summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.clang-format27
-rw-r--r--.dir-locals.el20
-rw-r--r--.gitignore10
-rw-r--r--.gitlab-ci.yml34
-rw-r--r--CONTRIBUTE5
-rw-r--r--ChangeLog.26
-rw-r--r--ChangeLog.3176
-rw-r--r--INSTALL6
-rw-r--r--Makefile.in34
-rw-r--r--README2
-rw-r--r--admin/CPP-DEFINES3
-rw-r--r--admin/MAINTAINERS10
-rw-r--r--admin/admin.el4
-rwxr-xr-xadmin/automerge259
-rw-r--r--admin/bzrmerge.el359
-rw-r--r--admin/find-gc.el2
-rw-r--r--admin/gitmerge.el160
-rw-r--r--admin/grammars/make.by19
-rw-r--r--admin/grammars/scheme.by5
-rw-r--r--admin/make-tarball.txt9
-rwxr-xr-xadmin/merge-gnulib17
-rw-r--r--admin/notes/bugtracker26
-rw-r--r--admin/notes/copyright3
-rw-r--r--admin/notes/git-workflow24
-rw-r--r--admin/notes/hydra4
-rw-r--r--admin/notes/multi-tty6
-rw-r--r--admin/notes/spelling11
-rw-r--r--admin/notes/unicode57
-rw-r--r--admin/nt/dist-build/README-windows-binaries6
-rwxr-xr-xadmin/nt/dist-build/build-dep-zips.py30
-rwxr-xr-xadmin/nt/dist-build/build-zips.sh127
-rw-r--r--admin/nt/dist-build/emacs.nsi88
-rw-r--r--admin/release-process6
-rw-r--r--admin/unidata/BidiBrackets.txt4
-rw-r--r--admin/unidata/BidiMirroring.txt6
-rw-r--r--admin/unidata/Blocks.txt15
-rw-r--r--admin/unidata/NormalizationTest.txt33
-rw-r--r--admin/unidata/SpecialCasing.txt6
-rw-r--r--admin/unidata/UnicodeData.txt564
-rwxr-xr-xadmin/unidata/blocks.awk5
-rw-r--r--admin/unidata/copyright.html208
-rw-r--r--admin/unidata/unidata-gen.el12
-rw-r--r--admin/unidata/uvs.el5
-rwxr-xr-xadmin/update_autogen2
-rwxr-xr-xautogen.sh11
-rwxr-xr-xbuild-aux/config.guess711
-rwxr-xr-xbuild-aux/config.sub2511
-rwxr-xr-xbuild-aux/gitlog-to-changelog4
-rwxr-xr-xbuild-aux/install-sh27
-rwxr-xr-xbuild-aux/move-if-change7
-rwxr-xr-xbuild-aux/update-copyright4
-rw-r--r--configure.ac659
-rw-r--r--doc/emacs/ChangeLog.12
-rw-r--r--doc/emacs/Makefile.in4
-rw-r--r--doc/emacs/building.texi42
-rw-r--r--doc/emacs/cmdargs.texi32
-rw-r--r--doc/emacs/custom.texi86
-rw-r--r--doc/emacs/dired.texi16
-rw-r--r--doc/emacs/display.texi6
-rw-r--r--doc/emacs/emacs.texi5
-rw-r--r--doc/emacs/files.texi70
-rw-r--r--doc/emacs/fixit.texi23
-rw-r--r--doc/emacs/frames.texi10
-rw-r--r--doc/emacs/help.texi10
-rw-r--r--doc/emacs/indent.texi4
-rw-r--r--doc/emacs/macos.texi21
-rw-r--r--doc/emacs/maintaining.texi62
-rw-r--r--doc/emacs/mini.texi20
-rw-r--r--doc/emacs/misc.texi113
-rw-r--r--doc/emacs/msdos.texi7
-rw-r--r--doc/emacs/mule.texi2
-rw-r--r--doc/emacs/package.texi82
-rw-r--r--doc/emacs/programs.texi60
-rw-r--r--doc/emacs/regs.texi4
-rw-r--r--doc/emacs/rmail.texi35
-rw-r--r--doc/emacs/search.texi52
-rw-r--r--doc/emacs/sending.texi22
-rw-r--r--doc/emacs/text.texi24
-rw-r--r--doc/emacs/windows.texi21
-rw-r--r--doc/lispintro/Makefile.in4
-rw-r--r--doc/lispintro/emacs-lisp-intro.texi25
-rw-r--r--doc/lispref/Makefile.in4
-rw-r--r--doc/lispref/abbrevs.texi3
-rw-r--r--doc/lispref/buffers.texi15
-rw-r--r--doc/lispref/commands.texi8
-rw-r--r--doc/lispref/control.texi14
-rw-r--r--doc/lispref/debugging.texi119
-rw-r--r--doc/lispref/display.texi153
-rw-r--r--doc/lispref/edebug.texi44
-rw-r--r--doc/lispref/elisp.texi6
-rw-r--r--doc/lispref/errors.texi8
-rw-r--r--doc/lispref/eval.texi129
-rw-r--r--doc/lispref/files.texi94
-rw-r--r--doc/lispref/frames.texi148
-rw-r--r--doc/lispref/functions.texi29
-rw-r--r--doc/lispref/hash.texi4
-rw-r--r--doc/lispref/hooks.texi2
-rw-r--r--doc/lispref/internals.texi180
-rw-r--r--doc/lispref/intro.texi14
-rw-r--r--doc/lispref/keymaps.texi4
-rw-r--r--doc/lispref/lists.texi45
-rw-r--r--doc/lispref/loading.texi2
-rw-r--r--doc/lispref/minibuf.texi29
-rw-r--r--doc/lispref/modes.texi55
-rw-r--r--doc/lispref/nonascii.texi20
-rw-r--r--doc/lispref/numbers.texi499
-rw-r--r--doc/lispref/objects.texi37
-rw-r--r--doc/lispref/os.texi242
-rw-r--r--doc/lispref/package.texi69
-rw-r--r--doc/lispref/processes.texi239
-rw-r--r--doc/lispref/searching.texi110
-rw-r--r--doc/lispref/sequences.texi22
-rw-r--r--doc/lispref/streams.texi15
-rw-r--r--doc/lispref/strings.texi67
-rw-r--r--doc/lispref/syntax.texi8
-rw-r--r--doc/lispref/text.texi572
-rw-r--r--doc/lispref/threads.texi68
-rw-r--r--doc/lispref/variables.texi17
-rw-r--r--doc/lispref/windows.texi454
-rw-r--r--doc/man/emacsclient.11
-rw-r--r--doc/man/etags.12
-rw-r--r--doc/misc/Makefile.in8
-rw-r--r--doc/misc/auth.texi65
-rw-r--r--doc/misc/calc.texi6
-rw-r--r--doc/misc/cc-mode.texi125
-rw-r--r--doc/misc/cl.texi12
-rw-r--r--doc/misc/dired-x.texi72
-rw-r--r--doc/misc/ede.texi6
-rw-r--r--doc/misc/ediff.texi2
-rw-r--r--doc/misc/efaq.texi91
-rw-r--r--doc/misc/emacs-gnutls.texi38
-rw-r--r--doc/misc/emacs-mime.texi100
-rw-r--r--doc/misc/ert.texi22
-rw-r--r--doc/misc/eshell.texi17
-rw-r--r--doc/misc/eww.texi21
-rw-r--r--doc/misc/flymake.texi202
-rw-r--r--doc/misc/gnus-coding.texi155
-rw-r--r--doc/misc/gnus-faq.texi18
-rw-r--r--doc/misc/gnus-news.el115
-rw-r--r--doc/misc/gnus-news.texi371
-rw-r--r--doc/misc/gnus-overrides.texi0
-rw-r--r--doc/misc/gnus.texi430
-rw-r--r--doc/misc/message.texi102
-rw-r--r--doc/misc/mh-e.texi11
-rw-r--r--doc/misc/org.texi10
-rw-r--r--doc/misc/pgg.texi2
-rw-r--r--doc/misc/sasl.texi2
-rw-r--r--doc/misc/sieve.texi2
-rw-r--r--doc/misc/texinfo.tex950
-rw-r--r--doc/misc/tramp.texi959
-rw-r--r--doc/misc/trampver.texi24
-rw-r--r--doc/misc/url.texi21
-rw-r--r--etc/CALC-NEWS11
-rw-r--r--etc/CENSORSHIP8
-rw-r--r--etc/DEBUG11
-rw-r--r--etc/FTP9
-rw-r--r--etc/GNU8
-rw-r--r--etc/GNUS-NEWS316
-rw-r--r--etc/HELLO166
-rw-r--r--etc/LINUX-GNU8
-rw-r--r--etc/MORE.STUFF8
-rw-r--r--etc/NEWS3425
-rw-r--r--etc/NEWS.1-17622
-rw-r--r--etc/NEWS.18396
-rw-r--r--etc/NEWS.196
-rw-r--r--etc/NEWS.202
-rw-r--r--etc/NEWS.261929
-rw-r--r--etc/ORDERS8
-rw-r--r--etc/PROBLEMS29
-rw-r--r--etc/THE-GNU-PROJECT8
-rw-r--r--etc/WHY-FREE8
-rw-r--r--etc/emacs-buffer.gdb22
-rw-r--r--etc/emacs.service2
-rw-r--r--etc/enriched.txt22
-rw-r--r--etc/images/icons/hicolor/scalable/apps/emacs.icobin0 -> 85182 bytes
-rw-r--r--etc/images/splash.bmpbin0 -> 154542 bytes
-rw-r--r--etc/refcards/Makefile2
-rw-r--r--etc/refcards/cs-survival.tex2
-rw-r--r--etc/refcards/fr-survival.tex2
-rw-r--r--etc/refcards/ru-refcard.tex2
-rw-r--r--etc/refcards/sk-survival.tex2
-rw-r--r--etc/refcards/survival.tex2
-rw-r--r--etc/themes/adwaita-theme.el4
-rw-r--r--etc/themes/deeper-blue-theme.el4
-rw-r--r--etc/themes/dichromacy-theme.el4
-rw-r--r--etc/themes/leuven-theme.el1
-rw-r--r--etc/themes/light-blue-theme.el4
-rw-r--r--etc/themes/manoj-dark-theme.el4
-rw-r--r--etc/themes/misterioso-theme.el4
-rw-r--r--etc/themes/tango-dark-theme.el4
-rw-r--r--etc/themes/tango-theme.el4
-rw-r--r--etc/themes/tsdh-dark-theme.el4
-rw-r--r--etc/themes/tsdh-light-theme.el5
-rw-r--r--etc/themes/wheatgrass-theme.el4
-rw-r--r--etc/themes/whiteboard-theme.el4
-rw-r--r--etc/themes/wombat-theme.el4
-rw-r--r--leim/Makefile.in6
-rw-r--r--lib-src/Makefile.in23
-rw-r--r--lib-src/ebrowse.c70
-rw-r--r--lib-src/emacsclient.c1294
-rw-r--r--lib-src/etags.c8
-rw-r--r--lib-src/make-docfile.c102
-rw-r--r--lib-src/make-fingerprint.c113
-rw-r--r--lib-src/movemail.c2
-rw-r--r--lib-src/ntlib.c67
-rw-r--r--lib-src/profile.c7
-rw-r--r--lib/Makefile.in10
-rw-r--r--lib/_Noreturn.h15
-rw-r--r--lib/acl-internal.c14
-rw-r--r--lib/acl-internal.h22
-rw-r--r--lib/acl_entries.c6
-rw-r--r--lib/alloca.in.h10
-rw-r--r--lib/binary-io.h9
-rw-r--r--lib/c-ctype.h3
-rw-r--r--lib/c-strcasecmp.c3
-rw-r--r--lib/c-strncasecmp.c3
-rw-r--r--lib/careadlinkat.c4
-rw-r--r--lib/cdefs.h514
-rw-r--r--lib/cloexec.c3
-rw-r--r--lib/close-stream.c3
-rw-r--r--lib/diffseq.h4
-rw-r--r--lib/dosname.h8
-rw-r--r--lib/dtotimespec.c10
-rw-r--r--lib/dup2.c5
-rw-r--r--lib/errno.in.h4
-rw-r--r--lib/euidaccess.c11
-rw-r--r--lib/explicit_bzero.c4
-rw-r--r--lib/fcntl.c556
-rw-r--r--lib/fcntl.in.h2
-rw-r--r--lib/fdatasync.c27
-rw-r--r--lib/filemode.h4
-rw-r--r--lib/fpending.c10
-rw-r--r--lib/fpending.h4
-rw-r--r--lib/fstatat.c6
-rw-r--r--lib/fsusage.c237
-rw-r--r--lib/fsusage.h40
-rw-r--r--lib/fsync.c2
-rw-r--r--lib/ftoastr.c6
-rw-r--r--lib/get-permissions.c98
-rw-r--r--lib/getdtablesize.c2
-rw-r--r--lib/getgroups.c7
-rw-r--r--lib/getloadavg.c131
-rw-r--r--lib/getopt.c2
-rw-r--r--lib/gettext.h17
-rw-r--r--lib/gettime.c32
-rw-r--r--lib/gettimeofday.c17
-rw-r--r--lib/gnulib.mk.in286
-rw-r--r--lib/group-member.c4
-rw-r--r--lib/ieee754.in.h222
-rw-r--r--lib/intprops.h16
-rw-r--r--lib/inttypes.in.h6
-rw-r--r--lib/libc-config.h174
-rw-r--r--lib/limits.in.h44
-rw-r--r--lib/localtime-buffer.c5
-rw-r--r--lib/localtime-buffer.h3
-rw-r--r--lib/lstat.c6
-rw-r--r--lib/md5.c37
-rw-r--r--lib/md5.h11
-rw-r--r--lib/memrchr.c6
-rw-r--r--lib/mktime-internal.h16
-rw-r--r--lib/mktime.c507
-rw-r--r--lib/nstrftime.c143
-rw-r--r--lib/open.c2
-rw-r--r--lib/pipe2.c7
-rw-r--r--lib/pselect.c4
-rw-r--r--lib/putenv.c4
-rw-r--r--lib/regcomp.c3934
-rw-r--r--lib/regex.c81
-rw-r--r--lib/regex.h658
-rw-r--r--lib/regex_internal.c1746
-rw-r--r--lib/regex_internal.h874
-rw-r--r--lib/regexec.c4336
-rw-r--r--lib/set-permissions.c268
-rw-r--r--lib/sha1.c38
-rw-r--r--lib/sha1.h7
-rw-r--r--lib/sha256.c137
-rw-r--r--lib/sha256.h7
-rw-r--r--lib/sha512.c132
-rw-r--r--lib/sha512.h7
-rw-r--r--lib/sig2str.c3
-rw-r--r--lib/stat-time.h12
-rw-r--r--lib/stdio-impl.h73
-rw-r--r--lib/stdio.in.h11
-rw-r--r--lib/stdlib.in.h106
-rw-r--r--lib/strtoimax.c4
-rw-r--r--lib/strtol.c33
-rw-r--r--lib/strtoll.c4
-rw-r--r--lib/sys_stat.in.h15
-rw-r--r--lib/sys_types.in.h15
-rw-r--r--lib/tempname.c3
-rw-r--r--lib/time.in.h4
-rw-r--r--lib/time_r.c3
-rw-r--r--lib/time_rz.c15
-rw-r--r--lib/timegm.c32
-rw-r--r--lib/timespec-add.c6
-rw-r--r--lib/timespec-sub.c6
-rw-r--r--lib/timespec.h30
-rw-r--r--lib/unistd.in.h62
-rw-r--r--lib/utimens.c15
-rw-r--r--lib/verify.h9
-rw-r--r--lib/vla.h26
-rw-r--r--lib/warn-on-use.h64
-rw-r--r--lib/xalloc-oversized.h3
-rw-r--r--lisp/ChangeLog.24
-rw-r--r--lisp/ChangeLog.42
-rw-r--r--lisp/ChangeLog.52
-rw-r--r--lisp/ChangeLog.72
-rw-r--r--lisp/Makefile.in35
-rw-r--r--lisp/abbrev.el87
-rw-r--r--lisp/align.el8
-rw-r--r--lisp/allout-widgets.el6
-rw-r--r--lisp/allout.el53
-rw-r--r--lisp/ansi-color.el3
-rw-r--r--lisp/apropos.el10
-rw-r--r--lisp/arc-mode.el118
-rw-r--r--lisp/auth-source-pass.el97
-rw-r--r--lisp/auth-source.el363
-rw-r--r--lisp/autoarg.el6
-rw-r--r--lisp/autoinsert.el13
-rw-r--r--lisp/autorevert.el166
-rw-r--r--lisp/avoid.el12
-rw-r--r--lisp/battery.el119
-rw-r--r--lisp/bindings.el81
-rw-r--r--lisp/bookmark.el22
-rw-r--r--lisp/bs.el4
-rw-r--r--lisp/button.el10
-rw-r--r--lisp/calc/calc-alg.el932
-rw-r--r--lisp/calc/calc-bin.el6
-rw-r--r--lisp/calc/calc-comb.el6
-rw-r--r--lisp/calc/calc-ext.el97
-rw-r--r--lisp/calc/calc-forms.el27
-rw-r--r--lisp/calc/calc-graph.el4
-rw-r--r--lisp/calc/calc-help.el2
-rw-r--r--lisp/calc/calc-lang.el6
-rw-r--r--lisp/calc/calc-math.el2
-rw-r--r--lisp/calc/calc-poly.el122
-rw-r--r--lisp/calc/calc-store.el4
-rw-r--r--lisp/calc/calc-units.el222
-rw-r--r--lisp/calc/calc.el165
-rw-r--r--lisp/calc/calccomp.el51
-rw-r--r--lisp/calculator.el4
-rw-r--r--lisp/calendar/appt.el44
-rw-r--r--lisp/calendar/cal-dst.el163
-rw-r--r--lisp/calendar/cal-tex.el2
-rw-r--r--lisp/calendar/calendar.el147
-rw-r--r--lisp/calendar/diary-lib.el550
-rw-r--r--lisp/calendar/holidays.el66
-rw-r--r--lisp/calendar/icalendar.el114
-rw-r--r--lisp/calendar/parse-time.el21
-rw-r--r--lisp/calendar/solar.el21
-rw-r--r--lisp/calendar/time-date.el23
-rw-r--r--lisp/calendar/timeclock.el418
-rw-r--r--lisp/calendar/todo-mode.el712
-rw-r--r--lisp/cedet/cedet.el3
-rw-r--r--lisp/cedet/data-debug.el6
-rw-r--r--lisp/cedet/ede.el7
-rw-r--r--lisp/cedet/ede/detect.el5
-rw-r--r--lisp/cedet/ede/dired.el9
-rw-r--r--lisp/cedet/ede/files.el2
-rw-r--r--lisp/cedet/ede/linux.el9
-rw-r--r--lisp/cedet/ede/makefile-edit.el2
-rw-r--r--lisp/cedet/ede/pconf.el4
-rw-r--r--lisp/cedet/ede/pmake.el1
-rw-r--r--lisp/cedet/ede/proj-archive.el1
-rw-r--r--lisp/cedet/ede/proj-aux.el3
-rw-r--r--lisp/cedet/ede/proj-comp.el1
-rw-r--r--lisp/cedet/ede/proj-elisp.el10
-rw-r--r--lisp/cedet/ede/proj-info.el5
-rw-r--r--lisp/cedet/ede/proj-misc.el7
-rw-r--r--lisp/cedet/ede/proj-obj.el32
-rw-r--r--lisp/cedet/ede/proj-prog.el1
-rw-r--r--lisp/cedet/ede/proj-shared.el2
-rw-r--r--lisp/cedet/ede/simple.el2
-rw-r--r--lisp/cedet/ede/source.el6
-rw-r--r--lisp/cedet/ede/speedbar.el3
-rw-r--r--lisp/cedet/mode-local.el2
-rw-r--r--lisp/cedet/pulse.el4
-rw-r--r--lisp/cedet/semantic.el24
-rw-r--r--lisp/cedet/semantic/analyze.el18
-rw-r--r--lisp/cedet/semantic/analyze/debug.el26
-rw-r--r--lisp/cedet/semantic/analyze/refs.el3
-rw-r--r--lisp/cedet/semantic/bovine.el2
-rw-r--r--lisp/cedet/semantic/bovine/c.el2
-rw-r--r--lisp/cedet/semantic/bovine/debug.el6
-rw-r--r--lisp/cedet/semantic/bovine/grammar.el9
-rw-r--r--lisp/cedet/semantic/complete.el25
-rw-r--r--lisp/cedet/semantic/db-file.el4
-rw-r--r--lisp/cedet/semantic/db-find.el6
-rw-r--r--lisp/cedet/semantic/db-javascript.el6
-rw-r--r--lisp/cedet/semantic/db-mode.el11
-rw-r--r--lisp/cedet/semantic/db-ref.el3
-rw-r--r--lisp/cedet/semantic/db.el8
-rw-r--r--lisp/cedet/semantic/debug.el2
-rw-r--r--lisp/cedet/semantic/decorate/mode.el24
-rw-r--r--lisp/cedet/semantic/dep.el4
-rw-r--r--lisp/cedet/semantic/ede-grammar.el10
-rw-r--r--lisp/cedet/semantic/grammar.el2
-rw-r--r--lisp/cedet/semantic/idle.el19
-rw-r--r--lisp/cedet/semantic/lex.el7
-rw-r--r--lisp/cedet/semantic/mru-bookmark.el12
-rw-r--r--lisp/cedet/semantic/sb.el10
-rw-r--r--lisp/cedet/semantic/scope.el6
-rw-r--r--lisp/cedet/semantic/symref/filter.el2
-rw-r--r--lisp/cedet/semantic/symref/grep.el10
-rw-r--r--lisp/cedet/semantic/symref/list.el7
-rw-r--r--lisp/cedet/semantic/texi.el3
-rw-r--r--lisp/cedet/semantic/util-modes.el52
-rw-r--r--lisp/cedet/semantic/util.el18
-rw-r--r--lisp/cedet/semantic/wisent/comp.el25
-rw-r--r--lisp/cedet/semantic/wisent/grammar.el2
-rw-r--r--lisp/cedet/semantic/wisent/python.el5
-rw-r--r--lisp/cedet/srecode/compile.el1
-rw-r--r--lisp/cedet/srecode/dictionary.el4
-rw-r--r--lisp/cedet/srecode/extract.el2
-rw-r--r--lisp/cedet/srecode/map.el11
-rw-r--r--lisp/cedet/srecode/mode.el25
-rw-r--r--lisp/cedet/srecode/srt-mode.el3
-rw-r--r--lisp/cedet/srecode/srt.el1
-rw-r--r--lisp/cedet/srecode/table.el4
-rw-r--r--lisp/char-fold.el4
-rw-r--r--lisp/chistory.el13
-rw-r--r--lisp/comint.el142
-rw-r--r--lisp/completion.el21
-rw-r--r--lisp/composite.el12
-rw-r--r--lisp/cus-edit.el85
-rw-r--r--lisp/cus-face.el2
-rw-r--r--lisp/cus-start.el46
-rw-r--r--lisp/cus-theme.el63
-rw-r--r--lisp/custom.el285
-rw-r--r--lisp/dabbrev.el4
-rw-r--r--lisp/delim-col.el4
-rw-r--r--lisp/delsel.el14
-rw-r--r--lisp/descr-text.el8
-rw-r--r--lisp/desktop.el110
-rw-r--r--lisp/dired-aux.el339
-rw-r--r--lisp/dired-x.el144
-rw-r--r--lisp/dired.el250
-rw-r--r--lisp/dirtrack.el8
-rw-r--r--lisp/disp-table.el18
-rw-r--r--lisp/dnd.el1
-rw-r--r--lisp/doc-view.el350
-rw-r--r--lisp/dom.el24
-rw-r--r--lisp/dos-fns.el6
-rw-r--r--lisp/dos-w32.el2
-rw-r--r--lisp/double.el3
-rw-r--r--lisp/ecomplete.el103
-rw-r--r--lisp/edmacro.el14
-rw-r--r--lisp/elec-pair.el87
-rw-r--r--lisp/electric.el260
-rw-r--r--lisp/elide-head.el2
-rw-r--r--lisp/emacs-lisp/advice.el120
-rw-r--r--lisp/emacs-lisp/autoload.el73
-rw-r--r--lisp/emacs-lisp/backtrace.el918
-rw-r--r--lisp/emacs-lisp/benchmark.el20
-rw-r--r--lisp/emacs-lisp/bindat.el28
-rw-r--r--lisp/emacs-lisp/byte-opt.el391
-rw-r--r--lisp/emacs-lisp/byte-run.el9
-rw-r--r--lisp/emacs-lisp/bytecomp.el188
-rw-r--r--lisp/emacs-lisp/cconv.el84
-rw-r--r--lisp/emacs-lisp/chart.el2
-rw-r--r--lisp/emacs-lisp/checkdoc.el151
-rw-r--r--lisp/emacs-lisp/cl-extra.el22
-rw-r--r--lisp/emacs-lisp/cl-generic.el54
-rw-r--r--lisp/emacs-lisp/cl-lib.el12
-rw-r--r--lisp/emacs-lisp/cl-macs.el301
-rw-r--r--lisp/emacs-lisp/cl-preloaded.el38
-rw-r--r--lisp/emacs-lisp/cl-print.el314
-rw-r--r--lisp/emacs-lisp/cl-seq.el7
-rw-r--r--lisp/emacs-lisp/copyright.el5
-rw-r--r--lisp/emacs-lisp/crm.el3
-rw-r--r--lisp/emacs-lisp/cursor-sensor.el4
-rw-r--r--lisp/emacs-lisp/debug.el550
-rw-r--r--lisp/emacs-lisp/derived.el31
-rw-r--r--lisp/emacs-lisp/easy-mmode.el119
-rw-r--r--lisp/emacs-lisp/easymenu.el28
-rw-r--r--lisp/emacs-lisp/edebug.el453
-rw-r--r--lisp/emacs-lisp/eieio-base.el2
-rw-r--r--lisp/emacs-lisp/eieio-compat.el4
-rw-r--r--lisp/emacs-lisp/eieio-core.el6
-rw-r--r--lisp/emacs-lisp/eieio-opt.el2
-rw-r--r--lisp/emacs-lisp/eieio-speedbar.el2
-rw-r--r--lisp/emacs-lisp/eieio.el67
-rw-r--r--lisp/emacs-lisp/eldoc.el18
-rw-r--r--lisp/emacs-lisp/elint.el18
-rw-r--r--lisp/emacs-lisp/elp.el7
-rw-r--r--lisp/emacs-lisp/ert.el172
-rw-r--r--lisp/emacs-lisp/ewoc.el2
-rw-r--r--lisp/emacs-lisp/faceup.el1180
-rw-r--r--lisp/emacs-lisp/find-func.el47
-rw-r--r--lisp/emacs-lisp/generator.el46
-rw-r--r--lisp/emacs-lisp/generic.el2
-rw-r--r--lisp/emacs-lisp/gv.el7
-rw-r--r--lisp/emacs-lisp/inline.el2
-rw-r--r--lisp/emacs-lisp/lisp-mnt.el36
-rw-r--r--lisp/emacs-lisp/lisp-mode.el37
-rw-r--r--lisp/emacs-lisp/lisp.el30
-rw-r--r--lisp/emacs-lisp/macroexp.el14
-rw-r--r--lisp/emacs-lisp/map-ynp.el38
-rw-r--r--lisp/emacs-lisp/map.el358
-rw-r--r--lisp/emacs-lisp/nadvice.el13
-rw-r--r--lisp/emacs-lisp/package-x.el4
-rw-r--r--lisp/emacs-lisp/package.el607
-rw-r--r--lisp/emacs-lisp/pcase.el21
-rw-r--r--lisp/emacs-lisp/radix-tree.el4
-rw-r--r--lisp/emacs-lisp/regexp-opt.el51
-rw-r--r--lisp/emacs-lisp/ring.el33
-rw-r--r--lisp/emacs-lisp/rx.el144
-rw-r--r--lisp/emacs-lisp/seq.el34
-rw-r--r--lisp/emacs-lisp/shadow.el6
-rw-r--r--lisp/emacs-lisp/smie.el14
-rw-r--r--lisp/emacs-lisp/subr-x.el45
-rw-r--r--lisp/emacs-lisp/syntax.el41
-rw-r--r--lisp/emacs-lisp/tabulated-list.el71
-rw-r--r--lisp/emacs-lisp/tcover-ses.el762
-rw-r--r--lisp/emacs-lisp/testcover.el711
-rw-r--r--lisp/emacs-lisp/text-property-search.el206
-rw-r--r--lisp/emacs-lisp/thunk.el68
-rw-r--r--lisp/emacs-lisp/timer-list.el16
-rw-r--r--lisp/emacs-lisp/timer.el72
-rw-r--r--lisp/emacs-lisp/unsafep.el2
-rw-r--r--lisp/emacs-lisp/warnings.el14
-rw-r--r--lisp/emacs-lock.el10
-rw-r--r--lisp/emulation/cua-base.el41
-rw-r--r--lisp/emulation/viper-cmd.el39
-rw-r--r--lisp/emulation/viper-ex.el30
-rw-r--r--lisp/emulation/viper-init.el1
-rw-r--r--lisp/emulation/viper-keym.el8
-rw-r--r--lisp/emulation/viper-macs.el13
-rw-r--r--lisp/emulation/viper-util.el68
-rw-r--r--lisp/emulation/viper.el111
-rw-r--r--lisp/env.el6
-rw-r--r--lisp/epa-file.el2
-rw-r--r--lisp/epa-hook.el5
-rw-r--r--lisp/epa-mail.el18
-rw-r--r--lisp/epa.el71
-rw-r--r--lisp/epg-config.el56
-rw-r--r--lisp/epg.el145
-rw-r--r--lisp/erc/erc-autoaway.el3
-rw-r--r--lisp/erc/erc-backend.el70
-rw-r--r--lisp/erc/erc-button.el13
-rw-r--r--lisp/erc/erc-capab.el6
-rw-r--r--lisp/erc/erc-compat.el3
-rw-r--r--lisp/erc/erc-dcc.el55
-rw-r--r--lisp/erc/erc-desktop-notifications.el26
-rw-r--r--lisp/erc/erc-ezbounce.el4
-rw-r--r--lisp/erc/erc-fill.el3
-rw-r--r--lisp/erc/erc-identd.el3
-rw-r--r--lisp/erc/erc-imenu.el1
-rw-r--r--lisp/erc/erc-join.el3
-rw-r--r--lisp/erc/erc-list.el3
-rw-r--r--lisp/erc/erc-log.el30
-rw-r--r--lisp/erc/erc-match.el5
-rw-r--r--lisp/erc/erc-menu.el3
-rw-r--r--lisp/erc/erc-netsplit.el3
-rw-r--r--lisp/erc/erc-notify.el3
-rw-r--r--lisp/erc/erc-page.el3
-rw-r--r--lisp/erc/erc-pcomplete.el3
-rw-r--r--lisp/erc/erc-replace.el3
-rw-r--r--lisp/erc/erc-ring.el3
-rw-r--r--lisp/erc/erc-services.el66
-rw-r--r--lisp/erc/erc-sound.el3
-rw-r--r--lisp/erc/erc-speedbar.el7
-rw-r--r--lisp/erc/erc-spelling.el6
-rw-r--r--lisp/erc/erc-stamp.el3
-rw-r--r--lisp/erc/erc-track.el27
-rw-r--r--lisp/erc/erc-truncate.el3
-rw-r--r--lisp/erc/erc-xdcc.el3
-rw-r--r--lisp/erc/erc.el181
-rw-r--r--lisp/eshell/em-alias.el8
-rw-r--r--lisp/eshell/em-banner.el2
-rw-r--r--lisp/eshell/em-basic.el2
-rw-r--r--lisp/eshell/em-cmpl.el47
-rw-r--r--lisp/eshell/em-dirs.el139
-rw-r--r--lisp/eshell/em-glob.el2
-rw-r--r--lisp/eshell/em-hist.el94
-rw-r--r--lisp/eshell/em-ls.el43
-rw-r--r--lisp/eshell/em-pred.el42
-rw-r--r--lisp/eshell/em-prompt.el3
-rw-r--r--lisp/eshell/em-rebind.el2
-rw-r--r--lisp/eshell/em-script.el12
-rw-r--r--lisp/eshell/em-smart.el2
-rw-r--r--lisp/eshell/em-term.el6
-rw-r--r--lisp/eshell/em-tramp.el8
-rw-r--r--lisp/eshell/em-unix.el81
-rw-r--r--lisp/eshell/em-xtra.el8
-rw-r--r--lisp/eshell/esh-arg.el96
-rw-r--r--lisp/eshell/esh-cmd.el100
-rw-r--r--lisp/eshell/esh-ext.el24
-rw-r--r--lisp/eshell/esh-io.el5
-rw-r--r--lisp/eshell/esh-mode.el41
-rw-r--r--lisp/eshell/esh-module.el4
-rw-r--r--lisp/eshell/esh-opt.el50
-rw-r--r--lisp/eshell/esh-proc.el74
-rw-r--r--lisp/eshell/esh-util.el43
-rw-r--r--lisp/eshell/esh-var.el133
-rw-r--r--lisp/eshell/eshell.el21
-rw-r--r--lisp/face-remap.el10
-rw-r--r--lisp/facemenu.el28
-rw-r--r--lisp/faces.el42
-rw-r--r--lisp/ffap.el1
-rw-r--r--lisp/filecache.el218
-rw-r--r--lisp/fileloop.el217
-rw-r--r--lisp/filenotify.el46
-rw-r--r--lisp/files-x.el95
-rw-r--r--lisp/files.el601
-rw-r--r--lisp/filesets.el15
-rw-r--r--lisp/find-dired.el6
-rw-r--r--lisp/find-lisp.el35
-rw-r--r--lisp/foldout.el4
-rw-r--r--lisp/follow.el75
-rw-r--r--lisp/font-core.el3
-rw-r--r--lisp/font-lock.el33
-rw-r--r--lisp/format-spec.el2
-rw-r--r--lisp/format.el18
-rw-r--r--lisp/frame.el390
-rw-r--r--lisp/frameset.el39
-rw-r--r--lisp/fringe.el20
-rw-r--r--lisp/generic-x.el32
-rw-r--r--lisp/gnus/canlock.el3
-rw-r--r--lisp/gnus/deuglify.el8
-rw-r--r--lisp/gnus/gnus-agent.el486
-rw-r--r--lisp/gnus/gnus-art.el127
-rw-r--r--lisp/gnus/gnus-async.el35
-rw-r--r--lisp/gnus/gnus-bcklg.el116
-rw-r--r--lisp/gnus/gnus-cache.el75
-rw-r--r--lisp/gnus/gnus-cite.el57
-rw-r--r--lisp/gnus/gnus-cloud.el12
-rw-r--r--lisp/gnus/gnus-cus.el2
-rw-r--r--lisp/gnus/gnus-delay.el26
-rw-r--r--lisp/gnus/gnus-demon.el16
-rw-r--r--lisp/gnus/gnus-diary.el45
-rw-r--r--lisp/gnus/gnus-draft.el1
-rw-r--r--lisp/gnus/gnus-dup.el58
-rw-r--r--lisp/gnus/gnus-fun.el3
-rw-r--r--lisp/gnus/gnus-group.el545
-rw-r--r--lisp/gnus/gnus-html.el8
-rw-r--r--lisp/gnus/gnus-icalendar.el84
-rw-r--r--lisp/gnus/gnus-int.el5
-rw-r--r--lisp/gnus/gnus-kill.el7
-rw-r--r--lisp/gnus/gnus-logic.el8
-rw-r--r--lisp/gnus/gnus-ml.el1
-rw-r--r--lisp/gnus/gnus-mlspl.el26
-rw-r--r--lisp/gnus/gnus-msg.el45
-rw-r--r--lisp/gnus/gnus-picon.el4
-rw-r--r--lisp/gnus/gnus-range.el16
-rw-r--r--lisp/gnus/gnus-registry.el62
-rw-r--r--lisp/gnus/gnus-salt.el21
-rw-r--r--lisp/gnus/gnus-score.el72
-rw-r--r--lisp/gnus/gnus-spec.el14
-rw-r--r--lisp/gnus/gnus-srvr.el131
-rw-r--r--lisp/gnus/gnus-start.el676
-rw-r--r--lisp/gnus/gnus-sum.el670
-rw-r--r--lisp/gnus/gnus-topic.el72
-rw-r--r--lisp/gnus/gnus-undo.el2
-rw-r--r--lisp/gnus/gnus-util.el134
-rw-r--r--lisp/gnus/gnus-uu.el6
-rw-r--r--lisp/gnus/gnus-vm.el10
-rw-r--r--lisp/gnus/gnus-win.el8
-rw-r--r--lisp/gnus/gnus.el543
-rw-r--r--lisp/gnus/mail-source.el24
-rw-r--r--lisp/gnus/message.el404
-rw-r--r--lisp/gnus/mm-bodies.el4
-rw-r--r--lisp/gnus/mm-decode.el199
-rw-r--r--lisp/gnus/mm-encode.el4
-rw-r--r--lisp/gnus/mm-extern.el21
-rw-r--r--lisp/gnus/mm-partial.el2
-rw-r--r--lisp/gnus/mm-url.el4
-rw-r--r--lisp/gnus/mm-util.el98
-rw-r--r--lisp/gnus/mm-uu.el1
-rw-r--r--lisp/gnus/mm-view.el50
-rw-r--r--lisp/gnus/mml-sec.el11
-rw-r--r--lisp/gnus/mml-smime.el4
-rw-r--r--lisp/gnus/mml.el19
-rw-r--r--lisp/gnus/mml1991.el6
-rw-r--r--lisp/gnus/mml2015.el6
-rw-r--r--lisp/gnus/nnagent.el1
-rw-r--r--lisp/gnus/nnbabyl.el10
-rw-r--r--lisp/gnus/nndiary.el29
-rw-r--r--lisp/gnus/nndir.el3
-rw-r--r--lisp/gnus/nndoc.el26
-rw-r--r--lisp/gnus/nndraft.el1
-rw-r--r--lisp/gnus/nneething.el25
-rw-r--r--lisp/gnus/nnfolder.el27
-rw-r--r--lisp/gnus/nngateway.el1
-rw-r--r--lisp/gnus/nnheader.el38
-rw-r--r--lisp/gnus/nnimap.el172
-rw-r--r--lisp/gnus/nnir.el191
-rw-r--r--lisp/gnus/nnmail.el51
-rw-r--r--lisp/gnus/nnmaildir.el349
-rw-r--r--lisp/gnus/nnmairix.el4
-rw-r--r--lisp/gnus/nnmbox.el1
-rw-r--r--lisp/gnus/nnmh.el30
-rw-r--r--lisp/gnus/nnml.el20
-rw-r--r--lisp/gnus/nnoo.el4
-rw-r--r--lisp/gnus/nnrss.el34
-rw-r--r--lisp/gnus/nnspool.el33
-rw-r--r--lisp/gnus/nntp.el90
-rw-r--r--lisp/gnus/nnvirtual.el22
-rw-r--r--lisp/gnus/nnweb.el26
-rw-r--r--lisp/gnus/score-mode.el3
-rw-r--r--lisp/gnus/smiley.el1
-rw-r--r--lisp/gnus/smime.el4
-rw-r--r--lisp/gnus/spam-stat.el21
-rw-r--r--lisp/gnus/spam.el124
-rw-r--r--lisp/help-fns.el31
-rw-r--r--lisp/help-mode.el55
-rw-r--r--lisp/help.el430
-rw-r--r--lisp/hexl.el165
-rw-r--r--lisp/hfy-cmap.el37
-rw-r--r--lisp/hi-lock.el56
-rw-r--r--lisp/hilit-chg.el9
-rw-r--r--lisp/hl-line.el6
-rw-r--r--lisp/htmlfontify.el55
-rw-r--r--lisp/ibuf-ext.el88
-rw-r--r--lisp/ibuf-macs.el61
-rw-r--r--lisp/ibuffer.el37
-rw-r--r--lisp/icomplete.el45
-rw-r--r--lisp/ido.el127
-rw-r--r--lisp/ielm.el46
-rw-r--r--lisp/image-dired.el12
-rw-r--r--lisp/image-file.el3
-rw-r--r--lisp/image-mode.el65
-rw-r--r--lisp/image.el34
-rw-r--r--lisp/image/gravatar.el6
-rw-r--r--lisp/imenu.el24
-rw-r--r--lisp/indent.el22
-rw-r--r--lisp/info-look.el3
-rw-r--r--lisp/info-xref.el2
-rw-r--r--lisp/info.el42
-rw-r--r--lisp/international/ccl.el22
-rw-r--r--lisp/international/characters.el34
-rw-r--r--lisp/international/fontset.el36
-rw-r--r--lisp/international/iso-ascii.el5
-rw-r--r--lisp/international/ja-dic-cnv.el65
-rw-r--r--lisp/international/ja-dic-utl.el43
-rw-r--r--lisp/international/kinsoku.el36
-rw-r--r--lisp/international/kkc.el4
-rw-r--r--lisp/international/latin1-disp.el4
-rw-r--r--lisp/international/mule-cmds.el227
-rw-r--r--lisp/international/mule-conf.el71
-rw-r--r--lisp/international/mule-diag.el2
-rw-r--r--lisp/international/mule-util.el26
-rw-r--r--lisp/international/mule.el17
-rw-r--r--lisp/international/quail.el37
-rw-r--r--lisp/international/titdic-cnv.el323
-rw-r--r--lisp/international/ucs-normalize.el4
-rw-r--r--lisp/isearch.el1058
-rw-r--r--lisp/jit-lock.el1
-rw-r--r--lisp/jka-cmpr-hook.el3
-rw-r--r--lisp/json.el84
-rw-r--r--lisp/jsonrpc.el700
-rw-r--r--lisp/kmacro.el75
-rw-r--r--lisp/language/china-util.el2
-rw-r--r--lisp/language/cyrillic.el14
-rw-r--r--lisp/language/english.el8
-rw-r--r--lisp/language/ethio-util.el2
-rw-r--r--lisp/language/european.el8
-rw-r--r--lisp/language/georgian.el2
-rw-r--r--lisp/language/japan-util.el96
-rw-r--r--lisp/language/japanese.el4
-rw-r--r--lisp/language/thai-util.el9
-rw-r--r--lisp/language/tibetan.el2
-rw-r--r--lisp/language/utf-8-lang.el32
-rw-r--r--lisp/language/vietnamese.el4
-rw-r--r--lisp/ldefs-boot.el4551
-rw-r--r--lisp/leim/quail/cyril-jis.el204
-rw-r--r--lisp/leim/quail/hanja-jis.el984
-rw-r--r--lisp/leim/quail/japanese.el374
-rw-r--r--lisp/leim/quail/latin-post.el51
-rw-r--r--lisp/leim/quail/latin-pre.el81
-rw-r--r--lisp/leim/quail/py-punct.el14
-rw-r--r--lisp/leim/quail/pypunct-b5.el8
-rw-r--r--lisp/leim/quail/sami.el755
-rw-r--r--lisp/linum.el4
-rw-r--r--lisp/loadhist.el7
-rw-r--r--lisp/loadup.el180
-rw-r--r--lisp/locate.el18
-rw-r--r--lisp/lpr.el20
-rw-r--r--lisp/ls-lisp.el65
-rw-r--r--lisp/macros.el30
-rw-r--r--lisp/mail/binhex.el30
-rw-r--r--lisp/mail/blessmail.el6
-rw-r--r--lisp/mail/emacsbug.el100
-rw-r--r--lisp/mail/feedmail.el100
-rw-r--r--lisp/mail/flow-fill.el3
-rw-r--r--lisp/mail/footnote.el486
-rw-r--r--lisp/mail/hashcash.el20
-rw-r--r--lisp/mail/ietf-drums.el26
-rw-r--r--lisp/mail/mail-extr.el20
-rw-r--r--lisp/mail/mail-utils.el2
-rw-r--r--lisp/mail/mailabbrev.el15
-rw-r--r--lisp/mail/mailalias.el6
-rw-r--r--lisp/mail/mspools.el2
-rw-r--r--lisp/mail/rfc2047.el26
-rw-r--r--lisp/mail/rfc2231.el8
-rw-r--r--lisp/mail/rmail-spam-filter.el2
-rw-r--r--lisp/mail/rmail.el83
-rw-r--r--lisp/mail/rmailout.el70
-rw-r--r--lisp/mail/rmailsum.el26
-rw-r--r--lisp/mail/sendmail.el116
-rw-r--r--lisp/mail/smtpmail.el186
-rw-r--r--lisp/mail/supercite.el14
-rw-r--r--lisp/mail/uce.el2
-rw-r--r--lisp/mail/uudecode.el49
-rw-r--r--lisp/mail/yenc.el8
-rw-r--r--lisp/man.el24
-rw-r--r--lisp/master.el3
-rw-r--r--lisp/mb-depth.el3
-rw-r--r--lisp/md4.el28
-rw-r--r--lisp/menu-bar.el48
-rw-r--r--lisp/mh-e/mh-acros.el31
-rw-r--r--lisp/mh-e/mh-alias.el9
-rw-r--r--lisp/mh-e/mh-comp.el129
-rw-r--r--lisp/mh-e/mh-compat.el6
-rw-r--r--lisp/mh-e/mh-e.el7
-rw-r--r--lisp/mh-e/mh-folder.el2
-rw-r--r--lisp/mh-e/mh-funcs.el2
-rw-r--r--lisp/mh-e/mh-identity.el27
-rw-r--r--lisp/mh-e/mh-junk.el6
-rw-r--r--lisp/mh-e/mh-letter.el13
-rw-r--r--lisp/mh-e/mh-mime.el2
-rw-r--r--lisp/mh-e/mh-search.el10
-rw-r--r--lisp/mh-e/mh-show.el6
-rw-r--r--lisp/mh-e/mh-speed.el6
-rw-r--r--lisp/mh-e/mh-thread.el25
-rw-r--r--lisp/mh-e/mh-utils.el1
-rw-r--r--lisp/mh-e/mh-xface.el2
-rw-r--r--lisp/minibuf-eldef.el3
-rw-r--r--lisp/minibuffer.el327
-rw-r--r--lisp/mouse.el246
-rw-r--r--lisp/mpc.el45
-rw-r--r--lisp/msb.el3
-rw-r--r--lisp/mwheel.el24
-rw-r--r--lisp/net/ange-ftp.el82
-rw-r--r--lisp/net/browse-url.el15
-rw-r--r--lisp/net/dbus.el9
-rw-r--r--lisp/net/dns.el29
-rw-r--r--lisp/net/eudc-bob.el117
-rw-r--r--lisp/net/eudc-hotlist.el10
-rw-r--r--lisp/net/eudc.el190
-rw-r--r--lisp/net/eudcb-bbdb.el40
-rw-r--r--lisp/net/eudcb-mab.el6
-rw-r--r--lisp/net/eww.el112
-rw-r--r--lisp/net/gnutls.el69
-rw-r--r--lisp/net/goto-addr.el13
-rw-r--r--lisp/net/hmac-def.el2
-rw-r--r--lisp/net/imap.el190
-rw-r--r--lisp/net/ldap.el10
-rw-r--r--lisp/net/mailcap.el83
-rw-r--r--lisp/net/net-utils.el5
-rw-r--r--lisp/net/netrc.el6
-rw-r--r--lisp/net/network-stream.el32
-rw-r--r--lisp/net/newst-backend.el334
-rw-r--r--lisp/net/newst-plainview.el1
-rw-r--r--lisp/net/newst-treeview.el2
-rw-r--r--lisp/net/nsm.el158
-rw-r--r--lisp/net/ntlm.el213
-rw-r--r--lisp/net/pop3.el59
-rw-r--r--lisp/net/puny.el1
-rw-r--r--lisp/net/quickurl.el12
-rw-r--r--lisp/net/rcirc.el66
-rw-r--r--lisp/net/rfc2104.el10
-rw-r--r--lisp/net/rlogin.el8
-rw-r--r--lisp/net/sasl.el6
-rw-r--r--lisp/net/secrets.el195
-rw-r--r--lisp/net/shr-color.el11
-rw-r--r--lisp/net/shr.el236
-rw-r--r--lisp/net/sieve-manage.el39
-rw-r--r--lisp/net/sieve-mode.el31
-rw-r--r--lisp/net/sieve.el9
-rw-r--r--lisp/net/soap-client.el33
-rw-r--r--lisp/net/socks.el524
-rw-r--r--lisp/net/tramp-adb.el770
-rw-r--r--lisp/net/tramp-archive.el661
-rw-r--r--lisp/net/tramp-cache.el117
-rw-r--r--lisp/net/tramp-cmds.el90
-rw-r--r--lisp/net/tramp-compat.el138
-rw-r--r--lisp/net/tramp-ftp.el46
-rw-r--r--lisp/net/tramp-gvfs.el1090
-rw-r--r--lisp/net/tramp-integration.el199
-rw-r--r--lisp/net/tramp-rclone.el608
-rw-r--r--lisp/net/tramp-sh.el2573
-rw-r--r--lisp/net/tramp-smb.el575
-rw-r--r--lisp/net/tramp-sudoedit.el893
-rw-r--r--lisp/net/tramp.el1836
-rw-r--r--lisp/net/trampver.el57
-rw-r--r--lisp/net/webjump.el2
-rw-r--r--lisp/net/zeroconf.el35
-rw-r--r--lisp/newcomment.el28
-rw-r--r--lisp/notifications.el4
-rw-r--r--lisp/novice.el3
-rw-r--r--lisp/nxml/nxml-maint.el4
-rw-r--r--lisp/nxml/nxml-mode.el37
-rw-r--r--lisp/nxml/rng-loc.el2
-rw-r--r--lisp/nxml/rng-maint.el6
-rw-r--r--lisp/nxml/rng-nxml.el6
-rw-r--r--lisp/nxml/rng-uri.el9
-rw-r--r--lisp/nxml/rng-xsd.el2
-rw-r--r--lisp/obsolete/assoc.el1
-rw-r--r--lisp/obsolete/complete.el1
-rw-r--r--lisp/obsolete/crisp.el9
-rw-r--r--lisp/obsolete/fast-lock.el7
-rw-r--r--lisp/obsolete/iswitchb.el7
-rw-r--r--lisp/obsolete/lazy-lock.el6
-rw-r--r--lisp/obsolete/levents.el2
-rw-r--r--lisp/obsolete/longlines.el3
-rw-r--r--lisp/obsolete/mailpost.el4
-rw-r--r--lisp/obsolete/mouse-sel.el6
-rw-r--r--lisp/obsolete/old-whitespace.el1
-rw-r--r--lisp/obsolete/options.el140
-rw-r--r--lisp/obsolete/pgg-gpg.el5
-rw-r--r--lisp/obsolete/pgg-parse.el39
-rw-r--r--lisp/obsolete/pgg-pgp.el3
-rw-r--r--lisp/obsolete/pgg-pgp5.el3
-rw-r--r--lisp/obsolete/pgg.el10
-rw-r--r--lisp/obsolete/sregex.el4
-rw-r--r--lisp/obsolete/starttls.el (renamed from lisp/net/starttls.el)5
-rw-r--r--lisp/obsolete/tls.el (renamed from lisp/net/tls.el)1
-rw-r--r--lisp/obsolete/tpu-edt.el5
-rw-r--r--lisp/obsolete/tpu-extras.el5
-rw-r--r--lisp/obsolete/vc-arch.el14
-rw-r--r--lisp/obsolete/vi.el4
-rw-r--r--lisp/obsolete/vip.el18
-rw-r--r--lisp/obsolete/xesam.el14
-rw-r--r--lisp/org/ob-abc.el4
-rw-r--r--lisp/org/ob-core.el7
-rw-r--r--lisp/org/ob-eval.el2
-rw-r--r--lisp/org/ob-forth.el2
-rw-r--r--lisp/org/org-agenda.el74
-rw-r--r--lisp/org/org-attach.el2
-rw-r--r--lisp/org/org-capture.el8
-rw-r--r--lisp/org/org-clock.el136
-rw-r--r--lisp/org/org-colview.el10
-rw-r--r--lisp/org/org-ctags.el5
-rw-r--r--lisp/org/org-datetree.el9
-rw-r--r--lisp/org/org-duration.el9
-rw-r--r--lisp/org/org-element.el15
-rw-r--r--lisp/org/org-eshell.el2
-rw-r--r--lisp/org/org-footnote.el2
-rw-r--r--lisp/org/org-habit.el5
-rw-r--r--lisp/org/org-id.el4
-rw-r--r--lisp/org/org-indent.el29
-rw-r--r--lisp/org/org-list.el4
-rw-r--r--lisp/org/org-macro.el5
-rw-r--r--lisp/org/org-macs.el2
-rw-r--r--lisp/org/org-mhe.el2
-rw-r--r--lisp/org/org-mobile.el4
-rw-r--r--lisp/org/org-mouse.el2
-rw-r--r--lisp/org/org-pcomplete.el26
-rw-r--r--lisp/org/org-plot.el2
-rw-r--r--lisp/org/org-protocol.el17
-rw-r--r--lisp/org/org-table.el19
-rw-r--r--lisp/org/org-timer.el32
-rw-r--r--lisp/org/org.el175
-rw-r--r--lisp/org/ox-ascii.el4
-rw-r--r--lisp/org/ox-html.el3
-rw-r--r--lisp/org/ox-latex.el2
-rw-r--r--lisp/org/ox-odt.el4
-rw-r--r--lisp/org/ox-publish.el19
-rw-r--r--lisp/org/ox.el4
-rw-r--r--lisp/outline.el45
-rw-r--r--lisp/paren.el3
-rw-r--r--lisp/pcmpl-cvs.el8
-rw-r--r--lisp/pcmpl-gnu.el4
-rw-r--r--lisp/pcmpl-linux.el6
-rw-r--r--lisp/pcmpl-rpm.el5
-rw-r--r--lisp/pcmpl-unix.el2
-rw-r--r--lisp/pcomplete.el99
-rw-r--r--lisp/pixel-scroll.el14
-rw-r--r--lisp/play/bubbles.el82
-rw-r--r--lisp/play/cookie1.el6
-rw-r--r--lisp/play/dunnet.el1
-rw-r--r--lisp/play/fortune.el2
-rw-r--r--lisp/play/gamegrid.el228
-rw-r--r--lisp/play/gametree.el3
-rw-r--r--lisp/play/gomoku.el28
-rw-r--r--lisp/play/hanoi.el2
-rw-r--r--lisp/printing.el1766
-rw-r--r--lisp/proced.el2
-rw-r--r--lisp/profiler.el6
-rw-r--r--lisp/progmodes/ada-mode.el24
-rw-r--r--lisp/progmodes/ada-xref.el5
-rw-r--r--lisp/progmodes/antlr-mode.el39
-rw-r--r--lisp/progmodes/autoconf.el2
-rw-r--r--lisp/progmodes/bat-mode.el4
-rw-r--r--lisp/progmodes/bug-reference.el13
-rw-r--r--lisp/progmodes/cc-align.el135
-rw-r--r--lisp/progmodes/cc-awk.el10
-rw-r--r--lisp/progmodes/cc-cmds.el966
-rw-r--r--lisp/progmodes/cc-defs.el178
-rw-r--r--lisp/progmodes/cc-engine.el1727
-rw-r--r--lisp/progmodes/cc-fonts.el248
-rw-r--r--lisp/progmodes/cc-langs.el197
-rw-r--r--lisp/progmodes/cc-mode.el409
-rw-r--r--lisp/progmodes/cc-styles.el16
-rw-r--r--lisp/progmodes/cc-vars.el15
-rw-r--r--lisp/progmodes/cfengine.el4
-rw-r--r--lisp/progmodes/cmacexp.el3
-rw-r--r--lisp/progmodes/compile.el410
-rw-r--r--lisp/progmodes/cperl-mode.el1449
-rw-r--r--lisp/progmodes/cpp.el23
-rw-r--r--lisp/progmodes/cwarn.el6
-rw-r--r--lisp/progmodes/dcl-mode.el2
-rw-r--r--lisp/progmodes/ebnf-abn.el4
-rw-r--r--lisp/progmodes/ebnf-bnf.el4
-rw-r--r--lisp/progmodes/ebnf-dtd.el4
-rw-r--r--lisp/progmodes/ebnf-ebx.el4
-rw-r--r--lisp/progmodes/ebnf-iso.el4
-rw-r--r--lisp/progmodes/ebnf-otz.el4
-rw-r--r--lisp/progmodes/ebnf-yac.el6
-rw-r--r--lisp/progmodes/ebnf2ps.el102
-rw-r--r--lisp/progmodes/ebrowse.el221
-rw-r--r--lisp/progmodes/elisp-mode.el59
-rw-r--r--lisp/progmodes/etags.el352
-rw-r--r--lisp/progmodes/f90.el17
-rw-r--r--lisp/progmodes/flymake-cc.el146
-rw-r--r--lisp/progmodes/flymake-proc.el64
-rw-r--r--lisp/progmodes/flymake.el505
-rw-r--r--lisp/progmodes/fortran.el14
-rw-r--r--lisp/progmodes/gdb-mi.el32
-rw-r--r--lisp/progmodes/glasses.el11
-rw-r--r--lisp/progmodes/grep.el104
-rw-r--r--lisp/progmodes/gud.el47
-rw-r--r--lisp/progmodes/hideif.el24
-rw-r--r--lisp/progmodes/hideshow.el3
-rw-r--r--lisp/progmodes/idlw-complete-structtag.el2
-rw-r--r--lisp/progmodes/idlw-help.el5
-rw-r--r--lisp/progmodes/idlw-shell.el222
-rw-r--r--lisp/progmodes/idlw-toolbar.el2
-rw-r--r--lisp/progmodes/idlwave.el61
-rw-r--r--lisp/progmodes/js.el1269
-rw-r--r--lisp/progmodes/m4-mode.el5
-rw-r--r--lisp/progmodes/make-mode.el8
-rw-r--r--lisp/progmodes/mantemp.el8
-rw-r--r--lisp/progmodes/meta-mode.el2
-rw-r--r--lisp/progmodes/mixal-mode.el4
-rw-r--r--lisp/progmodes/modula2.el30
-rw-r--r--lisp/progmodes/octave.el81
-rw-r--r--lisp/progmodes/opascal.el22
-rw-r--r--lisp/progmodes/pascal.el6
-rw-r--r--lisp/progmodes/perl-mode.el17
-rw-r--r--lisp/progmodes/prog-mode.el3
-rw-r--r--lisp/progmodes/project.el258
-rw-r--r--lisp/progmodes/prolog.el32
-rw-r--r--lisp/progmodes/ps-mode.el6
-rw-r--r--lisp/progmodes/python.el266
-rw-r--r--lisp/progmodes/ruby-mode.el161
-rw-r--r--lisp/progmodes/scheme.el2
-rw-r--r--lisp/progmodes/sh-script.el62
-rw-r--r--lisp/progmodes/sql.el852
-rw-r--r--lisp/progmodes/subword.el10
-rw-r--r--lisp/progmodes/tcl.el51
-rw-r--r--lisp/progmodes/verilog-mode.el853
-rw-r--r--lisp/progmodes/vhdl-mode.el40
-rw-r--r--lisp/progmodes/which-func.el20
-rw-r--r--lisp/progmodes/xref.el80
-rw-r--r--lisp/ps-bdf.el14
-rw-r--r--lisp/ps-def.el7
-rw-r--r--lisp/ps-mule.el6
-rw-r--r--lisp/ps-print.el62
-rw-r--r--lisp/ps-samp.el4
-rw-r--r--lisp/recentf.el7
-rw-r--r--lisp/rect.el40
-rw-r--r--lisp/register.el281
-rw-r--r--lisp/registry.el5
-rw-r--r--lisp/replace.el591
-rw-r--r--lisp/reveal.el9
-rw-r--r--lisp/rfn-eshadow.el3
-rw-r--r--lisp/rtree.el9
-rw-r--r--lisp/ruler-mode.el33
-rw-r--r--lisp/savehist.el26
-rw-r--r--lisp/saveplace.el3
-rw-r--r--lisp/scroll-all.el3
-rw-r--r--lisp/scroll-bar.el30
-rw-r--r--lisp/scroll-lock.el11
-rw-r--r--lisp/select.el8
-rw-r--r--lisp/server.el216
-rw-r--r--lisp/ses.el38
-rw-r--r--lisp/shadowfile.el9
-rw-r--r--lisp/shell.el108
-rw-r--r--lisp/simple.el678
-rw-r--r--lisp/skeleton.el4
-rw-r--r--lisp/speedbar.el188
-rw-r--r--lisp/startup.el497
-rw-r--r--lisp/strokes.el3
-rw-r--r--lisp/subr.el559
-rw-r--r--lisp/svg.el22
-rw-r--r--lisp/t-mouse.el3
-rw-r--r--lisp/tar-mode.el54
-rw-r--r--lisp/term.el836
-rw-r--r--lisp/term/common-win.el32
-rw-r--r--lisp/term/internal.el3
-rw-r--r--lisp/term/ns-win.el98
-rw-r--r--lisp/term/pc-win.el140
-rw-r--r--lisp/term/sun.el19
-rw-r--r--lisp/term/tty-colors.el20
-rw-r--r--lisp/term/tvi970.el3
-rw-r--r--lisp/term/vt100.el5
-rw-r--r--lisp/term/w32-win.el15
-rw-r--r--lisp/term/x-win.el8
-rw-r--r--lisp/term/xterm.el125
-rw-r--r--lisp/textmodes/artist.el12
-rw-r--r--lisp/textmodes/bib-mode.el2
-rw-r--r--lisp/textmodes/bibtex.el116
-rw-r--r--lisp/textmodes/conf-mode.el12
-rw-r--r--lisp/textmodes/css-mode.el276
-rw-r--r--lisp/textmodes/dns-mode.el8
-rw-r--r--lisp/textmodes/enriched.el23
-rw-r--r--lisp/textmodes/fill.el21
-rw-r--r--lisp/textmodes/flyspell.el27
-rw-r--r--lisp/textmodes/ispell.el198
-rw-r--r--lisp/textmodes/less-css-mode.el4
-rw-r--r--lisp/textmodes/mhtml-mode.el5
-rw-r--r--lisp/textmodes/nroff-mode.el10
-rw-r--r--lisp/textmodes/page-ext.el101
-rw-r--r--lisp/textmodes/paragraphs.el3
-rw-r--r--lisp/textmodes/picture.el14
-rw-r--r--lisp/textmodes/refbib.el2
-rw-r--r--lisp/textmodes/refill.el11
-rw-r--r--lisp/textmodes/reftex-cite.el4
-rw-r--r--lisp/textmodes/reftex-parse.el2
-rw-r--r--lisp/textmodes/reftex-ref.el4
-rw-r--r--lisp/textmodes/reftex-vars.el57
-rw-r--r--lisp/textmodes/remember.el10
-rw-r--r--lisp/textmodes/rst.el57
-rw-r--r--lisp/textmodes/sgml-mode.el131
-rw-r--r--lisp/textmodes/tex-mode.el33
-rw-r--r--lisp/textmodes/texinfmt.el10
-rw-r--r--lisp/textmodes/texinfo.el38
-rw-r--r--lisp/textmodes/texnfo-upd.el2
-rw-r--r--lisp/textmodes/text-mode.el37
-rw-r--r--lisp/thingatpt.el67
-rw-r--r--lisp/thread.el200
-rw-r--r--lisp/thumbs.el4
-rw-r--r--lisp/time.el47
-rw-r--r--lisp/tmm.el42
-rw-r--r--lisp/tool-bar.el3
-rw-r--r--lisp/tooltip.el21
-rw-r--r--lisp/tutorial.el4
-rw-r--r--lisp/type-break.el31
-rw-r--r--lisp/url/url-auth.el5
-rw-r--r--lisp/url/url-cache.el16
-rw-r--r--lisp/url/url-cookie.el105
-rw-r--r--lisp/url/url-dav.el28
-rw-r--r--lisp/url/url-dired.el5
-rw-r--r--lisp/url/url-file.el26
-rw-r--r--lisp/url/url-gw.el8
-rw-r--r--lisp/url/url-handlers.el17
-rw-r--r--lisp/url/url-http.el141
-rw-r--r--lisp/url/url-methods.el4
-rw-r--r--lisp/url/url-parse.el2
-rw-r--r--lisp/url/url-privacy.el6
-rw-r--r--lisp/url/url-queue.el22
-rw-r--r--lisp/url/url-util.el34
-rw-r--r--lisp/url/url-vars.el28
-rw-r--r--lisp/url/url.el4
-rw-r--r--lisp/userlock.el8
-rw-r--r--lisp/vc/add-log.el110
-rw-r--r--lisp/vc/cvs-status.el30
-rw-r--r--lisp/vc/diff-mode.el783
-rw-r--r--lisp/vc/diff.el8
-rw-r--r--lisp/vc/ediff-init.el22
-rw-r--r--lisp/vc/ediff-merg.el2
-rw-r--r--lisp/vc/ediff-ptch.el14
-rw-r--r--lisp/vc/ediff-util.el45
-rw-r--r--lisp/vc/ediff-wind.el243
-rw-r--r--lisp/vc/ediff.el6
-rw-r--r--lisp/vc/emerge.el602
-rw-r--r--lisp/vc/log-edit.el22
-rw-r--r--lisp/vc/log-view.el16
-rw-r--r--lisp/vc/pcvs-info.el20
-rw-r--r--lisp/vc/pcvs-parse.el1
-rw-r--r--lisp/vc/pcvs.el14
-rw-r--r--lisp/vc/smerge-mode.el57
-rw-r--r--lisp/vc/vc-annotate.el4
-rw-r--r--lisp/vc/vc-bzr.el26
-rw-r--r--lisp/vc/vc-cvs.el26
-rw-r--r--lisp/vc/vc-dir.el8
-rw-r--r--lisp/vc/vc-dispatcher.el30
-rw-r--r--lisp/vc/vc-git.el155
-rw-r--r--lisp/vc/vc-hg.el67
-rw-r--r--lisp/vc/vc-hooks.el57
-rw-r--r--lisp/vc/vc-mtn.el4
-rw-r--r--lisp/vc/vc-rcs.el17
-rw-r--r--lisp/vc/vc-svn.el8
-rw-r--r--lisp/vc/vc.el254
-rw-r--r--lisp/vcursor.el3
-rw-r--r--lisp/version.el34
-rw-r--r--lisp/view.el3
-rw-r--r--lisp/w32-fns.el209
-rw-r--r--lisp/w32-vars.el4
-rw-r--r--lisp/wdired.el78
-rw-r--r--lisp/whitespace.el26
-rw-r--r--lisp/wid-browse.el5
-rw-r--r--lisp/wid-edit.el5
-rw-r--r--lisp/windmove.el309
-rw-r--r--lisp/window.el712
-rw-r--r--lisp/winner.el3
-rw-r--r--lisp/woman.el102
-rw-r--r--lisp/x-dnd.el17
-rw-r--r--lisp/xdg.el107
-rw-r--r--lisp/xml.el21
-rw-r--r--lisp/xt-mouse.el31
-rw-r--r--lwlib/Makefile.in2
-rw-r--r--m4/__inline.m422
-rw-r--r--m4/acl.m45
-rw-r--r--m4/alloca.m413
-rw-r--r--m4/builtin-expect.m449
-rw-r--r--m4/c-strtod.m449
-rw-r--r--m4/d-type.m43
-rw-r--r--m4/dup2.m43
-rw-r--r--m4/eealloc.m431
-rw-r--r--m4/environ.m420
-rw-r--r--m4/errno_h.m410
-rw-r--r--m4/extensions.m48
-rw-r--r--m4/extern-inline.m416
-rw-r--r--m4/fdatasync.m432
-rw-r--r--m4/fdopendir.m412
-rw-r--r--m4/filemode.m43
-rw-r--r--m4/fsusage.m4307
-rw-r--r--m4/getgroups.m411
-rw-r--r--m4/getloadavg.m413
-rw-r--r--m4/gettime.m47
-rw-r--r--m4/gettimeofday.m47
-rw-r--r--m4/glibc21.m434
-rw-r--r--m4/gnulib-common.m4159
-rw-r--r--m4/gnulib-comp.m498
-rw-r--r--m4/group-member.m43
-rw-r--r--m4/ieee754-h.m421
-rw-r--r--m4/inttypes.m43
-rw-r--r--m4/limits-h.m424
-rw-r--r--m4/longlong.m410
-rw-r--r--m4/lstat.m45
-rw-r--r--m4/manywarnings.m4101
-rw-r--r--m4/mbstate_t.m441
-rw-r--r--m4/memrchr.m44
-rw-r--r--m4/mktime.m44
-rw-r--r--m4/nocrash.m44
-rw-r--r--m4/nstrftime.m43
-rw-r--r--m4/pkg.m416
-rw-r--r--m4/pselect.m412
-rw-r--r--m4/pthread_sigmask.m470
-rw-r--r--m4/putenv.m44
-rw-r--r--m4/readlink.m412
-rw-r--r--m4/regex.m4311
-rw-r--r--m4/sig2str.m43
-rw-r--r--m4/socklen.m415
-rw-r--r--m4/ssize_t.m43
-rw-r--r--m4/st_dm_mode.m43
-rw-r--r--m4/stat-time.m44
-rw-r--r--m4/std-gnu11.m44
-rw-r--r--m4/stddef_h.m429
-rw-r--r--m4/stdint.m413
-rw-r--r--m4/stdio_h.m44
-rw-r--r--m4/stdlib_h.m418
-rw-r--r--m4/strtoimax.m43
-rw-r--r--m4/strtoll.m43
-rw-r--r--m4/symlink.m412
-rw-r--r--m4/time_h.m43
-rw-r--r--m4/time_rz.m433
-rw-r--r--m4/timespec.m43
-rw-r--r--m4/unistd_h.m411
-rw-r--r--m4/utimens.m412
-rw-r--r--m4/utimes.m410
-rw-r--r--m4/vararrays.m466
-rw-r--r--m4/warnings.m411
-rwxr-xr-xmake-dist401
-rw-r--r--msdos/sed2v2.inp2
-rw-r--r--nextstep/Makefile.in9
-rw-r--r--nt/INSTALL7
-rw-r--r--nt/INSTALL.W641
-rw-r--r--nt/README.W322
-rw-r--r--nt/gnulib-cfg.mk1
-rw-r--r--nt/inc/langinfo.h4
-rw-r--r--nt/inc/ms-w32.h7
-rw-r--r--nt/mingw-cfg.site1
-rw-r--r--oldXMenu/Makefile.in2
-rw-r--r--src/.gdbinit114
-rw-r--r--src/Makefile.in201
-rw-r--r--src/alloc.c2277
-rw-r--r--src/atimer.c40
-rw-r--r--src/bidi.c26
-rw-r--r--src/bignum.c351
-rw-r--r--src/bignum.h99
-rw-r--r--src/buffer.c652
-rw-r--r--src/buffer.h69
-rw-r--r--src/bytecode.c132
-rw-r--r--src/callint.c356
-rw-r--r--src/callproc.c47
-rw-r--r--src/casefiddle.c20
-rw-r--r--src/casetab.c35
-rw-r--r--src/category.c62
-rw-r--r--src/category.h12
-rw-r--r--src/ccl.c188
-rw-r--r--src/character.c110
-rw-r--r--src/character.h10
-rw-r--r--src/charset.c376
-rw-r--r--src/charset.h7
-rw-r--r--src/chartab.c107
-rw-r--r--src/cmds.c106
-rw-r--r--src/coding.c691
-rw-r--r--src/coding.h38
-rw-r--r--src/composite.c197
-rw-r--r--src/composite.h58
-rw-r--r--src/conf_post.h58
-rw-r--r--src/data.c1141
-rw-r--r--src/dbusbind.c120
-rw-r--r--src/decompress.c56
-rw-r--r--src/deps.mk9
-rw-r--r--src/dired.c121
-rw-r--r--src/dispextern.h84
-rw-r--r--src/dispnew.c149
-rw-r--r--src/disptab.h4
-rw-r--r--src/dmpstruct.awk45
-rw-r--r--src/doc.c97
-rw-r--r--src/doprnt.c6
-rw-r--r--src/dosfns.c82
-rw-r--r--src/dynlib.c5
-rw-r--r--src/editfns.c2428
-rw-r--r--src/emacs-module.c491
-rw-r--r--src/emacs-module.h.in21
-rw-r--r--src/emacs.c528
-rw-r--r--src/eval.c458
-rw-r--r--src/fileio.c537
-rw-r--r--src/filelock.c14
-rw-r--r--src/fingerprint.h29
-rw-r--r--src/floatfns.c251
-rw-r--r--src/fns.c813
-rw-r--r--src/font.c502
-rw-r--r--src/font.h30
-rw-r--r--src/fontset.c134
-rw-r--r--src/frame.c743
-rw-r--r--src/frame.h112
-rw-r--r--src/fringe.c88
-rw-r--r--src/ftcrfont.c54
-rw-r--r--src/ftfont.c184
-rw-r--r--src/ftfont.h37
-rw-r--r--src/ftxfont.c9
-rw-r--r--src/gfilenotify.c39
-rw-r--r--src/gmalloc.c37
-rw-r--r--src/gnutls.c401
-rw-r--r--src/gtkutil.c147
-rw-r--r--src/image.c641
-rw-r--r--src/indent.c158
-rw-r--r--src/inotify.c26
-rw-r--r--src/insdel.c65
-rw-r--r--src/intervals.c82
-rw-r--r--src/intervals.h17
-rw-r--r--src/json.c1107
-rw-r--r--src/keyboard.c1351
-rw-r--r--src/keyboard.h13
-rw-r--r--src/keymap.c377
-rw-r--r--src/kqueue.c47
-rw-r--r--src/lastfile.c5
-rw-r--r--src/lcms.c7
-rw-r--r--src/lisp.h1698
-rw-r--r--src/lread.c1055
-rw-r--r--src/macfont.m119
-rw-r--r--src/macros.c22
-rw-r--r--src/macuvs.h3
-rw-r--r--src/marker.c64
-rw-r--r--src/menu.c174
-rw-r--r--src/menu.h4
-rw-r--r--src/mini-gmp-emacs.c32
-rw-r--r--src/mini-gmp.c4452
-rw-r--r--src/mini-gmp.h300
-rw-r--r--src/minibuf.c228
-rw-r--r--src/module-env-25.h4
-rw-r--r--src/module-env-27.h4
-rw-r--r--src/msdos.c52
-rw-r--r--src/nsfns.m604
-rw-r--r--src/nsfont.m163
-rw-r--r--src/nsgui.h12
-rw-r--r--src/nsimage.m94
-rw-r--r--src/nsmenu.m156
-rw-r--r--src/nsselect.m28
-rw-r--r--src/nsterm.h121
-rw-r--r--src/nsterm.m1065
-rw-r--r--src/pdumper.c5514
-rw-r--r--src/pdumper.h254
-rw-r--r--src/print.c477
-rw-r--r--src/process.c496
-rw-r--r--src/process.h12
-rw-r--r--src/profiler.c140
-rw-r--r--src/ptr-bounds.h79
-rw-r--r--src/puresize.h2
-rw-r--r--src/ralloc.c12
-rw-r--r--src/regex-emacs.c (renamed from src/regex.c)3037
-rw-r--r--src/regex-emacs.h197
-rw-r--r--src/regex.h644
-rw-r--r--src/scroll.c46
-rw-r--r--src/search.c1123
-rw-r--r--src/sheap.c1
-rw-r--r--src/sheap.h1
-rw-r--r--src/sound.c17
-rw-r--r--src/syntax.c310
-rw-r--r--src/syntax.h16
-rw-r--r--src/sysdep.c435
-rw-r--r--src/syssignal.h3
-rw-r--r--src/systhread.c98
-rw-r--r--src/systhread.h23
-rw-r--r--src/systime.h49
-rw-r--r--src/term.c108
-rw-r--r--src/termcap.c43
-rw-r--r--src/termhooks.h12
-rw-r--r--src/terminal.c10
-rw-r--r--src/textprop.c322
-rw-r--r--src/thread.c156
-rw-r--r--src/thread.h47
-rw-r--r--src/timefns.c1781
-rw-r--r--src/tparam.h5
-rw-r--r--src/undo.c39
-rw-r--r--src/unexcoff.c4
-rw-r--r--src/unexcw.c6
-rw-r--r--src/unexmacosx.c2
-rw-r--r--src/unexw32.c126
-rw-r--r--src/w16select.c57
-rw-r--r--src/w32.c721
-rw-r--r--src/w32.h19
-rw-r--r--src/w32common.h31
-rw-r--r--src/w32console.c12
-rw-r--r--src/w32cygwinx.c134
-rw-r--r--src/w32fns.c988
-rw-r--r--src/w32font.c62
-rw-r--r--src/w32heap.c48
-rw-r--r--src/w32heap.h3
-rw-r--r--src/w32inevt.c8
-rw-r--r--src/w32menu.c19
-rw-r--r--src/w32notify.c17
-rw-r--r--src/w32proc.c333
-rw-r--r--src/w32reg.c8
-rw-r--r--src/w32select.c58
-rw-r--r--src/w32term.c272
-rw-r--r--src/w32term.h6
-rw-r--r--src/w32uniscribe.c28
-rw-r--r--src/widget.c15
-rw-r--r--src/window.c1639
-rw-r--r--src/window.h54
-rw-r--r--src/xdisp.c1272
-rw-r--r--src/xfaces.c535
-rw-r--r--src/xfns.c606
-rw-r--r--src/xfont.c36
-rw-r--r--src/xftfont.c82
-rw-r--r--src/xmenu.c82
-rw-r--r--src/xml.c50
-rw-r--r--src/xrdb.c60
-rw-r--r--src/xselect.c129
-rw-r--r--src/xsettings.c10
-rw-r--r--src/xterm.c389
-rw-r--r--src/xterm.h6
-rw-r--r--src/xwidget.c152
-rw-r--r--src/xwidget.h15
-rw-r--r--test/Makefile.in57
-rw-r--r--test/README42
-rw-r--r--test/data/decompress/tg.tar.gzbin0 -> 150 bytes
-rw-r--r--test/data/decompress/zg.zipbin0 -> 182 bytes
-rw-r--r--test/data/emacs-module/mod-test.c79
-rw-r--r--test/data/shr/ol.html29
-rw-r--r--test/data/shr/ol.txt19
-rw-r--r--test/data/vc/diff-mode/hello_emacs.c6
-rw-r--r--test/data/vc/diff-mode/hello_emacs_1.c1
-rw-r--r--test/data/vc/diff-mode/hello_world.c6
-rw-r--r--test/data/vc/diff-mode/hello_world_1.c1
-rw-r--r--test/data/xdg/mimeapps.list9
-rw-r--r--test/data/xdg/mimeinfo.cache4
-rw-r--r--test/lisp/abbrev-tests.el25
-rw-r--r--test/lisp/arc-mode-tests.el14
-rw-r--r--test/lisp/auth-source-pass-tests.el87
-rw-r--r--test/lisp/auth-source-tests.el42
-rw-r--r--test/lisp/autorevert-tests.el19
-rw-r--r--test/lisp/button-tests.el40
-rw-r--r--test/lisp/calendar/icalendar-tests.el11
-rw-r--r--test/lisp/calendar/parse-time-tests.el62
-rw-r--r--test/lisp/calendar/todo-mode-tests.el275
-rw-r--r--test/lisp/char-fold-tests.el6
-rw-r--r--test/lisp/comint-tests.el3
-rw-r--r--test/lisp/custom-resources/custom--test-theme.el9
-rw-r--r--test/lisp/custom-tests.el126
-rw-r--r--test/lisp/dired-aux-tests.el77
-rw-r--r--test/lisp/dired-tests.el23
-rw-r--r--test/lisp/electric-tests.el250
-rw-r--r--test/lisp/emacs-lisp/backtrace-tests.el436
-rw-r--r--test/lisp/emacs-lisp/benchmark-tests.el30
-rw-r--r--test/lisp/emacs-lisp/bytecomp-tests.el51
-rw-r--r--test/lisp/emacs-lisp/cconv-tests.el40
-rw-r--r--test/lisp/emacs-lisp/cl-lib-tests.el17
-rw-r--r--test/lisp/emacs-lisp/cl-macs-tests.el16
-rw-r--r--test/lisp/emacs-lisp/cl-preloaded-tests.el33
-rw-r--r--test/lisp/emacs-lisp/cl-print-tests.el180
-rw-r--r--test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el9
-rw-r--r--test/lisp/emacs-lisp/edebug-tests.el29
-rw-r--r--test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el4
-rw-r--r--test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el19
-rw-r--r--test/lisp/emacs-lisp/eieio-tests/eieio-tests.el2
-rw-r--r--test/lisp/emacs-lisp/ert-tests.el52
-rw-r--r--test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el76
-rw-r--r--test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el32
-rw-r--r--test/lisp/emacs-lisp/faceup-resources/files/test1.txt15
-rw-r--r--test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup15
-rw-r--r--test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el269
-rw-r--r--test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el63
-rw-r--r--test/lisp/emacs-lisp/generator-tests.el10
-rw-r--r--test/lisp/emacs-lisp/map-tests.el25
-rw-r--r--test/lisp/emacs-lisp/package-tests.el130
-rw-r--r--test/lisp/emacs-lisp/pcase-tests.el6
-rw-r--r--test/lisp/emacs-lisp/ring-tests.el37
-rw-r--r--test/lisp/emacs-lisp/rx-tests.el68
-rw-r--r--test/lisp/emacs-lisp/seq-tests.el37
-rw-r--r--test/lisp/emacs-lisp/subr-x-tests.el65
-rw-r--r--test/lisp/emacs-lisp/testcover-resources/testcases.el61
-rw-r--r--test/lisp/emacs-lisp/testcover-tests.el12
-rw-r--r--test/lisp/emacs-lisp/text-property-search-tests.el113
-rw-r--r--test/lisp/emacs-lisp/thunk-tests.el50
-rw-r--r--test/lisp/emacs-lisp/timer-tests.el25
-rw-r--r--test/lisp/epg-tests.el51
-rw-r--r--test/lisp/eshell/em-ls-tests.el15
-rw-r--r--test/lisp/eshell/esh-opt-tests.el124
-rw-r--r--test/lisp/eshell/eshell-tests.el3
-rw-r--r--test/lisp/faces-tests.el9
-rw-r--r--test/lisp/filenotify-tests.el541
-rw-r--r--test/lisp/files-tests.el811
-rw-r--r--test/lisp/files-x-tests.el89
-rw-r--r--test/lisp/gnus/gnus-test-headers.el178
-rw-r--r--test/lisp/gnus/gnus-tests.el2
-rw-r--r--test/lisp/gnus/message-tests.el56
-rw-r--r--test/lisp/help-fns-tests.el5
-rw-r--r--test/lisp/hi-lock-tests.el4
-rw-r--r--test/lisp/htmlfontify-tests.el2
-rw-r--r--test/lisp/info-xref-tests.el17
-rw-r--r--test/lisp/international/ccl-tests.el229
-rw-r--r--test/lisp/international/ucs-normalize-tests.el70
-rw-r--r--test/lisp/json-tests.el67
-rw-r--r--test/lisp/jsonrpc-tests.el254
-rw-r--r--test/lisp/ls-lisp-tests.el1
-rw-r--r--test/lisp/mail/rmail-tests.el2
-rw-r--r--test/lisp/minibuffer-tests.el6
-rw-r--r--test/lisp/mouse-tests.el14
-rw-r--r--test/lisp/net/gnutls-tests.el30
-rw-r--r--test/lisp/net/network-stream-tests.el434
-rw-r--r--test/lisp/net/secrets-tests.el268
-rw-r--r--test/lisp/net/tramp-archive-resources/foo.iso/foo1
-rw-r--r--test/lisp/net/tramp-archive-resources/foo.tar.gzbin0 -> 274 bytes
-rw-r--r--test/lisp/net/tramp-archive-tests.el965
-rw-r--r--test/lisp/net/tramp-tests.el1625
-rw-r--r--test/lisp/progmodes/bat-mode-tests.el5
-rw-r--r--test/lisp/progmodes/f90-tests.el2
-rw-r--r--test/lisp/progmodes/flymake-resources/Makefile2
-rw-r--r--test/lisp/progmodes/flymake-tests.el18
-rw-r--r--test/lisp/progmodes/python-tests.el28
-rw-r--r--test/lisp/progmodes/ruby-mode-tests.el96
-rw-r--r--test/lisp/progmodes/sql-tests.el217
-rw-r--r--test/lisp/progmodes/tcl-tests.el77
-rw-r--r--test/lisp/replace-tests.el47
-rw-r--r--test/lisp/ses-tests.el80
-rw-r--r--test/lisp/shell-tests.el8
-rw-r--r--test/lisp/simple-tests.el226
-rw-r--r--test/lisp/subr-tests.el51
-rw-r--r--test/lisp/tar-mode-tests.el13
-rw-r--r--test/lisp/term-tests.el20
-rw-r--r--test/lisp/textmodes/conf-mode-tests.el204
-rw-r--r--test/lisp/textmodes/css-mode-tests.el113
-rw-r--r--test/lisp/textmodes/fill-tests.el50
-rw-r--r--test/lisp/textmodes/sgml-mode-tests.el30
-rw-r--r--test/lisp/thingatpt-tests.el5
-rw-r--r--test/lisp/thread-tests.el96
-rw-r--r--test/lisp/url/url-handlers-test.el75
-rw-r--r--test/lisp/url/url-util-tests.el12
-rw-r--r--test/lisp/vc/diff-mode-tests.el118
-rw-r--r--test/lisp/vc/vc-bzr-tests.el3
-rw-r--r--test/lisp/vc/vc-tests.el2
-rw-r--r--test/lisp/wid-edit-tests.el39
-rw-r--r--test/lisp/xdg-tests.el12
-rw-r--r--test/manual/BidiCharacterTest.txt4
-rw-r--r--test/manual/cedet/semantic-ia-utest.el2
-rw-r--r--test/manual/cedet/semantic-tests.el12
-rw-r--r--test/manual/indent/css-mode.css2
-rw-r--r--test/manual/indent/js-jsx.js85
-rw-r--r--test/manual/indent/js.js14
-rw-r--r--test/manual/indent/jsx-align-gt-with-lt.jsx12
-rw-r--r--test/manual/indent/jsx-indent-level.jsx13
-rw-r--r--test/manual/indent/jsx-quote.jsx16
-rw-r--r--test/manual/indent/jsx-self-closing.jsx13
-rw-r--r--test/manual/indent/jsx-unclosed-1.jsx13
-rw-r--r--test/manual/indent/jsx-unclosed-2.jsx65
-rw-r--r--test/manual/indent/jsx.jsx314
-rw-r--r--test/src/buffer-tests.el25
-rw-r--r--test/src/callint-tests.el54
-rw-r--r--test/src/cmds-tests.el8
-rw-r--r--test/src/data-tests.el177
-rw-r--r--test/src/editfns-tests.el157
-rw-r--r--test/src/emacs-module-tests.el76
-rw-r--r--test/src/eval-tests.el46
-rw-r--r--test/src/fileio-tests.el18
-rw-r--r--test/src/floatfns-tests.el93
-rw-r--r--test/src/fns-tests.el93
-rw-r--r--test/src/json-tests.el291
-rw-r--r--test/src/lread-tests.el50
-rw-r--r--test/src/print-tests.el58
-rw-r--r--test/src/process-tests.el83
-rw-r--r--test/src/regex-emacs-tests.el (renamed from test/src/regex-tests.el)20
-rw-r--r--test/src/thread-tests.el59
-rw-r--r--test/src/timefns-tests.el144
1602 files changed, 124242 insertions, 66349 deletions
diff --git a/.clang-format b/.clang-format
new file mode 100644
index 00000000000..7895ada36da
--- /dev/null
+++ b/.clang-format
@@ -0,0 +1,27 @@
+Language: Cpp
+BasedOnStyle: LLVM
+AlignEscapedNewlinesLeft: true
+AlwaysBreakAfterReturnType: TopLevelDefinitions
+BreakBeforeBinaryOperators: All
+BreakBeforeBraces: GNU
+ColumnLimit: 80
+ContinuationIndentWidth: 2
+ForEachMacros: [FOR_EACH_TAIL, FOR_EACH_TAIL_SAFE]
+IncludeCategories:
+ - Regex: '^<config\.h>$'
+ Priority: -1
+ - Regex: '^<'
+ Priority: 1
+ - Regex: '^"lisp\.h"$'
+ Priority: 2
+ - Regex: '.*'
+ Priority: 3
+KeepEmptyLinesAtTheStartOfBlocks: false
+MaxEmptyLinesToKeep: 1
+PenaltyBreakBeforeFirstCallParameter: 2000
+SpaceAfterCStyleCast: true
+SpaceBeforeParens: Always
+
+# Local Variables:
+# mode: yaml
+# End:
diff --git a/.dir-locals.el b/.dir-locals.el
index 68eb58fa18b..ffd65c88027 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -1,14 +1,22 @@
((nil . ((tab-width . 8)
(sentence-end-double-space . t)
- (fill-column . 70)))
+ (fill-column . 70)
+ (bug-reference-url-format . "https://debbugs.gnu.org/%s")))
(c-mode . ((c-file-style . "GNU")
- (c-noise-macro-names . ("UNINIT" "CALLBACK" "ALIGN_STACK"))))
- (objc-mode . ((c-file-style . "GNU")))
+ (c-noise-macro-names . ("INLINE" "ATTRIBUTE_NO_SANITIZE_UNDEFINED" "UNINIT" "CALLBACK" "ALIGN_STACK"))
+ (electric-quote-comment . nil)
+ (electric-quote-string . nil)))
+ (objc-mode . ((c-file-style . "GNU")
+ (electric-quote-comment . nil)
+ (electric-quote-string . nil)))
(log-edit-mode . ((log-edit-font-lock-gnu-style . t)
(log-edit-setup-add-author . t)))
(change-log-mode . ((add-log-time-zone-rule . t)
(fill-column . 74)
- (bug-reference-url-format . "https://debbugs.gnu.org/%s")
- (mode . bug-reference)))
+ (eval . (bug-reference-mode))))
(diff-mode . ((mode . whitespace)))
- (emacs-lisp-mode . ((indent-tabs-mode . nil))))
+ (emacs-lisp-mode . ((indent-tabs-mode . nil)
+ (electric-quote-comment . nil)
+ (electric-quote-string . nil)))
+ (texinfo-mode . ((electric-quote-comment . nil)
+ (electric-quote-string . nil))))
diff --git a/.gitignore b/.gitignore
index 48b15837d43..88b29760b74 100644
--- a/.gitignore
+++ b/.gitignore
@@ -57,6 +57,7 @@ lib/execinfo.h
lib/fcntl.h
lib/getopt.h
lib/getopt-cdefs.h
+lib/ieee754.h
lib/inttypes.h
lib/libgnu.a
lib/limits.h
@@ -170,6 +171,7 @@ lib-src/emacsclient
lib-src/etags
lib-src/hexl
lib-src/make-docfile
+lib-src/make-fingerprint
lib-src/movemail
lib-src/profile
lib-src/test-distrib
@@ -183,6 +185,9 @@ src/bootstrap-emacs
src/emacs
src/emacs-[0-9]*
src/temacs
+src/fingerprint.c
+src/dmpstruct.h
+src/*.pdmp
# Character-set info.
admin/charsets/jisx2131-filter
@@ -193,6 +198,7 @@ lisp/international/charscript.el
lisp/international/cp51932.el
lisp/international/eucjp-ms.el
lisp/international/uni-*.el
+lisp/language/pinyin.el
# Documentation.
*.aux
@@ -256,6 +262,9 @@ ChangeLog
# Built by 'make install'.
etc/emacs.tmpdesktop
+# Built by 'make-dist'.
+/MANIFEST
+
# Distribution directories.
/emacs-[1-9]*/
@@ -263,6 +272,7 @@ etc/emacs.tmpdesktop
*.in-h
_*
!lib/_Noreturn.h
+!m4/_*.m4
/bin/
/BIN/
/data/
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index ff51c20726b..b022e4b8af1 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -22,22 +22,44 @@
# evaluation purposes, thus possibly temporary.
# Maintainer: tzz@lifelogs.com
-# URL: https://gitlab.com/emacs-ci/emacs
+# URL: https://emba.gnu.org/emacs/emacs
image: debian:stretch
+variables:
+ GIT_STRATEGY: fetch
+ EMACS_EMBA_CI: 1
+
before_script:
- apt update -qq
- - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libc-dev gcc make autoconf automake libncurses-dev gnutls-dev
+ - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libc-dev gcc make autoconf automake libncurses-dev gnutls-dev git
stages:
- test
-test:
+test-all:
+ # This tests also file monitor libraries inotify and inotifywatch.
stage: test
- variables:
- EMACS_EMBA_CI: 1
script:
+ - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 inotify-tools
- ./autogen.sh autoconf
- ./configure --without-makeinfo
- - make check
+ - make bootstrap
+ - make check-expensive
+
+test-filenotify-gio:
+ stage: test
+ # This tests file monitor libraries gfilemonitor and gio.
+ only:
+ changes:
+ - .gitlab-ci.yml
+ - lisp/filenotify.el
+ - lisp/net/tramp-sh.el
+ - src/gfilenotify.c
+ - test/lisp/filenotify-tests.el
+ script:
+ - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libglib2.0-dev libglib2.0-bin libglib2.0-0
+ - ./autogen.sh autoconf
+ - ./configure --without-makeinfo --with-file-notification=gfile
+ - make bootstrap
+ - make -C test filenotify-tests
diff --git a/CONTRIBUTE b/CONTRIBUTE
index df7220a4ee6..a5433e30d37 100644
--- a/CONTRIBUTE
+++ b/CONTRIBUTE
@@ -65,7 +65,10 @@ fill and email it, in order to start this legal paperwork.
The Emacs issue tracker at https://debbugs.gnu.org lets you view bug
reports and search the database for bugs matching several criteria.
Messages posted to the bug-gnu-emacs@gnu.org mailing list, mentioned
-above, are recorded by the tracker with the corresponding bugs/issues.
+above, are recorded by the tracker with the corresponding
+bugs/issues. If a message to the bug tracker contains a patch, please
+include the string "[PATCH]" in the subject of the message in order to
+let the bug tracker tag the bug properly.
GNU ELPA has a 'debbugs' package that allows accessing the tracker
database from Emacs.
diff --git a/ChangeLog.2 b/ChangeLog.2
index 8695c410ecf..d26ea14d16d 100644
--- a/ChangeLog.2
+++ b/ChangeLog.2
@@ -25940,9 +25940,9 @@
2015-08-19 Artur Malabarba <bruce.connor.am@gmail.com>
* lisp/isearch.el (isearch-search-fun-default): Revert a5bdb87
- Remove usage of `isearch-lax-whitespace' inside the `iearch-word'
+ Remove usage of `isearch-lax-whitespace' inside the `isearch-word'
clause of `isearch-search-fun-default'. That lax variable does not
- refer to lax-whitespacing. Related to (bug#21777).
+ refer to lax-whitespacing. Related to (bug#21277).
This reverts commit a5bdb872edb9f031fe041faf9a8c0be432e5f64c.
* lisp/character-fold.el (character-fold-search): Set to nil.
Default to nil for now, until someone implements proper
@@ -29096,7 +29096,7 @@
* lisp/isearch.el: Move character-folding code to
character-fold.el
(isearch-toggle-character-fold): New command.
- (isearch-mode-map): Bind it to "\M-sf".
+ (isearch-mode-map): Bind it to "\M-s'".
(isearch-mode): Check value of `character-fold-search'.
2015-06-24 Stefan Monnier <monnier@iro.umontreal.ca>
diff --git a/ChangeLog.3 b/ChangeLog.3
index e49a3762643..e7f4d866326 100644
--- a/ChangeLog.3
+++ b/ChangeLog.3
@@ -912,7 +912,7 @@
* lisp/textmodes/mhtml-mode.el: Avoid loading flyspell. (Bug#33939)
-2019-01-05 Paul Eggert <eggert@cs.ucla.edu>
+2019-01-07 Paul Eggert <eggert@cs.ucla.edu>
Improve GC+Cairo workaround
@@ -923,7 +923,7 @@
(cherry picked from commit d02fd482fbeaf6ed551e78223b538495cb0c3541)
-2019-01-05 Paul Eggert <eggert@cs.ucla.edu>
+2019-01-07 Paul Eggert <eggert@cs.ucla.edu>
Work around GC+Cairo bug
@@ -931,21 +931,21 @@
* src/ftfont.c (ftfont_close) [USE_CAIRO]:
Do nothing if GC is in progress.
-2019-01-05 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Improve commentary in font.h
* src/font.h (struct font, struct font_driver): Fix typos and
wording in comments. Document all driver methods.
-2019-01-04 Martin Rudalics <rudalics@gmx.at>
+2019-01-07 Martin Rudalics <rudalics@gmx.at>
Fix definition of Qwindow_point_insertion_type (Bug#33871)
* src/window.c (Qwindow_point_insertion_type): Fix definition
(Bug#33871).
-2019-01-04 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Improve documentation of 'server-name'
@@ -955,14 +955,14 @@
'server-name' to specify the server file as an absolute file
name. Do not merge to master. (Bug#33934)
-2019-01-04 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Update Unicode copyright notice
* admin/unidata/copyright.html: Updated version from the
Unicode Consortium's site.
-2019-01-02 Michael Albinus <michael.albinus@gmx.de>
+2019-01-07 Michael Albinus <michael.albinus@gmx.de>
Handle quoted file names in filenotify.el
@@ -973,31 +973,31 @@
(files-file-name-non-special-notify-handlers): Do not expect
to fail.
-2019-01-01 Paul Eggert <eggert@cs.ucla.edu>
+2019-01-07 Paul Eggert <eggert@cs.ucla.edu>
Fix copyright years by hand
These are dates that admin/update-copyright did not update, or
updated incorrectly.
-2019-01-01 Paul Eggert <eggert@cs.ucla.edu>
+2019-01-07 Paul Eggert <eggert@cs.ucla.edu>
Update copyright year to 2019
Run 'TZ=UTC0 admin/update-copyright $(git ls-files)'.
-2018-12-31 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
* doc/man/emacs.1.in: Fix value of default frame height. (Bug#33921)
-2018-12-30 Martin Rudalics <rudalics@gmx.at>
+2019-01-07 Martin Rudalics <rudalics@gmx.at>
In user manual fix value of default frame height (Bug#33921)
* doc/emacs/cmdargs.texi (Window Size X): Fix value of default
frame height (Bug#33921).
-2018-12-29 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Improve documentation of 'file-local-name' and related APIs
@@ -1014,14 +1014,14 @@
the documentation of the "local part" of a remote file name,
and its use in APIs that start remote processes.
-2018-12-29 Michael Albinus <michael.albinus@gmx.de>
+2019-01-07 Michael Albinus <michael.albinus@gmx.de>
Fix Bug#31704. Do not merge
* lisp/net/tramp.el (tramp-eshell-directory-change):
Use `path-separator' as it does eshell. (Bug#31704)
-2018-12-29 Michael Albinus <michael.albinus@gmx.de>
+2019-01-07 Michael Albinus <michael.albinus@gmx.de>
Fix Bug#31704. Do not merge
@@ -1032,38 +1032,38 @@
* lisp/net/tramp.el (tramp-eshell-directory-change):
Use `path-separator' as it does eshell. (Bug#31704)
-2018-12-29 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
* lisp/files.el (cd): Fix last change. (Bug#33791)
-2018-12-29 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Fix remote directories in Eshell on MS-Windows
* lisp/files.el (cd): Support remote directory names on
MS-Windows. (Bug#33791)
-2018-12-29 Drew Adams <drew.adams@oracle.com>
+2019-01-07 Drew Adams <drew.adams@oracle.com>
Fix :type 'group' in defcustom
* lisp/wid-edit.el (group): Fix the :format spec. (Bug#33566)
-2018-12-28 Alan Third <alan@idiocy.org>
+2019-01-07 Alan Third <alan@idiocy.org>
Fix NS fringe bitmap drawing bug (bug#33864)
* src/nsterm.m (ns_draw_fringe_bitmap): Check the rectangle to clear
correctly.
-2018-12-28 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Fix commentary in dispnew.c
* src/dispnew.c (buffer_posn_from_coords): Fix inaccuracies in
the commentary.
-2018-12-27 Paul Eggert <eggert@cs.ucla.edu>
+2019-01-07 Paul Eggert <eggert@cs.ucla.edu>
Improve accept-process-process doc
@@ -1073,14 +1073,14 @@
even after P has exited, and that it can return nil even if P
is still running (Bug#33839).
-2018-12-23 Stephen Leake <stephen_leake@stephe-leake.org>
+2019-01-07 Stephen Leake <stephen_leake@stephe-leake.org>
Fix a simple bug in display-buffer-use-some-frame
* lisp/window.el (display-buffer-use-some-frame): Simplify the
predicate, fix TYPE arg to window--display-buffer.
-2018-12-23 Michael Albinus <michael.albinus@gmx.de>
+2019-01-07 Michael Albinus <michael.albinus@gmx.de>
Clarify thread switching while waiting for process output
@@ -1088,7 +1088,7 @@
switching happens when waiting for process output from
asynchronous processes.
-2018-12-22 Charles A. Roelli <charles@aurox.ch>
+2019-01-07 Charles A. Roelli <charles@aurox.ch>
Improve process doc. with respect to handling of large input (Bug#33191)
@@ -1101,13 +1101,13 @@
also the comment about ICANON in src/sysdep.c, function
child_setup_tty.
-2018-12-22 Terrence Brannon <metaperl@gmail.com>
+2019-01-07 Terrence Brannon <metaperl@gmail.com>
Minor copyedits in landmark.el
* lisp/obsolete/landmark.el: Fix author's email and commentary.
-2018-12-20 Alan Mackenzie <acm@muc.de>
+2019-01-07 Alan Mackenzie <acm@muc.de>
Check result from c-backward-token-2 to avoid infinite loop
@@ -1116,7 +1116,7 @@
* lisp/progmodes/cc-fonts.el (c-get-fontification-context): While moving back
over enclosing parentheses, check that c-backward-token-2 actually moves.
-2018-12-19 Paul Eggert <eggert@cs.ucla.edu>
+2019-01-07 Paul Eggert <eggert@cs.ucla.edu>
cl-make-random-state was not copying its arg
@@ -1126,7 +1126,7 @@
* test/lisp/emacs-lisp/cl-extra-tests.el:
(cl-extra-test-cl-make-random-state): New test.
-2018-12-19 Glenn Morris <rgm@gnu.org>
+2019-01-07 Glenn Morris <rgm@gnu.org>
Skip a vc-bzr test if run as root
@@ -1134,7 +1134,7 @@
Skip this test when run as root. This works around a race
condition in root-specific code in vc-mode-line when deleting a file.
-2018-12-19 Chris Feng <chris.w.feng@gmail.com>
+2019-01-07 Chris Feng <chris.w.feng@gmail.com>
Backport: Handle unread-command-events consistently (bug#23980)
@@ -1145,7 +1145,7 @@
(cherry picked from commit 1f3f4b1296613b8cdc0632a68fde86e86ddad866)
-2018-12-19 Glenn Morris <rgm@gnu.org>
+2019-01-07 Glenn Morris <rgm@gnu.org>
Restrict downcasing in elisp xref tests (bug#25534)
@@ -1159,7 +1159,7 @@
(xref-elisp-test-run, emacs-test-dir): Only downcase if the
filesystem seems to be case-insensitive.
-2018-12-18 Rob Browning <rlb@defaultvalue.org>
+2019-01-07 Rob Browning <rlb@defaultvalue.org>
Avoid test failures if directory name looks like a regexp
@@ -1169,7 +1169,7 @@
Regexp-quote file names to avoid failures with directory names
of the form "build/emacs-i87jK3/emacs-26.1+1/...".
-2018-12-18 Michael Albinus <michael.albinus@gmx.de>
+2019-01-07 Michael Albinus <michael.albinus@gmx.de>
Fix Bug#33524
@@ -1177,11 +1177,11 @@
(flymake-proc-create-temp-with-folder-structure):
Unquote file-name. (Bug#33524)
-2018-12-17 Glenn Morris <rgm@gnu.org>
+2019-01-07 Glenn Morris <rgm@gnu.org>
* doc/lispintro/emacs-lisp-intro.texi (Finding More): Fix xref.
-2018-12-17 Paul Eggert <eggert@cs.ucla.edu>
+2019-01-07 Paul Eggert <eggert@cs.ucla.edu>
More porting to GCC 8 of --enable-gcc-warnings
@@ -1193,14 +1193,14 @@
No longer const.
* src/emacs-module.c: Ignore -Wcast-function-type.
-2018-12-15 Glenn Morris <rgm@gnu.org>
+2019-01-07 Glenn Morris <rgm@gnu.org>
Fix an epg test for recent GnuPG versions (bug#33439)
* test/lisp/epg-tests.el (epg-decrypt-1):
Tell recent GnuPG (e.g. 2.2.11) not to worry about missing MDC.
-2018-12-14 Robert Pluim <rpluim@gmail.com>
+2019-01-07 Robert Pluim <rpluim@gmail.com>
Document font structure layout constraints
@@ -1208,7 +1208,7 @@
* src/xftfont.c (struct xftfont_info): Document layout constraints.
-2018-12-14 Robert Pluim <rpluim@gmail.com>
+2019-01-07 Robert Pluim <rpluim@gmail.com>
Document font structure layout constraints
@@ -1219,7 +1219,7 @@
* src/ftfont.c (struct ftfont_info): Document layout constraints.
-2018-12-14 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Fix display of line numbers in empty lines beyond EOB
@@ -1228,7 +1228,7 @@
on that single line, but not on the rest of empty lines beyond
EOB. (Bug#33732)
-2018-12-11 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Fix redisplay when a window's scroll bar or fringes are changed
@@ -1237,14 +1237,14 @@
thorough redisplay of a window when scroll bars or fringes are
changed. (Bug#33694)
-2018-12-11 Martin Rudalics <rudalics@gmx.at>
+2019-01-07 Martin Rudalics <rudalics@gmx.at>
Tiny markup fix in Elisp manual
* doc/lispref/lists.texi (Building Lists): Use '@var' instead
of '@code' for argument.
-2018-12-10 Alan Mackenzie <acm@muc.de>
+2019-01-07 Alan Mackenzie <acm@muc.de>
CC Mode: stop extra parens on expression causing false fontification as type
@@ -1252,7 +1252,7 @@
arithmetic operator followed by several open parentheses, not just one, as not
being an argument list.
-2018-12-10 Ari Roponen <ari.roponen@gmail.com>
+2019-01-07 Ari Roponen <ari.roponen@gmail.com>
Fix cairo scrolling for side-by-side windows
@@ -1263,7 +1263,7 @@
(cherry picked from commit 6e362a32bc9d21f73a0f29ca6f45481edeea6f29)
-2018-12-10 Alan Mackenzie <acm@muc.de>
+2019-01-07 Alan Mackenzie <acm@muc.de>
CC Mode: stop wrongly recognizing "func(a * 9)" as "pointer to type a"
@@ -1272,11 +1272,11 @@
new flag variable got-number if one is found. In the test for CASE 18, check
this flag.
-2018-12-10 Stefan Monnier <monnier@iro.umontreal.ca>
+2019-01-07 Stefan Monnier <monnier@iro.umontreal.ca>
* lisp/emacs-lisp/cursor-sensor.el: Add motivation
-2018-12-10 Raimon Grau <raimonster@gmail.com>
+2019-01-07 Raimon Grau <raimonster@gmail.com>
Guard occur against an undefined orig-line
@@ -1285,14 +1285,14 @@
buffer with `list-matching-lines-jump-to-current-line' set to t.
(Bug#33476)
-2018-12-09 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Indexing followup to recent changes
* doc/lispref/text.texi (Special Properties): Index
'cursor-sensor-inhibit'. (Bug#33664)
-2018-12-09 Stefan Monnier <monnier@iro.umontreal.ca>
+2019-01-07 Stefan Monnier <monnier@iro.umontreal.ca>
Improve documentation of cursor-sensor.el (bug#33664)
@@ -1300,20 +1300,20 @@
* lisp/emacs-lisp/cursor-sensor.el (Commentary): Add cursor-sensor-mode.
(cursor-sensor-inhibit): Add docstring.
-2018-12-09 Stefan Monnier <monnier@iro.umontreal.ca>
+2019-01-07 Stefan Monnier <monnier@iro.umontreal.ca>
* doc/lispref/commands.texi (Adjusting Point): Bug#33662
Tweak text to clarify intangibility.
-2018-12-09 Michael Albinus <michael.albinus@gmx.de>
+2019-01-07 Michael Albinus <michael.albinus@gmx.de>
Tramp multi-hop methods must be inline
* doc/misc/tramp.texi (Ad-hoc multi-hops): Involved methods must
be inline methods.
-2018-12-08 Ari Roponen <ari.roponen@gmail.com>
+2019-01-07 Ari Roponen <ari.roponen@gmail.com>
Fix scaling problem in Cairo builds
@@ -1321,21 +1321,21 @@
(x_update_begin) [USE_CAIRO && USE_GTK]: Support scaling.
(Bug#33442)
-2018-12-06 Juri Linkov <juri@linkov.net>
+2019-01-07 Juri Linkov <juri@linkov.net>
* lisp/simple.el (next-line-or-history-element): Use current-column
in all position calculations.
(previous-line-or-history-element): Idem. (Bug#33640)
-2018-12-03 Martin Rudalics <rudalics@gmx.at>
+2019-01-07 Martin Rudalics <rudalics@gmx.at>
A few further fixes of window internals description
* doc/lispref/internals.texi (Window Internals): Add a few
more items and clarify description of some others.
-2018-12-02 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Revert "Revert "Fix infloop in GC mark_kboards""
@@ -1344,7 +1344,7 @@
with the behavior reported in bug#33571, which seems to be
the expected behavior.
-2018-12-02 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Revert "Fix infloop in GC mark_kboards"
@@ -1352,29 +1352,29 @@
since it caused unintended adverse effects on echoing of keys.
(Bug#33571)
-2018-12-02 Glenn Morris <rgm@gnu.org>
+2019-01-07 Glenn Morris <rgm@gnu.org>
* lisp/emacs-lisp/subr-x.el (if-let, when-let): Doc fix: active voice.
-2018-12-01 Paul Eggert <eggert@cs.ucla.edu>
+2019-01-07 Paul Eggert <eggert@cs.ucla.edu>
Fix infloop in GC mark_kboards
Do not merge to master, as I have a more systematic fix there.
* src/keyboard.c (mark_kboards): Fix infloop (Bug#33547).
-2018-12-01 Alan Third <alan@idiocy.org>
+2019-01-07 Alan Third <alan@idiocy.org>
Fix macOS run-time feature check
* src/nsterm.m (x_set_parent_frame) [NS_IMPL_COCOA]: Fix run-time
feature check.
-2018-12-01 Stefan Monnier <monnier@iro.umontreal.ca>
+2019-01-07 Stefan Monnier <monnier@iro.umontreal.ca>
* etc/NEWS-*: Fix capitalization of "Emacs"
-2018-12-01 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Fix "M-x man" when there's no 'man' program on PATH
@@ -1382,7 +1382,7 @@
buffer is not read-only when inserting a message into it.
(Bug#33510)
-2018-11-30 Paul Eggert <eggert@cs.ucla.edu>
+2019-01-07 Paul Eggert <eggert@cs.ucla.edu>
Fix core dump in dbus-message-internal
@@ -1390,11 +1390,11 @@
* src/dbusbind.c (Fdbus_message_internal):
Don’t go past array end (Bug#33530).
-2018-11-30 Michael Albinus <michael.albinus@gmx.de>
+2019-01-07 Michael Albinus <michael.albinus@gmx.de>
* doc/misc/dbus.texi (Type Conversion): Fix typo. (Bug#33551)
-2018-11-30 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Improve documentation of gdb-mi.el
@@ -1405,7 +1405,7 @@
(GDB User Interface Layout): Mention some additional
customizable variables. (Bug#33548)
-2018-11-29 Thomas Fitzsimmons <fitzsim@fitzsim.org>
+2019-01-07 Thomas Fitzsimmons <fitzsim@fitzsim.org>
LDAP: Set process-connection-type to t on Darwin
@@ -1413,32 +1413,32 @@
process-connection-type to t on Darwin. Do not merge to
master. (Bug#33050)
-2018-11-28 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Fix a typo in a doc string
* lisp/emacs-lisp/map-ynp.el (read-answer-short): Fix typo.
(Bug#33528)
-2018-11-28 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Minor markup fix in frames.texi
* doc/lispref/frames.texi (Frame Layout): Fix markup of @table
entries. (Bug#33531)
-2018-11-28 Glenn Morris <rgm@gnu.org>
+2019-01-07 Glenn Morris <rgm@gnu.org>
* lisp/net/trampver.el (customize-package-emacs-version-alist):
Add 2.3.3.
* lisp/mh-e/mh-e.el (customize-package-emacs-version-alist): Additions.
-2018-11-27 Glenn Morris <rgm@gnu.org>
+2019-01-07 Glenn Morris <rgm@gnu.org>
* lisp/emacs-lisp/map-ynp.el (map-y-or-n-p): Pass format to message.
-2018-11-27 Robert Pluim <rpluim@gmail.com>
+2019-01-07 Robert Pluim <rpluim@gmail.com>
Don't call xwidget functions until GTK has been initialized
@@ -1453,7 +1453,7 @@
initialized.
(xwidget_init_view): Likewise.
-2018-11-27 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Improve documentation of Ediff wordwise commands
@@ -1467,7 +1467,7 @@
https://lists.gnu.org/archive/html/help-gnu-emacs/2018-11/msg00197.html
for the details.
-2018-11-26 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Support Hunspell 1.7.0 in ispell.el
@@ -1477,7 +1477,7 @@
in Hunspell 1.7.0 that prevents it from reporting the loaded
dictionary. (Bug#33493)
-2018-11-26 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Avoid clearing echo-area message by auto-save-visited-file-name
@@ -1485,14 +1485,14 @@
previous echo-area message, if any, and restore it before
exiting. (Bug#33490)
-2018-11-25 Alan Third <alan@idiocy.org>
+2019-01-07 Alan Third <alan@idiocy.org>
Set tooltip text color (bug#33452)
* src/nsmenu.m: ([EmacsTooltip init]): Set text color to black.
-2018-11-25 Alan Third <alan@idiocy.org>
+2019-01-07 Alan Third <alan@idiocy.org>
Fix more drawing bugs in NS port (bug#32932)
@@ -1509,7 +1509,7 @@
* src/xdisp.c (expose_window_tree) [HAVE_NS]:
(expose_frame) [HAVE_NS]: Redraw even if the frame is garbaged.
-2018-11-24 Alan Mackenzie <acm@muc.de>
+2019-01-07 Alan Mackenzie <acm@muc.de>
Fix bug #33416, where typing a ) in a comment at EOB caused a loop (CC Mode).
@@ -1517,7 +1517,7 @@
point inside whitespace when moving over a comment at EOB which has no
terminating LF. Check this possibility and correct for it.
-2018-11-24 Ulrich Müller <ulm@gentoo.org>
+2019-01-07 Ulrich Müller <ulm@gentoo.org>
Update the calc units table
@@ -1530,7 +1530,7 @@
* lisp/calc/calc-units.el (math-standard-units): Update according
to redefinition of the SI in 2018. (Bug#33412)
-2018-11-24 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Improve indexing in the ELisp manual
@@ -1542,7 +1542,7 @@
(Quoting, Backquote): Add index entries that begin with
"forms". (Bug#33440)
-2018-11-23 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
More Symbola-related extensions for default fontset
@@ -1550,14 +1550,14 @@
few more blocks of symbols and punctuation supported by latest
Symbola.
-2018-11-23 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Better support for display of U+1F900..U+1F9FF block
* lisp/international/fontset.el (setup-default-fontset): Add
the [#x1F900..#x1F9FF] block to those supported by Symbola.
-2018-11-23 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Improve documentation of 'edit-abbrevs-mode'
@@ -1565,7 +1565,7 @@
for more detailed usage information. (Bug#33443)
(edit-abbrevs): Doc fix.
-2018-11-22 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Improve documentation of 'dired-do-compress'
@@ -1573,7 +1573,7 @@
string the effect on directories and on compressed archive.
(Bug#33450)
-2018-11-22 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Improve doc string and display of 'describe-character'
@@ -1582,11 +1582,11 @@
display "preferred" before "charset": it tends to confuse
people.
-2018-11-21 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
* etc/NEWS: Clarify what 'Z' does in Dired. (Bug#33450)
-2018-11-20 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Update the docs of object internals
@@ -1594,7 +1594,7 @@
(Window Internals, Process Internals): Update the descriptions
of Lisp objects.
-2018-11-19 Stephen Berman <stephen.berman@gmx.net>
+2019-01-07 Stephen Berman <stephen.berman@gmx.net>
Fix two Edebug defcustoms (bug#33428)
@@ -1602,14 +1602,14 @@
(edebug-print-level): Fix customization type to allow setting
the documented valid value nil via the Customize interface.
-2018-11-19 Michael Albinus <michael.albinus@gmx.de>
+2019-01-07 Michael Albinus <michael.albinus@gmx.de>
Fix Bug#33141
* lisp/net/tramp.el (tramp-make-tramp-file-name): Avoid check for
empty method with simplified `tramp-syntax'. (Bug#33141)
-2018-11-19 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Improve documentation of the window tree
@@ -1620,7 +1620,7 @@
* src/window.h (struct window): Improve commentary to some
fields.
-2018-11-19 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Fix window scrolling on TTY frames when there's no mode line
@@ -1628,7 +1628,7 @@
next, prev, and parent pointers, as they are unrelated to
whether a window has a mode line. (Bug#33363)
-2018-11-19 Eli Zaretskii <eliz@gnu.org>
+2019-01-07 Eli Zaretskii <eliz@gnu.org>
Fix decoding XML files encoded in ISO-8859
@@ -1637,7 +1637,7 @@
encoding tag specifies an encoding whose type is 'charset'.
(Bug#33429)
-2018-11-19 Nicolas Petton <nicolas@petton.fr>
+2019-01-07 Nicolas Petton <nicolas@petton.fr>
* etc/AUTHORS: Update.
diff --git a/INSTALL b/INSTALL
index 72bba25df81..80223850100 100644
--- a/INSTALL
+++ b/INSTALL
@@ -318,6 +318,12 @@ features enabled, you can combine --without-all with --with-FEATURE.
For example, you can use --without-all --without-x --with-dbus to
build with D-Bus support and nothing more.
+Use --with-gnutls=ifavailable to use GnuTLS if available but go ahead
+and build without it if not available. This overrides Emacs's default
+behavior of refusing to build if GnuTLS is absent. When X11 support
+is enabled, the libraries for gif, jpeg, png, tiff, and xpm are in the
+same strongly-recommended category as GnuTLS, and have similar options.
+
Use --with-wide-int to implement Emacs values with the type 'long long',
even on hosts where a narrower type would do. With this option, on a
typical 32-bit host, Emacs integers have 62 bits instead of 30.
diff --git a/Makefile.in b/Makefile.in
index 364deeae226..53703638c42 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -66,6 +66,8 @@
SHELL = @SHELL@
+DUMPING=@DUMPING@
+
# This only matters when inheriting a CDPATH not starting with the
# current directory.
CDPATH=
@@ -491,6 +493,9 @@ install-arch-dep: src install-arch-indep install-etcdoc install-$(NTDIR)
$(MAKE) -C lib-src install
ifeq (${ns_self_contained},no)
${INSTALL_PROGRAM} $(INSTALL_STRIP) src/emacs${EXEEXT} "$(DESTDIR)${bindir}/$(EMACSFULL)"
+ifeq (${DUMPING},pdumper)
+ ${INSTALL_DATA} src/emacs.pdmp "$(DESTDIR)${libexecdir}/emacs/${version}/${configuration}"/emacs.pdmp
+endif
-chmod 755 "$(DESTDIR)${bindir}/$(EMACSFULL)"
ifndef NO_BIN_LINK
rm -f "$(DESTDIR)${bindir}/$(EMACS)"
@@ -519,9 +524,11 @@ INSTALL_ARCH_INDEP_EXTRA = @INSTALL_ARCH_INDEP_EXTRA@
## https://lists.gnu.org/r/emacs-devel/2007-10/msg01672.html
## Needs to be the user running install, so configure can't set it.
set_installuser=for installuser in $${LOGNAME} $${USERNAME} $${USER} \
- `id -un 2> /dev/null`; do \
+ `(id -u) 2> /dev/null`; do \
[ -n "$${installuser}" ] && break ; \
- done
+ done; \
+ installgroup=`(id -g) 2>/dev/null` && [ -n "$$installgroup" ] && \
+ installuser=$$installuser:$$installgroup
### Install the files that are machine-independent.
### Most of them come straight from the distribution; the exception is
@@ -784,7 +791,9 @@ uninstall: uninstall-$(NTDIR) uninstall-doc
(if cd "$(DESTDIR)${icondir}"; then \
rm -f hicolor/*x*/apps/"${EMACS_NAME}.png" \
"hicolor/scalable/apps/${EMACS_NAME}.svg" \
- hicolor/scalable/mimetypes/`echo emacs-document | sed '$(TRANSFORM)'`.svg; \
+ "hicolor/scalable/apps/${EMACS_NAME}.ico" \
+ "hicolor/scalable/mimetypes/${EMACS_NAME}-document.svg" \
+ "hicolor/scalable/mimetypes/${EMACS_NAME}-document23.svg"; \
fi)
-rm -f "$(DESTDIR)${desktopdir}/${EMACS_NAME}.desktop"
-rm -f "$(DESTDIR)${appdatadir}/${EMACS_NAME}.appdata.xml"
@@ -843,7 +852,7 @@ $(foreach dir,$(clean_dirs),$(eval $(call submake_template,$(dir),clean)))
clean: $(clean_dirs:=_clean)
$(MAKE) -C admin/charsets $@
[ ! -d test ] || $(MAKE) -C test $@
- -rm -f *.tmp etc/*.tmp*
+ -rm -f ./*.tmp etc/*.tmp*
-rm -rf info-dir.*
### 'bootclean'
@@ -930,12 +939,14 @@ $(foreach dir,$(extraclean_dirs),$(eval $(call submake_template,$(dir),extraclea
extraclean: $(extraclean_dirs:=_extraclean)
${top_maintainer_clean}
-rm -f config-tmp-*
- -rm -f *~ \#*
+ -rm -f ./*~ \#*
# The src subdir knows how to do the right thing
# even when the build directory and source dir are different.
.PHONY: TAGS tags
-TAGS tags: lib lib-src src
+# FIXME: We used to include `src` in the dependencies, not sure why.
+# I removed it because it causes `make tags` to build Emacs.
+TAGS tags: lib lib-src # src
$(MAKE) -C src tags
.PHONY: have-tests
@@ -1164,3 +1175,14 @@ check-declare:
exit 1; \
fi
$(MAKE) -C lisp $@
+ $(MAKE) -C test $@
+
+.PHONY: gitmerge
+
+GITMERGE_EMACS = ./src/emacs${EXEEXT}
+GITMERGE_NMIN = 10
+
+gitmerge:
+ ${GITMERGE_EMACS} -batch --no-site-file --no-site-lisp \
+ -l ${srcdir}/admin/gitmerge.el \
+ --eval '(setq gitmerge-minimum-missing ${GITMERGE_NMIN})' -f gitmerge
diff --git a/README b/README
index b115838b9fd..723681607ce 100644
--- a/README
+++ b/README
@@ -2,7 +2,7 @@ Copyright (C) 2001-2019 Free Software Foundation, Inc.
See the end of the file for license conditions.
-This directory tree holds version 26.1.92 of GNU Emacs, the extensible,
+This directory tree holds version 27.0.50 of GNU Emacs, the extensible,
customizable, self-documenting real-time display editor.
The file INSTALL in this directory says how to build and install GNU
diff --git a/admin/CPP-DEFINES b/admin/CPP-DEFINES
index 7a90b3dbe4f..ea99d50094f 100644
--- a/admin/CPP-DEFINES
+++ b/admin/CPP-DEFINES
@@ -19,7 +19,6 @@ __DJGPP_MINOR__ Minor version number of the DJGPP library; used only in msdos.c
DOS_NT Compiling for either the MS-DOS or native MS-Windows port.
WINDOWSNT Compiling the native MS-Windows (W32) port.
__MINGW32__ Compiling the W32 port with the MinGW or MinGW-w64 ports of GCC.
-_MSC_VER Compiling the W32 port with the Microsoft C compiler.
MINGW_W64 Compiling the W32 port with the MinGW-w64 port of GCC.
DARWIN_OS Compiling on macOS or pure Darwin (and using s/darwin.h).
SOLARIS2
@@ -105,7 +104,6 @@ HAVE_ALLOCA_H
HAVE_ALSA
HAVE_BDFFONT
HAVE_BOXES
-HAVE_C99_STRTOLD
HAVE_CFMAKERAW
HAVE_CFSETSPEED
HAVE_CLOCK_GETTIME
@@ -182,7 +180,6 @@ HAVE_GTK_WINDOW_SET_HAS_RESIZE_GRIP
HAVE_G_TYPE_INIT
HAVE_IFADDRS_H
HAVE_IMAGEMAGICK
-HAVE_INET_SOCKETS
HAVE_INTTYPES_H
HAVE_JPEG
HAVE_KERBEROSIV_KRB_H
diff --git a/admin/MAINTAINERS b/admin/MAINTAINERS
index cbf84d55df5..05faa586c20 100644
--- a/admin/MAINTAINERS
+++ b/admin/MAINTAINERS
@@ -37,7 +37,7 @@ Kenichi Handa
Mule
Stefan Monnier
- src/regex.c
+ src/regex-emacs.c
src/syntax.c
src/keymap.c
font-lock/jit-lock/syntax
@@ -240,6 +240,14 @@ Vibhav Pant
lisp/net/browse-url.el
lisp/erc/*
+Alan Third
+ The NS port:
+ nextstep/*
+ src/ns*
+ src/*.m
+ lisp/term/ns-win.el
+ doc/emacs/macos.texi
+
;;; Local Variables:
;;; coding: utf-8
diff --git a/admin/admin.el b/admin/admin.el
index 41b1854c90d..650cf47b807 100644
--- a/admin/admin.el
+++ b/admin/admin.el
@@ -144,7 +144,7 @@ Root must be the root of an Emacs source tree."
(unless (> (length newversion) 2) ; pretest or release candidate?
(with-temp-buffer
(insert-file-contents newsfile)
- (if (re-search-forward "^\\(+++ *\\|--- *\\)$" nil t)
+ (if (re-search-forward "^\\(\\+\\+\\+ *\\|--- *\\)$" nil t)
(display-warning 'admin
"NEWS file still contains temporary markup.
Documentation changes might not have been completed!"))))
@@ -657,7 +657,7 @@ style=\"text-align:left\">")
(defconst make-manuals-dist-output-variables
- `(("@\\(top_\\)?srcdir@" . ".") ; top_srcdir is wrong, but not used
+ '(("@\\(top_\\)?srcdir@" . ".") ; top_srcdir is wrong, but not used
("^\\(\\(?:texinfo\\|buildinfo\\|emacs\\)dir *=\\).*" . "\\1 .")
("^\\(clean:.*\\)" . "\\1 infoclean")
("@MAKEINFO@" . "makeinfo")
diff --git a/admin/automerge b/admin/automerge
new file mode 100755
index 00000000000..405fd9ed614
--- /dev/null
+++ b/admin/automerge
@@ -0,0 +1,259 @@
+#!/bin/bash
+### automerge - automatically merge the Emacs release branch to master
+
+## Copyright (C) 2018-2019 Free Software Foundation, Inc.
+
+## Author: Glenn Morris <rgm@gnu.org>
+
+## 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 <https://www.gnu.org/licenses/>.
+
+### Commentary:
+
+## Automatically merge the Emacs release branch to master.
+## If the merge succeeds, optionally build and test the results,
+## and then push it.
+## Intended usage:
+## Have a dedicated git directory just for this.
+## Have a cron job that calls this script with -r -p.
+##
+## Modifying a running shell script can have unpredictable results,
+## so the paranoid will first make a copy of this script, and then run
+## it with the -d option in the repository directory, in case a pull
+## updates this script while it is working.
+
+die () # write error to stderr and exit
+{
+ [ $# -gt 0 ] && echo "$PN: $@" >&2
+ exit 1
+}
+
+PN=${0##*/} # basename of script
+PD=${0%/*}
+
+[ "$PD" = "$0" ] && PD=. # if PATH includes PWD
+
+usage ()
+{
+ cat 1>&2 <<EOF
+Usage: ${PN} [-b] [-d] [-e emacs] [-n nmin] [-p] [-r] [-t] [-- mflags]
+Merge the Emacs release branch to master.
+Passes any non-option args to make (eg -- -j2).
+Options:
+-d: no initial cd to parent of script directory
+-e: Emacs executable to use for the initial merge (default $emacs)
+-n: minimum number of commits to try merging (default $nmin)
+-b: try to build after merging
+-t: try to check after building
+-p: if merge, build, check all succeed, push when finished (caution!)
+-r: start by doing a hard reset (caution!) and pull
+EOF
+ exit 1
+}
+
+
+## Defaults.
+
+emacs=emacs
+nmin=10
+build=
+test=
+push=
+quiet=
+reset=
+nocd=
+
+while getopts ":hbde:n:pqrt" option ; do
+ case $option in
+ (h) usage ;;
+
+ (b) build=1 ;;
+
+ (d) nocd=1 ;;
+
+ (e) emacs=$OPTARG ;;
+
+ (n) nmin=$OPTARG ;;
+
+ (p) push=1 ;;
+
+ (q) quiet=1 ;;
+
+ (r) reset=1 ;;
+
+ (t) test=1 ;;
+
+ (\?) die "Bad option -$OPTARG" ;;
+
+ (:) die "Option -$OPTARG requires an argument" ;;
+
+ (*) die "getopts error" ;;
+ esac
+done
+shift $(( --OPTIND ))
+OPTIND=1
+
+
+[ "$nocd" ] || {
+ cd $PD # this should be the admin directory
+ cd ../
+}
+
+[ -d admin ] || die "Could not locate admin directory"
+
+[ -e .git ] || die "No .git"
+
+
+## Does not work 100% because a lot of Emacs batch output comes on
+## stderr (?).
+[ "$quiet" ] && exec 1> /dev/null
+
+
+[ "$push" ] && test=1
+[ "$test" ] && build=1
+
+
+tempfile=/tmp/$PN.$$
+
+trap "rm -f $tempfile 2> /dev/null" EXIT
+
+
+[ -e Makefile ] && [ "$build" ] && {
+ echo "Cleaning..."
+ make maintainer-clean >& /dev/null
+}
+
+
+[ "$reset" ] && {
+ echo "Resetting..."
+ git reset -q --hard origin/master || die "reset error"
+
+ echo "Pulling..."
+ git pull -q --ff-only || die "pull error"
+}
+
+
+rev=$(git rev-parse HEAD)
+
+[ $(git rev-parse @{u}) = $rev ] || die "Local state does not match origin"
+
+
+merge ()
+{
+ echo "Merging..."
+
+ if $emacs --batch -Q -l ./admin/gitmerge.el \
+ --eval "(setq gitmerge-minimum-missing $nmin)" -f gitmerge \
+ >| $tempfile 2>&1; then
+ echo "merged ok"
+ return 0
+
+ else
+ grep -E "Nothing to merge|Number of missing commits" $tempfile && \
+ exit 0
+
+ cat "$tempfile" 1>&2
+
+ die "merge error"
+ fi
+}
+
+
+merge
+
+
+## FIXME it would be better to trap this in gitmerge.
+## NEWS should never be modified, only eg NEWS.26.
+git diff --stat --cached origin/master | grep -q "etc/NEWS " && \
+ die "etc/NEWS has been modified"
+
+
+[ "$build" ] || exit 0
+
+
+echo "Running autoreconf..."
+
+autoreconf -i -I m4 2>| $tempfile
+
+retval=$?
+
+## Annoyingly, autoreconf puts the "installing `./foo' messages on stderr.
+if [ "$quiet" ]; then
+ grep -v 'installing `\.' $tempfile 1>&2
+else
+ cat "$tempfile" 1>&2
+fi
+
+[ $retval -ne 0 ] && die "autoreconf error"
+
+
+echo "Running ./configure..."
+
+## Minimize required packages.
+./configure --without-x || die "configure error"
+
+
+echo "Building..."
+
+make "$@" || die "make error"
+
+echo "Build finished ok"
+
+
+[ "$test" ] || exit 0
+
+
+echo "Testing..."
+
+## We just want a fast pass/fail, we don't want to debug.
+make "$@" check TEST_LOAD_EL=no || die "check error"
+
+echo "Tests finished ok"
+
+
+[ "$push" ] || exit 0
+
+
+## In case someone else pushed while we were working.
+echo "Checking for remote changes..."
+git fetch || die "fetch error"
+
+[ $(git rev-parse @{u}) = $rev ] || {
+
+ echo "Upstream has changed"
+
+ ## Rebasing would be incorrect, since it would rewrite the
+ ## (already published) release branch commits.
+ ## Ref eg http://lists.gnu.org/r/emacs-devel/2014-12/msg01435.html
+ ## Instead, we throw away what we just did, and do the merge again.
+ echo "Resetting..."
+ git reset --hard $rev
+
+ echo "Pulling..."
+ git pull --ff-only || die "pull error"
+
+ merge
+
+ ## If the merge finished ok again, we don't bother doing a second
+ ## build and test.
+}
+
+echo "Pushing..."
+git push || die "push error"
+
+
+exit 0
+
+### automerge ends here
diff --git a/admin/bzrmerge.el b/admin/bzrmerge.el
deleted file mode 100644
index 8c4a444bdcd..00000000000
--- a/admin/bzrmerge.el
+++ /dev/null
@@ -1,359 +0,0 @@
-;;; bzrmerge.el --- help merge one Emacs bzr branch to another
-
-;; Copyright (C) 2010-2019 Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords: maint
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Some usage notes are in admin/notes/bzr.
-
-;;; Code:
-
-(eval-when-compile (require 'cl-lib))
-
-(defvar bzrmerge-skip-regexp
- "back[- ]?port\\|merge\\|sync\\|re-?generate\\|bump version\\|from trunk\\|\
-Auto-commit"
- "Regexp matching logs of revisions that might be skipped.
-`bzrmerge-missing' will ask you if it should skip any matches.")
-
-(defconst bzrmerge-buffer "*bzrmerge*"
- "Working buffer for bzrmerge.")
-
-(defconst bzrmerge-warning-buffer "*bzrmerge warnings*"
- "Buffer where bzrmerge will display any warnings.")
-
-(defun bzrmerge-merges ()
- "Return the list of already merged (not yet committed) revisions.
-The list returned is sorted by oldest-first."
- (with-current-buffer (get-buffer-create bzrmerge-buffer)
- (erase-buffer)
- ;; We generally want to make sure we start with a clean tree, but we also
- ;; want to allow restarts (i.e. with some part of FROM already merged but
- ;; not yet committed). Unversioned (unknown) files in the tree
- ;; are also ok.
- (call-process "bzr" nil t nil "status" "-v")
- (goto-char (point-min))
- (when (re-search-forward "^conflicts:\n" nil t)
- (user-error "You still have unresolved conflicts"))
- (let ((merges ())
- found)
- (if (not (re-search-forward "^pending merges:\n" nil t))
- (when (save-excursion
- (goto-char (point-min))
- (while (and
- (re-search-forward "^\\([a-z ]*\\):\n" nil t)
- (not
- (setq found
- (not (equal "unknown" (match-string 1)))))))
- found)
- (user-error "You still have uncommitted changes"))
- ;; This is really stupid, but it seems there's no easy way to figure
- ;; out which revisions have been merged already. The only info I can
- ;; find is the "pending merges" from "bzr status -v", which is not
- ;; very machine-friendly.
- (while (not (eobp))
- (skip-chars-forward " ")
- (push (buffer-substring (point) (line-end-position)) merges)
- (forward-line 1)))
- merges)))
-
-(defun bzrmerge-check-match (merge)
- ;; Make sure the MERGES match the revisions on the FROM branch.
- ;; Stupidly the best form of MERGES I can find is the one from
- ;; "bzr status -v" which is very machine non-friendly, so I have
- ;; to do some fuzzy matching.
- (let ((author
- (or
- (save-excursion
- (if (re-search-forward "^author: *\\([^<]*[^ ]\\) +<.*"
- nil t)
- (match-string 1)))
- (save-excursion
- (if (re-search-forward
- "^committer: *\\([^<]*[^< ]\\) +<" nil t)
- (match-string 1)))))
- (timestamp
- (save-excursion
- (if (re-search-forward
- "^timestamp:[^0-9]*\\([-0-9]+\\)" nil t)
- (match-string 1))))
- (line1
- (save-excursion
- (if (re-search-forward "^message:[ \n]*" nil t)
- (buffer-substring (point) (line-end-position))))))
- ;; The `merge' may have a truncated line1 with "...", so get
- ;; rid of any "..." and then look for a prefix match.
- (when (string-match "\\.+\\'" merge)
- (setq merge (substring merge 0 (match-beginning 0))))
- (or (string-prefix-p
- merge (concat author " " timestamp " " line1))
- (string-prefix-p
- merge (concat author " " timestamp " [merge] " line1)))))
-
-(defun bzrmerge-missing (from merges)
- "Return the list of revisions that need to be merged.
-MERGES is the revisions already merged but not yet committed.
-Asks about skipping revisions with logs matching `bzrmerge-skip-regexp'.
-The result is of the form (TOMERGE . TOSKIP) where TOMERGE and TOSKIP
-are both lists of revnos, in oldest-first order."
- (with-current-buffer (get-buffer-create bzrmerge-buffer)
- (erase-buffer)
- (call-process "bzr" nil t nil "missing" "--theirs-only"
- (expand-file-name from))
- (let ((revnos ()) (skipped ()))
- (pop-to-buffer (current-buffer))
- (goto-char (point-max))
- (while (re-search-backward "^------------------------------------------------------------\nrevno: \\([0-9.]+\\).*" nil t)
- (save-excursion
- (if merges
- (while (not (bzrmerge-check-match (pop merges)))
- (unless merges
- (error "Unmatched tip of merged revisions")))
- (let ((case-fold-search t)
- (revno (match-string 1))
- (skip nil))
- (if (string-match "\\." revno)
- (error "Unexpected dotted revno!")
- (setq revno (string-to-number revno)))
- (re-search-forward "^message:\n")
- (while (and (not skip)
- (re-search-forward bzrmerge-skip-regexp nil t))
- (let ((str (buffer-substring (line-beginning-position)
- (line-end-position))))
- (when (string-match "\\` *" str)
- (setq str (substring str (match-end 0))))
- (when (string-match "[.!;, ]+\\'" str)
- (setq str (substring str 0 (match-beginning 0))))
- (let ((help-form (substitute-command-keys "\
-Type `y' to skip this revision,
-`N' to include it and go on to the next revision,
-`n' to not skip, but continue to search this log entry for skip regexps,
-`q' to quit merging.")))
- (pcase (save-excursion
- (read-char-choice
- (format "%s: Skip (y/n/N/q/%s)? " str
- (key-description (vector help-char)))
- '(?y ?n ?N ?q)))
- (`?y (setq skip t))
- (`?q (keyboard-quit))
- ;; A single log entry can match skip-regexp multiple
- ;; times. If you are sure you don't want to skip it,
- ;; you don't want to be asked multiple times.
- (`?N (setq skip 'no))))))
- (if (eq skip t)
- (push revno skipped)
- (push revno revnos)))))
- (delete-region (point) (point-max)))
- (and (or revnos skipped)
- (cons (nreverse revnos) (nreverse skipped))))))
-
-(defun bzrmerge-resolve (file)
- (unless (file-exists-p file) (error "Bzrmerge-resolve: Can't find %s" file))
- (with-demoted-errors
- (let ((exists (find-buffer-visiting file)))
- (with-current-buffer (let ((enable-local-variables :safe)
- (enable-local-eval nil))
- (find-file-noselect file))
- (if (buffer-modified-p)
- (user-error "Unsaved changes in %s" (current-buffer)))
- (save-excursion
- (cond
- ((derived-mode-p 'change-log-mode)
- ;; Fix up dates before resolving the conflicts.
- (goto-char (point-min))
- (let ((diff-auto-refine-mode nil))
- (while (re-search-forward smerge-begin-re nil t)
- (smerge-match-conflict)
- (smerge-ensure-match 3)
- (let ((start1 (match-beginning 1))
- (end1 (match-end 1))
- (start3 (match-beginning 3))
- (end3 (copy-marker (match-end 3) t)))
- (goto-char start3)
- (while (re-search-forward change-log-start-entry-re end3 t)
- (let* ((str (match-string 0))
- (newstr (save-match-data
- (concat (add-log-iso8601-time-string)
- (when (string-match " *\\'" str)
- (match-string 0 str))))))
- (replace-match newstr t t)))
- ;; change-log-resolve-conflict prefers to put match-1's
- ;; elements first (for equal dates), whereas we want to put
- ;; match-3's first.
- (let ((match3 (buffer-substring start3 end3))
- (match1 (buffer-substring start1 end1)))
- (delete-region start3 end3)
- (goto-char start3)
- (insert match1)
- (delete-region start1 end1)
- (goto-char start1)
- (insert match3)))))
- ;; (pop-to-buffer (current-buffer)) (debug 'before-resolve)
- ))
- ;; Try to resolve the conflicts.
- (cond
- ((member file '("configure" "lisp/ldefs-boot.el"
- "lisp/emacs-lisp/cl-loaddefs.el"))
- ;; We are in the file's buffer, so names are relative.
- (call-process "bzr" nil t nil "revert"
- (file-name-nondirectory file))
- (revert-buffer nil 'noconfirm))
- (t
- (goto-char (point-max))
- (while (re-search-backward smerge-begin-re nil t)
- (save-excursion
- (ignore-errors
- (smerge-match-conflict)
- (smerge-resolve))))
- ;; (when (derived-mode-p 'change-log-mode)
- ;; (pop-to-buffer (current-buffer)) (debug 'after-resolve))
- (save-buffer)))
- (goto-char (point-min))
- (prog1 (re-search-forward smerge-begin-re nil t)
- (unless exists (kill-buffer))))))))
-
-(defun bzrmerge-add-metadata (from endrevno)
- "Add the metadata for a merge of FROM upto ENDREVNO.
-Does not make other difference."
- (if (with-temp-buffer
- (call-process "bzr" nil t nil "status")
- (goto-char (point-min))
- (re-search-forward "^conflicts:\n" nil t))
- (error "Don't know how to add metadata in the presence of conflicts")
- (call-process "bzr" nil t nil "shelve" "--all"
- "-m" "Bzrmerge shelved merge during skipping")
- (call-process "bzr" nil t nil "revert")
- (call-process "bzr" nil t nil
- "merge" "-r" (format "%s" endrevno) from)
- (call-process "bzr" nil t nil "revert" ".")
- (call-process "bzr" nil t nil "unshelve")))
-
-(defvar bzrmerge-already-done nil)
-
-(defun bzrmerge-apply (missing from)
- (setq from (expand-file-name from))
- (with-current-buffer (get-buffer-create bzrmerge-buffer)
- (erase-buffer)
- (when (equal (cdr bzrmerge-already-done) (list from missing))
- (setq missing (car bzrmerge-already-done)))
- (setq bzrmerge-already-done nil)
- (let ((merge (car missing))
- (skip (cdr missing))
- (unsafe nil)
- beg end)
- (when (or merge skip)
- (cond
- ((and skip (or (null merge) (< (car skip) (car merge))))
- ;; Do a "skip" (i.e. merge the meta-data only).
- (setq beg (1- (car skip)))
- (while (and skip (or (null merge) (< (car skip) (car merge))))
- (cl-assert (> (car skip) (or end beg)))
- (setq end (pop skip)))
- (message "Skipping %s..%s" beg end)
- (bzrmerge-add-metadata from end))
-
- (t
- ;; Do a "normal" merge.
- (cl-assert (or (null skip) (< (car merge) (car skip))))
- (setq beg (1- (car merge)))
- (while (and merge (or (null skip) (< (car merge) (car skip))))
- (cl-assert (> (car merge) (or end beg)))
- (setq end (pop merge)))
- (message "Merging %s..%s" beg end)
- (if (with-temp-buffer
- (call-process "bzr" nil t nil "status")
- (zerop (buffer-size)))
- (call-process "bzr" nil t nil
- "merge" "-r" (format "%s" end) from)
- ;; Stupidly, "bzr merge --force -r A..B" dos not maintain the
- ;; metadata properly except when the checkout is clean.
- (call-process "bzr" nil t nil "merge"
- "--force" "-r" (format "%s..%s" beg end) from)
- ;; The merge did not update the metadata, so force the next time
- ;; around to update it (as a "skip").
- (setq unsafe t)
- (push end skip))
- (pop-to-buffer (current-buffer))
- (sit-for 1)
- ;; (debug 'after-merge)
- ;; Check the conflicts.
- ;; FIXME if using the helpful bzr changelog_merge plugin,
- ;; there are normally no conflicts in ChangeLogs.
- ;; But we still want the dates fixing, like bzrmerge-resolve does.
- (let ((conflicted nil)
- (files ()))
- (goto-char (point-min))
- (when (re-search-forward "bzr: ERROR:" nil t)
- (error "Internal Bazaar error!!"))
- (while (re-search-forward "^Text conflict in " nil t)
- (push (buffer-substring (point) (line-end-position)) files))
- (if (re-search-forward "^\\([0-9]+\\) conflicts encountered" nil t)
- (if (/= (length files) (string-to-number (match-string 1)))
- (setq conflicted t))
- (if files (setq conflicted t)))
- (dolist (file files)
- (if (bzrmerge-resolve file)
- (setq conflicted t)))
- (when conflicted
- (setq bzrmerge-already-done
- (list (cons merge skip) from missing))
- (if unsafe
- ;; FIXME: Obviously, we'd rather make it right rather
- ;; than output such a warning. But I don't know how to add
- ;; the metadata to bzr's since the technique used in
- ;; bzrmerge-add-metadata does not work when there
- ;; are conflicts.
- (display-warning 'bzrmerge "Resolve conflicts manually.
-BEWARE! Important metadata is kept in this Emacs session!
-Do not commit without re-running `M-x bzrmerge' first!"
- :warning bzrmerge-warning-buffer))
- (user-error "Resolve conflicts manually")))))
- (cons merge skip)))))
-
-(defun bzrmerge (from)
- "Merge from branch FROM into `default-directory'."
- (interactive
- (list
- (let ((def
- (with-temp-buffer
- (call-process "bzr" nil t nil "info")
- (goto-char (point-min))
- (when (re-search-forward "submit branch: *" nil t)
- (buffer-substring (point) (line-end-position))))))
- (read-file-name "From branch: " nil nil nil def))))
- ;; Eg we ran bzrmerge once, it stopped with conflicts, we fixed them
- ;; and are running it again.
- (if (get-buffer bzrmerge-warning-buffer)
- (kill-buffer bzrmerge-warning-buffer))
- (message "Merging from %s..." from)
- (require 'vc-bzr)
- (let ((default-directory (or (vc-bzr-root default-directory)
- (error "Not in a Bzr tree"))))
- ;; First, check the status.
- (let* ((merges (bzrmerge-merges))
- ;; OK, we have the status, now check the missing data.
- (missing (bzrmerge-missing from merges)))
- (if (not missing)
- (message "Merging from %s...nothing to merge" from)
- (while missing
- (setq missing (bzrmerge-apply missing from)))
- (message "Merging from %s...done" from)))))
-
-(provide 'bzrmerge)
-;;; bzrmerge.el ends here
diff --git a/admin/find-gc.el b/admin/find-gc.el
index c985b1f7b21..bf93c4eedf4 100644
--- a/admin/find-gc.el
+++ b/admin/find-gc.el
@@ -57,7 +57,7 @@ Each entry has the form (FUNCTION . FUNCTIONS-IT-CALLS).")
"keymap.c" "sysdep.c" "buffer.c" "filelock.c"
"insdel.c" "marker.c" "minibuf.c" "fileio.c"
"dired.c" "cmds.c" "casefiddle.c"
- "indent.c" "search.c" "regex.c" "undo.c"
+ "indent.c" "search.c" "regex-emacs.c" "undo.c"
"alloc.c" "data.c" "doc.c" "editfns.c"
"callint.c" "eval.c" "fns.c" "print.c" "lread.c"
"syntax.c" "unexcoff.c"
diff --git a/admin/gitmerge.el b/admin/gitmerge.el
index bcf32f12e7f..edf43797304 100644
--- a/admin/gitmerge.el
+++ b/admin/gitmerge.el
@@ -50,11 +50,22 @@
(defvar gitmerge-skip-regexp
;; We used to include "sync" in there, but in my experience it only
;; caused false positives. --Stef
- "back[- ]?port\\|cherry picked from commit\\|\\(do\\( no\\|n['’]\\)t\\|no need to\\) merge\\|\
-re-?generate\\|bump version\\|from trunk\\|Auto-commit"
+ (let ((skip "back[- ]?port\\|cherry picked from commit\\|\
+\\(do\\( no\\|n['’]\\)t\\|no need to\\) merge\\|not to be merged\\|\
+bump \\(Emacs \\)?version\\|Auto-commit"))
+ (if noninteractive skip
+ ;; "Regenerate" is quite prone to false positives.
+ ;; We only want to skip merging things like AUTHORS and ldefs-boot.
+ ;; These should be covered by "bump version" and "auto-commit".
+ ;; It doesn't do much harm if we merge one of those files by mistake.
+ ;; So it's better to err on the side of false negatives.
+ (concat skip "\\|re-?generate\\|from trunk")))
"Regexp matching logs of revisions that might be skipped.
`gitmerge-missing' will ask you if it should skip any matches.")
+(defvar gitmerge-minimum-missing 10
+ "Minimum number of missing commits to consider merging in batch mode.")
+
(defvar gitmerge-status-file (expand-file-name "gitmerge-status"
user-emacs-directory)
"File where missing commits will be saved between sessions.")
@@ -67,8 +78,9 @@ re-?generate\\|bump version\\|from trunk\\|Auto-commit"
'((t (:strike-through t)))
"Face for skipped commits.")
-(defconst gitmerge-default-branch "origin/emacs-25"
- "Default for branch that should be merged.")
+(defvar gitmerge-default-branch nil
+ "Default for branch that should be merged.
+If nil, the function `gitmerge-default-branch' guesses.")
(defconst gitmerge-buffer "*gitmerge*"
"Working buffer for gitmerge.")
@@ -103,6 +115,21 @@ re-?generate\\|bump version\\|from trunk\\|Auto-commit"
(defvar gitmerge--commits nil)
(defvar gitmerge--from nil)
+(defun gitmerge-emacs-version (&optional branch)
+ "Return the major version of Emacs, optionally in BRANCH."
+ (with-temp-buffer
+ (if (not branch)
+ (insert-file-contents "configure.ac")
+ (call-process "git" nil t nil "show" (format "%s:configure.ac" branch))
+ (goto-char (point-min)))
+ (re-search-forward "^AC_INIT([^,]+, \\([0-9]+\\)\\.")
+ (string-to-number (match-string 1))))
+
+(defun gitmerge-default-branch ()
+ "Default for branch that should be merged; eg \"origin/emacs-26\"."
+ (or gitmerge-default-branch
+ (format "origin/emacs-%s" (1- (gitmerge-emacs-version)))))
+
(defun gitmerge-get-sha1 ()
"Get SHA1 from commit at point."
(save-excursion
@@ -182,11 +209,13 @@ Will detect a default set of skipped revision by looking at
cherry mark and search for `gitmerge-skip-regexp'. The result is
a list with entries of the form (SHA1 . SKIP), where SKIP denotes
if and why this commit should be skipped."
+ (message "Finding missing commits...")
(let (commits)
;; Go through the log and remember all commits that match
;; `gitmerge-skip-regexp' or are marked by --cherry-mark.
(with-temp-buffer
(call-process "git" nil t nil "log" "--cherry-mark" "--left-only"
+ "--no-decorate"
(concat from "..." (car (vc-git-branches))))
(goto-char (point-max))
(while (re-search-backward "^commit \\(.+\\) \\([0-9a-f]+\\).*" nil t)
@@ -203,6 +232,7 @@ if and why this commit should be skipped."
(when (re-search-forward gitmerge-skip-regexp nil t)
(setcdr (car commits) "R"))))))
(delete-region (point) (point-max))))
+ (message "Finding missing commits...done")
(nreverse commits)))
(defun gitmerge-setup-log-buffer (commits from)
@@ -245,6 +275,9 @@ should not be skipped."
(setq found (cdr skip))))
found))
+(defvar change-log-start-entry-re) ; in add-log, which defines change-log-mode
+(declare-function add-log-iso8601-time-string "add-log" ())
+
(defun gitmerge-resolve (file)
"Try to resolve conflicts in FILE with smerge.
Returns non-nil if conflicts remain."
@@ -261,7 +294,7 @@ Returns non-nil if conflicts remain."
((derived-mode-p 'change-log-mode)
;; Fix up dates before resolving the conflicts.
(goto-char (point-min))
- (let ((diff-auto-refine-mode nil))
+ (let ((diff-refine nil))
(while (re-search-forward smerge-begin-re nil t)
(smerge-match-conflict)
(smerge-ensure-match 3)
@@ -291,23 +324,53 @@ Returns non-nil if conflicts remain."
;; (pop-to-buffer (current-buffer)) (debug 'before-resolve)
))
;; Try to resolve the conflicts.
- (cond
- ((member file '("configure" "lisp/ldefs-boot.el"
- "lisp/emacs-lisp/cl-loaddefs.el"))
- ;; We are in the file's buffer, so names are relative.
- (call-process "git" nil t nil "checkout" "--"
- (file-name-nondirectory file))
- (revert-buffer nil 'noconfirm))
- (t
- (goto-char (point-max))
- (while (re-search-backward smerge-begin-re nil t)
- (save-excursion
- (ignore-errors
- (smerge-match-conflict)
- (smerge-resolve))))
- ;; (when (derived-mode-p 'change-log-mode)
- ;; (pop-to-buffer (current-buffer)) (debug 'after-resolve))
- (save-buffer)))
+ (let (temp)
+ (cond
+ ;; FIXME when merging release branch to master, we still
+ ;; need to detect and handle the case where NEWS was modified
+ ;; without a conflict. We should abort if NEWS gets changed.
+ ((and (equal file "etc/NEWS")
+ (ignore-errors
+ (setq temp
+ (format "NEWS.%s"
+ (gitmerge-emacs-version gitmerge--from))))
+ (file-exists-p temp)
+ (or noninteractive
+ (y-or-n-p "Try to fix NEWS conflict? ")))
+ (let ((relfile (file-name-nondirectory file))
+ (patchfile (concat temp "-gitmerge.patch")))
+ (call-process "git" nil `(:file ,patchfile) nil "diff"
+ (format ":1:%s" file)
+ (format ":3:%s" file))
+ (if (eq 0 (call-process "patch" patchfile nil nil temp))
+ (progn
+ ;; We intentionally use a non-temporary name for this
+ ;; file, and only delete it if applied successfully.
+ (delete-file patchfile)
+ (call-process "git" nil t nil "add" "--" temp)
+ (call-process "git" nil t nil "reset" "--" relfile)
+ (call-process "git" nil t nil "checkout" "--" relfile)
+ (revert-buffer nil 'noconfirm))
+ ;; The conflict markers remain so we return non-nil.
+ (message "Failed to fix NEWS conflict"))))
+ ;; Generated files.
+ ((member file '("lisp/ldefs-boot.el"))
+ ;; We are in the file's buffer, so names are relative.
+ (call-process "git" nil t nil "reset" "--"
+ (file-name-nondirectory file))
+ (call-process "git" nil t nil "checkout" "--"
+ (file-name-nondirectory file))
+ (revert-buffer nil 'noconfirm))
+ (t
+ (goto-char (point-max))
+ (while (re-search-backward smerge-begin-re nil t)
+ (save-excursion
+ (ignore-errors
+ (smerge-match-conflict)
+ (smerge-resolve))))
+ ;; (when (derived-mode-p 'change-log-mode)
+ ;; (pop-to-buffer (current-buffer)) (debug 'after-resolve))
+ (save-buffer))))
(goto-char (point-min))
(prog1 (re-search-forward smerge-begin-re nil t)
(unless exists (kill-buffer))))))))
@@ -387,13 +450,20 @@ Throw an user-error if we cannot resolve automatically."
(setq conflicted t)
;; Mark as resolved
(call-process "git" nil t nil "add" file)))
- (when conflicted
+ (if (not conflicted)
+ (and files (not (gitmerge-commit))
+ (error "Error committing resolution - fix it manually"))
(with-current-buffer (get-buffer-create gitmerge-warning-buffer)
(erase-buffer)
(insert "For the following files, conflicts could\n"
"not be resolved automatically:\n\n")
- (call-process "git" nil t nil
- "diff" "--name-only" "--diff-filter=U")
+ (let ((conflicts
+ (with-temp-buffer
+ (call-process "git" nil t nil
+ "diff" "--name-only" "--diff-filter=U")
+ (buffer-string))))
+ (insert conflicts)
+ (if noninteractive (message "Conflicts in:\n%s" conflicts)))
(insert "\nResolve the conflicts manually, then run gitmerge again."
"\nNote:\n - You don't have to add resolved files or "
"commit the merge yourself (but you can)."
@@ -413,11 +483,21 @@ Throw an user-error if we cannot resolve automatically."
"diff" "--name-only")
(zerop (buffer-size))))
+(defun gitmerge-commit ()
+ "Commit, and return non-nil if it succeeds."
+ (with-current-buffer (get-buffer-create gitmerge-output-buffer)
+ (erase-buffer)
+ (eq 0 (call-process "git" nil t nil "commit" "--no-edit"))))
+
(defun gitmerge-maybe-resume ()
"Check if we have to resume a merge.
If so, add no longer conflicted files and commit."
- (let ((mergehead (file-exists-p
- (expand-file-name ".git/MERGE_HEAD" default-directory)))
+ (let ((mergehead
+ (file-exists-p
+ (expand-file-name
+ "MERGE_HEAD"
+ (car (process-lines
+ "git" "rev-parse" "--no-flags" "--git-dir")))))
(statusexist (file-exists-p gitmerge-status-file)))
(when (and mergehead (not statusexist))
(user-error "Unfinished merge, but no record of a previous gitmerge run"))
@@ -425,7 +505,7 @@ If so, add no longer conflicted files and commit."
(not (gitmerge-repo-clean)))
(user-error "Repository is not clean"))
(when statusexist
- (if (not (y-or-n-p "Resume merge? "))
+ (if (or noninteractive (not (y-or-n-p "Resume merge? ")))
(progn
(delete-file gitmerge-status-file)
;; No resume.
@@ -434,11 +514,8 @@ If so, add no longer conflicted files and commit."
(gitmerge-resolve-unmerged)
;; Commit the merge.
(when mergehead
- (with-current-buffer (get-buffer-create gitmerge-output-buffer)
- (erase-buffer)
- (unless (zerop (call-process "git" nil t nil
- "commit" "--no-edit"))
- (error "Git error during merge - fix it manually"))))
+ (or (gitmerge-commit)
+ (error "Git error during merge - fix it manually")))
;; Successfully resumed.
t))))
@@ -494,8 +571,12 @@ Branch FROM will be prepended to the list."
(list
(if (gitmerge-maybe-resume)
'resume
- (completing-read "Merge branch: " (gitmerge-get-all-branches)
- nil t gitmerge-default-branch))))))
+ (if noninteractive
+ (or (pop command-line-args-left)
+ (gitmerge-default-branch))
+ (completing-read "Merge branch: "
+ (gitmerge-get-all-branches)
+ nil t (gitmerge-default-branch))))))))
(let ((default-directory (vc-git-root default-directory)))
(if (eq from 'resume)
(progn
@@ -507,6 +588,12 @@ Branch FROM will be prepended to the list."
(setq gitmerge--from from)
(when (null gitmerge--commits)
(user-error "Nothing to merge"))
+ (and noninteractive
+ gitmerge-minimum-missing
+ (< (length gitmerge--commits) gitmerge-minimum-missing)
+ (user-error "Number of missing commits (%s) is less than %s"
+ (length gitmerge--commits)
+ gitmerge-minimum-missing))
(with-current-buffer
(gitmerge-setup-log-buffer gitmerge--commits gitmerge--from)
(goto-char (point-min))
@@ -517,7 +604,8 @@ Branch FROM will be prepended to the list."
"(C) Detected backport (cherry-mark), (R) Log matches "
"regexp, (M) Manually picked\n\n")
(gitmerge-mode)
- (pop-to-buffer (current-buffer))))))
+ (pop-to-buffer (current-buffer))
+ (if noninteractive (gitmerge-start-merge))))))
(defun gitmerge-start-merge ()
(interactive)
diff --git a/admin/grammars/make.by b/admin/grammars/make.by
index 905166d221d..423c9529dec 100644
--- a/admin/grammars/make.by
+++ b/admin/grammars/make.by
@@ -54,15 +54,20 @@
%%
+;; Escape the ,@ below because the reader doesn't correctly detect
+;; old-style backquotes for this case. The backslashes can be removed
+;; once old-style backquotes are completely gone (probably in
+;; Emacs 28).
+
Makefile : bol newline (nil)
| bol variable
- ( ,@$2 )
+ ( \,@$2 )
| bol rule
- ( ,@$2 )
+ ( \,@$2 )
| bol conditional
- ( ,@$2 )
+ ( \,@$2 )
| bol include
- ( ,@$2 )
+ ( \,@$2 )
| whitespace ( nil )
| newline ( nil )
;
@@ -125,13 +130,13 @@ colons: COLON COLON ()
;
element-list: elements newline
- ( ,@$1 )
+ ( \,@$1 )
;
elements: element some-whitespace elements
- ( ,@$1 ,@$3 )
+ ( \,@$1 ,@$3 )
| element
- ( ,@$1 )
+ ( \,@$1 )
| ;;EMPTY
;
diff --git a/admin/grammars/scheme.by b/admin/grammars/scheme.by
index 91c7808e84c..76ded7faf61 100644
--- a/admin/grammars/scheme.by
+++ b/admin/grammars/scheme.by
@@ -20,6 +20,11 @@
%package semantic-scm-by
%provide semantic/bovine/scm-by
+%{
+(declare-function semantic-parse-region "semantic"
+ (start end &optional nonterminal depth returnonerror))
+}
+
%languagemode scheme-mode
%start scheme
diff --git a/admin/make-tarball.txt b/admin/make-tarball.txt
index 092027d1e2a..47b60173f8e 100644
--- a/admin/make-tarball.txt
+++ b/admin/make-tarball.txt
@@ -5,7 +5,7 @@ Instructions to create pretest or release tarballs. -*- coding: utf-8 -*-
Steps to take before starting on the first pretest in any release sequence:
-0. The release branch (e.g. emacs-25) should already have been made
+0. The release branch (e.g. emacs-26) should already have been made
and you should use it for all that follows. Diffs from this
branch should be going to the emacs-diffs mailing list.
@@ -87,6 +87,11 @@ General steps (for each step, check for possible errors):
make -C etc/refcards
make -C etc/refcards clean
+ If some of the non-English etc/refcards fail to build, you
+ probably need to install some TeX foreign language packages.
+ For more information, search for the string "refcard" in the file
+ admin/release-process.
+
5. Copy lisp/loaddefs.el to lisp/ldefs-boot.el.
Commit ChangeLog.N, etc/AUTHORS, lisp/ldefs-boot.el, and the
@@ -123,7 +128,7 @@ General steps (for each step, check for possible errors):
9. Decide what compression schemes to offer.
For a release, at least gz and xz:
- gzip --best -c emacs-NEW.tar > emacs-NEW.tar.gz
+ gzip --best --no-name -c emacs-NEW.tar > emacs-NEW.tar.gz
xz -c emacs-NEW.tar > emacs-NEW.tar.xz
For pretests, just xz is probably fine (saves bandwidth).
diff --git a/admin/merge-gnulib b/admin/merge-gnulib
index 8e768a42319..055e791d62a 100755
--- a/admin/merge-gnulib
+++ b/admin/merge-gnulib
@@ -29,15 +29,15 @@ GNULIB_MODULES='
alloca-opt binary-io byteswap c-ctype c-strcase
careadlinkat close-stream
count-leading-zeros count-one-bits count-trailing-zeros
- crypto/md5 crypto/sha1 crypto/sha256 crypto/sha512
- d-type diffseq dtoastr dtotimespec dup2
+ crypto/md5-buffer crypto/sha1-buffer crypto/sha256-buffer crypto/sha512-buffer
+ d-type diffseq dosname dtoastr dtotimespec dup2
environ execinfo explicit_bzero faccessat
- fcntl fcntl-h fdatasync fdopendir
- filemode filevercmp flexmember fpieee fstatat fsync
+ fcntl fcntl-h fdopendir
+ filemode filevercmp flexmember fpieee fstatat fsusage fsync
getloadavg getopt-gnu gettime gettimeofday gitlog-to-changelog
- ignore-value intprops largefile lstat
+ ieee754-h ignore-value intprops largefile lstat
manywarnings memrchr minmax mkostemp mktime nstrftime
- pipe2 pselect pthread_sigmask putenv qcopy-acl readlink readlinkat
+ pipe2 pselect pthread_sigmask putenv qcopy-acl readlink readlinkat regex
sig2str socklen stat-time std-gnu11 stdalign stddef stdio
stpcpy strtoimax symlink sys_stat sys_time
tempname time time_r time_rz timegm timer-time timespec-add timespec-sub
@@ -46,11 +46,12 @@ GNULIB_MODULES='
'
AVOIDED_MODULES='
- close dup fchdir fstat
- malloc-posix msvc-inval msvc-nothrow
+ btowc close dup fchdir fstat langinfo lock
+ malloc-posix mbrtowc mbsinit mkdir msvc-inval msvc-nothrow nl_langinfo
openat-die opendir raise
save-cwd select setenv sigprocmask stat stdarg stdbool
threadlib tzset unsetenv utime utime-h
+ wchar wcrtomb wctype-h
'
GNULIB_TOOL_FLAGS='
diff --git a/admin/notes/bugtracker b/admin/notes/bugtracker
index cda258339ea..92ae326ffd5 100644
--- a/admin/notes/bugtracker
+++ b/admin/notes/bugtracker
@@ -8,7 +8,7 @@ This is 95% of all you will ever need to know.
** How do I report a bug?
Use M-x report-emacs-bug, or send mail to bug-gnu-emacs@gnu.org.
-If you want to Cc someone, use an "X-Debbugs-CC" header (or
+If you want to Cc someone, use an "X-Debbugs-Cc" header (or
pseudo-header, see below) instead.
** How do I comment on a bug?
@@ -53,7 +53,7 @@ i) Your report will be assigned a number and generate an automatic reply.
ii) Optionally, you can set some database parameters when you first
report a bug (see "Setting bug parameters" below).
-iii) If you want to CC: someone, use X-Debbugs-CC: (note this only
+iii) If you want to Cc someone, use X-Debbugs-Cc: (note this only
applies to _new_ reports, not followups).
Once your report is filed and assigned a number, it is sent out to the
@@ -64,8 +64,8 @@ quiet@debbugs.gnu.org.
** How do I reply to an existing bug report?
Reply to 123@debbugs.gnu.org, replacing 123 with the number
of the bug you are interested in. NB this only sends mail to the
-bug-list, it does NOT send a CC to the original bug submitter.
-So you need to explicitly CC him/her (and anyone else you like).
+bug-list, it does NOT send a Cc to the original bug submitter.
+So you need to explicitly Cc him/her (and anyone else you like).
(This works the same way as all the Emacs mailing lists. We generally
don't assume anyone who posts to a list is subscribed to it, so we
cc everyone on replies.)
@@ -95,23 +95,23 @@ normal bug reporting.)
** When reporting a new bug, to send a Cc to another address
(e.g. bug-cc-mode@gnu.org), do NOT just use a Cc: header.
-Instead, use "X-Debbugs-CC:". This ensures the Cc address(es) will get a
+Instead, use "X-Debbugs-Cc:". This ensures the Cc address(es) will get a
mail with the bug report number in. If you do not do this, each reply
in the subsequent discussion might end up creating a new bug.
This is annoying. (So annoying that a form of message-id tracking has
been implemented to hopefully stop this happening, but it is still
-better to use X-Debbugs-CC.)
+better to use X-Debbugs-Cc.)
If you want to send copies to more than one address, add them
-comma-separated in only one X-Debbugs-CC line.
+comma-separated in only one X-Debbugs-Cc line.
Like any X-Debbugs- header, this one can also be specified in the
pseudo-header (see below), if your mail client does not let you add
"X-" headers.
-If a new report contains X-Debbugs-CC in the input, this is
+If a new report contains X-Debbugs-Cc in the input, this is
converted to a real Cc header in the output. (See Bug#1780,5384)
-It is also merged into the Resent-CC header (see below).
+It is also merged into the Resent-Cc header (see below).
** How does Debbugs send out mails?
@@ -120,15 +120,15 @@ header is unchanged. In new reports only (at present), the To:
address is altered as follows. Any "bug-gnu-emacs",
"emacs-pretest-bug", or "submit@debbugs" address is replaced by
123@debbugs in the mail that gets sent out. (This also applies to any
-Cc: header, though you should be using X-Debbugs-CC instead in new
+Cc: header, though you should be using X-Debbugs-Cc instead in new
reports). The original header is stored as X-Debbugs-Original-To, if
-it was changed. Any X-Debbugs-CC is merged into the Cc.
+it was changed. Any X-Debbugs-Cc is merged into the Cc.
Mails arriving at the bug list have the following Resent-* headers:
Resent-From: person who submitted the bug
Resent-To: owner@debbugs.gnu.org
-Resent-CC: maintainer email address, plus any X-Debbugs-CC: entries
+Resent-Cc: maintainer email address, plus any X-Debbugs-Cc: entries
The "maintainer email address" is "bug-gnu-emacs@gnu.org" in most cases.
@@ -239,7 +239,7 @@ The control server ignores anything after the last line above. So you
can place control commands at the beginning of a reply to a bug
report, and Bcc: the control server (note the commands have no effect
if you just send them to the bug-report number). Bcc: is better than Cc:
-in case people use Reply-to-All in response.
+in case people use Reply-To-All in response.
For the full documentation of control commands, see
https://debbugs.gnu.org/server-control.html
diff --git a/admin/notes/copyright b/admin/notes/copyright
index b2c74a835be..e22db6bc557 100644
--- a/admin/notes/copyright
+++ b/admin/notes/copyright
@@ -161,9 +161,6 @@ etc/letter.pbm,letter.xpm
- trivial, no notice needed.
<https://lists.gnu.org/r/emacs-devel/2007-02/msg00324.html>
-etc/FTP, ORDERS
- - trivial (at time of writing), no license needed
-
etc/HELLO
standard notices. Just a note that although the file itself is not
really copyrightable, in the wider context of it being part of
diff --git a/admin/notes/git-workflow b/admin/notes/git-workflow
index 83e81c68ef0..54657866ef5 100644
--- a/admin/notes/git-workflow
+++ b/admin/notes/git-workflow
@@ -19,15 +19,15 @@ Initial setup
=============
Then we want to clone the repository. We normally want to have both
-the current master and the emacs-25 branch.
+the current master and the emacs-26 branch.
mkdir ~/emacs
cd ~/emacs
git clone <membername>@git.sv.gnu.org:/srv/git/emacs.git master
(cd master; git config push.default current)
-./master/admin/git-new-workdir master emacs-25
-cd emacs-25
-git checkout emacs-25
+./master/admin/git-new-workdir master emacs-26
+cd emacs-26
+git checkout emacs-26
You now have both branches conveniently accessible, and you can do
"git pull" in them once in a while to keep updated.
@@ -57,11 +57,11 @@ you commit your change locally and then send a patch file as a bug report
as described in ../../CONTRIBUTE.
-Backporting to emacs-25
+Backporting to emacs-26
=======================
If you have applied a fix to the master, but then decide that it should
-be applied to the emacs-25 branch, too, then
+be applied to the emacs-26 branch, too, then
cd ~/emacs/master
git log
@@ -71,7 +71,7 @@ which will look like
commit 958b768a6534ae6e77a8547a56fc31b46b63710b
-cd ~/emacs/emacs-25
+cd ~/emacs/emacs-26
git cherry-pick -xe 958b768a6534ae6e77a8547a56fc31b46b63710b
and add "Backport:" to the commit string. Then
@@ -79,17 +79,17 @@ and add "Backport:" to the commit string. Then
git push
-Merging emacs-25 to the master
+Merging emacs-26 to the master
==============================
It is recommended to use the file gitmerge.el in the admin directory
-for merging 'emacs-25' into 'master'. It will take care of many
+for merging 'emacs-26' into 'master'. It will take care of many
things which would otherwise have to be done manually, like ignoring
commits that should not land in master, fixing up ChangeLogs and
automatically dealing with certain types of conflicts. If you really
want to, you can do the merge manually, but then you're on your own.
If you still choose to do that, make absolutely sure that you *always*
-use the 'merge' command to transport commits from 'emacs-25' to
+use the 'merge' command to transport commits from 'emacs-26' to
'master'. *Never* use 'cherry-pick'! If you don't know why, then you
shouldn't manually do the merge in the first place; just use
gitmerge.el instead.
@@ -102,11 +102,11 @@ up-to-date by doing a pull. Then start Emacs with
emacs -l admin/gitmerge.el -f gitmerge
You'll be asked for the branch to merge, which will default to
-'origin/emacs-25', which you should accept. Merging a local tracking
+'origin/emacs-26', which you should accept. Merging a local tracking
branch is discouraged, since it might not be up-to-date, or worse,
contain commits from you which are not yet pushed upstream.
-You will now see the list of commits from 'emacs-25' which are not yet
+You will now see the list of commits from 'emacs-26' which are not yet
merged to 'master'. You might also see commits that are already
marked for "skipping", which means that they will be merged with a
different merge strategy ('ours'), which will effectively ignore the
diff --git a/admin/notes/hydra b/admin/notes/hydra
index 49c995f3f7e..da8d98693ea 100644
--- a/admin/notes/hydra
+++ b/admin/notes/hydra
@@ -10,8 +10,6 @@ https://hydra.nixos.org/jobset/gnu/emacs-trunk
* It builds Emacs on various platforms.
Sometimes jobs fail due to hydra problems rather than Emacs problems.
-Eg it seems like the darwin build will never work again.
-https://lists.gnu.org/r/hydra-users/2016-01/msg00000.html
* Mail notifications
In addition to the web interface, Hydra can send notifications by
@@ -22,6 +20,8 @@ Emacs trunk to emacs-buildstatus@gnu.org.
If you want to receive these notifications, please subscribe at
https://lists.gnu.org/mailman/listinfo/emacs-buildstatus
+(This feature seems to have been broken for ages.)
+
* The Emacs jobset consists of the following jobs:
** The 'tarball' job
diff --git a/admin/notes/multi-tty b/admin/notes/multi-tty
index c124f37d23b..e15a25b55ca 100644
--- a/admin/notes/multi-tty
+++ b/admin/notes/multi-tty
@@ -171,7 +171,11 @@ preload-emacs "$name" wait
name="$1"
waitp="$2"
screendir="/var/run/screen/S-$USER"
-serverdir="/tmp/emacs$UID"
+if [ "${XDG_RUNTIME_DIR+set}" ]; then
+ serverdir="$XDG_RUNTIME_DIR/emacs"
+else
+ serverdir="${TMPDIR-/tmp}/emacs$UID"
+fi
emacs=/usr/bin/emacs-multi-tty # Or wherever you installed your multi-tty Emacs
if [ -z "$name" ]; then
diff --git a/admin/notes/spelling b/admin/notes/spelling
new file mode 100644
index 00000000000..a63d4bba849
--- /dev/null
+++ b/admin/notes/spelling
@@ -0,0 +1,11 @@
+Re "behavior" vs "behaviour", etc.
+
+- GNU Emacs originated in the US.
+
+- If there is a choice between US vs UK spelling for a word
+ for new text (code, docs), choose the US variant.
+
+- It's probably (IMHO --ttn, 2017-10-13) not a high priority to
+ change existing text; use your best judgement (ask if unsure).
+
+- http://lists.gnu.org/archive/html/emacs-devel/2005-06/msg00489.html
diff --git a/admin/notes/unicode b/admin/notes/unicode
index d641e60ff73..4d6aa6e9a9e 100644
--- a/admin/notes/unicode
+++ b/admin/notes/unicode
@@ -11,15 +11,20 @@ Emacs uses the following files from the Unicode Character Database
. UnicodeData.txt
. Blocks.txt
- . BidiMirroring.txt
. BidiBrackets.txt
+ . BidiCharacterTest.txt
+ . BidiMirroring.txt
. IVD_Sequences.txt
. NormalizationTest.txt
. SpecialCasing.txt
- . BidiCharacterTest.txt
First, the first 7 files need to be copied into admin/unidata/, and
-then Emacs should be rebuilt for them to take effect. Rebuilding
+the file https://www.unicode.org/copyright.html should be copied over
+copyright.html in admin/unidata (that file might need trailing
+whitespace removed before it can be committed to the Emacs
+repository).
+
+Then Emacs should be rebuilt for them to take effect. Rebuilding
Emacs updates several derived files elsewhere in the Emacs source
tree, mainly in lisp/international/.
@@ -28,7 +33,10 @@ files, pay attention to any warning or error messages. In particular,
admin/unidata/unidata-gen.el will complain if UnicodeData.txt defines
new bidirectional attributes of characters, because unidata-gen.el,
bidi.c and dispextern.h need to be updated in that case; failure to do
-so will cause aborts in redisplay.
+so will cause aborts in redisplay. unidata-gen.el will also complain
+if the format of the Unicode Copyright notice in copyright.html
+changed in significant ways; in that case, update the regular
+expression in unidata-gen-file used to extract the copyright string.
Next, review the changes in UnicodeData.txt vs the previous version
used by Emacs. Any changes, be it introduction of new scripts or
@@ -40,7 +48,12 @@ and see if any changes in admin/unidata/blocks.awk are required.
The setting of char-width-table around line 1200 of characters.el
should be checked against the latest version of the Unicode file
-EastAsianWidth.txt, and any discrepancies fixed.
+EastAsianWidth.txt, and any discrepancies fixed: double-width
+characters are those marked with W or F in that file. Zero-width
+characters are not taken from EastAsianWidth.txt, they are those whose
+Unicode General Category property is one of Mn, Me, or Cf, and also
+Hangul jungseong and jongseong characters (a.k.a. "Jamo medial vowels"
+and "Jamo final consonants").
Any new scripts added by UnicodeData.txt will also need updates to
script-representative-chars defined in fontset.el, and also the list
@@ -230,41 +243,21 @@ nontrivial changes to the build process.
admin/charsets/mapfiles/cns2ucsdkw.txt
- * iso-2022-7bit
-
- This file switches between CJK charsets, which is not encoded in UTF-8.
+ * iso-2022-jp
- etc/HELLO
-
- Each of these files contains just one CJK charset, but Emacs
- currently has no easy way to specify set-charset-priority on a
- per-file basis, so converting any of these files to UTF-8 might
- change the file's appearance when viewed by an Emacs that is
- operating in some other language environment.
+ This contains just one CJK charset, but Emacs currently has no
+ easy way to specify set-charset-priority on a per-file basis, so
+ converting this file to UTF-8 might change the file's appearance
+ when viewed by an Emacs that is operating in some other language
+ environment.
etc/tutorials/TUTORIAL.ja
- lisp/international/ja-dic-cnv.el
- lisp/international/ja-dic-utl.el
- lisp/international/kinsoku.el
- lisp/international/kkc.el
- lisp/international/titdic-cnv.el
- lisp/language/japan-util.el
- lisp/language/japanese.el
- lisp/leim/quail/cyril-jis.el
- lisp/leim/quail/hanja-jis.el
- lisp/leim/quail/japanese.el
- lisp/leim/quail/py-punct.el
- lisp/leim/quail/pypunct-b5.el
-
- This file contains just Chinese characters, and has same problem.
- Also, it contains characters that cannot be encoded in UTF-8.
-
- lisp/international/titdic-cnv.el
* utf-8-emacs
These files contain characters that cannot be encoded in UTF-8.
+ lisp/international/titdic-cnv.el
lisp/language/ethio-util.el
lisp/language/ethiopic.el
lisp/language/ind-util.el
diff --git a/admin/nt/dist-build/README-windows-binaries b/admin/nt/dist-build/README-windows-binaries
index 27a5483c02b..39a5871b6a0 100644
--- a/admin/nt/dist-build/README-windows-binaries
+++ b/admin/nt/dist-build/README-windows-binaries
@@ -27,17 +27,17 @@ Contains a 32-bit build of Emacs without dependencies
In addition, we provide the following files which will not be useful
for most end-users.
-emacs-26-x86_64-deps.zip
+emacs-27-x86_64-deps.zip
The dependencies. Unzipping this file on top of
emacs-$VERSION-x86_64-no-deps.zip should result in the same install as
emacs-$VERSION-x86_64.zip.
-emacs-26-i686-deps.zip
+emacs-27-i686-deps.zip
The 32-bit version of the dependencies.
-emacs-26-deps-mingw-w64-src.zip
+emacs-27-deps-mingw-w64-src.zip
The source for the dependencies. Source for Emacs itself is available
in the main distribution tarball. These dependencies were produced
diff --git a/admin/nt/dist-build/build-dep-zips.py b/admin/nt/dist-build/build-dep-zips.py
index c6864e1687f..5a5bfe7b37f 100755
--- a/admin/nt/dist-build/build-dep-zips.py
+++ b/admin/nt/dist-build/build-dep-zips.py
@@ -26,7 +26,7 @@ import re
from subprocess import check_output
## Constants
-EMACS_MAJOR_VERSION="26"
+EMACS_MAJOR_VERSION="27"
## Options
@@ -35,9 +35,9 @@ DRY_RUN=False
## Packages to fiddle with
SKIP_PKGS=["mingw-w64-gcc-libs"]
MUNGE_PKGS ={"mingw-w64-libwinpthread-git":"mingw-w64-winpthreads-git"}
-ARCH_PKGS=["mingw-w64-mpc",
- "mingw-w64-termcap",
- "mingw-w64-xpm-nox"]
+
+## Currently no packages seem to require this!
+ARCH_PKGS=[]
SRC_REPO="https://sourceforge.net/projects/msys2/files/REPOS/MINGW/Sources"
@@ -49,6 +49,7 @@ def check_output_maybe(*args,**kwargs):
def extract_deps():
+ print( "Extracting deps" )
# This list derives from the features we want Emacs to compile with.
PKG_REQ='''mingw-w64-x86_64-giflib
mingw-w64-x86_64-gnutls
@@ -103,7 +104,8 @@ def gather_deps(deps, arch, directory):
## And package them up
os.chdir(directory)
print("Zipping: {}".format(arch))
- check_output_maybe("zip -9r ../../emacs-26-{}-deps.zip *".format(arch),
+ check_output_maybe("zip -9r ../../emacs-{}-{}{}-deps.zip *"
+ .format(EMACS_MAJOR_VERSION, DATE, arch),
shell=True)
os.chdir("../../")
@@ -167,8 +169,8 @@ def gather_source(deps):
p.map(download_source,to_download)
print("Zipping")
- check_output_maybe("zip -9 ../emacs-{}-deps-mingw-w64-src.zip *"
- .format(EMACS_MAJOR_VERSION),
+ check_output_maybe("zip -9 ../emacs-{}-{}deps-mingw-w64-src.zip *"
+ .format(EMACS_MAJOR_VERSION,DATE),
shell=True)
os.chdir("..")
@@ -188,13 +190,16 @@ if(os.environ["MSYSTEM"] != "MSYS"):
parser = argparse.ArgumentParser()
+parser.add_argument("-s", help="snapshot build",
+ action="store_true")
+
parser.add_argument("-t", help="32 bit deps only",
action="store_true")
parser.add_argument("-f", help="64 bit deps only",
action="store_true")
-parser.add_argument("-s", help="source code only",
+parser.add_argument("-r", help="source code only",
action="store_true")
parser.add_argument("-c", help="clean only",
@@ -204,19 +209,24 @@ parser.add_argument("-d", help="dry run",
action="store_true")
args = parser.parse_args()
-do_all=not (args.c or args.s or args.f or args.t)
+do_all=not (args.c or args.r or args.f or args.t)
deps=extract_deps()
DRY_RUN=args.d
+if args.s:
+ DATE="{}-".format(check_output(["date", "+%Y-%m-%d"]).decode("utf-8").strip())
+else:
+ DATE=""
+
if( do_all or args.t ):
gather_deps(deps,"i686","mingw32")
if( do_all or args.f ):
gather_deps(deps,"x86_64","mingw64")
-if( do_all or args.s ):
+if( do_all or args.r ):
gather_source(deps)
if( args.c ):
diff --git a/admin/nt/dist-build/build-zips.sh b/admin/nt/dist-build/build-zips.sh
index 0069dc9c46b..4404c779629 100755
--- a/admin/nt/dist-build/build-zips.sh
+++ b/admin/nt/dist-build/build-zips.sh
@@ -19,14 +19,13 @@
function git_up {
- echo Making git worktree for Emacs $VERSION
+ echo [build] Making git worktree for Emacs $VERSION
cd $HOME/emacs-build/git/emacs-$MAJOR_VERSION
git pull
- git worktree add ../emacs-$BRANCH emacs-$BRANCH
+ git worktree add ../$BRANCH $BRANCH
- cd ../emacs-$BRANCH
+ cd ../$BRANCH
./autogen.sh
-
}
function build_zip {
@@ -35,44 +34,81 @@ function build_zip {
PKG=$2
HOST=$3
- echo Building Emacs-$VERSION for $ARCH
+ echo [build] Building Emacs-$VERSION for $ARCH
if [ $ARCH == "i686" ]
then
PATH=/mingw32/bin:$PATH
MSYSTEM=MINGW32
fi
+ ## Clean the install location because we use it twice
+ rm -rf $HOME/emacs-build/install/emacs-$VERSION/$ARCH
mkdir --parents $HOME/emacs-build/build/emacs-$VERSION/$ARCH
cd $HOME/emacs-build/build/emacs-$VERSION/$ARCH
export PKG_CONFIG_PATH=$PKG
- ../../../git/emacs-$BRANCH/configure \
- --without-dbus \
- --host=$HOST --without-compress-install \
- CFLAGS="-O2 -static -g3"
- make -j 8 install \
+
+ ## Running configure forces a rebuild of the C core which takes
+ ## time that is not always needed, so do not do it unless we have
+ ## to.
+ if [ ! -f Makefile ] || (($CONFIG))
+ then
+ echo [build] Configuring Emacs $ARCH
+ ../../../git/$BRANCH/configure \
+ --without-dbus \
+ --host=$HOST --without-compress-install \
+ $CACHE \
+ CFLAGS="-O2 -static -g3"
+ fi
+
+ make -j 2 install \
prefix=$HOME/emacs-build/install/emacs-$VERSION/$ARCH
cd $HOME/emacs-build/install/emacs-$VERSION/$ARCH
cp $HOME/emacs-build/deps/libXpm/$ARCH/libXpm-noX4.dll bin
- zip -r -9 emacs-$VERSION-$ARCH-no-deps.zip *
- mv emacs-$VERSION-$ARCH-no-deps.zip $HOME/emacs-upload
+ zip -r -9 emacs-$OF_VERSION-$ARCH-no-deps.zip *
+ mv emacs-$OF_VERSION-$ARCH-no-deps.zip $HOME/emacs-upload
rm bin/libXpm-noX4.dll
- unzip $HOME/emacs-build/deps/emacs-26-$ARCH-deps.zip
- zip -r -9 emacs-$VERSION-$ARCH.zip *
- mv emacs-$VERSION-$ARCH.zip ~/emacs-upload
+
+ if [ -z $SNAPSHOT ];
+ then
+ DEPS_FILE=$HOME/emacs-build/deps/emacs-$MAJOR_VERSION-$ARCH-deps.zip
+ else
+ ## Pick the most recent snapshot whatever that is
+ DEPS_FILE=`ls $HOME/emacs-build/deps/emacs-$MAJOR_VERSION-*-$ARCH-deps.zip | tail -n 1`
+ fi
+
+ echo [build] Using $DEPS_FILE
+ unzip $DEPS_FILE
+
+ zip -r -9 emacs-$OF_VERSION-$ARCH.zip *
+ mv emacs-$OF_VERSION-$ARCH.zip ~/emacs-upload
}
+function build_installer {
+ ARCH=$1
+ cd $HOME/emacs-build/install/emacs-$VERSION
+ echo [build] Calling makensis in `pwd`
+ cp ../../git/$BRANCH/admin/nt/dist-build/emacs.nsi .
+
+ makensis -v4 \
+ -DARCH=$ARCH -DEMACS_VERSION=$ACTUAL_VERSION \
+ -DOUT_VERSION=$OF_VERSION emacs.nsi
+ rm emacs.nsi
+ mv emacs-$OF_VERSION-$ARCH-installer.exe ~/emacs-upload
+}
-##set -o xtrace
set -o errexit
SNAPSHOT=
+CACHE=
+BUILD=1
BUILD_32=1
BUILD_64=1
GIT_UP=0
+CONFIG=1
-while getopts "36ghsV:" opt; do
+while getopts "36gb:hnsiV:" opt; do
case $opt in
3)
BUILD_32=1
@@ -90,6 +126,16 @@ while getopts "36ghsV:" opt; do
BUILD_64=0
GIT_UP=1
;;
+ n)
+ CONFIG=0
+ ;;
+ i)
+ BUILD=0
+ ;;
+ b)
+ REQUIRED_BRANCH=$OPTARG
+ echo "Setting Required branch $REQUIRED_BRANCH"
+ ;;
V)
VERSION=$OPTARG
;;
@@ -101,6 +147,7 @@ while getopts "36ghsV:" opt; do
echo " -3 32 bit build only"
echo " -6 64 bit build only"
echo " -g git update and worktree only"
+ echo " -i build installer only"
exit 0
;;
\?)
@@ -111,7 +158,6 @@ done
if [ -z $VERSION ];
then
- echo "doing version thing"
VERSION=`
sed -n 's/^AC_INIT(GNU Emacs,[ ]*\([^ ,)]*\).*/\1/p' < ../../../configure.ac
`
@@ -119,14 +165,43 @@ fi
if [ -z $VERSION ];
then
- echo Cannot determine Emacs version
+ echo [build] Cannot determine Emacs version
exit 1
fi
MAJOR_VERSION="$(echo $VERSION | cut -d'.' -f1)"
-BRANCH=$VERSION
+
+## ACTUAL VERSION is the version declared by emacs
+ACTUAL_VERSION=$VERSION
+
+## VERSION includes the word snapshot if necessary
VERSION=$VERSION$SNAPSHOT
+## OF version includes the date if we have a snapshot
+OF_VERSION=$VERSION
+
+if [ -z $SNAPSHOT ];
+then
+ BRANCH=emacs-$VERSION
+else
+ BRANCH=master
+ CACHE=-C
+ OF_VERSION="$VERSION-`date +%Y-%m-%d`"
+fi
+
+echo Checking for required branch
+if [ -z $REQUIRED_BRANCH ];
+then
+ :
+else
+ BRANCH=$REQUIRED_BRANCH
+ echo [build] Building from Branch $BRANCH
+ VERSION=$VERSION-$BRANCH
+ OF_VERSION="$VERSION-`date +%Y-%m-%d`"
+ ## Use snapshot dependencies
+ SNAPSHOT=1
+fi
+
if (($GIT_UP))
then
git_up
@@ -134,12 +209,20 @@ fi
if (($BUILD_64))
then
- build_zip x86_64 /mingw64/lib/pkgconfig x86_64-w64-mingw32
+ if (($BUILD))
+ then
+ build_zip x86_64 /mingw64/lib/pkgconfig x86_64-w64-mingw32
+ fi
+ build_installer x86_64
fi
## Do the 64 bit build first, because we reset some environment
## variables during the 32 bit which will break the build.
if (($BUILD_32))
then
- build_zip i686 /mingw32/lib/pkgconfig i686-w64-mingw32
+ if (($BUILD))
+ then
+ build_zip i686 /mingw32/lib/pkgconfig i686-w64-mingw32
+ fi
+ build_installer i686
fi
diff --git a/admin/nt/dist-build/emacs.nsi b/admin/nt/dist-build/emacs.nsi
new file mode 100644
index 00000000000..dce8f3db4a3
--- /dev/null
+++ b/admin/nt/dist-build/emacs.nsi
@@ -0,0 +1,88 @@
+!include MUI2.nsh
+!include LogicLib.nsh
+!include x64.nsh
+
+Outfile "emacs-${OUT_VERSION}-${ARCH}-installer.exe"
+
+
+SetCompressor /solid lzma
+
+Var StartMenuFolder
+
+
+!define MUI_WELCOMEPAGE_TITLE "Emacs"
+!define MUI_WELCOMEPAGE_TITLE_3LINES
+!define MUI_WELCOMEPAGE_TEXT "Welcome to Emacs -- the editor of a lifetime."
+
+!define MUI_WELCOMEFINISHPAGE_BITMAP "${ARCH}\share\emacs\${EMACS_VERSION}\etc\images\splash.bmp"
+!define MUI_ICON "${ARCH}\share\emacs\${EMACS_VERSION}\etc\images\icons\hicolor\scalable\apps\emacs.ico"
+!define MUI_UNICON "${ARCH}\share\emacs\${EMACS_VERSION}\etc\images\icons\hicolor\scalable\apps\emacs.ico"
+
+!insertmacro MUI_PAGE_WELCOME
+
+
+!define MUI_LICENSEPAGE_TEXT_TOP "The GNU General Public License"
+!insertmacro MUI_PAGE_LICENSE "${ARCH}\share\emacs\${EMACS_VERSION}\lisp\COPYING"
+
+!insertmacro MUI_PAGE_DIRECTORY
+!insertmacro MUI_PAGE_INSTFILES
+
+!insertmacro MUI_PAGE_STARTMENU Application $StartMenuFolder
+
+!insertmacro MUI_UNPAGE_CONFIRM
+!insertmacro MUI_UNPAGE_INSTFILES
+
+!insertmacro MUI_LANGUAGE "English"
+Name Emacs-${EMACS_VERSION}
+
+function .onInit
+ ${If} ${RunningX64}
+ ${If} ${ARCH} == "x86_64"
+ StrCpy $INSTDIR "$PROGRAMFILES64\Emacs"
+ ${Else}
+ StrCpy $INSTDIR "$PROGRAMFILES32\Emacs"
+ ${Endif}
+ ${Else}
+ ${If} ${ARCH} == "x86_64"
+ Quit
+ ${Else}
+ StrCpy $INSTDIR "$PROGRAMFILES\Emacs"
+ ${Endif}
+ ${EndIf}
+functionend
+
+
+Section
+
+ SetOutPath $INSTDIR
+
+ File /r ${ARCH}
+ # define uninstaller name
+ WriteUninstaller $INSTDIR\Uninstall.exe
+
+ !insertmacro MUI_STARTMENU_WRITE_BEGIN Application
+ ;Create shortcuts
+ CreateDirectory "$SMPROGRAMS\$StartMenuFolder"
+ CreateShortcut "$SMPROGRAMS\$StartMenuFolder\Uninstall.lnk" "$INSTDIR\Uninstall.exe"
+
+ !insertmacro MUI_STARTMENU_WRITE_END
+ CreateShortCut "$SMPROGRAMS\$StartMenuFolder\Emacs.lnk" "$INSTDIR\${ARCH}\bin\runemacs.exe"
+SectionEnd
+
+
+# create a section to define what the uninstaller does.
+# the section will always be named "Uninstall"
+Section "Uninstall"
+
+ # Always delete uninstaller first
+ Delete "$INSTDIR\Uninstall.exe"
+
+ # now delete installed directory
+ RMDir /r "$INSTDIR\${ARCH}"
+ RMDir "$INSTDIR"
+
+ !insertmacro MUI_STARTMENU_GETFOLDER Application $StartMenuFolder
+
+ Delete "$SMPROGRAMS\$StartMenuFolder\Uninstall.lnk"
+ RMDir "$SMPROGRAMS\$StartMenuFolder"
+SectionEnd
diff --git a/admin/release-process b/admin/release-process
index 71ada82356c..504b70270f8 100644
--- a/admin/release-process
+++ b/admin/release-process
@@ -166,9 +166,9 @@ emacs.pdf' (e.g., enable "smallbook").
What paper size are the English versions supposed to be on?
On Debian testing, the packages texlive-lang-czechslovak and
texlive-lang-polish will let you generate the cs-* and sk-* pdfs.
-(You may need texlive-lang-cyrillic, texlive-lang-german for others.)
-The Makefile rules did not work for me, I had to use something like:
-csplain -output-format=pdf cs-refcard
+(You may need texlive-lang-cyrillic, texlive-lang-german,
+and texlive-fonts-extra for others.) On Fedora-like systems,
+texlive-lh may help.
** Ask maintainers of refcard translations to update them.
diff --git a/admin/unidata/BidiBrackets.txt b/admin/unidata/BidiBrackets.txt
index c505861a902..9e518347672 100644
--- a/admin/unidata/BidiBrackets.txt
+++ b/admin/unidata/BidiBrackets.txt
@@ -1,5 +1,5 @@
-# BidiBrackets-11.0.0.txt
-# Date: 2018-02-18, 05:50:00 GMT [AG, LI, KW]
+# BidiBrackets-12.0.0.txt
+# Date: 2018-11-02, 16:32:00 GMT [AG, LI, KW]
# © 2018 Unicode®, Inc.
# Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries.
# For terms of use, see http://www.unicode.org/terms_of_use.html
diff --git a/admin/unidata/BidiMirroring.txt b/admin/unidata/BidiMirroring.txt
index b3135c03f2e..80dab88a81f 100644
--- a/admin/unidata/BidiMirroring.txt
+++ b/admin/unidata/BidiMirroring.txt
@@ -1,5 +1,5 @@
-# BidiMirroring-11.0.0.txt
-# Date: 2018-05-07, 18:02:00 GMT [KW, LI, RP]
+# BidiMirroring-12.0.0.txt
+# Date: 2018-11-02, 16:33:00 GMT [KW, LI, RP]
# © 2018 Unicode®, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
#
@@ -15,7 +15,7 @@
# value, for which there is another Unicode character that typically has a glyph
# that is the mirror image of the original character's glyph.
#
-# The repertoire covered by the file is Unicode 11.0.0.
+# The repertoire covered by the file is Unicode 12.0.0.
#
# The file contains a list of lines with mappings from one code point
# to another one for character-based mirroring.
diff --git a/admin/unidata/Blocks.txt b/admin/unidata/Blocks.txt
index 357982078a2..7216614be65 100644
--- a/admin/unidata/Blocks.txt
+++ b/admin/unidata/Blocks.txt
@@ -1,6 +1,6 @@
-# Blocks-11.0.0.txt
-# Date: 2017-10-16, 24:39:00 GMT [KW]
-# © 2017 Unicode®, Inc.
+# Blocks-12.0.0.txt
+# Date: 2018-07-30, 19:40:00 GMT [KW]
+# © 2018 Unicode®, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
#
# Unicode Character Database
@@ -239,6 +239,7 @@ FFF0..FFFF; Specials
10E60..10E7F; Rumi Numeral Symbols
10F00..10F2F; Old Sogdian
10F30..10F6F; Sogdian
+10FE0..10FFF; Elymaic
11000..1107F; Brahmi
11080..110CF; Kaithi
110D0..110FF; Sora Sompeng
@@ -259,6 +260,7 @@ FFF0..FFFF; Specials
11700..1173F; Ahom
11800..1184F; Dogra
118A0..118FF; Warang Citi
+119A0..119FF; Nandinagari
11A00..11A4F; Zanabazar Square
11A50..11AAF; Soyombo
11AC0..11AFF; Pau Cin Hau
@@ -267,10 +269,12 @@ FFF0..FFFF; Specials
11D00..11D5F; Masaram Gondi
11D60..11DAF; Gunjala Gondi
11EE0..11EFF; Makasar
+11FC0..11FFF; Tamil Supplement
12000..123FF; Cuneiform
12400..1247F; Cuneiform Numbers and Punctuation
12480..1254F; Early Dynastic Cuneiform
13000..1342F; Egyptian Hieroglyphs
+13430..1343F; Egyptian Hieroglyph Format Controls
14400..1467F; Anatolian Hieroglyphs
16800..16A3F; Bamum Supplement
16A40..16A6F; Mro
@@ -283,6 +287,7 @@ FFF0..FFFF; Specials
18800..18AFF; Tangut Components
1B000..1B0FF; Kana Supplement
1B100..1B12F; Kana Extended-A
+1B130..1B16F; Small Kana Extension
1B170..1B2FF; Nushu
1BC00..1BC9F; Duployan
1BCA0..1BCAF; Shorthand Format Controls
@@ -295,9 +300,12 @@ FFF0..FFFF; Specials
1D400..1D7FF; Mathematical Alphanumeric Symbols
1D800..1DAAF; Sutton SignWriting
1E000..1E02F; Glagolitic Supplement
+1E100..1E14F; Nyiakeng Puachue Hmong
+1E2C0..1E2FF; Wancho
1E800..1E8DF; Mende Kikakui
1E900..1E95F; Adlam
1EC70..1ECBF; Indic Siyaq Numbers
+1ED00..1ED4F; Ottoman Siyaq Numbers
1EE00..1EEFF; Arabic Mathematical Alphabetic Symbols
1F000..1F02F; Mahjong Tiles
1F030..1F09F; Domino Tiles
@@ -313,6 +321,7 @@ FFF0..FFFF; Specials
1F800..1F8FF; Supplemental Arrows-C
1F900..1F9FF; Supplemental Symbols and Pictographs
1FA00..1FA6F; Chess Symbols
+1FA70..1FAFF; Symbols and Pictographs Extended-A
20000..2A6DF; CJK Unified Ideographs Extension B
2A700..2B73F; CJK Unified Ideographs Extension C
2B740..2B81F; CJK Unified Ideographs Extension D
diff --git a/admin/unidata/NormalizationTest.txt b/admin/unidata/NormalizationTest.txt
index 72a31bcdf18..04c935c1f73 100644
--- a/admin/unidata/NormalizationTest.txt
+++ b/admin/unidata/NormalizationTest.txt
@@ -1,6 +1,6 @@
-# NormalizationTest-11.0.0.txt
-# Date: 2018-02-19, 18:33:08 GMT
-# © 2018 Unicode®, Inc.
+# NormalizationTest-12.0.0.txt
+# Date: 2019-01-22, 08:18:33 GMT
+# © 2019 Unicode®, Inc.
# Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries.
# For terms of use, see http://www.unicode.org/terms_of_use.html
#
@@ -16363,6 +16363,7 @@ FFEE;FFEE;FFEE;25CB;25CB; # (○; ○; ○; ○; ○; ) HALFWIDTH WHITE CIRCLE
1F14F;1F14F;1F14F;0057 0043;0057 0043; # (🅏; 🅏; 🅏; WC; WC; ) SQUARED WC
1F16A;1F16A;1F16A;004D 0043;004D 0043; # (🅪; 🅪; 🅪; MC; MC; ) RAISED MC SIGN
1F16B;1F16B;1F16B;004D 0044;004D 0044; # (🅫; 🅫; 🅫; MD; MD; ) RAISED MD SIGN
+1F16C;1F16C;1F16C;004D 0052;004D 0052; # (🅬; 🅬; 🅬; MR; MR; ) RAISED MR SIGN
1F190;1F190;1F190;0044 004A;0044 004A; # (🆐; 🆐; 🆐; DJ; DJ; ) SQUARE DJ
1F200;1F200;1F200;307B 304B;307B 304B; # (🈀; 🈀; 🈀; ほか; ほか; ) SQUARE HIRAGANA HOKA
1F201;1F201;1F201;30B3 30B3;30B3 30B3; # (🈁; 🈁; 🈁; ココ; ココ; ) SQUARED KATAKANA KOKO
@@ -17685,6 +17686,8 @@ FFEE;FFEE;FFEE;25CB;25CB; # (○; ○; ○; ○; ○; ) HALFWIDTH WHITE CIRCLE
0061 0EB8 0EC8 0EB8 0E48 0062;0061 0E48 0EB8 0EB8 0EC8 0062;0061 0E48 0EB8 0EB8 0EC8 0062;0061 0E48 0EB8 0EB8 0EC8 0062;0061 0E48 0EB8 0EB8 0EC8 0062; # (a◌ຸ◌່◌ຸ◌่b; a◌่◌ຸ◌ຸ◌່b; a◌่◌ຸ◌ຸ◌່b; a◌่◌ຸ◌ຸ◌່b; a◌่◌ຸ◌ຸ◌່b; ) LATIN SMALL LETTER A, LAO VOWEL SIGN U, LAO TONE MAI EK, LAO VOWEL SIGN U, THAI CHARACTER MAI EK, LATIN SMALL LETTER B
0061 0EC8 0EB8 0E48 0EB9 0062;0061 0E48 0EB8 0EB9 0EC8 0062;0061 0E48 0EB8 0EB9 0EC8 0062;0061 0E48 0EB8 0EB9 0EC8 0062;0061 0E48 0EB8 0EB9 0EC8 0062; # (a◌່◌ຸ◌่◌ູb; a◌่◌ຸ◌ູ◌່b; a◌่◌ຸ◌ູ◌່b; a◌่◌ຸ◌ູ◌່b; a◌่◌ຸ◌ູ◌່b; ) LATIN SMALL LETTER A, LAO TONE MAI EK, LAO VOWEL SIGN U, THAI CHARACTER MAI EK, LAO VOWEL SIGN UU, LATIN SMALL LETTER B
0061 0EB9 0EC8 0EB8 0E48 0062;0061 0E48 0EB9 0EB8 0EC8 0062;0061 0E48 0EB9 0EB8 0EC8 0062;0061 0E48 0EB9 0EB8 0EC8 0062;0061 0E48 0EB9 0EB8 0EC8 0062; # (a◌ູ◌່◌ຸ◌่b; a◌่◌ູ◌ຸ◌່b; a◌่◌ູ◌ຸ◌່b; a◌่◌ູ◌ຸ◌່b; a◌่◌ູ◌ຸ◌່b; ) LATIN SMALL LETTER A, LAO VOWEL SIGN UU, LAO TONE MAI EK, LAO VOWEL SIGN U, THAI CHARACTER MAI EK, LATIN SMALL LETTER B
+0061 05B0 094D 3099 0EBA 0062;0061 3099 094D 0EBA 05B0 0062;0061 3099 094D 0EBA 05B0 0062;0061 3099 094D 0EBA 05B0 0062;0061 3099 094D 0EBA 05B0 0062; # (a◌ְ◌्◌゙◌຺b; a◌゙◌्◌຺◌ְb; a◌゙◌्◌຺◌ְb; a◌゙◌्◌຺◌ְb; a◌゙◌्◌຺◌ְb; ) LATIN SMALL LETTER A, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, LAO SIGN PALI VIRAMA, LATIN SMALL LETTER B
+0061 0EBA 05B0 094D 3099 0062;0061 3099 0EBA 094D 05B0 0062;0061 3099 0EBA 094D 05B0 0062;0061 3099 0EBA 094D 05B0 0062;0061 3099 0EBA 094D 05B0 0062; # (a◌຺◌ְ◌्◌゙b; a◌゙◌຺◌्◌ְb; a◌゙◌຺◌्◌ְb; a◌゙◌຺◌्◌ְb; a◌゙◌຺◌्◌ְb; ) LATIN SMALL LETTER A, LAO SIGN PALI VIRAMA, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, LATIN SMALL LETTER B
0061 0F71 0EC8 0EB8 0EC8 0062;0061 0EB8 0EC8 0EC8 0F71 0062;0061 0EB8 0EC8 0EC8 0F71 0062;0061 0EB8 0EC8 0EC8 0F71 0062;0061 0EB8 0EC8 0EC8 0F71 0062; # (a◌ཱ◌່◌ຸ◌່b; a◌ຸ◌່◌່◌ཱb; a◌ຸ◌່◌່◌ཱb; a◌ຸ◌່◌່◌ཱb; a◌ຸ◌່◌່◌ཱb; ) LATIN SMALL LETTER A, TIBETAN VOWEL SIGN AA, LAO TONE MAI EK, LAO VOWEL SIGN U, LAO TONE MAI EK, LATIN SMALL LETTER B
0061 0EC8 0F71 0EC8 0EB8 0062;0061 0EB8 0EC8 0EC8 0F71 0062;0061 0EB8 0EC8 0EC8 0F71 0062;0061 0EB8 0EC8 0EC8 0F71 0062;0061 0EB8 0EC8 0EC8 0F71 0062; # (a◌່◌ཱ◌່◌ຸb; a◌ຸ◌່◌່◌ཱb; a◌ຸ◌່◌່◌ཱb; a◌ຸ◌່◌່◌ཱb; a◌ຸ◌່◌່◌ཱb; ) LATIN SMALL LETTER A, LAO TONE MAI EK, TIBETAN VOWEL SIGN AA, LAO TONE MAI EK, LAO VOWEL SIGN U, LATIN SMALL LETTER B
0061 0F71 0EC8 0EB8 0EC9 0062;0061 0EB8 0EC8 0EC9 0F71 0062;0061 0EB8 0EC8 0EC9 0F71 0062;0061 0EB8 0EC8 0EC9 0F71 0062;0061 0EB8 0EC8 0EC9 0F71 0062; # (a◌ཱ◌່◌ຸ◌້b; a◌ຸ◌່◌້◌ཱb; a◌ຸ◌່◌້◌ཱb; a◌ຸ◌່◌້◌ཱb; a◌ຸ◌່◌້◌ཱb; ) LATIN SMALL LETTER A, TIBETAN VOWEL SIGN AA, LAO TONE MAI EK, LAO VOWEL SIGN U, LAO TONE MAI THO, LATIN SMALL LETTER B
@@ -18453,6 +18456,8 @@ FFEE;FFEE;FFEE;25CB;25CB; # (○; ○; ○; ○; ○; ) HALFWIDTH WHITE CIRCLE
0061 11839 05B0 094D 3099 0062;0061 3099 11839 094D 05B0 0062;0061 3099 11839 094D 05B0 0062;0061 3099 11839 094D 05B0 0062;0061 3099 11839 094D 05B0 0062; # (a◌𑠹◌ְ◌्◌゙b; a◌゙◌𑠹◌्◌ְb; a◌゙◌𑠹◌्◌ְb; a◌゙◌𑠹◌्◌ְb; a◌゙◌𑠹◌्◌ְb; ) LATIN SMALL LETTER A, DOGRA SIGN VIRAMA, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, LATIN SMALL LETTER B
0061 3099 093C 0334 1183A 0062;0061 0334 093C 1183A 3099 0062;0061 0334 093C 1183A 3099 0062;0061 0334 093C 1183A 3099 0062;0061 0334 093C 1183A 3099 0062; # (a◌゙◌़◌̴◌𑠺b; a◌̴◌़◌𑠺◌゙b; a◌̴◌़◌𑠺◌゙b; a◌̴◌़◌𑠺◌゙b; a◌̴◌़◌𑠺◌゙b; ) LATIN SMALL LETTER A, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, DOGRA SIGN NUKTA, LATIN SMALL LETTER B
0061 1183A 3099 093C 0334 0062;0061 0334 1183A 093C 3099 0062;0061 0334 1183A 093C 3099 0062;0061 0334 1183A 093C 3099 0062;0061 0334 1183A 093C 3099 0062; # (a◌𑠺◌゙◌़◌̴b; a◌̴◌𑠺◌़◌゙b; a◌̴◌𑠺◌़◌゙b; a◌̴◌𑠺◌़◌゙b; a◌̴◌𑠺◌़◌゙b; ) LATIN SMALL LETTER A, DOGRA SIGN NUKTA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, LATIN SMALL LETTER B
+0061 05B0 094D 3099 119E0 0062;0061 3099 094D 119E0 05B0 0062;0061 3099 094D 119E0 05B0 0062;0061 3099 094D 119E0 05B0 0062;0061 3099 094D 119E0 05B0 0062; # (a◌ְ◌्◌゙◌𑧠b; a◌゙◌्◌𑧠◌ְb; a◌゙◌्◌𑧠◌ְb; a◌゙◌्◌𑧠◌ְb; a◌゙◌्◌𑧠◌ְb; ) LATIN SMALL LETTER A, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, NANDINAGARI SIGN VIRAMA, LATIN SMALL LETTER B
+0061 119E0 05B0 094D 3099 0062;0061 3099 119E0 094D 05B0 0062;0061 3099 119E0 094D 05B0 0062;0061 3099 119E0 094D 05B0 0062;0061 3099 119E0 094D 05B0 0062; # (a◌𑧠◌ְ◌्◌゙b; a◌゙◌𑧠◌्◌ְb; a◌゙◌𑧠◌्◌ְb; a◌゙◌𑧠◌्◌ְb; a◌゙◌𑧠◌्◌ְb; ) LATIN SMALL LETTER A, NANDINAGARI SIGN VIRAMA, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, LATIN SMALL LETTER B
0061 05B0 094D 3099 11A34 0062;0061 3099 094D 11A34 05B0 0062;0061 3099 094D 11A34 05B0 0062;0061 3099 094D 11A34 05B0 0062;0061 3099 094D 11A34 05B0 0062; # (a◌ְ◌्◌゙◌𑨴b; a◌゙◌्◌𑨴◌ְb; a◌゙◌्◌𑨴◌ְb; a◌゙◌्◌𑨴◌ְb; a◌゙◌्◌𑨴◌ְb; ) LATIN SMALL LETTER A, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, ZANABAZAR SQUARE SIGN VIRAMA, LATIN SMALL LETTER B
0061 11A34 05B0 094D 3099 0062;0061 3099 11A34 094D 05B0 0062;0061 3099 11A34 094D 05B0 0062;0061 3099 11A34 094D 05B0 0062;0061 3099 11A34 094D 05B0 0062; # (a◌𑨴◌ְ◌्◌゙b; a◌゙◌𑨴◌्◌ְb; a◌゙◌𑨴◌्◌ְb; a◌゙◌𑨴◌्◌ְb; a◌゙◌𑨴◌्◌ְb; ) LATIN SMALL LETTER A, ZANABAZAR SQUARE SIGN VIRAMA, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, LATIN SMALL LETTER B
0061 05B0 094D 3099 11A47 0062;0061 3099 094D 11A47 05B0 0062;0061 3099 094D 11A47 05B0 0062;0061 3099 094D 11A47 05B0 0062;0061 3099 094D 11A47 05B0 0062; # (a◌ְ◌्◌゙◌𑩇b; a◌゙◌्◌𑩇◌ְb; a◌゙◌्◌𑩇◌ְb; a◌゙◌्◌𑩇◌ְb; a◌゙◌्◌𑩇◌ְb; ) LATIN SMALL LETTER A, HEBREW POINT SHEVA, DEVANAGARI SIGN VIRAMA, COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK, ZANABAZAR SQUARE SUBJOINER, LATIN SMALL LETTER B
@@ -18637,6 +18642,28 @@ FFEE;FFEE;FFEE;25CB;25CB; # (○; ○; ○; ○; ○; ) HALFWIDTH WHITE CIRCLE
0061 1E029 0315 0300 05AE 0062;0061 05AE 1E029 0300 0315 0062;0061 05AE 1E029 0300 0315 0062;0061 05AE 1E029 0300 0315 0062;0061 05AE 1E029 0300 0315 0062; # (a◌𞀩◌̕◌̀◌֮b; a◌֮◌𞀩◌̀◌̕b; a◌֮◌𞀩◌̀◌̕b; a◌֮◌𞀩◌̀◌̕b; a◌֮◌𞀩◌̀◌̕b; ) LATIN SMALL LETTER A, COMBINING GLAGOLITIC LETTER IOTATED BIG YUS, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B
0061 0315 0300 05AE 1E02A 0062;00E0 05AE 1E02A 0315 0062;0061 05AE 0300 1E02A 0315 0062;00E0 05AE 1E02A 0315 0062;0061 05AE 0300 1E02A 0315 0062; # (a◌̕◌̀◌֮◌𞀪b; à◌֮◌𞀪◌̕b; a◌֮◌̀◌𞀪◌̕b; à◌֮◌𞀪◌̕b; a◌֮◌̀◌𞀪◌̕b; ) LATIN SMALL LETTER A, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, COMBINING GLAGOLITIC LETTER FITA, LATIN SMALL LETTER B
0061 1E02A 0315 0300 05AE 0062;0061 05AE 1E02A 0300 0315 0062;0061 05AE 1E02A 0300 0315 0062;0061 05AE 1E02A 0300 0315 0062;0061 05AE 1E02A 0300 0315 0062; # (a◌𞀪◌̕◌̀◌֮b; a◌֮◌𞀪◌̀◌̕b; a◌֮◌𞀪◌̀◌̕b; a◌֮◌𞀪◌̀◌̕b; a◌֮◌𞀪◌̀◌̕b; ) LATIN SMALL LETTER A, COMBINING GLAGOLITIC LETTER FITA, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B
+0061 0315 0300 05AE 1E130 0062;00E0 05AE 1E130 0315 0062;0061 05AE 0300 1E130 0315 0062;00E0 05AE 1E130 0315 0062;0061 05AE 0300 1E130 0315 0062; # (a◌̕◌̀◌֮◌𞄰b; à◌֮◌𞄰◌̕b; a◌֮◌̀◌𞄰◌̕b; à◌֮◌𞄰◌̕b; a◌֮◌̀◌𞄰◌̕b; ) LATIN SMALL LETTER A, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, NYIAKENG PUACHUE HMONG TONE-B, LATIN SMALL LETTER B
+0061 1E130 0315 0300 05AE 0062;0061 05AE 1E130 0300 0315 0062;0061 05AE 1E130 0300 0315 0062;0061 05AE 1E130 0300 0315 0062;0061 05AE 1E130 0300 0315 0062; # (a◌𞄰◌̕◌̀◌֮b; a◌֮◌𞄰◌̀◌̕b; a◌֮◌𞄰◌̀◌̕b; a◌֮◌𞄰◌̀◌̕b; a◌֮◌𞄰◌̀◌̕b; ) LATIN SMALL LETTER A, NYIAKENG PUACHUE HMONG TONE-B, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B
+0061 0315 0300 05AE 1E131 0062;00E0 05AE 1E131 0315 0062;0061 05AE 0300 1E131 0315 0062;00E0 05AE 1E131 0315 0062;0061 05AE 0300 1E131 0315 0062; # (a◌̕◌̀◌֮◌𞄱b; à◌֮◌𞄱◌̕b; a◌֮◌̀◌𞄱◌̕b; à◌֮◌𞄱◌̕b; a◌֮◌̀◌𞄱◌̕b; ) LATIN SMALL LETTER A, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, NYIAKENG PUACHUE HMONG TONE-M, LATIN SMALL LETTER B
+0061 1E131 0315 0300 05AE 0062;0061 05AE 1E131 0300 0315 0062;0061 05AE 1E131 0300 0315 0062;0061 05AE 1E131 0300 0315 0062;0061 05AE 1E131 0300 0315 0062; # (a◌𞄱◌̕◌̀◌֮b; a◌֮◌𞄱◌̀◌̕b; a◌֮◌𞄱◌̀◌̕b; a◌֮◌𞄱◌̀◌̕b; a◌֮◌𞄱◌̀◌̕b; ) LATIN SMALL LETTER A, NYIAKENG PUACHUE HMONG TONE-M, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B
+0061 0315 0300 05AE 1E132 0062;00E0 05AE 1E132 0315 0062;0061 05AE 0300 1E132 0315 0062;00E0 05AE 1E132 0315 0062;0061 05AE 0300 1E132 0315 0062; # (a◌̕◌̀◌֮◌𞄲b; à◌֮◌𞄲◌̕b; a◌֮◌̀◌𞄲◌̕b; à◌֮◌𞄲◌̕b; a◌֮◌̀◌𞄲◌̕b; ) LATIN SMALL LETTER A, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, NYIAKENG PUACHUE HMONG TONE-J, LATIN SMALL LETTER B
+0061 1E132 0315 0300 05AE 0062;0061 05AE 1E132 0300 0315 0062;0061 05AE 1E132 0300 0315 0062;0061 05AE 1E132 0300 0315 0062;0061 05AE 1E132 0300 0315 0062; # (a◌𞄲◌̕◌̀◌֮b; a◌֮◌𞄲◌̀◌̕b; a◌֮◌𞄲◌̀◌̕b; a◌֮◌𞄲◌̀◌̕b; a◌֮◌𞄲◌̀◌̕b; ) LATIN SMALL LETTER A, NYIAKENG PUACHUE HMONG TONE-J, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B
+0061 0315 0300 05AE 1E133 0062;00E0 05AE 1E133 0315 0062;0061 05AE 0300 1E133 0315 0062;00E0 05AE 1E133 0315 0062;0061 05AE 0300 1E133 0315 0062; # (a◌̕◌̀◌֮◌𞄳b; à◌֮◌𞄳◌̕b; a◌֮◌̀◌𞄳◌̕b; à◌֮◌𞄳◌̕b; a◌֮◌̀◌𞄳◌̕b; ) LATIN SMALL LETTER A, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, NYIAKENG PUACHUE HMONG TONE-V, LATIN SMALL LETTER B
+0061 1E133 0315 0300 05AE 0062;0061 05AE 1E133 0300 0315 0062;0061 05AE 1E133 0300 0315 0062;0061 05AE 1E133 0300 0315 0062;0061 05AE 1E133 0300 0315 0062; # (a◌𞄳◌̕◌̀◌֮b; a◌֮◌𞄳◌̀◌̕b; a◌֮◌𞄳◌̀◌̕b; a◌֮◌𞄳◌̀◌̕b; a◌֮◌𞄳◌̀◌̕b; ) LATIN SMALL LETTER A, NYIAKENG PUACHUE HMONG TONE-V, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B
+0061 0315 0300 05AE 1E134 0062;00E0 05AE 1E134 0315 0062;0061 05AE 0300 1E134 0315 0062;00E0 05AE 1E134 0315 0062;0061 05AE 0300 1E134 0315 0062; # (a◌̕◌̀◌֮◌𞄴b; à◌֮◌𞄴◌̕b; a◌֮◌̀◌𞄴◌̕b; à◌֮◌𞄴◌̕b; a◌֮◌̀◌𞄴◌̕b; ) LATIN SMALL LETTER A, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, NYIAKENG PUACHUE HMONG TONE-S, LATIN SMALL LETTER B
+0061 1E134 0315 0300 05AE 0062;0061 05AE 1E134 0300 0315 0062;0061 05AE 1E134 0300 0315 0062;0061 05AE 1E134 0300 0315 0062;0061 05AE 1E134 0300 0315 0062; # (a◌𞄴◌̕◌̀◌֮b; a◌֮◌𞄴◌̀◌̕b; a◌֮◌𞄴◌̀◌̕b; a◌֮◌𞄴◌̀◌̕b; a◌֮◌𞄴◌̀◌̕b; ) LATIN SMALL LETTER A, NYIAKENG PUACHUE HMONG TONE-S, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B
+0061 0315 0300 05AE 1E135 0062;00E0 05AE 1E135 0315 0062;0061 05AE 0300 1E135 0315 0062;00E0 05AE 1E135 0315 0062;0061 05AE 0300 1E135 0315 0062; # (a◌̕◌̀◌֮◌𞄵b; à◌֮◌𞄵◌̕b; a◌֮◌̀◌𞄵◌̕b; à◌֮◌𞄵◌̕b; a◌֮◌̀◌𞄵◌̕b; ) LATIN SMALL LETTER A, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, NYIAKENG PUACHUE HMONG TONE-G, LATIN SMALL LETTER B
+0061 1E135 0315 0300 05AE 0062;0061 05AE 1E135 0300 0315 0062;0061 05AE 1E135 0300 0315 0062;0061 05AE 1E135 0300 0315 0062;0061 05AE 1E135 0300 0315 0062; # (a◌𞄵◌̕◌̀◌֮b; a◌֮◌𞄵◌̀◌̕b; a◌֮◌𞄵◌̀◌̕b; a◌֮◌𞄵◌̀◌̕b; a◌֮◌𞄵◌̀◌̕b; ) LATIN SMALL LETTER A, NYIAKENG PUACHUE HMONG TONE-G, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B
+0061 0315 0300 05AE 1E136 0062;00E0 05AE 1E136 0315 0062;0061 05AE 0300 1E136 0315 0062;00E0 05AE 1E136 0315 0062;0061 05AE 0300 1E136 0315 0062; # (a◌̕◌̀◌֮◌𞄶b; à◌֮◌𞄶◌̕b; a◌֮◌̀◌𞄶◌̕b; à◌֮◌𞄶◌̕b; a◌֮◌̀◌𞄶◌̕b; ) LATIN SMALL LETTER A, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, NYIAKENG PUACHUE HMONG TONE-D, LATIN SMALL LETTER B
+0061 1E136 0315 0300 05AE 0062;0061 05AE 1E136 0300 0315 0062;0061 05AE 1E136 0300 0315 0062;0061 05AE 1E136 0300 0315 0062;0061 05AE 1E136 0300 0315 0062; # (a◌𞄶◌̕◌̀◌֮b; a◌֮◌𞄶◌̀◌̕b; a◌֮◌𞄶◌̀◌̕b; a◌֮◌𞄶◌̀◌̕b; a◌֮◌𞄶◌̀◌̕b; ) LATIN SMALL LETTER A, NYIAKENG PUACHUE HMONG TONE-D, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B
+0061 0315 0300 05AE 1E2EC 0062;00E0 05AE 1E2EC 0315 0062;0061 05AE 0300 1E2EC 0315 0062;00E0 05AE 1E2EC 0315 0062;0061 05AE 0300 1E2EC 0315 0062; # (a◌̕◌̀◌֮◌𞋬b; à◌֮◌𞋬◌̕b; a◌֮◌̀◌𞋬◌̕b; à◌֮◌𞋬◌̕b; a◌֮◌̀◌𞋬◌̕b; ) LATIN SMALL LETTER A, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, WANCHO TONE TUP, LATIN SMALL LETTER B
+0061 1E2EC 0315 0300 05AE 0062;0061 05AE 1E2EC 0300 0315 0062;0061 05AE 1E2EC 0300 0315 0062;0061 05AE 1E2EC 0300 0315 0062;0061 05AE 1E2EC 0300 0315 0062; # (a◌𞋬◌̕◌̀◌֮b; a◌֮◌𞋬◌̀◌̕b; a◌֮◌𞋬◌̀◌̕b; a◌֮◌𞋬◌̀◌̕b; a◌֮◌𞋬◌̀◌̕b; ) LATIN SMALL LETTER A, WANCHO TONE TUP, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B
+0061 0315 0300 05AE 1E2ED 0062;00E0 05AE 1E2ED 0315 0062;0061 05AE 0300 1E2ED 0315 0062;00E0 05AE 1E2ED 0315 0062;0061 05AE 0300 1E2ED 0315 0062; # (a◌̕◌̀◌֮◌𞋭b; à◌֮◌𞋭◌̕b; a◌֮◌̀◌𞋭◌̕b; à◌֮◌𞋭◌̕b; a◌֮◌̀◌𞋭◌̕b; ) LATIN SMALL LETTER A, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, WANCHO TONE TUPNI, LATIN SMALL LETTER B
+0061 1E2ED 0315 0300 05AE 0062;0061 05AE 1E2ED 0300 0315 0062;0061 05AE 1E2ED 0300 0315 0062;0061 05AE 1E2ED 0300 0315 0062;0061 05AE 1E2ED 0300 0315 0062; # (a◌𞋭◌̕◌̀◌֮b; a◌֮◌𞋭◌̀◌̕b; a◌֮◌𞋭◌̀◌̕b; a◌֮◌𞋭◌̀◌̕b; a◌֮◌𞋭◌̀◌̕b; ) LATIN SMALL LETTER A, WANCHO TONE TUPNI, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B
+0061 0315 0300 05AE 1E2EE 0062;00E0 05AE 1E2EE 0315 0062;0061 05AE 0300 1E2EE 0315 0062;00E0 05AE 1E2EE 0315 0062;0061 05AE 0300 1E2EE 0315 0062; # (a◌̕◌̀◌֮◌𞋮b; à◌֮◌𞋮◌̕b; a◌֮◌̀◌𞋮◌̕b; à◌֮◌𞋮◌̕b; a◌֮◌̀◌𞋮◌̕b; ) LATIN SMALL LETTER A, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, WANCHO TONE KOI, LATIN SMALL LETTER B
+0061 1E2EE 0315 0300 05AE 0062;0061 05AE 1E2EE 0300 0315 0062;0061 05AE 1E2EE 0300 0315 0062;0061 05AE 1E2EE 0300 0315 0062;0061 05AE 1E2EE 0300 0315 0062; # (a◌𞋮◌̕◌̀◌֮b; a◌֮◌𞋮◌̀◌̕b; a◌֮◌𞋮◌̀◌̕b; a◌֮◌𞋮◌̀◌̕b; a◌֮◌𞋮◌̀◌̕b; ) LATIN SMALL LETTER A, WANCHO TONE KOI, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B
+0061 0315 0300 05AE 1E2EF 0062;00E0 05AE 1E2EF 0315 0062;0061 05AE 0300 1E2EF 0315 0062;00E0 05AE 1E2EF 0315 0062;0061 05AE 0300 1E2EF 0315 0062; # (a◌̕◌̀◌֮◌𞋯b; à◌֮◌𞋯◌̕b; a◌֮◌̀◌𞋯◌̕b; à◌֮◌𞋯◌̕b; a◌֮◌̀◌𞋯◌̕b; ) LATIN SMALL LETTER A, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, WANCHO TONE KOINI, LATIN SMALL LETTER B
+0061 1E2EF 0315 0300 05AE 0062;0061 05AE 1E2EF 0300 0315 0062;0061 05AE 1E2EF 0300 0315 0062;0061 05AE 1E2EF 0300 0315 0062;0061 05AE 1E2EF 0300 0315 0062; # (a◌𞋯◌̕◌̀◌֮b; a◌֮◌𞋯◌̀◌̕b; a◌֮◌𞋯◌̀◌̕b; a◌֮◌𞋯◌̀◌̕b; a◌֮◌𞋯◌̀◌̕b; ) LATIN SMALL LETTER A, WANCHO TONE KOINI, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B
0061 059A 0316 302A 1E8D0 0062;0061 302A 0316 1E8D0 059A 0062;0061 302A 0316 1E8D0 059A 0062;0061 302A 0316 1E8D0 059A 0062;0061 302A 0316 1E8D0 059A 0062; # (a◌֚◌̖◌〪◌𞣐b; a◌〪◌̖◌𞣐◌֚b; a◌〪◌̖◌𞣐◌֚b; a◌〪◌̖◌𞣐◌֚b; a◌〪◌̖◌𞣐◌֚b; ) LATIN SMALL LETTER A, HEBREW ACCENT YETIV, COMBINING GRAVE ACCENT BELOW, IDEOGRAPHIC LEVEL TONE MARK, MENDE KIKAKUI COMBINING NUMBER TEENS, LATIN SMALL LETTER B
0061 1E8D0 059A 0316 302A 0062;0061 302A 1E8D0 0316 059A 0062;0061 302A 1E8D0 0316 059A 0062;0061 302A 1E8D0 0316 059A 0062;0061 302A 1E8D0 0316 059A 0062; # (a◌𞣐◌֚◌̖◌〪b; a◌〪◌𞣐◌̖◌֚b; a◌〪◌𞣐◌̖◌֚b; a◌〪◌𞣐◌̖◌֚b; a◌〪◌𞣐◌̖◌֚b; ) LATIN SMALL LETTER A, MENDE KIKAKUI COMBINING NUMBER TEENS, HEBREW ACCENT YETIV, COMBINING GRAVE ACCENT BELOW, IDEOGRAPHIC LEVEL TONE MARK, LATIN SMALL LETTER B
0061 059A 0316 302A 1E8D1 0062;0061 302A 0316 1E8D1 059A 0062;0061 302A 0316 1E8D1 059A 0062;0061 302A 0316 1E8D1 059A 0062;0061 302A 0316 1E8D1 059A 0062; # (a◌֚◌̖◌〪◌𞣑b; a◌〪◌̖◌𞣑◌֚b; a◌〪◌̖◌𞣑◌֚b; a◌〪◌̖◌𞣑◌֚b; a◌〪◌̖◌𞣑◌֚b; ) LATIN SMALL LETTER A, HEBREW ACCENT YETIV, COMBINING GRAVE ACCENT BELOW, IDEOGRAPHIC LEVEL TONE MARK, MENDE KIKAKUI COMBINING NUMBER TENS, LATIN SMALL LETTER B
diff --git a/admin/unidata/SpecialCasing.txt b/admin/unidata/SpecialCasing.txt
index c90d09acb3a..7db2e31ab0b 100644
--- a/admin/unidata/SpecialCasing.txt
+++ b/admin/unidata/SpecialCasing.txt
@@ -1,6 +1,6 @@
-# SpecialCasing-11.0.0.txt
-# Date: 2018-02-22, 06:16:47 GMT
-# © 2018 Unicode®, Inc.
+# SpecialCasing-12.0.0.txt
+# Date: 2019-01-22, 08:18:50 GMT
+# © 2019 Unicode®, Inc.
# Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries.
# For terms of use, see http://www.unicode.org/terms_of_use.html
#
diff --git a/admin/unidata/UnicodeData.txt b/admin/unidata/UnicodeData.txt
index ec32fafbce5..d88a60135f4 100644
--- a/admin/unidata/UnicodeData.txt
+++ b/admin/unidata/UnicodeData.txt
@@ -640,7 +640,7 @@
027F;LATIN SMALL LETTER REVERSED R WITH FISHHOOK;Ll;0;L;;;;;N;LATIN SMALL LETTER REVERSED FISHHOOK R;;;;
0280;LATIN LETTER SMALL CAPITAL R;Ll;0;L;;;;;N;;;01A6;;01A6
0281;LATIN LETTER SMALL CAPITAL INVERTED R;Ll;0;L;;;;;N;;;;;
-0282;LATIN SMALL LETTER S WITH HOOK;Ll;0;L;;;;;N;LATIN SMALL LETTER S HOOK;;;;
+0282;LATIN SMALL LETTER S WITH HOOK;Ll;0;L;;;;;N;LATIN SMALL LETTER S HOOK;;A7C5;;A7C5
0283;LATIN SMALL LETTER ESH;Ll;0;L;;;;;N;;;01A9;;01A9
0284;LATIN SMALL LETTER DOTLESS J WITH STROKE AND HOOK;Ll;0;L;;;;;N;LATIN SMALL LETTER DOTLESS J BAR HOOK;;;;
0285;LATIN SMALL LETTER SQUAT REVERSED ESH;Ll;0;L;;;;;N;;;;;
@@ -2809,6 +2809,7 @@
0C6D;TELUGU DIGIT SEVEN;Nd;0;L;;7;7;7;N;;;;;
0C6E;TELUGU DIGIT EIGHT;Nd;0;L;;8;8;8;N;;;;;
0C6F;TELUGU DIGIT NINE;Nd;0;L;;9;9;9;N;;;;;
+0C77;TELUGU SIGN SIDDHAM;Po;0;L;;;;;N;;;;;
0C78;TELUGU FRACTION DIGIT ZERO FOR ODD POWERS OF FOUR;No;0;ON;;;;0;N;;;;;
0C79;TELUGU FRACTION DIGIT ONE FOR ODD POWERS OF FOUR;No;0;ON;;;;1;N;;;;;
0C7A;TELUGU FRACTION DIGIT TWO FOR ODD POWERS OF FOUR;No;0;ON;;;;2;N;;;;;
@@ -3203,14 +3204,24 @@
0E81;LAO LETTER KO;Lo;0;L;;;;;N;;;;;
0E82;LAO LETTER KHO SUNG;Lo;0;L;;;;;N;;;;;
0E84;LAO LETTER KHO TAM;Lo;0;L;;;;;N;;;;;
+0E86;LAO LETTER PALI GHA;Lo;0;L;;;;;N;;;;;
0E87;LAO LETTER NGO;Lo;0;L;;;;;N;;;;;
0E88;LAO LETTER CO;Lo;0;L;;;;;N;;;;;
+0E89;LAO LETTER PALI CHA;Lo;0;L;;;;;N;;;;;
0E8A;LAO LETTER SO TAM;Lo;0;L;;;;;N;;;;;
+0E8C;LAO LETTER PALI JHA;Lo;0;L;;;;;N;;;;;
0E8D;LAO LETTER NYO;Lo;0;L;;;;;N;;;;;
+0E8E;LAO LETTER PALI NYA;Lo;0;L;;;;;N;;;;;
+0E8F;LAO LETTER PALI TTA;Lo;0;L;;;;;N;;;;;
+0E90;LAO LETTER PALI TTHA;Lo;0;L;;;;;N;;;;;
+0E91;LAO LETTER PALI DDA;Lo;0;L;;;;;N;;;;;
+0E92;LAO LETTER PALI DDHA;Lo;0;L;;;;;N;;;;;
+0E93;LAO LETTER PALI NNA;Lo;0;L;;;;;N;;;;;
0E94;LAO LETTER DO;Lo;0;L;;;;;N;;;;;
0E95;LAO LETTER TO;Lo;0;L;;;;;N;;;;;
0E96;LAO LETTER THO SUNG;Lo;0;L;;;;;N;;;;;
0E97;LAO LETTER THO TAM;Lo;0;L;;;;;N;;;;;
+0E98;LAO LETTER PALI DHA;Lo;0;L;;;;;N;;;;;
0E99;LAO LETTER NO;Lo;0;L;;;;;N;;;;;
0E9A;LAO LETTER BO;Lo;0;L;;;;;N;;;;;
0E9B;LAO LETTER PO;Lo;0;L;;;;;N;;;;;
@@ -3218,13 +3229,17 @@
0E9D;LAO LETTER FO TAM;Lo;0;L;;;;;N;;;;;
0E9E;LAO LETTER PHO TAM;Lo;0;L;;;;;N;;;;;
0E9F;LAO LETTER FO SUNG;Lo;0;L;;;;;N;;;;;
+0EA0;LAO LETTER PALI BHA;Lo;0;L;;;;;N;;;;;
0EA1;LAO LETTER MO;Lo;0;L;;;;;N;;;;;
0EA2;LAO LETTER YO;Lo;0;L;;;;;N;;;;;
0EA3;LAO LETTER LO LING;Lo;0;L;;;;;N;;;;;
0EA5;LAO LETTER LO LOOT;Lo;0;L;;;;;N;;;;;
0EA7;LAO LETTER WO;Lo;0;L;;;;;N;;;;;
+0EA8;LAO LETTER SANSKRIT SHA;Lo;0;L;;;;;N;;;;;
+0EA9;LAO LETTER SANSKRIT SSA;Lo;0;L;;;;;N;;;;;
0EAA;LAO LETTER SO SUNG;Lo;0;L;;;;;N;;;;;
0EAB;LAO LETTER HO SUNG;Lo;0;L;;;;;N;;;;;
+0EAC;LAO LETTER PALI LLA;Lo;0;L;;;;;N;;;;;
0EAD;LAO LETTER O;Lo;0;L;;;;;N;;;;;
0EAE;LAO LETTER HO TAM;Lo;0;L;;;;;N;;;;;
0EAF;LAO ELLIPSIS;Lo;0;L;;;;;N;;;;;
@@ -3238,6 +3253,7 @@
0EB7;LAO VOWEL SIGN YY;Mn;0;NSM;;;;;N;;;;;
0EB8;LAO VOWEL SIGN U;Mn;118;NSM;;;;;N;;;;;
0EB9;LAO VOWEL SIGN UU;Mn;118;NSM;;;;;N;;;;;
+0EBA;LAO SIGN PALI VIRAMA;Mn;9;NSM;;;;;N;;;;;
0EBB;LAO VOWEL SIGN MAI KON;Mn;0;NSM;;;;;N;;;;;
0EBC;LAO SEMIVOWEL SIGN LO;Mn;0;NSM;;;;;N;;;;;
0EBD;LAO SEMIVOWEL SIGN NYO;Lo;0;L;;;;;N;;;;;
@@ -5079,7 +5095,7 @@
166A;CANADIAN SYLLABICS CARRIER TTSEE;Lo;0;L;;;;;N;;;;;
166B;CANADIAN SYLLABICS CARRIER TTSI;Lo;0;L;;;;;N;;;;;
166C;CANADIAN SYLLABICS CARRIER TTSA;Lo;0;L;;;;;N;;;;;
-166D;CANADIAN SYLLABICS CHI SIGN;Po;0;L;;;;;N;;;;;
+166D;CANADIAN SYLLABICS CHI SIGN;So;0;L;;;;;N;;;;;
166E;CANADIAN SYLLABICS FULL STOP;Po;0;L;;;;;N;;;;;
166F;CANADIAN SYLLABICS QAI;Lo;0;L;;;;;N;;;;;
1670;CANADIAN SYLLABICS NGAI;Lo;0;L;;;;;N;;;;;
@@ -6488,14 +6504,15 @@
1CEF;VEDIC SIGN LONG ANUSVARA;Lo;0;L;;;;;N;;;;;
1CF0;VEDIC SIGN RTHANG LONG ANUSVARA;Lo;0;L;;;;;N;;;;;
1CF1;VEDIC SIGN ANUSVARA UBHAYATO MUKHA;Lo;0;L;;;;;N;;;;;
-1CF2;VEDIC SIGN ARDHAVISARGA;Mc;0;L;;;;;N;;;;;
-1CF3;VEDIC SIGN ROTATED ARDHAVISARGA;Mc;0;L;;;;;N;;;;;
+1CF2;VEDIC SIGN ARDHAVISARGA;Lo;0;L;;;;;N;;;;;
+1CF3;VEDIC SIGN ROTATED ARDHAVISARGA;Lo;0;L;;;;;N;;;;;
1CF4;VEDIC TONE CANDRA ABOVE;Mn;230;NSM;;;;;N;;;;;
1CF5;VEDIC SIGN JIHVAMULIYA;Lo;0;L;;;;;N;;;;;
1CF6;VEDIC SIGN UPADHMANIYA;Lo;0;L;;;;;N;;;;;
1CF7;VEDIC SIGN ATIKRAMA;Mc;0;L;;;;;N;;;;;
1CF8;VEDIC TONE RING ABOVE;Mn;230;NSM;;;;;N;;;;;
1CF9;VEDIC TONE DOUBLE RING ABOVE;Mn;230;NSM;;;;;N;;;;;
+1CFA;VEDIC SIGN DOUBLE ANUSVARA ANTARGOMUKHA;Lo;0;L;;;;;N;;;;;
1D00;LATIN LETTER SMALL CAPITAL A;Ll;0;L;;;;;N;;;;;
1D01;LATIN LETTER SMALL CAPITAL AE;Ll;0;L;;;;;N;;;;;
1D02;LATIN SMALL LETTER TURNED AE;Ll;0;L;;;;;N;;;;;
@@ -6638,7 +6655,7 @@
1D8B;LATIN SMALL LETTER ESH WITH PALATAL HOOK;Ll;0;L;;;;;N;;;;;
1D8C;LATIN SMALL LETTER V WITH PALATAL HOOK;Ll;0;L;;;;;N;;;;;
1D8D;LATIN SMALL LETTER X WITH PALATAL HOOK;Ll;0;L;;;;;N;;;;;
-1D8E;LATIN SMALL LETTER Z WITH PALATAL HOOK;Ll;0;L;;;;;N;;;;;
+1D8E;LATIN SMALL LETTER Z WITH PALATAL HOOK;Ll;0;L;;;;;N;;;A7C6;;A7C6
1D8F;LATIN SMALL LETTER A WITH RETROFLEX HOOK;Ll;0;L;;;;;N;;;;;
1D90;LATIN SMALL LETTER ALPHA WITH RETROFLEX HOOK;Ll;0;L;;;;;N;;;;;
1D91;LATIN SMALL LETTER D WITH HOOK AND TAIL;Ll;0;L;;;;;N;;;;;
@@ -10165,6 +10182,7 @@
2BC6;BLACK MEDIUM DOWN-POINTING TRIANGLE CENTRED;So;0;ON;;;;;N;;;;;
2BC7;BLACK MEDIUM LEFT-POINTING TRIANGLE CENTRED;So;0;ON;;;;;N;;;;;
2BC8;BLACK MEDIUM RIGHT-POINTING TRIANGLE CENTRED;So;0;ON;;;;;N;;;;;
+2BC9;NEPTUNE FORM TWO;So;0;ON;;;;;N;;;;;
2BCA;TOP HALF BLACK CIRCLE;So;0;ON;;;;;N;;;;;
2BCB;BOTTOM HALF BLACK CIRCLE;So;0;ON;;;;;N;;;;;
2BCC;LIGHT FOUR POINTED BLACK CUSP;So;0;ON;;;;;N;;;;;
@@ -10218,6 +10236,7 @@
2BFC;DOUBLED SYMBOL;So;0;ON;;;;;N;;;;;
2BFD;PASSED SYMBOL;So;0;ON;;;;;N;;;;;
2BFE;REVERSED RIGHT ANGLE;So;0;ON;;;;;Y;;;;;
+2BFF;HELLSCHREIBER PAUSE SYMBOL;So;0;ON;;;;;N;;;;;
2C00;GLAGOLITIC CAPITAL LETTER AZU;Lu;0;L;;;;;N;;;;2C30;
2C01;GLAGOLITIC CAPITAL LETTER BUKY;Lu;0;L;;;;;N;;;;2C31;
2C02;GLAGOLITIC CAPITAL LETTER VEDE;Lu;0;L;;;;;N;;;;2C32;
@@ -10756,6 +10775,7 @@
2E4C;MEDIEVAL COMMA;Po;0;ON;;;;;N;;;;;
2E4D;PARAGRAPHUS MARK;Po;0;ON;;;;;N;;;;;
2E4E;PUNCTUS ELEVATUS MARK;Po;0;ON;;;;;N;;;;;
+2E4F;CORNISH VERSE DIVIDER;Po;0;ON;;;;;N;;;;;
2E80;CJK RADICAL REPEAT;So;0;ON;;;;;N;;;;;
2E81;CJK RADICAL CLIFF;So;0;ON;;;;;N;;;;;
2E82;CJK RADICAL SECOND ONE;So;0;ON;;;;;N;;;;;
@@ -14060,7 +14080,7 @@ A790;LATIN CAPITAL LETTER N WITH DESCENDER;Lu;0;L;;;;;N;;;;A791;
A791;LATIN SMALL LETTER N WITH DESCENDER;Ll;0;L;;;;;N;;;A790;;A790
A792;LATIN CAPITAL LETTER C WITH BAR;Lu;0;L;;;;;N;;;;A793;
A793;LATIN SMALL LETTER C WITH BAR;Ll;0;L;;;;;N;;;A792;;A792
-A794;LATIN SMALL LETTER C WITH PALATAL HOOK;Ll;0;L;;;;;N;;;;;
+A794;LATIN SMALL LETTER C WITH PALATAL HOOK;Ll;0;L;;;;;N;;;A7C4;;A7C4
A795;LATIN SMALL LETTER H WITH PALATAL HOOK;Ll;0;L;;;;;N;;;;;
A796;LATIN CAPITAL LETTER B WITH FLOURISH;Lu;0;L;;;;;N;;;;A797;
A797;LATIN SMALL LETTER B WITH FLOURISH;Ll;0;L;;;;;N;;;A796;;A796
@@ -14098,6 +14118,17 @@ A7B6;LATIN CAPITAL LETTER OMEGA;Lu;0;L;;;;;N;;;;A7B7;
A7B7;LATIN SMALL LETTER OMEGA;Ll;0;L;;;;;N;;;A7B6;;A7B6
A7B8;LATIN CAPITAL LETTER U WITH STROKE;Lu;0;L;;;;;N;;;;A7B9;
A7B9;LATIN SMALL LETTER U WITH STROKE;Ll;0;L;;;;;N;;;A7B8;;A7B8
+A7BA;LATIN CAPITAL LETTER GLOTTAL A;Lu;0;L;;;;;N;;;;A7BB;
+A7BB;LATIN SMALL LETTER GLOTTAL A;Ll;0;L;;;;;N;;;A7BA;;A7BA
+A7BC;LATIN CAPITAL LETTER GLOTTAL I;Lu;0;L;;;;;N;;;;A7BD;
+A7BD;LATIN SMALL LETTER GLOTTAL I;Ll;0;L;;;;;N;;;A7BC;;A7BC
+A7BE;LATIN CAPITAL LETTER GLOTTAL U;Lu;0;L;;;;;N;;;;A7BF;
+A7BF;LATIN SMALL LETTER GLOTTAL U;Ll;0;L;;;;;N;;;A7BE;;A7BE
+A7C2;LATIN CAPITAL LETTER ANGLICANA W;Lu;0;L;;;;;N;;;;A7C3;
+A7C3;LATIN SMALL LETTER ANGLICANA W;Ll;0;L;;;;;N;;;A7C2;;A7C2
+A7C4;LATIN CAPITAL LETTER C WITH PALATAL HOOK;Lu;0;L;;;;;N;;;;A794;
+A7C5;LATIN CAPITAL LETTER S WITH HOOK;Lu;0;L;;;;;N;;;;0282;
+A7C6;LATIN CAPITAL LETTER Z WITH PALATAL HOOK;Lu;0;L;;;;;N;;;;1D8E;
A7F7;LATIN EPIGRAPHIC LETTER SIDEWAYS I;Lo;0;L;;;;;N;;;;;
A7F8;MODIFIER LETTER CAPITAL H WITH STROKE;Lm;0;L;<super> 0126;;;;N;;;;;
A7F9;MODIFIER LETTER SMALL LIGATURE OE;Lm;0;L;<super> 0153;;;;N;;;;;
@@ -14506,7 +14537,7 @@ A9B9;JAVANESE VOWEL SIGN SUKU MENDUT;Mn;0;NSM;;;;;N;;;;;
A9BA;JAVANESE VOWEL SIGN TALING;Mc;0;L;;;;;N;;;;;
A9BB;JAVANESE VOWEL SIGN DIRGA MURE;Mc;0;L;;;;;N;;;;;
A9BC;JAVANESE VOWEL SIGN PEPET;Mn;0;NSM;;;;;N;;;;;
-A9BD;JAVANESE CONSONANT SIGN KERET;Mc;0;L;;;;;N;;;;;
+A9BD;JAVANESE CONSONANT SIGN KERET;Mn;0;NSM;;;;;N;;;;;
A9BE;JAVANESE CONSONANT SIGN PENGKAL;Mc;0;L;;;;;N;;;;;
A9BF;JAVANESE CONSONANT SIGN CAKRA;Mc;0;L;;;;;N;;;;;
A9C0;JAVANESE PANGKON;Mc;9;L;;;;;N;;;;;
@@ -14863,6 +14894,8 @@ AB62;LATIN SMALL LETTER OPEN OE;Ll;0;L;;;;;N;;;;;
AB63;LATIN SMALL LETTER UO;Ll;0;L;;;;;N;;;;;
AB64;LATIN SMALL LETTER INVERTED ALPHA;Ll;0;L;;;;;N;;;;;
AB65;GREEK LETTER SMALL CAPITAL OMEGA;Ll;0;L;;;;;N;;;;;
+AB66;LATIN SMALL LETTER DZ DIGRAPH WITH RETROFLEX HOOK;Ll;0;L;;;;;N;;;;;
+AB67;LATIN SMALL LETTER TS DIGRAPH WITH RETROFLEX HOOK;Ll;0;L;;;;;N;;;;;
AB70;CHEROKEE SMALL LETTER A;Ll;0;L;;;;;N;;;13A0;;13A0
AB71;CHEROKEE SMALL LETTER E;Ll;0;L;;;;;N;;;13A1;;13A1
AB72;CHEROKEE SMALL LETTER I;Ll;0;L;;;;;N;;;13A2;;13A2
@@ -19105,6 +19138,29 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
10F57;SOGDIAN PUNCTUATION CIRCLE WITH DOT;Po;0;AL;;;;;N;;;;;
10F58;SOGDIAN PUNCTUATION TWO CIRCLES WITH DOTS;Po;0;AL;;;;;N;;;;;
10F59;SOGDIAN PUNCTUATION HALF CIRCLE WITH DOT;Po;0;AL;;;;;N;;;;;
+10FE0;ELYMAIC LETTER ALEPH;Lo;0;R;;;;;N;;;;;
+10FE1;ELYMAIC LETTER BETH;Lo;0;R;;;;;N;;;;;
+10FE2;ELYMAIC LETTER GIMEL;Lo;0;R;;;;;N;;;;;
+10FE3;ELYMAIC LETTER DALETH;Lo;0;R;;;;;N;;;;;
+10FE4;ELYMAIC LETTER HE;Lo;0;R;;;;;N;;;;;
+10FE5;ELYMAIC LETTER WAW;Lo;0;R;;;;;N;;;;;
+10FE6;ELYMAIC LETTER ZAYIN;Lo;0;R;;;;;N;;;;;
+10FE7;ELYMAIC LETTER HETH;Lo;0;R;;;;;N;;;;;
+10FE8;ELYMAIC LETTER TETH;Lo;0;R;;;;;N;;;;;
+10FE9;ELYMAIC LETTER YODH;Lo;0;R;;;;;N;;;;;
+10FEA;ELYMAIC LETTER KAPH;Lo;0;R;;;;;N;;;;;
+10FEB;ELYMAIC LETTER LAMEDH;Lo;0;R;;;;;N;;;;;
+10FEC;ELYMAIC LETTER MEM;Lo;0;R;;;;;N;;;;;
+10FED;ELYMAIC LETTER NUN;Lo;0;R;;;;;N;;;;;
+10FEE;ELYMAIC LETTER SAMEKH;Lo;0;R;;;;;N;;;;;
+10FEF;ELYMAIC LETTER AYIN;Lo;0;R;;;;;N;;;;;
+10FF0;ELYMAIC LETTER PE;Lo;0;R;;;;;N;;;;;
+10FF1;ELYMAIC LETTER SADHE;Lo;0;R;;;;;N;;;;;
+10FF2;ELYMAIC LETTER QOPH;Lo;0;R;;;;;N;;;;;
+10FF3;ELYMAIC LETTER RESH;Lo;0;R;;;;;N;;;;;
+10FF4;ELYMAIC LETTER SHIN;Lo;0;R;;;;;N;;;;;
+10FF5;ELYMAIC LETTER TAW;Lo;0;R;;;;;N;;;;;
+10FF6;ELYMAIC LIGATURE ZAYIN-YODH;Lo;0;R;;;;;N;;;;;
11000;BRAHMI SIGN CANDRABINDU;Mc;0;L;;;;;N;;;;;
11001;BRAHMI SIGN ANUSVARA;Mn;0;NSM;;;;;N;;;;;
11002;BRAHMI SIGN VISARGA;Mc;0;L;;;;;N;;;;;
@@ -19887,6 +19943,7 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
1145B;NEWA PLACEHOLDER MARK;Po;0;L;;;;;N;;;;;
1145D;NEWA INSERTION SIGN;Po;0;L;;;;;N;;;;;
1145E;NEWA SANDHI MARK;Mn;230;NSM;;;;;N;;;;;
+1145F;NEWA LETTER VEDIC ANUSVARA;Lo;0;L;;;;;N;;;;;
11480;TIRHUTA ANJI;Lo;0;L;;;;;N;;;;;
11481;TIRHUTA LETTER A;Lo;0;L;;;;;N;;;;;
11482;TIRHUTA LETTER AA;Lo;0;L;;;;;N;;;;;
@@ -20209,6 +20266,7 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
116B5;TAKRI VOWEL SIGN AU;Mn;0;NSM;;;;;N;;;;;
116B6;TAKRI SIGN VIRAMA;Mc;9;L;;;;;N;;;;;
116B7;TAKRI SIGN NUKTA;Mn;7;NSM;;;;;N;;;;;
+116B8;TAKRI LETTER ARCHAIC KHA;Lo;0;L;;;;;N;;;;;
116C0;TAKRI DIGIT ZERO;Nd;0;L;;0;0;0;N;;;;;
116C1;TAKRI DIGIT ONE;Nd;0;L;;1;1;1;N;;;;;
116C2;TAKRI DIGIT TWO;Nd;0;L;;2;2;2;N;;;;;
@@ -20421,6 +20479,71 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
118F1;WARANG CITI NUMBER EIGHTY;No;0;L;;;;80;N;;;;;
118F2;WARANG CITI NUMBER NINETY;No;0;L;;;;90;N;;;;;
118FF;WARANG CITI OM;Lo;0;L;;;;;N;;;;;
+119A0;NANDINAGARI LETTER A;Lo;0;L;;;;;N;;;;;
+119A1;NANDINAGARI LETTER AA;Lo;0;L;;;;;N;;;;;
+119A2;NANDINAGARI LETTER I;Lo;0;L;;;;;N;;;;;
+119A3;NANDINAGARI LETTER II;Lo;0;L;;;;;N;;;;;
+119A4;NANDINAGARI LETTER U;Lo;0;L;;;;;N;;;;;
+119A5;NANDINAGARI LETTER UU;Lo;0;L;;;;;N;;;;;
+119A6;NANDINAGARI LETTER VOCALIC R;Lo;0;L;;;;;N;;;;;
+119A7;NANDINAGARI LETTER VOCALIC RR;Lo;0;L;;;;;N;;;;;
+119AA;NANDINAGARI LETTER E;Lo;0;L;;;;;N;;;;;
+119AB;NANDINAGARI LETTER AI;Lo;0;L;;;;;N;;;;;
+119AC;NANDINAGARI LETTER O;Lo;0;L;;;;;N;;;;;
+119AD;NANDINAGARI LETTER AU;Lo;0;L;;;;;N;;;;;
+119AE;NANDINAGARI LETTER KA;Lo;0;L;;;;;N;;;;;
+119AF;NANDINAGARI LETTER KHA;Lo;0;L;;;;;N;;;;;
+119B0;NANDINAGARI LETTER GA;Lo;0;L;;;;;N;;;;;
+119B1;NANDINAGARI LETTER GHA;Lo;0;L;;;;;N;;;;;
+119B2;NANDINAGARI LETTER NGA;Lo;0;L;;;;;N;;;;;
+119B3;NANDINAGARI LETTER CA;Lo;0;L;;;;;N;;;;;
+119B4;NANDINAGARI LETTER CHA;Lo;0;L;;;;;N;;;;;
+119B5;NANDINAGARI LETTER JA;Lo;0;L;;;;;N;;;;;
+119B6;NANDINAGARI LETTER JHA;Lo;0;L;;;;;N;;;;;
+119B7;NANDINAGARI LETTER NYA;Lo;0;L;;;;;N;;;;;
+119B8;NANDINAGARI LETTER TTA;Lo;0;L;;;;;N;;;;;
+119B9;NANDINAGARI LETTER TTHA;Lo;0;L;;;;;N;;;;;
+119BA;NANDINAGARI LETTER DDA;Lo;0;L;;;;;N;;;;;
+119BB;NANDINAGARI LETTER DDHA;Lo;0;L;;;;;N;;;;;
+119BC;NANDINAGARI LETTER NNA;Lo;0;L;;;;;N;;;;;
+119BD;NANDINAGARI LETTER TA;Lo;0;L;;;;;N;;;;;
+119BE;NANDINAGARI LETTER THA;Lo;0;L;;;;;N;;;;;
+119BF;NANDINAGARI LETTER DA;Lo;0;L;;;;;N;;;;;
+119C0;NANDINAGARI LETTER DHA;Lo;0;L;;;;;N;;;;;
+119C1;NANDINAGARI LETTER NA;Lo;0;L;;;;;N;;;;;
+119C2;NANDINAGARI LETTER PA;Lo;0;L;;;;;N;;;;;
+119C3;NANDINAGARI LETTER PHA;Lo;0;L;;;;;N;;;;;
+119C4;NANDINAGARI LETTER BA;Lo;0;L;;;;;N;;;;;
+119C5;NANDINAGARI LETTER BHA;Lo;0;L;;;;;N;;;;;
+119C6;NANDINAGARI LETTER MA;Lo;0;L;;;;;N;;;;;
+119C7;NANDINAGARI LETTER YA;Lo;0;L;;;;;N;;;;;
+119C8;NANDINAGARI LETTER RA;Lo;0;L;;;;;N;;;;;
+119C9;NANDINAGARI LETTER LA;Lo;0;L;;;;;N;;;;;
+119CA;NANDINAGARI LETTER VA;Lo;0;L;;;;;N;;;;;
+119CB;NANDINAGARI LETTER SHA;Lo;0;L;;;;;N;;;;;
+119CC;NANDINAGARI LETTER SSA;Lo;0;L;;;;;N;;;;;
+119CD;NANDINAGARI LETTER SA;Lo;0;L;;;;;N;;;;;
+119CE;NANDINAGARI LETTER HA;Lo;0;L;;;;;N;;;;;
+119CF;NANDINAGARI LETTER LLA;Lo;0;L;;;;;N;;;;;
+119D0;NANDINAGARI LETTER RRA;Lo;0;L;;;;;N;;;;;
+119D1;NANDINAGARI VOWEL SIGN AA;Mc;0;L;;;;;N;;;;;
+119D2;NANDINAGARI VOWEL SIGN I;Mc;0;L;;;;;N;;;;;
+119D3;NANDINAGARI VOWEL SIGN II;Mc;0;L;;;;;N;;;;;
+119D4;NANDINAGARI VOWEL SIGN U;Mn;0;NSM;;;;;N;;;;;
+119D5;NANDINAGARI VOWEL SIGN UU;Mn;0;NSM;;;;;N;;;;;
+119D6;NANDINAGARI VOWEL SIGN VOCALIC R;Mn;0;NSM;;;;;N;;;;;
+119D7;NANDINAGARI VOWEL SIGN VOCALIC RR;Mn;0;NSM;;;;;N;;;;;
+119DA;NANDINAGARI VOWEL SIGN E;Mn;0;NSM;;;;;N;;;;;
+119DB;NANDINAGARI VOWEL SIGN AI;Mn;0;NSM;;;;;N;;;;;
+119DC;NANDINAGARI VOWEL SIGN O;Mc;0;L;;;;;N;;;;;
+119DD;NANDINAGARI VOWEL SIGN AU;Mc;0;L;;;;;N;;;;;
+119DE;NANDINAGARI SIGN ANUSVARA;Mc;0;L;;;;;N;;;;;
+119DF;NANDINAGARI SIGN VISARGA;Mc;0;L;;;;;N;;;;;
+119E0;NANDINAGARI SIGN VIRAMA;Mn;9;NSM;;;;;N;;;;;
+119E1;NANDINAGARI SIGN AVAGRAHA;Lo;0;L;;;;;N;;;;;
+119E2;NANDINAGARI SIGN SIDDHAM;Po;0;L;;;;;N;;;;;
+119E3;NANDINAGARI HEADSTROKE;Lo;0;L;;;;;N;;;;;
+119E4;NANDINAGARI VOWEL SIGN PRISHTHAMATRA E;Mc;0;L;;;;;N;;;;;
11A00;ZANABAZAR SQUARE LETTER A;Lo;0;L;;;;;N;;;;;
11A01;ZANABAZAR SQUARE VOWEL SIGN I;Mn;0;NSM;;;;;N;;;;;
11A02;ZANABAZAR SQUARE VOWEL SIGN UE;Mn;0;NSM;;;;;N;;;;;
@@ -20545,6 +20668,8 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
11A81;SOYOMBO LETTER SA;Lo;0;L;;;;;N;;;;;
11A82;SOYOMBO LETTER HA;Lo;0;L;;;;;N;;;;;
11A83;SOYOMBO LETTER KSSA;Lo;0;L;;;;;N;;;;;
+11A84;SOYOMBO SIGN JIHVAMULIYA;Lo;0;L;;;;;N;;;;;
+11A85;SOYOMBO SIGN UPADHMANIYA;Lo;0;L;;;;;N;;;;;
11A86;SOYOMBO CLUSTER-INITIAL LETTER RA;Lo;0;L;;;;;N;;;;;
11A87;SOYOMBO CLUSTER-INITIAL LETTER LA;Lo;0;L;;;;;N;;;;;
11A88;SOYOMBO CLUSTER-INITIAL LETTER SHA;Lo;0;L;;;;;N;;;;;
@@ -20959,6 +21084,57 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
11EF6;MAKASAR VOWEL SIGN O;Mc;0;L;;;;;N;;;;;
11EF7;MAKASAR PASSIMBANG;Po;0;L;;;;;N;;;;;
11EF8;MAKASAR END OF SECTION;Po;0;L;;;;;N;;;;;
+11FC0;TAMIL FRACTION ONE THREE-HUNDRED-AND-TWENTIETH;No;0;L;;;;1/320;N;;;;;
+11FC1;TAMIL FRACTION ONE ONE-HUNDRED-AND-SIXTIETH;No;0;L;;;;1/160;N;;;;;
+11FC2;TAMIL FRACTION ONE EIGHTIETH;No;0;L;;;;1/80;N;;;;;
+11FC3;TAMIL FRACTION ONE SIXTY-FOURTH;No;0;L;;;;1/64;N;;;;;
+11FC4;TAMIL FRACTION ONE FORTIETH;No;0;L;;;;1/40;N;;;;;
+11FC5;TAMIL FRACTION ONE THIRTY-SECOND;No;0;L;;;;1/32;N;;;;;
+11FC6;TAMIL FRACTION THREE EIGHTIETHS;No;0;L;;;;3/80;N;;;;;
+11FC7;TAMIL FRACTION THREE SIXTY-FOURTHS;No;0;L;;;;3/64;N;;;;;
+11FC8;TAMIL FRACTION ONE TWENTIETH;No;0;L;;;;1/20;N;;;;;
+11FC9;TAMIL FRACTION ONE SIXTEENTH-1;No;0;L;;;;1/16;N;;;;;
+11FCA;TAMIL FRACTION ONE SIXTEENTH-2;No;0;L;;;;1/16;N;;;;;
+11FCB;TAMIL FRACTION ONE TENTH;No;0;L;;;;1/10;N;;;;;
+11FCC;TAMIL FRACTION ONE EIGHTH;No;0;L;;;;1/8;N;;;;;
+11FCD;TAMIL FRACTION THREE TWENTIETHS;No;0;L;;;;3/20;N;;;;;
+11FCE;TAMIL FRACTION THREE SIXTEENTHS;No;0;L;;;;3/16;N;;;;;
+11FCF;TAMIL FRACTION ONE FIFTH;No;0;L;;;;1/5;N;;;;;
+11FD0;TAMIL FRACTION ONE QUARTER;No;0;L;;;;1/4;N;;;;;
+11FD1;TAMIL FRACTION ONE HALF-1;No;0;L;;;;1/2;N;;;;;
+11FD2;TAMIL FRACTION ONE HALF-2;No;0;L;;;;1/2;N;;;;;
+11FD3;TAMIL FRACTION THREE QUARTERS;No;0;L;;;;3/4;N;;;;;
+11FD4;TAMIL FRACTION DOWNSCALING FACTOR KIIZH;No;0;L;;;;1/320;N;;;;;
+11FD5;TAMIL SIGN NEL;So;0;ON;;;;;N;;;;;
+11FD6;TAMIL SIGN CEVITU;So;0;ON;;;;;N;;;;;
+11FD7;TAMIL SIGN AAZHAAKKU;So;0;ON;;;;;N;;;;;
+11FD8;TAMIL SIGN UZHAKKU;So;0;ON;;;;;N;;;;;
+11FD9;TAMIL SIGN MUUVUZHAKKU;So;0;ON;;;;;N;;;;;
+11FDA;TAMIL SIGN KURUNI;So;0;ON;;;;;N;;;;;
+11FDB;TAMIL SIGN PATHAKKU;So;0;ON;;;;;N;;;;;
+11FDC;TAMIL SIGN MUKKURUNI;So;0;ON;;;;;N;;;;;
+11FDD;TAMIL SIGN KAACU;Sc;0;ET;;;;;N;;;;;
+11FDE;TAMIL SIGN PANAM;Sc;0;ET;;;;;N;;;;;
+11FDF;TAMIL SIGN PON;Sc;0;ET;;;;;N;;;;;
+11FE0;TAMIL SIGN VARAAKAN;Sc;0;ET;;;;;N;;;;;
+11FE1;TAMIL SIGN PAARAM;So;0;ON;;;;;N;;;;;
+11FE2;TAMIL SIGN KUZHI;So;0;ON;;;;;N;;;;;
+11FE3;TAMIL SIGN VELI;So;0;ON;;;;;N;;;;;
+11FE4;TAMIL WET CULTIVATION SIGN;So;0;ON;;;;;N;;;;;
+11FE5;TAMIL DRY CULTIVATION SIGN;So;0;ON;;;;;N;;;;;
+11FE6;TAMIL LAND SIGN;So;0;ON;;;;;N;;;;;
+11FE7;TAMIL SALT PAN SIGN;So;0;ON;;;;;N;;;;;
+11FE8;TAMIL TRADITIONAL CREDIT SIGN;So;0;ON;;;;;N;;;;;
+11FE9;TAMIL TRADITIONAL NUMBER SIGN;So;0;ON;;;;;N;;;;;
+11FEA;TAMIL CURRENT SIGN;So;0;ON;;;;;N;;;;;
+11FEB;TAMIL AND ODD SIGN;So;0;ON;;;;;N;;;;;
+11FEC;TAMIL SPENT SIGN;So;0;ON;;;;;N;;;;;
+11FED;TAMIL TOTAL SIGN;So;0;ON;;;;;N;;;;;
+11FEE;TAMIL IN POSSESSION SIGN;So;0;ON;;;;;N;;;;;
+11FEF;TAMIL STARTING FROM SIGN;So;0;ON;;;;;N;;;;;
+11FF0;TAMIL SIGN MUTHALIYA;So;0;ON;;;;;N;;;;;
+11FF1;TAMIL SIGN VAKAIYARAA;So;0;ON;;;;;N;;;;;
+11FFF;TAMIL PUNCTUATION END OF TEXT;Po;0;L;;;;;N;;;;;
12000;CUNEIFORM SIGN A;Lo;0;L;;;;;N;;;;;
12001;CUNEIFORM SIGN A TIMES A;Lo;0;L;;;;;N;;;;;
12002;CUNEIFORM SIGN A TIMES BAD;Lo;0;L;;;;;N;;;;;
@@ -23264,6 +23440,15 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
1342C;EGYPTIAN HIEROGLYPH AA030;Lo;0;L;;;;;N;;;;;
1342D;EGYPTIAN HIEROGLYPH AA031;Lo;0;L;;;;;N;;;;;
1342E;EGYPTIAN HIEROGLYPH AA032;Lo;0;L;;;;;N;;;;;
+13430;EGYPTIAN HIEROGLYPH VERTICAL JOINER;Cf;0;L;;;;;N;;;;;
+13431;EGYPTIAN HIEROGLYPH HORIZONTAL JOINER;Cf;0;L;;;;;N;;;;;
+13432;EGYPTIAN HIEROGLYPH INSERT AT TOP START;Cf;0;L;;;;;N;;;;;
+13433;EGYPTIAN HIEROGLYPH INSERT AT BOTTOM START;Cf;0;L;;;;;N;;;;;
+13434;EGYPTIAN HIEROGLYPH INSERT AT TOP END;Cf;0;L;;;;;N;;;;;
+13435;EGYPTIAN HIEROGLYPH INSERT AT BOTTOM END;Cf;0;L;;;;;N;;;;;
+13436;EGYPTIAN HIEROGLYPH OVERLAY MIDDLE;Cf;0;L;;;;;N;;;;;
+13437;EGYPTIAN HIEROGLYPH BEGIN SEGMENT;Cf;0;L;;;;;N;;;;;
+13438;EGYPTIAN HIEROGLYPH END SEGMENT;Cf;0;L;;;;;N;;;;;
14400;ANATOLIAN HIEROGLYPH A001;Lo;0;L;;;;;N;;;;;
14401;ANATOLIAN HIEROGLYPH A002;Lo;0;L;;;;;N;;;;;
14402;ANATOLIAN HIEROGLYPH A003;Lo;0;L;;;;;N;;;;;
@@ -24782,6 +24967,13 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
16F42;MIAO LETTER WA;Lo;0;L;;;;;N;;;;;
16F43;MIAO LETTER AH;Lo;0;L;;;;;N;;;;;
16F44;MIAO LETTER HHA;Lo;0;L;;;;;N;;;;;
+16F45;MIAO LETTER BRI;Lo;0;L;;;;;N;;;;;
+16F46;MIAO LETTER SYI;Lo;0;L;;;;;N;;;;;
+16F47;MIAO LETTER DZYI;Lo;0;L;;;;;N;;;;;
+16F48;MIAO LETTER TE;Lo;0;L;;;;;N;;;;;
+16F49;MIAO LETTER TSE;Lo;0;L;;;;;N;;;;;
+16F4A;MIAO LETTER RTE;Lo;0;L;;;;;N;;;;;
+16F4F;MIAO SIGN CONSONANT MODIFIER BAR;Mn;0;NSM;;;;;N;;;;;
16F50;MIAO LETTER NASALIZATION;Lo;0;L;;;;;N;;;;;
16F51;MIAO SIGN ASPIRATION;Mc;0;L;;;;;N;;;;;
16F52;MIAO SIGN REFORMED VOICING;Mc;0;L;;;;;N;;;;;
@@ -24829,6 +25021,15 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
16F7C;MIAO VOWEL SIGN OU;Mc;0;L;;;;;N;;;;;
16F7D;MIAO VOWEL SIGN N;Mc;0;L;;;;;N;;;;;
16F7E;MIAO VOWEL SIGN NG;Mc;0;L;;;;;N;;;;;
+16F7F;MIAO VOWEL SIGN UOG;Mc;0;L;;;;;N;;;;;
+16F80;MIAO VOWEL SIGN YUI;Mc;0;L;;;;;N;;;;;
+16F81;MIAO VOWEL SIGN OG;Mc;0;L;;;;;N;;;;;
+16F82;MIAO VOWEL SIGN OER;Mc;0;L;;;;;N;;;;;
+16F83;MIAO VOWEL SIGN VW;Mc;0;L;;;;;N;;;;;
+16F84;MIAO VOWEL SIGN IG;Mc;0;L;;;;;N;;;;;
+16F85;MIAO VOWEL SIGN EA;Mc;0;L;;;;;N;;;;;
+16F86;MIAO VOWEL SIGN IONG;Mc;0;L;;;;;N;;;;;
+16F87;MIAO VOWEL SIGN UI;Mc;0;L;;;;;N;;;;;
16F8F;MIAO TONE RIGHT;Mn;0;NSM;;;;;N;;;;;
16F90;MIAO TONE TOP RIGHT;Mn;0;NSM;;;;;N;;;;;
16F91;MIAO TONE ABOVE;Mn;0;NSM;;;;;N;;;;;
@@ -24848,8 +25049,10 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
16F9F;MIAO LETTER REFORMED TONE-8;Lm;0;L;;;;;N;;;;;
16FE0;TANGUT ITERATION MARK;Lm;0;L;;;;;N;;;;;
16FE1;NUSHU ITERATION MARK;Lm;0;L;;;;;N;;;;;
+16FE2;OLD CHINESE HOOK MARK;Po;0;ON;;;;;N;;;;;
+16FE3;OLD CHINESE ITERATION MARK;Lm;0;L;;;;;N;;;;;
17000;<Tangut Ideograph, First>;Lo;0;L;;;;;N;;;;;
-187F1;<Tangut Ideograph, Last>;Lo;0;L;;;;;N;;;;;
+187F7;<Tangut Ideograph, Last>;Lo;0;L;;;;;N;;;;;
18800;TANGUT COMPONENT-001;Lo;0;L;;;;;N;;;;;
18801;TANGUT COMPONENT-002;Lo;0;L;;;;;N;;;;;
18802;TANGUT COMPONENT-003;Lo;0;L;;;;;N;;;;;
@@ -25892,6 +26095,13 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
1B11C;HENTAIGANA LETTER WO-7;Lo;0;L;;;;;N;;;;;
1B11D;HENTAIGANA LETTER N-MU-MO-1;Lo;0;L;;;;;N;;;;;
1B11E;HENTAIGANA LETTER N-MU-MO-2;Lo;0;L;;;;;N;;;;;
+1B150;HIRAGANA LETTER SMALL WI;Lo;0;L;;;;;N;;;;;
+1B151;HIRAGANA LETTER SMALL WE;Lo;0;L;;;;;N;;;;;
+1B152;HIRAGANA LETTER SMALL WO;Lo;0;L;;;;;N;;;;;
+1B164;KATAKANA LETTER SMALL WI;Lo;0;L;;;;;N;;;;;
+1B165;KATAKANA LETTER SMALL WE;Lo;0;L;;;;;N;;;;;
+1B166;KATAKANA LETTER SMALL WO;Lo;0;L;;;;;N;;;;;
+1B167;KATAKANA LETTER SMALL N;Lo;0;L;;;;;N;;;;;
1B170;NUSHU CHARACTER-1B170;Lo;0;L;;;;;N;;;;;
1B171;NUSHU CHARACTER-1B171;Lo;0;L;;;;;N;;;;;
1B172;NUSHU CHARACTER-1B172;Lo;0;L;;;;;N;;;;;
@@ -28820,6 +29030,136 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
1E028;COMBINING GLAGOLITIC LETTER BIG YUS;Mn;230;NSM;;;;;N;;;;;
1E029;COMBINING GLAGOLITIC LETTER IOTATED BIG YUS;Mn;230;NSM;;;;;N;;;;;
1E02A;COMBINING GLAGOLITIC LETTER FITA;Mn;230;NSM;;;;;N;;;;;
+1E100;NYIAKENG PUACHUE HMONG LETTER MA;Lo;0;L;;;;;N;;;;;
+1E101;NYIAKENG PUACHUE HMONG LETTER TSA;Lo;0;L;;;;;N;;;;;
+1E102;NYIAKENG PUACHUE HMONG LETTER NTA;Lo;0;L;;;;;N;;;;;
+1E103;NYIAKENG PUACHUE HMONG LETTER TA;Lo;0;L;;;;;N;;;;;
+1E104;NYIAKENG PUACHUE HMONG LETTER HA;Lo;0;L;;;;;N;;;;;
+1E105;NYIAKENG PUACHUE HMONG LETTER NA;Lo;0;L;;;;;N;;;;;
+1E106;NYIAKENG PUACHUE HMONG LETTER XA;Lo;0;L;;;;;N;;;;;
+1E107;NYIAKENG PUACHUE HMONG LETTER NKA;Lo;0;L;;;;;N;;;;;
+1E108;NYIAKENG PUACHUE HMONG LETTER CA;Lo;0;L;;;;;N;;;;;
+1E109;NYIAKENG PUACHUE HMONG LETTER LA;Lo;0;L;;;;;N;;;;;
+1E10A;NYIAKENG PUACHUE HMONG LETTER SA;Lo;0;L;;;;;N;;;;;
+1E10B;NYIAKENG PUACHUE HMONG LETTER ZA;Lo;0;L;;;;;N;;;;;
+1E10C;NYIAKENG PUACHUE HMONG LETTER NCA;Lo;0;L;;;;;N;;;;;
+1E10D;NYIAKENG PUACHUE HMONG LETTER NTSA;Lo;0;L;;;;;N;;;;;
+1E10E;NYIAKENG PUACHUE HMONG LETTER KA;Lo;0;L;;;;;N;;;;;
+1E10F;NYIAKENG PUACHUE HMONG LETTER DA;Lo;0;L;;;;;N;;;;;
+1E110;NYIAKENG PUACHUE HMONG LETTER NYA;Lo;0;L;;;;;N;;;;;
+1E111;NYIAKENG PUACHUE HMONG LETTER NRA;Lo;0;L;;;;;N;;;;;
+1E112;NYIAKENG PUACHUE HMONG LETTER VA;Lo;0;L;;;;;N;;;;;
+1E113;NYIAKENG PUACHUE HMONG LETTER NTXA;Lo;0;L;;;;;N;;;;;
+1E114;NYIAKENG PUACHUE HMONG LETTER TXA;Lo;0;L;;;;;N;;;;;
+1E115;NYIAKENG PUACHUE HMONG LETTER FA;Lo;0;L;;;;;N;;;;;
+1E116;NYIAKENG PUACHUE HMONG LETTER RA;Lo;0;L;;;;;N;;;;;
+1E117;NYIAKENG PUACHUE HMONG LETTER QA;Lo;0;L;;;;;N;;;;;
+1E118;NYIAKENG PUACHUE HMONG LETTER YA;Lo;0;L;;;;;N;;;;;
+1E119;NYIAKENG PUACHUE HMONG LETTER NQA;Lo;0;L;;;;;N;;;;;
+1E11A;NYIAKENG PUACHUE HMONG LETTER PA;Lo;0;L;;;;;N;;;;;
+1E11B;NYIAKENG PUACHUE HMONG LETTER XYA;Lo;0;L;;;;;N;;;;;
+1E11C;NYIAKENG PUACHUE HMONG LETTER NPA;Lo;0;L;;;;;N;;;;;
+1E11D;NYIAKENG PUACHUE HMONG LETTER DLA;Lo;0;L;;;;;N;;;;;
+1E11E;NYIAKENG PUACHUE HMONG LETTER NPLA;Lo;0;L;;;;;N;;;;;
+1E11F;NYIAKENG PUACHUE HMONG LETTER HAH;Lo;0;L;;;;;N;;;;;
+1E120;NYIAKENG PUACHUE HMONG LETTER MLA;Lo;0;L;;;;;N;;;;;
+1E121;NYIAKENG PUACHUE HMONG LETTER PLA;Lo;0;L;;;;;N;;;;;
+1E122;NYIAKENG PUACHUE HMONG LETTER GA;Lo;0;L;;;;;N;;;;;
+1E123;NYIAKENG PUACHUE HMONG LETTER RRA;Lo;0;L;;;;;N;;;;;
+1E124;NYIAKENG PUACHUE HMONG LETTER A;Lo;0;L;;;;;N;;;;;
+1E125;NYIAKENG PUACHUE HMONG LETTER AA;Lo;0;L;;;;;N;;;;;
+1E126;NYIAKENG PUACHUE HMONG LETTER I;Lo;0;L;;;;;N;;;;;
+1E127;NYIAKENG PUACHUE HMONG LETTER U;Lo;0;L;;;;;N;;;;;
+1E128;NYIAKENG PUACHUE HMONG LETTER O;Lo;0;L;;;;;N;;;;;
+1E129;NYIAKENG PUACHUE HMONG LETTER OO;Lo;0;L;;;;;N;;;;;
+1E12A;NYIAKENG PUACHUE HMONG LETTER E;Lo;0;L;;;;;N;;;;;
+1E12B;NYIAKENG PUACHUE HMONG LETTER EE;Lo;0;L;;;;;N;;;;;
+1E12C;NYIAKENG PUACHUE HMONG LETTER W;Lo;0;L;;;;;N;;;;;
+1E130;NYIAKENG PUACHUE HMONG TONE-B;Mn;230;NSM;;;;;N;;;;;
+1E131;NYIAKENG PUACHUE HMONG TONE-M;Mn;230;NSM;;;;;N;;;;;
+1E132;NYIAKENG PUACHUE HMONG TONE-J;Mn;230;NSM;;;;;N;;;;;
+1E133;NYIAKENG PUACHUE HMONG TONE-V;Mn;230;NSM;;;;;N;;;;;
+1E134;NYIAKENG PUACHUE HMONG TONE-S;Mn;230;NSM;;;;;N;;;;;
+1E135;NYIAKENG PUACHUE HMONG TONE-G;Mn;230;NSM;;;;;N;;;;;
+1E136;NYIAKENG PUACHUE HMONG TONE-D;Mn;230;NSM;;;;;N;;;;;
+1E137;NYIAKENG PUACHUE HMONG SIGN FOR PERSON;Lm;0;L;;;;;N;;;;;
+1E138;NYIAKENG PUACHUE HMONG SIGN FOR THING;Lm;0;L;;;;;N;;;;;
+1E139;NYIAKENG PUACHUE HMONG SIGN FOR LOCATION;Lm;0;L;;;;;N;;;;;
+1E13A;NYIAKENG PUACHUE HMONG SIGN FOR ANIMAL;Lm;0;L;;;;;N;;;;;
+1E13B;NYIAKENG PUACHUE HMONG SIGN FOR INVERTEBRATE;Lm;0;L;;;;;N;;;;;
+1E13C;NYIAKENG PUACHUE HMONG SIGN XW XW;Lm;0;L;;;;;N;;;;;
+1E13D;NYIAKENG PUACHUE HMONG SYLLABLE LENGTHENER;Lm;0;L;;;;;N;;;;;
+1E140;NYIAKENG PUACHUE HMONG DIGIT ZERO;Nd;0;L;;0;0;0;N;;;;;
+1E141;NYIAKENG PUACHUE HMONG DIGIT ONE;Nd;0;L;;1;1;1;N;;;;;
+1E142;NYIAKENG PUACHUE HMONG DIGIT TWO;Nd;0;L;;2;2;2;N;;;;;
+1E143;NYIAKENG PUACHUE HMONG DIGIT THREE;Nd;0;L;;3;3;3;N;;;;;
+1E144;NYIAKENG PUACHUE HMONG DIGIT FOUR;Nd;0;L;;4;4;4;N;;;;;
+1E145;NYIAKENG PUACHUE HMONG DIGIT FIVE;Nd;0;L;;5;5;5;N;;;;;
+1E146;NYIAKENG PUACHUE HMONG DIGIT SIX;Nd;0;L;;6;6;6;N;;;;;
+1E147;NYIAKENG PUACHUE HMONG DIGIT SEVEN;Nd;0;L;;7;7;7;N;;;;;
+1E148;NYIAKENG PUACHUE HMONG DIGIT EIGHT;Nd;0;L;;8;8;8;N;;;;;
+1E149;NYIAKENG PUACHUE HMONG DIGIT NINE;Nd;0;L;;9;9;9;N;;;;;
+1E14E;NYIAKENG PUACHUE HMONG LOGOGRAM NYAJ;Lo;0;L;;;;;N;;;;;
+1E14F;NYIAKENG PUACHUE HMONG CIRCLED CA;So;0;L;;;;;N;;;;;
+1E2C0;WANCHO LETTER AA;Lo;0;L;;;;;N;;;;;
+1E2C1;WANCHO LETTER A;Lo;0;L;;;;;N;;;;;
+1E2C2;WANCHO LETTER BA;Lo;0;L;;;;;N;;;;;
+1E2C3;WANCHO LETTER CA;Lo;0;L;;;;;N;;;;;
+1E2C4;WANCHO LETTER DA;Lo;0;L;;;;;N;;;;;
+1E2C5;WANCHO LETTER GA;Lo;0;L;;;;;N;;;;;
+1E2C6;WANCHO LETTER YA;Lo;0;L;;;;;N;;;;;
+1E2C7;WANCHO LETTER PHA;Lo;0;L;;;;;N;;;;;
+1E2C8;WANCHO LETTER LA;Lo;0;L;;;;;N;;;;;
+1E2C9;WANCHO LETTER NA;Lo;0;L;;;;;N;;;;;
+1E2CA;WANCHO LETTER PA;Lo;0;L;;;;;N;;;;;
+1E2CB;WANCHO LETTER TA;Lo;0;L;;;;;N;;;;;
+1E2CC;WANCHO LETTER THA;Lo;0;L;;;;;N;;;;;
+1E2CD;WANCHO LETTER FA;Lo;0;L;;;;;N;;;;;
+1E2CE;WANCHO LETTER SA;Lo;0;L;;;;;N;;;;;
+1E2CF;WANCHO LETTER SHA;Lo;0;L;;;;;N;;;;;
+1E2D0;WANCHO LETTER JA;Lo;0;L;;;;;N;;;;;
+1E2D1;WANCHO LETTER ZA;Lo;0;L;;;;;N;;;;;
+1E2D2;WANCHO LETTER WA;Lo;0;L;;;;;N;;;;;
+1E2D3;WANCHO LETTER VA;Lo;0;L;;;;;N;;;;;
+1E2D4;WANCHO LETTER KA;Lo;0;L;;;;;N;;;;;
+1E2D5;WANCHO LETTER O;Lo;0;L;;;;;N;;;;;
+1E2D6;WANCHO LETTER AU;Lo;0;L;;;;;N;;;;;
+1E2D7;WANCHO LETTER RA;Lo;0;L;;;;;N;;;;;
+1E2D8;WANCHO LETTER MA;Lo;0;L;;;;;N;;;;;
+1E2D9;WANCHO LETTER KHA;Lo;0;L;;;;;N;;;;;
+1E2DA;WANCHO LETTER HA;Lo;0;L;;;;;N;;;;;
+1E2DB;WANCHO LETTER E;Lo;0;L;;;;;N;;;;;
+1E2DC;WANCHO LETTER I;Lo;0;L;;;;;N;;;;;
+1E2DD;WANCHO LETTER NGA;Lo;0;L;;;;;N;;;;;
+1E2DE;WANCHO LETTER U;Lo;0;L;;;;;N;;;;;
+1E2DF;WANCHO LETTER LLHA;Lo;0;L;;;;;N;;;;;
+1E2E0;WANCHO LETTER TSA;Lo;0;L;;;;;N;;;;;
+1E2E1;WANCHO LETTER TRA;Lo;0;L;;;;;N;;;;;
+1E2E2;WANCHO LETTER ONG;Lo;0;L;;;;;N;;;;;
+1E2E3;WANCHO LETTER AANG;Lo;0;L;;;;;N;;;;;
+1E2E4;WANCHO LETTER ANG;Lo;0;L;;;;;N;;;;;
+1E2E5;WANCHO LETTER ING;Lo;0;L;;;;;N;;;;;
+1E2E6;WANCHO LETTER ON;Lo;0;L;;;;;N;;;;;
+1E2E7;WANCHO LETTER EN;Lo;0;L;;;;;N;;;;;
+1E2E8;WANCHO LETTER AAN;Lo;0;L;;;;;N;;;;;
+1E2E9;WANCHO LETTER NYA;Lo;0;L;;;;;N;;;;;
+1E2EA;WANCHO LETTER UEN;Lo;0;L;;;;;N;;;;;
+1E2EB;WANCHO LETTER YIH;Lo;0;L;;;;;N;;;;;
+1E2EC;WANCHO TONE TUP;Mn;230;NSM;;;;;N;;;;;
+1E2ED;WANCHO TONE TUPNI;Mn;230;NSM;;;;;N;;;;;
+1E2EE;WANCHO TONE KOI;Mn;230;NSM;;;;;N;;;;;
+1E2EF;WANCHO TONE KOINI;Mn;230;NSM;;;;;N;;;;;
+1E2F0;WANCHO DIGIT ZERO;Nd;0;L;;0;0;0;N;;;;;
+1E2F1;WANCHO DIGIT ONE;Nd;0;L;;1;1;1;N;;;;;
+1E2F2;WANCHO DIGIT TWO;Nd;0;L;;2;2;2;N;;;;;
+1E2F3;WANCHO DIGIT THREE;Nd;0;L;;3;3;3;N;;;;;
+1E2F4;WANCHO DIGIT FOUR;Nd;0;L;;4;4;4;N;;;;;
+1E2F5;WANCHO DIGIT FIVE;Nd;0;L;;5;5;5;N;;;;;
+1E2F6;WANCHO DIGIT SIX;Nd;0;L;;6;6;6;N;;;;;
+1E2F7;WANCHO DIGIT SEVEN;Nd;0;L;;7;7;7;N;;;;;
+1E2F8;WANCHO DIGIT EIGHT;Nd;0;L;;8;8;8;N;;;;;
+1E2F9;WANCHO DIGIT NINE;Nd;0;L;;9;9;9;N;;;;;
+1E2FF;WANCHO NGUN SIGN;Sc;0;ET;;;;;N;;;;;
1E800;MENDE KIKAKUI SYLLABLE M001 KI;Lo;0;R;;;;;N;;;;;
1E801;MENDE KIKAKUI SYLLABLE M002 KA;Lo;0;R;;;;;N;;;;;
1E802;MENDE KIKAKUI SYLLABLE M003 KU;Lo;0;R;;;;;N;;;;;
@@ -29108,6 +29448,7 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
1E948;ADLAM CONSONANT MODIFIER;Mn;230;NSM;;;;;N;;;;;
1E949;ADLAM GEMINATE CONSONANT MODIFIER;Mn;230;NSM;;;;;N;;;;;
1E94A;ADLAM NUKTA;Mn;7;NSM;;;;;N;;;;;
+1E94B;ADLAM NASALIZATION MARK;Lm;0;R;;;;;N;;;;;
1E950;ADLAM DIGIT ZERO;Nd;0;R;;0;0;0;N;;;;;
1E951;ADLAM DIGIT ONE;Nd;0;R;;1;1;1;N;;;;;
1E952;ADLAM DIGIT TWO;Nd;0;R;;2;2;2;N;;;;;
@@ -29188,6 +29529,67 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
1ECB2;INDIC SIYAQ NUMBER ALTERNATE TWO;No;0;AL;;;;2;N;;;;;
1ECB3;INDIC SIYAQ NUMBER ALTERNATE TEN THOUSAND;No;0;AL;;;;10000;N;;;;;
1ECB4;INDIC SIYAQ ALTERNATE LAKH MARK;No;0;AL;;;;100000;N;;;;;
+1ED01;OTTOMAN SIYAQ NUMBER ONE;No;0;AL;;;;1;N;;;;;
+1ED02;OTTOMAN SIYAQ NUMBER TWO;No;0;AL;;;;2;N;;;;;
+1ED03;OTTOMAN SIYAQ NUMBER THREE;No;0;AL;;;;3;N;;;;;
+1ED04;OTTOMAN SIYAQ NUMBER FOUR;No;0;AL;;;;4;N;;;;;
+1ED05;OTTOMAN SIYAQ NUMBER FIVE;No;0;AL;;;;5;N;;;;;
+1ED06;OTTOMAN SIYAQ NUMBER SIX;No;0;AL;;;;6;N;;;;;
+1ED07;OTTOMAN SIYAQ NUMBER SEVEN;No;0;AL;;;;7;N;;;;;
+1ED08;OTTOMAN SIYAQ NUMBER EIGHT;No;0;AL;;;;8;N;;;;;
+1ED09;OTTOMAN SIYAQ NUMBER NINE;No;0;AL;;;;9;N;;;;;
+1ED0A;OTTOMAN SIYAQ NUMBER TEN;No;0;AL;;;;10;N;;;;;
+1ED0B;OTTOMAN SIYAQ NUMBER TWENTY;No;0;AL;;;;20;N;;;;;
+1ED0C;OTTOMAN SIYAQ NUMBER THIRTY;No;0;AL;;;;30;N;;;;;
+1ED0D;OTTOMAN SIYAQ NUMBER FORTY;No;0;AL;;;;40;N;;;;;
+1ED0E;OTTOMAN SIYAQ NUMBER FIFTY;No;0;AL;;;;50;N;;;;;
+1ED0F;OTTOMAN SIYAQ NUMBER SIXTY;No;0;AL;;;;60;N;;;;;
+1ED10;OTTOMAN SIYAQ NUMBER SEVENTY;No;0;AL;;;;70;N;;;;;
+1ED11;OTTOMAN SIYAQ NUMBER EIGHTY;No;0;AL;;;;80;N;;;;;
+1ED12;OTTOMAN SIYAQ NUMBER NINETY;No;0;AL;;;;90;N;;;;;
+1ED13;OTTOMAN SIYAQ NUMBER ONE HUNDRED;No;0;AL;;;;100;N;;;;;
+1ED14;OTTOMAN SIYAQ NUMBER TWO HUNDRED;No;0;AL;;;;200;N;;;;;
+1ED15;OTTOMAN SIYAQ NUMBER THREE HUNDRED;No;0;AL;;;;300;N;;;;;
+1ED16;OTTOMAN SIYAQ NUMBER FOUR HUNDRED;No;0;AL;;;;400;N;;;;;
+1ED17;OTTOMAN SIYAQ NUMBER FIVE HUNDRED;No;0;AL;;;;500;N;;;;;
+1ED18;OTTOMAN SIYAQ NUMBER SIX HUNDRED;No;0;AL;;;;600;N;;;;;
+1ED19;OTTOMAN SIYAQ NUMBER SEVEN HUNDRED;No;0;AL;;;;700;N;;;;;
+1ED1A;OTTOMAN SIYAQ NUMBER EIGHT HUNDRED;No;0;AL;;;;800;N;;;;;
+1ED1B;OTTOMAN SIYAQ NUMBER NINE HUNDRED;No;0;AL;;;;900;N;;;;;
+1ED1C;OTTOMAN SIYAQ NUMBER ONE THOUSAND;No;0;AL;;;;1000;N;;;;;
+1ED1D;OTTOMAN SIYAQ NUMBER TWO THOUSAND;No;0;AL;;;;2000;N;;;;;
+1ED1E;OTTOMAN SIYAQ NUMBER THREE THOUSAND;No;0;AL;;;;3000;N;;;;;
+1ED1F;OTTOMAN SIYAQ NUMBER FOUR THOUSAND;No;0;AL;;;;4000;N;;;;;
+1ED20;OTTOMAN SIYAQ NUMBER FIVE THOUSAND;No;0;AL;;;;5000;N;;;;;
+1ED21;OTTOMAN SIYAQ NUMBER SIX THOUSAND;No;0;AL;;;;6000;N;;;;;
+1ED22;OTTOMAN SIYAQ NUMBER SEVEN THOUSAND;No;0;AL;;;;7000;N;;;;;
+1ED23;OTTOMAN SIYAQ NUMBER EIGHT THOUSAND;No;0;AL;;;;8000;N;;;;;
+1ED24;OTTOMAN SIYAQ NUMBER NINE THOUSAND;No;0;AL;;;;9000;N;;;;;
+1ED25;OTTOMAN SIYAQ NUMBER TEN THOUSAND;No;0;AL;;;;10000;N;;;;;
+1ED26;OTTOMAN SIYAQ NUMBER TWENTY THOUSAND;No;0;AL;;;;20000;N;;;;;
+1ED27;OTTOMAN SIYAQ NUMBER THIRTY THOUSAND;No;0;AL;;;;30000;N;;;;;
+1ED28;OTTOMAN SIYAQ NUMBER FORTY THOUSAND;No;0;AL;;;;40000;N;;;;;
+1ED29;OTTOMAN SIYAQ NUMBER FIFTY THOUSAND;No;0;AL;;;;50000;N;;;;;
+1ED2A;OTTOMAN SIYAQ NUMBER SIXTY THOUSAND;No;0;AL;;;;60000;N;;;;;
+1ED2B;OTTOMAN SIYAQ NUMBER SEVENTY THOUSAND;No;0;AL;;;;70000;N;;;;;
+1ED2C;OTTOMAN SIYAQ NUMBER EIGHTY THOUSAND;No;0;AL;;;;80000;N;;;;;
+1ED2D;OTTOMAN SIYAQ NUMBER NINETY THOUSAND;No;0;AL;;;;90000;N;;;;;
+1ED2E;OTTOMAN SIYAQ MARRATAN;So;0;AL;;;;;N;;;;;
+1ED2F;OTTOMAN SIYAQ ALTERNATE NUMBER TWO;No;0;AL;;;;2;N;;;;;
+1ED30;OTTOMAN SIYAQ ALTERNATE NUMBER THREE;No;0;AL;;;;3;N;;;;;
+1ED31;OTTOMAN SIYAQ ALTERNATE NUMBER FOUR;No;0;AL;;;;4;N;;;;;
+1ED32;OTTOMAN SIYAQ ALTERNATE NUMBER FIVE;No;0;AL;;;;5;N;;;;;
+1ED33;OTTOMAN SIYAQ ALTERNATE NUMBER SIX;No;0;AL;;;;6;N;;;;;
+1ED34;OTTOMAN SIYAQ ALTERNATE NUMBER SEVEN;No;0;AL;;;;7;N;;;;;
+1ED35;OTTOMAN SIYAQ ALTERNATE NUMBER EIGHT;No;0;AL;;;;8;N;;;;;
+1ED36;OTTOMAN SIYAQ ALTERNATE NUMBER NINE;No;0;AL;;;;9;N;;;;;
+1ED37;OTTOMAN SIYAQ ALTERNATE NUMBER TEN;No;0;AL;;;;10;N;;;;;
+1ED38;OTTOMAN SIYAQ ALTERNATE NUMBER FOUR HUNDRED;No;0;AL;;;;400;N;;;;;
+1ED39;OTTOMAN SIYAQ ALTERNATE NUMBER SIX HUNDRED;No;0;AL;;;;600;N;;;;;
+1ED3A;OTTOMAN SIYAQ ALTERNATE NUMBER TWO THOUSAND;No;0;AL;;;;2000;N;;;;;
+1ED3B;OTTOMAN SIYAQ ALTERNATE NUMBER TEN THOUSAND;No;0;AL;;;;10000;N;;;;;
+1ED3C;OTTOMAN SIYAQ FRACTION ONE HALF;No;0;AL;;;;1/2;N;;;;;
+1ED3D;OTTOMAN SIYAQ FRACTION ONE SIXTH;No;0;AL;;;;1/6;N;;;;;
1EE00;ARABIC MATHEMATICAL ALEF;Lo;0;AL;<font> 0627;;;;N;;;;;
1EE01;ARABIC MATHEMATICAL BEH;Lo;0;AL;<font> 0628;;;;N;;;;;
1EE02;ARABIC MATHEMATICAL JEEM;Lo;0;AL;<font> 062C;;;;N;;;;;
@@ -29662,6 +30064,7 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
1F169;NEGATIVE CIRCLED LATIN CAPITAL LETTER Z;So;0;L;;;;;N;;;;;
1F16A;RAISED MC SIGN;So;0;ON;<super> 004D 0043;;;;N;;;;;
1F16B;RAISED MD SIGN;So;0;ON;<super> 004D 0044;;;;N;;;;;
+1F16C;RAISED MR SIGN;So;0;ON;<super> 004D 0052;;;;N;;;;;
1F170;NEGATIVE SQUARED LATIN CAPITAL LETTER A;So;0;L;;;;;N;;;;;
1F171;NEGATIVE SQUARED LATIN CAPITAL LETTER B;So;0;L;;;;;N;;;;;
1F172;NEGATIVE SQUARED LATIN CAPITAL LETTER C;So;0;L;;;;;N;;;;;
@@ -30794,6 +31197,7 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
1F6D2;SHOPPING TROLLEY;So;0;ON;;;;;N;;;;;
1F6D3;STUPA;So;0;ON;;;;;N;;;;;
1F6D4;PAGODA;So;0;ON;;;;;N;;;;;
+1F6D5;HINDU TEMPLE;So;0;ON;;;;;N;;;;;
1F6E0;HAMMER AND WRENCH;So;0;ON;;;;;N;;;;;
1F6E1;SHIELD;So;0;ON;;;;;N;;;;;
1F6E2;OIL DRUM;So;0;ON;;;;;N;;;;;
@@ -30817,6 +31221,7 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
1F6F7;SLED;So;0;ON;;;;;N;;;;;
1F6F8;FLYING SAUCER;So;0;ON;;;;;N;;;;;
1F6F9;SKATEBOARD;So;0;ON;;;;;N;;;;;
+1F6FA;AUTO RICKSHAW;So;0;ON;;;;;N;;;;;
1F700;ALCHEMICAL SYMBOL FOR QUINTESSENCE;So;0;ON;;;;;N;;;;;
1F701;ALCHEMICAL SYMBOL FOR AIR;So;0;ON;;;;;N;;;;;
1F702;ALCHEMICAL SYMBOL FOR FIRE;So;0;ON;;;;;N;;;;;
@@ -31022,6 +31427,18 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
1F7D6;NEGATIVE CIRCLED TRIANGLE;So;0;ON;;;;;N;;;;;
1F7D7;CIRCLED SQUARE;So;0;ON;;;;;N;;;;;
1F7D8;NEGATIVE CIRCLED SQUARE;So;0;ON;;;;;N;;;;;
+1F7E0;LARGE ORANGE CIRCLE;So;0;ON;;;;;N;;;;;
+1F7E1;LARGE YELLOW CIRCLE;So;0;ON;;;;;N;;;;;
+1F7E2;LARGE GREEN CIRCLE;So;0;ON;;;;;N;;;;;
+1F7E3;LARGE PURPLE CIRCLE;So;0;ON;;;;;N;;;;;
+1F7E4;LARGE BROWN CIRCLE;So;0;ON;;;;;N;;;;;
+1F7E5;LARGE RED SQUARE;So;0;ON;;;;;N;;;;;
+1F7E6;LARGE BLUE SQUARE;So;0;ON;;;;;N;;;;;
+1F7E7;LARGE ORANGE SQUARE;So;0;ON;;;;;N;;;;;
+1F7E8;LARGE YELLOW SQUARE;So;0;ON;;;;;N;;;;;
+1F7E9;LARGE GREEN SQUARE;So;0;ON;;;;;N;;;;;
+1F7EA;LARGE PURPLE SQUARE;So;0;ON;;;;;N;;;;;
+1F7EB;LARGE BROWN SQUARE;So;0;ON;;;;;N;;;;;
1F800;LEFTWARDS ARROW WITH SMALL TRIANGLE ARROWHEAD;So;0;ON;;;;;N;;;;;
1F801;UPWARDS ARROW WITH SMALL TRIANGLE ARROWHEAD;So;0;ON;;;;;N;;;;;
1F802;RIGHTWARDS ARROW WITH SMALL TRIANGLE ARROWHEAD;So;0;ON;;;;;N;;;;;
@@ -31182,6 +31599,9 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
1F909;DOWNWARD FACING NOTCHED HOOK;So;0;ON;;;;;N;;;;;
1F90A;DOWNWARD FACING HOOK WITH DOT;So;0;ON;;;;;N;;;;;
1F90B;DOWNWARD FACING NOTCHED HOOK WITH DOT;So;0;ON;;;;;N;;;;;
+1F90D;WHITE HEART;So;0;ON;;;;;N;;;;;
+1F90E;BROWN HEART;So;0;ON;;;;;N;;;;;
+1F90F;PINCHING HAND;So;0;ON;;;;;N;;;;;
1F910;ZIPPER-MOUTH FACE;So;0;ON;;;;;N;;;;;
1F911;MONEY-MOUTH FACE;So;0;ON;;;;;N;;;;;
1F912;FACE WITH THERMOMETER;So;0;ON;;;;;N;;;;;
@@ -31229,6 +31649,7 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
1F93C;WRESTLERS;So;0;ON;;;;;N;;;;;
1F93D;WATER POLO;So;0;ON;;;;;N;;;;;
1F93E;HANDBALL;So;0;ON;;;;;N;;;;;
+1F93F;DIVING MASK;So;0;ON;;;;;N;;;;;
1F940;WILTED FLOWER;So;0;ON;;;;;N;;;;;
1F941;DRUM WITH DRUMSTICKS;So;0;ON;;;;;N;;;;;
1F942;CLINKING GLASSES;So;0;ON;;;;;N;;;;;
@@ -31278,11 +31699,13 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
1F96E;MOON CAKE;So;0;ON;;;;;N;;;;;
1F96F;BAGEL;So;0;ON;;;;;N;;;;;
1F970;SMILING FACE WITH SMILING EYES AND THREE HEARTS;So;0;ON;;;;;N;;;;;
+1F971;YAWNING FACE;So;0;ON;;;;;N;;;;;
1F973;FACE WITH PARTY HORN AND PARTY HAT;So;0;ON;;;;;N;;;;;
1F974;FACE WITH UNEVEN EYES AND WAVY MOUTH;So;0;ON;;;;;N;;;;;
1F975;OVERHEATED FACE;So;0;ON;;;;;N;;;;;
1F976;FREEZING FACE;So;0;ON;;;;;N;;;;;
1F97A;FACE WITH PLEADING EYES;So;0;ON;;;;;N;;;;;
+1F97B;SARI;So;0;ON;;;;;N;;;;;
1F97C;LAB COAT;So;0;ON;;;;;N;;;;;
1F97D;GOGGLES;So;0;ON;;;;;N;;;;;
1F97E;HIKING BOOT;So;0;ON;;;;;N;;;;;
@@ -31322,6 +31745,14 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
1F9A0;MICROBE;So;0;ON;;;;;N;;;;;
1F9A1;BADGER;So;0;ON;;;;;N;;;;;
1F9A2;SWAN;So;0;ON;;;;;N;;;;;
+1F9A5;SLOTH;So;0;ON;;;;;N;;;;;
+1F9A6;OTTER;So;0;ON;;;;;N;;;;;
+1F9A7;ORANGUTAN;So;0;ON;;;;;N;;;;;
+1F9A8;SKUNK;So;0;ON;;;;;N;;;;;
+1F9A9;FLAMINGO;So;0;ON;;;;;N;;;;;
+1F9AA;OYSTER;So;0;ON;;;;;N;;;;;
+1F9AE;GUIDE DOG;So;0;ON;;;;;N;;;;;
+1F9AF;PROBING CANE;So;0;ON;;;;;N;;;;;
1F9B0;EMOJI COMPONENT RED HAIR;So;0;ON;;;;;N;;;;;
1F9B1;EMOJI COMPONENT CURLY HAIR;So;0;ON;;;;;N;;;;;
1F9B2;EMOJI COMPONENT BALD;So;0;ON;;;;;N;;;;;
@@ -31332,9 +31763,26 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
1F9B7;TOOTH;So;0;ON;;;;;N;;;;;
1F9B8;SUPERHERO;So;0;ON;;;;;N;;;;;
1F9B9;SUPERVILLAIN;So;0;ON;;;;;N;;;;;
+1F9BA;SAFETY VEST;So;0;ON;;;;;N;;;;;
+1F9BB;EAR WITH HEARING AID;So;0;ON;;;;;N;;;;;
+1F9BC;MOTORIZED WHEELCHAIR;So;0;ON;;;;;N;;;;;
+1F9BD;MANUAL WHEELCHAIR;So;0;ON;;;;;N;;;;;
+1F9BE;MECHANICAL ARM;So;0;ON;;;;;N;;;;;
+1F9BF;MECHANICAL LEG;So;0;ON;;;;;N;;;;;
1F9C0;CHEESE WEDGE;So;0;ON;;;;;N;;;;;
1F9C1;CUPCAKE;So;0;ON;;;;;N;;;;;
1F9C2;SALT SHAKER;So;0;ON;;;;;N;;;;;
+1F9C3;BEVERAGE BOX;So;0;ON;;;;;N;;;;;
+1F9C4;GARLIC;So;0;ON;;;;;N;;;;;
+1F9C5;ONION;So;0;ON;;;;;N;;;;;
+1F9C6;FALAFEL;So;0;ON;;;;;N;;;;;
+1F9C7;WAFFLE;So;0;ON;;;;;N;;;;;
+1F9C8;BUTTER;So;0;ON;;;;;N;;;;;
+1F9C9;MATE DRINK;So;0;ON;;;;;N;;;;;
+1F9CA;ICE CUBE;So;0;ON;;;;;N;;;;;
+1F9CD;STANDING PERSON;So;0;ON;;;;;N;;;;;
+1F9CE;KNEELING PERSON;So;0;ON;;;;;N;;;;;
+1F9CF;DEAF PERSON;So;0;ON;;;;;N;;;;;
1F9D0;FACE WITH MONOCLE;So;0;ON;;;;;N;;;;;
1F9D1;ADULT;So;0;ON;;;;;N;;;;;
1F9D2;CHILD;So;0;ON;;;;;N;;;;;
@@ -31383,6 +31831,90 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
1F9FD;SPONGE;So;0;ON;;;;;N;;;;;
1F9FE;RECEIPT;So;0;ON;;;;;N;;;;;
1F9FF;NAZAR AMULET;So;0;ON;;;;;N;;;;;
+1FA00;NEUTRAL CHESS KING;So;0;ON;;;;;N;;;;;
+1FA01;NEUTRAL CHESS QUEEN;So;0;ON;;;;;N;;;;;
+1FA02;NEUTRAL CHESS ROOK;So;0;ON;;;;;N;;;;;
+1FA03;NEUTRAL CHESS BISHOP;So;0;ON;;;;;N;;;;;
+1FA04;NEUTRAL CHESS KNIGHT;So;0;ON;;;;;N;;;;;
+1FA05;NEUTRAL CHESS PAWN;So;0;ON;;;;;N;;;;;
+1FA06;WHITE CHESS KNIGHT ROTATED FORTY-FIVE DEGREES;So;0;ON;;;;;N;;;;;
+1FA07;BLACK CHESS KNIGHT ROTATED FORTY-FIVE DEGREES;So;0;ON;;;;;N;;;;;
+1FA08;NEUTRAL CHESS KNIGHT ROTATED FORTY-FIVE DEGREES;So;0;ON;;;;;N;;;;;
+1FA09;WHITE CHESS KING ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA0A;WHITE CHESS QUEEN ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA0B;WHITE CHESS ROOK ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA0C;WHITE CHESS BISHOP ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA0D;WHITE CHESS KNIGHT ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA0E;WHITE CHESS PAWN ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA0F;BLACK CHESS KING ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA10;BLACK CHESS QUEEN ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA11;BLACK CHESS ROOK ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA12;BLACK CHESS BISHOP ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA13;BLACK CHESS KNIGHT ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA14;BLACK CHESS PAWN ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA15;NEUTRAL CHESS KING ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA16;NEUTRAL CHESS QUEEN ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA17;NEUTRAL CHESS ROOK ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA18;NEUTRAL CHESS BISHOP ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA19;NEUTRAL CHESS KNIGHT ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA1A;NEUTRAL CHESS PAWN ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA1B;WHITE CHESS KNIGHT ROTATED ONE HUNDRED THIRTY-FIVE DEGREES;So;0;ON;;;;;N;;;;;
+1FA1C;BLACK CHESS KNIGHT ROTATED ONE HUNDRED THIRTY-FIVE DEGREES;So;0;ON;;;;;N;;;;;
+1FA1D;NEUTRAL CHESS KNIGHT ROTATED ONE HUNDRED THIRTY-FIVE DEGREES;So;0;ON;;;;;N;;;;;
+1FA1E;WHITE CHESS TURNED KING;So;0;ON;;;;;N;;;;;
+1FA1F;WHITE CHESS TURNED QUEEN;So;0;ON;;;;;N;;;;;
+1FA20;WHITE CHESS TURNED ROOK;So;0;ON;;;;;N;;;;;
+1FA21;WHITE CHESS TURNED BISHOP;So;0;ON;;;;;N;;;;;
+1FA22;WHITE CHESS TURNED KNIGHT;So;0;ON;;;;;N;;;;;
+1FA23;WHITE CHESS TURNED PAWN;So;0;ON;;;;;N;;;;;
+1FA24;BLACK CHESS TURNED KING;So;0;ON;;;;;N;;;;;
+1FA25;BLACK CHESS TURNED QUEEN;So;0;ON;;;;;N;;;;;
+1FA26;BLACK CHESS TURNED ROOK;So;0;ON;;;;;N;;;;;
+1FA27;BLACK CHESS TURNED BISHOP;So;0;ON;;;;;N;;;;;
+1FA28;BLACK CHESS TURNED KNIGHT;So;0;ON;;;;;N;;;;;
+1FA29;BLACK CHESS TURNED PAWN;So;0;ON;;;;;N;;;;;
+1FA2A;NEUTRAL CHESS TURNED KING;So;0;ON;;;;;N;;;;;
+1FA2B;NEUTRAL CHESS TURNED QUEEN;So;0;ON;;;;;N;;;;;
+1FA2C;NEUTRAL CHESS TURNED ROOK;So;0;ON;;;;;N;;;;;
+1FA2D;NEUTRAL CHESS TURNED BISHOP;So;0;ON;;;;;N;;;;;
+1FA2E;NEUTRAL CHESS TURNED KNIGHT;So;0;ON;;;;;N;;;;;
+1FA2F;NEUTRAL CHESS TURNED PAWN;So;0;ON;;;;;N;;;;;
+1FA30;WHITE CHESS KNIGHT ROTATED TWO HUNDRED TWENTY-FIVE DEGREES;So;0;ON;;;;;N;;;;;
+1FA31;BLACK CHESS KNIGHT ROTATED TWO HUNDRED TWENTY-FIVE DEGREES;So;0;ON;;;;;N;;;;;
+1FA32;NEUTRAL CHESS KNIGHT ROTATED TWO HUNDRED TWENTY-FIVE DEGREES;So;0;ON;;;;;N;;;;;
+1FA33;WHITE CHESS KING ROTATED TWO HUNDRED SEVENTY DEGREES;So;0;ON;;;;;N;;;;;
+1FA34;WHITE CHESS QUEEN ROTATED TWO HUNDRED SEVENTY DEGREES;So;0;ON;;;;;N;;;;;
+1FA35;WHITE CHESS ROOK ROTATED TWO HUNDRED SEVENTY DEGREES;So;0;ON;;;;;N;;;;;
+1FA36;WHITE CHESS BISHOP ROTATED TWO HUNDRED SEVENTY DEGREES;So;0;ON;;;;;N;;;;;
+1FA37;WHITE CHESS KNIGHT ROTATED TWO HUNDRED SEVENTY DEGREES;So;0;ON;;;;;N;;;;;
+1FA38;WHITE CHESS PAWN ROTATED TWO HUNDRED SEVENTY DEGREES;So;0;ON;;;;;N;;;;;
+1FA39;BLACK CHESS KING ROTATED TWO HUNDRED SEVENTY DEGREES;So;0;ON;;;;;N;;;;;
+1FA3A;BLACK CHESS QUEEN ROTATED TWO HUNDRED SEVENTY DEGREES;So;0;ON;;;;;N;;;;;
+1FA3B;BLACK CHESS ROOK ROTATED TWO HUNDRED SEVENTY DEGREES;So;0;ON;;;;;N;;;;;
+1FA3C;BLACK CHESS BISHOP ROTATED TWO HUNDRED SEVENTY DEGREES;So;0;ON;;;;;N;;;;;
+1FA3D;BLACK CHESS KNIGHT ROTATED TWO HUNDRED SEVENTY DEGREES;So;0;ON;;;;;N;;;;;
+1FA3E;BLACK CHESS PAWN ROTATED TWO HUNDRED SEVENTY DEGREES;So;0;ON;;;;;N;;;;;
+1FA3F;NEUTRAL CHESS KING ROTATED TWO HUNDRED SEVENTY DEGREES;So;0;ON;;;;;N;;;;;
+1FA40;NEUTRAL CHESS QUEEN ROTATED TWO HUNDRED SEVENTY DEGREES;So;0;ON;;;;;N;;;;;
+1FA41;NEUTRAL CHESS ROOK ROTATED TWO HUNDRED SEVENTY DEGREES;So;0;ON;;;;;N;;;;;
+1FA42;NEUTRAL CHESS BISHOP ROTATED TWO HUNDRED SEVENTY DEGREES;So;0;ON;;;;;N;;;;;
+1FA43;NEUTRAL CHESS KNIGHT ROTATED TWO HUNDRED SEVENTY DEGREES;So;0;ON;;;;;N;;;;;
+1FA44;NEUTRAL CHESS PAWN ROTATED TWO HUNDRED SEVENTY DEGREES;So;0;ON;;;;;N;;;;;
+1FA45;WHITE CHESS KNIGHT ROTATED THREE HUNDRED FIFTEEN DEGREES;So;0;ON;;;;;N;;;;;
+1FA46;BLACK CHESS KNIGHT ROTATED THREE HUNDRED FIFTEEN DEGREES;So;0;ON;;;;;N;;;;;
+1FA47;NEUTRAL CHESS KNIGHT ROTATED THREE HUNDRED FIFTEEN DEGREES;So;0;ON;;;;;N;;;;;
+1FA48;WHITE CHESS EQUIHOPPER;So;0;ON;;;;;N;;;;;
+1FA49;BLACK CHESS EQUIHOPPER;So;0;ON;;;;;N;;;;;
+1FA4A;NEUTRAL CHESS EQUIHOPPER;So;0;ON;;;;;N;;;;;
+1FA4B;WHITE CHESS EQUIHOPPER ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA4C;BLACK CHESS EQUIHOPPER ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA4D;NEUTRAL CHESS EQUIHOPPER ROTATED NINETY DEGREES;So;0;ON;;;;;N;;;;;
+1FA4E;WHITE CHESS KNIGHT-QUEEN;So;0;ON;;;;;N;;;;;
+1FA4F;WHITE CHESS KNIGHT-ROOK;So;0;ON;;;;;N;;;;;
+1FA50;WHITE CHESS KNIGHT-BISHOP;So;0;ON;;;;;N;;;;;
+1FA51;BLACK CHESS KNIGHT-QUEEN;So;0;ON;;;;;N;;;;;
+1FA52;BLACK CHESS KNIGHT-ROOK;So;0;ON;;;;;N;;;;;
+1FA53;BLACK CHESS KNIGHT-BISHOP;So;0;ON;;;;;N;;;;;
1FA60;XIANGQI RED GENERAL;So;0;ON;;;;;N;;;;;
1FA61;XIANGQI RED MANDARIN;So;0;ON;;;;;N;;;;;
1FA62;XIANGQI RED ELEPHANT;So;0;ON;;;;;N;;;;;
@@ -31397,6 +31929,22 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
1FA6B;XIANGQI BLACK CHARIOT;So;0;ON;;;;;N;;;;;
1FA6C;XIANGQI BLACK CANNON;So;0;ON;;;;;N;;;;;
1FA6D;XIANGQI BLACK SOLDIER;So;0;ON;;;;;N;;;;;
+1FA70;BALLET SHOES;So;0;ON;;;;;N;;;;;
+1FA71;ONE-PIECE SWIMSUIT;So;0;ON;;;;;N;;;;;
+1FA72;BRIEFS;So;0;ON;;;;;N;;;;;
+1FA73;SHORTS;So;0;ON;;;;;N;;;;;
+1FA78;DROP OF BLOOD;So;0;ON;;;;;N;;;;;
+1FA79;ADHESIVE BANDAGE;So;0;ON;;;;;N;;;;;
+1FA7A;STETHOSCOPE;So;0;ON;;;;;N;;;;;
+1FA80;YO-YO;So;0;ON;;;;;N;;;;;
+1FA81;KITE;So;0;ON;;;;;N;;;;;
+1FA82;PARACHUTE;So;0;ON;;;;;N;;;;;
+1FA90;RINGED PLANET;So;0;ON;;;;;N;;;;;
+1FA91;CHAIR;So;0;ON;;;;;N;;;;;
+1FA92;RAZOR;So;0;ON;;;;;N;;;;;
+1FA93;AXE;So;0;ON;;;;;N;;;;;
+1FA94;DIYA LAMP;So;0;ON;;;;;N;;;;;
+1FA95;BANJO;So;0;ON;;;;;N;;;;;
20000;<CJK Ideograph Extension B, First>;Lo;0;L;;;;;N;;;;;
2A6D6;<CJK Ideograph Extension B, Last>;Lo;0;L;;;;;N;;;;;
2A700;<CJK Ideograph Extension C, First>;Lo;0;L;;;;;N;;;;;
diff --git a/admin/unidata/blocks.awk b/admin/unidata/blocks.awk
index 1b1d3fc66ba..a7ee134c9f9 100755
--- a/admin/unidata/blocks.awk
+++ b/admin/unidata/blocks.awk
@@ -115,14 +115,15 @@ function name2alias(name , w, w2) {
else if (name ~ /duployan|shorthand/) return "duployan-shorthand"
else if (name ~ /sutton signwriting/) return "sutton-sign-writing"
- sub(/ (extended|extensions|supplement).*/, "", name)
+ sub(/^small /, "", name)
+ sub(/ (extended|extensions*|supplement).*/, "", name)
sub(/numbers/, "number", name)
sub(/numerals/, "numeral", name)
sub(/symbols/, "symbol", name)
sub(/forms$/, "form", name)
sub(/tiles$/, "tile", name)
sub(/^new /, "", name)
- sub(/ (characters|hieroglyphs|cursive)$/, "", name)
+ sub(/ (characters|hieroglyphs|cursive|hieroglyph format controls)$/, "", name)
gsub(/ /, "-", name)
return name
diff --git a/admin/unidata/copyright.html b/admin/unidata/copyright.html
index 84322c85380..2f5c88d1ac1 100644
--- a/admin/unidata/copyright.html
+++ b/admin/unidata/copyright.html
@@ -36,7 +36,7 @@ pre {
<td class="icon"><a href="http://www.unicode.org/"><img border="0"
src="http://www.unicode.org/webscripts/logo60s2.gif" align="middle"
alt="[Unicode]" width="34" height="33"></a>&nbsp;&nbsp;<a class="bar"
- href="http://www.unicode.org/copyright.html"><font size="3">Terms of
+ href="https://www.unicode.org/copyright.html"><font size="3">Terms of
Use</font></a></td>
<td class="bar"><a href="http://www.unicode.org" class="bar">Home</a>
| <a href="http://www.unicode.org/sitemap/" class="bar">Site Map</a> |
@@ -59,46 +59,48 @@ pre {
<td valign="top" class="navColCell"><a href="#1">Unicode Copyright</a></td>
</tr>
<tr>
- <td valign="top" class="navColCell"><a href="#2">Restricted Rights
- Legend</a></td>
+ <td valign="top" class="navColCell"><a href="#6">Definitions</a></td>
</tr>
<tr>
- <td valign="top" class="navColCell"><a href="#3">Warranties &amp;
- Disclaimers</a></td>
+ <td valign="top" class="navColCell"><a href="#8">Terms of Use</a></td>
+ </tr>
+ <tr>
+ <td valign="top" class="navColCell"><a href="#2">Restricted Rights Legend</a></td>
+ </tr>
+ <tr>
+ <td valign="top" class="navColCell"><a href="#3">Warranties &amp; Disclaimers</a></td>
</tr>
<tr>
<td valign="top" class="navColCell"><a href="#4">Waiver of Damages</a></td>
</tr>
<tr>
- <td valign="top" class="navColCell"><a href="#5">Trademarks & Logos</a></td>
+ <td valign="top" class="navColCell"><a href="#5">Trademarks &amp; Logos</a></td>
</tr>
<tr>
<td valign="top" class="navColCell"><a href="#7">Miscellaneous</a></td>
</tr>
<tr>
- <td valign="top" class="navColCell"><a href="#License">Data Files and
- Software License Agreement (Exhibit 1)</a></td>
+ <td class="navColTitle">Unicode License</td>
</tr>
<tr>
- <td valign="top" class="navColCell">&nbsp;</td>
+ <td valign="top" class="navColCell">
+ <a href="https://www.unicode.org/license.html">Unicode Data Files and Software License</a></td>
</tr>
- </table>
- <table class="navColTable" border="0" width="100%" cellspacing="4"
- cellpadding="0">
<tr>
<td class="navColTitle">Related Links</td>
</tr>
<tr>
<td valign="top" class="navColCell">
- <a href="http://www.unicode.org/policies/logo_policy.html">Trademark Policy</a></td>
+ <a href="https://www.unicode.org/policies/privacy_policy.html">Privacy Policy</a></td>
</tr>
<tr>
<td valign="top" class="navColCell">
- <a href="http://www.unicode.org/policies/policies.html">Unicode
- Policies</a></td>
+ <a href="https://www.unicode.org/policies/logo_policy.html">Trademark Policy</a></td>
</tr>
<tr>
- <td valign="top" class="navColCell"></td>
+ <td valign="top" class="navColCell">
+ <a href="https://www.unicode.org/policies/policies.html">Unicode
+ Policies</a></td>
</tr>
</table>
@@ -108,30 +110,41 @@ pre {
<td>
<blockquote>
- <h1>Unicode® Terms of Use</h1>
+ <h1>Unicode® Copyright and Terms of Use</h1>
<p>For the general privacy policy governing access to this site, see
the&nbsp;
<a href="http://www.unicode.org/policies/privacy_policy.html">
- Unicode Privacy Policy</a>. For trademark usage, see
- <a href="http://www.unicode.org/policies/logo_policy.html">the
- Unicode® Consortium Name and Trademark Usage Policy</a>.</p>
-
- <table class="sidebar" align="right" width="50%" id="table1">
- <tr>
- <td class="sidebarTitle">Notice to End User: Terms of Use</td>
- </tr>
- <tr>
- <td class="sidebar">Carefully read the following legal agreement
- (&quot;Agreement&quot;). Use or copying of the software and/or codes
- provided with this agreement (The &quot;Software&quot;) constitutes your
- acceptance of these terms. If you have any questions about these terms of use, please <a href="http://www.unicode.org/contacts.html">contact the Unicode Consortium</a>.</td>
- </tr>
- </table>
+ Unicode Privacy Policy</a>.</p>
+
<ol type="A">
- <li><u><a name="1"></a>Unicode Copyright.</u>
+ <li><u><a name="1"></a>Unicode Copyright</u>
<ol>
<li>Copyright © 1991-2019 Unicode, Inc. All rights reserved.</li>
+ </ol>
+ </li>
+
+ <li><u><a name="6"></a>Definitions</u>
+<pre>
+Unicode Data Files ("DATA FILES") include all data files under the directories:
+https://www.unicode.org/Public/
+https://www.unicode.org/reports/
+https://www.unicode.org/ivd/data/
+
+Unicode Data Files do not include PDF online code charts under the directory:
+https://www.unicode.org/Public/
+
+Unicode Software ("SOFTWARE") includes any source code published in the Unicode Standard
+or any source code or compiled code under the directories:
+https://www.unicode.org/Public/PROGRAMS/
+https://www.unicode.org/Public/cldr/
+https://site.icu-project.org/download/
+</pre>
+ </li>
+
+ <li><u><a name="8"></a>Terms of Use</u>
+ <ol>
+
<li>Certain documents and files on this website contain a legend
indicating that &quot;Modification is permitted.&quot; Any person is
hereby authorized, without fee, to modify such documents and
@@ -141,22 +154,26 @@ pre {
reproduce, and distribute all documents and files, subject to the Terms and Conditions
herein.</li>
<li>Further specifications of rights and restrictions pertaining
- to the use of the particular set of data files known as the
- &quot;Unicode Character Database&quot; can be found in the
- <a href="#License">License</a>.</li>
+ to the use of the Unicode DATA FILES and SOFTWARE can be found in the
+ <a href="https://www.unicode.org/license.html">Unicode Data Files and Software License</a>.</li>
<li>Each version of the Unicode Standard has further
specifications of rights and restrictions of use. For the book
editions (Unicode 5.0 and earlier), these are found on the back
of the
- <a href="http://www.unicode.org/versions/Unicode5.0.0/Title.pdf">title page</a>.
- The online code charts carry specific restrictions. All other files, including online documentation of the core specification for Unicode 6.0 and later, are covered under these general Terms of Use.</li>
+ <a href="http://www.unicode.org/versions/Unicode5.0.0/Title.pdf">title page</a>.</li>
+ <li>
+ The Unicode PDF <a href="https://www.unicode.org/charts/">online code charts</a> carry specific restrictions. Those restrictions are incorporated as the
+ first page of each PDF code chart.</li>
+ <li>All other files, including online documentation of the core specification for Unicode 6.0 and later, are covered under these general Terms of Use.</li>
<li>No license is granted to &quot;mirror&quot; the Unicode website where
a fee is charged for access to the &quot;mirror&quot; site.</li>
<li>Modification is not permitted with respect to this document.
All copies of this document must be verbatim.</li>
</ol>
</li>
- <li><u><a name="2"></a>Restricted Rights Legend</u>. Any technical
+ <li><u><a name="2"></a>Restricted Rights Legend</u>
+ <ol>
+ <li>Any technical
data or software which is licensed to the United States of
America, its agencies and/or instrumentalities under this
Agreement is commercial technical data or commercial computer
@@ -169,66 +186,71 @@ pre {
227-7202, as applicable, use, duplication or disclosure by the
Government is subject to the restrictions set forth in this
Agreement.</li>
- <li><u><a name="3"></a>Warranties and Disclaimers</u>.
+ </ol>
+ </li>
+ <li><u><a name="3"></a>Warranties and Disclaimers</u>
<ol>
<li>This publication and/or website may include technical or
- typographical errors or other inaccuracies . Changes are
+ typographical errors or other inaccuracies. Changes are
periodically added to the information herein; these changes will
be incorporated in new editions of the publication and/or
- website. Unicode may make improvements and/or changes in the
+ website. Unicode, Inc. may make improvements and/or changes in the
product(s) and/or program(s) described in this publication
and/or website at any time.</li>
<li>If this file has been purchased on magnetic or optical media
from Unicode, Inc. the sole and exclusive remedy for any claim
will be exchange of the defective media within ninety (90) days
of original purchase.</li>
- <li>EXCEPT AS PROVIDED IN SECTION&nbsp;C.2, THIS PUBLICATION AND/OR
+ <li>EXCEPT AS PROVIDED IN SECTION&nbsp;E.2, THIS PUBLICATION AND/OR
SOFTWARE IS PROVIDED &quot;AS IS&quot; WITHOUT WARRANTY OF ANY KIND EITHER
EXPRESS, IMPLIED, OR STATUTORY, INCLUDING, BUT NOT LIMITED TO,
ANY WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
- PURPOSE, OR NON-INFRINGEMENT. UNICODE AND ITS LICENSORS ASSUME
+ PURPOSE, OR NON-INFRINGEMENT. UNICODE, INC. AND ITS LICENSORS ASSUME
NO RESPONSIBILITY FOR ERRORS OR OMISSIONS IN THIS PUBLICATION
AND/OR SOFTWARE OR OTHER DOCUMENTS WHICH ARE REFERENCED BY OR
LINKED TO THIS PUBLICATION OR THE UNICODE WEBSITE.</li>
</ol>
</li>
- <li><u><a name="4"></a>Waiver of Damages.</u> In no event shall
- Unicode or its licensors be liable for any special, incidental,
+ <li><u><a name="4"></a>Waiver of Damages</u>
+ <ol>
+ <li>In no event shall
+ Unicode, Inc. or its licensors be liable for any special, incidental,
indirect or consequential damages of any kind, or any damages
- whatsoever, whether or not Unicode was advised of the possibility
+ whatsoever, whether or not Unicode, Inc. was advised of the possibility
of the damage, including, without limitation, those resulting from
the following: loss of use, data or profits, in connection with
the use, modification or distribution of this information or its
derivatives.</li>
- <li><u><a name="5"></a>Trademarks &amp; Logos.</u>
+ </ol>
+ </li>
+ <li><u><a name="5"></a>Trademarks &amp; Logos</u>
<ol>
<li>The Unicode Word Mark and the Unicode Logo are trademarks of Unicode, Inc. “The Unicode Consortium” and “Unicode, Inc.” are trade names of Unicode, Inc. Use of the information and materials found on this website indicates your acknowledgement of Unicode, Inc.’s exclusive worldwide rights in the Unicode Word Mark, the Unicode Logo, and the Unicode trade names.</li>
<li><a href="http://www.unicode.org/policies/logo_policy.html">The Unicode Consortium Name and Trademark Usage Policy</a> (“Trademark Policy”) are incorporated herein by reference and you agree to abide by the provisions of the Trademark Policy, which may be changed from time to time in the sole discretion of Unicode, Inc.</li>
-<li>All third party trademarks referenced herein are the property of their respective owners.
-</li>
+<li>All third party trademarks referenced herein are the property of their respective owners.</li>
</ol>
</li>
- <li><u><a name="7"></a>Miscellaneous</u>.
+ <li><u><a name="7"></a>Miscellaneous</u>
<ol>
- <li><u>Jurisdiction and Venue</u>. This server is operated from
+ <li><u>Jurisdiction and Venue</u>. This website is operated from
a location in the State of California, United States of America.
- Unicode makes no representation that the materials are
+ Unicode, Inc. makes no representation that the materials are
appropriate for use in other locations. If you access this
- server from other locations, you are responsible for compliance
- with local laws. This Agreement, all use of this site and any
- claims and damages resulting from use of this site are governed
+ website from other locations, you are responsible for compliance
+ with local laws. This Agreement, all use of this website and any
+ claims and damages resulting from use of this website are governed
solely by the laws of the State of California without regard to
any principles which would apply the laws of a different
jurisdiction. The user agrees that any disputes regarding this
- site shall be resolved solely in the courts located in Santa
+ website shall be resolved solely in the courts located in Santa
Clara County, California. The user agrees said courts have
personal jurisdiction and agree to waive any right to transfer
- the dispute to any other forum. </li>
- <li><u>Modification by Unicode </u>Unicode shall have the right
- to modify this Agreement at any time by posting it to this site.
+ the dispute to any other forum.</li>
+ <li><u>Modification by Unicode, Inc.</u> Unicode, Inc. shall have the right
+ to modify this Agreement at any time by posting it to this website.
The user may not assign any part of this Agreement without
- Unicode’s prior written consent.</li>
+ Unicode, Inc.’s prior written consent.</li>
<li><u>Taxes.</u> The user agrees to pay any taxes arising from
access to this website or use of the information herein, except
for those based on Unicode’s net income.</li>
@@ -240,71 +262,7 @@ pre {
</ol>
</li>
</ol>
-</blockquote>
- <hr width="95%">
-<blockquote>
-<h3 align="center"><a name="Exhibit1">EXHIBIT 1</a><br>
-<a name="License">UNICODE, INC. LICENSE AGREEMENT - DATA FILES AND SOFTWARE</a></h3>
-
-<pre>
-Unicode Data Files include all data files under the directories
-http://www.unicode.org/Public/, http://www.unicode.org/reports/,
-http://www.unicode.org/cldr/data/, http://source.icu-project.org/repos/icu/,
-http://www.unicode.org/ivd/data/, and
-http://www.unicode.org/utility/trac/browser/.
-
-Unicode Data Files do not include PDF online code charts under the
-directory http://www.unicode.org/Public/.
-
-Software includes any source code published in the Unicode Standard
-or under the directories
-http://www.unicode.org/Public/, http://www.unicode.org/reports/,
-http://www.unicode.org/cldr/data/, http://source.icu-project.org/repos/icu/, and
-http://www.unicode.org/utility/trac/browser/.
-
-NOTICE TO USER: Carefully read the following legal agreement.
-BY DOWNLOADING, INSTALLING, COPYING OR OTHERWISE USING UNICODE INC.'S
-DATA FILES ("DATA FILES"), AND/OR SOFTWARE ("SOFTWARE"),
-YOU UNEQUIVOCALLY ACCEPT, AND AGREE TO BE BOUND BY, ALL OF THE
-TERMS AND CONDITIONS OF THIS AGREEMENT.
-IF YOU DO NOT AGREE, DO NOT DOWNLOAD, INSTALL, COPY, DISTRIBUTE OR USE
-THE DATA FILES OR SOFTWARE.
-
-COPYRIGHT AND PERMISSION NOTICE
-
-Copyright © 1991-2019 Unicode, Inc. All rights reserved.
-Distributed under the Terms of Use in http://www.unicode.org/copyright.html.
-
-Permission is hereby granted, free of charge, to any person obtaining
-a copy of the Unicode data files and any associated documentation
-(the "Data Files") or Unicode software and any associated documentation
-(the "Software") to deal in the Data Files or Software
-without restriction, including without limitation the rights to use,
-copy, modify, merge, publish, distribute, and/or sell copies of
-the Data Files or Software, and to permit persons to whom the Data Files
-or Software are furnished to do so, provided that either
-(a) this copyright and permission notice appear with all copies
-of the Data Files or Software, or
-(b) this copyright and permission notice appear in associated
-Documentation.
-
-THE DATA FILES AND SOFTWARE ARE PROVIDED "AS IS", WITHOUT WARRANTY OF
-ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE
-WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-NONINFRINGEMENT OF THIRD PARTY RIGHTS.
-IN NO EVENT SHALL THE COPYRIGHT HOLDER OR HOLDERS INCLUDED IN THIS
-NOTICE BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL INDIRECT OR CONSEQUENTIAL
-DAMAGES, OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE,
-DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
-TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
-PERFORMANCE OF THE DATA FILES OR SOFTWARE.
-
-Except as contained in this notice, the name of a copyright holder
-shall not be used in advertising or otherwise to promote the sale,
-use or other dealings in these Data Files or Software without prior
-written authorization of the copyright holder.
-</pre>
</blockquote>
diff --git a/admin/unidata/unidata-gen.el b/admin/unidata/unidata-gen.el
index 749cde2178c..1a3afd3c76d 100644
--- a/admin/unidata/unidata-gen.el
+++ b/admin/unidata/unidata-gen.el
@@ -401,7 +401,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)."
(if (consp range)
(if val
(set-char-table-range table range val))
- (let* ((start (lsh (lsh range -7) 7))
+ (let* ((start (ash (ash range -7) 7))
(limit (+ start 127))
first-index last-index)
(fillarray vec 0)
@@ -548,7 +548,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)."
(if (< from (logand to #x1FFF80))
(setq from (logand to #x1FFF80)))
(setq prev-range-data (cons (cons from to) val-code)))))
- (let* ((start (lsh (lsh range -7) 7))
+ (let* ((start (ash (ash range -7) 7))
(limit (+ start 127))
str count new-val from to vcode)
(fillarray vec (car default-value))
@@ -761,7 +761,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)."
((stringp val)
(if (> (aref val 0) 0)
val
- (let* ((first-char (lsh (lsh char -7) 7))
+ (let* ((first-char (ash (ash char -7) 7))
(word-table (aref (char-table-extra-slot table 4) 0))
(i 1)
(len (length val))
@@ -865,7 +865,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)."
((stringp val)
(if (> (aref val 0) 0)
val
- (let* ((first-char (lsh (lsh char -7) 7))
+ (let* ((first-char (ash (ash char -7) 7))
(word-table (char-table-extra-slot table 4))
(i 1)
(len (length val))
@@ -982,7 +982,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)."
(if slot
(nconc slot (list range))
(push (list val range) block-list))))
- (let* ((start (lsh (lsh range -7) 7))
+ (let* ((start (ash (ash range -7) 7))
(limit (+ start 127))
(first tail)
(vec (make-vector 128 nil))
@@ -1413,7 +1413,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)."
(copyright (with-temp-buffer
(insert-file-contents
(expand-file-name "copyright.html" unidata-dir))
- (re-search-forward "^Copyright .*Unicode, Inc.")
+ (re-search-forward "Copyright .*Unicode, Inc.")
(match-string 0))))
(or unidata-list (unidata-setup-list unidata-text-file))
(let* ((basename (file-name-nondirectory file))
diff --git a/admin/unidata/uvs.el b/admin/unidata/uvs.el
index 277d33bbd81..ad2b6548a23 100644
--- a/admin/unidata/uvs.el
+++ b/admin/unidata/uvs.el
@@ -107,7 +107,7 @@ The most significant byte comes first."
(let (result)
(dotimes (i size)
(push (logand value #xff) result)
- (setq value (lsh value -8)))
+ (setq value (ash value -8)))
result))
(defun uvs-insert-fields-as-bytes (fields &rest values)
@@ -201,7 +201,8 @@ corresponding number."
(uvs-alist-from-ivd collection-id
sequence-id-to-glyph-func))))
(set-binary-mode 'stdout t)
- (princ "/* Automatically generated by uvs.el. */\n")
+ (princ "/* This file was automatically generated from admin/unidata/IVD_Sequences.txt\n")
+ (princ " by the script admin/unidata/uvs.el */\n")
(princ
(format "static const unsigned char mac_uvs_table_%s_bytes[] =\n {\n"
(replace-regexp-in-string "[^_[:alnum:]]" "_"
diff --git a/admin/update_autogen b/admin/update_autogen
index 67ed5d66465..bb831a02423 100755
--- a/admin/update_autogen
+++ b/admin/update_autogen
@@ -47,7 +47,7 @@ cd $PD
cd ../
[ -d admin ] || die "Could not locate admin directory"
-[ -d .git ] || die "No .git directory"
+[ -d .git ] || git rev-parse --git-dir > /dev/null 2>&1 || die "Not in a git repository"
usage ()
{
diff --git a/autogen.sh b/autogen.sh
index 7972f01b387..40d0c37b11b 100755
--- a/autogen.sh
+++ b/autogen.sh
@@ -82,7 +82,16 @@ check_version ()
printf '%s' "(using $uprog0=$uprog) "
fi
- command -v $uprog > /dev/null || return 1
+ ## /bin/sh should always define the "command" builtin, but
+ ## sometimes it does not on hydra.nixos.org.
+ ## /bin/sh = "BusyBox v1.27.2", "built-in shell (ash)".
+ ## It seems to be an optional compile-time feature in that shell:
+ ## see ASH_CMDCMD in <https://git.busybox.net/busybox/tree/shell/ash.c>.
+ if command -v command > /dev/null 2>&1; then
+ command -v $uprog > /dev/null || return 1
+ else
+ $uprog --version > /dev/null 2>&1 || return 1
+ fi
have_version=`get_version $uprog` || return 4
have_maj=`major_version $have_version`
diff --git a/build-aux/config.guess b/build-aux/config.guess
index 5dacc291236..79d1317f52b 100755
--- a/build-aux/config.guess
+++ b/build-aux/config.guess
@@ -2,7 +2,7 @@
# Attempt to guess a canonical system name.
# Copyright 1992-2019 Free Software Foundation, Inc.
-timestamp='2018-01-01'
+timestamp='2019-03-04'
# 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
@@ -84,8 +84,6 @@ if test $# != 0; then
exit 1
fi
-trap 'exit 1' 1 2 15
-
# CC_FOR_BUILD -- compiler used by this script. Note that the use of a
# compiler to aid in system detection is discouraged as it requires
# temporary files to be created and, as you can see below, it is a
@@ -96,34 +94,38 @@ trap 'exit 1' 1 2 15
# Portable tmp directory creation inspired by the Autoconf team.
-set_cc_for_build='
-trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ;
-trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ;
-: ${TMPDIR=/tmp} ;
- { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } ||
- { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } ||
- { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } ||
- { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ;
-dummy=$tmp/dummy ;
-tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ;
-case $CC_FOR_BUILD,$HOST_CC,$CC in
- ,,) echo "int x;" > $dummy.c ;
- for c in cc gcc c89 c99 ; do
- if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then
- CC_FOR_BUILD="$c"; break ;
- fi ;
- done ;
- if test x"$CC_FOR_BUILD" = x ; then
- CC_FOR_BUILD=no_compiler_found ;
- fi
- ;;
- ,,*) CC_FOR_BUILD=$CC ;;
- ,*,*) CC_FOR_BUILD=$HOST_CC ;;
-esac ; set_cc_for_build= ;'
+tmp=
+# shellcheck disable=SC2172
+trap 'test -z "$tmp" || rm -fr "$tmp"' 0 1 2 13 15
+
+set_cc_for_build() {
+ : "${TMPDIR=/tmp}"
+ # shellcheck disable=SC2039
+ { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } ||
+ { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir "$tmp" 2>/dev/null) ; } ||
+ { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir "$tmp" 2>/dev/null) && echo "Warning: creating insecure temp directory" >&2 ; } ||
+ { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; }
+ dummy=$tmp/dummy
+ case ${CC_FOR_BUILD-},${HOST_CC-},${CC-} in
+ ,,) echo "int x;" > "$dummy.c"
+ for driver in cc gcc c89 c99 ; do
+ if ($driver -c -o "$dummy.o" "$dummy.c") >/dev/null 2>&1 ; then
+ CC_FOR_BUILD="$driver"
+ break
+ fi
+ done
+ if test x"$CC_FOR_BUILD" = x ; then
+ CC_FOR_BUILD=no_compiler_found
+ fi
+ ;;
+ ,,*) CC_FOR_BUILD=$CC ;;
+ ,*,*) CC_FOR_BUILD=$HOST_CC ;;
+ esac
+}
# This is needed to find uname on a Pyramid OSx when run in the BSD universe.
# (ghazi@noc.rutgers.edu 1994-08-24)
-if (test -f /.attbin/uname) >/dev/null 2>&1 ; then
+if test -f /.attbin/uname ; then
PATH=$PATH:/.attbin ; export PATH
fi
@@ -132,14 +134,14 @@ UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown
UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown
UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown
-case "${UNAME_SYSTEM}" in
+case "$UNAME_SYSTEM" in
Linux|GNU|GNU/*)
# If the system lacks a compiler, then just pick glibc.
# We could probably try harder.
LIBC=gnu
- eval $set_cc_for_build
- cat <<-EOF > $dummy.c
+ set_cc_for_build
+ cat <<-EOF > "$dummy.c"
#include <features.h>
#if defined(__UCLIBC__)
LIBC=uclibc
@@ -149,13 +151,20 @@ Linux|GNU|GNU/*)
LIBC=gnu
#endif
EOF
- eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC' | sed 's, ,,g'`
+ eval "`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^LIBC' | sed 's, ,,g'`"
+
+ # If ldd exists, use it to detect musl libc.
+ if command -v ldd >/dev/null && \
+ ldd --version 2>&1 | grep -q ^musl
+ then
+ LIBC=musl
+ fi
;;
esac
# Note: order is significant - the case branches are not exclusive.
-case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
+case "$UNAME_MACHINE:$UNAME_SYSTEM:$UNAME_RELEASE:$UNAME_VERSION" in
*:NetBSD:*:*)
# NetBSD (nbsd) targets should (where applicable) match one or
# more of the tuples: *-*-netbsdelf*, *-*-netbsdaout*,
@@ -169,30 +178,30 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
# portion of the name. We always set it to "unknown".
sysctl="sysctl -n hw.machine_arch"
UNAME_MACHINE_ARCH=`(uname -p 2>/dev/null || \
- /sbin/$sysctl 2>/dev/null || \
- /usr/sbin/$sysctl 2>/dev/null || \
+ "/sbin/$sysctl" 2>/dev/null || \
+ "/usr/sbin/$sysctl" 2>/dev/null || \
echo unknown)`
- case "${UNAME_MACHINE_ARCH}" in
+ case "$UNAME_MACHINE_ARCH" in
armeb) machine=armeb-unknown ;;
arm*) machine=arm-unknown ;;
sh3el) machine=shl-unknown ;;
sh3eb) machine=sh-unknown ;;
sh5el) machine=sh5le-unknown ;;
earmv*)
- arch=`echo ${UNAME_MACHINE_ARCH} | sed -e 's,^e\(armv[0-9]\).*$,\1,'`
- endian=`echo ${UNAME_MACHINE_ARCH} | sed -ne 's,^.*\(eb\)$,\1,p'`
- machine=${arch}${endian}-unknown
+ arch=`echo "$UNAME_MACHINE_ARCH" | sed -e 's,^e\(armv[0-9]\).*$,\1,'`
+ endian=`echo "$UNAME_MACHINE_ARCH" | sed -ne 's,^.*\(eb\)$,\1,p'`
+ machine="${arch}${endian}"-unknown
;;
- *) machine=${UNAME_MACHINE_ARCH}-unknown ;;
+ *) machine="$UNAME_MACHINE_ARCH"-unknown ;;
esac
# The Operating System including object format, if it has switched
# to ELF recently (or will in the future) and ABI.
- case "${UNAME_MACHINE_ARCH}" in
+ case "$UNAME_MACHINE_ARCH" in
earm*)
os=netbsdelf
;;
arm*|i386|m68k|ns32k|sh3*|sparc|vax)
- eval $set_cc_for_build
+ set_cc_for_build
if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \
| grep -q __ELF__
then
@@ -208,10 +217,10 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
;;
esac
# Determine ABI tags.
- case "${UNAME_MACHINE_ARCH}" in
+ case "$UNAME_MACHINE_ARCH" in
earm*)
expr='s/^earmv[0-9]/-eabi/;s/eb$//'
- abi=`echo ${UNAME_MACHINE_ARCH} | sed -e "$expr"`
+ abi=`echo "$UNAME_MACHINE_ARCH" | sed -e "$expr"`
;;
esac
# The OS release
@@ -219,51 +228,51 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
# thus, need a distinct triplet. However, they do not need
# kernel version information, so it can be replaced with a
# suitable tag, in the style of linux-gnu.
- case "${UNAME_VERSION}" in
+ case "$UNAME_VERSION" in
Debian*)
release='-gnu'
;;
*)
- release=`echo ${UNAME_RELEASE} | sed -e 's/[-_].*//' | cut -d. -f1,2`
+ release=`echo "$UNAME_RELEASE" | sed -e 's/[-_].*//' | cut -d. -f1,2`
;;
esac
# Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM:
# contains redundant information, the shorter form:
# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used.
- echo "${machine}-${os}${release}${abi}"
+ echo "$machine-${os}${release}${abi-}"
exit ;;
*:Bitrig:*:*)
UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'`
- echo ${UNAME_MACHINE_ARCH}-unknown-bitrig${UNAME_RELEASE}
+ echo "$UNAME_MACHINE_ARCH"-unknown-bitrig"$UNAME_RELEASE"
exit ;;
*:OpenBSD:*:*)
UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'`
- echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE}
+ echo "$UNAME_MACHINE_ARCH"-unknown-openbsd"$UNAME_RELEASE"
exit ;;
*:LibertyBSD:*:*)
UNAME_MACHINE_ARCH=`arch | sed 's/^.*BSD\.//'`
- echo ${UNAME_MACHINE_ARCH}-unknown-libertybsd${UNAME_RELEASE}
+ echo "$UNAME_MACHINE_ARCH"-unknown-libertybsd"$UNAME_RELEASE"
exit ;;
*:MidnightBSD:*:*)
- echo ${UNAME_MACHINE}-unknown-midnightbsd${UNAME_RELEASE}
+ echo "$UNAME_MACHINE"-unknown-midnightbsd"$UNAME_RELEASE"
exit ;;
*:ekkoBSD:*:*)
- echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE}
+ echo "$UNAME_MACHINE"-unknown-ekkobsd"$UNAME_RELEASE"
exit ;;
*:SolidBSD:*:*)
- echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE}
+ echo "$UNAME_MACHINE"-unknown-solidbsd"$UNAME_RELEASE"
exit ;;
macppc:MirBSD:*:*)
- echo powerpc-unknown-mirbsd${UNAME_RELEASE}
+ echo powerpc-unknown-mirbsd"$UNAME_RELEASE"
exit ;;
*:MirBSD:*:*)
- echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE}
+ echo "$UNAME_MACHINE"-unknown-mirbsd"$UNAME_RELEASE"
exit ;;
*:Sortix:*:*)
- echo ${UNAME_MACHINE}-unknown-sortix
+ echo "$UNAME_MACHINE"-unknown-sortix
exit ;;
*:Redox:*:*)
- echo ${UNAME_MACHINE}-unknown-redox
+ echo "$UNAME_MACHINE"-unknown-redox
exit ;;
mips:OSF1:*.*)
echo mips-dec-osf1
@@ -319,7 +328,7 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
# A Tn.n version is a released field test version.
# A Xn.n version is an unreleased experimental baselevel.
# 1.2 uses "1.2" for uname -r.
- echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz`
+ echo "$UNAME_MACHINE"-dec-osf"`echo "$UNAME_RELEASE" | sed -e 's/^[PVTX]//' | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz`"
# Reset EXIT trap before exiting to avoid spurious non-zero exit code.
exitcode=$?
trap '' 0
@@ -328,10 +337,10 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
echo m68k-unknown-sysv4
exit ;;
*:[Aa]miga[Oo][Ss]:*:*)
- echo ${UNAME_MACHINE}-unknown-amigaos
+ echo "$UNAME_MACHINE"-unknown-amigaos
exit ;;
*:[Mm]orph[Oo][Ss]:*:*)
- echo ${UNAME_MACHINE}-unknown-morphos
+ echo "$UNAME_MACHINE"-unknown-morphos
exit ;;
*:OS/390:*:*)
echo i370-ibm-openedition
@@ -343,7 +352,7 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
echo powerpc-ibm-os400
exit ;;
arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*)
- echo arm-acorn-riscix${UNAME_RELEASE}
+ echo arm-acorn-riscix"$UNAME_RELEASE"
exit ;;
arm*:riscos:*:*|arm*:RISCOS:*:*)
echo arm-unknown-riscos
@@ -370,19 +379,19 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
sparc) echo sparc-icl-nx7; exit ;;
esac ;;
s390x:SunOS:*:*)
- echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ echo "$UNAME_MACHINE"-ibm-solaris2"`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'`"
exit ;;
sun4H:SunOS:5.*:*)
- echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ echo sparc-hal-solaris2"`echo "$UNAME_RELEASE"|sed -e 's/[^.]*//'`"
exit ;;
sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*)
- echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ echo sparc-sun-solaris2"`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'`"
exit ;;
i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*)
- echo i386-pc-auroraux${UNAME_RELEASE}
+ echo i386-pc-auroraux"$UNAME_RELEASE"
exit ;;
i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*)
- eval $set_cc_for_build
+ set_cc_for_build
SUN_ARCH=i386
# If there is a compiler, see if it is configured for 64-bit objects.
# Note that the Sun cc does not turn __LP64__ into 1 like gcc does.
@@ -395,13 +404,13 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
SUN_ARCH=x86_64
fi
fi
- echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ echo "$SUN_ARCH"-pc-solaris2"`echo "$UNAME_RELEASE"|sed -e 's/[^.]*//'`"
exit ;;
sun4*:SunOS:6*:*)
# According to config.sub, this is the proper way to canonicalize
# SunOS6. Hard to guess exactly what SunOS6 will be like, but
# it's likely to be more like Solaris than SunOS4.
- echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ echo sparc-sun-solaris3"`echo "$UNAME_RELEASE"|sed -e 's/[^.]*//'`"
exit ;;
sun4*:SunOS:*:*)
case "`/usr/bin/arch -k`" in
@@ -410,25 +419,25 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
;;
esac
# Japanese Language versions have a version number like `4.1.3-JL'.
- echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'`
+ echo sparc-sun-sunos"`echo "$UNAME_RELEASE"|sed -e 's/-/_/'`"
exit ;;
sun3*:SunOS:*:*)
- echo m68k-sun-sunos${UNAME_RELEASE}
+ echo m68k-sun-sunos"$UNAME_RELEASE"
exit ;;
sun*:*:4.2BSD:*)
UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null`
- test "x${UNAME_RELEASE}" = x && UNAME_RELEASE=3
+ test "x$UNAME_RELEASE" = x && UNAME_RELEASE=3
case "`/bin/arch`" in
sun3)
- echo m68k-sun-sunos${UNAME_RELEASE}
+ echo m68k-sun-sunos"$UNAME_RELEASE"
;;
sun4)
- echo sparc-sun-sunos${UNAME_RELEASE}
+ echo sparc-sun-sunos"$UNAME_RELEASE"
;;
esac
exit ;;
aushp:SunOS:*:*)
- echo sparc-auspex-sunos${UNAME_RELEASE}
+ echo sparc-auspex-sunos"$UNAME_RELEASE"
exit ;;
# The situation for MiNT is a little confusing. The machine name
# can be virtually everything (everything which is not
@@ -439,44 +448,44 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
# MiNT. But MiNT is downward compatible to TOS, so this should
# be no problem.
atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*)
- echo m68k-atari-mint${UNAME_RELEASE}
+ echo m68k-atari-mint"$UNAME_RELEASE"
exit ;;
atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*)
- echo m68k-atari-mint${UNAME_RELEASE}
+ echo m68k-atari-mint"$UNAME_RELEASE"
exit ;;
*falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*)
- echo m68k-atari-mint${UNAME_RELEASE}
+ echo m68k-atari-mint"$UNAME_RELEASE"
exit ;;
milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*)
- echo m68k-milan-mint${UNAME_RELEASE}
+ echo m68k-milan-mint"$UNAME_RELEASE"
exit ;;
hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*)
- echo m68k-hades-mint${UNAME_RELEASE}
+ echo m68k-hades-mint"$UNAME_RELEASE"
exit ;;
*:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*)
- echo m68k-unknown-mint${UNAME_RELEASE}
+ echo m68k-unknown-mint"$UNAME_RELEASE"
exit ;;
m68k:machten:*:*)
- echo m68k-apple-machten${UNAME_RELEASE}
+ echo m68k-apple-machten"$UNAME_RELEASE"
exit ;;
powerpc:machten:*:*)
- echo powerpc-apple-machten${UNAME_RELEASE}
+ echo powerpc-apple-machten"$UNAME_RELEASE"
exit ;;
RISC*:Mach:*:*)
echo mips-dec-mach_bsd4.3
exit ;;
RISC*:ULTRIX:*:*)
- echo mips-dec-ultrix${UNAME_RELEASE}
+ echo mips-dec-ultrix"$UNAME_RELEASE"
exit ;;
VAX*:ULTRIX*:*:*)
- echo vax-dec-ultrix${UNAME_RELEASE}
+ echo vax-dec-ultrix"$UNAME_RELEASE"
exit ;;
2020:CLIX:*:* | 2430:CLIX:*:*)
- echo clipper-intergraph-clix${UNAME_RELEASE}
+ echo clipper-intergraph-clix"$UNAME_RELEASE"
exit ;;
mips:*:*:UMIPS | mips:*:*:RISCos)
- eval $set_cc_for_build
- sed 's/^ //' << EOF >$dummy.c
+ set_cc_for_build
+ sed 's/^ //' << EOF > "$dummy.c"
#ifdef __cplusplus
#include <stdio.h> /* for printf() prototype */
int main (int argc, char *argv[]) {
@@ -497,11 +506,11 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
exit (-1);
}
EOF
- $CC_FOR_BUILD -o $dummy $dummy.c &&
- dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` &&
- SYSTEM_NAME=`$dummy $dummyarg` &&
+ $CC_FOR_BUILD -o "$dummy" "$dummy.c" &&
+ dummyarg=`echo "$UNAME_RELEASE" | sed -n 's/\([0-9]*\).*/\1/p'` &&
+ SYSTEM_NAME=`"$dummy" "$dummyarg"` &&
{ echo "$SYSTEM_NAME"; exit; }
- echo mips-mips-riscos${UNAME_RELEASE}
+ echo mips-mips-riscos"$UNAME_RELEASE"
exit ;;
Motorola:PowerMAX_OS:*:*)
echo powerpc-motorola-powermax
@@ -527,17 +536,17 @@ EOF
AViiON:dgux:*:*)
# DG/UX returns AViiON for all architectures
UNAME_PROCESSOR=`/usr/bin/uname -p`
- if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ]
+ if [ "$UNAME_PROCESSOR" = mc88100 ] || [ "$UNAME_PROCESSOR" = mc88110 ]
then
- if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \
- [ ${TARGET_BINARY_INTERFACE}x = x ]
+ if [ "$TARGET_BINARY_INTERFACE"x = m88kdguxelfx ] || \
+ [ "$TARGET_BINARY_INTERFACE"x = x ]
then
- echo m88k-dg-dgux${UNAME_RELEASE}
+ echo m88k-dg-dgux"$UNAME_RELEASE"
else
- echo m88k-dg-dguxbcs${UNAME_RELEASE}
+ echo m88k-dg-dguxbcs"$UNAME_RELEASE"
fi
else
- echo i586-dg-dgux${UNAME_RELEASE}
+ echo i586-dg-dgux"$UNAME_RELEASE"
fi
exit ;;
M88*:DolphinOS:*:*) # DolphinOS (SVR3)
@@ -554,7 +563,7 @@ EOF
echo m68k-tektronix-bsd
exit ;;
*:IRIX*:*:*)
- echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'`
+ echo mips-sgi-irix"`echo "$UNAME_RELEASE"|sed -e 's/-/_/g'`"
exit ;;
????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX.
echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id
@@ -566,14 +575,14 @@ EOF
if [ -x /usr/bin/oslevel ] ; then
IBM_REV=`/usr/bin/oslevel`
else
- IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE}
+ IBM_REV="$UNAME_VERSION.$UNAME_RELEASE"
fi
- echo ${UNAME_MACHINE}-ibm-aix${IBM_REV}
+ echo "$UNAME_MACHINE"-ibm-aix"$IBM_REV"
exit ;;
*:AIX:2:3)
if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then
- eval $set_cc_for_build
- sed 's/^ //' << EOF >$dummy.c
+ set_cc_for_build
+ sed 's/^ //' << EOF > "$dummy.c"
#include <sys/systemcfg.h>
main()
@@ -584,7 +593,7 @@ EOF
exit(0);
}
EOF
- if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy`
+ if $CC_FOR_BUILD -o "$dummy" "$dummy.c" && SYSTEM_NAME=`"$dummy"`
then
echo "$SYSTEM_NAME"
else
@@ -598,7 +607,7 @@ EOF
exit ;;
*:AIX:*:[4567])
IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'`
- if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then
+ if /usr/sbin/lsattr -El "$IBM_CPU_ID" | grep ' POWER' >/dev/null 2>&1; then
IBM_ARCH=rs6000
else
IBM_ARCH=powerpc
@@ -607,9 +616,9 @@ EOF
IBM_REV=`/usr/bin/lslpp -Lqc bos.rte.libc |
awk -F: '{ print $3 }' | sed s/[0-9]*$/0/`
else
- IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE}
+ IBM_REV="$UNAME_VERSION.$UNAME_RELEASE"
fi
- echo ${IBM_ARCH}-ibm-aix${IBM_REV}
+ echo "$IBM_ARCH"-ibm-aix"$IBM_REV"
exit ;;
*:AIX:*:*)
echo rs6000-ibm-aix
@@ -618,7 +627,7 @@ EOF
echo romp-ibm-bsd4.4
exit ;;
ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and
- echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to
+ echo romp-ibm-bsd"$UNAME_RELEASE" # 4.3 with uname added to
exit ;; # report: romp-ibm BSD 4.3
*:BOSX:*:*)
echo rs6000-bull-bosx
@@ -633,28 +642,28 @@ EOF
echo m68k-hp-bsd4.4
exit ;;
9000/[34678]??:HP-UX:*:*)
- HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`
- case "${UNAME_MACHINE}" in
+ HPUX_REV=`echo "$UNAME_RELEASE"|sed -e 's/[^.]*.[0B]*//'`
+ case "$UNAME_MACHINE" in
9000/31?) HP_ARCH=m68000 ;;
9000/[34]??) HP_ARCH=m68k ;;
9000/[678][0-9][0-9])
if [ -x /usr/bin/getconf ]; then
sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null`
sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null`
- case "${sc_cpu_version}" in
+ case "$sc_cpu_version" in
523) HP_ARCH=hppa1.0 ;; # CPU_PA_RISC1_0
528) HP_ARCH=hppa1.1 ;; # CPU_PA_RISC1_1
532) # CPU_PA_RISC2_0
- case "${sc_kernel_bits}" in
+ case "$sc_kernel_bits" in
32) HP_ARCH=hppa2.0n ;;
64) HP_ARCH=hppa2.0w ;;
'') HP_ARCH=hppa2.0 ;; # HP-UX 10.20
esac ;;
esac
fi
- if [ "${HP_ARCH}" = "" ]; then
- eval $set_cc_for_build
- sed 's/^ //' << EOF >$dummy.c
+ if [ "$HP_ARCH" = "" ]; then
+ set_cc_for_build
+ sed 's/^ //' << EOF > "$dummy.c"
#define _HPUX_SOURCE
#include <stdlib.h>
@@ -687,13 +696,13 @@ EOF
exit (0);
}
EOF
- (CCOPTS="" $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy`
+ (CCOPTS="" $CC_FOR_BUILD -o "$dummy" "$dummy.c" 2>/dev/null) && HP_ARCH=`"$dummy"`
test -z "$HP_ARCH" && HP_ARCH=hppa
fi ;;
esac
- if [ ${HP_ARCH} = hppa2.0w ]
+ if [ "$HP_ARCH" = hppa2.0w ]
then
- eval $set_cc_for_build
+ set_cc_for_build
# hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating
# 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler
@@ -712,15 +721,15 @@ EOF
HP_ARCH=hppa64
fi
fi
- echo ${HP_ARCH}-hp-hpux${HPUX_REV}
+ echo "$HP_ARCH"-hp-hpux"$HPUX_REV"
exit ;;
ia64:HP-UX:*:*)
- HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`
- echo ia64-hp-hpux${HPUX_REV}
+ HPUX_REV=`echo "$UNAME_RELEASE"|sed -e 's/[^.]*.[0B]*//'`
+ echo ia64-hp-hpux"$HPUX_REV"
exit ;;
3050*:HI-UX:*:*)
- eval $set_cc_for_build
- sed 's/^ //' << EOF >$dummy.c
+ set_cc_for_build
+ sed 's/^ //' << EOF > "$dummy.c"
#include <unistd.h>
int
main ()
@@ -745,7 +754,7 @@ EOF
exit (0);
}
EOF
- $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` &&
+ $CC_FOR_BUILD -o "$dummy" "$dummy.c" && SYSTEM_NAME=`"$dummy"` &&
{ echo "$SYSTEM_NAME"; exit; }
echo unknown-hitachi-hiuxwe2
exit ;;
@@ -766,9 +775,9 @@ EOF
exit ;;
i*86:OSF1:*:*)
if [ -x /usr/sbin/sysversion ] ; then
- echo ${UNAME_MACHINE}-unknown-osf1mk
+ echo "$UNAME_MACHINE"-unknown-osf1mk
else
- echo ${UNAME_MACHINE}-unknown-osf1
+ echo "$UNAME_MACHINE"-unknown-osf1
fi
exit ;;
parisc*:Lites*:*:*)
@@ -793,109 +802,120 @@ EOF
echo c4-convex-bsd
exit ;;
CRAY*Y-MP:*:*:*)
- echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ echo ymp-cray-unicos"$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'
exit ;;
CRAY*[A-Z]90:*:*:*)
- echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \
+ echo "$UNAME_MACHINE"-cray-unicos"$UNAME_RELEASE" \
| sed -e 's/CRAY.*\([A-Z]90\)/\1/' \
-e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \
-e 's/\.[^.]*$/.X/'
exit ;;
CRAY*TS:*:*:*)
- echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ echo t90-cray-unicos"$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'
exit ;;
CRAY*T3E:*:*:*)
- echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ echo alphaev5-cray-unicosmk"$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'
exit ;;
CRAY*SV1:*:*:*)
- echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ echo sv1-cray-unicos"$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'
exit ;;
*:UNICOS/mp:*:*)
- echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ echo craynv-cray-unicosmp"$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'
exit ;;
F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*)
FUJITSU_PROC=`uname -m | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz`
FUJITSU_SYS=`uname -p | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/\///'`
- FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'`
+ FUJITSU_REL=`echo "$UNAME_RELEASE" | sed -e 's/ /_/'`
echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
exit ;;
5000:UNIX_System_V:4.*:*)
FUJITSU_SYS=`uname -p | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/\///'`
- FUJITSU_REL=`echo ${UNAME_RELEASE} | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/ /_/'`
+ FUJITSU_REL=`echo "$UNAME_RELEASE" | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/ /_/'`
echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
exit ;;
i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*)
- echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE}
+ echo "$UNAME_MACHINE"-pc-bsdi"$UNAME_RELEASE"
exit ;;
sparc*:BSD/OS:*:*)
- echo sparc-unknown-bsdi${UNAME_RELEASE}
+ echo sparc-unknown-bsdi"$UNAME_RELEASE"
exit ;;
*:BSD/OS:*:*)
- echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE}
+ echo "$UNAME_MACHINE"-unknown-bsdi"$UNAME_RELEASE"
+ exit ;;
+ arm:FreeBSD:*:*)
+ UNAME_PROCESSOR=`uname -p`
+ set_cc_for_build
+ if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \
+ | grep -q __ARM_PCS_VFP
+ then
+ echo "${UNAME_PROCESSOR}"-unknown-freebsd"`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`"-gnueabi
+ else
+ echo "${UNAME_PROCESSOR}"-unknown-freebsd"`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`"-gnueabihf
+ fi
exit ;;
*:FreeBSD:*:*)
UNAME_PROCESSOR=`/usr/bin/uname -p`
- case ${UNAME_PROCESSOR} in
+ case "$UNAME_PROCESSOR" in
amd64)
UNAME_PROCESSOR=x86_64 ;;
i386)
UNAME_PROCESSOR=i586 ;;
esac
- echo ${UNAME_PROCESSOR}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`
+ echo "$UNAME_PROCESSOR"-unknown-freebsd"`echo "$UNAME_RELEASE"|sed -e 's/[-(].*//'`"
exit ;;
i*:CYGWIN*:*)
- echo ${UNAME_MACHINE}-pc-cygwin
+ echo "$UNAME_MACHINE"-pc-cygwin
exit ;;
*:MINGW64*:*)
- echo ${UNAME_MACHINE}-pc-mingw64
+ echo "$UNAME_MACHINE"-pc-mingw64
exit ;;
*:MINGW*:*)
- echo ${UNAME_MACHINE}-pc-mingw32
+ echo "$UNAME_MACHINE"-pc-mingw32
exit ;;
*:MSYS*:*)
- echo ${UNAME_MACHINE}-pc-msys
+ echo "$UNAME_MACHINE"-pc-msys
exit ;;
i*:PW*:*)
- echo ${UNAME_MACHINE}-pc-pw32
+ echo "$UNAME_MACHINE"-pc-pw32
exit ;;
*:Interix*:*)
- case ${UNAME_MACHINE} in
+ case "$UNAME_MACHINE" in
x86)
- echo i586-pc-interix${UNAME_RELEASE}
+ echo i586-pc-interix"$UNAME_RELEASE"
exit ;;
authenticamd | genuineintel | EM64T)
- echo x86_64-unknown-interix${UNAME_RELEASE}
+ echo x86_64-unknown-interix"$UNAME_RELEASE"
exit ;;
IA64)
- echo ia64-unknown-interix${UNAME_RELEASE}
+ echo ia64-unknown-interix"$UNAME_RELEASE"
exit ;;
esac ;;
i*:UWIN*:*)
- echo ${UNAME_MACHINE}-pc-uwin
+ echo "$UNAME_MACHINE"-pc-uwin
exit ;;
amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*)
- echo x86_64-unknown-cygwin
+ echo x86_64-pc-cygwin
exit ;;
prep*:SunOS:5.*:*)
- echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ echo powerpcle-unknown-solaris2"`echo "$UNAME_RELEASE"|sed -e 's/[^.]*//'`"
exit ;;
*:GNU:*:*)
# the GNU system
- echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-${LIBC}`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'`
+ echo "`echo "$UNAME_MACHINE"|sed -e 's,[-/].*$,,'`-unknown-$LIBC`echo "$UNAME_RELEASE"|sed -e 's,/.*$,,'`"
exit ;;
*:GNU/*:*:*)
# other systems with GNU libc and userland
- echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr "[:upper:]" "[:lower:]"``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-${LIBC}
+ echo "$UNAME_MACHINE-unknown-`echo "$UNAME_SYSTEM" | sed 's,^[^/]*/,,' | tr "[:upper:]" "[:lower:]"``echo "$UNAME_RELEASE"|sed -e 's/[-(].*//'`-$LIBC"
exit ;;
- i*86:Minix:*:*)
- echo ${UNAME_MACHINE}-pc-minix
+ *:Minix:*:*)
+ echo "$UNAME_MACHINE"-unknown-minix
exit ;;
aarch64:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
aarch64_be:Linux:*:*)
UNAME_MACHINE=aarch64_be
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
alpha:Linux:*:*)
case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in
@@ -909,140 +929,168 @@ EOF
esac
objdump --private-headers /bin/sh | grep -q ld.so.1
if test "$?" = 0 ; then LIBC=gnulibc1 ; fi
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
arc:Linux:*:* | arceb:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
arm*:Linux:*:*)
- eval $set_cc_for_build
+ set_cc_for_build
if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \
| grep -q __ARM_EABI__
then
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
else
if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \
| grep -q __ARM_PCS_VFP
then
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabi
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"eabi
else
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabihf
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"eabihf
fi
fi
exit ;;
avr32*:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
cris:Linux:*:*)
- echo ${UNAME_MACHINE}-axis-linux-${LIBC}
+ echo "$UNAME_MACHINE"-axis-linux-"$LIBC"
exit ;;
crisv32:Linux:*:*)
- echo ${UNAME_MACHINE}-axis-linux-${LIBC}
+ echo "$UNAME_MACHINE"-axis-linux-"$LIBC"
exit ;;
e2k:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
frv:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
hexagon:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
i*86:Linux:*:*)
- echo ${UNAME_MACHINE}-pc-linux-${LIBC}
+ echo "$UNAME_MACHINE"-pc-linux-"$LIBC"
exit ;;
ia64:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
k1om:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
m32r*:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
m68*:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
mips:Linux:*:* | mips64:Linux:*:*)
- eval $set_cc_for_build
- sed 's/^ //' << EOF >$dummy.c
+ set_cc_for_build
+ IS_GLIBC=0
+ test x"${LIBC}" = xgnu && IS_GLIBC=1
+ sed 's/^ //' << EOF > "$dummy.c"
#undef CPU
- #undef ${UNAME_MACHINE}
- #undef ${UNAME_MACHINE}el
+ #undef mips
+ #undef mipsel
+ #undef mips64
+ #undef mips64el
+ #if ${IS_GLIBC} && defined(_ABI64)
+ LIBCABI=gnuabi64
+ #else
+ #if ${IS_GLIBC} && defined(_ABIN32)
+ LIBCABI=gnuabin32
+ #else
+ LIBCABI=${LIBC}
+ #endif
+ #endif
+
+ #if ${IS_GLIBC} && defined(__mips64) && defined(__mips_isa_rev) && __mips_isa_rev>=6
+ CPU=mipsisa64r6
+ #else
+ #if ${IS_GLIBC} && !defined(__mips64) && defined(__mips_isa_rev) && __mips_isa_rev>=6
+ CPU=mipsisa32r6
+ #else
+ #if defined(__mips64)
+ CPU=mips64
+ #else
+ CPU=mips
+ #endif
+ #endif
+ #endif
+
#if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL)
- CPU=${UNAME_MACHINE}el
+ MIPS_ENDIAN=el
#else
#if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB)
- CPU=${UNAME_MACHINE}
+ MIPS_ENDIAN=
#else
- CPU=
+ MIPS_ENDIAN=
#endif
#endif
EOF
- eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'`
- test x"${CPU}" != x && { echo "${CPU}-unknown-linux-${LIBC}"; exit; }
+ eval "`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^CPU\|^MIPS_ENDIAN\|^LIBCABI'`"
+ test "x$CPU" != x && { echo "$CPU${MIPS_ENDIAN}-unknown-linux-$LIBCABI"; exit; }
;;
mips64el:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
openrisc*:Linux:*:*)
- echo or1k-unknown-linux-${LIBC}
+ echo or1k-unknown-linux-"$LIBC"
exit ;;
or32:Linux:*:* | or1k*:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
padre:Linux:*:*)
- echo sparc-unknown-linux-${LIBC}
+ echo sparc-unknown-linux-"$LIBC"
exit ;;
parisc64:Linux:*:* | hppa64:Linux:*:*)
- echo hppa64-unknown-linux-${LIBC}
+ echo hppa64-unknown-linux-"$LIBC"
exit ;;
parisc:Linux:*:* | hppa:Linux:*:*)
# Look for CPU level
case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in
- PA7*) echo hppa1.1-unknown-linux-${LIBC} ;;
- PA8*) echo hppa2.0-unknown-linux-${LIBC} ;;
- *) echo hppa-unknown-linux-${LIBC} ;;
+ PA7*) echo hppa1.1-unknown-linux-"$LIBC" ;;
+ PA8*) echo hppa2.0-unknown-linux-"$LIBC" ;;
+ *) echo hppa-unknown-linux-"$LIBC" ;;
esac
exit ;;
ppc64:Linux:*:*)
- echo powerpc64-unknown-linux-${LIBC}
+ echo powerpc64-unknown-linux-"$LIBC"
exit ;;
ppc:Linux:*:*)
- echo powerpc-unknown-linux-${LIBC}
+ echo powerpc-unknown-linux-"$LIBC"
exit ;;
ppc64le:Linux:*:*)
- echo powerpc64le-unknown-linux-${LIBC}
+ echo powerpc64le-unknown-linux-"$LIBC"
exit ;;
ppcle:Linux:*:*)
- echo powerpcle-unknown-linux-${LIBC}
+ echo powerpcle-unknown-linux-"$LIBC"
exit ;;
riscv32:Linux:*:* | riscv64:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
s390:Linux:*:* | s390x:Linux:*:*)
- echo ${UNAME_MACHINE}-ibm-linux-${LIBC}
+ echo "$UNAME_MACHINE"-ibm-linux-"$LIBC"
exit ;;
sh64*:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
sh*:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
sparc:Linux:*:* | sparc64:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
tile*:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
vax:Linux:*:*)
- echo ${UNAME_MACHINE}-dec-linux-${LIBC}
+ echo "$UNAME_MACHINE"-dec-linux-"$LIBC"
exit ;;
x86_64:Linux:*:*)
- echo ${UNAME_MACHINE}-pc-linux-${LIBC}
+ echo "$UNAME_MACHINE"-pc-linux-"$LIBC"
exit ;;
xtensa*:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}
+ echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"
exit ;;
i*86:DYNIX/ptx:4*:*)
# ptx 4.0 does uname -s correctly, with DYNIX/ptx in there.
@@ -1056,34 +1104,34 @@ EOF
# I am not positive that other SVR4 systems won't match this,
# I just have to hope. -- rms.
# Use sysv4.2uw... so that sysv4* matches it.
- echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION}
+ echo "$UNAME_MACHINE"-pc-sysv4.2uw"$UNAME_VERSION"
exit ;;
i*86:OS/2:*:*)
# If we were able to find `uname', then EMX Unix compatibility
# is probably installed.
- echo ${UNAME_MACHINE}-pc-os2-emx
+ echo "$UNAME_MACHINE"-pc-os2-emx
exit ;;
i*86:XTS-300:*:STOP)
- echo ${UNAME_MACHINE}-unknown-stop
+ echo "$UNAME_MACHINE"-unknown-stop
exit ;;
i*86:atheos:*:*)
- echo ${UNAME_MACHINE}-unknown-atheos
+ echo "$UNAME_MACHINE"-unknown-atheos
exit ;;
i*86:syllable:*:*)
- echo ${UNAME_MACHINE}-pc-syllable
+ echo "$UNAME_MACHINE"-pc-syllable
exit ;;
i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*)
- echo i386-unknown-lynxos${UNAME_RELEASE}
+ echo i386-unknown-lynxos"$UNAME_RELEASE"
exit ;;
i*86:*DOS:*:*)
- echo ${UNAME_MACHINE}-pc-msdosdjgpp
+ echo "$UNAME_MACHINE"-pc-msdosdjgpp
exit ;;
i*86:*:4.*:*)
- UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'`
+ UNAME_REL=`echo "$UNAME_RELEASE" | sed 's/\/MP$//'`
if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then
- echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL}
+ echo "$UNAME_MACHINE"-univel-sysv"$UNAME_REL"
else
- echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL}
+ echo "$UNAME_MACHINE"-pc-sysv"$UNAME_REL"
fi
exit ;;
i*86:*:5:[678]*)
@@ -1093,12 +1141,12 @@ EOF
*Pentium) UNAME_MACHINE=i586 ;;
*Pent*|*Celeron) UNAME_MACHINE=i686 ;;
esac
- echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION}
+ echo "$UNAME_MACHINE-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION}"
exit ;;
i*86:*:3.2:*)
if test -f /usr/options/cb.name; then
UNAME_REL=`sed -n 's/.*Version //p' </usr/options/cb.name`
- echo ${UNAME_MACHINE}-pc-isc$UNAME_REL
+ echo "$UNAME_MACHINE"-pc-isc"$UNAME_REL"
elif /bin/uname -X 2>/dev/null >/dev/null ; then
UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')`
(/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486
@@ -1108,9 +1156,9 @@ EOF
&& UNAME_MACHINE=i686
(/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \
&& UNAME_MACHINE=i686
- echo ${UNAME_MACHINE}-pc-sco$UNAME_REL
+ echo "$UNAME_MACHINE"-pc-sco"$UNAME_REL"
else
- echo ${UNAME_MACHINE}-pc-sysv32
+ echo "$UNAME_MACHINE"-pc-sysv32
fi
exit ;;
pc:*:*:*)
@@ -1130,9 +1178,9 @@ EOF
exit ;;
i860:*:4.*:*) # i860-SVR4
if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then
- echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4
+ echo i860-stardent-sysv"$UNAME_RELEASE" # Stardent Vistra i860-SVR4
else # Add other i860-SVR4 vendors below as they are discovered.
- echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4
+ echo i860-unknown-sysv"$UNAME_RELEASE" # Unknown i860-SVR4
fi
exit ;;
mini*:CTIX:SYS*5:*)
@@ -1152,9 +1200,9 @@ EOF
test -r /etc/.relid \
&& OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid`
/bin/uname -p 2>/dev/null | grep 86 >/dev/null \
- && { echo i486-ncr-sysv4.3${OS_REL}; exit; }
+ && { echo i486-ncr-sysv4.3"$OS_REL"; exit; }
/bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \
- && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;;
+ && { echo i586-ncr-sysv4.3"$OS_REL"; exit; } ;;
3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*)
/bin/uname -p 2>/dev/null | grep 86 >/dev/null \
&& { echo i486-ncr-sysv4; exit; } ;;
@@ -1163,28 +1211,28 @@ EOF
test -r /etc/.relid \
&& OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid`
/bin/uname -p 2>/dev/null | grep 86 >/dev/null \
- && { echo i486-ncr-sysv4.3${OS_REL}; exit; }
+ && { echo i486-ncr-sysv4.3"$OS_REL"; exit; }
/bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \
- && { echo i586-ncr-sysv4.3${OS_REL}; exit; }
+ && { echo i586-ncr-sysv4.3"$OS_REL"; exit; }
/bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \
- && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;;
+ && { echo i586-ncr-sysv4.3"$OS_REL"; exit; } ;;
m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*)
- echo m68k-unknown-lynxos${UNAME_RELEASE}
+ echo m68k-unknown-lynxos"$UNAME_RELEASE"
exit ;;
mc68030:UNIX_System_V:4.*:*)
echo m68k-atari-sysv4
exit ;;
TSUNAMI:LynxOS:2.*:*)
- echo sparc-unknown-lynxos${UNAME_RELEASE}
+ echo sparc-unknown-lynxos"$UNAME_RELEASE"
exit ;;
rs6000:LynxOS:2.*:*)
- echo rs6000-unknown-lynxos${UNAME_RELEASE}
+ echo rs6000-unknown-lynxos"$UNAME_RELEASE"
exit ;;
PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*)
- echo powerpc-unknown-lynxos${UNAME_RELEASE}
+ echo powerpc-unknown-lynxos"$UNAME_RELEASE"
exit ;;
SM[BE]S:UNIX_SV:*:*)
- echo mips-dde-sysv${UNAME_RELEASE}
+ echo mips-dde-sysv"$UNAME_RELEASE"
exit ;;
RM*:ReliantUNIX-*:*:*)
echo mips-sni-sysv4
@@ -1195,7 +1243,7 @@ EOF
*:SINIX-*:*:*)
if uname -p 2>/dev/null >/dev/null ; then
UNAME_MACHINE=`(uname -p) 2>/dev/null`
- echo ${UNAME_MACHINE}-sni-sysv4
+ echo "$UNAME_MACHINE"-sni-sysv4
else
echo ns32k-sni-sysv
fi
@@ -1215,23 +1263,23 @@ EOF
exit ;;
i*86:VOS:*:*)
# From Paul.Green@stratus.com.
- echo ${UNAME_MACHINE}-stratus-vos
+ echo "$UNAME_MACHINE"-stratus-vos
exit ;;
*:VOS:*:*)
# From Paul.Green@stratus.com.
echo hppa1.1-stratus-vos
exit ;;
mc68*:A/UX:*:*)
- echo m68k-apple-aux${UNAME_RELEASE}
+ echo m68k-apple-aux"$UNAME_RELEASE"
exit ;;
news*:NEWS-OS:6*:*)
echo mips-sony-newsos6
exit ;;
R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*)
if [ -d /usr/nec ]; then
- echo mips-nec-sysv${UNAME_RELEASE}
+ echo mips-nec-sysv"$UNAME_RELEASE"
else
- echo mips-unknown-sysv${UNAME_RELEASE}
+ echo mips-unknown-sysv"$UNAME_RELEASE"
fi
exit ;;
BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only.
@@ -1250,39 +1298,39 @@ EOF
echo x86_64-unknown-haiku
exit ;;
SX-4:SUPER-UX:*:*)
- echo sx4-nec-superux${UNAME_RELEASE}
+ echo sx4-nec-superux"$UNAME_RELEASE"
exit ;;
SX-5:SUPER-UX:*:*)
- echo sx5-nec-superux${UNAME_RELEASE}
+ echo sx5-nec-superux"$UNAME_RELEASE"
exit ;;
SX-6:SUPER-UX:*:*)
- echo sx6-nec-superux${UNAME_RELEASE}
+ echo sx6-nec-superux"$UNAME_RELEASE"
exit ;;
SX-7:SUPER-UX:*:*)
- echo sx7-nec-superux${UNAME_RELEASE}
+ echo sx7-nec-superux"$UNAME_RELEASE"
exit ;;
SX-8:SUPER-UX:*:*)
- echo sx8-nec-superux${UNAME_RELEASE}
+ echo sx8-nec-superux"$UNAME_RELEASE"
exit ;;
SX-8R:SUPER-UX:*:*)
- echo sx8r-nec-superux${UNAME_RELEASE}
+ echo sx8r-nec-superux"$UNAME_RELEASE"
exit ;;
SX-ACE:SUPER-UX:*:*)
- echo sxace-nec-superux${UNAME_RELEASE}
+ echo sxace-nec-superux"$UNAME_RELEASE"
exit ;;
Power*:Rhapsody:*:*)
- echo powerpc-apple-rhapsody${UNAME_RELEASE}
+ echo powerpc-apple-rhapsody"$UNAME_RELEASE"
exit ;;
*:Rhapsody:*:*)
- echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE}
+ echo "$UNAME_MACHINE"-apple-rhapsody"$UNAME_RELEASE"
exit ;;
*:Darwin:*:*)
UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown
- eval $set_cc_for_build
+ set_cc_for_build
if test "$UNAME_PROCESSOR" = unknown ; then
UNAME_PROCESSOR=powerpc
fi
- if test `echo "$UNAME_RELEASE" | sed -e 's/\..*//'` -le 10 ; then
+ if test "`echo "$UNAME_RELEASE" | sed -e 's/\..*//'`" -le 10 ; then
if [ "$CC_FOR_BUILD" != no_compiler_found ]; then
if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \
(CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \
@@ -1310,7 +1358,7 @@ EOF
# that Apple uses in portable devices.
UNAME_PROCESSOR=x86_64
fi
- echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE}
+ echo "$UNAME_PROCESSOR"-apple-darwin"$UNAME_RELEASE"
exit ;;
*:procnto*:*:* | *:QNX:[0123456789]*:*)
UNAME_PROCESSOR=`uname -p`
@@ -1318,22 +1366,25 @@ EOF
UNAME_PROCESSOR=i386
UNAME_MACHINE=pc
fi
- echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE}
+ echo "$UNAME_PROCESSOR"-"$UNAME_MACHINE"-nto-qnx"$UNAME_RELEASE"
exit ;;
*:QNX:*:4*)
echo i386-pc-qnx
exit ;;
NEO-*:NONSTOP_KERNEL:*:*)
- echo neo-tandem-nsk${UNAME_RELEASE}
+ echo neo-tandem-nsk"$UNAME_RELEASE"
exit ;;
NSE-*:NONSTOP_KERNEL:*:*)
- echo nse-tandem-nsk${UNAME_RELEASE}
+ echo nse-tandem-nsk"$UNAME_RELEASE"
exit ;;
NSR-*:NONSTOP_KERNEL:*:*)
- echo nsr-tandem-nsk${UNAME_RELEASE}
+ echo nsr-tandem-nsk"$UNAME_RELEASE"
+ exit ;;
+ NSV-*:NONSTOP_KERNEL:*:*)
+ echo nsv-tandem-nsk"$UNAME_RELEASE"
exit ;;
NSX-*:NONSTOP_KERNEL:*:*)
- echo nsx-tandem-nsk${UNAME_RELEASE}
+ echo nsx-tandem-nsk"$UNAME_RELEASE"
exit ;;
*:NonStop-UX:*:*)
echo mips-compaq-nonstopux
@@ -1342,18 +1393,19 @@ EOF
echo bs2000-siemens-sysv
exit ;;
DS/*:UNIX_System_V:*:*)
- echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE}
+ echo "$UNAME_MACHINE"-"$UNAME_SYSTEM"-"$UNAME_RELEASE"
exit ;;
*:Plan9:*:*)
# "uname -m" is not consistent, so use $cputype instead. 386
# is converted to i386 for consistency with other x86
# operating systems.
+ # shellcheck disable=SC2154
if test "$cputype" = 386; then
UNAME_MACHINE=i386
else
UNAME_MACHINE="$cputype"
fi
- echo ${UNAME_MACHINE}-unknown-plan9
+ echo "$UNAME_MACHINE"-unknown-plan9
exit ;;
*:TOPS-10:*:*)
echo pdp10-unknown-tops10
@@ -1374,14 +1426,14 @@ EOF
echo pdp10-unknown-its
exit ;;
SEI:*:*:SEIUX)
- echo mips-sei-seiux${UNAME_RELEASE}
+ echo mips-sei-seiux"$UNAME_RELEASE"
exit ;;
*:DragonFly:*:*)
- echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`
+ echo "$UNAME_MACHINE"-unknown-dragonfly"`echo "$UNAME_RELEASE"|sed -e 's/[-(].*//'`"
exit ;;
*:*VMS:*:*)
UNAME_MACHINE=`(uname -p) 2>/dev/null`
- case "${UNAME_MACHINE}" in
+ case "$UNAME_MACHINE" in
A*) echo alpha-dec-vms ; exit ;;
I*) echo ia64-dec-vms ; exit ;;
V*) echo vax-dec-vms ; exit ;;
@@ -1390,25 +1442,152 @@ EOF
echo i386-pc-xenix
exit ;;
i*86:skyos:*:*)
- echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE} | sed -e 's/ .*$//'`
+ echo "$UNAME_MACHINE"-pc-skyos"`echo "$UNAME_RELEASE" | sed -e 's/ .*$//'`"
exit ;;
i*86:rdos:*:*)
- echo ${UNAME_MACHINE}-pc-rdos
+ echo "$UNAME_MACHINE"-pc-rdos
exit ;;
i*86:AROS:*:*)
- echo ${UNAME_MACHINE}-pc-aros
+ echo "$UNAME_MACHINE"-pc-aros
exit ;;
x86_64:VMkernel:*:*)
- echo ${UNAME_MACHINE}-unknown-esx
+ echo "$UNAME_MACHINE"-unknown-esx
exit ;;
amd64:Isilon\ OneFS:*:*)
echo x86_64-unknown-onefs
exit ;;
+ *:Unleashed:*:*)
+ echo "$UNAME_MACHINE"-unknown-unleashed"$UNAME_RELEASE"
+ exit ;;
esac
+# No uname command or uname output not recognized.
+set_cc_for_build
+cat > "$dummy.c" <<EOF
+#ifdef _SEQUENT_
+#include <sys/types.h>
+#include <sys/utsname.h>
+#endif
+main ()
+{
+#if defined (sony)
+#if defined (MIPSEB)
+ /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed,
+ I don't know.... */
+ printf ("mips-sony-bsd\n"); exit (0);
+#else
+#include <sys/param.h>
+ printf ("m68k-sony-newsos%s\n",
+#ifdef NEWSOS4
+ "4"
+#else
+ ""
+#endif
+ ); exit (0);
+#endif
+#endif
+
+#if defined (NeXT)
+#if !defined (__ARCHITECTURE__)
+#define __ARCHITECTURE__ "m68k"
+#endif
+ int version;
+ version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`;
+ if (version < 4)
+ printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version);
+ else
+ printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version);
+ exit (0);
+#endif
+
+#if defined (MULTIMAX) || defined (n16)
+#if defined (UMAXV)
+ printf ("ns32k-encore-sysv\n"); exit (0);
+#else
+#if defined (CMU)
+ printf ("ns32k-encore-mach\n"); exit (0);
+#else
+ printf ("ns32k-encore-bsd\n"); exit (0);
+#endif
+#endif
+#endif
+
+#if defined (__386BSD__)
+ printf ("i386-pc-bsd\n"); exit (0);
+#endif
+
+#if defined (sequent)
+#if defined (i386)
+ printf ("i386-sequent-dynix\n"); exit (0);
+#endif
+#if defined (ns32000)
+ printf ("ns32k-sequent-dynix\n"); exit (0);
+#endif
+#endif
+
+#if defined (_SEQUENT_)
+ struct utsname un;
+
+ uname(&un);
+ if (strncmp(un.version, "V2", 2) == 0) {
+ printf ("i386-sequent-ptx2\n"); exit (0);
+ }
+ if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */
+ printf ("i386-sequent-ptx1\n"); exit (0);
+ }
+ printf ("i386-sequent-ptx\n"); exit (0);
+#endif
+
+#if defined (vax)
+#if !defined (ultrix)
+#include <sys/param.h>
+#if defined (BSD)
+#if BSD == 43
+ printf ("vax-dec-bsd4.3\n"); exit (0);
+#else
+#if BSD == 199006
+ printf ("vax-dec-bsd4.3reno\n"); exit (0);
+#else
+ printf ("vax-dec-bsd\n"); exit (0);
+#endif
+#endif
+#else
+ printf ("vax-dec-bsd\n"); exit (0);
+#endif
+#else
+ printf ("vax-dec-ultrix\n"); exit (0);
+#endif
+#endif
+#if defined(ultrix) || defined(_ultrix) || defined(__ultrix) || defined(__ultrix__)
+#if defined(mips) || defined(__mips) || defined(__mips__) || defined(MIPS) || defined(__MIPS__)
+#include <signal.h>
+#if defined(_SIZE_T_) /* >= ULTRIX4 */
+ printf ("mips-dec-ultrix4\n"); exit (0);
+#else
+#if defined(ULTRIX3) || defined(ultrix3) || defined(SIGLOST)
+ printf ("mips-dec-ultrix3\n"); exit (0);
+#endif
+#endif
+#endif
+#endif
+
+#if defined (alliant) && defined (i860)
+ printf ("i860-alliant-bsd\n"); exit (0);
+#endif
+
+ exit (1);
+}
+EOF
+
+$CC_FOR_BUILD -o "$dummy" "$dummy.c" 2>/dev/null && SYSTEM_NAME=`$dummy` &&
+ { echo "$SYSTEM_NAME"; exit; }
+
+# Apollos put the system type in the environment.
+test -d /usr/apollo && { echo "$ISP-apollo-$SYSTYPE"; exit; }
+
echo "$0: unable to guess system type" >&2
-case "${UNAME_MACHINE}:${UNAME_SYSTEM}" in
+case "$UNAME_MACHINE:$UNAME_SYSTEM" in
mips:Linux | mips64:Linux)
# If we got here on MIPS GNU/Linux, output extra information.
cat >&2 <<EOF
@@ -1450,16 +1629,16 @@ hostinfo = `(hostinfo) 2>/dev/null`
/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null`
/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null`
-UNAME_MACHINE = ${UNAME_MACHINE}
-UNAME_RELEASE = ${UNAME_RELEASE}
-UNAME_SYSTEM = ${UNAME_SYSTEM}
-UNAME_VERSION = ${UNAME_VERSION}
+UNAME_MACHINE = "$UNAME_MACHINE"
+UNAME_RELEASE = "$UNAME_RELEASE"
+UNAME_SYSTEM = "$UNAME_SYSTEM"
+UNAME_VERSION = "$UNAME_VERSION"
EOF
exit 1
# Local variables:
-# eval: (add-hook 'write-file-functions 'time-stamp)
+# eval: (add-hook 'before-save-hook 'time-stamp)
# time-stamp-start: "timestamp='"
# time-stamp-format: "%:y-%02m-%02d"
# time-stamp-end: "'"
diff --git a/build-aux/config.sub b/build-aux/config.sub
index cb90ee49099..3b4c7624b68 100755
--- a/build-aux/config.sub
+++ b/build-aux/config.sub
@@ -2,7 +2,7 @@
# Configuration validation subroutine script.
# Copyright 1992-2019 Free Software Foundation, Inc.
-timestamp='2018-01-01'
+timestamp='2019-01-05'
# 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
@@ -89,12 +89,12 @@ while test $# -gt 0 ; do
- ) # Use stdin as input.
break ;;
-* )
- echo "$me: invalid option $1$help"
+ echo "$me: invalid option $1$help" >&2
exit 1 ;;
*local*)
# First pass through any local machine types.
- echo $1
+ echo "$1"
exit ;;
* )
@@ -110,1251 +110,1164 @@ case $# in
exit 1;;
esac
-# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any).
-# Here we must recognize all the valid KERNEL-OS combinations.
-maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'`
-case $maybe_os in
- nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc | linux-newlib* | \
- linux-musl* | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \
- knetbsd*-gnu* | netbsd*-gnu* | netbsd*-eabi* | \
- kopensolaris*-gnu* | cloudabi*-eabi* | \
- storm-chaos* | os2-emx* | rtmk-nova*)
- os=-$maybe_os
- basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`
- ;;
- android-linux)
- os=-linux-android
- basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`-unknown
- ;;
- *)
- basic_machine=`echo $1 | sed 's/-[^-]*$//'`
- if [ $basic_machine != $1 ]
- then os=`echo $1 | sed 's/.*-/-/'`
- else os=; fi
- ;;
-esac
+# Split fields of configuration type
+# shellcheck disable=SC2162
+IFS="-" read field1 field2 field3 field4 <<EOF
+$1
+EOF
-### Let's recognize common machines as not being operating systems so
-### that things like config.sub decstation-3100 work. We also
-### recognize some manufacturers as not being operating systems, so we
-### can provide default operating systems below.
-case $os in
- -sun*os*)
- # Prevent following clause from handling this invalid input.
- ;;
- -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \
- -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \
- -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \
- -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\
- -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \
- -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \
- -apple | -axis | -knuth | -cray | -microblaze*)
- os=
- basic_machine=$1
- ;;
- -bluegene*)
- os=-cnk
- ;;
- -sim | -cisco | -oki | -wec | -winbond)
- os=
- basic_machine=$1
- ;;
- -scout)
- ;;
- -wrs)
- os=-vxworks
- basic_machine=$1
- ;;
- -chorusos*)
- os=-chorusos
- basic_machine=$1
- ;;
- -chorusrdb)
- os=-chorusrdb
- basic_machine=$1
- ;;
- -hiux*)
- os=-hiuxwe2
- ;;
- -sco6)
- os=-sco5v6
- basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
- ;;
- -sco5)
- os=-sco3.2v5
- basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
- ;;
- -sco4)
- os=-sco3.2v4
- basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
- ;;
- -sco3.2.[4-9]*)
- os=`echo $os | sed -e 's/sco3.2./sco3.2v/'`
- basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
- ;;
- -sco3.2v[4-9]*)
- # Don't forget version if it is 3.2v4 or newer.
- basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
- ;;
- -sco5v6*)
- # Don't forget version if it is 3.2v4 or newer.
- basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
- ;;
- -sco*)
- os=-sco3.2v2
- basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
- ;;
- -udk*)
- basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
- ;;
- -isc)
- os=-isc2.2
- basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
- ;;
- -clix*)
- basic_machine=clipper-intergraph
- ;;
- -isc*)
- basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
- ;;
- -lynx*178)
- os=-lynxos178
- ;;
- -lynx*5)
- os=-lynxos5
+# Separate into logical components for further validation
+case $1 in
+ *-*-*-*-*)
+ echo Invalid configuration \`"$1"\': more than four components >&2
+ exit 1
;;
- -lynx*)
- os=-lynxos
+ *-*-*-*)
+ basic_machine=$field1-$field2
+ os=$field3-$field4
;;
- -ptx*)
- basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'`
+ *-*-*)
+ # Ambiguous whether COMPANY is present, or skipped and KERNEL-OS is two
+ # parts
+ maybe_os=$field2-$field3
+ case $maybe_os in
+ nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc \
+ | linux-newlib* | linux-musl* | linux-uclibc* | uclinux-uclibc* \
+ | uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* \
+ | netbsd*-eabi* | kopensolaris*-gnu* | cloudabi*-eabi* \
+ | storm-chaos* | os2-emx* | rtmk-nova*)
+ basic_machine=$field1
+ os=$maybe_os
+ ;;
+ android-linux)
+ basic_machine=$field1-unknown
+ os=linux-android
+ ;;
+ *)
+ basic_machine=$field1-$field2
+ os=$field3
+ ;;
+ esac
;;
- -psos*)
- os=-psos
+ *-*)
+ # A lone config we happen to match not fitting any pattern
+ case $field1-$field2 in
+ decstation-3100)
+ basic_machine=mips-dec
+ os=
+ ;;
+ *-*)
+ # Second component is usually, but not always the OS
+ case $field2 in
+ # Prevent following clause from handling this valid os
+ sun*os*)
+ basic_machine=$field1
+ os=$field2
+ ;;
+ # Manufacturers
+ dec* | mips* | sequent* | encore* | pc533* | sgi* | sony* \
+ | att* | 7300* | 3300* | delta* | motorola* | sun[234]* \
+ | unicom* | ibm* | next | hp | isi* | apollo | altos* \
+ | convergent* | ncr* | news | 32* | 3600* | 3100* \
+ | hitachi* | c[123]* | convex* | sun | crds | omron* | dg \
+ | ultra | tti* | harris | dolphin | highlevel | gould \
+ | cbm | ns | masscomp | apple | axis | knuth | cray \
+ | microblaze* | sim | cisco \
+ | oki | wec | wrs | winbond)
+ basic_machine=$field1-$field2
+ os=
+ ;;
+ *)
+ basic_machine=$field1
+ os=$field2
+ ;;
+ esac
+ ;;
+ esac
;;
- -mint | -mint[0-9]*)
- basic_machine=m68k-atari
- os=-mint
+ *)
+ # Convert single-component short-hands not valid as part of
+ # multi-component configurations.
+ case $field1 in
+ 386bsd)
+ basic_machine=i386-pc
+ os=bsd
+ ;;
+ a29khif)
+ basic_machine=a29k-amd
+ os=udi
+ ;;
+ adobe68k)
+ basic_machine=m68010-adobe
+ os=scout
+ ;;
+ alliant)
+ basic_machine=fx80-alliant
+ os=
+ ;;
+ altos | altos3068)
+ basic_machine=m68k-altos
+ os=
+ ;;
+ am29k)
+ basic_machine=a29k-none
+ os=bsd
+ ;;
+ amdahl)
+ basic_machine=580-amdahl
+ os=sysv
+ ;;
+ amiga)
+ basic_machine=m68k-unknown
+ os=
+ ;;
+ amigaos | amigados)
+ basic_machine=m68k-unknown
+ os=amigaos
+ ;;
+ amigaunix | amix)
+ basic_machine=m68k-unknown
+ os=sysv4
+ ;;
+ apollo68)
+ basic_machine=m68k-apollo
+ os=sysv
+ ;;
+ apollo68bsd)
+ basic_machine=m68k-apollo
+ os=bsd
+ ;;
+ aros)
+ basic_machine=i386-pc
+ os=aros
+ ;;
+ aux)
+ basic_machine=m68k-apple
+ os=aux
+ ;;
+ balance)
+ basic_machine=ns32k-sequent
+ os=dynix
+ ;;
+ blackfin)
+ basic_machine=bfin-unknown
+ os=linux
+ ;;
+ cegcc)
+ basic_machine=arm-unknown
+ os=cegcc
+ ;;
+ convex-c1)
+ basic_machine=c1-convex
+ os=bsd
+ ;;
+ convex-c2)
+ basic_machine=c2-convex
+ os=bsd
+ ;;
+ convex-c32)
+ basic_machine=c32-convex
+ os=bsd
+ ;;
+ convex-c34)
+ basic_machine=c34-convex
+ os=bsd
+ ;;
+ convex-c38)
+ basic_machine=c38-convex
+ os=bsd
+ ;;
+ cray)
+ basic_machine=j90-cray
+ os=unicos
+ ;;
+ crds | unos)
+ basic_machine=m68k-crds
+ os=
+ ;;
+ da30)
+ basic_machine=m68k-da30
+ os=
+ ;;
+ decstation | pmax | pmin | dec3100 | decstatn)
+ basic_machine=mips-dec
+ os=
+ ;;
+ delta88)
+ basic_machine=m88k-motorola
+ os=sysv3
+ ;;
+ dicos)
+ basic_machine=i686-pc
+ os=dicos
+ ;;
+ djgpp)
+ basic_machine=i586-pc
+ os=msdosdjgpp
+ ;;
+ ebmon29k)
+ basic_machine=a29k-amd
+ os=ebmon
+ ;;
+ es1800 | OSE68k | ose68k | ose | OSE)
+ basic_machine=m68k-ericsson
+ os=ose
+ ;;
+ gmicro)
+ basic_machine=tron-gmicro
+ os=sysv
+ ;;
+ go32)
+ basic_machine=i386-pc
+ os=go32
+ ;;
+ h8300hms)
+ basic_machine=h8300-hitachi
+ os=hms
+ ;;
+ h8300xray)
+ basic_machine=h8300-hitachi
+ os=xray
+ ;;
+ h8500hms)
+ basic_machine=h8500-hitachi
+ os=hms
+ ;;
+ harris)
+ basic_machine=m88k-harris
+ os=sysv3
+ ;;
+ hp300)
+ basic_machine=m68k-hp
+ ;;
+ hp300bsd)
+ basic_machine=m68k-hp
+ os=bsd
+ ;;
+ hp300hpux)
+ basic_machine=m68k-hp
+ os=hpux
+ ;;
+ hppaosf)
+ basic_machine=hppa1.1-hp
+ os=osf
+ ;;
+ hppro)
+ basic_machine=hppa1.1-hp
+ os=proelf
+ ;;
+ i386mach)
+ basic_machine=i386-mach
+ os=mach
+ ;;
+ vsta)
+ basic_machine=i386-pc
+ os=vsta
+ ;;
+ isi68 | isi)
+ basic_machine=m68k-isi
+ os=sysv
+ ;;
+ m68knommu)
+ basic_machine=m68k-unknown
+ os=linux
+ ;;
+ magnum | m3230)
+ basic_machine=mips-mips
+ os=sysv
+ ;;
+ merlin)
+ basic_machine=ns32k-utek
+ os=sysv
+ ;;
+ mingw64)
+ basic_machine=x86_64-pc
+ os=mingw64
+ ;;
+ mingw32)
+ basic_machine=i686-pc
+ os=mingw32
+ ;;
+ mingw32ce)
+ basic_machine=arm-unknown
+ os=mingw32ce
+ ;;
+ monitor)
+ basic_machine=m68k-rom68k
+ os=coff
+ ;;
+ morphos)
+ basic_machine=powerpc-unknown
+ os=morphos
+ ;;
+ moxiebox)
+ basic_machine=moxie-unknown
+ os=moxiebox
+ ;;
+ msdos)
+ basic_machine=i386-pc
+ os=msdos
+ ;;
+ msys)
+ basic_machine=i686-pc
+ os=msys
+ ;;
+ mvs)
+ basic_machine=i370-ibm
+ os=mvs
+ ;;
+ nacl)
+ basic_machine=le32-unknown
+ os=nacl
+ ;;
+ ncr3000)
+ basic_machine=i486-ncr
+ os=sysv4
+ ;;
+ netbsd386)
+ basic_machine=i386-pc
+ os=netbsd
+ ;;
+ netwinder)
+ basic_machine=armv4l-rebel
+ os=linux
+ ;;
+ news | news700 | news800 | news900)
+ basic_machine=m68k-sony
+ os=newsos
+ ;;
+ news1000)
+ basic_machine=m68030-sony
+ os=newsos
+ ;;
+ necv70)
+ basic_machine=v70-nec
+ os=sysv
+ ;;
+ nh3000)
+ basic_machine=m68k-harris
+ os=cxux
+ ;;
+ nh[45]000)
+ basic_machine=m88k-harris
+ os=cxux
+ ;;
+ nindy960)
+ basic_machine=i960-intel
+ os=nindy
+ ;;
+ mon960)
+ basic_machine=i960-intel
+ os=mon960
+ ;;
+ nonstopux)
+ basic_machine=mips-compaq
+ os=nonstopux
+ ;;
+ os400)
+ basic_machine=powerpc-ibm
+ os=os400
+ ;;
+ OSE68000 | ose68000)
+ basic_machine=m68000-ericsson
+ os=ose
+ ;;
+ os68k)
+ basic_machine=m68k-none
+ os=os68k
+ ;;
+ paragon)
+ basic_machine=i860-intel
+ os=osf
+ ;;
+ parisc)
+ basic_machine=hppa-unknown
+ os=linux
+ ;;
+ pw32)
+ basic_machine=i586-unknown
+ os=pw32
+ ;;
+ rdos | rdos64)
+ basic_machine=x86_64-pc
+ os=rdos
+ ;;
+ rdos32)
+ basic_machine=i386-pc
+ os=rdos
+ ;;
+ rom68k)
+ basic_machine=m68k-rom68k
+ os=coff
+ ;;
+ sa29200)
+ basic_machine=a29k-amd
+ os=udi
+ ;;
+ sei)
+ basic_machine=mips-sei
+ os=seiux
+ ;;
+ sequent)
+ basic_machine=i386-sequent
+ os=
+ ;;
+ sps7)
+ basic_machine=m68k-bull
+ os=sysv2
+ ;;
+ st2000)
+ basic_machine=m68k-tandem
+ os=
+ ;;
+ stratus)
+ basic_machine=i860-stratus
+ os=sysv4
+ ;;
+ sun2)
+ basic_machine=m68000-sun
+ os=
+ ;;
+ sun2os3)
+ basic_machine=m68000-sun
+ os=sunos3
+ ;;
+ sun2os4)
+ basic_machine=m68000-sun
+ os=sunos4
+ ;;
+ sun3)
+ basic_machine=m68k-sun
+ os=
+ ;;
+ sun3os3)
+ basic_machine=m68k-sun
+ os=sunos3
+ ;;
+ sun3os4)
+ basic_machine=m68k-sun
+ os=sunos4
+ ;;
+ sun4)
+ basic_machine=sparc-sun
+ os=
+ ;;
+ sun4os3)
+ basic_machine=sparc-sun
+ os=sunos3
+ ;;
+ sun4os4)
+ basic_machine=sparc-sun
+ os=sunos4
+ ;;
+ sun4sol2)
+ basic_machine=sparc-sun
+ os=solaris2
+ ;;
+ sun386 | sun386i | roadrunner)
+ basic_machine=i386-sun
+ os=
+ ;;
+ sv1)
+ basic_machine=sv1-cray
+ os=unicos
+ ;;
+ symmetry)
+ basic_machine=i386-sequent
+ os=dynix
+ ;;
+ t3e)
+ basic_machine=alphaev5-cray
+ os=unicos
+ ;;
+ t90)
+ basic_machine=t90-cray
+ os=unicos
+ ;;
+ toad1)
+ basic_machine=pdp10-xkl
+ os=tops20
+ ;;
+ tpf)
+ basic_machine=s390x-ibm
+ os=tpf
+ ;;
+ udi29k)
+ basic_machine=a29k-amd
+ os=udi
+ ;;
+ ultra3)
+ basic_machine=a29k-nyu
+ os=sym1
+ ;;
+ v810 | necv810)
+ basic_machine=v810-nec
+ os=none
+ ;;
+ vaxv)
+ basic_machine=vax-dec
+ os=sysv
+ ;;
+ vms)
+ basic_machine=vax-dec
+ os=vms
+ ;;
+ vxworks960)
+ basic_machine=i960-wrs
+ os=vxworks
+ ;;
+ vxworks68)
+ basic_machine=m68k-wrs
+ os=vxworks
+ ;;
+ vxworks29k)
+ basic_machine=a29k-wrs
+ os=vxworks
+ ;;
+ xbox)
+ basic_machine=i686-pc
+ os=mingw32
+ ;;
+ ymp)
+ basic_machine=ymp-cray
+ os=unicos
+ ;;
+ *)
+ basic_machine=$1
+ os=
+ ;;
+ esac
;;
esac
-# Decode aliases for certain CPU-COMPANY combinations.
+# Decode 1-component or ad-hoc basic machines
case $basic_machine in
- # Recognize the basic CPU types without company name.
- # Some are omitted here because they have special meanings below.
- 1750a | 580 \
- | a29k \
- | aarch64 | aarch64_be \
- | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \
- | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \
- | am33_2.0 \
- | arc | arceb \
- | arm | arm[bl]e | arme[lb] | armv[2-8] | armv[3-8][lb] | armv7[arm] \
- | avr | avr32 \
- | ba \
- | be32 | be64 \
- | bfin \
- | c4x | c8051 | clipper \
- | d10v | d30v | dlx | dsp16xx \
- | e2k | epiphany \
- | fido | fr30 | frv | ft32 \
- | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \
- | hexagon \
- | i370 | i860 | i960 | ia16 | ia64 \
- | ip2k | iq2000 \
- | k1om \
- | le32 | le64 \
- | lm32 \
- | m32c | m32r | m32rle | m68000 | m68k | m88k \
- | maxq | mb | microblaze | microblazeel | mcore | mep | metag \
- | mips | mipsbe | mipseb | mipsel | mipsle \
- | mips16 \
- | mips64 | mips64el \
- | mips64octeon | mips64octeonel \
- | mips64orion | mips64orionel \
- | mips64r5900 | mips64r5900el \
- | mips64vr | mips64vrel \
- | mips64vr4100 | mips64vr4100el \
- | mips64vr4300 | mips64vr4300el \
- | mips64vr5000 | mips64vr5000el \
- | mips64vr5900 | mips64vr5900el \
- | mipsisa32 | mipsisa32el \
- | mipsisa32r2 | mipsisa32r2el \
- | mipsisa32r6 | mipsisa32r6el \
- | mipsisa64 | mipsisa64el \
- | mipsisa64r2 | mipsisa64r2el \
- | mipsisa64r6 | mipsisa64r6el \
- | mipsisa64sb1 | mipsisa64sb1el \
- | mipsisa64sr71k | mipsisa64sr71kel \
- | mipsr5900 | mipsr5900el \
- | mipstx39 | mipstx39el \
- | mn10200 | mn10300 \
- | moxie \
- | mt \
- | msp430 \
- | nds32 | nds32le | nds32be \
- | nios | nios2 | nios2eb | nios2el \
- | ns16k | ns32k \
- | open8 | or1k | or1knd | or32 \
- | pdp10 | pdp11 | pj | pjl \
- | powerpc | powerpc64 | powerpc64le | powerpcle \
- | pru \
- | pyramid \
- | riscv32 | riscv64 \
- | rl78 | rx \
- | score \
- | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[234]eb | sheb | shbe | shle | sh[1234]le | sh3ele \
- | sh64 | sh64le \
- | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \
- | sparcv8 | sparcv9 | sparcv9b | sparcv9v \
- | spu \
- | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \
- | ubicom32 \
- | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \
- | visium \
- | wasm32 \
- | x86 | xc16x | xstormy16 | xtensa \
- | z8k | z80)
- basic_machine=$basic_machine-unknown
- ;;
- c54x)
- basic_machine=tic54x-unknown
- ;;
- c55x)
- basic_machine=tic55x-unknown
- ;;
- c6x)
- basic_machine=tic6x-unknown
- ;;
- leon|leon[3-9])
- basic_machine=sparc-$basic_machine
- ;;
- m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | nvptx | picochip)
- basic_machine=$basic_machine-unknown
- os=-none
+ # Here we handle the default manufacturer of certain CPU types. It is in
+ # some cases the only manufacturer, in others, it is the most popular.
+ w89k)
+ cpu=hppa1.1
+ vendor=winbond
;;
- m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k)
+ op50n)
+ cpu=hppa1.1
+ vendor=oki
;;
- ms1)
- basic_machine=mt-unknown
+ op60c)
+ cpu=hppa1.1
+ vendor=oki
;;
-
- strongarm | thumb | xscale)
- basic_machine=arm-unknown
+ ibm*)
+ cpu=i370
+ vendor=ibm
;;
- xgate)
- basic_machine=$basic_machine-unknown
- os=-none
+ orion105)
+ cpu=clipper
+ vendor=highlevel
;;
- xscaleeb)
- basic_machine=armeb-unknown
+ mac | mpw | mac-mpw)
+ cpu=m68k
+ vendor=apple
;;
-
- xscaleel)
- basic_machine=armel-unknown
+ pmac | pmac-mpw)
+ cpu=powerpc
+ vendor=apple
;;
- # We use `pc' rather than `unknown'
- # because (1) that's what they normally are, and
- # (2) the word "unknown" tends to confuse beginning users.
- i*86 | x86_64)
- basic_machine=$basic_machine-pc
- ;;
- # Object if more than one company name word.
- *-*-*)
- echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
- exit 1
- ;;
- # Recognize the basic CPU types with company name.
- 580-* \
- | a29k-* \
- | aarch64-* | aarch64_be-* \
- | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \
- | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \
- | alphapca5[67]-* | alpha64pca5[67]-* | arc-* | arceb-* \
- | arm-* | armbe-* | armle-* | armeb-* | armv*-* \
- | avr-* | avr32-* \
- | ba-* \
- | be32-* | be64-* \
- | bfin-* | bs2000-* \
- | c[123]* | c30-* | [cjt]90-* | c4x-* \
- | c8051-* | clipper-* | craynv-* | cydra-* \
- | d10v-* | d30v-* | dlx-* \
- | e2k-* | elxsi-* \
- | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \
- | h8300-* | h8500-* \
- | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \
- | hexagon-* \
- | i*86-* | i860-* | i960-* | ia16-* | ia64-* \
- | ip2k-* | iq2000-* \
- | k1om-* \
- | le32-* | le64-* \
- | lm32-* \
- | m32c-* | m32r-* | m32rle-* \
- | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \
- | m88110-* | m88k-* | maxq-* | mcore-* | metag-* \
- | microblaze-* | microblazeel-* \
- | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \
- | mips16-* \
- | mips64-* | mips64el-* \
- | mips64octeon-* | mips64octeonel-* \
- | mips64orion-* | mips64orionel-* \
- | mips64r5900-* | mips64r5900el-* \
- | mips64vr-* | mips64vrel-* \
- | mips64vr4100-* | mips64vr4100el-* \
- | mips64vr4300-* | mips64vr4300el-* \
- | mips64vr5000-* | mips64vr5000el-* \
- | mips64vr5900-* | mips64vr5900el-* \
- | mipsisa32-* | mipsisa32el-* \
- | mipsisa32r2-* | mipsisa32r2el-* \
- | mipsisa32r6-* | mipsisa32r6el-* \
- | mipsisa64-* | mipsisa64el-* \
- | mipsisa64r2-* | mipsisa64r2el-* \
- | mipsisa64r6-* | mipsisa64r6el-* \
- | mipsisa64sb1-* | mipsisa64sb1el-* \
- | mipsisa64sr71k-* | mipsisa64sr71kel-* \
- | mipsr5900-* | mipsr5900el-* \
- | mipstx39-* | mipstx39el-* \
- | mmix-* \
- | mt-* \
- | msp430-* \
- | nds32-* | nds32le-* | nds32be-* \
- | nios-* | nios2-* | nios2eb-* | nios2el-* \
- | none-* | np1-* | ns16k-* | ns32k-* \
- | open8-* \
- | or1k*-* \
- | orion-* \
- | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \
- | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \
- | pru-* \
- | pyramid-* \
- | riscv32-* | riscv64-* \
- | rl78-* | romp-* | rs6000-* | rx-* \
- | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \
- | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \
- | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \
- | sparclite-* \
- | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx*-* \
- | tahoe-* \
- | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \
- | tile*-* \
- | tron-* \
- | ubicom32-* \
- | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \
- | vax-* \
- | visium-* \
- | wasm32-* \
- | we32k-* \
- | x86-* | x86_64-* | xc16x-* | xps100-* \
- | xstormy16-* | xtensa*-* \
- | ymp-* \
- | z8k-* | z80-*)
- ;;
- # Recognize the basic CPU types without company name, with glob match.
- xtensa*)
- basic_machine=$basic_machine-unknown
- ;;
# Recognize the various machine names and aliases which stand
# for a CPU type and a company and sometimes even an OS.
- 386bsd)
- basic_machine=i386-unknown
- os=-bsd
- ;;
3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc)
- basic_machine=m68000-att
+ cpu=m68000
+ vendor=att
;;
3b*)
- basic_machine=we32k-att
- ;;
- a29khif)
- basic_machine=a29k-amd
- os=-udi
- ;;
- abacus)
- basic_machine=abacus-unknown
- ;;
- adobe68k)
- basic_machine=m68010-adobe
- os=-scout
- ;;
- alliant | fx80)
- basic_machine=fx80-alliant
- ;;
- altos | altos3068)
- basic_machine=m68k-altos
- ;;
- am29k)
- basic_machine=a29k-none
- os=-bsd
- ;;
- amd64)
- basic_machine=x86_64-pc
- ;;
- amd64-*)
- basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'`
- ;;
- amdahl)
- basic_machine=580-amdahl
- os=-sysv
- ;;
- amiga | amiga-*)
- basic_machine=m68k-unknown
- ;;
- amigaos | amigados)
- basic_machine=m68k-unknown
- os=-amigaos
- ;;
- amigaunix | amix)
- basic_machine=m68k-unknown
- os=-sysv4
- ;;
- apollo68)
- basic_machine=m68k-apollo
- os=-sysv
- ;;
- apollo68bsd)
- basic_machine=m68k-apollo
- os=-bsd
- ;;
- aros)
- basic_machine=i386-pc
- os=-aros
- ;;
- asmjs)
- basic_machine=asmjs-unknown
- ;;
- aux)
- basic_machine=m68k-apple
- os=-aux
- ;;
- balance)
- basic_machine=ns32k-sequent
- os=-dynix
- ;;
- blackfin)
- basic_machine=bfin-unknown
- os=-linux
- ;;
- blackfin-*)
- basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'`
- os=-linux
+ cpu=we32k
+ vendor=att
;;
bluegene*)
- basic_machine=powerpc-ibm
- os=-cnk
- ;;
- c54x-*)
- basic_machine=tic54x-`echo $basic_machine | sed 's/^[^-]*-//'`
- ;;
- c55x-*)
- basic_machine=tic55x-`echo $basic_machine | sed 's/^[^-]*-//'`
- ;;
- c6x-*)
- basic_machine=tic6x-`echo $basic_machine | sed 's/^[^-]*-//'`
- ;;
- c90)
- basic_machine=c90-cray
- os=-unicos
- ;;
- cegcc)
- basic_machine=arm-unknown
- os=-cegcc
- ;;
- convex-c1)
- basic_machine=c1-convex
- os=-bsd
- ;;
- convex-c2)
- basic_machine=c2-convex
- os=-bsd
- ;;
- convex-c32)
- basic_machine=c32-convex
- os=-bsd
- ;;
- convex-c34)
- basic_machine=c34-convex
- os=-bsd
- ;;
- convex-c38)
- basic_machine=c38-convex
- os=-bsd
- ;;
- cray | j90)
- basic_machine=j90-cray
- os=-unicos
- ;;
- craynv)
- basic_machine=craynv-cray
- os=-unicosmp
- ;;
- cr16 | cr16-*)
- basic_machine=cr16-unknown
- os=-elf
- ;;
- crds | unos)
- basic_machine=m68k-crds
- ;;
- crisv32 | crisv32-* | etraxfs*)
- basic_machine=crisv32-axis
- ;;
- cris | cris-* | etrax*)
- basic_machine=cris-axis
- ;;
- crx)
- basic_machine=crx-unknown
- os=-elf
- ;;
- da30 | da30-*)
- basic_machine=m68k-da30
- ;;
- decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn)
- basic_machine=mips-dec
+ cpu=powerpc
+ vendor=ibm
+ os=cnk
;;
decsystem10* | dec10*)
- basic_machine=pdp10-dec
- os=-tops10
+ cpu=pdp10
+ vendor=dec
+ os=tops10
;;
decsystem20* | dec20*)
- basic_machine=pdp10-dec
- os=-tops20
+ cpu=pdp10
+ vendor=dec
+ os=tops20
;;
delta | 3300 | motorola-3300 | motorola-delta \
| 3300-motorola | delta-motorola)
- basic_machine=m68k-motorola
- ;;
- delta88)
- basic_machine=m88k-motorola
- os=-sysv3
- ;;
- dicos)
- basic_machine=i686-pc
- os=-dicos
- ;;
- djgpp)
- basic_machine=i586-pc
- os=-msdosdjgpp
- ;;
- dpx20 | dpx20-*)
- basic_machine=rs6000-bull
- os=-bosx
+ cpu=m68k
+ vendor=motorola
;;
dpx2*)
- basic_machine=m68k-bull
- os=-sysv3
- ;;
- e500v[12])
- basic_machine=powerpc-unknown
- os=$os"spe"
- ;;
- e500v[12]-*)
- basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'`
- os=$os"spe"
- ;;
- ebmon29k)
- basic_machine=a29k-amd
- os=-ebmon
- ;;
- elxsi)
- basic_machine=elxsi-elxsi
- os=-bsd
+ cpu=m68k
+ vendor=bull
+ os=sysv3
;;
encore | umax | mmax)
- basic_machine=ns32k-encore
+ cpu=ns32k
+ vendor=encore
;;
- es1800 | OSE68k | ose68k | ose | OSE)
- basic_machine=m68k-ericsson
- os=-ose
+ elxsi)
+ cpu=elxsi
+ vendor=elxsi
+ os=${os:-bsd}
;;
fx2800)
- basic_machine=i860-alliant
+ cpu=i860
+ vendor=alliant
;;
genix)
- basic_machine=ns32k-ns
- ;;
- gmicro)
- basic_machine=tron-gmicro
- os=-sysv
- ;;
- go32)
- basic_machine=i386-pc
- os=-go32
+ cpu=ns32k
+ vendor=ns
;;
h3050r* | hiux*)
- basic_machine=hppa1.1-hitachi
- os=-hiuxwe2
- ;;
- h8300hms)
- basic_machine=h8300-hitachi
- os=-hms
- ;;
- h8300xray)
- basic_machine=h8300-hitachi
- os=-xray
- ;;
- h8500hms)
- basic_machine=h8500-hitachi
- os=-hms
- ;;
- harris)
- basic_machine=m88k-harris
- os=-sysv3
- ;;
- hp300-*)
- basic_machine=m68k-hp
- ;;
- hp300bsd)
- basic_machine=m68k-hp
- os=-bsd
- ;;
- hp300hpux)
- basic_machine=m68k-hp
- os=-hpux
+ cpu=hppa1.1
+ vendor=hitachi
+ os=hiuxwe2
;;
hp3k9[0-9][0-9] | hp9[0-9][0-9])
- basic_machine=hppa1.0-hp
+ cpu=hppa1.0
+ vendor=hp
;;
hp9k2[0-9][0-9] | hp9k31[0-9])
- basic_machine=m68000-hp
+ cpu=m68000
+ vendor=hp
;;
hp9k3[2-9][0-9])
- basic_machine=m68k-hp
+ cpu=m68k
+ vendor=hp
;;
hp9k6[0-9][0-9] | hp6[0-9][0-9])
- basic_machine=hppa1.0-hp
+ cpu=hppa1.0
+ vendor=hp
;;
hp9k7[0-79][0-9] | hp7[0-79][0-9])
- basic_machine=hppa1.1-hp
+ cpu=hppa1.1
+ vendor=hp
;;
hp9k78[0-9] | hp78[0-9])
# FIXME: really hppa2.0-hp
- basic_machine=hppa1.1-hp
+ cpu=hppa1.1
+ vendor=hp
;;
hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893)
# FIXME: really hppa2.0-hp
- basic_machine=hppa1.1-hp
+ cpu=hppa1.1
+ vendor=hp
;;
hp9k8[0-9][13679] | hp8[0-9][13679])
- basic_machine=hppa1.1-hp
+ cpu=hppa1.1
+ vendor=hp
;;
hp9k8[0-9][0-9] | hp8[0-9][0-9])
- basic_machine=hppa1.0-hp
- ;;
- hppa-next)
- os=-nextstep3
- ;;
- hppaosf)
- basic_machine=hppa1.1-hp
- os=-osf
- ;;
- hppro)
- basic_machine=hppa1.1-hp
- os=-proelf
- ;;
- i370-ibm* | ibm*)
- basic_machine=i370-ibm
+ cpu=hppa1.0
+ vendor=hp
;;
i*86v32)
- basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
- os=-sysv32
+ cpu=`echo "$1" | sed -e 's/86.*/86/'`
+ vendor=pc
+ os=sysv32
;;
i*86v4*)
- basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
- os=-sysv4
+ cpu=`echo "$1" | sed -e 's/86.*/86/'`
+ vendor=pc
+ os=sysv4
;;
i*86v)
- basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
- os=-sysv
+ cpu=`echo "$1" | sed -e 's/86.*/86/'`
+ vendor=pc
+ os=sysv
;;
i*86sol2)
- basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
- os=-solaris2
+ cpu=`echo "$1" | sed -e 's/86.*/86/'`
+ vendor=pc
+ os=solaris2
;;
- i386mach)
- basic_machine=i386-mach
- os=-mach
- ;;
- i386-vsta | vsta)
- basic_machine=i386-unknown
- os=-vsta
+ j90 | j90-cray)
+ cpu=j90
+ vendor=cray
+ os=${os:-unicos}
;;
iris | iris4d)
- basic_machine=mips-sgi
+ cpu=mips
+ vendor=sgi
case $os in
- -irix*)
+ irix*)
;;
*)
- os=-irix4
+ os=irix4
;;
esac
;;
- isi68 | isi)
- basic_machine=m68k-isi
- os=-sysv
- ;;
- leon-*|leon[3-9]-*)
- basic_machine=sparc-`echo $basic_machine | sed 's/-.*//'`
- ;;
- m68knommu)
- basic_machine=m68k-unknown
- os=-linux
- ;;
- m68knommu-*)
- basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'`
- os=-linux
- ;;
- m88k-omron*)
- basic_machine=m88k-omron
- ;;
- magnum | m3230)
- basic_machine=mips-mips
- os=-sysv
- ;;
- merlin)
- basic_machine=ns32k-utek
- os=-sysv
- ;;
- microblaze*)
- basic_machine=microblaze-xilinx
- ;;
- mingw64)
- basic_machine=x86_64-pc
- os=-mingw64
- ;;
- mingw32)
- basic_machine=i686-pc
- os=-mingw32
- ;;
- mingw32ce)
- basic_machine=arm-unknown
- os=-mingw32ce
- ;;
miniframe)
- basic_machine=m68000-convergent
- ;;
- *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*)
- basic_machine=m68k-atari
- os=-mint
- ;;
- mips3*-*)
- basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`
- ;;
- mips3*)
- basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown
- ;;
- monitor)
- basic_machine=m68k-rom68k
- os=-coff
- ;;
- morphos)
- basic_machine=powerpc-unknown
- os=-morphos
- ;;
- moxiebox)
- basic_machine=moxie-unknown
- os=-moxiebox
- ;;
- msdos)
- basic_machine=i386-pc
- os=-msdos
- ;;
- ms1-*)
- basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'`
- ;;
- msys)
- basic_machine=i686-pc
- os=-msys
- ;;
- mvs)
- basic_machine=i370-ibm
- os=-mvs
+ cpu=m68000
+ vendor=convergent
;;
- nacl)
- basic_machine=le32-unknown
- os=-nacl
- ;;
- ncr3000)
- basic_machine=i486-ncr
- os=-sysv4
- ;;
- netbsd386)
- basic_machine=i386-unknown
- os=-netbsd
- ;;
- netwinder)
- basic_machine=armv4l-rebel
- os=-linux
- ;;
- news | news700 | news800 | news900)
- basic_machine=m68k-sony
- os=-newsos
- ;;
- news1000)
- basic_machine=m68030-sony
- os=-newsos
+ *mint | mint[0-9]* | *MiNT | *MiNT[0-9]*)
+ cpu=m68k
+ vendor=atari
+ os=mint
;;
news-3600 | risc-news)
- basic_machine=mips-sony
- os=-newsos
- ;;
- necv70)
- basic_machine=v70-nec
- os=-sysv
+ cpu=mips
+ vendor=sony
+ os=newsos
;;
next | m*-next)
- basic_machine=m68k-next
+ cpu=m68k
+ vendor=next
case $os in
- -nextstep* )
+ nextstep* )
;;
- -ns2*)
- os=-nextstep2
+ ns2*)
+ os=nextstep2
;;
*)
- os=-nextstep3
+ os=nextstep3
;;
esac
;;
- nh3000)
- basic_machine=m68k-harris
- os=-cxux
- ;;
- nh[45]000)
- basic_machine=m88k-harris
- os=-cxux
- ;;
- nindy960)
- basic_machine=i960-intel
- os=-nindy
- ;;
- mon960)
- basic_machine=i960-intel
- os=-mon960
- ;;
- nonstopux)
- basic_machine=mips-compaq
- os=-nonstopux
- ;;
np1)
- basic_machine=np1-gould
- ;;
- neo-tandem)
- basic_machine=neo-tandem
- ;;
- nse-tandem)
- basic_machine=nse-tandem
- ;;
- nsr-tandem)
- basic_machine=nsr-tandem
- ;;
- nsx-tandem)
- basic_machine=nsx-tandem
+ cpu=np1
+ vendor=gould
;;
op50n-* | op60c-*)
- basic_machine=hppa1.1-oki
- os=-proelf
- ;;
- openrisc | openrisc-*)
- basic_machine=or32-unknown
- ;;
- os400)
- basic_machine=powerpc-ibm
- os=-os400
- ;;
- OSE68000 | ose68000)
- basic_machine=m68000-ericsson
- os=-ose
- ;;
- os68k)
- basic_machine=m68k-none
- os=-os68k
+ cpu=hppa1.1
+ vendor=oki
+ os=proelf
;;
pa-hitachi)
- basic_machine=hppa1.1-hitachi
- os=-hiuxwe2
- ;;
- paragon)
- basic_machine=i860-intel
- os=-osf
- ;;
- parisc)
- basic_machine=hppa-unknown
- os=-linux
- ;;
- parisc-*)
- basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'`
- os=-linux
+ cpu=hppa1.1
+ vendor=hitachi
+ os=hiuxwe2
;;
pbd)
- basic_machine=sparc-tti
+ cpu=sparc
+ vendor=tti
;;
pbb)
- basic_machine=m68k-tti
+ cpu=m68k
+ vendor=tti
;;
- pc532 | pc532-*)
- basic_machine=ns32k-pc532
- ;;
- pc98)
- basic_machine=i386-pc
- ;;
- pc98-*)
- basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'`
- ;;
- pentium | p5 | k5 | k6 | nexgen | viac3)
- basic_machine=i586-pc
- ;;
- pentiumpro | p6 | 6x86 | athlon | athlon_*)
- basic_machine=i686-pc
- ;;
- pentiumii | pentium2 | pentiumiii | pentium3)
- basic_machine=i686-pc
- ;;
- pentium4)
- basic_machine=i786-pc
- ;;
- pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*)
- basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'`
- ;;
- pentiumpro-* | p6-* | 6x86-* | athlon-*)
- basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`
- ;;
- pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*)
- basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`
- ;;
- pentium4-*)
- basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'`
+ pc532)
+ cpu=ns32k
+ vendor=pc532
;;
pn)
- basic_machine=pn-gould
- ;;
- power) basic_machine=power-ibm
- ;;
- ppc | ppcbe) basic_machine=powerpc-unknown
- ;;
- ppc-* | ppcbe-*)
- basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'`
- ;;
- ppcle | powerpclittle)
- basic_machine=powerpcle-unknown
+ cpu=pn
+ vendor=gould
;;
- ppcle-* | powerpclittle-*)
- basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'`
- ;;
- ppc64) basic_machine=powerpc64-unknown
- ;;
- ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'`
- ;;
- ppc64le | powerpc64little)
- basic_machine=powerpc64le-unknown
- ;;
- ppc64le-* | powerpc64little-*)
- basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'`
+ power)
+ cpu=power
+ vendor=ibm
;;
ps2)
- basic_machine=i386-ibm
- ;;
- pw32)
- basic_machine=i586-unknown
- os=-pw32
- ;;
- rdos | rdos64)
- basic_machine=x86_64-pc
- os=-rdos
- ;;
- rdos32)
- basic_machine=i386-pc
- os=-rdos
- ;;
- rom68k)
- basic_machine=m68k-rom68k
- os=-coff
+ cpu=i386
+ vendor=ibm
;;
rm[46]00)
- basic_machine=mips-siemens
+ cpu=mips
+ vendor=siemens
;;
rtpc | rtpc-*)
- basic_machine=romp-ibm
- ;;
- s390 | s390-*)
- basic_machine=s390-ibm
- ;;
- s390x | s390x-*)
- basic_machine=s390x-ibm
- ;;
- sa29200)
- basic_machine=a29k-amd
- os=-udi
- ;;
- sb1)
- basic_machine=mipsisa64sb1-unknown
- ;;
- sb1el)
- basic_machine=mipsisa64sb1el-unknown
+ cpu=romp
+ vendor=ibm
;;
sde)
- basic_machine=mipsisa32-sde
- os=-elf
+ cpu=mipsisa32
+ vendor=sde
+ os=${os:-elf}
;;
- sei)
- basic_machine=mips-sei
- os=-seiux
+ simso-wrs)
+ cpu=sparclite
+ vendor=wrs
+ os=vxworks
;;
- sequent)
- basic_machine=i386-sequent
+ tower | tower-32)
+ cpu=m68k
+ vendor=ncr
;;
- sh)
- basic_machine=sh-hitachi
- os=-hms
+ vpp*|vx|vx-*)
+ cpu=f301
+ vendor=fujitsu
;;
- sh5el)
- basic_machine=sh5le-unknown
+ w65)
+ cpu=w65
+ vendor=wdc
;;
- sh64)
- basic_machine=sh64-unknown
+ w89k-*)
+ cpu=hppa1.1
+ vendor=winbond
+ os=proelf
;;
- sparclite-wrs | simso-wrs)
- basic_machine=sparclite-wrs
- os=-vxworks
+ none)
+ cpu=none
+ vendor=none
;;
- sps7)
- basic_machine=m68k-bull
- os=-sysv2
+ leon|leon[3-9])
+ cpu=sparc
+ vendor=$basic_machine
;;
- spur)
- basic_machine=spur-unknown
+ leon-*|leon[3-9]-*)
+ cpu=sparc
+ vendor=`echo "$basic_machine" | sed 's/-.*//'`
;;
- st2000)
- basic_machine=m68k-tandem
+
+ *-*)
+ # shellcheck disable=SC2162
+ IFS="-" read cpu vendor <<EOF
+$basic_machine
+EOF
;;
- stratus)
- basic_machine=i860-stratus
- os=-sysv4
+ # We use `pc' rather than `unknown'
+ # because (1) that's what they normally are, and
+ # (2) the word "unknown" tends to confuse beginning users.
+ i*86 | x86_64)
+ cpu=$basic_machine
+ vendor=pc
;;
- strongarm-* | thumb-*)
- basic_machine=arm-`echo $basic_machine | sed 's/^[^-]*-//'`
+ # These rules are duplicated from below for sake of the special case above;
+ # i.e. things that normalized to x86 arches should also default to "pc"
+ pc98)
+ cpu=i386
+ vendor=pc
;;
- sun2)
- basic_machine=m68000-sun
+ x64 | amd64)
+ cpu=x86_64
+ vendor=pc
;;
- sun2os3)
- basic_machine=m68000-sun
- os=-sunos3
+ # Recognize the basic CPU types without company name.
+ *)
+ cpu=$basic_machine
+ vendor=unknown
;;
- sun2os4)
- basic_machine=m68000-sun
- os=-sunos4
+esac
+
+unset -v basic_machine
+
+# Decode basic machines in the full and proper CPU-Company form.
+case $cpu-$vendor in
+ # Here we handle the default manufacturer of certain CPU types in canonical form. It is in
+ # some cases the only manufacturer, in others, it is the most popular.
+ craynv-unknown)
+ vendor=cray
+ os=${os:-unicosmp}
;;
- sun3os3)
- basic_machine=m68k-sun
- os=-sunos3
+ c90-unknown | c90-cray)
+ vendor=cray
+ os=${os:-unicos}
;;
- sun3os4)
- basic_machine=m68k-sun
- os=-sunos4
+ fx80-unknown)
+ vendor=alliant
;;
- sun4os3)
- basic_machine=sparc-sun
- os=-sunos3
+ romp-unknown)
+ vendor=ibm
;;
- sun4os4)
- basic_machine=sparc-sun
- os=-sunos4
+ mmix-unknown)
+ vendor=knuth
;;
- sun4sol2)
- basic_machine=sparc-sun
- os=-solaris2
+ microblaze-unknown | microblazeel-unknown)
+ vendor=xilinx
;;
- sun3 | sun3-*)
- basic_machine=m68k-sun
+ rs6000-unknown)
+ vendor=ibm
;;
- sun4)
- basic_machine=sparc-sun
+ vax-unknown)
+ vendor=dec
;;
- sun386 | sun386i | roadrunner)
- basic_machine=i386-sun
+ pdp11-unknown)
+ vendor=dec
;;
- sv1)
- basic_machine=sv1-cray
- os=-unicos
+ we32k-unknown)
+ vendor=att
;;
- symmetry)
- basic_machine=i386-sequent
- os=-dynix
+ cydra-unknown)
+ vendor=cydrome
;;
- t3e)
- basic_machine=alphaev5-cray
- os=-unicos
+ i370-ibm*)
+ vendor=ibm
;;
- t90)
- basic_machine=t90-cray
- os=-unicos
+ orion-unknown)
+ vendor=highlevel
;;
- tile*)
- basic_machine=$basic_machine-unknown
- os=-linux-gnu
+ xps-unknown | xps100-unknown)
+ cpu=xps100
+ vendor=honeywell
;;
- tx39)
- basic_machine=mipstx39-unknown
+
+ # Here we normalize CPU types with a missing or matching vendor
+ dpx20-unknown | dpx20-bull)
+ cpu=rs6000
+ vendor=bull
+ os=${os:-bosx}
;;
- tx39el)
- basic_machine=mipstx39el-unknown
+
+ # Here we normalize CPU types irrespective of the vendor
+ amd64-*)
+ cpu=x86_64
;;
- toad1)
- basic_machine=pdp10-xkl
- os=-tops20
+ blackfin-*)
+ cpu=bfin
+ os=linux
;;
- tower | tower-32)
- basic_machine=m68k-ncr
+ c54x-*)
+ cpu=tic54x
;;
- tpf)
- basic_machine=s390x-ibm
- os=-tpf
+ c55x-*)
+ cpu=tic55x
;;
- udi29k)
- basic_machine=a29k-amd
- os=-udi
+ c6x-*)
+ cpu=tic6x
;;
- ultra3)
- basic_machine=a29k-nyu
- os=-sym1
+ e500v[12]-*)
+ cpu=powerpc
+ os=$os"spe"
;;
- v810 | necv810)
- basic_machine=v810-nec
- os=-none
+ mips3*-*)
+ cpu=mips64
;;
- vaxv)
- basic_machine=vax-dec
- os=-sysv
+ ms1-*)
+ cpu=mt
;;
- vms)
- basic_machine=vax-dec
- os=-vms
+ m68knommu-*)
+ cpu=m68k
+ os=linux
;;
- vpp*|vx|vx-*)
- basic_machine=f301-fujitsu
+ m9s12z-* | m68hcs12z-* | hcs12z-* | s12z-*)
+ cpu=s12z
;;
- vxworks960)
- basic_machine=i960-wrs
- os=-vxworks
+ openrisc-*)
+ cpu=or32
;;
- vxworks68)
- basic_machine=m68k-wrs
- os=-vxworks
+ parisc-*)
+ cpu=hppa
+ os=linux
;;
- vxworks29k)
- basic_machine=a29k-wrs
- os=-vxworks
+ pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*)
+ cpu=i586
;;
- wasm32)
- basic_machine=wasm32-unknown
+ pentiumpro-* | p6-* | 6x86-* | athlon-* | athalon_*-*)
+ cpu=i686
;;
- w65*)
- basic_machine=w65-wdc
- os=-none
+ pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*)
+ cpu=i686
;;
- w89k-*)
- basic_machine=hppa1.1-winbond
- os=-proelf
+ pentium4-*)
+ cpu=i786
;;
- x64)
- basic_machine=x86_64-pc
+ pc98-*)
+ cpu=i386
;;
- xbox)
- basic_machine=i686-pc
- os=-mingw32
+ ppc-* | ppcbe-*)
+ cpu=powerpc
;;
- xps | xps100)
- basic_machine=xps100-honeywell
+ ppcle-* | powerpclittle-*)
+ cpu=powerpcle
;;
- xscale-* | xscalee[bl]-*)
- basic_machine=`echo $basic_machine | sed 's/^xscale/arm/'`
+ ppc64-*)
+ cpu=powerpc64
;;
- ymp)
- basic_machine=ymp-cray
- os=-unicos
+ ppc64le-* | powerpc64little-*)
+ cpu=powerpc64le
;;
- z8k-*-coff)
- basic_machine=z8k-unknown
- os=-sim
+ sb1-*)
+ cpu=mipsisa64sb1
;;
- z80-*-coff)
- basic_machine=z80-unknown
- os=-sim
+ sb1el-*)
+ cpu=mipsisa64sb1el
;;
- none)
- basic_machine=none-none
- os=-none
+ sh5e[lb]-*)
+ cpu=`echo "$cpu" | sed 's/^\(sh.\)e\(.\)$/\1\2e/'`
;;
-
-# Here we handle the default manufacturer of certain CPU types. It is in
-# some cases the only manufacturer, in others, it is the most popular.
- w89k)
- basic_machine=hppa1.1-winbond
+ spur-*)
+ cpu=spur
;;
- op50n)
- basic_machine=hppa1.1-oki
+ strongarm-* | thumb-*)
+ cpu=arm
;;
- op60c)
- basic_machine=hppa1.1-oki
+ tx39-*)
+ cpu=mipstx39
;;
- romp)
- basic_machine=romp-ibm
+ tx39el-*)
+ cpu=mipstx39el
;;
- mmix)
- basic_machine=mmix-knuth
+ x64-*)
+ cpu=x86_64
;;
- rs6000)
- basic_machine=rs6000-ibm
+ xscale-* | xscalee[bl]-*)
+ cpu=`echo "$cpu" | sed 's/^xscale/arm/'`
;;
- vax)
- basic_machine=vax-dec
+
+ # Recognize the canonical CPU Types that limit and/or modify the
+ # company names they are paired with.
+ cr16-*)
+ os=${os:-elf}
;;
- pdp10)
- # there are many clones, so DEC is not a safe bet
- basic_machine=pdp10-unknown
+ crisv32-* | etraxfs*-*)
+ cpu=crisv32
+ vendor=axis
;;
- pdp11)
- basic_machine=pdp11-dec
+ cris-* | etrax*-*)
+ cpu=cris
+ vendor=axis
;;
- we32k)
- basic_machine=we32k-att
+ crx-*)
+ os=${os:-elf}
;;
- sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele)
- basic_machine=sh-unknown
+ neo-tandem)
+ cpu=neo
+ vendor=tandem
;;
- sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v)
- basic_machine=sparc-sun
+ nse-tandem)
+ cpu=nse
+ vendor=tandem
;;
- cydra)
- basic_machine=cydra-cydrome
+ nsr-tandem)
+ cpu=nsr
+ vendor=tandem
;;
- orion)
- basic_machine=orion-highlevel
+ nsv-tandem)
+ cpu=nsv
+ vendor=tandem
;;
- orion105)
- basic_machine=clipper-highlevel
+ nsx-tandem)
+ cpu=nsx
+ vendor=tandem
;;
- mac | mpw | mac-mpw)
- basic_machine=m68k-apple
+ s390-*)
+ cpu=s390
+ vendor=ibm
;;
- pmac | pmac-mpw)
- basic_machine=powerpc-apple
+ s390x-*)
+ cpu=s390x
+ vendor=ibm
;;
- *-unknown)
- # Make sure to match an already-canonicalized machine name.
+ tile*-*)
+ os=${os:-linux-gnu}
;;
+
*)
- echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
- exit 1
+ # Recognize the canonical CPU types that are allowed with any
+ # company name.
+ case $cpu in
+ 1750a | 580 \
+ | a29k \
+ | aarch64 | aarch64_be \
+ | abacus \
+ | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] \
+ | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] \
+ | alphapca5[67] | alpha64pca5[67] \
+ | am33_2.0 \
+ | amdgcn \
+ | arc | arceb \
+ | arm | arm[lb]e | arme[lb] | armv* \
+ | avr | avr32 \
+ | asmjs \
+ | ba \
+ | be32 | be64 \
+ | bfin | bs2000 \
+ | c[123]* | c30 | [cjt]90 | c4x \
+ | c8051 | clipper | craynv | csky | cydra \
+ | d10v | d30v | dlx | dsp16xx \
+ | e2k | elxsi | epiphany \
+ | f30[01] | f700 | fido | fr30 | frv | ft32 | fx80 \
+ | h8300 | h8500 \
+ | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \
+ | hexagon \
+ | i370 | i*86 | i860 | i960 | ia16 | ia64 \
+ | ip2k | iq2000 \
+ | k1om \
+ | le32 | le64 \
+ | lm32 \
+ | m32c | m32r | m32rle \
+ | m5200 | m68000 | m680[012346]0 | m68360 | m683?2 | m68k \
+ | m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x \
+ | m88110 | m88k | maxq | mb | mcore | mep | metag \
+ | microblaze | microblazeel \
+ | mips | mipsbe | mipseb | mipsel | mipsle \
+ | mips16 \
+ | mips64 | mips64eb | mips64el \
+ | mips64octeon | mips64octeonel \
+ | mips64orion | mips64orionel \
+ | mips64r5900 | mips64r5900el \
+ | mips64vr | mips64vrel \
+ | mips64vr4100 | mips64vr4100el \
+ | mips64vr4300 | mips64vr4300el \
+ | mips64vr5000 | mips64vr5000el \
+ | mips64vr5900 | mips64vr5900el \
+ | mipsisa32 | mipsisa32el \
+ | mipsisa32r2 | mipsisa32r2el \
+ | mipsisa32r6 | mipsisa32r6el \
+ | mipsisa64 | mipsisa64el \
+ | mipsisa64r2 | mipsisa64r2el \
+ | mipsisa64r6 | mipsisa64r6el \
+ | mipsisa64sb1 | mipsisa64sb1el \
+ | mipsisa64sr71k | mipsisa64sr71kel \
+ | mipsr5900 | mipsr5900el \
+ | mipstx39 | mipstx39el \
+ | mmix \
+ | mn10200 | mn10300 \
+ | moxie \
+ | mt \
+ | msp430 \
+ | nds32 | nds32le | nds32be \
+ | nfp \
+ | nios | nios2 | nios2eb | nios2el \
+ | none | np1 | ns16k | ns32k | nvptx \
+ | open8 \
+ | or1k* \
+ | or32 \
+ | orion \
+ | picochip \
+ | pdp10 | pdp11 | pj | pjl | pn | power \
+ | powerpc | powerpc64 | powerpc64le | powerpcle | powerpcspe \
+ | pru \
+ | pyramid \
+ | riscv | riscv32 | riscv64 \
+ | rl78 | romp | rs6000 | rx \
+ | score \
+ | sh | shl \
+ | sh[1234] | sh[24]a | sh[24]ae[lb] | sh[23]e | she[lb] | sh[lb]e \
+ | sh[1234]e[lb] | sh[12345][lb]e | sh[23]ele | sh64 | sh64le \
+ | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet \
+ | sparclite \
+ | sparcv8 | sparcv9 | sparcv9b | sparcv9v | sv1 | sx* \
+ | spu \
+ | tahoe \
+ | tic30 | tic4x | tic54x | tic55x | tic6x | tic80 \
+ | tron \
+ | ubicom32 \
+ | v70 | v850 | v850e | v850e1 | v850es | v850e2 | v850e2v3 \
+ | vax \
+ | visium \
+ | w65 | wasm32 \
+ | we32k \
+ | x86 | x86_64 | xc16x | xgate | xps100 \
+ | xstormy16 | xtensa* \
+ | ymp \
+ | z8k | z80)
+ ;;
+
+ *)
+ echo Invalid configuration \`"$1"\': machine \`"$cpu-$vendor"\' not recognized 1>&2
+ exit 1
+ ;;
+ esac
;;
esac
# Here we canonicalize certain aliases for manufacturers.
-case $basic_machine in
- *-digital*)
- basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'`
+case $vendor in
+ digital*)
+ vendor=dec
;;
- *-commodore*)
- basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'`
+ commodore*)
+ vendor=cbm
;;
*)
;;
@@ -1362,213 +1275,246 @@ esac
# Decode manufacturer-specific aliases for certain operating systems.
-if [ x"$os" != x"" ]
+if [ x$os != x ]
then
case $os in
# First match some system type aliases that might get confused
# with valid system types.
- # -solaris* is a basic system type, with this one exception.
- -auroraux)
- os=-auroraux
+ # solaris* is a basic system type, with this one exception.
+ auroraux)
+ os=auroraux
;;
- -solaris1 | -solaris1.*)
- os=`echo $os | sed -e 's|solaris1|sunos4|'`
+ bluegene*)
+ os=cnk
;;
- -solaris)
- os=-solaris2
+ solaris1 | solaris1.*)
+ os=`echo $os | sed -e 's|solaris1|sunos4|'`
;;
- -svr4*)
- os=-sysv4
+ solaris)
+ os=solaris2
;;
- -unixware*)
- os=-sysv4.2uw
+ unixware*)
+ os=sysv4.2uw
;;
- -gnu/linux*)
+ gnu/linux*)
os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'`
;;
+ # es1800 is here to avoid being matched by es* (a different OS)
+ es1800*)
+ os=ose
+ ;;
+ # Some version numbers need modification
+ chorusos*)
+ os=chorusos
+ ;;
+ isc)
+ os=isc2.2
+ ;;
+ sco6)
+ os=sco5v6
+ ;;
+ sco5)
+ os=sco3.2v5
+ ;;
+ sco4)
+ os=sco3.2v4
+ ;;
+ sco3.2.[4-9]*)
+ os=`echo $os | sed -e 's/sco3.2./sco3.2v/'`
+ ;;
+ sco3.2v[4-9]* | sco5v6*)
+ # Don't forget version if it is 3.2v4 or newer.
+ ;;
+ scout)
+ # Don't match below
+ ;;
+ sco*)
+ os=sco3.2v2
+ ;;
+ psos*)
+ os=psos
+ ;;
# Now accept the basic system types.
# The portable systems comes first.
# Each alternative MUST end in a * to match a version number.
- # -sysv* is not here because it comes later, after sysvr4.
- -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \
- | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\
- | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \
- | -sym* | -kopensolaris* | -plan9* \
- | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \
- | -aos* | -aros* | -cloudabi* | -sortix* \
- | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \
- | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \
- | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \
- | -bitrig* | -openbsd* | -solidbsd* | -libertybsd* \
- | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \
- | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \
- | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \
- | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \
- | -chorusos* | -chorusrdb* | -cegcc* | -glidix* \
- | -cygwin* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \
- | -midipix* | -mingw32* | -mingw64* | -linux-gnu* | -linux-android* \
- | -linux-newlib* | -linux-musl* | -linux-uclibc* \
- | -uxpv* | -beos* | -mpeix* | -udk* | -moxiebox* \
- | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \
- | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \
- | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \
- | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \
- | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \
- | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \
- | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es* \
- | -onefs* | -tirtos* | -phoenix* | -fuchsia* | -redox* | -bme*)
+ # sysv* is not here because it comes later, after sysvr4.
+ gnu* | bsd* | mach* | minix* | genix* | ultrix* | irix* \
+ | *vms* | esix* | aix* | cnk* | sunos | sunos[34]*\
+ | hpux* | unos* | osf* | luna* | dgux* | auroraux* | solaris* \
+ | sym* | kopensolaris* | plan9* \
+ | amigaos* | amigados* | msdos* | newsos* | unicos* | aof* \
+ | aos* | aros* | cloudabi* | sortix* \
+ | nindy* | vxsim* | vxworks* | ebmon* | hms* | mvs* \
+ | clix* | riscos* | uniplus* | iris* | isc* | rtu* | xenix* \
+ | knetbsd* | mirbsd* | netbsd* \
+ | bitrig* | openbsd* | solidbsd* | libertybsd* \
+ | ekkobsd* | kfreebsd* | freebsd* | riscix* | lynxos* \
+ | bosx* | nextstep* | cxux* | aout* | elf* | oabi* \
+ | ptx* | coff* | ecoff* | winnt* | domain* | vsta* \
+ | udi* | eabi* | lites* | ieee* | go32* | aux* | hcos* \
+ | chorusrdb* | cegcc* | glidix* \
+ | cygwin* | msys* | pe* | moss* | proelf* | rtems* \
+ | midipix* | mingw32* | mingw64* | linux-gnu* | linux-android* \
+ | linux-newlib* | linux-musl* | linux-uclibc* \
+ | uxpv* | beos* | mpeix* | udk* | moxiebox* \
+ | interix* | uwin* | mks* | rhapsody* | darwin* \
+ | openstep* | oskit* | conix* | pw32* | nonstopux* \
+ | storm-chaos* | tops10* | tenex* | tops20* | its* \
+ | os2* | vos* | palmos* | uclinux* | nucleus* \
+ | morphos* | superux* | rtmk* | windiss* \
+ | powermax* | dnix* | nx6 | nx7 | sei* | dragonfly* \
+ | skyos* | haiku* | rdos* | toppers* | drops* | es* \
+ | onefs* | tirtos* | phoenix* | fuchsia* | redox* | bme* \
+ | midnightbsd* | amdhsa* | unleashed* | emscripten*)
# Remember, each alternative MUST END IN *, to match a version number.
;;
- -qnx*)
- case $basic_machine in
- x86-* | i*86-*)
+ qnx*)
+ case $cpu in
+ x86 | i*86)
;;
*)
- os=-nto$os
+ os=nto-$os
;;
esac
;;
- -nto-qnx*)
+ hiux*)
+ os=hiuxwe2
;;
- -nto*)
- os=`echo $os | sed -e 's|nto|nto-qnx|'`
+ nto-qnx*)
;;
- -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \
- | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \
- | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*)
+ nto*)
+ os=`echo $os | sed -e 's|nto|nto-qnx|'`
;;
- -mac*)
- os=`echo $os | sed -e 's|mac|macos|'`
+ sim | xray | os68k* | v88r* \
+ | windows* | osx | abug | netware* | os9* \
+ | macos* | mpw* | magic* | mmixware* | mon960* | lnews*)
;;
- -linux-dietlibc)
- os=-linux-dietlibc
+ linux-dietlibc)
+ os=linux-dietlibc
;;
- -linux*)
+ linux*)
os=`echo $os | sed -e 's|linux|linux-gnu|'`
;;
- -sunos5*)
- os=`echo $os | sed -e 's|sunos5|solaris2|'`
+ lynx*178)
+ os=lynxos178
;;
- -sunos6*)
- os=`echo $os | sed -e 's|sunos6|solaris3|'`
+ lynx*5)
+ os=lynxos5
;;
- -opened*)
- os=-openedition
+ lynx*)
+ os=lynxos
;;
- -os400*)
- os=-os400
+ mac*)
+ os=`echo "$os" | sed -e 's|mac|macos|'`
;;
- -wince*)
- os=-wince
+ opened*)
+ os=openedition
;;
- -osfrose*)
- os=-osfrose
+ os400*)
+ os=os400
;;
- -osf*)
- os=-osf
+ sunos5*)
+ os=`echo "$os" | sed -e 's|sunos5|solaris2|'`
;;
- -utek*)
- os=-bsd
+ sunos6*)
+ os=`echo "$os" | sed -e 's|sunos6|solaris3|'`
;;
- -dynix*)
- os=-bsd
+ wince*)
+ os=wince
;;
- -acis*)
- os=-aos
+ utek*)
+ os=bsd
;;
- -atheos*)
- os=-atheos
+ dynix*)
+ os=bsd
;;
- -syllable*)
- os=-syllable
+ acis*)
+ os=aos
;;
- -386bsd)
- os=-bsd
+ atheos*)
+ os=atheos
;;
- -ctix* | -uts*)
- os=-sysv
+ syllable*)
+ os=syllable
;;
- -nova*)
- os=-rtmk-nova
- ;;
- -ns2)
- os=-nextstep2
+ 386bsd)
+ os=bsd
;;
- -nsk*)
- os=-nsk
+ ctix* | uts*)
+ os=sysv
;;
- # Preserve the version number of sinix5.
- -sinix5.*)
- os=`echo $os | sed -e 's|sinix|sysv|'`
+ nova*)
+ os=rtmk-nova
;;
- -sinix*)
- os=-sysv4
+ ns2)
+ os=nextstep2
;;
- -tpf*)
- os=-tpf
+ nsk*)
+ os=nsk
;;
- -triton*)
- os=-sysv3
+ # Preserve the version number of sinix5.
+ sinix5.*)
+ os=`echo $os | sed -e 's|sinix|sysv|'`
;;
- -oss*)
- os=-sysv3
+ sinix*)
+ os=sysv4
;;
- -svr4)
- os=-sysv4
+ tpf*)
+ os=tpf
;;
- -svr3)
- os=-sysv3
+ triton*)
+ os=sysv3
;;
- -sysvr4)
- os=-sysv4
+ oss*)
+ os=sysv3
;;
- # This must come after -sysvr4.
- -sysv*)
+ svr4*)
+ os=sysv4
;;
- -ose*)
- os=-ose
+ svr3)
+ os=sysv3
;;
- -es1800*)
- os=-ose
+ sysvr4)
+ os=sysv4
;;
- -xenix)
- os=-xenix
+ # This must come after sysvr4.
+ sysv*)
;;
- -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)
- os=-mint
+ ose*)
+ os=ose
;;
- -aros*)
- os=-aros
+ *mint | mint[0-9]* | *MiNT | MiNT[0-9]*)
+ os=mint
;;
- -zvmoe)
- os=-zvmoe
+ zvmoe)
+ os=zvmoe
;;
- -dicos*)
- os=-dicos
+ dicos*)
+ os=dicos
;;
- -pikeos*)
+ pikeos*)
# Until real need of OS specific support for
# particular features comes up, bare metal
# configurations are quite functional.
- case $basic_machine in
+ case $cpu in
arm*)
- os=-eabi
+ os=eabi
;;
*)
- os=-elf
+ os=elf
;;
esac
;;
- -nacl*)
+ nacl*)
;;
- -ios)
+ ios)
;;
- -none)
+ none)
+ ;;
+ *-eabi)
;;
*)
- # Get rid of the `-' at the beginning of $os.
- os=`echo $os | sed 's/[^-]*-//'`
- echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2
+ echo Invalid configuration \`"$1"\': system \`"$os"\' not recognized 1>&2
exit 1
;;
esac
@@ -1584,264 +1530,265 @@ else
# will signal an error saying that MANUFACTURER isn't an operating
# system, and we'll never get to this point.
-case $basic_machine in
+case $cpu-$vendor in
score-*)
- os=-elf
+ os=elf
;;
spu-*)
- os=-elf
+ os=elf
;;
*-acorn)
- os=-riscix1.2
+ os=riscix1.2
;;
arm*-rebel)
- os=-linux
+ os=linux
;;
arm*-semi)
- os=-aout
+ os=aout
;;
c4x-* | tic4x-*)
- os=-coff
+ os=coff
;;
c8051-*)
- os=-elf
+ os=elf
+ ;;
+ clipper-intergraph)
+ os=clix
;;
hexagon-*)
- os=-elf
+ os=elf
;;
tic54x-*)
- os=-coff
+ os=coff
;;
tic55x-*)
- os=-coff
+ os=coff
;;
tic6x-*)
- os=-coff
+ os=coff
;;
# This must come before the *-dec entry.
pdp10-*)
- os=-tops20
+ os=tops20
;;
pdp11-*)
- os=-none
+ os=none
;;
*-dec | vax-*)
- os=-ultrix4.2
+ os=ultrix4.2
;;
m68*-apollo)
- os=-domain
+ os=domain
;;
i386-sun)
- os=-sunos4.0.2
+ os=sunos4.0.2
;;
m68000-sun)
- os=-sunos3
+ os=sunos3
;;
m68*-cisco)
- os=-aout
+ os=aout
;;
mep-*)
- os=-elf
+ os=elf
;;
mips*-cisco)
- os=-elf
+ os=elf
;;
mips*-*)
- os=-elf
+ os=elf
;;
or32-*)
- os=-coff
+ os=coff
;;
*-tti) # must be before sparc entry or we get the wrong os.
- os=-sysv3
+ os=sysv3
;;
sparc-* | *-sun)
- os=-sunos4.1.1
+ os=sunos4.1.1
;;
pru-*)
- os=-elf
+ os=elf
;;
*-be)
- os=-beos
- ;;
- *-haiku)
- os=-haiku
+ os=beos
;;
*-ibm)
- os=-aix
+ os=aix
;;
*-knuth)
- os=-mmixware
+ os=mmixware
;;
*-wec)
- os=-proelf
+ os=proelf
;;
*-winbond)
- os=-proelf
+ os=proelf
;;
*-oki)
- os=-proelf
+ os=proelf
;;
*-hp)
- os=-hpux
+ os=hpux
;;
*-hitachi)
- os=-hiux
+ os=hiux
;;
i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent)
- os=-sysv
+ os=sysv
;;
*-cbm)
- os=-amigaos
+ os=amigaos
;;
*-dg)
- os=-dgux
+ os=dgux
;;
*-dolphin)
- os=-sysv3
+ os=sysv3
;;
m68k-ccur)
- os=-rtu
+ os=rtu
;;
m88k-omron*)
- os=-luna
+ os=luna
;;
*-next)
- os=-nextstep
+ os=nextstep
;;
*-sequent)
- os=-ptx
+ os=ptx
;;
*-crds)
- os=-unos
+ os=unos
;;
*-ns)
- os=-genix
+ os=genix
;;
i370-*)
- os=-mvs
- ;;
- *-next)
- os=-nextstep3
+ os=mvs
;;
*-gould)
- os=-sysv
+ os=sysv
;;
*-highlevel)
- os=-bsd
+ os=bsd
;;
*-encore)
- os=-bsd
+ os=bsd
;;
*-sgi)
- os=-irix
+ os=irix
;;
*-siemens)
- os=-sysv4
+ os=sysv4
;;
*-masscomp)
- os=-rtu
+ os=rtu
;;
f30[01]-fujitsu | f700-fujitsu)
- os=-uxpv
+ os=uxpv
;;
*-rom68k)
- os=-coff
+ os=coff
;;
*-*bug)
- os=-coff
+ os=coff
;;
*-apple)
- os=-macos
+ os=macos
;;
*-atari*)
- os=-mint
+ os=mint
+ ;;
+ *-wrs)
+ os=vxworks
;;
*)
- os=-none
+ os=none
;;
esac
fi
# Here we handle the case where we know the os, and the CPU type, but not the
# manufacturer. We pick the logical manufacturer.
-vendor=unknown
-case $basic_machine in
- *-unknown)
+case $vendor in
+ unknown)
case $os in
- -riscix*)
+ riscix*)
vendor=acorn
;;
- -sunos*)
+ sunos*)
vendor=sun
;;
- -cnk*|-aix*)
+ cnk*|-aix*)
vendor=ibm
;;
- -beos*)
+ beos*)
vendor=be
;;
- -hpux*)
+ hpux*)
vendor=hp
;;
- -mpeix*)
+ mpeix*)
vendor=hp
;;
- -hiux*)
+ hiux*)
vendor=hitachi
;;
- -unos*)
+ unos*)
vendor=crds
;;
- -dgux*)
+ dgux*)
vendor=dg
;;
- -luna*)
+ luna*)
vendor=omron
;;
- -genix*)
+ genix*)
vendor=ns
;;
- -mvs* | -opened*)
+ clix*)
+ vendor=intergraph
+ ;;
+ mvs* | opened*)
vendor=ibm
;;
- -os400*)
+ os400*)
vendor=ibm
;;
- -ptx*)
+ ptx*)
vendor=sequent
;;
- -tpf*)
+ tpf*)
vendor=ibm
;;
- -vxsim* | -vxworks* | -windiss*)
+ vxsim* | vxworks* | windiss*)
vendor=wrs
;;
- -aux*)
+ aux*)
vendor=apple
;;
- -hms*)
+ hms*)
vendor=hitachi
;;
- -mpw* | -macos*)
+ mpw* | macos*)
vendor=apple
;;
- -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)
+ *mint | mint[0-9]* | *MiNT | MiNT[0-9]*)
vendor=atari
;;
- -vos*)
+ vos*)
vendor=stratus
;;
esac
- basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"`
;;
esac
-echo $basic_machine$os
+echo "$cpu-$vendor-$os"
exit
# Local variables:
-# eval: (add-hook 'write-file-functions 'time-stamp)
+# eval: (add-hook 'before-save-hook 'time-stamp)
# time-stamp-start: "timestamp='"
# time-stamp-format: "%:y-%02m-%02d"
# time-stamp-end: "'"
diff --git a/build-aux/gitlog-to-changelog b/build-aux/gitlog-to-changelog
index 69520eeae70..deddef24466 100755
--- a/build-aux/gitlog-to-changelog
+++ b/build-aux/gitlog-to-changelog
@@ -3,7 +3,7 @@ eval '(exit $?0)' && eval 'exec perl -wS "$0" "$@"'
if 0;
# Convert git log output to ChangeLog format.
-my $VERSION = '2017-09-13 06:45'; # UTC
+my $VERSION = '2018-03-07 03:47'; # UTC
# The definition above must lie within the first 8 lines in order
# for the Emacs time-stamp write hook (at end) to update it.
# If you change this file with Emacs, please let the write hook
@@ -491,7 +491,7 @@ sub git_dir_option($)
# Local Variables:
# mode: perl
# indent-tabs-mode: nil
-# eval: (add-hook 'write-file-hooks 'time-stamp)
+# eval: (add-hook 'before-save-hook 'time-stamp)
# time-stamp-start: "my $VERSION = '"
# time-stamp-format: "%:y-%02m-%02d %02H:%02M"
# time-stamp-time-zone: "UTC0"
diff --git a/build-aux/install-sh b/build-aux/install-sh
index ac159ceda40..8175c640fe6 100755
--- a/build-aux/install-sh
+++ b/build-aux/install-sh
@@ -1,7 +1,7 @@
#!/bin/sh
# install - install a program, script, or datafile
-scriptversion=2017-09-23.17; # UTC
+scriptversion=2018-03-11.20; # UTC
# This originates from X11R5 (mit/util/scripts/install.sh), which was
# later released in X11R6 (xc/config/util/install.sh) with the
@@ -332,34 +332,43 @@ do
# is incompatible with FreeBSD 'install' when (umask & 300) != 0.
;;
*)
+ # Note that $RANDOM variable is not portable (e.g. dash); Use it
+ # here however when possible just to lower collision chance.
tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$
- trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0
+ trap 'ret=$?; rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" 2>/dev/null; exit $ret' 0
+
+ # Because "mkdir -p" follows existing symlinks and we likely work
+ # directly in world-writeable /tmp, make sure that the '$tmpdir'
+ # directory is successfully created first before we actually test
+ # 'mkdir -p' feature.
if (umask $mkdir_umask &&
- exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1
+ $mkdirprog $mkdir_mode "$tmpdir" &&
+ exec $mkdirprog $mkdir_mode -p -- "$tmpdir/a/b") >/dev/null 2>&1
then
if test -z "$dir_arg" || {
# Check for POSIX incompatibilities with -m.
# HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or
# other-writable bit of parent directory when it shouldn't.
# FreeBSD 6.1 mkdir -m -p sets mode of existing directory.
- ls_ld_tmpdir=`ls -ld "$tmpdir"`
+ test_tmpdir="$tmpdir/a"
+ ls_ld_tmpdir=`ls -ld "$test_tmpdir"`
case $ls_ld_tmpdir in
d????-?r-*) different_mode=700;;
d????-?--*) different_mode=755;;
*) false;;
esac &&
- $mkdirprog -m$different_mode -p -- "$tmpdir" && {
- ls_ld_tmpdir_1=`ls -ld "$tmpdir"`
+ $mkdirprog -m$different_mode -p -- "$test_tmpdir" && {
+ ls_ld_tmpdir_1=`ls -ld "$test_tmpdir"`
test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1"
}
}
then posix_mkdir=:
fi
- rmdir "$tmpdir/d" "$tmpdir"
+ rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir"
else
# Remove any dirs left behind by ancient mkdir implementations.
- rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null
+ rmdir ./$mkdir_mode ./-p ./-- "$tmpdir" 2>/dev/null
fi
trap '' 0;;
esac;;
@@ -501,7 +510,7 @@ do
done
# Local variables:
-# eval: (add-hook 'write-file-hooks 'time-stamp)
+# eval: (add-hook 'before-save-hook 'time-stamp)
# time-stamp-start: "scriptversion="
# time-stamp-format: "%:y-%02m-%02d.%02H"
# time-stamp-time-zone: "UTC0"
diff --git a/build-aux/move-if-change b/build-aux/move-if-change
index 69662a3ff8b..9073f1a5001 100755
--- a/build-aux/move-if-change
+++ b/build-aux/move-if-change
@@ -2,7 +2,7 @@
# Like mv $1 $2, but if the files are the same, just delete $1.
# Status is zero if successful, nonzero otherwise.
-VERSION='2017-09-13 06:45'; # UTC
+VERSION='2018-03-07 03:47'; # UTC
# The definition above must lie within the first 8 lines in order
# for the Emacs time-stamp write hook (at end) to update it.
# If you change this file with Emacs, please let the write hook
@@ -36,9 +36,10 @@ The variable CMPPROG can be used to specify an alternative to 'cmp'.
Report bugs to <bug-gnulib@gnu.org>."
+year=`expr "$VERSION" : '\([^-]*\)'`
version=`expr "$VERSION" : '\([^ ]*\)'`
version="move-if-change (gnulib) $version
-Copyright (C) 2011 Free Software Foundation, Inc.
+Copyright $year Free Software Foundation, Inc.
License GPLv3+: GNU GPL version 3 or later <https://gnu.org/licenses/gpl.html>
This is free software: you are free to change and redistribute it.
There is NO WARRANTY, to the extent permitted by law."
@@ -75,7 +76,7 @@ else
fi
## Local Variables:
-## eval: (add-hook 'write-file-hooks 'time-stamp)
+## eval: (add-hook 'before-save-hook 'time-stamp)
## time-stamp-start: "VERSION='"
## time-stamp-format: "%:y-%02m-%02d %02H:%02M"
## time-stamp-time-zone: "UTC0"
diff --git a/build-aux/update-copyright b/build-aux/update-copyright
index 19d881316af..d80549ea8dd 100755
--- a/build-aux/update-copyright
+++ b/build-aux/update-copyright
@@ -3,7 +3,7 @@ eval '(exit $?0)' && eval 'exec perl -wS -0777 -pi "$0" "$@"'
if 0;
# Update an FSF copyright year list to include the current year.
-my $VERSION = '2018-01-04.14:48'; # UTC
+my $VERSION = '2018-03-07.03:47'; # UTC
# Copyright (C) 2009-2019 Free Software Foundation, Inc.
#
@@ -269,7 +269,7 @@ else
# coding: utf-8
# mode: perl
# indent-tabs-mode: nil
-# eval: (add-hook 'write-file-hooks 'time-stamp)
+# eval: (add-hook 'before-save-hook 'time-stamp)
# time-stamp-start: "my $VERSION = '"
# time-stamp-format: "%:y-%02m-%02d.%02H:%02M"
# time-stamp-time-zone: "UTC0"
diff --git a/configure.ac b/configure.ac
index 097c3bc68af..1814a30cbcc 100644
--- a/configure.ac
+++ b/configure.ac
@@ -23,7 +23,7 @@ dnl along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
AC_PREREQ(2.65)
dnl Note this is parsed by (at least) make-dist and lisp/cedet/ede/emacs.el.
-AC_INIT(GNU Emacs, 26.1.92, bug-gnu-emacs@gnu.org)
+AC_INIT(GNU Emacs, 27.0.50, bug-gnu-emacs@gnu.org, , https://www.gnu.org/software/emacs/)
dnl Set emacs_config_options to the options of 'configure', quoted for the shell,
dnl and then quoted again for a C string. Separate options with spaces.
@@ -311,6 +311,80 @@ this option's value should be 'yes', 'no', 'alsa', 'oss', or 'bsd-ossaudio'.])
],
[with_sound=$with_features])
+AC_ARG_WITH([pdumper],
+ AS_HELP_STRING(
+ [--with-pdumper=VALUE],
+ [enable pdumper support unconditionally
+ ('yes', 'no', or 'auto': default 'auto')]),
+ [ case "${withval}" in
+ yes|no|auto) val=$withval ;;
+ *) AC_MSG_ERROR(
+ ['--with-pdumper=$withval' is invalid;
+this option's value should be 'yes' or 'no'.]) ;;
+ esac
+ with_pdumper=$val
+ ],
+ [with_pdumper=auto])
+
+AC_ARG_WITH([unexec],
+ AS_HELP_STRING(
+ [--with-unexec=VALUE],
+ [enable unexec support unconditionally
+ ('yes', 'no', or 'auto': default 'auto')]),
+ [ case "${withval}" in
+ yes|no|auto) val=$withval ;;
+ *) AC_MSG_ERROR(
+ ['--with-unexec=$withval' is invalid;
+this option's value should be 'yes' or 'no'.]) ;;
+ esac
+ with_unexec=$val
+ ],
+ [with_unexec=auto])
+
+AC_ARG_WITH([dumping],[AS_HELP_STRING([--with-dumping=VALUE],
+ [kind of dumping to use for initial Emacs build
+(VALUE one of: pdumper, unexec, none; default pdumper)])],
+ [ case "${withval}" in
+ pdumper|unexec|none) val=$withval ;;
+ *) AC_MSG_ERROR(['--with-dumping=$withval is invalid;
+this option's value should be 'pdumper', 'unexec', or 'none'.])
+ ;;
+ esac
+ with_dumping=$val
+ ],
+ [with_dumping=pdumper])
+
+if test "$with_pdumper" = "auto"; then
+ if test "$with_dumping" = "pdumper"; then
+ with_pdumper=yes
+ else
+ with_pdumper=no
+ fi
+fi
+
+if test "$with_unexec" = "auto"; then
+ if test "$with_dumping" = "unexec"; then
+ with_unexec=yes
+ else
+ with_unexec=no
+ fi
+fi
+
+if test "$with_dumping" = "pdumper" && test "$with_pdumper" = "no"; then
+ AC_MSG_ERROR(['--with-dumping=pdumper' requires pdumper support])
+fi
+
+if test "$with_dumping" = "unexec" && test "$with_unexec" = "no"; then
+ AC_MSG_ERROR(['--with-dumping=unexec' requires unexec support])
+fi
+
+if test "$with_pdumper" = "yes"; then
+ AC_DEFINE(HAVE_PDUMPER, 1, [Define to build with portable dumper support])
+fi
+
+DUMPING=$with_dumping
+AC_SUBST(DUMPING)
+
dnl FIXME currently it is not the last.
dnl This should be the last --with option, because --with-x is
dnl added later on when we find the file name of X, and it's best to
@@ -355,6 +429,7 @@ OPTION_DEFAULT_ON([libsystemd],[don't compile with libsystemd support])
OPTION_DEFAULT_OFF([cairo],[compile with Cairo drawing (experimental)])
OPTION_DEFAULT_ON([xml2],[don't compile with XML parsing support])
OPTION_DEFAULT_ON([imagemagick],[don't compile with ImageMagick image support])
+OPTION_DEFAULT_ON([json], [don't compile with native JSON support])
OPTION_DEFAULT_ON([xft],[don't use XFT for anti aliased fonts])
OPTION_DEFAULT_ON([libotf],[don't use libotf for OpenType font support])
@@ -371,7 +446,12 @@ OPTION_DEFAULT_OFF([w32], [use native MS Windows GUI in a Cygwin build])
OPTION_DEFAULT_ON([gpm],[don't use -lgpm for mouse support on a GNU/Linux console])
OPTION_DEFAULT_ON([dbus],[don't compile with D-Bus support])
AC_ARG_WITH([gconf],[AS_HELP_STRING([--with-gconf],
-[compile with Gconf support (Gsettings replaces this)])],[],[with_gconf=maybe])
+[compile with Gconf support (Gsettings replaces this)])],[],
+[if test $with_features = yes; then
+with_gconf=maybe
+else
+with_gconf=no
+fi])
OPTION_DEFAULT_ON([gsettings],[don't compile with GSettings support])
OPTION_DEFAULT_ON([selinux],[don't compile with SELinux support])
OPTION_DEFAULT_ON([gnutls],[don't use -lgnutls for SSL/TLS support])
@@ -457,19 +537,21 @@ fi)
AC_ARG_ENABLE(checking,
[AS_HELP_STRING([--enable-checking@<:@=LIST@:>@],
- [enable expensive run-time checks. With LIST,
+ [enable expensive checks. With LIST,
enable only specific categories of checks.
Categories are: all,yes,no.
Flags are: stringbytes, stringoverrun, stringfreelist,
- xmallocoverrun, conslist, glyphs])],
+ structs, xmallocoverrun, conslist, glyphs])],
[ac_checking_flags="${enableval}"],[])
IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="$IFS,"
+CHECK_STRUCTS=false
for check in $ac_checking_flags
do
case $check in
# these set all the flags to specific states
yes) ac_enable_checking=1 ;;
no) ac_enable_checking= ;
+ CHECK_STRUCTS=false
ac_gc_check_stringbytes= ;
ac_gc_check_string_overrun= ;
ac_gc_check_string_free_list= ;
@@ -477,6 +559,7 @@ do
ac_gc_check_cons_list= ;
ac_glyphs_debug= ;;
all) ac_enable_checking=1 ;
+ CHECK_STRUCTS=true
ac_gc_check_stringbytes=1 ;
ac_gc_check_string_overrun=1 ;
ac_gc_check_string_free_list=1 ;
@@ -487,6 +570,7 @@ do
stringbytes) ac_gc_check_stringbytes=1 ;;
stringoverrun) ac_gc_check_string_overrun=1 ;;
stringfreelist) ac_gc_check_string_free_list=1 ;;
+ structs) CHECK_STRUCTS=true ;;
xmallocoverrun) ac_xmalloc_overrun=1 ;;
conslist) ac_gc_check_cons_list=1 ;;
glyphs) ac_glyphs_debug=1 ;;
@@ -499,6 +583,15 @@ if test x$ac_enable_checking != x ; then
AC_DEFINE(ENABLE_CHECKING, 1,
[Define to 1 if expensive run-time data type and consistency checks are enabled.])
fi
+if $CHECK_STRUCTS; then
+ AC_DEFINE([CHECK_STRUCTS], 1,
+ [Define this to check whether someone updated the portable dumper
+ code after changing the layout of a structure that it uses.
+ If you change one of these structures, check that the pdumper.c
+ code is still valid, and update the pertinent hash in pdumper.c
+ by manually copying the hash from the newly-generated dmpstruct.h.])
+fi
+AC_SUBST([CHECK_STRUCTS])
if test x$ac_gc_check_stringbytes != x ; then
AC_DEFINE(GC_CHECK_STRING_BYTES, 1,
[Define this temporarily to hunt a bug. If defined, the size of
@@ -704,7 +797,9 @@ case "${canonical}" in
opsys=qnxnto
test -z "$CC" && CC=qcc
CFLAGS="$CFLAGS -D__NO_EXT_QNX"
- LDFLAGS="-N2MB $LDFLAGS"
+ if test "$with_unexec" = yes; then
+ LDFLAGS="-N2MB $LDFLAGS"
+ fi
;;
## Intel 386 machines where we don't care about the manufacturer.
@@ -899,10 +994,9 @@ AC_ARG_ENABLE([gcc-warnings],
AC_ARG_ENABLE([check-lisp-object-type],
[AS_HELP_STRING([--enable-check-lisp-object-type],
- [Enable compile-time checks for the Lisp_Object data type,
- which can catch some bugs during development.
- The default is "no" if --enable-gcc-warnings is "no".])])
-if test "${enable_check_lisp_object_type-$gl_gcc_warnings}" != "no"; then
+ [Enable compile time checks for the Lisp_Object data type,
+ which can catch some bugs during development.])])
+if test "$enable_check_lisp_object_type" = yes; then
AC_DEFINE([CHECK_LISP_OBJECT_TYPE], 1,
[Define to enable compile-time checks for the Lisp_Object data type.])
fi
@@ -947,13 +1041,13 @@ AS_IF([test $gl_gcc_warnings = no],
AS_IF([test $gl_gcc_warnings = yes],
[WERROR_CFLAGS=-Werror])
+ nw="$nw -Wcast-align -Wcast-align=strict" # Emacs is tricky with pointers.
nw="$nw -Wduplicated-branches" # Too many false alarms
nw="$nw -Wformat-overflow=2" # False alarms due to GCC bug 80776
nw="$nw -Wsystem-headers" # Don't let system headers trigger warnings
nw="$nw -Woverlength-strings" # Not a problem these days
nw="$nw -Wformat-nonliteral" # we do this a lot
nw="$nw -Wvla" # Emacs uses <vla.h>.
- nw="$nw -Wswitch-default" # Too many warnings for now
nw="$nw -Wunused-const-variable=2" # lisp.h declares const objects.
nw="$nw -Winline" # OK to ignore 'inline'
nw="$nw -Wstrict-overflow" # OK to optimize assuming that
@@ -1014,9 +1108,10 @@ AS_IF([test $gl_gcc_warnings = no],
gl_WARN_ADD([-Wno-unused-parameter]) # Too many warnings for now
gl_WARN_ADD([-Wno-format-nonliteral])
- # clang is unduly picky about braces.
+ # clang is unduly picky about some things.
if test "$emacs_cv_clang" = yes; then
gl_WARN_ADD([-Wno-missing-braces])
+ gl_WARN_ADD([-Wno-null-pointer-arithmetic])
fi
# This causes too much noise in the MinGW build
@@ -1209,6 +1304,10 @@ AC_PATH_PROG(GZIP_PROG, gzip)
test $with_compress_install != yes && test -n "$GZIP_PROG" && \
GZIP_PROG=" # $GZIP_PROG # (disabled by configure --without-compress-install)"
+if test "$with_dumping" = "unexec" && test "$opsys" = "nacl"; then
+ AC_MSG_ERROR([nacl is not compatible with --with-dumping=unexec])
+fi
+
AC_CACHE_CHECK([for 'find' args to delete a file],
[emacs_cv_find_delete],
[if touch conftest.tmp && find conftest.tmp -delete 2>/dev/null &&
@@ -1221,7 +1320,7 @@ AC_SUBST([FIND_DELETE])
PAXCTL_dumped=
PAXCTL_notdumped=
-if test $opsys = gnu-linux; then
+if test $with_unexec = yes && test $opsys = gnu-linux; then
if test "${SETFATTR+set}" != set; then
AC_CACHE_CHECK([for setfattr],
[emacs_cv_prog_setfattr],
@@ -1237,36 +1336,43 @@ if test $opsys = gnu-linux; then
else
SETFATTR=
fi
- rm -f conftest.tmp
- AC_SUBST([SETFATTR])
fi
-fi
-case $opsys,$PAXCTL_notdumped,$emacs_uname_r in
- gnu-linux,,* | netbsd,,[0-7].*)
- AC_PATH_PROG([PAXCTL], [paxctl], [],
- [$PATH$PATH_SEPARATOR/sbin$PATH_SEPARATOR/usr/sbin])
- if test -n "$PAXCTL"; then
- if test "$opsys" = netbsd; then
- PAXCTL_dumped='$(PAXCTL) +a'
- PAXCTL_notdumped=$PAXCTL_dumped
- else
- AC_MSG_CHECKING([whether binaries have a PT_PAX_FLAGS header])
- AC_LINK_IFELSE([AC_LANG_PROGRAM([], [])],
- [if $PAXCTL -v conftest$EXEEXT >/dev/null 2>&1; then
- AC_MSG_RESULT([yes])
- else
- AC_MSG_RESULT([no])
- PAXCTL=
- fi])
- if test -n "$PAXCTL"; then
- PAXCTL_dumped='$(PAXCTL) -zex'
- PAXCTL_notdumped='$(PAXCTL) -r'
+ case $opsys,$PAXCTL_notdumped,$emacs_uname_r in
+ gnu-linux,,* | netbsd,,[0-7].*)
+ AC_PATH_PROG([PAXCTL], [paxctl], [],
+ [$PATH$PATH_SEPARATOR/sbin$PATH_SEPARATOR/usr/sbin])
+ if test -n "$PAXCTL"; then
+ if test "$opsys" = netbsd; then
+ PAXCTL_dumped='$(PAXCTL) +a'
+ PAXCTL_notdumped=$PAXCTL_dumped
+ else
+ AC_MSG_CHECKING([whether binaries have a PT_PAX_FLAGS header])
+ AC_LINK_IFELSE([AC_LANG_PROGRAM([], [])],
+ [if $PAXCTL -v conftest$EXEEXT >/dev/null 2>&1; then
+ AC_MSG_RESULT([yes])
+ else
+ AC_MSG_RESULT([no])
+ PAXCTL=
+ fi])
+ if test -n "$PAXCTL"; then
+ PAXCTL_dumped='$(PAXCTL) -zex'
+ PAXCTL_notdumped='$(PAXCTL) -r'
+ fi
fi
- fi
- fi;;
-esac
+ fi;;
+ esac
+fi
AC_SUBST([PAXCTL_dumped])
AC_SUBST([PAXCTL_notdumped])
+AC_SUBST([SETFATTR])
+
+# Makeinfo on macOS is ancient, check whether there is a more recent
+# version installed by Homebrew.
+AC_CHECK_PROGS(BREW, [brew])
+if test -n "$BREW"; then
+ AC_PATH_PROG([MAKEINFO], [makeinfo], [],
+ [`$BREW --prefix texinfo 2>/dev/null`/bin$PATH_SEPARATOR$PATH])
+fi
## Require makeinfo >= 4.13 (last of the 4.x series) to build the manuals.
if test "${MAKEINFO:=makeinfo}" != "no"; then
@@ -1320,37 +1426,35 @@ else
ac_link="$ac_link $NON_GCC_LINK_TEST_OPTIONS"
fi
-dnl We need -znocombreloc if we're using a relatively recent GNU ld.
-dnl If we can link with the flag, it shouldn't do any harm anyhow.
-dnl Treat GCC specially since it just gives a non-fatal 'unrecognized option'
+dnl On some platforms using GNU ld, linking temacs needs -znocombreloc.
+dnl Although this has something to do with dumping, the details are unknown.
+dnl If the flag is used but not needed,
+dnl Emacs should still work (albeit a bit more slowly),
+dnl so use the flag everywhere that it is supported.
+dnl When testing whether the flag works, treat GCC specially
+dnl since it just gives a non-fatal 'unrecognized option'
dnl if not built to support GNU ld.
-
-dnl For a long time, -znocombreloc was added to LDFLAGS rather than
-dnl LD_SWITCH_SYSTEM_TEMACS. That is:
-dnl * inappropriate, as LDFLAGS is a user option but this is essential.
-dnl Eg "make LDFLAGS=... all" could run into problems,
-dnl https://bugs.debian.org/684788
-dnl * unnecessary, since temacs is the only thing that actually needs it.
-dnl Indeed this is where it was originally, prior to:
-dnl https://lists.gnu.org/r/emacs-pretest-bug/2004-03/msg00170.html
-if test x$GCC = xyes; then
+if test "$GCC" = yes; then
LDFLAGS_NOCOMBRELOC="-Wl,-znocombreloc"
else
LDFLAGS_NOCOMBRELOC="-znocombreloc"
fi
AC_CACHE_CHECK([for -znocombreloc], [emacs_cv_znocombreloc],
-[late_LDFLAGS="$LDFLAGS"
-LDFLAGS="$LDFLAGS $LDFLAGS_NOCOMBRELOC"
-
-AC_LINK_IFELSE([AC_LANG_PROGRAM([], [])],
- [emacs_cv_znocombreloc=yes], [emacs_cv_znocombreloc=no])
-
-LDFLAGS="$late_LDFLAGS"])
+ [if test $with_unexec = no; then
+ emacs_cv_znocombreloc='not needed'
+ else
+ save_LDFLAGS=$LDFLAGS
+ LDFLAGS="$LDFLAGS $LDFLAGS_NOCOMBRELOC"
+ AC_LINK_IFELSE([AC_LANG_PROGRAM([], [])],
+ [emacs_cv_znocombreloc=yes], [emacs_cv_znocombreloc=no])
+ LDFLAGS=$save_LDFLAGS
+ fi])
-if test x$emacs_cv_znocombreloc = xno; then
- LDFLAGS_NOCOMBRELOC=
-fi
+case $emacs_cv_znocombreloc in
+ no*)
+ LDFLAGS_NOCOMBRELOC= ;;
+esac
AC_CACHE_CHECK([whether addresses are sanitized],
@@ -1368,23 +1472,16 @@ AC_CACHE_CHECK([whether addresses are sanitized],
[emacs_cv_sanitize_address=yes],
[emacs_cv_sanitize_address=no])])
-dnl The function dump-emacs will not be defined and temacs will do
-dnl (load "loadup") automatically unless told otherwise.
-test "x$CANNOT_DUMP" = "x" && CANNOT_DUMP=no
-case "$opsys" in
- nacl) CANNOT_DUMP=yes ;;
-esac
-
-if test "$CANNOT_DUMP" = "yes"; then
- AC_DEFINE(CANNOT_DUMP, 1, [Define if Emacs cannot be dumped on your system.])
-elif test "$emacs_cv_sanitize_address" = yes; then
- AC_MSG_WARN([[Addresses are sanitized; suggest CANNOT_DUMP=yes]])
+if test $with_unexec = yes; then
+ AC_DEFINE([HAVE_UNEXEC], 1, [Define if Emacs supports unexec.])
+ if test "$emacs_cv_sanitize_address" = yes; then
+ AC_MSG_WARN([[Addresses are sanitized; suggest --without-unexec]])
+ fi
fi
-AC_SUBST(CANNOT_DUMP)
-
-UNEXEC_OBJ=unexelf.o
+UNEXEC_OBJ=
+test $with_unexec = yes &&
case "$opsys" in
# MSDOS uses unexcoff.o
aix4-2)
@@ -1412,11 +1509,13 @@ case "$opsys" in
# not been tested, so for now this change is for Solaris 10 or newer.
UNEXEC_OBJ=unexsol.o
;;
+ *)
+ UNEXEC_OBJ=unexelf.o
+ ;;
esac
-test "$CANNOT_DUMP" = "yes" && UNEXEC_OBJ=
LD_SWITCH_SYSTEM=
-case "$opsys" in
+test "$with_unexec" = no || case "$opsys" in
freebsd|dragonfly)
## Let 'ld' find image libs and similar things in /usr/local/lib.
## The system compiler, GCC, has apparently been modified to not
@@ -1462,8 +1561,9 @@ case "$opsys" in
LD_SWITCH_SYSTEM="\$(LD_SWITCH_X_SITE_RPATH) $LD_SWITCH_SYSTEM" ;;
esac
-
C_SWITCH_MACHINE=
+
+test $with_unexec = yes &&
case $canonical in
alpha*)
AC_CHECK_DECL([__ELF__])
@@ -2076,7 +2176,7 @@ if test "${HAVE_W32}" = "yes"; then
AC_CHECK_TOOL(WINDRES, [windres],
[AC_MSG_ERROR([No resource compiler found.])])
W32_OBJ="w32fns.o w32menu.o w32reg.o w32font.o w32term.o"
- W32_OBJ="$W32_OBJ w32xfns.o w32select.o w32uniscribe.o"
+ W32_OBJ="$W32_OBJ w32xfns.o w32select.o w32uniscribe.o w32cygwinx.o"
EMACSRES="emacs.res"
case "$canonical" in
x86_64-*-*) EMACS_MANIFEST="emacs-x64.manifest" ;;
@@ -2111,6 +2211,12 @@ if test "${HAVE_W32}" = "yes"; then
XARGS_LIMIT="-s 10000"
fi
fi
+
+if test "${HAVE_W32}" = "no" && test "${opsys}" = "cygwin"; then
+ W32_LIBS="-lkernel32"
+ W32_OBJ="w32cygwinx.o"
+fi
+
AC_SUBST(W32_OBJ)
AC_SUBST(W32_LIBS)
AC_SUBST(EMACSRES)
@@ -2216,7 +2322,7 @@ doug_lea_malloc=$emacs_cv_var_doug_lea_malloc
hybrid_malloc=
system_malloc=yes
-test "$CANNOT_DUMP" = yes ||
+test $with_unexec = yes &&
case "$opsys" in
## darwin ld insists on the use of malloc routines in the System framework.
darwin | mingw32 | nacl | sol2-10) ;;
@@ -2521,11 +2627,20 @@ fi
HAVE_IMAGEMAGICK=no
if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" || test "${HAVE_W32}" = "yes"; then
if test "${with_imagemagick}" != "no"; then
- ## 6.3.5 is the earliest version known to work; see Bug#17339.
- ## 6.8.2 makes Emacs crash; see Bug#13867.
- ## 7 and later have not been ported to; See Bug#25967.
- IMAGEMAGICK_MODULE="Wand >= 6.3.5 Wand != 6.8.2 Wand < 7"
- EMACS_CHECK_MODULES([IMAGEMAGICK], [$IMAGEMAGICK_MODULE])
+ if test -n "$BREW"; then
+ # Homebrew doesn't link ImageMagick 6 by default, so make sure
+ # pkgconfig can find it.
+ export PKG_CONFIG_PATH="$PKG_CONFIG_PATH$PATH_SEPARATOR`$BREW --prefix imagemagick@6 2>/dev/null`/lib/pkgconfig"
+ fi
+
+ EMACS_CHECK_MODULES([IMAGEMAGICK], [MagickWand >= 7])
+ if test $HAVE_IMAGEMAGICK = yes; then
+ AC_DEFINE([HAVE_IMAGEMAGICK7], 1, [Define to 1 if using ImageMagick7.])
+ else
+ ## 6.3.5 is the earliest version known to work; see Bug#17339.
+ ## 6.8.2 makes Emacs crash; see Bug#13867.
+ EMACS_CHECK_MODULES([IMAGEMAGICK], [Wand >= 6.3.5 Wand != 6.8.2])
+ fi
if test $HAVE_IMAGEMAGICK = yes; then
OLD_CFLAGS=$CFLAGS
@@ -2839,7 +2954,7 @@ fi
AC_SUBST(LIBSELINUX_LIBS)
HAVE_GNUTLS=no
-if test "${with_gnutls}" = "yes" ; then
+if test "${with_gnutls}" != "no" ; then
EMACS_CHECK_MODULES([LIBGNUTLS], [gnutls >= 2.12.2],
[HAVE_GNUTLS=yes], [HAVE_GNUTLS=no])
if test "${HAVE_GNUTLS}" = "yes"; then
@@ -2870,6 +2985,27 @@ fi
AC_SUBST(LIBSYSTEMD_LIBS)
AC_SUBST(LIBSYSTEMD_CFLAGS)
+HAVE_JSON=no
+JSON_OBJ=
+
+if test "${with_json}" = yes; then
+ EMACS_CHECK_MODULES([JSON], [jansson >= 2.7],
+ [HAVE_JSON=yes], [HAVE_JSON=no])
+ if test "${HAVE_JSON}" = yes; then
+ AC_DEFINE(HAVE_JSON, 1, [Define if using Jansson.])
+ JSON_OBJ=json.o
+ fi
+
+ # Windows loads libjansson dynamically
+ if test "${opsys}" = "mingw32"; then
+ JSON_LIBS=
+ fi
+fi
+
+AC_SUBST(JSON_LIBS)
+AC_SUBST(JSON_CFLAGS)
+AC_SUBST(JSON_OBJ)
+
NOTIFY_OBJ=
NOTIFY_SUMMARY=no
@@ -3191,6 +3327,17 @@ either XPointer or XPointer*.])dnl
CFLAGS=$late_CFLAGS
fi
+# Check for XRender
+HAVE_XRENDER=no
+if test "${HAVE_X11}" = "yes"; then
+ AC_CHECK_LIB(Xrender, XRenderQueryExtension, HAVE_XRENDER=yes)
+ if test $HAVE_XRENDER = yes; then
+ XRENDER_LIBS="-lXrender"
+ AC_SUBST(XRENDER_LIBS)
+ AC_DEFINE([HAVE_XRENDER], 1, [Define to 1 if XRender is available.])
+ fi
+fi
+
### Start of font-backend (under any platform) section.
# (nothing here yet -- this is a placeholder)
### End of font-backend (under any platform) section.
@@ -3213,15 +3360,12 @@ if test "${HAVE_X11}" = "yes"; then
EMACS_CHECK_MODULES([XFT], [xft >= 0.13.0], [], [HAVE_XFT=no])
## Because xterm.c uses XRenderQueryExtension when XFT is
## enabled, we also need to link to -lXrender.
- HAVE_XRENDER=no
- AC_CHECK_LIB(Xrender, XRenderQueryExtension, HAVE_XRENDER=yes)
if test "$HAVE_XFT" != no && test "$HAVE_XRENDER" != no; then
OLD_CPPFLAGS="$CPPFLAGS"
OLD_CFLAGS="$CFLAGS"
OLD_LIBS="$LIBS"
CPPFLAGS="$CPPFLAGS $XFT_CFLAGS"
CFLAGS="$CFLAGS $XFT_CFLAGS"
- XFT_LIBS="-lXrender $XFT_LIBS"
LIBS="$XFT_LIBS $LIBS"
AC_CHECK_HEADER(X11/Xft/Xft.h,
AC_CHECK_LIB(Xft, XftFontOpen, HAVE_XFT=yes, , $XFT_LIBS) , ,
@@ -3272,6 +3416,10 @@ if test "${HAVE_X11}" = "yes"; then
AC_DEFINE(HAVE_OTF_GET_VARIATION_GLYPHS, 1,
[Define to 1 if libotf has OTF_get_variation_glyphs.])
fi
+ if ! $PKG_CONFIG --atleast-version=0.9.16 libotf; then
+ AC_DEFINE(HAVE_OTF_KANNADA_BUG, 1,
+[Define to 1 if libotf is affected by https://debbugs.gnu.org/28110.])
+ fi
fi
fi
dnl FIXME should there be an error if HAVE_FREETYPE != yes?
@@ -3377,7 +3525,10 @@ fi
if test "${HAVE_X11}" = "yes"; then
dnl Avoid Xpm on AIX unless requested, as it crashes; see Bug#17598.
- test "$opsys$with_xpm_set" = aix4-2 && with_xpm=no
+ case $opsys,$with_xpm_set,$with_xpm in
+ aix4-2,set,yes) ;;
+ aix4-2,*) with_xpm=no;;
+ esac
if test "${with_xpm}" != "no"; then
AC_CHECK_HEADER(X11/xpm.h,
@@ -3428,7 +3579,9 @@ AC_SUBST(LIBXPM)
### Use -ljpeg if available, unless '--with-jpeg=no'.
HAVE_JPEG=no
LIBJPEG=
-if test "${with_jpeg}" != "no"; then
+if test "${NS_IMPL_COCOA}" = yes; then
+ : # Cocoa provides its own jpeg support, so do nothing.
+elif test "${with_jpeg}" != "no"; then
AC_CACHE_CHECK([for jpeglib 6b or later],
[emacs_cv_jpeglib],
[OLD_LIBS=$LIBS
@@ -3471,23 +3624,20 @@ fi
AC_SUBST(LIBJPEG)
HAVE_LCMS2=no
-LIBLCMS2=
+LCMS2_CFLAGS=
+LCMS2_LIBS=
if test "${with_lcms2}" != "no"; then
- OLIBS=$LIBS
- AC_SEARCH_LIBS([cmsCreateTransform], [lcms2], [HAVE_LCMS2=yes])
- LIBS=$OLIBS
- case $ac_cv_search_cmsCreateTransform in
- -*) LIBLCMS2=$ac_cv_search_cmsCreateTransform ;;
- esac
+ EMACS_CHECK_MODULES([LCMS2], [lcms2])
fi
if test "${HAVE_LCMS2}" = "yes"; then
AC_DEFINE([HAVE_LCMS2], 1, [Define to 1 if you have the lcms2 library (-llcms2).])
### mingw32 doesn't use -llcms2, since it loads the library dynamically.
if test "${opsys}" = "mingw32"; then
- LIBLCMS2=
+ LCMS2_LIBS=
fi
fi
-AC_SUBST(LIBLCMS2)
+AC_SUBST(LCMS2_CFLAGS)
+AC_SUBST(LCMS2_LIBS)
HAVE_ZLIB=no
LIBZ=
@@ -3555,53 +3705,64 @@ AC_SUBST(MODULES_SUFFIX)
AC_CONFIG_FILES([src/emacs-module.h])
AC_SUBST_FILE([module_env_snippet_25])
AC_SUBST_FILE([module_env_snippet_26])
+AC_SUBST_FILE([module_env_snippet_27])
module_env_snippet_25="$srcdir/src/module-env-25.h"
module_env_snippet_26="$srcdir/src/module-env-26.h"
+module_env_snippet_27="$srcdir/src/module-env-27.h"
### Use -lpng if available, unless '--with-png=no'.
HAVE_PNG=no
LIBPNG=
PNG_CFLAGS=
if test "${NS_IMPL_COCOA}" = yes; then
- : # Nothing to do
+ : # Cocoa provides its own png support, so do nothing.
elif test "${with_png}" != no; then
# mingw32 loads the library dynamically.
if test "$opsys" = mingw32; then
AC_CHECK_HEADER([png.h], [HAVE_PNG=yes])
elif test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes"; then
- AC_MSG_CHECKING([for png])
- png_cflags=`(libpng-config --cflags) 2>&AS_MESSAGE_LOG_FD` &&
- png_ldflags=`(libpng-config --ldflags) 2>&AS_MESSAGE_LOG_FD` || {
- # libpng-config does not work; configure by hand.
- # Debian unstable as of July 2003 has multiple libpngs, and puts png.h
- # in /usr/include/libpng.
- if test -r /usr/include/libpng/png.h &&
- test ! -r /usr/include/png.h; then
- png_cflags=-I/usr/include/libpng
- else
- png_cflags=
- fi
- png_ldflags='-lpng'
- }
- SAVE_CFLAGS=$CFLAGS
- SAVE_LIBS=$LIBS
- CFLAGS="$CFLAGS $png_cflags"
- LIBS="$png_ldflags -lz -lm $LIBS"
- AC_LINK_IFELSE(
- [AC_LANG_PROGRAM([[#include <png.h>]],
- [[return !png_get_channels (0, 0);]])],
- [HAVE_PNG=yes
- PNG_CFLAGS=`AS_ECHO(["$png_cflags"]) | sed -e "$edit_cflags"`
- LIBPNG=$png_ldflags
- # $LIBPNG requires explicit -lz in some cases.
- # We don't know what those cases are, exactly, so play it safe and
- # append -lz to any nonempty $LIBPNG, unless we're already using LIBZ.
- if test -n "$LIBPNG" && test -z "$LIBZ"; then
- LIBPNG="$LIBPNG -lz"
- fi])
- CFLAGS=$SAVE_CFLAGS
- LIBS=$SAVE_LIBS
- AC_MSG_RESULT([$HAVE_PNG])
+ EMACS_CHECK_MODULES([PNG], [libpng >= 1.0.0])
+ if test $HAVE_PNG = yes; then
+ LIBPNG=$PNG_LIBS
+ else
+ # Test old way in case pkg-config doesn't have it (older machines).
+ AC_MSG_CHECKING([for libpng not configured by pkg-config])
+
+ png_cflags=`(libpng-config --cflags) 2>&AS_MESSAGE_LOG_FD` &&
+ png_ldflags=`(libpng-config --ldflags) 2>&AS_MESSAGE_LOG_FD` || {
+ # libpng-config does not work; configure by hand.
+ # Debian unstable as of July 2003 has multiple libpngs, and puts png.h
+ # in /usr/include/libpng.
+ if test -r /usr/include/libpng/png.h &&
+ test ! -r /usr/include/png.h; then
+ png_cflags=-I/usr/include/libpng
+ else
+ png_cflags=
+ fi
+ png_ldflags='-lpng'
+ }
+ SAVE_CFLAGS=$CFLAGS
+ SAVE_LIBS=$LIBS
+ CFLAGS="$CFLAGS $png_cflags"
+ LIBS="$png_ldflags -lz -lm $LIBS"
+ AC_LINK_IFELSE(
+ [AC_LANG_PROGRAM([[#include <png.h>]],
+ [[return !png_get_channels (0, 0);]])],
+ [HAVE_PNG=yes
+ PNG_CFLAGS=`AS_ECHO(["$png_cflags"]) | sed -e "$edit_cflags"`
+ LIBPNG=$png_ldflags])
+ CFLAGS=$SAVE_CFLAGS
+ LIBS=$SAVE_LIBS
+ AC_MSG_RESULT([$HAVE_PNG])
+ fi
+
+ # $LIBPNG requires explicit -lz in some cases.
+ # We don't know what those cases are, exactly, so play it safe and
+ # append -lz to any nonempty $LIBPNG, unless we're already using LIBZ.
+ case " $LIBPNG ",$LIBZ in
+ *' -lz '*, | *' ',?*) ;;
+ *) LIBPNG="$LIBPNG -lz" ;;
+ esac
fi
fi
if test $HAVE_PNG = yes; then
@@ -3685,28 +3846,46 @@ AC_SUBST(LIBGIF)
dnl Check for required libraries.
MISSING=
-WITH_NO=
+WITH_IFAVAILABLE=
if test "${HAVE_X11}" = "yes"; then
- test "${with_xpm}" != "no" && test "${HAVE_XPM}" != "yes" &&
- MISSING="libXpm" && WITH_NO="--with-xpm=no"
- test "${with_jpeg}" != "no" && test "${HAVE_JPEG}" != "yes" &&
- MISSING="$MISSING libjpeg" && WITH_NO="$WITH_NO --with-jpeg=no"
- test "${with_png}" != "no" && test "${HAVE_PNG}" != "yes" &&
- MISSING="$MISSING libpng" && WITH_NO="$WITH_NO --with-png=no"
- test "${with_gif}" != "no" && test "${HAVE_GIF}" != "yes" &&
- MISSING="$MISSING libgif/libungif" && WITH_NO="$WITH_NO --with-gif=no"
- test "${with_tiff}" != "no" && test "${HAVE_TIFF}" != "yes" &&
- MISSING="$MISSING libtiff" && WITH_NO="$WITH_NO --with-tiff=no"
-fi
-test "${with_gnutls}" != "no" && test "${HAVE_GNUTLS}" != "yes" &&
- MISSING="$MISSING gnutls" && WITH_NO="$WITH_NO --with-gnutls=no"
+ case $with_xpm,$HAVE_XPM in
+ no,* | ifavailable,* | *,yes) ;;
+ *) MISSING="libXpm"
+ WITH_IFAVAILABLE="--with-xpm=ifavailable";;
+ esac
+ case $with_jpeg,$HAVE_JPEG in
+ no,* | ifavailable,* | *,yes) ;;
+ *) MISSING="$MISSING libjpeg"
+ WITH_IFAVAILABLE="$WITH_IFAVAILABLE --with-jpeg=ifavailable";;
+ esac
+ case $with_png,$HAVE_PNG in
+ no,* | ifavailable,* | *,yes) ;;
+ *) MISSING="$MISSING libpng"
+ WITH_IFAVAILABLE="$WITH_IFAVAILABLE --with-png=ifavailable";;
+ esac
+ case $with_gif,$HAVE_GIF in
+ no,* | ifavailable,* | *,yes) ;;
+ *) MISSING="$MISSING libgif/libungif"
+ WITH_IFAVAILABLE="$WITH_IFAVAILABLE --with-gif=ifavailable";;
+ esac
+ case $with_tiff,$HAVE_TIFF in
+ no,* | ifavailable,* | *,yes) ;;
+ *) MISSING="$MISSING libtiff"
+ WITH_IFAVAILABLE="$WITH_IFAVAILABLE --with-tiff=ifavailable";;
+ esac
+fi
+case $with_gnutls,$HAVE_GNUTLS in
+ no,* | ifavailable,* | *,yes) ;;
+ *) MISSING="$MISSING gnutls"
+ WITH_IFAVAILABLE="$WITH_IFAVAILABLE --with-gnutls=ifavailable";;
+esac
if test "X${MISSING}" != X; then
AC_MSG_ERROR([The following required libraries were not found:
$MISSING
Maybe some development libraries/packages are missing?
-If you don't want to link with them give
- $WITH_NO
-as options to configure])
+To build anyway, give:
+ $WITH_IFAVAILABLE
+as options to configure.])
fi
### Use -lgpm if available, unless '--with-gpm=no'.
@@ -3862,13 +4041,13 @@ if test "${with_xml2}" != "no"; then
xcsdkdir="" ;;
esac
fi
- CPPFLAGS="$CPPFLAGS -I$xcsdkdir/usr/include/libxml2"
+ CPPFLAGS="$CPPFLAGS -isystem${xcsdkdir}/usr/include/libxml2"
AC_CHECK_HEADER(libxml/HTMLparser.h,
[AC_CHECK_DECL(HTML_PARSE_RECOVER, HAVE_LIBXML2=yes, ,
[#include <libxml/HTMLparser.h>])])
CPPFLAGS="$SAVE_CPPFLAGS"
if test "${HAVE_LIBXML2}" = "yes"; then
- LIBXML2_CFLAGS="-I'$xcsdkdir/usr/include/libxml2'"
+ LIBXML2_CFLAGS="-isystem${xcsdkdir}/usr/include/libxml2"
LIBXML2_LIBS="-lxml2"
fi
fi
@@ -3983,7 +4162,7 @@ getrusage get_current_dir_name \
lrand48 random rint trunc \
select getpagesize setlocale newlocale \
getrlimit setrlimit shutdown \
-pthread_sigmask strsignal setitimer \
+pthread_sigmask strsignal setitimer timer_getoverrun \
sendto recvfrom getsockname getifaddrs freeifaddrs \
gai_strerror sync \
getpwent endpwent getgrent endgrent \
@@ -3994,6 +4173,9 @@ dnl No need to check for posix_memalign if aligned_alloc works.
AC_CHECK_FUNCS([aligned_alloc posix_memalign], [break])
AC_CHECK_DECLS([aligned_alloc], [], [], [[#include <stdlib.h>]])
+# Dump loading
+AC_CHECK_FUNCS([posix_madvise])
+
dnl Cannot use AC_CHECK_FUNCS
AC_CACHE_CHECK([for __builtin_frame_address],
[emacs_cv_func___builtin_frame_address],
@@ -4049,7 +4231,8 @@ AC_CACHE_CHECK([for library containing tputs], [emacs_cv_tputs_lib],
emacs_cv_tputs_lib='none required'
else
# curses precedes termcap because of AIX (Bug#9736#35) and OpenIndiana.
- for tputs_library in '' tinfo ncurses terminfo curses termcap; do
+ tputs_libraries='tinfo ncurses terminfo curses termcap tinfow ncursesw'
+ for tputs_library in '' $tputs_libraries; do
OLIBS=$LIBS
if test -z "$tputs_library"; then
emacs_cv_tputs_lib='none required'
@@ -4145,10 +4328,6 @@ AC_SUBST(LIBS_TERMCAP)
AC_SUBST(TERMCAP_OBJ)
# GNU/Linux-specific timer functions.
-# Bug#34618.
-if test "$opsys" = "cygwin"; then
- emacs_cv_have_timerfd=no
-fi
AC_CACHE_CHECK([for timerfd interface], [emacs_cv_have_timerfd],
[AC_COMPILE_IFELSE(
[AC_LANG_PROGRAM([[#include <sys/timerfd.h>
@@ -4280,26 +4459,38 @@ AC_SUBST(KRB5LIB)
AC_SUBST(DESLIB)
AC_SUBST(KRB4LIB)
+AC_ARG_WITH([libgmp],
+ [AS_HELP_STRING([--without-libgmp],
+ [don't use the GNU Multiple Precision (GMP) library;
+ this is the default on systems lacking libgmp.])])
+GMP_LIB=
+GMP_OBJ=mini-gmp-emacs.o
+HAVE_GMP=no
+case $with_libgmp in
+ no) ;;
+ yes) HAVE_GMP=yes GMP_LIB=-lgmp;;
+ *) AC_CHECK_HEADERS([gmp.h],
+ [OLIBS=$LIBS
+ AC_SEARCH_LIBS([__gmpz_roinit_n], [gmp])
+ LIBS=$OLIBS
+ case $ac_cv_search___gmpz_roinit_n in
+ 'none needed') HAVE_GMP=yes;;
+ -*) HAVE_GMP=yes GMP_LIB=$ac_cv_search___gmpz_roinit_n;;
+ esac]);;
+esac
+if test "$HAVE_GMP" = yes; then
+ GMP_OBJ=
+ AC_DEFINE([HAVE_GMP], 1, [Define to 1 if you have recent-enough GMP.])
+fi
+AC_SUBST([GMP_LIB])
+AC_SUBST([GMP_OBJ])
+
AC_CHECK_HEADERS(valgrind/valgrind.h)
AC_CHECK_MEMBERS([struct unipair.unicode], [], [], [[#include <linux/kd.h>]])
AC_CHECK_FUNCS_ONCE([sbrk])
-ok_so_far=yes
-AC_CHECK_FUNC(socket, , ok_so_far=no)
-if test $ok_so_far = yes; then
- AC_CHECK_HEADER(netinet/in.h, , ok_so_far=no)
-fi
-if test $ok_so_far = yes; then
- AC_CHECK_HEADER(arpa/inet.h, , ok_so_far=no)
-fi
-if test $ok_so_far = yes; then
-dnl Fixme: Not used. Should this be HAVE_SOCKETS?
- AC_DEFINE(HAVE_INET_SOCKETS, 1,
- [Define to 1 if you have inet sockets.])
-fi
-
AC_FUNC_FORK
AC_CHECK_FUNCS(snprintf)
@@ -4337,15 +4528,27 @@ fi
AC_SUBST(XGSELOBJ)
dnl Adapted from Haible's version.
-AC_CACHE_CHECK([for nl_langinfo and CODESET], emacs_cv_langinfo_codeset,
+AC_CACHE_CHECK([for nl_langinfo and CODESET], [emacs_cv_langinfo_codeset],
[AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <langinfo.h>]],
- [[char* cs = nl_langinfo(CODESET);]])],
- emacs_cv_langinfo_codeset=yes,
- emacs_cv_langinfo_codeset=no)
+ [[char *cs = nl_langinfo(CODESET);]])],
+ [emacs_cv_langinfo_codeset=yes],
+ [emacs_cv_langinfo_codeset=no])
])
-if test $emacs_cv_langinfo_codeset = yes; then
- AC_DEFINE(HAVE_LANGINFO_CODESET, 1,
- [Define if you have <langinfo.h> and nl_langinfo(CODESET).])
+if test "$emacs_cv_langinfo_codeset" = yes; then
+ AC_DEFINE([HAVE_LANGINFO_CODESET], 1,
+ [Define if you have <langinfo.h> and nl_langinfo (CODESET).])
+
+ AC_CACHE_CHECK([for nl_langinfo and _NL_PAPER_WIDTH],
+ [emacs_cv_langinfo__nl_paper_width],
+ [AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <langinfo.h>]],
+ [[char *cs = nl_langinfo (_NL_PAPER_WIDTH);]])],
+ [emacs_cv_langinfo__nl_paper_width=yes],
+ [emacs_cv_langinfo__nl_paper_width=no])
+ ])
+ if test "$emacs_cv_langinfo__nl_paper_width" = yes; then
+ AC_DEFINE([HAVE_LANGINFO__NL_PAPER_WIDTH], 1,
+ [Define if you have <langinfo.h> and nl_langinfo (_NL_PAPER_WIDTH).])
+ fi
fi
AC_TYPE_MBSTATE_T
@@ -4377,7 +4580,6 @@ fi
dnl Everybody supports this, except MS-DOS.
dnl Seems like the kind of thing we should be testing for, though.
-dnl Compare with HAVE_INET_SOCKETS (which is unused...) above.
AC_DEFINE(HAVE_SOCKETS, 1, [Define if the system supports
4.2-compatible sockets.])
@@ -5123,6 +5325,22 @@ else
fi
AC_SUBST(LIBXMENU)
+AC_CACHE_CHECK([for struct alignment],
+ [emacs_cv_struct_alignment],
+ [AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM([[#include <stddef.h>
+ struct s { char c; } __attribute__ ((aligned (8)));
+ struct t { char c; struct s s; };
+ char verify[offsetof (struct t, s) == 8 ? 1 : -1];
+ ]])],
+ [emacs_cv_struct_alignment=yes],
+ [emacs_cv_struct_alignment=no])])
+if test "$emacs_cv_struct_alignment" = yes; then
+ AC_DEFINE([HAVE_STRUCT_ATTRIBUTE_ALIGNED], 1,
+ [Define to 1 if 'struct __attribute__ ((aligned (N)))' aligns the
+ structure to an N-byte boundary.])
+fi
+
if test "${GNU_MALLOC}" = "yes" ; then
AC_DEFINE(GNU_MALLOC, 1,
[Define to 1 if you want to use the GNU memory allocator.])
@@ -5210,6 +5428,15 @@ case "$opsys" in
cygwin) LD_SWITCH_SYSTEM_TEMACS="-Wl,-stack,0x00800000" ;;
darwin)
+ if test "$HAVE_NS" = "yes"; then
+ libs_nsgui="-framework AppKit"
+ if test "$NS_IMPL_COCOA" = "yes"; then
+ libs_nsgui="$libs_nsgui -framework IOKit -framework Carbon"
+ fi
+ else
+ libs_nsgui=
+ fi
+ LD_SWITCH_SYSTEM_TEMACS=$libs_nsgui
## The -headerpad option tells ld (see man page) to leave room at the
## end of the header for adding load commands. Needed for dumping.
## 0x1000 is enough for roughly 52 load commands on the x86_64
@@ -5218,15 +5445,9 @@ case "$opsys" in
## about 14 to about 34. Setting it high gets us plenty of slop and
## only costs about 1.5K of wasted binary space.
headerpad_extra=1000
- if test "$HAVE_NS" = "yes"; then
- libs_nsgui="-framework AppKit"
- if test "$NS_IMPL_COCOA" = "yes"; then
- libs_nsgui="$libs_nsgui -framework IOKit"
- fi
- else
- libs_nsgui=
+ if test "$with_unexec" = yes; then
+ LD_SWITCH_SYSTEM_TEMACS="-fno-pie $LD_SWITCH_SYSTEM_TEMACS -Xlinker -headerpad -Xlinker $headerpad_extra"
fi
- LD_SWITCH_SYSTEM_TEMACS="-fno-pie -prebind $libs_nsgui -Xlinker -headerpad -Xlinker $headerpad_extra"
## This is here because src/Makefile.in did some extra fiddling around
## with LD_SWITCH_SYSTEM. It seems cleaner to put this in
@@ -5266,19 +5487,25 @@ esac
AC_CACHE_CHECK(
[for $CC option to disable position independent executables],
[emacs_cv_prog_cc_no_pie],
- [emacs_save_c_werror_flag=$ac_c_werror_flag
- emacs_save_LDFLAGS=$LDFLAGS
- ac_c_werror_flag=yes
- for emacs_cv_prog_cc_no_pie in -no-pie -nopie no; do
- test $emacs_cv_prog_cc_no_pie = no && break
- LDFLAGS="$emacs_save_LDFLAGS $emacs_cv_prog_cc_no_pie"
- AC_LINK_IFELSE([AC_LANG_PROGRAM([], [])], [break])
- done
- ac_c_werror_flag=$emacs_save_c_werror_flag
- LDFLAGS=$emacs_save_LDFLAGS])
-if test "$emacs_cv_prog_cc_no_pie" != no; then
- LD_SWITCH_SYSTEM_TEMACS="$LD_SWITCH_SYSTEM_TEMACS $emacs_cv_prog_cc_no_pie"
-fi
+ [if test $with_unexec = no; then
+ emacs_cv_prog_cc_no_pie='not needed'
+ else
+ emacs_save_c_werror_flag=$ac_c_werror_flag
+ emacs_save_LDFLAGS=$LDFLAGS
+ ac_c_werror_flag=yes
+ for emacs_cv_prog_cc_no_pie in -no-pie -nopie no; do
+ test $emacs_cv_prog_cc_no_pie = no && break
+ LDFLAGS="$emacs_save_LDFLAGS $emacs_cv_prog_cc_no_pie"
+ AC_LINK_IFELSE([AC_LANG_PROGRAM([], [])], [break])
+ done
+ ac_c_werror_flag=$emacs_save_c_werror_flag
+ LDFLAGS=$emacs_save_LDFLAGS
+ fi])
+case $emacs_cv_prog_cc_no_pie in
+ -*)
+ LD_SWITCH_SYSTEM_TEMACS="$LD_SWITCH_SYSTEM_TEMACS $emacs_cv_prog_cc_no_pie"
+ ;;
+esac
if test x$ac_enable_profiling != x ; then
case $opsys in
@@ -5372,10 +5599,11 @@ emacs_config_features=
for opt in XAW3D XPM JPEG TIFF GIF PNG RSVG CAIRO IMAGEMAGICK SOUND GPM DBUS \
GCONF GSETTINGS GLIB NOTIFY ACL LIBSELINUX GNUTLS LIBXML2 FREETYPE M17N_FLT \
LIBOTF XFT ZLIB TOOLKIT_SCROLL_BARS X_TOOLKIT OLDXMENU X11 XDBE XIM \
- NS MODULES THREADS XWIDGETS LIBSYSTEMD CANNOT_DUMP LCMS2; do
+ NS MODULES THREADS XWIDGETS LIBSYSTEMD JSON PDUMPER UNEXEC LCMS2 GMP; do
case $opt in
- CANNOT_DUMP) eval val=\${$opt} ;;
+ PDUMPER) val=${with_pdumper} ;;
+ UNEXEC) val=${with_unexec} ;;
GLIB) val=${emacs_cv_links_glib} ;;
NOTIFY|ACL) eval val=\${${opt}_SUMMARY} ;;
TOOLKIT_SCROLL_BARS|X_TOOLKIT) eval val=\${USE_$opt} ;;
@@ -5392,6 +5620,15 @@ for opt in XAW3D XPM JPEG TIFF GIF PNG RSVG CAIRO IMAGEMAGICK SOUND GPM DBUS \
*) continue ;;
esac
;;
+ NOTIFY)
+ case $val in
+ *lkqueue*) opt="$opt LIBKQUEUE" ;;
+ *kqueue*) opt="$opt KQUEUE" ;;
+ *inotify*) opt="$opt INOTIFY" ;;
+ *gfile*) opt="$opt GFILENOTIFY" ;;
+ *w32*) opt="$opt W32NOTIFY" ;;
+ esac
+ ;;
esac
AS_VAR_APPEND([emacs_config_features], ["$optsep$opt"])
optsep=' '
@@ -5408,7 +5645,7 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D
Does Emacs use -lrsvg-2? ${HAVE_RSVG}
Does Emacs use cairo? ${HAVE_CAIRO}
Does Emacs use -llcms2? ${HAVE_LCMS2}
- Does Emacs use imagemagick (version 6)? ${HAVE_IMAGEMAGICK}
+ Does Emacs use imagemagick? ${HAVE_IMAGEMAGICK}
Does Emacs support sound? ${HAVE_SOUND}
Does Emacs use -lgpm? ${HAVE_GPM}
Does Emacs use -ldbus? ${HAVE_DBUS}
@@ -5424,11 +5661,16 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D
Does Emacs use -lotf? ${HAVE_LIBOTF}
Does Emacs use -lxft? ${HAVE_XFT}
Does Emacs use -lsystemd? ${HAVE_LIBSYSTEMD}
+ Does Emacs use -ljansson? ${HAVE_JSON}
+ Does Emacs use -lgmp? ${HAVE_GMP}
Does Emacs directly use zlib? ${HAVE_ZLIB}
Does Emacs have dynamic modules support? ${HAVE_MODULES}
Does Emacs use toolkit scroll bars? ${USE_TOOLKIT_SCROLL_BARS}
Does Emacs support Xwidgets (requires gtk3)? ${HAVE_XWIDGETS}
Does Emacs have threading support in lisp? ${threads_enabled}
+ Does Emacs support the portable dumper? ${with_pdumper}
+ Does Emacs support legacy unexec dumping? ${with_unexec}
+ Which dumping strategy does Emacs use? ${with_dumping}
"])
if test -n "${EMACSDATA}"; then
@@ -5442,9 +5684,10 @@ echo
if test "$HAVE_NS" = "yes"; then
echo
- AS_ECHO(["You must run \"${MAKE-make} install\" in order to test the built application.
-The installed application will go to nextstep/Emacs.app and can be
-run or moved from there."])
+ AS_ECHO(["Run '${MAKE-make}' to build Emacs, then run 'src/emacs' to test it.
+Run '${MAKE-make} install' in order to build an application bundle.
+The application will go to nextstep/Emacs.app and can be run or moved
+from there."])
if test "$EN_NS_SELF_CONTAINED" = "yes"; then
echo "The application will be fully self-contained."
else
diff --git a/doc/emacs/ChangeLog.1 b/doc/emacs/ChangeLog.1
index 99faff1623c..b9f7e49fc91 100644
--- a/doc/emacs/ChangeLog.1
+++ b/doc/emacs/ChangeLog.1
@@ -4398,7 +4398,7 @@
mail-header-separator.
(Mail Headers): Put info about initialization and changing in one place
at the start. Update FCC section for mbox Rmail. Clarify From
- section, mention mail-setup-with-from. Clarify Reply-to section.
+ section, mention mail-setup-with-from. Clarify Reply-To section.
Add Mail-followup-to and mail-mailing-lists. Clarify References
section.
(Mail Aliases): Update example, make less contentious.
diff --git a/doc/emacs/Makefile.in b/doc/emacs/Makefile.in
index fa451b1f927..01c6700197c 100644
--- a/doc/emacs/Makefile.in
+++ b/doc/emacs/Makefile.in
@@ -206,8 +206,8 @@ doc-emacsver:
## Temp files.
mostlyclean:
- rm -f *.aux *.log *.toc *.cp *.cps *.fn *.fns *.ky *.kys \
- *.op *.ops *.pg *.pgs *.tp *.tps *.vr *.vrs
+ rm -f ./*.aux ./*.log ./*.toc ./*.cp ./*.cps ./*.fn ./*.fns ./*.ky ./*.kys \
+ ./*.op ./*.ops ./*.pg ./*.pgs ./*.tp ./*.tps ./*.vr ./*.vrs
## Products not in the release tarfiles.
clean: mostlyclean
diff --git a/doc/emacs/building.texi b/doc/emacs/building.texi
index 7ce62498b8e..78d07b8d39e 100644
--- a/doc/emacs/building.texi
+++ b/doc/emacs/building.texi
@@ -190,6 +190,9 @@ compilation buffer produce automatic source display.
@item g
Re-run the last command whose output is shown in the
@file{*compilation*} buffer.
+@item M-x next-error-select-buffer
+Select a buffer to be used by next invocation of @code{next-error} and
+@code{previous-error}.
@end table
@kindex M-g M-n
@@ -202,16 +205,18 @@ Re-run the last command whose output is shown in the
This command can be invoked from any buffer, not just a Compilation
mode buffer. The first time you invoke it after a compilation, it
visits the locus of the first error message. Each subsequent
-@w{@kbd{C-x `}} visits the next error, in a similar fashion. If you
+@w{@kbd{M-g M-n}} visits the next error, in a similar fashion. If you
visit a specific error with @key{RET} or a mouse click in the
-@file{*compilation*} buffer, subsequent @w{@kbd{C-x `}} commands
-advance from there. When @w{@kbd{C-x `}} finds no more error messages
-to visit, it signals an error. @w{@kbd{C-u C-x `}} starts again from
+@file{*compilation*} buffer, subsequent @w{@kbd{M-g M-n}} commands
+advance from there. When @w{@kbd{M-g M-n}} finds no more error messages
+to visit, it signals an error. @w{@kbd{C-u M-g M-n}} starts again from
the beginning of the compilation buffer, and visits the first locus.
@kbd{M-g M-p} or @kbd{M-g p} (@code{previous-error}) iterates
through errors in the opposite direction.
+@vindex next-error-find-buffer-function
+@findex next-error-select-buffer
The @code{next-error} and @code{previous-error} commands don't just
act on the errors or matches listed in @file{*compilation*} and
@file{*grep*} buffers; they also know how to iterate through error or
@@ -219,10 +224,15 @@ match lists produced by other commands, such as @kbd{M-x occur}
(@pxref{Other Repeating Search}). If the current buffer contains
error messages or matches, these commands will iterate through them;
otherwise, Emacs looks for a buffer containing error messages or
-matches amongst the windows of the selected frame, then for any buffer
-that @code{next-error} or @code{previous-error} previously visited,
-and finally all other buffers. Any buffer these commands iterate
-through that is not currently displayed in a window will be displayed.
+matches amongst the windows of the selected frame (if the variable
+@code{next-error-find-buffer-function} is customized to the value
+@code{next-error-buffer-on-selected-frame}), then for a buffer used
+previously by @code{next-error} or @code{previous-error}, and finally
+all other buffers. Any buffer these commands iterate through that is
+not currently displayed in a window will be displayed. You can use
+the @command{next-error-select-buffer} command to switch to
+a different buffer to be used by the subsequent invocation of
+@code{next-error}.
@vindex compilation-skip-threshold
By default, the @code{next-error} and @code{previous-error} commands
@@ -394,8 +404,8 @@ grep -nH -e foo *.el | grep bar | grep toto
@end example
The output from @command{grep} goes in the @file{*grep*} buffer. You
-can find the corresponding lines in the original files using @w{@kbd{C-x
-`}}, @key{RET}, and so forth, just like compilation errors.
+can find the corresponding lines in the original files using @w{@kbd{M-g
+M-n}}, @key{RET}, and so forth, just like compilation errors.
@xref{Compilation Mode}, for detailed description of commands and key
bindings available in the @file{*grep*} buffer.
@@ -449,6 +459,18 @@ the variable @code{grep-files-aliases}.
@kbd{M-x rgrep}. The default value includes the data directories used
by various version control systems.
+@vindex grep-find-abbreviate
+@findex grep-find-toggle-abbreviation
+ By default, the shell commands constructed for @code{lgrep},
+@code{rgrep}, and @code{zgrep} are abbreviated for display by
+concealing the part that contains a long list of files and directories
+to ignore. You can reveal the concealed part by clicking on the
+button with ellipsis, which represents them. You can also
+interactively toggle viewing the concealed part by typing @kbd{M-x
+grep-find-toggle-abbreviation}. To disable this abbreviation of the
+shell commands, customize the option @code{grep-find-abbreviate} to a
+@code{nil} value.
+
@node Flymake
@section Finding Syntax Errors On The Fly
@cindex checking syntax
diff --git a/doc/emacs/cmdargs.texi b/doc/emacs/cmdargs.texi
index c870e6dad9d..00d5be70eb2 100644
--- a/doc/emacs/cmdargs.texi
+++ b/doc/emacs/cmdargs.texi
@@ -383,6 +383,21 @@ verify that their module conforms to the module API requirements. The
option makes Emacs abort if a module-related assertion triggers.
@xref{Writing Dynamic Modules,, Writing Dynamically-Loaded Modules,
elisp, The GNU Emacs Lisp Reference Manual}.
+
+@item --dump-file=@var{file}
+@opindex --dump-file
+@cindex specify dump file
+Load the dumped Emacs state from the named @var{file}. By default, an
+installed Emacs will look for its dump state in a file named
+@file{@var{emacs}.pdmp} in the directory where the Emacs installation
+puts the architecture-dependent files; the variable
+@code{exec-directory} holds the name of that directory. @var{emacs}
+is the name of the Emacs executable file, normally just @file{emacs}.
+(When you invoke Emacs from the @file{src} directory where it was
+built without installing it, it will look for the dump file in the
+directory of the executable.) If you rename or move the dump file to
+a different place, you can use this option to tell Emacs where to find
+that file.
@end table
@node Command Example
@@ -528,12 +543,17 @@ This variable defaults to @file{~/.bash_history} if you use Bash, to
otherwise.
@item HOME
@vindex HOME@r{, environment variable}
-The location of your files in the directory tree; used for
-expansion of file names starting with a tilde (@file{~}). On MS-DOS,
-it defaults to the directory from which Emacs was started, with
-@samp{/bin} removed from the end if it was present. On Windows, the
-default value of @env{HOME} is the @file{Application Data}
-subdirectory of the user profile directory (normally, this is
+The location of your files in the directory tree; used for expansion
+of file names starting with a tilde (@file{~}). If set, it should be
+set to an absolute file name. (If set to a relative file name, Emacs
+interprets it relative to the directory where Emacs was started, but
+we don't recommend to use this feature.) If unset, @env{HOME}
+normally defaults to the home directory of the user given by
+@env{LOGNAME}, @env{USER} or your user ID, or to @file{/} if all else
+fails. On MS-DOS, it defaults to the directory from which Emacs was
+started, with @samp{/bin} removed from the end if it was present. On
+Windows, the default value of @env{HOME} is the @file{Application
+Data} subdirectory of the user profile directory (normally, this is
@file{C:/Documents and Settings/@var{username}/Application Data},
where @var{username} is your user name), though for backwards
compatibility @file{C:/} will be used instead if a @file{.emacs} file
diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi
index 3f660fe9a28..c649c170293 100644
--- a/doc/emacs/custom.texi
+++ b/doc/emacs/custom.texi
@@ -765,6 +765,8 @@ expects (@pxref{Examining}).
* Locals:: Per-buffer values of variables.
* File Variables:: How files can specify variable values.
* Directory Variables:: How variable values can be specified by directory.
+* Connection Variables:: Variables which are valid for buffers with a
+ remote default directory.
@end menu
@node Examining
@@ -1421,6 +1423,52 @@ variables are handled in the same way as unsafe file-local variables
do not visit a file directly but perform work within a directory, such
as Dired buffers (@pxref{Dired}).
+@node Connection Variables
+@subsection Per-Connection Local Variables
+@cindex local variables, for all remote connections
+@cindex connection-local variables
+@cindex per-connection local variables
+
+ Most of the variables reflect the situation on the local machine.
+Often, they must use a different value when you operate in buffers
+with a remote default directory. Think about the shell to be applied
+when calling @code{shell} -- it might be @file{/bin/bash} on your
+local machine, and @file{/bin/ksh} on a remote machine.
+
+ This can be accomplished with @dfn{connection-local variables}.
+Directory and file local variables override connection-local
+variables. Unsafe connection-local variables are handled in the same
+way as unsafe file-local variables (@pxref{Safe File Variables}).
+
+@findex connection-local-set-profile-variables
+@findex connection-local-set-profiles
+ Connection-local variables are declared as a group of
+variables/value pairs in a @dfn{profile}, using the
+@code{connection-local-set-profile-variables} function. The function
+@code{connection-local-set-profiles} activates profiles for a given
+criteria, identifying a remote machine:
+
+@example
+(connection-local-set-profile-variables 'remote-ksh
+ '((shell-file-name . "/bin/ksh")
+ (shell-command-switch . "-c")))
+
+(connection-local-set-profile-variables 'remote-bash
+ '((shell-file-name . "/bin/bash")
+ (shell-command-switch . "-c")))
+
+(connection-local-set-profiles
+ '(:application tramp :machine "remotemachine") 'remote-ksh)
+@end example
+
+ This code declares two different profiles, @code{remote-ksh} and
+@code{remote-bash}. The profile @code{remote-ksh} is applied to all
+buffers which have a remote default directory matching the regexp
+@code{"remotemachine} as host name. Such a criteria can also
+discriminate for the properties @code{:protocol} (this is the Tramp
+method) or @code{:user} (a remote user name). The @code{nil} criteria
+matches all buffers with a remote default directory.
+
@node Key Bindings
@section Customizing Key Bindings
@cindex key bindings
@@ -2211,6 +2259,7 @@ Manual}.
* Terminal Init:: Each terminal type can have an init file.
* Find Init:: How Emacs finds the init file.
* Init Non-ASCII:: Using non-@acronym{ASCII} characters in an init file.
+* Early Init File:: Another init file, which is read early on.
@end menu
@node Init Syntax
@@ -2558,10 +2607,9 @@ library. @xref{Hooks}.
@node Find Init
@subsection How Emacs Finds Your Init File
- Normally Emacs uses the environment variable @env{HOME}
-(@pxref{General Variables, HOME}) to find @file{.emacs}; that's what
-@samp{~} means in a file name. If @file{.emacs} is not found inside
-@file{~/} (nor @file{.emacs.el}), Emacs looks for
+ Normally Emacs uses your home directory to find @file{~/.emacs};
+that's what @samp{~} means in a file name. @xref{General Variables, HOME}.
+If neither @file{~/.emacs} nor @file{~/.emacs.el} is found, Emacs looks for
@file{~/.emacs.d/init.el} (which, like @file{~/.emacs.el}, can be
byte-compiled).
@@ -2612,6 +2660,36 @@ instance:
@noindent
Type @kbd{C-q}, followed by the key you want to bind, to insert @var{char}.
+@node Early Init File
+@subsection The Early Init File
+@cindex early init file
+
+ Most customizations for Emacs should be put in the normal init file,
+@file{.emacs} or @file{~/.emacs.d/init.el}. However, it is sometimes desirable
+to have customizations that take effect during Emacs startup earlier than the
+normal init file is processed. Such customizations can be put in the early
+init file, @file{~/.emacs.d/early-init.el}. This file is loaded before the
+package system and GUI is initialized, so in it you can customize variables
+that affect frame appearance as well as the package initialization process,
+such as @code{package-enable-at-startup}, @code{package-load-list}, and
+@code{package-user-dir}. Note that variables like @code{package-archives}
+which only affect the installation of new packages, and not the process of
+making already-installed packages available, may be customized in the regular
+init file. @xref{Package Installation}.
+
+ We do not recommend that you move into @file{early-init.el}
+customizations that can be left in the normal init files. That is
+because the early init file is read before the GUI is initialized, so
+customizations related to GUI features will not work reliably in
+@file{early-init.el}. By contrast, the normal init files are read
+after the GUI is initialized. If you must have customizations in the
+early init file that rely on GUI features, make them run off hooks
+provided by the Emacs startup, such as @code{window-setup-hook} or
+@code{tty-setup-hook}. @xref{Hooks}.
+
+ For more information on the early init file, @pxref{Init File,,,
+elisp, The Emacs Lisp Reference Manual}.
+
@node Authentication
@section Keeping Persistent Authentication Information
diff --git a/doc/emacs/dired.texi b/doc/emacs/dired.texi
index cf9665ac5b4..9f454ea2ad6 100644
--- a/doc/emacs/dired.texi
+++ b/doc/emacs/dired.texi
@@ -663,6 +663,14 @@ Copy the specified files (@code{dired-do-copy}). The argument @var{new}
is the directory to copy into, or (if copying a single file) the new
name. This is like the shell command @code{cp}.
+@vindex dired-create-destination-dirs
+The option @code{dired-create-destination-dirs} controls whether Dired
+should create non-existent directories in the destination while
+copying/renaming files. The default value @code{nil} means Dired
+never creates such missing directories; the value @code{always},
+means Dired automatically creates them; the value @code{ask}
+means Dired asks you for confirmation before creating them.
+
@vindex dired-copy-preserve-time
If @code{dired-copy-preserve-time} is non-@code{nil}, then copying
with this command preserves the modification time of the old file in
@@ -694,6 +702,9 @@ single file, the argument @var{new} is the new name of the file. If
you rename several files, the argument @var{new} is the directory into
which to move the files (this is like the shell command @command{mv}).
+The option @code{dired-create-destination-dirs} controls whether Dired
+should create non-existent directories in @var{new}.
+
Dired automatically changes the visited file name of buffers associated
with renamed files so that they refer to the new names.
@@ -1463,6 +1474,11 @@ rotation is lossless, and uses an external utility called
directory's name, and creates that directory. It signals an error if
the directory already exists.
+@findex dired-create-empty-file
+ The command (@code{dired-create-empty-file}) reads a
+file name, and creates that file. It signals an error if
+the file already exists.
+
@cindex searching multiple files via Dired
@kindex M-s a C-s @r{(Dired)}
@kindex M-s a M-C-s @r{(Dired)}
diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi
index 9cf6baa7e91..f464a3a59f0 100644
--- a/doc/emacs/display.texi
+++ b/doc/emacs/display.texi
@@ -974,8 +974,10 @@ the buffer is loaded. For example, to highlight all occurrences of
the word ``whim'' using the default face (a yellow background), type
@kbd{M-s h r whim @key{RET} @key{RET}}. Any face can be used for
highlighting, Hi Lock provides several of its own and these are
-pre-loaded into a list of default values. While being prompted
-for a face use @kbd{M-n} and @kbd{M-p} to cycle through them.
+pre-loaded into a list of default values. While being prompted for a
+face use @kbd{M-n} and @kbd{M-p} to cycle through them. A prefix
+numeric argument limits the highlighting to the corresponding
+subexpression.
@vindex hi-lock-auto-select-face
Setting the option @code{hi-lock-auto-select-face} to a non-@code{nil}
diff --git a/doc/emacs/emacs.texi b/doc/emacs/emacs.texi
index 5b16d5034f1..58ec3730299 100644
--- a/doc/emacs/emacs.texi
+++ b/doc/emacs/emacs.texi
@@ -1135,6 +1135,8 @@ Variables
* Locals:: Per-buffer values of variables.
* File Variables:: How files can specify variable values.
* Directory Variables:: How variable values can be specified by directory.
+* Connection Variables:: Variables which are valid for buffers with a
+ remote default directory.
Local Variables in Files
@@ -1164,6 +1166,7 @@ The Emacs Initialization File
* Terminal Init:: Each terminal type can have an init file.
* Find Init:: How Emacs finds the init file.
* Init Non-ASCII:: Using non-@acronym{ASCII} characters in an init file.
+* Early Init File:: Another init file, which is read early on.
Dealing with Emacs Trouble
@@ -1481,7 +1484,7 @@ Stevens, Andy Stewart, Jonathan Stigelman, Martin Stjernholm, Kim F.
Storm, Steve Strassmann, Christopher Suckling, Olaf Sylvester, Naoto
Takahashi, Steven Tamm, Jan Tatarik, Luc Teirlinck, Jean-Philippe Theberge, Jens
T. Berger Thielemann, Spencer Thomas, Jim Thompson, Toru Tomabechi,
-David O'Toole, Markus Triska, Tom Tromey, Enami Tsugutomo, Eli
+David O'Toole, Markus Triska, Tom Tromey, Eli
Tziperman, Daiki Ueno, Masanobu Umeda, Rajesh Vaidheeswarran, Neil
W. Van Dyke, Didier Verna, Joakim Verona, Ulrik Vieth, Geoffrey
Voelker, Johan Vromans, Inge Wallin, John Paul Wallington, Colin
diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi
index cd64fb109ea..a57428230cc 100644
--- a/doc/emacs/files.texi
+++ b/doc/emacs/files.texi
@@ -206,7 +206,10 @@ saved it. If the file has changed, Emacs offers to reread it.
If you try to visit a file larger than
@code{large-file-warning-threshold} (the default is 10000000, which is
about 10 megabytes), Emacs asks you for confirmation first. You can
-answer @kbd{y} to proceed with visiting the file. Note, however, that
+answer @kbd{y} to proceed with visiting the file or @kbd{l} to visit
+the file literally (see below). Visiting large files literally speeds
+up navigation and editing of such files, because various
+potentially-expensive features are turned off. Note, however, that
Emacs cannot visit files that are larger than the maximum Emacs buffer
size, which is limited by the amount of memory Emacs can allocate and
by the integers that Emacs can represent (@pxref{Buffers}). If you
@@ -400,11 +403,14 @@ possible responses are analogous to those of @code{query-replace}:
@table @kbd
@item y
+@item @key{SPC}
Save this buffer and ask about the rest of the buffers.
@item n
+@item @key{DEL}
Don't save this buffer, but ask about the rest of the buffers.
@item !
Save this buffer and all the rest with no more questions.
+@item q
@c following generates acceptable underfull hbox
@item @key{RET}
Terminate @code{save-some-buffers} without any more saving.
@@ -1016,13 +1022,16 @@ separate file, without altering the file you actually use. This is
called @dfn{auto-saving}. It prevents you from losing more than a
limited amount of work if the system crashes.
+@vindex auto-save-no-message
When Emacs determines that it is time for auto-saving, it considers
each buffer, and each is auto-saved if auto-saving is enabled for it
-and it has been changed since the last time it was auto-saved. The
-message @samp{Auto-saving...} is displayed in the echo area during
-auto-saving, if any files are actually auto-saved. Errors occurring
-during auto-saving are caught so that they do not interfere with the
-execution of commands you have been typing.
+and it has been changed since the last time it was auto-saved. When
+the @code{auto-save-no-message} variable is set to @code{nil} (the
+default), the message @samp{Auto-saving...} is displayed in the echo
+area during auto-saving, if any files are actually auto-saved; to
+disable these messages, customize the variable to a non-@code{nil}
+value. Errors occurring during auto-saving are caught so that they do
+not interfere with the execution of commands you have been typing.
@menu
* Files: Auto Save Files. The file where auto-saved changes are
@@ -1309,17 +1318,8 @@ default), and @code{list-directory-verbose-switches} is a string
giving the switches to use in a verbose listing (@code{"-l"} by
default).
-@vindex directory-free-space-program
-@vindex directory-free-space-args
In verbose directory listings, Emacs adds information about the
-amount of free space on the disk that contains the directory. You can
-customize how this is done for local filesystems via the variables
-@code{directory-free-space-program} and
-@code{directory-free-space-args}: the former specifies what program to
-run (default: @command{df}), the latter which arguments to pass to
-that program (default is system-dependent). (On MS-Windows and
-MS-DOS, these two variables are ignored, and an internal Emacs
-implementation of the same functionality is used instead.)
+amount of free space on the disk that contains the directory.
The command @kbd{M-x delete-directory} prompts for a directory's name
using the minibuffer, and deletes the directory if it is empty. If
@@ -1448,7 +1448,7 @@ automatic line number correction, change the variable
@code{diff-update-on-the-fly} to @code{nil}.
Diff mode arranges for hunks to be treated as compiler error
-messages by @kbd{C-x `} and other commands that handle error messages
+messages by @kbd{M-g M-n} and other commands that handle error messages
(@pxref{Compilation Mode}). Thus, you can use the compilation-mode
commands to visit the corresponding source locations.
@@ -1461,26 +1461,19 @@ manipulate and apply parts of patches:
Move to the next hunk-start (@code{diff-hunk-next}). With prefix
argument @var{n}, move forward to the @var{n}th next hunk.
-@findex diff-auto-refine-mode
-@cindex mode, Diff Auto-Refine
-@cindex Diff Auto-Refine mode
-This command has a side effect: it @dfn{refines} the hunk you move to,
-highlighting its changes with better granularity. To disable this
-feature, type @kbd{M-x diff-auto-refine-mode} to toggle off the minor
-mode Diff Auto-Refine mode. To disable Diff Auto-Refine mode by
-default, add this to your init file (@pxref{Hooks}):
-
-@example
-(add-hook 'diff-mode-hook
- (lambda () (diff-auto-refine-mode -1)))
-@end example
+@vindex diff-refine
+By default, Diff mode @dfn{refines} hunks as Emacs displays them,
+highlighting their changes with better granularity. Alternatively, if
+you set @code{diff-refine} to the symbol @code{navigation}, Diff mode
+only refines the hunk you move to with this command or with
+@code{diff-hunk-prev}.
@item M-p
@findex diff-hunk-prev
Move to the previous hunk-start (@code{diff-hunk-prev}). With prefix
argument @var{n}, move back to the @var{n}th previous hunk. Like
-@kbd{M-n}, this has the side-effect of refining the hunk you move to,
-unless you disable Diff Auto-Refine mode.
+@kbd{M-n}, this command refines the hunk you move to if you set
+@code{diff-refine} to the symbol @code{navigation}.
@item M-@}
@findex diff-file-next
@@ -1518,6 +1511,11 @@ Highlight the changes of the hunk at point with a finer granularity
(@code{diff-refine-hunk}). This allows you to see exactly which parts
of each changed line were actually changed.
+@vindex diff-refine
+By default, Diff mode refines hunks as Emacs displays them, so you may
+find this command useful if you customize @code{diff-refine} to a
+non-default value.
+
@item C-c C-c
@findex diff-goto-source
@vindex diff-jump-to-old-file
@@ -1530,6 +1528,10 @@ default jumps to the ``old'' file, and the meaning of the prefix
argument is reversed. If the prefix argument is a number greater than
8 (e.g., if you type @kbd{C-u C-u C-c C-c}), then this command also
sets @code{diff-jump-to-old-file} for the next invocation.
+If the source file is under version control (@pxref{Version Control}),
+this jumps to the work file by default. With a prefix argument, jump
+to the ``old'' revision of the file (@pxref{Old Revisions}), when
+point is on the old line, or otherwise jump to the ``new'' revision.
@item C-c C-e
@findex diff-ediff-patch
@@ -1613,6 +1615,10 @@ displayed in the echo area). With a prefix argument, it tries to
modify the original (``old'') source files rather than the patched
(``new'') source files.
+@vindex diff-font-lock-syntax
+ If non-@code{nil}, fragments of source in hunks are highlighted
+according to the appropriate major mode.
+
@node Copying and Naming
@section Copying, Naming and Renaming Files
diff --git a/doc/emacs/fixit.texi b/doc/emacs/fixit.texi
index bb1b4c87137..fc610583c87 100644
--- a/doc/emacs/fixit.texi
+++ b/doc/emacs/fixit.texi
@@ -149,6 +149,12 @@ Transpose two words (@code{transpose-words}).
Transpose two balanced expressions (@code{transpose-sexps}).
@item C-x C-t
Transpose two lines (@code{transpose-lines}).
+@item M-x transpose-sentences
+Transpose two sentences (@code{transpose-sentences}).
+@item M-x transpose-paragraphs
+Transpose two paragraphs (@code{transpose-paragraphs}).
+@item M-x transpose-regions
+Transpose two regions.
@end table
@kindex C-t
@@ -183,10 +189,14 @@ punctuation characters between the words do not move. For example,
@w{@samp{BAR FOO,}}. When point is at the end of the line, it will
transpose the word before point with the first word on the next line.
+@findex transpose-sentences
+@findex transpose-paragraphs
@kbd{C-M-t} (@code{transpose-sexps}) is a similar command for
transposing two expressions (@pxref{Expressions}), and @kbd{C-x C-t}
-(@code{transpose-lines}) exchanges lines. They work like @kbd{M-t}
-except as regards the units of text they transpose.
+(@code{transpose-lines}) exchanges lines. @kbd{M-x
+transpose-sentences} and @kbd{M-x transpose-paragraphs} transpose
+sentences and paragraphs, respectively. These commands work like
+@kbd{M-t} except as regards the units of text they transpose.
A numeric argument to a transpose command serves as a repeat count: it
tells the transpose command to move the character (or word or
@@ -204,6 +214,15 @@ otherwise a command with a repeat count of zero would do nothing): to
transpose the character (or word or expression or line) ending after
point with the one ending after the mark.
+@findex transpose-regions
+ @kbd{M-x transpose-regions} transposes the text between point and
+mark with the text between the last two marks pushed to the mark ring
+(@pxref{Setting Mark}). With a numeric prefix argument, it transposes
+the text between point and mark with the text between two successive
+marks that many entries back in the mark ring. This command is best
+used for transposing multiple characters (or words or sentences or
+paragraphs) in one go.
+
@node Fixing Case
@section Case Conversion
diff --git a/doc/emacs/frames.texi b/doc/emacs/frames.texi
index 05aabd0e15b..6001096f35b 100644
--- a/doc/emacs/frames.texi
+++ b/doc/emacs/frames.texi
@@ -899,6 +899,16 @@ input stream for each server. Each server also has its own selected
frame. The commands you enter with a particular X server apply to
that server's selected frame.
+ On multi-monitor displays it is possible to use the command
+@code{make-frame-on-monitor}:
+
+@findex make-frame-on-monitor
+@table @kbd
+@item M-x make-frame-on-monitor @key{RET} @var{monitor} @key{RET}
+Create a new frame on monitor @var{monitor} whose screen area is
+a part of the current display.
+@end table
+
@node Frame Parameters
@section Frame Parameters
@vindex default-frame-alist
diff --git a/doc/emacs/help.texi b/doc/emacs/help.texi
index 9ffea416827..4851659b8b7 100644
--- a/doc/emacs/help.texi
+++ b/doc/emacs/help.texi
@@ -523,13 +523,17 @@ currently in use. @xref{Coding Systems}.
@section Other Help Commands
@kindex C-h i
+@kindex C-h 4 i
@findex info
+@findex info-other-window
@cindex Info
@cindex manuals, included
@kbd{C-h i} (@code{info}) runs the Info program, which browses
-structured documentation files. The entire Emacs manual is available
-within Info, along with many other manuals for the GNU system. Type
-@kbd{h} after entering Info to run a tutorial on using Info.
+structured documentation files. @kbd{C-h 4 i}
+(@code{info-other-window}) does the same, but shows the Info buffer in
+another window. The entire Emacs manual is available within Info,
+along with many other manuals for the GNU system. Type @kbd{h} after
+entering Info to run a tutorial on using Info.
@cindex find Info manual by its file name
With a numeric argument @var{n}, @kbd{C-h i} selects the Info buffer
diff --git a/doc/emacs/indent.texi b/doc/emacs/indent.texi
index a6aa75bbb42..5f40acba151 100644
--- a/doc/emacs/indent.texi
+++ b/doc/emacs/indent.texi
@@ -110,6 +110,10 @@ parentheses, or if the junction follows another newline.
If there is a fill prefix, @kbd{M-^} deletes the fill prefix if it
appears after the newline that is deleted. @xref{Fill Prefix}.
+With a prefix argument, join the current line line to the following
+line. If the region is active, and no prefix argument is given, join
+all lines in the region instead.
+
@item C-M-\
@kindex C-M-\
@findex indent-region
diff --git a/doc/emacs/macos.texi b/doc/emacs/macos.texi
index 6d27e978217..d9920957ad7 100644
--- a/doc/emacs/macos.texi
+++ b/doc/emacs/macos.texi
@@ -170,8 +170,25 @@ the requested line (@code{ns-open-file-select-line}).
This event occurs when a user drags an object from another application
into an Emacs frame. The default behavior is to open a file in the
window under the mouse, or to insert text at point of the window under
-the mouse. It may sometimes be necessary to use the @key{Meta} key in
-conjunction with dragging to force text insertion.
+the mouse.
+
+The sending application has some limited ability to decide how Emacs
+handles the sent object, but the user may override the default
+behaviour by holding one or more modifier key.
+
+@table @kbd
+@item control
+Insert as text in the current buffer. If the object is a file, this
+will insert the filename.
+@item alt/option
+Attempt to open the object as though it is a file or URL.
+@item super/command
+Perform the default action for the type. This can be useful when an
+application is overriding the default behaviour.
+@end table
+
+The modifier keys listed above are defined by macOS and are unaffected
+by user changes to the modifiers in Emacs.
@item ns-change-font
This event occurs when the user selects a font in a Nextstep font
diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi
index cddffd6f2a5..fd0119e98ce 100644
--- a/doc/emacs/maintaining.texi
+++ b/doc/emacs/maintaining.texi
@@ -831,6 +831,14 @@ working tree containing the current VC fileset). If you invoke this
command from a Dired buffer, it applies to the working tree containing
the directory.
+@findex vc-root-version-diff
+@kindex C-u C-x v D
+ To compare two arbitrary revisions of the whole trees, call
+@code{vc-root-diff} with a prefix argument: @kbd{C-u C-x v D}. This
+prompts for two revision IDs (@pxref{VCS Concepts}), and displays a
+diff between those versions of the entire version-controlled directory
+trees (RCS, SCCS, CVS, and SRC do not support this feature).
+
@vindex vc-diff-switches
You can customize the @command{diff} options that @kbd{C-x v =} and
@kbd{C-x v D} use for generating diffs. The options used are taken
@@ -963,6 +971,7 @@ and the maximum number of revisions to display.
Directory Mode}) or a Dired buffer (@pxref{Dired}), it applies to the
file listed on the current line.
+@kindex C-x v L
@findex vc-print-root-log
@findex log-view-toggle-entry-display
@kbd{C-x v L} (@code{vc-print-root-log}) displays a
@@ -1640,21 +1649,35 @@ entry is considered a page. This facilitates editing the entries.
@kbd{C-j} and auto-fill indent each new line like the previous line;
this is convenient for entering the contents of an entry.
-You can use the @code{next-error} command (by default bound to
-@kbd{C-x `}) to move between entries in the Change Log, when Change
-Log mode is on. You will jump to the actual site in the file that was
-changed, not just to the next Change Log entry. You can also use
-@code{previous-error} to move back in the same list.
+@findex change-log-goto-source
+ You can use the command @code{change-log-goto-source} (by default
+bound to @kbd{C-c C-c}) to go to the source location of the change log
+entry near point, when Change Log mode is on. Then subsequent
+invocations of the @code{next-error} command (by default bound to
+@kbd{M-g M-n} and @kbd{C-x `}) will move between entries in the change
+log. You will jump to the actual site in the file that was changed,
+not just to the next change log entry. You can also use
+@code{previous-error} to move back through the change log entries.
@findex change-log-merge
You can use the command @kbd{M-x change-log-merge} to merge other
log files into a buffer in Change Log Mode, preserving the date
ordering of entries.
+@vindex add-log-dont-create-changelog-file
Version control systems are another way to keep track of changes in
-your program and keep a change log. In the VC log buffer, typing
-@kbd{C-c C-a} (@code{log-edit-insert-changelog}) inserts the relevant
-Change Log entry, if one exists. @xref{Log Buffer}.
+your program and keep a change log. Many projects that use a VCS don't
+keep a separate versioned change log file nowadays, so you may wish to
+avoid having such a file in the repository. If the value of
+@code{add-log-dont-create-changelog-file} is non-@code{nil}, commands
+like @kbd{C-x 4 a} (@code{add-change-log-entry-other-window}) will
+record changes in a suitably named temporary buffer instead of a file,
+if such a file does not already exist.
+
+Whether you have a change log file or use a temporary buffer for
+change logs, you can type @kbd{C-c C-a}
+(@code{log-edit-insert-changelog}) in the VC Log buffer to insert the
+relevant change log entries, if they exist. @xref{Log Buffer}.
@node Format of ChangeLog
@subsection Format of ChangeLog
@@ -1809,6 +1832,8 @@ Find definitions of identifier, but display it in another window
@item C-x 5 .@: @key{RET}
Find definition of identifier, and display it in a new frame
(@code{xref-find-definitions-other-frame}).
+@item M-x xref-find-definitions-at-mouse
+Find definition of identifier at mouse click.
@item M-,
Go back to where you previously invoked @kbd{M-.} and friends
(@code{xref-pop-marker-stack}).
@@ -1849,6 +1874,11 @@ former is @w{@kbd{C-x 4 .}}
(@code{xref-find-definitions-other-window}), and the latter is
@w{@kbd{C-x 5 .}} (@code{xref-find-definitions-other-frame}).
+ The command @code{xref-find-definitions-at-mouse} works like
+@code{xref-find-definitions}, but it looks for the identifier name at
+or around the place of a mouse event. This command is intended to be
+bound to a mouse event, such as @kbd{C-M-mouse-1}, for example.
+
@findex xref-find-apropos
@kindex C-M-.
The command @kbd{C-M-.} (@code{xref-find-apropos}) finds the
@@ -1960,7 +1990,7 @@ table.
@item M-x tags-query-replace @key{RET} @var{regexp} @key{RET} @var{replacement} @key{RET}
Perform a @code{query-replace-regexp} on each file in the selected tags table.
-@item M-x tags-loop-continue
+@item M-x fileloop-continue
Restart one of the last 2 commands above, from the current location of point.
@end table
@@ -1996,9 +2026,9 @@ you can follow its progress. As soon as it finds an occurrence,
@code{tags-search} returns. This command requires tags tables to be
available (@pxref{Tags Tables}).
-@findex tags-loop-continue
+@findex fileloop-continue
Having found one match with @code{tags-search}, you probably want to
-find all the rest. @kbd{M-x tags-loop-continue} resumes the
+find all the rest. @kbd{M-x fileloop-continue} resumes the
@code{tags-search}, finding one more match. This searches the rest of
the current buffer, followed by the remaining files of the tags table.
@@ -2021,10 +2051,10 @@ default is to use the same setting as the value of
single invocation of @kbd{M-x tags-query-replace}. But often it is
useful to exit temporarily, which you can do with any input event that
has no special query replace meaning. You can resume the query
-replace subsequently by typing @kbd{M-x tags-loop-continue}; this
+replace subsequently by typing @kbd{M-x fileloop-continue}; this
command resumes the last tags search or replace command that you did.
For instance, to skip the rest of the current file, you can type
-@w{@kbd{M-> M-x tags-loop-continue}}.
+@w{@kbd{M-> M-x fileloop-continue}}.
Note that the commands described above carry out much broader
searches than the @code{xref-find-definitions} family. The
@@ -2056,7 +2086,7 @@ Display a list of all known identifiers matching @var{regexp}.
Display a list of the identifiers defined in the program file
@var{file}.
-@item M-x next-file
+@item M-x tags-next-file
Visit files recorded in the selected tags table.
@end table
@@ -2095,8 +2125,8 @@ variable @code{tags-apropos-additional-actions}; see its documentation
for details.
@end ignore
-@findex next-file
- @kbd{M-x next-file} visits files covered by the selected tags table.
+@findex tags-next-file
+ @kbd{M-x tags-next-file} visits files covered by the selected tags table.
The first time it is called, it visits the first file covered by the
table. Each subsequent call visits the next covered file, unless a
prefix argument is supplied, in which case it returns to the first
diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi
index d17ef2dad63..820d3baad13 100644
--- a/doc/emacs/mini.texi
+++ b/doc/emacs/mini.texi
@@ -362,14 +362,26 @@ While in the completion list buffer, this chooses the completion at
point (@code{choose-completion}).
@findex next-completion
+@item @key{TAB}
@item @key{RIGHT}
-While in the completion list buffer, this moves point to the following
-completion alternative (@code{next-completion}).
+While in the completion list buffer, these keys move point to the
+following completion alternative (@code{next-completion}).
@findex previous-completion
+@item @key{S-TAB}
@item @key{LEFT}
-While in the completion list buffer, this moves point to the previous
-completion alternative (@code{previous-completion}).
+While in the completion list buffer, these keys move point to the
+previous completion alternative (@code{previous-completion}).
+
+@findex quit-window
+@item @kbd{q}
+While in the completion list buffer, this quits the window showing it
+and selects the window showing the minibuffer (@code{quit-window}).
+
+@findex kill-current-buffer
+@item @kbd{z}
+While in the completion list buffer, kill it and delete the window
+showing it (@code{kill-current-buffer}).
@end table
@node Completion Exit
diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi
index 2d1617ef964..7d7065a441a 100644
--- a/doc/emacs/misc.texi
+++ b/doc/emacs/misc.texi
@@ -314,7 +314,28 @@ You can decide to register a permanent security exception for an
unverified connection, a temporary exception, or refuse the connection
entirely.
-Below is a list of the checks done on the @code{medium} level.
+@vindex network-security-protocol-checks
+In addition to the basic certificate correctness checks, several
+@acronym{TLS} algorithm checks are available. Some encryption
+technologies that were previously thought to be secure have shown
+themselves to be fragile, so Emacs (by default) warns you about some
+of these problems.
+
+The protocol network checks is controlled via the
+@code{network-security-protocol-checks} variable.
+
+It's an alist where the first element of each association is the name
+of the check, the second element is the security level where the check
+should be used, and the optional third element is a parameter supplied
+to the check.
+
+An element like @code{(rc4 medium)} will result in the function
+@code{nsm-protocol-check--rc4} being called like thus:
+@w{@code{(nsm-protocol-check--rc4 host port status optional-parameter)}}.
+The function should return non-@code{nil} if the connection should
+proceed and @code{nil} otherwise.
+
+Below is a list of the checks done on the default @code{medium} level.
@table @asis
@@ -352,12 +373,44 @@ over these connections. Similarly, if you're sending email via
connection to be encrypted. If the connection isn't encrypted,
@acronym{NSM} will warn you.
+@item Diffie-Hellman low prime bits
+When doing the public key exchange, the number of prime bits should be
+high enough to ensure that the channel can't be eavesdropped on by third
+parties. If this number is too low, Emacs will warn you. (This is the
+@code{diffie-hellman-prime-bits} check in
+@code{network-security-protocol-checks}).
+
+@item @acronym{RC4} stream cipher
+The @acronym{RC4} stream cipher is believed to be of low quality and
+may allow eavesdropping by third parties. (This is the @code{rc4}
+check in @code{network-security-protocol-checks}).
+
+@item @acronym{SHA1} in the host certificate or in intermediate certificates
+It is believed that if an intermediate certificate uses the
+@acronym{SHA1} hashing algorithm, then third parties can issue
+certificates pretending to be that issuing instance. These
+connections are therefore vulnerable to man-in-the-middle attacks.
+(These are the @code{signature-sha1} and @code{intermediate-sha1}
+checks in @code{network-security-protocol-checks}).
+
+@item @acronym{SSL1}, @acronym{SSL2} and @acronym{SSL3}
+The protocols older than @acronym{TLS1.0} are believed to be
+vulnerable to a variety of attacks, and you may want to avoid using
+these if what you're doing requires higher security. (This is the
+@code{ssl} check in @code{network-security-protocol-checks}).
+
@end table
If @code{network-security-level} is @code{high}, the following checks
will be made, in addition to the above:
@table @asis
+@item @acronym{3DES} cipher
+The @acronym{3DES} stream cipher provides at most 112 bits of
+effective security, which is considered to be towards the low end.
+(This is the @code{3des} check in
+@code{network-security-protocol-checks}).
+
@item a validated certificate changes the public key
Servers change their keys occasionally, and that is normally nothing
to be concerned about. However, if you are worried that your network
@@ -365,19 +418,6 @@ connections are being hijacked by agencies who have access to pliable
Certificate Authorities which issue new certificates for third-party
services, you may want to keep track of these changes.
-@item Diffie-Hellman low prime bits
-When doing the public key exchange, the number of prime bits
-should be high to ensure that the channel can't be eavesdropped on by
-third parties. If this number is too low, you will be warned.
-
-@item @acronym{RC4} stream cipher
-The @acronym{RC4} stream cipher is believed to be of low quality and
-may allow eavesdropping by third parties.
-
-@item @acronym{SSL1}, @acronym{SSL2} and @acronym{SSL3}
-The protocols older than @acronym{TLS1.0} are believed to be
-vulnerable to a variety of attacks, and you may want to avoid using
-these if what you're doing requires higher security.
@end table
Finally, if @code{network-security-level} is @code{paranoid}, you will
@@ -402,6 +442,7 @@ This means that one can't casually read the settings file to see what
servers the user has connected to. If this variable is @code{t},
@acronym{NSM} will also save host names in the
@code{nsm-settings-file}.
+
@end table
@@ -754,6 +795,10 @@ to @command{gpg}. This will output the list of keys to the
name is relative, Emacs searches the directories listed in
@code{exec-path} (@pxref{Shell}).
+ If the default directory is remote (@pxref{Remote Files}), the
+default value is @file{/bin/sh}. This can be changed by declaring
+@code{shell-file-name} connection-local (@pxref{Connection Variables}).
+
To specify a coding system for @kbd{M-!} or @kbd{M-|}, use the command
@kbd{C-x @key{RET} c} immediately beforehand. @xref{Communication Coding}.
@@ -985,8 +1030,8 @@ Move backward across one shell command, but not beyond the current line
Ask the shell for its working directory, and update the Shell buffer's
default directory. @xref{Directory Tracking}.
-@item M-x send-invisible @key{RET} @var{text} @key{RET}
-@findex send-invisible
+@item M-x comint-send-invisible @key{RET} @var{text} @key{RET}
+@findex comint-send-invisible
Send @var{text} as input to the shell, after reading it without
echoing. This is useful when a shell command runs a program that asks
for a password.
@@ -1133,7 +1178,7 @@ Fetch the next subsequent command from the history
@item C-c .
@kindex C-c . @r{(Shell mode)}
-@findex comint-input-previous-argument
+@findex comint-insert-previous-argument
Fetch one argument from an old shell command
(@code{comint-input-previous-argument}).
@@ -1180,14 +1225,20 @@ you just repeated. Then type @key{RET} to reexecute this command. You
can reexecute several successive commands by typing @kbd{C-c C-x
@key{RET}} over and over.
- The command @kbd{C-c .}@: (@code{comint-input-previous-argument})
+ The command @kbd{C-c .}@: (@code{comint-insert-previous-argument})
copies an individual argument from a previous command, like
-@kbd{@key{ESC} .} in Bash. The simplest use copies the last argument from the
-previous shell command. With a prefix argument @var{n}, it copies the
-@var{n}th argument instead. Repeating @kbd{C-c .} copies from an
-earlier shell command instead, always using the same value of @var{n}
-(don't give a prefix argument when you repeat the @kbd{C-c .}
-command).
+@kbd{@key{ESC} .}@: in Bash and @command{zsh}. The simplest use
+copies the last argument from the previous shell command. With a
+prefix argument @var{n}, it copies the @var{n}th argument instead.
+Repeating @kbd{C-c .} copies from an earlier shell commands, always
+using the same value of @var{n} (don't give a prefix argument when
+you repeat the @kbd{C-c .} command).
+
+@vindex comint-insert-previous-argument-from-end
+ If you set @code{comint-insert-previous-argument-from-end} to a
+non-@code{nil} value, @kbd{C-c .}@: will instead copy the @var{n}th
+argument counting from the last one; this emulates @kbd{@key{ESC} .}@:
+in @command{zsh}.
These commands get the text of previous shell commands from a special
history list, not from the shell buffer itself. Thus, editing the shell
@@ -1726,10 +1777,10 @@ a specific server file, use the @samp{-f} or @samp{--server-file}
option, or set the @env{EMACS_SERVER_FILE} environment variable
(@pxref{emacsclient Options}). If @code{server-auth-dir} is set to a
non-standard value, or if @code{server-name} is set to an absolute
-file name, @command{emacsclient} needs an absolute file name
-to the server file, as the default @code{server-auth-dir} is
-hard-coded in @command{emacsclient} to be used as the directory for
-resolving relative filenames.
+file name, @command{emacsclient} needs an absolute file name to the
+server file, as the default @code{server-auth-dir} is hard-coded in
+@command{emacsclient} to be used as the directory for resolving
+relative filenames.
@node Invoking emacsclient
@subsection Invoking @code{emacsclient}
@@ -1926,6 +1977,10 @@ If you set @code{server-name} of the Emacs server to an absolute file
name, give the same absolute file name as @var{server-name} to this
option to instruct @command{emacsclient} to connect to that server.
+Alternatively, you can set the @env{EMACS_SOCKET_NAME} environment
+variable to point to the server socket. (The command-line option
+overrides the environment variable.)
+
@item -t
@itemx --tty
@itemx -nw
@@ -2572,7 +2627,7 @@ e.g., the daemon cannot use GUI features, so parameters such as frame
position, size, and decorations cannot be restored. For that reason,
you may wish to delay restoring the desktop in daemon mode until the
first client connects, by calling @code{desktop-read} in a hook
-function that you add to @code{after-make-frame-functions}
+function that you add to @code{server-after-make-frame-hook}
(@pxref{Creating Frames,,, elisp, The Emacs Lisp Reference Manual}).
@node Recursive Edit
diff --git a/doc/emacs/msdos.texi b/doc/emacs/msdos.texi
index fb876340b41..9fc4b6262fb 100644
--- a/doc/emacs/msdos.texi
+++ b/doc/emacs/msdos.texi
@@ -808,6 +808,13 @@ communications with subprocesses to programs that exhibit unusual
behavior with respect to buffering pipe I/O.
@ifnottex
+@vindex w32-pipe-read-delay
+ If you need to invoke MS-DOS programs as Emacs subprocesses, you may
+see low rate of reading data from such programs. Setting the variable
+@code{w32-pipe-read-delay} to a non-zero value may improve throughput
+in these cases; we suggest the value of 50 for such situations. The
+default is zero.
+
@findex w32-shell-execute
The function @code{w32-shell-execute} can be useful for writing
customized commands that run MS-Windows applications registered to
diff --git a/doc/emacs/mule.texi b/doc/emacs/mule.texi
index b3e7d218c62..6a26667510a 100644
--- a/doc/emacs/mule.texi
+++ b/doc/emacs/mule.texi
@@ -397,7 +397,7 @@ messages. But if your locale matches an entry in the variable
coding system instead. For example, if the locale @samp{ja_JP.PCK}
matches @code{japanese-shift-jis} in
@code{locale-preferred-coding-systems}, Emacs uses that encoding even
-though it might normally use @code{japanese-iso-8bit}.
+though it might normally use @code{utf-8}.
You can override the language environment chosen at startup with
explicit use of the command @code{set-language-environment}, or with
diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi
index 99e04740d3c..26e64243301 100644
--- a/doc/emacs/package.texi
+++ b/doc/emacs/package.texi
@@ -241,57 +241,53 @@ lower-priority archives will not be shown in the menu, if the same
package is available from a higher-priority archive. (This is
controlled by the value of @code{package-menu-hide-low-priority}.)
- Once a package is downloaded and installed, it is @dfn{loaded} into
-the current Emacs session. Loading a package is not quite the same as
-loading a Lisp library (@pxref{Lisp Libraries}); loading a package
-adds its directory to @code{load-path} and loads its autoloads. The
-effect of a package's autoloads varies from package to package. Most
-packages just make some new commands available, while others have more
+ Once a package is downloaded and installed, it is made available to
+the current Emacs session. Making a package available adds its
+directory to @code{load-path} and loads its autoloads. The effect of
+a package's autoloads varies from package to package. Most packages
+just make some new commands available, while others have more
wide-ranging effects on the Emacs session. For such information,
consult the package's help buffer.
- By default, Emacs also automatically loads all installed packages in
-subsequent Emacs sessions. This happens at startup, after processing
-the init file (@pxref{Init File}). As an exception, Emacs does not
-load packages at startup if invoked with the @samp{-q} or
+ After a package is installed, it is automatically made available by
+Emacs in all subsequent sessions. This happens at startup, before
+processing the init file but after processing the early init file
+(@pxref{Early Init File}). As an exception, Emacs does not make
+packages available at startup if invoked with the @samp{-q} or
@samp{--no-init-file} options (@pxref{Initial Options}).
@vindex package-enable-at-startup
- To disable automatic package loading, change the variable
-@code{package-enable-at-startup} to @code{nil}.
-
-@findex package-initialize
- The reason automatic package loading occurs after loading the init
-file is that user options only receive their customized values after
-loading the init file, including user options which affect the
-packaging system. In some circumstances, you may want to load
-packages explicitly in your init file (usually because some other code
-in your init file depends on a package). In that case, your init file
-should call the function @code{package-initialize}. It is up to you
-to ensure that relevant user options, such as @code{package-load-list}
-(see below), are set up prior to the @code{package-initialize} call.
-This will automatically set @code{package-enable-at-startup} to @code{nil}, to
-avoid loading the packages again after processing the init file.
-Alternatively, you may choose to completely inhibit package loading at
-startup, and invoke the command @kbd{M-x package-initialize} to load
-your packages manually.
+ To keep Emacs from automatically making packages available at
+startup, change the variable @code{package-enable-at-startup} to
+@code{nil}. You must do this in the early init file, as the variable
+is read before loading the regular init file. Currently this variable
+cannot be set via Customize.
+
+@findex package-activate-all
+ If you have set @code{package-enable-at-startup} to @code{nil}, you
+can still make packages available either during or after startup. To
+make installed packages available during startup, call the function
+@code{package-activate-all} in your init file. To make installed
+packages available after startup, invoke the command @kbd{M-:
+(package-activate-all) RET}.
@vindex package-load-list
- For finer control over package loading, you can use the variable
-@code{package-load-list}. Its value should be a list. A list element
-of the form @code{(@var{name} @var{version})} tells Emacs to load
-version @var{version} of the package named @var{name}. Here,
-@var{version} should be a version string (corresponding to a specific
-version of the package), or @code{t} (which means to load any
-installed version), or @code{nil} (which means no version; this
-disables the package, preventing it from being loaded). A list
-element can also be the symbol @code{all}, which means to load the
-latest installed version of any package not named by the other list
-elements. The default value is just @code{'(all)}.
-
- For example, if you set @code{package-load-list} to @code{'((muse
-"3.20") all)}, then Emacs only loads version 3.20 of the @samp{muse}
-package, plus any installed version of packages other than
+ For finer control over which packages are made available at startup,
+you can use the variable @code{package-load-list}. Its value should
+be a list. A list element of the form @w{@code{(@var{name}
+@var{version})}} tells Emacs to make available version @var{version} of
+the package named @var{name}. Here, @var{version} should be a version
+string (corresponding to a specific version of the package), or
+@code{t} (which means to make available any installed version), or
+@code{nil} (which means no version; this disables the package,
+preventing it from being made available). A list element can also be
+the symbol @code{all}, which means to make available the latest
+installed version of any package not named by the other list elements.
+The default value is just @code{'(all)}.
+
+ For example, if you set @code{package-load-list} to @w{@code{'((muse
+"3.20") all)}}, then Emacs only makes available version 3.20 of the
+@samp{muse} package, plus any installed version of packages other than
@samp{muse}. Any other version of @samp{muse} that happens to be
installed will be ignored. The @samp{muse} package will be listed in
the package menu with the @samp{held} status.
diff --git a/doc/emacs/programs.texi b/doc/emacs/programs.texi
index 9d712eb66cc..c1ad5b57023 100644
--- a/doc/emacs/programs.texi
+++ b/doc/emacs/programs.texi
@@ -156,56 +156,22 @@ Emacs we use it for all languages.
@cindex open-parenthesis in leftmost column
@cindex ( in leftmost column
- Many programming-language modes assume by default that any opening
-delimiter found at the left margin is the start of a top-level
-definition, or defun. Therefore, @strong{don't put an opening
-delimiter at the left margin unless it should have that significance}.
-For instance, never put an open-parenthesis at the left margin in a
-Lisp file unless it is the start of a top-level list.
-
- The convention speeds up many Emacs operations, which would
-otherwise have to scan back to the beginning of the buffer to analyze
-the syntax of the code.
-
- If you don't follow this convention, not only will you have trouble
-when you explicitly use the commands for motion by defuns; other
-features that use them will also give you trouble. This includes the
-indentation commands (@pxref{Program Indent}) and Font Lock mode
-(@pxref{Font Lock}).
-
- The most likely problem case is when you want an opening delimiter
-at the start of a line inside a string. To avoid trouble, put an
-escape character (@samp{\}, in C and Emacs Lisp, @samp{/} in some
-other Lisp dialects) before the opening delimiter. This will not
-affect the contents of the string, but will prevent that opening
-delimiter from starting a defun. Here's an example:
-
-@example
- (insert "Foo:
-\(bar)
-")
-@end example
-
- To help you catch violations of this convention, Font Lock mode
-highlights confusing opening delimiters (those that ought to be
-quoted) in bold red.
+ Many programming-language modes have traditionally assumed that any
+opening parenthesis or brace found at the left margin is the start of
+a top-level definition, or defun. So, by default, commands which seek
+the beginning of a defun accept such a delimiter as signifying that
+position.
@vindex open-paren-in-column-0-is-defun-start
- If you need to override this convention, you can do so by setting
-the variable @code{open-paren-in-column-0-is-defun-start}.
-If this user option is set to @code{t} (the default), opening
-parentheses or braces at column zero always start defuns. When it is
+ If you want to override this convention, you can do so by setting
+the user option @code{open-paren-in-column-0-is-defun-start} to
+@code{nil}. If this option is set to @code{t} (the default), commands
+seeking the start of a defun will stop at opening parentheses or
+braces at column zero which aren't in a comment or string. When it is
@code{nil}, defuns are found by searching for parens or braces at the
-outermost level.
-
- Usually, you should leave this option at its default value of
-@code{t}. If your buffer contains parentheses or braces in column
-zero which don't start defuns, and it is somehow impractical to remove
-these parentheses or braces, it might be helpful to set the option to
-@code{nil}. Be aware that this might make scrolling and display in
-large buffers quite sluggish. Furthermore, the parentheses and braces
-must be correctly matched throughout the buffer for it to work
-properly.
+outermost level. Since low-level Emacs routines no longer depend on
+this convention, you usually won't need to change
+@code{open-paren-in-column-0-is-defun-start} from its default.
@node Moving by Defuns
@subsection Moving by Defuns
diff --git a/doc/emacs/regs.texi b/doc/emacs/regs.texi
index b9d0afe42ee..1881b49627e 100644
--- a/doc/emacs/regs.texi
+++ b/doc/emacs/regs.texi
@@ -80,7 +80,9 @@ information until you store something else in it.
@kindex C-x r j
@findex jump-to-register
The command @kbd{C-x r j @var{r}} switches to the buffer recorded in
-register @var{r}, and moves point to the recorded position. The
+register @var{r}, pushes a mark, and moves point to the recorded
+position. (The mark is not pushed if point was already at the
+recorded position, or in successive calls to the command.) The
contents of the register are not changed, so you can jump to the saved
position any number of times.
diff --git a/doc/emacs/rmail.texi b/doc/emacs/rmail.texi
index 94e1e63d44e..4901ca9709e 100644
--- a/doc/emacs/rmail.texi
+++ b/doc/emacs/rmail.texi
@@ -529,13 +529,18 @@ file name from the message @samp{Subject} header.
@kindex C-o @r{(Rmail)}
@findex rmail-output-as-seen
The commands @kbd{o} and @kbd{C-o} copy the current message into a
-specified file, adding it at the end. The two commands differ mainly
-in how much to copy: @kbd{o} copies the full message headers, even if
-they are not all visible, while @kbd{C-o} copies exactly the headers
-currently displayed and no more. @xref{Rmail Display}. In addition,
-@kbd{o} converts the message to Babyl format (used by Rmail in Emacs
-version 22 and before) if the file is in Babyl format; @kbd{C-o}
-cannot output to Babyl files at all.
+specified file, adding it at the end. A positive prefix argument
+serves as a repeat count: that many consecutive messages will be
+copied to the specified file, starting with the current one and
+ignoring deleted messages.
+
+The two commands differ mainly in how much to copy: @kbd{o} copies the
+full message headers, even if they are not all visible, while
+@kbd{C-o} copies exactly the headers currently displayed and no more.
+@xref{Rmail Display}. In addition, @kbd{o} converts the message to
+Babyl format (used by Rmail in Emacs version 22 and before) if the
+file is in Babyl format; @kbd{C-o} cannot output to Babyl files at
+all.
@c FIXME remove BABYL mention in some future version?
If the output file is currently visited in an Emacs buffer, the
@@ -565,17 +570,29 @@ second says which files in that directory to offer (all those that
match the regular expression). If no files match, you cannot select
this menu item.
-@vindex rmail-delete-after-output
Copying a message with @kbd{o} or @kbd{C-o} gives the original copy
of the message the @samp{filed} attribute, so that @samp{filed}
appears in the mode line when such a message is current.
+@vindex rmail-delete-after-output
If you like to keep just a single copy of every mail message, set
the variable @code{rmail-delete-after-output} to @code{t}; then the
@kbd{o}, @kbd{C-o} and @kbd{w} commands delete the original message
after copying it. (You can undelete it afterward if you wish, see
@ref{Rmail Deletion}.)
+@vindex rmail-output-reset-deleted-flag
+ By default, @kbd{o} will leave the deleted status of a message it
+outputs as it was on the original message; thus, a message deleted
+before it was output will appear as deleted in the output file.
+Setting the variable @code{rmail-output-reset-deleted-flag} to a
+non-@code{nil} value countermands that: the copy of the message will
+have its deleted status reset, so the message will appear as undeleted
+in the output file. In addition, when this variable is
+non-@code{nil}, specifying a positive argument to @kbd{o} will not
+ignore deleted messages when looking for consecutive messages to
+output.
+
@vindex rmail-output-file-alist
The variable @code{rmail-output-file-alist} lets you specify
intelligent defaults for the output file, based on the contents of the
@@ -753,7 +770,7 @@ Try sending a bounced message a second time (@code{rmail-retry-failure}).
to the message you are reading. To do this, type @kbd{r}
(@code{rmail-reply}). This displays a mail composition buffer in
another window, much like @kbd{C-x 4 m}, but preinitializes the
-@samp{Subject}, @samp{To}, @samp{CC}, @samp{In-reply-to} and
+@samp{Subject}, @samp{To}, @samp{CC}, @samp{In-Reply-To} and
@samp{References} header fields based on the message you are replying
to. The @samp{To} field starts out as the address of the person who
sent the message you received, and the @samp{CC} field starts out with
diff --git a/doc/emacs/search.texi b/doc/emacs/search.texi
index 9611d341860..a1c987c1252 100644
--- a/doc/emacs/search.texi
+++ b/doc/emacs/search.texi
@@ -253,6 +253,13 @@ character or word at point to the search string. This is an easy way
to search for another occurrence of the text at point. (The decision
of whether to copy a character or a word is heuristic.)
+@kindex C-M-w @r{(Incremental search)}
+@findex isearch-yank-symbol-or-char
+ @kbd{C-M-w} (@code{isearch-yank-symbol-or-char}) appends the next
+character or symbol at point to the search string. This is an easy way
+to search for another occurrence of the symbol at point. (The decision
+of whether to copy a character or a symbol is heuristic.)
+
@kindex M-s C-e @r{(Incremental search)}
@findex isearch-yank-line
Similarly, @kbd{M-s C-e} (@code{isearch-yank-line}) appends the rest
@@ -274,11 +281,11 @@ appended text with an earlier kill, similar to the usual @kbd{M-y}
in the echo area appends the current X selection (@pxref{Primary
Selection}) to the search string (@code{isearch-yank-x-selection}).
-@kindex C-M-w @r{(Incremental search)}
+@kindex C-M-d @r{(Incremental search)}
@kindex C-M-y @r{(Incremental search)}
@findex isearch-del-char
@findex isearch-yank-char
- @kbd{C-M-w} (@code{isearch-del-char}) deletes the last character
+ @kbd{C-M-d} (@code{isearch-del-char}) deletes the last character
from the search string, and @kbd{C-M-y} (@code{isearch-yank-char})
appends the character after point to the search string. An
alternative method to add the character after point is to enter the
@@ -308,7 +315,7 @@ string that failed to match is highlighted using the face
At this point, there are several things you can do. If your string
was mistyped, use @key{DEL} to cancel a previous input item
-(@pxref{Basic Isearch}), @kbd{C-M-w} to erase one character at a time,
+(@pxref{Basic Isearch}), @kbd{C-M-d} to erase one character at a time,
or @kbd{M-e} to edit it. If you like the place you have found, you
can type @key{RET} to remain there. Or you can type @kbd{C-g}, which
removes from the search string the characters that could not be found
@@ -468,7 +475,7 @@ of the keymap @code{isearch-mode-map} (@pxref{Keymaps}).
This subsection describes how to control whether typing a command not
specifically meaningful in searches exits the search before executing
-the command. It also describes two categories of commands which you
+the command. It also describes three categories of commands which you
can type without exiting the current incremental search, even though
they are not themselves part of incremental search.
@@ -477,7 +484,7 @@ they are not themselves part of incremental search.
search exits the search before executing the command. Thus, the
command operates on the buffer from which you invoked the search.
However, if you customize the variable @code{search-exit-option} to
-@code{nil}, the characters which you type that are not interpreted by
+@code{append}, the characters which you type that are not interpreted by
the incremental search are simply appended to the search string. This
is so you could include in the search string control characters, such
as @kbd{C-a}, that would normally exit the search and invoke the
@@ -538,6 +545,18 @@ change point, the buffer contents, the match data, the current buffer,
or the selected window and frame. The command must not itself attempt
an incremental search. This feature is disabled if
@code{isearch-allow-scroll} is @code{nil} (which it is by default).
+
+@item Motion Commands
+@cindex motion commands, during incremental search
+When @code{isearch-yank-on-move} is customized to @code{shift},
+you can extend the search string by holding down the shift key while
+typing cursor motion commands. It will yank text that ends at the new
+position after moving point in the current buffer.
+
+When @code{isearch-yank-on-move} is @code{t}, you can extend the
+search string without using the shift key for cursor motion commands,
+but it applies only for certain motion command that have the
+@code{isearch-move} property on their symbols.
@end table
@node Isearch Minibuffer
@@ -955,11 +974,10 @@ character class inside a character alternative. For instance,
elisp, The Emacs Lisp Reference Manual}, for a list of character
classes.
-To include a @samp{]} in a character set, you must make it the first
-character. For example, @samp{[]a]} matches @samp{]} or @samp{a}. To
-include a @samp{-}, write @samp{-} as the first or last character of the
-set, or put it after a range. Thus, @samp{[]-]} matches both @samp{]}
-and @samp{-}.
+To include a @samp{]} in a character set, you must make it the first character.
+For example, @samp{[]a]} matches @samp{]} or @samp{a}. To include a @samp{-},
+write @samp{-} as the last character of the set, tho you can also put it first
+or after a range. Thus, @samp{[]-]} matches both @samp{]} and @samp{-}.
To include @samp{^} in a set, put it anywhere but at the beginning of
the set. (At the beginning, it complements the set---see below.)
@@ -1819,7 +1837,7 @@ In the @file{*Occur*} buffer, you can click on each entry, or move
point there and type @key{RET}, to visit the corresponding position in
the buffer that was searched. @kbd{o} and @kbd{C-o} display the match
in another window; @kbd{C-o} does not select it. Alternatively, you
-can use the @kbd{C-x `} (@code{next-error}) command to visit the
+can use the @kbd{M-g M-n} (@code{next-error}) command to visit the
occurrences one by one (@pxref{Compilation Mode}).
@cindex Occur Edit mode
@@ -1855,11 +1873,13 @@ region instead.
@findex flush-lines
@item M-x flush-lines
Prompt for a regexp, and delete each line that contains a match for
-it, operating on the text after point. This command deletes the
-current line if it contains a match starting after point. If the
-region is active, it operates on the region instead; if a line
-partially contained in the region contains a match entirely contained
-in the region, it is deleted.
+it, operating on the text after point. When the command finishes,
+it prints the number of deleted matching lines.
+
+This command deletes the current line if it contains a match starting
+after point. If the region is active, it operates on the region
+instead; if a line partially contained in the region contains a match
+entirely contained in the region, it is deleted.
If a match is split across lines, @code{flush-lines} deletes all those
lines. It deletes the lines before starting to look for the next
diff --git a/doc/emacs/sending.texi b/doc/emacs/sending.texi
index f5d69abf279..c6b8912e2e3 100644
--- a/doc/emacs/sending.texi
+++ b/doc/emacs/sending.texi
@@ -70,7 +70,7 @@ or using some other method. @xref{Mail Sending}, for details.
@example
To: subotai@@example.org
-Cc: mongol.soldier@@example.net, rms@@gnu.org
+CC: mongol.soldier@@example.net, rms@@gnu.org
Subject: Re: What is best in life?
From: conan@@example.org
--text follows this line--
@@ -170,14 +170,14 @@ writes in Babyl format. If an Rmail buffer is visiting the file,
Emacs updates it accordingly. To specify more than one file, use
several @samp{FCC} fields, with one file name in each field.
-@item Reply-to
+@item Reply-To
An address to which replies should be sent, instead of @samp{From}.
This is used if, for some reason, your @samp{From} address cannot
receive replies.
-@item Mail-reply-to
-This field takes precedence over @samp{Reply-to}. It is used because
-some mailing lists set the @samp{Reply-to} field for their own
+@item Mail-Reply-To
+This field takes precedence over @samp{Reply-To}. It is used because
+some mailing lists set the @samp{Reply-To} field for their own
purposes (a somewhat controversial practice).
@item Mail-Followup-To
@@ -186,14 +186,14 @@ messages. This is typically used when you reply to a message from a
mailing list that you are subscribed to, and want replies to go to the
list without sending an extra copy to you.
-@item In-reply-to
+@item In-Reply-To
An identifier for the message you are replying to. Most mail readers
use this information to group related messages together. Normally,
this header is filled in automatically when you reply to a message in
any mail program built into Emacs.
@item References
-Identifiers for previous related messages. Like @samp{In-reply-to},
+Identifiers for previous related messages. Like @samp{In-Reply-To},
this is normally filled in automatically for you.
@end table
@@ -220,12 +220,12 @@ To: foo@@example.net, this@@example.net,
You can direct Emacs to insert certain default headers into the mail
buffer by setting the variable @code{mail-default-headers} to a
string. Then @kbd{C-x m} inserts this string into the message
-headers. For example, here is how to add a @samp{Reply-to} and
+headers. For example, here is how to add a @samp{Reply-To} and
@samp{FCC} header to each message:
@smallexample
(setq mail-default-headers
- "Reply-to: foo@@example.com\nFCC: ~/Mail/sent")
+ "Reply-To: foo@@example.com\nFCC: ~/Mail/sent")
@end smallexample
@noindent
@@ -293,7 +293,7 @@ alias definitions and include commands.
Mail aliases expand as abbrevs---that is to say, as soon as you type
a word-separator character after an alias (@pxref{Abbrevs}). This
expansion takes place only within the @samp{To}, @samp{From},
-@samp{CC}, @samp{BCC}, and @samp{Reply-to} header fields (plus their
+@samp{CC}, @samp{BCC}, and @samp{Reply-To} header fields (plus their
@samp{Resent-} variants); it does not take place in other header
fields, such as @samp{Subject}.
@@ -422,7 +422,7 @@ Move to the @samp{CC} header (@code{message-goto-cc}).
@item C-c C-f C-b
Move to the @samp{BCC} header (@code{message-goto-bcc}).
@item C-c C-f C-r
-Move to the @samp{Reply-to} header (@code{message-goto-reply-to}).
+Move to the @samp{Reply-To} header (@code{message-goto-reply-to}).
@item C-c C-f C-f
Move to the @samp{Mail-Followup-To} header field
(@code{message-goto-followup-to}).
diff --git a/doc/emacs/text.texi b/doc/emacs/text.texi
index e9b17dbb651..96492783b92 100644
--- a/doc/emacs/text.texi
+++ b/doc/emacs/text.texi
@@ -459,6 +459,13 @@ non-@code{nil}, and in programming-language strings if
@code{nil} for @code{electric-quote-string} and @code{t} for the other
variables.
+@vindex electric-quote-replace-double
+ You can also set the option @code{electric-quote-replace-double} to
+a non-@code{nil} value. Then, typing @t{"} insert an appropriate
+curved double quote depending on context: @t{“} at the beginning of
+the buffer or after a line break, whitespace, opening parenthesis, or
+quote character, and @t{”} otherwise.
+
Electric Quote mode is disabled by default. To toggle it in a
single buffer, use @kbd{M-x electric-quote-local-mode}.
To toggle it globally, type
@@ -631,8 +638,11 @@ line. If a function returns a non-@code{nil} value, Emacs will not
break the line there. Functions you can use there include:
@code{fill-single-word-nobreak-p} (don't break after the first word of
a sentence or before the last); @code{fill-single-char-nobreak-p}
-(don't break after a one-letter word); and @code{fill-french-nobreak-p}
-(don't break after @samp{(} or before @samp{)}, @samp{:} or @samp{?}).
+(don't break after a one-letter word preceded by a whitespace
+character); @code{fill-french-nobreak-p} (don't break after @samp{(}
+or before @samp{)}, @samp{:} or @samp{?}); and
+@code{fill-polish-nobreak-p} (don't break after a one letter word,
+even if preceded by a non-whitespace character).
@node Fill Prefix
@subsection The Fill Prefix
@@ -2406,11 +2416,13 @@ to the commands above.
@subsection Setting Other Text Properties
The Special Properties submenu of Text Properties has entries for
-adding or removing three other text properties: @code{read-only},
+adding or removing four other text properties: @code{read-only},
(which disallows alteration of the text), @code{invisible} (which
-hides text), and @code{intangible} (which disallows moving point
-within the text). The @samp{Remove Special} menu item removes all of
-these special properties from the text in the region.
+hides text), @code{intangible} (which disallows moving point within
+the text), and @code{charset} (which is important for selecting a
+proper font to display a character). The @samp{Remove Special} menu
+item removes all of these special properties from the text in the
+region.
The @code{invisible} and @code{intangible} properties are not saved.
diff --git a/doc/emacs/windows.texi b/doc/emacs/windows.texi
index c4c724e6bc2..ece53130531 100644
--- a/doc/emacs/windows.texi
+++ b/doc/emacs/windows.texi
@@ -157,7 +157,9 @@ this option is @code{nil}.
@item C-x o
Select another window (@code{other-window}).
@item C-M-v
-Scroll the next window (@code{scroll-other-window}).
+Scroll the next window upward (@code{scroll-other-window}).
+@item C-M-S-v
+Scroll the next window downward (@code{scroll-other-window-down}).
@item mouse-1
@kbd{mouse-1}, in the text area of a window, selects the window and
moves point to the position clicked. Clicking in the mode line
@@ -181,13 +183,18 @@ back and finish supplying the minibuffer argument that is requested.
@kindex C-M-v
@findex scroll-other-window
+@kindex C-M-S-v
+@findex scroll-other-window-down
The usual scrolling commands (@pxref{Display}) apply to the selected
-window only, but there is one command to scroll the next window.
+window only, but there are also commands to scroll the next window.
@kbd{C-M-v} (@code{scroll-other-window}) scrolls the window that
-@kbd{C-x o} would select. It takes arguments, positive and negative,
-like @kbd{C-v}. (In the minibuffer, @kbd{C-M-v} scrolls the help
-window associated with the minibuffer, if any, rather than the next
-window in the standard cyclic order; @pxref{Minibuffer Edit}.)
+@kbd{C-x o} would select. In other respects, the command behaves like
+@kbd{C-v}; both move the buffer text upward relative to the window, and
+take positive and negative arguments. (In the minibuffer, @kbd{C-M-v}
+scrolls the help window associated with the minibuffer, if any, rather
+than the next window in the standard cyclic order; @pxref{Minibuffer
+Edit}.) @kbd{C-M-S-v} (@code{scroll-other-window-down}) scrolls the
+next window downward in a similar way.
@vindex mouse-autoselect-window
If you set @code{mouse-autoselect-window} to a non-@code{nil} value,
@@ -359,7 +366,7 @@ various help commands (@pxref{Help}), work by calling
Other commands do the same as @code{display-buffer}, and
additionally select the displaying window so that you can begin
-editing its buffer. The command @kbd{C-x `} (@code{next-error}) is
+editing its buffer. The command @kbd{M-g M-n} (@code{next-error}) is
one example (@pxref{Compilation Mode}). Such commands work by calling
the function @code{pop-to-buffer} internally. @xref{Switching
Buffers,,Switching to a Buffer in a Window, elisp, The Emacs Lisp
diff --git a/doc/lispintro/Makefile.in b/doc/lispintro/Makefile.in
index efe5a1e0046..37fffb8a0f2 100644
--- a/doc/lispintro/Makefile.in
+++ b/doc/lispintro/Makefile.in
@@ -109,8 +109,8 @@ emacs-lisp-intro.ps: emacs-lisp-intro.dvi
.PHONY: mostlyclean clean distclean bootstrap-clean maintainer-clean infoclean
mostlyclean:
- rm -f *.aux *.log *.toc *.cp *.cps *.fn *.fns *.ky *.kys \
- *.op *.ops *.pg *.pgs *.tp *.tps *.vr *.vrs
+ rm -f ./*.aux ./*.log ./*.toc ./*.cp ./*.cps ./*.fn ./*.fns ./*.ky ./*.kys \
+ ./*.op ./*.ops ./*.pg ./*.pgs ./*.tp ./*.tps ./*.vr ./*.vrs
clean: mostlyclean
rm -f $(DVI_TARGETS) $(HTML_TARGETS) $(PDF_TARGETS) $(PS_TARGETS)
diff --git a/doc/lispintro/emacs-lisp-intro.texi b/doc/lispintro/emacs-lisp-intro.texi
index c4b19a4e50a..519decb1d04 100644
--- a/doc/lispintro/emacs-lisp-intro.texi
+++ b/doc/lispintro/emacs-lisp-intro.texi
@@ -11070,9 +11070,8 @@ The @code{dotimes} macro is similar to @code{dolist}, except that it
loops a specific number of times.
The first argument to @code{dotimes} is assigned the numbers 0, 1, 2
-and so forth each time around the loop, and the value of the third
-argument is returned. You need to provide the value of the second
-argument, which is how many times the macro loops.
+and so forth each time around the loop. You need to provide the value
+of the second argument, which is how many times the macro loops.
@need 1250
For example, the following binds the numbers from 0 up to, but not
@@ -11084,17 +11083,18 @@ three numbers in all, starting with zero as the first number.)
@smallexample
@group
(let (value) ; otherwise a value is a void variable
- (dotimes (number 3 value)
- (setq value (cons number value))))
+ (dotimes (number 3)
+ (setq value (cons number value)))
+ value)
@result{} (2 1 0)
@end group
@end smallexample
@noindent
-@code{dotimes} returns @code{value}, so the way to use
-@code{dotimes} is to operate on some expression @var{number} number of
-times and then return the result, either as a list or an atom.
+The way to use @code{dotimes} is to operate on some expression
+@var{number} number of times and then return the result, either as
+a list or an atom.
@need 1250
Here is an example of a @code{defun} that uses @code{dotimes} to add
@@ -11105,8 +11105,9 @@ up the number of pebbles in a triangle.
(defun triangle-using-dotimes (number-of-rows)
"Using `dotimes', add up the number of pebbles in a triangle."
(let ((total 0)) ; otherwise a total is a void variable
- (dotimes (number number-of-rows total)
- (setq total (+ total (1+ number))))))
+ (dotimes (number number-of-rows)
+ (setq total (+ total (1+ number))))
+ total))
(triangle-using-dotimes 4)
@end group
@@ -15598,7 +15599,7 @@ like this:
(recursive-lengths-list-many-files
(files-in-below-directory "/usr/local/src/emacs/lisp/"))
'<)
- (insert (format "%s" (current-time-string))))
+ (insert (current-time-string)))
@end ignore
@node Counting function definitions
@@ -16798,7 +16799,7 @@ It will look like this:
;; If you edit it by hand, you could mess it up, so be careful.
;; Your init file should contain only one such instance.
;; If there is more than one, they won't work right.
- '(text-mode-hook (quote (turn-on-auto-fill text-mode-hook-identify))))
+ '(text-mode-hook '(turn-on-auto-fill text-mode-hook-identify)))
@end group
@end smallexample
diff --git a/doc/lispref/Makefile.in b/doc/lispref/Makefile.in
index 74e3878a37e..5de04a7784c 100644
--- a/doc/lispref/Makefile.in
+++ b/doc/lispref/Makefile.in
@@ -167,8 +167,8 @@ elisp.ps: elisp.dvi
## [12] stuff is from two-volume.make.
mostlyclean:
- rm -f *.aux *.log *.toc *.cp *.cps *.fn *.fns *.ky *.kys \
- *.op *.ops *.pg *.pgs *.tp *.tps *.vr *.vrs
+ rm -f ./*.aux ./*.log ./*.toc ./*.cp ./*.cps ./*.fn ./*.fns ./*.ky ./*.kys \
+ ./*.op ./*.ops ./*.pg ./*.pgs ./*.tp ./*.tps ./*.vr ./*.vrs
rm -f elisp[12]* vol[12].tmp
clean: mostlyclean
diff --git a/doc/lispref/abbrevs.texi b/doc/lispref/abbrevs.texi
index 558040ebf67..b67c014a83d 100644
--- a/doc/lispref/abbrevs.texi
+++ b/doc/lispref/abbrevs.texi
@@ -232,7 +232,8 @@ Emacs commands to offer to save your abbrevs.
Save all abbrev definitions (except system abbrevs), for all abbrev
tables listed in @code{abbrev-table-name-list}, in the file
@var{filename}, in the form of a Lisp program that when loaded will
-define the same abbrevs. If @var{filename} is @code{nil} or omitted,
+define the same abbrevs. Tables that do not have any abbrevs to save
+are omitted. If @var{filename} is @code{nil} or omitted,
@code{abbrev-file-name} is used. This function returns @code{nil}.
@end deffn
diff --git a/doc/lispref/buffers.texi b/doc/lispref/buffers.texi
index 6ad1fb1824a..260f159851b 100644
--- a/doc/lispref/buffers.texi
+++ b/doc/lispref/buffers.texi
@@ -573,7 +573,6 @@ echo area; use @code{set-buffer-modified-p} (above) instead.
This function returns @var{buffer}'s modification-count. This is a
counter that increments every time the buffer is modified. If
@var{buffer} is @code{nil} (or omitted), the current buffer is used.
-The counter can wrap around occasionally.
@end defun
@defun buffer-chars-modified-tick &optional buffer
@@ -648,16 +647,13 @@ file should not be done.
@defun visited-file-modtime
This function returns the current buffer's recorded last file
-modification time, as a list of the form @code{(@var{high} @var{low}
-@var{microsec} @var{picosec})}. (This is the same format that
-@code{file-attributes} uses to return time values; @pxref{File
-Attributes}.)
+modification time, as a Lisp timestamp (@pxref{Time of Day}).
If the buffer has no recorded last modification time, this function
returns zero. This case occurs, for instance, if the buffer is not
visiting a file or if the time has been explicitly cleared by
@code{clear-visited-file-modtime}. Note, however, that
-@code{visited-file-modtime} returns a list for some non-file buffers
+@code{visited-file-modtime} returns a timestamp for some non-file buffers
too. For instance, in a Dired buffer listing a directory, it returns
the last modification time of that directory, as recorded by Dired.
@@ -672,9 +668,8 @@ is not @code{nil}, and otherwise to the last modification time of the
visited file.
If @var{time} is neither @code{nil} nor an integer flag returned
-by @code{visited-file-modtime}, it should have the form
-@code{(@var{high} @var{low} @var{microsec} @var{picosec})},
-the format used by @code{current-time} (@pxref{Time of Day}).
+by @code{visited-file-modtime}, it should be a Lisp time value
+(@pxref{Time of Day}).
This function is useful if the buffer was not read from the file
normally, or if the file itself has been changed for some known benign
@@ -831,7 +826,7 @@ regardless of which frames they were displayed on.
@group
;; @r{Note that the name of the minibuffer}
;; @r{begins with a space!}
-(mapcar (function buffer-name) (buffer-list))
+(mapcar #'buffer-name (buffer-list))
@result{} ("buffers.texi" " *Minibuf-1*"
"buffer.c" "*Help*" "TAGS")
@end group
diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi
index 1eb580e1e0f..cd44c1c87ef 100644
--- a/doc/lispref/commands.texi
+++ b/doc/lispref/commands.texi
@@ -2880,6 +2880,14 @@ command's key sequence (as returned by, e.g., @code{this-command-keys}),
as the events will already have been added once as they were read for
the first time. An element of the form @w{@code{(t . @var{event})}}
forces @var{event} to be added to the current command's key sequence.
+
+@cindex not recording input events
+@cindex input events, prevent recording
+Elements read from this list are normally recorded by the
+record-keeping features (@pxref{Recording Input}) and while defining a
+keyboard macro (@pxref{Keyboard Macros}). However, an element of the
+form @w{@code{(no-record . @var{event})}} causes @var{event} to be
+processed normally without recording it.
@end defvar
@defun listify-key-sequence key
diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi
index 3ffe8f7fb9d..5d4184e3fb4 100644
--- a/doc/lispref/control.texi
+++ b/doc/lispref/control.texi
@@ -1095,12 +1095,10 @@ Matches if @var{expval} is a vector of length @var{m} whose
@item @var{symbol}
@itemx @var{keyword}
-@itemx @var{integer}
+@itemx @var{number}
@itemx @var{string}
Matches if the corresponding element of @var{expval} is
@code{equal} to the specified literal object.
-Note that, aside from @var{symbol}, this is the same set of
-self-quoting literal objects that are acceptable as a core pattern.
@item ,@var{pattern}
Matches if the corresponding element of @var{expval}
@@ -1355,7 +1353,8 @@ This construct executes @var{body} once for each integer from 0
(inclusive) to @var{count} (exclusive), binding the variable @var{var}
to the integer for the current iteration. Then it returns the value
of evaluating @var{result}, or @code{nil} if @var{result} is omitted.
-Here is an example of using @code{dotimes} to do something 100 times:
+Use of @var{result} is deprecated. Here is an example of using
+@code{dotimes} to do something 100 times:
@example
(dotimes (i 100)
@@ -1986,9 +1985,10 @@ error occurs during @var{protected-form}.
Each of the @var{handlers} is a list of the form @code{(@var{conditions}
@var{body}@dots{})}. Here @var{conditions} is an error condition name
to be handled, or a list of condition names (which can include @code{debug}
-to allow the debugger to run before the handler); @var{body} is one or more
-Lisp expressions to be executed when this handler handles an error.
-Here are examples of handlers:
+to allow the debugger to run before the handler). A condition name of
+@code{t} matches any condition. @var{body} is one or more Lisp
+expressions to be executed when this handler handles an error. Here
+are examples of handlers:
@example
@group
diff --git a/doc/lispref/debugging.texi b/doc/lispref/debugging.texi
index 2576fbe39d7..9e433433107 100644
--- a/doc/lispref/debugging.texi
+++ b/doc/lispref/debugging.texi
@@ -81,7 +81,8 @@ debugger recursively. @xref{Recursive Editing}.
* Function Debugging:: Entering it when a certain function is called.
* Variable Debugging:: Entering it when a variable is modified.
* Explicit Debug:: Entering it at a certain point in the program.
-* Using Debugger:: What the debugger does; what you see while in it.
+* Using Debugger:: What the debugger does.
+* Backtraces:: What you see while in the debugger.
* Debugger Commands:: Commands used while in the debugger.
* Invoking the Debugger:: How to call the function @code{debug}.
* Internals of Debugger:: Subroutines of the debugger, and global variables.
@@ -392,32 +393,82 @@ this is not what you want, you can either set
@code{eval-expression-debug-on-error} to @code{nil}, or set
@code{debug-on-error} to @code{nil} in @code{debugger-mode-hook}.
+ The debugger itself must be run byte-compiled, since it makes
+assumptions about the state of the Lisp interpreter. These
+assumptions are false if the debugger is running interpreted.
+
+@node Backtraces
+@subsection Backtraces
+@cindex backtrace buffer
+
+Debugger mode is derived from Backtrace mode, which is also used to
+show backtraces by Edebug and ERT. (@pxref{Edebug}, and @ref{Top,the
+ERT manual,, ert, ERT: Emacs Lisp Regression Testing}.)
+
+@cindex stack frame
+The backtrace buffer shows you the functions that are executing and
+their argument values. When a backtrace buffer is created, it shows
+each stack frame on one, possibly very long, line. (A stack frame is
+the place where the Lisp interpreter records information about a
+particular invocation of a function.) The most recently called
+function will be at the top.
+
@cindex current stack frame
- The backtrace buffer shows you the functions that are executing and
-their argument values. It also allows you to specify a stack frame by
-moving point to the line describing that frame. (A stack frame is the
-place where the Lisp interpreter records information about a particular
-invocation of a function.) The frame whose line point is on is
-considered the @dfn{current frame}. Some of the debugger commands
-operate on the current frame. If a line starts with a star, that means
-that exiting that frame will call the debugger again. This is useful
-for examining the return value of a function.
-
- If a function name is underlined, that means the debugger knows
-where its source code is located. You can click with the mouse on
-that name, or move to it and type @key{RET}, to visit the source code.
+In a backtrace you can specify a stack frame by moving point to a line
+describing that frame. The frame whose line point is on is considered
+the @dfn{current frame}.
+
+If a function name is underlined, that means Emacs knows where its
+source code is located. You can click with the mouse on that name, or
+move to it and type @key{RET}, to visit the source code. You can also
+type @key{RET} while point is on any name of a function or variable
+which is not underlined, to see help information for that symbol in a
+help buffer, if any exists. The @code{xref-find-definitions} command,
+bound to @key{M-.}, can also be used on any identifier in a backtrace
+(@pxref{Looking Up Identifiers,,,emacs, The GNU Emacs Manual}).
+
+In backtraces, the tails of long lists and the ends of long strings,
+vectors or structures, as well as objects which are deeply nested,
+will be printed as underlined ``...''. You can click with the mouse
+on a ``...'', or type @key{RET} while point is on it, to show the part
+of the object that was hidden. To control how much abbreviation is
+done, customize @code{backtrace-line-length}.
+
+Here is a list of commands for navigating and viewing backtraces:
- The debugger itself must be run byte-compiled, since it makes
-assumptions about how many stack frames are used for the debugger
-itself. These assumptions are false if the debugger is running
-interpreted.
+@table @kbd
+@item v
+Toggle the display of local variables of the current stack frame.
+
+@item p
+Move to the beginning of the frame, or to the beginning
+of the previous frame.
+
+@item n
+Move to the beginning of the next frame.
+
+@item +
+Add line breaks and indentation to the top-level Lisp form at point to
+make it more readable.
+
+@item -
+Collapse the top-level Lisp form at point back to a single line.
+
+@item #
+Toggle @code{print-circle} for the frame at point.
+
+@item .
+Expand all the forms abbreviated with ``...'' in the frame at point.
+
+@end table
@node Debugger Commands
@subsection Debugger Commands
@cindex debugger command list
The debugger buffer (in Debugger mode) provides special commands in
-addition to the usual Emacs commands. The most important use of
+addition to the usual Emacs commands and to the Backtrace mode commands
+described in the previous section. The most important use of
debugger commands is for stepping through code, so that you can see
how control flows. The debugger can step through the control
structures of an interpreted function, but cannot do so in a
@@ -427,6 +478,11 @@ the same function. (To do this, visit the source for the function and
type @kbd{C-M-x} on its definition.) You cannot use the Lisp debugger
to step through a primitive function.
+Some of the debugger commands operate on the current frame. If a
+frame starts with a star, that means that exiting that frame will call the
+debugger again. This is useful for examining the return value of a
+function.
+
@c FIXME: Add @findex for the following commands? --xfq
Here is a list of Debugger mode commands:
@@ -502,8 +558,6 @@ Display a list of functions that will invoke the debugger when called.
This is a list of functions that are set to break on entry by means of
@code{debug-on-entry}.
-@item v
-Toggle the display of local variables of the current stack frame.
@end table
@node Invoking the Debugger
@@ -624,20 +678,19 @@ of @code{debug} (@pxref{Invoking the Debugger}).
@cindex run time stack
@cindex call stack
This function prints a trace of Lisp function calls currently active.
-This is the function used by @code{debug} to fill up the
-@file{*Backtrace*} buffer. It is written in C, since it must have access
-to the stack to determine which function calls are active. The return
-value is always @code{nil}.
+The trace is identical to the one that @code{debug} would show in the
+@file{*Backtrace*} buffer. The return value is always nil.
In the following example, a Lisp expression calls @code{backtrace}
explicitly. This prints the backtrace to the stream
@code{standard-output}, which, in this case, is the buffer
@samp{backtrace-output}.
-Each line of the backtrace represents one function call. The line shows
-the values of the function's arguments if they are all known; if they
-are still being computed, the line says so. The arguments of special
-forms are elided.
+Each line of the backtrace represents one function call. The line
+shows the function followed by a list of the values of the function's
+arguments if they are all known; if they are still being computed, the
+line consists of a list containing the function and its unevaluated
+arguments. Long lists or deeply nested structures may be elided.
@smallexample
@group
@@ -654,10 +707,10 @@ forms are elided.
@group
----------- Buffer: backtrace-output ------------
backtrace()
- (list ...computing arguments...)
+ (list 'testing (backtrace))
@end group
(progn ...)
- eval((progn (1+ var) (list (quote testing) (backtrace))))
+ eval((progn (1+ var) (list 'testing (backtrace))))
(setq ...)
(save-excursion ...)
(let ...)
@@ -685,10 +738,10 @@ example would look as follows:
@group
----------- Buffer: backtrace-output ------------
(backtrace)
- (list ...computing arguments...)
+ (list 'testing (backtrace))
@end group
(progn ...)
- (eval (progn (1+ var) (list (quote testing) (backtrace))))
+ (eval (progn (1+ var) (list 'testing (backtrace))))
(setq ...)
(save-excursion ...)
(let ...)
diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi
index e3ee62ffb68..a97aabe9dff 100644
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@@ -469,19 +469,54 @@ never print it, there are many good reasons for this not to happen.
Secondly, @samp{done} is more explicit.
@end defun
-@defmac dotimes-with-progress-reporter (var count [result]) message body@dots{}
+@defmac dotimes-with-progress-reporter (var count [result]) reporter-or-message body@dots{}
This is a convenience macro that works the same way as @code{dotimes}
does, but also reports loop progress using the functions described
-above. It allows you to save some typing.
+above. It allows you to save some typing. The argument
+@var{reporter-or-message} can be either a string or a progress
+reporter object.
-You can rewrite the example in the beginning of this node using
-this macro this way:
+You can rewrite the example in the beginning of this subsection using
+this macro as follows:
@example
+@group
(dotimes-with-progress-reporter
(k 500)
"Collecting some mana for Emacs..."
(sit-for 0.01))
+@end group
+@end example
+
+Using a reporter object as the @var{reporter-or-message} argument is
+useful if you want to specify the optional arguments in
+@var{make-progress-reporter}. For instance, you can write the
+previous example as follows:
+
+@example
+@group
+(dotimes-with-progress-reporter
+ (k 500)
+ (make-progress-reporter "Collecting some mana for Emacs..." 0 500 0 1 1.5)
+ (sit-for 0.01))
+@end group
+@end example
+@end defmac
+
+@defmac dolist-with-progress-reporter (var count [result]) reporter-or-message body@dots{}
+This is another convenience macro that works the same way as @code{dolist}
+does, but also reports loop progress using the functions described
+above. As in @code{dotimes-with-progress-reporter},
+@code{reporter-or-message} can be a progress reporter or a string.
+You can rewrite the previous example with this macro as follows:
+
+@example
+@group
+(dolist-with-progress-reporter
+ (k (number-sequence 0 500))
+ "Collecting some mana for Emacs..."
+ (sit-for 0.01))
+@end group
@end example
@end defmac
@@ -999,8 +1034,8 @@ hiding certain lines on the screen.
@cindex explicit selective display
The first variant, explicit selective display, was designed for use in a Lisp
program: it controls which lines are hidden by altering the text. This kind of
-hiding is now obsolete; instead you can get the same effect with the
-@code{invisible} property (@pxref{Invisible Text}).
+hiding is now obsolete and deprecated; instead you should use the
+@code{invisible} property (@pxref{Invisible Text}) to get the same effect.
In the second variant, the choice of lines to hide is made
automatically based on indentation. This variant is designed to be a
@@ -2939,7 +2974,13 @@ the remapped face---it replaces the normal definition of @var{face},
instead of modifying it.
If @code{face-remapping-alist} is buffer-local, its local value takes
-effect only within that buffer.
+effect only within that buffer. If @code{face-remapping-alist}
+includes faces applicable only to certain windows, by using the
+@w{@code{(:filtered (:window @var{param} @var{val}) @var{spec})}},
+that face takes effect only in windows that match the filter
+conditions (@pxref{Special Properties}). To turn off face filtering
+temporarily, bind @code{face-filters-always-match} to a non-@code{nil}
+value, then all face filters will match any window.
Note: face remapping is non-recursive. If @var{remapping} references
the same face name @var{face}, either directly or via the
@@ -4139,10 +4180,10 @@ Used to indicate continued lines.
@item @code{right-triangle}, @code{left-triangle}
The former is used by overlay arrows. The latter is unused.
-@item @code{up-arrow}, @code{down-arrow}, @code{top-left-angle} @code{top-right-angle}
+@item @code{up-arrow}, @code{down-arrow}
@itemx @code{bottom-left-angle}, @code{bottom-right-angle}
-@itemx @code{top-right-angle}, @code{top-left-angle}
-@itemx @code{left-bracket}, @code{right-bracket}, @code{top-right-angle}, @code{top-left-angle}
+@itemx @code{top-left-angle}, @code{top-right-angle}
+@itemx @code{left-bracket}, @code{right-bracket}
Used to indicate buffer boundaries.
@item @code{filled-rectangle}, @code{hollow-rectangle}
@@ -4150,7 +4191,7 @@ Used to indicate buffer boundaries.
@itemx @code{vertical-bar}, @code{horizontal-bar}
Used for different types of fringe cursors.
-@item @code{empty-line}, @code{exclamation-mark}, @code{question-mark}, @code{exclamation-mark}
+@item @code{empty-line}, @code{exclamation-mark}, @code{question-mark}
Not used by core Emacs features.
@end table
@@ -5097,6 +5138,47 @@ This adds a shadow rectangle around the image. The value,
@var{relief} is negative, shadows are drawn so that the image appears
as a pressed button; otherwise, it appears as an unpressed button.
+@item :width @var{width}, :height @var{height}
+The @code{:width} and @code{:height} keywords are used for scaling the
+image. If only one of them is specified, the other one will be
+calculated so as to preserve the aspect ratio. If both are specified,
+aspect ratio may not be preserved.
+
+@item :max-width @var{max-width}, :max-height @var{max-height}
+The @code{:max-width} and @code{:max-height} keywords are used for
+scaling if the size of the image exceeds these values. If
+@code{:width} is set, it will have precedence over @code{max-width},
+and if @code{:height} is set, it will have precedence over
+@code{max-height}, but you can otherwise mix these keywords as you
+wish.
+
+If both @code{:max-width} and @code{:height} are specified, but
+@code{:width} is not, preserving the aspect ratio might require that
+width exceeds @code{:max-width}. If this happens, scaling will use a
+smaller value for the height so as to preserve the aspect ratio while
+not exceeding @code{:max-width}. Similarly when both
+@code{:max-height} and @code{:width} are specified, but @code{:height}
+is not. For example, if you have a 200x100 image and specify that
+@code{:width} should be 400 and @code{:max-height} should be 150,
+you'll end up with an image that is 300x150: Preserving the aspect
+ratio and not exceeding the ``max'' setting. This combination of
+parameters is a useful way of saying ``display this image as large as
+possible, but no larger than the available display area''.
+
+@item :scale @var{scale}
+This should be a number, where values higher than 1 means to increase
+the size, and lower means to decrease the size, by multiplying both
+the width and height. For instance, a value of 0.25 will make the
+image a quarter size of what it originally was. If the scaling makes
+the image larger than specified by @code{:max-width} or
+@code{:max-height}, the resulting size will not exceed those two
+values. If both @code{:scale} and @code{:height}/@code{:width} are
+specified, the height/width will be adjusted by the specified scaling
+factor.
+
+@item :index @var{frame}
+@xref{Multi-Frame Images}.
+
@item :conversion @var{algorithm}
This specifies a conversion algorithm that should be applied to the
image before it is displayed; the value, @var{algorithm}, specifies
@@ -5236,6 +5318,16 @@ This function returns @code{t} if image @var{spec} has a mask bitmap.
(@pxref{Input Focus}).
@end defun
+@defun image-scaling-p &optional frame
+This function returns @code{t} if @var{frame} supports image scaling.
+@var{frame} @code{nil} or omitted means to use the selected frame
+(@pxref{Input Focus}).
+
+If image scaling is not supported, @code{:width}, @code{:height},
+@code{:scale}, @code{:max-width} and @code{:max-height} will only be
+usable through ImageMagick, if available (@pxref{ImageMagick Images}).
+@end defun
+
@node XBM Images
@subsection XBM Images
@cindex XBM
@@ -5372,42 +5464,6 @@ color, which is used as the image's background color if the image
supports transparency. If the value is @code{nil}, it defaults to the
frame's background color.
-@item :width @var{width}, :height @var{height}
-The @code{:width} and @code{:height} keywords are used for scaling the
-image. If only one of them is specified, the other one will be
-calculated so as to preserve the aspect ratio. If both are specified,
-aspect ratio may not be preserved.
-
-@item :max-width @var{max-width}, :max-height @var{max-height}
-The @code{:max-width} and @code{:max-height} keywords are used for
-scaling if the size of the image of the image exceeds these values.
-If @code{:width} is set it will have precedence over @code{max-width},
-and if @code{:height} is set it will have precedence over
-@code{max-height}, but you can otherwise mix these keywords as you
-wish. @code{:max-width} and @code{:max-height} will always preserve
-the aspect ratio.
-
-If both @code{:width} and @code{:max-height} has been set (but
-@code{:height} has not been set), then @code{:max-height} will have
-precedence. The same is the case for the opposite combination: The
-``max'' keyword has precedence. That is, if you have a 200x100 image
-and specify that @code{:width} should be 400 and @code{:max-height}
-should be 150, you'll end up with an image that is 300x150: Preserving
-the aspect ratio and not exceeding the ``max'' setting. This
-combination of parameters is a useful way of saying ``display this
-image as large as possible, but no larger than the available display
-area''.
-
-@item :scale @var{scale}
-This should be a number, where values higher than 1 means to increase
-the size, and lower means to decrease the size. For instance, a value
-of 0.25 will make the image a quarter size of what it originally was.
-If the scaling makes the image larger than specified by
-@code{:max-width} or @code{:max-height}, the resulting size will not
-exceed those two values. If both @code{:scale} and
-@code{:height}/@code{:width} are specified, the height/width will be
-adjusted by the specified scaling factor.
-
@item :format @var{type}
The value, @var{type}, should be a symbol specifying the type of the
image data, as found in @code{image-format-suffixes}. This is used
@@ -5416,9 +5472,6 @@ hint to ImageMagick to help it detect the image type.
@item :rotation @var{angle}
Specifies a rotation angle in degrees.
-
-@item :index @var{frame}
-@xref{Multi-Frame Images}.
@end table
@node SVG Images
diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi
index e674280a83d..2c0ee3969b9 100644
--- a/doc/lispref/edebug.texi
+++ b/doc/lispref/edebug.texi
@@ -442,8 +442,18 @@ Redisplay the most recently known expression result in the echo area
Display a backtrace, excluding Edebug's own functions for clarity
(@code{edebug-backtrace}).
-You cannot use debugger commands in the backtrace buffer in Edebug as
-you would in the standard debugger.
+@xref{Backtraces}, for a description of backtraces
+and the commands which work on them.
+
+@findex edebug-backtrace-show-instrumentation
+@findex edebug-backtrace-hide-instrumentation
+If you would like to see Edebug's functions in the backtrace,
+use @kbd{M-x edebug-backtrace-show-instrumentation}. To hide them
+again use @kbd{M-x edebug-backtrace-hide-instrumentation}.
+
+If a backtrace frame starts with @samp{>} that means that Edebug knows
+where the source code for the frame is located. Use @kbd{s} to jump
+to the source code for the current frame.
The backtrace buffer is killed automatically when you continue
execution.
@@ -1711,3 +1721,33 @@ Whether or not to pause for @code{edebug-sit-for-seconds} on reaching
a breakpoint. Set to @code{nil} to prevent the pause, non-@code{nil}
to allow it.
@end defopt
+
+@defopt edebug-behavior-alist
+By default, this alist contains one entry with the key @code{edebug}
+and a list of three functions, which are the default implementations
+of the functions inserted in instrumented code: @code{edebug-enter},
+@code{edebug-before} and @code{edebug-after}. To change Edebug's
+behavior globally, modify the default entry.
+
+Edebug's behavior may also be changed on a per-definition basis by
+adding an entry to this alist, with a key of your choice and three
+functions. Then set the @code{edebug-behavior} symbol property of an
+instrumented definition to the key of the new entry, and Edebug will
+call the new functions in place of its own for that definition.
+@end defopt
+
+@defopt edebug-new-definition-function
+A function run by Edebug after it wraps the body of a definition
+or closure. After Edebug has initialized its own data, this function
+is called with one argument, the symbol associated with the
+definition, which may be the actual symbol defined or one generated by
+Edebug. This function may be used to set the @code{edebug-behavior}
+symbol property of each definition instrumented by Edebug.
+@end defopt
+
+@defopt edebug-after-instrumentation-function
+To inspect or modify Edebug's instrumentation before it is used, set
+this variable to a function which takes one argument, an instrumented
+top-level form, and returns either the same or a replacement form,
+which Edebug will then use as the final result of instrumentation.
+@end defopt
diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi
index a2b03da5abc..e18759654d9 100644
--- a/doc/lispref/elisp.texi
+++ b/doc/lispref/elisp.texi
@@ -455,6 +455,7 @@ Evaluation
the program).
* Backquote:: Easier construction of list structure.
* Eval:: How to invoke the Lisp interpreter explicitly.
+* Deferred Eval:: Deferred and lazy evaluation of forms.
Kinds of Forms
@@ -654,7 +655,8 @@ The Lisp Debugger
* Function Debugging:: Entering it when a certain function is called.
* Variable Debugging:: Entering it when a variable is modified.
* Explicit Debug:: Entering it at a certain point in the program.
-* Using Debugger:: What the debugger does; what you see while in it.
+* Using Debugger:: What the debugger does.
+* Backtraces:: What you see while in the debugger.
* Debugger Commands:: Commands used while in the debugger.
* Invoking the Debugger:: How to call the function @code{debug}.
* Internals of Debugger:: Subroutines of the debugger, and global variables.
@@ -1354,6 +1356,7 @@ Threads
* Basic Thread Functions:: Basic thread functions.
* Mutexes:: Mutexes allow exclusive access to data.
* Condition Variables:: Inter-thread events.
+* The Thread List:: Show the active threads.
Processes
@@ -1398,7 +1401,6 @@ Packing and Unpacking Byte Arrays
* Bindat Spec:: Describing data layout.
* Bindat Functions:: Doing the unpacking and packing.
-* Bindat Examples:: Samples of what bindat.el can do for you!
Emacs Display
diff --git a/doc/lispref/errors.texi b/doc/lispref/errors.texi
index c794028b5e6..aa99b2b1a98 100644
--- a/doc/lispref/errors.texi
+++ b/doc/lispref/errors.texi
@@ -159,6 +159,11 @@ The message is @samp{No catch for tag}. @xref{Catch and Throw}.
The message is @samp{Attempt to modify a protected file}.
@end ignore
+@item range-error
+The message is @code{Arithmetic range error}.
+This can happen with integers exceeding the @code{integer-width} limit.
+@xref{Integer Basics}.
+
@item scan-error
The message is @samp{Scan error}. This happens when certain
syntax-parsing functions find invalid syntax or mismatched
@@ -223,9 +228,6 @@ The message is @samp{Arithmetic domain error}.
The message is @samp{Arithmetic overflow error}. This is a subcategory
of @code{domain-error}.
-@item range-error
-The message is @code{Arithmetic range error}.
-
@item singularity-error
The message is @samp{Arithmetic singularity error}. This is a
subcategory of @code{domain-error}.
diff --git a/doc/lispref/eval.texi b/doc/lispref/eval.texi
index 4bf70d247b6..db42dfb6373 100644
--- a/doc/lispref/eval.texi
+++ b/doc/lispref/eval.texi
@@ -20,11 +20,12 @@ function @code{eval}.
@ifnottex
@menu
-* Intro Eval:: Evaluation in the scheme of things.
-* Forms:: How various sorts of objects are evaluated.
-* Quoting:: Avoiding evaluation (to put constants in the program).
-* Backquote:: Easier construction of list structure.
-* Eval:: How to invoke the Lisp interpreter explicitly.
+* Intro Eval:: Evaluation in the scheme of things.
+* Forms:: How various sorts of objects are evaluated.
+* Quoting:: Avoiding evaluation (to put constants in the program).
+* Backquote:: Easier construction of list structure.
+* Eval:: How to invoke the Lisp interpreter explicitly.
+* Deferred Eval:: Deferred and lazy evaluation of forms.
@end menu
@node Intro Eval
@@ -584,15 +585,15 @@ Here are some examples of expressions that use @code{quote}:
@end group
@group
''foo
- @result{} (quote foo)
+ @result{} 'foo
@end group
@group
'(quote foo)
- @result{} (quote foo)
+ @result{} 'foo
@end group
@group
['foo]
- @result{} [(quote foo)]
+ @result{} ['foo]
@end group
@end example
@@ -883,3 +884,115 @@ particular elements, like this:
@end group
@end example
@end defvar
+
+@node Deferred Eval
+@section Deferred and Lazy Evaluation
+
+@cindex deferred evaluation
+@cindex lazy evaluation
+
+
+ Sometimes it is useful to delay the evaluation of an expression, for
+example if you want to avoid performing a time-consuming calculation
+if it turns out that the result is not needed in the future of the
+program. The @file{thunk} library provides the following functions
+and macros to support such @dfn{deferred evaluation}:
+
+@cindex thunk
+@defmac thunk-delay forms@dots{}
+Return a @dfn{thunk} for evaluating the @var{forms}. A thunk is a
+closure (@pxref{Closures}) that inherits the lexical environment of the
+@code{thunk-delay} call. Using this macro requires
+@code{lexical-binding}.
+@end defmac
+
+@defun thunk-force thunk
+Force @var{thunk} to perform the evaluation of the forms specified in
+the @code{thunk-delay} that created the thunk. The result of the
+evaluation of the last form is returned. The @var{thunk} also
+``remembers'' that it has been forced: Any further calls of
+@code{thunk-force} with the same @var{thunk} will just return the same
+result without evaluating the forms again.
+@end defun
+
+@defmac thunk-let (bindings@dots{}) forms@dots{}
+This macro is analogous to @code{let} but creates ``lazy'' variable
+bindings. Any binding has the form @w{@code{(@var{symbol}
+@var{value-form})}}. Unlike @code{let}, the evaluation of any
+@var{value-form} is deferred until the binding of the according
+@var{symbol} is used for the first time when evaluating the
+@var{forms}. Any @var{value-form} is evaluated at most once. Using
+this macro requires @code{lexical-binding}.
+@end defmac
+
+Example:
+
+@example
+@group
+(defun f (number)
+ (thunk-let ((derived-number
+ (progn (message "Calculating 1 plus 2 times %d" number)
+ (1+ (* 2 number)))))
+ (if (> number 10)
+ derived-number
+ number)))
+@end group
+
+@group
+(f 5)
+@result{} 5
+@end group
+
+@group
+(f 12)
+@print{} Calculating 1 plus 2 times 12
+@result{} 25
+@end group
+
+@end example
+
+Because of the special nature of lazily bound variables, it is an error
+to set them (e.g.@: with @code{setq}).
+
+
+@defmac thunk-let* (bindings@dots{}) forms@dots{}
+This is like @code{thunk-let} but any expression in @var{bindings} is allowed
+to refer to preceding bindings in this @code{thunk-let*} form. Using
+this macro requires @code{lexical-binding}.
+@end defmac
+
+@example
+@group
+(thunk-let* ((x (prog2 (message "Calculating x...")
+ (+ 1 1)
+ (message "Finished calculating x")))
+ (y (prog2 (message "Calculating y...")
+ (+ x 1)
+ (message "Finished calculating y")))
+ (z (prog2 (message "Calculating z...")
+ (+ y 1)
+ (message "Finished calculating z")))
+ (a (prog2 (message "Calculating a...")
+ (+ z 1)
+ (message "Finished calculating a"))))
+ (* z x))
+
+@print{} Calculating z...
+@print{} Calculating y...
+@print{} Calculating x...
+@print{} Finished calculating x
+@print{} Finished calculating y
+@print{} Finished calculating z
+@result{} 8
+
+@end group
+@end example
+
+@code{thunk-let} and @code{thunk-let*} use thunks implicitly: their
+expansion creates helper symbols and binds them to thunks wrapping the
+binding expressions. All references to the original variables in the
+body @var{forms} are then replaced by an expression that calls
+@code{thunk-force} with the according helper variable as the argument.
+So, any code using @code{thunk-let} or @code{thunk-let*} could be
+rewritten to use thunks, but in many cases using these macros results
+in nicer code than using thunks explicitly.
diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi
index 380e0543ddd..af16b1cf4bc 100644
--- a/doc/lispref/files.texi
+++ b/doc/lispref/files.texi
@@ -550,7 +550,7 @@ the functions in the list @code{after-insert-file-functions}.
(@pxref{Coding Systems}) used for decoding the file's contents,
including end-of-line conversion. However, if the file contains null
bytes, it is by default visited without any code conversions.
-@xref{Lisp and Coding Systems, inhibit-null-byte-detection}.
+@xref{Lisp and Coding Systems, inhibit-nul-byte-detection}.
If @var{visit} is non-@code{nil}, this function additionally marks the
buffer as unmodified and sets up various fields in the buffer so that it
@@ -1299,36 +1299,34 @@ Alternate names, also known as hard links, can be created by using the
@item
The file's @acronym{UID}, normally as a string
(@code{file-attribute-user-id}). However, if it does not correspond
-to a named user, the value is a number.
+to a named user, the value is an integer.
@item
The file's @acronym{GID}, likewise (@code{file-attribute-group-id}).
@item
-The time of last access, as a list of four integers
-@code{(@var{sec-high} @var{sec-low} @var{microsec} @var{picosec})}
-(@code{file-attribute-access-time}). (This is similar to the value of
-@code{current-time}; see @ref{Time of Day}.) The value is truncated
+The time of last access as a Lisp timestamp
+(@code{file-attribute-access-time}). The timestamp is in the
+style of @code{current-time} (@pxref{Time of Day}) and is truncated
to that of the filesystem's timestamp resolution; for example, on some
FAT-based filesystems, only the date of last access is recorded, so
this time will always hold the midnight of the day of the last access.
@cindex modification time of file
@item
-The time of last modification as a list of four integers (as above)
+The time of last modification as a Lisp timestamp
(@code{file-attribute-modification-time}). This is the last time when
the file's contents were modified.
@item
-The time of last status change as a list of four integers (as above)
+The time of last status change as a Lisp timestamp
(@code{file-attribute-status-change-time}). This is the time of the
last change to the file's access mode bits, its owner and group, and
other information recorded in the filesystem for the file, beyond the
file's contents.
@item
-The size of the file in bytes (@code{file-attribute-size}). This is
-floating point if the size is too large to fit in a Lisp integer.
+The size of the file in bytes (@code{file-attribute-size}).
@item
The file's modes, as a string of ten letters or dashes, as in
@@ -1338,21 +1336,13 @@ The file's modes, as a string of ten letters or dashes, as in
An unspecified value, present for backward compatibility.
@item
-The file's inode number (@code{file-attribute-inode-number}). If
-possible, this is an integer. If the inode number is too large to be
-represented as an integer in Emacs Lisp but dividing it by
-@math{2^{16}} yields a representable integer, then the value has the
-form @code{(@var{high} . @var{low})}, where @var{low} holds the low 16
-bits. If the inode number is too wide for even that, the value is of
-the form @code{(@var{high} @var{middle} . @var{low})}, where
-@code{high} holds the high bits, @var{middle} the middle 24 bits, and
-@var{low} the low 16 bits.
+The file's inode number (@code{file-attribute-inode-number}),
+a nonnegative integer.
@item
The filesystem number of the device that the file is on
-@code{file-attribute-device-number}). Depending on the magnitude of
-the value, this can be either an integer or a cons cell, in the same
-manner as the inode number. This element and the file's inode number
+@code{file-attribute-device-number}), an integer.
+This element and the file's inode number
together give enough information to distinguish any two files on the
system---no two files can have the same values for both of these
numbers.
@@ -1368,8 +1358,8 @@ For example, here are the file attributes for @file{files.texi}:
(20000 23 0 0)
(20614 64555 902289 872000)
122295 "-rw-rw-rw-"
- t (5888 2 . 43978)
- (15479 . 46724))
+ t 6473924464520138
+ 1014478468)
@end group
@end example
@@ -1410,10 +1400,10 @@ has a mode of read and write access for the owner, group, and world.
@item t
is merely a placeholder; it carries no information.
-@item (5888 2 . 43978)
+@item 6473924464520138
has an inode number of 6473924464520138.
-@item (15479 . 46724)
+@item 1014478468
is on the file-system device whose number is 1014478468.
@end table
@end defun
@@ -1567,13 +1557,16 @@ For compatibility, @var{predicate} can also be one of the symbols
a list of one or more of these symbols.
@end defun
-@defun executable-find program
+@defun executable-find program &optional remote
This function searches for the executable file of the named
@var{program} and returns the absolute file name of the executable,
including its file-name extensions, if any. It returns @code{nil} if
-the file is not found. The functions searches in all the directories
+the file is not found. The function searches in all the directories
in @code{exec-path}, and tries all the file-name extensions in
@code{exec-suffixes} (@pxref{Subprocess Creation}).
+
+If @var{remote} is non-@code{nil}, and @code{default-directory} is a
+remote directory, @var{program} is searched on the respective remote host.
@end defun
@node Changing Files
@@ -2131,7 +2124,7 @@ Note that the @samp{.~3~} in the two last examples is the backup part,
not an extension.
@end defun
-@defun file-name-base &optional filename
+@defun file-name-base filename
This function is the composition of @code{file-name-sans-extension}
and @code{file-name-nondirectory}. For example,
@@ -2139,8 +2132,6 @@ and @code{file-name-nondirectory}. For example,
(file-name-base "/my/home/foo.c")
@result{} "foo"
@end example
-
-The @var{filename} argument defaults to @code{buffer-file-name}.
@end defun
@node Relative File Names
@@ -2376,8 +2367,10 @@ start with @samp{~}.) Otherwise, the current buffer's value of
@end example
If the part of @var{filename} before the first slash is
-@samp{~}, it expands to the value of the @env{HOME} environment
-variable (usually your home directory). If the part before the first
+@samp{~}, it expands to your home directory, which is typically
+specified by the value of the @env{HOME} environment variable
+(@pxref{General Variables,,, emacs, The GNU Emacs Manual}).
+If the part before the first
slash is @samp{~@var{user}} and if @var{user} is a valid login name,
it expands to @var{user}'s home directory.
If you do not want this expansion for a relative @var{filename} that
@@ -2938,7 +2931,7 @@ are included.
This is similar to @code{directory-files} in deciding which files
to report on and how to report their names. However, instead
of returning a list of file names, it returns for each file a
-list @code{(@var{filename} @var{attributes})}, where @var{attributes}
+list @code{(@var{filename} . @var{attributes})}, where @var{attributes}
is what @code{file-attributes} returns for that file.
The optional argument @var{id-format} has the same meaning as the
corresponding argument to @code{file-attributes} (@pxref{Definition
@@ -3015,10 +3008,16 @@ This command creates a directory named @var{dirname}. If
@var{parents} is non-@code{nil}, as is always the case in an
interactive call, that means to create the parent directories first,
if they don't already exist.
-
@code{mkdir} is an alias for this.
@end deffn
+@deffn Command make-empty-file filename &optional parents
+This command creates an empty file named @var{filename}.
+As @code{make-directory}, this command creates parent directories
+if @var{parents} is non-@code{nil}.
+If @var{filename} already exists, this command signals an error.
+@end deffn
+
@deffn Command copy-directory dirname newname &optional keep-time parents copy-contents
This command copies the directory named @var{dirname} to
@var{newname}. If @var{newname} is a directory name,
@@ -3079,7 +3078,7 @@ expression to define the class of names (all those that match the
regular expression), plus a handler that implements all the primitive
Emacs file operations for file names that match.
-@cindex file handler
+@cindex file name handler
@vindex file-name-handler-alist
The variable @code{file-name-handler-alist} holds a list of handlers,
together with regular expressions that determine when to apply each
@@ -3150,8 +3149,8 @@ first, before handlers for jobs such as remote file access.
@code{directory-file-name},
@code{directory-files},
@code{directory-files-and-attributes},
-@code{dired-compress-file}, @code{dired-uncache},@*
-@code{expand-file-name},
+@code{dired-compress-file}, @code{dired-uncache},
+@code{exec-path}, @code{expand-file-name},@*
@code{file-accessible-directory-p},
@code{file-acl},
@code{file-attributes},
@@ -3172,7 +3171,8 @@ first, before handlers for jobs such as remote file access.
@code{file-ownership-preserved-p},
@code{file-readable-p}, @code{file-regular-p},
@code{file-remote-p}, @code{file-selinux-context},
-@code{file-symlink-p}, @code{file-truename}, @code{file-writable-p},
+@code{file-symlink-p}, @code{file-system-info},
+@code{file-truename}, @code{file-writable-p},
@code{find-backup-file-name},@*
@code{get-file-buffer},
@code{insert-directory},
@@ -3182,6 +3182,7 @@ first, before handlers for jobs such as remote file access.
@code{make-directory},
@code{make-directory-internal},
@code{make-nearby-temp-file},
+@code{make-process},
@code{make-symbolic-link},@*
@code{process-file},
@code{rename-file}, @code{set-file-acl}, @code{set-file-modes},
@@ -3207,7 +3208,7 @@ first, before handlers for jobs such as remote file access.
@code{directory-files},
@code{directory-files-and-at@discretionary{}{}{}tributes},
@code{dired-compress-file}, @code{dired-uncache},
-@code{expand-file-name},
+@code{exec-path}, @code{expand-file-name},
@code{file-accessible-direc@discretionary{}{}{}tory-p},
@code{file-acl},
@code{file-attributes},
@@ -3228,7 +3229,8 @@ first, before handlers for jobs such as remote file access.
@code{file-ownership-pre@discretionary{}{}{}served-p},
@code{file-readable-p}, @code{file-regular-p},
@code{file-remote-p}, @code{file-selinux-context},
-@code{file-symlink-p}, @code{file-truename}, @code{file-writable-p},
+@code{file-symlink-p}, @code{file-system-info},
+@code{file-truename}, @code{file-writable-p},
@code{find-backup-file-name},
@code{get-file-buffer},
@code{insert-directory},
@@ -3237,6 +3239,7 @@ first, before handlers for jobs such as remote file access.
@code{make-auto-save-file-name},
@code{make-direc@discretionary{}{}{}tory},
@code{make-direc@discretionary{}{}{}tory-internal},
+@code{make-process},
@code{make-symbolic-link},
@code{process-file},
@code{rename-file}, @code{set-file-acl}, @code{set-file-modes},
@@ -3364,8 +3367,8 @@ If @code{file-remote-p} returns the same identifier for two different
filenames, that means they are stored on the same file system and can
be accessed locally with respect to each other. This means, for
example, that it is possible to start a remote process accessing both
-files at the same time. Implementers of file handlers need to ensure
-this principle is valid.
+files at the same time. Implementers of file name handlers need to
+ensure this principle is valid.
@var{identification} specifies which part of the identifier shall be
returned as string. @var{identification} can be the symbol
@@ -3435,8 +3438,9 @@ between consecutive checks. For example:
(let ((remote-file-name-inhibit-cache
(- display-time-interval 5)))
(and (file-exists-p file)
- (< 0 (nth 7 (file-attributes
- (file-chase-links file)))))))
+ (< 0 (file-attribute-size
+ (file-attributes
+ (file-chase-links file)))))))
@end example
@end defopt
diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi
index b993f4932cd..9b3e02f4de0 100644
--- a/doc/lispref/frames.texi
+++ b/doc/lispref/frames.texi
@@ -181,6 +181,12 @@ the value of that parameter in the created frame to its value in the
selected frame.
@end defvar
+@defopt server-after-make-frame-hook
+A normal hook run when the Emacs server creates a client frame. When
+this hook is called, the created frame is the selected one.
+@xref{Emacs Server,,, emacs, The GNU Emacs Manual}.
+@end defopt
+
@node Multiple Terminals
@section Multiple Terminals
@@ -434,6 +440,17 @@ This function returns the attributes of the physical monitor
dominating (see above) @var{frame}, which defaults to the selected frame.
@end defun
+On multi-monitor displays it is possible to use the command
+@code{make-frame-on-monitor} to make frames on the specified monitor.
+
+@deffn Command make-frame-on-monitor monitor &optional display parameters
+This function creates and returns a new frame on @var{monitor} located
+on @var{display}, taking the other frame parameters from the alist
+@var{parameters}. @var{monitor} should be the name of the physical
+monitor, the same string as returned by the function
+@code{display-monitor-attributes-list} in the attribute @code{name}.
+@var{display} should be the name of an X display (a string).
+@end deffn
@node Frame Geometry
@section Frame Geometry
@@ -1867,6 +1884,12 @@ minibuffer window to @code{t} and vice-versa, or from @code{t} to
@code{nil}. If the parameter specifies a minibuffer window already,
setting it to @code{nil} has no effect.
+The special value @code{child-frame} means to make a minibuffer-only
+child frame (@pxref{Child Frames}) whose parent becomes the frame
+created. As if specified as @code{nil}, Emacs will set this parameter
+to the minibuffer window of the child frame but will not select the
+child frame after its creation.
+
@vindex buffer-predicate@r{, a frame parameter}
@item buffer-predicate
The buffer-predicate function for this frame. The function
@@ -2524,6 +2547,7 @@ it.
@deffn Command delete-frame &optional frame force
@vindex delete-frame-functions
+@vindex after-delete-frame-functions
This function deletes the frame @var{frame}. The argument @var{frame}
must specify a live frame (see below) and defaults to the selected
frame.
@@ -2535,7 +2559,9 @@ performed recursively; so this step makes sure that no other frames with
@var{frame} as their ancestor will exist. Then, unless @var{frame}
specifies a tooltip, this function runs the hook
@code{delete-frame-functions} (each function getting one argument,
-@var{frame}) before actually killing the frame.
+@var{frame}) before actually killing the frame. After actually killing
+the frame and removing the frame from the frame list, @code{delete-frame}
+runs @code{after-delete-frame-functions}.
Note that a frame cannot be deleted as long as its minibuffer serves as
surrogate minibuffer for another frame (@pxref{Minibuffers and Frames}).
@@ -2696,14 +2722,22 @@ This function returns the selected frame.
Some window systems and window managers direct keyboard input to the
window object that the mouse is in; others require explicit clicks or
commands to @dfn{shift the focus} to various window objects. Either
-way, Emacs automatically keeps track of which frame has the focus. To
+way, Emacs automatically keeps track of which frames have focus. To
explicitly switch to a different frame from a Lisp function, call
@code{select-frame-set-input-focus}.
-Lisp programs can also switch frames temporarily by calling the
-function @code{select-frame}. This does not alter the window system's
-concept of focus; rather, it escapes from the window manager's control
-until that control is somehow reasserted.
+The plural ``frames'' in the previous paragraph is deliberate: while
+Emacs itself has only one selected frame, Emacs can have frames on
+many different terminals (recall that a connection to a window system
+counts as a terminal), and each terminal has its own idea of which
+frame has input focus. When you set the input focus to a frame, you
+set the focus for that frame's terminal, but frames on other terminals
+may still remain focused.
+
+Lisp programs can switch frames temporarily by calling the function
+@code{select-frame}. This does not alter the window system's concept
+of focus; rather, it escapes from the window manager's control until
+that control is somehow reasserted.
When using a text terminal, only one frame can be displayed at a time
on the terminal, so after a call to @code{select-frame}, the next
@@ -2714,11 +2748,11 @@ before the buffer name (@pxref{Mode Line Variables}).
@defun select-frame-set-input-focus frame &optional norecord
This function selects @var{frame}, raises it (should it happen to be
-obscured by other frames) and tries to give it the X server's focus.
-On a text terminal, the next redisplay displays the new frame on the
-entire terminal screen. The optional argument @var{norecord} has the
-same meaning as for @code{select-frame} (see below). The return value
-of this function is not significant.
+obscured by other frames) and tries to give it the window system's
+focus. On a text terminal, the next redisplay displays the new frame
+on the entire terminal screen. The optional argument @var{norecord}
+has the same meaning as for @code{select-frame} (see below).
+The return value of this function is not significant.
@end defun
Ideally, the function described next should focus a frame without also
@@ -2766,17 +2800,35 @@ could switch to a different terminal without switching back when
you're done.
@end deffn
-Emacs cooperates with the window system by arranging to select frames as
-the server and window manager request. It does so by generating a
-special kind of input event, called a @dfn{focus} event, when
-appropriate. The command loop handles a focus event by calling
-@code{handle-switch-frame}. @xref{Focus Events}.
+@cindex text-terminal focus notification
+Emacs cooperates with the window system by arranging to select frames
+as the server and window manager request. When a window system
+informs Emacs that one of its frames has been selected, Emacs
+internally generates a @dfn{focus-in} event. When an Emacs frame is
+displayed on a text-terminal emulator, such as @command{xterm}, which
+supports reporting of focus-change notification, the focus-in and
+focus-out events are available even for text-mode frames. Focus
+events are normally handled by @code{handle-focus-in}.
+
+@deffn Command handle-focus-in event
+This function handles focus-in events from window systems and
+terminals that support explicit focus notifications. It updates the
+per-frame focus flags that @code{frame-focus-state} queries and calls
+@code{after-focus-change-function}. In addition, it generates a
+@code{switch-frame} event in order to switch the Emacs notion of the
+selected frame to the frame most recently focused in some terminal.
+It's important to note that this switching of the Emacs selected frame
+to the most recently focused frame does not mean that other frames do
+not continue to have the focus in their respective terminals. Do not
+invoke this function yourself: instead, attach logic to
+@code{after-focus-change-function}.
+@end deffn
@deffn Command handle-switch-frame frame
-This function handles a focus event by selecting frame @var{frame}.
-
-Focus events normally do their job by invoking this command.
-Don't call it for any other reason.
+This function handles a switch-frame event, which Emacs generates for
+itself upon focus notification or under various other circumstances
+involving an input event arriving at a different frame from the last
+event. Do not invoke this function yourself.
@end deffn
@defun redirect-frame-focus frame &optional focus-frame
@@ -2810,14 +2862,42 @@ The redirection lasts until @code{redirect-frame-focus} is called to
change it.
@end defun
-@defvar focus-in-hook
-This is a normal hook run when an Emacs frame gains input focus. The
-frame gaining focus is selected when this hook is run.
-@end defvar
+@defun frame-focus-state frame
+This function retrieves the last known focus state of @var{frame}.
+
+It returns @code{nil} if the frame is known not to be focused,
+@code{t} if the frame is known to be focused, or @code{unknown} if
+Emacs does not know the focus state of the frame. (You may see this
+last state in TTY frames running on terminals that do not support
+explicit focus notifications.)
+@end defun
-@defvar focus-out-hook
-This is a normal hook run when an Emacs frame has lost input focus and
-no other Emacs frame has gained input focus instead.
+@defvar after-focus-change-function
+This function is an extension point that code can use to receive a
+notification that focus has changed.
+
+This function is called with no arguments when Emacs notices that the
+set of focused frames may have changed. Code wanting to do something
+when frame focus changes should use @code{add-function} to add a
+function to this one, and in this added function, re-scan the set of
+focused frames, calling @code{frame-focus-state} to retrieve the last
+known focus state of each frame. Focus events are delivered
+asynchronously, and frame input focus according to an external system
+may not correspond to the notion of the Emacs selected frame.
+Multiple frames may appear to have input focus simultaneously due to
+focus event delivery differences, the presence of multiple Emacs
+terminals, and other factors, and code should be robust in the face of
+this situation.
+
+Depending on window system, focus events may also be delivered
+repeatedly and with different focus states before settling to the
+expected values. Code relying on focus notifications should
+``debounce'' any user-visible updates arising from focus changes,
+perhaps by deferring work until redisplay.
+
+This function may be called in arbitrary contexts, including from
+inside @code{read-event}, so take the same care as you might when
+writing a process filter.
@end defvar
@defopt focus-follows-mouse
@@ -3140,9 +3220,17 @@ top-level frame which also always appears on top of its parent
window---the desktop's root window. When a parent frame is iconified or
made invisible (@pxref{Visibility of Frames}), its child frames are made
invisible. When a parent frame is deiconified or made visible, its
-child frames are made visible. When a parent frame is about to be
-deleted (@pxref{Deleting Frames}), its child frames are recursively
-deleted before it.
+child frames are made visible.
+
+ When a parent frame is about to be deleted (@pxref{Deleting
+Frames}), its child frames are recursively deleted before it. There
+is one exception to this rule: When the child frame serves as a
+surrogate minibuffer frame (@pxref{Minibuffers and Frames}) for
+another frame, it is retained until the parent frame has been deleted.
+If, at this time, no remaining frame uses the child frame as its
+minibuffer frame, Emacs will try to delete the child frame too. If
+that deletion fails for whatever reason, the child frame is made a
+top-level frame.
Whether a child frame can have a menu or tool bar is window-system or
window manager dependent. Most window-systems explicitly disallow menus
diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi
index d01804e4940..222f863c988 100644
--- a/doc/lispref/functions.texi
+++ b/doc/lispref/functions.texi
@@ -371,8 +371,8 @@ keyword @code{&rest} before one final argument.
@example
@group
(@var{required-vars}@dots{}
- @r{[}&optional @var{optional-vars}@dots{}@r{]}
- @r{[}&rest @var{rest-var}@r{]})
+ @r{[}&optional @r{[}@var{optional-vars}@dots{}@r{]}@r{]}
+ @r{[}&rest @r{[}@var{rest-var}@r{]}@r{]})
@end group
@end example
@@ -1242,7 +1242,7 @@ This form defines a method like @code{cl-defmethod} does.
@end table
@end defmac
-@defmac cl-defmethod name [qualifier] arguments &rest [docstring] body
+@defmac cl-defmethod name [qualifier] arguments [&context (expr spec)@dots{}] &rest [docstring] body
This macro defines a particular implementation for the generic
function called @var{name}. The implementation code is given by
@var{body}. If present, @var{docstring} is the documentation string
@@ -1269,15 +1269,20 @@ defined with @code{cl-defstruct} (@pxref{Structures,,, cl, Common Lisp
Extensions for GNU Emacs Lisp}), or of one of its child classes.
@end table
-Alternatively, the argument specializer can be of the form
-@code{&context (@var{expr} @var{spec})}, in which case the value of
-@var{expr} must be compatible with the specializer provided by
-@var{spec}; @var{spec} can be any of the forms described above. In
-other words, this form of specializer uses the value of @var{expr}
-instead of arguments for the decision whether the method is
-applicable. For example, @code{&context (overwrite-mode (eql t))}
-will make the method compatible only when @code{overwrite-mode} is
-turned on.
+Method definitions can make use of a new argument-list keyword,
+@code{&context}, which introduces extra specializers that test the
+environment at the time the method is run. This keyword should appear
+after the list of required arguments, but before any @code{&rest} or
+@code{&optional} keywords. The @code{&context} specializers look much
+like regular argument specializers---(@var{expr} @var{spec})---except
+that @var{expr} is an expression to be evaluated in the current
+context, and the @var{spec} is a value to compare against. For
+example, @code{&context (overwrite-mode (eql t))} will make the method
+applicable only when @code{overwrite-mode} is turned on. The
+@code{&context} keyword can be followed by any number of context
+specializers. Because the context specializers are not part of the
+generic function's argument signature, they may be omitted in methods
+that don't require them.
The type specializer, @code{(@var{arg} @var{type})}, can specify one
of the @dfn{system types} in the following list. When a parent type
diff --git a/doc/lispref/hash.texi b/doc/lispref/hash.texi
index d5c9948ca73..5aaf31247b4 100644
--- a/doc/lispref/hash.texi
+++ b/doc/lispref/hash.texi
@@ -300,8 +300,8 @@ the same integer.
@defun sxhash-eql obj
This function returns a hash code for Lisp object @var{obj} suitable
for @code{eql} comparison. I.e. it reflects identity of @var{obj}
-except for the case where the object is a float number, in which case
-hash code is generated for the value.
+except for the case where the object is a bignum or a float number,
+in which case a hash code is generated for the value.
If two objects @var{obj1} and @var{obj2} are @code{eql}, then
@code{(sxhash-eql @var{obj1})} and @code{(sxhash-eql @var{obj2})} are
diff --git a/doc/lispref/hooks.texi b/doc/lispref/hooks.texi
index 7c8748b5e48..71992464e09 100644
--- a/doc/lispref/hooks.texi
+++ b/doc/lispref/hooks.texi
@@ -66,6 +66,7 @@ not exactly a hook, but does a similar job.
@item after-make-frame-functions
@itemx before-make-frame-hook
+@itemx server-after-make-frame-hook
@xref{Creating Frames}.
@c Not general enough?
@@ -123,6 +124,7 @@ The command loop runs this soon after @code{post-command-hook} (q.v.).
@xref{Input Focus}.
@item delete-frame-functions
+@itemx after-delete-frame-functions
@xref{Deleting Frames}.
@item delete-terminal-functions
diff --git a/doc/lispref/internals.texi b/doc/lispref/internals.texi
index 38d84f149e0..8ebe47d9ad7 100644
--- a/doc/lispref/internals.texi
+++ b/doc/lispref/internals.texi
@@ -48,24 +48,63 @@ environment. After this step, the Emacs executable is no longer
@dfn{bare}.
@cindex dumping Emacs
+@cindex @option{--temacs} option, and dumping method
Because it takes some time to load the standard Lisp files, the
@file{temacs} executable usually isn't run directly by users.
-Instead, as one of the last steps of building Emacs, the command
-@samp{temacs -batch -l loadup dump} is run. The special @samp{dump}
-argument causes @command{temacs} to dump out an executable program,
-called @file{emacs}, which has all the standard Lisp files preloaded.
-(The @samp{-batch} argument prevents @file{temacs} from trying to
-initialize any of its data on the terminal, so that the tables of
-terminal information are empty in the dumped Emacs.)
+Instead, one of the last steps of building Emacs runs the command
+@w{@samp{temacs -batch -l loadup --temacs=@var{dump-method}}}. The
+special option @option{--temacs} tells @command{temacs} how to record
+all the standard preloaded Lisp functions and variables, so that when
+you subsequently run Emacs, it will start much faster. The
+@option{--temacs} option requires an argument @var{dump-method}, which
+can be one of the following:
+
+@table @samp
+@item pdump
+@cindex portable dump file
+Record the preloaded Lisp data in a @dfn{portable dump} file. This
+method produces an additional data file which Emacs will load at
+startup. The portable dump file is usually called @file{emacs.pdmp},
+and is installed in the Emacs @code{exec-directory} (@pxref{Help
+Functions}). This method is the most preferred one, as it does not
+require Emacs to employ any special techniques of memory allocation,
+which might get in the way of various memory-layout techniques used by
+modern systems to enhance security and privacy.
+
+@item pbootstrap
+@cindex bootstrapping Emacs
+Like @samp{pdump}, but used while @dfn{bootstrapping} Emacs, when no
+previous Emacs binary and no @file{*.elc} byte-compiled Lisp files are
+available. The produced portable dump file is usually named
+@file{bootstrap-emacs.pdmp} in this case.
+
+@item dump
+@cindex unexec
+This method causes @command{temacs} to dump out an executable program,
+called @file{emacs}, which has all the standard Lisp files already
+preloaded into it. (The @samp{-batch} argument prevents
+@command{temacs} from trying to initialize any of its data on the
+terminal, so that the tables of terminal information are empty in the
+dumped Emacs.) This method is also known as @dfn{unexec}, because it
+produces a program file from a running process, and thus is in some
+sense the opposite of executing a program to start a process.
+
+@item bootstrap
+Like @samp{dump}, but used when bootstrapping Emacs with the
+@code{unexec} method.
+@end table
@cindex preloaded Lisp files
@vindex preloaded-file-list
The dumped @file{emacs} executable (also called a @dfn{pure} Emacs)
-is the one which is installed. The variable
-@code{preloaded-file-list} stores a list of the Lisp files preloaded
-into the dumped Emacs. If you port Emacs to a new operating system,
-and are not able to implement dumping, then Emacs must load
-@file{loadup.el} each time it starts.
+is the one which is installed. If the portable dumping was used to
+build Emacs, the @file{emacs} executable is actually an exact copy of
+@file{temacs}, and the corresponding @file{emacs.pdmp} file is
+installed as well. The variable @code{preloaded-file-list} stores a
+list of the preloaded Lisp files recorded in the portable dump file or
+in the dumped Emacs executable. If you port Emacs to a new operating
+system, and are not able to implement dumping of any kind, then Emacs
+must load @file{loadup.el} each time it starts.
@cindex build details
@cindex deterministic build
@@ -161,14 +200,41 @@ In the unlikely event that you need a more general functionality than
@code{custom-initialize-delay} provides, you can use
@code{before-init-hook} (@pxref{Startup Summary}).
+@defun dump-emacs-portable to-file &optional track-referrers
+This function dumps the current state of Emacs into a portable dump
+file @var{to-file}, using the @code{pdump} method. Normally, the
+portable dump file is called @file{@var{emacs-name}.dmp}, where
+@var{emacs-name} is the name of the Emacs executable file. The
+optional argument @var{track-referrers}, if non-@code{nil}, causes the
+portable dumping process keep additional information to help track
+down the provenance of object types that are not yet supported by the
+@code{pdump} method.
+
+If you want to use this function in an Emacs that was already dumped,
+you must run Emacs with the @samp{-batch} option.
+@end defun
+
@defun dump-emacs to-file from-file
@cindex unexec
This function dumps the current state of Emacs into an executable file
-@var{to-file}. It takes symbols from @var{from-file} (this is normally
-the executable file @file{temacs}).
+@var{to-file}, using the @code{unexec} method. It takes symbols from
+@var{from-file} (this is normally the executable file @file{temacs}).
-If you want to use this function in an Emacs that was already dumped,
-you must run Emacs with @samp{-batch}.
+This function cannot be used in an Emacs that was already dumped. If
+Emacs was built without @code{unexec} support, this function will not
+be available.
+@end defun
+
+@defun pdumper-stats
+If the current Emacs session restored its state from a portable dump
+file, this function returns information about the dump file and the
+time it took to restore the Emacs state. The value is an alist
+@w{@code{((dumped-with-pdumper . t) (load-time . @var{time})
+(dump-file-name . @var{file}))}},
+where @var{file} is the name of the dump file, and @var{time} is the
+time in seconds it took to restore the state from the dump file.
+If the current session was not restored from a portable dump file, the
+value is nil.
@end defun
@node Pure Storage
@@ -247,8 +313,8 @@ of 8k bytes, and small vectors are packed into blocks of 4k bytes).
@cindex vector-like objects, storage
@cindex storage of vector-like Lisp objects
- Beyond the basic vector, a lot of objects like window, buffer, and
-frame are managed as if they were vectors. The corresponding C data
+ Beyond the basic vector, a lot of objects like markers, overlays and
+buffers are managed as if they were vectors. The corresponding C data
structures include the @code{union vectorlike_header} field whose
@code{size} member contains the subtype enumerated by @code{enum pvec_type}
and an information about how many @code{Lisp_Object} fields this structure
@@ -319,7 +385,6 @@ future allocations. So an overall result is:
@example
((@code{conses} @var{cons-size} @var{used-conses} @var{free-conses})
(@code{symbols} @var{symbol-size} @var{used-symbols} @var{free-symbols})
- (@code{miscs} @var{misc-size} @var{used-miscs} @var{free-miscs})
(@code{strings} @var{string-size} @var{used-strings} @var{free-strings})
(@code{string-bytes} @var{byte-size} @var{used-bytes})
(@code{vectors} @var{vector-size} @var{used-vectors})
@@ -335,7 +400,7 @@ Here is an example:
@example
(garbage-collect)
@result{} ((conses 16 49126 8058) (symbols 48 14607 0)
- (miscs 40 34 56) (strings 32 2942 2607)
+ (strings 32 2942 2607)
(string-bytes 1 78607) (vectors 16 7247)
(vector-slots 8 341609 29474) (floats 8 71 102)
(intervals 56 27 26) (buffers 944 8)
@@ -367,19 +432,6 @@ The number of symbols in use.
The number of symbols for which space has been obtained from
the operating system, but that are not currently being used.
-@item misc-size
-Internal size of a miscellaneous entity, i.e.,
-@code{sizeof (union Lisp_Misc)}, which is a size of the
-largest type enumerated in @code{enum Lisp_Misc_Type}.
-
-@item used-miscs
-The number of miscellaneous objects in use. These include markers
-and overlays, plus certain objects not visible to users.
-
-@item free-miscs
-The number of miscellaneous objects for which space has been obtained
-from the operating system, but that are not currently being used.
-
@item string-size
Internal size of a string header, i.e., @code{sizeof (struct Lisp_String)}.
@@ -397,7 +449,7 @@ This is used for convenience and equals to @code{sizeof (char)}.
The total size of all string data in bytes.
@item vector-size
-Internal size of a vector header, i.e., @code{sizeof (struct Lisp_Vector)}.
+Size in bytes of a vector of length 1, including its header.
@item used-vectors
The number of vector headers allocated from the vector blocks.
@@ -407,6 +459,8 @@ Internal size of a vector slot, always equal to @code{sizeof (Lisp_Object)}.
@item used-slots
The number of slots in all used vectors.
+Slot counts might include some or all overhead from vector headers,
+depending on the platform.
@item free-slots
The number of free slots in all vector blocks.
@@ -508,10 +562,8 @@ function @code{memory-limit} provides information on the total amount of
memory Emacs is currently using.
@defun memory-limit
-This function returns the address of the last byte Emacs has allocated,
-divided by 1024. We divide the value by 1024 to make sure it fits in a
-Lisp integer.
-
+This function returns an estimate of the total amount of bytes of
+virtual memory that Emacs is currently using, divided by 1024.
You can use this to get a general idea of how your actions affect the
memory usage.
@end defun
@@ -596,6 +648,8 @@ in this Emacs session.
@defvar vector-cells-consed
The total number of vector cells that have been allocated so far
in this Emacs session.
+This includes vector-like objects such as markers and overlays, plus
+certain objects not visible to users.
@end defvar
@defvar symbols-consed
@@ -608,12 +662,6 @@ The total number of string characters that have been allocated so far
in this session.
@end defvar
-@defvar misc-objects-consed
-The total number of miscellaneous objects that have been allocated so
-far in this session. These include markers and overlays, plus
-certain objects not visible to users.
-@end defvar
-
@defvar intervals-consed
The total number of intervals that have been allocated so far
in this Emacs session.
@@ -760,6 +808,13 @@ names in the documentation string from the ones used in the C code.
@samp{usage:} is required if the function has an unlimited number of
arguments.
+Some primitives have multiple definitions, one per platform (e.g.,
+@code{x-create-frame}). In such cases, rather than writing the
+same documentation string in each definition, only one definition has
+the actual documentation. The others have placeholders beginning with
+@samp{SKIP}, which are ignored by the function that parses the
+@file{DOC} file.
+
All the usual rules for documentation strings in Lisp code
(@pxref{Documentation Tips}) apply to C code documentation strings
too.
@@ -1568,7 +1623,27 @@ purpose.
@deftypefn Function bool should_quit (emacs_env *@var{env})
This function returns @code{true} if the user wants to quit. In that
case, we recommend that your module function aborts any on-going
-processing and returns as soon as possible.
+processing and returns as soon as possible. In most cases, use
+@code{process_input} instead.
+@end deftypefn
+
+To process input events in addition to checking whether the user wants
+to quit, use the following function, which is available since Emacs
+27.1.
+
+@anchor{process_input}
+@deftypefn Function enum emacs_process_input_result process_input (emacs_env *@var{env})
+This function processes pending input events. It returns
+@code{emacs_process_input_quit} if the user wants to quit or an error
+occurred while processing signals. In that case, we recommend that
+your module function aborts any on-going processing and returns as
+soon as possible. If the module code may continue running,
+@code{process_input} returns @code{emacs_process_input_continue}. The
+return value is @code{emacs_process_input_continue} if and only if
+there is no pending nonlocal exit in @code{env}. If the module
+continues after calling @code{process_input}, global state such as
+variable values and buffer content may have been modified in arbitrary
+ways.
@end deftypefn
@node Module Nonlocal
@@ -1633,7 +1708,7 @@ The last @acronym{API} function exited via @code{throw}.
@end vtable
@end deftypefn
-@deftypefn Function emacs_funcall_exit non_local_exit_get (emacs_env *@var{env}, emacs_value *@var{symbol}, emacs_value *@var{data})
+@deftypefn Function enum emacs_funcall_exit non_local_exit_get (emacs_env *@var{env}, emacs_value *@var{symbol}, emacs_value *@var{data})
This function returns the kind of nonlocal exit condition stored in
@var{env}, like @code{non_local_exit_check} does, but it also returns
the full information about the nonlocal exit, if any. If the return
@@ -1699,7 +1774,7 @@ a special type to represent the pointers to all of them, which is known as
In C, the tagged pointer is an object of type @code{Lisp_Object}. Any
initialized variable of such a type always holds the value of one of the
following basic data types: integer, symbol, string, cons cell, float,
-vectorlike or miscellaneous object. Each of these data types has the
+or vectorlike object. Each of these data types has the
corresponding tag value. All tags are enumerated by @code{enum Lisp_Type}
and placed into a 3-bit bitfield of the @code{Lisp_Object}. The rest of the
bits is the value itself. Integers are immediate, i.e., directly
@@ -1731,18 +1806,13 @@ Symbol, the unique-named entity commonly used as an identifier.
@item struct Lisp_Float
Floating-point value.
-
-@item union Lisp_Misc
-Miscellaneous kinds of objects which don't fit into any of the above.
@end table
These types are the first-class citizens of an internal type system.
-Since the tag space is limited, all other types are the subtypes of either
-@code{Lisp_Vectorlike} or @code{Lisp_Misc}. Vector subtypes are enumerated
+Since the tag space is limited, all other types are the subtypes of
+@code{Lisp_Vectorlike}. Vector subtypes are enumerated
by @code{enum pvec_type}, and nearly all complex objects like windows, buffers,
-frames, and processes fall into this category. The rest of special types,
-including markers and overlays, are enumerated by @code{enum Lisp_Misc_Type}
-and form the set of subtypes of @code{Lisp_Misc}.
+frames, and processes fall into this category.
Below there is a description of a few subtypes of @code{Lisp_Vectorlike}.
Buffer object represents the text to display and edit. Window is the part
diff --git a/doc/lispref/intro.texi b/doc/lispref/intro.texi
index 2b5f7905258..2596e87939b 100644
--- a/doc/lispref/intro.texi
+++ b/doc/lispref/intro.texi
@@ -493,7 +493,7 @@ giving a prefix argument makes @var{here} non-@code{nil}.
@defvar emacs-build-time
The value of this variable indicates the time at which Emacs was
-built. It is a list of four integers, like the value of
+built. It uses the style of
@code{current-time} (@pxref{Time of Day}), or is @code{nil}
if the information is not available.
@@ -530,6 +530,18 @@ directory (without cleaning). This is only of relevance when
developing Emacs.
@end defvar
+@defvar emacs-repository-version
+A string that gives the repository revision from which Emacs was
+built. If Emacs was built outside revision control, the value is
+@code{nil}.
+@end defvar
+
+@defvar emacs-repository-branch
+A string that gives the repository branch from which Emacs was built.
+In the most cases this is @code{"master"}. If Emacs was built outside
+revision control, the value is @code{nil}.
+@end defvar
+
@node Acknowledgments
@section Acknowledgments
diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi
index d839be0e932..6ad665a9502 100644
--- a/doc/lispref/keymaps.texi
+++ b/doc/lispref/keymaps.texi
@@ -1660,7 +1660,7 @@ to turn the character that follows into a Hyper character:
(defun hyperify (prompt)
(let ((e (read-event)))
(vector (if (numberp e)
- (logior (lsh 1 24) e)
+ (logior (ash 1 24) e)
(if (memq 'hyper (event-modifiers e))
e
(add-event-modifier "H-" e))))))
@@ -2443,7 +2443,7 @@ Next we define the menu items:
@smallexample
(define-key menu-bar-replace-menu [tags-repl-continue]
- '(menu-item "Continue Replace" tags-loop-continue
+ '(menu-item "Continue Replace" multifile-continue
:help "Continue last tags replace operation"))
(define-key menu-bar-replace-menu [tags-repl]
'(menu-item "Replace in tagged files" tags-query-replace
diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index 615f21581aa..746b4643c18 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -156,6 +156,22 @@ considered a list and @code{not} when it is considered a truth value
@end example
@end defun
+@defun proper-list-p object
+This function returns the length of @var{object} if it is a proper
+list, @code{nil} otherwise (@pxref{Cons Cells}). In addition to
+satisfying @code{listp}, a proper list is neither circular nor dotted.
+
+@example
+@group
+(proper-list-p '(a b c))
+ @result{} 3
+@end group
+@group
+(proper-list-p '(a b . c))
+ @result{} nil
+@end group
+@end example
+@end defun
@node List Elements
@section Accessing Elements of Lists
@@ -651,8 +667,20 @@ non-@code{nil}, it copies vectors too (and operates recursively on
their elements).
@end defun
+@defun flatten-tree tree
+This function returns a ``flattened'' copy of @var{tree}, that is,
+a list containing all the non-@code{nil} terminal nodes, or leaves, of
+the tree of cons cells rooted at @var{tree}. Leaves in the returned
+list are in the same order as in @var{tree}.
+@end defun
+
+@example
+(flatten-tree '(1 (2 . 3) nil (4 5 (6)) 7))
+ @result{}(1 2 3 4 5 6 7)
+@end example
+
@defun number-sequence from &optional to separation
-This returns a list of numbers starting with @var{from} and
+This function returns a list of numbers starting with @var{from} and
incrementing by @var{separation}, and ending at or just before
@var{to}. @var{separation} can be positive or negative and defaults
to 1. If @var{to} is @code{nil} or numerically equal to @var{from},
@@ -1144,7 +1172,7 @@ each time you run it! Here is what happens:
@group
(symbol-function 'add-foo)
- @result{} (lambda (x) (nconc (quote (foo)) x))
+ @result{} (lambda (x) (nconc '(foo) x))
@end group
@group
@@ -1162,7 +1190,7 @@ each time you run it! Here is what happens:
@group
(symbol-function 'add-foo)
- @result{} (lambda (x) (nconc (quote (foo 1 2 3 4) x)))
+ @result{} (lambda (x) (nconc '(foo 1 2 3 4) x))
@end group
@end smallexample
@end defun
@@ -1736,11 +1764,12 @@ alist
@end example
@end defun
-@defun assoc-delete-all key alist
-This function deletes from @var{alist} all the elements whose @sc{car}
-is @code{equal} to @var{key}. It works like @code{assq-delete-all},
-except for the predicate used for comparing alist elements with
-@var{key}.
+@defun assoc-delete-all key alist &optional test
+This function is like @code{assq-delete-all} except that it accepts
+an optional argument @var{test}, a predicate function to compare the
+keys in @var{alist}. If omitted or @code{nil}, @var{test} defaults to
+@code{equal}. As @code{assq-delete-all}, this function often modifies
+the original list structure of @var{alist}.
@end defun
@defun rassq-delete-all value alist
diff --git a/doc/lispref/loading.texi b/doc/lispref/loading.texi
index f0cc689d1f6..6f1213f097b 100644
--- a/doc/lispref/loading.texi
+++ b/doc/lispref/loading.texi
@@ -641,7 +641,7 @@ autoloading with a magic comment:
Here's what that produces in @file{loaddefs.el}:
@example
-(autoload (quote doctor) "doctor" "\
+(autoload 'doctor "doctor" "\
Switch to *doctor* buffer and start giving psychotherapy.
\(fn)" t nil)
diff --git a/doc/lispref/minibuf.texi b/doc/lispref/minibuf.texi
index 3a2a9d82e97..cfea336a9e5 100644
--- a/doc/lispref/minibuf.texi
+++ b/doc/lispref/minibuf.texi
@@ -634,6 +634,12 @@ A history list for arguments that are Lisp expressions to evaluate.
A history list for arguments that are faces.
@end defvar
+@findex read-variable@r{, history list}
+@defvar custom-variable-history
+A history list for variable-name arguments read by
+@code{read-variable}.
+@end defvar
+
@c Less common: coding-system-history, input-method-history,
@c command-history, grep-history, grep-find-history,
@c read-envvar-name-history, setenv-history, yes-or-no-p-history.
@@ -2252,7 +2258,7 @@ function @code{read-passwd}.
@defun read-passwd prompt &optional confirm default
This function reads a password, prompting with @var{prompt}. It does
not echo the password as the user types it; instead, it echoes
-@samp{.} for each character in the password. If you want to apply
+@samp{*} for each character in the password. If you want to apply
another character to hide the password, let-bind the variable
@code{read-hide-char} with that character.
@@ -2397,6 +2403,25 @@ will not work. If you want to prevent resizing of minibuffer windows
when displaying long messages, bind the @code{message-truncate-lines}
variable instead (@pxref{Echo Area Customization}).
+The option @code{resize-mini-windows} does not affect the behavior of
+minibuffer-only frames (@pxref{Frame Layout}). The following option
+allows to automatically resize such frames as well.
+
+@defopt resize-mini-frames
+If this is @code{nil}, minibuffer-only frames are never resized
+automatically.
+
+If this is a function, that function is called with the
+minibuffer-only frame to be resized as sole argument. At the time
+this function is called, the buffer of the minibuffer window of that
+frame is the buffer whose contents will be shown the next time that
+window is redisplayed. The function is expected to fit the frame to
+the buffer in some appropriate way.
+
+Any other non-@code{nil} value means to resize minibuffer-only frames
+by calling @code{fit-frame-to-buffer} (@pxref{Resizing Windows}).
+@end defopt
+
@node Minibuffer Contents
@section Minibuffer Contents
@@ -2515,7 +2540,7 @@ locally inside the minibuffer (@pxref{Help Functions}).
@anchor{Definition of minibuffer-scroll-window}
If the value of this variable is non-@code{nil}, it should be a window
object. When the function @code{scroll-other-window} is called in the
-minibuffer, it scrolls this window.
+minibuffer, it scrolls this window (@pxref{Textual Scrolling}).
@end defvar
@defun minibuffer-selected-window
diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi
index 919816f3dee..4315b70ed72 100644
--- a/doc/lispref/modes.texi
+++ b/doc/lispref/modes.texi
@@ -197,6 +197,7 @@ from the buffer-local hook list instead of from the global hook list.
@cindex major mode
@cindex major mode command
+@cindex suspend major mode temporarily
Major modes specialize Emacs for editing or interacting with
particular kinds of text. Each buffer has exactly one major mode at a
time. Every major mode is associated with a @dfn{major mode command},
@@ -205,7 +206,8 @@ switching to that mode in the current buffer, by setting various
buffer-local variables such as a local keymap. @xref{Major Mode
Conventions}. Note that unlike minor modes there is no way to ``turn
off'' a major mode, instead the buffer must be switched to a different
-one.
+one. However, you can temporarily @dfn{suspend} a major mode and later
+@dfn{restore} the suspended mode, see below.
The least specialized major mode is called @dfn{Fundamental mode},
which has no mode-specific definitions or variable settings.
@@ -216,6 +218,24 @@ commands, it does @emph{not} run any mode hooks (@pxref{Major Mode
Conventions}), since you are not supposed to customize this mode.
@end deffn
+@defun major-mode-suspend
+This function works like @code{fundamental-mode}, in that it kills all
+buffer-local variables, but it also records the major mode in effect,
+so that it could subsequently be restored. This function and
+@code{major-mode-restore} (described next) are useful when you need to
+put a buffer under some specialized mode other than the one Emacs
+chooses for it automatically (@pxref{Auto Major Mode}), but would also
+like to be able to switch back to the original mode later.
+@end defun
+
+@defun major-mode-restore &optional avoided-modes
+This function restores the major mode recorded by
+@code{major-mode-suspend}. If no major mode was recorded, this
+function calls @code{normal-mode} (@pxref{Auto Major Mode,
+normal-mode}), but tries to force it not to choose any modes in
+@var{avoided-modes}, if that argument is non-@code{nil}.
+@end defun
+
The easiest way to write a major mode is to use the macro
@code{define-derived-mode}, which sets up the new mode as a variant of
an existing major mode. @xref{Derived Modes}. We recommend using
@@ -995,6 +1015,29 @@ list-processes}). The listing command should create or switch to a
buffer, turn on the derived mode, specify the tabulated data, and
finally call @code{tabulated-list-print} to populate the buffer.
+@defopt tabulated-list-gui-sort-indicator-asc
+This variable specifies the character to be used on GUI frames as an
+indication that the column is sorted in the ascending order.
+
+Whenever you change the sort direction in Tabulated List buffers, this
+indicator toggles between ascending (``asc'') and descending (``desc'').
+@end defopt
+
+@defopt tabulated-list-gui-sort-indicator-desc
+Like @code{tabulated-list-gui-sort-indicator-asc}, but used when the
+column is sorted in the descending order.
+@end defopt
+
+@defopt tabulated-list-tty-sort-indicator-asc
+Like @code{tabulated-list-gui-sort-indicator-asc}, but used for
+text-mode frames.
+@end defopt
+
+@defopt tabulated-list-tty-sort-indicator-desc
+Like @code{tabulated-list-tty-sort-indicator-asc}, but used when the
+column is sorted in the descending order.
+@end defopt
+
@defvar tabulated-list-format
This buffer-local variable specifies the format of the Tabulated List
data. Its value should be a vector. Each element of the vector
@@ -1248,17 +1291,11 @@ You can thus get the full benefit of adaptive filling
Turning on Text mode runs the normal hook `text-mode-hook'."
@end group
@group
- (set (make-local-variable 'text-mode-variant) t)
- (set (make-local-variable 'require-final-newline)
- mode-require-final-newline)
- (set (make-local-variable 'indent-line-function) 'indent-relative))
+ (setq-local text-mode-variant t)
+ (setq-local require-final-newline mode-require-final-newline))
@end group
@end smallexample
-@noindent
-(The last line is redundant nowadays, since @code{indent-relative} is
-the default value, and we'll delete it in a future version.)
-
@cindex @file{lisp-mode.el}
The three Lisp modes (Lisp mode, Emacs Lisp mode, and Lisp Interaction
mode) have more features than Text mode and the code is correspondingly
diff --git a/doc/lispref/nonascii.texi b/doc/lispref/nonascii.texi
index d58041b279b..9c64c3cf2ca 100644
--- a/doc/lispref/nonascii.texi
+++ b/doc/lispref/nonascii.texi
@@ -828,18 +828,18 @@ two functions support these conversions.
This function decodes a character that is assigned a @var{code-point}
in @var{charset}, to the corresponding Emacs character, and returns
it. If @var{charset} doesn't contain a character of that code point,
-the value is @code{nil}. If @var{code-point} doesn't fit in a Lisp
-integer (@pxref{Integer Basics, most-positive-fixnum}), it can be
+the value is @code{nil}.
+
+For backward compatibility, if @var{code-point} doesn't fit in a Lisp
+fixnum (@pxref{Integer Basics, most-positive-fixnum}), it can be
specified as a cons cell @code{(@var{high} . @var{low})}, where
@var{low} are the lower 16 bits of the value and @var{high} are the
-high 16 bits.
+high 16 bits. This usage is obsolescent.
@end defun
@defun encode-char char charset
This function returns the code point assigned to the character
-@var{char} in @var{charset}. If the result does not fit in a Lisp
-integer, it is returned as a cons cell @code{(@var{high} . @var{low})}
-that fits the second argument of @code{decode-char} above. If
+@var{char} in @var{charset}. If
@var{charset} doesn't have a codepoint for @var{char}, the value is
@code{nil}.
@end defun
@@ -1378,7 +1378,7 @@ operates on the contents of @var{string} instead of bytes in the buffer.
@end defun
@cindex null bytes, and decoding text
-@defvar inhibit-null-byte-detection
+@defvar inhibit-nul-byte-detection
If this variable has a non-@code{nil} value, null bytes are ignored
when detecting the encoding of a region or a string. This allows the
encoding of text that contains null bytes to be correctly detected,
@@ -2120,9 +2120,9 @@ Return a 12-element vector of month names (locale items @code{MON_1}
through @code{MON_12}).
@item paper
-Return a list @code{(@var{width} @var{height})} for the default paper
-size measured in millimeters (locale items @code{PAPER_WIDTH} and
-@code{PAPER_HEIGHT}).
+Return a list @w{@code{(@var{width} @var{height})}} of 2 integers, for
+the default paper size measured in millimeters (locale items
+@code{_NL_PAPER_WIDTH} and @code{_NL_PAPER_HEIGHT}).
@end table
If the system can't provide the requested information, or if
diff --git a/doc/lispref/numbers.texi b/doc/lispref/numbers.texi
index e7beed0073d..fbdd83fa86e 100644
--- a/doc/lispref/numbers.texi
+++ b/doc/lispref/numbers.texi
@@ -14,9 +14,9 @@
fractional parts, such as @minus{}4.5, 0.0, and 2.71828. They can
also be expressed in exponential notation: @samp{1.5e2} is the same as
@samp{150.0}; here, @samp{e2} stands for ten to the second power, and
-that is multiplied by 1.5. Integer computations are exact, though
-they may overflow. Floating-point computations often involve rounding
-errors, as the numbers have a fixed amount of precision.
+that is multiplied by 1.5. Integer computations are exact.
+Floating-point computations often involve rounding errors, as the
+numbers have a fixed amount of precision.
@menu
* Integer Basics:: Representation and range of integers.
@@ -34,7 +34,23 @@ errors, as the numbers have a fixed amount of precision.
@node Integer Basics
@section Integer Basics
- The range of values for an integer depends on the machine. The
+ Integers in Emacs Lisp are not limited to the machine word size.
+
+ Under the hood, though, there are two kinds of integers: smaller
+ones, called @dfn{fixnums}, and larger ones, called @dfn{bignums}.
+Some functions in Emacs accept only fixnums. Also, while fixnums can
+always be compared for numeric equality with @code{eq}, bignums
+require more-heavyweight equality predicates like @code{eql}.
+
+ The range of values for bignums is limited by the amount of main
+memory, by machine characteristics such as the size of the word used
+to represent a bignum's exponent, and by the @code{integer-width}
+variable. These limits are typically much more generous than the
+limits for fixnums. A bignum is never numerically equal to a fixnum;
+if Emacs computes an integer in fixnum range, it represents the
+integer as a fixnum, not a bignum.
+
+ The range of values for a fixnum depends on the machine. The
minimum range is @minus{}536,870,912 to 536,870,911 (30 bits; i.e.,
@ifnottex
@minus{}2**29
@@ -49,21 +65,17 @@ to
@tex
@math{2^{29}-1}),
@end tex
-but many machines provide a wider range. Many examples in this
-chapter assume the minimum integer width of 30 bits.
-@cindex overflow
+but many machines provide a wider range.
- The Lisp reader reads an integer as a sequence of digits with optional
-initial sign and optional final period. An integer that is out of the
-Emacs range is treated as a floating-point number.
+ The Lisp reader reads an integer as a nonempty sequence
+of decimal digits with optional initial sign and optional
+final period.
@example
1 ; @r{The integer 1.}
1. ; @r{The integer 1.}
+1 ; @r{Also the integer 1.}
-1 ; @r{The integer @minus{}1.}
- 9000000000000000000
- ; @r{The floating-point number 9e18.}
0 ; @r{The integer 0.}
-0 ; @r{The integer 0.}
@end example
@@ -74,14 +86,17 @@ Emacs range is treated as a floating-point number.
@cindex hex numbers
@cindex octal numbers
@cindex reading numbers in hex, octal, and binary
- The syntax for integers in bases other than 10 uses @samp{#}
-followed by a letter that specifies the radix: @samp{b} for binary,
-@samp{o} for octal, @samp{x} for hex, or @samp{@var{radix}r} to
-specify radix @var{radix}. Case is not significant for the letter
-that specifies the radix. Thus, @samp{#b@var{integer}} reads
+ The syntax for integers in bases other than 10 consists of @samp{#}
+followed by a radix indication followed by one or more digits. The
+radix indications are @samp{b} for binary, @samp{o} for octal,
+@samp{x} for hex, and @samp{@var{radix}r} for radix @var{radix}.
+Thus, @samp{#b@var{integer}} reads
@var{integer} in binary, and @samp{#@var{radix}r@var{integer}} reads
@var{integer} in radix @var{radix}. Allowed values of @var{radix} run
-from 2 to 36. For example:
+from 2 to 36, and allowed digits are the first @var{radix} characters
+taken from @samp{0}--@samp{9}, @samp{A}--@samp{Z}.
+Letter case is ignored and there is no initial sign or final period.
+For example:
@example
#b101100 @result{} 44
@@ -94,26 +109,26 @@ from 2 to 36. For example:
bitwise operators (@pxref{Bitwise Operations}), it is often helpful to
view the numbers in their binary form.
- In 30-bit binary, the decimal integer 5 looks like this:
+ In binary, the decimal integer 5 looks like this:
@example
-0000...000101 (30 bits total)
+@dots{}000101
@end example
@noindent
-(The @samp{...} stands for enough bits to fill out a 30-bit word; in
-this case, @samp{...} stands for twenty 0 bits. Later examples also
-use the @samp{...} notation to make binary integers easier to read.)
+(The ellipsis @samp{@dots{}} stands for a conceptually infinite number
+of bits that match the leading bit; here, an infinite number of 0
+bits. Later examples also use this @samp{@dots{}} notation.)
The integer @minus{}1 looks like this:
@example
-1111...111111 (30 bits total)
+@dots{}111111
@end example
@noindent
@cindex two's complement
-@minus{}1 is represented as 30 ones. (This is called @dfn{two's
+@minus{}1 is represented as all ones. (This is called @dfn{two's
complement} notation.)
Subtracting 4 from @minus{}1 returns the negative integer @minus{}5.
@@ -121,24 +136,7 @@ In binary, the decimal integer 4 is 100. Consequently,
@minus{}5 looks like this:
@example
-1111...111011 (30 bits total)
-@end example
-
- In this implementation, the largest 30-bit binary integer is
-536,870,911 in decimal. In binary, it looks like this:
-
-@example
-0111...111111 (30 bits total)
-@end example
-
- Since the arithmetic functions do not check whether integers go
-outside their range, when you add 1 to 536,870,911, the value is the
-negative integer @minus{}536,870,912:
-
-@example
-(+ 1 536870911)
- @result{} -536870912
- @result{} 1000...000000 (30 bits total)
+@dots{}111011
@end example
Many of the functions described in this chapter accept markers for
@@ -147,11 +145,11 @@ arguments to such functions may be either numbers or markers, we often
give these arguments the name @var{number-or-marker}. When the argument
value is a marker, its position value is used and its buffer is ignored.
-@cindex largest Lisp integer
-@cindex maximum Lisp integer
+@cindex largest fixnum
+@cindex maximum fixnum
@defvar most-positive-fixnum
-The value of this variable is the largest integer that Emacs Lisp can
-handle. Typical values are
+The value of this variable is the greatest ``small'' integer that Emacs
+Lisp can handle. Typical values are
@ifnottex
2**29 @minus{} 1
@end ifnottex
@@ -168,11 +166,11 @@ on 32-bit and
on 64-bit platforms.
@end defvar
-@cindex smallest Lisp integer
-@cindex minimum Lisp integer
+@cindex smallest fixnum
+@cindex minimum fixnum
@defvar most-negative-fixnum
-The value of this variable is the smallest integer that Emacs Lisp can
-handle. It is negative. Typical values are
+The value of this variable is the numerically least ``small'' integer
+that Emacs Lisp can handle. It is negative. Typical values are
@ifnottex
@minus{}2**29
@end ifnottex
@@ -189,6 +187,26 @@ on 32-bit and
on 64-bit platforms.
@end defvar
+@cindex bignum range
+@cindex integer range
+@cindex number of bignum bits, limit on
+@defvar integer-width
+The value of this variable is a nonnegative integer that is an upper
+bound on the number of bits in a bignum. Integers outside the fixnum
+range are limited to absolute values less than
+@ifnottex
+2**@var{n},
+@end ifnottex
+@tex
+@math{2^{n}},
+@end tex
+where @var{n} is this variable's value. Attempts to create bignums outside
+this range signal a range error. Setting this variable
+to zero disables creation of bignums; setting it to a large number can
+cause Emacs to consume large quantities of memory if a computation
+creates huge integers.
+@end defvar
+
In Emacs Lisp, text characters are represented by integers. Any
integer between zero and the value of @code{(max-char)}, inclusive, is
considered to be valid as a character. @xref{Character Codes}.
@@ -213,7 +231,7 @@ least one digit after any decimal point in a floating-point number;
@samp{1500.} is an integer, not a floating-point number.
Emacs Lisp treats @code{-0.0} as numerically equal to ordinary zero
-with respect to @code{equal} and @code{=}. This follows the
+with respect to numeric comparisons like @code{=}. This follows the
@acronym{IEEE} floating-point standard, which says @code{-0.0} and
@code{0.0} are numerically equal even though other operations can
distinguish them.
@@ -227,8 +245,20 @@ infinity and negative infinity as floating-point values. It also
provides for a class of values called NaN, or ``not a number'';
numerical functions return such values in cases where there is no
correct answer. For example, @code{(/ 0.0 0.0)} returns a NaN@.
-Although NaN values carry a sign, for practical purposes there is no other
-significant difference between different NaN values in Emacs Lisp.
+A NaN is never numerically equal to any value, not even to itself.
+NaNs carry a sign and a significand, and non-numeric functions treat
+two NaNs as equal when their
+signs and significands agree. Significands of NaNs are
+machine-dependent, as are the digits in their string representation.
+
+ When NaNs and signed zeros are involved, non-numeric functions like
+@code{eql}, @code{equal}, @code{sxhash-eql}, @code{sxhash-equal} and
+@code{gethash} determine whether values are indistinguishable, not
+whether they are numerically equal. For example, when @var{x} and
+@var{y} are the same NaN, @code{(equal x y)} returns @code{t} whereas
+@code{(= x y)} uses numeric comparison and returns @code{nil};
+conversely, @code{(equal 0.0 -0.0)} returns @code{nil} whereas
+@code{(= 0.0 -0.0)} returns @code{t}.
Here are read syntaxes for these special floating-point values:
@@ -283,14 +313,18 @@ and returns the result. @var{x1} and @var{x2} must be floating point.
@defun logb x
This function returns the binary exponent of @var{x}. More
-precisely, the value is the logarithm base 2 of @math{|x|}, rounded
-down to an integer.
+precisely, if @var{x} is finite and nonzero, the value is the
+logarithm base 2 of @math{|x|}, rounded down to an integer.
+If @var{x} is zero, infinite, or a NaN, the value is minus infinity,
+plus infinity, or a NaN respectively.
@example
(logb 10)
@result{} 3
(logb 10.0e20)
@result{} 69
+(logb 0)
+ @result{} -1.0e+INF
@end example
@end defun
@@ -305,6 +339,18 @@ use otherwise), but the @code{zerop} predicate requires a number as
its argument. See also @code{integer-or-marker-p} and
@code{number-or-marker-p}, in @ref{Predicates on Markers}.
+@defun bignump object
+This predicate tests whether its argument is a large integer, and
+returns @code{t} if so, @code{nil} otherwise. Unlike small integers,
+large integers can be @code{=} or @code{eql} even if they are not @code{eq}.
+@end defun
+
+@defun fixnump object
+This predicate tests whether its argument is a small integer, and
+returns @code{t} if so, @code{nil} otherwise. Small integers can be
+compared with @code{eq}.
+@end defun
+
@defun floatp object
This predicate tests whether its argument is floating point
and returns @code{t} if so, @code{nil} otherwise.
@@ -344,23 +390,27 @@ if so, @code{nil} otherwise. The argument must be a number.
@cindex comparing numbers
To test numbers for numerical equality, you should normally use
-@code{=}, not @code{eq}. There can be many distinct floating-point
-objects with the same numeric value. If you use @code{eq} to
-compare them, then you test whether two values are the same
-@emph{object}. By contrast, @code{=} compares only the numeric values
-of the objects.
-
- In Emacs Lisp, each integer is a unique Lisp object.
-Therefore, @code{eq} is equivalent to @code{=} where integers are
-concerned. It is sometimes convenient to use @code{eq} for comparing
-an unknown value with an integer, because @code{eq} does not report an
+@code{=} instead of non-numeric comparison predicates like @code{eq},
+@code{eql} and @code{equal}. Distinct floating-point and large
+integer objects can be numerically equal. If you use @code{eq} to
+compare them, you test whether they are the same @emph{object}; if you
+use @code{eql} or @code{equal}, you test whether their values are
+@emph{indistinguishable}. In contrast, @code{=} uses numeric
+comparison, and sometimes returns @code{t} when a non-numeric
+comparison would return @code{nil} and vice versa. @xref{Float
+Basics}.
+
+ In Emacs Lisp, if two fixnums are numerically equal, they are the
+same Lisp object. That is, @code{eq} is equivalent to @code{=} on
+fixnums. It is sometimes convenient to use @code{eq} for comparing
+an unknown value with a fixnum, because @code{eq} does not report an
error if the unknown value is not a number---it accepts arguments of
any type. By contrast, @code{=} signals an error if the arguments are
not numbers or markers. However, it is better programming practice to
use @code{=} if you can, even for comparing integers.
- Sometimes it is useful to compare numbers with @code{equal}, which
-treats two numbers as equal if they have the same data type (both
+ Sometimes it is useful to compare numbers with @code{eql} or @code{equal},
+which treat two numbers as equal if they have the same data type (both
integers, or both floating point) and the same value. By contrast,
@code{=} can treat an integer and a floating-point number as equal.
@xref{Equality Predicates}.
@@ -379,15 +429,6 @@ Here's a function to do this:
fuzz-factor)))
@end example
-@cindex CL note---integers vrs @code{eq}
-@quotation
-@b{Common Lisp note:} Comparing numbers in Common Lisp always requires
-@code{=} because Common Lisp implements multi-word integers, and two
-distinct integer objects can have the same numeric value. Emacs Lisp
-can have just one integer object for any given value because it has a
-limited range of integers.
-@end quotation
-
@defun = number-or-marker &rest number-or-markers
This function tests whether all its arguments are numerically equal,
and returns @code{t} if so, @code{nil} otherwise.
@@ -397,7 +438,8 @@ and returns @code{t} if so, @code{nil} otherwise.
This function acts like @code{eq} except when both arguments are
numbers. It compares numbers by type and numeric value, so that
@code{(eql 1.0 1)} returns @code{nil}, but @code{(eql 1.0 1.0)} and
-@code{(eql 1 1)} both return @code{t}.
+@code{(eql 1 1)} both return @code{t}. This can be used to compare
+large integers as well as small ones.
@end defun
@defun /= number-or-marker1 number-or-marker2
@@ -557,10 +599,6 @@ Except for @code{%}, each of these functions accepts both integer and
floating-point arguments, and returns a floating-point number if any
argument is floating point.
- Emacs Lisp arithmetic functions do not check for integer overflow.
-Thus @code{(1+ 536870911)} may evaluate to
-@minus{}536870912, depending on your hardware.
-
@defun 1+ number-or-marker
This function returns @var{number-or-marker} plus 1.
For example,
@@ -814,181 +852,119 @@ Rounding a value equidistant between two integers returns the even integer.
@cindex logical arithmetic
In a computer, an integer is represented as a binary number, a
-sequence of @dfn{bits} (digits which are either zero or one). A bitwise
+sequence of @dfn{bits} (digits which are either zero or one).
+Conceptually the bit sequence is infinite on the left, with the
+most-significant bits being all zeros or all ones. A bitwise
operation acts on the individual bits of such a sequence. For example,
@dfn{shifting} moves the whole sequence left or right one or more places,
reproducing the same pattern moved over.
The bitwise operations in Emacs Lisp apply only to integers.
-@defun lsh integer1 count
-@cindex logical shift
-@code{lsh}, which is an abbreviation for @dfn{logical shift}, shifts the
-bits in @var{integer1} to the left @var{count} places, or to the right
-if @var{count} is negative, bringing zeros into the vacated bits. If
-@var{count} is negative, @code{lsh} shifts zeros into the leftmost
-(most-significant) bit, producing a positive result even if
-@var{integer1} is negative. Contrast this with @code{ash}, below.
+@defun ash integer1 count
+@cindex arithmetic shift
+@code{ash} (@dfn{arithmetic shift}) shifts the bits in @var{integer1}
+to the left @var{count} places, or to the right if @var{count} is
+negative. Left shifts introduce zero bits on the right; right shifts
+discard the rightmost bits. Considered as an integer operation,
+@code{ash} multiplies @var{integer1} by
+@ifnottex
+2**@var{count},
+@end ifnottex
+@tex
+@math{2^{count}},
+@end tex
+and then converts the result to an integer by rounding downward, toward
+minus infinity.
-Here are two examples of @code{lsh}, shifting a pattern of bits one
-place to the left. We show only the low-order eight bits of the binary
-pattern; the rest are all zero.
+Here are examples of @code{ash}, shifting a pattern of bits one place
+to the left and to the right. These examples show only the low-order
+bits of the binary pattern; leading bits all agree with the
+highest-order bit shown. As you can see, shifting left by one is
+equivalent to multiplying by two, whereas shifting right by one is
+equivalent to dividing by two and then rounding toward minus infinity.
@example
@group
-(lsh 5 1)
- @result{} 10
-;; @r{Decimal 5 becomes decimal 10.}
-00000101 @result{} 00001010
-
-(lsh 7 1)
- @result{} 14
+(ash 7 1) @result{} 14
;; @r{Decimal 7 becomes decimal 14.}
-00000111 @result{} 00001110
+@dots{}000111
+ @result{}
+@dots{}001110
@end group
-@end example
-
-@noindent
-As the examples illustrate, shifting the pattern of bits one place to
-the left produces a number that is twice the value of the previous
-number.
-
-Shifting a pattern of bits two places to the left produces results
-like this (with 8-bit binary numbers):
-@example
@group
-(lsh 3 2)
- @result{} 12
-;; @r{Decimal 3 becomes decimal 12.}
-00000011 @result{} 00001100
+(ash 7 -1) @result{} 3
+@dots{}000111
+ @result{}
+@dots{}000011
@end group
-@end example
-On the other hand, shifting one place to the right looks like this:
-
-@example
@group
-(lsh 6 -1)
- @result{} 3
-;; @r{Decimal 6 becomes decimal 3.}
-00000110 @result{} 00000011
+(ash -7 1) @result{} -14
+@dots{}111001
+ @result{}
+@dots{}110010
@end group
@group
-(lsh 5 -1)
- @result{} 2
-;; @r{Decimal 5 becomes decimal 2.}
-00000101 @result{} 00000010
+(ash -7 -1) @result{} -4
+@dots{}111001
+ @result{}
+@dots{}111100
@end group
@end example
-@noindent
-As the example illustrates, shifting one place to the right divides the
-value of a positive integer by two, rounding downward.
+Here are examples of shifting left or right by two bits:
-The function @code{lsh}, like all Emacs Lisp arithmetic functions, does
-not check for overflow, so shifting left can discard significant bits
-and change the sign of the number. For example, left shifting
-536,870,911 produces @minus{}2 in the 30-bit implementation:
-
-@example
-(lsh 536870911 1) ; @r{left shift}
- @result{} -2
-@end example
-
-In binary, the argument looks like this:
-
-@example
+@smallexample
@group
-;; @r{Decimal 536,870,911}
-0111...111111 (30 bits total)
+ ; @r{ binary values}
+(ash 5 2) ; 5 = @r{@dots{}000101}
+ @result{} 20 ; = @r{@dots{}010100}
+(ash -5 2) ; -5 = @r{@dots{}111011}
+ @result{} -20 ; = @r{@dots{}101100}
@end group
-@end example
-
-@noindent
-which becomes the following when left shifted:
-
-@example
@group
-;; @r{Decimal @minus{}2}
-1111...111110 (30 bits total)
+(ash 5 -2)
+ @result{} 1 ; = @r{@dots{}000001}
@end group
-@end example
-@end defun
-
-@defun ash integer1 count
-@cindex arithmetic shift
-@code{ash} (@dfn{arithmetic shift}) shifts the bits in @var{integer1}
-to the left @var{count} places, or to the right if @var{count}
-is negative.
-
-@code{ash} gives the same results as @code{lsh} except when
-@var{integer1} and @var{count} are both negative. In that case,
-@code{ash} puts ones in the empty bit positions on the left, while
-@code{lsh} puts zeros in those bit positions.
-
-Thus, with @code{ash}, shifting the pattern of bits one place to the right
-looks like this:
-
-@example
@group
-(ash -6 -1) @result{} -3
-;; @r{Decimal @minus{}6 becomes decimal @minus{}3.}
-1111...111010 (30 bits total)
- @result{}
-1111...111101 (30 bits total)
+(ash -5 -2)
+ @result{} -2 ; = @r{@dots{}111110}
@end group
-@end example
-
-In contrast, shifting the pattern of bits one place to the right with
-@code{lsh} looks like this:
+@end smallexample
+@end defun
-@example
-@group
-(lsh -6 -1) @result{} 536870909
-;; @r{Decimal @minus{}6 becomes decimal 536,870,909.}
-1111...111010 (30 bits total)
- @result{}
-0111...111101 (30 bits total)
-@end group
-@end example
+@defun lsh integer1 count
+@cindex logical shift
+@code{lsh}, which is an abbreviation for @dfn{logical shift}, shifts the
+bits in @var{integer1} to the left @var{count} places, or to the right
+if @var{count} is negative, bringing zeros into the vacated bits. If
+@var{count} is negative, then @var{integer1} must be either a fixnum
+or a positive bignum, and @code{lsh} treats a negative fixnum as if it
+were unsigned by subtracting twice @code{most-negative-fixnum} before
+shifting, producing a nonnegative result. This quirky behavior dates
+back to when Emacs supported only fixnums; nowadays @code{ash} is a
+better choice.
-Here are other examples:
+As @code{lsh} behaves like @code{ash} except when @var{integer1} and
+@var{count1} are both negative, the following examples focus on these
+exceptional cases. These examples assume 30-bit fixnums.
-@c !!! Check if lined up in smallbook format! XDVI shows problem
-@c with smallbook but not with regular book! --rjc 16mar92
@smallexample
@group
- ; @r{ 30-bit binary values}
-
-(lsh 5 2) ; 5 = @r{0000...000101}
- @result{} 20 ; = @r{0000...010100}
+ ; @r{ binary values}
+(ash -7 -1) ; -7 = @r{@dots{}111111111111111111111111111001}
+ @result{} -4 ; = @r{@dots{}111111111111111111111111111100}
+(lsh -7 -1)
+ @result{} 536870908 ; = @r{@dots{}011111111111111111111111111100}
@end group
@group
-(ash 5 2)
- @result{} 20
-(lsh -5 2) ; -5 = @r{1111...111011}
- @result{} -20 ; = @r{1111...101100}
-(ash -5 2)
- @result{} -20
-@end group
-@group
-(lsh 5 -2) ; 5 = @r{0000...000101}
- @result{} 1 ; = @r{0000...000001}
-@end group
-@group
-(ash 5 -2)
- @result{} 1
-@end group
-@group
-(lsh -5 -2) ; -5 = @r{1111...111011}
- @result{} 268435454
- ; = @r{0011...111110}
-@end group
-@group
-(ash -5 -2) ; -5 = @r{1111...111011}
- @result{} -2 ; = @r{1111...111110}
+(ash -5 -2) ; -5 = @r{@dots{}111111111111111111111111111011}
+ @result{} -2 ; = @r{@dots{}111111111111111111111111111110}
+(lsh -5 -2)
+ @result{} 268435454 ; = @r{@dots{}001111111111111111111111111110}
@end group
@end smallexample
@end defun
@@ -1022,23 +998,23 @@ because its binary representation consists entirely of ones. If
@smallexample
@group
- ; @r{ 30-bit binary values}
+ ; @r{ binary values}
-(logand 14 13) ; 14 = @r{0000...001110}
- ; 13 = @r{0000...001101}
- @result{} 12 ; 12 = @r{0000...001100}
+(logand 14 13) ; 14 = @r{@dots{}001110}
+ ; 13 = @r{@dots{}001101}
+ @result{} 12 ; 12 = @r{@dots{}001100}
@end group
@group
-(logand 14 13 4) ; 14 = @r{0000...001110}
- ; 13 = @r{0000...001101}
- ; 4 = @r{0000...000100}
- @result{} 4 ; 4 = @r{0000...000100}
+(logand 14 13 4) ; 14 = @r{@dots{}001110}
+ ; 13 = @r{@dots{}001101}
+ ; 4 = @r{@dots{}000100}
+ @result{} 4 ; 4 = @r{@dots{}000100}
@end group
@group
(logand)
- @result{} -1 ; -1 = @r{1111...111111}
+ @result{} -1 ; -1 = @r{@dots{}111111}
@end group
@end smallexample
@end defun
@@ -1052,18 +1028,18 @@ passed just one argument, it returns that argument.
@smallexample
@group
- ; @r{ 30-bit binary values}
+ ; @r{ binary values}
-(logior 12 5) ; 12 = @r{0000...001100}
- ; 5 = @r{0000...000101}
- @result{} 13 ; 13 = @r{0000...001101}
+(logior 12 5) ; 12 = @r{@dots{}001100}
+ ; 5 = @r{@dots{}000101}
+ @result{} 13 ; 13 = @r{@dots{}001101}
@end group
@group
-(logior 12 5 7) ; 12 = @r{0000...001100}
- ; 5 = @r{0000...000101}
- ; 7 = @r{0000...000111}
- @result{} 15 ; 15 = @r{0000...001111}
+(logior 12 5 7) ; 12 = @r{@dots{}001100}
+ ; 5 = @r{@dots{}000101}
+ ; 7 = @r{@dots{}000111}
+ @result{} 15 ; 15 = @r{@dots{}001111}
@end group
@end smallexample
@end defun
@@ -1077,18 +1053,18 @@ result is 0, which is an identity element for this operation. If
@smallexample
@group
- ; @r{ 30-bit binary values}
+ ; @r{ binary values}
-(logxor 12 5) ; 12 = @r{0000...001100}
- ; 5 = @r{0000...000101}
- @result{} 9 ; 9 = @r{0000...001001}
+(logxor 12 5) ; 12 = @r{@dots{}001100}
+ ; 5 = @r{@dots{}000101}
+ @result{} 9 ; 9 = @r{@dots{}001001}
@end group
@group
-(logxor 12 5 7) ; 12 = @r{0000...001100}
- ; 5 = @r{0000...000101}
- ; 7 = @r{0000...000111}
- @result{} 14 ; 14 = @r{0000...001110}
+(logxor 12 5 7) ; 12 = @r{@dots{}001100}
+ ; 5 = @r{@dots{}000101}
+ ; 7 = @r{@dots{}000111}
+ @result{} 14 ; 14 = @r{@dots{}001110}
@end group
@end smallexample
@end defun
@@ -1101,9 +1077,27 @@ bit is one in the result if, and only if, the @var{n}th bit is zero in
@example
(lognot 5)
@result{} -6
-;; 5 = @r{0000...000101} (30 bits total)
+;; 5 = @r{@dots{}000101}
;; @r{becomes}
-;; -6 = @r{1111...111010} (30 bits total)
+;; -6 = @r{@dots{}111010}
+@end example
+@end defun
+
+@cindex popcount
+@cindex Hamming weight
+@cindex counting set bits
+@defun logcount integer
+This function returns the @dfn{Hamming weight} of @var{integer}: the
+number of ones in the binary representation of @var{integer}.
+If @var{integer} is negative, it returns the number of zero bits in
+its two's complement binary representation. The result is always
+nonnegative.
+
+@example
+(logcount 43) ; 43 = @r{@dots{}000101011}
+ @result{} 4
+(logcount -43) ; -43 = @r{@dots{}111010101}
+ @result{} 3
@end example
@end defun
@@ -1189,8 +1183,8 @@ returns a NaN.
@defun expt x y
This function returns @var{x} raised to power @var{y}. If both
-arguments are integers and @var{y} is positive, the result is an
-integer; in this case, overflow causes truncation, so watch out.
+arguments are integers and @var{y} is nonnegative, the result is an
+integer; in this case, overflow signals an error, so watch out.
If @var{x} is a finite negative number and @var{y} is a finite
non-integer, @code{expt} returns a NaN.
@end defun
@@ -1241,11 +1235,10 @@ other strings to choose various seed values.
This function returns a pseudo-random integer. Repeated calls return a
series of pseudo-random integers.
-If @var{limit} is a positive integer, the value is chosen to be
+If @var{limit} is a positive fixnum, the value is chosen to be
nonnegative and less than @var{limit}. Otherwise, the value might be
-any integer representable in Lisp, i.e., an integer between
-@code{most-negative-fixnum} and @code{most-positive-fixnum}
-(@pxref{Integer Basics}).
+any fixnum, i.e., any integer from @code{most-negative-fixnum} through
+@code{most-positive-fixnum} (@pxref{Integer Basics}).
If @var{limit} is @code{t}, it means to choose a new seed as if Emacs
were restarting, typically from the system entropy. On systems
diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi
index 69b6c859f65..745baacc297 100644
--- a/doc/lispref/objects.texi
+++ b/doc/lispref/objects.texi
@@ -166,7 +166,10 @@ latter are unique to Emacs Lisp.
@node Integer Type
@subsection Integer Type
- The range of values for an integer depends on the machine. The
+ Under the hood, there are two kinds of integers---small integers,
+called @dfn{fixnums}, and large integers, called @dfn{bignums}.
+
+ The range of values for a fixnum depends on the machine. The
minimum range is @minus{}536,870,912 to 536,870,911 (30 bits; i.e.,
@ifnottex
@minus{}2**29
@@ -182,8 +185,15 @@ to
@math{2^{29}-1})
@end tex
but many machines provide a wider range.
-Emacs Lisp arithmetic functions do not check for integer overflow. Thus
-@code{(1+ 536870911)} is @minus{}536,870,912 if Emacs integers are 30 bits.
+
+ Bignums can have arbitrary precision. Operations that overflow a
+fixnum will return a bignum instead.
+
+ Fixnums can be compared with @code{eq}, but bignums require
+@code{eql} or @code{=}. To test whether an integer is a fixnum or a
+bignum, you can compare it to @code{most-negative-fixnum} and
+@code{most-positive-fixnum}, or you can use the convenience predicates
+@code{fixnump} and @code{bignump} on any object.
The read syntax for integers is a sequence of (base ten) digits with an
optional sign at the beginning and an optional period at the end. The
@@ -200,11 +210,6 @@ leading @samp{+} or a final @samp{.}.
@end example
@noindent
-As a special exception, if a sequence of digits specifies an integer
-too large or too small to be a valid integer object, the Lisp reader
-reads it as a floating-point number (@pxref{Floating-Point Type}).
-For instance, if Emacs integers are 30 bits, @code{536870912} is read
-as the floating-point number @code{536870912.0}.
@xref{Numbers}, for more information.
@@ -1895,6 +1900,9 @@ with references to further information.
@item arrayp
@xref{Array Functions, arrayp}.
+@item bignump
+@xref{Predicates on Numbers, floatp}.
+
@item bool-vector-p
@xref{Bool-Vectors, bool-vector-p}.
@@ -1928,6 +1936,9 @@ with references to further information.
@item custom-variable-p
@xref{Variable Definitions, custom-variable-p}.
+@item fixnump
+@xref{Predicates on Numbers, floatp}.
+
@item floatp
@xref{Predicates on Numbers, floatp}.
@@ -2083,6 +2094,10 @@ strings), two arguments with the same contents or elements are not
necessarily @code{eq} to each other: they are @code{eq} only if they
are the same object, meaning that a change in the contents of one will
be reflected by the same change in the contents of the other.
+For other types of objects whose contents cannot be changed (e.g.,
+floats), two arguments with the same contents might or might not be
+the same object, and @code{eq} returns @code{t} or @code{nil}
+depending on whether the Lisp interpreter created one object or two.
@example
@group
@@ -2096,6 +2111,12 @@ be reflected by the same change in the contents of the other.
@end group
@group
+(eq 3.0 3.0)
+ @result{} t @r{or} nil
+;; @r{The result is implementation-dependent.}
+@end group
+
+@group
(eq "asdf" "asdf")
@result{} nil
@end group
diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi
index a04f03bd463..59cd5a8fe8a 100644
--- a/doc/lispref/os.texi
+++ b/doc/lispref/os.texi
@@ -95,6 +95,22 @@ if requested by environment variables such as @env{LANG}.
@item
It does some basic parsing of the command-line arguments.
+@item
+It loads your early init file (@pxref{Early Init File,,, emacs, The
+GNU Emacs Manual}). This is not done if the options @samp{-q},
+@samp{-Q}, or @samp{--batch} were specified. If the @samp{-u} option
+was specified, Emacs looks for the init file in that user's home
+directory instead.
+
+@item
+It calls the function @code{package-activate-all} to activate any
+optional Emacs Lisp package that has been installed. @xref{Packaging
+Basics}. However, Emacs doesn't activate the packages when
+@code{package-enable-at-startup} is @code{nil} or when it's started
+with one of the options @samp{-q}, @samp{-Q}, or @samp{--batch}. To
+activate the packages in the latter case, @code{package-activate-all}
+should be called explicitly (e.g., via the @samp{--funcall} option).
+
@vindex initial-window-system@r{, and startup}
@findex window-system-initialization
@item
@@ -159,15 +175,6 @@ It loads your abbrevs from the file specified by
(@pxref{Abbrev Files, abbrev-file-name}). This is not done if the
option @samp{--batch} was specified.
-@item
-It calls the function @code{package-initialize} to activate any
-optional Emacs Lisp package that has been installed. @xref{Packaging
-Basics}. However, Emacs doesn't initialize packages when
-@code{package-enable-at-startup} is @code{nil} or when it's started
-with one of the options @samp{-q}, @samp{-Q}, or @samp{--batch}. To
-initialize packages in the latter case, @code{package-initialize}
-should be called explicitly (e.g., via the @samp{--funcall} option).
-
@vindex after-init-time
@item
It sets the variable @code{after-init-time} to the value of
@@ -366,6 +373,7 @@ Equivalent to @samp{-q --no-site-file --no-splash}.
@cindex init file
@cindex @file{.emacs}
@cindex @file{init.el}
+@cindex @file{early-init.el}
When you start Emacs, it normally attempts to load your @dfn{init
file}. This is either a file named @file{.emacs} or @file{.emacs.el}
@@ -389,6 +397,19 @@ file; this way, even if you have su'd, Emacs still loads your own init
file. If those environment variables are absent, though, Emacs uses
your user-id to find your home directory.
+@cindex early init file
+ Emacs also attempts to load a second init file, called the
+@dfn{early init file}, if it exists. This is a file named
+@file{early-init.el} in your @file{~/.emacs.d} directory. The
+difference between the early init file and the regular init file is
+that the early init file is loaded much earlier during the startup
+process, so you can use it to customize some things that are
+initialized before loading the regular init file. For example, you
+can customize the process of initializing the package system, by
+setting variables such as @var{package-load-list} or
+@var{package-enable-at-startup}. @xref{Package Installation,,,
+emacs,The GNU Emacs Manual}.
+
@cindex default init file
An Emacs installation may have a @dfn{default init file}, which is a
Lisp library named @file{default.el}. Emacs finds this file through
@@ -1181,24 +1202,19 @@ Titles}).
@cindex UID
@defun user-real-uid
This function returns the real @acronym{UID} of the user.
-The value may be floating point, in the (unlikely) event that
-the UID is too large to fit in a Lisp integer.
@end defun
@defun user-uid
This function returns the effective @acronym{UID} of the user.
-The value may be floating point.
@end defun
@cindex GID
@defun group-gid
This function returns the effective @acronym{GID} of the Emacs process.
-The value may be floating point.
@end defun
@defun group-real-gid
This function returns the real @acronym{GID} of the Emacs process.
-The value may be floating point.
@end defun
@defun system-users
@@ -1214,6 +1230,11 @@ groups on the system. If Emacs cannot retrieve this information, the
return value is @code{nil}.
@end defun
+@defun group-name gid
+This function returns the group name that corresponds to the numeric
+group ID @var{gid}, or @code{nil} if there is no such group.
+@end defun
+
@node Time of Day
@section Time of Day
@@ -1222,11 +1243,44 @@ return value is @code{nil}.
This section explains how to determine the current time and time
zone.
+@cindex Lisp timestamp
+@cindex timestamp, Lisp
+ Many functions like @code{current-time} and @code{file-attributes}
+return @dfn{Lisp timestamp} values that count seconds, and that can
+represent absolute time by counting seconds since the @dfn{epoch} of
+1970-01-01 00:00:00 UTC.
+
+ Although traditionally Lisp timestamps were integer pairs, their
+form has evolved and programs ordinarily should not depend on the
+current default form. If your program needs a particular timestamp
+form, you can use the @code{encode-time} function to convert it to the
+needed form. @xref{Time Conversion}.
+
@cindex epoch
- Most of these functions represent time as a list of four integers
-@code{(@var{sec-high} @var{sec-low} @var{microsec} @var{picosec})}.
-This represents the number of seconds from the @dfn{epoch} (January
-1, 1970 at 00:00 UTC), using the formula:
+ There are currently three forms of Lisp timestamps, each of
+which represents a number of seconds:
+
+@itemize @bullet
+@item
+An integer. Although this is the simplest form, it cannot represent
+subsecond timestamps.
+
+@item
+A pair of integers @code{(@var{ticks} . @var{hz})}, where @var{hz} is
+positive. This represents @var{ticks}/@var{hz} seconds, which is the
+same time as plain @var{ticks} if @var{hz} is 1. A common value for
+@var{hz} is 1000000000, for a nanosecond-resolution
+clock.@footnote{Currently @var{hz} should be at least 65536 to avoid
+compatibility warnings when the timestamp is passed to standard
+functions, as previous versions of Emacs would interpret such a
+timestamps differently due to backward-compatibility concerns. These
+warnings are intended to be removed in a future Emacs version.}
+
+@item
+A list of four integers @code{(@var{high} @var{low} @var{micro}
+@var{pico})}, where 0 @leq{} @var{low} < 65536, 0 @leq{} @var{micro} <
+1000000, and 0 @leq{} @var{pico} < 1000000.
+This represents the number of seconds using the formula:
@ifnottex
@var{high} * 2**16 + @var{low} + @var{micro} * 10**@minus{}6 +
@var{pico} * 10**@minus{}12.
@@ -1234,21 +1288,23 @@ This represents the number of seconds from the @dfn{epoch} (January
@tex
$high*2^{16} + low + micro*10^{-6} + pico*10^{-12}$.
@end tex
-The return value of @code{current-time} represents time using this
-form, as do the timestamps in the return values of other functions
-such as @code{file-attributes} (@pxref{Definition of
-file-attributes}). In some cases, functions may return two- or
+In some cases, functions may default to returning two- or
three-element lists, with omitted @var{microsec} and @var{picosec}
components defaulting to zero.
+On all current machines @var{picosec} is a multiple of 1000, but this
+may change as higher-resolution clocks become available.
+@end itemize
@cindex time value
Function arguments, e.g., the @var{time} argument to
@code{current-time-string}, accept a more-general @dfn{time value}
-format, which can be a list of integers as above, or a single number
-for seconds since the epoch, or @code{nil} for the current time. You
-can convert a time value into a human-readable string using
-@code{current-time-string} and @code{format-time-string}, into a list
-of integers using @code{seconds-to-time}, and into other forms using
+format, which can be a Lisp timestamp, @code{nil} for the current
+time, a single floating-point number for seconds, or a list
+@code{(@var{high} @var{low} @var{micro})} or @code{(@var{high}
+@var{low})} that is a truncated list timestamp with missing elements
+taken to be zero. You can convert a time value into
+a human-readable string using @code{format-time-string}, into a Lisp
+timestamp using @code{encode-time}, and into other forms using
@code{decode-time} and @code{float-time}. These functions are
described in the following sections.
@@ -1257,9 +1313,10 @@ This function returns the current time and date as a human-readable
string. The format does not vary for the initial part of the string,
which contains the day of week, month, day of month, and time of day
in that order: the number of characters used for these fields is
-always the same, so you can reliably
-use @code{substring} to extract them. You should count
-characters from the beginning of the string rather than from the end,
+always the same, although (unless you require English weekday or
+month abbreviations regardless of locale) it is typically more
+convenient to use @code{format-time-string} than to extract
+fields from the output of @code{current-time-string},
as the year might not have exactly four digits, and additional
information may some day be added at the end.
@@ -1276,12 +1333,7 @@ defaults to the current time zone rule. @xref{Time Zone Rules}.
@end defun
@defun current-time
-This function returns the current time, represented as a list of four
-integers @code{(@var{sec-high} @var{sec-low} @var{microsec} @var{picosec})}.
-These integers have trailing zeros on systems that return time with
-lower resolutions. On all current machines @var{picosec} is a
-multiple of 1000, but this may change as higher-resolution clocks
-become available.
+This function returns the current time as a Lisp timestamp.
@end defun
@defun float-time &optional time
@@ -1295,13 +1347,6 @@ exact. Do not use this function if precise time stamps are required.
@code{time-to-seconds} is an alias for this function.
@end defun
-@defun seconds-to-time time
-This function converts a time value to list-of-integer form.
-For example, if @var{time} is a number, @code{(time-to-seconds
-(seconds-to-time @var{time}))} equals the number unless overflow
-or rounding errors occur.
-@end defun
-
@node Time Zone Rules
@section Time Zone Rules
@cindex time zone rules
@@ -1412,7 +1457,8 @@ The year, an integer typically greater than 1900.
The day of week, as an integer between 0 and 6, where 0 stands for
Sunday.
@item dst
-@code{t} if daylight saving time is effect, otherwise @code{nil}.
+@code{t} if daylight saving time is effect, @code{nil} if it is not
+in effect, and @minus{}1 if this information is not available.
@item utcoff
An integer indicating the Universal Time offset in seconds, i.e., the number of
seconds east of Greenwich.
@@ -1422,32 +1468,63 @@ seconds east of Greenwich.
@var{dow} and @var{utcoff}.
@end defun
-@defun encode-time seconds minutes hour day month year &optional zone
-This function is the inverse of @code{decode-time}. It converts seven
-items of calendrical data into a list-of-integer time value. For the
-meanings of the arguments, see the table above under
-@code{decode-time}.
+@defun encode-time &optional time form &rest obsolescent-arguments
+This function converts @var{time} to a Lisp timestamp.
+It can act as the inverse of @code{decode-time}.
+
+The first argument can be a time value such as a number of seconds, a
+pair @code{(@var{ticks} . @var{hz})}, a list @code{(@var{high}
+@var{low} @var{micro} @var{pico})}, or @code{nil} (the default) for
+the current time (@pxref{Time of Day}). It can also be a list
+@code{(@var{second} @var{minute} @var{hour} @var{day} @var{month}
+@var{year} @var{ignored} @var{dst} @var{zone})} that specifies a
+decoded time in the style of @code{decode-time}, so that
+@code{(encode-time (decode-time ...))} works. For the meanings of
+these list members, see the table under @code{decode-time}.
+
+The optional @var{form} argument specifies the desired timestamp form
+to be returned. If @var{form} is the symbol @code{integer}, this
+function returns an integer count of seconds. If @var{form} is a
+positive integer, it specifies a clock frequency and this function
+returns an integer-pair timestamp @code{(@var{ticks}
+. @var{form})}.@footnote{Currently a positive integer @var{form}
+should be at least 65536 if the returned value is intended to be given
+to standard functions expecting Lisp timestamps.} If @var{form} is
+@code{t}, this function treats it as a positive integer suitable for
+representing the timestamp; for example, it is treated as 1000000000
+if the platform timestamp has nanosecond resolution. If @var{form} is
+@code{list}, this function returns an integer list @code{(@var{high}
+@var{low} @var{micro} @var{pico})}. Although an omitted or @code{nil}
+@var{form} currently acts like @code{list}, this is planned to change
+in a future Emacs version, so callers requiring list timestamps should
+pass @code{list} explicitly.
+
+As an obsolescent calling convention, this function can be given six
+or more arguments. The first six arguments @var{second},
+@var{minute}, @var{hour}, @var{day}, @var{month}, and @var{year}
+specify most of the components of a decoded time. If there are more
+than six arguments the @emph{last} argument is used as @var{zone} and
+any other extra arguments are ignored, so that @code{(apply
+#\\='encode-time (decode-time ...))} works; otherwise @var{zone} defaults
+to the current time zone rule (@pxref{Time Zone Rules}). The decoded
+time's @var{dst} component is treated as if it was @minus{}1, and
+@var{form} takes its default value.
Year numbers less than 100 are not treated specially. If you want them
to stand for years above 1900, or years above 2000, you must alter them
yourself before you call @code{encode-time}.
-The optional argument @var{zone} defaults to the current time zone rule.
-@xref{Time Zone Rules}.
-
-If you pass more than seven arguments to @code{encode-time}, the first
-six are used as @var{seconds} through @var{year}, the last argument is
-used as @var{zone}, and the arguments in between are ignored. This
-feature makes it possible to use the elements of a list returned by
-@code{decode-time} as the arguments to @code{encode-time}, like this:
+The @code{encode-time} function acts as a rough inverse to
+@code{decode-time}. For example, you can pass the output of
+the latter to the former as follows:
@example
-(apply 'encode-time (decode-time @dots{}))
+(encode-time (decode-time @dots{}))
@end example
You can perform simple date arithmetic by using out-of-range values for
-the @var{seconds}, @var{minutes}, @var{hour}, @var{day}, and @var{month}
-arguments; for example, day 0 means the day preceding the given month.
+@var{seconds}, @var{minutes}, @var{hour}, @var{day}, and @var{month};
+for example, day 0 means the day preceding the given month.
The operating system puts limits on the range of possible time values;
if you try to encode a time that is out of range, an error results.
@@ -1462,12 +1539,12 @@ on others, years as early as 1901 do work.
@cindex formatting time values
These functions convert time values to text in a string, and vice versa.
-Time values include @code{nil}, numbers, and lists of two to four
-integers (@pxref{Time of Day}).
+Time values include @code{nil}, numbers, and Lisp timestamps
+(@pxref{Time of Day}).
@defun date-to-time string
This function parses the time-string @var{string} and returns the
-corresponding time value. The argument @var{string} should represent
+corresponding Lisp timestamp. The argument @var{string} should represent
a date-time, and should be in one of the forms recognized by
@code{parse-time-string} (see below). This function assumes the GMT
timezone if @var{string} lacks an explicit timezone information.
@@ -1523,7 +1600,9 @@ This is a synonym for @samp{%m/%d/%y}.
@item %e
This stands for the day of month, blank-padded.
@item %F
-This stands for the ISO 8601 date format, i.e., @samp{"%Y-%m-%d"}.
+This stands for the ISO 8601 date format, which is like
+@samp{%+4Y-%m-%d} except that any flags or field width override the
+@samp{+} and (after subtracting 6) the @samp{4}.
@item %g
This stands for the year corresponding to the ISO week within the century.
@item %G
@@ -1603,7 +1682,9 @@ This stands for a single @samp{%}.
@end table
One or more flag characters can appear immediately after the @samp{%}.
-@samp{0} pads with zeros, @samp{_} pads with blanks, @samp{-}
+@samp{0} pads with zeros, @samp{+} pads with zeros and also puts
+@samp{+} before nonnegative year numbers with more than four digits,
+@samp{_} pads with blanks, @samp{-}
suppresses padding, @samp{^} upper-cases letters, and @samp{#}
reverses the case of letters.
@@ -1686,10 +1767,6 @@ You can also specify the field width by following the @samp{%} with a
number; shorter numbers will be padded with blanks. An optional
period before the width requests zero-padding instead. For example,
@code{"%.3Y"} might produce @code{"004 years"}.
-
-@emph{Warning:} This function works only with values of @var{seconds}
-that don't exceed @code{most-positive-fixnum} (@pxref{Integer Basics,
-most-positive-fixnum}).
@end defun
@node Processor Run Time
@@ -1714,10 +1791,8 @@ When called interactively, it prints the uptime in the echo area.
@end deffn
@defun get-internal-run-time
-This function returns the processor run time used by Emacs as a list
-of four integers: @code{(@var{sec-high} @var{sec-low} @var{microsec}
-@var{picosec})}, using the same format as @code{current-time}
-(@pxref{Time of Day}).
+This function returns the processor run time used by Emacs, as a Lisp
+timestamp (@pxref{Time of Day}).
Note that the time returned by this function excludes the time Emacs
was not using the processor, and if the Emacs process has several
@@ -1742,26 +1817,36 @@ interactively, it prints the duration in the echo area.
@cindex calendrical computations
These functions perform calendrical computations using time values
-(@pxref{Time of Day}). A value of @code{nil} for any of their
+(@pxref{Time of Day}). As with any time value, a value of
+@code{nil} for any of their
time-value arguments stands for the current system time, and a single
-integer number stands for the number of seconds since the epoch.
+number stands for the number of seconds since the epoch.
@defun time-less-p t1 t2
This returns @code{t} if time value @var{t1} is less than time value
@var{t2}.
+The result is @code{nil} if either argument is a NaN.
+@end defun
+
+@defun time-equal-p t1 t2
+This returns @code{t} if @var{t1} and @var{t2} are equal time values.
+The result is @code{nil} if either argument is a NaN.
@end defun
@defun time-subtract t1 t2
This returns the time difference @var{t1} @minus{} @var{t2} between
-two time values, as a time value. If you need the difference in units
+two time values, as a time value. However, the result is a float
+if either argument is a float infinity or NaN@.
+If you need the difference in units
of elapsed seconds, use @code{float-time} (@pxref{Time of Day,
float-time}) to convert the result into seconds.
@end defun
@defun time-add t1 t2
This returns the sum of two time values, as a time value.
+However, the result is a float if either argument is a float infinity or NaN@.
One argument should represent a time difference rather than a point in time,
-either as a list or as a single number of elapsed seconds.
+as a time value that is often just a single number of elapsed seconds.
Here is how to add a number of seconds to a time value:
@example
@@ -2004,8 +2089,7 @@ the idleness time, as described below.
@defun current-idle-time
If Emacs is idle, this function returns the length of time Emacs has
-been idle, as a list of four integers: @code{(@var{sec-high}
-@var{sec-low} @var{microsec} @var{picosec})}, using the same format as
+been idle, using the same format as
@code{current-time} (@pxref{Time of Day}).
When Emacs is not idle, @code{current-idle-time} returns @code{nil}.
diff --git a/doc/lispref/package.texi b/doc/lispref/package.texi
index 39bdc01a75c..7244efbd8f7 100644
--- a/doc/lispref/package.texi
+++ b/doc/lispref/package.texi
@@ -22,6 +22,7 @@ user-level features of the packaging system.
* Simple Packages:: How to package a single .el file.
* Multi-file Packages:: How to package multiple files.
* Package Archives:: Maintaining package archives.
+* Archive Web Server:: Interfacing to an archive web server.
@end menu
@node Packaging Basics
@@ -105,24 +106,36 @@ adds the package's content directory to @code{load-path}, and
evaluates the autoload definitions in @file{@var{name}-autoloads.el}.
Whenever Emacs starts up, it automatically calls the function
-@code{package-initialize} to load installed packages. This is done
-after loading the init file and abbrev file (if any) and before
-running @code{after-init-hook} (@pxref{Startup Summary}). Automatic
-package loading is disabled if the user option
-@code{package-enable-at-startup} is @code{nil}.
+@code{package-activate-all} to make installed packages available to the
+current session. This is done after loading the early init file, but
+before loading the regular init file (@pxref{Startup Summary}).
+Packages are not automatically made available if the user option
+@code{package-enable-at-startup} is set to @code{nil} in the early
+init file.
+
+@defun package-activate-all
+This function makes the packages available to the current session.
+The user option @code{package-load-list} specifies which packages to
+make available; by default, all installed packages are made available.
+If called during startup, this function also sets
+@code{package-enable-at-startup} to @code{nil}, to avoid accidentally
+evaluating package autoloads more than once. @xref{Package
+Installation,,, emacs, The GNU Emacs Manual}.
+
+In most cases, you should not need to call @code{package-activate-all},
+as this is done automatically during startup. Simply make sure to put
+any code that should run before @code{package-activate-all} in the early
+init file, and any code that should run after it in the primary init
+file (@pxref{Init File,,, emacs, The GNU Emacs Manual}).
+@end defun
@deffn Command package-initialize &optional no-activate
This function initializes Emacs' internal record of which packages are
-installed, and loads them. The user option @code{package-load-list}
-specifies which packages to load; by default, all installed packages
-are loaded. If called during startup, this function also sets
-@code{package-enable-at-startup} to @code{nil}, to avoid accidentally
-loading the packages twice. @xref{Package Installation,,, emacs, The
-GNU Emacs Manual}.
+installed, and then calls @code{package-activate-all}.
The optional argument @var{no-activate}, if non-@code{nil}, causes
Emacs to update its record of installed packages without actually
-loading them; it is for internal use only.
+making them available.
@end deffn
@node Simple Packages
@@ -237,7 +250,8 @@ dependency's version (a string).
@end defun
If the content directory contains a file named @file{README}, this
-file is used as the long description.
+file is used as the long description (overriding any @samp{;;;
+Commentary:} section).
If the content directory contains a file named @file{dir}, this is
assumed to be an Info directory file made with @command{install-info}.
@@ -299,8 +313,8 @@ access. Such local archives are mainly useful for testing.
A package archive is simply a directory in which the package files,
and associated files, are stored. If you want the archive to be
-reachable via HTTP, this directory must be accessible to a web server.
-How to accomplish this is beyond the scope of this manual.
+reachable via HTTP, this directory must be accessible to a web server;
+@xref{Archive Web Server}.
A convenient way to set up and update a package archive is via the
@code{package-x} library. This is included with Emacs, but not loaded
@@ -381,3 +395,28 @@ manual. For more information on cryptographic keys and signing,
@pxref{Top,, GnuPG, gnupg, The GNU Privacy Guard Manual}. Emacs comes
with an interface to GNU Privacy Guard, @pxref{Top,, EasyPG, epa,
Emacs EasyPG Assistant Manual}.
+
+@node Archive Web Server
+@section Interfacing to an archive web server
+@cindex archive web server
+
+A web server providing access to a package archive must support the
+following queries:
+
+@table @asis
+@item archive-contents
+Return a lisp form describing the archive contents. The form is a list
+of 'package-desc' structures (see @file{package.el}), except the first
+element of the list is the archive version.
+
+@item <package name>-readme.txt
+Return the long description of the package.
+
+@item <file name>.sig
+Return the signature for the file.
+
+@item <file name>
+Return the file. This will be the tarball for a multi-file
+package, or the single file for a simple package.
+
+@end table
diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi
index d2ab518e5eb..6be311b5639 100644
--- a/doc/lispref/processes.texi
+++ b/doc/lispref/processes.texi
@@ -177,6 +177,14 @@ before starting Emacs. Trying to modify @code{exec-path}
independently of @env{PATH} can lead to confusing results.
@end defopt
+@defun exec-path
+This function is an extension of the variable @code{exec-path}. If
+@code{default-directory} indicates a remote directory, this function
+returns a list of directories used for searching programs on the
+respective remote host. In case of a local @code{default-directory},
+the function returns just the value of the variable @code{exec-path}.
+@end defun
+
@node Shell Arguments
@section Shell Arguments
@cindex arguments for shell commands
@@ -415,27 +423,27 @@ be found in the definition of the @code{insert-directory} function:
@defun process-file program &optional infile buffer display &rest args
This function processes files synchronously in a separate process. It
-is similar to @code{call-process}, but may invoke a file handler based
-on the value of the variable @code{default-directory}, which specifies
-the current working directory of the subprocess.
+is similar to @code{call-process}, but may invoke a file name handler
+based on the value of the variable @code{default-directory}, which
+specifies the current working directory of the subprocess.
The arguments are handled in almost the same way as for
@code{call-process}, with the following differences:
-Some file handlers may not support all combinations and forms of the
+Some file name handlers may not support all combinations and forms of the
arguments @var{infile}, @var{buffer}, and @var{display}. For example,
-some file handlers might behave as if @var{display} were @code{nil},
+some file name handlers might behave as if @var{display} were @code{nil},
regardless of the value actually passed. As another example, some
-file handlers might not support separating standard output and error
+file name handlers might not support separating standard output and error
output by way of the @var{buffer} argument.
-If a file handler is invoked, it determines the program to run based
+If a file name handler is invoked, it determines the program to run based
on the first argument @var{program}. For instance, suppose that a
handler for remote files is invoked. Then the path that is used for
searching for the program might be different from @code{exec-path}.
-The second argument @var{infile} may invoke a file handler. The file
-handler could be different from the handler chosen for the
+The second argument @var{infile} may invoke a file name handler. The file
+name handler could be different from the handler chosen for the
@code{process-file} function itself. (For example,
@code{default-directory} could be on one remote host, and
@var{infile} on a different remote host. Or @code{default-directory}
@@ -462,7 +470,7 @@ remote files.
By default, this variable is always set to @code{t}, meaning that a
call of @code{process-file} could potentially change any file on a
-remote host. When set to @code{nil}, a file handler could optimize
+remote host. When set to @code{nil}, a file name handler could optimize
its behavior with respect to remote file attribute caching.
You should only ever change this variable with a let-binding; never
@@ -686,7 +694,15 @@ a default sentinel will be used, which can be overridden later.
@item :stderr @var{stderr}
Associate @var{stderr} with the standard error of the process. A
non-@code{nil} value should be either a buffer or a pipe process
-created with @code{make-pipe-process}, described below.
+created with @code{make-pipe-process}, described below. If
+@var{stderr} is @code{nil}, standard error is mixed with standard
+output, and both are sent to @var{buffer} or @var{filter}.
+
+@item :file-handler @var{file-handler}
+If @var{file-handler} is non-@code{nil}, then look for a file name
+handler for the current buffer's @code{default-directory}, and invoke
+that file name handler to make the process. If there is no such
+handler, proceed as if @var{file-handler} were @code{nil}.
@end table
The original argument list, modified with the actual connection
@@ -694,9 +710,18 @@ information, is available via the @code{process-contact} function.
The current working directory of the subprocess is set to the current
buffer's value of @code{default-directory} if that is local (as
-determined by `unhandled-file-name-directory'), or "~" otherwise. If
-you want to run a process in a remote directory use
-@code{start-file-process}.
+determined by @code{unhandled-file-name-directory}), or @file{~}
+otherwise. If you want to run a process in a remote directory, pass
+@code{:file-handler t} to @code{make-process}. In that case, the
+current working directory is the local name component of
+@code{default-directory} (as determined by @code{file-local-name}).
+
+Depending on the implementation of the file name handler, it might not
+be possible to apply @var{filter} or @var{sentinel} to the resulting
+process object. @xref{Filter Functions}, and @ref{Sentinels}.
+
+Some file name handlers may not support @code{make-process}. In such
+cases, this function does nothing and returns @code{nil}.
@end defun
@defun make-pipe-process &rest args
@@ -812,7 +837,7 @@ subprocess running @var{program} in it, and returns its process
object.
The difference from @code{start-process} is that this function may
-invoke a file handler based on the value of @code{default-directory}.
+invoke a file name handler based on the value of @code{default-directory}.
This handler ought to run @var{program}, perhaps on the local host,
perhaps on a remote host that corresponds to @code{default-directory}.
In the latter case, the local part of @code{default-directory} becomes
@@ -826,13 +851,13 @@ names relative to @code{default-directory}, or to names that identify
the files locally on the remote host, by running them through
@code{file-local-name}.
-Depending on the implementation of the file handler, it might not be
+Depending on the implementation of the file name handler, it might not be
possible to apply @code{process-filter} or @code{process-sentinel} to
the resulting process object. @xref{Filter Functions}, and @ref{Sentinels}.
@c FIXME Can we find a better example (i.e., a more modern function
@c that is actually documented).
-Some file handlers may not support @code{start-file-process} (for
+Some file name handlers may not support @code{start-file-process} (for
example the function @code{ange-ftp-hook-function}). In such cases,
this function does nothing and returns @code{nil}.
@end defun
@@ -1764,7 +1789,7 @@ system comes from @code{coding-system-for-read}, if that is
non-@code{nil}; or else from the defaulting mechanism (@pxref{Default
Coding Systems}). If the text output by a process contains null
bytes, Emacs by default uses @code{no-conversion} for it; see
-@ref{Lisp and Coding Systems, inhibit-null-byte-detection}, for how to
+@ref{Lisp and Coding Systems, inhibit-nul-byte-detection}, for how to
control this behavior.
@strong{Warning:} Coding systems such as @code{undecided}, which
@@ -1834,6 +1859,26 @@ corresponding connection contains buffered data. The function returns
arrived.
@end defun
+If a connection from a process contains buffered data,
+@code{accept-process-output} can return non-@code{nil} even after the
+process has exited. Therefore, although the following loop:
+
+@example
+;; This loop contains a bug.
+(while (process-live-p process)
+ (accept-process-output process))
+@end example
+
+@noindent
+will often read all output from @var{process}, it has a race condition
+and can miss some output if @code{process-live-p} returns @code{nil}
+while the connection still contains data. Better is to write the loop
+like this:
+
+@example
+(while (accept-process-output process))
+@end example
+
@node Processes and Threads
@subsection Processes and Threads
@cindex processes, threads
@@ -2079,8 +2124,6 @@ attribute and @var{value} is the value of that attribute. The various
attribute @var{key}s that this function can return are listed below.
Not all platforms support all of these attributes; if an attribute is
not supported, its association will not appear in the returned alist.
-Values that are numbers can be either integer or floating point,
-depending on the magnitude of the value.
@table @code
@item euid
@@ -2164,19 +2207,17 @@ faults for all the child processes of the given process.
@item utime
Time spent by the process in the user context, for running the
-application's code. The corresponding @var{value} is in the
-@w{@code{(@var{high} @var{low} @var{microsec} @var{picosec})}} format, the same
-format used by functions @code{current-time} (@pxref{Time of Day,
-current-time}) and @code{file-attributes} (@pxref{File Attributes}).
+application's code. The corresponding @var{value} is a Lisp
+timestamp (@pxref{Time of Day}).
@item stime
Time spent by the process in the system (kernel) context, for
-processing system calls. The corresponding @var{value} is in the same
-format as for @code{utime}.
+processing system calls. The corresponding @var{value} is a Lisp
+timestamp.
@item time
The sum of @code{utime} and @code{stime}. The corresponding
-@var{value} is in the same format as for @code{utime}.
+@var{value} is a Lisp timestamp.
@item cutime
@itemx cstime
@@ -2195,13 +2236,10 @@ nice values get scheduled more favorably.)
The number of threads in the process.
@item start
-The time when the process was started, in the same
-@code{(@var{high} @var{low} @var{microsec} @var{picosec})} format used by
-@code{file-attributes} and @code{current-time}.
+The time when the process was started, as a Lisp timestamp.
@item etime
-The time elapsed since the process started, in the format @code{(@var{high}
-@var{low} @var{microsec} @var{picosec})}.
+The time elapsed since the process started, as a Lisp timestamp.
@item vsize
The virtual memory size of the process, measured in kilobytes.
@@ -2602,7 +2640,9 @@ Specify the host to connect to. @var{host} should be a host name or
Internet address, as a string, or the symbol @code{local} to specify
the local host. If you specify @var{host} for a server, it must
specify a valid address for the local host, and only clients
-connecting to that address will be accepted.
+connecting to that address will be accepted. When using @code{local},
+by default IPv4 will be used, specify a @var{family} of @code{ipv6} to
+override this.
@item :service @var{service}
@var{service} specifies a port number to connect to; or, for a server,
@@ -2729,8 +2769,7 @@ Initialize the process filter to @var{filter}.
@item :filter-multibyte @var{multibyte}
If @var{multibyte} is non-@code{nil}, strings given to the process
-filter are multibyte, otherwise they are unibyte. The default is the
-default value of @code{enable-multibyte-characters}.
+filter are multibyte, otherwise they are unibyte. The default is @code{t}.
@item :sentinel @var{sentinel}
Initialize the process sentinel to @var{sentinel}.
@@ -3133,7 +3172,6 @@ direction is also known as @dfn{serializing} or @dfn{packing}.
@menu
* Bindat Spec:: Describing data layout.
* Bindat Functions:: Doing the unpacking and packing.
-* Bindat Examples:: Samples of what bindat.el can do for you!
@end menu
@node Bindat Spec
@@ -3376,132 +3414,3 @@ dotted notation.
@result{} "127.0.0.1"
@end example
@end defun
-
-@node Bindat Examples
-@subsection Examples of Byte Unpacking and Packing
-@c FIXME? This seems a very long example for something that is not used
-@c very often. As of 25.2, gdb-mi.el is the only user of bindat.el in Emacs.
-@c Maybe one or both of these examples should just be moved to the
-@c commentary of bindat.el.
-
- Here are two complete examples that use bindat.el.
-The first shows simple byte packing:
-
-@lisp
-(require 'bindat)
-
-(defun rfc868-payload ()
- (bindat-pack
- '((now-hi u16)
- (now-lo u16))
- ;; Emacs uses Unix epoch, while RFC868 epoch
- ;; is 1900-01-01 00:00:00, which is 2208988800
- ;; (or #x83aa7e80) seconds more.
- (let ((now (time-add nil '(#x83aa #x7e80))))
- `((now-hi . ,(car now))
- (now-lo . ,(cadr now))))))
-
-(let ((s (rfc868-payload)))
- (list (multibyte-string-p s)
- (mapconcat (lambda (byte)
- (format "%02x" byte))
- s " ")
- (current-time-string)))
- @result{} (nil "dc 6d 17 01" "Fri Mar 10 13:13:53 2017")
-@end lisp
-
-The following is an example of defining and unpacking a complex
-structure. Consider the following C structures:
-
-@example
-struct header @{
- unsigned long dest_ip;
- unsigned long src_ip;
- unsigned short dest_port;
- unsigned short src_port;
-@};
-
-struct data @{
- unsigned char type;
- unsigned char opcode;
- unsigned short length; /* in network byte order */
- unsigned char id[8]; /* null-terminated string */
- unsigned char data[/* (length + 3) & ~3 */];
-@};
-
-struct packet @{
- struct header header;
- unsigned long counters[2]; /* in little endian order */
- unsigned char items;
- unsigned char filler[3];
- struct data item[/* items */];
-
-@};
-@end example
-
-The corresponding data layout specification is:
-
-@lisp
-(setq header-spec
- '((dest-ip ip)
- (src-ip ip)
- (dest-port u16)
- (src-port u16)))
-
-(setq data-spec
- '((type u8)
- (opcode u8)
- (length u16) ; network byte order
- (id strz 8)
- (data vec (length))
- (align 4)))
-
-(setq packet-spec
- '((header struct header-spec)
- (counters vec 2 u32r) ; little endian order
- (items u8)
- (fill 3)
- (item repeat (items)
- (struct data-spec))))
-@end lisp
-
-A binary data representation is:
-
-@lisp
-(setq binary-data
- [ 192 168 1 100 192 168 1 101 01 28 21 32
- 160 134 1 0 5 1 0 0 2 0 0 0
- 2 3 0 5 ?A ?B ?C ?D ?E ?F 0 0 1 2 3 4 5 0 0 0
- 1 4 0 7 ?B ?C ?D ?E ?F ?G 0 0 6 7 8 9 10 11 12 0 ])
-@end lisp
-
-The corresponding decoded structure is:
-
-@lisp
-(setq decoded (bindat-unpack packet-spec binary-data))
- @result{}
-((header
- (dest-ip . [192 168 1 100])
- (src-ip . [192 168 1 101])
- (dest-port . 284)
- (src-port . 5408))
- (counters . [100000 261])
- (items . 2)
- (item ((data . [1 2 3 4 5])
- (id . "ABCDEF")
- (length . 5)
- (opcode . 3)
- (type . 2))
- ((data . [6 7 8 9 10 11 12])
- (id . "BCDEFG")
- (length . 7)
- (opcode . 4)
- (type . 1))))
-@end lisp
-
-An example of fetching data from this structure:
-
-@lisp
-(bindat-get-field decoded 'item 1 'id)
- @result{} "BCDEFG"
-@end lisp
diff --git a/doc/lispref/searching.texi b/doc/lispref/searching.texi
index 0cf527b6ac7..8775254dd07 100644
--- a/doc/lispref/searching.texi
+++ b/doc/lispref/searching.texi
@@ -395,20 +395,23 @@ or @samp{$}, @samp{%} or period. However, the ending character of one
range should not be the starting point of another one; for example,
@samp{[a-m-z]} should be avoided.
+A character alternative can also specify named character classes
+(@pxref{Char Classes}). This is a POSIX feature. For example,
+@samp{[[:ascii:]]} matches any @acronym{ASCII} character.
+Using a character class is equivalent to mentioning each of the
+characters in that class; but the latter is not feasible in practice,
+since some classes include thousands of different characters.
+A character class should not appear as the lower or upper bound
+of a range.
+
The usual regexp special characters are not special inside a
character alternative. A completely different set of characters is
-special inside character alternatives: @samp{]}, @samp{-} and @samp{^}.
-
-To include a @samp{]} in a character alternative, you must make it the
-first character. For example, @samp{[]a]} matches @samp{]} or @samp{a}.
-To include a @samp{-}, write @samp{-} as the first or last character of
-the character alternative, or as the upper bound of a range. Thus, @samp{[]-]}
-matches both @samp{]} and @samp{-}. (As explained below, you cannot
-use @samp{\]} to include a @samp{]} inside a character alternative,
-since @samp{\} is not special there.)
-
-To include @samp{^} in a character alternative, put it anywhere but at
-the beginning.
+special: @samp{]}, @samp{-} and @samp{^}.
+To include @samp{]} in a character alternative, put it at the
+beginning. To include @samp{^}, put it anywhere but at the beginning.
+To include @samp{-}, put it at the end. Thus, @samp{[]^-]} matches
+all three of these special characters. You cannot use @samp{\} to
+escape these three characters, since @samp{\} is not special here.
The following aspects of ranges are specific to Emacs, in that POSIX
allows but does not require this behavior and programs other than
@@ -426,33 +429,52 @@ of its bounds, so that @samp{[a-z]} matches only ASCII letters, even
outside the C or POSIX locale.
@item
-As a special case, if either bound of a range is a raw 8-bit byte, the
-other bound should be a unibyte character, and the range matches only
-unibyte characters.
-
-@item
If the lower bound of a range is greater than its upper bound, the
-range is empty and represents no characters. Thus, @samp{[b-a]}
-always fails to match, and @samp{[^b-a]} matches any character,
-including newline. However, the lower bound should be at most one
-greater than the upper bound; for example, @samp{[c-a]} should be
-avoided.
+range is empty and represents no characters. Thus, @samp{[z-a]}
+always fails to match, and @samp{[^z-a]} matches any character,
+including newline. However, a reversed range should always be from
+the letter @samp{z} to the letter @samp{a} to make it clear that it is
+not a typo; for example, @samp{[+-*/]} should be avoided, because it
+matches only @samp{/} rather than the likely-intended four characters.
@end enumerate
-A character alternative can also specify named character classes
-(@pxref{Char Classes}). This is a POSIX feature. For example,
-@samp{[[:ascii:]]} matches any @acronym{ASCII} character.
-Using a character class is equivalent to mentioning each of the
-characters in that class; but the latter is not feasible in practice,
-since some classes include thousands of different characters.
-A character class should not appear as the lower or upper bound
-of a range.
+Some kinds of character alternatives are not the best style even
+though they have a well-defined meaning in Emacs. They include:
+
+@enumerate
+@item
+Although a range's bound can be almost any character, it is better
+style to stay within natural sequences of ASCII letters and digits
+because most people have not memorized character code tables.
+For example, @samp{[.-9]} is less clear than @samp{[./0-9]},
+and @samp{[`-~]} is less clear than @samp{[`a-z@{|@}~]}.
+Unicode character escapes can help here; for example, for most programmers
+@samp{[ก-ฺ฿-๛]} is less clear than @samp{[\u0E01-\u0E3A\u0E3F-\u0E5B]}.
+
+@item
+Although a character alternative can include duplicates, it is better
+style to avoid them. For example, @samp{[XYa-yYb-zX]} is less clear
+than @samp{[XYa-z]}.
+
+@item
+Although a range can denote just one, two, or three characters, it
+is simpler to list the characters. For example,
+@samp{[a-a0]} is less clear than @samp{[a0]}, @samp{[i-j]} is less clear
+than @samp{[ij]}, and @samp{[i-k]} is less clear than @samp{[ijk]}.
+
+@item
+Although a @samp{-} can appear at the beginning of a character
+alternative or as the upper bound of a range, it is better style to
+put @samp{-} by itself at the end of a character alternative. For
+example, although @samp{[-a-z]} is valid, @samp{[a-z-]} is better
+style; and although @samp{[*--]} is valid, @samp{[*+,-]} is clearer.
+@end enumerate
@item @samp{[^ @dots{} ]}
@cindex @samp{^} in regexp
@samp{[^} begins a @dfn{complemented character alternative}. This
matches any character except the ones specified. Thus,
-@samp{[^a-z0-9A-Z]} matches all characters @emph{except} letters and
+@samp{[^a-z0-9A-Z]} matches all characters @emph{except} ASCII letters and
digits.
@samp{^} is not special in a character alternative unless it is the first
@@ -575,7 +597,7 @@ tabs, and other characters whose Unicode @samp{general-category}
property (@pxref{Character Properties}) indicates they are spacing
separators.
@item [:cntrl:]
-This matches any @acronym{ASCII} control character.
+This matches any character whose code is in the range 0--31.
@item [:digit:]
This matches @samp{0} through @samp{9}. Thus, @samp{[-+[:digit:]]}
matches any digit, as well as @samp{+} and @samp{-}.
@@ -658,10 +680,10 @@ is omitted, the minimum is 0; if @var{n} is omitted, there is no
maximum. For both forms, @var{m} and @var{n}, if specified, may be no
larger than
@ifnottex
-2**15 @minus{} 1
+2**16 @minus{} 1
@end ifnottex
@tex
-@math{2^{15}-1}
+@math{2^{16}-1}
@end tex
.
@@ -966,7 +988,7 @@ whitespace:
@end defun
@cindex optimize regexp
-@defun regexp-opt strings &optional paren
+@defun regexp-opt strings &optional paren keep-order
This function returns an efficient regular expression that will match
any of the strings in the list @var{strings}. This is useful when you
need to make matching or searching as fast as possible---for example,
@@ -976,6 +998,9 @@ possible. A hand-tuned regular expression can sometimes be slightly
more efficient, but is almost never worth the effort.}.
@c E.g., see https://debbugs.gnu.org/2816
+If @var{strings} is the empty list, the return value is a regexp that
+never matches anything.
+
The optional argument @var{paren} can be any of the following:
@table @asis
@@ -1001,8 +1026,15 @@ if it is necessary to ensure that a postfix operator appended to
it will apply to the whole expression.
@end table
-The resulting regexp of @code{regexp-opt} is equivalent to but usually
-more efficient than that of a simplified version:
+The optional argument @var{keep-order}, if @code{nil} or omitted,
+allows the returned regexp to match the strings in any order. If
+non-@code{nil}, the match is guaranteed to be performed in the order
+given, as if the strings were made into a regexp by joining them with
+the @samp{\|} operator.
+
+Up to reordering, the resulting regexp of @code{regexp-opt} is
+equivalent to but usually more efficient than that of a simplified
+version:
@example
(defun simplified-regexp-opt (strings &optional paren)
@@ -1013,9 +1045,9 @@ more efficient than that of a simplified version:
((eq paren 'symbols) '("\\_<\\(" . "\\)\\_>"))
((null paren) '("\\(?:" . "\\)"))
(t '("\\(" . "\\)")))))
- (concat (car paren)
+ (concat (car parens)
(mapconcat 'regexp-quote strings "\\|")
- (cdr paren))))
+ (cdr parens))))
@end example
@end defun
diff --git a/doc/lispref/sequences.texi b/doc/lispref/sequences.texi
index 5cf2e89644d..a7f270c0680 100644
--- a/doc/lispref/sequences.texi
+++ b/doc/lispref/sequences.texi
@@ -782,10 +782,11 @@ before being sorted. @var{function} is a function of one argument.
@end defun
-@defun seq-contains sequence elt &optional function
- This function returns the first element in @var{sequence} that is equal to
-@var{elt}. If the optional argument @var{function} is non-@code{nil},
-it is a function of two arguments to use instead of the default @code{equal}.
+@defun seq-contains-p sequence elt &optional function
+ This function returns non-@code{nil} if at least one element in
+@var{sequence} is equal to @var{elt}. If the optional argument
+@var{function} is non-@code{nil}, it is a function of two arguments to
+use instead of the default @code{equal}.
@example
@group
@@ -1308,9 +1309,9 @@ not evaluate or even examine the elements of the vector.
@example
@group
(setq avector [1 two '(three) "four" [five]])
- @result{} [1 two (quote (three)) "four" [five]]
+ @result{} [1 two '(three) "four" [five]]
(eval avector)
- @result{} [1 two (quote (three)) "four" [five]]
+ @result{} [1 two '(three) "four" [five]]
(eq avector (eval avector))
@result{} t
@end group
@@ -1400,9 +1401,9 @@ list with the same elements:
@example
@group
(setq avector [1 two (quote (three)) "four" [five]])
- @result{} [1 two (quote (three)) "four" [five]]
+ @result{} [1 two '(three) "four" [five]]
(append avector nil)
- @result{} (1 two (quote (three)) "four" [five])
+ @result{} (1 two '(three) "four" [five])
@end group
@end example
@@ -1777,6 +1778,11 @@ If the ring is full, this function removes the newest element to make
room for the inserted element.
@end defun
+@defun ring-resize ring size
+Set the size of @var{ring} to @var{size}. If the new size is smaller,
+then the oldest items in the ring are discarded.
+@end defun
+
@cindex fifo data structure
If you are careful not to exceed the ring size, you can
use the ring as a first-in-first-out queue. For example:
diff --git a/doc/lispref/streams.texi b/doc/lispref/streams.texi
index 5aa49c2e954..600639f244f 100644
--- a/doc/lispref/streams.texi
+++ b/doc/lispref/streams.texi
@@ -809,6 +809,21 @@ when the output stream is a unibyte buffer or a marker pointing into
one.
@end defvar
+@defvar print-charset-text-property
+This variable controls printing of `charset' text property on printing
+a string. The value should be @code{nil}, @code{t}, or
+@code{default}.
+
+If the value is @code{nil}, @code{charset} text properties are never
+printed. If @code{t}, they are always printed.
+
+If the value is @code{default}, only print @code{charset} text
+properties if there is an ``unexpected'' @code{charset} property. For
+ascii characters, all charsets are considered ``expected''.
+Otherwise, the expected @code{charset} property of a character is
+given by @code{char-charset}.
+@end defvar
+
@defvar print-length
@cindex printing limits
The value of this variable is the maximum number of elements to print in
diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi
index 8420527f858..521f163663d 100644
--- a/doc/lispref/strings.texi
+++ b/doc/lispref/strings.texi
@@ -121,7 +121,7 @@ character (i.e., an integer), @code{nil} otherwise.
The following functions create strings, either from scratch, or by
putting strings together, or by taking them apart.
-@defun make-string count character
+@defun make-string count character &optional multibyte
This function returns a string made up of @var{count} repetitions of
@var{character}. If @var{count} is negative, an error is signaled.
@@ -132,6 +132,13 @@ This function returns a string made up of @var{count} repetitions of
@result{} ""
@end example
+ Normally, if @var{character} is an @acronym{ASCII} character, the
+result is a unibyte string. But if the optional argument
+@var{multibyte} is non-@code{nil}, the function will produce a
+multibyte string instead. This is useful when you later need to
+concatenate the result with non-@acronym{ASCII} strings or replace
+some of its characters with non-@acronym{ASCII} characters.
+
Other functions to compare with this one include @code{make-vector}
(@pxref{Vectors}) and @code{make-list} (@pxref{Building Lists}).
@end defun
@@ -666,6 +673,28 @@ of the two strings. The sign is negative if @var{string1} (or its
specified portion) is less.
@end defun
+@cindex Levenshtein distance
+@cindex distance between strings
+@cindex edit distance between strings
+@defun string-distance string1 string2 &optional bytecompare
+This function returns the @dfn{Levenshtein distance} between the
+source string @var{string1} and the target string @var{string2}. The
+Levenshtein distance is the number of single-character
+changes---deletions, insertions, or replacements---required to
+transform the source string into the target string; it is one possible
+definition of the @dfn{edit distance} between strings.
+
+Letter-case of the strings is significant for the computed distance,
+but their text properties are ignored. If the optional argument
+@var{bytecompare} is non-@code{nil}, the function calculates the
+distance in terms of bytes instead of characters. The byte-wise
+comparison uses the internal Emacs representation of characters, so it
+will produce inaccurate results for multibyte strings that include raw
+bytes (@pxref{Text Representations}); make the strings unibyte by
+encoding them (@pxref{Explicit Encoding}) if you need accurate results
+with raw bytes.
+@end defun
+
@defun assoc-string key alist &optional case-fold
This function works like @code{assoc}, except that @var{key} must be a
string or symbol, and comparison is done using @code{compare-strings}.
@@ -893,18 +922,25 @@ Functions}). Thus, strings are enclosed in @samp{"} characters, and
@item %o
@cindex integer to octal
Replace the specification with the base-eight representation of an
-unsigned integer.
+integer. Negative integers are formatted in a platform-dependent
+way. The object can also be a nonnegative floating-point
+number that is formatted as an integer, dropping any fraction, if the
+integer does not exceed machine limits.
@item %d
Replace the specification with the base-ten representation of a signed
-integer.
+integer. The object can also be a floating-point number that is
+formatted as an integer, dropping any fraction.
@item %x
@itemx %X
@cindex integer to hexadecimal
Replace the specification with the base-sixteen representation of an
-unsigned integer. @samp{%x} uses lower case and @samp{%X} uses upper
-case.
+integer. Negative integers are formatted in a platform-dependent
+way. @samp{%x} uses lower case and @samp{%X} uses upper
+case. The object can also be a nonnegative floating-point number that
+is formatted as an integer, dropping any fraction, if the integer does
+not exceed machine limits.
@item %c
Replace the specification with the character which is the value given.
@@ -981,17 +1017,17 @@ numbered or unnumbered format specifications but not both, except that
After the @samp{%} and any field number, you can put certain
@dfn{flag characters}.
- The flag @samp{+} inserts a plus sign before a positive number, so
+ The flag @samp{+} inserts a plus sign before a nonnegative number, so
that it always has a sign. A space character as flag inserts a space
-before a positive number. (Otherwise, positive numbers start with the
-first digit.) These flags are useful for ensuring that positive
-numbers and negative numbers use the same number of columns. They are
+before a nonnegative number. (Otherwise, nonnegative numbers start with the
+first digit.) These flags are useful for ensuring that nonnegative
+and negative numbers use the same number of columns. They are
ignored except for @samp{%d}, @samp{%e}, @samp{%f}, @samp{%g}, and if
both flags are used, @samp{+} takes precedence.
The flag @samp{#} specifies an alternate form which depends on
the format in use. For @samp{%o}, it ensures that the result begins
-with a @samp{0}. For @samp{%x} and @samp{%X}, it prefixes the result
+with a @samp{0}. For @samp{%x} and @samp{%X}, it prefixes nonzero results
with @samp{0x} or @samp{0X}. For @samp{%e} and @samp{%f}, the
@samp{#} flag means include a decimal point even if the precision is
zero. For @samp{%g}, it always includes a decimal point, and also
@@ -1074,6 +1110,17 @@ shows only the first three characters of the representation for
precision is what the local library functions of the @code{printf}
family produce.
+@cindex formatting numbers for rereading later
+ If you plan to use @code{read} later on the formatted string to
+retrieve a copy of the formatted value, use a specification that lets
+@code{read} reconstruct the value. To format numbers in this
+reversible way you can use @samp{%s} and @samp{%S}, to format just
+integers you can also use @samp{%d}, and to format just nonnegative
+integers you can also use @samp{#x%x} and @samp{#o%o}. Other formats
+may be problematic; for example, @samp{%d} and @samp{%g} can mishandle
+NaNs and can lose precision and type, and @samp{#x%x} and @samp{#o%o}
+can mishandle negative integers. @xref{Input Functions}.
+
@node Case Conversion
@section Case Conversion in Lisp
@cindex upper case
diff --git a/doc/lispref/syntax.texi b/doc/lispref/syntax.texi
index 9ad4a133509..b0c04ef9c25 100644
--- a/doc/lispref/syntax.texi
+++ b/doc/lispref/syntax.texi
@@ -1013,13 +1013,13 @@ corresponds to each syntax flag.
@item
@i{Prefix} @tab @i{Flag} @tab @i{Prefix} @tab @i{Flag}
@item
-@samp{1} @tab @code{(lsh 1 16)} @tab @samp{p} @tab @code{(lsh 1 20)}
+@samp{1} @tab @code{(ash 1 16)} @tab @samp{p} @tab @code{(ash 1 20)}
@item
-@samp{2} @tab @code{(lsh 1 17)} @tab @samp{b} @tab @code{(lsh 1 21)}
+@samp{2} @tab @code{(ash 1 17)} @tab @samp{b} @tab @code{(ash 1 21)}
@item
-@samp{3} @tab @code{(lsh 1 18)} @tab @samp{n} @tab @code{(lsh 1 22)}
+@samp{3} @tab @code{(ash 1 18)} @tab @samp{n} @tab @code{(ash 1 22)}
@item
-@samp{4} @tab @code{(lsh 1 19)} @tab @samp{c} @tab @code{(lsh 1 23)}
+@samp{4} @tab @code{(ash 1 19)} @tab @samp{c} @tab @code{(ash 1 23)}
@end multitable
@defun string-to-syntax desc
diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi
index 73312bb0caa..1ef836b8f94 100644
--- a/doc/lispref/text.texi
+++ b/doc/lispref/text.texi
@@ -61,6 +61,8 @@ the character after point.
* Checksum/Hash:: Computing cryptographic hashes.
* GnuTLS Cryptography:: Cryptographic algorithms imported from GnuTLS.
* Parsing HTML/XML:: Parsing HTML and XML.
+* Parsing JSON:: Parsing and generating JSON values.
+* JSONRPC:: JSON Remote Procedure Call protocol
* Atomic Changes:: Installing several buffer changes atomically.
* Change Hooks:: Supplying functions to be run when text is changed.
@end menu
@@ -498,14 +500,14 @@ after point. It leaves the mark after the inserted text. The value
is @code{nil}.
@end deffn
-@deffn Command self-insert-command count
+@deffn Command self-insert-command count &optional char
@cindex character insertion
@cindex self-insertion
-This command inserts the last character typed; it does so @var{count}
-times, before point, and returns @code{nil}. Most printing characters
-are bound to this command. In routine use, @code{self-insert-command}
-is the most frequently called function in Emacs, but programs rarely use
-it except to install it on a keymap.
+This command inserts the character @var{char} (the last character typed);
+it does so @var{count} times, before point, and returns @code{nil}.
+Most printing characters are bound to this command. In routine use,
+@code{self-insert-command} is the most frequently called function in Emacs,
+but programs rarely use it except to install it on a keymap.
In an interactive call, @var{count} is the numeric prefix argument.
@@ -721,12 +723,18 @@ You thought
@end example
@end deffn
-@deffn Command delete-indentation &optional join-following-p
+@deffn Command delete-indentation &optional join-following-p beg end
This function joins the line point is on to the previous line, deleting
any whitespace at the join and in some cases replacing it with one
space. If @var{join-following-p} is non-@code{nil},
@code{delete-indentation} joins this line to the following line
-instead. The function returns @code{nil}.
+instead. Otherwise, if @var{beg} and @var{end} are non-@code{nil},
+this function joins all lines in the region they define.
+
+In an interactive call, @var{join-following-p} is the prefix argument,
+and @var{beg} and @var{end} are, respectively, the start and end of
+the region if it is active, else @code{nil}. The function returns
+@code{nil}.
If there is a fill prefix, and the second of the lines being joined
starts with the prefix, then @code{delete-indentation} deletes the
@@ -1325,9 +1333,8 @@ elements follow immediately after this element.
@item (t . @var{time-flag})
This kind of element indicates that an unmodified buffer became
-modified. A @var{time-flag} of the form
-@code{(@var{sec-high} @var{sec-low} @var{microsec}
-@var{picosec})} represents the visited file's modification time as of
+modified. A @var{time-flag} that is a non-integer Lisp timestamp
+represents the visited file's modification time as of
when it was previously visited or saved, using the same format as
@code{current-time}; see @ref{Time of Day}.
A @var{time-flag} of 0 means the buffer does not correspond to any file;
@@ -3184,6 +3191,95 @@ buffer to scan. Positions are relative to @var{object}. The default
for @var{object} is the current buffer.
@end defun
+@defun text-property-search-forward prop &optional value predicate not-current
+Search for the next region that has text property @var{prop} set to
+@var{value} according to @var{predicate}.
+
+This function is modelled after @code{search-forward} and friends in
+that it moves point, but it returns a structure that describes the
+match instead of returning it in @code{match-beginning} and friends.
+
+If the text property can't be found, the function returns @code{nil}.
+If it's found, point is placed at the end of the region that has this
+text property match, and a @code{prop-match} structure is returned.
+
+@var{predicate} can either be @code{t} (which is a synonym for
+@code{equal}), @code{nil} (which means ``not equal''), or a predicate
+that will be called with two parameters: The first is @var{value}, and
+the second is the value of the text property we're inspecting.
+
+If @var{not-current}, if point is in a region where we have a match,
+then skip past that and find the next instance instead.
+
+The @code{prop-match} structure has the following accessors:
+@code{prop-match-beginning} (the start of the match),
+@code{prop-match-end} (the end of the match), and
+@code{prop-match-value} (the value of @var{property} at the start of
+the match).
+
+In the examples below, imagine that you're in a buffer that looks like
+this:
+
+@example
+This is a bold and here's bolditalic and this is the end.
+@end example
+
+That is, the ``bold'' words are the @code{bold} face, and the
+``italic'' word is in the @code{italic} face.
+
+With point at the start:
+
+@lisp
+(while (setq match (text-property-search-forward 'face 'bold t))
+ (push (buffer-substring (prop-match-beginning match)
+ (prop-match-end match))
+ words))
+@end lisp
+
+This will pick out all the words that use the @code{bold} face.
+
+@lisp
+(while (setq match (text-property-search-forward 'face nil t))
+ (push (buffer-substring (prop-match-beginning match)
+ (prop-match-end match))
+ words))
+@end lisp
+
+This will pick out all the bits that have no face properties, which
+will result in the list @samp{("This is a " "and here's " "and this is
+the end")} (only reversed, since we used @code{push}).
+
+@lisp
+(while (setq match (text-property-search-forward 'face nil nil))
+ (push (buffer-substring (prop-match-beginning match)
+ (prop-match-end match))
+ words))
+@end lisp
+
+This will pick out all the regions where @code{face} is set to
+something, but this is split up into where the properties change, so
+the result here will be @samp{("bold" "bold" "italic")}.
+
+For a more realistic example where you might use this, consider that
+you have a buffer where certain sections represent URLs, and these are
+tagged with @code{shr-url}.
+
+@lisp
+(while (setq match (text-property-search-forward 'shr-url nil nil))
+ (push (prop-match-value match) urls))
+@end lisp
+
+This will give you a list of all those URLs.
+
+@end defun
+
+@defun text-property-search-backward prop &optional value predicate not-current
+This is just like @code{text-property-search-backward}, but searches
+backward instead. Point is placed at the beginning of the matched
+region instead of the end, though.
+@end defun
+
+
@node Special Properties
@subsection Properties with Special Meanings
@@ -3235,6 +3331,17 @@ foreground or background color, similar to @code{(:foreground
@var{color-name})} or @code{(:background @var{color-name})}. This
form is supported for backward compatibility only, and should be
avoided.
+
+@item
+A cons cell of the form @w{@code{(:filtered @var{filter}
+@var{face-spec})}}, that specifies the face given by @var{face-spec},
+but only if @var{filter} matches when the face is used for display.
+The @var{face-spec} can use any of the forms mentioned above. The
+@var{filter} should be of the form @w{@code{(:window @var{param}
+@var{value})}}, which matches for windows whose parameter @var{param}
+is @code{eq} to @var{value}. If the variable
+@code{face-filters-always-match} is non-@code{nil}, all face filters
+are deemed to have matched.
@end itemize
Font Lock mode (@pxref{Font Lock Mode}) works in most buffers by
@@ -3617,6 +3724,12 @@ string to display, which is passed through
The GNU Emacs Manual}) provides an example.
@end defvar
+@defvar face-filters-always-match
+If this variable is non-@code{nil}, face filters that specify
+attributes applied only when certain conditions are met will be deemed
+to match always.
+@end defvar
+
@node Format Properties
@subsection Formatted Text Properties
@@ -4329,22 +4442,59 @@ all markers unrelocated.
You can use the following function to replace the text of one buffer
with the text of another buffer:
-@deffn Command replace-buffer-contents source
+@deffn Command replace-buffer-contents source &optional max-secs max-costs
This function replaces the accessible portion of the current buffer
with the accessible portion of the buffer @var{source}. @var{source}
may either be a buffer object or the name of a buffer. When
@code{replace-buffer-contents} succeeds, the text of the accessible
portion of the current buffer will be equal to the text of the
-accessible portion of the @var{source} buffer. This function attempts
-to keep point, markers, text properties, and overlays in the current
-buffer intact. One potential case where this behavior is useful is
-external code formatting programs: they typically write the
-reformatted text into a temporary buffer or file, and using
-@code{delete-region} and @code{insert-buffer-substring} would destroy
-these properties. However, the latter combination is typically
-faster. @xref{Deletion}, and @ref{Insertion}.
+accessible portion of the @var{source} buffer.
+
+This function attempts to keep point, markers, text properties, and
+overlays in the current buffer intact. One potential case where this
+behavior is useful is external code formatting programs: they
+typically write the reformatted text into a temporary buffer or file,
+and using @code{delete-region} and @code{insert-buffer-substring}
+would destroy these properties. However, the latter combination is
+typically faster (@xref{Deletion}, and @ref{Insertion}).
+
+For its working, @code{replace-buffer-contents} needs to compare the
+contents of the original buffer with that of @code{source} which is a
+costly operation if the buffers are huge and there is a high number of
+differences between them. In order to keep
+@code{replace-buffer-contents}'s runtime in bounds, it has two
+optional arguments.
+
+@code{max-secs} defines a hard boundary in terms of seconds. If given
+and exceeded, it will fall back to @code{delete-region} and
+@code{insert-buffer-substring}.
+
+@code{max-costs} defines the quality of the difference computation.
+If the actual costs exceed this limit, heuristics are used to provide
+a faster but suboptimal solution. The default value is 1000000.
+
+@code{replace-buffer-contents} returns t if a non-destructive
+replacement could be performed. Otherwise, i.e., if @code{max-secs}
+was exceeded, it returns nil.
@end deffn
+@defun replace-region-contents beg end replace-fn &optional max-secs max-costs
+This function replaces the region between @code{beg} and @code{end}
+using the given @code{replace-fn}. The function @code{replace-fn} is
+run in the current buffer narrowed to the specified region and it
+should return either a string or a buffer replacing the region.
+
+The replacement is performed using @code{replace-buffer-contents} (see
+above) which also describes the @code{max-secs} and @code{max-costs}
+arguments and the return value.
+
+Note: If the replacement is a string, it will be placed in a temporary
+buffer so that @code{replace-buffer-contents} can operate on it.
+Therefore, if you already have the replacement in a buffer, it makes
+no sense to convert it to a string using @code{buffer-substring} or
+similar.
+@end defun
+
@node Decompression
@section Dealing With Compressed Data
@@ -4363,14 +4513,17 @@ This function returns non-@code{nil} if built-in zlib decompression is
available.
@end defun
-@defun zlib-decompress-region start end
+@defun zlib-decompress-region start end &optional allow-partial
This function decompresses the region between @var{start} and
@var{end}, using built-in zlib decompression. The region should
contain data that were compressed with gzip or zlib. On success, the
function replaces the contents of the region with the decompressed
-data. On failure, the function leaves the region unchanged and
-returns @code{nil}. This function can be called only in unibyte
-buffers.
+data. If @var{allow-partial} is @code{nil} or omitted, then on
+failure, the function leaves the region unchanged and returns
+@code{nil}. Otherwise, it returns the number of bytes that were not
+decompressed and replaces the region text by whatever data was
+successfully decompressed. This function can be called only in
+unibyte buffers.
@end defun
@@ -4529,9 +4682,9 @@ It should be somewhat more efficient on larger buffers than
@cindex symmetric cipher
@cindex cipher, symmetric
-If compiled with GnuTLS, Emacs offers built-in cryptographic support.
-Following the GnuTLS API terminology, the available tools are digests,
-MACs, symmetric ciphers, and AEAD ciphers.
+ If compiled with GnuTLS, Emacs offers built-in cryptographic
+support. Following the GnuTLS API terminology, the available tools
+are digests, MACs, symmetric ciphers, and AEAD ciphers.
The terms used herein, such as IV (Initialization Vector), require
some familiarity with cryptography and will not be defined in detail.
@@ -4549,7 +4702,7 @@ structure of the GnuTLS library.
@cindex format of gnutls cryptography inputs
@cindex gnutls cryptography inputs format
-The inputs to GnuTLS cryptographic functions can be specified in
+ The inputs to GnuTLS cryptographic functions can be specified in
several ways, both as primitive Emacs Lisp types or as lists.
The list form is currently similar to how @code{md5} and
@@ -4716,8 +4869,15 @@ IV used.
@section Parsing HTML and XML
@cindex parsing html
-When Emacs is compiled with libxml2 support, the following functions
-are available to parse HTML or XML text into Lisp object trees.
+ Emacs can be compiled with built-in libxml2 support.
+
+@defun libxml-available-p
+This function returns non-@code{nil} if built-in libxml2 support is
+available in this Emacs session.
+@end defun
+
+When libxml2 support is available, the following functions can be used
+to parse HTML or XML text into Lisp object trees.
@defun libxml-parse-html-region start end &optional base-url discard-comments
This function parses the text between @var{start} and @var{end} as
@@ -4729,7 +4889,10 @@ The optional argument @var{base-url}, if non-@code{nil}, should be a
string specifying the base URL for relative URLs occurring in links.
If the optional argument @var{discard-comments} is non-@code{nil},
-then the parse tree is created without any comments.
+any top-level comment is discarded. (This argument is obsolete and
+will be removed in future Emacs versions. To remove comments, use the
+@code{xml-remove-comments} utility function on the data before you
+call the parsing function.)
In the parse tree, each HTML node is represented by a list in which
the first element is a symbol representing the node name, the second
@@ -4784,9 +4947,9 @@ about syntax).
@cindex DOM
@cindex Document Object Model
-The @acronym{DOM} returned by @code{libxml-parse-html-region} (and the
-other @acronym{XML} parsing functions) is a tree structure where each
-node has a node name (called a @dfn{tag}), and optional key/value
+ The @acronym{DOM} returned by @code{libxml-parse-html-region} (and
+the other @acronym{XML} parsing functions) is a tree structure where
+each node has a node name (called a @dfn{tag}), and optional key/value
@dfn{attribute} list, and then a list of @dfn{child nodes}. The child
nodes are either strings or @acronym{DOM} objects.
@@ -4904,6 +5067,319 @@ textual nodes that just contain white-space.
@end table
+@node Parsing JSON
+@section Parsing and generating JSON values
+@cindex JSON
+@cindex JavaScript Object Notation
+
+ When Emacs is compiled with @acronym{JSON} (@dfn{JavaScript Object
+Notation}) support, it provides several functions to convert
+between Lisp objects and JSON values. Any JSON value can be converted
+to a Lisp object, but not vice versa. Specifically:
+
+@itemize
+@item
+JSON uses three keywords: @code{true}, @code{null}, @code{false}.
+@code{true} is represented by the symbol @code{t}. By default, the
+remaining two are represented, respectively, by the symbols
+@code{:null} and @code{:false}.
+
+@item
+JSON only has floating-point numbers. They can represent both Lisp
+integers and Lisp floating-point numbers.
+
+@item
+JSON strings are always Unicode strings encoded in UTF-8. Lisp
+strings can contain non-Unicode characters.
+
+@item
+JSON has only one sequence type, the array. JSON arrays are
+represented using Lisp vectors.
+
+@item
+JSON has only one map type, the object. JSON objects are represented
+using Lisp hashtables, alists or plists. When an alist or plist
+contains several elements with the same key, Emacs uses only the first
+element for serialization, in accordance with the behavior of
+@code{assq}.
+@end itemize
+
+@noindent
+Note that @code{nil}, being both a valid alist and a valid plist,
+represents @code{@{@}}, the empty JSON object; not @code{null},
+@code{false}, or an empty array, all of which are different JSON
+values.
+
+ If some Lisp object can't be represented in JSON, the serialization
+functions will signal an error of type @code{wrong-type-argument}.
+The parsing functions can also signal the following errors:
+
+@table @code
+@item json-end-of-file
+Signaled when encountering a premature end of the input text.
+
+@item json-trailing-content
+Signaled when encountering unexpected input after the first JSON
+object parsed.
+
+@item json-parse-error
+Signaled when encountering invalid JSON syntax.
+@end table
+
+ Only top-level values (arrays and objects) can be serialized to
+JSON. The subobjects within these top-level values can be of any
+type. Likewise, the parsing functions will only return vectors,
+hashtables, alists, and plists.
+
+@defun json-serialize object &rest args
+This function returns a new Lisp string which contains the JSON
+representation of @var{object}. The argument @var{args} is a list of
+keyword/argument pairs. The following keywords are accepted:
+
+@table @code
+@item :null-object
+The value decides which Lisp object to use to represent the JSON
+keyword @code{null}. It defaults to the symbol @code{:null}.
+
+@item :false-object
+The value decides which Lisp object to use to represent the JSON
+keyword @code{false}. It defaults to the symbol @code{:false}.
+@end table
+
+@end defun
+
+@defun json-insert object &rest args
+This function inserts the JSON representation of @var{object} into the
+current buffer before point. The argument @var{args} are interpreted
+as in @code{json-parse-string}.
+@end defun
+
+@defun json-parse-string string &rest args
+This function parses the JSON value in @var{string}, which must be a
+Lisp string. The argument @var{args} is a list of keyword/argument
+pairs. The following keywords are accepted:
+
+@table @code
+@item :object-type
+The value decides which Lisp object to use for representing the
+key-value mappings of a JSON object. It can be either
+@code{hash-table}, the default, to make hashtables with strings as
+keys; @code{alist} to use alists with symbols as keys; or @code{plist}
+to use plists with keyword symbols as keys.
+
+@item :null-object
+The value decides which Lisp object to use to represent the JSON
+keyword @code{null}. It defaults to the symbol @code{:null}.
+
+@item :false-object
+The value decides which Lisp object to use to represent the JSON
+keyword @code{false}. It defaults to the symbol @code{:false}.
+@end table
+
+@end defun
+
+@defun json-parse-buffer &rest args
+This function reads the next JSON value from the current buffer,
+starting at point. It moves point to the position immediately after
+the value if a value could be read and converted to Lisp; otherwise it
+doesn't move point. The arguments @var{args} are interpreted as in
+@code{json-parse-string}.
+@end defun
+
+@node JSONRPC
+@section JSONRPC communication
+@cindex JSON remote procedure call protocol
+
+The @code{jsonrpc} library implements the @acronym{JSONRPC}
+specification, version 2.0, as it is described in
+@uref{http://www.jsonrpc.org/}. As the name suggests, JSONRPC is a
+generic @code{Remote Procedure Call} protocol designed around
+@acronym{JSON} objects, which you can convert to and from Lisp objects
+(@pxref{Parsing JSON}).
+
+@menu
+* JSONRPC Overview::
+* Process-based JSONRPC connections::
+* JSONRPC JSON object format::
+* JSONRPC deferred requests::
+@end menu
+
+@node JSONRPC Overview
+@subsection Overview
+
+Quoting from the @uref{http://www.jsonrpc.org/, spec}, JSONRPC "is
+transport agnostic in that the concepts can be used within the same
+process, over sockets, over http, or in many various message passing
+environments."
+
+To model this agnosticism, the @code{jsonrpc} library uses objects of
+a @code{jsonrpc-connection} class, which represent a connection the
+remote JSON endpoint (for details on Emacs's object system,
+@pxref{Top,EIEIO,,eieio,EIEIO}). In modern object-oriented parlance,
+this class is ``abstract'', i.e. the actual class of a useful
+connection object used is always a subclass of it. Nevertheless, we
+can define two distinct API's around the @code{jsonrpc-connection}
+class:
+
+@enumerate
+
+@item A user interface for building JSONRPC applications
+
+In this scenario, the JSONRPC application selects a concrete subclass
+of @code{jsonrpc-connection}, and proceeds to create objects of that
+subclass using @code{make-instance}. To initiate a contact to the
+remote endpoint, the JSONRPC application passes this object to the
+functions @code{jsonrpc-notify'}, @code{jsonrpc-request} and
+@code{jsonrpc-async-request}. For handling remotely initiated
+contacts, which generally come in asynchronously, the instantiation
+should include @code{:request-dispatcher} and
+@code{:notification-dispatcher} initargs, which are both functions of
+3 arguments: the connection object; a symbol naming the JSONRPC method
+invoked remotely; and a JSONRPC "params" object.
+
+The function passed as @code{:request-dispatcher} is responsible for
+handling the remote endpoint's requests, which expect a reply from the
+local endpoint (in this case, the program you're building). Inside
+that function, you may either return locally (normally) or non-locally
+(error). A local return value must be a Lisp object serializable as
+JSON (@pxref{Parsing JSON}). This determines a success response, and
+the object is forwarded to the server as the JSONRPC "result" object.
+A non-local return, achieved by calling the function
+@code{jsonrpc-error}, causes an error response to be sent to the
+server. The details of the accompanying JSONRPC "error" are filled
+out with whatever was passed to @code{jsonrpc-error}. A non-local
+return triggered by an unexpected error of any other type also causes
+an error response to be sent (unless you have set
+@code{debug-on-error}, in which case this should land you in the
+debugger, @pxref{Error Debugging}).
+
+@item A inheritance interface for building JSONRPC transport implementations
+
+In this scenario, @code{jsonrpc-connection} is subclassed to implement
+a different underlying transport strategy (for details on how to
+subclass, @pxref{Inheritance,Inheritance,,eieio}). Users of the
+application-building interface can then instantiate objects of this
+concrete class (using the @code{make-instance} function) and connect
+to JSONRPC endpoints using that strategy.
+
+This API has mandatory and optional parts.
+
+To allow its users to initiate JSONRPC contacts (notifications or
+requests) or reply to endpoint requests, the method
+@code{jsonrpc-connection-send} must be implemented for the subclass.
+
+Likewise, for handling the three types of remote contacts (requests,
+notifications and responses to local requests) the transport
+implementation must arrange for the function
+@code{jsonrpc-connection-receive} to be called after noticing a new
+JSONRPC message on the wire (whatever that "wire" may be).
+
+Finally, and optionally, the @code{jsonrpc-connection} subclass should
+implement @code{jsonrpc-shutdown} and @code{jsonrpc-running-p} if
+these concepts apply to the transport. If they do, then any system
+resources (e.g. processes, timers, etc..) used listen for messages on
+the wire should be released in @code{jsonrpc-shutdown}, i.e. they
+should only be needed while @code{jsonrpc-running-p} is non-nil.
+
+@end enumerate
+
+@node Process-based JSONRPC connections
+@subsection Process-based JSONRPC connections
+
+For convenience, the @code{jsonrpc} library comes built-in with a
+@code{jsonrpc-process-connection} transport implementation that can
+talk to local subprocesses (using the standard input and standard
+output); or TCP hosts (using sockets); or any other remote endpoint
+that Emacs's process object can represent (@pxref{Processes}).
+
+Using this transport, the JSONRPC messages are encoded on the wire as
+plain text and prefaced by some basic HTTP-style enveloping headers,
+such as ``Content-Length''.
+
+For an example of an application using this transport scheme on top of
+JSONRPC, see the
+@uref{https://microsoft.github.io/language-server-protocol/specification,
+Language Server Protocol}.
+
+Along with the mandatory @code{:request-dispatcher} and
+@code{:notification-dispatcher} initargs, users of the
+@code{jsonrpc-process-connection} class should pass the following
+initargs as keyword-value pairs to @code{make-instance}:
+
+@table @code
+@item :process
+Value must be a live process object or a function of no arguments
+producing one such object. If passed a process object, that is
+expected to contain an pre-established connection; otherwise, the
+function is called immediately after the object is made.
+
+@item :on-shutdown
+Value must be a function of a single argument, the
+@code{jsonrpc-process-connection} object. The function is called
+after the underlying process object has been deleted (either
+deliberately by @code{jsonrpc-shutdown} or unexpectedly, because of
+some external cause).
+@end table
+
+@node JSONRPC JSON object format
+@subsection JSON object format
+
+JSON objects are exchanged as Lisp plists (@pxref{Parsing JSON}):
+JSON-compatible plists are handed to the dispatcher functions and,
+likewise, JSON-compatible plists should be given to
+@code{jsonrpc-notify}, @code{jsonrpc-request} and
+@code{jsonrpc-async-request}.
+
+To facilitate handling plists, this library make liberal use of
+@code{cl-lib} library and suggests (but doesn't force) its clients to
+do the same. A macro @code{jsonrpc-lambda} can be used to create a
+lambda for destructuring a JSON-object like in this example:
+
+@example
+(jsonrpc-async-request
+ myproc :frobnicate `(:foo "trix")
+ :success-fn (jsonrpc-lambda (&key bar baz &allow-other-keys)
+ (message "Server replied back with %s and %s!"
+ bar baz))
+ :error-fn (jsonrpc-lambda (&key code message _data)
+ (message "Sadly, server reports %s: %s"
+ code message)))
+@end example
+
+@node JSONRPC deferred requests
+@subsection Deferred requests
+
+In many @acronym{RPC} situations, synchronization between the two
+communicating endpoints is a matter of correctly designing the RPC
+application: when synchronization is needed, requests (which are
+blocking) should be used; when it isn't, notifications should suffice.
+However, when Emacs acts as one of these endpoints, asynchronous
+events (e.g. timer- or process-related) may be triggered while there
+is still uncertainty about the state of the remote endpoint.
+Furthermore, acting on these events may only sometimes demand
+synchronization, depending on the event's specific nature.
+
+The @code{:deferred} keyword argument to @code{jsonrpc-request} and
+@code{jsonrpc-async-request} is designed to let the caller indicate
+that the specific request needs synchronization and its actual
+issuance may be delayed to the future, until some condition is
+satisfied. Specifying @code{:deferred} for a request doesn't mean it
+@emph{will} be delayed, only that it @emph{can} be. If the request
+isn't sent immediately, @code{jsonrpc} will make renewed efforts to
+send it at certain key times during communication, such as when
+receiving or sending other messages to the endpoint.
+
+Before any attempt to send the request, the application-specific
+conditions are checked. Since the @code{jsonrpc} library can't known
+what these conditions are, the programmer may use the
+@code{jsonrpc-connection-ready-p} generic function (@pxref{Generic
+Functions}) to specify them. The default method for this function
+returns @code{t}, but you can add overriding methods that return
+@code{nil} in some situations, based on the arguments passed to it,
+which are the @code{jsonrpc-connection} object (@pxref{JSONRPC
+Overview}) and whichever value you passed as the @code{:deferred}
+keyword argument.
+
@node Atomic Changes
@section Atomic Change Groups
@cindex atomic changes
@@ -5049,8 +5525,8 @@ making. When that happens, the arguments to
individual changes are made, but won't necessarily be the minimal such
region, and the arguments to each successive call of
@code{after-change-functions} will then delimit the part of text being
-changed exactly. In general, we advise to use either before- or the
-after-change hooks, but not both.
+changed exactly. In general, we advise using either the before- or
+the after-change hook, but not both.
@defmac combine-after-change-calls body@dots{}
The macro executes @var{body} normally, but arranges to call the
@@ -5074,6 +5550,30 @@ because it may lead to inefficient behavior for some change hook
functions.
@end defmac
+@defmac combine-change-calls beg end body@dots{}
+This executes @var{body} normally, except any buffer changes it makes
+do not trigger the calls to @code{before-change-functions} and
+@code{after-change-functions}. Instead there is a single call of each
+of these hooks for the region enclosed by @var{beg} and @var{end}, the
+parameters supplied to @code{after-change-functions} reflecting the
+changes made to the size of the region by @var{body}.
+
+The result of this macro is the result returned by @var{body}.
+
+This macro is useful when a function makes a possibly large number of
+repetitive changes to the buffer, and the change hooks would otherwise
+take a long time to run, were they to be run for each individual
+buffer modification. Emacs itself uses this macro, for example, in
+the commands @code{comment-region} and @code{uncomment-region}.
+
+@strong{Warning:} You must not alter the values of
+@code{before-change-functions} or @code{after-change-function} within
+@var{body}.
+
+@strong{Warning:} You must not make any buffer changes outside of the
+region specified by @var{beg} and @var{end}.
+@end defmac
+
@defvar first-change-hook
This variable is a normal hook that is run whenever a buffer is changed
that was previously in the unmodified state.
diff --git a/doc/lispref/threads.texi b/doc/lispref/threads.texi
index 7b14ab5a730..db68f9192bd 100644
--- a/doc/lispref/threads.texi
+++ b/doc/lispref/threads.texi
@@ -45,6 +45,7 @@ closure are shared by any threads invoking the closure.
* Basic Thread Functions:: Basic thread functions.
* Mutexes:: Mutexes allow exclusive access to data.
* Condition Variables:: Inter-thread events.
+* The Thread List:: Show the active threads.
@end menu
@node Basic Thread Functions
@@ -75,8 +76,8 @@ thread, @code{nil} otherwise.
@defun thread-join thread
Block until @var{thread} exits, or until the current thread is
-signaled. If @var{thread} has already exited, this returns
-immediately.
+signaled. It returns the result of the @var{thread} function. If
+@var{thread} has already exited, this returns immediately.
@end defun
@defun thread-signal thread error-symbol data
@@ -87,6 +88,9 @@ thread, then this just calls @code{signal} immediately. Otherwise,
If @var{thread} was blocked by a call to @code{mutex-lock},
@code{condition-wait}, or @code{thread-join}; @code{thread-signal}
will unblock it.
+
+If @var{thread} is the main thread, the signal is not propagated
+there. Instead, it is shown as message in the main thread.
@end defun
@defun thread-yield
@@ -127,15 +131,21 @@ Return a list of all the live thread objects. A new list is returned
by each invocation.
@end defun
+@defvar main-thread
+This variable keeps the main thread Emacs is running, or @code{nil} if
+Emacs is compiled without thread support.
+@end defvar
+
When code run by a thread signals an error that is unhandled, the
thread exits. Other threads can access the error form which caused
the thread to exit using the following function.
-@defun thread-last-error
+@defun thread-last-error &optional cleanup
This function returns the last error form recorded when a thread
exited due to an error. Each thread that exits abnormally overwrites
the form stored by the previous thread's error with a new value, so
-only the last one can be accessed.
+only the last one can be accessed. If @var{cleanup} is
+non-@code{nil}, the stored form is reset to @code{nil}.
@end defun
@node Mutexes
@@ -262,3 +272,53 @@ Return the name of @var{cond}, as passed to
Return the mutex associated with @var{cond}. Note that the associated
mutex cannot be changed.
@end defun
+
+@node The Thread List
+@section The Thread List
+
+@cindex thread list
+@cindex list of threads
+@findex list-threads
+The @code{list-threads} command lists all the currently alive threads.
+In the resulting buffer, each thread is identified either by the name
+passed to @code{make-thread} (@pxref{Basic Thread Functions}), or by
+its unique internal identifier if it was not created with a name. The
+status of each thread at the time of the creation or last update of
+the buffer is shown, in addition to the object the thread was blocked
+on at the time, if it was blocked.
+
+@defvar thread-list-refresh-seconds
+The @file{*Threads*} buffer will automatically update twice per
+second. You can make the refresh rate faster or slower by customizing
+this variable.
+@end defvar
+
+Here are the commands available in the thread list buffer:
+
+@table @kbd
+
+@cindex backtrace of thread
+@cindex thread backtrace
+@item b
+Show a backtrace of the thread at point. This will show where in its
+code the thread had yielded or was blocked at the moment you pressed
+@kbd{b}. Be aware that the backtrace is a snapshot; the thread could
+have meanwhile resumed execution, and be in a different state, or
+could have exited.
+
+You may use @kbd{g} in the thread's backtrace buffer to get an updated
+backtrace, as backtrace buffers do not automatically update.
+@xref{Backtraces}, for a description of backtraces and the other
+commands which work on them.
+
+@item s
+Signal the thread at point. After @kbd{s}, type @kbd{q} to send a
+quit signal or @kbd{e} to send an error signal. Threads may implement
+handling of signals, but the default behavior is to exit on any
+signal. Therefore you should only use this command if you understand
+how to restart the target thread, because your Emacs session may
+behave incorrectly if necessary threads are killed.
+
+@item g
+Update the list of threads and their statuses.
+@end table
diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi
index f1e0e37e6d6..aca7d2f5e93 100644
--- a/doc/lispref/variables.texi
+++ b/doc/lispref/variables.texi
@@ -2191,9 +2191,9 @@ This function looks for connection-local variables according to
@var{criteria}, and immediately applies them in the current buffer.
@end defun
-@defmac with-connection-local-profiles profiles &rest body
-All connection-local variables, which are specified by a connection
-profile in @var{profiles}, are applied.
+@defmac with-connection-local-variables &rest body
+All connection-local variables, which are specified by
+@code{default-directory}, are applied.
After that, @var{body} is executed, and the connection-local variables
are unwound. Example:
@@ -2207,8 +2207,15 @@ are unwound. Example:
@end group
@group
-(with-connection-local-profiles '(remote-perl)
- do something useful)
+(connection-local-set-profiles
+ '(:application 'tramp :protocol "ssh" :machine "remotehost")
+ 'remote-perl)
+@end group
+
+@group
+(let ((default-directory "/ssh:remotehost:/working/dir/"))
+ (with-connection-local-variables
+ do something useful))
@end group
@end example
@end defmac
diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi
index f4395c12d26..32e8c2afa31 100644
--- a/doc/lispref/windows.texi
+++ b/doc/lispref/windows.texi
@@ -568,12 +568,6 @@ its pixel height is the pixel height of the screen areas spanned by its
children.
@end defun
-@defun window-pixel-height-before-size-change &optional Lisp_Object &optional window
-This function returns the height of window @var{window} in pixels at the
-time @code{window-size-change-functions} was run for the last time on
-@var{window}'s frame (@pxref{Window Hooks}).
-@end defun
-
@cindex window pixel width
@cindex pixel width of a window
@cindex total pixel width of a window
@@ -588,12 +582,6 @@ If @var{window} is an internal window, its pixel width is the width of
the screen areas spanned by its children.
@end defun
-@defun window-pixel-width-before-size-change &optional Lisp_Object &optional window
-This function returns the width of window @var{window} in pixels at the
-time @code{window-size-change-functions} was run for the last time on
-@var{window}'s frame (@pxref{Window Hooks}).
-@end defun
-
@cindex full-width window
@cindex full-height window
The following functions can be used to determine whether a given
@@ -1770,7 +1758,7 @@ raise the frame or make sure input focus is directed to that frame.
@xref{Input Focus}.
@end defun
-@cindex select window hook
+@cindex select window hooks
@cindex running a hook when a window gets selected
For historical reasons, Emacs does not run a separate hook whenever a
window gets selected. Applications and internal routines often
@@ -1786,8 +1774,8 @@ useful.
However, when its @var{norecord} argument is @code{nil},
@code{select-window} updates the buffer list and thus indirectly runs
the normal hook @code{buffer-list-update-hook} (@pxref{Buffer List}).
-Consequently, that hook provides a reasonable way to run a function
-whenever a window gets selected more ``permanently''.
+Consequently, that hook provides one way to run a function whenever a
+window gets selected more ``permanently''.
Since @code{buffer-list-update-hook} is also run by functions that are
not related to window management, it will usually make sense to save the
@@ -1799,6 +1787,13 @@ temporarily passes a non-@code{nil} @var{norecord} argument. If
possible, the macro @code{with-selected-window} (see below) should be
used in such cases.
+ Emacs also runs the hook @code{window-selection-change-functions}
+whenever the redisplay routine detects that another window has been
+selected since last redisplay. @xref{Window Hooks}, for a detailed
+explanation. @code{window-state-change-functions} (described in the
+same section) is another abnormal hook run after a different window
+has been selected but is triggered by other window changes as well.
+
@cindex most recently selected windows
The sequence of calls to @code{select-window} with a non-@code{nil}
@var{norecord} argument determines an ordering of windows by their
@@ -2269,6 +2264,12 @@ selected window or never appeared in it before, or if
buffer.
@end defopt
+@defopt switch-to-buffer-obey-display-actions
+If this variable is non-@code{nil}, @code{switch-to-buffer} respects
+display actions specified by @code{display-buffer-overriding-action},
+@code{display-buffer-alist} and other display related variables.
+@end defopt
+
The next two commands are similar to @code{switch-to-buffer}, except for
the described features.
@@ -2613,6 +2614,12 @@ suitable @code{window-height} or @code{window-width} entry, see above.
If splitting the selected window fails and there is a non-dedicated
window below the selected one showing some other buffer, this function
tries to use that window for showing @var{buffer}.
+
+If @var{alist} contains a @code{window-min-height} entry, this
+function ensures that the window used is or can become at least as
+high as specified by that entry's value. Note that this is only a
+guarantee. In order to actually resize the window used, @var{alist}
+must also provide an appropriate @code{window-height} entry.
@end defun
@defun display-buffer-at-bottom buffer alist
@@ -2796,6 +2803,22 @@ The value specifies an alist of window parameters to give the chosen
window. All action functions that choose a window should process this
entry.
+@vindex window-min-height@r{, a buffer display action alist entry}
+@item window-min-height
+The value specifies a minimum height of the window used, in lines. If
+a window is not or cannot be made as high as specified by this entry,
+the window is not considered for use. The only client of this entry
+is presently @code{display-buffer-below-selected}.
+
+Note that providing such an entry alone does not necessarily make the
+window as tall as specified by its value. To actually resize an
+existing window or make a new window as tall as specified by that
+value, a @code{window-height} entry specifying that value should be
+provided as well. Such a @code{window-height} entry can, however,
+specify a completely different value or ask the window height to be
+fit to that of its buffer in which case the @code{window-min-height}
+entry provides the guaranteed minimum height of the window used.
+
@vindex window-height@r{, a buffer display action alist entry}
@item window-height
The value specifies whether and how to adjust the height of the chosen
@@ -2859,6 +2882,13 @@ Frames}) to avoid changing the width of other, unrelated windows.
Also, this entry should be processed under only certain conditions
which are specified right below this list.
+@vindex dedicated@r{, a buffer display action alist entry}
+@item dedicated
+If non-@code{nil}, such an entry tells @code{display-buffer} to mark
+any window it creates as dedicated to its buffer (@pxref{Dedicated
+Windows}). It does that by calling @code{set-window-dedicated-p} with
+the chosen window as first argument and the entry's value as second.
+
@vindex preserve-size@r{, a buffer display action alist entry}
@item preserve-size
If non-@code{nil} such an entry tells Emacs to preserve the size of
@@ -3878,6 +3908,9 @@ display. Other functions do not treat @code{t} differently from any
non-@code{nil} value.
@end defun
+You can also tell @code{display-buffer} to mark a window it creates as
+dedicated to its buffer by providing a suitable @code{dedicated}
+action alist entry (@pxref{Buffer Display Action Alists}).
@node Quitting Windows
@section Quitting Windows
@@ -4889,6 +4922,13 @@ line reappears after the echo area momentarily displays the message
@samp{End of buffer}.
@end deffn
+@deffn Command scroll-other-window-down &optional count
+This function scrolls the text in another window downward @var{count}
+lines. Negative values of @var{count}, or @code{nil}, are handled as
+in @code{scroll-down}. In other respects, it behaves the same way as
+@code{scroll-other-window} does.
+@end deffn
+
@defvar other-window-scroll-buffer
If this variable is non-@code{nil}, it tells @code{scroll-other-window}
which buffer's window to scroll.
@@ -4991,7 +5031,7 @@ beginning or end of the buffer (depending on scrolling direction);
only if point is already on that position do they signal an error.
@end defopt
-@deffn Command recenter &optional count
+@deffn Command recenter &optional count redisplay
@cindex centering point
This function scrolls the text in the selected window so that point is
displayed at a specified vertical position within the window. It does
@@ -5005,8 +5045,12 @@ line in the window.
If @var{count} is @code{nil} (or a non-@code{nil} list),
@code{recenter} puts the line containing point in the middle of the
-window. If @var{count} is @code{nil}, this function may redraw the
-frame, according to the value of @code{recenter-redisplay}.
+window. If @var{count} is @code{nil} and @var{redisplay} is
+non-@code{nil}, this function may redraw the frame, according to the
+value of @code{recenter-redisplay}. Thus, omitting the second
+argument can be used to countermand the effect of
+@code{recenter-redisplay} being non-@code{nil}. Interactive calls
+pass non-‘nil’ for @var{redisplay}.
When @code{recenter} is called interactively, @var{count} is the raw
prefix argument. Thus, typing @kbd{C-u} as the prefix sets the
@@ -5034,8 +5078,9 @@ respect to the entire window group.
@defopt recenter-redisplay
If this variable is non-@code{nil}, calling @code{recenter} with a
-@code{nil} argument redraws the frame. The default value is
-@code{tty}, which means only redraw the frame if it is a tty frame.
+@code{nil} @var{count} argument and non-@code{nil} @var{redisplay}
+argument redraws the frame. The default value is @code{tty}, which
+means only redraw the frame if it is a tty frame.
@end defopt
@deffn Command recenter-top-bottom &optional count
@@ -5694,10 +5739,6 @@ prevent the code in @var{forms} from opening new windows, because new
windows might be opened in other frames (@pxref{Choosing Window}), and
@code{save-window-excursion} only saves and restores the window
configuration on the current frame.
-
-Do not use this macro in @code{window-size-change-functions}; exiting
-the macro triggers execution of @code{window-size-change-functions},
-leading to an endless loop.
@end defmac
@defun window-configuration-p object
@@ -5759,9 +5800,10 @@ This function puts the window state @var{state} into @var{window}.
The argument @var{state} should be the state of a window returned by
an earlier invocation of @code{window-state-get}, see above. The
optional argument @var{window} can be either a live window or an
-internal window (@pxref{Windows and Frames}) and defaults to the
-selected one. If @var{window} is not live, it is replaced by a live
-window before putting @var{state} into it.
+internal window (@pxref{Windows and Frames}). If @var{window} is not
+a live window, it is replaced by a new live window created on the same
+frame before putting @var{state} into it. If @var{window} is @code{nil},
+it puts the window state into a new window.
If the optional argument @var{ignore} is non-@code{nil}, it means to ignore
minimum window sizes and fixed-size restrictions. If @var{ignore}
@@ -5815,10 +5857,10 @@ This function sets @var{window}'s value of @var{parameter} to
is the selected window.
@end defun
-By default, the functions that save and restore window configurations or the
-states of windows (@pxref{Window Configurations}) do not care about
-window parameters. This means that when you change the value of a
-parameter within the body of a @code{save-window-excursion}, the
+By default, the functions that save and restore window configurations
+or the states of windows (@pxref{Window Configurations}) do not care
+about window parameters. This means that when you change the value of
+a parameter within the body of a @code{save-window-excursion}, the
previous value is not restored when that macro exits. It also means
that when you restore via @code{window-state-put} a window state saved
earlier by @code{window-state-get}, all cloned windows have their
@@ -5985,27 +6027,26 @@ applications. It might be replaced by an improved solution in future
versions of Emacs.
@end table
+
@node Window Hooks
@section Hooks for Window Scrolling and Changes
@cindex hooks for window operations
-This section describes how a Lisp program can take action whenever a
-window displays a different part of its buffer or a different buffer.
-There are three actions that can change this: scrolling the window,
-switching buffers in the window, and changing the size of the window.
-The first two actions run @code{window-scroll-functions}; the last runs
-@code{window-size-change-functions}.
+This section describes how Lisp programs can take action after a
+window has been scrolled or other window modifications occurred. We
+first consider the case where a window shows a different part of its
+buffer.
@defvar window-scroll-functions
This variable holds a list of functions that Emacs should call before
-redisplaying a window with scrolling. Displaying a different buffer in
-the window also runs these functions.
+redisplaying a window with scrolling. Displaying a different buffer
+in a window and making a new window also call these functions.
-This variable is not a normal hook, because each function is called with
-two arguments: the window, and its new display-start position. At the
-time of the call, the display-start position of the window argument is
-already set to its new value, and the buffer to be displayed in the
-window is already set as the current buffer.
+This variable is not a normal hook, because each function is called
+with two arguments: the window, and its new display-start position.
+At the time of the call, the display-start position of the argument
+window is already set to its new value, and the buffer to be displayed
+in the window is set as the current buffer.
These functions must take care when using @code{window-end}
(@pxref{Window Start and End}); if you need an up-to-date value, you
@@ -6016,55 +6057,294 @@ is scrolled. It's not designed for that, and such use probably won't
work.
@end defvar
-@defun run-window-scroll-functions &optional window
-This function calls @code{window-scroll-functions} for the specified
-@var{window}, which defaults to the selected window.
-@end defun
+In addition, you can use @code{jit-lock-register} to register a Font
+Lock fontification function, which will be called whenever parts of a
+buffer are (re)fontified because a window was scrolled or its size
+changed. @xref{Other Font Lock Variables}.
+
+@cindex window change functions
+ The remainder of this section covers six hooks that are called
+during redisplay provided a significant, non-scrolling change of a
+window has been detected. For simplicity, these hooks and the
+functions they call will be collectively referred to as @dfn{window
+change functions}.
+
+@cindex window buffer change
+The first of these hooks is run after a @dfn{window buffer change} is
+detected, which means that a window was created, deleted or assigned
+another buffer.
+
+@defvar window-buffer-change-functions
+This variable specifies functions called during redisplay when window
+buffers have changed. The value should be a list of functions that
+take one argument.
+
+Functions specified buffer-locally are called for any window showing
+the corresponding buffer if that window has been created or assigned
+that buffer since the last time window change functions were run. In
+this case the window is passed as argument.
+
+Functions specified by the default value are called for a frame if at
+least one window on that frame has been added, deleted or assigned
+another buffer since the last time window change functions were run.
+In this case the frame is passed as argument.
+@end defvar
+
+@cindex window size change
+The second of these hooks is run when a @dfn{window size change} has
+been detected which means that a window was created, assigned another
+buffer, or changed its total size or that of its text area.
@defvar window-size-change-functions
-This variable holds a list of functions to be called if the size of any
-window changes for any reason. The functions are called once per
-redisplay, and once for each frame on which size changes have occurred.
-
-Each function receives the frame as its sole argument. To find out
-whether a specific window has changed size, compare the return values of
-@code{window-pixel-width-before-size-change} and
-@code{window-pixel-width} respectively
-@code{window-pixel-height-before-size-change} and
-@code{window-pixel-height} for that window (@pxref{Window Sizes}).
-
-These function are usually only called when at least one window was
-added or has changed size since the last time this hook was run for
-the associated frame. In some rare cases this hook also runs when a
-window that was added intermittently has been deleted afterwards. In
-these cases none of the windows on the frame will appear to have
-changed its size.
+This variable specifies functions called during redisplay when a
+window size change occurred. The value should be a list of functions
+that take one argument.
+
+Functions specified buffer-locally are called for any window showing
+the corresponding buffer if that window has been added or assigned
+another buffer or changed its total or body size since the last time
+window change functions were run. In this case the window is passed
+as argument.
+
+Functions specified by the default value are called for a frame if at
+least one window on that frame has been added or assigned another
+buffer or changed its total or body size since the last time window
+change functions were run. In this case the frame is passed as
+argument.
+@end defvar
+
+@cindex window selection change
+The third of these hooks is run when a @dfn{window selection change}
+has selected another window since the last redisplay.
+
+@defvar window-selection-change-functions
+This variable specifies functions called during redisplay when the
+selected window or a frame's selected window has changed. The value
+should be a list of functions that take one argument.
+
+Functions specified buffer-locally are called for any window showing
+the corresponding buffer if that window has been selected or
+deselected (among all windows or among all windows on its frame) since
+the last time window change functions were run. In this case the
+window is passed as argument.
+
+Functions specified by the default value are called for a frame if
+that frame has been selected or deselected or the frame's selected
+window has changed since the last time window change functions were
+run. In this case the frame is passed as argument.
+@end defvar
+
+@cindex window state change
+The fourth of these hooks is run when a @dfn{window state change} has
+been detected, which means that at least one of the three preceding
+window changes has occurred.
+
+@defvar window-state-change-functions
+This variable specifies functions called during redisplay when a
+window buffer or size change occurred or the selected window or a
+frame's selected window has changed. The value should be a list of
+functions that take one argument.
+
+Functions specified buffer-locally are called for any window showing
+the corresponding buffer if that window has been added or assigned
+another buffer, changed its total or body size or has been selected or
+deselected (among all windows or among all windows on its frame) since
+the last time window change functions were run. In this case the
+window is passed as argument.
+
+Functions specified by the default value are called for a frame if at
+least one window on that frame has been added, deleted or assigned
+another buffer, changed its total or body size or that frame has been
+selected or deselected or the frame's selected window has changed
+since the last time window change functions were run. In this case
+the frame is passed as argument.
+
+Functions specified by the default value are also run for a frame when
+that frame's window state change flag (see below) has been set since
+last redisplay.
@end defvar
+@cindex window configuration change
+The fifth of these hooks is run when a @dfn{window configuration
+change} has been detected which means that either the buffer or the
+size of a window changed. It differs from the four preceding hooks in
+the way it is run.
+
@defvar window-configuration-change-hook
-A normal hook that is run every time the window configuration of a
-frame changes. Window configuration changes include splitting and
-deleting windows, and the display of a different buffer in a window.
-
-The hook can be also used for tracking changes of window sizes. It
-is, however, not run when the size of a frame changes or automatic
-resizing of a minibuffer window (@pxref{Minibuffer Windows}) changes
-the size of another window. As a rule, adding a function to
-@code{window-size-change-functions}, see above, is the recommended way
-for reliably tracking size changes of any window.
-
-The buffer-local value of this hook is run once for each window on the
-affected frame, with the relevant window selected and its buffer
-current. The global value of this hook is run once for the modified
-frame, with that frame selected.
+This variable specifies functions called during redisplay when either
+the buffer or the size of a window has changed. The value should be a
+list of functions that take no argument.
+
+Functions specified buffer-locally are called for any window showing
+the corresponding buffer if at least one window on that frame has been
+added, deleted or assigned another buffer or changed its total or
+body size since the last time window change functions were run. Each
+call is performed with the window showing the buffer temporarily
+selected and its buffer current.
+
+Functions specified by the default value are called for each frame if
+at least one window on that frame has been added, deleted or assigned
+another buffer or changed its total or body size since the last time
+window change functions were run. Each call is performed with the
+frame temporarily selected and the selected window's buffer current.
+@end defvar
+
+Finally, Emacs runs a normal hook that generalizes the behavior of
+@code{window-state-change-functions}.
+
+@defvar window-state-change-hook
+The default value of this variable specifies functions called during
+redisplay when a window state change has been detected or the window
+state change flag has been set on at least one frame. The value
+should be a list of functions that take no argument.
+
+Applications should put a function on this hook only if they want to
+react to changes that happened on (or have been signaled for) two or
+more frames since last redisplay. In every other case, putting the
+function on @code{window-state-change-functions} should be preferred.
@end defvar
-@defun run-window-configuration-change-hook &optional frame
-This function runs @code{window-configuration-change-hook} for the
-specified @var{frame}, which defaults to the selected frame.
+Window change functions are called during redisplay for each frame as
+follows: First, any buffer-local window buffer change function, window
+size change function, selected window change and window state change
+functions are called in this order. Next, the default values for
+these functions are called in the same order. Then any buffer-local
+window configuration change functions are called followed by functions
+specified by the default value of those functions. Finally, functions
+on @code{window-state-change-hook} are run.
+
+ Window change functions are run for a specific frame only if a
+corresponding change was registered for that frame earlier. Such
+changes include the creation or deletion of a window or the assignment
+of another buffer or size to a window. Note that even when such a
+change has been registered, this does not mean that any of the hooks
+described above is run. If, for example, a change was registered
+within the scope of a window excursion (@pxref{Window
+Configurations}), this will trigger a call of window change functions
+only if that excursion still persists at the time change functions are
+run. If it is exited earlier, hooks will be run only if registered by
+a change outside the scope of that excursion.
+
+@cindex window state change flag
+ The @dfn{window state change flag} of a frame, if set, will cause
+the default values of @code{window-state-change-functions} (for that
+frame) and @code{window-state-change-hook} to be run during next
+redisplay regardless of whether a window state change actually
+occurred for that frame or not. After running any functions on these
+hooks, the flag is reset for each frame. Applications can set that
+flag and inspect its value using the following functions.
+
+@defun set-frame-window-state-change &optional frame arg
+This function sets @var{frame}'s window state change flag if @var{arg}
+is non-@code{nil} and resets it otherwise. @var{frame} must be a live
+frame and defaults to the selected one.
@end defun
- In addition, you can use @code{jit-lock-register} to register a Font
-Lock fontification function, which will be called whenever parts of a
-buffer are (re)fontified because a window was scrolled or its size
-changed. @xref{Other Font Lock Variables}.
+@defun frame-window-state-change &optional frame
+This functions returns @code{t} if @var{frame}'s window state change
+flag is set and @code{nil} otherwise. @var{frame} must be a live
+frame and defaults to the selected one.
+@end defun
+
+ While window change functions are run, the functions described next
+can be called to get more insight into what has changed for a specific
+window or frame since the last redisplay. All these functions take a
+live window as single, optional argument, defaulting to the selected
+window.
+
+@defun window-old-buffer &optional window
+This function returns the buffer shown in @var{window} at the last
+time window change functions were run for @var{window}'s frame. If it
+returns @code{nil}, @var{window} has been created after that. If it
+returns @code{t}, @var{window} was not shown at that time but has been
+restored from a previously saved window configuration afterwards.
+Otherwise, the return value is the buffer shown by @code{window} at
+that time.
+@end defun
+
+@defun window-old-pixel-width &optional window
+This function returns the total pixel width of @var{window} the
+last time window change functions found @code{window} live on its
+frame. It is zero if @code{window} was created after that.
+@end defun
+
+@defun window-old-pixel-height &optional window
+This function returns the total pixel height of @var{window} the last
+time window change functions found @code{window} live on its frame.
+It is zero if @code{window} was created after that.
+@end defun
+
+@defun window-old-body-pixel-width &optional window
+This function returns the pixel width of @var{window}'s text area the
+last time window change functions found @code{window} live on its
+frame. It is zero if @code{window} was created after that.
+@end defun
+
+@defun window-old-body-pixel-height &optional window
+This function returns the pixel height of @var{window}'s text area the
+last time window change functions found @code{window} live on its
+frame. It is zero if @code{window} was created after that.
+@end defun
+
+In order to find out which window or frame was selected the last time
+window change functions were run, the following functions can be used:
+
+@defun frame-old-selected-window &optional frame
+This function returns the selected window of @var{frame} at the last
+time window change functions were run. If omitted or @code{nil}
+@var{frame} defaults to the selected frame.
+@end defun
+
+@defun old-selected-window
+This function returns the selected window at the last time window
+change functions were run.
+@end defun
+
+@defun old-selected-frame
+This function returns the selected frame at the last time window
+change functions were run.
+@end defun
+
+Note that window change functions provide no information about which
+windows have been deleted since the last time they were run. If
+necessary, applications should remember any window showing a specific
+buffer in a local variable of that buffer and update it in a function
+run by the default values of any of the hooks that are run when a
+window buffer change was detected.
+
+ The following caveats should be considered when adding a function
+to window change functions:
+
+@itemize @bullet
+@item
+Some operations will not trigger a call of window change functions.
+These include showing another buffer in a minibuffer window or any
+change of a tooltip window.
+
+@item
+Window change functions should not create or delete windows or change
+the buffer, size or selection status of any window because there is no
+guarantee that the information about such a change will be propagated
+to other window change functions. If at all, any such change should
+be executed only by the last function listed by the default value of
+@code{window-state-change-hook}.
+
+@item
+Macros like @code{save-window-excursion}, @code{with-selected-window}
+or @code{with-current-buffer} can be used when running window change
+functions.
+
+@item
+Running window change functions does not save and restore match data.
+Unless running @code{window-configuration-change-hook} it does not
+save or restore the selected window or frame or the current buffer
+either.
+
+@item
+Any redisplay triggering the run of window change functions may be
+aborted. If the abort occurs before window change functions have run
+to their completion, they will be run again with the previous values,
+that is, as if redisplay had not been performed. If aborted later,
+they will be run with the new values, that is, as if redisplay had
+been actually performed.
+@end itemize
diff --git a/doc/man/emacsclient.1 b/doc/man/emacsclient.1
index 5aaa6d1f083..24ca1c9a468 100644
--- a/doc/man/emacsclient.1
+++ b/doc/man/emacsclient.1
@@ -94,6 +94,7 @@ open a new Emacs frame on the current terminal
.TP
.B \-s, \-\-socket-name=FILENAME
use socket named FILENAME for communication.
+This can also be specified via the EMACS_SOCKET_NAME environment variable.
.TP
.B \-V, \-\-version
print version information and exit
diff --git a/doc/man/etags.1 b/doc/man/etags.1
index 57120e78dda..7cc501cc496 100644
--- a/doc/man/etags.1
+++ b/doc/man/etags.1
@@ -145,7 +145,7 @@ May be used (only once) in place of a file name on the command line.
\fBetags\fP will read from standard input and mark the produced tags
as belonging to the file \fBFILE\fP.
.TP
-\fB \-Q, \-\-class\-qualify\fP
+\fB\-Q, \-\-class\-qualify\fP
Qualify tag names with their class name in C++, ObjC, Java, and Perl.
This produces tag names of the form \fIclass\fP\fB::\fP\fImember\fP
for C++ and Perl,
diff --git a/doc/misc/Makefile.in b/doc/misc/Makefile.in
index d02f42bbeb9..a03efaf8bef 100644
--- a/doc/misc/Makefile.in
+++ b/doc/misc/Makefile.in
@@ -224,13 +224,13 @@ ${buildinfodir}/tramp.info tramp.html: ${srcdir}/trampver.texi
.PHONY: mostlyclean clean distclean bootstrap-clean maintainer-clean
mostlyclean:
- rm -f *.aux *.log *.toc *.c[mp] *.c[mp]s *.fn *.fns \
- *.ky *.kys *.op *.ops *.p[gj] *.p[gj]s *.sc *.scs *.ss \
- *.t[gp] *.t[gp]s *.vr *.vrs
+ rm -f ./*.aux ./*.log ./*.toc ./*.c[mp] ./*.c[mp]s ./*.fn ./*.fns \
+ ./*.ky ./*.kys ./*.op ./*.ops ./*.p[gj] ./*.p[gj]s ./*.sc ./*.scs ./*.ss \
+ ./*.t[gp] ./*.t[gp]s ./*.vr ./*.vrs
rm -f gnustmp*
clean: mostlyclean
- rm -f *.dvi *.html *.pdf *.ps
+ rm -f ./*.dvi ./*.html ./*.pdf ./*.ps
distclean: clean
rm -f Makefile
diff --git a/doc/misc/auth.texi b/doc/misc/auth.texi
index e467fc135f3..a46e3d73fce 100644
--- a/doc/misc/auth.texi
+++ b/doc/misc/auth.texi
@@ -1,7 +1,5 @@
\input texinfo @c -*-texinfo-*-
-@include gnus-overrides.texi
-
@set VERSION 0.3
@setfilename ../../info/auth.info
@@ -86,7 +84,7 @@ password (known as the secret).
Similarly, the auth-source library supports multiple storage backend,
currently either the classic ``netrc'' backend, examples of which you
-can see later in this document, the Secret Service API, and pass, the
+can see later in this document, JSON files, the Secret Service API, and pass, the
standard unix password manager. This is done with EIEIO-based
backends and you can write your own if you want.
@@ -109,6 +107,15 @@ The @code{user} is the user name. It's known as @var{:user} in
@code{auth-source-search} queries. You can also use @code{login} and
@code{account}.
+You can also use this file to specify client certificates to use when
+setting up TLS connections. The format is:
+@example
+machine @var{mymachine} port @var{myport} key @var{key} cert @var{cert}
+@end example
+
+@var{key} and @var{cert} are filenames containing the key and
+certificate to use respectively.
+
You can use spaces inside a password or other token by surrounding the
token with either single or double quotes.
@@ -169,6 +176,9 @@ get fancy, the default and simplest configuration is:
;;; use pass (@file{~/.password-store})
;;; (@pxref{The Unix password store})
(setq auth-sources '(password-store))
+;;; JSON data in format [@{ "machine": "SERVER",
+;;; "login": "USER", "password": "PASSWORD" @}...]
+(setq auth-sources '("~/.authinfo.json.gpg"))
@end lisp
By adding multiple entries to @code{auth-sources} with a particular
@@ -235,6 +245,16 @@ don't use a port entry, you match any Tramp method, as explained
earlier. Since Tramp has about 88 connection methods, this may be
necessary if you have an unusual (see earlier comment on those) setup.
+The netrc format is directly translated into JSON, if you are into
+that sort of thing. Just point to a JSON file with entries like this:
+
+@example
+[
+ @{ "machine": "yourmachine.com", "port": "http",
+ "login": "testuser", "password": "testpass" @}
+]
+@end example
+
@node Multiple GMail accounts with Gnus
@chapter Multiple GMail accounts with Gnus
@@ -335,25 +355,36 @@ Returns all the item labels of @var{collection} as a list.
@defun secrets-create-item collection item password &rest attributes
This function creates a new item in @var{collection} with label
-@var{item} and password @var{password}. @var{attributes} are
-key-value pairs set for the created item. The keys are keyword
-symbols, starting with a colon. Example:
+@var{item} and password @var{password}. The label @var{item} does not
+have to be unique in @var{collection}. @var{attributes} are key-value
+pairs set for the created item. The keys are keyword symbols,
+starting with a colon. Example:
@example
-;;; The session "session", the label is "my item"
-;;; and the secret (password) is "geheim"
+;;; The session is "session", the label is "my item"
+;;; and the secret (password) is "geheim".
(secrets-create-item "session" "my item" "geheim"
:method "sudo" :user "joe" :host "remote-host")
@end example
+
+The key @code{:xdg:schema} determines the scope of the item to be
+generated, i.e.@: for which applications the item is intended for.
+This is just a string like "org.freedesktop.NetworkManager.Mobile" or
+"org.gnome.OnlineAccounts", the other required keys are determined by
+this. If no @code{:xdg:schema} is given,
+"org.freedesktop.Secret.Generic" is used by default.
@end defun
@defun secrets-get-secret collection item
-Return the secret of item labeled @var{item} in @var{collection}.
-If there is no such item, return @code{nil}.
+Return the secret of item labeled @var{item} in @var{collection}. If
+there are several items labeled @var{item}, it is undefined which one
+is returned. If there is no such item, return @code{nil}.
@end defun
@defun secrets-delete-item collection item
-This function deletes item @var{item} in @var{collection}.
+This function deletes item @var{item} in @var{collection}. If there
+are several items labeled @var{item}, it is undefined which one is
+deleted.
@end defun
The lookup attributes, which are specified during creation of a
@@ -363,18 +394,20 @@ from a given secret item and they can be used for searching of items.
@defun secrets-get-attribute collection item attribute
Returns the value of key @var{attribute} of item labeled @var{item} in
-@var{collection}. If there is no such item, or the item doesn't own
-this key, the function returns @code{nil}.
+@var{collection}. If there are several items labeled @var{item}, it
+is undefined which one is returned. If there is no such item, or the
+item doesn't own this key, the function returns @code{nil}.
@end defun
@defun secrets-get-attributes collection item
Return the lookup attributes of item labeled @var{item} in
-@var{collection}. If there is no such item, or the item has no
-attributes, it returns @code{nil}. Example:
+@var{collection}. If there are several items labeled @var{item}, it
+is undefined which one is returned. If there is no such item, or the
+item has no attributes, it returns @code{nil}. Example:
@example
(secrets-get-attributes "session" "my item")
- @result{} ((:user . "joe") (:host ."remote-host"))
+ @result{} ((:user . "joe") (:host . "remote-host"))
@end example
@end defun
diff --git a/doc/misc/calc.texi b/doc/misc/calc.texi
index 7cfb7e1f0b2..ca322f21720 100644
--- a/doc/misc/calc.texi
+++ b/doc/misc/calc.texi
@@ -32717,7 +32717,7 @@ create an intermediate set.
(while (> n 0)
(if (oddp n)
(setq count (1+ count)))
- (setq n (lsh n -1)))
+ (setq n (ash n -1)))
count))
@end smallexample
@@ -32761,7 +32761,7 @@ routines are especially fast when dividing by an integer less than
(let ((count 0))
(while (> n 0)
(setq count (+ count (logand n 1))
- n (lsh n -1)))
+ n (ash n -1)))
count))
@end smallexample
@@ -32774,7 +32774,7 @@ uses.
The @code{idivmod} function does an integer division, returning both
the quotient and the remainder at once. Again, note that while it
-might seem that @samp{(logand n 511)} and @samp{(lsh n -9)} are
+might seem that @samp{(logand n 511)} and @samp{(ash n -9)} are
more efficient ways to split off the bottom nine bits of @code{n},
actually they are less efficient because each operation is really
a division by 512 in disguise; @code{idivmod} allows us to do the
diff --git a/doc/misc/cc-mode.texi b/doc/misc/cc-mode.texi
index 0102a4ace87..f73a7fb57cb 100644
--- a/doc/misc/cc-mode.texi
+++ b/doc/misc/cc-mode.texi
@@ -5638,9 +5638,9 @@ any problems writing custom line-up functions for AWK mode.
The calling convention for line-up functions is described fully in
@ref{Custom Line-Up}. Roughly speaking, the return value is either an
-offset itself (such as @code{+} or @code{[0]}) or it's @code{nil},
-meaning ``this function is inappropriate in this case; try a
-different one''. @xref{c-offsets-alist}.
+offset itself (such as @code{+} or @code{[0]}), another line-up
+function, or it's @code{nil}, meaning ``this function is inappropriate
+in this case - try a different one''. @xref{c-offsets-alist}.
The subsections below describe all the standard line-up functions,
categorized by the sort of token the lining-up centers around. For
@@ -5995,6 +5995,125 @@ brace block.
@comment ------------------------------------------------------------
+@defun c-lineup-2nd-brace-entry-in-arglist
+@findex lineup-2nd-brace-entry-in-arglist (c-)
+Line up the second entry of a brace block under the first, when the
+first line is also contained in an arglist or an enclosing brace
+@emph{on that line}.
+
+I.e. handle something like the following:
+
+@example
+@group
+set_line (line_t @{point_t@{0.4, 0.2@},
+ point_t@{0.2, 0.5@}, @hereFn{brace-list-intro}
+ .....@});
+ ^ enclosing parenthesis.
+@end group
+@end example
+
+
+The middle line of that example will have a syntactic context with
+three syntactic symbols, @code{arglist-cont-nonempty},
+@code{brace-list-intro}, and @code{brace-list-entry} (@pxref{Brace
+List Symbols}).
+
+This function is intended for use in a list. If the construct being
+analyzed isn't like the preceding, the function returns nil.
+Otherwise it returns the function
+@code{c-lineup-arglist-intro-after-paren}, which the caller then uses
+to perform indentation.
+
+@workswith{} @code{brace-list-intro}.
+@end defun
+
+@comment ------------------------------------------------------------
+
+@defun c-lineup-class-decl-init-+
+@findex lineup-class-decl-init-+ (c-)
+Line up the second entry of a class (etc.) initializer
+@code{c-basic-offset} characters in from the identifier when:
+@enumerate
+@item
+The type is a class, struct, union, etc. (but not an enum);
+@item
+There is a brace block in the type declaration, specifying it; and
+@item
+The first element of the initializer is on the same line as its
+opening brace.
+@end enumerate
+
+I.e. we have a construct like this:
+
+@example
+@group
+struct STR @{
+ int i; float f;
+@} str_1 = @{1, 1.7@},
+ str_2 = @{2,
+ 3.1 @hereFn{brace-list-intro}
+ @};
+ @sssTBasicOffset{}
+@end group
+@end example
+
+
+Note that the syntactic context of the @code{brace-list-intro} line
+also has a syntactic element with the symbol @code{brace-list-entry}
+(@pxref{Brace List Symbols}).
+
+This function is intended for use in a list. If the above structure
+isn't present, the function returns nil, allowing a different offset
+specification to indent the line.
+
+@workswith{} @code{brace-list-intro}.
+@end defun
+
+@comment ------------------------------------------------------------
+
+@defun c-lineup-class-decl-init-after-brace
+@findex lineup-class-decl-init-after-brace (c-)
+Line up the second entry of a class (etc.) initializer after its
+opening brace when:
+@enumerate
+@item
+The type is a class, struct, union, etc. (but not an enum);
+@item
+There is a brace block in the type declaration, specifying it; and
+@item
+The first element of the initializer is on the same line as its
+opening brace.
+@end enumerate
+
+I.e. we have a construct like this:
+
+@example
+@group
+struct STR @{
+ int i; float f;
+@} str_1 = @{1, 1.7@},
+ str_2 = @{2,
+ 3.1 @hereFn{brace-list-intro}
+ @};
+@end group
+@end example
+
+
+Note that the syntactic context of the @code{brace-list-intro} line
+also has a syntactic element with the symbol @code{brace-list-entry}
+(@pxref{Brace List Symbols}). Also note that this function works by
+returning the symbol @code{c-lineup-arglist-intro-after-paren}, which
+the caller then uses to perform the indentation.
+
+This function is intended for use in a list. If the above structure
+isn't present, the function returns nil, allowing a different offset
+specification to indent the line.
+
+@workswith{} @code{brace-list-intro}.
+@end defun
+
+@comment ------------------------------------------------------------
+
@defun c-lineup-multi-inher
@findex lineup-multi-inher @r{(c-)}
Line up the classes in C++ multiple inheritance clauses and member
diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi
index 6ce0b72aa5f..eb06791ba90 100644
--- a/doc/misc/cl.texi
+++ b/doc/misc/cl.texi
@@ -784,7 +784,7 @@ default. Some examples:
(cl-deftype null () '(satisfies null)) ; predefined
(cl-deftype list () '(or null cons)) ; predefined
(cl-deftype unsigned-byte (&optional bits)
- (list 'integer 0 (if (eq bits '*) bits (1- (lsh 1 bits)))))
+ (list 'integer 0 (if (eq bits '*) bits (1- (ash 1 bits)))))
(unsigned-byte 8) @equiv{} (integer 0 255)
(unsigned-byte) @equiv{} (integer 0 *)
unsigned-byte @equiv{} (integer 0 *)
@@ -1709,9 +1709,9 @@ but surrounds the loop with an implicit @code{nil} block.
The body is executed with @var{var} bound to the integers
from zero (inclusive) to @var{count} (exclusive), in turn. Then
@c FIXME lispref does not state this part explicitly, could move this there.
-the @code{result} form is evaluated with @var{var} bound to the total
+the @var{result} form is evaluated with @var{var} bound to the total
number of iterations that were done (i.e., @code{(max 0 @var{count})})
-to get the return value for the loop form.
+to get the return value for the loop form. Use of @var{result} is deprecated.
@end defmac
@defmac cl-do-symbols (var [obarray [result]]) forms@dots{}
@@ -4149,7 +4149,7 @@ package, @code{cl-typep} simply looks for a function called
only if they used the default predicate name.
@item :include
-This option implements a very limited form of C++-style inheritance.
+This option implements a very limited form of C@t{++}-style inheritance.
The argument is the name of another structure type previously
created with @code{cl-defstruct}. The effect is to cause the new
structure type to inherit all of the included structure's slots
@@ -4194,6 +4194,10 @@ of a @code{person}, plus extra slots that are specific to
astronauts. Operations that work on people (like @code{person-name})
work on astronauts just like other people.
+@item :noinline
+If this option is present, this structure's functions will not be
+inlined, even functions that normally would.
+
@item :print-function
In full Common Lisp, this option allows you to specify a function
that is called to print an instance of the structure type. The
diff --git a/doc/misc/dired-x.texi b/doc/misc/dired-x.texi
index c2630e6be66..b6a9d23f7dc 100644
--- a/doc/misc/dired-x.texi
+++ b/doc/misc/dired-x.texi
@@ -92,7 +92,6 @@ For @file{dired-x.el} as distributed with GNU Emacs @value{EMACSVER}.
* Introduction::
* Installation::
* Omitting Files in Dired::
-* Local Variables::
* Shell Command Guessing::
* Virtual Dired::
* Advanced Mark Commands::
@@ -478,77 +477,6 @@ Loading @file{dired-x.el} will install Dired Omit by putting
call @code{dired-extra-startup}, which in turn calls @code{dired-omit-startup}
in your @code{dired-mode-hook}.
-@node Local Variables
-@chapter Local Variables for Dired Directories
-
-@cindex Local Variables for Dired Directories
-@vindex dired-local-variables-file
-@vindex dired-enable-local-variables
-@noindent
-This Dired-X feature is obsolete as of Emacs 24.1. The standard Emacs
-directory local variables mechanism (@pxref{Directory
-Variables,,,emacs,The GNU Emacs manual}) replaces it. For an example of
-the new mechanisms, @pxref{Omitting Variables}.
-
-When Dired visits a directory, it looks for a file whose name is the
-value of variable @code{dired-local-variables-file} (default: @file{.dired}).
-If such a file is found, Dired will temporarily insert it into the Dired
-buffer and run @code{hack-local-variables}.
-
-@noindent
-For example, if the user puts
-
-@example
-Local Variables:
-dired-actual-switches: "-lat"
-dired-omit-mode: t
-End:
-@end example
-
-@noindent
-into a file called @file{.dired} in a directory then when that directory is
-viewed it will be
-
-@enumerate
-@item
-sorted by date
-@item
-omitted automatically
-@end enumerate
-
-@noindent
-You can set @code{dired-local-variables-file} to @code{nil} to suppress this.
-The value of @code{dired-enable-local-variables} controls if and how these
-local variables are read. This variable exists so that it may override the
-default value of @code{enable-local-variables}.
-
-@noindent
-Please see the GNU Emacs Manual to learn more about local variables.
-@xref{File Variables,Local Variables in Files,Local Variables in
-Files,emacs,The GNU Emacs Manual}.
-
-@noindent
-The following variables affect Dired Local Variables
-
-@table @code
-@vindex dired-local-variables-file
-@item dired-local-variables-file
-Default: @code{".dired"}
-
-If non-@code{nil}, file name for local variables for Dired. If Dired finds a
-file with that name in the current directory, it will temporarily insert it
-into the Dired buffer and run @code{hack-local-variables}.
-
-@vindex dired-enable-local-variables
-@item dired-enable-local-variables
-Default: @code{t}
-
-Controls the use of local-variables lists in Dired. This variable
-temporarily overrides the value of @code{enable-local-variables} when
-the Dired Local Variables are hacked. It takes the same values as that
-variable. A value of @code{nil} means to ignore any Dired Local Variables.
-@end table
-
@node Shell Command Guessing
@chapter Shell Command Guessing
@cindex Guessing shell commands for files.
diff --git a/doc/misc/ede.texi b/doc/misc/ede.texi
index 4edb53d9533..7ab386c97a4 100644
--- a/doc/misc/ede.texi
+++ b/doc/misc/ede.texi
@@ -1824,7 +1824,7 @@ This class implements the @code{ede-cpp-root} project type.
@table @code
@item :include-path
Type: @code{list} @*
-Default Value: @code{(quote ("/include" "../include/"))}
+Default Value: @code{("/include" "../include/")}
The default locate function expands filenames within a project.
If a header file (.h, .hh, etc.)@: name is expanded, and
@@ -2262,14 +2262,14 @@ The variable GNUSTEP_INSTALLATION_DOMAIN is set at this value.
@item :preamble
Type: @code{(or null list)} @*
-Default Value: @code{(quote ("GNUmakefile.preamble"))}
+Default Value: @code{("GNUmakefile.preamble")}
The auxiliary makefile for additional variables.
Included just before the specific target files.
@item :postamble
Type: @code{(or null list)} @*
-Default Value: @code{(quote ("GNUmakefile.postamble"))}
+Default Value: @code{("GNUmakefile.postamble")}
The auxiliary makefile for additional rules.
Included just after the specific target files.
diff --git a/doc/misc/ediff.texi b/doc/misc/ediff.texi
index 443aae3dbd5..c4ef1da3158 100644
--- a/doc/misc/ediff.texi
+++ b/doc/misc/ediff.texi
@@ -1147,7 +1147,7 @@ file (unlike what the @code{patch} utility would usually do). Instead, the
source file retains its name and the result of applying the patch is placed
in a temporary file that has the suffix @file{_patched} attached.
Generally, this applies to files that are handled using black magic, such
-as special file handlers (ange-ftp and some compression and encryption
+as special file name handlers (ange-ftp and some compression and encryption
packages also use this method).
Regular files are treated by the @code{patch} utility in the usual manner,
diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi
index 4c0d17f9a7b..485776e1c73 100644
--- a/doc/misc/efaq.texi
+++ b/doc/misc/efaq.texi
@@ -1570,38 +1570,68 @@ exhibits all the colors Emacs knows about on the current display.
Syntax highlighting is on by default since version 22.1.
+@cindex direct color in terminals
Emacs 26.1 and later support direct color mode in terminals. If Emacs
finds Terminfo capabilities @samp{setb24} and @samp{setf24}, 24-bit
direct color mode is used. The capability strings are expected to
take one 24-bit pixel value as argument and transform the pixel to a
string that can be used to send 24-bit colors to the terminal.
-There aren't yet any standard terminal type definitions that would
-support the capabilities, but Emacs can be invoked with a custom
-definition as shown below.
+Standard terminal definitions don't support these capabilities and
+therefore custom definition is needed.
@example
-$ cat terminfo-24bit.src
+$ cat terminfo-custom.src
-# Use colon separators.
-xterm-24bit|xterm with 24-bit direct color mode,
+xterm-emacs|xterm with 24-bit direct color mode for Emacs,
use=xterm-256color,
- setb24=\E[48:2:%p1%@{65536@}%/%d:%p1%@{256@}%/%@{255@}%&%d:%p1%@{255@}%&%dm,
- setf24=\E[38:2:%p1%@{65536@}%/%d:%p1%@{256@}%/%@{255@}%&%d:%p1%@{255@}%&%dm,
-# Use semicolon separators.
-xterm-24bits|xterm with 24-bit direct color mode,
- use=xterm-256color,
- setb24=\E[48;2;%p1%@{65536@}%/%d;%p1%@{256@}%/%@{255@}%&%d;%p1%@{255@}%&%dm,
- setf24=\E[38;2;%p1%@{65536@}%/%d;%p1%@{256@}%/%@{255@}%&%d;%p1%@{255@}%&%dm,
+ setb24=\E[48\:2\:\:%p1%@{65536@}%/%d\:%p1%@{256@}%/%@{255@}%&\
+ %d\:%p1%@{255@}%&%dm,
+ setf24=\E[38\:2\:\:%p1%@{65536@}%/%d\:%p1%@{256@}%/%@{255@}%&\
+ %d\:%p1%@{255@}%&%dm,
+
+$ tic -x -o ~/.terminfo terminfo-custom.src
+
+$ TERM=xterm-emacs emacs -nw
+@end example
+
+@cindex 24-bit direct color mode
+Emacs 27.1 and later support Terminfo capability @samp{RGB} for
+detecting 24-bit direct color mode. Multiple standard terminal
+definitions support this capability.
+
+@example
+$ TERM=xterm-direct infocmp | grep seta[bf]
+
+ setab=\E[%?%p1%@{8@}%<%t4%p1%d%e48\:2\:\:%p1%@{65536@}%/\
+ %d\:%p1%@{256@}%/%@{255@}%&%d\:%p1%@{255@}%&%d%;m,
+ setaf=\E[%?%p1%@{8@}%<%t3%p1%d%e38\:2\:\:%p1%@{65536@}%/\
+ %d\:%p1%@{256@}%/%@{255@}%&%d\:%p1%@{255@}%&%d%;m,
+
+$ TERM=xterm-direct emacs -nw
+@end example
+
+If your terminal is incompatible with XTerm, you may have to use
+another @env{TERM} definition. Any terminal whose name includes
+@samp{direct} should be a candidate. The @command{toe} command can be
+used to find out which of these are installed on your system:
-$ tic -x -o ~/.terminfo terminfo-24bit.src
+@example
+$ toe | grep '\-direct'
-$ TERM=xterm-24bit emacs -nw
+konsole-direct konsole with direct-color indexing
+vte-direct vte with direct-color indexing
+st-direct st with direct-color indexing
+xterm-direct2 xterm with direct-color indexing (old)
+xterm-direct xterm with direct-color indexing
@end example
-Currently there's no standard way to determine whether a terminal
-supports direct color mode. If such standard arises later on, support
-for @samp{setb24} and @samp{setf24} may be removed.
+Terminals with @samp{RGB} capability treat pixels #000001 - #000007 as
+indexed colors to maintain backward compatibility with applications
+that are unaware of direct color mode. Therefore the seven darkest
+blue shades may not be available. If this is a problem, you can
+always use custom terminal definition with @samp{setb24} and
+@samp{setf24}.
@node Debugging a customization file
@section How do I debug a @file{.emacs} file?
@@ -1975,9 +2005,18 @@ or by invoking @code{server-start} from @file{.emacs}:
(if (@var{some conditions are met}) (server-start))
@end lisp
-When this is done, Emacs creates a Unix domain socket named
-@file{server} in @file{/tmp/emacs@var{userid}}. See
-@code{server-socket-dir}.
+When this is done, Emacs by default creates a Unix domain socket named
+@file{server} in a well-known directory, typically
+@file{$XDG_RUNTIME_DIR/emacs} if Emacs is running under an X Window System
+desktop and @file{$TMPDIR/emacs@var{userid}} otherwise. See the variable
+@code{server-socket-dir}. Traditionally, Emacs used
+@file{$TMPDIR/emacs@var{userid}} even when running under an X desktop;
+if you prefer this traditional (and less-secure) behavior, you
+can set the environment variable @env{EMACS_SOCKET_NAME} to
+@samp{$TMPDIR/emacs@var{userid}/server} before invoking Emacs and
+@samp{emacsclient}, although it will be your responsibility to create
+the directory @samp{$TMPDIR/emacs@var{userid}} with appropriate
+ownership and permissions.
To get your news reader, mail reader, etc., to invoke
@samp{emacsclient}, try setting the environment variable @code{EDITOR}
@@ -2958,7 +2997,7 @@ Emacs compiled on a 64-bit machine can handle much larger buffers.
@cindex Shell buffer, echoed commands and @samp{^M} in
@cindex Echoed commands in @code{shell-mode}
-Try typing @kbd{M-x shell-strip-ctrl-m @key{RET}} while in @code{shell-mode} to
+Try typing @kbd{M-x comint-strip-ctrl-m @key{RET}} while in @code{shell-mode} to
make them go away. If that doesn't work, you have several options:
For @code{tcsh}, put this in your @file{.cshrc} (or @file{.tcshrc})
@@ -3011,7 +3050,7 @@ characters from the buffer by adding this to your @file{.emacs} init
file:
@smalllisp
-(add-hook 'comint-output-filter-functions 'shell-strip-ctrl-m)
+(add-hook 'comint-output-filter-functions #'comint-strip-ctrl-m)
@end smalllisp
On a related note: if your shell is echoing your input line in the shell
@@ -3733,7 +3772,7 @@ to bind the key is in the kill ring, and can be yanked into your
command are required. For example,
@lisp
-(global-set-key (quote [f1]) (quote help-for-help))
+(global-set-key [f1] 'help-for-help)
@end lisp
@noindent
@@ -3744,7 +3783,7 @@ For example, in TeX mode, a local binding might be
@lisp
(add-hook 'tex-mode-hook
(lambda ()
- (local-set-key (quote [f1]) (quote help-for-help))))
+ (local-set-key [f1] 'help-for-help)))
@end lisp
@@ -4538,7 +4577,7 @@ these systems, you should configure @code{movemail} to use @code{flock}.
@c isaacson@@seas.upenn.edu
Ron Isaacson says: When you hit
-@kbd{r} to reply in Rmail, by default it CCs all of the original
+@kbd{r} to reply in Rmail, by default it Ccs all of the original
recipients (everyone on the original @samp{To} and @samp{CC}
lists). With a prefix argument (i.e., typing @kbd{C-u} before @kbd{r}),
it replies only to the sender. However, going through the whole
diff --git a/doc/misc/emacs-gnutls.texi b/doc/misc/emacs-gnutls.texi
index aae583c641c..add79d12e42 100644
--- a/doc/misc/emacs-gnutls.texi
+++ b/doc/misc/emacs-gnutls.texi
@@ -179,17 +179,35 @@ Just use @code{open-protocol-stream} or @code{open-network-stream}
You should not have to use the @file{gnutls.el} functions directly.
But you can test them with @code{open-gnutls-stream}.
-@defun open-gnutls-stream name buffer host service &optional nowait
+@defun open-gnutls-stream name buffer host service &optional parameters
This function creates a buffer connected to a specific @var{host} and
-@var{service} (port number or service name). The parameters and their
-syntax are the same as those given to @code{open-network-stream}
-(@pxref{Network,, Network Connections, elisp, The Emacs Lisp Reference
-Manual}). The connection process is called @var{name} (made unique if
-necessary). This function returns the connection process.
-
-The @var{nowait} parameter means that the socket should be
-asynchronous, and the connection process will be returned to the
-caller before TLS negotiation has happened.
+@var{service} (port number or service name). The mandatory arguments
+and their syntax are the same as those given to
+@code{open-network-stream} (@pxref{Network,, Network Connections,
+elisp, The Emacs Lisp Reference Manual}). The connection process is
+called @var{name} (made unique if necessary). This function returns
+the connection process.
+
+The optional @var{parameters} argument is a list of keywords and
+values. The only keywords which currently have any effect are
+@code{:client-certificate} and @code{:nowait}.
+
+Passing @w{@code{:client certificate t}} triggers looking up of client
+certificates matching @var{host} and @var{service} using the
+@file{auth-source} library. Any resulting client certificates are passed
+down to the lower TLS layers. The format used by @file{.authinfo} to
+specify the per-server keys is described in @ref{Help for
+users,,auth-source, auth, Emacs auth-source Library}.
+
+Passing @w{@code{:nowait t}} means that the socket should be asynchronous,
+and the connection process will be returned to the caller before TLS
+negotiation has happened.
+
+For historical reasons @var{parameters} can also be a symbol, which is
+interpreted the same as passing a list containing @code{:nowait} and
+the value of that symbol.
+
+Example calls:
@lisp
;; open a HTTPS connection
diff --git a/doc/misc/emacs-mime.texi b/doc/misc/emacs-mime.texi
index 373bdeb9013..dd651fff356 100644
--- a/doc/misc/emacs-mime.texi
+++ b/doc/misc/emacs-mime.texi
@@ -1,7 +1,5 @@
\input texinfo
-@include gnus-overrides.texi
-
@setfilename ../../info/emacs-mime.info
@settitle Emacs MIME Manual
@include docstyle.texi
@@ -404,12 +402,12 @@ variable will cause @samp{text/html} parts to be treated as attachments.
@item mm-text-html-renderer
@vindex mm-text-html-renderer
-This selects the function used to render @acronym{HTML}. The predefined
-renderers are selected by the symbols @code{shr}, @code{gnus-w3m},
-@code{w3m}@footnote{See @uref{http://emacs-w3m.namazu.org/} for more
-information about emacs-w3m}, @code{links}, @code{lynx},
-@code{w3m-standalone} or @code{html2text}. If @code{nil} use an
-external viewer. You can also specify a function, which will be
+This selects the function used to render @acronym{HTML}. The
+predefined renderers are selected by the symbols @code{shr},
+@code{gnus-w3m}, @code{w3m}@footnote{See
+@uref{http://emacs-w3m.namazu.org/} for more information about
+emacs-w3m}, @code{links}, @code{lynx}, @code{w3m-standalone} or
+@code{html2text}. You can also specify a function, which will be
called with a @acronym{MIME} handle as the argument.
@item mm-html-inhibit-images
@@ -710,7 +708,7 @@ RFC 822 (or later) date when the part was read (@code{Content-Disposition}).
@item recipients
Who to encrypt/sign the part to. This field is used to override any
-auto-detection based on the To/CC headers.
+auto-detection based on the To/Cc headers.
@item sender
Identity used to sign the part. This field is used to override the
@@ -1526,45 +1524,54 @@ many mailers don't support it. @xref{rfc2231}.
@section time-date
While not really a part of the @acronym{MIME} library, it is convenient to
-document this library here. It deals with parsing @code{Date} headers
+document time conversion functions often used when parsing @code{Date} headers
and manipulating time. (Not by using tesseracts, though, I'm sorry to
say.)
-These functions convert between five formats: A date string, an Emacs
-time structure, a decoded time list, a second number, and a day number.
+These functions convert between five formats: A date string, a Lisp
+timestamp, a decoded time list, a second number, and a day number.
Here's a bunch of time/date/second/day examples:
@example
(parse-time-string "Sat Sep 12 12:21:54 1998 +0200")
-@result{} (54 21 12 12 9 1998 6 nil 7200)
+@result{} (54 21 12 12 9 1998 6 -1 7200)
-(date-to-time "Sat Sep 12 12:21:54 1998 +0200")
-@result{} (13818 19266)
+(encode-time (date-to-time "Sat Sep 12 12:21:54 1998 +0200")
+ 1000000)
+@result{} (905595714000000 . 1000000)
-(parse-iso8601-time-string "1998-09-12T12:21:54+0200")
-@result{} (13818 19266)
+(encode-time (parse-iso8601-time-string "1998-09-12T12:21:54+0200")
+ 1000000)
+@result{} (905595714000000 . 1000000)
-(float-time '(13818 19266))
+(float-time '(905595714000000 . 1000000))
@result{} 905595714.0
-(seconds-to-time 905595714.0)
-@result{} (13818 19266 0 0)
+(encode-time 905595714.0 1000000)
+@result{} (905595714000000 . 1000000)
-(time-to-days '(13818 19266))
+(time-to-days '(905595714000000 . 1000000))
@result{} 729644
-(days-to-time 729644)
-@result{} (961933 512)
+(encode-time (days-to-time 729644) 1000000)
+@result{} (63041241600000000 . 1000000)
-(time-since '(13818 19266))
-@result{} (6797 9607 984839 247000)
+(encode-time (time-since '(905595714000000 . 1000000))
+ 1000000)
+@result{} (631963244775642171 . 1000000000)
-(time-less-p '(13818 19266) '(13818 19145))
+(time-less-p '(905595714000000 . 1000000)
+ '(905595593000000000 . 1000000000))
@result{} nil
-(time-subtract '(13818 19266) '(13818 19145))
-@result{} (0 121)
+(time-equal-p '(905595593000000000 . 1000000000)
+ '(905595593000000 . 1000000 ))
+@result{} t
+
+(time-subtract '(905595714000000 . 1000000)
+ '(905595593000000000 . 1000000000))
+@result{} (121000000000 . 1000000000)
(days-between "Sat Sep 12 12:21:54 1998 +0200"
"Sat Sep 07 12:21:54 1998 +0200")
@@ -1573,13 +1580,13 @@ Here's a bunch of time/date/second/day examples:
(date-leap-year-p 2000)
@result{} t
-(time-to-day-in-year '(13818 19266))
+(time-to-day-in-year '(905595714000000 . 1000000))
@result{} 255
(time-to-number-of-days
(time-since
(date-to-time "Mon, 01 Jan 2001 02:22:26 GMT")))
-@result{} 4314.095589286675
+@result{} 6472.722661506652
@end example
And finally, we have @code{safe-date-to-time}, which does the same as
@@ -1594,22 +1601,24 @@ An RFC 822 (or similar) date string. For instance: @code{"Sat Sep 12
12:21:54 1998 +0200"}.
@item time
-An internal Emacs time. For instance: @code{(13818 26466 0 0)}.
+A Lisp timestamp.
+For instance: @code{(905595714000000 . 1000000)}.
@item seconds
-A floating point representation of the internal Emacs time. For
-instance: @code{905595714.0}.
+An integer or floating point count of seconds. For instance:
+@code{905595714.0}, @code{905595714}.
@item days
An integer number representing the number of days since 00000101. For
instance: @code{729644}.
@item decoded time
-A list of decoded time. For instance: @code{(54 21 12 12 9 1998 6 t
+A list of decoded time. For instance: @code{(54 21 12 12 9 1998 6 nil
7200)}.
@end table
-All the examples above represent the same moment.
+All the examples above represent the same moment, except that
+@var{days} represents the day containing the moment.
These are the functions available:
@@ -1620,8 +1629,9 @@ Take a date and return a time.
@item float-time
Take a time and return seconds. (This is a built-in function.)
-@item seconds-to-time
-Take seconds and return a time.
+@item encode-time
+Take seconds (and other ways to represent time, notably decoded time
+lists), and return a time.
@item time-to-days
Take a time and return days.
@@ -1643,6 +1653,10 @@ return a ``zero'' time.
Take two times and say whether the first time is less (i.e., earlier)
than the second time. (This is a built-in function.)
+@item time-equal-p
+Check whether two time values are equal. The time values need not be
+in the same format. (This is a built-in function.)
+
@item time-since
Take a time and return a time saying how long it was since that time.
@@ -1847,11 +1861,23 @@ Interface functions:
@table @code
@item mailcap-parse-mailcaps
@findex mailcap-parse-mailcaps
+@vindex mailcap-prefer-mailcap-viewers
Parse the @file{~/.mailcap} file.
@item mailcap-mime-info
Takes a @acronym{MIME} type as its argument and returns the matching viewer.
+The @code{mailcap-prefer-mailcap-viewers} variable controls which
+viewer is chosen. The default non-@code{nil} value means that
+settings from @file{~/.mailcap} is preferred over system-wide or
+Emacs-provided viewer settings.
+
+If @code{nil}, Emacs-provided viewer settings have precedence. Next,
+the most specific viewer has precedence over less specific settings,
+no matter if they're system-provided or private, so @samp{image/gif}
+in @file{/etc/mailcap} will ``win'' over an @samp{image/*} setting in
+@file{~/.mailcap}.
+
@end table
diff --git a/doc/misc/ert.texi b/doc/misc/ert.texi
index d70eca81f9c..d2d86555e3c 100644
--- a/doc/misc/ert.texi
+++ b/doc/misc/ert.texi
@@ -273,9 +273,11 @@ moving point to it and typing @kbd{@key{RET}} jumps to its definition.
@cindex backtrace of a failed test
Pressing @kbd{r} re-runs the test near point on its own. Pressing
@kbd{d} re-runs it with the debugger enabled. @kbd{.} jumps to the
-definition of the test near point (@kbd{@key{RET}} has the same effect if
-point is on the name of the test). On a failed test, @kbd{b} shows
-the backtrace of the failure.
+definition of the test near point (@kbd{@key{RET}} has the same effect
+if point is on the name of the test). On a failed test, @kbd{b} shows
+the backtrace of the failure. @xref{Debugging,, Backtraces, elisp,
+GNU Emacs Lisp Reference Manual}, for more information about
+backtraces.
@kindex l@r{, in ert results buffer}
@kbd{l} shows the list of @code{should} forms executed in the test.
@@ -321,6 +323,20 @@ summary as shown below:
emacs -batch -l ert -f ert-summarize-tests-batch-and-exit output.log
@end example
+@vindex ert-quiet
+By default, ERT in batch mode is quite verbose, printing a line with
+result after each test. This gives you progress information: how many
+tests have been executed and how many there are. However, in some
+cases this much output may be undesirable. In this case, set
+@code{ert-quiet} variable to a non-nil value:
+
+@example
+emacs -batch -l ert -l my-tests.el \
+ --eval "(let ((ert-quiet t)) (ert-run-tests-batch-and-exit))"
+@end example
+
+In quiet mode ERT prints only unexpected results and summary.
+
If ERT is not part of your Emacs distribution, you may need to use
@code{-L /path/to/ert/} so that Emacs can find it. You may need
additional @code{-L} flags to ensure that @code{my-tests.el} and all the
diff --git a/doc/misc/eshell.texi b/doc/misc/eshell.texi
index 712780e3352..716b4b7a50d 100644
--- a/doc/misc/eshell.texi
+++ b/doc/misc/eshell.texi
@@ -329,7 +329,7 @@ List subprocesses of the Emacs process, if any, using the function
@item kill
@cmindex kill
Kill processes. Takes a PID or a process object and an optional
-signal specifier.
+signal specifier which can either be a number or a signal name.
@item listify
@cmindex listify
@@ -499,15 +499,14 @@ be directories @emph{and} files. Eshell provides predefined completions
for the built-in functions and some common external commands, and you
can define your own for any command.
-Eshell completion also works for lisp forms and glob patterns. If the
-point is on a lisp form, then @key{TAB} will behave similarly to completion
-in @code{elisp-mode} and @code{lisp-interaction-mode}. For glob
-patterns, If there are few enough possible completions of the patterns,
-they will be cycled when @key{TAB} is pressed, otherwise it will be removed
-from the input line and the possible completions will be listed.
+Eshell completion also works for lisp forms and glob patterns. If the point is
+on a lisp form, then @key{TAB} will behave similarly to completion in
+@code{elisp-mode} and @code{lisp-interaction-mode}. For glob patterns, the
+pattern will be removed from the input line, and replaced by the
+completion.
-If you want to see the entire list of possible completions when it's
-below the cycling threshold, press @kbd{M-?}.
+If you want to see the entire list of possible completions (e.g. when it's
+below the @code{completion-cycle-threshold}), press @kbd{M-?}.
@subsection pcomplete
Pcomplete, short for programmable completion, is the completion
diff --git a/doc/misc/eww.texi b/doc/misc/eww.texi
index d2c60b0abf7..8dc58e84257 100644
--- a/doc/misc/eww.texi
+++ b/doc/misc/eww.texi
@@ -85,6 +85,10 @@ searched via @code{eww-search-prefix}. The default search engine is
either prefix the file name with @code{file://} or use the command
@kbd{M-x eww-open-file}.
+ If you invoke @code{eww} with a prefix argument, as in @w{@kbd{C-u
+M-x eww}}, it will create a new EWW buffer instead of reusing the
+default one, which is normally called @file{*eww*}.
+
@findex eww-quit
@findex eww-reload
@findex eww-copy-page-url
@@ -125,9 +129,10 @@ HTML-specified colors or not. This sets the @code{shr-use-colors} variable.
@vindex eww-download-directory
@kindex d
@cindex Download
- A URL under the point can be downloaded with @kbd{d}
-(@code{eww-download}). The file will be written to the directory
-specified in @code{eww-download-directory} (Default: @file{~/Downloads/}).
+ A URL can be downloaded with @kbd{d} (@code{eww-download}). This
+will download the link under point if there is one, or else the URL of
+the current page. The file will be written to the directory specified
+in @code{eww-download-directory} (default: @file{~/Downloads/}).
@findex eww-back-url
@findex eww-forward-url
@@ -262,6 +267,16 @@ contrast. If that is still too low for you, you can customize the
variables @code{shr-color-visible-distance-min} and
@code{shr-color-visible-luminance-min} to get a better contrast.
+@vindex shr-discard-aria-hidden
+@cindex @code{aria-hidden}, HTML attribute
+ The HTML attribute @code{aria-hidden} is meant to tell screen
+readers to ignore a tag's contents. You can customize the variable
+@code{shr-discard-aria-hidden} to tell @code{shr} to ignore such tags.
+This can be useful when using a screen reader on the output of
+@code{shr} (e.g., on EWW buffer text). It can be useful even when not
+using a screen reader, since web authors often put this attribute on
+non-essential decorative elements.
+
@cindex Desktop Support
@cindex Saving Sessions
In addition to maintaining the history at run-time, EWW will also
diff --git a/doc/misc/flymake.texi b/doc/misc/flymake.texi
index 2689b5d8cd9..894203ca5a1 100644
--- a/doc/misc/flymake.texi
+++ b/doc/misc/flymake.texi
@@ -1,8 +1,8 @@
\input texinfo @c -*-texinfo; coding: utf-8 -*-
@comment %**start of header
@setfilename ../../info/flymake.info
-@set VERSION 0.3
-@set UPDATED April 2004
+@set VERSION 1.0
+@set UPDATED June 2018
@settitle GNU Flymake @value{VERSION}
@include docstyle.texi
@syncodeindex pg cp
@@ -37,7 +37,7 @@ modify this GNU manual.''
@titlepage
@title GNU Flymake
@subtitle for version @value{VERSION}, @value{UPDATED}
-@author Pavel Kobiakov(@email{pk_at_work@@yahoo.com}) and João Távora.
+@author João Távora and Pavel Kobiakov(@email{pk_at_work@@yahoo.com}).
@page
@vskip 0pt plus 1filll
@insertcopying
@@ -84,6 +84,10 @@ Syntax check is done ``on-the-fly''. It is started whenever
@code{flymake-start-on-flymake-mode} is nil;
@item
+the buffer is saved, unless @code{flymake-start-on-save-buffer} is
+nil;
+
+@item
a newline character is added to the buffer, unless
@code{flymake-start-syntax-check-on-newline} is nil;
@@ -95,9 +99,15 @@ some changes were made to the buffer more than @code{0.5} seconds ago
Syntax check can also be started manually by typing the @kbd{M-x
flymake-start @key{RET}} command.
+If the check detected errors or warnings, the respective buffer
+regions are highlighted. You can place point on those regions and use
+@kbd{C-h .} (@code{display-local-help}) to see what the specific
+problem was. Alternatively, hovering the mouse on those regions
+should also display a tool-tip with the same information.
+
@code{flymake-goto-next-error} and @code{flymake-goto-prev-error} are
commands that allow easy navigation to the next/previous erroneous
-line, respectively. If might be a good idea to map them to @kbd{M-n}
+regions, respectively. If might be a good idea to map them to @kbd{M-n}
and @kbd{M-p} in @code{flymake-mode}, by adding to your init file:
@lisp
@@ -220,6 +230,10 @@ after a newline character is inserted into the buffer.
A boolean flag indicating whether to start syntax check immediately
after enabling @code{flymake-mode}.
+@item flymake-start-on-save-buffer
+A boolean flag indicating whether to start syntax check after saving
+the buffer.
+
@item flymake-error
A custom face for highlighting regions for which an error has been
reported.
@@ -275,54 +289,61 @@ The following sections discuss each approach in detail.
@cindex customizing error types
@cindex error types, customization
-@vindex flymake-diagnostic-types-alist
-The variable @code{flymake-diagnostic-types-alist} is looked up by
-Flymake every time an annotation for a diagnostic is created in the
-buffer. Specifically, this variable holds a table of correspondence
-between symbols designating diagnostic types and an additional
-sub-table of properties pertaining to each diagnostic type.
+To customize the appearance of error types, set properties on the
+symbols associated with each diagnostic type. The standard diagnostic
+symbols are @code{:error}, @code{:warning} and @code{:note} (though
+the backend may define more, @pxref{Backend functions}).
-Both tables are laid out in association list (@pxref{Association
-Lists,,, elisp, The Emacs Lisp Reference Manual}) format, and thus can
-be conveniently accessed with the functions of the @code{assoc}
-family.
-
-You can use any symbol-value association in the properties sub-table,
-but some symbols have special meaning as to where and how Flymake
-presents the diagnostic:
+The following properties can be set:
@itemize
@item
@cindex bitmap of diagnostic
-@code{bitmap}, an image displayed in the fringe according to
+@code{flymake-bitmap}, an image displayed in the fringe according to
@code{flymake-fringe-indicator-position}. The value actually follows
the syntax of @code{flymake-error-bitmap} (@pxref{Customizable
variables}). It is overridden by any @code{before-string} overlay
property.
@item
-@cindex severity of diagnostic
-@code{severity} is a non-negative integer specifying the diagnostic's
-severity. The higher the value, the more serious is the error. If
-the overlay property @code{priority} is not specified, @code{severity}
-is used to set it and help sort overlapping overlays.
+@code{flymake-overlay-control}, an alist ((@var{OVPROP} . @var{VALUE})
+@var{...}) of further properties used to affect the appearance of
+Flymake annotations. With the exception of @code{category} and
+@code{evaporate}, these properties are applied directly to the created
+overlay (@pxref{Overlay Properties,,, elisp, The Emacs Lisp Reference
+Manual}).
-@item
-Every property pertaining to overlays (@pxref{Overlay Properties,,,
-elisp, The Emacs Lisp Reference Manual}), except @code{category} and
-@code{evaporate}. These properties are used to affect the appearance
-of Flymake annotations.
+As an example, here's how to make diagnostics of the type @code{:note}
+stand out more prominently:
-As an example, here's how to make errors (diagnostics of the type
-@code{:error}) stand out even more prominently in the buffer, by
-raising the characters using a @code{display} overlay property.
+@example
+(push '(face . highlight) (get :note 'flymake-overlay-control))
+@end example
+
+If you push another alist entry in front, it overrides the previous
+one. So this effectively removes the face from @code{:note}
+diagnostics:
@example
-(push '(display . (raise 1.2))
- (cdr (assoc :error flymake-diagnostic-types-alist)))
+(push '(face . nil) (get :note 'flymake-overlay-control))
@end example
+To restore the original look for @code{:note} types, empty or remove
+its @code{flymake-overlay-control} property:
+
+@example
+(put :note 'flymake-overlay-control '())
+@end example
+
+@item
+@cindex severity of diagnostic
+@code{flymake-severity} is a non-negative integer specifying the
+diagnostic's severity. The higher the value, the more serious is the
+error. If the overlay property @code{priority} is not specified in
+@code{flymake-overlay-control}, @code{flymake-severity} is used to set
+it and help sort overlapping overlays.
+
@item
@vindex flymake-category
@code{flymake-category} is a symbol whose property list is considered
@@ -333,32 +354,29 @@ the default for missing values of any other properties.
@vindex flymake-error
@vindex flymake-warning
@vindex flymake-note
-Three default diagnostic types, @code{:error}, @code{:warning} and
-@code{:note} are predefined in
-@code{flymake-diagnostic-types-alist}. By default each lists a single
+Three default diagnostic types are predefined: @code{:error},
+@code{:warning}, and @code{:note}. By default, each one of them has a
@code{flymake-category} property whose value is, respectively, the
-symbols @code{flymake-error}, @code{flymake-warning} and
+category symbol @code{flymake-error}, @code{flymake-warning} and
@code{flymake-note}.
-These category symbols' plists is where the values of customizable
-variables and faces such as @code{flymake-error-bitmap} are found.
-Thus, if you change their plists, Flymake may stop honoring these
-user customizations.
+These category symbols' plist is where the values of customizable
+variables and faces (such as @code{flymake-error-bitmap}) are found.
+Thus, if you change their plists, Flymake may stop honoring these user
+customizations.
-The @code{flymake-category} special property is also especially useful
-for backends which create diagnostics objects with non-default
-types that differ from an existing type by only a few properties
-(@pxref{Flymake utility functions}).
+The @code{flymake-category} special property is especially useful for
+backends which create diagnostics objects with non-default types that
+differ from an existing type by only a few properties (@pxref{Flymake
+utility functions}).
As an example, consider configuring a new diagnostic type
-@code{:low-priority-note} that behaves much like the @code{:note}
-priority but without an overlay face.
+@code{:low-priority-note} that behaves much like @code{:note}, but
+without an overlay face.
@example
-(add-to-list
- 'flymake-diagnostic-types-alist
- `(:low-priority-note . ((face . nil)
- (flymake-category . flymake-note))))
+(put :low-priority-note 'flymake-overlay-control '((face . nil)))
+(put :low-priority-note 'flymake-category 'flymake-note)
@end example
@vindex flymake-diagnostics
@@ -389,20 +407,17 @@ Internet search for the text of a @code{:warning} or @code{:error}.
(eww-browse-url
(concat
"https://duckduckgo.com/?q="
- (replace-regexp-in-string " "
- "+"
- (flymake-diagnostic-text topmost-diag)))
+ (replace-regexp-in-string
+ " " "+" (flymake-diagnostic-text topmost-diag)))
t)))
(dolist (type '(:warning :error))
- (let ((a (assoc type flymake-diagnostic-types-alist)))
- (setf (cdr a)
- (append `((mouse-face . highlight)
- (keymap . ,(let ((map (make-sparse-keymap)))
- (define-key map [mouse-2]
- 'my-search-for-message)
- map)))
- (cdr a)))))
+ (push '(mouse-face . highlight) (get type 'flymake-overlay-control))
+ (push `(keymap . ,(let ((map (make-sparse-keymap)))
+ (define-key map [mouse-2]
+ 'my-search-for-message)
+ map))
+ (get type 'flymake-overlay-control)))
@end example
@node Backend functions
@@ -428,18 +443,35 @@ calling convention: one for calls made by Flymake into the backend via
the backend function, the other in the reverse direction via a
callback. To be usable, backends must adhere to both.
-Backend functions must accept an arbitrary number of arguments:
+The first argument passed to a backend function is always
+@var{report-fn}, a callback function detailed below. Beyond it,
+functions must be prepared to accept (and possibly ignore) an
+arbitrary number of keyword-value pairs of the form
+@w{@code{(@var{:key} @var{value} @var{:key2} @var{value2}...)}}.
+
+Currently, Flymake may pass the following keywords and values to the
+backend function:
@itemize
-@item
-the first argument is always @var{report-fn}, a callback function
-detailed below;
-@item
-the remaining arguments are keyword-value pairs of the
-form @w{@code{(@var{:key} @var{value} @var{:key2} @var{value2}...)}}. Currently,
-Flymake provides no such arguments, but backend functions must be
-prepared to accept (and possibly ignore) any number of them.
+@item @code{:recent-changes}
+The value is a list recent changes since the last time the backend
+function was called for the buffer. If the list is empty, this
+indicates that no changes have been recorded. If it is the first time
+that this backend function is called for this activation of
+@code{flymake-mode}, then this argument isn't provided at all
+(i.e. it's not merely nil).
+
+Each element is in the form (@var{beg} @var{end} @var{text}) where
+@var{beg} and @var{end} are buffer positions, and @var{text} is a
+string containing the text contained between those positions (if any),
+after the change was performed.
+
+@item @code{:changes-start} and @code{:changes-end}
+The value is, repectively, the minimum and maximum buffer positions
+touched by the recent changes. These are provided for convenience and
+only if @code{:recent-changes} is also provided.
+
@end itemize
Whenever Flymake or the user decide to re-check the buffer, backend
@@ -495,6 +527,11 @@ details of the situation encountered, if any.
@code{:force}, whose value should be a boolean suggesting
that Flymake consider the report even if it was somehow
unexpected.
+
+@item
+@code{:region}, a cons (@var{beg} . @var{end}) of buffer positions
+indicating that the report applies to that region and that previous
+reports targeting other parts of the buffer remain valid.
@end itemize
@menu
@@ -512,9 +549,9 @@ by calling the function @code{flymake-make-diagnostic}.
@deffn Function flymake-make-diagnostic buffer beg end type text
Make a Flymake diagnostic for @var{buffer}'s region from @var{beg} to
-@var{end}. @var{type} is a key to
-@code{flymake-diagnostic-types-alist} and @var{text} is a description
-of the problem detected in this region.
+@var{end}. @var{type} is a diagnostic symbol (@pxref{Flymake error
+types}), and @var{text} is a description of the problem detected in
+this region.
@end deffn
@cindex access diagnostic object
@@ -715,14 +752,13 @@ Patterns for error/warning messages in the form @code{(regexp file-idx
line-idx col-idx err-text-idx)}. @xref{Parsing the output}.
@item flymake-proc-diagnostic-type-pred
-A function to classify a diagnostic text as particular type of
-error. Should be a function taking an error text and returning one of
-the symbols indexing @code{flymake-diagnostic-types-alist}. If non-nil
-is returned but there is no such symbol in that table, a warning is
-assumed. If nil is returned, an error is assumed. Can also be a
-regular expression that should match only warnings. This variable
-replaces the old @code{flymake-warning-re} and
-@code{flymake-warning-predicate}.
+A function to classify a diagnostic text as particular type of error.
+Should be a function taking an error text and returning a diagnostic
+symbol (@pxref{Flymake error types}). If non-nil is returned but
+there is no such symbol in that table, a warning is assumed. If nil
+is returned, an error is assumed. Can also be a regular expression
+that should match only warnings. This variable replaces the old
+@code{flymake-warning-re} and @code{flymake-warning-predicate}.
@item flymake-proc-compilation-prevents-syntax-check
A flag indicating whether compilation and syntax check of the same
diff --git a/doc/misc/gnus-coding.texi b/doc/misc/gnus-coding.texi
index 95544628f79..6affea48724 100644
--- a/doc/misc/gnus-coding.texi
+++ b/doc/misc/gnus-coding.texi
@@ -227,161 +227,6 @@ ends (probably @file{nnml.el}, @file{nnfolder.el} and
@c requires nnheader.
-@section Compatibility
-
-No Gnus and Gnus 5.10.10 and up should work on:
-@itemize @bullet
-@item
-Emacs 21.1 and up.
-@item
-XEmacs 21.4 and up.
-@end itemize
-
-Gnus 5.10.8 and below should work on:
-@itemize @bullet
-@item
-Emacs 20.7 and up.
-@item
-XEmacs 21.1 and up.
-@end itemize
-
-@node Gnus Maintenance Guide
-@chapter Gnus Maintenance Guide
-
-@section Stable and development versions
-
-The development of Gnus normally is done on the Git repository trunk
-as of April 19, 2010 (formerly it was done in CVS; the repository is
-at http://git.gnus.org), i.e., there are no separate branches to
-develop and test new features. Most of the time, the trunk is
-developed quite actively with more or less daily changes. Only after
-a new major release, e.g., 5.10.1, there's usually a feature period of
-several months. After the release of Gnus 5.10.6 the development of
-new features started again on the trunk while the 5.10 series is
-continued on the stable branch (v5-10) from which more stable releases
-will be done when needed (5.10.8, @dots{}). @ref{Gnus Development,
-,Gnus Development, gnus, The Gnus Newsreader}
-
-Stable releases of Gnus finally become part of Emacs. E.g., Gnus 5.8
-became a part of Emacs 21 (relabeled to Gnus 5.9). The 5.10 series
-became part of Emacs 22 as Gnus 5.11.
-
-@section Syncing
-
-@c Some MIDs related to this follow. Use http://thread.gmane.org/MID
-@c (and click on the subject) to get the thread on Gmane.
-
-@c Some quotes from Miles Bader follow...
-
-@c <v9eklyke6b.fsf@marauder.physik.uni-ulm.de>
-@c <buovfd71nkk.fsf@mctpc71.ucom.lsi.nec.co.jp>
-
-In the past, the inclusion of Gnus into Emacs was quite cumbersome. For
-each change made to Gnus in Emacs repository, it had to be checked that
-it was applied to the new Gnus version, too. Else, bug fixes done in
-Emacs repository might have been lost.
-
-With the inclusion of Gnus 5.10, Miles Bader has set up an Emacs-Gnus
-gateway to ensure the bug fixes from Emacs CVS are propagated to Gnus
-CVS semi-automatically.
-
-After Emacs moved to bzr and Gnus moved to git, Katsumi Yamaoka has
-taken over the chore of keeping Emacs and Gnus in sync. In general,
-changes made to one repository will usually be replicated in the other
-within a few days.
-
-Basically the idea is that the gateway will cause all common files in
-Emacs and Gnus v5-13 to be identical except when there's a very good
-reason (e.g., the Gnus version string in Emacs says @samp{5.11}, but
-the v5-13 version string remains @samp{5.13.x}). Furthermore, all
-changes in these files in either Emacs or the v5-13 branch will be
-installed into the Gnus git trunk, again except where there's a good
-reason.
-
-@c (typically so far the only exception has been that the changes
-@c already exist in the trunk in modified form).
-Because of this, when the next major version of Gnus will be included in
-Emacs, it should be very easy---just plonk in the files from the Gnus
-trunk without worrying about lost changes from the Emacs tree.
-
-The effect of this is that as hacker, you should generally only have to
-make changes in one place:
-
-@itemize
-@item
-If it's a file which is thought of as being outside of Gnus (e.g., the
-new @file{encrypt.el}), you should probably make the change in the Emacs
-tree, and it will show up in the Gnus tree a few days later.
-
-If you don't have Emacs repository access (or it's inconvenient), you
-can change such a file in the v5-10 branch, and it should propagate to
-the Emacs repository---however, it will get some extra scrutiny (by
-Miles) to see if the changes are possibly controversial and need
-discussion on the mailing list. Many changes are obvious bug-fixes
-however, so often there won't be any problem.
-
-@item
-If it's to a Gnus file, and it's important enough that it should be part
-of Emacs and the v5-10 branch, then you can make the change on the v5-10
-branch, and it will go into Emacs and the Gnus git trunk (a few days
-later). The most prominent examples for such changes are bug-fixed
-including improvements on the documentation.
-
-If you know that there will be conflicts (perhaps because the affected
-source code is different in v5-10 and the Gnus git trunk), then you can
-install your change in both places, and when I try to sync them, there
-will be a conflict---however, since in most such cases there would be a
-conflict @emph{anyway}, it's often easier for me to resolve it simply if
-I see two @samp{identical} changes, and can just choose the proper one,
-rather than having to actually fix the code.
-
-@item
-For general Gnus development changes, of course you just make the
-change on the Gnus Git trunk and it goes into Emacs a few years
-later... :-)
-
-@end itemize
-
-Of course in any case, if you just can't wait for me to sync your
-change, you can commit it in more than one place and probably there will
-be no problem; usually the changes are textually identical anyway, so
-can be easily resolved automatically (sometimes I notice silly things in
-such multiple commits, like whitespace differences, and unify those ;-).
-
-
-@c I do Emacs->Gnus less often (than Gnus->Emacs) because it tends to
-@c require more manual work.
-
-@c By default I sync about once a week. I also try to follow any Gnus
-@c threads on the mailing lists and make sure any changes being discussed
-@c are kept more up-to-date (so say 1-2 days delay for "topical" changes).
-
-@c <buovfd71nkk.fsf@mctpc71.ucom.lsi.nec.co.jp>
-
-@c BTW, just to add even more verbose explanation about the syncing thing:
-
-@section Miscellanea
-
-@heading @file{GNUS-NEWS}
-
-The @file{etc/GNUS-NEWS} is created from
-@file{doc/misc/gnus-news.texi}. Don't edit @file{etc/GNUS-NEWS}.
-Edit @file{doc/misc/gnus-news.texi}, type @command{make
-update-gnus-news} in the @file{lisp} directory and commit
-@file{etc/GNUS-NEWS} and @file{doc/misc/gnus-news.texi}.
-
-@heading Conventions for version information in defcustoms
-
-For new customizable variables introduced in Oort Gnus (including the
-v5-10 branch) use @code{:version "22.1" ;; Oort Gnus} (including the
-comment) or, e.g., @code{:version "22.2" ;; Gnus 5.10.10} if the feature
-was added for Emacs 22.2 and Gnus 5.10.10.
-@c
-If the variable is new in No Gnus use @code{:version "23.1" ;; No Gnus}.
-
-The same applies for customizable variables when its default value was
-changed.
-
@node GNU Free Documentation License
@appendix GNU Free Documentation License
@include doclicense.texi
diff --git a/doc/misc/gnus-faq.texi b/doc/misc/gnus-faq.texi
index d4be7b1f0ce..075f5218414 100644
--- a/doc/misc/gnus-faq.texi
+++ b/doc/misc/gnus-faq.texi
@@ -1161,13 +1161,13 @@ from using them):
@example
(setq nnmail-split-methods
'(("duplicates" "^Gnus-Warning:.*duplicate")
- ("XEmacs-NT" "^\\(To:\\|CC:\\).*localpart@@xemacs.invalid.*")
- ("Gnus-Tut" "^\\(To:\\|CC:\\).*localpart@@socha.invalid.*")
- ("tcsh" "^\\(To:\\|CC:\\).*localpart@@mx.gw.invalid.*")
- ("BAfH" "^\\(To:\\|CC:\\).*localpart@@.*uni-muenchen.invalid.*")
- ("Hamster-src" "^\\(CC:\\|To:\\).*hamster-sourcen@@yahoogroups.\\(de\\|com\\).*")
+ ("XEmacs-NT" "^\\(To:\\|Cc:\\).*localpart@@xemacs.invalid.*")
+ ("Gnus-Tut" "^\\(To:\\|Cc:\\).*localpart@@socha.invalid.*")
+ ("tcsh" "^\\(To:\\|Cc:\\).*localpart@@mx.gw.invalid.*")
+ ("BAfH" "^\\(To:\\|Cc:\\).*localpart@@.*uni-muenchen.invalid.*")
+ ("Hamster-src" "^\\(Cc:\\|To:\\).*hamster-sourcen@@yahoogroups.\\(de\\|com\\).*")
("Tagesschau" "^From: tagesschau <localpart@@www.tagesschau.invalid>$")
- ("Replies" "^\\(CC:\\|To:\\).*localpart@@Frank-Schmitt.invalid.*")
+ ("Replies" "^\\(Cc:\\|To:\\).*localpart@@Frank-Schmitt.invalid.*")
("EK" "^From:.*\\(localpart@@privateprovider.invalid\\|localpart@@workplace.invalid\\).*")
("Spam" "^Content-Type:.*\\(ks_c_5601-1987\\|EUC-KR\\|big5\\|iso-2022-jp\\).*")
("Spam" "^Subject:.*\\(This really work\\|XINGA\\|ADV:\\|XXX\\|adult\\|sex\\).*")
@@ -1177,10 +1177,10 @@ from using them):
("Spam" "^From:.*\\(verizon\.net\\|prontomail\.com\\|money\\|ConsumerDirect\\).*")
("Spam" "^Delivered-To: GMX delivery to spamtrap@@gmx.invalid$")
("Spam" "^Received: from link2buy.com")
- ("Spam" "^CC: .*azzrael@@t-online.invalid")
+ ("Spam" "^Cc: .*azzrael@@t-online.invalid")
("Spam" "^X-Mailer-Version: 1.50 BETA")
- ("Uni" "^\\(CC:\\|To:\\).*localpart@@uni-koblenz.invalid.*")
- ("Inbox" "^\\(CC:\\|To:\\).*\\(my\ name\\|address@@one.invalid\\|address@@two.invalid\\)")
+ ("Uni" "^\\(Cc:\\|To:\\).*localpart@@uni-koblenz.invalid.*")
+ ("Inbox" "^\\(Cc:\\|To:\\).*\\(my\ name\\|address@@one.invalid\\|address@@two.invalid\\)")
("Spam" "")))
@end example
@noindent
diff --git a/doc/misc/gnus-news.el b/doc/misc/gnus-news.el
deleted file mode 100644
index c90269fffef..00000000000
--- a/doc/misc/gnus-news.el
+++ /dev/null
@@ -1,115 +0,0 @@
-;;; gnus-news.el --- a hack to create GNUS-NEWS from texinfo source
-;; Copyright (C) 2004-2019 Free Software Foundation, Inc.
-
-;; Author: Reiner Steib <Reiner.Steib@gmx.de>
-;; Keywords: tools
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(defvar gnus-news-header-disclaimer
-"GNUS NEWS -- history of user-visible changes.
-
-Copyright (C) 1999-2019 Free Software Foundation, Inc.
-See the end of the file for license conditions.
-
-Please send Gnus bug reports to bugs@gnus.org.
-For older news, see Gnus info node \"New Features\".\n\n")
-
-(defvar gnus-news-trailer
-"
-* For older news, see Gnus info node \"New Features\".
-
-----------------------------------------------------------------------
-
-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 <https://www.gnu.org/licenses/>.
-
- \nLocal variables:\nmode: outline
-paragraph-separate: \"[ ]*$\"\nend:\n")
-
-(defvar gnus-news-makeinfo-command "makeinfo")
-
-(defvar gnus-news-fill-column 80)
-
-(defvar gnus-news-makeinfo-switches
- (concat " --no-headers --paragraph-indent=0"
- " --no-validate" ;; Allow unresolved references.
- " --fill-column=" (number-to-string
- (+ 3 ;; will strip leading spaces later
- (or gnus-news-fill-column 80)))))
-
-(defun batch-gnus-news ()
- "Make GNUS-NEWS in batch mode."
- (let (infile outfile)
- (setq infile (car command-line-args-left)
- command-line-args-left (cdr command-line-args-left)
- outfile (car command-line-args-left)
- command-line-args-left nil)
- (if (and infile outfile)
- (message "Creating `%s' from `%s'..." outfile infile)
- (error "Not enough files given."))
- (gnus-news-translate-file infile outfile)))
-
-(defun gnus-news-translate-file (infile outfile)
- "Translate INFILE (texinfo) to OUTFILE (GNUS-NEWS)."
- (let* ((dir (concat (or (getenv "srcdir") ".") "/"))
- (infile (concat dir infile))
- (buffer (find-file-noselect (concat dir outfile))))
- (with-temp-buffer
- ;; Could be done using 'texinfmt' stuff as in 'infohack.el'.
- (insert
- (shell-command-to-string
- (concat gnus-news-makeinfo-command " "
- gnus-news-makeinfo-switches " " infile)))
- (goto-char (point-max))
- (delete-char -1)
- (goto-char (point-min))
- (save-excursion
- (while (re-search-forward "^ \\* " nil t)
- (replace-match "\f\n* ")))
- (save-excursion
- (while (re-search-forward "^ \\* " nil t)
- (replace-match "** ")))
- (save-excursion
- (while (re-search-forward "^ " nil t)
- (replace-match "")))
- ;; Avoid '*' from @ref at beginning of line:
- (save-excursion
- (while (re-search-forward "^\\*Note" nil t)
- (replace-match " \\&")))
- (goto-char (point-min))
- (insert gnus-news-header-disclaimer)
- (goto-char (point-max))
- (insert gnus-news-trailer)
- (write-region (point-min) (point-max) outfile))))
-
-;;; gnus-news.el ends here
diff --git a/doc/misc/gnus-news.texi b/doc/misc/gnus-news.texi
deleted file mode 100644
index 9bf8d190416..00000000000
--- a/doc/misc/gnus-news.texi
+++ /dev/null
@@ -1,371 +0,0 @@
-@c -*-texinfo-*-
-
-@c Copyright (C) 2004-2019 Free Software Foundation, Inc.
-
-@c Permission is granted to anyone to make or distribute verbatim copies
-@c of this document as received, in any medium, provided that the
-@c copyright notice and this permission notice are preserved,
-@c thus giving the recipient permission to redistribute in turn.
-
-@c Permission is granted to distribute modified versions
-@c of this document, or of portions of it,
-@c under the above conditions, provided also that they
-@c carry prominent notices stating who last changed them.
-
-@c This file contains a list of news features Gnus. It is supposed to be
-@c included in 'gnus.texi'. 'GNUS-NEWS' is automatically generated from
-@c this file (see 'gnus-news.el').
-
-@itemize @bullet
-
-@item Supported Emacs versions
-The following Emacs versions are supported by No Gnus:
-@itemize @bullet
-
-@item Emacs 22 and up
-@item XEmacs 21.4
-@item XEmacs 21.5
-@item SXEmacs
-
-@end itemize
-
-@item Installation changes
-
-@itemize @bullet
-@item Upgrading from previous (stable) version if you have used No Gnus.
-
-If you have tried No Gnus (the unstable Gnus branch leading to this
-release) but went back to a stable version, be careful when upgrading
-to this version. In particular, you will probably want to remove the
-@file{~/News/marks} directory (perhaps selectively), so that flags are
-read from your @file{~/.newsrc.eld} instead of from the stale marks
-file, where this release will store flags for nntp. See a later entry
-for more information about nntp marks. Note that downgrading isn't
-safe in general.
-
-@item Incompatibility when switching from Emacs 23 to Emacs 22
-In Emacs 23, Gnus uses Emacs's new internal coding system @code{utf-8-emacs}
-for saving articles drafts and @file{~/.newsrc.eld}. These files may not
-be read correctly in Emacs 22 and below. If you want to use Gnus across
-different Emacs versions, you may set @code{mm-auto-save-coding-system}
-to @code{emacs-mule}.
-@c FIXME: Untested. (Or did anyone test it?)
-@c Cf. http://thread.gmane.org/gmane.emacs.gnus.general/66251/focus=66344
-
-@item Lisp files are now installed in @file{.../site-lisp/gnus/} by default.
-It defaulted to @file{.../site-lisp/} formerly. In addition to this,
-the new installer issues a warning if other Gnus installations which
-will shadow the latest one are detected. You can then remove those
-shadows manually or remove them using @code{make
-remove-installed-shadows}.
-
-@item The installation directory's name is allowed to have spaces and/or tabs.
-@end itemize
-
-@item New packages and libraries within Gnus
-
-@itemize @bullet
-
-@item New version of @code{nnimap}
-
-@code{nnimap} has been reimplemented in a mostly-compatible way. See
-the Gnus manual for a description of the new interface. In
-particular, @code{nnimap-inbox} and the client side split method has
-changed.
-
-@item Gnus includes the Emacs Lisp @acronym{SASL} library.
-
-This provides a clean @acronym{API} to @acronym{SASL} mechanisms from
-within Emacs. The user visible aspects of this, compared to the earlier
-situation, include support for @acronym{DIGEST}-@acronym{MD5} and
-@acronym{NTLM}. @xref{Top, ,Emacs SASL, sasl, Emacs SASL}.
-
-@item ManageSieve connections uses the @acronym{SASL} library by default.
-
-The primary change this brings is support for @acronym{DIGEST-MD5} and
-@acronym{NTLM}, when the server supports it.
-
-@item Gnus includes a password cache mechanism in password.el.
-
-It is enabled by default (see @code{password-cache}), with a short
-timeout of 16 seconds (see @code{password-cache-expiry}). If
-@acronym{PGG} is used as the @acronym{PGP} back end, the @acronym{PGP}
-passphrase is managed by this mechanism. Passwords for ManageSieve
-connections are managed by this mechanism, after querying the user
-about whether to do so.
-
-@item Using EasyPG with Gnus
-When EasyPG, is available, Gnus will use it instead of @acronym{PGG}.
-EasyPG is an Emacs user interface to GNU Privacy Guard. @xref{Top,
-,EasyPG Assistant user's manual, epa, EasyPG Assistant user's manual}.
-EasyPG is included in Emacs 23 and available separately as well.
-@end itemize
-
-@item Changes in group mode
-@c ************************
-
-@itemize @bullet
-
-@item
-Symbols like @code{gcc-self} now have the same precedence rules in
-@code{gnus-parameters} as other ``real'' variables: The last match
-wins instead of the first match.
-
-@item
-Old intermediate incoming mail files (@file{Incoming*}) are deleted
-after a couple of days, not immediately. @xref{Mail Source
-Customization}.
-(New in Gnus 5.10.10 / No Gnus 0.8)
-@c This entry is also present in the node "Oort Gnus".
-
-@end itemize
-
-@item Changes in summary and article mode
-
-@itemize @bullet
-
-@item There's now only one variable that determines how @acronym{HTML}
-is rendered: @code{mm-text-html-renderer}.
-
-@item Gnus now supports sticky article buffers. Those are article buffers
-that are not reused when you select another article. @xref{Sticky
-Articles}.
-
-@c @item Bookmarks
-@c FIXME: To be added
-
-@item Gnus can selectively display @samp{text/html} articles
-with a WWW browser with @kbd{K H}. @xref{MIME Commands}.
-
-@c gnus-registry-marks
-@c FIXME: To be added
-
-@item International host names (@acronym{IDNA}) can now be decoded
-inside article bodies using @kbd{W i}
-(@code{gnus-summary-idna-message}). This requires that GNU Libidn
-(@url{https://www.gnu.org/software/libidn/}) has been installed.
-@c FIXME: Also mention @code{message-use-idna}?
-
-@item The non-@acronym{ASCII} group names handling has been much
-improved. The back ends that fully support non-@acronym{ASCII} group
-names are now @code{nntp}, @code{nnml}, and @code{nnrss}. Also the
-agent, the cache, and the marks features work with those back ends.
-@xref{Non-ASCII Group Names}.
-
-@item Gnus now displays @acronym{DNS} master files sent as text/dns
-using dns-mode.
-
-@item Gnus supports new limiting commands in the Summary buffer:
-@kbd{/ r} (@code{gnus-summary-limit-to-replied}) and @kbd{/ R}
-(@code{gnus-summary-limit-to-recipient}). @xref{Limiting}.
-
-@item You can now fetch all ticked articles from the server using
-@kbd{Y t} (@code{gnus-summary-insert-ticked-articles}). @xref{Summary
-Generation Commands}.
-
-@item Gnus supports a new sort command in the Summary buffer:
-@kbd{C-c C-s C-t} (@code{gnus-summary-sort-by-recipient}). @xref{Summary
-Sorting}.
-
-@item @acronym{S/MIME} now features @acronym{LDAP} user certificate searches.
-You need to configure the server in @code{smime-ldap-host-list}.
-
-@item URLs inside Open@acronym{PGP} headers are retrieved and imported
-to your PGP key ring when you click on them.
-
-@item
-Picons can be displayed right from the textual address, see
-@code{gnus-picon-style}. @xref{Picons}.
-
-@item @acronym{ANSI} @acronym{SGR} control sequences can be transformed
-using @kbd{W A}.
-
-@acronym{ANSI} sequences are used in some Chinese hierarchies for
-highlighting articles (@code{gnus-article-treat-ansi-sequences}).
-
-@item Gnus now MIME decodes articles even when they lack "MIME-Version" header.
-This changes the default of @code{gnus-article-loose-mime}.
-
-@item @code{gnus-decay-scores} can be a regexp matching score files.
-For example, set it to @samp{\\.ADAPT\\'} and only adaptive score files
-will be decayed. @xref{Score Decays}.
-
-@item Strings prefixing to the @code{To} and @code{Newsgroup} headers in
-summary lines when using @code{gnus-ignored-from-addresses} can be
-customized with @code{gnus-summary-to-prefix} and
-@code{gnus-summary-newsgroup-prefix}. @xref{To From Newsgroups}.
-
-@item You can replace @acronym{MIME} parts with external bodies.
-See @code{gnus-mime-replace-part} and @code{gnus-article-replace-part}.
-@xref{MIME Commands}, @ref{Using MIME}.
-
-@item
-The option @code{mm-fill-flowed} can be used to disable treatment of
-format=flowed messages. Also, flowed text is disabled when sending
-inline @acronym{PGP} signed messages. @xref{Flowed text, ,Flowed text,
-emacs-mime, The Emacs MIME Manual}. (New in Gnus 5.10.7)
-@c This entry is also present in the node "Oort Gnus".
-
-@item Now the new command @kbd{S W}
-(@code{gnus-article-wide-reply-with-original}) for a wide reply in the
-article buffer yanks a text that is in the active region, if it is set,
-as well as the @kbd{R} (@code{gnus-article-reply-with-original}) command.
-Note that the @kbd{R} command in the article buffer no longer accepts a
-prefix argument, which was used to make it do a wide reply.
-@xref{Article Keymap}.
-
-@item The new command @kbd{C-h b}
-(@code{gnus-article-describe-bindings}) used in the article buffer now
-shows not only the article commands but also the real summary commands
-that are accessible from the article buffer.
-
-@end itemize
-
-@item Changes in Message mode
-
-@itemize @bullet
-@item Gnus now defaults to saving all outgoing messages in per-month
-nnfolder archives.
-
-@item Gnus now supports the ``hashcash'' client puzzle anti-spam mechanism.
-Use @code{(setq message-generate-hashcash t)} to enable.
-@xref{Hashcash}.
-
-@item You can now drag and drop attachments to the Message buffer.
-See @code{mml-dnd-protocol-alist} and @code{mml-dnd-attach-options}.
-@xref{MIME, ,MIME, message, Message Manual}.
-
-@item The option @code{message-yank-empty-prefix} now controls how
-empty lines are prefixed in cited text. @xref{Insertion Variables,
-,Insertion Variables, message, Message Manual}.
-
-@item Gnus uses narrowing to hide headers in Message buffers.
-The @code{References} header is hidden by default. To make all
-headers visible, use @code{(setq message-hidden-headers nil)}.
-@xref{Message Headers, ,Message Headers, message, Message Manual}.
-
-@item You can highlight different levels of citations like in the
-article buffer. See @code{gnus-message-highlight-citation}.
-
-@item @code{auto-fill-mode} is enabled by default in Message mode.
-See @code{message-fill-column}. @xref{Various Message Variables, ,
-Message Headers, message, Message Manual}.
-
-@item You can now store signature files in a special directory
-named @code{message-signature-directory}.
-
-@item The option @code{message-citation-line-format} controls the format
-of the "Whomever writes:" line. You need to set
-@code{message-citation-line-function} to
-@code{message-insert-formatted-citation-line} as well.
-@end itemize
-
-@item Changes in Browse Server mode
-
-@itemize @bullet
-@item Gnus' sophisticated subscription methods are now available in
-Browse Server buffers as well using the variable
-@code{gnus-browse-subscribe-newsgroup-method}.
-
-@end itemize
-
-
-@item Changes in back ends
-
-@itemize @bullet
-@item The nntp back end stores article marks in @file{~/News/marks}.
-
-The directory can be changed using the (customizable) variable
-@code{nntp-marks-directory}, and marks can be disabled using the
-(back end) variable @code{nntp-marks-is-evil}. The advantage of this
-is that you can copy @file{~/News/marks} (using rsync, scp or
-whatever) to another Gnus installation, and it will realize what
-articles you have read and marked. The data in @file{~/News/marks}
-has priority over the same data in @file{~/.newsrc.eld}.
-
-@item
-You can import and export your @acronym{RSS} subscriptions from
-@acronym{OPML} files. @xref{RSS}.
-
-@item @acronym{IMAP} identity (@acronym{RFC} 2971) is supported.
-
-By default, Gnus does not send any information about itself, but you can
-customize it using the variable @code{nnimap-id}.
-
-@item The @code{nnrss} back end now supports multilingual text.
-Non-@acronym{ASCII} group names for the @code{nnrss} groups are also
-supported. @xref{RSS}.
-
-@item Retrieving mail with @acronym{POP3} is supported over @acronym{SSL}/@acronym{TLS} and with StartTLS.
-
-@item The nnml back end allows other compression programs beside @file{gzip}
-for compressed message files. @xref{Mail Spool}.
-
-@item The nnml back end supports group compaction.
-
-This feature, accessible via the functions
-@code{gnus-group-compact-group} (@kbd{G z} in the group buffer) and
-@code{gnus-server-compact-server} (@kbd{z} in the server buffer)
-renumbers all articles in a group, starting from 1 and removing gaps.
-As a consequence, you get a correct total article count (until
-messages are deleted again).
-
-@c @item nnmairix.el
-@c FIXME
-
-@c @item nnir.el
-@c FIXME
-
-@end itemize
-
-@item Appearance
-@c Maybe it's not worth to separate this from "Miscellaneous"?
-
-@itemize @bullet
-
-@item The tool bar has been updated to use GNOME icons.
-You can also customize the tool bars: @kbd{M-x customize-apropos @key{RET}
--tool-bar$} should get you started. (Only for Emacs, not in XEmacs.)
-@c FIXME: Document this in the manual
-
-@item The tool bar icons are now (de)activated correctly
-in the group buffer, see the variable @code{gnus-group-update-tool-bar}.
-Its default value depends on your Emacs version.
-@c FIXME: Document this in the manual
-
-@item You can change the location of XEmacs's toolbars in Gnus buffers.
-See @code{gnus-use-toolbar} and @code{message-use-toolbar}.
-
-@end itemize
-
-@item Miscellaneous changes
-
-@itemize @bullet
-@item Having edited the select-method for the foreign server in the
-server buffer is immediately reflected to the subscription of the groups
-which use the server in question. For instance, if you change
-@code{nntp-via-address} into @samp{bar.example.com} from
-@samp{foo.example.com}, Gnus will connect to the news host by way of the
-intermediate host @samp{bar.example.com} from next time.
-
-@item The @file{all.SCORE} file can be edited from the group buffer
-using @kbd{W e}.
-
-@item You can set @code{gnus-mark-copied-or-moved-articles-as-expirable}
-to a non-@code{nil} value so that articles that have been read may be
-marked as expirable automatically when copying or moving them to a group
-that has auto-expire turned on. The default is @code{nil} and copying
-and moving of articles behave as before; i.e., the expirable marks will
-be unchanged except that the marks will be removed when copying or
-moving articles to a group that has not turned auto-expire on.
-@xref{Expiring Mail}.
-
-@item NoCeM support has been removed.
-
-@item Carpal mode has been removed.
-
-@end itemize
-
-@end itemize
-
-@c gnus-news.texi ends here.
diff --git a/doc/misc/gnus-overrides.texi b/doc/misc/gnus-overrides.texi
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/doc/misc/gnus-overrides.texi
+++ /dev/null
diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi
index 4ee80eacb2e..b9c91a02a3a 100644
--- a/doc/misc/gnus.texi
+++ b/doc/misc/gnus.texi
@@ -1,7 +1,5 @@
\input texinfo
-@include gnus-overrides.texi
-
@setfilename ../../info/gnus.info
@settitle Gnus Manual
@include docstyle.texi
@@ -3102,6 +3100,21 @@ interest in relation to the sieve parameter.
The Sieve language is described in RFC 3028. @xref{Top, Emacs Sieve,
Top, sieve, Emacs Sieve}.
+@item match-list
+@cindex match-list
+If this parameter is set to @code{t} and @code{nnmail-split-method} is
+set to @code{gnus-group-split}, Gnus will match @code{to-address},
+@code{to-list}, @code{extra-aliases} and @code{split-regexp} against
+the @code{list} split abbreviation. The split regexp is modified to
+match either a @code{@@} or a dot @code{.} in mail addresses to
+conform to RFC2919 @code{List-ID}.
+
+See @code{nnmail-split-abbrev-alist} for the regular expression
+matching mailing-list headers.
+
+See @pxref{Group Mail Splitting} to automatically split on group
+parameters.
+
@item (agent parameters)
If the agent has been enabled, you can set any of its parameters to
control the behavior of the agent in individual groups. See Agent
@@ -5577,7 +5590,7 @@ command uses the process/prefix convention.
Mail a wide reply to the author of the current article
(@code{gnus-summary-wide-reply}). A @dfn{wide reply} is a reply that
goes out to all people listed in the @code{To}, @code{From} (or
-@code{Reply-to}) and @code{Cc} headers. If @code{Mail-Followup-To} is
+@code{Reply-To}) and @code{Cc} headers. If @code{Mail-Followup-To} is
present, that's used instead.
@item S W
@@ -5601,7 +5614,7 @@ message to the mailing list, and include the original message
Mail a very wide reply to the author of the current article
(@code{gnus-summary-wide-reply}). A @dfn{very wide reply} is a reply
that goes out to all people listed in the @code{To}, @code{From} (or
-@code{Reply-to}) and @code{Cc} headers in all the process/prefixed
+@code{Reply-To}) and @code{Cc} headers in all the process/prefixed
articles. This command uses the process/prefix convention.
@item S V
@@ -5643,8 +5656,7 @@ as an rfc822 @acronym{MIME} section; if the prefix is 3, decode message and
forward as an rfc822 @acronym{MIME} section; if the prefix is 4, forward message
directly inline; otherwise, the message is forwarded as no prefix given
but use the flipped value of (@code{message-forward-as-mime}). By
-default, the message is decoded and forwarded as an rfc822 @acronym{MIME}
-section.
+default, the forwarded message is inlined into the mail.
@item S m
@itemx m
@@ -5836,6 +5848,15 @@ buffer (@code{gnus-summary-yank-message}). This command prompts for
what message buffer you want to yank into, and understands the
process/prefix convention (@pxref{Process/Prefix}).
+@item S A
+@kindex S A @r{(Summary)}
+@findex gnus-summary-attach-article
+Attach the current article into an already existing Message
+composition buffer (@code{gnus-summary-attach-message}). If no such
+buffer exists, a new one is created. This command prompts for what
+message buffer you want to yank into, and understands the
+process/prefix convention (@pxref{Process/Prefix}).
+
@end table
@@ -6657,7 +6678,8 @@ Limit the summary buffer to the unseen articles
@kindex / v @r{(Summary)}
@findex gnus-summary-limit-to-score
Limit the summary buffer to articles that have a score at or above some
-score (@code{gnus-summary-limit-to-score}).
+score (@code{gnus-summary-limit-to-score}). If given a prefix, below
+some score.
@item / p
@kindex / p @r{(Summary)}
@@ -9791,9 +9813,6 @@ this command passes the @acronym{HTML} content to the browser without
eliminating these ``web bugs'' you should only use it for mails from
trusted senders.
-If you always want to display @acronym{HTML} parts in the browser, set
-@code{mm-text-html-renderer} to @code{nil}.
-
This command creates temporary files to pass @acronym{HTML} contents
including images if any to the browser, and deletes them when exiting
the group (if you want).
@@ -13209,6 +13228,11 @@ Also @pxref{Formatting Variables}.
@subsection Server Commands
@cindex server commands
+The following keybinding are available in the server buffer. Be aware
+that some of the commands will only work on servers that you've added
+through this interface (with @kbd{a}), not with servers you've defined
+in your init files.
+
@table @kbd
@item v
@@ -14294,6 +14318,12 @@ fetch all textual parts, while leaving the rest on the server.
If non-@code{nil}, record all @acronym{IMAP} commands in the
@samp{"*imap log*"} buffer.
+@item nnimap-use-namespaces
+If non-@code{nil}, omit the IMAP namespace prefix in nnimap group
+names. If your IMAP mailboxes are called something like @samp{INBOX}
+and @samp{INBOX.Lists.emacs}, but you'd like the nnimap group names to
+be @samp{INBOX} and @samp{Lists.emacs}, you should enable this option.
+
@end table
@@ -15469,6 +15499,9 @@ Matches the @samp{To}, @samp{Cc}, @samp{Apparently-To},
@samp{Resent-To} and @samp{Resent-Cc} fields.
@item any
Is the union of the @code{from} and @code{to} entries.
+@item list
+Matches the @samp{List-ID}, @samp{List-Post}, @samp{X-Mailing-List},
+@samp{X-BeenThere} and @samp{X-Loop} fields.
@end table
@vindex nnmail-split-fancy-syntax-table
@@ -18479,7 +18512,7 @@ something along the lines of the following:
(defun my-article-old-p ()
"Say whether an article is old."
(< (time-to-days (date-to-time (mail-header-date gnus-headers)))
- (- (time-to-days (current-time)) gnus-agent-expire-days)))
+ (- (time-to-days nil) gnus-agent-expire-days)))
@end lisp
with the predicate then defined as:
@@ -19467,8 +19500,8 @@ score file and edit it.
@item V w
@kindex V w @r{(Summary)}
-@findex gnus-score-find-favourite-words
-List words used in scoring (@code{gnus-score-find-favourite-words}).
+@findex gnus-score-find-favorite-words
+List words used in scoring (@code{gnus-score-find-favorite-words}).
@item V R
@kindex V R @r{(Summary)}
@@ -21434,6 +21467,18 @@ The prefix to remove from each file name returned by notmuch in order
to get a group name (albeit with @samp{/} instead of @samp{.}). This
is a regular expression.
+@item nnir-notmuch-filter-group-names-function
+A function used to transform the names of groups being searched in,
+for use as a ``path:'' search keyword for notmuch. If nil, the
+default, ``path:'' keywords are not used. Otherwise, this should be a
+callable which accepts a single group name and returns a transformed
+name as notmuch expects to see it. In many mail backends, for
+instance, dots in group names must be converted to forward slashes: to
+achieve this, set this option to
+@example
+(lambda (g) (replace-regexp-in-string "\\." "/" g))
+@end example
+
@end table
@@ -25855,13 +25900,13 @@ Reset: (setq spam-stat (make-hash-table :test 'equal))
Learn spam: (spam-stat-process-spam-directory "~/Mail/mail/spam")
Learn non-spam: (spam-stat-process-non-spam-directory "~/Mail/mail/misc")
Save table: (spam-stat-save)
-File size: (nth 7 (file-attributes spam-stat-file))
+File size: (file-attribute-size (file-attributes spam-stat-file))
Number of words: (hash-table-count spam-stat)
Test spam: (spam-stat-test-directory "~/Mail/mail/spam")
Test non-spam: (spam-stat-test-directory "~/Mail/mail/misc")
Reduce table size: (spam-stat-reduce-size)
Save table: (spam-stat-save)
-File size: (nth 7 (file-attributes spam-stat-file))
+File size: (file-attribute-size (file-attributes spam-stat-file))
Number of words: (hash-table-count spam-stat)
Test spam: (spam-stat-test-directory "~/Mail/mail/spam")
Test non-spam: (spam-stat-test-directory "~/Mail/mail/misc")
@@ -27171,6 +27216,8 @@ actually are people who are using Gnus. Who'd'a thunk it!
* Ma Gnus:: Celebrating 25 years of Gnus.
@end menu
+For summaries of more recent changes, see the normal Emacs @file{NEWS} files.
+
These lists are, of course, just @emph{short} overviews of the
@emph{most} important new features. No, really. There are tons more.
Yes, we have feeping creaturism in full effect.
@@ -28541,7 +28588,358 @@ A new command which starts Gnus offline in slave mode.
New features in No Gnus:
@c FIXME: Gnus 5.12?
-@include gnus-news.texi
+@itemize @bullet
+
+@item Supported Emacs versions
+The following Emacs versions are supported by No Gnus:
+@itemize @bullet
+
+@item Emacs 22 and up
+@item XEmacs 21.4
+@item XEmacs 21.5
+@item SXEmacs
+
+@end itemize
+
+@item Installation changes
+
+@itemize @bullet
+@item Upgrading from previous (stable) version if you have used No Gnus.
+
+If you have tried No Gnus (the unstable Gnus branch leading to this
+release) but went back to a stable version, be careful when upgrading
+to this version. In particular, you will probably want to remove the
+@file{~/News/marks} directory (perhaps selectively), so that flags are
+read from your @file{~/.newsrc.eld} instead of from the stale marks
+file, where this release will store flags for nntp. See a later entry
+for more information about nntp marks. Note that downgrading isn't
+safe in general.
+
+@item Incompatibility when switching from Emacs 23 to Emacs 22
+In Emacs 23, Gnus uses Emacs's new internal coding system @code{utf-8-emacs}
+for saving articles drafts and @file{~/.newsrc.eld}. These files may not
+be read correctly in Emacs 22 and below. If you want to use Gnus across
+different Emacs versions, you may set @code{mm-auto-save-coding-system}
+to @code{emacs-mule}.
+@c FIXME: Untested. (Or did anyone test it?)
+@c Cf. http://thread.gmane.org/gmane.emacs.gnus.general/66251/focus=66344
+
+@item Lisp files are now installed in @file{.../site-lisp/gnus/} by default.
+It defaulted to @file{.../site-lisp/} formerly. In addition to this,
+the new installer issues a warning if other Gnus installations which
+will shadow the latest one are detected. You can then remove those
+shadows manually or remove them using @code{make
+remove-installed-shadows}.
+
+@item The installation directory's name is allowed to have spaces and/or tabs.
+@end itemize
+
+@item New packages and libraries within Gnus
+
+@itemize @bullet
+
+@item New version of @code{nnimap}
+
+@code{nnimap} has been reimplemented in a mostly-compatible way. See
+the Gnus manual for a description of the new interface. In
+particular, @code{nnimap-inbox} and the client side split method has
+changed.
+
+@item Gnus includes the Emacs Lisp @acronym{SASL} library.
+
+This provides a clean @acronym{API} to @acronym{SASL} mechanisms from
+within Emacs. The user visible aspects of this, compared to the earlier
+situation, include support for @acronym{DIGEST}-@acronym{MD5} and
+@acronym{NTLM}. @xref{Top, ,Emacs SASL, sasl, Emacs SASL}.
+
+@item ManageSieve connections uses the @acronym{SASL} library by default.
+
+The primary change this brings is support for @acronym{DIGEST-MD5} and
+@acronym{NTLM}, when the server supports it.
+
+@item Gnus includes a password cache mechanism in password.el.
+
+It is enabled by default (see @code{password-cache}), with a short
+timeout of 16 seconds (see @code{password-cache-expiry}). If
+@acronym{PGG} is used as the @acronym{PGP} back end, the @acronym{PGP}
+passphrase is managed by this mechanism. Passwords for ManageSieve
+connections are managed by this mechanism, after querying the user
+about whether to do so.
+
+@item Using EasyPG with Gnus
+When EasyPG, is available, Gnus will use it instead of @acronym{PGG}.
+EasyPG is an Emacs user interface to GNU Privacy Guard. @xref{Top,
+,EasyPG Assistant user's manual, epa, EasyPG Assistant user's manual}.
+EasyPG is included in Emacs 23 and available separately as well.
+@end itemize
+
+@item Changes in group mode
+@c ************************
+
+@itemize @bullet
+
+@item
+Symbols like @code{gcc-self} now have the same precedence rules in
+@code{gnus-parameters} as other ``real'' variables: The last match
+wins instead of the first match.
+
+@item
+Old intermediate incoming mail files (@file{Incoming*}) are deleted
+after a couple of days, not immediately. @xref{Mail Source
+Customization}.
+(New in Gnus 5.10.10 / No Gnus 0.8)
+@c This entry is also present in the node "Oort Gnus".
+
+@end itemize
+
+@item Changes in summary and article mode
+
+@itemize @bullet
+
+@item There's now only one variable that determines how @acronym{HTML}
+is rendered: @code{mm-text-html-renderer}.
+
+@item Gnus now supports sticky article buffers. Those are article buffers
+that are not reused when you select another article. @xref{Sticky
+Articles}.
+
+@c @item Bookmarks
+@c FIXME: To be added
+
+@item Gnus can selectively display @samp{text/html} articles
+with a WWW browser with @kbd{K H}. @xref{MIME Commands}.
+
+@c gnus-registry-marks
+@c FIXME: To be added
+
+@item International host names (@acronym{IDNA}) can now be decoded
+inside article bodies using @kbd{W i}
+(@code{gnus-summary-idna-message}). This requires that GNU Libidn
+(@url{https://www.gnu.org/software/libidn/}) has been installed.
+@c FIXME: Also mention @code{message-use-idna}?
+
+@item The non-@acronym{ASCII} group names handling has been much
+improved. The back ends that fully support non-@acronym{ASCII} group
+names are now @code{nntp}, @code{nnml}, and @code{nnrss}. Also the
+agent, the cache, and the marks features work with those back ends.
+@xref{Non-ASCII Group Names}.
+
+@item Gnus now displays @acronym{DNS} master files sent as text/dns
+using dns-mode.
+
+@item Gnus supports new limiting commands in the Summary buffer:
+@kbd{/ r} (@code{gnus-summary-limit-to-replied}) and @kbd{/ R}
+(@code{gnus-summary-limit-to-recipient}). @xref{Limiting}.
+
+@item You can now fetch all ticked articles from the server using
+@kbd{Y t} (@code{gnus-summary-insert-ticked-articles}). @xref{Summary
+Generation Commands}.
+
+@item Gnus supports a new sort command in the Summary buffer:
+@kbd{C-c C-s C-t} (@code{gnus-summary-sort-by-recipient}). @xref{Summary
+Sorting}.
+
+@item @acronym{S/MIME} now features @acronym{LDAP} user certificate searches.
+You need to configure the server in @code{smime-ldap-host-list}.
+
+@item URLs inside Open@acronym{PGP} headers are retrieved and imported
+to your PGP key ring when you click on them.
+
+@item
+Picons can be displayed right from the textual address, see
+@code{gnus-picon-style}. @xref{Picons}.
+
+@item @acronym{ANSI} @acronym{SGR} control sequences can be transformed
+using @kbd{W A}.
+
+@acronym{ANSI} sequences are used in some Chinese hierarchies for
+highlighting articles (@code{gnus-article-treat-ansi-sequences}).
+
+@item Gnus now MIME decodes articles even when they lack "MIME-Version" header.
+This changes the default of @code{gnus-article-loose-mime}.
+
+@item @code{gnus-decay-scores} can be a regexp matching score files.
+For example, set it to @samp{\\.ADAPT\\'} and only adaptive score files
+will be decayed. @xref{Score Decays}.
+
+@item Strings prefixing to the @code{To} and @code{Newsgroup} headers in
+summary lines when using @code{gnus-ignored-from-addresses} can be
+customized with @code{gnus-summary-to-prefix} and
+@code{gnus-summary-newsgroup-prefix}. @xref{To From Newsgroups}.
+
+@item You can replace @acronym{MIME} parts with external bodies.
+See @code{gnus-mime-replace-part} and @code{gnus-article-replace-part}.
+@xref{MIME Commands}, @ref{Using MIME}.
+
+@item
+The option @code{mm-fill-flowed} can be used to disable treatment of
+format=flowed messages. Also, flowed text is disabled when sending
+inline @acronym{PGP} signed messages. @xref{Flowed text, ,Flowed text,
+emacs-mime, The Emacs MIME Manual}. (New in Gnus 5.10.7)
+@c This entry is also present in the node "Oort Gnus".
+
+@item Now the new command @kbd{S W}
+(@code{gnus-article-wide-reply-with-original}) for a wide reply in the
+article buffer yanks a text that is in the active region, if it is set,
+as well as the @kbd{R} (@code{gnus-article-reply-with-original}) command.
+Note that the @kbd{R} command in the article buffer no longer accepts a
+prefix argument, which was used to make it do a wide reply.
+@xref{Article Keymap}.
+
+@item The new command @kbd{C-h b}
+(@code{gnus-article-describe-bindings}) used in the article buffer now
+shows not only the article commands but also the real summary commands
+that are accessible from the article buffer.
+
+@end itemize
+
+@item Changes in Message mode
+
+@itemize @bullet
+@item Gnus now defaults to saving all outgoing messages in per-month
+nnfolder archives.
+
+@item Gnus now supports the ``hashcash'' client puzzle anti-spam mechanism.
+Use @code{(setq message-generate-hashcash t)} to enable.
+@xref{Hashcash}.
+
+@item You can now drag and drop attachments to the Message buffer.
+See @code{mml-dnd-protocol-alist} and @code{mml-dnd-attach-options}.
+@xref{MIME, ,MIME, message, Message Manual}.
+
+@item The option @code{message-yank-empty-prefix} now controls how
+empty lines are prefixed in cited text. @xref{Insertion Variables,
+,Insertion Variables, message, Message Manual}.
+
+@item Gnus uses narrowing to hide headers in Message buffers.
+The @code{References} header is hidden by default. To make all
+headers visible, use @code{(setq message-hidden-headers nil)}.
+@xref{Message Headers, ,Message Headers, message, Message Manual}.
+
+@item You can highlight different levels of citations like in the
+article buffer. See @code{gnus-message-highlight-citation}.
+
+@item @code{auto-fill-mode} is enabled by default in Message mode.
+See @code{message-fill-column}. @xref{Various Message Variables, ,
+Message Headers, message, Message Manual}.
+
+@item You can now store signature files in a special directory
+named @code{message-signature-directory}.
+
+@item The option @code{message-citation-line-format} controls the format
+of the "Whomever writes:" line. You need to set
+@code{message-citation-line-function} to
+@code{message-insert-formatted-citation-line} as well.
+@end itemize
+
+@item Changes in Browse Server mode
+
+@itemize @bullet
+@item Gnus' sophisticated subscription methods are now available in
+Browse Server buffers as well using the variable
+@code{gnus-browse-subscribe-newsgroup-method}.
+
+@end itemize
+
+
+@item Changes in back ends
+
+@itemize @bullet
+@item The nntp back end stores article marks in @file{~/News/marks}.
+
+The directory can be changed using the (customizable) variable
+@code{nntp-marks-directory}, and marks can be disabled using the
+(back end) variable @code{nntp-marks-is-evil}. The advantage of this
+is that you can copy @file{~/News/marks} (using rsync, scp or
+whatever) to another Gnus installation, and it will realize what
+articles you have read and marked. The data in @file{~/News/marks}
+has priority over the same data in @file{~/.newsrc.eld}.
+
+@item
+You can import and export your @acronym{RSS} subscriptions from
+@acronym{OPML} files. @xref{RSS}.
+
+@item @acronym{IMAP} identity (@acronym{RFC} 2971) is supported.
+
+By default, Gnus does not send any information about itself, but you can
+customize it using the variable @code{nnimap-id}.
+
+@item The @code{nnrss} back end now supports multilingual text.
+Non-@acronym{ASCII} group names for the @code{nnrss} groups are also
+supported. @xref{RSS}.
+
+@item Retrieving mail with @acronym{POP3} is supported over @acronym{SSL}/@acronym{TLS} and with StartTLS.
+
+@item The nnml back end allows other compression programs beside @file{gzip}
+for compressed message files. @xref{Mail Spool}.
+
+@item The nnml back end supports group compaction.
+
+This feature, accessible via the functions
+@code{gnus-group-compact-group} (@kbd{G z} in the group buffer) and
+@code{gnus-server-compact-server} (@kbd{z} in the server buffer)
+renumbers all articles in a group, starting from 1 and removing gaps.
+As a consequence, you get a correct total article count (until
+messages are deleted again).
+
+@c @item nnmairix.el
+@c FIXME
+
+@c @item nnir.el
+@c FIXME
+
+@end itemize
+
+@item Appearance
+@c Maybe it's not worth to separate this from "Miscellaneous"?
+
+@itemize @bullet
+
+@item The tool bar has been updated to use GNOME icons.
+You can also customize the tool bars: @kbd{M-x customize-apropos @key{RET}
+-tool-bar$} should get you started. (Only for Emacs, not in XEmacs.)
+@c FIXME: Document this in the manual
+
+@item The tool bar icons are now (de)activated correctly
+in the group buffer, see the variable @code{gnus-group-update-tool-bar}.
+Its default value depends on your Emacs version.
+@c FIXME: Document this in the manual
+
+@item You can change the location of XEmacs's toolbars in Gnus buffers.
+See @code{gnus-use-toolbar} and @code{message-use-toolbar}.
+
+@end itemize
+
+@item Miscellaneous changes
+
+@itemize @bullet
+@item Having edited the select-method for the foreign server in the
+server buffer is immediately reflected to the subscription of the groups
+which use the server in question. For instance, if you change
+@code{nntp-via-address} into @samp{bar.example.com} from
+@samp{foo.example.com}, Gnus will connect to the news host by way of the
+intermediate host @samp{bar.example.com} from next time.
+
+@item The @file{all.SCORE} file can be edited from the group buffer
+using @kbd{W e}.
+
+@item You can set @code{gnus-mark-copied-or-moved-articles-as-expirable}
+to a non-@code{nil} value so that articles that have been read may be
+marked as expirable automatically when copying or moving them to a group
+that has auto-expire turned on. The default is @code{nil} and copying
+and moving of articles behave as before; i.e., the expirable marks will
+be unchanged except that the marks will be removed when copying or
+moving articles to a group that has not turned auto-expire on.
+@xref{Expiring Mail}.
+
+@item NoCeM support has been removed.
+
+@item Carpal mode has been removed.
+
+@end itemize
+
+@end itemize
+
@node Ma Gnus
@subsubsection Ma Gnus
diff --git a/doc/misc/message.texi b/doc/misc/message.texi
index 21a57590066..7089bb5dfe3 100644
--- a/doc/misc/message.texi
+++ b/doc/misc/message.texi
@@ -1,7 +1,5 @@
\input texinfo @c -*-texinfo-*-
-@include gnus-overrides.texi
-
@setfilename ../../info/message.info
@settitle Message Manual
@include docstyle.texi
@@ -162,7 +160,7 @@ header should be. If it does not, it should just return @code{nil}, and
the normal methods for determining the To header will be used.
Each list element should be a cons, where the @sc{car} should be the
-name of a header (e.g., @code{Cc}) and the @sc{cdr} should be the header
+name of a header (e.g., @code{CC}) and the @sc{cdr} should be the header
value (e.g., @samp{larsi@@ifi.uio.no}). All these headers will be
inserted into the head of the outgoing mail.
@@ -174,7 +172,7 @@ inserted into the head of the outgoing mail.
The @code{message-wide-reply} pops up a message buffer that's a wide
reply to the message in the current buffer. A @dfn{wide reply} is a
reply that goes out to all people listed in the @code{To}, @code{From}
-(or @code{Reply-to}) and @code{Cc} headers.
+(or @code{Reply-To}) and @code{CC} headers.
@vindex message-wide-reply-to-function
Message uses the normal methods to determine where wide replies are to go,
@@ -185,7 +183,7 @@ but you can change the behavior to suit your needs by fiddling with the
@vindex message-dont-reply-to-names
Addresses that match the @code{message-dont-reply-to-names} regular
expression (or list of regular expressions or a predicate function)
-will be removed from the @code{Cc} header. A value of @code{nil} means
+will be removed from the @code{CC} header. A value of @code{nil} means
to exclude only your email address.
@vindex message-prune-recipient-rules
@@ -199,7 +197,7 @@ to match addresses to be pruned.
It's complicated to explain, but it's easy to use.
For instance, if you get an email from @samp{foo@@example.org}, but
-@samp{foo@@zot.example.org} is also in the @code{Cc} list, then your
+@samp{foo@@zot.example.org} is also in the @code{CC} list, then your
wide reply will go out to both these addresses, since they are unique.
To avoid this, do something like the following:
@@ -316,7 +314,7 @@ when forwarding a message.
@item message-forward-included-headers
@vindex message-forward-included-headers
In non-@code{nil}, only headers that match this regexp will be kept
-when forwarding a message.
+when forwarding a message. This can also be a list of regexps.
@item message-make-forward-subject-function
@vindex message-make-forward-subject-function
@@ -345,10 +343,10 @@ constructed. The default value is @code{nil}.
@item message-forward-as-mime
@vindex message-forward-as-mime
-If this variable is @code{t} (the default), forwarded messages are
-included as inline @acronym{MIME} RFC822 parts. If it's @code{nil}, forwarded
-messages will just be copied inline to the new message, like previous,
-non @acronym{MIME}-savvy versions of Gnus would do.
+If this variable is @code{t}, forwarded messages are included as
+inline @acronym{MIME} RFC822 parts. If it's @code{nil} (the default),
+forwarded messages will just be copied inline to the new message, like
+previous, non @acronym{MIME}-savvy versions of Gnus would do.
@item message-forward-before-signature
@vindex message-forward-before-signature
@@ -487,10 +485,10 @@ MFT field. If there is one, it is left alone. (Except if it's empty;
in that case, the field is removed and is not replaced with an
automatically generated one. This lets you disable MFT generation on a
per-message basis.) If there is none, then the list of recipient
-addresses (in the To: and Cc: headers) is checked to see if one of them
+addresses (in the To: and CC: headers) is checked to see if one of them
is a list address you are subscribed to. If none of them is a list
address, then no MFT is generated; otherwise, a MFT is added to the
-other headers and set to the value of all addresses in To: and Cc:
+other headers and set to the value of all addresses in To: and CC:
@kindex C-c C-f C-a
@findex message-generate-unsubscribed-mail-followup-to
@@ -516,7 +514,7 @@ header, Gnus' action will depend on the value of the variable
@table @code
@item use
- Always honor MFTs. The To: and Cc: headers in your followup will be
+ Always honor MFTs. The To: and CC: headers in your followup will be
derived from the MFT header of the original post. This is the default.
@item nil
@@ -593,17 +591,17 @@ in the key binding is for Originator.)
@item C-c C-f C-b
@kindex C-c C-f C-b
@findex message-goto-bcc
-Go to the @code{Bcc} header (@code{message-goto-bcc}).
+Go to the @code{BCC} header (@code{message-goto-bcc}).
@item C-c C-f C-w
@kindex C-c C-f C-w
@findex message-goto-fcc
-Go to the @code{Fcc} header (@code{message-goto-fcc}).
+Go to the @code{FCC} header (@code{message-goto-fcc}).
@item C-c C-f C-c
@kindex C-c C-f C-c
@findex message-goto-cc
-Go to the @code{Cc} header (@code{message-goto-cc}).
+Go to the @code{CC} header (@code{message-goto-cc}).
@item C-c C-f C-s
@kindex C-c C-f C-s
@@ -662,7 +660,7 @@ fetches the contents of the @samp{To:} header in the current mail
buffer, and appends the current @code{user-mail-address}.
If the optional argument @code{include-cc} is non-@code{nil}, the
-addresses in the @samp{Cc:} header are also put into the
+addresses in the @samp{CC:} header are also put into the
@samp{Mail-Followup-To:} header.
@end table
@@ -696,7 +694,7 @@ or @code{Newsgroups} header of the article you're replying to
@kindex C-c C-l
@findex message-to-list-only
Send a message to the list only. Remove all addresses but the list
-address from @code{To:} and @code{Cc:} headers.
+address from @code{To:} and @code{CC:} headers.
@item C-c M-n
@kindex C-c M-n
@@ -746,13 +744,13 @@ by the @code{message-cross-post-note-function} variable.
@item C-c C-f t
@kindex C-c C-f t
@findex message-reduce-to-to-cc
-Replace contents of @samp{To} header with contents of @samp{Cc}
-header (or the @samp{Bcc} header, if there is no @samp{Cc} header).
+Replace contents of @samp{To} header with contents of @samp{CC}
+header (or the @samp{BCC} header, if there is no @samp{CC} header).
@item C-c C-f w
@kindex C-c C-f w
@findex message-insert-wide-reply
-Insert @samp{To} and @samp{Cc} headers as if you were doing a wide
+Insert @samp{To} and @samp{CC} headers as if you were doing a wide
reply even if the message was not made for a wide reply first.
@item C-c C-f a
@@ -902,7 +900,7 @@ found in RFC 3490.
Message is a @acronym{IDNA}-compliant posting agent. The user
generally doesn't have to do anything to make the @acronym{IDNA}
happen---Message will encode non-@acronym{ASCII} domain names in @code{From},
-@code{To}, and @code{Cc} headers automatically.
+@code{To}, and @code{CC} headers automatically.
Until @acronym{IDNA} becomes more well known, Message queries you
whether @acronym{IDNA} encoding of the domain name really should
@@ -1011,7 +1009,7 @@ and/or encrypted messages as explained in the following.
* Passphrase caching:: How to cache passphrases
* PGP Compatibility:: Compatibility with older implementations
* Encrypt-to-self:: Reading your own encrypted messages
-* Bcc Warning:: Do not use encryption with Bcc headers
+* BCC Warning:: Do not use encryption with BCC headers
@end menu
@node Signing and encryption
@@ -1300,7 +1298,7 @@ information about the problem.)
@subsection Encrypt-to-self
By default, messages are encrypted to all recipients (@code{To},
-@code{Cc}, @code{Bcc} headers). Thus, you will not be able to decrypt
+@code{CC}, @code{BCC} headers). Thus, you will not be able to decrypt
your own messages. To make sure that messages are also encrypted to
your own key(s), several alternative solutions exist:
@enumerate
@@ -1318,17 +1316,17 @@ OpenPGP) or @code{mml-secure-smime-encrypt-to-self} (for
@acronym{S/MIME} with EasyPG).
@end enumerate
-@node Bcc Warning
-@subsection Bcc Warning
+@node BCC Warning
+@subsection BCC Warning
-The @code{Bcc} header is meant to hide recipients of messages.
+The @code{BCC} header is meant to hide recipients of messages.
However, when encrypted messages are used, the e-mail addresses of all
-@code{Bcc}-headers are given away to all recipients without
+@code{BCC}-headers are given away to all recipients without
warning, which is a bug.
@vindex mml-secure-safe-bcc-list
-But now Message got to warn if @code{Bcc} recipients are found in an
+But now Message got to warn if @code{BCC} recipients are found in an
encrypted message when you are just about to send it. If you are sure
-those @code{Bcc} addresses are safe to expose, set the
+those @code{BCC} addresses are safe to expose, set the
@code{mml-secure-safe-bcc-list} variable, that is a list of e-mail
addresses. See
@uref{https://debbugs.gnu.org/cgi/bugreport.cgi?bug=18718}.
@@ -1468,20 +1466,24 @@ alias ding "ding@@ifi.uio.no (ding mailing list)"
@end example
After adding lines like this to your @file{~/.mailrc} file, you should
-be able to just write @samp{lmi} in the @code{To} or @code{Cc} (and so
+be able to just write @samp{lmi} in the @code{To} or @code{CC} (and so
on) headers and press @kbd{SPC} to expand the alias.
No expansion will be performed upon sending of the message---all
expansions have to be done explicitly.
If you're using @code{ecomplete}, all addresses from @code{To} and
-@code{Cc} headers will automatically be put into the
+@code{CC} headers will automatically be put into the
@file{~/.ecompleterc} file. When you enter text in the @code{To} and
-@code{Cc} headers, @code{ecomplete} will check out the values stored
+@code{CC} headers, @code{ecomplete} will check out the values stored
there and ``electrically'' say what completions are possible. To
choose one of these completions, use the @kbd{M-n} command to move
-down to the list. Use @kbd{M-n} and @kbd{M-p} to move down and up the
-list, and @kbd{RET} to choose a completion.
+down to the list. Use @kbd{@key{DOWN}} or @kbd{M-n} and
+@kbd{@key{UP}} or @kbd{M-p} to move down and up the list, and
+@kbd{@key{RET}} to choose a completion.
+
+The @code{ecomplete-sort-predicate} variable controls how
+@code{ecomplete} matches are sorted.
@node Spelling
@section Spelling
@@ -1677,7 +1679,7 @@ trailing old subject. In this case,
@item message-alternative-emails
@vindex message-alternative-emails
Regexp or predicate function matching alternative email addresses.
-The first address in the To, Cc or From headers of the original
+The first address in the To, CC or From headers of the original
article matching this variable is used as the From field of outgoing
messages, replacing the default From value.
@@ -1697,7 +1699,7 @@ off @code{message-setup-hook}.
@item message-allow-no-recipients
@vindex message-allow-no-recipients
Specifies what to do when there are no recipients other than
-@code{Gcc} or @code{Fcc}. If it is @code{always}, the posting is
+@code{Gcc} or @code{FCC}. If it is @code{always}, the posting is
allowed. If it is @code{never}, the posting is not allowed. If it is
@code{ask} (the default), you are prompted.
@@ -1709,7 +1711,7 @@ hidden when composing a message.
@lisp
(setq message-hidden-headers
- '(not "From" "Subject" "To" "Cc" "Newsgroups"))
+ '(not "From" "Subject" "To" "CC" "Newsgroups"))
@end lisp
Headers are hidden using narrowing, you can use @kbd{M-x widen} to
@@ -1718,9 +1720,9 @@ expose them in the buffer.
@item message-header-synonyms
@vindex message-header-synonyms
A list of lists of header synonyms. E.g., if this list contains a
-member list with elements @code{Cc} and @code{To}, then
+member list with elements @code{CC} and @code{To}, then
@code{message-carefully-insert-headers} will not insert a @code{To}
-header when the message is already @code{Cc}ed to the recipient.
+header when the message is already @code{CC}ed to the recipient.
@end table
@@ -1738,7 +1740,7 @@ header when the message is already @code{Cc}ed to the recipient.
@item message-ignored-mail-headers
@vindex message-ignored-mail-headers
Regexp of headers to be removed before mailing. The default is@*
-@samp{^[GF]cc:\\|^Resent-Fcc:\\|^Xref:\\|^X-Draft-From:\\|@*
+@samp{^[GF]cc:\\|^Resent-FCC:\\|^Xref:\\|^X-Draft-From:\\|@*
^X-Gnus-Agent-Meta-Information:}.
@item message-default-mail-headers
@@ -2052,7 +2054,7 @@ Check whether the @code{Newsgroups} header exists and is not empty.
@item quoting-style
Check whether text follows last quoted portion.
@item repeated-newsgroups
-Check whether the @code{Newsgroups} and @code{Followup-to} headers
+Check whether the @code{Newsgroups} and @code{Followup-To} headers
contains repeated group names.
@item reply-to
Check whether the @code{Reply-To} header looks ok.
@@ -2065,7 +2067,7 @@ Check for the existence of version and sendsys commands.
@item shoot
Check whether the domain part of the @code{Message-ID} header looks ok.
@item shorten-followup-to
-Check whether to add a @code{Followup-to} header to shorten the number
+Check whether to add a @code{Followup-To} header to shorten the number
of groups to post to.
@item signature
Check the length of the signature.
@@ -2076,7 +2078,7 @@ Check whether the @code{Subject} header exists and is not empty.
@item subject-cmsg
Check the subject for commands.
@item valid-newsgroups
-Check whether the @code{Newsgroups} and @code{Followup-to} headers
+Check whether the @code{Newsgroups} and @code{Followup-To} headers
are valid syntactically.
@end table
@@ -2087,7 +2089,7 @@ for which the check is disabled by default if
@item message-ignored-news-headers
@vindex message-ignored-news-headers
Regexp of headers to be removed before posting. The default is@*
-@samp{^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:\\|@*
+@samp{^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-FCC:\\|@*
^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:}.
@item message-default-news-headers
@@ -2467,7 +2469,7 @@ an article\\nthat has been posted to %s as well.\\n\\n"}.
@item message-fcc-externalize-attachments
@vindex message-fcc-externalize-attachments
-If @code{nil}, attach files as normal parts in Fcc copies; if it is
+If @code{nil}, attach files as normal parts in FCC copies; if it is
non-@code{nil}, attach local files as external parts.
@item message-interactive
@@ -2622,13 +2624,13 @@ consulted, in turn:
A @dfn{wide reply} is a mail response that includes @emph{all} entities
mentioned in the message you are responding to. All mailboxes from the
following headers will be concatenated to form the outgoing
-@code{To}/@code{Cc} headers:
+@code{To}/@code{CC} headers:
@table @code
@item From
(unless there's a @code{Reply-To}, in which case that is used instead).
-@item Cc
+@item CC
@item To
@end table
@@ -2652,7 +2654,7 @@ sent:
@end table
If a @code{Mail-Copies-To} header is present, it will be used as the
-basis of the new @code{Cc} header, except if this header is
+basis of the new @code{CC} header, except if this header is
@samp{never}.
@end table
diff --git a/doc/misc/mh-e.texi b/doc/misc/mh-e.texi
index 898b3418f8d..99070950026 100644
--- a/doc/misc/mh-e.texi
+++ b/doc/misc/mh-e.texi
@@ -847,9 +847,9 @@ sending the original message, like this:
To:
cc:
Subject: Re: Test
-In-reply-to: <31054.1142621351@@stop.mail-abuse.org>
+In-Reply-To: <31054.1142621351@@stop.mail-abuse.org>
References: <31054.1142621351@@stop.mail-abuse.org>
-Comments: In-reply-to Bill Wohler <wohler@@stop.mail-abuse.org>
+Comments: In-Reply-To Bill Wohler <wohler@@stop.mail-abuse.org>
message dated "Fri, 17 Mar 2006 10:49:11 -0800."
X-Mailer: MH-E 8.1; nmh 1.1; GNU Emacs 23.1
--------
@@ -2589,13 +2589,6 @@ centers the output and wraps long lines more than most. It does not
always handle special characters like @samp{&reg;} or @samp{&ndash;}.
It does not download images.
@c -------------------------
-@item @samp{nil}
-This choice obviously requires an external browser. With this setting,
-HTML messages have a button for the body part which you can view with
-@kbd{K v} (@code{mh-folder-toggle-mime-part}). Rendering of special
-characters and handling of remote images depends on your choice of
-browser.
-@c -------------------------
@item @samp{shr}
@cindex @samp{shr}
This choice does not require an external program, but it does require
diff --git a/doc/misc/org.texi b/doc/misc/org.texi
index 2be2707d95e..7862713f47a 100644
--- a/doc/misc/org.texi
+++ b/doc/misc/org.texi
@@ -891,9 +891,7 @@ org}.
been visited, i.e., where no Org built-in function have been loaded.
Otherwise autoload Org functions will mess up the installation.
-Then, to make sure your Org configuration is taken into account, initialize
-the package system with @code{(package-initialize)} in your Emacs init file
-before setting any Org option. If you want to use Org's package repository,
+If you want to use Org's package repository,
check out the @uref{https://orgmode.org/elpa.html, Org ELPA page}.
@subsubheading Downloading Org as an archive
@@ -18168,7 +18166,7 @@ Suggested Org crypt settings in Emacs init file:
@lisp
(require 'org-crypt)
(org-crypt-use-before-save-magic)
-(setq org-tags-exclude-from-inheritance (quote ("crypt")))
+(setq org-tags-exclude-from-inheritance '("crypt"))
(setq org-crypt-key nil)
;; GPG key to use for encryption
@@ -19707,8 +19705,8 @@ mentioned in the manual. For a complete list, use @kbd{M-x org-customize
@c Local variables:
@c fill-column: 77
@c indent-tabs-mode: nil
-@c paragraph-start: "\\|^@[a-zA-Z]*[ \n]\\|^@x?org\\(key\\|cmd\\)\\|\f\\|[ ]*$"
-@c paragraph-separate: "\\|^@[a-zA-Z]*[ \n]\\|^@x?org\\(key\\|cmd\\)\\|[ \f]*$"
+@c paragraph-start: "^@[a-zA-Z]*[ \n]\\|^@x?org\\(key\\|cmd\\)\\|\f\\|[ ]*$"
+@c paragraph-separate: "^@[a-zA-Z]*[ \n]\\|^@x?org\\(key\\|cmd\\)\\|[ \f]*$"
@c End:
diff --git a/doc/misc/pgg.texi b/doc/misc/pgg.texi
index ffb8e4a3578..2fac24a4277 100644
--- a/doc/misc/pgg.texi
+++ b/doc/misc/pgg.texi
@@ -1,7 +1,5 @@
\input texinfo @c -*-texinfo-*-
-@include gnus-overrides.texi
-
@setfilename ../../info/pgg.info
@set VERSION 0.1
diff --git a/doc/misc/sasl.texi b/doc/misc/sasl.texi
index 3e7768d3191..1d31150f045 100644
--- a/doc/misc/sasl.texi
+++ b/doc/misc/sasl.texi
@@ -1,7 +1,5 @@
\input texinfo @c -*-texinfo-*-
-@include gnus-overrides.texi
-
@setfilename ../../info/sasl.info
@set VERSION 0.2
diff --git a/doc/misc/sieve.texi b/doc/misc/sieve.texi
index 7f28994f1e3..2d07b0a8d7b 100644
--- a/doc/misc/sieve.texi
+++ b/doc/misc/sieve.texi
@@ -1,7 +1,5 @@
\input texinfo @c -*-texinfo-*-
-@include gnus-overrides.texi
-
@setfilename ../../info/sieve.info
@settitle Emacs Sieve Manual
@include docstyle.texi
diff --git a/doc/misc/texinfo.tex b/doc/misc/texinfo.tex
index f2be62ce47b..667292a96a1 100644
--- a/doc/misc/texinfo.tex
+++ b/doc/misc/texinfo.tex
@@ -3,10 +3,9 @@
% Load plain if necessary, i.e., if running under initex.
\expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi
%
-\def\texinfoversion{2017-12-26.21}
+\def\texinfoversion{2019-03-23.11}
%
-% Copyright 1985-1986, 1988, 1990-2017, 2019 Free Software Foundation,
-% Inc.
+% Copyright 1985, 1986, 1988, 1990-2019 Free Software Foundation, Inc.
%
% This texinfo.tex file is free software: you can redistribute it and/or
% modify it under the terms of the GNU General Public License as
@@ -242,17 +241,7 @@
%
\def\finalout{\overfullrule=0pt }
-% Do @cropmarks to get crop marks.
-%
-\newif\ifcropmarks
-\let\cropmarks = \cropmarkstrue
-%
-% Dimensions to add cropmarks at corners.
-% Added by P. A. MacKay, 12 Nov. 1986
-%
\newdimen\outerhsize \newdimen\outervsize % set by the paper size routines
-\newdimen\cornerlong \cornerlong=1pc
-\newdimen\cornerthick \cornerthick=.3pt
\newdimen\topandbottommargin \topandbottommargin=.75in
% Output a mark which sets \thischapter, \thissection and \thiscolor.
@@ -268,8 +257,8 @@
% \domark is called twice inside \chapmacro, to add one
% mark before the section break, and one after.
-% In the second call \prevchapterdefs is the same as \lastchapterdefs,
-% and \prevsectiondefs is the same as \lastsectiondefs.
+% In the second call \prevchapterdefs is the same as \currentchapterdefs,
+% and \prevsectiondefs is the same as \currentsectiondefs.
% Then if the page is not broken at the mark, some of the previous
% section appears on the page, and we can get the name of this section
% from \firstmark for @everyheadingmarks top.
@@ -277,11 +266,11 @@
%
% See page 260 of The TeXbook.
\def\domark{%
- \toks0=\expandafter{\lastchapterdefs}%
- \toks2=\expandafter{\lastsectiondefs}%
+ \toks0=\expandafter{\currentchapterdefs}%
+ \toks2=\expandafter{\currentsectiondefs}%
\toks4=\expandafter{\prevchapterdefs}%
\toks6=\expandafter{\prevsectiondefs}%
- \toks8=\expandafter{\lastcolordefs}%
+ \toks8=\expandafter{\currentcolordefs}%
\mark{%
\the\toks0 \the\toks2 % 0: marks for @everyheadingmarks top
\noexpand\or \the\toks4 \the\toks6 % 1: for @everyheadingmarks bottom
@@ -298,19 +287,19 @@
% @setcolor (or @url, or @link, etc.) between @contents and the very
% first @chapter.
\def\gettopheadingmarks{%
- \ifcase0\topmark\fi
+ \ifcase0\the\savedtopmark\fi
\ifx\thischapter\empty \ifcase0\firstmark\fi \fi
}
\def\getbottomheadingmarks{\ifcase1\botmark\fi}
-\def\getcolormarks{\ifcase2\topmark\fi}
+\def\getcolormarks{\ifcase2\the\savedtopmark\fi}
% Avoid "undefined control sequence" errors.
-\def\lastchapterdefs{}
-\def\lastsectiondefs{}
-\def\lastsection{}
+\def\currentchapterdefs{}
+\def\currentsectiondefs{}
+\def\currentsection{}
\def\prevchapterdefs{}
\def\prevsectiondefs{}
-\def\lastcolordefs{}
+\def\currentcolordefs{}
% Margin to add to right of even pages, to left of odd pages.
\newdimen\bindingoffset
@@ -320,39 +309,57 @@
% Main output routine.
%
\chardef\PAGE = 255
-\output = {\onepageout{\pagecontents\PAGE}}
+\newtoks\defaultoutput
+\defaultoutput = {\savetopmark\onepageout{\pagecontents\PAGE}}
+\output=\expandafter{\the\defaultoutput}
\newbox\headlinebox
\newbox\footlinebox
+% When outputting the double column layout for indices, an output routine
+% is run several times, which hides the original value of \topmark. This
+% can lead to a page heading being output and duplicating the chapter heading
+% of the index. Hence, save the contents of \topmark at the beginning of
+% the output routine. The saved contents are valid until we actually
+% \shipout a page.
+%
+% (We used to run a short output routine to actually set \topmark and
+% \firstmark to the right values, but if this was called with an empty page
+% containing whatsits for writing index entries, the whatsits would be thrown
+% away and the index auxiliary file would remain empty.)
+%
+\newtoks\savedtopmark
+\newif\iftopmarksaved
+\topmarksavedtrue
+\def\savetopmark{%
+ \iftopmarksaved\else
+ \global\savedtopmark=\expandafter{\topmark}%
+ \global\topmarksavedtrue
+ \fi
+}
+
% \onepageout takes a vbox as an argument.
-% \shipout a vbox for a single page, adding an optional header, footer,
-% cropmarks, and footnote. This also causes index entries for this page
-% to be written to the auxiliary files.
+% \shipout a vbox for a single page, adding an optional header, footer
+% and footnote. This also causes index entries for this page to be written
+% to the auxiliary files.
%
\def\onepageout#1{%
- \ifcropmarks \hoffset=0pt \else \hoffset=\normaloffset \fi
+ \hoffset=\normaloffset
%
\ifodd\pageno \advance\hoffset by \bindingoffset
\else \advance\hoffset by -\bindingoffset\fi
%
- % Common context changes for both heading and footing.
- % Do this outside of the \shipout so @code etc. will be expanded in
- % the headline as they should be, not taken literally (outputting ''code).
- \def\commmonheadfootline{\let\hsize=\txipagewidth \texinfochars}
- %
% Retrieve the information for the headings from the marks in the page,
% and call Plain TeX's \makeheadline and \makefootline, which use the
% values in \headline and \footline.
%
% This is used to check if we are on the first page of a chapter.
- \ifcase1\topmark\fi
+ \ifcase1\the\savedtopmark\fi
\let\prevchaptername\thischaptername
\ifcase0\firstmark\fi
\let\curchaptername\thischaptername
%
\ifodd\pageno \getoddheadingmarks \else \getevenheadingmarks \fi
- \ifodd\pageno \getoddfootingmarks \else \getevenfootingmarks \fi
%
\ifx\curchaptername\prevchaptername
\let\thischapterheading\thischapter
@@ -363,7 +370,14 @@
\def\thischapterheading{}%
\fi
%
+ % Common context changes for both heading and footing.
+ % Do this outside of the \shipout so @code etc. will be expanded in
+ % the headline as they should be, not taken literally (outputting ''code).
+ \def\commmonheadfootline{\let\hsize=\txipagewidth \texinfochars}
+ %
\global\setbox\headlinebox = \vbox{\commmonheadfootline \makeheadline}%
+ %
+ \ifodd\pageno \getoddfootingmarks \else \getevenfootingmarks \fi
\global\setbox\footlinebox = \vbox{\commmonheadfootline \makefootline}%
%
{%
@@ -372,37 +386,12 @@
% take effect in \write's, yet the group defined by the \vbox ends
% before the \shipout runs.
%
- \indexdummies % don't expand commands in the output.
- \normalturnoffactive % \ in index entries must not stay \, e.g., if
- % the page break happens to be in the middle of an example.
- % We don't want .vr (or whatever) entries like this:
- % \entry{{\indexbackslash }acronym}{32}{\code {\acronym}}
- % "\acronym" won't work when it's read back in;
- % it needs to be
- % {\code {{\backslashcurfont }acronym}
+ \atdummies % don't expand commands in the output.
+ \turnoffactive
\shipout\vbox{%
% Do this early so pdf references go to the beginning of the page.
\ifpdfmakepagedest \pdfdest name{\the\pageno} xyz\fi
%
- \ifcropmarks \vbox to \outervsize\bgroup
- \hsize = \outerhsize
- \vskip-\topandbottommargin
- \vtop to0pt{%
- \line{\ewtop\hfil\ewtop}%
- \nointerlineskip
- \line{%
- \vbox{\moveleft\cornerthick\nstop}%
- \hfill
- \vbox{\moveright\cornerthick\nstop}%
- }%
- \vss}%
- \vskip\topandbottommargin
- \line\bgroup
- \hfil % center the page within the outer (page) hsize.
- \ifodd\pageno\hskip\bindingoffset\fi
- \vbox\bgroup
- \fi
- %
\unvbox\headlinebox
\pagebody{#1}%
\ifdim\ht\footlinebox > 0pt
@@ -413,24 +402,9 @@
\unvbox\footlinebox
\fi
%
- \ifcropmarks
- \egroup % end of \vbox\bgroup
- \hfil\egroup % end of (centering) \line\bgroup
- \vskip\topandbottommargin plus1fill minus1fill
- \boxmaxdepth = \cornerthick
- \vbox to0pt{\vss
- \line{%
- \vbox{\moveleft\cornerthick\nsbot}%
- \hfill
- \vbox{\moveright\cornerthick\nsbot}%
- }%
- \nointerlineskip
- \line{\ewbot\hfil\ewbot}%
- }%
- \egroup % \vbox from first cropmarks clause
- \fi
- }% end of \shipout\vbox
- }% end of group with \indexdummies
+ }%
+ }%
+ \global\topmarksavedfalse
\advancepageno
\ifnum\outputpenalty>-20000 \else\dosupereject\fi
}
@@ -449,17 +423,6 @@
\ifr@ggedbottom \kern-\dimen@ \vfil \fi}
}
-% Here are the rules for the cropmarks. Note that they are
-% offset so that the space between them is truly \outerhsize or \outervsize
-% (P. A. MacKay, 12 November, 1986)
-%
-\def\ewtop{\vrule height\cornerthick depth0pt width\cornerlong}
-\def\nstop{\vbox
- {\hrule height\cornerthick depth\cornerlong width\cornerthick}}
-\def\ewbot{\vrule height0pt depth\cornerthick width\cornerlong}
-\def\nsbot{\vbox
- {\hrule height\cornerlong depth\cornerthick width\cornerthick}}
-
% Argument parsing
@@ -485,11 +448,10 @@
}%
}
-% First remove any @comment, then any @c comment. Also remove a @texinfoc
-% comment (see \scanmacro for details). Pass the result on to \argcheckspaces.
+% First remove any @comment, then any @c comment. Pass the result on to
+% \argcheckspaces.
\def\argremovecomment#1\comment#2\ArgTerm{\argremovec #1\c\ArgTerm}
-\def\argremovec#1\c#2\ArgTerm{\argremovetexinfoc #1\texinfoc\ArgTerm}
-\def\argremovetexinfoc#1\texinfoc#2\ArgTerm{\argcheckspaces#1\^^M\ArgTerm}
+\def\argremovec#1\c#2\ArgTerm{\argcheckspaces#1\^^M\ArgTerm}
% Each occurrence of `\^^M' or `<space>\^^M' is replaced by a single space.
%
@@ -1161,6 +1123,16 @@ where each line of input produces a line of output.}
\fi
\fi
+\newif\ifpdforxetex
+\pdforxetexfalse
+\ifpdf
+ \pdforxetextrue
+\fi
+\ifx\XeTeXrevision\thisisundefined\else
+ \pdforxetextrue
+\fi
+
+
% PDF uses PostScript string constants for the names of xref targets,
% for display in the outlines, and in other places. Thus, we have to
% double any backslashes. Otherwise, a name like "\node" will be
@@ -1217,7 +1189,7 @@ output) for that.)}
% Set color, and create a mark which defines \thiscolor accordingly,
% so that \makeheadline knows which color to restore.
\def\setcolor#1{%
- \xdef\lastcolordefs{\gdef\noexpand\thiscolor{#1}}%
+ \xdef\currentcolordefs{\gdef\noexpand\thiscolor{#1}}%
\domark
\pdfsetcolor{#1}%
}
@@ -1225,7 +1197,7 @@ output) for that.)}
\def\maincolor{\rgbBlack}
\pdfsetcolor{\maincolor}
\edef\thiscolor{\maincolor}
- \def\lastcolordefs{}
+ \def\currentcolordefs{}
%
\def\makefootline{%
\baselineskip24pt
@@ -1526,6 +1498,9 @@ output) for that.)}
\startlink attr{/Border [0 0 0]}%
user{/Subtype /Link /A << /S /URI /URI (#1) >>}%
\endgroup}
+ % \pdfgettoks - Surround page numbers in #1 with @pdflink. #1 may
+ % be a simple number, or a list of numbers in the case of an index
+ % entry.
\def\pdfgettoks#1.{\setbox\boxA=\hbox{\toksA={#1.}\toksB={}\maketoks}}
\def\addtokens#1#2{\edef\addtoks{\noexpand#1={\the#1#2}}\addtoks}
\def\adn#1{\addtokens{\toksC}{#1}\global\countA=1\let\next=\maketoks}
@@ -1600,7 +1575,7 @@ output) for that.)}
% Set color, and create a mark which defines \thiscolor accordingly,
% so that \makeheadline knows which color to restore.
\def\setcolor#1{%
- \xdef\lastcolordefs{\gdef\noexpand\thiscolor{#1}}%
+ \xdef\currentcolordefs{\gdef\noexpand\thiscolor{#1}}%
\domark
\pdfsetcolor{#1}%
}
@@ -1608,7 +1583,7 @@ output) for that.)}
\def\maincolor{\rgbBlack}
\pdfsetcolor{\maincolor}
\edef\thiscolor{\maincolor}
- \def\lastcolordefs{}
+ \def\currentcolordefs{}
%
\def\makefootline{%
\baselineskip24pt
@@ -2233,6 +2208,20 @@ end
\font\smallersy=cmsy8
\def\smallerecsize{0800}
+% Fonts for math mode superscripts (7pt).
+\def\sevennominalsize{7pt}
+\setfont\sevenrm\rmshape{7}{1000}{OT1}
+\setfont\seventt\ttshape{10}{700}{OT1TT}
+\setfont\sevenbf\bfshape{10}{700}{OT1}
+\setfont\sevenit\itshape{7}{1000}{OT1IT}
+\setfont\sevensl\slshape{10}{700}{OT1}
+\setfont\sevensf\sfshape{10}{700}{OT1}
+\setfont\sevensc\scshape{10}{700}{OT1}
+\setfont\seventtsl\ttslshape{10}{700}{OT1TT}
+\font\seveni=cmmi7
+\font\sevensy=cmsy7
+\def\sevenecsize{0700}
+
% Fonts for title page (20.4pt):
\def\titlenominalsize{20pt}
\setfont\titlerm\rmbshape{12}{\magstep3}{OT1}
@@ -2367,6 +2356,20 @@ end
\font\smallersy=cmsy8
\def\smallerecsize{0800}
+% Fonts for math mode superscripts (7pt).
+\def\sevennominalsize{7pt}
+\setfont\sevenrm\rmshape{7}{1000}{OT1}
+\setfont\seventt\ttshape{10}{700}{OT1TT}
+\setfont\sevenbf\bfshape{10}{700}{OT1}
+\setfont\sevenit\itshape{7}{1000}{OT1IT}
+\setfont\sevensl\slshape{10}{700}{OT1}
+\setfont\sevensf\sfshape{10}{700}{OT1}
+\setfont\sevensc\scshape{10}{700}{OT1}
+\setfont\seventtsl\ttslshape{10}{700}{OT1TT}
+\font\seveni=cmmi7
+\font\sevensy=cmsy7
+\def\sevenecsize{0700}
+
% Fonts for title page (20.4pt):
\def\titlenominalsize{20pt}
\setfont\titlerm\rmbshape{12}{\magstep3}{OT1}
@@ -2501,13 +2504,20 @@ end
% In order for the font changes to affect most math symbols and letters,
-% we have to define the \textfont of the standard families. We don't
-% bother to reset \scriptfont and \scriptscriptfont; awaiting user need.
+% we have to define the \textfont of the standard families.
+% We don't bother to reset \scriptscriptfont; awaiting user need.
%
\def\resetmathfonts{%
\textfont0=\rmfont \textfont1=\ifont \textfont2=\syfont
\textfont\itfam=\itfont \textfont\slfam=\slfont \textfont\bffam=\bffont
\textfont\ttfam=\ttfont \textfont\sffam=\sffont
+ %
+ % Fonts for superscript. Note that the 7pt fonts are used regardless
+ % of the current font size.
+ \scriptfont0=\sevenrm \scriptfont1=\seveni \scriptfont2=\sevensy
+ \scriptfont\itfam=\sevenit \scriptfont\slfam=\sevensl
+ \scriptfont\bffam=\sevenbf \scriptfont\ttfam=\seventt
+ \scriptfont\sffam=\sevensf
}
%
@@ -2517,6 +2527,9 @@ end
% to also set the current \fam for math mode. Our \STYLE (e.g., \rm)
% commands hardwire \STYLEfont to set the current font.
%
+% The fonts used for \ifont are for "math italics" (\itfont is for italics
+% in regular text). \syfont is also used in math mode only.
+%
% Each font-changing command also sets the names \lsize (one size lower)
% and \lllsize (three sizes lower). These relative commands are used
% in, e.g., the LaTeX logo and acronyms.
@@ -2833,7 +2846,7 @@ end
% @t, explicit typewriter.
\def\t#1{%
- {\tt \rawbackslash \plainfrenchspacing #1}%
+ {\tt \plainfrenchspacing #1}%
\null
}
@@ -2860,7 +2873,6 @@ end
% Turn off hyphenation.
\nohyphenation
%
- \rawbackslash
\plainfrenchspacing
#1%
}%
@@ -3047,41 +3059,33 @@ end
\global\def/{\normalslash}
}
-% we put a little stretch before and after the breakable chars, to help
-% line breaking of long url's. The unequal skips make look better in
-% cmtt at least, especially for dots.
-\def\urefprestretchamount{.13em}
-\def\urefpoststretchamount{.1em}
-\def\urefprestretch{\urefprebreak \hskip0pt plus\urefprestretchamount\relax}
-\def\urefpoststretch{\urefpostbreak \hskip0pt plus\urefprestretchamount\relax}
-%
-\def\urefcodeamp{\urefprestretch \&\urefpoststretch}
-\def\urefcodedot{\urefprestretch .\urefpoststretch}
-\def\urefcodehash{\urefprestretch \#\urefpoststretch}
-\def\urefcodequest{\urefprestretch ?\urefpoststretch}
+\def\urefcodeamp{\urefprebreak \&\urefpostbreak}
+\def\urefcodedot{\urefprebreak .\urefpostbreak}
+\def\urefcodehash{\urefprebreak \#\urefpostbreak}
+\def\urefcodequest{\urefprebreak ?\urefpostbreak}
\def\urefcodeslash{\futurelet\next\urefcodeslashfinish}
{
\catcode`\/=\active
\global\def\urefcodeslashfinish{%
- \urefprestretch \slashChar
+ \urefprebreak \slashChar
% Allow line break only after the final / in a sequence of
% slashes, to avoid line break between the slashes in http://.
- \ifx\next/\else \urefpoststretch \fi
+ \ifx\next/\else \urefpostbreak \fi
}
}
-% One more complication: by default we'll break after the special
-% characters, but some people like to break before the special chars, so
-% allow that. Also allow no breaking at all, for manual control.
+% By default we'll break after the special characters, but some people like to
+% break before the special chars, so allow that. Also allow no breaking at
+% all, for manual control.
%
\parseargdef\urefbreakstyle{%
\def\txiarg{#1}%
\ifx\txiarg\wordnone
\def\urefprebreak{\nobreak}\def\urefpostbreak{\nobreak}
\else\ifx\txiarg\wordbefore
- \def\urefprebreak{\allowbreak}\def\urefpostbreak{\nobreak}
+ \def\urefprebreak{\urefallowbreak}\def\urefpostbreak{\nobreak}
\else\ifx\txiarg\wordafter
- \def\urefprebreak{\nobreak}\def\urefpostbreak{\allowbreak}
+ \def\urefprebreak{\nobreak}\def\urefpostbreak{\urefallowbreak}
\else
\errhelp = \EMsimple
\errmessage{Unknown @urefbreakstyle setting `\txiarg'}%
@@ -3091,6 +3095,14 @@ end
\def\wordbefore{before}
\def\wordnone{none}
+% Allow a ragged right output to aid breaking long URL's. Putting stretch in
+% between characters of the URL doesn't look good.
+\def\urefallowbreak{%
+ \hskip 0pt plus 1fil\relax
+ \allowbreak
+ \hskip 0pt plus -1fil\relax
+}
+
\urefbreakstyle after
% @url synonym for @uref, since that's how everyone uses it.
@@ -3101,7 +3113,7 @@ end
% So now @email is just like @uref, unless we are pdf.
%
%\def\email#1{\angleleft{\tt #1}\angleright}
-\ifpdf
+\ifpdforxetex
\def\email#1{\doemail#1,,\finish}
\def\doemail#1,#2,#3\finish{\begingroup
\unsepspaces
@@ -3111,18 +3123,7 @@ end
\endlink
\endgroup}
\else
- \ifx\XeTeXrevision\thisisundefined
- \let\email=\uref
- \else
- \def\email#1{\doemail#1,,\finish}
- \def\doemail#1,#2,#3\finish{\begingroup
- \unsepspaces
- \pdfurl{mailto:#1}%
- \setbox0 = \hbox{\ignorespaces #2}%
- \ifdim\wd0>0pt\unhbox0\else\code{#1}\fi
- \endlink
- \endgroup}
- \fi
+ \let\email=\uref
\fi
% @kbdinputstyle -- arg is `distinct' (@kbd uses slanted tty font always),
@@ -4656,19 +4657,6 @@ end
}
}
-% We have this subroutine so that we can handle at least some @value's
-% properly in indexes (we call \makevalueexpandable in \indexdummies).
-% The command has to be fully expandable (if the variable is set), since
-% the result winds up in the index file. This means that if the
-% variable's value contains other Texinfo commands, it's almost certain
-% it will fail (although perhaps we could fix that with sufficient work
-% to do a one-level expansion on the result, instead of complete).
-%
-% Unfortunately, this has the consequence that when _ is in the *value*
-% of an @set, it does not print properly in the roman fonts (get the cmr
-% dot accent at position 126 instead). No fix comes to mind, and it's
-% been this way since 2003 or earlier, so just ignore it.
-%
\def\expandablevalue#1{%
\expandafter\ifx\csname SET#1\endcsname\relax
{[No value for ``#1'']}%
@@ -4697,7 +4685,7 @@ end
% if possible, otherwise sort late.
\def\indexnofontsvalue#1{%
\expandafter\ifx\csname SET#1\endcsname\relax
- ZZZZZZZ
+ ZZZZZZZ%
\else
\csname SET#1\endcsname
\fi
@@ -4847,23 +4835,8 @@ end
\def\docodeindexxxx #1{\doind{\indexname}{\code{#1}}}
-% Used when writing an index entry out to an index file to prevent
-% expansion of Texinfo commands that can appear in an index entry.
-%
-\def\indexdummies{%
- \escapechar = `\\ % use backslash in output files.
- \definedummyletter\@%
- \definedummyletter\ %
- %
- % For texindex which always views { and } as separators.
- \def\{{\lbracechar{}}%
- \def\}{\rbracechar{}}%
- %
- % Do the redefinitions.
- \definedummies
-}
-
-% Used for the aux and toc files, where @ is the escape character.
+% Used for the aux, toc and index files to prevent expansion of Texinfo
+% commands.
%
\def\atdummies{%
\definedummyletter\@%
@@ -4893,8 +4866,7 @@ end
\def\definedummyletter#1{\def#1{\string#1}}%
\let\definedummyaccent\definedummyletter
-% Called from \indexdummies and \atdummies, to effectively prevent
-% the expansion of commands.
+% Called from \atdummies to prevent the expansion of commands.
%
\def\definedummies{%
%
@@ -5059,11 +5031,9 @@ end
\commondummyword\xref
}
-% For testing: output @{ and @} in index sort strings as \{ and \}.
-\newif\ifusebracesinindexes
-
\let\indexlbrace\relax
\let\indexrbrace\relax
+\let\indexatchar\relax
{\catcode`\@=0
\catcode`\\=13
@@ -5097,10 +5067,8 @@ end
}
\gdef\indexnonalnumreappear{%
- \useindexbackslash
\let-\normaldash
\let<\normalless
- \def\@{@}%
}
}
@@ -5211,36 +5179,16 @@ end
-\let\SETmarginindex=\relax % put index entries in margin (undocumented)?
-
-% Most index entries go through here, but \dosubind is the general case.
% #1 is the index name, #2 is the entry text.
-\def\doind#1#2{\dosubind{#1}{#2}{}}
-
-% There is also \dosubind {index}{topic}{subtopic}
-% which makes an entry in a two-level index such as the operation index.
-% TODO: Two-level index? Operation index?
-
-% Workhorse for all indexes.
-% #1 is name of index, #2 is stuff to put there, #3 is subentry --
-% empty if called from \doind, as we usually are (the main exception
-% is with most defuns, which call us directly).
-%
-\def\dosubind#1#2#3{%
+\def\doind#1#2{%
\iflinks
{%
- \requireopenindexfile{#1}%
- % Store the main index entry text (including the third arg).
- \toks0 = {#2}%
- % If third arg is present, precede it with a space.
- \def\thirdarg{#3}%
- \ifx\thirdarg\empty \else
- \toks0 = \expandafter{\the\toks0 \space #3}%
- \fi
%
+ \requireopenindexfile{#1}%
\edef\writeto{\csname#1indfile\endcsname}%
%
- \safewhatsit\dosubindwrite
+ \def\indextext{#2}%
+ \safewhatsit\doindwrite
}%
\fi
}
@@ -5262,21 +5210,7 @@ end
\fi}
\def\indexisfl{fl}
-% Output \ as {\indexbackslash}, because \ is an escape character in
-% the index files.
-\let\indexbackslash=\relax
-{\catcode`\@=0 \catcode`\\=\active
- @gdef@useindexbackslash{@def\{{@indexbackslash}}}
-}
-
-% Definition for writing index entry text.
-\def\sortas#1{\ignorespaces}%
-
-% Definition for writing index entry sort key. Should occur at the at
-% the beginning of the index entry, like
-% @cindex @sortas{september} \september
-% The \ignorespaces takes care of following space, but there's no way
-% to remove space before it.
+% Definition for writing index entry sort key.
{
\catcode`\-=13
\gdef\indexwritesortas{%
@@ -5287,51 +5221,121 @@ end
\xdef\indexsortkey{#1}\endgroup}
}
+\def\indexwriteseealso#1{
+ \gdef\pagenumbertext{@seealso{#1}}%
+}
-% Write the entry in \toks0 to the index file.
+% The default definitions
+\def\sortas#1{}%
+\def\seealso#1{\i{\putwordSeeAlso}\ #1}% for sorted index file only
+\def\putwordSeeAlso{see also}
+
+% Given index entry text like "aaa @subentry bbb @sortas{ZZZ}":
+% * Set \bracedtext to "{aaa}{bbb}"
+% * Set \fullindexsortkey to "aaa @subentry ZZZ"
+% * If @seealso occurs, set \pagenumbertext
%
-\def\dosubindwrite{%
- % Put the index entry in the margin if desired.
- \ifx\SETmarginindex\relax\else
- \insert\margin{\hbox{\vrule height8pt depth3pt width0pt \the\toks0}}%
+\def\splitindexentry#1{%
+ \gdef\fullindexsortkey{}%
+ \xdef\bracedtext{}%
+ \def\sep{}%
+ \def\seealso##1{}%
+ \expandafter\doindexsegment#1\subentry\finish\subentry
+}
+
+% append the results from the next segment
+\def\doindexsegment#1\subentry{%
+ \def\segment{#1}%
+ \ifx\segment\isfinish
+ \else
+ %
+ % Fully expand the segment, throwing away any @sortas directives, and
+ % trim spaces.
+ \edef\trimmed{\segment}%
+ \edef\trimmed{\expandafter\eatspaces\expandafter{\trimmed}}%
+ %
+ \xdef\bracedtext{\bracedtext{\trimmed}}%
+ %
+ % Get the string to sort by. Process the segment with all
+ % font commands turned off.
+ \bgroup
+ \let\sortas\indexwritesortas
+ \let\seealso\indexwriteseealso
+ \indexnofonts
+ % The braces around the commands are recognized by texindex.
+ \def\lbracechar{{\indexlbrace}}%
+ \def\rbracechar{{\indexrbrace}}%
+ \let\{=\lbracechar
+ \let\}=\rbracechar
+ \def\@{{\indexatchar}}%
+ \def\atchar##1{\@}%
+ %
+ \let\indexsortkey\empty
+ \global\let\pagenumbertext\empty
+ % Execute the segment and throw away the typeset output. This executes
+ % any @sortas or @seealso commands in this segment.
+ \setbox\dummybox = \hbox{\segment}%
+ \ifx\indexsortkey\empty{%
+ \indexnonalnumdisappear
+ \xdef\trimmed{\segment}%
+ \xdef\trimmed{\expandafter\eatspaces\expandafter{\trimmed}}%
+ \xdef\indexsortkey{\trimmed}%
+ \ifx\indexsortkey\empty\xdef\indexsortkey{ }\fi
+ }\fi
+ %
+ % Append to \fullindexsortkey.
+ \edef\tmp{\gdef\noexpand\fullindexsortkey{%
+ \fullindexsortkey\sep\indexsortkey}}%
+ \tmp
+ \egroup
+ \def\sep{\subentry}%
+ %
+ \expandafter\doindexsegment
\fi
+}
+\def\isfinish{\finish}%
+\newbox\dummybox % used above
+
+\let\subentry\relax
+
+% Write the entry in \toks0 to the index file.
+%
+\def\doindwrite{%
+ \maybemarginindex
%
- % Remember, we are within a group.
- \indexdummies % Must do this here, since \bf, etc expand at this stage
- \useindexbackslash % \indexbackslash isn't defined now so it will be output
- % as is; and it will print as backslash.
- % The braces around \indexbrace are recognized by texindex.
- %
- % Get the string to sort by, by processing the index entry with all
- % font commands turned off.
- {\indexnofonts
- \def\lbracechar{{\indexlbrace}}%
- \def\rbracechar{{\indexrbrace}}%
- \let\{=\lbracechar
- \let\}=\rbracechar
- \indexnonalnumdisappear
- \xdef\indexsortkey{}%
- \let\sortas=\indexwritesortas
- \edef\temp{\the\toks0}%
- \setbox\dummybox = \hbox{\temp}% Make sure to execute any \sortas
- \ifx\indexsortkey\empty
- \xdef\indexsortkey{\temp}%
- \ifx\indexsortkey\empty\xdef\indexsortkey{ }\fi
- \fi
- }%
+ \atdummies
+ %
+ % For texindex which always views { and } as separators.
+ \def\{{\lbracechar{}}%
+ \def\}{\rbracechar{}}%
+ %
+ % Split the entry into primary entry and any subentries, and get the index
+ % sort key.
+ \splitindexentry\indextext
%
% Set up the complete index entry, with both the sort key and
% the original text, including any font commands. We write
% three arguments to \entry to the .?? file (four in the
% subentry case), texindex reduces to two when writing the .??s
% sorted result.
+ %
\edef\temp{%
\write\writeto{%
- \string\entry{\indexsortkey}{\noexpand\folio}{\the\toks0}}%
+ \string\entry{\fullindexsortkey}%
+ {\ifx\pagenumbertext\empty\noexpand\folio\else\pagenumbertext\fi}%
+ \bracedtext}%
}%
\temp
}
-\newbox\dummybox % used above
+
+% Put the index entry in the margin if desired (undocumented).
+\def\maybemarginindex{%
+ \ifx\SETmarginindex\relax\else
+ \insert\margin{\hbox{\vrule height8pt depth3pt width0pt \relax\indextext}}%
+ \fi
+}
+\let\SETmarginindex=\relax
+
% Take care of unwanted page breaks/skips around a whatsit:
%
@@ -5419,9 +5423,14 @@ end
% \entry {topic}{pagelist}
% for a topic that is used without subtopics
% \primary {topic}
+% \entry {topic}{}
% for the beginning of a topic that is used with subtopics
% \secondary {subtopic}{pagelist}
% for each subtopic.
+% \secondary {subtopic}{}
+% for a subtopic with sub-subtopics
+% \tertiary {subtopic}{subsubtopic}{pagelist}
+% for each sub-subtopic.
% Define the user-accessible indexing commands
% @findex, @vindex, @kindex, @cindex.
@@ -5433,11 +5442,6 @@ end
\def\tindex {\tpindex}
\def\pindex {\pgindex}
-\def\cindexsub {\begingroup\obeylines\cindexsub}
-{\obeylines %
-\gdef\cindexsub "#1" #2^^M{\endgroup %
-\dosubind{cp}{#2}{#1}}}
-
% Define the macros used in formatting output of the sorted index material.
% @printindex causes a particular index (the ??s file) to get printed.
@@ -5451,14 +5455,10 @@ end
\plainfrenchspacing
\everypar = {}% don't want the \kern\-parindent from indentation suppression.
%
- % See if the index file exists and is nonempty.
- % Change catcode of @ here so that if the index file contains
- % \initial {@}
- % as its first line, TeX doesn't complain about mismatched braces
- % (because it thinks @} is a control sequence).
- \catcode`\@ = 12
% See comment in \requireopenindexfile.
\def\indexname{#1}\ifx\indexname\indexisfl\def\indexname{f1}\fi
+ %
+ % See if the index file exists and is nonempty.
\openin 1 \jobname.\indexname s
\ifeof 1
% \enddoublecolumns gets confused if there is no text in the index,
@@ -5468,8 +5468,6 @@ end
\putwordIndexNonexistent
\typeout{No file \jobname.\indexname s.}%
\else
- \catcode`\\ = 0
- %
% If the index file exists but is empty, then \openin leaves \ifeof
% false. We have to make TeX try to read something from the file, so
% it can discover if there is anything in it.
@@ -5477,47 +5475,27 @@ end
\ifeof 1
\putwordIndexIsEmpty
\else
- % Index files are almost Texinfo source, but we use \ as the escape
- % character. It would be better to use @, but that's too big a change
- % to make right now.
- \def\indexbackslash{\ttbackslash}%
- \let\indexlbrace\{ % Likewise, set these sequences for braces
- \let\indexrbrace\} % used in the sort key.
- \begindoublecolumns
- \let\dotheinsertentrybox\dotheinsertentryboxwithpenalty
- %
- % Read input from the index file line by line.
- \loopdo
- \ifeof1 \else
- \read 1 to \nextline
- \fi
- %
- \indexinputprocessing
- \thisline
- %
- \ifeof1\else
- \let\thisline\nextline
- \repeat
- %%
- \enddoublecolumns
+ \expandafter\printindexzz\thisline\relax\relax\finish%
\fi
\fi
\closein 1
\endgroup}
-\def\loopdo#1\repeat{\def\body{#1}\loopdoxxx}
-\def\loopdoxxx{\let\next=\relax\body\let\next=\loopdoxxx\fi\next}
-\def\indexinputprocessing{%
- \ifeof1
- \let\firsttoken\relax
+% If the index file starts with a backslash, forgo reading the index
+% file altogether. If somebody upgrades texinfo.tex they may still have
+% old index files using \ as the escape character. Reading this would
+% at best lead to typesetting garbage, at worst a TeX syntax error.
+\def\printindexzz#1#2\finish{%
+ % NB this won't work if the index file starts with a group...
+ \uccode`\~=`\\ \uppercase{\if\noexpand~}\noexpand#1
+ \message{skipping sorted index file}%
+ (Skipped sorted index file in obsolete format)
\else
- \edef\act{\gdef\noexpand\firsttoken{\getfirsttoken\nextline}}%
- \act
+ \begindoublecolumns
+ \input \jobname.\indexname s
+ \enddoublecolumns
\fi
}
-\def\getfirsttoken#1{\expandafter\getfirsttokenx#1\endfirsttoken}
-\long\def\getfirsttokenx#1#2\endfirsttoken{\noexpand#1}
-
% These macros are used by the sorted index file itself.
% Change them to control the appearance of the index.
@@ -5526,12 +5504,18 @@ end
\catcode`\|=13 \catcode`\<=13 \catcode`\>=13 \catcode`\+=13 \catcode`\"=13
\catcode`\$=3
\gdef\initialglyphs{%
+ % special control sequences used in the index sort key
+ \let\indexlbrace\{%
+ \let\indexrbrace\}%
+ \let\indexatchar\@%
+ %
% Some changes for non-alphabetic characters. Using the glyphs from the
% math fonts looks more consistent than the typewriter font used elsewhere
% for these characters.
- \def\indexbackslash{\math{\backslash}}%
- \let\\=\indexbackslash
+ \uccode`\~=`\\ \uppercase{\def~{\math{\backslash}}}
%
+ % In case @\ is used for backslash
+ \uppercase{\let\\=~}
% Can't get bold backslash so don't use bold forward slash
\catcode`\/=13
\def/{{\secrmnotbold \normalslash}}%
@@ -5591,12 +5575,6 @@ end
\def\entry{%
\begingroup
%
- % For pdfTeX and XeTeX.
- % The redefinition of \domark stops marks being added in \pdflink to
- % preserve coloured links across page boundaries. Otherwise the marks
- % would get in the way of \lastbox in \insertentrybox.
- \let\domark\relax
- %
% Start a new paragraph if necessary, so our assignments below can't
% affect previous text.
\par
@@ -5629,35 +5607,31 @@ end
\gdef\finishentry#1{%
\egroup % end box A
\dimen@ = \wd\boxA % Length of text of entry
- \global\setbox\boxA=\hbox\bgroup\unhbox\boxA
- % #1 is the page number.
- %
- % Get the width of the page numbers, and only use
- % leaders if they are present.
- \global\setbox\boxB = \hbox{#1}%
- \ifdim\wd\boxB = 0pt
- \null\nobreak\hfill\ %
- \else
- %
- \null\nobreak\indexdotfill % Have leaders before the page number.
+ \global\setbox\boxA=\hbox\bgroup
+ \unhbox\boxA
+ % #1 is the page number.
%
- \ifpdf
- \pdfgettoks#1.%
- \hskip\skip\thinshrinkable\the\toksA
+ % Get the width of the page numbers, and only use
+ % leaders if they are present.
+ \global\setbox\boxB = \hbox{#1}%
+ \ifdim\wd\boxB = 0pt
+ \null\nobreak\hfill\ %
\else
- \ifx\XeTeXrevision\thisisundefined
- \hskip\skip\thinshrinkable #1%
- \else
+ %
+ \null\nobreak\indexdotfill % Have leaders before the page number.
+ %
+ \ifpdforxetex
\pdfgettoks#1.%
\hskip\skip\thinshrinkable\the\toksA
+ \else
+ \hskip\skip\thinshrinkable #1%
\fi
\fi
- \fi
\egroup % end \boxA
\ifdim\wd\boxB = 0pt
- \global\setbox\entrybox=\vbox{\unhbox\boxA}%
- \else
- \global\setbox\entrybox=\vbox\bgroup
+ \noindent\unhbox\boxA\par
+ \nobreak
+ \else\bgroup
% We want the text of the entries to be aligned to the left, and the
% page numbers to be aligned to the right.
%
@@ -5723,55 +5697,11 @@ end
\egroup % The \vbox
\fi
\endgroup
- \dotheinsertentrybox
}}
\newskip\thinshrinkable
\skip\thinshrinkable=.15em minus .15em
-\newbox\entrybox
-\def\insertentrybox{%
- \ourunvbox\entrybox
-}
-
-% default definition
-\let\dotheinsertentrybox\insertentrybox
-
-% Use \lastbox to take apart vbox box by box, and add each sub-box
-% to the current vertical list.
-\def\ourunvbox#1{%
-\bgroup % for local binding of \delayedbox
- % Remove the last box from box #1
- \global\setbox#1=\vbox{%
- \unvbox#1%
- \unskip % remove any glue
- \unpenalty
- \global\setbox\interbox=\lastbox
- }%
- \setbox\delayedbox=\box\interbox
- \ifdim\ht#1=0pt\else
- \ourunvbox#1 % Repeat on what's left of the box
- \nobreak
- \fi
- \box\delayedbox
-\egroup
-}
-\newbox\delayedbox
-\newbox\interbox
-
-% Used from \printindex. \firsttoken should be the first token
-% after the \entry. If it's not another \entry, we are at the last
-% line of a group of index entries, so insert a penalty to discourage
-% widowed index entries.
-\def\dotheinsertentryboxwithpenalty{%
- \ifx\firsttoken\isentry
- \else
- \penalty 9000
- \fi
- \insertentrybox
-}
-\def\isentry{\entry}%
-
% Like plain.tex's \dotfill, except uses up at least 1 em.
% The filll stretch here overpowers both the fil and fill stretch to push
% the page number to the right.
@@ -5781,24 +5711,15 @@ end
\def\primary #1{\line{#1\hfil}}
-\newskip\secondaryindent \secondaryindent=0.5cm
-\def\secondary#1#2{{%
- \parfillskip=0in
- \parskip=0in
- \hangindent=1in
- \hangafter=1
- \noindent\hskip\secondaryindent\hbox{#1}\indexdotfill
- \ifpdf
- \pdfgettoks#2.\ \the\toksA % The page number ends the paragraph.
- \else
- \ifx\XeTeXrevision\thisisundefined
- #2
- \else
- \pdfgettoks#2.\ \the\toksA % The page number ends the paragraph.
- \fi
- \fi
- \par
-}}
+\def\secondary{\indententry{0.5cm}}
+\def\tertiary{\indententry{1cm}}
+
+\def\indententry#1#2#3{%
+ \bgroup
+ \leftskip=#1
+ \entry{#2}{#3}%
+ \egroup
+}
% Define two-column mode, which we use to typeset indexes.
% Adapted from the TeXbook, page 416, which is to say,
@@ -5808,60 +5729,21 @@ end
\newbox\partialpage
\newdimen\doublecolumnhsize
-% Use inside an output routine to save \topmark and \firstmark
-\def\savemarks{%
- \global\savedtopmark=\expandafter{\topmark }%
- \global\savedfirstmark=\expandafter{\firstmark }%
-}
-\newtoks\savedtopmark
-\newtoks\savedfirstmark
-
-% Set \topmark and \firstmark for next time \output runs.
-% Can't be run from withinside \output (because any material
-% added while an output routine is active, including
-% penalties, is saved for after it finishes). The page so far
-% should be empty, otherwise what's on it will be thrown away.
-\def\restoremarks{%
- \mark{\the\savedtopmark}%
- \bgroup\output = {%
- \setbox\dummybox=\box\PAGE
- }abc\eject\egroup
- % "abc" because output routine doesn't fire for a completely empty page.
- \mark{\the\savedfirstmark}%
-}
-
\def\begindoublecolumns{\begingroup % ended by \enddoublecolumns
% If not much space left on page, start a new page.
\ifdim\pagetotal>0.8\vsize\vfill\eject\fi
%
% Grab any single-column material above us.
\output = {%
- %
- % Here is a possibility not foreseen in manmac: if we accumulate a
- % whole lot of material, we might end up calling this \output
- % routine twice in a row (see the doublecol-lose test, which is
- % essentially a couple of indexes with @setchapternewpage off). In
- % that case we just ship out what is in \partialpage with the normal
- % output routine. Generally, \partialpage will be empty when this
- % runs and this will be a no-op. See the indexspread.tex test case.
- \ifvoid\partialpage \else
- \onepageout{\pagecontents\partialpage}%
- \fi
+ \savetopmark
%
\global\setbox\partialpage = \vbox{%
% Unvbox the main output page.
\unvbox\PAGE
\kern-\topskip \kern\baselineskip
}%
- \savemarks
}%
\eject % run that output routine to set \partialpage
- \restoremarks
- %
- % We recover the two marks that the last output routine saved in order
- % to propagate the information in marks added around a chapter heading,
- % which could be otherwise be lost by the time the final page is output.
- %
%
% Use the double-column output routine for subsequent pages.
\output = {\doublecolumnout}%
@@ -5887,7 +5769,9 @@ end
\divide\doublecolumnhsize by 2
\hsize = \doublecolumnhsize
%
- % Double the \vsize as well.
+ % Get the available space for the double columns -- the normal
+ % (undoubled) page height minus any material left over from the
+ % previous page.
\advance\vsize by -\ht\partialpage
\vsize = 2\vsize
%
@@ -5900,17 +5784,15 @@ end
%
\def\doublecolumnout{%
%
+ \savetopmark
\splittopskip=\topskip \splitmaxdepth=\maxdepth
- % Get the available space for the double columns -- the normal
- % (undoubled) page height minus any material left over from the
- % previous page.
\dimen@ = \vsize
\divide\dimen@ by 2
%
% box0 will be the left-hand column, box2 the right.
\setbox0=\vsplit\PAGE to\dimen@ \setbox2=\vsplit\PAGE to\dimen@
\global\advance\vsize by 2\ht\partialpage
- \onepageout\pagesofar
+ \onepageout\pagesofar % empty except for the first time we are called
\unvbox\PAGE
\penalty\outputpenalty
}
@@ -5958,7 +5840,7 @@ end
%
\output = {%
% Split the last of the double-column material.
- \savemarks
+ \savetopmark
\balancecolumns
}%
\eject % call the \output just set
@@ -5966,10 +5848,9 @@ end
% Having called \balancecolumns once, we do not
% want to call it again. Therefore, reset \output to its normal
% definition right away.
- \global\output = {\onepageout{\pagecontents\PAGE}}%
+ \global\output=\expandafter{\the\defaultoutput}
%
\endgroup % started in \begindoublecolumns
- \restoremarks
% Leave the double-column material on the current page, no automatic
% page break.
\box\balancedcolumns
@@ -5993,13 +5874,14 @@ end
\def\balancecolumns{%
\setbox0 = \vbox{\unvbox\PAGE}% like \box255 but more efficient, see p.120.
\dimen@ = \ht0
- \advance\dimen@ by \topskip
- \advance\dimen@ by-\baselineskip
- \ifdim\dimen@<5\baselineskip
+ \ifdim\dimen@<7\baselineskip
% Don't split a short final column in two.
\setbox2=\vbox{}%
\global\setbox\balancedcolumns=\vbox{\pagesofar}%
\else
+ % double the leading vertical space
+ \advance\dimen@ by \topskip
+ \advance\dimen@ by-\baselineskip
\divide\dimen@ by 2 % target to split to
\dimen@ii = \dimen@
\splittopskip = \topskip
@@ -6134,11 +6016,9 @@ end
% @raisesections: treat @section as chapter, @subsection as section, etc.
\def\raisesections{\global\advance\secbase by -1}
-\let\up=\raisesections % original BFox name
% @lowersections: treat @chapter as section, @section as subsection, etc.
\def\lowersections{\global\advance\secbase by 1}
-\let\down=\lowersections % original BFox name
% we only have subsub.
\chardef\maxseclevel = 3
@@ -6483,27 +6363,22 @@ end
\expandafter\ifx\thisenv\titlepage\else
\checkenv{}% chapters, etc., should not start inside an environment.
\fi
- % FIXME: \chapmacro is currently called from inside \titlepage when
- % \setcontentsaftertitlepage to print the "Table of Contents" heading, but
- % this should probably be done by \sectionheading with an option to print
- % in chapter size.
- %
% Insert the first mark before the heading break (see notes for \domark).
- \let\prevchapterdefs=\lastchapterdefs
- \let\prevsectiondefs=\lastsectiondefs
- \gdef\lastsectiondefs{\gdef\thissectionname{}\gdef\thissectionnum{}%
+ \let\prevchapterdefs=\currentchapterdefs
+ \let\prevsectiondefs=\currentsectiondefs
+ \gdef\currentsectiondefs{\gdef\thissectionname{}\gdef\thissectionnum{}%
\gdef\thissection{}}%
%
\def\temptype{#2}%
\ifx\temptype\Ynothingkeyword
- \gdef\lastchapterdefs{\gdef\thischaptername{#1}\gdef\thischapternum{}%
+ \gdef\currentchapterdefs{\gdef\thischaptername{#1}\gdef\thischapternum{}%
\gdef\thischapter{\thischaptername}}%
\else\ifx\temptype\Yomitfromtockeyword
- \gdef\lastchapterdefs{\gdef\thischaptername{#1}\gdef\thischapternum{}%
+ \gdef\currentchapterdefs{\gdef\thischaptername{#1}\gdef\thischapternum{}%
\gdef\thischapter{}}%
\else\ifx\temptype\Yappendixkeyword
\toks0={#1}%
- \xdef\lastchapterdefs{%
+ \xdef\currentchapterdefs{%
\gdef\noexpand\thischaptername{\the\toks0}%
\gdef\noexpand\thischapternum{\appendixletter}%
% \noexpand\putwordAppendix avoids expanding indigestible
@@ -6514,7 +6389,7 @@ end
}%
\else
\toks0={#1}%
- \xdef\lastchapterdefs{%
+ \xdef\currentchapterdefs{%
\gdef\noexpand\thischaptername{\the\toks0}%
\gdef\noexpand\thischapternum{\the\chapno}%
% \noexpand\putwordChapter avoids expanding indigestible
@@ -6534,18 +6409,18 @@ end
%
% Now the second mark, after the heading break. No break points
% between here and the heading.
- \let\prevchapterdefs=\lastchapterdefs
- \let\prevsectiondefs=\lastsectiondefs
+ \let\prevchapterdefs=\currentchapterdefs
+ \let\prevsectiondefs=\currentsectiondefs
\domark
%
{%
\chapfonts \rm
\let\footnote=\errfootnoteheading % give better error message
%
- % Have to define \lastsection before calling \donoderef, because the
+ % Have to define \currentsection before calling \donoderef, because the
% xref code eventually uses it. On the other hand, it has to be called
% after \pchapsepmacro, or the headline will change too soon.
- \gdef\lastsection{#1}%
+ \gdef\currentsection{#1}%
%
% Only insert the separating space if we have a chapter/appendix
% number, and don't print the unnumbered ``number''.
@@ -6634,10 +6509,10 @@ end
\csname #2fonts\endcsname \rm
%
% Insert first mark before the heading break (see notes for \domark).
- \let\prevsectiondefs=\lastsectiondefs
+ \let\prevsectiondefs=\currentsectiondefs
\ifx\temptype\Ynothingkeyword
\ifx\sectionlevel\seckeyword
- \gdef\lastsectiondefs{\gdef\thissectionname{#1}\gdef\thissectionnum{}%
+ \gdef\currentsectiondefs{\gdef\thissectionname{#1}\gdef\thissectionnum{}%
\gdef\thissection{\thissectionname}}%
\fi
\else\ifx\temptype\Yomitfromtockeyword
@@ -6645,7 +6520,7 @@ end
\else\ifx\temptype\Yappendixkeyword
\ifx\sectionlevel\seckeyword
\toks0={#1}%
- \xdef\lastsectiondefs{%
+ \xdef\currentsectiondefs{%
\gdef\noexpand\thissectionname{\the\toks0}%
\gdef\noexpand\thissectionnum{#4}%
% \noexpand\putwordSection avoids expanding indigestible
@@ -6658,7 +6533,7 @@ end
\else
\ifx\sectionlevel\seckeyword
\toks0={#1}%
- \xdef\lastsectiondefs{%
+ \xdef\currentsectiondefs{%
\gdef\noexpand\thissectionname{\the\toks0}%
\gdef\noexpand\thissectionnum{#4}%
% \noexpand\putwordSection avoids expanding indigestible
@@ -6684,28 +6559,28 @@ end
%
% Now the second mark, after the heading break. No break points
% between here and the heading.
- \global\let\prevsectiondefs=\lastsectiondefs
+ \global\let\prevsectiondefs=\currentsectiondefs
\domark
%
% Only insert the space after the number if we have a section number.
\ifx\temptype\Ynothingkeyword
\setbox0 = \hbox{}%
\def\toctype{unn}%
- \gdef\lastsection{#1}%
+ \gdef\currentsection{#1}%
\else\ifx\temptype\Yomitfromtockeyword
% for @headings -- no section number, don't include in toc,
- % and don't redefine \lastsection.
+ % and don't redefine \currentsection.
\setbox0 = \hbox{}%
\def\toctype{omit}%
\let\sectionlevel=\empty
\else\ifx\temptype\Yappendixkeyword
\setbox0 = \hbox{#4\enspace}%
\def\toctype{app}%
- \gdef\lastsection{#1}%
+ \gdef\currentsection{#1}%
\else
\setbox0 = \hbox{#4\enspace}%
\def\toctype{num}%
- \gdef\lastsection{#1}%
+ \gdef\currentsection{#1}%
\fi\fi\fi
%
% Write the toc entry (before \donoderef). See comments in \chapmacro.
@@ -6795,13 +6670,8 @@ end
% 1 and 2 (the page numbers aren't printed), and so are the first
% two pages of the document. Thus, we'd have two destinations named
% `1', and two named `2'.
- \ifpdf
+ \ifpdforxetex
\global\pdfmakepagedesttrue
- \else
- \ifx\XeTeXrevision\thisisundefined
- \else
- \global\pdfmakepagedesttrue
- \fi
\fi
}
@@ -7164,11 +7034,7 @@ end
% @cartouche ... @end cartouche: draw rectangle w/rounded corners around
% environment contents.
-\font\circle=lcircle10
-\newdimen\circthick
-\newdimen\cartouter\newdimen\cartinner
-\newskip\normbskip\newskip\normpskip\newskip\normlskip
-\circthick=\fontdimen8\circle
+
%
\def\ctl{{\circle\char'013\hskip -6pt}}% 6pt from pl file: 1/2charwidth
\def\ctr{{\hskip 6pt\circle\char'010}}
@@ -7183,7 +7049,18 @@ end
%
\newskip\lskip\newskip\rskip
+% only require the font if @cartouche is actually used
+\def\cartouchefontdefs{%
+ \font\circle=lcircle10\relax
+ \circthick=\fontdimen8\circle
+}
+\newdimen\circthick
+\newdimen\cartouter\newdimen\cartinner
+\newskip\normbskip\newskip\normpskip\newskip\normlskip
+
+
\envdef\cartouche{%
+ \cartouchefontdefs
\ifhmode\par\fi % can't be in the midst of a paragraph.
\startsavinginserts
\lskip=\leftskip \rskip=\rightskip
@@ -7362,13 +7239,9 @@ end
% @raggedright does more-or-less normal line breaking but no right
-% justification. From plain.tex. Don't stretch around special
-% characters in urls in this environment, since the stretch at the right
-% should be enough.
+% justification. From plain.tex.
\envdef\raggedright{%
\rightskip0pt plus2.4em \spaceskip.3333em \xspaceskip.5em\relax
- \def\urefprestretchamount{0pt}%
- \def\urefpoststretchamount{0pt}%
}
\let\Eraggedright\par
@@ -7530,7 +7403,7 @@ end
\nonfillstart
\tt % easiest (and conventionally used) font for verbatim
% The \leavevmode here is for blank lines. Otherwise, we would
- % never \starttabox and the \egroup would end verbatim mode.
+ % never \starttabbox and the \egroup would end verbatim mode.
\def\par{\leavevmode\egroup\box\verbbox\endgraf}%
\tabexpand
\setupmarkupstyle{verbatim}%
@@ -7593,9 +7466,12 @@ end
{%
\makevalueexpandable
\setupverbatim
- \indexnofonts % Allow `@@' and other weird things in file names.
- \wlog{texinfo.tex: doing @verbatiminclude of #1^^J}%
- \input #1
+ {%
+ \indexnofonts % Allow `@@' and other weird things in file names.
+ \wlog{texinfo.tex: doing @verbatiminclude of #1^^J}%
+ \edef\tmp{\noexpand\input #1 }
+ \expandafter
+ }\tmp
\afterenvbreak
}%
}
@@ -7740,6 +7616,21 @@ end
\fi\fi
}
+% \dosubind {index}{topic}{subtopic}
+%
+% If SUBTOPIC is present, precede it with a space, and call \doind.
+% (At some time during the 20th century, this made a two-level entry in an
+% index such as the operation index. Nobody seemed to notice the change in
+% behaviour though.)
+\def\dosubind#1#2#3{%
+ \def\thirdarg{#3}%
+ \ifx\thirdarg\empty
+ \doind{#1}{#2}%
+ \else
+ \doind{#1}{#2\space#3}%
+ \fi
+}
+
% Untyped functions:
% @deffn category name args
@@ -7754,7 +7645,6 @@ end
% \deffngeneral {subind}category name args
%
\def\deffngeneral#1#2 #3 #4\endheader{%
- % Remember that \dosubind{fn}{foo}{} is equivalent to \doind{fn}{foo}.
\dosubind{fn}{\code{#3}}{#1}%
\defname{#2}{}{#3}\magicamp\defunargs{#4\unskip}%
}
@@ -7961,6 +7851,7 @@ end
\gdef\boldbrax{\let(=\opnr\let)=\clnr\let[=\lbrb\let]=\rbrb}
\gdef\magicamp{\let&=\amprm}
}
+\let\ampchar\&
\newcount\parencount
@@ -8041,36 +7932,18 @@ end
}
\fi
-% alias because \c means cedilla in @tex or @math
-\let\texinfoc=\c
-
-\newcount\savedcatcodeone
-\newcount\savedcatcodetwo
-
% Used at the time of macro expansion.
% Argument is macro body with arguments substituted
\def\scanmacro#1{%
\newlinechar`\^^M
\def\xeatspaces{\eatspaces}%
%
- % Temporarily undo catcode changes of \printindex. Set catcode of @ to
- % 0 so that @-commands in macro expansions aren't printed literally when
- % formatting an index file, where \ is used as the escape character.
- \savedcatcodeone=\catcode`\@
- \savedcatcodetwo=\catcode`\\
- \catcode`\@=0
- \catcode`\\=\active
- %
% Process the macro body under the current catcode regime.
- \scantokens{#1@texinfoc}%
- %
- \catcode`\@=\savedcatcodeone
- \catcode`\\=\savedcatcodetwo
+ \scantokens{#1@comment}%
%
- % The \texinfoc is to remove the \newlinechar added by \scantokens, and
- % can be noticed by \parsearg.
- % We avoid surrounding the call to \scantokens with \bgroup and \egroup
- % to allow macros to open or close groups themselves.
+ % The \comment is to remove the \newlinechar added by \scantokens, and
+ % can be noticed by \parsearg. Note \c isn't used because this means cedilla
+ % in math mode.
}
% Used for copying and captions
@@ -8171,12 +8044,14 @@ end
\def\macroargctxt{%
\scanctxt
\catcode`\ =\active
+ \catcode`\@=\other
\catcode`\^^M=\other
\catcode`\\=\active
}
\def\macrolineargctxt{% used for whole-line arguments without braces
\scanctxt
+ \catcode`\@=\other
\catcode`\{=\other
\catcode`\}=\other
}
@@ -8740,9 +8615,21 @@ end
% also remove a trailing comma, in case of something like this:
% @node Help-Cross, , , Cross-refs
\def\donode#1 ,#2\finishnodeparse{\dodonode #1,\finishnodeparse}
-\def\dodonode#1,#2\finishnodeparse{\gdef\lastnode{#1}}
+\def\dodonode#1,#2\finishnodeparse{\gdef\lastnode{#1}\omittopnode}
+
+% Used so that the @top node doesn't have to be wrapped in an @ifnottex
+% conditional.
+% \doignore goes to more effort to skip nested conditionals but we don't need
+% that here.
+\def\omittopnode{%
+ \ifx\lastnode\wordTop
+ \expandafter\ignorenode\fi
+}
+\def\wordTop{Top}
+
+% Divert output to a box that is not output until the next @node command.
+\def\ignorenode{\setbox\dummybox\vbox\bgroup\def\node{\egroup\node}}
-\let\nwnode=\node
\let\lastnode=\empty
% Write a cross-reference definition for the current node. #1 is the
@@ -8765,7 +8652,7 @@ end
% \setref{NAME}{SNT} defines a cross-reference point NAME (a node or an
% anchor), which consists of three parts:
-% 1) NAME-title - the current sectioning name taken from \lastsection,
+% 1) NAME-title - the current sectioning name taken from \currentsection,
% or the anchor name.
% 2) NAME-snt - section number and type, passed as the SNT arg, or
% empty for anchors.
@@ -8787,7 +8674,7 @@ end
\write\auxfile{@xrdef{#1-% #1 of \setref, expanded by the \edef
##1}{##2}}% these are parameters of \writexrdef
}%
- \toks0 = \expandafter{\lastsection}%
+ \toks0 = \expandafter{\currentsection}%
\immediate \writexrdef{title}{\the\toks0 }%
\immediate \writexrdef{snt}{\csname #2\endcsname}% \Ynumbered etc.
\safewhatsit{\writexrdef{pg}{\folio}}% will be written later, at \shipout
@@ -9217,19 +9104,6 @@ end
\catcode`\^^]=\other
\catcode`\^^^=\other
\catcode`\^^_=\other
- % It was suggested to set the catcode of ^ to 7, which would allow ^^e4 etc.
- % in xref tags, i.e., node names. But since ^^e4 notation isn't
- % supported in the main text, it doesn't seem desirable. Furthermore,
- % that is not enough: for node names that actually contain a ^
- % character, we would end up writing a line like this: 'xrdef {'hat
- % b-title}{'hat b} and \xrdef does a \csname...\endcsname on the first
- % argument, and \hat is not an expandable control sequence. It could
- % all be worked out, but why? Either we support ^^ or we don't.
- %
- % The other change necessary for this was to define \auxhat:
- % \def\auxhat{\def^{'hat }}% extra space so ok if followed by letter
- % and then to call \auxhat in \setq.
- %
\catcode`\^=\other
%
% Special characters. Should be turned off anyway, but...
@@ -9247,14 +9121,7 @@ end
\catcode`\%=\other
\catcode`+=\other % avoid \+ for paranoia even though we've turned it off
%
- % This is to support \ in node names and titles, since the \
- % characters end up in a \csname. It's easier than
- % leaving it active and making its active definition an actual \
- % character. What I don't understand is why it works in the *value*
- % of the xrdef. Seems like it should be a catcode12 \, and that
- % should not typeset properly. But it works, so I'm moving on for
- % now. --karl, 15jan04.
- \catcode`\\=\other
+ \catcode`\\=\active
%
% @ is our escape character in .aux files, and we need braces.
\catcode`\{=1
@@ -9585,13 +9452,13 @@ end
\global\advance\floatno by 1
%
{%
- % This magic value for \lastsection is output by \setref as the
+ % This magic value for \currentsection is output by \setref as the
% XREFLABEL-title value. \xrefX uses it to distinguish float
% labels (which have a completely different output format) from
% node and anchor labels. And \xrdef uses it to construct the
% lists of floats.
%
- \edef\lastsection{\floatmagic=\safefloattype}%
+ \edef\currentsection{\floatmagic=\safefloattype}%
\setref{\floatlabel}{Yfloat}%
}%
\fi
@@ -9714,7 +9581,7 @@ end
% #1 is the control sequence we are passed; we expand into a conditional
% which is true if #1 represents a float ref. That is, the magic
-% \lastsection value which we \setref above.
+% \currentsection value which we \setref above.
%
\def\iffloat#1{\expandafter\doiffloat#1==\finish}
%
@@ -11202,21 +11069,14 @@ directory should work if nowhere else does.}
\relax
}
-% define all Unicode characters we know about, for the sake of @U.
+% Define all Unicode characters we know about. This makes UTF-8 the default
+% input encoding and allows @U to work.
\iftxinativeunicodecapable
\nativeunicodechardefsatu
\else
\utfeightchardefs
\fi
-
-% Make non-ASCII characters printable again for compatibility with
-% existing Texinfo documents that may use them, even without declaring a
-% document encoding.
-%
-\setnonasciicharscatcode \other
-
-
\message{formatting,}
\newdimen\defaultparindent \defaultparindent = 15pt
@@ -11532,11 +11392,9 @@ directory should work if nowhere else does.}
% \backslashcurfont outputs one backslash character in current font,
% as in \char`\\.
\global\chardef\backslashcurfont=`\\
-\global\let\rawbackslashxx=\backslashcurfont % let existing .??s files work
-% \realbackslash is an actual character `\' with catcode other, and
-% \doublebackslash is two of them (for the pdf outlines).
-{\catcode`\\=\other @gdef@realbackslash{\} @gdef@doublebackslash{\\}}
+% \realbackslash is an actual character `\' with catcode other.
+{\catcode`\\=\other @gdef@realbackslash{\}}
% In Texinfo, backslash is an active character; it prints the backslash
% in fixed width font.
@@ -11554,10 +11412,8 @@ directory should work if nowhere else does.}
@def@ttbackslash{{@tt @ifmmode @mathchar29020 @else @backslashcurfont @fi}}
@let@backslashchar = @ttbackslash % @backslashchar{} is for user documents.
-% \rawbackslash defines an active \ to do \backslashcurfont.
% \otherbackslash defines an active \ to be a literal `\' character with
-% catcode other. We switch back and forth between these.
-@gdef@rawbackslash{@let\=@backslashcurfont}
+% catcode other.
@gdef@otherbackslash{@let\=@realbackslash}
% Same as @turnoffactive except outputs \ as {\tt\char`\\} instead of
@@ -11629,7 +11485,7 @@ directory should work if nowhere else does.}
@ifx\@eatinput @let\ = @ttbackslash @fi
@catcode13=5 % regular end of line
@enableemergencynewline
- @let@c=@texinfoc
+ @let@c=@comment
@let@parsearg@originalparsearg
% Also turn back on active characters that might appear in the input
% file name, in case not using a pre-dumped format.
@@ -11675,7 +11531,7 @@ directory should work if nowhere else does.}
@markupsetuprqdefault
@c Local variables:
-@c eval: (add-hook 'write-file-hooks 'time-stamp)
+@c eval: (add-hook 'before-save-hook 'time-stamp)
@c page-delimiter: "^\\\\message\\|emacs-page"
@c time-stamp-start: "def\\\\texinfoversion{"
@c time-stamp-format: "%:y-%02m-%02d.%02H"
diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi
index 633f2d16b6b..e376fc7495e 100644
--- a/doc/misc/tramp.texi
+++ b/doc/misc/tramp.texi
@@ -12,16 +12,6 @@
@c This is *so* much nicer :)
@footnotestyle end
-@c Macro for formatting a file name according to the respective
-@c syntax. Macro arguments should not have any leading or trailing
-@c whitespace. Not very elegant, but I don't know it better.
-
-@macro trampfn {method, userhost, localname}
-@value{prefix}@c
-\method\@value{postfixhop}@c
-\userhost\@value{postfix}\localname\
-@end macro
-
@copying
Copyright @copyright{} 1999--2019 Free Software Foundation, Inc.
@@ -83,9 +73,9 @@ Savannah Project Page}.
@end ifhtml
There is a mailing list for @value{tramp}, available at
-@email{tramp-devel@@gnu.org}, and archived at
-@uref{https://lists.gnu.org/r/tramp-devel/, the
-@value{tramp} Mail Archive}.
+@email{@value{tramp-bug-report-address}}, and archived at
+@uref{https://lists.gnu.org/r/tramp-devel/, the @value{tramp} Mail
+Archive}.
@page
@insertcopying
@@ -96,7 +86,6 @@ There is a mailing list for @value{tramp}, available at
For the end user:
* Obtaining @value{tramp}:: How to obtain @value{tramp}.
-* History:: History of @value{tramp}.
@ifset installchapter
* Installation:: Installing @value{tramp} with your Emacs.
@end ifset
@@ -122,8 +111,11 @@ For the developer:
--- The Detailed Node Listing ---
@c
@ifset installchapter
+
Installing @value{tramp} with your Emacs
+* System Requirements:: Prerequisites for :@value{tramp} installation.
+* Basic Installation:: Installation steps.:
* Installation parameters:: Parameters in order to control installation.
* Testing:: A test suite for @value{tramp}.
* Load paths:: How to plug-in @value{tramp} into your environment.
@@ -162,6 +154,7 @@ Using @value{tramp}
* Ad-hoc multi-hops:: Declaring multiple hops in the file name.
* Remote processes:: Integration with other Emacs packages.
* Cleanup remote connections:: Cleanup remote connections.
+* Archive file names:: Access to files in file archives.
How file names, directories and localnames are mangled and managed
@@ -385,31 +378,6 @@ $ autoconf
@end example
-@node History
-@chapter History of @value{tramp}
-@cindex history
-@cindex development history
-
-@value{tramp} development started at the end of November 1998 as
-@file{rssh.el}. It provided only one method of access. It used
-@command{ssh} for login and @command{scp} to transfer file contents.
-The name was changed to @file{rcp.el} before it got its present name
-@value{tramp}. New methods of remote access were added, so was support
-for version control.
-
-April 2000 was the first time when multi-hop methods were added. In
-July 2002, @value{tramp} unified file names with Ange FTP@. In July
-2004, proxy hosts replaced multi-hop methods. Running commands on
-remote hosts was introduced in December 2005. Support for gateways
-since April 2007 (and removed in December 2016). GVFS integration
-started in February 2009. Remote commands on MS Windows hosts since
-September 2011. Ad-hoc multi-hop methods (with a changed syntax)
-re-enabled in November 2011. In November 2012, added Juergen
-Hoetzel's @file{tramp-adb.el}.
-
-XEmacs support was stopped in January 2016. Since March 2017,
-@value{tramp} syntax mandates a method.
-
@c Installation chapter is necessary only in case of standalone
@c installation. Text taken from trampinst.texi.
@ifset installchapter
@@ -463,13 +431,13 @@ this case it is written as @code{host#port}.
@anchor{Quick Start Guide: @option{ssh} and @option{plink} methods}
@section Using @option{ssh} and @option{plink}
-@cindex method ssh
-@cindex ssh method
-@cindex method plink
-@cindex plink method
+@cindex method @option{ssh}
+@cindex @option{ssh} method
+@cindex method @option{plink}
+@cindex @option{plink} method
If your local host runs an SSH client, and the remote host runs an SSH
-server, the most simple remote file name is
+server, the simplest remote file name is
@file{@trampfn{ssh,user@@host,/path/to/file}}. The remote file name
@file{@trampfn{ssh,,}} opens a remote connection to yourself on the
local host, and is taken often for testing @value{tramp}.
@@ -482,12 +450,12 @@ an @command{ssh} server:
@anchor{Quick Start Guide: @option{su}, @option{sudo} and @option{sg} methods}
@section Using @option{su}, @option{sudo} and @option{sg}
-@cindex method su
-@cindex su method
-@cindex method sudo
-@cindex sudo method
-@cindex method sg
-@cindex sg method
+@cindex method @option{su}
+@cindex @option{su} method
+@cindex method @option{sudo}
+@cindex @option{sudo} method
+@cindex method @option{sg}
+@cindex @option{sg} method
Sometimes, it is necessary to work on your local host under different
permissions. For this, you could use the @option{su} or @option{sudo}
@@ -500,12 +468,25 @@ The method @option{sg} stands for ``switch group''; the changed group
must be used here as user name. The default host name is the same.
+@anchor{Quick Start Guide: @option{sudoedit} method}
+@section Using @command{sudoedit}
+@cindex method @option{sudoedit}
+@cindex @option{sudoedit} method
+
+The @option{sudoedit} method is similar to the @option{sudo} method.
+However, it is a different implementation: it does not keep an open
+session running in the background. This is for security reasons; on
+the backside this method is less performant than the @option{sudo}
+method, it is restricted to the @samp{localhost} only, and it does not
+support external processes.
+
+
@anchor{Quick Start Guide: @option{smb} method}
@section Using @command{smbclient}
-@cindex method smb
-@cindex smb method
-@cindex ms windows (with smb method)
-@cindex smbclient
+@cindex method @option{smb}
+@cindex @option{smb} method
+@cindex ms windows (with @option{smb} method)
+@cindex @command{smbclient}
In order to access a remote MS Windows host or Samba server, the
@command{smbclient} client is used. The remote file name syntax is
@@ -518,39 +499,48 @@ of the local file name is the share exported by the remote host,
@section Using GVFS-based methods
@cindex methods, gvfs
@cindex gvfs based methods
-@cindex method sftp
-@cindex sftp method
-@cindex method afp
-@cindex afp method
-@cindex method dav
-@cindex method davs
-@cindex dav method
-@cindex davs method
-
-On systems, which have installed the virtual file system for the Gnome
-Desktop (GVFS), its offered methods could be used by @value{tramp}.
-Examples are @file{@trampfn{sftp,user@@host,/path/to/file}},
+@cindex method @option{sftp}
+@cindex @option{sftp} method
+@cindex method @option{afp}
+@cindex @option{afp} method
+@cindex method @option{dav}
+@cindex method @option{davs}
+@cindex @option{dav} method
+@cindex @option{davs} method
+
+On systems, which have installed the virtual file system for the
+@acronym{GNOME} Desktop (GVFS), its offered methods could be used by
+@value{tramp}. Examples are
+@file{@trampfn{sftp,user@@host,/path/to/file}},
@file{@trampfn{afp,user@@host,/path/to/file}} (accessing Apple's AFP
file system), @file{@trampfn{dav,user@@host,/path/to/file}} and
@file{@trampfn{davs,user@@host,/path/to/file}} (for WebDAV shares).
-@anchor{Quick Start Guide: Google Drive}
-@section Using Google Drive
-@cindex method gdrive
-@cindex gdrive method
+@anchor{Quick Start Guide: GNOME Online Accounts based methods}
+@section Using @acronym{GNOME} Online Accounts based methods
+@cindex @acronym{GNOME} Online Accounts
+@cindex method @option{gdrive}
+@cindex @option{gdrive} method
@cindex google drive
+@cindex method @option{nextcloud}
+@cindex @option{nextcloud} method
+@cindex owncloud
-Another GVFS-based method allows to access a Google Drive file system.
-The file name syntax is here always
-@file{@trampfn{gdrive,john.doe@@gmail.com,/path/to/file}}.
-@samp{john.doe@@gmail.com} stands here for your Google Drive account.
+GVFS-based methods include also @acronym{GNOME} Online Accounts, which
+support the @option{Files} service. These are the Google Drive file
+system, and the OwnCloud/NextCloud file system. The file name syntax
+is here always
+@file{@trampfn{gdrive,john.doe@@gmail.com,/path/to/file}}
+(@samp{john.doe@@gmail.com} stands here for your Google Drive
+account), or @file{@trampfn{nextcloud,user@@host#8081,/path/to/file}}
+(@samp{8081} stands for the port number) for OwnCloud/NextCloud files.
@anchor{Quick Start Guide: Android}
@section Using Android
-@cindex method adb
-@cindex adb method
+@cindex method @option{adb}
+@cindex @option{adb} method
@cindex android
An Android device, which is connected via USB to your local host, can
@@ -558,6 +548,18 @@ be accessed via the @command{adb} command. No user or host name is
needed. The file name syntax is @file{@trampfn{adb,,/path/to/file}}.
+@anchor{Quick Start Guide: @option{rclone} method}
+@section Using @command{rclone}
+@cindex method @option{rclone}
+@cindex @option{rclone} method
+
+A convenient way to access system storages is the @command{rclone}
+program. If you have configured a storage in @command{rclone} under a
+name @samp{storage} (for example), you could access it via the remote
+file name syntax @file{@trampfn{rclone,storage,/path/to/file}}. User
+names are not needed.
+
+
@node Configuration
@chapter Configuring @value{tramp}
@cindex configuration
@@ -582,6 +584,13 @@ installed and loaded:
(customize-set-variable 'tramp-verbose 6 "Enable remote command traces")
@end lisp
+For functions used to configure @value{tramp}, the following clause
+might be used in your init file:
+
+@lisp
+(with-eval-after-load 'tramp (tramp-change-syntax 'simplified))
+@end lisp
+
@menu
* Connection types:: Types of connections to remote hosts.
@@ -654,8 +663,8 @@ Inline methods can work in situations where an external transfer
program is unavailable. Inline methods also work when transferring
files between different @emph{user identities} on the same host.
-@cindex uuencode
-@cindex mimencode
+@cindex @command{uuencode}
+@cindex @command{mimencode}
@cindex base-64 encoding
@value{tramp} checks the remote host for the availability and
@@ -676,15 +685,15 @@ such optimization.
@table @asis
@item @option{rsh}
-@cindex method rsh
-@cindex rsh method
+@cindex method @option{rsh}
+@cindex @option{rsh} method
@command{rsh} is an option for connecting to hosts within local
networks since @command{rsh} is not as secure as other methods.
@item @option{ssh}
-@cindex method ssh
-@cindex ssh method
+@cindex method @option{ssh}
+@cindex @option{ssh} method
@command{ssh} is a more secure option than others to connect to a
remote host.
@@ -695,15 +704,15 @@ host name, a hash sign, then a port number). It is the same as passing
@samp{-p 42} to the @command{ssh} command.
@item @option{telnet}
-@cindex method telnet
-@cindex telnet method
+@cindex method @option{telnet}
+@cindex @option{telnet} method
Connecting to a remote host with @command{telnet} is as insecure
as the @option{rsh} method.
@item @option{su}
-@cindex method su
-@cindex su method
+@cindex method @option{su}
+@cindex @option{su} method
Instead of connecting to a remote host, @command{su} program allows
editing as another user. The host can be either @samp{localhost} or
@@ -711,21 +720,27 @@ the host returned by the function @command{(system-name)}. See
@ref{Multi-hops} for an exception to this behavior.
@item @option{sudo}
-@cindex method sudo
-@cindex sudo method
+@cindex method @option{sudo}
+@cindex @option{sudo} method
Similar to @option{su} method, @option{sudo} uses @command{sudo}.
@command{sudo} must have sufficient rights to start a shell.
+For security reasons, a @option{sudo} connection is disabled after a
+predefined timeout (5 minutes per default). This can be changed, see
+@ref{Predefined connection information}.
+
@item @option{doas}
-@cindex method doas
-@cindex doas method
+@cindex method @option{doas}
+@cindex @option{doas} method
-This method is used on OpenBSD like the @command{sudo} command.
+This method is used on OpenBSD like the @command{sudo} command. Like
+the @option{sudo} method, a @option{doas} connection is disabled after
+a predefined timeout.
@item @option{sg}
-@cindex method sg
-@cindex sg method
+@cindex method @option{sg}
+@cindex @option{sg} method
The @command{sg} program allows editing as different group. The host
can be either @samp{localhost} or the host returned by the function
@@ -734,8 +749,8 @@ denotes a group name. See @ref{Multi-hops} for an exception to this
behavior.
@item @option{sshx}
-@cindex method sshx
-@cindex sshx method
+@cindex method @option{sshx}
+@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}
@@ -755,23 +770,23 @@ missing shell prompts that confuses @value{tramp}.
@option{sshx} supports the @samp{-p} argument.
@item @option{krlogin}
-@cindex method krlogin
-@cindex krlogin method
-@cindex kerberos (with krlogin method)
+@cindex method @option{krlogin}
+@cindex @option{krlogin} method
+@cindex kerberos (with @option{krlogin} method)
This method is also similar to @option{ssh}. It uses the
@command{krlogin -x} command only for remote host login.
@item @option{ksu}
-@cindex method ksu
-@cindex ksu method
-@cindex kerberos (with ksu method)
+@cindex method @option{ksu}
+@cindex @option{ksu} method
+@cindex kerberos (with @option{ksu} method)
This is another method from the Kerberos suite. It behaves like @option{su}.
@item @option{plink}
-@cindex method plink
-@cindex plink method
+@cindex method @option{plink}
+@cindex @option{plink} method
@option{plink} method is for MS Windows users with the PuTTY
implementation of SSH@. It uses @samp{plink -ssh} to log in to the
@@ -783,8 +798,8 @@ session.
@option{plink} method supports the @samp{-P} argument.
@item @option{plinkx}
-@cindex method plinkx
-@cindex plinkx method
+@cindex method @option{plinkx}
+@cindex @option{plinkx} method
Another method using PuTTY on MS Windows with session names instead of
host names. @option{plinkx} calls @samp{plink -load @var{session}
@@ -814,10 +829,9 @@ methods.
@table @asis
@item @option{rcp}
-@cindex method rcp
-@cindex rcp method
-@cindex rcp (with rcp method)
-@cindex rsh (with rcp method)
+@cindex method @option{rcp}
+@cindex @option{rcp} method
+@cindex @command{rsh} (with @option{rcp} method)
This method uses the @command{rsh} and @command{rcp} commands to
connect to the remote host and transfer files. This is the fastest
@@ -827,10 +841,9 @@ The alternative method @option{remcp} uses the @command{remsh} and
@command{rcp} commands.
@item @option{scp}
-@cindex method scp
-@cindex scp method
-@cindex scp (with scp method)
-@cindex ssh (with scp method)
+@cindex method @option{scp}
+@cindex @option{scp} method
+@cindex @command{ssh} (with @option{scp} method)
Using a combination of @command{ssh} to connect and @command{scp} to
transfer is the most secure. While the performance is good, it is
@@ -844,10 +857,9 @@ argument list to @command{ssh}, and @samp{-P 42} in the argument list
to @command{scp}.
@item @option{rsync}
-@cindex method rsync
-@cindex rsync method
-@cindex rsync (with rsync method)
-@cindex ssh (with rsync method)
+@cindex method @option{rsync}
+@cindex @option{rsync} method
+@cindex @command{ssh} (with @option{rsync} method)
@command{ssh} command to connect in combination with @command{rsync}
command to transfer is similar to the @option{scp} method.
@@ -859,10 +871,9 @@ is lost if the file exists only on one side of the connection.
This method supports the @samp{-p} argument.
@item @option{scpx}
-@cindex method scpx
-@cindex scpx method
-@cindex scp (with scpx method)
-@cindex ssh (with scpx method)
+@cindex method @option{scpx}
+@cindex @option{scpx} method
+@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
@@ -876,16 +887,14 @@ This method supports the @samp{-p} argument.
@item @option{pscp}
@item @option{psftp}
-@cindex method pscp
-@cindex pscp method
-@cindex pscp (with pscp method)
-@cindex plink (with pscp method)
-@cindex putty (with pscp method)
-@cindex method psftp
-@cindex psftp method
-@cindex pscp (with psftp method)
-@cindex plink (with psftp method)
-@cindex putty (with psftp method)
+@cindex method @option{pscp}
+@cindex @option{pscp} method
+@cindex @command{plink} (with @option{pscp} method)
+@cindex @command{putty} (with @option{pscp} method)
+@cindex method @option{psftp}
+@cindex @option{psftp} method
+@cindex @command{plink} (with @option{psftp} method)
+@cindex @command{putty} (with @option{psftp} method)
These methods are similar to @option{scp} or @option{sftp}, but they
use the @command{plink} command to connect to the remote host, and
@@ -898,10 +907,9 @@ session.
These methods support the @samp{-P} argument.
@item @option{fcp}
-@cindex method fcp
-@cindex fcp method
-@cindex fsh (with fcp method)
-@cindex fcp (with fcp method)
+@cindex method @option{fcp}
+@cindex @option{fcp} method
+@cindex @command{fsh} (with @option{fcp} method)
This method is similar to @option{scp}, but uses @command{fsh} to
connect and @command{fcp} to transfer files. @command{fsh/fcp}, a
@@ -913,18 +921,17 @@ benefits.
The command used for this connection is: @samp{fsh @var{host} -l
@var{user} /bin/sh -i}
-@cindex method fsh
-@cindex fsh method
+@cindex method @option{fsh}
+@cindex @option{fsh} method
@option{fsh} has no inline method since the multiplexing it offers is
not useful for @value{tramp}. @command{fsh} connects to remote host
and @value{tramp} keeps that one connection open.
@item @option{nc}
-@cindex method nc
-@cindex nc method
-@cindex nc (with nc method)
-@cindex telnet (with nc method)
+@cindex method @option{nc}
+@cindex @option{nc} method
+@cindex @command{telnet} (with @option{nc} method)
Using @command{telnet} to connect and @command{nc} to transfer files
is sometimes the only combination suitable for accessing routers or
@@ -932,19 +939,43 @@ NAS hosts. These dumb devices have severely restricted local shells,
such as the @command{busybox} and do not host any other encode or
decode programs.
+@item @option{sudoedit}
+@cindex method @option{sudoedit}
+@cindex @option{sudoedit} method
+
+The @option{sudoedit} method allows to edit a file as a different user
+on the local host. You could regard this as @value{tramp}'s
+implementation of the @command{sudoedit}. Contrary to the
+@option{sudo} method, all magic file name functions are implemented by
+single @command{sudo @dots{}} commands. The purpose is to make
+editing such a file as secure as possible; there must be no session
+running in the Emacs background which could be attacked from inside
+Emacs.
+
+Consequently, external processes are not implemented.
+
+The host name of such remote file names must represent the local host.
+Since the default value is already proper, it is recommended not to
+use any host name in the remote file name, like
+@file{@trampfn{sudoedit,,/path/to/file}} or
+@file{@trampfn{sudoedit,user@@,/path/to/file}}.
+
+Like the @option{sudo} method, a @option{sudoedit} password expires
+after a predefined timeout.
+
@item @option{ftp}
-@cindex method ftp
-@cindex ftp method
+@cindex method @option{ftp}
+@cindex @option{ftp} method
When @value{tramp} uses @option{ftp}, it forwards requests to whatever
ftp program is specified by Ange FTP. This external program must be
capable of servicing requests from @value{tramp}.
@item @option{smb}
-@cindex method smb
-@cindex smb method
-@cindex ms windows (with smb method)
-@cindex smbclient
+@cindex method @option{smb}
+@cindex @option{smb} method
+@cindex ms windows (with @option{smb} method)
+@cindex @command{smbclient}
This non-native @value{tramp} method connects via the Server Message
Block (SMB) networking protocol to hosts running file servers that are
@@ -1015,9 +1046,9 @@ can.
@item @option{adb}
-@cindex method adb
-@cindex adb method
-@cindex android (with adb method)
+@cindex method @option{adb}
+@cindex @option{adb} method
+@cindex android (with @option{adb} method)
@vindex tramp-adb-program
@vindex PATH@r{, environment variable}
@@ -1052,6 +1083,48 @@ specified using @file{device#42} host name syntax or @value{tramp} can
use the default value as declared in @command{adb} command. Port
numbers are not applicable to Android devices connected through USB@.
+
+@item @option{rclone}
+@cindex method @option{rclone}
+@cindex @option{rclone} method
+
+@vindex tramp-rclone-program
+The program @command{rclone} allows to access different system
+storages in the cloud, see @url{https://rclone.org/} for a list of
+supported systems. If the @command{rclone} program isn't found in
+your @env{PATH} environment variable, you can tell Tramp its absolute
+path via the user option @code{tramp-rclone-program}.
+
+A system storage must be configured via the @command{rclone config}
+command, outside Emacs. If you have configured a storage in
+@command{rclone} under a name @samp{storage} (for example), you could
+access it via the remote file name
+
+@example
+@trampfn{rclone,storage,/path/to/file}
+@end example
+
+User names are part of the @command{rclone} configuration, and not
+needed in the remote file name. If a user name is contained in the
+remote file name, it is ignored.
+
+Internally, Tramp mounts the remote system storage at location
+@file{/tmp/tramp.rclone.storage}, with @file{storage} being the name
+of the configured system storage.
+
+Optional flags to the different @option{rclone} operations could be
+passed as connection property, @xref{Predefined connection
+information}. Supported properties are @samp{mount-args},
+@samp{copyto-args} and @samp{moveto-args}.
+
+Access via @option{rclone} is slow. If you have an alternative method
+for accessing the system storage, you shall prefer this. @ref{GVFS
+based methods} for example, methods @option{gdrive} and
+@option{nextcloud}.
+
+@strong{Note}: The @option{rclone} method is experimental, don't use
+it in production systems!
+
@end table
@@ -1061,7 +1134,7 @@ numbers are not applicable to Android devices connected through USB@.
@cindex gvfs based methods
@cindex dbus
-GVFS is the virtual file system for the Gnome Desktop,
+GVFS is the virtual file system for the @acronym{GNOME} Desktop,
@uref{https://en.wikipedia.org/wiki/GVFS}. Remote files on GVFS are
mounted locally through FUSE and @value{tramp} uses this locally
mounted directory internally.
@@ -1072,8 +1145,8 @@ D-Bus, dbus}.
@table @asis
@item @option{afp}
-@cindex method afp
-@cindex afp method
+@cindex method @option{afp}
+@cindex @option{afp} method
This method is for connecting to remote hosts with the Apple Filing
Protocol for accessing files on macOS volumes. @value{tramp} access
@@ -1082,10 +1155,10 @@ syntax requires a leading volume (share) name, for example:
@item @option{dav}
@item @option{davs}
-@cindex method dav
-@cindex method davs
-@cindex dav method
-@cindex davs method
+@cindex method @option{dav}
+@cindex method @option{davs}
+@cindex @option{dav} method
+@cindex @option{davs} method
@option{dav} method provides access to WebDAV files and directories
based on standard protocols, such as HTTP@. @option{davs} does the same
@@ -1093,11 +1166,11 @@ but with SSL encryption. Both methods support the port numbers.
Paths being part of the WebDAV volume to be mounted by GVFS, as it is
common for OwnCloud or NextCloud file names, are not supported by
-these methods.
+these methods. See method @option{nextcloud} for handling them.
@item @option{gdrive}
-@cindex method gdrive
-@cindex gdrive method
+@cindex method @option{gdrive}
+@cindex @option{gdrive} method
@cindex google drive
Via the @option{gdrive} method it is possible to access your Google
@@ -1111,36 +1184,36 @@ Since Google Drive uses cryptic blob file names internally,
could produce unexpected behavior in case two files in the same
directory have the same @code{display-name}, such a situation must be avoided.
-@item @option{obex}
-@cindex method obex
-@cindex obex method
+@item @option{nextcloud}
+@cindex @acronym{GNOME} Online Accounts
+@cindex method @option{nextcloud}
+@cindex @option{nextcloud} method
+@cindex owncloud
-OBEX is an FTP-like access protocol for cell phones and similar simple
-devices. @value{tramp} supports OBEX over Bluetooth.
+As the name indicates, the method @option{nextcloud} allows you to
+access OwnCloud or NextCloud hosted files and directories. Like the
+@option{gdrive} method, your credentials must be populated in your
+@command{Online Accounts} application outside Emacs. The method
+supports port numbers.
@item @option{sftp}
-@cindex method sftp
-@cindex sftp method
+@cindex method @option{sftp}
+@cindex @option{sftp} method
This method uses @command{sftp} in order to securely access remote
hosts. @command{sftp} is a more secure option for connecting to hosts
that for security reasons refuse @command{ssh} connections.
-@item @option{synce}
-@cindex method synce
-@cindex synce method
-
-@option{synce} method allows connecting to MS Windows Mobile devices.
-It uses GVFS for mounting remote files and directories via FUSE and
-requires the SYNCE-GVFS plugin.
-
@end table
@defopt tramp-gvfs-methods
This user option is a list of external methods for GVFS@. By default,
this list includes @option{afp}, @option{dav}, @option{davs},
-@option{gdrive}, @option{obex}, @option{sftp} and @option{synce}.
-Other methods to include are: @option{ftp} and @option{smb}.
+@option{gdrive}, @option{nextcloud} and @option{sftp}. Other methods
+to include are @option{ftp}, @option{http}, @option{https} and
+@option{smb}. These methods are not intended to be used directly as
+GVFS based method. Instead, they are added here for the benefit of
+@ref{Archive file names}.
@end defopt
@@ -1378,7 +1451,8 @@ connect to @samp{bastion.your.domain}, then:
@end lisp
@var{proxy} can take patterns @code{%h} or @code{%u} for @var{host} or
-@var{user} respectively.
+@var{user} respectively. Ports or domains, if they are part of
+a hop file name, are not expanded by those patterns.
To login as @samp{root} on remote hosts in the domain
@samp{your.domain}, but login as @samp{root} is disabled for non-local
@@ -1395,8 +1469,10 @@ Opening @file{@trampfn{sudo,randomhost.your.domain,}} first connects
to @samp{randomhost.your.domain} via @code{ssh} under your account
name, and then performs @code{sudo -u root} on that host.
-It is key for the sudo method in the above example to be applied on
-the host after reaching it and not on the local host.
+It is key for the @option{sudo} method in the above example to be
+applied on the host after reaching it and not on the local host.
+@value{tramp} checks therefore, that the host name for such hops
+matches the host name of the previous hop.
@var{host}, @var{user} and @var{proxy} can also take Lisp forms. These
forms when evaluated must return either a string or @code{nil}.
@@ -1492,6 +1568,74 @@ predefined methods. Any part of this list can be modified with more
suitable settings. Refer to the Lisp documentation of that variable,
accessible with @kbd{C-h v tramp-methods @key{RET}}.
+In the ELPA archives, there are several examples of such extensions.
+They can be installed with Emacs' Package Manager. This includes
+
+@table @samp
+@c @item anything-tramp
+@c @item counsel-tramp
+@c @item helm-tramp
+@c Contact Masashí Míyaura <masasam@users.noreply.github.com>
+
+@c @item ibuffer-tramp.el
+@c Contact Svend Sorensen <svend@@ciffer.net>
+
+@item docker-tramp
+@cindex method @option{docker}
+@cindex @option{docker} method
+Integration for Docker containers. A container is accessed via
+@file{@trampfn{docker,user@@container,/path/to/file}}, where
+@samp{user} is the (optional) user that you want to use, and
+@samp{container} is the id or name of the container.
+
+@item kubernetes-tramp
+@cindex method @option{kubectl}
+@cindex @option{kubectl} method
+Integration for Docker containers deployed in a Kubernetes cluster.
+It is derived from @samp{docker-tramp}. A container is accessed via
+@file{@trampfn{kubectl,user@@container,/path/to/file}}, @samp{user}
+and @samp{container} have the same meaning as in @samp{docker-tramp}.
+
+@item lxc-tramp
+@cindex method @option{lxc}
+@cindex @option{lxc} method
+Integration for LXC containers. A container is accessed via
+@file{@trampfn{lxc,container,/path/to/file}}, @samp{container} has the
+same meaning as in @samp{docker-tramp}. A @samp{user} specification
+is ignored.
+
+@item lxd-tramp
+@cindex method @option{lxd}
+@cindex @option{lxd} method
+Integration for LXD containers. A container is accessed via
+@file{@trampfn{lxd,user@@container,/path/to/file}}, @samp{user} and
+@samp{container} have the same meaning as in @samp{docker-tramp}.
+
+@item magit-tramp
+@cindex method @option{git}
+@cindex @option{git} method
+Browing git repositories with @code{magit}. A versioned file is accessed via
+@file{@trampfn{git,rev@@root-dir,/path/to/file}}. @samp{rev} is a git
+revision, and @samp{root-dir} is a virtual host name for the root
+directory, specified in @code{magit-tramp-hosts-alist}.
+
+@item tramp-hdfs
+@cindex method @option{hdfs}
+@cindex @option{hdfs} method
+Access of a hadoop/hdfs file system. A file is accessed via
+@file{@trampfn{hdfs,user@@node,/path/to/file}}, where @samp{user} is
+the user that you want to use, and @samp{node} is the name of the
+hadoop server.
+
+@item vagrant-tramp
+@cindex method @option{vagrant}
+@cindex @option{vagrant} method
+Convenience method to access vagrant boxes. It is often used in
+multi-hop file names like
+@file{@value{prefix}vagrant@value{postfixhop}box|sudo@value{postfixhop}box@value{postfix}/path/to/file},
+where @samp{box} is the name of the vagrant box.
+@end table
+
@node Customizing Completion
@section Selecting config files for user/host name completion
@@ -1641,7 +1785,7 @@ the need.
The package @file{auth-source.el}, originally developed for No Gnus,
reads passwords from different sources, @xref{Help for users, ,
auth-source, auth}. The default authentication file is
-@file{~/.authinfo.gpg}, but this can be changed via the variable
+@file{~/.authinfo.gpg}, but this can be changed via the user option
@code{auth-sources}.
@noindent
@@ -1660,9 +1804,26 @@ file name syntax, must be appended to the machine and login items:
machine melancholia#4711 port davs login daniel%BIZARRE password geheim
@end example
+@vindex auth-source-save-behavior
+If there doesn't exist a proper entry, the password is read
+interactively. After successful login (verification of the password),
+it is offered to save a corresponding entry for further use by
+@code{auth-source} backends which support this. This could be changed
+by setting the user option @code{auth-source-save-behavior} to @code{nil}.
+
@vindex auth-source-debug
Set @code{auth-source-debug} to @code{t} to debug messages.
+@vindex ange-ftp-netrc-filename
+@strong{Note} that @file{auth-source.el} is not used for @option{ftp}
+connections, because @value{tramp} passes the work to Ange FTP@. If
+you want, for example, use your @file{~/.authinfo.gpg} authentication
+file, you must customize @code{ange-ftp-netrc-filename}:
+
+@lisp
+(customize-set-variable 'ange-ftp-netrc-filename "~/.authinfo.gpg")
+@end lisp
+
@anchor{Caching passwords}
@subsection Caching passwords
@@ -1742,6 +1903,24 @@ The parameters @code{tramp-remote-shell} and
@code{tramp-remote-shell-login} in @code{tramp-methods} now have new
values for the remote host.
+A common use case is to override the session timeout of a connection,
+that is the time (in seconds) after a connection is disabled, and must
+be reestablished. This can be set for any connection; for the
+@option{sudo} and @option{doas} methods there exist predefined values.
+A value of @code{nil} disables this feature. For example:
+
+@lisp
+@group
+(add-to-list 'tramp-connection-properties
+ (list (regexp-quote "@trampfn{sudo,root@@system-name,}")
+ "session-timeout" 30))
+@end group
+@end lisp
+
+@noindent
+@samp{system-name} stands here for the host returned by the function
+@command{(system-name)}.
+
@var{property} could also be any property found in
@code{tramp-persistency-file-name}.
@@ -1807,10 +1986,43 @@ preserves the path value, which can be used to update
shell supports the login argument @samp{-l}.
@end defopt
+Starting with Emacs 26, @code{tramp-remote-path} can be set per host
+via connection-local
+@ifinfo
+variables, @xref{Connection Variables, , , emacs}.
+@end ifinfo
+@ifnotinfo
+variables.
+@end ifnotinfo
+You could define your own search directories like this:
+
+@lisp
+@group
+(connection-local-set-profile-variables 'remote-path-with-bin
+ '((tramp-remote-path . ("~/bin" tramp-default-remote-path))))
+@end group
+
+@group
+(connection-local-set-profile-variables 'remote-path-with-apply-pub-bin
+ '((tramp-remote-path . ("/appli/pub/bin" tramp-default-remote-path))))
+@end group
+
+@group
+(connection-local-set-profiles
+ '(:application tramp :machine "randomhost") 'remote-path-with-bin)
+@end group
+
+@group
+(connection-local-set-profiles
+ '(:application tramp :user "anotheruser" :machine "anotherhost")
+ 'remote-path-with-apply-pub-bin)
+@end group
+@end lisp
+
When remote search paths are changed, local @value{tramp} caches must
-be recomputed. To force @value{tramp} to recompute afresh, exit
-Emacs, remove the persistent file (@pxref{Connection caching}), and
-restart Emacs.
+be recomputed. To force @value{tramp} to recompute afresh, call
+@kbd{M-x tramp-cleanup-this-connection @key{RET}} or friends
+(@pxref{Cleanup remote connections}).
@node Remote shell setup
@@ -2019,10 +2231,10 @@ shell-specific config files. For example, bash can use
parsing. This redefinition affects the looks of a prompt in an
interactive remote shell through commands, such as @kbd{M-x shell
@key{RET}}. Such prompts, however, can be reset to something more
-readable and recognizable using these @value{tramp} variables.
+readable and recognizable using these environment variables.
-@value{tramp} sets the @env{INSIDE_EMACS} variable in the startup
-script file @file{~/.emacs_SHELLNAME}.
+@value{tramp} sets the @env{INSIDE_EMACS} environment variable in the
+startup script file @file{~/.emacs_SHELLNAME}.
@env{SHELLNAME} is @code{bash} or equivalent shell names. Change it by
setting the environment variable @env{ESHELL} in the @file{.emacs} as
@@ -2048,8 +2260,8 @@ fi
@end ifinfo
@item @command{busybox} / @command{nc}
-@cindex unix command nc
-@cindex nc unix command
+@cindex unix command @command{nc}
+@cindex @command{nc} unix command
@value{tramp}'s @option{nc} method uses the @command{nc} command to
install and execute a listener as follows (see @code{tramp-methods}):
@@ -2267,8 +2479,8 @@ to direct all auto saves to that location.
This section is incomplete. Please share your solutions.
-@cindex method sshx with cygwin
-@cindex sshx method with cygwin
+@cindex method @option{sshx} with cygwin
+@cindex @option{sshx} method with cygwin
Cygwin's @command{ssh} works only with a Cygwin version of Emacs. To
check for compatibility: type @kbd{M-x eshell @key{RET}}, and start
@@ -2290,8 +2502,8 @@ On @uref{https://www.emacswiki.org/emacs/SshWithNTEmacs, the Emacs
Wiki} it is explained how to use the helper program
@command{fakecygpty} to fix this problem.
-@cindex method scpx with cygwin
-@cindex scpx method with cygwin
+@cindex method @option{scpx} with cygwin
+@cindex @option{scpx} method with cygwin
When using the @option{scpx} access method, Emacs may call
@command{scp} with MS Windows file naming, such as @code{c:/foo}. But
@@ -2347,6 +2559,7 @@ is a feature of Emacs that may cause missed prompts when using
* Ad-hoc multi-hops:: Declaring multiple hops in the file name.
* Remote processes:: Integration with other Emacs packages.
* Cleanup remote connections:: Cleanup remote connections.
+* Archive file names:: Access to files in file archives.
@end menu
@@ -2453,11 +2666,12 @@ and @code{user@@} parts are optional.
@defvar tramp-file-name-regexp
This variable keeps a regexp which matches the selected remote file
-name syntax. However, it is not recommended to use this variable in
-external packages, a call of @code{file-remote-p} is much more
-appropriate.
+name syntax. Its value changes after every call of
+@code{tramp-change-syntax}. However, it is not recommended to use
+this variable in external packages, a call of @code{file-remote-p} is
+much more appropriate.
@ifinfo
-@pxref{Magic File Names, , , elisp}
+@pxref{Magic File Names, , , elisp}.
@end ifinfo
@end defvar
@end ifset
@@ -2531,6 +2745,14 @@ names on that host.
When the configuration (@pxref{Customizing Completion}) includes user
names, then the completion lists will account for the user names as well.
+@vindex tramp-completion-use-auth-sources
+Results from @code{auth-sources} search (@pxref{Using an
+authentication file}) are added to the completion candidates. This
+search could be annoying, for example due to a passphrase request of
+the @file{~/.authinfo.gpg} authentication file. The user option
+@code{tramp-completion-use-auth-sources} controls, whether such a
+search is performed during completion.
+
Remote hosts previously visited or hosts whose connections are kept
persistently (@pxref{Connection caching}) will be included in the
completion lists.
@@ -2553,7 +2775,7 @@ Example:
@print{} @trampfn{ssh,melancholia,/etc}
@kbd{C-x C-f @trampfn{ssh,melancholia,//etc} @key{TAB}}
- @print{} /etc
+ @print{} @trampfn{ssh,melancholia,/etc}
@kbd{C-x C-f @trampfn{ssh,melancholia,/usr/local/bin///etc} @key{TAB}}
@print{} /etc
@@ -2579,9 +2801,9 @@ directory contents.
@cindex multi-hop, ad-hoc
@cindex proxy hosts, ad-hoc
-@value{tramp} file name syntax can accommodate ad hoc specification of
+@value{tramp} file name syntax can accommodate ad-hoc specification of
multiple proxies without using @code{tramp-default-proxies-alist}
-configuration setup(@pxref{Multi-hops}).
+configuration setup (@pxref{Multi-hops}).
Each proxy is specified using the same syntax as the remote host
specification minus the file name part. Each hop is separated by a
@@ -2596,13 +2818,14 @@ proxy @samp{bird@@bastion} to a remote file on @samp{you@@remotehost}:
Each involved method must be an inline method (@pxref{Inline methods}).
-Proxies can take patterns @code{%h} or @code{%u}.
-
@value{tramp} adds the ad-hoc definitions on the fly to
-@code{tramp-default-proxies-alist} and is available for re-use
-during that Emacs session. Subsequent @value{tramp} connections to
-the same remote host can then use the shortcut form:
-@samp{@trampfn{ssh,you@@remotehost,/path}}.
+@code{tramp-default-proxies-alist} and is available for re-use during
+that Emacs session. Subsequent @value{tramp} connections to the same
+remote host can then use the shortcut form:
+@samp{@trampfn{ssh,you@@remotehost,/path}}. Ad-hoc definitions are
+removed from @code{tramp-default-proxies-alist} via the command
+@kbd{M-x tramp-cleanup-all-connections @key{RET}} (@pxref{Cleanup
+remote connections}).
@defopt tramp-save-ad-hoc-proxies
For ad-hoc definitions to be saved automatically in
@@ -2614,6 +2837,17 @@ For ad-hoc definitions to be saved automatically in
@end lisp
@end defopt
+Ad-hoc proxies can take patterns @code{%h} or @code{%u} like in
+@code{tramp-default-proxies-alist}. The following file name expands
+to user @code{root} on host @code{remotehost}, starting with an
+@option{ssh} session on host @code{remotehost}:
+@samp{@value{prefix}ssh@value{postfixhop}%h|su@value{postfixhop}remotehost@value{postfix}}.
+
+On the other hand, if a trailing hop does not specifiy a host name,
+the host name of the previous hop is reused. Therefore, the following
+file name is equivalent to the previous example:
+@samp{@value{prefix}ssh@value{postfixhop}remotehost|su@value{postfixhop}@value{postfix}}.
+
@node Remote processes
@section Integration with other Emacs packages
@@ -2776,7 +3010,7 @@ Starting with Emacs 26, you could use connection-local variables for
setting different values of @code{explicit-shell-file-name} for
different remote hosts.
@ifinfo
-@pxref{Connection Local Variables, , , elisp}
+@xref{Connection Variables, , , emacs}.
@end ifinfo
@lisp
@@ -2829,6 +3063,14 @@ host. Example:
@kbd{M-x auto-revert-tail-mode @key{RET}} runs similarly showing
continuous output.
+@code{shell-command} uses the variables @code{shell-file-name} and
+@code{shell-command-switch} in order to determine which shell to run.
+For remote hosts, their default values are @file{/bin/sh} and
+@option{-c}, respectively (except for the @option{adb} method, which
+uses @file{/system/bin/sh}). Like the variables in the previous
+section, these variables can be changed via connection-local
+variables.
+
@subsection Running @code{eshell} on a remote host
@cindex @code{eshell}
@@ -2877,7 +3119,7 @@ uid=0(root) gid=0(root) groups=0(root)
@anchor{Running a debugger on a remote host}
@subsection Running a debugger on a remote host
-@cindex @code{gud}
+@cindex @file{gud.el}
@cindex @code{gdb}
@cindex @code{perldb}
@@ -2972,7 +3214,8 @@ interactively, this command lists active remote connections in the
minibuffer. Each connection is of the format
@file{@trampfn{method,user@@host,}}. Flushing remote connections also
cleans the password cache (@pxref{Password handling}), file cache,
-connection cache (@pxref{Connection caching}), and connection buffers.
+connection cache (@pxref{Connection caching}), recentf cache
+(@pxref{File Conveniences, , , emacs}), and connection buffers.
@end deffn
@deffn Command tramp-cleanup-this-connection
@@ -2982,16 +3225,254 @@ as in @code{tramp-cleanup-connection}.
@deffn Command tramp-cleanup-all-connections
Flushes all active remote connection objects, the same as in
-@code{tramp-cleanup-connection}.
+@code{tramp-cleanup-connection}. This command removes also ad-hoc
+proxy definitions (@pxref{Ad-hoc multi-hops}).
+
@end deffn
@deffn Command tramp-cleanup-all-buffers
Just as for @code{tramp-cleanup-all-connections}, all remote
-connections are cleaned up in addition to killing buffers related to
-that remote connection.
+connections and ad-hoc proxy definition are cleaned up in addition to
+killing buffers related to that remote connection.
@end deffn
+@node Archive file names
+@section Archive file names
+@cindex file archives
+@cindex archive file names
+@cindex method archive
+@cindex archive method
+
+@value{tramp} offers also transparent access to files inside file
+archives. This is possible only on machines which have installed the
+virtual file system for the @acronym{GNOME} Desktop (GVFS), @ref{GVFS
+based methods}. Internally, file archives are mounted via the GVFS
+@option{archive} method.
+
+A file archive is a regular file of kind @file{/path/to/dir/file.EXT}.
+The extension @samp{.EXT} identifies the type of the file archive. A
+file inside a file archive, called archive file name, has the name
+@file{/path/to/dir/file.EXT/dir/file}.
+
+Most of the @ref{Magic File Names, , magic file name operations,
+elisp}, are implemented for archive file names, exceptions are all
+operations which write into a file archive, and process related
+operations. Therefore, functions like
+
+@lisp
+(copy-file "/path/to/dir/file.tar/dir/file" "/somewhere/else")
+@end lisp
+
+@noindent
+work out of the box. This is also true for file name completion, and
+for libraries like @code{dired} or @code{ediff}, which accept archive
+file names as well.
+
+@vindex tramp-archive-suffixes
+File archives are identified by the file name extension @samp{.EXT}.
+Since GVFS uses internally the library @code{libarchive(3)}, all
+suffixes, which are accepted by this library, work also for archive
+file names. Accepted suffixes are listed in the constant
+@code{tramp-archive-suffixes}. They are
+
+@itemize
+@item @samp{.7z} ---
+7-Zip archives
+@cindex @file{7z} file archive suffix
+@cindex file archive suffix @file{7z}
+
+@item @samp{.apk} ---
+Android package kits
+@cindex @file{apk} file archive suffix
+@cindex file archive suffix @file{apk}
+
+@item @samp{.ar} ---
+UNIX archiver formats
+@cindex @file{ar} file archive suffix
+@cindex file archive suffix @file{ar}
+
+@item @samp{.cab}, @samp{.CAB} ---
+Microsoft Windows cabinets
+@cindex @file{cab} file archive suffix
+@cindex @file{CAB} file archive suffix
+@cindex file archive suffix @file{cab}
+@cindex file archive suffix @file{CAB}
+
+@item @samp{.cpio} ---
+CPIO archives
+@cindex @file{cpio} file archive suffix
+@cindex file archive suffix @file{cpio}
+
+@item @samp{.deb} ---
+Debian packages
+@cindex @file{deb} file archive suffix
+@cindex file archive suffix @file{deb}
+
+@item @samp{.depot} ---
+HP-UX SD depots
+@cindex @file{depot} file archive suffix
+@cindex file archive suffix @file{depot}
+
+@item @samp{.exe} ---
+Self extracting Microsoft Windows EXE files
+@cindex @file{exe} file archive suffix
+@cindex file archive suffix @file{exe}
+
+@item @samp{.iso} ---
+ISO 9660 images
+@cindex @file{iso} file archive suffix
+@cindex file archive suffix @file{iso}
+
+@item @samp{.jar} ---
+Java archives
+@cindex @file{jar} file archive suffix
+@cindex file archive suffix @file{jar}
+
+@item @samp{.lzh}, @samp{.LZH} ---
+Microsoft Windows compressed LHA archives
+@cindex @file{lzh} file archive suffix
+@cindex @file{LZH} file archive suffix
+@cindex file archive suffix @file{lzh}
+@cindex file archive suffix @file{LZH}
+
+@item @samp{.msu}, @samp{.MSU} ---
+Microsoft Windows Update packages
+@cindex @file{msu} file archive suffix
+@cindex @file{MSU} file archive suffix
+@cindex file archive suffix @file{msu}
+@cindex file archive suffix @file{MSU}
+
+@item @samp{.mtree} ---
+BSD mtree format
+@cindex @file{mtree} file archive suffix
+@cindex file archive suffix @file{mtree}
+
+@item @samp{.odb}, @samp{.odf}, @samp{.odg}, @samp{.odp}, @samp{.ods},
+@samp{.odt} ---
+OpenDocument formats
+@cindex @file{odb} file archive suffix
+@cindex @file{odf} file archive suffix
+@cindex @file{odg} file archive suffix
+@cindex @file{odp} file archive suffix
+@cindex @file{ods} file archive suffix
+@cindex @file{odt} file archive suffix
+@cindex file archive suffix @file{odb}
+@cindex file archive suffix @file{odf}
+@cindex file archive suffix @file{odg}
+@cindex file archive suffix @file{odp}
+@cindex file archive suffix @file{ods}
+@cindex file archive suffix @file{odt}
+
+@item @samp{.pax} ---
+Posix archives
+@cindex @file{pax} file archive suffix
+@cindex file archive suffix @file{pax}
+
+@item @samp{.rar} ---
+RAR archives
+@cindex @file{rar} file archive suffix
+@cindex file archive suffix @file{rar}
+
+@item @samp{.rpm} ---
+Red Hat packages
+@cindex @file{rpm} file archive suffix
+@cindex file archive suffix @file{rpm}
+
+@item @samp{.shar} ---
+Shell archives
+@cindex @file{shar} file archive suffix
+@cindex file archive suffix @file{shar}
+
+@item @samp{.tar}, @samp{.tbz}, @samp{.tgz}, @samp{.tlz}, @samp{.txz} ---
+(Compressed) tape archives
+@cindex @file{tar} file archive suffix
+@cindex @file{tbz} file archive suffix
+@cindex @file{tgz} file archive suffix
+@cindex @file{tlz} file archive suffix
+@cindex @file{txz} file archive suffix
+@cindex file archive suffix @file{tar}
+@cindex file archive suffix @file{tbz}
+@cindex file archive suffix @file{tgz}
+@cindex file archive suffix @file{tlz}
+@cindex file archive suffix @file{txz}
+
+@item @samp{.warc} ---
+Web archives
+@cindex @file{warc} file archive suffix
+@cindex file archive suffix @file{warc}
+
+@item @samp{.xar} ---
+macOS XAR archives
+@cindex @file{xar} file archive suffix
+@cindex file archive suffix @file{xar}
+
+@item @samp{.xpi} ---
+XPInstall Mozilla addons
+@cindex @file{xpi} file archive suffix
+@cindex file archive suffix @file{xpi}
+
+@item @samp{.xps} ---
+Open XML Paper Specification (OpenXPS) documents
+@cindex @file{xps} file archive suffix
+@cindex file archive suffix @file{xps}
+
+@item @samp{.zip}, @samp{.ZIP} ---
+ZIP archives
+@cindex @file{zip} file archive suffix
+@cindex @file{ZIP} file archive suffix
+@cindex file archive suffix @file{zip}
+@cindex file archive suffix @file{ZIP}
+@end itemize
+
+@vindex tramp-archive-compression-suffixes
+File archives could also be compressed, identified by an additional
+compression suffix. Valid compression suffixes are listed in the
+constant @code{tramp-archive-compression-suffixes}. They are
+@samp{.bz2}, @samp{.gz}, @samp{.lrz}, @samp{.lz}, @samp{.lz4},
+@samp{.lzma}, @samp{.lzo}, @samp{.uu}, @samp{.xz} and @samp{.Z}. A
+valid archive file name would be
+@file{/path/to/dir/file.tar.gz/dir/file}. Even several suffixes in a
+row are possible, like @file{/path/to/dir/file.tar.gz.uu/dir/file}.
+
+@vindex tramp-archive-all-gvfs-methods
+An archive file name could be a remote file name, as in
+@file{/ftp:anonymous@@ftp.gnu.org:/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL}.
+Since all file operations are mapped internally to GVFS operations,
+remote file names supported by @code{tramp-gvfs} perform better,
+because no local copy of the file archive must be downloaded first.
+For example, @samp{/sftp:user@@host:...} performs better than the
+similar @samp{/scp:user@@host:...}. See the constant
+@code{tramp-archive-all-gvfs-methods} for a complete list of
+@code{tramp-gvfs} supported method names.
+
+If @code{url-handler-mode} is enabled, archives could be visited via
+URLs, like
+@file{https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL}. This
+allows complex file operations like
+
+@lisp
+@group
+(progn
+ (url-handler-mode 1)
+ (ediff-directories
+ "https://ftp.gnu.org/gnu/tramp/tramp-2.3.1.tar.gz/tramp-2.3.1"
+ "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/tramp-2.3.2" ""))
+@end group
+@end lisp
+
+It is even possible to access file archives in file archives, as
+
+@lisp
+@group
+(progn
+ (url-handler-mode 1)
+ (find-file
+ "http://ftp.debian.org/debian/pool/main/c/coreutils/coreutils_8.28-1_amd64.deb/control.tar.gz/control"))
+@end group
+@end lisp
+
+
@node Bug Reports
@chapter Reporting Bugs and Problems
@cindex bug reports
@@ -3007,9 +3488,9 @@ discussing, and general discussions about @value{tramp}.
post for moderator approval. Sometimes this approval step may take as
long as 48 hours due to public holidays.
-@email{tramp-devel@@gnu.org} is the mailing list. Messages sent to
-this address go to all the subscribers. This is @emph{not} the
-address to send subscription requests to.
+@email{@value{tramp-bug-report-address}} is the mailing list.
+Messages sent to this address go to all the subscribers. This is
+@emph{not} the address to send subscription requests to.
To subscribe to the mailing list, visit:
@uref{https://lists.gnu.org/mailman/listinfo/tramp-devel/, the
@@ -3043,7 +3524,9 @@ When including @value{tramp}'s messages in the bug report, increase
the verbosity level to 6 (@pxref{Traces and Profiles, Traces}) in the
@file{~/.emacs} file before repeating steps to the bug. Include the
contents of the @file{*tramp/foo*} and @file{*debug tramp/foo*}
-buffers with the bug report.
+buffers with the bug report. Both buffers could contain
+non-@acronym{ASCII} characters which are relevant for analysis, append
+the buffers as attachments to the bug report.
@strong{Note} that a verbosity level greater than 6 is not necessary
at this stage. Also note that a verbosity level of 6 or greater, the
@@ -3076,7 +3559,8 @@ Where is the latest @value{tramp}?
@item
Which systems does it work on?
-The package works successfully on Emacs 24, Emacs 25, and Emacs 26.
+The package works successfully on Emacs 24, Emacs 25, Emacs 26, and
+Emacs 27.
While Unix and Unix-like systems are the primary remote targets,
@value{tramp} has equal success connecting to other platforms, such as
@@ -3099,6 +3583,7 @@ Keep the file @code{tramp-persistency-file-name}, which is where
@value{tramp} caches remote information about hosts and files. Caching
is enabled by default. Don't disable it.
+@vindex remote-file-name-inhibit-cache
Set @code{remote-file-name-inhibit-cache} to @code{nil} if remote
files are not independently updated outside @value{tramp}'s control.
That cache cleanup will be necessary if the remote directories or
@@ -3235,7 +3720,7 @@ Set @code{file-precious-flag} to @code{t} for files accessed by
@value{tramp} so the file contents are checked using checksum by
first saving to a temporary file.
@ifinfo
-@pxref{Saving Buffers, , , elisp}
+@pxref{Saving Buffers, , , elisp}.
@end ifinfo
@lisp
@@ -3251,6 +3736,16 @@ first saving to a temporary file.
@item
+@value{tramp} fails in a chrooted environment
+
+@vindex tramp-local-host-regexp
+When connecting to a local host, @value{tramp} uses some internal
+optimizations. They fail, when there is a chrooted environment. In
+order to disable those optimizations, set user option
+@code{tramp-local-host-regexp} to @code{nil}.
+
+
+@item
@value{tramp} does not recognize if a @command{ssh} session hangs
@command{ssh} sessions on the local host hang when the network is
@@ -3765,6 +4260,15 @@ export EDITOR=/path/to/emacsclient.sh
@item
+How to determine whether a buffer is remote?
+
+The buffer-local variable @code{default-directory} tells this. If the
+form @code{(file-remote-p default-directory)} returns non-@code{nil},
+the buffer is remote. See the optional arguments of
+@code{file-remote-p} for determining details of the remote connection.
+
+
+@item
How to disable other packages from calling @value{tramp}?
There are packages that call @value{tramp} without the user ever
@@ -3806,6 +4310,7 @@ in @file{.emacs}:
@end lisp
@item
+@vindex tramp-mode
To disable both @value{tramp} (and Ange FTP), set @code{tramp-mode} to
@code{nil} in @file{.emacs}. @strong{Note}, that we don't use
@code{customize-set-variable}, in order to avoid loading @value{tramp}.
@@ -3815,6 +4320,21 @@ To disable both @value{tramp} (and Ange FTP), set @code{tramp-mode} to
@end lisp
@item
+@vindex tramp-ignored-file-name-regexp
+To deactivate @value{tramp} for some look-alike remote file names, set
+@code{tramp-ignored-file-name-regexp} to a proper regexp in
+@file{.emacs}. @strong{Note}, that we don't use
+@code{customize-set-variable}, in order to avoid loading
+@value{tramp}.
+
+@lisp
+(setq tramp-ignored-file-name-regexp "\\`/ssh:example\\.com:")
+@end lisp
+
+This is needed, if you mount for example a virtual file system on your
+local host's root directory as @file{/ssh:example.com:}.
+
+@item
To unload @value{tramp}, type @kbd{M-x tramp-unload-tramp @key{RET}}.
Unloading @value{tramp} resets Ange FTP plugins also.
@end itemize
@@ -3823,7 +4343,7 @@ Unloading @value{tramp} resets Ange FTP plugins also.
@c For the developer
@node Files directories and localnames
-@chapter How file names, directories and localnames are mangled and managed.
+@chapter How file names, directories and localnames are mangled and managed
@menu
* Localname deconstruction:: Splitting a localname into its component parts.
@@ -3849,6 +4369,7 @@ handlers.
@section Integrating with external Lisp packages
@subsection File name completion.
+@vindex non-essential
Sometimes, it is not convenient to open a new connection to a remote
host, including entering the password and alike. For example, this is
nasty for packages providing file name completion. Such a package
diff --git a/doc/misc/trampver.texi b/doc/misc/trampver.texi
index aecbbe261c8..5b1408a4974 100644
--- a/doc/misc/trampver.texi
+++ b/doc/misc/trampver.texi
@@ -5,12 +5,12 @@
@c Copyright (C) 2003-2019 Free Software Foundation, Inc.
@c See file doclicense.texi for copying conditions.
-@c In the Tramp GIT, the version number is auto-frobbed from
-@c configure.ac, so you should edit that file and run
-@c "autoconf && ./configure" to change the version number.
-@set trampver 2.3.4.26.2
+@c In the Tramp GIT, the version number is auto-frobbed from tramp.el,
+@c and the bug report address is auto-frobbed from configure.ac.
+@set trampver 2.4.2-pre
+@set tramp-bug-report-address tramp-devel@@gnu.org
-@c Other flags from configuration
+@c Other flags from configuration.
@set instprefix /usr/local
@set lispdir /usr/local/share/emacs/site-lisp
@set infodir /usr/local/share/info
@@ -44,3 +44,17 @@
@set ipv6prefix
@set ipv6postfix
@end ifset
+
+@c Macro for formatting a file name according to the respective
+@c syntax. trampver.texi is included several times in tramp.texi and
+@c trampinst.texi. Redefining the macro is reported as warning for
+@c creating the dvi and pdf files, so we declare the macro only the
+@c first time this file is included.
+@ifclear trampfndefined
+@set trampfndefined
+@macro trampfn {method, userhost, localname}
+@value{prefix}@c
+\method\@value{postfixhop}@c
+\userhost\@value{postfix}\localname\
+@end macro
+@end ifclear
diff --git a/doc/misc/url.texi b/doc/misc/url.texi
index b190c58c023..0cdfcac24e8 100644
--- a/doc/misc/url.texi
+++ b/doc/misc/url.texi
@@ -571,13 +571,6 @@ if it has the file suffix @file{.z}, @file{.gz}, @file{.Z},
hard-coded, and cannot be altered by customizing
@code{jka-compr-compression-info-list}.)
-@defopt url-directory-index-file
-This option specifies the filename to look for when a @code{file} or
-@code{ftp} URL specifies a directory. The default is
-@file{index.html}. If this file exists and is readable, it is viewed.
-Otherwise, Emacs visits the directory using Dired.
-@end defopt
-
@node info
@section info
@cindex Info
@@ -1291,6 +1284,20 @@ It may also be a list of the types of messages to be logged.
@end defopt
@defopt url-privacy-level
@end defopt
+@defopt url-lastloc-privacy-level
+Provided @code{lastloc} is not prohibited by @code{url-privacy-level},
+this determines who we send our last location to. @code{none} means
+we include our last location in every outgoing request.
+@code{domain-match} means we send it only if the domain of our last
+location matches the domain of the URI we are requesting.
+@code{host-match} means we only send our last location back to the
+same host. The default is @code{domain-match}.
+
+Using @code{domain-match} for this option requires emacs to make one
+or more DNS requests each time a new host is contacted, to determine
+the domain of the host. Results of these lookups are cached, so
+repeated visits do not require repeated domain lookups.
+@end defopt
@defopt url-uncompressor-alist
@end defopt
@defopt url-passwd-entry-func
diff --git a/etc/CALC-NEWS b/etc/CALC-NEWS
index 07167c95661..d00f136f917 100644
--- a/etc/CALC-NEWS
+++ b/etc/CALC-NEWS
@@ -10,18 +10,9 @@ Originally written by:
San Jose CA 95134
daveg@synaptics.com, uunet!synaptx!daveg
-Currently maintained by:
+Calc was maintained for many years by:
Jay Belanger <jay.p.belanger@gmail.com>
-I am anxious to hear about your experiences using Calc. Send mail to
-"jay.p.belanger@gmail.com". A bug report is most useful if you include the
-exact input and output that occurred, any modes in effect (such as the
-current precision), and so on. If you find Calc is difficult to operate
-in any way, or if you have other suggestions, don't hesitate to let me
-know. If you find errors (including simple typos) in the manual, let me
-know. Even if you find no bugs at all I would love to hear your opinions.
-
-
Summary of changes to "Calc"
------- -- ------- -- ----
diff --git a/etc/CENSORSHIP b/etc/CENSORSHIP
deleted file mode 100644
index cd779e4915c..00000000000
--- a/etc/CENSORSHIP
+++ /dev/null
@@ -1,8 +0,0 @@
-Censoring my Software
-
-Note added March 2014:
-
-This file is obsolete and will be removed in future.
-Please update any references to use
-
-<https://www.gnu.org/philosophy/censoring-emacs.html>
diff --git a/etc/DEBUG b/etc/DEBUG
index 377cfcfc8f7..d401d0be901 100644
--- a/etc/DEBUG
+++ b/etc/DEBUG
@@ -160,9 +160,10 @@ If you attached the debugger to a running Emacs, type "continue" into
the *gud-emacs* buffer and press RET.
Many variables you will encounter while debugging are Lisp objects.
-These are displayed as integer values (or structures, if you used the
-"--enable-check-lisp-object-type" option at configure time) that are
-hard to interpret, especially if they represent long lists. You can
+These are normally displayed as opaque pointers or integers that are
+hard to interpret, especially if they represent long lists.
+(They are instead displayed as structures containing these opaque
+values, if --enable-check-lisp-object-type is in effect.) You can
use the 'pp' command to display them in their Lisp form. That command
displays its output on the standard error stream, which you
can redirect to a file using "M-x redirect-debugging-output".
@@ -841,7 +842,7 @@ the machine where you started GDB and use the debugger from there.
** Debugging problems which happen in GC
The array 'last_marked' (defined on alloc.c) can be used to display up
-to 500 last objects marked by the garbage collection process.
+to the 512 most-recent objects marked by the garbage collection process.
Whenever the garbage collector marks a Lisp object, it records the
pointer to that object in the 'last_marked' array, which is maintained
as a circular buffer. The variable 'last_marked_index' holds the
@@ -935,7 +936,7 @@ its own versions, and because the dumping process might be
incompatible with the way these packages use to track allocated
memory. Here are some of the changes you might find necessary:
- - Edit configure, to set system_malloc and CANNOT_DUMP to "yes".
+ - Make sure unexec is disabled, e.g., './configure --without-unexec'.
- Configure with a different --prefix= option. If you use GCC,
version 2.7.2 is preferred, as some malloc debugging packages
diff --git a/etc/FTP b/etc/FTP
deleted file mode 100644
index ebd2695da17..00000000000
--- a/etc/FTP
+++ /dev/null
@@ -1,9 +0,0 @@
-For information about how to download GNU Emacs, please see:
-<https://www.gnu.org/software/emacs/>
-
-For general GNU software downloading, please see
-<https://www.gnu.org/order/ftp.html>
-
-Note added January 2014:
-This file is obsolete and will be removed in future.
-Please update any links to use the above URLs.
diff --git a/etc/GNU b/etc/GNU
deleted file mode 100644
index f8078d41cd3..00000000000
--- a/etc/GNU
+++ /dev/null
@@ -1,8 +0,0 @@
-The GNU Manifesto
-
-Note added March 2014:
-
-This file is obsolete and will be removed in future.
-Please update any references to use
- info node `(emacs)Manifesto'
-instead.
diff --git a/etc/GNUS-NEWS b/etc/GNUS-NEWS
deleted file mode 100644
index a8b03857bd2..00000000000
--- a/etc/GNUS-NEWS
+++ /dev/null
@@ -1,316 +0,0 @@
-GNUS NEWS -- history of user-visible changes.
-
-Copyright (C) 1999-2019 Free Software Foundation, Inc.
-See the end of the file for license conditions.
-
-Please send Gnus bug reports to bugs@gnus.org.
-For older news, see Gnus info node "New Features".
-
-
-* Supported Emacs versions The following Emacs versions are supported by No
-Gnus:
-
-** Emacs 22 and up
-** XEmacs 21.4
-** XEmacs 21.5
-** SXEmacs
-
-
-* Installation changes
-
-** Upgrading from previous (stable) version if you have used No Gnus.
-
-If you have tried No Gnus (the unstable Gnus branch leading to this
-release) but went back to a stable version, be careful when upgrading to
-this version. In particular, you will probably want to remove the
-'~/News/marks' directory (perhaps selectively), so that flags are read
-from your '~/.newsrc.eld' instead of from the stale marks file, where
-this release will store flags for nntp. See a later entry for more
-information about nntp marks. Note that downgrading isn't safe in
-general.
-
-** Incompatibility when switching from Emacs 23 to Emacs 22 In Emacs 23,
-Gnus uses Emacs's new internal coding system 'utf-8-emacs' for saving
-articles drafts and '~/.newsrc.eld'. These files may not be read
-correctly in Emacs 22 and below. If you want to use Gnus across
-different Emacs versions, you may set 'mm-auto-save-coding-system' to
-'emacs-mule'.
-
-** Lisp files are now installed in '.../site-lisp/gnus/' by default. It
-defaulted to '.../site-lisp/' formerly. In addition to this, the new
-installer issues a warning if other Gnus installations which will shadow
-the latest one are detected. You can then remove those shadows manually
-or remove them using 'make remove-installed-shadows'.
-
-** The installation directory name is allowed to have spaces and/or tabs.
-
-
-* New packages and libraries within Gnus
-
-** New version of 'nnimap'
-
-'nnimap' has been reimplemented in a mostly-compatible way. See the Gnus
-manual for a description of the new interface. In particular,
-'nnimap-inbox' and the client side split method has changed.
-
-** Gnus includes the Emacs Lisp SASL library.
-
-This provides a clean API to SASL mechanisms from within Emacs. The user
-visible aspects of this, compared to the earlier situation, include
-support for DIGEST-MD5 and NTLM. *Note Emacs SASL: (sasl)Top.
-
-** ManageSieve connections uses the SASL library by default.
-
-The primary change this brings is support for DIGEST-MD5 and NTLM, when
-the server supports it.
-
-** Gnus includes a password cache mechanism in password.el.
-
-It is enabled by default (see 'password-cache'), with a short timeout of
-16 seconds (see 'password-cache-expiry'). If PGG is used as the PGP back
-end, the PGP passphrase is managed by this mechanism. Passwords for
-ManageSieve connections are managed by this mechanism, after querying the
-user about whether to do so.
-
-** Using EasyPG with Gnus When EasyPG, is available, Gnus will use it
-instead of PGG. EasyPG is an Emacs user interface to GNU Privacy Guard.
- *Note EasyPG Assistant user's manual: (epa)Top. EasyPG is included in
-Emacs 23 and available separately as well.
-
-
-* Changes in group mode
-
-** Symbols like 'gcc-self' now have the same precedence rules in
-'gnus-parameters' as other "real" variables: The last match wins instead
-of the first match.
-
-** Old intermediate incoming mail files ('Incoming*') are deleted after a
-couple of days, not immediately. *Note Mail Source Customization::.
-(New in Gnus 5.10.10 / No Gnus 0.8)
-
-
-* Changes in summary and article mode
-
-** There's now only one variable that determines how HTML is rendered:
-'mm-text-html-renderer'.
-
-** Gnus now supports sticky article buffers. Those are article buffers that
-are not reused when you select another article. *Note Sticky Articles::.
-
-** Gnus can selectively display 'text/html' articles with a WWW browser with
-'K H'. *Note MIME Commands::.
-
-** International host names (IDNA) can now be decoded inside article bodies
-using 'W i' ('gnus-summary-idna-message'). This requires that GNU Libidn
-(<https://www.gnu.org/software/libidn/>) has been installed.
-
-** The non-ASCII group names handling has been much improved. The back ends
-that fully support non-ASCII group names are now 'nntp', 'nnml', and
-'nnrss'. Also the agent, the cache, and the marks features work with
-those back ends. *Note Non-ASCII Group Names::.
-
-** Gnus now displays DNS master files sent as text/dns using dns-mode.
-
-** Gnus supports new limiting commands in the Summary buffer: '/ r'
-('gnus-summary-limit-to-replied') and '/ R'
-('gnus-summary-limit-to-recipient'). *Note Limiting::.
-
-** You can now fetch all ticked articles from the server using 'Y t'
-('gnus-summary-insert-ticked-articles'). *Note Summary Generation
-Commands::.
-
-** Gnus supports a new sort command in the Summary buffer: 'C-c C-s C-t'
-('gnus-summary-sort-by-recipient'). *Note Summary Sorting::.
-
-** S/MIME now features LDAP user certificate searches. You need to
-configure the server in 'smime-ldap-host-list'.
-
-** URLs inside OpenPGP headers are retrieved and imported to your PGP key
-ring when you click on them.
-
-** Picons can be displayed right from the textual address, see
-'gnus-picon-style'. *Note Picons::.
-
-** ANSI SGR control sequences can be transformed using 'W A'.
-
-ANSI sequences are used in some Chinese hierarchies for highlighting
-articles ('gnus-article-treat-ansi-sequences').
-
-** Gnus now MIME decodes articles even when they lack "MIME-Version" header.
-This changes the default of 'gnus-article-loose-mime'.
-
-** 'gnus-decay-scores' can be a regexp matching score files. For example,
-set it to '\\.ADAPT\\'' and only adaptive score files will be decayed.
- *Note Score Decays::.
-
-** Strings prefixing to the 'To' and 'Newsgroup' headers in summary lines
-when using 'gnus-ignored-from-addresses' can be customized with
-'gnus-summary-to-prefix' and 'gnus-summary-newsgroup-prefix'. *Note To
-From Newsgroups::.
-
-** You can replace MIME parts with external bodies. See
-'gnus-mime-replace-part' and 'gnus-article-replace-part'. *Note MIME
-Commands::, *note Using MIME::.
-
-** The option 'mm-fill-flowed' can be used to disable treatment of
-format=flowed messages. Also, flowed text is disabled when sending
-inline PGP signed messages. *Note Flowed text: (emacs-mime)Flowed text.
-(New in Gnus 5.10.7)
-
-** Now the new command 'S W' ('gnus-article-wide-reply-with-original') for a
-wide reply in the article buffer yanks a text that is in the active
-region, if it is set, as well as the 'R'
-('gnus-article-reply-with-original') command. Note that the 'R' command
-in the article buffer no longer accepts a prefix argument, which was used
-to make it do a wide reply. *Note Article Keymap::.
-
-** The new command 'C-h b' ('gnus-article-describe-bindings') used in the
-article buffer now shows not only the article commands but also the real
-summary commands that are accessible from the article buffer.
-
-
-* Changes in Message mode
-
-** Gnus now defaults to saving all outgoing messages in per-month nnfolder
-archives.
-
-** Gnus now supports the "hashcash" client puzzle anti-spam mechanism. Use
-'(setq message-generate-hashcash t)' to enable. *Note Hashcash::.
-
-** You can now drag and drop attachments to the Message buffer. See
-'mml-dnd-protocol-alist' and 'mml-dnd-attach-options'. *Note MIME:
-(message)MIME.
-
-** The option 'message-yank-empty-prefix' now controls how empty lines are
-prefixed in cited text. *Note Insertion Variables: (message)Insertion
-Variables.
-
-** Gnus uses narrowing to hide headers in Message buffers. The 'References'
-header is hidden by default. To make all headers visible, use '(setq
-message-hidden-headers nil)'. *Note Message Headers: (message)Message
-Headers.
-
-** You can highlight different levels of citations like in the article
-buffer. See 'gnus-message-highlight-citation'.
-
-** 'auto-fill-mode' is enabled by default in Message mode. See
-'message-fill-column'. *Note Message Headers: (message)Various Message
-Variables.
-
-** You can now store signature files in a special directory named
-'message-signature-directory'.
-
-** The option 'message-citation-line-format' controls the format of the
-"Whomever writes:" line. You need to set
-'message-citation-line-function' to
-'message-insert-formatted-citation-line' as well.
-
-
-* Changes in Browse Server mode
-
-** Gnus' sophisticated subscription methods are now available in Browse
-Server buffers as well using the variable
-'gnus-browse-subscribe-newsgroup-method'.
-
-
-* Changes in back ends
-
-** The nntp back end stores article marks in '~/News/marks'.
-
-The directory can be changed using the (customizable) variable
-'nntp-marks-directory', and marks can be disabled using the (back end)
-variable 'nntp-marks-is-evil'. The advantage of this is that you can
-copy '~/News/marks' (using rsync, scp or whatever) to another Gnus
-installation, and it will realize what articles you have read and marked.
-The data in '~/News/marks' has priority over the same data in
-'~/.newsrc.eld'.
-
-** You can import and export your RSS subscriptions from OPML files. *Note
-RSS::.
-
-** IMAP identity (RFC 2971) is supported.
-
-By default, Gnus does not send any information about itself, but you can
-customize it using the variable 'nnimap-id'.
-
-** The 'nnrss' back end now supports multilingual text. Non-ASCII group
-names for the 'nnrss' groups are also supported. *Note RSS::.
-
-** Retrieving mail with POP3 is supported over SSL/TLS and with StartTLS.
-
-** The nnml back end allows other compression programs beside 'gzip' for
-compressed message files. *Note Mail Spool::.
-
-** The nnml back end supports group compaction.
-
-This feature, accessible via the functions 'gnus-group-compact-group' ('G
-z' in the group buffer) and 'gnus-server-compact-server' ('z' in the
-server buffer) renumbers all articles in a group, starting from 1 and
-removing gaps. As a consequence, you get a correct total article count
-(until messages are deleted again).
-
-
-* Appearance
-
-** The tool bar has been updated to use GNOME icons. You can also customize
-the tool bars: 'M-x customize-apropos RET -tool-bar$' should get you
-started. (Only for Emacs, not in XEmacs.)
-
-** The tool bar icons are now (de)activated correctly in the group buffer,
-see the variable 'gnus-group-update-tool-bar'. Its default value depends
-on your Emacs version.
-
-** You can change the location of XEmacs's toolbars in Gnus buffers. See
-'gnus-use-toolbar' and 'message-use-toolbar'.
-
-
-* Miscellaneous changes
-
-** New user option 'gnus-rcvstore-options' provides a way to
-specify additional options when saving messages to an MH folder.
-
-** Having edited the select-method for the foreign server in the server
-buffer is immediately reflected to the subscription of the groups which
-use the server in question. For instance, if you change
-'nntp-via-address' into 'bar.example.com' from 'foo.example.com', Gnus
-will connect to the news host by way of the intermediate host
-'bar.example.com' from next time.
-
-** The 'all.SCORE' file can be edited from the group buffer using 'W e'.
-
-** You can set 'gnus-mark-copied-or-moved-articles-as-expirable' to a
-non-'nil' value so that articles that have been read may be marked as
-expirable automatically when copying or moving them to a group that has
-auto-expire turned on. The default is 'nil' and copying and moving of
-articles behave as before; i.e., the expirable marks will be unchanged
-except that the marks will be removed when copying or moving articles to
-a group that has not turned auto-expire on. *Note Expiring Mail::.
-
-** NoCeM support has been removed.
-
-** Carpal mode has been removed.
-
-* For older news, see Gnus info node "New Features".
-
-----------------------------------------------------------------------
-
-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 <https://www.gnu.org/licenses/>.
-
-
-Local variables:
-mode: outline
-paragraph-separate: "[ ]*$"
-end:
diff --git a/etc/HELLO b/etc/HELLO
index ae52e94b065..a56a73bc1d2 100644
--- a/etc/HELLO
+++ b/etc/HELLO
@@ -1,99 +1,127 @@
+Content-Type: text/enriched
+Text-Width: 70
+
This is a list of ways to say hello in various languages.
It is not intended to be comprehensive, but to demonstrate
some of the character sets that Emacs supports.
+
Non-ASCII examples:
- Europe: ,A!(BHola!, Gr,A|_(B Gott, Hyv,Add(B p,Ad(Biv,Add(B, Tere ,Au(Bhtust, Bon,Cu(Bu
- Cze,B6f(B!, Dobr,B}(B den, ,L7T`PRabRcYbU(B!, ,FCei\(B ,Fsar(B, $,1J2J0J;J0J@JOJ=J1J0(B
- Africa: $(3!A!,!>(B
- Middle/Near East: ,Hylem(B, $,1-g.$-s.1.$-g.%(B $,1-y.$.*.#.%(B
- South Asia: $,19h9n9x:-9d:'(B, $,15h5n5x6-5d6'(B, $,1?(?.?8?M>u?>?0(B, $,1@H@N@X@m@5@^@P@"(B, $,1;6;A;#;?;,;G(B,
- $,1AFAzB4AvB=B AqB*(B, $,1<U<C<5<m<5<N<m(B, $,1=h=n=x>-=U=~=p=B(B, $(7"7"!#C!;"E"S"G!;"7"2"[!;"D"["#"G!>(B
- South East Asia: $,1\'\f\:\V\4\?\]\:(B, (1JP:R-4U(B, $,1H9H$HZHYH"H<HLH5HK(B, ,TJGQJ4U$CQ:(B, Ch,1`(Bo b,1U(Bn
- East Asia: $ADc:C(B, $(0*/=((B, $B$3$s$K$A$O(B, $(C>H3gGO<<?d(B
- Misc: E,C6(Bo,C~(Ban,Cx(Bo ,Cf(Biu,C<(Ba,C}(Bde, $,2(3(1('('(5(B, $,1x (B p $,1x((B world $,1s"(B hello p $,2!a(B
- CJK variety: GB($AT*Fx(B,$A?*7"(B), BIG5($(0&x86(B,$(0DeBv(B), JIS($B855$(B,$B3+H/(B), KSC($(Cj*Q((B,$(CKR[!(B)
- Unicode charset: E$,1 E(Bo$,1 }(Ban$,1 =(Bo $,1 )(Biu$,1 U(Ba$,1!-(Bde, $,1&s'5'9',(B $,1'C'1'B(B, $,1-),|,u,}(B, $,1(7(T(`(P(R(a(b(R(c(Y(b(U(B!
+ Europe: <x-charset><param>latin-iso8859-1</param>¡Hola!, Grüß Gott, Hyvää päivää,</x-charset><x-charset><param>latin-iso8859-15</param> Tere õhtust,</x-charset><x-charset><param>latin-iso8859-3</param> Bonġu
+ Cześć!,</x-charset><x-charset><param>latin-iso8859-2</param> Dobrý den,</x-charset><x-charset><param>cyrillic-iso8859-5</param> Здравствуйте!,</x-charset><x-charset><param>greek-iso8859-7</param> Γειά σας,</x-charset><x-charset><param>mule-unicode-0100-24ff</param> გამარჯობა</x-charset>
+ Africa:<x-charset><param>mule-unicode-0100-24ff</param> </x-charset><x-charset><param>ethiopic</param>ሠላም</x-charset>
+ Middle/Near East:<x-charset><param>hebrew-iso8859-8</param> שלום,</x-charset><x-charset><param>mule-unicode-0100-24ff</param> السّلام عليكم</x-charset>
+ South Asia:<x-charset><param>mule-unicode-0100-24ff</param> નમસ્તે, नमस्ते, ನಮಸ್ಕಾರ, നമസ്കാരം, ଶୁଣିବେ,
+ ආයුබෝවන්, வணக்கம், నమస్కారం,</x-charset><x-charset><param>tibetan</param> བཀྲ་ཤིས་བདེ་ལེགས༎</x-charset>
+ South East Asia:<x-charset><param>mule-unicode-0100-24ff</param> ជំរាបសួរ,</x-charset><x-charset><param>lao</param> ສະບາຍດີ,</x-charset><x-charset><param>mule-unicode-0100-24ff</param> မင်္ဂလာပါ,</x-charset><x-charset><param>thai-tis620</param> สวัสดีครับ,</x-charset><x-charset><param>vietnamese-viscii-lower</param> </x-charset><x-charset><param>vietnamese-viscii-upper</param>C</x-charset><x-charset><param>vietnamese-viscii-lower</param>hào bạn</x-charset>
+ East Asia:<x-charset><param>chinese-gb2312</param> 你好,</x-charset><x-charset><param>chinese-big5-1</param> 早晨,</x-charset><x-charset><param>japanese-jisx0208</param> こんにちは,</x-charset><x-charset><param>korean-ksc5601</param> 안녕하세요</x-charset>
+ Misc:<x-charset><param>latin-iso8859-3</param> Eĥoŝanĝo ĉiuĵaŭde,</x-charset><x-charset><param>mule-unicode-2500-33ff</param> ⠓⠑⠇⠇⠕,</x-charset><x-charset><param>mule-unicode-0100-24ff</param> ∀ p ∈ world • hello p </x-charset><x-charset><param>mule-unicode-2500-33ff</param>□</x-charset>
+ CJK variety:<x-charset><param>chinese-gb2312</param> GB(元气,开发),</x-charset><x-charset><param>chinese-big5-1</param> BIG5(元氣,開發),</x-charset><x-charset><param>japanese-jisx0208</param> JIS(元気,開発),</x-charset><x-charset><param>korean-ksc5601</param> KSC(元氣,開發)</x-charset>
+ Unicode charset:<x-charset><param>unicode</param> Eĥoŝanĝo ĉiuĵaŭde, Γειά σας, שלום, Здравствуйте!</x-charset>
+
LANGUAGE (NATIVE NAME) HELLO
---------------------- -----
-Amharic ($,1O M[MmN{(B) $,1M`MKM](B
-Arabic ($,1-g.$-y-q-h.*.1-i(B) $,1-g.$-s.1.$-g.%(B $,1-y.$.*.#.%(B
-Armenian ($,1+p+a+u+e, +e+v(B) $,1+2+a, ,'(B $,1+q+e+f(B
-Bengali ($,17,7>6b727>(B) $,17(7.787M6u7>70(B
-Braille $,2(3(1('('(5(B
-Burmese ($,1H9H\H4HZH9HL(B) $,1H9H$HZHYH"H<HLH5HK(B
-C printf ("Hello, world!\n");
-Czech (,Bh(Be,B9(Btina) Dobr,A}(B den
-Danish (dansk) Hej / Goddag / Hall,Ax(Bj
+<x-charset><param>mule-unicode-0100-24ff</param>Amharic (አማርኛ) ሠላም
+Arabic (العربيّة) السّلام عليكم
+Armenian (հայերեն) Բարև ձեզ
+Bengali (বাংলা) নমস্কার
+</x-charset><x-charset><param>mule-unicode-2500-33ff</param>Braille ⠓⠑⠇⠇⠕
+</x-charset><x-charset><param>mule-unicode-0100-24ff</param>Burmese (မြန်မာ) မင်္ဂလာပါ
+</x-charset>C printf ("Hello, world!\n");
+<x-charset><param>unicode</param>Cherokee (ᏣᎳᎩ ᎦᏬᏂᎯᏍᏗ) ᎣᏏᏲ / ᏏᏲ
+Comanche /kəˈmæntʃiː/ Haa marʉ́awe
+
+Cree (ᓀᐦᐃᔭᐍᐏᐣ) ᑕᓂᓯ / ᐙᒋᔮ
+
+</x-charset><x-charset><param>latin-iso8859-2</param>Czech (čeština) Dobrý den
+</x-charset><x-charset><param>latin-iso8859-1</param>Danish (dansk) Hej / Goddag / Halløj
Dutch (Nederlands) Hallo / Dag
+</x-charset><x-charset><param>unicode</param>Efik /ˈɛfɪk/ Mɔkɔm
+
Emacs emacs --no-splash -f view-hello-file
-English /$(O+S,0!,D?$(O*y(Bl,0!$(O*h(B/ Hello
-Esperanto Saluton (E,C6(Bo,C~(Ban,Cx(Bo ,Cf(Biu,C<(Ba,C}(Bde)
-Estonian (eesti keel) Tere p,Ad(Bevast / Tere ,Au(Bhtust
-Finnish (suomi) Hei / Hyv,Add(B p,Ad(Biv,Add(B
-French (fran,Ag(Bais) Bonjour / Salut
-Georgian ($,1JEJ0J@J7J5J4J:J8(B) $,1J2J0J;J0J@JOJ=J1J0(B
-German (Deutsch) Guten Tag / Gr,A|_(B Gott
-Greek (,Fekkgmij\(B) ,FCei\(B ,Fsar(B
-Greek, ancient ($,1p1,Fkkgmij^(B) ,FO$,1pv,Fk](B ,Fte(B ,Fja$,1q6(B ,Fl]ca(B ,Fwa$,1r6,Fqe(B
-Gujarati ($,19W:!9\9p9~9d: (B) $,19h9n9x:-9d:'(B
-Hebrew ($,1-",q-(,y-*(B) ,Hylem(B
-Hungarian (magyar) Sz,Bi(Bp j,Bs(B napot!
-Hindi ($,15y55B5f6 (B) $,15h5n5x6-5d6'(B / $,15h5n5x6-5U5~5p(B $,16D(B
-Italian (italiano) Ciao / Buon giorno
-Javanese (Jawa) System.out.println("Sugeng siang!");
-Kannada ($,1>u?(?M?(?!(B) $,1?(?.?8?M>u?>?0(B
-Khmer ($,1\7\V\?\V\!\r\8\b\:(B) $,1\'\f\:\V\4\?\]\:(B
-Lao ((1>RJRERG(B) (1JP:R-4U(B / (1"mcKib*!4U(B
-Malayalam ($,1@N@R@O@^@S@"(B) $,1@H@N@X@m@5@^@P@"(B
-Maltese (il-Malti) Bon,Cu(Bu / Sa,C11(Ba
-Mathematics $,1x (B p $,1x((B world $,1s"(B hello p $,2!a(B
-Mongolian (,L\^]S^[(B ,Lem[(B) ,LAPY](B ,LQPY]P(B ,Lcc(B?
-Norwegian (norsk) Hei / God dag
-Oriya ($,1:s;\;?:f(B) $,1;6;A;#;?;,;G(B
-Polish (j,Bj(Bzyk polski) Dzie,Bq(B dobry! / Cze,B6f(B!
-Russian (,L`caaZXY(B) ,L7T`P$(O+Z,LRabRcYbU(B!
-Sinhala ($,1B#B2ABB$A}(B) $,1AFAzB4AvB=B AqB*(B
-Slovak (sloven,Bh(Bina) Dobr,A}(B de,Br(B
-Slovenian (sloven,B9h(Bina) Pozdravljeni!
-Spanish (espa,Aq(Bol) ,A!(BHola!
-Swedish (svenska) Hej / Goddag / Hall,Ae(B
-Tamil ($,1<D<N<_<T<m(B) $,1<U<C<5<m<5<N<m(B
-Telugu ($,1=d>&=r>!=W>!(B) $,1=h=n=x>-=U=~=p=B(B
-Thai (,T@RIRd7B(B) ,TJGQJ4U$CQ:(B / ,TJGQJ4U$hP(B
-Tibetan ($(7"7"]"2!;"G#!"2!;(B) $(7"7"!#C!;"E"S"G!;"7"2"[!;"D"["#"G!>(B
-Tigrigna ($,1NUP-MmN{(B) $,1MpMKM[NU(B
-Turkish (T,A|(Brk,Ag(Be) Merhaba
-Ukrainian (,LcZ`Pw]alZP(B) ,L2vbPn(B
-Vietnamese (ti,1*(Bng Vi,1.(Bt) Ch,A`(Bo b,1U(Bn
-
-Japanese ($BF|K\8l(B) $B$3$s$K$A$O(B / (I:]FAJ(B
-Chinese ($AVPND(B,$AFUM(;0(B,$A::So(B) $ADc:C(B
-Cantonese ($(0GnM$(B,$(0N]0*Hd(B) $(0*/=((B, $(0+$)p(B
-Korean ($(CGQ1[(B) $(C>H3gGO<<?d(B / $(C>H3gGO=J4O1n(B
-
-
+
+Emoji 👋
+</x-charset>English <x-charset><param>ipa</param>/ˈɪŋɡlɪʃ/</x-charset> Hello
+<x-charset><param>latin-iso8859-3</param>Esperanto Saluton (Eĥoŝanĝo ĉiuĵaŭde)
+</x-charset><x-charset><param>latin-iso8859-15</param>Estonian (eesti keel) Tere päevast / Tere õhtust
+</x-charset><x-charset><param>latin-iso8859-1</param>Finnish (suomi) Hei / Hyvää päivää
+French (français) Bonjour / Salut
+</x-charset><x-charset><param>mule-unicode-0100-24ff</param>Georgian (ქართველი) გამარჯობა
+</x-charset><x-charset><param>latin-iso8859-1</param>German (Deutsch) Guten Tag / Grüß Gott
+</x-charset><x-charset><param>greek-iso8859-7</param>Greek (ελληνικά) Γειά σας
+</x-charset><x-charset><param>mule-unicode-0100-24ff</param>Greek, ancient (ἑλληνική) Οὖλέ τε καὶ μέγα χαῖρε
+Gujarati (ગુજરાતી) નમસ્તે
+</x-charset><x-charset><param>hebrew-iso8859-8</param>Hebrew (עברית) שלום
+</x-charset><x-charset><param>latin-iso8859-2</param>Hungarian (magyar) Szép jó napot!
+</x-charset><x-charset><param>mule-unicode-0100-24ff</param>Hindi (हिंदी) नमस्ते / नमस्कार ।
+</x-charset><x-charset><param>unicode</param>Inuktitut (ᐃᓄᒃᑎᑐᑦ) ᐊᐃ
+
+</x-charset><x-charset><param>latin-iso8859-1</param>Italian (italiano) Ciao / Buon giorno
+</x-charset>Javanese (Jawa) System.out.println("Sugeng siang!");
+<x-charset><param>mule-unicode-0100-24ff</param>Kannada (ಕನ್ನಡ) ನಮಸ್ಕಾರ
+Khmer (ភាសាខ្មែរ) ជំរាបសួរ
+</x-charset><x-charset><param>lao</param>Lao (ພາສາລາວ) ສະບາຍດີ / ຂໍໃຫ້ໂຊກດີ
+</x-charset><x-charset><param>mule-unicode-0100-24ff</param>Malayalam (മലയാളം) നമസ്കാരം
+</x-charset><x-charset><param>unicode</param>Maldivian (ދިވެހި) އައްސަލާމު ޢަލައިކުމް / ކިހިނެހް؟
+
+</x-charset><x-charset><param>latin-iso8859-3</param>Maltese (il-Malti) Bonġu / Saħħa
+</x-charset><x-charset><param>unicode</param>Mathematics ∀ p ∈ world • hello p □
+</x-charset><x-charset><param>cyrillic-iso8859-5</param>Mongolian (монгол хэл) Сайн байна уу?
+</x-charset><x-charset><param>latin-iso8859-1</param>Norwegian (norsk) Hei / God dag
+</x-charset><x-charset><param>mule-unicode-0100-24ff</param>Oriya (ଓଡ଼ିଆ) ଶୁଣିବେ
+</x-charset><x-charset><param>latin-iso8859-2</param>Polish (język polski) Dzień dobry! / Cześć!
+</x-charset><x-charset><param>cyrillic-iso8859-5</param>Russian (русский) Здра́вствуйте!
+</x-charset><x-charset><param>mule-unicode-0100-24ff</param>Sinhala (සිංහල) ආයුබෝවන්
+</x-charset><x-charset><param>latin-iso8859-2</param>Slovak (slovenčina) Dobrý deň
+Slovenian (slovenščina) Pozdravljeni!
+Spanish (espa</x-charset><x-charset><param>latin-iso8859-1</param>ñol) ¡Hola!
+Swedish (svenska) Hej / Goddag / Hallå
+</x-charset><x-charset><param>mule-unicode-0100-24ff</param>Tamil (தமிழ்) வணக்கம்
+Telugu (తెలుగు) నమస్కారం
+</x-charset><x-charset><param>thai-tis620</param>Thai (ภาษาไทย) สวัสดีครับ / สวัสดีค่ะ
+</x-charset><x-charset><param>tibetan</param>Tibetan (བོད་སྐད་) བཀྲ་ཤིས་བདེ་ལེགས༎
+</x-charset><x-charset><param>mule-unicode-0100-24ff</param>Tigrigna (ትግርኛ) ሰላማት
+</x-charset><x-charset><param>latin-iso8859-9</param>Turkish (Türkçe) Merhaba
+</x-charset><x-charset><param>cyrillic-iso8859-5</param>Ukrainian (українська) Вітаю
+</x-charset><x-charset><param>vietnamese-viscii-lower</param>Vietnamese (tiếng </x-charset><x-charset><param>vietnamese-viscii-upper</param>V</x-charset><x-charset><param>vietnamese-viscii-lower</param>iệt) </x-charset><x-charset><param>vietnamese-viscii-upper</param>Chào bạn
+
+</x-charset>
+
+<x-charset><param>japanese-jisx0208</param>Japanese (日本語) こんにちは</x-charset> <x-charset><param>katakana-jisx0201</param>/ コンニチハ
+</x-charset><x-charset><param>chinese-gb2312</param>Chinese (中文,普通话,汉语) 你好
+</x-charset><x-charset><param>chinese-big5-1</param>Cantonese (粵語,廣東話) 早晨, 你好
+</x-charset><x-charset><param>korean-ksc5601</param>Korean (한글) 안녕하세요 / 안녕하십니까
+
+</x-charset>
+
+<x-charset><param>unicode</param>
+
Copyright (C) 2001-2019 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 <https://www.gnu.org/licenses/>.
+along with GNU Emacs. If not, see <<https://www.gnu.org/licenses/>.
+
;;; Local Variables:
;;; tab-width: 32
;;; bidi-display-reordering: t
-;;; coding: iso-2022-7bit
-;;; End:
+;;; coding: utf-8
+;;; End:</x-charset>
diff --git a/etc/LINUX-GNU b/etc/LINUX-GNU
deleted file mode 100644
index 0f45e15ac1d..00000000000
--- a/etc/LINUX-GNU
+++ /dev/null
@@ -1,8 +0,0 @@
-Linux and the GNU system
-
-Note added March 2014:
-
-This file is obsolete and will be removed in future.
-Please update any references to use
-
-<https://www.gnu.org/gnu/linux-and-gnu.html>
diff --git a/etc/MORE.STUFF b/etc/MORE.STUFF
deleted file mode 100644
index e3f2c1664c5..00000000000
--- a/etc/MORE.STUFF
+++ /dev/null
@@ -1,8 +0,0 @@
-More Neat Stuff for your Emacs
-
-Note added January 2014:
-
-This file is obsolete and will be removed in future.
-Please update any links to use
- info node `(efaq)Packages that do not come with Emacs'
-instead.
diff --git a/etc/NEWS b/etc/NEWS
index c927872f4d3..9e3d993cab0 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1,1905 +1,1926 @@
GNU Emacs NEWS -- history of user-visible changes.
-Copyright (C) 2016-2019 Free Software Foundation, Inc.
+Copyright (C) 2017-2019 Free Software Foundation, Inc.
See the end of the file for license conditions.
Please send Emacs bug reports to 'bug-gnu-emacs@gnu.org'.
If possible, use 'M-x report-emacs-bug'.
-This file is about changes in Emacs version 26.
+This file is about changes in Emacs version 27.
See file HISTORY for a list of GNU Emacs versions and release dates.
-See files NEWS.25, NEWS.24, ..., NEWS.18, and NEWS.1-17 for changes
+See files NEWS.26, NEWS.25, ..., NEWS.18, and NEWS.1-17 for changes
in older Emacs versions.
You can narrow news to a specific version by calling 'view-emacs-news'
with a prefix argument or by typing 'C-u C-h C-n'.
-
-* Installation Changes in Emacs 26.2
-
-** Building Emacs with the '--with-xwidgets' option now requires WebKit2.
-To build Emacs with xwidgets support, you will need to install the
-webkit2gtk-4.0 package; version 2.12 or later is required.
-(This change was actually made in Emacs 26.1, but was not called out
-in its NEWS.)
-
-** Installing Emacs now installs the emacs-module.h file.
-The emacs-module.h file is now installed in the system-wide include
-directory as part of the Emacs installation. This allows to build
-Emacs modules outside of the Emacs source tree.
-
-
-* Startup Changes in Emacs 26.2
-
-
-* Changes in Emacs 26.2
-
-** Emacs is now compliant with the latest version 11.0 of the Unicode Standard.
-
-** New variable 'xft-ignore-color-fonts'.
-Default t means don't try to load color fonts when using Xft, as they
-often cause crashes. Set it to nil if you really need those fonts.
-
-
-* Editing Changes in Emacs 26.2
-
-
-* Changes in Specialized Modes and Packages in Emacs 26.2
-
-** Dired
-
-*** The 'Z' command on a directory name compresses all of its files.
-It produces a compressed '.tar.gz' archive with all the files in the
-directory and all of its subdirectories. For symmetry, 'Z' on a
-'.tar.gz' or a '.tgz' archive extracts all the archived files into the
-current directory; thus, typing 'Z' on a '.tar.gz' archive created by
-a previous 'Z' command will extract the archived files into a
-directory whose name is the archive name sans the '.tar.gz' extension.
-(This change was actually made in Emacs 25.1 but was only
-partially called out in its NEWS; 'tgz' handling was added in 26.1.)
-
-** Ibuffer
-
-*** New toggle 'ibuffer-do-toggle-lock', bound to 'L'.
-
-** Imenu
-
-*** The value for 'imenu-auto-rescan-maxout' has been increased to 600000.
-
-** Gnus
-
-*** Mailutils movemail will now be used if found at runtime.
-The default value of 'mail-source-movemail-program' is now "movemail".
-This ensures that the movemail program from GNU Mailutils will be used
-if found in 'exec-path', even if it was not found at build time. To
-use a different program, customize 'mail-source-movemail-program' to the
-absolute file name of the desired executable.
-
-** Shadowfile
-
-*** shadowfile.el has been rewritten to support Tramp file names.
-
-** Shell mode
-
-*** Shell mode buffers now have 'scroll-conservatively' set to 101.
-This is so as to better emulate the scrolling behavior of a text
-terminal when new output is added to the screen buffer. To get back
-the previous behavior, reset 'scroll-conservatively' to zero (or any
-other value you like) in a function and add it to 'shell-mode-hook'.
-(This change was actually made in Emacs 26.1, but was not called out
-in its NEWS.)
-
-** VC
-
-*** VC support for Mercurial was improved.
-Emacs now avoids invoking 'hg' as much as possible, for faster operation.
-(This and the following changes were actually made in Emacs 26.1, but
-were not called out in its NEWS.)
-
-**** New vc-hg options.
-The new option 'vc-hg-parse-hg-data-structures' controls whether vc-hg
-will try parsing the Mercurial data structures directly instead of
-running 'hg'; it defaults to t (set to nil if you want the pre-26.1
-behavior).
-The new option 'vc-hg-symbolic-revision-styles' controls how versions
-in a Mercurial repository are presented symbolically on the mode line.
-The new option 'vc-hg-use-file-version-for-mode-line-version' controls
-whether the version shown on the mode line is that of the visited file
-or of the repository working copy.
-
-**** Display of Mercurial revisions in the mode line has changed.
-Previously, the mode line displayed the local number (1, 2, 3, ...) of
-the revision. Starting with Emacs 26.1, the default has changed, and
-it now shows the global revision number, in the form of its changeset
-hash value. To get back the previous behavior, customize the new
-option 'vc-hg-symbolic-revision-styles' to the value '("{rev}")'.
-
-
-* New Modes and Packages in Emacs 26.2
+Temporary note:
++++ indicates that all necessary documentation updates are complete.
+ (This means all relevant manuals in doc/ AND lisp doc-strings.)
+--- means no change in the manuals is needed.
+When you add a new item, use the appropriate mark if you are sure it applies,
-* Incompatible Lisp Changes in Emacs 26.2
-
-** shadowfile config files have changed their syntax.
-Existing files "~/.emacs.d/shadows" and "~/.emacs.d/shadow_todo" must
-be removed prior using the changed 'shadow-*' commands.
-
-** 'thread-alive-p' has been renamed to 'thread-live-p'.
-The old name is an alias of the new name. Future Emacs version will
-obsolete it.
-
-** 'while-no-input' does not return due to input from subprocesses.
-Input that arrived from subprocesses while some code executed inside
-the 'while-no-input' form injected an internal buffer-switch event
-that counted as input and would cause 'while-no-input' to return,
-perhaps prematurely. These buffer-switch events are now by default
-ignored by 'while-no-input'; if you need to get the old behavior,
-remove 'buffer-switch' from the list of events in
-'while-no-input-ignore-events'.
+* Installation Changes in Emacs 27.1
+
+** Emacs now uses GMP, the GNU Multiple Precision library.
+By default, if 'configure' does not find a suitable libgmp, it
+arranges for the included mini-gmp library to be built and used.
+The new 'configure' option '--without-libgmp' uses mini-gmp even if a
+suitable libgmp is available.
+
+** The new configure option '--with-json' adds support for JSON using
+the Jansson library. It is on by default; use './configure
+--with-json=no' to build without Jansson support. The new JSON
+functions 'json-serialize', 'json-insert', 'json-parse-string', and
+'json-parse-buffer' are typically much faster than their Lisp
+counterparts from json.el.
+
+** Several configure options now accept an option-argument 'ifavailable'.
+For example, './configure --with-xpm=ifavailable' now configures Emacs
+to attempt to use libxpm but to continue building even if libxpm is absent.
+The other affected options are --with-gif, --with-gnutls, --with-jpeg,
+--with-png, and --with-tiff.
+
+** The etags program now uses the C library's regular expression matcher
+when possible, and a compatible regex substitute otherwise. This will
+let developers maintain Emacs's own regex code without having to also
+support other programs. The new configure option '--without-included-regex'
+forces etags to use the C library's regex matcher even if the regex
+substitute ordinarily would be used to work around compatibility problems.
+
+** Emacs has been ported to the '-fcheck-pointer-bounds' option of GCC.
+This causes Emacs to check bounds of some arrays addressed by its
+internal pointers, which can be helpful when debugging the Emacs
+interpreter or modules that it uses. If your platform supports it you
+can enable it when configuring, e.g., './configure CFLAGS="-g3 -O2
+-mmpx -fcheck-pointer-bounds"' on Intel MPX platforms.
+
+** Emacs now normally uses a C pointer type instead of a C integer
+type to implement Lisp_Object, which is the fundamental machine word
+type internal to the Emacs Lisp interpreter. This change aims to
+catch typos and supports '-fcheck-pointer-bounds'. The 'configure'
+option '--enable-check-lisp-object-type' is therefore no longer as
+useful and so is no longer enabled by default in developer builds,
+to reduce differences between developer and production builds.
+
++++
+** Emacs now uses a "portable dumper" instead of unexec.
+This improves compatibility with memory allocation on modern systems,
+and in particular better supports the Address Space Layout
+Randomization (ASLR) feature, a security technique used by most modern
+operating systems.
+
+Portable dumping can be disabled at configure time via the configure
+option '--with-dumping=unexec' (but we don't recommend that, unless
+the portable dumping doesn't work on your system for some
+reason---please report such systems to the Emacs developers as bugs).
+
+When built with the portable dumping support (which is the default),
+Emacs looks for the 'emacs.pdmp' file, generated during the build, in
+its data directory at startup, and loads the dumped state from there.
+The new command-line argument '--dump-file=FILE' allows to specify a
+non-default '.pdmp' file to load the state from; see the node "Initial
+Options" in the Emacs manual for more information.
+
++++
+** The new configure option '--enable-checking=structs' attempts to
+check that the portable dumper code has been updated to match the last
+change to one of the data structures that it relies on.
-* Lisp Changes in Emacs 26.2
-
-** The new function 'read-answer' accepts either long or short answers
-depending on the new customizable variable 'read-answer-short'.
-
-** New function 'assoc-delete-all'.
-Like 'assq-delete-all', but uses 'equal' for comparison.
-
-** The function 'thing-at-point' behaves as before Emacs 26.1.
-The behavior of 'thing-at-point' when called with argument 'list' has
-changed in Emacs 26.1, in that it didn't consider text inside comments
-and strings as a potential list. This change is now reverted, and
-'thing-at-point' behaves like it did before Emacs 26.1.
-
-** To cater to use cases where comments and strings are to be ignored
-when looking for a list, the function 'list-at-point' now takes an
-optional argument to do so.
+* Startup Changes in Emacs 27.1
+
++++
+** Emacs can now be configured using an early init file.
+The file is called 'early-init.el', in 'user-emacs-directory'. It is
+loaded very early in the startup process: before graphical elements
+such as the tool bar are initialized, and before the package manager
+is initialized. The primary purpose is to allow customizing how the
+package system is initialized given that initialization now happens
+before loading the regular init file (see below).
+
+We recommend against putting any customizations in this file that
+don't need to be set up before initializing installed add-on packages,
+because the early init file is read too early into the startup
+process, and some important parts of the Emacs session, such as
+'window-system' and other GUI features, are not yet set up, which could
+make some customization fail to work.
+
++++
+** Installed packages are now activated *before* loading the init file.
+This is part of a change intended to eliminate the behavior of
+package.el inserting a call to 'package-initialize' into the init
+file, which was previously done when Emacs was started. As a result
+of this change, it is no longer necessary to call 'package-initialize'
+in your init file.
+
+However, if your init file changes the values of 'package-load-list' or
+'package-user-dir', or sets 'package-enable-at-startup' to nil then it won't
+work right without some adjustment:
+- you can move that code to the early init file (see above), so those settings
+ apply before Emacs tries to activate the packages.
+- you can use the new 'package-quickstart' so activation of packages does not
+ need to pay attention to 'package-load-list' or 'package-user-dir' any more.
+
+---
+** Emacs now notifies systemd when startup finishes or shutdown begins.
+Units that are ordered after 'emacs.service' will only be started
+after Emacs has finished initialization and is ready for use.
+(If your Emacs is installed in a non-standard location and you copied the
+emacs.service file to eg "~/.config/systemd/user/", you will need to copy
+the new version of the file again.)
-* Changes in Emacs 26.2 on Non-Free Operating Systems
-
-** macOS features can now be detected at run-time as well as at
-build-time. See nextstep/INSTALL for details.
-(This change was actually made in Emacs 26.1, but was undocumented and
-not called out in its NEWS.)
-
-
-* Installation Changes in Emacs 26.1
-
-** By default libgnutls is now required when building Emacs.
-Use 'configure --with-gnutls=no' to build even when GnuTLS is missing.
-
-** GnuTLS version 2.12.2 or later is now required, instead of merely
-version 2.6.6 or later.
-
-** The new option 'configure --with-mailutils' causes Emacs to rely on
-GNU Mailutils to retrieve email. It is recommended, and is the
-default if GNU Mailutils is installed. When '--with-mailutils' is not
-in effect, the Emacs build procedure by default continues to build and
-install a limited 'movemail' substitute that retrieves POP3 email only
-via insecure channels. To avoid this problem, use either
-'--with-mailutils' or '--without-pop' when configuring; '--without-pop'
-is the default on platforms other than native MS-Windows.
-
-** The new option 'configure --enable-gcc-warnings=warn-only' causes
-GCC to issue warnings without stopping the build. This behavior is
-now the default in developer builds. As before, use
-'--disable-gcc-warnings' to suppress GCC's warnings, and
-'--enable-gcc-warnings' to stop the build if GCC issues warnings.
-
-** When GCC warnings are enabled, '--enable-check-lisp-object-type' is
-now enabled by default when configuring.
-
-** The Emacs server now has socket-launching support.
-This allows socket based activation, where an external process like
-systemd can invoke the Emacs server process upon a socket connection
-event and hand the socket over to Emacs. Emacs uses this socket to
-service emacsclient commands. This new functionality can be disabled
-with the configure option '--disable-libsystemd'.
-
-** A systemd user unit file is provided.
-Use it in the standard way: 'systemctl --user enable emacs'. (If your
-Emacs is installed in a non-standard location, you may need to copy
-the emacs.service file to eg ~/.config/systemd/user/)
-
-** New configure option '--disable-build-details' attempts to build an
-Emacs that is more likely to be reproducible; that is, if you build
-and install Emacs twice, the second Emacs is a copy of the first.
-Deterministic builds omit the build date from the output of the
-'emacs-version' and 'erc-cmd-SV' functions, and the leave the
-following variables nil: 'emacs-build-system', 'emacs-build-time',
-'erc-emacs-build-time'.
-
-** Emacs can now be built with support for Little CMS.
-If the lcms2 library is installed, Emacs will enable features built on
-top of that library. The new configure option '--without-lcms2' can
-be used to build without lcms2 support even if it is installed. Emacs
-linked to Little CMS exposes color management functions in Lisp: the
-color metrics 'lcms-cie-de2000' and 'lcms-cam02-ucs', as well as
-functions for conversion to and from CIE CAM02 and CAM02-UCS.
-
-** The configure option '--with-gameuser' now defaults to 'no',
-as this appears to be the most common configuration in practice.
-When it is 'no', the shared game directory and the auxiliary program
-update-game-score are no longer needed and are not installed.
-
-** Emacs no longer works on IRIX. We expect that Emacs users are not
-affected by this, as SGI stopped supporting IRIX in December 2013.
-
-
-* Startup Changes in Emacs 26.1
-
-** New option '--fg-daemon'. This is the same as '--daemon', except
-it runs in the foreground and does not fork. This is intended for
-modern init systems such as systemd, which manage many of the traditional
-aspects of daemon behavior themselves. '--bg-daemon' is now an alias
-for '--daemon'.
-
-** New option '--module-assertions'.
-When given this option, Emacs will perform expensive correctness
-checks when dealing with dynamic modules. This is intended for module
-authors that wish to verify that their module conforms to the module
-requirements. The option makes Emacs abort if a module-related
-assertion triggers.
-
-** Emacs now supports 24-bit colors on capable text terminals.
-Terminal is automatically initialized to use 24-bit colors if the
-required capabilities are found in terminfo. See the FAQ node
-"(efaq) Colors on a TTY" for more information.
+* Changes in Emacs 27.1
+
+** emacsclient
+
++++
+*** emacsclient now supports the 'EMACS_SOCKET_NAME' environment variable.
+The behavior is identical to 'EMACS_SERVER_FILE', in that the
+command-line value specified via '--socket-name' will override the
+environment, and the natural default to TMPDIR, then "/tmp", continues
+to apply.
+
++++
+*** Emacs and emacsclient now default to $XDG_RUNTIME_DIR/emacs
+as the directory for client/server sockets, if Emacs is running
+under an X Window System desktop that sets the XDG_RUNTIME_DIR
+environment variable to indicate where session sockets should go.
+To get the old, less-secure behavior, you can set the
+EMACS_SOCKET_NAME environment variable to an appropriate value.
+
+---
+*** When run by root, emacsclient no longer connects to non-root sockets.
+(Instead you can use Tramp methods to run root commands in a non-root Emacs.)
+
+---
+** Control of the threshold for using the 'distant-foreground' color.
+The threshold for color distance below which the 'distant-foreground'
+color of the face will be used instead of the foreground color can now
+be controlled via the new variable 'face-near-same-color-threshold'.
+The default value is 30000, as the previously hard-coded threshold.
+
++++
+** The function 'read-passwd' uses '*' as default character to hide passwords.
+
+---
+** The new option 'tooltip-resize-echo-area' avoids truncating tooltip text
+on GUI frames when tooltips are displayed in the echo area. Instead,
+it resizes the echo area as needed to accommodate the full tool-tip
+text.
+
+---
+** Show mode line tooltips only if the corresponding action applies.
+Customize the option 'mode-line-default-help-echo' to restore the old
+behavior where the tooltip text is also shown when the corresponding
+action does not apply.
+
++++
+** New hook 'server-after-make-frame-hook'.
+This hook is a convenient place to perform initializations in daemon
+mode which require GUI features to be available. One example is
+restoration of the previous session using the desktop.el package: put
+the call to 'desktop-read' in this hook, if you want the GUI settings
+to be restored, or if desktop.el needs to interact with you during
+restoration of the session.
+
++++
+** New function 'logcount' calculates an integer's Hamming weight.
+
++++
+** New function 'libxml-available-p'.
+This function returns non-nil if libxml support is both compiled in
+and available at run time. Lisp programs should use this function to
+detect built-in libxml support, instead of testing for that
+indirectly, e.g., by checking that functions like
+'libxml-parse-html-region' return nil.
+
++++
+** 'libxml-parse-xml-region' and 'libxml-parse-html' region take
+a parameter that's called DISCARD-COMMENTS, but it really only
+discards the top-level comment. Therefore this parameter is now
+obsolete, and the new utility function 'xml-remove-comments' can be
+used to remove comments before calling the libxml functions to parse
+the data.
+
++++
+** The Network Security Manager now allows more fine-grained control
+of what checks to run via the 'network-security-protocol-checks'
+variable.
-** Emacs now obeys the X resource "scrollBar" at startup.
-The effect is similar to that of "toolBar" resource on the tool bar.
++++
+** TLS connections have their security tightened by default.
+Most of the checks for outdated, believed-to-be-weak TLS algorithms
+and ciphers are now switched on by default. By default, the NSM will
+flag connections using these weak algorithms and ask users whether to
+allow them. To get the old behavior back (where certificates are
+checked for validity, but no warnings about weak cryptography are
+issued), you can either set 'network-security-protocol-checks' to nil,
+or adjust the elements in that variable to only happen on the 'high'
+security level (assuming you use the 'medium' level).
+
++++
+** Native GnuTLS connections can now use client certificates.
+Previously, this support was only available when using the external
+gnutls-cli command. Call 'open-network-stream' with
+':client-certificate t' to trigger looking up of per-server
+certificates via 'auth-source'.
+
++++
+** New function 'fill-polish-nobreak-p', to be used in 'fill-nobreak-predicate'.
+It blocks line breaking after a one-letter word, also in the case when
+this word is preceded by a non-space, but non-alphanumeric character.
+
++++
+** The limit on repetitions in regexps has been raised to 2^16-1.
+It was previously limited to 2^15-1. For example, the following
+regular expression was previously invalid, but is now accepted:
+
+ x\{32768\}
+
+---
+** The German prefix and postfix input methods now support Capital sharp S.
+
+---
+** New input methods 'hawaiian-postfix' and 'hawaiian-prefix'.
+
+---
+** New input methods for several variants of the Sami language.
+The Sami input methods include: 'norwegian-sami-prefix',
+'bergsland-hasselbrink-sami-prefix', 'southern-sami-prefix',
+'ume-sami-prefix', 'northern-sami-prefix', 'inari-sami-prefix',
+'skolt-sami-prefix', and 'kildin-sami-prefix'.
+
++++
+** In Japanese environments that do not specify encodings and are not
+based on MS-Windows, the default encoding is now utf-8 instead of
+japanese-iso-8bit.
+
++++
+** New function 'exec-path'.
+This function by default returns the value of the corresponding
+variable, but can optionally return the equivalent of 'exec-path'
+from a remote host.
+
++++
+** The function 'executable-find' supports an optional argument REMOTE.
+This triggers to search the program on the remote host as indicated by
+'default-directory'.
+
++++
+** New variable 'auto-save-no-message'.
+When set to t, no message will be shown when auto-saving (default
+value: nil).
+
+---
+** The value of 'make-cursor-line-fully-visible' can now be a function.
+In addition to nil or non-nil, the value can now be a predicate
+function. Follow mode uses this to control scrolling of its windows
+when the last screen line in a window is not fully visible.
+
++++
+** New variable 'emacs-repository-branch'.
+It reports the git branch from which Emacs was built.
+
++++
+** New user option 'switch-to-buffer-obey-display-actions'.
+When non-nil, 'switch-to-buffer' uses 'pop-to-buffer-same-window' that
+respects display actions specified by 'display-buffer-alist' and
+'display-buffer-overriding-action'.
+
+** New 'flex' completion style
+An implementation of popular "flx/fuzzy/scatter" completion which
+matches strings where the pattern appears as a subsequence. Put
+simply, makes "foo" complete to both "barfoo" and "frodo". Add 'flex'
+to 'completion-styles' or 'completion-category-overrides' to use it.
+
+** Connection-local variables
+
++++
+*** Connection-local variables are applied by default like file-local
+and directory-local variables.
+
++++
+*** The macro 'with-connection-local-variables' has been renamed from
+'with-connection-local-profiles'. No argument 'profiles' needed any
+longer.
+
+---
+** next-error-verbosity controls when `next-error' outputs a message
+ about the error locus.
-* Changes in Emacs 26.1
-
-** Option 'buffer-offer-save' can be set to new value, 'always'.
-When set to 'always', the command 'save-some-buffers' will always
-offer this buffer for saving.
-
-** Security vulnerability related to Enriched Text mode is removed.
-
-*** Enriched Text mode does not evaluate Lisp in 'display' properties.
-This feature allows saving 'display' properties as part of text.
-Emacs 'display' properties support evaluation of arbitrary Lisp forms
-as part of processing the property for display, so displaying Enriched
-Text could be vulnerable to executing arbitrary malicious Lisp code
-included in the text (e.g., sent as part of an email message).
-Therefore, execution of arbitrary Lisp forms in 'display' properties
-decoded by Enriched Text mode is now disabled by default. Customize
-the new option 'enriched-allow-eval-in-display-props' to a non-nil
-value to allow Lisp evaluation in decoded 'display' properties.
-
-This vulnerability was introduced in Emacs 21.1. To work around that
-in Emacs versions before 25.3, append the following to your ~/.emacs
-init file:
-
- (eval-after-load "enriched"
- '(defun enriched-decode-display-prop (start end &optional param)
- (list start end)))
-
-** Functions in 'write-contents-functions' can fully short-circuit the
-'save-buffer' process. Previously, saving a buffer that was not
-visiting a file would always prompt for a file name. Now it only does
-so if 'write-contents-functions' is nil (or all its functions return
-nil).
-
-** New variable 'executable-prefix-env' for inserting magic signatures.
-This variable affects the format of the interpreter magic number
-inserted by 'executable-set-magic'. If non-nil, the magic number now
-takes the form "#!/usr/bin/env interpreter", otherwise the value
-determined by 'executable-prefix', which is by default
-"#!/path/to/interpreter". By default, 'executable-prefix-env' is nil,
-so the default behavior is not changed.
-
-** The variable 'emacs-version' no longer includes the build number.
-This is now stored separately in a new variable, 'emacs-build-number'.
-
-** Emacs now provides a limited form of concurrency with Lisp threads.
-Concurrency in Emacs Lisp is "mostly cooperative", meaning that
-Emacs will only switch execution between threads at well-defined
-times: when Emacs waits for input, during blocking operations related
-to threads (such as mutex locking), or when the current thread
-explicitly yields. Global variables are shared among all threads, but
-a 'let' binding is thread-local. Each thread also has its own current
-buffer and its own match data.
-
-See the chapter "(elisp) Threads" in the ELisp manual for full
-documentation of these facilities.
-
-** The new user variable 'electric-quote-chars' provides a list
-of curved quotes for 'electric-quote-mode', allowing user to choose
-the types of quotes to be used.
-
-** The new user option 'electric-quote-context-sensitive' makes
-'electric-quote-mode' context sensitive. If it is non-nil, you can
-type an ASCII apostrophe to insert an opening or closing quote,
-depending on context. Emacs will replace the apostrophe by an opening
-quote character at the beginning of the buffer, the beginning of a
-line, after a whitespace character, and after an opening parenthesis;
-and it will replace the apostrophe by a closing quote character in all
-other cases.
-
-** The new variable 'electric-quote-inhibit-functions' controls when
-to disable electric quoting based on context. Major modes can add
-functions to this list; Emacs will temporarily disable
-'electric-quote-mode' whenever any of the functions returns non-nil.
-This can be used by major modes that derive from 'text-mode' but allow
-inline code segments, such as 'markdown-mode'.
-
-** The new user variable 'dired-omit-case-fold' allows the user to
-customize the case-sensitivity of dired-omit-mode. It defaults to
-the same sensitivity as that of the filesystem for the corresponding
-dired buffer.
-
-** Emacs now uses double buffering to reduce flicker when editing and
-resizing graphical Emacs frames on the X Window System. This support
-requires the DOUBLE-BUFFER extension, which major X servers have
-supported for many years. If your system has this extension, but an
-Emacs built with double buffering misbehaves on some displays you use,
-you can disable the feature by adding
-
- '(inhibit-double-buffering . t)
-
-to default-frame-alist. Or inject this parameter into the selected
-frame by evaluating this form:
-
- (modify-frame-parameters nil '((inhibit-double-buffering . t)))
-
-** The customization group 'wp', whose label was "text", is now
-deprecated. Use the new group 'text', which inherits from 'wp',
-instead.
-
-** The new function 'call-shell-region' executes a command in an
-inferior shell with the buffer region as input.
-
-** The new user option 'shell-command-dont-erase-buffer' controls
-if the output buffer is erased between shell commands; if non-nil,
-the output buffer is not erased; this variable also controls where
-to set the point in the output buffer: beginning of the output,
-end of the buffer or save the point.
-When 'shell-command-dont-erase-buffer' is nil, the default value,
-the behavior of 'shell-command', 'shell-command-on-region' and
-'async-shell-command' is as usual.
-
-** The new user option 'async-shell-command-display-buffer' controls
-whether the output buffer of an asynchronous command is shown
-immediately, or only when there is output.
-
-** New user option 'mouse-select-region-move-to-beginning'.
-This option controls the position of point when double-clicking
-mouse-1 on the end of a parenthetical grouping or string-delimiter:
-the default value nil keeps point at the end of the region, setting it
-to non-nil moves point to the beginning of the region.
-
-** New user option 'mouse-drag-and-drop-region'.
-This option allows you to drag the entire region of text to another
-place or another buffer. Its behavior is customizable via the new
-options 'mouse-drag-and-drop-region-cut-when-buffers-differ',
-'mouse-drag-and-drop-region-show-tooltip', and
-'mouse-drag-and-drop-region-show-cursor'.
-
-** The new user option 'confirm-kill-processes' allows the user to
-skip a confirmation prompt for killing subprocesses when exiting
-Emacs. When set to t (the default), Emacs will prompt for
-confirmation before killing subprocesses on exit, which is the same
-behavior as before.
-
-** 'find-library-name' will now fall back on looking at 'load-history'
-to try to locate libraries that have been loaded with an explicit path
-outside 'load-path'.
-
-** Faces in 'minibuffer-prompt-properties' no longer overwrite properties
-in the text in functions like 'read-from-minibuffer', but instead are
-added to the end of the face list. This allows users to say things
-like '(read-from-minibuffer (propertize "Enter something: " 'face 'bold))'.
-
-** The new variable 'extended-command-suggest-shorter' has been added
-to control whether to suggest shorter 'M-x' commands or not.
-
-** icomplete now respects 'completion-ignored-extensions'.
-
-** Non-breaking hyphens are now displayed with the 'nobreak-hyphen'
-face instead of the 'escape-glyph' face.
-
-** Approximations to quotes are now displayed with the new 'homoglyph'
-face instead of the 'escape-glyph' face.
-
-** New face 'header-line-highlight'.
-This face is the header-line analogue of 'mode-line-highlight'; it
-should be the preferred mouse-face for mouse-sensitive elements in the
-header line.
-
-** 'C-x h' ('mark-whole-buffer') will now avoid marking the prompt
-part of minibuffers.
-
-** 'fill-paragraph' no longer marks the buffer as changed unless it
-actually changed something.
-
-** The locale language name 'ca' is now mapped to the language
-environment 'Catalan', which has been added.
-
-** 'align-regexp' has a separate history for its interactive argument.
-'align-regexp' no longer shares its history with all other
-history-less functions that use 'read-string'.
-
-** The networking code has been reworked so that it's more
-asynchronous than it was (when specifying :nowait t in
-'make-network-process'). How asynchronous it is varies based on the
-capabilities of the system, but on a typical GNU/Linux system the DNS
-resolution, the connection, and (for TLS streams) the TLS negotiation
-are all done without blocking the main Emacs thread. To get
-asynchronous TLS, the TLS boot parameters have to be passed in (see
-the manual for details).
-
-Certain process oriented functions (like 'process-datagram-address')
-will block until socket setup has been performed. The recommended way
-to deal with asynchronous sockets is to avoid interacting with them
-until they have changed status to "run". This is most easily done
-from a process sentinel.
-
-** 'make-network-process' and 'open-network-stream' sometimes allowed
-:service to be an integer string (e.g., :service "993") and sometimes
-required an integer (e.g., :service 993). This difference has been
-eliminated, and integer strings work everywhere.
-
-** It is possible to disable attempted recovery on fatal signals.
-Two new variables support disabling attempts to recover from stack
-overflow and to avoid automatic auto-save when Emacs is delivered a
-fatal signal. 'attempt-stack-overflow-recovery', if set to nil,
-will disable attempts to recover from C stack overflows; Emacs will
-then crash as with any other fatal signal.
-'attempt-orderly-shutdown-on-fatal-signal', if set to nil, will
-disable attempts to auto-save the session and shut down in an orderly
-fashion when Emacs receives a fatal signal; instead, Emacs will
-terminate immediately. Both variables are non-nil by default.
-These variables are for users who would like to avoid the small
-probability of data corruption due to techniques Emacs uses to recover
-in these situations.
-
-** File local and directory local variables are now initialized each
-time the major mode is set, not just when the file is first visited.
-These local variables will thus not vanish on setting a major mode.
-
-** A second dir-local file (.dir-locals-2.el) is now accepted.
-See the doc string of 'dir-locals-file' for more information.
-
-** Connection-local variables can be used to specify local variables
-with a value depending on the connected remote server. For details,
-see the node "(elisp) Connection Local Variables" in the ELisp manual.
-
-** International domain names (IDNA) are now encoded via the new
-puny.el library, so that one can visit Web sites with non-ASCII URLs.
-
-** The new 'list-timers' command lists all active timers in a buffer,
-where you can cancel them with the 'c' command.
-
-** 'switch-to-buffer-preserve-window-point' now defaults to t.
-Applications that call 'switch-to-buffer' and want to show the buffer at
-the position of its point should use 'pop-to-buffer-same-window' in lieu
-of 'switch-to-buffer'.
-
-** The new variable 'debugger-stack-frame-as-list' allows displaying
-all call stack frames in a Lisp backtrace buffer as lists. Both
-debug.el and edebug.el have been updated to heed to this variable.
-
-** Values in call stack frames are now displayed using 'cl-prin1'.
-The old behavior of using 'prin1' can be restored by customizing the
-new option 'debugger-print-function'.
-
-** NUL bytes in text copied to the system clipboard are now replaced with "\0".
-
-** The new variable 'x-ctrl-keysym' has been added to the existing
-roster of X keysyms. It can be used in combination with another
-variable of this kind to swap modifiers in Emacs.
-
-** New input methods: 'cyrillic-tuvan', 'polish-prefix', 'uzbek-cyrillic'.
-
-** The 'dutch' input method no longer attempts to support Turkish too.
-Also, it no longer converts 'IJ' and 'ij' to the compatibility
-characters U+0132 LATIN CAPITAL LIGATURE IJ and U+0133 LATIN SMALL
-LIGATURE IJ.
-
-** File name quoting by adding the prefix "/:" is now possible for the
-local part of a remote file name. Thus, if you have a directory named
-"/~" on the remote host "foo", you can prevent it from being
-substituted by a home directory by writing it as "/foo:/:/~/file".
-
-** The new variable 'maximum-scroll-margin' allows having effective
-settings of 'scroll-margin' up to half the window size, instead of
-always restricting the margin to a quarter of the window.
-
-** Emacs can scroll horizontally using mouse, touchpad, and trackbar.
-You can enable this by customizing 'mouse-wheel-tilt-scroll'. If you
-want to reverse the direction of the scroll, customize
-'mouse-wheel-flip-direction'.
-
-** The default GnuTLS priority string now includes %DUMBFW.
-This is to avoid bad behavior in some firewalls, which causes the
-connection to be closed by the remote host.
-
-** Emacsclient changes
-
-*** Emacsclient has a new option '-u' / '--suppress-output'.
-This option suppresses display of return values from the server
-process.
-
-*** Emacsclient has a new option '-T' / '--tramp'.
-This helps with using a local Emacs session as the server for a remote
-emacsclient. With appropriate setup, one can now set the EDITOR
-environment variable on a remote machine to emacsclient, and
-use the local Emacs to edit remote files via Tramp. See the node
-"(emacs) emacsclient Options" in the user manual for the details.
-
-*** Emacsclient now accepts command-line options in ALTERNATE_EDITOR
-and '--alternate-editor'. For example, ALTERNATE_EDITOR="emacs -Q -nw".
-Arguments may be quoted "like this", so that for example an absolute
-path containing a space may be specified; quote escaping is not
-supported.
-
-** New user option 'dig-program-options' and extended functionality
-for DNS-querying functions 'nslookup-host', 'dns-lookup-host',
-and 'run-dig'. Each function now accepts an optional name server
-argument interactively (with a prefix argument) and non-interactively.
-
-** 'describe-key-briefly' now ignores mouse movement events.
-
-** The new variable 'eval-expression-print-maximum-character' prevents
-large integers from being displayed as characters by 'M-:' and similar
-commands.
-
-** Two new commands for finding the source code of Emacs Lisp
-libraries: 'find-library-other-window' and 'find-library-other-frame'.
-
-** The new variable 'display-raw-bytes-as-hex' allows you to change
-the display of raw bytes from octal to hex.
-
-** You can now provide explicit field numbers in format specifiers.
-For example, '(format "%2$s %1$s %2$s" "X" "Y")' produces "Y X Y".
-
-** Emacs now supports optional display of line numbers in the buffer.
-This is similar to what 'linum-mode' provides, but much faster and
-doesn't usurp the display margin for the line numbers. Customize the
-buffer-local variable 'display-line-numbers' to activate this optional
-display. Alternatively, you can use the 'display-line-numbers-mode'
-minor mode or the global 'global-display-line-numbers-mode'. When
-using these modes, customize 'display-line-numbers-type' with the same
-value as you would use with 'display-line-numbers'.
+* Editing Changes in Emacs 27.1
-Line numbers are not displayed at all in minibuffer windows and in
-tooltips, as they are not useful there.
-
-Lisp programs can disable line-number display for a particular screen
-line by putting the 'display-line-numbers-disable' text property or
-overlay property on the first character of that screen line. This is
-intended for add-on packages that need a finer control of the display.
-
-Lisp programs that need to know how much screen estate is used up for
-line-number display in a window can use the new function
-'line-number-display-width'.
-
-'linum-mode' and all similar packages are henceforth becoming obsolete.
-Users and developers are encouraged to switch to this new feature
-instead.
-
-** The new user option 'arabic-shaper-ZWNJ-handling' controls how to
-handle ZWNJ in Arabic text rendering.
-
-
-* Editing Changes in Emacs 26.1
-
-** New variable 'column-number-indicator-zero-based'.
-Traditionally, in Column Number mode, the displayed column number
-counts from zero starting at the left margin of the window. This
-behavior is now controlled by 'column-number-indicator-zero-based'.
-If you would prefer for the displayed column number to count from one,
-you may set this variable to nil. (Behind the scenes, there is now a
-new mode line construct, '%C', which operates exactly as '%c' does
-except that it counts from one.)
-
-** New single-line horizontal scrolling mode.
-The 'auto-hscroll-mode' variable can now have a new special value,
-'current-line', which causes only the line where the cursor is
-displayed to be horizontally scrolled when lines are truncated on
-display and point moves outside the left or right window margin.
-
-** New mode line constructs '%o' and '%q', and user option
-'mode-line-percent-position'. '%o' displays the "degree of travel" of
-the window through the buffer. Unlike the default '%p', this
-percentage approaches 100% as the window approaches the end of the
-buffer. '%q' displays the percentage offsets of both the start and
-the end of the window, e.g. "5-17%". The new option
-'mode-line-percent-position' makes it easier to switch between '%p',
-'%P', and these new constructs.
-
-** Two new user options 'list-matching-lines-jump-to-current-line' and
-'list-matching-lines-current-line-face' to show the current line
-highlighted in *Occur* buffer.
-
-** The 'occur' command can now operate on the region.
-
-** New bindings for 'query-replace-map'.
-'undo', undo the last replacement; bound to 'u'.
-'undo-all', undo all replacements; bound to 'U'.
-
-** 'delete-trailing-whitespace' deletes whitespace after form feed.
-In modes where form feed was treated as a whitespace character,
-'delete-trailing-whitespace' would keep lines containing it unchanged.
-It now deletes whitespace after the last form feed thus behaving the
-same as in modes where the character is not whitespace.
-
-** Emacs no longer prompts about editing a changed file when the file's
-content is unchanged. Instead of only checking the modification time,
-Emacs now also checks the file's actual content before prompting the user.
-
-** Various casing improvements.
-
-*** 'upcase', 'upcase-region' et al. convert title case characters
-(such as Dz) into their upper case form (such as DZ).
-
-*** 'capitalize', 'upcase-initials' et al. make use of title-case forms
-of initial characters (correctly producing for example Džungla instead
-of incorrect DŽungla).
-
-*** Characters which turn into multiple ones when cased are correctly handled.
-For example, fi ligature is converted to FI when upper cased.
-
-*** Greek small sigma is correctly handled when at the end of the word.
-Strings such as ΌΣΟΣ are now correctly converted to Όσος when
-capitalized instead of incorrect Όσοσ (compare lowercase sigma at the
-end of the word).
-
-** Emacs can now auto-save buffers to visited files in a more robust
-manner via the new mode 'auto-save-visited-mode'. Unlike
-'auto-save-visited-file-name', this mode uses the normal saving
-procedure and therefore obeys saving hooks.
-'auto-save-visited-file-name' is now obsolete.
-
-** New behavior of 'mark-defun'.
-Prefix argument selects that many (or that many more) defuns.
-Negative prefix arg flips the direction of selection. Also,
-'mark-defun' between defuns correctly selects N following defuns (or
--N previous for negative arguments). Finally, comments preceding the
-defun are selected unless they are separated from the defun by a blank
-line.
-
-** New command 'replace-buffer-contents'.
-This command replaces the contents of the accessible portion of the
-current buffer with the contents of the accessible portion of a
-different buffer while keeping point, mark, markers, and text
-properties as intact as possible.
-
-** New commands 'apropos-local-variable' and 'apropos-local-value'.
-These are buffer-local versions of 'apropos-variable' and
-'apropos-value', respectively. They show buffer-local variables whose
-names and values, respectively, match a given pattern.
-
-** More user control of reordering bidirectional text for display.
-The two new variables, 'bidi-paragraph-start-re' and
-'bidi-paragraph-separate-re', allow customization of what exactly are
-paragraphs, for the purposes of bidirectional display.
++++
+** New command 'make-empty-file'.
+---
** New variable 'x-wait-for-event-timeout'.
This controls how long Emacs will wait for updates to the graphical
state to take effect (making a frame visible, for example).
++++
+** New user option 'electric-quote-replace-double'.
+This option controls whether '"' is replaced in 'electric-quote-mode',
+in addition to other quote characters. If non-nil, ASCII double-quote
+characters that quote text "like this" are replaced by double
+typographic quotes, “like this”, in text modes, and in comments in
+non-text modes.
+
+---
+** New user option 'flyspell-case-fold-duplications'.
+This option controls whether Flyspell mode considers consecutive words
+to be duplicates if they are not in the same case. If non-nil, the
+default, words are considered to be duplicates even if their letters'
+case does not match.
+
+---
+** 'write-abbrev-file' now includes special properties.
+'write-abbrev-file' now writes special properties like ':case-fixed'
+for abbrevs that have them.
+
++++
+** 'write-abbrev-file' skips empty tables.
+'write-abbrev-file' now skips inserting a 'define-abbrev-table' form for
+tables which do not have any non-system abbrevs to save.
+
++++
+** The new functions and commands 'text-property-search-forward' and
+'text-property-search-backward' have been added. These provide an
+interface that's more like functions like 'search-forward'.
+
+---
+** More commands support noncontiguous rectangular regions, namely
+'upcase-dwim', 'downcase-dwim', 'replace-string', 'replace-regexp'.
+
++++
+** When asked to visit a large file, Emacs now offers visiting it literally.
+Previously, Emacs would only ask for confirmation before visiting
+large files. Now it also offers a third alternative: to visit the
+file literally, as in 'find-file-literally', which speeds up
+navigation and editing of large files.
+
+---
+** 'add-dir-local-variable' now uses dotted pair notation syntax to
+write alists of variables to ".dir-locals.el". This is the same
+syntax that you can see in the example of a ".dir-locals.el" file in
+the node "(emacs) Directory Variables" of the user manual.
+
++++
+** Network connections using 'local can now use IPv6.
+'make-network-process' now uses the correct loopback address when
+asked to use :host 'local and :family 'ipv6.
+
++++
+** The new function `replace-region-contents' replaces the current
+region using a given replacement-function in a non-destructive manner
+(in terms of `replace-buffer-contents').
+
++++
+** The command `replace-buffer-contents' now has two optional
+arguments mitigating performance issues when operating on huge
+buffers.
+
+** The command 'delete-indentation' now operates on the active region.
+If the region is active, the command joins all the lines in the
+region. When there's no active region, the command works on the
+current and the previous or the next line, as before.
+
++++
-* Changes in Specialized Modes and Packages in Emacs 26.1
+* Changes in Specialized Modes and Packages in Emacs 27.1
+
+** compile.el
+---
+*** In compilation-error-regexp-alist, 'line' (and 'end-line') can be functions
+
+** cl-lib
++++
+*** cl-defstruct has a new :noinline argument to prevent inlining its functions
+
+** doc-view-mode
+*** New commands doc-view-presentation and doc-view-fit-window-to-page
+*** Added support for password-protected PDF files
+
+** map.el
+*** Now also understands plists.
+*** Now defined via generic functions that can be extended via 'cl-defmethod'.
+*** Deprecate the 'map-put' macro in favor of a new 'map-put!' function.
+*** 'map-contains-key' now returns a boolean rather than the key.
+*** Deprecate the 'testfn' args of 'map-elt' and 'map-contains-key'.
+*** New generic function 'map-insert'.
+
++++
+** seq.el
+New convenience functions 'seq-first' and 'seq-rest' give easy access
+to respectively the first and all but the first elements of sequences.
+
+The new predicate function 'seq-contains-p' should be used instead of
+the now obsolete 'seq-contains'.
+
+---
+** Follow mode
+In the current follow group of windows, "ghost" cursors are no longer
+displayed in the non-selected follow windows. To get the old behavior
+back, customize 'follow-hide-ghost-cursors' to nil.
+
+** Windmove
+
+*** 'windmove-create-window' when non-nil makes a new window on moving off
+the edge of the frame.
+
+*** Windmove supports directional window display and selection.
+The new command 'windmove-display-default-keybindings' binds default
+keys with provided modifiers (by default, Shift-Meta) to the commands
+that display the next buffer in the window at the specified direction.
+This is like 'windmove-default-keybindings' that binds keys to commands
+that select the window in the specified direction, but additionally it
+displays the buffer from the next command in that window. For example,
+'S-M-right C-h i' displays the *Info* buffer in the right window,
+creating the window if necessary. A special key can be customized to
+display the buffer in the same window, for example, 'S-M-0 C-h e'
+displays the *Messages* buffer in the same window.
+
+*** Windmove also supports directional window deletion.
+The new command 'windmove-delete-default-keybindings' binds default
+keys with provided prefix (by default, 'C-x') and modifiers (by default,
+'Shift') to the commands that delete the window in the specified
+direction. For example, 'C-x S-down' deletes the window below.
+With a prefix arg 'C-u', also kills the buffer in that window.
+With 'M-0', deletes the selected window and selects the window
+that was in the specified direction.
+
+*** New command 'windmove-swap-states-in-direction' binds default keys
+to the commands that swap the states of the selected window with the
+window in the specified direction.
+
+** Octave mode
+The mode is automatically enabled in files that start with the
+'function' keyword.
+
+** project.el
+*** New commands 'project-search' and 'project-query-replace-regexp'.
+
+** Etags
+
++++
+*** 'next-file' is now an obsolete alias of 'tags-next-file'.
+
+*** 'tags-loop-revert-buffers' is an obsolete alias of
+'fileloop-revert-buffers'.
+
+*** The 'tags-loop-continue' function along with the
+'tags-loop-operate' and 'tags-loop-scan' variables are now obsolete;
+use the new 'fileloop-initialize' and 'fileloop-continue' functions
+instead.
-** Emacs 26.1 comes with Org v9.1.6.
-See the file ORG-NEWS for user-visible changes in Org.
+** bibtex
-** New function 'cl-generic-p'.
+---
+*** New commands 'bibtex-next-entry' and 'bibtex-previous-entry'.
+In 'bibtex-mode-map', 'forward-paragraph' and 'backward-paragraph' are
+remapped to these, respectively.
** Dired
-*** You can answer 'all' in 'dired-do-delete' to delete recursively all
-remaining directories without more prompts.
++++
+*** New command 'dired-create-empty-file'.
+
+** Change Logs and VC
+
+*** Recording ChangeLog entries doesn't require an actual file.
+If a ChangeLog file doesn't exist, and if the new variable
+'add-log-dont-create-changelog-file' is non-nil (which is the
+default), commands such as 'C-x 4 a' will add log entries to a
+suitable named temporary buffer. (An existing ChangeLog file will
+still be used if it exists.) Set the variable to nil to get the
+previous behavior of always creating a buffer that visits a ChangeLog
+file.
+
+*** New customizable variable 'vc-find-revision-no-save'.
+With non-nil, 'vc-find-revision' doesn't write the created buffer to file.
+
+*** New customizable variable 'vc-git-grep-template'.
+This new variable allows customizing the default arguments passed to
+'git-grep' when 'vc-git-grep' is used.
+
+*** Command 'vc-git-stash' now respects marks in the '*vc-dir*' buffer.
+When some files are marked, only those are stashed.
+When no files are marked, all modified files are stashed, as before.
+
+*** The new hook 'vc-retrieve-tag-hook' runs after retrieving a tag.
+
+---
+*** 'vc-hg' now invokes 'smerge-mode' when visiting files.
+Code that attempted to invoke 'smerge-mode' when visiting an Hg file
+with conflicts existed in earlier versions of Emacs, but incorrectly
+never detected a conflict due to invalid assumptions about cached
+values.
+
++++
+*** 'C-u C-x v D' ('vc-root-version-diff') prompts for two revisions
+and compares their entire trees.
+
+*** New user option 'vc-hg-revert-switches' specifies switches to pass
+to hg revert.
+
+*** 'C-x v M D' ('vc-diff-mergebase') and 'C-x v M L' ('vc-log-mergebase')
+print diffs and logs between the merge base (common ancestor) of two
+given revisions.
+
+** Diff mode
++++
+*** Hunks are now automatically refined by font-lock.
+To disable refinement, set the new defcustom 'diff-refine' to nil.
+To get back the old behavior where hunks are refined as you navigate
+through a diff, set 'diff-refine' to the symbol 'navigate'.
++++
+*** 'diff-auto-refine-mode' is deprecated in favor of 'diff-refine'.
+It is no longer enabled by default and binding it no longer has any
+effect.
+
++++
+*** Better syntax highlighting of Diff hunks.
+Fragments of source in Diff hunks are now by default highlighted
+according to the appropriate major mode. Customize the new option
+'diff-font-lock-syntax' to nil to disable this.
+
+*** File headers can be shortened, mimicking Magit's diff format.
+To enable it, set the new defcustom 'diff-font-lock-prettify' to t.
+
++++
+*** Prefix arg of 'diff-goto-source' means jump to the old revision
+of the file under version control if point is on an old changed line,
+or to the new revision of the file otherwise.
+
+** Texinfo
+
++++
+*** New function for inserting @pxref, @xref, or @ref commands.
+The function 'texinfo-insert-dwim-@ref', bound to 'C-c C-c r' by
+default, inserts one of three types of references based on the text
+surrounding point, namely @pxref near a parenthesis, @xref at the
+start of a sentence or at (point-min), else @ref.
+
+** Browse-url
+
+*** The function 'browse-url-emacs' can now visit a URL in selected window.
+It now treats the optional 2nd argument to mean that the URL should be
+shown in the currently selected window.
-*** Dired supports wildcards in the directory part of the file names.
+** Comint
-*** You can now use '`?`' in 'dired-do-shell-command'.
-It gets replaced by the current file name, like ' ? '.
++++
+*** 'send-invisible' is now an obsolete alias for 'comint-send-invisible'.
+Also, 'shell-strip-ctrl-m' is declared obsolete.
+
++++
+*** 'C-c .' ('comint-insert-previous-argument') no longer interprets '&'.
+This feature caused problems when '&&' was present in the previous
+command. Since this command emulates 'M-.' in Bash and zsh, neither
+of which treats '&' specially, the feature was removed for
+compatibility with these shells.
+
++++
+*** 'comint-insert-previous-argument' can now count arguments from the end.
+By default, invoking 'C-c .' with a numeric argument N would copy the
+Nth argument, counting from the first one. But if the new option
+'comint-insert-previous-argument-from-end' is non-nil, it will copy
+the Nth argument counting from the last one. Thus 'C-c .' can now
+better emulate 'M-.' in both Bash and zsh, since the former counts
+from the beginning of the arguments, while the latter counts from the
+end.
+
+** SQL
+
+*** SQL Indent Minor Mode
+
+SQL Mode now supports the ELPA 'sql-indent' package for assisting
+sophisticated SQL indenting rules. Note, however, that SQL is not
+like other programming languages like C, Java, or Python where code is
+sparse and rules for formatting are fairly well established. Instead
+SQL is more like COBOL (from which it came) and code tends to be very
+dense and line ending decisions driven by syntax and line length
+considerations to make readable code. Experienced SQL developers may
+prefer to rely upon existing Emacs facilities for formatting code but
+the 'sql-indent' package provides facilities to aid more casual SQL
+developers layout queries and complex expressions.
+
+**** 'sql-use-indent-support' (default t) enables SQL indention support.
+The 'sql-indent' package from ELPA must be installed to get the
+indentation support in 'sql-mode' and 'sql-interactive-mode'.
+
+**** 'sql-mode-hook' and 'sql-interactive-mode-hook' changed.
+Both hook variables have had 'sql-indent-enable' added to their
+default values. If you have existing customizations to these variables,
+you should make sure that the new default entry is included.
+
+*** Connection Wallet
+
+Database passwords can now by stored in NETRC or JSON data files that
+may optionally be encrypted. When establishing an interactive session
+with the database via 'sql-connect' or a product specific function,
+like 'sql-mysql' or 'my-postgres', the password wallet will be
+searched for the password. The 'sql-product', 'sql-server',
+'sql-database', and the 'sql-username' will be used to identify the
+appropriate authorization. This eliminates the discouraged practice of
+embedding database passwords in your Emacs initialization.
+
+See the `auth-source' module for complete documentation on the file
+formats. By default, the wallet file is expected to be in the
+`user-emacs-directory', named 'sql-wallet' or '.sql-wallet', with
+'.json' (JSON) or no (NETRC) suffix. Both file formats can optionally
+be encrypted with GPG by adding an additional '.gpg' suffix.
-*** A new option 'dired-always-read-filesystem' defaulting to nil.
-If non-nil, buffers visiting files are reverted before they are
-searched; for instance, in 'dired-mark-files-containing-regexp' a
-non-nil value of this option means the file is revisited in a
-temporary buffer; this temporary buffer is the actual buffer searched:
-the original buffer visiting the file is not modified.
+** Term
-*** Users can now customize mouse clicks in Dired in a more flexible way.
-The new command 'dired-mouse-find-file' can be bound to a mouse click
-and used to visit files/directories in Dired in the selected window.
-The new command 'dired-mouse-find-file-other-frame' similarly visits
-files/directories in another frame. You can write your own commands
-that invoke 'dired-mouse-find-file' with non-default optional
-arguments, to tailor the effects of mouse clicks on file names in
-Dired buffers.
+---
+*** 'term-read-noecho' is now obsolete, use 'read-passwd' instead.
-*** In wdired, when editing files to contain slash characters,
-the resulting directories are automatically created. Whether to do
-this is controlled by the 'wdired-create-parent-directories' variable.
+** Flymake
-*** 'W' is now bound to 'browse-url-of-dired-file', and is useful for
-viewing HTML files and the like.
++++
+*** The variable 'flymake-diagnostic-types-alist' is obsolete.
+You should instead set properties on known diagnostic symbols, like
+':error' and ':warning', as demonstrated in the Flymake manual.
-*** New variable 'dired-clean-confirm-killing-deleted-buffers'
-controls whether Dired asks to kill buffers visiting deleted files and
-directories. The default is t, so Dired asks for confirmation, to
-keep previous behavior.
+*** New customizable variable 'flymake-start-on-save-buffer'.
+Control whether Flymake starts checking the buffer on save.
-** html2text is now marked obsolete.
+*** Flymake and backend functions may exchange hints about buffer changes.
+This enables more efficient backends. See the docstring of
+'flymake-diagnostic-functions' or the Flymake manual for details.
-** smerge-refine-regions can refine regions in separate buffers.
+** Ruby
-** Info menu and index completion uses substring completion by default.
-This can be customized via the 'info-menu' category in
-'completion-category-overrides'.
+*** The Rubocop Flymake diagnostic function will only run Lint cops if
+it can't find the config file.
-** The ancestor buffer is shown by default in 3-way merges.
-A new option 'ediff-show-ancestor' and a new toggle
-'ediff-toggle-show-ancestor'.
+*** Rubocop is called with 'bundle exec' if Gemfile mentions it.
-** TeX: Add luatex and xetex as alternatives to pdftex.
+** Package
-** Electric-Buffer-menu
+*** New function 'package-get-version' lets packages query their own version.
+Example use in auctex.el: '(defconst auctex-version (package-get-version))'
-*** Key 'U' is bound to 'Buffer-menu-unmark-all' and key 'M-DEL' is
-bound to 'Buffer-menu-unmark-all-buffers'.
+*** New 'package-quickstart' feature.
+When 'package-quickstart' is non-nil, package.el precomputes a big autoloads
+file so that activation of packages can be done much faster, which can speed up
+your startup significantly.
+It also causes variables like 'package-user-dir' and 'package-load-list' to be
+consulted when 'package-quickstart-refresh' is run rather than at startup so
+you don't need to set them in your early init file.
-** hideshow mode got four key bindings that are analogous to outline
-mode bindings: 'C-c @ C-a', 'C-c @ C-t', 'C-c @ C-d', and 'C-c @ C-e'.
+*** New function 'package-activate-all'.
-** bs
+** Info
-*** Two new commands 'bs-unmark-all', bound to 'U', and
-'bs-unmark-previous', bound to <backspace>.
+---
+*** Info can now follow 'file://' protocol URLs.
+The 'file://' URLs in Info documents can now be followed by passing
+them to the 'browse-url' function, like the other protocols: ftp,
+http, and https. This allows to have references to local HTML files,
+for example.
-** Buffer-menu
+** Xref
-*** Two new commands 'Buffer-menu-unmark-all', bound to 'U' and
-'Buffer-menu-unmark-all-buffers', bound to 'M-DEL'.
++++
+*** New command 'xref-find-definitions-at-mouse'.
+This command finds definitions of the identifier at the place of a
+mouse click event, and is intended to be bound to a mouse event.
-** Checkdoc
++++
+*** Changing 'xref-marker-ring-length' works after 'xref.el' is loaded.
+Previously, setting 'xref-marker-ring-length' would only take effect
+if set before 'xref.el' was loaded.
-*** 'checkdoc-arguments-in-order-flag' now defaults to nil.
+---
+*** xref-find-definitions now sets the mark at the buffer position
+where it was invoked
-** Gnus
+** Ecomplete
-*** The ~/.newsrc file will now only be saved if the native select
-method is an NNTP select method.
+*** The ecomplete sorting has changed to a decay-based algorithm.
+This can be controlled by the new 'ecomplete-sort-predicate' variable.
-*** A new command for sorting articles by readedness marks has been
-added: 'C-c C-s C-m C-m'.
+*** The 'ecompleterc' file is now placed in ~/.emacs.d/ecompleterc by default.
+Of course it will still find it if you have it in ~/.ecompleterc
-*** In 'message-citation-line-format' the '%Z' format is now the time
-zone name instead of the numeric form. The '%z' format continues to
-be the numeric form. The new behavior is compatible with
-'format-time-string'.
+** Gnus
-** Ibuffer
+---
+*** Gnus now maps imaps to 993 only on old MS-Windows versions.
+The nnimap backend used to do this unconditionally to work around
+problems on old versions of MS-Windows. This is now done only for
+Windows XP and older.
-*** New command 'ibuffer-jump'.
++++
+*** The nnimap backend now has support for IMAP namespaces.
+This feature can be enabled by setting the new 'nnimap-use-namespaces'
+server variable to non-nil.
-*** New filter commands 'ibuffer-filter-by-basename',
-'ibuffer-filter-by-file-extension', 'ibuffer-filter-by-directory',
-'ibuffer-filter-by-starred-name', 'ibuffer-filter-by-modified'
-and 'ibuffer-filter-by-visiting-file'; bound respectively
-to '/b', '/.', '//', '/*', '/i' and '/v'.
++++
+*** A prefix argument to 'gnus-summary-limit-to-score' will limit reverse.
+Limit to articles with score at below.
-*** Two new commands 'ibuffer-filter-chosen-by-completion'
-and 'ibuffer-and-filter', the second bound to '/&'.
+*** The function 'gnus-score-find-favorite-words' has been renamed
+from 'gnus-score-find-favourite-words'.
-*** The commands 'ibuffer-pop-filter', 'ibuffer-pop-filter-group',
-'ibuffer-or-filter' and 'ibuffer-filter-disable' have the alternative
-bindings '/<up>', '/S-<up>', '/|' and '/DEL', respectively.
+---
+*** Gmane has been removed as an nnir backend, since Gmane no longer
+has a search engine.
-*** The data format specifying filters has been extended to allow
-explicit logical 'and', and a more flexible form for logical 'not'.
-See 'ibuffer-filtering-qualifiers' doc string for full details.
++++
+*** Splitting mail on common mailing list headers has been added.
+See the concept index in the Gnus manual for the 'match-list' entry.
-*** A new command 'ibuffer-copy-buffername-as-kill'; bound
-to 'B'.
++++
+*** nil is no longer an allowed value for 'mm-text-html-renderer'.
-*** New command 'ibuffer-change-marks'; bound to '* c'.
++++
+*** A new Gnus summary mode command, 'S A'
+('gnus-summary-attach-article') can be used to attach the current
+article(s) to a pre-existing Message buffer, or create a new Message
+buffer with the article(s) attached.
-*** A new command 'ibuffer-mark-by-locked' to mark
-all locked buffers; bound to '% L'.
+---
+*** New option 'nnir-notmuch-filter-group-names-function'.
+This option controls whether and how to use Gnus search groups as
+'path:' search terms to 'notmuch'.
-*** A new option 'ibuffer-locked-char' to indicate
-locked buffers; Ibuffer shows a new column displaying
-'ibuffer-locked-char' for locked buffers.
+** erc
-*** A new command 'ibuffer-unmark-all-marks' to unmark
-all buffers without asking confirmation; bound to
-'U'; 'ibuffer-do-replace-regexp' bound to 'r'.
+---
+*** 'erc-button-google-url' has been renamed 'erc-button-search-url'
+and its value has been changed to Duck Duck Go.
-*** A new command 'ibuffer-mark-by-content-regexp' to mark buffers
-whose content matches a regexp; bound to '% g'.
+** EUDC
-*** Two new options 'ibuffer-never-search-content-name' and
-'ibuffer-never-search-content-mode' used by
-'ibuffer-mark-by-content-regexp'.
+*** XEmacs support has been removed.
-** Browse-URL
+** eww/shr
-*** Support for opening links to man pages in Man or WoMan mode.
++++
+*** The 'eww' command can now create a new EWW buffer.
+Invoking the command with a prefix argument will cause it to create a
+new EWW buffer for the URL instead of reusing the default one.
-** Comint
++++
+*** The 'd' ('eww-download') command now falls back to current page's URL.
+If this command is invoked with no URL at point, it now downloads the
+current page instead of signaling an error.
-*** New user option 'comint-move-point-for-matching-input' to control
-where to place point after 'C-c M-r' and 'C-c M-s'.
+*** When opening external links in eww/shr (typically with the
+'C-u RET' keystroke on a link), the link will be flashed with the new
+'shr-selected-link' face to give the user feedback that the command
+has been executed.
-*** New user option 'comint-terminfo-terminal'.
-This option allows control of the value of the TERM environment
-variable Emacs puts into the environment of the Comint mode and its
-derivatives, such as Shell mode and Compilation Shell minor-mode. The
-default is "dumb", for compatibility with previous behavior.
++++
+*** New option 'shr-discard-aria-hidden'.
+If set, shr will not render tags with attribute 'aria-hidden="true"'.
+This attribute is meant to tell screen readers to ignore a tag.
-** Compilation mode
+---
+*** 'shr-tag-ol' now respects the ordered list 'start' attribute.
-*** Messages from CMake are now recognized.
+** Htmlfontify
-*** The number of errors, warnings, and informational messages is now
-displayed in the mode line. These are updated as compilation
-proceeds.
+*** The functions 'hfy-color', 'hfy-color-vals' and
+'hfy-fallback-color-values' and the variables 'hfy-fallback-color-map'
+and 'hfy-rgb-txt-color-map' have been renamed from names that used
+'colour' instead of 'color'.
-** Grep
++++
+** Enriched mode supports the 'charset' text property.
+You can add or modify the 'charset' text properties of text using the
+'Edit->Text Properties->Special Properties' menu, or by invoking the
+'facemenu-set-charset' command. Documents in Enriched mode will be
+saved with the charset properties, and those properties will be
+restored when the file is visited.
-*** Grep commands will now use GNU grep's '--null' option if
-available, which allows distinguishing the filename from contents if
-they contain colons. This can be controlled by the new custom option
-'grep-use-null-filename-separator'.
+** Smtpmail
-*** The grep/rgrep/lgrep functions will now ask about saving files
-before running. This is controlled by the 'grep-save-buffers'
-variable.
+Authentication mechanisms can be added via external packages, by
+defining new 'cl-defmethod' of 'smtpmail-try-auth-method'.
-** Edebug
+** Footnote mode
-*** Edebug can be prevented from pausing 1 second after reaching a
-breakpoint (e.g. with "f" and "o") by customizing the new option
-'edebug-sit-on-break'.
+*** Support Hebrew-style footnotes
+*** Footnote text lines are now aligned.
+Can be controlled via the new variable 'footnote-align-to-fn-text'.
-*** New customizable option 'edebug-max-depth'.
-This allows you to enlarge the maximum recursion depth when
-instrumenting code.
+** CSS mode
-*** 'edebug-prin1-to-string' now aliases 'cl-prin1-to-string'.
-This means edebug output is affected by variables 'cl-print-readably'
-and 'cl-print-compiled'. To completely restore the previous printing
-behavior, use
+---
+*** A new command 'css-cycle-color-format' for cycling between color
+formats (e.g. "black" => "#000000" => "rgb(0, 0, 0)") has been added,
+bound to 'C-c C-f'.
- (fset 'edebug-prin1-to-string #'prin1-to-string)
+---
+*** CSS mode, SCSS mode, and Less CSS mode now have support for Imenu.
-** Eshell
+** SGML mode
-*** 'eshell-input-filter's value is now a named function
-'eshell-input-filter-default', and has a new custom option
-'eshell-input-filter-initial-space' to ignore adding commands prefixed
-with blank space to eshell history.
+---
+*** 'sgml-quote' now handles double quotes and apostrophes
+when escaping text and in addition all numeric entities when
+unescaping text.
-** EUDC
+** Python mode
-*** Backward compatibility support for BBDB versions less than 3
-(i.e., BBDB 2.x) is deprecated and will likely be removed in the next
-major release of Emacs. Users of BBDB 2.x should plan to upgrade to
-BBDB 3.x.
+---
+*** Python mode supports three different font lock decoration levels.
+The maximum level is used by default; customize
+'font-lock-maximum-decoration' to tone down the decoration.
-** eww
-
-*** New 'M-RET' command for opening a link at point in a new eww buffer.
-
-*** A new 's' command for switching to another eww buffer via the minibuffer.
+** Dired
-*** The 'o' command ('shr-save-contents') has moved to 'O' to avoid collision
-with the 'o' command from 'image-map'.
++++
+*** The new user option 'dired-create-destination-dirs' controls whether
+'dired-do-copy' and 'dired-rename-file' should create non-existent
+directories in the destination.
-*** A new command 'C' ('eww-toggle-colors') can be used to toggle
-whether to use the HTML-specified colors or not. The user can also
-customize the 'shr-use-colors' variable.
+** Help
-*** Images that are being loaded are now marked with gray
-"placeholder" images of the size specified by the HTML. They are then
-replaced by the real images asynchronously, which will also now
-respect width/height HTML specs (unless they specify widths/heights
-bigger than the current window).
+---
+*** Output format of 'C-h l' ('view-lossage') has changed.
+For convenience, 'view-lossage' now displays the last keystrokes
+and commands in the same format as the edit buffer of
+'edit-last-kbd-macro'. This makes it possible to copy the lines from
+the buffer generated by 'view-lossage' to the "*Edit Macro*" buffer
+created by 'edit-last-kbd-macro', and to save the macro by 'C-c C-c'.
-*** The 'w' command on links is now 'shr-maybe-probe-and-copy-url'.
-'shr-copy-url' now only copies the url at point; users who wish to
-avoid accidentally accessing remote links may rebind 'w' and 'u' in
-'eww-link-keymap' to it.
+---
+*** The list of help commands produced by 'C-h C-h' ('help-for-help')
+can now be searched via 'C-s'.
-** Ido
+** Ibuffer
-*** The commands 'find-alternate-file-other-window',
-'dired-other-window', 'dired-other-frame', and
-'display-buffer-other-window' are now remapped to Ido equivalents if
-Ido mode is active.
+---
+*** New filter 'ibuffer-filter-by-process'; bound to '/E'.
+
+---
+*** All mode filters can now accept a list of symbols.
+This means you can now easily filter several major modes, as well
+as a single mode.
+
+** Search and Replace
+
+*** Isearch supports a prefix argument for 'C-s' ('isearch-repeat-forward')
+and 'C-r' ('isearch-repeat-backward'). With a prefix argument, these
+commands repeat the search for the specified occurrence of the search string.
+A negative argument repeats the search in the opposite direction.
+This makes possible also to use a prefix argument for 'M-s .'
+('isearch-forward-symbol-at-point') to find the next Nth symbol.
+
+*** To go to the first/last occurrence of the current search string
+is possible now with new commands 'isearch-beginning-of-buffer' and
+'isearch-end-of-buffer' bound to 'M-s M-<' and 'M-s M->' in Isearch.
+With a numeric argument, they go to the Nth absolute occurrence
+counting from the beginning/end of the buffer. This complements
+'C-s'/'C-r' that searches for the next Nth relative occurrence
+with a numeric argument.
+
+*** 'isearch-lazy-count' shows the current match number and total number
+of matches in the Isearch prompt. Customizable variables
+'lazy-count-prefix-format' and 'lazy-count-suffix-format' define the
+format of the current and the total number of matches in the prompt's
+prefix and suffix respectively.
+
+*** 'lazy-highlight-buffer' highlights matches in the full buffer.
+It is useful in combination with 'lazy-highlight-cleanup' customized to nil
+to leave matches highlighted in the whole buffer after exiting isearch.
+Also when 'lazy-highlight-buffer' prepares highlighting in the buffer,
+navigation through the matches without flickering is more smooth.
+'lazy-highlight-buffer-max-at-a-time' controls the number of matches to
+highlight in one iteration while processing the full buffer.
+
++++
+*** New isearch bindings.
+
+'C-M-w' in isearch changed from 'isearch-del-char' to the new function
+'isearch-yank-symbol-or-char'. 'isearch-del-char' is now bound to
+'C-M-d'.
+
++++
+*** New variable 'isearch-yank-on-move' provides options 't' and 'shift'
+to extend the search string by yanking text that ends at the new
+position after moving point in the current buffer. 'shift' extends
+the search string by motion commands while holding down the shift key.
+
+*** 'isearch-allow-scroll' provides new option 'unlimited' to allow
+scrolling any distance off screen.
+
+---
+*** Isearch now remembers the regexp-based search mode for words/symbols
+and case-sensitivity together with search strings in the search ring.
+
+---
+*** Isearch now has its own tool-bar and menu-bar menu.
+
++++
+*** flush-lines prints and returns the number of deleted matching lines.
+
+** Debugger
+
++++
+*** The Lisp Debugger is now based on 'backtrace-mode'.
+Backtrace mode adds fontification and commands for changing the
+appearance of backtrace frames. See the node "(elisp) Backtraces" in
+the Elisp manual for documentation of the new mode and its commands.
-** Images
+** Edebug
-*** Images are automatically scaled before displaying based on the
-'image-scaling-factor' variable (if Emacs supports scaling the images
-in question).
++++
+*** The runtime behavior of Edebug's instrumentation can be changed
+using the new variables 'edebug-behavior-alist',
+'edebug-after-instrumentation-function' and
+'edebug-new-definition-function'. Edebug's behavior can be changed
+globally or for individual definitions.
-*** It's now possible to specify aspect-ratio preserving combinations
-of :width/:max-height and :height/:max-width keywords. In either
-case, the "max" keywords win. (Previously some combinations would,
-depending on the aspect ratio of the image, just be ignored and in
-other instances this would lead to the aspect ratio not being
-preserved.)
++++
+*** Edebug's backtrace buffer now uses 'backtrace-mode'.
+Backtrace mode adds fontification, links and commands for changing the
+appearance of backtrace frames. See the node "(elisp) Backtraces" in
+the Elisp manual for documentation of the new mode and its commands.
-*** Images inserted with 'insert-image' and related functions get a
-keymap put into the text properties (or overlays) that span the
-image. This keymap binds keystrokes for manipulating size and
-rotation, as well as saving the image to a file. These commands are
-also available in 'image-mode'.
+The binding of 'd' in Edebug's keymap is now 'edebug-pop-to-backtrace'
+which replaces 'edebug-backtrace'. Consequently Edebug's backtrace
+windows now behave like those of the Lisp Debugger and of ERT, in that
+when they appear they will be the selected window.
-*** A new library for creating and manipulating SVG images has been
-added. See the "(elisp) SVG Images" section in the ELisp reference
-manual for details.
+The new 'backtrace-goto-source' command, bound to 's', works in
+Edebug's backtraces on backtrace frames whose source code has
+been instrumented by Edebug.
-*** New setf-able function to access and set image parameters is
-provided: 'image-property'.
+** Enhanced xterm support
-*** New commands 'image-scroll-left' and 'image-scroll-right'
-for 'image-mode' that complement 'image-scroll-up' and
-'image-scroll-down': they have the same prefix arg behavior and stop
-at image boundaries.
+*** New variable 'xterm-set-window-title' controls whether Emacs sets
+the XTerm window title. This feature is experimental and is disabled
+by default.
-** Image-Dired
+** Grep
-*** Now provides a minor mode 'image-dired-minor-mode' which replaces
-the function 'image-dired-setup-dired-keybindings'.
++++
+*** rgrep, lgrep and zrgrep now hide part of the command line
+that contains a list of ignored directories and files.
+Clicking on the button with ellipsis unhides it.
+The abbreviation can be disabled by the new option
+'grep-find-abbreviate'. The new command
+'grep-find-toggle-abbreviation' toggles it interactively.
-*** Thumbnail generation is now asynchronous.
-The number of concurrent processes is limited by the variable
-'image-dired-queue-active-limit'.
+** ERT
-*** 'image-dired-thumbnail-storage' has a new option 'standard-large'
-for generating 256x256 thumbnails according to the Thumbnail Managing
-Standard.
++++
+*** New variable 'ert-quiet' allows to make ERT output in batch mode
+less verbose by removing non-essential information.
-*** Inherits movement keys from 'image-mode' for viewing full images.
-This includes the usual char, line, and page movement commands.
++++
+*** ERT's backtrace buffer now uses 'backtrace-mode'.
+Backtrace mode adds fontification and commands for changing the
+appearance of backtrace frames. See the node "(elisp) Backtraces" in
+the Elisp manual for documentation of the new mode and its commands.
-*** All the -options types have been changed to argument lists
-instead of shell command strings. This change affects
-'image-dired-cmd-create-thumbnail-options',
-'image-dired-cmd-create-temp-image-options',
-'image-dired-cmd-rotate-thumbnail-options',
-'image-dired-cmd-rotate-original-options',
-'image-dired-cmd-write-exif-data-options',
-'image-dired-cmd-read-exif-data-options', and introduces
-'image-dired-cmd-pngnq-options', 'image-dired-cmd-pngcrush-options',
-'image-dired-cmd-create-standard-thumbnail-options'.
+** Gamegrid
-*** Recognizes more tools by default, including pngnq-s9 and OptiPNG.
+---
+*** Gamegrid now determines its default glyph size based on display
+dimensions, instead of always using 16 pixels. As a result, Tetris,
+Snake and Pong are more playable on HiDPI displays.
-*** 'find-file' and related commands now work on thumbnails and
-displayed images, providing a default argument of the original file name
-via an addition to 'file-name-at-point-functions'.
+** Filecache
-** The default 'Info-default-directory-list' no longer checks some obsolete
-directory suffixes (gnu, gnu/lib, gnu/lib/emacs, emacs, lib, lib/emacs)
-when searching for info directories.
+---
+*** Completing filenames in the minibuffer via 'C-TAB' now uses the
+styles as configured by the variable 'completion-styles'.
-** The commands that add ChangeLog entries now prefer a VCS root directory
-for the ChangeLog file, if none already exists. Customize
-'change-log-directory-files' to nil for the old behavior.
+** New macros 'thunk-let' and 'thunk-let*'.
+These macros are analogue to 'let' and 'let*', but create bindings that
+are evaluated lazily.
-** Support for non-string values of 'time-stamp-format' has been removed.
+** next-error
-** Message
++++
+*** New customizable variable 'next-error-find-buffer-function'.
+The value should be a function that determines how to find the
+next buffer to be used by 'next-error' and 'previous-error'. The
+default is to use the last buffer that navigated to the current
+error.
-*** 'message-use-idna' now defaults to t (because Emacs comes with
-built-in IDNA support now).
++++
+*** New command 'next-error-select-buffer'.
+It can be used to set any buffer as the next one to be used by
+'next-error' and 'previous-error'.
-*** When sending HTML messages with embedded images, and you have
-exiftool installed, and you rotate images with EXIF data (i.e.,
-JPEGs), the rotational information will be inserted into the outgoing
-image in the message. (The original image will not have its
-orientation affected.)
+** nxml-mode
-*** The 'message-valid-fqdn-regexp' variable has been removed, since
-there are now top-level domains added all the time. Message will no
-longer warn about sending emails to top-level domains it hasn't heard
-about.
+---
+*** The default value of 'nxml-sexp-element-flag' is now t.
+This means that pressing 'C-M-SPACE' now selects the entire tree by
+default, and not just the opening element.
-*** 'message-beginning-of-line' (bound to 'C-a') understands folded headers.
-In 'visual-line-mode' it will look for the true beginning of a header
-while in non-'visual-line-mode' it will move the point to the indented
-header's value.
+** Eshell
-** Package
+*** TAB completion uses the standard completion-at-point rather than pcomplete
+Its UI is slightly different but can be customized to behave similarly,
+e.g. Pcomplete's default cycling can be obtained with
+(setq completion-cycle-threshold 5).
-*** The new variable 'package-gnupghome-dir' has been added to control
-where the GnuPG home directory (used for signature verification) is
-located and whether GnuPG's option '--homedir' is used or not.
+---
+*** Expansion of history event designators is disabled by default.
+To restore the old behavior, use
-*** Deleting a package no longer respects 'delete-by-moving-to-trash'.
+ (add-hook 'eshell-expand-input-functions
+ #'eshell-expand-history-references)
-** Python
+---
+*** The function 'eshell-uniquify-list' has been renamed from
+'eshell-uniqify-list'.
-*** The new variable 'python-indent-def-block-scale' has been added.
-It controls the depth of indentation of arguments inside multi-line
-function signatures.
+*** The function 'eshell/kill' is now able to handle signal switches.
+Previously 'eshell/kill' would fail if provided a kill signal to send
+to the process. It now accepts signals specified either by name or by
+its number.
-** Tramp
+---
+*** Emacs now follows symlinks in history-related files.
+The files specified by 'eshell-history-file-name' and
+'eshell-last-dir-ring-file-name' can include symlinks; these are now
+followed when Emacs writes the relevant history variables to the disk.
-*** The method part of remote file names is mandatory now.
-A valid remote file name starts with "/method:host:" or
-"/method:user@host:".
+** Shell
-*** The new pseudo method "-" is a marker for the default method.
-"/-::" is the shortest remote file name then.
+---
+*** Program name completion inside remote shells works now as expected.
-*** The command 'tramp-change-syntax' allows you to choose an
-alternative remote file name syntax.
++++
+*** The variable 'shell-file-name' can be set now as connection-local
+variable for remote shells. It still defaults to "/bin/sh".
-*** New connection method "sg", which supports editing files under a
-different group ID.
+** Pcomplete
-*** New connection method "doas" for OpenBSD hosts.
+*** The function 'pcomplete-uniquify-list' has been renamed from
+'pcomplete-uniqify-list'.
-*** New connection method "gdrive", which allows access to Google
-Drive onsite repositories.
+** Auth-source
-*** Gateway methods in Tramp have been removed.
-Instead, the Tramp manual documents how to configure ssh and PuTTY
-accordingly.
+---
+*** The Secret Service backend supports the ':create' key now.
-*** Setting the "ENV" environment variable in
-'tramp-remote-process-environment' enables reading of shell
-initialization files.
+** Tramp
-*** Tramp is able now to send SIGINT to remote asynchronous processes.
++++
+*** New connection method "nextcloud", which allows to access OwnCloud
+or NextCloud hosted files and directories.
-*** Variable 'tramp-completion-mode' is obsoleted.
++++
+*** New connection method "rclone", which allows to access system
+storages via the 'rclone' program. This feature is experimental.
-** 'auto-revert-use-notify' is set back to t in 'global-auto-revert-mode'.
++++
+*** New connection method "sudoedit", which allows to edit local files
+with different user credentials. Contrary to the "sudo" method, no
+session is run permanently in the background. This is for security
+reasons.
-** JS mode
++++
+*** Connection methods "obex" and "synce" are removed, because they
+are obsoleted in GVFS.
-*** JS mode now sets 'comment-multi-line' to t.
++++
+*** Validated passwords are saved by auth-source backends which support this.
-*** New variable 'js-indent-align-list-continuation', when set to nil,
-will not align continuations of bracketed lists, but will indent them
-by the fixed width 'js-indent-level'.
++++
+*** During user and host name completion in the minibuffer, results
+from auth-source search are taken into account. This can be disabled
+by setting the user option 'tramp-completion-use-auth-sources' to nil.
-** CSS mode
++++
+*** The user option 'tramp-ignored-file-name-regexp' allows to disable
+Tramp for some look-alike remote file names.
-*** Support for completing attribute values, at-rules, bang-rules,
-HTML tags, classes and IDs using the 'completion-at-point' command.
-Completion candidates for HTML classes and IDs are retrieved from open
-HTML mode buffers.
++++
+*** For some connection methods, like "su" or "sudo", the host name in
+ad-hoc multi-hop file names must match the previous hop. Default host
+names are adjusted to the host name from the previous hop.
-*** CSS mode now binds 'C-h S' to a function that will show
-information about a CSS construct (an at-rule, property, pseudo-class,
-pseudo-element, with the default being guessed from context). By
-default the information is looked up on the Mozilla Developer Network,
-but this can be customized using 'css-lookup-url-format'.
++++
+*** For the connection methods "sudo" and "doas" there exists a
+timeout, after which the underlying session is disabled. This is for
+security reasons.
-*** CSS colors are fontified using the color they represent as the
-background. For instance, #ff0000 would be fontified with a red
-background.
+** Rcirc
-** Emacs now supports character name escape sequences in character and
-string literals. The syntax variants '\N{character name}' and
-'\N{U+code}' are supported.
+---
+*** New user option 'rcirc-url-max-length'.
+Setting this option to an integer causes URLs displayed in Rcirc
+buffers to be truncated to that many characters.
-** Prog mode has some support for multi-mode indentation.
-This allows better indentation support in modes that support multiple
-programming languages in the same buffer, like literate programming
-environments or ANTLR programs with embedded Python code.
+** Register
+---
+*** The return value of method 'register-val-describe' includes the
+names of buffers shown by the windows of a window configuration.
-A major mode can provide indentation context for a sub-mode. To
-support this, modes should use 'prog-first-column' instead of a
-literal zero and avoid calling 'widen' in their indentation functions.
-See the node "(elisp) Mode-Specific Indent" in the ELisp manual for
-more details.
+---
+** The options.el library has been removed.
+It was obsolete since Emacs 22.1, replaced by customize.
-** ERC
+** The tls.el and starttls.el libraries are now marked obsolete.
+Use of built-in libgnutls based functionality (described in the Emacs
+GnuTLS manual) is recommended instead.
-*** New variable 'erc-default-port-tls' used to connect to TLS IRC
-servers.
+** Message
-** URL
++++
+*** Messages can now be systematically encrypted
+when the PGP keyring contains a public key for every recipient. To
+achieve this, add 'message-sign-encrypt-if-all-keys-available' to
+'message-send-hook'.
-*** The new function 'url-cookie-delete-cookie' can be used to
-programmatically delete all cookies, or cookies from a specific
-domain.
+---
+*** When replying a message that have addresses on the form
+'"foo@bar.com" <foo@bar.com>', Message will elide the repeated "name"
+from the address field in the response.
-*** 'url-retrieve-synchronously' now takes an optional timeout parameter.
+---
+*** The default of 'message-forward-as-mime' has changed from t to nil
+as it has been reported that many recipients can't read forwards that
+are formatted as MIME digests.
-*** The URL package now supports HTTPS over proxies supporting CONNECT.
++++
+*** 'message-forward-included-headers' has changed its default to
+exclude most headers when forwarding.
+
+** EasyPG
-*** 'url-user-agent' now defaults to 'default', and the User-Agent
-string is computed dynamically based on 'url-privacy-level'.
+---
+*** 'epa-pinentry-mode' is renamed to 'epg-pinentry-mode'.
+It now applies to epg functions as well as epa functions.
-** VC and related modes
+---
+*** The alias functions 'epa--encode-coding-string',
+'epa--decode-coding-string', and 'epa--select-safe-coding-system' have
+been removed. Use 'encode-coding-string', 'decode-coding-string', and
+'select-safe-coding-system' instead.
-*** 'vc-dir-mode' now binds 'vc-log-outgoing' to 'O'; and has various
-branch-related commands on a keymap bound to 'B'.
+** Rmail
-*** 'vc-region-history' is now bound to 'C-x v h', replacing the older
-'vc-insert-headers' binding.
++++
+*** New user option 'rmail-output-reset-deleted-flag'.
+If this option is non-nil, messages appended to an output file by the
+'rmail-output' command have their Deleted flag reset.
-*** New user option 'vc-git-print-log-follow' to follow renames in Git logs
-for a single file.
+*** The command 'rmail-summary-by-senders' with an empty argument
+selects the messages to summarize with a regexp that matches the
+sender of the current message.
-** CC mode
+** Threads
-*** Opening a .h file will turn C or C++ mode depending on language used.
-This is done with the help of the 'c-or-c++-mode' function, which
-analyzes buffer contents to infer whether it's a C or C++ source file.
++++
+*** New variable 'main-thread' holds Emacs's main thread.
+This is handy in Lisp programs that run on a non-main thread and want
+to signal the main thread, e.g., when they encounter an error.
-** New option 'cpp-message-min-time-interval' to allow user control
-of progress messages in cpp.el.
++++
+*** 'thread-join' returns the result of the finished thread now.
-** New DNS mode command 'dns-mode-ipv6-to-nibbles' to convert IPv6 addresses
-to a format suitable for reverse lookup zone files.
++++
+*** 'thread-signal' does not propagate errors to the main thread.
+Instead, error messages are just printed in the main thread.
-** Ispell
+---
+*** 'thread-alive-p' is now obsolete, use 'thread-live-p' instead.
-*** Enchant is now supported as a spell-checker.
-Enchant is a meta-spell-checker that uses providers such as Hunspell
-to do the actual checking. With it, users can use spell-checkers not
-directly supported by Emacs, such as Voikko, Hspell and AppleSpell,
-more easily share personal word-lists with other programs, and
-configure different spelling-checkers for different languages.
-(Version 2.1.0 or later of Enchant is required.)
++++
+*** New command 'list-threads' shows Lisp threads.
+See the current list of live threads in a tabulated-list buffer which
+automatically updates. In the buffer, you can use 's q' or 's e' to
+signal a thread with quit or error respectively, or get a snapshot
+backtrace with 'b'.
-** Flymake
+---
+** thingatpt.el supports a new "thing" called 'uuid'.
+A symbol 'uuid' can be passed to 'thing-at-point' and it returns the
+UUID at point.
-*** Flymake has been completely redesigned.
-Flymake now annotates arbitrary buffer regions, not just lines. It
-supports arbitrary diagnostic types, not just errors and warnings (see
-variable 'flymake-diagnostic-types-alist').
+** Interactive automatic highlighting
-It also supports multiple simultaneous backends, meaning that you can
-check your buffer from different perspectives (see variable
-'flymake-diagnostic-functions'). Backends for Emacs Lisp mode are
-provided.
++++
+*** 'highlight-regexp' can now highlight subexpressions.
+The new command accepts a prefix numeric argument to choose the
+subexpression.
-The old Flymake behavior is preserved in the so-called "legacy
-backend", which has been updated to benefit from the new UI features.
+** Mouse display of minor mode menu
-** Term
+---
+*** 'minor-mode-menu-from-indicator' now displays full minor mode name.
+When there is no menu for a mode, display the mode name after the
+indicator instead of just the indicator (which is sometimes cryptic).
-*** 'term-char-mode' now makes its buffer read-only.
-The buffer is made read-only to prevent changes from being made by
-anything other than the process filter; and movements of point away
-from the process mark are counter-acted so that the cursor is in the
-correct position after each command. This is needed to avoid states
-which are inconsistent with the state of the terminal understood by
-the inferior process.
+** rx
-New user options 'term-char-mode-buffer-read-only' and
-'term-char-mode-point-at-process-mark' control these behaviors, and
-are non-nil by default. Customize these options to nil if you want
-the previous behavior.
+---
+*** rx now handles raw bytes in character alternatives correctly,
+when given in a string. Previously, '(any "\x80-\xff")' would match
+characters U+0080...U+00FF. Now the expression matches raw bytes in
+the 128...255 range, as expected.
-** Xref
+** Frames
-*** When an *xref* buffer is needed, 'TAB' quits and jumps to an xref.
-A new command 'xref-quit-and-goto-xref', bound to 'TAB' in *xref*
-buffers, quits the window before jumping to the destination. In many
-situations, the intended window configuration is restored, just as if
-the *xref* buffer hadn't been necessary in the first place.
++++
+*** New command 'make-frame-on-monitor' makes a frame on the specified monitor.
-
-* New Modes and Packages in Emacs 26.1
++++
+*** New value of 'minibuffer' frame parameter 'child-frame'.
+This allows to create and parent immediately a minibuffer-only child
+frame when making a frame.
-** New Elisp data-structure library 'radix-tree'.
+---
+*** New predicates 'display-blink-cursor-p' and 'display-symbol-keys-p'.
+These predicates are to be preferred over 'display-graphic-p' when
+testing for blinking cursor capability and the capability to have
+symbols (e.g., [return], [tab], [backspace]) as keys respectively.
-** New library 'xdg' with utilities for some XDG standards and specs.
+** Tabulated List mode
-** HTML
++++
+*** New user options for tabulated list sort indicators.
+You can now customize which sorting indicator character to display
+near the current column in Tabulated Lists (see variables
+'tabulated-list-gui-sort-indicator-asc',
+'tabulated-list-gui-sort-indicator-desc',
+'tabulated-list-tty-sort-indicator-asc', and
+'tabulated-list-tty-sort-indicator-desc').
-*** A new submode of 'html-mode', 'mhtml-mode', is now the default
-mode for *.html files. This mode handles indentation,
-fontification, and commenting for embedded JavaScript and CSS.
+** Text mode
-** New mode 'conf-toml-mode' is a sub-mode of 'conf-mode', specialized
-for editing TOML files.
++++
+*** 'text-mode-variant' is now obsolete, use 'derived-mode-p' instead.
-** New mode 'conf-desktop-mode' is a sub-mode of 'conf-unix-mode',
-specialized for editing freedesktop.org desktop entries.
+** CUA mode
-** New minor mode 'pixel-scroll-mode' provides smooth pixel-level scrolling.
+---
+*** New defcustom 'cua-rectangle-terminal-modifier-key'.
+This defcustom allows for the customization of the modifier key used
+in a terminal frame.
-** New major mode 'less-css-mode' (a minor variant of 'css-mode') for
-editing Less files.
+** JS mode
-** New package 'auth-source-pass' integrates 'auth-source' with the
-password manager password-store (http://passwordstore.org).
+---
+*** JSX syntax is now automatically detected and enabled.
+If a file imports Facebook's 'React' library, or if the file uses the
+extension '.jsx', then various features supporting XML-like syntax
+will be supported in 'js-mode' and derivative modes. ('js-jsx-mode'
+no longer needs to be enabled.)
+
+---
+*** New defcustom 'js-jsx-detect-syntax' disables automatic detection.
+This is turned on by default.
+
+---
+*** New defcustom 'js-jsx-syntax' enables JSX syntax unconditionally.
+This is off by default.
+
+---
+*** New variable 'js-jsx-regexps' controls JSX detection.
+
+---
+*** JSX syntax is now highlighted like SGML.
+
+---
+*** JSX code is properly indented in many more scenarios.
+Previously, JSX indentation usually only worked when an element was
+wrapped in parenthesis (e.g. in a 'return' statement or a function
+call). It would also fail in many intricate cases. Now, indentation
+should work anywhere without parenthesis; many more intricacies are
+supported; and, indentation conventions align more closely with those
+of the React developer community (see 'js-jsx-align->-with-<'),
+otherwise still adhering to SGML conventions.
+
+---
+*** New defcustom 'js-jsx-align->-with-<' controls '>' indents.
+Commonly in JSX code, a '>' on its own line is indented at the same
+level as its opening '<'. This is the new default for JSX. This
+behavior is slightly different than that used by SGML in Emacs, where
+'>' is indented at the same level as attributes, which was also the
+old default for JSX.
+
+This is turned on by default. To get back the old default indentation
+behavior of aligning '>' with attributes, set 'js-jsx-align->-with-<'
+to nil.
+
+---
+*** Indentation uses 'js-indent-level' instead of 'sgml-basic-offset'.
+Since JSX is a syntax extension of JavaScript, it makes the most sense
+for JSX expressions to be indented the same number of spaces as other
+JS expressions. This is a breaking change, but it probably aligns
+with how you'd expect this indentation to behave. If you want JSX to
+be indented like JS, you won't need to change your config.
+
+The old behavior can be emulated by controlling JSX indentation
+independently of JS, by setting 'js-jsx-indent-level'.
+
+---
+*** New defcustom 'js-jsx-indent-level' for different JSX indentation.
+If you wish to indent JSX by a different number of spaces than JS, set
+this variable to the desired number.
+
+---
+*** New defcustom 'js-jsx-attribute-offset' for JSX attribute indents.
+
+---
+*** New variable 'js-syntactic-mode-name' controls mode name display.
+Previously, the mode name was simply 'JavaScript'. Now, when a syntax
+extension like JSX is enabled, the mode name is 'JavaScript[JSX]'.
+Set this variable to nil to disable the new behavior.
+
+---
+*** New function 'js-use-syntactic-mode-name' for deriving modes.
+Packages deriving from 'js-mode' with 'define-derived-mode' should
+call this function to add enabled syntax extensions to their mode
+name, too.
-* Incompatible Lisp Changes in Emacs 26.1
-
-** 'password-data' is now a hash-table so that 'password-read' can use
-any object for the 'key' argument.
-
-** Command 'dired-mark-extension' now automatically prepends a '.' to the
-extension when not present. The new command 'dired-mark-suffix' behaves
-similarly but it doesn't prepend a '.'.
-
-** Certain cond/pcase/cl-case forms are now compiled using a faster jump
-table implementation. This uses a new bytecode op 'switch', which
-isn't compatible with previous Emacs versions. This functionality can
-be disabled by setting 'byte-compile-cond-use-jump-table' to nil.
-
-** If 'comment-auto-fill-only-comments' is non-nil, 'auto-fill-function'
-is now called only if either no comment syntax is defined for the
-current buffer or the self-insertion takes place within a comment.
-
-** The alist 'ucs-names' is now a hash table.
-
-** 'if-let' and 'when-let' now support binding lists as defined by the
-SRFI-2 (Scheme Request for Implementation 2).
-
-** 'C-up', 'C-down', 'C-left' and 'C-right' are now defined in term
-mode to send the same escape sequences that xterm does. This makes
-things like 'forward-word' in readline work.
-
-** Customizable variable 'query-replace-from-to-separator'
-now doesn't propertize the string value of the separator.
-Instead, text properties are added by 'query-replace-read-from'.
-Additionally, the new nil value restores pre-24.5 behavior
-of not providing replacement pairs via the history.
-
-** Some obsolete functions, variables, and faces have been removed:
-
-*** 'make-variable-frame-local'. Variables cannot be frame-local any more.
-
-*** From subr.el: 'window-dot', 'set-window-dot', 'read-input',
-'show-buffer', 'eval-current-buffer', 'string-to-int'.
-
-*** 'icomplete-prospects-length'.
-
-*** All the default-FOO variables that hold the default value of the
-FOO variable. Use 'default-value' and 'setq-default' to access and
-change FOO, respectively. The exhaustive list of removed variables is:
-'default-mode-line-format', 'default-header-line-format',
-'default-line-spacing', 'default-abbrev-mode', 'default-ctl-arrow',
-'default-truncate-lines', 'default-left-margin', 'default-tab-width',
-'default-case-fold-search', 'default-left-margin-width',
-'default-right-margin-width', 'default-left-fringe-width',
-'default-right-fringe-width', 'default-fringes-outside-margins',
-'default-scroll-bar-width', 'default-vertical-scroll-bar',
-'default-indicate-empty-lines', 'default-indicate-buffer-boundaries',
-'default-fringe-indicator-alist', 'default-fringe-cursor-alist',
-'default-scroll-up-aggressively', 'default-scroll-down-aggressively',
-'default-fill-column', 'default-cursor-type',
-'default-cursor-in-non-selected-windows',
-'default-buffer-file-coding-system', 'default-major-mode', and
-'default-enable-multibyte-characters'.
-
-*** Many variables obsoleted in 22.1 referring to face symbols.
-
-** The variable 'text-quoting-style' is now a customizable option.
-It controls whether to and how to translate ASCII quotes in messages
-and help output. Its possible values and their semantics remain
-unchanged from Emacs 25. In particular, when this variable's value is
-'grave', all quotes in formats are output as-is.
-
-** Functions like 'check-declare-file' and 'check-declare-directory'
-now generate less chatter and more-compact diagnostics. The auxiliary
-function 'check-declare-errmsg' has been removed.
-
-** The regular expression character class '[:blank:]' now matches
-Unicode horizontal whitespace as defined in the Unicode Technical
-Standard #18. If you only want to match space and tab, use '[ \t]'
-instead.
-
-** 'min' and 'max' no longer round their results.
-Formerly, they returned a floating-point value if any argument was
-floating-point, which was sometimes numerically incorrect. For
-example, on a 64-bit host (max 1e16 10000000000000001) now returns its
-second argument instead of its first.
-
-** The variable 'old-style-backquotes' has been made internal and
-renamed to 'lread--old-style-backquotes'. No user code should use
-this variable.
-
-** 'default-file-name-coding-system' now defaults to a coding system
-that does not process CRLF. For example, it defaults to 'utf-8-unix'
-instead of to 'utf-8'. Before this change, Emacs would sometimes
-mishandle file names containing these control characters.
-
-** 'file-attributes', 'file-symlink-p' and 'make-symbolic-link' no
-longer quietly mutate the target of a local symbolic link, so that
-Emacs can access and copy them reliably regardless of their contents.
-The following changes are involved.
-
-*** 'file-attributes' and 'file-symlink-p' no longer prepend "/:" to
-symbolic links whose targets begin with "/" and contain ":". For
-example, if a symbolic link "x" has a target "/y:z:", '(file-symlink-p
-"x")' now returns "/y:z:" rather than "/:/y:z:".
-
-*** 'make-symbolic-link' no longer looks for file name handlers of
-target when creating a symbolic link. For example,
-'(make-symbolic-link "/y:z:" "x")' now creates a symbolic link to
-"/y:z:" instead of failing.
-
-*** 'make-symbolic-link' removes the remote part of a link target if
-target and newname have the same remote part. For example,
-'(make-symbolic-link "/x:y:a" "/x:y:b")' creates a link with the
-literal string "a"; and '(make-symbolic-link "/x:y:a" "/x:z:b")'
-creates a link with the literal string "/x:y:a" instead of failing.
-
-*** 'make-symbolic-link' now expands a link target with leading "~"
-only when the optional third arg is an integer, as when invoked
-interactively. For example, '(make-symbolic-link "~y" "x")' now
-creates a link with target the literal string "~y"; to get the old
-behavior, use '(make-symbolic-link (expand-file-name "~y") "x")'. To
-avoid this expansion in interactive use, you can now prefix the link
-target with "/:". For example, '(make-symbolic-link "/:~y" "x" 1)'
-now creates a link to literal "~y".
-
-** 'file-truename' returns a quoted file name if the target of a
-symbolic link has remote file name syntax.
-
-** Module functions are now implemented slightly differently; in
-particular, the function 'internal--module-call' has been removed.
-Code that depends on undocumented internals of the module system might
-break.
-
-** The argument LOCKNAME of 'write-region' is propagated to file name
-handlers now.
-
-** When built against recent versions of GTK+, Emacs always uses
-gtk_window_move for moving frames and ignores the value of the
-variable 'x-gtk-use-window-move'. The variable is now obsolete.
-
-** Several functions that create or rename files now treat their
-destination argument specially only when it is a directory name, i.e.,
-when it ends in '/' on GNU and other POSIX-like systems. When the
-destination argument D of one of these functions is an existing
-directory and the intent is to act on an entry in that directory, D
-should now be a directory name. For example, (rename-file "e" "f/")
-renames to 'f/e'. Although this formerly happened sometimes even when
-D was not a directory name, as in (rename-file "e" "f") where 'f'
-happened to be a directory, the old behavior often contradicted the
-documentation and had inherent races that led to security holes. A
-call like (rename-file C D) that used the old, undocumented behavior
-can be written as (rename-file C (file-name-as-directory D)), a
-formulation portable to both older and newer versions of Emacs.
-Affected functions include 'add-name-to-file', 'copy-directory',
-'copy-file', 'format-write-file', 'gnus-copy-file',
-'make-symbolic-link', 'rename-file', 'thumbs-rename-images', and
-'write-file'.
-
-** The list returned by 'overlays-at' is now in decreasing priority order.
-The documentation of this function always said the order should be
-that of decreasing priority, if the 2nd argument of the function is
-non-nil, but the code returned the list in the increasing order of
-priority instead. Now the code does what the documentation says it
-should do.
-
-** 'format' now avoids allocating a new string in more cases.
-'format' was previously documented to return a newly-allocated string,
-but this documentation was not correct, as (eq x (format x)) returned
-t when x was the empty string. 'format' is no longer documented to
-return a newly-allocated string, and the implementation now takes
-advantage of the doc change to avoid making copies of strings in
-common cases like (format "foo") and (format "%s" "foo").
+* New Modes and Packages in Emacs 27.1
+
+** fileloop.el lets one setup multifile operations like search&replace.
+
++++
+** Emacs can now visit files in archives as if they were directories.
+This feature uses Tramp and works only on systems which support GVFS,
+i.e. GNU/Linux, roughly spoken. See the node "(tramp) Archive file
+names" in the Tramp manual for full documentation of these facilities.
+
++++
+** New library for writing JSONRPC applications (https://jsonrpc.org).
+The 'jsonrpc' library enables writing Emacs Lisp applications that
+rely on this protocol. Since the protocol is designed to be
+transport-agnostic, the library provides an API to implement new
+transport strategies as well as a separate API to use them. A
+transport implementation for process-based communication, such as is
+used by the Language Server Protocol (LSP), is readily available.
+
++++
+** Backtrace mode improves viewing of Elisp backtraces.
+Backtrace mode adds pretty printing, fontification and ellipsis
+expansion to backtrace buffers produced by the Lisp debugger, Edebug
+and ERT. See the node "(elisp) Backtraces" in the Elisp manual for
+documentation of the new mode and its commands.
+
+* Incompatible Lisp Changes in Emacs 27.1
+
+** In compilation-error-regexp-alist the old undocumented feature where 'line'
+could be a function of 2 arguments has been dropped.
+
+** 'define-fringe-bitmap' is always defined, even when Emacs is built
+without any GUI support.
+
+---
+** Just loading a theme's file no longer activates the theme's settings.
+Loading a theme with 'M-x load-theme' still activates the theme, as it
+did before. However, loading the theme's file with 'M-x load-file',
+or using 'require' or 'load' in a Lisp program, doesn't actually apply
+the theme's settings until you either invoke 'M-x enable-theme' or
+type 'M-x load-theme'. (In a Lisp program, calling 'enable-theme' or
+invoking 'load-theme' with NO-ENABLE argument omitted or nil has the
+same effect of activating a theme whose file has been loaded.) The
+special case of the 'user' theme is an exception: it is frequently
+used for ad-hoc customizations, so the settings of that theme are by
+default applied immediately.
+
+The variable 'custom--inhibit-theme-enable' controls this behavior;
+its default value changed in Emacs 27.1.
+
+** The REPETITIONS argument of 'benchmark-run' can now also be a variable.
+
+** Interpretation of relative HOME directory has changed.
+If $HOME is set to a relative file name, 'expand-file-name' now
+interprets it relative to the directory where Emacs was started, not
+relative to the 'default-directory' of the current buffer. We recommend
+always setting $HOME to an absolute file name, so that its meaning is
+independent of where Emacs was started.
+
+** The FILENAME argument to 'file-name-base' is now mandatory and no
+longer defaults to 'buffer-file-name'.
+
+---
** The function 'eldoc-message' now accepts a single argument.
Programs that called it with multiple arguments before should pass
them through 'format' first. Even that is discouraged: for ElDoc
support, you should set 'eldoc-documentation-function' instead of
calling 'eldoc-message' directly.
-** Using '&rest' or '&optional' incorrectly is now an error.
-For example giving '&optional' without a following variable, or
-passing '&optional' multiple times:
-
- (defun foo (&optional &rest x))
- (defun bar (&optional &optional x))
-
-Previously, Emacs would just ignore the extra keyword, or give
-incorrect results in certain cases.
-
-** The pinentry.el library has been removed.
-That package (and the corresponding change in GnuPG and pinentry)
-was intended to provide a way to input passphrase through Emacs with
-GnuPG 2.0. However, the change to support that was only implemented
-in GnuPG >= 2.1 and didn't get backported to GnuPG 2.0. And with
-GnuPG 2.1 and later, pinentry.el is not needed at all. So the
-library was useless, and we removed it. GnuPG 2.0 is no longer
-supported by the upstream project.
-
-To adapt to the change, you may need to set 'epa-pinentry-mode' to the
-symbol 'loopback'. Alternatively, leave 'epa-pinentry-mode' at its
-default value of nil, and remove the 'allow-emacs-pinentry' setting
-from your 'gpg-agent.conf' configuration file, usually found in the
-'~/.gnupg' directory.
-
-Note that previously, it was said that passphrase input through
-minibuffer would be much less secure than other graphical pinentry
-programs. However, these days the difference is insignificant: the
-'read-password' function sufficiently protects input from leakage to
-message logs. Emacs still doesn't use secure memory to protect
-passphrases, but it was also removed from other pinentry programs as
-the attack is unrealistic on modern computer systems which don't
-utilize swap memory usually.
-
-** The function 'display-buffer-in-major-side-window' no longer exists.
-It has been renamed as internal function 'window--make-major-side-window',
-however applications should instead call 'display-buffer-in-side-window'
-(passing the SIDE and SLOT parameters as elements of ALIST). This approach
-is backwards-compatible with versions of Emacs in which the old function
-exists. See the node "Displaying Buffers in Side Windows" in the ELisp
-manual for more details.
-
-* Lisp Changes in Emacs 26.1
-
-** The function 'assoc' now takes an optional third argument TESTFN.
-This argument, when non-nil, is used for comparison instead of
-'equal'.
-
-** New optional argument TESTFN in 'alist-get', 'map-elt' and 'map-put'.
-If non-nil, the argument specifies a function to use for comparison,
-instead of, respectively, 'assq' and 'eql'.
-
-** New function 'seq-set-equal-p' to check if SEQUENCE1 and SEQUENCE2
-contain the same elements, regardless of the order.
-
-** The new function 'mapbacktrace' applies a function to all frames of
-the current stack trace.
-
-** The new function 'file-name-case-insensitive-p' tests whether a
-given file is on a case-insensitive filesystem.
-
-** Several accessors for the value returned by 'file-attributes'
-have been added. They are: 'file-attribute-type',
-'file-attribute-link-number', 'file-attribute-user-id',
-'file-attribute-group-id', 'file-attribute-access-time',
-'file-attribute-modification-time',
-'file-attribute-status-change-time', 'file-attribute-size',
-'file-attribute-modes', 'file-attribute-inode-number',
-'file-attribute-device-number' and 'file-attribute-collect'.
-
-** The new function 'buffer-hash' computes a fast, non-consing hash of
-a buffer's contents.
-
-** 'interrupt-process' now consults the list 'interrupt-process-functions',
-to determine which function has to be called in order to deliver the
-SIGINT signal. This allows Tramp to send the SIGINT signal to remote
-asynchronous processes. The hitherto existing implementation has been
-moved to 'internal-default-interrupt-process'.
-
-** The new function 'read-multiple-choice' prompts for multiple-choice
-questions, with a handy way to display help texts.
-
-** 'comment-indent-function' values may now return a cons to specify a
-range of indentation.
-
-** New optional argument TEXT in 'make-temp-file'.
-
-** New function 'define-symbol-prop'.
-
-** New function 'secure-hash-algorithms' to list the algorithms that
-'secure-hash' supports.
-See the node "(elisp) Checksum/Hash" in the ELisp manual for details.
-
-** Emacs now exposes the GnuTLS cryptographic API with the functions
-'gnutls-macs' and 'gnutls-hash-mac'; 'gnutls-digests' and
-'gnutls-hash-digest'; 'gnutls-ciphers' and 'gnutls-symmetric-encrypt'
-and 'gnutls-symmetric-decrypt'.
-See the node "(elisp) GnuTLS Cryptography" in the ELisp manual for details.
-
-** The function 'gnutls-available-p' now returns a list of capabilities
-supported by the GnuTLS library used by Emacs.
-
-** Emacs now supports records for user-defined types, via the new
-functions 'make-record', 'record', and 'recordp'. Records are now
-used internally to represent cl-defstruct and defclass instances, for
-example.
-
-If your program defines new record types, you should use
-package-naming conventions for naming those types. This is so any
-potential conflicts with other types are avoided.
-
-** 'save-some-buffers' now uses 'save-some-buffers-default-predicate'
-to decide which buffers to ask about, if the PRED argument is nil.
-The default value of 'save-some-buffers-default-predicate' is nil,
-which means ask about all file-visiting buffers.
-
-** string-(to|as|make)-(uni|multi)byte are now declared obsolete.
-
-** New variable 'while-no-input-ignore-events' which allow
-setting which special events 'while-no-input' should ignore.
-It is a list of symbols.
-
-** New function 'undo-amalgamate-change-group' to get rid of
-undo-boundaries between two states.
-
-** New var 'definition-prefixes' is a hash table mapping prefixes to
-the files where corresponding definitions can be found. This can be
-used to fetch definitions that are not yet loaded, for example for
-'C-h f'.
-
-** New var 'syntax-ppss-table' to control the syntax-table used in
-'syntax-ppss'.
-
-** 'define-derived-mode' can now specify an :after-hook form, which
-gets evaluated after the new mode's hook has run. This can be used to
-incorporate configuration changes made in the mode hook into the
-mode's setup.
-
-** Autoload files are now generated without timestamps.
-Set 'autoload-timestamps' to a non-nil value to get timestamps in
-autoload files.
-
-** 'gnutls-boot' now takes a parameter ':complete-negotiation' that
-says that negotiation should complete even on non-blocking sockets.
-
-** There is now a new variable 'flyspell-sort-corrections-function'
-that allows changing the way corrections are sorted.
-
-** The new command 'fortune-message' has been added, which displays
-fortunes in the echo area.
-
-** New function 'func-arity' returns information about the argument list
-of an arbitrary function. This generalizes 'subr-arity' for functions
-that are not built-in primitives. We recommend using this new
-function instead of 'subr-arity'.
-
-** New function 'region-bounds' can be used in the interactive spec
-to provide region boundaries (for rectangular regions more than one)
-to an interactively callable function as a single argument instead of
-two separate arguments 'region-beginning' and 'region-end'.
-
-** 'parse-partial-sexp' state has a new element.
-Element 10 is non-nil when the last character scanned might be the
-first character of a two character construct, i.e., a comment
-delimiter or escaped character. Its value is the syntax of that last
-character.
-
-** 'parse-partial-sexp's state, element 9, has now been confirmed as
-permanent and documented, and may be used by Lisp programs. Its value
-is a list of currently open parenthesis positions, starting with the
-outermost parenthesis.
-
-** 'read-color' will now display the color names using the color itself
-as the background color.
-
-** The function 'redirect-debugging-output' now works on platforms
-other than GNU/Linux.
-
-** The new function 'string-version-lessp' compares strings by
-interpreting consecutive runs of numerical characters as numbers, and
-compares their numerical values. According to this predicate,
-"foo2.png" is smaller than "foo12.png".
-
-** Numeric comparisons and 'logb' no longer return incorrect answers
-due to internal rounding errors. For example, '(< most-positive-fixnum
-(+ 1.0 most-positive-fixnum))' now correctly returns t on 64-bit hosts.
-
-** The functions 'ffloor', 'fceiling', 'ftruncate' and 'fround' now
-accept only floating-point arguments, as per their documentation.
-Formerly, they quietly accepted integer arguments and sometimes
-returned nonsensical answers, e.g., '(< N (ffloor N))' could return t.
-
-** On hosts like GNU/Linux x86-64 where a 'long double' fraction
-contains at least EMACS_INT_WIDTH - 3 bits, 'format' no longer returns
-incorrect answers due to internal rounding errors when formatting
-Emacs integers with '%e', '%f', or '%g' conversions. For example, on
-these hosts '(eql N (string-to-number (format "%.0f" N)))' now returns
-t for all Emacs integers N.
-
-** Calls that accept floating-point integers (for use on hosts with
-limited integer range) now signal an error if arguments are not
-integral. For example '(decode-char 'ascii 0.5)' now signals an
-error.
-
-** Functions 'string-trim-left', 'string-trim-right' and 'string-trim'
-now accept optional arguments which specify the regexp of a substring
-to trim.
-
-** The new function 'char-from-name' converts a Unicode name string
-to the corresponding character code.
-
-** New functions 'sxhash-eq' and 'sxhash-eql' return hash codes of a
-Lisp object suitable for use with 'eq' and 'eql' correspondingly. If
-two objects are 'eq' ('eql'), then the result of 'sxhash-eq'
-('sxhash-eql') on them will be the same.
-
-** Function 'sxhash' has been renamed to 'sxhash-equal' for
-consistency with the new functions. For compatibility, 'sxhash'
-remains as an alias to 'sxhash-equal'.
-
-** 'make-hash-table' now defaults to a rehash threshold of 0.8125
-instead of 0.8, to avoid rounding glitches.
-
-** New function 'add-variable-watcher' can be used to call a function
-when a symbol's value is changed. This is used to implement the new
-debugger command 'debug-on-variable-change'.
-
-** New variable 'print-escape-control-characters' causes 'prin1' and
-'print' to output control characters as backslash sequences.
-
-** Time conversion functions that accept a time zone rule argument now
-allow it to be OFFSET or a list (OFFSET ABBR), where the integer
-OFFSET is a count of seconds east of Universal Time, and the string
-ABBR is a time zone abbreviation. The affected functions are
-'current-time-string', 'current-time-zone', 'decode-time',
-'format-time-string', and 'set-time-zone-rule'.
-
-** 'format-time-string' now formats '%q' to the calendar quarter.
-
-** New built-in function 'mapcan'.
-It avoids unnecessary consing (and garbage collection).
-
-** 'car' and 'cdr' compositions 'cXXXr' and 'cXXXXr' are now part of Elisp.
-
-** 'gensym' is now part of Elisp.
-
-** Low-level list functions like 'length' and 'member' now do a better
-job of signaling list cycles instead of looping indefinitely.
-
-** The new functions 'make-nearby-temp-file' and 'temporary-file-directory'
-can be used for creation of temporary files on remote or mounted directories.
-
-** On GNU platforms when operating on a local file, 'file-attributes'
-no longer suffers from a race when called while another process is
-altering the filesystem. On non-GNU platforms 'file-attributes'
-attempts to detect the race, and returns nil if it does so.
-
-** The new function 'file-local-name' can be used to specify arguments
-of remote processes.
-
-** The new functions 'file-name-quote', 'file-name-unquote' and
-'file-name-quoted-p' can be used to quote / unquote file names with
-the prefix "/:".
-
-** The new error 'file-missing', a subcategory of 'file-error', is now
-signaled instead of 'file-error' if a file operation acts on a file
-that does not exist.
-
-** The function 'delete-directory' no longer signals an error when
-operating recursively and when some other process deletes the directory
-or its files before 'delete-directory' gets to them.
-
-** New error type 'user-search-failed' like 'search-failed' but
-avoids debugger like 'user-error'.
-
-** The function 'line-number-at-pos' now takes a second optional
-argument 'absolute'. If this parameter is nil, the default, this
-function keeps on returning the line number taking potential narrowing
-into account. If this parameter is non-nil, the function ignores
-narrowing and returns the absolute line number.
-
-** The function 'color-distance' now takes a second optional argument
-'metric'. When non-nil, it should be a function of two arguments that
-accepts two colors and returns a number.
-
-** Changes in Frame and Window Handling
+** Old-style backquotes now generate an error.
+They have been generating warnings for a decade. To interpret
+old-style backquotes as new-style, bind the new variable
+'force-new-style-backquotes' to t.
+
+** Defining a Common Lisp structure using 'cl-defstruct' or
+'cl-struct-define' whose name clashes with a builtin type (e.g.,
+'integer' or 'hash-table') now signals an error.
+
+** When formatting a floating-point number as an octal or hexadecimal
+integer, Emacs now signals an error if the number is too large for the
+implementation to format.
+
+** logb now returns infinity when given an infinite or zero argument,
+and returns a NaN when given a NaN. Formerly, it returned an extreme
+fixnum for such arguments.
+
+---
+** Some functions and variables obsolete since Emacs 22 have been removed:
+archive-mouse-extract, assoc-ignore-case, assoc-ignore-representation,
+backward-text-line, blink-cursor, bookmark-exit-hooks,
+comint-use-prompt-regexp-instead-of-fields, compilation-finish-function,
+count-text-lines, cperl-vc-header-alist, custom-face-save-command,
+cvs-display-full-path, cvs-fileinfo->full-path, delete-frame-hook,
+derived-mode-class, describe-char-after, describe-project,
+desktop-basefilename, desktop-buffer-handlers, desktop-buffer-misc-functions,
+desktop-buffer-modes-to-save, desktop-enable, desktop-load-default,
+dired-omit-files-p, disabled-command-hook, dungeon-mode-map,
+electric-nroff-mode, electric-nroff-newline, electric-perl-terminator,
+focus-frame, forward-text-line, generic-define-mswindows-modes,
+generic-define-unix-modes, generic-font-lock-defaults, goto-address-at-mouse,
+highlight-changes-colours, ibuffer-elide-long-columns, ibuffer-hooks,
+ibuffer-mode-hooks, icalendar-convert-diary-to-ical,
+icalendar-extract-ical-from-buffer, imenu-always-use-completion-buffer-p,
+ipconfig-program, ipconfig-program-options, isearch-lazy-highlight-cleanup,
+isearch-lazy-highlight-initial-delay, isearch-lazy-highlight-interval,
+isearch-lazy-highlight-max-at-a-time, iswitchb-use-fonts,
+latin1-char-displayable-p, mouse-wheel-click-button, mouse-wheel-down-button,
+mouse-wheel-up-button, new-frame, pascal-outline, process-kill-without-query,
+recentf-menu-append-commands-p, rmail-pop-password,
+rmail-pop-password-required, savehist-load, set-default-font,
+spam-list-of-processors, speedbar-add-ignored-path-regexp,
+speedbar-buffers-line-path, speedbar-ignored-path-expressions,
+speedbar-ignored-path-regexp, speedbar-line-path, speedbar-path-line,
+timer-set-time-with-usecs, tooltip-gud-display, tooltip-gud-modes,
+tooltip-gud-toggle-dereference, unfocus-frame, unload-hook-features-list,
+update-autoloads-from-directories, vc-comment-ring, vc-comment-ring-index,
+vc-comment-search-forward, vc-comment-search-reverse, vc-comment-to-change-log,
+vc-diff-switches-list, vc-next-comment, vc-previous-comment, view-todo,
+x-lost-selection-hooks, x-sent-selection-hooks.
+
+---
+** Further functions and variables obsolete since Emacs 24 have been removed:
+default-directory-alist, dired-default-directory,
+dired-default-directory-alist, dired-enable-local-variables,
+dired-hack-local-variables, dired-local-variables-file, dired-omit-here-always.
+
+** Garbage collection no longer treats miscellaneous objects specially;
+they are now allocated like any other pseudovector. As a result, the
+'garbage-collect' and 'memory-use-count' functions no longer return a
+'misc' component, and the 'misc-objects-consed' variable has been
+removed.
+
++++
+** Reversed character ranges are no longer permitted in rx.
+Previously, ranges where the starting character is greater than the
+ending character were silently omitted.
+For example, '(rx (any "@z-a" (?9 . ?0)))' would match '@' only.
+Now, such rx expressions generate an error.
+
++++
+** 'text-mode' no longer sets the value of 'indent-line-function'.
+The global value of 'indent-line-function', which defaults to
+'indent-relative', will no longer be reset locally when turning on
+'text-mode'.
+
+To get back the old behavior, add a function to 'text-mode-hook' which
+performs (setq-local indent-line-function #'indent-relative).
-*** Resizing a frame no longer runs 'window-configuration-change-hook'.
-'window-size-change-functions' should be used instead.
-
-*** The new function 'frame-size-changed-p' can tell whether a frame has
-been resized since the last time 'window-size-change-functions' has been
-run.
-
-*** The function 'frame-geometry' now also returns the width of a
-frame's outer border.
-
-*** New frame parameters and changed semantics for older ones:
-
-**** 'z-group' positions a frame above or below all others.
-
-**** 'min-width' and 'min-height' specify the absolute minimum size of a
-frame.
-
-**** 'parent-frame' makes a frame the child frame of another Emacs
-frame. The section "(elisp) Child Frames" in the ELisp manual
-describes the intrinsics of that relationship.
-
-**** 'delete-before' triggers deletion of one frame before that of
-another.
-
-**** 'mouse-wheel-frame' specifies another frame whose windows shall be
-scrolled instead.
-
-**** 'no-other-frame' has 'next-frame' and 'previous-frame' skip this
-frame.
-
-**** 'skip-taskbar' removes a frame's icon from the taskbar and has
-'Alt-<TAB>' skip this frame.
-
-**** 'no-focus-on-map' avoids that a frame gets input focus when mapped.
-
-**** 'no-accept-focus' means that a frame does not want to get input
-focus via the mouse.
-
-**** 'undecorated' removes the window manager decorations from a frame.
-
-**** 'override-redirect' tells the window manager to disregard this
-frame.
-
-**** 'width' and 'height' now allow the specification of pixel values
-and ratios.
-
-**** 'left' and 'top' now allow the specification of ratios.
-
-**** 'keep-ratio' preserves size and position of child frames when their
-parent frame is resized.
-
-**** 'no-special-glyphs' suppresses display of truncation and
-continuation glyphs in a frame.
-
-**** 'auto-hide-function' and 'minibuffer-exit' handle auto hiding of
-frames and exiting from minibuffer individually.
-
-**** 'fit-frame-to-buffer-margins' and 'fit-frame-to-buffer-sizes'
-handle fitting a frame to its buffer individually.
-
-**** 'drag-internal-border', 'drag-with-header-line',
-'drag-with-mode-line', 'snap-width', 'top-visible' and 'bottom-visible'
-allow dragging and resizing frames with the mouse.
-
-**** 'minibuffer' is now set to the default minibuffer window when
-initially specified as nil and is not reset to nil when initially
-specifying a minibuffer window.
-
-*** The new function 'frame-list-z-order' returns a list of all frames
-in Z (stacking) order.
-
-*** The function 'x-focus-frame' optionally tries to not activate its
-frame.
-
-*** The variable 'focus-follows-mouse' has a third meaningful value
-'auto-raise' to indicate that the window manager automatically raises a
-frame when the mouse pointer enters it.
-
-*** The new function 'frame-restack' puts a frame above or below
-another on the display.
-
-*** The new face 'internal-border' specifies the background of a frame's
-internal border.
-
-*** The NORECORD argument of 'select-window' now has a meaningful value
-'mark-for-redisplay' which is like any other non-nil value but marks
-WINDOW for redisplay.
-
-*** Support for side windows is now official. The display action
-function 'display-buffer-in-side-window' will display its buffer in a
-side window. Functions for toggling all side windows on a frame,
-changing and reversing the layout of side windows and returning the
-main (major non-side) window of a frame are provided. For details
-consult the section "(elisp) Side Windows" in the ELisp manual.
-
-*** Support for atomic windows - rectangular compositions of windows
-treated by 'split-window', 'delete-window' and 'delete-other-windows'
-like a single live window - is now official. For details consult the
-section "(elisp) Atomic Windows" in the ELisp manual.
-
-*** New 'display-buffer' alist entry 'window-parameters' allows the
-assignment of window parameters to the window used for displaying the
-buffer.
-
-*** New function 'display-buffer-reuse-mode-window' is an action function
-suitable for use in 'display-buffer-alist'. For example, to avoid
-creating a new window when opening man pages when there's already one,
-use
-
-(add-to-list 'display-buffer-alist
- '("\\`\\*Man .*\\*\\'" .
- (display-buffer-reuse-mode-window
- (inhibit-same-window . nil)
- (mode . Man-mode))))
-
-*** New window parameter 'no-delete-other-windows' prevents that
-its window gets deleted by 'delete-other-windows'.
-
-*** New window parameters 'mode-line-format' and 'header-line-format'
-allow the buffer-local formats for this window to be overridden.
-
-*** New command 'window-swap-states' swaps the states of two live
-windows.
-
-*** New functions 'window-pixel-width-before-size-change' and
-'window-pixel-height-before-size-change' support detecting which
-window changed size when 'window-size-change-functions' are run.
-
-*** The new function 'window-lines-pixel-dimensions' returns the pixel
-dimensions of a window's text lines.
-
-*** The new function 'window-largest-empty-rectangle' returns the
-dimensions of the largest rectangular area not occupying any text in a
-window's body.
-
-*** The semantics of 'mouse-autoselect-window' has changed slightly.
-For details see the section "(elisp) Mouse Window Auto-selection" in
-the ELisp manual.
-
-*** 'select-frame-by-name' now may return a frame on another display
-if it does not find a suitable one on the current display.
-
-** 'tcl-auto-fill-mode' is now declared obsolete.
-Its functionality can be replicated simply by setting
-'comment-auto-fill-only-comments'.
-
-** New pcase pattern 'rx' to match against an rx-style regular expression.
-For details, see the doc string of 'rx--pcase-macroexpander'.
+
+* Lisp Changes in Emacs 27.1
+
+** i18n (internationalization)
+
+*** ngettext can be used now to return the right plural form
+according to the given numeric value.
+
++++
+** inhibit-null-byte-detection is renamed to inhibit-nul-byte-detection
+
++++
+** 'self-insert-command' takes the char to insert as (optional) argument.
+
+** 'lookup-key' can take a list of keymaps as argument.
+
++++
+** 'condition-case' now accepts 't' to match any error symbol.
+
++++
+** New function 'proper-list-p'.
+Given a proper list as argument, this predicate returns its length;
+otherwise, it returns nil. 'format-proper-list-p' is now an obsolete
+alias for the new function.
+
++++
+** Emacs Lisp integers can now be of arbitrary size.
+Emacs uses the GNU Multiple Precision (GMP) library to support
+integers whose size is too large to support natively. The integers
+supported natively are known as "fixnums", while the larger ones are
+"bignums". The new predicates 'bignump' and 'fixnump' can be used to
+distinguish between these two types of integers.
+
+All the arithmetic, comparison, and logical (a.k.a. "bitwise")
+operations where bignums make sense now support both fixnums and
+bignums. However, note that unlike fixnums, bignums will not compare
+equal with 'eq', you must use 'eql' instead. (Numerical comparison
+with '=' works on both, of course.)
+
+Since large bignums consume a lot of memory, Emacs limits the size of
+the largest bignum a Lisp program is allowed to create. The
+nonnegative value of the new variable 'integer-width' specifies the
+maximum number of bits allowed in a bignum. Emacs signals an integer
+overflow error if this limit is exceeded.
+
+Several primitive functions formerly returned floats or lists of
+integers to represent integers that did not fit into fixnums. These
+functions now simply return integers instead. Affected functions
+include functions like 'encode-char' that compute code-points, functions
+like 'file-attributes' that compute file sizes and other attributes,
+functions like 'process-id' that compute process IDs, and functions like
+'user-uid' and 'group-gid' that compute user and group IDs.
+
++++
+** Although the default timestamp format is still (HI LO US PS),
+it is planned to change in a future Emacs version, to exploit bignums.
+The documentation has been updated to mention that the timestamp
+format may change and that programs should use functions like
+'format-time-string', 'decode-time', and 'encode-time' rather than
+probing the innards of a timestamp directly, or creating a timestamp
+by hand.
+
++++
+** 'encode-time' supports a new API '(encode-time TIME &optional FORM)'.
+This can convert decoded times and Lisp time values to Lisp timestamps
+of various forms, including a new timestamp form '(TICKS . HZ)', where
+TICKS is an integer and HZ is a positive integer denoting a clock
+frequency. The old 'encode-time' API is still supported.
+
++++
+** 'time-add', 'time-subtract', and 'time-less-p' now accept
+infinities and NaNs too, and propagate them or return nil like
+floating-point operators do.
+
++++
+** New function 'time-equal-p' compares time values for equality.
+
++++
+** 'format-time-string' supports a new conversion specifier flag '+'
+that acts like the '0' flag but also puts a '+' before nonnegative
+years containing more than four digits. This is for compatibility
+with POSIX.1-2017.
+
+** 'define-minor-mode' automatically documents the meaning of ARG.
+
++++
+** The function 'recenter' now accepts an additional optional argument.
+By default, calling 'recenter' will not redraw the frame even if
+'recenter-redisplay' is non-nil. Call 'recenter' with the new second
+argument non-nil to force redisplay per 'recenter-redisplay's value.
+
++++
+** New functions 'major-mode-suspend' and 'major-mode-restore'.
+Use them when switching temporarily to another major mode, e.g. for
+'hexl-mode', or to switch between 'c-mode' and 'image-mode' in XPM.
+
++++
+** New macro 'dolist-with-progress-reporter'.
+This works like 'dolist', but reports progress similar to
+'dotimes-with-progress-reporter'.
+
++++
+** New hook 'after-delete-frame-functions'.
+This works like 'delete-frame-functions', but runs after the frame to
+be deleted has been made dead and removed from the frame list.
+
+---
+** The function 'provided-mode-derived-p' was extended to support aliases.
+The function now returns non-nil when the argument MODE is derived
+from any alias of any of MODES.
+
++++
+** New frame focus state inspection interface.
+The hooks 'focus-in-hook' and 'focus-out-hook' are now obsolete.
+Instead, attach to 'after-focus-change-function' using 'add-function'
+and inspect the focus state of each frame using 'frame-focus-state'.
+
++++
+** Emacs now requests and recognizes focus-change notifications from TTYs.
+On terminal emulators that support the feature, Emacs can now support
+'focus-in-hook' and 'focus-out-hook' for TTY frames.
+
++++
+** Window-specific face remapping.
+Face specifications (of the kind used in 'face-remapping-alist')
+now support filters, allowing faces to vary between different windows
+displaying the same buffer. See the node "(elisp) Face Remapping"
+of the Emacs Lisp Reference manual for more detail.
+
++++
+** Window change functions have been redesigned.
+
+Hooks reacting to window changes run now only when redisplay detects
+that a change has actually occurred. Six hooks are now provided:
+'window-buffer-change-functions' (run after window buffers have
+changed), 'window-size-change-functions' (run after a window was
+assigned a new buffer or size), 'window-configuration-change-hook'
+(like the former but run also when a window was deleted),
+'window-selection-change-functions' (run when the selected window
+changed) and 'window-state-change-functions' and
+'window-state-change-hook' (run when any of the preceding ones is
+run). Applications can enforce running the latter two using the new
+function 'set-frame-window-state-change'. 'window-scroll-functions'
+are unaffected by these changes.
+
+In addition, a number of functions now allow the caller to detect what
+has changed since last redisplay: 'window-old-buffer' returns for any
+window the buffer it showed at that time. ‘old-selected-window’ and
+'old-selected-frame' return the window and frame that were selected
+during last redisplay. 'window-old-pixel-width' (renamed from
+'window-pixel-width-before-size-change'), 'window-old-pixel-height'
+(renamed from 'window-pixel-height-before-size-change'),
+'window-old-body-pixel-width' and 'window-old-body-pixel-height'
+return the total and body sizes of any window during last redisplay.
+
+See the section "(elisp) Window Hooks" in the Elisp manual for a
+detailed explanation of the new behavior.
+
++++
+*** New option 'resize-mini-frames'.
+This option allows to automatically resize minibuffer-only frames
+similarly to how minibuffer windows are resized on "normal" frames.
+
++++
+** New buffer display action alist entry 'dedicated'.
+Such an entry allows to specify the dedicated status of a window
+created by 'display-buffer'.
+
++++
+** New buffer display action alist entry 'window-min-height'.
+Such an entry allows to specify a minimum height of the window used
+for displaying a buffer. 'display-buffer-below-selected' is the only
+action function to respect it at the moment.
+
++++
+** The function 'assoc-delete-all' now takes an optional predicate argument.
+
++++
+** New function 'string-distance' to calculate the Levenshtein distance
+between two strings.
+
+** 'print-quoted' now defaults to t, so if you want to see
+'(quote x)' instead of 'x you will have to bind it to nil where applicable.
+
++++
+** Numbers formatted via '%o' or '%x' are now formatted as signed integers.
+This avoids problems in calls like '(read (format "#x%x" -1))', and is
+more compatible with bignums. To get the traditional machine-dependent
+behavior, set the experimental variable 'binary-as-unsigned' to t,
+and if the new behavior breaks your code please email
+32252@debbugs.gnu.org. Because '%o' and '%x' can now format signed
+integers, they now support the '+' and space flags.
+
+** To avoid confusion caused by "smart quotes", the reader signals an
+error when reading Lisp symbols which begin with one of the following
+quotation characters: ‘’‛“”‟〞"'. A symbol beginning with such a
+character can be written by escaping the quotation character with a
+backslash. For example:
+
+ (read "‘smart") => (invalid-read-syntax "strange quote" "‘")
+ (read "\\‘smart") == (intern "‘smart")
+
++++
+** Omitting variables after '&optional' and '&rest' is now allowed.
+For example '(defun foo (&optional))' is no longer an error. This is
+sometimes convenient when writing macros. See the ChangeLog entry
+titled "Allow '&rest' or '&optional' without following variable
+(Bug#29165)" for a full listing of which arglists are accepted across
+versions.
+
+** Internal parsing commands now use 'syntax-ppss' and disregard
+'open-paren-in-column-0-is-defun-start'. This affects mostly things like
+'forward-comment', 'scan-sexps', and 'forward-sexp' when parsing backward.
+The new variable 'comment-use-syntax-ppss' can be set to nil to recover
+the old behavior if needed.
+
+** The 'server-name' and 'server-socket-dir' variables are set when a
+socket has been passed to Emacs.
+
+---
+** The 'file-system-info' function is now available on all platforms.
+instead of just Microsoft platforms. This fixes a 'get-free-disk-space'
+bug on OS X 10.8 and later.
+
+---
+** The function 'get-free-disk-space' returns now a non-nil value for
+remote systems, which support this check.
+
++++
+** 'memory-limit' now returns a better estimate of memory consumption.
+
++++
+** New macro 'combine-change-calls' arranges to call the change hooks
+('before-change-functions' and 'after-change-functions') just once
+each around a sequence of lisp forms, given a region. This is
+useful when a function makes a possibly large number of repetitive
+changes and the change hooks are time consuming.
+
++++
+** 'eql', 'make-hash-table', etc. now treat NaNs consistently.
+Formerly, some of these functions ignored signs and significands of
+NaNs. Now, all these functions treat NaN signs and significands as
+significant. For example, '(eql 0.0e+NaN -0.0e+NaN)' now returns nil
+because the two NaNs have different signs; formerly it returned t.
+Also, Emacs now reads and prints NaN significands; e.g., if X is a
+NaN, '(format "%s" X)' now returns "0.0e+NaN", "1.0e+NaN", etc.,
+depending on X's significand.
+
++++
+** The function 'make-string' accepts an additional optional argument.
+If the optional third argument is non-nil, 'make-string' will produce
+a multibyte string even if its second argument is an ASCII character.
+
+** '(format "%d" X)' no longer mishandles a floating-point number X that
+does not fit in a machine integer.
+
+---
+** New coding-system 'ibm038'.
+This is the International EBCDIC encoding, also available as aliases
+'ebcdic-int' and 'cp038'.
+
++++
+** In the DST slot, 'encode-time' and 'parse-time-string' now return -1
+if it is not known whether daylight saving time is in effect.
+Formerly they were inconsistent: 'encode-time' returned t in this
+situation, whereas 'parse-time-string' returned nil. Now they
+consistently use use nil to mean that DST is not in effect, and use -1
+to mean that it is not known whether DST is in effect.
+
+** New JSON parsing and serialization functions 'json-serialize',
+'json-insert', 'json-parse-string', and 'json-parse-buffer'. These
+are implemented in C using the Jansson library.
+
++++
+** New function 'ring-resize'.
+'ring-resize' can be used to grow or shrink a ring.
+
++++
+** New function 'flatten-tree'.
+'flatten-list' is provided as an alias. These functions take a tree
+and 'flatten' it such that the result is a list of all the terminal
+nodes.
+
++++
+** 'zlib-decompress-region' can partially decompress corrupted data.
+If the new optional ALLOW-PARTIAL argument is passed, then the data
+that was decompressed successfully before failing will be inserted
+into the buffer.
+
+** Mailcap
+
+---
+*** The new function 'mailcap-file-name-to-mime-type' has been added.
+It's a simple convenience function for looking up MIME types based on
+file name extensions.
+
+*** The default way the list of possible external viewers for MIME
+types is sorted and chosen has changed. Earlier, the most specific
+viewer was chosen, even if there was a general override in "~/.mailcap".
+For instance, if "/etc/mailcap" has an entry for "image/gif", that one
+will be chosen even if you have an entry for "image/*" in your
+"~/.mailcap" file. But with the new method, entries from "~/.mailcap"
+overrides all system and Emacs-provided defaults. To get the old
+method back, set 'mailcap-prefer-mailcap-viewers' to nil.
-** New functions to set region from secondary selection and vice versa.
-The new functions 'secondary-selection-to-region' and
-'secondary-selection-from-region' let you set the beginning and the
-end of the region from those of the secondary selection and vice
-versa.
+** URL
-** New function 'lgstring-remove-glyph' can be used to modify a
-gstring returned by the underlying layout engine (e.g. m17n-flt,
-uniscribe).
+*** The 'file:' handler no longer looks for "index.html" in
+directories if you ask it for a "file:///dir" URL. Since this is a
+low-level library, such decisions (if they are to be made at all) are
+left to higher-level functions.
+
+** Image mode
+
+*** 'image-mode' started using ImageMagick by default for all images
+some years back. It now respects 'imagemagick-types-inhibit' as a way
+to disable that.
+
+---
+*** Some image-mode variables are now buffer-local.
+The image parameters 'image-transform-rotation',
+'image-transform-scale' and 'image-transform-resize' are now declared
+buffer-local, so each buffer could have its own values for these
+parameters.
+
+** The function 'load' now behaves correctly when loading modules.
+Specifically, it puts the module name into 'load-history', prints
+loading messages if requested, and protects against recursive loads.
+
++++
+** The function 'read-variable' now uses its own history list.
+The history of variable names read by 'read-variable' is recorded in
+the new variable 'custom-variable-history'.
+
+---
+** The function 'string-to-unibyte' is no longer declared obsolete.
+We have found that there are legitimate use cases for this function,
+where there's no better alternative. We believe that the incorrect
+uses of this function all but disappeared by now, so we are
+un-obsoleting it.
+
++++
+** New function 'group-name' returns a group name corresponding to GID.
+
++++
+** 'make-process' now takes a keyword argument ':file-handler'; if
+that is non-nil, it will look for a file name handler for the current
+buffer's 'default-directory' and invoke that file name handler to make
+the process. That way 'make-process' can start remote processes.
+
++++
+** Emacs now supports resizing (scaling) of images without ImageMagick.
+All modern systems are supported by this feature. (On GNU and Unix
+systems, Cairo drawing or the XRender extension to X11 is required for
+this to be available; the configure script will test for it and, if
+found, enable scaling.)
+
+The new function 'image-scaling-p' can be used to test whether any
+given frame supports resizing.
+
++++
+** (locale-info 'paper) now returns the paper size on systems that support it.
+This is currently supported on GNUish hosts and on modern versions of
+MS-Windows.
+
+** New module environment function 'process_input' to process user
+input while module code is running.
+
++++
+** The function 'regexp-opt' accepts an additional optional argument.
+By default, the regexp returned by 'regexp-opt' may match the strings
+in any order. If the new third argument is non-nil, the match is
+guaranteed to be performed in the order given, as if the strings were
+made into a regexp by joining them with '\|'.
+
++++
+** The function 'regexp-opt', when given an empty list of strings, now
+returns a regexp that never matches anything, which is an identity for
+this operation. Previously, the empty string was returned in this
+case.
-* Changes in Emacs 26.1 on Non-Free Operating Systems
-
-** Intercepting hotkeys on Windows 7 and later now works better.
-The new keyboard hooking code properly grabs system hotkeys such as
-'Win-*' and 'Alt-TAB', in a way that Emacs can get at them before the
-system. This makes the 'w32-register-hot-key' functionality work
-again on all versions of MS-Windows starting with Windows 7. On
-Windows NT and later you can now register any hotkey combination. (On
-Windows 9X, the previous limitations, spelled out in the Emacs manual,
-still apply.)
-
-** 'convert-standard-filename' no longer mirrors slashes on MS-Windows.
-Previously, on MS-Windows this function converted slash characters in
-file names into backslashes. It no longer does that. If your Lisp
-program used 'convert-standard-filename' to prepare file names to be
-passed to subprocesses (which is not the recommended usage of that
-function), you will now have to mirror slashes in your application
-code. One possible way is this:
-
- (let ((start 0))
- (while (string-match "/" file-name start)
- (aset file-name (match-beginning 0) ?\\)
- (setq start (match-end 0))))
-
-** GUI sessions on MS-Windows now treat SIGINT like Posix platforms do.
-The effect of delivering a Ctrl-C (SIGINT) signal to a GUI Emacs on
-MS-Windows is now the same as on Posix platforms -- Emacs saves the
-session and exits. In particular, this will happen if you start
-emacs.exe from the Windows shell, then type Ctrl-C into that shell's
-window.
-
-** 'signal-process' supports SIGTRAP on Windows XP and later.
-The 'kill' emulation on Windows now maps SIGTRAP to a call to the
-'DebugBreakProcess' API. This causes the receiving process to break
-execution and return control to the debugger. If no debugger is
-attached to the receiving process, the call is typically ignored.
-This is in contrast to the default action on POSIX Systems, where it
-causes the receiving process to terminate with a core dump if no
-debugger has been attached to it.
-
-** 'set-mouse-position' and 'set-mouse-absolute-pixel-position' work
-on macOS.
-
-** Emacs can now be run as a GUI application from the command line on
-macOS.
-
-** 'ns-appearance' and 'ns-transparent-titlebar' change the appearance
-of frame decorations on macOS 10.9+.
-
-** 'ns-use-thin-smoothing' enables thin font smoothing on macOS 10.8+.
-
-** 'process-attributes' on Darwin systems now returns more information.
-
-** Mousewheel and trackpad scrolling on macOS 10.7+ now behaves more
-like the macOS default. The new variables 'ns-mwheel-line-height',
-'ns-use-mwheel-acceleration' and 'ns-use-mwheel-momentum' can be used
-to customize the behavior.
+* Changes in Emacs 27.1 on Non-Free Operating Systems
+
+---
+** Battery status is now supported in all Cygwin builds.
+Previously it was supported only in the Cygwin-w32 build.
+
+** Emacs now handles key combinations involving the macOS "command"
+and "option" modifier keys more correctly.
+
+** The special handling of 'frame-title-format' on NS where setting it
+to 't' would enable the macOS proxy icon has been replaced with a
+separate variable, 'ns-use-proxy-icon'. 'frame-title-format' will now
+work as on other platforms.
+
+---
+** New primitive 'w32-read-registry'.
+This primitive lets Lisp programs access the MS-Windows Registry by
+retrieving values stored under a given key. It is intended to be used
+for supporting features such as XDG-like location of important files
+and directories.
+
++++
+** The default value of 'w32-pipe-read-delay' is now zero.
+This speeds up reading output from sub-processes that produce a lot of
+data.
+
+This variable may need to be non-zero only when running DOS programs
+as Emacs subprocesses, which by now is not supported on modern
+versions of MS-Windows. Set this variable to 50 if for some reason
+you need the old behavior (and please report such situations to Emacs
+developers).
+
+---
+** New variable 'w32-multibyte-code-page'.
+This variable holds the value of the multibyte code page used by the
+system. It is usually zero, which indicates that 'w32-ansi-code-page'
+is being used, except in Far Eastern locales. When this variable is
+non-zero, Emacs at startup sets 'locale-coding-system' to the
+corresponding encoding, instead of using 'w32-ansi-code-page'.
+
++++
+** On NS the behaviour of drag and drop can now be modified by use of
+modifier keys in line with Apples guidelines. This makes the drag and
+drop behaviour more consistent, as previously the sending application
+was able to 'set' modifiers without the knowledge of the user.
----------------------------------------------------------------------
diff --git a/etc/NEWS.1-17 b/etc/NEWS.1-17
index f215542a529..758ef65ed95 100644
--- a/etc/NEWS.1-17
+++ b/etc/NEWS.1-17
@@ -8,21 +8,21 @@ This file is about changes in Emacs versions 1 through 17.
-Changes in Emacs 17
+* Changes in Emacs 17
-* Frustrated?
+** Frustrated?
Try M-x doctor.
-* Bored?
+** Bored?
Try M-x hanoi.
-* Brain-damaged?
+** Brain-damaged?
Try M-x yow.
-* Sun3, Tahoe, Apollo, HP9000s300, Celerity, NCR Tower 32,
+** Sun3, Tahoe, Apollo, HP9000s300, Celerity, NCR Tower 32,
Sequent, Stride, Encore, Plexus and AT&T 7300 machines supported.
The Tahoe, Sun3, Sequent and Celerity use 4.2. In regard to the
@@ -30,24 +30,24 @@ Apollo, see the file APOLLO in this directory. NCR Tower32,
HP9000s300, Stride and Nu run forms of System V. System V rel 2 also
works on Vaxes now. See etc/MACHINES.
-* System V Unix supported, including subprocesses.
+** System V Unix supported, including subprocesses.
It should be possible now to bring up Emacs on a machine running
mere unameliorated system V Unix with no major work; just possible bug
fixes. But you can expect to find a handful of those on any machine
that Emacs has not been run on before.
-* Berkeley 4.1 Unix supported.
+** Berkeley 4.1 Unix supported.
See etc/MACHINES.
-* Portable `alloca' provided.
+** Portable `alloca' provided.
Emacs can now run on machines that do not and cannot support the library
subroutine `alloca' in the canonical fashion, using an `alloca' emulation
written in C.
-* On-line manual.
+** On-line manual.
Info now contains an Emacs manual, with essentially the same text
as in the printed manual.
@@ -57,7 +57,7 @@ The manual can now be printed with a standard TeX.
Nicely typeset and printed copies of the manual are available
from the Free Software Foundation.
-* Backup file version numbers.
+** Backup file version numbers.
Emacs now supports version numbers in backup files.
@@ -108,7 +108,7 @@ to keep, overriding `dired-kept-versions'. A negative argument specifies
the number of oldest versions to keep, using minus the argument to override
`kept-old-versions'.
-* Immediate conflict detection.
+** Immediate conflict detection.
Emacs now locks the files it is modifying, so that if
you start to modify within Emacs a file that is being
@@ -130,27 +130,27 @@ directory. If such a directory is not provided and told to
Emacs as part of configuring it for your machine, the lock feature
is turned off.
-* M-x recover-file.
+** M-x recover-file.
This command is used to get a file back from an auto-save
(after a system crash, for example). It takes a file name
as argument and visits that file, but gets the data from the
file's last auto save rather than from the file itself.
-* M-x normal-mode.
+** M-x normal-mode.
This command resets the current buffer's major mode and local
variables to be as specified by the visit filename, the -*- line
and/or the Local Variables: block at the end of the buffer.
It is the same thing normally done when a file is first visited.
-* Echo area messages disappear shortly if minibuffer is in use.
+** Echo area messages disappear shortly if minibuffer is in use.
Any message in the echo area disappears after 2 seconds
if the minibuffer is active. This allows the minibuffer
to become visible again.
-* C-z on System V runs a subshell.
+** C-z on System V runs a subshell.
On systems which do not allow programs to be suspended, the C-z command
forks a subshell that talks directly to the terminal, and then waits
@@ -158,18 +158,18 @@ for the subshell to exit. This gets almost the effect of suspending
in that you can run other programs and then return to Emacs. However,
you cannot log out from the subshell.
-* C-c is always a prefix character.
+** C-c is always a prefix character.
Also, subcommands of C-c which are letters are always
reserved for the user. No standard Emacs major mode
defines any of them.
-* Picture mode C-c commands changed.
+** Picture mode C-c commands changed.
The old C-c k command is now C-c C-w.
The old C-c y command is now C-c C-x.
-* Shell mode commands changed.
+** Shell mode commands changed.
All the special commands of Shell mode are now moved onto
the C-c prefix. Most are not changed aside from that.
@@ -182,7 +182,7 @@ is now C-c C-o, and C-x C-v (show output) is now C-c C-r.
The old M-= (copy previous input) command is now C-c C-y.
-* Shell mode recognizes aliases for `pushd', `popd' and `cd'.
+** Shell mode recognizes aliases for `pushd', `popd' and `cd'.
Shell mode now uses the variable `shell-pushd-regexp' as a
regular expression to recognize any command name that is
@@ -194,13 +194,13 @@ There are also `shell-popd-regexp' to recognize commands
with the effect of a `popd', and `shell-cd-regexp' to recognize
commands with the effect of a `cd'.
-* "Exit" command in certain modes now C-c C-c.
+** "Exit" command in certain modes now C-c C-c.
These include electric buffer menu mode, electric command history
mode, Info node edit mode, and Rmail edit mode. In all these
modes, the command to exit used to be just C-c.
-* Outline mode changes.
+** Outline mode changes.
Lines that are not heading lines are now called "body" lines.
The command `hide-text' is renamed to `hide-body'.
@@ -212,7 +212,7 @@ Changes of line visibility are no longer undoable. As a result,
they no longer use up undo memory and no longer interfere with
undoing earlier commands.
-* Rmail changes.
+** Rmail changes.
The s and q commands now both expunge deleted messages before saving;
use C-x C-s to save without expunging.
@@ -229,23 +229,23 @@ o now outputs to an Rmail file, and C-o to a Unix mail file.
The F command (rmail-find) is renamed to M-s (rmail-search).
Various new commands and features exist; see the Emacs manual.
-* Local bindings described first in describe-bindings.
+** Local bindings described first in describe-bindings.
-* [...], {...} now balance in Fundamental mode.
+** [...], {...} now balance in Fundamental mode.
-* Nroff mode and TeX mode.
+** Nroff mode and TeX mode.
There are two new major modes for editing nroff input and TeX input.
See the Emacs manual for full information.
-* New C indentation style variable `c-brace-imaginary-offset'.
+** New C indentation style variable `c-brace-imaginary-offset'.
The value of `c-brace-imaginary-offset', normally zero, controls the
indentation of a statement inside a brace-group where the open-brace
is not the first thing on a line. The value says where the open-brace
is imagined to be, relative to the first nonblank character on the line.
-* Dired improvements.
+** Dired improvements.
Dired now normally keeps the cursor at the beginning of the file name,
not at the beginning of the line. The most used motion commands are
@@ -259,22 +259,22 @@ printed in an error message.
If the `v' command is invoked on a file which is a directory,
dired is run on that directory.
-* `visit-tag-table' renamed `visit-tags-table'.
+** `visit-tag-table' renamed `visit-tags-table'.
This is so apropos of `tags' finds everything you need to
know about in connection with Tags.
-* `mh-e' library uses C-c as prefix.
+** `mh-e' library uses C-c as prefix.
All the special commands of `mh-rmail' now are placed on a
C-c prefix rather than on the C-x prefix. This is for
consistency with other special modes with their own commands.
-* M-$ or `spell-word' checks word before point.
+** M-$ or `spell-word' checks word before point.
It used to check the word after point.
-* Quitting during autoloading no longer causes trouble.
+** Quitting during autoloading no longer causes trouble.
Now, when a file is autoloaded, all function redefinitions
and `provide' calls are recorded and are undone if you quit
@@ -284,14 +284,14 @@ As a result, it no longer happens that some of the entry points
which are normally autoloading have been defined already, but the
entire file is not really present to support them.
-* `else' can now be indented correctly in C mode.
+** `else' can now be indented correctly in C mode.
TAB in C mode now knows which `if' statement an `else' matches
up with, and can indent the `else' correctly under the `if',
even if the `if' contained such things as another `if' statement,
or a `while' or `for' statement, with no braces around it.
-* `batch-byte-compile'
+** `batch-byte-compile'
Runs byte-compile-file on the files specified on the command line.
All the rest of the command line arguments are taken as files to
@@ -300,7 +300,7 @@ Must be used only with -batch, and kills emacs on completion.
Each file will be processed even if an error occurred previously.
For example, invoke `emacs -batch -f batch-byte-compile *.el'.
-* `-batch' changes.
+** `-batch' changes.
`-batch' now implies `-q': no init file is loaded by Emacs when
`-batch' is used. Also, no `term/TERMTYPE.el' file is loaded. Auto
@@ -313,7 +313,7 @@ One echo-area message that is not suppressed is the one that says
that a file is being loaded. That is because you can prevent this
message by passing `t' as the third argument to `load'.
-* Display of search string in incremental search.
+** Display of search string in incremental search.
Now, when you type C-s or C-r to reuse the previous search
string, that search string is displayed immediately in the echo area.
@@ -321,23 +321,23 @@ string, that search string is displayed immediately in the echo area.
Three dots are displayed after the search string while search
is actually going on.
-* View commands.
+** View commands.
The commands C-x ], C-x [, C-x /, C-x j and C-x o are now
available inside `view-buffer' and `view-file', with their
normal meanings.
-* Full-width windows preferred.
+** Full-width windows preferred.
The ``other-window'' commands prefer other full width windows,
and will split only full width windows.
-* M-x rename-file can copy if necessary.
+** M-x rename-file can copy if necessary.
When used between different file systems, since actual renaming does
not work, the old file will be copied and deleted.
-* Within C-x ESC, you can pick the command to repeat.
+** Within C-x ESC, you can pick the command to repeat.
While editing a previous command to be repeated, inside C-x ESC,
you can now use the commands M-p and M-n to pick an earlier or
@@ -353,24 +353,24 @@ The command you finally execute using C-x ESC is added to the
front of the command history, unless it is identical with the
first thing in the command history.
-* Use C-c C-c to exit from editing within Info.
+** Use C-c C-c to exit from editing within Info.
It used to be C-z for this. Somehow this use of C-z was
left out when all the others were moved. The intention is that
C-z should always suspend Emacs.
-* Default arg to C-x < and C-x > now window width minus 2.
+** Default arg to C-x < and C-x > now window width minus 2.
These commands, which scroll the current window horizontally
by a specified number of columns, now scroll a considerable
distance rather than a single column if used with no argument.
-* Auto Save Files Deleted.
+** Auto Save Files Deleted.
The default value of `delete-auto-save-files' is now `t', so that
when you save a file for real, its auto save file is deleted.
-* Rnews changes.
+** Rnews changes.
The N, P and J keys in Rnews are renamed to M-n, M-p and M-j.
These keys move among newsgroups.
@@ -382,7 +382,7 @@ this change, are eliminated.
The s command for outputting the current article to a file
is renamed as o, to be compatible with Rmail.
-* Sendmail changes.
+** Sendmail changes.
If you have a ~/.mailrc file, Emacs searches it for mailing address
aliases, and these aliases are expanded when you send mail in Emacs.
@@ -407,15 +407,15 @@ The new variable `mail-header-separator' now specifies the string
to use on the line that goes between the headers and the message text.
By default it is still "--text follows this line--".
-* Command history truncated automatically.
+** Command history truncated automatically.
Just before each garbage collection, all but the last 30 elements
of the command history are discarded.
-Incompatible Lisp Programming Changes in Emacs 17
+* Incompatible Lisp Programming Changes in Emacs 17
-* `&quote' no longer supported.
+** `&quote' no longer supported.
This feature, which allowed Lisp functions to take arguments
that were not evaluated, has been eliminated, because it is
@@ -434,7 +434,7 @@ with
(defun foo-1 (x y z) ...
-* Functions `region-to-string' and `region-around-match' removed.
+** Functions `region-to-string' and `region-around-match' removed.
These functions were made for compatibility with Gosling Emacs, but it
turns out to be undesirable to use them in GNU Emacs because they use
@@ -450,24 +450,24 @@ the two functions `match-beginning' and `match-end'. These give
you one bound at a time, as a numeric value, without changing
point or the mark.
-* Function `function-type' removed.
+** Function `function-type' removed.
This just appeared not to be very useful. It can easily be written in
Lisp if you happen to want it. Just use `symbol-function' to get the
function definition of a symbol, and look at its data type or its car
if it is a list.
-* Variable `buffer-number' removed.
+** Variable `buffer-number' removed.
You can still use the function `buffer-number' to find out
a buffer's unique number (assigned in order of creation).
-* Variable `executing-macro' renamed `executing-kbd-macro'.
+** Variable `executing-macro' renamed `executing-kbd-macro'.
This variable is the currently executing keyboard macro, as
a string, or `nil' when no keyboard macro is being executed.
-* Loading term/$TERM.
+** Loading term/$TERM.
The library term/$TERM (where $TERM get replaced by your terminal
type), which is done by Emacs automatically when it starts up, now
@@ -478,12 +478,12 @@ term-$TERM; thus, for example, term-vt100.el, but now they live
in a special subdirectory named term, and have names like
term/vt100.el.
-* `command-history' format changed.
+** `command-history' format changed.
The elements of this list are now Lisp expressions which can
be evaluated directly to repeat a command.
-* Unused editing commands removed.
+** Unused editing commands removed.
The functions `forward-to-word', `backward-to-word',
`upcase-char', `mark-beginning-of-buffer' and `mark-end-of-buffer'
@@ -491,9 +491,9 @@ have been removed. Their definitions can be found in file
lisp/unused.el if you need them.
-Upward Compatible Lisp Programming Changes in Emacs 17
+* Upward Compatible Lisp Programming Changes in Emacs 17
-* You can now continue after errors and quits.
+** You can now continue after errors and quits.
When the debugger is entered because of a C-g, due to
a non-`nil' value of `debug-on-quit', the `c' command in the debugger
@@ -513,7 +513,7 @@ is not valid, another error occurs.
Errors signaled with the function `error' cannot be continued.
If you try to continue, the error just happens again.
-* `dot' renamed `point'.
+** `dot' renamed `point'.
The word `dot' has been replaced with `point' in all
function and variable names, including:
@@ -526,7 +526,7 @@ function and variable names, including:
The old names are still supported, for now.
-* `string-match' records position of end of match.
+** `string-match' records position of end of match.
After a successful call to `string-match', `(match-end 0)' will
return the index in the string of the first character after the match.
@@ -534,7 +534,7 @@ Also, `match-begin' and `match-end' with nonzero arguments can be
used to find the indices of beginnings and ends of substrings matched
by subpatterns surrounded by parentheses.
-* New function `insert-before-markers'.
+** New function `insert-before-markers'.
This function is just like `insert' except in the handling of any
relocatable markers that are located at the point of insertion.
@@ -542,7 +542,7 @@ With `insert', such markers end up pointing before the inserted text.
With `insert-before-markers', they end up pointing after the inserted
text.
-* New function `copy-alist'.
+** New function `copy-alist'.
This function takes one argument, a list, and makes a disjoint copy
of the alist structure. The list itself is copied, and each element
@@ -552,30 +552,30 @@ remain shared with the original argument.
This is what it takes to get two alists disjoint enough that changes
in one do not change the result of `assq' on the other.
-* New function `copy-keymap'.
+** New function `copy-keymap'.
This function takes a keymap as argument and returns a new keymap
containing initially the same bindings. Rebindings in either one of
them will not alter the bindings in the other.
-* New function `copy-syntax-table'.
+** New function `copy-syntax-table'.
This function takes a syntax table as argument and returns a new
syntax table containing initially the same syntax settings. Changes
in either one of them will not alter the other.
-* Randomizing the random numbers.
+** Randomizing the random numbers.
`(random t)' causes the random number generator's seed to be set
based on the current time and Emacs's process id.
-* Third argument to `modify-syntax-entry'.
+** Third argument to `modify-syntax-entry'.
The optional third argument to `modify-syntax-entry', if specified
should be a syntax table. The modification is made in that syntax table
rather than in the current syntax table.
-* New function `run-hooks'.
+** New function `run-hooks'.
This function takes any number of symbols as arguments.
It processes the symbols in order. For each symbol which
@@ -584,7 +584,7 @@ called as a function, with no arguments.
This is useful in major mode commands.
-* Second arg to `switch-to-buffer'.
+** Second arg to `switch-to-buffer'.
If this function is given a non-`nil' second argument, then the
selection being done is not recorded on the selection history.
@@ -592,7 +592,7 @@ The buffer's position in the history remains unchanged. This
feature is used by the view commands, so that the selection history
after exiting from viewing is the same as it was before.
-* Second arg to `display-buffer' and `pop-to-buffer'.
+** Second arg to `display-buffer' and `pop-to-buffer'.
These two functions both accept an optional second argument which
defaults to `nil'. If the argument is not `nil', it means that
@@ -602,7 +602,7 @@ the selected window.
This feature is used by `switch-to-buffer-other-window'.
-* New variable `completion-ignore-case'.
+** New variable `completion-ignore-case'.
If this variable is non-`nil', completion allows strings
in different cases to be considered matching. The global value
@@ -614,13 +614,13 @@ to change the value globally, but you might not like the consequences
in the many situations (buffer names, command names, file names)
where case makes a difference.
-* Major modes related to Text mode call text-mode-hook, then their own hooks.
+** Major modes related to Text mode call text-mode-hook, then their own hooks.
For example, turning on Outline mode first calls the value of
`text-mode-hook' as a function, if it exists and is non-`nil',
and then does likewise for the variable `outline-mode-hook'.
-* Defining new command line switches.
+** Defining new command line switches.
You can define a new command line switch in your .emacs file
by putting elements on the value of `command-switch-alist'.
@@ -638,26 +638,26 @@ examine this variable, and do
(setq command-line-args (cdr command-line-args)
to "use up" an argument.
-* New variable `load-in-progress'.
+** New variable `load-in-progress'.
This variable is non-`nil' when a file of Lisp code is being read
and executed by `load'.
-* New variable `print-length'.
+** New variable `print-length'.
The value of this variable is normally `nil'. It may instead be
a number; in that case, when a list is printed by `prin1' or
`princ' only that many initial elements are printed; the rest are
replaced by `...'.
-* New variable `find-file-not-found-hook'.
+** New variable `find-file-not-found-hook'.
If `find-file' or any of its variants is used on a nonexistent file,
the value of `find-file-not-found-hook' is called (if it is not `nil')
with no arguments, after creating an empty buffer. The file's name
can be found as the value of `buffer-file-name'.
-* Processes without buffers.
+** Processes without buffers.
In the function `start-process', you can now specify `nil' as
the process's buffer. You can also set a process's buffer to `nil'
@@ -672,7 +672,7 @@ When a process has no buffer, its output is lost unless it has a
filter, and no indication of its being stopped or killed is given
unless it has a sentinel.
-* New function `user-variable-p'. `v' arg prompting changed.
+** New function `user-variable-p'. `v' arg prompting changed.
This function takes a symbol as argument and returns `t' if
the symbol is defined as a user option variable. This means
@@ -686,7 +686,7 @@ user variables.
The function `read-variable' also now accepts and completes
over user variables only.
-* CBREAK mode input is the default in Unix 4.3 bsd.
+** CBREAK mode input is the default in Unix 4.3 bsd.
In Berkeley 4.3 Unix, there are sufficient features for Emacs to
work fully correctly using CBREAK mode and not using SIGIO.
@@ -695,7 +695,7 @@ This mode corresponds to `nil' as the first argument to
`set-input-mode'. You can still select either mode by calling
that function.
-* Information on memory usage.
+** Information on memory usage.
The new variable `data-bytes-used' contains the number
of bytes of impure space allocated in Emacs.
@@ -704,18 +704,18 @@ Emacs could allocate. Note that space formerly allocated
and freed again still counts as `used', since it is still
in Emacs's address space.
-* No limit on size of output from `format'.
+** No limit on size of output from `format'.
The string output from `format' used to be truncated to
100 characters in length. Now it can have any length.
-* New errors `void-variable' and `void-function' replace `void-symbol'.
+** New errors `void-variable' and `void-function' replace `void-symbol'.
This change makes it possible to have error messages that
clearly distinguish undefined variables from undefined functions.
It also allows `condition-case' to handle one case without the other.
-* `replace-match' handling of `\'.
+** `replace-match' handling of `\'.
In `replace-match', when the replacement is not literal,
`\' in the replacement string is always treated as an
@@ -728,19 +728,19 @@ This level of escaping is comparable with what goes on in
a regular expression. It is over and above the level of `\'
escaping that goes on when strings are read in Lisp syntax.
-* New error `invalid-regexp'.
+** New error `invalid-regexp'.
A regexp search signals this type of error if the argument does
not meet the rules for regexp syntax.
-* `kill-emacs' with argument.
+** `kill-emacs' with argument.
If the argument is a number, it is returned as the exit status code
of the Emacs process. If the argument is a string, its contents
are stuffed as pending terminal input, to be read by another program
after Emacs is dead.
-* New fifth argument to `subst-char-in-region'.
+** New fifth argument to `subst-char-in-region'.
This argument is optional and defaults to `nil'. If it is not `nil',
then the substitutions made by this function are not recorded
@@ -749,7 +749,7 @@ in the Undo mechanism.
This feature should be used with great care. It is now used
by Outline mode to make lines visible or invisible.
-* ` *Backtrace*' buffer renamed to `*Backtrace*'.
+** ` *Backtrace*' buffer renamed to `*Backtrace*'.
As a result, you can now reselect this buffer easily if you switch to
another while in the debugger.
@@ -757,7 +757,7 @@ another while in the debugger.
Exiting from the debugger kills the `*Backtrace*' buffer, so you will
not try to give commands in it when no longer really in the debugger.
-* New function `switch-to-buffer-other-window'.
+** New function `switch-to-buffer-other-window'.
This is the new primitive to select a specified buffer (the
argument) in another window. It is not quite the same as
@@ -768,7 +768,7 @@ leave the current window's old buffer displayed as well.
All functions to select a buffer in another window should
do so by calling this new function.
-* New variable `minibuffer-help-form'.
+** New variable `minibuffer-help-form'.
At entry to the minibuffer, the variable `help-form' is bound
to the value of `minibuffer-help-form'.
@@ -779,7 +779,7 @@ the definition of C-h as a command). `minibuffer-help-form'
can be used to provide a different default way of handling
C-h while in the minibuffer.
-* New \{...} documentation construct.
+** New \{...} documentation construct.
It is now possible to set up the documentation string for
a major mode in such a way that it always describes the contents
@@ -799,23 +799,23 @@ For example, the documentation string for the function `c-mode' contains
Variables controlling indentation style:
...
-* New character syntax class "punctuation".
+** New character syntax class "punctuation".
Punctuation characters behave like whitespace in word and
list parsing, but can be distinguished in regexps and in the
function `char-syntax'. Punctuation syntax is represented by
a period in `modify-syntax-entry'.
-* `auto-mode-alist' no longer needs entries for backup-file names,
+** `auto-mode-alist' no longer needs entries for backup-file names,
Backup suffixes of all kinds are now stripped from a file's name
before searching `auto-mode-alist'.
-Changes in Emacs 16
+* Changes in Emacs 16
-* No special code for Ambassadors, VT-100's and Concept-100's.
+** No special code for Ambassadors, VT-100's and Concept-100's.
Emacs now controls these terminals based on the termcap entry, like
all other terminals. Formerly it did not refer to the termcap entries
@@ -827,24 +827,24 @@ fixing up the termcap entry. See ./TERMS for more info.
See ./TERMS in any case if you find that some terminal does not work
right with Emacs now.
-* Minibuffer default completion character is TAB (and not ESC).
+** Minibuffer default completion character is TAB (and not ESC).
So that ESC can be used in minibuffer for more useful prefix commands.
-* C-z suspends Emacs in all modes.
+** C-z suspends Emacs in all modes.
Formerly, C-z was redefined for other purposes by certain modes,
such as Buffer Menu mode. Now other keys are used for those purposes,
to keep the meaning of C-z uniform.
-* C-x ESC (repeat-complex-command) allows editing the command it repeats.
+** C-x ESC (repeat-complex-command) allows editing the command it repeats.
Instead of asking for confirmation to re-execute a command from the
command history, the command is placed, in its Lisp form, into the
minibuffer for editing. You can confirm by typing RETURN, change some
arguments and then confirm, or abort with C-g.
-* Incremental search does less redisplay on slow terminals.
+** Incremental search does less redisplay on slow terminals.
If the terminal baud rate is <= the value of `isearch-slow-speed',
incremental searching outside the text on the screen creates
@@ -857,7 +857,7 @@ The initial value of `isearch-slow-speed' is 1200.
This feature is courtesy of crl@purdue.
-* Recursive minibuffers not allowed.
+** Recursive minibuffers not allowed.
If the minibuffer window is selected, most commands that would
use the minibuffer gets an error instead. (Specific commands
@@ -873,7 +873,7 @@ you can probably understand recursive minibuffers.
This may be overridden by binding the variable
`enable-recursive-minibuffers' to t.
-* New major mode Emacs-Lisp mode, for editing Lisp code to run in Emacs.
+** New major mode Emacs-Lisp mode, for editing Lisp code to run in Emacs.
The mode in which emacs lisp files is edited is now called emacs-lisp-mode
and is distinct from lisp-mode. The latter is intended for use with
@@ -884,7 +884,7 @@ called emacs-lisp-mode-hook. A consequence of this changes is that
.emacs init files which set the value of lisp-mode-hook may need to be
changed to use the new names.
-* Correct matching of parentheses is checked on insertion.
+** Correct matching of parentheses is checked on insertion.
When you insert a close-paren, the matching open-paren
is checked for validity. The close paren must be the kind
@@ -894,9 +894,9 @@ preceded by quoting backslash syntax character is not matched.
This feature was originally written by shane@mit-ajax.
-* M-x list-command-history
-* M-x command-history-mode
-* M-x electric-command-history
+** M-x list-command-history
+** M-x command-history-mode
+** M-x electric-command-history
`list-command-history' displays forms from the command history subject
to user controlled filtering and limit on number of forms. It leaves
@@ -913,7 +913,7 @@ which invoked `electric-command-history'. The original window
configuration is restored on exit unless the command selected changes
it.
-* M-x edit-picture
+** M-x edit-picture
Enters a temporary major mode (the previous major mode is remembered
and can is restored on exit) designed for editing pictures and tables.
@@ -926,7 +926,7 @@ the documentation of function edit-picture for more details.
Calls value of `edit-picture-hook' on entry if non-nil.
-* Stupid C-s/C-q `flow control' supported.
+** Stupid C-s/C-q `flow control' supported.
Do (set-input-mode nil t) to tell Emacs to use CBREAK mode and interpret
C-s and C-q as flow control commands. (set-input-mode t nil) switches
@@ -955,18 +955,18 @@ The configuration switch CBREAK_INPUT is now eliminated.
INTERRUPT_INPUT exists only to specify the default mode of operation;
#define it to make interrupt-driven input the default.
-* Completion of directory names provides a slash.
+** Completion of directory names provides a slash.
If file name completion yields the name of a directory,
a slash is appended to it.
-* Undo can clear modified-flag.
+** Undo can clear modified-flag.
If you undo changes in a buffer back to a state in which the
buffer was not considered "modified", then it is labeled as
once again "unmodified".
-* M-x run-lisp.
+** M-x run-lisp.
This command creates an inferior Lisp process whose input and output
appear in the Emacs buffer named `*lisp*'. That buffer uses a major mode
@@ -977,21 +977,21 @@ lisp-mode-hook, in that order, if non-nil.
Meanwhile, in lisp-mode, the command C-M-x is defined to
send the current defun as input to the `*lisp*' subprocess.
-* Mode line says `Narrow' when buffer is clipped.
+** Mode line says `Narrow' when buffer is clipped.
If a buffer has a clipping restriction (made by `narrow-to-region')
then its mode line contains the word `Narrow' after the major and
minor modes.
-* Mode line says `Abbrev' when abbrev mode is on.
+** Mode line says `Abbrev' when abbrev mode is on.
-* add-change-log-entry takes prefix argument
+** add-change-log-entry takes prefix argument
Giving a prefix argument makes it prompt for login name, full name,
and site name, with defaults. Otherwise the defaults are used
with no confirmation.
-* M-x view-buffer and M-x view-file
+** M-x view-buffer and M-x view-file
view-buffer selects the named buffer, view-file finds the named file; the
resulting buffer is placed into view-mode (a recursive edit). The normal
@@ -1004,7 +1004,7 @@ Each calls value of `view-hook' if non-nil on entry.
written by shane@mit-ajax.
-* New key commands in dired.
+** New key commands in dired.
`v' views (like more) the file on the current line.
`#' marks auto-save files for deletion.
@@ -1014,7 +1014,7 @@ file is renamed to same directory.
`c' copies a file and updates the directory listing if the file is
copied to the same directory.
-* New function `electric-buffer-list'.
+** New function `electric-buffer-list'.
This pops up a buffer describing the set of emacs buffers.
Immediately typing space makes the buffer list go away and returns
@@ -1032,15 +1032,15 @@ Type C-h after invoking electric-buffer-list for more information.
Calls value of `electric-buffer-menu-mode-hook' if non-nil on entry.
Calls value of `after-electric-buffer-menu' on exit (select) if non-nil.
-Changes in version 16 for mail reading and sending
+** Changes in version 16 for mail reading and sending
-* sendmail prefix character is C-c (and not C-z). New command C-c w.
+*** sendmail prefix character is C-c (and not C-z). New command C-c w.
For instance C-c C-c (or C-c C-s) sends mail now rather than C-z C-z.
C-c w inserts your `signature' (contents of ~/.signature) at the end
of mail.
-* New feature in C-c y command in sending mail.
+*** New feature in C-c y command in sending mail.
C-c y is the command to insert the message being replied to.
Normally it deletes most header fields and indents everything
@@ -1050,7 +1050,7 @@ Now, C-c y does not delete header fields or indent.
C-c y with any other numeric argument does delete most header
fields, but indents by the amount specified in the argument.
-* C-r command in Rmail edits current message.
+*** C-r command in Rmail edits current message.
It does this by switching to a different major mode
which is nearly the same as Text mode. The only difference
@@ -1063,31 +1063,31 @@ C-c and C-] are the only ways "back into Rmail", but you
can switch to other buffers and edit them as usual.
C-r in Rmail changes only the handling of the Rmail buffer.
-* Rmail command `t' toggles header display.
+*** Rmail command `t' toggles header display.
Normally Rmail reformats messages to hide most header fields.
`t' switches to display of all the header fields of the
current message, as long as it remains current.
Another `t' switches back to the usual display.
-* Rmail command '>' goes to the last message.
+*** Rmail command '>' goes to the last message.
-* Rmail commands `a' and `k' set message attributes.
+*** Rmail commands `a' and `k' set message attributes.
`a' adds an attribute and `k' removes one. You specify
the attribute by name. You can specify either a built-in
flag such as "deleted" or "filed", or a user-defined keyword
(anything not recognized as built-in).
-* Rmail commands `l' and `L' summarize by attributes.
+*** Rmail commands `l' and `L' summarize by attributes.
These commands create a summary with one line per message,
like `h', but they list only some of the messages. You
specify which attribute (for `l') or attributes (for `L')
the messages should have.
-* Rmail can parse mmdf mail files.
+*** Rmail can parse mmdf mail files.
-* Interface to MH mail system.
+*** Interface to MH mail system.
mh-e is a front end for GNU emacs and the MH mail system. It
provides a friendly and convenient interface to the MH commands.
@@ -1103,9 +1103,9 @@ compiler switch.
From larus@berkeley.
-New hooks and parameters in version 16
+** New hooks and parameters in version 16
-* New variable `blink-matching-paren-distance'.
+*** New variable `blink-matching-paren-distance'.
This is the maximum number of characters to search for
an open-paren to match an inserted close-paren.
@@ -1118,13 +1118,13 @@ open-paren is found.
This feature was originally written by shane@mit-ajax.
-* New variable `find-file-run-dired'
+*** New variable `find-file-run-dired'
If nil, find-file will report an error if an attempt to visit a
directory is detected; otherwise, it runs dired on that directory.
The default is t.
-* Variable `dired-listing-switches' holds switches given to `ls' by dired.
+*** Variable `dired-listing-switches' holds switches given to `ls' by dired.
The value should be a string containing `-' followed by letters.
The letter `l' had better be included and letter 'F' had better be excluded!
@@ -1132,12 +1132,12 @@ The default is "-al".
This feature was originally written by shane@mit-ajax.
-* New variable `display-time-day-and-date'.
+*** New variable `display-time-day-and-date'.
If this variable is set non-`nil', the function M-x display-time
displays the day and date, as well as the time.
-* New parameter `c-continued-statement-indent'.
+*** New parameter `c-continued-statement-indent'.
This controls the extra indentation given to a line
that continues a C statement started on the previous line.
@@ -1147,7 +1147,7 @@ By default it is 2, which is why you would see
bar ();
-* Changed meaning of `c-indent-level'.
+*** Changed meaning of `c-indent-level'.
The value of `c-brace-offset' used to be
subtracted from the value of `c-indent-level' whenever
@@ -1157,20 +1157,20 @@ As a result, `c-indent-level' is now the offset of
statements within a block, relative to the line containing
the open-brace that starts the block.
-* turn-on-auto-fill is useful value for text-mode-hook.
+*** turn-on-auto-fill is useful value for text-mode-hook.
(setq text-mode-hook 'turn-on-auto-fill)
is all you have to do to make sure Auto Fill mode is turned
on whenever you enter Text mode.
-* Parameter explicit-shell-file-name for M-x shell.
+*** Parameter explicit-shell-file-name for M-x shell.
This variable, if non-nil, specifies the file name to use
for the shell to run if you do M-x shell.
Changes in version 16 affecting Lisp programming:
-* Documentation strings adapt to customization.
+*** Documentation strings adapt to customization.
Often the documentation string for a command wants to mention
another command. Simply stating the other command as a
@@ -1201,12 +1201,12 @@ The new function `substitute-command-keys' takes a string possibly
containing \[...] constructs and replaces those constructs with
the key sequences they currently stand for.
-* Primitives `find-line-comment' and `find-line-comment-body' flushed.
+*** Primitives `find-line-comment' and `find-line-comment-body' flushed.
Search for the value of `comment-start-skip' if you want to find
whether and where a line has a comment.
-* New function `auto-save-file-name-p'
+*** New function `auto-save-file-name-p'
Should return non-`nil' if given a string which is the name of an
auto-save file (sans directory name). If you redefine
@@ -1214,11 +1214,11 @@ auto-save file (sans directory name). If you redefine
default, this function returns `t' for filenames beginning with
character `#'.
-* The value of `exec-directory' now ends in a slash.
+*** The value of `exec-directory' now ends in a slash.
This is to be compatible with most directory names in GNU Emacs.
-* Dribble files and termscript files.
+*** Dribble files and termscript files.
(open-dribble-file FILE) opens a dribble file named FILE. When a
dribble file is open, every character Emacs reads from the terminal is
@@ -1231,51 +1231,51 @@ are also written in the termscript file.
The two of these together are very useful for debugging Emacs problems
in redisplay.
-* Upper case command characters by default are same as lower case.
+*** Upper case command characters by default are same as lower case.
If a character in a command is an upper case letter, and is not defined,
Emacs uses the definition of the corresponding lower case letter.
For example, if C-x U is not directly undefined, it is treated as
a synonym for C-x u (undo).
-* Undefined function errors versus undefined variable errors.
+*** Undefined function errors versus undefined variable errors.
Void-symbol errors now say "boundp" if the symbol's value was void
or "fboundp" if the function definition was void.
-* New function `bury-buffer'.
+*** New function `bury-buffer'.
The new function `bury-buffer' takes one argument, a buffer object,
and puts that buffer at the end of the internal list of buffers.
So it is the least preferred candidate for use as the default value
of C-x b, or for other-buffer to return.
-* Already-displayed buffers have low priority for display.
+*** Already-displayed buffers have low priority for display.
When a buffer is chosen automatically for display, or to be the
default in C-x b, buffers already displayed in windows have lower
priority than buffers not currently visible.
-* `set-window-start' accepts a third argument NOFORCE.
+*** `set-window-start' accepts a third argument NOFORCE.
This argument, if non-nil, prevents the window's force_start flag
from being set. Setting the force_start flag causes the next
redisplay to insist on starting display at the specified starting
point, even if dot must be moved to get it onto the screen.
-* New function `send-string-to-terminal'.
+*** New function `send-string-to-terminal'.
This function takes one argument, a string, and outputs its contents
to the terminal exactly as specified: control characters, escape
sequences, and all.
-* Keypad put in command mode.
+*** Keypad put in command mode.
The terminal's keypad is now put into command mode, as opposed to
numeric mode, while Emacs is running. This is done by means of the
termcap `ks' and `ke' strings.
-* New function `generate-new-buffer'
+*** New function `generate-new-buffer'
This function takes a string as an argument NAME and looks for a
creates and returns a buffer called NAME if one did not already exist.
@@ -1283,12 +1283,12 @@ Otherwise, it successively tries appending suffixes of the form "<1>",
"<2>" etc to NAME until it creates a string which does not name an
existing buffer. A new buffer with that name is the created and returned.
-* New function `prin1-to-string'
+*** New function `prin1-to-string'
This function takes one argument, a lisp object, and returns a string
containing that object's printed representation, such as `prin1'
would output.
-* New function `read-from-minibuffer'
+*** New function `read-from-minibuffer'
Lets you supply a prompt, initial-contents, a keymap, and specify
whether the result should be interpreted as a string or a lisp object.
@@ -1296,23 +1296,23 @@ Old functions `read-minibuffer', `eval-minibuffer', `read-string' all
take second optional string argument which is initial contents of
minibuffer.
-* minibuffer variable names changed (names of keymaps)
+*** minibuffer variable names changed (names of keymaps)
minibuf-local-map -> minibuffer-local-map
minibuf-local-ns-map -> minibuffer-local-ns-map
minibuf-local-completion-map -> minibuffer-local-completion-map
minibuf-local-must-match-map -> minibuffer-local-must-match-map
-Changes in version 16 affecting configuring and building Emacs
+** Changes in version 16 affecting configuring and building Emacs
-* Configuration switch VT100_INVERSE eliminated.
+*** Configuration switch VT100_INVERSE eliminated.
You can control the use of inverse video on any terminal by setting
the variable `inverse-video', or by changing the termcap entry. If
you like, set `inverse-video' in your `.emacs' file based on
examination of (getenv "TERM").
-* New switch `-batch' makes Emacs run noninteractively.
+*** New switch `-batch' makes Emacs run noninteractively.
If the switch `-batch' is used, Emacs treats its standard output
and input like ordinary files (even if they are a terminal).
@@ -1330,22 +1330,22 @@ way to accomplish this.
The Lisp variable `noninteractive' is now defined, to be `nil'
except when `-batch' has been specified.
-* Emacs can be built with output redirected to a file.
+*** Emacs can be built with output redirected to a file.
This is because -batch (see above) is now used in building Emacs.
-Changes in Emacs 15
+* Changes in Emacs 15
-* Emacs now runs on Sun and Megatest 68000 systems;
+** Emacs now runs on Sun and Megatest 68000 systems;
also on at least one 16000 system running 4.2.
-* Emacs now alters the output-start and output-stop characters
+** Emacs now alters the output-start and output-stop characters
to prevent C-s and C-q from being considered as flow control
by cretinous rlogin software in 4.2.
-* It is now possible convert Mocklisp code (for Gosling Emacs) to Lisp code
+** It is now possible convert Mocklisp code (for Gosling Emacs) to Lisp code
that can run in GNU Emacs. M-x convert-mocklisp-buffer
converts the contents of the current buffer from Mocklisp to
GNU Emacs Lisp. You should then save the converted buffer with C-x C-w
@@ -1365,7 +1365,7 @@ Changes in Emacs 15
to GNU lisp code, with M-x convert-mocklisp-buffer being the first
step in this process.
-* Control-x n (narrow-to-region) is now by default a disabled command.
+** Control-x n (narrow-to-region) is now by default a disabled command.
This means that, if you issue this command, it will ask whether
you really mean it. You have the opportunity to enable the
@@ -1373,7 +1373,7 @@ Changes in Emacs 15
This will place the form "(put 'narrow-to-region 'disabled nil)" in your
.emacs file.
-* Tags now prompts for the tag table file name to use.
+** Tags now prompts for the tag table file name to use.
All the tags commands ask for the tag table file name
if you have not yet specified one.
@@ -1382,12 +1382,12 @@ Changes in Emacs 15
specify the tag table file name initially, or to switch
to a new tag table.
-* If truncate-partial-width-windows is non-nil (as it initially is),
+** If truncate-partial-width-windows is non-nil (as it initially is),
all windows less than the full screen width (that is,
made by side-by-side splitting) truncate lines rather than continuing
them.
-* Emacs now checks for Lisp stack overflow to avoid fatal errors.
+** Emacs now checks for Lisp stack overflow to avoid fatal errors.
The depth in eval, apply and funcall may not exceed max-lisp-eval-depth.
The depth in variable bindings and unwind-protects may not exceed
max-specpdl-size. If either limit is exceeded, an error occurs.
@@ -1395,7 +1395,7 @@ Changes in Emacs 15
too large, you are vulnerable to a fatal error if you invoke
Lisp code that does infinite recursion.
-* New hooks find-file-hook and write-file-hook.
+** New hooks find-file-hook and write-file-hook.
Both of these variables if non-nil should be functions of no arguments.
At the time they are called (current-buffer) will be the buffer being
read or written respectively.
@@ -1409,13 +1409,13 @@ Changes in Emacs 15
write-file-hook is called just before writing out a file from a buffer.
-* The initial value of shell-prompt-pattern is now "^[^#$%>]*[#$%>] *"
+** The initial value of shell-prompt-pattern is now "^[^#$%>]*[#$%>] *"
-* If the .emacs file sets inhibit-startup-message to non-nil,
+** If the .emacs file sets inhibit-startup-message to non-nil,
the messages normally printed by Emacs at startup time
are inhibited.
-* Facility for run-time conditionalization on the basis of emacs features.
+** Facility for run-time conditionalization on the basis of emacs features.
The new variable features is a list of symbols which represent "features"
of the executing emacs, for use in run-time conditionalization.
@@ -1438,14 +1438,14 @@ Changes in Emacs 15
(if (not featurep FEATURE) (error ...))))
FILE-NAME is optional and defaults to FEATURE.
-* New function load-average.
+** New function load-average.
This returns a list of three integers, which are
the current 1 minute, 5 minute and 15 minute load averages,
each multiplied by a hundred (since normally they are floating
point numbers).
-* Per-terminal libraries loaded automatically.
+** Per-terminal libraries loaded automatically.
Emacs when starting up on terminal type T automatically loads
a library named term-T. T is the value of the TERM environment variable.
@@ -1457,7 +1457,7 @@ Changes in Emacs 15
redefinitions and let the user's init file, which is loaded later,
call that command or not, as the user prefers.
-* Programmer's note: detecting killed buffers.
+** Programmer's note: detecting killed buffers.
Buffers are eliminated by explicitly killing them, using
the function kill-buffer. This does not eliminate or affect
@@ -1466,7 +1466,7 @@ Changes in Emacs 15
the buffer has been killed, use the function buffer-name.
It returns nil on a killed buffer, and a string on a live buffer.
-* New ways to access the last command input character.
+** New ways to access the last command input character.
The function last-key-struck, which used to return the last
input character that was read by command input, is eliminated.
@@ -1479,13 +1479,13 @@ Changes in Emacs 15
read for. last-input-char and last-command-char are different
only inside a command that has called read-char to read input.
-* The new switch -kill causes Emacs to exit after processing the
+** The new switch -kill causes Emacs to exit after processing the
preceding command line arguments. Thus,
emacs -l lib data -e do-it -kill
means to load lib, find file data, call do-it on no arguments,
and then exit.
-* The config.h file has been modularized.
+** The config.h file has been modularized.
Options that depend on the machine you are running on are defined
in a file whose name starts with "m-", such as m-vax.h.
@@ -1499,25 +1499,25 @@ Changes in Emacs 15
select the correct m- and s- files but will never have to change their
contents.
-* Termcap AL and DL strings are understood.
+** Termcap AL and DL strings are understood.
If the termcap entry defines AL and DL strings, for insertion
and deletion of multiple lines in one blow, Emacs now uses them.
This matters most on certain bit map display terminals for which
scrolling is comparatively slow.
-* Bias against scrolling screen far on fast terminals.
+** Bias against scrolling screen far on fast terminals.
Emacs now prefers to redraw a few lines rather than
shift them a long distance on the screen, when the terminal is fast.
-* New major mode, mim-mode.
+** New major mode, mim-mode.
This major mode is for editing MDL code. Perhaps a MDL
user can explain why it is not called mdl-mode.
You must load the library mim-mode explicitly to use this.
-* GNU documentation formatter `texinfo'.
+** GNU documentation formatter `texinfo'.
The `texinfo' library defines a format for documentation
files which can be passed through Tex to make a printed manual
@@ -1532,7 +1532,7 @@ Changes in Emacs 15
This is not ready for distribution yet, but will appear at
a later time.
-* New function read-from-string (emacs 15.29)
+** New function read-from-string (emacs 15.29)
read-from-string takes three arguments: a string to read from,
and optionally start and end indices which delimit a substring
@@ -1551,14 +1551,14 @@ Changes in Emacs 15
-Changes in Emacs 14
+* Changes in Emacs 14
-* Completion now prints various messages such as [Sole Completion]
+** Completion now prints various messages such as [Sole Completion]
or [Next Character Not Unique] to describe the results obtained.
These messages appear after the text in the minibuffer, and remain
on the screen until a few seconds go by or you type a key.
-* The buffer-read-only flag is implemented.
+** The buffer-read-only flag is implemented.
Setting or binding this per-buffer variable to a non-nil value
makes illegal any operation which would modify the textual content of
the buffer. (Such operations signal a buffer-read-only error)
@@ -1568,12 +1568,12 @@ Changes in Emacs 14
by default to prevent accidental damage to the information in those
buffers.
-* Functions car-safe and cdr-safe.
+** Functions car-safe and cdr-safe.
These functions are like car and cdr when the argument is a cons.
Given an argument not a cons, car-safe always returns nil, with
no error; the same for cdr-safe.
-* The new function user-real-login-name returns the name corresponding
+** The new function user-real-login-name returns the name corresponding
to the real uid of the Emacs process. This is usually the same
as what user-login-name returns; however, when Emacs is invoked
from su, user-real-login-name returns "root" but user-login-name
@@ -1581,9 +1581,9 @@ Changes in Emacs 14
-Changes in Emacs 13
+* Changes in Emacs 13
-* There is a new version numbering scheme.
+** There is a new version numbering scheme.
What used to be the first version number, which was 1,
has been discarded since it does not seem that I need three
@@ -1594,7 +1594,7 @@ Changes in Emacs 13
Emacs when I distribute it; it will be incremented each time
Emacs is built at another site.
-* There is now a reader syntax for Meta characters:
+** There is now a reader syntax for Meta characters:
\M-CHAR means CHAR or'ed with the Meta bit. For example:
?\M-x is (+ ?x 128)
@@ -1608,7 +1608,7 @@ Changes in Emacs 13
?\C- can be used likewise for control characters. (13.9)
-* Installation change
+** Installation change
The string "../lisp" now adds to the front of the load-path
used for searching for Lisp files during Emacs initialization.
It used to replace the path specified in paths.h entirely.
@@ -1617,13 +1617,13 @@ Changes in Emacs 13
-Changes in Emacs 1.12
+* Changes in Emacs 1.12
-* There is a new installation procedure.
+** There is a new installation procedure.
See the file INSTALL that comes in the top level
directory in the tar file or tape.
-* The Meta key is now supported on terminals that have it.
+** The Meta key is now supported on terminals that have it.
This is a shift key which causes the high bit to be turned on
in all input characters typed while it is held down.
@@ -1643,10 +1643,10 @@ Changes in Emacs 1.12
explicitly, but not effective if the character comes from
the use of the Meta key.
-* `-' is no longer a completion command in the minibuffer.
+** `-' is no longer a completion command in the minibuffer.
It is an ordinary self-inserting character.
-* The list load-path of directories load to search for Lisp files
+** The list load-path of directories load to search for Lisp files
is now controlled by the EMACSLOADPATH environment variable
[[ Note this was originally EMACS-LOAD-PATH and has been changed
again; sh does not deal properly with hyphens in env variable names]]
@@ -1658,7 +1658,7 @@ Changes in Emacs 1.12
ignore EMACSLOADPATH, however; you should avoid having
this variable set while building Emacs.
-* You can now specify a translation table for keyboard
+** You can now specify a translation table for keyboard
input characters, as a way of exchanging or substituting
keys on the keyboard.
@@ -1709,20 +1709,20 @@ Changes in Emacs 1.12
(aset keyboard-translate-table (+ 128 ?\_) (+ 128 ?\^?))
(aset keyboard-translate-table (+ 128 ?\^?) (+ 128 ?\_))
-* (process-kill-without-query PROCESS)
+** (process-kill-without-query PROCESS)
This marks the process so that, when you kill Emacs,
you will not on its account be queried about active subprocesses.
-Changes in Emacs 1.11
+* Changes in Emacs 1.11
-* The commands C-c and C-z have been interchanged,
+** The commands C-c and C-z have been interchanged,
for greater compatibility with normal Unix usage.
C-z now runs suspend-emacs and C-c runs exit-recursive-edit.
-* The value returned by file-name-directory now ends
+** The value returned by file-name-directory now ends
with a slash. (file-name-directory "foo/bar") => "foo/".
This avoids confusing results when dealing with files
in the root directory.
@@ -1730,13 +1730,13 @@ Changes in Emacs 1.11
The value of the per-buffer variable default-directory
is also supposed to have a final slash now.
-* There are now variables to control the switches passed to
+** There are now variables to control the switches passed to
`ls' by the C-x C-d command (list-directory).
list-directory-brief-switches is a string, initially "-CF",
used for brief listings, and list-directory-verbose-switches
is a string, initially "-l", used for verbose ones.
-* For Ann Arbor Ambassador terminals, the termcap "ti" string
+** For Ann Arbor Ambassador terminals, the termcap "ti" string
is now used to initialize the screen geometry on entry to Emacs,
and the "te" string is used to set it back on exit.
If the termcap entry does not define the "ti" or "te" string,
@@ -1744,36 +1744,36 @@ Changes in Emacs 1.11
-Changes in Emacs 1.10
+* Changes in Emacs 1.10
-* GNU Emacs has been made almost 1/3 smaller.
+** GNU Emacs has been made almost 1/3 smaller.
It now dumps out as only 530kbytes on Vax 4.2bsd.
-* The term "checkpoint" has been replaced by "auto save"
+** The term "checkpoint" has been replaced by "auto save"
throughout the function names, variable names and documentation
of GNU Emacs.
-* The function load now tries appending ".elc" and ".el"
+** The function load now tries appending ".elc" and ".el"
to the specified filename BEFORE it tries the filename
without change.
-* rmail now makes the mode line display the total number
+** rmail now makes the mode line display the total number
of messages and the current message number.
The "f" command now means forward a message to another user.
The command to search through all messages for a string is now "F".
The "u" command now means to move back to the previous
message and undelete it. To undelete the selected message, use Meta-u.
-* The hyphen character is now equivalent to a Space while
+** The hyphen character is now equivalent to a Space while
in completing minibuffers. Both mean to complete an additional word.
-* The Lisp function error now takes args like format
+** The Lisp function error now takes args like format
which are used to construct the error message.
-* Redisplay will refuse to start its display at the end of the buffer.
+** Redisplay will refuse to start its display at the end of the buffer.
It will pick a new place to display from, rather than use that.
-* The value returned by garbage-collect has been changed.
+** The value returned by garbage-collect has been changed.
Its first element is no longer a number but a cons,
whose car is the number of cons cells now in use,
and whose cdr is the number of cons cells that have been
@@ -1781,42 +1781,42 @@ Changes in Emacs 1.10
The second element is similar but describes symbols rather than cons cells.
The third element is similar but describes markers.
-* The variable buffer-name has been eliminated.
+** The variable buffer-name has been eliminated.
The function buffer-name still exists. This is to prevent
user programs from changing buffer names without going
through the rename-buffer function.
-Changes in Emacs 1.9
+* Changes in Emacs 1.9
-* When a fill prefix is in effect, paragraphs are started
+** When a fill prefix is in effect, paragraphs are started
or separated by lines that do not start with the fill prefix.
Also, a line which consists of the fill prefix followed by
white space separates paragraphs.
-* C-x C-v runs the new function find-alternate-file.
+** C-x C-v runs the new function find-alternate-file.
It finds the specified file, switches to that buffer,
and kills the previous current buffer. (It requires
confirmation if that buffer had changes.) This is
most useful after you find the wrong file due to a typo.
-* Exiting the minibuffer moves the cursor to column 0,
+** Exiting the minibuffer moves the cursor to column 0,
to show you that it has really been exited.
-* Meta-g (fill-region) now fills each paragraph in the
+** Meta-g (fill-region) now fills each paragraph in the
region individually. To fill the region as if it were
a single paragraph (for when the paragraph-delimiting mechanism
does the wrong thing), use fill-region-as-paragraph.
-* Tab in text mode now runs the function tab-to-tab-stop.
+** Tab in text mode now runs the function tab-to-tab-stop.
A new mode called indented-text-mode is like text-mode
except that in it Tab runs the function indent-relative,
which indents the line under the previous line.
If auto fill is enabled while in indented-text-mode,
the new lines that it makes are indented.
-* Functions kill-rectangle and yank-rectangle.
+** Functions kill-rectangle and yank-rectangle.
kill-rectangle deletes the rectangle specified by dot and mark
(or by two arguments) and saves it in the variable killed-rectangle.
yank-rectangle inserts the rectangle in that variable.
@@ -1826,7 +1826,7 @@ Changes in Emacs 1.9
not be changed if the rectangle is later reinserted
at a different column position.
-* `+' in a regular expression now means
+** `+' in a regular expression now means
to repeat the previous expression one or more times.
`?' means to repeat it zero or one time.
They are in all regards like `*' except for the
@@ -1836,19 +1836,19 @@ Changes in Emacs 1.9
when it is at the beginning of a word; \> matches
the null string at the end of a word.
-* C-x p narrows the buffer so that only the current page
+** C-x p narrows the buffer so that only the current page
is visible.
-* C-x ) with argument repeats the kbd macro just
+** C-x ) with argument repeats the kbd macro just
defined that many times, counting the definition
as one repetition.
-* C-x ( with argument begins defining a kbd macro
+** C-x ( with argument begins defining a kbd macro
starting with the last one defined. It executes that
previous kbd macro initially, just as if you began
by typing it over again.
-* C-x q command queries the user during kbd macro execution.
+** C-x q command queries the user during kbd macro execution.
With prefix argument, enters recursive edit,
reading keyboard commands even within a kbd macro.
You can give different commands each time the macro executes.
@@ -1859,7 +1859,7 @@ Changes in Emacs 1.9
C-r -- enter a recursive edit, then on exit ask again for a character
C-l -- redisplay screen and ask again."
-* write-kbd-macro and append-kbd-macro are used to save
+** write-kbd-macro and append-kbd-macro are used to save
a kbd macro definition in a file (as Lisp code to
redefine the macro when the file is loaded).
These commands differ in that write-kbd-macro
@@ -1868,26 +1868,26 @@ Changes in Emacs 1.9
record the keys which invoke the macro as well as the
macro's definition.
-* The variable global-minor-modes is used to display
+** The variable global-minor-modes is used to display
strings in the mode line of all buffers. It should be
a list of elements that are conses whose cdrs are strings
to be displayed. This complements the variable
minor-modes, which has the same effect but has a separate
value in each buffer.
-* C-x = describes horizontal scrolling in effect, if any.
+** C-x = describes horizontal scrolling in effect, if any.
-* Return now auto-fills the line it is ending, in auto fill mode.
+** Return now auto-fills the line it is ending, in auto fill mode.
Space with zero as argument auto-fills the line before it
just like Space without an argument.
-Changes in Emacs 1.8
+* Changes in Emacs 1.8
This release mostly fixes bugs. There are a few new features:
-* apropos now sorts the symbols before displaying them.
+** apropos now sorts the symbols before displaying them.
Also, it returns a list of the symbols found.
apropos now accepts a second arg PRED which should be a function
@@ -1901,26 +1901,26 @@ This release mostly fixes bugs. There are a few new features:
C-h a now runs the new function command-apropos rather than
apropos, and shows only symbols with definitions as commands.
-* M-x shell sends the command
+** M-x shell sends the command
if (-f ~/.emacs_NAME)source ~/.emacs_NAME
invisibly to the shell when it starts. Here NAME
is replaced by the name of shell used,
as it came from your ESHELL or SHELL environment variable
but with directory name, if any, removed.
-* M-, now runs the command tags-loop-continue, which is used
+** M-, now runs the command tags-loop-continue, which is used
to resume a terminated tags-search or tags-query-replace.
-Changes in Emacs 1.7
+* Changes in Emacs 1.7
It's Beat CCA Week.
-* The initial buffer is now called "*scratch*" instead of "scratch",
+** The initial buffer is now called "*scratch*" instead of "scratch",
so that all buffer names used automatically by Emacs now have *'s.
-* Undo information is now stored separately for each buffer.
+** Undo information is now stored separately for each buffer.
The Undo command (C-x u) always applies to the current
buffer only.
@@ -1932,7 +1932,7 @@ It's Beat CCA Week.
kept for buffers whose names start with spaces. (These
buffers also do not appear in the C-x C-b display.)
-* Rectangle operations are now implemented.
+** Rectangle operations are now implemented.
C-x r stores the rectangle described by dot and mark
into a register; it reads the register name from the keyboard.
C-x g, the command to insert the contents of a register,
@@ -1950,7 +1950,7 @@ It's Beat CCA Week.
delete the text of the specified rectangle,
moving the text beyond it on each line leftward.
-* Side-by-side windows are allowed. Use C-x 5 to split the
+** Side-by-side windows are allowed. Use C-x 5 to split the
current window into two windows side by side.
C-x } makes the selected window ARG columns wider at the
expense of the windows at its sides. C-x { makes the selected
@@ -1960,7 +1960,7 @@ It's Beat CCA Week.
C-x 2 now accepts a numeric argument to specify the number of
lines to give to the uppermost of the two windows it makes.
-* Horizontal scrolling of the lines in a window is now implemented.
+** Horizontal scrolling of the lines in a window is now implemented.
C-x < (scroll-left) scrolls all displayed lines left,
with the numeric argument (default 1) saying how far to scroll.
When the window is scrolled left, some amount of the beginning
@@ -1972,17 +1972,17 @@ It's Beat CCA Week.
regardless of the value of the variable truncate-lines in the
buffer being displayed.
-* C-x C-d now uses the default output format of `ls',
+** C-x C-d now uses the default output format of `ls',
which gives just file names in multiple columns.
C-u C-x C-d passes the -l switch to `ls'.
-* C-t at the end of a line now exchanges the two preceding characters.
+** C-t at the end of a line now exchanges the two preceding characters.
All the transpose commands now interpret zero as an argument
to mean to transpose the textual unit after or around dot
with the one after or around the mark.
-* M-! executes a shell command in an inferior shell
+** M-! executes a shell command in an inferior shell
and displays the output from it. With a prefix argument,
it inserts the output in the current buffer after dot
and sets the mark after the output. The shell command
@@ -1992,10 +1992,10 @@ It's Beat CCA Week.
as input to the shell command. A prefix argument makes
the output from the command replace the contents of the region.
-* The mode line will now say "Def" after the major mode
+** The mode line will now say "Def" after the major mode
while a keyboard macro is being defined.
-* The variable fill-prefix is now used by Meta-q.
+** The variable fill-prefix is now used by Meta-q.
Meta-q removes the fill prefix from lines that start with it
before filling, and inserts the fill prefix on each line
after filling.
@@ -2003,35 +2003,35 @@ It's Beat CCA Week.
The command C-x . sets the fill prefix equal to the text
on the current line before dot.
-* The new command Meta-j (indent-new-comment-line),
+** The new command Meta-j (indent-new-comment-line),
is like Linefeed (indent-new-line) except when dot is inside a comment;
in that case, Meta-j inserts a comment starter on the new line,
indented under the comment starter above. It also inserts
a comment terminator at the end of the line above,
if the language being edited calls for one.
-* Rmail should work correctly now, and has some C-h m documentation.
+** Rmail should work correctly now, and has some C-h m documentation.
-Changes in Emacs 1.6
+* Changes in Emacs 1.6
-* save-buffers-kill-emacs is now on C-x C-c
+** save-buffers-kill-emacs is now on C-x C-c
while C-x C-z does suspend-emacs. This is to make
C-x C-c like the normal Unix meaning of C-c
and C-x C-z like the normal Unix meaning of C-z.
-* M-ESC (eval-expression) is now a disabled command by default.
+** M-ESC (eval-expression) is now a disabled command by default.
This prevents users who type ESC ESC accidentally from
getting confusing results. Put
(put 'eval-expression 'disabled nil)
in your ~/.emacs file to enable the command.
-* Self-inserting text is grouped into bunches for undoing.
+** Self-inserting text is grouped into bunches for undoing.
Each C-x u command undoes up to 20 consecutive self-inserting
characters.
-* Help f now uses as a default the function being called
+** Help f now uses as a default the function being called
in the innermost Lisp expression that dot is in.
This makes it more convenient to use while writing
Lisp code to run in Emacs.
@@ -2041,7 +2041,7 @@ Changes in Emacs 1.6
Likewise, Help v uses the symbol around or before dot
as a default, if that is a variable name.
-* Commands that read filenames now insert the default
+** Commands that read filenames now insert the default
directory in the minibuffer, to become part of your input.
This allows you to see what the default is.
You may type a filename which goes at the end of the
@@ -2060,13 +2060,13 @@ Changes in Emacs 1.6
Set the variable insert-default-directory to nil
to turn off this feature.
-* M-x shell now uses the environment variable ESHELL,
+** M-x shell now uses the environment variable ESHELL,
if it exists, as the file name of the shell to run.
If there is no ESHELL variable, the SHELL variable is used.
This is because some shells do not work properly as inferiors
of Emacs (or anything like Emacs).
-* A new variable minor-modes now exists, with a separate value
+** A new variable minor-modes now exists, with a separate value
in each buffer. Its value should be an alist of elements
(MODE-FUNCTION-SYMBOL . PRETTY-NAME-STRING), one for each
minor mode that is turned on in the buffer. The pretty
@@ -2076,7 +2076,7 @@ Changes in Emacs 1.6
turn on the minor mode if given 1 as an argument; they are present
so that Help m can find their documentation strings.
-* The format of tag table files has been changed.
+** The format of tag table files has been changed.
The new format enables Emacs to find tags much faster.
A new program, etags, exists to make the kind of
@@ -2092,13 +2092,13 @@ Changes in Emacs 1.6
The tags library can no longer use standard ctags-style
tag tables files.
-* The file of Lisp code Emacs reads on startup is now
+** The file of Lisp code Emacs reads on startup is now
called ~/.emacs rather than ~/.emacs_pro.
-* copy-file now gives the copied file the same mode bits
+** copy-file now gives the copied file the same mode bits
as the original file.
-* Output from a process inserted into the process's buffer
+** Output from a process inserted into the process's buffer
no longer sets the buffer's mark. Instead it sets a
marker associated with the process to point to the end
of the inserted text. You can access this marker with
@@ -2106,27 +2106,27 @@ Changes in Emacs 1.6
and then either examine its position with marker-position
or set its position with set-marker.
-* completing-read takes a new optional fifth argument which,
+** completing-read takes a new optional fifth argument which,
if non-nil, should be a string of text to insert into
the minibuffer before reading user commands.
-* The Lisp function elt now exists:
+** The Lisp function elt now exists:
(elt ARRAY N) is like (aref ARRAY N),
(elt LIST N) is like (nth N LIST).
-* rplaca is now a synonym for setcar, and rplacd for setcdr.
+** rplaca is now a synonym for setcar, and rplacd for setcdr.
eql is now a synonym for eq; it turns out that the Common Lisp
distinction between eq and eql is insignificant in Emacs.
numberp is a new synonym for integerp.
-* auto-save has been renamed to auto-save-mode.
+** auto-save has been renamed to auto-save-mode.
-* Auto save file names for buffers are now created by the
+** Auto save file names for buffers are now created by the
function make-auto-save-file-name. This is so you can
redefine that function to change the way auto save file names
are chosen.
-* expand-file-name no longer discards a final slash.
+** expand-file-name no longer discards a final slash.
(expand-file-name "foo" "/lose") => "/lose/foo"
(expand-file-name "foo/" "/lose") => "/lose/foo/"
@@ -2140,7 +2140,7 @@ Changes in Emacs 1.6
delete-file call expand-file-name on the file name supplied.
This change makes them considerably faster in the usual case.
-* Interactive calling spec strings allow the new code letter 'D'
+** Interactive calling spec strings allow the new code letter 'D'
which means to read a directory name. It is like 'f' except
that the default if the user makes no change in the minibuffer
is to return the current default directory rather than the
@@ -2148,9 +2148,9 @@ Changes in Emacs 1.6
-Changes in Emacs 1.5
+* Changes in Emacs 1.5
-* suspend-emacs now accepts an optional argument
+** suspend-emacs now accepts an optional argument
which is a string to be stuffed as terminal input
to be read by Emacs's superior shell after Emacs exits.
@@ -2158,28 +2158,28 @@ Changes in Emacs 1.5
to transmit text to a Lisp job running as a sibling of
Emacs.
-* If find-file is given the name of a directory,
+** If find-file is given the name of a directory,
it automatically invokes dired on that directory
rather than reading in the binary data that make up
the actual contents of the directory according to Unix.
-* Saving an Emacs buffer now preserves the file modes
+** Saving an Emacs buffer now preserves the file modes
of any previously existing file with the same name.
This works using new Lisp functions file-modes and
set-file-modes, which can be used to read or set the mode
bits of any file.
-* The Lisp function cond now exists, with its traditional meaning.
+** The Lisp function cond now exists, with its traditional meaning.
-* defvar and defconst now permit the documentation string
+** defvar and defconst now permit the documentation string
to be omitted. defvar also permits the initial value
to be omitted; then it acts only as a comment.
-Changes in Emacs 1.4
+* Changes in Emacs 1.4
-* Auto-filling now normally indents the new line it creates
+** Auto-filling now normally indents the new line it creates
by calling indent-according-to-mode. This function, meanwhile,
has in Fundamental and Text modes the effect of making the line
have an indentation of the value of left-margin, a per-buffer variable.
@@ -2188,7 +2188,7 @@ Changes in Emacs 1.4
it does that in all modes that supply their own indentation routine,
but in Fundamental, Text and allied modes it inserts a tab character.
-* The command M-x grep now invokes grep (on arguments
+** The command M-x grep now invokes grep (on arguments
supplied by the user) and reads the output from grep
asynchronously into a buffer. The command C-x ` can
be used to move to the lines that grep has found.
@@ -2199,35 +2199,35 @@ Changes in Emacs 1.4
is proceeding; as more matches or error messages arrive,
C-x ` will parse them and be able to find them.
-* M-x mail now provides a command to send the message
+** M-x mail now provides a command to send the message
and "exit"--that is, return to the previously selected
buffer. It is C-z C-z.
-* Tab in C mode now tries harder to adapt to all indentation styles.
+** Tab in C mode now tries harder to adapt to all indentation styles.
If the line being indented is a statement that is not the first
one in the containing compound-statement, it is aligned under
the beginning of the first statement.
-* The functions screen-width and screen-height return the
+** The functions screen-width and screen-height return the
total width and height of the screen as it is now being used.
set-screen-width and set-screen-height tell Emacs how big
to assume the screen is; they each take one argument,
an integer.
-* The Lisp function 'function' now exists. function is the
+** The Lisp function 'function' now exists. function is the
same as quote, except that it serves as a signal to the
Lisp compiler that the argument should be compiled as
a function. Example:
(mapcar (function (lambda (x) (+ x 5))) list)
-* The function set-key has been renamed to global-set-key.
+** The function set-key has been renamed to global-set-key.
undefine-key and local-undefine-key has been renamed to
global-unset-key and local-unset-key.
-* Emacs now collects input from asynchronous subprocesses
+** Emacs now collects input from asynchronous subprocesses
while waiting in the functions sleep-for and sit-for.
-* Shell mode's Newline command attempts to distinguish subshell
+** Shell mode's Newline command attempts to distinguish subshell
prompts from user input when issued in the middle of the buffer.
It no longer reexecutes from dot to the end of the line;
it reeexecutes the entire line minus any prompt.
@@ -2237,9 +2237,9 @@ Changes in Emacs 1.4
-Changes in Emacs 1.3
+* Changes in Emacs 1.3
-* An undo facility exists now. Type C-x u to undo a batch of
+** An undo facility exists now. Type C-x u to undo a batch of
changes (usually one command's changes, but some commands
such as query-replace divide their changes into multiple
batches. You can repeat C-x u to undo further. As long
@@ -2256,45 +2256,45 @@ Changes in Emacs 1.3
for each buffer, so it is mainly good if you do something
totally spastic. [This has since been fixed.]
-* A learn-by-doing tutorial introduction to Emacs now exists.
+** A learn-by-doing tutorial introduction to Emacs now exists.
Type C-h t to enter it.
-* An Info documentation browser exists. Do M-x info to enter it.
+** An Info documentation browser exists. Do M-x info to enter it.
It contains a tutorial introduction so that no more documentation
is needed here. As of now, the only documentation in it
is that of Info itself.
-* Help k and Help c are now different. Help c prints just the
+** Help k and Help c are now different. Help c prints just the
name of the function which the specified key invokes. Help k
prints the documentation of the function as well.
-* A document of the differences between GNU Emacs and Twenex Emacs
+** A document of the differences between GNU Emacs and Twenex Emacs
now exists. It is called DIFF, in the same directory as this file.
-* C mode can now indent comments better, including multi-line ones.
+** C mode can now indent comments better, including multi-line ones.
Meta-Control-q now reindents comment lines within the expression
being aligned.
-* Insertion of a close-parenthesis now shows the matching open-parenthesis
+** Insertion of a close-parenthesis now shows the matching open-parenthesis
even if it is off screen, by printing the text following it on its line
in the minibuffer.
-* A file can now contain a list of local variable values
+** A file can now contain a list of local variable values
to be in effect when the file is edited. See the file DIFF
in the same directory as this file for full details.
-* A function nth is defined. It means the same thing as in Common Lisp.
+** A function nth is defined. It means the same thing as in Common Lisp.
-* The function install-command has been renamed to set-key.
+** The function install-command has been renamed to set-key.
It now takes the key sequence as the first argument
and the definition for it as the second argument.
Likewise, local-install-command has been renamed to local-set-key.
-Changes in Emacs 1.2
+* Changes in Emacs 1.2
-* A Lisp single-stepping and debugging facility exists.
+** A Lisp single-stepping and debugging facility exists.
To cause the debugger to be entered when an error
occurs, set the variable debug-on-error non-nil.
@@ -2337,7 +2337,7 @@ Changes in Emacs 1.2
You can mark a frame to enter the debugger on exit
with the `b' command, or clear such a mark with `u'.
-* Lisp macros now exist.
+** Lisp macros now exist.
For example, you can write
(defmacro cadr (arg) (list 'car (list 'cdr arg)))
and then the expression
@@ -2347,9 +2347,9 @@ Changes in Emacs 1.2
-Changes in Emacs 1.1
+* Changes in Emacs 1.1
-* The initial buffer is now called "scratch" and is in a
+** The initial buffer is now called "scratch" and is in a
new major mode, Lisp Interaction mode. This mode is
intended for typing Lisp expressions, evaluating them,
and having the values printed into the buffer.
@@ -2360,31 +2360,31 @@ Changes in Emacs 1.1
The other commands of Lisp mode are available.
-* The C-x C-e command for evaluating the Lisp expression
+** The C-x C-e command for evaluating the Lisp expression
before dot has been changed to print the value in the
minibuffer line rather than insert it in the buffer.
A numeric argument causes the printed value to appear
in the buffer instead.
-* In Lisp mode, the command M-C-x evaluates the defun
+** In Lisp mode, the command M-C-x evaluates the defun
containing or following dot. The value is printed in
the minibuffer.
-* The value of a Lisp expression evaluated using M-ESC
+** The value of a Lisp expression evaluated using M-ESC
is now printed in the minibuffer.
-* M-q now runs fill-paragraph, independent of major mode.
+** M-q now runs fill-paragraph, independent of major mode.
-* C-h m now prints documentation on the current buffer's
+** C-h m now prints documentation on the current buffer's
major mode. What it prints is the documentation of the
major mode name as a function. All major modes have been
equipped with documentation that describes all commands
peculiar to the major mode, for this purpose.
-* You can display a Unix manual entry with
+** You can display a Unix manual entry with
the M-x manual-entry command.
-* You can run a shell, displaying its output in a buffer,
+** You can run a shell, displaying its output in a buffer,
with the M-x shell command. The Return key sends input
to the subshell. Output is printed inserted automatically
in the buffer. Commands C-c, C-d, C-u, C-w and C-z are redefined
@@ -2393,7 +2393,7 @@ Changes in Emacs 1.1
enter them, so that the default directory of the Emacs buffer
always remains the same as that of the subshell.
-* C-x $ (that's a real dollar sign) controls line-hiding based
+** C-x $ (that's a real dollar sign) controls line-hiding based
on indentation. With a numeric arg N > 0, it causes all lines
indented by N or more columns to become invisible.
They are, effectively, tacked onto the preceding line, where
@@ -2408,7 +2408,7 @@ Changes in Emacs 1.1
C-x $ with no argument turns off this mode, which in any case
is remembered separately for each buffer.
-* Outline mode is another form of selective display.
+** Outline mode is another form of selective display.
It is a major mode invoked with M-x outline-mode.
It is intended for editing files that are structured as
outlines, with heading lines (lines that begin with one
@@ -2429,12 +2429,12 @@ Changes in Emacs 1.1
All editing commands treat hidden outline-mode lines
as part of the preceding visible line.
-* C-x C-z runs save-buffers-kill-emacs
+** C-x C-z runs save-buffers-kill-emacs
offers to save each file buffer, then exits.
-* C-c's function is now called suspend-emacs.
+** C-c's function is now called suspend-emacs.
-* The command C-x m runs mail, which switches to a buffer *mail*
+** The command C-x m runs mail, which switches to a buffer *mail*
and lets you compose a message to send. C-x 4 m runs mail in
another window. Type C-z C-s in the mail buffer to send the
message according to what you have entered in the buffer.
@@ -2442,7 +2442,7 @@ Changes in Emacs 1.1
You must separate the headers from the message text with
an empty line.
-* You can now dired partial directories (specified with names
+** You can now dired partial directories (specified with names
containing *'s, etc, all processed by the shell). Also, you
can dired more than one directory; dired names the buffer
according to the filespec or directory name. Reinvoking
@@ -2455,9 +2455,9 @@ Changes in Emacs 1.1
C-x C-d (list-directory) also allows partial directories now.
-Lisp programming changes
+** Lisp programming changes
-* t as an output stream now means "print to the minibuffer".
+*** t as an output stream now means "print to the minibuffer".
If there is already text in the minibuffer printed via t
as an output stream, the new text is appended to the old
(or is truncated and lost at the margin). If the minibuffer
@@ -2472,17 +2472,17 @@ Lisp programming changes
is ignored; each `read' from t reads fresh input.
t is now the top-level value of standard-input.
-* A marker may be used as an input stream or an output stream.
+*** A marker may be used as an input stream or an output stream.
The effect is to grab input from where the marker points,
advancing it over the characters read, or to insert output
at the marker and advance it.
-* Output from an asynchronous subprocess is now inserted at
+*** Output from an asynchronous subprocess is now inserted at
the end of the associated buffer, not at the buffer's dot,
and the buffer's mark is set to the end of the inserted output
each time output is inserted.
-* (pos-visible-in-window-p POS WINDOW)
+*** (pos-visible-in-window-p POS WINDOW)
returns t if position POS in WINDOW's buffer is in the range
that is being displayed in WINDOW; nil if it is scrolled
vertically out of visibility.
@@ -2493,18 +2493,18 @@ Lisp programming changes
POS defaults to (dot), and WINDOW to (selected-window).
-* Variable buffer-alist replaced by function (buffer-list).
+*** Variable buffer-alist replaced by function (buffer-list).
The actual alist of buffers used internally by Emacs is now
no longer accessible, to prevent the user from crashing Emacs
by modifying it. The function buffer-list returns a list
of all existing buffers. Modifying this list cannot hurt anything
as a new list is constructed by each call to buffer-list.
-* load now takes an optional third argument NOMSG which, if non-nil,
+*** load now takes an optional third argument NOMSG which, if non-nil,
prevents load from printing a message when it starts and when
it is done.
-* byte-recompile-directory is a new function which finds all
+*** byte-recompile-directory is a new function which finds all
the .elc files in a directory, and regenerates each one which
is older than the corresponding .el (Lisp source) file.
@@ -2528,5 +2528,5 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
Local variables:
-mode: text
+mode: outline
end:
diff --git a/etc/NEWS.18 b/etc/NEWS.18
index 8d30d549aea..fe2f8c8ab9c 100644
--- a/etc/NEWS.18
+++ b/etc/NEWS.18
@@ -8,23 +8,23 @@ This file is about changes in Emacs version 18.
-Changes in version 18.52.
+* Changes in Emacs 18.52.
-* X windows version 10 is supported under system V.
+** X windows version 10 is supported under system V.
-* Pop-up menus are now supported with the same Lisp interface in
+** Pop-up menus are now supported with the same Lisp interface in
both version 10 and 11 of X windows.
-* C-x 4 a is a new command to edit a change-log entry in another window.
+** C-x 4 a is a new command to edit a change-log entry in another window.
-* The emacs client program now allows an option +NNN to specify the
+** The emacs client program now allows an option +NNN to specify the
line number to go to in the file whose name follows. Thus,
emacsclient foo.c +45 bar.c
will find the files `foo.c' and `bar.c', going to line 45 in `bar.c'.
-* Dired allows empty directories to be deleted like files.
+** Dired allows empty directories to be deleted like files.
-* When the terminal type is used to find a terminal-specific file to
+** When the terminal type is used to find a terminal-specific file to
run, Emacs now tries the entire terminal type first. If that doesn't
yield a file that exists, the last hyphen and what follows it is
stripped. If that doesn't yield a file that exists, the previous
@@ -34,97 +34,97 @@ example, if the terminal type is `aaa-48-foo', Emacs will try first
Underscores now receive the same treatment as hyphens.
-* Texinfo features: @defun, etc. texinfo-show-structure.
+** Texinfo features: @defun, etc. texinfo-show-structure.
New template commands. texinfo-format-region.
-* The special "local variable" `eval' is now ignored if you are running
+** The special "local variable" `eval' is now ignored if you are running
as root.
-* New command `c-macro-expand' shows the result of C macro expansion
+** New command `c-macro-expand' shows the result of C macro expansion
in the region. It works using the C preprocessor, so its results
are completely accurate.
-* Errors in trying to auto save now flash error messages for a few seconds.
+** Errors in trying to auto save now flash error messages for a few seconds.
-* Killing a buffer now sends SIGHUP to the buffer's process.
+** Killing a buffer now sends SIGHUP to the buffer's process.
-* New hooks.
+** New hooks.
-** `spell-region' now allows you to filter the text before spelling-checking.
+*** `spell-region' now allows you to filter the text before spelling-checking.
If the value of `spell-filter' is non-nil, it is called, with no arguments,
looking at a temporary buffer containing a copy of the text to be checked.
It can alter the text freely before the spell program sees it.
-** The variable `lpr-command' now specifies the command to be used when
+*** The variable `lpr-command' now specifies the command to be used when
you use the commands to print text (such as M-x print-buffer).
-** Posting netnews now calls the value of `news-inews-hook' (if not nil)
+*** Posting netnews now calls the value of `news-inews-hook' (if not nil)
as a function of no arguments before the actual posting.
-** Rmail now calls the value of `rmail-show-message-hook' (if not nil)
+*** Rmail now calls the value of `rmail-show-message-hook' (if not nil)
as a function of no arguments, each time a new message is selected.
-** `kill-emacs' calls the value of `kill-emacs-hook' as a function of no args.
+*** `kill-emacs' calls the value of `kill-emacs-hook' as a function of no args.
-* New libraries.
+** New libraries.
See the source code of each library for more information.
-** icon.el: a major mode for editing programs written in Icon.
+*** icon.el: a major mode for editing programs written in Icon.
-** life.el: a simulator for the cellular automaton "life". Load the
+*** life.el: a simulator for the cellular automaton "life". Load the
library and run M-x life.
-** doctex.el: a library for converting the Emacs `etc/DOC' file of
+*** doctex.el: a library for converting the Emacs `etc/DOC' file of
documentation strings into TeX input.
-** saveconf.el: a library which records the arrangement of windows and
+*** saveconf.el: a library which records the arrangement of windows and
buffers when you exit Emacs, and automatically recreates the same
setup the next time you start Emacs.
-** uncompress.el: a library that automatically uncompresses files
+*** uncompress.el: a library that automatically uncompresses files
when you visit them.
-** c-fill.el: a mode for editing filled comments in C.
+*** c-fill.el: a mode for editing filled comments in C.
-** kermit.el: an extended version of shell-mode designed for running kermit.
+*** kermit.el: an extended version of shell-mode designed for running kermit.
-** spook.el: a library for adding some "distract the NSA" keywords to every
+*** spook.el: a library for adding some "distract the NSA" keywords to every
message you send.
-** hideif.el: a library for hiding parts of a C program based on preprocessor
+*** hideif.el: a library for hiding parts of a C program based on preprocessor
conditionals.
-** autoinsert.el: a library to put in some initial text when you visit
+*** autoinsert.el: a library to put in some initial text when you visit
a nonexistent file. The text used depends on the major mode, and
comes from a directory of files created by you.
-* New programming features.
+** New programming features.
-** The variable `window-system-version' now contains the version number
+*** The variable `window-system-version' now contains the version number
of the window system you are using (if appropriate). When using X windows,
its value is either 10 or 11.
-** (interactive "N") uses the prefix argument if any; otherwise, it reads
+*** (interactive "N") uses the prefix argument if any; otherwise, it reads
a number using the minibuffer.
-** VMS: there are two new functions `vms-system-info' and `shrink-to-icon'.
+*** VMS: there are two new functions `vms-system-info' and `shrink-to-icon'.
The former allows you to get many kinds of system status information.
See its self-documentation for full details.
The second is used with the window system: it iconifies the Emacs window.
-** VMS: the new function `define-logical-name' allows you to create
+*** VMS: the new function `define-logical-name' allows you to create
job-wide logical names. The old function `define-dcl-symbol' has been
removed.
-Changes in version 18.50.
+* Changes in Emacs 18.50.
-* X windows version 11 is supported.
+** X windows version 11 is supported.
Define X11 in config.h if you want X version 11 instead of version 10.
-* The command M-x gdb runs the GDB debugger as an inferior.
+** The command M-x gdb runs the GDB debugger as an inferior.
It asks for the filename of the executable you want to debug.
GDB runs as an inferior with I/O through an Emacs buffer. All the
@@ -140,21 +140,21 @@ and `finish'.
In any source file, the commands C-x SPC tells GDB to set a breakpoint
on the current line.
-* M-x calendar displays a three-month calendar.
+** M-x calendar displays a three-month calendar.
-* C-u 0 C-x C-s never makes a backup file.
+** C-u 0 C-x C-s never makes a backup file.
This is a way you can explicitly request not to make a backup.
-* `term-setup-hook' is for users only.
+** `term-setup-hook' is for users only.
Emacs never uses this variable for internal purposes, so you can freely
set it in your `.emacs' file to make Emacs do something special after
loading any terminal-specific setup file from `lisp/term'.
-* `copy-keymap' now copies recursive submaps.
+** `copy-keymap' now copies recursive submaps.
-* New overlay-arrow feature.
+** New overlay-arrow feature.
If you set the variable `overlay-arrow-string' to a string
and `overlay-arrow-position' to a marker, that string is displayed on
@@ -162,12 +162,12 @@ the screen at the position of that marker, hiding whatever text would
have appeared there. If that position isn't on the screen, or if
the buffer the marker points into isn't displayed, there is no effect.
-* -batch mode can read from the terminal.
+** -batch mode can read from the terminal.
It now works to use `read-char' to do terminal input in a noninteractive
Emacs run. End of file causes Emacs to exit.
-* Variables `data-bytes-used' and `data-bytes-free' removed.
+** Variables `data-bytes-used' and `data-bytes-free' removed.
These variables cannot really work because the 24-bit range of an
integer in (most ports of) GNU Emacs is not large enough to hold their
@@ -175,9 +175,9 @@ values on many systems.
-Changes in version 18.45, since version 18.41.
+* Changes in Emacs 18.45, since version 18.41.
-* C indentation parameter `c-continued-brace-offset'.
+** C indentation parameter `c-continued-brace-offset'.
This parameter's value is added to the indentation of any
line that is in a continuation context and starts with an open-brace.
@@ -188,26 +188,26 @@ For example, it applies to the open brace shown here:
The default value is zero.
-* Dabbrev expansion (Meta-/) preserves case.
+** Dabbrev expansion (Meta-/) preserves case.
When you use Meta-/ to search the buffer for an expansion of an
abbreviation, if the expansion found is all lower case except perhaps
for its first letter, then the case pattern of the abbreviation
is carried over to the expansion that replaces it.
-* TeX-mode syntax.
+** TeX-mode syntax.
\ is no longer given "escape character" syntax in TeX mode. It now
has the syntax of an ordinary punctuation character. As a result,
\[...\] and such like are considered to balance each other.
-* Mail-mode automatic Reply-to field.
+** Mail-mode automatic Reply-To field.
If the variable `mail-default-reply-to' is non-`nil', then each time
-you start to compose a message, a Reply-to field is inserted with
+you start to compose a message, a Reply-To field is inserted with
its contents taken from the value of `mail-default-reply-to'.
-* Where is your .emacs file?
+** Where is your .emacs file?
If you run Emacs under `su', so your real and effective uids are
different, Emacs uses the home directory associated with the real uid
@@ -218,23 +218,23 @@ file.
The .emacs file is not loaded at all if -batch is specified.
-* Prolog mode is the default for ".pl" files.
+** Prolog mode is the default for ".pl" files.
-* File names are not case-sensitive on VMS.
+** File names are not case-sensitive on VMS.
On VMS systems, all file names that you specify are converted to upper
case. You can use either upper or lower case indiscriminately.
-* VMS-only function 'define-dcl-symbol'.
+** VMS-only function 'define-dcl-symbol'.
This is a new name for the function formerly called
`define-logical-name'.
-Editing Changes in Emacs 18
+* Editing Changes in Emacs 18
-* Additional systems and machines are supported.
+** Additional systems and machines are supported.
GNU Emacs now runs on Vax VMS. However, many facilities that are normally
implemented by running subprocesses do not work yet. This includes listing
@@ -256,13 +256,13 @@ to working. The port for the Elxsi is partly merged. See the file
MACHINES for full status information and machine-specific installation
advice.
-* Searching is faster.
+** Searching is faster.
Forward search for a text string, or for a regexp that is equivalent
to a text string, is now several times faster. Motion by lines and
counting lines is also faster.
-* Memory usage improvements.
+** Memory usage improvements.
It is no longer possible to run out of memory during garbage
collection. As a result, running out of memory is never fatal. This
@@ -271,27 +271,27 @@ strings in place rather than copying them. Another consequence of the
change is a reduction in total memory usage and a slight increase in
garbage collection speed.
-* Display changes.
+** Display changes.
-** Editing above top of screen.
+*** Editing above top of screen.
When you delete or kill or alter text that reaches to the top of the
screen or above it, so that display would start in the middle of a
line, Emacs will usually attempt to scroll the text so that display
starts at the beginning of a line again.
-** Yanking in the minibuffer.
+*** Yanking in the minibuffer.
The message "Mark Set" is no longer printed when the minibuffer is
active. This is convenient with many commands, including C-y, that
normally print such a message.
-** Cursor appears in last line during y-or-n questions.
+*** Cursor appears in last line during y-or-n questions.
Questions that want a `y' or `n' answer now move the cursor
to the last line, following the question.
-* Library loading changes.
+** Library loading changes.
`load' now considers all possible suffixes (`.elc', `.el' and none)
for each directory in `load-path' before going on to the next directory.
@@ -313,13 +313,13 @@ is no longer allowed. Instead, there are two commands for loading files.
`M-x load-file' reads a file name with completion and defaulting
and then loads exactly that file, with no searching and no suffixes.
-* Emulation of other editors.
+** Emulation of other editors.
-** `edt-emulation-on' starts emulating DEC's EDT editor.
+*** `edt-emulation-on' starts emulating DEC's EDT editor.
Do `edt-emulation-off' to return Emacs to normal.
-** `vi-mode' and `vip-mode' starts emulating vi.
+*** `vi-mode' and `vip-mode' starts emulating vi.
These are two different vi emulations provided by GNU Emacs users.
We are interested in feedback as to which emulation is preferable.
@@ -327,20 +327,20 @@ We are interested in feedback as to which emulation is preferable.
See the documentation and source code for these functions
for more information.
-** `set-gosmacs-bindings' emulates Gosling Emacs.
+*** `set-gosmacs-bindings' emulates Gosling Emacs.
This command changes many global bindings to resemble those of
Gosling Emacs. The previous bindings are saved and can be restored using
`set-gnu-bindings'.
-* Emulation of a display terminal.
+** Emulation of a display terminal.
Within Emacs it is now possible to run programs (such as emacs or
supdup) which expect to do output to a visual display terminal.
See the function `terminal-emulator' for more information.
-* New support for keypads and function keys.
+** New support for keypads and function keys.
There is now a first attempt at terminal-independent support for
keypad and function keys.
@@ -369,7 +369,7 @@ used in forming the name of the terminal-specific file. Thus, for
terminal type `aaa-48', the file loaded is now `term/aaa.el' rather
than `term/aaa-48.el'.
-* New startup command line options.
+** New startup command line options.
`-i FILE' or `-insert FILE' in the command line to Emacs tells Emacs to
insert the contents of FILE into the current buffer at that point in
@@ -383,7 +383,7 @@ emulator on the X window system and you want to run Emacs to work through
the terminal emulator instead of working directly with the window system,
use this switch.
-* Buffer-sorting commands.
+** Buffer-sorting commands.
Various M-x commands whose names start with `sort-' sort parts of
the region:
@@ -404,13 +404,13 @@ sort-columns divides into lines and sorts them according to the contents
Refer to the self-documentation of these commands for full usage information.
-* Changes in various commands.
+** Changes in various commands.
-** `tags-query-replace' and `tags-search' change.
+*** `tags-query-replace' and `tags-search' change.
These functions now display the name of the file being searched at the moment.
-** `occur' output now serves as a menu. `occur-menu' command deleted.
+*** `occur' output now serves as a menu. `occur-menu' command deleted.
`M-x occur' now allows you to move quickly to any of the occurrences
listed. Select the `*Occur*' buffer that contains the output of `occur',
@@ -423,7 +423,7 @@ The command `occur-menu' is thus obsolete, and has been deleted.
One way to get a list of matching lines without line numbers is to
copy the text to another buffer and use the command `keep-lines'.
-** Incremental search changes.
+*** Incremental search changes.
Ordinary and regexp incremental searches now have distinct default
search strings. Thus, regexp searches recall only previous regexp
@@ -458,12 +458,12 @@ If `search-slow-window-lines' is negative, the slow search window
is put at the top of the screen, and the absolute value or the
negative number specifies the height of it.
-** Undo changes
+*** Undo changes
The undo command now will mark the buffer as unmodified only when it is
identical to the contents of the visited file.
-** C-M-v in minibuffer.
+*** C-M-v in minibuffer.
If while in the minibuffer you request help in a way that uses a
window to display something, then until you exit the minibuffer C-M-v
@@ -472,7 +472,7 @@ in the minibuffer window scrolls the window of help.
For example, if you request a list of possible completions, C-M-v can
be used reliably to scroll the completion list.
-** M-TAB command.
+*** M-TAB command.
Meta-TAB performs completion on the Emacs Lisp symbol names. The sexp
in the buffer before point is compared against all existing nontrivial
@@ -483,12 +483,12 @@ or properties.
If there are multiple possibilities for the very next character, a
list of possible completions is displayed.
-** Dynamic abbreviation package.
+*** Dynamic abbreviation package.
The new command Meta-/ expands an abbreviation in the buffer before point
by searching the buffer for words that start with the abbreviation.
-** Changes in saving kbd macros.
+*** Changes in saving kbd macros.
The commands `write-kbd-macro' and `append-kbd-macro' have been
deleted. The way to save a keyboard macro is to use the new command
@@ -498,12 +498,12 @@ file such as your Emacs init file `~/.emacs', insert the macro
definition (perhaps deleting an old definition for the same macro)
and then save the file.
-** C-x ' command.
+*** C-x ' command.
The new command C-x ' (expand-abbrev) expands the word before point as
an abbrev, even if abbrev-mode is not turned on.
-** Sending to inferior Lisp.
+*** Sending to inferior Lisp.
The command C-M-x in Lisp mode, which sends the current defun to
an inferior Lisp process, now works by writing the text into a temporary
@@ -517,20 +517,20 @@ appear on the screen and scrolls it so that the bottom is showing.
Two variables `inferior-lisp-load-command' and `inferior-lisp-prompt',
exist to customize these feature for different Lisp implementations.
-** C-x p now disabled.
+*** C-x p now disabled.
The command C-x p, a nonrecommended command which narrows to the current
page, is now initially disabled like C-x n.
-* Dealing with files.
+** Dealing with files.
-** C-x C-v generalized
+*** C-x C-v generalized
This command is now allowed even if the current buffer is not visiting
a file. As usual, it kills the current buffer and replaces it with a
newly found file.
-** M-x recover-file improved; auto save file names changed.
+*** M-x recover-file improved; auto save file names changed.
M-x recover-file now checks whether the last auto-save file is more
recent than the real visited file before offering to read in the
@@ -555,21 +555,21 @@ You can customize the way auto save file names are made by redefining
the two functions `make-auto-save-file-name' and `auto-save-file-name-p',
both of which are defined in `files.el'.
-** Modifying a buffer whose file is changed on disk is detected instantly.
+*** Modifying a buffer whose file is changed on disk is detected instantly.
On systems where clash detection (locking of files being edited) is
implemented, Emacs also checks the first time you modify a buffer
whether the file has changed on disk since it was last visited or saved.
If it has, you are asked to confirm that you want to change the buffer.
-** Exiting Emacs offers to save `*mail*'.
+*** Exiting Emacs offers to save `*mail*'.
Emacs can now know about buffers that it should offer to save on exit
even though they are not visiting files. This is done for any buffer
which has a non-nil local value of `buffer-offer-save'. By default,
Mail mode provides such a local value.
-** Backup file changes.
+*** Backup file changes.
If a backup file cannot be written in the directory of the visited file
due to fascist file protection, a backup file is now written in your home
@@ -579,7 +579,7 @@ the most recently made such backup is available.
When backup files are made by copying, the last-modification time of the
original file is now preserved in the backup copy.
-** Visiting remote files.
+*** Visiting remote files.
On an internet host, you can now visit and save files on any other
internet host directly from Emacs with the commands M-x ftp-find-file
@@ -592,14 +592,14 @@ give the user name and password for use on that host. FTP is reinvoked
each time you ask to use it, but previously specified user names and
passwords are remembered automatically.
-** Dired `g' command.
+*** Dired `g' command.
`g' in Dired mode is equivalent to M-x revert-buffer; it causes the
current contents of the same directory to be read in.
-* Changes in major modes.
+** Changes in major modes.
-** C mode indentation change.
+*** C mode indentation change.
The binding of Linefeed is no longer changed by C mode. It once again
has its normal meaning, which is to insert a newline and then indent
@@ -618,28 +618,28 @@ is non-whitespace preceding point on the current line. Giving it a
prefix argument will force reindentation of the line (as well as
of the compound statement that begins after point, if any).
-** Fortran mode now exists.
+*** Fortran mode now exists.
This mode provides commands for motion and indentation of Fortran code,
plus built-in abbrevs for Fortran keywords. For details, see the manual
or the on-line documentation of the command `fortran-mode'.
-** Scribe mode now exists.
+*** Scribe mode now exists.
This mode does something useful for editing files of Scribe input.
It is used automatically for files with names ending in ".mss".
-** Modula2 and Prolog modes now exist.
+*** Modula2 and Prolog modes now exist.
These modes are for editing programs in the languages of the same names.
They can be selected with M-x modula-2-mode and M-x prolog-mode.
-** Telnet mode changes.
+*** Telnet mode changes.
The telnet mode special commands have now been assigned to C-c keys.
Most of them are the same as in Shell mode.
-** Picture mode changes.
+*** Picture mode changes.
The special picture-mode commands to specify the direction of cursor
motion after insertion have been moved to C-c keys. The commands to
@@ -647,13 +647,13 @@ specify diagonal motion were already C-c keys; they are unchanged.
The keys to specify horizontal or vertical motion are now
C-c < (left), C-c > (right), C-c ^ (up) and C-c . (down).
-** Nroff mode comments.
+*** Nroff mode comments.
Comments are now supported in Nroff mode. The standard comment commands
such as M-; and C-x ; know how to insert, align and delete comments
that start with backslash-doublequote.
-** LaTeX mode.
+*** LaTeX mode.
LaTeX mode now exists. Use M-x latex-mode to select this mode, and
M-x plain-tex-mode to select the previously existing mode for Plain
@@ -677,7 +677,7 @@ C-c C-f close a block (appropriate for LaTeX only).
this inserts an \end{...} on the following line
and puts point on a blank line between them.
-** Outline mode changes.
+*** Outline mode changes.
Invisible lines in outline mode are now indicated by `...' at the
end of the previous visible line.
@@ -701,9 +701,9 @@ the string that matches.
A line starting with a ^L (formfeed) is now by default considered
a header line.
-* Mail reading and sending.
+** Mail reading and sending.
-** MH-E changes.
+*** MH-E changes.
MH-E has been extensively modified and improved since the v17 release.
It contains many new features, including commands to: extracted failed
@@ -715,7 +715,7 @@ single messages. MH-E also has had numerous bugs fixed and commands
made to run faster. Furthermore, its keybindings have been changed to
be compatible with Rmail and the rest of GNU Emacs.
-** Mail mode changes.
+*** Mail mode changes.
The C-c commands of mail mode have been rearranged:
@@ -727,28 +727,28 @@ C-c y, C-c w and C-c q have been changed to C-c C-y, C-c C-w and C-c C-q.
Thus, C-c LETTER is always unassigned.
-** Rmail C-r command changed to w.
+*** Rmail C-r command changed to w.
The Rmail command to edit the current message is now `w'. This change
has been made because people frequently type C-r while in Rmail hoping
to do a reverse incremental search. That now works.
-* Rnews changes.
+** Rnews changes.
-** Caesar rotation added.
+*** Caesar rotation added.
The function news-caesar-buffer-body performs encryption and
decryption of the body of a news message. It defaults to the USENET
standard of 13, and accepts any numeric arg between 1 to 25 and -25 to -1.
The function is bound to C-c C-r in both news-mode and news-reply-mode.
-** rmail-output command added.
+*** rmail-output command added.
The C-o command has been bound to rmail-output in news-mode.
This allows one to append an article to a file which is in either Unix
mail or RMAIL format.
-** news-reply-mode changes.
+*** news-reply-mode changes.
The C-c commands of news reply mode have been rearranged and changed,
so that C-c LETTER is always unassigned:
@@ -773,7 +773,7 @@ C-c C-y news-reply-yank-original (insert current message, in NEWS).
C-c C-q mail-fill-yanked-message (fill what was yanked).
C-c C-r caesar rotate all letters by 13 places in the article's body (rot13).
-* Existing Emacs usable as a server.
+** Existing Emacs usable as a server.
Programs such as mailers that invoke "the editor" as an inferior
to edit some text can now be told to use an existing Emacs process
@@ -810,11 +810,11 @@ The client/server work only on Berkeley Unix, since they use the Berkeley
sockets mechanism for their communication.
-Changes in Lisp programming in Emacs version 18.
+* Changes in Lisp programming in Emacs 18
-* Init file changes.
+** Init file changes.
-** Suffixes no longer accepted on `.emacs'.
+*** Suffixes no longer accepted on `.emacs'.
Emacs will no longer load a file named `.emacs.el' or `emacs.elc'
in place of `.emacs'. This is so that it will take less time to
@@ -822,7 +822,7 @@ find `.emacs'. If you want to compile your init file, give it another
name and make `.emacs' a link to the `.elc' file, or make it contain
a call to `load' to load the `.elc' file.
-** `default-profile' renamed to `default', and loaded after `.emacs'.
+*** `default-profile' renamed to `default', and loaded after `.emacs'.
It used to be the case that the file `default-profile' was loaded if
and only if `.emacs' was not found.
@@ -839,13 +839,13 @@ Note that for most purposes you are better off using a `site-init' library
since that will be loaded before the runnable Emacs is dumped. By using
a `site-init' library, you avoid taking up time each time Emacs is started.
-** inhibit-command-line has been eliminated.
+*** inhibit-command-line has been eliminated.
This variable used to exist for .emacs files to set. It has been
eliminated because you can get the same effect by setting
command-line-args to nil and setting inhibit-startup-message to t.
-* `apply' is more general.
+** `apply' is more general.
`apply' now accepts any number of arguments. The first one is a function;
the rest are individual arguments to pass to that function, except for the
@@ -854,7 +854,7 @@ last, which is a list of arguments to pass.
Previously, `apply' required exactly two arguments. Its old behavior
follows as a special case of the new definition.
-* New code-letter for `interactive'.
+** New code-letter for `interactive'.
(interactive "NFoo: ") is like (interactive "nFoo: ") in reading
a number using the minibuffer to serve as the argument; however,
@@ -863,9 +863,9 @@ value as the argument, and does not use the minibuffer at all.
This is used by the `goto-line' and `goto-char' commands.
-* Semantics of variables.
+** Semantics of variables.
-** Built-in per-buffer variables improved.
+*** Built-in per-buffer variables improved.
Several built-in variables which in the past had a different value in
each buffer now behave exactly as if `make-variable-buffer-local' had
@@ -887,12 +887,12 @@ They now refer to the default value of the variable, which is not
quite the same behavior as before, but it should enable old init files
to continue to work.
-** New per-buffer variables.
+*** New per-buffer variables.
The variables `fill-prefix', `comment-column' and `indent-tabs-mode'
are now per-buffer. They work just like `fill-column', etc.
-** New function `setq-default'.
+*** New function `setq-default'.
`setq-default' sets the default value of a variable, and uses the
same syntax that `setq' accepts: the variable name is not evaluated
@@ -901,12 +901,12 @@ and need not be quoted.
`(setq-default case-fold-search nil)' would make searches case-sensitive
in all buffers that do not have local values for `case-fold-search'.
-** Functions `global-set' and `global-value' deleted.
+*** Functions `global-set' and `global-value' deleted.
These functions were never used except by mistake by users expecting
the functionality of `set-default' and `default-value'.
-* Changes in defaulting of major modes.
+** Changes in defaulting of major modes.
When `default-major-mode' is `nil', new buffers are supposed to
get their major mode from the buffer that is current. However,
@@ -917,7 +917,7 @@ Now such modes' names have been given non-`nil' `mode-class' properties.
If the current buffer's mode has such a property, Fundamental mode is
used as the default for newly created buffers.
-* `where-is-internal' requires additional arguments.
+** `where-is-internal' requires additional arguments.
This function now accepts three arguments, two of them required:
DEFINITION, the definition to search for; LOCAL-KEYMAP, the keymap
@@ -938,38 +938,38 @@ The incompatibility is sad, but `nil' is a legitimate value for the
second argument (it means there is no local keymap), so it cannot also
serve as a default meaning to use the current local keymap.
-* Abbrevs with hooks.
+** Abbrevs with hooks.
When an abbrev defined with a hook is expanded, it now performs the
usual replacement of the abbrev with the expansion before running the
hook. Previously the abbrev itself was deleted but the expansion was
not inserted.
-* Function `scan-buffer' deleted.
+** Function `scan-buffer' deleted.
Use `search-forward' or `search-backward' in place of `scan-buffer'.
You will have to rearrange the arguments.
-* X window interface improvements.
+** X window interface improvements.
-** Detect release of mouse buttons.
+*** Detect release of mouse buttons.
Button-up events can now be detected. See the file `lisp/x-mouse.el'
for details.
-** New pop-up menu facility.
+*** New pop-up menu facility.
The new function `x-popup-menu' pops up a menu (in a X window)
and returns an indication of which selection the user made.
For more information, see its self-documentation.
-* M-x disassemble.
+** M-x disassemble.
This command prints the disassembly of a byte-compiled Emacs Lisp function.
Would anyone like to interface this to the debugger?
-* `insert-buffer-substring' can insert part of the current buffer.
+** `insert-buffer-substring' can insert part of the current buffer.
The old restriction that the text being inserted had to come from
a different buffer is now lifted.
@@ -977,7 +977,7 @@ a different buffer is now lifted.
When inserting text from the current buffer, the text to be inserted
is determined from the specified bounds before any copying takes place.
-* New function `substitute-key-definition'.
+** New function `substitute-key-definition'.
This is a new way to replace one command with another command as the
binding of whatever keys may happen to refer to it.
@@ -986,29 +986,29 @@ binding of whatever keys may happen to refer to it.
for keys defined to run OLDDEF, and rebinds those keys to run NEWDEF
instead.
-* New function `insert-char'.
+** New function `insert-char'.
Insert a specified character, a specified number of times.
-* `mark-marker' changed.
+** `mark-marker' changed.
When there is no mark, this now returns a marker that points
nowhere, rather than `nil'.
-* `ding' accepts argument.
+** `ding' accepts argument.
When given an argument, the function `ding' does not terminate
execution of a keyboard macro. Normally, `ding' does terminate
all macros that are currently executing.
-* New function `minibuffer-depth'.
+** New function `minibuffer-depth'.
This function returns the current depth in minibuffer activations.
The value is zero when the minibuffer is not in use.
Values greater than one are possible if the user has entered the
minibuffer recursively.
-* New function `documentation-property'.
+** New function `documentation-property'.
(documentation-property SYMBOL PROPNAME) is like (get SYMBOL PROPNAME),
except that if the property value is a number `documentation-property'
@@ -1018,7 +1018,7 @@ in the DOC file and return the string found there.
(documentation-property VAR 'variable-documentation) is the proper
way for a Lisp program to get the documentation of variable VAR.
-* New documentation-string expansion feature.
+** New documentation-string expansion feature.
If a documentation string (for a variable or function) contains text
of the form `\<FOO>', it means that all command names specified in
@@ -1045,7 +1045,7 @@ in the current buffer's local map.
The current global keymap is always searched second, whether `\<...>'
has been used or not.
-* Multiple hooks allowed in certain contexts.
+** Multiple hooks allowed in certain contexts.
The old hook variables `find-file-hook', `find-file-not-found-hook' and
`write-file-hook' have been replaced.
@@ -1072,7 +1072,7 @@ together to implement editing of files that are not stored as Unix
files: stored in archives, or inside version control systems, or on
other machines running other operating systems and accessible via ftp.
-* New hooks for suspending Emacs.
+** New hooks for suspending Emacs.
Suspending Emacs runs the hook `suspend-hook' before suspending
and the hook `suspend-resume-hook' if the suspended Emacs is resumed.
@@ -1082,22 +1082,22 @@ non-`nil', then suspending is inhibited and so is running the
`suspend-resume-hook'. The non-`nil' value means that the `suspend-hook'
has done whatever suspending is required.
-* Disabling commands can print a special message.
+** Disabling commands can print a special message.
A command is disabled by giving it a non-`nil' `disabled' property.
Now, if this property is a string, it is included in the message
printed when the user tries to run the command.
-* Emacs can open TCP connections.
+** Emacs can open TCP connections.
The function `open-network-stream' opens a TCP connection to
a specified host and service. Its value is a Lisp object that represents
the connection. The object is a kind of "subprocess", and I/O are
done like I/O to subprocesses.
-* Display-related changes.
+** Display-related changes.
-** New mode-line control features.
+*** New mode-line control features.
The display of the mode line used to be controlled by a format-string
that was the value of the variable `mode-line-format'.
@@ -1188,12 +1188,12 @@ global-mode-string
The idea of these variables is to eliminate the need for major modes
to alter mode-line-format itself.
-** `window-point' valid for selected window.
+*** `window-point' valid for selected window.
The value returned by `window-point' used to be incorrect when its
argument was the selected window. Now the value is correct.
-** Window configurations may be saved as Lisp objects.
+*** Window configurations may be saved as Lisp objects.
The function `current-window-configuration' returns a special type of
Lisp object that represents the current layout of windows: the
@@ -1203,7 +1203,7 @@ which parts of the buffers appear on the screen.
The function `set-window-configuration' takes one argument, which must
be a window configuration object, and restores that configuration.
-** New hook `temp-output-buffer-show-hook'.
+*** New hook `temp-output-buffer-show-hook'.
This hook allows you to control how help buffers are displayed.
Whenever `with-output-to-temp-buffer' has executed its body and wants
@@ -1213,30 +1213,30 @@ The hook function is solely responsible for displaying the buffer.
The standard manner of display--making the buffer appear in a window--is
used only if there is no hook function.
-** New function `minibuffer-window'.
+*** New function `minibuffer-window'.
This function returns the window used (sometimes) for displaying
the minibuffer. It can be used even when the minibuffer is not active.
-** New feature to `next-window'.
+*** New feature to `next-window'.
If the optional second argument is neither `nil' nor `t', the minibuffer
window is omitted from consideration even when active; if the starting
window was the last non-minibuffer window, the value will be the first
non-minibuffer window.
-** New variable `minibuffer-scroll-window'.
+*** New variable `minibuffer-scroll-window'.
When this variable is non-`nil', the command `scroll-other-window'
uses it as the window to be scrolled. Displays of completion-lists
set this variable to the window containing the display.
-** New argument to `sit-for'.
+*** New argument to `sit-for'.
A non-nil second argument to `sit-for' means do not redisplay;
just wait for the specified time or until input is available.
-** Deleted function `set-minor-mode'; minor modes must be changed.
+*** Deleted function `set-minor-mode'; minor modes must be changed.
The function `set-minor-mode' has been eliminated. The display
of minor mode names in the mode line is now controlled by the
@@ -1245,7 +1245,7 @@ mode, it is sufficient to add an element to this list. Once that
is done, you can turn the mode on and off just by setting a variable,
and the display will show its status automatically.
-** New variable `cursor-in-echo-area'.
+*** New variable `cursor-in-echo-area'.
If this variable is non-nil, the screen cursor appears on the
last line of the screen, at the end of the text displayed there.
@@ -1253,7 +1253,7 @@ last line of the screen, at the end of the text displayed there.
Binding this variable to t is useful at times when reading single
characters of input with `read-char'.
-** New per-buffer variable `selective-display-ellipses'.
+*** New per-buffer variable `selective-display-ellipses'.
If this variable is non-nil, an ellipsis (`...') appears on the screen
at the end of each text line that is followed by invisible text.
@@ -1264,14 +1264,14 @@ on the screen that invisible text is present.
Text is made invisible under the control of the variable
`selective-display'; this is how Outline mode and C-x $ work.
-** New variable `no-redraw-on-reenter'.
+*** New variable `no-redraw-on-reenter'.
If you set this variable non-nil, Emacs will not clear the screen when
you resume it after suspending it. This is for the sake of terminals
with multiple screens of memory, where the termcap entry has been set
up to switch between screens when Emacs is suspended and resumed.
-** New argument to `set-screen-height' or `set-screen-width'.
+*** New argument to `set-screen-height' or `set-screen-width'.
These functions now take an optional second argument which says
what significance the newly specified height or width has.
@@ -1293,9 +1293,9 @@ to move the cursor to the last line will do.
2. The ``real'' height of the terminal determines how much padding is
needed.
-* File-related changes.
+** File-related changes.
-** New parameter `backup-by-copying-when-mismatch'.
+*** New parameter `backup-by-copying-when-mismatch'.
If this variable is non-`nil', then when Emacs is about to save a
file, it will create the backup file by copying if that would avoid
@@ -1307,7 +1307,7 @@ last. I recommend that this variable be left normally `nil' and
changed with a local variables list in those particular files where
the uid needs to be preserved.
-** New parameter `file-precious-flag'.
+*** New parameter `file-precious-flag'.
If this variable is non-`nil', saving the buffer tries to avoid
leaving an incomplete file due to disk full or other I/O errors.
@@ -1317,14 +1317,14 @@ file is renamed back to the name you visited.
Backups are always made by copying for such files.
-** New variable `buffer-offer-save'.
+*** New variable `buffer-offer-save'.
If the value of this variable is non-`nil' in a buffer then exiting
Emacs will offer to save the buffer (if it is modified and nonempty)
even if the buffer is not visiting a file. This variable is
automatically made local to the current buffer whenever it is set.
-** `rename-file', `copy-file', `add-name-to-file' and `make-symbolic-link'.
+*** `rename-file', `copy-file', `add-name-to-file' and `make-symbolic-link'.
The third argument to these functions used to be `t' or `nil'; `t'
meaning go ahead even if the specified new file name already has a file,
@@ -1333,13 +1333,13 @@ and `nil' meaning to get an error.
Now if the third argument is a number it means to ask the user for
confirmation in this case.
-** New optional argument to `copy-file'.
+*** New optional argument to `copy-file'.
If `copy-file' receives a non-nil fourth argument, it attempts
to give the new copy the same time-of-last-modification that the
original file has.
-** New function `file-newer-than-file-p'.
+*** New function `file-newer-than-file-p'.
(file-newer-than-file-p FILE1 FILE2) returns non-nil if FILE1 has been
modified more recently than FILE2. If FILE1 does not exist, the value
@@ -1347,24 +1347,24 @@ is always nil; otherwise, if FILE2 does not exist, the value is t.
This is meant for use when FILE2 depends on FILE1, to see if changes
in FILE1 make it necessary to recompute FILE2 from it.
-** Changed function `file-exists-p'.
+*** Changed function `file-exists-p'.
This function is no longer the same as `file-readable-p'.
`file-exists-p' can now return t for a file that exists but which
the fascists won't allow you to read.
-** New function `file-locked-p'.
+*** New function `file-locked-p'.
This function receives a file name as argument and returns `nil'
if the file is not locked, `t' if locked by this Emacs, or a
string giving the name of the user who has locked it.
-** New function `file-name-sans-versions'.
+*** New function `file-name-sans-versions'.
(file-name-sans-versions NAME) returns a substring of NAME, with any
version numbers or other backup suffixes deleted from the end.
-** New functions for directory names.
+*** New functions for directory names.
Although a directory is really a kind of file, specifying a directory
uses a somewhat different syntax from specifying a file.
@@ -1390,7 +1390,7 @@ and (directory-file-name "/usr/rms/") returns "/usr/rms".
On VMS, (file-name-as-directory "du:[rms]foo.dir") returns "du:[rms.foo]"
and (directory-file-name "du:[rms.foo]") returns "du:[rms]foo.dir".
-** Value of `file-attributes' changed.
+*** Value of `file-attributes' changed.
The function file-attributes returns a list containing many kinds of
information about a file. Now the list has eleven elements.
@@ -1403,14 +1403,14 @@ the same directory by you.
The eleventh element is the inode number of the file.
-** VMS-only function `file-name-all-versions'.
+*** VMS-only function `file-name-all-versions'.
This function returns a list of all the completions, including version
number, of a specified version-number-less file name. This is like
`file-name-all-completions', except that the latter returns values
that do not include version numbers.
-** VMS-only variable `vms-stmlf-recfm'.
+*** VMS-only variable `vms-stmlf-recfm'.
On a VMS system, if this variable is non-nil, Emacs will give newly
created files the record format `stmlf'. This is necessary for files
@@ -1423,46 +1423,46 @@ no effect.
This variable has no effect on Unix systems.
-** `insert-file-contents' on an empty file.
+*** `insert-file-contents' on an empty file.
This no longer sets the buffer's "modified" flag.
-** New function (VMS only) `define-logical-name':
+*** New function (VMS only) `define-logical-name':
(define-logical-name LOGICAL TRANSLATION) defines a VMS logical name
LOGICAL whose translation is TRANSLATION. The new name applies to
the current process only.
-** Deleted variable `ask-about-buffer-names'.
+*** Deleted variable `ask-about-buffer-names'.
If you want buffer names for files to be generated in a special way,
you must redefine `create-file-buffer'.
-* Subprocess-related changes.
+** Subprocess-related changes.
-** New function `process-list'.
+*** New function `process-list'.
This function takes no arguments and returns a list of all
of Emacs's asynchronous subprocesses.
-** New function `process-exit-status'.
+*** New function `process-exit-status'.
This function, given a process, process name or buffer as argument,
returns the exit status code or signal number of the process.
If the process has not yet exited or died, this function returns 0.
-** Process output ignores `buffer-read-only'.
+*** Process output ignores `buffer-read-only'.
Output from a process will go into the process's buffer even if the
buffer is read only.
-** Switching buffers in filter functions and sentinels.
+*** Switching buffers in filter functions and sentinels.
Emacs no longer saves and restore the current buffer around calling
the filter and sentinel functions, so these functions can now
permanently alter the selected buffer in a straightforward manner.
-** Specifying environment variables for subprocesses.
+*** Specifying environment variables for subprocesses.
When a subprocess is started with `start-process' or `call-process',
the value of the variable `process-environment' is taken to
@@ -1472,38 +1472,38 @@ value should be a list of strings, each of the form "VAR=VALUE".
`process-environment' is initialized when Emacs starts up
based on Emacs's environment.
-** New variable `process-connection-type'.
+*** New variable `process-connection-type'.
If this variable is `nil', when a subprocess is created, Emacs uses
a pipe rather than a pty to communicate with it. Normally this
variable is `t', telling Emacs to use a pty if ptys are supported
and one is available.
-** New function `waiting-for-user-input-p'.
+*** New function `waiting-for-user-input-p'.
This function, given a subprocess as argument, returns `t' if that
subprocess appears to be waiting for input sent from Emacs,
or `nil' otherwise.
-** New hook `shell-set-directory-error-hook'.
+*** New hook `shell-set-directory-error-hook'.
The value of this variable is called, with no arguments, whenever
Shell mode gets an error trying to keep track of directory-setting
commands (such as `cd' and `pushd') used in the shell buffer.
-* New functions `user-uid' and `user-real-uid'.
+** New functions `user-uid' and `user-real-uid'.
These functions take no arguments and return, respectively,
the effective uid and the real uid of the Emacs process.
The value in each case is an integer.
-* New variable `print-escape-newlines' controls string printing.
+** New variable `print-escape-newlines' controls string printing.
If this variable is non-`nil', then when a Lisp string is printed
by the Lisp printing function `prin1' or `print', newline characters
are printed as `\n' rather than as a literal newline.
-* New function `sysnetunam' on HPUX.
+** New function `sysnetunam' on HPUX.
This function takes two arguments, a network address PATH and a
login string LOGIN, and executes the system call `netunam'.
@@ -1511,7 +1511,7 @@ It returns `t' if the call succeeds, otherwise `nil'.
News regarding installation:
-* Many `s-...' file names changed.
+** Many `s-...' file names changed.
Many `s-...' files have been renamed. All periods in such names,
except the ones just before the final `h', have been changed to
@@ -1519,7 +1519,7 @@ hyphens. Thus, `s-bsd4.2.h' has been renamed to `s-bsd4-2.h'.
This is so a Unix distribution can be moved mechanically to VMS.
-* `DOCSTR...' file now called `DOC-...'.
+** `DOCSTR...' file now called `DOC-...'.
The file of on-line documentation strings, that used to be
`DOCSTR.mm.nn.oo' in this directory, is now called `DOC-mm.nn.oo'.
@@ -1529,11 +1529,11 @@ for translating filenames for VMS.
This file also now contains the doc strings for variables as
well as functions.
-* Emacs no longer uses floating point arithmetic.
+** Emacs no longer uses floating point arithmetic.
This may make it easier to port to some machines.
-* Macros `XPNTR' and `XSETPNTR'; flag `DATA_SEG_BITS'.
+** Macros `XPNTR' and `XSETPNTR'; flag `DATA_SEG_BITS'.
These macros exclusively are used to unpack a pointer from a Lisp_Object
and to insert a pointer into a Lisp_Object. Redefining them may help
@@ -1543,7 +1543,7 @@ certain high bits set.
If `DATA_SEG_BITS' is defined, it should be a number which contains
the high bits to be inclusive or'ed with pointers that are unpacked.
-* New flag `HAVE_X_MENU'.
+** New flag `HAVE_X_MENU'.
Define this flag in `config.h' in addition to `HAVE_X_WINDOWS'
to enable use of the Emacs interface to X Menus. On some operating
@@ -1551,11 +1551,11 @@ systems, the rest of the X interface works properly but X Menus
do not work; hence this separate flag. See the file `src/xmenu.c'
for more information.
-* Macros `ARRAY_MARK_FLAG' and `DONT_COPY_FLAG'.
+** Macros `ARRAY_MARK_FLAG' and `DONT_COPY_FLAG'.
-* `HAVE_ALLOCA' prevents assembly of `alloca.s'.
+** `HAVE_ALLOCA' prevents assembly of `alloca.s'.
-* `SYSTEM_MALLOC' prevents use of GNU `malloc.c'.
+** `SYSTEM_MALLOC' prevents use of GNU `malloc.c'.
SYSTEM_MALLOC, if defined, means use the system's own `malloc' routines
rather than those that come with Emacs.
@@ -1563,21 +1563,21 @@ rather than those that come with Emacs.
Use this only if absolutely necessary, because if it is used you do
not get warnings when space is getting low.
-* New flags to control unexec.
+** New flags to control unexec.
See the file `unexec.c' for a long comment on the compilation
switches that suffice to make it work on many machines.
-* `PNTR_COMPARISON_TYPE'
+** `PNTR_COMPARISON_TYPE'
Pointers that need to be compared for ordering are converted to this type
first. Normally this is `unsigned int'.
-* `HAVE_VFORK', `HAVE_DUP2' and `HAVE_GETTIMEOFDAY'.
+** `HAVE_VFORK', `HAVE_DUP2' and `HAVE_GETTIMEOFDAY'.
These flags just say whether certain system calls are available.
-* New macros control compiler switches, linker switches and libraries.
+** New macros control compiler switches, linker switches and libraries.
The m- and s- files can now control in a modular fashion the precise
arguments passed to `cc' and `ld'.
@@ -1618,5 +1618,5 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
Local variables:
-mode: text
+mode: outline
end:
diff --git a/etc/NEWS.19 b/etc/NEWS.19
index 617248e31ad..757d029941b 100644
--- a/etc/NEWS.19
+++ b/etc/NEWS.19
@@ -438,7 +438,7 @@ The other accent characters, not needed for the chosen language,
remain normal.
** Posting articles and sending mail now has M-TAB completion on various
-header fields (Newsgroups, To, CC, ...).
+header fields (Newsgroups, To, Cc, ...).
Completion in the Newsgroups header depends on the list of groups
known to your news reader. Completion in the Followup-To header
@@ -2087,7 +2087,7 @@ arguments are ARGS.
for mail-default-reply-to.
** When you send a message in Emacs, if you specify an Rmail file with
-the FCC: header field, Emacs converts the message to Rmail format
+the Fcc: header field, Emacs converts the message to Rmail format
before writing it. Thus, the file never contains anything but Rmail
format messages.
@@ -4341,7 +4341,7 @@ turn the character that follows into a hyper character:
(defun hyperify (prompt)
(let ((e (read-event)))
(vector (if (numberp e)
- (logior (lsh 1 20) e)
+ (logior (ash 1 20) e)
(if (memq 'hyper (event-modifiers e))
e
(add-event-modifier "H-" e))))))
diff --git a/etc/NEWS.20 b/etc/NEWS.20
index ff687015cca..931e2273732 100644
--- a/etc/NEWS.20
+++ b/etc/NEWS.20
@@ -986,7 +986,7 @@ be prompted for confirmation
**** can generate a MESSAGE-ID: line and a DATE: line; the date can be
the time the message was written or the time it is being sent; this
-can make FCC copies more closely resemble copies that recipients get
+can make Fcc copies more closely resemble copies that recipients get
**** you can specify an arbitrary function for actually transmitting
the message; included in feedmail are interfaces for /bin/[r]mail,
diff --git a/etc/NEWS.26 b/etc/NEWS.26
new file mode 100644
index 00000000000..f570f759b9a
--- /dev/null
+++ b/etc/NEWS.26
@@ -0,0 +1,1929 @@
+GNU Emacs NEWS -- history of user-visible changes.
+
+Copyright (C) 2016-2019 Free Software Foundation, Inc.
+See the end of the file for license conditions.
+
+Please send Emacs bug reports to 'bug-gnu-emacs@gnu.org'.
+If possible, use 'M-x report-emacs-bug'.
+
+This file is about changes in Emacs version 26.
+
+See file HISTORY for a list of GNU Emacs versions and release dates.
+See files NEWS.25, NEWS.24, ..., NEWS.18, and NEWS.1-17 for changes
+in older Emacs versions.
+
+You can narrow news to a specific version by calling 'view-emacs-news'
+with a prefix argument or by typing 'C-u C-h C-n'.
+
+
+* Installation Changes in Emacs 26.2
+
+** Building Emacs with the '--with-xwidgets' option now requires WebKit2.
+To build Emacs with xwidgets support, you will need to install the
+webkit2gtk-4.0 package; version 2.12 or later is required.
+(This change was actually made in Emacs 26.1, but was not called out
+in its NEWS.)
+
+** Installing Emacs now installs the emacs-module.h file.
+The emacs-module.h file is now installed in the system-wide include
+directory as part of the Emacs installation. This allows to build
+Emacs modules outside of the Emacs source tree.
+
+
+* Startup Changes in Emacs 26.2
+
+
+* Changes in Emacs 26.2
+
+** Emacs is now compliant with the latest version 11.0 of the Unicode Standard.
+
+** New variable 'xft-ignore-color-fonts'.
+Default t means don't try to load color fonts when using Xft, as they
+often cause crashes. Set it to nil if you really need those fonts.
+
+
+* Editing Changes in Emacs 26.2
+
+
+* Changes in Specialized Modes and Packages in Emacs 26.2
+
+** Dired
+
+*** The 'Z' command on a directory name compresses all of its files.
+It produces a compressed '.tar.gz' archive with all the files in the
+directory and all of its subdirectories. For symmetry, 'Z' on a
+'.tar.gz' or a '.tgz' archive extracts all the archived files into the
+current directory; thus, typing 'Z' on a '.tar.gz' archive created by
+a previous 'Z' command will extract the archived files into a
+directory whose name is the archive name sans the '.tar.gz' extension.
+(This change was actually made in Emacs 25.1 but was only
+partially called out in its NEWS; 'tgz' handling was added in 26.1.)
+
+** Ibuffer
+
+*** New toggle 'ibuffer-do-toggle-lock', bound to 'L'.
+
+** Imenu
+
+*** The value for 'imenu-auto-rescan-maxout' has been increased to 600000.
+
+** Gnus
+
+*** Mailutils movemail will now be used if found at runtime.
+The default value of 'mail-source-movemail-program' is now "movemail".
+This ensures that the movemail program from GNU Mailutils will be used
+if found in 'exec-path', even if it was not found at build time. To
+use a different program, customize 'mail-source-movemail-program' to the
+absolute file name of the desired executable.
+
+** Shadowfile
+
+*** shadowfile.el has been rewritten to support Tramp file names.
+
+** Shell mode
+
+*** Shell mode buffers now have 'scroll-conservatively' set to 101.
+This is so as to better emulate the scrolling behavior of a text
+terminal when new output is added to the screen buffer. To get back
+the previous behavior, reset 'scroll-conservatively' to zero (or any
+other value you like) in a function and add it to 'shell-mode-hook'.
+(This change was actually made in Emacs 26.1, but was not called out
+in its NEWS.)
+
+** VC
+
+*** VC support for Mercurial was improved.
+Emacs now avoids invoking 'hg' as much as possible, for faster operation.
+(This and the following changes were actually made in Emacs 26.1, but
+were not called out in its NEWS.)
+
+**** New vc-hg options.
+The new option 'vc-hg-parse-hg-data-structures' controls whether vc-hg
+will try parsing the Mercurial data structures directly instead of
+running 'hg'; it defaults to t (set to nil if you want the pre-26.1
+behavior).
+The new option 'vc-hg-symbolic-revision-styles' controls how versions
+in a Mercurial repository are presented symbolically on the mode line.
+The new option 'vc-hg-use-file-version-for-mode-line-version' controls
+whether the version shown on the mode line is that of the visited file
+or of the repository working copy.
+
+**** Display of Mercurial revisions in the mode line has changed.
+Previously, the mode line displayed the local number (1, 2, 3, ...) of
+the revision. Starting with Emacs 26.1, the default has changed, and
+it now shows the global revision number, in the form of its changeset
+hash value. To get back the previous behavior, customize the new
+option 'vc-hg-symbolic-revision-styles' to the value '("{rev}")'.
+
+
+* New Modes and Packages in Emacs 26.2
+
+
+* Incompatible Lisp Changes in Emacs 26.2
+
+** shadowfile config files have changed their syntax.
+Existing files "~/.emacs.d/shadows" and "~/.emacs.d/shadow_todo" must
+be removed prior using the changed 'shadow-*' commands.
+
+** 'thread-alive-p' has been renamed to 'thread-live-p'.
+The old name is an alias of the new name. Future Emacs version will
+obsolete it.
+
+** 'while-no-input' does not return due to input from subprocesses.
+Input that arrived from subprocesses while some code executed inside
+the 'while-no-input' form injected an internal buffer-switch event
+that counted as input and would cause 'while-no-input' to return,
+perhaps prematurely. These buffer-switch events are now by default
+ignored by 'while-no-input'; if you need to get the old behavior,
+remove 'buffer-switch' from the list of events in
+'while-no-input-ignore-events'.
+
+
+* Lisp Changes in Emacs 26.2
+
+** The new function 'read-answer' accepts either long or short answers
+depending on the new customizable variable 'read-answer-short'.
+
+** New function 'assoc-delete-all'.
+Like 'assq-delete-all', but uses 'equal' for comparison.
+
+** The function 'thing-at-point' behaves as before Emacs 26.1.
+The behavior of 'thing-at-point' when called with argument 'list' has
+changed in Emacs 26.1, in that it didn't consider text inside comments
+and strings as a potential list. This change is now reverted, and
+'thing-at-point' behaves like it did before Emacs 26.1.
+
+** To cater to use cases where comments and strings are to be ignored
+when looking for a list, the function 'list-at-point' now takes an
+optional argument to do so.
+
+
+* Changes in Emacs 26.2 on Non-Free Operating Systems
+
+** macOS features can now be detected at run-time as well as at
+build-time. See nextstep/INSTALL for details.
+(This change was actually made in Emacs 26.1, but was undocumented and
+not called out in its NEWS.)
+
+
+* Installation Changes in Emacs 26.1
+
+** By default libgnutls is now required when building Emacs.
+Use 'configure --with-gnutls=no' to build even when GnuTLS is missing.
+
+** GnuTLS version 2.12.2 or later is now required, instead of merely
+version 2.6.6 or later.
+
+** The new option 'configure --with-mailutils' causes Emacs to rely on
+GNU Mailutils to retrieve email. It is recommended, and is the
+default if GNU Mailutils is installed. When '--with-mailutils' is not
+in effect, the Emacs build procedure by default continues to build and
+install a limited 'movemail' substitute that retrieves POP3 email only
+via insecure channels. To avoid this problem, use either
+'--with-mailutils' or '--without-pop' when configuring; '--without-pop'
+is the default on platforms other than native MS-Windows.
+
+** The new option 'configure --enable-gcc-warnings=warn-only' causes
+GCC to issue warnings without stopping the build. This behavior is
+now the default in developer builds. As before, use
+'--disable-gcc-warnings' to suppress GCC's warnings, and
+'--enable-gcc-warnings' to stop the build if GCC issues warnings.
+
+** When GCC warnings are enabled, '--enable-check-lisp-object-type' is
+now enabled by default when configuring.
+
+** The Emacs server now has socket-launching support.
+This allows socket based activation, where an external process like
+systemd can invoke the Emacs server process upon a socket connection
+event and hand the socket over to Emacs. Emacs uses this socket to
+service emacsclient commands. This new functionality can be disabled
+with the configure option '--disable-libsystemd'.
+
+** A systemd user unit file is provided.
+Use it in the standard way: 'systemctl --user enable emacs'. (If your
+Emacs is installed in a non-standard location, you may need to copy
+the emacs.service file to eg ~/.config/systemd/user/)
+
+** New configure option '--disable-build-details' attempts to build an
+Emacs that is more likely to be reproducible; that is, if you build
+and install Emacs twice, the second Emacs is a copy of the first.
+Deterministic builds omit the build date from the output of the
+'emacs-version' and 'erc-cmd-SV' functions, and the leave the
+following variables nil: 'emacs-build-system', 'emacs-build-time',
+'erc-emacs-build-time'.
+
+** Emacs can now be built with support for Little CMS.
+If the lcms2 library is installed, Emacs will enable features built on
+top of that library. The new configure option '--without-lcms2' can
+be used to build without lcms2 support even if it is installed. Emacs
+linked to Little CMS exposes color management functions in Lisp: the
+color metrics 'lcms-cie-de2000' and 'lcms-cam02-ucs', as well as
+functions for conversion to and from CIE CAM02 and CAM02-UCS.
+
+** The configure option '--with-gameuser' now defaults to 'no',
+as this appears to be the most common configuration in practice.
+When it is 'no', the shared game directory and the auxiliary program
+update-game-score are no longer needed and are not installed.
+
+** Emacs no longer works on IRIX. We expect that Emacs users are not
+affected by this, as SGI stopped supporting IRIX in December 2013.
+
+
+* Startup Changes in Emacs 26.1
+
+** New option '--fg-daemon'. This is the same as '--daemon', except
+it runs in the foreground and does not fork. This is intended for
+modern init systems such as systemd, which manage many of the traditional
+aspects of daemon behavior themselves. '--bg-daemon' is now an alias
+for '--daemon'.
+
+** New option '--module-assertions'.
+When given this option, Emacs will perform expensive correctness
+checks when dealing with dynamic modules. This is intended for module
+authors that wish to verify that their module conforms to the module
+requirements. The option makes Emacs abort if a module-related
+assertion triggers.
+
+** Emacs now supports 24-bit colors on capable text terminals.
+Terminal is automatically initialized to use 24-bit colors if the
+required capabilities are found in terminfo. See the FAQ node
+"(efaq) Colors on a TTY" for more information.
+
+** Emacs now obeys the X resource "scrollBar" at startup.
+The effect is similar to that of "toolBar" resource on the tool bar.
+
+
+* Changes in Emacs 26.1
+
+** Option 'buffer-offer-save' can be set to new value, 'always'.
+When set to 'always', the command 'save-some-buffers' will always
+offer this buffer for saving.
+
+** Security vulnerability related to Enriched Text mode is removed.
+
+*** Enriched Text mode does not evaluate Lisp in 'display' properties.
+This feature allows saving 'display' properties as part of text.
+Emacs 'display' properties support evaluation of arbitrary Lisp forms
+as part of processing the property for display, so displaying Enriched
+Text could be vulnerable to executing arbitrary malicious Lisp code
+included in the text (e.g., sent as part of an email message).
+Therefore, execution of arbitrary Lisp forms in 'display' properties
+decoded by Enriched Text mode is now disabled by default. Customize
+the new option 'enriched-allow-eval-in-display-props' to a non-nil
+value to allow Lisp evaluation in decoded 'display' properties.
+
+This vulnerability was introduced in Emacs 21.1. To work around that
+in Emacs versions before 25.3, append the following to your ~/.emacs
+init file:
+
+ (eval-after-load "enriched"
+ '(defun enriched-decode-display-prop (start end &optional param)
+ (list start end)))
+
+** Functions in 'write-contents-functions' can fully short-circuit the
+'save-buffer' process. Previously, saving a buffer that was not
+visiting a file would always prompt for a file name. Now it only does
+so if 'write-contents-functions' is nil (or all its functions return
+nil).
+
+** New variable 'executable-prefix-env' for inserting magic signatures.
+This variable affects the format of the interpreter magic number
+inserted by 'executable-set-magic'. If non-nil, the magic number now
+takes the form "#!/usr/bin/env interpreter", otherwise the value
+determined by 'executable-prefix', which is by default
+"#!/path/to/interpreter". By default, 'executable-prefix-env' is nil,
+so the default behavior is not changed.
+
+** The variable 'emacs-version' no longer includes the build number.
+This is now stored separately in a new variable, 'emacs-build-number'.
+
+** Emacs now provides a limited form of concurrency with Lisp threads.
+Concurrency in Emacs Lisp is "mostly cooperative", meaning that
+Emacs will only switch execution between threads at well-defined
+times: when Emacs waits for input, during blocking operations related
+to threads (such as mutex locking), or when the current thread
+explicitly yields. Global variables are shared among all threads, but
+a 'let' binding is thread-local. Each thread also has its own current
+buffer and its own match data.
+
+See the chapter "(elisp) Threads" in the ELisp manual for full
+documentation of these facilities.
+
+** The new user variable 'electric-quote-chars' provides a list
+of curved quotes for 'electric-quote-mode', allowing user to choose
+the types of quotes to be used.
+
+** The new user option 'electric-quote-context-sensitive' makes
+'electric-quote-mode' context sensitive. If it is non-nil, you can
+type an ASCII apostrophe to insert an opening or closing quote,
+depending on context. Emacs will replace the apostrophe by an opening
+quote character at the beginning of the buffer, the beginning of a
+line, after a whitespace character, and after an opening parenthesis;
+and it will replace the apostrophe by a closing quote character in all
+other cases.
+
+** The new variable 'electric-quote-inhibit-functions' controls when
+to disable electric quoting based on context. Major modes can add
+functions to this list; Emacs will temporarily disable
+'electric-quote-mode' whenever any of the functions returns non-nil.
+This can be used by major modes that derive from 'text-mode' but allow
+inline code segments, such as 'markdown-mode'.
+
+** The new user variable 'dired-omit-case-fold' allows the user to
+customize the case-sensitivity of dired-omit-mode. It defaults to
+the same sensitivity as that of the filesystem for the corresponding
+dired buffer.
+
+** Emacs now uses double buffering to reduce flicker when editing and
+resizing graphical Emacs frames on the X Window System. This support
+requires the DOUBLE-BUFFER extension, which major X servers have
+supported for many years. If your system has this extension, but an
+Emacs built with double buffering misbehaves on some displays you use,
+you can disable the feature by adding
+
+ '(inhibit-double-buffering . t)
+
+to default-frame-alist. Or inject this parameter into the selected
+frame by evaluating this form:
+
+ (modify-frame-parameters nil '((inhibit-double-buffering . t)))
+
+** The customization group 'wp', whose label was "text", is now
+deprecated. Use the new group 'text', which inherits from 'wp',
+instead.
+
+** The new function 'call-shell-region' executes a command in an
+inferior shell with the buffer region as input.
+
+** The new user option 'shell-command-dont-erase-buffer' controls
+if the output buffer is erased between shell commands; if non-nil,
+the output buffer is not erased; this variable also controls where
+to set the point in the output buffer: beginning of the output,
+end of the buffer or save the point.
+When 'shell-command-dont-erase-buffer' is nil, the default value,
+the behavior of 'shell-command', 'shell-command-on-region' and
+'async-shell-command' is as usual.
+
+** The new user option 'async-shell-command-display-buffer' controls
+whether the output buffer of an asynchronous command is shown
+immediately, or only when there is output.
+
+** New user option 'mouse-select-region-move-to-beginning'.
+This option controls the position of point when double-clicking
+mouse-1 on the end of a parenthetical grouping or string-delimiter:
+the default value nil keeps point at the end of the region, setting it
+to non-nil moves point to the beginning of the region.
+
+** New user option 'mouse-drag-and-drop-region'.
+This option allows you to drag the entire region of text to another
+place or another buffer. Its behavior is customizable via the new
+options 'mouse-drag-and-drop-region-cut-when-buffers-differ',
+'mouse-drag-and-drop-region-show-tooltip', and
+'mouse-drag-and-drop-region-show-cursor'.
+
+** The new user option 'confirm-kill-processes' allows the user to
+skip a confirmation prompt for killing subprocesses when exiting
+Emacs. When set to t (the default), Emacs will prompt for
+confirmation before killing subprocesses on exit, which is the same
+behavior as before.
+
+** 'find-library-name' will now fall back on looking at 'load-history'
+to try to locate libraries that have been loaded with an explicit path
+outside 'load-path'.
+
+** Faces in 'minibuffer-prompt-properties' no longer overwrite properties
+in the text in functions like 'read-from-minibuffer', but instead are
+added to the end of the face list. This allows users to say things
+like '(read-from-minibuffer (propertize "Enter something: " 'face 'bold))'.
+
+** The new variable 'extended-command-suggest-shorter' has been added
+to control whether to suggest shorter 'M-x' commands or not.
+
+** icomplete now respects 'completion-ignored-extensions'.
+
+** Non-breaking hyphens are now displayed with the 'nobreak-hyphen'
+face instead of the 'escape-glyph' face.
+
+** Approximations to quotes are now displayed with the new 'homoglyph'
+face instead of the 'escape-glyph' face.
+
+** New face 'header-line-highlight'.
+This face is the header-line analogue of 'mode-line-highlight'; it
+should be the preferred mouse-face for mouse-sensitive elements in the
+header line.
+
+** 'C-x h' ('mark-whole-buffer') will now avoid marking the prompt
+part of minibuffers.
+
+** 'fill-paragraph' no longer marks the buffer as changed unless it
+actually changed something.
+
+** The locale language name 'ca' is now mapped to the language
+environment 'Catalan', which has been added.
+
+** 'align-regexp' has a separate history for its interactive argument.
+'align-regexp' no longer shares its history with all other
+history-less functions that use 'read-string'.
+
+** The networking code has been reworked so that it's more
+asynchronous than it was (when specifying :nowait t in
+'make-network-process'). How asynchronous it is varies based on the
+capabilities of the system, but on a typical GNU/Linux system the DNS
+resolution, the connection, and (for TLS streams) the TLS negotiation
+are all done without blocking the main Emacs thread. To get
+asynchronous TLS, the TLS boot parameters have to be passed in (see
+the manual for details).
+
+Certain process oriented functions (like 'process-datagram-address')
+will block until socket setup has been performed. The recommended way
+to deal with asynchronous sockets is to avoid interacting with them
+until they have changed status to "run". This is most easily done
+from a process sentinel.
+
+** 'make-network-process' and 'open-network-stream' sometimes allowed
+:service to be an integer string (e.g., :service "993") and sometimes
+required an integer (e.g., :service 993). This difference has been
+eliminated, and integer strings work everywhere.
+
+** It is possible to disable attempted recovery on fatal signals.
+Two new variables support disabling attempts to recover from stack
+overflow and to avoid automatic auto-save when Emacs is delivered a
+fatal signal. 'attempt-stack-overflow-recovery', if set to nil,
+will disable attempts to recover from C stack overflows; Emacs will
+then crash as with any other fatal signal.
+'attempt-orderly-shutdown-on-fatal-signal', if set to nil, will
+disable attempts to auto-save the session and shut down in an orderly
+fashion when Emacs receives a fatal signal; instead, Emacs will
+terminate immediately. Both variables are non-nil by default.
+These variables are for users who would like to avoid the small
+probability of data corruption due to techniques Emacs uses to recover
+in these situations.
+
+** File local and directory local variables are now initialized each
+time the major mode is set, not just when the file is first visited.
+These local variables will thus not vanish on setting a major mode.
+
+** A second dir-local file (.dir-locals-2.el) is now accepted.
+See the doc string of 'dir-locals-file' for more information.
+
+** Connection-local variables can be used to specify local variables
+with a value depending on the connected remote server. For details,
+see the node "(elisp) Connection Local Variables" in the ELisp manual.
+
+** International domain names (IDNA) are now encoded via the new
+puny.el library, so that one can visit Web sites with non-ASCII URLs.
+
+** The new 'list-timers' command lists all active timers in a buffer,
+where you can cancel them with the 'c' command.
+
+** 'switch-to-buffer-preserve-window-point' now defaults to t.
+Applications that call 'switch-to-buffer' and want to show the buffer at
+the position of its point should use 'pop-to-buffer-same-window' in lieu
+of 'switch-to-buffer'.
+
+** The new variable 'debugger-stack-frame-as-list' allows displaying
+all call stack frames in a Lisp backtrace buffer as lists. Both
+debug.el and edebug.el have been updated to heed to this variable.
+
+** Values in call stack frames are now displayed using 'cl-prin1'.
+The old behavior of using 'prin1' can be restored by customizing the
+new option 'debugger-print-function'.
+
+** NUL bytes in text copied to the system clipboard are now replaced with "\0".
+
+** The new variable 'x-ctrl-keysym' has been added to the existing
+roster of X keysyms. It can be used in combination with another
+variable of this kind to swap modifiers in Emacs.
+
+** New input methods: 'cyrillic-tuvan', 'polish-prefix', 'uzbek-cyrillic'.
+
+** The 'dutch' input method no longer attempts to support Turkish too.
+Also, it no longer converts 'IJ' and 'ij' to the compatibility
+characters U+0132 LATIN CAPITAL LIGATURE IJ and U+0133 LATIN SMALL
+LIGATURE IJ.
+
+** File name quoting by adding the prefix "/:" is now possible for the
+local part of a remote file name. Thus, if you have a directory named
+"/~" on the remote host "foo", you can prevent it from being
+substituted by a home directory by writing it as "/foo:/:/~/file".
+
+** The new variable 'maximum-scroll-margin' allows having effective
+settings of 'scroll-margin' up to half the window size, instead of
+always restricting the margin to a quarter of the window.
+
+** Emacs can scroll horizontally using mouse, touchpad, and trackbar.
+You can enable this by customizing 'mouse-wheel-tilt-scroll'. If you
+want to reverse the direction of the scroll, customize
+'mouse-wheel-flip-direction'.
+
+** The default GnuTLS priority string now includes %DUMBFW.
+This is to avoid bad behavior in some firewalls, which causes the
+connection to be closed by the remote host.
+
+** Emacsclient changes
+
+*** Emacsclient has a new option '-u' / '--suppress-output'.
+This option suppresses display of return values from the server
+process.
+
+*** Emacsclient has a new option '-T' / '--tramp'.
+This helps with using a local Emacs session as the server for a remote
+emacsclient. With appropriate setup, one can now set the EDITOR
+environment variable on a remote machine to emacsclient, and
+use the local Emacs to edit remote files via Tramp. See the node
+"(emacs) emacsclient Options" in the user manual for the details.
+
+*** Emacsclient now accepts command-line options in ALTERNATE_EDITOR
+and '--alternate-editor'. For example, ALTERNATE_EDITOR="emacs -Q -nw".
+Arguments may be quoted "like this", so that for example an absolute
+path containing a space may be specified; quote escaping is not
+supported.
+
+** New user option 'dig-program-options' and extended functionality
+for DNS-querying functions 'nslookup-host', 'dns-lookup-host',
+and 'run-dig'. Each function now accepts an optional name server
+argument interactively (with a prefix argument) and non-interactively.
+
+** 'describe-key-briefly' now ignores mouse movement events.
+
+** The new variable 'eval-expression-print-maximum-character' prevents
+large integers from being displayed as characters by 'M-:' and similar
+commands.
+
+** Two new commands for finding the source code of Emacs Lisp
+libraries: 'find-library-other-window' and 'find-library-other-frame'.
+
+** The new variable 'display-raw-bytes-as-hex' allows you to change
+the display of raw bytes from octal to hex.
+
+** You can now provide explicit field numbers in format specifiers.
+For example, '(format "%2$s %1$s %2$s" "X" "Y")' produces "Y X Y".
+
+** Emacs now supports optional display of line numbers in the buffer.
+This is similar to what 'linum-mode' provides, but much faster and
+doesn't usurp the display margin for the line numbers. Customize the
+buffer-local variable 'display-line-numbers' to activate this optional
+display. Alternatively, you can use the 'display-line-numbers-mode'
+minor mode or the global 'global-display-line-numbers-mode'. When
+using these modes, customize 'display-line-numbers-type' with the same
+value as you would use with 'display-line-numbers'.
+
+Line numbers are not displayed at all in minibuffer windows and in
+tooltips, as they are not useful there.
+
+Lisp programs can disable line-number display for a particular screen
+line by putting the 'display-line-numbers-disable' text property or
+overlay property on the first character of that screen line. This is
+intended for add-on packages that need a finer control of the display.
+
+Lisp programs that need to know how much screen estate is used up for
+line-number display in a window can use the new function
+'line-number-display-width'.
+
+'linum-mode' and all similar packages are henceforth becoming obsolete.
+Users and developers are encouraged to switch to this new feature
+instead.
+
+** The new user option 'arabic-shaper-ZWNJ-handling' controls how to
+handle ZWNJ in Arabic text rendering.
+
+
+* Editing Changes in Emacs 26.1
+
+** New variable 'column-number-indicator-zero-based'.
+Traditionally, in Column Number mode, the displayed column number
+counts from zero starting at the left margin of the window. This
+behavior is now controlled by 'column-number-indicator-zero-based'.
+If you would prefer for the displayed column number to count from one,
+you may set this variable to nil. (Behind the scenes, there is now a
+new mode line construct, '%C', which operates exactly as '%c' does
+except that it counts from one.)
+
+** New single-line horizontal scrolling mode.
+The 'auto-hscroll-mode' variable can now have a new special value,
+'current-line', which causes only the line where the cursor is
+displayed to be horizontally scrolled when lines are truncated on
+display and point moves outside the left or right window margin.
+
+** New mode line constructs '%o' and '%q', and user option
+'mode-line-percent-position'. '%o' displays the "degree of travel" of
+the window through the buffer. Unlike the default '%p', this
+percentage approaches 100% as the window approaches the end of the
+buffer. '%q' displays the percentage offsets of both the start and
+the end of the window, e.g. "5-17%". The new option
+'mode-line-percent-position' makes it easier to switch between '%p',
+'%P', and these new constructs.
+
+** Two new user options 'list-matching-lines-jump-to-current-line' and
+'list-matching-lines-current-line-face' to show the current line
+highlighted in *Occur* buffer.
+
+** The 'occur' command can now operate on the region.
+
+** New bindings for 'query-replace-map'.
+'undo', undo the last replacement; bound to 'u'.
+'undo-all', undo all replacements; bound to 'U'.
+
+** 'delete-trailing-whitespace' deletes whitespace after form feed.
+In modes where form feed was treated as a whitespace character,
+'delete-trailing-whitespace' would keep lines containing it unchanged.
+It now deletes whitespace after the last form feed thus behaving the
+same as in modes where the character is not whitespace.
+
+** Emacs no longer prompts about editing a changed file when the file's
+content is unchanged. Instead of only checking the modification time,
+Emacs now also checks the file's actual content before prompting the user.
+
+** Various casing improvements.
+
+*** 'upcase', 'upcase-region' et al. convert title case characters
+(such as Dz) into their upper case form (such as DZ).
+
+*** 'capitalize', 'upcase-initials' et al. make use of title-case forms
+of initial characters (correctly producing for example Džungla instead
+of incorrect DŽungla).
+
+*** Characters which turn into multiple ones when cased are correctly handled.
+For example, fi ligature is converted to FI when upper cased.
+
+*** Greek small sigma is correctly handled when at the end of the word.
+Strings such as ΌΣΟΣ are now correctly converted to Όσος when
+capitalized instead of incorrect Όσοσ (compare lowercase sigma at the
+end of the word).
+
+** Emacs can now auto-save buffers to visited files in a more robust
+manner via the new mode 'auto-save-visited-mode'. Unlike
+'auto-save-visited-file-name', this mode uses the normal saving
+procedure and therefore obeys saving hooks.
+'auto-save-visited-file-name' is now obsolete.
+
+** New behavior of 'mark-defun'.
+Prefix argument selects that many (or that many more) defuns.
+Negative prefix arg flips the direction of selection. Also,
+'mark-defun' between defuns correctly selects N following defuns (or
+-N previous for negative arguments). Finally, comments preceding the
+defun are selected unless they are separated from the defun by a blank
+line.
+
+** New command 'replace-buffer-contents'.
+This command replaces the contents of the accessible portion of the
+current buffer with the contents of the accessible portion of a
+different buffer while keeping point, mark, markers, and text
+properties as intact as possible.
+
+** New commands 'apropos-local-variable' and 'apropos-local-value'.
+These are buffer-local versions of 'apropos-variable' and
+'apropos-value', respectively. They show buffer-local variables whose
+names and values, respectively, match a given pattern.
+
+** More user control of reordering bidirectional text for display.
+The two new variables, 'bidi-paragraph-start-re' and
+'bidi-paragraph-separate-re', allow customization of what exactly are
+paragraphs, for the purposes of bidirectional display.
+
+** New variable 'x-wait-for-event-timeout'.
+This controls how long Emacs will wait for updates to the graphical
+state to take effect (making a frame visible, for example).
+
+
+* Changes in Specialized Modes and Packages in Emacs 26.1
+
+** Emacs 26.1 comes with Org v9.1.6.
+See the file ORG-NEWS for user-visible changes in Org.
+
+** New function 'cl-generic-p'.
+
+** Dired
+
+*** You can answer 'all' in 'dired-do-delete' to delete recursively all
+remaining directories without more prompts.
+
+*** Dired supports wildcards in the directory part of the file names.
+
+*** You can now use '`?`' in 'dired-do-shell-command'.
+It gets replaced by the current file name, like ' ? '.
+
+*** A new option 'dired-always-read-filesystem' defaulting to nil.
+If non-nil, buffers visiting files are reverted before they are
+searched; for instance, in 'dired-mark-files-containing-regexp' a
+non-nil value of this option means the file is revisited in a
+temporary buffer; this temporary buffer is the actual buffer searched:
+the original buffer visiting the file is not modified.
+
+*** Users can now customize mouse clicks in Dired in a more flexible way.
+The new command 'dired-mouse-find-file' can be bound to a mouse click
+and used to visit files/directories in Dired in the selected window.
+The new command 'dired-mouse-find-file-other-frame' similarly visits
+files/directories in another frame. You can write your own commands
+that invoke 'dired-mouse-find-file' with non-default optional
+arguments, to tailor the effects of mouse clicks on file names in
+Dired buffers.
+
+*** In wdired, when editing files to contain slash characters,
+the resulting directories are automatically created. Whether to do
+this is controlled by the 'wdired-create-parent-directories' variable.
+
+*** 'W' is now bound to 'browse-url-of-dired-file', and is useful for
+viewing HTML files and the like.
+
+*** New variable 'dired-clean-confirm-killing-deleted-buffers'
+controls whether Dired asks to kill buffers visiting deleted files and
+directories. The default is t, so Dired asks for confirmation, to
+keep previous behavior.
+
+** html2text is now marked obsolete.
+
+** smerge-refine-regions can refine regions in separate buffers.
+
+** Info menu and index completion uses substring completion by default.
+This can be customized via the 'info-menu' category in
+'completion-category-overrides'.
+
+** The ancestor buffer is shown by default in 3-way merges.
+A new option 'ediff-show-ancestor' and a new toggle
+'ediff-toggle-show-ancestor'.
+
+** TeX: Add luatex and xetex as alternatives to pdftex.
+
+** Electric-Buffer-menu
+
+*** Key 'U' is bound to 'Buffer-menu-unmark-all' and key 'M-DEL' is
+bound to 'Buffer-menu-unmark-all-buffers'.
+
+** hideshow mode got four key bindings that are analogous to outline
+mode bindings: 'C-c @ C-a', 'C-c @ C-t', 'C-c @ C-d', and 'C-c @ C-e'.
+
+** bs
+
+*** Two new commands 'bs-unmark-all', bound to 'U', and
+'bs-unmark-previous', bound to <backspace>.
+
+** Buffer-menu
+
+*** Two new commands 'Buffer-menu-unmark-all', bound to 'U' and
+'Buffer-menu-unmark-all-buffers', bound to 'M-DEL'.
+
+** Checkdoc
+
+*** 'checkdoc-arguments-in-order-flag' now defaults to nil.
+
+** Gnus
+
+*** The ~/.newsrc file will now only be saved if the native select
+method is an NNTP select method.
+
+*** A new command for sorting articles by readedness marks has been
+added: 'C-c C-s C-m C-m'.
+
+*** In 'message-citation-line-format' the '%Z' format is now the time
+zone name instead of the numeric form. The '%z' format continues to
+be the numeric form. The new behavior is compatible with
+'format-time-string'.
+
+*** New user option 'gnus-rcvstore-options' provides a way to
+specify additional options when saving messages to an MH folder.
+
+** Ibuffer
+
+*** New command 'ibuffer-jump'.
+
+*** New filter commands 'ibuffer-filter-by-basename',
+'ibuffer-filter-by-file-extension', 'ibuffer-filter-by-directory',
+'ibuffer-filter-by-starred-name', 'ibuffer-filter-by-modified'
+and 'ibuffer-filter-by-visiting-file'; bound respectively
+to '/b', '/.', '//', '/*', '/i' and '/v'.
+
+*** Two new commands 'ibuffer-filter-chosen-by-completion'
+and 'ibuffer-and-filter', the second bound to '/&'.
+
+*** The commands 'ibuffer-pop-filter', 'ibuffer-pop-filter-group',
+'ibuffer-or-filter' and 'ibuffer-filter-disable' have the alternative
+bindings '/<up>', '/S-<up>', '/|' and '/DEL', respectively.
+
+*** The data format specifying filters has been extended to allow
+explicit logical 'and', and a more flexible form for logical 'not'.
+See 'ibuffer-filtering-qualifiers' doc string for full details.
+
+*** A new command 'ibuffer-copy-buffername-as-kill'; bound
+to 'B'.
+
+*** New command 'ibuffer-change-marks'; bound to '* c'.
+
+*** A new command 'ibuffer-mark-by-locked' to mark
+all locked buffers; bound to '% L'.
+
+*** A new option 'ibuffer-locked-char' to indicate
+locked buffers; Ibuffer shows a new column displaying
+'ibuffer-locked-char' for locked buffers.
+
+*** A new command 'ibuffer-unmark-all-marks' to unmark
+all buffers without asking confirmation; bound to
+'U'; 'ibuffer-do-replace-regexp' bound to 'r'.
+
+*** A new command 'ibuffer-mark-by-content-regexp' to mark buffers
+whose content matches a regexp; bound to '% g'.
+
+*** Two new options 'ibuffer-never-search-content-name' and
+'ibuffer-never-search-content-mode' used by
+'ibuffer-mark-by-content-regexp'.
+
+** Browse-URL
+
+*** Support for opening links to man pages in Man or WoMan mode.
+
+** Comint
+
+*** New user option 'comint-move-point-for-matching-input' to control
+where to place point after 'C-c M-r' and 'C-c M-s'.
+
+*** New user option 'comint-terminfo-terminal'.
+This option allows control of the value of the TERM environment
+variable Emacs puts into the environment of the Comint mode and its
+derivatives, such as Shell mode and Compilation Shell minor-mode. The
+default is "dumb", for compatibility with previous behavior.
+
+** Compilation mode
+
+*** Messages from CMake are now recognized.
+
+*** The number of errors, warnings, and informational messages is now
+displayed in the mode line. These are updated as compilation
+proceeds.
+
+** Grep
+
+*** Grep commands will now use GNU grep's '--null' option if
+available, which allows distinguishing the filename from contents if
+they contain colons. This can be controlled by the new custom option
+'grep-use-null-filename-separator'.
+
+*** The grep/rgrep/lgrep functions will now ask about saving files
+before running. This is controlled by the 'grep-save-buffers'
+variable.
+
+** Edebug
+
+*** Edebug can be prevented from pausing 1 second after reaching a
+breakpoint (e.g. with "f" and "o") by customizing the new option
+'edebug-sit-on-break'.
+
+*** New customizable option 'edebug-max-depth'.
+This allows you to enlarge the maximum recursion depth when
+instrumenting code.
+
+*** 'edebug-prin1-to-string' now aliases 'cl-prin1-to-string'.
+This means edebug output is affected by variables 'cl-print-readably'
+and 'cl-print-compiled'. To completely restore the previous printing
+behavior, use
+
+ (fset 'edebug-prin1-to-string #'prin1-to-string)
+
+** Eshell
+
+*** 'eshell-input-filter's value is now a named function
+'eshell-input-filter-default', and has a new custom option
+'eshell-input-filter-initial-space' to ignore adding commands prefixed
+with blank space to eshell history.
+
+** EUDC
+
+*** Backward compatibility support for BBDB versions less than 3
+(i.e., BBDB 2.x) is deprecated and will likely be removed in the next
+major release of Emacs. Users of BBDB 2.x should plan to upgrade to
+BBDB 3.x.
+
+** eww
+
+*** New 'M-RET' command for opening a link at point in a new eww buffer.
+
+*** A new 's' command for switching to another eww buffer via the minibuffer.
+
+*** The 'o' command ('shr-save-contents') has moved to 'O' to avoid collision
+with the 'o' command from 'image-map'.
+
+*** A new command 'C' ('eww-toggle-colors') can be used to toggle
+whether to use the HTML-specified colors or not. The user can also
+customize the 'shr-use-colors' variable.
+
+*** Images that are being loaded are now marked with gray
+"placeholder" images of the size specified by the HTML. They are then
+replaced by the real images asynchronously, which will also now
+respect width/height HTML specs (unless they specify widths/heights
+bigger than the current window).
+
+*** The 'w' command on links is now 'shr-maybe-probe-and-copy-url'.
+'shr-copy-url' now only copies the url at point; users who wish to
+avoid accidentally accessing remote links may rebind 'w' and 'u' in
+'eww-link-keymap' to it.
+
+** Ido
+
+*** The commands 'find-alternate-file-other-window',
+'dired-other-window', 'dired-other-frame', and
+'display-buffer-other-window' are now remapped to Ido equivalents if
+Ido mode is active.
+
+** Images
+
+*** Images are automatically scaled before displaying based on the
+'image-scaling-factor' variable (if Emacs supports scaling the images
+in question).
+
+*** It's now possible to specify aspect-ratio preserving combinations
+of :width/:max-height and :height/:max-width keywords. In either
+case, the "max" keywords win. (Previously some combinations would,
+depending on the aspect ratio of the image, just be ignored and in
+other instances this would lead to the aspect ratio not being
+preserved.)
+
+*** Images inserted with 'insert-image' and related functions get a
+keymap put into the text properties (or overlays) that span the
+image. This keymap binds keystrokes for manipulating size and
+rotation, as well as saving the image to a file. These commands are
+also available in 'image-mode'.
+
+*** A new library for creating and manipulating SVG images has been
+added. See the "(elisp) SVG Images" section in the ELisp reference
+manual for details.
+
+*** New setf-able function to access and set image parameters is
+provided: 'image-property'.
+
+*** New commands 'image-scroll-left' and 'image-scroll-right'
+for 'image-mode' that complement 'image-scroll-up' and
+'image-scroll-down': they have the same prefix arg behavior and stop
+at image boundaries.
+
+** Image-Dired
+
+*** Now provides a minor mode 'image-dired-minor-mode' which replaces
+the function 'image-dired-setup-dired-keybindings'.
+
+*** Thumbnail generation is now asynchronous.
+The number of concurrent processes is limited by the variable
+'image-dired-queue-active-limit'.
+
+*** 'image-dired-thumbnail-storage' has a new option 'standard-large'
+for generating 256x256 thumbnails according to the Thumbnail Managing
+Standard.
+
+*** Inherits movement keys from 'image-mode' for viewing full images.
+This includes the usual char, line, and page movement commands.
+
+*** All the -options types have been changed to argument lists
+instead of shell command strings. This change affects
+'image-dired-cmd-create-thumbnail-options',
+'image-dired-cmd-create-temp-image-options',
+'image-dired-cmd-rotate-thumbnail-options',
+'image-dired-cmd-rotate-original-options',
+'image-dired-cmd-write-exif-data-options',
+'image-dired-cmd-read-exif-data-options', and introduces
+'image-dired-cmd-pngnq-options', 'image-dired-cmd-pngcrush-options',
+'image-dired-cmd-create-standard-thumbnail-options'.
+
+*** Recognizes more tools by default, including pngnq-s9 and OptiPNG.
+
+*** 'find-file' and related commands now work on thumbnails and
+displayed images, providing a default argument of the original file name
+via an addition to 'file-name-at-point-functions'.
+
+** The default 'Info-default-directory-list' no longer checks some obsolete
+directory suffixes (gnu, gnu/lib, gnu/lib/emacs, emacs, lib, lib/emacs)
+when searching for info directories.
+
+** The commands that add ChangeLog entries now prefer a VCS root directory
+for the ChangeLog file, if none already exists. Customize
+'change-log-directory-files' to nil for the old behavior.
+
+** Support for non-string values of 'time-stamp-format' has been removed.
+
+** Message
+
+*** 'message-use-idna' now defaults to t (because Emacs comes with
+built-in IDNA support now).
+
+*** When sending HTML messages with embedded images, and you have
+exiftool installed, and you rotate images with EXIF data (i.e.,
+JPEGs), the rotational information will be inserted into the outgoing
+image in the message. (The original image will not have its
+orientation affected.)
+
+*** The 'message-valid-fqdn-regexp' variable has been removed, since
+there are now top-level domains added all the time. Message will no
+longer warn about sending emails to top-level domains it hasn't heard
+about.
+
+*** 'message-beginning-of-line' (bound to 'C-a') understands folded headers.
+In 'visual-line-mode' it will look for the true beginning of a header
+while in non-'visual-line-mode' it will move the point to the indented
+header's value.
+
+** Package
+
+*** The new variable 'package-gnupghome-dir' has been added to control
+where the GnuPG home directory (used for signature verification) is
+located and whether GnuPG's option '--homedir' is used or not.
+
+*** Deleting a package no longer respects 'delete-by-moving-to-trash'.
+
+** Python
+
+*** The new variable 'python-indent-def-block-scale' has been added.
+It controls the depth of indentation of arguments inside multi-line
+function signatures.
+
+** Tramp
+
+*** The method part of remote file names is mandatory now.
+A valid remote file name starts with "/method:host:" or
+"/method:user@host:".
+
+*** The new pseudo method "-" is a marker for the default method.
+"/-::" is the shortest remote file name then.
+
+*** The command 'tramp-change-syntax' allows you to choose an
+alternative remote file name syntax.
+
+*** New connection method "sg", which supports editing files under a
+different group ID.
+
+*** New connection method "doas" for OpenBSD hosts.
+
+*** New connection method "gdrive", which allows access to Google
+Drive onsite repositories.
+
+*** Gateway methods in Tramp have been removed.
+Instead, the Tramp manual documents how to configure ssh and PuTTY
+accordingly.
+
+*** Setting the "ENV" environment variable in
+'tramp-remote-process-environment' enables reading of shell
+initialization files.
+
+*** Tramp is able now to send SIGINT to remote asynchronous processes.
+
+*** Variable 'tramp-completion-mode' is obsoleted.
+
+** 'auto-revert-use-notify' is set back to t in 'global-auto-revert-mode'.
+
+** JS mode
+
+*** JS mode now sets 'comment-multi-line' to t.
+
+*** New variable 'js-indent-align-list-continuation', when set to nil,
+will not align continuations of bracketed lists, but will indent them
+by the fixed width 'js-indent-level'.
+
+** CSS mode
+
+*** Support for completing attribute values, at-rules, bang-rules,
+HTML tags, classes and IDs using the 'completion-at-point' command.
+Completion candidates for HTML classes and IDs are retrieved from open
+HTML mode buffers.
+
+*** CSS mode now binds 'C-h S' to a function that will show
+information about a CSS construct (an at-rule, property, pseudo-class,
+pseudo-element, with the default being guessed from context). By
+default the information is looked up on the Mozilla Developer Network,
+but this can be customized using 'css-lookup-url-format'.
+
+*** CSS colors are fontified using the color they represent as the
+background. For instance, #ff0000 would be fontified with a red
+background.
+
+** Emacs now supports character name escape sequences in character and
+string literals. The syntax variants '\N{character name}' and
+'\N{U+code}' are supported.
+
+** Prog mode has some support for multi-mode indentation.
+This allows better indentation support in modes that support multiple
+programming languages in the same buffer, like literate programming
+environments or ANTLR programs with embedded Python code.
+
+A major mode can provide indentation context for a sub-mode. To
+support this, modes should use 'prog-first-column' instead of a
+literal zero and avoid calling 'widen' in their indentation functions.
+See the node "(elisp) Mode-Specific Indent" in the ELisp manual for
+more details.
+
+** ERC
+
+*** New variable 'erc-default-port-tls' used to connect to TLS IRC
+servers.
+
+** URL
+
+*** The new function 'url-cookie-delete-cookie' can be used to
+programmatically delete all cookies, or cookies from a specific
+domain.
+
+*** 'url-retrieve-synchronously' now takes an optional timeout parameter.
+
+*** The URL package now supports HTTPS over proxies supporting CONNECT.
+
+*** 'url-user-agent' now defaults to 'default', and the User-Agent
+string is computed dynamically based on 'url-privacy-level'.
+
+** VC and related modes
+
+*** 'vc-dir-mode' now binds 'vc-log-outgoing' to 'O'; and has various
+branch-related commands on a keymap bound to 'B'.
+
+*** 'vc-region-history' is now bound to 'C-x v h', replacing the older
+'vc-insert-headers' binding.
+
+*** New user option 'vc-git-print-log-follow' to follow renames in Git logs
+for a single file.
+
+** CC mode
+
+*** Opening a .h file will turn C or C++ mode depending on language used.
+This is done with the help of the 'c-or-c++-mode' function, which
+analyzes buffer contents to infer whether it's a C or C++ source file.
+
+** New option 'cpp-message-min-time-interval' to allow user control
+of progress messages in cpp.el.
+
+** New DNS mode command 'dns-mode-ipv6-to-nibbles' to convert IPv6 addresses
+to a format suitable for reverse lookup zone files.
+
+** Ispell
+
+*** Enchant is now supported as a spell-checker.
+Enchant is a meta-spell-checker that uses providers such as Hunspell
+to do the actual checking. With it, users can use spell-checkers not
+directly supported by Emacs, such as Voikko, Hspell and AppleSpell,
+more easily share personal word-lists with other programs, and
+configure different spelling-checkers for different languages.
+(Version 2.1.0 or later of Enchant is required.)
+
+** Flymake
+
+*** Flymake has been completely redesigned.
+Flymake now annotates arbitrary buffer regions, not just lines. It
+supports arbitrary diagnostic types, not just errors and warnings (see
+variable 'flymake-diagnostic-types-alist').
+
+It also supports multiple simultaneous backends, meaning that you can
+check your buffer from different perspectives (see variable
+'flymake-diagnostic-functions'). Backends for Emacs Lisp mode are
+provided.
+
+The old Flymake behavior is preserved in the so-called "legacy
+backend", which has been updated to benefit from the new UI features.
+
+** Term
+
+*** 'term-char-mode' now makes its buffer read-only.
+The buffer is made read-only to prevent changes from being made by
+anything other than the process filter; and movements of point away
+from the process mark are counter-acted so that the cursor is in the
+correct position after each command. This is needed to avoid states
+which are inconsistent with the state of the terminal understood by
+the inferior process.
+
+New user options 'term-char-mode-buffer-read-only' and
+'term-char-mode-point-at-process-mark' control these behaviors, and
+are non-nil by default. Customize these options to nil if you want
+the previous behavior.
+
+** Xref
+
+*** When an *xref* buffer is needed, 'TAB' quits and jumps to an xref.
+A new command 'xref-quit-and-goto-xref', bound to 'TAB' in *xref*
+buffers, quits the window before jumping to the destination. In many
+situations, the intended window configuration is restored, just as if
+the *xref* buffer hadn't been necessary in the first place.
+
+
+* New Modes and Packages in Emacs 26.1
+
+** New Elisp data-structure library 'radix-tree'.
+
+** New library 'xdg' with utilities for some XDG standards and specs.
+
+** HTML
+
+*** A new submode of 'html-mode', 'mhtml-mode', is now the default
+mode for *.html files. This mode handles indentation,
+fontification, and commenting for embedded JavaScript and CSS.
+
+** New mode 'conf-toml-mode' is a sub-mode of 'conf-mode', specialized
+for editing TOML files.
+
+** New mode 'conf-desktop-mode' is a sub-mode of 'conf-unix-mode',
+specialized for editing freedesktop.org desktop entries.
+
+** New minor mode 'pixel-scroll-mode' provides smooth pixel-level scrolling.
+
+** New major mode 'less-css-mode' (a minor variant of 'css-mode') for
+editing Less files.
+
+** New package 'auth-source-pass' integrates 'auth-source' with the
+password manager password-store (http://passwordstore.org).
+
+
+* Incompatible Lisp Changes in Emacs 26.1
+
+** 'password-data' is now a hash-table so that 'password-read' can use
+any object for the 'key' argument.
+
+** Command 'dired-mark-extension' now automatically prepends a '.' to the
+extension when not present. The new command 'dired-mark-suffix' behaves
+similarly but it doesn't prepend a '.'.
+
+** Certain cond/pcase/cl-case forms are now compiled using a faster jump
+table implementation. This uses a new bytecode op 'switch', which
+isn't compatible with previous Emacs versions. This functionality can
+be disabled by setting 'byte-compile-cond-use-jump-table' to nil.
+
+** If 'comment-auto-fill-only-comments' is non-nil, 'auto-fill-function'
+is now called only if either no comment syntax is defined for the
+current buffer or the self-insertion takes place within a comment.
+
+** The alist 'ucs-names' is now a hash table.
+
+** 'if-let' and 'when-let' now support binding lists as defined by the
+SRFI-2 (Scheme Request for Implementation 2).
+
+** 'C-up', 'C-down', 'C-left' and 'C-right' are now defined in term
+mode to send the same escape sequences that xterm does. This makes
+things like 'forward-word' in readline work.
+
+** Customizable variable 'query-replace-from-to-separator'
+now doesn't propertize the string value of the separator.
+Instead, text properties are added by 'query-replace-read-from'.
+Additionally, the new nil value restores pre-24.5 behavior
+of not providing replacement pairs via the history.
+
+** Some obsolete functions, variables, and faces have been removed:
+
+*** 'make-variable-frame-local'. Variables cannot be frame-local any more.
+
+*** From subr.el: 'window-dot', 'set-window-dot', 'read-input',
+'show-buffer', 'eval-current-buffer', 'string-to-int'.
+
+*** 'icomplete-prospects-length'.
+
+*** All the default-FOO variables that hold the default value of the
+FOO variable. Use 'default-value' and 'setq-default' to access and
+change FOO, respectively. The exhaustive list of removed variables is:
+'default-mode-line-format', 'default-header-line-format',
+'default-line-spacing', 'default-abbrev-mode', 'default-ctl-arrow',
+'default-truncate-lines', 'default-left-margin', 'default-tab-width',
+'default-case-fold-search', 'default-left-margin-width',
+'default-right-margin-width', 'default-left-fringe-width',
+'default-right-fringe-width', 'default-fringes-outside-margins',
+'default-scroll-bar-width', 'default-vertical-scroll-bar',
+'default-indicate-empty-lines', 'default-indicate-buffer-boundaries',
+'default-fringe-indicator-alist', 'default-fringe-cursor-alist',
+'default-scroll-up-aggressively', 'default-scroll-down-aggressively',
+'default-fill-column', 'default-cursor-type',
+'default-cursor-in-non-selected-windows',
+'default-buffer-file-coding-system', 'default-major-mode', and
+'default-enable-multibyte-characters'.
+
+*** Many variables obsoleted in 22.1 referring to face symbols.
+
+** The variable 'text-quoting-style' is now a customizable option.
+It controls whether to and how to translate ASCII quotes in messages
+and help output. Its possible values and their semantics remain
+unchanged from Emacs 25. In particular, when this variable's value is
+'grave', all quotes in formats are output as-is.
+
+** Functions like 'check-declare-file' and 'check-declare-directory'
+now generate less chatter and more-compact diagnostics. The auxiliary
+function 'check-declare-errmsg' has been removed.
+
+** The regular expression character class '[:blank:]' now matches
+Unicode horizontal whitespace as defined in the Unicode Technical
+Standard #18. If you only want to match space and tab, use '[ \t]'
+instead.
+
+** 'min' and 'max' no longer round their results.
+Formerly, they returned a floating-point value if any argument was
+floating-point, which was sometimes numerically incorrect. For
+example, on a 64-bit host (max 1e16 10000000000000001) now returns its
+second argument instead of its first.
+
+** The variable 'old-style-backquotes' has been made internal and
+renamed to 'lread--old-style-backquotes'. No user code should use
+this variable.
+
+** 'default-file-name-coding-system' now defaults to a coding system
+that does not process CRLF. For example, it defaults to 'utf-8-unix'
+instead of to 'utf-8'. Before this change, Emacs would sometimes
+mishandle file names containing these control characters.
+
+** 'file-attributes', 'file-symlink-p' and 'make-symbolic-link' no
+longer quietly mutate the target of a local symbolic link, so that
+Emacs can access and copy them reliably regardless of their contents.
+The following changes are involved.
+
+*** 'file-attributes' and 'file-symlink-p' no longer prepend "/:" to
+symbolic links whose targets begin with "/" and contain ":". For
+example, if a symbolic link "x" has a target "/y:z:", '(file-symlink-p
+"x")' now returns "/y:z:" rather than "/:/y:z:".
+
+*** 'make-symbolic-link' no longer looks for file name handlers of
+target when creating a symbolic link. For example,
+'(make-symbolic-link "/y:z:" "x")' now creates a symbolic link to
+"/y:z:" instead of failing.
+
+*** 'make-symbolic-link' removes the remote part of a link target if
+target and newname have the same remote part. For example,
+'(make-symbolic-link "/x:y:a" "/x:y:b")' creates a link with the
+literal string "a"; and '(make-symbolic-link "/x:y:a" "/x:z:b")'
+creates a link with the literal string "/x:y:a" instead of failing.
+
+*** 'make-symbolic-link' now expands a link target with leading "~"
+only when the optional third arg is an integer, as when invoked
+interactively. For example, '(make-symbolic-link "~y" "x")' now
+creates a link with target the literal string "~y"; to get the old
+behavior, use '(make-symbolic-link (expand-file-name "~y") "x")'. To
+avoid this expansion in interactive use, you can now prefix the link
+target with "/:". For example, '(make-symbolic-link "/:~y" "x" 1)'
+now creates a link to literal "~y".
+
+** 'file-truename' returns a quoted file name if the target of a
+symbolic link has remote file name syntax.
+
+** Module functions are now implemented slightly differently; in
+particular, the function 'internal--module-call' has been removed.
+Code that depends on undocumented internals of the module system might
+break.
+
+** The argument LOCKNAME of 'write-region' is propagated to file name
+handlers now.
+
+** When built against recent versions of GTK+, Emacs always uses
+gtk_window_move for moving frames and ignores the value of the
+variable 'x-gtk-use-window-move'. The variable is now obsolete.
+
+** Several functions that create or rename files now treat their
+destination argument specially only when it is a directory name, i.e.,
+when it ends in '/' on GNU and other POSIX-like systems. When the
+destination argument D of one of these functions is an existing
+directory and the intent is to act on an entry in that directory, D
+should now be a directory name. For example, (rename-file "e" "f/")
+renames to 'f/e'. Although this formerly happened sometimes even when
+D was not a directory name, as in (rename-file "e" "f") where 'f'
+happened to be a directory, the old behavior often contradicted the
+documentation and had inherent races that led to security holes. A
+call like (rename-file C D) that used the old, undocumented behavior
+can be written as (rename-file C (file-name-as-directory D)), a
+formulation portable to both older and newer versions of Emacs.
+Affected functions include 'add-name-to-file', 'copy-directory',
+'copy-file', 'format-write-file', 'gnus-copy-file',
+'make-symbolic-link', 'rename-file', 'thumbs-rename-images', and
+'write-file'.
+
+** The list returned by 'overlays-at' is now in decreasing priority order.
+The documentation of this function always said the order should be
+that of decreasing priority, if the 2nd argument of the function is
+non-nil, but the code returned the list in the increasing order of
+priority instead. Now the code does what the documentation says it
+should do.
+
+** 'format' now avoids allocating a new string in more cases.
+'format' was previously documented to return a newly-allocated string,
+but this documentation was not correct, as (eq x (format x)) returned
+t when x was the empty string. 'format' is no longer documented to
+return a newly-allocated string, and the implementation now takes
+advantage of the doc change to avoid making copies of strings in
+common cases like (format "foo") and (format "%s" "foo").
+
+** The function 'eldoc-message' now accepts a single argument.
+Programs that called it with multiple arguments before should pass
+them through 'format' first. Even that is discouraged: for ElDoc
+support, you should set 'eldoc-documentation-function' instead of
+calling 'eldoc-message' directly.
+
+** Using '&rest' or '&optional' incorrectly is now an error.
+For example giving '&optional' without a following variable, or
+passing '&optional' multiple times:
+
+ (defun foo (&optional &rest x))
+ (defun bar (&optional &optional x))
+
+Previously, Emacs would just ignore the extra keyword, or give
+incorrect results in certain cases.
+
+** The pinentry.el library has been removed.
+That package (and the corresponding change in GnuPG and pinentry)
+was intended to provide a way to input passphrase through Emacs with
+GnuPG 2.0. However, the change to support that was only implemented
+in GnuPG >= 2.1 and didn't get backported to GnuPG 2.0. And with
+GnuPG 2.1 and later, pinentry.el is not needed at all. So the
+library was useless, and we removed it. GnuPG 2.0 is no longer
+supported by the upstream project.
+
+To adapt to the change, you may need to set 'epa-pinentry-mode' to the
+symbol 'loopback'. Alternatively, leave 'epa-pinentry-mode' at its
+default value of nil, and remove the 'allow-emacs-pinentry' setting
+from your 'gpg-agent.conf' configuration file, usually found in the
+'~/.gnupg' directory.
+
+Note that previously, it was said that passphrase input through
+minibuffer would be much less secure than other graphical pinentry
+programs. However, these days the difference is insignificant: the
+'read-password' function sufficiently protects input from leakage to
+message logs. Emacs still doesn't use secure memory to protect
+passphrases, but it was also removed from other pinentry programs as
+the attack is unrealistic on modern computer systems which don't
+utilize swap memory usually.
+
+** The function 'display-buffer-in-major-side-window' no longer exists.
+It has been renamed as internal function 'window--make-major-side-window',
+however applications should instead call 'display-buffer-in-side-window'
+(passing the SIDE and SLOT parameters as elements of ALIST). This approach
+is backwards-compatible with versions of Emacs in which the old function
+exists. See the node "Displaying Buffers in Side Windows" in the ELisp
+manual for more details.
+
+* Lisp Changes in Emacs 26.1
+
+** The function 'assoc' now takes an optional third argument TESTFN.
+This argument, when non-nil, is used for comparison instead of
+'equal'.
+
+** New optional argument TESTFN in 'alist-get', 'map-elt' and 'map-put'.
+If non-nil, the argument specifies a function to use for comparison,
+instead of, respectively, 'assq' and 'eql'.
+
+** New function 'seq-set-equal-p' to check if SEQUENCE1 and SEQUENCE2
+contain the same elements, regardless of the order.
+
+** The new function 'mapbacktrace' applies a function to all frames of
+the current stack trace.
+
+** The new function 'file-name-case-insensitive-p' tests whether a
+given file is on a case-insensitive filesystem.
+
+** Several accessors for the value returned by 'file-attributes'
+have been added. They are: 'file-attribute-type',
+'file-attribute-link-number', 'file-attribute-user-id',
+'file-attribute-group-id', 'file-attribute-access-time',
+'file-attribute-modification-time',
+'file-attribute-status-change-time', 'file-attribute-size',
+'file-attribute-modes', 'file-attribute-inode-number',
+'file-attribute-device-number' and 'file-attribute-collect'.
+
+** The new function 'buffer-hash' computes a fast, non-consing hash of
+a buffer's contents.
+
+** 'interrupt-process' now consults the list 'interrupt-process-functions',
+to determine which function has to be called in order to deliver the
+SIGINT signal. This allows Tramp to send the SIGINT signal to remote
+asynchronous processes. The hitherto existing implementation has been
+moved to 'internal-default-interrupt-process'.
+
+** The new function 'read-multiple-choice' prompts for multiple-choice
+questions, with a handy way to display help texts.
+
+** 'comment-indent-function' values may now return a cons to specify a
+range of indentation.
+
+** New optional argument TEXT in 'make-temp-file'.
+
+** New function 'define-symbol-prop'.
+
+** New function 'secure-hash-algorithms' to list the algorithms that
+'secure-hash' supports.
+See the node "(elisp) Checksum/Hash" in the ELisp manual for details.
+
+** Emacs now exposes the GnuTLS cryptographic API with the functions
+'gnutls-macs' and 'gnutls-hash-mac'; 'gnutls-digests' and
+'gnutls-hash-digest'; 'gnutls-ciphers' and 'gnutls-symmetric-encrypt'
+and 'gnutls-symmetric-decrypt'.
+See the node "(elisp) GnuTLS Cryptography" in the ELisp manual for details.
+
+** The function 'gnutls-available-p' now returns a list of capabilities
+supported by the GnuTLS library used by Emacs.
+
+** Emacs now supports records for user-defined types, via the new
+functions 'make-record', 'record', and 'recordp'. Records are now
+used internally to represent cl-defstruct and defclass instances, for
+example.
+
+If your program defines new record types, you should use
+package-naming conventions for naming those types. This is so any
+potential conflicts with other types are avoided.
+
+** 'save-some-buffers' now uses 'save-some-buffers-default-predicate'
+to decide which buffers to ask about, if the PRED argument is nil.
+The default value of 'save-some-buffers-default-predicate' is nil,
+which means ask about all file-visiting buffers.
+
+** string-(to|as|make)-(uni|multi)byte are now declared obsolete.
+
+** New variable 'while-no-input-ignore-events' which allow
+setting which special events 'while-no-input' should ignore.
+It is a list of symbols.
+
+** New function 'undo-amalgamate-change-group' to get rid of
+undo-boundaries between two states.
+
+** New var 'definition-prefixes' is a hash table mapping prefixes to
+the files where corresponding definitions can be found. This can be
+used to fetch definitions that are not yet loaded, for example for
+'C-h f'.
+
+** New var 'syntax-ppss-table' to control the syntax-table used in
+'syntax-ppss'.
+
+** 'define-derived-mode' can now specify an :after-hook form, which
+gets evaluated after the new mode's hook has run. This can be used to
+incorporate configuration changes made in the mode hook into the
+mode's setup.
+
+** Autoload files are now generated without timestamps.
+Set 'autoload-timestamps' to a non-nil value to get timestamps in
+autoload files.
+
+** 'gnutls-boot' now takes a parameter ':complete-negotiation' that
+says that negotiation should complete even on non-blocking sockets.
+
+** There is now a new variable 'flyspell-sort-corrections-function'
+that allows changing the way corrections are sorted.
+
+** The new command 'fortune-message' has been added, which displays
+fortunes in the echo area.
+
+** New function 'func-arity' returns information about the argument list
+of an arbitrary function. This generalizes 'subr-arity' for functions
+that are not built-in primitives. We recommend using this new
+function instead of 'subr-arity'.
+
+** New function 'region-bounds' can be used in the interactive spec
+to provide region boundaries (for rectangular regions more than one)
+to an interactively callable function as a single argument instead of
+two separate arguments 'region-beginning' and 'region-end'.
+
+** 'parse-partial-sexp' state has a new element.
+Element 10 is non-nil when the last character scanned might be the
+first character of a two character construct, i.e., a comment
+delimiter or escaped character. Its value is the syntax of that last
+character.
+
+** 'parse-partial-sexp's state, element 9, has now been confirmed as
+permanent and documented, and may be used by Lisp programs. Its value
+is a list of currently open parenthesis positions, starting with the
+outermost parenthesis.
+
+** 'read-color' will now display the color names using the color itself
+as the background color.
+
+** The function 'redirect-debugging-output' now works on platforms
+other than GNU/Linux.
+
+** The new function 'string-version-lessp' compares strings by
+interpreting consecutive runs of numerical characters as numbers, and
+compares their numerical values. According to this predicate,
+"foo2.png" is smaller than "foo12.png".
+
+** Numeric comparisons and 'logb' no longer return incorrect answers
+due to internal rounding errors. For example, '(< most-positive-fixnum
+(+ 1.0 most-positive-fixnum))' now correctly returns t on 64-bit hosts.
+
+** The functions 'ffloor', 'fceiling', 'ftruncate' and 'fround' now
+accept only floating-point arguments, as per their documentation.
+Formerly, they quietly accepted integer arguments and sometimes
+returned nonsensical answers, e.g., '(< N (ffloor N))' could return t.
+
+** On hosts like GNU/Linux x86-64 where a 'long double' fraction
+contains at least EMACS_INT_WIDTH - 3 bits, 'format' no longer returns
+incorrect answers due to internal rounding errors when formatting
+Emacs integers with '%e', '%f', or '%g' conversions. For example, on
+these hosts '(eql N (string-to-number (format "%.0f" N)))' now returns
+t for all Emacs integers N.
+
+** Calls that accept floating-point integers (for use on hosts with
+limited integer range) now signal an error if arguments are not
+integral. For example '(decode-char 'ascii 0.5)' now signals an
+error.
+
+** Functions 'string-trim-left', 'string-trim-right' and 'string-trim'
+now accept optional arguments which specify the regexp of a substring
+to trim.
+
+** The new function 'char-from-name' converts a Unicode name string
+to the corresponding character code.
+
+** New functions 'sxhash-eq' and 'sxhash-eql' return hash codes of a
+Lisp object suitable for use with 'eq' and 'eql' correspondingly. If
+two objects are 'eq' ('eql'), then the result of 'sxhash-eq'
+('sxhash-eql') on them will be the same.
+
+** Function 'sxhash' has been renamed to 'sxhash-equal' for
+consistency with the new functions. For compatibility, 'sxhash'
+remains as an alias to 'sxhash-equal'.
+
+** 'make-hash-table' now defaults to a rehash threshold of 0.8125
+instead of 0.8, to avoid rounding glitches.
+
+** New function 'add-variable-watcher' can be used to call a function
+when a symbol's value is changed. This is used to implement the new
+debugger command 'debug-on-variable-change'.
+
+** New variable 'print-escape-control-characters' causes 'prin1' and
+'print' to output control characters as backslash sequences.
+
+** Time conversion functions that accept a time zone rule argument now
+allow it to be OFFSET or a list (OFFSET ABBR), where the integer
+OFFSET is a count of seconds east of Universal Time, and the string
+ABBR is a time zone abbreviation. The affected functions are
+'current-time-string', 'current-time-zone', 'decode-time',
+'format-time-string', and 'set-time-zone-rule'.
+
+** 'format-time-string' now formats '%q' to the calendar quarter.
+
+** New built-in function 'mapcan'.
+It avoids unnecessary consing (and garbage collection).
+
+** 'car' and 'cdr' compositions 'cXXXr' and 'cXXXXr' are now part of Elisp.
+
+** 'gensym' is now part of Elisp.
+
+** Low-level list functions like 'length' and 'member' now do a better
+job of signaling list cycles instead of looping indefinitely.
+
+** The new functions 'make-nearby-temp-file' and 'temporary-file-directory'
+can be used for creation of temporary files on remote or mounted directories.
+
+** On GNU platforms when operating on a local file, 'file-attributes'
+no longer suffers from a race when called while another process is
+altering the filesystem. On non-GNU platforms 'file-attributes'
+attempts to detect the race, and returns nil if it does so.
+
+** The new function 'file-local-name' can be used to specify arguments
+of remote processes.
+
+** The new functions 'file-name-quote', 'file-name-unquote' and
+'file-name-quoted-p' can be used to quote / unquote file names with
+the prefix "/:".
+
+** The new error 'file-missing', a subcategory of 'file-error', is now
+signaled instead of 'file-error' if a file operation acts on a file
+that does not exist.
+
+** The function 'delete-directory' no longer signals an error when
+operating recursively and when some other process deletes the directory
+or its files before 'delete-directory' gets to them.
+
+** New error type 'user-search-failed' like 'search-failed' but
+avoids debugger like 'user-error'.
+
+** The function 'line-number-at-pos' now takes a second optional
+argument 'absolute'. If this parameter is nil, the default, this
+function keeps on returning the line number taking potential narrowing
+into account. If this parameter is non-nil, the function ignores
+narrowing and returns the absolute line number.
+
+** The function 'color-distance' now takes a second optional argument
+'metric'. When non-nil, it should be a function of two arguments that
+accepts two colors and returns a number.
+
+** Changes in Frame and Window Handling
+
+*** Resizing a frame no longer runs 'window-configuration-change-hook'.
+'window-size-change-functions' should be used instead.
+
+*** The new function 'frame-size-changed-p' can tell whether a frame has
+been resized since the last time 'window-size-change-functions' has been
+run.
+
+*** The function 'frame-geometry' now also returns the width of a
+frame's outer border.
+
+*** New frame parameters and changed semantics for older ones:
+
+**** 'z-group' positions a frame above or below all others.
+
+**** 'min-width' and 'min-height' specify the absolute minimum size of a
+frame.
+
+**** 'parent-frame' makes a frame the child frame of another Emacs
+frame. The section "(elisp) Child Frames" in the ELisp manual
+describes the intrinsics of that relationship.
+
+**** 'delete-before' triggers deletion of one frame before that of
+another.
+
+**** 'mouse-wheel-frame' specifies another frame whose windows shall be
+scrolled instead.
+
+**** 'no-other-frame' has 'next-frame' and 'previous-frame' skip this
+frame.
+
+**** 'skip-taskbar' removes a frame's icon from the taskbar and has
+'Alt-<TAB>' skip this frame.
+
+**** 'no-focus-on-map' avoids that a frame gets input focus when mapped.
+
+**** 'no-accept-focus' means that a frame does not want to get input
+focus via the mouse.
+
+**** 'undecorated' removes the window manager decorations from a frame.
+
+**** 'override-redirect' tells the window manager to disregard this
+frame.
+
+**** 'width' and 'height' now allow the specification of pixel values
+and ratios.
+
+**** 'left' and 'top' now allow the specification of ratios.
+
+**** 'keep-ratio' preserves size and position of child frames when their
+parent frame is resized.
+
+**** 'no-special-glyphs' suppresses display of truncation and
+continuation glyphs in a frame.
+
+**** 'auto-hide-function' and 'minibuffer-exit' handle auto hiding of
+frames and exiting from minibuffer individually.
+
+**** 'fit-frame-to-buffer-margins' and 'fit-frame-to-buffer-sizes'
+handle fitting a frame to its buffer individually.
+
+**** 'drag-internal-border', 'drag-with-header-line',
+'drag-with-mode-line', 'snap-width', 'top-visible' and 'bottom-visible'
+allow dragging and resizing frames with the mouse.
+
+**** 'minibuffer' is now set to the default minibuffer window when
+initially specified as nil and is not reset to nil when initially
+specifying a minibuffer window.
+
+*** The new function 'frame-list-z-order' returns a list of all frames
+in Z (stacking) order.
+
+*** The function 'x-focus-frame' optionally tries to not activate its
+frame.
+
+*** The variable 'focus-follows-mouse' has a third meaningful value
+'auto-raise' to indicate that the window manager automatically raises a
+frame when the mouse pointer enters it.
+
+*** The new function 'frame-restack' puts a frame above or below
+another on the display.
+
+*** The new face 'internal-border' specifies the background of a frame's
+internal border.
+
+*** The NORECORD argument of 'select-window' now has a meaningful value
+'mark-for-redisplay' which is like any other non-nil value but marks
+WINDOW for redisplay.
+
+*** Support for side windows is now official. The display action
+function 'display-buffer-in-side-window' will display its buffer in a
+side window. Functions for toggling all side windows on a frame,
+changing and reversing the layout of side windows and returning the
+main (major non-side) window of a frame are provided. For details
+consult the section "(elisp) Side Windows" in the ELisp manual.
+
+*** Support for atomic windows - rectangular compositions of windows
+treated by 'split-window', 'delete-window' and 'delete-other-windows'
+like a single live window - is now official. For details consult the
+section "(elisp) Atomic Windows" in the ELisp manual.
+
+*** New 'display-buffer' alist entry 'window-parameters' allows the
+assignment of window parameters to the window used for displaying the
+buffer.
+
+*** New function 'display-buffer-reuse-mode-window' is an action function
+suitable for use in 'display-buffer-alist'. For example, to avoid
+creating a new window when opening man pages when there's already one,
+use
+
+(add-to-list 'display-buffer-alist
+ '("\\`\\*Man .*\\*\\'" .
+ (display-buffer-reuse-mode-window
+ (inhibit-same-window . nil)
+ (mode . Man-mode))))
+
+*** New window parameter 'no-delete-other-windows' prevents that
+its window gets deleted by 'delete-other-windows'.
+
+*** New window parameters 'mode-line-format' and 'header-line-format'
+allow the buffer-local formats for this window to be overridden.
+
+*** New command 'window-swap-states' swaps the states of two live
+windows.
+
+*** New functions 'window-pixel-width-before-size-change' and
+'window-pixel-height-before-size-change' support detecting which
+window changed size when 'window-size-change-functions' are run.
+
+*** The new function 'window-lines-pixel-dimensions' returns the pixel
+dimensions of a window's text lines.
+
+*** The new function 'window-largest-empty-rectangle' returns the
+dimensions of the largest rectangular area not occupying any text in a
+window's body.
+
+*** The semantics of 'mouse-autoselect-window' has changed slightly.
+For details see the section "(elisp) Mouse Window Auto-selection" in
+the ELisp manual.
+
+*** 'select-frame-by-name' now may return a frame on another display
+if it does not find a suitable one on the current display.
+
+** 'tcl-auto-fill-mode' is now declared obsolete.
+Its functionality can be replicated simply by setting
+'comment-auto-fill-only-comments'.
+
+** New pcase pattern 'rx' to match against an rx-style regular expression.
+For details, see the doc string of 'rx--pcase-macroexpander'.
+
+** New functions to set region from secondary selection and vice versa.
+The new functions 'secondary-selection-to-region' and
+'secondary-selection-from-region' let you set the beginning and the
+end of the region from those of the secondary selection and vice
+versa.
+
+** New function 'lgstring-remove-glyph' can be used to modify a
+gstring returned by the underlying layout engine (e.g. m17n-flt,
+uniscribe).
+
+
+* Changes in Emacs 26.1 on Non-Free Operating Systems
+
+** Intercepting hotkeys on Windows 7 and later now works better.
+The new keyboard hooking code properly grabs system hotkeys such as
+'Win-*' and 'Alt-TAB', in a way that Emacs can get at them before the
+system. This makes the 'w32-register-hot-key' functionality work
+again on all versions of MS-Windows starting with Windows 7. On
+Windows NT and later you can now register any hotkey combination. (On
+Windows 9X, the previous limitations, spelled out in the Emacs manual,
+still apply.)
+
+** 'convert-standard-filename' no longer mirrors slashes on MS-Windows.
+Previously, on MS-Windows this function converted slash characters in
+file names into backslashes. It no longer does that. If your Lisp
+program used 'convert-standard-filename' to prepare file names to be
+passed to subprocesses (which is not the recommended usage of that
+function), you will now have to mirror slashes in your application
+code. One possible way is this:
+
+ (let ((start 0))
+ (while (string-match "/" file-name start)
+ (aset file-name (match-beginning 0) ?\\)
+ (setq start (match-end 0))))
+
+** GUI sessions on MS-Windows now treat SIGINT like Posix platforms do.
+The effect of delivering a Ctrl-C (SIGINT) signal to a GUI Emacs on
+MS-Windows is now the same as on Posix platforms -- Emacs saves the
+session and exits. In particular, this will happen if you start
+emacs.exe from the Windows shell, then type Ctrl-C into that shell's
+window.
+
+** 'signal-process' supports SIGTRAP on Windows XP and later.
+The 'kill' emulation on Windows now maps SIGTRAP to a call to the
+'DebugBreakProcess' API. This causes the receiving process to break
+execution and return control to the debugger. If no debugger is
+attached to the receiving process, the call is typically ignored.
+This is in contrast to the default action on POSIX Systems, where it
+causes the receiving process to terminate with a core dump if no
+debugger has been attached to it.
+
+** 'set-mouse-position' and 'set-mouse-absolute-pixel-position' work
+on macOS.
+
+** Emacs can now be run as a GUI application from the command line on
+macOS.
+
+** 'ns-appearance' and 'ns-transparent-titlebar' change the appearance
+of frame decorations on macOS 10.9+.
+
+** 'ns-use-thin-smoothing' enables thin font smoothing on macOS 10.8+.
+
+** 'process-attributes' on Darwin systems now returns more information.
+
+** Mousewheel and trackpad scrolling on macOS 10.7+ now behaves more
+like the macOS default. The new variables 'ns-mwheel-line-height',
+'ns-use-mwheel-acceleration' and 'ns-use-mwheel-momentum' can be used
+to customize the behavior.
+
+
+----------------------------------------------------------------------
+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 <https://www.gnu.org/licenses/>.
+
+
+Local variables:
+coding: utf-8
+mode: outline
+paragraph-separate: "[ ]*$"
+end:
diff --git a/etc/ORDERS b/etc/ORDERS
deleted file mode 100644
index 1df755de9f5..00000000000
--- a/etc/ORDERS
+++ /dev/null
@@ -1,8 +0,0 @@
-Printed copies of Emacs manuals
-
-Note added January 2014:
-
-This file is obsolete and will be removed in future.
-Please update any links to use
- info node `(emacs)Printed Books'
-instead.
diff --git a/etc/PROBLEMS b/etc/PROBLEMS
index b3f1d70858a..785e6e18afa 100644
--- a/etc/PROBLEMS
+++ b/etc/PROBLEMS
@@ -207,7 +207,7 @@ configuring your compiler to use the native linker instead of GNU ld.
** When Emacs is compiled with Gtk+, closing a display kills Emacs.
There is a long-standing bug in GTK that prevents it from recovering
-from disconnects: https://gitlab.gnome.org/GNOME/gtk/issues/221.
+from disconnects: https://gitlab.gnome.org/GNOME/gtk/issues/221
Thus, for instance, when Emacs is run as a server on a text terminal,
and an X frame is created, and the X server for that frame crashes or
@@ -575,17 +575,6 @@ And then rename the system's readline so that it won't be loaded:
See <https://pypi.python.org/pypi/gnureadline> for more details on
installation.
-*** Emacs startup on GNU/Linux systems (and possibly other systems) is slow.
-
-This can happen if the system is misconfigured and Emacs can't get the
-full qualified domain name, FQDN. You should have your FQDN in the
-/etc/hosts file, something like this:
-
-127.0.0.1 localhost
-129.187.137.82 nuc04.t30.physik.tu-muenchen.de nuc04
-
-The way to set this up may vary on non-GNU systems.
-
*** Visiting files in some auto-mounted directories causes Emacs to print
'Error reading dir-locals: (file-error "Read error" "is a directory" ...'
@@ -613,7 +602,7 @@ and then choose /usr/bin/netkit-ftp.
*** Dired is very slow.
-This could happen if invocation of the 'df' program takes a long
+This could happen if getting a file system's status takes a long
time. Possible reasons for this include:
- ClearCase mounted filesystems (VOBs) that sometimes make 'df'
@@ -621,12 +610,8 @@ time. Possible reasons for this include:
- slow automounters on some old versions of Unix;
- - slow operation of some versions of 'df'.
-
-To work around the problem, you could either (a) set the variable
-'directory-free-space-program' to nil, and thus prevent Emacs from
-invoking 'df'; (b) use 'df' from the GNU Coreutils package; or
-(c) use CVS, which is Free Software, instead of ClearCase.
+To work around the problem, you could use Git or some other
+free-software program, instead of ClearCase.
*** ps-print commands fail to find prologue files ps-prin*.ps.
@@ -807,10 +792,8 @@ frame's parameter list, like this:
** Underlines appear at the wrong position.
This is caused by fonts having a wrong UNDERLINE_POSITION property.
-Examples are the 7x13 font on XFree86 prior to version 4.1, or the jmk
-neep font from the Debian xfonts-jmk package prior to version 3.0.17.
-To circumvent this problem, set x-use-underline-position-properties
-to nil in your '.emacs'.
+To avoid this problem (seen in some very old X releases and font packages),
+set x-use-underline-position-properties to nil.
To see what is the value of UNDERLINE_POSITION defined by the font,
type 'xlsfonts -lll FONT' and look at the font's UNDERLINE_POSITION property.
diff --git a/etc/THE-GNU-PROJECT b/etc/THE-GNU-PROJECT
deleted file mode 100644
index d2aa15565e0..00000000000
--- a/etc/THE-GNU-PROJECT
+++ /dev/null
@@ -1,8 +0,0 @@
-The GNU Project
-
-Note added March 2014:
-
-This file is obsolete and will be removed in future.
-Please update any references to use
-
-<https://www.gnu.org/gnu/thegnuproject.html>
diff --git a/etc/WHY-FREE b/etc/WHY-FREE
deleted file mode 100644
index cd2c2fcf8d8..00000000000
--- a/etc/WHY-FREE
+++ /dev/null
@@ -1,8 +0,0 @@
-Why Software Should Not Have Owners
-
-Note added March 2014:
-
-This file is obsolete and will be removed in future.
-Please update any references to use
-
-<https://www.gnu.org/philosophy/why-free.html>
diff --git a/etc/emacs-buffer.gdb b/etc/emacs-buffer.gdb
index e5916b3784f..efbf75dc0d6 100644
--- a/etc/emacs-buffer.gdb
+++ b/etc/emacs-buffer.gdb
@@ -81,7 +81,7 @@ set $yfile_buffers_only = 0
define ygetptr
set $ptr = $arg0
- set $ptr = (CHECK_LISP_OBJECT_TYPE ? $ptr.i : $ptr) & VALMASK
+ set $ptr = (EMACS_INT) (CHECK_LISP_OBJECT_TYPE ? $ptr.i : $ptr) & VALMASK
end
# Get the value of Qnil for comparison. Needed when
@@ -103,12 +103,12 @@ define ybuffer-list
ygetptr $alist
set $alist = $ptr
while $alist != $qnil
- set $this = ((struct Lisp_Cons *) $ptr)->car
- set $alist = ((struct Lisp_Cons *) $ptr)->u.cdr
+ set $this = ((struct Lisp_Cons *) $ptr)->u.s.car
+ set $alist = ((struct Lisp_Cons *) $ptr)->u.s.u.cdr
# Vbuffer_alist elts are pairs of the form (name . buffer)
ygetptr $this
- set $buf = ((struct Lisp_Cons *) $ptr)->u.cdr
+ set $buf = ((struct Lisp_Cons *) $ptr)->u.s.u.cdr
ygetptr $buf
set $buf = (struct buffer *) $ptr
@@ -116,17 +116,17 @@ define ybuffer-list
set $fname = $ptr
if ! ($files_only && $fname == $qnil)
ygetptr $buf->name_
- set $name = ((struct Lisp_String *) $ptr)->data
+ set $name = ((struct Lisp_String *) $ptr)->u.s.data
set $modp = ($buf->text->modiff > $buf->text->save_modiff) ? '*' : ' '
ygetptr $buf->mode_name_
- set $mode = ((struct Lisp_String *) $ptr)->data
+ set $mode = ((struct Lisp_String *) $ptr)->u.s.data
if $fname != $qnil
ygetptr $buf->filename_
printf "%2d %c %9d %-20s %-10s %s\n", \
$i, $modp, ($buf->text->z_byte - 1), $name, $mode, \
- ((struct Lisp_String *) $fname)->data
+ ((struct Lisp_String *) $fname)->u.s.data
else
printf "%2d %c %9d %-20s %-10s\n", \
$i, $modp, ($buf->text->z_byte - 1), $name, $mode
@@ -161,18 +161,18 @@ define yset-buffer
ygetptr $alist
set $alist = $ptr
while ($alist != $qnil && $i > 0)
- set $alist = ((struct Lisp_Cons *) $ptr)->u.cdr
+ set $alist = ((struct Lisp_Cons *) $ptr)->u.s.u.cdr
ygetptr $alist
set $alist = $ptr
set $i--
end
# Get car of alist; this is a pair (name . buffer)
- set $this = ((struct Lisp_Cons *) $alist)->car
+ set $this = ((struct Lisp_Cons *) $alist)->u.s.car
# Get the buffer object
ygetptr $this
- set $this = ((struct Lisp_Cons *) $ptr)->u.cdr
+ set $this = ((struct Lisp_Cons *) $ptr)->u.s.u.cdr
ygetptr $this
set $ycurrent_buffer = (struct buffer *) $ptr
@@ -206,7 +206,7 @@ end
define yget-current-buffer-name
set $this = $ycurrent_buffer->name_
ygetptr $this
- set $ycurrent_buffer_name = ((struct Lisp_String *) $ptr)->data
+ set $ycurrent_buffer_name = ((struct Lisp_String *) $ptr)->u.s.data
end
document yget-current-buffer-name
Set $ycurrent_buffer_name to the name of the currently selected buffer.
diff --git a/etc/emacs.service b/etc/emacs.service
index b29177b120c..dbcb6bc301e 100644
--- a/etc/emacs.service
+++ b/etc/emacs.service
@@ -7,7 +7,7 @@ Description=Emacs text editor
Documentation=info:emacs man:emacs(1) https://gnu.org/software/emacs/
[Service]
-Type=simple
+Type=notify
ExecStart=emacs --fg-daemon
ExecStop=emacsclient --eval "(kill-emacs)"
Environment=SSH_AUTH_SOCK=%t/keyring/ssh
diff --git a/etc/enriched.txt b/etc/enriched.txt
index 0a9c4be9fc7..839dd2f8af9 100644
--- a/etc/enriched.txt
+++ b/etc/enriched.txt
@@ -64,7 +64,11 @@ the right margin, fully justified, centered, or left alone).</indent>
<bold>Excerpts:</bold><indent> <excerpt>"For quoted material."</excerpt></indent>
-<bold>Read-only</bold> regions.
+<bold>Read-only, Invisible, and Intangible</bold> regions.
+
+<bold>Charset</bold> properties.
+
+<bold>Display</bold> properties.
</indent>
@@ -158,6 +162,16 @@ parts of other people's email messages and the like. It is just a
face, which is the same as the 'italic' face by default.</indent></excerpt>
+<x-bg-color><param>blue</param><x-color><param>white</param><bold>CHARSET</bold></x-color></x-bg-color>
+
+
+<indent>You can add character set information to stretches of text; this
+is important for selecting the font that will display that text.
+Users of various charsets, especially in East Asian cultures,
+prefer the same characters to be rendered differently depending on
+the language/charset context.</indent>
+
+
<x-bg-color><param>blue</param><x-color><param>white</param><bold>THE FILE FORMAT</bold></x-color></x-bg-color>
@@ -192,9 +206,9 @@ requires you to name your annotation starting<italic> "x-" </italic>(as in
<italic>"x-read-only"</italic>). Please report any such additions that you
think might be of general interest using <fixed>M-x report-emacs-bug</fixed>.</indent>
-</indent>
+</indent><bold>
-<x-bg-color><param>blue</param><x-color><param>white</param><bold>TODO LIST</bold></x-color></x-bg-color>
+<x-bg-color><param>blue</param><x-color><param>white</param>TODO LIST</x-color></x-bg-color></bold>
<italic><indent>[Feel free to work on these and send us the results!]</indent></italic><indent>
@@ -235,7 +249,7 @@ it.</indent>
<x-bg-color><param>blue</param><x-color><param>white</param><bold>Original Author:</bold></x-color></x-bg-color>
-<bold><x-color><param>white</param><x-bg-color><param>blue</param>Boris Goldowsky</x-bg-color></x-color><x-color><param>light blue</param> </x-color></bold><x-color><param>light blue</param><fixed><<boris@gnu.ai.mit.edu></fixed></x-color><x-color><param>blue</param>
+<bold><x-color><param>white</param><x-bg-color><param>blue</param>Boris Goldowsky</x-bg-color></x-color><x-color><param>light blue</param> </x-color></bold><x-color><param>light blue</param><fixed><<boris@gnu.ai.mit.edu></fixed></x-color>
diff --git a/etc/images/icons/hicolor/scalable/apps/emacs.ico b/etc/images/icons/hicolor/scalable/apps/emacs.ico
new file mode 100644
index 00000000000..70591275217
--- /dev/null
+++ b/etc/images/icons/hicolor/scalable/apps/emacs.ico
Binary files differ
diff --git a/etc/images/splash.bmp b/etc/images/splash.bmp
new file mode 100644
index 00000000000..3ec4c276d53
--- /dev/null
+++ b/etc/images/splash.bmp
Binary files differ
diff --git a/etc/refcards/Makefile b/etc/refcards/Makefile
index f6b7c2e7f9f..469e8fa05cd 100644
--- a/etc/refcards/Makefile
+++ b/etc/refcards/Makefile
@@ -311,7 +311,7 @@ viperCard.dvi: $(vipercard_deps)
.PHONY: clean
clean:
- -rm -f *.dvi *.log *.aux
+ -rm -f ./*.dvi ./*.log ./*.aux
distclean: clean
diff --git a/etc/refcards/cs-survival.tex b/etc/refcards/cs-survival.tex
index 8ac2c03d0ce..b91c9c927ca 100644
--- a/etc/refcards/cs-survival.tex
+++ b/etc/refcards/cs-survival.tex
@@ -289,7 +289,7 @@ zaznamenaných v tabulce značek.
\key{C-x m} nová zpráva
\key{C-c C-c} pošli zprávu a přepni do jiného bufferu
-\key{C-c C-f C-c} přesuň se na hlavičku `CC' a pokud neexistuje, tak ji
+\key{C-c C-f C-c} přesuň se na hlavičku `Cc' a pokud neexistuje, tak ji
vytvoř
\section{Různé}
diff --git a/etc/refcards/fr-survival.tex b/etc/refcards/fr-survival.tex
index 5cbb48810ac..20755497ff2 100644
--- a/etc/refcards/fr-survival.tex
+++ b/etc/refcards/fr-survival.tex
@@ -287,7 +287,7 @@ dans la fen\^etre de compilation, ou
\key{C-x m} d\'ebute la composition d'un message
\key{C-c C-c} envoie le message et bascule dans un autre tampon
-\key{C-c C-f C-c} va \`a l'ent\^ete `CC', en cr\'ee un s'il n'existe pas
+\key{C-c C-f C-c} va \`a l'ent\^ete `Cc', en cr\'ee un s'il n'existe pas
\section{Divers}
diff --git a/etc/refcards/ru-refcard.tex b/etc/refcards/ru-refcard.tex
index d44a104f6ba..43c18d58e29 100644
--- a/etc/refcards/ru-refcard.tex
+++ b/etc/refcards/ru-refcard.tex
@@ -40,7 +40,7 @@
\newlength{\ColThreeWidth}
\setlength{\ColThreeWidth}{25mm}
-\newcommand{\versionemacs}[0]{26} % version of Emacs this is for
+\newcommand{\versionemacs}[0]{27} % version of Emacs this is for
\newcommand{\cyear}[0]{2019} % copyright year
\newcommand\shortcopyrightnotice[0]{\vskip 1ex plus 2 fill
diff --git a/etc/refcards/sk-survival.tex b/etc/refcards/sk-survival.tex
index 1968b456b59..b63a618b060 100644
--- a/etc/refcards/sk-survival.tex
+++ b/etc/refcards/sk-survival.tex
@@ -292,7 +292,7 @@ zaznamenaných v tabuľke značiek.
\key{C-x m} nová správa
\key{C-c C-c} pošli správu a prepni sa do iného bufferu
-\key{C-c C-f C-c} presuň sa na hlavičku `CC', a ak neexistuje, tak ju
+\key{C-c C-f C-c} presuň sa na hlavičku `Cc', a ak neexistuje, tak ju
vytvor
\section{Rôzne}
diff --git a/etc/refcards/survival.tex b/etc/refcards/survival.tex
index 727383c694b..5dbe788ee62 100644
--- a/etc/refcards/survival.tex
+++ b/etc/refcards/survival.tex
@@ -278,7 +278,7 @@ else convenient. To create a tags table file, type
\key{C-x m} begin composing a message
\key{C-c C-c} send the message and switch to another buffer
-\key{C-c C-f C-c} move to the `CC' header field, creating one
+\key{C-c C-f C-c} move to the `Cc' header field, creating one
if there is none
\section{Miscellaneous}
diff --git a/etc/themes/adwaita-theme.el b/etc/themes/adwaita-theme.el
index 800e6cf817c..73ef7b6e9ee 100644
--- a/etc/themes/adwaita-theme.el
+++ b/etc/themes/adwaita-theme.el
@@ -99,8 +99,4 @@ default look of the Gnome 3 desktop.")
`(diff-added ((,class (:bold t :foreground "#4E9A06"))))
`(diff-removed ((,class (:bold t :foreground "#F5666D"))))))
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
-
;;; adwaita-theme.el ends here
diff --git a/etc/themes/deeper-blue-theme.el b/etc/themes/deeper-blue-theme.el
index 2bf5ef16a3d..d04a270ba5e 100644
--- a/etc/themes/deeper-blue-theme.el
+++ b/etc/themes/deeper-blue-theme.el
@@ -110,8 +110,4 @@
(provide-theme 'deeper-blue)
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
-
;;; deeper-blue-theme.el ends here
diff --git a/etc/themes/dichromacy-theme.el b/etc/themes/dichromacy-theme.el
index 69e56f9a65d..b361fe5c509 100644
--- a/etc/themes/dichromacy-theme.el
+++ b/etc/themes/dichromacy-theme.el
@@ -122,8 +122,4 @@ Ansi-Color faces are included.")
(provide-theme 'dichromacy)
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
-
;;; dichromacy-theme.el ends here
diff --git a/etc/themes/leuven-theme.el b/etc/themes/leuven-theme.el
index 485406362ec..d544f28da79 100644
--- a/etc/themes/leuven-theme.el
+++ b/etc/themes/leuven-theme.el
@@ -708,7 +708,6 @@ Semantic, and Ansi-Color faces are included -- and much more...")
;; time-stamp-format: "%:y%02m%02d.%02H%02M"
;; time-stamp-start: "Version: "
;; time-stamp-end: "$"
-;; no-byte-compile: t
;; End:
;;; leuven-theme.el ends here
diff --git a/etc/themes/light-blue-theme.el b/etc/themes/light-blue-theme.el
index e9abfa319ca..3060dcf09c7 100644
--- a/etc/themes/light-blue-theme.el
+++ b/etc/themes/light-blue-theme.el
@@ -61,8 +61,4 @@
(provide-theme 'light-blue)
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
-
;;; light-blue-theme.el ends here
diff --git a/etc/themes/manoj-dark-theme.el b/etc/themes/manoj-dark-theme.el
index 1a24a92e918..b6bf9bff1e1 100644
--- a/etc/themes/manoj-dark-theme.el
+++ b/etc/themes/manoj-dark-theme.el
@@ -700,8 +700,4 @@ jarring angry fruit salad look to reduce eye fatigue.")
(provide-theme 'manoj-dark)
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
-
;;; manoj-dark.el ends here
diff --git a/etc/themes/misterioso-theme.el b/etc/themes/misterioso-theme.el
index a343aa172c4..cac76d681eb 100644
--- a/etc/themes/misterioso-theme.el
+++ b/etc/themes/misterioso-theme.el
@@ -103,8 +103,4 @@
(provide-theme 'misterioso)
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
-
;;; misterioso-theme.el ends here
diff --git a/etc/themes/tango-dark-theme.el b/etc/themes/tango-dark-theme.el
index 5cd796ed168..bd99790f452 100644
--- a/etc/themes/tango-dark-theme.el
+++ b/etc/themes/tango-dark-theme.el
@@ -170,8 +170,4 @@ Semantic, and Ansi-Color faces are included.")
(provide-theme 'tango-dark)
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
-
;;; tango-dark-theme.el ends here
diff --git a/etc/themes/tango-theme.el b/etc/themes/tango-theme.el
index 2d115e245b0..12d4db3fe7c 100644
--- a/etc/themes/tango-theme.el
+++ b/etc/themes/tango-theme.el
@@ -154,8 +154,4 @@ Semantic, and Ansi-Color faces are included.")
(provide-theme 'tango)
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
-
;;; tango-theme.el ends here
diff --git a/etc/themes/tsdh-dark-theme.el b/etc/themes/tsdh-dark-theme.el
index 6229538363f..5482ced6b29 100644
--- a/etc/themes/tsdh-dark-theme.el
+++ b/etc/themes/tsdh-dark-theme.el
@@ -144,8 +144,4 @@
(provide-theme 'tsdh-dark)
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
-
;;; tsdh-dark-theme.el ends here
diff --git a/etc/themes/tsdh-light-theme.el b/etc/themes/tsdh-light-theme.el
index 8617d72aca9..8e6a79f8e36 100644
--- a/etc/themes/tsdh-light-theme.el
+++ b/etc/themes/tsdh-light-theme.el
@@ -106,9 +106,4 @@ Used and created by Tassilo Horn.")
(provide-theme 'tsdh-light)
-
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
-
;;; tsdh-light-theme.el ends here
diff --git a/etc/themes/wheatgrass-theme.el b/etc/themes/wheatgrass-theme.el
index 363a7a06c52..2e18eb9e3a4 100644
--- a/etc/themes/wheatgrass-theme.el
+++ b/etc/themes/wheatgrass-theme.el
@@ -83,8 +83,4 @@ of green, brown, and blue.")
(provide-theme 'wheatgrass)
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
-
;;; wheatgrass-theme.el ends here
diff --git a/etc/themes/whiteboard-theme.el b/etc/themes/whiteboard-theme.el
index 8c259be2e3e..75c6c1c0f6b 100644
--- a/etc/themes/whiteboard-theme.el
+++ b/etc/themes/whiteboard-theme.el
@@ -100,8 +100,4 @@
(provide-theme 'whiteboard)
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
-
;;; whiteboard-theme.el ends here
diff --git a/etc/themes/wombat-theme.el b/etc/themes/wombat-theme.el
index 4b0283fb8cc..c56700ffd9a 100644
--- a/etc/themes/wombat-theme.el
+++ b/etc/themes/wombat-theme.el
@@ -102,8 +102,4 @@ are included.")
(provide-theme 'wombat)
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
-
;;; wombat-theme.el ends here
diff --git a/leim/Makefile.in b/leim/Makefile.in
index c2fc8c41f23..4307d500876 100644
--- a/leim/Makefile.in
+++ b/leim/Makefile.in
@@ -84,7 +84,8 @@ MISC= \
${leimdir}/quail/PY.el \
${leimdir}/quail/ZIRANMA.el \
${leimdir}/quail/CTLau.el \
- ${leimdir}/quail/CTLau-b5.el
+ ${leimdir}/quail/CTLau-b5.el \
+ ${srcdir}/../lisp/language/pinyin.el
## All the generated .el files.
TIT_MISC = ${TIT_GB} ${TIT_BIG5} ${MISC}
@@ -142,6 +143,9 @@ ${leimdir}/ja-dic/ja-dic.el: $(srcdir)/SKK-DIC/SKK-JISYO.L
$(AM_V_GEN)$(RUN_EMACS) -batch -l ja-dic-cnv \
-f batch-skkdic-convert -dir "$(leimdir)/ja-dic" "$<"
+${srcdir}/../lisp/language/pinyin.el: ${srcdir}/MISC-DIC/pinyin.map
+ $(AM_V_GEN)${RUN_EMACS} -l titdic-cnv -f pinyin-convert $< $@
+
.PHONY: bootstrap-clean distclean maintainer-clean extraclean
diff --git a/lib-src/Makefile.in b/lib-src/Makefile.in
index 5b526f1bf51..387a6e33249 100644
--- a/lib-src/Makefile.in
+++ b/lib-src/Makefile.in
@@ -167,7 +167,7 @@ UTILITIES = profile${EXEEXT} hexl${EXEEXT} \
$(if $(with_mailutils), , movemail${EXEEXT}) \
$(and $(use_gamedir), update-game-score${EXEEXT})
-DONT_INSTALL= make-docfile${EXEEXT}
+DONT_INSTALL= make-docfile${EXEEXT} make-fingerprint${EXEEXT}
# Like UTILITIES, but they're not system-dependent, and should not be
# deleted by the distclean target.
@@ -204,8 +204,6 @@ LIBRESOLV=@LIBRESOLV@
LIBS_MAIL=@LIBS_MAIL@
## empty or -lrt or -lposix4 if HAVE_CLOCK_GETTIME
LIB_CLOCK_GETTIME = @LIB_CLOCK_GETTIME@
-## empty or -lrt or -lposix4 if HAVE_FDATASYNC
-LIB_FDATASYNC = @LIB_FDATASYNC@
## empty or -lwsock2 for MinGW
LIB_WSOCK32=@LIB_WSOCK32@
@@ -334,7 +332,7 @@ uninstall:
fi
mostlyclean:
- rm -f core *.o *.res
+ rm -f core ./*.o ./*.res
clean: mostlyclean
rm -f ${EXE_FILES}
@@ -345,7 +343,7 @@ distclean: clean
bootstrap-clean maintainer-clean: distclean
extraclean: maintainer-clean
- rm -f *~ \#*
+ rm -f ./*~ \#*
## Test the contents of the directory.
check:
@@ -361,13 +359,9 @@ TAGS: etags${EXEEXT} ${tagsfiles}
../lib/libgnu.a: $(config_h)
$(MAKE) -C ../lib all
-regex.o: $(srcdir)/../src/regex.c $(srcdir)/../src/regex.h $(config_h)
- $(AM_V_CC)$(CC) -c $(CPP_CFLAGS) $<
-
-
-etags_deps = ${srcdir}/etags.c regex.o $(NTLIB) $(config_h)
+etags_deps = ${srcdir}/etags.c $(NTLIB) $(config_h)
etags_cflags = -DEMACS_NAME="\"GNU Emacs\"" -DVERSION="\"${version}\"" -o $@
-etags_libs = regex.o $(NTLIB) $(LOADLIBES)
+etags_libs = $(NTLIB) $(LOADLIBES)
etags${EXEEXT}: ${etags_deps}
$(AM_V_CCLD)$(CC) ${ALL_CFLAGS} $(etags_cflags) $< $(etags_libs)
@@ -391,6 +385,9 @@ profile${EXEEXT}: ${srcdir}/profile.c $(NTLIB) $(config_h)
make-docfile${EXEEXT}: ${srcdir}/make-docfile.c $(NTLIB) $(config_h)
$(AM_V_CCLD)$(CC) ${ALL_CFLAGS} $< $(NTLIB) $(LOADLIBES) -o $@
+make-fingerprint${EXEEXT}: ${srcdir}/make-fingerprint.c $(NTLIB) $(config_h)
+ $(AM_V_CCLD)$(CC) ${ALL_CFLAGS} $< $(NTLIB) $(LOADLIBES) -o $@
+
movemail${EXEEXT}: ${srcdir}/movemail.c pop.o $(NTLIB) $(config_h)
$(AM_V_CCLD)$(CC) ${ALL_CFLAGS} ${MOVE_FLAGS} $< pop.o \
$(NTLIB) $(LOADLIBES) $(LIBS_MOVE) -o $@
@@ -400,12 +397,12 @@ pop.o: ${srcdir}/pop.c ${srcdir}/pop.h ${srcdir}/../lib/min-max.h $(config_h)
emacsclient${EXEEXT}: ${srcdir}/emacsclient.c $(NTLIB) $(config_h)
$(AM_V_CCLD)$(CC) ${ALL_CFLAGS} $< \
- -DVERSION="\"${version}\"" $(NTLIB) $(LOADLIBES) $(LIB_FDATASYNC) \
+ -DVERSION="\"${version}\"" $(NTLIB) $(LOADLIBES) \
$(LIB_WSOCK32) $(LIBS_ECLIENT) -o $@
emacsclientw${EXEEXT}: ${srcdir}/emacsclient.c $(NTLIB) $(CLIENTRES) $(config_h)
$(AM_V_CCLD)$(CC) ${ALL_CFLAGS} $(CLIENTRES) -mwindows $< \
- -DVERSION="\"${version}\"" $(LOADLIBES) $(LIB_FDATASYNC) \
+ -DVERSION="\"${version}\"" $(LOADLIBES) \
$(LIB_WSOCK32) $(LIBS_ECLIENT) -o $@
NTINC = ${srcdir}/../nt/inc
diff --git a/lib-src/ebrowse.c b/lib-src/ebrowse.c
index a383127758b..938b405f3cf 100644
--- a/lib-src/ebrowse.c
+++ b/lib-src/ebrowse.c
@@ -187,7 +187,8 @@ enum token
STATIC_CAST, /* static_cast */
TYPEID, /* typeid */
USING, /* using */
- WCHAR /* wchar_t */
+ WCHAR, /* wchar_t */
+ FINAL /* final */
};
/* Storage classes, in a wider sense. */
@@ -471,7 +472,7 @@ static struct sym *add_sym (const char *, struct sym *);
static void add_global_defn (char *, char *, int, unsigned, int, int, int);
static void add_global_decl (char *, char *, int, unsigned, int, int, int);
static struct member *add_member (struct sym *, char *, int, int, unsigned);
-static void class_definition (struct sym *, int, int, int);
+static void class_definition (struct sym *, const char *, int, int, int);
static char *operator_name (int *);
static void parse_qualified_param_ident_or_type (char **);
@@ -494,7 +495,7 @@ yyerror (const char *format, const char *s)
/* Like malloc but print an error and exit if not enough memory is
available. */
-static void *
+static void * ATTRIBUTE_MALLOC
xmalloc (size_t nbytes)
{
void *p = malloc (nbytes);
@@ -2035,6 +2036,7 @@ token_string (int t)
case USING: return "using";
case WCHAR: return "wchar_t";
case YYEOF: return "EOF";
+ case FINAL: return "final";
default:
if (t < 255)
@@ -2140,6 +2142,7 @@ init_scanner (void)
insert_keyword ("explicit", EXPLICIT);
insert_keyword ("extern", EXTERN);
insert_keyword ("false", FALSE);
+ insert_keyword ("final", FINAL);
insert_keyword ("float", FLOAT);
insert_keyword ("for", FOR);
insert_keyword ("friend", FRIEND);
@@ -2501,9 +2504,9 @@ member (struct sym *cls, int vis)
char *regexp = NULL;
int pos;
int is_constructor;
- int anonymous = 0;
int flags = 0;
int class_tag;
+ char *class_name;
int type_seen = 0;
int paren_seen = 0;
unsigned hash = 0;
@@ -2626,7 +2629,7 @@ member (struct sym *cls, int vis)
class_tag = LA1;
type_seen = 1;
MATCH ();
- anonymous = 1;
+ class_name = NULL;
/* More than one ident here to allow for MS-DOS specialties
like `_export class' etc. The last IDENT seen counts
@@ -2634,14 +2637,33 @@ member (struct sym *cls, int vis)
while (!LOOKING_AT4 (YYEOF, ';', ':', '{'))
{
if (LOOKING_AT (IDENT))
- anonymous = 0;
- MATCH ();
+ {
+ if (class_name)
+ {
+ int size = strlen (yytext);
+
+ if(strlen (class_name) < size)
+ {
+ class_name = (char *) xrealloc(class_name, size + 1);
+ }
+
+ memcpy(class_name, yytext, size + 1);
+ }
+ else
+ {
+ class_name = xstrdup(yytext);
+ }
+ }
+
+ MATCH ();
}
if (LOOKING_AT2 (':', '{'))
- class_definition (anonymous ? NULL : cls, class_tag, flags, 1);
+ class_definition (class_name ? cls : NULL, class_name ? class_name : yytext, class_tag, flags, 1);
else
skip_to (';');
+
+ free(class_name);
break;
case INT: case CHAR: case LONG: case UNSIGNED:
@@ -2997,7 +3019,7 @@ parse_qualified_param_ident_or_type (char **last_id)
Current lookahead is the class name. */
static void
-class_definition (struct sym *containing, int tag, int flags, int nested)
+class_definition (struct sym *containing, const char *class_name, int tag, int flags, int nested)
{
struct sym *current;
struct sym *base_class;
@@ -3009,7 +3031,7 @@ class_definition (struct sym *containing, int tag, int flags, int nested)
current = NULL;
else
{
- current = add_sym (yytext, containing);
+ current = add_sym (class_name, containing);
current->pos = BUFFER_POS ();
current->regexp = matching_regexp ();
current->filename = filename;
@@ -3292,8 +3314,8 @@ declaration (int flags)
static int
globals (int start_flags)
{
- int anonymous;
int class_tk;
+ char *class_name;
int flags = start_flags;
for (;;)
@@ -3362,7 +3384,7 @@ globals (int start_flags)
case CLASS: case STRUCT: case UNION:
class_tk = LA1;
MATCH ();
- anonymous = 1;
+ class_name = NULL;
/* More than one ident here to allow for MS-DOS and OS/2
specialties like `far', `_Export' etc. Some C++ libs
@@ -3371,19 +3393,37 @@ globals (int start_flags)
while (!LOOKING_AT4 (YYEOF, ';', ':', '{'))
{
if (LOOKING_AT (IDENT))
- anonymous = 0;
+ {
+ if (class_name)
+ {
+ int size = strlen (yytext);
+
+ if(strlen (class_name) < size)
+ {
+ class_name = (char *) xrealloc(class_name, size + 1);
+ }
+
+ memcpy(class_name, yytext, size + 1);
+ }
+ else
+ {
+ class_name = xstrdup(yytext);
+ }
+ }
+
MATCH ();
}
/* Don't add anonymous unions. */
- if (LOOKING_AT2 (':', '{') && !anonymous)
- class_definition (NULL, class_tk, flags, 0);
+ if (LOOKING_AT2 (':', '{') && class_name)
+ class_definition (NULL, class_name, class_tk, flags, 0);
else
{
if (skip_to (';') == ';')
MATCH ();
}
+ free(class_name);
flags = start_flags;
break;
diff --git a/lib-src/emacsclient.c b/lib-src/emacsclient.c
index 702fa40d604..f4768408980 100644
--- a/lib-src/emacsclient.c
+++ b/lib-src/emacsclient.c
@@ -27,146 +27,136 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
# undef _WINSOCK_H
# include <malloc.h>
-# include <stdlib.h>
# include <windows.h>
# include <commctrl.h>
# include <io.h>
# include <winsock2.h>
-# define NO_SOCKETS_IN_FILE_SYSTEM
-
# define HSOCKET SOCKET
# define CLOSE_SOCKET closesocket
-# define INITIALIZE() (initialize_sockets ())
+# define INITIALIZE() initialize_sockets ()
char *w32_getenv (const char *);
-#define egetenv(VAR) w32_getenv(VAR)
+# define egetenv(VAR) w32_getenv (VAR)
+
+# undef signal
#else /* !WINDOWSNT */
# ifdef HAVE_NTGUI
-# include <windows.h>
-# endif /* HAVE_NTGUI */
+# include <windows.h>
+# endif
# include "syswait.h"
-# ifdef HAVE_INET_SOCKETS
-# include <netinet/in.h>
-# ifdef HAVE_SOCKETS
-# include <sys/types.h>
-# include <sys/socket.h>
-# include <sys/un.h>
-# endif /* HAVE_SOCKETS */
-# endif
# include <arpa/inet.h>
+# include <fcntl.h>
+# include <netinet/in.h>
+# include <sys/socket.h>
+# include <sys/un.h>
-# define INVALID_SOCKET -1
+# define SOCKETS_IN_FILE_SYSTEM
+
+# define INVALID_SOCKET (-1)
# define HSOCKET int
# define CLOSE_SOCKET close
# define INITIALIZE()
-#define egetenv(VAR) getenv(VAR)
+# define egetenv(VAR) getenv (VAR)
#endif /* !WINDOWSNT */
-#undef signal
-
-#include <stdarg.h>
#include <ctype.h>
-#include <stdlib.h>
-#include <string.h>
+#include <errno.h>
#include <getopt.h>
-#include <unistd.h>
-
+#include <inttypes.h>
#include <pwd.h>
-#include <sys/stat.h>
#include <signal.h>
-#include <errno.h>
+#include <stdarg.h>
+#include <stddef.h>
+#include <stdlib.h>
+#include <string.h>
+#include <sys/stat.h>
+#include <unistd.h>
+#include <dosname.h>
+#include <intprops.h>
+#include <min-max.h>
#include <unlocked-io.h>
#ifndef VERSION
#define VERSION "unspecified"
#endif
-
-
-#ifndef EXIT_SUCCESS
-#define EXIT_SUCCESS 0
-#endif
-
-#ifndef EXIT_FAILURE
-#define EXIT_FAILURE 1
-#endif
-
-/* Additional space when allocating buffers for filenames, etc. */
-#define EXTRA_SPACE 100
-#ifdef min
-#undef min
+/* Work around GCC bug 88251. */
+#if GNUC_PREREQ (7, 0, 0)
+# pragma GCC diagnostic ignored "-Wformat-truncation=2"
#endif
-#define min(x, y) (((x) < (y)) ? (x) : (y))
/* Name used to invoke this program. */
-const char *progname;
+static char const *progname;
/* The first argument to main. */
-int main_argc;
+static int main_argc;
/* The second argument to main. */
-char **main_argv;
+static char *const *main_argv;
-/* Nonzero means don't wait for a response from Emacs. --no-wait. */
-int nowait = 0;
+/* True means don't wait for a response from Emacs. --no-wait. */
+static bool nowait;
-/* Nonzero means don't print messages for successful operations. --quiet. */
-int quiet = 0;
+/* True means don't print messages for successful operations. --quiet. */
+static bool quiet;
-/* Nonzero means don't print values returned from emacs. --suppress-output. */
-int suppress_output = 0;
+/* True means don't print values returned from emacs. --suppress-output. */
+static bool suppress_output;
-/* Nonzero means args are expressions to be evaluated. --eval. */
-int eval = 0;
+/* True means args are expressions to be evaluated. --eval. */
+static bool eval;
-/* Nonzero means don't open a new frame. Inverse of --create-frame. */
-int current_frame = 1;
+/* True means open a new frame. --create-frame etc. */
+static bool create_frame;
/* The display on which Emacs should work. --display. */
-const char *display = NULL;
+static char const *display;
/* The alternate display we should try if Emacs does not support display. */
-const char *alt_display = NULL;
+static char const *alt_display;
/* The parent window ID, if we are opening a frame via XEmbed. */
-char *parent_id = NULL;
+static char *parent_id;
-/* Nonzero means open a new Emacs frame on the current terminal. */
-int tty = 0;
+/* True means open a new Emacs frame on the current terminal. */
+static bool tty;
/* If non-NULL, the name of an editor to fallback to if the server
is not running. --alternate-editor. */
-const char *alternate_editor = NULL;
+static char *alternate_editor;
+#ifdef SOCKETS_IN_FILE_SYSTEM
/* If non-NULL, the filename of the UNIX socket. */
-const char *socket_name = NULL;
+static char const *socket_name;
+#endif
/* If non-NULL, the filename of the authentication file. */
-const char *server_file = NULL;
+static char const *server_file;
/* If non-NULL, the tramp prefix emacs must use to find the files. */
-const char *tramp_prefix = NULL;
+static char const *tramp_prefix;
-/* PID of the Emacs server process. */
-int emacs_pid = 0;
+/* If nonzero, PID of the Emacs server process. */
+static pid_t emacs_pid;
/* If non-NULL, a string that should form a frame parameter alist to
be used for the new frame. */
-const char *frame_parameters = NULL;
+static char const *frame_parameters;
static _Noreturn void print_help_and_exit (void);
+/* Long command-line options. */
-struct option longopts[] =
+static struct option const longopts[] =
{
{ "no-wait", no_argument, NULL, 'n' },
{ "quiet", no_argument, NULL, 'q' },
@@ -179,7 +169,7 @@ struct option longopts[] =
{ "create-frame", no_argument, NULL, 'c' },
{ "alternate-editor", required_argument, NULL, 'a' },
{ "frame-parameters", required_argument, NULL, 'F' },
-#ifndef NO_SOCKETS_IN_FILE_SYSTEM
+#ifdef SOCKETS_IN_FILE_SYSTEM
{ "socket-name", required_argument, NULL, 's' },
#endif
{ "server-file", required_argument, NULL, 'f' },
@@ -189,10 +179,19 @@ struct option longopts[] =
{ 0, 0, 0, 0 }
};
+/* Short options, in the same order as the corresponding long options.
+ There is no '-p' short option. */
+static char const shortopts[] =
+ "nqueHVtca:F:"
+#ifdef SOCKETS_IN_FILE_SYSTEM
+ "s:"
+#endif
+ "f:d:T:";
+
/* Like malloc but get fatal error if memory is exhausted. */
-static void *
+static void * ATTRIBUTE_MALLOC
xmalloc (size_t size)
{
void *result = malloc (size);
@@ -219,9 +218,8 @@ xrealloc (void *ptr, size_t size)
}
/* Like strdup but get a fatal error if memory is exhausted. */
-char *xstrdup (const char *);
-char *
+static char * ATTRIBUTE_MALLOC
xstrdup (const char *s)
{
char *result = strdup (s);
@@ -234,7 +232,7 @@ xstrdup (const char *s)
}
/* From sysdep.c */
-#if !defined (HAVE_GET_CURRENT_DIR_NAME) || defined (BROKEN_GET_CURRENT_DIR_NAME)
+#if !defined HAVE_GET_CURRENT_DIR_NAME || defined BROKEN_GET_CURRENT_DIR_NAME
char *get_current_dir_name (void);
@@ -245,23 +243,23 @@ char *
get_current_dir_name (void)
{
char *buf;
- const char *pwd;
struct stat dotstat, pwdstat;
/* If PWD is accurate, use it instead of calling getcwd. PWD is
sometimes a nicer name, and using it may avoid a fatal error if a
parent directory is searchable but not readable. */
- if ((pwd = egetenv ("PWD")) != 0
+ char const *pwd = egetenv ("PWD");
+ if (pwd
&& (IS_DIRECTORY_SEP (*pwd) || (*pwd && IS_DEVICE_SEP (pwd[1])))
&& stat (pwd, &pwdstat) == 0
&& stat (".", &dotstat) == 0
&& dotstat.st_ino == pwdstat.st_ino
&& dotstat.st_dev == pwdstat.st_dev
-#ifdef MAXPATHLEN
+# ifdef MAXPATHLEN
&& strlen (pwd) < MAXPATHLEN
-#endif
+# endif
)
{
- buf = (char *) xmalloc (strlen (pwd) + 1);
+ buf = xmalloc (strlen (pwd) + 1);
strcpy (buf, pwd);
}
else
@@ -296,7 +294,7 @@ get_current_dir_name (void)
#ifdef WINDOWSNT
-#define REG_ROOT "SOFTWARE\\GNU\\Emacs"
+# define REG_ROOT "SOFTWARE\\GNU\\Emacs"
char *w32_get_resource (HKEY, const char *, LPDWORD);
@@ -310,14 +308,18 @@ w32_get_resource (HKEY predefined, const char *key, LPDWORD type)
char *result = NULL;
DWORD cbData;
- if (RegOpenKeyEx (predefined, REG_ROOT, 0, KEY_READ, &hrootkey) == ERROR_SUCCESS)
+ if (RegOpenKeyEx (predefined, REG_ROOT, 0, KEY_READ, &hrootkey)
+ == ERROR_SUCCESS)
{
- if (RegQueryValueEx (hrootkey, key, NULL, NULL, NULL, &cbData) == ERROR_SUCCESS)
+ if (RegQueryValueEx (hrootkey, key, NULL, NULL, NULL, &cbData)
+ == ERROR_SUCCESS)
{
- result = (char *) xmalloc (cbData);
+ result = xmalloc (cbData);
- if ((RegQueryValueEx (hrootkey, key, NULL, type, (LPBYTE)result, &cbData) != ERROR_SUCCESS)
- || (*result == 0))
+ if ((RegQueryValueEx (hrootkey, key, NULL, type, (LPBYTE) result,
+ &cbData)
+ != ERROR_SUCCESS)
+ || *result == 0)
{
free (result);
result = NULL;
@@ -369,7 +371,7 @@ w32_getenv (const char *envvar)
if ((size = ExpandEnvironmentStrings (value, NULL, 0)))
{
- char *buffer = (char *) xmalloc (size);
+ char *buffer = xmalloc (size);
if (ExpandEnvironmentStrings (value, buffer, size))
{
/* Found and expanded. */
@@ -436,8 +438,8 @@ w32_execvp (const char *path, char **argv)
return execvp (path, argv);
}
-#undef execvp
-#define execvp w32_execvp
+# undef execvp
+# define execvp w32_execvp
/* Emulation of ttyname for Windows. */
const char *ttyname (int);
@@ -484,7 +486,7 @@ message (bool is_error, const char *format, ...)
}
/* Decode the options from argv and argc.
- The global variable `optind' will say how many arguments we used up. */
+ The global variable 'optind' will say how many arguments we used up. */
static void
decode_options (int argc, char **argv)
@@ -492,17 +494,10 @@ decode_options (int argc, char **argv)
alternate_editor = egetenv ("ALTERNATE_EDITOR");
tramp_prefix = egetenv ("EMACSCLIENT_TRAMP");
- while (1)
+ while (true)
{
- int opt = getopt_long_only (argc, argv,
-#ifndef NO_SOCKETS_IN_FILE_SYSTEM
- "VHnequa:s:f:d:F:tcT:",
-#else
- "VHnequa:f:d:F:tcT:",
-#endif
- longopts, 0);
-
- if (opt == EOF)
+ int opt = getopt_long_only (argc, argv, shortopts, longopts, NULL);
+ if (opt < 0)
break;
switch (opt)
@@ -516,7 +511,7 @@ decode_options (int argc, char **argv)
alternate_editor = optarg;
break;
-#ifndef NO_SOCKETS_IN_FILE_SYSTEM
+#ifdef SOCKETS_IN_FILE_SYSTEM
case 's':
socket_name = optarg;
break;
@@ -535,19 +530,19 @@ decode_options (int argc, char **argv)
break;
case 'n':
- nowait = 1;
+ nowait = true;
break;
case 'e':
- eval = 1;
+ eval = true;
break;
case 'q':
- quiet = 1;
+ quiet = true;
break;
case 'u':
- suppress_output = 1;
+ suppress_output = true;
break;
case 'V':
@@ -556,17 +551,17 @@ decode_options (int argc, char **argv)
break;
case 't':
- tty = 1;
- current_frame = 0;
+ tty = true;
+ create_frame = true;
break;
case 'c':
- current_frame = 0;
+ create_frame = true;
break;
case 'p':
parent_id = optarg;
- current_frame = 0;
+ create_frame = true;
break;
case 'H':
@@ -590,7 +585,7 @@ decode_options (int argc, char **argv)
/* If the -c option is used (without -t) and no --display argument
is provided, try $DISPLAY.
- Without the -c option, we used to set `display' to $DISPLAY by
+ Without the -c option, we used to set 'display' to $DISPLAY by
default, but this changed the default behavior and is sometimes
inconvenient. So we force users to use "--display $DISPLAY" if
they want Emacs to connect to their current display.
@@ -599,7 +594,7 @@ decode_options (int argc, char **argv)
reflected in the DISPLAY variable. If the user didn't give us an
explicit display, try this platform-specific after trying the
display in DISPLAY (if any). */
- if (!current_frame && !tty && !display)
+ if (create_frame && !tty && !display)
{
/* Set these here so we use a default_display only when the user
didn't give us an explicit display. */
@@ -619,24 +614,24 @@ decode_options (int argc, char **argv)
}
/* A null-string display is invalid. */
- if (display && strlen (display) == 0)
+ if (display && !display[0])
display = NULL;
/* If no display is available, new frames are tty frames. */
- if (!current_frame && !display)
- tty = 1;
+ if (create_frame && !display)
+ tty = true;
#ifdef WINDOWSNT
/* Emacs on Windows does not support graphical and text terminal
frames in the same instance. So, treat the -t and -c options as
equivalent, and open a new frame on the server's terminal.
- Ideally, we would only set tty = 1 when the serve is running in a
+ Ideally, we would set tty = true only if the server is running in a
console, but alas we don't know that. As a workaround, always
ask for a tty frame, and let server.el figure it out. */
- if (!current_frame)
+ if (create_frame)
{
display = NULL;
- tty = 1;
+ tty = true;
}
#endif /* WINDOWSNT */
}
@@ -671,7 +666,7 @@ The following OPTIONS are accepted:\n\
Visit the file in the given display\n\
", "\
--parent-id=ID Open in parent window ID, via XEmbed\n"
-#ifndef NO_SOCKETS_IN_FILE_SYSTEM
+#ifdef SOCKETS_IN_FILE_SYSTEM
"-s SOCKET, --socket-name=SOCKET\n\
Set filename of the UNIX socket for communication\n"
#endif
@@ -702,14 +697,15 @@ fail (void)
size_t new_argv_size = extra_args_size;
char **new_argv = xmalloc (new_argv_size);
char *s = xstrdup (alternate_editor);
- unsigned toks = 0;
+ ptrdiff_t toks = 0;
/* Unpack alternate_editor's space-separated tokens into new_argv. */
for (char *tok = s; tok != NULL && *tok != '\0';)
{
/* Allocate new token. */
++toks;
- new_argv = xrealloc (new_argv, new_argv_size + toks * sizeof (char *));
+ new_argv = xrealloc (new_argv,
+ new_argv_size + toks * sizeof (char *));
/* Skip leading delimiters, and set separator, skipping any
opening quote. */
@@ -737,39 +733,26 @@ fail (void)
}
-#if !defined (HAVE_SOCKETS) || !defined (HAVE_INET_SOCKETS)
-
-int
-main (int argc, char **argv)
-{
- main_argc = argc;
- main_argv = argv;
- progname = argv[0];
- message (true, "%s: Sorry, the Emacs server is supported only\n"
- "on systems with Berkeley sockets.\n",
- argv[0]);
- fail ();
-}
-
-#else /* HAVE_SOCKETS && HAVE_INET_SOCKETS */
-
-#define AUTH_KEY_LENGTH 64
-#define SEND_BUFFER_SIZE 4096
-
-/* Buffer to accumulate data to send in TCP connections. */
-char send_buffer[SEND_BUFFER_SIZE + 1];
-int sblen = 0; /* Fill pointer for the send buffer. */
-/* Socket used to communicate with the Emacs server process. */
-HSOCKET emacs_socket = 0;
+#ifdef SOCKETS_IN_FILE_SYSTEM
+static void act_on_signals (HSOCKET);
+#else
+static void act_on_signals (HSOCKET s) {}
+static void init_signals (void) {}
+#endif
-/* On Windows, the socket library was historically separate from the
- standard C library, so errors are handled differently. */
+enum { AUTH_KEY_LENGTH = 64 };
static void
sock_err_message (const char *function_name)
{
#ifdef WINDOWSNT
- char* msg = NULL;
+ /* On Windows, the socket library was historically separate from the
+ standard C library, so errors are handled differently. */
+
+ if (w32_window_app () && alternate_editor)
+ return;
+
+ char *msg = NULL;
FormatMessage (FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_ALLOCATE_BUFFER
@@ -785,39 +768,47 @@ sock_err_message (const char *function_name)
}
-/* Let's send the data to Emacs when either
- - the data ends in "\n", or
+/* Send to S the data in *DATA when either
+ - the data's last byte is '\n', or
- the buffer is full (but this shouldn't happen)
- Otherwise, we just accumulate it. */
+ Otherwise, just accumulate the data. */
static void
send_to_emacs (HSOCKET s, const char *data)
{
- size_t dlen;
+ enum { SEND_BUFFER_SIZE = 4096 };
- if (!data)
- return;
+ /* Buffer to accumulate data to send in TCP connections. */
+ static char send_buffer[SEND_BUFFER_SIZE + 1];
+
+ /* Fill pointer for the send buffer. */
+ static int sblen;
- dlen = strlen (data);
- while (*data)
+ for (ptrdiff_t dlen = strlen (data); dlen != 0; )
{
- size_t part = min (dlen, SEND_BUFFER_SIZE - sblen);
+ int part = min (dlen, SEND_BUFFER_SIZE - sblen);
memcpy (&send_buffer[sblen], data, part);
data += part;
sblen += part;
if (sblen == SEND_BUFFER_SIZE
- || (sblen > 0 && send_buffer[sblen-1] == '\n'))
+ || (0 < sblen && send_buffer[sblen - 1] == '\n'))
{
- int sent = send (s, send_buffer, sblen, 0);
- if (sent < 0)
+ int sent;
+ while ((sent = send (s, send_buffer, sblen, 0)) < 0)
{
- message (true, "%s: failed to send %d bytes to socket: %s\n",
- progname, sblen, strerror (errno));
- fail ();
+ if (errno != EINTR)
+ {
+ message (true, "%s: failed to send %d bytes to socket: %s\n",
+ progname, sblen, strerror (errno));
+ fail ();
+ }
+ /* Act on signals not requiring communication to Emacs,
+ but defer action on the others to avoid confusing the
+ communication currently in progress. */
+ act_on_signals (INVALID_SOCKET);
}
- if (sent != sblen)
- memmove (send_buffer, &send_buffer[sent], sblen - sent);
sblen -= sent;
+ memmove (send_buffer, &send_buffer[sent], sblen);
}
dlen -= part;
@@ -833,34 +824,22 @@ send_to_emacs (HSOCKET s, const char *data)
static void
quote_argument (HSOCKET s, const char *str)
{
- char *copy = (char *) xmalloc (strlen (str) * 2 + 1);
- const char *p;
- char *q;
-
- p = str;
- q = copy;
- while (*p)
+ char *copy = xmalloc (strlen (str) * 2 + 1);
+ char *q = copy;
+ if (*str == '-')
+ *q++ = '&', *q++ = *str++;
+ for (; *str; str++)
{
- if (*p == ' ')
- {
- *q++ = '&';
- *q++ = '_';
- p++;
- }
- else if (*p == '\n')
- {
- *q++ = '&';
- *q++ = 'n';
- p++;
- }
- else
- {
- if (*p == '&' || (*p == '-' && p == str))
- *q++ = '&';
- *q++ = *p++;
- }
+ char c = *str;
+ if (c == ' ')
+ *q++ = '&', c = '_';
+ else if (c == '\n')
+ *q++ = '&', c = 'n';
+ else if (c == '&')
+ *q++ = '&';
+ *q++ = c;
}
- *q++ = 0;
+ *q = 0;
send_to_emacs (s, copy);
@@ -868,65 +847,35 @@ quote_argument (HSOCKET s, const char *str)
}
-/* The inverse of quote_argument. Removes quoting in string STR by
- modifying the string in place. Returns STR. */
+/* The inverse of quote_argument. Remove quoting in string STR by
+ modifying the addressed string in place. Return STR. */
static char *
unquote_argument (char *str)
{
- char *p, *q;
-
- if (! str)
- return str;
+ char const *p = str;
+ char *q = str;
+ char c;
- p = str;
- q = str;
- while (*p)
+ do
{
- if (*p == '&')
- {
- p++;
- if (*p == '&')
- *p = '&';
- else if (*p == '_')
- *p = ' ';
- else if (*p == 'n')
- *p = '\n';
- else if (*p == '-')
- *p = '-';
- }
- *q++ = *p++;
+ c = *p++;
+ if (c == '&')
+ {
+ c = *p++;
+ if (c == '_')
+ c = ' ';
+ else if (c == 'n')
+ c = '\n';
+ }
+ *q++ = c;
}
- *q = 0;
+ while (c);
+
return str;
}
-static int
-file_name_absolute_p (const char *filename)
-{
- /* Sanity check, it shouldn't happen. */
- if (! filename) return false;
-
- /* /xxx is always an absolute path. */
- if (filename[0] == '/') return true;
-
- /* Empty filenames (which shouldn't happen) are relative. */
- if (filename[0] == '\0') return false;
-
-#ifdef WINDOWSNT
- /* X:\xxx is always absolute. */
- if (isalpha ((unsigned char) filename[0])
- && filename[1] == ':' && (filename[2] == '\\' || filename[2] == '/'))
- return true;
-
- /* Both \xxx and \\xxx\yyy are absolute. */
- if (filename[0] == '\\') return true;
-#endif
-
- return false;
-}
-
#ifdef WINDOWSNT
/* Wrapper to make WSACleanup a cdecl, as required by atexit. */
void __cdecl close_winsock (void);
@@ -954,44 +903,45 @@ initialize_sockets (void)
#endif /* WINDOWSNT */
+/* If the home directory is HOME, return the configuration file with
+ basename CONFIG_FILE. Fail if there is no home directory or if the
+ configuration file could not be opened. */
+
+static FILE *
+open_config (char const *home, char const *config_file)
+{
+ if (!home)
+ return NULL;
+ ptrdiff_t homelen = strlen (home);
+ static char const emacs_d_server[] = "/.emacs.d/server/";
+ ptrdiff_t suffixsize = sizeof emacs_d_server + strlen (config_file);
+ char *configname = xmalloc (homelen + suffixsize);
+ strcpy (stpcpy (stpcpy (configname, home), emacs_d_server), config_file);
+
+ FILE *config = fopen (configname, "rb");
+ free (configname);
+ return config;
+}
+
/* Read the information needed to set up a TCP comm channel with
the Emacs server: host, port, and authentication string. */
-static int
+static bool
get_server_config (const char *config_file, struct sockaddr_in *server,
char *authentication)
{
char dotted[32];
char *port;
- FILE *config = NULL;
+ FILE *config;
- if (file_name_absolute_p (config_file))
+ if (IS_ABSOLUTE_FILE_NAME (config_file))
config = fopen (config_file, "rb");
else
{
- const char *home = egetenv ("HOME");
-
- if (home)
- {
- char *path = xmalloc (strlen (home) + strlen (config_file)
- + EXTRA_SPACE);
- char *z = stpcpy (path, home);
- z = stpcpy (z, "/.emacs.d/server/");
- strcpy (z, config_file);
- config = fopen (path, "rb");
- free (path);
- }
+ config = open_config (egetenv ("HOME"), config_file);
#ifdef WINDOWSNT
- if (!config && (home = egetenv ("APPDATA")))
- {
- char *path = xmalloc (strlen (home) + strlen (config_file)
- + EXTRA_SPACE);
- char *z = stpcpy (path, home);
- z = stpcpy (z, "/.emacs.d/server/");
- strcpy (z, config_file);
- config = fopen (path, "rb");
- free (path);
- }
+ if (!config)
+ config = open_config (egetenv ("APPDATA"), config_file);
#endif
}
@@ -1007,6 +957,7 @@ get_server_config (const char *config_file, struct sockaddr_in *server,
exit (EXIT_FAILURE);
}
+ memset (server, 0, sizeof *server);
server->sin_family = AF_INET;
server->sin_addr.s_addr = inet_addr (dotted);
server->sin_port = htons (atoi (port));
@@ -1022,46 +973,64 @@ get_server_config (const char *config_file, struct sockaddr_in *server,
return true;
}
+/* Like socket (DOMAIN, TYPE, PROTOCOL), except arrange for the
+ resulting file descriptor to be close-on-exec. */
+
+static HSOCKET
+cloexec_socket (int domain, int type, int protocol)
+{
+#ifdef SOCK_CLOEXEC
+ return socket (domain, type | SOCK_CLOEXEC, protocol);
+#else
+ HSOCKET s = socket (domain, type, protocol);
+# ifndef WINDOWSNT
+ if (0 <= s)
+ fcntl (s, F_SETFD, FD_CLOEXEC);
+# endif
+ return s;
+#endif
+}
+
static HSOCKET
set_tcp_socket (const char *local_server_file)
{
- HSOCKET s;
- struct sockaddr_in server;
- struct linger l_arg = {1, 1};
+ union {
+ struct sockaddr_in in;
+ struct sockaddr sa;
+ } server;
+ struct linger l_arg = { .l_onoff = 1, .l_linger = 1 };
char auth_string[AUTH_KEY_LENGTH + 1];
- if (! get_server_config (local_server_file, &server, auth_string))
+ if (! get_server_config (local_server_file, &server.in, auth_string))
return INVALID_SOCKET;
- if (server.sin_addr.s_addr != inet_addr ("127.0.0.1") && !quiet)
+ if (server.in.sin_addr.s_addr != inet_addr ("127.0.0.1") && !quiet)
message (false, "%s: connected to remote socket at %s\n",
- progname, inet_ntoa (server.sin_addr));
+ progname, inet_ntoa (server.in.sin_addr));
/* Open up an AF_INET socket. */
- if ((s = socket (AF_INET, SOCK_STREAM, IPPROTO_TCP)) < 0)
+ HSOCKET s = cloexec_socket (AF_INET, SOCK_STREAM, IPPROTO_TCP);
+ if (s < 0)
{
/* Since we have an alternate to try out, this is not an error
yet; popping out a modal dialog at this stage would make -a
option totally useless for emacsclientw -- the user will
still get an error message if the alternate editor fails. */
-#ifdef WINDOWSNT
- if(!(w32_window_app () && alternate_editor))
-#endif
sock_err_message ("socket");
return INVALID_SOCKET;
}
/* Set up the socket. */
- if (connect (s, (struct sockaddr *) &server, sizeof server) < 0)
+ if (connect (s, &server.sa, sizeof server.in) != 0)
{
-#ifdef WINDOWSNT
- if(!(w32_window_app () && alternate_editor))
-#endif
sock_err_message ("connect");
+ CLOSE_SOCKET (s);
return INVALID_SOCKET;
}
- setsockopt (s, SOL_SOCKET, SO_LINGER, (char *) &l_arg, sizeof l_arg);
+ /* The cast to 'const char *' is to avoid a compiler warning when
+ compiling for MS-Windows sockets. */
+ setsockopt (s, SOL_SOCKET, SO_LINGER, (const char *) &l_arg, sizeof l_arg);
/* Send the authentication. */
auth_string[AUTH_KEY_LENGTH] = '\0';
@@ -1074,44 +1043,38 @@ set_tcp_socket (const char *local_server_file)
}
-/* Returns 1 if PREFIX is a prefix of STRING. */
-static int
+/* Return true if PREFIX is a prefix of STRING. */
+static bool
strprefix (const char *prefix, const char *string)
{
return !strncmp (prefix, string, strlen (prefix));
}
-/* Get tty name and type. If successful, return the type in TTY_TYPE
- and the name in TTY_NAME, and return 1. Otherwise, fail if NOABORT
- is zero, or return 0 if NOABORT is non-zero. */
+/* Get tty name and type. If successful, store the type into
+ *TTY_TYPE and the name into *TTY_NAME, and return true.
+ Otherwise, fail if NOABORT is zero, or return false if NOABORT. */
-static int
-find_tty (const char **tty_type, const char **tty_name, int noabort)
+static bool
+find_tty (const char **tty_type, const char **tty_name, bool noabort)
{
const char *type = egetenv ("TERM");
- const char *name = ttyname (fileno (stdout));
+ const char *name = ttyname (STDOUT_FILENO);
if (!name)
{
if (noabort)
- return 0;
- else
- {
- message (true, "%s: could not get terminal name\n", progname);
- fail ();
- }
+ return false;
+ message (true, "%s: could not get terminal name\n", progname);
+ fail ();
}
if (!type)
{
if (noabort)
- return 0;
- else
- {
- message (true, "%s: please set the TERM variable to your terminal type\n",
- progname);
- fail ();
- }
+ return false;
+ message (true, "%s: please set the TERM variable to your terminal type\n",
+ progname);
+ fail ();
}
const char *inside_emacs = egetenv ("INSIDE_EMACS");
@@ -1119,297 +1082,416 @@ find_tty (const char **tty_type, const char **tty_name, int noabort)
&& strprefix ("eterm", type))
{
if (noabort)
- return 0;
- else
- {
- /* This causes nasty, MULTI_KBOARD-related input lockouts. */
- message (true, "%s: opening a frame in an Emacs term buffer"
- " is not supported\n", progname);
- fail ();
- }
+ return false;
+ /* This causes nasty, MULTI_KBOARD-related input lockouts. */
+ message (true, ("%s: opening a frame in an Emacs term buffer"
+ " is not supported\n"),
+ progname);
+ fail ();
}
*tty_name = name;
*tty_type = type;
- return 1;
+ return true;
}
+/* Return the process group if in the foreground, the negative of the
+ process group if in the background, and zero if there is no
+ foreground process group for the controlling terminal.
+ Unfortunately, use of this function introduces an unavoidable race,
+ since whether the process is in the foreground or background can
+ change at any time. */
+
+static pid_t
+process_grouping (void)
+{
+#ifdef SOCKETS_IN_FILE_SYSTEM
+ pid_t tcpgrp = tcgetpgrp (STDOUT_FILENO);
+ if (0 <= tcpgrp)
+ {
+ pid_t pgrp = getpgrp ();
+ return tcpgrp == pgrp ? pgrp : -pgrp;
+ }
+#endif
+ return 0;
+}
-#if !defined (NO_SOCKETS_IN_FILE_SYSTEM)
+#ifdef SOCKETS_IN_FILE_SYSTEM
-/* Three possibilities:
- 2 - can't be `stat'ed (sets errno)
- 1 - isn't owned by us
+/* Return the file status of NAME, ordinarily a socket.
+ It should be owned by UID. Return one of the following:
+ >0 - 'stat' failed with this errno value
+ -1 - isn't owned by us
0 - success: none of the above */
static int
-socket_status (const char *name)
+socket_status (const char *name, uid_t uid)
{
struct stat statbfr;
- if (stat (name, &statbfr) == -1)
- return 2;
+ if (stat (name, &statbfr) != 0)
+ return errno;
- if (statbfr.st_uid != geteuid ())
- return 1;
+ if (statbfr.st_uid != uid)
+ return -1;
return 0;
}
-/* A signal handler that passes the signal to the Emacs process.
- Useful for SIGWINCH. */
-
+/* Signal handlers merely set a flag, to avoid race conditions on
+ POSIXish systems. Non-POSIX platforms lacking sigaction make do
+ with traditional calls to 'signal'; races are rare so this usually
+ works. Although this approach may treat multiple deliveries of SIG
+ as a single delivery and may act on signals in a different order
+ than received, that is OK for emacsclient. Also, this approach may
+ omit output if a printf call is interrupted by a signal, but printf
+ output is not that important (emacsclient does not check for printf
+ errors, after all) so this is also OK for emacsclient. */
+
+/* Reinstall for SIG the signal handler HANDLER if needed. It is
+ needed on a non-POSIX or traditional platform where an interrupt
+ resets the signal handler to SIG_DFL. */
static void
-pass_signal_to_emacs (int signalnum)
+reinstall_handler_if_needed (int sig, void (*handler) (int))
{
- int old_errno = errno;
+# ifndef SA_RESETHAND
+ /* This is a platform without POSIX's sigaction. */
+ signal (sig, handler);
+# endif
+}
+
+/* Flags for each signal, and handlers that set the flags. */
- if (emacs_pid)
- kill (emacs_pid, signalnum);
+static sig_atomic_t volatile
+ got_sigcont, got_sigtstp, got_sigttou, got_sigwinch;
- signal (signalnum, pass_signal_to_emacs);
- errno = old_errno;
+static void
+handle_sigcont (int sig)
+{
+ got_sigcont = 1;
+ reinstall_handler_if_needed (sig, handle_sigcont);
+}
+static void
+handle_sigtstp (int sig)
+{
+ got_sigtstp = 1;
+ reinstall_handler_if_needed (sig, handle_sigtstp);
+}
+static void
+handle_sigttou (int sig)
+{
+ got_sigttou = 1;
+ reinstall_handler_if_needed (sig, handle_sigttou);
+}
+static void
+handle_sigwinch (int sig)
+{
+ got_sigwinch = 1;
+ reinstall_handler_if_needed (sig, handle_sigwinch);
}
-/* Signal handler for SIGCONT; notify the Emacs process that it can
- now resume our tty frame. */
+/* Install for signal SIG the handler HANDLER. However, if FLAG is
+ non-null and if the signal is currently being ignored, do not
+ install the handler and keep *FLAG zero. */
static void
-handle_sigcont (int signalnum)
+install_handler (int sig, void (*handler) (int), sig_atomic_t volatile *flag)
{
- int old_errno = errno;
- pid_t pgrp = getpgrp ();
- pid_t tcpgrp = tcgetpgrp (1);
-
- if (tcpgrp == pgrp)
+# ifdef SA_RESETHAND
+ if (flag)
{
- /* We are in the foreground. */
- send_to_emacs (emacs_socket, "-resume \n");
+ struct sigaction oact;
+ if (sigaction (sig, NULL, &oact) == 0 && oact.sa_handler == SIG_IGN)
+ return;
}
- else if (0 <= tcpgrp && tty)
+ struct sigaction act = { .sa_handler = handler };
+ sigemptyset (&act.sa_mask);
+ sigaction (sig, &act, NULL);
+# else
+ void (*ohandler) (int) = signal (sig, handler);
+ if (flag)
{
- /* We are in the background; cancel the continue. */
- kill (-pgrp, SIGTTIN);
+ if (ohandler == SIG_IGN)
+ {
+ signal (sig, SIG_IGN);
+ /* While HANDLER was mistakenly installed a signal may have
+ arrived and set *FLAG, so clear *FLAG now. */
+ *flag = 0;
+ }
}
-
- signal (signalnum, handle_sigcont);
- errno = old_errno;
+# endif
}
-/* Signal handler for SIGTSTP; notify the Emacs process that we are
- going to sleep. Normally the suspend is initiated by Emacs via
- server-handle-suspend-tty, but if the server gets out of sync with
- reality, we may get a SIGTSTP on C-z. Handling this signal and
- notifying Emacs about it should get things under control again. */
+/* Initial installation of signal handlers. */
static void
-handle_sigtstp (int signalnum)
+init_signals (void)
{
- int old_errno = errno;
- sigset_t set;
-
- if (emacs_socket)
- send_to_emacs (emacs_socket, "-suspend \n");
-
- /* Unblock this signal and call the default handler by temporarily
- changing the handler and resignaling. */
- sigprocmask (SIG_BLOCK, NULL, &set);
- sigdelset (&set, signalnum);
- signal (signalnum, SIG_DFL);
- raise (signalnum);
- sigprocmask (SIG_SETMASK, &set, NULL); /* Let's the above signal through. */
- signal (signalnum, handle_sigtstp);
-
- errno = old_errno;
+ install_handler (SIGCONT, handle_sigcont, &got_sigcont);
+ install_handler (SIGTSTP, handle_sigtstp, &got_sigtstp);
+ install_handler (SIGTTOU, handle_sigttou, &got_sigttou);
+ install_handler (SIGWINCH, handle_sigwinch, &got_sigwinch);
+ /* Don't mess with SIGINT and SIGQUIT, as Emacs has no way to
+ determine which terminal the signal came from. C-g is a normal
+ input event on secondary terminals. */
}
+/* Act on delivered tty-related signal SIG that normally has handler
+ HANDLER. EMACS_SOCKET connects to Emacs. */
-/* Set up signal handlers before opening a frame on the current tty. */
+static void
+act_on_tty_signal (int sig, void (*handler) (int), HSOCKET emacs_socket)
+{
+ /* Notify Emacs that we are going to sleep. Normally the suspend is
+ initiated by Emacs via server-handle-suspend-tty, but if the
+ server gets out of sync with reality, we may get a SIGTSTP on
+ C-z. Handling this signal and notifying Emacs about it should
+ get things under control again. */
+ send_to_emacs (emacs_socket, "-suspend \n");
+
+ /* Execute the default action by temporarily changing handling to
+ the default and resignaling. */
+ install_handler (sig, SIG_DFL, NULL);
+ raise (sig);
+ install_handler (sig, handler, NULL);
+}
+
+/* Act on delivered signals if possible. If EMACS_SOCKET is valid,
+ use it to communicate to Emacs. */
static void
-init_signals (void)
+act_on_signals (HSOCKET emacs_socket)
{
- /* Set up signal handlers. */
- signal (SIGWINCH, pass_signal_to_emacs);
-
- /* Don't pass SIGINT and SIGQUIT to Emacs, because it has no way of
- deciding which terminal the signal came from. C-g is now a
- normal input event on secondary terminals. */
-#if 0
- signal (SIGINT, pass_signal_to_emacs);
- signal (SIGQUIT, pass_signal_to_emacs);
-#endif
+ while (true)
+ {
+ bool took_action = false;
+
+ if (emacs_socket != INVALID_SOCKET)
+ {
+ if (got_sigcont)
+ {
+ got_sigcont = 0;
+ took_action = true;
+ pid_t grouping = process_grouping ();
+ if (grouping < 0)
+ {
+ if (tty)
+ {
+ /* Cancel the continue. */
+ kill (grouping, SIGTTIN);
+ }
+ }
+ else
+ send_to_emacs (emacs_socket, "-resume \n");
+ }
+
+ if (got_sigtstp)
+ {
+ got_sigtstp = 0;
+ took_action = true;
+ act_on_tty_signal (SIGTSTP, handle_sigtstp, emacs_socket);
+ }
+ if (got_sigttou)
+ {
+ got_sigttou = 0;
+ took_action = true;
+ act_on_tty_signal (SIGTTOU, handle_sigttou, emacs_socket);
+ }
+ }
- signal (SIGCONT, handle_sigcont);
- signal (SIGTSTP, handle_sigtstp);
- signal (SIGTTOU, handle_sigtstp);
+ if (emacs_pid && got_sigwinch)
+ {
+ got_sigwinch = 0;
+ took_action = true;
+ kill (emacs_pid, SIGWINCH);
+ }
+
+ if (!took_action)
+ break;
+ }
}
+/* Create in SOCKNAME (of size SOCKNAMESIZE) a name for a local socket.
+ The first TMPDIRLEN bytes of SOCKNAME are already initialized to be
+ the name of a temporary directory. Use UID and SERVER_NAME to
+ concoct the name. Return the total length of the name if successful,
+ -1 if it does not fit (and store a truncated name in that case).
+ Fail if TMPDIRLEN is out of range. */
+
+static int
+local_sockname (char *sockname, int socknamesize, int tmpdirlen,
+ uintmax_t uid, char const *server_name)
+{
+ /* If ! (0 <= TMPDIRLEN && TMPDIRLEN < SOCKNAMESIZE) the truncated
+ temporary directory name is already in SOCKNAME, so nothing more
+ need be stored. */
+ if (0 <= tmpdirlen)
+ {
+ int remaining = socknamesize - tmpdirlen;
+ if (0 < remaining)
+ {
+ int suffixlen = snprintf (&sockname[tmpdirlen], remaining,
+ "/emacs%"PRIuMAX"/%s", uid, server_name);
+ if (0 <= suffixlen && suffixlen < remaining)
+ return tmpdirlen + suffixlen;
+ }
+ }
+ return -1;
+}
+
+/* Create a local socket for SERVER_NAME and connect it to Emacs. If
+ SERVER_NAME is a file name component, the local socket name
+ relative to a well-known location in a temporary directory.
+ Otherwise, the local socket name is SERVER_NAME. */
static HSOCKET
-set_local_socket (const char *local_socket_name)
+set_local_socket (char const *server_name)
{
- HSOCKET s;
- struct sockaddr_un server;
+ union {
+ struct sockaddr_un un;
+ struct sockaddr sa;
+ } server = {{ .sun_family = AF_UNIX }};
+ char *sockname = server.un.sun_path;
+ enum { socknamesize = sizeof server.un.sun_path };
+ int tmpdirlen = -1;
+ int socknamelen = -1;
+ uid_t uid = geteuid ();
+
+ if (strchr (server_name, '/')
+ || (ISSLASH ('\\') && strchr (server_name, '\\')))
+ socknamelen = snprintf (sockname, socknamesize, "%s", server_name);
+ else
+ {
+ /* socket_name is a file name component. */
+ char const *xdg_runtime_dir = egetenv ("XDG_RUNTIME_DIR");
+ if (xdg_runtime_dir)
+ socknamelen = snprintf (sockname, socknamesize, "%s/emacs/%s",
+ xdg_runtime_dir, server_name);
+ else
+ {
+ char const *tmpdir = egetenv ("TMPDIR");
+ if (tmpdir)
+ tmpdirlen = snprintf (sockname, socknamesize, "%s", tmpdir);
+ else
+ {
+# ifdef DARWIN_OS
+# ifndef _CS_DARWIN_USER_TEMP_DIR
+# define _CS_DARWIN_USER_TEMP_DIR 65537
+# endif
+ size_t n = confstr (_CS_DARWIN_USER_TEMP_DIR,
+ sockname, socknamesize);
+ if (0 < n && n < (size_t) -1)
+ tmpdirlen = min (n - 1, socknamesize);
+# endif
+ if (tmpdirlen < 0)
+ tmpdirlen = snprintf (sockname, socknamesize, "/tmp");
+ }
+ socknamelen = local_sockname (sockname, socknamesize, tmpdirlen,
+ uid, server_name);
+ }
+ }
- /* Open up an AF_UNIX socket in this person's home directory. */
- if ((s = socket (AF_UNIX, SOCK_STREAM, 0)) < 0)
+ if (! (0 <= socknamelen && socknamelen < socknamesize))
{
- message (true, "%s: socket: %s\n", progname, strerror (errno));
- return INVALID_SOCKET;
+ message (true, "%s: socket-name %s... too long\n", progname, sockname);
+ fail ();
}
- server.sun_family = AF_UNIX;
+ /* See if the socket exists, and if it's owned by us. */
+ int sock_status = socket_status (sockname, uid);
+ if (sock_status)
+ {
+ /* Failing that, see if LOGNAME or USER exist and differ from
+ our euid. If so, look for a socket based on the UID
+ associated with the name. This is reminiscent of the logic
+ that init_editfns uses to set the global Vuser_full_name. */
- {
- int sock_status;
- int saved_errno;
- const char *server_name = local_socket_name;
- const char *tmpdir = NULL;
- char *tmpdir_storage = NULL;
- char *socket_name_storage = NULL;
+ char const *user_name = egetenv ("LOGNAME");
- if (!strchr (local_socket_name, '/') && !strchr (local_socket_name, '\\'))
- {
- /* socket_name is a file name component. */
- long uid = geteuid ();
- tmpdir = egetenv ("TMPDIR");
- if (!tmpdir)
- {
-#ifdef DARWIN_OS
-#ifndef _CS_DARWIN_USER_TEMP_DIR
-#define _CS_DARWIN_USER_TEMP_DIR 65537
-#endif
- size_t n = confstr (_CS_DARWIN_USER_TEMP_DIR, NULL, (size_t) 0);
- if (n > 0)
- {
- tmpdir = tmpdir_storage = xmalloc (n);
- confstr (_CS_DARWIN_USER_TEMP_DIR, tmpdir_storage, n);
- }
- else
-#endif
- tmpdir = "/tmp";
- }
- socket_name_storage =
- xmalloc (strlen (tmpdir) + strlen (server_name) + EXTRA_SPACE);
- char *z = stpcpy (socket_name_storage, tmpdir);
- z += sprintf (z, "/emacs%ld/", uid);
- strcpy (z, server_name);
- local_socket_name = socket_name_storage;
- }
+ if (!user_name)
+ user_name = egetenv ("USER");
- if (strlen (local_socket_name) < sizeof (server.sun_path))
- strcpy (server.sun_path, local_socket_name);
- else
- {
- message (true, "%s: socket-name %s too long\n",
- progname, local_socket_name);
- fail ();
- }
+ if (user_name)
+ {
+ struct passwd *pw = getpwnam (user_name);
- /* See if the socket exists, and if it's owned by us. */
- sock_status = socket_status (server.sun_path);
- saved_errno = errno;
- if (sock_status && tmpdir)
- {
- /* Failing that, see if LOGNAME or USER exist and differ from
- our euid. If so, look for a socket based on the UID
- associated with the name. This is reminiscent of the logic
- that init_editfns uses to set the global Vuser_full_name. */
-
- const char *user_name = egetenv ("LOGNAME");
-
- if (!user_name)
- user_name = egetenv ("USER");
-
- if (user_name)
- {
- struct passwd *pw = getpwnam (user_name);
-
- if (pw && (pw->pw_uid != geteuid ()))
- {
- /* We're running under su, apparently. */
- long uid = pw->pw_uid;
- char *user_socket_name
- = xmalloc (strlen (tmpdir) + strlen (server_name)
- + EXTRA_SPACE);
- char *z = stpcpy (user_socket_name, tmpdir);
- z += sprintf (z, "/emacs%ld/", uid);
- strcpy (z, server_name);
-
- if (strlen (user_socket_name) < sizeof (server.sun_path))
- strcpy (server.sun_path, user_socket_name);
- else
- {
- message (true, "%s: socket-name %s too long\n",
- progname, user_socket_name);
- exit (EXIT_FAILURE);
- }
- free (user_socket_name);
-
- sock_status = socket_status (server.sun_path);
- saved_errno = errno;
- }
- else
- errno = saved_errno;
- }
- }
+ if (pw && pw->pw_uid != uid)
+ {
+ /* We're running under su, apparently. */
+ socknamelen = local_sockname (sockname, socknamesize, tmpdirlen,
+ pw->pw_uid, server_name);
+ if (socknamelen < 0)
+ {
+ message (true, "%s: socket-name %s... too long\n",
+ progname, sockname);
+ exit (EXIT_FAILURE);
+ }
- free (socket_name_storage);
- free (tmpdir_storage);
+ sock_status = socket_status (sockname, uid);
+ }
+ }
+ }
- switch (sock_status)
- {
- case 1:
- /* There's a socket, but it isn't owned by us. This is OK if
- we are root. */
- if (0 != geteuid ())
- {
- message (true, "%s: Invalid socket owner\n", progname);
- return INVALID_SOCKET;
- }
- break;
+ if (sock_status == 0)
+ {
+ HSOCKET s = cloexec_socket (AF_UNIX, SOCK_STREAM, 0);
+ if (s < 0)
+ {
+ message (true, "%s: socket: %s\n", progname, strerror (errno));
+ return INVALID_SOCKET;
+ }
+ if (connect (s, &server.sa, sizeof server.un) != 0)
+ {
+ message (true, "%s: connect: %s\n", progname, strerror (errno));
+ CLOSE_SOCKET (s);
+ return INVALID_SOCKET;
+ }
- case 2:
- /* `stat' failed */
- if (saved_errno == ENOENT)
- message (true,
- "%s: can't find socket; have you started the server?\n\
-To start the server in Emacs, type \"M-x server-start\".\n",
- progname);
- else
- message (true, "%s: can't stat %s: %s\n",
- progname, server.sun_path, strerror (saved_errno));
- return INVALID_SOCKET;
- }
- }
+ struct stat connect_stat;
+ if (fstat (s, &connect_stat) != 0)
+ sock_status = errno;
+ else if (connect_stat.st_uid == uid)
+ return s;
+ else
+ sock_status = -1;
- if (connect (s, (struct sockaddr *) &server, strlen (server.sun_path) + 2)
- < 0)
- {
- message (true, "%s: connect: %s\n", progname, strerror (errno));
- return INVALID_SOCKET;
+ CLOSE_SOCKET (s);
}
- return s;
+ if (sock_status < 0)
+ message (true, "%s: Invalid socket owner\n", progname);
+ else if (sock_status == ENOENT)
+ message (true,
+ ("%s: can't find socket; have you started the server?\n"
+ "%s: To start the server in Emacs,"
+ " type \"M-x server-start\".\n"),
+ progname, progname);
+ else
+ message (true, "%s: can't stat %s: %s\n",
+ progname, sockname, strerror (sock_status));
+
+ return INVALID_SOCKET;
}
-#endif /* ! NO_SOCKETS_IN_FILE_SYSTEM */
+#endif /* SOCKETS_IN_FILE_SYSTEM */
static HSOCKET
-set_socket (int no_exit_if_error)
+set_socket (bool no_exit_if_error)
{
HSOCKET s;
const char *local_server_file = server_file;
INITIALIZE ();
-#ifndef NO_SOCKETS_IN_FILE_SYSTEM
- /* Explicit --socket-name argument. */
+#ifdef SOCKETS_IN_FILE_SYSTEM
+ if (!socket_name)
+ socket_name = egetenv ("EMACS_SOCKET_NAME");
+
if (socket_name)
{
+ /* Explicit --socket-name argument, or environment variable. */
s = set_local_socket (socket_name);
- if ((s != INVALID_SOCKET) || no_exit_if_error)
+ if (s != INVALID_SOCKET || no_exit_if_error)
return s;
message (true, "%s: error accessing socket \"%s\"\n",
progname, socket_name);
@@ -1424,7 +1506,7 @@ set_socket (int no_exit_if_error)
if (local_server_file)
{
s = set_tcp_socket (local_server_file);
- if ((s != INVALID_SOCKET) || no_exit_if_error)
+ if (s != INVALID_SOCKET || no_exit_if_error)
return s;
message (true, "%s: error accessing server file \"%s\"\n",
@@ -1432,7 +1514,7 @@ set_socket (int no_exit_if_error)
exit (EXIT_FAILURE);
}
-#ifndef NO_SOCKETS_IN_FILE_SYSTEM
+#ifdef SOCKETS_IN_FILE_SYSTEM
/* Implicit local socket. */
s = set_local_socket ("server");
if (s != INVALID_SOCKET)
@@ -1441,12 +1523,12 @@ set_socket (int no_exit_if_error)
/* Implicit server file. */
s = set_tcp_socket ("server");
- if ((s != INVALID_SOCKET) || no_exit_if_error)
+ if (s != INVALID_SOCKET || no_exit_if_error)
return s;
/* No implicit or explicit socket, and no alternate editor. */
message (true, "%s: No socket or alternate editor. Please use:\n\n"
-#ifndef NO_SOCKETS_IN_FILE_SYSTEM
+#ifdef SOCKETS_IN_FILE_SYSTEM
"\t--socket-name\n"
#endif
"\t--server-file (or environment variable EMACS_SERVER_FILE)\n\
@@ -1543,7 +1625,7 @@ w32_give_focus (void)
/* Start the emacs daemon and try to connect to it. */
-static void
+static HSOCKET
start_daemon_and_retry_set_socket (void)
{
#ifndef WINDOWSNT
@@ -1554,22 +1636,17 @@ start_daemon_and_retry_set_socket (void)
if (dpid > 0)
{
- pid_t w;
- w = waitpid (dpid, &status, WUNTRACED | WCONTINUED);
+ pid_t w = waitpid (dpid, &status, WUNTRACED | WCONTINUED);
- if ((w == -1) || !WIFEXITED (status) || WEXITSTATUS (status))
+ if (w < 0 || !WIFEXITED (status) || WEXITSTATUS (status))
{
message (true, "Error: Could not start the Emacs daemon\n");
exit (EXIT_FAILURE);
}
/* Try connecting, the daemon should have started by now. */
- message (true, "Emacs daemon should have started, trying to connect again\n");
- if ((emacs_socket = set_socket (1)) == INVALID_SOCKET)
- {
- message (true, "Error: Cannot connect even after starting the Emacs daemon\n");
- exit (EXIT_FAILURE);
- }
+ message (true,
+ "Emacs daemon should have started, trying to connect again\n");
}
else if (dpid < 0)
{
@@ -1584,6 +1661,7 @@ start_daemon_and_retry_set_socket (void)
d_argv[0] = emacs;
d_argv[1] = daemon_option;
d_argv[2] = 0;
+# ifdef SOCKETS_IN_FILE_SYSTEM
if (socket_name != NULL)
{
/* Pass --daemon=socket_name as argument. */
@@ -1593,8 +1671,10 @@ start_daemon_and_retry_set_socket (void)
strcpy (stpcpy (daemon_arg, deq), socket_name);
d_argv[1] = daemon_arg;
}
+# endif
execvp ("emacs", d_argv);
message (true, "%s: error starting emacs daemon\n", progname);
+ exit (EXIT_FAILURE);
}
#else /* WINDOWSNT */
DWORD wait_result;
@@ -1660,27 +1740,29 @@ start_daemon_and_retry_set_socket (void)
if (!w32_window_app ())
message (true,
"Emacs daemon should have started, trying to connect again\n");
- if ((emacs_socket = set_socket (1)) == INVALID_SOCKET)
+#endif /* WINDOWSNT */
+
+ HSOCKET emacs_socket = set_socket (true);
+ if (emacs_socket == INVALID_SOCKET)
{
message (true,
"Error: Cannot connect even after starting the Emacs daemon\n");
exit (EXIT_FAILURE);
}
-#endif /* WINDOWSNT */
+ return emacs_socket;
}
int
main (int argc, char **argv)
{
- int rl = 0, needlf = 0;
- char *cwd, *str;
- char string[BUFSIZ+1];
- int start_daemon_if_needed;
- int exit_status = EXIT_SUCCESS;
-
main_argc = argc;
main_argv = argv;
- progname = argv[0];
+ progname = argv[0] ? argv[0] : "emacsclient";
+
+ int rl = 0;
+ bool skiplf = true;
+ char string[BUFSIZ + 1];
+ int exit_status = EXIT_SUCCESS;
#ifdef HAVE_NTGUI
/* On Windows 7 and later, we need to explicitly associate
@@ -1688,44 +1770,43 @@ main (int argc, char **argv)
association does no harm if we're not actually connecting to an
Emacs using a window display. */
w32_set_user_model_id ();
-#endif /* HAVE_NTGUI */
+#endif
/* Process options. */
decode_options (argc, argv);
- if ((argc - optind < 1) && !eval && current_frame)
+ if (! (optind < argc || eval || create_frame))
{
- message (true, "%s: file name or argument required\n"
- "Try '%s --help' for more information\n",
+ message (true, ("%s: file name or argument required\n"
+ "Try '%s --help' for more information\n"),
progname, progname);
exit (EXIT_FAILURE);
}
-#ifndef WINDOWSNT
+#ifdef SOCKETS_IN_FILE_SYSTEM
if (tty)
{
- pid_t pgrp = getpgrp ();
- pid_t tcpgrp = tcgetpgrp (1);
- if (0 <= tcpgrp && tcpgrp != pgrp)
- kill (-pgrp, SIGTTIN);
+ pid_t grouping = process_grouping ();
+ if (grouping < 0)
+ kill (grouping, SIGTTIN);
}
-#endif /* !WINDOWSNT */
+#endif
/* If alternate_editor is the empty string, start the emacs daemon
in case of failure to connect. */
- start_daemon_if_needed = (alternate_editor
- && (alternate_editor[0] == '\0'));
+ bool start_daemon_if_needed = alternate_editor && !alternate_editor[0];
- emacs_socket = set_socket (alternate_editor || start_daemon_if_needed);
+ HSOCKET emacs_socket = set_socket (alternate_editor
+ || start_daemon_if_needed);
if (emacs_socket == INVALID_SOCKET)
{
if (! start_daemon_if_needed)
fail ();
- start_daemon_and_retry_set_socket ();
+ emacs_socket = start_daemon_and_retry_set_socket ();
}
- cwd = get_current_dir_name ();
+ char *cwd = get_current_dir_name ();
if (cwd == 0)
{
message (true, "%s: %s\n", progname,
@@ -1736,16 +1817,15 @@ main (int argc, char **argv)
#ifdef HAVE_NTGUI
if (display && !strcmp (display, "w32"))
w32_give_focus ();
-#endif /* HAVE_NTGUI */
+#endif
/* Send over our environment and current directory. */
- if (!current_frame)
+ if (create_frame)
{
- int i;
- for (i = 0; environ[i]; i++)
+ for (char *const *e = environ; *e; e++)
{
send_to_emacs (emacs_socket, "-env ");
- quote_argument (emacs_socket, environ[i]);
+ quote_argument (emacs_socket, *e);
send_to_emacs (emacs_socket, " ");
}
}
@@ -1761,7 +1841,7 @@ main (int argc, char **argv)
if (nowait)
send_to_emacs (emacs_socket, "-nowait ");
- if (current_frame)
+ if (!create_frame)
send_to_emacs (emacs_socket, "-current-frame ");
if (display)
@@ -1778,7 +1858,7 @@ main (int argc, char **argv)
send_to_emacs (emacs_socket, " ");
}
- if (frame_parameters && !current_frame)
+ if (frame_parameters && create_frame)
{
send_to_emacs (emacs_socket, "-frame-parameters ");
quote_argument (emacs_socket, frame_parameters);
@@ -1788,15 +1868,16 @@ main (int argc, char **argv)
/* Unless we are certain we don't want to occupy the tty, send our
tty information to Emacs. For example, in daemon mode Emacs may
need to occupy this tty if no other frame is available. */
- if (!current_frame || !eval)
+ if (create_frame || !eval)
{
const char *tty_type, *tty_name;
if (find_tty (&tty_type, &tty_name, !tty))
{
-#if !defined (NO_SOCKETS_IN_FILE_SYSTEM)
+ /* Install signal handlers before opening a frame on the
+ current tty. */
init_signals ();
-#endif
+
send_to_emacs (emacs_socket, "-tty ");
quote_argument (emacs_socket, tty_name);
send_to_emacs (emacs_socket, " ");
@@ -1805,13 +1886,12 @@ main (int argc, char **argv)
}
}
- if (!current_frame && !tty)
+ if (create_frame && !tty)
send_to_emacs (emacs_socket, "-window-system ");
- if ((argc - optind > 0))
+ if (optind < argc)
{
- int i;
- for (i = optind; i < argc; i++)
+ for (int i = optind; i < argc; i++)
{
if (eval)
@@ -1823,11 +1903,15 @@ main (int argc, char **argv)
continue;
}
- if (*argv[i] == '+')
+ char *p = argv[i];
+ if (*p == '+')
{
- char *p = argv[i] + 1;
- while (isdigit ((unsigned char) *p) || *p == ':') p++;
- if (*p == 0)
+ unsigned char c;
+ do
+ c = *++p;
+ while (isdigit (c) || c == ':');
+
+ if (c == 0)
{
send_to_emacs (emacs_socket, "-position ");
quote_argument (emacs_socket, argv[i]);
@@ -1836,7 +1920,7 @@ main (int argc, char **argv)
}
}
#ifdef WINDOWSNT
- else if (! file_name_absolute_p (argv[i])
+ else if (! IS_ABSOLUTE_FILE_NAME (argv[i])
&& (isalpha (argv[i][0]) && argv[i][1] == ':'))
/* Windows can have a different default directory for each
drive, so the cwd passed via "-dir" is not sufficient
@@ -1845,7 +1929,7 @@ main (int argc, char **argv)
careful to expand <relpath> with the default directory
corresponding to <drive>. */
{
- char *filename = (char *) xmalloc (MAX_PATH);
+ char *filename = xmalloc (MAX_PATH);
DWORD size;
size = GetFullPathName (argv[i], MAX_PATH, filename, NULL);
@@ -1857,7 +1941,7 @@ main (int argc, char **argv)
#endif
send_to_emacs (emacs_socket, "-file ");
- if (tramp_prefix && file_name_absolute_p (argv[i]))
+ if (tramp_prefix && IS_ABSOLUTE_FILE_NAME (argv[i]))
quote_argument (emacs_socket, tramp_prefix);
quote_argument (emacs_socket, argv[i]);
send_to_emacs (emacs_socket, " ");
@@ -1866,10 +1950,10 @@ main (int argc, char **argv)
else if (eval)
{
/* Read expressions interactively. */
- while ((str = fgets (string, BUFSIZ, stdin)))
+ while (fgets (string, BUFSIZ, stdin))
{
send_to_emacs (emacs_socket, "-eval ");
- quote_argument (emacs_socket, str);
+ quote_argument (emacs_socket, string);
}
send_to_emacs (emacs_socket, " ");
}
@@ -1877,26 +1961,21 @@ main (int argc, char **argv)
send_to_emacs (emacs_socket, "\n");
/* Wait for an answer. */
- if (!eval && !tty && !nowait && !quiet)
+ if (!eval && !tty && !nowait && !quiet && 0 <= process_grouping ())
{
printf ("Waiting for Emacs...");
- needlf = 2;
+ skiplf = false;
}
fflush (stdout);
- while (fdatasync (1) != 0 && errno == EINTR)
- continue;
/* Now, wait for an answer and print any messages. */
while (exit_status == EXIT_SUCCESS)
{
- char *p, *end_p;
do
- {
- errno = 0;
- rl = recv (emacs_socket, string, BUFSIZ, 0);
- }
- /* If we receive a signal (e.g. SIGWINCH, which we pass
- through to Emacs), on some OSes we get EINTR and must retry. */
+ {
+ act_on_signals (emacs_socket);
+ rl = recv (emacs_socket, string, BUFSIZ, 0);
+ }
while (rl < 0 && errno == EINTR);
if (rl <= 0)
@@ -1905,7 +1984,8 @@ main (int argc, char **argv)
string[rl] = '\0';
/* Loop over all NL-terminated messages. */
- for (end_p = p = string; end_p != NULL && *end_p != '\0'; p = end_p)
+ char *p = string;
+ for (char *end_p = p; end_p && *end_p != '\0'; p = end_p)
{
end_p = strchr (p, '\n');
if (end_p != NULL)
@@ -1914,7 +1994,7 @@ main (int argc, char **argv)
if (strprefix ("-emacs-pid ", p))
{
/* -emacs-pid PID: The process id of the Emacs process. */
- emacs_pid = strtol (p + strlen ("-emacs-pid"), NULL, 10);
+ emacs_pid = strtoumax (p + strlen ("-emacs-pid"), NULL, 10);
}
else if (strprefix ("-window-system-unsupported ", p))
{
@@ -1928,8 +2008,8 @@ main (int argc, char **argv)
}
else
{
- nowait = 0;
- tty = 1;
+ nowait = false;
+ tty = true;
}
goto retry;
@@ -1939,11 +2019,10 @@ main (int argc, char **argv)
/* -print STRING: Print STRING on the terminal. */
if (!suppress_output)
{
- str = unquote_argument (p + strlen ("-print "));
- if (needlf)
- printf ("\n");
- printf ("%s", str);
- needlf = str[0] == '\0' ? needlf : str[strlen (str) - 1] != '\n';
+ char *str = unquote_argument (p + strlen ("-print "));
+ printf (&"\n%s"[skiplf], str);
+ if (str[0])
+ skiplf = str[strlen (str) - 1] == '\n';
}
}
else if (strprefix ("-print-nonl ", p))
@@ -1952,47 +2031,44 @@ main (int argc, char **argv)
Used to continue a preceding -print command. */
if (!suppress_output)
{
- str = unquote_argument (p + strlen ("-print-nonl "));
+ char *str = unquote_argument (p + strlen ("-print-nonl "));
printf ("%s", str);
- needlf = str[0] == '\0' ? needlf : str[strlen (str) - 1] != '\n';
+ if (str[0])
+ skiplf = str[strlen (str) - 1] == '\n';
}
}
else if (strprefix ("-error ", p))
{
/* -error DESCRIPTION: Signal an error on the terminal. */
- str = unquote_argument (p + strlen ("-error "));
- if (needlf)
+ char *str = unquote_argument (p + strlen ("-error "));
+ if (!skiplf)
printf ("\n");
fprintf (stderr, "*ERROR*: %s", str);
- needlf = str[0] == '\0' ? needlf : str[strlen (str) - 1] != '\n';
+ if (str[0])
+ skiplf = str[strlen (str) - 1] == '\n';
exit_status = EXIT_FAILURE;
}
-#ifdef SIGSTOP
+#ifndef WINDOWSNT
else if (strprefix ("-suspend ", p))
{
/* -suspend: Suspend this terminal, i.e., stop the process. */
- if (needlf)
+ if (!skiplf)
printf ("\n");
- needlf = 0;
+ skiplf = true;
kill (0, SIGSTOP);
}
#endif
else
{
/* Unknown command. */
- if (needlf)
- printf ("\n");
- needlf = 0;
- printf ("*ERROR*: Unknown message: %s\n", p);
+ printf (&"\n*ERROR*: Unknown message: %s\n"[skiplf], p);
+ skiplf = true;
}
}
}
- if (needlf)
+ if (!skiplf && 0 <= process_grouping ())
printf ("\n");
- fflush (stdout);
- while (fdatasync (1) != 0 && errno == EINTR)
- continue;
if (rl < 0)
exit_status = EXIT_FAILURE;
@@ -2000,5 +2076,3 @@ main (int argc, char **argv)
CLOSE_SOCKET (emacs_socket);
return exit_status;
}
-
-#endif /* HAVE_SOCKETS && HAVE_INET_SOCKETS */
diff --git a/lib-src/etags.c b/lib-src/etags.c
index 6c6372b955f..362897fb0c3 100644
--- a/lib-src/etags.c
+++ b/lib-src/etags.c
@@ -85,7 +85,9 @@ char pot_etags_version[] = "@(#) pot revision number is 17.38.1.4";
# define DEBUG true
#else
# define DEBUG false
-# define NDEBUG /* disable assert */
+# ifndef NDEBUG
+# define NDEBUG /* disable assert */
+# endif
#endif
#include <config.h>
@@ -6401,7 +6403,7 @@ add_regex (char *regexp_pattern, language *lang)
*patbuf = zeropattern;
if (ignore_case)
{
- static char lc_trans[UCHAR_MAX + 1];
+ static unsigned char lc_trans[UCHAR_MAX + 1];
int i;
for (i = 0; i < UCHAR_MAX + 1; i++)
lc_trans[i] = c_tolower (i);
@@ -7304,7 +7306,7 @@ linebuffer_setlen (linebuffer *lbp, int toksize)
}
/* Like malloc but get fatal error if memory is exhausted. */
-static void *
+static void * ATTRIBUTE_MALLOC
xmalloc (size_t size)
{
void *result = malloc (size);
diff --git a/lib-src/make-docfile.c b/lib-src/make-docfile.c
index 212f73e10b1..ccd245e0139 100644
--- a/lib-src/make-docfile.c
+++ b/lib-src/make-docfile.c
@@ -43,6 +43,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <string.h>
#include <binary-io.h>
+#include <c-ctype.h>
#include <intprops.h>
#include <min-max.h>
#include <unlocked-io.h>
@@ -122,7 +123,7 @@ memory_exhausted (void)
/* Like malloc but get fatal error if memory is exhausted. */
-static void *
+static void * ATTRIBUTE_MALLOC
xmalloc (ptrdiff_t size)
{
void *result = malloc (size);
@@ -341,7 +342,7 @@ scan_keyword_or_put_char (char ch, struct rcsoc_state *state)
state->pending_newlines = 2;
state->pending_spaces = 0;
- /* Skip any whitespace between the keyword and the
+ /* Skip any spaces and newlines between the keyword and the
usage string. */
int c;
do
@@ -361,6 +362,7 @@ scan_keyword_or_put_char (char ch, struct rcsoc_state *state)
fatal ("Unexpected EOF after keyword");
}
while (c != ' ' && c != ')');
+
put_char ('f', state);
put_char ('n', state);
@@ -415,7 +417,7 @@ read_c_string_or_comment (FILE *infile, int printflag, bool comment,
c = getc (infile);
if (comment)
- while (c == '\n' || c == '\r' || c == '\t' || c == ' ')
+ while (c_isspace (c))
c = getc (infile);
while (c != EOF)
@@ -425,15 +427,14 @@ read_c_string_or_comment (FILE *infile, int printflag, bool comment,
if (c == '\\')
{
c = getc (infile);
- if (c == '\n' || c == '\r')
+ switch (c)
{
+ case '\n': case '\r':
c = getc (infile);
continue;
+ case 'n': c = '\n'; break;
+ case 't': c = '\t'; break;
}
- if (c == 'n')
- c = '\n';
- if (c == 't')
- c = '\t';
}
if (c == ' ')
@@ -504,10 +505,7 @@ write_c_args (char *func, char *buf, int minargs, int maxargs)
char c = *p;
/* Notice when a new identifier starts. */
- if ((('A' <= c && c <= 'Z')
- || ('a' <= c && c <= 'z')
- || ('0' <= c && c <= '9')
- || c == '_')
+ if ((c_isalnum (c) || c == '_')
!= in_ident)
{
if (!in_ident)
@@ -550,11 +548,8 @@ write_c_args (char *func, char *buf, int minargs, int maxargs)
else
while (ident_length-- > 0)
{
- c = *ident_start++;
- if (c >= 'a' && c <= 'z')
- /* Upcase the letter. */
- c += 'A' - 'a';
- else if (c == '_')
+ c = c_toupper (*ident_start++);
+ if (c == '_')
/* Print underscore as hyphen. */
c = '-';
putchar (c);
@@ -705,7 +700,7 @@ write_globals (void)
switch (globals[i].type)
{
case EMACS_INTEGER:
- type = "EMACS_INT";
+ type = "intmax_t";
break;
case BOOLEAN:
type = "bool";
@@ -960,7 +955,7 @@ scan_c_stream (FILE *infile)
{
c = getc (infile);
}
- while (c == ',' || c == ' ' || c == '\t' || c == '\n' || c == '\r');
+ while (c == ',' || c_isspace (c));
/* Read in the identifier. */
do
@@ -972,8 +967,8 @@ scan_c_stream (FILE *infile)
fatal ("identifier too long");
c = getc (infile);
}
- while (! (c == ',' || c == ' ' || c == '\t'
- || c == '\n' || c == '\r'));
+ while (! (c == ',' || c_isspace (c)));
+
input_buffer[i] = '\0';
memcpy (name, input_buffer, i + 1);
@@ -981,7 +976,8 @@ scan_c_stream (FILE *infile)
{
do
c = getc (infile);
- while (c == ' ' || c == '\t' || c == '\n' || c == '\r');
+ while (c_isspace (c));
+
if (c != '"')
continue;
c = read_c_string_or_comment (infile, -1, false, 0);
@@ -1022,7 +1018,8 @@ scan_c_stream (FILE *infile)
int scanned = 0;
do
c = getc (infile);
- while (c == ' ' || c == '\n' || c == '\r' || c == '\t');
+ while (c_isspace (c));
+
if (c < 0)
goto eof;
ungetc (c, infile);
@@ -1072,7 +1069,7 @@ scan_c_stream (FILE *infile)
int d = getc (infile);
if (d == EOF)
goto eof;
- while (1)
+ while (true)
{
if (c == '*' && d == '/')
break;
@@ -1087,13 +1084,14 @@ scan_c_stream (FILE *infile)
if (c == EOF)
goto eof;
}
- while (c == ' ' || c == '\n' || c == '\r' || c == '\t');
+ while (c_isspace (c));
+
/* Check for 'attributes:' token. */
if (c == 'a' && stream_match (infile, "ttributes:"))
{
char *p = input_buffer;
/* Collect attributes up to ')'. */
- while (1)
+ while (true)
{
c = getc (infile);
if (c == EOF)
@@ -1109,13 +1107,16 @@ scan_c_stream (FILE *infile)
g->flags |= DEFUN_noreturn;
if (strstr (input_buffer, "const"))
g->flags |= DEFUN_const;
+
+ /* Although the noinline attribute is no longer used,
+ leave its support in, in case it's needed later. */
if (strstr (input_buffer, "noinline"))
g->flags |= DEFUN_noinline;
}
continue;
}
- while (c == ' ' || c == '\n' || c == '\r' || c == '\t')
+ while (c_isspace (c))
c = getc (infile);
if (c == '"')
@@ -1125,17 +1126,18 @@ scan_c_stream (FILE *infile)
c = getc (infile);
if (c == ',')
{
- c = getc (infile);
- while (c == ' ' || c == '\n' || c == '\r' || c == '\t')
+ do
c = getc (infile);
- while ((c >= 'a' && c <= 'z') || (c >= 'Z' && c <= 'Z'))
+ while (c_isspace (c));
+
+ while (c_isalpha (c))
c = getc (infile);
if (c == ':')
{
doc_keyword = true;
- c = getc (infile);
- while (c == ' ' || c == '\n' || c == '\r' || c == '\t')
+ do
c = getc (infile);
+ while (c_isspace (c));
}
}
@@ -1186,8 +1188,14 @@ scan_c_stream (FILE *infile)
/* Copy arguments into ARGBUF. */
*p++ = c;
do
- *p++ = c = getc (infile);
+ {
+ c = getc (infile);
+ if (c < 0)
+ goto eof;
+ *p++ = c;
+ }
while (c != ')');
+
*p = '\0';
/* Output them. */
fputs ("\n\n", stdout);
@@ -1243,25 +1251,32 @@ scan_c_stream (FILE *infile)
static void
skip_white (FILE *infile)
{
- char c = ' ';
- while (c == ' ' || c == '\t' || c == '\n' || c == '\r')
+ int c;
+ do
c = getc (infile);
+ while (c_isspace (c));
+
ungetc (c, infile);
}
static void
read_lisp_symbol (FILE *infile, char *buffer)
{
- char c;
+ int c;
char *fillp = buffer;
skip_white (infile);
- while (1)
+ while (true)
{
c = getc (infile);
if (c == '\\')
- *(++fillp) = getc (infile);
- else if (c == ' ' || c == '\t' || c == '\n' || c == '\r' || c == '(' || c == ')')
+ {
+ c = getc (infile);
+ if (c < 0)
+ return;
+ *fillp++ = c;
+ }
+ else if (c_isspace (c) || c == '(' || c == ')' || c < 0)
{
ungetc (c, infile);
*fillp = 0;
@@ -1381,7 +1396,7 @@ scan_lisp_file (const char *filename, const char *mode)
/* Read the length. */
while ((c = getc (infile),
- c >= '0' && c <= '9'))
+ c_isdigit (c)))
{
if (INT_MULTIPLY_WRAPV (length, 10, &length)
|| INT_ADD_WRAPV (length, c - '0', &length)
@@ -1413,7 +1428,7 @@ scan_lisp_file (const char *filename, const char *mode)
while (c == '\n' || c == '\r')
c = getc (infile);
/* Skip the following line. */
- while (c != '\n' && c != '\r')
+ while (! (c == '\n' || c == '\r' || c < 0))
c = getc (infile);
}
continue;
@@ -1451,7 +1466,7 @@ scan_lisp_file (const char *filename, const char *mode)
continue;
}
else
- while (c != ')')
+ while (! (c == ')' || c < 0))
c = getc (infile);
skip_white (infile);
@@ -1595,7 +1610,8 @@ scan_lisp_file (const char *filename, const char *mode)
}
}
skip_white (infile);
- if ((c = getc (infile)) != '\"')
+ c = getc (infile);
+ if (c != '\"')
{
fprintf (stderr, "## autoload of %s unparsable (%s)\n",
buffer, filename);
diff --git a/lib-src/make-fingerprint.c b/lib-src/make-fingerprint.c
new file mode 100644
index 00000000000..35bb8b98a00
--- /dev/null
+++ b/lib-src/make-fingerprint.c
@@ -0,0 +1,113 @@
+/* Hash inputs and generate C file with the digest.
+
+Copyright (C) 1985-1986, 1992-1994, 1997, 1999-2016, 2018-2019
+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 <http://www.gnu.org/licenses/>. */
+
+
+/* The arguments given to this program are all the object files that
+ go into building GNU Emacs. There is no special search logic to find
+ the files. */
+
+#include <config.h>
+
+#include <stdarg.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <sysstdio.h>
+#include <sha256.h>
+#include <getopt.h>
+
+#ifdef WINDOWSNT
+/* Defined to be sys_fopen in ms-w32.h, but only #ifdef emacs, so this
+ is really just insurance. */
+#undef fopen
+#include <direct.h>
+#endif /* WINDOWSNT */
+
+int
+main (int argc, char **argv)
+{
+ int c;
+ bool raw = false;
+ while (0 <= (c = getopt (argc, argv, "rh")))
+ {
+ switch (c)
+ {
+ case 'r':
+ raw = true;
+ break;
+ case 'h':
+ printf ("make-fingerprint [-r] FILES...: compute a hash\n");
+ return 0;
+ default:
+ return 1;
+ }
+ }
+
+ struct sha256_ctx ctx;
+ sha256_init_ctx (&ctx);
+
+ for (int i = optind; i < argc; ++i)
+ {
+ FILE *f = fopen (argv[i], "r" FOPEN_BINARY);
+ if (!f)
+ {
+ fprintf (stderr, "%s: Error: could not open %s\n",
+ argv[0], argv[i]);
+ return 1;
+ }
+
+ char buf[128*1024];
+ do
+ {
+ size_t chunksz = fread (buf, 1, sizeof (buf), f);
+ if (ferror (f))
+ {
+ fprintf (stderr, "%s: Error: could not read %s\n",
+ argv[0], argv[i]);
+ return 1;
+ }
+ sha256_process_bytes (buf, chunksz, &ctx);
+ } while (!feof (f));
+ fclose (f);
+ }
+
+ unsigned char digest[32];
+ sha256_finish_ctx (&ctx, digest);
+
+ if (raw)
+ {
+ for (int i = 0; i < 32; ++i)
+ printf ("%02X", digest[i]);
+ }
+ else
+ {
+ puts ("#include \"fingerprint.h\"\n"
+ "unsigned char const fingerprint[] =\n"
+ "{");
+ for (int i = 0; i < 32; ++i)
+ printf ("\t0x%02X,\n", digest[i]);
+ puts ("};");
+ }
+
+ return EXIT_SUCCESS;
+}
+
+/* make-fingerprint.c ends here */
diff --git a/lib-src/movemail.c b/lib-src/movemail.c
index b1749362136..109e99828ed 100644
--- a/lib-src/movemail.c
+++ b/lib-src/movemail.c
@@ -145,7 +145,7 @@ static bool mbx_delimit_end (FILE *);
|| (!defined DISABLE_DIRECT_ACCESS && !defined MAIL_USE_SYSTEM_LOCK))
/* Like malloc but get fatal error if memory is exhausted. */
-static void *
+static void * ATTRIBUTE_MALLOC
xmalloc (size_t size)
{
void *result = malloc (size);
diff --git a/lib-src/ntlib.c b/lib-src/ntlib.c
index 5e1742a3174..dbafc47da28 100644
--- a/lib-src/ntlib.c
+++ b/lib-src/ntlib.c
@@ -31,6 +31,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <ctype.h>
#include <sys/timeb.h>
#include <mbstring.h>
+#include <locale.h>
+
+#include <nl_types.h>
+#include <langinfo.h>
#include "ntlib.h"
@@ -423,3 +427,66 @@ sys_open (const char * path, int oflag, int mode)
{
return _open (path, oflag, mode);
}
+
+/* Emulation of nl_langinfo that supports only CODESET.
+ Used in Gnulib regex.c. */
+char *
+nl_langinfo (nl_item item)
+{
+ switch (item)
+ {
+ case CODESET:
+ {
+ /* Shamelessly stolen from Gnulib's nl_langinfo.c, modulo
+ CPP directives. */
+ static char buf[2 + 10 + 1];
+ char const *locale = setlocale (LC_CTYPE, NULL);
+ char *codeset = buf;
+ size_t codesetlen;
+ codeset[0] = '\0';
+
+ if (locale && locale[0])
+ {
+ /* If the locale name contains an encoding after the
+ dot, return it. */
+ char *dot = strchr (locale, '.');
+
+ if (dot)
+ {
+ /* Look for the possible @... trailer and remove it,
+ if any. */
+ char *codeset_start = dot + 1;
+ char const *modifier = strchr (codeset_start, '@');
+
+ if (! modifier)
+ codeset = codeset_start;
+ else
+ {
+ codesetlen = modifier - codeset_start;
+ if (codesetlen < sizeof buf)
+ {
+ codeset = memcpy (buf, codeset_start, codesetlen);
+ codeset[codesetlen] = '\0';
+ }
+ }
+ }
+ }
+ /* If setlocale is successful, it returns the number of the
+ codepage, as a string. Otherwise, fall back on Windows
+ API GetACP, which returns the locale's codepage as a
+ number (although this doesn't change according to what
+ the 'setlocale' call specified). Either way, prepend
+ "CP" to make it a valid codeset name. */
+ codesetlen = strlen (codeset);
+ if (0 < codesetlen && codesetlen < sizeof buf - 2)
+ memmove (buf + 2, codeset, codesetlen + 1);
+ else
+ sprintf (buf + 2, "%u", GetACP ());
+ codeset = memcpy (buf, "CP", 2);
+
+ return codeset;
+ }
+ default:
+ return (char *) "";
+ }
+}
diff --git a/lib-src/profile.c b/lib-src/profile.c
index 2e83d48e0b1..257008e92d9 100644
--- a/lib-src/profile.c
+++ b/lib-src/profile.c
@@ -30,20 +30,19 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
** operations: reset_watch, get_time
*/
-#define INLINE EXTERN_INLINE
#include <config.h>
#include <inttypes.h>
#include <stdlib.h>
#include <intprops.h>
-#include <systime.h>
+#include <timespec.h>
#include <unlocked-io.h>
static struct timespec TV1;
static int watch_not_started = 1; /* flag */
static char time_string[INT_STRLEN_BOUND (uintmax_t) + sizeof "."
- + LOG10_TIMESPEC_RESOLUTION];
+ + LOG10_TIMESPEC_HZ];
/* Reset the stopwatch to zero. */
@@ -66,7 +65,7 @@ get_time (void)
int ns = TV2.tv_nsec;
if (watch_not_started)
exit (EXIT_FAILURE); /* call reset_watch first ! */
- sprintf (time_string, "%"PRIuMAX".%0*d", s, LOG10_TIMESPEC_RESOLUTION, ns);
+ sprintf (time_string, "%"PRIuMAX".%0*d", s, LOG10_TIMESPEC_HZ, ns);
return time_string;
}
diff --git a/lib/Makefile.in b/lib/Makefile.in
index a907254cd46..f2d203564ac 100644
--- a/lib/Makefile.in
+++ b/lib/Makefile.in
@@ -79,9 +79,15 @@ endif
Makefile: ../config.status $(srcdir)/Makefile.in
$(MAKE) -C .. src/$@
+# Object modules that need not be built for Emacs.
+# Emacs does not need e-regex.o (it has its own regex-emacs.c),
+# and building it would just waste time.
+not_emacs_OBJECTS = regex.o
+
libgnu_a_OBJECTS = $(gl_LIBOBJS) \
$(patsubst %.c,%.o,$(filter %.c,$(libgnu_a_SOURCES)))
-libegnu_a_OBJECTS = $(patsubst %.o,e-%.o,$(libgnu_a_OBJECTS))
+for_emacs_OBJECTS = $(filter-out $(not_emacs_OBJECTS),$(libgnu_a_OBJECTS))
+libegnu_a_OBJECTS = $(patsubst %.o,e-%.o,$(for_emacs_OBJECTS))
$(libegnu_a_OBJECTS) $(libgnu_a_OBJECTS): $(BUILT_SOURCES)
@@ -112,7 +118,7 @@ TAGS: $(ETAGS) $(tagsfiles)
.PHONY: $(ETAGS) tags
clean:
- rm -f *.[ao] *-t \#* $(DEPDIR)/*
+ rm -f ./*.[ao] ./*-t \#* $(DEPDIR)/*
mostlyclean: clean
rm -f $(filter-out %-t,$(MOSTLYCLEANFILES))
distclean bootstrap-clean: mostlyclean
diff --git a/lib/_Noreturn.h b/lib/_Noreturn.h
index c44ad89b7c0..7594e4b0c0b 100644
--- a/lib/_Noreturn.h
+++ b/lib/_Noreturn.h
@@ -1,8 +1,15 @@
-#if !defined _Noreturn && __STDC_VERSION__ < 201112
-# if (3 <= __GNUC__ || (__GNUC__ == 2 && 8 <= __GNUC_MINOR__) \
- || 0x5110 <= __SUNPRO_C)
+#ifndef _Noreturn
+# if (defined __cplusplus \
+ && ((201103 <= __cplusplus && !(__GNUC__ == 4 && __GNUC_MINOR__ == 7)) \
+ || (defined _MSC_VER && 1900 <= _MSC_VER)))
+# define _Noreturn [[noreturn]]
+# elif ((!defined __cplusplus || defined __clang__) \
+ && (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \
+ || 4 < __GNUC__ + (7 <= __GNUC_MINOR__)))
+ /* _Noreturn works as-is. */
+# elif 2 < __GNUC__ + (8 <= __GNUC_MINOR__) || 0x5110 <= __SUNPRO_C
# define _Noreturn __attribute__ ((__noreturn__))
-# elif 1200 <= _MSC_VER
+# elif 1200 <= (defined _MSC_VER ? _MSC_VER : 0)
# define _Noreturn __declspec (noreturn)
# else
# define _Noreturn
diff --git a/lib/acl-internal.c b/lib/acl-internal.c
index 99ebe811051..cc42183f443 100644
--- a/lib/acl-internal.c
+++ b/lib/acl-internal.c
@@ -23,7 +23,7 @@
#include "acl-internal.h"
-#if USE_ACL && HAVE_ACL_GET_FILE
+#if USE_ACL && HAVE_ACL_GET_FILE /* Linux, FreeBSD, Mac OS X, IRIX, Tru64, Cygwin >= 2.5 */
# if HAVE_ACL_TYPE_EXTENDED /* Mac OS X */
@@ -37,7 +37,7 @@ acl_extended_nontrivial (acl_t acl)
return (acl_entries (acl) > 0);
}
-# else /* Linux, FreeBSD, IRIX, Tru64 */
+# else /* Linux, FreeBSD, IRIX, Tru64, Cygwin >= 2.5 */
/* ACL is an ACL, from a file, stored as type ACL_TYPE_ACCESS.
Return 1 if the given ACL is non-trivial.
@@ -51,7 +51,7 @@ acl_access_nontrivial (acl_t acl)
at least, allowing us to write
return (3 < acl_entries (acl));
but the following code is more robust. */
-# if HAVE_ACL_FIRST_ENTRY /* Linux, FreeBSD */
+# if HAVE_ACL_FIRST_ENTRY /* Linux, FreeBSD, Cygwin >= 2.5 */
acl_entry_t ace;
int got_one;
@@ -124,7 +124,7 @@ acl_default_nontrivial (acl_t acl)
# endif
-#elif USE_ACL && HAVE_FACL && defined GETACL /* Solaris, Cygwin, not HP-UX */
+#elif USE_ACL && HAVE_FACL && defined GETACL /* Solaris, Cygwin < 2.5, not HP-UX */
/* Test an ACL retrieved with GETACL.
Return 1 if the given ACL, consisting of COUNT entries, is non-trivial.
@@ -355,7 +355,7 @@ acl_nontrivial (int count, struct acl_entry *entries)
struct acl_entry *ace = &entries[i];
if (ace->uid != ACL_NSUSER && ace->gid != ACL_NSGROUP)
- return 1;
+ return 1;
}
return 0;
}
@@ -479,7 +479,7 @@ void
free_permission_context (struct permission_context *ctx)
{
#if USE_ACL
-# if HAVE_ACL_GET_FILE /* Linux, FreeBSD, Mac OS X, IRIX, Tru64 */
+# if HAVE_ACL_GET_FILE /* Linux, FreeBSD, Mac OS X, IRIX, Tru64, Cygwin >= 2.5 */
if (ctx->acl)
acl_free (ctx->acl);
# if !HAVE_ACL_TYPE_EXTENDED
@@ -487,7 +487,7 @@ free_permission_context (struct permission_context *ctx)
acl_free (ctx->default_acl);
# endif
-# elif defined GETACL /* Solaris, Cygwin */
+# elif defined GETACL /* Solaris, Cygwin < 2.5 */
free (ctx->entries);
# ifdef ACE_GETACL
free (ctx->ace_entries);
diff --git a/lib/acl-internal.h b/lib/acl-internal.h
index 883f06a3986..05833efaa89 100644
--- a/lib/acl-internal.h
+++ b/lib/acl-internal.h
@@ -30,7 +30,8 @@
# define GETACLCNT ACL_CNT
#endif
-/* On Linux, additional ACL related API is available in <acl/libacl.h>. */
+/* On Linux and Cygwin >= 2.5, additional ACL related API is available in
+ <acl/libacl.h>. */
#ifdef HAVE_ACL_LIBACL_H
# include <acl/libacl.h>
#endif
@@ -72,7 +73,7 @@ _GL_INLINE_HEADER_BEGIN
# if HAVE_ACL_GET_FILE
/* POSIX 1003.1e (draft 17 -- abandoned) specific version. */
-/* Linux, FreeBSD, Mac OS X, IRIX, Tru64 */
+/* Linux, FreeBSD, Mac OS X, IRIX, Tru64, Cygwin >= 2.5 */
# ifndef MIN_ACL_ENTRIES
# define MIN_ACL_ENTRIES 4
@@ -122,7 +123,10 @@ rpl_acl_set_fd (int fd, acl_t acl)
# endif
/* Linux-specific */
-# ifndef HAVE_ACL_EXTENDED_FILE
+/* Cygwin >= 2.5 implements this function, but it returns 1 for all
+ directories, thus is unusable. */
+# if !defined HAVE_ACL_EXTENDED_FILE || defined __CYGWIN__
+# undef HAVE_ACL_EXTENDED_FILE
# define HAVE_ACL_EXTENDED_FILE false
# define acl_extended_file(name) (-1)
# endif
@@ -163,7 +167,7 @@ extern int acl_access_nontrivial (acl_t);
extern int acl_default_nontrivial (acl_t);
# endif
-# elif HAVE_FACL && defined GETACL /* Solaris, Cygwin, not HP-UX */
+# elif HAVE_FACL && defined GETACL /* Solaris, Cygwin < 2.5, not HP-UX */
/* Set to 0 if a file's mode is stored independently from the ACL. */
# if defined __CYGWIN__ /* Cygwin */
@@ -256,14 +260,14 @@ extern int acl_nontrivial (int count, struct acl *entries);
struct permission_context {
mode_t mode;
#if USE_ACL
-# if HAVE_ACL_GET_FILE /* Linux, FreeBSD, Mac OS X, IRIX, Tru64 */
+# if HAVE_ACL_GET_FILE /* Linux, FreeBSD, Mac OS X, IRIX, Tru64, Cygwin >= 2.5 */
acl_t acl;
# if !HAVE_ACL_TYPE_EXTENDED
acl_t default_acl;
# endif
bool acls_not_supported;
-# elif defined GETACL /* Solaris, Cygwin */
+# elif defined GETACL /* Solaris, Cygwin < 2.5 */
int count;
aclent_t *entries;
# ifdef ACE_GETACL
@@ -293,10 +297,6 @@ struct permission_context {
int get_permissions (const char *, int, mode_t, struct permission_context *);
int set_permissions (struct permission_context *, const char *, int);
-void free_permission_context (struct permission_context *)
-#if ! (defined USE_ACL && (HAVE_ACL_GET_FILE || defined GETACL))
- _GL_ATTRIBUTE_CONST
-#endif
- ;
+void free_permission_context (struct permission_context *);
_GL_INLINE_HEADER_END
diff --git a/lib/acl_entries.c b/lib/acl_entries.c
index b58b4db0ee7..19ac3c3bd9f 100644
--- a/lib/acl_entries.c
+++ b/lib/acl_entries.c
@@ -22,7 +22,7 @@
#include "acl-internal.h"
/* This file assumes POSIX-draft like ACLs
- (Linux, FreeBSD, Mac OS X, IRIX, Tru64). */
+ (Linux, FreeBSD, Mac OS X, IRIX, Tru64, Cygwin >= 2.5). */
/* Return the number of entries in ACL.
Return -1 and set errno upon failure to determine it. */
@@ -34,7 +34,7 @@ acl_entries (acl_t acl)
if (acl != NULL)
{
-#if HAVE_ACL_FIRST_ENTRY /* Linux, FreeBSD, Mac OS X */
+#if HAVE_ACL_FIRST_ENTRY /* Linux, FreeBSD, Mac OS X, Cygwin >= 2.5 */
# if HAVE_ACL_TYPE_EXTENDED /* Mac OS X */
/* acl_get_entry returns 0 when it successfully fetches an entry,
and -1/EINVAL at the end. */
@@ -45,7 +45,7 @@ acl_entries (acl_t acl)
got_one >= 0;
got_one = acl_get_entry (acl, ACL_NEXT_ENTRY, &ace))
count++;
-# else /* Linux, FreeBSD */
+# else /* Linux, FreeBSD, Cygwin >= 2.5 */
/* acl_get_entry returns 1 when it successfully fetches an entry,
and 0 at the end. */
acl_entry_t ace;
diff --git a/lib/alloca.in.h b/lib/alloca.in.h
index 0e3622f1b96..a581d58f834 100644
--- a/lib/alloca.in.h
+++ b/lib/alloca.in.h
@@ -1,7 +1,7 @@
/* Memory allocation on the stack.
- Copyright (C) 1995, 1999, 2001-2004, 2006-2019 Free Software
- Foundation, Inc.
+ Copyright (C) 1995, 1999, 2001-2004, 2006-2019 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
@@ -36,6 +36,12 @@
#ifndef alloca
# ifdef __GNUC__
+ /* Some version of mingw have an <alloca.h> that causes trouble when
+ included after 'alloca' gets defined as a macro. As a workaround, include
+ this <alloca.h> first and define 'alloca' as a macro afterwards. */
+# if (defined _WIN32 && ! defined __CYGWIN__) && @HAVE_ALLOCA_H@
+# include_next <alloca.h>
+# endif
# define alloca __builtin_alloca
# elif defined _AIX
# define alloca __alloca
diff --git a/lib/binary-io.h b/lib/binary-io.h
index 763eddba56a..720b08c7551 100644
--- a/lib/binary-io.h
+++ b/lib/binary-io.h
@@ -1,6 +1,5 @@
/* Binary mode I/O.
- Copyright (C) 2001, 2003, 2005, 2008-2019 Free Software Foundation,
- Inc.
+ Copyright (C) 2001, 2003, 2005, 2008-2019 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
@@ -48,10 +47,8 @@ _GL_INLINE_HEADER_BEGIN
/* Use a function rather than a macro, to avoid gcc warnings
"warning: statement with no effect". */
BINARY_IO_INLINE int
-__gl_setmode (int fd, int mode)
+__gl_setmode (int fd _GL_UNUSED, int mode _GL_UNUSED)
{
- (void) fd;
- (void) mode;
return O_BINARY;
}
#endif
@@ -60,7 +57,7 @@ __gl_setmode (int fd, int mode)
extern int __gl_setmode_check (int);
#else
BINARY_IO_INLINE int
-__gl_setmode_check (int fd) { return 0; }
+__gl_setmode_check (int fd _GL_UNUSED) { return 0; }
#endif
/* Set FD's mode to MODE, which should be either O_TEXT or O_BINARY.
diff --git a/lib/c-ctype.h b/lib/c-ctype.h
index d207bd01a18..4d521763843 100644
--- a/lib/c-ctype.h
+++ b/lib/c-ctype.h
@@ -5,8 +5,7 @@
<ctype.h> functions' behaviour depends on the current locale set via
setlocale.
- Copyright (C) 2000-2003, 2006, 2008-2019 Free Software Foundation,
- Inc.
+ Copyright (C) 2000-2003, 2006, 2008-2019 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
diff --git a/lib/c-strcasecmp.c b/lib/c-strcasecmp.c
index 620f87566a8..ec50f1abe76 100644
--- a/lib/c-strcasecmp.c
+++ b/lib/c-strcasecmp.c
@@ -1,6 +1,5 @@
/* c-strcasecmp.c -- case insensitive string comparator in C locale
- Copyright (C) 1998-1999, 2005-2006, 2009-2019 Free Software
- Foundation, Inc.
+ Copyright (C) 1998-1999, 2005-2006, 2009-2019 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
diff --git a/lib/c-strncasecmp.c b/lib/c-strncasecmp.c
index 1d284e62366..513c353f6c2 100644
--- a/lib/c-strncasecmp.c
+++ b/lib/c-strncasecmp.c
@@ -1,6 +1,5 @@
/* c-strncasecmp.c -- case insensitive string comparator in C locale
- Copyright (C) 1998-1999, 2005-2006, 2009-2019 Free Software
- Foundation, Inc.
+ Copyright (C) 1998-1999, 2005-2006, 2009-2019 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
diff --git a/lib/careadlinkat.c b/lib/careadlinkat.c
index ad75bad3083..e56d5030856 100644
--- a/lib/careadlinkat.c
+++ b/lib/careadlinkat.c
@@ -1,7 +1,7 @@
/* Read symbolic links into a buffer without size limitation, relative to fd.
- Copyright (C) 2001, 2003-2004, 2007, 2009-2019 Free Software
- Foundation, Inc.
+ Copyright (C) 2001, 2003-2004, 2007, 2009-2019 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
diff --git a/lib/cdefs.h b/lib/cdefs.h
new file mode 100644
index 00000000000..96d26164199
--- /dev/null
+++ b/lib/cdefs.h
@@ -0,0 +1,514 @@
+/* Copyright (C) 1992-2019 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
+ <https://www.gnu.org/licenses/>. */
+
+#ifndef _SYS_CDEFS_H
+#define _SYS_CDEFS_H 1
+
+/* We are almost always included from features.h. */
+#ifndef _FEATURES_H
+# include <features.h>
+#endif
+
+/* 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. */
+#if defined __GNUC__ && !defined __STDC__
+# error "You need a ISO C conforming compiler to use the glibc headers"
+#endif
+
+/* Some user header file might have defined this before. */
+#undef __P
+#undef __PMT
+
+#ifdef __GNUC__
+
+/* All functions, except those with callbacks or those that
+ synchronize memory, are leaf functions. */
+# if __GNUC_PREREQ (4, 6) && !defined _LIBC
+# define __LEAF , __leaf__
+# define __LEAF_ATTR __attribute__ ((__leaf__))
+# else
+# define __LEAF
+# define __LEAF_ATTR
+# endif
+
+/* GCC can always grok prototypes. For C++ programs we add throw()
+ to help it optimize the function calls. But this works only with
+ gcc 2.8.x and egcs. For gcc 3.2 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, 3)
+# 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)
+# define __THROW throw ()
+# define __THROWNL throw ()
+# define __NTH(fct) __LEAF_ATTR fct throw ()
+# define __NTHNL(fct) fct throw ()
+# else
+# define __THROW
+# define __THROWNL
+# define __NTH(fct) fct
+# define __NTHNL(fct) fct
+# endif
+# endif
+
+#else /* Not GCC. */
+
+# if (defined __cplusplus \
+ || (defined __STDC_VERSION__ && __STDC_VERSION__ >= 199901L))
+# define __inline inline
+# else
+# define __inline /* No inline functions. */
+# endif
+
+# define __THROW
+# define __THROWNL
+# define __NTH(fct) fct
+
+#endif /* GCC. */
+
+/* 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)
+#else
+# define __glibc_clang_has_extension(ext) 0
+#endif
+
+/* These two macros are not used in glibc anymore. They are kept here
+ only because some other projects expect the macros to be defined. */
+#define __P(args) args
+#define __PMT(args) args
+
+/* For these things, GCC behaves the ANSI way normally,
+ and the non-ANSI way under -traditional. */
+
+#define __CONCAT(x,y) x ## y
+#define __STRING(x) #x
+
+/* This is not a typedef so `const __ptr_t' does the right thing. */
+#define __ptr_t void *
+
+
+/* C++ needs to know that types and declarations are C, not C++. */
+#ifdef __cplusplus
+# define __BEGIN_DECLS extern "C" {
+# define __END_DECLS }
+#else
+# define __BEGIN_DECLS
+# define __END_DECLS
+#endif
+
+
+/* Fortify support. */
+#define __bos(ptr) __builtin_object_size (ptr, __USE_FORTIFY_LEVEL > 1)
+#define __bos0(ptr) __builtin_object_size (ptr, 0)
+
+#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)))
+#else
+# define __warndecl(name, msg) extern void name (void)
+# define __warnattr(msg)
+# define __errordecl(name, msg) extern void name (void)
+#endif
+
+/* Support for flexible arrays.
+ Headers that should use flexible arrays only if they're "real"
+ (e.g. only if they won't affect sizeof()) should test
+ #if __glibc_c99_flexarr_available. */
+#if defined __STDC_VERSION__ && __STDC_VERSION__ >= 199901L && !defined __HP_cc
+# define __flexarr []
+# define __glibc_c99_flexarr_available 1
+#elif __GNUC_PREREQ (2,97)
+/* GCC 2.97 supports C99 flexible array members as an extension,
+ even when in C89 mode or compiling C++ (any version). */
+# define __flexarr []
+# define __glibc_c99_flexarr_available 1
+#elif defined __GNUC__
+/* Pre-2.97 GCC did not support C99 flexible arrays but did have
+ an equivalent extension with slightly different notation. */
+# define __flexarr [0]
+# define __glibc_c99_flexarr_available 1
+#else
+/* Some other non-C99 compiler. Approximate with [1]. */
+# define __flexarr [1]
+# define __glibc_c99_flexarr_available 0
+#endif
+
+
+/* __asm__ ("xyz") is used throughout the headers to rename functions
+ at the assembly language level. This is wrapped by the __REDIRECT
+ macro, in order to support compilers that can do this some other
+ way. When compilers don't support asm-names at all, we have to do
+ preprocessor tricks instead (which don't have exactly the right
+ semantics, but it's the best we can do).
+
+ Example:
+ int __REDIRECT(setpgrp, (__pid_t pid, __pid_t pgrp), setpgid); */
+
+#if defined __GNUC__ && __GNUC__ >= 2
+
+# define __REDIRECT(name, proto, alias) name proto __asm__ (__ASMNAME (#alias))
+# ifdef __cplusplus
+# define __REDIRECT_NTH(name, proto, alias) \
+ name proto __THROW __asm__ (__ASMNAME (#alias))
+# define __REDIRECT_NTHNL(name, proto, alias) \
+ name proto __THROWNL __asm__ (__ASMNAME (#alias))
+# else
+# define __REDIRECT_NTH(name, proto, alias) \
+ name proto __asm__ (__ASMNAME (#alias)) __THROW
+# define __REDIRECT_NTHNL(name, proto, alias) \
+ name proto __asm__ (__ASMNAME (#alias)) __THROWNL
+# endif
+# define __ASMNAME(cname) __ASMNAME2 (__USER_LABEL_PREFIX__, cname)
+# define __ASMNAME2(prefix, cname) __STRING (prefix) cname
+
+/*
+#elif __SOME_OTHER_COMPILER__
+
+# define __REDIRECT(name, proto, alias) name proto; \
+ _Pragma("let " #name " = " #alias)
+*/
+#endif
+
+/* GCC has various useful declarations that can be made with the
+ `__attribute__' syntax. All of the ways we use this do fine if
+ they are omitted for compilers that don't understand it. */
+#if !defined __GNUC__ || __GNUC__ < 2
+# define __attribute__(xyz) /* Ignore */
+#endif
+
+/* 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)
+# define __attribute_malloc__ __attribute__ ((__malloc__))
+#else
+# define __attribute_malloc__ /* Ignore */
+#endif
+
+/* Tell the compiler which arguments to an allocation function
+ indicate the size of the allocation. */
+#if __GNUC_PREREQ (4, 3)
+# define __attribute_alloc_size__(params) \
+ __attribute__ ((__alloc_size__ params))
+#else
+# define __attribute_alloc_size__(params) /* Ignore. */
+#endif
+
+/* 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)
+# 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)
+# define __attribute_const__ __attribute__ ((__const__))
+#else
+# define __attribute_const__ /* 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)
+# define __attribute_used__ __attribute__ ((__used__))
+# define __attribute_noinline__ __attribute__ ((__noinline__))
+#else
+# define __attribute_used__ __attribute__ ((__unused__))
+# define __attribute_noinline__ /* Ignore */
+#endif
+
+/* Since version 3.2, gcc allows marking deprecated functions. */
+#if __GNUC_PREREQ (3,2)
+# define __attribute_deprecated__ __attribute__ ((__deprecated__))
+#else
+# define __attribute_deprecated__ /* Ignore */
+#endif
+
+/* 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__)
+# define __attribute_deprecated_msg__(msg) \
+ __attribute__ ((__deprecated__ (msg)))
+#else
+# define __attribute_deprecated_msg__(msg) __attribute_deprecated__
+#endif
+
+/* At some point during the gcc 2.8 development the `format_arg' attribute
+ for functions was introduced. We don't want to use it unconditionally
+ (although this would be possible) since it generates warnings.
+ 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)
+# define __attribute_format_arg__(x) __attribute__ ((__format_arg__ (x)))
+#else
+# define __attribute_format_arg__(x) /* Ignore */
+#endif
+
+/* At some point during the gcc 2.97 development the `strfmon' format
+ 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)
+# define __attribute_format_strfmon__(a,b) \
+ __attribute__ ((__format__ (__strfmon__, a, b)))
+#else
+# define __attribute_format_strfmon__(a,b) /* Ignore */
+#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. */
+#ifndef __nonnull
+# if __GNUC_PREREQ (3,3)
+# define __nonnull(params) __attribute__ ((__nonnull__ params))
+# else
+# define __nonnull(params)
+# endif
+#endif
+
+/* If fortification mode, we warn about unused results of certain
+ function calls which can lead to problems. */
+#if __GNUC_PREREQ (3,4)
+# define __attribute_warn_unused_result__ \
+ __attribute__ ((__warn_unused_result__))
+# if defined __USE_FORTIFY_LEVEL && __USE_FORTIFY_LEVEL > 0
+# define __wur __attribute_warn_unused_result__
+# endif
+#else
+# define __attribute_warn_unused_result__ /* empty */
+#endif
+#ifndef __wur
+# define __wur /* Ignore */
+#endif
+
+/* Forces a function to be always inlined. */
+#if __GNUC_PREREQ (3,2)
+/* 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. */
+# undef __always_inline
+# define __always_inline __inline __attribute__ ((__always_inline__))
+#else
+# undef __always_inline
+# define __always_inline __inline
+#endif
+
+/* 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)
+# define __attribute_artificial__ __attribute__ ((__artificial__))
+#else
+# define __attribute_artificial__ /* Ignore */
+#endif
+
+/* GCC 4.3 and above with -std=c99 or -std=gnu99 implements ISO C99
+ inline semantics, unless -fgnu89-inline is used. Using __GNUC_STDC_INLINE__
+ or __GNUC_GNU_INLINE is not a good enough check for gcc because gcc versions
+ older than 4.3 may define these macros and still not guarantee GNU inlining
+ semantics.
+
+ clang++ identifies itself as gcc-4.2, but has support for GNU inlining
+ semantics, that can be checked for by using the __GNUC_STDC_INLINE_ and
+ __GNUC_GNU_INLINE__ macro definitions. */
+#if (!defined __cplusplus || __GNUC_PREREQ (4,3) \
+ || (defined __clang__ && (defined __GNUC_STDC_INLINE__ \
+ || defined __GNUC_GNU_INLINE__)))
+# if defined __GNUC_STDC_INLINE__ || defined __cplusplus
+# define __extern_inline extern __inline __attribute__ ((__gnu_inline__))
+# define __extern_always_inline \
+ extern __always_inline __attribute__ ((__gnu_inline__))
+# else
+# define __extern_inline extern __inline
+# define __extern_always_inline extern __always_inline
+# endif
+#endif
+
+#ifdef __extern_always_inline
+# define __fortify_function __extern_always_inline __attribute_artificial__
+#endif
+
+/* GCC 4.3 and above allow passing all anonymous arguments of an
+ __extern_always_inline function to some other vararg function. */
+#if __GNUC_PREREQ (4,3)
+# define __va_arg_pack() __builtin_va_arg_pack ()
+# define __va_arg_pack_len() __builtin_va_arg_pack_len ()
+#endif
+
+/* It is possible to compile containing GCC extensions even if GCC is
+ run in pedantic mode if the uses are carefully marked using the
+ `__extension__' keyword. But this is not generally available before
+ version 2.8. */
+#if !__GNUC_PREREQ (2,8)
+# define __extension__ /* Ignore */
+#endif
+
+/* __restrict is known in EGCS 1.2 and above. */
+#if !__GNUC_PREREQ (2,92)
+# if defined __STDC_VERSION__ && __STDC_VERSION__ >= 199901L
+# define __restrict restrict
+# else
+# define __restrict /* Ignore */
+# endif
+#endif
+
+/* ISO C99 also allows to declare arrays as non-overlapping. The syntax is
+ array_name[restrict]
+ GCC 3.1 supports this. */
+#if __GNUC_PREREQ (3,1) && !defined __GNUG__
+# define __restrict_arr __restrict
+#else
+# ifdef __GNUC__
+# define __restrict_arr /* Not supported in old GCC. */
+# else
+# if defined __STDC_VERSION__ && __STDC_VERSION__ >= 199901L
+# define __restrict_arr restrict
+# else
+/* Some other non-C99 compiler. */
+# define __restrict_arr /* Not supported. */
+# endif
+# endif
+#endif
+
+#if __GNUC__ >= 3
+# define __glibc_unlikely(cond) __builtin_expect ((cond), 0)
+# define __glibc_likely(cond) __builtin_expect ((cond), 1)
+#else
+# define __glibc_unlikely(cond) (cond)
+# 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))
+# if __GNUC_PREREQ (2,8)
+# define _Noreturn __attribute__ ((__noreturn__))
+# else
+# define _Noreturn
+# endif
+#endif
+
+#if __GNUC_PREREQ (8, 0)
+/* Describes a char array whose address can safely be passed as the first
+ argument to strncpy and strncat, as the char array is not necessarily
+ a NUL-terminated string. */
+# define __attribute_nonstring__ __attribute__ ((__nonstring__))
+#else
+# define __attribute_nonstring__
+#endif
+
+#if (!defined _Static_assert && !defined __cplusplus \
+ && (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) < 201112 \
+ && (!__GNUC_PREREQ (4, 6) || defined __STRICT_ANSI__))
+# define _Static_assert(expr, diagnostic) \
+ extern int (*__Static_assert_function (void)) \
+ [!!sizeof (struct { int __error_if_negative: (expr) ? 2 : -1; })]
+#endif
+
+/* The #ifndef lets Gnulib avoid including these on non-glibc
+ platforms, where the includes typically do not exist. */
+#ifndef __WORDSIZE
+# include <bits/wordsize.h>
+# include <bits/long-double.h>
+#endif
+
+#if 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)
+# define __LDBL_REDIR(name, proto) \
+ __LDBL_REDIR1 (name, proto, __nldbl_##name)
+# 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_REDIR1_DECL(name, alias) \
+ extern __typeof (name) name __asm (__ASMNAME (#alias));
+# define __LDBL_REDIR_DECL(name) \
+ extern __typeof (name) name __asm (__ASMNAME ("__nldbl_" #name));
+# define __REDIRECT_LDBL(name, proto, alias) \
+ __LDBL_REDIR1 (name, proto, __nldbl_##alias)
+# define __REDIRECT_NTH_LDBL(name, proto, alias) \
+ __LDBL_REDIR1_NTH (name, proto, __nldbl_##alias)
+# endif
+#endif
+#if !defined __LDBL_COMPAT || !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_REDIR_DECL(name)
+# ifdef __REDIRECT
+# define __REDIRECT_LDBL(name, proto, alias) __REDIRECT (name, proto, alias)
+# define __REDIRECT_NTH_LDBL(name, proto, alias) \
+ __REDIRECT_NTH (name, proto, alias)
+# endif
+#endif
+
+/* __glibc_macro_warning (MESSAGE) issues warning MESSAGE. This is
+ intended for use in preprocessor macros.
+
+ Note: MESSAGE must be a _single_ string; concatenation of string
+ literals is not supported. */
+#if __GNUC_PREREQ (4,8) || __glibc_clang_prereq (3,5)
+# define __glibc_macro_warning1(message) _Pragma (#message)
+# define __glibc_macro_warning(message) \
+ __glibc_macro_warning1 (GCC warning message)
+#else
+# define __glibc_macro_warning(msg)
+#endif
+
+/* Generic selection (ISO C11) is a C-only feature, available in GCC
+ since version 4.9. Previous versions do not provide generic
+ selection, even though they might set __STDC_VERSION__ to 201112L,
+ when in -std=c11 mode. Thus, we must check for !defined __GNUC__
+ when testing __STDC_VERSION__ for generic selection support.
+ On the other hand, Clang also defines __GNUC__, so a clang-specific
+ check is required to enable the use of generic selection. */
+#if !defined __cplusplus \
+ && (__GNUC_PREREQ (4, 9) \
+ || __glibc_clang_has_extension (c_generic_selections) \
+ || (!defined __GNUC__ && defined __STDC_VERSION__ \
+ && __STDC_VERSION__ >= 201112L))
+# define __HAVE_GENERIC_SELECTION 1
+#else
+# define __HAVE_GENERIC_SELECTION 0
+#endif
+
+#endif /* sys/cdefs.h */
diff --git a/lib/cloexec.c b/lib/cloexec.c
index 2b31d26efd6..db425766a0e 100644
--- a/lib/cloexec.c
+++ b/lib/cloexec.c
@@ -1,7 +1,6 @@
/* cloexec.c - set or clear the close-on-exec descriptor flag
- Copyright (C) 1991, 2004-2006, 2009-2019 Free Software Foundation,
- Inc.
+ Copyright (C) 1991, 2004-2006, 2009-2019 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
diff --git a/lib/close-stream.c b/lib/close-stream.c
index 6de923af69f..5458c4f29f3 100644
--- a/lib/close-stream.c
+++ b/lib/close-stream.c
@@ -1,7 +1,6 @@
/* Close a stream, with nicer error checking than fclose's.
- Copyright (C) 1998-2002, 2004, 2006-2019 Free Software Foundation,
- Inc.
+ Copyright (C) 1998-2002, 2004, 2006-2019 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
diff --git a/lib/diffseq.h b/lib/diffseq.h
index 88a6c4d7ada..c6aac3d8120 100644
--- a/lib/diffseq.h
+++ b/lib/diffseq.h
@@ -1,7 +1,7 @@
/* Analyze differences between two vectors.
- Copyright (C) 1988-1989, 1992-1995, 2001-2004, 2006-2019 Free
- Software Foundation, Inc.
+ Copyright (C) 1988-1989, 1992-1995, 2001-2004, 2006-2019 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
diff --git a/lib/dosname.h b/lib/dosname.h
index 3aaf104c6ca..c0ab6848a58 100644
--- a/lib/dosname.h
+++ b/lib/dosname.h
@@ -1,7 +1,6 @@
/* File names on MS-DOS/Windows systems.
- Copyright (C) 2000-2001, 2004-2006, 2009-2019 Free Software
- Foundation, Inc.
+ Copyright (C) 2000-2001, 2004-2006, 2009-2019 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
@@ -21,9 +20,8 @@
#ifndef _DOSNAME_H
#define _DOSNAME_H
-#if (defined _WIN32 || defined __WIN32__ || \
- defined __MSDOS__ || defined __CYGWIN__ || \
- defined __EMX__ || defined __DJGPP__)
+#if (defined _WIN32 || defined __CYGWIN__ \
+ || defined __EMX__ || defined __MSDOS__ || defined __DJGPP__)
/* This internal macro assumes ASCII, but all hosts that support drive
letters use ASCII. */
# define _IS_DRIVE_LETTER(C) (((unsigned int) (C) | ('a' - 'A')) - 'a' \
diff --git a/lib/dtotimespec.c b/lib/dtotimespec.c
index 65aae10b56e..a8ff04a9859 100644
--- a/lib/dtotimespec.c
+++ b/lib/dtotimespec.c
@@ -32,20 +32,20 @@ dtotimespec (double sec)
if (! (TYPE_MINIMUM (time_t) < sec))
return make_timespec (TYPE_MINIMUM (time_t), 0);
else if (! (sec < 1.0 + TYPE_MAXIMUM (time_t)))
- return make_timespec (TYPE_MAXIMUM (time_t), TIMESPEC_RESOLUTION - 1);
+ return make_timespec (TYPE_MAXIMUM (time_t), TIMESPEC_HZ - 1);
else
{
time_t s = sec;
- double frac = TIMESPEC_RESOLUTION * (sec - s);
+ double frac = TIMESPEC_HZ * (sec - s);
long ns = frac;
ns += ns < frac;
- s += ns / TIMESPEC_RESOLUTION;
- ns %= TIMESPEC_RESOLUTION;
+ s += ns / TIMESPEC_HZ;
+ ns %= TIMESPEC_HZ;
if (ns < 0)
{
s--;
- ns += TIMESPEC_RESOLUTION;
+ ns += TIMESPEC_HZ;
}
return make_timespec (s, ns);
diff --git a/lib/dup2.c b/lib/dup2.c
index 583417c0eec..d3aafa458b5 100644
--- a/lib/dup2.c
+++ b/lib/dup2.c
@@ -1,7 +1,6 @@
/* Duplicate an open file descriptor to a specified file descriptor.
- Copyright (C) 1999, 2004-2007, 2009-2019 Free Software Foundation,
- Inc.
+ Copyright (C) 1999, 2004-2007, 2009-2019 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
@@ -30,7 +29,7 @@
# undef dup2
-# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+# if defined _WIN32 && ! defined __CYGWIN__
/* Get declarations of the native Windows API functions. */
# define WIN32_LEAN_AND_MEAN
diff --git a/lib/errno.in.h b/lib/errno.in.h
index 3bc064602d5..3bd27f1cc9f 100644
--- a/lib/errno.in.h
+++ b/lib/errno.in.h
@@ -30,7 +30,7 @@
/* On native Windows platforms, many macros are not defined. */
-# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+# if defined _WIN32 && ! defined __CYGWIN__
/* These are the same values as defined by MSVC 10, for interoperability. */
@@ -248,7 +248,7 @@
interoperability. */
# define EOWNERDEAD 58
# define ENOTRECOVERABLE 59
-# elif (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+# elif defined _WIN32 && ! defined __CYGWIN__
/* We have a conflict here: pthreads-win32 defines these values
differently than MSVC 10. It's hairy to decide which one to use. */
# if defined __MINGW32__ && !defined USE_WINDOWS_THREADS
diff --git a/lib/euidaccess.c b/lib/euidaccess.c
index c7b057b792e..fece4cfc5e0 100644
--- a/lib/euidaccess.c
+++ b/lib/euidaccess.c
@@ -29,8 +29,11 @@
#include <sys/types.h>
#include <sys/stat.h>
#include <unistd.h>
-
-#include "root-uid.h"
+#if defined _WIN32 && ! defined __CYGWIN__
+# include <io.h>
+#else
+# include "root-uid.h"
+#endif
#if HAVE_LIBGEN_H
# include <libgen.h>
@@ -84,7 +87,9 @@ euidaccess (const char *file, int mode)
return accessx (file, mode, ACC_SELF);
#elif HAVE_EACCESS /* FreeBSD */
return eaccess (file, mode);
-#else /* Mac OS X, NetBSD, OpenBSD, HP-UX, Solaris, Cygwin, mingw, BeOS */
+#elif defined _WIN32 && ! defined __CYGWIN__ /* mingw */
+ return _access (file, mode);
+#else /* Mac OS X, NetBSD, OpenBSD, HP-UX, Solaris, Cygwin, BeOS */
uid_t uid = getuid ();
gid_t gid = getgid ();
diff --git a/lib/explicit_bzero.c b/lib/explicit_bzero.c
index a4abc337b59..79ef1860fb7 100644
--- a/lib/explicit_bzero.c
+++ b/lib/explicit_bzero.c
@@ -27,9 +27,11 @@
#include <string.h>
+#if _LIBC
/* glibc-internal users use __explicit_bzero_chk, and explicit_bzero
redirects to that. */
-#undef explicit_bzero
+# undef explicit_bzero
+#endif
/* Set LEN bytes of S to 0. The compiler will not delete a call to
this function, even if S is dead after the call. */
diff --git a/lib/fcntl.c b/lib/fcntl.c
index 06d8e51f4b9..51f62ef78a8 100644
--- a/lib/fcntl.c
+++ b/lib/fcntl.c
@@ -27,12 +27,12 @@
#include <stdarg.h>
#include <unistd.h>
-#if !HAVE_FCNTL
-# define rpl_fcntl fcntl
+#ifdef __KLIBC__
+# define INCL_DOS
+# include <os2.h>
#endif
-#undef fcntl
-#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+#if defined _WIN32 && ! defined __CYGWIN__
/* Get declarations of the native Windows API functions. */
# define WIN32_LEAN_AND_MEAN
# include <windows.h>
@@ -166,93 +166,18 @@ dupfd (int oldfd, int newfd, int flags)
}
#endif /* W32 */
+/* Forward declarations, because we '#undef fcntl' in the middle of this
+ compilation unit. */
+/* Our implementation of fcntl (fd, F_DUPFD, target). */
+static int rpl_fcntl_DUPFD (int fd, int target);
+/* Our implementation of fcntl (fd, F_DUPFD_CLOEXEC, target). */
+static int rpl_fcntl_DUPFD_CLOEXEC (int fd, int target);
#ifdef __KLIBC__
-
-# define INCL_DOS
-# include <os2.h>
-
-static int
-klibc_fcntl (int fd, int action, /* arg */...)
-{
- va_list arg_ptr;
- int arg;
- struct stat sbuf;
- int result = -1;
-
- va_start (arg_ptr, action);
- arg = va_arg (arg_ptr, int);
- result = fcntl (fd, action, arg);
- /* EPERM for F_DUPFD, ENOTSUP for others */
- if (result == -1 && (errno == EPERM || errno == ENOTSUP)
- && !fstat (fd, &sbuf) && S_ISDIR (sbuf.st_mode))
- {
- ULONG ulMode;
-
- switch (action)
- {
- case F_DUPFD:
- /* Find available fd */
- while (fcntl (arg, F_GETFL) != -1 || errno != EBADF)
- arg++;
-
- result = dup2 (fd, arg);
- break;
-
- /* Using underlying APIs is right ? */
- case F_GETFD:
- if (DosQueryFHState (fd, &ulMode))
- break;
-
- result = (ulMode & OPEN_FLAGS_NOINHERIT) ? FD_CLOEXEC : 0;
- break;
-
- case F_SETFD:
- if (arg & ~FD_CLOEXEC)
- break;
-
- if (DosQueryFHState (fd, &ulMode))
- break;
-
- if (arg & FD_CLOEXEC)
- ulMode |= OPEN_FLAGS_NOINHERIT;
- else
- ulMode &= ~OPEN_FLAGS_NOINHERIT;
-
- /* Filter supported flags. */
- ulMode &= (OPEN_FLAGS_WRITE_THROUGH | OPEN_FLAGS_FAIL_ON_ERROR
- | OPEN_FLAGS_NO_CACHE | OPEN_FLAGS_NOINHERIT);
-
- if (DosSetFHState (fd, ulMode))
- break;
-
- result = 0;
- break;
-
- case F_GETFL:
- result = 0;
- break;
-
- case F_SETFL:
- if (arg != 0)
- break;
-
- result = 0;
- break;
-
- default :
- errno = EINVAL;
- break;
- }
- }
-
- va_end (arg_ptr);
-
- return result;
-}
-
-# define fcntl klibc_fcntl
+/* Adds support for fcntl on directories. */
+static int klibc_fcntl (int fd, int action, /* arg */...);
#endif
+
/* Perform the specified ACTION on the file descriptor FD, possibly
using the argument ARG further described below. This replacement
handles the following actions, and forwards all others on to the
@@ -273,110 +198,35 @@ klibc_fcntl (int fd, int action, /* arg */...)
return -1 and set errno. */
int
-rpl_fcntl (int fd, int action, /* arg */...)
+fcntl (int fd, int action, /* arg */...)
+#undef fcntl
+#ifdef __KLIBC__
+# define fcntl klibc_fcntl
+#endif
{
va_list arg;
int result = -1;
va_start (arg, action);
switch (action)
{
-
-#if !HAVE_FCNTL
case F_DUPFD:
{
int target = va_arg (arg, int);
- result = dupfd (fd, target, 0);
+ result = rpl_fcntl_DUPFD (fd, target);
break;
}
-#elif FCNTL_DUPFD_BUGGY || REPLACE_FCHDIR
- case F_DUPFD:
- {
- int target = va_arg (arg, int);
- /* Detect invalid target; needed for cygwin 1.5.x. */
- if (target < 0 || getdtablesize () <= target)
- errno = EINVAL;
- else
- {
- /* Haiku alpha 2 loses fd flags on original. */
- int flags = fcntl (fd, F_GETFD);
- if (flags < 0)
- {
- result = -1;
- break;
- }
- result = fcntl (fd, action, target);
- if (0 <= result && fcntl (fd, F_SETFD, flags) == -1)
- {
- int saved_errno = errno;
- close (result);
- result = -1;
- errno = saved_errno;
- }
-# if REPLACE_FCHDIR
- if (0 <= result)
- result = _gl_register_dup (fd, result);
-# endif
- }
- break;
- } /* F_DUPFD */
-#endif /* FCNTL_DUPFD_BUGGY || REPLACE_FCHDIR */
case F_DUPFD_CLOEXEC:
{
int target = va_arg (arg, int);
-
-#if !HAVE_FCNTL
- result = dupfd (fd, target, O_CLOEXEC);
- break;
-#else /* HAVE_FCNTL */
- /* Try the system call first, if the headers claim it exists
- (that is, if GNULIB_defined_F_DUPFD_CLOEXEC is 0), since we
- may be running with a glibc that has the macro but with an
- older kernel that does not support it. Cache the
- information on whether the system call really works, but
- avoid caching failure if the corresponding F_DUPFD fails
- for any reason. 0 = unknown, 1 = yes, -1 = no. */
- static int have_dupfd_cloexec = GNULIB_defined_F_DUPFD_CLOEXEC ? -1 : 0;
- if (0 <= have_dupfd_cloexec)
- {
- result = fcntl (fd, action, target);
- if (0 <= result || errno != EINVAL)
- {
- have_dupfd_cloexec = 1;
-# if REPLACE_FCHDIR
- if (0 <= result)
- result = _gl_register_dup (fd, result);
-# endif
- }
- else
- {
- result = rpl_fcntl (fd, F_DUPFD, target);
- if (result < 0)
- break;
- have_dupfd_cloexec = -1;
- }
- }
- else
- result = rpl_fcntl (fd, F_DUPFD, target);
- if (0 <= result && have_dupfd_cloexec == -1)
- {
- int flags = fcntl (result, F_GETFD);
- if (flags < 0 || fcntl (result, F_SETFD, flags | FD_CLOEXEC) == -1)
- {
- int saved_errno = errno;
- close (result);
- errno = saved_errno;
- result = -1;
- }
- }
+ result = rpl_fcntl_DUPFD_CLOEXEC (fd, target);
break;
-#endif /* HAVE_FCNTL */
- } /* F_DUPFD_CLOEXEC */
+ }
#if !HAVE_FCNTL
case F_GETFD:
{
-# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+# if defined _WIN32 && ! defined __CYGWIN__
HANDLE handle = (HANDLE) _get_osfhandle (fd);
DWORD flags;
if (handle == INVALID_HANDLE_VALUE
@@ -405,8 +255,183 @@ rpl_fcntl (int fd, int action, /* arg */...)
default:
{
#if HAVE_FCNTL
- void *p = va_arg (arg, void *);
- result = fcntl (fd, action, p);
+ switch (action)
+ {
+ #ifdef F_BARRIERFSYNC /* macOS */
+ case F_BARRIERFSYNC:
+ #endif
+ #ifdef F_CHKCLEAN /* macOS */
+ case F_CHKCLEAN:
+ #endif
+ #ifdef F_CLOSEM /* NetBSD, HP-UX */
+ case F_CLOSEM:
+ #endif
+ #ifdef F_FLUSH_DATA /* macOS */
+ case F_FLUSH_DATA:
+ #endif
+ #ifdef F_FREEZE_FS /* macOS */
+ case F_FREEZE_FS:
+ #endif
+ #ifdef F_FULLFSYNC /* macOS */
+ case F_FULLFSYNC:
+ #endif
+ #ifdef F_GETCONFINED /* macOS */
+ case F_GETCONFINED:
+ #endif
+ #ifdef F_GETDEFAULTPROTLEVEL /* macOS */
+ case F_GETDEFAULTPROTLEVEL:
+ #endif
+ #ifdef F_GETFD /* POSIX */
+ case F_GETFD:
+ #endif
+ #ifdef F_GETFL /* POSIX */
+ case F_GETFL:
+ #endif
+ #ifdef F_GETLEASE /* Linux */
+ case F_GETLEASE:
+ #endif
+ #ifdef F_GETNOSIGPIPE /* macOS */
+ case F_GETNOSIGPIPE:
+ #endif
+ #ifdef F_GETOWN /* POSIX */
+ case F_GETOWN:
+ #endif
+ #ifdef F_GETPIPE_SZ /* Linux */
+ case F_GETPIPE_SZ:
+ #endif
+ #ifdef F_GETPROTECTIONCLASS /* macOS */
+ case F_GETPROTECTIONCLASS:
+ #endif
+ #ifdef F_GETPROTECTIONLEVEL /* macOS */
+ case F_GETPROTECTIONLEVEL:
+ #endif
+ #ifdef F_GET_SEALS /* Linux */
+ case F_GET_SEALS:
+ #endif
+ #ifdef F_GETSIG /* Linux */
+ case F_GETSIG:
+ #endif
+ #ifdef F_MAXFD /* NetBSD */
+ case F_MAXFD:
+ #endif
+ #ifdef F_RECYCLE /* macOS */
+ case F_RECYCLE:
+ #endif
+ #ifdef F_SETFIFOENH /* HP-UX */
+ case F_SETFIFOENH:
+ #endif
+ #ifdef F_THAW_FS /* macOS */
+ case F_THAW_FS:
+ #endif
+ /* These actions take no argument. */
+ result = fcntl (fd, action);
+ break;
+
+ #ifdef F_ADD_SEALS /* Linux */
+ case F_ADD_SEALS:
+ #endif
+ #ifdef F_BADFD /* Solaris */
+ case F_BADFD:
+ #endif
+ #ifdef F_CHECK_OPENEVT /* macOS */
+ case F_CHECK_OPENEVT:
+ #endif
+ #ifdef F_DUP2FD /* FreeBSD, AIX, Solaris */
+ case F_DUP2FD:
+ #endif
+ #ifdef F_DUP2FD_CLOEXEC /* FreeBSD, Solaris */
+ case F_DUP2FD_CLOEXEC:
+ #endif
+ #ifdef F_DUP2FD_CLOFORK /* Solaris */
+ case F_DUP2FD_CLOFORK:
+ #endif
+ #ifdef F_DUPFD /* POSIX */
+ case F_DUPFD:
+ #endif
+ #ifdef F_DUPFD_CLOEXEC /* POSIX */
+ case F_DUPFD_CLOEXEC:
+ #endif
+ #ifdef F_DUPFD_CLOFORK /* Solaris */
+ case F_DUPFD_CLOFORK:
+ #endif
+ #ifdef F_GETXFL /* Solaris */
+ case F_GETXFL:
+ #endif
+ #ifdef F_GLOBAL_NOCACHE /* macOS */
+ case F_GLOBAL_NOCACHE:
+ #endif
+ #ifdef F_MAKECOMPRESSED /* macOS */
+ case F_MAKECOMPRESSED:
+ #endif
+ #ifdef F_MOVEDATAEXTENTS /* macOS */
+ case F_MOVEDATAEXTENTS:
+ #endif
+ #ifdef F_NOCACHE /* macOS */
+ case F_NOCACHE:
+ #endif
+ #ifdef F_NODIRECT /* macOS */
+ case F_NODIRECT:
+ #endif
+ #ifdef F_NOTIFY /* Linux */
+ case F_NOTIFY:
+ #endif
+ #ifdef F_OPLKACK /* IRIX */
+ case F_OPLKACK:
+ #endif
+ #ifdef F_OPLKREG /* IRIX */
+ case F_OPLKREG:
+ #endif
+ #ifdef F_RDAHEAD /* macOS */
+ case F_RDAHEAD:
+ #endif
+ #ifdef F_SETBACKINGSTORE /* macOS */
+ case F_SETBACKINGSTORE:
+ #endif
+ #ifdef F_SETCONFINED /* macOS */
+ case F_SETCONFINED:
+ #endif
+ #ifdef F_SETFD /* POSIX */
+ case F_SETFD:
+ #endif
+ #ifdef F_SETFL /* POSIX */
+ case F_SETFL:
+ #endif
+ #ifdef F_SETLEASE /* Linux */
+ case F_SETLEASE:
+ #endif
+ #ifdef F_SETNOSIGPIPE /* macOS */
+ case F_SETNOSIGPIPE:
+ #endif
+ #ifdef F_SETOWN /* POSIX */
+ case F_SETOWN:
+ #endif
+ #ifdef F_SETPIPE_SZ /* Linux */
+ case F_SETPIPE_SZ:
+ #endif
+ #ifdef F_SETPROTECTIONCLASS /* macOS */
+ case F_SETPROTECTIONCLASS:
+ #endif
+ #ifdef F_SETSIG /* Linux */
+ case F_SETSIG:
+ #endif
+ #ifdef F_SINGLE_WRITER /* macOS */
+ case F_SINGLE_WRITER:
+ #endif
+ /* These actions take an 'int' argument. */
+ {
+ int x = va_arg (arg, int);
+ result = fcntl (fd, action, x);
+ }
+ break;
+
+ default:
+ /* Other actions take a pointer argument. */
+ {
+ void *p = va_arg (arg, void *);
+ result = fcntl (fd, action, p);
+ }
+ break;
+ }
#else
errno = EINVAL;
#endif
@@ -416,3 +441,186 @@ rpl_fcntl (int fd, int action, /* arg */...)
va_end (arg);
return result;
}
+
+static int
+rpl_fcntl_DUPFD (int fd, int target)
+{
+ int result;
+#if !HAVE_FCNTL
+ result = dupfd (fd, target, 0);
+#elif FCNTL_DUPFD_BUGGY || REPLACE_FCHDIR
+ /* Detect invalid target; needed for cygwin 1.5.x. */
+ if (target < 0 || getdtablesize () <= target)
+ {
+ result = -1;
+ errno = EINVAL;
+ }
+ else
+ {
+ /* Haiku alpha 2 loses fd flags on original. */
+ int flags = fcntl (fd, F_GETFD);
+ if (flags < 0)
+ result = -1;
+ else
+ {
+ result = fcntl (fd, F_DUPFD, target);
+ if (0 <= result && fcntl (fd, F_SETFD, flags) == -1)
+ {
+ int saved_errno = errno;
+ close (result);
+ result = -1;
+ errno = saved_errno;
+ }
+# if REPLACE_FCHDIR
+ if (0 <= result)
+ result = _gl_register_dup (fd, result);
+# endif
+ }
+ }
+#else
+ result = fcntl (fd, F_DUPFD, target);
+#endif
+ return result;
+}
+
+static int
+rpl_fcntl_DUPFD_CLOEXEC (int fd, int target)
+{
+ int result;
+#if !HAVE_FCNTL
+ result = dupfd (fd, target, O_CLOEXEC);
+#else /* HAVE_FCNTL */
+# if defined __HAIKU__
+ /* On Haiku, the system fcntl (fd, F_DUPFD_CLOEXEC, target) sets
+ the FD_CLOEXEC flag on fd, not on target. Therefore avoid the
+ system fcntl in this case. */
+# define have_dupfd_cloexec -1
+# else
+ /* Try the system call first, if the headers claim it exists
+ (that is, if GNULIB_defined_F_DUPFD_CLOEXEC is 0), since we
+ may be running with a glibc that has the macro but with an
+ older kernel that does not support it. Cache the
+ information on whether the system call really works, but
+ avoid caching failure if the corresponding F_DUPFD fails
+ for any reason. 0 = unknown, 1 = yes, -1 = no. */
+ static int have_dupfd_cloexec = GNULIB_defined_F_DUPFD_CLOEXEC ? -1 : 0;
+ if (0 <= have_dupfd_cloexec)
+ {
+ result = fcntl (fd, F_DUPFD_CLOEXEC, target);
+ if (0 <= result || errno != EINVAL)
+ {
+ have_dupfd_cloexec = 1;
+# if REPLACE_FCHDIR
+ if (0 <= result)
+ result = _gl_register_dup (fd, result);
+# endif
+ }
+ else
+ {
+ result = rpl_fcntl_DUPFD (fd, target);
+ if (result >= 0)
+ have_dupfd_cloexec = -1;
+ }
+ }
+ else
+# endif
+ result = rpl_fcntl_DUPFD (fd, target);
+ if (0 <= result && have_dupfd_cloexec == -1)
+ {
+ int flags = fcntl (result, F_GETFD);
+ if (flags < 0 || fcntl (result, F_SETFD, flags | FD_CLOEXEC) == -1)
+ {
+ int saved_errno = errno;
+ close (result);
+ errno = saved_errno;
+ result = -1;
+ }
+ }
+#endif /* HAVE_FCNTL */
+ return result;
+}
+
+#undef fcntl
+
+#ifdef __KLIBC__
+
+static int
+klibc_fcntl (int fd, int action, /* arg */...)
+{
+ va_list arg_ptr;
+ int arg;
+ struct stat sbuf;
+ int result;
+
+ va_start (arg_ptr, action);
+ arg = va_arg (arg_ptr, int);
+ result = fcntl (fd, action, arg);
+ /* EPERM for F_DUPFD, ENOTSUP for others */
+ if (result == -1 && (errno == EPERM || errno == ENOTSUP)
+ && !fstat (fd, &sbuf) && S_ISDIR (sbuf.st_mode))
+ {
+ ULONG ulMode;
+
+ switch (action)
+ {
+ case F_DUPFD:
+ /* Find available fd */
+ while (fcntl (arg, F_GETFL) != -1 || errno != EBADF)
+ arg++;
+
+ result = dup2 (fd, arg);
+ break;
+
+ /* Using underlying APIs is right ? */
+ case F_GETFD:
+ if (DosQueryFHState (fd, &ulMode))
+ break;
+
+ result = (ulMode & OPEN_FLAGS_NOINHERIT) ? FD_CLOEXEC : 0;
+ break;
+
+ case F_SETFD:
+ if (arg & ~FD_CLOEXEC)
+ break;
+
+ if (DosQueryFHState (fd, &ulMode))
+ break;
+
+ if (arg & FD_CLOEXEC)
+ ulMode |= OPEN_FLAGS_NOINHERIT;
+ else
+ ulMode &= ~OPEN_FLAGS_NOINHERIT;
+
+ /* Filter supported flags. */
+ ulMode &= (OPEN_FLAGS_WRITE_THROUGH | OPEN_FLAGS_FAIL_ON_ERROR
+ | OPEN_FLAGS_NO_CACHE | OPEN_FLAGS_NOINHERIT);
+
+ if (DosSetFHState (fd, ulMode))
+ break;
+
+ result = 0;
+ break;
+
+ case F_GETFL:
+ result = 0;
+ break;
+
+ case F_SETFL:
+ if (arg != 0)
+ break;
+
+ result = 0;
+ break;
+
+ default:
+ errno = EINVAL;
+ break;
+ }
+ }
+
+ va_end (arg_ptr);
+
+ return result;
+}
+
+#endif
diff --git a/lib/fcntl.in.h b/lib/fcntl.in.h
index 5f17d8f65a1..eb70dc61eca 100644
--- a/lib/fcntl.in.h
+++ b/lib/fcntl.in.h
@@ -68,7 +68,7 @@
/* Native Windows platforms declare open(), creat() in <io.h>. */
#if (@GNULIB_OPEN@ || defined GNULIB_POSIXCHECK) \
- && ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__)
+ && (defined _WIN32 && ! defined __CYGWIN__)
# include <io.h>
#endif
diff --git a/lib/fdatasync.c b/lib/fdatasync.c
deleted file mode 100644
index 9fa93297499..00000000000
--- a/lib/fdatasync.c
+++ /dev/null
@@ -1,27 +0,0 @@
-/* Emulate fdatasync on platforms that lack it.
-
- Copyright (C) 2011-2019 Free Software Foundation, Inc.
-
- This 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.
-
- This 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 this program. If not, see <https://www.gnu.org/licenses/>. */
-
-#include <config.h>
-#include <unistd.h>
-
-int
-fdatasync (int fd)
-{
- /* This does more work than strictly necessary, but is the best we
- can do portably. */
- return fsync (fd);
-}
diff --git a/lib/filemode.h b/lib/filemode.h
index 3a578cb9052..5ae9da0ebe3 100644
--- a/lib/filemode.h
+++ b/lib/filemode.h
@@ -1,7 +1,7 @@
/* Make a string describing file modes.
- Copyright (C) 1998-1999, 2003, 2006, 2009-2019 Free Software
- Foundation, Inc.
+ Copyright (C) 1998-1999, 2003, 2006, 2009-2019 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
diff --git a/lib/fpending.c b/lib/fpending.c
index 8d995e9de85..3c01285bb83 100644
--- a/lib/fpending.c
+++ b/lib/fpending.c
@@ -1,6 +1,6 @@
/* fpending.c -- return the number of pending output bytes on a stream
- Copyright (C) 2000, 2004, 2006-2007, 2009-2019 Free Software
- Foundation, Inc.
+ Copyright (C) 2000, 2004, 2006-2007, 2009-2019 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
@@ -24,6 +24,9 @@
#include "stdio-impl.h"
+/* This file is not used on systems that already have the __fpending function,
+ namely glibc >= 2.2, Solaris >= 7, Android API >= 23. */
+
/* Return the number of pending (aka buffered, unflushed)
bytes on the stream, FP, that is open for writing. */
size_t
@@ -32,7 +35,8 @@ __fpending (FILE *fp)
/* Most systems provide FILE as a struct and the necessary bitmask in
<stdio.h>, because they need it for implementing getc() and putc() as
fast macros. */
-#if defined _IO_ftrylockfile || __GNU_LIBRARY__ == 1 /* GNU libc, BeOS, Haiku, Linux libc5 */
+#if defined _IO_EOF_SEEN || defined _IO_ftrylockfile || __GNU_LIBRARY__ == 1
+ /* GNU libc, BeOS, Haiku, Linux libc5 */
return fp->_IO_write_ptr - fp->_IO_write_base;
#elif defined __sferror || defined __DragonFly__ || defined __ANDROID__
/* FreeBSD, NetBSD, OpenBSD, DragonFly, Mac OS X, Cygwin, Minix 3, Android */
diff --git a/lib/fpending.h b/lib/fpending.h
index 0d77266da4c..097a3ef0717 100644
--- a/lib/fpending.h
+++ b/lib/fpending.h
@@ -1,7 +1,7 @@
/* Declare __fpending.
- Copyright (C) 2000, 2003, 2005-2006, 2009-2019 Free Software
- Foundation, Inc.
+ Copyright (C) 2000, 2003, 2005-2006, 2009-2019 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
diff --git a/lib/fstatat.c b/lib/fstatat.c
index 515b5693991..019d3c61638 100644
--- a/lib/fstatat.c
+++ b/lib/fstatat.c
@@ -36,10 +36,14 @@ orig_fstatat (int fd, char const *filename, struct stat *buf, int flags)
}
#endif
+#ifdef __osf__
/* Write "sys/stat.h" here, not <sys/stat.h>, otherwise OSF/1 5.1 DTK cc
eliminates this include because of the preliminary #include <sys/stat.h>
above. */
-#include "sys/stat.h"
+# include "sys/stat.h"
+#else
+# include <sys/stat.h>
+#endif
#include "stat-time.h"
diff --git a/lib/fsusage.c b/lib/fsusage.c
new file mode 100644
index 00000000000..7ddeb52fc0f
--- /dev/null
+++ b/lib/fsusage.c
@@ -0,0 +1,237 @@
+/* fsusage.c -- return space usage of mounted file systems
+
+ Copyright (C) 1991-1992, 1996, 1998-1999, 2002-2006, 2009-2019 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#include "fsusage.h"
+
+#include <limits.h>
+#include <sys/types.h>
+
+#if STAT_STATVFS || STAT_STATVFS64 /* POSIX 1003.1-2001 (and later) with XSI */
+# include <sys/statvfs.h>
+#else
+/* Don't include backward-compatibility files unless they're needed.
+ Eventually we'd like to remove all this cruft. */
+# include <fcntl.h>
+# include <unistd.h>
+# include <sys/stat.h>
+#if HAVE_SYS_PARAM_H
+# include <sys/param.h>
+#endif
+#if HAVE_SYS_MOUNT_H
+# include <sys/mount.h>
+#endif
+#if HAVE_SYS_VFS_H
+# include <sys/vfs.h>
+#endif
+# if HAVE_SYS_FS_S5PARAM_H /* Fujitsu UXP/V */
+# include <sys/fs/s5param.h>
+# endif
+# if HAVE_SYS_STATFS_H
+# include <sys/statfs.h>
+# endif
+#endif
+
+/* Many space usage primitives use all 1 bits to denote a value that is
+ not applicable or unknown. Propagate this information by returning
+ a uintmax_t value that is all 1 bits if X is all 1 bits, even if X
+ is unsigned and narrower than uintmax_t. */
+#define PROPAGATE_ALL_ONES(x) \
+ ((sizeof (x) < sizeof (uintmax_t) \
+ && (~ (x) == (sizeof (x) < sizeof (int) \
+ ? - (1 << (sizeof (x) * CHAR_BIT)) \
+ : 0))) \
+ ? UINTMAX_MAX : (uintmax_t) (x))
+
+/* Extract the top bit of X as an uintmax_t value. */
+#define EXTRACT_TOP_BIT(x) ((x) \
+ & ((uintmax_t) 1 << (sizeof (x) * CHAR_BIT - 1)))
+
+/* If a value is negative, many space usage primitives store it into an
+ integer variable by assignment, even if the variable's type is unsigned.
+ So, if a space usage variable X's top bit is set, convert X to the
+ uintmax_t value V such that (- (uintmax_t) V) is the negative of
+ the original value. If X's top bit is clear, just yield X.
+ Use PROPAGATE_TOP_BIT if the original value might be negative;
+ otherwise, use PROPAGATE_ALL_ONES. */
+#define PROPAGATE_TOP_BIT(x) ((x) | ~ (EXTRACT_TOP_BIT (x) - 1))
+
+#ifdef STAT_STATVFS
+/* Return true if statvfs works. This is false for statvfs on systems
+ with GNU libc on Linux kernels before 2.6.36, which stats all
+ preceding entries in /proc/mounts; that makes df hang if even one
+ of the corresponding file systems is hard-mounted but not available. */
+# if ! (__linux__ && (__GLIBC__ || __UCLIBC__))
+/* The FRSIZE fallback is not required in this case. */
+# undef STAT_STATFS2_FRSIZE
+static int statvfs_works (void) { return 1; }
+# else
+# include <string.h> /* for strverscmp */
+# include <sys/utsname.h>
+# include <sys/statfs.h>
+# define STAT_STATFS2_BSIZE 1
+
+static int
+statvfs_works (void)
+{
+ static int statvfs_works_cache = -1;
+ struct utsname name;
+ if (statvfs_works_cache < 0)
+ statvfs_works_cache = (uname (&name) == 0
+ && 0 <= strverscmp (name.release, "2.6.36"));
+ return statvfs_works_cache;
+}
+# endif
+#endif
+
+
+/* Fill in the fields of FSP with information about space usage for
+ the file system on which FILE resides.
+ DISK is the device on which FILE is mounted, for space-getting
+ methods that need to know it.
+ Return 0 if successful, -1 if not. When returning -1, ensure that
+ ERRNO is either a system error value, or zero if DISK is NULL
+ on a system that requires a non-NULL value. */
+int
+get_fs_usage (char const *file, char const *disk, struct fs_usage *fsp)
+{
+#ifdef STAT_STATVFS /* POSIX, except pre-2.6.36 glibc/Linux */
+
+ if (statvfs_works ())
+ {
+ struct statvfs vfsd;
+
+ if (statvfs (file, &vfsd) < 0)
+ return -1;
+
+ /* f_frsize isn't guaranteed to be supported. */
+ fsp->fsu_blocksize = (vfsd.f_frsize
+ ? PROPAGATE_ALL_ONES (vfsd.f_frsize)
+ : PROPAGATE_ALL_ONES (vfsd.f_bsize));
+
+ fsp->fsu_blocks = PROPAGATE_ALL_ONES (vfsd.f_blocks);
+ fsp->fsu_bfree = PROPAGATE_ALL_ONES (vfsd.f_bfree);
+ fsp->fsu_bavail = PROPAGATE_TOP_BIT (vfsd.f_bavail);
+ fsp->fsu_bavail_top_bit_set = EXTRACT_TOP_BIT (vfsd.f_bavail) != 0;
+ fsp->fsu_files = PROPAGATE_ALL_ONES (vfsd.f_files);
+ fsp->fsu_ffree = PROPAGATE_ALL_ONES (vfsd.f_ffree);
+ return 0;
+ }
+
+#endif
+
+#if defined STAT_STATVFS64 /* AIX */
+
+ struct statvfs64 fsd;
+
+ if (statvfs64 (file, &fsd) < 0)
+ return -1;
+
+ /* f_frsize isn't guaranteed to be supported. */
+ fsp->fsu_blocksize = (fsd.f_frsize
+ ? PROPAGATE_ALL_ONES (fsd.f_frsize)
+ : PROPAGATE_ALL_ONES (fsd.f_bsize));
+
+#elif defined STAT_STATFS3_OSF1 /* OSF/1 */
+
+ struct statfs fsd;
+
+ if (statfs (file, &fsd, sizeof (struct statfs)) != 0)
+ return -1;
+
+ fsp->fsu_blocksize = PROPAGATE_ALL_ONES (fsd.f_fsize);
+
+#elif defined STAT_STATFS2_FRSIZE /* 2.6 < glibc/Linux < 2.6.36 */
+
+ struct statfs fsd;
+
+ if (statfs (file, &fsd) < 0)
+ return -1;
+
+ fsp->fsu_blocksize = PROPAGATE_ALL_ONES (fsd.f_frsize);
+
+#elif defined STAT_STATFS2_BSIZE /* glibc/Linux < 2.6, 4.3BSD, SunOS 4, \
+ Mac OS X < 10.4, FreeBSD < 5.0, \
+ NetBSD < 3.0, OpenBSD < 4.4 */
+
+ struct statfs fsd;
+
+ if (statfs (file, &fsd) < 0)
+ return -1;
+
+ fsp->fsu_blocksize = PROPAGATE_ALL_ONES (fsd.f_bsize);
+
+# ifdef STATFS_TRUNCATES_BLOCK_COUNTS
+
+ /* In SunOS 4.1.2, 4.1.3, and 4.1.3_U1, the block counts in the
+ struct statfs are truncated to 2GB. These conditions detect that
+ truncation, presumably without botching the 4.1.1 case, in which
+ the values are not truncated. The correct counts are stored in
+ undocumented spare fields. */
+ if (fsd.f_blocks == 0x7fffffff / fsd.f_bsize && fsd.f_spare[0] > 0)
+ {
+ fsd.f_blocks = fsd.f_spare[0];
+ fsd.f_bfree = fsd.f_spare[1];
+ fsd.f_bavail = fsd.f_spare[2];
+ }
+# endif /* STATFS_TRUNCATES_BLOCK_COUNTS */
+
+#elif defined STAT_STATFS2_FSIZE /* 4.4BSD and older NetBSD */
+
+ struct statfs fsd;
+
+ if (statfs (file, &fsd) < 0)
+ return -1;
+
+ fsp->fsu_blocksize = PROPAGATE_ALL_ONES (fsd.f_fsize);
+
+#elif defined STAT_STATFS4 /* SVR3, old Irix */
+
+ struct statfs fsd;
+
+ if (statfs (file, &fsd, sizeof fsd, 0) < 0)
+ return -1;
+
+ /* Empirically, the block counts on most SVR3 and SVR3-derived
+ systems seem to always be in terms of 512-byte blocks,
+ no matter what value f_bsize has. */
+# if defined _CRAY
+ fsp->fsu_blocksize = PROPAGATE_ALL_ONES (fsd.f_bsize);
+# else
+ fsp->fsu_blocksize = 512;
+# endif
+
+#endif
+
+#if (defined STAT_STATVFS64 || defined STAT_STATFS3_OSF1 \
+ || defined STAT_STATFS2_FRSIZE || defined STAT_STATFS2_BSIZE \
+ || defined STAT_STATFS2_FSIZE || defined STAT_STATFS4)
+
+ fsp->fsu_blocks = PROPAGATE_ALL_ONES (fsd.f_blocks);
+ fsp->fsu_bfree = PROPAGATE_ALL_ONES (fsd.f_bfree);
+ fsp->fsu_bavail = PROPAGATE_TOP_BIT (fsd.f_bavail);
+ fsp->fsu_bavail_top_bit_set = EXTRACT_TOP_BIT (fsd.f_bavail) != 0;
+ fsp->fsu_files = PROPAGATE_ALL_ONES (fsd.f_files);
+ fsp->fsu_ffree = PROPAGATE_ALL_ONES (fsd.f_ffree);
+
+#endif
+
+ (void) disk; /* avoid argument-unused warning */
+ return 0;
+}
diff --git a/lib/fsusage.h b/lib/fsusage.h
new file mode 100644
index 00000000000..1d550bc451a
--- /dev/null
+++ b/lib/fsusage.h
@@ -0,0 +1,40 @@
+/* fsusage.h -- declarations for file system space usage info
+
+ Copyright (C) 1991-1992, 1997, 2003-2006, 2009-2019 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 <https://www.gnu.org/licenses/>. */
+
+/* Space usage statistics for a file system. Blocks are 512-byte. */
+
+#if !defined FSUSAGE_H_
+# define FSUSAGE_H_
+
+# include <stdint.h>
+# include <stdbool.h>
+
+struct fs_usage
+{
+ uintmax_t fsu_blocksize; /* Size of a block. */
+ uintmax_t fsu_blocks; /* Total blocks. */
+ uintmax_t fsu_bfree; /* Free blocks available to superuser. */
+ uintmax_t fsu_bavail; /* Free blocks available to non-superuser. */
+ bool fsu_bavail_top_bit_set; /* 1 if fsu_bavail represents a value < 0. */
+ uintmax_t fsu_files; /* Total file nodes. */
+ uintmax_t fsu_ffree; /* Free file nodes. */
+};
+
+int get_fs_usage (char const *file, char const *disk, struct fs_usage *fsp);
+
+#endif
diff --git a/lib/fsync.c b/lib/fsync.c
index 182fd95b88f..bfb6d28a5cf 100644
--- a/lib/fsync.c
+++ b/lib/fsync.c
@@ -25,7 +25,7 @@
#include <config.h>
#include <unistd.h>
-#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+#if defined _WIN32 && ! defined __CYGWIN__
/* FlushFileBuffers */
# define WIN32_LEAN_AND_MEAN
diff --git a/lib/ftoastr.c b/lib/ftoastr.c
index 6c0ce261dca..55f1e02e80f 100644
--- a/lib/ftoastr.c
+++ b/lib/ftoastr.c
@@ -40,9 +40,7 @@
# define FLOAT_PREC_BOUND _GL_LDBL_PREC_BOUND
# define FTOASTR ldtoastr
# define PROMOTED_FLOAT long double
-# if HAVE_C99_STRTOLD
-# define STRTOF strtold
-# endif
+# define STRTOF strtold
#elif LENGTH == 2
# define FLOAT double
# define FLOAT_DIG DBL_DIG
@@ -63,7 +61,7 @@
# endif
#endif
-/* On pre-C99 hosts, approximate strtof and strtold with strtod. This
+/* On pre-C99 hosts, approximate strtof with strtod. This
may generate one or two extra digits, but that's better than not
working at all. */
#ifndef STRTOF
diff --git a/lib/get-permissions.c b/lib/get-permissions.c
index 354693e599d..99b4664aae7 100644
--- a/lib/get-permissions.c
+++ b/lib/get-permissions.c
@@ -31,16 +31,16 @@
int
get_permissions (const char *name, int desc, mode_t mode,
- struct permission_context *ctx)
+ struct permission_context *ctx)
{
memset (ctx, 0, sizeof *ctx);
ctx->mode = mode;
#if USE_ACL && HAVE_ACL_GET_FILE
/* POSIX 1003.1e (draft 17 -- abandoned) specific version. */
- /* Linux, FreeBSD, Mac OS X, IRIX, Tru64 */
+ /* Linux, FreeBSD, Mac OS X, IRIX, Tru64, Cygwin >= 2.5 */
# if !HAVE_ACL_TYPE_EXTENDED
- /* Linux, FreeBSD, IRIX, Tru64 */
+ /* Linux, FreeBSD, IRIX, Tru64, Cygwin >= 2.5 */
if (HAVE_ACL_GET_FD && desc != -1)
ctx->acl = acl_get_fd (desc);
@@ -57,16 +57,16 @@ get_permissions (const char *name, int desc, mode_t mode,
{
ctx->default_acl = acl_get_file (name, ACL_TYPE_DEFAULT);
if (ctx->default_acl == NULL)
- return -1;
+ return -1;
}
-# if HAVE_ACL_TYPE_NFS4 /* FreeBSD */
+# if HAVE_ACL_TYPE_NFS4 /* FreeBSD */
/* TODO (see set_permissions). */
-# endif
+# endif
-# else /* HAVE_ACL_TYPE_EXTENDED */
+# else /* HAVE_ACL_TYPE_EXTENDED */
/* Mac OS X */
/* On Mac OS X, acl_get_file (name, ACL_TYPE_ACCESS)
@@ -115,16 +115,16 @@ get_permissions (const char *name, int desc, mode_t mode,
int ret;
if (desc != -1)
- ret = facl (desc, ACE_GETACLCNT, 0, NULL);
+ ret = facl (desc, ACE_GETACLCNT, 0, NULL);
else
- ret = acl (name, ACE_GETACLCNT, 0, NULL);
+ ret = acl (name, ACE_GETACLCNT, 0, NULL);
if (ret < 0)
- {
- if (errno == ENOSYS || errno == EINVAL)
- ret = 0;
- else
- return -1;
- }
+ {
+ if (errno == ENOSYS || errno == EINVAL)
+ ret = 0;
+ else
+ return -1;
+ }
ctx->ace_count = ret;
if (ctx->ace_count == 0)
@@ -138,15 +138,15 @@ get_permissions (const char *name, int desc, mode_t mode,
}
if (desc != -1)
- ret = facl (desc, ACE_GETACL, ctx->ace_count, ctx->ace_entries);
+ ret = facl (desc, ACE_GETACL, ctx->ace_count, ctx->ace_entries);
else
- ret = acl (name, ACE_GETACL, ctx->ace_count, ctx->ace_entries);
+ ret = acl (name, ACE_GETACL, ctx->ace_count, ctx->ace_entries);
if (ret < 0)
{
if (errno == ENOSYS || errno == EINVAL)
{
- free (ctx->ace_entries);
- ctx->ace_entries = NULL;
+ free (ctx->ace_entries);
+ ctx->ace_entries = NULL;
ctx->ace_count = 0;
break;
}
@@ -154,10 +154,10 @@ get_permissions (const char *name, int desc, mode_t mode,
return -1;
}
if (ret <= ctx->ace_count)
- {
- ctx->ace_count = ret;
- break;
- }
+ {
+ ctx->ace_count = ret;
+ break;
+ }
/* Huh? The number of ACL entries has increased since the last call.
Repeat. */
free (ctx->ace_entries);
@@ -170,20 +170,20 @@ get_permissions (const char *name, int desc, mode_t mode,
int ret;
if (desc != -1)
- ret = facl (desc, GETACLCNT, 0, NULL);
+ ret = facl (desc, GETACLCNT, 0, NULL);
else
- ret = acl (name, GETACLCNT, 0, NULL);
+ ret = acl (name, GETACLCNT, 0, NULL);
if (ret < 0)
- {
- if (errno == ENOSYS || errno == ENOTSUP || errno == EOPNOTSUPP)
- ret = 0;
- else
- return -1;
- }
+ {
+ if (errno == ENOSYS || errno == ENOTSUP || errno == EOPNOTSUPP)
+ ret = 0;
+ else
+ return -1;
+ }
ctx->count = ret;
if (ctx->count == 0)
- break;
+ break;
ctx->entries = (aclent_t *) malloc (ctx->count * sizeof (aclent_t));
if (ctx->entries == NULL)
@@ -193,26 +193,26 @@ get_permissions (const char *name, int desc, mode_t mode,
}
if (desc != -1)
- ret = facl (desc, GETACL, ctx->count, ctx->entries);
+ ret = facl (desc, GETACL, ctx->count, ctx->entries);
else
- ret = acl (name, GETACL, ctx->count, ctx->entries);
+ ret = acl (name, GETACL, ctx->count, ctx->entries);
if (ret < 0)
- {
- if (errno == ENOSYS || errno == ENOTSUP || errno == EOPNOTSUPP)
- {
- free (ctx->entries);
- ctx->entries = NULL;
- ctx->count = 0;
- break;
- }
- else
- return -1;
- }
+ {
+ if (errno == ENOSYS || errno == ENOTSUP || errno == EOPNOTSUPP)
+ {
+ free (ctx->entries);
+ ctx->entries = NULL;
+ ctx->count = 0;
+ break;
+ }
+ else
+ return -1;
+ }
if (ret <= ctx->count)
- {
- ctx->count = ret;
- break;
- }
+ {
+ ctx->count = ret;
+ break;
+ }
/* Huh? The number of ACL entries has increased since the last call.
Repeat. */
free (ctx->entries);
diff --git a/lib/getdtablesize.c b/lib/getdtablesize.c
index 1bee093bc15..03a92435f0b 100644
--- a/lib/getdtablesize.c
+++ b/lib/getdtablesize.c
@@ -20,7 +20,7 @@
/* Specification. */
#include <unistd.h>
-#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+#if defined _WIN32 && ! defined __CYGWIN__
# include <stdio.h>
diff --git a/lib/getgroups.c b/lib/getgroups.c
index 7dc672d1f4d..d8c77e9a650 100644
--- a/lib/getgroups.c
+++ b/lib/getgroups.c
@@ -1,7 +1,6 @@
/* provide consistent interface to getgroups for systems that don't allow N==0
- Copyright (C) 1996, 1999, 2003, 2006-2019 Free Software Foundation,
- Inc.
+ Copyright (C) 1996, 1999, 2003, 2006-2019 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
@@ -59,8 +58,8 @@ int posix_getgroups (int, gid_t []) __asm ("_getgroups");
# define getgroups posix_getgroups
# endif
-/* On at least Ultrix 4.3 and NextStep 3.2, getgroups (0, NULL) always
- fails. On other systems, it returns the number of supplemental
+/* On at least NeXTstep 3.2, getgroups (0, NULL) always fails.
+ On other systems, it returns the number of supplemental
groups for the process. This function handles that special case
and lets the system-provided function handle all others. However,
it can fail with ENOMEM if memory is tight. It is unspecified
diff --git a/lib/getloadavg.c b/lib/getloadavg.c
index c07f7db175d..08c14efcfce 100644
--- a/lib/getloadavg.c
+++ b/lib/getloadavg.c
@@ -1,7 +1,7 @@
/* Get the system load averages.
- Copyright (C) 1985-1989, 1991-1995, 1997, 1999-2000, 2003-2019 Free
- Software Foundation, Inc.
+ Copyright (C) 1985-1989, 1991-1995, 1997, 1999-2000, 2003-2019 Free Software
+ Foundation, Inc.
NOTE: The canonical source of this file is maintained with gnulib.
Bugs can be reported to bug-gnulib@gnu.org.
@@ -47,29 +47,25 @@
N_NAME_POINTER The nlist n_name element is a pointer,
not an array.
HAVE_STRUCT_NLIST_N_UN_N_NAME 'n_un.n_name' is member of 'struct nlist'.
- LINUX_LDAV_FILE [__linux__, __CYGWIN__]: File containing
- load averages.
+ LINUX_LDAV_FILE [__linux__, __ANDROID__, __CYGWIN__]: File
+ containing load averages.
Specific system predefines this file uses, aside from setting
default values if not emacs:
apollo
BSD Real BSD, not just BSD-like.
- convex
DGUX
eunice UNIX emulator under VMS.
hpux
__MSDOS__ No-op for MSDOS.
NeXT
sgi
- sequent Sequent Dynix 3.x.x (BSD)
- _SEQUENT_ Sequent DYNIX/ptx 1.x.x (SYSV)
- sony_news NEWS-OS (works at least for 4.1C)
UMAX
UMAX4_3
VMS
- WINDOWS32 No-op for Windows95/NT.
- __linux__ Linux: assumes /proc file system mounted.
+ _WIN32 Native Windows (possibly also defined on Cygwin)
+ __linux__, __ANDROID__ Linux: assumes /proc file system mounted.
Support from Michael K. Johnson.
__CYGWIN__ Cygwin emulates linux /proc/loadavg.
__NetBSD__ NetBSD: assumes /kern file system mounted.
@@ -97,9 +93,8 @@
# include "intprops.h"
-# if !defined (BSD) && defined (ultrix)
-/* Ultrix behaves like BSD on Vaxen. */
-# define BSD
+# if defined _WIN32 && ! defined __CYGWIN__ && ! defined WINDOWS32
+# define WINDOWS32
# endif
# ifdef NeXT
@@ -141,10 +136,6 @@
# define MORE_BSD
# endif
-# if defined (ultrix) && defined (mips)
-# define decstation
-# endif
-
# if defined (__SVR4) && !defined (SVR4)
# define SVR4
# endif
@@ -168,13 +159,6 @@
# include <sys/table.h>
# endif
-/* UTek's /bin/cc on the 4300 has no architecture specific cpp define by
- default, but _MACH_IND_SYS_TYPES is defined in <sys/types.h>. Combine
- that with a couple of other things and we'll have a unique match. */
-# if !defined (tek4300) && defined (unix) && defined (m68k) && defined (mc68000) && defined (mc68020) && defined (_MACH_IND_SYS_TYPES)
-# define tek4300 /* Define by emacs, but not by other users. */
-# endif
-
/* VAX C can't handle multi-line #ifs, or lines longer than 256 chars. */
# ifndef LOAD_AVE_TYPE
@@ -187,14 +171,6 @@
# define LOAD_AVE_TYPE long
# endif
-# ifdef decstation
-# define LOAD_AVE_TYPE long
-# endif
-
-# ifdef _SEQUENT_
-# define LOAD_AVE_TYPE long
-# endif
-
# ifdef sgi
# define LOAD_AVE_TYPE long
# endif
@@ -203,41 +179,14 @@
# define LOAD_AVE_TYPE long
# endif
-# ifdef sony_news
-# define LOAD_AVE_TYPE long
-# endif
-
-# ifdef sequent
-# define LOAD_AVE_TYPE long
-# endif
-
# ifdef OSF_ALPHA
# define LOAD_AVE_TYPE long
# endif
-# if defined (ardent) && defined (titan)
-# define LOAD_AVE_TYPE long
-# endif
-
-# ifdef tek4300
-# define LOAD_AVE_TYPE long
-# endif
-
-# if defined (alliant) && defined (i860) /* Alliant FX/2800 */
-# define LOAD_AVE_TYPE long
-# endif
-
# if defined _AIX && ! defined HAVE_LIBPERFSTAT
# define LOAD_AVE_TYPE long
# endif
-# ifdef convex
-# define LOAD_AVE_TYPE double
-# ifndef LDAV_CVT
-# define LDAV_CVT(n) (n)
-# endif
-# endif
-
# endif /* No LOAD_AVE_TYPE. */
# ifdef OSF_ALPHA
@@ -247,13 +196,6 @@
# define FSCALE 1024.0
# endif
-# if defined (alliant) && defined (i860) /* Alliant FX/2800 */
-/* <sys/param.h> defines an incorrect value for FSCALE on an
- Alliant FX/2800 Concentrix 2.2, according to ghazi@noc.rutgers.edu. */
-# undef FSCALE
-# define FSCALE 100.0
-# endif
-
# ifndef FSCALE
@@ -263,25 +205,17 @@
# define FSCALE 2048.0
# endif
-# if defined (MIPS) || defined (SVR4) || defined (decstation)
+# if defined (MIPS) || defined (SVR4)
# define FSCALE 256
# endif
-# if defined (sgi) || defined (sequent)
+# if defined (sgi)
/* Sometimes both MIPS and sgi are defined, so FSCALE was just defined
above under #ifdef MIPS. But we want the sgi value. */
# undef FSCALE
# define FSCALE 1000.0
# endif
-# if defined (ardent) && defined (titan)
-# define FSCALE 65536.0
-# endif
-
-# ifdef tek4300
-# define FSCALE 100.0
-# endif
-
# if defined _AIX && !defined HAVE_LIBPERFSTAT
# define FSCALE 65536.0
# endif
@@ -303,28 +237,22 @@
# endif
-# if !defined (KERNEL_FILE) && defined (sequent)
-# define KERNEL_FILE "/dynix"
-# endif
-
# if !defined (KERNEL_FILE) && defined (hpux)
# define KERNEL_FILE "/hp-ux"
# endif
-# if !defined (KERNEL_FILE) && (defined (_SEQUENT_) || defined (MIPS) || defined (SVR4) || defined (ISC) || defined (sgi) || (defined (ardent) && defined (titan)))
+# if !defined (KERNEL_FILE) && (defined (MIPS) || defined (SVR4) || defined (ISC) || defined (sgi))
# define KERNEL_FILE "/unix"
# endif
-# if !defined (LDAV_SYMBOL) && defined (alliant)
-# define LDAV_SYMBOL "_Loadavg"
-# endif
-
-# if !defined (LDAV_SYMBOL) && ((defined (hpux) && !defined (hp9000s300)) || defined (_SEQUENT_) || defined (SVR4) || defined (ISC) || defined (sgi) || (defined (ardent) && defined (titan)) || (defined (_AIX) && !defined(HAVE_LIBPERFSTAT)))
+# if !defined (LDAV_SYMBOL) && (defined (hpux) || defined (SVR4) || defined (ISC) || defined (sgi) || (defined (_AIX) && !defined(HAVE_LIBPERFSTAT)))
# define LDAV_SYMBOL "avenrun"
# endif
-# include <unistd.h>
+# ifdef HAVE_UNISTD_H
+# include <unistd.h>
+# endif
/* LOAD_AVE_TYPE should only get defined if we're going to use the
nlist method. */
@@ -335,7 +263,7 @@
# ifdef LOAD_AVE_TYPE
# ifndef __VMS
-# ifndef __linux__
+# if !(defined __linux__ || defined __ANDROID__)
# ifndef NLIST_STRUCT
# include <a.out.h>
# else /* NLIST_STRUCT */
@@ -358,7 +286,7 @@
# ifndef LDAV_SYMBOL
# define LDAV_SYMBOL "_avenrun"
# endif /* LDAV_SYMBOL */
-# endif /* __linux__ */
+# endif /* __linux__ || __ANDROID__ */
# else /* __VMS */
@@ -431,7 +359,8 @@
# include <sys/dg_sys_info.h>
# endif
-# if (defined __linux__ || defined __CYGWIN__ || defined SUNOS_5 \
+# if (defined __linux__ || defined __ANDROID__ \
+ || defined __CYGWIN__ || defined SUNOS_5 \
|| (defined LOAD_AVE_TYPE && ! defined __VMS))
# include <fcntl.h>
# endif
@@ -460,7 +389,7 @@ static bool getloadavg_initialized;
/* Offset in kmem to seek to read load average, or 0 means invalid. */
static long offset;
-# if ! defined __VMS && ! defined sgi && ! defined __linux__
+# if ! defined __VMS && ! defined sgi && ! (defined __linux__ || defined __ANDROID__)
static struct nlist name_list[2];
# endif
@@ -495,17 +424,17 @@ getloadavg (double loadavg[], int nelem)
int saved_errno;
kc = kstat_open ();
- if (kc == 0)
+ if (kc == NULL)
return -1;
ksp = kstat_lookup (kc, "unix", 0, "system_misc");
- if (ksp == 0)
+ if (ksp == NULL)
return -1;
if (kstat_read (kc, ksp, 0) == -1)
return -1;
kn = kstat_data_lookup (ksp, "avenrun_1min");
- if (kn == 0)
+ if (kn == NULL)
{
/* Return -1 if no load average information is available. */
nelem = 0;
@@ -518,14 +447,14 @@ getloadavg (double loadavg[], int nelem)
if (nelem >= 2)
{
kn = kstat_data_lookup (ksp, "avenrun_5min");
- if (kn != 0)
+ if (kn != NULL)
{
loadavg[elem++] = (double) kn->value.ul / FSCALE;
if (nelem >= 3)
{
kn = kstat_data_lookup (ksp, "avenrun_15min");
- if (kn != 0)
+ if (kn != NULL)
loadavg[elem++] = (double) kn->value.ul / FSCALE;
}
}
@@ -570,8 +499,8 @@ getloadavg (double loadavg[], int nelem)
}
# endif
-# if !defined (LDAV_DONE) && (defined (__linux__) || defined (__CYGWIN__))
- /* Linux without glibc, Cygwin */
+# if !defined (LDAV_DONE) && (defined __linux__ || defined __ANDROID__ || defined __CYGWIN__)
+ /* Linux without glibc, Android, Cygwin */
# define LDAV_DONE
# undef LOAD_AVE_TYPE
@@ -626,7 +555,7 @@ getloadavg (double loadavg[], int nelem)
return elem;
-# endif /* __linux__ || __CYGWIN__ */
+# endif /* __linux__ || __ANDROID__ || __CYGWIN__ */
# if !defined (LDAV_DONE) && defined (__NetBSD__) /* NetBSD < 0.9 */
# define LDAV_DONE
@@ -915,7 +844,7 @@ getloadavg (double loadavg[], int nelem)
# ifndef SUNOS_5
if (
-# if !(defined (_AIX) && !defined (ps2))
+# if !defined (_AIX)
nlist (KERNEL_FILE, name_list)
# else /* _AIX */
knlist (name_list, 1, sizeof (name_list[0]))
@@ -966,7 +895,7 @@ getloadavg (double loadavg[], int nelem)
/* We pass 0 for the kernel, corefile, and swapfile names
to use the currently running kernel. */
kd = kvm_open (0, 0, 0, O_RDONLY, 0);
- if (kd != 0)
+ if (kd != NULL)
{
/* nlist the currently running kernel. */
kvm_nlist (kd, name_list);
diff --git a/lib/getopt.c b/lib/getopt.c
index cb0f338b5d3..8ee075a8091 100644
--- a/lib/getopt.c
+++ b/lib/getopt.c
@@ -46,7 +46,7 @@
/* When used standalone, flockfile and funlockfile might not be
available. */
# if (!defined _POSIX_THREAD_SAFE_FUNCTIONS \
- || ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__))
+ || (defined _WIN32 && ! defined __CYGWIN__))
# define flockfile(fp) /* nop */
# define funlockfile(fp) /* nop */
# endif
diff --git a/lib/gettext.h b/lib/gettext.h
index 9492b46c49b..c7c0fdb5311 100644
--- a/lib/gettext.h
+++ b/lib/gettext.h
@@ -1,6 +1,6 @@
/* Convenience header for conditional use of GNU <libintl.h>.
- Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009-2019 Free
- Software Foundation, Inc.
+ Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009-2019 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
@@ -184,9 +184,16 @@ npgettext_aux (const char *domain,
#include <string.h>
-#if (((__GNUC__ >= 3 || __GNUG__ >= 2) && !defined __STRICT_ANSI__) \
- /* || __STDC_VERSION__ == 199901L
- || (__STDC_VERSION__ >= 201112L && !defined __STDC_NO_VLA__) */ )
+/* GNULIB_NO_VLA can be defined to disable use of VLAs even if supported.
+ This relates to the -Wvla and -Wvla-larger-than warnings, enabled in
+ the default GCC many warnings set. This allows programs to disable use
+ of VLAs, which may be unintended, or may be awkward to support portably,
+ or may have security implications due to non-deterministic stack usage. */
+
+#if (!defined GNULIB_NO_VLA \
+ && (((__GNUC__ >= 3 || __GNUG__ >= 2) && !defined __STRICT_ANSI__) \
+ /* || (__STDC_VERSION__ == 199901L && !defined __HP_cc)
+ || (__STDC_VERSION__ >= 201112L && !defined __STDC_NO_VLA__) */ ))
# define _LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS 1
#else
# define _LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS 0
diff --git a/lib/gettime.c b/lib/gettime.c
index 6e61a09a418..1fd153f6dce 100644
--- a/lib/gettime.c
+++ b/lib/gettime.c
@@ -1,7 +1,6 @@
/* gettime -- get the system clock
- Copyright (C) 2002, 2004-2007, 2009-2019 Free Software Foundation,
- Inc.
+ Copyright (C) 2002, 2004-2007, 2009-2019 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
@@ -29,21 +28,22 @@
void
gettime (struct timespec *ts)
{
-#if HAVE_NANOTIME
- nanotime (ts);
+#if defined CLOCK_REALTIME && HAVE_CLOCK_GETTIME
+ clock_gettime (CLOCK_REALTIME, ts);
#else
+ struct timeval tv;
+ gettimeofday (&tv, NULL);
+ ts->tv_sec = tv.tv_sec;
+ ts->tv_nsec = tv.tv_usec * 1000;
+#endif
+}
-# if defined CLOCK_REALTIME && HAVE_CLOCK_GETTIME
- if (clock_gettime (CLOCK_REALTIME, ts) == 0)
- return;
-# endif
-
- {
- struct timeval tv;
- gettimeofday (&tv, NULL);
- ts->tv_sec = tv.tv_sec;
- ts->tv_nsec = tv.tv_usec * 1000;
- }
+/* Return the current system time as a struct timespec. */
-#endif
+struct timespec
+current_timespec (void)
+{
+ struct timespec ts;
+ gettime (&ts);
+ return ts;
}
diff --git a/lib/gettimeofday.c b/lib/gettimeofday.c
index db4e8f48891..e728bf47355 100644
--- a/lib/gettimeofday.c
+++ b/lib/gettimeofday.c
@@ -1,7 +1,6 @@
/* Provide gettimeofday for systems that don't have it or for which it's broken.
- Copyright (C) 2001-2003, 2005-2007, 2009-2019 Free Software
- Foundation, Inc.
+ Copyright (C) 2001-2003, 2005-2007, 2009-2019 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
@@ -25,7 +24,7 @@
#include <time.h>
-#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+#if defined _WIN32 && ! defined __CYGWIN__
# define WINDOWS_NATIVE
# include <windows.h>
#endif
@@ -34,6 +33,10 @@
#ifdef WINDOWS_NATIVE
+/* Avoid warnings from gcc -Wcast-function-type. */
+# define GetProcAddress \
+ (void *) GetProcAddress
+
/* GetSystemTimePreciseAsFileTime was introduced only in Windows 8. */
typedef void (WINAPI * GetSystemTimePreciseAsFileTimeFuncType) (FILETIME *lpTime);
static GetSystemTimePreciseAsFileTimeFuncType GetSystemTimePreciseAsFileTimeFunc = NULL;
@@ -46,7 +49,7 @@ initialize (void)
if (kernel32 != NULL)
{
GetSystemTimePreciseAsFileTimeFunc =
- (GetSystemTimePreciseAsFileTimeFuncType) GetProcAddress (kernel32, "GetSystemTimePreciseAsFileTime");
+ (GetSystemTimePreciseAsFileTimeFuncType) GetProcAddress (kernel32, "GetSystemTimePreciseAsFileTime");
}
initialized = TRUE;
}
@@ -69,10 +72,10 @@ gettimeofday (struct timeval *restrict tv, void *restrict tz)
/* On native Windows, there are two ways to get the current time:
GetSystemTimeAsFileTime
- <https://msdn.microsoft.com/en-us/library/ms724397.aspx>
+ <https://docs.microsoft.com/en-us/windows/desktop/api/sysinfoapi/nf-sysinfoapi-getsystemtimeasfiletime>
or
GetSystemTimePreciseAsFileTime
- <https://msdn.microsoft.com/en-us/library/hh706895.aspx>.
+ <https://docs.microsoft.com/en-us/windows/desktop/api/sysinfoapi/nf-sysinfoapi-getsystemtimepreciseasfiletime>.
GetSystemTimeAsFileTime produces values that jump by increments of
15.627 milliseconds (!) on average.
Whereas GetSystemTimePreciseAsFileTime values usually jump by 1 or 2
@@ -89,7 +92,7 @@ gettimeofday (struct timeval *restrict tv, void *restrict tz)
GetSystemTimeAsFileTime (&current_time);
/* Convert from FILETIME to 'struct timeval'. */
- /* FILETIME: <https://msdn.microsoft.com/en-us/library/ms724284.aspx> */
+ /* FILETIME: <https://docs.microsoft.com/en-us/windows/desktop/api/minwinbase/ns-minwinbase-filetime> */
ULONGLONG since_1601 =
((ULONGLONG) current_time.dwHighDateTime << 32)
| (ULONGLONG) current_time.dwLowDateTime;
diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in
index efa87bc45dd..0d9a885be3d 100644
--- a/lib/gnulib.mk.in
+++ b/lib/gnulib.mk.in
@@ -1,5 +1,4 @@
## DO NOT EDIT! GENERATED AUTOMATICALLY!
-## Process this file with automake to produce Makefile.in.
# Copyright (C) 2002-2019 Free Software Foundation, Inc.
#
# This file is free software; you can redistribute it and/or modify
@@ -21,7 +20,135 @@
# the same distribution terms as the rest of that program.
#
# Generated by gnulib-tool.
-# Reproduce by: gnulib-tool --import --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=close --avoid=dup --avoid=fchdir --avoid=fstat --avoid=malloc-posix --avoid=msvc-inval --avoid=msvc-nothrow --avoid=openat-die --avoid=opendir --avoid=raise --avoid=save-cwd --avoid=select --avoid=setenv --avoid=sigprocmask --avoid=stat --avoid=stdarg --avoid=stdbool --avoid=threadlib --avoid=tzset --avoid=unsetenv --avoid=utime --avoid=utime-h --gnu-make --makefile-name=gnulib.mk.in --conditional-dependencies --no-libtool --macro-prefix=gl --no-vc-files alloca-opt binary-io byteswap c-ctype c-strcase careadlinkat close-stream count-leading-zeros count-one-bits count-trailing-zeros crypto/md5 crypto/sha1 crypto/sha256 crypto/sha512 d-type diffseq dtoastr dtotimespec dup2 environ execinfo explicit_bzero faccessat fcntl fcntl-h fdatasync fdopendir filemode filevercmp flexmember fpieee fstatat fsync getloadavg getopt-gnu gettime gettimeofday gitlog-to-changelog ignore-value intprops largefile lstat manywarnings memrchr minmax mkostemp mktime nstrftime pipe2 pselect pthread_sigmask putenv qcopy-acl readlink readlinkat sig2str socklen stat-time std-gnu11 stdalign stddef stdio stpcpy strtoimax symlink sys_stat sys_time tempname time time_r time_rz timegm timer-time timespec-add timespec-sub unlocked-io update-copyright utimens vla warnings
+# Reproduce by:
+# gnulib-tool --import \
+# --lib=libgnu \
+# --source-base=lib \
+# --m4-base=m4 \
+# --doc-base=doc \
+# --tests-base=tests \
+# --aux-dir=build-aux \
+# --gnu-make \
+# --makefile-name=gnulib.mk.in \
+# --conditional-dependencies \
+# --no-libtool \
+# --macro-prefix=gl \
+# --no-vc-files \
+# --avoid=btowc \
+# --avoid=close \
+# --avoid=dup \
+# --avoid=fchdir \
+# --avoid=fstat \
+# --avoid=langinfo \
+# --avoid=lock \
+# --avoid=malloc-posix \
+# --avoid=mbrtowc \
+# --avoid=mbsinit \
+# --avoid=mkdir \
+# --avoid=msvc-inval \
+# --avoid=msvc-nothrow \
+# --avoid=nl_langinfo \
+# --avoid=openat-die \
+# --avoid=opendir \
+# --avoid=raise \
+# --avoid=save-cwd \
+# --avoid=select \
+# --avoid=setenv \
+# --avoid=sigprocmask \
+# --avoid=stat \
+# --avoid=stdarg \
+# --avoid=stdbool \
+# --avoid=threadlib \
+# --avoid=tzset \
+# --avoid=unsetenv \
+# --avoid=utime \
+# --avoid=utime-h \
+# --avoid=wchar \
+# --avoid=wcrtomb \
+# --avoid=wctype-h \
+# alloca-opt \
+# binary-io \
+# byteswap \
+# c-ctype \
+# c-strcase \
+# careadlinkat \
+# close-stream \
+# count-leading-zeros \
+# count-one-bits \
+# count-trailing-zeros \
+# crypto/md5-buffer \
+# crypto/sha1-buffer \
+# crypto/sha256-buffer \
+# crypto/sha512-buffer \
+# d-type \
+# diffseq \
+# dosname \
+# dtoastr \
+# dtotimespec \
+# dup2 \
+# environ \
+# execinfo \
+# explicit_bzero \
+# faccessat \
+# fcntl \
+# fcntl-h \
+# fdopendir \
+# filemode \
+# filevercmp \
+# flexmember \
+# fpieee \
+# fstatat \
+# fsusage \
+# fsync \
+# getloadavg \
+# getopt-gnu \
+# gettime \
+# gettimeofday \
+# gitlog-to-changelog \
+# ieee754-h \
+# ignore-value \
+# intprops \
+# largefile \
+# lstat \
+# manywarnings \
+# memrchr \
+# minmax \
+# mkostemp \
+# mktime \
+# nstrftime \
+# pipe2 \
+# pselect \
+# pthread_sigmask \
+# putenv \
+# qcopy-acl \
+# readlink \
+# readlinkat \
+# regex \
+# sig2str \
+# socklen \
+# stat-time \
+# std-gnu11 \
+# stdalign \
+# stddef \
+# stdio \
+# stpcpy \
+# strtoimax \
+# symlink \
+# sys_stat \
+# sys_time \
+# tempname \
+# time \
+# time_r \
+# time_rz \
+# timegm \
+# timer-time \
+# timespec-add \
+# timespec-sub \
+# unlocked-io \
+# update-copyright \
+# utimens \
+# vla \
+# warnings
MOSTLYCLEANFILES += core *.stackdump
@@ -44,11 +171,11 @@ BITSIZEOF_SIZE_T = @BITSIZEOF_SIZE_T@
BITSIZEOF_WCHAR_T = @BITSIZEOF_WCHAR_T@
BITSIZEOF_WINT_T = @BITSIZEOF_WINT_T@
BLESSMAIL_TARGET = @BLESSMAIL_TARGET@
+BREW = @BREW@
BUILD_DETAILS = @BUILD_DETAILS@
BYTESWAP_H = @BYTESWAP_H@
CAIRO_CFLAGS = @CAIRO_CFLAGS@
CAIRO_LIBS = @CAIRO_LIBS@
-CANNOT_DUMP = @CANNOT_DUMP@
CC = @CC@
CFLAGS = @CFLAGS@
CFLAGS_SOUND = @CFLAGS_SOUND@
@@ -69,6 +196,7 @@ DBUS_OBJ = @DBUS_OBJ@
DEFS = @DEFS@
DESLIB = @DESLIB@
DOCMISC_W32 = @DOCMISC_W32@
+DUMPING = @DUMPING@
ECHO_C = @ECHO_C@
ECHO_N = @ECHO_N@
ECHO_T = @ECHO_T@
@@ -99,16 +227,20 @@ GETOPT_CDEFS_H = @GETOPT_CDEFS_H@
GETOPT_H = @GETOPT_H@
GFILENOTIFY_CFLAGS = @GFILENOTIFY_CFLAGS@
GFILENOTIFY_LIBS = @GFILENOTIFY_LIBS@
+GLIBC21 = @GLIBC21@
GL_COND_LIBTOOL = @GL_COND_LIBTOOL@
GL_GENERATE_ALLOCA_H = @GL_GENERATE_ALLOCA_H@
GL_GENERATE_BYTESWAP_H = @GL_GENERATE_BYTESWAP_H@
GL_GENERATE_ERRNO_H = @GL_GENERATE_ERRNO_H@
GL_GENERATE_EXECINFO_H = @GL_GENERATE_EXECINFO_H@
+GL_GENERATE_IEEE754_H = @GL_GENERATE_IEEE754_H@
GL_GENERATE_LIMITS_H = @GL_GENERATE_LIMITS_H@
GL_GENERATE_STDALIGN_H = @GL_GENERATE_STDALIGN_H@
GL_GENERATE_STDDEF_H = @GL_GENERATE_STDDEF_H@
GL_GENERATE_STDINT_H = @GL_GENERATE_STDINT_H@
GMALLOC_OBJ = @GMALLOC_OBJ@
+GMP_LIB = @GMP_LIB@
+GMP_OBJ = @GMP_OBJ@
GNULIB_ALPHASORT = @GNULIB_ALPHASORT@
GNULIB_ATOLL = @GNULIB_ATOLL@
GNULIB_CALLOC_POSIX = @GNULIB_CALLOC_POSIX@
@@ -172,6 +304,7 @@ GNULIB_GETLOADAVG = @GNULIB_GETLOADAVG@
GNULIB_GETLOGIN = @GNULIB_GETLOGIN@
GNULIB_GETLOGIN_R = @GNULIB_GETLOGIN_R@
GNULIB_GETPAGESIZE = @GNULIB_GETPAGESIZE@
+GNULIB_GETPASS = @GNULIB_GETPASS@
GNULIB_GETSUBOPT = @GNULIB_GETSUBOPT@
GNULIB_GETTIMEOFDAY = @GNULIB_GETTIMEOFDAY@
GNULIB_GETUSERSHELL = @GNULIB_GETUSERSHELL@
@@ -298,6 +431,7 @@ GNULIB_STRSTR = @GNULIB_STRSTR@
GNULIB_STRTOD = @GNULIB_STRTOD@
GNULIB_STRTOIMAX = @GNULIB_STRTOIMAX@
GNULIB_STRTOK_R = @GNULIB_STRTOK_R@
+GNULIB_STRTOLD = @GNULIB_STRTOLD@
GNULIB_STRTOLL = @GNULIB_STRTOLL@
GNULIB_STRTOULL = @GNULIB_STRTOULL@
GNULIB_STRTOUMAX = @GNULIB_STRTOUMAX@
@@ -345,6 +479,7 @@ GTK_CFLAGS = @GTK_CFLAGS@
GTK_LIBS = @GTK_LIBS@
GTK_OBJ = @GTK_OBJ@
GZIP_PROG = @GZIP_PROG@
+HAVE_ALLOCA_H = @HAVE_ALLOCA_H@
HAVE_ALPHASORT = @HAVE_ALPHASORT@
HAVE_ATOLL = @HAVE_ATOLL@
HAVE_C99_STDINT_H = @HAVE_C99_STDINT_H@
@@ -386,6 +521,7 @@ HAVE_DECL_STRSIGNAL = @HAVE_DECL_STRSIGNAL@
HAVE_DECL_STRTOIMAX = @HAVE_DECL_STRTOIMAX@
HAVE_DECL_STRTOK_R = @HAVE_DECL_STRTOK_R@
HAVE_DECL_STRTOUMAX = @HAVE_DECL_STRTOUMAX@
+HAVE_DECL_TRUNCATE = @HAVE_DECL_TRUNCATE@
HAVE_DECL_TTYNAME_R = @HAVE_DECL_TTYNAME_R@
HAVE_DECL_UNSETENV = @HAVE_DECL_UNSETENV@
HAVE_DECL_VSNPRINTF = @HAVE_DECL_VSNPRINTF@
@@ -416,10 +552,13 @@ HAVE_GETHOSTNAME = @HAVE_GETHOSTNAME@
HAVE_GETLOGIN = @HAVE_GETLOGIN@
HAVE_GETOPT_H = @HAVE_GETOPT_H@
HAVE_GETPAGESIZE = @HAVE_GETPAGESIZE@
+HAVE_GETPASS = @HAVE_GETPASS@
HAVE_GETSUBOPT = @HAVE_GETSUBOPT@
HAVE_GETTIMEOFDAY = @HAVE_GETTIMEOFDAY@
HAVE_GRANTPT = @HAVE_GRANTPT@
HAVE_GROUP_MEMBER = @HAVE_GROUP_MEMBER@
+HAVE_IMAXDIV_T = @HAVE_IMAXDIV_T@
+HAVE_INITSTATE = @HAVE_INITSTATE@
HAVE_INTTYPES_H = @HAVE_INTTYPES_H@
HAVE_LCHMOD = @HAVE_LCHMOD@
HAVE_LCHOWN = @HAVE_LCHOWN@
@@ -430,6 +569,7 @@ HAVE_LSTAT = @HAVE_LSTAT@
HAVE_MAKEINFO = @HAVE_MAKEINFO@
HAVE_MAX_ALIGN_T = @HAVE_MAX_ALIGN_T@
HAVE_MBSLEN = @HAVE_MBSLEN@
+HAVE_MBTOWC = @HAVE_MBTOWC@
HAVE_MEMCHR = @HAVE_MEMCHR@
HAVE_MEMPCPY = @HAVE_MEMPCPY@
HAVE_MKDIRAT = @HAVE_MKDIRAT@
@@ -477,6 +617,7 @@ HAVE_SCANDIR = @HAVE_SCANDIR@
HAVE_SECURE_GETENV = @HAVE_SECURE_GETENV@
HAVE_SETENV = @HAVE_SETENV@
HAVE_SETHOSTNAME = @HAVE_SETHOSTNAME@
+HAVE_SETSTATE = @HAVE_SETSTATE@
HAVE_SIGACTION = @HAVE_SIGACTION@
HAVE_SIGHANDLER_T = @HAVE_SIGHANDLER_T@
HAVE_SIGINFO_T = @HAVE_SIGINFO_T@
@@ -494,6 +635,7 @@ HAVE_STRPBRK = @HAVE_STRPBRK@
HAVE_STRPTIME = @HAVE_STRPTIME@
HAVE_STRSEP = @HAVE_STRSEP@
HAVE_STRTOD = @HAVE_STRTOD@
+HAVE_STRTOLD = @HAVE_STRTOLD@
HAVE_STRTOLL = @HAVE_STRTOLL@
HAVE_STRTOULL = @HAVE_STRTOULL@
HAVE_STRUCT_RANDOM_DATA = @HAVE_STRUCT_RANDOM_DATA@
@@ -512,7 +654,6 @@ HAVE_SYS_TIME_H = @HAVE_SYS_TIME_H@
HAVE_SYS_TYPES_H = @HAVE_SYS_TYPES_H@
HAVE_TIMEGM = @HAVE_TIMEGM@
HAVE_TIMEZONE_T = @HAVE_TIMEZONE_T@
-HAVE_TRUNCATE = @HAVE_TRUNCATE@
HAVE_TYPE_VOLATILE_SIG_ATOMIC_T = @HAVE_TYPE_VOLATILE_SIG_ATOMIC_T@
HAVE_TZSET = @HAVE_TZSET@
HAVE_UNISTD_H = @HAVE_UNISTD_H@
@@ -529,6 +670,7 @@ HAVE_WINSOCK2_H = @HAVE_WINSOCK2_H@
HAVE_XSERVER = @HAVE_XSERVER@
HAVE__EXIT = @HAVE__EXIT@
HYBRID_MALLOC = @HYBRID_MALLOC@
+IEEE754_H = @IEEE754_H@
IMAGEMAGICK_CFLAGS = @IMAGEMAGICK_CFLAGS@
IMAGEMAGICK_LIBS = @IMAGEMAGICK_LIBS@
INCLUDE_NEXT = @INCLUDE_NEXT@
@@ -540,10 +682,15 @@ INSTALL_PROGRAM = @INSTALL_PROGRAM@
INSTALL_SCRIPT = @INSTALL_SCRIPT@
INT32_MAX_LT_INTMAX_MAX = @INT32_MAX_LT_INTMAX_MAX@
INT64_MAX_EQ_LONG_MAX = @INT64_MAX_EQ_LONG_MAX@
+JSON_CFLAGS = @JSON_CFLAGS@
+JSON_LIBS = @JSON_LIBS@
+JSON_OBJ = @JSON_OBJ@
KQUEUE_CFLAGS = @KQUEUE_CFLAGS@
KQUEUE_LIBS = @KQUEUE_LIBS@
KRB4LIB = @KRB4LIB@
KRB5LIB = @KRB5LIB@
+LCMS2_CFLAGS = @LCMS2_CFLAGS@
+LCMS2_LIBS = @LCMS2_LIBS@
LDFLAGS = @LDFLAGS@
LD_SWITCH_SYSTEM = @LD_SWITCH_SYSTEM@
LD_SWITCH_SYSTEM_TEMACS = @LD_SWITCH_SYSTEM_TEMACS@
@@ -558,7 +705,6 @@ LIBGPM = @LIBGPM@
LIBHESIOD = @LIBHESIOD@
LIBINTL = @LIBINTL@
LIBJPEG = @LIBJPEG@
-LIBLCMS2 = @LIBLCMS2@
LIBMODULES = @LIBMODULES@
LIBOBJS = @LIBOBJS@
LIBOTF_CFLAGS = @LIBOTF_CFLAGS@
@@ -590,7 +736,6 @@ LIB_ACL = @LIB_ACL@
LIB_CLOCK_GETTIME = @LIB_CLOCK_GETTIME@
LIB_EACCESS = @LIB_EACCESS@
LIB_EXECINFO = @LIB_EXECINFO@
-LIB_FDATASYNC = @LIB_FDATASYNC@
LIB_MATH = @LIB_MATH@
LIB_PTHREAD = @LIB_PTHREAD@
LIB_PTHREAD_SIGMASK = @LIB_PTHREAD_SIGMASK@
@@ -668,6 +813,7 @@ PKG_CONFIG = @PKG_CONFIG@
PKG_CONFIG_LIBDIR = @PKG_CONFIG_LIBDIR@
PKG_CONFIG_PATH = @PKG_CONFIG_PATH@
PNG_CFLAGS = @PNG_CFLAGS@
+PNG_LIBS = @PNG_LIBS@
POST_ALLOC_OBJ = @POST_ALLOC_OBJ@
PRAGMA_COLUMNS = @PRAGMA_COLUMNS@
PRAGMA_SYSTEM_HEADER = @PRAGMA_SYSTEM_HEADER@
@@ -716,8 +862,10 @@ REPLACE_GETGROUPS = @REPLACE_GETGROUPS@
REPLACE_GETLINE = @REPLACE_GETLINE@
REPLACE_GETLOGIN_R = @REPLACE_GETLOGIN_R@
REPLACE_GETPAGESIZE = @REPLACE_GETPAGESIZE@
+REPLACE_GETPASS = @REPLACE_GETPASS@
REPLACE_GETTIMEOFDAY = @REPLACE_GETTIMEOFDAY@
REPLACE_GMTIME = @REPLACE_GMTIME@
+REPLACE_INITSTATE = @REPLACE_INITSTATE@
REPLACE_ISATTY = @REPLACE_ISATTY@
REPLACE_LCHOWN = @REPLACE_LCHOWN@
REPLACE_LINK = @REPLACE_LINK@
@@ -753,6 +901,7 @@ REPLACE_PUTENV = @REPLACE_PUTENV@
REPLACE_PWRITE = @REPLACE_PWRITE@
REPLACE_QSORT_R = @REPLACE_QSORT_R@
REPLACE_RAISE = @REPLACE_RAISE@
+REPLACE_RANDOM = @REPLACE_RANDOM@
REPLACE_RANDOM_R = @REPLACE_RANDOM_R@
REPLACE_READ = @REPLACE_READ@
REPLACE_READLINK = @REPLACE_READLINK@
@@ -765,6 +914,7 @@ REPLACE_RENAMEAT = @REPLACE_RENAMEAT@
REPLACE_RMDIR = @REPLACE_RMDIR@
REPLACE_SELECT = @REPLACE_SELECT@
REPLACE_SETENV = @REPLACE_SETENV@
+REPLACE_SETSTATE = @REPLACE_SETSTATE@
REPLACE_SLEEP = @REPLACE_SLEEP@
REPLACE_SNPRINTF = @REPLACE_SNPRINTF@
REPLACE_SPRINTF = @REPLACE_SPRINTF@
@@ -786,6 +936,7 @@ REPLACE_STRSTR = @REPLACE_STRSTR@
REPLACE_STRTOD = @REPLACE_STRTOD@
REPLACE_STRTOIMAX = @REPLACE_STRTOIMAX@
REPLACE_STRTOK_R = @REPLACE_STRTOK_R@
+REPLACE_STRTOLD = @REPLACE_STRTOLD@
REPLACE_STRTOUMAX = @REPLACE_STRTOUMAX@
REPLACE_STRUCT_TIMEVAL = @REPLACE_STRUCT_TIMEVAL@
REPLACE_SYMLINK = @REPLACE_SYMLINK@
@@ -868,6 +1019,7 @@ XMKMF = @XMKMF@
XOBJ = @XOBJ@
XRANDR_CFLAGS = @XRANDR_CFLAGS@
XRANDR_LIBS = @XRANDR_LIBS@
+XRENDER_LIBS = @XRENDER_LIBS@
XWIDGETS_OBJ = @XWIDGETS_OBJ@
X_TOOLKIT_TYPE = @X_TOOLKIT_TYPE@
ac_ct_CC = @ac_ct_CC@
@@ -898,7 +1050,9 @@ gamegroup = @gamegroup@
gameuser = @gameuser@
gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7 = @gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7@
gl_GNULIB_ENABLED_2049e887c7e5308faad27b3f894bb8c9 = @gl_GNULIB_ENABLED_2049e887c7e5308faad27b3f894bb8c9@
+gl_GNULIB_ENABLED_21ee726a3540c09237a8e70c0baf7467 = @gl_GNULIB_ENABLED_21ee726a3540c09237a8e70c0baf7467@
gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b = @gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b@
+gl_GNULIB_ENABLED_37f71b604aa9c54446783d80f42fe547 = @gl_GNULIB_ENABLED_37f71b604aa9c54446783d80f42fe547@
gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31 = @gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31@
gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c = @gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c@
gl_GNULIB_ENABLED_682e609604ccaac6be382e4ee3a4eaec = @gl_GNULIB_ENABLED_682e609604ccaac6be382e4ee3a4eaec@
@@ -906,7 +1060,6 @@ 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_dosname = @gl_GNULIB_ENABLED_dosname@
gl_GNULIB_ENABLED_euidaccess = @gl_GNULIB_ENABLED_euidaccess@
gl_GNULIB_ENABLED_getdtablesize = @gl_GNULIB_ENABLED_getdtablesize@
gl_GNULIB_ENABLED_getgroups = @gl_GNULIB_ENABLED_getgroups@
@@ -997,7 +1150,7 @@ ifneq (,$(GL_GENERATE_ALLOCA_H))
alloca.h: alloca.in.h $(top_builddir)/config.status
$(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
- cat $(srcdir)/alloca.in.h; \
+ sed -e 's|@''HAVE_ALLOCA_H''@|$(HAVE_ALLOCA_H)|g' < $(srcdir)/alloca.in.h; \
} > $@-t && \
mv -f $@-t $@
else
@@ -1145,45 +1298,45 @@ EXTRA_DIST += count-trailing-zeros.h
endif
## end gnulib module count-trailing-zeros
-## begin gnulib module crypto/md5
-ifeq (,$(OMIT_GNULIB_MODULE_crypto/md5))
+## begin gnulib module crypto/md5-buffer
+ifeq (,$(OMIT_GNULIB_MODULE_crypto/md5-buffer))
libgnu_a_SOURCES += md5.c
EXTRA_DIST += gl_openssl.h md5.h
endif
-## end gnulib module crypto/md5
+## end gnulib module crypto/md5-buffer
-## begin gnulib module crypto/sha1
-ifeq (,$(OMIT_GNULIB_MODULE_crypto/sha1))
+## begin gnulib module crypto/sha1-buffer
+ifeq (,$(OMIT_GNULIB_MODULE_crypto/sha1-buffer))
libgnu_a_SOURCES += sha1.c
EXTRA_DIST += gl_openssl.h sha1.h
endif
-## end gnulib module crypto/sha1
+## end gnulib module crypto/sha1-buffer
-## begin gnulib module crypto/sha256
-ifeq (,$(OMIT_GNULIB_MODULE_crypto/sha256))
+## begin gnulib module crypto/sha256-buffer
+ifeq (,$(OMIT_GNULIB_MODULE_crypto/sha256-buffer))
libgnu_a_SOURCES += sha256.c
EXTRA_DIST += gl_openssl.h sha256.h
endif
-## end gnulib module crypto/sha256
+## end gnulib module crypto/sha256-buffer
-## begin gnulib module crypto/sha512
-ifeq (,$(OMIT_GNULIB_MODULE_crypto/sha512))
+## begin gnulib module crypto/sha512-buffer
+ifeq (,$(OMIT_GNULIB_MODULE_crypto/sha512-buffer))
libgnu_a_SOURCES += sha512.c
EXTRA_DIST += gl_openssl.h sha512.h
endif
-## end gnulib module crypto/sha512
+## end gnulib module crypto/sha512-buffer
## begin gnulib module diffseq
ifeq (,$(OMIT_GNULIB_MODULE_diffseq))
@@ -1259,9 +1412,7 @@ endif
## begin gnulib module dosname
ifeq (,$(OMIT_GNULIB_MODULE_dosname))
-ifneq (,$(gl_GNULIB_ENABLED_dosname))
-endif
EXTRA_DIST += dosname.h
endif
@@ -1444,17 +1595,6 @@ EXTRA_DIST += fcntl.in.h
endif
## end gnulib module fcntl-h
-## begin gnulib module fdatasync
-ifeq (,$(OMIT_GNULIB_MODULE_fdatasync))
-
-
-EXTRA_DIST += fdatasync.c
-
-EXTRA_libgnu_a_SOURCES += fdatasync.c
-
-endif
-## end gnulib module fdatasync
-
## begin gnulib module fdopendir
ifeq (,$(OMIT_GNULIB_MODULE_fdopendir))
@@ -1517,6 +1657,17 @@ EXTRA_libgnu_a_SOURCES += at-func.c fstatat.c
endif
## end gnulib module fstatat
+## begin gnulib module fsusage
+ifeq (,$(OMIT_GNULIB_MODULE_fsusage))
+
+
+EXTRA_DIST += fsusage.c fsusage.h
+
+EXTRA_libgnu_a_SOURCES += fsusage.c
+
+endif
+## end gnulib module fsusage
+
## begin gnulib module fsync
ifeq (,$(OMIT_GNULIB_MODULE_fsync))
@@ -1572,7 +1723,7 @@ BUILT_SOURCES += $(GETOPT_H) $(GETOPT_CDEFS_H)
# We need the following in order to create <getopt.h> when the system
# doesn't have one that works with the given compiler.
-getopt.h: getopt.in.h $(top_builddir)/config.status
+getopt.h: getopt.in.h $(top_builddir)/config.status $(ARG_NONNULL_H)
$(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's|@''GUARD_PREFIX''@|GL|g' \
@@ -1654,6 +1805,32 @@ EXTRA_libgnu_a_SOURCES += group-member.c
endif
## end gnulib module group-member
+## begin gnulib module ieee754-h
+ifeq (,$(OMIT_GNULIB_MODULE_ieee754-h))
+
+BUILT_SOURCES += $(IEEE754_H)
+
+# We need the following in order to create <ieee754.h> when the system
+# doesn't have one that works with the given compiler.
+ifneq (,$(GL_GENERATE_IEEE754_H))
+ieee754.h: ieee754.in.h $(top_builddir)/config.status
+ $(AM_V_GEN)rm -f $@-t && \
+ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
+ sed -e 's/ifndef _GL_GNULIB_HEADER/if 0/g' \
+ $(srcdir)/ieee754.in.h; \
+ } > $@-t && \
+ mv -f $@-t $@
+else
+ieee754.h: $(top_builddir)/config.status
+ rm -f $@
+endif
+MOSTLYCLEANFILES += ieee754.h ieee754.h-t
+
+EXTRA_DIST += ieee754.in.h
+
+endif
+## end gnulib module ieee754-h
+
## begin gnulib module ignore-value
ifeq (,$(OMIT_GNULIB_MODULE_ignore-value))
@@ -1700,6 +1877,7 @@ inttypes.h: inttypes.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(WARN_ON_U
-e 's/@''HAVE_DECL_IMAXDIV''@/$(HAVE_DECL_IMAXDIV)/g' \
-e 's/@''HAVE_DECL_STRTOIMAX''@/$(HAVE_DECL_STRTOIMAX)/g' \
-e 's/@''HAVE_DECL_STRTOUMAX''@/$(HAVE_DECL_STRTOUMAX)/g' \
+ -e 's/@''HAVE_IMAXDIV_T''@/$(HAVE_IMAXDIV_T)/g' \
-e 's/@''REPLACE_STRTOIMAX''@/$(REPLACE_STRTOIMAX)/g' \
-e 's/@''REPLACE_STRTOUMAX''@/$(REPLACE_STRTOUMAX)/g' \
-e 's/@''INT32_MAX_LT_INTMAX_MAX''@/$(INT32_MAX_LT_INTMAX_MAX)/g' \
@@ -1719,6 +1897,17 @@ EXTRA_DIST += inttypes.in.h
endif
## end gnulib module inttypes-incomplete
+## begin gnulib module libc-config
+ifeq (,$(OMIT_GNULIB_MODULE_libc-config))
+
+ifneq (,$(gl_GNULIB_ENABLED_21ee726a3540c09237a8e70c0baf7467))
+
+endif
+EXTRA_DIST += cdefs.h libc-config.h
+
+endif
+## end gnulib module libc-config
+
## begin gnulib module limits-h
ifeq (,$(OMIT_GNULIB_MODULE_limits-h))
@@ -1932,6 +2121,17 @@ EXTRA_libgnu_a_SOURCES += at-func.c readlinkat.c
endif
## end gnulib module readlinkat
+## begin gnulib module regex
+ifeq (,$(OMIT_GNULIB_MODULE_regex))
+
+
+EXTRA_DIST += regcomp.c regex.c regex.h regex_internal.c regex_internal.h regexec.c
+
+EXTRA_libgnu_a_SOURCES += regcomp.c regex.c regex_internal.c regexec.c
+
+endif
+## end gnulib module regex
+
## begin gnulib module root-uid
ifeq (,$(OMIT_GNULIB_MODULE_root-uid))
@@ -1969,8 +2169,8 @@ signal.h: signal.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
-e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \
-e 's|@''NEXT_SIGNAL_H''@|$(NEXT_SIGNAL_H)|g' \
- -e 's|@''GNULIB_PTHREAD_SIGMASK''@|$(GNULIB_PTHREAD_SIGMASK)|g' \
- -e 's|@''GNULIB_RAISE''@|$(GNULIB_RAISE)|g' \
+ -e 's/@''GNULIB_PTHREAD_SIGMASK''@/$(GNULIB_PTHREAD_SIGMASK)/g' \
+ -e 's/@''GNULIB_RAISE''@/$(GNULIB_RAISE)/g' \
-e 's/@''GNULIB_SIGNAL_H_SIGPIPE''@/$(GNULIB_SIGNAL_H_SIGPIPE)/g' \
-e 's/@''GNULIB_SIGPROCMASK''@/$(GNULIB_SIGPROCMASK)/g' \
-e 's/@''GNULIB_SIGACTION''@/$(GNULIB_SIGACTION)/g' \
@@ -2350,6 +2550,7 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \
-e 's/@''GNULIB_SECURE_GETENV''@/$(GNULIB_SECURE_GETENV)/g' \
-e 's/@''GNULIB_SETENV''@/$(GNULIB_SETENV)/g' \
-e 's/@''GNULIB_STRTOD''@/$(GNULIB_STRTOD)/g' \
+ -e 's/@''GNULIB_STRTOLD''@/$(GNULIB_STRTOLD)/g' \
-e 's/@''GNULIB_STRTOLL''@/$(GNULIB_STRTOLL)/g' \
-e 's/@''GNULIB_STRTOULL''@/$(GNULIB_STRTOULL)/g' \
-e 's/@''GNULIB_SYSTEM_POSIX''@/$(GNULIB_SYSTEM_POSIX)/g' \
@@ -2363,7 +2564,9 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \
-e 's|@''HAVE_DECL_GETLOADAVG''@|$(HAVE_DECL_GETLOADAVG)|g' \
-e 's|@''HAVE_GETSUBOPT''@|$(HAVE_GETSUBOPT)|g' \
-e 's|@''HAVE_GRANTPT''@|$(HAVE_GRANTPT)|g' \
+ -e 's|@''HAVE_INITSTATE''@|$(HAVE_INITSTATE)|g' \
-e 's|@''HAVE_DECL_INITSTATE''@|$(HAVE_DECL_INITSTATE)|g' \
+ -e 's|@''HAVE_MBTOWC''@|$(HAVE_MBTOWC)|g' \
-e 's|@''HAVE_MKDTEMP''@|$(HAVE_MKDTEMP)|g' \
-e 's|@''HAVE_MKOSTEMP''@|$(HAVE_MKOSTEMP)|g' \
-e 's|@''HAVE_MKOSTEMPS''@|$(HAVE_MKOSTEMPS)|g' \
@@ -2381,8 +2584,10 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \
-e 's|@''HAVE_RPMATCH''@|$(HAVE_RPMATCH)|g' \
-e 's|@''HAVE_SECURE_GETENV''@|$(HAVE_SECURE_GETENV)|g' \
-e 's|@''HAVE_DECL_SETENV''@|$(HAVE_DECL_SETENV)|g' \
+ -e 's|@''HAVE_SETSTATE''@|$(HAVE_SETSTATE)|g' \
-e 's|@''HAVE_DECL_SETSTATE''@|$(HAVE_DECL_SETSTATE)|g' \
-e 's|@''HAVE_STRTOD''@|$(HAVE_STRTOD)|g' \
+ -e 's|@''HAVE_STRTOLD''@|$(HAVE_STRTOLD)|g' \
-e 's|@''HAVE_STRTOLL''@|$(HAVE_STRTOLL)|g' \
-e 's|@''HAVE_STRTOULL''@|$(HAVE_STRTOULL)|g' \
-e 's|@''HAVE_STRUCT_RANDOM_DATA''@|$(HAVE_STRUCT_RANDOM_DATA)|g' \
@@ -2391,6 +2596,7 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \
-e 's|@''HAVE_DECL_UNSETENV''@|$(HAVE_DECL_UNSETENV)|g' \
-e 's|@''REPLACE_CALLOC''@|$(REPLACE_CALLOC)|g' \
-e 's|@''REPLACE_CANONICALIZE_FILE_NAME''@|$(REPLACE_CANONICALIZE_FILE_NAME)|g' \
+ -e 's|@''REPLACE_INITSTATE''@|$(REPLACE_INITSTATE)|g' \
-e 's|@''REPLACE_MALLOC''@|$(REPLACE_MALLOC)|g' \
-e 's|@''REPLACE_MBTOWC''@|$(REPLACE_MBTOWC)|g' \
-e 's|@''REPLACE_MKSTEMP''@|$(REPLACE_MKSTEMP)|g' \
@@ -2398,11 +2604,14 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \
-e 's|@''REPLACE_PTSNAME_R''@|$(REPLACE_PTSNAME_R)|g' \
-e 's|@''REPLACE_PUTENV''@|$(REPLACE_PUTENV)|g' \
-e 's|@''REPLACE_QSORT_R''@|$(REPLACE_QSORT_R)|g' \
+ -e 's|@''REPLACE_RANDOM''@|$(REPLACE_RANDOM)|g' \
-e 's|@''REPLACE_RANDOM_R''@|$(REPLACE_RANDOM_R)|g' \
-e 's|@''REPLACE_REALLOC''@|$(REPLACE_REALLOC)|g' \
-e 's|@''REPLACE_REALPATH''@|$(REPLACE_REALPATH)|g' \
-e 's|@''REPLACE_SETENV''@|$(REPLACE_SETENV)|g' \
+ -e 's|@''REPLACE_SETSTATE''@|$(REPLACE_SETSTATE)|g' \
-e 's|@''REPLACE_STRTOD''@|$(REPLACE_STRTOD)|g' \
+ -e 's|@''REPLACE_STRTOLD''@|$(REPLACE_STRTOLD)|g' \
-e 's|@''REPLACE_UNSETENV''@|$(REPLACE_UNSETENV)|g' \
-e 's|@''REPLACE_WCTOMB''@|$(REPLACE_WCTOMB)|g' \
-e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \
@@ -2910,6 +3119,7 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's/@''GNULIB_GETLOGIN''@/$(GNULIB_GETLOGIN)/g' \
-e 's/@''GNULIB_GETLOGIN_R''@/$(GNULIB_GETLOGIN_R)/g' \
-e 's/@''GNULIB_GETPAGESIZE''@/$(GNULIB_GETPAGESIZE)/g' \
+ -e 's/@''GNULIB_GETPASS''@/$(GNULIB_GETPASS)/g' \
-e 's/@''GNULIB_GETUSERSHELL''@/$(GNULIB_GETUSERSHELL)/g' \
-e 's/@''GNULIB_GROUP_MEMBER''@/$(GNULIB_GROUP_MEMBER)/g' \
-e 's/@''GNULIB_ISATTY''@/$(GNULIB_ISATTY)/g' \
@@ -2953,6 +3163,7 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's|@''HAVE_GETGROUPS''@|$(HAVE_GETGROUPS)|g' \
-e 's|@''HAVE_GETHOSTNAME''@|$(HAVE_GETHOSTNAME)|g' \
-e 's|@''HAVE_GETPAGESIZE''@|$(HAVE_GETPAGESIZE)|g' \
+ -e 's|@''HAVE_GETPASS''@|$(HAVE_GETPASS)|g' \
-e 's|@''HAVE_GROUP_MEMBER''@|$(HAVE_GROUP_MEMBER)|g' \
-e 's|@''HAVE_LCHOWN''@|$(HAVE_LCHOWN)|g' \
-e 's|@''HAVE_LINK''@|$(HAVE_LINK)|g' \
@@ -2967,7 +3178,6 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's|@''HAVE_SLEEP''@|$(HAVE_SLEEP)|g' \
-e 's|@''HAVE_SYMLINK''@|$(HAVE_SYMLINK)|g' \
-e 's|@''HAVE_SYMLINKAT''@|$(HAVE_SYMLINKAT)|g' \
- -e 's|@''HAVE_TRUNCATE''@|$(HAVE_TRUNCATE)|g' \
-e 's|@''HAVE_UNLINKAT''@|$(HAVE_UNLINKAT)|g' \
-e 's|@''HAVE_USLEEP''@|$(HAVE_USLEEP)|g' \
-e 's|@''HAVE_DECL_ENVIRON''@|$(HAVE_DECL_ENVIRON)|g' \
@@ -2979,6 +3189,7 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's|@''HAVE_DECL_GETPAGESIZE''@|$(HAVE_DECL_GETPAGESIZE)|g' \
-e 's|@''HAVE_DECL_GETUSERSHELL''@|$(HAVE_DECL_GETUSERSHELL)|g' \
-e 's|@''HAVE_DECL_SETHOSTNAME''@|$(HAVE_DECL_SETHOSTNAME)|g' \
+ -e 's|@''HAVE_DECL_TRUNCATE''@|$(HAVE_DECL_TRUNCATE)|g' \
-e 's|@''HAVE_DECL_TTYNAME_R''@|$(HAVE_DECL_TTYNAME_R)|g' \
-e 's|@''HAVE_OS_H''@|$(HAVE_OS_H)|g' \
-e 's|@''HAVE_SYS_PARAM_H''@|$(HAVE_SYS_PARAM_H)|g' \
@@ -2996,6 +3207,7 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's|@''REPLACE_GETLOGIN_R''@|$(REPLACE_GETLOGIN_R)|g' \
-e 's|@''REPLACE_GETGROUPS''@|$(REPLACE_GETGROUPS)|g' \
-e 's|@''REPLACE_GETPAGESIZE''@|$(REPLACE_GETPAGESIZE)|g' \
+ -e 's|@''REPLACE_GETPASS''@|$(REPLACE_GETPASS)|g' \
-e 's|@''REPLACE_ISATTY''@|$(REPLACE_ISATTY)|g' \
-e 's|@''REPLACE_LCHOWN''@|$(REPLACE_LCHOWN)|g' \
-e 's|@''REPLACE_LINK''@|$(REPLACE_LINK)|g' \
diff --git a/lib/group-member.c b/lib/group-member.c
index a14056f9a82..ad61cf0b630 100644
--- a/lib/group-member.c
+++ b/lib/group-member.c
@@ -1,7 +1,7 @@
/* group-member.c -- determine whether group id is in calling user's group list
- Copyright (C) 1994, 1997-1998, 2003, 2005-2006, 2009-2019 Free
- Software Foundation, Inc.
+ Copyright (C) 1994, 1997-1998, 2003, 2005-2006, 2009-2019 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
diff --git a/lib/ieee754.in.h b/lib/ieee754.in.h
new file mode 100644
index 00000000000..a079e59d791
--- /dev/null
+++ b/lib/ieee754.in.h
@@ -0,0 +1,222 @@
+/* Copyright (C) 1992-2019 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
+ <http://www.gnu.org/licenses/>. */
+
+#ifndef _IEEE754_H
+
+#define _IEEE754_H 1
+
+#ifndef _GL_GNULIB_HEADER
+/* Ordinary glibc usage. */
+# include <features.h>
+# include <endian.h>
+#else
+/* Gnulib usage. */
+# ifndef __BEGIN_DECLS
+# ifdef __cplusplus
+# define __BEGIN_DECLS extern "C" {
+# define __END_DECLS }
+# else
+# define __BEGIN_DECLS
+# define __END_DECLS
+# endif
+# endif
+# ifndef __FLOAT_WORD_ORDER
+# define __LITTLE_ENDIAN 1234
+# define __BIG_ENDIAN 4321
+# ifdef WORDS_BIGENDIAN
+# define __BYTE_ORDER __BIG_ENDIAN
+# else
+# define __BYTE_ORDER __LITTLE_ENDIAN
+# endif
+# define __FLOAT_WORD_ORDER __BYTE_ORDER
+# endif
+#endif
+
+__BEGIN_DECLS
+
+union ieee754_float
+ {
+ float f;
+
+ /* This is the IEEE 754 single-precision format. */
+ struct
+ {
+#if __BYTE_ORDER == __BIG_ENDIAN
+ unsigned int negative:1;
+ unsigned int exponent:8;
+ unsigned int mantissa:23;
+#endif /* Big endian. */
+#if __BYTE_ORDER == __LITTLE_ENDIAN
+ unsigned int mantissa:23;
+ unsigned int exponent:8;
+ unsigned int negative:1;
+#endif /* Little endian. */
+ } ieee;
+
+ /* This format makes it easier to see if a NaN is a signalling NaN. */
+ struct
+ {
+#if __BYTE_ORDER == __BIG_ENDIAN
+ unsigned int negative:1;
+ unsigned int exponent:8;
+ unsigned int quiet_nan:1;
+ unsigned int mantissa:22;
+#endif /* Big endian. */
+#if __BYTE_ORDER == __LITTLE_ENDIAN
+ unsigned int mantissa:22;
+ unsigned int quiet_nan:1;
+ unsigned int exponent:8;
+ unsigned int negative:1;
+#endif /* Little endian. */
+ } ieee_nan;
+ };
+
+#define IEEE754_FLOAT_BIAS 0x7f /* Added to exponent. */
+
+
+union ieee754_double
+ {
+ double d;
+
+ /* This is the IEEE 754 double-precision format. */
+ struct
+ {
+#if __BYTE_ORDER == __BIG_ENDIAN
+ unsigned int negative:1;
+ unsigned int exponent:11;
+ /* Together these comprise the mantissa. */
+ unsigned int mantissa0:20;
+ unsigned int mantissa1:32;
+#endif /* Big endian. */
+#if __BYTE_ORDER == __LITTLE_ENDIAN
+# if __FLOAT_WORD_ORDER == __BIG_ENDIAN
+ unsigned int mantissa0:20;
+ unsigned int exponent:11;
+ unsigned int negative:1;
+ unsigned int mantissa1:32;
+# else
+ /* Together these comprise the mantissa. */
+ unsigned int mantissa1:32;
+ unsigned int mantissa0:20;
+ unsigned int exponent:11;
+ unsigned int negative:1;
+# endif
+#endif /* Little endian. */
+ } ieee;
+
+ /* This format makes it easier to see if a NaN is a signalling NaN. */
+ struct
+ {
+#if __BYTE_ORDER == __BIG_ENDIAN
+ unsigned int negative:1;
+ unsigned int exponent:11;
+ unsigned int quiet_nan:1;
+ /* Together these comprise the mantissa. */
+ unsigned int mantissa0:19;
+ unsigned int mantissa1:32;
+#else
+# if __FLOAT_WORD_ORDER == __BIG_ENDIAN
+ unsigned int mantissa0:19;
+ unsigned int quiet_nan:1;
+ unsigned int exponent:11;
+ unsigned int negative:1;
+ unsigned int mantissa1:32;
+# else
+ /* Together these comprise the mantissa. */
+ unsigned int mantissa1:32;
+ unsigned int mantissa0:19;
+ unsigned int quiet_nan:1;
+ unsigned int exponent:11;
+ unsigned int negative:1;
+# endif
+#endif
+ } ieee_nan;
+ };
+
+#define IEEE754_DOUBLE_BIAS 0x3ff /* Added to exponent. */
+
+
+union ieee854_long_double
+ {
+ long double d;
+
+ /* This is the IEEE 854 double-extended-precision format. */
+ struct
+ {
+#if __BYTE_ORDER == __BIG_ENDIAN
+ unsigned int negative:1;
+ unsigned int exponent:15;
+ unsigned int empty:16;
+ unsigned int mantissa0:32;
+ unsigned int mantissa1:32;
+#endif
+#if __BYTE_ORDER == __LITTLE_ENDIAN
+# if __FLOAT_WORD_ORDER == __BIG_ENDIAN
+ unsigned int exponent:15;
+ unsigned int negative:1;
+ unsigned int empty:16;
+ unsigned int mantissa0:32;
+ unsigned int mantissa1:32;
+# else
+ unsigned int mantissa1:32;
+ unsigned int mantissa0:32;
+ unsigned int exponent:15;
+ unsigned int negative:1;
+ unsigned int empty:16;
+# endif
+#endif
+ } ieee;
+
+ /* This is for NaNs in the IEEE 854 double-extended-precision format. */
+ struct
+ {
+#if __BYTE_ORDER == __BIG_ENDIAN
+ unsigned int negative:1;
+ unsigned int exponent:15;
+ unsigned int empty:16;
+ unsigned int one:1;
+ unsigned int quiet_nan:1;
+ unsigned int mantissa0:30;
+ unsigned int mantissa1:32;
+#endif
+#if __BYTE_ORDER == __LITTLE_ENDIAN
+# if __FLOAT_WORD_ORDER == __BIG_ENDIAN
+ unsigned int exponent:15;
+ unsigned int negative:1;
+ unsigned int empty:16;
+ unsigned int mantissa0:30;
+ unsigned int quiet_nan:1;
+ unsigned int one:1;
+ unsigned int mantissa1:32;
+# else
+ unsigned int mantissa1:32;
+ unsigned int mantissa0:30;
+ unsigned int quiet_nan:1;
+ unsigned int one:1;
+ unsigned int exponent:15;
+ unsigned int negative:1;
+ unsigned int empty:16;
+# endif
+#endif
+ } ieee_nan;
+ };
+
+#define IEEE854_LONG_DOUBLE_BIAS 0x3fff
+
+__END_DECLS
+
+#endif /* ieee754.h */
diff --git a/lib/intprops.h b/lib/intprops.h
index 592371469d4..1a44ae55653 100644
--- a/lib/intprops.h
+++ b/lib/intprops.h
@@ -22,12 +22,13 @@
#include <limits.h>
-/* Return a value with the common real type of E and V and the value of V. */
-#define _GL_INT_CONVERT(e, v) (0 * (e) + (v))
+/* Return a value with the common real type of E and V and the value of V.
+ Do not evaluate E. */
+#define _GL_INT_CONVERT(e, v) ((1 ? 0 : (e)) + (v))
/* Act like _GL_INT_CONVERT (E, -V) but work around a bug in IRIX 6.5 cc; see
<https://lists.gnu.org/r/bug-gnulib/2011-05/msg00406.html>. */
-#define _GL_INT_NEGATE_CONVERT(e, v) (0 * (e) - (v))
+#define _GL_INT_NEGATE_CONVERT(e, v) ((1 ? 0 : (e)) - (v))
/* The extra casts in the following macros work around compiler bugs,
e.g., in Cray C 5.0.3.0. */
@@ -40,13 +41,14 @@
#define TYPE_SIGNED(t) (! ((t) 0 < (t) -1))
/* Return 1 if the real expression E, after promotion, has a
- signed or floating type. */
+ signed or floating type. Do not evaluate E. */
#define EXPR_SIGNED(e) (_GL_INT_NEGATE_CONVERT (e, 1) < 0)
/* Minimum and maximum values for integer types and expressions. */
/* The width in bits of the integer type or expression T.
+ Do not evaluate T.
Padding bits are not supported; this is checked at compile-time below. */
#define TYPE_WIDTH(t) (sizeof (t) * CHAR_BIT)
@@ -58,7 +60,7 @@
: ((((t) 1 << (TYPE_WIDTH (t) - 2)) - 1) * 2 + 1)))
/* The maximum and minimum values for the type of the expression E,
- after integer promotion. E should not have side effects. */
+ after integer promotion. E is not evaluated. */
#define _GL_INT_MINIMUM(e) \
(EXPR_SIGNED (e) \
? ~ _GL_SIGNED_INT_MAXIMUM (e) \
@@ -340,8 +342,8 @@
Arguments should be free of side effects. */
#define _GL_BINARY_OP_OVERFLOW(a, b, op_result_overflow) \
op_result_overflow (a, b, \
- _GL_INT_MINIMUM (0 * (b) + (a)), \
- _GL_INT_MAXIMUM (0 * (b) + (a)))
+ _GL_INT_MINIMUM (_GL_INT_CONVERT (a, b)), \
+ _GL_INT_MAXIMUM (_GL_INT_CONVERT (a, b)))
/* Store the low-order bits of A + B, A - B, A * B, respectively, into *R.
Return 1 if the result overflows. See above for restrictions. */
diff --git a/lib/inttypes.in.h b/lib/inttypes.in.h
index 8fe89db4659..d3c735c12ce 100644
--- a/lib/inttypes.in.h
+++ b/lib/inttypes.in.h
@@ -52,7 +52,7 @@
/* Get CHAR_BIT. */
#include <limits.h>
/* On mingw, __USE_MINGW_ANSI_STDIO only works if <stdio.h> is also included */
-#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+#if defined _WIN32 && ! defined __CYGWIN__
# include <stdio.h>
#endif
@@ -1067,11 +1067,13 @@ _GL_WARN_ON_USE (imaxabs, "imaxabs is unportable - "
#endif
#if @GNULIB_IMAXDIV@
-# if !@HAVE_DECL_IMAXDIV@
+# if !@HAVE_IMAXDIV_T@
# if !GNULIB_defined_imaxdiv_t
typedef struct { intmax_t quot; intmax_t rem; } imaxdiv_t;
# define GNULIB_defined_imaxdiv_t 1
# endif
+# endif
+# if !@HAVE_DECL_IMAXDIV@
extern imaxdiv_t imaxdiv (intmax_t, intmax_t);
# endif
#elif defined GNULIB_POSIXCHECK
diff --git a/lib/libc-config.h b/lib/libc-config.h
new file mode 100644
index 00000000000..57c69661d2f
--- /dev/null
+++ b/lib/libc-config.h
@@ -0,0 +1,174 @@
+/* System definitions for code taken from the GNU C Library
+
+ Copyright 2017-2019 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
+ <https://www.gnu.org/licenses/>. */
+
+/* Written by Paul Eggert. */
+
+/* This is intended to be a good-enough substitute for glibc system
+ macros like those defined in <sys/cdefs.h>, so that Gnulib code
+ shared with glibc can do this as the first #include:
+
+ #ifndef _LIBC
+ # include <libc-config.h>
+ #endif
+
+ When compiled as part of glibc this is a no-op; when compiled as
+ part of Gnulib this includes Gnulib's <config.h> and defines macros
+ that glibc library code would normally assume. */
+
+#include <config.h>
+
+/* On glibc this includes <features.h> and <sys/cdefs.h> and #defines
+ _FEATURES_H, __WORDSIZE, and __set_errno. On FreeBSD 11 it
+ includes <sys/cdefs.h> which defines __nonnull. Elsewhere it
+ is harmless. */
+#include <errno.h>
+
+/* From glibc <errno.h>. */
+#ifndef __set_errno
+# define __set_errno(val) (errno = (val))
+#endif
+
+/* From glibc <features.h>. */
+
+#ifndef __GNUC_PREREQ
+# if defined __GNUC__ && defined __GNUC_MINOR__
+# define __GNUC_PREREQ(maj, min) ((maj) < __GNUC__ + ((min) <= __GNUC_MINOR__))
+# else
+# define __GNUC_PREREQ(maj, min) 0
+# endif
+#endif
+
+#ifndef __glibc_clang_prereq
+# if defined __clang_major__ && defined __clang_minor__
+# define __glibc_clang_prereq(maj, min) \
+ ((maj) < __clang_major__ + ((min) <= __clang_minor__))
+# else
+# define __glibc_clang_prereq(maj, min) 0
+# endif
+#endif
+
+
+/* Prepare to include <cdefs.h>, which is our copy of glibc
+ <sys/cdefs.h>. */
+
+/* Define _FEATURES_H so that <cdefs.h> does not include <features.h>. */
+#ifndef _FEATURES_H
+# define _FEATURES_H 1
+#endif
+/* Define __WORDSIZE so that <cdefs.h> 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
+/* Undef the macros unconditionally defined by our copy of glibc
+ <sys/cdefs.h>, 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
+
+/* Include our copy of glibc <sys/cdefs.h>. */
+#include <cdefs.h>
+
+/* <cdefs.h> __inline is too pessimistic for non-GCC. */
+#undef __inline
+#ifndef HAVE___INLINE
+# if 199901 <= __STDC_VERSION__ || defined inline
+# define __inline inline
+# else
+# define __inline
+# endif
+#endif
+
+
+/* A substitute for glibc <libc-symbols.h>, good enough for Gnulib. */
+#define attribute_hidden
+#define libc_hidden_proto(name, ...)
+#define libc_hidden_def(name)
+#define libc_hidden_weak(name)
+#define libc_hidden_ver(local, name)
+#define strong_alias(name, aliasname)
+#define weak_alias(name, aliasname)
+
+/* A substitute for glibc <shlib-compat.h>, good enough for Gnulib. */
+#define SHLIB_COMPAT(lib, introduced, obsoleted) 0
+#define versioned_symbol(lib, local, symbol, version)
diff --git a/lib/limits.in.h b/lib/limits.in.h
index 0788a4e67e6..39750b38d1a 100644
--- a/lib/limits.in.h
+++ b/lib/limits.in.h
@@ -28,15 +28,32 @@
#ifndef _@GUARD_PREFIX@_LIMITS_H
#define _@GUARD_PREFIX@_LIMITS_H
-/* For HP-UX 11.31. */
-#if defined LONG_LONG_MIN && !defined LLONG_MIN
-# define LLONG_MIN LONG_LONG_MIN
+#ifndef LLONG_MIN
+# if defined LONG_LONG_MIN /* HP-UX 11.31 */
+# define LLONG_MIN LONG_LONG_MIN
+# elif defined LONGLONG_MIN /* IRIX 6.5 */
+# define LLONG_MIN LONGLONG_MIN
+# elif defined __GNUC__
+# define LLONG_MIN (- __LONG_LONG_MAX__ - 1LL)
+# endif
#endif
-#if defined LONG_LONG_MAX && !defined LLONG_MAX
-# define LLONG_MAX LONG_LONG_MAX
+#ifndef LLONG_MAX
+# if defined LONG_LONG_MAX /* HP-UX 11.31 */
+# define LLONG_MAX LONG_LONG_MAX
+# elif defined LONGLONG_MAX /* IRIX 6.5 */
+# define LLONG_MAX LONGLONG_MAX
+# elif defined __GNUC__
+# define LLONG_MAX __LONG_LONG_MAX__
+# endif
#endif
-#if defined ULONG_LONG_MAX && !defined ULLONG_MAX
-# define ULLONG_MAX ULONG_LONG_MAX
+#ifndef ULLONG_MAX
+# if defined ULONG_LONG_MAX /* HP-UX 11.31 */
+# define ULLONG_MAX ULONG_LONG_MAX
+# elif defined ULONGLONG_MAX /* IRIX 6.5 */
+# define ULLONG_MAX ULONGLONG_MAX
+# elif defined __GNUC__
+# define ULLONG_MAX (__LONG_LONG_MAX__ * 2ULL + 1ULL)
+# endif
#endif
/* The number of usable bits in an unsigned or signed integer type
@@ -53,6 +70,19 @@
#define _GL_COB8(n) (_GL_COB4 ((n) >> 4) + _GL_COB4 (n))
#define _GL_COB4(n) (!!((n) & 8) + !!((n) & 4) + !!((n) & 2) + !!((n) & 1))
+#ifndef WORD_BIT
+/* Assume 'int' is 32 bits wide. */
+# define WORD_BIT 32
+#endif
+#ifndef LONG_BIT
+/* Assume 'long' is 32 or 64 bits wide. */
+# if LONG_MAX == INT_MAX
+# define LONG_BIT 32
+# else
+# define LONG_BIT 64
+# endif
+#endif
+
/* Macros specified by ISO/IEC TS 18661-1:2014. */
#if (! defined ULLONG_WIDTH \
diff --git a/lib/localtime-buffer.c b/lib/localtime-buffer.c
index f98e0b8f37a..b65ea45af20 100644
--- a/lib/localtime-buffer.c
+++ b/lib/localtime-buffer.c
@@ -1,7 +1,6 @@
/* Provide access to the last buffer returned by localtime() or gmtime().
- Copyright (C) 2001-2003, 2005-2007, 2009-2019 Free Software
- Foundation, Inc.
+ Copyright (C) 2001-2003, 2005-2007, 2009-2019 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
@@ -35,6 +34,7 @@ struct tm *localtime_buffer_addr = &tm_zero_buffer;
struct tm *
rpl_localtime (time_t const *timep)
+#undef localtime
{
struct tm *tm = localtime (timep);
@@ -47,6 +47,7 @@ rpl_localtime (time_t const *timep)
/* Same as above, since gmtime and localtime use the same buffer. */
struct tm *
rpl_gmtime (time_t const *timep)
+#undef gmtime
{
struct tm *tm = gmtime (timep);
diff --git a/lib/localtime-buffer.h b/lib/localtime-buffer.h
index cf15cbd3433..031111a752f 100644
--- a/lib/localtime-buffer.h
+++ b/lib/localtime-buffer.h
@@ -1,7 +1,6 @@
/* Provide access to the last buffer returned by localtime() or gmtime().
- Copyright (C) 2001-2003, 2005-2007, 2009-2019 Free Software
- Foundation, Inc.
+ Copyright (C) 2001-2003, 2005-2007, 2009-2019 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
diff --git a/lib/lstat.c b/lib/lstat.c
index d57ca105fd3..a3e40d826f0 100644
--- a/lib/lstat.c
+++ b/lib/lstat.c
@@ -42,10 +42,14 @@ orig_lstat (const char *filename, struct stat *buf)
}
/* Specification. */
+# ifdef __osf__
/* Write "sys/stat.h" here, not <sys/stat.h>, otherwise OSF/1 5.1 DTK cc
eliminates this include because of the preliminary #include <sys/stat.h>
above. */
-# include "sys/stat.h"
+# include "sys/stat.h"
+# else
+# include <sys/stat.h>
+# endif
# include "stat-time.h"
diff --git a/lib/md5.c b/lib/md5.c
index 3d797ef8fea..5c8bcf91e48 100644
--- a/lib/md5.c
+++ b/lib/md5.c
@@ -1,7 +1,7 @@
/* Functions to compute MD5 message digest of files or memory blocks.
according to the definition of MD5 in RFC 1321 from April 1992.
- Copyright (C) 1995-1997, 1999-2001, 2005-2006, 2008-2019 Free
- Software Foundation, Inc.
+ Copyright (C) 1995-1997, 1999-2001, 2005-2006, 2008-2019 Free Software
+ Foundation, Inc.
This file is part of the GNU C Library.
This program is free software; you can redistribute it and/or modify it
@@ -52,9 +52,9 @@
# define md5_buffer __md5_buffer
#endif
+#include <byteswap.h>
#ifdef WORDS_BIGENDIAN
-# define SWAP(n) \
- (((n) << 24) | (((n) & 0xff00) << 8) | (((n) >> 8) & 0xff00) | ((n) >> 24))
+# define SWAP(n) bswap_32 (n)
#else
# define SWAP(n) (n)
#endif
@@ -134,21 +134,29 @@ md5_finish_ctx (struct md5_ctx *ctx, void *resbuf)
}
#endif
+#if defined _LIBC || defined GL_COMPILE_CRYPTO_STREAM
+
+#include "af_alg.h"
+
/* Compute MD5 message digest for bytes read from STREAM. The
resulting message digest number will be written into the 16 bytes
beginning at RESBLOCK. */
int
md5_stream (FILE *stream, void *resblock)
{
- struct md5_ctx ctx;
- size_t sum;
+ switch (afalg_stream (stream, "md5", resblock, MD5_DIGEST_SIZE))
+ {
+ case 0: return 0;
+ case -EIO: return 1;
+ }
char *buffer = malloc (BLOCKSIZE + 72);
if (!buffer)
return 1;
- /* Initialize the computation context. */
+ struct md5_ctx ctx;
md5_init_ctx (&ctx);
+ size_t sum;
/* Iterate over full file contents. */
while (1)
@@ -162,6 +170,14 @@ md5_stream (FILE *stream, void *resblock)
/* Read block. Take care for partial reads. */
while (1)
{
+ /* Either process a partial fread() from this loop,
+ or the fread() in afalg_stream may have gotten EOF.
+ We need to avoid a subsequent fread() as EOF may
+ not be sticky. For details of such systems, see:
+ https://sourceware.org/bugzilla/show_bug.cgi?id=1190 */
+ if (feof (stream))
+ goto process_partial_block;
+
n = fread (buffer + sum, 1, BLOCKSIZE - sum, stream);
sum += n;
@@ -181,12 +197,6 @@ md5_stream (FILE *stream, void *resblock)
}
goto process_partial_block;
}
-
- /* We've read at least one byte, so ignore errors. But always
- check for EOF, since feof may be true even though N > 0.
- Otherwise, we could end up calling fread after EOF. */
- if (feof (stream))
- goto process_partial_block;
}
/* Process buffer with BLOCKSIZE bytes. Note that
@@ -206,6 +216,7 @@ process_partial_block:
free (buffer);
return 0;
}
+#endif
#if ! HAVE_OPENSSL_MD5
/* Compute MD5 message digest for LEN bytes beginning at BUFFER. The
diff --git a/lib/md5.h b/lib/md5.h
index b41eaf42c13..478a27bc518 100644
--- a/lib/md5.h
+++ b/lib/md5.h
@@ -1,7 +1,7 @@
/* Declaration of functions and data types used for MD5 sum computing
library functions.
- Copyright (C) 1995-1997, 1999-2001, 2004-2006, 2008-2019 Free
- Software Foundation, Inc.
+ Copyright (C) 1995-1997, 1999-2001, 2004-2006, 2008-2019 Free Software
+ Foundation, Inc.
This file is part of the GNU C Library.
This program is free software; you can redistribute it and/or modify it
@@ -122,8 +122,11 @@ extern void *__md5_buffer (const char *buffer, size_t len,
void *resblock) __THROW;
# endif
-/* Compute MD5 message digest for bytes read from STREAM. The
- resulting message digest number will be written into the 16 bytes
+/* Compute MD5 message digest for bytes read from STREAM.
+ STREAM is an open file stream. Regular files are handled more efficiently.
+ The contents of STREAM from its current position to its end will be read.
+ The case that the last operation on STREAM was an 'ungetc' is not supported.
+ The resulting message digest number will be written into the 16 bytes
beginning at RESBLOCK. */
extern int __md5_stream (FILE *stream, void *resblock) __THROW;
diff --git a/lib/memrchr.c b/lib/memrchr.c
index da7c988efb6..96022835cef 100644
--- a/lib/memrchr.c
+++ b/lib/memrchr.c
@@ -1,7 +1,7 @@
/* memrchr -- find the last occurrence of a byte in a memory block
- Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2019 Free
- Software Foundation, Inc.
+ Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2019 Free Software
+ Foundation, Inc.
Based on strlen implementation by Torbjorn Granlund (tege@sics.se),
with help from Dan Sahlin (dan@sics.se) and
@@ -68,7 +68,7 @@ __memrchr (void const *s, int c_in, size_t n)
if (*--char_ptr == c)
return (void *) char_ptr;
- longword_ptr = (const longword *) char_ptr;
+ longword_ptr = (const void *) char_ptr;
/* All these elucidatory comments refer to 4-byte longwords,
but the theory applies equally well to any size longwords. */
diff --git a/lib/mktime-internal.h b/lib/mktime-internal.h
index 8d1c97faa5e..d13d89cfae7 100644
--- a/lib/mktime-internal.h
+++ b/lib/mktime-internal.h
@@ -35,3 +35,19 @@ typedef int mktime_offset_t;
time_t mktime_internal (struct tm *,
struct tm * (*) (time_t const *, struct tm *),
mktime_offset_t *);
+
+/* Although glibc source code uses leading underscores, Gnulib wants
+ ordinary names.
+
+ Portable standalone applications should supply a <time.h> that
+ declares a POSIX-compliant localtime_r, for the benefit of older
+ implementations that lack localtime_r or have a nonstandard one.
+ Similarly for gmtime_r. See the gnulib time_r module for one way
+ to implement this. */
+
+#undef __gmtime_r
+#undef __localtime_r
+#define __gmtime_r gmtime_r
+#define __localtime_r localtime_r
+
+#define __mktime_internal mktime_internal
diff --git a/lib/mktime.c b/lib/mktime.c
index 43efa0ced5c..e3783d7a95e 100644
--- a/lib/mktime.c
+++ b/lib/mktime.c
@@ -17,27 +17,21 @@
License along with the GNU C Library; if not, see
<https://www.gnu.org/licenses/>. */
-/* Define this to 1 to have a standalone program to test this implementation of
- mktime. */
-#ifndef DEBUG_MKTIME
-# define DEBUG_MKTIME 0
-#endif
-
/* The following macros influence what gets defined when this file is compiled:
Macro/expression Which gnulib module This compilation unit
should define
+ _LIBC (glibc proper) mktime
+
NEED_MKTIME_WORKING mktime rpl_mktime
|| NEED_MKTIME_WINDOWS
NEED_MKTIME_INTERNAL mktime-internal mktime_internal
-
- DEBUG_MKTIME (defined manually) my_mktime, main
*/
-#if !defined _LIBC && !DEBUG_MKTIME
-# include <config.h>
+#ifndef _LIBC
+# include <libc-config.h>
#endif
/* Assume that leap seconds are possible, unless told otherwise.
@@ -49,34 +43,74 @@
#include <time.h>
+#include <errno.h>
#include <limits.h>
#include <stdbool.h>
+#include <stdlib.h>
+#include <string.h>
#include <intprops.h>
#include <verify.h>
-#if DEBUG_MKTIME
-# include <stdio.h>
-# include <stdlib.h>
-# include <string.h>
-/* Make it work even if the system's libc has its own mktime routine. */
-# undef mktime
-# define mktime my_mktime
+#ifndef NEED_MKTIME_INTERNAL
+# define NEED_MKTIME_INTERNAL 0
+#endif
+#ifndef NEED_MKTIME_WINDOWS
+# define NEED_MKTIME_WINDOWS 0
+#endif
+#ifndef NEED_MKTIME_WORKING
+# define NEED_MKTIME_WORKING 0
#endif
-#if NEED_MKTIME_WINDOWS /* on native Windows */
-# include <stdlib.h>
-# include <string.h>
+#include "mktime-internal.h"
+
+#if !defined _LIBC && (NEED_MKTIME_WORKING || NEED_MKTIME_WINDOWS)
+static void
+my_tzset (void)
+{
+# if NEED_MKTIME_WINDOWS
+ /* Rectify the value of the environment variable TZ.
+ There are four possible kinds of such values:
+ - Traditional US time zone names, e.g. "PST8PDT". Syntax: see
+ <https://docs.microsoft.com/en-us/cpp/c-runtime-library/reference/tzset>
+ - Time zone names based on geography, that contain one or more
+ slashes, e.g. "Europe/Moscow".
+ - Time zone names based on geography, without slashes, e.g.
+ "Singapore".
+ - Time zone names that contain explicit DST rules. Syntax: see
+ <http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap08.html#tag_08_03>
+ The Microsoft CRT understands only the first kind. It produces incorrect
+ results if the value of TZ is of the other kinds.
+ But in a Cygwin environment, /etc/profile.d/tzset.sh sets TZ to a value
+ of the second kind for most geographies, or of the first kind in a few
+ other geographies. If it is of the second kind, neutralize it. For the
+ Microsoft CRT, an absent or empty TZ means the time zone that the user
+ has set in the Windows Control Panel.
+ If the value of TZ is of the third or fourth kind -- Cygwin programs
+ understand these syntaxes as well --, it does not matter whether we
+ neutralize it or not, since these values occur only when a Cygwin user
+ has set TZ explicitly; this case is 1. rare and 2. under the user's
+ responsibility. */
+ const char *tz = getenv ("TZ");
+ if (tz != NULL && strchr (tz, '/') != NULL)
+ _putenv ("TZ=");
+# elif HAVE_TZSET
+ tzset ();
+# endif
+}
+# undef __tzset
+# define __tzset() my_tzset ()
#endif
-#if NEED_MKTIME_WORKING || NEED_MKTIME_INTERNAL || DEBUG_MKTIME
+#if defined _LIBC || NEED_MKTIME_WORKING || NEED_MKTIME_INTERNAL
/* A signed type that can represent an integer number of years
- multiplied by three times the number of seconds in a year. It is
+ multiplied by four times the number of seconds in a year. It is
needed when converting a tm_year value times the number of seconds
- in a year. The factor of three comes because these products need
+ in a year. The factor of four comes because these products need
to be subtracted from each other, and sometimes with an offset
- added to them, without worrying about overflow.
+ added to them, and then with another timestamp added, without
+ worrying about overflow.
Much of the code uses long_int to represent time_t values, to
lessen the hassle of dealing with platforms where time_t is
@@ -84,12 +118,12 @@
time_t values that mktime can generate even on platforms where
time_t is excessively wide. */
-#if INT_MAX <= LONG_MAX / 3 / 366 / 24 / 60 / 60
+#if INT_MAX <= LONG_MAX / 4 / 366 / 24 / 60 / 60
typedef long int long_int;
#else
typedef long long int long_int;
#endif
-verify (INT_MAX <= TYPE_MAXIMUM (long_int) / 3 / 366 / 24 / 60 / 60);
+verify (INT_MAX <= TYPE_MAXIMUM (long_int) / 4 / 366 / 24 / 60 / 60);
/* Shift A right by B bits portably, by dividing A by 2**B and
truncating towards minus infinity. B should be in the range 0 <= B
@@ -150,19 +184,6 @@ const unsigned short int __mon_yday[2][13] =
};
-#ifdef _LIBC
-typedef time_t mktime_offset_t;
-#else
-/* Portable standalone applications should supply a <time.h> that
- declares a POSIX-compliant localtime_r, for the benefit of older
- implementations that lack localtime_r or have a nonstandard one.
- See the gnulib time_r module for one way to implement this. */
-# undef __localtime_r
-# define __localtime_r localtime_r
-# define __mktime_internal mktime_internal
-# include "mktime-internal.h"
-#endif
-
/* Do the values A and B differ according to the rules for tm_isdst?
A and B differ if one is zero and the other positive. */
static bool
@@ -176,9 +197,10 @@ isdst_differ (int a, int b)
were not adjusted between the timestamps.
The YEAR values uses the same numbering as TP->tm_year. Values
- need not be in the usual range. However, YEAR1 must not overflow
- when multiplied by three times the number of seconds in a year, and
- likewise for YDAY1 and three times the number of seconds in a day. */
+ need not be in the usual range. However, YEAR1 - YEAR0 must not
+ overflow even when multiplied by three times the number of seconds
+ in a year, and likewise for YDAY1 - YDAY0 and three times the
+ number of seconds in a day. */
static long_int
ydhms_diff (long_int year1, long_int yday1, int hour1, int min1, int sec1,
@@ -213,43 +235,25 @@ long_int_avg (long_int a, long_int b)
return shr (a, 1) + shr (b, 1) + ((a | b) & 1);
}
-/* Return a time_t value corresponding to (YEAR-YDAY HOUR:MIN:SEC),
- assuming that T corresponds to *TP and that no clock adjustments
- occurred between *TP and the desired time.
- Although T and the returned value are of type long_int,
- they represent time_t values and must be in time_t range.
- If TP is null, return a value not equal to T; this avoids false matches.
+/* Return a long_int value corresponding to (YEAR-YDAY HOUR:MIN:SEC)
+ minus *TP seconds, assuming no clock adjustments occurred between
+ the two timestamps.
+
YEAR and YDAY must not be so large that multiplying them by three times the
number of seconds in a year (or day, respectively) would overflow long_int.
- If the returned value would be out of range, yield the minimal or
- maximal in-range value, except do not yield a value equal to T. */
+ *TP should be in the usual range. */
static long_int
-guess_time_tm (long_int year, long_int yday, int hour, int min, int sec,
- long_int t, const struct tm *tp)
+tm_diff (long_int year, long_int yday, int hour, int min, int sec,
+ struct tm const *tp)
{
- if (tp)
- {
- long_int result;
- long_int d = ydhms_diff (year, yday, hour, min, sec,
- tp->tm_year, tp->tm_yday,
- tp->tm_hour, tp->tm_min, tp->tm_sec);
- if (! INT_ADD_WRAPV (t, d, &result))
- return result;
- }
-
- /* Overflow occurred one way or another. Return the nearest result
- that is actually in range, except don't report a zero difference
- if the actual difference is nonzero, as that would cause a false
- match; and don't oscillate between two values, as that would
- confuse the spring-forward gap detector. */
- return (t < long_int_avg (mktime_min, mktime_max)
- ? (t <= mktime_min + 1 ? t + 1 : mktime_min)
- : (mktime_max - 1 <= t ? t - 1 : mktime_max));
+ return ydhms_diff (year, yday, hour, min, sec,
+ tp->tm_year, tp->tm_yday,
+ tp->tm_hour, tp->tm_min, tp->tm_sec);
}
/* Use CONVERT to convert T to a struct tm value in *TM. T must be in
- range for time_t. Return TM if successful, NULL if T is out of
- range for CONVERT. */
+ range for time_t. Return TM if successful, NULL (setting errno) on
+ failure. */
static struct tm *
convert_time (struct tm *(*convert) (const time_t *, struct tm *),
long_int t, struct tm *tm)
@@ -261,61 +265,64 @@ convert_time (struct tm *(*convert) (const time_t *, struct tm *),
/* Use CONVERT to convert *T to a broken down time in *TP.
If *T is out of range for conversion, adjust it so that
it is the nearest in-range value and then convert that.
- A value is in range if it fits in both time_t and long_int. */
+ A value is in range if it fits in both time_t and long_int.
+ Return TP on success, NULL (setting errno) on failure. */
static struct tm *
ranged_convert (struct tm *(*convert) (const time_t *, struct tm *),
long_int *t, struct tm *tp)
{
- struct tm *r;
- if (*t < mktime_min)
- *t = mktime_min;
- else if (mktime_max < *t)
- *t = mktime_max;
- r = convert_time (convert, *t, tp);
-
- if (!r && *t)
+ long_int t1 = (*t < mktime_min ? mktime_min
+ : *t <= mktime_max ? *t : mktime_max);
+ struct tm *r = convert_time (convert, t1, tp);
+ if (r)
{
- long_int bad = *t;
- long_int ok = 0;
+ *t = t1;
+ return r;
+ }
+ if (errno != EOVERFLOW)
+ return NULL;
- /* BAD is a known unconvertible value, and OK is a known good one.
- Use binary search to narrow the range between BAD and OK until
- they differ by 1. */
- while (true)
- {
- long_int mid = long_int_avg (ok, bad);
- if (mid != ok && mid != bad)
- break;
- r = convert_time (convert, mid, tp);
- if (r)
- ok = mid;
- else
- bad = mid;
- }
+ long_int bad = t1;
+ long_int ok = 0;
+ struct tm oktm; oktm.tm_sec = -1;
- if (!r && ok)
- {
- /* The last conversion attempt failed;
- revert to the most recent successful attempt. */
- r = convert_time (convert, ok, tp);
- }
+ /* BAD is a known out-of-range value, and OK is a known in-range one.
+ Use binary search to narrow the range between BAD and OK until
+ they differ by 1. */
+ while (true)
+ {
+ long_int mid = long_int_avg (ok, bad);
+ if (mid == ok || mid == bad)
+ break;
+ if (convert_time (convert, mid, tp))
+ ok = mid, oktm = *tp;
+ else if (errno != EOVERFLOW)
+ return NULL;
+ else
+ bad = mid;
}
- return r;
+ if (oktm.tm_sec < 0)
+ return NULL;
+ *t = ok;
+ *tp = oktm;
+ return tp;
}
+
/* Convert *TP to a time_t value, inverting
the monotonic and mostly-unit-linear conversion function CONVERT.
Use *OFFSET to keep track of a guess at the offset of the result,
compared to what the result would be for UTC without leap seconds.
If *OFFSET's guess is correct, only one CONVERT call is needed.
+ If successful, set *TP to the canonicalized struct tm;
+ otherwise leave *TP alone, return ((time_t) -1) and set errno.
This function is external because it is used also by timegm.c. */
time_t
__mktime_internal (struct tm *tp,
struct tm *(*convert) (const time_t *, struct tm *),
mktime_offset_t *offset)
{
- long_int t, gt, t0, t1, t2, dt;
struct tm tm;
/* The maximum number of probes (calls to CONVERT) should be enough
@@ -335,7 +342,7 @@ __mktime_internal (struct tm *tp,
int isdst = tp->tm_isdst;
/* 1 if the previous probe was DST. */
- int dst2;
+ int dst2 = 0;
/* Ensure that mon is in range, and set year accordingly. */
int mon_remainder = mon % 12;
@@ -355,6 +362,7 @@ __mktime_internal (struct tm *tp,
long_int lmday = mday;
long_int yday = mon_yday + lmday;
+ mktime_offset_t off = *offset;
int negative_offset_guess;
int sec_requested = sec;
@@ -362,7 +370,7 @@ __mktime_internal (struct tm *tp,
if (LEAP_SECONDS_POSSIBLE)
{
/* Handle out-of-range seconds specially,
- since ydhms_tm_diff assumes every minute has 60 seconds. */
+ since ydhms_diff assumes every minute has 60 seconds. */
if (sec < 0)
sec = 0;
if (59 < sec)
@@ -372,34 +380,47 @@ __mktime_internal (struct tm *tp,
/* Invert CONVERT by probing. First assume the same offset as last
time. */
- INT_SUBTRACT_WRAPV (0, *offset, &negative_offset_guess);
- t0 = ydhms_diff (year, yday, hour, min, sec,
- EPOCH_YEAR - TM_YEAR_BASE, 0, 0, 0, negative_offset_guess);
+ INT_SUBTRACT_WRAPV (0, off, &negative_offset_guess);
+ long_int t0 = ydhms_diff (year, yday, hour, min, sec,
+ EPOCH_YEAR - TM_YEAR_BASE, 0, 0, 0,
+ negative_offset_guess);
+ long_int t = t0, t1 = t0, t2 = t0;
/* Repeatedly use the error to improve the guess. */
- for (t = t1 = t2 = t0, dst2 = 0;
- (gt = guess_time_tm (year, yday, hour, min, sec, t,
- ranged_convert (convert, &t, &tm)),
- t != gt);
- t1 = t2, t2 = t, t = gt, dst2 = tm.tm_isdst != 0)
- if (t == t1 && t != t2
- && (tm.tm_isdst < 0
- || (isdst < 0
- ? dst2 <= (tm.tm_isdst != 0)
- : (isdst != 0) != (tm.tm_isdst != 0))))
- /* We can't possibly find a match, as we are oscillating
- between two values. The requested time probably falls
- within a spring-forward gap of size GT - T. Follow the common
- practice in this case, which is to return a time that is GT - T
- away from the requested time, preferring a time whose
- tm_isdst differs from the requested value. (If no tm_isdst
- was requested and only one of the two values has a nonzero
- tm_isdst, prefer that value.) In practice, this is more
- useful than returning -1. */
- goto offset_found;
- else if (--remaining_probes == 0)
- return -1;
+ while (true)
+ {
+ if (! ranged_convert (convert, &t, &tm))
+ return -1;
+ long_int dt = tm_diff (year, yday, hour, min, sec, &tm);
+ if (dt == 0)
+ break;
+
+ if (t == t1 && t != t2
+ && (tm.tm_isdst < 0
+ || (isdst < 0
+ ? dst2 <= (tm.tm_isdst != 0)
+ : (isdst != 0) != (tm.tm_isdst != 0))))
+ /* We can't possibly find a match, as we are oscillating
+ between two values. The requested time probably falls
+ within a spring-forward gap of size DT. Follow the common
+ practice in this case, which is to return a time that is DT
+ away from the requested time, preferring a time whose
+ tm_isdst differs from the requested value. (If no tm_isdst
+ was requested and only one of the two values has a nonzero
+ tm_isdst, prefer that value.) In practice, this is more
+ useful than returning -1. */
+ goto offset_found;
+
+ remaining_probes--;
+ if (remaining_probes == 0)
+ {
+ __set_errno (EOVERFLOW);
+ return -1;
+ }
+
+ t1 = t2, t2 = t, t += dt, dst2 = tm.tm_isdst != 0;
+ }
/* We have a match. Check whether tm.tm_isdst has the requested
value, if any. */
@@ -441,25 +462,38 @@ __mktime_internal (struct tm *tp,
if (! INT_ADD_WRAPV (t, delta * direction, &ot))
{
struct tm otm;
- ranged_convert (convert, &ot, &otm);
+ if (! ranged_convert (convert, &ot, &otm))
+ return -1;
if (! isdst_differ (isdst, otm.tm_isdst))
{
/* We found the desired tm_isdst.
Extrapolate back to the desired time. */
- t = guess_time_tm (year, yday, hour, min, sec, ot, &otm);
- ranged_convert (convert, &t, &tm);
- goto offset_found;
+ long_int gt = ot + tm_diff (year, yday, hour, min, sec,
+ &otm);
+ if (mktime_min <= gt && gt <= mktime_max)
+ {
+ if (convert_time (convert, gt, &tm))
+ {
+ t = gt;
+ goto offset_found;
+ }
+ if (errno != EOVERFLOW)
+ return -1;
+ }
}
}
}
+
+ __set_errno (EOVERFLOW);
+ return -1;
}
offset_found:
/* Set *OFFSET to the low-order bits of T - T0 - NEGATIVE_OFFSET_GUESS.
This is just a heuristic to speed up the next mktime call, and
correctness is unaffected if integer overflow occurs here. */
- INT_SUBTRACT_WRAPV (t, t0, &dt);
- INT_SUBTRACT_WRAPV (dt, negative_offset_guess, offset);
+ INT_SUBTRACT_WRAPV (t, t0, offset);
+ INT_SUBTRACT_WRAPV (*offset, negative_offset_guess, offset);
if (LEAP_SECONDS_POSSIBLE && sec_requested != tm.tm_sec)
{
@@ -469,8 +503,12 @@ __mktime_internal (struct tm *tp,
sec_adjustment -= sec;
sec_adjustment += sec_requested;
if (INT_ADD_WRAPV (t, sec_adjustment, &t)
- || ! (mktime_min <= t && t <= mktime_max)
- || ! convert_time (convert, t, &tm))
+ || ! (mktime_min <= t && t <= mktime_max))
+ {
+ __set_errno (EOVERFLOW);
+ return -1;
+ }
+ if (! convert_time (convert, t, &tm))
return -1;
}
@@ -478,64 +516,28 @@ __mktime_internal (struct tm *tp,
return t;
}
-#endif /* NEED_MKTIME_WORKING || NEED_MKTIME_INTERNAL || DEBUG_MKTIME */
+#endif /* _LIBC || NEED_MKTIME_WORKING || NEED_MKTIME_INTERNAL */
-#if NEED_MKTIME_WORKING || NEED_MKTIME_WINDOWS || DEBUG_MKTIME
-
-# if NEED_MKTIME_WORKING || DEBUG_MKTIME
-static mktime_offset_t localtime_offset;
-# endif
+#if defined _LIBC || NEED_MKTIME_WORKING || NEED_MKTIME_WINDOWS
/* Convert *TP to a time_t value. */
time_t
mktime (struct tm *tp)
{
-# if NEED_MKTIME_WINDOWS
- /* Rectify the value of the environment variable TZ.
- There are four possible kinds of such values:
- - Traditional US time zone names, e.g. "PST8PDT". Syntax: see
- <https://msdn.microsoft.com/en-us/library/90s5c885.aspx>
- - Time zone names based on geography, that contain one or more
- slashes, e.g. "Europe/Moscow".
- - Time zone names based on geography, without slashes, e.g.
- "Singapore".
- - Time zone names that contain explicit DST rules. Syntax: see
- <http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap08.html#tag_08_03>
- The Microsoft CRT understands only the first kind. It produces incorrect
- results if the value of TZ is of the other kinds.
- But in a Cygwin environment, /etc/profile.d/tzset.sh sets TZ to a value
- of the second kind for most geographies, or of the first kind in a few
- other geographies. If it is of the second kind, neutralize it. For the
- Microsoft CRT, an absent or empty TZ means the time zone that the user
- has set in the Windows Control Panel.
- If the value of TZ is of the third or fourth kind -- Cygwin programs
- understand these syntaxes as well --, it does not matter whether we
- neutralize it or not, since these values occur only when a Cygwin user
- has set TZ explicitly; this case is 1. rare and 2. under the user's
- responsibility. */
- const char *tz = getenv ("TZ");
- if (tz != NULL && strchr (tz, '/') != NULL)
- _putenv ("TZ=");
-# endif
-
-# if NEED_MKTIME_WORKING || DEBUG_MKTIME
-# ifdef _LIBC
/* POSIX.1 8.1.1 requires that whenever mktime() is called, the
time zone names contained in the external variable 'tzname' shall
be set as if the tzset() function had been called. */
__tzset ();
-# elif HAVE_TZSET
- tzset ();
-# endif
+# if defined _LIBC || NEED_MKTIME_WORKING
+ static mktime_offset_t localtime_offset;
return __mktime_internal (tp, __localtime_r, &localtime_offset);
# else
# undef mktime
return mktime (tp);
# endif
}
-
-#endif /* NEED_MKTIME_WORKING || NEED_MKTIME_WINDOWS || DEBUG_MKTIME */
+#endif /* _LIBC || NEED_MKTIME_WORKING || NEED_MKTIME_WINDOWS */
#ifdef weak_alias
weak_alias (mktime, timelocal)
@@ -545,146 +547,3 @@ weak_alias (mktime, timelocal)
libc_hidden_def (mktime)
libc_hidden_weak (timelocal)
#endif
-
-#if DEBUG_MKTIME
-
-static int
-not_equal_tm (const struct tm *a, const struct tm *b)
-{
- return ((a->tm_sec ^ b->tm_sec)
- | (a->tm_min ^ b->tm_min)
- | (a->tm_hour ^ b->tm_hour)
- | (a->tm_mday ^ b->tm_mday)
- | (a->tm_mon ^ b->tm_mon)
- | (a->tm_year ^ b->tm_year)
- | (a->tm_yday ^ b->tm_yday)
- | isdst_differ (a->tm_isdst, b->tm_isdst));
-}
-
-static void
-print_tm (const struct tm *tp)
-{
- if (tp)
- printf ("%04d-%02d-%02d %02d:%02d:%02d yday %03d wday %d isdst %d",
- tp->tm_year + TM_YEAR_BASE, tp->tm_mon + 1, tp->tm_mday,
- tp->tm_hour, tp->tm_min, tp->tm_sec,
- tp->tm_yday, tp->tm_wday, tp->tm_isdst);
- else
- printf ("0");
-}
-
-static int
-check_result (time_t tk, struct tm tmk, time_t tl, const struct tm *lt)
-{
- if (tk != tl || !lt || not_equal_tm (&tmk, lt))
- {
- printf ("mktime (");
- print_tm (lt);
- printf (")\nyields (");
- print_tm (&tmk);
- printf (") == %ld, should be %ld\n", (long int) tk, (long int) tl);
- return 1;
- }
-
- return 0;
-}
-
-int
-main (int argc, char **argv)
-{
- int status = 0;
- struct tm tm, tmk, tml;
- struct tm *lt;
- time_t tk, tl, tl1;
- char trailer;
-
- /* Sanity check, plus call tzset. */
- tl = 0;
- if (! localtime (&tl))
- {
- printf ("localtime (0) fails\n");
- status = 1;
- }
-
- if ((argc == 3 || argc == 4)
- && (sscanf (argv[1], "%d-%d-%d%c",
- &tm.tm_year, &tm.tm_mon, &tm.tm_mday, &trailer)
- == 3)
- && (sscanf (argv[2], "%d:%d:%d%c",
- &tm.tm_hour, &tm.tm_min, &tm.tm_sec, &trailer)
- == 3))
- {
- tm.tm_year -= TM_YEAR_BASE;
- tm.tm_mon--;
- tm.tm_isdst = argc == 3 ? -1 : atoi (argv[3]);
- tmk = tm;
- tl = mktime (&tmk);
- lt = localtime_r (&tl, &tml);
- printf ("mktime returns %ld == ", (long int) tl);
- print_tm (&tmk);
- printf ("\n");
- status = check_result (tl, tmk, tl, lt);
- }
- else if (argc == 4 || (argc == 5 && strcmp (argv[4], "-") == 0))
- {
- time_t from = atol (argv[1]);
- time_t by = atol (argv[2]);
- time_t to = atol (argv[3]);
-
- if (argc == 4)
- for (tl = from; by < 0 ? to <= tl : tl <= to; tl = tl1)
- {
- lt = localtime_r (&tl, &tml);
- if (lt)
- {
- tmk = tml;
- tk = mktime (&tmk);
- status |= check_result (tk, tmk, tl, &tml);
- }
- else
- {
- printf ("localtime_r (%ld) yields 0\n", (long int) tl);
- status = 1;
- }
- tl1 = tl + by;
- if ((tl1 < tl) != (by < 0))
- break;
- }
- else
- for (tl = from; by < 0 ? to <= tl : tl <= to; tl = tl1)
- {
- /* Null benchmark. */
- lt = localtime_r (&tl, &tml);
- if (lt)
- {
- tmk = tml;
- tk = tl;
- status |= check_result (tk, tmk, tl, &tml);
- }
- else
- {
- printf ("localtime_r (%ld) yields 0\n", (long int) tl);
- status = 1;
- }
- tl1 = tl + by;
- if ((tl1 < tl) != (by < 0))
- break;
- }
- }
- else
- printf ("Usage:\
-\t%s YYYY-MM-DD HH:MM:SS [ISDST] # Test given time.\n\
-\t%s FROM BY TO # Test values FROM, FROM+BY, ..., TO.\n\
-\t%s FROM BY TO - # Do not test those values (for benchmark).\n",
- argv[0], argv[0], argv[0]);
-
- return status;
-}
-
-#endif /* DEBUG_MKTIME */
-
-/*
-Local Variables:
-compile-command: "gcc -DDEBUG_MKTIME -I. -Wall -W -O2 -g mktime.c -o mktime"
-End:
-*/
diff --git a/lib/nstrftime.c b/lib/nstrftime.c
index 7df3869bbaf..bc84da5a0cb 100644
--- a/lib/nstrftime.c
+++ b/lib/nstrftime.c
@@ -91,6 +91,7 @@ extern char *tzname[];
# define UCHAR_T unsigned char
# define L_(Str) Str
# define NLW(Sym) Sym
+# define ABALTMON_1 _NL_ABALTMON_1
# define MEMCPY(d, s, n) memcpy (d, s, n)
# define STRLEN(s) strlen (s)
@@ -179,7 +180,7 @@ extern char *tzname[];
if (digits == 0 && _n < _w) \
{ \
size_t _delta = width - _n; \
- if (pad == L_('0')) \
+ if (pad == L_('0') || pad == L_('+')) \
memset_zero (p, _delta); \
else \
memset_space (p, _delta); \
@@ -255,7 +256,7 @@ extern char *tzname[];
# undef _NL_CURRENT
# define _NL_CURRENT(category, item) \
(current->values[_NL_ITEM_INDEX (item)].string)
-# define LOCALE_PARAM , __locale_t loc
+# define LOCALE_PARAM , locale_t loc
# define LOCALE_ARG , loc
# define HELPER_LOCALE_ARG , current
#else
@@ -417,7 +418,7 @@ iso_week_days (int yday, int wday)
static size_t __strftime_internal (STREAM_OR_CHAR_T *, STRFTIME_ARG (size_t)
const CHAR_T *, const struct tm *,
- bool, bool *
+ bool, int, int, bool *
extra_args_spec LOCALE_PARAM);
/* Write information from TP into S according to the format
@@ -432,8 +433,8 @@ my_strftime (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
const struct tm *tp extra_args_spec LOCALE_PARAM)
{
bool tzset_called = false;
- return __strftime_internal (s, STRFTIME_ARG (maxsize) format, tp,
- false, &tzset_called extra_args LOCALE_ARG);
+ return __strftime_internal (s, STRFTIME_ARG (maxsize) format, tp, false,
+ 0, -1, &tzset_called extra_args LOCALE_ARG);
}
#if defined _LIBC && ! FPRINTFTIME
libc_hidden_def (my_strftime)
@@ -445,7 +446,8 @@ libc_hidden_def (my_strftime)
static size_t
__strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
const CHAR_T *format,
- const struct tm *tp, bool upcase, bool *tzset_called
+ const struct tm *tp, bool upcase,
+ int yr_spec, int width, bool *tzset_called
extra_args_spec LOCALE_PARAM)
{
#if defined _LIBC && defined USE_IN_EXTENDED_LOCALE_MODEL
@@ -475,12 +477,19 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
# define f_month \
((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
? "?" : _NL_CURRENT (LC_TIME, NLW(MON_1) + tp->tm_mon)))
+# define a_altmonth \
+ ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
+ ? "?" : _NL_CURRENT (LC_TIME, NLW(ABALTMON_1) + tp->tm_mon)))
+# define f_altmonth \
+ ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
+ ? "?" : _NL_CURRENT (LC_TIME, NLW(ALTMON_1) + tp->tm_mon)))
# define ampm \
((const CHAR_T *) _NL_CURRENT (LC_TIME, tp->tm_hour > 11 \
? NLW(PM_STR) : NLW(AM_STR)))
# define aw_len STRLEN (a_wkday)
# define am_len STRLEN (a_month)
+# define aam_len STRLEN (a_altmonth)
# define ap_len STRLEN (ampm)
#endif
#if HAVE_TZNAME
@@ -550,7 +559,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
if (hour12 == 0)
hour12 = 12;
- for (f = format; *f != '\0'; ++f)
+ for (f = format; *f != '\0'; width = -1, f++)
{
int pad = 0; /* Padding for number ('-', '_', or 0). */
int modifier; /* Field modifier ('E', 'O', or 0). */
@@ -568,12 +577,12 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
+ (sizeof (int) < sizeof (time_t)
? INT_STRLEN_BOUND (time_t)
: INT_STRLEN_BOUND (int))];
- int width = -1;
bool to_lowcase = false;
bool to_uppcase = upcase;
size_t colons;
bool change_case = false;
int format_char;
+ int subwidth;
#if DO_MULTIBYTE && !defined COMPILE_WIDE
switch (*f)
@@ -671,6 +680,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
/* This influences the number formats. */
case L_('_'):
case L_('-'):
+ case L_('+'):
case L_('0'):
pad = *f;
continue;
@@ -689,7 +699,6 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
break;
}
- /* As a GNU extension we allow the field width to be specified. */
if (ISDIGIT (*f))
{
width = 0;
@@ -735,12 +744,16 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
} \
while (0)
#define DO_SIGNED_NUMBER(d, negative, v) \
+ DO_MAYBE_SIGNED_NUMBER (d, negative, v, do_signed_number)
+#define DO_YEARISH(d, negative, v) \
+ DO_MAYBE_SIGNED_NUMBER (d, negative, v, do_yearish)
+#define DO_MAYBE_SIGNED_NUMBER(d, negative, v, label) \
do \
{ \
digits = d; \
negative_number = negative; \
u_number_value = v; \
- goto do_signed_number; \
+ goto label; \
} \
while (0)
@@ -808,17 +821,20 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
to_uppcase = true;
to_lowcase = false;
}
- if (modifier != 0)
+ if (modifier == L_('E'))
goto bad_format;
#ifdef _NL_CURRENT
- cpy (am_len, a_month);
+ if (modifier == L_('O'))
+ cpy (aam_len, a_altmonth);
+ else
+ cpy (am_len, a_month);
break;
#else
goto underlying_strftime;
#endif
case L_('B'):
- if (modifier != 0)
+ if (modifier == L_('E'))
goto bad_format;
if (change_case)
{
@@ -826,7 +842,10 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
to_lowcase = false;
}
#ifdef _NL_CURRENT
- cpy (STRLEN (f_month), f_month);
+ if (modifier == L_('O'))
+ cpy (STRLEN (f_altmonth), f_altmonth);
+ else
+ cpy (STRLEN (f_month), f_month);
break;
#else
goto underlying_strftime;
@@ -836,7 +855,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
if (modifier == L_('O'))
goto bad_format;
#ifdef _NL_CURRENT
- if (! (modifier == 'E'
+ if (! (modifier == L_('E')
&& (*(subfmt =
(const CHAR_T *) _NL_CURRENT (LC_TIME,
NLW(ERA_D_T_FMT)))
@@ -847,15 +866,17 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
#endif
subformat:
+ subwidth = -1;
+ subformat_width:
{
size_t len = __strftime_internal (NULL, STRFTIME_ARG ((size_t) -1)
- subfmt,
- tp, to_uppcase, tzset_called
+ subfmt, tp, to_uppcase,
+ pad, subwidth, tzset_called
extra_args LOCALE_ARG);
add (len, __strftime_internal (p,
STRFTIME_ARG (maxsize - i)
- subfmt,
- tp, to_uppcase, tzset_called
+ subfmt, tp, to_uppcase,
+ pad, subwidth, tzset_called
extra_args LOCALE_ARG));
}
break;
@@ -916,7 +937,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
{
int century = tp->tm_year / 100 + TM_YEAR_BASE / 100;
century -= tp->tm_year % 100 < 0 && 0 < century;
- DO_SIGNED_NUMBER (2, tp->tm_year < - TM_YEAR_BASE, century);
+ DO_YEARISH (2, tp->tm_year < - TM_YEAR_BASE, century);
}
case L_('x'):
@@ -925,7 +946,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
#ifdef _NL_CURRENT
if (! (modifier == L_('E')
&& (*(subfmt =
- (const CHAR_T *)_NL_CURRENT (LC_TIME, NLW(ERA_D_FMT)))
+ (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(ERA_D_FMT)))
!= L_('\0'))))
subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(D_FMT));
goto subformat;
@@ -957,9 +978,17 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
always_output_a_sign = true;
goto do_number_body;
+ do_yearish:
+ if (pad == 0)
+ pad = yr_spec;
+ always_output_a_sign
+ = (pad == L_('+')
+ && ((digits == 2 ? 99 : 9999) < u_number_value
+ || digits < width));
+ goto do_maybe_signed_number;
+
do_number_spacepad:
- /* Force '_' flag unless overridden by '0' or '-' flag. */
- if (pad != L_('0') && pad != L_('-'))
+ if (pad == 0)
pad = L_('_');
do_number:
@@ -969,6 +998,8 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
do_signed_number:
always_output_a_sign = false;
+
+ do_maybe_signed_number:
tz_colon_mask = 0;
do_number_body:
@@ -1073,8 +1104,19 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
case L_('F'):
if (modifier != 0)
goto bad_format;
+ if (pad == 0 && width < 0)
+ {
+ pad = L_('+');
+ subwidth = 4;
+ }
+ else
+ {
+ subwidth = width - 6;
+ if (subwidth < 0)
+ subwidth = 0;
+ }
subfmt = L_("%Y-%m-%d");
- goto subformat;
+ goto subformat_width;
case L_('H'):
if (modifier == L_('E'))
@@ -1283,17 +1325,18 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
case L_('g'):
{
int yy = (tp->tm_year % 100 + year_adjust) % 100;
- DO_NUMBER (2, (0 <= yy
- ? yy
- : tp->tm_year < -TM_YEAR_BASE - year_adjust
- ? -yy
- : yy + 100));
+ DO_YEARISH (2, false,
+ (0 <= yy
+ ? yy
+ : tp->tm_year < -TM_YEAR_BASE - year_adjust
+ ? -yy
+ : yy + 100));
}
case L_('G'):
- DO_SIGNED_NUMBER (4, tp->tm_year < -TM_YEAR_BASE - year_adjust,
- (tp->tm_year + (unsigned int) TM_YEAR_BASE
- + year_adjust));
+ DO_YEARISH (4, tp->tm_year < -TM_YEAR_BASE - year_adjust,
+ (tp->tm_year + (unsigned int) TM_YEAR_BASE
+ + year_adjust));
default:
DO_NUMBER (2, days / 7 + 1);
@@ -1313,7 +1356,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
DO_NUMBER (1, tp->tm_wday);
case L_('Y'):
- if (modifier == 'E')
+ if (modifier == L_('E'))
{
#if HAVE_STRUCT_ERA_ENTRY
struct era_entry *era = _nl_get_era_entry (tp HELPER_LOCALE_ARG);
@@ -1324,6 +1367,8 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
# else
subfmt = era->era_format;
# endif
+ if (pad == 0)
+ pad = yr_spec;
goto subformat;
}
#else
@@ -1333,8 +1378,8 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
if (modifier == L_('O'))
goto bad_format;
- DO_SIGNED_NUMBER (4, tp->tm_year < -TM_YEAR_BASE,
- tp->tm_year + (unsigned int) TM_YEAR_BASE);
+ DO_YEARISH (4, tp->tm_year < -TM_YEAR_BASE,
+ tp->tm_year + (unsigned int) TM_YEAR_BASE);
case L_('y'):
if (modifier == L_('E'))
@@ -1344,7 +1389,9 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
if (era)
{
int delta = tp->tm_year - era->start_date[0];
- DO_NUMBER (1, (era->offset
+ if (pad == 0)
+ pad = yr_spec;
+ DO_NUMBER (2, (era->offset
+ delta * era->absolute_direction));
}
#else
@@ -1356,7 +1403,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
int yy = tp->tm_year % 100;
if (yy < 0)
yy = tp->tm_year < - TM_YEAR_BASE ? -yy : yy + 100;
- DO_NUMBER (2, yy);
+ DO_YEARISH (2, false, yy);
}
case L_('Z'):
@@ -1424,28 +1471,10 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
# endif
ltm = *tp;
+ ltm.tm_wday = -1;
lt = mktime_z (tz, &ltm);
-
- if (lt == (time_t) -1)
- {
- /* mktime returns -1 for errors, but -1 is also a
- valid time_t value. Check whether an error really
- occurred. */
- struct tm tm;
-
- if (! localtime_rz (tz, &lt, &tm)
- || ((ltm.tm_sec ^ tm.tm_sec)
- | (ltm.tm_min ^ tm.tm_min)
- | (ltm.tm_hour ^ tm.tm_hour)
- | (ltm.tm_mday ^ tm.tm_mday)
- | (ltm.tm_mon ^ tm.tm_mon)
- | (ltm.tm_year ^ tm.tm_year)))
- break;
- }
-
- if (! localtime_rz (0, &lt, &gtm))
+ if (ltm.tm_wday < 0 || ! localtime_rz (0, &lt, &gtm))
break;
-
diff = tm_diff (&ltm, &gtm);
}
#endif
diff --git a/lib/open.c b/lib/open.c
index ba223bff1be..655260572d4 100644
--- a/lib/open.c
+++ b/lib/open.c
@@ -86,7 +86,7 @@ open (const char *filename, int flags, ...)
flags &= ~O_NONBLOCK;
#endif
-#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+#if defined _WIN32 && ! defined __CYGWIN__
if (strcmp (filename, "/dev/null") == 0)
filename = "NUL";
#endif
diff --git a/lib/pipe2.c b/lib/pipe2.c
index c5747cd1874..15a5dec9852 100644
--- a/lib/pipe2.c
+++ b/lib/pipe2.c
@@ -29,7 +29,7 @@
# include "nonblocking.h"
#endif
-#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+#if defined _WIN32 && ! defined __CYGWIN__
/* Native Windows API. */
# include <io.h>
@@ -73,7 +73,7 @@ pipe2 (int fd[2], int flags)
return -1;
}
-#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+#if defined _WIN32 && ! defined __CYGWIN__
/* Native Windows API. */
if (_pipe (fd, 4096, flags & ~O_NONBLOCK) < 0)
@@ -152,8 +152,7 @@ pipe2 (int fd[2], int flags)
#endif
-#if GNULIB_defined_O_NONBLOCK || \
- !((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__)
+#if GNULIB_defined_O_NONBLOCK || !(defined _WIN32 && ! defined __CYGWIN__)
fail:
{
int saved_errno = errno;
diff --git a/lib/pselect.c b/lib/pselect.c
index dacb5332ec6..ae010aa02e4 100644
--- a/lib/pselect.c
+++ b/lib/pselect.c
@@ -83,9 +83,9 @@ pselect (int nfds, fd_set *restrict rfds,
int
rpl_pselect (int nfds, fd_set *restrict rfds,
- fd_set *restrict wfds, fd_set *restrict xfds,
+ fd_set *restrict wfds, fd_set *restrict xfds,
struct timespec const *restrict timeout,
- sigset_t const *restrict sigmask)
+ sigset_t const *restrict sigmask)
{
int i;
diff --git a/lib/putenv.c b/lib/putenv.c
index 81a651a7549..81085e9d80a 100644
--- a/lib/putenv.c
+++ b/lib/putenv.c
@@ -34,7 +34,7 @@
#include <string.h>
#include <unistd.h>
-#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+#if defined _WIN32 && ! defined __CYGWIN__
# define WIN32_LEAN_AND_MEAN
# include <windows.h>
#endif
@@ -153,7 +153,7 @@ putenv (char *string)
*ep = string;
break;
}
-# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+# if defined _WIN32 && ! defined __CYGWIN__
if (putenv_result == 0)
{
/* _putenv propagated "NAME= " into the subprocess environment;
diff --git a/lib/regcomp.c b/lib/regcomp.c
new file mode 100644
index 00000000000..892139a02af
--- /dev/null
+++ b/lib/regcomp.c
@@ -0,0 +1,3934 @@
+/* Extended regular expression matching and search library.
+ Copyright (C) 2002-2019 Free Software Foundation, Inc.
+ This file is part of the GNU C Library.
+ Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>.
+
+ 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
+ <https://www.gnu.org/licenses/>. */
+
+#ifdef _LIBC
+# include <locale/weight.h>
+#endif
+
+static reg_errcode_t re_compile_internal (regex_t *preg, const char * pattern,
+ size_t length, reg_syntax_t syntax);
+static void re_compile_fastmap_iter (regex_t *bufp,
+ const re_dfastate_t *init_state,
+ char *fastmap);
+static reg_errcode_t init_dfa (re_dfa_t *dfa, size_t pat_len);
+#ifdef RE_ENABLE_I18N
+static void free_charset (re_charset_t *cset);
+#endif /* RE_ENABLE_I18N */
+static void free_workarea_compile (regex_t *preg);
+static reg_errcode_t create_initial_state (re_dfa_t *dfa);
+#ifdef RE_ENABLE_I18N
+static void optimize_utf8 (re_dfa_t *dfa);
+#endif
+static reg_errcode_t analyze (regex_t *preg);
+static reg_errcode_t preorder (bin_tree_t *root,
+ reg_errcode_t (fn (void *, bin_tree_t *)),
+ void *extra);
+static reg_errcode_t postorder (bin_tree_t *root,
+ reg_errcode_t (fn (void *, bin_tree_t *)),
+ void *extra);
+static reg_errcode_t optimize_subexps (void *extra, bin_tree_t *node);
+static reg_errcode_t lower_subexps (void *extra, bin_tree_t *node);
+static bin_tree_t *lower_subexp (reg_errcode_t *err, regex_t *preg,
+ bin_tree_t *node);
+static reg_errcode_t calc_first (void *extra, bin_tree_t *node);
+static reg_errcode_t calc_next (void *extra, bin_tree_t *node);
+static reg_errcode_t link_nfa_nodes (void *extra, bin_tree_t *node);
+static Idx duplicate_node (re_dfa_t *dfa, Idx org_idx, unsigned int constraint);
+static Idx search_duplicated_node (const re_dfa_t *dfa, Idx org_node,
+ unsigned int constraint);
+static reg_errcode_t calc_eclosure (re_dfa_t *dfa);
+static reg_errcode_t calc_eclosure_iter (re_node_set *new_set, re_dfa_t *dfa,
+ Idx node, bool root);
+static reg_errcode_t calc_inveclosure (re_dfa_t *dfa);
+static Idx fetch_number (re_string_t *input, re_token_t *token,
+ reg_syntax_t syntax);
+static int peek_token (re_token_t *token, re_string_t *input,
+ reg_syntax_t syntax);
+static bin_tree_t *parse (re_string_t *regexp, regex_t *preg,
+ reg_syntax_t syntax, reg_errcode_t *err);
+static bin_tree_t *parse_reg_exp (re_string_t *regexp, regex_t *preg,
+ re_token_t *token, reg_syntax_t syntax,
+ Idx nest, reg_errcode_t *err);
+static bin_tree_t *parse_branch (re_string_t *regexp, regex_t *preg,
+ re_token_t *token, reg_syntax_t syntax,
+ Idx nest, reg_errcode_t *err);
+static bin_tree_t *parse_expression (re_string_t *regexp, regex_t *preg,
+ re_token_t *token, reg_syntax_t syntax,
+ Idx nest, reg_errcode_t *err);
+static bin_tree_t *parse_sub_exp (re_string_t *regexp, regex_t *preg,
+ re_token_t *token, reg_syntax_t syntax,
+ Idx nest, reg_errcode_t *err);
+static bin_tree_t *parse_dup_op (bin_tree_t *dup_elem, re_string_t *regexp,
+ re_dfa_t *dfa, re_token_t *token,
+ reg_syntax_t syntax, reg_errcode_t *err);
+static bin_tree_t *parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa,
+ re_token_t *token, reg_syntax_t syntax,
+ reg_errcode_t *err);
+static reg_errcode_t parse_bracket_element (bracket_elem_t *elem,
+ re_string_t *regexp,
+ re_token_t *token, int token_len,
+ re_dfa_t *dfa,
+ reg_syntax_t syntax,
+ bool accept_hyphen);
+static reg_errcode_t parse_bracket_symbol (bracket_elem_t *elem,
+ re_string_t *regexp,
+ re_token_t *token);
+#ifdef RE_ENABLE_I18N
+static reg_errcode_t build_equiv_class (bitset_t sbcset,
+ re_charset_t *mbcset,
+ Idx *equiv_class_alloc,
+ const unsigned char *name);
+static reg_errcode_t build_charclass (RE_TRANSLATE_TYPE trans,
+ bitset_t sbcset,
+ re_charset_t *mbcset,
+ Idx *char_class_alloc,
+ const char *class_name,
+ reg_syntax_t syntax);
+#else /* not RE_ENABLE_I18N */
+static reg_errcode_t build_equiv_class (bitset_t sbcset,
+ const unsigned char *name);
+static reg_errcode_t build_charclass (RE_TRANSLATE_TYPE trans,
+ bitset_t sbcset,
+ const char *class_name,
+ reg_syntax_t syntax);
+#endif /* not RE_ENABLE_I18N */
+static bin_tree_t *build_charclass_op (re_dfa_t *dfa,
+ RE_TRANSLATE_TYPE trans,
+ const char *class_name,
+ const char *extra,
+ bool non_match, reg_errcode_t *err);
+static bin_tree_t *create_tree (re_dfa_t *dfa,
+ bin_tree_t *left, bin_tree_t *right,
+ re_token_type_t type);
+static bin_tree_t *create_token_tree (re_dfa_t *dfa,
+ bin_tree_t *left, bin_tree_t *right,
+ const re_token_t *token);
+static bin_tree_t *duplicate_tree (const bin_tree_t *src, re_dfa_t *dfa);
+static void free_token (re_token_t *node);
+static reg_errcode_t free_tree (void *extra, bin_tree_t *node);
+static reg_errcode_t mark_opt_subexp (void *extra, bin_tree_t *node);
+
+/* This table gives an error message for each of the error codes listed
+ in regex.h. Obviously the order here has to be same as there.
+ POSIX doesn't require that we do anything for REG_NOERROR,
+ but why not be nice? */
+
+static const char __re_error_msgid[] =
+ {
+#define REG_NOERROR_IDX 0
+ gettext_noop ("Success") /* REG_NOERROR */
+ "\0"
+#define REG_NOMATCH_IDX (REG_NOERROR_IDX + sizeof "Success")
+ gettext_noop ("No match") /* REG_NOMATCH */
+ "\0"
+#define REG_BADPAT_IDX (REG_NOMATCH_IDX + sizeof "No match")
+ gettext_noop ("Invalid regular expression") /* REG_BADPAT */
+ "\0"
+#define REG_ECOLLATE_IDX (REG_BADPAT_IDX + sizeof "Invalid regular expression")
+ gettext_noop ("Invalid collation character") /* REG_ECOLLATE */
+ "\0"
+#define REG_ECTYPE_IDX (REG_ECOLLATE_IDX + sizeof "Invalid collation character")
+ gettext_noop ("Invalid character class name") /* REG_ECTYPE */
+ "\0"
+#define REG_EESCAPE_IDX (REG_ECTYPE_IDX + sizeof "Invalid character class name")
+ gettext_noop ("Trailing backslash") /* REG_EESCAPE */
+ "\0"
+#define REG_ESUBREG_IDX (REG_EESCAPE_IDX + sizeof "Trailing backslash")
+ gettext_noop ("Invalid back reference") /* REG_ESUBREG */
+ "\0"
+#define REG_EBRACK_IDX (REG_ESUBREG_IDX + sizeof "Invalid back reference")
+ gettext_noop ("Unmatched [, [^, [:, [., or [=") /* REG_EBRACK */
+ "\0"
+#define REG_EPAREN_IDX (REG_EBRACK_IDX + sizeof "Unmatched [, [^, [:, [., or [=")
+ gettext_noop ("Unmatched ( or \\(") /* REG_EPAREN */
+ "\0"
+#define REG_EBRACE_IDX (REG_EPAREN_IDX + sizeof "Unmatched ( or \\(")
+ gettext_noop ("Unmatched \\{") /* REG_EBRACE */
+ "\0"
+#define REG_BADBR_IDX (REG_EBRACE_IDX + sizeof "Unmatched \\{")
+ gettext_noop ("Invalid content of \\{\\}") /* REG_BADBR */
+ "\0"
+#define REG_ERANGE_IDX (REG_BADBR_IDX + sizeof "Invalid content of \\{\\}")
+ gettext_noop ("Invalid range end") /* REG_ERANGE */
+ "\0"
+#define REG_ESPACE_IDX (REG_ERANGE_IDX + sizeof "Invalid range end")
+ gettext_noop ("Memory exhausted") /* REG_ESPACE */
+ "\0"
+#define REG_BADRPT_IDX (REG_ESPACE_IDX + sizeof "Memory exhausted")
+ gettext_noop ("Invalid preceding regular expression") /* REG_BADRPT */
+ "\0"
+#define REG_EEND_IDX (REG_BADRPT_IDX + sizeof "Invalid preceding regular expression")
+ gettext_noop ("Premature end of regular expression") /* REG_EEND */
+ "\0"
+#define REG_ESIZE_IDX (REG_EEND_IDX + sizeof "Premature end of regular expression")
+ gettext_noop ("Regular expression too big") /* REG_ESIZE */
+ "\0"
+#define REG_ERPAREN_IDX (REG_ESIZE_IDX + sizeof "Regular expression too big")
+ gettext_noop ("Unmatched ) or \\)") /* REG_ERPAREN */
+ };
+
+static const size_t __re_error_msgid_idx[] =
+ {
+ REG_NOERROR_IDX,
+ REG_NOMATCH_IDX,
+ REG_BADPAT_IDX,
+ REG_ECOLLATE_IDX,
+ REG_ECTYPE_IDX,
+ REG_EESCAPE_IDX,
+ REG_ESUBREG_IDX,
+ REG_EBRACK_IDX,
+ REG_EPAREN_IDX,
+ REG_EBRACE_IDX,
+ REG_BADBR_IDX,
+ REG_ERANGE_IDX,
+ REG_ESPACE_IDX,
+ REG_BADRPT_IDX,
+ REG_EEND_IDX,
+ REG_ESIZE_IDX,
+ REG_ERPAREN_IDX
+ };
+
+/* Entry points for GNU code. */
+
+/* re_compile_pattern is the GNU regular expression compiler: it
+ compiles PATTERN (of length LENGTH) and puts the result in BUFP.
+ Returns 0 if the pattern was valid, otherwise an error string.
+
+ Assumes the 'allocated' (and perhaps 'buffer') and 'translate' fields
+ are set in BUFP on entry. */
+
+const char *
+re_compile_pattern (const char *pattern, size_t length,
+ struct re_pattern_buffer *bufp)
+{
+ reg_errcode_t ret;
+
+ /* And GNU code determines whether or not to get register information
+ by passing null for the REGS argument to re_match, etc., not by
+ setting no_sub, unless RE_NO_SUB is set. */
+ bufp->no_sub = !!(re_syntax_options & RE_NO_SUB);
+
+ /* Match anchors at newline. */
+ bufp->newline_anchor = 1;
+
+ ret = re_compile_internal (bufp, pattern, length, re_syntax_options);
+
+ if (!ret)
+ return NULL;
+ return gettext (__re_error_msgid + __re_error_msgid_idx[(int) ret]);
+}
+weak_alias (__re_compile_pattern, re_compile_pattern)
+
+/* Set by 're_set_syntax' to the current regexp syntax to recognize. Can
+ also be assigned to arbitrarily: each pattern buffer stores its own
+ syntax, so it can be changed between regex compilations. */
+/* This has no initializer because initialized variables in Emacs
+ become read-only after dumping. */
+reg_syntax_t re_syntax_options;
+
+
+/* Specify the precise syntax of regexps for compilation. This provides
+ for compatibility for various utilities which historically have
+ different, incompatible syntaxes.
+
+ The argument SYNTAX is a bit mask comprised of the various bits
+ defined in regex.h. We return the old syntax. */
+
+reg_syntax_t
+re_set_syntax (reg_syntax_t syntax)
+{
+ reg_syntax_t ret = re_syntax_options;
+
+ re_syntax_options = syntax;
+ return ret;
+}
+weak_alias (__re_set_syntax, re_set_syntax)
+
+int
+re_compile_fastmap (struct re_pattern_buffer *bufp)
+{
+ re_dfa_t *dfa = bufp->buffer;
+ char *fastmap = bufp->fastmap;
+
+ memset (fastmap, '\0', sizeof (char) * SBC_MAX);
+ re_compile_fastmap_iter (bufp, dfa->init_state, fastmap);
+ if (dfa->init_state != dfa->init_state_word)
+ re_compile_fastmap_iter (bufp, dfa->init_state_word, fastmap);
+ if (dfa->init_state != dfa->init_state_nl)
+ re_compile_fastmap_iter (bufp, dfa->init_state_nl, fastmap);
+ if (dfa->init_state != dfa->init_state_begbuf)
+ re_compile_fastmap_iter (bufp, dfa->init_state_begbuf, fastmap);
+ bufp->fastmap_accurate = 1;
+ return 0;
+}
+weak_alias (__re_compile_fastmap, re_compile_fastmap)
+
+static inline void
+__attribute__ ((always_inline))
+re_set_fastmap (char *fastmap, bool icase, int ch)
+{
+ fastmap[ch] = 1;
+ if (icase)
+ fastmap[tolower (ch)] = 1;
+}
+
+/* Helper function for re_compile_fastmap.
+ Compile fastmap for the initial_state INIT_STATE. */
+
+static void
+re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state,
+ char *fastmap)
+{
+ re_dfa_t *dfa = bufp->buffer;
+ Idx node_cnt;
+ bool icase = (dfa->mb_cur_max == 1 && (bufp->syntax & RE_ICASE));
+ for (node_cnt = 0; node_cnt < init_state->nodes.nelem; ++node_cnt)
+ {
+ Idx node = init_state->nodes.elems[node_cnt];
+ re_token_type_t type = dfa->nodes[node].type;
+
+ if (type == CHARACTER)
+ {
+ re_set_fastmap (fastmap, icase, dfa->nodes[node].opr.c);
+#ifdef RE_ENABLE_I18N
+ if ((bufp->syntax & RE_ICASE) && dfa->mb_cur_max > 1)
+ {
+ unsigned char buf[MB_LEN_MAX];
+ unsigned char *p;
+ wchar_t wc;
+ mbstate_t state;
+
+ p = buf;
+ *p++ = dfa->nodes[node].opr.c;
+ while (++node < dfa->nodes_len
+ && dfa->nodes[node].type == CHARACTER
+ && dfa->nodes[node].mb_partial)
+ *p++ = dfa->nodes[node].opr.c;
+ memset (&state, '\0', sizeof (state));
+ if (__mbrtowc (&wc, (const char *) buf, p - buf,
+ &state) == p - buf
+ && (__wcrtomb ((char *) buf, __towlower (wc), &state)
+ != (size_t) -1))
+ re_set_fastmap (fastmap, false, buf[0]);
+ }
+#endif
+ }
+ else if (type == SIMPLE_BRACKET)
+ {
+ int i, ch;
+ for (i = 0, ch = 0; i < BITSET_WORDS; ++i)
+ {
+ int j;
+ bitset_word_t w = dfa->nodes[node].opr.sbcset[i];
+ for (j = 0; j < BITSET_WORD_BITS; ++j, ++ch)
+ if (w & ((bitset_word_t) 1 << j))
+ re_set_fastmap (fastmap, icase, ch);
+ }
+ }
+#ifdef RE_ENABLE_I18N
+ else if (type == COMPLEX_BRACKET)
+ {
+ re_charset_t *cset = dfa->nodes[node].opr.mbcset;
+ Idx i;
+
+# ifdef _LIBC
+ /* See if we have to try all bytes which start multiple collation
+ elements.
+ e.g. In da_DK, we want to catch 'a' since "aa" is a valid
+ collation element, and don't catch 'b' since 'b' is
+ the only collation element which starts from 'b' (and
+ it is caught by SIMPLE_BRACKET). */
+ if (_NL_CURRENT_WORD (LC_COLLATE, _NL_COLLATE_NRULES) != 0
+ && (cset->ncoll_syms || cset->nranges))
+ {
+ const int32_t *table = (const int32_t *)
+ _NL_CURRENT (LC_COLLATE, _NL_COLLATE_TABLEMB);
+ for (i = 0; i < SBC_MAX; ++i)
+ if (table[i] < 0)
+ re_set_fastmap (fastmap, icase, i);
+ }
+# endif /* _LIBC */
+
+ /* See if we have to start the match at all multibyte characters,
+ i.e. where we would not find an invalid sequence. This only
+ applies to multibyte character sets; for single byte character
+ sets, the SIMPLE_BRACKET again suffices. */
+ if (dfa->mb_cur_max > 1
+ && (cset->nchar_classes || cset->non_match || cset->nranges
+# ifdef _LIBC
+ || cset->nequiv_classes
+# endif /* _LIBC */
+ ))
+ {
+ unsigned char c = 0;
+ do
+ {
+ mbstate_t mbs;
+ memset (&mbs, 0, sizeof (mbs));
+ if (__mbrtowc (NULL, (char *) &c, 1, &mbs) == (size_t) -2)
+ re_set_fastmap (fastmap, false, (int) c);
+ }
+ while (++c != 0);
+ }
+
+ else
+ {
+ /* ... Else catch all bytes which can start the mbchars. */
+ for (i = 0; i < cset->nmbchars; ++i)
+ {
+ char buf[256];
+ mbstate_t state;
+ memset (&state, '\0', sizeof (state));
+ if (__wcrtomb (buf, cset->mbchars[i], &state) != (size_t) -1)
+ re_set_fastmap (fastmap, icase, *(unsigned char *) buf);
+ if ((bufp->syntax & RE_ICASE) && dfa->mb_cur_max > 1)
+ {
+ if (__wcrtomb (buf, __towlower (cset->mbchars[i]), &state)
+ != (size_t) -1)
+ re_set_fastmap (fastmap, false, *(unsigned char *) buf);
+ }
+ }
+ }
+ }
+#endif /* RE_ENABLE_I18N */
+ else if (type == OP_PERIOD
+#ifdef RE_ENABLE_I18N
+ || type == OP_UTF8_PERIOD
+#endif /* RE_ENABLE_I18N */
+ || type == END_OF_RE)
+ {
+ memset (fastmap, '\1', sizeof (char) * SBC_MAX);
+ if (type == END_OF_RE)
+ bufp->can_be_null = 1;
+ return;
+ }
+ }
+}
+
+/* Entry point for POSIX code. */
+/* regcomp takes a regular expression as a string and compiles it.
+
+ PREG is a regex_t *. We do not expect any fields to be initialized,
+ since POSIX says we shouldn't. Thus, we set
+
+ 'buffer' to the compiled pattern;
+ 'used' to the length of the compiled pattern;
+ 'syntax' to RE_SYNTAX_POSIX_EXTENDED if the
+ REG_EXTENDED bit in CFLAGS is set; otherwise, to
+ RE_SYNTAX_POSIX_BASIC;
+ 'newline_anchor' to REG_NEWLINE being set in CFLAGS;
+ 'fastmap' to an allocated space for the fastmap;
+ 'fastmap_accurate' to zero;
+ 're_nsub' to the number of subexpressions in PATTERN.
+
+ PATTERN is the address of the pattern string.
+
+ CFLAGS is a series of bits which affect compilation.
+
+ If REG_EXTENDED is set, we use POSIX extended syntax; otherwise, we
+ use POSIX basic syntax.
+
+ If REG_NEWLINE is set, then . and [^...] don't match newline.
+ Also, regexec will try a match beginning after every newline.
+
+ If REG_ICASE is set, then we considers upper- and lowercase
+ versions of letters to be equivalent when matching.
+
+ If REG_NOSUB is set, then when PREG is passed to regexec, that
+ routine will report only success or failure, and nothing about the
+ registers.
+
+ It returns 0 if it succeeds, nonzero if it doesn't. (See regex.h for
+ the return codes and their meanings.) */
+
+int
+regcomp (regex_t *__restrict preg, const char *__restrict pattern, int cflags)
+{
+ reg_errcode_t ret;
+ reg_syntax_t syntax = ((cflags & REG_EXTENDED) ? RE_SYNTAX_POSIX_EXTENDED
+ : RE_SYNTAX_POSIX_BASIC);
+
+ preg->buffer = NULL;
+ preg->allocated = 0;
+ preg->used = 0;
+
+ /* Try to allocate space for the fastmap. */
+ preg->fastmap = re_malloc (char, SBC_MAX);
+ if (__glibc_unlikely (preg->fastmap == NULL))
+ return REG_ESPACE;
+
+ syntax |= (cflags & REG_ICASE) ? RE_ICASE : 0;
+
+ /* If REG_NEWLINE is set, newlines are treated differently. */
+ if (cflags & REG_NEWLINE)
+ { /* REG_NEWLINE implies neither . nor [^...] match newline. */
+ syntax &= ~RE_DOT_NEWLINE;
+ syntax |= RE_HAT_LISTS_NOT_NEWLINE;
+ /* It also changes the matching behavior. */
+ preg->newline_anchor = 1;
+ }
+ else
+ preg->newline_anchor = 0;
+ preg->no_sub = !!(cflags & REG_NOSUB);
+ preg->translate = NULL;
+
+ ret = re_compile_internal (preg, pattern, strlen (pattern), syntax);
+
+ /* POSIX doesn't distinguish between an unmatched open-group and an
+ unmatched close-group: both are REG_EPAREN. */
+ if (ret == REG_ERPAREN)
+ ret = REG_EPAREN;
+
+ /* We have already checked preg->fastmap != NULL. */
+ if (__glibc_likely (ret == REG_NOERROR))
+ /* Compute the fastmap now, since regexec cannot modify the pattern
+ buffer. This function never fails in this implementation. */
+ (void) re_compile_fastmap (preg);
+ else
+ {
+ /* Some error occurred while compiling the expression. */
+ re_free (preg->fastmap);
+ preg->fastmap = NULL;
+ }
+
+ return (int) ret;
+}
+libc_hidden_def (__regcomp)
+weak_alias (__regcomp, regcomp)
+
+/* Returns a message corresponding to an error code, ERRCODE, returned
+ from either regcomp or regexec. We don't use PREG here. */
+
+size_t
+regerror (int errcode, const regex_t *__restrict preg, char *__restrict errbuf,
+ size_t errbuf_size)
+{
+ const char *msg;
+ size_t msg_size;
+ int nerrcodes = sizeof __re_error_msgid_idx / sizeof __re_error_msgid_idx[0];
+
+ if (__glibc_unlikely (errcode < 0 || errcode >= nerrcodes))
+ /* Only error codes returned by the rest of the code should be passed
+ to this routine. If we are given anything else, or if other regex
+ code generates an invalid error code, then the program has a bug.
+ Dump core so we can fix it. */
+ abort ();
+
+ msg = gettext (__re_error_msgid + __re_error_msgid_idx[errcode]);
+
+ msg_size = strlen (msg) + 1; /* Includes the null. */
+
+ if (__glibc_likely (errbuf_size != 0))
+ {
+ size_t cpy_size = msg_size;
+ if (__glibc_unlikely (msg_size > errbuf_size))
+ {
+ cpy_size = errbuf_size - 1;
+ errbuf[cpy_size] = '\0';
+ }
+ memcpy (errbuf, msg, cpy_size);
+ }
+
+ return msg_size;
+}
+weak_alias (__regerror, regerror)
+
+
+#ifdef RE_ENABLE_I18N
+/* This static array is used for the map to single-byte characters when
+ UTF-8 is used. Otherwise we would allocate memory just to initialize
+ it the same all the time. UTF-8 is the preferred encoding so this is
+ a worthwhile optimization. */
+static const bitset_t utf8_sb_map =
+{
+ /* Set the first 128 bits. */
+# if defined __GNUC__ && !defined __STRICT_ANSI__
+ [0 ... 0x80 / BITSET_WORD_BITS - 1] = BITSET_WORD_MAX
+# else
+# if 4 * BITSET_WORD_BITS < ASCII_CHARS
+# error "bitset_word_t is narrower than 32 bits"
+# elif 3 * BITSET_WORD_BITS < ASCII_CHARS
+ BITSET_WORD_MAX, BITSET_WORD_MAX, BITSET_WORD_MAX,
+# elif 2 * BITSET_WORD_BITS < ASCII_CHARS
+ BITSET_WORD_MAX, BITSET_WORD_MAX,
+# elif 1 * BITSET_WORD_BITS < ASCII_CHARS
+ BITSET_WORD_MAX,
+# endif
+ (BITSET_WORD_MAX
+ >> (SBC_MAX % BITSET_WORD_BITS == 0
+ ? 0
+ : BITSET_WORD_BITS - SBC_MAX % BITSET_WORD_BITS))
+# endif
+};
+#endif
+
+
+static void
+free_dfa_content (re_dfa_t *dfa)
+{
+ Idx i, j;
+
+ if (dfa->nodes)
+ for (i = 0; i < dfa->nodes_len; ++i)
+ free_token (dfa->nodes + i);
+ re_free (dfa->nexts);
+ for (i = 0; i < dfa->nodes_len; ++i)
+ {
+ if (dfa->eclosures != NULL)
+ re_node_set_free (dfa->eclosures + i);
+ if (dfa->inveclosures != NULL)
+ re_node_set_free (dfa->inveclosures + i);
+ if (dfa->edests != NULL)
+ re_node_set_free (dfa->edests + i);
+ }
+ re_free (dfa->edests);
+ re_free (dfa->eclosures);
+ re_free (dfa->inveclosures);
+ re_free (dfa->nodes);
+
+ if (dfa->state_table)
+ for (i = 0; i <= dfa->state_hash_mask; ++i)
+ {
+ struct re_state_table_entry *entry = dfa->state_table + i;
+ for (j = 0; j < entry->num; ++j)
+ {
+ re_dfastate_t *state = entry->array[j];
+ free_state (state);
+ }
+ re_free (entry->array);
+ }
+ re_free (dfa->state_table);
+#ifdef RE_ENABLE_I18N
+ if (dfa->sb_char != utf8_sb_map)
+ re_free (dfa->sb_char);
+#endif
+ re_free (dfa->subexp_map);
+#ifdef DEBUG
+ re_free (dfa->re_str);
+#endif
+
+ re_free (dfa);
+}
+
+
+/* Free dynamically allocated space used by PREG. */
+
+void
+regfree (regex_t *preg)
+{
+ re_dfa_t *dfa = preg->buffer;
+ if (__glibc_likely (dfa != NULL))
+ {
+ lock_fini (dfa->lock);
+ free_dfa_content (dfa);
+ }
+ preg->buffer = NULL;
+ preg->allocated = 0;
+
+ re_free (preg->fastmap);
+ preg->fastmap = NULL;
+
+ re_free (preg->translate);
+ preg->translate = NULL;
+}
+libc_hidden_def (__regfree)
+weak_alias (__regfree, regfree)
+
+/* Entry points compatible with 4.2 BSD regex library. We don't define
+ them unless specifically requested. */
+
+#if defined _REGEX_RE_COMP || defined _LIBC
+
+/* BSD has one and only one pattern buffer. */
+static struct re_pattern_buffer re_comp_buf;
+
+char *
+# ifdef _LIBC
+/* Make these definitions weak in libc, so POSIX programs can redefine
+ these names if they don't use our functions, and still use
+ regcomp/regexec above without link errors. */
+weak_function
+# endif
+re_comp (const char *s)
+{
+ reg_errcode_t ret;
+ char *fastmap;
+
+ if (!s)
+ {
+ if (!re_comp_buf.buffer)
+ return gettext ("No previous regular expression");
+ return 0;
+ }
+
+ if (re_comp_buf.buffer)
+ {
+ fastmap = re_comp_buf.fastmap;
+ re_comp_buf.fastmap = NULL;
+ __regfree (&re_comp_buf);
+ memset (&re_comp_buf, '\0', sizeof (re_comp_buf));
+ re_comp_buf.fastmap = fastmap;
+ }
+
+ if (re_comp_buf.fastmap == NULL)
+ {
+ re_comp_buf.fastmap = re_malloc (char, SBC_MAX);
+ if (re_comp_buf.fastmap == NULL)
+ return (char *) gettext (__re_error_msgid
+ + __re_error_msgid_idx[(int) REG_ESPACE]);
+ }
+
+ /* Since 're_exec' always passes NULL for the 'regs' argument, we
+ don't need to initialize the pattern buffer fields which affect it. */
+
+ /* Match anchors at newlines. */
+ re_comp_buf.newline_anchor = 1;
+
+ ret = re_compile_internal (&re_comp_buf, s, strlen (s), re_syntax_options);
+
+ if (!ret)
+ return NULL;
+
+ /* Yes, we're discarding 'const' here if !HAVE_LIBINTL. */
+ return (char *) gettext (__re_error_msgid + __re_error_msgid_idx[(int) ret]);
+}
+
+#ifdef _LIBC
+libc_freeres_fn (free_mem)
+{
+ __regfree (&re_comp_buf);
+}
+#endif
+
+#endif /* _REGEX_RE_COMP */
+
+/* Internal entry point.
+ Compile the regular expression PATTERN, whose length is LENGTH.
+ SYNTAX indicate regular expression's syntax. */
+
+static reg_errcode_t
+re_compile_internal (regex_t *preg, const char * pattern, size_t length,
+ reg_syntax_t syntax)
+{
+ reg_errcode_t err = REG_NOERROR;
+ re_dfa_t *dfa;
+ re_string_t regexp;
+
+ /* Initialize the pattern buffer. */
+ preg->fastmap_accurate = 0;
+ preg->syntax = syntax;
+ preg->not_bol = preg->not_eol = 0;
+ preg->used = 0;
+ preg->re_nsub = 0;
+ preg->can_be_null = 0;
+ preg->regs_allocated = REGS_UNALLOCATED;
+
+ /* Initialize the dfa. */
+ dfa = preg->buffer;
+ if (__glibc_unlikely (preg->allocated < sizeof (re_dfa_t)))
+ {
+ /* If zero allocated, but buffer is non-null, try to realloc
+ enough space. This loses if buffer's address is bogus, but
+ that is the user's responsibility. If ->buffer is NULL this
+ is a simple allocation. */
+ dfa = re_realloc (preg->buffer, re_dfa_t, 1);
+ if (dfa == NULL)
+ return REG_ESPACE;
+ preg->allocated = sizeof (re_dfa_t);
+ preg->buffer = dfa;
+ }
+ preg->used = sizeof (re_dfa_t);
+
+ err = init_dfa (dfa, length);
+ if (__glibc_unlikely (err == REG_NOERROR && lock_init (dfa->lock) != 0))
+ err = REG_ESPACE;
+ if (__glibc_unlikely (err != REG_NOERROR))
+ {
+ free_dfa_content (dfa);
+ preg->buffer = NULL;
+ preg->allocated = 0;
+ return err;
+ }
+#ifdef DEBUG
+ /* Note: length+1 will not overflow since it is checked in init_dfa. */
+ dfa->re_str = re_malloc (char, length + 1);
+ strncpy (dfa->re_str, pattern, length + 1);
+#endif
+
+ err = re_string_construct (&regexp, pattern, length, preg->translate,
+ (syntax & RE_ICASE) != 0, dfa);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ {
+ re_compile_internal_free_return:
+ free_workarea_compile (preg);
+ re_string_destruct (&regexp);
+ lock_fini (dfa->lock);
+ free_dfa_content (dfa);
+ preg->buffer = NULL;
+ preg->allocated = 0;
+ return err;
+ }
+
+ /* Parse the regular expression, and build a structure tree. */
+ preg->re_nsub = 0;
+ dfa->str_tree = parse (&regexp, preg, syntax, &err);
+ if (__glibc_unlikely (dfa->str_tree == NULL))
+ goto re_compile_internal_free_return;
+
+ /* Analyze the tree and create the nfa. */
+ err = analyze (preg);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ goto re_compile_internal_free_return;
+
+#ifdef RE_ENABLE_I18N
+ /* If possible, do searching in single byte encoding to speed things up. */
+ if (dfa->is_utf8 && !(syntax & RE_ICASE) && preg->translate == NULL)
+ optimize_utf8 (dfa);
+#endif
+
+ /* Then create the initial state of the dfa. */
+ err = create_initial_state (dfa);
+
+ /* Release work areas. */
+ free_workarea_compile (preg);
+ re_string_destruct (&regexp);
+
+ if (__glibc_unlikely (err != REG_NOERROR))
+ {
+ lock_fini (dfa->lock);
+ free_dfa_content (dfa);
+ preg->buffer = NULL;
+ preg->allocated = 0;
+ }
+
+ return err;
+}
+
+/* Initialize DFA. We use the length of the regular expression PAT_LEN
+ as the initial length of some arrays. */
+
+static reg_errcode_t
+init_dfa (re_dfa_t *dfa, size_t pat_len)
+{
+ __re_size_t table_size;
+#ifndef _LIBC
+ const char *codeset_name;
+#endif
+#ifdef RE_ENABLE_I18N
+ size_t max_i18n_object_size = MAX (sizeof (wchar_t), sizeof (wctype_t));
+#else
+ size_t max_i18n_object_size = 0;
+#endif
+ size_t max_object_size =
+ MAX (sizeof (struct re_state_table_entry),
+ MAX (sizeof (re_token_t),
+ MAX (sizeof (re_node_set),
+ MAX (sizeof (regmatch_t),
+ max_i18n_object_size))));
+
+ memset (dfa, '\0', sizeof (re_dfa_t));
+
+ /* Force allocation of str_tree_storage the first time. */
+ dfa->str_tree_storage_idx = BIN_TREE_STORAGE_SIZE;
+
+ /* Avoid overflows. The extra "/ 2" is for the table_size doubling
+ calculation below, and for similar doubling calculations
+ elsewhere. And it's <= rather than <, because some of the
+ doubling calculations add 1 afterwards. */
+ if (__glibc_unlikely (MIN (IDX_MAX, SIZE_MAX / max_object_size) / 2
+ <= pat_len))
+ return REG_ESPACE;
+
+ dfa->nodes_alloc = pat_len + 1;
+ dfa->nodes = re_malloc (re_token_t, dfa->nodes_alloc);
+
+ /* table_size = 2 ^ ceil(log pat_len) */
+ for (table_size = 1; ; table_size <<= 1)
+ if (table_size > pat_len)
+ break;
+
+ dfa->state_table = calloc (sizeof (struct re_state_table_entry), table_size);
+ dfa->state_hash_mask = table_size - 1;
+
+ dfa->mb_cur_max = MB_CUR_MAX;
+#ifdef _LIBC
+ if (dfa->mb_cur_max == 6
+ && strcmp (_NL_CURRENT (LC_CTYPE, _NL_CTYPE_CODESET_NAME), "UTF-8") == 0)
+ dfa->is_utf8 = 1;
+ dfa->map_notascii = (_NL_CURRENT_WORD (LC_CTYPE, _NL_CTYPE_MAP_TO_NONASCII)
+ != 0);
+#else
+ codeset_name = nl_langinfo (CODESET);
+ if ((codeset_name[0] == 'U' || codeset_name[0] == 'u')
+ && (codeset_name[1] == 'T' || codeset_name[1] == 't')
+ && (codeset_name[2] == 'F' || codeset_name[2] == 'f')
+ && strcmp (codeset_name + 3 + (codeset_name[3] == '-'), "8") == 0)
+ dfa->is_utf8 = 1;
+
+ /* We check exhaustively in the loop below if this charset is a
+ superset of ASCII. */
+ dfa->map_notascii = 0;
+#endif
+
+#ifdef RE_ENABLE_I18N
+ if (dfa->mb_cur_max > 1)
+ {
+ if (dfa->is_utf8)
+ dfa->sb_char = (re_bitset_ptr_t) utf8_sb_map;
+ else
+ {
+ int i, j, ch;
+
+ dfa->sb_char = (re_bitset_ptr_t) calloc (sizeof (bitset_t), 1);
+ if (__glibc_unlikely (dfa->sb_char == NULL))
+ return REG_ESPACE;
+
+ /* Set the bits corresponding to single byte chars. */
+ for (i = 0, ch = 0; i < BITSET_WORDS; ++i)
+ for (j = 0; j < BITSET_WORD_BITS; ++j, ++ch)
+ {
+ wint_t wch = __btowc (ch);
+ if (wch != WEOF)
+ dfa->sb_char[i] |= (bitset_word_t) 1 << j;
+# ifndef _LIBC
+ if (isascii (ch) && wch != ch)
+ dfa->map_notascii = 1;
+# endif
+ }
+ }
+ }
+#endif
+
+ if (__glibc_unlikely (dfa->nodes == NULL || dfa->state_table == NULL))
+ return REG_ESPACE;
+ return REG_NOERROR;
+}
+
+/* Initialize WORD_CHAR table, which indicate which character is
+ "word". In this case "word" means that it is the word construction
+ character used by some operators like "\<", "\>", etc. */
+
+static void
+init_word_char (re_dfa_t *dfa)
+{
+ int i = 0;
+ int j;
+ int ch = 0;
+ dfa->word_ops_used = 1;
+ if (__glibc_likely (dfa->map_notascii == 0))
+ {
+ /* Avoid uint32_t and uint64_t as some non-GCC platforms lack
+ them, an issue when this code is used in Gnulib. */
+ bitset_word_t bits0 = 0x00000000;
+ bitset_word_t bits1 = 0x03ff0000;
+ bitset_word_t bits2 = 0x87fffffe;
+ bitset_word_t bits3 = 0x07fffffe;
+ if (BITSET_WORD_BITS == 64)
+ {
+ /* Pacify gcc -Woverflow on 32-bit platformns. */
+ dfa->word_char[0] = bits1 << 31 << 1 | bits0;
+ dfa->word_char[1] = bits3 << 31 << 1 | bits2;
+ i = 2;
+ }
+ else if (BITSET_WORD_BITS == 32)
+ {
+ dfa->word_char[0] = bits0;
+ dfa->word_char[1] = bits1;
+ dfa->word_char[2] = bits2;
+ dfa->word_char[3] = bits3;
+ i = 4;
+ }
+ else
+ goto general_case;
+ ch = 128;
+
+ if (__glibc_likely (dfa->is_utf8))
+ {
+ memset (&dfa->word_char[i], '\0', (SBC_MAX - ch) / 8);
+ return;
+ }
+ }
+
+ general_case:
+ for (; i < BITSET_WORDS; ++i)
+ for (j = 0; j < BITSET_WORD_BITS; ++j, ++ch)
+ if (isalnum (ch) || ch == '_')
+ dfa->word_char[i] |= (bitset_word_t) 1 << j;
+}
+
+/* Free the work area which are only used while compiling. */
+
+static void
+free_workarea_compile (regex_t *preg)
+{
+ re_dfa_t *dfa = preg->buffer;
+ bin_tree_storage_t *storage, *next;
+ for (storage = dfa->str_tree_storage; storage; storage = next)
+ {
+ next = storage->next;
+ re_free (storage);
+ }
+ dfa->str_tree_storage = NULL;
+ dfa->str_tree_storage_idx = BIN_TREE_STORAGE_SIZE;
+ dfa->str_tree = NULL;
+ re_free (dfa->org_indices);
+ dfa->org_indices = NULL;
+}
+
+/* Create initial states for all contexts. */
+
+static reg_errcode_t
+create_initial_state (re_dfa_t *dfa)
+{
+ Idx first, i;
+ reg_errcode_t err;
+ re_node_set init_nodes;
+
+ /* Initial states have the epsilon closure of the node which is
+ the first node of the regular expression. */
+ first = dfa->str_tree->first->node_idx;
+ dfa->init_node = first;
+ err = re_node_set_init_copy (&init_nodes, dfa->eclosures + first);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+
+ /* The back-references which are in initial states can epsilon transit,
+ since in this case all of the subexpressions can be null.
+ Then we add epsilon closures of the nodes which are the next nodes of
+ the back-references. */
+ if (dfa->nbackref > 0)
+ for (i = 0; i < init_nodes.nelem; ++i)
+ {
+ Idx node_idx = init_nodes.elems[i];
+ re_token_type_t type = dfa->nodes[node_idx].type;
+
+ Idx clexp_idx;
+ if (type != OP_BACK_REF)
+ continue;
+ for (clexp_idx = 0; clexp_idx < init_nodes.nelem; ++clexp_idx)
+ {
+ re_token_t *clexp_node;
+ clexp_node = dfa->nodes + init_nodes.elems[clexp_idx];
+ if (clexp_node->type == OP_CLOSE_SUBEXP
+ && clexp_node->opr.idx == dfa->nodes[node_idx].opr.idx)
+ break;
+ }
+ if (clexp_idx == init_nodes.nelem)
+ continue;
+
+ if (type == OP_BACK_REF)
+ {
+ Idx dest_idx = dfa->edests[node_idx].elems[0];
+ if (!re_node_set_contains (&init_nodes, dest_idx))
+ {
+ reg_errcode_t merge_err
+ = re_node_set_merge (&init_nodes, dfa->eclosures + dest_idx);
+ if (merge_err != REG_NOERROR)
+ return merge_err;
+ i = 0;
+ }
+ }
+ }
+
+ /* It must be the first time to invoke acquire_state. */
+ dfa->init_state = re_acquire_state_context (&err, dfa, &init_nodes, 0);
+ /* We don't check ERR here, since the initial state must not be NULL. */
+ if (__glibc_unlikely (dfa->init_state == NULL))
+ return err;
+ if (dfa->init_state->has_constraint)
+ {
+ dfa->init_state_word = re_acquire_state_context (&err, dfa, &init_nodes,
+ CONTEXT_WORD);
+ dfa->init_state_nl = re_acquire_state_context (&err, dfa, &init_nodes,
+ CONTEXT_NEWLINE);
+ dfa->init_state_begbuf = re_acquire_state_context (&err, dfa,
+ &init_nodes,
+ CONTEXT_NEWLINE
+ | CONTEXT_BEGBUF);
+ if (__glibc_unlikely (dfa->init_state_word == NULL
+ || dfa->init_state_nl == NULL
+ || dfa->init_state_begbuf == NULL))
+ return err;
+ }
+ else
+ dfa->init_state_word = dfa->init_state_nl
+ = dfa->init_state_begbuf = dfa->init_state;
+
+ re_node_set_free (&init_nodes);
+ return REG_NOERROR;
+}
+
+#ifdef RE_ENABLE_I18N
+/* If it is possible to do searching in single byte encoding instead of UTF-8
+ to speed things up, set dfa->mb_cur_max to 1, clear is_utf8 and change
+ DFA nodes where needed. */
+
+static void
+optimize_utf8 (re_dfa_t *dfa)
+{
+ Idx node;
+ int i;
+ bool mb_chars = false;
+ bool has_period = false;
+
+ for (node = 0; node < dfa->nodes_len; ++node)
+ switch (dfa->nodes[node].type)
+ {
+ case CHARACTER:
+ if (dfa->nodes[node].opr.c >= ASCII_CHARS)
+ mb_chars = true;
+ break;
+ case ANCHOR:
+ switch (dfa->nodes[node].opr.ctx_type)
+ {
+ case LINE_FIRST:
+ case LINE_LAST:
+ case BUF_FIRST:
+ case BUF_LAST:
+ break;
+ default:
+ /* Word anchors etc. cannot be handled. It's okay to test
+ opr.ctx_type since constraints (for all DFA nodes) are
+ created by ORing one or more opr.ctx_type values. */
+ return;
+ }
+ break;
+ case OP_PERIOD:
+ has_period = true;
+ break;
+ case OP_BACK_REF:
+ case OP_ALT:
+ case END_OF_RE:
+ case OP_DUP_ASTERISK:
+ case OP_OPEN_SUBEXP:
+ case OP_CLOSE_SUBEXP:
+ break;
+ case COMPLEX_BRACKET:
+ return;
+ case SIMPLE_BRACKET:
+ /* Just double check. */
+ {
+ int rshift = (ASCII_CHARS % BITSET_WORD_BITS == 0
+ ? 0
+ : BITSET_WORD_BITS - ASCII_CHARS % BITSET_WORD_BITS);
+ for (i = ASCII_CHARS / BITSET_WORD_BITS; i < BITSET_WORDS; ++i)
+ {
+ if (dfa->nodes[node].opr.sbcset[i] >> rshift != 0)
+ return;
+ rshift = 0;
+ }
+ }
+ break;
+ default:
+ abort ();
+ }
+
+ if (mb_chars || has_period)
+ for (node = 0; node < dfa->nodes_len; ++node)
+ {
+ if (dfa->nodes[node].type == CHARACTER
+ && dfa->nodes[node].opr.c >= ASCII_CHARS)
+ dfa->nodes[node].mb_partial = 0;
+ else if (dfa->nodes[node].type == OP_PERIOD)
+ dfa->nodes[node].type = OP_UTF8_PERIOD;
+ }
+
+ /* The search can be in single byte locale. */
+ dfa->mb_cur_max = 1;
+ dfa->is_utf8 = 0;
+ dfa->has_mb_node = dfa->nbackref > 0 || has_period;
+}
+#endif
+
+/* Analyze the structure tree, and calculate "first", "next", "edest",
+ "eclosure", and "inveclosure". */
+
+static reg_errcode_t
+analyze (regex_t *preg)
+{
+ re_dfa_t *dfa = preg->buffer;
+ reg_errcode_t ret;
+
+ /* Allocate arrays. */
+ dfa->nexts = re_malloc (Idx, dfa->nodes_alloc);
+ dfa->org_indices = re_malloc (Idx, dfa->nodes_alloc);
+ dfa->edests = re_malloc (re_node_set, dfa->nodes_alloc);
+ dfa->eclosures = re_malloc (re_node_set, dfa->nodes_alloc);
+ if (__glibc_unlikely (dfa->nexts == NULL || dfa->org_indices == NULL
+ || dfa->edests == NULL || dfa->eclosures == NULL))
+ return REG_ESPACE;
+
+ dfa->subexp_map = re_malloc (Idx, preg->re_nsub);
+ if (dfa->subexp_map != NULL)
+ {
+ Idx i;
+ for (i = 0; i < preg->re_nsub; i++)
+ dfa->subexp_map[i] = i;
+ preorder (dfa->str_tree, optimize_subexps, dfa);
+ for (i = 0; i < preg->re_nsub; i++)
+ if (dfa->subexp_map[i] != i)
+ break;
+ if (i == preg->re_nsub)
+ {
+ re_free (dfa->subexp_map);
+ dfa->subexp_map = NULL;
+ }
+ }
+
+ ret = postorder (dfa->str_tree, lower_subexps, preg);
+ if (__glibc_unlikely (ret != REG_NOERROR))
+ return ret;
+ ret = postorder (dfa->str_tree, calc_first, dfa);
+ if (__glibc_unlikely (ret != REG_NOERROR))
+ return ret;
+ preorder (dfa->str_tree, calc_next, dfa);
+ ret = preorder (dfa->str_tree, link_nfa_nodes, dfa);
+ if (__glibc_unlikely (ret != REG_NOERROR))
+ return ret;
+ ret = calc_eclosure (dfa);
+ if (__glibc_unlikely (ret != REG_NOERROR))
+ return ret;
+
+ /* We only need this during the prune_impossible_nodes pass in regexec.c;
+ skip it if p_i_n will not run, as calc_inveclosure can be quadratic. */
+ if ((!preg->no_sub && preg->re_nsub > 0 && dfa->has_plural_match)
+ || dfa->nbackref)
+ {
+ dfa->inveclosures = re_malloc (re_node_set, dfa->nodes_len);
+ if (__glibc_unlikely (dfa->inveclosures == NULL))
+ return REG_ESPACE;
+ ret = calc_inveclosure (dfa);
+ }
+
+ return ret;
+}
+
+/* Our parse trees are very unbalanced, so we cannot use a stack to
+ implement parse tree visits. Instead, we use parent pointers and
+ some hairy code in these two functions. */
+static reg_errcode_t
+postorder (bin_tree_t *root, reg_errcode_t (fn (void *, bin_tree_t *)),
+ void *extra)
+{
+ bin_tree_t *node, *prev;
+
+ for (node = root; ; )
+ {
+ /* Descend down the tree, preferably to the left (or to the right
+ if that's the only child). */
+ while (node->left || node->right)
+ if (node->left)
+ node = node->left;
+ else
+ node = node->right;
+
+ do
+ {
+ reg_errcode_t err = fn (extra, node);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ if (node->parent == NULL)
+ return REG_NOERROR;
+ prev = node;
+ node = node->parent;
+ }
+ /* Go up while we have a node that is reached from the right. */
+ while (node->right == prev || node->right == NULL);
+ node = node->right;
+ }
+}
+
+static reg_errcode_t
+preorder (bin_tree_t *root, reg_errcode_t (fn (void *, bin_tree_t *)),
+ void *extra)
+{
+ bin_tree_t *node;
+
+ for (node = root; ; )
+ {
+ reg_errcode_t err = fn (extra, node);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+
+ /* Go to the left node, or up and to the right. */
+ if (node->left)
+ node = node->left;
+ else
+ {
+ bin_tree_t *prev = NULL;
+ while (node->right == prev || node->right == NULL)
+ {
+ prev = node;
+ node = node->parent;
+ if (!node)
+ return REG_NOERROR;
+ }
+ node = node->right;
+ }
+ }
+}
+
+/* Optimization pass: if a SUBEXP is entirely contained, strip it and tell
+ re_search_internal to map the inner one's opr.idx to this one's. Adjust
+ backreferences as well. Requires a preorder visit. */
+static reg_errcode_t
+optimize_subexps (void *extra, bin_tree_t *node)
+{
+ re_dfa_t *dfa = (re_dfa_t *) extra;
+
+ if (node->token.type == OP_BACK_REF && dfa->subexp_map)
+ {
+ int idx = node->token.opr.idx;
+ node->token.opr.idx = dfa->subexp_map[idx];
+ dfa->used_bkref_map |= 1 << node->token.opr.idx;
+ }
+
+ else if (node->token.type == SUBEXP
+ && node->left && node->left->token.type == SUBEXP)
+ {
+ Idx other_idx = node->left->token.opr.idx;
+
+ node->left = node->left->left;
+ if (node->left)
+ node->left->parent = node;
+
+ dfa->subexp_map[other_idx] = dfa->subexp_map[node->token.opr.idx];
+ if (other_idx < BITSET_WORD_BITS)
+ dfa->used_bkref_map &= ~((bitset_word_t) 1 << other_idx);
+ }
+
+ return REG_NOERROR;
+}
+
+/* Lowering pass: Turn each SUBEXP node into the appropriate concatenation
+ of OP_OPEN_SUBEXP, the body of the SUBEXP (if any) and OP_CLOSE_SUBEXP. */
+static reg_errcode_t
+lower_subexps (void *extra, bin_tree_t *node)
+{
+ regex_t *preg = (regex_t *) extra;
+ reg_errcode_t err = REG_NOERROR;
+
+ if (node->left && node->left->token.type == SUBEXP)
+ {
+ node->left = lower_subexp (&err, preg, node->left);
+ if (node->left)
+ node->left->parent = node;
+ }
+ if (node->right && node->right->token.type == SUBEXP)
+ {
+ node->right = lower_subexp (&err, preg, node->right);
+ if (node->right)
+ node->right->parent = node;
+ }
+
+ return err;
+}
+
+static bin_tree_t *
+lower_subexp (reg_errcode_t *err, regex_t *preg, bin_tree_t *node)
+{
+ re_dfa_t *dfa = preg->buffer;
+ bin_tree_t *body = node->left;
+ bin_tree_t *op, *cls, *tree1, *tree;
+
+ if (preg->no_sub
+ /* We do not optimize empty subexpressions, because otherwise we may
+ have bad CONCAT nodes with NULL children. This is obviously not
+ very common, so we do not lose much. An example that triggers
+ this case is the sed "script" /\(\)/x. */
+ && node->left != NULL
+ && (node->token.opr.idx >= BITSET_WORD_BITS
+ || !(dfa->used_bkref_map
+ & ((bitset_word_t) 1 << node->token.opr.idx))))
+ return node->left;
+
+ /* Convert the SUBEXP node to the concatenation of an
+ OP_OPEN_SUBEXP, the contents, and an OP_CLOSE_SUBEXP. */
+ op = create_tree (dfa, NULL, NULL, OP_OPEN_SUBEXP);
+ cls = create_tree (dfa, NULL, NULL, OP_CLOSE_SUBEXP);
+ tree1 = body ? create_tree (dfa, body, cls, CONCAT) : cls;
+ tree = create_tree (dfa, op, tree1, CONCAT);
+ if (__glibc_unlikely (tree == NULL || tree1 == NULL
+ || op == NULL || cls == NULL))
+ {
+ *err = REG_ESPACE;
+ return NULL;
+ }
+
+ op->token.opr.idx = cls->token.opr.idx = node->token.opr.idx;
+ op->token.opt_subexp = cls->token.opt_subexp = node->token.opt_subexp;
+ return tree;
+}
+
+/* Pass 1 in building the NFA: compute FIRST and create unlinked automaton
+ nodes. Requires a postorder visit. */
+static reg_errcode_t
+calc_first (void *extra, bin_tree_t *node)
+{
+ re_dfa_t *dfa = (re_dfa_t *) extra;
+ if (node->token.type == CONCAT)
+ {
+ node->first = node->left->first;
+ node->node_idx = node->left->node_idx;
+ }
+ else
+ {
+ node->first = node;
+ node->node_idx = re_dfa_add_node (dfa, node->token);
+ if (__glibc_unlikely (node->node_idx == -1))
+ return REG_ESPACE;
+ if (node->token.type == ANCHOR)
+ dfa->nodes[node->node_idx].constraint = node->token.opr.ctx_type;
+ }
+ return REG_NOERROR;
+}
+
+/* Pass 2: compute NEXT on the tree. Preorder visit. */
+static reg_errcode_t
+calc_next (void *extra, bin_tree_t *node)
+{
+ switch (node->token.type)
+ {
+ case OP_DUP_ASTERISK:
+ node->left->next = node;
+ break;
+ case CONCAT:
+ node->left->next = node->right->first;
+ node->right->next = node->next;
+ break;
+ default:
+ if (node->left)
+ node->left->next = node->next;
+ if (node->right)
+ node->right->next = node->next;
+ break;
+ }
+ return REG_NOERROR;
+}
+
+/* Pass 3: link all DFA nodes to their NEXT node (any order will do). */
+static reg_errcode_t
+link_nfa_nodes (void *extra, bin_tree_t *node)
+{
+ re_dfa_t *dfa = (re_dfa_t *) extra;
+ Idx idx = node->node_idx;
+ reg_errcode_t err = REG_NOERROR;
+
+ switch (node->token.type)
+ {
+ case CONCAT:
+ break;
+
+ case END_OF_RE:
+ assert (node->next == NULL);
+ break;
+
+ case OP_DUP_ASTERISK:
+ case OP_ALT:
+ {
+ Idx left, right;
+ dfa->has_plural_match = 1;
+ if (node->left != NULL)
+ left = node->left->first->node_idx;
+ else
+ left = node->next->node_idx;
+ if (node->right != NULL)
+ right = node->right->first->node_idx;
+ else
+ right = node->next->node_idx;
+ assert (left > -1);
+ assert (right > -1);
+ err = re_node_set_init_2 (dfa->edests + idx, left, right);
+ }
+ break;
+
+ case ANCHOR:
+ case OP_OPEN_SUBEXP:
+ case OP_CLOSE_SUBEXP:
+ err = re_node_set_init_1 (dfa->edests + idx, node->next->node_idx);
+ break;
+
+ case OP_BACK_REF:
+ dfa->nexts[idx] = node->next->node_idx;
+ if (node->token.type == OP_BACK_REF)
+ err = re_node_set_init_1 (dfa->edests + idx, dfa->nexts[idx]);
+ break;
+
+ default:
+ assert (!IS_EPSILON_NODE (node->token.type));
+ dfa->nexts[idx] = node->next->node_idx;
+ break;
+ }
+
+ return err;
+}
+
+/* Duplicate the epsilon closure of the node ROOT_NODE.
+ Note that duplicated nodes have constraint INIT_CONSTRAINT in addition
+ to their own constraint. */
+
+static reg_errcode_t
+duplicate_node_closure (re_dfa_t *dfa, Idx top_org_node, Idx top_clone_node,
+ Idx root_node, unsigned int init_constraint)
+{
+ Idx org_node, clone_node;
+ bool ok;
+ unsigned int constraint = init_constraint;
+ for (org_node = top_org_node, clone_node = top_clone_node;;)
+ {
+ Idx org_dest, clone_dest;
+ if (dfa->nodes[org_node].type == OP_BACK_REF)
+ {
+ /* If the back reference epsilon-transit, its destination must
+ also have the constraint. Then duplicate the epsilon closure
+ of the destination of the back reference, and store it in
+ edests of the back reference. */
+ org_dest = dfa->nexts[org_node];
+ re_node_set_empty (dfa->edests + clone_node);
+ clone_dest = duplicate_node (dfa, org_dest, constraint);
+ if (__glibc_unlikely (clone_dest == -1))
+ return REG_ESPACE;
+ dfa->nexts[clone_node] = dfa->nexts[org_node];
+ ok = re_node_set_insert (dfa->edests + clone_node, clone_dest);
+ if (__glibc_unlikely (! ok))
+ return REG_ESPACE;
+ }
+ else if (dfa->edests[org_node].nelem == 0)
+ {
+ /* In case of the node can't epsilon-transit, don't duplicate the
+ destination and store the original destination as the
+ destination of the node. */
+ dfa->nexts[clone_node] = dfa->nexts[org_node];
+ break;
+ }
+ else if (dfa->edests[org_node].nelem == 1)
+ {
+ /* In case of the node can epsilon-transit, and it has only one
+ destination. */
+ org_dest = dfa->edests[org_node].elems[0];
+ re_node_set_empty (dfa->edests + clone_node);
+ /* If the node is root_node itself, it means the epsilon closure
+ has a loop. Then tie it to the destination of the root_node. */
+ if (org_node == root_node && clone_node != org_node)
+ {
+ ok = re_node_set_insert (dfa->edests + clone_node, org_dest);
+ if (__glibc_unlikely (! ok))
+ return REG_ESPACE;
+ break;
+ }
+ /* In case the node has another constraint, append it. */
+ constraint |= dfa->nodes[org_node].constraint;
+ clone_dest = duplicate_node (dfa, org_dest, constraint);
+ if (__glibc_unlikely (clone_dest == -1))
+ return REG_ESPACE;
+ ok = re_node_set_insert (dfa->edests + clone_node, clone_dest);
+ if (__glibc_unlikely (! ok))
+ return REG_ESPACE;
+ }
+ else /* dfa->edests[org_node].nelem == 2 */
+ {
+ /* In case of the node can epsilon-transit, and it has two
+ destinations. In the bin_tree_t and DFA, that's '|' and '*'. */
+ org_dest = dfa->edests[org_node].elems[0];
+ re_node_set_empty (dfa->edests + clone_node);
+ /* Search for a duplicated node which satisfies the constraint. */
+ clone_dest = search_duplicated_node (dfa, org_dest, constraint);
+ if (clone_dest == -1)
+ {
+ /* There is no such duplicated node, create a new one. */
+ reg_errcode_t err;
+ clone_dest = duplicate_node (dfa, org_dest, constraint);
+ if (__glibc_unlikely (clone_dest == -1))
+ return REG_ESPACE;
+ ok = re_node_set_insert (dfa->edests + clone_node, clone_dest);
+ if (__glibc_unlikely (! ok))
+ return REG_ESPACE;
+ err = duplicate_node_closure (dfa, org_dest, clone_dest,
+ root_node, constraint);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ }
+ else
+ {
+ /* There is a duplicated node which satisfies the constraint,
+ use it to avoid infinite loop. */
+ ok = re_node_set_insert (dfa->edests + clone_node, clone_dest);
+ if (__glibc_unlikely (! ok))
+ return REG_ESPACE;
+ }
+
+ org_dest = dfa->edests[org_node].elems[1];
+ clone_dest = duplicate_node (dfa, org_dest, constraint);
+ if (__glibc_unlikely (clone_dest == -1))
+ return REG_ESPACE;
+ ok = re_node_set_insert (dfa->edests + clone_node, clone_dest);
+ if (__glibc_unlikely (! ok))
+ return REG_ESPACE;
+ }
+ org_node = org_dest;
+ clone_node = clone_dest;
+ }
+ return REG_NOERROR;
+}
+
+/* Search for a node which is duplicated from the node ORG_NODE, and
+ satisfies the constraint CONSTRAINT. */
+
+static Idx
+search_duplicated_node (const re_dfa_t *dfa, Idx org_node,
+ unsigned int constraint)
+{
+ Idx idx;
+ for (idx = dfa->nodes_len - 1; dfa->nodes[idx].duplicated && idx > 0; --idx)
+ {
+ if (org_node == dfa->org_indices[idx]
+ && constraint == dfa->nodes[idx].constraint)
+ return idx; /* Found. */
+ }
+ return -1; /* Not found. */
+}
+
+/* Duplicate the node whose index is ORG_IDX and set the constraint CONSTRAINT.
+ Return the index of the new node, or -1 if insufficient storage is
+ available. */
+
+static Idx
+duplicate_node (re_dfa_t *dfa, Idx org_idx, unsigned int constraint)
+{
+ Idx dup_idx = re_dfa_add_node (dfa, dfa->nodes[org_idx]);
+ if (__glibc_likely (dup_idx != -1))
+ {
+ dfa->nodes[dup_idx].constraint = constraint;
+ dfa->nodes[dup_idx].constraint |= dfa->nodes[org_idx].constraint;
+ dfa->nodes[dup_idx].duplicated = 1;
+
+ /* Store the index of the original node. */
+ dfa->org_indices[dup_idx] = org_idx;
+ }
+ return dup_idx;
+}
+
+static reg_errcode_t
+calc_inveclosure (re_dfa_t *dfa)
+{
+ Idx src, idx;
+ bool ok;
+ for (idx = 0; idx < dfa->nodes_len; ++idx)
+ re_node_set_init_empty (dfa->inveclosures + idx);
+
+ for (src = 0; src < dfa->nodes_len; ++src)
+ {
+ Idx *elems = dfa->eclosures[src].elems;
+ for (idx = 0; idx < dfa->eclosures[src].nelem; ++idx)
+ {
+ ok = re_node_set_insert_last (dfa->inveclosures + elems[idx], src);
+ if (__glibc_unlikely (! ok))
+ return REG_ESPACE;
+ }
+ }
+
+ return REG_NOERROR;
+}
+
+/* Calculate "eclosure" for all the node in DFA. */
+
+static reg_errcode_t
+calc_eclosure (re_dfa_t *dfa)
+{
+ Idx node_idx;
+ bool incomplete;
+#ifdef DEBUG
+ assert (dfa->nodes_len > 0);
+#endif
+ incomplete = false;
+ /* For each nodes, calculate epsilon closure. */
+ for (node_idx = 0; ; ++node_idx)
+ {
+ reg_errcode_t err;
+ re_node_set eclosure_elem;
+ if (node_idx == dfa->nodes_len)
+ {
+ if (!incomplete)
+ break;
+ incomplete = false;
+ node_idx = 0;
+ }
+
+#ifdef DEBUG
+ assert (dfa->eclosures[node_idx].nelem != -1);
+#endif
+
+ /* If we have already calculated, skip it. */
+ if (dfa->eclosures[node_idx].nelem != 0)
+ continue;
+ /* Calculate epsilon closure of 'node_idx'. */
+ err = calc_eclosure_iter (&eclosure_elem, dfa, node_idx, true);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+
+ if (dfa->eclosures[node_idx].nelem == 0)
+ {
+ incomplete = true;
+ re_node_set_free (&eclosure_elem);
+ }
+ }
+ return REG_NOERROR;
+}
+
+/* Calculate epsilon closure of NODE. */
+
+static reg_errcode_t
+calc_eclosure_iter (re_node_set *new_set, re_dfa_t *dfa, Idx node, bool root)
+{
+ reg_errcode_t err;
+ Idx i;
+ re_node_set eclosure;
+ bool ok;
+ bool incomplete = false;
+ err = re_node_set_alloc (&eclosure, dfa->edests[node].nelem + 1);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+
+ /* This indicates that we are calculating this node now.
+ We reference this value to avoid infinite loop. */
+ dfa->eclosures[node].nelem = -1;
+
+ /* If the current node has constraints, duplicate all nodes
+ since they must inherit the constraints. */
+ if (dfa->nodes[node].constraint
+ && dfa->edests[node].nelem
+ && !dfa->nodes[dfa->edests[node].elems[0]].duplicated)
+ {
+ err = duplicate_node_closure (dfa, node, node, node,
+ dfa->nodes[node].constraint);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ }
+
+ /* Expand each epsilon destination nodes. */
+ if (IS_EPSILON_NODE(dfa->nodes[node].type))
+ for (i = 0; i < dfa->edests[node].nelem; ++i)
+ {
+ re_node_set eclosure_elem;
+ Idx edest = dfa->edests[node].elems[i];
+ /* If calculating the epsilon closure of 'edest' is in progress,
+ return intermediate result. */
+ if (dfa->eclosures[edest].nelem == -1)
+ {
+ incomplete = true;
+ continue;
+ }
+ /* If we haven't calculated the epsilon closure of 'edest' yet,
+ calculate now. Otherwise use calculated epsilon closure. */
+ if (dfa->eclosures[edest].nelem == 0)
+ {
+ err = calc_eclosure_iter (&eclosure_elem, dfa, edest, false);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ }
+ else
+ eclosure_elem = dfa->eclosures[edest];
+ /* Merge the epsilon closure of 'edest'. */
+ err = re_node_set_merge (&eclosure, &eclosure_elem);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ /* If the epsilon closure of 'edest' is incomplete,
+ the epsilon closure of this node is also incomplete. */
+ if (dfa->eclosures[edest].nelem == 0)
+ {
+ incomplete = true;
+ re_node_set_free (&eclosure_elem);
+ }
+ }
+
+ /* An epsilon closure includes itself. */
+ ok = re_node_set_insert (&eclosure, node);
+ if (__glibc_unlikely (! ok))
+ return REG_ESPACE;
+ if (incomplete && !root)
+ dfa->eclosures[node].nelem = 0;
+ else
+ dfa->eclosures[node] = eclosure;
+ *new_set = eclosure;
+ return REG_NOERROR;
+}
+
+/* Functions for token which are used in the parser. */
+
+/* Fetch a token from INPUT.
+ We must not use this function inside bracket expressions. */
+
+static void
+fetch_token (re_token_t *result, re_string_t *input, reg_syntax_t syntax)
+{
+ re_string_skip_bytes (input, peek_token (result, input, syntax));
+}
+
+/* Peek a token from INPUT, and return the length of the token.
+ We must not use this function inside bracket expressions. */
+
+static int
+peek_token (re_token_t *token, re_string_t *input, reg_syntax_t syntax)
+{
+ unsigned char c;
+
+ if (re_string_eoi (input))
+ {
+ token->type = END_OF_RE;
+ return 0;
+ }
+
+ c = re_string_peek_byte (input, 0);
+ token->opr.c = c;
+
+ token->word_char = 0;
+#ifdef RE_ENABLE_I18N
+ token->mb_partial = 0;
+ if (input->mb_cur_max > 1
+ && !re_string_first_byte (input, re_string_cur_idx (input)))
+ {
+ token->type = CHARACTER;
+ token->mb_partial = 1;
+ return 1;
+ }
+#endif
+ if (c == '\\')
+ {
+ unsigned char c2;
+ if (re_string_cur_idx (input) + 1 >= re_string_length (input))
+ {
+ token->type = BACK_SLASH;
+ return 1;
+ }
+
+ c2 = re_string_peek_byte_case (input, 1);
+ token->opr.c = c2;
+ token->type = CHARACTER;
+#ifdef RE_ENABLE_I18N
+ if (input->mb_cur_max > 1)
+ {
+ wint_t wc = re_string_wchar_at (input,
+ re_string_cur_idx (input) + 1);
+ token->word_char = IS_WIDE_WORD_CHAR (wc) != 0;
+ }
+ else
+#endif
+ token->word_char = IS_WORD_CHAR (c2) != 0;
+
+ switch (c2)
+ {
+ case '|':
+ if (!(syntax & RE_LIMITED_OPS) && !(syntax & RE_NO_BK_VBAR))
+ token->type = OP_ALT;
+ break;
+ case '1': case '2': case '3': case '4': case '5':
+ case '6': case '7': case '8': case '9':
+ if (!(syntax & RE_NO_BK_REFS))
+ {
+ token->type = OP_BACK_REF;
+ token->opr.idx = c2 - '1';
+ }
+ break;
+ case '<':
+ if (!(syntax & RE_NO_GNU_OPS))
+ {
+ token->type = ANCHOR;
+ token->opr.ctx_type = WORD_FIRST;
+ }
+ break;
+ case '>':
+ if (!(syntax & RE_NO_GNU_OPS))
+ {
+ token->type = ANCHOR;
+ token->opr.ctx_type = WORD_LAST;
+ }
+ break;
+ case 'b':
+ if (!(syntax & RE_NO_GNU_OPS))
+ {
+ token->type = ANCHOR;
+ token->opr.ctx_type = WORD_DELIM;
+ }
+ break;
+ case 'B':
+ if (!(syntax & RE_NO_GNU_OPS))
+ {
+ token->type = ANCHOR;
+ token->opr.ctx_type = NOT_WORD_DELIM;
+ }
+ break;
+ case 'w':
+ if (!(syntax & RE_NO_GNU_OPS))
+ token->type = OP_WORD;
+ break;
+ case 'W':
+ if (!(syntax & RE_NO_GNU_OPS))
+ token->type = OP_NOTWORD;
+ break;
+ case 's':
+ if (!(syntax & RE_NO_GNU_OPS))
+ token->type = OP_SPACE;
+ break;
+ case 'S':
+ if (!(syntax & RE_NO_GNU_OPS))
+ token->type = OP_NOTSPACE;
+ break;
+ case '`':
+ if (!(syntax & RE_NO_GNU_OPS))
+ {
+ token->type = ANCHOR;
+ token->opr.ctx_type = BUF_FIRST;
+ }
+ break;
+ case '\'':
+ if (!(syntax & RE_NO_GNU_OPS))
+ {
+ token->type = ANCHOR;
+ token->opr.ctx_type = BUF_LAST;
+ }
+ break;
+ case '(':
+ if (!(syntax & RE_NO_BK_PARENS))
+ token->type = OP_OPEN_SUBEXP;
+ break;
+ case ')':
+ if (!(syntax & RE_NO_BK_PARENS))
+ token->type = OP_CLOSE_SUBEXP;
+ break;
+ case '+':
+ if (!(syntax & RE_LIMITED_OPS) && (syntax & RE_BK_PLUS_QM))
+ token->type = OP_DUP_PLUS;
+ break;
+ case '?':
+ if (!(syntax & RE_LIMITED_OPS) && (syntax & RE_BK_PLUS_QM))
+ token->type = OP_DUP_QUESTION;
+ break;
+ case '{':
+ if ((syntax & RE_INTERVALS) && (!(syntax & RE_NO_BK_BRACES)))
+ token->type = OP_OPEN_DUP_NUM;
+ break;
+ case '}':
+ if ((syntax & RE_INTERVALS) && (!(syntax & RE_NO_BK_BRACES)))
+ token->type = OP_CLOSE_DUP_NUM;
+ break;
+ default:
+ break;
+ }
+ return 2;
+ }
+
+ token->type = CHARACTER;
+#ifdef RE_ENABLE_I18N
+ if (input->mb_cur_max > 1)
+ {
+ wint_t wc = re_string_wchar_at (input, re_string_cur_idx (input));
+ token->word_char = IS_WIDE_WORD_CHAR (wc) != 0;
+ }
+ else
+#endif
+ token->word_char = IS_WORD_CHAR (token->opr.c);
+
+ switch (c)
+ {
+ case '\n':
+ if (syntax & RE_NEWLINE_ALT)
+ token->type = OP_ALT;
+ break;
+ case '|':
+ if (!(syntax & RE_LIMITED_OPS) && (syntax & RE_NO_BK_VBAR))
+ token->type = OP_ALT;
+ break;
+ case '*':
+ token->type = OP_DUP_ASTERISK;
+ break;
+ case '+':
+ if (!(syntax & RE_LIMITED_OPS) && !(syntax & RE_BK_PLUS_QM))
+ token->type = OP_DUP_PLUS;
+ break;
+ case '?':
+ if (!(syntax & RE_LIMITED_OPS) && !(syntax & RE_BK_PLUS_QM))
+ token->type = OP_DUP_QUESTION;
+ break;
+ case '{':
+ if ((syntax & RE_INTERVALS) && (syntax & RE_NO_BK_BRACES))
+ token->type = OP_OPEN_DUP_NUM;
+ break;
+ case '}':
+ if ((syntax & RE_INTERVALS) && (syntax & RE_NO_BK_BRACES))
+ token->type = OP_CLOSE_DUP_NUM;
+ break;
+ case '(':
+ if (syntax & RE_NO_BK_PARENS)
+ token->type = OP_OPEN_SUBEXP;
+ break;
+ case ')':
+ if (syntax & RE_NO_BK_PARENS)
+ token->type = OP_CLOSE_SUBEXP;
+ break;
+ case '[':
+ token->type = OP_OPEN_BRACKET;
+ break;
+ case '.':
+ token->type = OP_PERIOD;
+ break;
+ case '^':
+ if (!(syntax & (RE_CONTEXT_INDEP_ANCHORS | RE_CARET_ANCHORS_HERE))
+ && re_string_cur_idx (input) != 0)
+ {
+ char prev = re_string_peek_byte (input, -1);
+ if (!(syntax & RE_NEWLINE_ALT) || prev != '\n')
+ break;
+ }
+ token->type = ANCHOR;
+ token->opr.ctx_type = LINE_FIRST;
+ break;
+ case '$':
+ if (!(syntax & RE_CONTEXT_INDEP_ANCHORS)
+ && re_string_cur_idx (input) + 1 != re_string_length (input))
+ {
+ re_token_t next;
+ re_string_skip_bytes (input, 1);
+ peek_token (&next, input, syntax);
+ re_string_skip_bytes (input, -1);
+ if (next.type != OP_ALT && next.type != OP_CLOSE_SUBEXP)
+ break;
+ }
+ token->type = ANCHOR;
+ token->opr.ctx_type = LINE_LAST;
+ break;
+ default:
+ break;
+ }
+ return 1;
+}
+
+/* Peek a token from INPUT, and return the length of the token.
+ We must not use this function out of bracket expressions. */
+
+static int
+peek_token_bracket (re_token_t *token, re_string_t *input, reg_syntax_t syntax)
+{
+ unsigned char c;
+ if (re_string_eoi (input))
+ {
+ token->type = END_OF_RE;
+ return 0;
+ }
+ c = re_string_peek_byte (input, 0);
+ token->opr.c = c;
+
+#ifdef RE_ENABLE_I18N
+ if (input->mb_cur_max > 1
+ && !re_string_first_byte (input, re_string_cur_idx (input)))
+ {
+ token->type = CHARACTER;
+ return 1;
+ }
+#endif /* RE_ENABLE_I18N */
+
+ if (c == '\\' && (syntax & RE_BACKSLASH_ESCAPE_IN_LISTS)
+ && re_string_cur_idx (input) + 1 < re_string_length (input))
+ {
+ /* In this case, '\' escape a character. */
+ unsigned char c2;
+ re_string_skip_bytes (input, 1);
+ c2 = re_string_peek_byte (input, 0);
+ token->opr.c = c2;
+ token->type = CHARACTER;
+ return 1;
+ }
+ if (c == '[') /* '[' is a special char in a bracket exps. */
+ {
+ unsigned char c2;
+ int token_len;
+ if (re_string_cur_idx (input) + 1 < re_string_length (input))
+ c2 = re_string_peek_byte (input, 1);
+ else
+ c2 = 0;
+ token->opr.c = c2;
+ token_len = 2;
+ switch (c2)
+ {
+ case '.':
+ token->type = OP_OPEN_COLL_ELEM;
+ break;
+
+ case '=':
+ token->type = OP_OPEN_EQUIV_CLASS;
+ break;
+
+ case ':':
+ if (syntax & RE_CHAR_CLASSES)
+ {
+ token->type = OP_OPEN_CHAR_CLASS;
+ break;
+ }
+ FALLTHROUGH;
+ default:
+ token->type = CHARACTER;
+ token->opr.c = c;
+ token_len = 1;
+ break;
+ }
+ return token_len;
+ }
+ switch (c)
+ {
+ case '-':
+ token->type = OP_CHARSET_RANGE;
+ break;
+ case ']':
+ token->type = OP_CLOSE_BRACKET;
+ break;
+ case '^':
+ token->type = OP_NON_MATCH_LIST;
+ break;
+ default:
+ token->type = CHARACTER;
+ }
+ return 1;
+}
+
+/* Functions for parser. */
+
+/* Entry point of the parser.
+ Parse the regular expression REGEXP and return the structure tree.
+ If an error occurs, ERR is set by error code, and return NULL.
+ This function build the following tree, from regular expression <reg_exp>:
+ CAT
+ / \
+ / \
+ <reg_exp> EOR
+
+ CAT means concatenation.
+ EOR means end of regular expression. */
+
+static bin_tree_t *
+parse (re_string_t *regexp, regex_t *preg, reg_syntax_t syntax,
+ reg_errcode_t *err)
+{
+ re_dfa_t *dfa = preg->buffer;
+ bin_tree_t *tree, *eor, *root;
+ re_token_t current_token;
+ dfa->syntax = syntax;
+ fetch_token (&current_token, regexp, syntax | RE_CARET_ANCHORS_HERE);
+ tree = parse_reg_exp (regexp, preg, &current_token, syntax, 0, err);
+ if (__glibc_unlikely (*err != REG_NOERROR && tree == NULL))
+ return NULL;
+ eor = create_tree (dfa, NULL, NULL, END_OF_RE);
+ if (tree != NULL)
+ root = create_tree (dfa, tree, eor, CONCAT);
+ else
+ root = eor;
+ if (__glibc_unlikely (eor == NULL || root == NULL))
+ {
+ *err = REG_ESPACE;
+ return NULL;
+ }
+ return root;
+}
+
+/* This function build the following tree, from regular expression
+ <branch1>|<branch2>:
+ ALT
+ / \
+ / \
+ <branch1> <branch2>
+
+ ALT means alternative, which represents the operator '|'. */
+
+static bin_tree_t *
+parse_reg_exp (re_string_t *regexp, regex_t *preg, re_token_t *token,
+ reg_syntax_t syntax, Idx nest, reg_errcode_t *err)
+{
+ re_dfa_t *dfa = preg->buffer;
+ bin_tree_t *tree, *branch = NULL;
+ bitset_word_t initial_bkref_map = dfa->completed_bkref_map;
+ tree = parse_branch (regexp, preg, token, syntax, nest, err);
+ if (__glibc_unlikely (*err != REG_NOERROR && tree == NULL))
+ return NULL;
+
+ while (token->type == OP_ALT)
+ {
+ fetch_token (token, regexp, syntax | RE_CARET_ANCHORS_HERE);
+ if (token->type != OP_ALT && token->type != END_OF_RE
+ && (nest == 0 || token->type != OP_CLOSE_SUBEXP))
+ {
+ bitset_word_t accumulated_bkref_map = dfa->completed_bkref_map;
+ dfa->completed_bkref_map = initial_bkref_map;
+ branch = parse_branch (regexp, preg, token, syntax, nest, err);
+ if (__glibc_unlikely (*err != REG_NOERROR && branch == NULL))
+ {
+ if (tree != NULL)
+ postorder (tree, free_tree, NULL);
+ return NULL;
+ }
+ dfa->completed_bkref_map |= accumulated_bkref_map;
+ }
+ else
+ branch = NULL;
+ tree = create_tree (dfa, tree, branch, OP_ALT);
+ if (__glibc_unlikely (tree == NULL))
+ {
+ *err = REG_ESPACE;
+ return NULL;
+ }
+ }
+ return tree;
+}
+
+/* This function build the following tree, from regular expression
+ <exp1><exp2>:
+ CAT
+ / \
+ / \
+ <exp1> <exp2>
+
+ CAT means concatenation. */
+
+static bin_tree_t *
+parse_branch (re_string_t *regexp, regex_t *preg, re_token_t *token,
+ reg_syntax_t syntax, Idx nest, reg_errcode_t *err)
+{
+ bin_tree_t *tree, *expr;
+ re_dfa_t *dfa = preg->buffer;
+ tree = parse_expression (regexp, preg, token, syntax, nest, err);
+ if (__glibc_unlikely (*err != REG_NOERROR && tree == NULL))
+ return NULL;
+
+ while (token->type != OP_ALT && token->type != END_OF_RE
+ && (nest == 0 || token->type != OP_CLOSE_SUBEXP))
+ {
+ expr = parse_expression (regexp, preg, token, syntax, nest, err);
+ if (__glibc_unlikely (*err != REG_NOERROR && expr == NULL))
+ {
+ if (tree != NULL)
+ postorder (tree, free_tree, NULL);
+ return NULL;
+ }
+ if (tree != NULL && expr != NULL)
+ {
+ bin_tree_t *newtree = create_tree (dfa, tree, expr, CONCAT);
+ if (newtree == NULL)
+ {
+ postorder (expr, free_tree, NULL);
+ postorder (tree, free_tree, NULL);
+ *err = REG_ESPACE;
+ return NULL;
+ }
+ tree = newtree;
+ }
+ else if (tree == NULL)
+ tree = expr;
+ /* Otherwise expr == NULL, we don't need to create new tree. */
+ }
+ return tree;
+}
+
+/* This function build the following tree, from regular expression a*:
+ *
+ |
+ a
+*/
+
+static bin_tree_t *
+parse_expression (re_string_t *regexp, regex_t *preg, re_token_t *token,
+ reg_syntax_t syntax, Idx nest, reg_errcode_t *err)
+{
+ re_dfa_t *dfa = preg->buffer;
+ bin_tree_t *tree;
+ switch (token->type)
+ {
+ case CHARACTER:
+ tree = create_token_tree (dfa, NULL, NULL, token);
+ if (__glibc_unlikely (tree == NULL))
+ {
+ *err = REG_ESPACE;
+ return NULL;
+ }
+#ifdef RE_ENABLE_I18N
+ if (dfa->mb_cur_max > 1)
+ {
+ while (!re_string_eoi (regexp)
+ && !re_string_first_byte (regexp, re_string_cur_idx (regexp)))
+ {
+ bin_tree_t *mbc_remain;
+ fetch_token (token, regexp, syntax);
+ mbc_remain = create_token_tree (dfa, NULL, NULL, token);
+ tree = create_tree (dfa, tree, mbc_remain, CONCAT);
+ if (__glibc_unlikely (mbc_remain == NULL || tree == NULL))
+ {
+ *err = REG_ESPACE;
+ return NULL;
+ }
+ }
+ }
+#endif
+ break;
+
+ case OP_OPEN_SUBEXP:
+ tree = parse_sub_exp (regexp, preg, token, syntax, nest + 1, err);
+ if (__glibc_unlikely (*err != REG_NOERROR && tree == NULL))
+ return NULL;
+ break;
+
+ case OP_OPEN_BRACKET:
+ tree = parse_bracket_exp (regexp, dfa, token, syntax, err);
+ if (__glibc_unlikely (*err != REG_NOERROR && tree == NULL))
+ return NULL;
+ break;
+
+ case OP_BACK_REF:
+ if (!__glibc_likely (dfa->completed_bkref_map & (1 << token->opr.idx)))
+ {
+ *err = REG_ESUBREG;
+ return NULL;
+ }
+ dfa->used_bkref_map |= 1 << token->opr.idx;
+ tree = create_token_tree (dfa, NULL, NULL, token);
+ if (__glibc_unlikely (tree == NULL))
+ {
+ *err = REG_ESPACE;
+ return NULL;
+ }
+ ++dfa->nbackref;
+ dfa->has_mb_node = 1;
+ break;
+
+ case OP_OPEN_DUP_NUM:
+ if (syntax & RE_CONTEXT_INVALID_DUP)
+ {
+ *err = REG_BADRPT;
+ return NULL;
+ }
+ FALLTHROUGH;
+ case OP_DUP_ASTERISK:
+ case OP_DUP_PLUS:
+ case OP_DUP_QUESTION:
+ if (syntax & RE_CONTEXT_INVALID_OPS)
+ {
+ *err = REG_BADRPT;
+ return NULL;
+ }
+ else if (syntax & RE_CONTEXT_INDEP_OPS)
+ {
+ fetch_token (token, regexp, syntax);
+ return parse_expression (regexp, preg, token, syntax, nest, err);
+ }
+ FALLTHROUGH;
+ case OP_CLOSE_SUBEXP:
+ if ((token->type == OP_CLOSE_SUBEXP)
+ && !(syntax & RE_UNMATCHED_RIGHT_PAREN_ORD))
+ {
+ *err = REG_ERPAREN;
+ return NULL;
+ }
+ FALLTHROUGH;
+ case OP_CLOSE_DUP_NUM:
+ /* We treat it as a normal character. */
+
+ /* Then we can these characters as normal characters. */
+ token->type = CHARACTER;
+ /* mb_partial and word_char bits should be initialized already
+ by peek_token. */
+ tree = create_token_tree (dfa, NULL, NULL, token);
+ if (__glibc_unlikely (tree == NULL))
+ {
+ *err = REG_ESPACE;
+ return NULL;
+ }
+ break;
+
+ case ANCHOR:
+ if ((token->opr.ctx_type
+ & (WORD_DELIM | NOT_WORD_DELIM | WORD_FIRST | WORD_LAST))
+ && dfa->word_ops_used == 0)
+ init_word_char (dfa);
+ if (token->opr.ctx_type == WORD_DELIM
+ || token->opr.ctx_type == NOT_WORD_DELIM)
+ {
+ bin_tree_t *tree_first, *tree_last;
+ if (token->opr.ctx_type == WORD_DELIM)
+ {
+ token->opr.ctx_type = WORD_FIRST;
+ tree_first = create_token_tree (dfa, NULL, NULL, token);
+ token->opr.ctx_type = WORD_LAST;
+ }
+ else
+ {
+ token->opr.ctx_type = INSIDE_WORD;
+ tree_first = create_token_tree (dfa, NULL, NULL, token);
+ token->opr.ctx_type = INSIDE_NOTWORD;
+ }
+ tree_last = create_token_tree (dfa, NULL, NULL, token);
+ tree = create_tree (dfa, tree_first, tree_last, OP_ALT);
+ if (__glibc_unlikely (tree_first == NULL || tree_last == NULL
+ || tree == NULL))
+ {
+ *err = REG_ESPACE;
+ return NULL;
+ }
+ }
+ else
+ {
+ tree = create_token_tree (dfa, NULL, NULL, token);
+ if (__glibc_unlikely (tree == NULL))
+ {
+ *err = REG_ESPACE;
+ return NULL;
+ }
+ }
+ /* We must return here, since ANCHORs can't be followed
+ by repetition operators.
+ eg. RE"^*" is invalid or "<ANCHOR(^)><CHAR(*)>",
+ it must not be "<ANCHOR(^)><REPEAT(*)>". */
+ fetch_token (token, regexp, syntax);
+ return tree;
+
+ case OP_PERIOD:
+ tree = create_token_tree (dfa, NULL, NULL, token);
+ if (__glibc_unlikely (tree == NULL))
+ {
+ *err = REG_ESPACE;
+ return NULL;
+ }
+ if (dfa->mb_cur_max > 1)
+ dfa->has_mb_node = 1;
+ break;
+
+ case OP_WORD:
+ case OP_NOTWORD:
+ tree = build_charclass_op (dfa, regexp->trans,
+ "alnum",
+ "_",
+ token->type == OP_NOTWORD, err);
+ if (__glibc_unlikely (*err != REG_NOERROR && tree == NULL))
+ return NULL;
+ break;
+
+ case OP_SPACE:
+ case OP_NOTSPACE:
+ tree = build_charclass_op (dfa, regexp->trans,
+ "space",
+ "",
+ token->type == OP_NOTSPACE, err);
+ if (__glibc_unlikely (*err != REG_NOERROR && tree == NULL))
+ return NULL;
+ break;
+
+ case OP_ALT:
+ case END_OF_RE:
+ return NULL;
+
+ case BACK_SLASH:
+ *err = REG_EESCAPE;
+ return NULL;
+
+ default:
+ /* Must not happen? */
+#ifdef DEBUG
+ assert (0);
+#endif
+ return NULL;
+ }
+ fetch_token (token, regexp, syntax);
+
+ while (token->type == OP_DUP_ASTERISK || token->type == OP_DUP_PLUS
+ || token->type == OP_DUP_QUESTION || token->type == OP_OPEN_DUP_NUM)
+ {
+ bin_tree_t *dup_tree = parse_dup_op (tree, regexp, dfa, token,
+ syntax, err);
+ if (__glibc_unlikely (*err != REG_NOERROR && dup_tree == NULL))
+ {
+ if (tree != NULL)
+ postorder (tree, free_tree, NULL);
+ return NULL;
+ }
+ tree = dup_tree;
+ /* In BRE consecutive duplications are not allowed. */
+ if ((syntax & RE_CONTEXT_INVALID_DUP)
+ && (token->type == OP_DUP_ASTERISK
+ || token->type == OP_OPEN_DUP_NUM))
+ {
+ if (tree != NULL)
+ postorder (tree, free_tree, NULL);
+ *err = REG_BADRPT;
+ return NULL;
+ }
+ }
+
+ return tree;
+}
+
+/* This function build the following tree, from regular expression
+ (<reg_exp>):
+ SUBEXP
+ |
+ <reg_exp>
+*/
+
+static bin_tree_t *
+parse_sub_exp (re_string_t *regexp, regex_t *preg, re_token_t *token,
+ reg_syntax_t syntax, Idx nest, reg_errcode_t *err)
+{
+ re_dfa_t *dfa = preg->buffer;
+ bin_tree_t *tree;
+ size_t cur_nsub;
+ cur_nsub = preg->re_nsub++;
+
+ fetch_token (token, regexp, syntax | RE_CARET_ANCHORS_HERE);
+
+ /* The subexpression may be a null string. */
+ if (token->type == OP_CLOSE_SUBEXP)
+ tree = NULL;
+ else
+ {
+ tree = parse_reg_exp (regexp, preg, token, syntax, nest, err);
+ if (__glibc_unlikely (*err == REG_NOERROR
+ && token->type != OP_CLOSE_SUBEXP))
+ {
+ if (tree != NULL)
+ postorder (tree, free_tree, NULL);
+ *err = REG_EPAREN;
+ }
+ if (__glibc_unlikely (*err != REG_NOERROR))
+ return NULL;
+ }
+
+ if (cur_nsub <= '9' - '1')
+ dfa->completed_bkref_map |= 1 << cur_nsub;
+
+ tree = create_tree (dfa, tree, NULL, SUBEXP);
+ if (__glibc_unlikely (tree == NULL))
+ {
+ *err = REG_ESPACE;
+ return NULL;
+ }
+ tree->token.opr.idx = cur_nsub;
+ return tree;
+}
+
+/* This function parse repetition operators like "*", "+", "{1,3}" etc. */
+
+static bin_tree_t *
+parse_dup_op (bin_tree_t *elem, re_string_t *regexp, re_dfa_t *dfa,
+ re_token_t *token, reg_syntax_t syntax, reg_errcode_t *err)
+{
+ bin_tree_t *tree = NULL, *old_tree = NULL;
+ Idx i, start, end, start_idx = re_string_cur_idx (regexp);
+ re_token_t start_token = *token;
+
+ if (token->type == OP_OPEN_DUP_NUM)
+ {
+ end = 0;
+ start = fetch_number (regexp, token, syntax);
+ if (start == -1)
+ {
+ if (token->type == CHARACTER && token->opr.c == ',')
+ start = 0; /* We treat "{,m}" as "{0,m}". */
+ else
+ {
+ *err = REG_BADBR; /* <re>{} is invalid. */
+ return NULL;
+ }
+ }
+ if (__glibc_likely (start != -2))
+ {
+ /* We treat "{n}" as "{n,n}". */
+ end = ((token->type == OP_CLOSE_DUP_NUM) ? start
+ : ((token->type == CHARACTER && token->opr.c == ',')
+ ? fetch_number (regexp, token, syntax) : -2));
+ }
+ if (__glibc_unlikely (start == -2 || end == -2))
+ {
+ /* Invalid sequence. */
+ if (__glibc_unlikely (!(syntax & RE_INVALID_INTERVAL_ORD)))
+ {
+ if (token->type == END_OF_RE)
+ *err = REG_EBRACE;
+ else
+ *err = REG_BADBR;
+
+ return NULL;
+ }
+
+ /* If the syntax bit is set, rollback. */
+ re_string_set_index (regexp, start_idx);
+ *token = start_token;
+ token->type = CHARACTER;
+ /* mb_partial and word_char bits should be already initialized by
+ peek_token. */
+ return elem;
+ }
+
+ if (__glibc_unlikely ((end != -1 && start > end)
+ || token->type != OP_CLOSE_DUP_NUM))
+ {
+ /* First number greater than second. */
+ *err = REG_BADBR;
+ return NULL;
+ }
+
+ if (__glibc_unlikely (RE_DUP_MAX < (end == -1 ? start : end)))
+ {
+ *err = REG_ESIZE;
+ return NULL;
+ }
+ }
+ else
+ {
+ start = (token->type == OP_DUP_PLUS) ? 1 : 0;
+ end = (token->type == OP_DUP_QUESTION) ? 1 : -1;
+ }
+
+ fetch_token (token, regexp, syntax);
+
+ if (__glibc_unlikely (elem == NULL))
+ return NULL;
+ if (__glibc_unlikely (start == 0 && end == 0))
+ {
+ postorder (elem, free_tree, NULL);
+ return NULL;
+ }
+
+ /* Extract "<re>{n,m}" to "<re><re>...<re><re>{0,<m-n>}". */
+ if (__glibc_unlikely (start > 0))
+ {
+ tree = elem;
+ for (i = 2; i <= start; ++i)
+ {
+ elem = duplicate_tree (elem, dfa);
+ tree = create_tree (dfa, tree, elem, CONCAT);
+ if (__glibc_unlikely (elem == NULL || tree == NULL))
+ goto parse_dup_op_espace;
+ }
+
+ if (start == end)
+ return tree;
+
+ /* Duplicate ELEM before it is marked optional. */
+ elem = duplicate_tree (elem, dfa);
+ if (__glibc_unlikely (elem == NULL))
+ goto parse_dup_op_espace;
+ old_tree = tree;
+ }
+ else
+ old_tree = NULL;
+
+ if (elem->token.type == SUBEXP)
+ {
+ uintptr_t subidx = elem->token.opr.idx;
+ postorder (elem, mark_opt_subexp, (void *) subidx);
+ }
+
+ tree = create_tree (dfa, elem, NULL,
+ (end == -1 ? OP_DUP_ASTERISK : OP_ALT));
+ if (__glibc_unlikely (tree == NULL))
+ goto parse_dup_op_espace;
+
+ /* This loop is actually executed only when end != -1,
+ to rewrite <re>{0,n} as (<re>(<re>...<re>?)?)?... We have
+ already created the start+1-th copy. */
+ if (TYPE_SIGNED (Idx) || end != -1)
+ for (i = start + 2; i <= end; ++i)
+ {
+ elem = duplicate_tree (elem, dfa);
+ tree = create_tree (dfa, tree, elem, CONCAT);
+ if (__glibc_unlikely (elem == NULL || tree == NULL))
+ goto parse_dup_op_espace;
+
+ tree = create_tree (dfa, tree, NULL, OP_ALT);
+ if (__glibc_unlikely (tree == NULL))
+ goto parse_dup_op_espace;
+ }
+
+ if (old_tree)
+ tree = create_tree (dfa, old_tree, tree, CONCAT);
+
+ return tree;
+
+ parse_dup_op_espace:
+ *err = REG_ESPACE;
+ return NULL;
+}
+
+/* Size of the names for collating symbol/equivalence_class/character_class.
+ I'm not sure, but maybe enough. */
+#define BRACKET_NAME_BUF_SIZE 32
+
+#ifndef _LIBC
+
+# ifdef RE_ENABLE_I18N
+/* Convert the byte B to the corresponding wide character. In a
+ unibyte locale, treat B as itself. In a multibyte locale, return
+ WEOF if B is an encoding error. */
+static wint_t
+parse_byte (unsigned char b, re_charset_t *mbcset)
+{
+ return mbcset == NULL ? b : __btowc (b);
+}
+# endif
+
+ /* Local function for parse_bracket_exp only used in case of NOT _LIBC.
+ Build the range expression which starts from START_ELEM, and ends
+ at END_ELEM. The result are written to MBCSET and SBCSET.
+ RANGE_ALLOC is the allocated size of mbcset->range_starts, and
+ mbcset->range_ends, is a pointer argument since we may
+ update it. */
+
+static reg_errcode_t
+# ifdef RE_ENABLE_I18N
+build_range_exp (const reg_syntax_t syntax,
+ bitset_t sbcset,
+ re_charset_t *mbcset,
+ Idx *range_alloc,
+ const bracket_elem_t *start_elem,
+ const bracket_elem_t *end_elem)
+# else /* not RE_ENABLE_I18N */
+build_range_exp (const reg_syntax_t syntax,
+ bitset_t sbcset,
+ const bracket_elem_t *start_elem,
+ const bracket_elem_t *end_elem)
+# endif /* not RE_ENABLE_I18N */
+{
+ unsigned int start_ch, end_ch;
+ /* Equivalence Classes and Character Classes can't be a range start/end. */
+ if (__glibc_unlikely (start_elem->type == EQUIV_CLASS
+ || start_elem->type == CHAR_CLASS
+ || end_elem->type == EQUIV_CLASS
+ || end_elem->type == CHAR_CLASS))
+ return REG_ERANGE;
+
+ /* We can handle no multi character collating elements without libc
+ support. */
+ if (__glibc_unlikely ((start_elem->type == COLL_SYM
+ && strlen ((char *) start_elem->opr.name) > 1)
+ || (end_elem->type == COLL_SYM
+ && strlen ((char *) end_elem->opr.name) > 1)))
+ return REG_ECOLLATE;
+
+# ifdef RE_ENABLE_I18N
+ {
+ wchar_t wc;
+ wint_t start_wc;
+ wint_t end_wc;
+
+ start_ch = ((start_elem->type == SB_CHAR) ? start_elem->opr.ch
+ : ((start_elem->type == COLL_SYM) ? start_elem->opr.name[0]
+ : 0));
+ end_ch = ((end_elem->type == SB_CHAR) ? end_elem->opr.ch
+ : ((end_elem->type == COLL_SYM) ? end_elem->opr.name[0]
+ : 0));
+ start_wc = ((start_elem->type == SB_CHAR || start_elem->type == COLL_SYM)
+ ? parse_byte (start_ch, mbcset) : start_elem->opr.wch);
+ end_wc = ((end_elem->type == SB_CHAR || end_elem->type == COLL_SYM)
+ ? parse_byte (end_ch, mbcset) : end_elem->opr.wch);
+ if (start_wc == WEOF || end_wc == WEOF)
+ return REG_ECOLLATE;
+ else if (__glibc_unlikely ((syntax & RE_NO_EMPTY_RANGES)
+ && start_wc > end_wc))
+ return REG_ERANGE;
+
+ /* Got valid collation sequence values, add them as a new entry.
+ However, for !_LIBC we have no collation elements: if the
+ character set is single byte, the single byte character set
+ that we build below suffices. parse_bracket_exp passes
+ no MBCSET if dfa->mb_cur_max == 1. */
+ if (mbcset)
+ {
+ /* Check the space of the arrays. */
+ if (__glibc_unlikely (*range_alloc == mbcset->nranges))
+ {
+ /* There is not enough space, need realloc. */
+ wchar_t *new_array_start, *new_array_end;
+ Idx new_nranges;
+
+ /* +1 in case of mbcset->nranges is 0. */
+ new_nranges = 2 * mbcset->nranges + 1;
+ /* Use realloc since mbcset->range_starts and mbcset->range_ends
+ are NULL if *range_alloc == 0. */
+ new_array_start = re_realloc (mbcset->range_starts, wchar_t,
+ new_nranges);
+ new_array_end = re_realloc (mbcset->range_ends, wchar_t,
+ new_nranges);
+
+ if (__glibc_unlikely (new_array_start == NULL
+ || new_array_end == NULL))
+ {
+ re_free (new_array_start);
+ re_free (new_array_end);
+ return REG_ESPACE;
+ }
+
+ mbcset->range_starts = new_array_start;
+ mbcset->range_ends = new_array_end;
+ *range_alloc = new_nranges;
+ }
+
+ mbcset->range_starts[mbcset->nranges] = start_wc;
+ mbcset->range_ends[mbcset->nranges++] = end_wc;
+ }
+
+ /* Build the table for single byte characters. */
+ for (wc = 0; wc < SBC_MAX; ++wc)
+ {
+ if (start_wc <= wc && wc <= end_wc)
+ bitset_set (sbcset, wc);
+ }
+ }
+# else /* not RE_ENABLE_I18N */
+ {
+ unsigned int ch;
+ start_ch = ((start_elem->type == SB_CHAR ) ? start_elem->opr.ch
+ : ((start_elem->type == COLL_SYM) ? start_elem->opr.name[0]
+ : 0));
+ end_ch = ((end_elem->type == SB_CHAR ) ? end_elem->opr.ch
+ : ((end_elem->type == COLL_SYM) ? end_elem->opr.name[0]
+ : 0));
+ if (start_ch > end_ch)
+ return REG_ERANGE;
+ /* Build the table for single byte characters. */
+ for (ch = 0; ch < SBC_MAX; ++ch)
+ if (start_ch <= ch && ch <= end_ch)
+ bitset_set (sbcset, ch);
+ }
+# endif /* not RE_ENABLE_I18N */
+ return REG_NOERROR;
+}
+#endif /* not _LIBC */
+
+#ifndef _LIBC
+/* Helper function for parse_bracket_exp only used in case of NOT _LIBC..
+ Build the collating element which is represented by NAME.
+ The result are written to MBCSET and SBCSET.
+ COLL_SYM_ALLOC is the allocated size of mbcset->coll_sym, is a
+ pointer argument since we may update it. */
+
+static reg_errcode_t
+# ifdef RE_ENABLE_I18N
+build_collating_symbol (bitset_t sbcset, re_charset_t *mbcset,
+ Idx *coll_sym_alloc, const unsigned char *name)
+# else /* not RE_ENABLE_I18N */
+build_collating_symbol (bitset_t sbcset, const unsigned char *name)
+# endif /* not RE_ENABLE_I18N */
+{
+ size_t name_len = strlen ((const char *) name);
+ if (__glibc_unlikely (name_len != 1))
+ return REG_ECOLLATE;
+ else
+ {
+ bitset_set (sbcset, name[0]);
+ return REG_NOERROR;
+ }
+}
+#endif /* not _LIBC */
+
+/* This function parse bracket expression like "[abc]", "[a-c]",
+ "[[.a-a.]]" etc. */
+
+static bin_tree_t *
+parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token,
+ reg_syntax_t syntax, reg_errcode_t *err)
+{
+#ifdef _LIBC
+ const unsigned char *collseqmb;
+ const char *collseqwc;
+ uint32_t nrules;
+ int32_t table_size;
+ const int32_t *symb_table;
+ const unsigned char *extra;
+
+ /* Local function for parse_bracket_exp used in _LIBC environment.
+ Seek the collating symbol entry corresponding to NAME.
+ Return the index of the symbol in the SYMB_TABLE,
+ or -1 if not found. */
+
+ auto inline int32_t
+ __attribute__ ((always_inline))
+ seek_collating_symbol_entry (const unsigned char *name, size_t name_len)
+ {
+ int32_t elem;
+
+ for (elem = 0; elem < table_size; elem++)
+ if (symb_table[2 * elem] != 0)
+ {
+ int32_t idx = symb_table[2 * elem + 1];
+ /* Skip the name of collating element name. */
+ idx += 1 + extra[idx];
+ if (/* Compare the length of the name. */
+ name_len == extra[idx]
+ /* Compare the name. */
+ && memcmp (name, &extra[idx + 1], name_len) == 0)
+ /* Yep, this is the entry. */
+ return elem;
+ }
+ return -1;
+ }
+
+ /* Local function for parse_bracket_exp used in _LIBC environment.
+ Look up the collation sequence value of BR_ELEM.
+ Return the value if succeeded, UINT_MAX otherwise. */
+
+ auto inline unsigned int
+ __attribute__ ((always_inline))
+ lookup_collation_sequence_value (bracket_elem_t *br_elem)
+ {
+ if (br_elem->type == SB_CHAR)
+ {
+ /*
+ if (MB_CUR_MAX == 1)
+ */
+ if (nrules == 0)
+ return collseqmb[br_elem->opr.ch];
+ else
+ {
+ wint_t wc = __btowc (br_elem->opr.ch);
+ return __collseq_table_lookup (collseqwc, wc);
+ }
+ }
+ else if (br_elem->type == MB_CHAR)
+ {
+ if (nrules != 0)
+ return __collseq_table_lookup (collseqwc, br_elem->opr.wch);
+ }
+ else if (br_elem->type == COLL_SYM)
+ {
+ size_t sym_name_len = strlen ((char *) br_elem->opr.name);
+ if (nrules != 0)
+ {
+ int32_t elem, idx;
+ elem = seek_collating_symbol_entry (br_elem->opr.name,
+ sym_name_len);
+ if (elem != -1)
+ {
+ /* We found the entry. */
+ idx = symb_table[2 * elem + 1];
+ /* Skip the name of collating element name. */
+ idx += 1 + extra[idx];
+ /* Skip the byte sequence of the collating element. */
+ idx += 1 + extra[idx];
+ /* Adjust for the alignment. */
+ idx = (idx + 3) & ~3;
+ /* Skip the multibyte collation sequence value. */
+ idx += sizeof (unsigned int);
+ /* Skip the wide char sequence of the collating element. */
+ idx += sizeof (unsigned int) *
+ (1 + *(unsigned int *) (extra + idx));
+ /* Return the collation sequence value. */
+ return *(unsigned int *) (extra + idx);
+ }
+ else if (sym_name_len == 1)
+ {
+ /* No valid character. Match it as a single byte
+ character. */
+ return collseqmb[br_elem->opr.name[0]];
+ }
+ }
+ else if (sym_name_len == 1)
+ return collseqmb[br_elem->opr.name[0]];
+ }
+ return UINT_MAX;
+ }
+
+ /* Local function for parse_bracket_exp used in _LIBC environment.
+ Build the range expression which starts from START_ELEM, and ends
+ at END_ELEM. The result are written to MBCSET and SBCSET.
+ RANGE_ALLOC is the allocated size of mbcset->range_starts, and
+ mbcset->range_ends, is a pointer argument since we may
+ update it. */
+
+ auto inline reg_errcode_t
+ __attribute__ ((always_inline))
+ build_range_exp (bitset_t sbcset, re_charset_t *mbcset, int *range_alloc,
+ bracket_elem_t *start_elem, bracket_elem_t *end_elem)
+ {
+ unsigned int ch;
+ uint32_t start_collseq;
+ uint32_t end_collseq;
+
+ /* Equivalence Classes and Character Classes can't be a range
+ start/end. */
+ if (__glibc_unlikely (start_elem->type == EQUIV_CLASS
+ || start_elem->type == CHAR_CLASS
+ || end_elem->type == EQUIV_CLASS
+ || end_elem->type == CHAR_CLASS))
+ return REG_ERANGE;
+
+ /* FIXME: Implement rational ranges here, too. */
+ start_collseq = lookup_collation_sequence_value (start_elem);
+ end_collseq = lookup_collation_sequence_value (end_elem);
+ /* Check start/end collation sequence values. */
+ if (__glibc_unlikely (start_collseq == UINT_MAX
+ || end_collseq == UINT_MAX))
+ return REG_ECOLLATE;
+ if (__glibc_unlikely ((syntax & RE_NO_EMPTY_RANGES)
+ && start_collseq > end_collseq))
+ return REG_ERANGE;
+
+ /* Got valid collation sequence values, add them as a new entry.
+ However, if we have no collation elements, and the character set
+ is single byte, the single byte character set that we
+ build below suffices. */
+ if (nrules > 0 || dfa->mb_cur_max > 1)
+ {
+ /* Check the space of the arrays. */
+ if (__glibc_unlikely (*range_alloc == mbcset->nranges))
+ {
+ /* There is not enough space, need realloc. */
+ uint32_t *new_array_start;
+ uint32_t *new_array_end;
+ Idx new_nranges;
+
+ /* +1 in case of mbcset->nranges is 0. */
+ new_nranges = 2 * mbcset->nranges + 1;
+ new_array_start = re_realloc (mbcset->range_starts, uint32_t,
+ new_nranges);
+ new_array_end = re_realloc (mbcset->range_ends, uint32_t,
+ new_nranges);
+
+ if (__glibc_unlikely (new_array_start == NULL
+ || new_array_end == NULL))
+ return REG_ESPACE;
+
+ mbcset->range_starts = new_array_start;
+ mbcset->range_ends = new_array_end;
+ *range_alloc = new_nranges;
+ }
+
+ mbcset->range_starts[mbcset->nranges] = start_collseq;
+ mbcset->range_ends[mbcset->nranges++] = end_collseq;
+ }
+
+ /* Build the table for single byte characters. */
+ for (ch = 0; ch < SBC_MAX; ch++)
+ {
+ uint32_t ch_collseq;
+ /*
+ if (MB_CUR_MAX == 1)
+ */
+ if (nrules == 0)
+ ch_collseq = collseqmb[ch];
+ else
+ ch_collseq = __collseq_table_lookup (collseqwc, __btowc (ch));
+ if (start_collseq <= ch_collseq && ch_collseq <= end_collseq)
+ bitset_set (sbcset, ch);
+ }
+ return REG_NOERROR;
+ }
+
+ /* Local function for parse_bracket_exp used in _LIBC environment.
+ Build the collating element which is represented by NAME.
+ The result are written to MBCSET and SBCSET.
+ COLL_SYM_ALLOC is the allocated size of mbcset->coll_sym, is a
+ pointer argument since we may update it. */
+
+ auto inline reg_errcode_t
+ __attribute__ ((always_inline))
+ build_collating_symbol (bitset_t sbcset, re_charset_t *mbcset,
+ Idx *coll_sym_alloc, const unsigned char *name)
+ {
+ int32_t elem, idx;
+ size_t name_len = strlen ((const char *) name);
+ if (nrules != 0)
+ {
+ elem = seek_collating_symbol_entry (name, name_len);
+ if (elem != -1)
+ {
+ /* We found the entry. */
+ idx = symb_table[2 * elem + 1];
+ /* Skip the name of collating element name. */
+ idx += 1 + extra[idx];
+ }
+ else if (name_len == 1)
+ {
+ /* No valid character, treat it as a normal
+ character. */
+ bitset_set (sbcset, name[0]);
+ return REG_NOERROR;
+ }
+ else
+ return REG_ECOLLATE;
+
+ /* Got valid collation sequence, add it as a new entry. */
+ /* Check the space of the arrays. */
+ if (__glibc_unlikely (*coll_sym_alloc == mbcset->ncoll_syms))
+ {
+ /* Not enough, realloc it. */
+ /* +1 in case of mbcset->ncoll_syms is 0. */
+ Idx new_coll_sym_alloc = 2 * mbcset->ncoll_syms + 1;
+ /* Use realloc since mbcset->coll_syms is NULL
+ if *alloc == 0. */
+ int32_t *new_coll_syms = re_realloc (mbcset->coll_syms, int32_t,
+ new_coll_sym_alloc);
+ if (__glibc_unlikely (new_coll_syms == NULL))
+ return REG_ESPACE;
+ mbcset->coll_syms = new_coll_syms;
+ *coll_sym_alloc = new_coll_sym_alloc;
+ }
+ mbcset->coll_syms[mbcset->ncoll_syms++] = idx;
+ return REG_NOERROR;
+ }
+ else
+ {
+ if (__glibc_unlikely (name_len != 1))
+ return REG_ECOLLATE;
+ else
+ {
+ bitset_set (sbcset, name[0]);
+ return REG_NOERROR;
+ }
+ }
+ }
+#endif
+
+ re_token_t br_token;
+ re_bitset_ptr_t sbcset;
+#ifdef RE_ENABLE_I18N
+ re_charset_t *mbcset;
+ Idx coll_sym_alloc = 0, range_alloc = 0, mbchar_alloc = 0;
+ Idx equiv_class_alloc = 0, char_class_alloc = 0;
+#endif /* not RE_ENABLE_I18N */
+ bool non_match = false;
+ bin_tree_t *work_tree;
+ int token_len;
+ bool first_round = true;
+#ifdef _LIBC
+ collseqmb = (const unsigned char *)
+ _NL_CURRENT (LC_COLLATE, _NL_COLLATE_COLLSEQMB);
+ nrules = _NL_CURRENT_WORD (LC_COLLATE, _NL_COLLATE_NRULES);
+ if (nrules)
+ {
+ /*
+ if (MB_CUR_MAX > 1)
+ */
+ collseqwc = _NL_CURRENT (LC_COLLATE, _NL_COLLATE_COLLSEQWC);
+ table_size = _NL_CURRENT_WORD (LC_COLLATE, _NL_COLLATE_SYMB_HASH_SIZEMB);
+ symb_table = (const int32_t *) _NL_CURRENT (LC_COLLATE,
+ _NL_COLLATE_SYMB_TABLEMB);
+ extra = (const unsigned char *) _NL_CURRENT (LC_COLLATE,
+ _NL_COLLATE_SYMB_EXTRAMB);
+ }
+#endif
+ sbcset = (re_bitset_ptr_t) calloc (sizeof (bitset_t), 1);
+#ifdef RE_ENABLE_I18N
+ mbcset = (re_charset_t *) calloc (sizeof (re_charset_t), 1);
+#endif /* RE_ENABLE_I18N */
+#ifdef RE_ENABLE_I18N
+ if (__glibc_unlikely (sbcset == NULL || mbcset == NULL))
+#else
+ if (__glibc_unlikely (sbcset == NULL))
+#endif /* RE_ENABLE_I18N */
+ {
+ re_free (sbcset);
+#ifdef RE_ENABLE_I18N
+ re_free (mbcset);
+#endif
+ *err = REG_ESPACE;
+ return NULL;
+ }
+
+ token_len = peek_token_bracket (token, regexp, syntax);
+ if (__glibc_unlikely (token->type == END_OF_RE))
+ {
+ *err = REG_BADPAT;
+ goto parse_bracket_exp_free_return;
+ }
+ if (token->type == OP_NON_MATCH_LIST)
+ {
+#ifdef RE_ENABLE_I18N
+ mbcset->non_match = 1;
+#endif /* not RE_ENABLE_I18N */
+ non_match = true;
+ if (syntax & RE_HAT_LISTS_NOT_NEWLINE)
+ bitset_set (sbcset, '\n');
+ re_string_skip_bytes (regexp, token_len); /* Skip a token. */
+ token_len = peek_token_bracket (token, regexp, syntax);
+ if (__glibc_unlikely (token->type == END_OF_RE))
+ {
+ *err = REG_BADPAT;
+ goto parse_bracket_exp_free_return;
+ }
+ }
+
+ /* We treat the first ']' as a normal character. */
+ if (token->type == OP_CLOSE_BRACKET)
+ token->type = CHARACTER;
+
+ while (1)
+ {
+ bracket_elem_t start_elem, end_elem;
+ unsigned char start_name_buf[BRACKET_NAME_BUF_SIZE];
+ unsigned char end_name_buf[BRACKET_NAME_BUF_SIZE];
+ reg_errcode_t ret;
+ int token_len2 = 0;
+ bool is_range_exp = false;
+ re_token_t token2;
+
+ start_elem.opr.name = start_name_buf;
+ start_elem.type = COLL_SYM;
+ ret = parse_bracket_element (&start_elem, regexp, token, token_len, dfa,
+ syntax, first_round);
+ if (__glibc_unlikely (ret != REG_NOERROR))
+ {
+ *err = ret;
+ goto parse_bracket_exp_free_return;
+ }
+ first_round = false;
+
+ /* Get information about the next token. We need it in any case. */
+ token_len = peek_token_bracket (token, regexp, syntax);
+
+ /* Do not check for ranges if we know they are not allowed. */
+ if (start_elem.type != CHAR_CLASS && start_elem.type != EQUIV_CLASS)
+ {
+ if (__glibc_unlikely (token->type == END_OF_RE))
+ {
+ *err = REG_EBRACK;
+ goto parse_bracket_exp_free_return;
+ }
+ if (token->type == OP_CHARSET_RANGE)
+ {
+ re_string_skip_bytes (regexp, token_len); /* Skip '-'. */
+ token_len2 = peek_token_bracket (&token2, regexp, syntax);
+ if (__glibc_unlikely (token2.type == END_OF_RE))
+ {
+ *err = REG_EBRACK;
+ goto parse_bracket_exp_free_return;
+ }
+ if (token2.type == OP_CLOSE_BRACKET)
+ {
+ /* We treat the last '-' as a normal character. */
+ re_string_skip_bytes (regexp, -token_len);
+ token->type = CHARACTER;
+ }
+ else
+ is_range_exp = true;
+ }
+ }
+
+ if (is_range_exp == true)
+ {
+ end_elem.opr.name = end_name_buf;
+ end_elem.type = COLL_SYM;
+ ret = parse_bracket_element (&end_elem, regexp, &token2, token_len2,
+ dfa, syntax, true);
+ if (__glibc_unlikely (ret != REG_NOERROR))
+ {
+ *err = ret;
+ goto parse_bracket_exp_free_return;
+ }
+
+ token_len = peek_token_bracket (token, regexp, syntax);
+
+#ifdef _LIBC
+ *err = build_range_exp (sbcset, mbcset, &range_alloc,
+ &start_elem, &end_elem);
+#else
+# ifdef RE_ENABLE_I18N
+ *err = build_range_exp (syntax, sbcset,
+ dfa->mb_cur_max > 1 ? mbcset : NULL,
+ &range_alloc, &start_elem, &end_elem);
+# else
+ *err = build_range_exp (syntax, sbcset, &start_elem, &end_elem);
+# endif
+#endif /* RE_ENABLE_I18N */
+ if (__glibc_unlikely (*err != REG_NOERROR))
+ goto parse_bracket_exp_free_return;
+ }
+ else
+ {
+ switch (start_elem.type)
+ {
+ case SB_CHAR:
+ bitset_set (sbcset, start_elem.opr.ch);
+ break;
+#ifdef RE_ENABLE_I18N
+ case MB_CHAR:
+ /* Check whether the array has enough space. */
+ if (__glibc_unlikely (mbchar_alloc == mbcset->nmbchars))
+ {
+ wchar_t *new_mbchars;
+ /* Not enough, realloc it. */
+ /* +1 in case of mbcset->nmbchars is 0. */
+ mbchar_alloc = 2 * mbcset->nmbchars + 1;
+ /* Use realloc since array is NULL if *alloc == 0. */
+ new_mbchars = re_realloc (mbcset->mbchars, wchar_t,
+ mbchar_alloc);
+ if (__glibc_unlikely (new_mbchars == NULL))
+ goto parse_bracket_exp_espace;
+ mbcset->mbchars = new_mbchars;
+ }
+ mbcset->mbchars[mbcset->nmbchars++] = start_elem.opr.wch;
+ break;
+#endif /* RE_ENABLE_I18N */
+ case EQUIV_CLASS:
+ *err = build_equiv_class (sbcset,
+#ifdef RE_ENABLE_I18N
+ mbcset, &equiv_class_alloc,
+#endif /* RE_ENABLE_I18N */
+ start_elem.opr.name);
+ if (__glibc_unlikely (*err != REG_NOERROR))
+ goto parse_bracket_exp_free_return;
+ break;
+ case COLL_SYM:
+ *err = build_collating_symbol (sbcset,
+#ifdef RE_ENABLE_I18N
+ mbcset, &coll_sym_alloc,
+#endif /* RE_ENABLE_I18N */
+ start_elem.opr.name);
+ if (__glibc_unlikely (*err != REG_NOERROR))
+ goto parse_bracket_exp_free_return;
+ break;
+ case CHAR_CLASS:
+ *err = build_charclass (regexp->trans, sbcset,
+#ifdef RE_ENABLE_I18N
+ mbcset, &char_class_alloc,
+#endif /* RE_ENABLE_I18N */
+ (const char *) start_elem.opr.name,
+ syntax);
+ if (__glibc_unlikely (*err != REG_NOERROR))
+ goto parse_bracket_exp_free_return;
+ break;
+ default:
+ assert (0);
+ break;
+ }
+ }
+ if (__glibc_unlikely (token->type == END_OF_RE))
+ {
+ *err = REG_EBRACK;
+ goto parse_bracket_exp_free_return;
+ }
+ if (token->type == OP_CLOSE_BRACKET)
+ break;
+ }
+
+ re_string_skip_bytes (regexp, token_len); /* Skip a token. */
+
+ /* If it is non-matching list. */
+ if (non_match)
+ bitset_not (sbcset);
+
+#ifdef RE_ENABLE_I18N
+ /* Ensure only single byte characters are set. */
+ if (dfa->mb_cur_max > 1)
+ bitset_mask (sbcset, dfa->sb_char);
+
+ if (mbcset->nmbchars || mbcset->ncoll_syms || mbcset->nequiv_classes
+ || mbcset->nranges || (dfa->mb_cur_max > 1 && (mbcset->nchar_classes
+ || mbcset->non_match)))
+ {
+ bin_tree_t *mbc_tree;
+ int sbc_idx;
+ /* Build a tree for complex bracket. */
+ dfa->has_mb_node = 1;
+ br_token.type = COMPLEX_BRACKET;
+ br_token.opr.mbcset = mbcset;
+ mbc_tree = create_token_tree (dfa, NULL, NULL, &br_token);
+ if (__glibc_unlikely (mbc_tree == NULL))
+ goto parse_bracket_exp_espace;
+ for (sbc_idx = 0; sbc_idx < BITSET_WORDS; ++sbc_idx)
+ if (sbcset[sbc_idx])
+ break;
+ /* If there are no bits set in sbcset, there is no point
+ of having both SIMPLE_BRACKET and COMPLEX_BRACKET. */
+ if (sbc_idx < BITSET_WORDS)
+ {
+ /* Build a tree for simple bracket. */
+ br_token.type = SIMPLE_BRACKET;
+ br_token.opr.sbcset = sbcset;
+ work_tree = create_token_tree (dfa, NULL, NULL, &br_token);
+ if (__glibc_unlikely (work_tree == NULL))
+ goto parse_bracket_exp_espace;
+
+ /* Then join them by ALT node. */
+ work_tree = create_tree (dfa, work_tree, mbc_tree, OP_ALT);
+ if (__glibc_unlikely (work_tree == NULL))
+ goto parse_bracket_exp_espace;
+ }
+ else
+ {
+ re_free (sbcset);
+ work_tree = mbc_tree;
+ }
+ }
+ else
+#endif /* not RE_ENABLE_I18N */
+ {
+#ifdef RE_ENABLE_I18N
+ free_charset (mbcset);
+#endif
+ /* Build a tree for simple bracket. */
+ br_token.type = SIMPLE_BRACKET;
+ br_token.opr.sbcset = sbcset;
+ work_tree = create_token_tree (dfa, NULL, NULL, &br_token);
+ if (__glibc_unlikely (work_tree == NULL))
+ goto parse_bracket_exp_espace;
+ }
+ return work_tree;
+
+ parse_bracket_exp_espace:
+ *err = REG_ESPACE;
+ parse_bracket_exp_free_return:
+ re_free (sbcset);
+#ifdef RE_ENABLE_I18N
+ free_charset (mbcset);
+#endif /* RE_ENABLE_I18N */
+ return NULL;
+}
+
+/* Parse an element in the bracket expression. */
+
+static reg_errcode_t
+parse_bracket_element (bracket_elem_t *elem, re_string_t *regexp,
+ re_token_t *token, int token_len, re_dfa_t *dfa,
+ reg_syntax_t syntax, bool accept_hyphen)
+{
+#ifdef RE_ENABLE_I18N
+ int cur_char_size;
+ cur_char_size = re_string_char_size_at (regexp, re_string_cur_idx (regexp));
+ if (cur_char_size > 1)
+ {
+ elem->type = MB_CHAR;
+ elem->opr.wch = re_string_wchar_at (regexp, re_string_cur_idx (regexp));
+ re_string_skip_bytes (regexp, cur_char_size);
+ return REG_NOERROR;
+ }
+#endif /* RE_ENABLE_I18N */
+ re_string_skip_bytes (regexp, token_len); /* Skip a token. */
+ if (token->type == OP_OPEN_COLL_ELEM || token->type == OP_OPEN_CHAR_CLASS
+ || token->type == OP_OPEN_EQUIV_CLASS)
+ return parse_bracket_symbol (elem, regexp, token);
+ if (__glibc_unlikely (token->type == OP_CHARSET_RANGE) && !accept_hyphen)
+ {
+ /* A '-' must only appear as anything but a range indicator before
+ the closing bracket. Everything else is an error. */
+ re_token_t token2;
+ (void) peek_token_bracket (&token2, regexp, syntax);
+ if (token2.type != OP_CLOSE_BRACKET)
+ /* The actual error value is not standardized since this whole
+ case is undefined. But ERANGE makes good sense. */
+ return REG_ERANGE;
+ }
+ elem->type = SB_CHAR;
+ elem->opr.ch = token->opr.c;
+ return REG_NOERROR;
+}
+
+/* Parse a bracket symbol in the bracket expression. Bracket symbols are
+ such as [:<character_class>:], [.<collating_element>.], and
+ [=<equivalent_class>=]. */
+
+static reg_errcode_t
+parse_bracket_symbol (bracket_elem_t *elem, re_string_t *regexp,
+ re_token_t *token)
+{
+ unsigned char ch, delim = token->opr.c;
+ int i = 0;
+ if (re_string_eoi(regexp))
+ return REG_EBRACK;
+ for (;; ++i)
+ {
+ if (i >= BRACKET_NAME_BUF_SIZE)
+ return REG_EBRACK;
+ if (token->type == OP_OPEN_CHAR_CLASS)
+ ch = re_string_fetch_byte_case (regexp);
+ else
+ ch = re_string_fetch_byte (regexp);
+ if (re_string_eoi(regexp))
+ return REG_EBRACK;
+ if (ch == delim && re_string_peek_byte (regexp, 0) == ']')
+ break;
+ elem->opr.name[i] = ch;
+ }
+ re_string_skip_bytes (regexp, 1);
+ elem->opr.name[i] = '\0';
+ switch (token->type)
+ {
+ case OP_OPEN_COLL_ELEM:
+ elem->type = COLL_SYM;
+ break;
+ case OP_OPEN_EQUIV_CLASS:
+ elem->type = EQUIV_CLASS;
+ break;
+ case OP_OPEN_CHAR_CLASS:
+ elem->type = CHAR_CLASS;
+ break;
+ default:
+ break;
+ }
+ return REG_NOERROR;
+}
+
+ /* Helper function for parse_bracket_exp.
+ Build the equivalence class which is represented by NAME.
+ The result are written to MBCSET and SBCSET.
+ EQUIV_CLASS_ALLOC is the allocated size of mbcset->equiv_classes,
+ is a pointer argument since we may update it. */
+
+static reg_errcode_t
+#ifdef RE_ENABLE_I18N
+build_equiv_class (bitset_t sbcset, re_charset_t *mbcset,
+ Idx *equiv_class_alloc, const unsigned char *name)
+#else /* not RE_ENABLE_I18N */
+build_equiv_class (bitset_t sbcset, const unsigned char *name)
+#endif /* not RE_ENABLE_I18N */
+{
+#ifdef _LIBC
+ uint32_t nrules = _NL_CURRENT_WORD (LC_COLLATE, _NL_COLLATE_NRULES);
+ if (nrules != 0)
+ {
+ const int32_t *table, *indirect;
+ const unsigned char *weights, *extra, *cp;
+ unsigned char char_buf[2];
+ int32_t idx1, idx2;
+ unsigned int ch;
+ size_t len;
+ /* Calculate the index for equivalence class. */
+ cp = name;
+ table = (const int32_t *) _NL_CURRENT (LC_COLLATE, _NL_COLLATE_TABLEMB);
+ weights = (const unsigned char *) _NL_CURRENT (LC_COLLATE,
+ _NL_COLLATE_WEIGHTMB);
+ extra = (const unsigned char *) _NL_CURRENT (LC_COLLATE,
+ _NL_COLLATE_EXTRAMB);
+ indirect = (const int32_t *) _NL_CURRENT (LC_COLLATE,
+ _NL_COLLATE_INDIRECTMB);
+ idx1 = findidx (table, indirect, extra, &cp, -1);
+ if (__glibc_unlikely (idx1 == 0 || *cp != '\0'))
+ /* This isn't a valid character. */
+ return REG_ECOLLATE;
+
+ /* Build single byte matching table for this equivalence class. */
+ len = weights[idx1 & 0xffffff];
+ for (ch = 0; ch < SBC_MAX; ++ch)
+ {
+ char_buf[0] = ch;
+ cp = char_buf;
+ idx2 = findidx (table, indirect, extra, &cp, 1);
+/*
+ idx2 = table[ch];
+*/
+ if (idx2 == 0)
+ /* This isn't a valid character. */
+ continue;
+ /* Compare only if the length matches and the collation rule
+ index is the same. */
+ if (len == weights[idx2 & 0xffffff] && (idx1 >> 24) == (idx2 >> 24)
+ && memcmp (weights + (idx1 & 0xffffff) + 1,
+ weights + (idx2 & 0xffffff) + 1, len) == 0)
+ bitset_set (sbcset, ch);
+ }
+ /* Check whether the array has enough space. */
+ if (__glibc_unlikely (*equiv_class_alloc == mbcset->nequiv_classes))
+ {
+ /* Not enough, realloc it. */
+ /* +1 in case of mbcset->nequiv_classes is 0. */
+ Idx new_equiv_class_alloc = 2 * mbcset->nequiv_classes + 1;
+ /* Use realloc since the array is NULL if *alloc == 0. */
+ int32_t *new_equiv_classes = re_realloc (mbcset->equiv_classes,
+ int32_t,
+ new_equiv_class_alloc);
+ if (__glibc_unlikely (new_equiv_classes == NULL))
+ return REG_ESPACE;
+ mbcset->equiv_classes = new_equiv_classes;
+ *equiv_class_alloc = new_equiv_class_alloc;
+ }
+ mbcset->equiv_classes[mbcset->nequiv_classes++] = idx1;
+ }
+ else
+#endif /* _LIBC */
+ {
+ if (__glibc_unlikely (strlen ((const char *) name) != 1))
+ return REG_ECOLLATE;
+ bitset_set (sbcset, *name);
+ }
+ return REG_NOERROR;
+}
+
+ /* Helper function for parse_bracket_exp.
+ Build the character class which is represented by NAME.
+ The result are written to MBCSET and SBCSET.
+ CHAR_CLASS_ALLOC is the allocated size of mbcset->char_classes,
+ is a pointer argument since we may update it. */
+
+static reg_errcode_t
+#ifdef RE_ENABLE_I18N
+build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset,
+ re_charset_t *mbcset, Idx *char_class_alloc,
+ const char *class_name, reg_syntax_t syntax)
+#else /* not RE_ENABLE_I18N */
+build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset,
+ const char *class_name, reg_syntax_t syntax)
+#endif /* not RE_ENABLE_I18N */
+{
+ int i;
+ const char *name = class_name;
+
+ /* In case of REG_ICASE "upper" and "lower" match the both of
+ upper and lower cases. */
+ if ((syntax & RE_ICASE)
+ && (strcmp (name, "upper") == 0 || strcmp (name, "lower") == 0))
+ name = "alpha";
+
+#ifdef RE_ENABLE_I18N
+ /* Check the space of the arrays. */
+ if (__glibc_unlikely (*char_class_alloc == mbcset->nchar_classes))
+ {
+ /* Not enough, realloc it. */
+ /* +1 in case of mbcset->nchar_classes is 0. */
+ Idx new_char_class_alloc = 2 * mbcset->nchar_classes + 1;
+ /* Use realloc since array is NULL if *alloc == 0. */
+ wctype_t *new_char_classes = re_realloc (mbcset->char_classes, wctype_t,
+ new_char_class_alloc);
+ if (__glibc_unlikely (new_char_classes == NULL))
+ return REG_ESPACE;
+ mbcset->char_classes = new_char_classes;
+ *char_class_alloc = new_char_class_alloc;
+ }
+ mbcset->char_classes[mbcset->nchar_classes++] = __wctype (name);
+#endif /* RE_ENABLE_I18N */
+
+#define BUILD_CHARCLASS_LOOP(ctype_func) \
+ do { \
+ if (__glibc_unlikely (trans != NULL)) \
+ { \
+ for (i = 0; i < SBC_MAX; ++i) \
+ if (ctype_func (i)) \
+ bitset_set (sbcset, trans[i]); \
+ } \
+ else \
+ { \
+ for (i = 0; i < SBC_MAX; ++i) \
+ if (ctype_func (i)) \
+ bitset_set (sbcset, i); \
+ } \
+ } while (0)
+
+ if (strcmp (name, "alnum") == 0)
+ BUILD_CHARCLASS_LOOP (isalnum);
+ else if (strcmp (name, "cntrl") == 0)
+ BUILD_CHARCLASS_LOOP (iscntrl);
+ else if (strcmp (name, "lower") == 0)
+ BUILD_CHARCLASS_LOOP (islower);
+ else if (strcmp (name, "space") == 0)
+ BUILD_CHARCLASS_LOOP (isspace);
+ else if (strcmp (name, "alpha") == 0)
+ BUILD_CHARCLASS_LOOP (isalpha);
+ else if (strcmp (name, "digit") == 0)
+ BUILD_CHARCLASS_LOOP (isdigit);
+ else if (strcmp (name, "print") == 0)
+ BUILD_CHARCLASS_LOOP (isprint);
+ else if (strcmp (name, "upper") == 0)
+ BUILD_CHARCLASS_LOOP (isupper);
+ else if (strcmp (name, "blank") == 0)
+ BUILD_CHARCLASS_LOOP (isblank);
+ else if (strcmp (name, "graph") == 0)
+ BUILD_CHARCLASS_LOOP (isgraph);
+ else if (strcmp (name, "punct") == 0)
+ BUILD_CHARCLASS_LOOP (ispunct);
+ else if (strcmp (name, "xdigit") == 0)
+ BUILD_CHARCLASS_LOOP (isxdigit);
+ else
+ return REG_ECTYPE;
+
+ return REG_NOERROR;
+}
+
+static bin_tree_t *
+build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans,
+ const char *class_name,
+ const char *extra, bool non_match,
+ reg_errcode_t *err)
+{
+ re_bitset_ptr_t sbcset;
+#ifdef RE_ENABLE_I18N
+ re_charset_t *mbcset;
+ Idx alloc = 0;
+#endif /* not RE_ENABLE_I18N */
+ reg_errcode_t ret;
+ re_token_t br_token;
+ bin_tree_t *tree;
+
+ sbcset = (re_bitset_ptr_t) calloc (sizeof (bitset_t), 1);
+ if (__glibc_unlikely (sbcset == NULL))
+ {
+ *err = REG_ESPACE;
+ return NULL;
+ }
+#ifdef RE_ENABLE_I18N
+ mbcset = (re_charset_t *) calloc (sizeof (re_charset_t), 1);
+ if (__glibc_unlikely (mbcset == NULL))
+ {
+ re_free (sbcset);
+ *err = REG_ESPACE;
+ return NULL;
+ }
+ mbcset->non_match = non_match;
+#endif /* RE_ENABLE_I18N */
+
+ /* We don't care the syntax in this case. */
+ ret = build_charclass (trans, sbcset,
+#ifdef RE_ENABLE_I18N
+ mbcset, &alloc,
+#endif /* RE_ENABLE_I18N */
+ class_name, 0);
+
+ if (__glibc_unlikely (ret != REG_NOERROR))
+ {
+ re_free (sbcset);
+#ifdef RE_ENABLE_I18N
+ free_charset (mbcset);
+#endif /* RE_ENABLE_I18N */
+ *err = ret;
+ return NULL;
+ }
+ /* \w match '_' also. */
+ for (; *extra; extra++)
+ bitset_set (sbcset, *extra);
+
+ /* If it is non-matching list. */
+ if (non_match)
+ bitset_not (sbcset);
+
+#ifdef RE_ENABLE_I18N
+ /* Ensure only single byte characters are set. */
+ if (dfa->mb_cur_max > 1)
+ bitset_mask (sbcset, dfa->sb_char);
+#endif
+
+ /* Build a tree for simple bracket. */
+#if defined GCC_LINT || defined lint
+ memset (&br_token, 0, sizeof br_token);
+#endif
+ br_token.type = SIMPLE_BRACKET;
+ br_token.opr.sbcset = sbcset;
+ tree = create_token_tree (dfa, NULL, NULL, &br_token);
+ if (__glibc_unlikely (tree == NULL))
+ goto build_word_op_espace;
+
+#ifdef RE_ENABLE_I18N
+ if (dfa->mb_cur_max > 1)
+ {
+ bin_tree_t *mbc_tree;
+ /* Build a tree for complex bracket. */
+ br_token.type = COMPLEX_BRACKET;
+ br_token.opr.mbcset = mbcset;
+ dfa->has_mb_node = 1;
+ mbc_tree = create_token_tree (dfa, NULL, NULL, &br_token);
+ if (__glibc_unlikely (mbc_tree == NULL))
+ goto build_word_op_espace;
+ /* Then join them by ALT node. */
+ tree = create_tree (dfa, tree, mbc_tree, OP_ALT);
+ if (__glibc_likely (mbc_tree != NULL))
+ return tree;
+ }
+ else
+ {
+ free_charset (mbcset);
+ return tree;
+ }
+#else /* not RE_ENABLE_I18N */
+ return tree;
+#endif /* not RE_ENABLE_I18N */
+
+ build_word_op_espace:
+ re_free (sbcset);
+#ifdef RE_ENABLE_I18N
+ free_charset (mbcset);
+#endif /* RE_ENABLE_I18N */
+ *err = REG_ESPACE;
+ return NULL;
+}
+
+/* This is intended for the expressions like "a{1,3}".
+ Fetch a number from 'input', and return the number.
+ Return -1 if the number field is empty like "{,1}".
+ Return RE_DUP_MAX + 1 if the number field is too large.
+ Return -2 if an error occurred. */
+
+static Idx
+fetch_number (re_string_t *input, re_token_t *token, reg_syntax_t syntax)
+{
+ Idx num = -1;
+ unsigned char c;
+ while (1)
+ {
+ fetch_token (token, input, syntax);
+ c = token->opr.c;
+ if (__glibc_unlikely (token->type == END_OF_RE))
+ return -2;
+ if (token->type == OP_CLOSE_DUP_NUM || c == ',')
+ break;
+ num = ((token->type != CHARACTER || c < '0' || '9' < c || num == -2)
+ ? -2
+ : num == -1
+ ? c - '0'
+ : MIN (RE_DUP_MAX + 1, num * 10 + c - '0'));
+ }
+ return num;
+}
+
+#ifdef RE_ENABLE_I18N
+static void
+free_charset (re_charset_t *cset)
+{
+ re_free (cset->mbchars);
+# ifdef _LIBC
+ re_free (cset->coll_syms);
+ re_free (cset->equiv_classes);
+# endif
+ re_free (cset->range_starts);
+ re_free (cset->range_ends);
+ re_free (cset->char_classes);
+ re_free (cset);
+}
+#endif /* RE_ENABLE_I18N */
+
+/* Functions for binary tree operation. */
+
+/* Create a tree node. */
+
+static bin_tree_t *
+create_tree (re_dfa_t *dfa, bin_tree_t *left, bin_tree_t *right,
+ re_token_type_t type)
+{
+ re_token_t t;
+#if defined GCC_LINT || defined lint
+ memset (&t, 0, sizeof t);
+#endif
+ t.type = type;
+ return create_token_tree (dfa, left, right, &t);
+}
+
+static bin_tree_t *
+create_token_tree (re_dfa_t *dfa, bin_tree_t *left, bin_tree_t *right,
+ const re_token_t *token)
+{
+ bin_tree_t *tree;
+ if (__glibc_unlikely (dfa->str_tree_storage_idx == BIN_TREE_STORAGE_SIZE))
+ {
+ bin_tree_storage_t *storage = re_malloc (bin_tree_storage_t, 1);
+
+ if (storage == NULL)
+ return NULL;
+ storage->next = dfa->str_tree_storage;
+ dfa->str_tree_storage = storage;
+ dfa->str_tree_storage_idx = 0;
+ }
+ tree = &dfa->str_tree_storage->data[dfa->str_tree_storage_idx++];
+
+ tree->parent = NULL;
+ tree->left = left;
+ tree->right = right;
+ tree->token = *token;
+ tree->token.duplicated = 0;
+ tree->token.opt_subexp = 0;
+ tree->first = NULL;
+ tree->next = NULL;
+ tree->node_idx = -1;
+
+ if (left != NULL)
+ left->parent = tree;
+ if (right != NULL)
+ right->parent = tree;
+ return tree;
+}
+
+/* Mark the tree SRC as an optional subexpression.
+ To be called from preorder or postorder. */
+
+static reg_errcode_t
+mark_opt_subexp (void *extra, bin_tree_t *node)
+{
+ Idx idx = (uintptr_t) extra;
+ if (node->token.type == SUBEXP && node->token.opr.idx == idx)
+ node->token.opt_subexp = 1;
+
+ return REG_NOERROR;
+}
+
+/* Free the allocated memory inside NODE. */
+
+static void
+free_token (re_token_t *node)
+{
+#ifdef RE_ENABLE_I18N
+ if (node->type == COMPLEX_BRACKET && node->duplicated == 0)
+ free_charset (node->opr.mbcset);
+ else
+#endif /* RE_ENABLE_I18N */
+ if (node->type == SIMPLE_BRACKET && node->duplicated == 0)
+ re_free (node->opr.sbcset);
+}
+
+/* Worker function for tree walking. Free the allocated memory inside NODE
+ and its children. */
+
+static reg_errcode_t
+free_tree (void *extra, bin_tree_t *node)
+{
+ free_token (&node->token);
+ return REG_NOERROR;
+}
+
+
+/* Duplicate the node SRC, and return new node. This is a preorder
+ visit similar to the one implemented by the generic visitor, but
+ we need more infrastructure to maintain two parallel trees --- so,
+ it's easier to duplicate. */
+
+static bin_tree_t *
+duplicate_tree (const bin_tree_t *root, re_dfa_t *dfa)
+{
+ const bin_tree_t *node;
+ bin_tree_t *dup_root;
+ bin_tree_t **p_new = &dup_root, *dup_node = root->parent;
+
+ for (node = root; ; )
+ {
+ /* Create a new tree and link it back to the current parent. */
+ *p_new = create_token_tree (dfa, NULL, NULL, &node->token);
+ if (*p_new == NULL)
+ return NULL;
+ (*p_new)->parent = dup_node;
+ (*p_new)->token.duplicated = 1;
+ dup_node = *p_new;
+
+ /* Go to the left node, or up and to the right. */
+ if (node->left)
+ {
+ node = node->left;
+ p_new = &dup_node->left;
+ }
+ else
+ {
+ const bin_tree_t *prev = NULL;
+ while (node->right == prev || node->right == NULL)
+ {
+ prev = node;
+ node = node->parent;
+ dup_node = dup_node->parent;
+ if (!node)
+ return dup_root;
+ }
+ node = node->right;
+ p_new = &dup_node->right;
+ }
+ }
+}
diff --git a/lib/regex.c b/lib/regex.c
new file mode 100644
index 00000000000..eab7a48b240
--- /dev/null
+++ b/lib/regex.c
@@ -0,0 +1,81 @@
+/* Extended regular expression matching and search library.
+ Copyright (C) 2002-2019 Free Software Foundation, Inc.
+ This file is part of the GNU C Library.
+ Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>.
+
+ 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
+ <https://www.gnu.org/licenses/>. */
+
+#ifndef _LIBC
+# include <libc-config.h>
+
+# if __GNUC_PREREQ (4, 6)
+# pragma GCC diagnostic ignored "-Wsuggest-attribute=pure"
+# endif
+# if __GNUC_PREREQ (4, 3)
+# pragma GCC diagnostic ignored "-Wold-style-definition"
+# pragma GCC diagnostic ignored "-Wtype-limits"
+# endif
+#endif
+
+/* Make sure no one compiles this code with a C++ compiler. */
+#if defined __cplusplus && defined _LIBC
+# error "This is C code, use a C compiler"
+#endif
+
+#ifdef _LIBC
+/* We have to keep the namespace clean. */
+# define regfree(preg) __regfree (preg)
+# define regexec(pr, st, nm, pm, ef) __regexec (pr, st, nm, pm, ef)
+# define regcomp(preg, pattern, cflags) __regcomp (preg, pattern, cflags)
+# define regerror(errcode, preg, errbuf, errbuf_size) \
+ __regerror(errcode, preg, errbuf, errbuf_size)
+# define re_set_registers(bu, re, nu, st, en) \
+ __re_set_registers (bu, re, nu, st, en)
+# define re_match_2(bufp, string1, size1, string2, size2, pos, regs, stop) \
+ __re_match_2 (bufp, string1, size1, string2, size2, pos, regs, stop)
+# define re_match(bufp, string, size, pos, regs) \
+ __re_match (bufp, string, size, pos, regs)
+# define re_search(bufp, string, size, startpos, range, regs) \
+ __re_search (bufp, string, size, startpos, range, regs)
+# define re_compile_pattern(pattern, length, bufp) \
+ __re_compile_pattern (pattern, length, bufp)
+# define re_set_syntax(syntax) __re_set_syntax (syntax)
+# define re_search_2(bufp, st1, s1, st2, s2, startpos, range, regs, stop) \
+ __re_search_2 (bufp, st1, s1, st2, s2, startpos, range, regs, stop)
+# define re_compile_fastmap(bufp) __re_compile_fastmap (bufp)
+
+# include "../locale/localeinfo.h"
+#endif
+
+/* On some systems, limits.h sets RE_DUP_MAX to a lower value than
+ GNU regex allows. Include it before <regex.h>, which correctly
+ #undefs RE_DUP_MAX and sets it to the right value. */
+#include <limits.h>
+
+#include <regex.h>
+#include "regex_internal.h"
+
+#include "regex_internal.c"
+#include "regcomp.c"
+#include "regexec.c"
+
+/* Binary backward compatibility. */
+#if _LIBC
+# include <shlib-compat.h>
+# if SHLIB_COMPAT (libc, GLIBC_2_0, GLIBC_2_3)
+link_warning (re_max_failures, "the 're_max_failures' variable is obsolete and will go away.")
+int re_max_failures = 2000;
+# endif
+#endif
diff --git a/lib/regex.h b/lib/regex.h
new file mode 100644
index 00000000000..77ac1a559c4
--- /dev/null
+++ b/lib/regex.h
@@ -0,0 +1,658 @@
+/* Definitions for data structures and routines for the regular
+ expression library.
+ Copyright (C) 1985, 1989-2019 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
+ <https://www.gnu.org/licenses/>. */
+
+#ifndef _REGEX_H
+#define _REGEX_H 1
+
+#include <sys/types.h>
+
+/* Allow the use in C++ code. */
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* Define __USE_GNU to declare GNU extensions that violate the
+ POSIX name space rules. */
+#ifdef _GNU_SOURCE
+# define __USE_GNU 1
+#endif
+
+#ifdef _REGEX_LARGE_OFFSETS
+
+/* Use types and values that are wide enough to represent signed and
+ unsigned byte offsets in memory. This currently works only when
+ the regex code is used outside of the GNU C library; it is not yet
+ supported within glibc itself, and glibc users should not define
+ _REGEX_LARGE_OFFSETS. */
+
+/* The type of object sizes. */
+typedef size_t __re_size_t;
+
+/* The type of object sizes, in places where the traditional code
+ uses unsigned long int. */
+typedef size_t __re_long_size_t;
+
+#else
+
+/* The traditional GNU regex implementation mishandles strings longer
+ than INT_MAX. */
+typedef unsigned int __re_size_t;
+typedef unsigned long int __re_long_size_t;
+
+#endif
+
+/* The following two types have to be signed and unsigned integer type
+ wide enough to hold a value of a pointer. For most ANSI compilers
+ ptrdiff_t and size_t should be likely OK. Still size of these two
+ types is 2 for Microsoft C. Ugh... */
+typedef long int s_reg_t;
+typedef unsigned long int active_reg_t;
+
+/* The following bits are used to determine the regexp syntax we
+ recognize. The set/not-set meanings are chosen so that Emacs syntax
+ remains the value 0. The bits are given in alphabetical order, and
+ the definitions shifted by one from the previous bit; thus, when we
+ add or remove a bit, only one other definition need change. */
+typedef unsigned long int reg_syntax_t;
+
+#ifdef __USE_GNU
+/* If this bit is not set, then \ inside a bracket expression is literal.
+ If set, then such a \ quotes the following character. */
+# define RE_BACKSLASH_ESCAPE_IN_LISTS ((unsigned long int) 1)
+
+/* If this bit is not set, then + and ? are operators, and \+ and \? are
+ literals.
+ If set, then \+ and \? are operators and + and ? are literals. */
+# define RE_BK_PLUS_QM (RE_BACKSLASH_ESCAPE_IN_LISTS << 1)
+
+/* If this bit is set, then character classes are supported. They are:
+ [:alpha:], [:upper:], [:lower:], [:digit:], [:alnum:], [:xdigit:],
+ [:space:], [:print:], [:punct:], [:graph:], and [:cntrl:].
+ If not set, then character classes are not supported. */
+# define RE_CHAR_CLASSES (RE_BK_PLUS_QM << 1)
+
+/* If this bit is set, then ^ and $ are always anchors (outside bracket
+ expressions, of course).
+ If this bit is not set, then it depends:
+ ^ is an anchor if it is at the beginning of a regular
+ expression or after an open-group or an alternation operator;
+ $ is an anchor if it is at the end of a regular expression, or
+ before a close-group or an alternation operator.
+
+ This bit could be (re)combined with RE_CONTEXT_INDEP_OPS, because
+ POSIX draft 11.2 says that * etc. in leading positions is undefined.
+ We already implemented a previous draft which made those constructs
+ invalid, though, so we haven't changed the code back. */
+# define RE_CONTEXT_INDEP_ANCHORS (RE_CHAR_CLASSES << 1)
+
+/* If this bit is set, then special characters are always special
+ regardless of where they are in the pattern.
+ If this bit is not set, then special characters are special only in
+ some contexts; otherwise they are ordinary. Specifically,
+ * + ? and intervals are only special when not after the beginning,
+ open-group, or alternation operator. */
+# define RE_CONTEXT_INDEP_OPS (RE_CONTEXT_INDEP_ANCHORS << 1)
+
+/* If this bit is set, then *, +, ?, and { cannot be first in an re or
+ immediately after an alternation or begin-group operator. */
+# define RE_CONTEXT_INVALID_OPS (RE_CONTEXT_INDEP_OPS << 1)
+
+/* If this bit is set, then . matches newline.
+ If not set, then it doesn't. */
+# define RE_DOT_NEWLINE (RE_CONTEXT_INVALID_OPS << 1)
+
+/* If this bit is set, then . doesn't match NUL.
+ If not set, then it does. */
+# define RE_DOT_NOT_NULL (RE_DOT_NEWLINE << 1)
+
+/* If this bit is set, nonmatching lists [^...] do not match newline.
+ If not set, they do. */
+# define RE_HAT_LISTS_NOT_NEWLINE (RE_DOT_NOT_NULL << 1)
+
+/* If this bit is set, either \{...\} or {...} defines an
+ interval, depending on RE_NO_BK_BRACES.
+ If not set, \{, \}, {, and } are literals. */
+# define RE_INTERVALS (RE_HAT_LISTS_NOT_NEWLINE << 1)
+
+/* If this bit is set, +, ? and | aren't recognized as operators.
+ If not set, they are. */
+# define RE_LIMITED_OPS (RE_INTERVALS << 1)
+
+/* If this bit is set, newline is an alternation operator.
+ If not set, newline is literal. */
+# define RE_NEWLINE_ALT (RE_LIMITED_OPS << 1)
+
+/* If this bit is set, then '{...}' defines an interval, and \{ and \}
+ are literals.
+ If not set, then '\{...\}' defines an interval. */
+# define RE_NO_BK_BRACES (RE_NEWLINE_ALT << 1)
+
+/* If this bit is set, (...) defines a group, and \( and \) are literals.
+ If not set, \(...\) defines a group, and ( and ) are literals. */
+# define RE_NO_BK_PARENS (RE_NO_BK_BRACES << 1)
+
+/* If this bit is set, then \<digit> matches <digit>.
+ If not set, then \<digit> is a back-reference. */
+# define RE_NO_BK_REFS (RE_NO_BK_PARENS << 1)
+
+/* If this bit is set, then | is an alternation operator, and \| is literal.
+ If not set, then \| is an alternation operator, and | is literal. */
+# define RE_NO_BK_VBAR (RE_NO_BK_REFS << 1)
+
+/* If this bit is set, then an ending range point collating higher
+ than the starting range point, as in [z-a], is invalid.
+ If not set, then when ending range point collates higher than the
+ starting range point, the range is ignored. */
+# define RE_NO_EMPTY_RANGES (RE_NO_BK_VBAR << 1)
+
+/* If this bit is set, then an unmatched ) is ordinary.
+ If not set, then an unmatched ) is invalid. */
+# define RE_UNMATCHED_RIGHT_PAREN_ORD (RE_NO_EMPTY_RANGES << 1)
+
+/* If this bit is set, succeed as soon as we match the whole pattern,
+ without further backtracking. */
+# define RE_NO_POSIX_BACKTRACKING (RE_UNMATCHED_RIGHT_PAREN_ORD << 1)
+
+/* If this bit is set, do not process the GNU regex operators.
+ If not set, then the GNU regex operators are recognized. */
+# define RE_NO_GNU_OPS (RE_NO_POSIX_BACKTRACKING << 1)
+
+/* If this bit is set, turn on internal regex debugging.
+ If not set, and debugging was on, turn it off.
+ This only works if regex.c is compiled -DDEBUG.
+ We define this bit always, so that all that's needed to turn on
+ debugging is to recompile regex.c; the calling code can always have
+ this bit set, and it won't affect anything in the normal case. */
+# define RE_DEBUG (RE_NO_GNU_OPS << 1)
+
+/* If this bit is set, a syntactically invalid interval is treated as
+ a string of ordinary characters. For example, the ERE 'a{1' is
+ treated as 'a\{1'. */
+# define RE_INVALID_INTERVAL_ORD (RE_DEBUG << 1)
+
+/* If this bit is set, then ignore case when matching.
+ If not set, then case is significant. */
+# define RE_ICASE (RE_INVALID_INTERVAL_ORD << 1)
+
+/* This bit is used internally like RE_CONTEXT_INDEP_ANCHORS but only
+ for ^, because it is difficult to scan the regex backwards to find
+ whether ^ should be special. */
+# define RE_CARET_ANCHORS_HERE (RE_ICASE << 1)
+
+/* If this bit is set, then \{ cannot be first in a regex or
+ immediately after an alternation, open-group or \} operator. */
+# define RE_CONTEXT_INVALID_DUP (RE_CARET_ANCHORS_HERE << 1)
+
+/* If this bit is set, then no_sub will be set to 1 during
+ re_compile_pattern. */
+# define RE_NO_SUB (RE_CONTEXT_INVALID_DUP << 1)
+#endif
+
+/* This global variable defines the particular regexp syntax to use (for
+ some interfaces). When a regexp is compiled, the syntax used is
+ stored in the pattern buffer, so changing this does not affect
+ already-compiled regexps. */
+extern reg_syntax_t re_syntax_options;
+
+#ifdef __USE_GNU
+/* Define combinations of the above bits for the standard possibilities.
+ (The [[[ comments delimit what gets put into the Texinfo file, so
+ don't delete them!) */
+/* [[[begin syntaxes]]] */
+# define RE_SYNTAX_EMACS 0
+
+# define RE_SYNTAX_AWK \
+ (RE_BACKSLASH_ESCAPE_IN_LISTS | RE_DOT_NOT_NULL \
+ | RE_NO_BK_PARENS | RE_NO_BK_REFS \
+ | RE_NO_BK_VBAR | RE_NO_EMPTY_RANGES \
+ | RE_DOT_NEWLINE | RE_CONTEXT_INDEP_ANCHORS \
+ | RE_CHAR_CLASSES \
+ | RE_UNMATCHED_RIGHT_PAREN_ORD | RE_NO_GNU_OPS)
+
+# define RE_SYNTAX_GNU_AWK \
+ ((RE_SYNTAX_POSIX_EXTENDED | RE_BACKSLASH_ESCAPE_IN_LISTS \
+ | RE_INVALID_INTERVAL_ORD) \
+ & ~(RE_DOT_NOT_NULL | RE_CONTEXT_INDEP_OPS \
+ | RE_CONTEXT_INVALID_OPS ))
+
+# define RE_SYNTAX_POSIX_AWK \
+ (RE_SYNTAX_POSIX_EXTENDED | RE_BACKSLASH_ESCAPE_IN_LISTS \
+ | RE_INTERVALS | RE_NO_GNU_OPS \
+ | RE_INVALID_INTERVAL_ORD)
+
+# define RE_SYNTAX_GREP \
+ ((RE_SYNTAX_POSIX_BASIC | RE_NEWLINE_ALT) \
+ & ~(RE_CONTEXT_INVALID_DUP | RE_DOT_NOT_NULL))
+
+# define RE_SYNTAX_EGREP \
+ ((RE_SYNTAX_POSIX_EXTENDED | RE_INVALID_INTERVAL_ORD | RE_NEWLINE_ALT) \
+ & ~(RE_CONTEXT_INVALID_OPS | RE_DOT_NOT_NULL))
+
+/* POSIX grep -E behavior is no longer incompatible with GNU. */
+# define RE_SYNTAX_POSIX_EGREP \
+ RE_SYNTAX_EGREP
+
+/* P1003.2/D11.2, section 4.20.7.1, lines 5078ff. */
+# define RE_SYNTAX_ED RE_SYNTAX_POSIX_BASIC
+
+# define RE_SYNTAX_SED RE_SYNTAX_POSIX_BASIC
+
+/* Syntax bits common to both basic and extended POSIX regex syntax. */
+# define _RE_SYNTAX_POSIX_COMMON \
+ (RE_CHAR_CLASSES | RE_DOT_NEWLINE | RE_DOT_NOT_NULL \
+ | RE_INTERVALS | RE_NO_EMPTY_RANGES)
+
+# define RE_SYNTAX_POSIX_BASIC \
+ (_RE_SYNTAX_POSIX_COMMON | RE_BK_PLUS_QM | RE_CONTEXT_INVALID_DUP)
+
+/* Differs from ..._POSIX_BASIC only in that RE_BK_PLUS_QM becomes
+ RE_LIMITED_OPS, i.e., \? \+ \| are not recognized. Actually, this
+ isn't minimal, since other operators, such as \`, aren't disabled. */
+# define RE_SYNTAX_POSIX_MINIMAL_BASIC \
+ (_RE_SYNTAX_POSIX_COMMON | RE_LIMITED_OPS)
+
+# define RE_SYNTAX_POSIX_EXTENDED \
+ (_RE_SYNTAX_POSIX_COMMON | RE_CONTEXT_INDEP_ANCHORS \
+ | RE_CONTEXT_INDEP_OPS | RE_NO_BK_BRACES \
+ | RE_NO_BK_PARENS | RE_NO_BK_VBAR \
+ | RE_CONTEXT_INVALID_OPS | RE_UNMATCHED_RIGHT_PAREN_ORD)
+
+/* Differs from ..._POSIX_EXTENDED in that RE_CONTEXT_INDEP_OPS is
+ removed and RE_NO_BK_REFS is added. */
+# define RE_SYNTAX_POSIX_MINIMAL_EXTENDED \
+ (_RE_SYNTAX_POSIX_COMMON | RE_CONTEXT_INDEP_ANCHORS \
+ | RE_CONTEXT_INVALID_OPS | RE_NO_BK_BRACES \
+ | RE_NO_BK_PARENS | RE_NO_BK_REFS \
+ | RE_NO_BK_VBAR | RE_UNMATCHED_RIGHT_PAREN_ORD)
+/* [[[end syntaxes]]] */
+
+/* Maximum number of duplicates an interval can allow. POSIX-conforming
+ systems might define this in <limits.h>, but we want our
+ value, so remove any previous define. */
+# ifdef _REGEX_INCLUDE_LIMITS_H
+# include <limits.h>
+# endif
+# ifdef RE_DUP_MAX
+# undef RE_DUP_MAX
+# endif
+
+/* RE_DUP_MAX is 2**15 - 1 because an earlier implementation stored
+ the counter as a 2-byte signed integer. This is no longer true, so
+ RE_DUP_MAX could be increased to (INT_MAX / 10 - 1), or to
+ ((SIZE_MAX - 9) / 10) if _REGEX_LARGE_OFFSETS is defined.
+ However, there would be a huge performance problem if someone
+ actually used a pattern like a\{214748363\}, so RE_DUP_MAX retains
+ its historical value. */
+# define RE_DUP_MAX (0x7fff)
+#endif
+
+
+/* POSIX 'cflags' bits (i.e., information for 'regcomp'). */
+
+/* If this bit is set, then use extended regular expression syntax.
+ If not set, then use basic regular expression syntax. */
+#define REG_EXTENDED 1
+
+/* If this bit is set, then ignore case when matching.
+ If not set, then case is significant. */
+#define REG_ICASE (1 << 1)
+
+/* If this bit is set, then anchors do not match at newline
+ characters in the string.
+ If not set, then anchors do match at newlines. */
+#define REG_NEWLINE (1 << 2)
+
+/* If this bit is set, then report only success or fail in regexec.
+ If not set, then returns differ between not matching and errors. */
+#define REG_NOSUB (1 << 3)
+
+
+/* POSIX 'eflags' bits (i.e., information for regexec). */
+
+/* If this bit is set, then the beginning-of-line operator doesn't match
+ the beginning of the string (presumably because it's not the
+ beginning of a line).
+ If not set, then the beginning-of-line operator does match the
+ beginning of the string. */
+#define REG_NOTBOL 1
+
+/* Like REG_NOTBOL, except for the end-of-line. */
+#define REG_NOTEOL (1 << 1)
+
+/* Use PMATCH[0] to delimit the start and end of the search in the
+ buffer. */
+#define REG_STARTEND (1 << 2)
+
+
+/* If any error codes are removed, changed, or added, update the
+ '__re_error_msgid' table in regcomp.c. */
+
+typedef enum
+{
+ _REG_ENOSYS = -1, /* This will never happen for this implementation. */
+ _REG_NOERROR = 0, /* Success. */
+ _REG_NOMATCH, /* Didn't find a match (for regexec). */
+
+ /* POSIX regcomp return error codes. (In the order listed in the
+ standard.) */
+ _REG_BADPAT, /* Invalid pattern. */
+ _REG_ECOLLATE, /* Invalid collating element. */
+ _REG_ECTYPE, /* Invalid character class name. */
+ _REG_EESCAPE, /* Trailing backslash. */
+ _REG_ESUBREG, /* Invalid back reference. */
+ _REG_EBRACK, /* Unmatched left bracket. */
+ _REG_EPAREN, /* Parenthesis imbalance. */
+ _REG_EBRACE, /* Unmatched \{. */
+ _REG_BADBR, /* Invalid contents of \{\}. */
+ _REG_ERANGE, /* Invalid range end. */
+ _REG_ESPACE, /* Ran out of memory. */
+ _REG_BADRPT, /* No preceding re for repetition op. */
+
+ /* Error codes we've added. */
+ _REG_EEND, /* Premature end. */
+ _REG_ESIZE, /* Too large (e.g., repeat count too large). */
+ _REG_ERPAREN /* Unmatched ) or \); not returned from regcomp. */
+} reg_errcode_t;
+
+#if defined _XOPEN_SOURCE || defined __USE_XOPEN2K
+# define REG_ENOSYS _REG_ENOSYS
+#endif
+#define REG_NOERROR _REG_NOERROR
+#define REG_NOMATCH _REG_NOMATCH
+#define REG_BADPAT _REG_BADPAT
+#define REG_ECOLLATE _REG_ECOLLATE
+#define REG_ECTYPE _REG_ECTYPE
+#define REG_EESCAPE _REG_EESCAPE
+#define REG_ESUBREG _REG_ESUBREG
+#define REG_EBRACK _REG_EBRACK
+#define REG_EPAREN _REG_EPAREN
+#define REG_EBRACE _REG_EBRACE
+#define REG_BADBR _REG_BADBR
+#define REG_ERANGE _REG_ERANGE
+#define REG_ESPACE _REG_ESPACE
+#define REG_BADRPT _REG_BADRPT
+#define REG_EEND _REG_EEND
+#define REG_ESIZE _REG_ESIZE
+#define REG_ERPAREN _REG_ERPAREN
+
+/* This data structure represents a compiled pattern. Before calling
+ the pattern compiler, the fields 'buffer', 'allocated', 'fastmap',
+ and 'translate' can be set. After the pattern has been compiled,
+ the fields 're_nsub', 'not_bol' and 'not_eol' are available. All
+ other fields are private to the regex routines. */
+
+#ifndef RE_TRANSLATE_TYPE
+# define __RE_TRANSLATE_TYPE unsigned char *
+# ifdef __USE_GNU
+# define RE_TRANSLATE_TYPE __RE_TRANSLATE_TYPE
+# endif
+#endif
+
+#ifdef __USE_GNU
+# define __REPB_PREFIX(name) name
+#else
+# define __REPB_PREFIX(name) __##name
+#endif
+
+struct re_pattern_buffer
+{
+ /* Space that holds the compiled pattern. The type
+ 'struct re_dfa_t' is private and is not declared here. */
+ struct re_dfa_t *__REPB_PREFIX(buffer);
+
+ /* Number of bytes to which 'buffer' points. */
+ __re_long_size_t __REPB_PREFIX(allocated);
+
+ /* Number of bytes actually used in 'buffer'. */
+ __re_long_size_t __REPB_PREFIX(used);
+
+ /* Syntax setting with which the pattern was compiled. */
+ reg_syntax_t __REPB_PREFIX(syntax);
+
+ /* Pointer to a fastmap, if any, otherwise zero. re_search uses the
+ fastmap, if there is one, to skip over impossible starting points
+ for matches. */
+ char *__REPB_PREFIX(fastmap);
+
+ /* Either a translate table to apply to all characters before
+ comparing them, or zero for no translation. The translation is
+ applied to a pattern when it is compiled and to a string when it
+ is matched. */
+ __RE_TRANSLATE_TYPE __REPB_PREFIX(translate);
+
+ /* Number of subexpressions found by the compiler. */
+ size_t re_nsub;
+
+ /* Zero if this pattern cannot match the empty string, one else.
+ Well, in truth it's used only in 're_search_2', to see whether or
+ not we should use the fastmap, so we don't set this absolutely
+ perfectly; see 're_compile_fastmap' (the "duplicate" case). */
+ unsigned __REPB_PREFIX(can_be_null) : 1;
+
+ /* If REGS_UNALLOCATED, allocate space in the 'regs' structure
+ for 'max (RE_NREGS, re_nsub + 1)' groups.
+ If REGS_REALLOCATE, reallocate space if necessary.
+ If REGS_FIXED, use what's there. */
+#ifdef __USE_GNU
+# define REGS_UNALLOCATED 0
+# define REGS_REALLOCATE 1
+# define REGS_FIXED 2
+#endif
+ unsigned __REPB_PREFIX(regs_allocated) : 2;
+
+ /* Set to zero when 're_compile_pattern' compiles a pattern; set to
+ one by 're_compile_fastmap' if it updates the fastmap. */
+ unsigned __REPB_PREFIX(fastmap_accurate) : 1;
+
+ /* If set, 're_match_2' does not return information about
+ subexpressions. */
+ unsigned __REPB_PREFIX(no_sub) : 1;
+
+ /* If set, a beginning-of-line anchor doesn't match at the beginning
+ of the string. */
+ unsigned __REPB_PREFIX(not_bol) : 1;
+
+ /* Similarly for an end-of-line anchor. */
+ unsigned __REPB_PREFIX(not_eol) : 1;
+
+ /* If true, an anchor at a newline matches. */
+ unsigned __REPB_PREFIX(newline_anchor) : 1;
+};
+
+typedef struct re_pattern_buffer regex_t;
+
+/* Type for byte offsets within the string. POSIX mandates this. */
+#ifdef _REGEX_LARGE_OFFSETS
+/* POSIX 1003.1-2008 requires that regoff_t be at least as wide as
+ ptrdiff_t and ssize_t. We don't know of any hosts where ptrdiff_t
+ is wider than ssize_t, so ssize_t is safe. ptrdiff_t is not
+ visible here, so use ssize_t. */
+typedef ssize_t regoff_t;
+#else
+/* The traditional GNU regex implementation mishandles strings longer
+ than INT_MAX. */
+typedef int regoff_t;
+#endif
+
+
+#ifdef __USE_GNU
+/* This is the structure we store register match data in. See
+ regex.texinfo for a full description of what registers match. */
+struct re_registers
+{
+ __re_size_t num_regs;
+ regoff_t *start;
+ regoff_t *end;
+};
+
+
+/* If 'regs_allocated' is REGS_UNALLOCATED in the pattern buffer,
+ 're_match_2' returns information about at least this many registers
+ the first time a 'regs' structure is passed. */
+# ifndef RE_NREGS
+# define RE_NREGS 30
+# endif
+#endif
+
+
+/* POSIX specification for registers. Aside from the different names than
+ 're_registers', POSIX uses an array of structures, instead of a
+ structure of arrays. */
+typedef struct
+{
+ regoff_t rm_so; /* Byte offset from string's start to substring's start. */
+ regoff_t rm_eo; /* Byte offset from string's start to substring's end. */
+} regmatch_t;
+
+/* Declarations for routines. */
+
+#ifdef __USE_GNU
+/* Sets the current default syntax to SYNTAX, and return the old syntax.
+ You can also simply assign to the 're_syntax_options' variable. */
+extern reg_syntax_t re_set_syntax (reg_syntax_t __syntax);
+
+/* Compile the regular expression PATTERN, with length LENGTH
+ and syntax given by the global 're_syntax_options', into the buffer
+ BUFFER. Return NULL if successful, and an error string if not.
+
+ To free the allocated storage, you must call 'regfree' on BUFFER.
+ Note that the translate table must either have been initialized by
+ 'regcomp', with a malloc'ed value, or set to NULL before calling
+ 'regfree'. */
+extern const char *re_compile_pattern (const char *__pattern, size_t __length,
+ struct re_pattern_buffer *__buffer);
+
+
+/* Compile a fastmap for the compiled pattern in BUFFER; used to
+ accelerate searches. Return 0 if successful and -2 if was an
+ internal error. */
+extern int re_compile_fastmap (struct re_pattern_buffer *__buffer);
+
+
+/* Search in the string STRING (with length LENGTH) for the pattern
+ compiled into BUFFER. Start searching at position START, for RANGE
+ characters. Return the starting position of the match, -1 for no
+ match, or -2 for an internal error. Also return register
+ information in REGS (if REGS and BUFFER->no_sub are nonzero). */
+extern regoff_t re_search (struct re_pattern_buffer *__buffer,
+ const char *__String, regoff_t __length,
+ regoff_t __start, regoff_t __range,
+ struct re_registers *__regs);
+
+
+/* Like 're_search', but search in the concatenation of STRING1 and
+ STRING2. Also, stop searching at index START + STOP. */
+extern regoff_t re_search_2 (struct re_pattern_buffer *__buffer,
+ const char *__string1, regoff_t __length1,
+ const char *__string2, regoff_t __length2,
+ regoff_t __start, regoff_t __range,
+ struct re_registers *__regs,
+ regoff_t __stop);
+
+
+/* Like 're_search', but return how many characters in STRING the regexp
+ in BUFFER matched, starting at position START. */
+extern regoff_t re_match (struct re_pattern_buffer *__buffer,
+ const char *__String, regoff_t __length,
+ regoff_t __start, struct re_registers *__regs);
+
+
+/* Relates to 're_match' as 're_search_2' relates to 're_search'. */
+extern regoff_t re_match_2 (struct re_pattern_buffer *__buffer,
+ const char *__string1, regoff_t __length1,
+ const char *__string2, regoff_t __length2,
+ regoff_t __start, struct re_registers *__regs,
+ regoff_t __stop);
+
+
+/* Set REGS to hold NUM_REGS registers, storing them in STARTS and
+ ENDS. Subsequent matches using BUFFER and REGS will use this memory
+ for recording register information. STARTS and ENDS must be
+ allocated with malloc, and must each be at least 'NUM_REGS * sizeof
+ (regoff_t)' bytes long.
+
+ If NUM_REGS == 0, then subsequent matches should allocate their own
+ register data.
+
+ Unless this function is called, the first search or match using
+ BUFFER will allocate its own register data, without
+ freeing the old data. */
+extern void re_set_registers (struct re_pattern_buffer *__buffer,
+ struct re_registers *__regs,
+ __re_size_t __num_regs,
+ regoff_t *__starts, regoff_t *__ends);
+#endif /* Use GNU */
+
+#if defined _REGEX_RE_COMP || (defined _LIBC && defined __USE_MISC)
+# ifndef _CRAY
+/* 4.2 bsd compatibility. */
+extern char *re_comp (const char *);
+extern int re_exec (const char *);
+# endif
+#endif
+
+/* For plain 'restrict', use glibc's __restrict if defined.
+ Otherwise, GCC 2.95 and later have "__restrict"; C99 compilers have
+ "restrict", and "configure" may have defined "restrict".
+ Other compilers use __restrict, __restrict__, and _Restrict, and
+ 'configure' might #define 'restrict' to those words, so pick a
+ different name. */
+#ifndef _Restrict_
+# if defined __restrict || 2 < __GNUC__ + (95 <= __GNUC_MINOR__)
+# define _Restrict_ __restrict
+# elif 199901L <= __STDC_VERSION__ || defined restrict
+# define _Restrict_ restrict
+# else
+# define _Restrict_
+# endif
+#endif
+/* For [restrict], use glibc's __restrict_arr if available.
+ Otherwise, GCC 3.1 (not in C++ mode) and C99 support [restrict]. */
+#ifndef _Restrict_arr_
+# ifdef __restrict_arr
+# define _Restrict_arr_ __restrict_arr
+# elif ((199901L <= __STDC_VERSION__ || 3 < __GNUC__ + (1 <= __GNUC_MINOR__)) \
+ && !defined __GNUG__)
+# define _Restrict_arr_ _Restrict_
+# else
+# define _Restrict_arr_
+# endif
+#endif
+
+/* POSIX compatibility. */
+extern int regcomp (regex_t *_Restrict_ __preg,
+ const char *_Restrict_ __pattern,
+ int __cflags);
+
+extern int regexec (const regex_t *_Restrict_ __preg,
+ const char *_Restrict_ __String, size_t __nmatch,
+ regmatch_t __pmatch[_Restrict_arr_],
+ int __eflags);
+
+extern size_t regerror (int __errcode, const regex_t *_Restrict_ __preg,
+ char *_Restrict_ __errbuf, size_t __errbuf_size);
+
+extern void regfree (regex_t *__preg);
+
+
+#ifdef __cplusplus
+}
+#endif /* C++ */
+
+#endif /* regex.h */
diff --git a/lib/regex_internal.c b/lib/regex_internal.c
new file mode 100644
index 00000000000..b592f06725c
--- /dev/null
+++ b/lib/regex_internal.c
@@ -0,0 +1,1746 @@
+/* Extended regular expression matching and search library.
+ Copyright (C) 2002-2019 Free Software Foundation, Inc.
+ This file is part of the GNU C Library.
+ Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>.
+
+ 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
+ <https://www.gnu.org/licenses/>. */
+
+static void re_string_construct_common (const char *str, Idx len,
+ re_string_t *pstr,
+ RE_TRANSLATE_TYPE trans, bool icase,
+ const re_dfa_t *dfa);
+static re_dfastate_t *create_ci_newstate (const re_dfa_t *dfa,
+ const re_node_set *nodes,
+ re_hashval_t hash);
+static re_dfastate_t *create_cd_newstate (const re_dfa_t *dfa,
+ const re_node_set *nodes,
+ unsigned int context,
+ re_hashval_t hash);
+static reg_errcode_t re_string_realloc_buffers (re_string_t *pstr,
+ Idx new_buf_len);
+#ifdef RE_ENABLE_I18N
+static void build_wcs_buffer (re_string_t *pstr);
+static reg_errcode_t build_wcs_upper_buffer (re_string_t *pstr);
+#endif /* RE_ENABLE_I18N */
+static void build_upper_buffer (re_string_t *pstr);
+static void re_string_translate_buffer (re_string_t *pstr);
+static unsigned int re_string_context_at (const re_string_t *input, Idx idx,
+ int eflags) __attribute__ ((pure));
+
+/* Functions for string operation. */
+
+/* This function allocate the buffers. It is necessary to call
+ re_string_reconstruct before using the object. */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+re_string_allocate (re_string_t *pstr, const char *str, Idx len, Idx init_len,
+ RE_TRANSLATE_TYPE trans, bool icase, const re_dfa_t *dfa)
+{
+ reg_errcode_t ret;
+ Idx init_buf_len;
+
+ /* Ensure at least one character fits into the buffers. */
+ if (init_len < dfa->mb_cur_max)
+ init_len = dfa->mb_cur_max;
+ init_buf_len = (len + 1 < init_len) ? len + 1: init_len;
+ re_string_construct_common (str, len, pstr, trans, icase, dfa);
+
+ ret = re_string_realloc_buffers (pstr, init_buf_len);
+ if (__glibc_unlikely (ret != REG_NOERROR))
+ return ret;
+
+ pstr->word_char = dfa->word_char;
+ pstr->word_ops_used = dfa->word_ops_used;
+ pstr->mbs = pstr->mbs_allocated ? pstr->mbs : (unsigned char *) str;
+ pstr->valid_len = (pstr->mbs_allocated || dfa->mb_cur_max > 1) ? 0 : len;
+ pstr->valid_raw_len = pstr->valid_len;
+ return REG_NOERROR;
+}
+
+/* This function allocate the buffers, and initialize them. */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+re_string_construct (re_string_t *pstr, const char *str, Idx len,
+ RE_TRANSLATE_TYPE trans, bool icase, const re_dfa_t *dfa)
+{
+ reg_errcode_t ret;
+ memset (pstr, '\0', sizeof (re_string_t));
+ re_string_construct_common (str, len, pstr, trans, icase, dfa);
+
+ if (len > 0)
+ {
+ ret = re_string_realloc_buffers (pstr, len + 1);
+ if (__glibc_unlikely (ret != REG_NOERROR))
+ return ret;
+ }
+ pstr->mbs = pstr->mbs_allocated ? pstr->mbs : (unsigned char *) str;
+
+ if (icase)
+ {
+#ifdef RE_ENABLE_I18N
+ if (dfa->mb_cur_max > 1)
+ {
+ while (1)
+ {
+ ret = build_wcs_upper_buffer (pstr);
+ if (__glibc_unlikely (ret != REG_NOERROR))
+ return ret;
+ if (pstr->valid_raw_len >= len)
+ break;
+ if (pstr->bufs_len > pstr->valid_len + dfa->mb_cur_max)
+ break;
+ ret = re_string_realloc_buffers (pstr, pstr->bufs_len * 2);
+ if (__glibc_unlikely (ret != REG_NOERROR))
+ return ret;
+ }
+ }
+ else
+#endif /* RE_ENABLE_I18N */
+ build_upper_buffer (pstr);
+ }
+ else
+ {
+#ifdef RE_ENABLE_I18N
+ if (dfa->mb_cur_max > 1)
+ build_wcs_buffer (pstr);
+ else
+#endif /* RE_ENABLE_I18N */
+ {
+ if (trans != NULL)
+ re_string_translate_buffer (pstr);
+ else
+ {
+ pstr->valid_len = pstr->bufs_len;
+ pstr->valid_raw_len = pstr->bufs_len;
+ }
+ }
+ }
+
+ return REG_NOERROR;
+}
+
+/* Helper functions for re_string_allocate, and re_string_construct. */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+re_string_realloc_buffers (re_string_t *pstr, Idx new_buf_len)
+{
+#ifdef RE_ENABLE_I18N
+ if (pstr->mb_cur_max > 1)
+ {
+ wint_t *new_wcs;
+
+ /* Avoid overflow in realloc. */
+ const size_t max_object_size = MAX (sizeof (wint_t), sizeof (Idx));
+ if (__glibc_unlikely (MIN (IDX_MAX, SIZE_MAX / max_object_size)
+ < new_buf_len))
+ return REG_ESPACE;
+
+ new_wcs = re_realloc (pstr->wcs, wint_t, new_buf_len);
+ if (__glibc_unlikely (new_wcs == NULL))
+ return REG_ESPACE;
+ pstr->wcs = new_wcs;
+ if (pstr->offsets != NULL)
+ {
+ Idx *new_offsets = re_realloc (pstr->offsets, Idx, new_buf_len);
+ if (__glibc_unlikely (new_offsets == NULL))
+ return REG_ESPACE;
+ pstr->offsets = new_offsets;
+ }
+ }
+#endif /* RE_ENABLE_I18N */
+ if (pstr->mbs_allocated)
+ {
+ unsigned char *new_mbs = re_realloc (pstr->mbs, unsigned char,
+ new_buf_len);
+ if (__glibc_unlikely (new_mbs == NULL))
+ return REG_ESPACE;
+ pstr->mbs = new_mbs;
+ }
+ pstr->bufs_len = new_buf_len;
+ return REG_NOERROR;
+}
+
+
+static void
+re_string_construct_common (const char *str, Idx len, re_string_t *pstr,
+ RE_TRANSLATE_TYPE trans, bool icase,
+ const re_dfa_t *dfa)
+{
+ pstr->raw_mbs = (const unsigned char *) str;
+ pstr->len = len;
+ pstr->raw_len = len;
+ pstr->trans = trans;
+ pstr->icase = icase;
+ pstr->mbs_allocated = (trans != NULL || icase);
+ pstr->mb_cur_max = dfa->mb_cur_max;
+ pstr->is_utf8 = dfa->is_utf8;
+ pstr->map_notascii = dfa->map_notascii;
+ pstr->stop = pstr->len;
+ pstr->raw_stop = pstr->stop;
+}
+
+#ifdef RE_ENABLE_I18N
+
+/* Build wide character buffer PSTR->WCS.
+ If the byte sequence of the string are:
+ <mb1>(0), <mb1>(1), <mb2>(0), <mb2>(1), <sb3>
+ Then wide character buffer will be:
+ <wc1> , WEOF , <wc2> , WEOF , <wc3>
+ We use WEOF for padding, they indicate that the position isn't
+ a first byte of a multibyte character.
+
+ Note that this function assumes PSTR->VALID_LEN elements are already
+ built and starts from PSTR->VALID_LEN. */
+
+static void
+build_wcs_buffer (re_string_t *pstr)
+{
+#ifdef _LIBC
+ unsigned char buf[MB_LEN_MAX];
+ assert (MB_LEN_MAX >= pstr->mb_cur_max);
+#else
+ unsigned char buf[64];
+#endif
+ mbstate_t prev_st;
+ Idx byte_idx, end_idx, remain_len;
+ size_t mbclen;
+
+ /* Build the buffers from pstr->valid_len to either pstr->len or
+ pstr->bufs_len. */
+ end_idx = (pstr->bufs_len > pstr->len) ? pstr->len : pstr->bufs_len;
+ for (byte_idx = pstr->valid_len; byte_idx < end_idx;)
+ {
+ wchar_t wc;
+ const char *p;
+
+ remain_len = end_idx - byte_idx;
+ prev_st = pstr->cur_state;
+ /* Apply the translation if we need. */
+ if (__glibc_unlikely (pstr->trans != NULL))
+ {
+ int i, ch;
+
+ for (i = 0; i < pstr->mb_cur_max && i < remain_len; ++i)
+ {
+ ch = pstr->raw_mbs [pstr->raw_mbs_idx + byte_idx + i];
+ buf[i] = pstr->mbs[byte_idx + i] = pstr->trans[ch];
+ }
+ p = (const char *) buf;
+ }
+ else
+ p = (const char *) pstr->raw_mbs + pstr->raw_mbs_idx + byte_idx;
+ mbclen = __mbrtowc (&wc, p, remain_len, &pstr->cur_state);
+ if (__glibc_unlikely (mbclen == (size_t) -1 || mbclen == 0
+ || (mbclen == (size_t) -2
+ && pstr->bufs_len >= pstr->len)))
+ {
+ /* We treat these cases as a singlebyte character. */
+ mbclen = 1;
+ wc = (wchar_t) pstr->raw_mbs[pstr->raw_mbs_idx + byte_idx];
+ if (__glibc_unlikely (pstr->trans != NULL))
+ wc = pstr->trans[wc];
+ pstr->cur_state = prev_st;
+ }
+ else if (__glibc_unlikely (mbclen == (size_t) -2))
+ {
+ /* The buffer doesn't have enough space, finish to build. */
+ pstr->cur_state = prev_st;
+ break;
+ }
+
+ /* Write wide character and padding. */
+ pstr->wcs[byte_idx++] = wc;
+ /* Write paddings. */
+ for (remain_len = byte_idx + mbclen - 1; byte_idx < remain_len ;)
+ pstr->wcs[byte_idx++] = WEOF;
+ }
+ pstr->valid_len = byte_idx;
+ pstr->valid_raw_len = byte_idx;
+}
+
+/* Build wide character buffer PSTR->WCS like build_wcs_buffer,
+ but for REG_ICASE. */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+build_wcs_upper_buffer (re_string_t *pstr)
+{
+ mbstate_t prev_st;
+ Idx src_idx, byte_idx, end_idx, remain_len;
+ size_t mbclen;
+#ifdef _LIBC
+ char buf[MB_LEN_MAX];
+ assert (MB_LEN_MAX >= pstr->mb_cur_max);
+#else
+ char buf[64];
+#endif
+
+ byte_idx = pstr->valid_len;
+ end_idx = (pstr->bufs_len > pstr->len) ? pstr->len : pstr->bufs_len;
+
+ /* The following optimization assumes that ASCII characters can be
+ mapped to wide characters with a simple cast. */
+ if (! pstr->map_notascii && pstr->trans == NULL && !pstr->offsets_needed)
+ {
+ while (byte_idx < end_idx)
+ {
+ wchar_t wc;
+
+ if (isascii (pstr->raw_mbs[pstr->raw_mbs_idx + byte_idx])
+ && mbsinit (&pstr->cur_state))
+ {
+ /* In case of a singlebyte character. */
+ pstr->mbs[byte_idx]
+ = toupper (pstr->raw_mbs[pstr->raw_mbs_idx + byte_idx]);
+ /* The next step uses the assumption that wchar_t is encoded
+ ASCII-safe: all ASCII values can be converted like this. */
+ pstr->wcs[byte_idx] = (wchar_t) pstr->mbs[byte_idx];
+ ++byte_idx;
+ continue;
+ }
+
+ remain_len = end_idx - byte_idx;
+ prev_st = pstr->cur_state;
+ mbclen = __mbrtowc (&wc,
+ ((const char *) pstr->raw_mbs + pstr->raw_mbs_idx
+ + byte_idx), remain_len, &pstr->cur_state);
+ if (__glibc_likely (0 < mbclen && mbclen < (size_t) -2))
+ {
+ wchar_t wcu = __towupper (wc);
+ if (wcu != wc)
+ {
+ size_t mbcdlen;
+
+ mbcdlen = __wcrtomb (buf, wcu, &prev_st);
+ if (__glibc_likely (mbclen == mbcdlen))
+ memcpy (pstr->mbs + byte_idx, buf, mbclen);
+ else
+ {
+ src_idx = byte_idx;
+ goto offsets_needed;
+ }
+ }
+ else
+ memcpy (pstr->mbs + byte_idx,
+ pstr->raw_mbs + pstr->raw_mbs_idx + byte_idx, mbclen);
+ pstr->wcs[byte_idx++] = wcu;
+ /* Write paddings. */
+ for (remain_len = byte_idx + mbclen - 1; byte_idx < remain_len ;)
+ pstr->wcs[byte_idx++] = WEOF;
+ }
+ else if (mbclen == (size_t) -1 || mbclen == 0
+ || (mbclen == (size_t) -2 && pstr->bufs_len >= pstr->len))
+ {
+ /* It is an invalid character, an incomplete character
+ at the end of the string, or '\0'. Just use the byte. */
+ int ch = pstr->raw_mbs[pstr->raw_mbs_idx + byte_idx];
+ pstr->mbs[byte_idx] = ch;
+ /* And also cast it to wide char. */
+ pstr->wcs[byte_idx++] = (wchar_t) ch;
+ if (__glibc_unlikely (mbclen == (size_t) -1))
+ pstr->cur_state = prev_st;
+ }
+ else
+ {
+ /* The buffer doesn't have enough space, finish to build. */
+ pstr->cur_state = prev_st;
+ break;
+ }
+ }
+ pstr->valid_len = byte_idx;
+ pstr->valid_raw_len = byte_idx;
+ return REG_NOERROR;
+ }
+ else
+ for (src_idx = pstr->valid_raw_len; byte_idx < end_idx;)
+ {
+ wchar_t wc;
+ const char *p;
+ offsets_needed:
+ remain_len = end_idx - byte_idx;
+ prev_st = pstr->cur_state;
+ if (__glibc_unlikely (pstr->trans != NULL))
+ {
+ int i, ch;
+
+ for (i = 0; i < pstr->mb_cur_max && i < remain_len; ++i)
+ {
+ ch = pstr->raw_mbs [pstr->raw_mbs_idx + src_idx + i];
+ buf[i] = pstr->trans[ch];
+ }
+ p = (const char *) buf;
+ }
+ else
+ p = (const char *) pstr->raw_mbs + pstr->raw_mbs_idx + src_idx;
+ mbclen = __mbrtowc (&wc, p, remain_len, &pstr->cur_state);
+ if (__glibc_likely (0 < mbclen && mbclen < (size_t) -2))
+ {
+ wchar_t wcu = __towupper (wc);
+ if (wcu != wc)
+ {
+ size_t mbcdlen;
+
+ mbcdlen = __wcrtomb ((char *) buf, wcu, &prev_st);
+ if (__glibc_likely (mbclen == mbcdlen))
+ memcpy (pstr->mbs + byte_idx, buf, mbclen);
+ else if (mbcdlen != (size_t) -1)
+ {
+ size_t i;
+
+ if (byte_idx + mbcdlen > pstr->bufs_len)
+ {
+ pstr->cur_state = prev_st;
+ break;
+ }
+
+ if (pstr->offsets == NULL)
+ {
+ pstr->offsets = re_malloc (Idx, pstr->bufs_len);
+
+ if (pstr->offsets == NULL)
+ return REG_ESPACE;
+ }
+ if (!pstr->offsets_needed)
+ {
+ for (i = 0; i < (size_t) byte_idx; ++i)
+ pstr->offsets[i] = i;
+ pstr->offsets_needed = 1;
+ }
+
+ memcpy (pstr->mbs + byte_idx, buf, mbcdlen);
+ pstr->wcs[byte_idx] = wcu;
+ pstr->offsets[byte_idx] = src_idx;
+ for (i = 1; i < mbcdlen; ++i)
+ {
+ pstr->offsets[byte_idx + i]
+ = src_idx + (i < mbclen ? i : mbclen - 1);
+ pstr->wcs[byte_idx + i] = WEOF;
+ }
+ pstr->len += mbcdlen - mbclen;
+ if (pstr->raw_stop > src_idx)
+ pstr->stop += mbcdlen - mbclen;
+ end_idx = (pstr->bufs_len > pstr->len)
+ ? pstr->len : pstr->bufs_len;
+ byte_idx += mbcdlen;
+ src_idx += mbclen;
+ continue;
+ }
+ else
+ memcpy (pstr->mbs + byte_idx, p, mbclen);
+ }
+ else
+ memcpy (pstr->mbs + byte_idx, p, mbclen);
+
+ if (__glibc_unlikely (pstr->offsets_needed != 0))
+ {
+ size_t i;
+ for (i = 0; i < mbclen; ++i)
+ pstr->offsets[byte_idx + i] = src_idx + i;
+ }
+ src_idx += mbclen;
+
+ pstr->wcs[byte_idx++] = wcu;
+ /* Write paddings. */
+ for (remain_len = byte_idx + mbclen - 1; byte_idx < remain_len ;)
+ pstr->wcs[byte_idx++] = WEOF;
+ }
+ else if (mbclen == (size_t) -1 || mbclen == 0
+ || (mbclen == (size_t) -2 && pstr->bufs_len >= pstr->len))
+ {
+ /* It is an invalid character or '\0'. Just use the byte. */
+ int ch = pstr->raw_mbs[pstr->raw_mbs_idx + src_idx];
+
+ if (__glibc_unlikely (pstr->trans != NULL))
+ ch = pstr->trans [ch];
+ pstr->mbs[byte_idx] = ch;
+
+ if (__glibc_unlikely (pstr->offsets_needed != 0))
+ pstr->offsets[byte_idx] = src_idx;
+ ++src_idx;
+
+ /* And also cast it to wide char. */
+ pstr->wcs[byte_idx++] = (wchar_t) ch;
+ if (__glibc_unlikely (mbclen == (size_t) -1))
+ pstr->cur_state = prev_st;
+ }
+ else
+ {
+ /* The buffer doesn't have enough space, finish to build. */
+ pstr->cur_state = prev_st;
+ break;
+ }
+ }
+ pstr->valid_len = byte_idx;
+ pstr->valid_raw_len = src_idx;
+ return REG_NOERROR;
+}
+
+/* Skip characters until the index becomes greater than NEW_RAW_IDX.
+ Return the index. */
+
+static Idx
+re_string_skip_chars (re_string_t *pstr, Idx new_raw_idx, wint_t *last_wc)
+{
+ mbstate_t prev_st;
+ Idx rawbuf_idx;
+ size_t mbclen;
+ wint_t wc = WEOF;
+
+ /* Skip the characters which are not necessary to check. */
+ for (rawbuf_idx = pstr->raw_mbs_idx + pstr->valid_raw_len;
+ rawbuf_idx < new_raw_idx;)
+ {
+ wchar_t wc2;
+ Idx remain_len = pstr->raw_len - rawbuf_idx;
+ prev_st = pstr->cur_state;
+ mbclen = __mbrtowc (&wc2, (const char *) pstr->raw_mbs + rawbuf_idx,
+ remain_len, &pstr->cur_state);
+ if (__glibc_unlikely (mbclen == (size_t) -2 || mbclen == (size_t) -1
+ || mbclen == 0))
+ {
+ /* We treat these cases as a single byte character. */
+ if (mbclen == 0 || remain_len == 0)
+ wc = L'\0';
+ else
+ wc = *(unsigned char *) (pstr->raw_mbs + rawbuf_idx);
+ mbclen = 1;
+ pstr->cur_state = prev_st;
+ }
+ else
+ wc = wc2;
+ /* Then proceed the next character. */
+ rawbuf_idx += mbclen;
+ }
+ *last_wc = wc;
+ return rawbuf_idx;
+}
+#endif /* RE_ENABLE_I18N */
+
+/* Build the buffer PSTR->MBS, and apply the translation if we need.
+ This function is used in case of REG_ICASE. */
+
+static void
+build_upper_buffer (re_string_t *pstr)
+{
+ Idx char_idx, end_idx;
+ end_idx = (pstr->bufs_len > pstr->len) ? pstr->len : pstr->bufs_len;
+
+ for (char_idx = pstr->valid_len; char_idx < end_idx; ++char_idx)
+ {
+ int ch = pstr->raw_mbs[pstr->raw_mbs_idx + char_idx];
+ if (__glibc_unlikely (pstr->trans != NULL))
+ ch = pstr->trans[ch];
+ pstr->mbs[char_idx] = toupper (ch);
+ }
+ pstr->valid_len = char_idx;
+ pstr->valid_raw_len = char_idx;
+}
+
+/* Apply TRANS to the buffer in PSTR. */
+
+static void
+re_string_translate_buffer (re_string_t *pstr)
+{
+ Idx buf_idx, end_idx;
+ end_idx = (pstr->bufs_len > pstr->len) ? pstr->len : pstr->bufs_len;
+
+ for (buf_idx = pstr->valid_len; buf_idx < end_idx; ++buf_idx)
+ {
+ int ch = pstr->raw_mbs[pstr->raw_mbs_idx + buf_idx];
+ pstr->mbs[buf_idx] = pstr->trans[ch];
+ }
+
+ pstr->valid_len = buf_idx;
+ pstr->valid_raw_len = buf_idx;
+}
+
+/* This function re-construct the buffers.
+ Concretely, convert to wide character in case of pstr->mb_cur_max > 1,
+ convert to upper case in case of REG_ICASE, apply translation. */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags)
+{
+ Idx offset;
+
+ if (__glibc_unlikely (pstr->raw_mbs_idx <= idx))
+ offset = idx - pstr->raw_mbs_idx;
+ else
+ {
+ /* Reset buffer. */
+#ifdef RE_ENABLE_I18N
+ if (pstr->mb_cur_max > 1)
+ memset (&pstr->cur_state, '\0', sizeof (mbstate_t));
+#endif /* RE_ENABLE_I18N */
+ pstr->len = pstr->raw_len;
+ pstr->stop = pstr->raw_stop;
+ pstr->valid_len = 0;
+ pstr->raw_mbs_idx = 0;
+ pstr->valid_raw_len = 0;
+ pstr->offsets_needed = 0;
+ pstr->tip_context = ((eflags & REG_NOTBOL) ? CONTEXT_BEGBUF
+ : CONTEXT_NEWLINE | CONTEXT_BEGBUF);
+ if (!pstr->mbs_allocated)
+ pstr->mbs = (unsigned char *) pstr->raw_mbs;
+ offset = idx;
+ }
+
+ if (__glibc_likely (offset != 0))
+ {
+ /* Should the already checked characters be kept? */
+ if (__glibc_likely (offset < pstr->valid_raw_len))
+ {
+ /* Yes, move them to the front of the buffer. */
+#ifdef RE_ENABLE_I18N
+ if (__glibc_unlikely (pstr->offsets_needed))
+ {
+ Idx low = 0, high = pstr->valid_len, mid;
+ do
+ {
+ mid = (high + low) / 2;
+ if (pstr->offsets[mid] > offset)
+ high = mid;
+ else if (pstr->offsets[mid] < offset)
+ low = mid + 1;
+ else
+ break;
+ }
+ while (low < high);
+ if (pstr->offsets[mid] < offset)
+ ++mid;
+ pstr->tip_context = re_string_context_at (pstr, mid - 1,
+ eflags);
+ /* This can be quite complicated, so handle specially
+ only the common and easy case where the character with
+ different length representation of lower and upper
+ case is present at or after offset. */
+ if (pstr->valid_len > offset
+ && mid == offset && pstr->offsets[mid] == offset)
+ {
+ memmove (pstr->wcs, pstr->wcs + offset,
+ (pstr->valid_len - offset) * sizeof (wint_t));
+ memmove (pstr->mbs, pstr->mbs + offset, pstr->valid_len - offset);
+ pstr->valid_len -= offset;
+ pstr->valid_raw_len -= offset;
+ for (low = 0; low < pstr->valid_len; low++)
+ pstr->offsets[low] = pstr->offsets[low + offset] - offset;
+ }
+ else
+ {
+ /* Otherwise, just find out how long the partial multibyte
+ character at offset is and fill it with WEOF/255. */
+ pstr->len = pstr->raw_len - idx + offset;
+ pstr->stop = pstr->raw_stop - idx + offset;
+ pstr->offsets_needed = 0;
+ while (mid > 0 && pstr->offsets[mid - 1] == offset)
+ --mid;
+ while (mid < pstr->valid_len)
+ if (pstr->wcs[mid] != WEOF)
+ break;
+ else
+ ++mid;
+ if (mid == pstr->valid_len)
+ pstr->valid_len = 0;
+ else
+ {
+ pstr->valid_len = pstr->offsets[mid] - offset;
+ if (pstr->valid_len)
+ {
+ for (low = 0; low < pstr->valid_len; ++low)
+ pstr->wcs[low] = WEOF;
+ memset (pstr->mbs, 255, pstr->valid_len);
+ }
+ }
+ pstr->valid_raw_len = pstr->valid_len;
+ }
+ }
+ else
+#endif
+ {
+ pstr->tip_context = re_string_context_at (pstr, offset - 1,
+ eflags);
+#ifdef RE_ENABLE_I18N
+ if (pstr->mb_cur_max > 1)
+ memmove (pstr->wcs, pstr->wcs + offset,
+ (pstr->valid_len - offset) * sizeof (wint_t));
+#endif /* RE_ENABLE_I18N */
+ if (__glibc_unlikely (pstr->mbs_allocated))
+ memmove (pstr->mbs, pstr->mbs + offset,
+ pstr->valid_len - offset);
+ pstr->valid_len -= offset;
+ pstr->valid_raw_len -= offset;
+#if defined DEBUG && DEBUG
+ assert (pstr->valid_len > 0);
+#endif
+ }
+ }
+ else
+ {
+#ifdef RE_ENABLE_I18N
+ /* No, skip all characters until IDX. */
+ Idx prev_valid_len = pstr->valid_len;
+
+ if (__glibc_unlikely (pstr->offsets_needed))
+ {
+ pstr->len = pstr->raw_len - idx + offset;
+ pstr->stop = pstr->raw_stop - idx + offset;
+ pstr->offsets_needed = 0;
+ }
+#endif
+ pstr->valid_len = 0;
+#ifdef RE_ENABLE_I18N
+ if (pstr->mb_cur_max > 1)
+ {
+ Idx wcs_idx;
+ wint_t wc = WEOF;
+
+ if (pstr->is_utf8)
+ {
+ const unsigned char *raw, *p, *end;
+
+ /* Special case UTF-8. Multi-byte chars start with any
+ byte other than 0x80 - 0xbf. */
+ raw = pstr->raw_mbs + pstr->raw_mbs_idx;
+ end = raw + (offset - pstr->mb_cur_max);
+ if (end < pstr->raw_mbs)
+ end = pstr->raw_mbs;
+ p = raw + offset - 1;
+#ifdef _LIBC
+ /* We know the wchar_t encoding is UCS4, so for the simple
+ case, ASCII characters, skip the conversion step. */
+ if (isascii (*p) && __glibc_likely (pstr->trans == NULL))
+ {
+ memset (&pstr->cur_state, '\0', sizeof (mbstate_t));
+ /* pstr->valid_len = 0; */
+ wc = (wchar_t) *p;
+ }
+ else
+#endif
+ for (; p >= end; --p)
+ if ((*p & 0xc0) != 0x80)
+ {
+ mbstate_t cur_state;
+ wchar_t wc2;
+ Idx mlen = raw + pstr->len - p;
+ unsigned char buf[6];
+ size_t mbclen;
+
+ const unsigned char *pp = p;
+ if (__glibc_unlikely (pstr->trans != NULL))
+ {
+ int i = mlen < 6 ? mlen : 6;
+ while (--i >= 0)
+ buf[i] = pstr->trans[p[i]];
+ pp = buf;
+ }
+ /* XXX Don't use mbrtowc, we know which conversion
+ to use (UTF-8 -> UCS4). */
+ memset (&cur_state, 0, sizeof (cur_state));
+ mbclen = __mbrtowc (&wc2, (const char *) pp, mlen,
+ &cur_state);
+ if (raw + offset - p <= mbclen
+ && mbclen < (size_t) -2)
+ {
+ memset (&pstr->cur_state, '\0',
+ sizeof (mbstate_t));
+ pstr->valid_len = mbclen - (raw + offset - p);
+ wc = wc2;
+ }
+ break;
+ }
+ }
+
+ if (wc == WEOF)
+ pstr->valid_len = re_string_skip_chars (pstr, idx, &wc) - idx;
+ if (wc == WEOF)
+ pstr->tip_context
+ = re_string_context_at (pstr, prev_valid_len - 1, eflags);
+ else
+ pstr->tip_context = ((__glibc_unlikely (pstr->word_ops_used != 0)
+ && IS_WIDE_WORD_CHAR (wc))
+ ? CONTEXT_WORD
+ : ((IS_WIDE_NEWLINE (wc)
+ && pstr->newline_anchor)
+ ? CONTEXT_NEWLINE : 0));
+ if (__glibc_unlikely (pstr->valid_len))
+ {
+ for (wcs_idx = 0; wcs_idx < pstr->valid_len; ++wcs_idx)
+ pstr->wcs[wcs_idx] = WEOF;
+ if (pstr->mbs_allocated)
+ memset (pstr->mbs, 255, pstr->valid_len);
+ }
+ pstr->valid_raw_len = pstr->valid_len;
+ }
+ else
+#endif /* RE_ENABLE_I18N */
+ {
+ int c = pstr->raw_mbs[pstr->raw_mbs_idx + offset - 1];
+ pstr->valid_raw_len = 0;
+ if (pstr->trans)
+ c = pstr->trans[c];
+ pstr->tip_context = (bitset_contain (pstr->word_char, c)
+ ? CONTEXT_WORD
+ : ((IS_NEWLINE (c) && pstr->newline_anchor)
+ ? CONTEXT_NEWLINE : 0));
+ }
+ }
+ if (!__glibc_unlikely (pstr->mbs_allocated))
+ pstr->mbs += offset;
+ }
+ pstr->raw_mbs_idx = idx;
+ pstr->len -= offset;
+ pstr->stop -= offset;
+
+ /* Then build the buffers. */
+#ifdef RE_ENABLE_I18N
+ if (pstr->mb_cur_max > 1)
+ {
+ if (pstr->icase)
+ {
+ reg_errcode_t ret = build_wcs_upper_buffer (pstr);
+ if (__glibc_unlikely (ret != REG_NOERROR))
+ return ret;
+ }
+ else
+ build_wcs_buffer (pstr);
+ }
+ else
+#endif /* RE_ENABLE_I18N */
+ if (__glibc_unlikely (pstr->mbs_allocated))
+ {
+ if (pstr->icase)
+ build_upper_buffer (pstr);
+ else if (pstr->trans != NULL)
+ re_string_translate_buffer (pstr);
+ }
+ else
+ pstr->valid_len = pstr->len;
+
+ pstr->cur_idx = 0;
+ return REG_NOERROR;
+}
+
+static unsigned char
+__attribute__ ((pure))
+re_string_peek_byte_case (const re_string_t *pstr, Idx idx)
+{
+ int ch;
+ Idx off;
+
+ /* Handle the common (easiest) cases first. */
+ if (__glibc_likely (!pstr->mbs_allocated))
+ return re_string_peek_byte (pstr, idx);
+
+#ifdef RE_ENABLE_I18N
+ if (pstr->mb_cur_max > 1
+ && ! re_string_is_single_byte_char (pstr, pstr->cur_idx + idx))
+ return re_string_peek_byte (pstr, idx);
+#endif
+
+ off = pstr->cur_idx + idx;
+#ifdef RE_ENABLE_I18N
+ if (pstr->offsets_needed)
+ off = pstr->offsets[off];
+#endif
+
+ ch = pstr->raw_mbs[pstr->raw_mbs_idx + off];
+
+#ifdef RE_ENABLE_I18N
+ /* Ensure that e.g. for tr_TR.UTF-8 BACKSLASH DOTLESS SMALL LETTER I
+ this function returns CAPITAL LETTER I instead of first byte of
+ DOTLESS SMALL LETTER I. The latter would confuse the parser,
+ since peek_byte_case doesn't advance cur_idx in any way. */
+ if (pstr->offsets_needed && !isascii (ch))
+ return re_string_peek_byte (pstr, idx);
+#endif
+
+ return ch;
+}
+
+static unsigned char
+re_string_fetch_byte_case (re_string_t *pstr)
+{
+ if (__glibc_likely (!pstr->mbs_allocated))
+ return re_string_fetch_byte (pstr);
+
+#ifdef RE_ENABLE_I18N
+ if (pstr->offsets_needed)
+ {
+ Idx off;
+ int ch;
+
+ /* For tr_TR.UTF-8 [[:islower:]] there is
+ [[: CAPITAL LETTER I WITH DOT lower:]] in mbs. Skip
+ in that case the whole multi-byte character and return
+ the original letter. On the other side, with
+ [[: DOTLESS SMALL LETTER I return [[:I, as doing
+ anything else would complicate things too much. */
+
+ if (!re_string_first_byte (pstr, pstr->cur_idx))
+ return re_string_fetch_byte (pstr);
+
+ off = pstr->offsets[pstr->cur_idx];
+ ch = pstr->raw_mbs[pstr->raw_mbs_idx + off];
+
+ if (! isascii (ch))
+ return re_string_fetch_byte (pstr);
+
+ re_string_skip_bytes (pstr,
+ re_string_char_size_at (pstr, pstr->cur_idx));
+ return ch;
+ }
+#endif
+
+ return pstr->raw_mbs[pstr->raw_mbs_idx + pstr->cur_idx++];
+}
+
+static void
+re_string_destruct (re_string_t *pstr)
+{
+#ifdef RE_ENABLE_I18N
+ re_free (pstr->wcs);
+ re_free (pstr->offsets);
+#endif /* RE_ENABLE_I18N */
+ if (pstr->mbs_allocated)
+ re_free (pstr->mbs);
+}
+
+/* Return the context at IDX in INPUT. */
+
+static unsigned int
+re_string_context_at (const re_string_t *input, Idx idx, int eflags)
+{
+ int c;
+ if (__glibc_unlikely (idx < 0))
+ /* In this case, we use the value stored in input->tip_context,
+ since we can't know the character in input->mbs[-1] here. */
+ return input->tip_context;
+ if (__glibc_unlikely (idx == input->len))
+ return ((eflags & REG_NOTEOL) ? CONTEXT_ENDBUF
+ : CONTEXT_NEWLINE | CONTEXT_ENDBUF);
+#ifdef RE_ENABLE_I18N
+ if (input->mb_cur_max > 1)
+ {
+ wint_t wc;
+ Idx wc_idx = idx;
+ while(input->wcs[wc_idx] == WEOF)
+ {
+#if defined DEBUG && DEBUG
+ /* It must not happen. */
+ assert (wc_idx >= 0);
+#endif
+ --wc_idx;
+ if (wc_idx < 0)
+ return input->tip_context;
+ }
+ wc = input->wcs[wc_idx];
+ if (__glibc_unlikely (input->word_ops_used != 0)
+ && IS_WIDE_WORD_CHAR (wc))
+ return CONTEXT_WORD;
+ return (IS_WIDE_NEWLINE (wc) && input->newline_anchor
+ ? CONTEXT_NEWLINE : 0);
+ }
+ else
+#endif
+ {
+ c = re_string_byte_at (input, idx);
+ if (bitset_contain (input->word_char, c))
+ return CONTEXT_WORD;
+ return IS_NEWLINE (c) && input->newline_anchor ? CONTEXT_NEWLINE : 0;
+ }
+}
+
+/* Functions for set operation. */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+re_node_set_alloc (re_node_set *set, Idx size)
+{
+ set->alloc = size;
+ set->nelem = 0;
+ set->elems = re_malloc (Idx, size);
+ if (__glibc_unlikely (set->elems == NULL)
+ && (MALLOC_0_IS_NONNULL || size != 0))
+ return REG_ESPACE;
+ return REG_NOERROR;
+}
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+re_node_set_init_1 (re_node_set *set, Idx elem)
+{
+ set->alloc = 1;
+ set->nelem = 1;
+ set->elems = re_malloc (Idx, 1);
+ if (__glibc_unlikely (set->elems == NULL))
+ {
+ set->alloc = set->nelem = 0;
+ return REG_ESPACE;
+ }
+ set->elems[0] = elem;
+ return REG_NOERROR;
+}
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+re_node_set_init_2 (re_node_set *set, Idx elem1, Idx elem2)
+{
+ set->alloc = 2;
+ set->elems = re_malloc (Idx, 2);
+ if (__glibc_unlikely (set->elems == NULL))
+ return REG_ESPACE;
+ if (elem1 == elem2)
+ {
+ set->nelem = 1;
+ set->elems[0] = elem1;
+ }
+ else
+ {
+ set->nelem = 2;
+ if (elem1 < elem2)
+ {
+ set->elems[0] = elem1;
+ set->elems[1] = elem2;
+ }
+ else
+ {
+ set->elems[0] = elem2;
+ set->elems[1] = elem1;
+ }
+ }
+ return REG_NOERROR;
+}
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+re_node_set_init_copy (re_node_set *dest, const re_node_set *src)
+{
+ dest->nelem = src->nelem;
+ if (src->nelem > 0)
+ {
+ dest->alloc = dest->nelem;
+ dest->elems = re_malloc (Idx, dest->alloc);
+ if (__glibc_unlikely (dest->elems == NULL))
+ {
+ dest->alloc = dest->nelem = 0;
+ return REG_ESPACE;
+ }
+ memcpy (dest->elems, src->elems, src->nelem * sizeof (Idx));
+ }
+ else
+ re_node_set_init_empty (dest);
+ return REG_NOERROR;
+}
+
+/* Calculate the intersection of the sets SRC1 and SRC2. And merge it to
+ DEST. Return value indicate the error code or REG_NOERROR if succeeded.
+ Note: We assume dest->elems is NULL, when dest->alloc is 0. */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+re_node_set_add_intersect (re_node_set *dest, const re_node_set *src1,
+ const re_node_set *src2)
+{
+ Idx i1, i2, is, id, delta, sbase;
+ if (src1->nelem == 0 || src2->nelem == 0)
+ return REG_NOERROR;
+
+ /* We need dest->nelem + 2 * elems_in_intersection; this is a
+ conservative estimate. */
+ if (src1->nelem + src2->nelem + dest->nelem > dest->alloc)
+ {
+ Idx new_alloc = src1->nelem + src2->nelem + dest->alloc;
+ Idx *new_elems = re_realloc (dest->elems, Idx, new_alloc);
+ if (__glibc_unlikely (new_elems == NULL))
+ return REG_ESPACE;
+ dest->elems = new_elems;
+ dest->alloc = new_alloc;
+ }
+
+ /* Find the items in the intersection of SRC1 and SRC2, and copy
+ into the top of DEST those that are not already in DEST itself. */
+ sbase = dest->nelem + src1->nelem + src2->nelem;
+ i1 = src1->nelem - 1;
+ i2 = src2->nelem - 1;
+ id = dest->nelem - 1;
+ for (;;)
+ {
+ if (src1->elems[i1] == src2->elems[i2])
+ {
+ /* Try to find the item in DEST. Maybe we could binary search? */
+ while (id >= 0 && dest->elems[id] > src1->elems[i1])
+ --id;
+
+ if (id < 0 || dest->elems[id] != src1->elems[i1])
+ dest->elems[--sbase] = src1->elems[i1];
+
+ if (--i1 < 0 || --i2 < 0)
+ break;
+ }
+
+ /* Lower the highest of the two items. */
+ else if (src1->elems[i1] < src2->elems[i2])
+ {
+ if (--i2 < 0)
+ break;
+ }
+ else
+ {
+ if (--i1 < 0)
+ break;
+ }
+ }
+
+ id = dest->nelem - 1;
+ is = dest->nelem + src1->nelem + src2->nelem - 1;
+ delta = is - sbase + 1;
+
+ /* Now copy. When DELTA becomes zero, the remaining
+ DEST elements are already in place; this is more or
+ less the same loop that is in re_node_set_merge. */
+ dest->nelem += delta;
+ if (delta > 0 && id >= 0)
+ for (;;)
+ {
+ if (dest->elems[is] > dest->elems[id])
+ {
+ /* Copy from the top. */
+ dest->elems[id + delta--] = dest->elems[is--];
+ if (delta == 0)
+ break;
+ }
+ else
+ {
+ /* Slide from the bottom. */
+ dest->elems[id + delta] = dest->elems[id];
+ if (--id < 0)
+ break;
+ }
+ }
+
+ /* Copy remaining SRC elements. */
+ memcpy (dest->elems, dest->elems + sbase, delta * sizeof (Idx));
+
+ return REG_NOERROR;
+}
+
+/* Calculate the union set of the sets SRC1 and SRC2. And store it to
+ DEST. Return value indicate the error code or REG_NOERROR if succeeded. */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+re_node_set_init_union (re_node_set *dest, const re_node_set *src1,
+ const re_node_set *src2)
+{
+ Idx i1, i2, id;
+ if (src1 != NULL && src1->nelem > 0 && src2 != NULL && src2->nelem > 0)
+ {
+ dest->alloc = src1->nelem + src2->nelem;
+ dest->elems = re_malloc (Idx, dest->alloc);
+ if (__glibc_unlikely (dest->elems == NULL))
+ return REG_ESPACE;
+ }
+ else
+ {
+ if (src1 != NULL && src1->nelem > 0)
+ return re_node_set_init_copy (dest, src1);
+ else if (src2 != NULL && src2->nelem > 0)
+ return re_node_set_init_copy (dest, src2);
+ else
+ re_node_set_init_empty (dest);
+ return REG_NOERROR;
+ }
+ for (i1 = i2 = id = 0 ; i1 < src1->nelem && i2 < src2->nelem ;)
+ {
+ if (src1->elems[i1] > src2->elems[i2])
+ {
+ dest->elems[id++] = src2->elems[i2++];
+ continue;
+ }
+ if (src1->elems[i1] == src2->elems[i2])
+ ++i2;
+ dest->elems[id++] = src1->elems[i1++];
+ }
+ if (i1 < src1->nelem)
+ {
+ memcpy (dest->elems + id, src1->elems + i1,
+ (src1->nelem - i1) * sizeof (Idx));
+ id += src1->nelem - i1;
+ }
+ else if (i2 < src2->nelem)
+ {
+ memcpy (dest->elems + id, src2->elems + i2,
+ (src2->nelem - i2) * sizeof (Idx));
+ id += src2->nelem - i2;
+ }
+ dest->nelem = id;
+ return REG_NOERROR;
+}
+
+/* Calculate the union set of the sets DEST and SRC. And store it to
+ DEST. Return value indicate the error code or REG_NOERROR if succeeded. */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+re_node_set_merge (re_node_set *dest, const re_node_set *src)
+{
+ Idx is, id, sbase, delta;
+ if (src == NULL || src->nelem == 0)
+ return REG_NOERROR;
+ if (dest->alloc < 2 * src->nelem + dest->nelem)
+ {
+ Idx new_alloc = 2 * (src->nelem + dest->alloc);
+ Idx *new_buffer = re_realloc (dest->elems, Idx, new_alloc);
+ if (__glibc_unlikely (new_buffer == NULL))
+ return REG_ESPACE;
+ dest->elems = new_buffer;
+ dest->alloc = new_alloc;
+ }
+
+ if (__glibc_unlikely (dest->nelem == 0))
+ {
+ dest->nelem = src->nelem;
+ memcpy (dest->elems, src->elems, src->nelem * sizeof (Idx));
+ return REG_NOERROR;
+ }
+
+ /* Copy into the top of DEST the items of SRC that are not
+ found in DEST. Maybe we could binary search in DEST? */
+ for (sbase = dest->nelem + 2 * src->nelem,
+ is = src->nelem - 1, id = dest->nelem - 1; is >= 0 && id >= 0; )
+ {
+ if (dest->elems[id] == src->elems[is])
+ is--, id--;
+ else if (dest->elems[id] < src->elems[is])
+ dest->elems[--sbase] = src->elems[is--];
+ else /* if (dest->elems[id] > src->elems[is]) */
+ --id;
+ }
+
+ if (is >= 0)
+ {
+ /* If DEST is exhausted, the remaining items of SRC must be unique. */
+ sbase -= is + 1;
+ memcpy (dest->elems + sbase, src->elems, (is + 1) * sizeof (Idx));
+ }
+
+ id = dest->nelem - 1;
+ is = dest->nelem + 2 * src->nelem - 1;
+ delta = is - sbase + 1;
+ if (delta == 0)
+ return REG_NOERROR;
+
+ /* Now copy. When DELTA becomes zero, the remaining
+ DEST elements are already in place. */
+ dest->nelem += delta;
+ for (;;)
+ {
+ if (dest->elems[is] > dest->elems[id])
+ {
+ /* Copy from the top. */
+ dest->elems[id + delta--] = dest->elems[is--];
+ if (delta == 0)
+ break;
+ }
+ else
+ {
+ /* Slide from the bottom. */
+ dest->elems[id + delta] = dest->elems[id];
+ if (--id < 0)
+ {
+ /* Copy remaining SRC elements. */
+ memcpy (dest->elems, dest->elems + sbase,
+ delta * sizeof (Idx));
+ break;
+ }
+ }
+ }
+
+ return REG_NOERROR;
+}
+
+/* Insert the new element ELEM to the re_node_set* SET.
+ SET should not already have ELEM.
+ Return true if successful. */
+
+static bool
+__attribute_warn_unused_result__
+re_node_set_insert (re_node_set *set, Idx elem)
+{
+ Idx idx;
+ /* In case the set is empty. */
+ if (set->alloc == 0)
+ return __glibc_likely (re_node_set_init_1 (set, elem) == REG_NOERROR);
+
+ if (__glibc_unlikely (set->nelem) == 0)
+ {
+ /* We already guaranteed above that set->alloc != 0. */
+ set->elems[0] = elem;
+ ++set->nelem;
+ return true;
+ }
+
+ /* Realloc if we need. */
+ if (set->alloc == set->nelem)
+ {
+ Idx *new_elems;
+ set->alloc = set->alloc * 2;
+ new_elems = re_realloc (set->elems, Idx, set->alloc);
+ if (__glibc_unlikely (new_elems == NULL))
+ return false;
+ set->elems = new_elems;
+ }
+
+ /* Move the elements which follows the new element. Test the
+ first element separately to skip a check in the inner loop. */
+ if (elem < set->elems[0])
+ {
+ idx = 0;
+ for (idx = set->nelem; idx > 0; idx--)
+ set->elems[idx] = set->elems[idx - 1];
+ }
+ else
+ {
+ for (idx = set->nelem; set->elems[idx - 1] > elem; idx--)
+ set->elems[idx] = set->elems[idx - 1];
+ }
+
+ /* Insert the new element. */
+ set->elems[idx] = elem;
+ ++set->nelem;
+ return true;
+}
+
+/* Insert the new element ELEM to the re_node_set* SET.
+ SET should not already have any element greater than or equal to ELEM.
+ Return true if successful. */
+
+static bool
+__attribute_warn_unused_result__
+re_node_set_insert_last (re_node_set *set, Idx elem)
+{
+ /* Realloc if we need. */
+ if (set->alloc == set->nelem)
+ {
+ Idx *new_elems;
+ set->alloc = (set->alloc + 1) * 2;
+ new_elems = re_realloc (set->elems, Idx, set->alloc);
+ if (__glibc_unlikely (new_elems == NULL))
+ return false;
+ set->elems = new_elems;
+ }
+
+ /* Insert the new element. */
+ set->elems[set->nelem++] = elem;
+ return true;
+}
+
+/* Compare two node sets SET1 and SET2.
+ Return true if SET1 and SET2 are equivalent. */
+
+static bool
+__attribute__ ((pure))
+re_node_set_compare (const re_node_set *set1, const re_node_set *set2)
+{
+ Idx i;
+ if (set1 == NULL || set2 == NULL || set1->nelem != set2->nelem)
+ return false;
+ for (i = set1->nelem ; --i >= 0 ; )
+ if (set1->elems[i] != set2->elems[i])
+ return false;
+ return true;
+}
+
+/* Return (idx + 1) if SET contains the element ELEM, return 0 otherwise. */
+
+static Idx
+__attribute__ ((pure))
+re_node_set_contains (const re_node_set *set, Idx elem)
+{
+ __re_size_t idx, right, mid;
+ if (set->nelem <= 0)
+ return 0;
+
+ /* Binary search the element. */
+ idx = 0;
+ right = set->nelem - 1;
+ while (idx < right)
+ {
+ mid = (idx + right) / 2;
+ if (set->elems[mid] < elem)
+ idx = mid + 1;
+ else
+ right = mid;
+ }
+ return set->elems[idx] == elem ? idx + 1 : 0;
+}
+
+static void
+re_node_set_remove_at (re_node_set *set, Idx idx)
+{
+ if (idx < 0 || idx >= set->nelem)
+ return;
+ --set->nelem;
+ for (; idx < set->nelem; idx++)
+ set->elems[idx] = set->elems[idx + 1];
+}
+
+
+/* Add the token TOKEN to dfa->nodes, and return the index of the token.
+ Or return -1 if an error occurred. */
+
+static Idx
+re_dfa_add_node (re_dfa_t *dfa, re_token_t token)
+{
+ if (__glibc_unlikely (dfa->nodes_len >= dfa->nodes_alloc))
+ {
+ size_t new_nodes_alloc = dfa->nodes_alloc * 2;
+ Idx *new_nexts, *new_indices;
+ re_node_set *new_edests, *new_eclosures;
+ re_token_t *new_nodes;
+
+ /* Avoid overflows in realloc. */
+ const size_t max_object_size = MAX (sizeof (re_token_t),
+ MAX (sizeof (re_node_set),
+ sizeof (Idx)));
+ if (__glibc_unlikely (MIN (IDX_MAX, SIZE_MAX / max_object_size)
+ < new_nodes_alloc))
+ return -1;
+
+ new_nodes = re_realloc (dfa->nodes, re_token_t, new_nodes_alloc);
+ if (__glibc_unlikely (new_nodes == NULL))
+ return -1;
+ dfa->nodes = new_nodes;
+ new_nexts = re_realloc (dfa->nexts, Idx, new_nodes_alloc);
+ new_indices = re_realloc (dfa->org_indices, Idx, new_nodes_alloc);
+ new_edests = re_realloc (dfa->edests, re_node_set, new_nodes_alloc);
+ new_eclosures = re_realloc (dfa->eclosures, re_node_set, new_nodes_alloc);
+ if (__glibc_unlikely (new_nexts == NULL || new_indices == NULL
+ || new_edests == NULL || new_eclosures == NULL))
+ {
+ re_free (new_nexts);
+ re_free (new_indices);
+ re_free (new_edests);
+ re_free (new_eclosures);
+ return -1;
+ }
+ dfa->nexts = new_nexts;
+ dfa->org_indices = new_indices;
+ dfa->edests = new_edests;
+ dfa->eclosures = new_eclosures;
+ dfa->nodes_alloc = new_nodes_alloc;
+ }
+ dfa->nodes[dfa->nodes_len] = token;
+ dfa->nodes[dfa->nodes_len].constraint = 0;
+#ifdef RE_ENABLE_I18N
+ dfa->nodes[dfa->nodes_len].accept_mb =
+ ((token.type == OP_PERIOD && dfa->mb_cur_max > 1)
+ || token.type == COMPLEX_BRACKET);
+#endif
+ dfa->nexts[dfa->nodes_len] = -1;
+ re_node_set_init_empty (dfa->edests + dfa->nodes_len);
+ re_node_set_init_empty (dfa->eclosures + dfa->nodes_len);
+ return dfa->nodes_len++;
+}
+
+static re_hashval_t
+calc_state_hash (const re_node_set *nodes, unsigned int context)
+{
+ re_hashval_t hash = nodes->nelem + context;
+ Idx i;
+ for (i = 0 ; i < nodes->nelem ; i++)
+ hash += nodes->elems[i];
+ return hash;
+}
+
+/* Search for the state whose node_set is equivalent to NODES.
+ Return the pointer to the state, if we found it in the DFA.
+ Otherwise create the new one and return it. In case of an error
+ return NULL and set the error code in ERR.
+ Note: - We assume NULL as the invalid state, then it is possible that
+ return value is NULL and ERR is REG_NOERROR.
+ - We never return non-NULL value in case of any errors, it is for
+ optimization. */
+
+static re_dfastate_t *
+__attribute_warn_unused_result__
+re_acquire_state (reg_errcode_t *err, const re_dfa_t *dfa,
+ const re_node_set *nodes)
+{
+ re_hashval_t hash;
+ re_dfastate_t *new_state;
+ struct re_state_table_entry *spot;
+ Idx i;
+#if defined GCC_LINT || defined lint
+ /* Suppress bogus uninitialized-variable warnings. */
+ *err = REG_NOERROR;
+#endif
+ if (__glibc_unlikely (nodes->nelem == 0))
+ {
+ *err = REG_NOERROR;
+ return NULL;
+ }
+ hash = calc_state_hash (nodes, 0);
+ spot = dfa->state_table + (hash & dfa->state_hash_mask);
+
+ for (i = 0 ; i < spot->num ; i++)
+ {
+ re_dfastate_t *state = spot->array[i];
+ if (hash != state->hash)
+ continue;
+ if (re_node_set_compare (&state->nodes, nodes))
+ return state;
+ }
+
+ /* There are no appropriate state in the dfa, create the new one. */
+ new_state = create_ci_newstate (dfa, nodes, hash);
+ if (__glibc_unlikely (new_state == NULL))
+ *err = REG_ESPACE;
+
+ return new_state;
+}
+
+/* Search for the state whose node_set is equivalent to NODES and
+ whose context is equivalent to CONTEXT.
+ Return the pointer to the state, if we found it in the DFA.
+ Otherwise create the new one and return it. In case of an error
+ return NULL and set the error code in ERR.
+ Note: - We assume NULL as the invalid state, then it is possible that
+ return value is NULL and ERR is REG_NOERROR.
+ - We never return non-NULL value in case of any errors, it is for
+ optimization. */
+
+static re_dfastate_t *
+__attribute_warn_unused_result__
+re_acquire_state_context (reg_errcode_t *err, const re_dfa_t *dfa,
+ const re_node_set *nodes, unsigned int context)
+{
+ re_hashval_t hash;
+ re_dfastate_t *new_state;
+ struct re_state_table_entry *spot;
+ Idx i;
+#if defined GCC_LINT || defined lint
+ /* Suppress bogus uninitialized-variable warnings. */
+ *err = REG_NOERROR;
+#endif
+ if (nodes->nelem == 0)
+ {
+ *err = REG_NOERROR;
+ return NULL;
+ }
+ hash = calc_state_hash (nodes, context);
+ spot = dfa->state_table + (hash & dfa->state_hash_mask);
+
+ for (i = 0 ; i < spot->num ; i++)
+ {
+ re_dfastate_t *state = spot->array[i];
+ if (state->hash == hash
+ && state->context == context
+ && re_node_set_compare (state->entrance_nodes, nodes))
+ return state;
+ }
+ /* There are no appropriate state in 'dfa', create the new one. */
+ new_state = create_cd_newstate (dfa, nodes, context, hash);
+ if (__glibc_unlikely (new_state == NULL))
+ *err = REG_ESPACE;
+
+ return new_state;
+}
+
+/* Finish initialization of the new state NEWSTATE, and using its hash value
+ HASH put in the appropriate bucket of DFA's state table. Return value
+ indicates the error code if failed. */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+register_state (const re_dfa_t *dfa, re_dfastate_t *newstate,
+ re_hashval_t hash)
+{
+ struct re_state_table_entry *spot;
+ reg_errcode_t err;
+ Idx i;
+
+ newstate->hash = hash;
+ err = re_node_set_alloc (&newstate->non_eps_nodes, newstate->nodes.nelem);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return REG_ESPACE;
+ for (i = 0; i < newstate->nodes.nelem; i++)
+ {
+ Idx elem = newstate->nodes.elems[i];
+ if (!IS_EPSILON_NODE (dfa->nodes[elem].type))
+ if (! re_node_set_insert_last (&newstate->non_eps_nodes, elem))
+ return REG_ESPACE;
+ }
+
+ spot = dfa->state_table + (hash & dfa->state_hash_mask);
+ if (__glibc_unlikely (spot->alloc <= spot->num))
+ {
+ Idx new_alloc = 2 * spot->num + 2;
+ re_dfastate_t **new_array = re_realloc (spot->array, re_dfastate_t *,
+ new_alloc);
+ if (__glibc_unlikely (new_array == NULL))
+ return REG_ESPACE;
+ spot->array = new_array;
+ spot->alloc = new_alloc;
+ }
+ spot->array[spot->num++] = newstate;
+ return REG_NOERROR;
+}
+
+static void
+free_state (re_dfastate_t *state)
+{
+ re_node_set_free (&state->non_eps_nodes);
+ re_node_set_free (&state->inveclosure);
+ if (state->entrance_nodes != &state->nodes)
+ {
+ re_node_set_free (state->entrance_nodes);
+ re_free (state->entrance_nodes);
+ }
+ re_node_set_free (&state->nodes);
+ re_free (state->word_trtable);
+ re_free (state->trtable);
+ re_free (state);
+}
+
+/* Create the new state which is independent of contexts.
+ Return the new state if succeeded, otherwise return NULL. */
+
+static re_dfastate_t *
+__attribute_warn_unused_result__
+create_ci_newstate (const re_dfa_t *dfa, const re_node_set *nodes,
+ re_hashval_t hash)
+{
+ Idx i;
+ reg_errcode_t err;
+ re_dfastate_t *newstate;
+
+ newstate = (re_dfastate_t *) calloc (sizeof (re_dfastate_t), 1);
+ if (__glibc_unlikely (newstate == NULL))
+ return NULL;
+ err = re_node_set_init_copy (&newstate->nodes, nodes);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ {
+ re_free (newstate);
+ return NULL;
+ }
+
+ newstate->entrance_nodes = &newstate->nodes;
+ for (i = 0 ; i < nodes->nelem ; i++)
+ {
+ re_token_t *node = dfa->nodes + nodes->elems[i];
+ re_token_type_t type = node->type;
+ if (type == CHARACTER && !node->constraint)
+ continue;
+#ifdef RE_ENABLE_I18N
+ newstate->accept_mb |= node->accept_mb;
+#endif /* RE_ENABLE_I18N */
+
+ /* If the state has the halt node, the state is a halt state. */
+ if (type == END_OF_RE)
+ newstate->halt = 1;
+ else if (type == OP_BACK_REF)
+ newstate->has_backref = 1;
+ else if (type == ANCHOR || node->constraint)
+ newstate->has_constraint = 1;
+ }
+ err = register_state (dfa, newstate, hash);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ {
+ free_state (newstate);
+ newstate = NULL;
+ }
+ return newstate;
+}
+
+/* Create the new state which is depend on the context CONTEXT.
+ Return the new state if succeeded, otherwise return NULL. */
+
+static re_dfastate_t *
+__attribute_warn_unused_result__
+create_cd_newstate (const re_dfa_t *dfa, const re_node_set *nodes,
+ unsigned int context, re_hashval_t hash)
+{
+ Idx i, nctx_nodes = 0;
+ reg_errcode_t err;
+ re_dfastate_t *newstate;
+
+ newstate = (re_dfastate_t *) calloc (sizeof (re_dfastate_t), 1);
+ if (__glibc_unlikely (newstate == NULL))
+ return NULL;
+ err = re_node_set_init_copy (&newstate->nodes, nodes);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ {
+ re_free (newstate);
+ return NULL;
+ }
+
+ newstate->context = context;
+ newstate->entrance_nodes = &newstate->nodes;
+
+ for (i = 0 ; i < nodes->nelem ; i++)
+ {
+ re_token_t *node = dfa->nodes + nodes->elems[i];
+ re_token_type_t type = node->type;
+ unsigned int constraint = node->constraint;
+
+ if (type == CHARACTER && !constraint)
+ continue;
+#ifdef RE_ENABLE_I18N
+ newstate->accept_mb |= node->accept_mb;
+#endif /* RE_ENABLE_I18N */
+
+ /* If the state has the halt node, the state is a halt state. */
+ if (type == END_OF_RE)
+ newstate->halt = 1;
+ else if (type == OP_BACK_REF)
+ newstate->has_backref = 1;
+
+ if (constraint)
+ {
+ if (newstate->entrance_nodes == &newstate->nodes)
+ {
+ newstate->entrance_nodes = re_malloc (re_node_set, 1);
+ if (__glibc_unlikely (newstate->entrance_nodes == NULL))
+ {
+ free_state (newstate);
+ return NULL;
+ }
+ if (re_node_set_init_copy (newstate->entrance_nodes, nodes)
+ != REG_NOERROR)
+ return NULL;
+ nctx_nodes = 0;
+ newstate->has_constraint = 1;
+ }
+
+ if (NOT_SATISFY_PREV_CONSTRAINT (constraint,context))
+ {
+ re_node_set_remove_at (&newstate->nodes, i - nctx_nodes);
+ ++nctx_nodes;
+ }
+ }
+ }
+ err = register_state (dfa, newstate, hash);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ {
+ free_state (newstate);
+ newstate = NULL;
+ }
+ return newstate;
+}
diff --git a/lib/regex_internal.h b/lib/regex_internal.h
new file mode 100644
index 00000000000..a3aedda8915
--- /dev/null
+++ b/lib/regex_internal.h
@@ -0,0 +1,874 @@
+/* Extended regular expression matching and search library.
+ Copyright (C) 2002-2019 Free Software Foundation, Inc.
+ This file is part of the GNU C Library.
+ Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>.
+
+ 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
+ <https://www.gnu.org/licenses/>. */
+
+#ifndef _REGEX_INTERNAL_H
+#define _REGEX_INTERNAL_H 1
+
+#include <assert.h>
+#include <ctype.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include <langinfo.h>
+#include <locale.h>
+#include <wchar.h>
+#include <wctype.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include <intprops.h>
+
+#ifdef _LIBC
+# include <libc-lock.h>
+# define lock_define(name) __libc_lock_define (, name)
+# define lock_init(lock) (__libc_lock_init (lock), 0)
+# define lock_fini(lock) ((void) 0)
+# define lock_lock(lock) __libc_lock_lock (lock)
+# define lock_unlock(lock) __libc_lock_unlock (lock)
+#elif defined GNULIB_LOCK && !defined USE_UNLOCKED_IO
+# include "glthread/lock.h"
+ /* Use gl_lock_define if empty macro arguments are known to work.
+ Otherwise, fall back on less-portable substitutes. */
+# if ((defined __GNUC__ && !defined __STRICT_ANSI__) \
+ || (defined __STDC_VERSION__ && 199901L <= __STDC_VERSION__))
+# define lock_define(name) gl_lock_define (, name)
+# elif USE_POSIX_THREADS
+# define lock_define(name) pthread_mutex_t name;
+# elif USE_PTH_THREADS
+# define lock_define(name) pth_mutex_t name;
+# elif USE_SOLARIS_THREADS
+# define lock_define(name) mutex_t name;
+# elif USE_WINDOWS_THREADS
+# define lock_define(name) gl_lock_t name;
+# else
+# define lock_define(name)
+# endif
+# define lock_init(lock) glthread_lock_init (&(lock))
+# define lock_fini(lock) glthread_lock_destroy (&(lock))
+# define lock_lock(lock) glthread_lock_lock (&(lock))
+# define lock_unlock(lock) glthread_lock_unlock (&(lock))
+#elif defined GNULIB_PTHREAD && !defined USE_UNLOCKED_IO
+# include <pthread.h>
+# define lock_define(name) pthread_mutex_t name;
+# define lock_init(lock) pthread_mutex_init (&(lock), 0)
+# define lock_fini(lock) pthread_mutex_destroy (&(lock))
+# define lock_lock(lock) pthread_mutex_lock (&(lock))
+# define lock_unlock(lock) pthread_mutex_unlock (&(lock))
+#else
+# define lock_define(name)
+# define lock_init(lock) 0
+# define lock_fini(lock) ((void) 0)
+ /* The 'dfa' avoids an "unused variable 'dfa'" warning from GCC. */
+# define lock_lock(lock) ((void) dfa)
+# define lock_unlock(lock) ((void) 0)
+#endif
+
+/* In case that the system doesn't have isblank(). */
+#if !defined _LIBC && ! (defined isblank || (HAVE_ISBLANK && HAVE_DECL_ISBLANK))
+# define isblank(ch) ((ch) == ' ' || (ch) == '\t')
+#endif
+
+#ifdef _LIBC
+# ifndef _RE_DEFINE_LOCALE_FUNCTIONS
+# define _RE_DEFINE_LOCALE_FUNCTIONS 1
+# include <locale/localeinfo.h>
+# include <locale/coll-lookup.h>
+# endif
+#endif
+
+/* This is for other GNU distributions with internationalized messages. */
+#if (HAVE_LIBINTL_H && ENABLE_NLS) || defined _LIBC
+# include <libintl.h>
+# ifdef _LIBC
+# undef gettext
+# define gettext(msgid) \
+ __dcgettext (_libc_intl_domainname, msgid, LC_MESSAGES)
+# endif
+#else
+# undef gettext
+# define gettext(msgid) (msgid)
+#endif
+
+#ifndef gettext_noop
+/* This define is so xgettext can find the internationalizable
+ strings. */
+# define gettext_noop(String) String
+#endif
+
+#if (defined MB_CUR_MAX && HAVE_WCTYPE_H && HAVE_ISWCTYPE) || _LIBC
+# define RE_ENABLE_I18N
+#endif
+
+/* Number of ASCII characters. */
+#define ASCII_CHARS 0x80
+
+/* Number of single byte characters. */
+#define SBC_MAX (UCHAR_MAX + 1)
+
+#define COLL_ELEM_LEN_MAX 8
+
+/* The character which represents newline. */
+#define NEWLINE_CHAR '\n'
+#define WIDE_NEWLINE_CHAR L'\n'
+
+/* Rename to standard API for using out of glibc. */
+#ifndef _LIBC
+# undef __wctype
+# undef __iswalnum
+# undef __iswctype
+# undef __towlower
+# undef __towupper
+# define __wctype wctype
+# define __iswalnum iswalnum
+# define __iswctype iswctype
+# define __towlower towlower
+# define __towupper towupper
+# define __btowc btowc
+# define __mbrtowc mbrtowc
+# define __wcrtomb wcrtomb
+# define __regfree regfree
+#endif /* not _LIBC */
+
+#ifndef SSIZE_MAX
+# define SSIZE_MAX ((ssize_t) (SIZE_MAX / 2))
+#endif
+
+/* The type of indexes into strings. This is signed, not size_t,
+ since the API requires indexes to fit in regoff_t anyway, and using
+ signed integers makes the code a bit smaller and presumably faster.
+ The traditional GNU regex implementation uses int for indexes.
+ The POSIX-compatible implementation uses a possibly-wider type.
+ The name 'Idx' is three letters to minimize the hassle of
+ reindenting a lot of regex code that formerly used 'int'. */
+typedef regoff_t Idx;
+#ifdef _REGEX_LARGE_OFFSETS
+# define IDX_MAX SSIZE_MAX
+#else
+# define IDX_MAX INT_MAX
+#endif
+
+/* A hash value, suitable for computing hash tables. */
+typedef __re_size_t re_hashval_t;
+
+/* An integer used to represent a set of bits. It must be unsigned,
+ and must be at least as wide as unsigned int. */
+typedef unsigned long int bitset_word_t;
+/* All bits set in a bitset_word_t. */
+#define BITSET_WORD_MAX ULONG_MAX
+
+/* Number of bits in a bitset_word_t. For portability to hosts with
+ padding bits, do not use '(sizeof (bitset_word_t) * CHAR_BIT)';
+ instead, deduce it directly from BITSET_WORD_MAX. Avoid
+ greater-than-32-bit integers and unconditional shifts by more than
+ 31 bits, as they're not portable. */
+#if BITSET_WORD_MAX == 0xffffffffUL
+# define BITSET_WORD_BITS 32
+#elif BITSET_WORD_MAX >> 31 >> 4 == 1
+# define BITSET_WORD_BITS 36
+#elif BITSET_WORD_MAX >> 31 >> 16 == 1
+# define BITSET_WORD_BITS 48
+#elif BITSET_WORD_MAX >> 31 >> 28 == 1
+# define BITSET_WORD_BITS 60
+#elif BITSET_WORD_MAX >> 31 >> 31 >> 1 == 1
+# define BITSET_WORD_BITS 64
+#elif BITSET_WORD_MAX >> 31 >> 31 >> 9 == 1
+# define BITSET_WORD_BITS 72
+#elif BITSET_WORD_MAX >> 31 >> 31 >> 31 >> 31 >> 3 == 1
+# define BITSET_WORD_BITS 128
+#elif BITSET_WORD_MAX >> 31 >> 31 >> 31 >> 31 >> 31 >> 31 >> 31 >> 31 >> 7 == 1
+# define BITSET_WORD_BITS 256
+#elif BITSET_WORD_MAX >> 31 >> 31 >> 31 >> 31 >> 31 >> 31 >> 31 >> 31 >> 7 > 1
+# define BITSET_WORD_BITS 257 /* any value > SBC_MAX will do here */
+# if BITSET_WORD_BITS <= SBC_MAX
+# error "Invalid SBC_MAX"
+# endif
+#else
+# error "Add case for new bitset_word_t size"
+#endif
+
+/* Number of bitset_word_t values in a bitset_t. */
+#define BITSET_WORDS ((SBC_MAX + BITSET_WORD_BITS - 1) / BITSET_WORD_BITS)
+
+typedef bitset_word_t bitset_t[BITSET_WORDS];
+typedef bitset_word_t *re_bitset_ptr_t;
+typedef const bitset_word_t *re_const_bitset_ptr_t;
+
+#define PREV_WORD_CONSTRAINT 0x0001
+#define PREV_NOTWORD_CONSTRAINT 0x0002
+#define NEXT_WORD_CONSTRAINT 0x0004
+#define NEXT_NOTWORD_CONSTRAINT 0x0008
+#define PREV_NEWLINE_CONSTRAINT 0x0010
+#define NEXT_NEWLINE_CONSTRAINT 0x0020
+#define PREV_BEGBUF_CONSTRAINT 0x0040
+#define NEXT_ENDBUF_CONSTRAINT 0x0080
+#define WORD_DELIM_CONSTRAINT 0x0100
+#define NOT_WORD_DELIM_CONSTRAINT 0x0200
+
+typedef enum
+{
+ INSIDE_WORD = PREV_WORD_CONSTRAINT | NEXT_WORD_CONSTRAINT,
+ WORD_FIRST = PREV_NOTWORD_CONSTRAINT | NEXT_WORD_CONSTRAINT,
+ WORD_LAST = PREV_WORD_CONSTRAINT | NEXT_NOTWORD_CONSTRAINT,
+ INSIDE_NOTWORD = PREV_NOTWORD_CONSTRAINT | NEXT_NOTWORD_CONSTRAINT,
+ LINE_FIRST = PREV_NEWLINE_CONSTRAINT,
+ LINE_LAST = NEXT_NEWLINE_CONSTRAINT,
+ BUF_FIRST = PREV_BEGBUF_CONSTRAINT,
+ BUF_LAST = NEXT_ENDBUF_CONSTRAINT,
+ WORD_DELIM = WORD_DELIM_CONSTRAINT,
+ NOT_WORD_DELIM = NOT_WORD_DELIM_CONSTRAINT
+} re_context_type;
+
+typedef struct
+{
+ Idx alloc;
+ Idx nelem;
+ Idx *elems;
+} re_node_set;
+
+typedef enum
+{
+ NON_TYPE = 0,
+
+ /* Node type, These are used by token, node, tree. */
+ CHARACTER = 1,
+ END_OF_RE = 2,
+ SIMPLE_BRACKET = 3,
+ OP_BACK_REF = 4,
+ OP_PERIOD = 5,
+#ifdef RE_ENABLE_I18N
+ COMPLEX_BRACKET = 6,
+ OP_UTF8_PERIOD = 7,
+#endif /* RE_ENABLE_I18N */
+
+ /* We define EPSILON_BIT as a macro so that OP_OPEN_SUBEXP is used
+ when the debugger shows values of this enum type. */
+#define EPSILON_BIT 8
+ OP_OPEN_SUBEXP = EPSILON_BIT | 0,
+ OP_CLOSE_SUBEXP = EPSILON_BIT | 1,
+ OP_ALT = EPSILON_BIT | 2,
+ OP_DUP_ASTERISK = EPSILON_BIT | 3,
+ ANCHOR = EPSILON_BIT | 4,
+
+ /* Tree type, these are used only by tree. */
+ CONCAT = 16,
+ SUBEXP = 17,
+
+ /* Token type, these are used only by token. */
+ OP_DUP_PLUS = 18,
+ OP_DUP_QUESTION,
+ OP_OPEN_BRACKET,
+ OP_CLOSE_BRACKET,
+ OP_CHARSET_RANGE,
+ OP_OPEN_DUP_NUM,
+ OP_CLOSE_DUP_NUM,
+ OP_NON_MATCH_LIST,
+ OP_OPEN_COLL_ELEM,
+ OP_CLOSE_COLL_ELEM,
+ OP_OPEN_EQUIV_CLASS,
+ OP_CLOSE_EQUIV_CLASS,
+ OP_OPEN_CHAR_CLASS,
+ OP_CLOSE_CHAR_CLASS,
+ OP_WORD,
+ OP_NOTWORD,
+ OP_SPACE,
+ OP_NOTSPACE,
+ BACK_SLASH
+
+} re_token_type_t;
+
+#ifdef RE_ENABLE_I18N
+typedef struct
+{
+ /* Multibyte characters. */
+ wchar_t *mbchars;
+
+ /* Collating symbols. */
+# ifdef _LIBC
+ int32_t *coll_syms;
+# endif
+
+ /* Equivalence classes. */
+# ifdef _LIBC
+ int32_t *equiv_classes;
+# endif
+
+ /* Range expressions. */
+# ifdef _LIBC
+ uint32_t *range_starts;
+ uint32_t *range_ends;
+# else /* not _LIBC */
+ wchar_t *range_starts;
+ wchar_t *range_ends;
+# endif /* not _LIBC */
+
+ /* Character classes. */
+ wctype_t *char_classes;
+
+ /* If this character set is the non-matching list. */
+ unsigned int non_match : 1;
+
+ /* # of multibyte characters. */
+ Idx nmbchars;
+
+ /* # of collating symbols. */
+ Idx ncoll_syms;
+
+ /* # of equivalence classes. */
+ Idx nequiv_classes;
+
+ /* # of range expressions. */
+ Idx nranges;
+
+ /* # of character classes. */
+ Idx nchar_classes;
+} re_charset_t;
+#endif /* RE_ENABLE_I18N */
+
+typedef struct
+{
+ union
+ {
+ unsigned char c; /* for CHARACTER */
+ re_bitset_ptr_t sbcset; /* for SIMPLE_BRACKET */
+#ifdef RE_ENABLE_I18N
+ re_charset_t *mbcset; /* for COMPLEX_BRACKET */
+#endif /* RE_ENABLE_I18N */
+ Idx idx; /* for BACK_REF */
+ re_context_type ctx_type; /* for ANCHOR */
+ } opr;
+#if __GNUC__ >= 2 && !defined __STRICT_ANSI__
+ re_token_type_t type : 8;
+#else
+ re_token_type_t type;
+#endif
+ unsigned int constraint : 10; /* context constraint */
+ unsigned int duplicated : 1;
+ unsigned int opt_subexp : 1;
+#ifdef RE_ENABLE_I18N
+ unsigned int accept_mb : 1;
+ /* These 2 bits can be moved into the union if needed (e.g. if running out
+ of bits; move opr.c to opr.c.c and move the flags to opr.c.flags). */
+ unsigned int mb_partial : 1;
+#endif
+ unsigned int word_char : 1;
+} re_token_t;
+
+#define IS_EPSILON_NODE(type) ((type) & EPSILON_BIT)
+
+struct re_string_t
+{
+ /* Indicate the raw buffer which is the original string passed as an
+ argument of regexec(), re_search(), etc.. */
+ const unsigned char *raw_mbs;
+ /* Store the multibyte string. In case of "case insensitive mode" like
+ REG_ICASE, upper cases of the string are stored, otherwise MBS points
+ the same address that RAW_MBS points. */
+ unsigned char *mbs;
+#ifdef RE_ENABLE_I18N
+ /* Store the wide character string which is corresponding to MBS. */
+ wint_t *wcs;
+ Idx *offsets;
+ mbstate_t cur_state;
+#endif
+ /* Index in RAW_MBS. Each character mbs[i] corresponds to
+ raw_mbs[raw_mbs_idx + i]. */
+ Idx raw_mbs_idx;
+ /* The length of the valid characters in the buffers. */
+ Idx valid_len;
+ /* The corresponding number of bytes in raw_mbs array. */
+ Idx valid_raw_len;
+ /* The length of the buffers MBS and WCS. */
+ Idx bufs_len;
+ /* The index in MBS, which is updated by re_string_fetch_byte. */
+ Idx cur_idx;
+ /* length of RAW_MBS array. */
+ Idx raw_len;
+ /* This is RAW_LEN - RAW_MBS_IDX + VALID_LEN - VALID_RAW_LEN. */
+ Idx len;
+ /* End of the buffer may be shorter than its length in the cases such
+ as re_match_2, re_search_2. Then, we use STOP for end of the buffer
+ instead of LEN. */
+ Idx raw_stop;
+ /* This is RAW_STOP - RAW_MBS_IDX adjusted through OFFSETS. */
+ Idx stop;
+
+ /* The context of mbs[0]. We store the context independently, since
+ the context of mbs[0] may be different from raw_mbs[0], which is
+ the beginning of the input string. */
+ unsigned int tip_context;
+ /* The translation passed as a part of an argument of re_compile_pattern. */
+ RE_TRANSLATE_TYPE trans;
+ /* Copy of re_dfa_t's word_char. */
+ re_const_bitset_ptr_t word_char;
+ /* true if REG_ICASE. */
+ unsigned char icase;
+ unsigned char is_utf8;
+ unsigned char map_notascii;
+ unsigned char mbs_allocated;
+ unsigned char offsets_needed;
+ unsigned char newline_anchor;
+ unsigned char word_ops_used;
+ int mb_cur_max;
+};
+typedef struct re_string_t re_string_t;
+
+
+struct re_dfa_t;
+typedef struct re_dfa_t re_dfa_t;
+
+#ifndef _LIBC
+# define IS_IN(libc) false
+#endif
+
+#define re_string_peek_byte(pstr, offset) \
+ ((pstr)->mbs[(pstr)->cur_idx + offset])
+#define re_string_fetch_byte(pstr) \
+ ((pstr)->mbs[(pstr)->cur_idx++])
+#define re_string_first_byte(pstr, idx) \
+ ((idx) == (pstr)->valid_len || (pstr)->wcs[idx] != WEOF)
+#define re_string_is_single_byte_char(pstr, idx) \
+ ((pstr)->wcs[idx] != WEOF && ((pstr)->valid_len == (idx) + 1 \
+ || (pstr)->wcs[(idx) + 1] != WEOF))
+#define re_string_eoi(pstr) ((pstr)->stop <= (pstr)->cur_idx)
+#define re_string_cur_idx(pstr) ((pstr)->cur_idx)
+#define re_string_get_buffer(pstr) ((pstr)->mbs)
+#define re_string_length(pstr) ((pstr)->len)
+#define re_string_byte_at(pstr,idx) ((pstr)->mbs[idx])
+#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 <alloca.h>
+#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
+# define MALLOC_0_IS_NONNULL 0
+#endif
+
+#ifndef MAX
+# define MAX(a,b) ((a) < (b) ? (b) : (a))
+#endif
+#ifndef MIN
+# define MIN(a,b) ((a) < (b) ? (a) : (b))
+#endif
+
+#define re_malloc(t,n) ((t *) malloc ((n) * sizeof (t)))
+#define re_realloc(p,t,n) ((t *) realloc (p, (n) * sizeof (t)))
+#define re_free(p) free (p)
+
+struct bin_tree_t
+{
+ struct bin_tree_t *parent;
+ struct bin_tree_t *left;
+ struct bin_tree_t *right;
+ struct bin_tree_t *first;
+ struct bin_tree_t *next;
+
+ re_token_t token;
+
+ /* 'node_idx' is the index in dfa->nodes, if 'type' == 0.
+ Otherwise 'type' indicate the type of this node. */
+ Idx node_idx;
+};
+typedef struct bin_tree_t bin_tree_t;
+
+#define BIN_TREE_STORAGE_SIZE \
+ ((1024 - sizeof (void *)) / sizeof (bin_tree_t))
+
+struct bin_tree_storage_t
+{
+ struct bin_tree_storage_t *next;
+ bin_tree_t data[BIN_TREE_STORAGE_SIZE];
+};
+typedef struct bin_tree_storage_t bin_tree_storage_t;
+
+#define CONTEXT_WORD 1
+#define CONTEXT_NEWLINE (CONTEXT_WORD << 1)
+#define CONTEXT_BEGBUF (CONTEXT_NEWLINE << 1)
+#define CONTEXT_ENDBUF (CONTEXT_BEGBUF << 1)
+
+#define IS_WORD_CONTEXT(c) ((c) & CONTEXT_WORD)
+#define IS_NEWLINE_CONTEXT(c) ((c) & CONTEXT_NEWLINE)
+#define IS_BEGBUF_CONTEXT(c) ((c) & CONTEXT_BEGBUF)
+#define IS_ENDBUF_CONTEXT(c) ((c) & CONTEXT_ENDBUF)
+#define IS_ORDINARY_CONTEXT(c) ((c) == 0)
+
+#define IS_WORD_CHAR(ch) (isalnum (ch) || (ch) == '_')
+#define IS_NEWLINE(ch) ((ch) == NEWLINE_CHAR)
+#define IS_WIDE_WORD_CHAR(ch) (__iswalnum (ch) || (ch) == L'_')
+#define IS_WIDE_NEWLINE(ch) ((ch) == WIDE_NEWLINE_CHAR)
+
+#define NOT_SATISFY_PREV_CONSTRAINT(constraint,context) \
+ ((((constraint) & PREV_WORD_CONSTRAINT) && !IS_WORD_CONTEXT (context)) \
+ || ((constraint & PREV_NOTWORD_CONSTRAINT) && IS_WORD_CONTEXT (context)) \
+ || ((constraint & PREV_NEWLINE_CONSTRAINT) && !IS_NEWLINE_CONTEXT (context))\
+ || ((constraint & PREV_BEGBUF_CONSTRAINT) && !IS_BEGBUF_CONTEXT (context)))
+
+#define NOT_SATISFY_NEXT_CONSTRAINT(constraint,context) \
+ ((((constraint) & NEXT_WORD_CONSTRAINT) && !IS_WORD_CONTEXT (context)) \
+ || (((constraint) & NEXT_NOTWORD_CONSTRAINT) && IS_WORD_CONTEXT (context)) \
+ || (((constraint) & NEXT_NEWLINE_CONSTRAINT) && !IS_NEWLINE_CONTEXT (context)) \
+ || (((constraint) & NEXT_ENDBUF_CONSTRAINT) && !IS_ENDBUF_CONTEXT (context)))
+
+struct re_dfastate_t
+{
+ re_hashval_t hash;
+ re_node_set nodes;
+ re_node_set non_eps_nodes;
+ re_node_set inveclosure;
+ re_node_set *entrance_nodes;
+ struct re_dfastate_t **trtable, **word_trtable;
+ unsigned int context : 4;
+ unsigned int halt : 1;
+ /* If this state can accept "multi byte".
+ Note that we refer to multibyte characters, and multi character
+ collating elements as "multi byte". */
+ unsigned int accept_mb : 1;
+ /* If this state has backreference node(s). */
+ unsigned int has_backref : 1;
+ unsigned int has_constraint : 1;
+};
+typedef struct re_dfastate_t re_dfastate_t;
+
+struct re_state_table_entry
+{
+ Idx num;
+ Idx alloc;
+ re_dfastate_t **array;
+};
+
+/* Array type used in re_sub_match_last_t and re_sub_match_top_t. */
+
+typedef struct
+{
+ Idx next_idx;
+ Idx alloc;
+ re_dfastate_t **array;
+} state_array_t;
+
+/* Store information about the node NODE whose type is OP_CLOSE_SUBEXP. */
+
+typedef struct
+{
+ Idx node;
+ Idx str_idx; /* The position NODE match at. */
+ state_array_t path;
+} re_sub_match_last_t;
+
+/* Store information about the node NODE whose type is OP_OPEN_SUBEXP.
+ And information about the node, whose type is OP_CLOSE_SUBEXP,
+ corresponding to NODE is stored in LASTS. */
+
+typedef struct
+{
+ Idx str_idx;
+ Idx node;
+ state_array_t *path;
+ Idx alasts; /* Allocation size of LASTS. */
+ Idx nlasts; /* The number of LASTS. */
+ re_sub_match_last_t **lasts;
+} re_sub_match_top_t;
+
+struct re_backref_cache_entry
+{
+ Idx node;
+ Idx str_idx;
+ Idx subexp_from;
+ Idx subexp_to;
+ char more;
+ char unused;
+ unsigned short int eps_reachable_subexps_map;
+};
+
+typedef struct
+{
+ /* The string object corresponding to the input string. */
+ re_string_t input;
+#if defined _LIBC || (defined __STDC_VERSION__ && __STDC_VERSION__ >= 199901L)
+ const re_dfa_t *const dfa;
+#else
+ const re_dfa_t *dfa;
+#endif
+ /* EFLAGS of the argument of regexec. */
+ int eflags;
+ /* Where the matching ends. */
+ Idx match_last;
+ Idx last_node;
+ /* The state log used by the matcher. */
+ re_dfastate_t **state_log;
+ Idx state_log_top;
+ /* Back reference cache. */
+ Idx nbkref_ents;
+ Idx abkref_ents;
+ struct re_backref_cache_entry *bkref_ents;
+ int max_mb_elem_len;
+ Idx nsub_tops;
+ Idx asub_tops;
+ re_sub_match_top_t **sub_tops;
+} re_match_context_t;
+
+typedef struct
+{
+ re_dfastate_t **sifted_states;
+ re_dfastate_t **limited_states;
+ Idx last_node;
+ Idx last_str_idx;
+ re_node_set limits;
+} re_sift_context_t;
+
+struct re_fail_stack_ent_t
+{
+ Idx idx;
+ Idx node;
+ regmatch_t *regs;
+ re_node_set eps_via_nodes;
+};
+
+struct re_fail_stack_t
+{
+ Idx num;
+ Idx alloc;
+ struct re_fail_stack_ent_t *stack;
+};
+
+struct re_dfa_t
+{
+ re_token_t *nodes;
+ size_t nodes_alloc;
+ size_t nodes_len;
+ Idx *nexts;
+ Idx *org_indices;
+ re_node_set *edests;
+ re_node_set *eclosures;
+ re_node_set *inveclosures;
+ struct re_state_table_entry *state_table;
+ re_dfastate_t *init_state;
+ re_dfastate_t *init_state_word;
+ re_dfastate_t *init_state_nl;
+ re_dfastate_t *init_state_begbuf;
+ bin_tree_t *str_tree;
+ bin_tree_storage_t *str_tree_storage;
+ re_bitset_ptr_t sb_char;
+ int str_tree_storage_idx;
+
+ /* number of subexpressions 're_nsub' is in regex_t. */
+ re_hashval_t state_hash_mask;
+ Idx init_node;
+ Idx nbackref; /* The number of backreference in this dfa. */
+
+ /* Bitmap expressing which backreference is used. */
+ bitset_word_t used_bkref_map;
+ bitset_word_t completed_bkref_map;
+
+ unsigned int has_plural_match : 1;
+ /* If this dfa has "multibyte node", which is a backreference or
+ a node which can accept multibyte character or multi character
+ collating element. */
+ unsigned int has_mb_node : 1;
+ unsigned int is_utf8 : 1;
+ unsigned int map_notascii : 1;
+ unsigned int word_ops_used : 1;
+ int mb_cur_max;
+ bitset_t word_char;
+ reg_syntax_t syntax;
+ Idx *subexp_map;
+#ifdef DEBUG
+ char* re_str;
+#endif
+ lock_define (lock)
+};
+
+#define re_node_set_init_empty(set) memset (set, '\0', sizeof (re_node_set))
+#define re_node_set_remove(set,id) \
+ (re_node_set_remove_at (set, re_node_set_contains (set, id) - 1))
+#define re_node_set_empty(p) ((p)->nelem = 0)
+#define re_node_set_free(set) re_free ((set)->elems)
+
+
+typedef enum
+{
+ SB_CHAR,
+ MB_CHAR,
+ EQUIV_CLASS,
+ COLL_SYM,
+ CHAR_CLASS
+} bracket_elem_type;
+
+typedef struct
+{
+ bracket_elem_type type;
+ union
+ {
+ unsigned char ch;
+ unsigned char *name;
+ wchar_t wch;
+ } opr;
+} bracket_elem_t;
+
+
+/* Functions for bitset_t operation. */
+
+static inline void
+bitset_set (bitset_t set, Idx i)
+{
+ set[i / BITSET_WORD_BITS] |= (bitset_word_t) 1 << i % BITSET_WORD_BITS;
+}
+
+static inline void
+bitset_clear (bitset_t set, Idx i)
+{
+ set[i / BITSET_WORD_BITS] &= ~ ((bitset_word_t) 1 << i % BITSET_WORD_BITS);
+}
+
+static inline bool
+bitset_contain (const bitset_t set, Idx i)
+{
+ return (set[i / BITSET_WORD_BITS] >> i % BITSET_WORD_BITS) & 1;
+}
+
+static inline void
+bitset_empty (bitset_t set)
+{
+ memset (set, '\0', sizeof (bitset_t));
+}
+
+static inline void
+bitset_set_all (bitset_t set)
+{
+ memset (set, -1, sizeof (bitset_word_t) * (SBC_MAX / BITSET_WORD_BITS));
+ if (SBC_MAX % BITSET_WORD_BITS != 0)
+ set[BITSET_WORDS - 1] =
+ ((bitset_word_t) 1 << SBC_MAX % BITSET_WORD_BITS) - 1;
+}
+
+static inline void
+bitset_copy (bitset_t dest, const bitset_t src)
+{
+ memcpy (dest, src, sizeof (bitset_t));
+}
+
+static inline void
+bitset_not (bitset_t set)
+{
+ int bitset_i;
+ for (bitset_i = 0; bitset_i < SBC_MAX / BITSET_WORD_BITS; ++bitset_i)
+ set[bitset_i] = ~set[bitset_i];
+ if (SBC_MAX % BITSET_WORD_BITS != 0)
+ set[BITSET_WORDS - 1] =
+ ((((bitset_word_t) 1 << SBC_MAX % BITSET_WORD_BITS) - 1)
+ & ~set[BITSET_WORDS - 1]);
+}
+
+static inline void
+bitset_merge (bitset_t dest, const bitset_t src)
+{
+ int bitset_i;
+ for (bitset_i = 0; bitset_i < BITSET_WORDS; ++bitset_i)
+ dest[bitset_i] |= src[bitset_i];
+}
+
+static inline void
+bitset_mask (bitset_t dest, const bitset_t src)
+{
+ int bitset_i;
+ for (bitset_i = 0; bitset_i < BITSET_WORDS; ++bitset_i)
+ dest[bitset_i] &= src[bitset_i];
+}
+
+#ifdef RE_ENABLE_I18N
+/* Functions for re_string. */
+static int
+__attribute__ ((pure, unused))
+re_string_char_size_at (const re_string_t *pstr, Idx idx)
+{
+ int byte_idx;
+ if (pstr->mb_cur_max == 1)
+ return 1;
+ for (byte_idx = 1; idx + byte_idx < pstr->valid_len; ++byte_idx)
+ if (pstr->wcs[idx + byte_idx] != WEOF)
+ break;
+ return byte_idx;
+}
+
+static wint_t
+__attribute__ ((pure, unused))
+re_string_wchar_at (const re_string_t *pstr, Idx idx)
+{
+ if (pstr->mb_cur_max == 1)
+ return (wint_t) pstr->mbs[idx];
+ return (wint_t) pstr->wcs[idx];
+}
+
+# ifdef _LIBC
+# include <locale/weight.h>
+# endif
+
+static int
+__attribute__ ((pure, unused))
+re_string_elem_size_at (const re_string_t *pstr, Idx idx)
+{
+# ifdef _LIBC
+ const unsigned char *p, *extra;
+ const int32_t *table, *indirect;
+ uint_fast32_t nrules = _NL_CURRENT_WORD (LC_COLLATE, _NL_COLLATE_NRULES);
+
+ if (nrules != 0)
+ {
+ table = (const int32_t *) _NL_CURRENT (LC_COLLATE, _NL_COLLATE_TABLEMB);
+ extra = (const unsigned char *)
+ _NL_CURRENT (LC_COLLATE, _NL_COLLATE_EXTRAMB);
+ indirect = (const int32_t *) _NL_CURRENT (LC_COLLATE,
+ _NL_COLLATE_INDIRECTMB);
+ p = pstr->mbs + idx;
+ findidx (table, indirect, extra, &p, pstr->len - idx);
+ return p - pstr->mbs - idx;
+ }
+ else
+# endif /* _LIBC */
+ return 1;
+}
+#endif /* RE_ENABLE_I18N */
+
+#ifndef FALLTHROUGH
+# if __GNUC__ < 7
+# define FALLTHROUGH ((void) 0)
+# else
+# define FALLTHROUGH __attribute__ ((__fallthrough__))
+# endif
+#endif
+
+#endif /* _REGEX_INTERNAL_H */
diff --git a/lib/regexec.c b/lib/regexec.c
new file mode 100644
index 00000000000..f464869fb03
--- /dev/null
+++ b/lib/regexec.c
@@ -0,0 +1,4336 @@
+/* Extended regular expression matching and search library.
+ Copyright (C) 2002-2019 Free Software Foundation, Inc.
+ This file is part of the GNU C Library.
+ Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>.
+
+ 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
+ <https://www.gnu.org/licenses/>. */
+
+static reg_errcode_t match_ctx_init (re_match_context_t *cache, int eflags,
+ Idx n);
+static void match_ctx_clean (re_match_context_t *mctx);
+static void match_ctx_free (re_match_context_t *cache);
+static reg_errcode_t match_ctx_add_entry (re_match_context_t *cache, Idx node,
+ Idx str_idx, Idx from, Idx to);
+static Idx search_cur_bkref_entry (const re_match_context_t *mctx, Idx str_idx);
+static reg_errcode_t match_ctx_add_subtop (re_match_context_t *mctx, Idx node,
+ Idx str_idx);
+static re_sub_match_last_t * match_ctx_add_sublast (re_sub_match_top_t *subtop,
+ Idx node, Idx str_idx);
+static void sift_ctx_init (re_sift_context_t *sctx, re_dfastate_t **sifted_sts,
+ re_dfastate_t **limited_sts, Idx last_node,
+ Idx last_str_idx);
+static reg_errcode_t re_search_internal (const regex_t *preg,
+ const char *string, Idx length,
+ Idx start, Idx last_start, Idx stop,
+ size_t nmatch, regmatch_t pmatch[],
+ int eflags);
+static regoff_t re_search_2_stub (struct re_pattern_buffer *bufp,
+ const char *string1, Idx length1,
+ const char *string2, Idx length2,
+ Idx start, regoff_t range,
+ struct re_registers *regs,
+ Idx stop, bool ret_len);
+static regoff_t re_search_stub (struct re_pattern_buffer *bufp,
+ const char *string, Idx length, Idx start,
+ regoff_t range, Idx stop,
+ struct re_registers *regs,
+ bool ret_len);
+static unsigned re_copy_regs (struct re_registers *regs, regmatch_t *pmatch,
+ Idx nregs, int regs_allocated);
+static reg_errcode_t prune_impossible_nodes (re_match_context_t *mctx);
+static Idx check_matching (re_match_context_t *mctx, bool fl_longest_match,
+ Idx *p_match_first);
+static Idx check_halt_state_context (const re_match_context_t *mctx,
+ const re_dfastate_t *state, Idx idx);
+static void update_regs (const re_dfa_t *dfa, regmatch_t *pmatch,
+ regmatch_t *prev_idx_match, Idx cur_node,
+ Idx cur_idx, Idx nmatch);
+static reg_errcode_t push_fail_stack (struct re_fail_stack_t *fs,
+ Idx str_idx, Idx dest_node, Idx nregs,
+ regmatch_t *regs,
+ re_node_set *eps_via_nodes);
+static reg_errcode_t set_regs (const regex_t *preg,
+ const re_match_context_t *mctx,
+ size_t nmatch, regmatch_t *pmatch,
+ bool fl_backtrack);
+static reg_errcode_t free_fail_stack_return (struct re_fail_stack_t *fs);
+
+#ifdef RE_ENABLE_I18N
+static int sift_states_iter_mb (const re_match_context_t *mctx,
+ re_sift_context_t *sctx,
+ Idx node_idx, Idx str_idx, Idx max_str_idx);
+#endif /* RE_ENABLE_I18N */
+static reg_errcode_t sift_states_backward (const re_match_context_t *mctx,
+ re_sift_context_t *sctx);
+static reg_errcode_t build_sifted_states (const re_match_context_t *mctx,
+ re_sift_context_t *sctx, Idx str_idx,
+ re_node_set *cur_dest);
+static reg_errcode_t update_cur_sifted_state (const re_match_context_t *mctx,
+ re_sift_context_t *sctx,
+ Idx str_idx,
+ re_node_set *dest_nodes);
+static reg_errcode_t add_epsilon_src_nodes (const re_dfa_t *dfa,
+ re_node_set *dest_nodes,
+ const re_node_set *candidates);
+static bool check_dst_limits (const re_match_context_t *mctx,
+ const re_node_set *limits,
+ Idx dst_node, Idx dst_idx, Idx src_node,
+ Idx src_idx);
+static int check_dst_limits_calc_pos_1 (const re_match_context_t *mctx,
+ int boundaries, Idx subexp_idx,
+ Idx from_node, Idx bkref_idx);
+static int check_dst_limits_calc_pos (const re_match_context_t *mctx,
+ Idx limit, Idx subexp_idx,
+ Idx node, Idx str_idx,
+ Idx bkref_idx);
+static reg_errcode_t check_subexp_limits (const re_dfa_t *dfa,
+ re_node_set *dest_nodes,
+ const re_node_set *candidates,
+ re_node_set *limits,
+ struct re_backref_cache_entry *bkref_ents,
+ Idx str_idx);
+static reg_errcode_t sift_states_bkref (const re_match_context_t *mctx,
+ re_sift_context_t *sctx,
+ Idx str_idx, const re_node_set *candidates);
+static reg_errcode_t merge_state_array (const re_dfa_t *dfa,
+ re_dfastate_t **dst,
+ re_dfastate_t **src, Idx num);
+static re_dfastate_t *find_recover_state (reg_errcode_t *err,
+ re_match_context_t *mctx);
+static re_dfastate_t *transit_state (reg_errcode_t *err,
+ re_match_context_t *mctx,
+ re_dfastate_t *state);
+static re_dfastate_t *merge_state_with_log (reg_errcode_t *err,
+ re_match_context_t *mctx,
+ re_dfastate_t *next_state);
+static reg_errcode_t check_subexp_matching_top (re_match_context_t *mctx,
+ re_node_set *cur_nodes,
+ Idx str_idx);
+#if 0
+static re_dfastate_t *transit_state_sb (reg_errcode_t *err,
+ re_match_context_t *mctx,
+ re_dfastate_t *pstate);
+#endif
+#ifdef RE_ENABLE_I18N
+static reg_errcode_t transit_state_mb (re_match_context_t *mctx,
+ re_dfastate_t *pstate);
+#endif /* RE_ENABLE_I18N */
+static reg_errcode_t transit_state_bkref (re_match_context_t *mctx,
+ const re_node_set *nodes);
+static reg_errcode_t get_subexp (re_match_context_t *mctx,
+ Idx bkref_node, Idx bkref_str_idx);
+static reg_errcode_t get_subexp_sub (re_match_context_t *mctx,
+ const re_sub_match_top_t *sub_top,
+ re_sub_match_last_t *sub_last,
+ Idx bkref_node, Idx bkref_str);
+static Idx find_subexp_node (const re_dfa_t *dfa, const re_node_set *nodes,
+ Idx subexp_idx, int type);
+static reg_errcode_t check_arrival (re_match_context_t *mctx,
+ state_array_t *path, Idx top_node,
+ Idx top_str, Idx last_node, Idx last_str,
+ int type);
+static reg_errcode_t check_arrival_add_next_nodes (re_match_context_t *mctx,
+ Idx str_idx,
+ re_node_set *cur_nodes,
+ re_node_set *next_nodes);
+static reg_errcode_t check_arrival_expand_ecl (const re_dfa_t *dfa,
+ re_node_set *cur_nodes,
+ Idx ex_subexp, int type);
+static reg_errcode_t check_arrival_expand_ecl_sub (const re_dfa_t *dfa,
+ re_node_set *dst_nodes,
+ Idx target, Idx ex_subexp,
+ int type);
+static reg_errcode_t expand_bkref_cache (re_match_context_t *mctx,
+ re_node_set *cur_nodes, Idx cur_str,
+ Idx subexp_num, int type);
+static bool build_trtable (const re_dfa_t *dfa, re_dfastate_t *state);
+#ifdef RE_ENABLE_I18N
+static int check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx,
+ const re_string_t *input, Idx idx);
+# ifdef _LIBC
+static unsigned int find_collation_sequence_value (const unsigned char *mbs,
+ size_t name_len);
+# endif /* _LIBC */
+#endif /* RE_ENABLE_I18N */
+static Idx group_nodes_into_DFAstates (const re_dfa_t *dfa,
+ const re_dfastate_t *state,
+ re_node_set *states_node,
+ bitset_t *states_ch);
+static bool check_node_accept (const re_match_context_t *mctx,
+ const re_token_t *node, Idx idx);
+static reg_errcode_t extend_buffers (re_match_context_t *mctx, int min_len);
+
+/* Entry point for POSIX code. */
+
+/* regexec searches for a given pattern, specified by PREG, in the
+ string STRING.
+
+ If NMATCH is zero or REG_NOSUB was set in the cflags argument to
+ 'regcomp', we ignore PMATCH. Otherwise, we assume PMATCH has at
+ least NMATCH elements, and we set them to the offsets of the
+ corresponding matched substrings.
+
+ EFLAGS specifies "execution flags" which affect matching: if
+ REG_NOTBOL is set, then ^ does not match at the beginning of the
+ string; if REG_NOTEOL is set, then $ does not match at the end.
+
+ We return 0 if we find a match and REG_NOMATCH if not. */
+
+int
+regexec (const regex_t *__restrict preg, const char *__restrict string,
+ size_t nmatch, regmatch_t pmatch[], int eflags)
+{
+ reg_errcode_t err;
+ Idx start, length;
+ re_dfa_t *dfa = preg->buffer;
+
+ if (eflags & ~(REG_NOTBOL | REG_NOTEOL | REG_STARTEND))
+ return REG_BADPAT;
+
+ if (eflags & REG_STARTEND)
+ {
+ start = pmatch[0].rm_so;
+ length = pmatch[0].rm_eo;
+ }
+ else
+ {
+ start = 0;
+ length = strlen (string);
+ }
+
+ lock_lock (dfa->lock);
+ if (preg->no_sub)
+ err = re_search_internal (preg, string, length, start, length,
+ length, 0, NULL, eflags);
+ else
+ err = re_search_internal (preg, string, length, start, length,
+ length, nmatch, pmatch, eflags);
+ lock_unlock (dfa->lock);
+ return err != REG_NOERROR;
+}
+
+#ifdef _LIBC
+libc_hidden_def (__regexec)
+
+# include <shlib-compat.h>
+versioned_symbol (libc, __regexec, regexec, GLIBC_2_3_4);
+
+# if SHLIB_COMPAT (libc, GLIBC_2_0, GLIBC_2_3_4)
+__typeof__ (__regexec) __compat_regexec;
+
+int
+attribute_compat_text_section
+__compat_regexec (const regex_t *__restrict preg,
+ const char *__restrict string, size_t nmatch,
+ regmatch_t pmatch[], int eflags)
+{
+ return regexec (preg, string, nmatch, pmatch,
+ eflags & (REG_NOTBOL | REG_NOTEOL));
+}
+compat_symbol (libc, __compat_regexec, regexec, GLIBC_2_0);
+# endif
+#endif
+
+/* Entry points for GNU code. */
+
+/* re_match, re_search, re_match_2, re_search_2
+
+ The former two functions operate on STRING with length LENGTH,
+ while the later two operate on concatenation of STRING1 and STRING2
+ with lengths LENGTH1 and LENGTH2, respectively.
+
+ re_match() matches the compiled pattern in BUFP against the string,
+ starting at index START.
+
+ re_search() first tries matching at index START, then it tries to match
+ starting from index START + 1, and so on. The last start position tried
+ is START + RANGE. (Thus RANGE = 0 forces re_search to operate the same
+ way as re_match().)
+
+ The parameter STOP of re_{match,search}_2 specifies that no match exceeding
+ the first STOP characters of the concatenation of the strings should be
+ concerned.
+
+ If REGS is not NULL, and BUFP->no_sub is not set, the offsets of the match
+ and all groups is stored in REGS. (For the "_2" variants, the offsets are
+ computed relative to the concatenation, not relative to the individual
+ strings.)
+
+ On success, re_match* functions return the length of the match, re_search*
+ return the position of the start of the match. Return value -1 means no
+ match was found and -2 indicates an internal error. */
+
+regoff_t
+re_match (struct re_pattern_buffer *bufp, const char *string, Idx length,
+ Idx start, struct re_registers *regs)
+{
+ return re_search_stub (bufp, string, length, start, 0, length, regs, true);
+}
+#ifdef _LIBC
+weak_alias (__re_match, re_match)
+#endif
+
+regoff_t
+re_search (struct re_pattern_buffer *bufp, const char *string, Idx length,
+ Idx start, regoff_t range, struct re_registers *regs)
+{
+ return re_search_stub (bufp, string, length, start, range, length, regs,
+ false);
+}
+#ifdef _LIBC
+weak_alias (__re_search, re_search)
+#endif
+
+regoff_t
+re_match_2 (struct re_pattern_buffer *bufp, const char *string1, Idx length1,
+ const char *string2, Idx length2, Idx start,
+ struct re_registers *regs, Idx stop)
+{
+ return re_search_2_stub (bufp, string1, length1, string2, length2,
+ start, 0, regs, stop, true);
+}
+#ifdef _LIBC
+weak_alias (__re_match_2, re_match_2)
+#endif
+
+regoff_t
+re_search_2 (struct re_pattern_buffer *bufp, const char *string1, Idx length1,
+ const char *string2, Idx length2, Idx start, regoff_t range,
+ struct re_registers *regs, Idx stop)
+{
+ return re_search_2_stub (bufp, string1, length1, string2, length2,
+ start, range, regs, stop, false);
+}
+#ifdef _LIBC
+weak_alias (__re_search_2, re_search_2)
+#endif
+
+static regoff_t
+re_search_2_stub (struct re_pattern_buffer *bufp, const char *string1,
+ Idx length1, const char *string2, Idx length2, Idx start,
+ regoff_t range, struct re_registers *regs,
+ Idx stop, bool ret_len)
+{
+ const char *str;
+ regoff_t rval;
+ Idx len;
+ char *s = NULL;
+
+ if (__glibc_unlikely ((length1 < 0 || length2 < 0 || stop < 0
+ || INT_ADD_WRAPV (length1, length2, &len))))
+ return -2;
+
+ /* Concatenate the strings. */
+ if (length2 > 0)
+ if (length1 > 0)
+ {
+ s = re_malloc (char, len);
+
+ if (__glibc_unlikely (s == NULL))
+ return -2;
+#ifdef _LIBC
+ memcpy (__mempcpy (s, string1, length1), string2, length2);
+#else
+ memcpy (s, string1, length1);
+ memcpy (s + length1, string2, length2);
+#endif
+ str = s;
+ }
+ else
+ str = string2;
+ else
+ str = string1;
+
+ rval = re_search_stub (bufp, str, len, start, range, stop, regs,
+ ret_len);
+ re_free (s);
+ return rval;
+}
+
+/* The parameters have the same meaning as those of re_search.
+ Additional parameters:
+ If RET_LEN is true the length of the match is returned (re_match style);
+ otherwise the position of the match is returned. */
+
+static regoff_t
+re_search_stub (struct re_pattern_buffer *bufp, const char *string, Idx length,
+ Idx start, regoff_t range, Idx stop, struct re_registers *regs,
+ bool ret_len)
+{
+ reg_errcode_t result;
+ regmatch_t *pmatch;
+ Idx nregs;
+ regoff_t rval;
+ int eflags = 0;
+ re_dfa_t *dfa = bufp->buffer;
+ Idx last_start = start + range;
+
+ /* Check for out-of-range. */
+ if (__glibc_unlikely (start < 0 || start > length))
+ return -1;
+ if (__glibc_unlikely (length < last_start
+ || (0 <= range && last_start < start)))
+ last_start = length;
+ else if (__glibc_unlikely (last_start < 0
+ || (range < 0 && start <= last_start)))
+ last_start = 0;
+
+ lock_lock (dfa->lock);
+
+ eflags |= (bufp->not_bol) ? REG_NOTBOL : 0;
+ eflags |= (bufp->not_eol) ? REG_NOTEOL : 0;
+
+ /* Compile fastmap if we haven't yet. */
+ if (start < last_start && bufp->fastmap != NULL && !bufp->fastmap_accurate)
+ re_compile_fastmap (bufp);
+
+ if (__glibc_unlikely (bufp->no_sub))
+ regs = NULL;
+
+ /* We need at least 1 register. */
+ if (regs == NULL)
+ nregs = 1;
+ else if (__glibc_unlikely (bufp->regs_allocated == REGS_FIXED
+ && regs->num_regs <= bufp->re_nsub))
+ {
+ nregs = regs->num_regs;
+ if (__glibc_unlikely (nregs < 1))
+ {
+ /* Nothing can be copied to regs. */
+ regs = NULL;
+ nregs = 1;
+ }
+ }
+ else
+ nregs = bufp->re_nsub + 1;
+ pmatch = re_malloc (regmatch_t, nregs);
+ if (__glibc_unlikely (pmatch == NULL))
+ {
+ rval = -2;
+ goto out;
+ }
+
+ result = re_search_internal (bufp, string, length, start, last_start, stop,
+ nregs, pmatch, eflags);
+
+ rval = 0;
+
+ /* I hope we needn't fill their regs with -1's when no match was found. */
+ if (result != REG_NOERROR)
+ rval = result == REG_NOMATCH ? -1 : -2;
+ else if (regs != NULL)
+ {
+ /* If caller wants register contents data back, copy them. */
+ bufp->regs_allocated = re_copy_regs (regs, pmatch, nregs,
+ bufp->regs_allocated);
+ if (__glibc_unlikely (bufp->regs_allocated == REGS_UNALLOCATED))
+ rval = -2;
+ }
+
+ if (__glibc_likely (rval == 0))
+ {
+ if (ret_len)
+ {
+ assert (pmatch[0].rm_so == start);
+ rval = pmatch[0].rm_eo - start;
+ }
+ else
+ rval = pmatch[0].rm_so;
+ }
+ re_free (pmatch);
+ out:
+ lock_unlock (dfa->lock);
+ return rval;
+}
+
+static unsigned
+re_copy_regs (struct re_registers *regs, regmatch_t *pmatch, Idx nregs,
+ int regs_allocated)
+{
+ int rval = REGS_REALLOCATE;
+ Idx i;
+ Idx need_regs = nregs + 1;
+ /* We need one extra element beyond 'num_regs' for the '-1' marker GNU code
+ uses. */
+
+ /* Have the register data arrays been allocated? */
+ if (regs_allocated == REGS_UNALLOCATED)
+ { /* No. So allocate them with malloc. */
+ regs->start = re_malloc (regoff_t, need_regs);
+ if (__glibc_unlikely (regs->start == NULL))
+ return REGS_UNALLOCATED;
+ regs->end = re_malloc (regoff_t, need_regs);
+ if (__glibc_unlikely (regs->end == NULL))
+ {
+ re_free (regs->start);
+ return REGS_UNALLOCATED;
+ }
+ regs->num_regs = need_regs;
+ }
+ else if (regs_allocated == REGS_REALLOCATE)
+ { /* Yes. If we need more elements than were already
+ allocated, reallocate them. If we need fewer, just
+ leave it alone. */
+ if (__glibc_unlikely (need_regs > regs->num_regs))
+ {
+ regoff_t *new_start = re_realloc (regs->start, regoff_t, need_regs);
+ regoff_t *new_end;
+ if (__glibc_unlikely (new_start == NULL))
+ return REGS_UNALLOCATED;
+ new_end = re_realloc (regs->end, regoff_t, need_regs);
+ if (__glibc_unlikely (new_end == NULL))
+ {
+ re_free (new_start);
+ return REGS_UNALLOCATED;
+ }
+ regs->start = new_start;
+ regs->end = new_end;
+ regs->num_regs = need_regs;
+ }
+ }
+ else
+ {
+ assert (regs_allocated == REGS_FIXED);
+ /* This function may not be called with REGS_FIXED and nregs too big. */
+ assert (regs->num_regs >= nregs);
+ rval = REGS_FIXED;
+ }
+
+ /* Copy the regs. */
+ for (i = 0; i < nregs; ++i)
+ {
+ regs->start[i] = pmatch[i].rm_so;
+ regs->end[i] = pmatch[i].rm_eo;
+ }
+ for ( ; i < regs->num_regs; ++i)
+ regs->start[i] = regs->end[i] = -1;
+
+ return rval;
+}
+
+/* Set REGS to hold NUM_REGS registers, storing them in STARTS and
+ ENDS. Subsequent matches using PATTERN_BUFFER and REGS will use
+ this memory for recording register information. STARTS and ENDS
+ must be allocated using the malloc library routine, and must each
+ be at least NUM_REGS * sizeof (regoff_t) bytes long.
+
+ If NUM_REGS == 0, then subsequent matches should allocate their own
+ register data.
+
+ Unless this function is called, the first search or match using
+ PATTERN_BUFFER will allocate its own register data, without
+ freeing the old data. */
+
+void
+re_set_registers (struct re_pattern_buffer *bufp, struct re_registers *regs,
+ __re_size_t num_regs, regoff_t *starts, regoff_t *ends)
+{
+ if (num_regs)
+ {
+ bufp->regs_allocated = REGS_REALLOCATE;
+ regs->num_regs = num_regs;
+ regs->start = starts;
+ regs->end = ends;
+ }
+ else
+ {
+ bufp->regs_allocated = REGS_UNALLOCATED;
+ regs->num_regs = 0;
+ regs->start = regs->end = NULL;
+ }
+}
+#ifdef _LIBC
+weak_alias (__re_set_registers, re_set_registers)
+#endif
+
+/* Entry points compatible with 4.2 BSD regex library. We don't define
+ them unless specifically requested. */
+
+#if defined _REGEX_RE_COMP || defined _LIBC
+int
+# ifdef _LIBC
+weak_function
+# endif
+re_exec (const char *s)
+{
+ return 0 == regexec (&re_comp_buf, s, 0, NULL, 0);
+}
+#endif /* _REGEX_RE_COMP */
+
+/* Internal entry point. */
+
+/* Searches for a compiled pattern PREG in the string STRING, whose
+ length is LENGTH. NMATCH, PMATCH, and EFLAGS have the same
+ meaning as with regexec. LAST_START is START + RANGE, where
+ START and RANGE have the same meaning as with re_search.
+ Return REG_NOERROR if we find a match, and REG_NOMATCH if not,
+ otherwise return the error code.
+ Note: We assume front end functions already check ranges.
+ (0 <= LAST_START && LAST_START <= LENGTH) */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+re_search_internal (const regex_t *preg, const char *string, Idx length,
+ Idx start, Idx last_start, Idx stop, size_t nmatch,
+ regmatch_t pmatch[], int eflags)
+{
+ reg_errcode_t err;
+ const re_dfa_t *dfa = preg->buffer;
+ Idx left_lim, right_lim;
+ int incr;
+ bool fl_longest_match;
+ int match_kind;
+ Idx match_first;
+ Idx match_last = -1;
+ Idx extra_nmatch;
+ bool sb;
+ int ch;
+#if defined _LIBC || (defined __STDC_VERSION__ && __STDC_VERSION__ >= 199901L)
+ re_match_context_t mctx = { .dfa = dfa };
+#else
+ re_match_context_t mctx;
+#endif
+ char *fastmap = ((preg->fastmap != NULL && preg->fastmap_accurate
+ && start != last_start && !preg->can_be_null)
+ ? preg->fastmap : NULL);
+ RE_TRANSLATE_TYPE t = preg->translate;
+
+#if !(defined _LIBC || (defined __STDC_VERSION__ && __STDC_VERSION__ >= 199901L))
+ memset (&mctx, '\0', sizeof (re_match_context_t));
+ mctx.dfa = dfa;
+#endif
+
+ extra_nmatch = (nmatch > preg->re_nsub) ? nmatch - (preg->re_nsub + 1) : 0;
+ nmatch -= extra_nmatch;
+
+ /* Check if the DFA haven't been compiled. */
+ if (__glibc_unlikely (preg->used == 0 || dfa->init_state == NULL
+ || dfa->init_state_word == NULL
+ || dfa->init_state_nl == NULL
+ || dfa->init_state_begbuf == NULL))
+ return REG_NOMATCH;
+
+#ifdef DEBUG
+ /* We assume front-end functions already check them. */
+ assert (0 <= last_start && last_start <= length);
+#endif
+
+ /* If initial states with non-begbuf contexts have no elements,
+ the regex must be anchored. If preg->newline_anchor is set,
+ we'll never use init_state_nl, so do not check it. */
+ if (dfa->init_state->nodes.nelem == 0
+ && dfa->init_state_word->nodes.nelem == 0
+ && (dfa->init_state_nl->nodes.nelem == 0
+ || !preg->newline_anchor))
+ {
+ if (start != 0 && last_start != 0)
+ return REG_NOMATCH;
+ start = last_start = 0;
+ }
+
+ /* We must check the longest matching, if nmatch > 0. */
+ fl_longest_match = (nmatch != 0 || dfa->nbackref);
+
+ err = re_string_allocate (&mctx.input, string, length, dfa->nodes_len + 1,
+ preg->translate, (preg->syntax & RE_ICASE) != 0,
+ dfa);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ goto free_return;
+ mctx.input.stop = stop;
+ mctx.input.raw_stop = stop;
+ mctx.input.newline_anchor = preg->newline_anchor;
+
+ err = match_ctx_init (&mctx, eflags, dfa->nbackref * 2);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ goto free_return;
+
+ /* We will log all the DFA states through which the dfa pass,
+ if nmatch > 1, or this dfa has "multibyte node", which is a
+ back-reference or a node which can accept multibyte character or
+ multi character collating element. */
+ if (nmatch > 1 || dfa->has_mb_node)
+ {
+ /* Avoid overflow. */
+ if (__glibc_unlikely ((MIN (IDX_MAX, SIZE_MAX / sizeof (re_dfastate_t *))
+ <= mctx.input.bufs_len)))
+ {
+ err = REG_ESPACE;
+ goto free_return;
+ }
+
+ mctx.state_log = re_malloc (re_dfastate_t *, mctx.input.bufs_len + 1);
+ if (__glibc_unlikely (mctx.state_log == NULL))
+ {
+ err = REG_ESPACE;
+ goto free_return;
+ }
+ }
+ else
+ mctx.state_log = NULL;
+
+ match_first = start;
+ mctx.input.tip_context = (eflags & REG_NOTBOL) ? CONTEXT_BEGBUF
+ : CONTEXT_NEWLINE | CONTEXT_BEGBUF;
+
+ /* Check incrementally whether the input string matches. */
+ incr = (last_start < start) ? -1 : 1;
+ left_lim = (last_start < start) ? last_start : start;
+ right_lim = (last_start < start) ? start : last_start;
+ sb = dfa->mb_cur_max == 1;
+ match_kind =
+ (fastmap
+ ? ((sb || !(preg->syntax & RE_ICASE || t) ? 4 : 0)
+ | (start <= last_start ? 2 : 0)
+ | (t != NULL ? 1 : 0))
+ : 8);
+
+ for (;; match_first += incr)
+ {
+ err = REG_NOMATCH;
+ if (match_first < left_lim || right_lim < match_first)
+ goto free_return;
+
+ /* Advance as rapidly as possible through the string, until we
+ find a plausible place to start matching. This may be done
+ with varying efficiency, so there are various possibilities:
+ only the most common of them are specialized, in order to
+ save on code size. We use a switch statement for speed. */
+ switch (match_kind)
+ {
+ case 8:
+ /* No fastmap. */
+ break;
+
+ case 7:
+ /* Fastmap with single-byte translation, match forward. */
+ while (__glibc_likely (match_first < right_lim)
+ && !fastmap[t[(unsigned char) string[match_first]]])
+ ++match_first;
+ goto forward_match_found_start_or_reached_end;
+
+ case 6:
+ /* Fastmap without translation, match forward. */
+ while (__glibc_likely (match_first < right_lim)
+ && !fastmap[(unsigned char) string[match_first]])
+ ++match_first;
+
+ forward_match_found_start_or_reached_end:
+ if (__glibc_unlikely (match_first == right_lim))
+ {
+ ch = match_first >= length
+ ? 0 : (unsigned char) string[match_first];
+ if (!fastmap[t ? t[ch] : ch])
+ goto free_return;
+ }
+ break;
+
+ case 4:
+ case 5:
+ /* Fastmap without multi-byte translation, match backwards. */
+ while (match_first >= left_lim)
+ {
+ ch = match_first >= length
+ ? 0 : (unsigned char) string[match_first];
+ if (fastmap[t ? t[ch] : ch])
+ break;
+ --match_first;
+ }
+ if (match_first < left_lim)
+ goto free_return;
+ break;
+
+ default:
+ /* In this case, we can't determine easily the current byte,
+ since it might be a component byte of a multibyte
+ character. Then we use the constructed buffer instead. */
+ for (;;)
+ {
+ /* If MATCH_FIRST is out of the valid range, reconstruct the
+ buffers. */
+ __re_size_t offset = match_first - mctx.input.raw_mbs_idx;
+ if (__glibc_unlikely (offset
+ >= (__re_size_t) mctx.input.valid_raw_len))
+ {
+ err = re_string_reconstruct (&mctx.input, match_first,
+ eflags);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ goto free_return;
+
+ offset = match_first - mctx.input.raw_mbs_idx;
+ }
+ /* If MATCH_FIRST is out of the buffer, leave it as '\0'.
+ Note that MATCH_FIRST must not be smaller than 0. */
+ ch = (match_first >= length
+ ? 0 : re_string_byte_at (&mctx.input, offset));
+ if (fastmap[ch])
+ break;
+ match_first += incr;
+ if (match_first < left_lim || match_first > right_lim)
+ {
+ err = REG_NOMATCH;
+ goto free_return;
+ }
+ }
+ break;
+ }
+
+ /* Reconstruct the buffers so that the matcher can assume that
+ the matching starts from the beginning of the buffer. */
+ err = re_string_reconstruct (&mctx.input, match_first, eflags);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ goto free_return;
+
+#ifdef RE_ENABLE_I18N
+ /* Don't consider this char as a possible match start if it part,
+ yet isn't the head, of a multibyte character. */
+ if (!sb && !re_string_first_byte (&mctx.input, 0))
+ continue;
+#endif
+
+ /* It seems to be appropriate one, then use the matcher. */
+ /* We assume that the matching starts from 0. */
+ mctx.state_log_top = mctx.nbkref_ents = mctx.max_mb_elem_len = 0;
+ match_last = check_matching (&mctx, fl_longest_match,
+ start <= last_start ? &match_first : NULL);
+ if (match_last != -1)
+ {
+ if (__glibc_unlikely (match_last == -2))
+ {
+ err = REG_ESPACE;
+ goto free_return;
+ }
+ else
+ {
+ mctx.match_last = match_last;
+ if ((!preg->no_sub && nmatch > 1) || dfa->nbackref)
+ {
+ re_dfastate_t *pstate = mctx.state_log[match_last];
+ mctx.last_node = check_halt_state_context (&mctx, pstate,
+ match_last);
+ }
+ if ((!preg->no_sub && nmatch > 1 && dfa->has_plural_match)
+ || dfa->nbackref)
+ {
+ err = prune_impossible_nodes (&mctx);
+ if (err == REG_NOERROR)
+ break;
+ if (__glibc_unlikely (err != REG_NOMATCH))
+ goto free_return;
+ match_last = -1;
+ }
+ else
+ break; /* We found a match. */
+ }
+ }
+
+ match_ctx_clean (&mctx);
+ }
+
+#ifdef DEBUG
+ assert (match_last != -1);
+ assert (err == REG_NOERROR);
+#endif
+
+ /* Set pmatch[] if we need. */
+ if (nmatch > 0)
+ {
+ Idx reg_idx;
+
+ /* Initialize registers. */
+ for (reg_idx = 1; reg_idx < nmatch; ++reg_idx)
+ pmatch[reg_idx].rm_so = pmatch[reg_idx].rm_eo = -1;
+
+ /* Set the points where matching start/end. */
+ pmatch[0].rm_so = 0;
+ pmatch[0].rm_eo = mctx.match_last;
+ /* FIXME: This function should fail if mctx.match_last exceeds
+ the maximum possible regoff_t value. We need a new error
+ code REG_OVERFLOW. */
+
+ if (!preg->no_sub && nmatch > 1)
+ {
+ err = set_regs (preg, &mctx, nmatch, pmatch,
+ dfa->has_plural_match && dfa->nbackref > 0);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ goto free_return;
+ }
+
+ /* At last, add the offset to each register, since we slid
+ the buffers so that we could assume that the matching starts
+ from 0. */
+ for (reg_idx = 0; reg_idx < nmatch; ++reg_idx)
+ if (pmatch[reg_idx].rm_so != -1)
+ {
+#ifdef RE_ENABLE_I18N
+ if (__glibc_unlikely (mctx.input.offsets_needed != 0))
+ {
+ pmatch[reg_idx].rm_so =
+ (pmatch[reg_idx].rm_so == mctx.input.valid_len
+ ? mctx.input.valid_raw_len
+ : mctx.input.offsets[pmatch[reg_idx].rm_so]);
+ pmatch[reg_idx].rm_eo =
+ (pmatch[reg_idx].rm_eo == mctx.input.valid_len
+ ? mctx.input.valid_raw_len
+ : mctx.input.offsets[pmatch[reg_idx].rm_eo]);
+ }
+#else
+ assert (mctx.input.offsets_needed == 0);
+#endif
+ pmatch[reg_idx].rm_so += match_first;
+ pmatch[reg_idx].rm_eo += match_first;
+ }
+ for (reg_idx = 0; reg_idx < extra_nmatch; ++reg_idx)
+ {
+ pmatch[nmatch + reg_idx].rm_so = -1;
+ pmatch[nmatch + reg_idx].rm_eo = -1;
+ }
+
+ if (dfa->subexp_map)
+ for (reg_idx = 0; reg_idx + 1 < nmatch; reg_idx++)
+ if (dfa->subexp_map[reg_idx] != reg_idx)
+ {
+ pmatch[reg_idx + 1].rm_so
+ = pmatch[dfa->subexp_map[reg_idx] + 1].rm_so;
+ pmatch[reg_idx + 1].rm_eo
+ = pmatch[dfa->subexp_map[reg_idx] + 1].rm_eo;
+ }
+ }
+
+ free_return:
+ re_free (mctx.state_log);
+ if (dfa->nbackref)
+ match_ctx_free (&mctx);
+ re_string_destruct (&mctx.input);
+ return err;
+}
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+prune_impossible_nodes (re_match_context_t *mctx)
+{
+ const re_dfa_t *const dfa = mctx->dfa;
+ Idx halt_node, match_last;
+ reg_errcode_t ret;
+ re_dfastate_t **sifted_states;
+ re_dfastate_t **lim_states = NULL;
+ re_sift_context_t sctx;
+#ifdef DEBUG
+ assert (mctx->state_log != NULL);
+#endif
+ match_last = mctx->match_last;
+ halt_node = mctx->last_node;
+
+ /* Avoid overflow. */
+ if (__glibc_unlikely (MIN (IDX_MAX, SIZE_MAX / sizeof (re_dfastate_t *))
+ <= match_last))
+ return REG_ESPACE;
+
+ sifted_states = re_malloc (re_dfastate_t *, match_last + 1);
+ if (__glibc_unlikely (sifted_states == NULL))
+ {
+ ret = REG_ESPACE;
+ goto free_return;
+ }
+ if (dfa->nbackref)
+ {
+ lim_states = re_malloc (re_dfastate_t *, match_last + 1);
+ if (__glibc_unlikely (lim_states == NULL))
+ {
+ ret = REG_ESPACE;
+ goto free_return;
+ }
+ while (1)
+ {
+ memset (lim_states, '\0',
+ sizeof (re_dfastate_t *) * (match_last + 1));
+ sift_ctx_init (&sctx, sifted_states, lim_states, halt_node,
+ match_last);
+ ret = sift_states_backward (mctx, &sctx);
+ re_node_set_free (&sctx.limits);
+ if (__glibc_unlikely (ret != REG_NOERROR))
+ goto free_return;
+ if (sifted_states[0] != NULL || lim_states[0] != NULL)
+ break;
+ do
+ {
+ --match_last;
+ if (match_last < 0)
+ {
+ ret = REG_NOMATCH;
+ goto free_return;
+ }
+ } while (mctx->state_log[match_last] == NULL
+ || !mctx->state_log[match_last]->halt);
+ halt_node = check_halt_state_context (mctx,
+ mctx->state_log[match_last],
+ match_last);
+ }
+ ret = merge_state_array (dfa, sifted_states, lim_states,
+ match_last + 1);
+ re_free (lim_states);
+ lim_states = NULL;
+ if (__glibc_unlikely (ret != REG_NOERROR))
+ goto free_return;
+ }
+ else
+ {
+ sift_ctx_init (&sctx, sifted_states, lim_states, halt_node, match_last);
+ ret = sift_states_backward (mctx, &sctx);
+ re_node_set_free (&sctx.limits);
+ if (__glibc_unlikely (ret != REG_NOERROR))
+ goto free_return;
+ if (sifted_states[0] == NULL)
+ {
+ ret = REG_NOMATCH;
+ goto free_return;
+ }
+ }
+ re_free (mctx->state_log);
+ mctx->state_log = sifted_states;
+ sifted_states = NULL;
+ mctx->last_node = halt_node;
+ mctx->match_last = match_last;
+ ret = REG_NOERROR;
+ free_return:
+ re_free (sifted_states);
+ re_free (lim_states);
+ return ret;
+}
+
+/* Acquire an initial state and return it.
+ We must select appropriate initial state depending on the context,
+ since initial states may have constraints like "\<", "^", etc.. */
+
+static inline re_dfastate_t *
+__attribute__ ((always_inline))
+acquire_init_state_context (reg_errcode_t *err, const re_match_context_t *mctx,
+ Idx idx)
+{
+ const re_dfa_t *const dfa = mctx->dfa;
+ if (dfa->init_state->has_constraint)
+ {
+ unsigned int context;
+ context = re_string_context_at (&mctx->input, idx - 1, mctx->eflags);
+ if (IS_WORD_CONTEXT (context))
+ return dfa->init_state_word;
+ else if (IS_ORDINARY_CONTEXT (context))
+ return dfa->init_state;
+ else if (IS_BEGBUF_CONTEXT (context) && IS_NEWLINE_CONTEXT (context))
+ return dfa->init_state_begbuf;
+ else if (IS_NEWLINE_CONTEXT (context))
+ return dfa->init_state_nl;
+ else if (IS_BEGBUF_CONTEXT (context))
+ {
+ /* It is relatively rare case, then calculate on demand. */
+ return re_acquire_state_context (err, dfa,
+ dfa->init_state->entrance_nodes,
+ context);
+ }
+ else
+ /* Must not happen? */
+ return dfa->init_state;
+ }
+ else
+ return dfa->init_state;
+}
+
+/* Check whether the regular expression match input string INPUT or not,
+ and return the index where the matching end. Return -1 if
+ there is no match, and return -2 in case of an error.
+ FL_LONGEST_MATCH means we want the POSIX longest matching.
+ If P_MATCH_FIRST is not NULL, and the match fails, it is set to the
+ next place where we may want to try matching.
+ Note that the matcher assumes that the matching starts from the current
+ index of the buffer. */
+
+static Idx
+__attribute_warn_unused_result__
+check_matching (re_match_context_t *mctx, bool fl_longest_match,
+ Idx *p_match_first)
+{
+ const re_dfa_t *const dfa = mctx->dfa;
+ reg_errcode_t err;
+ Idx match = 0;
+ Idx match_last = -1;
+ Idx cur_str_idx = re_string_cur_idx (&mctx->input);
+ re_dfastate_t *cur_state;
+ bool at_init_state = p_match_first != NULL;
+ Idx next_start_idx = cur_str_idx;
+
+ err = REG_NOERROR;
+ cur_state = acquire_init_state_context (&err, mctx, cur_str_idx);
+ /* An initial state must not be NULL (invalid). */
+ if (__glibc_unlikely (cur_state == NULL))
+ {
+ assert (err == REG_ESPACE);
+ return -2;
+ }
+
+ if (mctx->state_log != NULL)
+ {
+ mctx->state_log[cur_str_idx] = cur_state;
+
+ /* Check OP_OPEN_SUBEXP in the initial state in case that we use them
+ later. E.g. Processing back references. */
+ if (__glibc_unlikely (dfa->nbackref))
+ {
+ at_init_state = false;
+ err = check_subexp_matching_top (mctx, &cur_state->nodes, 0);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+
+ if (cur_state->has_backref)
+ {
+ err = transit_state_bkref (mctx, &cur_state->nodes);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ }
+ }
+ }
+
+ /* If the RE accepts NULL string. */
+ if (__glibc_unlikely (cur_state->halt))
+ {
+ if (!cur_state->has_constraint
+ || check_halt_state_context (mctx, cur_state, cur_str_idx))
+ {
+ if (!fl_longest_match)
+ return cur_str_idx;
+ else
+ {
+ match_last = cur_str_idx;
+ match = 1;
+ }
+ }
+ }
+
+ while (!re_string_eoi (&mctx->input))
+ {
+ re_dfastate_t *old_state = cur_state;
+ Idx next_char_idx = re_string_cur_idx (&mctx->input) + 1;
+
+ if ((__glibc_unlikely (next_char_idx >= mctx->input.bufs_len)
+ && mctx->input.bufs_len < mctx->input.len)
+ || (__glibc_unlikely (next_char_idx >= mctx->input.valid_len)
+ && mctx->input.valid_len < mctx->input.len))
+ {
+ err = extend_buffers (mctx, next_char_idx + 1);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ {
+ assert (err == REG_ESPACE);
+ return -2;
+ }
+ }
+
+ cur_state = transit_state (&err, mctx, cur_state);
+ if (mctx->state_log != NULL)
+ cur_state = merge_state_with_log (&err, mctx, cur_state);
+
+ if (cur_state == NULL)
+ {
+ /* Reached the invalid state or an error. Try to recover a valid
+ state using the state log, if available and if we have not
+ already found a valid (even if not the longest) match. */
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return -2;
+
+ if (mctx->state_log == NULL
+ || (match && !fl_longest_match)
+ || (cur_state = find_recover_state (&err, mctx)) == NULL)
+ break;
+ }
+
+ if (__glibc_unlikely (at_init_state))
+ {
+ if (old_state == cur_state)
+ next_start_idx = next_char_idx;
+ else
+ at_init_state = false;
+ }
+
+ if (cur_state->halt)
+ {
+ /* Reached a halt state.
+ Check the halt state can satisfy the current context. */
+ if (!cur_state->has_constraint
+ || check_halt_state_context (mctx, cur_state,
+ re_string_cur_idx (&mctx->input)))
+ {
+ /* We found an appropriate halt state. */
+ match_last = re_string_cur_idx (&mctx->input);
+ match = 1;
+
+ /* We found a match, do not modify match_first below. */
+ p_match_first = NULL;
+ if (!fl_longest_match)
+ break;
+ }
+ }
+ }
+
+ if (p_match_first)
+ *p_match_first += next_start_idx;
+
+ return match_last;
+}
+
+/* Check NODE match the current context. */
+
+static bool
+check_halt_node_context (const re_dfa_t *dfa, Idx node, unsigned int context)
+{
+ re_token_type_t type = dfa->nodes[node].type;
+ unsigned int constraint = dfa->nodes[node].constraint;
+ if (type != END_OF_RE)
+ return false;
+ if (!constraint)
+ return true;
+ if (NOT_SATISFY_NEXT_CONSTRAINT (constraint, context))
+ return false;
+ return true;
+}
+
+/* Check the halt state STATE match the current context.
+ Return 0 if not match, if the node, STATE has, is a halt node and
+ match the context, return the node. */
+
+static Idx
+check_halt_state_context (const re_match_context_t *mctx,
+ const re_dfastate_t *state, Idx idx)
+{
+ Idx i;
+ unsigned int context;
+#ifdef DEBUG
+ assert (state->halt);
+#endif
+ context = re_string_context_at (&mctx->input, idx, mctx->eflags);
+ for (i = 0; i < state->nodes.nelem; ++i)
+ if (check_halt_node_context (mctx->dfa, state->nodes.elems[i], context))
+ return state->nodes.elems[i];
+ return 0;
+}
+
+/* Compute the next node to which "NFA" transit from NODE("NFA" is a NFA
+ corresponding to the DFA).
+ Return the destination node, and update EPS_VIA_NODES;
+ return -1 in case of errors. */
+
+static Idx
+proceed_next_node (const re_match_context_t *mctx, Idx nregs, regmatch_t *regs,
+ Idx *pidx, Idx node, re_node_set *eps_via_nodes,
+ struct re_fail_stack_t *fs)
+{
+ const re_dfa_t *const dfa = mctx->dfa;
+ Idx i;
+ bool ok;
+ if (IS_EPSILON_NODE (dfa->nodes[node].type))
+ {
+ re_node_set *cur_nodes = &mctx->state_log[*pidx]->nodes;
+ re_node_set *edests = &dfa->edests[node];
+ Idx dest_node;
+ ok = re_node_set_insert (eps_via_nodes, node);
+ if (__glibc_unlikely (! ok))
+ return -2;
+ /* Pick up a valid destination, or return -1 if none
+ is found. */
+ for (dest_node = -1, i = 0; i < edests->nelem; ++i)
+ {
+ Idx candidate = edests->elems[i];
+ if (!re_node_set_contains (cur_nodes, candidate))
+ continue;
+ if (dest_node == -1)
+ dest_node = candidate;
+
+ else
+ {
+ /* In order to avoid infinite loop like "(a*)*", return the second
+ epsilon-transition if the first was already considered. */
+ if (re_node_set_contains (eps_via_nodes, dest_node))
+ return candidate;
+
+ /* Otherwise, push the second epsilon-transition on the fail stack. */
+ else if (fs != NULL
+ && push_fail_stack (fs, *pidx, candidate, nregs, regs,
+ eps_via_nodes))
+ return -2;
+
+ /* We know we are going to exit. */
+ break;
+ }
+ }
+ return dest_node;
+ }
+ else
+ {
+ Idx naccepted = 0;
+ re_token_type_t type = dfa->nodes[node].type;
+
+#ifdef RE_ENABLE_I18N
+ if (dfa->nodes[node].accept_mb)
+ naccepted = check_node_accept_bytes (dfa, node, &mctx->input, *pidx);
+ else
+#endif /* RE_ENABLE_I18N */
+ if (type == OP_BACK_REF)
+ {
+ Idx subexp_idx = dfa->nodes[node].opr.idx + 1;
+ naccepted = regs[subexp_idx].rm_eo - regs[subexp_idx].rm_so;
+ if (fs != NULL)
+ {
+ if (regs[subexp_idx].rm_so == -1 || regs[subexp_idx].rm_eo == -1)
+ return -1;
+ else if (naccepted)
+ {
+ char *buf = (char *) re_string_get_buffer (&mctx->input);
+ if (mctx->input.valid_len - *pidx < naccepted
+ || (memcmp (buf + regs[subexp_idx].rm_so, buf + *pidx,
+ naccepted)
+ != 0))
+ return -1;
+ }
+ }
+
+ if (naccepted == 0)
+ {
+ Idx dest_node;
+ ok = re_node_set_insert (eps_via_nodes, node);
+ if (__glibc_unlikely (! ok))
+ return -2;
+ dest_node = dfa->edests[node].elems[0];
+ if (re_node_set_contains (&mctx->state_log[*pidx]->nodes,
+ dest_node))
+ return dest_node;
+ }
+ }
+
+ if (naccepted != 0
+ || check_node_accept (mctx, dfa->nodes + node, *pidx))
+ {
+ Idx dest_node = dfa->nexts[node];
+ *pidx = (naccepted == 0) ? *pidx + 1 : *pidx + naccepted;
+ if (fs && (*pidx > mctx->match_last || mctx->state_log[*pidx] == NULL
+ || !re_node_set_contains (&mctx->state_log[*pidx]->nodes,
+ dest_node)))
+ return -1;
+ re_node_set_empty (eps_via_nodes);
+ return dest_node;
+ }
+ }
+ return -1;
+}
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+push_fail_stack (struct re_fail_stack_t *fs, Idx str_idx, Idx dest_node,
+ Idx nregs, regmatch_t *regs, re_node_set *eps_via_nodes)
+{
+ reg_errcode_t err;
+ Idx num = fs->num++;
+ if (fs->num == fs->alloc)
+ {
+ struct re_fail_stack_ent_t *new_array;
+ new_array = re_realloc (fs->stack, struct re_fail_stack_ent_t,
+ fs->alloc * 2);
+ if (new_array == NULL)
+ return REG_ESPACE;
+ fs->alloc *= 2;
+ fs->stack = new_array;
+ }
+ fs->stack[num].idx = str_idx;
+ fs->stack[num].node = dest_node;
+ fs->stack[num].regs = re_malloc (regmatch_t, nregs);
+ if (fs->stack[num].regs == NULL)
+ return REG_ESPACE;
+ memcpy (fs->stack[num].regs, regs, sizeof (regmatch_t) * nregs);
+ err = re_node_set_init_copy (&fs->stack[num].eps_via_nodes, eps_via_nodes);
+ return err;
+}
+
+static Idx
+pop_fail_stack (struct re_fail_stack_t *fs, Idx *pidx, Idx nregs,
+ regmatch_t *regs, re_node_set *eps_via_nodes)
+{
+ Idx num = --fs->num;
+ assert (num >= 0);
+ *pidx = fs->stack[num].idx;
+ memcpy (regs, fs->stack[num].regs, sizeof (regmatch_t) * nregs);
+ re_node_set_free (eps_via_nodes);
+ re_free (fs->stack[num].regs);
+ *eps_via_nodes = fs->stack[num].eps_via_nodes;
+ return fs->stack[num].node;
+}
+
+/* Set the positions where the subexpressions are starts/ends to registers
+ PMATCH.
+ Note: We assume that pmatch[0] is already set, and
+ pmatch[i].rm_so == pmatch[i].rm_eo == -1 for 0 < i < nmatch. */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch,
+ regmatch_t *pmatch, bool fl_backtrack)
+{
+ const re_dfa_t *dfa = preg->buffer;
+ Idx idx, cur_node;
+ 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;
+
+#ifdef DEBUG
+ assert (nmatch > 1);
+ assert (mctx->state_log != NULL);
+#endif
+ if (fl_backtrack)
+ {
+ fs = &fs_body;
+ fs->stack = re_malloc (struct re_fail_stack_ent_t, fs->alloc);
+ if (fs->stack == NULL)
+ return REG_ESPACE;
+ }
+ else
+ fs = NULL;
+
+ 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
+ {
+ 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;
+ }
+ memcpy (prev_idx_match, pmatch, sizeof (regmatch_t) * nmatch);
+
+ for (idx = pmatch[0].rm_so; idx <= pmatch[0].rm_eo ;)
+ {
+ update_regs (dfa, pmatch, prev_idx_match, cur_node, idx, nmatch);
+
+ if (idx == pmatch[0].rm_eo && cur_node == mctx->last_node)
+ {
+ Idx reg_idx;
+ if (fs)
+ {
+ for (reg_idx = 0; reg_idx < nmatch; ++reg_idx)
+ if (pmatch[reg_idx].rm_so > -1 && pmatch[reg_idx].rm_eo == -1)
+ break;
+ if (reg_idx == nmatch)
+ {
+ re_node_set_free (&eps_via_nodes);
+ if (prev_idx_match_malloced)
+ re_free (prev_idx_match);
+ return free_fail_stack_return (fs);
+ }
+ cur_node = pop_fail_stack (fs, &idx, nmatch, pmatch,
+ &eps_via_nodes);
+ }
+ else
+ {
+ re_node_set_free (&eps_via_nodes);
+ if (prev_idx_match_malloced)
+ re_free (prev_idx_match);
+ return REG_NOERROR;
+ }
+ }
+
+ /* Proceed to next node. */
+ cur_node = proceed_next_node (mctx, nmatch, pmatch, &idx, cur_node,
+ &eps_via_nodes, fs);
+
+ if (__glibc_unlikely (cur_node < 0))
+ {
+ if (__glibc_unlikely (cur_node == -2))
+ {
+ re_node_set_free (&eps_via_nodes);
+ if (prev_idx_match_malloced)
+ re_free (prev_idx_match);
+ free_fail_stack_return (fs);
+ return REG_ESPACE;
+ }
+ if (fs)
+ cur_node = pop_fail_stack (fs, &idx, nmatch, pmatch,
+ &eps_via_nodes);
+ else
+ {
+ re_node_set_free (&eps_via_nodes);
+ if (prev_idx_match_malloced)
+ re_free (prev_idx_match);
+ return REG_NOMATCH;
+ }
+ }
+ }
+ re_node_set_free (&eps_via_nodes);
+ if (prev_idx_match_malloced)
+ re_free (prev_idx_match);
+ return free_fail_stack_return (fs);
+}
+
+static reg_errcode_t
+free_fail_stack_return (struct re_fail_stack_t *fs)
+{
+ if (fs)
+ {
+ Idx fs_idx;
+ for (fs_idx = 0; fs_idx < fs->num; ++fs_idx)
+ {
+ re_node_set_free (&fs->stack[fs_idx].eps_via_nodes);
+ re_free (fs->stack[fs_idx].regs);
+ }
+ re_free (fs->stack);
+ }
+ return REG_NOERROR;
+}
+
+static void
+update_regs (const re_dfa_t *dfa, regmatch_t *pmatch,
+ regmatch_t *prev_idx_match, Idx cur_node, Idx cur_idx, Idx nmatch)
+{
+ int type = dfa->nodes[cur_node].type;
+ if (type == OP_OPEN_SUBEXP)
+ {
+ Idx reg_num = dfa->nodes[cur_node].opr.idx + 1;
+
+ /* We are at the first node of this sub expression. */
+ if (reg_num < nmatch)
+ {
+ pmatch[reg_num].rm_so = cur_idx;
+ pmatch[reg_num].rm_eo = -1;
+ }
+ }
+ else if (type == OP_CLOSE_SUBEXP)
+ {
+ Idx reg_num = dfa->nodes[cur_node].opr.idx + 1;
+ if (reg_num < nmatch)
+ {
+ /* We are at the last node of this sub expression. */
+ if (pmatch[reg_num].rm_so < cur_idx)
+ {
+ pmatch[reg_num].rm_eo = cur_idx;
+ /* This is a non-empty match or we are not inside an optional
+ subexpression. Accept this right away. */
+ memcpy (prev_idx_match, pmatch, sizeof (regmatch_t) * nmatch);
+ }
+ else
+ {
+ if (dfa->nodes[cur_node].opt_subexp
+ && prev_idx_match[reg_num].rm_so != -1)
+ /* We transited through an empty match for an optional
+ subexpression, like (a?)*, and this is not the subexp's
+ first match. Copy back the old content of the registers
+ so that matches of an inner subexpression are undone as
+ well, like in ((a?))*. */
+ memcpy (pmatch, prev_idx_match, sizeof (regmatch_t) * nmatch);
+ else
+ /* We completed a subexpression, but it may be part of
+ an optional one, so do not update PREV_IDX_MATCH. */
+ pmatch[reg_num].rm_eo = cur_idx;
+ }
+ }
+ }
+}
+
+/* This function checks the STATE_LOG from the SCTX->last_str_idx to 0
+ and sift the nodes in each states according to the following rules.
+ Updated state_log will be wrote to STATE_LOG.
+
+ Rules: We throw away the Node 'a' in the STATE_LOG[STR_IDX] if...
+ 1. When STR_IDX == MATCH_LAST(the last index in the state_log):
+ If 'a' isn't the LAST_NODE and 'a' can't epsilon transit to
+ the LAST_NODE, we throw away the node 'a'.
+ 2. When 0 <= STR_IDX < MATCH_LAST and 'a' accepts
+ string 's' and transit to 'b':
+ i. If 'b' isn't in the STATE_LOG[STR_IDX+strlen('s')], we throw
+ away the node 'a'.
+ ii. If 'b' is in the STATE_LOG[STR_IDX+strlen('s')] but 'b' is
+ thrown away, we throw away the node 'a'.
+ 3. When 0 <= STR_IDX < MATCH_LAST and 'a' epsilon transit to 'b':
+ i. If 'b' isn't in the STATE_LOG[STR_IDX], we throw away the
+ node 'a'.
+ ii. If 'b' is in the STATE_LOG[STR_IDX] but 'b' is thrown away,
+ we throw away the node 'a'. */
+
+#define STATE_NODE_CONTAINS(state,node) \
+ ((state) != NULL && re_node_set_contains (&(state)->nodes, node))
+
+static reg_errcode_t
+sift_states_backward (const re_match_context_t *mctx, re_sift_context_t *sctx)
+{
+ reg_errcode_t err;
+ int null_cnt = 0;
+ Idx str_idx = sctx->last_str_idx;
+ re_node_set cur_dest;
+
+#ifdef DEBUG
+ assert (mctx->state_log != NULL && mctx->state_log[str_idx] != NULL);
+#endif
+
+ /* Build sifted state_log[str_idx]. It has the nodes which can epsilon
+ transit to the last_node and the last_node itself. */
+ err = re_node_set_init_1 (&cur_dest, sctx->last_node);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ err = update_cur_sifted_state (mctx, sctx, str_idx, &cur_dest);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ goto free_return;
+
+ /* Then check each states in the state_log. */
+ while (str_idx > 0)
+ {
+ /* Update counters. */
+ null_cnt = (sctx->sifted_states[str_idx] == NULL) ? null_cnt + 1 : 0;
+ if (null_cnt > mctx->max_mb_elem_len)
+ {
+ memset (sctx->sifted_states, '\0',
+ sizeof (re_dfastate_t *) * str_idx);
+ re_node_set_free (&cur_dest);
+ return REG_NOERROR;
+ }
+ re_node_set_empty (&cur_dest);
+ --str_idx;
+
+ if (mctx->state_log[str_idx])
+ {
+ err = build_sifted_states (mctx, sctx, str_idx, &cur_dest);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ goto free_return;
+ }
+
+ /* Add all the nodes which satisfy the following conditions:
+ - It can epsilon transit to a node in CUR_DEST.
+ - It is in CUR_SRC.
+ And update state_log. */
+ err = update_cur_sifted_state (mctx, sctx, str_idx, &cur_dest);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ goto free_return;
+ }
+ err = REG_NOERROR;
+ free_return:
+ re_node_set_free (&cur_dest);
+ return err;
+}
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+build_sifted_states (const re_match_context_t *mctx, re_sift_context_t *sctx,
+ Idx str_idx, re_node_set *cur_dest)
+{
+ const re_dfa_t *const dfa = mctx->dfa;
+ const re_node_set *cur_src = &mctx->state_log[str_idx]->non_eps_nodes;
+ Idx i;
+
+ /* Then build the next sifted state.
+ We build the next sifted state on 'cur_dest', and update
+ 'sifted_states[str_idx]' with 'cur_dest'.
+ Note:
+ 'cur_dest' is the sifted state from 'state_log[str_idx + 1]'.
+ 'cur_src' points the node_set of the old 'state_log[str_idx]'
+ (with the epsilon nodes pre-filtered out). */
+ for (i = 0; i < cur_src->nelem; i++)
+ {
+ Idx prev_node = cur_src->elems[i];
+ int naccepted = 0;
+ bool ok;
+
+#ifdef DEBUG
+ re_token_type_t type = dfa->nodes[prev_node].type;
+ assert (!IS_EPSILON_NODE (type));
+#endif
+#ifdef RE_ENABLE_I18N
+ /* If the node may accept "multi byte". */
+ if (dfa->nodes[prev_node].accept_mb)
+ naccepted = sift_states_iter_mb (mctx, sctx, prev_node,
+ str_idx, sctx->last_str_idx);
+#endif /* RE_ENABLE_I18N */
+
+ /* We don't check backreferences here.
+ See update_cur_sifted_state(). */
+ if (!naccepted
+ && check_node_accept (mctx, dfa->nodes + prev_node, str_idx)
+ && STATE_NODE_CONTAINS (sctx->sifted_states[str_idx + 1],
+ dfa->nexts[prev_node]))
+ naccepted = 1;
+
+ if (naccepted == 0)
+ continue;
+
+ if (sctx->limits.nelem)
+ {
+ Idx to_idx = str_idx + naccepted;
+ if (check_dst_limits (mctx, &sctx->limits,
+ dfa->nexts[prev_node], to_idx,
+ prev_node, str_idx))
+ continue;
+ }
+ ok = re_node_set_insert (cur_dest, prev_node);
+ if (__glibc_unlikely (! ok))
+ return REG_ESPACE;
+ }
+
+ return REG_NOERROR;
+}
+
+/* Helper functions. */
+
+static reg_errcode_t
+clean_state_log_if_needed (re_match_context_t *mctx, Idx next_state_log_idx)
+{
+ Idx top = mctx->state_log_top;
+
+ if ((next_state_log_idx >= mctx->input.bufs_len
+ && mctx->input.bufs_len < mctx->input.len)
+ || (next_state_log_idx >= mctx->input.valid_len
+ && mctx->input.valid_len < mctx->input.len))
+ {
+ reg_errcode_t err;
+ err = extend_buffers (mctx, next_state_log_idx + 1);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ }
+
+ if (top < next_state_log_idx)
+ {
+ memset (mctx->state_log + top + 1, '\0',
+ sizeof (re_dfastate_t *) * (next_state_log_idx - top));
+ mctx->state_log_top = next_state_log_idx;
+ }
+ return REG_NOERROR;
+}
+
+static reg_errcode_t
+merge_state_array (const re_dfa_t *dfa, re_dfastate_t **dst,
+ re_dfastate_t **src, Idx num)
+{
+ Idx st_idx;
+ reg_errcode_t err;
+ for (st_idx = 0; st_idx < num; ++st_idx)
+ {
+ if (dst[st_idx] == NULL)
+ dst[st_idx] = src[st_idx];
+ else if (src[st_idx] != NULL)
+ {
+ re_node_set merged_set;
+ err = re_node_set_init_union (&merged_set, &dst[st_idx]->nodes,
+ &src[st_idx]->nodes);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ dst[st_idx] = re_acquire_state (&err, dfa, &merged_set);
+ re_node_set_free (&merged_set);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ }
+ }
+ return REG_NOERROR;
+}
+
+static reg_errcode_t
+update_cur_sifted_state (const re_match_context_t *mctx,
+ re_sift_context_t *sctx, Idx str_idx,
+ re_node_set *dest_nodes)
+{
+ const re_dfa_t *const dfa = mctx->dfa;
+ reg_errcode_t err = REG_NOERROR;
+ const re_node_set *candidates;
+ candidates = ((mctx->state_log[str_idx] == NULL) ? NULL
+ : &mctx->state_log[str_idx]->nodes);
+
+ if (dest_nodes->nelem == 0)
+ sctx->sifted_states[str_idx] = NULL;
+ else
+ {
+ if (candidates)
+ {
+ /* At first, add the nodes which can epsilon transit to a node in
+ DEST_NODE. */
+ err = add_epsilon_src_nodes (dfa, dest_nodes, candidates);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+
+ /* Then, check the limitations in the current sift_context. */
+ if (sctx->limits.nelem)
+ {
+ err = check_subexp_limits (dfa, dest_nodes, candidates, &sctx->limits,
+ mctx->bkref_ents, str_idx);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ }
+ }
+
+ sctx->sifted_states[str_idx] = re_acquire_state (&err, dfa, dest_nodes);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ }
+
+ if (candidates && mctx->state_log[str_idx]->has_backref)
+ {
+ err = sift_states_bkref (mctx, sctx, str_idx, candidates);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ }
+ return REG_NOERROR;
+}
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+add_epsilon_src_nodes (const re_dfa_t *dfa, re_node_set *dest_nodes,
+ const re_node_set *candidates)
+{
+ reg_errcode_t err = REG_NOERROR;
+ Idx i;
+
+ re_dfastate_t *state = re_acquire_state (&err, dfa, dest_nodes);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+
+ if (!state->inveclosure.alloc)
+ {
+ err = re_node_set_alloc (&state->inveclosure, dest_nodes->nelem);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return REG_ESPACE;
+ for (i = 0; i < dest_nodes->nelem; i++)
+ {
+ err = re_node_set_merge (&state->inveclosure,
+ dfa->inveclosures + dest_nodes->elems[i]);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return REG_ESPACE;
+ }
+ }
+ return re_node_set_add_intersect (dest_nodes, candidates,
+ &state->inveclosure);
+}
+
+static reg_errcode_t
+sub_epsilon_src_nodes (const re_dfa_t *dfa, Idx node, re_node_set *dest_nodes,
+ const re_node_set *candidates)
+{
+ Idx ecl_idx;
+ reg_errcode_t err;
+ re_node_set *inv_eclosure = dfa->inveclosures + node;
+ re_node_set except_nodes;
+ re_node_set_init_empty (&except_nodes);
+ for (ecl_idx = 0; ecl_idx < inv_eclosure->nelem; ++ecl_idx)
+ {
+ Idx cur_node = inv_eclosure->elems[ecl_idx];
+ if (cur_node == node)
+ continue;
+ if (IS_EPSILON_NODE (dfa->nodes[cur_node].type))
+ {
+ Idx edst1 = dfa->edests[cur_node].elems[0];
+ Idx edst2 = ((dfa->edests[cur_node].nelem > 1)
+ ? dfa->edests[cur_node].elems[1] : -1);
+ if ((!re_node_set_contains (inv_eclosure, edst1)
+ && re_node_set_contains (dest_nodes, edst1))
+ || (edst2 > 0
+ && !re_node_set_contains (inv_eclosure, edst2)
+ && re_node_set_contains (dest_nodes, edst2)))
+ {
+ err = re_node_set_add_intersect (&except_nodes, candidates,
+ dfa->inveclosures + cur_node);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ {
+ re_node_set_free (&except_nodes);
+ return err;
+ }
+ }
+ }
+ }
+ for (ecl_idx = 0; ecl_idx < inv_eclosure->nelem; ++ecl_idx)
+ {
+ Idx cur_node = inv_eclosure->elems[ecl_idx];
+ if (!re_node_set_contains (&except_nodes, cur_node))
+ {
+ Idx idx = re_node_set_contains (dest_nodes, cur_node) - 1;
+ re_node_set_remove_at (dest_nodes, idx);
+ }
+ }
+ re_node_set_free (&except_nodes);
+ return REG_NOERROR;
+}
+
+static bool
+check_dst_limits (const re_match_context_t *mctx, const re_node_set *limits,
+ Idx dst_node, Idx dst_idx, Idx src_node, Idx src_idx)
+{
+ const re_dfa_t *const dfa = mctx->dfa;
+ Idx lim_idx, src_pos, dst_pos;
+
+ Idx dst_bkref_idx = search_cur_bkref_entry (mctx, dst_idx);
+ Idx src_bkref_idx = search_cur_bkref_entry (mctx, src_idx);
+ for (lim_idx = 0; lim_idx < limits->nelem; ++lim_idx)
+ {
+ Idx subexp_idx;
+ struct re_backref_cache_entry *ent;
+ ent = mctx->bkref_ents + limits->elems[lim_idx];
+ subexp_idx = dfa->nodes[ent->node].opr.idx;
+
+ dst_pos = check_dst_limits_calc_pos (mctx, limits->elems[lim_idx],
+ subexp_idx, dst_node, dst_idx,
+ dst_bkref_idx);
+ src_pos = check_dst_limits_calc_pos (mctx, limits->elems[lim_idx],
+ subexp_idx, src_node, src_idx,
+ src_bkref_idx);
+
+ /* In case of:
+ <src> <dst> ( <subexp> )
+ ( <subexp> ) <src> <dst>
+ ( <subexp1> <src> <subexp2> <dst> <subexp3> ) */
+ if (src_pos == dst_pos)
+ continue; /* This is unrelated limitation. */
+ else
+ return true;
+ }
+ return false;
+}
+
+static int
+check_dst_limits_calc_pos_1 (const re_match_context_t *mctx, int boundaries,
+ Idx subexp_idx, Idx from_node, Idx bkref_idx)
+{
+ const re_dfa_t *const dfa = mctx->dfa;
+ const re_node_set *eclosures = dfa->eclosures + from_node;
+ Idx node_idx;
+
+ /* Else, we are on the boundary: examine the nodes on the epsilon
+ closure. */
+ for (node_idx = 0; node_idx < eclosures->nelem; ++node_idx)
+ {
+ Idx node = eclosures->elems[node_idx];
+ switch (dfa->nodes[node].type)
+ {
+ case OP_BACK_REF:
+ if (bkref_idx != -1)
+ {
+ struct re_backref_cache_entry *ent = mctx->bkref_ents + bkref_idx;
+ do
+ {
+ Idx dst;
+ int cpos;
+
+ if (ent->node != node)
+ continue;
+
+ if (subexp_idx < BITSET_WORD_BITS
+ && !(ent->eps_reachable_subexps_map
+ & ((bitset_word_t) 1 << subexp_idx)))
+ continue;
+
+ /* Recurse trying to reach the OP_OPEN_SUBEXP and
+ OP_CLOSE_SUBEXP cases below. But, if the
+ destination node is the same node as the source
+ node, don't recurse because it would cause an
+ infinite loop: a regex that exhibits this behavior
+ is ()\1*\1* */
+ dst = dfa->edests[node].elems[0];
+ if (dst == from_node)
+ {
+ if (boundaries & 1)
+ return -1;
+ else /* if (boundaries & 2) */
+ return 0;
+ }
+
+ cpos =
+ check_dst_limits_calc_pos_1 (mctx, boundaries, subexp_idx,
+ dst, bkref_idx);
+ if (cpos == -1 /* && (boundaries & 1) */)
+ return -1;
+ if (cpos == 0 && (boundaries & 2))
+ return 0;
+
+ if (subexp_idx < BITSET_WORD_BITS)
+ ent->eps_reachable_subexps_map
+ &= ~((bitset_word_t) 1 << subexp_idx);
+ }
+ while (ent++->more);
+ }
+ break;
+
+ case OP_OPEN_SUBEXP:
+ if ((boundaries & 1) && subexp_idx == dfa->nodes[node].opr.idx)
+ return -1;
+ break;
+
+ case OP_CLOSE_SUBEXP:
+ if ((boundaries & 2) && subexp_idx == dfa->nodes[node].opr.idx)
+ return 0;
+ break;
+
+ default:
+ break;
+ }
+ }
+
+ return (boundaries & 2) ? 1 : 0;
+}
+
+static int
+check_dst_limits_calc_pos (const re_match_context_t *mctx, Idx limit,
+ Idx subexp_idx, Idx from_node, Idx str_idx,
+ Idx bkref_idx)
+{
+ struct re_backref_cache_entry *lim = mctx->bkref_ents + limit;
+ int boundaries;
+
+ /* If we are outside the range of the subexpression, return -1 or 1. */
+ if (str_idx < lim->subexp_from)
+ return -1;
+
+ if (lim->subexp_to < str_idx)
+ return 1;
+
+ /* If we are within the subexpression, return 0. */
+ boundaries = (str_idx == lim->subexp_from);
+ boundaries |= (str_idx == lim->subexp_to) << 1;
+ if (boundaries == 0)
+ return 0;
+
+ /* Else, examine epsilon closure. */
+ return check_dst_limits_calc_pos_1 (mctx, boundaries, subexp_idx,
+ from_node, bkref_idx);
+}
+
+/* Check the limitations of sub expressions LIMITS, and remove the nodes
+ which are against limitations from DEST_NODES. */
+
+static reg_errcode_t
+check_subexp_limits (const re_dfa_t *dfa, re_node_set *dest_nodes,
+ const re_node_set *candidates, re_node_set *limits,
+ struct re_backref_cache_entry *bkref_ents, Idx str_idx)
+{
+ reg_errcode_t err;
+ Idx node_idx, lim_idx;
+
+ for (lim_idx = 0; lim_idx < limits->nelem; ++lim_idx)
+ {
+ Idx subexp_idx;
+ struct re_backref_cache_entry *ent;
+ ent = bkref_ents + limits->elems[lim_idx];
+
+ if (str_idx <= ent->subexp_from || ent->str_idx < str_idx)
+ continue; /* This is unrelated limitation. */
+
+ subexp_idx = dfa->nodes[ent->node].opr.idx;
+ if (ent->subexp_to == str_idx)
+ {
+ Idx ops_node = -1;
+ Idx cls_node = -1;
+ for (node_idx = 0; node_idx < dest_nodes->nelem; ++node_idx)
+ {
+ Idx node = dest_nodes->elems[node_idx];
+ re_token_type_t type = dfa->nodes[node].type;
+ if (type == OP_OPEN_SUBEXP
+ && subexp_idx == dfa->nodes[node].opr.idx)
+ ops_node = node;
+ else if (type == OP_CLOSE_SUBEXP
+ && subexp_idx == dfa->nodes[node].opr.idx)
+ cls_node = node;
+ }
+
+ /* Check the limitation of the open subexpression. */
+ /* Note that (ent->subexp_to = str_idx != ent->subexp_from). */
+ if (ops_node >= 0)
+ {
+ err = sub_epsilon_src_nodes (dfa, ops_node, dest_nodes,
+ candidates);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ }
+
+ /* Check the limitation of the close subexpression. */
+ if (cls_node >= 0)
+ for (node_idx = 0; node_idx < dest_nodes->nelem; ++node_idx)
+ {
+ Idx node = dest_nodes->elems[node_idx];
+ if (!re_node_set_contains (dfa->inveclosures + node,
+ cls_node)
+ && !re_node_set_contains (dfa->eclosures + node,
+ cls_node))
+ {
+ /* It is against this limitation.
+ Remove it form the current sifted state. */
+ err = sub_epsilon_src_nodes (dfa, node, dest_nodes,
+ candidates);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ --node_idx;
+ }
+ }
+ }
+ else /* (ent->subexp_to != str_idx) */
+ {
+ for (node_idx = 0; node_idx < dest_nodes->nelem; ++node_idx)
+ {
+ Idx node = dest_nodes->elems[node_idx];
+ re_token_type_t type = dfa->nodes[node].type;
+ if (type == OP_CLOSE_SUBEXP || type == OP_OPEN_SUBEXP)
+ {
+ if (subexp_idx != dfa->nodes[node].opr.idx)
+ continue;
+ /* It is against this limitation.
+ Remove it form the current sifted state. */
+ err = sub_epsilon_src_nodes (dfa, node, dest_nodes,
+ candidates);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ }
+ }
+ }
+ }
+ return REG_NOERROR;
+}
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+sift_states_bkref (const re_match_context_t *mctx, re_sift_context_t *sctx,
+ Idx str_idx, const re_node_set *candidates)
+{
+ const re_dfa_t *const dfa = mctx->dfa;
+ reg_errcode_t err;
+ Idx node_idx, node;
+ re_sift_context_t local_sctx;
+ Idx first_idx = search_cur_bkref_entry (mctx, str_idx);
+
+ if (first_idx == -1)
+ return REG_NOERROR;
+
+ local_sctx.sifted_states = NULL; /* Mark that it hasn't been initialized. */
+
+ for (node_idx = 0; node_idx < candidates->nelem; ++node_idx)
+ {
+ Idx enabled_idx;
+ re_token_type_t type;
+ struct re_backref_cache_entry *entry;
+ node = candidates->elems[node_idx];
+ type = dfa->nodes[node].type;
+ /* Avoid infinite loop for the REs like "()\1+". */
+ if (node == sctx->last_node && str_idx == sctx->last_str_idx)
+ continue;
+ if (type != OP_BACK_REF)
+ continue;
+
+ entry = mctx->bkref_ents + first_idx;
+ enabled_idx = first_idx;
+ do
+ {
+ Idx subexp_len;
+ Idx to_idx;
+ Idx dst_node;
+ bool ok;
+ re_dfastate_t *cur_state;
+
+ if (entry->node != node)
+ continue;
+ subexp_len = entry->subexp_to - entry->subexp_from;
+ to_idx = str_idx + subexp_len;
+ dst_node = (subexp_len ? dfa->nexts[node]
+ : dfa->edests[node].elems[0]);
+
+ if (to_idx > sctx->last_str_idx
+ || sctx->sifted_states[to_idx] == NULL
+ || !STATE_NODE_CONTAINS (sctx->sifted_states[to_idx], dst_node)
+ || check_dst_limits (mctx, &sctx->limits, node,
+ str_idx, dst_node, to_idx))
+ continue;
+
+ if (local_sctx.sifted_states == NULL)
+ {
+ local_sctx = *sctx;
+ err = re_node_set_init_copy (&local_sctx.limits, &sctx->limits);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ goto free_return;
+ }
+ local_sctx.last_node = node;
+ local_sctx.last_str_idx = str_idx;
+ ok = re_node_set_insert (&local_sctx.limits, enabled_idx);
+ if (__glibc_unlikely (! ok))
+ {
+ err = REG_ESPACE;
+ goto free_return;
+ }
+ cur_state = local_sctx.sifted_states[str_idx];
+ err = sift_states_backward (mctx, &local_sctx);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ goto free_return;
+ if (sctx->limited_states != NULL)
+ {
+ err = merge_state_array (dfa, sctx->limited_states,
+ local_sctx.sifted_states,
+ str_idx + 1);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ goto free_return;
+ }
+ local_sctx.sifted_states[str_idx] = cur_state;
+ re_node_set_remove (&local_sctx.limits, enabled_idx);
+
+ /* mctx->bkref_ents may have changed, reload the pointer. */
+ entry = mctx->bkref_ents + enabled_idx;
+ }
+ while (enabled_idx++, entry++->more);
+ }
+ err = REG_NOERROR;
+ free_return:
+ if (local_sctx.sifted_states != NULL)
+ {
+ re_node_set_free (&local_sctx.limits);
+ }
+
+ return err;
+}
+
+
+#ifdef RE_ENABLE_I18N
+static int
+sift_states_iter_mb (const re_match_context_t *mctx, re_sift_context_t *sctx,
+ Idx node_idx, Idx str_idx, Idx max_str_idx)
+{
+ const re_dfa_t *const dfa = mctx->dfa;
+ int naccepted;
+ /* Check the node can accept "multi byte". */
+ naccepted = check_node_accept_bytes (dfa, node_idx, &mctx->input, str_idx);
+ if (naccepted > 0 && str_idx + naccepted <= max_str_idx
+ && !STATE_NODE_CONTAINS (sctx->sifted_states[str_idx + naccepted],
+ dfa->nexts[node_idx]))
+ /* The node can't accept the "multi byte", or the
+ destination was already thrown away, then the node
+ couldn't accept the current input "multi byte". */
+ naccepted = 0;
+ /* Otherwise, it is sure that the node could accept
+ 'naccepted' bytes input. */
+ return naccepted;
+}
+#endif /* RE_ENABLE_I18N */
+
+
+/* Functions for state transition. */
+
+/* Return the next state to which the current state STATE will transit by
+ accepting the current input byte, and update STATE_LOG if necessary.
+ If STATE can accept a multibyte char/collating element/back reference
+ update the destination of STATE_LOG. */
+
+static re_dfastate_t *
+__attribute_warn_unused_result__
+transit_state (reg_errcode_t *err, re_match_context_t *mctx,
+ re_dfastate_t *state)
+{
+ re_dfastate_t **trtable;
+ unsigned char ch;
+
+#ifdef RE_ENABLE_I18N
+ /* If the current state can accept multibyte. */
+ if (__glibc_unlikely (state->accept_mb))
+ {
+ *err = transit_state_mb (mctx, state);
+ if (__glibc_unlikely (*err != REG_NOERROR))
+ return NULL;
+ }
+#endif /* RE_ENABLE_I18N */
+
+ /* Then decide the next state with the single byte. */
+#if 0
+ if (0)
+ /* don't use transition table */
+ return transit_state_sb (err, mctx, state);
+#endif
+
+ /* Use transition table */
+ ch = re_string_fetch_byte (&mctx->input);
+ for (;;)
+ {
+ trtable = state->trtable;
+ if (__glibc_likely (trtable != NULL))
+ return trtable[ch];
+
+ trtable = state->word_trtable;
+ if (__glibc_likely (trtable != NULL))
+ {
+ unsigned int context;
+ context
+ = re_string_context_at (&mctx->input,
+ re_string_cur_idx (&mctx->input) - 1,
+ mctx->eflags);
+ if (IS_WORD_CONTEXT (context))
+ return trtable[ch + SBC_MAX];
+ else
+ return trtable[ch];
+ }
+
+ if (!build_trtable (mctx->dfa, state))
+ {
+ *err = REG_ESPACE;
+ return NULL;
+ }
+
+ /* Retry, we now have a transition table. */
+ }
+}
+
+/* Update the state_log if we need */
+static re_dfastate_t *
+merge_state_with_log (reg_errcode_t *err, re_match_context_t *mctx,
+ re_dfastate_t *next_state)
+{
+ const re_dfa_t *const dfa = mctx->dfa;
+ Idx cur_idx = re_string_cur_idx (&mctx->input);
+
+ if (cur_idx > mctx->state_log_top)
+ {
+ mctx->state_log[cur_idx] = next_state;
+ mctx->state_log_top = cur_idx;
+ }
+ else if (mctx->state_log[cur_idx] == 0)
+ {
+ mctx->state_log[cur_idx] = next_state;
+ }
+ else
+ {
+ re_dfastate_t *pstate;
+ unsigned int context;
+ re_node_set next_nodes, *log_nodes, *table_nodes = NULL;
+ /* If (state_log[cur_idx] != 0), it implies that cur_idx is
+ the destination of a multibyte char/collating element/
+ back reference. Then the next state is the union set of
+ these destinations and the results of the transition table. */
+ pstate = mctx->state_log[cur_idx];
+ log_nodes = pstate->entrance_nodes;
+ if (next_state != NULL)
+ {
+ table_nodes = next_state->entrance_nodes;
+ *err = re_node_set_init_union (&next_nodes, table_nodes,
+ log_nodes);
+ if (__glibc_unlikely (*err != REG_NOERROR))
+ return NULL;
+ }
+ else
+ next_nodes = *log_nodes;
+ /* Note: We already add the nodes of the initial state,
+ then we don't need to add them here. */
+
+ context = re_string_context_at (&mctx->input,
+ re_string_cur_idx (&mctx->input) - 1,
+ mctx->eflags);
+ next_state = mctx->state_log[cur_idx]
+ = re_acquire_state_context (err, dfa, &next_nodes, context);
+ /* We don't need to check errors here, since the return value of
+ this function is next_state and ERR is already set. */
+
+ if (table_nodes != NULL)
+ re_node_set_free (&next_nodes);
+ }
+
+ if (__glibc_unlikely (dfa->nbackref) && next_state != NULL)
+ {
+ /* Check OP_OPEN_SUBEXP in the current state in case that we use them
+ later. We must check them here, since the back references in the
+ next state might use them. */
+ *err = check_subexp_matching_top (mctx, &next_state->nodes,
+ cur_idx);
+ if (__glibc_unlikely (*err != REG_NOERROR))
+ return NULL;
+
+ /* If the next state has back references. */
+ if (next_state->has_backref)
+ {
+ *err = transit_state_bkref (mctx, &next_state->nodes);
+ if (__glibc_unlikely (*err != REG_NOERROR))
+ return NULL;
+ next_state = mctx->state_log[cur_idx];
+ }
+ }
+
+ return next_state;
+}
+
+/* Skip bytes in the input that correspond to part of a
+ multi-byte match, then look in the log for a state
+ from which to restart matching. */
+static re_dfastate_t *
+find_recover_state (reg_errcode_t *err, re_match_context_t *mctx)
+{
+ re_dfastate_t *cur_state;
+ do
+ {
+ Idx max = mctx->state_log_top;
+ Idx cur_str_idx = re_string_cur_idx (&mctx->input);
+
+ do
+ {
+ if (++cur_str_idx > max)
+ return NULL;
+ re_string_skip_bytes (&mctx->input, 1);
+ }
+ while (mctx->state_log[cur_str_idx] == NULL);
+
+ cur_state = merge_state_with_log (err, mctx, NULL);
+ }
+ while (*err == REG_NOERROR && cur_state == NULL);
+ return cur_state;
+}
+
+/* Helper functions for transit_state. */
+
+/* From the node set CUR_NODES, pick up the nodes whose types are
+ OP_OPEN_SUBEXP and which have corresponding back references in the regular
+ expression. And register them to use them later for evaluating the
+ corresponding back references. */
+
+static reg_errcode_t
+check_subexp_matching_top (re_match_context_t *mctx, re_node_set *cur_nodes,
+ Idx str_idx)
+{
+ const re_dfa_t *const dfa = mctx->dfa;
+ Idx node_idx;
+ reg_errcode_t err;
+
+ /* TODO: This isn't efficient.
+ Because there might be more than one nodes whose types are
+ OP_OPEN_SUBEXP and whose index is SUBEXP_IDX, we must check all
+ nodes.
+ E.g. RE: (a){2} */
+ for (node_idx = 0; node_idx < cur_nodes->nelem; ++node_idx)
+ {
+ Idx node = cur_nodes->elems[node_idx];
+ if (dfa->nodes[node].type == OP_OPEN_SUBEXP
+ && dfa->nodes[node].opr.idx < BITSET_WORD_BITS
+ && (dfa->used_bkref_map
+ & ((bitset_word_t) 1 << dfa->nodes[node].opr.idx)))
+ {
+ err = match_ctx_add_subtop (mctx, node, str_idx);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ }
+ }
+ return REG_NOERROR;
+}
+
+#if 0
+/* Return the next state to which the current state STATE will transit by
+ accepting the current input byte. */
+
+static re_dfastate_t *
+transit_state_sb (reg_errcode_t *err, re_match_context_t *mctx,
+ re_dfastate_t *state)
+{
+ const re_dfa_t *const dfa = mctx->dfa;
+ re_node_set next_nodes;
+ re_dfastate_t *next_state;
+ Idx node_cnt, cur_str_idx = re_string_cur_idx (&mctx->input);
+ unsigned int context;
+
+ *err = re_node_set_alloc (&next_nodes, state->nodes.nelem + 1);
+ if (__glibc_unlikely (*err != REG_NOERROR))
+ return NULL;
+ for (node_cnt = 0; node_cnt < state->nodes.nelem; ++node_cnt)
+ {
+ Idx cur_node = state->nodes.elems[node_cnt];
+ if (check_node_accept (mctx, dfa->nodes + cur_node, cur_str_idx))
+ {
+ *err = re_node_set_merge (&next_nodes,
+ dfa->eclosures + dfa->nexts[cur_node]);
+ if (__glibc_unlikely (*err != REG_NOERROR))
+ {
+ re_node_set_free (&next_nodes);
+ return NULL;
+ }
+ }
+ }
+ context = re_string_context_at (&mctx->input, cur_str_idx, mctx->eflags);
+ next_state = re_acquire_state_context (err, dfa, &next_nodes, context);
+ /* We don't need to check errors here, since the return value of
+ this function is next_state and ERR is already set. */
+
+ re_node_set_free (&next_nodes);
+ re_string_skip_bytes (&mctx->input, 1);
+ return next_state;
+}
+#endif
+
+#ifdef RE_ENABLE_I18N
+static reg_errcode_t
+transit_state_mb (re_match_context_t *mctx, re_dfastate_t *pstate)
+{
+ const re_dfa_t *const dfa = mctx->dfa;
+ reg_errcode_t err;
+ Idx i;
+
+ for (i = 0; i < pstate->nodes.nelem; ++i)
+ {
+ re_node_set dest_nodes, *new_nodes;
+ Idx cur_node_idx = pstate->nodes.elems[i];
+ int naccepted;
+ Idx dest_idx;
+ unsigned int context;
+ re_dfastate_t *dest_state;
+
+ if (!dfa->nodes[cur_node_idx].accept_mb)
+ continue;
+
+ if (dfa->nodes[cur_node_idx].constraint)
+ {
+ context = re_string_context_at (&mctx->input,
+ re_string_cur_idx (&mctx->input),
+ mctx->eflags);
+ if (NOT_SATISFY_NEXT_CONSTRAINT (dfa->nodes[cur_node_idx].constraint,
+ context))
+ continue;
+ }
+
+ /* How many bytes the node can accept? */
+ naccepted = check_node_accept_bytes (dfa, cur_node_idx, &mctx->input,
+ re_string_cur_idx (&mctx->input));
+ if (naccepted == 0)
+ continue;
+
+ /* The node can accepts 'naccepted' bytes. */
+ dest_idx = re_string_cur_idx (&mctx->input) + naccepted;
+ mctx->max_mb_elem_len = ((mctx->max_mb_elem_len < naccepted) ? naccepted
+ : mctx->max_mb_elem_len);
+ err = clean_state_log_if_needed (mctx, dest_idx);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+#ifdef DEBUG
+ assert (dfa->nexts[cur_node_idx] != -1);
+#endif
+ new_nodes = dfa->eclosures + dfa->nexts[cur_node_idx];
+
+ dest_state = mctx->state_log[dest_idx];
+ if (dest_state == NULL)
+ dest_nodes = *new_nodes;
+ else
+ {
+ err = re_node_set_init_union (&dest_nodes,
+ dest_state->entrance_nodes, new_nodes);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ }
+ context = re_string_context_at (&mctx->input, dest_idx - 1,
+ mctx->eflags);
+ mctx->state_log[dest_idx]
+ = re_acquire_state_context (&err, dfa, &dest_nodes, context);
+ if (dest_state != NULL)
+ re_node_set_free (&dest_nodes);
+ if (__glibc_unlikely (mctx->state_log[dest_idx] == NULL
+ && err != REG_NOERROR))
+ return err;
+ }
+ return REG_NOERROR;
+}
+#endif /* RE_ENABLE_I18N */
+
+static reg_errcode_t
+transit_state_bkref (re_match_context_t *mctx, const re_node_set *nodes)
+{
+ const re_dfa_t *const dfa = mctx->dfa;
+ reg_errcode_t err;
+ Idx i;
+ Idx cur_str_idx = re_string_cur_idx (&mctx->input);
+
+ for (i = 0; i < nodes->nelem; ++i)
+ {
+ Idx dest_str_idx, prev_nelem, bkc_idx;
+ Idx node_idx = nodes->elems[i];
+ unsigned int context;
+ const re_token_t *node = dfa->nodes + node_idx;
+ re_node_set *new_dest_nodes;
+
+ /* Check whether 'node' is a backreference or not. */
+ if (node->type != OP_BACK_REF)
+ continue;
+
+ if (node->constraint)
+ {
+ context = re_string_context_at (&mctx->input, cur_str_idx,
+ mctx->eflags);
+ if (NOT_SATISFY_NEXT_CONSTRAINT (node->constraint, context))
+ continue;
+ }
+
+ /* 'node' is a backreference.
+ Check the substring which the substring matched. */
+ bkc_idx = mctx->nbkref_ents;
+ err = get_subexp (mctx, node_idx, cur_str_idx);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ goto free_return;
+
+ /* And add the epsilon closures (which is 'new_dest_nodes') of
+ the backreference to appropriate state_log. */
+#ifdef DEBUG
+ assert (dfa->nexts[node_idx] != -1);
+#endif
+ for (; bkc_idx < mctx->nbkref_ents; ++bkc_idx)
+ {
+ Idx subexp_len;
+ re_dfastate_t *dest_state;
+ struct re_backref_cache_entry *bkref_ent;
+ bkref_ent = mctx->bkref_ents + bkc_idx;
+ if (bkref_ent->node != node_idx || bkref_ent->str_idx != cur_str_idx)
+ continue;
+ subexp_len = bkref_ent->subexp_to - bkref_ent->subexp_from;
+ new_dest_nodes = (subexp_len == 0
+ ? dfa->eclosures + dfa->edests[node_idx].elems[0]
+ : dfa->eclosures + dfa->nexts[node_idx]);
+ dest_str_idx = (cur_str_idx + bkref_ent->subexp_to
+ - bkref_ent->subexp_from);
+ context = re_string_context_at (&mctx->input, dest_str_idx - 1,
+ mctx->eflags);
+ dest_state = mctx->state_log[dest_str_idx];
+ prev_nelem = ((mctx->state_log[cur_str_idx] == NULL) ? 0
+ : mctx->state_log[cur_str_idx]->nodes.nelem);
+ /* Add 'new_dest_node' to state_log. */
+ if (dest_state == NULL)
+ {
+ mctx->state_log[dest_str_idx]
+ = re_acquire_state_context (&err, dfa, new_dest_nodes,
+ context);
+ if (__glibc_unlikely (mctx->state_log[dest_str_idx] == NULL
+ && err != REG_NOERROR))
+ goto free_return;
+ }
+ else
+ {
+ re_node_set dest_nodes;
+ err = re_node_set_init_union (&dest_nodes,
+ dest_state->entrance_nodes,
+ new_dest_nodes);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ {
+ re_node_set_free (&dest_nodes);
+ goto free_return;
+ }
+ mctx->state_log[dest_str_idx]
+ = re_acquire_state_context (&err, dfa, &dest_nodes, context);
+ re_node_set_free (&dest_nodes);
+ if (__glibc_unlikely (mctx->state_log[dest_str_idx] == NULL
+ && err != REG_NOERROR))
+ goto free_return;
+ }
+ /* We need to check recursively if the backreference can epsilon
+ transit. */
+ if (subexp_len == 0
+ && mctx->state_log[cur_str_idx]->nodes.nelem > prev_nelem)
+ {
+ err = check_subexp_matching_top (mctx, new_dest_nodes,
+ cur_str_idx);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ goto free_return;
+ err = transit_state_bkref (mctx, new_dest_nodes);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ goto free_return;
+ }
+ }
+ }
+ err = REG_NOERROR;
+ free_return:
+ return err;
+}
+
+/* Enumerate all the candidates which the backreference BKREF_NODE can match
+ at BKREF_STR_IDX, and register them by match_ctx_add_entry().
+ Note that we might collect inappropriate candidates here.
+ However, the cost of checking them strictly here is too high, then we
+ delay these checking for prune_impossible_nodes(). */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+get_subexp (re_match_context_t *mctx, Idx bkref_node, Idx bkref_str_idx)
+{
+ const re_dfa_t *const dfa = mctx->dfa;
+ Idx subexp_num, sub_top_idx;
+ const char *buf = (const char *) re_string_get_buffer (&mctx->input);
+ /* Return if we have already checked BKREF_NODE at BKREF_STR_IDX. */
+ Idx cache_idx = search_cur_bkref_entry (mctx, bkref_str_idx);
+ if (cache_idx != -1)
+ {
+ const struct re_backref_cache_entry *entry
+ = mctx->bkref_ents + cache_idx;
+ do
+ if (entry->node == bkref_node)
+ return REG_NOERROR; /* We already checked it. */
+ while (entry++->more);
+ }
+
+ subexp_num = dfa->nodes[bkref_node].opr.idx;
+
+ /* For each sub expression */
+ for (sub_top_idx = 0; sub_top_idx < mctx->nsub_tops; ++sub_top_idx)
+ {
+ reg_errcode_t err;
+ re_sub_match_top_t *sub_top = mctx->sub_tops[sub_top_idx];
+ re_sub_match_last_t *sub_last;
+ Idx sub_last_idx, sl_str, bkref_str_off;
+
+ if (dfa->nodes[sub_top->node].opr.idx != subexp_num)
+ continue; /* It isn't related. */
+
+ sl_str = sub_top->str_idx;
+ bkref_str_off = bkref_str_idx;
+ /* At first, check the last node of sub expressions we already
+ evaluated. */
+ for (sub_last_idx = 0; sub_last_idx < sub_top->nlasts; ++sub_last_idx)
+ {
+ regoff_t sl_str_diff;
+ sub_last = sub_top->lasts[sub_last_idx];
+ sl_str_diff = sub_last->str_idx - sl_str;
+ /* The matched string by the sub expression match with the substring
+ at the back reference? */
+ if (sl_str_diff > 0)
+ {
+ if (__glibc_unlikely (bkref_str_off + sl_str_diff
+ > mctx->input.valid_len))
+ {
+ /* Not enough chars for a successful match. */
+ if (bkref_str_off + sl_str_diff > mctx->input.len)
+ break;
+
+ err = clean_state_log_if_needed (mctx,
+ bkref_str_off
+ + sl_str_diff);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ buf = (const char *) re_string_get_buffer (&mctx->input);
+ }
+ if (memcmp (buf + bkref_str_off, buf + sl_str, sl_str_diff) != 0)
+ /* We don't need to search this sub expression any more. */
+ break;
+ }
+ bkref_str_off += sl_str_diff;
+ sl_str += sl_str_diff;
+ err = get_subexp_sub (mctx, sub_top, sub_last, bkref_node,
+ bkref_str_idx);
+
+ /* Reload buf, since the preceding call might have reallocated
+ the buffer. */
+ buf = (const char *) re_string_get_buffer (&mctx->input);
+
+ if (err == REG_NOMATCH)
+ continue;
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ }
+
+ if (sub_last_idx < sub_top->nlasts)
+ continue;
+ if (sub_last_idx > 0)
+ ++sl_str;
+ /* Then, search for the other last nodes of the sub expression. */
+ for (; sl_str <= bkref_str_idx; ++sl_str)
+ {
+ Idx cls_node;
+ regoff_t sl_str_off;
+ const re_node_set *nodes;
+ sl_str_off = sl_str - sub_top->str_idx;
+ /* The matched string by the sub expression match with the substring
+ at the back reference? */
+ if (sl_str_off > 0)
+ {
+ if (__glibc_unlikely (bkref_str_off >= mctx->input.valid_len))
+ {
+ /* If we are at the end of the input, we cannot match. */
+ if (bkref_str_off >= mctx->input.len)
+ break;
+
+ err = extend_buffers (mctx, bkref_str_off + 1);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+
+ buf = (const char *) re_string_get_buffer (&mctx->input);
+ }
+ if (buf [bkref_str_off++] != buf[sl_str - 1])
+ break; /* We don't need to search this sub expression
+ any more. */
+ }
+ if (mctx->state_log[sl_str] == NULL)
+ continue;
+ /* Does this state have a ')' of the sub expression? */
+ nodes = &mctx->state_log[sl_str]->nodes;
+ cls_node = find_subexp_node (dfa, nodes, subexp_num,
+ OP_CLOSE_SUBEXP);
+ if (cls_node == -1)
+ continue; /* No. */
+ if (sub_top->path == NULL)
+ {
+ sub_top->path = calloc (sizeof (state_array_t),
+ sl_str - sub_top->str_idx + 1);
+ if (sub_top->path == NULL)
+ return REG_ESPACE;
+ }
+ /* Can the OP_OPEN_SUBEXP node arrive the OP_CLOSE_SUBEXP node
+ in the current context? */
+ err = check_arrival (mctx, sub_top->path, sub_top->node,
+ sub_top->str_idx, cls_node, sl_str,
+ OP_CLOSE_SUBEXP);
+ if (err == REG_NOMATCH)
+ continue;
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ sub_last = match_ctx_add_sublast (sub_top, cls_node, sl_str);
+ if (__glibc_unlikely (sub_last == NULL))
+ return REG_ESPACE;
+ err = get_subexp_sub (mctx, sub_top, sub_last, bkref_node,
+ bkref_str_idx);
+ buf = (const char *) re_string_get_buffer (&mctx->input);
+ if (err == REG_NOMATCH)
+ continue;
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ }
+ }
+ return REG_NOERROR;
+}
+
+/* Helper functions for get_subexp(). */
+
+/* Check SUB_LAST can arrive to the back reference BKREF_NODE at BKREF_STR.
+ If it can arrive, register the sub expression expressed with SUB_TOP
+ and SUB_LAST. */
+
+static reg_errcode_t
+get_subexp_sub (re_match_context_t *mctx, const re_sub_match_top_t *sub_top,
+ re_sub_match_last_t *sub_last, Idx bkref_node, Idx bkref_str)
+{
+ reg_errcode_t err;
+ Idx to_idx;
+ /* Can the subexpression arrive the back reference? */
+ err = check_arrival (mctx, &sub_last->path, sub_last->node,
+ sub_last->str_idx, bkref_node, bkref_str,
+ OP_OPEN_SUBEXP);
+ if (err != REG_NOERROR)
+ return err;
+ err = match_ctx_add_entry (mctx, bkref_node, bkref_str, sub_top->str_idx,
+ sub_last->str_idx);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ to_idx = bkref_str + sub_last->str_idx - sub_top->str_idx;
+ return clean_state_log_if_needed (mctx, to_idx);
+}
+
+/* Find the first node which is '(' or ')' and whose index is SUBEXP_IDX.
+ Search '(' if FL_OPEN, or search ')' otherwise.
+ TODO: This function isn't efficient...
+ Because there might be more than one nodes whose types are
+ OP_OPEN_SUBEXP and whose index is SUBEXP_IDX, we must check all
+ nodes.
+ E.g. RE: (a){2} */
+
+static Idx
+find_subexp_node (const re_dfa_t *dfa, const re_node_set *nodes,
+ Idx subexp_idx, int type)
+{
+ Idx cls_idx;
+ for (cls_idx = 0; cls_idx < nodes->nelem; ++cls_idx)
+ {
+ Idx cls_node = nodes->elems[cls_idx];
+ const re_token_t *node = dfa->nodes + cls_node;
+ if (node->type == type
+ && node->opr.idx == subexp_idx)
+ return cls_node;
+ }
+ return -1;
+}
+
+/* Check whether the node TOP_NODE at TOP_STR can arrive to the node
+ LAST_NODE at LAST_STR. We record the path onto PATH since it will be
+ heavily reused.
+ Return REG_NOERROR if it can arrive, or REG_NOMATCH otherwise. */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+check_arrival (re_match_context_t *mctx, state_array_t *path, Idx top_node,
+ Idx top_str, Idx last_node, Idx last_str, int type)
+{
+ const re_dfa_t *const dfa = mctx->dfa;
+ reg_errcode_t err = REG_NOERROR;
+ Idx subexp_num, backup_cur_idx, str_idx, null_cnt;
+ re_dfastate_t *cur_state = NULL;
+ re_node_set *cur_nodes, next_nodes;
+ re_dfastate_t **backup_state_log;
+ unsigned int context;
+
+ subexp_num = dfa->nodes[top_node].opr.idx;
+ /* Extend the buffer if we need. */
+ if (__glibc_unlikely (path->alloc < last_str + mctx->max_mb_elem_len + 1))
+ {
+ re_dfastate_t **new_array;
+ Idx old_alloc = path->alloc;
+ Idx incr_alloc = last_str + mctx->max_mb_elem_len + 1;
+ Idx new_alloc;
+ if (__glibc_unlikely (IDX_MAX - old_alloc < incr_alloc))
+ return REG_ESPACE;
+ new_alloc = old_alloc + incr_alloc;
+ if (__glibc_unlikely (SIZE_MAX / sizeof (re_dfastate_t *) < new_alloc))
+ return REG_ESPACE;
+ new_array = re_realloc (path->array, re_dfastate_t *, new_alloc);
+ if (__glibc_unlikely (new_array == NULL))
+ return REG_ESPACE;
+ path->array = new_array;
+ path->alloc = new_alloc;
+ memset (new_array + old_alloc, '\0',
+ sizeof (re_dfastate_t *) * (path->alloc - old_alloc));
+ }
+
+ str_idx = path->next_idx ? path->next_idx : top_str;
+
+ /* Temporary modify MCTX. */
+ backup_state_log = mctx->state_log;
+ backup_cur_idx = mctx->input.cur_idx;
+ mctx->state_log = path->array;
+ mctx->input.cur_idx = str_idx;
+
+ /* Setup initial node set. */
+ context = re_string_context_at (&mctx->input, str_idx - 1, mctx->eflags);
+ if (str_idx == top_str)
+ {
+ err = re_node_set_init_1 (&next_nodes, top_node);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ err = check_arrival_expand_ecl (dfa, &next_nodes, subexp_num, type);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ {
+ re_node_set_free (&next_nodes);
+ return err;
+ }
+ }
+ else
+ {
+ cur_state = mctx->state_log[str_idx];
+ if (cur_state && cur_state->has_backref)
+ {
+ err = re_node_set_init_copy (&next_nodes, &cur_state->nodes);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ }
+ else
+ re_node_set_init_empty (&next_nodes);
+ }
+ if (str_idx == top_str || (cur_state && cur_state->has_backref))
+ {
+ if (next_nodes.nelem)
+ {
+ err = expand_bkref_cache (mctx, &next_nodes, str_idx,
+ subexp_num, type);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ {
+ re_node_set_free (&next_nodes);
+ return err;
+ }
+ }
+ cur_state = re_acquire_state_context (&err, dfa, &next_nodes, context);
+ if (__glibc_unlikely (cur_state == NULL && err != REG_NOERROR))
+ {
+ re_node_set_free (&next_nodes);
+ return err;
+ }
+ mctx->state_log[str_idx] = cur_state;
+ }
+
+ for (null_cnt = 0; str_idx < last_str && null_cnt <= mctx->max_mb_elem_len;)
+ {
+ re_node_set_empty (&next_nodes);
+ if (mctx->state_log[str_idx + 1])
+ {
+ err = re_node_set_merge (&next_nodes,
+ &mctx->state_log[str_idx + 1]->nodes);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ {
+ re_node_set_free (&next_nodes);
+ return err;
+ }
+ }
+ if (cur_state)
+ {
+ err = check_arrival_add_next_nodes (mctx, str_idx,
+ &cur_state->non_eps_nodes,
+ &next_nodes);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ {
+ re_node_set_free (&next_nodes);
+ return err;
+ }
+ }
+ ++str_idx;
+ if (next_nodes.nelem)
+ {
+ err = check_arrival_expand_ecl (dfa, &next_nodes, subexp_num, type);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ {
+ re_node_set_free (&next_nodes);
+ return err;
+ }
+ err = expand_bkref_cache (mctx, &next_nodes, str_idx,
+ subexp_num, type);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ {
+ re_node_set_free (&next_nodes);
+ return err;
+ }
+ }
+ context = re_string_context_at (&mctx->input, str_idx - 1, mctx->eflags);
+ cur_state = re_acquire_state_context (&err, dfa, &next_nodes, context);
+ if (__glibc_unlikely (cur_state == NULL && err != REG_NOERROR))
+ {
+ re_node_set_free (&next_nodes);
+ return err;
+ }
+ mctx->state_log[str_idx] = cur_state;
+ null_cnt = cur_state == NULL ? null_cnt + 1 : 0;
+ }
+ re_node_set_free (&next_nodes);
+ cur_nodes = (mctx->state_log[last_str] == NULL ? NULL
+ : &mctx->state_log[last_str]->nodes);
+ path->next_idx = str_idx;
+
+ /* Fix MCTX. */
+ mctx->state_log = backup_state_log;
+ mctx->input.cur_idx = backup_cur_idx;
+
+ /* Then check the current node set has the node LAST_NODE. */
+ if (cur_nodes != NULL && re_node_set_contains (cur_nodes, last_node))
+ return REG_NOERROR;
+
+ return REG_NOMATCH;
+}
+
+/* Helper functions for check_arrival. */
+
+/* Calculate the destination nodes of CUR_NODES at STR_IDX, and append them
+ to NEXT_NODES.
+ TODO: This function is similar to the functions transit_state*(),
+ however this function has many additional works.
+ Can't we unify them? */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+check_arrival_add_next_nodes (re_match_context_t *mctx, Idx str_idx,
+ re_node_set *cur_nodes, re_node_set *next_nodes)
+{
+ const re_dfa_t *const dfa = mctx->dfa;
+ bool ok;
+ Idx cur_idx;
+#ifdef RE_ENABLE_I18N
+ reg_errcode_t err = REG_NOERROR;
+#endif
+ re_node_set union_set;
+ re_node_set_init_empty (&union_set);
+ for (cur_idx = 0; cur_idx < cur_nodes->nelem; ++cur_idx)
+ {
+ int naccepted = 0;
+ Idx cur_node = cur_nodes->elems[cur_idx];
+#ifdef DEBUG
+ re_token_type_t type = dfa->nodes[cur_node].type;
+ assert (!IS_EPSILON_NODE (type));
+#endif
+#ifdef RE_ENABLE_I18N
+ /* If the node may accept "multi byte". */
+ if (dfa->nodes[cur_node].accept_mb)
+ {
+ naccepted = check_node_accept_bytes (dfa, cur_node, &mctx->input,
+ str_idx);
+ if (naccepted > 1)
+ {
+ re_dfastate_t *dest_state;
+ Idx next_node = dfa->nexts[cur_node];
+ Idx next_idx = str_idx + naccepted;
+ dest_state = mctx->state_log[next_idx];
+ re_node_set_empty (&union_set);
+ if (dest_state)
+ {
+ err = re_node_set_merge (&union_set, &dest_state->nodes);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ {
+ re_node_set_free (&union_set);
+ return err;
+ }
+ }
+ ok = re_node_set_insert (&union_set, next_node);
+ if (__glibc_unlikely (! ok))
+ {
+ re_node_set_free (&union_set);
+ return REG_ESPACE;
+ }
+ mctx->state_log[next_idx] = re_acquire_state (&err, dfa,
+ &union_set);
+ if (__glibc_unlikely (mctx->state_log[next_idx] == NULL
+ && err != REG_NOERROR))
+ {
+ re_node_set_free (&union_set);
+ return err;
+ }
+ }
+ }
+#endif /* RE_ENABLE_I18N */
+ if (naccepted
+ || check_node_accept (mctx, dfa->nodes + cur_node, str_idx))
+ {
+ ok = re_node_set_insert (next_nodes, dfa->nexts[cur_node]);
+ if (__glibc_unlikely (! ok))
+ {
+ re_node_set_free (&union_set);
+ return REG_ESPACE;
+ }
+ }
+ }
+ re_node_set_free (&union_set);
+ return REG_NOERROR;
+}
+
+/* For all the nodes in CUR_NODES, add the epsilon closures of them to
+ CUR_NODES, however exclude the nodes which are:
+ - inside the sub expression whose number is EX_SUBEXP, if FL_OPEN.
+ - out of the sub expression whose number is EX_SUBEXP, if !FL_OPEN.
+*/
+
+static reg_errcode_t
+check_arrival_expand_ecl (const re_dfa_t *dfa, re_node_set *cur_nodes,
+ Idx ex_subexp, int type)
+{
+ reg_errcode_t err;
+ Idx idx, outside_node;
+ re_node_set new_nodes;
+#ifdef DEBUG
+ assert (cur_nodes->nelem);
+#endif
+ err = re_node_set_alloc (&new_nodes, cur_nodes->nelem);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ /* Create a new node set NEW_NODES with the nodes which are epsilon
+ closures of the node in CUR_NODES. */
+
+ for (idx = 0; idx < cur_nodes->nelem; ++idx)
+ {
+ Idx cur_node = cur_nodes->elems[idx];
+ const re_node_set *eclosure = dfa->eclosures + cur_node;
+ outside_node = find_subexp_node (dfa, eclosure, ex_subexp, type);
+ if (outside_node == -1)
+ {
+ /* There are no problematic nodes, just merge them. */
+ err = re_node_set_merge (&new_nodes, eclosure);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ {
+ re_node_set_free (&new_nodes);
+ return err;
+ }
+ }
+ else
+ {
+ /* There are problematic nodes, re-calculate incrementally. */
+ err = check_arrival_expand_ecl_sub (dfa, &new_nodes, cur_node,
+ ex_subexp, type);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ {
+ re_node_set_free (&new_nodes);
+ return err;
+ }
+ }
+ }
+ re_node_set_free (cur_nodes);
+ *cur_nodes = new_nodes;
+ return REG_NOERROR;
+}
+
+/* Helper function for check_arrival_expand_ecl.
+ Check incrementally the epsilon closure of TARGET, and if it isn't
+ problematic append it to DST_NODES. */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+check_arrival_expand_ecl_sub (const re_dfa_t *dfa, re_node_set *dst_nodes,
+ Idx target, Idx ex_subexp, int type)
+{
+ Idx cur_node;
+ for (cur_node = target; !re_node_set_contains (dst_nodes, cur_node);)
+ {
+ bool ok;
+
+ if (dfa->nodes[cur_node].type == type
+ && dfa->nodes[cur_node].opr.idx == ex_subexp)
+ {
+ if (type == OP_CLOSE_SUBEXP)
+ {
+ ok = re_node_set_insert (dst_nodes, cur_node);
+ if (__glibc_unlikely (! ok))
+ return REG_ESPACE;
+ }
+ break;
+ }
+ ok = re_node_set_insert (dst_nodes, cur_node);
+ if (__glibc_unlikely (! ok))
+ return REG_ESPACE;
+ if (dfa->edests[cur_node].nelem == 0)
+ break;
+ if (dfa->edests[cur_node].nelem == 2)
+ {
+ reg_errcode_t err;
+ err = check_arrival_expand_ecl_sub (dfa, dst_nodes,
+ dfa->edests[cur_node].elems[1],
+ ex_subexp, type);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ }
+ cur_node = dfa->edests[cur_node].elems[0];
+ }
+ return REG_NOERROR;
+}
+
+
+/* For all the back references in the current state, calculate the
+ destination of the back references by the appropriate entry
+ in MCTX->BKREF_ENTS. */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+expand_bkref_cache (re_match_context_t *mctx, re_node_set *cur_nodes,
+ Idx cur_str, Idx subexp_num, int type)
+{
+ const re_dfa_t *const dfa = mctx->dfa;
+ reg_errcode_t err;
+ Idx cache_idx_start = search_cur_bkref_entry (mctx, cur_str);
+ struct re_backref_cache_entry *ent;
+
+ if (cache_idx_start == -1)
+ return REG_NOERROR;
+
+ restart:
+ ent = mctx->bkref_ents + cache_idx_start;
+ do
+ {
+ Idx to_idx, next_node;
+
+ /* Is this entry ENT is appropriate? */
+ if (!re_node_set_contains (cur_nodes, ent->node))
+ continue; /* No. */
+
+ to_idx = cur_str + ent->subexp_to - ent->subexp_from;
+ /* Calculate the destination of the back reference, and append it
+ to MCTX->STATE_LOG. */
+ if (to_idx == cur_str)
+ {
+ /* The backreference did epsilon transit, we must re-check all the
+ node in the current state. */
+ re_node_set new_dests;
+ reg_errcode_t err2, err3;
+ next_node = dfa->edests[ent->node].elems[0];
+ if (re_node_set_contains (cur_nodes, next_node))
+ continue;
+ err = re_node_set_init_1 (&new_dests, next_node);
+ err2 = check_arrival_expand_ecl (dfa, &new_dests, subexp_num, type);
+ err3 = re_node_set_merge (cur_nodes, &new_dests);
+ re_node_set_free (&new_dests);
+ if (__glibc_unlikely (err != REG_NOERROR || err2 != REG_NOERROR
+ || err3 != REG_NOERROR))
+ {
+ err = (err != REG_NOERROR ? err
+ : (err2 != REG_NOERROR ? err2 : err3));
+ return err;
+ }
+ /* TODO: It is still inefficient... */
+ goto restart;
+ }
+ else
+ {
+ re_node_set union_set;
+ next_node = dfa->nexts[ent->node];
+ if (mctx->state_log[to_idx])
+ {
+ bool ok;
+ if (re_node_set_contains (&mctx->state_log[to_idx]->nodes,
+ next_node))
+ continue;
+ err = re_node_set_init_copy (&union_set,
+ &mctx->state_log[to_idx]->nodes);
+ ok = re_node_set_insert (&union_set, next_node);
+ if (__glibc_unlikely (err != REG_NOERROR || ! ok))
+ {
+ re_node_set_free (&union_set);
+ err = err != REG_NOERROR ? err : REG_ESPACE;
+ return err;
+ }
+ }
+ else
+ {
+ err = re_node_set_init_1 (&union_set, next_node);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ return err;
+ }
+ mctx->state_log[to_idx] = re_acquire_state (&err, dfa, &union_set);
+ re_node_set_free (&union_set);
+ if (__glibc_unlikely (mctx->state_log[to_idx] == NULL
+ && err != REG_NOERROR))
+ return err;
+ }
+ }
+ while (ent++->more);
+ return REG_NOERROR;
+}
+
+/* Build transition table for the state.
+ Return true if successful. */
+
+static bool
+build_trtable (const re_dfa_t *dfa, re_dfastate_t *state)
+{
+ reg_errcode_t err;
+ Idx i, j;
+ 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;
+ 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;
+
+ /* Initialize transition table. */
+ state->word_trtable = state->trtable = NULL;
+
+ /* At first, group all nodes belonging to 'state' into several
+ destinations. */
+ 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)
+ {
+ state->trtable = (re_dfastate_t **)
+ calloc (sizeof (re_dfastate_t *), SBC_MAX);
+ if (__glibc_unlikely (state->trtable == NULL))
+ return false;
+ return true;
+ }
+ return false;
+ }
+
+ 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;
+ }
+ dest_states_word = dest_states + ndests;
+ dest_states_nl = dest_states_word + ndests;
+ bitset_empty (acceptable);
+
+ /* Then build the states for all destinations. */
+ for (i = 0; i < ndests; ++i)
+ {
+ Idx next_node;
+ re_node_set_empty (&follows);
+ /* Merge the follows of this destination states. */
+ for (j = 0; j < dests_node[i].nelem; ++j)
+ {
+ next_node = dfa->nexts[dests_node[i].elems[j]];
+ if (next_node != -1)
+ {
+ err = re_node_set_merge (&follows, dfa->eclosures + next_node);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ goto out_free;
+ }
+ }
+ dest_states[i] = re_acquire_state_context (&err, dfa, &follows, 0);
+ if (__glibc_unlikely (dest_states[i] == NULL && err != REG_NOERROR))
+ goto out_free;
+ /* If the new state has context constraint,
+ build appropriate states for these contexts. */
+ if (dest_states[i]->has_constraint)
+ {
+ dest_states_word[i] = re_acquire_state_context (&err, dfa, &follows,
+ CONTEXT_WORD);
+ if (__glibc_unlikely (dest_states_word[i] == NULL
+ && err != REG_NOERROR))
+ goto out_free;
+
+ if (dest_states[i] != dest_states_word[i] && dfa->mb_cur_max > 1)
+ need_word_trtable = true;
+
+ dest_states_nl[i] = re_acquire_state_context (&err, dfa, &follows,
+ CONTEXT_NEWLINE);
+ if (__glibc_unlikely (dest_states_nl[i] == NULL && err != REG_NOERROR))
+ goto out_free;
+ }
+ else
+ {
+ dest_states_word[i] = dest_states[i];
+ dest_states_nl[i] = dest_states[i];
+ }
+ bitset_merge (acceptable, dests_ch[i]);
+ }
+
+ if (!__glibc_unlikely (need_word_trtable))
+ {
+ /* We don't care about whether the following character is a word
+ character, or we are in a single-byte character set so we can
+ discern by looking at the character code: allocate a
+ 256-entry transition table. */
+ trtable = state->trtable =
+ (re_dfastate_t **) calloc (sizeof (re_dfastate_t *), SBC_MAX);
+ if (__glibc_unlikely (trtable == NULL))
+ goto out_free;
+
+ /* For all characters ch...: */
+ for (i = 0; i < BITSET_WORDS; ++i)
+ for (ch = i * BITSET_WORD_BITS, elem = acceptable[i], mask = 1;
+ elem;
+ mask <<= 1, elem >>= 1, ++ch)
+ if (__glibc_unlikely (elem & 1))
+ {
+ /* There must be exactly one destination which accepts
+ character ch. See group_nodes_into_DFAstates. */
+ for (j = 0; (dests_ch[j][i] & mask) == 0; ++j)
+ ;
+
+ /* j-th destination accepts the word character ch. */
+ if (dfa->word_char[i] & mask)
+ trtable[ch] = dest_states_word[j];
+ else
+ trtable[ch] = dest_states[j];
+ }
+ }
+ else
+ {
+ /* We care about whether the following character is a word
+ character, and we are in a multi-byte character set: discern
+ by looking at the character code: build two 256-entry
+ transition tables, one starting at trtable[0] and one
+ starting at trtable[SBC_MAX]. */
+ trtable = state->word_trtable =
+ (re_dfastate_t **) calloc (sizeof (re_dfastate_t *), 2 * SBC_MAX);
+ if (__glibc_unlikely (trtable == NULL))
+ goto out_free;
+
+ /* For all characters ch...: */
+ for (i = 0; i < BITSET_WORDS; ++i)
+ for (ch = i * BITSET_WORD_BITS, elem = acceptable[i], mask = 1;
+ elem;
+ mask <<= 1, elem >>= 1, ++ch)
+ if (__glibc_unlikely (elem & 1))
+ {
+ /* There must be exactly one destination which accepts
+ character ch. See group_nodes_into_DFAstates. */
+ for (j = 0; (dests_ch[j][i] & mask) == 0; ++j)
+ ;
+
+ /* j-th destination accepts the word character ch. */
+ trtable[ch] = dest_states[j];
+ trtable[ch + SBC_MAX] = dest_states_word[j];
+ }
+ }
+
+ /* new line */
+ if (bitset_contain (acceptable, NEWLINE_CHAR))
+ {
+ /* The current state accepts newline character. */
+ for (j = 0; j < ndests; ++j)
+ if (bitset_contain (dests_ch[j], NEWLINE_CHAR))
+ {
+ /* k-th destination accepts newline character. */
+ trtable[NEWLINE_CHAR] = dest_states_nl[j];
+ if (need_word_trtable)
+ trtable[NEWLINE_CHAR + SBC_MAX] = dest_states_nl[j];
+ /* There must be only one destination which accepts
+ newline. See group_nodes_into_DFAstates. */
+ break;
+ }
+ }
+
+ 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;
+}
+
+/* Group all nodes belonging to STATE into several destinations.
+ Then for all destinations, set the nodes belonging to the destination
+ to DESTS_NODE[i] and set the characters accepted by the destination
+ to DEST_CH[i]. This function return the number of destinations. */
+
+static Idx
+group_nodes_into_DFAstates (const re_dfa_t *dfa, const re_dfastate_t *state,
+ re_node_set *dests_node, bitset_t *dests_ch)
+{
+ reg_errcode_t err;
+ bool ok;
+ Idx i, j, k;
+ Idx ndests; /* Number of the destinations from 'state'. */
+ bitset_t accepts; /* Characters a node can accept. */
+ const re_node_set *cur_nodes = &state->nodes;
+ bitset_empty (accepts);
+ ndests = 0;
+
+ /* For all the nodes belonging to 'state', */
+ for (i = 0; i < cur_nodes->nelem; ++i)
+ {
+ re_token_t *node = &dfa->nodes[cur_nodes->elems[i]];
+ re_token_type_t type = node->type;
+ unsigned int constraint = node->constraint;
+
+ /* Enumerate all single byte character this node can accept. */
+ if (type == CHARACTER)
+ bitset_set (accepts, node->opr.c);
+ else if (type == SIMPLE_BRACKET)
+ {
+ bitset_merge (accepts, node->opr.sbcset);
+ }
+ else if (type == OP_PERIOD)
+ {
+#ifdef RE_ENABLE_I18N
+ if (dfa->mb_cur_max > 1)
+ bitset_merge (accepts, dfa->sb_char);
+ else
+#endif
+ bitset_set_all (accepts);
+ if (!(dfa->syntax & RE_DOT_NEWLINE))
+ bitset_clear (accepts, '\n');
+ if (dfa->syntax & RE_DOT_NOT_NULL)
+ bitset_clear (accepts, '\0');
+ }
+#ifdef RE_ENABLE_I18N
+ else if (type == OP_UTF8_PERIOD)
+ {
+ if (ASCII_CHARS % BITSET_WORD_BITS == 0)
+ memset (accepts, -1, ASCII_CHARS / CHAR_BIT);
+ else
+ bitset_merge (accepts, utf8_sb_map);
+ if (!(dfa->syntax & RE_DOT_NEWLINE))
+ bitset_clear (accepts, '\n');
+ if (dfa->syntax & RE_DOT_NOT_NULL)
+ bitset_clear (accepts, '\0');
+ }
+#endif
+ else
+ continue;
+
+ /* Check the 'accepts' and sift the characters which are not
+ match it the context. */
+ if (constraint)
+ {
+ if (constraint & NEXT_NEWLINE_CONSTRAINT)
+ {
+ bool accepts_newline = bitset_contain (accepts, NEWLINE_CHAR);
+ bitset_empty (accepts);
+ if (accepts_newline)
+ bitset_set (accepts, NEWLINE_CHAR);
+ else
+ continue;
+ }
+ if (constraint & NEXT_ENDBUF_CONSTRAINT)
+ {
+ bitset_empty (accepts);
+ continue;
+ }
+
+ if (constraint & NEXT_WORD_CONSTRAINT)
+ {
+ bitset_word_t any_set = 0;
+ if (type == CHARACTER && !node->word_char)
+ {
+ bitset_empty (accepts);
+ continue;
+ }
+#ifdef RE_ENABLE_I18N
+ if (dfa->mb_cur_max > 1)
+ for (j = 0; j < BITSET_WORDS; ++j)
+ any_set |= (accepts[j] &= (dfa->word_char[j] | ~dfa->sb_char[j]));
+ else
+#endif
+ for (j = 0; j < BITSET_WORDS; ++j)
+ any_set |= (accepts[j] &= dfa->word_char[j]);
+ if (!any_set)
+ continue;
+ }
+ if (constraint & NEXT_NOTWORD_CONSTRAINT)
+ {
+ bitset_word_t any_set = 0;
+ if (type == CHARACTER && node->word_char)
+ {
+ bitset_empty (accepts);
+ continue;
+ }
+#ifdef RE_ENABLE_I18N
+ if (dfa->mb_cur_max > 1)
+ for (j = 0; j < BITSET_WORDS; ++j)
+ any_set |= (accepts[j] &= ~(dfa->word_char[j] & dfa->sb_char[j]));
+ else
+#endif
+ for (j = 0; j < BITSET_WORDS; ++j)
+ any_set |= (accepts[j] &= ~dfa->word_char[j]);
+ if (!any_set)
+ continue;
+ }
+ }
+
+ /* Then divide 'accepts' into DFA states, or create a new
+ state. Above, we make sure that accepts is not empty. */
+ for (j = 0; j < ndests; ++j)
+ {
+ bitset_t intersec; /* Intersection sets, see below. */
+ bitset_t remains;
+ /* Flags, see below. */
+ bitset_word_t has_intersec, not_subset, not_consumed;
+
+ /* Optimization, skip if this state doesn't accept the character. */
+ if (type == CHARACTER && !bitset_contain (dests_ch[j], node->opr.c))
+ continue;
+
+ /* Enumerate the intersection set of this state and 'accepts'. */
+ has_intersec = 0;
+ for (k = 0; k < BITSET_WORDS; ++k)
+ has_intersec |= intersec[k] = accepts[k] & dests_ch[j][k];
+ /* And skip if the intersection set is empty. */
+ if (!has_intersec)
+ continue;
+
+ /* Then check if this state is a subset of 'accepts'. */
+ not_subset = not_consumed = 0;
+ for (k = 0; k < BITSET_WORDS; ++k)
+ {
+ not_subset |= remains[k] = ~accepts[k] & dests_ch[j][k];
+ not_consumed |= accepts[k] = accepts[k] & ~dests_ch[j][k];
+ }
+
+ /* If this state isn't a subset of 'accepts', create a
+ new group state, which has the 'remains'. */
+ if (not_subset)
+ {
+ bitset_copy (dests_ch[ndests], remains);
+ bitset_copy (dests_ch[j], intersec);
+ err = re_node_set_init_copy (dests_node + ndests, &dests_node[j]);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ goto error_return;
+ ++ndests;
+ }
+
+ /* Put the position in the current group. */
+ ok = re_node_set_insert (&dests_node[j], cur_nodes->elems[i]);
+ if (__glibc_unlikely (! ok))
+ goto error_return;
+
+ /* If all characters are consumed, go to next node. */
+ if (!not_consumed)
+ break;
+ }
+ /* Some characters remain, create a new group. */
+ if (j == ndests)
+ {
+ bitset_copy (dests_ch[ndests], accepts);
+ err = re_node_set_init_1 (dests_node + ndests, cur_nodes->elems[i]);
+ if (__glibc_unlikely (err != REG_NOERROR))
+ goto error_return;
+ ++ndests;
+ bitset_empty (accepts);
+ }
+ }
+ return ndests;
+ error_return:
+ for (j = 0; j < ndests; ++j)
+ re_node_set_free (dests_node + j);
+ return -1;
+}
+
+#ifdef RE_ENABLE_I18N
+/* Check how many bytes the node 'dfa->nodes[node_idx]' accepts.
+ Return the number of the bytes the node accepts.
+ STR_IDX is the current index of the input string.
+
+ This function handles the nodes which can accept one character, or
+ one collating element like '.', '[a-z]', opposite to the other nodes
+ can only accept one byte. */
+
+# ifdef _LIBC
+# include <locale/weight.h>
+# endif
+
+static int
+check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx,
+ const re_string_t *input, Idx str_idx)
+{
+ const re_token_t *node = dfa->nodes + node_idx;
+ int char_len, elem_len;
+ Idx i;
+
+ if (__glibc_unlikely (node->type == OP_UTF8_PERIOD))
+ {
+ unsigned char c = re_string_byte_at (input, str_idx), d;
+ if (__glibc_likely (c < 0xc2))
+ return 0;
+
+ if (str_idx + 2 > input->len)
+ return 0;
+
+ d = re_string_byte_at (input, str_idx + 1);
+ if (c < 0xe0)
+ return (d < 0x80 || d > 0xbf) ? 0 : 2;
+ else if (c < 0xf0)
+ {
+ char_len = 3;
+ if (c == 0xe0 && d < 0xa0)
+ return 0;
+ }
+ else if (c < 0xf8)
+ {
+ char_len = 4;
+ if (c == 0xf0 && d < 0x90)
+ return 0;
+ }
+ else if (c < 0xfc)
+ {
+ char_len = 5;
+ if (c == 0xf8 && d < 0x88)
+ return 0;
+ }
+ else if (c < 0xfe)
+ {
+ char_len = 6;
+ if (c == 0xfc && d < 0x84)
+ return 0;
+ }
+ else
+ return 0;
+
+ if (str_idx + char_len > input->len)
+ return 0;
+
+ for (i = 1; i < char_len; ++i)
+ {
+ d = re_string_byte_at (input, str_idx + i);
+ if (d < 0x80 || d > 0xbf)
+ return 0;
+ }
+ return char_len;
+ }
+
+ char_len = re_string_char_size_at (input, str_idx);
+ if (node->type == OP_PERIOD)
+ {
+ if (char_len <= 1)
+ return 0;
+ /* FIXME: I don't think this if is needed, as both '\n'
+ and '\0' are char_len == 1. */
+ /* '.' accepts any one character except the following two cases. */
+ if ((!(dfa->syntax & RE_DOT_NEWLINE)
+ && re_string_byte_at (input, str_idx) == '\n')
+ || ((dfa->syntax & RE_DOT_NOT_NULL)
+ && re_string_byte_at (input, str_idx) == '\0'))
+ return 0;
+ return char_len;
+ }
+
+ elem_len = re_string_elem_size_at (input, str_idx);
+ if ((elem_len <= 1 && char_len <= 1) || char_len == 0)
+ return 0;
+
+ if (node->type == COMPLEX_BRACKET)
+ {
+ const re_charset_t *cset = node->opr.mbcset;
+# ifdef _LIBC
+ const unsigned char *pin
+ = ((const unsigned char *) re_string_get_buffer (input) + str_idx);
+ Idx j;
+ uint32_t nrules;
+# endif /* _LIBC */
+ int match_len = 0;
+ wchar_t wc = ((cset->nranges || cset->nchar_classes || cset->nmbchars)
+ ? re_string_wchar_at (input, str_idx) : 0);
+
+ /* match with multibyte character? */
+ for (i = 0; i < cset->nmbchars; ++i)
+ if (wc == cset->mbchars[i])
+ {
+ match_len = char_len;
+ goto check_node_accept_bytes_match;
+ }
+ /* match with character_class? */
+ for (i = 0; i < cset->nchar_classes; ++i)
+ {
+ wctype_t wt = cset->char_classes[i];
+ if (__iswctype (wc, wt))
+ {
+ match_len = char_len;
+ goto check_node_accept_bytes_match;
+ }
+ }
+
+# ifdef _LIBC
+ nrules = _NL_CURRENT_WORD (LC_COLLATE, _NL_COLLATE_NRULES);
+ if (nrules != 0)
+ {
+ unsigned int in_collseq = 0;
+ const int32_t *table, *indirect;
+ const unsigned char *weights, *extra;
+ const char *collseqwc;
+
+ /* match with collating_symbol? */
+ if (cset->ncoll_syms)
+ extra = (const unsigned char *)
+ _NL_CURRENT (LC_COLLATE, _NL_COLLATE_SYMB_EXTRAMB);
+ for (i = 0; i < cset->ncoll_syms; ++i)
+ {
+ const unsigned char *coll_sym = extra + cset->coll_syms[i];
+ /* Compare the length of input collating element and
+ the length of current collating element. */
+ if (*coll_sym != elem_len)
+ continue;
+ /* Compare each bytes. */
+ for (j = 0; j < *coll_sym; j++)
+ if (pin[j] != coll_sym[1 + j])
+ break;
+ if (j == *coll_sym)
+ {
+ /* Match if every bytes is equal. */
+ match_len = j;
+ goto check_node_accept_bytes_match;
+ }
+ }
+
+ if (cset->nranges)
+ {
+ if (elem_len <= char_len)
+ {
+ collseqwc = _NL_CURRENT (LC_COLLATE, _NL_COLLATE_COLLSEQWC);
+ in_collseq = __collseq_table_lookup (collseqwc, wc);
+ }
+ else
+ in_collseq = find_collation_sequence_value (pin, elem_len);
+ }
+ /* match with range expression? */
+ /* FIXME: Implement rational ranges here, too. */
+ for (i = 0; i < cset->nranges; ++i)
+ if (cset->range_starts[i] <= in_collseq
+ && in_collseq <= cset->range_ends[i])
+ {
+ match_len = elem_len;
+ goto check_node_accept_bytes_match;
+ }
+
+ /* match with equivalence_class? */
+ if (cset->nequiv_classes)
+ {
+ const unsigned char *cp = pin;
+ table = (const int32_t *)
+ _NL_CURRENT (LC_COLLATE, _NL_COLLATE_TABLEMB);
+ weights = (const unsigned char *)
+ _NL_CURRENT (LC_COLLATE, _NL_COLLATE_WEIGHTMB);
+ extra = (const unsigned char *)
+ _NL_CURRENT (LC_COLLATE, _NL_COLLATE_EXTRAMB);
+ indirect = (const int32_t *)
+ _NL_CURRENT (LC_COLLATE, _NL_COLLATE_INDIRECTMB);
+ int32_t idx = findidx (table, indirect, extra, &cp, elem_len);
+ int32_t rule = idx >> 24;
+ idx &= 0xffffff;
+ if (idx > 0)
+ {
+ size_t weight_len = weights[idx];
+ for (i = 0; i < cset->nequiv_classes; ++i)
+ {
+ int32_t equiv_class_idx = cset->equiv_classes[i];
+ int32_t equiv_class_rule = equiv_class_idx >> 24;
+ equiv_class_idx &= 0xffffff;
+ if (weights[equiv_class_idx] == weight_len
+ && equiv_class_rule == rule
+ && memcmp (weights + idx + 1,
+ weights + equiv_class_idx + 1,
+ weight_len) == 0)
+ {
+ match_len = elem_len;
+ goto check_node_accept_bytes_match;
+ }
+ }
+ }
+ }
+ }
+ else
+# endif /* _LIBC */
+ {
+ /* match with range expression? */
+ for (i = 0; i < cset->nranges; ++i)
+ {
+ if (cset->range_starts[i] <= wc && wc <= cset->range_ends[i])
+ {
+ match_len = char_len;
+ goto check_node_accept_bytes_match;
+ }
+ }
+ }
+ check_node_accept_bytes_match:
+ if (!cset->non_match)
+ return match_len;
+ else
+ {
+ if (match_len > 0)
+ return 0;
+ else
+ return (elem_len > char_len) ? elem_len : char_len;
+ }
+ }
+ return 0;
+}
+
+# ifdef _LIBC
+static unsigned int
+find_collation_sequence_value (const unsigned char *mbs, size_t mbs_len)
+{
+ uint32_t nrules = _NL_CURRENT_WORD (LC_COLLATE, _NL_COLLATE_NRULES);
+ if (nrules == 0)
+ {
+ if (mbs_len == 1)
+ {
+ /* No valid character. Match it as a single byte character. */
+ const unsigned char *collseq = (const unsigned char *)
+ _NL_CURRENT (LC_COLLATE, _NL_COLLATE_COLLSEQMB);
+ return collseq[mbs[0]];
+ }
+ return UINT_MAX;
+ }
+ else
+ {
+ int32_t idx;
+ const unsigned char *extra = (const unsigned char *)
+ _NL_CURRENT (LC_COLLATE, _NL_COLLATE_SYMB_EXTRAMB);
+ int32_t extrasize = (const unsigned char *)
+ _NL_CURRENT (LC_COLLATE, _NL_COLLATE_SYMB_EXTRAMB + 1) - extra;
+
+ for (idx = 0; idx < extrasize;)
+ {
+ int mbs_cnt;
+ bool found = false;
+ int32_t elem_mbs_len;
+ /* Skip the name of collating element name. */
+ idx = idx + extra[idx] + 1;
+ elem_mbs_len = extra[idx++];
+ if (mbs_len == elem_mbs_len)
+ {
+ for (mbs_cnt = 0; mbs_cnt < elem_mbs_len; ++mbs_cnt)
+ if (extra[idx + mbs_cnt] != mbs[mbs_cnt])
+ break;
+ if (mbs_cnt == elem_mbs_len)
+ /* Found the entry. */
+ found = true;
+ }
+ /* Skip the byte sequence of the collating element. */
+ idx += elem_mbs_len;
+ /* Adjust for the alignment. */
+ idx = (idx + 3) & ~3;
+ /* Skip the collation sequence value. */
+ idx += sizeof (uint32_t);
+ /* Skip the wide char sequence of the collating element. */
+ idx = idx + sizeof (uint32_t) * (*(int32_t *) (extra + idx) + 1);
+ /* If we found the entry, return the sequence value. */
+ if (found)
+ return *(uint32_t *) (extra + idx);
+ /* Skip the collation sequence value. */
+ idx += sizeof (uint32_t);
+ }
+ return UINT_MAX;
+ }
+}
+# endif /* _LIBC */
+#endif /* RE_ENABLE_I18N */
+
+/* Check whether the node accepts the byte which is IDX-th
+ byte of the INPUT. */
+
+static bool
+check_node_accept (const re_match_context_t *mctx, const re_token_t *node,
+ Idx idx)
+{
+ unsigned char ch;
+ ch = re_string_byte_at (&mctx->input, idx);
+ switch (node->type)
+ {
+ case CHARACTER:
+ if (node->opr.c != ch)
+ return false;
+ break;
+
+ case SIMPLE_BRACKET:
+ if (!bitset_contain (node->opr.sbcset, ch))
+ return false;
+ break;
+
+#ifdef RE_ENABLE_I18N
+ case OP_UTF8_PERIOD:
+ if (ch >= ASCII_CHARS)
+ return false;
+ FALLTHROUGH;
+#endif
+ case OP_PERIOD:
+ if ((ch == '\n' && !(mctx->dfa->syntax & RE_DOT_NEWLINE))
+ || (ch == '\0' && (mctx->dfa->syntax & RE_DOT_NOT_NULL)))
+ return false;
+ break;
+
+ default:
+ return false;
+ }
+
+ if (node->constraint)
+ {
+ /* The node has constraints. Check whether the current context
+ satisfies the constraints. */
+ unsigned int context = re_string_context_at (&mctx->input, idx,
+ mctx->eflags);
+ if (NOT_SATISFY_NEXT_CONSTRAINT (node->constraint, context))
+ return false;
+ }
+
+ return true;
+}
+
+/* Extend the buffers, if the buffers have run out. */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+extend_buffers (re_match_context_t *mctx, int min_len)
+{
+ reg_errcode_t ret;
+ re_string_t *pstr = &mctx->input;
+
+ /* Avoid overflow. */
+ if (__glibc_unlikely (MIN (IDX_MAX, SIZE_MAX / sizeof (re_dfastate_t *)) / 2
+ <= pstr->bufs_len))
+ return REG_ESPACE;
+
+ /* Double the lengths of the buffers, but allocate at least MIN_LEN. */
+ ret = re_string_realloc_buffers (pstr,
+ MAX (min_len,
+ MIN (pstr->len, pstr->bufs_len * 2)));
+ if (__glibc_unlikely (ret != REG_NOERROR))
+ return ret;
+
+ if (mctx->state_log != NULL)
+ {
+ /* And double the length of state_log. */
+ /* XXX We have no indication of the size of this buffer. If this
+ allocation fail we have no indication that the state_log array
+ does not have the right size. */
+ re_dfastate_t **new_array = re_realloc (mctx->state_log, re_dfastate_t *,
+ pstr->bufs_len + 1);
+ if (__glibc_unlikely (new_array == NULL))
+ return REG_ESPACE;
+ mctx->state_log = new_array;
+ }
+
+ /* Then reconstruct the buffers. */
+ if (pstr->icase)
+ {
+#ifdef RE_ENABLE_I18N
+ if (pstr->mb_cur_max > 1)
+ {
+ ret = build_wcs_upper_buffer (pstr);
+ if (__glibc_unlikely (ret != REG_NOERROR))
+ return ret;
+ }
+ else
+#endif /* RE_ENABLE_I18N */
+ build_upper_buffer (pstr);
+ }
+ else
+ {
+#ifdef RE_ENABLE_I18N
+ if (pstr->mb_cur_max > 1)
+ build_wcs_buffer (pstr);
+ else
+#endif /* RE_ENABLE_I18N */
+ {
+ if (pstr->trans != NULL)
+ re_string_translate_buffer (pstr);
+ }
+ }
+ return REG_NOERROR;
+}
+
+
+/* Functions for matching context. */
+
+/* Initialize MCTX. */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+match_ctx_init (re_match_context_t *mctx, int eflags, Idx n)
+{
+ mctx->eflags = eflags;
+ mctx->match_last = -1;
+ if (n > 0)
+ {
+ /* Avoid overflow. */
+ size_t max_object_size =
+ MAX (sizeof (struct re_backref_cache_entry),
+ sizeof (re_sub_match_top_t *));
+ if (__glibc_unlikely (MIN (IDX_MAX, SIZE_MAX / max_object_size) < n))
+ return REG_ESPACE;
+
+ mctx->bkref_ents = re_malloc (struct re_backref_cache_entry, n);
+ mctx->sub_tops = re_malloc (re_sub_match_top_t *, n);
+ if (__glibc_unlikely (mctx->bkref_ents == NULL || mctx->sub_tops == NULL))
+ return REG_ESPACE;
+ }
+ /* Already zero-ed by the caller.
+ else
+ mctx->bkref_ents = NULL;
+ mctx->nbkref_ents = 0;
+ mctx->nsub_tops = 0; */
+ mctx->abkref_ents = n;
+ mctx->max_mb_elem_len = 1;
+ mctx->asub_tops = n;
+ return REG_NOERROR;
+}
+
+/* Clean the entries which depend on the current input in MCTX.
+ This function must be invoked when the matcher changes the start index
+ of the input, or changes the input string. */
+
+static void
+match_ctx_clean (re_match_context_t *mctx)
+{
+ Idx st_idx;
+ for (st_idx = 0; st_idx < mctx->nsub_tops; ++st_idx)
+ {
+ Idx sl_idx;
+ re_sub_match_top_t *top = mctx->sub_tops[st_idx];
+ for (sl_idx = 0; sl_idx < top->nlasts; ++sl_idx)
+ {
+ re_sub_match_last_t *last = top->lasts[sl_idx];
+ re_free (last->path.array);
+ re_free (last);
+ }
+ re_free (top->lasts);
+ if (top->path)
+ {
+ re_free (top->path->array);
+ re_free (top->path);
+ }
+ re_free (top);
+ }
+
+ mctx->nsub_tops = 0;
+ mctx->nbkref_ents = 0;
+}
+
+/* Free all the memory associated with MCTX. */
+
+static void
+match_ctx_free (re_match_context_t *mctx)
+{
+ /* First, free all the memory associated with MCTX->SUB_TOPS. */
+ match_ctx_clean (mctx);
+ re_free (mctx->sub_tops);
+ re_free (mctx->bkref_ents);
+}
+
+/* Add a new backreference entry to MCTX.
+ Note that we assume that caller never call this function with duplicate
+ entry, and call with STR_IDX which isn't smaller than any existing entry.
+*/
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+match_ctx_add_entry (re_match_context_t *mctx, Idx node, Idx str_idx, Idx from,
+ Idx to)
+{
+ if (mctx->nbkref_ents >= mctx->abkref_ents)
+ {
+ struct re_backref_cache_entry* new_entry;
+ new_entry = re_realloc (mctx->bkref_ents, struct re_backref_cache_entry,
+ mctx->abkref_ents * 2);
+ if (__glibc_unlikely (new_entry == NULL))
+ {
+ re_free (mctx->bkref_ents);
+ return REG_ESPACE;
+ }
+ mctx->bkref_ents = new_entry;
+ memset (mctx->bkref_ents + mctx->nbkref_ents, '\0',
+ sizeof (struct re_backref_cache_entry) * mctx->abkref_ents);
+ mctx->abkref_ents *= 2;
+ }
+ if (mctx->nbkref_ents > 0
+ && mctx->bkref_ents[mctx->nbkref_ents - 1].str_idx == str_idx)
+ mctx->bkref_ents[mctx->nbkref_ents - 1].more = 1;
+
+ mctx->bkref_ents[mctx->nbkref_ents].node = node;
+ mctx->bkref_ents[mctx->nbkref_ents].str_idx = str_idx;
+ mctx->bkref_ents[mctx->nbkref_ents].subexp_from = from;
+ mctx->bkref_ents[mctx->nbkref_ents].subexp_to = to;
+
+ /* This is a cache that saves negative results of check_dst_limits_calc_pos.
+ If bit N is clear, means that this entry won't epsilon-transition to
+ an OP_OPEN_SUBEXP or OP_CLOSE_SUBEXP for the N+1-th subexpression. If
+ it is set, check_dst_limits_calc_pos_1 will recurse and try to find one
+ such node.
+
+ A backreference does not epsilon-transition unless it is empty, so set
+ to all zeros if FROM != TO. */
+ mctx->bkref_ents[mctx->nbkref_ents].eps_reachable_subexps_map
+ = (from == to ? -1 : 0);
+
+ mctx->bkref_ents[mctx->nbkref_ents++].more = 0;
+ if (mctx->max_mb_elem_len < to - from)
+ mctx->max_mb_elem_len = to - from;
+ return REG_NOERROR;
+}
+
+/* Return the first entry with the same str_idx, or -1 if none is
+ found. Note that MCTX->BKREF_ENTS is already sorted by MCTX->STR_IDX. */
+
+static Idx
+search_cur_bkref_entry (const re_match_context_t *mctx, Idx str_idx)
+{
+ Idx left, right, mid, last;
+ last = right = mctx->nbkref_ents;
+ for (left = 0; left < right;)
+ {
+ mid = (left + right) / 2;
+ if (mctx->bkref_ents[mid].str_idx < str_idx)
+ left = mid + 1;
+ else
+ right = mid;
+ }
+ if (left < last && mctx->bkref_ents[left].str_idx == str_idx)
+ return left;
+ else
+ return -1;
+}
+
+/* Register the node NODE, whose type is OP_OPEN_SUBEXP, and which matches
+ at STR_IDX. */
+
+static reg_errcode_t
+__attribute_warn_unused_result__
+match_ctx_add_subtop (re_match_context_t *mctx, Idx node, Idx str_idx)
+{
+#ifdef DEBUG
+ assert (mctx->sub_tops != NULL);
+ assert (mctx->asub_tops > 0);
+#endif
+ if (__glibc_unlikely (mctx->nsub_tops == mctx->asub_tops))
+ {
+ Idx new_asub_tops = mctx->asub_tops * 2;
+ re_sub_match_top_t **new_array = re_realloc (mctx->sub_tops,
+ re_sub_match_top_t *,
+ new_asub_tops);
+ if (__glibc_unlikely (new_array == NULL))
+ return REG_ESPACE;
+ mctx->sub_tops = new_array;
+ mctx->asub_tops = new_asub_tops;
+ }
+ mctx->sub_tops[mctx->nsub_tops] = calloc (1, sizeof (re_sub_match_top_t));
+ if (__glibc_unlikely (mctx->sub_tops[mctx->nsub_tops] == NULL))
+ return REG_ESPACE;
+ mctx->sub_tops[mctx->nsub_tops]->node = node;
+ mctx->sub_tops[mctx->nsub_tops++]->str_idx = str_idx;
+ return REG_NOERROR;
+}
+
+/* Register the node NODE, whose type is OP_CLOSE_SUBEXP, and which matches
+ at STR_IDX, whose corresponding OP_OPEN_SUBEXP is SUB_TOP. */
+
+static re_sub_match_last_t *
+match_ctx_add_sublast (re_sub_match_top_t *subtop, Idx node, Idx str_idx)
+{
+ re_sub_match_last_t *new_entry;
+ if (__glibc_unlikely (subtop->nlasts == subtop->alasts))
+ {
+ Idx new_alasts = 2 * subtop->alasts + 1;
+ re_sub_match_last_t **new_array = re_realloc (subtop->lasts,
+ re_sub_match_last_t *,
+ new_alasts);
+ if (__glibc_unlikely (new_array == NULL))
+ return NULL;
+ subtop->lasts = new_array;
+ subtop->alasts = new_alasts;
+ }
+ new_entry = calloc (1, sizeof (re_sub_match_last_t));
+ if (__glibc_likely (new_entry != NULL))
+ {
+ subtop->lasts[subtop->nlasts] = new_entry;
+ new_entry->node = node;
+ new_entry->str_idx = str_idx;
+ ++subtop->nlasts;
+ }
+ return new_entry;
+}
+
+static void
+sift_ctx_init (re_sift_context_t *sctx, re_dfastate_t **sifted_sts,
+ re_dfastate_t **limited_sts, Idx last_node, Idx last_str_idx)
+{
+ sctx->sifted_states = sifted_sts;
+ sctx->limited_states = limited_sts;
+ sctx->last_node = last_node;
+ sctx->last_str_idx = last_str_idx;
+ re_node_set_init_empty (&sctx->limits);
+}
diff --git a/lib/set-permissions.c b/lib/set-permissions.c
index e99d51fcd20..38cd30a5a1c 100644
--- a/lib/set-permissions.c
+++ b/lib/set-permissions.c
@@ -24,7 +24,7 @@
#include "acl-internal.h"
#if USE_ACL
-# if ! defined HAVE_ACL_FROM_MODE && defined HAVE_ACL_FROM_TEXT /* FreeBSD, IRIX, Tru64 */
+# if ! defined HAVE_ACL_FROM_MODE && defined HAVE_ACL_FROM_TEXT /* FreeBSD, IRIX, Tru64, Cygwin >= 2.5 */
# if HAVE_ACL_GET_FILE && !HAVE_ACL_TYPE_EXTENDED
static acl_t
@@ -32,7 +32,7 @@ acl_from_mode (mode_t mode)
{
# if HAVE_ACL_FREE_TEXT /* Tru64 */
char acl_text[] = "u::---,g::---,o::---,";
-# else /* FreeBSD, IRIX */
+# else /* FreeBSD, IRIX, Cygwin >= 2.5 */
char acl_text[] = "u::---,g::---,o::---";
# endif
@@ -51,7 +51,7 @@ acl_from_mode (mode_t mode)
# endif
# endif
-# if HAVE_FACL && defined GETACL /* Solaris, Cygwin, not HP-UX */
+# if HAVE_FACL && defined GETACL /* Solaris, Cygwin < 2.5, not HP-UX */
static int
set_acls_from_mode (const char *name, int desc, mode_t mode, bool *must_chmod)
{
@@ -229,14 +229,14 @@ set_acls_from_mode (const char *name, int desc, mode_t mode, bool *must_chmod)
if (ret < 0 && errno != EINVAL && errno != ENOTSUP)
{
if (errno == ENOSYS)
- {
- *must_chmod = true;
- return 0;
- }
+ {
+ *must_chmod = true;
+ return 0;
+ }
return -1;
}
if (ret == 0)
- return 0;
+ return 0;
}
# endif
@@ -256,18 +256,18 @@ set_acls_from_mode (const char *name, int desc, mode_t mode, bool *must_chmod)
if (desc != -1)
ret = facl (desc, SETACL,
- sizeof (entries) / sizeof (aclent_t), entries);
+ sizeof (entries) / sizeof (aclent_t), entries);
else
ret = acl (name, SETACL,
- sizeof (entries) / sizeof (aclent_t), entries);
+ sizeof (entries) / sizeof (aclent_t), entries);
if (ret < 0)
{
- if (errno == ENOSYS || errno == EOPNOTSUPP)
- {
- *must_chmod = true;
- return 0;
- }
- return -1;
+ if (errno == ENOSYS || errno == EOPNOTSUPP)
+ {
+ *must_chmod = true;
+ return 0;
+ }
+ return -1;
}
return 0;
}
@@ -483,15 +483,15 @@ context_acl_from_mode (struct permission_context *ctx)
static int
set_acls (struct permission_context *ctx, const char *name, int desc,
- int from_mode, bool *must_chmod, bool *acls_set)
+ int from_mode, bool *must_chmod, bool *acls_set)
{
int ret = 0;
# if HAVE_ACL_GET_FILE
/* POSIX 1003.1e (draft 17 -- abandoned) specific version. */
- /* Linux, FreeBSD, Mac OS X, IRIX, Tru64 */
+ /* Linux, FreeBSD, Mac OS X, IRIX, Tru64, Cygwin >= 2.5 */
# if !HAVE_ACL_TYPE_EXTENDED
- /* Linux, FreeBSD, IRIX, Tru64 */
+ /* Linux, FreeBSD, IRIX, Tru64, Cygwin >= 2.5 */
# ifndef HAVE_ACL_FROM_TEXT
# error Must have acl_from_text (see POSIX 1003.1e draft 17).
@@ -503,53 +503,53 @@ set_acls (struct permission_context *ctx, const char *name, int desc,
if (! ctx->acls_not_supported)
{
if (ret == 0 && from_mode)
- {
- if (ctx->acl)
- acl_free (ctx->acl);
- ctx->acl = acl_from_mode (ctx->mode);
- if (ctx->acl == NULL)
- ret = -1;
- }
+ {
+ if (ctx->acl)
+ acl_free (ctx->acl);
+ ctx->acl = acl_from_mode (ctx->mode);
+ if (ctx->acl == NULL)
+ ret = -1;
+ }
if (ret == 0 && ctx->acl)
- {
- if (HAVE_ACL_SET_FD && desc != -1)
- ret = acl_set_fd (desc, ctx->acl);
- else
- ret = acl_set_file (name, ACL_TYPE_ACCESS, ctx->acl);
- if (ret != 0)
- {
- if (! acl_errno_valid (errno))
- {
- ctx->acls_not_supported = true;
- if (from_mode || acl_access_nontrivial (ctx->acl) == 0)
- ret = 0;
- }
- }
- else
- {
- *acls_set = true;
- if (S_ISDIR(ctx->mode))
- {
- if (! from_mode && ctx->default_acl &&
- acl_default_nontrivial (ctx->default_acl))
- ret = acl_set_file (name, ACL_TYPE_DEFAULT,
- ctx->default_acl);
- else
- ret = acl_delete_def_file (name);
- }
- }
- }
+ {
+ if (HAVE_ACL_SET_FD && desc != -1)
+ ret = acl_set_fd (desc, ctx->acl);
+ else
+ ret = acl_set_file (name, ACL_TYPE_ACCESS, ctx->acl);
+ if (ret != 0)
+ {
+ if (! acl_errno_valid (errno))
+ {
+ ctx->acls_not_supported = true;
+ if (from_mode || acl_access_nontrivial (ctx->acl) == 0)
+ ret = 0;
+ }
+ }
+ else
+ {
+ *acls_set = true;
+ if (S_ISDIR(ctx->mode))
+ {
+ if (! from_mode && ctx->default_acl &&
+ acl_default_nontrivial (ctx->default_acl))
+ ret = acl_set_file (name, ACL_TYPE_DEFAULT,
+ ctx->default_acl);
+ else
+ ret = acl_delete_def_file (name);
+ }
+ }
+ }
}
-# if HAVE_ACL_TYPE_NFS4 /* FreeBSD */
+# if HAVE_ACL_TYPE_NFS4 /* FreeBSD */
/* File systems either support POSIX ACLs (for example, ufs) or NFS4 ACLs
(for example, zfs). */
/* TODO: Implement setting ACLs once get_permissions() reads them. */
-# endif
+# endif
# else /* HAVE_ACL_TYPE_EXTENDED */
/* Mac OS X */
@@ -573,38 +573,38 @@ set_acls (struct permission_context *ctx, const char *name, int desc,
/* Remove ACLs if the file has ACLs. */
if (HAVE_ACL_GET_FD && desc != -1)
- acl = acl_get_fd (desc);
+ acl = acl_get_fd (desc);
else
- acl = acl_get_file (name, ACL_TYPE_EXTENDED);
+ acl = acl_get_file (name, ACL_TYPE_EXTENDED);
if (acl)
- {
- acl_free (acl);
-
- acl = acl_init (0);
- if (acl)
- {
- if (HAVE_ACL_SET_FD && desc != -1)
- ret = acl_set_fd (desc, acl);
- else
- ret = acl_set_file (name, ACL_TYPE_EXTENDED, acl);
- acl_free (acl);
- }
- else
- ret = -1;
- }
+ {
+ acl_free (acl);
+
+ acl = acl_init (0);
+ if (acl)
+ {
+ if (HAVE_ACL_SET_FD && desc != -1)
+ ret = acl_set_fd (desc, acl);
+ else
+ ret = acl_set_file (name, ACL_TYPE_EXTENDED, acl);
+ acl_free (acl);
+ }
+ else
+ ret = -1;
+ }
}
else
{
if (HAVE_ACL_SET_FD && desc != -1)
- ret = acl_set_fd (desc, ctx->acl);
+ ret = acl_set_fd (desc, ctx->acl);
else
- ret = acl_set_file (name, ACL_TYPE_EXTENDED, ctx->acl);
+ ret = acl_set_file (name, ACL_TYPE_EXTENDED, ctx->acl);
if (ret != 0)
- {
- if (! acl_errno_valid (errno)
- && ! acl_extended_nontrivial (ctx->acl))
- ret = 0;
- }
+ {
+ if (! acl_errno_valid (errno)
+ && ! acl_extended_nontrivial (ctx->acl))
+ ret = 0;
+ }
}
*acls_set = true;
@@ -626,34 +626,34 @@ set_acls (struct permission_context *ctx, const char *name, int desc,
if (ret == 0 && ctx->count)
{
if (desc != -1)
- ret = facl (desc, SETACL, ctx->count, ctx->entries);
+ ret = facl (desc, SETACL, ctx->count, ctx->entries);
else
- ret = acl (name, SETACL, ctx->count, ctx->entries);
+ ret = acl (name, SETACL, ctx->count, ctx->entries);
if (ret < 0)
- {
- if ((errno == ENOSYS || errno == EOPNOTSUPP || errno == EINVAL)
- && acl_nontrivial (ctx->count, ctx->entries) == 0)
- ret = 0;
- }
+ {
+ if ((errno == ENOSYS || errno == EOPNOTSUPP || errno == EINVAL)
+ && acl_nontrivial (ctx->count, ctx->entries) == 0)
+ ret = 0;
+ }
else
- *acls_set = true;
+ *acls_set = true;
}
# ifdef ACE_GETACL
if (ret == 0 && ctx->ace_count)
{
if (desc != -1)
- ret = facl (desc, ACE_SETACL, ctx->ace_count, ctx->ace_entries);
+ ret = facl (desc, ACE_SETACL, ctx->ace_count, ctx->ace_entries);
else
- ret = acl (name, ACE_SETACL, ctx->ace_count, ctx->ace_entries);
+ ret = acl (name, ACE_SETACL, ctx->ace_count, ctx->ace_entries);
if (ret < 0)
- {
- if ((errno == ENOSYS || errno == EINVAL || errno == ENOTSUP)
- && acl_ace_nontrivial (ctx->ace_count, ctx->ace_entries) == 0)
- ret = 0;
- }
+ {
+ if ((errno == ENOSYS || errno == EINVAL || errno == ENOTSUP)
+ && acl_ace_nontrivial (ctx->ace_count, ctx->ace_entries) == 0)
+ ret = 0;
+ }
else
- *acls_set = true;
+ *acls_set = true;
}
# endif
@@ -665,17 +665,17 @@ set_acls (struct permission_context *ctx, const char *name, int desc,
if (ret == 0 && ctx->count > 0)
{
if (desc != -1)
- ret = fsetacl (desc, ctx->count, ctx->entries);
+ ret = fsetacl (desc, ctx->count, ctx->entries);
else
- ret = setacl (name, ctx->count, ctx->entries);
+ ret = setacl (name, ctx->count, ctx->entries);
if (ret < 0)
- {
- if ((errno == ENOSYS || errno == EOPNOTSUPP || errno == ENOTSUP)
- && (from_mode || !acl_nontrivial (ctx->count, ctx->entries)))
- ret = 0;
- }
+ {
+ if ((errno == ENOSYS || errno == EOPNOTSUPP || errno == ENOTSUP)
+ && (from_mode || !acl_nontrivial (ctx->count, ctx->entries)))
+ ret = 0;
+ }
else
- *acls_set = true;
+ *acls_set = true;
}
# if HAVE_ACLV_H
@@ -686,13 +686,13 @@ set_acls (struct permission_context *ctx, const char *name, int desc,
{
ret = acl ((char *) name, ACL_SET, ctx->aclv_count, ctx->aclv_entries);
if (ret < 0)
- {
- if ((errno == ENOSYS || errno == EOPNOTSUPP || errno == EINVAL)
- && (from_mode || !aclv_nontrivial (ctx->aclv_count, ctx->aclv_entries)))
- ret = 0;
- }
+ {
+ if ((errno == ENOSYS || errno == EOPNOTSUPP || errno == EINVAL)
+ && (from_mode || !aclv_nontrivial (ctx->aclv_count, ctx->aclv_entries)))
+ ret = 0;
+ }
else
- *acls_set = true;
+ *acls_set = true;
}
# endif
@@ -711,16 +711,16 @@ set_acls (struct permission_context *ctx, const char *name, int desc,
if (ret == 0 && ctx->have_u)
{
if (desc != -1)
- ret = fchacl (desc, &ctx->u.a, ctx->u.a.acl_len);
+ ret = fchacl (desc, &ctx->u.a, ctx->u.a.acl_len);
else
- ret = chacl ((char *) name, &ctx->u.a, ctx->u.a.acl_len);
+ ret = chacl ((char *) name, &ctx->u.a, ctx->u.a.acl_len);
if (ret < 0)
- {
- if (errno == ENOSYS && from_mode)
- ret = 0;
- }
+ {
+ if (errno == ENOSYS && from_mode)
+ ret = 0;
+ }
else
- *acls_set = true;
+ *acls_set = true;
}
# elif HAVE_ACLSORT /* NonStop Kernel */
@@ -732,12 +732,12 @@ set_acls (struct permission_context *ctx, const char *name, int desc,
{
ret = acl ((char *) name, ACL_SET, ctx->count, ctx->entries);
if (ret != 0)
- {
- if (!acl_nontrivial (ctx->count, ctx->entries))
- ret = 0;
- }
+ {
+ if (!acl_nontrivial (ctx->count, ctx->entries))
+ ret = 0;
+ }
else
- *acls_set = true;
+ *acls_set = true;
}
# else /* No ACLs */
@@ -805,7 +805,7 @@ set_permissions (struct permission_context *ctx, const char *name, int desc)
{
ret = chmod_or_fchmod (name, desc, ctx->mode);
if (ret != 0)
- return -1;
+ return -1;
}
#if USE_ACL
@@ -815,18 +815,18 @@ set_permissions (struct permission_context *ctx, const char *name, int desc)
int saved_errno = ret ? errno : 0;
/* If we can't set an acl which we expect to be able to set, try setting
- the permissions to ctx->mode. Due to possible inherited permissions,
- we cannot simply chmod. */
+ the permissions to ctx->mode. Due to possible inherited permissions,
+ we cannot simply chmod. */
ret = set_acls (ctx, name, desc, true, &must_chmod, &acls_set);
if (! acls_set)
- must_chmod = true;
+ must_chmod = true;
if (saved_errno)
- {
- errno = saved_errno;
- ret = -1;
- }
+ {
+ errno = saved_errno;
+ ret = -1;
+ }
}
#endif
@@ -837,10 +837,10 @@ set_permissions (struct permission_context *ctx, const char *name, int desc)
ret = chmod_or_fchmod (name, desc, ctx->mode);
if (saved_errno)
- {
- errno = saved_errno;
- ret = -1;
- }
+ {
+ errno = saved_errno;
+ ret = -1;
+ }
}
return ret;
diff --git a/lib/sha1.c b/lib/sha1.c
index a64a488bcdc..d94c4373a55 100644
--- a/lib/sha1.c
+++ b/lib/sha1.c
@@ -1,8 +1,7 @@
/* sha1.c - Functions to compute SHA1 message digest of files or
memory blocks according to the NIST specification FIPS-180-1.
- Copyright (C) 2000-2001, 2003-2006, 2008-2019 Free Software
- Foundation, Inc.
+ Copyright (C) 2000-2001, 2003-2006, 2008-2019 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
@@ -38,11 +37,11 @@
# include "unlocked-io.h"
#endif
+#include <byteswap.h>
#ifdef WORDS_BIGENDIAN
# define SWAP(n) (n)
#else
-# define SWAP(n) \
- (((n) << 24) | (((n) & 0xff00) << 8) | (((n) >> 8) & 0xff00) | ((n) >> 24))
+# define SWAP(n) bswap_32 (n)
#endif
#define BLOCKSIZE 32768
@@ -123,21 +122,29 @@ sha1_finish_ctx (struct sha1_ctx *ctx, void *resbuf)
}
#endif
+#ifdef GL_COMPILE_CRYPTO_STREAM
+
+#include "af_alg.h"
+
/* Compute SHA1 message digest for bytes read from STREAM. The
- resulting message digest number will be written into the 16 bytes
+ resulting message digest number will be written into the 20 bytes
beginning at RESBLOCK. */
int
sha1_stream (FILE *stream, void *resblock)
{
- struct sha1_ctx ctx;
- size_t sum;
+ switch (afalg_stream (stream, "sha1", resblock, SHA1_DIGEST_SIZE))
+ {
+ case 0: return 0;
+ case -EIO: return 1;
+ }
char *buffer = malloc (BLOCKSIZE + 72);
if (!buffer)
return 1;
- /* Initialize the computation context. */
+ struct sha1_ctx ctx;
sha1_init_ctx (&ctx);
+ size_t sum;
/* Iterate over full file contents. */
while (1)
@@ -151,6 +158,14 @@ sha1_stream (FILE *stream, void *resblock)
/* Read block. Take care for partial reads. */
while (1)
{
+ /* Either process a partial fread() from this loop,
+ or the fread() in afalg_stream may have gotten EOF.
+ We need to avoid a subsequent fread() as EOF may
+ not be sticky. For details of such systems, see:
+ https://sourceware.org/bugzilla/show_bug.cgi?id=1190 */
+ if (feof (stream))
+ goto process_partial_block;
+
n = fread (buffer + sum, 1, BLOCKSIZE - sum, stream);
sum += n;
@@ -170,12 +185,6 @@ sha1_stream (FILE *stream, void *resblock)
}
goto process_partial_block;
}
-
- /* We've read at least one byte, so ignore errors. But always
- check for EOF, since feof may be true even though N > 0.
- Otherwise, we could end up calling fread after EOF. */
- if (feof (stream))
- goto process_partial_block;
}
/* Process buffer with BLOCKSIZE bytes. Note that
@@ -195,6 +204,7 @@ sha1_stream (FILE *stream, void *resblock)
free (buffer);
return 0;
}
+#endif
#if ! HAVE_OPENSSL_SHA1
/* Compute SHA1 message digest for LEN bytes beginning at BUFFER. The
diff --git a/lib/sha1.h b/lib/sha1.h
index cfc6842758b..617f7b0169a 100644
--- a/lib/sha1.h
+++ b/lib/sha1.h
@@ -87,8 +87,11 @@ extern void *sha1_read_ctx (const struct sha1_ctx *ctx, void *resbuf);
extern void *sha1_buffer (const char *buffer, size_t len, void *resblock);
# endif
-/* Compute SHA1 message digest for bytes read from STREAM. The
- resulting message digest number will be written into the 20 bytes
+/* Compute SHA1 message digest for bytes read from STREAM.
+ STREAM is an open file stream. Regular files are handled more efficiently.
+ The contents of STREAM from its current position to its end will be read.
+ The case that the last operation on STREAM was an 'ungetc' is not supported.
+ The resulting message digest number will be written into the 20 bytes
beginning at RESBLOCK. */
extern int sha1_stream (FILE *stream, void *resblock);
diff --git a/lib/sha256.c b/lib/sha256.c
index 1b944b59eb7..721e944a79f 100644
--- a/lib/sha256.c
+++ b/lib/sha256.c
@@ -36,11 +36,11 @@
# include "unlocked-io.h"
#endif
+#include <byteswap.h>
#ifdef WORDS_BIGENDIAN
# define SWAP(n) (n)
#else
-# define SWAP(n) \
- (((n) << 24) | (((n) & 0xff00) << 8) | (((n) >> 8) & 0xff00) | ((n) >> 24))
+# define SWAP(n) bswap_32 (n)
#endif
#define BLOCKSIZE 32768
@@ -91,17 +91,17 @@ sha224_init_ctx (struct sha256_ctx *ctx)
ctx->buflen = 0;
}
-/* Copy the value from v into the memory location pointed to by *cp,
- If your architecture allows unaligned access this is equivalent to
- * (uint32_t *) cp = v */
+/* Copy the value from v into the memory location pointed to by *CP,
+ If your architecture allows unaligned access, this is equivalent to
+ * (__typeof__ (v) *) cp = v */
static void
set_uint32 (char *cp, uint32_t v)
{
memcpy (cp, &v, sizeof v);
}
-/* Put result from CTX in first 32 bytes following RESBUF. The result
- must be in little endian byte order. */
+/* Put result from CTX in first 32 bytes following RESBUF.
+ The result must be in little endian byte order. */
void *
sha256_read_ctx (const struct sha256_ctx *ctx, void *resbuf)
{
@@ -169,21 +169,32 @@ sha224_finish_ctx (struct sha256_ctx *ctx, void *resbuf)
}
#endif
-/* Compute SHA256 message digest for bytes read from STREAM. The
- resulting message digest number will be written into the 32 bytes
- beginning at RESBLOCK. */
-int
-sha256_stream (FILE *stream, void *resblock)
+#ifdef GL_COMPILE_CRYPTO_STREAM
+
+#include "af_alg.h"
+
+/* Compute message digest for bytes read from STREAM using algorithm ALG.
+ Write the message digest into RESBLOCK, which contains HASHLEN bytes.
+ The initial and finishing operations are INIT_CTX and FINISH_CTX.
+ Return zero if and only if successful. */
+static int
+shaxxx_stream (FILE *stream, char const *alg, void *resblock,
+ ssize_t hashlen, void (*init_ctx) (struct sha256_ctx *),
+ void *(*finish_ctx) (struct sha256_ctx *, void *))
{
- struct sha256_ctx ctx;
- size_t sum;
+ switch (afalg_stream (stream, alg, resblock, hashlen))
+ {
+ case 0: return 0;
+ case -EIO: return 1;
+ }
char *buffer = malloc (BLOCKSIZE + 72);
if (!buffer)
return 1;
- /* Initialize the computation context. */
- sha256_init_ctx (&ctx);
+ struct sha256_ctx ctx;
+ init_ctx (&ctx);
+ size_t sum;
/* Iterate over full file contents. */
while (1)
@@ -197,6 +208,14 @@ sha256_stream (FILE *stream, void *resblock)
/* Read block. Take care for partial reads. */
while (1)
{
+ /* Either process a partial fread() from this loop,
+ or the fread() in afalg_stream may have gotten EOF.
+ We need to avoid a subsequent fread() as EOF may
+ not be sticky. For details of such systems, see:
+ https://sourceware.org/bugzilla/show_bug.cgi?id=1190 */
+ if (feof (stream))
+ goto process_partial_block;
+
n = fread (buffer + sum, 1, BLOCKSIZE - sum, stream);
sum += n;
@@ -216,12 +235,6 @@ sha256_stream (FILE *stream, void *resblock)
}
goto process_partial_block;
}
-
- /* We've read at least one byte, so ignore errors. But always
- check for EOF, since feof may be true even though N > 0.
- Otherwise, we could end up calling fread after EOF. */
- if (feof (stream))
- goto process_partial_block;
}
/* Process buffer with BLOCKSIZE bytes. Note that
@@ -237,84 +250,28 @@ sha256_stream (FILE *stream, void *resblock)
sha256_process_bytes (buffer, sum, &ctx);
/* Construct result in desired memory. */
- sha256_finish_ctx (&ctx, resblock);
+ finish_ctx (&ctx, resblock);
free (buffer);
return 0;
}
-/* FIXME: Avoid code duplication */
int
-sha224_stream (FILE *stream, void *resblock)
+sha256_stream (FILE *stream, void *resblock)
{
- struct sha256_ctx ctx;
- size_t sum;
-
- char *buffer = malloc (BLOCKSIZE + 72);
- if (!buffer)
- return 1;
-
- /* Initialize the computation context. */
- sha224_init_ctx (&ctx);
-
- /* Iterate over full file contents. */
- while (1)
- {
- /* We read the file in blocks of BLOCKSIZE bytes. One call of the
- computation function processes the whole buffer so that with the
- next round of the loop another block can be read. */
- size_t n;
- sum = 0;
-
- /* Read block. Take care for partial reads. */
- while (1)
- {
- n = fread (buffer + sum, 1, BLOCKSIZE - sum, stream);
-
- sum += n;
-
- if (sum == BLOCKSIZE)
- break;
-
- if (n == 0)
- {
- /* Check for the error flag IFF N == 0, so that we don't
- exit the loop after a partial read due to e.g., EAGAIN
- or EWOULDBLOCK. */
- if (ferror (stream))
- {
- free (buffer);
- return 1;
- }
- goto process_partial_block;
- }
-
- /* We've read at least one byte, so ignore errors. But always
- check for EOF, since feof may be true even though N > 0.
- Otherwise, we could end up calling fread after EOF. */
- if (feof (stream))
- goto process_partial_block;
- }
-
- /* Process buffer with BLOCKSIZE bytes. Note that
- BLOCKSIZE % 64 == 0
- */
- sha256_process_block (buffer, BLOCKSIZE, &ctx);
- }
-
- process_partial_block:;
-
- /* Process any remaining bytes. */
- if (sum > 0)
- sha256_process_bytes (buffer, sum, &ctx);
+ return shaxxx_stream (stream, "sha256", resblock, SHA256_DIGEST_SIZE,
+ sha256_init_ctx, sha256_finish_ctx);
+}
- /* Construct result in desired memory. */
- sha224_finish_ctx (&ctx, resblock);
- free (buffer);
- return 0;
+int
+sha224_stream (FILE *stream, void *resblock)
+{
+ return shaxxx_stream (stream, "sha224", resblock, SHA224_DIGEST_SIZE,
+ sha224_init_ctx, sha224_finish_ctx);
}
+#endif
#if ! HAVE_OPENSSL_SHA256
-/* Compute SHA512 message digest for LEN bytes beginning at BUFFER. The
+/* Compute SHA256 message digest for LEN bytes beginning at BUFFER. The
result is always in little endian byte order, so that a byte-wise
output yields to the wanted ASCII representation of the message
digest. */
diff --git a/lib/sha256.h b/lib/sha256.h
index a76bdffa191..b1ccb2aeb6b 100644
--- a/lib/sha256.h
+++ b/lib/sha256.h
@@ -89,8 +89,11 @@ extern void *sha256_buffer (const char *buffer, size_t len, void *resblock);
extern void *sha224_buffer (const char *buffer, size_t len, void *resblock);
# endif
-/* Compute SHA256 (SHA224) message digest for bytes read from STREAM. The
- resulting message digest number will be written into the 32 (28) bytes
+/* Compute SHA256 (SHA224) message digest for bytes read from STREAM.
+ STREAM is an open file stream. Regular files are handled more efficiently.
+ The contents of STREAM from its current position to its end will be read.
+ The case that the last operation on STREAM was an 'ungetc' is not supported.
+ The resulting message digest number will be written into the 32 (28) bytes
beginning at RESBLOCK. */
extern int sha256_stream (FILE *stream, void *resblock);
extern int sha224_stream (FILE *stream, void *resblock);
diff --git a/lib/sha512.c b/lib/sha512.c
index 2e8c485efb9..e7f5bd5a159 100644
--- a/lib/sha512.c
+++ b/lib/sha512.c
@@ -36,18 +36,11 @@
# include "unlocked-io.h"
#endif
+#include <byteswap.h>
#ifdef WORDS_BIGENDIAN
# define SWAP(n) (n)
#else
-# define SWAP(n) \
- u64or (u64or (u64or (u64shl (n, 56), \
- u64shl (u64and (n, u64lo (0x0000ff00)), 40)), \
- u64or (u64shl (u64and (n, u64lo (0x00ff0000)), 24), \
- u64shl (u64and (n, u64lo (0xff000000)), 8))), \
- u64or (u64or (u64and (u64shr (n, 8), u64lo (0xff000000)), \
- u64and (u64shr (n, 24), u64lo (0x00ff0000))), \
- u64or (u64and (u64shr (n, 40), u64lo (0x0000ff00)), \
- u64shr (n, 56))))
+# define SWAP(n) bswap_64 (n)
#endif
#define BLOCKSIZE 32768
@@ -177,21 +170,32 @@ sha384_finish_ctx (struct sha512_ctx *ctx, void *resbuf)
}
#endif
-/* Compute SHA512 message digest for bytes read from STREAM. The
- resulting message digest number will be written into the 64 bytes
- beginning at RESBLOCK. */
-int
-sha512_stream (FILE *stream, void *resblock)
+#ifdef GL_COMPILE_CRYPTO_STREAM
+
+#include "af_alg.h"
+
+/* Compute message digest for bytes read from STREAM using algorithm ALG.
+ Write the message digest into RESBLOCK, which contains HASHLEN bytes.
+ The initial and finishing operations are INIT_CTX and FINISH_CTX.
+ Return zero if and only if successful. */
+static int
+shaxxx_stream (FILE *stream, char const *alg, void *resblock,
+ ssize_t hashlen, void (*init_ctx) (struct sha512_ctx *),
+ void *(*finish_ctx) (struct sha512_ctx *, void *))
{
- struct sha512_ctx ctx;
- size_t sum;
+ switch (afalg_stream (stream, alg, resblock, hashlen))
+ {
+ case 0: return 0;
+ case -EIO: return 1;
+ }
char *buffer = malloc (BLOCKSIZE + 72);
if (!buffer)
return 1;
- /* Initialize the computation context. */
- sha512_init_ctx (&ctx);
+ struct sha512_ctx ctx;
+ init_ctx (&ctx);
+ size_t sum;
/* Iterate over full file contents. */
while (1)
@@ -205,6 +209,14 @@ sha512_stream (FILE *stream, void *resblock)
/* Read block. Take care for partial reads. */
while (1)
{
+ /* Either process a partial fread() from this loop,
+ or the fread() in afalg_stream may have gotten EOF.
+ We need to avoid a subsequent fread() as EOF may
+ not be sticky. For details of such systems, see:
+ https://sourceware.org/bugzilla/show_bug.cgi?id=1190 */
+ if (feof (stream))
+ goto process_partial_block;
+
n = fread (buffer + sum, 1, BLOCKSIZE - sum, stream);
sum += n;
@@ -224,12 +236,6 @@ sha512_stream (FILE *stream, void *resblock)
}
goto process_partial_block;
}
-
- /* We've read at least one byte, so ignore errors. But always
- check for EOF, since feof may be true even though N > 0.
- Otherwise, we could end up calling fread after EOF. */
- if (feof (stream))
- goto process_partial_block;
}
/* Process buffer with BLOCKSIZE bytes. Note that
@@ -245,81 +251,25 @@ sha512_stream (FILE *stream, void *resblock)
sha512_process_bytes (buffer, sum, &ctx);
/* Construct result in desired memory. */
- sha512_finish_ctx (&ctx, resblock);
+ finish_ctx (&ctx, resblock);
free (buffer);
return 0;
}
-/* FIXME: Avoid code duplication */
int
-sha384_stream (FILE *stream, void *resblock)
+sha512_stream (FILE *stream, void *resblock)
{
- struct sha512_ctx ctx;
- size_t sum;
-
- char *buffer = malloc (BLOCKSIZE + 72);
- if (!buffer)
- return 1;
-
- /* Initialize the computation context. */
- sha384_init_ctx (&ctx);
-
- /* Iterate over full file contents. */
- while (1)
- {
- /* We read the file in blocks of BLOCKSIZE bytes. One call of the
- computation function processes the whole buffer so that with the
- next round of the loop another block can be read. */
- size_t n;
- sum = 0;
-
- /* Read block. Take care for partial reads. */
- while (1)
- {
- n = fread (buffer + sum, 1, BLOCKSIZE - sum, stream);
-
- sum += n;
-
- if (sum == BLOCKSIZE)
- break;
-
- if (n == 0)
- {
- /* Check for the error flag IFF N == 0, so that we don't
- exit the loop after a partial read due to e.g., EAGAIN
- or EWOULDBLOCK. */
- if (ferror (stream))
- {
- free (buffer);
- return 1;
- }
- goto process_partial_block;
- }
-
- /* We've read at least one byte, so ignore errors. But always
- check for EOF, since feof may be true even though N > 0.
- Otherwise, we could end up calling fread after EOF. */
- if (feof (stream))
- goto process_partial_block;
- }
-
- /* Process buffer with BLOCKSIZE bytes. Note that
- BLOCKSIZE % 128 == 0
- */
- sha512_process_block (buffer, BLOCKSIZE, &ctx);
- }
-
- process_partial_block:;
-
- /* Process any remaining bytes. */
- if (sum > 0)
- sha512_process_bytes (buffer, sum, &ctx);
+ return shaxxx_stream (stream, "sha512", resblock, SHA512_DIGEST_SIZE,
+ sha512_init_ctx, sha512_finish_ctx);
+}
- /* Construct result in desired memory. */
- sha384_finish_ctx (&ctx, resblock);
- free (buffer);
- return 0;
+int
+sha384_stream (FILE *stream, void *resblock)
+{
+ return shaxxx_stream (stream, "sha384", resblock, SHA384_DIGEST_SIZE,
+ sha384_init_ctx, sha384_finish_ctx);
}
+#endif
#if ! HAVE_OPENSSL_SHA512
/* Compute SHA512 message digest for LEN bytes beginning at BUFFER. The
diff --git a/lib/sha512.h b/lib/sha512.h
index 3c059d1084e..7e8cc2852aa 100644
--- a/lib/sha512.h
+++ b/lib/sha512.h
@@ -92,8 +92,11 @@ extern void *sha512_buffer (const char *buffer, size_t len, void *resblock);
extern void *sha384_buffer (const char *buffer, size_t len, void *resblock);
# endif
-/* Compute SHA512 (SHA384) message digest for bytes read from STREAM. The
- resulting message digest number will be written into the 64 (48) bytes
+/* Compute SHA512 (SHA384) message digest for bytes read from STREAM.
+ STREAM is an open file stream. Regular files are handled more efficiently.
+ The contents of STREAM from its current position to its end will be read.
+ The case that the last operation on STREAM was an 'ungetc' is not supported.
+ The resulting message digest number will be written into the 64 (48) bytes
beginning at RESBLOCK. */
extern int sha512_stream (FILE *stream, void *resblock);
extern int sha384_stream (FILE *stream, void *resblock);
diff --git a/lib/sig2str.c b/lib/sig2str.c
index 56114afde98..cd5bd4d70c7 100644
--- a/lib/sig2str.c
+++ b/lib/sig2str.c
@@ -1,7 +1,6 @@
/* sig2str.c -- convert between signal names and numbers
- Copyright (C) 2002, 2004, 2006, 2009-2019 Free Software Foundation,
- Inc.
+ Copyright (C) 2002, 2004, 2006, 2009-2019 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
diff --git a/lib/stat-time.h b/lib/stat-time.h
index c7f5725f682..38a1f55a6cf 100644
--- a/lib/stat-time.h
+++ b/lib/stat-time.h
@@ -168,10 +168,10 @@ get_stat_birthtime (struct stat const *st _GL_UNUSED)
#elif defined HAVE_STRUCT_STAT_ST_BIRTHTIMENSEC
t.tv_sec = st->st_birthtime;
t.tv_nsec = st->st_birthtimensec;
-#elif (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+#elif defined _WIN32 && ! defined __CYGWIN__
/* Native Windows platforms (but not Cygwin) put the "file creation
time" in st_ctime (!). See
- <https://msdn.microsoft.com/en-us/library/14h5k7ff(VS.80).aspx>. */
+ <https://docs.microsoft.com/en-us/cpp/c-runtime-library/reference/stat-functions>. */
# if _GL_WINDOWS_STAT_TIMESPEC
t = st->st_ctim;
# else
@@ -213,7 +213,7 @@ stat_time_normalize (int result, struct stat *st _GL_UNUSED)
#if defined __sun && defined STAT_TIMESPEC
if (result == 0)
{
- long int timespec_resolution = 1000000000;
+ long int timespec_hz = 1000000000;
short int const ts_off[] = { offsetof (struct stat, st_atim),
offsetof (struct stat, st_mtim),
offsetof (struct stat, st_ctim) };
@@ -221,11 +221,11 @@ stat_time_normalize (int result, struct stat *st _GL_UNUSED)
for (i = 0; i < sizeof ts_off / sizeof *ts_off; i++)
{
struct timespec *ts = (struct timespec *) ((char *) st + ts_off[i]);
- long int q = ts->tv_nsec / timespec_resolution;
- long int r = ts->tv_nsec % timespec_resolution;
+ long int q = ts->tv_nsec / timespec_hz;
+ long int r = ts->tv_nsec % timespec_hz;
if (r < 0)
{
- r += timespec_resolution;
+ r += timespec_hz;
q--;
}
ts->tv_nsec = r;
diff --git a/lib/stdio-impl.h b/lib/stdio-impl.h
index 5005754a9a3..4260468b612 100644
--- a/lib/stdio-impl.h
+++ b/lib/stdio-impl.h
@@ -18,6 +18,12 @@
the same implementation of stdio extension API, except that some fields
have different naming conventions, or their access requires some casts. */
+/* Glibc 2.28 made _IO_IN_BACKUP private. For now, work around this
+ problem by defining it ourselves. FIXME: Do not rely on glibc
+ internals. */
+#if !defined _IO_IN_BACKUP && defined _IO_EOF_SEEN
+# define _IO_IN_BACKUP 0x100
+#endif
/* BSD stdio derived implementations. */
@@ -54,25 +60,84 @@
# define _flags pub._flags
# define _r pub._r
# define _w pub._w
+# elif defined __ANDROID__ /* Android */
+# ifdef __LP64__
+# define _gl_flags_file_t int
+# else
+# define _gl_flags_file_t short
+# endif
+ /* Up to this commit from 2015-10-12
+ <https://android.googlesource.com/platform/bionic.git/+/f0141dfab10a4b332769d52fa76631a64741297a>
+ the innards of FILE were public, and fp_ub could be defined like for OpenBSD,
+ see <https://android.googlesource.com/platform/bionic.git/+/e78392637d5086384a5631ddfdfa8d7ec8326ee3/libc/stdio/fileext.h>
+ and <https://android.googlesource.com/platform/bionic.git/+/e78392637d5086384a5631ddfdfa8d7ec8326ee3/libc/stdio/local.h>.
+ After this commit, the innards of FILE are hidden. */
+# define fp_ ((struct { unsigned char *_p; \
+ int _r; \
+ int _w; \
+ _gl_flags_file_t _flags; \
+ _gl_flags_file_t _file; \
+ struct { unsigned char *_base; size_t _size; } _bf; \
+ int _lbfsize; \
+ void *_cookie; \
+ void *_close; \
+ void *_read; \
+ void *_seek; \
+ void *_write; \
+ struct { unsigned char *_base; size_t _size; } _ext; \
+ unsigned char *_up; \
+ int _ur; \
+ unsigned char _ubuf[3]; \
+ unsigned char _nbuf[1]; \
+ struct { unsigned char *_base; size_t _size; } _lb; \
+ int _blksize; \
+ fpos_t _offset; \
+ /* More fields, not relevant here. */ \
+ } *) fp)
# else
# define fp_ fp
# endif
-# if (defined __NetBSD__ && __NetBSD_Version__ >= 105270000) || defined __OpenBSD__ || defined __minix || defined __ANDROID__ /* NetBSD >= 1.5ZA, OpenBSD, Minix 3, Android */
+# if (defined __NetBSD__ && __NetBSD_Version__ >= 105270000) || defined __OpenBSD__ || defined __minix /* NetBSD >= 1.5ZA, OpenBSD, Minix 3 */
/* See <http://cvsweb.netbsd.org/bsdweb.cgi/src/lib/libc/stdio/fileext.h?rev=HEAD&content-type=text/x-cvsweb-markup>
- and <https://cvsweb.openbsd.org/cgi-bin/cvsweb/src/lib/libc/stdio/fileext.h?rev=HEAD&content-type=text/x-cvsweb-markup> */
+ and <https://cvsweb.openbsd.org/cgi-bin/cvsweb/src/lib/libc/stdio/fileext.h?rev=HEAD&content-type=text/x-cvsweb-markup>
+ and <https://github.com/Stichting-MINIX-Research-Foundation/minix/blob/master/lib/libc/stdio/fileext.h> */
struct __sfileext
{
struct __sbuf _ub; /* ungetc buffer */
/* More fields, not relevant here. */
};
# define fp_ub ((struct __sfileext *) fp->_ext._base)->_ub
-# else /* FreeBSD, NetBSD <= 1.5Z, DragonFly, Mac OS X, Cygwin, Android */
+# elif defined __ANDROID__ /* Android */
+ struct __sfileext
+ {
+ struct { unsigned char *_base; size_t _size; } _ub; /* ungetc buffer */
+ /* More fields, not relevant here. */
+ };
+# define fp_ub ((struct __sfileext *) fp_->_ext._base)->_ub
+# else /* FreeBSD, NetBSD <= 1.5Z, DragonFly, Mac OS X, Cygwin */
# define fp_ub fp_->_ub
# endif
# define HASUB(fp) (fp_ub._base != NULL)
+# if defined __ANDROID__ /* Android */
+ /* Needed after this commit from 2016-01-25
+ <https://android.googlesource.com/platform/bionic.git/+/e70e0e9267d069bf56a5078c99307e08a7280de7> */
+# ifndef __SEOF
+# define __SLBF 1
+# define __SNBF 2
+# define __SRD 4
+# define __SWR 8
+# define __SRW 0x10
+# define __SEOF 0x20
+# define __SERR 0x40
+# endif
+# ifndef __SOFF
+# define __SOFF 0x1000
+# endif
+# endif
+
#endif
@@ -112,7 +177,7 @@
# define _flag __flag
# endif
-#elif (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ /* newer Windows with MSVC */
+#elif defined _WIN32 && ! defined __CYGWIN__ /* newer Windows with MSVC */
/* <stdio.h> does not define the innards of FILE any more. */
# define WINDOWS_OPAQUE_FILE
diff --git a/lib/stdio.in.h b/lib/stdio.in.h
index 012bcdd7d02..4a8aa55528b 100644
--- a/lib/stdio.in.h
+++ b/lib/stdio.in.h
@@ -118,11 +118,18 @@
# include <unistd.h>
#endif
+/* Android 4.3 declares renameat in <sys/stat.h>, not in <stdio.h>. */
+/* But in any case avoid namespace pollution on glibc systems. */
+#if (@GNULIB_RENAMEAT@ || defined GNULIB_POSIXCHECK) && defined __ANDROID__ \
+ && ! defined __GLIBC__
+# include <sys/stat.h>
+#endif
+
/* MSVC declares 'perror' in <stdlib.h>, not in <stdio.h>. We must include
it before we #define perror rpl_perror. */
/* But in any case avoid namespace pollution on glibc systems. */
#if (@GNULIB_PERROR@ || defined GNULIB_POSIXCHECK) \
- && ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__) \
+ && (defined _WIN32 && ! defined __CYGWIN__) \
&& ! defined __GLIBC__
# include <stdlib.h>
#endif
@@ -133,7 +140,7 @@
it before we #define rename rpl_rename. */
/* But in any case avoid namespace pollution on glibc systems. */
#if (@GNULIB_REMOVE@ || @GNULIB_RENAME@ || defined GNULIB_POSIXCHECK) \
- && ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__) \
+ && (defined _WIN32 && ! defined __CYGWIN__) \
&& ! defined __GLIBC__
# include <io.h>
#endif
diff --git a/lib/stdlib.in.h b/lib/stdlib.in.h
index 6e3866dd8a1..f829525c104 100644
--- a/lib/stdlib.in.h
+++ b/lib/stdlib.in.h
@@ -1,7 +1,6 @@
/* A GNU-like <stdlib.h>.
- Copyright (C) 1995, 2001-2004, 2006-2019 Free Software Foundation,
- Inc.
+ Copyright (C) 1995, 2001-2004, 2006-2019 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
@@ -48,11 +47,14 @@
/* Solaris declares getloadavg() in <sys/loadavg.h>. */
#if (@GNULIB_GETLOADAVG@ || defined GNULIB_POSIXCHECK) && @HAVE_SYS_LOADAVG_H@
+/* OpenIndiana has a bug: <sys/time.h> must be included before
+ <sys/loadavg.h>. */
+# include <sys/time.h>
# include <sys/loadavg.h>
#endif
/* Native Windows platforms declare mktemp() in <io.h>. */
-#if 0 && ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__)
+#if 0 && (defined _WIN32 && ! defined __CYGWIN__)
# include <io.h>
#endif
@@ -88,9 +90,10 @@ struct random_data
# endif
#endif
-#if (@GNULIB_MKSTEMP@ || @GNULIB_MKSTEMPS@ || @GNULIB_GETSUBOPT@ || defined GNULIB_POSIXCHECK) && ! defined __GLIBC__ && !((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__)
+#if (@GNULIB_MKSTEMP@ || @GNULIB_MKSTEMPS@ || @GNULIB_MKOSTEMP@ || @GNULIB_MKOSTEMPS@ || @GNULIB_GETSUBOPT@ || defined GNULIB_POSIXCHECK) && ! defined __GLIBC__ && !(defined _WIN32 && ! defined __CYGWIN__)
/* On Mac OS X 10.3, only <unistd.h> declares mkstemp. */
/* On Mac OS X 10.5, only <unistd.h> declares mkstemps. */
+/* On Mac OS X 10.13, only <unistd.h> declares mkostemp and mkostemps. */
/* On Cygwin 1.7.1, only <unistd.h> declares getsubopt. */
/* But avoid namespace pollution on glibc systems and native Windows. */
# include <unistd.h>
@@ -303,9 +306,18 @@ _GL_WARN_ON_USE (malloc, "malloc is not POSIX compliant everywhere - "
_GL_FUNCDECL_RPL (mbtowc, int, (wchar_t *pwc, const char *s, size_t n));
_GL_CXXALIAS_RPL (mbtowc, int, (wchar_t *pwc, const char *s, size_t n));
# else
+# if !@HAVE_MBTOWC@
+_GL_FUNCDECL_SYS (mbtowc, int, (wchar_t *pwc, const char *s, size_t n));
+# endif
_GL_CXXALIAS_SYS (mbtowc, int, (wchar_t *pwc, const char *s, size_t n));
# endif
_GL_CXXALIASWARN (mbtowc);
+#elif defined GNULIB_POSIXCHECK
+# undef mbtowc
+# if HAVE_RAW_DECL_MBTOWC
+_GL_WARN_ON_USE (mbtowc, "mbtowc is not portable - "
+ "use gnulib module mbtowc for portability");
+# endif
#endif
#if @GNULIB_MKDTEMP@
@@ -570,10 +582,19 @@ _GL_WARN_ON_USE (qsort_r, "qsort_r is not portable - "
#if @GNULIB_RANDOM@
-# if !@HAVE_RANDOM@
+# if @REPLACE_RANDOM@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef random
+# define random rpl_random
+# endif
+_GL_FUNCDECL_RPL (random, long, (void));
+_GL_CXXALIAS_RPL (random, long, (void));
+# else
+# if !@HAVE_RANDOM@
_GL_FUNCDECL_SYS (random, long, (void));
-# endif
+# endif
_GL_CXXALIAS_SYS (random, long, (void));
+# endif
_GL_CXXALIASWARN (random);
#elif defined GNULIB_POSIXCHECK
# undef random
@@ -584,10 +605,19 @@ _GL_WARN_ON_USE (random, "random is unportable - "
#endif
#if @GNULIB_RANDOM@
-# if !@HAVE_RANDOM@
+# if @REPLACE_RANDOM@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef srandom
+# define srandom rpl_srandom
+# endif
+_GL_FUNCDECL_RPL (srandom, void, (unsigned int seed));
+_GL_CXXALIAS_RPL (srandom, void, (unsigned int seed));
+# else
+# if !@HAVE_RANDOM@
_GL_FUNCDECL_SYS (srandom, void, (unsigned int seed));
-# endif
+# endif
_GL_CXXALIAS_SYS (srandom, void, (unsigned int seed));
+# endif
_GL_CXXALIASWARN (srandom);
#elif defined GNULIB_POSIXCHECK
# undef srandom
@@ -598,31 +628,52 @@ _GL_WARN_ON_USE (srandom, "srandom is unportable - "
#endif
#if @GNULIB_RANDOM@
-# if !@HAVE_RANDOM@ || !@HAVE_DECL_INITSTATE@
+# if @REPLACE_INITSTATE@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef initstate
+# define initstate rpl_initstate
+# endif
+_GL_FUNCDECL_RPL (initstate, char *,
+ (unsigned int seed, char *buf, size_t buf_size)
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (initstate, char *,
+ (unsigned int seed, char *buf, size_t buf_size));
+# else
+# if !@HAVE_INITSTATE@ || !@HAVE_DECL_INITSTATE@
_GL_FUNCDECL_SYS (initstate, char *,
(unsigned int seed, char *buf, size_t buf_size)
_GL_ARG_NONNULL ((2)));
-# endif
+# endif
_GL_CXXALIAS_SYS (initstate, char *,
(unsigned int seed, char *buf, size_t buf_size));
+# endif
_GL_CXXALIASWARN (initstate);
#elif defined GNULIB_POSIXCHECK
# undef initstate
-# if HAVE_RAW_DECL_INITSTATE_R
+# if HAVE_RAW_DECL_INITSTATE
_GL_WARN_ON_USE (initstate, "initstate is unportable - "
"use gnulib module random for portability");
# endif
#endif
#if @GNULIB_RANDOM@
-# if !@HAVE_RANDOM@ || !@HAVE_DECL_SETSTATE@
+# if @REPLACE_SETSTATE@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef setstate
+# define setstate rpl_setstate
+# endif
+_GL_FUNCDECL_RPL (setstate, char *, (char *arg_state) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (setstate, char *, (char *arg_state));
+# else
+# if !@HAVE_SETSTATE@ || !@HAVE_DECL_SETSTATE@
_GL_FUNCDECL_SYS (setstate, char *, (char *arg_state) _GL_ARG_NONNULL ((1)));
-# endif
+# endif
_GL_CXXALIAS_SYS (setstate, char *, (char *arg_state));
+# endif
_GL_CXXALIASWARN (setstate);
#elif defined GNULIB_POSIXCHECK
# undef setstate
-# if HAVE_RAW_DECL_SETSTATE_R
+# if HAVE_RAW_DECL_SETSTATE
_GL_WARN_ON_USE (setstate, "setstate is unportable - "
"use gnulib module random for portability");
# endif
@@ -878,6 +929,7 @@ _GL_WARN_ON_USE (setenv, "setenv is unportable - "
# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# define strtod rpl_strtod
# endif
+# define GNULIB_defined_strtod_function 1
_GL_FUNCDECL_RPL (strtod, double, (const char *str, char **endp)
_GL_ARG_NONNULL ((1)));
_GL_CXXALIAS_RPL (strtod, double, (const char *str, char **endp));
@@ -897,6 +949,32 @@ _GL_WARN_ON_USE (strtod, "strtod is unportable - "
# endif
#endif
+#if @GNULIB_STRTOLD@
+ /* Parse a 'long double' from STRING, updating ENDP if appropriate. */
+# if @REPLACE_STRTOLD@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define strtold rpl_strtold
+# endif
+# define GNULIB_defined_strtold_function 1
+_GL_FUNCDECL_RPL (strtold, long double, (const char *str, char **endp)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (strtold, long double, (const char *str, char **endp));
+# else
+# if !@HAVE_STRTOLD@
+_GL_FUNCDECL_SYS (strtold, long double, (const char *str, char **endp)
+ _GL_ARG_NONNULL ((1)));
+# endif
+_GL_CXXALIAS_SYS (strtold, long double, (const char *str, char **endp));
+# endif
+_GL_CXXALIASWARN (strtold);
+#elif defined GNULIB_POSIXCHECK
+# undef strtold
+# if HAVE_RAW_DECL_STRTOLD
+_GL_WARN_ON_USE (strtold, "strtold is unportable - "
+ "use gnulib module strtold for portability");
+# endif
+#endif
+
#if @GNULIB_STRTOLL@
/* Parse a signed integer whose textual representation starts at STRING.
The integer is expected to be in base BASE (2 <= BASE <= 36); if BASE == 0,
diff --git a/lib/strtoimax.c b/lib/strtoimax.c
index 0d602e2f5e0..87b080c4f35 100644
--- a/lib/strtoimax.c
+++ b/lib/strtoimax.c
@@ -1,7 +1,7 @@
/* Convert string representation of a number into an intmax_t value.
- Copyright (C) 1999, 2001-2004, 2006, 2009-2019 Free Software
- Foundation, Inc.
+ Copyright (C) 1999, 2001-2004, 2006, 2009-2019 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
diff --git a/lib/strtol.c b/lib/strtol.c
index e5dc5659bcd..1d920aff544 100644
--- a/lib/strtol.c
+++ b/lib/strtol.c
@@ -1,7 +1,7 @@
/* Convert string representation of a number into an integer value.
- Copyright (C) 1991-1992, 1994-1999, 2003, 2005-2007, 2009-2019 Free
- Software Foundation, Inc.
+ Copyright (C) 1991-1992, 1994-1999, 2003, 2005-2007, 2009-2019 Free Software
+ Foundation, Inc.
NOTE: The canonical source of this file is maintained with the GNU C
Library. Bugs can be reported to bug-glibc@gnu.org.
@@ -117,35 +117,6 @@
# define STRTOL_LONG_MIN LLONG_MIN
# define STRTOL_LONG_MAX LLONG_MAX
# define STRTOL_ULONG_MAX ULLONG_MAX
-
-/* The extra casts in the following macros work around compiler bugs,
- e.g., in Cray C 5.0.3.0. */
-
-/* True if the arithmetic type T is signed. */
-# define TYPE_SIGNED(t) (! ((t) 0 < (t) -1))
-
-/* Minimum and maximum values for integer types.
- These macros have undefined behavior for signed types that either
- have padding bits or do not use two's complement. If this is a
- problem for you, please let us know how to fix it for your host. */
-
-/* The maximum and minimum values for the integer type T. */
-# define TYPE_MINIMUM(t) ((t) ~ TYPE_MAXIMUM (t))
-# define TYPE_MAXIMUM(t) \
- ((t) (! TYPE_SIGNED (t) \
- ? (t) -1 \
- : ((((t) 1 << (sizeof (t) * CHAR_BIT - 2)) - 1) * 2 + 1)))
-
-# ifndef ULLONG_MAX
-# define ULLONG_MAX TYPE_MAXIMUM (unsigned long long)
-# endif
-# ifndef LLONG_MAX
-# define LLONG_MAX TYPE_MAXIMUM (long long int)
-# endif
-# ifndef LLONG_MIN
-# define LLONG_MIN TYPE_MINIMUM (long long int)
-# endif
-
# if __GNUC__ == 2 && __GNUC_MINOR__ < 7
/* Work around gcc bug with using this constant. */
static const unsigned long long int maxquad = ULLONG_MAX;
diff --git a/lib/strtoll.c b/lib/strtoll.c
index c89554813a5..038362a308b 100644
--- a/lib/strtoll.c
+++ b/lib/strtoll.c
@@ -1,6 +1,6 @@
/* Function to parse a 'long long int' from text.
- Copyright (C) 1995-1997, 1999, 2001, 2009-2019 Free Software
- Foundation, Inc.
+ Copyright (C) 1995-1997, 1999, 2001, 2009-2019 Free Software Foundation,
+ Inc.
This file is part of the GNU C Library.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/sys_stat.in.h b/lib/sys_stat.in.h
index b25a6d46b25..9ddd1a8d004 100644
--- a/lib/sys_stat.in.h
+++ b/lib/sys_stat.in.h
@@ -54,16 +54,23 @@
/* The definition of _GL_WARN_ON_USE is copied here. */
+/* Before doing "#define mknod rpl_mknod" below, we need to include all
+ headers that may declare mknod(). OS/2 kLIBC declares mknod() in
+ <unistd.h>, not in <sys/stat.h>. */
+#ifdef __KLIBC__
+# include <unistd.h>
+#endif
+
/* Before doing "#define mkdir rpl_mkdir" below, we need to include all
headers that may declare mkdir(). Native Windows platforms declare mkdir
- in <io.h> and/or <direct.h>, not in <unistd.h>. */
-#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+ in <io.h> and/or <direct.h>, not in <sys/stat.h>. */
+#if defined _WIN32 && ! defined __CYGWIN__
# include <io.h> /* mingw32, mingw64 */
# include <direct.h> /* mingw64, MSVC 9 */
#endif
/* Native Windows platforms declare umask() in <io.h>. */
-#if 0 && ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__)
+#if 0 && (defined _WIN32 && ! defined __CYGWIN__)
# include <io.h>
#endif
@@ -576,7 +583,7 @@ _GL_CXXALIAS_RPL (mkdir, int, (char const *name, mode_t mode));
Additionally, it declares _mkdir (and depending on compile flags, an
alias mkdir), only in the nonstandard includes <direct.h> and <io.h>,
which are included above. */
-# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+# if defined _WIN32 && ! defined __CYGWIN__
# if !GNULIB_defined_rpl_mkdir
static int
diff --git a/lib/sys_types.in.h b/lib/sys_types.in.h
index 0e85241714a..237e2068cf8 100644
--- a/lib/sys_types.in.h
+++ b/lib/sys_types.in.h
@@ -20,6 +20,17 @@
#endif
@PRAGMA_COLUMNS@
+#if defined _WIN32 && !defined __CYGWIN__ \
+ && (defined __need_off_t || defined __need___off64_t \
+ || defined __need_ssize_t || defined __need_time_t)
+
+/* Special invocation convention inside mingw header files. */
+
+#@INCLUDE_NEXT@ @NEXT_SYS_TYPES_H@
+
+#else
+/* Normal invocation convention. */
+
#ifndef _@GUARD_PREFIX@_SYS_TYPES_H
/* The include_next requires a split double-inclusion guard. */
@@ -86,10 +97,10 @@ typedef unsigned long long int rpl_ino_t;
/* MSVC 9 defines size_t in <stddef.h>, not in <sys/types.h>. */
/* But avoid namespace pollution on glibc systems. */
-#if ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__) \
- && ! defined __GLIBC__
+#if (defined _WIN32 && ! defined __CYGWIN__) && ! defined __GLIBC__
# include <stddef.h>
#endif
#endif /* _@GUARD_PREFIX@_SYS_TYPES_H */
#endif /* _@GUARD_PREFIX@_SYS_TYPES_H */
+#endif /* __need_XXX */
diff --git a/lib/tempname.c b/lib/tempname.c
index 43aaef86d19..be62ed9513c 100644
--- a/lib/tempname.c
+++ b/lib/tempname.c
@@ -1,7 +1,6 @@
/* tempname.c - generate the name of a temporary file.
- Copyright (C) 1991-2003, 2005-2007, 2009-2019 Free Software
- Foundation, Inc.
+ Copyright (C) 1991-2003, 2005-2007, 2009-2019 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
diff --git a/lib/time.in.h b/lib/time.in.h
index f9e422ffcad..dd3b21273c9 100644
--- a/lib/time.in.h
+++ b/lib/time.in.h
@@ -48,7 +48,7 @@
/* The definition of _GL_WARN_ON_USE is copied here. */
-/* Some systems don't define struct timespec (e.g., AIX 4.1, Ultrix 4.3).
+/* Some systems don't define struct timespec (e.g., AIX 4.1).
Or they define it with the wrong member names or define it in <sys/time.h>
(e.g., FreeBSD circa 1997). Stock Mingw prior to 3.0 does not define it,
but the pthreads-win32 library defines it in <pthread.h>. */
@@ -212,7 +212,7 @@ _GL_CXXALIASWARN (gmtime_r);
# define localtime rpl_localtime
# endif
_GL_FUNCDECL_RPL (localtime, struct tm *, (time_t const *__timer)
- _GL_ARG_NONNULL ((1)));
+ _GL_ARG_NONNULL ((1)));
_GL_CXXALIAS_RPL (localtime, struct tm *, (time_t const *__timer));
# else
_GL_CXXALIAS_SYS (localtime, struct tm *, (time_t const *__timer));
diff --git a/lib/time_r.c b/lib/time_r.c
index abec93020d3..a701ccc5b82 100644
--- a/lib/time_r.c
+++ b/lib/time_r.c
@@ -1,7 +1,6 @@
/* Reentrant time functions like localtime_r.
- Copyright (C) 2003, 2006-2007, 2010-2019 Free Software Foundation,
- Inc.
+ Copyright (C) 2003, 2006-2007, 2010-2019 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
diff --git a/lib/time_rz.c b/lib/time_rz.c
index a1dd1cf2481..42ae3d3649f 100644
--- a/lib/time_rz.c
+++ b/lib/time_rz.c
@@ -286,6 +286,21 @@ revert_tz (timezone_t tz)
struct tm *
localtime_rz (timezone_t tz, time_t const *t, struct tm *tm)
{
+#ifdef HAVE_LOCALTIME_INFLOOP_BUG
+ /* The -67768038400665599 comes from:
+ https://lists.gnu.org/r/bug-gnulib/2017-07/msg00142.html
+ On affected platforms the greatest POSIX-compatible time_t value
+ that could return nonnull is 67768036191766798 (when
+ TZ="XXX24:59:59" it resolves to the year 2**31 - 1 + 1900, on
+ 12-31 at 23:59:59), so test for that too while we're in the
+ neighborhood. */
+ if (! (-67768038400665599 <= *t && *t <= 67768036191766798))
+ {
+ errno = EOVERFLOW;
+ return NULL;
+ }
+#endif
+
if (!tz)
return gmtime_r (t, tm);
else
diff --git a/lib/timegm.c b/lib/timegm.c
index 8532a00342b..2ca57444d43 100644
--- a/lib/timegm.c
+++ b/lib/timegm.c
@@ -1,20 +1,21 @@
/* Convert UTC calendar time to simple time. Like mktime but assumes UTC.
- Copyright (C) 1994, 1997, 2003-2004, 2006-2007, 2009-2019 Free
- Software Foundation, Inc. This file is part of the GNU C Library.
+ Copyright (C) 1994-2019 Free Software Foundation, Inc.
+ This file is part of the GNU C Library.
- 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, or (at your option)
- any later version.
+ 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.
- This program is distributed in the hope that it will be useful,
+ 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.
+ 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 <https://www.gnu.org/licenses/>. */
+ You should have received a copy of the GNU General Public
+ License along with the GNU C Library; if not, see
+ <http://www.gnu.org/licenses/>. */
#ifndef _LIBC
# include <config.h>
@@ -22,14 +23,7 @@
#include <time.h>
-#ifdef _LIBC
-typedef time_t mktime_offset_t;
-#else
-# undef __gmtime_r
-# define __gmtime_r gmtime_r
-# define __mktime_internal mktime_internal
-# include "mktime-internal.h"
-#endif
+#include "mktime-internal.h"
time_t
timegm (struct tm *tmp)
diff --git a/lib/timespec-add.c b/lib/timespec-add.c
index ded923a355b..e0a9f12e14c 100644
--- a/lib/timespec-add.c
+++ b/lib/timespec-add.c
@@ -18,7 +18,7 @@
/* Written by Paul Eggert. */
/* Return the sum of two timespec values A and B. On overflow, return
- an extremal value. This assumes 0 <= tv_nsec < TIMESPEC_RESOLUTION. */
+ an extremal value. This assumes 0 <= tv_nsec < TIMESPEC_HZ. */
#include <config.h>
#include "timespec.h"
@@ -31,7 +31,7 @@ timespec_add (struct timespec a, struct timespec b)
time_t rs = a.tv_sec;
time_t bs = b.tv_sec;
int ns = a.tv_nsec + b.tv_nsec;
- int nsd = ns - TIMESPEC_RESOLUTION;
+ int nsd = ns - TIMESPEC_HZ;
int rns = ns;
time_t tmin = TYPE_MINIMUM (time_t);
time_t tmax = TYPE_MAXIMUM (time_t);
@@ -63,7 +63,7 @@ timespec_add (struct timespec a, struct timespec b)
{
high_overflow:
rs = tmax;
- rns = TIMESPEC_RESOLUTION - 1;
+ rns = TIMESPEC_HZ - 1;
}
}
diff --git a/lib/timespec-sub.c b/lib/timespec-sub.c
index 664e6340a7b..48434e81506 100644
--- a/lib/timespec-sub.c
+++ b/lib/timespec-sub.c
@@ -19,7 +19,7 @@
/* Return the difference between two timespec values A and B. On
overflow, return an extremal value. This assumes 0 <= tv_nsec <
- TIMESPEC_RESOLUTION. */
+ TIMESPEC_HZ. */
#include <config.h>
#include "timespec.h"
@@ -38,7 +38,7 @@ timespec_sub (struct timespec a, struct timespec b)
if (ns < 0)
{
- rns = ns + TIMESPEC_RESOLUTION;
+ rns = ns + TIMESPEC_HZ;
if (bs < tmax)
bs++;
else if (- TYPE_SIGNED (time_t) < rs)
@@ -63,7 +63,7 @@ timespec_sub (struct timespec a, struct timespec b)
else
{
rs = tmax;
- rns = TIMESPEC_RESOLUTION - 1;
+ rns = TIMESPEC_HZ - 1;
}
}
diff --git a/lib/timespec.h b/lib/timespec.h
index 8d4232a98c2..26f1bc1a4c7 100644
--- a/lib/timespec.h
+++ b/lib/timespec.h
@@ -17,9 +17,9 @@
along with this program. If not, see <https://www.gnu.org/licenses/>. */
#if ! defined TIMESPEC_H
-# define TIMESPEC_H
+#define TIMESPEC_H
-# include <time.h>
+#include <time.h>
#ifndef _GL_INLINE_HEADER_BEGIN
#error "Please include config.h first."
@@ -33,13 +33,20 @@ _GL_INLINE_HEADER_BEGIN
extern "C" {
#endif
+#include "arg-nonnull.h"
#include "verify.h"
-/* Resolution of timespec timestamps (in units per second), and log
- base 10 of the resolution. */
+/* Inverse resolution of timespec timestamps (in units per second),
+ and log base 10 of the inverse resolution. */
-enum { TIMESPEC_RESOLUTION = 1000000000 };
-enum { LOG10_TIMESPEC_RESOLUTION = 9 };
+enum { TIMESPEC_HZ = 1000000000 };
+enum { LOG10_TIMESPEC_HZ = 9 };
+
+/* Obsolescent names for backward compatibility.
+ They are misnomers, because TIMESPEC_RESOLUTION is not a resolution. */
+
+enum { TIMESPEC_RESOLUTION = TIMESPEC_HZ };
+enum { LOG10_TIMESPEC_RESOLUTION = LOG10_TIMESPEC_HZ };
/* Return a timespec with seconds S and nanoseconds NS. */
@@ -87,9 +94,9 @@ timespec_cmp (struct timespec a, struct timespec b)
return 1;
/* Pacify gcc -Wstrict-overflow (bleeding-edge circa 2017-10-02). See:
- http://lists.gnu.org/r/bug-gnulib/2017-10/msg00006.html */
- assume (-1 <= a.tv_nsec && a.tv_nsec <= 2 * TIMESPEC_RESOLUTION);
- assume (-1 <= b.tv_nsec && b.tv_nsec <= 2 * TIMESPEC_RESOLUTION);
+ https://lists.gnu.org/r/bug-gnulib/2017-10/msg00006.html */
+ assume (-1 <= a.tv_nsec && a.tv_nsec <= 2 * TIMESPEC_HZ);
+ assume (-1 <= b.tv_nsec && b.tv_nsec <= 2 * TIMESPEC_HZ);
return a.tv_nsec - b.tv_nsec;
}
@@ -116,8 +123,9 @@ timespectod (struct timespec a)
return a.tv_sec + a.tv_nsec / 1e9;
}
-void gettime (struct timespec *);
-int settime (struct timespec const *);
+struct timespec current_timespec (void);
+void gettime (struct timespec *) _GL_ARG_NONNULL ((1));
+int settime (struct timespec const *) _GL_ARG_NONNULL ((1));
#ifdef __cplusplus
}
diff --git a/lib/unistd.in.h b/lib/unistd.in.h
index d83553805f2..7778d25dc7e 100644
--- a/lib/unistd.in.h
+++ b/lib/unistd.in.h
@@ -61,16 +61,18 @@
/* But avoid namespace pollution on glibc systems. */
#if (!(defined SEEK_CUR && defined SEEK_END && defined SEEK_SET) \
|| ((@GNULIB_UNLINK@ || defined GNULIB_POSIXCHECK) \
- && ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__)) \
+ && (defined _WIN32 && ! defined __CYGWIN__)) \
|| ((@GNULIB_SYMLINKAT@ || defined GNULIB_POSIXCHECK) \
&& defined __CYGWIN__)) \
&& ! defined __GLIBC__
# include <stdio.h>
#endif
-/* Cygwin 1.7.1 declares unlinkat in <fcntl.h>, not in <unistd.h>. */
+/* Cygwin 1.7.1 and Android 4.3 declare unlinkat in <fcntl.h>, not in
+ <unistd.h>. */
/* But avoid namespace pollution on glibc systems. */
-#if (@GNULIB_UNLINKAT@ || defined GNULIB_POSIXCHECK) && defined __CYGWIN__ \
+#if (@GNULIB_UNLINKAT@ || defined GNULIB_POSIXCHECK) \
+ && (defined __CYGWIN__ || defined __ANDROID__) \
&& ! defined __GLIBC__
# include <fcntl.h>
#endif
@@ -94,13 +96,13 @@
lseek(), read(), unlink(), write() in <io.h>. */
#if ((@GNULIB_CHDIR@ || @GNULIB_GETCWD@ || @GNULIB_RMDIR@ \
|| defined GNULIB_POSIXCHECK) \
- && ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__))
+ && (defined _WIN32 && ! defined __CYGWIN__))
# include <io.h> /* mingw32, mingw64 */
# include <direct.h> /* mingw64, MSVC 9 */
#elif (@GNULIB_CLOSE@ || @GNULIB_DUP@ || @GNULIB_DUP2@ || @GNULIB_ISATTY@ \
|| @GNULIB_LSEEK@ || @GNULIB_READ@ || @GNULIB_UNLINK@ || @GNULIB_WRITE@ \
|| defined GNULIB_POSIXCHECK) \
- && ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__)
+ && (defined _WIN32 && ! defined __CYGWIN__)
# include <io.h>
#endif
@@ -113,6 +115,13 @@
# include <netdb.h>
#endif
+/* Android 4.3 declares fchownat in <sys/stat.h>, not in <unistd.h>. */
+/* But avoid namespace pollution on glibc systems. */
+#if (@GNULIB_FCHOWNAT@ || defined GNULIB_POSIXCHECK) && defined __ANDROID__ \
+ && !defined __GLIBC__
+# include <sys/stat.h>
+#endif
+
/* MSVC defines off_t in <sys/types.h>.
May also define off_t to a 64-bit type on native Windows. */
#if !@HAVE_UNISTD_H@ || @WINDOWS_64_BIT_OFF_T@
@@ -400,6 +409,13 @@ _GL_WARN_ON_USE (dup3, "dup3 is unportable - "
#if @GNULIB_ENVIRON@
+# if defined __CYGWIN__ && !defined __i386__
+/* The 'environ' variable is defined in a DLL. Therefore its declaration needs
+ the '__declspec(dllimport)' attribute, but the system's <unistd.h> lacks it.
+ This leads to a link error on 64-bit Cygwin when the option
+ -Wl,--disable-auto-import is in use. */
+_GL_EXTERN_C __declspec(dllimport) char **environ;
+# endif
# if !@HAVE_DECL_ENVIRON@
/* Set of environment variables and values. An array of strings of the form
"VARIABLE=VALUE", terminated with a NULL. */
@@ -425,12 +441,12 @@ extern char **environ;
#elif defined GNULIB_POSIXCHECK
# if HAVE_RAW_DECL_ENVIRON
_GL_UNISTD_INLINE char ***
+_GL_WARN_ON_USE_ATTRIBUTE ("environ is unportable - "
+ "use gnulib module environ for portability")
rpl_environ (void)
{
return &environ;
}
-_GL_WARN_ON_USE (rpl_environ, "environ is unportable - "
- "use gnulib module environ for portability");
# undef environ
# define environ (*rpl_environ ())
# endif
@@ -928,6 +944,36 @@ _GL_WARN_ON_USE (getpagesize, "getpagesize is unportable - "
#endif
+#if @GNULIB_GETPASS@
+/* Function getpass() from module 'getpass':
+ Read a password from /dev/tty or stdin.
+ Function getpass() from module 'getpass-gnu':
+ Read a password of arbitrary length from /dev/tty or stdin. */
+# if @REPLACE_GETPASS@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef getpass
+# define getpass rpl_getpass
+# endif
+_GL_FUNCDECL_RPL (getpass, char *, (const char *prompt)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (getpass, char *, (const char *prompt));
+# else
+# if !@HAVE_GETPASS@
+_GL_FUNCDECL_SYS (getpass, char *, (const char *prompt)
+ _GL_ARG_NONNULL ((1)));
+# endif
+_GL_CXXALIAS_SYS (getpass, char *, (const char *prompt));
+# endif
+_GL_CXXALIASWARN (getpass);
+#elif defined GNULIB_POSIXCHECK
+# undef getpass
+# if HAVE_RAW_DECL_GETPASS
+_GL_WARN_ON_USE (getpass, "getpass is unportable - "
+ "use gnulib module getpass or getpass-gnu for portability");
+# endif
+#endif
+
+
#if @GNULIB_GETUSERSHELL@
/* Return the next valid login shell on the system, or NULL when the end of
the list has been reached. */
@@ -1482,7 +1528,7 @@ _GL_FUNCDECL_RPL (truncate, int, (const char *filename, off_t length)
_GL_ARG_NONNULL ((1)));
_GL_CXXALIAS_RPL (truncate, int, (const char *filename, off_t length));
# else
-# if !@HAVE_TRUNCATE@
+# if !@HAVE_DECL_TRUNCATE@
_GL_FUNCDECL_SYS (truncate, int, (const char *filename, off_t length)
_GL_ARG_NONNULL ((1)));
# endif
diff --git a/lib/utimens.c b/lib/utimens.c
index c7599afdb88..c9b65ef4c20 100644
--- a/lib/utimens.c
+++ b/lib/utimens.c
@@ -39,8 +39,7 @@
GNU Emacs, which arranges for this in some other way and which
defines WIN32_LEAN_AND_MEAN itself. */
-#if ((defined _WIN32 || defined __WIN32__) \
- && ! defined __CYGWIN__ && ! defined EMACS_CONFIGURATION)
+#if defined _WIN32 && ! defined __CYGWIN__ && ! defined EMACS_CONFIGURATION
# define USE_SETFILETIME
# define WIN32_LEAN_AND_MEAN
# include <windows.h>
@@ -92,11 +91,11 @@ validate_timespec (struct timespec timespec[2])
if ((timespec[0].tv_nsec != UTIME_NOW
&& timespec[0].tv_nsec != UTIME_OMIT
&& ! (0 <= timespec[0].tv_nsec
- && timespec[0].tv_nsec < TIMESPEC_RESOLUTION))
+ && timespec[0].tv_nsec < TIMESPEC_HZ))
|| (timespec[1].tv_nsec != UTIME_NOW
&& timespec[1].tv_nsec != UTIME_OMIT
&& ! (0 <= timespec[1].tv_nsec
- && timespec[1].tv_nsec < TIMESPEC_RESOLUTION)))
+ && timespec[1].tv_nsec < TIMESPEC_HZ)))
{
errno = EINVAL;
return -1;
@@ -289,8 +288,8 @@ fdutimens (int fd, char const *file, struct timespec const timespec[2])
#ifdef USE_SETFILETIME
/* On native Windows, use SetFileTime(). See
- <https://msdn.microsoft.com/en-us/library/ms724933.aspx>
- <https://msdn.microsoft.com/en-us/library/ms724284.aspx> */
+ <https://docs.microsoft.com/en-us/windows/desktop/api/fileapi/nf-fileapi-setfiletime>
+ <https://docs.microsoft.com/en-us/windows/desktop/api/minwinbase/ns-minwinbase-filetime> */
if (0 <= fd)
{
HANDLE handle;
@@ -308,10 +307,10 @@ fdutimens (int fd, char const *file, struct timespec const timespec[2])
if (ts == NULL || ts[0].tv_nsec == UTIME_NOW || ts[1].tv_nsec == UTIME_NOW)
{
/* GetSystemTimeAsFileTime
- <https://msdn.microsoft.com/en-us/library/ms724397.aspx>.
+ <https://docs.microsoft.com/en-us/windows/desktop/api/sysinfoapi/nf-sysinfoapi-getsystemtimeasfiletime>.
It would be overkill to use
GetSystemTimePreciseAsFileTime
- <https://msdn.microsoft.com/en-us/library/hh706895.aspx>. */
+ <https://docs.microsoft.com/en-us/windows/desktop/api/sysinfoapi/nf-sysinfoapi-getsystemtimepreciseasfiletime>. */
GetSystemTimeAsFileTime (&current_time);
}
diff --git a/lib/verify.h b/lib/verify.h
index 4cd2f4af8a3..6930645a350 100644
--- a/lib/verify.h
+++ b/lib/verify.h
@@ -26,7 +26,7 @@
here generates easier-to-read diagnostics when verify (R) fails.
Define _GL_HAVE_STATIC_ASSERT to 1 if static_assert works as per C++11.
- This will likely be supported by future GCC versions, in C++ mode.
+ This is supported by GCC 6.1.0 and later, in C++ mode.
Use this only with GCC. If we were willing to slow 'configure'
down we could also use it with other compilers, but since this
@@ -36,9 +36,7 @@
&& !defined __cplusplus)
# define _GL_HAVE__STATIC_ASSERT 1
#endif
-/* The condition (99 < __GNUC__) is temporary, until we know about the
- first G++ release that supports static_assert. */
-#if (99 < __GNUC__) && defined __cplusplus
+#if (6 <= __GNUC__) && defined __cplusplus
# define _GL_HAVE_STATIC_ASSERT 1
#endif
@@ -276,7 +274,8 @@ template <int w>
when 'assume' silences warnings even with older GCCs. */
# define assume(R) ((R) ? (void) 0 : __builtin_trap ())
#else
-# define assume(R) ((void) (0 && (R)))
+ /* Some tools grok NOTREACHED, e.g., Oracle Studio 12.6. */
+# define assume(R) ((R) ? (void) 0 : /*NOTREACHED*/ (void) 0)
#endif
/* @assert.h omit end@ */
diff --git a/lib/vla.h b/lib/vla.h
index f6ebba0ede3..8f5dea76f61 100644
--- a/lib/vla.h
+++ b/lib/vla.h
@@ -17,6 +17,20 @@
Written by Paul Eggert. */
+/* The VLA_ELEMS macro does not allocate variable-length arrays (VLAs),
+ so it does not have the security or performance issues commonly
+ associated with VLAs. VLA_ELEMS is for exploiting a C11 feature
+ where a function can start like this:
+
+ double scan_array (int n, double v[static n])
+
+ to require a caller to pass a vector V with at least N elements;
+ this allows better static checking and performance in some cases.
+ In C11 this feature means that V is a VLA, so the feature is
+ supported only if __STDC_NO_VLA__ is defined, and for compatibility
+ to platforms that do not support VLAs, VLA_ELEMS (n) expands to
+ nothing when __STDC_NO_VLA__ is not defined. */
+
/* A function's argument must point to an array with at least N elements.
Example: 'int main (int argc, char *argv[VLA_ELEMS (argc)]);'. */
@@ -25,3 +39,15 @@
#else
# define VLA_ELEMS(n) static n
#endif
+
+/* Although C99 requires support for variable-length arrays (VLAs),
+ some C compilers never supported VLAs and VLAs are optional in C11.
+ VLAs are controversial because their allocation may be unintended
+ or awkward to support, and large VLAs might cause security or
+ performance problems. GCC can diagnose the use of VLAs via the
+ -Wvla and -Wvla-larger-than warnings options, and defining the
+ macro GNULIB_NO_VLA disables the allocation of VLAs in Gnulib code.
+
+ The VLA_ELEMS macro is unaffected by GNULIB_NO_VLA, since it does
+ not allocate VLAs. Programs that use VLA_ELEMS should be compiled
+ with 'gcc -Wvla-larger-than' instead of with 'gcc -Wvla'. */
diff --git a/lib/warn-on-use.h b/lib/warn-on-use.h
index 9f17e5bfd4b..7d11a156911 100644
--- a/lib/warn-on-use.h
+++ b/lib/warn-on-use.h
@@ -20,23 +20,32 @@
supported by the compiler. If the compiler does not support this
feature, the macro expands to an unused extern declaration.
- This macro is useful for marking a function as a potential
+ _GL_WARN_ON_USE_ATTRIBUTE ("literal string") expands to the
+ attribute used in _GL_WARN_ON_USE. If the compiler does not support
+ this feature, it expands to empty.
+
+ These macros are useful for marking a function as a potential
portability trap, with the intent that "literal string" include
instructions on the replacement function that should be used
- instead. However, one of the reasons that a function is a
- portability trap is if it has the wrong signature. Declaring
- FUNCTION with a different signature in C is a compilation error, so
- this macro must use the same type as any existing declaration so
- that programs that avoid the problematic FUNCTION do not fail to
- compile merely because they included a header that poisoned the
- function. But this implies that _GL_WARN_ON_USE is only safe to
- use if FUNCTION is known to already have a declaration. Use of
- this macro implies that there must not be any other macro hiding
- the declaration of FUNCTION; but undefining FUNCTION first is part
- of the poisoning process anyway (although for symbols that are
- provided only via a macro, the result is a compilation error rather
- than a warning containing "literal string"). Also note that in
- C++, it is only safe to use if FUNCTION has no overloads.
+ instead.
+ _GL_WARN_ON_USE is for functions with 'extern' linkage.
+ _GL_WARN_ON_USE_ATTRIBUTE is for functions with 'static' or 'inline'
+ linkage.
+
+ However, one of the reasons that a function is a portability trap is
+ if it has the wrong signature. Declaring FUNCTION with a different
+ signature in C is a compilation error, so this macro must use the
+ same type as any existing declaration so that programs that avoid
+ the problematic FUNCTION do not fail to compile merely because they
+ included a header that poisoned the function. But this implies that
+ _GL_WARN_ON_USE is only safe to use if FUNCTION is known to already
+ have a declaration. Use of this macro implies that there must not
+ be any other macro hiding the declaration of FUNCTION; but
+ undefining FUNCTION first is part of the poisoning process anyway
+ (although for symbols that are provided only via a macro, the result
+ is a compilation error rather than a warning containing
+ "literal string"). Also note that in C++, it is only safe to use if
+ FUNCTION has no overloads.
For an example, it is possible to poison 'getline' by:
- adding a call to gl_WARN_ON_USE_PREPARE([[#include <stdio.h>]],
@@ -54,12 +63,21 @@
(less common usage, like &environ, will cause a compilation error
rather than issue the nice warning, but the end result of informing
the developer about their portability problem is still achieved):
- #if HAVE_RAW_DECL_ENVIRON
- static char ***rpl_environ (void) { return &environ; }
- _GL_WARN_ON_USE (rpl_environ, "environ is not always properly declared");
- # undef environ
- # define environ (*rpl_environ ())
- #endif
+ #if HAVE_RAW_DECL_ENVIRON
+ static char ***
+ rpl_environ (void) { return &environ; }
+ _GL_WARN_ON_USE (rpl_environ, "environ is not always properly declared");
+ # undef environ
+ # define environ (*rpl_environ ())
+ #endif
+ or better (avoiding contradictory use of 'static' and 'extern'):
+ #if HAVE_RAW_DECL_ENVIRON
+ static char ***
+ _GL_WARN_ON_USE_ATTRIBUTE ("environ is not always properly declared")
+ rpl_environ (void) { return &environ; }
+ # undef environ
+ # define environ (*rpl_environ ())
+ #endif
*/
#ifndef _GL_WARN_ON_USE
@@ -67,13 +85,17 @@
/* A compiler attribute is available in gcc versions 4.3.0 and later. */
# define _GL_WARN_ON_USE(function, message) \
extern __typeof__ (function) function __attribute__ ((__warning__ (message)))
+# define _GL_WARN_ON_USE_ATTRIBUTE(message) \
+ __attribute__ ((__warning__ (message)))
# elif __GNUC__ >= 3 && GNULIB_STRICT_CHECKING
/* Verify the existence of the function. */
# define _GL_WARN_ON_USE(function, message) \
extern __typeof__ (function) function
+# define _GL_WARN_ON_USE_ATTRIBUTE(message)
# else /* Unsupported. */
# define _GL_WARN_ON_USE(function, message) \
_GL_WARN_EXTERN_C int _gl_warn_on_use
+# define _GL_WARN_ON_USE_ATTRIBUTE(message)
# endif
#endif
diff --git a/lib/xalloc-oversized.h b/lib/xalloc-oversized.h
index 1bbde4e6eed..e3068c83c48 100644
--- a/lib/xalloc-oversized.h
+++ b/lib/xalloc-oversized.h
@@ -1,7 +1,6 @@
/* xalloc-oversized.h -- memory allocation size checking
- Copyright (C) 1990-2000, 2003-2004, 2006-2019 Free Software
- Foundation, Inc.
+ Copyright (C) 1990-2000, 2003-2004, 2006-2019 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
diff --git a/lisp/ChangeLog.2 b/lisp/ChangeLog.2
index 4b9aa7fc4b6..e8675b9896e 100644
--- a/lisp/ChangeLog.2
+++ b/lisp/ChangeLog.2
@@ -1229,7 +1229,7 @@
1987-05-13 Richard M. Stallman (rms@prep)
* sendmail.el (mail-setup): New parameter mail-default-reply-to:
- if non-nil, insert it as a Reply-to field.
+ if non-nil, insert it as a Reply-To field.
* dired.el (dired-unflag): Doc fix.
@@ -3924,7 +3924,7 @@
New key bindings for setting insert motion direction:
C-c <, C-c >, C-c ^ and C-c . instead of M- chars.
- * rmail.el (rmail-reply): When putting From into In-reply-to,
+ * rmail.el (rmail-reply): When putting From into In-Reply-To,
stop at any newline.
* mail-utils.el (mail-strip-quoted-names):
diff --git a/lisp/ChangeLog.4 b/lisp/ChangeLog.4
index b8ae394d54d..74f09e5e380 100644
--- a/lisp/ChangeLog.4
+++ b/lisp/ChangeLog.4
@@ -3739,7 +3739,7 @@
1994-01-10 Michael D. Ernst (mernst@monozygote)
- * mailabbrev.el (mail-abbrev-mode-regexp): Add Reply-to.
+ * mailabbrev.el (mail-abbrev-mode-regexp): Add Reply-To.
1994-01-09 Roland McGrath (roland@churchy.gnu.ai.mit.edu)
diff --git a/lisp/ChangeLog.5 b/lisp/ChangeLog.5
index 5d079756387..0976a15a600 100644
--- a/lisp/ChangeLog.5
+++ b/lisp/ChangeLog.5
@@ -991,7 +991,7 @@
1995-05-19 Kevin Rodgers <kevinr@ihs.com> (tiny change)
* mailalias.el (expand-mail-aliases): Expand aliases in
- From and Reply-to headers as well, plus the Resent- variants.
+ From and Reply-To headers as well, plus the Resent- variants.
* sendmail.el (mail-mode): Clarify doc string.
(mail-text): Ditto.
diff --git a/lisp/ChangeLog.7 b/lisp/ChangeLog.7
index b3686af0d07..b8e0f10199c 100644
--- a/lisp/ChangeLog.7
+++ b/lisp/ChangeLog.7
@@ -21076,7 +21076,7 @@
1996-12-17 Jonathan I. Kamens <jik@cam.ov.com>
* rnewspost.el (news-mail-reply, news-reply): Include the message
- ID in the In-reply-to line.
+ ID in the In-Reply-To line.
1996-12-16 Erik Naggum <erik@naggum.no>
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index e0abce49d3c..9bcd5a88242 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -101,6 +101,10 @@ COMPILE_FIRST = \
$(lisp)/emacs-lisp/bytecomp.elc \
$(lisp)/emacs-lisp/autoload.elc
+# Files to compile early in compile-main. Works around bug#25556.
+MAIN_FIRST = ./emacs-lisp/eieio.el ./emacs-lisp/eieio-base.el \
+ ./cedet/semantic/db.el
+
# Prevent any settings in the user environment causing problems.
unexport EMACSDATA EMACSDOC EMACSPATH
@@ -216,7 +220,7 @@ update-subdirs:
$(srcdir)/../build-aux/update-subdirs $$file; \
done;
-.PHONY: updates repo-update update-authors update-gnus-news
+.PHONY: updates repo-update update-authors
# Some modes of make-dist use this.
updates: update-subdirs autoloads finder-data custom-deps
@@ -229,17 +233,12 @@ updates: update-subdirs autoloads finder-data custom-deps
# this directory's autoloads rule.
repo-update: compile finder-data custom-deps
-# Update etc/AUTHORS and etc/GNUS-NEWS.
+# Update etc/AUTHORS
update-authors:
$(emacs) -L "$(top_srcdir)/admin" -l authors \
-f batch-update-authors "$(top_srcdir)/etc/AUTHORS" "$(top_srcdir)"
-update-gnus-news:
- $(emacs) -L "$(top_srcdir)/doc/misc" -l gnus-news -f batch-gnus-news \
- "$(top_srcdir)/doc/misc/gnus-news.texi" \
- "$(top_srcdir)/etc/GNUS-NEWS"
-
FORCE:
.PHONY: FORCE
@@ -317,14 +316,16 @@ compile-targets: $(TARGETS)
# Compile all the Elisp files that need it. Beware: it approximates
# 'no-byte-compile', so watch out for false-positives!
compile-main: gen-lisp compile-clean
- @(cd $(lisp) && \
+ @(cd $(lisp) && \
els=`echo "${SUBDIRS_REL} " | sed -e 's|/\./|/|g' -e 's|/\. | |g' -e 's| |/*.el |g'`; \
- for el in $$els; do \
- test -f $$el || continue; \
- test ! -f $${el}c && GREP_OPTIONS= grep '^;.*no-byte-compile: t' $$el > /dev/null && continue; \
- echo "$${el}c"; \
- done | xargs $(XARGS_LIMIT) echo) | \
- while read chunk; do \
+ for el in ${MAIN_FIRST} $$els; do \
+ test -f $$el || continue; \
+ test ! -f $${el}c && \
+ GREP_OPTIONS= grep '^;.*[^a-zA-Z]no-byte-compile: *t' $$el > /dev/null && \
+ continue; \
+ echo "$${el}c"; \
+ done | xargs $(XARGS_LIMIT) echo) | \
+ while read chunk; do \
$(MAKE) compile-targets TARGETS="$$chunk"; \
done
@@ -337,7 +338,7 @@ compile-clean:
if test -f "$$el" || test ! -f "$${el}c"; then :; else \
echo rm "$${el}c"; \
rm "$${el}c"; \
- fi \
+ fi; \
done
.PHONY: gen-lisp leim semantic
@@ -346,7 +347,9 @@ compile-clean:
## with ../src. See comments above for loaddefs.
gen-lisp: leim semantic
-leim:
+# (re)compile titdic-cnv before recursing into `leim` since its used to
+# generate some of the Quail source files from tables.
+leim: $(lisp)/international/titdic-cnv.elc
$(MAKE) -C ../leim all EMACS="$(EMACS)"
semantic:
diff --git a/lisp/abbrev.el b/lisp/abbrev.el
index aebf65e0f78..3c88ec661a9 100644
--- a/lisp/abbrev.el
+++ b/lisp/abbrev.el
@@ -56,9 +56,6 @@ define global abbrevs instead."
(define-minor-mode abbrev-mode
"Toggle Abbrev mode in the current buffer.
-With a prefix argument ARG, enable Abbrev mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-Abbrev mode if ARG is omitted or nil.
In Abbrev mode, inserting an abbreviation causes it to expand and
be replaced by its expansion."
@@ -68,6 +65,8 @@ be replaced by its expansion."
(put 'abbrev-mode 'safe-local-variable 'booleanp)
+(define-obsolete-variable-alias 'edit-abbrevs-map
+ 'edit-abbrevs-mode-map "24.4")
(defvar edit-abbrevs-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "\C-x\C-s" 'abbrev-edit-save-buffer)
@@ -75,8 +74,6 @@ be replaced by its expansion."
(define-key map "\C-c\C-c" 'edit-abbrevs-redefine)
map)
"Keymap used in `edit-abbrevs'.")
-(define-obsolete-variable-alias 'edit-abbrevs-map
- 'edit-abbrevs-mode-map "24.4")
(defun kill-all-abbrevs ()
"Undefine all defined abbrevs."
@@ -255,7 +252,8 @@ have been saved."
(lambda (s1 s2)
(string< (symbol-name s1)
(symbol-name s2)))))
- (insert-abbrev-table-description table nil))
+ (if (abbrev--table-symbols table)
+ (insert-abbrev-table-description table nil)))
(when (unencodable-char-position (point-min) (point-max) 'utf-8)
(setq coding-system-for-write
(if (> emacs-major-version 24)
@@ -900,18 +898,22 @@ is not undone."
(defun abbrev--write (sym)
"Write the abbrev in a `read'able form.
-Only writes the non-system abbrevs.
Presumes that `standard-output' points to `current-buffer'."
- (unless (or (null (symbol-value sym)) (abbrev-get sym :system))
- (insert " (")
- (prin1 (symbol-name sym))
- (insert " ")
- (prin1 (symbol-value sym))
- (insert " ")
- (prin1 (symbol-function sym))
- (insert " ")
- (prin1 (abbrev-get sym :count))
- (insert ")\n")))
+ (insert " (")
+ (prin1 (symbol-name sym))
+ (insert " ")
+ (prin1 (symbol-value sym))
+ (insert " ")
+ (prin1 (symbol-function sym))
+ (insert " :count ")
+ (prin1 (abbrev-get sym :count))
+ (when (abbrev-get sym :case-fixed)
+ (insert " :case-fixed ")
+ (prin1 (abbrev-get sym :case-fixed)))
+ (when (abbrev-get sym :enable-function)
+ (insert " :enable-function ")
+ (prin1 (abbrev-get sym :enable-function)))
+ (insert ")\n"))
(defun abbrev--describe (sym)
(when (symbol-value sym)
@@ -932,32 +934,43 @@ Presumes that `standard-output' points to `current-buffer'."
"Insert before point a full description of abbrev table named NAME.
NAME is a symbol whose value is an abbrev table.
If optional 2nd arg READABLE is non-nil, a human-readable description
-is inserted. Otherwise the description is an expression,
-a call to `define-abbrev-table', which would
-define the abbrev table NAME exactly as it is currently defined.
+is inserted.
-Abbrevs marked as \"system abbrevs\" are omitted."
- (let ((table (symbol-value name))
- (symbols ()))
- (mapatoms (lambda (sym) (if (symbol-value sym) (push sym symbols))) table)
+If READABLE is nil, an expression is inserted. The expression is
+a call to `define-abbrev-table' that when evaluated will define
+the abbrev table NAME exactly as it is currently defined.
+Abbrevs marked as \"system abbrevs\" are ignored."
+ (let ((symbols (abbrev--table-symbols name readable)))
(setq symbols (sort symbols 'string-lessp))
(let ((standard-output (current-buffer)))
(if readable
- (progn
- (insert "(")
- (prin1 name)
- (insert ")\n\n")
- (mapc 'abbrev--describe symbols)
- (insert "\n\n"))
- (insert "(define-abbrev-table '")
- (prin1 name)
- (if (null symbols)
- (insert " '())\n\n")
- (insert "\n '(\n")
- (mapc 'abbrev--write symbols)
- (insert " ))\n\n")))
+ (progn
+ (insert "(")
+ (prin1 name)
+ (insert ")\n\n")
+ (mapc 'abbrev--describe symbols)
+ (insert "\n\n"))
+ (insert "(define-abbrev-table '")
+ (prin1 name)
+ (if (null symbols)
+ (insert " '())\n\n")
+ (insert "\n '(\n")
+ (mapc 'abbrev--write symbols)
+ (insert " ))\n\n")))
nil)))
+(defun abbrev--table-symbols (name &optional system)
+ "Return the user abbrev symbols in the abbrev table named NAME.
+NAME is a symbol whose value is an abbrev table. System abbrevs
+are omitted unless SYSTEM is non-nil."
+ (let ((table (symbol-value name))
+ (symbols ()))
+ (mapatoms (lambda (sym)
+ (if (and (symbol-value sym) (or system (not (abbrev-get sym :system))))
+ (push sym symbols)))
+ table)
+ symbols))
+
(defun define-abbrev-table (tablename definitions
&optional docstring &rest props)
"Define TABLENAME (a symbol) as an abbrev table name.
diff --git a/lisp/align.el b/lisp/align.el
index 43918811b9a..fd88d0eda42 100644
--- a/lisp/align.el
+++ b/lisp/align.el
@@ -399,7 +399,7 @@ The possible settings for `align-region-separate' are:
(lambda (end reverse)
(funcall (if reverse 're-search-backward
're-search-forward)
- (concat "[^ \t\n\\\\]"
+ (concat "[^ \t\n\\]"
(regexp-quote comment-start)
"\\(.+\\)$") end t))))
(modes . align-open-comment-modes))
@@ -438,7 +438,7 @@ The possible settings for `align-region-separate' are:
(tab-stop . nil))
(perl-assignment
- (regexp . ,(concat "[^=!^&*-+<>/| \t\n]\\(\\s-*\\)=[~>]?"
+ (regexp . ,(concat "[^=!^&*+<>/| \t\n-]\\(\\s-*\\)=[~>]?"
"\\(\\s-*\\)\\([^>= \t\n]\\|$\\)"))
(group . (1 2))
(modes . align-perl-modes)
@@ -452,7 +452,7 @@ The possible settings for `align-region-separate' are:
(tab-stop . nil))
(make-assignment
- (regexp . "^\\s-*\\w+\\(\\s-*\\):?=\\(\\s-*\\)\\([^\t\n \\\\]\\|$\\)")
+ (regexp . "^\\s-*\\w+\\(\\s-*\\):?=\\(\\s-*\\)\\([^\t\n \\]\\|$\\)")
(group . (1 2))
(modes . '(makefile-mode))
(tab-stop . nil))
@@ -759,7 +759,7 @@ The following attributes are meaningful:
(lambda (end reverse)
(funcall (if reverse 're-search-backward
're-search-forward)
- (concat "[^ \t\n\\\\]"
+ (concat "[^ \t\n\\]"
(regexp-quote comment-start)
"\\(.+\\)$") end t))))
(modes . align-open-comment-modes))
diff --git a/lisp/allout-widgets.el b/lisp/allout-widgets.el
index a10a3f599af..67fce325ff1 100644
--- a/lisp/allout-widgets.el
+++ b/lisp/allout-widgets.el
@@ -513,9 +513,6 @@ happens in the buffer.")
;;;###autoload
(define-minor-mode allout-widgets-mode
"Toggle Allout Widgets mode.
-With a prefix argument ARG, enable Allout Widgets mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Allout Widgets mode is an extension of Allout mode that provides
graphical decoration of outline structure. It is meant to
@@ -768,8 +765,7 @@ Optional RECURSING is for internal use, to limit recursion."
(if allout-widgets-time-decoration-activity
(setq allout-widgets-last-decoration-timing
- (list (allout-elapsed-time-seconds (current-time)
- start-time)
+ (list (allout-elapsed-time-seconds nil start-time)
allout-widgets-changes-record)))
(setq allout-widgets-changes-record nil)
diff --git a/lisp/allout.el b/lisp/allout.el
index 2a6401bcc3b..b3b87e533b9 100644
--- a/lisp/allout.el
+++ b/lisp/allout.el
@@ -1506,41 +1506,6 @@ wrapped within allout's automatic `fill-prefix' setting.")
(make-variable-buffer-local 'allout-outside-normal-auto-fill-function)
;;;_ = prevent redundant activation by desktop mode:
(add-to-list 'desktop-minor-mode-handlers '(allout-mode . nil))
-;;;_ = allout-passphrase-verifier-string
-(defvar allout-passphrase-verifier-string nil
- "Setting used to test solicited encryption passphrases against the one
-already associated with a file.
-
-It consists of an encrypted random string useful only to verify that a
-passphrase entered by the user is effective for decryption. The passphrase
-itself is *not* recorded in the file anywhere, and the encrypted contents
-are random binary characters to avoid exposing greater susceptibility to
-search attacks.
-
-The verifier string is retained as an Emacs file variable, as well as in
-the Emacs buffer state, if file variable adjustments are enabled. See
-`allout-enable-file-variable-adjustment' for details about that.")
-(make-variable-buffer-local 'allout-passphrase-verifier-string)
-(make-obsolete-variable 'allout-passphrase-verifier-string
- "it is no longer used." "23.3")
-;;;###autoload
-(put 'allout-passphrase-verifier-string 'safe-local-variable 'stringp)
-;;;_ = allout-passphrase-hint-string
-(defvar allout-passphrase-hint-string ""
- "Variable used to retain reminder string for file's encryption passphrase.
-
-See the description of `allout-passphrase-hint-handling' for details about how
-the reminder is deployed.
-
-The hint is retained as an Emacs file variable, as well as in the Emacs buffer
-state, if file variable adjustments are enabled. See
-`allout-enable-file-variable-adjustment' for details about that.")
-(make-variable-buffer-local 'allout-passphrase-hint-string)
-(setq-default allout-passphrase-hint-string "")
-(make-obsolete-variable 'allout-passphrase-hint-string
- "it is no longer used." "23.3")
-;;;###autoload
-(put 'allout-passphrase-hint-string 'safe-local-variable 'stringp)
;;;_ = allout-after-save-decrypt
(defvar allout-after-save-decrypt nil
"Internal variable, is nil or has the value of two points:
@@ -1687,7 +1652,7 @@ from what it did before, for backwards compatibility.
MODE is the activation mode - see `allout-auto-activation' for
valid values."
(declare (obsolete allout-auto-activation "23.3"))
- (custom-set-variables (list 'allout-auto-activation (format "%s" mode)))
+ (customize-set-variable 'allout-auto-activation (format "%s" mode))
(format "%s" mode))
;;;_ > allout-setup-menubar ()
@@ -1728,9 +1693,6 @@ valid values."
(define-minor-mode allout-mode
;;;_ . Doc string:
"Toggle Allout outline mode.
-With a prefix argument ARG, enable Allout outline mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
\\<allout-mode-map-value>
Allout outline mode is a minor mode that provides extensive
@@ -4389,7 +4351,7 @@ subtopics into siblings of the item."
(let ((children-chart (allout-chart-subtree 1)))
(if (listp (car children-chart))
;; whoops:
- (setq children-chart (allout-flatten children-chart)))
+ (setq children-chart (flatten-tree children-chart)))
(save-excursion
(dolist (child-point children-chart)
(goto-char child-point)
@@ -5826,7 +5788,7 @@ BULLET string, and a list of TEXT strings for the body."
; "\end{verbatim}" in text,
; it's special:
(if (and body-content
- (setq bop (string-match "\\end{verbatim}" curr-line)))
+ (setq bop (string-match "\\\\end{verbatim}" curr-line)))
(setq curr-line (concat (substring curr-line 0 bop)
">"
(substring curr-line bop))))
@@ -6585,14 +6547,7 @@ If BEG is bigger than END we return 0."
(apply 'concat
(mapcar (lambda (char) (if (= char ?%) "%%" (char-to-string char)))
string)))
-;;;_ : lists
-;;;_ > allout-flatten (list)
-(defun allout-flatten (list)
- "Return a list of all atoms in list."
- ;; classic.
- (cond ((null list) nil)
- ((atom (car list)) (cons (car list) (allout-flatten (cdr list))))
- (t (append (allout-flatten (car list)) (allout-flatten (cdr list))))))
+(define-obsolete-function-alias 'allout-flatten #'flatten-tree "27.1")
;;;_ : Compatibility:
;;;_ : xemacs undo-in-progress provision:
(unless (boundp 'undo-in-progress)
diff --git a/lisp/ansi-color.el b/lisp/ansi-color.el
index 121a89a2d81..d3b8d06604c 100644
--- a/lisp/ansi-color.el
+++ b/lisp/ansi-color.el
@@ -182,7 +182,7 @@ in shell buffers. You set this variable by calling one of:
:group 'ansi-colors
:version "23.2")
-(defvar ansi-color-apply-face-function 'ansi-color-apply-overlay-face
+(defvar ansi-color-apply-face-function #'ansi-color-apply-overlay-face
"Function for applying an Ansi Color face to text in a buffer.
This function should accept three arguments: BEG, END, and FACE,
and it should apply face FACE to the text between BEG and END.")
@@ -480,6 +480,7 @@ Emacs requires OBJECT to be a buffer."
;; In order to avoid this, we use the `insert-behind-hooks' overlay
;; property to make sure it works.
(let ((overlay (make-overlay from to object)))
+ (overlay-put overlay 'evaporate t)
(overlay-put overlay 'modification-hooks '(ansi-color-freeze-overlay))
(overlay-put overlay 'insert-behind-hooks '(ansi-color-freeze-overlay))
overlay)))
diff --git a/lisp/apropos.el b/lisp/apropos.el
index e27ff76c119..1b86f5bcde3 100644
--- a/lisp/apropos.el
+++ b/lisp/apropos.el
@@ -681,19 +681,19 @@ the output includes key-bindings of commands."
(re (concat "\\(?:\\`\\|[\\/]\\)" (regexp-quote file)
"\\(\\.\\|\\'\\)")))
(while (and lh (null lh-entry))
- (if (and (caar lh) (string-match re (caar lh)))
+ (if (and (stringp (caar lh)) (string-match re (caar lh)))
(setq lh-entry (car lh))
(setq lh (cdr lh)))))
(unless lh-entry (error "Unknown library `%s'" file)))
(dolist (x (cdr lh-entry))
(pcase (car-safe x)
;; (autoload (push (cdr x) autoloads))
- (`require (push (cdr x) requires))
- (`provide (push (cdr x) provides))
- (`t nil) ; Skip "was an autoload" entries.
+ ('require (push (cdr x) requires))
+ ('provide (push (cdr x) provides))
+ ('t nil) ; Skip "was an autoload" entries.
;; FIXME: Print information about each individual method: both
;; its docstring and specializers (bug#21422).
- (`cl-defmethod (push (cadr x) provides))
+ ('cl-defmethod (push (cadr x) provides))
(_ (push (or (cdr-safe x) x) symbols))))
(let ((apropos-pattern "")) ;Dummy binding for apropos-symbols-internal.
(apropos-symbols-internal
diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el
index 0e4ee525db1..6a58d61a547 100644
--- a/lisp/arc-mode.el
+++ b/lisp/arc-mode.el
@@ -531,12 +531,10 @@ Each descriptor is a vector of the form
(defsubst archive-name (suffix)
(intern (concat "archive-" (symbol-name archive-subtype) "-" suffix)))
-(defun archive-l-e (str &optional len float)
+(defun archive-l-e (str &optional len)
"Convert little endian string/vector STR to integer.
Alternatively, STR may be a buffer position in the current buffer
-in which case a second argument, length LEN, should be supplied.
-FLOAT, if non-nil, means generate and return a float instead of an integer
-\(use this for numbers that can overflow the Emacs integer)."
+in which case a second argument, length LEN, should be supplied."
(if (stringp str)
(setq len (length str))
(setq str (buffer-substring str (+ str len))))
@@ -545,7 +543,7 @@ FLOAT, if non-nil, means generate and return a float instead of an integer
(i 0))
(while (< i len)
(setq i (1+ i)
- result (+ (if float (* result 256.0) (ash result 8))
+ result (+ (ash result 8)
(aref str (- len i)))))
result))
@@ -583,7 +581,7 @@ the mode is invalid. If ERROR is nil then nil will be returned."
(len (length newmode))
(i 1))
(while (< i len)
- (setq result (+ (lsh result 3) (aref newmode i) (- ?0))
+ (setq result (+ (ash result 3) (aref newmode i) (- ?0))
i (1+ i)))
(logior (logand oldmode 65024) result)))
((string-match "^\\([agou]+\\)\\([---+=]\\)\\([rwxst]+\\)$" newmode)
@@ -639,7 +637,7 @@ the mode is invalid. If ERROR is nil then nil will be returned."
(defun archive-unixdate (low high)
"Stringify Unix (LOW HIGH) date."
- (let* ((time (cons high low))
+ (let* ((time (list high low))
(str (current-time-string time)))
(format "%s-%s-%s"
(substring str 8 10)
@@ -648,8 +646,7 @@ the mode is invalid. If ERROR is nil then nil will be returned."
(defun archive-unixtime (low high)
"Stringify Unix (LOW HIGH) time."
- (let ((str (current-time-string (cons high low))))
- (substring str 11 19)))
+ (format-time-string "%H:%M:%S" (list high low)))
(defun archive-get-lineno ()
(if (>= (point) archive-file-list-start)
@@ -748,8 +745,7 @@ archive.
(or file-name-coding-system
default-file-name-coding-system
locale-coding-system))
- (if (default-value 'enable-multibyte-characters)
- (set-buffer-multibyte 'to))
+ (set-buffer-multibyte 'to)
(archive-summarize nil)
(setq buffer-read-only t)
(when (and archive-visit-single-files
@@ -807,7 +803,7 @@ is visible (and the real data of the buffer is hidden).
Optional argument SHUT-UP, if non-nil, means don't print messages
when parsing the archive."
(widen)
- (let ((buffer-file-truename nil) ; avoid changing dir mtime by lock_file
+ (let ((create-lockfiles nil) ; avoid changing dir mtime by lock_file
(inhibit-read-only t))
(setq archive-proper-file-start (copy-marker (point-min) t))
(set (make-local-variable 'change-major-mode-hook) 'archive-desummarize)
@@ -972,8 +968,8 @@ using `make-temp-file', and the generated name is returned."
(jka-compr-inhibit t))
(write-region (point-min) (point-max) tmpfile nil 'quiet))
(erase-buffer)
- (let ((coding-system-for-read 'no-conversion))
- (insert-file-contents tmpfile)))
+ (set-buffer-multibyte t)
+ (insert-file-contents tmpfile))
(delete-file tmpfile)))))
(defun archive-file-name-handler (op &rest args)
@@ -1011,8 +1007,6 @@ using `make-temp-file', and the generated name is returned."
(kill-local-variable 'buffer-file-coding-system)
(after-insert-file-set-coding (- (point-max) (point-min))))))
-(define-obsolete-function-alias 'archive-mouse-extract 'archive-extract "22.1")
-
(defun archive-extract (&optional other-window-p event)
"In archive mode, extract this entry of the archive into its own buffer."
(interactive (list nil last-input-event))
@@ -1064,7 +1058,9 @@ using `make-temp-file', and the generated name is returned."
;; We read an archive member by no-conversion at
;; first, then decode appropriately by calling
;; archive-set-buffer-as-visiting-file later.
- (coding-system-for-read 'no-conversion))
+ (coding-system-for-read 'no-conversion)
+ ;; Avoid changing dir mtime by lock_file
+ (create-lockfiles nil))
(condition-case err
(if (fboundp extractor)
(funcall extractor archive ename)
@@ -1502,14 +1498,13 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(fnlen (or (string-match "\0" namefld) 13))
(efnname (decode-coding-string (substring namefld 0 fnlen)
archive-file-name-coding-system))
- ;; Convert to float to avoid overflow for very large files.
- (csize (archive-l-e (+ p 15) 4 'float))
+ (csize (archive-l-e (+ p 15) 4))
(moddate (archive-l-e (+ p 19) 2))
(modtime (archive-l-e (+ p 21) 2))
- (ucsize (archive-l-e (+ p 25) 4 'float))
+ (ucsize (archive-l-e (+ p 25) 4))
(fiddle (string= efnname (upcase efnname)))
(ifnname (if fiddle (downcase efnname) efnname))
- (text (format " %8.0f %-11s %-8s %s"
+ (text (format " %8d %-11s %-8s %s"
ucsize
(archive-dosdate moddate)
(archive-dostime modtime)
@@ -1522,11 +1517,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
visual)
files (cons (vector efnname ifnname fiddle nil (1- p))
files)
- ;; p needs to stay an integer, since we use it in char-after
- ;; above. Passing through `round' limits the compressed size
- ;; to most-positive-fixnum, but if the compressed size exceeds
- ;; that, we cannot visit the archive anyway.
- p (+ p 29 (round csize)))))
+ p (+ p 29 csize))))
(goto-char (point-min))
(let ((dash (concat "- -------- ----------- -------- "
(make-string maxlen ?-)
@@ -1535,7 +1526,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
dash)
(archive-summarize-files (nreverse visual))
(insert dash
- (format " %8.0f %d file%s"
+ (format " %8d %d file%s"
totalsize
(length files)
(if (= 1 (length files)) "" "s"))
@@ -1543,7 +1534,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(apply #'vector (nreverse files))))
(defun archive-arc-rename-entry (newname descr)
- (if (string-match "[:\\\\/]" newname)
+ (if (string-match "[:\\/]" newname)
(error "File names in arc files must not contain a directory component"))
(if (> (length newname) 12)
(error "File names in arc files are limited to 12 characters"))
@@ -1568,10 +1559,9 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(while (progn (goto-char p) ;beginning of a base header.
(looking-at "\\(.\\|\n\\)\\(.\\|\n\\)-l[hz][0-9ds]-"))
(let* ((hsize (byte-after p)) ;size of the base header (level 0 and 1)
- ;; Convert to float to avoid overflow for very large files.
- (csize (archive-l-e (+ p 7) 4 'float)) ;size of a compressed file to follow (level 0 and 2),
+ (csize (archive-l-e (+ p 7) 4)) ;size of a compressed file to follow (level 0 and 2),
;size of extended headers + the compressed file to follow (level 1).
- (ucsize (archive-l-e (+ p 11) 4 'float)) ;size of an uncompressed file.
+ (ucsize (archive-l-e (+ p 11) 4)) ;size of an uncompressed file.
(time1 (archive-l-e (+ p 15) 2)) ;date/time (MSDOS format in level 0, 1 headers
(time2 (archive-l-e (+ p 17) 2)) ;and UNIX format in level 2 header.)
(hdrlvl (byte-after (+ p 20))) ;header level
@@ -1661,12 +1651,12 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(archive-unixtime time1 time2)
(archive-dostime time1)))
(setq text (if archive-alternate-display
- (format " %8.0f %5S %5S %s"
+ (format " %8d %5S %5S %s"
ucsize
(or uid "?")
(or gid "?")
ifnname)
- (format " %10s %8.0f %-11s %-8s %s"
+ (format " %10s %8d %-11s %-8s %s"
modestr
ucsize
moddate
@@ -1681,13 +1671,9 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
files (cons (vector prname ifnname fiddle mode (1- p))
files))
(cond ((= hdrlvl 1)
- ;; p needs to stay an integer, since we use it in goto-char
- ;; above. Passing through `round' limits the compressed size
- ;; to most-positive-fixnum, but if the compressed size exceeds
- ;; that, we cannot visit the archive anyway.
- (setq p (+ p hsize 2 (round csize))))
+ (setq p (+ p hsize 2 csize)))
((or (= hdrlvl 2) (= hdrlvl 0))
- (setq p (+ p thsize 2 (round csize)))))
+ (setq p (+ p thsize 2 csize))))
))
(goto-char (point-min))
(let ((dash (concat (if archive-alternate-display
@@ -1760,7 +1746,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(setq newval (funcall newval (archive-l-e (+ p2 ofs) 2))))
(goto-char (+ p2 ofs))
(delete-char 2)
- (insert-unibyte (logand newval 255) (lsh newval -8))
+ (insert-unibyte (logand newval 255) (ash newval -8))
(goto-char (1+ p))
(delete-char 1)
(insert-unibyte (archive-lzh-resum (1+ p) hsize)))
@@ -1825,32 +1811,21 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
;;
;; First, find the Zip64 end-of-central-directory locator.
(search-backward "PK\006\007")
- ;; Pay attention: the offset of Zip64 end-of-central-directory
- ;; is a 64-bit field, so it could overflow the Emacs integer
- ;; even on a 64-bit host, let alone 32-bit one. But since we've
- ;; already read the zip file into a buffer, and this is a byte
- ;; offset into the file we've read, it must be short enough, so
- ;; such an overflow can never happen, and we can safely read
- ;; these 8 bytes into an Emacs integer. Moreover, on host with
- ;; 32-bit Emacs integer we can only read 4 bytes, since they are
- ;; stored in little-endian byte order.
- (setq emacs-int-has-32bits (<= most-positive-fixnum #x1fffffff))
(setq p (+ (point-min)
- (archive-l-e (+ (point) 8) (if emacs-int-has-32bits 4 8))))
+ (archive-l-e (+ (point) 8) 8)))
(goto-char p)
;; We should be at Zip64 end-of-central-directory record now.
(or (string= "PK\006\006" (buffer-substring p (+ p 4)))
(error "Unrecognized ZIP file format"))
;; Offset to central directory:
- (setq p (archive-l-e (+ p 48) (if emacs-int-has-32bits 4 8))))
+ (setq p (archive-l-e (+ p 48) 8)))
(setq p (+ p (point-min)))
(while (string= "PK\001\002" (buffer-substring p (+ p 4)))
(let* ((creator (byte-after (+ p 5)))
;; (method (archive-l-e (+ p 10) 2))
(modtime (archive-l-e (+ p 12) 2))
(moddate (archive-l-e (+ p 14) 2))
- ;; Convert to float to avoid overflow for very large files.
- (ucsize (archive-l-e (+ p 24) 4 'float))
+ (ucsize (archive-l-e (+ p 24) 4))
(fnlen (archive-l-e (+ p 28) 2))
(exlen (archive-l-e (+ p 30) 2))
(fclen (archive-l-e (+ p 32) 2))
@@ -1875,7 +1850,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(string= (upcase efnname) efnname)))
(ifnname (if fiddle (downcase efnname) efnname))
(width (string-width ifnname))
- (text (format " %10s %8.0f %-11s %-8s %s"
+ (text (format " %10s %8d %-11s %-8s %s"
modestr
ucsize
(archive-dosdate moddate)
@@ -1901,7 +1876,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
dash)
(archive-summarize-files (nreverse visual))
(insert dash
- (format " %8.0f %d file%s"
+ (format " %8d %d file%s"
totalsize
(length files)
(if (= 1 (length files)) "" "s"))
@@ -1950,11 +1925,11 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(cond ((memq creator '(2 3)) ; Unix
(goto-char (+ p 40))
(delete-char 2)
- (insert-unibyte (logand newval 255) (lsh newval -8)))
+ (insert-unibyte (logand newval 255) (ash newval -8)))
((memq creator '(0 5 6 7 10 11 15)) ; Dos etc.
(goto-char (+ p 38))
(insert-unibyte (logior (logand (byte-after (point)) 254)
- (logand (logxor 1 (lsh newval -7)) 1)))
+ (logand (logxor 1 (ash newval -7)) 1)))
(delete-char 1))
(t (message "Don't know how to change mode for this member"))))
))))
@@ -1972,8 +1947,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(let* ((next (1+ (archive-l-e (+ p 6) 4)))
(moddate (archive-l-e (+ p 14) 2))
(modtime (archive-l-e (+ p 16) 2))
- ;; Convert to float to avoid overflow for very large files.
- (ucsize (archive-l-e (+ p 20) 4 'float))
+ (ucsize (archive-l-e (+ p 20) 4))
(namefld (buffer-substring (+ p 38) (+ p 38 13)))
(dirtype (byte-after (+ p 4)))
(lfnlen (if (= dirtype 2) (byte-after (+ p 56)) 0))
@@ -1996,7 +1970,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(fiddle (and (= lfnlen 0) (string= efnname (upcase efnname))))
(ifnname (if fiddle (downcase efnname) efnname))
(width (string-width ifnname))
- (text (format " %8.0f %-11s %-8s %s"
+ (text (format " %8d %-11s %-8s %s"
ucsize
(archive-dosdate moddate)
(archive-dostime modtime)
@@ -2018,7 +1992,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
dash)
(archive-summarize-files (nreverse visual))
(insert dash
- (format " %8.0f %d file%s"
+ (format " %8d %d file%s"
totalsize
(length files)
(if (= 1 (length files)) "" "s"))
@@ -2042,14 +2016,14 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(call-process "lsar" nil t nil "-l" (or file copy))
(if copy (delete-file copy))
(goto-char (point-min))
- (re-search-forward "^\\(\s+=+\s?+\\)+\n")
- (while (looking-at (concat "^\s+[0-9.]+\s+-+\s+" ; Flags
- "\\([0-9-]+\\)\s+" ; Size
- "\\([0-9.%]+\\)\s+" ; Ratio
- "\\([0-9a-zA-Z]+\\)\s+" ; Mode
- "\\([0-9-]+\\)\s+" ; Date
- "\\([0-9:]+\\)\s+" ; Time
- "\\(.*\\)\n" ; Name
+ (re-search-forward "^\\(\s+=+\s*\\)+\n")
+ (while (looking-at (concat "^\s+[0-9.]+\s+D?-+\s+" ; Flags
+ "\\([0-9-]+\\)\s+" ; Size
+ "\\([-0-9.%]+\\|-+\\)\s+" ; Ratio
+ "\\([0-9a-zA-Z]+\\)\s+" ; Mode
+ "\\([0-9-]+\\)\s+" ; Date
+ "\\([0-9:]+\\)\s+" ; Time
+ "\\(.*\\)\n" ; Name
))
(goto-char (match-end 0))
(let ((name (match-string 6))
@@ -2091,7 +2065,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
;; The code below assumes the name is relative and may do undesirable
;; things otherwise.
(error "Can't extract files with non-relative names")
- (archive-extract-by-file archive name `("unar" "-no-directory" "-o") "Successfully extracted")))
+ (archive-extract-by-file archive name '("unar" "-no-directory" "-o") "Successfully extracted")))
;;; Section: Rar self-extracting .exe archives.
@@ -2212,8 +2186,6 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(while (looking-at archive-ar-file-header-re)
(let ((name (match-string 1))
extname
- ;; Emacs will automatically use float here because those
- ;; timestamps don't fit in our ints.
(time (string-to-number (match-string 2)))
(user (match-string 3))
(group (match-string 4))
diff --git a/lisp/auth-source-pass.el b/lisp/auth-source-pass.el
index bd90045b38d..4283ed0392b 100644
--- a/lisp/auth-source-pass.el
+++ b/lisp/auth-source-pass.el
@@ -4,10 +4,10 @@
;; Author: Damien Cassou <damien@cassou.me>,
;; Nicolas Petton <nicolas@petton.fr>
-;; Version: 2.0.0
-;; Package-Requires: ((emacs "24.4")
+;; Version: 4.0.1
+;; Package-Requires: ((emacs "25"))
+;; Url: https://github.com/DamienCassou/auth-password-store
;; Created: 07 Jun 2015
-;; Keywords: pass password-store auth-source username password login
;; This file is part of GNU Emacs.
@@ -45,14 +45,22 @@
See `auth-source-search' for details on SPEC."
(cl-assert (or (null type) (eq type (oref backend type)))
t "Invalid password-store search: %s %s")
- (when (listp host)
+ (when (consp host)
+ (warn "auth-source-pass ignores all but first host in spec.")
;; Take the first non-nil item of the list of hosts
(setq host (seq-find #'identity host)))
- (list (auth-source-pass--build-result host port user)))
+ (cond ((eq host t)
+ (warn "auth-source-pass does not handle host wildcards.")
+ nil)
+ ((null host)
+ ;; Do not build a result, as none will match when HOST is nil
+ nil)
+ (t
+ (list (auth-source-pass--build-result host port user)))))
(defun auth-source-pass--build-result (host port user)
"Build auth-source-pass entry matching HOST, PORT and USER."
- (let ((entry (auth-source-pass--find-match host user)))
+ (let ((entry (auth-source-pass--find-match host user port)))
(when entry
(let ((retval (list
:host host
@@ -73,7 +81,7 @@ See `auth-source-search' for details on SPEC."
(defvar auth-source-pass-backend
(auth-source-backend
- (format "Password store")
+ (when (<= emacs-major-version 25) "password-store")
:source "." ;; not used
:type 'password-store
:search-function #'auth-source-pass-search)
@@ -84,7 +92,9 @@ See `auth-source-search' for details on SPEC."
(when (eq entry 'password-store)
(auth-source-backend-parse-parameters entry auth-source-pass-backend)))
-(add-hook 'auth-source-backend-parser-functions #'auth-source-pass-backend-parse)
+(if (boundp 'auth-source-backend-parser-functions)
+ (add-hook 'auth-source-backend-parser-functions #'auth-source-pass-backend-parse)
+ (advice-add 'auth-source-backend-parse :before-until #'auth-source-pass-backend-parse))
(defun auth-source-pass-get (key entry)
@@ -124,12 +134,12 @@ ENTRY is the name of a password-store entry."
(defun auth-source-pass--parse-secret (contents)
"Parse the password-store data in the string CONTENTS and return its secret.
The secret is the first line of CONTENTS."
- (car (split-string contents "\\\n" t)))
+ (car (split-string contents "\n" t)))
(defun auth-source-pass--parse-data (contents)
"Parse the password-store data in the string CONTENTS and return an alist.
CONTENTS is the contents of a password-store formatted file."
- (let ((lines (split-string contents "\\\n" t "\\\s")))
+ (let ((lines (split-string contents "\n" t "[ \t]+")))
(seq-remove #'null
(mapcar (lambda (line)
(let ((pair (mapcar (lambda (s) (string-trim s))
@@ -139,30 +149,10 @@ CONTENTS is the contents of a password-store formatted file."
(mapconcat #'identity (cdr pair) ":")))))
(cdr lines)))))
-(defun auth-source-pass--user-match-p (entry user)
- "Return true iff ENTRY match USER."
- (or (null user)
- (string= user (auth-source-pass-get "user" entry))))
-
-(defun auth-source-pass--hostname (host)
- "Extract hostname from HOST."
- (let ((url (url-generic-parse-url host)))
- (or (url-host url) host)))
-
-(defun auth-source-pass--hostname-with-user (host)
- "Extract hostname and user from HOST."
- (let* ((url (url-generic-parse-url host))
- (user (url-user url))
- (hostname (url-host url)))
- (cond
- ((and user hostname) (format "%s@%s" user hostname))
- (hostname hostname)
- (t host))))
-
(defun auth-source-pass--do-debug (&rest msg)
"Call `auth-source-do-debug` with MSG and a prefix."
(apply #'auth-source-do-debug
- (cons (concat "auth-source-password-store: " (car msg))
+ (cons (concat "auth-source-pass: " (car msg))
(cdr msg))))
(defun auth-source-pass--select-one-entry (entries user)
@@ -199,7 +189,7 @@ often."
(let ((store-dir (expand-file-name "~/.password-store/")))
(mapcar
(lambda (file) (file-name-sans-extension (file-relative-name file store-dir)))
- (directory-files-recursively store-dir "\.gpg$"))))
+ (directory-files-recursively store-dir "\\.gpg$"))))
(defun auth-source-pass--find-all-by-entry-name (entryname user)
"Search the store for all entries either matching ENTRYNAME/USER or ENTRYNAME.
@@ -230,24 +220,39 @@ matching USER."
(car matching-entries))
(_ (auth-source-pass--select-one-entry matching-entries user)))))
-(defun auth-source-pass--find-match (host user)
- "Return a password-store entry name matching HOST and USER.
-If many matches are found, return the first one. If no match is
-found, return nil."
+(defun auth-source-pass--find-match (host user port)
+ "Return a password-store entry name matching HOST, USER and PORT.
+
+Disambiguate between user provided inside HOST (e.g., user@server.com) and
+inside USER by giving priority to USER. Same for PORT."
+ (let* ((url (url-generic-parse-url (if (string-match-p ".*://" host)
+ host
+ (format "https://%s" host)))))
+ (auth-source-pass--find-match-unambiguous
+ (or (url-host url) host)
+ (or user (url-user url))
+ ;; url-port returns 443 (because of the https:// above) by default
+ (or port (number-to-string (url-port url))))))
+
+(defun auth-source-pass--find-match-unambiguous (hostname user port)
+ "Return a password-store entry name matching HOSTNAME, USER and PORT.
+If many matches are found, return the first one. If no match is found,
+return nil.
+
+HOSTNAME should not contain any username or port number."
(or
- (if (url-user (url-generic-parse-url host))
- ;; if HOST contains a user (e.g., "user@host.com"), <HOST>
- (auth-source-pass--find-one-by-entry-name (auth-source-pass--hostname-with-user host) user)
- ;; otherwise, if USER is provided, search for <USER>@<HOST>
- (when (stringp user)
- (auth-source-pass--find-one-by-entry-name (concat user "@" (auth-source-pass--hostname host)) user)))
- ;; if that didn't work, search for HOST without it's user component if any
- (auth-source-pass--find-one-by-entry-name (auth-source-pass--hostname host) user)
+ (and user port (auth-source-pass--find-one-by-entry-name (format "%s@%s:%s" user hostname port) user))
+ (and user (auth-source-pass--find-one-by-entry-name (format "%s@%s" user hostname) user))
+ (and port (auth-source-pass--find-one-by-entry-name (format "%s:%s" hostname port) nil))
+ (auth-source-pass--find-one-by-entry-name hostname user)
;; if that didn't work, remove subdomain: foo.bar.com -> bar.com
- (let ((components (split-string host "\\.")))
+ (let ((components (split-string hostname "\\.")))
(when (= (length components) 3)
;; start from scratch
- (auth-source-pass--find-match (mapconcat 'identity (cdr components) ".") user)))))
+ (auth-source-pass--find-match-unambiguous
+ (mapconcat 'identity (cdr components) ".")
+ user
+ port)))))
(provide 'auth-source-pass)
;;; auth-source-pass.el ends here
diff --git a/lisp/auth-source.el b/lisp/auth-source.el
index 33a9b510f4e..74c44916992 100644
--- a/lisp/auth-source.el
+++ b/lisp/auth-source.el
@@ -39,6 +39,7 @@
;;; Code:
+(require 'json)
(require 'password-cache)
(eval-when-compile (require 'cl-lib))
@@ -82,7 +83,6 @@
expiring. Overrides `password-cache-expiry' through a
let-binding."
:version "24.1"
- :group 'auth-source
:type '(choice (const :tag "Never" nil)
(const :tag "All Day" 86400)
(const :tag "2 Hours" 7200)
@@ -138,7 +138,6 @@ let-binding."
(smtp "smtp" "25"))
"List of authentication protocols and their names"
- :group 'auth-source
:version "23.2" ;; No Gnus
:type '(repeat :tag "Authentication Protocols"
(cons :tag "Protocol Entry"
@@ -167,9 +166,8 @@ let-binding."
(defcustom auth-source-save-behavior 'ask
"If set, auth-source will respect it for save behavior."
- :group 'auth-source
:version "23.2" ;; No Gnus
- :type `(choice
+ :type '(choice
:tag "auth-source new token save behavior"
(const :tag "Always save" t)
(const :tag "Never save" nil)
@@ -182,7 +180,6 @@ let-binding."
"Set this to tell auth-source when to create GPG password
tokens in netrc files. It's either an alist or `never'.
Note that if EPA/EPG is not available, this should NOT be used."
- :group 'auth-source
:version "23.2" ;; No Gnus
:type `(choice
(const :tag "Always use GPG password tokens" (t gpg))
@@ -202,9 +199,8 @@ Note that if EPA/EPG is not available, this should NOT be used."
(defcustom auth-source-do-cache t
"Whether auth-source should cache information with `password-cache'."
- :group 'auth-source
:version "23.2" ;; No Gnus
- :type `boolean)
+ :type 'boolean)
(defcustom auth-source-debug nil
"Whether auth-source should log debug messages.
@@ -217,9 +213,8 @@ for passwords).
If the value is a function, debug messages are logged by calling
that function using the same arguments as `message'."
- :group 'auth-source
:version "23.2" ;; No Gnus
- :type `(choice
+ :type '(choice
:tag "auth-source debugging mode"
(const :tag "Log using `message' to the *Messages* buffer" t)
(const :tag "Log all trivia with `message' to the *Messages* buffer"
@@ -240,8 +235,7 @@ for details.
It's best to customize this with `\\[customize-variable]' because the choices
can get pretty complex."
- :group 'auth-source
- :version "26.1" ;; No Gnus
+ :version "26.1" ; neither new nor changed default
:type `(repeat :tag "Authentication Sources"
(choice
(string :tag "Just a file")
@@ -310,7 +304,6 @@ can get pretty complex."
(defcustom auth-source-gpg-encrypt-to t
"List of recipient keys that `authinfo.gpg' encrypted to.
If the value is not a list, symmetric encryption will be used."
- :group 'auth-source
:version "24.1" ;; No Gnus
:type '(choice (const :tag "Symmetric encryption" t)
(repeat :tag "Recipient public keys"
@@ -362,10 +355,9 @@ soon as a function returns non-nil.")
(defun auth-source-backend-parse (entry)
"Create an auth-source-backend from an ENTRY in `auth-sources'."
- (let (backend)
- (cl-dolist (f auth-source-backend-parser-functions)
- (when (setq backend (funcall f entry))
- (cl-return)))
+ (let ((backend
+ (run-hook-with-args-until-success 'auth-source-backend-parser-functions
+ entry)))
(unless backend
;; none of the parsers worked
@@ -380,27 +372,42 @@ soon as a function returns non-nil.")
;; take just a file name use it as a netrc/plist file
;; matching any user, host, and protocol
(when (stringp entry)
- (setq entry `(:source ,entry)))
- (cond
- ;; a file name with parameters
- ((stringp (plist-get entry :source))
- (if (equal (file-name-extension (plist-get entry :source)) "plist")
+ (setq entry (list :source entry)))
+ (let* ((source (plist-get entry :source))
+ (source-without-gpg
+ (if (and (stringp source)
+ (equal (file-name-extension source) "gpg"))
+ (file-name-sans-extension source)
+ (or source "")))
+ (extension (or (and (stringp source-without-gpg)
+ (file-name-extension source-without-gpg))
+ "")))
+ (when (stringp source)
+ (cond
+ ((equal extension "plist")
(auth-source-backend
- (plist-get entry :source)
- :source (plist-get entry :source)
+ source
+ :source source
:type 'plstore
:search-function #'auth-source-plstore-search
:create-function #'auth-source-plstore-create
- :data (plstore-open (plist-get entry :source)))
- (auth-source-backend
- (plist-get entry :source)
- :source (plist-get entry :source)
- :type 'netrc
- :search-function #'auth-source-netrc-search
- :create-function #'auth-source-netrc-create)))))
+ :data (plstore-open source)))
+ ((member-ignore-case extension '("json"))
+ (auth-source-backend
+ source
+ :source source
+ :type 'json
+ :search-function #'auth-source-json-search))
+ (t
+ (auth-source-backend
+ source
+ :source source
+ :type 'netrc
+ :search-function #'auth-source-netrc-search
+ :create-function #'auth-source-netrc-create))))))
;; Note this function should be last in the parser functions, so we add it first
-(add-hook 'auth-source-backend-parser-functions 'auth-source-backends-parser-file)
+(add-hook 'auth-source-backend-parser-functions #'auth-source-backends-parser-file)
(defun auth-source-backends-parser-macos-keychain (entry)
;; take macos-keychain-{internet,generic}:XYZ and use it as macOS
@@ -447,7 +454,7 @@ soon as a function returns non-nil.")
:search-function #'auth-source-macos-keychain-search
:create-function #'auth-source-macos-keychain-create)))))
-(add-hook 'auth-source-backend-parser-functions 'auth-source-backends-parser-macos-keychain)
+(add-hook 'auth-source-backend-parser-functions #'auth-source-backends-parser-macos-keychain)
(defun auth-source-backends-parser-secrets (entry)
;; take secrets:XYZ and use it as Secrets API collection "XYZ"
@@ -494,7 +501,7 @@ soon as a function returns non-nil.")
:source ""
:type 'ignore))))))
-(add-hook 'auth-source-backend-parser-functions 'auth-source-backends-parser-secrets)
+(add-hook 'auth-source-backend-parser-functions #'auth-source-backends-parser-secrets)
(defun auth-source-backend-parse-parameters (entry backend)
"Fills in the extra auth-source-backend parameters of ENTRY.
@@ -512,7 +519,7 @@ parameters."
(oset backend port val)))
backend)
-;; (mapcar 'auth-source-backend-parse auth-sources)
+;; (mapcar #'auth-source-backend-parse auth-sources)
(cl-defun auth-source-search (&rest spec
&key max require create delete
@@ -940,7 +947,8 @@ Note that the MAX parameter is used so we can exit the parse early."
(if (and (functionp cached-secrets)
(equal cached-mtime
- (nth 5 (file-attributes file))))
+ (file-attribute-modification-time
+ (file-attributes file))))
(progn
(auth-source-do-trivia
"auth-source-netrc-parse: using CACHED file data for %s"
@@ -952,7 +960,8 @@ Note that the MAX parameter is used so we can exit the parse early."
;; (note for the irony-impaired: they are just obfuscated)
(auth-source--aput
auth-source-netrc-cache file
- (list :mtime (nth 5 (file-attributes file))
+ (list :mtime (file-attribute-modification-time
+ (file-attributes file))
:secret (let ((v (mapcar #'1+ (buffer-string))))
(lambda () (apply #'string (mapcar #'1- v)))))))
(goto-char (point-min))
@@ -1302,9 +1311,7 @@ See `auth-source-search' for details on SPEC."
(string-match (car item) file))
(setq ret (cdr item))
(setq check nil)))
- ;; FIXME: `ret' unused.
- ;; Should we return it here?
- ))
+ ret))
(t 'never)))
(plain (or (eval default) (read-passwd prompt))))
;; ask if we don't know what to do (in which case
@@ -1485,13 +1492,13 @@ Here's an example that looks for the first item in the `Login'
Secrets collection:
(let ((auth-sources \\='(\"secrets:Login\")))
- (auth-source-search :max 1)
+ (auth-source-search :max 1))
Here's another that looks for the first item in the `Login'
Secrets collection whose label contains `gnus':
(let ((auth-sources \\='(\"secrets:Login\")))
- (auth-source-search :max 1 :label \"gnus\")
+ (auth-source-search :max 1 :label \"gnus\"))
And this one looks for the first item in the `Login' Secrets
collection that's a Google Chrome entry for the git.gnus.org site
@@ -1502,9 +1509,6 @@ authentication tokens:
"
;; TODO
- (cl-assert (not create) nil
- "The Secrets API auth-source backend doesn't support creation yet")
- ;; TODO
;; (secrets-delete-item coll elt)
(cl-assert (not delete) nil
"The Secrets API auth-source backend doesn't support deletion yet")
@@ -1564,12 +1568,204 @@ authentication tokens:
returned-keys))
plist))
items)))
+ (cond
+ ;; if we need to create an entry AND none were found to match
+ ((and create
+ (not items))
+
+ ;; create based on the spec and record the value
+ (setq items (or
+ ;; if the user did not want to create the entry
+ ;; in the file, it will be returned
+ (apply (slot-value backend 'create-function) spec)
+ ;; if not, we do the search again without :create
+ ;; to get the updated data.
+
+ ;; the result will be returned, even if the search fails
+ (apply #'auth-source-secrets-search
+ (plist-put spec :create nil))))))
items))
-(defun auth-source-secrets-create (&rest spec)
- ;; TODO
- ;; (apply 'secrets-create-item (auth-get-source entry) name passwd spec)
- (debug spec))
+(cl-defun auth-source-secrets-create (&rest spec
+ &key backend host port create
+ &allow-other-keys)
+ (let* ((base-required '(host user port secret label))
+ ;; we know (because of an assertion in auth-source-search) that the
+ ;; :create parameter is either t or a list (which includes nil)
+ (create-extra (if (eq t create) nil create))
+ (current-data (car (auth-source-search :max 1
+ :host host
+ :port port)))
+ (required (append base-required create-extra))
+ (collection (oref backend source))
+ ;; `args' are the arguments for `secrets-create-item'.
+ args
+ ;; `valist' is an alist
+ valist
+ ;; `artificial' will be returned if no creation is needed
+ artificial)
+
+ ;; only for base required elements (defined as function parameters):
+ ;; fill in the valist with whatever data we may have from the search
+ ;; we complete the first value if it's a list and use the value otherwise
+ (dolist (br base-required)
+ (let ((val (plist-get spec (auth-source--symbol-keyword br))))
+ (when val
+ (let ((br-choice (cond
+ ;; all-accepting choice (predicate is t)
+ ((eq t val) nil)
+ ;; just the value otherwise
+ (t val))))
+ (when br-choice
+ (auth-source--aput valist br br-choice))))))
+
+ ;; for extra required elements, see if the spec includes a value for them
+ (dolist (er create-extra)
+ (let ((k (auth-source--symbol-keyword er))
+ (keys (cl-loop for i below (length spec) by 2
+ collect (nth i spec))))
+ (when (memq k keys)
+ (auth-source--aput valist er (plist-get spec k)))))
+
+ ;; for each required element
+ (dolist (r required)
+ (let* ((data (auth-source--aget valist r))
+ ;; take the first element if the data is a list
+ (data (or (auth-source-netrc-element-or-first data)
+ (plist-get current-data
+ (auth-source--symbol-keyword r))))
+ ;; this is the default to be offered
+ (given-default (auth-source--aget
+ auth-source-creation-defaults r))
+ ;; the default supplementals are simple:
+ ;; for the user, try `given-default' and then (user-login-name);
+ ;; for the label, try `given-default' and then user@host;
+ ;; otherwise take `given-default'
+ (default (cond
+ ((and (not given-default) (eq r 'user))
+ (user-login-name))
+ ((and (not given-default) (eq r 'label))
+ (format "%s@%s"
+ (or (auth-source-netrc-element-or-first
+ (auth-source--aget valist 'user))
+ (plist-get artificial :user))
+ (or (auth-source-netrc-element-or-first
+ (auth-source--aget valist 'host))
+ (plist-get artificial :host))))
+ (t given-default)))
+ (printable-defaults (list
+ (cons 'user
+ (or
+ (auth-source-netrc-element-or-first
+ (auth-source--aget valist 'user))
+ (plist-get artificial :user)
+ "[any user]"))
+ (cons 'host
+ (or
+ (auth-source-netrc-element-or-first
+ (auth-source--aget valist 'host))
+ (plist-get artificial :host)
+ "[any host]"))
+ (cons 'port
+ (or
+ (auth-source-netrc-element-or-first
+ (auth-source--aget valist 'port))
+ (plist-get artificial :port)
+ "[any port]"))
+ (cons 'label
+ (or
+ (auth-source-netrc-element-or-first
+ (auth-source--aget valist 'label))
+ (plist-get artificial :label)
+ "[any label]"))))
+ (prompt (or (auth-source--aget auth-source-creation-prompts r)
+ (cl-case r
+ (secret "%p password for %u@%h: ")
+ (user "%p user name for %h: ")
+ (host "%p host name for user %u: ")
+ (port "%p port for %u@%h: ")
+ (label "Enter label for %u@%h: "))
+ (format "Enter %s (%%u@%%h:%%p): " r)))
+ (prompt (auth-source-format-prompt
+ prompt
+ `((?u ,(auth-source--aget printable-defaults 'user))
+ (?h ,(auth-source--aget printable-defaults 'host))
+ (?p ,(auth-source--aget printable-defaults 'port))))))
+
+ ;; Store the data, prompting for the password if needed.
+ (setq data (or data
+ (if (eq r 'secret)
+ (or (eval default) (read-passwd prompt))
+ (if (stringp default)
+ (read-string (if (string-match ": *\\'" prompt)
+ (concat (substring prompt 0 (match-beginning 0))
+ " (default " default "): ")
+ (concat prompt "(default " default ") "))
+ nil nil default)
+ (eval default)))))
+
+ (when data
+ (setq artificial (plist-put artificial
+ (auth-source--symbol-keyword r)
+ (if (eq r 'secret)
+ (let ((data data))
+ (lambda () data))
+ data))))
+
+ ;; When r is not an empty string...
+ (when (and (stringp data)
+ (< 0 (length data))
+ (not (member r '(secret label))))
+ ;; append the key (the symbol name of r)
+ ;; and the value in r
+ (setq args (append args (list (auth-source--symbol-keyword r) data))))))
+
+ (plist-put
+ artificial
+ :save-function
+ (let* ((collection collection)
+ (item (plist-get artificial :label))
+ (secret (plist-get artificial :secret))
+ (secret (if (functionp secret) (funcall secret) secret)))
+ (lambda ()
+ (auth-source-secrets-saver collection item secret args))))
+
+ (list artificial)))
+
+(defun auth-source-secrets-saver (collection item secret args)
+ "Wrapper around `secrets-create-item', prompting along the way.
+Respects `auth-source-save-behavior'."
+ (let ((prompt (format "Save auth info to secrets collection %s? " collection))
+ (done (not (eq auth-source-save-behavior 'ask)))
+ (doit (eq auth-source-save-behavior t))
+ (bufname "*auth-source Help*")
+ k)
+ (while (not done)
+ (setq k (auth-source-read-char-choice prompt '(?y ?n ?N ??)))
+ (cl-case k
+ (?y (setq done t doit t))
+ (?? (save-excursion
+ (with-output-to-temp-buffer bufname
+ (princ
+ (concat "(y)es, save\n"
+ "(n)o but use the info\n"
+ "(N)o and don't ask to save again\n"
+ "(?) for help as you can see.\n"))
+ ;; Why? Doesn't with-output-to-temp-buffer already do
+ ;; the exact same thing anyway? --Stef
+ (set-buffer standard-output)
+ (help-mode))))
+ (?n (setq done t doit nil))
+ (?N (setq done t doit nil)
+ (customize-save-variable 'auth-source-save-behavior nil))
+ (t nil)))
+
+ (when doit
+ (progn
+ (auth-source-do-debug
+ "secrets-create-item: wrote 1 new item to %s" collection)
+ (message "Saved new authentication information to %s" collection)
+ (apply 'secrets-create-item collection item secret args)))))
;;; Backend specific parsing: Mac OS Keychain (using /usr/bin/security) backend
@@ -1970,6 +2166,77 @@ entries for git.gnus.org:
(plstore-get-file (oref backend data))))
(plstore-save (oref backend data)))))
+;;; Backend specific parsing: JSON backend
+;; (auth-source-search :max 1 :machine "imap.gmail.com")
+;; (auth-source-search :max 1 :host '("my-gmail" "imap.gmail.com") :port '(993 "imaps" "imap" "993" "143") :user nil :require '(:user :secret))
+
+(defun auth-source-json-check (host user port require item)
+ (and item
+ (auth-source-search-collection
+ (or host t)
+ (or
+ (plist-get item :machine)
+ (plist-get item :host)
+ t))
+ (auth-source-search-collection
+ (or user t)
+ (or
+ (plist-get item :login)
+ (plist-get item :account)
+ (plist-get item :user)
+ t))
+ (auth-source-search-collection
+ (or port t)
+ (or
+ (plist-get item :port)
+ (plist-get item :protocol)
+ t))
+ (or
+ ;; the required list of keys is nil, or
+ (null require)
+ ;; every element of require is in
+ (cl-loop for req in require
+ always (plist-get item req)))))
+
+(cl-defun auth-source-json-search (&rest spec
+ &key backend require
+ type max host user port
+ &allow-other-keys)
+ "Given a property list SPEC, return search matches from the :backend.
+See `auth-source-search' for details on SPEC."
+ ;; just in case, check that the type is correct (null or same as the backend)
+ (cl-assert (or (null type) (eq type (oref backend type)))
+ t "Invalid JSON search: %s %s")
+
+ ;; Hide the secrets early to avoid accidental exposure.
+ (let* ((jdata
+ (mapcar (lambda (entry)
+ (let (ret)
+ (while entry
+ (let* ((item (pop entry))
+ (k (auth-source--symbol-keyword (car item)))
+ (v (cdr item)))
+ (setq k (cond ((memq k '(:machine)) :host)
+ ((memq k '(:login :account)) :user)
+ ((memq k '(:protocol)) :port)
+ ((memq k '(:password)) :secret)
+ (t k)))
+ ;; send back the secret in a function (lexical binding)
+ (when (eq k :secret)
+ (setq v (let ((lexv v))
+ (lambda () lexv))))
+ (setq ret (plist-put ret k v))))
+ ret))
+ (json-read-file (oref backend source))))
+ (max (or max 5000)) ; sanity check: default to stop at 5K
+ all)
+ (dolist (item jdata)
+ (when (and item
+ (> max (length all))
+ (auth-source-json-check host user port require item))
+ (push item all)))
+ (nreverse all)))
+
;;; older API
;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" t "tzz")
diff --git a/lisp/autoarg.el b/lisp/autoarg.el
index d344d273538..97e9d6be9cc 100644
--- a/lisp/autoarg.el
+++ b/lisp/autoarg.el
@@ -90,9 +90,6 @@
;;;###autoload
(define-minor-mode autoarg-mode
"Toggle Autoarg mode, a global minor mode.
-With a prefix argument ARG, enable Autoarg mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
\\<autoarg-mode-map>
In Autoarg mode, digits are bound to `digit-argument', i.e. they
@@ -116,9 +113,6 @@ then invokes the normal binding of \\[autoarg-terminate].
;;;###autoload
(define-minor-mode autoarg-kp-mode
"Toggle Autoarg-KP mode, a global minor mode.
-With a prefix argument ARG, enable Autoarg-KP mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
\\<autoarg-kp-mode-map>
This is similar to `autoarg-mode' but rebinds the keypad keys
diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el
index 1e606dde208..f7ecfe27bb1 100644
--- a/lisp/autoinsert.el
+++ b/lisp/autoinsert.el
@@ -141,14 +141,14 @@ If this contains a %s, that will be replaced by the matching rule."
"
.\\\" You may distribute this file under the terms of the GNU Free
.\\\" Documentation License.
-.TH " (file-name-base)
+.TH " (file-name-base (buffer-file-name))
" " (file-name-extension (buffer-file-name))
" " (format-time-string "%Y-%m-%d ")
"\n.SH NAME\n"
- (file-name-base)
+ (file-name-base (buffer-file-name))
" \\- " str
"\n.SH SYNOPSIS
-.B " (file-name-base)
+.B " (file-name-base (buffer-file-name))
"\n"
_
"
@@ -211,7 +211,7 @@ If this contains a %s, that will be replaced by the matching rule."
\(provide '"
- (file-name-base)
+ (file-name-base (buffer-file-name))
")
\;;; " (file-name-nondirectory (buffer-file-name)) " ends here\n")
(("\\.texi\\(nfo\\)?\\'" . "Texinfo file skeleton")
@@ -219,7 +219,7 @@ If this contains a %s, that will be replaced by the matching rule."
"\\input texinfo @c -*-texinfo-*-
@c %**start of header
@setfilename "
- (file-name-base) ".info\n"
+ (file-name-base (buffer-file-name)) ".info\n"
"@settitle " str "
@c %**end of header
@copying\n"
@@ -412,9 +412,6 @@ or if CONDITION had no actions, after all other CONDITIONs."
;;;###autoload
(define-minor-mode auto-insert-mode
"Toggle Auto-insert mode, a global minor mode.
-With a prefix argument ARG, enable Auto-insert mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
When Auto-insert mode is enabled, when new files are created you can
insert a template for the file depending on the mode of the buffer."
diff --git a/lisp/autorevert.el b/lisp/autorevert.el
index 58c5dba3160..4fb865e8adb 100644
--- a/lisp/autorevert.el
+++ b/lisp/autorevert.el
@@ -321,7 +321,7 @@ the list of old buffers.")
(defun auto-revert-find-file-function ()
(setq-local auto-revert-tail-pos
- (nth 7 (file-attributes buffer-file-name))))
+ (file-attribute-size (file-attributes buffer-file-name))))
(add-hook 'find-file-hook
#'auto-revert-find-file-function)
@@ -343,17 +343,15 @@ This has been reported by a file notification event.")
;; Functions:
-(defun auto-revert-remove-current-buffer ()
- "Remove dead buffer from `auto-revert-buffer-list'."
+(defun auto-revert-remove-current-buffer (&optional buffer)
+ "Remove BUFFER from `auto-revert-buffer-list'.
+BUFFER defaults to `current-buffer'."
(setq auto-revert-buffer-list
- (delq (current-buffer) auto-revert-buffer-list)))
+ (delq (or buffer (current-buffer)) auto-revert-buffer-list)))
;;;###autoload
(define-minor-mode auto-revert-mode
"Toggle reverting buffer when the file changes (Auto-Revert Mode).
-With a prefix argument ARG, enable Auto-Revert Mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Auto-Revert Mode is a minor mode that affects only the current
buffer. When enabled, it reverts the buffer when the file on
@@ -373,7 +371,7 @@ without being changed in the part that is already in the buffer."
'kill-buffer-hook
#'auto-revert-remove-current-buffer
nil t))
- (when auto-revert-use-notify (auto-revert-notify-rm-watch))
+ (when auto-revert-notify-watch-descriptor (auto-revert-notify-rm-watch))
(auto-revert-remove-current-buffer))
(auto-revert-set-timer)
(when auto-revert-mode
@@ -393,9 +391,6 @@ This function is designed to be added to hooks, for example:
;;;###autoload
(define-minor-mode auto-revert-tail-mode
"Toggle reverting tail of buffer when the file grows.
-With a prefix argument ARG, enable Auto-Revert Tail Mode if ARG
-is positive, and disable it otherwise. If called from Lisp,
-enable the mode if ARG is omitted or nil.
When Auto-Revert Tail Mode is enabled, the tail of the file is
constantly followed, as with the shell command `tail -f'. This
@@ -440,7 +435,8 @@ Perform a full revert? ")
(add-hook 'before-save-hook (lambda () (auto-revert-tail-mode 0)) nil t)
(or (local-variable-p 'auto-revert-tail-pos) ; don't lose prior position
(setq-local auto-revert-tail-pos
- (nth 7 (file-attributes buffer-file-name))))
+ (file-attribute-size
+ (file-attributes buffer-file-name))))
;; let auto-revert-mode set up the mechanism for us if it isn't already
(or auto-revert-mode
(let ((auto-revert-tail-mode t))
@@ -460,9 +456,6 @@ This function is designed to be added to hooks, for example:
;;;###autoload
(define-minor-mode global-auto-revert-mode
"Toggle Global Auto-Revert Mode.
-With a prefix argument ARG, enable Global Auto-Revert Mode if ARG
-is positive, and disable it otherwise. If called from Lisp,
-enable the mode if ARG is omitted or nil.
Global Auto-Revert Mode is a global minor mode that reverts any
buffer associated with a file when the file changes on disk. Use
@@ -486,7 +479,7 @@ specifies in the mode line."
(auto-revert-buffers)
(dolist (buf (buffer-list))
(with-current-buffer buf
- (when auto-revert-use-notify
+ (when auto-revert-notify-watch-descriptor
(auto-revert-notify-rm-watch))))))
(defun auto-revert-set-timer ()
@@ -517,45 +510,50 @@ will use an up-to-date value of `auto-revert-interval'"
(ignore-errors
(file-notify-rm-watch auto-revert-notify-watch-descriptor)))))
auto-revert-notify-watch-descriptor-hash-list)
- (remove-hook 'kill-buffer-hook #'auto-revert-notify-rm-watch))
+ (remove-hook 'kill-buffer-hook #'auto-revert-notify-rm-watch t))
(setq auto-revert-notify-watch-descriptor nil
auto-revert-notify-modified-p nil))
(defun auto-revert-notify-add-watch ()
"Enable file notification for current buffer's associated file."
- ;; We can assume that `buffer-file-name' and
- ;; `auto-revert-use-notify' are non-nil.
- (if (or (string-match auto-revert-notify-exclude-dir-regexp
- (expand-file-name default-directory))
- (file-symlink-p (or buffer-file-name default-directory)))
-
- ;; Fallback to file checks.
- (setq-local auto-revert-use-notify nil)
-
- (when (not auto-revert-notify-watch-descriptor)
- (setq auto-revert-notify-watch-descriptor
- (ignore-errors
- (if buffer-file-name
- (file-notify-add-watch
- (expand-file-name buffer-file-name default-directory)
- '(change attribute-change)
- 'auto-revert-notify-handler)
+ ;; We can assume that `auto-revert-notify-watch-descriptor' is nil.
+ (unless (or auto-revert-notify-watch-descriptor
+ (string-match auto-revert-notify-exclude-dir-regexp
+ (expand-file-name default-directory))
+ (file-symlink-p (or buffer-file-name default-directory)))
+ ;; Check, whether this has been activated already.
+ (let ((file (if buffer-file-name
+ (expand-file-name buffer-file-name default-directory)
+ (expand-file-name default-directory))))
+ (maphash
+ (lambda (key _value)
+ (when (and
+ (file-notify-valid-p key)
+ (equal (file-notify--watch-absolute-filename
+ (gethash key file-notify-descriptors))
+ (directory-file-name file))
+ (equal (file-notify--watch-callback
+ (gethash key file-notify-descriptors))
+ 'auto-revert-notify-handler))
+ (setq auto-revert-notify-watch-descriptor key)))
+ auto-revert-notify-watch-descriptor-hash-list)
+ ;; Create a new watch if needed.
+ (unless auto-revert-notify-watch-descriptor
+ (setq auto-revert-notify-watch-descriptor
+ (ignore-errors
(file-notify-add-watch
- (expand-file-name default-directory)
- '(change)
- 'auto-revert-notify-handler))))
- (if auto-revert-notify-watch-descriptor
- (progn
- (puthash
- auto-revert-notify-watch-descriptor
- (cons (current-buffer)
- (gethash auto-revert-notify-watch-descriptor
- auto-revert-notify-watch-descriptor-hash-list))
- auto-revert-notify-watch-descriptor-hash-list)
- (add-hook 'kill-buffer-hook
- #'auto-revert-notify-rm-watch nil t))
- ;; Fallback to file checks.
- (setq-local auto-revert-use-notify nil)))))
+ file
+ (if buffer-file-name '(change attribute-change) '(change))
+ 'auto-revert-notify-handler))))
+ (when auto-revert-notify-watch-descriptor
+ (setq auto-revert-notify-modified-p t)
+ (puthash
+ auto-revert-notify-watch-descriptor
+ (cons (current-buffer)
+ (gethash auto-revert-notify-watch-descriptor
+ auto-revert-notify-watch-descriptor-hash-list))
+ auto-revert-notify-watch-descriptor-hash-list)
+ (add-hook 'kill-buffer-hook #'auto-revert-notify-rm-watch nil t)))))
;; If we have file notifications, we want to update the auto-revert buffers
;; immediately when a notification occurs. Since file updates can happen very
@@ -611,8 +609,7 @@ no more reverts are possible until the next call of
(file-name-nondirectory buffer-file-name)))
;; A buffer w/o a file, like dired.
(null buffer-file-name)))
- (auto-revert-notify-rm-watch)
- (setq-local auto-revert-use-notify nil))))
+ (auto-revert-notify-rm-watch))))
;; Loop over all buffers, in order to find the intended one.
(cl-dolist (buffer buffers)
@@ -642,20 +639,15 @@ no more reverts are possible until the next call of
auto-revert-buffers-counter)
(auto-revert-handler)
(setq auto-revert-buffers-counter-lockedout
- auto-revert-buffers-counter))
-
- ;; No need to check other buffers.
- (cl-return)))))))))
+ auto-revert-buffers-counter))))))))))
(defun auto-revert-active-p ()
"Check if auto-revert is active (in current buffer or globally)."
(or auto-revert-mode
auto-revert-tail-mode
- (and
- global-auto-revert-mode
- (not global-auto-revert-ignore-buffer)
- (not (memq major-mode
- global-auto-revert-ignore-modes)))))
+ (and global-auto-revert-mode
+ (not global-auto-revert-ignore-buffer)
+ (not (memq major-mode global-auto-revert-ignore-modes)))))
(defun auto-revert-handler ()
"Revert current buffer, if appropriate.
@@ -669,14 +661,14 @@ This is an internal function used by Auto-Revert Mode."
(if buffer-file-name
(and (or auto-revert-remote-files
(not (file-remote-p buffer-file-name)))
- (or (not auto-revert-use-notify)
+ (or (not auto-revert-notify-watch-descriptor)
auto-revert-notify-modified-p)
(if auto-revert-tail-mode
(and (file-readable-p buffer-file-name)
(/= auto-revert-tail-pos
(setq size
- (nth 7 (file-attributes
- buffer-file-name)))))
+ (file-attribute-size
+ (file-attributes buffer-file-name)))))
(funcall (or buffer-stale-function
#'buffer-stale--default-function)
t)))
@@ -719,7 +711,8 @@ This is an internal function used by Auto-Revert Mode."
;; `preserve-modes' avoids changing the (minor) modes. But we do
;; want to reset the mode for VC, so we do it manually.
(when (or revert auto-revert-check-vc-info)
- (vc-refresh-state))))
+ (let ((revert-buffer-in-progress-p t))
+ (vc-refresh-state)))))
(defun auto-revert-tail-handler (size)
(let ((modified (buffer-modified-p))
@@ -775,6 +768,18 @@ the timer when no buffers need to be checked."
(buffer-list)
auto-revert-buffer-list))
remaining new)
+ ;; Buffers with remote contents shall be reverted only if the
+ ;; connection is established already.
+ (setq bufs (delq nil
+ (mapcar
+ (lambda (buf)
+ (and (buffer-live-p buf)
+ (with-current-buffer buf
+ (and
+ (or (not (file-remote-p default-directory))
+ (file-remote-p default-directory nil t))
+ buf))))
+ bufs)))
;; Partition `bufs' into two halves depending on whether or not
;; the buffers are in `auto-revert-remaining-buffers'. The two
;; halves are then re-joined with the "remaining" buffers at the
@@ -790,24 +795,23 @@ the timer when no buffers need to be checked."
(not (and auto-revert-stop-on-user-input
(input-pending-p))))
(let ((buf (car bufs)))
- (with-current-buffer buf
- (if (buffer-live-p buf)
- (progn
- ;; Test if someone has turned off Auto-Revert Mode
- ;; in a non-standard way, for example by changing
- ;; major mode.
- (if (and (not auto-revert-mode)
- (not auto-revert-tail-mode)
- (memq buf auto-revert-buffer-list))
- (auto-revert-remove-current-buffer))
- (when (auto-revert-active-p)
- ;; Enable file notification.
- (when (and auto-revert-use-notify
- (not auto-revert-notify-watch-descriptor))
- (auto-revert-notify-add-watch))
- (auto-revert-handler)))
+ (if (not (buffer-live-p buf))
;; Remove dead buffer from `auto-revert-buffer-list'.
- (auto-revert-remove-current-buffer))))
+ (auto-revert-remove-current-buffer buf)
+ (with-current-buffer buf
+ ;; Test if someone has turned off Auto-Revert Mode
+ ;; in a non-standard way, for example by changing
+ ;; major mode.
+ (if (and (not auto-revert-mode)
+ (not auto-revert-tail-mode)
+ (memq buf auto-revert-buffer-list))
+ (auto-revert-remove-current-buffer))
+ (when (auto-revert-active-p)
+ ;; Enable file notification.
+ (when (and auto-revert-use-notify
+ (not auto-revert-notify-watch-descriptor))
+ (auto-revert-notify-add-watch))
+ (auto-revert-handler)))))
(setq bufs (cdr bufs)))
(setq auto-revert-remaining-buffers bufs)
;; Check if we should cancel the timer.
diff --git a/lisp/avoid.el b/lisp/avoid.el
index 0ad1b0ba535..7d69fa2a247 100644
--- a/lisp/avoid.el
+++ b/lisp/avoid.el
@@ -205,8 +205,8 @@ If you want the mouse banished to a different corner set
'frame-or-window
mouse-avoidance-banish-position 'eq))
(list-values (pcase fra-or-win
- (`frame (list 0 0 (frame-width) (frame-height)))
- (`window (window-edges))))
+ ('frame (list 0 0 (frame-width) (frame-height)))
+ ('window (window-edges))))
(alist (cl-loop for v in list-values
for k in '(left top right bottom)
collect (cons k v)))
@@ -223,11 +223,11 @@ If you want the mouse banished to a different corner set
'top-or-bottom-pos
mouse-avoidance-banish-position #'eq))
(side-fn (pcase side
- (`left '+)
- (`right '-)))
+ ('left '+)
+ ('right '-)))
(top-or-bottom-fn (pcase top-or-bottom
- (`top '+)
- (`bottom '-))))
+ ('top '+)
+ ('bottom '-))))
(cons (funcall side-fn ; -/+
(assoc-default side alist 'eq) ; right or left
side-dist) ; distance from side
diff --git a/lisp/battery.el b/lisp/battery.el
index e23dab4c91a..49b01d5b54b 100644
--- a/lisp/battery.el
+++ b/lisp/battery.el
@@ -175,9 +175,6 @@ The text being displayed in the echo area is controlled by the variables
;;;###autoload
(define-minor-mode display-battery-mode
"Toggle battery status display in mode line (Display Battery mode).
-With a prefix argument ARG, enable Display Battery mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
The text displayed in the mode line is controlled by
`battery-mode-line-format' and `battery-status-function'.
@@ -378,12 +375,12 @@ The following %-sequences are provided:
last-full-capacity design-capacity))
(and capacity rate
(setq minutes (if (zerop rate) 0
- (floor (* (/ (float (if (string= charging-state
- "charging")
- (- full-capacity capacity)
- capacity))
- rate)
- 60)))
+ (floor (* (if (string= charging-state
+ "charging")
+ (- full-capacity capacity)
+ capacity)
+ 60)
+ rate))
hours (/ minutes 60)))
(list (cons ?c (or (and capacity (number-to-string capacity)) "N/A"))
(cons ?L (or (battery-search-for-one-match-in-files
@@ -417,8 +414,7 @@ The following %-sequences are provided:
(cons ?p (or (and full-capacity capacity
(> full-capacity 0)
(number-to-string
- (floor (/ capacity
- (/ (float full-capacity) 100)))))
+ (floor (* 100 capacity) full-capacity)))
"N/A")))))
@@ -474,9 +470,9 @@ The following %-sequences are provided:
"POWER_SUPPLY_\\(CURRENT\\|POWER\\)_NOW=\\([0-9]*\\)$"
nil t)
(cl-incf power-now
- (* (float (string-to-number (match-string 2)))
+ (* (string-to-number (match-string 2))
(if (eq (char-after (match-beginning 1)) ?C)
- voltage-now 1.0))))
+ voltage-now 1))))
(goto-char (point-min))
(when (re-search-forward "POWER_SUPPLY_TEMP=\\([0-9]*\\)$" nil t)
(setq temperature (match-string 1)))
@@ -588,9 +584,7 @@ The following %-sequences are provided:
(when seconds
(setq minutes (/ seconds 60)
hours (/ minutes 60)
- remaining-time
- (format "%d:%02d" (truncate hours)
- (- (truncate minutes) (* 60 (truncate hours))))))
+ remaining-time (format "%d:%02d" hours (mod minutes 60))))
(list (cons ?c (or (and energy
(number-to-string (round (* 1000 energy))))
"N/A"))
@@ -623,46 +617,71 @@ The following %-sequences are provided:
%h Remaining battery charge time in hours
%t Remaining battery charge time in the form `h:min'"
(let* ((os-name (car (split-string
- (shell-command-to-string "/usr/bin/uname"))))
- (apm-flag (if (equal os-name "OpenBSD") "P" "s"))
- (apm-cmd (concat "/usr/sbin/apm -ablm" apm-flag))
- (apm-output (split-string (shell-command-to-string apm-cmd)))
- ;; Battery status
- (battery-status
- (let ((stat (string-to-number (nth 0 apm-output))))
- (cond ((eq stat 0) '("high" . ""))
- ((eq stat 1) '("low" . "-"))
- ((eq stat 2) '("critical" . "!"))
- ((eq stat 3) '("charging" . "+"))
- ((eq stat 4) '("absent" . nil)))))
- ;; Battery percentage
- (battery-percentage (nth 1 apm-output))
- ;; Battery life
- (battery-life (nth 2 apm-output))
- ;; AC status
- (line-status
- (let ((ac (string-to-number (nth 3 apm-output))))
- (cond ((eq ac 0) "disconnected")
- ((eq ac 1) "connected")
- ((eq ac 2) "backup power"))))
- ;; Advanced power savings mode
- (apm-mode
- (let ((apm (string-to-number (nth 4 apm-output))))
- (if (string= os-name "OpenBSD")
- (cond ((eq apm 0) "manual")
- ((eq apm 1) "automatic")
- ((eq apm 2) "cool running"))
- (if (eq apm 1) "on" "off"))))
+ ;; FIXME: Can't we use something like `system-type'?
+ (shell-command-to-string "/usr/bin/uname"))))
+ (apm-flag (pcase os-name
+ ("OpenBSD" "mP")
+ ("FreeBSD" "st")
+ (_ "ms")))
+ (apm-cmd (concat "/usr/sbin/apm -abl" apm-flag))
+ (apm-output (split-string (shell-command-to-string apm-cmd)))
+ (indices (pcase os-name
+ ;; FreeBSD's manpage documents that multiple
+ ;; outputs are ordered by "the order in which
+ ;; they're listed in the manpage", which is alphabetical
+ ;; and is also the order in which we pass them.
+ ("FreeBSD" '((ac . 0)
+ (battery-status . 1)
+ (battery-percent . 2)
+ (apm-mode . 3)
+ (battery-life . 4)))
+ ;; For NetBSD and OpenBSD, the manpage doesn't document
+ ;; the order. The previous code used this order, so let's
+ ;; assume it's right.
+ (_ '((ac . 3)
+ (battery-status . 0)
+ (battery-percent . 1)
+ (apm-mode . 4)
+ (battery-life . 2)))))
+ ;; Battery status
+ (battery-status
+ (pcase (string-to-number
+ (nth (alist-get 'battery-status indices) apm-output))
+ (0 '("high" . ""))
+ (1 '("low" . "-"))
+ (2 '("critical" . "!"))
+ (3 '("charging" . "+"))
+ (4 '("absent" . nil))))
+ ;; Battery percentage
+ (battery-percentage
+ (nth (alist-get 'battery-percent indices) apm-output))
+ ;; Battery life
+ (battery-life (nth (alist-get 'battery-life indices) apm-output))
+ ;; AC status
+ (line-status
+ (pcase (string-to-number (nth (alist-get 'ac indices) apm-output))
+ (0 "disconnected")
+ (1 "connected")
+ (2 "backup power")))
+ ;; Advanced power savings mode
+ (apm-mode
+ (let ((apm (string-to-number
+ (nth (alist-get 'apm-mode indices) apm-output))))
+ (if (string= os-name "OpenBSD")
+ (pcase apm
+ (0 "manual")
+ (1 "automatic")
+ (2 "cool running"))
+ (if (eql apm 1) "on" "off"))))
seconds minutes hours remaining-time)
(unless (member battery-life '("unknown" "-1"))
(if (member os-name '("OpenBSD" "NetBSD"))
(setq minutes (string-to-number battery-life)
seconds (* 60 minutes))
(setq seconds (string-to-number battery-life)
- minutes (truncate (/ seconds 60))))
- (setq hours (truncate (/ minutes 60))
- remaining-time (format "%d:%02d" hours
- (- minutes (* 60 hours)))))
+ minutes (truncate seconds 60)))
+ (setq hours (truncate minutes 60)
+ remaining-time (format "%d:%02d" hours (mod minutes 60))))
(list (cons ?L (or line-status "N/A"))
(cons ?B (or (car battery-status) "N/A"))
(cons ?b (or (cdr battery-status) "N/A"))
diff --git a/lisp/bindings.el b/lisp/bindings.el
index 210cf59e4f7..744bcc36a85 100644
--- a/lisp/bindings.el
+++ b/lisp/bindings.el
@@ -124,17 +124,61 @@ corresponding to the mode line clicked."
;;; Mode line contents
-(defcustom mode-line-default-help-echo
- "mouse-1: Select (drag to resize)\n\
-mouse-2: Make current window occupy the whole frame\n\
-mouse-3: Remove current window from display"
+(defun mode-line-default-help-echo (window)
+ "Return default help echo text for WINDOW's mode line."
+ (let* ((frame (window-frame window))
+ (line-1a
+ ;; Show text to select window only if the window is not
+ ;; selected.
+ (not (eq window (frame-selected-window frame))))
+ (line-1b
+ ;; Show text to drag mode line if either the window is not
+ ;; at the bottom of its frame or the minibuffer window of
+ ;; this frame can be resized. This matches a corresponding
+ ;; check in `mouse-drag-mode-line'.
+ (or (not (window-at-side-p window 'bottom))
+ (let ((mini-window (minibuffer-window frame)))
+ (and (eq frame (window-frame mini-window))
+ (or (minibuffer-window-active-p mini-window)
+ (not resize-mini-windows))))))
+ (line-2
+ ;; Show text make window occupy the whole frame
+ ;; only if it doesn't already do that.
+ (not (eq window (frame-root-window frame))))
+ (line-3
+ ;; Show text to delete window only if that's possible.
+ (not (eq window (frame-root-window frame)))))
+ (when (or line-1a line-1b line-2 line-3)
+ (concat
+ (when (or line-1a line-1b)
+ (concat
+ "mouse-1: "
+ (when line-1a "Select window")
+ (when line-1b
+ (if line-1a " (drag to resize)" "Drag to resize"))
+ (when (or line-2 line-3) "\n")))
+ (when line-2
+ (concat
+ "mouse-2: Make window occupy whole frame"
+ (when line-3 "\n")))
+ (when line-3
+ "mouse-3: Remove window from frame")))))
+
+(defcustom mode-line-default-help-echo #'mode-line-default-help-echo
"Default help text for the mode line.
If the value is a string, it specifies the tooltip or echo area
message to display when the mouse is moved over the mode line.
-If the text at the mouse position has a `help-echo' text
-property, that overrides this variable."
- :type '(choice (const :tag "No help" :value nil) string)
- :version "24.3"
+If the value is a function, call that function with one argument
+- the window whose mode line to display. If the text at the
+mouse position has a `help-echo' text property, that overrides
+this variable."
+ :type '(choice
+ (const :tag "No help" :value nil)
+ function
+ (string :value "mouse-1: Select (drag to resize)\n\
+mouse-2: Make current window occupy the whole frame\n\
+mouse-3: Remove current window from display"))
+ :version "27.1"
:group 'mode-line)
(defvar mode-line-front-space '(:eval (if (display-graphic-p) " " "-"))
@@ -373,7 +417,7 @@ zero, otherwise they start from one."
This option specifies both the field width and the type of offset
displayed in `mode-line-position', a component of the default
`mode-line-format'."
- :type `(radio
+ :type '(radio
(const :tag "nil: No offset is displayed" nil)
(const :tag "\"%o\": Proportion of \"travel\" of the window through the buffer"
(-3 "%o"))
@@ -680,11 +724,11 @@ okay. See `mode-line-format'.")
;; FIXME: Maybe beginning-of-line, beginning-of-buffer, end-of-line,
;; end-of-buffer, end-of-file, buffer-read-only, and
;; file-supersession should all be user-errors!
- `(beginning-of-line beginning-of-buffer end-of-line
- end-of-buffer end-of-file buffer-read-only
- file-supersession mark-inactive
- user-error ;; That's the main one!
- ))
+ '(beginning-of-line beginning-of-buffer end-of-line
+ end-of-buffer end-of-file buffer-read-only
+ file-supersession mark-inactive
+ user-error ;; That's the main one!
+ ))
(make-variable-buffer-local 'indent-tabs-mode)
@@ -702,7 +746,7 @@ okay. See `mode-line-format'.")
buffer-file-format buffer-auto-save-file-format
buffer-display-count buffer-display-time
enable-multibyte-characters
- buffer-file-coding-system))
+ buffer-file-coding-system truncate-lines))
;; We have base64, md5 and sha1 functions built in now.
(provide 'base64)
@@ -985,6 +1029,13 @@ if `inhibit-field-text-motion' is non-nil."
(define-key search-map "hu" 'unhighlight-regexp)
(define-key search-map "hf" 'hi-lock-find-patterns)
(define-key search-map "hw" 'hi-lock-write-interactive-patterns)
+(put 'highlight-regexp :advertised-binding [?\M-s ?h ?r])
+(put 'highlight-phrase :advertised-binding [?\M-s ?h ?p])
+(put 'highlight-lines-matching-regexp :advertised-binding [?\M-s ?h ?l])
+(put 'highlight-symbol-at-point :advertised-binding [?\M-s ?h ?.])
+(put 'unhighlight-regexp :advertised-binding [?\M-s ?h ?u])
+(put 'hi-lock-find-patterns :advertised-binding [?\M-s ?h ?f])
+(put 'hi-lock-write-interactive-patterns :advertised-binding [?\M-s ?h ?w])
;;(defun function-key-error ()
;; (interactive)
diff --git a/lisp/bookmark.el b/lisp/bookmark.el
index a2a712348de..3041401e175 100644
--- a/lisp/bookmark.el
+++ b/lisp/bookmark.el
@@ -209,6 +209,7 @@ A non-nil value may result in truncated bookmark names."
(define-key map "j" 'bookmark-jump)
(define-key map "g" 'bookmark-jump) ;"g"o
(define-key map "o" 'bookmark-jump-other-window)
+ (define-key map "5" 'bookmark-jump-other-frame)
(define-key map "i" 'bookmark-insert)
(define-key map "e" 'edit-bookmarks)
(define-key map "f" 'bookmark-insert-location) ;"f"ind
@@ -734,7 +735,7 @@ CODING is the symbol of the coding-system in which the file is encoded."
(if (memq (coding-system-base coding) '(undecided prefer-utf-8))
(setq coding 'utf-8-emacs))
(insert
- (format ";;;; Emacs Bookmark Format Version %d ;;;; -*- coding: %S -*- \n"
+ (format ";;;; Emacs Bookmark Format Version %d ;;;; -*- coding: %S -*-\n"
bookmark-file-format-version (coding-system-base coding)))
(insert ";;; This format is meant to be slightly human-readable;\n"
";;; nevertheless, you probably don't want to edit it.\n"
@@ -1124,6 +1125,14 @@ DISPLAY-FUNC would be `switch-to-buffer-other-window'."
bookmark-current-bookmark)))
(bookmark-jump bookmark 'switch-to-buffer-other-window))
+;;;###autoload
+(defun bookmark-jump-other-frame (bookmark)
+ "Jump to BOOKMARK in another frame. See `bookmark-jump' for more."
+ (interactive
+ (list (bookmark-completing-read "Jump to bookmark (in another frame)"
+ bookmark-current-bookmark)))
+ (let ((pop-up-frames t))
+ (bookmark-jump-other-window bookmark)))
(defun bookmark-jump-noselect (bookmark)
"Return the location pointed to by BOOKMARK (see `bookmark-jump').
@@ -1561,6 +1570,7 @@ unique numeric suffixes \"<2>\", \"<3>\", etc."
(set-keymap-parent map special-mode-map)
(define-key map "v" 'bookmark-bmenu-select)
(define-key map "w" 'bookmark-bmenu-locate)
+ (define-key map "5" 'bookmark-bmenu-other-frame)
(define-key map "2" 'bookmark-bmenu-2-window)
(define-key map "1" 'bookmark-bmenu-1-window)
(define-key map "j" 'bookmark-bmenu-this-window)
@@ -1702,6 +1712,7 @@ Bookmark names preceded by a \"*\" have annotations.
\\[bookmark-bmenu-this-window] -- select this bookmark in place of the bookmark menu buffer.
\\[bookmark-bmenu-other-window] -- select this bookmark in another window,
so the bookmark menu bookmark remains visible in its window.
+\\[bookmark-bmenu-other-frame] -- select this bookmark in another frame.
\\[bookmark-bmenu-switch-other-window] -- switch the other window to this bookmark.
\\[bookmark-bmenu-rename] -- rename this bookmark (prompts for new name).
\\[bookmark-bmenu-relocate] -- relocate this bookmark's file (prompts for new file).
@@ -1971,6 +1982,13 @@ With a prefix arg, prompts for a file to save them in."
(bookmark--jump-via bookmark 'switch-to-buffer-other-window)))
+(defun bookmark-bmenu-other-frame ()
+ "Select this line's bookmark in other frame."
+ (interactive)
+ (let ((bookmark (bookmark-bmenu-bookmark))
+ (pop-up-frames t))
+ (bookmark-jump-other-window bookmark)))
+
(defun bookmark-bmenu-switch-other-window ()
"Make the other window select this line's bookmark.
The current window remains selected."
@@ -2254,8 +2272,6 @@ strings returned are not."
"Hook run at the end of loading library `bookmark.el'.")
;; Exit Hook, called from kill-emacs-hook
-(define-obsolete-variable-alias 'bookmark-exit-hooks
- 'bookmark-exit-hook "22.1")
(defvar bookmark-exit-hook nil
"Hook run when Emacs exits.")
diff --git a/lisp/bs.el b/lisp/bs.el
index 06ba0042ab7..86a19fddcc3 100644
--- a/lisp/bs.el
+++ b/lisp/bs.el
@@ -828,8 +828,8 @@ See `visit-tags-table'."
(let ((res
(with-current-buffer (bs--current-buffer)
(setq bs-buffer-show-mark (pcase bs-buffer-show-mark
- (`nil 'never)
- (`never 'always)
+ ('nil 'never)
+ ('never 'always)
(_ nil))))))
(bs--update-current-line)
(bs--set-window-height)
diff --git a/lisp/button.el b/lisp/button.el
index c46f3d9a52b..921e84dfa68 100644
--- a/lisp/button.el
+++ b/lisp/button.el
@@ -382,10 +382,12 @@ Also see `make-text-button'."
If the button at POS is a text property button, the return value
is a marker pointing to POS."
(let ((button (get-char-property pos 'button)))
- (if (or (overlayp button) (null button))
- button
- ;; Must be a text-property button; return a marker pointing to it.
- (copy-marker pos t))))
+ (and button (get-char-property pos 'category)
+ (if (overlayp button)
+ button
+ ;; Must be a text-property button;
+ ;; return a marker pointing to it.
+ (copy-marker pos t)))))
(defun next-button (pos &optional count-current)
"Return the next button after position POS in the current buffer.
diff --git a/lisp/calc/calc-alg.el b/lisp/calc/calc-alg.el
index 8e3476d191e..41ffc83d86f 100644
--- a/lisp/calc/calc-alg.el
+++ b/lisp/calc/calc-alg.el
@@ -1,4 +1,4 @@
-;;; calc-alg.el --- algebraic functions for Calc
+;;; calc-alg.el --- algebraic functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2019 Free Software Foundation, Inc.
@@ -308,7 +308,7 @@
(let ((math-living-dangerously t))
(math-simplify a)))
-(defalias 'calcFunc-esimplify 'math-simplify-extended)
+(defalias 'calcFunc-esimplify #'math-simplify-extended)
;;; Rewrite the trig functions in a form easier to simplify.
(defun math-trig-rewrite (fn)
@@ -329,7 +329,7 @@
(list '/ (cons 'calcFunc-cos newfn)
(cons 'calcFunc-sin newfn))))
(t
- (mapcar 'math-trig-rewrite fn))))
+ (mapcar #'math-trig-rewrite fn))))
(defun math-hyperbolic-trig-rewrite (fn)
"Rewrite hyperbolic functions in terms of sinhs and coshs."
@@ -349,7 +349,7 @@
(list '/ (cons 'calcFunc-cosh newfn)
(cons 'calcFunc-sinh newfn))))
(t
- (mapcar 'math-hyperbolic-trig-rewrite fn))))
+ (mapcar #'math-hyperbolic-trig-rewrite fn))))
;; math-top-only is local to math-simplify, but is used by
;; math-simplify-step, which is called by math-simplify.
@@ -402,11 +402,11 @@
(setq top-expr res)))))
top-expr)
-(defalias 'calcFunc-simplify 'math-simplify)
+(defalias 'calcFunc-simplify #'math-simplify)
-;;; The following has a "bug" in that if any recursive simplifications
-;;; occur only the first handler will be tried; this doesn't really
-;;; matter, since math-simplify-step is iterated to a fixed point anyway.
+;; The following has a "bug" in that if any recursive simplifications
+;; occur only the first handler will be tried; this doesn't really
+;; matter, since math-simplify-step is iterated to a fixed point anyway.
(defun math-simplify-step (a)
(if (Math-primp a)
a
@@ -414,7 +414,7 @@
(memq (car a) '(calcFunc-quote calcFunc-condition
calcFunc-evalto)))
a
- (cons (car a) (mapcar 'math-simplify-step (cdr a))))))
+ (cons (car a) (mapcar #'math-simplify-step (cdr a))))))
(and (symbolp (car aa))
(let ((handler (get (car aa) 'math-simplify)))
(and handler
@@ -427,159 +427,155 @@
(defmacro math-defsimplify (funcs &rest code)
+ "Define the simplification code for functions FUNCS.
+Code can refer to the expression to simplify via lexical variable `expr'
+and should return the simplified expression to use (or nil)."
+ (declare (indent 1) (debug (sexp body)))
(cons 'progn
(mapcar #'(lambda (func)
`(put ',func 'math-simplify
(nconc
(get ',func 'math-simplify)
(list
- #'(lambda (math-simplify-expr) ,@code)))))
+ #'(lambda (expr) ,@code)))))
(if (symbolp funcs) (list funcs) funcs))))
-(put 'math-defsimplify 'lisp-indent-hook 1)
-
-;; The function created by math-defsimplify uses the variable
-;; math-simplify-expr, and so is used by functions in math-defsimplify
-(defvar math-simplify-expr)
(math-defsimplify (+ -)
- (math-simplify-plus))
-
-(defun math-simplify-plus ()
- (cond ((and (memq (car-safe (nth 1 math-simplify-expr)) '(+ -))
- (Math-numberp (nth 2 (nth 1 math-simplify-expr)))
- (not (Math-numberp (nth 2 math-simplify-expr))))
- (let ((x (nth 2 math-simplify-expr))
- (op (car math-simplify-expr)))
- (setcar (cdr (cdr math-simplify-expr)) (nth 2 (nth 1 math-simplify-expr)))
- (setcar math-simplify-expr (car (nth 1 math-simplify-expr)))
- (setcar (cdr (cdr (nth 1 math-simplify-expr))) x)
- (setcar (nth 1 math-simplify-expr) op)))
- ((and (eq (car math-simplify-expr) '+)
- (Math-numberp (nth 1 math-simplify-expr))
- (not (Math-numberp (nth 2 math-simplify-expr))))
- (let ((x (nth 2 math-simplify-expr)))
- (setcar (cdr (cdr math-simplify-expr)) (nth 1 math-simplify-expr))
- (setcar (cdr math-simplify-expr) x))))
- (let ((aa math-simplify-expr)
+ (cond ((and (memq (car-safe (nth 1 expr)) '(+ -))
+ (Math-numberp (nth 2 (nth 1 expr)))
+ (not (Math-numberp (nth 2 expr))))
+ (let ((x (nth 2 expr))
+ (op (car expr)))
+ (setcar (cdr (cdr expr)) (nth 2 (nth 1 expr)))
+ (setcar expr (car (nth 1 expr)))
+ (setcar (cdr (cdr (nth 1 expr))) x)
+ (setcar (nth 1 expr) op)))
+ ((and (eq (car expr) '+)
+ (Math-numberp (nth 1 expr))
+ (not (Math-numberp (nth 2 expr))))
+ (let ((x (nth 2 expr)))
+ (setcar (cdr (cdr expr)) (nth 1 expr))
+ (setcar (cdr expr) x))))
+ (let ((aa expr)
aaa temp)
(while (memq (car-safe (setq aaa (nth 1 aa))) '(+ -))
- (if (setq temp (math-combine-sum (nth 2 aaa) (nth 2 math-simplify-expr)
+ (if (setq temp (math-combine-sum (nth 2 aaa) (nth 2 expr)
(eq (car aaa) '-)
- (eq (car math-simplify-expr) '-) t))
+ (eq (car expr) '-) t))
(progn
- (setcar (cdr (cdr math-simplify-expr)) temp)
- (setcar math-simplify-expr '+)
+ (setcar (cdr (cdr expr)) temp)
+ (setcar expr '+)
(setcar (cdr (cdr aaa)) 0)))
(setq aa (nth 1 aa)))
- (if (setq temp (math-combine-sum aaa (nth 2 math-simplify-expr)
- nil (eq (car math-simplify-expr) '-) t))
+ (if (setq temp (math-combine-sum aaa (nth 2 expr)
+ nil (eq (car expr) '-) t))
(progn
- (setcar (cdr (cdr math-simplify-expr)) temp)
- (setcar math-simplify-expr '+)
+ (setcar (cdr (cdr expr)) temp)
+ (setcar expr '+)
(setcar (cdr aa) 0)))
- math-simplify-expr))
+ expr))
(math-defsimplify *
- (math-simplify-times))
-
-(defun math-simplify-times ()
- (if (eq (car-safe (nth 2 math-simplify-expr)) '*)
- (and (math-beforep (nth 1 (nth 2 math-simplify-expr)) (nth 1 math-simplify-expr))
- (or (math-known-scalarp (nth 1 math-simplify-expr) t)
- (math-known-scalarp (nth 1 (nth 2 math-simplify-expr)) t))
- (let ((x (nth 1 math-simplify-expr)))
- (setcar (cdr math-simplify-expr) (nth 1 (nth 2 math-simplify-expr)))
- (setcar (cdr (nth 2 math-simplify-expr)) x)))
- (and (math-beforep (nth 2 math-simplify-expr) (nth 1 math-simplify-expr))
- (or (math-known-scalarp (nth 1 math-simplify-expr) t)
- (math-known-scalarp (nth 2 math-simplify-expr) t))
- (let ((x (nth 2 math-simplify-expr)))
- (setcar (cdr (cdr math-simplify-expr)) (nth 1 math-simplify-expr))
- (setcar (cdr math-simplify-expr) x))))
- (let ((aa math-simplify-expr)
+ (if (eq (car-safe (nth 2 expr)) '*)
+ (and (math-beforep (nth 1 (nth 2 expr)) (nth 1 expr))
+ (or (math-known-scalarp (nth 1 expr) t)
+ (math-known-scalarp (nth 1 (nth 2 expr)) t))
+ (let ((x (nth 1 expr)))
+ (setcar (cdr expr) (nth 1 (nth 2 expr)))
+ (setcar (cdr (nth 2 expr)) x)))
+ (and (math-beforep (nth 2 expr) (nth 1 expr))
+ (or (math-known-scalarp (nth 1 expr) t)
+ (math-known-scalarp (nth 2 expr) t))
+ (let ((x (nth 2 expr)))
+ (setcar (cdr (cdr expr)) (nth 1 expr))
+ (setcar (cdr expr) x))))
+ (let ((aa expr)
aaa temp
- (safe t) (scalar (math-known-scalarp (nth 1 math-simplify-expr))))
- (if (and (Math-ratp (nth 1 math-simplify-expr))
- (setq temp (math-common-constant-factor (nth 2 math-simplify-expr))))
+ (safe t) (scalar (math-known-scalarp (nth 1 expr))))
+ (if (and (Math-ratp (nth 1 expr))
+ (setq temp (math-common-constant-factor (nth 2 expr))))
(progn
- (setcar (cdr (cdr math-simplify-expr))
- (math-cancel-common-factor (nth 2 math-simplify-expr) temp))
- (setcar (cdr math-simplify-expr) (math-mul (nth 1 math-simplify-expr) temp))))
+ (setcar (cdr (cdr expr))
+ (math-cancel-common-factor (nth 2 expr) temp))
+ (setcar (cdr expr) (math-mul (nth 1 expr) temp))))
(while (and (eq (car-safe (setq aaa (nth 2 aa))) '*)
safe)
- (if (setq temp (math-combine-prod (nth 1 math-simplify-expr)
+ (if (setq temp (math-combine-prod (nth 1 expr)
(nth 1 aaa) nil nil t))
(progn
- (setcar (cdr math-simplify-expr) temp)
+ (setcar (cdr expr) temp)
(setcar (cdr aaa) 1)))
(setq safe (or scalar (math-known-scalarp (nth 1 aaa) t))
aa (nth 2 aa)))
- (if (and (setq temp (math-combine-prod aaa (nth 1 math-simplify-expr) nil nil t))
+ (if (and (setq temp (math-combine-prod aaa (nth 1 expr) nil nil t))
safe)
(progn
- (setcar (cdr math-simplify-expr) temp)
+ (setcar (cdr expr) temp)
(setcar (cdr (cdr aa)) 1)))
- (if (and (eq (car-safe (nth 1 math-simplify-expr)) 'frac)
- (memq (nth 1 (nth 1 math-simplify-expr)) '(1 -1)))
- (math-div (math-mul (nth 2 math-simplify-expr)
- (nth 1 (nth 1 math-simplify-expr)))
- (nth 2 (nth 1 math-simplify-expr)))
- math-simplify-expr)))
+ (if (and (eq (car-safe (nth 1 expr)) 'frac)
+ (memq (nth 1 (nth 1 expr)) '(1 -1)))
+ (math-div (math-mul (nth 2 expr)
+ (nth 1 (nth 1 expr)))
+ (nth 2 (nth 1 expr)))
+ expr)))
(math-defsimplify /
- (math-simplify-divide))
+ (math-simplify-divide expr))
-(defun math-simplify-divide ()
- (let ((np (cdr math-simplify-expr))
+(defvar math--simplify-divide-expr)
+
+(defun math-simplify-divide (expr)
+ (let ((np (cdr expr))
(nover nil)
- (nn (and (or (eq (car math-simplify-expr) '/)
- (not (Math-realp (nth 2 math-simplify-expr))))
- (math-common-constant-factor (nth 2 math-simplify-expr))))
+ (nn (and (or (eq (car expr) '/)
+ (not (Math-realp (nth 2 expr))))
+ (math-common-constant-factor (nth 2 expr))))
n op)
(if nn
(progn
- (setq n (and (or (eq (car math-simplify-expr) '/)
- (not (Math-realp (nth 1 math-simplify-expr))))
- (math-common-constant-factor (nth 1 math-simplify-expr))))
+ (setq n (and (or (eq (car expr) '/)
+ (not (Math-realp (nth 1 expr))))
+ (math-common-constant-factor (nth 1 expr))))
(if (and (eq (car-safe nn) 'frac) (eq (nth 1 nn) 1) (not n))
- (unless (and (eq (car-safe math-simplify-expr) 'calcFunc-eq)
- (eq (car-safe (nth 1 math-simplify-expr)) 'var)
- (not (math-expr-contains (nth 2 math-simplify-expr)
- (nth 1 math-simplify-expr))))
- (setcar (cdr math-simplify-expr)
- (math-mul (nth 2 nn) (nth 1 math-simplify-expr)))
- (setcar (cdr (cdr math-simplify-expr))
- (math-cancel-common-factor (nth 2 math-simplify-expr) nn))
+ (unless (and (eq (car-safe expr) 'calcFunc-eq)
+ (eq (car-safe (nth 1 expr)) 'var)
+ (not (math-expr-contains (nth 2 expr)
+ (nth 1 expr))))
+ (setcar (cdr expr)
+ (math-mul (nth 2 nn) (nth 1 expr)))
+ (setcar (cdr (cdr expr))
+ (math-cancel-common-factor (nth 2 expr) nn))
(if (and (math-negp nn)
- (setq op (assq (car math-simplify-expr) calc-tweak-eqn-table)))
- (setcar math-simplify-expr (nth 1 op))))
+ (setq op (assq (car expr) calc-tweak-eqn-table)))
+ (setcar expr (nth 1 op))))
(if (and n (not (eq (setq n (math-frac-gcd n nn)) 1)))
(progn
- (setcar (cdr math-simplify-expr)
- (math-cancel-common-factor (nth 1 math-simplify-expr) n))
- (setcar (cdr (cdr math-simplify-expr))
- (math-cancel-common-factor (nth 2 math-simplify-expr) n))
+ (setcar (cdr expr)
+ (math-cancel-common-factor (nth 1 expr) n))
+ (setcar (cdr (cdr expr))
+ (math-cancel-common-factor (nth 2 expr) n))
(if (and (math-negp n)
- (setq op (assq (car math-simplify-expr)
+ (setq op (assq (car expr)
calc-tweak-eqn-table)))
- (setcar math-simplify-expr (nth 1 op))))))))
- (if (and (eq (car-safe (car np)) '/)
- (math-known-scalarp (nth 2 math-simplify-expr) t))
- (progn
- (setq np (cdr (nth 1 math-simplify-expr)))
- (while (eq (car-safe (setq n (car np))) '*)
- (and (math-known-scalarp (nth 2 n) t)
- (math-simplify-divisor (cdr n) (cdr (cdr math-simplify-expr)) nil t))
- (setq np (cdr (cdr n))))
- (math-simplify-divisor np (cdr (cdr math-simplify-expr)) nil t)
- (setq nover t
- np (cdr (cdr (nth 1 math-simplify-expr))))))
- (while (eq (car-safe (setq n (car np))) '*)
- (and (math-known-scalarp (nth 2 n) t)
- (math-simplify-divisor (cdr n) (cdr (cdr math-simplify-expr)) nover t))
- (setq np (cdr (cdr n))))
- (math-simplify-divisor np (cdr (cdr math-simplify-expr)) nover t)
- math-simplify-expr))
+ (setcar expr (nth 1 op))))))))
+ (let ((math--simplify-divide-expr expr)) ;For use in math-simplify-divisor
+ (if (and (eq (car-safe (car np)) '/)
+ (math-known-scalarp (nth 2 expr) t))
+ (progn
+ (setq np (cdr (nth 1 expr)))
+ (while (eq (car-safe (setq n (car np))) '*)
+ (and (math-known-scalarp (nth 2 n) t)
+ (math-simplify-divisor (cdr n) (cdr (cdr expr)) nil t))
+ (setq np (cdr (cdr n))))
+ (math-simplify-divisor np (cdr (cdr expr)) nil t)
+ (setq nover t
+ np (cdr (cdr (nth 1 expr))))))
+ (while (eq (car-safe (setq n (car np))) '*)
+ (and (math-known-scalarp (nth 2 n) t)
+ (math-simplify-divisor (cdr n) (cdr (cdr expr)) nover t))
+ (setq np (cdr (cdr n))))
+ (math-simplify-divisor np (cdr (cdr expr)) nover t)
+ expr)))
;; The variables math-simplify-divisor-nover and math-simplify-divisor-dover
;; are local variables for math-simplify-divisor, but are used by
@@ -587,25 +583,25 @@
(defvar math-simplify-divisor-nover)
(defvar math-simplify-divisor-dover)
-(defun math-simplify-divisor (np dp math-simplify-divisor-nover
- math-simplify-divisor-dover)
+(defun math-simplify-divisor (np dp nover dover)
(cond ((eq (car-safe (car dp)) '/)
(math-simplify-divisor np (cdr (car dp))
- math-simplify-divisor-nover
- math-simplify-divisor-dover)
+ nover dover)
(and (math-known-scalarp (nth 1 (car dp)) t)
(math-simplify-divisor np (cdr (cdr (car dp)))
- math-simplify-divisor-nover
- (not math-simplify-divisor-dover))))
- ((or (or (eq (car math-simplify-expr) '/)
+ nover (not dover))))
+ ((or (or (eq (car math--simplify-divide-expr) '/)
(let ((signs (math-possible-signs (car np))))
(or (memq signs '(1 4))
- (and (memq (car math-simplify-expr) '(calcFunc-eq calcFunc-neq))
+ (and (memq (car math--simplify-divide-expr)
+ '(calcFunc-eq calcFunc-neq))
(eq signs 5))
math-living-dangerously)))
(math-numberp (car np)))
(let (d
(safe t)
+ (math-simplify-divisor-nover nover)
+ (math-simplify-divisor-dover dover)
(scalar (math-known-scalarp (car np))))
(while (and (eq (car-safe (setq d (car dp))) '*)
safe)
@@ -621,14 +617,16 @@
op)
(if temp
(progn
- (and (not (memq (car math-simplify-expr) '(/ calcFunc-eq calcFunc-neq)))
+ (and (not (memq (car math--simplify-divide-expr)
+ '(/ calcFunc-eq calcFunc-neq)))
(math-known-negp (car dp))
- (setq op (assq (car math-simplify-expr) calc-tweak-eqn-table))
- (setcar math-simplify-expr (nth 1 op)))
+ (setq op (assq (car math--simplify-divide-expr)
+ calc-tweak-eqn-table))
+ (setcar math--simplify-divide-expr (nth 1 op)))
(setcar np (if math-simplify-divisor-nover (math-div 1 temp) temp))
(setcar dp 1))
(and math-simplify-divisor-dover (not math-simplify-divisor-nover)
- (eq (car math-simplify-expr) '/)
+ (eq (car math--simplify-divide-expr) '/)
(eq (car-safe (car dp)) 'calcFunc-sqrt)
(Math-integerp (nth 1 (car dp)))
(progn
@@ -680,26 +678,23 @@
(math-gcd (nth 2 a) (nth 2 b)))))))
(math-defsimplify %
- (math-simplify-mod))
-
-(defun math-simplify-mod ()
- (and (Math-realp (nth 2 math-simplify-expr))
- (Math-posp (nth 2 math-simplify-expr))
- (let ((lin (math-is-linear (nth 1 math-simplify-expr)))
- t1 t2 t3)
+ (and (Math-realp (nth 2 expr))
+ (Math-posp (nth 2 expr))
+ (let ((lin (math-is-linear (nth 1 expr)))
+ t1)
(or (and lin
(or (math-negp (car lin))
- (not (Math-lessp (car lin) (nth 2 math-simplify-expr))))
+ (not (Math-lessp (car lin) (nth 2 expr))))
(list '%
(list '+
(math-mul (nth 1 lin) (nth 2 lin))
- (math-mod (car lin) (nth 2 math-simplify-expr)))
- (nth 2 math-simplify-expr)))
+ (math-mod (car lin) (nth 2 expr)))
+ (nth 2 expr)))
(and lin
(not (math-equal-int (nth 1 lin) 1))
(math-num-integerp (nth 1 lin))
- (math-num-integerp (nth 2 math-simplify-expr))
- (setq t1 (calcFunc-gcd (nth 1 lin) (nth 2 math-simplify-expr)))
+ (math-num-integerp (nth 2 expr))
+ (setq t1 (calcFunc-gcd (nth 1 lin) (nth 2 expr)))
(not (math-equal-int t1 1))
(list '*
t1
@@ -709,53 +704,53 @@
(nth 2 lin))
(let ((calc-prefer-frac t))
(math-div (car lin) t1)))
- (math-div (nth 2 math-simplify-expr) t1))))
- (and (math-equal-int (nth 2 math-simplify-expr) 1)
+ (math-div (nth 2 expr) t1))))
+ (and (math-equal-int (nth 2 expr) 1)
(math-known-integerp (if lin
(math-mul (nth 1 lin) (nth 2 lin))
- (nth 1 math-simplify-expr)))
+ (nth 1 expr)))
(if lin (math-mod (car lin) 1) 0))))))
(math-defsimplify (calcFunc-eq calcFunc-neq calcFunc-lt
calcFunc-gt calcFunc-leq calcFunc-geq)
- (if (= (length math-simplify-expr) 3)
- (math-simplify-ineq)))
+ (if (= (length expr) 3)
+ (math-simplify-ineq expr)))
-(defun math-simplify-ineq ()
- (let ((np (cdr math-simplify-expr))
+(defun math-simplify-ineq (expr)
+ (let ((np (cdr expr))
n)
(while (memq (car-safe (setq n (car np))) '(+ -))
- (math-simplify-add-term (cdr (cdr n)) (cdr (cdr math-simplify-expr))
+ (math-simplify-add-term (cdr (cdr n)) (cdr (cdr expr))
(eq (car n) '-) nil)
(setq np (cdr n)))
- (math-simplify-add-term np (cdr (cdr math-simplify-expr)) nil
- (eq np (cdr math-simplify-expr)))
- (math-simplify-divide)
- (let ((signs (math-possible-signs (cons '- (cdr math-simplify-expr)))))
- (or (cond ((eq (car math-simplify-expr) 'calcFunc-eq)
+ (math-simplify-add-term np (cdr (cdr expr)) nil
+ (eq np (cdr expr)))
+ (math-simplify-divide expr)
+ (let ((signs (math-possible-signs (cons '- (cdr expr)))))
+ (or (cond ((eq (car expr) 'calcFunc-eq)
(or (and (eq signs 2) 1)
(and (memq signs '(1 4 5)) 0)))
- ((eq (car math-simplify-expr) 'calcFunc-neq)
+ ((eq (car expr) 'calcFunc-neq)
(or (and (eq signs 2) 0)
(and (memq signs '(1 4 5)) 1)))
- ((eq (car math-simplify-expr) 'calcFunc-lt)
+ ((eq (car expr) 'calcFunc-lt)
(or (and (eq signs 1) 1)
(and (memq signs '(2 4 6)) 0)))
- ((eq (car math-simplify-expr) 'calcFunc-gt)
+ ((eq (car expr) 'calcFunc-gt)
(or (and (eq signs 4) 1)
(and (memq signs '(1 2 3)) 0)))
- ((eq (car math-simplify-expr) 'calcFunc-leq)
+ ((eq (car expr) 'calcFunc-leq)
(or (and (eq signs 4) 0)
(and (memq signs '(1 2 3)) 1)))
- ((eq (car math-simplify-expr) 'calcFunc-geq)
+ ((eq (car expr) 'calcFunc-geq)
(or (and (eq signs 1) 0)
(and (memq signs '(2 4 6)) 1))))
- math-simplify-expr))))
+ expr))))
(defun math-simplify-add-term (np dp minus lplain)
(or (math-vectorp (car np))
(let ((rplain t)
- n d dd temp)
+ n d temp)
(while (memq (car-safe (setq n (car np) d (car dp))) '(+ -))
(setq rplain nil)
(if (setq temp (math-combine-sum n (nth 2 d)
@@ -782,27 +777,27 @@
(setcar dp (setq n (math-neg temp)))))))))
(math-defsimplify calcFunc-sin
- (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
- (nth 1 (nth 1 math-simplify-expr)))
- (and (math-looks-negp (nth 1 math-simplify-expr))
- (math-neg (list 'calcFunc-sin (math-neg (nth 1 math-simplify-expr)))))
+ (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin)
+ (nth 1 (nth 1 expr)))
+ (and (math-looks-negp (nth 1 expr))
+ (math-neg (list 'calcFunc-sin (math-neg (nth 1 expr)))))
(and (eq calc-angle-mode 'rad)
- (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
+ (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi))))
(and n
(math-known-sin (car n) (nth 1 n) 120 0))))
(and (eq calc-angle-mode 'deg)
- (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
+ (let ((n (math-integer-plus (nth 1 expr))))
(and n
(math-known-sin (car n) (nth 1 n) '(frac 2 3) 0))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos)
(list 'calcFunc-sqrt (math-sub 1 (math-sqr
- (nth 1 (nth 1 math-simplify-expr))))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
- (math-div (nth 1 (nth 1 math-simplify-expr))
+ (nth 1 (nth 1 expr))))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan)
+ (math-div (nth 1 (nth 1 expr))
(list 'calcFunc-sqrt
(math-add 1 (math-sqr
- (nth 1 (nth 1 math-simplify-expr)))))))
- (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
+ (nth 1 (nth 1 expr)))))))
+ (let ((m (math-should-expand-trig (nth 1 expr))))
(and m (integerp (car m))
(let ((n (car m)) (a (nth 1 m)))
(list '+
@@ -812,27 +807,27 @@
(list 'calcFunc-sin a))))))))
(math-defsimplify calcFunc-cos
- (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
- (nth 1 (nth 1 math-simplify-expr)))
- (and (math-looks-negp (nth 1 math-simplify-expr))
- (list 'calcFunc-cos (math-neg (nth 1 math-simplify-expr))))
+ (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos)
+ (nth 1 (nth 1 expr)))
+ (and (math-looks-negp (nth 1 expr))
+ (list 'calcFunc-cos (math-neg (nth 1 expr))))
(and (eq calc-angle-mode 'rad)
- (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
+ (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi))))
(and n
(math-known-sin (car n) (nth 1 n) 120 300))))
(and (eq calc-angle-mode 'deg)
- (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
+ (let ((n (math-integer-plus (nth 1 expr))))
(and n
(math-known-sin (car n) (nth 1 n) '(frac 2 3) 300))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin)
(list 'calcFunc-sqrt
- (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
+ (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan)
(math-div 1
(list 'calcFunc-sqrt
(math-add 1
- (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
- (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
+ (math-sqr (nth 1 (nth 1 expr)))))))
+ (let ((m (math-should-expand-trig (nth 1 expr))))
(and m (integerp (car m))
(let ((n (car m)) (a (nth 1 m)))
(list '-
@@ -842,53 +837,53 @@
(list 'calcFunc-sin a))))))))
(math-defsimplify calcFunc-sec
- (or (and (math-looks-negp (nth 1 math-simplify-expr))
- (list 'calcFunc-sec (math-neg (nth 1 math-simplify-expr))))
+ (or (and (math-looks-negp (nth 1 expr))
+ (list 'calcFunc-sec (math-neg (nth 1 expr))))
(and (eq calc-angle-mode 'rad)
- (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
+ (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi))))
(and n
(math-div 1 (math-known-sin (car n) (nth 1 n) 120 300)))))
(and (eq calc-angle-mode 'deg)
- (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
+ (let ((n (math-integer-plus (nth 1 expr))))
(and n
(math-div 1 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 300)))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin)
(math-div
1
(list 'calcFunc-sqrt
- (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
+ (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos)
(math-div
1
- (nth 1 (nth 1 math-simplify-expr))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
+ (nth 1 (nth 1 expr))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan)
(list 'calcFunc-sqrt
(math-add 1
- (math-sqr (nth 1 (nth 1 math-simplify-expr))))))))
+ (math-sqr (nth 1 (nth 1 expr))))))))
(math-defsimplify calcFunc-csc
- (or (and (math-looks-negp (nth 1 math-simplify-expr))
- (math-neg (list 'calcFunc-csc (math-neg (nth 1 math-simplify-expr)))))
+ (or (and (math-looks-negp (nth 1 expr))
+ (math-neg (list 'calcFunc-csc (math-neg (nth 1 expr)))))
(and (eq calc-angle-mode 'rad)
- (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
+ (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi))))
(and n
(math-div 1 (math-known-sin (car n) (nth 1 n) 120 0)))))
(and (eq calc-angle-mode 'deg)
- (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
+ (let ((n (math-integer-plus (nth 1 expr))))
(and n
(math-div 1 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 0)))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
- (math-div 1 (nth 1 (nth 1 math-simplify-expr))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin)
+ (math-div 1 (nth 1 (nth 1 expr))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos)
(math-div
1
(list 'calcFunc-sqrt (math-sub 1 (math-sqr
- (nth 1 (nth 1 math-simplify-expr)))))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
+ (nth 1 (nth 1 expr)))))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan)
(math-div (list 'calcFunc-sqrt
(math-add 1 (math-sqr
- (nth 1 (nth 1 math-simplify-expr)))))
- (nth 1 (nth 1 math-simplify-expr))))))
+ (nth 1 (nth 1 expr)))))
+ (nth 1 (nth 1 expr))))))
(defun math-should-expand-trig (x &optional hyperbolic)
(let ((m (math-is-multiple x)))
@@ -943,55 +938,55 @@
(t nil))))))
(math-defsimplify calcFunc-tan
- (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
- (nth 1 (nth 1 math-simplify-expr)))
- (and (math-looks-negp (nth 1 math-simplify-expr))
- (math-neg (list 'calcFunc-tan (math-neg (nth 1 math-simplify-expr)))))
+ (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan)
+ (nth 1 (nth 1 expr)))
+ (and (math-looks-negp (nth 1 expr))
+ (math-neg (list 'calcFunc-tan (math-neg (nth 1 expr)))))
(and (eq calc-angle-mode 'rad)
- (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
+ (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi))))
(and n
(math-known-tan (car n) (nth 1 n) 120))))
(and (eq calc-angle-mode 'deg)
- (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
+ (let ((n (math-integer-plus (nth 1 expr))))
(and n
(math-known-tan (car n) (nth 1 n) '(frac 2 3)))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
- (math-div (nth 1 (nth 1 math-simplify-expr))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin)
+ (math-div (nth 1 (nth 1 expr))
(list 'calcFunc-sqrt
- (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
+ (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos)
(math-div (list 'calcFunc-sqrt
- (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))
- (nth 1 (nth 1 math-simplify-expr))))
- (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
+ (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))
+ (nth 1 (nth 1 expr))))
+ (let ((m (math-should-expand-trig (nth 1 expr))))
(and m
(if (equal (car m) '(frac 1 2))
(math-div (math-sub 1 (list 'calcFunc-cos (nth 1 m)))
(list 'calcFunc-sin (nth 1 m)))
- (math-div (list 'calcFunc-sin (nth 1 math-simplify-expr))
- (list 'calcFunc-cos (nth 1 math-simplify-expr))))))))
+ (math-div (list 'calcFunc-sin (nth 1 expr))
+ (list 'calcFunc-cos (nth 1 expr))))))))
(math-defsimplify calcFunc-cot
- (or (and (math-looks-negp (nth 1 math-simplify-expr))
- (math-neg (list 'calcFunc-cot (math-neg (nth 1 math-simplify-expr)))))
+ (or (and (math-looks-negp (nth 1 expr))
+ (math-neg (list 'calcFunc-cot (math-neg (nth 1 expr)))))
(and (eq calc-angle-mode 'rad)
- (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
+ (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi))))
(and n
(math-div 1 (math-known-tan (car n) (nth 1 n) 120)))))
(and (eq calc-angle-mode 'deg)
- (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
+ (let ((n (math-integer-plus (nth 1 expr))))
(and n
(math-div 1 (math-known-tan (car n) (nth 1 n) '(frac 2 3))))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin)
(math-div (list 'calcFunc-sqrt
- (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))
- (nth 1 (nth 1 math-simplify-expr))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
- (math-div (nth 1 (nth 1 math-simplify-expr))
+ (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))
+ (nth 1 (nth 1 expr))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos)
+ (math-div (nth 1 (nth 1 expr))
(list 'calcFunc-sqrt
- (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
- (math-div 1 (nth 1 (nth 1 math-simplify-expr))))))
+ (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan)
+ (math-div 1 (nth 1 (nth 1 expr))))))
(defun math-known-tan (plus n mul)
(setq n (math-mul n mul))
@@ -1026,20 +1021,20 @@
(t nil))))))
(math-defsimplify calcFunc-sinh
- (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
- (nth 1 (nth 1 math-simplify-expr)))
- (and (math-looks-negp (nth 1 math-simplify-expr))
- (math-neg (list 'calcFunc-sinh (math-neg (nth 1 math-simplify-expr)))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
+ (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh)
+ (nth 1 (nth 1 expr)))
+ (and (math-looks-negp (nth 1 expr))
+ (math-neg (list 'calcFunc-sinh (math-neg (nth 1 expr)))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh)
math-living-dangerously
(list 'calcFunc-sqrt
- (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
+ (math-sub (math-sqr (nth 1 (nth 1 expr))) 1)))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh)
math-living-dangerously
- (math-div (nth 1 (nth 1 math-simplify-expr))
+ (math-div (nth 1 (nth 1 expr))
(list 'calcFunc-sqrt
- (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
- (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
+ (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))))
+ (let ((m (math-should-expand-trig (nth 1 expr) t)))
(and m (integerp (car m))
(let ((n (car m)) (a (nth 1 m)))
(if (> n 1)
@@ -1050,20 +1045,20 @@
(list 'calcFunc-sinh a)))))))))
(math-defsimplify calcFunc-cosh
- (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
- (nth 1 (nth 1 math-simplify-expr)))
- (and (math-looks-negp (nth 1 math-simplify-expr))
- (list 'calcFunc-cosh (math-neg (nth 1 math-simplify-expr))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
+ (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh)
+ (nth 1 (nth 1 expr)))
+ (and (math-looks-negp (nth 1 expr))
+ (list 'calcFunc-cosh (math-neg (nth 1 expr))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh)
math-living-dangerously
(list 'calcFunc-sqrt
- (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
+ (math-add (math-sqr (nth 1 (nth 1 expr))) 1)))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh)
math-living-dangerously
(math-div 1
(list 'calcFunc-sqrt
- (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
- (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
+ (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))))
+ (let ((m (math-should-expand-trig (nth 1 expr) t)))
(and m (integerp (car m))
(let ((n (car m)) (a (nth 1 m)))
(if (> n 1)
@@ -1074,188 +1069,188 @@
(list 'calcFunc-sinh a)))))))))
(math-defsimplify calcFunc-tanh
- (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
- (nth 1 (nth 1 math-simplify-expr)))
- (and (math-looks-negp (nth 1 math-simplify-expr))
- (math-neg (list 'calcFunc-tanh (math-neg (nth 1 math-simplify-expr)))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
+ (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh)
+ (nth 1 (nth 1 expr)))
+ (and (math-looks-negp (nth 1 expr))
+ (math-neg (list 'calcFunc-tanh (math-neg (nth 1 expr)))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh)
math-living-dangerously
- (math-div (nth 1 (nth 1 math-simplify-expr))
+ (math-div (nth 1 (nth 1 expr))
(list 'calcFunc-sqrt
- (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
+ (math-add (math-sqr (nth 1 (nth 1 expr))) 1))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh)
math-living-dangerously
(math-div (list 'calcFunc-sqrt
- (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))
- (nth 1 (nth 1 math-simplify-expr))))
- (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
+ (math-sub (math-sqr (nth 1 (nth 1 expr))) 1))
+ (nth 1 (nth 1 expr))))
+ (let ((m (math-should-expand-trig (nth 1 expr) t)))
(and m
(if (equal (car m) '(frac 1 2))
(math-div (math-sub (list 'calcFunc-cosh (nth 1 m)) 1)
(list 'calcFunc-sinh (nth 1 m)))
- (math-div (list 'calcFunc-sinh (nth 1 math-simplify-expr))
- (list 'calcFunc-cosh (nth 1 math-simplify-expr))))))))
+ (math-div (list 'calcFunc-sinh (nth 1 expr))
+ (list 'calcFunc-cosh (nth 1 expr))))))))
(math-defsimplify calcFunc-sech
- (or (and (math-looks-negp (nth 1 math-simplify-expr))
- (list 'calcFunc-sech (math-neg (nth 1 math-simplify-expr))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
+ (or (and (math-looks-negp (nth 1 expr))
+ (list 'calcFunc-sech (math-neg (nth 1 expr))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh)
math-living-dangerously
(math-div
1
(list 'calcFunc-sqrt
- (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
+ (math-add (math-sqr (nth 1 (nth 1 expr))) 1))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh)
math-living-dangerously
- (math-div 1 (nth 1 (nth 1 math-simplify-expr))) 1)
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
+ (math-div 1 (nth 1 (nth 1 expr))) 1)
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh)
math-living-dangerously
(list 'calcFunc-sqrt
- (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))))
+ (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))))))
(math-defsimplify calcFunc-csch
- (or (and (math-looks-negp (nth 1 math-simplify-expr))
- (math-neg (list 'calcFunc-csch (math-neg (nth 1 math-simplify-expr)))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
+ (or (and (math-looks-negp (nth 1 expr))
+ (math-neg (list 'calcFunc-csch (math-neg (nth 1 expr)))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh)
math-living-dangerously
- (math-div 1 (nth 1 (nth 1 math-simplify-expr))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
+ (math-div 1 (nth 1 (nth 1 expr))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh)
math-living-dangerously
(math-div
1
(list 'calcFunc-sqrt
- (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
+ (math-sub (math-sqr (nth 1 (nth 1 expr))) 1))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh)
math-living-dangerously
(math-div (list 'calcFunc-sqrt
- (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))
- (nth 1 (nth 1 math-simplify-expr))))))
+ (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))
+ (nth 1 (nth 1 expr))))))
(math-defsimplify calcFunc-coth
- (or (and (math-looks-negp (nth 1 math-simplify-expr))
- (math-neg (list 'calcFunc-coth (math-neg (nth 1 math-simplify-expr)))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
+ (or (and (math-looks-negp (nth 1 expr))
+ (math-neg (list 'calcFunc-coth (math-neg (nth 1 expr)))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh)
math-living-dangerously
(math-div (list 'calcFunc-sqrt
- (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))
- (nth 1 (nth 1 math-simplify-expr))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
+ (math-add (math-sqr (nth 1 (nth 1 expr))) 1))
+ (nth 1 (nth 1 expr))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh)
math-living-dangerously
- (math-div (nth 1 (nth 1 math-simplify-expr))
+ (math-div (nth 1 (nth 1 expr))
(list 'calcFunc-sqrt
- (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
+ (math-sub (math-sqr (nth 1 (nth 1 expr))) 1))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh)
math-living-dangerously
- (math-div 1 (nth 1 (nth 1 math-simplify-expr))))))
+ (math-div 1 (nth 1 (nth 1 expr))))))
(math-defsimplify calcFunc-arcsin
- (or (and (math-looks-negp (nth 1 math-simplify-expr))
- (math-neg (list 'calcFunc-arcsin (math-neg (nth 1 math-simplify-expr)))))
- (and (eq (nth 1 math-simplify-expr) 1)
+ (or (and (math-looks-negp (nth 1 expr))
+ (math-neg (list 'calcFunc-arcsin (math-neg (nth 1 expr)))))
+ (and (eq (nth 1 expr) 1)
(math-quarter-circle t))
- (and (equal (nth 1 math-simplify-expr) '(frac 1 2))
+ (and (equal (nth 1 expr) '(frac 1 2))
(math-div (math-half-circle t) 6))
(and math-living-dangerously
- (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sin)
- (nth 1 (nth 1 math-simplify-expr)))
+ (eq (car-safe (nth 1 expr)) 'calcFunc-sin)
+ (nth 1 (nth 1 expr)))
(and math-living-dangerously
- (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
+ (eq (car-safe (nth 1 expr)) 'calcFunc-cos)
(math-sub (math-quarter-circle t)
- (nth 1 (nth 1 math-simplify-expr))))))
+ (nth 1 (nth 1 expr))))))
(math-defsimplify calcFunc-arccos
- (or (and (eq (nth 1 math-simplify-expr) 0)
+ (or (and (eq (nth 1 expr) 0)
(math-quarter-circle t))
- (and (eq (nth 1 math-simplify-expr) -1)
+ (and (eq (nth 1 expr) -1)
(math-half-circle t))
- (and (equal (nth 1 math-simplify-expr) '(frac 1 2))
+ (and (equal (nth 1 expr) '(frac 1 2))
(math-div (math-half-circle t) 3))
- (and (equal (nth 1 math-simplify-expr) '(frac -1 2))
+ (and (equal (nth 1 expr) '(frac -1 2))
(math-div (math-mul (math-half-circle t) 2) 3))
(and math-living-dangerously
- (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
- (nth 1 (nth 1 math-simplify-expr)))
+ (eq (car-safe (nth 1 expr)) 'calcFunc-cos)
+ (nth 1 (nth 1 expr)))
(and math-living-dangerously
- (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sin)
+ (eq (car-safe (nth 1 expr)) 'calcFunc-sin)
(math-sub (math-quarter-circle t)
- (nth 1 (nth 1 math-simplify-expr))))))
+ (nth 1 (nth 1 expr))))))
(math-defsimplify calcFunc-arctan
- (or (and (math-looks-negp (nth 1 math-simplify-expr))
- (math-neg (list 'calcFunc-arctan (math-neg (nth 1 math-simplify-expr)))))
- (and (eq (nth 1 math-simplify-expr) 1)
+ (or (and (math-looks-negp (nth 1 expr))
+ (math-neg (list 'calcFunc-arctan (math-neg (nth 1 expr)))))
+ (and (eq (nth 1 expr) 1)
(math-div (math-half-circle t) 4))
(and math-living-dangerously
- (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-tan)
- (nth 1 (nth 1 math-simplify-expr)))))
+ (eq (car-safe (nth 1 expr)) 'calcFunc-tan)
+ (nth 1 (nth 1 expr)))))
(math-defsimplify calcFunc-arcsinh
- (or (and (math-looks-negp (nth 1 math-simplify-expr))
- (math-neg (list 'calcFunc-arcsinh (math-neg (nth 1 math-simplify-expr)))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sinh)
+ (or (and (math-looks-negp (nth 1 expr))
+ (math-neg (list 'calcFunc-arcsinh (math-neg (nth 1 expr)))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-sinh)
(or math-living-dangerously
- (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
- (nth 1 (nth 1 math-simplify-expr)))))
+ (math-known-realp (nth 1 (nth 1 expr))))
+ (nth 1 (nth 1 expr)))))
(math-defsimplify calcFunc-arccosh
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cosh)
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-cosh)
(or math-living-dangerously
- (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
- (nth 1 (nth 1 math-simplify-expr))))
+ (math-known-realp (nth 1 (nth 1 expr))))
+ (nth 1 (nth 1 expr))))
(math-defsimplify calcFunc-arctanh
- (or (and (math-looks-negp (nth 1 math-simplify-expr))
- (math-neg (list 'calcFunc-arctanh (math-neg (nth 1 math-simplify-expr)))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-tanh)
+ (or (and (math-looks-negp (nth 1 expr))
+ (math-neg (list 'calcFunc-arctanh (math-neg (nth 1 expr)))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-tanh)
(or math-living-dangerously
- (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
- (nth 1 (nth 1 math-simplify-expr)))))
+ (math-known-realp (nth 1 (nth 1 expr))))
+ (nth 1 (nth 1 expr)))))
(math-defsimplify calcFunc-sqrt
- (math-simplify-sqrt))
+ (math-simplify-sqrt expr))
-(defun math-simplify-sqrt ()
- (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'frac)
+(defun math-simplify-sqrt (expr)
+ (or (and (eq (car-safe (nth 1 expr)) 'frac)
(math-div (list 'calcFunc-sqrt
- (math-mul (nth 1 (nth 1 math-simplify-expr))
- (nth 2 (nth 1 math-simplify-expr))))
- (nth 2 (nth 1 math-simplify-expr))))
- (let ((fac (if (math-objectp (nth 1 math-simplify-expr))
- (math-squared-factor (nth 1 math-simplify-expr))
- (math-common-constant-factor (nth 1 math-simplify-expr)))))
+ (math-mul (nth 1 (nth 1 expr))
+ (nth 2 (nth 1 expr))))
+ (nth 2 (nth 1 expr))))
+ (let ((fac (if (math-objectp (nth 1 expr))
+ (math-squared-factor (nth 1 expr))
+ (math-common-constant-factor (nth 1 expr)))))
(and fac (not (eq fac 1))
(math-mul (math-normalize (list 'calcFunc-sqrt fac))
(math-normalize
(list 'calcFunc-sqrt
(math-cancel-common-factor
- (nth 1 math-simplify-expr) fac))))))
+ (nth 1 expr) fac))))))
(and math-living-dangerously
- (or (and (eq (car-safe (nth 1 math-simplify-expr)) '-)
- (math-equal-int (nth 1 (nth 1 math-simplify-expr)) 1)
- (eq (car-safe (nth 2 (nth 1 math-simplify-expr))) '^)
- (math-equal-int (nth 2 (nth 2 (nth 1 math-simplify-expr))) 2)
- (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr))))
+ (or (and (eq (car-safe (nth 1 expr)) '-)
+ (math-equal-int (nth 1 (nth 1 expr)) 1)
+ (eq (car-safe (nth 2 (nth 1 expr))) '^)
+ (math-equal-int (nth 2 (nth 2 (nth 1 expr))) 2)
+ (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 expr))))
'calcFunc-sin)
(list 'calcFunc-cos
- (nth 1 (nth 1 (nth 2 (nth 1 math-simplify-expr))))))
- (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr))))
+ (nth 1 (nth 1 (nth 2 (nth 1 expr))))))
+ (and (eq (car-safe (nth 1 (nth 2 (nth 1 expr))))
'calcFunc-cos)
(list 'calcFunc-sin
(nth 1 (nth 1 (nth 2
- (nth 1 math-simplify-expr))))))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) '-)
- (math-equal-int (nth 2 (nth 1 math-simplify-expr)) 1)
- (eq (car-safe (nth 1 (nth 1 math-simplify-expr))) '^)
- (math-equal-int (nth 2 (nth 1 (nth 1 math-simplify-expr))) 2)
- (and (eq (car-safe (nth 1 (nth 1 (nth 1 math-simplify-expr))))
+ (nth 1 expr))))))))
+ (and (eq (car-safe (nth 1 expr)) '-)
+ (math-equal-int (nth 2 (nth 1 expr)) 1)
+ (eq (car-safe (nth 1 (nth 1 expr))) '^)
+ (math-equal-int (nth 2 (nth 1 (nth 1 expr))) 2)
+ (and (eq (car-safe (nth 1 (nth 1 (nth 1 expr))))
'calcFunc-cosh)
(list 'calcFunc-sinh
- (nth 1 (nth 1 (nth 1 (nth 1 math-simplify-expr)))))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) '+)
- (let ((a (nth 1 (nth 1 math-simplify-expr)))
- (b (nth 2 (nth 1 math-simplify-expr))))
+ (nth 1 (nth 1 (nth 1 (nth 1 expr)))))))
+ (and (eq (car-safe (nth 1 expr)) '+)
+ (let ((a (nth 1 (nth 1 expr)))
+ (b (nth 2 (nth 1 expr))))
(and (or (and (math-equal-int a 1)
- (setq a b b (nth 1 (nth 1 math-simplify-expr))))
+ (setq a b b (nth 1 (nth 1 expr))))
(math-equal-int b 1))
(eq (car-safe a) '^)
(math-equal-int (nth 2 a) 2)
@@ -1269,20 +1264,20 @@
(and (eq (car-safe (nth 1 a)) 'calcFunc-cot)
(list '/ 1 (list 'calcFunc-sin
(nth 1 (nth 1 a)))))))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
+ (and (eq (car-safe (nth 1 expr)) '^)
(list '^
- (nth 1 (nth 1 math-simplify-expr))
- (math-div (nth 2 (nth 1 math-simplify-expr)) 2)))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sqrt)
- (list '^ (nth 1 (nth 1 math-simplify-expr)) (math-div 1 4)))
- (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
- (list (car (nth 1 math-simplify-expr))
- (list 'calcFunc-sqrt (nth 1 (nth 1 math-simplify-expr)))
- (list 'calcFunc-sqrt (nth 2 (nth 1 math-simplify-expr)))))
- (and (memq (car-safe (nth 1 math-simplify-expr)) '(+ -))
- (not (math-any-floats (nth 1 math-simplify-expr)))
+ (nth 1 (nth 1 expr))
+ (math-div (nth 2 (nth 1 expr)) 2)))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-sqrt)
+ (list '^ (nth 1 (nth 1 expr)) (math-div 1 4)))
+ (and (memq (car-safe (nth 1 expr)) '(* /))
+ (list (car (nth 1 expr))
+ (list 'calcFunc-sqrt (nth 1 (nth 1 expr)))
+ (list 'calcFunc-sqrt (nth 2 (nth 1 expr)))))
+ (and (memq (car-safe (nth 1 expr)) '(+ -))
+ (not (math-any-floats (nth 1 expr)))
(let ((f (calcFunc-factors (calcFunc-expand
- (nth 1 math-simplify-expr)))))
+ (nth 1 expr)))))
(and (math-vectorp f)
(or (> (length f) 2)
(> (nth 2 (nth 1 f)) 1))
@@ -1318,7 +1313,7 @@
fac)))
(math-defsimplify calcFunc-exp
- (math-simplify-exp (nth 1 math-simplify-expr)))
+ (math-simplify-exp (nth 1 expr)))
(defun math-simplify-exp (x)
(or (and (eq (car-safe x) 'calcFunc-ln)
@@ -1349,22 +1344,22 @@
(list '+ c (list '* s '(var i var-i))))))))
(math-defsimplify calcFunc-ln
- (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-exp)
+ (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-exp)
(or math-living-dangerously
- (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
- (nth 1 (nth 1 math-simplify-expr)))
- (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
- (equal (nth 1 (nth 1 math-simplify-expr)) '(var e var-e))
+ (math-known-realp (nth 1 (nth 1 expr))))
+ (nth 1 (nth 1 expr)))
+ (and (eq (car-safe (nth 1 expr)) '^)
+ (equal (nth 1 (nth 1 expr)) '(var e var-e))
(or math-living-dangerously
- (math-known-realp (nth 2 (nth 1 math-simplify-expr))))
- (nth 2 (nth 1 math-simplify-expr)))
+ (math-known-realp (nth 2 (nth 1 expr))))
+ (nth 2 (nth 1 expr)))
(and calc-symbolic-mode
- (math-known-negp (nth 1 math-simplify-expr))
- (math-add (list 'calcFunc-ln (math-neg (nth 1 math-simplify-expr)))
+ (math-known-negp (nth 1 expr))
+ (math-add (list 'calcFunc-ln (math-neg (nth 1 expr)))
'(* (var pi var-pi) (var i var-i))))
(and calc-symbolic-mode
- (math-known-imagp (nth 1 math-simplify-expr))
- (let* ((ip (calcFunc-im (nth 1 math-simplify-expr)))
+ (math-known-imagp (nth 1 expr))
+ (let* ((ip (calcFunc-im (nth 1 expr)))
(ips (math-possible-signs ip)))
(or (and (memq ips '(4 6))
(math-add (list 'calcFunc-ln ip)
@@ -1374,95 +1369,92 @@
'(/ (* (var pi var-pi) (var i var-i)) 2))))))))
(math-defsimplify ^
- (math-simplify-pow))
-
-(defun math-simplify-pow ()
(or (and math-living-dangerously
- (or (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
+ (or (and (eq (car-safe (nth 1 expr)) '^)
(list '^
- (nth 1 (nth 1 math-simplify-expr))
- (math-mul (nth 2 math-simplify-expr)
- (nth 2 (nth 1 math-simplify-expr)))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sqrt)
+ (nth 1 (nth 1 expr))
+ (math-mul (nth 2 expr)
+ (nth 2 (nth 1 expr)))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-sqrt)
(list '^
- (nth 1 (nth 1 math-simplify-expr))
- (math-div (nth 2 math-simplify-expr) 2)))
- (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
- (list (car (nth 1 math-simplify-expr))
- (list '^ (nth 1 (nth 1 math-simplify-expr))
- (nth 2 math-simplify-expr))
- (list '^ (nth 2 (nth 1 math-simplify-expr))
- (nth 2 math-simplify-expr))))))
- (and (math-equal-int (nth 1 math-simplify-expr) 10)
- (eq (car-safe (nth 2 math-simplify-expr)) 'calcFunc-log10)
- (nth 1 (nth 2 math-simplify-expr)))
- (and (equal (nth 1 math-simplify-expr) '(var e var-e))
- (math-simplify-exp (nth 2 math-simplify-expr)))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-exp)
+ (nth 1 (nth 1 expr))
+ (math-div (nth 2 expr) 2)))
+ (and (memq (car-safe (nth 1 expr)) '(* /))
+ (list (car (nth 1 expr))
+ (list '^ (nth 1 (nth 1 expr))
+ (nth 2 expr))
+ (list '^ (nth 2 (nth 1 expr))
+ (nth 2 expr))))))
+ (and (math-equal-int (nth 1 expr) 10)
+ (eq (car-safe (nth 2 expr)) 'calcFunc-log10)
+ (nth 1 (nth 2 expr)))
+ (and (equal (nth 1 expr) '(var e var-e))
+ (math-simplify-exp (nth 2 expr)))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-exp)
(not math-integrating)
- (list 'calcFunc-exp (math-mul (nth 1 (nth 1 math-simplify-expr))
- (nth 2 math-simplify-expr))))
- (and (equal (nth 1 math-simplify-expr) '(var i var-i))
+ (list 'calcFunc-exp (math-mul (nth 1 (nth 1 expr))
+ (nth 2 expr))))
+ (and (equal (nth 1 expr) '(var i var-i))
(math-imaginary-i)
- (math-num-integerp (nth 2 math-simplify-expr))
- (let ((x (math-mod (math-trunc (nth 2 math-simplify-expr)) 4)))
+ (math-num-integerp (nth 2 expr))
+ (let ((x (math-mod (math-trunc (nth 2 expr)) 4)))
(cond ((eq x 0) 1)
- ((eq x 1) (nth 1 math-simplify-expr))
+ ((eq x 1) (nth 1 expr))
((eq x 2) -1)
- ((eq x 3) (math-neg (nth 1 math-simplify-expr))))))
+ ((eq x 3) (math-neg (nth 1 expr))))))
(and math-integrating
- (integerp (nth 2 math-simplify-expr))
- (>= (nth 2 math-simplify-expr) 2)
- (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
- (math-mul (math-pow (nth 1 math-simplify-expr)
- (- (nth 2 math-simplify-expr) 2))
+ (integerp (nth 2 expr))
+ (>= (nth 2 expr) 2)
+ (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-cos)
+ (math-mul (math-pow (nth 1 expr)
+ (- (nth 2 expr) 2))
(math-sub 1
(math-sqr
(list 'calcFunc-sin
- (nth 1 (nth 1 math-simplify-expr)))))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cosh)
- (math-mul (math-pow (nth 1 math-simplify-expr)
- (- (nth 2 math-simplify-expr) 2))
+ (nth 1 (nth 1 expr)))))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-cosh)
+ (math-mul (math-pow (nth 1 expr)
+ (- (nth 2 expr) 2))
(math-add 1
(math-sqr
(list 'calcFunc-sinh
- (nth 1 (nth 1 math-simplify-expr)))))))))
- (and (eq (car-safe (nth 2 math-simplify-expr)) 'frac)
- (Math-ratp (nth 1 math-simplify-expr))
- (Math-posp (nth 1 math-simplify-expr))
- (if (equal (nth 2 math-simplify-expr) '(frac 1 2))
- (list 'calcFunc-sqrt (nth 1 math-simplify-expr))
- (let ((flr (math-floor (nth 2 math-simplify-expr))))
+ (nth 1 (nth 1 expr)))))))))
+ (and (eq (car-safe (nth 2 expr)) 'frac)
+ (Math-ratp (nth 1 expr))
+ (Math-posp (nth 1 expr))
+ (if (equal (nth 2 expr) '(frac 1 2))
+ (list 'calcFunc-sqrt (nth 1 expr))
+ (let ((flr (math-floor (nth 2 expr))))
(and (not (Math-zerop flr))
- (list '* (list '^ (nth 1 math-simplify-expr) flr)
- (list '^ (nth 1 math-simplify-expr)
- (math-sub (nth 2 math-simplify-expr) flr)))))))
- (and (eq (math-quarter-integer (nth 2 math-simplify-expr)) 2)
- (let ((temp (math-simplify-sqrt)))
+ (list '* (list '^ (nth 1 expr) flr)
+ (list '^ (nth 1 expr)
+ (math-sub (nth 2 expr) flr)))))))
+ (and (eq (math-quarter-integer (nth 2 expr)) 2)
+ (let ((temp (math-simplify-sqrt expr)))
(and temp
- (list '^ temp (math-mul (nth 2 math-simplify-expr) 2)))))))
+ (list '^ temp (math-mul (nth 2 expr) 2)))))))
(math-defsimplify calcFunc-log10
- (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
- (math-equal-int (nth 1 (nth 1 math-simplify-expr)) 10)
+ (and (eq (car-safe (nth 1 expr)) '^)
+ (math-equal-int (nth 1 (nth 1 expr)) 10)
(or math-living-dangerously
- (math-known-realp (nth 2 (nth 1 math-simplify-expr))))
- (nth 2 (nth 1 math-simplify-expr))))
+ (math-known-realp (nth 2 (nth 1 expr))))
+ (nth 2 (nth 1 expr))))
(math-defsimplify calcFunc-erf
- (or (and (math-looks-negp (nth 1 math-simplify-expr))
- (math-neg (list 'calcFunc-erf (math-neg (nth 1 math-simplify-expr)))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-conj)
+ (or (and (math-looks-negp (nth 1 expr))
+ (math-neg (list 'calcFunc-erf (math-neg (nth 1 expr)))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-conj)
(list 'calcFunc-conj
- (list 'calcFunc-erf (nth 1 (nth 1 math-simplify-expr)))))))
+ (list 'calcFunc-erf (nth 1 (nth 1 expr)))))))
(math-defsimplify calcFunc-erfc
- (or (and (math-looks-negp (nth 1 math-simplify-expr))
- (math-sub 2 (list 'calcFunc-erfc (math-neg (nth 1 math-simplify-expr)))))
- (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-conj)
+ (or (and (math-looks-negp (nth 1 expr))
+ (math-sub 2 (list 'calcFunc-erfc (math-neg (nth 1 expr)))))
+ (and (eq (car-safe (nth 1 expr)) 'calcFunc-conj)
(list 'calcFunc-conj
- (list 'calcFunc-erfc (nth 1 (nth 1 math-simplify-expr)))))))
+ (list 'calcFunc-erfc (nth 1 (nth 1 expr)))))))
(defun math-linear-in (expr term &optional always)
@@ -1614,10 +1606,12 @@
(defvar math-expr-subst-old)
(defvar math-expr-subst-new)
-(defun math-expr-subst (expr math-expr-subst-old math-expr-subst-new)
- (math-expr-subst-rec expr))
+(defun math-expr-subst (expr old new)
+ (let ((math-expr-subst-old old)
+ (math-expr-subst-new new))
+ (math-expr-subst-rec expr)))
-(defalias 'calcFunc-subst 'math-expr-subst)
+(defalias 'calcFunc-subst #'math-expr-subst)
(defun math-expr-subst-rec (expr)
(cond ((equal expr math-expr-subst-old) math-expr-subst-new)
@@ -1632,7 +1626,7 @@
(math-expr-subst-rec (nth 2 expr)))))
(t
(cons (car expr)
- (mapcar 'math-expr-subst-rec (cdr expr))))))
+ (mapcar #'math-expr-subst-rec (cdr expr))))))
;;; Various measures of the size of an expression.
(defun math-expr-weight (expr)
@@ -1659,7 +1653,7 @@
(defun calcFunc-collect (expr base)
(let ((p (math-is-polynomial expr base 50 t)))
(if (cdr p)
- (math-build-polynomial-expr (mapcar 'math-normalize p) base)
+ (math-build-polynomial-expr (mapcar #'math-normalize p) base)
(car p))))
;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...),
@@ -1672,13 +1666,16 @@
(defvar math-is-poly-loose)
(defvar math-var)
-(defun math-is-polynomial (expr math-var &optional math-is-poly-degree math-is-poly-loose)
- (let* ((math-poly-base-variable (if math-is-poly-loose
- (if (eq math-is-poly-loose 'gen) math-var '(var XXX XXX))
+(defun math-is-polynomial (expr var &optional degree loose)
+ (let* ((math-poly-base-variable (if loose
+ (if (eq loose 'gen) var '(var XXX XXX))
math-poly-base-variable))
+ (math-var var)
+ (math-is-poly-loose loose)
+ (math-is-poly-degree degree)
(poly (math-is-poly-rec expr math-poly-neg-powers)))
- (and (or (null math-is-poly-degree)
- (<= (length poly) (1+ math-is-poly-degree)))
+ (and (or (null degree)
+ (<= (length poly) (1+ degree)))
poly)))
(defun math-is-poly-rec (expr negpow)
@@ -1749,7 +1746,7 @@
(math-poly-mix p1 1 p2
(if (eq (car expr) '+) 1 -1)))))))
((eq (car expr) 'neg)
- (mapcar 'math-neg (math-is-poly-rec (nth 1 expr) negpow)))
+ (mapcar #'math-neg (math-is-poly-rec (nth 1 expr) negpow)))
((eq (car expr) '*)
(let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
(and p1
@@ -1812,24 +1809,20 @@
(math-expr-contains expr math-poly-base-variable)
(math-expr-depends expr var)))
-;;; Find the variable (or sub-expression) which is the base of polynomial expr.
;; The variables math-poly-base-const-ok and math-poly-base-pred are
;; local to math-polynomial-base, but are used by math-polynomial-base-rec.
(defvar math-poly-base-const-ok)
(defvar math-poly-base-pred)
-;; The variable math-poly-base-top-expr is local to math-polynomial-base,
-;; but is used by math-polynomial-p1 in calc-poly.el, which is called
-;; by math-polynomial-base.
-
-(defun math-polynomial-base (math-poly-base-top-expr &optional math-poly-base-pred)
- (or math-poly-base-pred
- (setq math-poly-base-pred (function (lambda (base) (math-polynomial-p
- math-poly-base-top-expr base)))))
+(defun math-polynomial-base (top-expr &optional pred)
+ "Find the variable (or sub-expression) which is the base of polynomial expr."
+ (let ((math-poly-base-pred
+ (or pred (function (lambda (base) (math-polynomial-p
+ top-expr base))))))
(or (let ((math-poly-base-const-ok nil))
- (math-polynomial-base-rec math-poly-base-top-expr))
+ (math-polynomial-base-rec top-expr))
(let ((math-poly-base-const-ok t))
- (math-polynomial-base-rec math-poly-base-top-expr))))
+ (math-polynomial-base-rec top-expr)))))
(defun math-polynomial-base-rec (mpb-expr)
(and (not (Math-objvecp mpb-expr))
@@ -1846,8 +1839,8 @@
(funcall math-poly-base-pred mpb-expr)
mpb-expr))))
-;;; Return non-nil if expr refers to any variables.
(defun math-expr-contains-vars (expr)
+ "Return non-nil if expr refers to any variables."
(or (eq (car-safe expr) 'var)
(and (not (Math-primp expr))
(progn
@@ -1855,9 +1848,9 @@
(not (math-expr-contains-vars (car expr)))))
expr))))
-;;; Simplify a polynomial in list form by stripping off high-end zeros.
-;;; This always leaves the constant part, i.e., nil->nil and non-nil->non-nil.
(defun math-poly-simplify (p)
+ "Simplify a polynomial in list form by stripping off high-end zeros.
+This always leaves the constant part, i.e., nil->nil and non-nil->non-nil."
(and p
(if (Math-zerop (nth (1- (length p)) p))
(let ((pp (copy-sequence p)))
@@ -1879,14 +1872,14 @@
(or (null a)
(and (null (cdr a)) (Math-zerop (car a)))))
-;;; Multiply two polynomials in list form.
(defun math-poly-mul (a b)
+ "Multiply two polynomials in list form."
(and a b
(math-poly-mix b (car a)
(math-poly-mul (cdr a) (cons 0 b)) 1)))
-;;; Build an expression from a polynomial list.
(defun math-build-polynomial-expr (p var)
+ "Build an expression from a polynomial list."
(if p
(if (Math-numberp var)
(math-with-extra-prec 1
@@ -1897,8 +1890,7 @@
accum))
(let* ((rp (reverse p))
(n (1- (length rp)))
- (accum (math-mul (car rp) (math-pow var n)))
- term)
+ (accum (math-mul (car rp) (math-pow var n))))
(while (setq rp (cdr rp))
(setq n (1- n))
(or (math-zerop (car rp))
diff --git a/lisp/calc/calc-bin.el b/lisp/calc/calc-bin.el
index a85792a6113..d979edb5fdb 100644
--- a/lisp/calc/calc-bin.el
+++ b/lisp/calc/calc-bin.el
@@ -420,7 +420,7 @@ the size of a Calc bignum digit.")
(let ((q (math-div-bignum-digit a math-bignum-digit-power-of-two)))
(if (<= w math-bignum-logb-digit-size)
(list (logand (lognot (cdr q))
- (1- (lsh 1 w))))
+ (1- (ash 1 w))))
(math-mul-bignum-digit (math-not-bignum (math-norm-bignum (car q))
(- w math-bignum-logb-digit-size))
math-bignum-digit-power-of-two
@@ -529,7 +529,7 @@ the size of a Calc bignum digit.")
((and (integerp a) (< a math-small-integer-size))
(if (> w (logb math-small-integer-size))
a
- (logand a (1- (lsh 1 w)))))
+ (logand a (1- (ash 1 w)))))
(t
(math-normalize
(cons 'bigpos
@@ -542,7 +542,7 @@ the size of a Calc bignum digit.")
(let ((q (math-div-bignum-digit a math-bignum-digit-power-of-two)))
(if (<= w math-bignum-logb-digit-size)
(list (logand (cdr q)
- (1- (lsh 1 w))))
+ (1- (ash 1 w))))
(math-mul-bignum-digit (math-clip-bignum (math-norm-bignum (car q))
(- w math-bignum-logb-digit-size))
math-bignum-digit-power-of-two
diff --git a/lisp/calc/calc-comb.el b/lisp/calc/calc-comb.el
index d74c815bd24..02779039610 100644
--- a/lisp/calc/calc-comb.el
+++ b/lisp/calc/calc-comb.el
@@ -580,7 +580,7 @@
;; deduce a better value for RAND_MAX.
(let ((i 0))
(while (< (setq i (1+ i)) 30)
- (if (> (lsh (math-abs (random)) math-random-shift) 4095)
+ (if (> (ash (math-abs (random)) math-random-shift) 4095)
(setq math-random-shift (1- math-random-shift))))))
(setq math-last-RandSeed var-RandSeed
math-gaussian-cache nil))
@@ -592,11 +592,11 @@
(cdr math-random-table))
math-random-ptr2 (or (cdr math-random-ptr2)
(cdr math-random-table)))
- (logand (lsh (setcar math-random-ptr1
+ (logand (ash (setcar math-random-ptr1
(logand (- (car math-random-ptr1)
(car math-random-ptr2)) 524287))
-6) 1023))
- (logand (lsh (random) math-random-shift) 1023)))
+ (logand (ash (random) math-random-shift) 1023)))
;;; Produce a random digit in the range 0..999.
diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el
index f2e70906e94..1456fb28570 100644
--- a/lisp/calc/calc-ext.el
+++ b/lisp/calc/calc-ext.el
@@ -1,4 +1,4 @@
-;;; calc-ext.el --- various extension functions for Calc
+;;; calc-ext.el --- various extension functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2019 Free Software Foundation, Inc.
@@ -88,7 +88,7 @@
(defvar calc-alg-map)
(defvar calc-alg-esc-map)
-;;; The following was made a function so that it could be byte-compiled.
+;; The following was made a function so that it could be byte-compiled.
(defun calc-init-extensions ()
(define-key calc-mode-map ":" 'calc-fdiv)
@@ -714,8 +714,8 @@
;;;; (Autoloads here)
(mapc (function (lambda (x)
- (mapcar (function (lambda (func)
- (autoload func (car x)))) (cdr x))))
+ (mapcar (function (lambda (func) (autoload func (car x))))
+ (cdr x))))
'(
("calc-alg" calc-has-rules math-defsimplify
@@ -894,8 +894,8 @@ calcFunc-pcont calcFunc-pdeg calcFunc-pdiv calcFunc-pdivide
calcFunc-pdivrem calcFunc-pgcd calcFunc-plead calcFunc-pprim
calcFunc-prem math-accum-factors math-atomic-factorp
math-div-poly-const math-div-thru math-expand-power math-expand-term
-math-factor-contains math-factor-expr math-factor-expr-part
-math-factor-expr-try math-factor-finish math-factor-poly-coefs
+math-factor-contains math-factor-expr
+math-factor-finish
math-factor-protect math-mul-thru math-padded-polynomial
math-partial-fractions math-poly-degree math-poly-deriv-coefs
math-poly-gcd-frac-list math-poly-modulus-rec math-ratpoly-p
@@ -984,8 +984,8 @@ calc-force-refresh calc-locate-cursor-element calc-show-edit-buffer)
))
(mapcar (function (lambda (x)
- (mapcar (function (lambda (cmd)
- (autoload cmd (car x) nil t))) (cdr x))))
+ (mapcar (function (lambda (cmd) (autoload cmd (car x) nil t)))
+ (cdr x))))
'(
("calc-alg" calc-alg-evaluate calc-apart calc-collect calc-expand
@@ -1307,8 +1307,9 @@ calc-kill calc-kill-region calc-yank))))
(message "%s" (if msg
(concat group ": " msg ":"
(make-string
- (- (apply 'max (mapcar 'length msgs))
- (length msg)) 32)
+ (- (apply #'max (mapcar #'length msgs))
+ (length msg))
+ ?\s)
" [MORE]"
(if key
(concat " " (char-to-string key)
@@ -1334,6 +1335,8 @@ calc-kill calc-kill-region calc-yank))))
;;; General.
+(defvar calc-embedded-quiet)
+
(defun calc-reset (arg)
(interactive "P")
(setq arg (if arg (prefix-numeric-value arg) nil))
@@ -1398,7 +1401,7 @@ calc-kill calc-kill-region calc-yank))))
(defun calc-scroll-up (n)
(interactive "P")
- (condition-case err
+ (condition-case nil
(scroll-up (or n (/ (window-height) 2)))
(error nil))
(if (pos-visible-in-window-p (max 1 (- (point-max) 2)))
@@ -1657,7 +1660,7 @@ calc-kill calc-kill-region calc-yank))))
(let ((entries (calc-top-list n 1 'entry))
(calc-undo-list nil) (calc-redo-list nil))
(calc-pop-stack n 1 t)
- (calc-push-list (mapcar 'car entries)
+ (calc-push-list (mapcar #'car entries)
1
(mapcar (function (lambda (x) (nth 2 x)))
entries)))))))
@@ -1707,7 +1710,7 @@ calc-kill calc-kill-region calc-yank))))
(calc-pop-push-record-list 1 "eval"
(math-evaluate-expr (calc-top (- n)))
(- n))
- (calc-pop-push-record-list n "eval" (mapcar 'math-evaluate-expr
+ (calc-pop-push-record-list n "eval" (mapcar #'math-evaluate-expr
(calc-top-list n)))))
(calc-handle-whys)))
@@ -1928,7 +1931,7 @@ calc-kill calc-kill-region calc-yank))))
(calc-z-prefix-buf "")
(kmap (sort (copy-sequence (calc-user-key-map))
(function (lambda (x y) (< (car x) (car y))))))
- (flags (apply 'logior
+ (flags (apply #'logior
(mapcar (function
(lambda (k)
(calc-user-function-classify (car k))))
@@ -2003,12 +2006,13 @@ calc-kill calc-kill-region calc-yank))))
;;;; Caches.
(defmacro math-defcache (name init form)
+ (declare (indent 2) (debug (symbolp sexp form)))
(let ((cache-prec (intern (concat (symbol-name name) "-cache-prec")))
(cache-val (intern (concat (symbol-name name) "-cache")))
(last-prec (intern (concat (symbol-name name) "-last-prec")))
(last-val (intern (concat (symbol-name name) "-last"))))
`(progn
-; (defvar ,cache-prec ,(if init (math-numdigs (nth 1 init)) -100))
+ ;; (defvar ,cache-prec ,(if init (math-numdigs (nth 1 init)) -100))
(defvar ,cache-prec (cond
((consp ,init) (math-numdigs (nth 1 ,init)))
(,init
@@ -2037,7 +2041,6 @@ calc-kill calc-kill-region calc-yank))))
,cache-val))
,last-prec calc-internal-prec))
,last-val))))
-(put 'math-defcache 'lisp-indent-hook 2)
;;; Betcha didn't know that pi = 16 atan(1/5) - 4 atan(1/239). [F] [Public]
(defconst math-approx-pi
@@ -2294,14 +2297,14 @@ calc-kill calc-kill-region calc-yank))))
(let ((a (math-trunc a)))
(if (integerp a)
a
- (if (or (Math-lessp (lsh -1 -1) a)
- (Math-lessp a (- (lsh -1 -1))))
+ (if (or (Math-lessp most-positive-fixnum a)
+ (Math-lessp a (- most-positive-fixnum)))
(math-reject-arg a 'fixnump)
(math-fixnum a)))))
((and allow-inf (equal a '(var inf var-inf)))
- (lsh -1 -1))
+ most-positive-fixnum)
((and allow-inf (equal a '(neg (var inf var-inf))))
- (- (lsh -1 -1)))
+ (- most-positive-fixnum))
(t (math-reject-arg a 'fixnump))))
;;; Verify that A is an integer >= 0 and return A in integer form. [I N; - x]
@@ -2400,7 +2403,7 @@ If X is not an error form, return 1."
(list 'calcFunc-intv mask lo hi)
(math-make-intv mask lo hi))))
((eq (car a) 'vec)
- (cons 'vec (mapcar 'math-normalize (cdr a))))
+ (cons 'vec (mapcar #'math-normalize (cdr a))))
((eq (car a) 'quote)
(math-normalize (nth 1 a)))
((eq (car a) 'special-const)
@@ -2412,7 +2415,7 @@ If X is not an error form, return 1."
(math-normalize-logical-op a))
((memq (car a) '(calcFunc-lambda calcFunc-quote calcFunc-condition))
(let ((calc-simplify-mode 'none))
- (cons (car a) (mapcar 'math-normalize (cdr a)))))
+ (cons (car a) (mapcar #'math-normalize (cdr a)))))
((eq (car a) 'calcFunc-evalto)
(setq a (or (nth 1 a) 0))
(or calc-refreshing-evaltos
@@ -2435,27 +2438,25 @@ If X is not an error form, return 1."
;; The variable math-normalize-a is local to math-normalize in calc.el,
;; but is used by math-normalize-nonstandard, which is called by
;; math-normalize.
-(defvar math-normalize-a)
-
-(defun math-normalize-nonstandard ()
+(defun math-normalize-nonstandard (a)
(if (consp calc-simplify-mode)
(progn
(setq calc-simplify-mode 'none
- math-simplify-only (car-safe (cdr-safe math-normalize-a)))
+ math-simplify-only (car-safe (cdr-safe a)))
nil)
- (and (symbolp (car math-normalize-a))
+ (and (symbolp (car a))
(or (eq calc-simplify-mode 'none)
(and (eq calc-simplify-mode 'num)
- (let ((aptr (setq math-normalize-a
+ (let ((aptr (setq a
(cons
- (car math-normalize-a)
- (mapcar 'math-normalize
- (cdr math-normalize-a))))))
+ (car a)
+ (mapcar #'math-normalize
+ (cdr a))))))
(while (and aptr (math-constp (car aptr)))
(setq aptr (cdr aptr)))
aptr)))
- (cons (car math-normalize-a)
- (mapcar 'math-normalize (cdr math-normalize-a))))))
+ (cons (car a)
+ (mapcar #'math-normalize (cdr a))))))
;;; Normalize a bignum digit list by trimming high-end zeros. [L l]
@@ -2808,7 +2809,7 @@ If X is not an error form, return 1."
x)
(if (Math-primp x)
x
- (cons (car x) (mapcar 'math-evaluate-expr-rec (cdr x))))))
+ (cons (car x) (mapcar #'math-evaluate-expr-rec (cdr x))))))
x))
(defun math-any-floats (expr)
@@ -2822,9 +2823,10 @@ If X is not an error form, return 1."
(defvar math-mt-many nil)
(defvar math-mt-func nil)
-(defun math-map-tree (math-mt-func mmt-expr &optional math-mt-many)
- (or math-mt-many (setq math-mt-many 1000000))
- (math-map-tree-rec mmt-expr))
+(defun math-map-tree (func mmt-expr &optional many)
+ (let ((math-mt-func func)
+ (math-mt-many (or many 1000000)))
+ (math-map-tree-rec mmt-expr)))
(defun math-map-tree-rec (mmt-expr)
(or (= math-mt-many 0)
@@ -2842,7 +2844,7 @@ If X is not an error form, return 1."
(<= math-mt-many 0))
(setq mmt-done t)
(setq mmt-nextval (cons (car mmt-expr)
- (mapcar 'math-map-tree-rec
+ (mapcar #'math-map-tree-rec
(cdr mmt-expr))))
(if (equal mmt-nextval mmt-expr)
(setq mmt-done t)
@@ -2867,6 +2869,7 @@ If X is not an error form, return 1."
(defvar math-integral-cache)
(defmacro math-defintegral (funcs &rest code)
+ (declare (indent 1) (debug (sexp body)))
(setq math-integral-cache nil)
(cons 'progn
(mapcar #'(lambda (func)
@@ -2876,9 +2879,9 @@ If X is not an error form, return 1."
(list
#'(lambda (u) ,@code)))))
(if (symbolp funcs) (list funcs) funcs))))
-(put 'math-defintegral 'lisp-indent-hook 1)
(defmacro math-defintegral-2 (funcs &rest code)
+ (declare (indent 1) (debug (sexp body)))
(setq math-integral-cache nil)
(cons 'progn
(mapcar #'(lambda (func)
@@ -2887,7 +2890,6 @@ If X is not an error form, return 1."
(get ',func 'math-integral-2)
(list #'(lambda (u v) ,@code)))))
(if (symbolp funcs) (list funcs) funcs))))
-(put 'math-defintegral-2 'lisp-indent-hook 1)
(defvar var-IntegAfterRules 'calc-IntegAfterRules)
@@ -3097,9 +3099,16 @@ If X is not an error form, return 1."
;;; Expression parsing.
(defvar math-expr-data)
+(defvar math-exp-pos)
+(defvar math-exp-old-pos)
+(defvar math-exp-keep-spaces)
+(defvar math-exp-token)
+(defvar math-expr-data)
+(defvar math-exp-str)
-(defun math-read-expr (math-exp-str)
+(defun math-read-expr (str)
(let ((math-exp-pos 0)
+ (math-exp-str str)
(math-exp-old-pos 0)
(math-exp-keep-spaces nil)
math-exp-token math-expr-data)
@@ -3138,6 +3147,10 @@ If X is not an error form, return 1."
;;; They said it couldn't be done...
+(defvar math-read-big-baseline)
+(defvar math-read-big-h2)
+(defvar math-read-big-err-msg)
+
(defun math-read-big-expr (str)
(and (> (length calc-left-label) 0)
(string-match (concat "^" (regexp-quote calc-left-label)) str)
@@ -3179,6 +3192,8 @@ If X is not an error form, return 1."
'(error 0 "Syntax error"))
(math-read-expr str)))))
+(defvar math-rb-h2)
+
(defun math-read-big-bigp (math-read-big-lines)
(and (cdr math-read-big-lines)
(let ((matrix nil)
diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el
index e521eaeaff2..fce82d2eaac 100644
--- a/lisp/calc/calc-forms.el
+++ b/lisp/calc/calc-forms.el
@@ -37,13 +37,11 @@
(defun calc-time ()
(interactive)
(calc-wrapper
- (let ((time (current-time-string)))
+ (let ((time (decode-time)))
(calc-enter-result 0 "time"
(list 'mod
(list 'hms
- (string-to-number (substring time 11 13))
- (string-to-number (substring time 14 16))
- (string-to-number (substring time 17 19)))
+ (nth 2 time) (nth 1 time) (nth 0 time))
(list 'hms 24 0 0))))))
(defun calc-to-hms (arg)
@@ -62,7 +60,7 @@
(defun calc-hms-notation (fmt)
- (interactive "sHours-minutes-seconds format (hms, @ \\=' \", etc.): ")
+ (interactive "sHours-minutes-seconds format (hms, @ ' \", etc.): ")
(calc-wrapper
(if (string-match "\\`\\([^,; ]+\\)\\([,; ]*\\)\\([^,; ]\\)\\([,; ]*\\)\\([^,; ]\\)\\'" fmt)
(progn
@@ -1341,16 +1339,15 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)."
(math-parse-iso-date-validate isoyear isoweek isoweekday hour minute second)))))
(defun calcFunc-now (&optional zone)
- (let ((date (let ((calc-date-format nil))
- (math-parse-date (current-time-string)))))
- (if (consp date)
- (if zone
- (math-add date (math-div (math-sub (calcFunc-tzone nil date)
- (calcFunc-tzone zone date))
- '(float 864 2)))
- date)
- (calc-record-why "*Unable to interpret current date from system")
- (append (list 'calcFunc-now) (and zone (list zone))))))
+ (let ((date (let ((now (decode-time)))
+ (list 'date (math-dt-to-date
+ (list (nth 5 now) (nth 4 now) (nth 3 now)
+ (nth 2 now) (nth 1 now) (nth 0 now)))))))
+ (if zone
+ (math-add date (math-div (math-sub (calcFunc-tzone nil date)
+ (calcFunc-tzone zone date))
+ '(float 864 2)))
+ date)))
(defun calcFunc-year (date)
(car (math-date-to-dt date)))
diff --git a/lisp/calc/calc-graph.el b/lisp/calc/calc-graph.el
index 317f403ead6..56f11c67119 100644
--- a/lisp/calc/calc-graph.el
+++ b/lisp/calc/calc-graph.el
@@ -1121,7 +1121,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(eval (intern
(concat "var-"
(save-excursion
- (re-search-backward ":\\(.*\\)\\}")
+ (re-search-backward ":\\(.*\\)}")
(match-string 1))))))
(error nil)))
(if yerr
@@ -1186,7 +1186,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(or (looking-at "{")
(error "Can't hide this curve (wrong format)"))
(forward-char 1)
- (if (looking-at "*")
+ (if (looking-at "\\*")
(if (or (null flag) (<= (prefix-numeric-value flag) 0))
(delete-char 1))
(if (or (null flag) (> (prefix-numeric-value flag) 0))
diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el
index cf7574e7385..d9e8fe779bf 100644
--- a/lisp/calc/calc-help.el
+++ b/lisp/calc/calc-help.el
@@ -172,7 +172,7 @@ C-w Describe how there is no warranty for Calc."
(setq desc (concat "M-" (substring desc 4))))
(while (string-match "^M-# \\(ESC \\|C-\\)" desc)
(setq desc (concat "M-# " (substring desc (match-end 0)))))
- (if (string-match "\\(DEL\\|\\LFD\\|RET\\|SPC\\|TAB\\)" desc)
+ (if (string-match "\\(DEL\\|LFD\\|RET\\|SPC\\|TAB\\)" desc)
(setq desc (replace-match "<\\&>" nil nil desc)))
(if briefly
(let ((msg (with-current-buffer (get-buffer-create "*Calc Summary*")
diff --git a/lisp/calc/calc-lang.el b/lisp/calc/calc-lang.el
index 3f55fb15d56..ee107df39c1 100644
--- a/lisp/calc/calc-lang.el
+++ b/lisp/calc/calc-lang.el
@@ -753,8 +753,8 @@
right " \\right)"))
((and (eq (aref func 0) ?\\)
(not (or
- (string-match "\\hbox{" func)
- (string-match "\\text{" func)))
+ (string-match "\\\\hbox{" func)
+ (string-match "\\\\text{" func)))
(= (length a) 2)
(or (Math-realp (nth 1 a))
(memq (car (nth 1 a)) '(var *))))
@@ -1127,7 +1127,7 @@
(math-read-token)))))))
(put 'eqn 'math-lang-read
- '((eq (string-match "->\\|<-\\|+-\\|\\\\dots\\|~\\|\\^"
+ '((eq (string-match "->\\|<-\\|\\+-\\|\\\\dots\\|~\\|\\^"
math-exp-str math-exp-pos)
math-exp-pos)
(progn
diff --git a/lisp/calc/calc-math.el b/lisp/calc/calc-math.el
index 50c8758ace2..62fe3d4b3c0 100644
--- a/lisp/calc/calc-math.el
+++ b/lisp/calc/calc-math.el
@@ -1697,7 +1697,7 @@ If this can't be done, return NIL."
(while (not (Math-lessp x pow))
(setq pows (cons pow pows)
pow (math-sqr pow)))
- (setq n (lsh 1 (1- (length pows)))
+ (setq n (ash 1 (1- (length pows)))
sum n
pow (car pows))
(while (and (setq pows (cdr pows))
diff --git a/lisp/calc/calc-poly.el b/lisp/calc/calc-poly.el
index 7e3e423868c..5fba85e059d 100644
--- a/lisp/calc/calc-poly.el
+++ b/lisp/calc/calc-poly.el
@@ -1,4 +1,4 @@
-;;; calc-poly.el --- polynomial functions for Calc
+;;; calc-poly.el --- polynomial functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2019 Free Software Foundation, Inc.
@@ -177,8 +177,8 @@
(math-add (car res) (math-div (cdr res) pd))))
-;;; Multiply two terms, expanding out products of sums.
(defun math-mul-thru (lhs rhs)
+ "Multiply two terms, expanding out products of sums."
(if (memq (car-safe lhs) '(+ -))
(list (car lhs)
(math-mul-thru (nth 1 lhs) rhs)
@@ -197,8 +197,8 @@
(math-div num den)))
-;;; Sort the terms of a sum into canonical order.
(defun math-sort-terms (expr)
+ "Sort the terms of a sum into canonical order."
(if (memq (car-safe expr) '(+ -))
(math-list-to-sum
(sort (math-sum-to-list expr)
@@ -223,8 +223,8 @@
(math-sum-to-list (nth 2 tree) (not neg))))
(t (list (cons tree neg)))))
-;;; Check if the polynomial coefficients are modulo forms.
(defun math-poly-modulus (expr &optional expr2)
+ "Check if the polynomial coefficients are modulo forms."
(or (math-poly-modulus-rec expr)
(and expr2 (math-poly-modulus-rec expr2))
1))
@@ -237,12 +237,13 @@
(math-poly-modulus-rec (nth 2 expr))))))
-;;; Divide two polynomials. Return (quotient . remainder).
(defvar math-poly-div-base nil)
-(defun math-poly-div (u v &optional math-poly-div-base)
- (if math-poly-div-base
- (math-do-poly-div u v)
- (math-do-poly-div (calcFunc-expand u) (calcFunc-expand v))))
+(defun math-poly-div (u v &optional div-base)
+ "Divide two polynomials. Return (quotient . remainder)."
+ (let ((math-poly-div-base div-base))
+ (if div-base
+ (math-do-poly-div u v)
+ (math-do-poly-div (calcFunc-expand u) (calcFunc-expand v)))))
(defun math-poly-div-exact (u v &optional base)
(let ((res (math-poly-div u v base)))
@@ -308,8 +309,8 @@
(math-div (math-build-polynomial-expr (cdr res) base)
v)))))))
-;;; Divide two polynomials in coefficient-list form. Return (quot . rem).
(defun math-poly-div-coefs (u v)
+ "Divide two polynomials in coefficient-list form. Return (quot . rem)."
(cond ((null v) (math-reject-arg nil "Division by zero"))
((< (length u) (length v)) (cons nil u))
((cdr u)
@@ -334,9 +335,9 @@
(cons (list (math-poly-div-rec (car u) (car v)))
nil))))
-;;; Perform a pseudo-division of polynomials. (See Knuth section 4.6.1.)
-;;; This returns only the remainder from the pseudo-division.
(defun math-poly-pseudo-div (u v)
+ "Perform a pseudo-division of polynomials. (See Knuth section 4.6.1.)
+This returns only the remainder from the pseudo-division."
(cond ((null v) nil)
((< (length u) (length v)) u)
((or (cdr u) (cdr v))
@@ -359,8 +360,8 @@
(nreverse (mapcar 'math-simplify urev))))
(t nil)))
-;;; Compute the GCD of two multivariate polynomials.
(defun math-poly-gcd (u v)
+ "Compute the GCD of two multivariate polynomials."
(cond ((Math-equal u v) u)
((math-constp u)
(if (Math-zerop u)
@@ -423,7 +424,7 @@
(defun math-poly-gcd-coefs (u v)
(let ((d (math-poly-gcd (math-poly-gcd-list u)
(math-poly-gcd-list v)))
- (g 1) (h 1) (z 0) hh r delta ghd)
+ (g 1) (h 1) (z 0) r delta)
(while (and u v (Math-zerop (car u)) (Math-zerop (car v)))
(setq u (cdr u) v (cdr v) z (1+ z)))
(or (eq d 1)
@@ -452,8 +453,8 @@
v))
-;;; Return true if is a factor containing no sums or quotients.
(defun math-atomic-factorp (expr)
+ "Return true if is a factor containing no sums or quotients."
(cond ((eq (car-safe expr) '*)
(and (math-atomic-factorp (nth 1 expr))
(math-atomic-factorp (nth 2 expr))))
@@ -463,14 +464,13 @@
(math-atomic-factorp (nth 1 expr)))
(t t)))
-;;; Find a suitable base for dividing a by b.
-;;; The base must exist in both expressions.
-;;; The degree in the numerator must be higher or equal than the
-;;; degree in the denominator.
-;;; If the above conditions are not met the quotient is just a remainder.
-;;; Return nil if this is the case.
-
(defun math-poly-div-base (a b)
+ "Find a suitable base for dividing a by b.
+The base must exist in both expressions.
+The degree in the numerator must be higher or equal than the
+degree in the denominator.
+If the above conditions are not met the quotient is just a remainder.
+Return nil if this is the case."
(let (a-base b-base)
(and (setq a-base (math-total-polynomial-base a))
(setq b-base (math-total-polynomial-base b))
@@ -482,12 +482,11 @@
(throw 'return (car (car a-base))))))
(setq a-base (cdr a-base)))))))
-;;; Same as above but for gcd algorithm.
-;;; Here there is no requirement that degree(a) > degree(b).
-;;; Take the base that has the highest degree considering both a and b.
-;;; ("a^20+b^21+x^3+a+b", "a+b^2+x^5+a^22+b^10") --> (a 22)
-
(defun math-poly-gcd-base (a b)
+ "Same as `math-poly-div-base' but for gcd algorithm.
+Here there is no requirement that degree(a) > degree(b).
+Take the base that has the highest degree considering both a and b.
+ (\"a^20+b^21+x^3+a+b\", \"a+b^2+x^5+a^22+b^10\") --> (a 22)"
(let (a-base b-base)
(and (setq a-base (math-total-polynomial-base a))
(setq b-base (math-total-polynomial-base b))
@@ -501,8 +500,8 @@
(throw 'return (car (car b-base)))
(setq b-base (cdr b-base)))))))))
-;;; Sort a list of polynomial bases.
(defun math-sort-poly-base-list (lst)
+ "Sort a list of polynomial bases."
(sort lst (function (lambda (a b)
(or (> (nth 1 a) (nth 1 b))
(and (= (nth 1 a) (nth 1 b))
@@ -511,21 +510,18 @@
;;; Given an expression find all variables that are polynomial bases.
;;; Return list in the form '( (var1 degree1) (var2 degree2) ... ).
-;; The variable math-poly-base-total-base is local to
-;; math-total-polynomial-base, but is used by math-polynomial-p1,
-;; which is called by math-total-polynomial-base.
+;; The variable math-poly-base-total-base and math-poly-base-top-expr are local
+;; to math-total-polynomial-base, but used by math-polynomial-p1, which is
+;; called by math-total-polynomial-base.
(defvar math-poly-base-total-base)
+(defvar math-poly-base-top-expr)
(defun math-total-polynomial-base (expr)
- (let ((math-poly-base-total-base nil))
- (math-polynomial-base expr 'math-polynomial-p1)
+ (let ((math-poly-base-total-base nil)
+ (math-poly-base-top-expr expr))
+ (math-polynomial-base expr #'math-polynomial-p1)
(math-sort-poly-base-list math-poly-base-total-base)))
-;; The variable math-poly-base-top-expr is local to math-polynomial-base
-;; in calc-alg.el, but is used by math-polynomial-p1 which is called
-;; by math-polynomial-base.
-(defvar math-poly-base-top-expr)
-
(defun math-polynomial-p1 (subexpr)
(or (assoc subexpr math-poly-base-total-base)
(memq (car subexpr) '(+ - * / neg))
@@ -554,28 +550,30 @@
;; called (indirectly) by calcFunc-factors and calcFunc-factor.
(defvar math-to-list)
-(defun calcFunc-factors (math-fact-expr &optional var)
+(defun calcFunc-factors (expr &optional var)
(let ((math-factored-vars (if var t nil))
(math-to-list t)
(calc-prefer-frac t))
(or var
- (setq var (math-polynomial-base math-fact-expr)))
+ (setq var (math-polynomial-base expr)))
(let ((res (math-factor-finish
- (or (catch 'factor (math-factor-expr-try var))
- math-fact-expr))))
+ (or (catch 'factor
+ (let ((math-fact-expr expr)) (math-factor-expr-try var)))
+ expr))))
(math-simplify (if (math-vectorp res)
res
(list 'vec (list 'vec res 1)))))))
-(defun calcFunc-factor (math-fact-expr &optional var)
+(defun calcFunc-factor (expr &optional var)
(let ((math-factored-vars nil)
(math-to-list nil)
(calc-prefer-frac t))
(math-simplify (math-factor-finish
(if var
- (let ((math-factored-vars t))
- (or (catch 'factor (math-factor-expr-try var)) math-fact-expr))
- (math-factor-expr math-fact-expr))))))
+ (let ((math-factored-vars t)
+ (math-fact-expr expr))
+ (or (catch 'factor (math-factor-expr-try var)) expr))
+ (math-factor-expr expr))))))
(defun math-factor-finish (x)
(if (Math-primp x)
@@ -589,18 +587,19 @@
(list 'calcFunc-Fac-Prot x)
x))
-(defun math-factor-expr (math-fact-expr)
- (cond ((eq math-factored-vars t) math-fact-expr)
- ((or (memq (car-safe math-fact-expr) '(* / ^ neg))
- (assq (car-safe math-fact-expr) calc-tweak-eqn-table))
- (cons (car math-fact-expr) (mapcar 'math-factor-expr (cdr math-fact-expr))))
- ((memq (car-safe math-fact-expr) '(+ -))
+(defun math-factor-expr (expr)
+ (cond ((eq math-factored-vars t) expr)
+ ((or (memq (car-safe expr) '(* / ^ neg))
+ (assq (car-safe expr) calc-tweak-eqn-table))
+ (cons (car expr) (mapcar 'math-factor-expr (cdr expr))))
+ ((memq (car-safe expr) '(+ -))
(let* ((math-factored-vars math-factored-vars)
- (y (catch 'factor (math-factor-expr-part math-fact-expr))))
+ (y (catch 'factor (let ((math-fact-expr expr))
+ (math-factor-expr-part expr)))))
(if y
(math-factor-expr y)
- math-fact-expr)))
- (t math-fact-expr)))
+ expr)))
+ (t expr)))
(defun math-factor-expr-part (x) ; uses "expr"
(if (memq (car-safe x) '(+ - * / ^ neg))
@@ -616,20 +615,20 @@
;; used by math-factor-poly-coefs, which is called by math-factor-expr-try.
(defvar math-fet-x)
-(defun math-factor-expr-try (math-fet-x)
+(defun math-factor-expr-try (x)
(if (eq (car-safe math-fact-expr) '*)
(let ((res1 (catch 'factor (let ((math-fact-expr (nth 1 math-fact-expr)))
- (math-factor-expr-try math-fet-x))))
+ (math-factor-expr-try x))))
(res2 (catch 'factor (let ((math-fact-expr (nth 2 math-fact-expr)))
- (math-factor-expr-try math-fet-x)))))
+ (math-factor-expr-try x)))))
(and (or res1 res2)
(throw 'factor (math-accum-factors (or res1 (nth 1 math-fact-expr)) 1
(or res2 (nth 2 math-fact-expr))))))
- (let* ((p (math-is-polynomial math-fact-expr math-fet-x 30 'gen))
+ (let* ((p (math-is-polynomial math-fact-expr x 30 'gen))
(math-poly-modulus (math-poly-modulus math-fact-expr))
res)
(and (cdr p)
- (setq res (math-factor-poly-coefs p))
+ (setq res (let ((math-fet-x x)) (math-factor-poly-coefs p)))
(throw 'factor res)))))
(defun math-accum-factors (fac pow facs)
@@ -735,7 +734,6 @@
(let ((roots (car t1))
(csign (if (math-negp (nth (1- (length p)) p)) -1 1))
(expr 1)
- (unfac (nth 1 t1))
(scale (nth 2 t1)))
(while roots
(let ((coef0 (car (car roots)))
@@ -1108,7 +1106,7 @@ If no partial fraction representation can be found, return nil."
(t expr)))
(defun calcFunc-expand (expr &optional many)
- (math-normalize (math-map-tree 'math-expand-term expr many)))
+ (math-normalize (math-map-tree #'math-expand-term expr many)))
(defun math-expand-power (x n &optional var else-nil)
(or (and (natnump n)
diff --git a/lisp/calc/calc-store.el b/lisp/calc/calc-store.el
index 589a776c413..3987c129c23 100644
--- a/lisp/calc/calc-store.el
+++ b/lisp/calc/calc-store.el
@@ -405,8 +405,8 @@
sconst))))
(if var
(let ((msg (calc-store-value var value "")))
- (message (concat "Special constant \"%s\" copied to \"%s\"" msg)
- sconst (calc-var-name var)))))))))
+ (message "Special constant \"%s\" copied to \"%s\"%s"
+ sconst (calc-var-name var) msg))))))))
(defun calc-copy-variable (&optional var1 var2)
(interactive)
diff --git a/lisp/calc/calc-units.el b/lisp/calc/calc-units.el
index 8794d1f3c67..86bebe6a9ed 100644
--- a/lisp/calc/calc-units.el
+++ b/lisp/calc/calc-units.el
@@ -1,4 +1,4 @@
-;;; calc-units.el --- unit conversion functions for Calc
+;;; calc-units.el --- unit conversion functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2019 Free Software Foundation, Inc.
@@ -455,7 +455,6 @@ If COMP or STD is non-nil, put that in the units table instead."
(uoldname nil)
(unitscancel nil)
(nouold nil)
- unew
units
defunits)
(if (or (not (math-units-in-expr-p expr t))
@@ -672,8 +671,8 @@ If COMP or STD is non-nil, put that in the units table instead."
(substring name (1+ pos)))))
(setq name (concat "(" name ")"))))
(or (eq (nth 1 expr) (car u))
- (setq name (concat (nth 2 (assq (aref (symbol-name
- (nth 1 expr)) 0)
+ (setq name (concat (nth 2 (assq (aref (symbol-name (nth 1 expr))
+ 0)
math-unit-prefixes))
(if (and (string-match "[^a-zA-Zα-ωΑ-Ω0-9']" name)
(not (memq (car u) '(mHg gf))))
@@ -857,7 +856,7 @@ If COMP or STD is non-nil, put that in the units table instead."
(or math-units-table
(let* ((combined-units (append math-additional-units
math-standard-units))
- (math-cu-unit-list (mapcar 'car combined-units))
+ (math-cu-unit-list (mapcar #'car combined-units))
tab)
(message "Building units table...")
(setq math-units-table-buffer-valid nil)
@@ -880,7 +879,7 @@ If COMP or STD is non-nil, put that in the units table instead."
(nth 4 x))))
combined-units))
(let ((math-units-table tab))
- (mapc 'math-find-base-units tab))
+ (mapc #'math-find-base-units tab))
(message "Building units table...done")
(setq math-units-table tab))))
@@ -890,15 +889,16 @@ If COMP or STD is non-nil, put that in the units table instead."
(defvar math-fbu-base)
(defvar math-fbu-entry)
-(defun math-find-base-units (math-fbu-entry)
- (if (eq (nth 4 math-fbu-entry) 'boom)
- (error "Circular definition involving unit %s" (car math-fbu-entry)))
- (or (nth 4 math-fbu-entry)
- (let (math-fbu-base)
- (setcar (nthcdr 4 math-fbu-entry) 'boom)
- (math-find-base-units-rec (nth 1 math-fbu-entry) 1)
+(defun math-find-base-units (entry)
+ (if (eq (nth 4 entry) 'boom)
+ (error "Circular definition involving unit %s" (car entry)))
+ (or (nth 4 entry)
+ (let (math-fbu-base
+ (math-fbu-entry entry))
+ (setcar (nthcdr 4 entry) 'boom)
+ (math-find-base-units-rec (nth 1 entry) 1)
'(or math-fbu-base
- (error "Dimensionless definition for unit %s" (car math-fbu-entry)))
+ (error "Dimensionless definition for unit %s" (car entry)))
(while (eq (cdr (car math-fbu-base)) 0)
(setq math-fbu-base (cdr math-fbu-base)))
(let ((b math-fbu-base))
@@ -907,7 +907,7 @@ If COMP or STD is non-nil, put that in the units table instead."
(setcdr b (cdr (cdr b)))
(setq b (cdr b)))))
(setq math-fbu-base (sort math-fbu-base 'math-compare-unit-names))
- (setcar (nthcdr 4 math-fbu-entry) math-fbu-base)
+ (setcar (nthcdr 4 entry) math-fbu-base)
math-fbu-base)))
(defun math-compare-unit-names (a b)
@@ -942,7 +942,8 @@ If COMP or STD is non-nil, put that in the units table instead."
(error "Unknown name %s in defining expression for unit %s"
(nth 1 expr) (car math-fbu-entry))))
((equal expr '(calcFunc-ln 10)))
- (t (error "Malformed defining expression for unit %s" (car math-fbu-entry))))))
+ (t (error "Malformed defining expression for unit %s"
+ (car math-fbu-entry))))))
(defun math-units-in-expr-p (expr sub-exprs)
@@ -1018,8 +1019,9 @@ If COMP or STD is non-nil, put that in the units table instead."
;; math-to-standard-units.
(defvar math-which-standard)
-(defun math-to-standard-units (expr math-which-standard)
- (math-to-standard-rec expr))
+(defun math-to-standard-units (expr which-standard)
+ (let ((math-which-standard which-standard))
+ (math-to-standard-rec expr)))
(defun math-to-standard-rec (expr)
(if (eq (car-safe expr) 'var)
@@ -1052,7 +1054,7 @@ If COMP or STD is non-nil, put that in the units table instead."
(eq (car-safe (nth 1 expr)) 'var)))
expr
(cons (car expr)
- (mapcar 'math-to-standard-rec (cdr expr))))))
+ (mapcar #'math-to-standard-rec (cdr expr))))))
(defun math-apply-units (expr units ulist &optional pure)
(setq expr (math-simplify-units expr))
@@ -1085,8 +1087,7 @@ If COMP or STD is non-nil, put that in the units table instead."
(let ((entry (list units calc-internal-prec calc-prefer-frac)))
(or (equal entry (car math-decompose-units-cache))
(let ((ulist nil)
- (utemp units)
- qty unit)
+ (utemp units))
(while (eq (car-safe utemp) '+)
(setq ulist (cons (math-decompose-unit-part (nth 2 utemp))
ulist)
@@ -1144,15 +1145,15 @@ If COMP or STD is non-nil, put that in the units table instead."
(defvar math-cu-new-units)
(defvar math-cu-pure)
-(defun math-convert-units (expr math-cu-new-units &optional math-cu-pure)
- (if (eq (car-safe math-cu-new-units) 'var)
- (let ((unew (assq (nth 1 math-cu-new-units)
+(defun math-convert-units (expr new-units &optional pure)
+ (if (eq (car-safe new-units) 'var)
+ (let ((unew (assq (nth 1 new-units)
(math-build-units-table))))
(if (eq (car-safe (nth 1 unew)) '+)
- (setq math-cu-new-units (nth 1 unew)))))
+ (setq new-units (nth 1 unew)))))
(math-with-extra-prec 2
- (let ((compat (and (not math-cu-pure)
- (math-find-compatible-unit expr math-cu-new-units)))
+ (let ((compat (and (not pure)
+ (math-find-compatible-unit expr new-units)))
(math-cu-unit-list nil)
(math-combining-units nil))
(if compat
@@ -1160,21 +1161,23 @@ If COMP or STD is non-nil, put that in the units table instead."
(math-mul (math-mul (math-simplify-units
(math-div expr (math-pow (car compat)
(cdr compat))))
- (math-pow math-cu-new-units (cdr compat)))
+ (math-pow new-units (cdr compat)))
(math-simplify-units
(math-to-standard-units
- (math-pow (math-div (car compat) math-cu-new-units)
+ (math-pow (math-div (car compat) new-units)
(cdr compat))
nil))))
- (when (setq math-cu-unit-list (math-decompose-units math-cu-new-units))
- (setq math-cu-new-units (nth 2 (car math-cu-unit-list))))
+ (when (setq math-cu-unit-list (math-decompose-units new-units))
+ (setq new-units (nth 2 (car math-cu-unit-list))))
(when (eq (car-safe expr) '+)
(setq expr (math-simplify-units expr)))
(if (math-units-in-expr-p expr t)
- (math-convert-units-rec expr)
+ (let ((math-cu-new-units new-units)
+ (math-cu-pure pure))
+ (math-convert-units-rec expr))
(math-apply-units (math-to-standard-units
- (list '/ expr math-cu-new-units) nil)
- math-cu-new-units math-cu-unit-list math-cu-pure))))))
+ (list '/ expr new-units) nil)
+ new-units math-cu-unit-list pure))))))
(defun math-convert-units-rec (expr)
(if (math-units-in-expr-p expr nil)
@@ -1184,7 +1187,7 @@ If COMP or STD is non-nil, put that in the units table instead."
(if (Math-primp expr)
expr
(cons (car expr)
- (mapcar 'math-convert-units-rec (cdr expr))))))
+ (mapcar #'math-convert-units-rec (cdr expr))))))
(defun math-convert-temperature (expr old new &optional pure)
(let* ((units (math-single-units-in-expr-p expr))
@@ -1228,37 +1231,34 @@ If COMP or STD is non-nil, put that in the units table instead."
(math-simplify a)))
(defalias 'calcFunc-usimplify 'math-simplify-units)
-;; The function created by math-defsimplify uses the variable
-;; math-simplify-expr, and so is used by functions in math-defsimplify
-(defvar math-simplify-expr)
-
+;; The function created by math-defsimplify uses the variable `expr'.
(math-defsimplify (+ -)
(and math-simplifying-units
- (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
- (let* ((units (math-extract-units (nth 1 math-simplify-expr)))
+ (math-units-in-expr-p (nth 1 expr) nil)
+ (let* ((units (math-extract-units (nth 1 expr)))
(ratio (math-simplify (math-to-standard-units
- (list '/ (nth 2 math-simplify-expr) units) nil))))
+ (list '/ (nth 2 expr) units) nil))))
(if (math-units-in-expr-p ratio nil)
(progn
- (calc-record-why "*Inconsistent units" math-simplify-expr)
- math-simplify-expr)
- (list '* (math-add (math-remove-units (nth 1 math-simplify-expr))
- (if (eq (car math-simplify-expr) '-)
+ (calc-record-why "*Inconsistent units" expr)
+ expr)
+ (list '* (math-add (math-remove-units (nth 1 expr))
+ (if (eq (car expr) '-)
(math-neg ratio) ratio))
units)))))
(math-defsimplify *
- (math-simplify-units-prod))
+ (math-simplify-units-prod expr))
-(defun math-simplify-units-prod ()
+(defun math-simplify-units-prod (expr)
(and math-simplifying-units
calc-autorange-units
- (Math-realp (nth 1 math-simplify-expr))
- (let* ((num (math-float (nth 1 math-simplify-expr)))
+ (Math-realp (nth 1 expr))
+ (let* ((num (math-float (nth 1 expr)))
(xpon (calcFunc-xpon num))
- (unitp (cdr (cdr math-simplify-expr)))
+ (unitp (cdr (cdr expr)))
(unit (car unitp))
- (pow (if (eq (car math-simplify-expr) '*) 1 -1))
+ (pow (if (eq (car expr) '*) 1 -1))
u)
(and (eq (car-safe unit) '*)
(setq unitp (cdr unit)
@@ -1308,46 +1308,46 @@ If COMP or STD is non-nil, put that in the units table instead."
(or (not (eq p pref))
(< xpon (+ pxpon (* (math-abs pow) 3))))
(progn
- (setcar (cdr math-simplify-expr)
+ (setcar (cdr expr)
(let ((calc-prefer-frac nil))
- (calcFunc-scf (nth 1 math-simplify-expr)
+ (calcFunc-scf (nth 1 expr)
(- uxpon pxpon))))
(setcar unitp pname)
- math-simplify-expr)))))))
+ expr)))))))
(defvar math-try-cancel-units)
(math-defsimplify /
(and math-simplifying-units
- (let ((np (cdr math-simplify-expr))
+ (let ((np (cdr expr))
(math-try-cancel-units 0)
- n nn)
- (setq n (if (eq (car-safe (nth 2 math-simplify-expr)) '*)
- (cdr (nth 2 math-simplify-expr))
- (nthcdr 2 math-simplify-expr)))
+ n)
+ (setq n (if (eq (car-safe (nth 2 expr)) '*)
+ (cdr (nth 2 expr))
+ (nthcdr 2 expr)))
(if (math-realp (car n))
(progn
- (setcar (cdr math-simplify-expr) (math-mul (nth 1 math-simplify-expr)
+ (setcar (cdr expr) (math-mul (nth 1 expr)
(let ((calc-prefer-frac nil))
(math-div 1 (car n)))))
(setcar n 1)))
(while (eq (car-safe (setq n (car np))) '*)
- (math-simplify-units-divisor (cdr n) (cdr (cdr math-simplify-expr)))
+ (math-simplify-units-divisor (cdr n) (cdr (cdr expr)))
(setq np (cdr (cdr n))))
- (math-simplify-units-divisor np (cdr (cdr math-simplify-expr)))
+ (math-simplify-units-divisor np (cdr (cdr expr)))
(if (eq math-try-cancel-units 0)
(let* ((math-simplifying-units nil)
(base (math-simplify
- (math-to-standard-units math-simplify-expr nil))))
+ (math-to-standard-units expr nil))))
(if (Math-numberp base)
- (setq math-simplify-expr base))))
- (if (eq (car-safe math-simplify-expr) '/)
- (math-simplify-units-prod))
- math-simplify-expr)))
+ (setq expr base))))
+ (if (eq (car-safe expr) '/)
+ (math-simplify-units-prod expr))
+ expr)))
(defun math-simplify-units-divisor (np dp)
(let ((n (car np))
- d dd temp)
+ d temp)
(while (eq (car-safe (setq d (car dp))) '*)
(when (setq temp (math-simplify-units-quotient n (nth 1 d)))
(setcar np (setq n temp))
@@ -1387,23 +1387,23 @@ If COMP or STD is non-nil, put that in the units table instead."
(math-defsimplify ^
(and math-simplifying-units
- (math-realp (nth 2 math-simplify-expr))
- (if (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
- (list (car (nth 1 math-simplify-expr))
- (list '^ (nth 1 (nth 1 math-simplify-expr))
- (nth 2 math-simplify-expr))
- (list '^ (nth 2 (nth 1 math-simplify-expr))
- (nth 2 math-simplify-expr)))
- (math-simplify-units-pow (nth 1 math-simplify-expr)
- (nth 2 math-simplify-expr)))))
+ (math-realp (nth 2 expr))
+ (if (memq (car-safe (nth 1 expr)) '(* /))
+ (list (car (nth 1 expr))
+ (list '^ (nth 1 (nth 1 expr))
+ (nth 2 expr))
+ (list '^ (nth 2 (nth 1 expr))
+ (nth 2 expr)))
+ (math-simplify-units-pow (nth 1 expr)
+ (nth 2 expr)))))
(math-defsimplify calcFunc-sqrt
(and math-simplifying-units
- (if (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
- (list (car (nth 1 math-simplify-expr))
- (list 'calcFunc-sqrt (nth 1 (nth 1 math-simplify-expr)))
- (list 'calcFunc-sqrt (nth 2 (nth 1 math-simplify-expr))))
- (math-simplify-units-pow (nth 1 math-simplify-expr) '(frac 1 2)))))
+ (if (memq (car-safe (nth 1 expr)) '(* /))
+ (list (car (nth 1 expr))
+ (list 'calcFunc-sqrt (nth 1 (nth 1 expr)))
+ (list 'calcFunc-sqrt (nth 2 (nth 1 expr))))
+ (math-simplify-units-pow (nth 1 expr) '(frac 1 2)))))
(math-defsimplify (calcFunc-floor
calcFunc-ceil
@@ -1416,21 +1416,21 @@ If COMP or STD is non-nil, put that in the units table instead."
calcFunc-abs
calcFunc-clean)
(and math-simplifying-units
- (= (length math-simplify-expr) 2)
- (if (math-only-units-in-expr-p (nth 1 math-simplify-expr))
- (nth 1 math-simplify-expr)
- (if (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
+ (= (length expr) 2)
+ (if (math-only-units-in-expr-p (nth 1 expr))
+ (nth 1 expr)
+ (if (and (memq (car-safe (nth 1 expr)) '(* /))
(or (math-only-units-in-expr-p
- (nth 1 (nth 1 math-simplify-expr)))
+ (nth 1 (nth 1 expr)))
(math-only-units-in-expr-p
- (nth 2 (nth 1 math-simplify-expr)))))
- (list (car (nth 1 math-simplify-expr))
- (cons (car math-simplify-expr)
- (cons (nth 1 (nth 1 math-simplify-expr))
- (cdr (cdr math-simplify-expr))))
- (cons (car math-simplify-expr)
- (cons (nth 2 (nth 1 math-simplify-expr))
- (cdr (cdr math-simplify-expr)))))))))
+ (nth 2 (nth 1 expr)))))
+ (list (car (nth 1 expr))
+ (cons (car expr)
+ (cons (nth 1 (nth 1 expr))
+ (cdr (cdr expr))))
+ (cons (car expr)
+ (cons (nth 2 (nth 1 expr))
+ (cdr (cdr expr)))))))))
(defun math-simplify-units-pow (a pow)
(if (and (eq (car-safe a) '^)
@@ -1453,10 +1453,10 @@ If COMP or STD is non-nil, put that in the units table instead."
(math-defsimplify calcFunc-sin
(and math-simplifying-units
- (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
+ (math-units-in-expr-p (nth 1 expr) nil)
(let ((rad (math-simplify-units
(math-evaluate-expr
- (math-to-standard-units (nth 1 math-simplify-expr) nil))))
+ (math-to-standard-units (nth 1 expr) nil))))
(calc-angle-mode 'rad))
(and (eq (car-safe rad) '*)
(math-realp (nth 1 rad))
@@ -1466,10 +1466,10 @@ If COMP or STD is non-nil, put that in the units table instead."
(math-defsimplify calcFunc-cos
(and math-simplifying-units
- (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
+ (math-units-in-expr-p (nth 1 expr) nil)
(let ((rad (math-simplify-units
(math-evaluate-expr
- (math-to-standard-units (nth 1 math-simplify-expr) nil))))
+ (math-to-standard-units (nth 1 expr) nil))))
(calc-angle-mode 'rad))
(and (eq (car-safe rad) '*)
(math-realp (nth 1 rad))
@@ -1479,10 +1479,10 @@ If COMP or STD is non-nil, put that in the units table instead."
(math-defsimplify calcFunc-tan
(and math-simplifying-units
- (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
+ (math-units-in-expr-p (nth 1 expr) nil)
(let ((rad (math-simplify-units
(math-evaluate-expr
- (math-to-standard-units (nth 1 math-simplify-expr) nil))))
+ (math-to-standard-units (nth 1 expr) nil))))
(calc-angle-mode 'rad))
(and (eq (car-safe rad) '*)
(math-realp (nth 1 rad))
@@ -1492,10 +1492,10 @@ If COMP or STD is non-nil, put that in the units table instead."
(math-defsimplify calcFunc-sec
(and math-simplifying-units
- (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
+ (math-units-in-expr-p (nth 1 expr) nil)
(let ((rad (math-simplify-units
(math-evaluate-expr
- (math-to-standard-units (nth 1 math-simplify-expr) nil))))
+ (math-to-standard-units (nth 1 expr) nil))))
(calc-angle-mode 'rad))
(and (eq (car-safe rad) '*)
(math-realp (nth 1 rad))
@@ -1505,10 +1505,10 @@ If COMP or STD is non-nil, put that in the units table instead."
(math-defsimplify calcFunc-csc
(and math-simplifying-units
- (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
+ (math-units-in-expr-p (nth 1 expr) nil)
(let ((rad (math-simplify-units
(math-evaluate-expr
- (math-to-standard-units (nth 1 math-simplify-expr) nil))))
+ (math-to-standard-units (nth 1 expr) nil))))
(calc-angle-mode 'rad))
(and (eq (car-safe rad) '*)
(math-realp (nth 1 rad))
@@ -1518,10 +1518,10 @@ If COMP or STD is non-nil, put that in the units table instead."
(math-defsimplify calcFunc-cot
(and math-simplifying-units
- (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
+ (math-units-in-expr-p (nth 1 expr) nil)
(let ((rad (math-simplify-units
(math-evaluate-expr
- (math-to-standard-units (nth 1 math-simplify-expr) nil))))
+ (math-to-standard-units (nth 1 expr) nil))))
(calc-angle-mode 'rad))
(and (eq (car-safe rad) '*)
(math-realp (nth 1 rad))
@@ -1536,13 +1536,13 @@ If COMP or STD is non-nil, put that in the units table instead."
(if (Math-primp expr)
expr
(cons (car expr)
- (mapcar 'math-remove-units (cdr expr))))))
+ (mapcar #'math-remove-units (cdr expr))))))
(defun math-extract-units (expr)
(cond
((memq (car-safe expr) '(* /))
(cons (car expr)
- (mapcar 'math-extract-units (cdr expr))))
+ (mapcar #'math-extract-units (cdr expr))))
((eq (car-safe expr) 'neg)
(math-extract-units (nth 1 expr)))
((eq (car-safe expr) '^)
@@ -1669,7 +1669,7 @@ In symbolic mode, return the list (^ a b)."
(defun math-extract-logunits (expr)
(if (memq (car-safe expr) '(* /))
(cons (car expr)
- (mapcar 'math-extract-logunits (cdr expr)))
+ (mapcar #'math-extract-logunits (cdr expr)))
(if (memq (car-safe expr) '(^))
(list '^ (math-extract-logunits (nth 1 expr)) (nth 2 expr))
(if (member expr math-logunits) expr 1))))
diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el
index 1d403b73943..35f13f9656a 100644
--- a/lisp/calc/calc.el
+++ b/lisp/calc/calc.el
@@ -1,4 +1,4 @@
-;;; calc.el --- the GNU Emacs calculator
+;;; calc.el --- the GNU Emacs calculator -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2019 Free Software Foundation, Inc.
@@ -178,7 +178,7 @@
(declare-function math-read-radix-digit "calc-misc" (dig))
(declare-function calc-digit-dots "calc-incom" ())
(declare-function math-normalize-fancy "calc-ext" (a))
-(declare-function math-normalize-nonstandard "calc-ext" ())
+(declare-function math-normalize-nonstandard "calc-ext" (a))
(declare-function math-recompile-eval-rules "calc-alg" ())
(declare-function math-apply-rewrites "calc-rewr" (expr rules &optional heads math-apply-rw-ruleset))
(declare-function calc-record-why "calc-misc" (&rest stuff))
@@ -203,7 +203,7 @@
(declare-function math-compose-expr "calccomp" (a prec &optional div))
(declare-function math-comp-width "calccomp" (c))
(declare-function math-composition-to-string "calccomp" (c &optional width))
-(declare-function math-stack-value-offset-fancy "calccomp" ())
+(declare-function math-stack-value-offset-fancy "calccomp" (c))
(declare-function math-format-flat-expr-fancy "calc-ext" (a prec))
(declare-function math-adjust-fraction "calc-ext" (a))
(declare-function math-format-binary "calc-bin" (a))
@@ -1338,16 +1338,17 @@ Notations: 3.14e6 3.14 * 10^6
"
(interactive)
(mapc (function ;FIXME: Why (set-default v (symbol-value v)) ?!?!?
- (lambda (v) (set-default v (symbol-value v)))) calc-local-var-list)
+ (lambda (v) (set-default v (symbol-value v))))
+ calc-local-var-list)
(kill-all-local-variables)
(use-local-map (if (eq calc-algebraic-mode 'total)
(progn (require 'calc-ext) calc-alg-map) calc-mode-map))
(mapc #'make-local-variable calc-local-var-list)
(make-local-variable 'overlay-arrow-position)
(make-local-variable 'overlay-arrow-string)
- (add-hook 'change-major-mode-hook 'font-lock-defontify nil t)
+ (add-hook 'change-major-mode-hook #'font-lock-defontify nil t)
(add-hook 'kill-buffer-query-functions
- 'calc-kill-stack-buffer
+ #'calc-kill-stack-buffer
t t)
(setq truncate-lines t)
(setq buffer-read-only t)
@@ -1802,7 +1803,7 @@ See calc-keypad for details."
(if calc-hyperbolic-flag "Hyp " "")
(if calc-keep-args-flag "Keep " "")
(if (/= calc-stack-top 1) "Narrow " "")
- (apply 'concat calc-other-modes)))))
+ (apply #'concat calc-other-modes)))))
(if (equal new-mode-string mode-line-buffer-identification)
nil
(setq mode-line-buffer-identification new-mode-string)
@@ -1876,7 +1877,7 @@ See calc-keypad for details."
(if (and (consp vals)
(or (integerp (car vals))
(consp (car vals))))
- (setq vals (mapcar 'calc-normalize vals))
+ (setq vals (mapcar #'calc-normalize vals))
(setq vals (calc-normalize vals)))
(or (and (consp vals)
(or (integerp (car vals))
@@ -1959,8 +1960,8 @@ See calc-keypad for details."
(mapcar (lambda (x) (calc-get-stack-element x sel-mode)) top)))))
(defun calc-top-list-n (&optional n m sel-mode)
- (mapcar 'math-check-complete
- (mapcar 'calc-normalize (calc-top-list n m sel-mode))))
+ (mapcar #'math-check-complete
+ (mapcar #'calc-normalize (calc-top-list n m sel-mode))))
(defun calc-renumber-stack ()
@@ -2214,7 +2215,7 @@ the United States."
(setq calc-aborted-prefix name)
(if (null arg)
(calc-enter-result 2 name (cons (or func2 func)
- (mapcar 'math-check-complete
+ (mapcar #'math-check-complete
(calc-top-list 2))))
(require 'calc-ext)
(calc-binary-op-fancy name func arg ident unary)))
@@ -2429,7 +2430,7 @@ the United States."
(beep)
(and (not (calc-minibuffer-contains "[-+]?\\(1[5-9]\\|[2-9][0-9]\\)#.*"))
(search-forward "e" nil t))
- (if (looking-at "+")
+ (if (looking-at "\\+")
(delete-char 1))
(if (looking-at "-")
(delete-char 1)
@@ -2626,78 +2627,78 @@ largest Emacs integer.")
(defvar math-eval-rules-cache-other)
;;; Reduce an object to canonical (normalized) form. [O o; Z Z] [Public]
-(defvar math-normalize-a)
(defvar math-normalize-error nil
"Non-nil if the last call the `math-normalize' returned an error.")
-(defun math-normalize (math-normalize-a)
+(defun math-normalize (a)
(setq math-normalize-error nil)
(cond
- ((not (consp math-normalize-a))
- (if (integerp math-normalize-a)
- (if (or (>= math-normalize-a math-small-integer-size)
- (<= math-normalize-a (- math-small-integer-size)))
- (math-bignum math-normalize-a)
- math-normalize-a)
- math-normalize-a))
- ((eq (car math-normalize-a) 'bigpos)
- (if (eq (nth (1- (length math-normalize-a)) math-normalize-a) 0)
- (let* ((last (setq math-normalize-a
- (copy-sequence math-normalize-a))) (digs math-normalize-a))
+ ((not (consp a))
+ (if (integerp a)
+ (if (or (>= a math-small-integer-size)
+ (<= a (- math-small-integer-size)))
+ (math-bignum a)
+ a)
+ a))
+ ((eq (car a) 'bigpos)
+ (if (eq (nth (1- (length a)) a) 0)
+ (let* ((last (setq a
+ (copy-sequence a)))
+ (digs a))
(while (setq digs (cdr digs))
(or (eq (car digs) 0) (setq last digs)))
(setcdr last nil)))
- (if (cdr (cdr (cdr math-normalize-a)))
- math-normalize-a
+ (if (cdr (cdr (cdr a)))
+ a
(cond
- ((cdr (cdr math-normalize-a)) (+ (nth 1 math-normalize-a)
- (* (nth 2 math-normalize-a)
+ ((cdr (cdr a)) (+ (nth 1 a)
+ (* (nth 2 a)
math-bignum-digit-size)))
- ((cdr math-normalize-a) (nth 1 math-normalize-a))
+ ((cdr a) (nth 1 a))
(t 0))))
- ((eq (car math-normalize-a) 'bigneg)
- (if (eq (nth (1- (length math-normalize-a)) math-normalize-a) 0)
- (let* ((last (setq math-normalize-a (copy-sequence math-normalize-a)))
- (digs math-normalize-a))
+ ((eq (car a) 'bigneg)
+ (if (eq (nth (1- (length a)) a) 0)
+ (let* ((last (setq a (copy-sequence a)))
+ (digs a))
(while (setq digs (cdr digs))
(or (eq (car digs) 0) (setq last digs)))
(setcdr last nil)))
- (if (cdr (cdr (cdr math-normalize-a)))
- math-normalize-a
+ (if (cdr (cdr (cdr a)))
+ a
(cond
- ((cdr (cdr math-normalize-a)) (- (+ (nth 1 math-normalize-a)
- (* (nth 2 math-normalize-a)
+ ((cdr (cdr a)) (- (+ (nth 1 a)
+ (* (nth 2 a)
math-bignum-digit-size))))
- ((cdr math-normalize-a) (- (nth 1 math-normalize-a)))
+ ((cdr a) (- (nth 1 a)))
(t 0))))
- ((eq (car math-normalize-a) 'float)
- (math-make-float (math-normalize (nth 1 math-normalize-a))
- (nth 2 math-normalize-a)))
- ((or (memq (car math-normalize-a)
+ ((eq (car a) 'float)
+ (math-make-float (math-normalize (nth 1 a))
+ (nth 2 a)))
+ ((or (memq (car a)
'(frac cplx polar hms date mod sdev intv vec var quote
special-const calcFunc-if calcFunc-lambda
calcFunc-quote calcFunc-condition
calcFunc-evalto))
- (integerp (car math-normalize-a))
- (and (consp (car math-normalize-a))
- (not (eq (car (car math-normalize-a)) 'lambda))))
+ (integerp (car a))
+ (and (consp (car a))
+ (not (eq (car (car a)) 'lambda))))
(require 'calc-ext)
- (math-normalize-fancy math-normalize-a))
+ (math-normalize-fancy a))
(t
(or (and calc-simplify-mode
(require 'calc-ext)
- (math-normalize-nonstandard))
- (let ((args (mapcar 'math-normalize (cdr math-normalize-a))))
+ (math-normalize-nonstandard a))
+ (let ((args (mapcar #'math-normalize (cdr a))))
(or (condition-case err
(let ((func
- (assq (car math-normalize-a) '( ( + . math-add )
- ( - . math-sub )
- ( * . math-mul )
- ( / . math-div )
- ( % . math-mod )
- ( ^ . math-pow )
- ( neg . math-neg )
- ( | . math-concat ) ))))
+ (assq (car a) '( ( + . math-add )
+ ( - . math-sub )
+ ( * . math-mul )
+ ( / . math-div )
+ ( % . math-mod )
+ ( ^ . math-pow )
+ ( neg . math-neg )
+ ( | . math-concat ) ))))
(or (and var-EvalRules
(progn
(or (eq var-EvalRules math-eval-rules-cache-tag)
@@ -2705,59 +2706,59 @@ largest Emacs integer.")
(require 'calc-ext)
(math-recompile-eval-rules)))
(and (or math-eval-rules-cache-other
- (assq (car math-normalize-a)
+ (assq (car a)
math-eval-rules-cache))
(math-apply-rewrites
- (cons (car math-normalize-a) args)
+ (cons (car a) args)
(cdr math-eval-rules-cache)
nil math-eval-rules-cache))))
(if func
(apply (cdr func) args)
- (and (or (consp (car math-normalize-a))
- (fboundp (car math-normalize-a))
+ (and (or (consp (car a))
+ (fboundp (car a))
(and (not (featurep 'calc-ext))
(require 'calc-ext)
- (fboundp (car math-normalize-a))))
- (apply (car math-normalize-a) args)))))
+ (fboundp (car a))))
+ (apply (car a) args)))))
(wrong-number-of-arguments
(setq math-normalize-error t)
(calc-record-why "*Wrong number of arguments"
- (cons (car math-normalize-a) args))
+ (cons (car a) args))
nil)
(wrong-type-argument
(or calc-next-why
(calc-record-why "Wrong type of argument"
- (cons (car math-normalize-a) args)))
+ (cons (car a) args)))
nil)
(args-out-of-range
(setq math-normalize-error t)
(calc-record-why "*Argument out of range"
- (cons (car math-normalize-a) args))
+ (cons (car a) args))
nil)
(inexact-result
(calc-record-why "No exact representation for result"
- (cons (car math-normalize-a) args))
+ (cons (car a) args))
nil)
(math-overflow
(setq math-normalize-error t)
(calc-record-why "*Floating-point overflow occurred"
- (cons (car math-normalize-a) args))
+ (cons (car a) args))
nil)
(math-underflow
(setq math-normalize-error t)
(calc-record-why "*Floating-point underflow occurred"
- (cons (car math-normalize-a) args))
+ (cons (car a) args))
nil)
(void-variable
(setq math-normalize-error t)
(if (eq (nth 1 err) 'var-EvalRules)
(progn
(setq var-EvalRules nil)
- (math-normalize (cons (car math-normalize-a) args)))
+ (math-normalize (cons (car a) args)))
(calc-record-why "*Variable is void" (nth 1 err)))))
- (if (consp (car math-normalize-a))
+ (if (consp (car a))
(math-dimension-error)
- (cons (car math-normalize-a) args))))))))
+ (cons (car a) args))))))))
@@ -2788,13 +2789,6 @@ largest Emacs integer.")
(cond
((>= a 0)
(cons 'bigpos (math-bignum-big a)))
- ((= a most-negative-fixnum)
- ;; Note: cannot get the negation directly because
- ;; (- most-negative-fixnum) is most-negative-fixnum.
- ;;
- ;; most-negative-fixnum := -most-positive-fixnum - 1
- (math-sub (cons 'bigneg (math-bignum-big most-positive-fixnum))
- 1))
(t
(cons 'bigneg (math-bignum-big (- a))))))
@@ -2848,7 +2842,7 @@ largest Emacs integer.")
((eq (car a) 'frac) (math-div (math-float (nth 1 a)) (nth 2 a)))
((eq (car a) 'float) a)
((memq (car a) '(cplx polar vec hms date sdev mod))
- (cons (car a) (mapcar 'math-float (cdr a))))
+ (cons (car a) (mapcar #'math-float (cdr a))))
(t (math-float-fancy a))))
@@ -2859,7 +2853,7 @@ largest Emacs integer.")
((memq (car a) '(frac float))
(list (car a) (Math-integer-neg (nth 1 a)) (nth 2 a)))
((memq (car a) '(cplx vec hms date calcFunc-idn))
- (cons (car a) (mapcar 'math-neg (cdr a))))
+ (cons (car a) (mapcar #'math-neg (cdr a))))
(t (math-neg-fancy a))))
@@ -3439,22 +3433,21 @@ largest Emacs integer.")
(setcar (cdr entry) (calc-count-lines s))
s))
-;; The variables math-svo-c, math-svo-wid and math-svo-off are local
+;; The variables math-svo-wid and math-svo-off are local
;; to math-stack-value-offset, but are used by math-stack-value-offset-fancy
;; in calccomp.el.
-(defvar math-svo-c)
(defvar math-svo-wid)
(defvar math-svo-off)
-(defun math-stack-value-offset (math-svo-c)
+(defun math-stack-value-offset (c)
(let* ((num (if calc-line-numbering 4 0))
(math-svo-wid (calc-window-width))
math-svo-off)
(if calc-display-just
(progn
(require 'calc-ext)
- (math-stack-value-offset-fancy))
+ (math-stack-value-offset-fancy c))
(setq math-svo-off (or calc-display-origin 0))
(when (integerp calc-line-breaking)
(setq math-svo-wid calc-line-breaking)))
@@ -3887,7 +3880,7 @@ The prefix `calcFunc-' is added to the specified name to get the
actual Lisp function name.
See Info node `(calc)Defining Functions'."
- (declare (doc-string 3))
+ (declare (doc-string 3)) ;; FIXME: Edebug spec?
(require 'calc-ext)
(math-do-defmath func args body))
diff --git a/lisp/calc/calccomp.el b/lisp/calc/calccomp.el
index d81cc04fe50..91eadfbb4e8 100644
--- a/lisp/calc/calccomp.el
+++ b/lisp/calc/calccomp.el
@@ -1,4 +1,4 @@
-;;; calccomp.el --- composition functions for Calc
+;;; calccomp.el --- composition functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2019 Free Software Foundation, Inc.
@@ -121,7 +121,8 @@
calc-lang-slash-idiv)
(math-float (nth 1 aa))
(nth 1 aa))
- (nth 2 aa)) prec))
+ (nth 2 aa))
+ prec))
(if (and (eq calc-language 'big)
(= (length (car calc-frac-format)) 1))
(let* ((aa (math-adjust-fraction a))
@@ -202,8 +203,9 @@
(math-comp-comma-spc (or calc-vector-commas " "))
(math-comp-comma (or calc-vector-commas ""))
(math-comp-vector-prec (if (or (and calc-vector-commas
- (math-vector-no-parens a))
- (memq 'P calc-matrix-brackets)) 0 1000))
+ (math-vector-no-parens a))
+ (memq 'P calc-matrix-brackets))
+ 0 1000))
(math-comp-just (cond ((eq calc-matrix-just 'right) 'vright)
((eq calc-matrix-just 'center) 'vcent)
(t 'vleft)))
@@ -803,8 +805,7 @@
( % . calcFunc-mod )
( ^ . calcFunc-pow )
( neg . calcFunc-neg )
- ( | . calcFunc-vconcat ))))
- left right args)
+ ( | . calcFunc-vconcat )))))
(if func2
(setq func (cdr func2)))
(if (setq func2 (rassq func math-expr-function-mapping))
@@ -858,7 +859,7 @@
(or (cdr (cdr a))
(not (eq (car-safe (nth 1 a)) '*))))
-(defun math-compose-matrix (a col cols base)
+(defun math-compose-matrix (a _col cols base)
(let ((col 0)
(res nil))
(while (<= (setq col (1+ col)) cols)
@@ -968,8 +969,8 @@
(and (memq (car a) '(^ calcFunc-subscr))
(math-tex-expr-is-flat (nth 1 a)))))
-(put 'calcFunc-log 'math-compose-big 'math-compose-log)
-(defun math-compose-log (a prec)
+(put 'calcFunc-log 'math-compose-big #'math-compose-log)
+(defun math-compose-log (a _prec)
(and (= (length a) 3)
(list 'horiz
(list 'subscr "log"
@@ -979,8 +980,8 @@
(math-compose-expr (nth 1 a) 1000)
")")))
-(put 'calcFunc-log10 'math-compose-big 'math-compose-log10)
-(defun math-compose-log10 (a prec)
+(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")
@@ -988,8 +989,8 @@
(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)
+(put 'calcFunc-deriv 'math-compose-big #'math-compose-deriv)
+(put 'calcFunc-tderiv 'math-compose-big #'math-compose-deriv)
(defun math-compose-deriv (a prec)
(when (= (length a) 3)
(math-compose-expr (list '/
@@ -1003,8 +1004,8 @@
(nth 2 a))))
prec)))
-(put 'calcFunc-sqrt 'math-compose-big 'math-compose-sqrt)
-(defun math-compose-sqrt (a prec)
+(put 'calcFunc-sqrt 'math-compose-big #'math-compose-sqrt)
+(defun math-compose-sqrt (a _prec)
(when (= (length a) 2)
(let* ((c (math-compose-expr (nth 1 a) 0))
(a (math-comp-ascent c))
@@ -1024,8 +1025,8 @@
" "
c)))))
-(put 'calcFunc-choose 'math-compose-big 'math-compose-choose)
-(defun math-compose-choose (a prec)
+(put 'calcFunc-choose 'math-compose-big #'math-compose-choose)
+(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
@@ -1035,7 +1036,7 @@
a1 " " a2)
")")))
-(put 'calcFunc-integ 'math-compose-big 'math-compose-integ)
+(put 'calcFunc-integ 'math-compose-big #'math-compose-integ)
(defun math-compose-integ (a prec)
(and (memq (length a) '(3 5))
(eq (car-safe (nth 2 a)) 'var)
@@ -1072,7 +1073,7 @@
(list 'horiz " d" var))
(if parens ")" "")))))
-(put 'calcFunc-sum 'math-compose-big 'math-compose-sum)
+(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))
@@ -1097,7 +1098,7 @@
expr
(if (memq prec '(180 201)) ")" "")))))
-(put 'calcFunc-prod 'math-compose-big 'math-compose-prod)
+(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))
@@ -1124,12 +1125,11 @@
;; 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
;; math-stack-value-offset-fancy, which is called by math-stack-value-offset..
-(defvar math-svo-c)
(defvar math-svo-wid)
(defvar math-svo-off)
-(defun math-stack-value-offset-fancy ()
- (let ((cwid (+ (math-comp-width math-svo-c))))
+(defun math-stack-value-offset-fancy (c)
+ (let ((cwid (+ (math-comp-width c))))
(cond ((eq calc-display-just 'right)
(if calc-display-origin
(setq math-svo-wid (max calc-display-origin 5))
@@ -1215,7 +1215,7 @@
;; which are called by math-comp-to-string-flat.
(defvar math-comp-pos)
-(defun math-comp-to-string-flat (c math-comp-full-width)
+(defun math-comp-to-string-flat (c full-width)
(if math-comp-sel-hpos
(let ((math-comp-pos 0))
(math-comp-sel-flat-term c))
@@ -1224,6 +1224,7 @@
(math-comp-pos 0)
(math-comp-margin 0)
(math-comp-highlight (and math-comp-selected calc-show-selections))
+ (math-comp-full-width full-width)
(math-comp-level -1))
(math-comp-to-string-flat-term '(set -1 0))
(math-comp-to-string-flat-term c)
@@ -1387,7 +1388,7 @@
(defvar math-comp-hpos)
(defvar math-comp-vpos)
-(defun math-comp-simplify (c full-width)
+(defun math-comp-simplify (c _full-width)
(let ((math-comp-buf (list ""))
(math-comp-base 0)
(math-comp-hgt 1)
diff --git a/lisp/calculator.el b/lisp/calculator.el
index 39aa4ec1d28..eec7aff5878 100644
--- a/lisp/calculator.el
+++ b/lisp/calculator.el
@@ -1184,7 +1184,7 @@ arguments."
(DX (if (and X calculator-deg) (degrees-to-radians X) X))
(L calculator-saved-list)
(fF `(calculator-funcall ',f x y))
- (fD `(if calculator-deg (radians-to-degrees x) x)))
+ (fD '(if calculator-deg (radians-to-degrees x) x)))
(eval `(cl-flet ((F (&optional x y) ,fF) (D (x) ,fD))
(let ((X ,X) (Y ,Y) (DX ,DX) (TX ,TX) (TY ,TY) (L ',L))
,f))
@@ -1226,7 +1226,7 @@ OP is the operator (if any) that caused this call."
(when (and (or calculator-display-fragile
(not (numberp (car calculator-stack))))
(<= inp (pcase calculator-input-radix
- (`nil ?9) (`bin ?1) (`oct ?7) (_ 999))))
+ ('nil ?9) ('bin ?1) ('oct ?7) (_ 999))))
(calculator-clear-fragile)
(setq calculator-curnum
(concat (if (equal calculator-curnum "0") ""
diff --git a/lisp/calendar/appt.el b/lisp/calendar/appt.el
index da041f024f8..40cb9f7cbdb 100644
--- a/lisp/calendar/appt.el
+++ b/lisp/calendar/appt.el
@@ -1,4 +1,4 @@
-;;; appt.el --- appointment notification functions
+;;; appt.el --- appointment notification functions -*- lexical-binding:t -*-
;; Copyright (C) 1989-1990, 1994, 1998, 2001-2019 Free Software
;; Foundation, Inc.
@@ -90,8 +90,7 @@ The first subexpression matches the time in minutes (an integer).
This overrides the default `appt-message-warning-time'.
You may want to put this inside a diary comment (see `diary-comment-start').
For example, to be warned 30 minutes in advance of an appointment:
- 2011/06/01 12:00 Do something ## warntime 30
-"
+ 2011/06/01 12:00 Do something ## warntime 30"
:version "24.1"
:type 'regexp
:group 'appt)
@@ -150,7 +149,7 @@ always updates every minute."
:type 'integer
:group 'appt)
-(defcustom appt-disp-window-function 'appt-disp-window
+(defcustom appt-disp-window-function #'appt-disp-window
"Function called to display appointment window.
Only relevant if reminders are being displayed in a window.
It should take three string arguments: the number of minutes till
@@ -160,7 +159,7 @@ relevant at any one time."
:type 'function
:group 'appt)
-(defcustom appt-delete-window-function 'appt-delete-window
+(defcustom appt-delete-window-function #'appt-delete-window
"Function called to remove appointment window and buffer.
Only relevant if reminders are being displayed in a window."
:type 'function
@@ -228,12 +227,11 @@ also calls `beep' for an audible reminder."
string (car string)))
(cond ((eq appt-display-format 'window)
;; TODO use calendar-month-abbrev-array rather than %b?
- (let ((time (format-time-string "%a %b %e "))
- err)
+ (let ((time (format-time-string "%a %b %e ")))
(condition-case err
(funcall appt-disp-window-function
(if (listp mins)
- (mapcar 'number-to-string mins)
+ (mapcar #'number-to-string mins)
(number-to-string mins))
time string)
(wrong-type-argument
@@ -250,7 +248,7 @@ update it for multiple appts?")
appt-delete-window-function))
((eq appt-display-format 'echo)
(message "%s" (if (listp string)
- (mapconcat 'identity string "\n")
+ (mapconcat #'identity string "\n")
string)))))
(defun appt-mode-line (min-to-app &optional abbrev)
@@ -267,7 +265,7 @@ If ABBREV is non-nil, abbreviates some text."
(if multiple "s" "")
(if (equal imin "0") "now"
(format "in %s %s"
- (or imin (mapconcat 'identity min-to-app ","))
+ (or imin (mapconcat #'identity min-to-app ","))
(if abbrev "min."
(format "minute%s" (if (equal imin "1") "" "s"))))))))
@@ -335,9 +333,9 @@ displayed in a window:
(null appt-prev-comp-time) ; first check
(< now-mins appt-prev-comp-time)) ; new day
(ignore-errors
- (let ((diary-hook (if (assoc 'appt-make-list diary-hook)
+ (let ((diary-hook (if (memq #'appt-make-list diary-hook)
diary-hook
- (cons 'appt-make-list diary-hook))))
+ (cons #'appt-make-list diary-hook))))
(if appt-display-diary
(diary)
;; Not displaying the diary, so we can ignore
@@ -405,8 +403,9 @@ displayed in a window:
(when appt-display-mode-line
(setq appt-mode-string
(concat " " (propertize
- (appt-mode-line (mapcar 'number-to-string
- min-list) t)
+ (appt-mode-line (mapcar #'number-to-string
+ min-list)
+ t)
'face 'mode-line-emphasis))))
;; Reset count to 0 in case we display another appt on the next cycle.
(setq appt-display-count (if (eq '(0) min-list) 0
@@ -458,14 +457,14 @@ separate appointment."
;; FIXME Link to diary entry?
(calendar-set-mode-line
(format " %s. %s" (appt-mode-line min-to-app)
- (mapconcat 'identity new-time ", ")))
+ (mapconcat #'identity new-time ", ")))
(setq buffer-read-only nil
buffer-undo-list t)
(erase-buffer)
;; If we have appointments at different times, prepend the times.
(if (or (= 1 (length min-to-app))
(not (delete (car min-to-app) min-to-app)))
- (insert (mapconcat 'identity appt-msg "\n"))
+ (insert (mapconcat #'identity appt-msg "\n"))
(dotimes (i (length appt-msg))
(insert (format "%s%sm: %s" (if (> i 0) "\n" "")
(nth i min-to-app) (nth i appt-msg)))))
@@ -547,19 +546,18 @@ sMinutes before the appointment to start warning: ")
(message ""))
-(defvar number)
-(defvar original-date)
(defvar diary-entries-list)
(defun appt-make-list ()
"Update the appointments list from today's diary buffer.
The time must be at the beginning of a line for it to be
put in the appointments list (see examples in documentation of
-the function `appt-check'). We assume that the variables DATE and
-NUMBER hold the arguments that `diary-list-entries' received.
+the function `appt-check'). We assume that the variables `original-date' and
+`number' hold the arguments that `diary-list-entries' received.
They specify the range of dates that the diary is being processed for.
Any appointments made with `appt-add' are not affected by this function."
+ (with-no-warnings (defvar number) (defvar original-date))
;; We have something to do if the range of dates that the diary is
;; considering includes the current date.
(if (and (not (calendar-date-compare
@@ -701,7 +699,7 @@ ARG is positive, otherwise off."
(let ((appt-active appt-timer))
(setq appt-active (if arg (> (prefix-numeric-value arg) 0)
(not appt-active)))
- (remove-hook 'write-file-functions 'appt-update-list)
+ (remove-hook 'write-file-functions #'appt-update-list)
(or global-mode-string (setq global-mode-string '("")))
(delq 'appt-mode-string global-mode-string)
(when appt-timer
@@ -709,8 +707,8 @@ ARG is positive, otherwise off."
(setq appt-timer nil))
(if appt-active
(progn
- (add-hook 'write-file-functions 'appt-update-list)
- (setq appt-timer (run-at-time t 60 'appt-check)
+ (add-hook 'write-file-functions #'appt-update-list)
+ (setq appt-timer (run-at-time t 60 #'appt-check)
global-mode-string
(append global-mode-string '(appt-mode-string)))
(appt-check t)
diff --git a/lisp/calendar/cal-dst.el b/lisp/calendar/cal-dst.el
index e78f19f803f..2126cfdadb1 100644
--- a/lisp/calendar/cal-dst.el
+++ b/lisp/calendar/cal-dst.el
@@ -1,4 +1,4 @@
-;;; cal-dst.el --- calendar functions for daylight saving rules
+;;; cal-dst.el --- calendar functions for daylight saving rules -*- lexical-binding:t -*-
;; Copyright (C) 1993-1996, 2001-2019 Free Software Foundation, Inc.
@@ -97,62 +97,48 @@ If the locale never uses daylight saving time, set this to nil."
;;;###autoload
(put 'calendar-current-time-zone-cache 'risky-local-variable t)
-(defvar calendar-system-time-basis
+(defconst calendar-system-time-basis
(calendar-absolute-from-gregorian '(1 1 1970))
"Absolute date of starting date of system clock.")
(defun calendar-absolute-from-time (x utc-diff)
"Absolute local date of time X; local time is UTC-DIFF seconds from UTC.
-X is (HIGH . LOW) or (HIGH LOW . IGNORED) where HIGH and LOW are the
-high and low 16 bits, respectively, of the number of seconds since
-1970-01-01 00:00:00 UTC, ignoring leap seconds.
+X is the number of seconds since 1970-01-01 00:00:00 UTC,
+ignoring leap seconds.
Returns the pair (ABS-DATE . SECONDS) where SECONDS after local midnight on
absolute date ABS-DATE is the equivalent moment to X."
- (let* ((h (car x))
- (xtail (cdr x))
- (l (+ utc-diff (if (numberp xtail) xtail (car xtail))))
- (u (+ (* 512 (mod h 675)) (floor l 128))))
- ;; Overflow is a terrible thing!
- (cons (+ calendar-system-time-basis
- ;; floor((2^16 h +l) / (60*60*24))
- (* 512 (floor h 675)) (floor u 675))
- ;; (2^16 h +l) mod (60*60*24)
- (+ (* (mod u 675) 128) (mod l 128)))))
+ (let ((secsperday 86400)
+ (local (+ x utc-diff)))
+ (cons (+ calendar-system-time-basis (floor local secsperday))
+ (mod local secsperday))))
(defun calendar-time-from-absolute (abs-date s)
"Time of absolute date ABS-DATE, S seconds after midnight.
-Returns the list (HIGH LOW) where HIGH and LOW are the high and low
-16 bits, respectively, of the number of seconds 1970-01-01 00:00:00 UTC,
-ignoring leap seconds, that is the equivalent moment to S seconds after
-midnight UTC on absolute date ABS-DATE."
- (let* ((a (- abs-date calendar-system-time-basis))
- (u (+ (* 163 (mod a 512)) (floor s 128))))
- ;; Overflow is a terrible thing!
- (list
- ;; floor((60*60*24*a + s) / 2^16)
- (+ a (* 163 (floor a 512)) (floor u 512))
- ;; (60*60*24*a + s) mod 2^16
- (+ (* 128 (mod u 512)) (mod s 128)))))
+Return the number of seconds since 1970-01-01 00:00:00 UTC,
+ignoring leap seconds, that is the equivalent moment to S seconds
+after midnight UTC on absolute date ABS-DATE."
+ (let ((secsperday 86400))
+ (+ s (* secsperday (- abs-date calendar-system-time-basis)))))
(defun calendar-next-time-zone-transition (time)
"Return the time of the next time zone transition after TIME.
Both TIME and the result are acceptable arguments to `current-time-zone'.
Return nil if no such transition can be found."
- (let* ((base 65536) ; 2^16 = base of current-time output
- (quarter-multiple 120) ; approx = (seconds per quarter year) / base
+ (let* ((time (encode-time time 'integer))
(time-zone (current-time-zone time))
(time-utc-diff (car time-zone))
hi
hi-zone
(hi-utc-diff time-utc-diff)
+ (quarter-seconds 7889238) ; Average seconds per 1/4 Gregorian year.
(quarters '(2 1 3)))
;; Heuristic: probe the time zone offset in the next three calendar
;; quarters, looking for a time zone offset different from TIME.
(while (and quarters (eq time-utc-diff hi-utc-diff))
- (setq hi (cons (+ (car time) (* (car quarters) quarter-multiple)) 0)
+ (setq hi (+ time (* (car quarters) quarter-seconds))
hi-zone (current-time-zone hi)
hi-utc-diff (car hi-zone)
quarters (cdr quarters)))
@@ -163,23 +149,16 @@ Return nil if no such transition can be found."
;; Now HI is after the next time zone transition.
;; Set LO to TIME, and then binary search to increase LO and decrease HI
;; until LO is just before and HI is just after the time zone transition.
- (let* ((tail (cdr time))
- (lo (cons (car time) (if (numberp tail) tail (car tail))))
+ (let* ((lo time)
probe)
(while
;; Set PROBE to halfway between LO and HI, rounding down.
;; If PROBE equals LO, we are done.
- (let* ((lsum (+ (cdr lo) (cdr hi)))
- (hsum (+ (car lo) (car hi) (/ lsum base)))
- (hsumodd (logand 1 hsum)))
- (setq probe (cons (/ (- hsum hsumodd) 2)
- (/ (+ (* hsumodd base) (% lsum base)) 2)))
- (not (equal lo probe)))
+ (not (= lo (setq probe (floor (+ lo hi) 2))))
;; Set either LO or HI to PROBE, depending on probe results.
(if (eq (car (current-time-zone probe)) hi-utc-diff)
(setq hi probe)
(setq lo probe)))
- (setcdr hi (list (cdr hi)))
hi))))
(autoload 'calendar-persian-to-absolute "cal-persia")
@@ -220,29 +199,30 @@ The result has the proper form for `calendar-daylight-savings-starts'."
'((calendar-gregorian-from-absolute
(calendar-persian-to-absolute `(7 1 ,(- year 621))))))))
(prevday-sec (- -1 utc-diff)) ; last sec of previous local day
- (year (1+ y))
new-rules)
- ;; Scan through the next few years until only one rule remains.
- (while (cdr candidate-rules)
- (dolist (rule candidate-rules)
- ;; The rule we return should give a Gregorian date, but here
- ;; we require an absolute date. The following is for efficiency.
- (setq date (cond ((eq (car rule) 'calendar-nth-named-day)
- (eval (cons 'calendar-nth-named-absday (cdr rule))))
- ((eq (car rule) 'calendar-gregorian-from-absolute)
- (eval (cadr rule)))
- (t (calendar-absolute-from-gregorian (eval rule)))))
- (or (equal (current-time-zone
- (calendar-time-from-absolute date prevday-sec))
- (current-time-zone
- (calendar-time-from-absolute (1+ date) prevday-sec)))
- (setq new-rules (cons rule new-rules))))
- ;; If no rules remain, just use the first candidate rule;
- ;; it's wrong in general, but it's right for at least one year.
- (setq candidate-rules (if new-rules (nreverse new-rules)
- (list (car candidate-rules)))
- new-rules nil
- year (1+ year)))
+ (calendar-dlet* ((year (1+ y)))
+ ;; Scan through the next few years until only one rule remains.
+ (while (cdr candidate-rules)
+ (dolist (rule candidate-rules)
+ ;; The rule we return should give a Gregorian date, but here
+ ;; we require an absolute date. The following is for efficiency.
+ (setq date (cond ((eq (car rule) #'calendar-nth-named-day)
+ (eval (cons #'calendar-nth-named-absday
+ (cdr rule))))
+ ((eq (car rule) #'calendar-gregorian-from-absolute)
+ (eval (cadr rule)))
+ (t (calendar-absolute-from-gregorian (eval rule)))))
+ (or (equal (current-time-zone
+ (calendar-time-from-absolute date prevday-sec))
+ (current-time-zone
+ (calendar-time-from-absolute (1+ date) prevday-sec)))
+ (setq new-rules (cons rule new-rules))))
+ ;; If no rules remain, just use the first candidate rule;
+ ;; it's wrong in general, but it's right for at least one year.
+ (setq candidate-rules (if new-rules (nreverse new-rules)
+ (list (car candidate-rules)))
+ new-rules nil
+ year (1+ year))))
(car candidate-rules)))
;; TODO it might be better to extract this information directly from
@@ -251,7 +231,7 @@ The result has the proper form for `calendar-daylight-savings-starts'."
;; https://lists.gnu.org/r/emacs-pretest-bug/2006-11/msg00060.html
(defun calendar-dst-find-data (&optional time)
"Find data on the first daylight saving time transitions after TIME.
-TIME defaults to `current-time'. Return value is as described
+TIME defaults to the current time. Return value is as described
for `calendar-current-time-zone'."
(let* ((t0 (or time (current-time)))
(t0-zone (current-time-zone t0))
@@ -279,14 +259,11 @@ for `calendar-current-time-zone'."
(car t2-date-sec) t1-utc-diff))
(t1-time (/ (cdr t1-date-sec) 60))
(t2-time (/ (cdr t2-date-sec) 60)))
- (cons
- (/ (min t0-utc-diff t1-utc-diff) 60)
- (cons
- (/ (abs (- t0-utc-diff t1-utc-diff)) 60)
- (if (< t0-utc-diff t1-utc-diff)
- (list t0-name t1-name t1-rules t2-rules t1-time t2-time)
- (list t1-name t0-name t2-rules t1-rules t2-time t1-time)
- )))))))))
+ (if (nth 7 (decode-time t1))
+ (list (/ t0-utc-diff 60) (/ (- t1-utc-diff t0-utc-diff) 60)
+ t0-name t1-name t1-rules t2-rules t1-time t2-time)
+ (list (/ t1-utc-diff 60) (/ (- t0-utc-diff t1-utc-diff) 60)
+ t1-name t0-name t2-rules t1-rules t2-time t1-time))))))))
(defvar calendar-dst-transition-cache nil
"Internal cal-dst variable storing date of daylight saving time transitions.
@@ -302,8 +279,8 @@ expressions that when evaluated return the start and end dates,
respectively. This function first attempts to use pre-calculated
data from `calendar-dst-transition-cache', otherwise it calls
`calendar-dst-find-data' (and adds the results to the cache).
-If dates in YEAR cannot be handled by `encode-time' (e.g. if they
-are too large to be represented as a lisp integer), then rather
+If dates in YEAR cannot be handled by `encode-time' (e.g.,
+if they are out of range for POSIX time_t), then rather
than an error this function returns the result appropriate for
the current year."
(let ((e (assoc year calendar-dst-transition-cache))
@@ -405,7 +382,8 @@ This function respects the value of `calendar-dst-check-each-year-flag'."
(or (let ((expr (if calendar-dst-check-each-year-flag
(cadr (calendar-dst-find-startend year))
(nth 4 calendar-current-time-zone-cache))))
- (if expr (eval expr)))
+ (calendar-dlet* ((year year))
+ (if expr (eval expr))))
;; New US rules commencing 2007. https://www.iana.org/time-zones
(and (not (zerop calendar-daylight-time-offset))
(calendar-nth-named-day 2 0 3 year))))
@@ -416,7 +394,8 @@ This function respects the value of `calendar-dst-check-each-year-flag'."
(or (let ((expr (if calendar-dst-check-each-year-flag
(nth 2 (calendar-dst-find-startend year))
(nth 5 calendar-current-time-zone-cache))))
- (if expr (eval expr)))
+ (calendar-dlet* ((year year))
+ (if expr (eval expr))))
;; New US rules commencing 2007. https://www.iana.org/time-zones
(and (not (zerop calendar-daylight-time-offset))
(calendar-nth-named-day 1 0 11 year))))
@@ -425,25 +404,25 @@ This function respects the value of `calendar-dst-check-each-year-flag'."
(defun dst-in-effect (date)
"True if on absolute DATE daylight saving time is in effect.
Fractional part of DATE is local standard time of day."
- (let* ((year (calendar-extract-year
- (calendar-gregorian-from-absolute (floor date))))
- (dst-starts-gregorian (eval calendar-daylight-savings-starts))
- (dst-ends-gregorian (eval calendar-daylight-savings-ends))
- (dst-starts (and dst-starts-gregorian
+ (calendar-dlet* ((year (calendar-extract-year
+ (calendar-gregorian-from-absolute (floor date)))))
+ (let* ((dst-starts-gregorian (eval calendar-daylight-savings-starts))
+ (dst-ends-gregorian (eval calendar-daylight-savings-ends))
+ (dst-starts (and dst-starts-gregorian
+ (+ (calendar-absolute-from-gregorian
+ dst-starts-gregorian)
+ (/ calendar-daylight-savings-starts-time
+ 60.0 24.0))))
+ (dst-ends (and dst-ends-gregorian
(+ (calendar-absolute-from-gregorian
- dst-starts-gregorian)
- (/ calendar-daylight-savings-starts-time
- 60.0 24.0))))
- (dst-ends (and dst-ends-gregorian
- (+ (calendar-absolute-from-gregorian
- dst-ends-gregorian)
- (/ (- calendar-daylight-savings-ends-time
- calendar-daylight-time-offset)
- 60.0 24.0)))))
- (and dst-starts dst-ends
- (if (< dst-starts dst-ends)
- (and (<= dst-starts date) (< date dst-ends))
- (or (<= dst-starts date) (< date dst-ends))))))
+ dst-ends-gregorian)
+ (/ (- calendar-daylight-savings-ends-time
+ calendar-daylight-time-offset)
+ 60.0 24.0)))))
+ (and dst-starts dst-ends
+ (if (< dst-starts dst-ends)
+ (and (<= dst-starts date) (< date dst-ends))
+ (or (<= dst-starts date) (< date dst-ends)))))))
;; used by calc, lunar, solar.
(defun dst-adjust-time (date time)
diff --git a/lisp/calendar/cal-tex.el b/lisp/calendar/cal-tex.el
index 30429b6d592..78ab0765952 100644
--- a/lisp/calendar/cal-tex.el
+++ b/lisp/calendar/cal-tex.el
@@ -246,8 +246,6 @@ This definition is the heart of the calendar!")
(autoload 'holiday-in-range "holidays")
-(define-obsolete-function-alias 'cal-tex-list-holidays 'holiday-in-range "24.3")
-
(autoload 'diary-list-entries "diary-lib")
(defun cal-tex-list-diary-entries (d1 d2)
diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el
index a15f15cf307..de8f758fae8 100644
--- a/lisp/calendar/calendar.el
+++ b/lisp/calendar/calendar.el
@@ -1,4 +1,4 @@
-;;; calendar.el --- calendar functions
+;;; calendar.el --- calendar functions -*- lexical-binding:t -*-
;; Copyright (C) 1988-1995, 1997, 2000-2019 Free Software Foundation,
;; Inc.
@@ -114,6 +114,37 @@
(load "cal-loaddefs" nil t)
+;; Calendar has historically relied heavily on dynamic scoping.
+;; Concretely, this manifests in the use of references to let-bound variables
+;; in Custom vars as well as code in diary files.
+;; `eval` is hence the core of the culprit. It's used on:
+;; - calendar-date-display-form
+;; - calendar-time-display-form
+;; - calendar-chinese-time-zone
+;; - in cal-dst's there are various calls to `eval' but they seem not to refer
+;; to let-bound variables, surprisingly.
+;; - calendar-date-echo-text
+;; - calendar-mode-line-format
+;; - cal-tex-daily-string
+;; - diary-date-forms
+;; - diary-remind-message
+;; - calendar-holidays
+;; - calendar-location-name
+;; - whatever is passed to calendar-string-spread
+;; - whatever is passed to calendar-insert-at-column
+;; - whatever is passed to diary-sexp-entry
+;; - whatever is passed to diary-remind
+
+(defmacro calendar-dlet* (binders &rest body)
+ "Like `let*' but using dynamic scoping."
+ (declare (indent 1) (debug let))
+ `(progn
+ (with-no-warnings ;Silence "lacks a prefix" warnings!
+ ,@(mapcar (lambda (binder)
+ `(defvar ,(if (consp binder) (car binder) binder)))
+ binders))
+ (let* ,binders ,@body)))
+
;; Avoid recursive load of calendar when loading cal-menu. Yuck.
(provide 'calendar)
(require 'cal-menu)
@@ -371,7 +402,7 @@ redisplays the diary for whatever date the cursor is moved to."
(defcustom calendar-date-echo-text
"mouse-2: general menu\nmouse-3: menu for this date"
"String displayed when the cursor is over a date in the calendar.
-Can be either a fixed string, or a lisp expression that returns one.
+Can be either a fixed string, or a Lisp expression that returns one.
When this expression is evaluated, DAY, MONTH, and YEAR are
integers appropriate to the relevant date. For example, to
display the ISO date:
@@ -465,8 +496,8 @@ Then redraw the calendar, if necessary."
(defcustom calendar-left-margin 5
"Empty space to the left of the first month in the calendar."
:group 'calendar
- :initialize 'custom-initialize-default
- :set 'calendar-set-layout-variable
+ :initialize #'custom-initialize-default
+ :set #'calendar-set-layout-variable
:type 'integer
:version "23.1")
@@ -476,7 +507,7 @@ Then redraw the calendar, if necessary."
(defcustom calendar-intermonth-spacing 4
"Space between months in the calendar. Minimum value is 1."
:group 'calendar
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (sym val)
(calendar-set-layout-variable sym val 1))
:type 'integer
@@ -485,7 +516,7 @@ Then redraw the calendar, if necessary."
;; FIXME calendar-month-column-width?
(defcustom calendar-column-width 3
"Width of each day column in the calendar. Minimum value is 3."
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (sym val)
(calendar-set-layout-variable sym val 3))
:type 'integer
@@ -505,7 +536,7 @@ WIDTH defaults to `calendar-day-header-width'."
"Width of the day column headers in the calendar.
Must be at least one less than `calendar-column-width'."
:group 'calendar
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (sym val)
(or (calendar-customized-p 'calendar-day-header-array)
(setq calendar-day-header-array
@@ -518,7 +549,7 @@ Must be at least one less than `calendar-column-width'."
(defcustom calendar-day-digit-width 2
"Width of the day digits in the calendar. Minimum value is 2."
:group 'calendar
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (sym val)
(calendar-set-layout-variable sym val 2))
:type 'integer
@@ -542,8 +573,8 @@ See `calendar-intermonth-text'."
(defcustom calendar-intermonth-text nil
"Text to display in the space to the left of each calendar month.
-Can be nil, a fixed string, or a lisp expression that returns a string.
-When the expression is evaluated, the variables DAY, MONTH and YEAR
+Can be nil, a fixed string, or a Lisp expression that returns a string.
+When the expression is evaluated, the variables `day', `month' and `year'
are integers appropriate for the first day in each week.
Will be truncated to the smaller of `calendar-left-margin' and
`calendar-intermonth-spacing'. The last character is forced to be a space.
@@ -714,7 +745,7 @@ calendar package is already loaded). Rather, use either
(const european :tag "Day/Month/Year")
(const iso :tag "Year/Month/Day"))
:initialize 'custom-initialize-default
- :set (lambda (symbol value)
+ :set (lambda (_symbol value)
(calendar-set-date-style value))
:group 'calendar)
@@ -939,7 +970,7 @@ Normally you should not customize this, but `calendar-month-header'."
calendar-european-month-header)
(t calendar-american-month-header))
"Expression to evaluate to return the calendar month headings.
-When this expression is evaluated, the variables MONTH and YEAR are
+When this expression is evaluated, the variables `month' and `year' are
integers appropriate to the relevant month. The result is padded
to the width of `calendar-month-digit-width'.
@@ -1104,7 +1135,7 @@ MON defaults to `displayed-month'. YR defaults to `displayed-year'."
(defmacro calendar-in-read-only-buffer (buffer &rest body)
"Switch to BUFFER and execute the forms in BODY.
First creates or erases BUFFER as needed. Leaves BUFFER read-only,
-with disabled undo. Leaves point at point-min, displays BUFFER."
+with disabled undo. Leaves point at `point-min', displays BUFFER."
(declare (indent 1) (debug t))
`(progn
(set-buffer (get-buffer-create ,buffer))
@@ -1356,7 +1387,7 @@ Optional integers MON and YR are used instead of today's date."
(let* ((inhibit-read-only t)
(today (calendar-current-date))
(month (calendar-extract-month today))
- (day (calendar-extract-day today))
+ ;; (day (calendar-extract-day today))
(year (calendar-extract-year today))
(today-visible (or (not mon)
(<= (abs (calendar-interval mon yr month year)) 1)))
@@ -1458,8 +1489,9 @@ line."
(goto-char (point-min))
(calendar-move-to-column indent)
(insert
- (calendar-string-spread (list calendar-month-header)
- ?\s calendar-month-digit-width))
+ (calendar-dlet* ((month month) (year year))
+ (calendar-string-spread (list calendar-month-header)
+ ?\s calendar-month-digit-width)))
(calendar-ensure-newline)
(calendar-insert-at-column indent calendar-intermonth-header trunc)
;; Use the first N characters of each day to head the columns.
@@ -1474,7 +1506,8 @@ line."
calendar-day-header-width nil ?\s)
(make-string (- calendar-column-width calendar-day-header-width) ?\s)))
(calendar-ensure-newline)
- (calendar-insert-at-column indent calendar-intermonth-text trunc)
+ (calendar-dlet* ((day day) (month month) (year year))
+ (calendar-insert-at-column indent calendar-intermonth-text trunc))
;; Add blank days before the first of the month.
(insert (make-string (* blank-days calendar-column-width) ?\s))
;; Put in the days of the month.
@@ -1484,7 +1517,8 @@ line."
(insert (propertize
(format (format "%%%dd" calendar-day-digit-width) day)
'mouse-face 'highlight
- 'help-echo (eval calendar-date-echo-text)
+ 'help-echo (calendar-dlet* ((day day) (month month) (year year))
+ (eval calendar-date-echo-text))
;; 'date property prevents intermonth text confusing re-searches.
;; (Tried intangible, it did not really work.)
'date t)
@@ -1494,7 +1528,8 @@ line."
(/= day last))
(calendar-ensure-newline)
(setq day (1+ day)) ; first day of next week
- (calendar-insert-at-column indent calendar-intermonth-text trunc)))))
+ (calendar-dlet* ((day day) (month month) (year year))
+ (calendar-insert-at-column indent calendar-intermonth-text trunc))))))
(defun calendar-redraw ()
"Redraw the calendar display, if `calendar-buffer' is live."
@@ -1754,25 +1789,22 @@ For a complete description, see the info node `Calendar/Diary'.
;; so let's make sure they're always set. Most likely, this will be reset
;; soon in calendar-generate, but better safe than sorry.
(unless (boundp 'displayed-month) (setq displayed-month 1))
- (unless (boundp 'displayed-year) (setq displayed-year 2001))
- (if (bound-and-true-p calendar-font-lock-keywords)
- (set (make-local-variable 'font-lock-defaults)
- '(calendar-font-lock-keywords t))))
+ (unless (boundp 'displayed-year) (setq displayed-year 2001)))
(defun calendar-string-spread (strings char length)
"Concatenate list of STRINGS separated with copies of CHAR to fill LENGTH.
-The effect is like mapconcat but the separating pieces are as balanced as
+The effect is like `mapconcat' but the separating pieces are as balanced as
possible. Each item of STRINGS is evaluated before concatenation so it can
actually be an expression that evaluates to a string. If LENGTH is too short,
the STRINGS are just concatenated and the result truncated."
-;; The algorithm is based on equation (3.25) on page 85 of Concrete
-;; Mathematics by Ronald L. Graham, Donald E. Knuth, and Oren Patashnik,
-;; Addison-Wesley, Reading, MA, 1989.
- (let* ((strings (mapcar 'eval
+ ;; The algorithm is based on equation (3.25) on page 85 of Concrete
+ ;; Mathematics by Ronald L. Graham, Donald E. Knuth, and Oren Patashnik,
+ ;; Addison-Wesley, Reading, MA, 1989.
+ (let* ((strings (mapcar #'eval
(if (< (length strings) 2)
(append (list "") strings (list ""))
strings)))
- (n (- length (string-width (apply 'concat strings))))
+ (n (- length (string-width (apply #'concat strings))))
(m (* (1- (length strings)) (char-width char)))
(s (car strings))
(strings (cdr strings))
@@ -1789,17 +1821,18 @@ the STRINGS are just concatenated and the result truncated."
(if (and calendar-mode-line-format
(bufferp (get-buffer calendar-buffer)))
(with-current-buffer calendar-buffer
- (let ((start (- calendar-left-margin 2))
- (date (condition-case nil
- (calendar-cursor-to-nearest-date)
- (error (calendar-current-date)))))
- (setq mode-line-format
- (concat (make-string (max 0 (+ start
- (- (car (window-inside-edges))
- (car (window-edges))))) ?\s)
- (calendar-string-spread
- (mapcar 'eval calendar-mode-line-format)
- ?\s (- calendar-right-margin (1- start))))))
+ (let ((start (- calendar-left-margin 2)))
+ (calendar-dlet* ((date (condition-case nil
+ (calendar-cursor-to-nearest-date)
+ (error (calendar-current-date)))))
+ (setq mode-line-format
+ (concat (make-string (max 0 (+ start
+ (- (car (window-inside-edges))
+ (car (window-edges)))))
+ ?\s)
+ (calendar-string-spread
+ calendar-mode-line-format
+ ?\s (- calendar-right-margin (1- start)))))))
(force-mode-line-update))))
(defun calendar-buffer-list ()
@@ -2033,11 +2066,11 @@ is a string to insert in the minibuffer before reading."
Each abbreviation is no longer than MAXLEN (default `calendar-abbrev-length')
characters."
(or maxlen (setq maxlen calendar-abbrev-length))
- (apply 'vector (mapcar
- (lambda (f)
- ;; TODO? truncate-string-to-width?
- (substring f 0 (min maxlen (length f))))
- full)))
+ (apply #'vector (mapcar
+ (lambda (f)
+ ;; TODO? truncate-string-to-width?
+ (substring f 0 (min maxlen (length f))))
+ full)))
(defcustom calendar-day-name-array
["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"]
@@ -2255,7 +2288,7 @@ If optional NODAY is t, does not ask for day, but just returns
(month (cdr (assoc-string
(completing-read
"Month name: "
- (mapcar 'list (append month-array nil))
+ (mapcar #'list (append month-array nil))
nil t)
(calendar-make-alist month-array 1) t)))
(last (calendar-last-day-of-month month year)))
@@ -2277,13 +2310,6 @@ Negative years are interpreted as years BC; -1 being 1 BC, and so on."
(+ (* 12 (- yr2 yr1))
(- mon2 mon1)))
-(defvar calendar-font-lock-keywords nil
- "Default keywords to highlight in Calendar mode.")
-
-(make-obsolete-variable 'calendar-font-lock-keywords
- "set font-lock keywords in `calendar-mode-hook', \
-or customize calendar faces." "24.4")
-
(defun calendar-day-name (date &optional abbrev absolute)
"Return a string with the name of the day of the week of DATE.
DATE should be a list in the format (MONTH DAY YEAR), unless the
@@ -2323,7 +2349,7 @@ interpreted as BC; -1 being 1 BC, and so on."
(setq calendar-mark-holidays-flag nil
calendar-mark-diary-entries-flag nil)
(with-current-buffer calendar-buffer
- (mapc 'delete-overlay (overlays-in (point-min) (point-max)))))
+ (mapc #'delete-overlay (overlays-in (point-min) (point-max)))))
(defun calendar-date-is-visible-p (date)
"Return non-nil if DATE is valid and is visible in the calendar window."
@@ -2426,7 +2452,7 @@ ATTRLIST is a list with elements of the form :face face :foreground color."
(make-face temp-face)
(copy-face face temp-face)
;; Apply the font aspects.
- (apply 'set-face-attribute temp-face nil (nreverse faceinfo))
+ (apply #'set-face-attribute temp-face nil (nreverse faceinfo))
temp-face)))
(defun calendar-mark-visible-date (date &optional mark)
@@ -2498,13 +2524,14 @@ and day names to be abbreviated as specified by
`calendar-month-abbrev-array' and `calendar-day-abbrev-array',
respectively. An optional parameter NODAYNAME, when t, omits the
name of the day of the week."
- (let* ((dayname (unless nodayname (calendar-day-name date abbreviate)))
- (month (calendar-extract-month date))
+ (let ((month (calendar-extract-month date)))
+ (calendar-dlet*
+ ((dayname (unless nodayname (calendar-day-name date abbreviate)))
(monthname (calendar-month-name month abbreviate))
(day (number-to-string (calendar-extract-day date)))
(month (number-to-string month))
(year (number-to-string (calendar-extract-year date))))
- (mapconcat 'eval calendar-date-display-form "")))
+ (mapconcat #'eval calendar-date-display-form ""))))
(defun calendar-dayname-on-or-before (dayname date)
"Return the absolute date of the DAYNAME on or before absolute DATE.
@@ -2607,11 +2634,11 @@ If called by a mouse-event, pops up a menu with the result."
selection)
(if (mouse-event-p event)
(and (setq selection (cal-menu-x-popup-menu event title
- (mapcar 'list others)))
+ (mapcar #'list others)))
(call-interactively selection))
(calendar-in-read-only-buffer calendar-other-calendars-buffer
(calendar-set-mode-line title)
- (insert (mapconcat 'identity others "\n"))))))
+ (insert (mapconcat #'identity others "\n"))))))
(defun calendar-print-day-of-year ()
"Show day number in year/days remaining in year for date under the cursor."
diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el
index 164363c2b70..1be2a05eee3 100644
--- a/lisp/calendar/diary-lib.el
+++ b/lisp/calendar/diary-lib.el
@@ -1,4 +1,4 @@
-;;; diary-lib.el --- diary functions
+;;; diary-lib.el --- diary functions -*- lexical-binding:t -*-
;; Copyright (C) 1989-1990, 1992-1995, 2001-2019 Free Software
;; Foundation, Inc.
@@ -119,7 +119,7 @@ are: `string', `symbol', `int', `tnil', `stringtnil.'"
:type 'boolean
:group 'diary)
-(defcustom diary-file-name-prefix-function 'identity
+(defcustom diary-file-name-prefix-function #'identity
"The function that will take a diary file name and return the desired prefix."
:type 'function
:group 'diary)
@@ -151,12 +151,14 @@ See also `diary-comment-start'."
:group 'diary)
(defcustom diary-hook nil
- "List of functions called after the display of the diary.
-Used for example by the appointment package - see `appt-activate'."
+ "Hook run after displaying the diary.
+Used for example by the appointment package - see `appt-activate'.
+The variables `number' and `original-date' are dynamically bound around
+the call."
:type 'hook
:group 'diary)
-(defcustom diary-display-function 'diary-fancy-display
+(defcustom diary-display-function #'diary-fancy-display
"Function used to display the diary.
The two standard options are `diary-fancy-display' and `diary-simple-display'.
@@ -185,9 +187,9 @@ diary buffer to be displayed with diary entries from various
included files, each day's entries sorted into lexicographic
order, add the following to your init file:
- (setq diary-display-function \\='diary-fancy-display)
- (add-hook \\='diary-list-entries-hook \\='diary-include-other-diary-files)
- (add-hook \\='diary-list-entries-hook \\='diary-sort-entries t)
+ (setq diary-display-function #\\='diary-fancy-display)
+ (add-hook \\='diary-list-entries-hook #\\='diary-include-other-diary-files)
+ (add-hook \\='diary-list-entries-hook #\\='diary-sort-entries t)
Note how the sort function is placed last, so that it can sort
the entries included from other files.
@@ -251,7 +253,7 @@ use `diary-mark-entries-hook', which runs only for the main diary file."
diary-islamic-mark-entries)
:group 'diary)
-(defcustom diary-print-entries-hook 'lpr-buffer
+(defcustom diary-print-entries-hook #'lpr-buffer
"Run by `diary-print-entries' after preparing a temporary diary buffer.
The buffer shows only the diary entries currently visible in the
diary buffer. The default just does the printing. Other uses
@@ -328,7 +330,8 @@ Returns a string using match elements 1-5, where:
;; use the standard function calendar-date-string.
(concat (if month
(calendar-date-string (list month (string-to-number day)
- (string-to-number year)) nil t)
+ (string-to-number year))
+ nil t)
(cond ((eq calendar-date-style 'iso) "\\3 \\1 \\2") ; YMD
((eq calendar-date-style 'european) "\\2 \\1 \\3") ; DMY
(t "\\1 \\2 \\3"))) ; MDY
@@ -552,42 +555,40 @@ If ENTRY is a string, search for matches in that string, and remove them.
Returns a list of ENTRY followed by (ATTRIBUTE VALUE) pairs.
When ENTRY is non-nil, FILEGLOBATTRS forms the start of the (ATTRIBUTE VALUE)
pairs."
- (let (regexp regnum attrname attrname attrvalue type ret-attr)
+ (let (ret-attr)
(if (null entry)
(save-excursion
(dolist (attr diary-face-attrs)
;; FIXME inefficient searching.
(goto-char (point-min))
- (setq regexp (concat diary-glob-file-regexp-prefix (car attr))
- regnum (cadr attr)
- attrname (nth 2 attr)
- type (nth 3 attr)
- attrvalue (if (re-search-forward regexp nil t)
- (match-string-no-properties regnum)))
- (and attrvalue
- (setq attrvalue (diary-attrtype-convert attrvalue type))
- (setq ret-attr (append ret-attr
- (list attrname attrvalue))))))
+ (let* ((regexp (concat diary-glob-file-regexp-prefix (car attr)))
+ (regnum (cadr attr))
+ (attrname (nth 2 attr))
+ (type (nth 3 attr))
+ (attrvalue (if (re-search-forward regexp nil t)
+ (match-string-no-properties regnum))))
+ (and attrvalue
+ (setq attrvalue (diary-attrtype-convert attrvalue type))
+ (setq ret-attr (append ret-attr
+ (list attrname attrvalue)))))))
(setq ret-attr fileglobattrs)
(dolist (attr diary-face-attrs)
- (setq regexp (car attr)
- regnum (cadr attr)
- attrname (nth 2 attr)
- type (nth 3 attr)
- attrvalue nil)
- ;; If multiple matches, replace all, use the last (which may
- ;; be the first instance in the line, if the regexp is
- ;; anchored with $).
- (while (string-match regexp entry)
- (setq attrvalue (match-string-no-properties regnum entry)
- entry (replace-match "" t t entry)))
- (and attrvalue
- (setq attrvalue (diary-attrtype-convert attrvalue type))
- (setq ret-attr (append ret-attr (list attrname attrvalue))))))
+ (let ((regexp (car attr))
+ (regnum (cadr attr))
+ (attrname (nth 2 attr))
+ (type (nth 3 attr))
+ (attrvalue nil))
+ ;; If multiple matches, replace all, use the last (which may
+ ;; be the first instance in the line, if the regexp is
+ ;; anchored with $).
+ (while (string-match regexp entry)
+ (setq attrvalue (match-string-no-properties regnum entry)
+ entry (replace-match "" t t entry)))
+ (and attrvalue
+ (setq attrvalue (diary-attrtype-convert attrvalue type))
+ (setq ret-attr (append ret-attr (list attrname attrvalue)))))))
(list entry ret-attr)))
-
-
(defvar diary-modify-entry-list-string-function nil
"Function applied to entry string before putting it into the entries list.
Can be used by programs integrating a diary list into other buffers (e.g.
@@ -656,9 +657,12 @@ any entries were found."
(let* ((month (calendar-extract-month date))
(day (calendar-extract-day date))
(year (calendar-extract-year date))
- (dayname (format "%s\\|%s\\.?" (calendar-day-name date)
- (calendar-day-name date 'abbrev)))
(calendar-month-name-array (or months calendar-month-name-array))
+ (case-fold-search t)
+ entry-found)
+ (calendar-dlet*
+ ((dayname (format "%s\\|%s\\.?" (calendar-day-name date)
+ (calendar-day-name date 'abbrev)))
(monthname (format "\\*\\|%s%s" (calendar-month-name month)
(if months ""
(format "\\|%s\\.?"
@@ -668,61 +672,60 @@ any entries were found."
(year (format "\\*\\|0*%d%s" year
(if diary-abbreviated-year-flag
(format "\\|%02d" (% year 100))
- "")))
- (case-fold-search t)
- entry-found)
- (dolist (date-form diary-date-forms)
- (let ((backup (when (eq (car date-form) 'backup)
- (setq date-form (cdr date-form))
- t))
- ;; date-form uses day etc as set above.
- (regexp (format "^%s?%s\\(%s\\)" (regexp-quote mark)
- (if symbol (regexp-quote symbol) "")
- (mapconcat 'eval date-form "\\)\\(?:")))
- entry-start date-start temp)
- (goto-char (point-min))
- (while (re-search-forward regexp nil t)
- (if backup (re-search-backward "\\<" nil t))
- ;; regexp moves us past the end of date, onto the next line.
- ;; Trailing whitespace after date not allowed (see diary-file).
- (if (and (bolp) (not (looking-at "[ \t]")))
- ;; Diary entry that consists only of date.
- (backward-char 1)
- ;; Found a nonempty diary entry--make it
- ;; visible and add it to the list.
- (setq date-start (line-end-position 0))
- ;; Actual entry starts on the next-line?
- (if (looking-at "[ \t]*\n[ \t]") (forward-line 1))
- (setq entry-found t
- entry-start (point))
- (forward-line 1)
- (while (looking-at "[ \t]") ; continued entry
- (forward-line 1))
- (unless (and (eobp) (not (bolp)))
- (backward-char 1))
- (unless list-only
- (remove-overlays date-start (point) 'invisible 'diary))
- (setq temp (diary-pull-attrs
- (buffer-substring-no-properties
- entry-start (point)) globattr))
- (diary-add-to-list
- (or gdate date) (car temp)
- (buffer-substring-no-properties (1+ date-start) (1- entry-start))
- (copy-marker entry-start) (cadr temp))))))
- entry-found))
+ ""))))
+ (dolist (date-form diary-date-forms)
+ (let ((backup (when (eq (car date-form) 'backup)
+ (setq date-form (cdr date-form))
+ t))
+ ;; date-form uses day etc as set above.
+ (regexp (format "^%s?%s\\(%s\\)" (regexp-quote mark)
+ (if symbol (regexp-quote symbol) "")
+ (mapconcat #'eval date-form "\\)\\(?:")))
+ entry-start date-start temp)
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (if backup (re-search-backward "\\<" nil t))
+ ;; regexp moves us past the end of date, onto the next line.
+ ;; Trailing whitespace after date not allowed (see diary-file).
+ (if (and (bolp) (not (looking-at "[ \t]")))
+ ;; Diary entry that consists only of date.
+ (backward-char 1)
+ ;; Found a nonempty diary entry--make it
+ ;; visible and add it to the list.
+ (setq date-start (line-end-position 0))
+ ;; Actual entry starts on the next-line?
+ (if (looking-at "[ \t]*\n[ \t]") (forward-line 1))
+ (setq entry-found t
+ entry-start (point))
+ (forward-line 1)
+ (while (looking-at "[ \t]") ; continued entry
+ (forward-line 1))
+ (unless (and (eobp) (not (bolp)))
+ (backward-char 1))
+ (unless list-only
+ (remove-overlays date-start (point) 'invisible 'diary))
+ (setq temp (diary-pull-attrs
+ (buffer-substring-no-properties
+ entry-start (point))
+ globattr))
+ (diary-add-to-list
+ (or gdate date) (car temp)
+ (buffer-substring-no-properties
+ (1+ date-start) (1- entry-start))
+ (copy-marker entry-start) (cadr temp))))))
+ entry-found)))
(defvar original-date) ; from diary-list-entries
(defvar file-glob-attrs)
-(defvar list-only)
-(defvar number)
(defun diary-list-entries-1 (months symbol absfunc)
"List diary entries of a certain type.
MONTHS is an array of month names. SYMBOL marks diary entries of the type
in question. ABSFUNC is a function that converts absolute dates to dates
of the appropriate type."
+ (with-no-warnings (defvar number) (defvar list-only))
(let ((gdate original-date))
- (dotimes (_idummy number)
+ (dotimes (_ number)
(diary-list-entries-2
(funcall absfunc (calendar-absolute-from-gregorian gdate))
diary-nonmarking-symbol file-glob-attrs list-only months symbol gdate)
@@ -735,6 +738,10 @@ of the appropriate type."
"List of any diary files included in the last call to `diary-list-entries'.
Or to `diary-mark-entries'.")
+(defvar diary-saved-point) ; bound in diary-list-entries
+(defvar diary-including)
+(defvar diary--date-string) ; bound in diary-list-entries
+
(defun diary-list-entries (date number &optional list-only)
"Create and display a buffer containing the relevant lines in `diary-file'.
Selects entries for NUMBER days starting with date DATE. Hides any
@@ -774,10 +781,10 @@ After preparing the initial list, hooks run in this order:
`diary-hook' runs last, after the diary is displayed.
This is used e.g. by `appt-check'.
-Functions called by these hooks may use the variables ORIGINAL-DATE
-and NUMBER, which are the arguments with which this function was called.
-Note that hook functions should _not_ use DATE, but ORIGINAL-DATE.
-\(Sexp diary entries may use DATE - see `diary-list-sexp-entries'.)
+Functions called by these hooks may use the variables `original-date'
+and `number', which are the arguments with which this function was called.
+Note that hook functions should _not_ use `date', but `original-date'.
+\(Sexp diary entries may use `date' - see `diary-list-sexp-entries'.)
This function displays the list using `diary-display-function', unless
LIST-ONLY is non-nil, in which case it just returns the list."
@@ -787,7 +794,7 @@ LIST-ONLY is non-nil, in which case it just returns the list."
diary-number-of-entries)))
(when (> number 0)
(let* ((original-date date) ; save for possible use in the hooks
- (date-string (calendar-date-string date))
+ (diary--date-string (calendar-date-string date))
(diary-buffer (find-buffer-visiting diary-file))
;; Dynamically bound in diary-include-files.
(d-incp (and (boundp 'diary-including) diary-including))
@@ -832,7 +839,7 @@ LIST-ONLY is non-nil, in which case it just returns the list."
(set (make-local-variable 'diary-selective-display) t)
(overlay-put ol 'invisible 'diary)
(overlay-put ol 'evaporate t)))
- (dotimes (_idummy number)
+ (dotimes (_ number)
(let ((sexp-found (diary-list-sexp-entries date))
(entry-found (diary-list-entries-2
date diary-nonmarking-symbol
@@ -848,8 +855,10 @@ LIST-ONLY is non-nil, in which case it just returns the list."
;; every time, diary-include-other-diary-files
;; binds it to nil (essentially) when it runs
;; in included files.
- (run-hooks 'diary-nongregorian-listing-hook
- 'diary-list-entries-hook)
+ (calendar-dlet* ((number number)
+ (list-only list-only))
+ (run-hooks 'diary-nongregorian-listing-hook
+ 'diary-list-entries-hook))
;; We could make this explicit:
;;; (run-hooks 'diary-nongregorian-listing-hook)
;;; (if d-incp
@@ -865,7 +874,9 @@ LIST-ONLY is non-nil, in which case it just returns the list."
(copy-sequence
(car display-buffer-fallback-action))))))
(funcall diary-display-function)))
- (run-hooks 'diary-hook)))))
+ (calendar-dlet* ((number number)
+ (original-date original-date))
+ (run-hooks 'diary-hook))))))
(and temp-buff (buffer-name temp-buff) (kill-buffer temp-buff)))
(or d-incp (message "Preparing diary...done"))
diary-entries-list)))
@@ -878,8 +889,6 @@ LIST-ONLY is non-nil, in which case it just returns the list."
(remove-overlays (point-min) (point-max) 'invisible 'diary))
(kill-local-variable 'mode-line-format))
-(defvar original-date) ; bound in diary-list-entries
-;(defvar number) ; already declared above
(defun diary-include-files (&optional mark)
"Process diary entries from included diary files.
@@ -894,8 +903,8 @@ This is recursive; that is, included files may include other files."
(format "^%s \"\\([^\"]*\\)\"" (regexp-quote diary-include-string))
nil t)
(let ((diary-file (match-string-no-properties 1))
- (diary-mark-entries-hook 'diary-mark-included-diary-files)
- (diary-list-entries-hook 'diary-include-other-diary-files)
+ (diary-mark-entries-hook #'diary-mark-included-diary-files)
+ (diary-list-entries-hook #'diary-include-other-diary-files)
(diary-including t)
diary-hook diary-list-include-blanks efile)
(if (file-exists-p diary-file)
@@ -907,6 +916,13 @@ This is recursive; that is, included files may include other files."
(append diary-included-files (list efile)))
(if mark
(diary-mark-entries)
+ ;; FIXME: `diary-include-files' can be run from
+ ;; diary-mark-entries-hook (via
+ ;; diary-mark-included-diary-files) or from
+ ;; diary-list-entries-hook (via
+ ;; diary-include-other-diary-files). In the "list" case,
+ ;; `number' is dynamically bound, but not in the "mark" case!
+ (with-no-warnings (defvar number))
(setq diary-entries-list
(append diary-entries-list
(diary-list-entries original-date number t)))))
@@ -929,8 +945,6 @@ For details, see `diary-include-files'.
See also `diary-mark-included-diary-files'."
(diary-include-files))
-(defvar date-string) ; bound in diary-list-entries
-
(defun diary-display-no-entries ()
"Common subroutine of `diary-simple-display' and `diary-fancy-display'.
Handles the case where there are no diary entries.
@@ -938,9 +952,9 @@ Returns a cons (NOENTRIES . HOLIDAY-STRING)."
(let* ((holiday-list (if diary-show-holidays-flag
(calendar-check-holidays original-date)))
(hol-string (format "%s%s%s"
- date-string
+ diary--date-string
(if holiday-list ": " "")
- (mapconcat 'identity holiday-list "; ")))
+ (mapconcat #'identity holiday-list "; ")))
(msg (format "No diary entries for %s" hol-string))
;; Empty list, or single item with no text.
;; FIXME multiple items with no text?
@@ -956,14 +970,13 @@ Returns a cons (NOENTRIES . HOLIDAY-STRING)."
(message "%s" msg)
;; holiday-list which is too wide for a message gets a buffer.
(calendar-in-read-only-buffer holiday-buffer
- (calendar-set-mode-line (format "Holidays for %s" date-string))
- (insert (mapconcat 'identity holiday-list "\n")))
- (message "No diary entries for %s" date-string)))
+ (calendar-set-mode-line (format "Holidays for %s"
+ diary--date-string))
+ (insert (mapconcat #'identity holiday-list "\n")))
+ (message "No diary entries for %s" diary--date-string)))
(cons noentries hol-string)))
-(defvar diary-saved-point) ; bound in diary-list-entries
-
(defun diary-simple-display ()
"Display the diary buffer if there are any relevant entries or holidays.
Entries that do not apply are made invisible. Holidays are shown
@@ -987,7 +1000,7 @@ in the mode line. This is an option for `diary-display-function'."
(set-window-point window diary-saved-point)
(set-window-start window (point-min)))))))
-(defvar diary-goto-entry-function 'diary-goto-entry
+(defvar diary-goto-entry-function #'diary-goto-entry
"Function called to jump to a diary entry.
Modes that require special handling of the included file
containing the diary entry can assign a suitable function to this
@@ -1022,6 +1035,9 @@ variable.")
(goto-char (match-beginning 1)))))
(message "Unable to locate this diary entry")))))
+(defvar displayed-year) ; bound in calendar-generate
+(defvar displayed-month)
+
(defun diary-fancy-display ()
"Prepare a diary buffer with relevant entries in a fancy, noneditable form.
Holidays are shown unless `diary-show-holidays-flag' is nil.
@@ -1111,7 +1127,7 @@ This is an option for `diary-display-function'."
(if (eq major-mode 'diary-fancy-display-mode)
(run-hooks 'diary-fancy-display-mode-hook)
(diary-fancy-display-mode))
- (calendar-set-mode-line date-string))))
+ (calendar-set-mode-line diary--date-string))))
;; FIXME modernize?
(defun diary-print-entries ()
@@ -1204,7 +1220,7 @@ ensure that all relevant variables are set.
(interactive "P")
(if (string-equal diary-mail-addr "")
(user-error "You must set `diary-mail-addr' to use this command")
- (let ((diary-display-function 'diary-fancy-display))
+ (let ((diary-display-function #'diary-fancy-display))
(diary-list-entries (calendar-current-date) (or ndays diary-mail-days)))
(compose-mail diary-mail-addr
(concat "Diary entries generated "
@@ -1242,109 +1258,111 @@ MARKFUNC is a function that marks entries of the appropriate type
matching a given date pattern. MONTHS is an array of month names.
SYMBOL marks diary entries of the type in question. ABSFUNC is a
function that converts absolute dates to dates of the appropriate type. "
- (let ((dayname (diary-name-pattern calendar-day-name-array
- calendar-day-abbrev-array))
- (monthname (format "%s\\|\\*"
- (if months
- (diary-name-pattern months)
- (diary-name-pattern calendar-month-name-array
- calendar-month-abbrev-array))))
- (month "[0-9]+\\|\\*")
- (day "[0-9]+\\|\\*")
- (year "[0-9]+\\|\\*")
- (case-fold-search t)
- marks)
- (dolist (date-form diary-date-forms)
- (if (eq (car date-form) 'backup) ; ignore 'backup directive
- (setq date-form (cdr date-form)))
- (let* ((l (length date-form))
- (d-name-pos (- l (length (memq 'dayname date-form))))
- (d-name-pos (if (/= l d-name-pos) (1+ d-name-pos)))
- (m-name-pos (- l (length (memq 'monthname date-form))))
- (m-name-pos (if (/= l m-name-pos) (1+ m-name-pos)))
- (d-pos (- l (length (memq 'day date-form))))
- (d-pos (if (/= l d-pos) (1+ d-pos)))
- (m-pos (- l (length (memq 'month date-form))))
- (m-pos (if (/= l m-pos) (1+ m-pos)))
- (y-pos (- l (length (memq 'year date-form))))
- (y-pos (if (/= l y-pos) (1+ y-pos)))
- (regexp (format "^%s\\(%s\\)"
- (if symbol (regexp-quote symbol) "")
- (mapconcat 'eval date-form "\\)\\("))))
- (goto-char (point-min))
- (while (re-search-forward regexp nil t)
- (let* ((dd-name
- (if d-name-pos
- (match-string-no-properties d-name-pos)))
- (mm-name
- (if m-name-pos
- (match-string-no-properties m-name-pos)))
- (mm (string-to-number
- (if m-pos
- (match-string-no-properties m-pos)
- "")))
- (dd (string-to-number
- (if d-pos
- (match-string-no-properties d-pos)
- "")))
- (y-str (if y-pos
- (match-string-no-properties y-pos)))
- (yy (if (not y-str)
- 0
- (if (and (= (length y-str) 2)
- diary-abbreviated-year-flag)
- (let* ((current-y
- (calendar-extract-year
- (if absfunc
- (funcall
- absfunc
- (calendar-absolute-from-gregorian
- (calendar-current-date)))
- (calendar-current-date))))
- (y (+ (string-to-number y-str)
- ;; Current century, eg 2000.
- (* 100 (/ current-y 100))))
- (offset (- y current-y)))
- ;; Add 2-digit year to current century.
- ;; If more than 50 years in the future,
- ;; assume last century. If more than 50
- ;; years in the past, assume next century.
- (if (> offset 50)
- (- y 100)
- (if (< offset -50)
- (+ y 100)
- y)))
- (string-to-number y-str)))))
- (setq marks (cadr (diary-pull-attrs
- (buffer-substring-no-properties
- (point) (line-end-position))
- file-glob-attrs)))
- ;; Only mark all days of a given name if the pattern
- ;; contains no more specific elements.
- (if (and dd-name (not (or d-pos m-pos y-pos)))
- (calendar-mark-days-named
- (cdr (assoc-string dd-name
+ (calendar-dlet*
+ ((dayname (diary-name-pattern calendar-day-name-array
+ calendar-day-abbrev-array))
+ (monthname (format "%s\\|\\*"
+ (if months
+ (diary-name-pattern months)
+ (diary-name-pattern calendar-month-name-array
+ calendar-month-abbrev-array))))
+ (month "[0-9]+\\|\\*")
+ (day "[0-9]+\\|\\*")
+ (year "[0-9]+\\|\\*"))
+ (let* ((case-fold-search t)
+ marks)
+ (dolist (date-form diary-date-forms)
+ (if (eq (car date-form) 'backup) ; ignore 'backup directive
+ (setq date-form (cdr date-form)))
+ (let* ((l (length date-form))
+ (d-name-pos (- l (length (memq 'dayname date-form))))
+ (d-name-pos (if (/= l d-name-pos) (1+ d-name-pos)))
+ (m-name-pos (- l (length (memq 'monthname date-form))))
+ (m-name-pos (if (/= l m-name-pos) (1+ m-name-pos)))
+ (d-pos (- l (length (memq 'day date-form))))
+ (d-pos (if (/= l d-pos) (1+ d-pos)))
+ (m-pos (- l (length (memq 'month date-form))))
+ (m-pos (if (/= l m-pos) (1+ m-pos)))
+ (y-pos (- l (length (memq 'year date-form))))
+ (y-pos (if (/= l y-pos) (1+ y-pos)))
+ (regexp (format "^%s\\(%s\\)"
+ (if symbol (regexp-quote symbol) "")
+ (mapconcat #'eval date-form "\\)\\("))))
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (let* ((dd-name
+ (if d-name-pos
+ (match-string-no-properties d-name-pos)))
+ (mm-name
+ (if m-name-pos
+ (match-string-no-properties m-name-pos)))
+ (mm (string-to-number
+ (if m-pos
+ (match-string-no-properties m-pos)
+ "")))
+ (dd (string-to-number
+ (if d-pos
+ (match-string-no-properties d-pos)
+ "")))
+ (y-str (if y-pos
+ (match-string-no-properties y-pos)))
+ (yy (if (not y-str)
+ 0
+ (if (and (= (length y-str) 2)
+ diary-abbreviated-year-flag)
+ (let* ((current-y
+ (calendar-extract-year
+ (if absfunc
+ (funcall
+ absfunc
+ (calendar-absolute-from-gregorian
+ (calendar-current-date)))
+ (calendar-current-date))))
+ (y (+ (string-to-number y-str)
+ ;; Current century, eg 2000.
+ (* 100 (/ current-y 100))))
+ (offset (- y current-y)))
+ ;; Add 2-digit year to current century.
+ ;; If more than 50 years in the future,
+ ;; assume last century. If more than 50
+ ;; years in the past, assume next century.
+ (if (> offset 50)
+ (- y 100)
+ (if (< offset -50)
+ (+ y 100)
+ y)))
+ (string-to-number y-str)))))
+ (setq marks (cadr (diary-pull-attrs
+ (buffer-substring-no-properties
+ (point) (line-end-position))
+ file-glob-attrs)))
+ ;; Only mark all days of a given name if the pattern
+ ;; contains no more specific elements.
+ (if (and dd-name (not (or d-pos m-pos y-pos)))
+ (calendar-mark-days-named
+ (cdr (assoc-string dd-name
+ (calendar-make-alist
+ calendar-day-name-array
+ 0 nil calendar-day-abbrev-array
+ (mapcar (lambda (e)
+ (format "%s." e))
+ calendar-day-abbrev-array))
+ t))
+ marks)
+ (if mm-name
+ (setq mm
+ (if (string-equal mm-name "*") 0
+ (cdr (assoc-string
+ mm-name
+ (if months (calendar-make-alist months)
(calendar-make-alist
- calendar-day-name-array
- 0 nil calendar-day-abbrev-array
+ calendar-month-name-array
+ 1 nil calendar-month-abbrev-array
(mapcar (lambda (e)
(format "%s." e))
- calendar-day-abbrev-array))
- t)) marks)
- (if mm-name
- (setq mm
- (if (string-equal mm-name "*") 0
- (cdr (assoc-string
- mm-name
- (if months (calendar-make-alist months)
- (calendar-make-alist
- calendar-month-name-array
- 1 nil calendar-month-abbrev-array
- (mapcar (lambda (e)
- (format "%s." e))
- calendar-month-abbrev-array)))
- t)))))
- (funcall markfunc mm dd yy marks))))))))
+ calendar-month-abbrev-array)))
+ t)))))
+ (funcall markfunc mm dd yy marks)))))))))
;;;###cal-autoload
(defun diary-mark-entries (&optional redraw)
@@ -1394,42 +1412,44 @@ marks. This is intended to deal with deleted diary entries."
(setq file-glob-attrs (nth 1 (diary-pull-attrs nil '())))
(with-syntax-table diary-syntax-table
(save-excursion
- (diary-mark-entries-1 'calendar-mark-date-pattern)
- (diary-mark-sexp-entries)
- ;; Although it looks like mark-entries-hook runs every time,
- ;; diary-mark-included-diary-files binds it to nil
- ;; (essentially) when it runs in included files.
- (run-hooks 'diary-nongregorian-marking-hook
- 'diary-mark-entries-hook))))
+ (save-restriction
+ (widen) ; bug#33423
+ (diary-mark-entries-1 'calendar-mark-date-pattern)
+ (diary-mark-sexp-entries)
+ ;; Although it looks like mark-entries-hook runs every time,
+ ;; diary-mark-included-diary-files binds it to nil
+ ;; (essentially) when it runs in included files.
+ (run-hooks 'diary-nongregorian-marking-hook
+ 'diary-mark-entries-hook)))))
(and temp-buff (buffer-name temp-buff) (kill-buffer temp-buff)))
(or d-incp (message "Marking diary entries...done"))))
(defun diary-sexp-entry (sexp entry date)
"Process a SEXP diary ENTRY for DATE."
- (let ((result (if calendar-debug-sexp
- (let ((debug-on-error t))
- (eval (car (read-from-string sexp))))
- (let (err)
- (condition-case err
- (eval (car (read-from-string sexp)))
- (error
- (display-warning
- 'diary
- (format "Bad diary sexp at line %d in %s:\n%s\n\
-Error: %s\n"
- (count-lines (point-min) (point))
- diary-file sexp err)
- :error)
- nil))))))
+ (let ((result
+ (calendar-dlet* ((date date)
+ (entry entry))
+ (if calendar-debug-sexp
+ (let ((debug-on-error t))
+ (eval (car (read-from-string sexp))))
+ (condition-case err
+ (eval (car (read-from-string sexp)))
+ (error
+ (display-warning
+ 'diary
+ (format "Bad diary sexp at line %d in %s:\n%s\n\
+Error: %S\n"
+ (count-lines (point-min) (point))
+ diary-file sexp err)
+ :error)
+ nil))))))
(cond ((stringp result) result)
((and (consp result)
- (stringp (cdr result))) result)
+ (stringp (cdr result)))
+ result)
(result entry)
(t nil))))
-(defvar displayed-year) ; bound in calendar-generate
-(defvar displayed-month)
-
(defun diary-mark-sexp-entries ()
"Mark days in the calendar window that have sexp diary entries.
Each entry in the diary file (or included files) visible in the calendar window
@@ -1532,7 +1552,7 @@ passed to `calendar-mark-visible-date' as MARK."
(let ((m displayed-month)
(y displayed-year))
(calendar-increment-month m y -1)
- (dotimes (_idummy 3)
+ (dotimes (_ 3)
(calendar-mark-month m y month day year color)
(calendar-increment-month m y 1)))))
@@ -1651,7 +1671,7 @@ Sexp diary entries must be prefaced by a `diary-sexp-entry-symbol'
%%(SEXP) ENTRY
-Both ENTRY and DATE are available when the SEXP is evaluated. If
+Both `entry' and `date' are available when the SEXP is evaluated. If
the SEXP returns nil, the diary entry does not apply. If it
returns a non-nil value, ENTRY will be taken to apply to DATE; if
the value is a string, that string will be the diary entry in the
@@ -1814,9 +1834,6 @@ form used internally by the calendar and diary."
;;; Sexp diary functions.
-(defvar date)
-(defvar entry)
-
;; To be called from diary-sexp-entry, where DATE, ENTRY are bound.
(defun diary-date (month day year &optional mark)
"Specific date(s) diary entry.
@@ -1827,6 +1844,7 @@ of the input parameters changes according to `calendar-date-style'
An optional parameter MARK specifies a face or single-character string
to use when highlighting the day in the calendar."
+ (with-no-warnings (defvar date) (defvar entry))
(let* ((ddate (diary-make-date month day year))
(dd (calendar-extract-day ddate))
(mm (calendar-extract-month ddate))
@@ -1855,6 +1873,7 @@ of the input parameters changes according to `calendar-date-style'
An optional parameter MARK specifies a face or single-character string
to use when highlighting the day in the calendar."
+ (with-no-warnings (defvar date) (defvar entry))
(let ((date1 (calendar-absolute-from-gregorian
(diary-make-date m1 d1 y1)))
(date2 (calendar-absolute-from-gregorian
@@ -1873,6 +1892,7 @@ DAY defaults to 1 if N>0, and MONTH's last day otherwise.
MONTH can be a list of months, an integer, or t (meaning all months).
Optional MARK specifies a face or single-character string to use when
highlighting the day in the calendar."
+ (with-no-warnings (defvar date) (defvar entry))
;; This is messy because the diary entry may apply, but the date on which it
;; is based can be in a different month/year. For example, asking for the
;; first Monday after December 30. For large values of |n| the problem is
@@ -1951,6 +1971,7 @@ is considered to be March 1 in non-leap years.
An optional parameter MARK specifies a face or single-character
string to use when highlighting the day in the calendar."
+ (with-no-warnings (defvar date) (defvar entry))
(let* ((ddate (diary-make-date month day year))
(dd (calendar-extract-day ddate))
(mm (calendar-extract-month ddate))
@@ -1975,6 +1996,7 @@ and %s by the ordinal ending of that number (that is, `st', `nd',
An optional parameter MARK specifies a face or single-character
string to use when highlighting the day in the calendar."
+ (with-no-warnings (defvar date) (defvar entry))
(or (> n 0)
(user-error "Day count must be positive"))
(let* ((diff (- (calendar-absolute-from-gregorian date)
@@ -1986,6 +2008,7 @@ string to use when highlighting the day in the calendar."
(defun diary-day-of-year ()
"Day of year and number of days remaining in the year of date diary entry."
+ (with-no-warnings (defvar date))
(calendar-day-of-year-string date))
(defun diary-remind (sexp days &optional marking)
@@ -2007,11 +2030,12 @@ whether the entry itself is a marking or nonmarking; if optional
parameter MARKING is non-nil then the reminders are marked on the
calendar."
;; `date' has a value at this point, from diary-sexp-entry.
+ (with-no-warnings (defvar date))
;; Convert a negative number to a list of days.
(and (integerp days)
(< days 0)
(setq days (number-sequence 1 (- days))))
- (let ((diary-entry (eval sexp)))
+ (calendar-dlet* ((diary-entry (eval sexp)))
(cond
;; Diary entry applies on date.
((and diary-entry
@@ -2027,7 +2051,8 @@ calendar."
(when (setq diary-entry (eval sexp))
;; Discard any mark portion from diary-anniversary, etc.
(if (consp diary-entry) (setq diary-entry (cdr diary-entry)))
- (mapconcat 'eval diary-remind-message ""))))
+ (calendar-dlet* ((days days))
+ (mapconcat #'eval diary-remind-message "")))))
;; Diary entry may apply to one of a list of days before date.
((and (listp days) days)
(or (diary-remind sexp (car days) marking)
@@ -2224,18 +2249,19 @@ If given, optional SYMBOL must be a prefix to entries. If
optional ABBREV-ARRAY is present, also matches the abbreviations
from this array (with or without a final `.'), in addition to the
full month names."
- (let ((dayname (diary-name-pattern calendar-day-name-array
- calendar-day-abbrev-array t))
- (monthname (format "\\(%s\\|\\*\\)"
- (diary-name-pattern month-array abbrev-array)))
- (month "\\([0-9]+\\|\\*\\)")
- (day "\\([0-9]+\\|\\*\\)")
- (year "-?\\([0-9]+\\|\\*\\)"))
+ (calendar-dlet*
+ ((dayname (diary-name-pattern calendar-day-name-array
+ calendar-day-abbrev-array t))
+ (monthname (format "\\(%s\\|\\*\\)"
+ (diary-name-pattern month-array abbrev-array)))
+ (month "\\([0-9]+\\|\\*\\)")
+ (day "\\([0-9]+\\|\\*\\)")
+ (year "-?\\([0-9]+\\|\\*\\)"))
(mapcar (lambda (x)
(cons
(concat "^" (regexp-quote diary-nonmarking-symbol) "?"
(if symbol (regexp-quote symbol) "") "\\("
- (mapconcat 'eval
+ (mapconcat #'eval
;; If backup, omit first item (backup)
;; and last item (not part of date).
(if (equal (car x) 'backup)
@@ -2312,7 +2338,7 @@ return a font-lock pattern matching array of MONTHS and marking SYMBOL."
'font-lock-constant-face)
(cons
(format "^%s?%s" (regexp-quote diary-nonmarking-symbol)
- (regexp-opt (mapcar 'regexp-quote
+ (regexp-opt (mapcar #'regexp-quote
(list diary-hebrew-entry-symbol
diary-islamic-entry-symbol
diary-bahai-entry-symbol
@@ -2345,10 +2371,10 @@ return a font-lock pattern matching array of MONTHS and marking SYMBOL."
(set (make-local-variable 'comment-start) diary-comment-start)
(set (make-local-variable 'comment-end) diary-comment-end)
(add-to-invisibility-spec '(diary . nil))
- (add-hook 'after-save-hook 'diary-redraw-calendar nil t)
+ (add-hook 'after-save-hook #'diary-redraw-calendar nil t)
;; In case the file was modified externally, refresh the calendar
;; after refreshing the diary buffer.
- (add-hook 'after-revert-hook 'diary-redraw-calendar nil t)
+ (add-hook 'after-revert-hook #'diary-redraw-calendar nil t)
(if diary-header-line-flag
(setq header-line-format diary-header-line-format)))
@@ -2359,18 +2385,19 @@ return a font-lock pattern matching array of MONTHS and marking SYMBOL."
"Return a regexp matching the first line of a fancy diary date header.
This depends on the calendar date style."
(concat
- (let ((dayname (diary-name-pattern calendar-day-name-array nil t))
- (monthname (diary-name-pattern calendar-month-name-array nil t))
- (day "1")
- (month "2")
- ;; FIXME? This used to be "-?[0-9]+" - what was the "-?" for?
- (year "3"))
+ (calendar-dlet*
+ ((dayname (diary-name-pattern calendar-day-name-array nil t))
+ (monthname (diary-name-pattern calendar-month-name-array nil t))
+ (day "1")
+ (month "2")
+ ;; FIXME? This used to be "-?[0-9]+" - what was the "-?" for?
+ (year "3"))
;; This is ugly. c-d-d-form expects `day' etc to be "numbers in
;; string form"; eg the iso version calls string-to-number on some.
;; Therefore we cannot eg just let day = "[0-9]+". (Bug#8583).
;; Assumes no integers in c-day/month-name-array.
(replace-regexp-in-string "[0-9]+" "[0-9]+"
- (mapconcat 'eval calendar-date-display-form "")
+ (mapconcat #'eval calendar-date-display-form "")
nil t))
;; Optional ": holiday name" after the date.
"\\(: .*\\)?"))
@@ -2391,7 +2418,8 @@ This depends on the calendar date style."
("^Day.*omer.*$" . font-lock-builtin-face)
("^Parashat.*$" . font-lock-comment-face)
(,(format "\\(^\\|\\s-\\)%s\\(-%s\\)?" diary-time-regexp
- diary-time-regexp) . 'diary-time))
+ diary-time-regexp)
+ . 'diary-time))
"Keywords to highlight in fancy diary display.")
;; If region looks like it might start or end in the middle of a
diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el
index 40bc066c9ec..2b080c30738 100644
--- a/lisp/calendar/holidays.el
+++ b/lisp/calendar/holidays.el
@@ -1,4 +1,4 @@
-;;; holidays.el --- holiday functions for the calendar package
+;;; holidays.el --- holiday functions for the calendar package -*- lexical-binding:t -*-
;; Copyright (C) 1989-1990, 1992-1994, 1997, 2001-2019 Free Software
;; Foundation, Inc.
@@ -64,8 +64,7 @@
(holiday-float 11 4 4 "Thanksgiving")))
"General holidays. Default value is for the United States.
See the documentation for `calendar-holidays' for details."
- :type 'sexp
- :group 'holidays)
+ :type 'sexp)
;;;###autoload
(put 'holiday-general-holidays 'risky-local-variable t)
@@ -86,8 +85,7 @@ See the documentation for `calendar-holidays' for details."
"Oriental holidays.
See the documentation for `calendar-holidays' for details."
:version "23.1" ; added more holidays
- :type 'sexp
- :group 'holidays)
+ :type 'sexp)
;;;###autoload
(put 'holiday-oriental-holidays 'risky-local-variable t)
@@ -95,8 +93,7 @@ See the documentation for `calendar-holidays' for details."
(defcustom holiday-local-holidays nil
"Local holidays.
See the documentation for `calendar-holidays' for details."
- :type 'sexp
- :group 'holidays)
+ :type 'sexp)
;;;###autoload
(put 'holiday-local-holidays 'risky-local-variable t)
@@ -104,8 +101,7 @@ See the documentation for `calendar-holidays' for details."
(defcustom holiday-other-holidays nil
"User defined holidays.
See the documentation for `calendar-holidays' for details."
- :type 'sexp
- :group 'holidays)
+ :type 'sexp)
;;;###autoload
(put 'holiday-other-holidays 'risky-local-variable t)
@@ -122,8 +118,8 @@ See the documentation for `calendar-holidays' for details."
"Jewish holidays.
See the documentation for `calendar-holidays' for details."
:type 'sexp
- :version "23.1" ; removed dependency on hebrew-holidays-N
- :group 'holidays)
+ :version "23.1") ; removed dependency on hebrew-holidays-N
+
;;;###autoload
(put 'holiday-hebrew-holidays 'risky-local-variable t)
@@ -141,8 +137,7 @@ See the documentation for `calendar-holidays' for details."
(holiday-advent 0 "Advent")))))
"Christian holidays.
See the documentation for `calendar-holidays' for details."
- :type 'sexp
- :group 'holidays)
+ :type 'sexp)
;;;###autoload
(put 'holiday-christian-holidays 'risky-local-variable t)
@@ -162,8 +157,7 @@ See the documentation for `calendar-holidays' for details."
(holiday-islamic 12 10 "Id-al-Adha")))))
"Islamic holidays.
See the documentation for `calendar-holidays' for details."
- :type 'sexp
- :group 'holidays)
+ :type 'sexp)
;;;###autoload
(put 'holiday-islamic-holidays 'risky-local-variable t)
@@ -183,8 +177,7 @@ See the documentation for `calendar-holidays' for details."
(holiday-fixed 11 28 "Ascension of `Abdu’l-Bahá")))))
"Bahá’í holidays.
See the documentation for `calendar-holidays' for details."
- :type 'sexp
- :group 'holidays)
+ :type 'sexp)
;;;###autoload
(put 'holiday-bahai-holidays 'risky-local-variable t)
@@ -204,8 +197,7 @@ See the documentation for `calendar-holidays' for details."
calendar-daylight-time-zone-name)))))
"Sun-related holidays.
See the documentation for `calendar-holidays' for details."
- :type 'sexp
- :group 'holidays)
+ :type 'sexp)
;;;###autoload
(put 'holiday-solar-holidays 'risky-local-variable t)
@@ -323,8 +315,7 @@ you've written to return a (possibly empty) list of the relevant VISIBLE dates
with descriptive strings such as
(((2 6 1989) \"New Moon\") ((2 12 1989) \"First Quarter Moon\") ... )."
- :type 'sexp
- :group 'holidays)
+ :type 'sexp)
;;;###autoload
(put 'calendar-holidays 'risky-local-variable t)
@@ -336,14 +327,14 @@ with descriptive strings such as
(defun calendar-holiday-list ()
"Form the list of holidays that occur on dates in the calendar window.
The holidays are those in the list `calendar-holidays'."
- (let (res h err)
+ (let (res h)
(sort
(dolist (p calendar-holidays res)
(if (setq h (if calendar-debug-sexp
(let ((debug-on-error t))
- (eval p))
+ (eval p t))
(condition-case err
- (eval p)
+ (eval p t)
(error
(display-warning
'holidays
@@ -470,7 +461,7 @@ The optional LABEL is used to label the buffer created."
(choice (capitalize
(completing-read "List (TAB for choices): " lists nil t)))
(which (if (string-equal choice "Ask")
- (eval (read-variable "Enter list name: "))
+ (symbol-value (read-variable "Enter list name: "))
(cdr (assoc choice lists))))
(name (if (string-equal choice "Equinoxes/Solstices")
choice
@@ -522,7 +513,6 @@ strings describing those holidays that apply on DATE, or nil if none do."
(setq holiday-list (append holiday-list (cdr h)))))))
-;; Formerly cal-tex-list-holidays.
(defun holiday-in-range (d1 d2)
"Generate a list of all holidays in range from absolute date D1 to D2."
(let* ((start (calendar-gregorian-from-absolute d1))
@@ -537,7 +527,7 @@ strings describing those holidays that apply on DATE, or nil if none do."
3)))
holidays in-range a)
(calendar-increment-month displayed-month displayed-year 1)
- (dotimes (_idummy number-of-intervals)
+ (dotimes (_ number-of-intervals)
(setq holidays (append holidays (calendar-holiday-list)))
(calendar-increment-month displayed-month displayed-year 3))
(dolist (hol holidays)
@@ -691,19 +681,19 @@ the holiday description of `date'. If `date' is visible in the
calendar window, the holiday STRING is on that date. If date is
nil, or if the date is not visible, there is no holiday."
(let ((m displayed-month)
- (y displayed-year)
- year date)
+ (y displayed-year))
(calendar-increment-month m y -1)
(holiday-filter-visible-calendar
- (list
- (progn
- (setq year y
- date (eval sexp))
- (list date (if date (eval string))))
- (progn
- (setq year (1+ y)
- date (eval sexp))
- (list date (if date (eval string))))))))
+ (calendar-dlet* (year date)
+ (list
+ (progn
+ (setq year y
+ date (eval sexp t))
+ (list date (if date (eval string t))))
+ (progn
+ (setq year (1+ y)
+ date (eval sexp t))
+ (list date (if date (eval string t)))))))))
(defun holiday-advent (&optional n string)
diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el
index 408ebdb789e..a8fd765129e 100644
--- a/lisp/calendar/icalendar.el
+++ b/lisp/calendar/icalendar.el
@@ -43,13 +43,13 @@
;; 0.06: (2004-10-06)
;; - Bugfixes regarding icalendar-import-format-*.
-;; - Fix in icalendar-convert-diary-to-ical -- thanks to Philipp Grau.
+;; - Fix in icalendar-export-file -- thanks to Philipp Grau.
;; 0.05: (2003-06-19)
;; - New import format scheme: Replaced icalendar-import-prefix-*,
;; icalendar-import-ignored-properties, and
;; icalendar-import-separator with icalendar-import-format(-*).
-;; - icalendar-import-file and icalendar-convert-diary-to-ical
+;; - icalendar-import-file and icalendar-export-file
;; have an extra parameter which should prevent them from
;; erasing their target files (untested!).
;; - Tested with Emacs 21.3.2
@@ -643,12 +643,14 @@ FIXME: multiple comma-separated values should be allowed!"
(setq year (nth 2 mdy))))
;; create the decoded date-time
;; FIXME!?!
- (condition-case nil
- (decode-time (encode-time second minute hour day month year zone))
- (error
- (message "Cannot decode \"%s\"" isodatetimestring)
- ;; hope for the best...
- (list second minute hour day month year 0 nil 0))))
+ (let ((decoded-time (list second minute hour day month year
+ nil -1 zone)))
+ (condition-case nil
+ (decode-time (encode-time decoded-time 'integer))
+ (error
+ (message "Cannot decode \"%s\"" isodatetimestring)
+ ;; Hope for the best....
+ decoded-time))))
;; isodatetimestring == nil
nil))
@@ -996,9 +998,6 @@ Finto iCalendar file: ")
(set-buffer (find-file diary-filename))
(icalendar-export-region (point-min) (point-max) ical-filename)))
-(define-obsolete-function-alias 'icalendar-convert-diary-to-ical
- 'icalendar-export-file "22.1")
-
(defvar icalendar--uid-count 0
"Auxiliary counter for creating unique ids.")
@@ -1019,9 +1018,7 @@ current iCalendar object, as a string. Increase
(setq icalendar--uid-count (1+ icalendar--uid-count))
(setq uid (replace-regexp-in-string
"%t"
- (format "%d%d%d" (car (current-time))
- (cadr (current-time))
- (car (cddr (current-time))))
+ (format-time-string "%s%N")
uid t t))
(setq uid (replace-regexp-in-string
"%h"
@@ -1048,12 +1045,10 @@ written into the buffer `*icalendar-errors*'."
(interactive "r
FExport diary data into iCalendar file: ")
(let ((result "")
- (start 0)
(entry-main "")
(entry-rest "")
(entry-full "")
(header "")
- (contents-n-summary)
(contents)
(alarm)
(found-error nil)
@@ -1073,7 +1068,8 @@ FExport diary data into iCalendar file: ")
;; possibly ignore hidden entries beginning with "&"
(if icalendar-export-hidden-diary-entries
"^\\([^ \t\n#].+\\)\\(\\(\n[ \t].*\\)*\\)"
- "^\\([^ \t\n&#].+\\)\\(\\(\n[ \t].*\\)*\\)") max t)
+ "^\\([^ \t\n&#].+\\)\\(\\(\n[ \t].*\\)*\\)")
+ max t)
(setq entry-main (match-string 1))
(if (match-beginning 2)
(setq entry-rest (match-string 2))
@@ -1095,7 +1091,7 @@ FExport diary data into iCalendar file: ")
(loc (cdr (assoc 'loc other-elements)))
(org (cdr (assoc 'org other-elements)))
(sta (cdr (assoc 'sta other-elements)))
- (sum (cdr (assoc 'sum other-elements)))
+ ;; (sum (cdr (assoc 'sum other-elements)))
(url (cdr (assoc 'url other-elements)))
(uid (cdr (assoc 'uid other-elements))))
(if cla
@@ -1202,7 +1198,7 @@ Returns an alist."
(p-uid (or (string-match "%U" icalendar-import-format) -1))
(p-list (sort (list p-cla p-des p-loc p-org p-sta p-sum p-url p-uid) '<))
(ct 0)
- pos-cla pos-des pos-loc pos-org pos-sta pos-sum pos-url pos-uid)
+ pos-cla pos-des pos-loc pos-org pos-sta pos-url pos-uid) ;pos-sum
(dotimes (i (length p-list))
;; Use 'ct' to keep track of current position in list
(cond ((and (>= p-cla 0) (= (nth i p-list) p-cla))
@@ -1222,7 +1218,8 @@ Returns an alist."
(setq pos-sta (* 2 ct)))
((and (>= p-sum 0) (= (nth i p-list) p-sum))
(setq ct (+ ct 1))
- (setq pos-sum (* 2 ct)))
+ ;; (setq pos-sum (* 2 ct))
+ )
((and (>= p-url 0) (= (nth i p-list) p-url))
(setq ct (+ ct 1))
(setq pos-url (* 2 ct)))
@@ -1254,11 +1251,11 @@ Returns an alist."
(icalendar--rris "%s" "\\(.*?\\)" s nil t)
"\\'"))
(if (string-match s summary-and-rest)
- (let (cla des loc org sta sum url uid)
- (if (and pos-sum (match-beginning pos-sum))
- (setq sum (substring summary-and-rest
- (match-beginning pos-sum)
- (match-end pos-sum))))
+ (let (cla des loc org sta url uid) ;; sum
+ ;; (if (and pos-sum (match-beginning pos-sum))
+ ;; (setq sum (substring summary-and-rest
+ ;; (match-beginning pos-sum)
+ ;; (match-end pos-sum))))
(if (and pos-cla (match-beginning pos-cla))
(setq cla (substring summary-and-rest
(match-beginning pos-cla)
@@ -1601,8 +1598,7 @@ regular expression matching the start of non-marking entries.
ENTRY-MAIN is the first line of the diary entry.
Optional argument START determines the first day of the
-enumeration, given as a time value, in same format as returned by
-`current-time' -- used for test purposes."
+enumeration, given as a Lisp time value -- used for test purposes."
(cond ((string-match (concat nonmarker
"%%(and \\(([^)]+)\\))\\(\\s-*.*?\\) ?$")
entry-main)
@@ -1626,8 +1622,7 @@ enumeration, given as a time value, in same format as returned by
(mapcar
(lambda (offset)
(let* ((day (decode-time (time-add now
- (seconds-to-time
- (* offset 60 60 24)))))
+ (* 60 60 24 offset))))
(d (nth 3 day))
(m (nth 4 day))
(y (nth 5 day))
@@ -1763,8 +1758,8 @@ entries. ENTRY-MAIN is the first line of the diary entry."
;;BUT remove today if `diary-float'
;;expression does not hold true for today:
(when
- (null (let ((date (calendar-current-date))
- (entry entry-main))
+ (null (calendar-dlet* ((date (calendar-current-date))
+ (entry entry-main))
(diary-float month dayname n)))
(concat
"\nEXDATE;VALUE=DATE:"
@@ -1975,13 +1970,13 @@ P")
(icalendar-import-buffer diary-filename t non-marking)))
;;;###autoload
-(defun icalendar-import-buffer (&optional diary-file do-not-ask
+(defun icalendar-import-buffer (&optional diary-filename do-not-ask
non-marking)
"Extract iCalendar events from current buffer.
This function searches the current buffer for the first iCalendar
object, reads it and adds all VEVENT elements to the diary
-DIARY-FILE.
+DIARY-FILENAME.
It will ask for each appointment whether to add it to the diary
unless DO-NOT-ASK is non-nil. When called interactively,
@@ -2011,10 +2006,10 @@ buffer `*icalendar-errors*'."
(message "Converting iCalendar...")
(setq ical-errors (icalendar--convert-ical-to-diary
ical-contents
- diary-file do-not-ask non-marking))
- (when diary-file
+ diary-filename do-not-ask non-marking))
+ (when diary-filename
;; save the diary file if it is visited already
- (let ((b (find-buffer-visiting diary-file)))
+ (let ((b (find-buffer-visiting diary-filename)))
(when b
(save-current-buffer
(set-buffer b)
@@ -2027,9 +2022,6 @@ buffer `*icalendar-errors*'."
;; return nil, i.e. import did not work
nil)))
-(define-obsolete-function-alias 'icalendar-extract-ical-from-buffer
- 'icalendar-import-buffer "22.1")
-
(defun icalendar--format-ical-event (event)
"Create a string representation of an iCalendar EVENT."
(if (functionp icalendar-import-format)
@@ -2066,12 +2058,12 @@ buffer `*icalendar-errors*'."
conversion-list)
string)))
-(defun icalendar--convert-ical-to-diary (ical-list diary-file
+(defun icalendar--convert-ical-to-diary (ical-list diary-filename
&optional do-not-ask
non-marking)
"Convert iCalendar data to an Emacs diary file.
Import VEVENTS from the iCalendar object ICAL-LIST and saves them to a
-DIARY-FILE. If DO-NOT-ASK is nil the user is asked for each event
+DIARY-FILENAME. If DO-NOT-ASK is nil the user is asked for each event
whether to actually import it. NON-MARKING determines whether diary
events are created as non-marking.
This function attempts to return t if something goes wrong. In this
@@ -2164,7 +2156,7 @@ written into the buffer `*icalendar-errors*'."
(rdate
(icalendar--dmsg "rdate event")
(setq diary-string "")
- (mapc (lambda (datestring)
+ (mapc (lambda (_datestring)
(setq diary-string
(concat diary-string
(format "......"))))
@@ -2174,14 +2166,14 @@ written into the buffer `*icalendar-errors*'."
((not (string= start-d end-d))
(setq diary-string
(icalendar--convert-non-recurring-all-day-to-diary
- e start-d end-1-d))
+ start-d end-1-d))
(setq event-ok t))
;; not all-day
((and start-t (or (not end-t)
(not (string= start-t end-t))))
(setq diary-string
(icalendar--convert-non-recurring-not-all-day-to-diary
- e dtstart-dec dtend-dec start-t end-t))
+ dtstart-dec start-t end-t))
(setq event-ok t))
;; all-day event
(t
@@ -2199,8 +2191,8 @@ written into the buffer `*icalendar-errors*'."
(if do-not-ask (setq summary nil))
;; add entry to diary and store actual name of diary
;; file (in case it was nil)
- (setq diary-file
- (icalendar--add-diary-entry diary-string diary-file
+ (setq diary-filename
+ (icalendar--add-diary-entry diary-string diary-filename
non-marking summary)))
;; event was not ok
(setq found-error t)
@@ -2217,8 +2209,8 @@ written into the buffer `*icalendar-errors*'."
(message "%s" error-string))))
;; insert final newline
- (if diary-file
- (let ((b (find-buffer-visiting diary-file)))
+ (if diary-filename
+ (let ((b (find-buffer-visiting diary-filename)))
(when b
(save-current-buffer
(set-buffer b)
@@ -2467,7 +2459,7 @@ END-T is the event's end time in diary format."
e 'EXRULE))))
result))
-(defun icalendar--convert-non-recurring-all-day-to-diary (event start-d end-d)
+(defun icalendar--convert-non-recurring-all-day-to-diary (start-d end-d)
"Convert non-recurring iCalendar EVENT to diary format.
DTSTART is the decoded DTSTART property of E.
@@ -2476,14 +2468,12 @@ Argument END-D gives the last day."
(icalendar--dmsg "non-recurring all-day event")
(format "%%%%(and (diary-block %s %s))" start-d end-d))
-(defun icalendar--convert-non-recurring-not-all-day-to-diary (event dtstart-dec
- dtend-dec
- start-t
- end-t)
+(defun icalendar--convert-non-recurring-not-all-day-to-diary (dtstart-dec
+ start-t
+ end-t)
"Convert recurring icalendar EVENT to diary format.
DTSTART-DEC is the decoded DTSTART property of E.
-DTEND-DEC is the decoded DTEND property of E.
START-T is the event's start time in diary format.
END-T is the event's end time in diary format."
(icalendar--dmsg "not all day event")
@@ -2498,9 +2488,9 @@ END-T is the event's end time in diary format."
dtstart-dec "/")
start-t))))
-(defun icalendar--add-diary-entry (string diary-file non-marking
+(defun icalendar--add-diary-entry (string diary-filename non-marking
&optional summary)
- "Add STRING to the diary file DIARY-FILE.
+ "Add STRING to the diary file DIARY-FILENAME.
STRING must be a properly formatted valid diary entry. NON-MARKING
determines whether diary events are created as non-marking. If
SUMMARY is not nil it must be a string that gives the summary of the
@@ -2513,21 +2503,21 @@ the entry."
(setq non-marking
(y-or-n-p (format "Make appointment non-marking? "))))
(save-window-excursion
- (unless diary-file
- (setq diary-file
+ (unless diary-filename
+ (setq diary-filename
(read-file-name "Add appointment to this diary file: ")))
;; Note: diary-make-entry will add a trailing blank char.... :(
(funcall (if (fboundp 'diary-make-entry)
'diary-make-entry
'make-diary-entry)
- string non-marking diary-file)))
+ string non-marking diary-filename)))
;; Würgaround to remove the trailing blank char
- (with-current-buffer (find-file diary-file)
+ (with-current-buffer (find-file diary-filename)
(goto-char (point-max))
(if (= (char-before) ? )
(delete-char -1)))
- ;; return diary-file in case it has been changed interactively
- diary-file)
+ ;; return diary-filename in case it has been changed interactively
+ diary-filename)
;; ======================================================================
;; Examples
diff --git a/lisp/calendar/parse-time.el b/lisp/calendar/parse-time.el
index 41806cfc375..93e7e53b6ab 100644
--- a/lisp/calendar/parse-time.el
+++ b/lisp/calendar/parse-time.el
@@ -29,8 +29,9 @@
;; `parse-time-string' parses a time in a string and returns a list of 9
;; values, just like `decode-time', where unspecified elements in the
-;; string are returned as nil. `encode-time' may be applied on these
-;; values to obtain an internal time value.
+;; string are returned as nil (except unspecfied DST is returned as -1).
+;; `encode-time' may be applied on these values to obtain an internal
+;; time value.
;;; Code:
@@ -98,7 +99,7 @@ letters, digits, plus or minus signs or colons."
`(((6) parse-time-weekdays)
((3) (1 31))
((4) parse-time-months)
- ((5) (100 ,most-positive-fixnum))
+ ((5) (100))
((2 1 0)
,#'(lambda () (and (stringp parse-time-elt)
(= (length parse-time-elt) 8)
@@ -151,8 +152,9 @@ STRING should be something resembling an RFC 822 (or later) date-time, e.g.,
somewhat liberal in what format it accepts, and will attempt to
return a \"likely\" value even for somewhat malformed strings.
The values returned are identical to those of `decode-time', but
-any values that are unknown are returned as nil."
- (let ((time (list nil nil nil nil nil nil nil nil nil))
+any unknown values other than DST are returned as nil, and an
+unknown DST value is returned as -1."
+ (let ((time (list nil nil nil nil nil nil nil -1 nil))
(temp (parse-time-tokenize (downcase string))))
(while temp
(let ((parse-time-elt (pop temp))
@@ -170,7 +172,9 @@ any values that are unknown are returned as nil."
'lambda)))
(and (numberp parse-time-elt)
(<= (car predicate) parse-time-elt)
- (<= parse-time-elt (cadr predicate))
+ (or (not (cdr predicate))
+ (<= parse-time-elt
+ (cadr predicate)))
parse-time-elt))
((symbolp predicate)
(cdr (assoc parse-time-elt
@@ -223,7 +227,7 @@ If DATE-STRING cannot be parsed, it falls back to
(tz-re (nth 2 parse-time-iso8601-regexp))
re-start
time seconds minute hour
- day month year day-of-week dst tz)
+ day month year day-of-week (dst -1) tz)
;; We need to populate 'time' with
;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ)
@@ -239,6 +243,7 @@ If DATE-STRING cannot be parsed, it falls back to
seconds (string-to-number (match-string 3 date-string))
re-start (match-end 0))
(when (string-match tz-re date-string re-start)
+ (setq dst nil)
(if (string= "Z" (match-string 1 date-string))
(setq tz 0) ;; UTC timezone indicated by Z
(setq tz (+
@@ -256,7 +261,7 @@ If DATE-STRING cannot be parsed, it falls back to
(setq time (parse-time-string date-string)))
(and time
- (apply 'encode-time time))))
+ (encode-time time))))
(provide 'parse-time)
diff --git a/lisp/calendar/solar.el b/lisp/calendar/solar.el
index aa5ab91f16e..23bc7611e5f 100644
--- a/lisp/calendar/solar.el
+++ b/lisp/calendar/solar.el
@@ -1,4 +1,4 @@
-;;; solar.el --- calendar functions for solar events
+;;; solar.el --- calendar functions for solar events -*- lexical-binding:t -*-
;; Copyright (C) 1992-1993, 1995, 1997, 2001-2019 Free Software
;; Foundation, Inc.
@@ -552,12 +552,14 @@ degrees to find out if polar regions have 24 hours of sun or only night."
"Printable form for decimal fraction TIME in TIME-ZONE.
Format used is given by `calendar-time-display-form'."
(let* ((time (round (* 60 time)))
- (24-hours (/ time 60))
+ (24-hours (/ time 60)))
+ (calendar-dlet*
+ ((time-zone time-zone)
(minutes (format "%02d" (% time 60)))
(12-hours (format "%d" (1+ (% (+ 24-hours 11) 12))))
(am-pm (if (>= 24-hours 12) "pm" "am"))
(24-hours (format "%02d" 24-hours)))
- (mapconcat 'eval calendar-time-display-form "")))
+ (mapconcat #'eval calendar-time-display-form ""))))
(defun solar-daylight (time)
"Printable form for TIME expressed in hours."
@@ -661,10 +663,10 @@ Optional NOLOCATION non-nil means do not print the location."
(format
"%s, %s%s (%s hrs daylight)"
(if (car l)
- (concat "Sunrise " (apply 'solar-time-string (car l)))
+ (concat "Sunrise " (apply #'solar-time-string (car l)))
"No sunrise")
(if (cadr l)
- (concat "sunset " (apply 'solar-time-string (cadr l)))
+ (concat "sunset " (apply #'solar-time-string (cadr l)))
"no sunset")
(if nolocation ""
(format " at %s" (eval calendar-location-name)))
@@ -749,7 +751,7 @@ The values of `calendar-daylight-savings-starts',
(+ 4.9353929
(* 62833.1961680 U)
(* 0.0000001
- (apply '+
+ (apply #'+
(mapcar (lambda (x)
(* (car x)
(sin (mod
@@ -889,13 +891,12 @@ Accurate to a few seconds."
(insert (format "%s %2d: " (calendar-month-name month t) (1+ i))
(solar-sunrise-sunset-string date t) "\n")))))
-(defvar date)
-
-;; To be called from diary-list-sexp-entries, where DATE is bound.
;;;###diary-autoload
(defun diary-sunrise-sunset ()
"Local time of sunrise and sunset as a diary entry.
Accurate to a few seconds."
+ ;; To be called from diary-list-sexp-entries, where DATE is bound.
+ (with-no-warnings (defvar date))
(or (and calendar-latitude calendar-longitude calendar-time-zone)
(solar-setup))
(solar-sunrise-sunset-string date))
@@ -938,7 +939,7 @@ Accurate to within a minute between 1951 and 2050."
(W (- (* 35999.373 T) 2.47))
(Delta-lambda (+ 1 (* 0.0334 (solar-cosine-degrees W))
(* 0.0007 (solar-cosine-degrees (* 2 W)))))
- (S (apply '+ (mapcar (lambda(x)
+ (S (apply #'+ (mapcar (lambda(x)
(* (car x) (solar-cosine-degrees
(+ (* (nth 2 x) T) (cadr x)))))
solar-seasons-data)))
diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el
index afd5c091b40..cc30bd1fda4 100644
--- a/lisp/calendar/time-date.el
+++ b/lisp/calendar/time-date.el
@@ -151,15 +151,14 @@ it is assumed that PICO was omitted and should be treated as zero."
DATE should be in one of the forms recognized by `parse-time-string'.
If DATE lacks timezone information, GMT is assumed."
(condition-case err
- (apply 'encode-time (parse-time-string date))
+ (encode-time (parse-time-string date))
(error
(let ((overflow-error '(error "Specified time is not representable")))
(if (equal err overflow-error)
(apply 'signal err)
(condition-case err
- (apply 'encode-time
- (parse-time-string
- (timezone-make-date-arpa-standard date)))
+ (encode-time (parse-time-string
+ (timezone-make-date-arpa-standard date)))
(error
(if (equal err overflow-error)
(apply 'signal err)
@@ -169,16 +168,15 @@ If DATE lacks timezone information, GMT is assumed."
(defalias 'time-to-seconds 'float-time)
;;;###autoload
-(defun seconds-to-time (seconds)
- "Convert SECONDS to a time value."
- (time-add 0 seconds))
+(defalias 'seconds-to-time 'encode-time)
;;;###autoload
(defun days-to-time (days)
"Convert DAYS into a time value."
- (let ((time (condition-case nil (seconds-to-time (* 86400.0 days))
- (range-error (list most-positive-fixnum 65535)))))
- (if (integerp days)
+ (let ((time (encode-time (* 86400 days))))
+ ;; Traditionally, this returned a two-element list if DAYS was an integer.
+ ;; Keep that tradition if encode-time outputs timestamps in list form.
+ (if (and (integerp days) (consp (cdr time)))
(setcdr (cdr time) nil))
time))
@@ -278,9 +276,7 @@ return something of the form \"001 year\".
The \"%z\" specifier does not print anything. When it is used, specifiers
must be given in order of decreasing size. To the left of \"%z\", nothing
-is output until the first non-zero unit is encountered.
-
-This function does not work for SECONDS greater than `most-positive-fixnum'."
+is output until the first non-zero unit is encountered."
(let ((start 0)
(units '(("y" "year" 31536000)
("d" "day" 86400)
@@ -307,6 +303,7 @@ This function does not work for SECONDS greater than `most-positive-fixnum'."
(push match usedunits)))
(and zeroflag larger
(error "Units are not in decreasing order of size"))
+ (setq seconds (floor seconds))
(dolist (u units)
(setq spec (car u)
name (cadr u)
diff --git a/lisp/calendar/timeclock.el b/lisp/calendar/timeclock.el
index 769beddc3c4..a896df5e57c 100644
--- a/lisp/calendar/timeclock.el
+++ b/lisp/calendar/timeclock.el
@@ -1,4 +1,4 @@
-;;; timeclock.el --- mode for keeping track of how much you work
+;;; timeclock.el --- mode for keeping track of how much you work -*- lexical-binding:t -*-
;; Copyright (C) 1999-2019 Free Software Foundation, Inc.
@@ -62,7 +62,7 @@
;; `timeclock-ask-before-exiting' to t using M-x customize (this is
;; the default), or by adding the following to your init file:
;;
-;; (add-hook 'kill-emacs-query-functions 'timeclock-query-out)
+;; (add-hook 'kill-emacs-query-functions #'timeclock-query-out)
;; NOTE: If you change your timelog file without using timeclock's
;; functions, or if you change the value of any of timeclock's
@@ -75,6 +75,8 @@
;;; Code:
+(require 'cl-lib)
+
(defgroup timeclock nil
"Keeping track of the time that gets spent."
:group 'data)
@@ -84,13 +86,11 @@
(defcustom timeclock-file (locate-user-emacs-file "timelog" ".timelog")
"The file used to store timeclock data in."
:version "24.4" ; added locate-user-emacs-file
- :type 'file
- :group 'timeclock)
+ :type 'file)
(defcustom timeclock-workday (* 8 60 60)
"The length of a work period in seconds."
- :type 'integer
- :group 'timeclock)
+ :type 'integer)
(defcustom timeclock-relative t
"Whether to make reported time relative to `timeclock-workday'.
@@ -100,24 +100,21 @@ Tuesday is twelve hours -- relative to an averaged work period of
eight hours -- or eight hours, non-relative. So relative time takes
into account any discrepancy of time under-worked or over-worked on
previous days. This only affects the timeclock mode line display."
- :type 'boolean
- :group 'timeclock)
+ :type 'boolean)
(defcustom timeclock-get-project-function 'timeclock-ask-for-project
"The function used to determine the name of the current project.
When clocking in, and no project is specified, this function will be
called to determine what is the current project to be worked on.
If this variable is nil, no questions will be asked."
- :type 'function
- :group 'timeclock)
+ :type 'function)
(defcustom timeclock-get-reason-function 'timeclock-ask-for-reason
"A function used to determine the reason for clocking out.
When clocking out, and no reason is specified, this function will be
called to determine what is the reason.
If this variable is nil, no questions will be asked."
- :type 'function
- :group 'timeclock)
+ :type 'function)
(defcustom timeclock-get-workday-function nil
"A function used to determine the length of today's workday.
@@ -127,23 +124,24 @@ the return value is nil, or equal to `timeclock-workday', nothing special
will be done. If it is a quantity different from `timeclock-workday',
however, a record will be output to the timelog file to note the fact that
that day has a length that is different from the norm."
- :type '(choice (const nil) function)
- :group 'timeclock)
+ :type '(choice (const nil) function))
(defcustom timeclock-ask-before-exiting t
"If non-nil, ask if the user wants to clock out before exiting Emacs.
This variable only has effect if set with \\[customize]."
:set (lambda (symbol value)
(if value
- (add-hook 'kill-emacs-query-functions 'timeclock-query-out)
- (remove-hook 'kill-emacs-query-functions 'timeclock-query-out))
+ (add-hook 'kill-emacs-query-functions #'timeclock-query-out)
+ (remove-hook 'kill-emacs-query-functions #'timeclock-query-out))
(set symbol value))
- :type 'boolean
- :group 'timeclock)
+ :type 'boolean)
(defvar timeclock-update-timer nil
"The timer used to update `timeclock-mode-string'.")
+(define-obsolete-variable-alias 'timeclock-modeline-display
+ 'timeclock-mode-line-display "24.3")
+
;; For byte-compiler.
(defvar display-time-hook)
(defvar timeclock-mode-line-display)
@@ -169,7 +167,7 @@ a positive argument to force an update."
(if (and currently-displaying
(or (and value
(boundp 'display-time-hook)
- (memq 'timeclock-update-mode-line
+ (memq #'timeclock-update-mode-line
display-time-hook))
(and (not value)
timeclock-update-timer)))
@@ -182,7 +180,6 @@ a positive argument to force an update."
;; FIXME: The return value isn't used, AFAIK!
value))
:type 'boolean
- :group 'timeclock
:require 'time)
(defcustom timeclock-first-in-hook nil
@@ -191,40 +188,33 @@ Note that this hook is run before recording any events. Thus the
value of `timeclock-hours-today', `timeclock-last-event' and the
return value of function `timeclock-last-period' are relative previous
to today."
- :type 'hook
- :group 'timeclock)
+ :type 'hook)
(defcustom timeclock-load-hook nil
"Hook that gets run after timeclock has been loaded."
- :type 'hook
- :group 'timeclock)
+ :type 'hook)
(defcustom timeclock-in-hook nil
"A hook run every time an \"in\" event is recorded."
- :type 'hook
- :group 'timeclock)
+ :type 'hook)
(defcustom timeclock-day-over-hook nil
"A hook that is run when the workday has been completed.
This hook is only run if the current time remaining is being displayed
in the mode line. See the variable `timeclock-mode-line-display'."
- :type 'hook
- :group 'timeclock)
+ :type 'hook)
(defcustom timeclock-out-hook nil
"A hook run every time an \"out\" event is recorded."
- :type 'hook
- :group 'timeclock)
+ :type 'hook)
(defcustom timeclock-done-hook nil
"A hook run every time a project is marked as completed."
- :type 'hook
- :group 'timeclock)
+ :type 'hook)
(defcustom timeclock-event-hook nil
"A hook run every time any event is recorded."
- :type 'hook
- :group 'timeclock)
+ :type 'hook)
(defvar timeclock-last-event nil
"A list containing the last event that was recorded.
@@ -271,8 +261,6 @@ The time is bracketed by <> if you are clocked in, otherwise by [].")
(define-obsolete-function-alias 'timeclock-modeline-display
'timeclock-mode-line-display "24.3")
-(define-obsolete-variable-alias 'timeclock-modeline-display
- 'timeclock-mode-line-display "24.3")
;;;###autoload
(define-minor-mode timeclock-mode-line-display
@@ -293,12 +281,12 @@ display (non-nil means on)."
(or (memq 'timeclock-mode-string global-mode-string)
(setq global-mode-string
(append global-mode-string '(timeclock-mode-string))))
- (add-hook 'timeclock-event-hook 'timeclock-update-mode-line)
+ (add-hook 'timeclock-event-hook #'timeclock-update-mode-line)
(when timeclock-update-timer
(cancel-timer timeclock-update-timer)
(setq timeclock-update-timer nil))
(if (boundp 'display-time-hook)
- (remove-hook 'display-time-hook 'timeclock-update-mode-line))
+ (remove-hook 'display-time-hook #'timeclock-update-mode-line))
(if timeclock-use-display-time
(progn
;; Update immediately so there is a visible change
@@ -307,15 +295,15 @@ display (non-nil means on)."
(timeclock-update-mode-line)
(message "Activate `display-time-mode' or turn off \
`timeclock-use-display-time' to see timeclock information"))
- (add-hook 'display-time-hook 'timeclock-update-mode-line))
+ (add-hook 'display-time-hook #'timeclock-update-mode-line))
(setq timeclock-update-timer
(run-at-time nil 60 'timeclock-update-mode-line))))
(setq global-mode-string
(delq 'timeclock-mode-string global-mode-string))
- (remove-hook 'timeclock-event-hook 'timeclock-update-mode-line)
+ (remove-hook 'timeclock-event-hook #'timeclock-update-mode-line)
(if (boundp 'display-time-hook)
(remove-hook 'display-time-hook
- 'timeclock-update-mode-line))
+ #'timeclock-update-mode-line))
(when timeclock-update-timer
(cancel-timer timeclock-update-timer)
(setq timeclock-update-timer nil))))
@@ -364,7 +352,8 @@ discover the name of the project."
(if (not (= workday timeclock-workday))
(timeclock-log "h" (number-to-string
(/ workday (if (zerop (% workday (* 60 60)))
- 60 60.0) 60))))))
+ 60 60.0)
+ 60))))))
(timeclock-log "i" (or project
(and timeclock-get-project-function
(or find-project
@@ -416,12 +405,11 @@ If SHOW-SECONDS is non-nil, display second resolution.
If TODAY-ONLY is non-nil, the display will be relative only to time
worked today, ignoring the time worked on previous days."
(interactive "P")
- (let ((remainder (timeclock-workday-remaining
- (or today-only
- (not timeclock-relative))))
- (last-in (equal (car timeclock-last-event) "i"))
- status)
- (setq status
+ (let* ((remainder (timeclock-workday-remaining
+ (or today-only
+ (not timeclock-relative))))
+ (last-in (equal (car timeclock-last-event) "i"))
+ (status
(format "Currently %s since %s (%s), %s %s, leave at %s"
(if last-in "IN" "OUT")
(if show-seconds
@@ -434,7 +422,7 @@ worked today, ignoring the time worked on previous days."
(timeclock-seconds-to-string remainder show-seconds t)
(if (> remainder 0)
"remaining" "over")
- (timeclock-when-to-leave-string show-seconds today-only)))
+ (timeclock-when-to-leave-string show-seconds today-only))))
(if (called-interactively-p 'interactive)
(message "%s" status)
status)))
@@ -479,16 +467,10 @@ include the second count. If REVERSE-LEADER is non-nil, it means to
output a \"+\" if the time value is negative, rather than a \"-\".
This is used when negative time values have an inverted meaning (such
as with time remaining, where negative time really means overtime)."
- (if show-seconds
- (format "%s%d:%02d:%02d"
- (if (< seconds 0) (if reverse-leader "+" "-") "")
- (truncate (/ (abs seconds) 60 60))
- (% (truncate (/ (abs seconds) 60)) 60)
- (% (truncate (abs seconds)) 60))
- (format "%s%d:%02d"
+ (let ((s (abs (truncate seconds))))
+ (format (if show-seconds "%s%d:%02d:%02d" "%s%d:%02d")
(if (< seconds 0) (if reverse-leader "+" "-") "")
- (truncate (/ (abs seconds) 60 60))
- (% (truncate (/ (abs seconds) 60)) 60))))
+ (/ s 3600) (% (/ s 60) 60) (% s 60))))
(defsubst timeclock-currently-in-p ()
"Return non-nil if the user is currently clocked in."
@@ -533,22 +515,19 @@ non-nil, the amount returned will be relative to past time worked."
string)))
(define-obsolete-function-alias 'timeclock-time-to-seconds 'float-time "26.1")
-(define-obsolete-function-alias 'timeclock-seconds-to-time 'seconds-to-time
- "26.1")
+(define-obsolete-function-alias 'timeclock-seconds-to-time 'encode-time "26.1")
;; Should today-only be removed in favor of timeclock-relative? - gm
(defsubst timeclock-when-to-leave (&optional today-only)
"Return a time value representing the end of today's workday.
If TODAY-ONLY is non-nil, the value returned will be relative only to
the time worked today, and not to past time."
- (seconds-to-time
- (- (float-time)
- (let ((discrep (timeclock-find-discrep)))
- (if discrep
- (if today-only
- (cadr discrep)
- (car discrep))
- 0.0)))))
+ (time-since (let ((discrep (timeclock-find-discrep)))
+ (if discrep
+ (if today-only
+ (cadr discrep)
+ (car discrep))
+ 0))))
;;;###autoload
(defun timeclock-when-to-leave-string (&optional show-seconds
@@ -623,7 +602,7 @@ arguments of `completing-read'."
(format "Clock into which project (default %s): "
(or timeclock-last-project
(car timeclock-project-list)))
- (mapcar 'list timeclock-project-list)
+ timeclock-project-list
(or timeclock-last-project
(car timeclock-project-list))))
@@ -632,7 +611,7 @@ arguments of `completing-read'."
(defun timeclock-ask-for-reason ()
"Ask the user for the reason they are clocking out."
(timeclock-completing-read "Reason for clocking out: "
- (mapcar 'list timeclock-reason-list)))
+ timeclock-reason-list))
(define-obsolete-function-alias 'timeclock-update-modeline
'timeclock-update-mode-line "24.3")
@@ -685,8 +664,8 @@ being logged for. Normally only \"in\" events specify a project."
"\n")
(if (equal (downcase code) "o")
(setq timeclock-last-period
- (- (float-time now)
- (float-time (cadr timeclock-last-event)))
+ (float-time
+ (time-subtract now (cadr timeclock-last-event)))
timeclock-discrepancy
(+ timeclock-discrepancy
timeclock-last-period)))
@@ -700,7 +679,7 @@ being logged for. Normally only \"in\" events specify a project."
"\\([0-9]+\\)/\\([0-9]+\\)/\\([0-9]+\\)\\s-+"
"\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)[ \t]*" "\\([^\n]*\\)"))
-(defsubst timeclock-read-moment ()
+(defun timeclock-read-moment ()
"Read the moment under point from the timelog."
(if (looking-at timeclock-moment-regexp)
(let ((code (match-string 1))
@@ -721,30 +700,20 @@ recorded to disk. If MOMENT is non-nil, use that as the current time.
This is only provided for coherency when used by
`timeclock-discrepancy'."
(if (equal (car timeclock-last-event) "i")
- (- (float-time moment)
- (float-time (cadr timeclock-last-event)))
+ (float-time (time-subtract moment (cadr timeclock-last-event)))
timeclock-last-period))
+(cl-defstruct (timeclock-entry
+ (:constructor nil) (:copier nil)
+ (:type list))
+ begin end project comment
+ ;; FIXME: Documented in docstring of timeclock-log-data, but I can't see
+ ;; where it's used in the code.
+ final-p)
+
(defsubst timeclock-entry-length (entry)
"Return the length of ENTRY in seconds."
- (- (float-time (cadr entry))
- (float-time (car entry))))
-
-(defsubst timeclock-entry-begin (entry)
- "Return the start time of ENTRY."
- (car entry))
-
-(defsubst timeclock-entry-end (entry)
- "Return the end time of ENTRY."
- (cadr entry))
-
-(defsubst timeclock-entry-project (entry)
- "Return the project of ENTRY."
- (nth 2 entry))
-
-(defsubst timeclock-entry-comment (entry)
- "Return the comment of ENTRY."
- (nth 3 entry))
+ (float-time (time-subtract (cadr entry) (car entry))))
(defsubst timeclock-entry-list-length (entry-list)
"Return the total length of ENTRY-LIST in seconds."
@@ -763,22 +732,19 @@ This is only provided for coherency when used by
(defsubst timeclock-entry-list-span (entry-list)
"Return the total time in seconds spanned by ENTRY-LIST."
- (- (float-time (timeclock-entry-list-end entry-list))
- (float-time (timeclock-entry-list-begin entry-list))))
+ (float-time (time-subtract (timeclock-entry-list-end entry-list)
+ (timeclock-entry-list-begin entry-list))))
(defsubst timeclock-entry-list-break (entry-list)
"Return the total break time (span - length) in ENTRY-LIST."
(- (timeclock-entry-list-span entry-list)
(timeclock-entry-list-length entry-list)))
-(defsubst timeclock-entry-list-projects (entry-list)
+(defun timeclock-entry-list-projects (entry-list)
"Return a list of all the projects in ENTRY-LIST."
- (let (projects proj)
+ (let (projects)
(dolist (entry entry-list)
- (setq proj (timeclock-entry-project entry))
- (if projects
- (add-to-list 'projects proj)
- (setq projects (list proj))))
+ (cl-pushnew (timeclock-entry-project entry) projects :test #'equal))
projects))
(defsubst timeclock-day-required (day)
@@ -854,9 +820,7 @@ This is only provided for coherency when used by
(let (projects)
(dolist (day day-list)
(dolist (proj (timeclock-day-projects day))
- (if projects
- (add-to-list 'projects proj)
- (setq projects (list proj)))))
+ (cl-pushnew proj projects :test #'equal)))
projects))
(defsubst timeclock-current-debt (&optional log-data)
@@ -871,7 +835,7 @@ This is only provided for coherency when used by
"Return a list of the cdrs of the date alist from LOG-DATA."
(let (day-list)
(dolist (date-list (timeclock-day-alist log-data))
- (setq day-list (cons (cdr date-list) day-list)))
+ (push (cdr date-list) day-list))
day-list))
(defsubst timeclock-project-alist (&optional log-data)
@@ -1022,54 +986,55 @@ See the documentation for the given function if more info is needed."
(and beg (not last)
(setq last t event (list "o" now))))
(setq line (1+ line))
- (cond ((equal (car event) "b")
- (setcar log-data (string-to-number (nth 2 event))))
- ((equal (car event) "h")
- (setq last-date-limited (timeclock-time-to-date (cadr event))
- last-date-seconds (* (string-to-number (nth 2 event))
- 3600.0)))
- ((equal (car event) "i")
- (if beg
- (error "Error in format of timelog file, line %d" line)
- (setq beg t))
- (setq entry (list (cadr event) nil
- (and (> (length (nth 2 event)) 0)
- (nth 2 event))))
- (let ((date (timeclock-time-to-date (cadr event))))
- (if (and last-date
- (not (equal date last-date)))
- (progn
- (setcar (cdr log-data)
- (cons (cons last-date day)
- (cadr log-data)))
- (setq day (list (and last-date-limited
- last-date-seconds))))
- (unless day
- (setq day (list (and last-date-limited
- last-date-seconds)))))
- (setq last-date date
- last-date-limited nil)))
- ((equal (downcase (car event)) "o")
- (if (not beg)
- (error "Error in format of timelog file, line %d" line)
- (setq beg nil))
- (setcar (cdr entry) (cadr event))
- (let ((desc (and (> (length (nth 2 event)) 0)
- (nth 2 event))))
- (if desc
- (nconc entry (list (nth 2 event))))
- (if (equal (car event) "O")
- (nconc entry (if desc
- (list t)
- (list nil t))))
- (nconc day (list entry))
- (setq desc (nth 2 entry))
- (let ((proj (assoc desc (nth 2 log-data))))
- (if (null proj)
- (setcar (cddr log-data)
- (cons (cons desc (list entry))
- (nth 2 log-data)))
- (nconc (cdr proj) (list entry)))))))
+ (pcase (car event)
+ ("b"
+ (setcar log-data (string-to-number (nth 2 event))))
+ ("h"
+ (setq last-date-limited (timeclock-time-to-date (cadr event))
+ last-date-seconds (* (string-to-number (nth 2 event))
+ 3600.0)))
+ ("i"
+ (if beg
+ (error "Error in format of timelog file, line %d" line)
+ (setq beg t))
+ (setq entry (list (cadr event) nil
+ (and (> (length (nth 2 event)) 0)
+ (nth 2 event))))
+ (let ((date (timeclock-time-to-date (cadr event))))
+ (if (and last-date
+ (not (equal date last-date)))
+ (progn
+ (setcar (cdr log-data)
+ (cons (cons last-date day)
+ (cadr log-data)))
+ (setq day (list (and last-date-limited
+ last-date-seconds))))
+ (unless day
+ (setq day (list (and last-date-limited
+ last-date-seconds)))))
+ (setq last-date date
+ last-date-limited nil)))
+ ((or "o" "O")
+ (if (not beg)
+ (error "Error in format of timelog file, line %d" line)
+ (setq beg nil))
+ (setcar (cdr entry) (cadr event))
+ (let ((desc (and (> (length (nth 2 event)) 0)
+ (nth 2 event))))
+ (if desc
+ (nconc entry (list (nth 2 event))))
+ (if (equal (car event) "O")
+ (nconc entry (if desc
+ (list t)
+ (list nil t))))
+ (nconc day (list entry))
+ (setq desc (nth 2 entry))
+ (let ((proj (assoc desc (nth 2 log-data))))
+ (if (null proj)
+ (setcar (cddr log-data)
+ (cons (cons desc (list entry))
+ (nth 2 log-data)))
+ (nconc (cdr proj) (list entry)))))))
(forward-line))
(if day
(setcar (cdr log-data)
@@ -1135,7 +1100,7 @@ discrepancy, today's discrepancy, and the time worked today."
last-date-limited nil)
(if beg
(error "Error in format of timelog file!")
- (setq beg (float-time (cadr event))))))
+ (setq beg (cadr event)))))
((equal (downcase (car event)) "o")
(if (and (nth 2 event)
(> (length (nth 2 event)) 0))
@@ -1143,7 +1108,7 @@ discrepancy, today's discrepancy, and the time worked today."
(if (not beg)
(error "Error in format of timelog file!")
(setq timeclock-last-period
- (- (float-time (cadr event)) beg)
+ (float-time (time-subtract (cadr event) beg))
accum (+ timeclock-last-period accum)
beg nil))
(if (equal last-date todays-date)
@@ -1181,18 +1146,16 @@ If optional argument TIME is non-nil, use that instead of the current time."
(setcar (nthcdr 0 decoded) 0)
(setcar (nthcdr 1 decoded) 0)
(setcar (nthcdr 2 decoded) 0)
- (apply 'encode-time decoded)))
+ (encode-time decoded)))
(defun timeclock-mean (l)
"Compute the arithmetic mean of the values in the list L."
- (let ((total 0)
- (count 0))
- (dolist (thisl l)
- (setq total (+ total thisl)
- count (1+ count)))
- (if (zerop count)
- 0
- (/ total count))))
+ (if (not (consp l))
+ 0
+ (let ((total 0))
+ (dolist (thisl l)
+ (setq total (+ total thisl)))
+ (/ total (length l)))))
(defun timeclock-generate-report (&optional html-p)
"Generate a summary report based on the current timelog file.
@@ -1223,9 +1186,7 @@ HTML-P is non-nil, HTML markup is added."
(insert project "</b><br>\n")
(insert project "*\n"))
(let ((proj-data (cdr (assoc project (timeclock-project-alist log))))
- (two-weeks-ago (seconds-to-time
- (- (float-time today)
- (* 2 7 24 60 60))))
+ (two-weeks-ago (time-subtract today (* 2 7 24 60 60)))
two-week-len today-len)
(while proj-data
(if (not (time-less-p
@@ -1276,18 +1237,10 @@ HTML-P is non-nil, HTML markup is added."
<th>-1 year</th>
</tr>")
(let* ((day-list (timeclock-day-list))
- (thirty-days-ago (seconds-to-time
- (- (float-time today)
- (* 30 24 60 60))))
- (three-months-ago (seconds-to-time
- (- (float-time today)
- (* 90 24 60 60))))
- (six-months-ago (seconds-to-time
- (- (float-time today)
- (* 180 24 60 60))))
- (one-year-ago (seconds-to-time
- (- (float-time today)
- (* 365 24 60 60))))
+ (thirty-days-ago (time-subtract today (* 30 24 60 60)))
+ (three-months-ago (time-subtract today (* 90 24 60 60)))
+ (six-months-ago (time-subtract today (* 180 24 60 60)))
+ (one-year-ago (time-subtract today (* 365 24 60 60)))
(time-in (vector (list t) (list t) (list t) (list t) (list t)))
(time-out (vector (list t) (list t) (list t) (list t) (list t)))
(breaks (vector (list t) (list t) (list t) (list t) (list t)))
@@ -1296,81 +1249,69 @@ HTML-P is non-nil, HTML markup is added."
six-months-ago one-year-ago)))
;; collect statistics from complete timelog
(dolist (day day-list)
- (let ((i 0) (l 5))
- (while (< i l)
- (unless (time-less-p
- (timeclock-day-begin day)
- (aref lengths i))
- (let ((base (float-time
- (timeclock-day-base
- (timeclock-day-begin day)))))
- (nconc (aref time-in i)
- (list (- (float-time (timeclock-day-begin day))
- base)))
- (let ((span (timeclock-day-span day))
- (len (timeclock-day-length day))
- (req (timeclock-day-required day)))
- ;; If the day's actual work length is less than
- ;; 70% of its span, then likely the exit time
- ;; and break amount are not worthwhile adding to
- ;; the statistic
- (when (and (> span 0)
- (> (/ (float len) (float span)) 0.70))
- (nconc (aref time-out i)
- (list (- (float-time (timeclock-day-end day))
- base)))
- (nconc (aref breaks i) (list (- span len))))
- (if req
- (setq len (+ len (- timeclock-workday req))))
- (nconc (aref workday i) (list len)))))
- (setq i (1+ i)))))
+ (dotimes (i 5)
+ (unless (time-less-p
+ (timeclock-day-begin day)
+ (aref lengths i))
+ (let ((base (timeclock-day-base (timeclock-day-begin day))))
+ (nconc (aref time-in i)
+ (list (float-time (time-subtract
+ (timeclock-day-begin day)
+ base))))
+ (let ((span (timeclock-day-span day))
+ (len (timeclock-day-length day))
+ (req (timeclock-day-required day)))
+ ;; If the day's actual work length is less than
+ ;; 70% of its span, then likely the exit time
+ ;; and break amount are not worthwhile adding to
+ ;; the statistic
+ (when (and (> span 0)
+ (> (/ (float len) (float span)) 0.70))
+ (nconc (aref time-out i)
+ (list (float-time (time-subtract
+ (timeclock-day-end day)
+ base))))
+ (nconc (aref breaks i) (list (- span len))))
+ (if req
+ (setq len (+ len (- timeclock-workday req))))
+ (nconc (aref workday i) (list len)))))))
;; average statistics
- (let ((i 0) (l 5))
- (while (< i l)
- (aset time-in i (timeclock-mean (cdr (aref time-in i))))
- (aset time-out i (timeclock-mean (cdr (aref time-out i))))
- (aset breaks i (timeclock-mean (cdr (aref breaks i))))
- (aset workday i (timeclock-mean (cdr (aref workday i))))
- (setq i (1+ i))))
+ (dotimes (i 5)
+ (aset time-in i (timeclock-mean (cdr (aref time-in i))))
+ (aset time-out i (timeclock-mean (cdr (aref time-out i))))
+ (aset breaks i (timeclock-mean (cdr (aref breaks i))))
+ (aset workday i (timeclock-mean (cdr (aref workday i)))))
;; Output the HTML table
(insert "<tr>\n")
(insert "<td align=\"center\">Time in</td>\n")
- (let ((i 0) (l 5))
- (while (< i l)
- (insert "<td align=\"right\">"
- (timeclock-seconds-to-string (aref time-in i))
- "</td>\n")
- (setq i (1+ i))))
+ (dotimes (i 5)
+ (insert "<td align=\"right\">"
+ (timeclock-seconds-to-string (aref time-in i))
+ "</td>\n"))
(insert "</tr>\n")
(insert "<tr>\n")
(insert "<td align=\"center\">Time out</td>\n")
- (let ((i 0) (l 5))
- (while (< i l)
- (insert "<td align=\"right\">"
- (timeclock-seconds-to-string (aref time-out i))
- "</td>\n")
- (setq i (1+ i))))
+ (dotimes (i 5)
+ (insert "<td align=\"right\">"
+ (timeclock-seconds-to-string (aref time-out i))
+ "</td>\n"))
(insert "</tr>\n")
(insert "<tr>\n")
(insert "<td align=\"center\">Break</td>\n")
- (let ((i 0) (l 5))
- (while (< i l)
- (insert "<td align=\"right\">"
- (timeclock-seconds-to-string (aref breaks i))
- "</td>\n")
- (setq i (1+ i))))
+ (dotimes (i 5)
+ (insert "<td align=\"right\">"
+ (timeclock-seconds-to-string (aref breaks i))
+ "</td>\n"))
(insert "</tr>\n")
(insert "<tr>\n")
(insert "<td align=\"center\">Workday</td>\n")
- (let ((i 0) (l 5))
- (while (< i l)
- (insert "<td align=\"right\">"
- (timeclock-seconds-to-string (aref workday i))
- "</td>\n")
- (setq i (1+ i))))
+ (dotimes (i 5)
+ (insert "<td align=\"right\">"
+ (timeclock-seconds-to-string (aref workday i))
+ "</td>\n"))
(insert "</tr>\n"))
(insert "<tfoot>
<td colspan=\"6\" align=\"center\">
@@ -1393,6 +1334,7 @@ HTML-P is non-nil, HTML markup is added."
;; make sure we know the list of reasons, projects, and have computed
;; the last event and current discrepancy.
(if (file-readable-p timeclock-file)
+ ;; FIXME: Loading a file should not have these kinds of side-effects.
(timeclock-reread-log))
;;; timeclock.el ends here
diff --git a/lisp/calendar/todo-mode.el b/lisp/calendar/todo-mode.el
index 892e8bee95e..7169ef41aef 100644
--- a/lisp/calendar/todo-mode.el
+++ b/lisp/calendar/todo-mode.el
@@ -188,25 +188,17 @@ The final element is \"*\", indicating an unspecified month.")
"Array of abbreviated month names, in order.
The final element is \"*\", indicating an unspecified month.")
-(with-no-warnings
- ;; FIXME: These vars lack a prefix, but this is out of our control, because
- ;; they're defined by Calendar, e.g. for calendar-date-display-form.
- (defvar dayname)
- (defvar monthname)
- (defvar day)
- (defvar month)
- (defvar year))
-
(defconst todo-date-pattern
(let ((dayname (diary-name-pattern calendar-day-name-array nil t)))
(concat "\\(?4:\\(?5:" dayname "\\)\\|"
- (let ((dayname)
- (monthname (format "\\(?6:%s\\)" (diary-name-pattern
- todo-month-name-array
- todo-month-abbrev-array)))
- (month "\\(?7:[0-9]+\\|\\*\\)")
- (day "\\(?8:[0-9]+\\|\\*\\)")
- (year "-?\\(?9:[0-9]+\\|\\*\\)"))
+ (calendar-dlet*
+ ((dayname)
+ (monthname (format "\\(?6:%s\\)" (diary-name-pattern
+ todo-month-name-array
+ todo-month-abbrev-array)))
+ (month "\\(?7:[0-9]+\\|\\*\\)")
+ (day "\\(?8:[0-9]+\\|\\*\\)")
+ (year "-?\\(?9:[0-9]+\\|\\*\\)"))
(mapconcat #'eval calendar-date-display-form ""))
"\\)"))
"Regular expression matching a todo item date header.")
@@ -861,17 +853,18 @@ category. With non-nil argument BACK, visit the numerically
previous category (the highest numbered one, if the current
category is the first)."
(interactive)
- (setq todo-category-number
- (1+ (mod (- todo-category-number (if back 2 0))
- (length todo-categories))))
- (when todo-skip-archived-categories
- (while (and (zerop (todo-get-count 'todo))
- (zerop (todo-get-count 'done))
- (not (zerop (todo-get-count 'archived))))
- (setq todo-category-number
- (funcall (if back #'1- #'1+) todo-category-number))))
- (todo-category-select)
- (goto-char (point-min)))
+ (let ((setcatnum (lambda () (1+ (mod (- todo-category-number
+ (if back 2 0))
+ (length todo-categories))))))
+ (setq todo-category-number (funcall setcatnum))
+ (when todo-skip-archived-categories
+ (while (and (zerop (todo-get-count 'todo))
+ (zerop (todo-get-count 'done))
+ (not (zerop (todo-get-count 'archived))))
+ (setq todo-category-number (funcall setcatnum))))
+ (todo-category-select)
+ (if transient-mark-mode (deactivate-mark))
+ (goto-char (point-min))))
(defun todo-backward-category ()
"Visit the numerically previous category in this todo file.
@@ -936,11 +929,13 @@ Categories mode."
(when goto-archive (todo-archive-mode))
(set-window-buffer (selected-window)
(set-buffer (find-buffer-visiting file0)))
+ (if transient-mark-mode (deactivate-mark))
(unless todo-global-current-todo-file
(setq todo-global-current-todo-file todo-current-todo-file))
(todo-category-number category)
(todo-category-select)
(goto-char (point-min))
+ (if (bound-and-true-p hl-line-mode) (hl-line-highlight))
(when add-item (todo-insert-item--basic))))))
(defun todo-next-item (&optional count)
@@ -1026,15 +1021,17 @@ empty line above the done items separator."
(setq shown (progn
(goto-char (point-min))
(re-search-forward todo-done-string-start nil t)))
- (if (not (pos-visible-in-window-p shown))
- (recenter)
- (goto-char opoint)))))))
+ (if (pos-visible-in-window-p shown)
+ (goto-char opoint)
+ (recenter)
+ (if transient-mark-mode (deactivate-mark))))))))
(defun todo-toggle-view-done-only ()
"Switch between displaying only done or only todo items."
(interactive)
(setq todo-show-done-only (not todo-show-done-only))
- (todo-category-select))
+ (todo-category-select)
+ (if transient-mark-mode (deactivate-mark)))
(defun todo-toggle-item-highlighting ()
"Highlight or unhighlight the todo item the cursor is on."
@@ -1109,7 +1106,9 @@ Noninteractively, return the name of the new file."
(progn
(set-window-buffer (selected-window)
(set-buffer (find-file-noselect file)))
- (setq todo-current-todo-file file)
+ ;; Since buffer is not yet in todo-mode, we need to
+ ;; explicitly make todo-current-todo-file buffer local.
+ (setq-local todo-current-todo-file file)
(todo-show))
file)))
@@ -1245,9 +1244,10 @@ this command should be used with caution."
(widen)
(todo-edit-mode)
(remove-overlays)
- (display-warning 'todo (format "\
+ (display-warning
+ 'todo (format "\
-Type %s to return to Todo mode.
+Type %s to return to Todo%s mode.
This also runs a file format check and signals an error if
the format has become invalid. However, this check cannot
@@ -1257,7 +1257,12 @@ You can repair this inconsistency by invoking the command
`todo-repair-categories-sexp', but this will revert any
renumbering of the categories you have made, so you will
have to renumber them again (see `(todo-mode) Reordering
-Categories')." (substitute-command-keys "\\[todo-edit-quit]"))))
+Categories').
+"
+ (substitute-command-keys "\\[todo-edit-quit]")
+ (if (equal "toda" (file-name-extension
+ (buffer-file-name)))
+ " Archive" ""))))
(defun todo-add-category (&optional file cat)
"Add a new category to a todo file.
@@ -1833,7 +1838,6 @@ consist of the last todo items and the first done items."
(defvar todo-date-from-calendar nil
"Helper variable for setting item date from the Emacs Calendar.")
-(defvar todo-insert-item--keys-so-far)
(defvar todo-insert-item--parameters)
(defun todo-insert-item (&optional arg)
@@ -1855,8 +1859,7 @@ already been entered and which remain available. See
`(todo-mode) Inserting New Items' for details of the parameters,
their associated keys and their effects."
(interactive "P")
- (setq todo-insert-item--keys-so-far "i")
- (todo-insert-item--next-param nil (list arg) todo-insert-item--parameters))
+ (todo-insert-item--next-param (list arg) todo-insert-item--parameters nil "i"))
(defun todo-insert-item--basic (&optional arg diary-type date-type time where)
"Function implementing the core of `todo-insert-item'."
@@ -1868,15 +1871,18 @@ their associated keys and their effects."
(region (eq where 'region))
(here (eq where 'here))
diary-item)
- (when copy
- (cond
- ((not (eq major-mode 'todo-mode))
- (user-error "You must be in Todo mode to copy a todo item"))
- ((todo-done-item-p)
- (user-error "You cannot copy a done item as a new todo item"))
- ((looking-at "^$")
- (user-error "Point must be on a todo item to copy it")))
- (setq diary-item (todo-diary-item-p)))
+ (when (and arg here)
+ (user-error "Here insertion only valid in current category"))
+ (when (and (or copy here)
+ (or (not (eq major-mode 'todo-mode)) (todo-done-item-p)
+ (when copy (looking-at "^$"))
+ (save-excursion
+ (beginning-of-line)
+ ;; Point is on done items separator.
+ (looking-at todo-category-done))))
+ (user-error (concat "Item " (if copy "copying" "insertion")
+ " is not valid here")))
+ (when copy (setq diary-item (todo-diary-item-p)))
(when region
(let (use-empty-active-region)
(unless (and todo-use-only-highlighted-region (use-region-p))
@@ -1884,7 +1890,6 @@ their associated keys and their effects."
(let* ((obuf (current-buffer))
(ocat (todo-current-category))
(opoint (point))
- (todo-mm (eq major-mode 'todo-mode))
(cat+file (cond ((equal arg '(4))
(todo-read-category "Insert in category: "))
((equal arg '(16))
@@ -1902,7 +1907,10 @@ their associated keys and their effects."
(new-item (cond (copy (todo-item-string))
(region (buffer-substring-no-properties
(region-beginning) (region-end)))
- (t (read-from-minibuffer "Todo item: "))))
+ (t (if (eq major-mode 'todo-archive-mode)
+ (user-error (concat "Cannot insert a new Todo"
+ " item in an archive"))
+ (read-from-minibuffer "Todo item: ")))))
(date-string (cond
((eq date-type 'date)
(todo-read-date))
@@ -1923,7 +1931,7 @@ their associated keys and their effects."
(calendar-current-date) t t))))
(time-string (or (and time (todo-read-time))
(and todo-always-add-time-string
- (substring (current-time-string) 11 16)))))
+ (format-time-string "%H:%M")))))
(setq todo-date-from-calendar nil)
(find-file-noselect file 'nowarn)
(set-window-buffer (selected-window)
@@ -1939,7 +1947,6 @@ their associated keys and their effects."
(unless todo-global-current-todo-file
(setq todo-global-current-todo-file todo-current-todo-file))
(let ((buffer-read-only nil)
- (called-from-outside (not (and todo-mm (equal cat ocat))))
done-only item-added)
(unless copy
(setq new-item
@@ -1963,14 +1970,8 @@ their associated keys and their effects."
"\n\t" new-item nil nil 1)))
(unwind-protect
(progn
- ;; Make sure the correct category is selected. There
- ;; are two cases: (i) we just visited the file, so no
- ;; category is selected yet, or (ii) we invoked
- ;; insertion "here" from outside the category we want
- ;; to insert in (with priority insertion, category
- ;; selection is done by todo-set-item-priority).
- (when (or (= (- (point-max) (point-min)) (buffer-size))
- (and here called-from-outside))
+ ;; If we just visited the file, no category is selected yet.
+ (when (= (- (point-max) (point-min)) (buffer-size))
(todo-category-number cat)
(todo-category-select))
;; If only done items are displayed in category,
@@ -1981,16 +1982,7 @@ their associated keys and their effects."
(setq done-only t)
(todo-toggle-view-done-only))
(if here
- (progn
- ;; If command was invoked with point in done
- ;; items section or outside of the current
- ;; category, can't insert "here", so to be
- ;; useful give new item top priority.
- (when (or (todo-done-item-section-p)
- called-from-outside
- done-only)
- (goto-char (point-min)))
- (todo-insert-with-overlays new-item))
+ (todo-insert-with-overlays new-item)
(todo-set-item-priority new-item cat t))
(setq item-added t))
;; If user cancels before setting priority, restore
@@ -2105,20 +2097,24 @@ the item at point."
(setq todo-categories-with-marks
(assq-delete-all cat todo-categories-with-marks)))
(todo-update-categories-sexp)
- (todo-prefix-overlays)))
+ (todo-prefix-overlays)
+ (when (and (zerop (todo-get-count 'diary))
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote todo-category-done))
+ nil t)))
+ (let (todo-show-with-done) (todo-category-select)))))
(if ov (delete-overlay ov)))))
-(defvar todo-edit-item--param-key-alist)
-(defvar todo-edit-done-item--param-key-alist)
-
(defun todo-edit-item (&optional arg)
"Choose an editing operation for the current item and carry it out."
(interactive "P")
(let ((marked (assoc (todo-current-category) todo-categories-with-marks)))
(cond ((and (todo-done-item-p) (not marked))
- (todo-edit-item--next-key todo-edit-done-item--param-key-alist))
+ (todo-edit-item--next-key 'done arg))
((or marked (todo-item-string))
- (todo-edit-item--next-key todo-edit-item--param-key-alist arg)))))
+ (todo-edit-item--next-key 'todo arg)))))
(defun todo-edit-item--text (&optional arg)
"Function providing the text editing facilities of `todo-edit-item'."
@@ -2241,7 +2237,8 @@ made in the number or names of categories."
(insert item))
(kill-buffer)
(unless (eq (current-buffer) buf)
- (set-window-buffer (selected-window) (set-buffer buf))))
+ (set-window-buffer (selected-window) (set-buffer buf)))
+ (if transient-mark-mode (deactivate-mark)))
;; We got here via `F e'.
(when (todo-check-format)
;; FIXME: separate out sexp check?
@@ -2251,7 +2248,9 @@ made in the number or names of categories."
;; (todo-repair-categories-sexp)
;; Compare (todo-make-categories-list t) with sexp and if
;; different ask (todo-update-categories-sexp) ?
- (todo-mode)
+ (if (equal (file-name-extension (buffer-file-name)) "toda")
+ (todo-archive-mode)
+ (todo-mode))
(let* ((cat-beg (concat "^" (regexp-quote todo-category-beg)
"\\(.*\\)$"))
(curline (buffer-substring-no-properties
@@ -2274,8 +2273,8 @@ made in the number or names of categories."
;; `todo-edit-item' as e.g. `-' or `C-u'.
(inc (prefix-numeric-value inc))
(buffer-read-only nil)
- ndate ntime year monthname month day
- dayname) ; Needed by calendar-date-display-form.
+ ndate ntime
+ year monthname month day dayname)
(when marked (todo--user-error-if-marked-done-item))
(save-excursion
(or (and marked (goto-char (point-min))) (todo-item-start))
@@ -2348,7 +2347,7 @@ made in the number or names of categories."
((or (string= omonth "*") (= mm 13))
(user-error "Cannot increment *"))
(t
- (let ((mminc (+ mm inc)))
+ (let ((mminc (+ mm inc (if (< inc 0) 12 0))))
;; Increment or decrement month by INC
;; modulo 12.
(setq mm (% mminc 12))
@@ -2416,7 +2415,15 @@ made in the number or names of categories."
;; If year, month or day date string components were
;; changed, rebuild the date string.
(when (memq what '(year month day))
- (setq ndate (mapconcat #'eval calendar-date-display-form ""))))
+ (setq ndate
+ (calendar-dlet*
+ ;; Needed by calendar-date-display-form.
+ ((year year)
+ (monthname monthname)
+ (month month)
+ (day day)
+ (dayname dayname))
+ (mapconcat #'eval calendar-date-display-form "")))))
(when ndate (replace-match ndate nil nil nil 1))
;; Add new time string to the header, if it was supplied.
(when ntime
@@ -2549,7 +2556,11 @@ whose value can be either of the symbols `raise' or `lower',
meaning to raise or lower the item's priority by one."
(interactive)
(unless (and (or (called-interactively-p 'any) (memq arg '(raise lower)))
- (or (todo-done-item-p) (looking-at "^$")))
+ ;; Noop if point is not on a todo (i.e. not done) item.
+ (or (todo-done-item-p) (looking-at "^$")
+ ;; On done items separator.
+ (save-excursion (beginning-of-line)
+ (looking-at todo-category-done))))
(let* ((item (or item (todo-item-string)))
(marked (todo-marked-item-p))
(cat (or cat (cond ((eq major-mode 'todo-mode)
@@ -2697,9 +2708,13 @@ section in the category moved to."
(interactive "P")
(let* ((cat1 (todo-current-category))
(marked (assoc cat1 todo-categories-with-marks)))
- ;; Noop if point is not on an item and there are no marked items.
- (unless (and (looking-at "^$")
- (not marked))
+ (unless
+ ;; Noop if point is not on an item and there are no marked items.
+ (and (or (looking-at "^$")
+ ;; On done items separator.
+ (save-excursion (beginning-of-line)
+ (looking-at todo-category-done)))
+ (not marked))
(let* ((buffer-read-only)
(file1 todo-current-todo-file)
(item (todo-item-string))
@@ -2856,14 +2871,17 @@ visible."
(let* ((cat (todo-current-category))
(marked (assoc cat todo-categories-with-marks)))
(when marked (todo--user-error-if-marked-done-item))
- (unless (and (not marked)
- (or (todo-done-item-p)
- ;; Point is between todo and done items.
- (looking-at "^$")))
+ (unless
+ ;; Noop if point is not on a todo (i.e. not done) item and
+ ;; there are no marked items.
+ (and (or (todo-done-item-p) (looking-at "^$")
+ ;; On done items separator.
+ (save-excursion (beginning-of-line)
+ (looking-at todo-category-done)))
+ (not marked))
(let* ((date-string (calendar-date-string (calendar-current-date) t t))
(time-string (if todo-always-add-time-string
- (concat " " (substring (current-time-string)
- 11 16))
+ (format-time-string " %H:%M")
""))
(done-prefix (concat "[" todo-done-string date-string time-string
"] "))
@@ -3830,6 +3848,7 @@ face."
(goto-char (point-min))
(while (not (eobp))
(setq match (re-search-forward regex nil t))
+ (if (and match transient-mark-mode) (deactivate-mark))
(goto-char (line-beginning-position))
(unless (or (equal (point) 1)
(looking-at (concat "^" (regexp-quote todo-category-beg))))
@@ -4028,19 +4047,22 @@ regexp items."
(interactive "P")
(todo-filter-items 'regexp arg t))
+(defvar todo--fifiles-history nil
+ "List of short file names used by todo-find-filtered-items-file.")
+
(defun todo-find-filtered-items-file ()
"Choose a filtered items file and visit it."
(interactive)
(let ((files (directory-files todo-directory t "\\.tod[rty]$" t))
falist file)
(dolist (f files)
- (let ((type (cond ((equal (file-name-extension f) "todr") "regexp")
+ (let ((sf-name (todo-short-file-name f))
+ (type (cond ((equal (file-name-extension f) "todr") "regexp")
((equal (file-name-extension f) "todt") "top")
((equal (file-name-extension f) "tody") "diary"))))
- (push (cons (concat (todo-short-file-name f) " (" type ")") f)
- falist)))
- (setq file (completing-read "Choose a filtered items file: "
- falist nil t nil nil (car falist)))
+ (push (cons (concat sf-name " (" type ")") f) falist)))
+ (setq file (completing-read "Choose a filtered items file: " falist nil t nil
+ 'todo--fifiles-history (caar falist)))
(setq file (cdr (assoc-string file falist)))
(find-file file)
(unless (derived-mode-p 'todo-filtered-items-mode)
@@ -4050,25 +4072,27 @@ regexp items."
(defun todo-go-to-source-item ()
"Display the file and category of the filtered item at point."
(interactive)
- (let* ((str (todo-item-string))
- (buf (current-buffer))
- (res (todo-find-item str))
- (found (nth 0 res))
- (file (nth 1 res))
- (cat (nth 2 res)))
- (if (not found)
- (message "Category %s does not contain this item." cat)
- (kill-buffer buf)
- (set-window-buffer (selected-window)
- (set-buffer (find-buffer-visiting file)))
- (setq todo-current-todo-file file)
- (setq todo-category-number (todo-category-number cat))
- (let ((todo-show-with-done (if (or todo-filter-done-items
- (eq (cdr found) 'done))
- t
- todo-show-with-done)))
- (todo-category-select))
- (goto-char (car found)))))
+ (unless (looking-at "^$") ; Empty line at EOB.
+ (let* ((str (todo-item-string))
+ (buf (current-buffer))
+ (res (todo-find-item str))
+ (found (nth 0 res))
+ (file (nth 1 res))
+ (cat (nth 2 res)))
+ (if (not found)
+ (message "Category %s does not contain this item." cat)
+ (kill-buffer buf)
+ (set-window-buffer (selected-window)
+ (set-buffer (find-buffer-visiting file)))
+ (setq todo-current-todo-file file)
+ (setq todo-category-number (todo-category-number cat))
+ (let ((todo-show-with-done (if (or todo-filter-done-items
+ (eq (cdr found) 'done))
+ t
+ todo-show-with-done)))
+ (todo-category-select))
+ (if transient-mark-mode (deactivate-mark))
+ (goto-char (car found))))))
(defvar todo-multiple-filter-files nil
"List of files selected from `todo-multiple-filter-files' widget.")
@@ -4520,8 +4544,11 @@ its priority has changed, and `same' otherwise."
(defun todo-save-filtered-items-buffer ()
"Save current Filtered Items buffer to a file.
If the file already exists, overwrite it only on confirmation."
- (let ((filename (or (buffer-file-name) (todo-filter-items-filename))))
- (write-file filename t)))
+ (let ((filename (or (buffer-file-name) (todo-filter-items-filename)))
+ (bufname (buffer-name)))
+ (write-file filename t)
+ (setq buffer-read-only t)
+ (rename-buffer bufname)))
;; -----------------------------------------------------------------------------
;;; Printing Todo mode buffers
@@ -4613,12 +4640,13 @@ strings built using the default value of
(defun todo-convert-legacy-date-time ()
"Return converted date-time string.
Helper function for `todo-convert-legacy-files'."
- (let* ((year (match-string 1))
- (month (match-string 2))
- (monthname (calendar-month-name (string-to-number month) t))
- (day (match-string 3))
- (time (match-string 4))
- dayname)
+ (calendar-dlet*
+ ((year (match-string 1))
+ (month (match-string 2))
+ (monthname (calendar-month-name (string-to-number month) t))
+ (day (match-string 3))
+ (time (match-string 4))
+ dayname)
(replace-match "")
(insert (mapconcat #'eval calendar-date-display-form "")
(when time (concat " " time)))))
@@ -5075,7 +5103,7 @@ again."
(defun todo-check-format ()
"Signal an error if the current todo file is ill-formatted.
-Otherwise return t. Display a message if the file is well-formed
+Otherwise return t. Display a warning if the file is well-formed
but the categories sexp differs from the current value of
`todo-categories'."
(save-excursion
@@ -5109,12 +5137,14 @@ but the categories sexp differs from the current value of
(forward-line)))
;; Warn user if categories sexp has changed.
(unless (string= ssexp cats)
- (message (concat "The sexp at the beginning of the file differs "
- "from the value of `todo-categories'.\n"
- "If the sexp is wrong, you can fix it with "
- "M-x todo-repair-categories-sexp,\n"
- "but note this reverts any changes you have "
- "made in the order of the categories."))))))
+ (display-warning 'todo "\
+
+The sexp at the beginning of the file differs from the value of
+`todo-categories'. If the sexp is wrong, you can fix it with
+M-x todo-repair-categories-sexp, but note this reverts any
+changes you have made in the order of the categories.
+"
+ )))))
t)
(defun todo-item-start ()
@@ -5131,6 +5161,8 @@ but the categories sexp differs from the current value of
(forward-line)
(looking-at (concat "^"
(regexp-quote todo-category-done))))))
+ ;; Point is on done items separator.
+ (save-excursion (beginning-of-line) (looking-at todo-category-done))
;; Buffer is widened.
(looking-at (regexp-quote todo-category-beg)))
(goto-char (line-beginning-position))
@@ -5140,8 +5172,11 @@ but the categories sexp differs from the current value of
(defun todo-item-end ()
"Move to end of current todo item and return its position."
- ;; Items cannot end with a blank line.
- (unless (looking-at "^$")
+ (unless (or
+ ;; Items cannot end with a blank line.
+ (looking-at "^$")
+ ;; Point is on done items separator.
+ (save-excursion (beginning-of-line) (looking-at todo-category-done)))
(let* ((done (todo-done-item-p))
(to-lim nil)
;; For todo items, end is before the done items section, for done
@@ -5292,6 +5327,7 @@ Overrides `diary-goto-entry'."
nil t)
(todo-category-number (match-string 1))
(todo-category-select)
+ (if transient-mark-mode (deactivate-mark))
(goto-char opoint))))))
(add-function :override diary-goto-entry-function #'todo-diary-goto-entry)
@@ -5493,12 +5529,14 @@ of each other."
;;; Generating and applying item insertion and editing key sequences
;; -----------------------------------------------------------------------------
-;; Thanks to Stefan Monnier for suggesting dynamically generating item
-;; insertion commands and their key bindings, and offering an elegant
-;; implementation, which, however, relies on lexical scoping and so
-;; cannot be used here until the Calendar code used by todo-mode.el is
-;; converted to lexical binding. Hence, the following implementation
-;; uses dynamic binding.
+;; Thanks to Stefan Monnier for (i) not only suggesting dynamically
+;; generating item insertion commands and their key bindings but also
+;; offering an elegant implementation which, however, since it used
+;; lexical binding, was at the time incompatible with the Calendar and
+;; Diary code in todo-mode.el; and (ii) later making that code
+;; compatible with lexical binding, so that his implementation, of
+;; which the following is a somewhat expanded version, could be
+;; realized in todo-mode.el.
(defconst todo-insert-item--parameters
'((default copy) (diary nonmarking) (calendar date dayname) time (here region))
@@ -5506,91 +5544,33 @@ of each other."
Passed by `todo-insert-item' to `todo-insert-item--next-param' to
dynamically create item insertion commands.")
-(defconst todo-insert-item--param-key-alist
- '((default . "i")
- (copy . "p")
- (diary . "y")
- (nonmarking . "k")
- (calendar . "c")
- (date . "d")
- (dayname . "n")
- (time . "t")
- (here . "h")
- (region . "r"))
- "List pairing item insertion parameters with their completion keys.")
-
-(defsubst todo-insert-item--keyof (param)
- "Return key paired with item insertion PARAM."
- (cdr (assoc param todo-insert-item--param-key-alist)))
-
-(defun todo-insert-item--argsleft (key list)
- "Return sublist of LIST whose first member corresponds to KEY."
- (let (l sym)
- (mapc (lambda (m)
- (when (consp m)
- (catch 'found1
- (dolist (s m)
- (when (equal key (todo-insert-item--keyof s))
- (throw 'found1 (setq sym s))))))
- (if sym
- (progn
- (push sym l)
- (setq sym nil))
- (push m l)))
- list)
- (setq list (reverse l)))
- (memq (catch 'found2
- (dolist (e todo-insert-item--param-key-alist)
- (when (equal key (cdr e))
- (throw 'found2 (car e)))))
- list))
-
-(defsubst todo-insert-item--this-key () (char-to-string last-command-event))
-
-(defvar todo-insert-item--keys-so-far ""
- "String of item insertion keys so far entered for this command.")
-
-(defvar todo-insert-item--args nil)
-(defvar todo-insert-item--argleft nil)
-(defvar todo-insert-item--argsleft nil)
-(defvar todo-insert-item--newargsleft nil)
-
-(defun todo-insert-item--apply-args ()
- "Build list of arguments for item insertion and apply them.
-The list consists of item insertion parameters that can be passed
-as insertion command arguments in fixed positions. If a position
-in the list is not occupied by the corresponding parameter, it is
-occupied by nil."
- (let* ((arg (list (car todo-insert-item--args)))
- (args (nconc (cdr todo-insert-item--args)
- (list (car (todo-insert-item--argsleft
- (todo-insert-item--this-key)
- todo-insert-item--argsleft)))))
- (arglist (if (= 4 (length args))
- args
- (let ((v (make-vector 4 nil)) elt)
- (while args
- (setq elt (pop args))
- (cond ((memq elt '(diary nonmarking))
- (aset v 0 elt))
- ((memq elt '(calendar date dayname))
- (aset v 1 elt))
- ((eq elt 'time)
- (aset v 2 elt))
- ((memq elt '(copy here region))
- (aset v 3 elt))))
- (append v nil)))))
- (apply #'todo-insert-item--basic (nconc arg arglist))))
-
-(defun todo-insert-item--next-param (last args argsleft)
- "Build item insertion command from LAST, ARGS and ARGSLEFT and call it.
-Dynamically generate key bindings, prompting with the keys
-already entered and those still available."
- (cl-assert argsleft)
+(defun todo-insert-item--next-param (args params last keys-so-far)
+ "Generate and invoke an item insertion command.
+Dynamically generate the command, its arguments ARGS and its key
+binding by recursing through the list of parameters PARAMS,
+taking the LAST from a sublist and prompting with KEYS-SO-FAR
+keys already entered and those still available."
+ (cl-assert params)
(let* ((map (make-sparse-keymap))
+ (param-key-alist '((default . "i")
+ (copy . "p")
+ (diary . "y")
+ (nonmarking . "k")
+ (calendar . "c")
+ (date . "d")
+ (dayname . "n")
+ (time . "t")
+ (here . "h")
+ (region . "r")))
+ ;; Return key paired with given item insertion parameter.
+ (key-of (lambda (param) (cdr (assoc param param-key-alist))))
+ ;; The key just typed.
+ (this-key (lambda () (char-to-string last-command-event)))
(prompt nil)
- (addprompt
- (lambda (k name)
+ ;; Add successively entered keys to the prompt and show what
+ ;; possibilities remain.
+ (add-to-prompt
+ (lambda (key name)
(setq prompt
(concat prompt
(format
@@ -5600,80 +5580,119 @@ already entered and those still available."
"%s=>%s"
(when (memq name '(copy nonmarking dayname region))
" }"))
- (propertize k 'face 'todo-key-prompt)
- name))))))
- (setq todo-insert-item--args args)
- (setq todo-insert-item--argsleft argsleft)
+ (propertize key 'face 'todo-key-prompt)
+ name)))))
+ ;; Return the sublist of the given list of parameters whose
+ ;; first member is paired with the given key.
+ (get-params
+ (lambda (key lst)
+ (setq lst (if (consp lst) lst (list lst)))
+ (let (l sym)
+ (mapc (lambda (m)
+ (when (consp m)
+ (catch 'found1
+ (dolist (s m)
+ (when (equal key (funcall key-of s))
+ (throw 'found1 (setq sym s))))))
+ (if sym
+ (progn
+ (push sym l)
+ (setq sym nil))
+ (push m l)))
+ lst)
+ (setq lst (reverse l)))
+ (memq (catch 'found2
+ (dolist (e param-key-alist)
+ (when (equal key (cdr e))
+ (throw 'found2 (car e)))))
+ lst)))
+ ;; Build list of arguments for item insertion and then
+ ;; execute the basic insertion function. The list consists of
+ ;; item insertion parameters that can be passed as insertion
+ ;; command arguments in fixed positions. If a position in
+ ;; the list is not occupied by the corresponding parameter,
+ ;; it is occupied by nil.
+ (gen-and-exec
+ (lambda ()
+ (let* ((arg (list (car args))) ; Possible prefix argument.
+ (rest (nconc (cdr args)
+ (list (car (funcall get-params
+ (funcall this-key)
+ params)))))
+ (parlist (if (= 4 (length rest))
+ rest
+ (let ((v (make-vector 4 nil)) elt)
+ (while rest
+ (setq elt (pop rest))
+ (cond ((memq elt '(diary nonmarking))
+ (aset v 0 elt))
+ ((memq elt '(calendar date dayname))
+ (aset v 1 elt))
+ ((eq elt 'time)
+ (aset v 2 elt))
+ ((memq elt '(copy here region))
+ (aset v 3 elt))))
+ (append v nil)))))
+ (apply #'todo-insert-item--basic (nconc arg parlist)))))
+ ;; Operate on a copy of the parameter list so the original is
+ ;; not consumed, thus available for the next key typed.
+ (params0 params))
(when last
(if (memq last '(default copy))
(progn
- (setq todo-insert-item--argsleft nil)
- (todo-insert-item--apply-args))
- (let ((k (todo-insert-item--keyof last)))
- (funcall addprompt k (make-symbol (concat (symbol-name last) ":GO!")))
- (define-key map (todo-insert-item--keyof last)
+ (setq params0 nil)
+ (funcall gen-and-exec))
+ (let ((key (funcall key-of last)))
+ (funcall add-to-prompt key (make-symbol
+ (concat (symbol-name last) ":GO!")))
+ (define-key map (funcall key-of last)
(lambda () (interactive)
- (todo-insert-item--apply-args))))))
- (while todo-insert-item--argsleft
- (let ((x (car todo-insert-item--argsleft)))
- (setq todo-insert-item--newargsleft (cdr todo-insert-item--argsleft))
- (dolist (argleft (if (consp x) x (list x)))
- (let ((k (todo-insert-item--keyof argleft)))
- (funcall addprompt k argleft)
- (define-key map k
- (if (null todo-insert-item--newargsleft)
- (lambda () (interactive)
- (todo-insert-item--apply-args))
- (lambda () (interactive)
- (setq todo-insert-item--keys-so-far
- (concat todo-insert-item--keys-so-far " "
- (todo-insert-item--this-key)))
- (todo-insert-item--next-param
- (car (todo-insert-item--argsleft
- (todo-insert-item--this-key)
- todo-insert-item--argsleft))
- (nconc todo-insert-item--args
- (list (car (todo-insert-item--argsleft
- (todo-insert-item--this-key)
- todo-insert-item--argsleft))))
- (cdr (todo-insert-item--argsleft
- (todo-insert-item--this-key)
- todo-insert-item--argsleft)))))))))
- (setq todo-insert-item--argsleft todo-insert-item--newargsleft))
- (when prompt (message "Press a key (so far `%s'): %s"
- todo-insert-item--keys-so-far prompt))
+ (funcall gen-and-exec))))))
+ (while params0
+ (let* ((x (car params0))
+ (restparams (cdr params0)))
+ (dolist (param (if (consp x) x (list x)))
+ (let ((key (funcall key-of param)))
+ (funcall add-to-prompt key param)
+ (define-key map key
+ (if (null restparams)
+ (lambda () (interactive)
+ (funcall gen-and-exec))
+ (lambda () (interactive)
+ (setq keys-so-far (concat keys-so-far " " (funcall this-key)))
+ (todo-insert-item--next-param
+ (nconc args (list (car (funcall get-params
+ (funcall this-key) param))))
+ (cdr (funcall get-params (funcall this-key) params))
+ (car (funcall get-params (funcall this-key) param))
+ keys-so-far))))))
+ (setq params0 restparams)))
(set-transient-map map)
- (setq todo-insert-item--argsleft argsleft)))
-
-(defconst todo-edit-item--param-key-alist
- '((edit . "e")
- (header . "h")
- (multiline . "m")
- (diary . "y")
- (nonmarking . "k")
- (date . "d")
- (time . "t"))
- "Alist of item editing parameters and their keys.")
-
-(defconst todo-edit-item--date-param-key-alist
- '((full . "f")
- (calendar . "c")
- (today . "a")
- (dayname . "n")
- (year . "y")
- (month . "m")
- (daynum . "d"))
- "Alist of item date editing parameters and their keys.")
-
-(defconst todo-edit-done-item--param-key-alist
- '((add/edit . "c")
- (delete . "d"))
- "Alist of done item comment editing parameters and their keys.")
-
-(defvar todo-edit-item--prompt "Press a key (so far `e'): ")
-
-(defun todo-edit-item--next-key (params &optional arg)
- (let* ((p->k (mapconcat (lambda (elt)
+ (when prompt (message "Press a key (so far `%s'): %s" keys-so-far prompt))
+ (setq params0 params)))
+
+(defun todo-edit-item--next-key (type &optional arg)
+ (let* ((todo-param-key-alist '((edit . "e")
+ (header . "h")
+ (multiline . "m")
+ (diary . "y")
+ (nonmarking . "k")
+ (date . "d")
+ (time . "t")))
+ (done-param-key-alist '((add/edit . "c")
+ (delete . "d")))
+ (date-param-key-alist '((full . "f")
+ (calendar . "c")
+ (today . "a")
+ (dayname . "n")
+ (year . "y")
+ (month . "m")
+ (daynum . "d")))
+ (params (pcase type
+ ('todo todo-param-key-alist)
+ ('done done-param-key-alist)
+ ('date date-param-key-alist)))
+ (p->k (mapconcat (lambda (elt)
(format "%s=>%s"
(propertize (cdr elt) 'face
'todo-key-prompt)
@@ -5682,31 +5701,32 @@ already entered and those still available."
'(add/edit delete))
" comment"))))
params " "))
- (key-prompt (substitute-command-keys todo-edit-item--prompt))
+ (key-prompt (substitute-command-keys
+ (concat "Press a key (so far `e"
+ (if (eq type 'date) " d" "")
+ "'): ")))
(this-key (let ((key (read-key (concat key-prompt p->k))))
(and (characterp key) (char-to-string key))))
(this-param (car (rassoc this-key params))))
(pcase this-param
- (`edit (todo-edit-item--text))
- (`header (todo-edit-item--text 'include-header))
- (`multiline (todo-edit-item--text 'multiline))
- (`add/edit (todo-edit-item--text 'comment-edit))
- (`delete (todo-edit-item--text 'comment-delete))
- (`diary (todo-edit-item--diary-inclusion))
- (`nonmarking (todo-edit-item--diary-inclusion 'nonmarking))
- (`date (let ((todo-edit-item--prompt "Press a key (so far `e d'): "))
- (todo-edit-item--next-key
- todo-edit-item--date-param-key-alist arg)))
- (`full (progn (todo-edit-item--header 'date)
+ ('edit (todo-edit-item--text))
+ ('header (todo-edit-item--text 'include-header))
+ ('multiline (todo-edit-item--text 'multiline))
+ ('add/edit (todo-edit-item--text 'comment-edit))
+ ('delete (todo-edit-item--text 'comment-delete))
+ ('diary (todo-edit-item--diary-inclusion))
+ ('nonmarking (todo-edit-item--diary-inclusion 'nonmarking))
+ ('date (todo-edit-item--next-key 'date arg))
+ ('full (progn (todo-edit-item--header 'date)
(when todo-always-add-time-string
(todo-edit-item--header 'time))))
- (`calendar (todo-edit-item--header 'calendar))
- (`today (todo-edit-item--header 'today))
- (`dayname (todo-edit-item--header 'dayname))
- (`year (todo-edit-item--header 'year arg))
- (`month (todo-edit-item--header 'month arg))
- (`daynum (todo-edit-item--header 'day arg))
- (`time (todo-edit-item--header 'time)))))
+ ('calendar (todo-edit-item--header 'calendar))
+ ('today (todo-edit-item--header 'today))
+ ('dayname (todo-edit-item--header 'dayname))
+ ('year (todo-edit-item--header 'year arg))
+ ('month (todo-edit-item--header 'month arg))
+ ('daynum (todo-edit-item--header 'day arg))
+ ('time (todo-edit-item--header 'time)))))
;; -----------------------------------------------------------------------------
;;; Todo minibuffer utilities
@@ -5990,8 +6010,8 @@ indicating an unspecified month, day, or year.
When ARG is `day', non-nil arguments MO and YR determine the
number of the last the day of the month."
- (let (year monthname month day
- dayname) ; Needed by calendar-date-display-form.
+ (calendar-dlet*
+ (year monthname month day dayname) ;Needed by calendar-date-display-form.
(when (or (not arg) (eq arg 'year))
(while (if (natnump year) (< year 1) (not (eq year '*)))
(setq year (read-from-minibuffer
@@ -6070,7 +6090,7 @@ the empty string (i.e., no time string)."
(while (not valid)
(setq answer (read-string "Enter a clock time: " nil nil
(when todo-always-add-time-string
- (substring (current-time-string) 11 16))))
+ (format-time-string "%H:%M"))))
(when (or (string= "" answer)
(string-match diary-time-regexp answer))
(setq valid t)))
@@ -6368,8 +6388,7 @@ Filtered Items mode following todo (not done) items."
;; -----------------------------------------------------------------------------
(defvar todo-key-bindings-t
- `(
- ("Af" todo-find-archive)
+ '(("Af" todo-find-archive)
("Ac" todo-choose-archive)
("Ad" todo-archive-done-item)
("Cv" todo-toggle-view-done-items)
@@ -6400,13 +6419,11 @@ Filtered Items mode following todo (not done) items."
("k" todo-delete-item)
("m" todo-move-item)
("u" todo-item-undone)
- ([remap newline] newline-and-indent)
- )
+ ([remap newline] newline-and-indent))
"List of key bindings for Todo mode only.")
(defvar todo-key-bindings-t+a+f
- `(
- ("C*" todo-mark-category)
+ '(("C*" todo-mark-category)
("Cu" todo-unmark-category)
("Fh" todo-toggle-item-header)
("h" todo-toggle-item-header)
@@ -6418,33 +6435,27 @@ Filtered Items mode following todo (not done) items."
("N" todo-toggle-prefix-numbers)
("PB" todo-print-buffer)
("PF" todo-print-buffer-to-file)
- ("b" todo-backward-category)
- ("d" todo-item-done)
- ("f" todo-forward-category)
("j" todo-jump-to-category)
("n" todo-next-item)
("p" todo-previous-item)
("q" todo-quit)
("s" todo-save)
- ("t" todo-show)
- )
+ ("t" todo-show))
"List of key bindings for Todo, Archive, and Filtered Items modes.")
(defvar todo-key-bindings-t+a
- `(
- ("Fc" todo-show-categories-table)
+ '(("Fc" todo-show-categories-table)
("S" todo-search)
("X" todo-clear-matches)
- ("*" todo-toggle-mark-item)
- )
+ ("b" todo-backward-category)
+ ("f" todo-forward-category)
+ ("*" todo-toggle-mark-item))
"List of key bindings for Todo and Todo Archive modes.")
(defvar todo-key-bindings-t+f
- `(
- ("l" todo-lower-item-priority)
+ '(("l" todo-lower-item-priority)
("r" todo-raise-item-priority)
- ("#" todo-set-item-priority)
- )
+ ("#" todo-set-item-priority))
"List of key bindings for Todo and Todo Filtered Items modes.")
(defvar todo-mode-map
@@ -6703,32 +6714,19 @@ Added to `window-configuration-change-hook' in Todo mode."
(setq-local todo-current-todo-file (file-truename (buffer-file-name)))
(setq-local todo-show-done-only t))
-(defun todo-mode-external-set ()
- "Set `todo-categories' externally to `todo-current-todo-file'."
- (setq-local todo-current-todo-file todo-global-current-todo-file)
- (let ((cats (with-current-buffer
- ;; Can't use find-buffer-visiting when
- ;; `todo-show-categories-table' is called on first
- ;; invocation of `todo-show', since there is then
- ;; no buffer visiting the current file.
- (find-file-noselect todo-current-todo-file 'nowarn)
- (or todo-categories
- ;; In Todo Edit mode todo-categories is now nil
- ;; since it uses same buffer as Todo mode but
- ;; doesn't have the latter's local variables.
- (save-excursion
- (goto-char (point-min))
- (read (buffer-substring-no-properties
- (line-beginning-position)
- (line-end-position))))))))
- (setq-local todo-categories cats)))
-
(define-derived-mode todo-edit-mode text-mode "Todo-Ed"
"Major mode for editing multiline todo items.
\\{todo-edit-mode-map}"
(todo-modes-set-1)
- (todo-mode-external-set)
+ (if (> (buffer-size) (- (point-max) (point-min)))
+ ;; Editing one item in an indirect buffer, so buffer-file-name is nil.
+ (setq-local todo-current-todo-file todo-global-current-todo-file)
+ ;; When editing archive file, make sure it is current todo file.
+ (setq-local todo-current-todo-file (file-truename (buffer-file-name)))
+ ;; Need this when editing the whole file to return to the category
+ ;; editing was invoked from.
+ (setq-local todo-categories (todo-set-categories)))
(setq buffer-read-only nil))
(put 'todo-categories-mode 'mode-class 'special)
@@ -6737,7 +6735,15 @@ Added to `window-configuration-change-hook' in Todo mode."
"Major mode for displaying and editing todo categories.
\\{todo-categories-mode-map}"
- (todo-mode-external-set))
+ (setq-local todo-current-todo-file todo-global-current-todo-file)
+ (setq-local todo-categories
+ ;; Can't use find-buffer-visiting when
+ ;; `todo-show-categories-table' is called on first
+ ;; invocation of `todo-show', since there is then no
+ ;; buffer visiting the current file.
+ (with-current-buffer (find-file-noselect
+ todo-current-todo-file 'nowarn)
+ todo-categories)))
(put 'todo-filtered-items-mode 'mode-class 'special)
diff --git a/lisp/cedet/cedet.el b/lisp/cedet/cedet.el
index 92fede9e76c..b3d4a5def2e 100644
--- a/lisp/cedet/cedet.el
+++ b/lisp/cedet/cedet.el
@@ -30,9 +30,6 @@
;; load them all by doing (require 'cedet). This is mostly for
;; compatibility with the upstream, stand-alone CEDET distribution.
-(eval-when-compile
- (require 'cl))
-
(declare-function inversion-find-version "inversion")
(defconst cedet-version "2.0"
diff --git a/lisp/cedet/data-debug.el b/lisp/cedet/data-debug.el
index ba312433d38..eeec6b5834b 100644
--- a/lisp/cedet/data-debug.el
+++ b/lisp/cedet/data-debug.el
@@ -920,14 +920,14 @@ If PARENT is non-nil, it is somehow related as a parent to thing."
(interactive)
(forward-line 1)
(beginning-of-line)
- (skip-chars-forward " *-><[]" (point-at-eol)))
+ (skip-chars-forward "- *><[]" (point-at-eol)))
(defun data-debug-prev ()
"Go to the previous line in the Ddebug buffer."
(interactive)
(forward-line -1)
(beginning-of-line)
- (skip-chars-forward " *-><[]" (point-at-eol)))
+ (skip-chars-forward "- *><[]" (point-at-eol)))
(defun data-debug-next-expando ()
"Go to the next line in the Ddebug buffer.
@@ -1014,7 +1014,7 @@ Do nothing if already contracted."
(data-debug-current-line-expanded-p))
(data-debug-contract-current-line)
(data-debug-expand-current-line))
- (skip-chars-forward " *-><[]" (point-at-eol)))
+ (skip-chars-forward "- *><[]" (point-at-eol)))
(defun data-debug-expand-or-contract-mouse (event)
"Expand or contract anything at event EVENT."
diff --git a/lisp/cedet/ede.el b/lisp/cedet/ede.el
index ea3cd9972fc..22374dd6a63 100644
--- a/lisp/cedet/ede.el
+++ b/lisp/cedet/ede.el
@@ -475,9 +475,6 @@ To be used in hook functions."
(define-minor-mode ede-minor-mode
"Toggle EDE (Emacs Development Environment) minor mode.
-With a prefix argument ARG, enable EDE minor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-EDE minor mode if ARG is omitted or nil.
If this file is contained, or could be contained in an EDE
controlled project, then this mode is activated automatically
@@ -563,9 +560,6 @@ Sets buffer local variables for EDE."
;;;###autoload
(define-minor-mode global-ede-mode
"Toggle global EDE (Emacs Development Environment) mode.
-With a prefix argument ARG, enable global EDE mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
This global minor mode enables `ede-minor-mode' in all buffers in
an EDE controlled project."
@@ -1095,6 +1089,7 @@ Flush the dead projects from the project cache."
))
(defvar ede--disable-inode) ;Defined in ede/files.el.
+(declare-function ede--project-inode "ede/files" (proj))
(defun ede-global-list-sanity-check ()
"Perform a sanity check to make sure there are no duplicate projects."
diff --git a/lisp/cedet/ede/detect.el b/lisp/cedet/ede/detect.el
index 73058ea6bce..e33f7a9a0fe 100644
--- a/lisp/cedet/ede/detect.el
+++ b/lisp/cedet/ede/detect.el
@@ -195,11 +195,10 @@ Return a cons cell:
"Run a quick test for autodetecting on BUFFER."
(interactive)
(let ((start (current-time))
- (ans (ede-detect-directory-for-project default-directory))
- (end (current-time)))
+ (ans (ede-detect-directory-for-project default-directory)))
(if ans
(message "Project found in %d sec @ %s of type %s"
- (float-time (time-subtract end start))
+ (encode-time (time-since start) 'integer)
(car ans)
(eieio-object-name-string (cdr ans)))
(message "No Project found.") )))
diff --git a/lisp/cedet/ede/dired.el b/lisp/cedet/ede/dired.el
index cf62d470bab..7fe88091ef1 100644
--- a/lisp/cedet/ede/dired.el
+++ b/lisp/cedet/ede/dired.el
@@ -27,12 +27,13 @@
;; This provides a dired interface to EDE, allowing users to modify
;; their project file by adding files (or whatever) directly from a
;; dired buffer.
-(eval-when-compile (require 'cl))
+
+;;; Code:
+
(require 'easymenu)
(require 'dired)
(require 'ede)
-;;; Code:
(defvar ede-dired-keymap
(let ((map (make-sparse-keymap)))
(define-key map ".a" 'ede-dired-add-to-target)
@@ -58,9 +59,7 @@
;;;###autoload
(define-minor-mode ede-dired-minor-mode
- "A minor mode that should only be activated in DIRED buffers.
-If ARG is nil or a positive number, force on, if
-negative, force off."
+ "A minor mode that should only be activated in DIRED buffers."
:lighter " EDE" :keymap ede-dired-keymap
(unless (derived-mode-p 'dired-mode)
(setq ede-dired-minor-mode nil)
diff --git a/lisp/cedet/ede/files.el b/lisp/cedet/ede/files.el
index 2372ace807f..dbe07fbbdbe 100644
--- a/lisp/cedet/ede/files.el
+++ b/lisp/cedet/ede/files.el
@@ -113,7 +113,7 @@ of the anchor file for the project."
(if ede--disable-inode
(ede--put-inode-dir-hash dir 0)
(let ((fattr (file-attributes dir)))
- (ede--put-inode-dir-hash dir (nth 10 fattr))
+ (ede--put-inode-dir-hash dir (file-attribute-inode-number fattr))
)))))
(cl-defmethod ede--project-inode ((proj ede-project-placeholder))
diff --git a/lisp/cedet/ede/linux.el b/lisp/cedet/ede/linux.el
index 471286bb860..8ec6d8b0b15 100644
--- a/lisp/cedet/ede/linux.el
+++ b/lisp/cedet/ede/linux.el
@@ -32,10 +32,9 @@
;; * Add texinfo lookup options.
;; * Add website
-(eval-when-compile (require 'cl))
-
(require 'ede)
(require 'ede/make)
+(eval-when-compile (require 'cl-lib))
(declare-function semanticdb-file-table-object "semantic/db")
(declare-function semanticdb-needs-refresh-p "semantic/db")
@@ -116,7 +115,7 @@ If DIR has not been used as a build directory, fall back to
;; detected build on source directory
(and (file-exists-p (expand-file-name ".config" dir)) dir)
;; use configuration
- (case project-linux-build-directory-default
+ (cl-case project-linux-build-directory-default
(same dir)
(ask (read-directory-name "Select Linux' build directory: " dir)))))
@@ -165,7 +164,7 @@ Uses `ede-linux--detect-architecture' for the auto-detection. If
the result is `ask', let the user choose from architectures found
in DIR."
(let ((arch (ede-linux--detect-architecture bdir)))
- (case arch
+ (cl-case arch
(ask
(completing-read "Select target architecture: "
(ede-linux--get-archs dir)))
@@ -176,7 +175,7 @@ in DIR."
"Returns a list with include directories.
Returned directories might not exist, since they are not created
until Linux is built for the first time."
- (map 'list
+ (cl-map 'list
(lambda (elem) (format (concat (car elem) "/" (cdr elem)) arch))
;; XXX: taken from the output of "make V=1"
(list (cons dir "arch/%s/include")
diff --git a/lisp/cedet/ede/makefile-edit.el b/lisp/cedet/ede/makefile-edit.el
index 7d8a44bd9aa..1472108ad5e 100644
--- a/lisp/cedet/ede/makefile-edit.el
+++ b/lisp/cedet/ede/makefile-edit.el
@@ -105,7 +105,7 @@ STOP-BEFORE is a regular expression matching a file name."
(let ((e (save-excursion
(makefile-end-of-command)
(point))))
- (while (re-search-forward "\\s-**\\([-a-zA-Z0-9./_@$%(){}]+\\)\\s-*" e t)
+ (while (re-search-forward "\\s-*\\([-a-zA-Z0-9./_@$%(){}]+\\)\\s-*" e t)
(let ((var nil)(varexp nil)
(match (buffer-substring-no-properties
(match-beginning 1)
diff --git a/lisp/cedet/ede/pconf.el b/lisp/cedet/ede/pconf.el
index b9712036822..4b6da4440a5 100644
--- a/lisp/cedet/ede/pconf.el
+++ b/lisp/cedet/ede/pconf.el
@@ -135,7 +135,9 @@ don't do it. A value of nil means to just do it.")
(with-current-buffer "*compilation*"
(goto-char (point-max))
- (when (not (string= mode-line-process ":exit [0]"))
+ ;; FIXME: Use `compilation-finish-functions' or similar to
+ ;; avoid relying on exact format of `mode-line-process'.
+ (when (not (string= (car mode-line-process) ":exit [0]"))
(error "Configure failed!"))
;; The Makefile is now recreated by configure?
diff --git a/lisp/cedet/ede/pmake.el b/lisp/cedet/ede/pmake.el
index aa720a7e3e4..db5a33e9031 100644
--- a/lisp/cedet/ede/pmake.el
+++ b/lisp/cedet/ede/pmake.el
@@ -43,7 +43,6 @@
;; 1) Insert distribution source variables for targets
;; 2) Insert user requested rules
-(eval-when-compile (require 'cl))
(require 'ede/proj)
(require 'ede/proj-obj)
(require 'ede/proj-comp)
diff --git a/lisp/cedet/ede/proj-archive.el b/lisp/cedet/ede/proj-archive.el
index 81d2b767ad9..d071e422872 100644
--- a/lisp/cedet/ede/proj-archive.el
+++ b/lisp/cedet/ede/proj-archive.el
@@ -34,7 +34,6 @@
(defvar ede-archive-linker
(ede-linker
- "ede-archive-linker"
:name "ar"
:variables '(("AR" . "ar")
("AR_CMD" . "$(AR) cr"))
diff --git a/lisp/cedet/ede/proj-aux.el b/lisp/cedet/ede/proj-aux.el
index 8b3aec3e532..1b037229933 100644
--- a/lisp/cedet/ede/proj-aux.el
+++ b/lisp/cedet/ede/proj-aux.el
@@ -34,8 +34,7 @@
"This target consists of aux files such as READMEs and COPYING.")
(defvar ede-aux-source
- (ede-sourcecode "ede-aux-source-txt"
- :name "Auxiliary Text"
+ (ede-sourcecode :name "Auxiliary Text"
:sourcepattern "^[A-Z]+$\\|\\.txt$")
"Miscellaneous fields definition.")
diff --git a/lisp/cedet/ede/proj-comp.el b/lisp/cedet/ede/proj-comp.el
index 7431191dc41..aa6baf3e340 100644
--- a/lisp/cedet/ede/proj-comp.el
+++ b/lisp/cedet/ede/proj-comp.el
@@ -44,7 +44,6 @@
;; To write a method that inserts a variable or rule for a compiler
;; based object, wrap the body of your call in `ede-compiler-only-once'
-(eval-when-compile (require 'cl))
(require 'ede) ;source object
(require 'ede/autoconf-edit)
diff --git a/lisp/cedet/ede/proj-elisp.el b/lisp/cedet/ede/proj-elisp.el
index f69dbba690c..c8e920aa94e 100644
--- a/lisp/cedet/ede/proj-elisp.el
+++ b/lisp/cedet/ede/proj-elisp.el
@@ -77,21 +77,18 @@ For Emacs Lisp, return addsuffix command on source files."
(ede-proj-makefile-sourcevar this)))
(defvar ede-source-emacs
- (ede-sourcecode "ede-emacs-source"
- :name "Emacs Lisp"
+ (ede-sourcecode :name "Emacs Lisp"
:sourcepattern "\\.el$"
:garbagepattern '("*.elc"))
"Emacs Lisp source code definition.")
(defvar ede-emacs-compiler
(ede-compiler
- "ede-emacs-compiler"
:name "emacs"
:variables '(("EMACS" . "emacs")
("EMACSFLAGS" . "-batch --no-site-file --eval '(setq debug-on-error t)'")
("require" . "$(foreach r,$(1),(require (quote $(r))))"))
:rules (list (ede-makefile-rule
- "elisp-inference-rule"
:target "%.elc"
:dependencies "%.el"
:rules '("$(EMACS) $(EMACSFLAGS) $(addprefix -L ,$(LOADPATH)) \
@@ -103,7 +100,7 @@ For Emacs Lisp, return addsuffix command on source files."
"Compile Emacs Lisp programs.")
(defvar ede-xemacs-compiler
- (clone ede-emacs-compiler "ede-xemacs-compiler"
+ (clone ede-emacs-compiler
:name "xemacs"
:variables '(("EMACS" . "xemacs")))
"Compile Emacs Lisp programs with XEmacs.")
@@ -324,7 +321,6 @@ Lays claim to all .elc files that match .el files in this target."
;; Compilers
(defvar ede-emacs-cedet-autogen-compiler
(ede-compiler
- "ede-emacs-autogen-compiler"
:name "emacs"
:variables '(("EMACS" . "emacs")
("EMACSFLAGS" . "-batch --no-site-file --eval '(setq debug-on-error t)'")
@@ -333,7 +329,7 @@ Lays claim to all .elc files that match .el files in this target."
'("$(EMACS) $(EMACSFLAGS) $(addprefix -L ,$(LOADPATH)) \
--eval '(setq generated-autoload-file \"$(abspath $(LOADDEFS))\")' \
-f batch-update-autoloads $(abspath $(LOADDIRS))")
- :rules (list (ede-makefile-rule "clean-autoloads" :target "clean-autoloads" :phony t :rules '("rm -f $(LOADDEFS)")))
+ :rules (list (ede-makefile-rule :target "clean-autoloads" :phony t :rules '("rm -f $(LOADDEFS)")))
:sourcetype '(ede-source-emacs)
)
"Build an autoloads file.")
diff --git a/lisp/cedet/ede/proj-info.el b/lisp/cedet/ede/proj-info.el
index 27a11a30f32..1a2f1074182 100644
--- a/lisp/cedet/ede/proj-info.el
+++ b/lisp/cedet/ede/proj-info.el
@@ -43,15 +43,13 @@ All other sources should be included independently."))
"Target for a single info file.")
(defvar ede-makeinfo-source
- (ede-sourcecode "ede-makeinfo-source"
- :name "Texinfo"
+ (ede-sourcecode :name "Texinfo"
:sourcepattern "\\.texi?$"
:garbagepattern '("*.info*" "*.html"))
"Texinfo source code definition.")
(defvar ede-makeinfo-compiler
(ede-compiler
- "ede-makeinfo-compiler"
:name "makeinfo"
:variables '(("MAKEINFO" . "makeinfo"))
:commands '("$(MAKEINFO) $<")
@@ -62,7 +60,6 @@ All other sources should be included independently."))
(defvar ede-texi2html-compiler
(ede-compiler
- "ede-texi2html-compiler"
:name "texi2html"
:variables '(("TEXI2HTML" . "makeinfo -html"))
:commands '("makeinfo -o $@ $<")
diff --git a/lisp/cedet/ede/proj-misc.el b/lisp/cedet/ede/proj-misc.el
index 10021a5e50a..c9be119b4eb 100644
--- a/lisp/cedet/ede/proj-misc.el
+++ b/lisp/cedet/ede/proj-misc.el
@@ -26,7 +26,6 @@
;; This misc target lets the user link in custom makefiles to an EDE
;; project.
-(eval-when-compile (require 'cl))
(require 'ede/pmake)
(require 'ede/proj-comp)
@@ -49,14 +48,12 @@ A user-written makefile is used to build this target.
All listed sources are included in the distribution.")
(defvar ede-misc-source
- (ede-sourcecode "ede-misc-source"
- :name "Miscellaneous"
+ (ede-sourcecode :name "Miscellaneous"
:sourcepattern ".*")
"Miscellaneous field definition.")
(defvar ede-misc-compile
- (ede-compiler "ede-misc-compile"
- :name "Sub Makefile"
+ (ede-compiler :name "Sub Makefile"
:commands
'(
)
diff --git a/lisp/cedet/ede/proj-obj.el b/lisp/cedet/ede/proj-obj.el
index c5ea81b83ea..45e874037a7 100644
--- a/lisp/cedet/ede/proj-obj.el
+++ b/lisp/cedet/ede/proj-obj.el
@@ -26,7 +26,6 @@
;; Handles a superclass of target types which create object code in
;; and EDE Project file.
-(eval-when-compile (require 'cl))
(require 'ede/proj)
(declare-function ede-pmake-varname "ede/pmake")
@@ -83,8 +82,7 @@ file.")
;;; C/C++ Compilers and Linkers
;;
(defvar ede-source-c
- (ede-sourcecode "ede-source-c"
- :name "C"
+ (ede-sourcecode :name "C"
:sourcepattern "\\.c$"
:auxsourcepattern "\\.h$"
:garbagepattern '("*.o" "*.obj" ".deps/*.P" ".lo"))
@@ -92,14 +90,12 @@ file.")
(defvar ede-gcc-compiler
(ede-object-compiler
- "ede-c-compiler-gcc"
:name "gcc"
:dependencyvar '("C_DEPENDENCIES" . "-Wp,-MD,.deps/$(*F).P")
:variables '(("CC" . "gcc")
("C_COMPILE" .
"$(CC) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)"))
:rules (list (ede-makefile-rule
- "c-inference-rule"
:target "%.o"
:dependencies "%.c"
:rules '("@echo '$(C_COMPILE) -c $<'; \\"
@@ -115,7 +111,6 @@ file.")
(defvar ede-cc-linker
(ede-linker
- "ede-cc-linker"
:name "cc"
:sourcetype '(ede-source-c)
:variables '(("C_LINK" . "$(CC) $(CFLAGS) $(LDFLAGS) -L."))
@@ -124,8 +119,7 @@ file.")
"Linker for C sourcecode.")
(defvar ede-source-c++
- (ede-sourcecode "ede-source-c++"
- :name "C++"
+ (ede-sourcecode :name "C++"
:sourcepattern "\\.\\(c\\(pp?\\|c\\|xx\\|++\\)\\|C\\(PP\\)?\\)$"
:auxsourcepattern "\\.\\(hpp?\\|hh?\\|hxx\\|H\\)$"
:garbagepattern '("*.o" "*.obj" ".deps/*.P" ".lo"))
@@ -133,7 +127,6 @@ file.")
(defvar ede-g++-compiler
(ede-object-compiler
- "ede-c-compiler-g++"
:name "g++"
:dependencyvar '("CXX_DEPENDENCIES" . "-Wp,-MD,.deps/$(*F).P")
:variables '(("CXX" "g++")
@@ -141,7 +134,6 @@ file.")
"$(CXX) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)")
)
:rules (list (ede-makefile-rule
- "c++-inference-rule"
:target "%.o"
:dependencies "%.cpp"
:rules '("@echo '$(CXX_COMPILE) -c $<'; \\"
@@ -157,7 +149,6 @@ file.")
(defvar ede-g++-linker
(ede-linker
- "ede-g++-linker"
:name "g++"
;; Only use this linker when c++ exists.
:sourcetype '(ede-source-c++)
@@ -169,15 +160,13 @@ file.")
;;; LEX
(defvar ede-source-lex
- (ede-sourcecode "ede-source-lex"
- :name "lex"
+ (ede-sourcecode :name "lex"
:sourcepattern "\\.l\\(l\\|pp\\|++\\)")
"Lex source code definition.
No garbage pattern since it creates C or C++ code.")
(defvar ede-lex-compiler
(ede-object-compiler
- "ede-lex-compiler"
;; Can we support regular makefiles too??
:autoconf '("AC_PROG_LEX")
:sourcetype '(ede-source-lex))
@@ -185,15 +174,13 @@ No garbage pattern since it creates C or C++ code.")
;;; YACC
(defvar ede-source-yacc
- (ede-sourcecode "ede-source-yacc"
- :name "yacc"
+ (ede-sourcecode :name "yacc"
:sourcepattern "\\.y\\(y\\|pp\\|++\\)")
"Yacc source code definition.
No garbage pattern since it creates C or C++ code.")
(defvar ede-yacc-compiler
(ede-object-compiler
- "ede-yacc-compiler"
;; Can we support regular makefiles too??
:autoconf '("AC_PROG_YACC")
:sourcetype '(ede-source-yacc))
@@ -203,16 +190,14 @@ No garbage pattern since it creates C or C++ code.")
;;
;; Contributed by David Engster
(defvar ede-source-f90
- (ede-sourcecode "ede-source-f90"
- :name "Fortran 90/95"
+ (ede-sourcecode :name "Fortran 90/95"
:sourcepattern "\\.[fF]9[05]$"
:auxsourcepattern "\\.incf$"
:garbagepattern '("*.o" "*.mod" ".deps/*.P"))
"Fortran 90/95 source code definition.")
(defvar ede-source-f77
- (ede-sourcecode "ede-source-f77"
- :name "Fortran 77"
+ (ede-sourcecode :name "Fortran 77"
:sourcepattern "\\.\\([fF]\\|for\\)$"
:auxsourcepattern "\\.incf$"
:garbagepattern '("*.o" ".deps/*.P"))
@@ -220,14 +205,12 @@ No garbage pattern since it creates C or C++ code.")
(defvar ede-gfortran-compiler
(ede-object-compiler
- "ede-f90-compiler-gfortran"
:name "gfortran"
:dependencyvar '("F90_DEPENDENCIES" . "-Wp,-MD,.deps/$(*F).P")
:variables '(("F90" . "gfortran")
("F90_COMPILE" .
"$(F90) $(DEFS) $(INCLUDES) $(F90FLAGS)"))
:rules (list (ede-makefile-rule
- "f90-inference-rule"
:target "%.o"
:dependencies "%.f90"
:rules '("@echo '$(F90_COMPILE) -c $<'; \\"
@@ -242,7 +225,6 @@ No garbage pattern since it creates C or C++ code.")
(defvar ede-gfortran-module-compiler
(clone ede-gfortran-compiler
- "ede-f90-module-compiler-gfortran"
:name "gfortranmod"
:sourcetype '(ede-source-f90)
:commands '("$(F90_COMPILE) -c $^")
@@ -253,7 +235,6 @@ No garbage pattern since it creates C or C++ code.")
(defvar ede-gfortran-linker
(ede-linker
- "ede-gfortran-linker"
:name "gfortran"
:sourcetype '(ede-source-f90 ede-source-f77)
:variables '(("F90_LINK" . "$(F90) $(CFLAGS) $(LDFLAGS) -L."))
@@ -265,7 +246,6 @@ No garbage pattern since it creates C or C++ code.")
;;
(defvar ede-ld-linker
(ede-linker
- "ede-ld-linker"
:name "ld"
:variables '(("LD" . "ld")
("LD_LINK" . "$(LD) $(LDFLAGS) -L."))
diff --git a/lisp/cedet/ede/proj-prog.el b/lisp/cedet/ede/proj-prog.el
index a7450361b17..8299b721acc 100644
--- a/lisp/cedet/ede/proj-prog.el
+++ b/lisp/cedet/ede/proj-prog.el
@@ -25,7 +25,6 @@
;;
;; Handle building programs from object files in and EDE Project file.
-(eval-when-compile (require 'cl))
(require 'ede/pmake)
(require 'ede/proj-obj)
diff --git a/lisp/cedet/ede/proj-shared.el b/lisp/cedet/ede/proj-shared.el
index b21c617252a..47fb453ac13 100644
--- a/lisp/cedet/ede/proj-shared.el
+++ b/lisp/cedet/ede/proj-shared.el
@@ -75,7 +75,6 @@ Use ldlibs to add addition libraries.")
("LTLINK" . "$(LIBTOOL) --mode=link $(CC) $(CFLAGS) $(LDFLAGS) -L. -o $@")
)
:rules (list (ede-makefile-rule
- "cc-inference-rule-libtool"
:target "%.o"
:dependencies "%.c"
:rules '("@echo '$(LTCOMPILE) -o $@ $<'; \\"
@@ -122,7 +121,6 @@ Use ldlibs to add addition libraries.")
("LTCOMPILE" . "$(LIBTOOL) --tag=CXX --mode=compile $(CXX) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)")
)
:rules (list (ede-makefile-rule
- "c++-inference-rule-libtool"
:target "%.o"
:dependencies "%.cpp"
:rules '("@echo '$(LTCOMPILE) -o $@ $<'; \\"
diff --git a/lisp/cedet/ede/simple.el b/lisp/cedet/ede/simple.el
index 5b1c14bcd74..fb4df489584 100644
--- a/lisp/cedet/ede/simple.el
+++ b/lisp/cedet/ede/simple.el
@@ -46,7 +46,7 @@
;;; Code:
(add-to-list 'ede-project-class-files
- (ede-project-autoload "simple-overlay"
+ (ede-project-autoload
:name "Simple" :file 'ede/simple
:proj-file 'ede-simple-projectfile-for-dir
:load-type 'ede-simple-load
diff --git a/lisp/cedet/ede/source.el b/lisp/cedet/ede/source.el
index ece99f59917..8105af0d6a4 100644
--- a/lisp/cedet/ede/source.el
+++ b/lisp/cedet/ede/source.el
@@ -156,14 +156,12 @@ Used to guess header files, but uses the auxsource regular expression."
;;
;; This must appear at the end so that the init method will work.
(defvar ede-source-scheme
- (ede-sourcecode "ede-source-scheme"
- :name "Scheme"
+ (ede-sourcecode :name "Scheme"
:sourcepattern "\\.scm$")
"Scheme source code definition.")
;;(defvar ede-source-
-;; (ede-sourcecode "ede-source-"
-;; :name ""
+;; (ede-sourcecode :name ""
;; :sourcepattern "\\.$"
;; :garbagepattern '("*."))
;; " source code definition.")
diff --git a/lisp/cedet/ede/speedbar.el b/lisp/cedet/ede/speedbar.el
index e471bb6f957..a5ccb666644 100644
--- a/lisp/cedet/ede/speedbar.el
+++ b/lisp/cedet/ede/speedbar.el
@@ -28,7 +28,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
(require 'speedbar)
(require 'eieio-speedbar)
(require 'ede)
@@ -277,7 +276,7 @@ INDENT is the current indentation level."
Etags does not support this feature. TEXT will be the button
string. TOKEN will be the list, and INDENT is the current indentation
level."
- (cond ((string-match "+" text) ;we have to expand this file
+ (cond ((string-match "\\+" text) ;we have to expand this file
(speedbar-change-expand-button-char ?-)
(speedbar-with-writable
(save-excursion
diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el
index 4ce156d832b..f83decbc01c 100644
--- a/lisp/cedet/mode-local.el
+++ b/lisp/cedet/mode-local.el
@@ -46,8 +46,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
-
(require 'find-func)
;; For find-function-regexp-alist. It is tempting to replace this
;; ‘require’ by (defvar find-function-regexp-alist) and
diff --git a/lisp/cedet/pulse.el b/lisp/cedet/pulse.el
index bfd0f0c8e8f..fd658fa19bf 100644
--- a/lisp/cedet/pulse.el
+++ b/lisp/cedet/pulse.el
@@ -196,11 +196,11 @@ Optional argument FACE specifies the face to do the highlighting."
(pulse-reset-face face)
(setq pulse-momentary-timer
(run-with-timer 0 pulse-delay #'pulse-tick
- (time-add (current-time)
+ (time-add nil
(* pulse-delay pulse-iterations)))))))
(defun pulse-tick (stop-time)
- (if (time-less-p (current-time) stop-time)
+ (if (time-less-p nil stop-time)
(pulse-lighten-highlight)
(pulse-momentary-unhighlight)))
diff --git a/lisp/cedet/semantic.el b/lisp/cedet/semantic.el
index 05272117879..3c844610e41 100644
--- a/lisp/cedet/semantic.el
+++ b/lisp/cedet/semantic.el
@@ -225,37 +225,37 @@ during a flush when the cache is given a new value of nil.")
"Indicate that the current buffer is unparseable.
It is also true that the parse tree will need either updating or
a rebuild. This state will be changed when the user edits the buffer."
- `(setq semantic-parse-tree-state 'unparseable))
+ '(setq semantic-parse-tree-state 'unparseable))
(defmacro semantic-parse-tree-unparseable-p ()
"Return non-nil if the current buffer has been marked unparseable."
- `(eq semantic-parse-tree-state 'unparseable))
+ '(eq semantic-parse-tree-state 'unparseable))
(defmacro semantic-parse-tree-set-needs-update ()
"Indicate that the current parse tree needs to be updated.
The parse tree can be updated by `semantic-parse-changes'."
- `(setq semantic-parse-tree-state 'needs-update))
+ '(setq semantic-parse-tree-state 'needs-update))
(defmacro semantic-parse-tree-needs-update-p ()
"Return non-nil if the current parse tree needs to be updated."
- `(eq semantic-parse-tree-state 'needs-update))
+ '(eq semantic-parse-tree-state 'needs-update))
(defmacro semantic-parse-tree-set-needs-rebuild ()
"Indicate that the current parse tree needs to be rebuilt.
The parse tree must be rebuilt by `semantic-parse-region'."
- `(setq semantic-parse-tree-state 'needs-rebuild))
+ '(setq semantic-parse-tree-state 'needs-rebuild))
(defmacro semantic-parse-tree-needs-rebuild-p ()
"Return non-nil if the current parse tree needs to be rebuilt."
- `(eq semantic-parse-tree-state 'needs-rebuild))
+ '(eq semantic-parse-tree-state 'needs-rebuild))
(defmacro semantic-parse-tree-set-up-to-date ()
"Indicate that the current parse tree is up to date."
- `(setq semantic-parse-tree-state nil))
+ '(setq semantic-parse-tree-state nil))
(defmacro semantic-parse-tree-up-to-date-p ()
"Return non-nil if the current parse tree is up to date."
- `(null semantic-parse-tree-state))
+ '(null semantic-parse-tree-state))
;;; Interfacing with the system
;;
@@ -389,10 +389,9 @@ the output buffer."
(if clear (semantic-clear-toplevel-cache))
(if (eq clear '-) (setq clear -1))
(let* ((start (current-time))
- (out (semantic-fetch-tags))
- (end (current-time)))
+ (out (semantic-fetch-tags)))
(message "Retrieving tags took %.2f seconds."
- (semantic-elapsed-time start end))
+ (semantic-elapsed-time start nil))
(when (or (null clear) (not (listp clear))
(and (numberp clear) (< 0 clear)))
(pop-to-buffer "*Parser Output*")
@@ -1097,9 +1096,6 @@ The following modes are more targeted at people who want to see
;;;###autoload
(define-minor-mode semantic-mode
"Toggle parser features (Semantic mode).
-With a prefix argument ARG, enable Semantic mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-Semantic mode if ARG is omitted or nil.
In Semantic mode, Emacs parses the buffers you visit for their
semantic content. This information is used by a variety of
diff --git a/lisp/cedet/semantic/analyze.el b/lisp/cedet/semantic/analyze.el
index d68098b5b9a..9ea7ebf7c1b 100644
--- a/lisp/cedet/semantic/analyze.el
+++ b/lisp/cedet/semantic/analyze.el
@@ -63,7 +63,6 @@
;; constant. These need to be returned as there would be no
;; other possible completions.
-(eval-when-compile (require 'cl))
(require 'semantic)
(require 'semantic/format)
(require 'semantic/ctxt)
@@ -440,12 +439,11 @@ to provide a large number of non-cached analysis for filtering symbols."
(defun semantic-analyze-current-symbol-default (analyzehookfcn position)
"Call ANALYZEHOOKFCN on the analyzed symbol at POSITION."
(let* ((semantic-analyze-error-stack nil)
- (LLstart (current-time))
+ ;; (LLstart (current-time))
(prefixandbounds (semantic-ctxt-current-symbol-and-bounds (or position (point))))
(prefix (car prefixandbounds))
(bounds (nth 2 prefixandbounds))
(scope (semantic-calculate-scope position))
- (end nil)
)
;; Only do work if we have bounds (meaning a prefix to complete)
(when bounds
@@ -464,15 +462,13 @@ to provide a large number of non-cached analysis for filtering symbols."
prefix scope 'prefixtypes))
(error (semantic-analyze-push-error err))))
- (setq end (current-time))
- ;;(message "Analysis took %.2f sec" (semantic-elapsed-time LLstart end))
+ ;;(message "Analysis took %.2f sec" (semantic-elapsed-time LLstart nil))
)
(when prefix
(prog1
(funcall analyzehookfcn (car bounds) (cdr bounds) prefix)
- ;;(setq end (current-time))
- ;;(message "hookfcn took %.5f sec" (semantic-elapsed-time LLstart end))
+ ;;(message "hookfcn took %.5f sec" (semantic-elapsed-time LLstart nil))
)
)))
@@ -645,7 +641,6 @@ Returns an object based on symbol `semantic-analyze-context'."
;; for the argument.
(setq context-return
(semantic-analyze-context-functionarg
- "functionargument"
:buffer (current-buffer)
:function fntag
:index arg
@@ -668,7 +663,6 @@ Returns an object based on symbol `semantic-analyze-context'."
(setq context-return
(semantic-analyze-context-assignment
- "assignment"
:buffer (current-buffer)
:assignee asstag
:scope scope
@@ -686,7 +680,6 @@ Returns an object based on symbol `semantic-analyze-context'."
;; Nothing in particular
(setq context-return
(semantic-analyze-context
- "context"
:buffer (current-buffer)
:scope scope
:bounds bounds
@@ -723,12 +716,11 @@ Optional argument CTXT is the context to show."
(interactive)
(require 'data-debug)
(let ((start (current-time))
- (ctxt (or ctxt (semantic-analyze-current-context)))
- (end (current-time)))
+ (ctxt (or ctxt (semantic-analyze-current-context))))
(if (not ctxt)
(message "No Analyzer Results")
(message "Analysis took %.2f seconds."
- (semantic-elapsed-time start end))
+ (semantic-elapsed-time start nil))
(semantic-analyze-pulse ctxt)
(if ctxt
(progn
diff --git a/lisp/cedet/semantic/analyze/debug.el b/lisp/cedet/semantic/analyze/debug.el
index c9927d29f08..d78d850723f 100644
--- a/lisp/cedet/semantic/analyze/debug.el
+++ b/lisp/cedet/semantic/analyze/debug.el
@@ -558,19 +558,19 @@ PARENT is a possible parent (by nesting) tag."
'mouse-face 'custom-button-pressed-face
'tag tag
'action
- `(lambda (button)
- (let ((buff nil)
- (pnt nil))
- (save-excursion
- (semantic-go-to-tag
- (button-get button 'tag))
- (setq buff (current-buffer))
- (setq pnt (point)))
- (if (get-buffer-window buff)
- (select-window (get-buffer-window buff))
- (pop-to-buffer buff t))
- (goto-char pnt)
- (pulse-line-hook-function)))
+ (lambda (button)
+ (let ((buff nil)
+ (pnt nil))
+ (save-excursion
+ (semantic-go-to-tag
+ (button-get button 'tag))
+ (setq buff (current-buffer))
+ (setq pnt (point)))
+ (if (get-buffer-window buff)
+ (select-window (get-buffer-window buff))
+ (pop-to-buffer buff t))
+ (goto-char pnt)
+ (pulse-line-hook-function)))
))
(princ "\"")
(princ str)
diff --git a/lisp/cedet/semantic/analyze/refs.el b/lisp/cedet/semantic/analyze/refs.el
index 309500b0adb..773210698ad 100644
--- a/lisp/cedet/semantic/analyze/refs.el
+++ b/lisp/cedet/semantic/analyze/refs.el
@@ -317,9 +317,8 @@ Only works for tags in the global namespace."
(let* ((tag (semantic-current-tag))
(start (current-time))
(sac (semantic-analyze-tag-references tag))
- (end (current-time))
)
- (message "Analysis took %.2f seconds." (semantic-elapsed-time start end))
+ (message "Analysis took %.2f seconds." (semantic-elapsed-time start nil))
(if sac
(progn
(require 'eieio-datadebug)
diff --git a/lisp/cedet/semantic/bovine.el b/lisp/cedet/semantic/bovine.el
index b185765df76..5d174c812ee 100644
--- a/lisp/cedet/semantic/bovine.el
+++ b/lisp/cedet/semantic/bovine.el
@@ -72,7 +72,7 @@ The return list is a lambda expression to be used in a bovine table."
"Return the current nonterminal symbol.
Part of the grammar source debugger. Depends on the existing
environment of `semantic-bovinate-stream'."
- `(if nt-stack
+ '(if nt-stack
(car (aref (car nt-stack) 2))
nonterminal))
diff --git a/lisp/cedet/semantic/bovine/c.el b/lisp/cedet/semantic/bovine/c.el
index 2b2cac11783..5f0ea168e25 100644
--- a/lisp/cedet/semantic/bovine/c.el
+++ b/lisp/cedet/semantic/bovine/c.el
@@ -1990,7 +1990,7 @@ have to be wrapped in that namespace."
(list (semantic-tag-new-type inside-ns "namespace" tags nil)))
;; Create new semantic-table for the wrapped tags, since we don't want
;; the namespace to actually be a part of the header file.
- (setq newtable (semanticdb-table "include with context"))
+ (setq newtable (semanticdb-table))
(oset newtable tags newtags)
(oset newtable parent-db (oref inctable parent-db))
(oset newtable file (oref inctable file)))
diff --git a/lisp/cedet/semantic/bovine/debug.el b/lisp/cedet/semantic/bovine/debug.el
index d4f04253dcb..3464e25787f 100644
--- a/lisp/cedet/semantic/bovine/debug.el
+++ b/lisp/cedet/semantic/bovine/debug.el
@@ -73,8 +73,7 @@ The RULE is for \"thing\" is 1.
The MATCH for \"thing\" is 1.
COLLECTION is a list of `things' that have been matched so far.
LEXTOKEN, is a token returned by the lexer which is being matched."
- (let ((frame (semantic-bovine-debug-frame "frame"
- :nonterm nonterm
+ (let ((frame (semantic-bovine-debug-frame :nonterm nonterm
:rule rule
:match match
:collection collection
@@ -119,8 +118,7 @@ LEXTOKEN, is a token returned by the lexer which is being matched."
(defun semantic-create-bovine-debug-error-frame (condition)
"Create an error frame for bovine debugger.
Argument CONDITION is the thrown error condition."
- (let ((frame (semantic-bovine-debug-error-frame "frame"
- :condition condition)))
+ (let ((frame (semantic-bovine-debug-error-frame :condition condition)))
(semantic-debug-set-frame semantic-debug-current-interface
frame)
frame))
diff --git a/lisp/cedet/semantic/bovine/grammar.el b/lisp/cedet/semantic/bovine/grammar.el
index 529958a8075..f77bc9db555 100644
--- a/lisp/cedet/semantic/bovine/grammar.el
+++ b/lisp/cedet/semantic/bovine/grammar.el
@@ -475,6 +475,7 @@ Menu items are appended to the common grammar menu.")
;; This is with-demoted-errors.
(condition-case err
(with-current-buffer (find-file-noselect infile)
+ (setq infile buffer-file-name)
(if outdir (setq default-directory outdir))
(semantic-grammar-create-package nil t))
(error (message "%s" (error-message-string err)) nil)))
@@ -509,8 +510,12 @@ Menu items are appended to the common grammar menu.")
;;; Commentary:
;;
-;; This file was generated from admin/grammars/"
- lang ".by.
+;; This file was generated from "
+ (if (string-match "\\(admin/grammars/.*\\.by\\)\\'" infile)
+ (match-string 1 infile)
+ (concat "admin/grammars/"
+ (if (string-equal lang "scm") "scheme" lang) ".by"))
+".
;;; Code:
")
diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el
index 1e7bbbd813c..88ddd58059d 100644
--- a/lisp/cedet/semantic/complete.el
+++ b/lisp/cedet/semantic/complete.el
@@ -106,7 +106,6 @@
;; `semantic-complete-inline-tag-engine' will complete text in
;; a buffer.
-(eval-when-compile (require 'cl))
(require 'semantic)
(require 'eieio-opt)
(require 'semantic/analyze)
@@ -1890,8 +1889,8 @@ If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
HISTORY is a symbol representing a variable to store the history in."
(semantic-complete-read-tag-engine
(semantic-collector-buffer-deep prompt :buffer (current-buffer))
- (semantic-displayor-traditional-with-focus-highlight "simple")
- ;;(semantic-displayor-tooltip "simple")
+ (semantic-displayor-traditional-with-focus-highlight)
+ ;;(semantic-displayor-tooltip)
prompt
default-tag
initial-input
@@ -1912,8 +1911,8 @@ If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
HISTORY is a symbol representing a variable to store the history in."
(semantic-complete-read-tag-engine
(semantic-collector-local-members prompt :buffer (current-buffer))
- (semantic-displayor-traditional-with-focus-highlight "simple")
- ;;(semantic-displayor-tooltip "simple")
+ (semantic-displayor-traditional-with-focus-highlight)
+ ;;(semantic-displayor-tooltip)
prompt
default-tag
initial-input
@@ -1937,7 +1936,7 @@ HISTORY is a symbol representing a variable to store the history in."
:buffer (current-buffer)
:path (current-buffer)
)
- (semantic-displayor-traditional-with-focus-highlight "simple")
+ (semantic-displayor-traditional-with-focus-highlight)
prompt
default-tag
initial-input
@@ -1954,7 +1953,6 @@ to control how completion options are displayed.
See `semantic-complete-inline-tag-engine' for details on how
completion works."
(let* ((collector (semantic-collector-project-brutish
- "inline"
:buffer (current-buffer)
:path (current-buffer)))
(sbounds (semantic-ctxt-current-symbol-and-bounds))
@@ -1984,9 +1982,8 @@ completion works."
;; There are several options. Do the completion.
(semantic-complete-inline-tag-engine
collector
- (funcall semantic-complete-inline-analyzer-displayor-class
- "inline displayor")
- ;;(semantic-displayor-tooltip "simple")
+ (funcall semantic-complete-inline-analyzer-displayor-class)
+ ;;(semantic-displayor-tooltip)
(current-buffer)
start end))
)))
@@ -2013,7 +2010,7 @@ prompts. these are calculated from the CONTEXT variable passed in."
prompt
:buffer (oref context buffer)
:context context)
- (semantic-displayor-traditional-with-focus-highlight "simple")
+ (semantic-displayor-traditional-with-focus-highlight)
(with-current-buffer (oref context buffer)
(goto-char (cdr (oref context bounds)))
(concat prompt (mapconcat 'identity syms ".")
@@ -2037,7 +2034,6 @@ completion works."
(if (not context) (setq context (semantic-analyze-current-context (point))))
(if (not context) (error "Nothing to complete on here"))
(let* ((collector (semantic-collector-analyze-completions
- "inline"
:buffer (oref context buffer)
:context context))
(syms (semantic-ctxt-current-symbol (point)))
@@ -2064,9 +2060,8 @@ completion works."
;; There are several options. Do the completion.
(semantic-complete-inline-tag-engine
collector
- (funcall semantic-complete-inline-analyzer-displayor-class
- "inline displayor")
- ;;(semantic-displayor-tooltip "simple")
+ (funcall semantic-complete-inline-analyzer-displayor-class)
+ ;;(semantic-displayor-tooltip)
(oref context buffer)
(car (oref context bounds))
(cdr (oref context bounds))
diff --git a/lisp/cedet/semantic/db-file.el b/lisp/cedet/semantic/db-file.el
index 496d0a59d24..8dbb337ee55 100644
--- a/lisp/cedet/semantic/db-file.el
+++ b/lisp/cedet/semantic/db-file.el
@@ -307,8 +307,8 @@ Argument OBJ is the object to write."
;; Make sure that the file size and other attributes are
;; up to date.
(let ((fattr (file-attributes (semanticdb-full-filename obj))))
- (oset obj fsize (nth 7 fattr))
- (oset obj lastmodtime (nth 5 fattr))
+ (oset obj fsize (file-attribute-size fattr))
+ (oset obj lastmodtime (file-attribute-modification-time fattr))
)
;; Do it!
diff --git a/lisp/cedet/semantic/db-find.el b/lisp/cedet/semantic/db-find.el
index 81691fbbeea..c89ae1392dd 100644
--- a/lisp/cedet/semantic/db-find.el
+++ b/lisp/cedet/semantic/db-find.el
@@ -1333,6 +1333,9 @@ Returns a table of all matching tags."
(semantic-find-tags-included (or tags (semanticdb-get-tags table)))
(semantic-find-tags-by-class class (or tags (semanticdb-get-tags table)))))
+(declare-function semantic-find-tags-external-children-of-type
+ "semantic/find" (type &optional table))
+
(cl-defmethod semanticdb-find-tags-external-children-of-type-method ((table semanticdb-abstract-table) parent &optional tags)
"In TABLE, find all occurrences of tags whose parent is the PARENT type.
Optional argument TAGS is a list of tags to search.
@@ -1340,6 +1343,9 @@ Returns a table of all matching tags."
(require 'semantic/find)
(semantic-find-tags-external-children-of-type parent (or tags (semanticdb-get-tags table))))
+(declare-function semantic-find-tags-subclasses-of-type
+ "semantic/find" (type &optional table))
+
(cl-defmethod semanticdb-find-tags-subclasses-of-type-method ((table semanticdb-abstract-table) parent &optional tags)
"In TABLE, find all occurrences of tags whose parent is the PARENT type.
Optional argument TAGS is a list of tags to search.
diff --git a/lisp/cedet/semantic/db-javascript.el b/lisp/cedet/semantic/db-javascript.el
index 230fbfd84ed..5622594a5c3 100644
--- a/lisp/cedet/semantic/db-javascript.el
+++ b/lisp/cedet/semantic/db-javascript.el
@@ -98,7 +98,7 @@ See bottom of this file for instructions on managing this list.")
;; Create the database, and add it to searchable databases for javascript mode.
(defvar-mode-local javascript-mode semanticdb-project-system-databases
(list
- (semanticdb-project-database-javascript "Javascript"))
+ (semanticdb-project-database-javascript))
"Search javascript for symbols.")
;; NOTE: Be sure to modify this to the best advantage of your
@@ -115,13 +115,13 @@ the omniscience database.")
"For a javascript database, there are no explicit tables.
Create one of our special tables that can act as an intermediary."
;; NOTE: This method overrides an accessor for the `tables' slot in
- ;; a database. You can either construct your own (like tmp here
+ ;; a database. You can either construct your own (like newtable here
;; or you can manage any number of tables.
;; We need to return something since there is always the "master table"
;; The table can then answer file name type questions.
(when (not (slot-boundp obj 'tables))
- (let ((newtable (semanticdb-table-javascript "tmp")))
+ (let ((newtable (semanticdb-table-javascript)))
(oset obj tables (list newtable))
(oset newtable parent-db obj)
(oset newtable tags nil)
diff --git a/lisp/cedet/semantic/db-mode.el b/lisp/cedet/semantic/db-mode.el
index c2dd906e8e2..e1d8f632853 100644
--- a/lisp/cedet/semantic/db-mode.el
+++ b/lisp/cedet/semantic/db-mode.el
@@ -50,10 +50,12 @@
(member (car (car semanticdb-hooks))
(symbol-value (car (cdr (car semanticdb-hooks))))))
+(defvaralias 'semanticdb-mode-hook 'global-semanticdb-minor-mode-hook)
+(defvaralias 'semanticdb-global-mode 'global-semanticdb-minor-mode)
+
;;;###autoload
(define-minor-mode global-semanticdb-minor-mode
"Toggle Semantic DB mode.
-With ARG, turn Semantic DB mode on if ARG is positive, off otherwise.
In Semantic DB mode, Semantic parsers store results in a
database, which can be saved for future Emacs sessions."
@@ -67,8 +69,6 @@ database, which can be saved for future Emacs sessions."
(dolist (elt semanticdb-hooks)
(remove-hook (cadr elt) (car elt)))))
-(defvaralias 'semanticdb-mode-hook 'global-semanticdb-minor-mode-hook)
-(defvaralias 'semanticdb-global-mode 'global-semanticdb-minor-mode)
(semantic-varalias-obsolete 'semanticdb-mode-hooks
'global-semanticdb-minor-mode-hook "23.2")
@@ -178,8 +178,9 @@ handle it later if need be."
(let ((fattr (file-attributes
(semanticdb-full-filename
semanticdb-current-table))))
- (oset semanticdb-current-table fsize (nth 7 fattr))
- (oset semanticdb-current-table lastmodtime (nth 5 fattr))
+ (oset semanticdb-current-table fsize (file-attribute-size fattr))
+ (oset semanticdb-current-table lastmodtime
+ (file-attribute-modification-time fattr))
(oset semanticdb-current-table buffer nil)
))
;; If this messes up, just clear the system
diff --git a/lisp/cedet/semantic/db-ref.el b/lisp/cedet/semantic/db-ref.el
index 366fb15cf28..ddac96c7045 100644
--- a/lisp/cedet/semantic/db-ref.el
+++ b/lisp/cedet/semantic/db-ref.el
@@ -162,8 +162,7 @@ refreshed before dumping the result."
(let* ((tab semanticdb-current-table)
(myrefs (oref tab db-refs))
(myinc (semanticdb-includes-in-table tab))
- (adbc (semanticdb-ref-adebug "DEBUG"
- :i-depend-on myrefs
+ (adbc (semanticdb-ref-adebug :i-depend-on myrefs
:local-table tab
:i-include myinc)))
(data-debug-new-buffer "*References ADEBUG*")
diff --git a/lisp/cedet/semantic/db.el b/lisp/cedet/semantic/db.el
index a04d0777aca..1987bc07e29 100644
--- a/lisp/cedet/semantic/db.el
+++ b/lisp/cedet/semantic/db.el
@@ -611,8 +611,8 @@ The file associated with OBJ does not need to be in a buffer."
;; Buffer isn't loaded. The only clue we have is if the file
;; is somehow different from our mark in the semanticdb table.
(let* ((stats (file-attributes ff))
- (actualsize (nth 7 stats))
- (actualmod (nth 5 stats))
+ (actualsize (file-attribute-size stats))
+ (actualmod (file-attribute-modification-time stats))
)
(or (not (slot-boundp obj 'tags))
@@ -631,8 +631,8 @@ The file associated with OBJ does not need to be in a buffer."
(oset table tags new-tags)
(oset table pointmax (point-max))
(let ((fattr (file-attributes (semanticdb-full-filename table))))
- (oset table fsize (nth 7 fattr))
- (oset table lastmodtime (nth 5 fattr))
+ (oset table fsize (file-attribute-size fattr))
+ (oset table lastmodtime (file-attribute-modification-time fattr))
)
;; Assume it is now up to date.
(oset table unmatched-syntax semantic-unmatched-syntax-cache)
diff --git a/lisp/cedet/semantic/debug.el b/lisp/cedet/semantic/debug.el
index e4fe243302b..e5c04d1b8d7 100644
--- a/lisp/cedet/semantic/debug.el
+++ b/lisp/cedet/semantic/debug.el
@@ -36,7 +36,6 @@
;; Each parser must implement the interface and override any methods as needed.
;;
-(eval-when-compile (require 'cl))
(require 'semantic)
(require 'eieio)
(require 'cl-generic)
@@ -361,7 +360,6 @@ Argument ONOFF is non-nil when we are entering debug mode.
(semantic-debug-current-interface
(let ((parserb (semantic-debug-find-parser-source)))
(semantic-debug-interface
- "Debug Interface"
:parser-buffer parserb
:parser-local-map (with-current-buffer parserb
(current-local-map))
diff --git a/lisp/cedet/semantic/decorate/mode.el b/lisp/cedet/semantic/decorate/mode.el
index d4345a9ab0b..be1d5db069f 100644
--- a/lisp/cedet/semantic/decorate/mode.el
+++ b/lisp/cedet/semantic/decorate/mode.el
@@ -35,7 +35,7 @@
;;
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'semantic)
(require 'semantic/decorate)
(require 'semantic/tag-ls)
@@ -82,13 +82,13 @@ add items to this list."
(defsubst semantic-decoration-set-property (deco property value)
"Set the DECO decoration's PROPERTY to VALUE.
Return DECO."
- (assert (semantic-decoration-p deco))
+ (cl-assert (semantic-decoration-p deco))
(semantic-overlay-put deco property value)
deco)
(defsubst semantic-decoration-get-property (deco property)
"Return the DECO decoration's PROPERTY value."
- (assert (semantic-decoration-p deco))
+ (cl-assert (semantic-decoration-p deco))
(semantic-overlay-get deco property))
(defsubst semantic-decoration-set-face (deco face)
@@ -103,7 +103,7 @@ Return DECO."
(defsubst semantic-decoration-set-priority (deco priority)
"Set the priority of the decoration DECO to PRIORITY.
Return DECO."
- (assert (natnump priority))
+ (cl-assert (natnump priority))
(semantic-decoration-set-property deco 'priority priority))
(defsubst semantic-decoration-priority (deco)
@@ -113,7 +113,7 @@ Return DECO."
(defsubst semantic-decoration-move (deco begin end)
"Move the decoration DECO on the region between BEGIN and END.
Return DECO."
- (assert (semantic-decoration-p deco))
+ (cl-assert (semantic-decoration-p deco))
(semantic-overlay-move deco begin end)
deco)
@@ -135,7 +135,7 @@ Return the overlay that makes up the new decoration."
(defun semantic-decorate-clear-tag (tag &optional deco)
"Remove decorations from TAG.
If optional argument DECO is non-nil, remove only that decoration."
- (assert (or (null deco) (semantic-decoration-p deco)))
+ (cl-assert (or (null deco) (semantic-decoration-p deco)))
;; Clear primary decorations.
;; For now, just unhighlight the tag. How to deal with other
;; primary decorations like invisibility, etc. ? Maybe just
@@ -249,13 +249,13 @@ by `semantic-decoration-styles'."
(define-minor-mode semantic-decoration-mode
"Minor mode for decorating tags.
-Decorations are specified in `semantic-decoration-styles'.
-You can define new decoration styles with
+Decorations are specified in `semantic-decoration-styles'. You
+can define new decoration styles with
`define-semantic-decoration-style'.
-With prefix argument ARG, turn on if positive, otherwise off. The
-minor mode can be turned on only if semantic feature is available and
-the current buffer was set up for parsing. Return non-nil if the
-minor mode is enabled."
+
+The minor mode can be turned on only if semantic feature is
+available and the current buffer was set up for parsing. Return
+non-nil if the minor mode is enabled."
;;
;;\\{semantic-decoration-map}"
nil nil nil
diff --git a/lisp/cedet/semantic/dep.el b/lisp/cedet/semantic/dep.el
index 5dacc28d9e7..84bb2285b4e 100644
--- a/lisp/cedet/semantic/dep.el
+++ b/lisp/cedet/semantic/dep.el
@@ -56,7 +56,7 @@ reparsed, the cache will be reset.
TODO: use ffap.el to locate such items?
NOTE: Obsolete this, or use as special user")
-(make-variable-buffer-local `semantic-dependency-include-path)
+(make-variable-buffer-local 'semantic-dependency-include-path)
(defvar semantic-dependency-system-include-path nil
"Defines the system include path.
@@ -71,7 +71,7 @@ When searching for a file associated with a name found in a tag of
class include, this path will be inspected for includes of type
`system'. Some include tags are agnostic to this setting and will
check both the project and system directories.")
-(make-variable-buffer-local `semantic-dependency-system-include-path)
+(make-variable-buffer-local 'semantic-dependency-system-include-path)
(defmacro defcustom-mode-local-semantic-dependency-system-include-path
(mode name value &optional docstring)
diff --git a/lisp/cedet/semantic/ede-grammar.el b/lisp/cedet/semantic/ede-grammar.el
index 6e02394f156..4ced6fa80ef 100644
--- a/lisp/cedet/semantic/ede-grammar.el
+++ b/lisp/cedet/semantic/ede-grammar.el
@@ -67,8 +67,7 @@ For Emacs Lisp, return addsuffix command on source files."
(ede-proj-makefile-sourcevar this))))))
(defvar semantic-ede-source-grammar-wisent
- (ede-sourcecode "semantic-ede-grammar-source-wisent"
- :name "Wisent Grammar"
+ (ede-sourcecode :name "Wisent Grammar"
:sourcepattern "\\.wy$"
:garbagepattern '("*-wy.el")
)
@@ -80,13 +79,11 @@ For Emacs Lisp, return addsuffix command on source files."
(defvar semantic-ede-grammar-compiler-wisent
(semantic-ede-grammar-compiler-class
- "ede-emacs-wisent-compiler"
:name "emacs"
:variables '(("EMACS" . "emacs")
("EMACSFLAGS" . "-batch --no-site-file --eval '(setq debug-on-error t)'")
("require" . "$(foreach r,$(1),(require (quote $(r))))"))
:rules (list (ede-makefile-rule
- "elisp-inference-rule"
:target "%-wy.el"
:dependencies "%.wy"
:rules '("$(EMACS) $(EMACSFLAGS) $(addprefix -L ,$(LOADPATH)) \
@@ -98,8 +95,7 @@ For Emacs Lisp, return addsuffix command on source files."
(defvar semantic-ede-source-grammar-bovine
- (ede-sourcecode "semantic-ede-grammar-source-bovine"
- :name "Bovine Grammar"
+ (ede-sourcecode :name "Bovine Grammar"
:sourcepattern "\\.by$"
:garbagepattern '("*-by.el")
)
@@ -107,13 +103,11 @@ For Emacs Lisp, return addsuffix command on source files."
(defvar semantic-ede-grammar-compiler-bovine
(semantic-ede-grammar-compiler-class
- "ede-emacs-wisent-compiler"
:name "emacs"
:variables '(("EMACS" . "emacs")
("EMACSFLAGS" . "-batch --no-site-file --eval '(setq debug-on-error t)'")
("require" . "$(foreach r,$(1),(require (quote $(r))))"))
:rules (list (ede-makefile-rule
- "elisp-inference-rule"
:target "%-by.el"
:dependencies "%.by"
:rules '("$(EMACS) $(EMACSFLAGS) $(addprefix -L ,$(LOADPATH)) \
diff --git a/lisp/cedet/semantic/grammar.el b/lisp/cedet/semantic/grammar.el
index 9851280e14a..f6d67cf48eb 100644
--- a/lisp/cedet/semantic/grammar.el
+++ b/lisp/cedet/semantic/grammar.el
@@ -1611,7 +1611,7 @@ Select the buffer containing the tag's definition, and move point there."
;;
(defvar semantic-grammar-syntax-help
- `(
+ '(
;; Lexical Symbols
("symbol" . "Syntax: A symbol of alpha numeric and symbol characters")
("number" . "Syntax: Numeric characters.")
diff --git a/lisp/cedet/semantic/idle.el b/lisp/cedet/semantic/idle.el
index bb06de25985..a8946301da5 100644
--- a/lisp/cedet/semantic/idle.el
+++ b/lisp/cedet/semantic/idle.el
@@ -172,11 +172,9 @@ some command requests the list of available tokens. When idle-scheduler
is enabled, Emacs periodically checks to see if the buffer is out of
date, and reparses while the user is idle (not typing.)
-With prefix argument ARG, turn on if positive, otherwise off. The
-minor mode can be turned on only if semantic feature is available and
-the current buffer was set up for parsing. Return non-nil if the
-minor mode is enabled."
- nil nil nil
+The minor mode can be turned on only if semantic feature is
+available and the current buffer was set up for parsing. Return
+non-nil if the minor mode is enabled." nil nil nil
(if semantic-idle-scheduler-mode
(if (not (and (featurep 'semantic) (semantic-active-p)))
(progn
@@ -776,8 +774,6 @@ current tag to display information."
(define-minor-mode semantic-idle-summary-mode
"Toggle Semantic Idle Summary mode.
-With ARG, turn Semantic Idle Summary mode on if ARG is positive,
-off otherwise.
When this minor mode is enabled, the echo area displays a summary
of the lexical token at point whenever Emacs is idle."
@@ -812,8 +808,6 @@ of the lexical token at point whenever Emacs is idle."
(define-minor-mode global-semantic-idle-summary-mode
"Toggle Global Semantic Idle Summary mode.
-With ARG, turn Global Semantic Idle Summary mode on if ARG is
-positive, off otherwise.
When this minor mode is enabled, `semantic-idle-summary-mode' is
turned on in every Semantic-supported buffer."
@@ -931,9 +925,10 @@ Call `semantic-symref-hits-in-region' to identify local references."
;;;###autoload
(define-minor-mode global-semantic-idle-scheduler-mode
"Toggle global use of option `semantic-idle-scheduler-mode'.
-The idle scheduler will automatically reparse buffers in idle time,
-and then schedule other jobs setup with `semantic-idle-scheduler-add'.
-If ARG is positive or nil, enable, if it is negative, disable."
+
+The idle scheduler will automatically reparse buffers in idle
+time, and then schedule other jobs setup with
+`semantic-idle-scheduler-add'."
:global t
:group 'semantic
:group 'semantic-modes
diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el
index 7bef6b8324d..2690122f067 100644
--- a/lisp/cedet/semantic/lex.el
+++ b/lisp/cedet/semantic/lex.el
@@ -658,10 +658,9 @@ If universal argument ARG, then try the whole buffer."
(let* ((start (current-time))
(result (semantic-lex
(if arg (point-min) (point))
- (point-max)))
- (end (current-time)))
+ (point-max))))
(message "Elapsed Time: %.2f seconds."
- (semantic-elapsed-time start end))
+ (semantic-elapsed-time start nil))
(pop-to-buffer "*Lexer Output*")
(require 'pp)
(erase-buffer)
@@ -811,7 +810,7 @@ analyzer which might mistake a number for as a symbol."
tmp-start (car semantic-lex-token-stream)))
(setq tmp-start semantic-lex-end-point)
(goto-char semantic-lex-end-point)
- ;;(when (> (semantic-elapsed-time starttime (current-time))
+ ;;(when (> (semantic-elapsed-time starttime nil)
;; semantic-lex-timeout)
;; (error "Timeout during lex at char %d" (point)))
(semantic-throw-on-input 'lex)
diff --git a/lisp/cedet/semantic/mru-bookmark.el b/lisp/cedet/semantic/mru-bookmark.el
index b9124d80d51..2f38d357804 100644
--- a/lisp/cedet/semantic/mru-bookmark.el
+++ b/lisp/cedet/semantic/mru-bookmark.el
@@ -45,7 +45,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
(require 'semantic)
(require 'eieio-base)
(require 'ring)
@@ -166,7 +165,6 @@ We can't use the built-in ring data structure because we need
to delete some items from the ring when we don't have the data.")
(defvar semantic-mru-bookmark-ring (semantic-bookmark-ring
- "Ring"
:ring (make-ring 20))
"The MRU bookmark ring.
This ring tracks the most recent active tags of interest.")
@@ -254,8 +252,7 @@ been edited, and you can re-visit them with \\[semantic-mrub-switch-tags]."
;;;###autoload
(define-minor-mode global-semantic-mru-bookmark-mode
- "Toggle global use of option `semantic-mru-bookmark-mode'.
-If ARG is positive or nil, enable, if it is negative, disable."
+ "Toggle global use of option `semantic-mru-bookmark-mode'."
:global t :group 'semantic :group 'semantic-modes
;; Not needed because it's autoloaded instead.
;; :require 'semantic-util-modes
@@ -280,10 +277,9 @@ been edited, and you can re-visit them with \\[semantic-mrub-switch-tags].
\\{semantic-mru-bookmark-mode-map}
-With prefix argument ARG, turn on if positive, otherwise off. The
-minor mode can be turned on only if semantic feature is available and
-the current buffer was set up for parsing. Return non-nil if the
-minor mode is enabled."
+The minor mode can be turned on only if semantic feature is
+available and the current buffer was set up for parsing. Return
+non-nil if the minor mode is enabled."
:keymap semantic-mru-bookmark-mode-map
(if semantic-mru-bookmark-mode
(if (not (and (featurep 'semantic) (semantic-active-p)))
diff --git a/lisp/cedet/semantic/sb.el b/lisp/cedet/semantic/sb.el
index e4471be9aba..83d11e16583 100644
--- a/lisp/cedet/semantic/sb.el
+++ b/lisp/cedet/semantic/sb.el
@@ -279,7 +279,7 @@ Optional MODIFIERS is additional text needed for variables."
(defun semantic-sb-show-extra (text token indent)
"Display additional information about the token as an expansion.
TEXT TOKEN and INDENT are the details."
- (cond ((string-match "+" text) ;we have to expand this file
+ (cond ((string-match "\\+" text) ;we have to expand this file
(speedbar-change-expand-button-char ?-)
(speedbar-with-writable
(save-excursion
@@ -298,11 +298,7 @@ TEXT TOKEN and INDENT are the details."
"Jump to the location specified in token.
TEXT TOKEN and INDENT are the details."
(let ((file
- (or
- (cond ((fboundp 'speedbar-line-path)
- (speedbar-line-directory indent))
- ((fboundp 'speedbar-line-directory)
- (speedbar-line-directory indent)))
+ (or (speedbar-line-directory indent)
;; If speedbar cannot figure this out, extract the filename from
;; the token. True for Analysis mode.
(semantic-tag-file-name token)))
@@ -329,7 +325,7 @@ TEXT TOKEN and INDENT are the details."
(defun semantic-sb-expand-group (text token indent)
"Expand a group which has semantic tokens.
TEXT TOKEN and INDENT are the details."
- (cond ((string-match "+" text) ;we have to expand this file
+ (cond ((string-match "\\+" text) ;we have to expand this file
(speedbar-change-expand-button-char ?-)
(speedbar-with-writable
(save-excursion
diff --git a/lisp/cedet/semantic/scope.el b/lisp/cedet/semantic/scope.el
index ddb6185a4e9..e0851d309b9 100644
--- a/lisp/cedet/semantic/scope.el
+++ b/lisp/cedet/semantic/scope.el
@@ -309,7 +309,7 @@ are from nesting data types."
(list searchname)))
(fullsearchname nil)
- (miniscope (semantic-scope-cache "mini"))
+ (miniscope (semantic-scope-cache))
ptag)
;; Find the next entry in the referenced type for
@@ -368,7 +368,7 @@ and PROTECTION is the level of protection offered by the relationship.
Optional SCOPETYPES are additional scoped entities in which our parent might
be found."
(let ((lineage nil)
- (miniscope (semantic-scope-cache "mini"))
+ (miniscope (semantic-scope-cache))
)
(oset miniscope parents parents)
(oset miniscope scope scopetypes)
@@ -644,7 +644,7 @@ whose tags can be searched when needed, OR it may be a scope object."
;; We need to make a mini scope, and only include the misc bits
;; that will help in finding the parent. We don't really need
;; to do any of the stuff related to variables and what-not.
- (setq tmpscope (semantic-scope-cache "mini"))
+ (setq tmpscope (semantic-scope-cache))
(let* ( ;; Step 1:
(scopetypes (cons type (semantic-analyze-scoped-types (point))))
(parents (semantic-analyze-scope-nested-tags (point) scopetypes))
diff --git a/lisp/cedet/semantic/symref/filter.el b/lisp/cedet/semantic/symref/filter.el
index 99a629319da..5d166699533 100644
--- a/lisp/cedet/semantic/symref/filter.el
+++ b/lisp/cedet/semantic/symref/filter.el
@@ -103,7 +103,7 @@ tag that contains point, and return that."
(when (called-interactively-p 'interactive)
(message "Found %d occurrences of %s in %.2f seconds"
Lcount (semantic-tag-name target)
- (semantic-elapsed-time start (current-time))))
+ (semantic-elapsed-time start nil)))
Lcount)))
(defun semantic-symref-rename-local-variable ()
diff --git a/lisp/cedet/semantic/symref/grep.el b/lisp/cedet/semantic/symref/grep.el
index 3653aa9a1e9..caac757d512 100644
--- a/lisp/cedet/semantic/symref/grep.el
+++ b/lisp/cedet/semantic/symref/grep.el
@@ -173,14 +173,16 @@ This shell should support pipe redirect syntax."
;; find . -type f -print0 | xargs -0 -e grep -nH -e
;; Note : I removed -e as it is not posix, nor necessary it seems.
- (let ((cmd (concat "find " default-directory " -type f " filepattern " -print0 "
+ (let ((cmd (concat "find " (file-local-name rootdir)
+ " -type f " filepattern " -print0 "
"| xargs -0 grep -H " grepflags "-e " greppat)))
;;(message "Old command: %s" cmd)
- (call-process semantic-symref-grep-shell nil b nil
+ (process-file semantic-symref-grep-shell nil b nil
shell-command-switch cmd)
)
- (let ((cmd (semantic-symref-grep-use-template rootdir filepattern grepflags greppat)))
- (call-process semantic-symref-grep-shell nil b nil
+ (let ((cmd (semantic-symref-grep-use-template
+ (file-local-name rootdir) filepattern grepflags greppat)))
+ (process-file semantic-symref-grep-shell nil b nil
shell-command-switch cmd))
))
(setq ans (semantic-symref-parse-tool-output tool b))
diff --git a/lisp/cedet/semantic/symref/list.el b/lisp/cedet/semantic/symref/list.el
index 007e86c77d6..50aa5c5740b 100644
--- a/lisp/cedet/semantic/symref/list.el
+++ b/lisp/cedet/semantic/symref/list.el
@@ -114,7 +114,7 @@ Display the references in `semantic-symref-results-mode'."
(define-key km "+" 'semantic-symref-list-toggle-showing)
(define-key km "n" 'semantic-symref-list-next-line)
(define-key km "p" 'semantic-symref-list-prev-line)
- (define-key km "q" 'semantic-symref-hide-buffer)
+ (define-key km "q" 'quit-window)
(define-key km "\C-c\C-e" 'semantic-symref-list-expand-all)
(define-key km "\C-c\C-r" 'semantic-symref-list-contract-all)
(define-key km "R" 'semantic-symref-list-rename-open-hits)
@@ -193,11 +193,6 @@ Display the references in `semantic-symref-results-mode'."
(set (make-local-variable 'font-lock-global-modes) nil)
(font-lock-mode -1))
-(defun semantic-symref-hide-buffer ()
- "Hide buffer with semantic-symref results."
- (interactive)
- (bury-buffer))
-
(defcustom semantic-symref-results-summary-function 'semantic-format-tag-prototype
"Function to use when creating items in Imenu.
Some useful functions are found in `semantic-format-tag-functions'."
diff --git a/lisp/cedet/semantic/texi.el b/lisp/cedet/semantic/texi.el
index f07ab2636e0..f079bf201c8 100644
--- a/lisp/cedet/semantic/texi.el
+++ b/lisp/cedet/semantic/texi.el
@@ -365,6 +365,8 @@ Optional argument POINT is where to look for the environment."
(eval-when-compile
(require 'semantic/analyze))
+(declare-function semantic-analyze-context "semantic/analyze")
+
(define-mode-local-override semantic-analyze-current-context
texinfo-mode (point)
"Analysis context makes no sense for texinfo. Return nil."
@@ -376,7 +378,6 @@ Optional argument POINT is where to look for the environment."
(when prefix
(require 'semantic/analyze)
(semantic-analyze-context
- "Context-for-texinfo"
:buffer (current-buffer)
:scope nil
:bounds bounds
diff --git a/lisp/cedet/semantic/util-modes.el b/lisp/cedet/semantic/util-modes.el
index 39885627fb9..69df671217d 100644
--- a/lisp/cedet/semantic/util-modes.el
+++ b/lisp/cedet/semantic/util-modes.el
@@ -170,8 +170,7 @@ too an interactive function used to toggle the mode."
;;;###autoload
(define-minor-mode global-semantic-highlight-edits-mode
- "Toggle global use of option `semantic-highlight-edits-mode'.
-If ARG is positive or nil, enable, if it is negative, disable."
+ "Toggle global use of option `semantic-highlight-edits-mode'."
:global t :group 'semantic :group 'semantic-modes
(semantic-toggle-minor-mode-globally
'semantic-highlight-edits-mode
@@ -209,10 +208,10 @@ Changes are tracked by semantic so that the incremental parser can work
properly.
This mode will highlight those changes as they are made, and clear them
when the incremental parser accounts for those edits.
-With prefix argument ARG, turn on if positive, otherwise off. The
-minor mode can be turned on only if semantic feature is available and
-the current buffer was set up for parsing. Return non-nil if the
-minor mode is enabled."
+
+The minor mode can be turned on only if semantic feature is
+available and the current buffer was set up for parsing. Return
+non-nil if the minor mode is enabled."
:keymap semantic-highlight-edits-mode-map
(if semantic-highlight-edits-mode
(if (not (and (featurep 'semantic) (semantic-active-p)))
@@ -237,8 +236,7 @@ minor mode is enabled."
;;;###autoload
(define-minor-mode global-semantic-show-unmatched-syntax-mode
- "Toggle global use of option `semantic-show-unmatched-syntax-mode'.
-If ARG is positive or nil, enable, if it is negative, disable."
+ "Toggle global use of option `semantic-show-unmatched-syntax-mode'."
:global t :group 'semantic :group 'semantic-modes
;; Not needed because it's autoloaded instead.
;; :require 'semantic/util-modes
@@ -360,10 +358,9 @@ parser rules. These text characters are considered unmatched syntax.
Often time, the display of unmatched syntax can expose coding
problems before the compiler is run.
-With prefix argument ARG, turn on if positive, otherwise off. The
-minor mode can be turned on only if semantic feature is available and
-the current buffer was set up for parsing. Return non-nil if the
-minor mode is enabled.
+The minor mode can be turned on only if semantic feature is
+available and the current buffer was set up for parsing. Return
+non-nil if the minor mode is enabled.
\\{semantic-show-unmatched-syntax-mode-map}"
:keymap semantic-show-unmatched-syntax-mode-map
@@ -410,8 +407,7 @@ minor mode is enabled.
;;;###autoload
(define-minor-mode global-semantic-show-parser-state-mode
- "Toggle global use of option `semantic-show-parser-state-mode'.
-If ARG is positive or nil, enable, if it is negative, disable."
+ "Toggle global use of option `semantic-show-parser-state-mode'."
:global t :group 'semantic
;; Not needed because it's autoloaded instead.
;; :require 'semantic/util-modes
@@ -440,10 +436,10 @@ The state is indicated in the modeline with the following characters:
`~' -> The cache needs to be incrementally parsed.
`%' -> The cache is not currently parsable.
`@' -> Auto-parse in progress (not set here.)
-With prefix argument ARG, turn on if positive, otherwise off. The
-minor mode can be turned on only if semantic feature is available and
-the current buffer was set up for parsing. Return non-nil if the
-minor mode is enabled."
+
+The minor mode can be turned on only if semantic feature is
+available and the current buffer was set up for parsing. Return
+non-nil if the minor mode is enabled."
:keymap semantic-show-parser-state-mode-map
(if semantic-show-parser-state-mode
(if (not (and (featurep 'semantic) (semantic-active-p)))
@@ -557,8 +553,7 @@ to indicate a parse in progress."
;;;###autoload
(define-minor-mode global-semantic-stickyfunc-mode
- "Toggle global use of option `semantic-stickyfunc-mode'.
-If ARG is positive or nil, enable, if it is negative, disable."
+ "Toggle global use of option `semantic-stickyfunc-mode'."
:global t :group 'semantic :group 'semantic-modes
;; Not needed because it's autoloaded instead.
;; :require 'semantic/util-modes
@@ -700,10 +695,9 @@ A function (or other tag class specified by
first line which describes the rest of the construct. This first
line is what is displayed in the header line.
-With prefix argument ARG, turn on if positive, otherwise off. The
-minor mode can be turned on only if semantic feature is available and
-the current buffer was set up for parsing. Return non-nil if the
-minor mode is enabled."
+The minor mode can be turned on only if semantic feature is
+available and the current buffer was set up for parsing. Return
+non-nil if the minor mode is enabled."
;; Don't need indicator. It's quite visible
:keymap semantic-stickyfunc-mode-map
(if semantic-stickyfunc-mode
@@ -837,8 +831,7 @@ Argument EVENT describes the event that caused this function to be called."
;;;###autoload
(define-minor-mode global-semantic-highlight-func-mode
- "Toggle global use of option `semantic-highlight-func-mode'.
-If ARG is positive or nil, enable, if it is negative, disable."
+ "Toggle global use of option `semantic-highlight-func-mode'."
:global t :group 'semantic :group 'semantic-modes
;; Not needed because it's autoloaded instead.
;; :require 'semantic/util-modes
@@ -933,10 +926,9 @@ See `semantic-stickyfunc-mode' for putting a function in the
header line. This mode recycles the stickyfunc configuration
classes list.
-With prefix argument ARG, turn on if positive, otherwise off. The
-minor mode can be turned on only if semantic feature is available and
-the current buffer was set up for parsing. Return non-nil if the
-minor mode is enabled."
+The minor mode can be turned on only if semantic feature is
+available and the current buffer was set up for parsing. Return
+non-nil if the minor mode is enabled."
:lighter nil ;; Don't need indicator. It's quite visible.
(if semantic-highlight-func-mode
(progn
diff --git a/lisp/cedet/semantic/util.el b/lisp/cedet/semantic/util.el
index 6b13c41cfe2..943f9c78ef0 100644
--- a/lisp/cedet/semantic/util.el
+++ b/lisp/cedet/semantic/util.el
@@ -54,6 +54,8 @@ Equivalent modes share a parser, and a set of override methods.
A value of nil means that the current major mode is the only one.")
(make-variable-buffer-local 'semantic-equivalent-major-modes)
+(declare-function semanticdb-file-stream "semantic/db" (file))
+
;; These semanticdb calls will throw warnings in the byte compiler.
;; Doing the right thing to make them available at compile time
;; really messes up the compilation sequence.
@@ -80,6 +82,11 @@ If FILE is not loaded, and semanticdb is not available, find the file
(semantic-alias-obsolete 'semantic-file-token-stream
'semantic-file-tag-table "23.2")
+(declare-function semanticdb-abstract-table-child-p "semantic/db" (obj) t)
+(declare-function semanticdb-refresh-table "semantic/db")
+(declare-function semanticdb-get-tags "semantic/db" (arg &rest args) t)
+(declare-function semanticdb-find-results-p "semantic/db-find" (resultp))
+
(defun semantic-something-to-tag-table (something)
"Convert SOMETHING into a semantic tag table.
Something can be a tag with a valid BUFFER property, a tag table, a
@@ -140,6 +147,11 @@ buffer, or a filename. If SOMETHING is nil return nil."
(defvar semantic-read-symbol-history nil
"History for a symbol read.")
+(declare-function semantic-brute-find-tag-by-function
+ "semantic/find"
+ (function streamorbuffer
+ &optional search-parts search-includes))
+
(defun semantic-read-symbol (prompt &optional default stream filter)
"Read a symbol name from the user for the current buffer.
PROMPT is the prompt to use.
@@ -154,6 +166,7 @@ FILTER must be a function to call on each element."
(setq stream
(if filter
(semantic--find-tags-by-function filter stream)
+ (require 'semantic/find)
(semantic-brute-find-tag-standard stream)))
(if (and default (string-match ":" prompt))
(setq prompt
@@ -367,6 +380,11 @@ NOTFIRST indicates that this was not the first call in the recursive use."
;; Symbol completion
+(declare-function semanticdb-fast-strip-find-results
+ "semantic/db-find" (results))
+(declare-function semanticdb-deep-find-tags-for-completion
+ "semantic/db-find" (prefix &optional path find-file-match))
+
(defun semantic-find-tag-for-completion (prefix)
"Find all tags with name starting with PREFIX.
This uses `semanticdb' when available."
diff --git a/lisp/cedet/semantic/wisent/comp.el b/lisp/cedet/semantic/wisent/comp.el
index 4f6f5b02ba4..db910b1424e 100644
--- a/lisp/cedet/semantic/wisent/comp.el
+++ b/lisp/cedet/semantic/wisent/comp.el
@@ -41,7 +41,7 @@
;;; Code:
(require 'semantic/wisent)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
;;;; -------------------
;;;; Misc. useful things
@@ -139,14 +139,7 @@ If optional LEFT is non-nil insert spaces on left."
;;;; Environment dependencies
;;;; ------------------------
-(defconst wisent-BITS-PER-WORD
- (let ((i 1)
- (do-shift (if (boundp 'most-positive-fixnum)
- (lambda (i) (lsh most-positive-fixnum (- i)))
- (lambda (i) (lsh 1 i)))))
- (while (not (zerop (funcall do-shift i)))
- (setq i (1+ i)))
- i))
+(defconst wisent-BITS-PER-WORD (logcount most-positive-fixnum))
(defsubst wisent-WORDSIZE (n)
"(N + BITS-PER-WORD - 1) / BITS-PER-WORD."
@@ -156,18 +149,18 @@ If optional LEFT is non-nil insert spaces on left."
"X[I/BITS-PER-WORD] |= 1 << (I % BITS-PER-WORD)."
(let ((k (/ i wisent-BITS-PER-WORD)))
(aset x k (logior (aref x k)
- (lsh 1 (% i wisent-BITS-PER-WORD))))))
+ (ash 1 (% i wisent-BITS-PER-WORD))))))
(defsubst wisent-RESETBIT (x i)
"X[I/BITS-PER-WORD] &= ~(1 << (I % BITS-PER-WORD))."
(let ((k (/ i wisent-BITS-PER-WORD)))
(aset x k (logand (aref x k)
- (lognot (lsh 1 (% i wisent-BITS-PER-WORD)))))))
+ (lognot (ash 1 (% i wisent-BITS-PER-WORD)))))))
(defsubst wisent-BITISSET (x i)
"(X[I/BITS-PER-WORD] & (1 << (I % BITS-PER-WORD))) != 0."
(not (zerop (logand (aref x (/ i wisent-BITS-PER-WORD))
- (lsh 1 (% i wisent-BITS-PER-WORD))))))
+ (ash 1 (% i wisent-BITS-PER-WORD))))))
(defsubst wisent-noninteractive ()
"Return non-nil if running without interactive terminal."
@@ -203,11 +196,11 @@ If optional LEFT is non-nil insert spaces on left."
(defmacro wisent-log-buffer ()
"Return the log buffer.
Its name is defined in constant `wisent-log-buffer-name'."
- `(get-buffer-create wisent-log-buffer-name))
+ '(get-buffer-create wisent-log-buffer-name))
(defmacro wisent-clear-log ()
"Delete the entire contents of the log buffer."
- `(with-current-buffer (wisent-log-buffer)
+ '(with-current-buffer (wisent-log-buffer)
(erase-buffer)))
(defvar byte-compile-current-file)
@@ -2906,7 +2899,7 @@ references found in BODY, and XBODY is BODY expression with
(progn
(if (wisent-check-$N body n)
;; Accumulate $i symbol
- (pushnew body found :test #'equal))
+ (cl-pushnew body found :test #'equal))
(cons found body))
;; BODY is a list, expand inside it
(let (xbody sexpr)
@@ -2926,7 +2919,7 @@ references found in BODY, and XBODY is BODY expression with
;; $i symbol
((wisent-check-$N sexpr n)
;; Accumulate $i symbol
- (pushnew sexpr found :test #'equal))
+ (cl-pushnew sexpr found :test #'equal))
)
;; Accumulate expanded forms
(setq xbody (nconc xbody (list sexpr))))
diff --git a/lisp/cedet/semantic/wisent/grammar.el b/lisp/cedet/semantic/wisent/grammar.el
index d51e3f33113..7d776712eb4 100644
--- a/lisp/cedet/semantic/wisent/grammar.el
+++ b/lisp/cedet/semantic/wisent/grammar.el
@@ -194,7 +194,7 @@ See also the function `wisent-skip-block'."
"Expand call to SKIP-TOKEN grammar macro.
Return the form to skip the lookahead token.
See also the function `wisent-skip-token'."
- `(wisent-skip-token))
+ '(wisent-skip-token))
(defun wisent-grammar-assocs ()
"Return associativity and precedence level definitions."
diff --git a/lisp/cedet/semantic/wisent/python.el b/lisp/cedet/semantic/wisent/python.el
index 1edbc05a3a9..c530329baed 100644
--- a/lisp/cedet/semantic/wisent/python.el
+++ b/lisp/cedet/semantic/wisent/python.el
@@ -41,9 +41,6 @@
(require 'semantic/ctxt)
(require 'semantic/format)
-(eval-when-compile
- (require 'cl))
-
;;; Customization
;;
@@ -358,7 +355,7 @@ Set attributes for constructors, special, private and static methods."
;; + first argument is self
(when (and (> (length (semantic-tag-function-arguments tag)) 0)
(string= (semantic-tag-name
- (first (semantic-tag-function-arguments tag)))
+ (car (semantic-tag-function-arguments tag)))
"self"))
(semantic-tag-put-attribute tag :parent "dummy"))
diff --git a/lisp/cedet/srecode/compile.el b/lisp/cedet/srecode/compile.el
index a19df179013..204211b5e53 100644
--- a/lisp/cedet/srecode/compile.el
+++ b/lisp/cedet/srecode/compile.el
@@ -31,7 +31,6 @@
;; The output are a series of EIEIO objects which represent the
;; templates in a way that could be inserted later.
-(eval-when-compile (require 'cl))
(require 'semantic)
(require 'eieio)
(require 'cl-generic)
diff --git a/lisp/cedet/srecode/dictionary.el b/lisp/cedet/srecode/dictionary.el
index 6e7887f0530..a13c42df330 100644
--- a/lisp/cedet/srecode/dictionary.el
+++ b/lisp/cedet/srecode/dictionary.el
@@ -28,7 +28,6 @@
;;; CLASSES
-(eval-when-compile (require 'cl))
(require 'eieio)
(require 'cl-generic)
(require 'srecode)
@@ -612,10 +611,9 @@ STATE is the current compiler state."
(srecode-get-mode-table modesym))
(error "No table found for mode %S" modesym)))
(dict (srecode-create-dictionary (current-buffer)))
- (end (current-time))
)
(message "Creating a dictionary took %.2f seconds."
- (semantic-elapsed-time start end))
+ (semantic-elapsed-time start nil))
(data-debug-new-buffer "*SRECODE ADEBUG*")
(data-debug-insert-object-slots dict "*")))
diff --git a/lisp/cedet/srecode/extract.el b/lisp/cedet/srecode/extract.el
index 0086eeb6bd1..f4932513bcb 100644
--- a/lisp/cedet/srecode/extract.el
+++ b/lisp/cedet/srecode/extract.el
@@ -88,7 +88,7 @@ the dictionary entries were for that block of text."
(save-restriction
(narrow-to-region start end)
(let ((dict (srecode-create-dictionary t))
- (state (srecode-extract-state "state"))
+ (state (srecode-extract-state))
)
(goto-char start)
(srecode-extract-method template dict state)
diff --git a/lisp/cedet/srecode/map.el b/lisp/cedet/srecode/map.el
index 01ed630a66c..fa5d27b8d2e 100644
--- a/lisp/cedet/srecode/map.el
+++ b/lisp/cedet/srecode/map.el
@@ -224,10 +224,9 @@ Optional argument RESET forces a reset of the current map."
(require 'data-debug)
(let ((start (current-time))
(p (srecode-get-maps t)) ;; Time the reset.
- (end (current-time))
)
(message "Updating the map took %.2f seconds."
- (semantic-elapsed-time start end))
+ (semantic-elapsed-time start nil))
(data-debug-new-buffer "*SRECODE ADEBUG*")
(data-debug-insert-stuff-list p "*")))
@@ -271,7 +270,7 @@ if that file is NEW, otherwise assume the mode has not changed."
(if (not srecode-map-save-file)
;; 0) Create a MAP when in no save file mode.
(when (not srecode-current-map)
- (setq srecode-current-map (srecode-map "SRecode Map"))
+ (setq srecode-current-map (srecode-map))
(message "SRecode map created in non-save mode.")
)
@@ -291,8 +290,7 @@ if that file is NEW, otherwise assume the mode has not changed."
(error "Change your SRecode map file"))))
;; Have a dir. Make the object.
(setq srecode-current-map
- (srecode-map "SRecode Map"
- :file srecode-map-save-file)))
+ (srecode-map :file srecode-map-save-file)))
;; 2) Do we not have a current map? If so load.
(when (not srecode-current-map)
@@ -302,8 +300,7 @@ if that file is NEW, otherwise assume the mode has not changed."
(error
;; There was an error loading the old map. Create a new one.
(setq srecode-current-map
- (srecode-map "SRecode Map"
- :file srecode-map-save-file))))
+ (srecode-map :file srecode-map-save-file))))
)
)
diff --git a/lisp/cedet/srecode/mode.el b/lisp/cedet/srecode/mode.el
index c78f98bfc04..bf1f64e125a 100644
--- a/lisp/cedet/srecode/mode.el
+++ b/lisp/cedet/srecode/mode.el
@@ -89,14 +89,14 @@
])
"---"
'( "Insert ..." :filter srecode-minor-mode-templates-menu )
- `( "Generate ..." :filter srecode-minor-mode-generate-menu )
+ '( "Generate ..." :filter srecode-minor-mode-generate-menu )
"---"
- (semantic-menu-item
- ["Customize..."
- (customize-group "srecode")
- :active t
- :help "Customize SRecode options"
- ])
+ (semantic-menu-item
+ ["Customize..."
+ (customize-group "srecode")
+ :active t
+ :help "Customize SRecode options"
+ ])
(list
"Debugging Tools..."
(semantic-menu-item
@@ -148,10 +148,10 @@
;;;###autoload
(define-minor-mode srecode-minor-mode
"Toggle srecode minor mode.
-With prefix argument ARG, turn on if positive, otherwise off. The
-minor mode can be turned on only if semantic feature is available and
-the current buffer was set up for parsing. Return non-nil if the
-minor mode is enabled.
+
+The minor mode can be turned on only if semantic feature is
+available and the current buffer was set up for parsing. Return
+non-nil if the minor mode is enabled.
\\{srecode-mode-map}"
:keymap srecode-mode-map
@@ -176,8 +176,7 @@ minor mode is enabled.
;;;###autoload
(define-minor-mode global-srecode-minor-mode
- "Toggle global use of srecode minor mode.
-If ARG is positive or nil, enable, if it is negative, disable."
+ "Toggle global use of srecode minor mode."
:global t :group 'srecode
;; Not needed because it's autoloaded instead.
;; :require 'srecode/mode
diff --git a/lisp/cedet/srecode/srt-mode.el b/lisp/cedet/srecode/srt-mode.el
index df97d6e55e5..2ad7ffcdb87 100644
--- a/lisp/cedet/srecode/srt-mode.el
+++ b/lisp/cedet/srecode/srt-mode.el
@@ -494,7 +494,7 @@ section or ? for an ask variable."
(let* ((macroend (match-beginning 0))
(raw (buffer-substring-no-properties
macrostart macroend))
- (STATE (srecode-compile-state "TMP"))
+ (STATE (srecode-compile-state))
(inserter (condition-case nil
(srecode-compile-parse-inserter
raw STATE)
@@ -605,7 +605,6 @@ section or ? for an ask variable."
(setq context-return
(semantic-analyze-context-functionarg
- "context-for-srecode"
:buffer (current-buffer)
:scope scope
:bounds bounds
diff --git a/lisp/cedet/srecode/srt.el b/lisp/cedet/srecode/srt.el
index 0a6c732efda..e6d2bb7c9e0 100644
--- a/lisp/cedet/srecode/srt.el
+++ b/lisp/cedet/srecode/srt.el
@@ -25,7 +25,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
(require 'eieio)
(require 'srecode/dictionary)
(require 'srecode/insert)
diff --git a/lisp/cedet/srecode/table.el b/lisp/cedet/srecode/table.el
index 67e363499f4..3b271f06f71 100644
--- a/lisp/cedet/srecode/table.el
+++ b/lisp/cedet/srecode/table.el
@@ -187,8 +187,8 @@ INIT are the initialization parameters for the new template table."
(new (apply 'srecode-template-table
(file-name-nondirectory file)
:file file
- :filesize (nth 7 attr)
- :filedate (nth 5 attr)
+ :filesize (file-attribute-size attr)
+ :filedate (file-attribute-modification-time attr)
:major-mode mode
init
)))
diff --git a/lisp/char-fold.el b/lisp/char-fold.el
index c1f8c458f7e..e61bc3edc6a 100644
--- a/lisp/char-fold.el
+++ b/lisp/char-fold.el
@@ -170,7 +170,7 @@ from which to start."
;; need to keep them grouped together like this: "\\( \\|[ ...][ ...]\\)".
(while (< i end)
(pcase (aref string i)
- (`?\s (setq spaces (1+ spaces)))
+ (?\s (setq spaces (1+ spaces)))
(c (when (> spaces 0)
(push (char-fold--make-space-string spaces) out)
(setq spaces 0))
@@ -214,7 +214,7 @@ from which to start."
(when (> spaces 0)
(push (char-fold--make-space-string spaces) out))
(let ((regexp (apply #'concat (nreverse out))))
- ;; Limited by `MAX_BUF_SIZE' in `regex.c'.
+ ;; Limited by `MAX_BUF_SIZE' in `regex-emacs.c'.
(if (> (length regexp) 5000)
(regexp-quote string)
regexp))))
diff --git a/lisp/chistory.el b/lisp/chistory.el
index a8a69b8c245..59bdc00c674 100644
--- a/lisp/chistory.el
+++ b/lisp/chistory.el
@@ -125,8 +125,8 @@ The buffer is left in Command History mode."
'command-history-mode-map "24.1")
(defvar command-history-mode-map
(let ((map (make-sparse-keymap)))
- (set-keymap-parent map lisp-mode-shared-map)
- (suppress-keymap map)
+ (set-keymap-parent map (make-composed-keymap lisp-mode-shared-map
+ special-mode-map))
(define-key map "x" 'command-history-repeat)
(define-key map "\n" 'next-line)
(define-key map "\r" 'next-line)
@@ -134,20 +134,23 @@ The buffer is left in Command History mode."
map)
"Keymap for `command-history-mode'.")
-(define-derived-mode command-history-mode fundamental-mode "Command History"
+(define-derived-mode command-history-mode special-mode "Command History"
"Major mode for listing and repeating recent commands.
Keybindings:
\\{command-history-mode-map}"
(lisp-mode-variables nil)
- (set-syntax-table emacs-lisp-mode-syntax-table)
- (setq buffer-read-only t))
+ (set (make-local-variable 'revert-buffer-function) 'command-history-revert)
+ (set-syntax-table emacs-lisp-mode-syntax-table))
(defcustom command-history-hook nil
"If non-nil, its value is called on entry to `command-history-mode'."
:type 'hook
:group 'chistory)
+(defun command-history-revert (_ignore-auto _noconfirm)
+ (list-command-history))
+
(defun command-history-repeat ()
"Repeat the command shown on the current line.
The buffer for that command is the previous current buffer."
diff --git a/lisp/comint.el b/lisp/comint.el
index 56e38e24aca..d21cc1378f7 100644
--- a/lisp/comint.el
+++ b/lisp/comint.el
@@ -78,7 +78,7 @@
;;
;; Not bound by default in comint-mode (some are in shell mode)
;; comint-run Run a program under comint-mode
-;; send-invisible Read a line w/o echo, and send to proc
+;; comint-send-invisible Read a line w/o echo, and send to proc
;; comint-dynamic-complete-filename Complete filename at point.
;; comint-dynamic-list-filename-completions List completions in help buffer.
;; comint-replace-by-expanded-filename Expand and complete filename at point;
@@ -263,6 +263,8 @@ See `comint-preinput-scroll-to-bottom'. This variable is buffer-local."
(const this))
:group 'comint)
+(defvaralias 'comint-scroll-to-bottom-on-output 'comint-move-point-for-output)
+
(defcustom comint-move-point-for-output nil
"Controls whether interpreter output moves point to the end of the output.
If nil, then output never moves point to the output.
@@ -295,8 +297,6 @@ end of the current logical (not visual) line after insertion."
(const :tag "Move to end of line" end-of-line))
:group 'comint)
-(defvaralias 'comint-scroll-to-bottom-on-output 'comint-move-point-for-output)
-
(defcustom comint-scroll-show-maximum-output t
"Controls how to scroll due to interpreter output.
This variable applies when point is at the end of the buffer
@@ -360,14 +360,15 @@ This variable is buffer-local."
"Kerberos" "CVS" "UNIX" " SMB" "LDAP" "PEM" "SUDO"
"[sudo]" "Repeat" "Bad" "Retype")
t)
- " +\\)"
+ ;; Allow for user name to precede password equivalent (Bug#31075).
+ " +.*\\)"
"\\(?:" (regexp-opt password-word-equivalents) "\\|Response\\)"
"\\(?:\\(?:, try\\)? *again\\| (empty for no passphrase)\\| (again)\\)?"
;; "[[:alpha:]]" used to be "for", which fails to match non-English.
- "\\(?: [[:alpha:]]+ .+\\)?[::៖]\\s *\\'")
+ "\\(?: [[:alpha:]]+ .+\\)?[[:blank:]]*[::៖][[:blank:]]*\\'")
"Regexp matching prompts for passwords in the inferior process.
This is used by `comint-watch-for-password-prompt'."
- :version "26.1"
+ :version "27.1"
:type 'regexp
:group 'comint)
@@ -429,9 +430,6 @@ See `comint-send-input'."
:type 'boolean
:group 'comint)
-(define-obsolete-variable-alias 'comint-use-prompt-regexp-instead-of-fields
- 'comint-use-prompt-regexp "22.1")
-
;; Note: If it is decided to purge comint-prompt-regexp from the source
;; entirely, searching for uses of this variable will help to identify
;; places that need attention.
@@ -635,7 +633,7 @@ Input ring history expansion can be achieved with the commands
Input ring expansion is controlled by the variable `comint-input-autoexpand',
and addition is controlled by the variable `comint-input-ignoredups'.
-Commands with no default key bindings include `send-invisible',
+Commands with no default key bindings include `comint-send-invisible',
`completion-at-point', `comint-dynamic-list-filename-completions', and
`comint-magic-space'.
@@ -1434,24 +1432,32 @@ If nil, Isearch operates on the whole comint buffer."
(defun comint-history-isearch-backward ()
"Search for a string backward in input history using Isearch."
(interactive)
- (let ((comint-history-isearch t))
- (isearch-backward nil t)))
+ (setq comint-history-isearch t)
+ (isearch-backward nil t))
(defun comint-history-isearch-backward-regexp ()
"Search for a regular expression backward in input history using Isearch."
(interactive)
- (let ((comint-history-isearch t))
- (isearch-backward-regexp nil t)))
+ (setq comint-history-isearch t)
+ (isearch-backward-regexp nil t))
(defvar-local comint-history-isearch-message-overlay nil)
(defun comint-history-isearch-setup ()
"Set up a comint for using Isearch to search the input history.
Intended to be added to `isearch-mode-hook' in `comint-mode'."
- (when (or (eq comint-history-isearch t)
- (and (eq comint-history-isearch 'dwim)
- ;; Point is at command line.
- (comint-after-pmark-p)))
+ (when (and
+ ;; Prompt is not empty like in Async Shell Command buffers
+ ;; or in finished shell buffers
+ (not (eq (save-excursion
+ (goto-char (comint-line-beginning-position))
+ (forward-line 0)
+ (point))
+ (comint-line-beginning-position)))
+ (or (eq comint-history-isearch t)
+ (and (eq comint-history-isearch 'dwim)
+ ;; Point is at command line.
+ (comint-after-pmark-p))))
(setq isearch-message-prefix-add "history ")
(setq-local isearch-search-fun-function
#'comint-history-isearch-search)
@@ -1472,7 +1478,9 @@ Intended to be added to `isearch-mode-hook' in `comint-mode'."
(setq isearch-message-function nil)
(setq isearch-wrap-function nil)
(setq isearch-push-state-function nil)
- (remove-hook 'isearch-mode-end-hook 'comint-history-isearch-end t))
+ (remove-hook 'isearch-mode-end-hook 'comint-history-isearch-end t)
+ (unless isearch-suspended
+ (custom-reevaluate-setting 'comint-history-isearch)))
(defun comint-goto-input (pos)
"Put input history item of the absolute history position POS."
@@ -1610,8 +1618,8 @@ Go to the history element by the absolute history position HIST-POS."
(defun comint-within-quotes (beg end)
"Return t if the number of quotes between BEG and END is odd.
Quotes are single and double."
- (let ((countsq (comint-how-many-region "\\(^\\|[^\\\\]\\)'" beg end))
- (countdq (comint-how-many-region "\\(^\\|[^\\\\]\\)\"" beg end)))
+ (let ((countsq (comint-how-many-region "\\(^\\|[^\\]\\)'" beg end))
+ (countdq (comint-how-many-region "\\(^\\|[^\\]\\)\"" beg end)))
(or (= (mod countsq 2) 1) (= (mod countdq 2) 1))))
(defun comint-how-many-region (regexp beg end)
@@ -1676,11 +1684,13 @@ characters), and are not considered to be delimiters."
(defun comint-arguments (string nth mth)
"Return from STRING the NTH to MTH arguments.
NTH and/or MTH can be nil, which means the last argument.
-Returned arguments are separated by single spaces.
-We assume whitespace separates arguments, except within quotes
-and except for a space or tab that immediately follows a backslash.
-Also, a run of one or more of a single character
-in `comint-delimiter-argument-list' is a separate argument.
+NTH and MTH can be negative to count from the end; -1 means
+the last argument.
+Returned arguments are separated by single spaces. We assume
+whitespace separates arguments, except within quotes and except
+for a space or tab that immediately follows a backslash. Also, a
+run of one or more of a single character in
+`comint-delimiter-argument-list' is a separate argument.
Argument 0 is the command name."
;; The first line handles ordinary characters and backslash-sequences
;; (except with w32 msdos-like shells, where backslashes are valid).
@@ -1702,7 +1712,7 @@ Argument 0 is the command name."
(count 0)
beg str quotes)
;; Build a list of all the args until we have as many as we want.
- (while (and (or (null mth) (<= count mth))
+ (while (and (or (null mth) (< mth 0) (<= count mth))
(string-match argpart string pos))
;; Apply the `literal' text property to backslash-escaped
;; characters, so that `comint-delim-arg' won't break them up.
@@ -1729,8 +1739,14 @@ Argument 0 is the command name."
args (if quotes (cons str args)
(nconc (comint-delim-arg str) args))))
(setq count (length args))
- (let ((n (or nth (1- count)))
- (m (if mth (1- (- count mth)) 0)))
+ (let ((n (cond
+ ((null nth) (1- count))
+ ((>= nth 0) nth)
+ (t (+ count nth))))
+ (m (cond
+ ((null mth) 0)
+ ((>= mth 0) (1- (- count mth)))
+ (t (1- (- mth))))))
(mapconcat
(function (lambda (a) a)) (nthcdr n (nreverse (nthcdr m args))) " "))))
@@ -2056,20 +2072,6 @@ Make backspaces delete the previous character."
(goto-char (process-mark process))
(set-marker comint-last-output-start (point))
- ;; Try to skip repeated prompts, which can occur as a result of
- ;; commands sent without inserting them in the buffer.
- (let ((bol (save-excursion (forward-line 0) (point)))) ;No fields.
- (when (and (not (bolp))
- (looking-back comint-prompt-regexp bol))
- (let* ((prompt (buffer-substring bol (point)))
- (prompt-re (concat "\\`" (regexp-quote prompt))))
- (while (string-match prompt-re string)
- (setq string (substring string (match-end 0)))))))
- (while (string-match (concat "\\(^" comint-prompt-regexp
- "\\)\\1+")
- string)
- (setq string (replace-match "\\1" nil nil string)))
-
;; insert-before-markers is a bad thing. XXX
;; Luckily we don't have to use it any more, we use
;; window-point-insertion-type instead.
@@ -2232,7 +2234,7 @@ This function could be on `comint-output-filter-functions' or bound to a key."
(error nil))
(while (re-search-forward "\r+$" pmark t)
(replace-match "" t t)))))
-(defalias 'shell-strip-ctrl-m 'comint-strip-ctrl-m)
+(define-obsolete-function-alias 'shell-strip-ctrl-m #'comint-strip-ctrl-m "27.1")
(defun comint-show-maximum-output ()
"Put the end of the buffer at the bottom of the window."
@@ -2281,8 +2283,10 @@ If this takes us past the end of the current line, don't skip at all."
(defun comint-after-pmark-p ()
"Return t if point is after the process output marker."
- (let ((pmark (process-mark (get-buffer-process (current-buffer)))))
- (<= (marker-position pmark) (point))))
+ (let ((process (get-buffer-process (current-buffer))))
+ (when process
+ (let ((pmark (process-mark process)))
+ (<= (marker-position pmark) (point))))))
(defun comint-simple-send (proc string)
"Default function for sending to PROC input STRING.
@@ -2340,9 +2344,9 @@ a buffer local variable."
;; These three functions are for entering text you don't want echoed or
;; saved -- typically passwords to ftp, telnet, or somesuch.
-;; Just enter m-x send-invisible and type in your line.
+;; Just enter m-x comint-send-invisible and type in your line.
-(defun send-invisible (&optional prompt)
+(defun comint-send-invisible (&optional prompt)
"Read a string without echoing.
Then send it to the process running in the current buffer.
The string is sent using `comint-input-sender'.
@@ -2365,18 +2369,19 @@ Security bug: your string can still be temporarily recovered with
(message "Warning: text will be echoed")))
(error "Buffer %s has no process" (current-buffer)))))
+(define-obsolete-function-alias 'send-invisible #'comint-send-invisible "27.1")
+
(defun comint-watch-for-password-prompt (string)
"Prompt in the minibuffer for password and send without echoing.
-This function uses `send-invisible' to read and send a password to the buffer's
-process if STRING contains a password prompt defined by
-`comint-password-prompt-regexp'.
+Looks for a match to `comint-password-prompt-regexp' in order
+to detect the need to (prompt and) send a password.
This function could be in the list `comint-output-filter-functions'."
(when (let ((case-fold-search t))
(string-match comint-password-prompt-regexp string))
(when (string-match "^[ \n\r\t\v\f\b\a]+" string)
(setq string (replace-match "" t t string)))
- (send-invisible string)))
+ (comint-send-invisible string)))
;; Low-level process communication
@@ -2517,13 +2522,16 @@ Useful if you accidentally suspend the top-level process."
(defun comint-skip-input ()
"Skip all pending input, from last stuff output by interpreter to point.
-This means mark it as if it had been sent as input, without sending it."
+This means mark it as if it had been sent as input, without
+sending it. The command keys used to trigger the command that
+called this function are inserted into the buffer."
(let ((comint-input-sender 'ignore)
(comint-input-filter-functions nil))
(comint-send-input t t))
(end-of-line)
(let ((pos (point))
- (marker (process-mark (get-buffer-process (current-buffer)))))
+ (marker (process-mark (get-buffer-process (current-buffer))))
+ (inhibit-read-only t))
(insert " " (key-description (this-command-keys)))
(if (= marker pos)
(set-marker marker (point)))))
@@ -2643,8 +2651,17 @@ text matching `comint-prompt-regexp'."
(defvar-local comint-insert-previous-argument-last-start-pos nil)
(defvar-local comint-insert-previous-argument-last-index nil)
-;; Needs fixing:
-;; make comint-arguments understand negative indices as bash does
+(defcustom comint-insert-previous-argument-from-end nil
+ "If non-nil, `comint-insert-previous-argument' counts args from the end.
+If this variable is nil, the default, `comint-insert-previous-argument'
+counts the arguments from the beginning; if non-nil, it counts from
+the end instead. This allows to emulate the behavior of `ESC-NUM ESC-.'
+in both Bash and zsh: in Bash, `number' counts from the
+beginning (variable is nil), while in zsh, it counts from the end."
+ :type 'boolean
+ :group 'comint
+ :version "27.1")
+
(defun comint-insert-previous-argument (index)
"Insert the INDEXth argument from the previous Comint command-line at point.
Spaces are added at beginning and/or end of the inserted string if
@@ -2652,8 +2669,9 @@ necessary to ensure that it's separated from adjacent arguments.
Interactively, if no prefix argument is given, the last argument is inserted.
Repeated interactive invocations will cycle through the same argument
from progressively earlier commands (using the value of INDEX specified
-with the first command).
-This command is like `M-.' in bash."
+with the first command). Values of INDEX < 0 count from the end, so
+INDEX = -1 is the last argument. This command is like `M-.' in
+Bash and zsh."
(interactive "P")
(unless (null index)
(setq index (prefix-numeric-value index)))
@@ -2663,6 +2681,9 @@ This command is like `M-.' in bash."
(setq index comint-insert-previous-argument-last-index))
(t
;; This is a non-repeat invocation, so initialize state.
+ (when (and index
+ comint-insert-previous-argument-from-end)
+ (setq index (- index)))
(setq comint-input-ring-index nil)
(setq comint-insert-previous-argument-last-index index)
(when (null comint-insert-previous-argument-last-start-pos)
@@ -2678,9 +2699,6 @@ This command is like `M-.' in bash."
(set-marker comint-insert-previous-argument-last-start-pos (point))
;; Insert the argument.
(let ((input-string (comint-previous-input-string 0)))
- (when (string-match "[ \t\n]*&" input-string)
- ;; strip terminating '&'
- (setq input-string (substring input-string 0 (match-beginning 0))))
(insert (comint-arguments input-string index index)))
;; Make next invocation return arg from previous input
(setq comint-input-ring-index (1+ (or comint-input-ring-index 0)))
@@ -3060,7 +3078,7 @@ interpreter (e.g., the percent notation of cmd.exe on Windows)."
(let (env-var-name
env-var-val)
(save-match-data
- (while (string-match "%\\([^\\\\/]*\\)%" name)
+ (while (string-match "%\\([^\\/]*\\)%" name)
(setq env-var-name (match-string 1 name))
(setq env-var-val (or (getenv env-var-name) ""))
(setq name (replace-match env-var-val t t name))))))
diff --git a/lisp/completion.el b/lisp/completion.el
index 7248d0d89fe..89285c74d41 100644
--- a/lisp/completion.el
+++ b/lisp/completion.el
@@ -409,10 +409,7 @@ Used to decide whether to save completions.")
(defun cmpl-coerce-string-case (string case-type)
(cond ((eq case-type :down) (downcase string))
((eq case-type :up) (upcase string))
- ((eq case-type :capitalized)
- (setq string (downcase string))
- (aset string 0 (logand ?\337 (aref string 0)))
- string)
+ ((eq case-type :capitalized) (capitalize string))
(t string)))
(defun cmpl-merge-string-cases (string-to-coerce given-string)
@@ -435,7 +432,7 @@ Used to decide whether to save completions.")
(defun cmpl-hours-since-origin ()
- (floor (float-time) 3600))
+ (floor (encode-time nil 'integer) 3600))
;;---------------------------------------------------------------------------
;; "Symbol" parsing functions
@@ -518,6 +515,9 @@ Used to decide whether to save completions.")
(modify-syntax-entry char "w" table)))
table))
+;; Old name, non-namespace-clean.
+(defvaralias 'cmpl-syntax-table 'completion-syntax-table)
+
(defvar completion-syntax-table completion-standard-syntax-table
"This variable holds the current completion syntax table.")
(make-variable-buffer-local 'completion-syntax-table)
@@ -2225,7 +2225,10 @@ TYPE is the type of the wrapper to be added. Can be :before or :under."
(modify-syntax-entry char "_" table))
table))
+(declare-function cl-set-difference "cl-seq" (cl-list1 cl-list2 &rest cl-keys))
+
(defun completion-lisp-mode-hook ()
+ (require 'cl-lib)
(setq completion-syntax-table completion-lisp-syntax-table)
;; Lisp Mode diffs
(setq-local completion-separator-chars
@@ -2269,10 +2272,7 @@ TYPE is the type of the wrapper to be added. Can be :before or :under."
;;;###autoload
(define-minor-mode dynamic-completion-mode
- "Toggle dynamic word-completion on or off.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil."
+ "Toggle dynamic word-completion on or off."
:global t
:group 'completion
;; This is always good, not specific to dynamic-completion-mode.
@@ -2357,8 +2357,7 @@ if ARG is omitted or nil."
(completion-def-wrapper 'delete-backward-char :backward)
(completion-def-wrapper 'delete-backward-char-untabify :backward)
-;; Old names, non-namespace-clean.
-(defvaralias 'cmpl-syntax-table 'completion-syntax-table)
+;; Old name, non-namespace-clean.
(defalias 'initialize-completions 'completion-initialize)
(provide 'completion)
diff --git a/lisp/composite.el b/lisp/composite.el
index e50e5d381ec..d2df3d1e922 100644
--- a/lisp/composite.el
+++ b/lisp/composite.el
@@ -119,7 +119,7 @@ RULE is a cons of global and new reference point symbols
(setq nref (cdr (assq nref reference-point-alist))))
(or (and (>= gref 0) (< gref 12) (>= nref 0) (< nref 12))
(error "Invalid composition rule: %S" rule))
- (logior (lsh xoff 16) (lsh yoff 8) (+ (* gref 12) nref)))
+ (logior (ash xoff 16) (ash yoff 8) (+ (* gref 12) nref)))
(error "Invalid composition rule: %S" rule))))
;; Decode encoded composition rule RULE-CODE. The value is a cons of
@@ -130,8 +130,8 @@ RULE is a cons of global and new reference point symbols
(defun decode-composition-rule (rule-code)
(or (and (natnump rule-code) (< rule-code #x1000000))
(error "Invalid encoded composition rule: %S" rule-code))
- (let ((xoff (lsh rule-code -16))
- (yoff (logand (lsh rule-code -8) #xFF))
+ (let ((xoff (ash rule-code -16))
+ (yoff (logand (ash rule-code -8) #xFF))
gref nref)
(setq rule-code (logand rule-code #xFF)
gref (car (rassq (/ rule-code 12) reference-point-alist))
@@ -829,9 +829,6 @@ This function is the default value of `auto-composition-function' (which see)."
;;;###autoload
(define-minor-mode auto-composition-mode
"Toggle Auto Composition mode.
-With a prefix argument ARG, enable Auto Composition mode if ARG
-is positive, and disable it otherwise. If called from Lisp,
-enable the mode if ARG is omitted or nil.
When Auto Composition mode is enabled, text characters are
automatically composed by functions registered in
@@ -847,9 +844,6 @@ Auto Composition mode in all buffers (this is the default)."
;;;###autoload
(define-minor-mode global-auto-composition-mode
"Toggle Auto Composition mode in all buffers.
-With a prefix argument ARG, enable it if ARG is positive, and
-disable it otherwise. If called from Lisp, enable it if ARG is
-omitted or nil.
For more information on Auto Composition mode, see
`auto-composition-mode' ."
diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el
index 31c23a5c4b8..f87b6b621c1 100644
--- a/lisp/cus-edit.el
+++ b/lisp/cus-edit.el
@@ -986,7 +986,7 @@ If given a prefix (or a COMMENT argument), also prompt for a comment."
current-prefix-arg))
(custom-load-symbol variable)
(custom-push-theme 'theme-value variable 'user 'set (custom-quote value))
- (funcall (or (get variable 'custom-set) 'set-default) variable value)
+ (funcall (or (get variable 'custom-set) #'set-default) variable value)
(put variable 'customized-value (list (custom-quote value)))
(cond ((string= comment "")
(put variable 'variable-comment nil)
@@ -2431,8 +2431,20 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"."
;;; The `custom-variable' Widget.
+(defface custom-variable-obsolete
+ '((((class color) (background dark))
+ :foreground "light blue")
+ (((min-colors 88) (class color) (background light))
+ :foreground "blue1")
+ (((class color) (background light))
+ :foreground "blue")
+ (t :slant italic))
+ "Face used for obsolete variables."
+ :version "27.1"
+ :group 'custom-faces)
+
(defface custom-variable-tag
- `((((class color) (background dark))
+ '((((class color) (background dark))
:foreground "light blue" :weight bold)
(((min-colors 88) (class color) (background light))
:foreground "blue1" :weight bold)
@@ -2456,8 +2468,9 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"."
(defun custom-variable-documentation (variable)
"Return documentation of VARIABLE for use in Custom buffer.
Normally just return the docstring. But if VARIABLE automatically
-becomes buffer local when set, append a message to that effect."
- (format "%s%s" (documentation-property variable 'variable-documentation t)
+becomes buffer local when set, append a message to that effect.
+Also append any obsolescence information."
+ (format "%s%s%s" (documentation-property variable 'variable-documentation t)
(if (and (local-variable-if-set-p variable)
(or (not (local-variable-p variable))
(with-temp-buffer
@@ -2465,7 +2478,21 @@ becomes buffer local when set, append a message to that effect."
"\n
This variable automatically becomes buffer-local when set outside Custom.
However, setting it through Custom sets the default value."
- "")))
+ "")
+ ;; This duplicates some code from describe-variable.
+ ;; TODO extract to separate utility function?
+ (let* ((obsolete (get variable 'byte-obsolete-variable))
+ (use (car obsolete)))
+ (if obsolete
+ (concat "\n
+This variable is obsolete"
+ (if (nth 2 obsolete)
+ (format " since %s" (nth 2 obsolete)))
+ (cond ((stringp use) (concat ";\n" use))
+ (use (format-message ";\nuse `%s' instead."
+ (car obsolete)))
+ (t ".")))
+ ""))))
(define-widget 'custom-variable 'custom
"A widget for displaying a Custom variable.
@@ -2549,7 +2576,8 @@ try matching its doc string against `custom-guess-doc-alist'."
(state (or (widget-get widget :custom-state)
(if (memq (custom-variable-state symbol value)
(widget-get widget :hidden-states))
- 'hidden))))
+ 'hidden)))
+ (obsolete (get symbol 'byte-obsolete-variable)))
;; If we don't know the state, see if we need to edit it in lisp form.
(unless state
@@ -2581,7 +2609,9 @@ try matching its doc string against `custom-guess-doc-alist'."
(push (widget-create-child-and-convert
widget 'item
:format "%{%t%} "
- :sample-face 'custom-variable-tag
+ :sample-face (if obsolete
+ 'custom-variable-obsolete
+ 'custom-variable-tag)
:tag tag
:parent widget)
buttons))
@@ -2639,7 +2669,9 @@ try matching its doc string against `custom-guess-doc-alist'."
:help-echo "Change value of this option."
:mouse-down-action 'custom-tag-mouse-down-action
:button-face 'custom-variable-button
- :sample-face 'custom-variable-tag
+ :sample-face (if obsolete
+ 'custom-variable-obsolete
+ 'custom-variable-tag)
tag)
buttons)
(push (widget-create-child-and-convert
@@ -3322,6 +3354,23 @@ Only match frames that support the specified face attributes.")
:group 'custom-buffer
:version "20.3")
+(defun custom-face-documentation (face)
+ "Return documentation of FACE for use in Custom buffer."
+ (format "%s%s" (face-documentation face)
+ ;; This duplicates some code from describe-face.
+ ;; TODO extract to separate utility function?
+ ;; In practice this does not get used, because M-x customize-face
+ ;; follows aliases.
+ (let ((alias (get face 'face-alias))
+ (obsolete (get face 'obsolete-face)))
+ (if (and alias obsolete)
+ (format "\nThis face is obsolete%s; use `%s' instead.\n"
+ (if (stringp obsolete)
+ (format " since %s" obsolete)
+ "")
+ alias)
+ ""))))
+
(define-widget 'custom-face 'custom
"Widget for customizing a face.
The following properties have special meanings for this widget:
@@ -3345,7 +3394,7 @@ The following properties have special meanings for this widget:
of the widget, instead of the current face spec."
:sample-face 'custom-face-tag
:help-echo "Set or reset this face."
- :documentation-property #'face-doc-string
+ :documentation-property #'custom-face-documentation
:value-create 'custom-face-value-create
:action 'custom-face-action
:custom-category 'face
@@ -3741,10 +3790,6 @@ Optional EVENT is the location for the menu."
(custom-save-all)
(custom-face-state-set-and-redraw widget))
-;; For backward compatibility.
-(define-obsolete-function-alias 'custom-face-save-command 'custom-face-save
- "22.1")
-
(defun custom-face-reset-saved (widget)
"Restore WIDGET to the face's default attributes.
If there is a saved face, restore it; otherwise reset to the
@@ -3875,7 +3920,7 @@ restoring it to the state of a face that has never been customized."
(defun custom-hook-convert-widget (widget)
;; Handle `:options'.
(let* ((options (widget-get widget :options))
- (other `(editable-list :inline t
+ (other '(editable-list :inline t
:entry-format "%i %d%v"
(function :format " %v")))
(args (if options
@@ -4100,7 +4145,7 @@ If GROUPS-ONLY is non-nil, return only those members that are groups."
;; Update buttons.
(widget-put widget :buttons buttons)
;; Insert documentation.
- (if (and (eq custom-buffer-style 'links) (> level 1))
+ (when (eq custom-buffer-style 'links)
(widget-put widget :documentation-indent
custom-group-doc-align-col))
(widget-add-documentation-string-button
@@ -4176,19 +4221,14 @@ If GROUPS-ONLY is non-nil, return only those members that are groups."
custom-buffer-order-groups))
(prefixes (widget-get widget :custom-prefixes))
(custom-prefix-list (custom-prefix-add symbol prefixes))
- (len (length members))
- (count 0)
- (reporter (make-progress-reporter
- "Creating group entries..." 0 len))
(have-subtitle (and (not (eq symbol 'emacs))
(eq custom-buffer-order-groups 'last)))
prev-type
children)
- (dolist (entry members)
+ (dolist-with-progress-reporter (entry members) "Creating group entries..."
(unless (eq prev-type 'custom-group)
(widget-insert "\n"))
- (progress-reporter-update reporter (setq count (1+ count)))
(let ((sym (nth 0 entry))
(type (nth 1 entry)))
(when (and have-subtitle (eq type 'custom-group))
@@ -4210,8 +4250,7 @@ If GROUPS-ONLY is non-nil, return only those members that are groups."
(setq children (nreverse children))
(mapc 'custom-magic-reset children)
(widget-put widget :children children)
- (custom-group-state-update widget)
- (progress-reporter-done reporter))
+ (custom-group-state-update widget))
;; End line
(let ((p (1+ (point))))
(insert "\n\n")
diff --git a/lisp/cus-face.el b/lisp/cus-face.el
index 0662e9ca9fa..0ee6a8dcc8f 100644
--- a/lisp/cus-face.el
+++ b/lisp/cus-face.el
@@ -342,7 +342,7 @@ argument list."
;; is aliased to.
(if (get face 'face-alias)
(setq face (get face 'face-alias)))
- (if custom--inhibit-theme-enable
+ (if (not (custom--should-apply-setting theme))
;; Just update theme settings.
(custom-push-theme 'theme-face face theme 'set spec)
;; Update theme settings and set the face spec.
diff --git a/lisp/cus-start.el b/lisp/cus-start.el
index 0fcfbed9fdb..baa05d0a89a 100644
--- a/lisp/cus-start.el
+++ b/lisp/cus-start.el
@@ -314,7 +314,13 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
(other :tag "hidden by keypress" 1))
"22.1")
(make-pointer-invisible mouse boolean "23.2")
- (menu-bar-mode frames boolean nil
+ (resize-mini-frames
+ frames (choice
+ (const :tag "Never" nil)
+ (const :tag "Fit frame to buffer" t)
+ (function :tag "User-defined function"))
+ "27.1")
+ (menu-bar-mode frames boolean nil
;; FIXME?
;; :initialize custom-initialize-default
:set custom-set-minor-mode)
@@ -345,6 +351,7 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
;; keyboard.c
(meta-prefix-char keyboard character)
(auto-save-interval auto-save integer)
+ (auto-save-no-message auto-save boolean "27.1")
(auto-save-timeout auto-save (choice (const :tag "off" nil)
(integer :format "%v")))
(echo-keystrokes minibuffer number)
@@ -414,6 +421,10 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
;; msdos.c
(dos-unsupported-char-glyph display integer)
;; nsterm.m
+ ;;
+ ;; FIXME: Why does ⌃ use nil instead of none? Also the
+ ;; description is confusing; setting it to nil disables ⌃
+ ;; entirely.
(ns-control-modifier
ns
(choice (const :tag "No modifier" nil)
@@ -430,13 +441,13 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
(const super)) "24.1")
(ns-command-modifier
ns
- (choice (const :tag "No modifier" nil)
+ (choice (const :tag "No modifier (work as layout switch)" none)
(const control) (const meta)
(const alt) (const hyper)
(const super)) "23.1")
(ns-right-command-modifier
ns
- (choice (const :tag "No modifier (work as command)" none)
+ (choice (const :tag "No modifier (work as layout switch)" none)
(const :tag "Use the value of ns-command-modifier"
left)
(const control) (const meta)
@@ -542,7 +553,12 @@ since it could result in memory overflow and make Emacs crash."
(const :tag "Respect `truncate-lines'" nil)
(other :tag "Truncate if not full-width" t))
"23.1")
- (make-cursor-line-fully-visible windows boolean)
+ (make-cursor-line-fully-visible
+ windows
+ (choice
+ (const :tag "Make cursor always fully visible" t)
+ (const :tag "Allow cursor to be partially-visible" nil)
+ (function :tag "User-defined function")))
(mode-line-in-non-selected-windows mode-line boolean "22.1")
(line-number-display-limit display
(choice integer
@@ -675,7 +691,7 @@ since it could result in memory overflow and make Emacs crash."
((string-match "selection" (symbol-name symbol))
(fboundp 'x-selection-exists-p))
((string-match "fringe" (symbol-name symbol))
- (fboundp 'define-fringe-bitmap))
+ (boundp 'fringe-bitmaps))
((string-match "\\`imagemagick" (symbol-name symbol))
(fboundp 'imagemagick-types))
((equal "font-use-system-font" (symbol-name symbol))
@@ -708,17 +724,19 @@ since it could result in memory overflow and make Emacs crash."
(put symbol 'custom-set (cadr prop)))
;; This is used by describe-variable.
(if version (put symbol 'custom-version version))
- ;; Note this is the _only_ initialize property we handle.
- (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,
- ;; auto-save-file-name-transforms will appear in M-x customize-rogue.
- (add-to-list 'custom-delayed-init-variables symbol 'append))
+ ;; 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)
+ ;; 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,
+ ;; auto-save-file-name-transforms will appear in customize-rogue.
+ (add-to-list 'custom-delayed-init-variables symbol 'append)))
;; If this is NOT while dumping Emacs, set up the rest of the
;; customization info. This is the stuff that is not needed
;; until someone does M-x customize etc.
- (unless purify-flag
+ (unless dump-mode
;; Add it to the right group(s).
(if (listp group)
(dolist (g group)
@@ -740,7 +758,7 @@ since it could result in memory overflow and make Emacs crash."
;; Record cus-start as loaded if we have set up all the info that we can.
;; Don't record it as loaded if we have only set up the standard values
;; and safe/risky properties.
-(unless purify-flag
+(unless dump-mode
(provide 'cus-start))
;;; cus-start.el ends here
diff --git a/lisp/cus-theme.el b/lisp/cus-theme.el
index c195f4afe26..bc9d1d4f7d6 100644
--- a/lisp/cus-theme.el
+++ b/lisp/cus-theme.el
@@ -1,4 +1,4 @@
-;;; cus-theme.el -- custom theme creation user interface
+;;; cus-theme.el -- custom theme creation user interface -*- lexical-binding: t -*-
;;
;; Copyright (C) 2001-2019 Free Software Foundation, Inc.
;;
@@ -47,7 +47,7 @@
Do not call this mode function yourself. It is meant for internal use."
(use-local-map custom-new-theme-mode-map)
(custom--initialize-widget-variables)
- (set (make-local-variable 'revert-buffer-function) 'custom-theme-revert))
+ (setq-local revert-buffer-function #'custom-theme-revert))
(put 'custom-new-theme-mode 'mode-class 'special)
(defvar custom-theme-name nil)
@@ -93,15 +93,14 @@ named *Custom Theme*."
(switch-to-buffer (get-buffer-create (or buffer "*Custom Theme*")))
(let ((inhibit-read-only t))
(erase-buffer)
- (dolist (ov (overlays-in (point-min) (point-max)))
- (delete-overlay ov)))
+ (delete-all-overlays))
(custom-new-theme-mode)
(make-local-variable 'custom-theme-name)
- (set (make-local-variable 'custom-theme--save-name) theme)
- (set (make-local-variable 'custom-theme-faces) nil)
- (set (make-local-variable 'custom-theme-variables) nil)
- (set (make-local-variable 'custom-theme-description) "")
- (set (make-local-variable 'custom-theme--migrate-settings) nil)
+ (setq-local custom-theme--save-name theme)
+ (setq-local custom-theme-faces nil)
+ (setq-local custom-theme-variables nil)
+ (setq-local custom-theme-description "")
+ (setq-local custom-theme--migrate-settings nil)
(make-local-variable 'custom-theme-insert-face-marker)
(make-local-variable 'custom-theme-insert-variable-marker)
(make-local-variable 'custom-theme--listed-faces)
@@ -118,13 +117,13 @@ remove them from your saved Custom file.\n\n"))
:tag " Visit Theme "
:help-echo "Insert the settings of a pre-defined theme."
:action (lambda (_widget &optional _event)
- (call-interactively 'custom-theme-visit-theme)))
+ (call-interactively #'custom-theme-visit-theme)))
(widget-insert " ")
(widget-create 'push-button
:tag " Merge Theme "
:help-echo "Merge in the settings of a pre-defined theme."
:action (lambda (_widget &optional _event)
- (call-interactively 'custom-theme-merge-theme)))
+ (call-interactively #'custom-theme-merge-theme)))
(widget-insert " ")
(widget-create 'push-button
:tag " Revert "
@@ -142,7 +141,7 @@ remove them from your saved Custom file.\n\n"))
(widget-create 'text
:value (format-time-string "Created %Y-%m-%d.")))
(widget-create 'push-button
- :notify (function custom-theme-write)
+ :notify #'custom-theme-write
" Save Theme ")
(when (eq theme 'user)
(setq custom-theme--migrate-settings t)
@@ -188,7 +187,7 @@ remove them from your saved Custom file.\n\n"))
:mouse-face 'highlight
:pressed-face 'highlight
:action (lambda (_widget &optional _event)
- (call-interactively 'custom-theme-add-face)))
+ (call-interactively #'custom-theme-add-face)))
;; If THEME is non-nil, insert all of that theme's variables.
(widget-insert "\n\n Theme variables:\n ")
@@ -207,7 +206,7 @@ remove them from your saved Custom file.\n\n"))
:mouse-face 'highlight
:pressed-face 'highlight
:action (lambda (_widget &optional _event)
- (call-interactively 'custom-theme-add-variable)))
+ (call-interactively #'custom-theme-add-variable)))
(widget-insert ?\n)
(widget-setup)
(goto-char (point-min))
@@ -254,7 +253,7 @@ interactively, this defaults to the current value of VAR."
:tag (custom-unlispify-tag-name symbol)
:value symbol
:shown-value (list val)
- :notify 'ignore
+ :notify #'ignore
:custom-level 0
:custom-state 'hidden
:custom-style 'simple))
@@ -313,7 +312,7 @@ SPEC, if non-nil, should be a face spec to which to set the widget."
(interactive
(list
(intern (completing-read "Find custom theme: "
- (mapcar 'symbol-name
+ (mapcar #'symbol-name
(custom-available-themes))))))
(unless (custom-theme-name-valid-p theme)
(error "No valid theme named `%s'" theme))
@@ -328,7 +327,7 @@ SPEC, if non-nil, should be a face spec to which to set the widget."
(interactive
(list
(intern (completing-read "Merge custom theme: "
- (mapcar 'symbol-name
+ (mapcar #'symbol-name
(custom-available-themes))))))
(unless (eq theme 'user)
(unless (custom-theme-name-valid-p theme)
@@ -343,8 +342,8 @@ SPEC, if non-nil, should be a face spec to which to set the widget."
(memq name '(custom-enabled-themes
custom-safe-themes)))
(funcall (if option
- 'custom-theme-add-variable
- 'custom-theme-add-face)
+ #'custom-theme-add-variable
+ #'custom-theme-add-face)
name value)))))
theme)
@@ -475,7 +474,7 @@ It includes all faces in list FACES."
(interactive
(list
(intern (completing-read "Describe custom theme: "
- (mapcar 'symbol-name
+ (mapcar #'symbol-name
(custom-available-themes))))))
(unless (custom-theme-name-valid-p theme)
(error "Invalid theme name `%s'" theme))
@@ -513,8 +512,7 @@ It includes all faces in list FACES."
(condition-case nil
(read (current-buffer))
(end-of-file nil)))))
- (and sexp (listp sexp)
- (eq (car sexp) 'deftheme)
+ (and (eq (car-safe sexp) 'deftheme)
(setq doc (nth 2 sexp)))))))
(princ "\n\nDocumentation:\n")
(princ (if (stringp doc)
@@ -552,10 +550,10 @@ It includes all faces in list FACES."
Do not call this mode function yourself. It is meant for internal use."
(use-local-map custom-theme-choose-mode-map)
(custom--initialize-widget-variables)
- (set (make-local-variable 'revert-buffer-function)
- (lambda (_ignore-auto noconfirm)
- (when (or noconfirm (y-or-n-p "Discard current choices? "))
- (customize-themes (current-buffer))))))
+ (setq-local revert-buffer-function
+ (lambda (_ignore-auto noconfirm)
+ (when (or noconfirm (y-or-n-p "Discard current choices? "))
+ (customize-themes (current-buffer))))))
(put 'custom-theme-choose-mode 'mode-class 'special)
;;;###autoload
@@ -568,7 +566,7 @@ omitted, a buffer named *Custom Themes* is used."
(let ((inhibit-read-only t))
(erase-buffer))
(custom-theme-choose-mode)
- (set (make-local-variable 'custom--listed-themes) nil)
+ (setq-local custom--listed-themes nil)
(make-local-variable 'custom-theme-allow-multiple-selections)
(and (null custom-theme-allow-multiple-selections)
(> (length custom-enabled-themes) 1)
@@ -616,11 +614,11 @@ Theme files are named *-theme.el in `"))
(widget-create 'push-button
:tag " Save Theme Settings "
:help-echo "Save the selected themes for future sessions."
- :action 'custom-theme-save)
+ :action #'custom-theme-save)
(widget-insert ?\n)
(widget-create 'checkbox
:value custom-theme-allow-multiple-selections
- :action 'custom-theme-selections-toggle)
+ :action #'custom-theme-selections-toggle)
(widget-insert (propertize " Select more than one theme at a time"
'face '(variable-pitch (:height 0.9))))
@@ -632,13 +630,13 @@ Theme files are named *-theme.el in `"))
:value (custom-theme-enabled-p theme)
:theme-name theme
:help-echo help-echo
- :action 'custom-theme-checkbox-toggle))
+ :action #'custom-theme-checkbox-toggle))
(push (cons theme widget) custom--listed-themes)
(widget-create-child-and-convert widget 'push-button
:button-face-get 'ignore
:mouse-face-get 'ignore
:value (format " %s" theme)
- :action 'widget-parent-action
+ :action #'widget-parent-action
:help-echo help-echo)
(widget-insert " -- "
(propertize (custom-theme-summary theme)
@@ -662,8 +660,7 @@ Theme files are named *-theme.el in `"))
(condition-case nil
(read (current-buffer))
(end-of-file nil)))))
- (and sexp (listp sexp)
- (eq (car sexp) 'deftheme)
+ (and (eq (car-safe sexp) 'deftheme)
(setq doc (nth 2 sexp))))))))
(cond ((null doc)
"(no documentation available)")
diff --git a/lisp/custom.el b/lisp/custom.el
index f0125742d1f..53b8045f058 100644
--- a/lisp/custom.el
+++ b/lisp/custom.el
@@ -1,4 +1,4 @@
-;;; custom.el --- tools for declaring and initializing options
+;;; custom.el --- tools for declaring and initializing options -*- lexical-binding: t -*-
;;
;; Copyright (C) 1996-1997, 1999, 2001-2019 Free Software Foundation,
;; Inc.
@@ -150,7 +150,7 @@ set to nil, as the value is no longer rogue."
(put symbol 'force-value nil))
(if (keywordp doc)
(error "Doc string is missing"))
- (let ((initialize 'custom-initialize-reset)
+ (let ((initialize #'custom-initialize-reset)
(requests nil))
(unless (memq :group args)
(custom-add-to-group (custom-current-group) symbol 'custom-variable))
@@ -426,7 +426,7 @@ information."
(defun custom-declare-group (symbol members doc &rest args)
"Like `defgroup', but SYMBOL is evaluated as a normal argument."
(while members
- (apply 'custom-add-to-group symbol (car members))
+ (apply #'custom-add-to-group symbol (car members))
(setq members (cdr members)))
(when doc
;; This text doesn't get into DOC.
@@ -618,11 +618,8 @@ VARIABLE is a symbol that names a user option.
The result is that the change is treated as having been made through Custom."
(put variable 'customized-value (list (custom-quote (eval variable)))))
-
-;;; Custom Themes
-
-;;; Loading files needed to customize a symbol.
-;;; This is in custom.el because menu-bar.el needs it for toggle cmds.
+;; Loading files needed to customize a symbol.
+;; This is in custom.el because menu-bar.el needs it for toggle cmds.
(defvar custom-load-recursion nil
"Hack to avoid recursive dependencies.")
@@ -633,14 +630,12 @@ The result is that the change is treated as having been made through Custom."
(let ((custom-load-recursion t))
;; Load these files if not already done,
;; to make sure we know all the dependencies of SYMBOL.
- (condition-case nil
- (require 'cus-load)
- (error nil))
- (condition-case nil
- (require 'cus-start)
- (error nil))
+ (ignore-errors
+ (require 'cus-load))
+ (ignore-errors
+ (require 'cus-start))
(dolist (load (get symbol 'custom-loads))
- (cond ((symbolp load) (condition-case nil (require load) (error nil)))
+ (cond ((symbolp load) (ignore-errors (require load)))
;; This is subsumed by the test below, but it's much faster.
((assoc load load-history))
;; This was just (assoc (locate-library load) load-history)
@@ -658,7 +653,7 @@ The result is that the change is treated as having been made through Custom."
;; We are still loading it when we call this,
;; and it is not in load-history yet.
((equal load "cus-edit"))
- (t (condition-case nil (load load) (error nil))))))))
+ (t (ignore-errors (load load))))))))
(defvar custom-local-buffer nil
"Non-nil, in a Customization buffer, means customize a specific buffer.
@@ -691,16 +686,12 @@ this sets the local binding in that buffer instead."
(defun custom-quote (sexp)
"Quote SEXP if it is not self quoting."
- (if (or (memq sexp '(t nil))
- (keywordp sexp)
- (and (listp sexp)
- (memq (car sexp) '(lambda)))
- (stringp sexp)
- (numberp sexp)
- (vectorp sexp)
-;;; (and (fboundp 'characterp)
-;;; (characterp sexp))
- )
+ ;; Can't use `macroexp-quote' because it is loaded after `custom.el'
+ ;; during bootstrap. See `loadup.el'.
+ (if (and (not (consp sexp))
+ (or (keywordp sexp)
+ (not (symbolp sexp))
+ (booleanp sexp)))
sexp
(list 'quote sexp)))
@@ -715,18 +706,16 @@ To actually save the value, call `custom-save-all'.
Return non-nil if the `saved-value' property actually changed."
(custom-load-symbol symbol)
- (let* ((get (or (get symbol 'custom-get) 'default-value))
+ (let* ((get (or (get symbol 'custom-get) #'default-value))
(value (funcall get symbol))
(saved (get symbol 'saved-value))
(standard (get symbol 'standard-value))
(comment (get symbol 'customized-variable-comment)))
;; Save default value if different from standard value.
- (if (or (null standard)
- (not (equal value (condition-case nil
- (eval (car standard))
- (error nil)))))
- (put symbol 'saved-value (list (custom-quote value)))
- (put symbol 'saved-value nil))
+ (put symbol 'saved-value
+ (unless (and standard
+ (equal value (ignore-errors (eval (car standard)))))
+ (list (custom-quote value))))
;; Clear customized information (set, but not saved).
(put symbol 'customized-value nil)
;; Save any comment that might have been set.
@@ -744,15 +733,14 @@ default value. Otherwise, set it to nil.
Return non-nil if the `customized-value' property actually changed."
(custom-load-symbol symbol)
- (let* ((get (or (get symbol 'custom-get) 'default-value))
+ (let* ((get (or (get symbol 'custom-get) #'default-value))
(value (funcall get symbol))
(customized (get symbol 'customized-value))
(old (or (get symbol 'saved-value) (get symbol 'standard-value))))
;; Mark default value as set if different from old value.
(if (not (and old
- (equal value (condition-case nil
- (eval (car old))
- (error nil)))))
+ (equal value (ignore-errors
+ (eval (car old))))))
(progn (put symbol 'customized-value (list (custom-quote value)))
(custom-push-theme 'theme-value symbol 'user 'set
(custom-quote value)))
@@ -776,7 +764,7 @@ E.g. dumped variables whose default depends on run-time information."
;; always do the funcall step, even if symbol was not bound before.
(or (default-boundp symbol)
(eval `(defvar ,symbol nil))) ; reset below, so any value is fine
- (funcall (or (get symbol 'custom-set) 'set-default)
+ (funcall (or (get symbol 'custom-set) #'set-default)
symbol
(eval (car (or (get symbol 'saved-value) (get symbol 'standard-value))))))
@@ -843,6 +831,11 @@ to the front of this list.")
(unless (custom-theme-p theme)
(error "Unknown theme `%s'" theme)))
+(defun custom--should-apply-setting (theme)
+ (or (null custom--inhibit-theme-enable)
+ (and (eq custom--inhibit-theme-enable 'apply-only-user)
+ (eq theme 'user))))
+
(defun custom-push-theme (prop symbol theme mode &optional value)
"Record VALUE for face or variable SYMBOL in custom theme THEME.
PROP is `theme-face' for a face, `theme-value' for a variable.
@@ -882,7 +875,7 @@ See `custom-known-themes' for a list of known themes."
(setcar (cdr setting) value)))
;; Add a new setting:
(t
- (unless custom--inhibit-theme-enable
+ (when (custom--should-apply-setting theme)
(unless old
;; If the user changed a variable outside of Customize, save
;; the value to a fake theme, `changed'. If the theme is
@@ -941,7 +934,7 @@ the default value for the SYMBOL to the value of EXP.
REQUEST is a list of features we must require in order to
handle SYMBOL properly.
COMMENT is a comment string about SYMBOL."
- (apply 'custom-theme-set-variables 'user args))
+ (apply #'custom-theme-set-variables 'user args))
(defun custom-theme-set-variables (theme &rest args)
"Initialize variables for theme THEME according to settings in ARGS.
@@ -981,7 +974,7 @@ COMMENT is a comment string about SYMBOL."
(let* ((symbol (indirect-variable (nth 0 entry)))
(value (nth 1 entry)))
(custom-push-theme 'theme-value symbol theme 'set value)
- (unless custom--inhibit-theme-enable
+ (when (custom--should-apply-setting theme)
;; Now set the variable.
(let* ((now (nth 2 entry))
(requests (nth 3 entry))
@@ -989,8 +982,8 @@ COMMENT is a comment string about SYMBOL."
set)
(when requests
(put symbol 'custom-requests requests)
- (mapc 'require requests))
- (setq set (or (get symbol 'custom-set) 'custom-set-default))
+ (mapc #'require requests))
+ (setq set (or (get symbol 'custom-set) #'custom-set-default))
(put symbol 'saved-value (list value))
(put symbol 'saved-variable-comment comment)
;; Allow for errors in the case where the setter has
@@ -1086,26 +1079,29 @@ list, in which A occurs before B if B was defined with a
;; they were used to supply keyword-value pairs like `:immediate',
;; `:variable-reset-string', etc. We don't use any of these, so ignore them.
-(defmacro deftheme (theme &optional doc &rest ignored)
+(defmacro deftheme (theme &optional doc &rest _ignored)
"Declare THEME to be a Custom theme.
The optional argument DOC is a doc string describing the theme.
Any theme `foo' should be defined in a file called `foo-theme.el';
see `custom-make-theme-feature' for more information."
- (declare (doc-string 2))
+ (declare (doc-string 2)
+ (advertised-calling-convention (theme &optional doc) "22.1"))
(let ((feature (custom-make-theme-feature theme)))
;; It is better not to use backquote in this file,
;; because that makes a bootstrapping problem
;; if you need to recompile all the Lisp files using interpreted code.
(list 'custom-declare-theme (list 'quote theme) (list 'quote feature) doc)))
-(defun custom-declare-theme (theme feature &optional doc &rest ignored)
+(defun custom-declare-theme (theme feature &optional doc &rest _ignored)
"Like `deftheme', but THEME is evaluated as a normal argument.
FEATURE is the feature this theme provides. Normally, this is a symbol
created from THEME by `custom-make-theme-feature'."
+ (declare (advertised-calling-convention (theme feature &optional doc) "22.1"))
(unless (custom-theme-name-valid-p theme)
(error "Custom theme cannot be named %S" theme))
- (add-to-list 'custom-known-themes theme)
+ (unless (memq theme custom-known-themes)
+ (push theme custom-known-themes))
(put theme 'theme-feature feature)
(when doc (put theme 'theme-documentation doc)))
@@ -1149,11 +1145,13 @@ This variable is designed for use in lisp code (including
external packages). For manual user customizations, use
`custom-theme-directory' instead.")
-(defvar custom--inhibit-theme-enable nil
+(defvar custom--inhibit-theme-enable 'apply-only-user
"Whether the custom-theme-set-* functions act immediately.
If nil, `custom-theme-set-variables' and `custom-theme-set-faces'
change the current values of the given variable or face. If
-non-nil, they just make a record of the theme settings.")
+t, they just make a record of the theme settings. If the
+value is `apply-only-user', then apply setting to the
+`user' theme immediately and defer other updates.")
(defun provide-theme (theme)
"Indicate that this file provides THEME.
@@ -1184,7 +1182,7 @@ This variable cannot be set in a Custom theme."
:version "24.1")
(defun load-theme (theme &optional no-confirm no-enable)
- "Load Custom theme named THEME from its file.
+ "Load Custom theme named THEME from its file and possibly enable it.
The theme file is named THEME-theme.el, in one of the directories
specified by `custom-theme-load-path'.
@@ -1197,6 +1195,11 @@ Normally, this function also enables THEME. If optional arg
NO-ENABLE is non-nil, load the theme but don't enable it, unless
the theme was already enabled.
+Note that enabling THEME does not disable any other
+already-enabled themes. If THEME is enabled, it has the highest
+precedence (after `user') among enabled themes. To disable other
+themes, use `disable-theme'.
+
This function is normally called through Customize when setting
`custom-enabled-themes'. If used directly in your init file, it
should be called with a non-nil NO-CONFIRM argument, or after
@@ -1206,7 +1209,7 @@ Return t if THEME was successfully loaded, nil otherwise."
(interactive
(list
(intern (completing-read "Load custom theme: "
- (mapcar 'symbol-name
+ (mapcar #'symbol-name
(custom-available-themes))))
nil nil))
(unless (custom-theme-name-valid-p theme)
@@ -1221,43 +1224,47 @@ Return t if THEME was successfully loaded, nil otherwise."
(put theme 'theme-settings nil)
(put theme 'theme-feature nil)
(put theme 'theme-documentation nil))
- (let ((fn (locate-file (concat (symbol-name theme) "-theme.el")
- (custom-theme--load-path)
- '("" "c"))))
- (unless fn
- (error "Unable to find theme file for `%s'" theme))
- (with-temp-buffer
- (insert-file-contents fn)
- ;; Check file safety with `custom-safe-themes', prompting the
- ;; user if necessary.
- (when (or no-confirm
- (eq custom-safe-themes t)
- (and (memq 'default custom-safe-themes)
- (equal (file-name-directory fn)
- (expand-file-name "themes/" data-directory)))
- (let ((hash (secure-hash 'sha256 (current-buffer))))
- (or (member hash custom-safe-themes)
- (custom-theme-load-confirm hash))))
- (let ((custom--inhibit-theme-enable t)
- (buffer-file-name fn)) ;For load-history.
- (eval-buffer))
- ;; Optimization: if the theme changes the `default' face, put that
- ;; entry first. This avoids some `frame-set-background-mode' rigmarole
- ;; by assigning the new background immediately.
- (let* ((settings (get theme 'theme-settings))
- (tail settings)
- found)
- (while (and tail (not found))
- (and (eq (nth 0 (car tail)) 'theme-face)
- (eq (nth 1 (car tail)) 'default)
- (setq found (car tail)))
- (setq tail (cdr tail)))
- (if found
- (put theme 'theme-settings (cons found (delq found settings)))))
- ;; Finally, enable the theme.
- (unless no-enable
- (enable-theme theme))
- t))))
+ (let ((file (locate-file (concat (symbol-name theme) "-theme.el")
+ (custom-theme--load-path)
+ '("" "c")))
+ (custom--inhibit-theme-enable t))
+ ;; Check file safety with `custom-safe-themes', prompting the
+ ;; user if necessary.
+ (cond ((not file)
+ (error "Unable to find theme file for `%s'" theme))
+ ((or no-confirm
+ (eq custom-safe-themes t)
+ (and (memq 'default custom-safe-themes)
+ (equal (file-name-directory file)
+ (expand-file-name "themes/" data-directory))))
+ ;; Theme is safe; load byte-compiled version if available.
+ (load (file-name-sans-extension file) nil t nil t))
+ ((with-temp-buffer
+ (insert-file-contents file)
+ (let ((hash (secure-hash 'sha256 (current-buffer))))
+ (when (or (member hash custom-safe-themes)
+ (custom-theme-load-confirm hash))
+ (eval-buffer nil nil file)
+ t))))
+ (t
+ (error "Unable to load theme `%s'" theme))))
+ ;; Optimization: if the theme changes the `default' face, put that
+ ;; entry first. This avoids some `frame-set-background-mode' rigmarole
+ ;; by assigning the new background immediately.
+ (let* ((settings (get theme 'theme-settings))
+ (tail settings)
+ found)
+ (while (and tail (not found))
+ (and (eq (nth 0 (car tail)) 'theme-face)
+ (eq (nth 1 (car tail)) 'default)
+ (setq found (car tail)))
+ (setq tail (cdr tail)))
+ (when found
+ (put theme 'theme-settings (cons found (delq found settings)))))
+ ;; Finally, enable the theme.
+ (unless no-enable
+ (enable-theme theme))
+ t)
(defun custom-theme-load-confirm (hash)
"Query the user about loading a Custom theme that may not be safe.
@@ -1280,11 +1287,9 @@ query also about adding HASH to `custom-safe-themes'."
(defun custom-theme-name-valid-p (name)
"Return t if NAME is a valid name for a Custom theme, nil otherwise.
NAME should be a symbol."
- (and (symbolp name)
- name
- (not (or (zerop (length (symbol-name name)))
- (eq name 'user)
- (eq name 'changed)))))
+ (and (not (memq name '(nil user changed)))
+ (symbolp name)
+ (not (string= "" (symbol-name name)))))
(defun custom-available-themes ()
"Return a list of Custom themes available for loading.
@@ -1295,19 +1300,25 @@ The returned symbols may not correspond to themes that have been
loaded, and no effort is made to check that the files contain
valid Custom themes. For a list of loaded themes, check the
variable `custom-known-themes'."
- (let (sym themes)
+ (let ((suffix "-theme\\.el\\'")
+ themes)
(dolist (dir (custom-theme--load-path))
- (when (file-directory-p dir)
- (dolist (file (file-expand-wildcards
- (expand-file-name "*-theme.el" dir) t))
- (setq file (file-name-nondirectory file))
- (and (string-match "\\`\\(.+\\)-theme.el\\'" file)
- (setq sym (intern (match-string 1 file)))
- (custom-theme-name-valid-p sym)
- (push sym themes)))))
- (nreverse (delete-dups themes))))
+ ;; `custom-theme--load-path' promises DIR exists and is a
+ ;; directory, but `custom.el' is loaded too early during
+ ;; bootstrap to use `cl-lib' macros, so guard with
+ ;; `file-directory-p' instead of calling `cl-assert'.
+ (dolist (file (and (file-directory-p dir)
+ (directory-files dir nil suffix)))
+ (let ((theme (intern (substring file 0 (string-match-p suffix file)))))
+ (and (custom-theme-name-valid-p theme)
+ (not (memq theme themes))
+ (push theme themes)))))
+ (nreverse themes)))
(defun custom-theme--load-path ()
+ "Expand `custom-theme-load-path' into a list of directories.
+Members of `custom-theme-load-path' that either don't exist or
+are not directories are omitted from the expansion."
(let (lpath)
(dolist (f custom-theme-load-path)
(cond ((eq f 'custom-theme-directory)
@@ -1324,14 +1335,18 @@ variable `custom-known-themes'."
(defun enable-theme (theme)
"Reenable all variable and face settings defined by THEME.
THEME should be either `user', or a theme loaded via `load-theme'.
+
After this function completes, THEME will have the highest
-precedence (after `user')."
+precedence (after `user') among enabled themes.
+
+Note that any already-enabled themes remain enabled after this
+function runs. To disable other themes, use `disable-theme'."
(interactive (list (intern
(completing-read
"Enable custom theme: "
obarray (lambda (sym) (get sym 'theme-settings)) t))))
- (if (not (custom-theme-p theme))
- (error "Undefined Custom theme %s" theme))
+ (unless (custom-theme-p theme)
+ (error "Undefined Custom theme %s" theme))
(let ((settings (get theme 'theme-settings)))
;; Loop through theme settings, recalculating vars/faces.
(dolist (s settings)
@@ -1371,23 +1386,23 @@ Setting this variable through Customize calls `enable-theme' or
(let (failures)
(setq themes (delq 'user (delete-dups themes)))
;; Disable all themes not in THEMES.
- (if (boundp symbol)
- (dolist (theme (symbol-value symbol))
- (if (not (memq theme themes))
- (disable-theme theme))))
+ (dolist (theme (and (boundp symbol)
+ (symbol-value symbol)))
+ (unless (memq theme themes)
+ (disable-theme theme)))
;; Call `enable-theme' or `load-theme' on each of THEMES.
(dolist (theme (reverse themes))
(condition-case nil
(if (custom-theme-p theme)
(enable-theme theme)
(load-theme theme))
- (error (setq failures (cons theme failures)
- themes (delq theme themes)))))
+ (error (push theme failures)
+ (setq themes (delq theme themes)))))
(enable-theme 'user)
(custom-set-default symbol themes)
- (if failures
- (message "Failed to enable theme: %s"
- (mapconcat 'symbol-name failures ", "))))))
+ (when failures
+ (message "Failed to enable theme(s): %s"
+ (mapconcat #'symbol-name failures ", "))))))
(defsubst custom-theme-enabled-p (theme)
"Return non-nil if THEME is enabled."
@@ -1399,7 +1414,7 @@ See `custom-enabled-themes' for a list of enabled themes."
(interactive (list (intern
(completing-read
"Disable custom theme: "
- (mapcar 'symbol-name custom-enabled-themes)
+ (mapcar #'symbol-name custom-enabled-themes)
nil t))))
(when (custom-theme-enabled-p theme)
(let ((settings (get theme 'theme-settings)))
@@ -1415,23 +1430,23 @@ See `custom-enabled-themes' for a list of enabled themes."
;; If the face spec specified by this theme is in the
;; saved-face property, reset that property.
(when (equal (nth 3 s) (get symbol 'saved-face))
- (put symbol 'saved-face (and val (cadr (car val)))))))))
- ;; Recompute faces on all frames.
- (dolist (frame (frame-list))
- ;; We must reset the fg and bg color frame parameters, or
- ;; `face-set-after-frame-default' will use the existing
- ;; parameters, which could be from the disabled theme.
- (set-frame-parameter frame 'background-color
- (custom--frame-color-default
- frame :background "background" "Background"
- "unspecified-bg" "white"))
- (set-frame-parameter frame 'foreground-color
- (custom--frame-color-default
- frame :foreground "foreground" "Foreground"
- "unspecified-fg" "black"))
- (face-set-after-frame-default frame))
- (setq custom-enabled-themes
- (delq theme custom-enabled-themes)))))
+ (put symbol 'saved-face (cadar val))))))))
+ ;; Recompute faces on all frames.
+ (dolist (frame (frame-list))
+ ;; We must reset the fg and bg color frame parameters, or
+ ;; `face-set-after-frame-default' will use the existing
+ ;; parameters, which could be from the disabled theme.
+ (set-frame-parameter frame 'background-color
+ (custom--frame-color-default
+ frame :background "background" "Background"
+ "unspecified-bg" "white"))
+ (set-frame-parameter frame 'foreground-color
+ (custom--frame-color-default
+ frame :foreground "foreground" "Foreground"
+ "unspecified-fg" "black"))
+ (face-set-after-frame-default frame))
+ (setq custom-enabled-themes
+ (delq theme custom-enabled-themes))))
;; Only used if window-system not null.
(declare-function x-get-resource "frame.c"
@@ -1465,7 +1480,7 @@ This function returns nil if no custom theme specifies a value for VARIABLE."
(if (and valspec
(or (get variable 'force-value)
(default-boundp variable)))
- (funcall (or (get variable 'custom-set) 'set-default) variable
+ (funcall (or (get variable 'custom-set) #'set-default) variable
(eval (car valspec))))))
(defun custom-theme-recalc-face (face)
@@ -1506,7 +1521,7 @@ Each of the arguments ARGS has this form:
(VARIABLE IGNORED)
This means reset VARIABLE. (The argument IGNORED is ignored)."
- (apply 'custom-theme-reset-variables 'user args))
+ (apply #'custom-theme-reset-variables 'user args))
;;; The End.
diff --git a/lisp/dabbrev.el b/lisp/dabbrev.el
index 650ea84f088..2159f96028f 100644
--- a/lisp/dabbrev.el
+++ b/lisp/dabbrev.el
@@ -219,7 +219,7 @@ designated by `dabbrev-select-buffers-function'.
Then, if `dabbrev-check-all-buffers' is non-nil, dabbrev searches
all the other buffers, except those named in `dabbrev-ignored-buffer-names',
-or matched by `dabbrev-ignored-regexps'."
+or matched by `dabbrev-ignored-buffer-regexps'."
:type 'boolean
:group 'dabbrev)
@@ -434,7 +434,7 @@ buffers accepted by the function pointed out by variable
`dabbrev-friend-buffer-function', if `dabbrev-check-other-buffers'
says so. Then, if `dabbrev-check-all-buffers' is non-nil, look in
all the other buffers, subject to constraints specified
-by `dabbrev-ignored-buffer-names' and `dabbrev-ignored-regexps'.
+by `dabbrev-ignored-buffer-names' and `dabbrev-ignored-buffer-regexps'.
A positive prefix argument, N, says to take the Nth backward *distinct*
possibility. A negative argument says search forward.
diff --git a/lisp/delim-col.el b/lisp/delim-col.el
index d8116f3544b..a968b32052b 100644
--- a/lisp/delim-col.el
+++ b/lisp/delim-col.el
@@ -2,8 +2,8 @@
;; Copyright (C) 1999-2019 Free Software Foundation, Inc.
-;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
-;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
+;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Version: 2.1
;; Keywords: internal
;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
diff --git a/lisp/delsel.el b/lisp/delsel.el
index 08c47ddca8d..8f71bc65191 100644
--- a/lisp/delsel.el
+++ b/lisp/delsel.el
@@ -70,12 +70,6 @@ Value must be the register (key) to use.")
;;;###autoload
(define-minor-mode delete-selection-mode
"Toggle Delete Selection mode.
-Interactively, with a prefix argument, enable
-Delete Selection mode if the prefix argument is positive,
-and disable it otherwise. If called from Lisp, toggle
-the mode if ARG is `toggle', disable the mode if ARG is
-a non-positive integer, and enable the mode otherwise
-\(including if ARG is omitted or nil or a positive integer).
When Delete Selection mode is enabled, typed text replaces the selection
if the selection is active. Otherwise, typed text is just inserted at
@@ -300,18 +294,10 @@ then it takes a second \\[keyboard-quit] to abort the minibuffer."
(abort-recursive-edit)))
(define-key minibuffer-local-map "\C-g" 'minibuffer-keyboard-quit)
-(define-key minibuffer-local-ns-map "\C-g" 'minibuffer-keyboard-quit)
-(define-key minibuffer-local-completion-map "\C-g" 'minibuffer-keyboard-quit)
-(define-key minibuffer-local-must-match-map "\C-g" 'minibuffer-keyboard-quit)
-(define-key minibuffer-local-isearch-map "\C-g" 'minibuffer-keyboard-quit)
(defun delsel-unload-function ()
"Unload the Delete Selection library."
(define-key minibuffer-local-map "\C-g" 'abort-recursive-edit)
- (define-key minibuffer-local-ns-map "\C-g" 'abort-recursive-edit)
- (define-key minibuffer-local-completion-map "\C-g" 'abort-recursive-edit)
- (define-key minibuffer-local-must-match-map "\C-g" 'abort-recursive-edit)
- (define-key minibuffer-local-isearch-map "\C-g" 'abort-recursive-edit)
(dolist (sym '(self-insert-command insert-char quoted-insert yank
clipboard-yank insert-register newline-and-indent
reindent-then-newline-and-indent newline open-line))
diff --git a/lisp/descr-text.el b/lisp/descr-text.el
index c4959a81808..8be2b94458a 100644
--- a/lisp/descr-text.el
+++ b/lisp/descr-text.el
@@ -413,12 +413,6 @@ The character information includes:
(charset (if eight-bit-p 'eight-bit
(or (get-text-property pos 'charset)
(char-charset char))))
- ;; TIS620.2533 overlaps eight-bit-control, but we want to
- ;; show eight-bit for raw bytes, not some obscure character
- ;; set no one heard of.
- (charset (if (eq charset 'tis620-2533)
- 'eight-bit
- charset))
(composition (find-composition pos nil nil t))
(component-chars nil)
(display-table (or (window-display-table)
@@ -850,8 +844,6 @@ The character information includes:
(if text-props-desc (insert text-props-desc))
(setq buffer-read-only t))))))
-(define-obsolete-function-alias 'describe-char-after 'describe-char "22.1")
-
;;; Describe-Char-ElDoc
(defun describe-char-eldoc--truncate (name width)
diff --git a/lisp/desktop.el b/lisp/desktop.el
index a14abdd8fc1..97c057e2013 100644
--- a/lisp/desktop.el
+++ b/lisp/desktop.el
@@ -158,14 +158,9 @@ Used at desktop read to provide backward compatibility.")
"Save status of Emacs when you exit."
:group 'frames)
-;; Maintained for backward compatibility
-(define-obsolete-variable-alias 'desktop-enable 'desktop-save-mode "22.1")
;;;###autoload
(define-minor-mode desktop-save-mode
"Toggle desktop saving (Desktop Save mode).
-With a prefix argument ARG, enable Desktop Save mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode if ARG
-is omitted or nil.
When Desktop Save mode is enabled, the state of Emacs is saved from
one session to another. In particular, Emacs will save the desktop when
@@ -248,9 +243,6 @@ the normal hook `desktop-not-loaded-hook' is run."
:group 'desktop
:version "22.2")
-(define-obsolete-variable-alias 'desktop-basefilename
- 'desktop-base-file-name "22.1")
-
(defcustom desktop-base-file-name
(convert-standard-filename ".emacs.desktop")
"Name of file for Emacs desktop, excluding the directory part."
@@ -392,7 +384,7 @@ or `desktop-modes-not-to-save'."
;; Skip tramp and ange-ftp files
(defcustom desktop-files-not-to-save
- "\\(^/[^/:]*:\\|(ftp)$\\)"
+ "\\(\\`/[^/:]*:\\|(ftp)\\'\\)"
"Regexp identifying files whose buffers are to be excluded from saving.
The default value excludes buffers visiting remote files."
:type '(choice (const :tag "None" nil)
@@ -494,10 +486,6 @@ When file names are returned, they should be formatted using the call
Later, when `desktop-read' evaluates the desktop file, auxiliary information
is passed as the argument DESKTOP-BUFFER-MISC to functions in
`desktop-buffer-mode-handlers'.")
-(make-obsolete-variable 'desktop-buffer-modes-to-save
- 'desktop-save-buffer "22.1")
-(make-obsolete-variable 'desktop-buffer-misc-functions
- 'desktop-save-buffer "22.1")
;;;###autoload
(defvar desktop-buffer-mode-handlers nil
@@ -541,12 +529,9 @@ can guess how to load the mode's definition.")
;;;###autoload
(put 'desktop-buffer-mode-handlers 'risky-local-variable t)
-(make-obsolete-variable 'desktop-buffer-handlers
- 'desktop-buffer-mode-handlers "22.1")
(defcustom desktop-minor-mode-table
- '((auto-fill-function auto-fill-mode)
- (defining-kbd-macro nil)
+ '((defining-kbd-macro nil)
(isearch-mode nil)
(vc-mode nil)
(vc-dired-mode nil)
@@ -713,12 +698,12 @@ if different)."
(if (symbolp var)
(set-default var nil)
(set-default var (eval (cdr var)))))
- (let ((preserve-regexp (concat "^\\("
+ (let ((preserve-regexp (concat "\\`\\("
(mapconcat (lambda (regexp)
(concat "\\(" regexp "\\)"))
desktop-clear-preserve-buffers
"\\|")
- "\\)$")))
+ "\\)\\'")))
(dolist (buffer (buffer-list))
(let ((bufname (buffer-name buffer)))
(unless (or (eq (aref bufname 0) ?\s) ;; Don't kill internal buffers
@@ -746,7 +731,7 @@ if different)."
;; ----------------------------------------------------------------------------
(unless noninteractive
- (add-hook 'kill-emacs-hook 'desktop-kill))
+ (add-hook 'kill-emacs-hook #'desktop-kill))
(defun desktop-kill ()
"If `desktop-save-mode' is non-nil, do what `desktop-save' says to do.
@@ -815,6 +800,7 @@ buffer, which is (in order):
(symbol-value minor-mode)
(let* ((special (assq minor-mode desktop-minor-mode-table))
(value (cond (special (cadr special))
+ ((get minor-mode :minor-mode-function))
((functionp minor-mode) minor-mode))))
(when value (cl-pushnew value ret))))))
;; point and mark, and read-only status
@@ -852,10 +838,12 @@ QUOTE may be `may' (value may be quoted),
((or (numberp value) (null value) (eq t value) (keywordp value))
(cons 'may value))
((stringp value)
- (let ((copy (copy-sequence value)))
- (set-text-properties 0 (length copy) nil copy)
- ;; Get rid of text properties because we cannot read them.
- (cons 'may copy)))
+ ;; Get rid of unreadable text properties.
+ (if (condition-case nil (read (format "%S" value)) (error nil))
+ (cons 'may value)
+ (let ((copy (copy-sequence value)))
+ (set-text-properties 0 (length copy) nil copy)
+ (cons 'may copy))))
((symbolp value)
(cons 'must value))
((vectorp value)
@@ -868,6 +856,19 @@ QUOTE may be `may' (value may be quoted),
`',(cdr el) (cdr el)))
pass1)))
(cons 'may `[,@(mapcar #'cdr pass1)]))))
+ ((and (recordp value) (symbolp (aref value 0)))
+ (let* ((pass1 (let ((res ()))
+ (dotimes (i (length value))
+ (push (desktop--v2s (aref value i)) res))
+ (nreverse res)))
+ (special (assq nil pass1)))
+ (if special
+ (cons nil `(record
+ ,@(mapcar (lambda (el)
+ (if (eq (car el) 'must)
+ `',(cdr el) (cdr el)))
+ pass1)))
+ (cons 'may (apply #'record (mapcar #'cdr pass1))))))
((consp value)
(let ((p value)
newlist
@@ -900,8 +901,8 @@ QUOTE may be `may' (value may be quoted),
(cons nil
`(let ((mk (make-marker)))
(add-hook 'desktop-delay-hook
- `(lambda ()
- (set-marker ,mk ,,pos (get-buffer ,,buf))))
+ (lambda ()
+ (set-marker mk ,pos (get-buffer ,buf))))
mk))))
(t ; Save as text.
(cons 'may "Unprintable entity"))))
@@ -1043,7 +1044,8 @@ without further confirmation."
(setq desktop-dirname (file-name-as-directory (expand-file-name dirname)))
(save-excursion
(let ((eager desktop-restore-eager)
- (new-modtime (nth 5 (file-attributes (desktop-full-file-name)))))
+ (new-modtime (file-attribute-modification-time
+ (file-attributes (desktop-full-file-name)))))
(when
(or (not new-modtime) ; nothing to overwrite
(equal desktop-file-modtime new-modtime)
@@ -1085,7 +1087,7 @@ without further confirmation."
(with-temp-buffer
(insert
- ";; -*- mode: emacs-lisp; coding: emacs-mule; -*-\n"
+ ";; -*- mode: emacs-lisp; lexical-binding:t; coding: utf-8-emacs; -*-\n"
desktop-header
";; Created " (current-time-string) "\n"
";; Desktop file format version " (format "%d" desktop-io-file-version) "\n"
@@ -1098,7 +1100,7 @@ without further confirmation."
(desktop-save-frameset)
(unless (memq 'desktop-saved-frameset desktop-globals-to-save)
(desktop-outvar 'desktop-saved-frameset))
- (mapc (function desktop-outvar) desktop-globals-to-save)
+ (mapc #'desktop-outvar desktop-globals-to-save)
(setq desktop-saved-frameset nil) ; after saving desktop-globals-to-save
(when (memq 'kill-ring desktop-globals-to-save)
(insert
@@ -1107,9 +1109,9 @@ without further confirmation."
" kill-ring))\n"))
(insert "\n;; Buffer section -- buffers listed in same order as in buffer list:\n")
- (dolist (l (mapcar 'desktop-buffer-info (buffer-list)))
+ (dolist (l (mapcar #'desktop-buffer-info (buffer-list)))
(let ((base (pop l)))
- (when (apply 'desktop-save-buffer-p l)
+ (when (apply #'desktop-save-buffer-p l)
(insert "("
(if (or (not (integerp eager))
(if (zerop eager)
@@ -1140,13 +1142,15 @@ without further confirmation."
;; This is saved after the timestamp
(search-forward (format "%S" desktop--app-id) nil t))
(point))))
- (checksum (and beg (md5 (current-buffer) beg (point-max) 'emacs-mule))))
+ (checksum (and beg (md5 (current-buffer) beg (point-max) 'utf-8-emacs))))
(unless (and checksum (equal checksum desktop-file-checksum))
- (let ((coding-system-for-write 'emacs-mule))
+ (let ((coding-system-for-write 'utf-8-emacs))
(write-region (point-min) (point-max) (desktop-full-file-name) nil 'nomessage))
(setq desktop-file-checksum checksum)
;; We remember when it was modified (which is presumably just now).
- (setq desktop-file-modtime (nth 5 (file-attributes (desktop-full-file-name)))))))))))
+ (setq desktop-file-modtime (file-attribute-modification-time
+ (file-attributes
+ (desktop-full-file-name)))))))))))
;; ----------------------------------------------------------------------------
;;;###autoload
@@ -1241,16 +1245,18 @@ Using it may cause conflicts. Use it anyway? " owner)))))
;; disabled when loading the desktop fails with errors,
;; thus not overwriting the desktop with broken contents.
(setq desktop-autosave-was-enabled
- (memq 'desktop-auto-save-set-timer
- ;; Use the toplevel value of the hook, in case some
+ (memq #'desktop-auto-save-set-timer
+ ;; Use the global value of the hook, in case some
;; feature makes window-configuration-change-hook
;; buffer-local, and puts there stuff which
;; doesn't include our timer.
- (default-toplevel-value
+ (default-value
'window-configuration-change-hook)))
(desktop-auto-save-disable)
;; Evaluate desktop buffer and remember when it was modified.
- (setq desktop-file-modtime (nth 5 (file-attributes (desktop-full-file-name))))
+ (setq desktop-file-modtime (file-attribute-modification-time
+ (file-attributes
+ (desktop-full-file-name))))
(load (desktop-full-file-name) t t t)
;; If it wasn't already, mark it as in-use, to bother other
;; desktop instances.
@@ -1265,7 +1271,7 @@ Using it may cause conflicts. Use it anyway? " owner)))))
;; We want buffers existing prior to evaluating the desktop (and
;; not reused) to be placed at the end of the buffer list, so we
;; move them here.
- (mapc 'bury-buffer
+ (mapc #'bury-buffer
(nreverse (cdr (memq desktop-first-buffer (nreverse (buffer-list))))))
(switch-to-buffer (car (buffer-list))))
(run-hooks 'desktop-delay-hook)
@@ -1310,17 +1316,6 @@ Using it may cause conflicts. Use it anyway? " owner)))))
nil)))
;; ----------------------------------------------------------------------------
-;; Maintained for backward compatibility
-;;;###autoload
-(defun desktop-load-default ()
- "Load the `default' start-up library manually.
-Also inhibit further loading of it."
- (declare (obsolete desktop-save-mode "22.1"))
- (unless inhibit-default-init ; safety check
- (load "default" t t)
- (setq inhibit-default-init t)))
-
-;; ----------------------------------------------------------------------------
;;;###autoload
(defun desktop-change-dir (dirname)
"Change to desktop saved in DIRNAME.
@@ -1350,10 +1345,10 @@ directory DIRNAME."
(defun desktop-auto-save-enable (&optional timeout)
(when (and (integerp (or timeout desktop-auto-save-timeout))
(> (or timeout desktop-auto-save-timeout) 0))
- (add-hook 'window-configuration-change-hook 'desktop-auto-save-set-timer)))
+ (add-hook 'window-configuration-change-hook #'desktop-auto-save-set-timer)))
(defun desktop-auto-save-disable ()
- (remove-hook 'window-configuration-change-hook 'desktop-auto-save-set-timer)
+ (remove-hook 'window-configuration-change-hook #'desktop-auto-save-set-timer)
(desktop-auto-save-cancel-timer))
(defun desktop-auto-save ()
@@ -1562,11 +1557,10 @@ and try to load that."
;; for the sake of `clean-buffer-list': preserving the invariant
;; "how much time the user spent in Emacs without looking at this buffer".
(setq buffer-display-time
- (if buffer-display-time
- (time-add buffer-display-time
- (time-subtract (current-time)
- desktop-file-modtime))
- (current-time)))
+ (time-since (if buffer-display-time
+ (time-subtract desktop-file-modtime
+ buffer-display-time)
+ 0)))
(unless (< desktop-file-version 208) ; Don't misinterpret any old custom args
(dolist (record compacted-vars)
(let*
@@ -1609,7 +1603,7 @@ ARGS must be an argument list for `desktop-create-buffer'."
(let ((desktop-first-buffer nil)
(desktop-buffer-ok-count 0)
(desktop-buffer-fail-count 0))
- (apply 'desktop-create-buffer args)
+ (apply #'desktop-create-buffer args)
(run-hooks 'desktop-delay-hook)
(setq desktop-delay-hook nil)
(bury-buffer (get-buffer buffer-name))
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index a9443482d63..b81c0d1a4f5 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -148,7 +148,7 @@ the string of command switches used as the third argument of `diff'."
(read-string "Options for diff: "
(if (stringp diff-switches)
diff-switches
- (mapconcat 'identity diff-switches " ")))))))
+ (mapconcat #'identity diff-switches " ")))))))
(let ((current (dired-get-filename t)))
(when (or (equal (expand-file-name file)
(expand-file-name current))
@@ -173,7 +173,7 @@ With prefix arg, prompt for argument SWITCHES which is options for `diff'."
(list (read-string "Options for diff: "
(if (stringp diff-switches)
diff-switches
- (mapconcat 'identity diff-switches " "))))
+ (mapconcat #'identity diff-switches " "))))
nil))
(diff-backup (dired-get-filename) switches))
@@ -200,9 +200,12 @@ Examples of PREDICATE:
(> mtime1 mtime2) - mark newer files
(not (= size1 size2)) - mark files with different sizes
- (not (string= (nth 8 fa1) (nth 8 fa2))) - mark files with different modes
- (not (and (= (nth 2 fa1) (nth 2 fa2)) - mark files with different UID
- (= (nth 3 fa1) (nth 3 fa2)))) and GID."
+ (not (string= (file-attribute-modes fa1) - mark files with different modes
+ (file-attribute-modes fa2)))
+ (not (and (= (file-attribute-user-id fa1) - mark files with different UID
+ (file-attribute-user-id fa2))
+ (= (file-attribute-group-id fa1) - and GID.
+ (file-attribute-group-id fa2))))"
(interactive
(list
(let* ((target-dir (dired-dwim-target-directory))
@@ -224,12 +227,12 @@ Examples of PREDICATE:
(setq file-alist2 (delq (assoc "." file-alist2) file-alist2))
(setq file-alist2 (delq (assoc ".." file-alist2) file-alist2))
(setq file-list1 (mapcar
- 'cadr
+ #'cadr
(dired-file-set-difference
file-alist1 file-alist2
predicate))
file-list2 (mapcar
- 'cadr
+ #'cadr
(dired-file-set-difference
file-alist2 file-alist1
predicate)))
@@ -269,12 +272,12 @@ condition. Two file items are considered to match if they are equal
(eval predicate
`((fa1 . ,fa1)
(fa2 . ,fa2)
- (size1 . ,(nth 7 fa1))
- (size2 . ,(nth 7 fa2))
+ (size1 . ,(file-attribute-size fa1))
+ (size2 . ,(file-attribute-size fa2))
(mtime1
- . ,(float-time (nth 5 fa1)))
+ . ,(float-time (file-attribute-modification-time fa1)))
(mtime2
- . ,(float-time (nth 5 fa2)))
+ . ,(float-time (file-attribute-modification-time fa2)))
)))))
(setq list (cdr list)))
list)
@@ -301,18 +304,21 @@ List has a form of (file-name full-file-name (attribute-list))."
;; PROGRAM is the program used to change the attribute.
;; OP-SYMBOL is the type of operation (for use in `dired-mark-pop-up').
;; ARG describes which files to use, as in `dired-get-marked-files'.
- (let* ((files (dired-get-marked-files t arg))
+ (let* ((files (dired-get-marked-files t arg nil nil t))
;; The source of default file attributes is the file at point.
(default-file (dired-get-filename t t))
(default (when default-file
(cond ((eq op-symbol 'touch)
(format-time-string
"%Y%m%d%H%M.%S"
- (nth 5 (file-attributes default-file))))
+ (file-attribute-modification-time
+ (file-attributes default-file))))
((eq op-symbol 'chown)
- (nth 2 (file-attributes default-file 'string)))
+ (file-attribute-user-id
+ (file-attributes default-file 'string)))
((eq op-symbol 'chgrp)
- (nth 3 (file-attributes default-file 'string))))))
+ (file-attribute-group-id
+ (file-attributes default-file 'string))))))
(prompt (concat "Change " attribute-name " of %s to"
(if (eq op-symbol 'touch)
" (default now): "
@@ -361,11 +367,11 @@ Symbolic modes like `g+w' are allowed.
Type M-n to pull the file attributes of the file at point
into the minibuffer."
(interactive "P")
- (let* ((files (dired-get-marked-files t arg))
+ (let* ((files (dired-get-marked-files t arg nil nil t))
;; The source of default file attributes is the file at point.
(default-file (dired-get-filename t t))
(modestr (when default-file
- (nth 8 (file-attributes default-file))))
+ (file-attribute-modes (file-attributes default-file))))
(default
(and (stringp modestr)
(string-match "^.\\(...\\)\\(...\\)\\(...\\)$" modestr)
@@ -476,7 +482,7 @@ Uses the shell command coming from variables `lpr-command' and
`lpr-switches' as default."
(interactive "P")
(require 'lpr)
- (let* ((file-list (dired-get-marked-files t arg))
+ (let* ((file-list (dired-get-marked-files t arg nil nil t))
(lpr-switches
(if (and (stringp printer-name)
(string< "" printer-name))
@@ -485,7 +491,7 @@ Uses the shell command coming from variables `lpr-command' and
lpr-switches))
(command (dired-mark-read-string
"Print %s with: "
- (mapconcat 'identity
+ (mapconcat #'identity
(cons lpr-command
(if (stringp lpr-switches)
(list lpr-switches)
@@ -591,7 +597,7 @@ with a prefix argument."
(possibilities (file-name-all-completions
base-versions
(file-name-directory fn)))
- (versions (mapcar 'backup-extract-version possibilities)))
+ (versions (mapcar #'backup-extract-version possibilities)))
(if versions
(setq dired-file-version-alist
(cons (cons fn versions)
@@ -668,7 +674,7 @@ In shell syntax this means separating the individual commands with `;'.
The output appears in the buffer `*Async Shell Command*'."
(interactive
- (let ((files (dired-get-marked-files t current-prefix-arg)))
+ (let ((files (dired-get-marked-files t current-prefix-arg nil nil t)))
(list
;; Want to give feedback whether this file or marked files are used:
(dired-read-shell-command "& on %s: " current-prefix-arg files)
@@ -729,7 +735,7 @@ can be produced by `dired-get-marked-files', for example."
;;Functions dired-run-shell-command and dired-shell-stuff-it do the
;;actual work and can be redefined for customization.
(interactive
- (let ((files (dired-get-marked-files t current-prefix-arg)))
+ (let ((files (dired-get-marked-files t current-prefix-arg nil nil t)))
(list
;; Want to give feedback whether this file or marked files are used:
(dired-read-shell-command "! on %s: " current-prefix-arg files)
@@ -816,27 +822,28 @@ can be produced by `dired-get-marked-files', for example."
retval))
(lambda (x) (concat cmd-prefix command dired-mark-separator x)))))
(concat
- (cond (on-each
- (format "%s%s"
- (mapconcat stuff-it (mapcar 'shell-quote-argument file-list)
- cmd-sep)
- ;; POSIX shells running a list of commands in the background
- ;; (LIST = cmd_1 & [cmd_2 & ... cmd_i & ... cmd_N &])
- ;; return once cmd_N ends, i.e., the shell does not
- ;; wait for cmd_i to finish before executing cmd_i+1.
- ;; That means, running (shell-command LIST) may not show
- ;; the output of all the commands (Bug#23206).
- ;; Add 'wait' to force those POSIX shells to wait until
- ;; all commands finish.
- (or (and parallel-in-background (not w32-shell)
- "&wait")
- "")))
- (t
- (let ((files (mapconcat 'shell-quote-argument
- file-list dired-mark-separator)))
- (when (cdr file-list)
- (setq files (concat dired-mark-prefix files dired-mark-postfix)))
- (funcall stuff-it files))))
+ (cond
+ (on-each
+ (format "%s%s"
+ (mapconcat stuff-it (mapcar #'shell-quote-argument file-list)
+ cmd-sep)
+ ;; POSIX shells running a list of commands in the background
+ ;; (LIST = cmd_1 & [cmd_2 & ... cmd_i & ... cmd_N &])
+ ;; return once cmd_N ends, i.e., the shell does not
+ ;; wait for cmd_i to finish before executing cmd_i+1.
+ ;; That means, running (shell-command LIST) may not show
+ ;; the output of all the commands (Bug#23206).
+ ;; Add 'wait' to force those POSIX shells to wait until
+ ;; all commands finish.
+ (or (and parallel-in-background (not w32-shell)
+ "&wait")
+ "")))
+ (t
+ (let ((files (mapconcat #'shell-quote-argument
+ file-list dired-mark-separator)))
+ (when (cdr file-list)
+ (setq files (concat dired-mark-prefix files dired-mark-postfix)))
+ (funcall stuff-it files))))
(or (and in-background "&") ""))))
;; This is an extra function so that it can be redefined by ange-ftp.
@@ -866,7 +873,7 @@ Else returns nil for success."
(set-buffer err-buffer)
(erase-buffer)
(setq default-directory dir ; caller's default-directory
- err (not (eq 0 (apply 'process-file program nil t nil arguments))))
+ err (not (eq 0 (apply #'process-file program nil t nil arguments))))
(if err
(progn
(dired-log (concat program " " (prin1-to-string arguments) "\n"))
@@ -1033,7 +1040,7 @@ Prompt for the archive file name.
Choose the archiving command based on the archive file-name extension
and `dired-compress-files-alist'."
(interactive)
- (let* ((in-files (dired-get-marked-files))
+ (let* ((in-files (dired-get-marked-files nil nil nil nil t))
(out-file (expand-file-name (read-file-name "Compress to: ")))
(rule (cl-find-if
(lambda (x)
@@ -1156,7 +1163,7 @@ Return nil if no change in files."
;; Pass t for DISTINGUISH-ONE-MARKED so that a single file which
;; is marked pops up a window. That will help the user see
;; it isn't the current line file.
- (let ((files (dired-get-marked-files t arg nil t))
+ (let ((files (dired-get-marked-files t arg nil t t))
(string (if (eq op-symbol 'compress) "Compress or uncompress"
(capitalize (symbol-name op-symbol)))))
(dired-mark-pop-up nil op-symbol files #'y-or-n-p
@@ -1343,7 +1350,7 @@ See Info node `(emacs)Subdir switches' for more details."
;; Replace space by old marker without moving point.
;; Faster than goto+insdel inside a save-excursion?
(when char
- (subst-char-in-region opoint (1+ opoint) ?\040 char)))))
+ (subst-char-in-region opoint (1+ opoint) ?\s char)))))
(dired-move-to-filename))
;;;###autoload
@@ -1397,8 +1404,8 @@ files matching `dired-omit-regexp'."
(catch 'not-found
(if (string= directory cur-dir)
(progn
- (skip-chars-forward "^\r\n")
- (if (eq (following-char) ?\r)
+ (end-of-line)
+ (if (dired--hidden-p)
(dired-unhide-subdir))
;; We are already where we should be, except when
;; point is before the subdir line or its total line.
@@ -1408,7 +1415,7 @@ files matching `dired-omit-regexp'."
;; else try to find correct place to insert
(if (dired-goto-subdir directory)
(progn ;; unhide if necessary
- (if (= (following-char) ?\r)
+ (if (dired--hidden-p)
;; Point is at end of subdir line.
(dired-unhide-subdir))
;; found - skip subdir and `total' line
@@ -1517,7 +1524,7 @@ files matching `dired-omit-regexp'."
(point))
(line-beginning-position 2)))
(setq file (directory-file-name file))
- (dired-add-entry file (if (eq ?\040 marker) nil marker)))))
+ (dired-add-entry file (if (eq ?\s marker) nil marker)))))
;;; Copy, move/rename, making hard and symbolic links
@@ -1557,22 +1564,41 @@ Special value `always' suppresses confirmation."
(declare-function make-symbolic-link "fileio.c")
+(defcustom dired-create-destination-dirs nil
+ "Whether Dired should create destination dirs when copying/removing files.
+If nil, don't create them.
+If `always', create them without asking.
+If `ask', ask for user confirmation."
+ :type '(choice (const :tag "Never create non-existent dirs" nil)
+ (const :tag "Always create non-existent dirs" always)
+ (const :tag "Ask for user confirmation" ask))
+ :group 'dired
+ :version "27.1")
+
+(defun dired-maybe-create-dirs (dir)
+ "Create DIR if doesn't exist according to `dired-create-destination-dirs'."
+ (when (and dired-create-destination-dirs (not (file-exists-p dir)))
+ (if (or (eq dired-create-destination-dirs 'always)
+ (yes-or-no-p (format "Create destination dir `%s'? " dir)))
+ (dired-create-directory dir))))
+
(defun dired-copy-file-recursive (from to ok-flag &optional
preserve-time top recursive)
- (when (and (eq t (car (file-attributes from)))
+ (when (and (eq t (file-attribute-type (file-attributes from)))
(file-in-directory-p to from))
(error "Cannot copy `%s' into its subdirectory `%s'" from to))
(let ((attrs (file-attributes from)))
(if (and recursive
- (eq t (car attrs))
+ (eq t (file-attribute-type attrs))
(or (eq recursive 'always)
(yes-or-no-p (format "Recursive copies of %s? " from))))
(copy-directory from to preserve-time)
(or top (dired-handle-overwrite to))
(condition-case err
- (if (stringp (car attrs))
+ (if (stringp (file-attribute-type attrs))
;; It is a symlink
- (make-symbolic-link (car attrs) to ok-flag)
+ (make-symbolic-link (file-attribute-type attrs) to ok-flag)
+ (dired-maybe-create-dirs (file-name-directory to))
(copy-file from to ok-flag preserve-time))
(file-date-error
(push (dired-make-relative from)
@@ -1582,6 +1608,7 @@ Special value `always' suppresses confirmation."
;;;###autoload
(defun dired-rename-file (file newname ok-if-already-exists)
(dired-handle-overwrite newname)
+ (dired-maybe-create-dirs (file-name-directory newname))
(rename-file file newname ok-if-already-exists) ; error is caught in -create-files
;; Silently rename the visited file of any buffer visiting this file.
(and (get-file-buffer file)
@@ -1751,7 +1778,7 @@ ESC or `q' to not overwrite any of the remaining files,
(setq to destname))
;; If DESTNAME is a subdirectory of FROM, not a symlink,
;; and the method in use is copying, signal an error.
- (and (eq t (car (file-attributes destname)))
+ (and (eq t (file-attribute-type (file-attributes destname)))
(eq file-creator 'dired-copy-file)
(file-in-directory-p destname from)
(error "Cannot copy `%s' into its subdirectory `%s'"
@@ -1834,7 +1861,7 @@ Optional arg HOW-TO determines how to treat the target.
arguments for the function that is the first element of the list.
For any other return value, TARGET is treated as a directory."
(or op1 (setq op1 operation))
- (let* ((fn-list (dired-get-marked-files nil arg))
+ (let* ((fn-list (dired-get-marked-files nil arg nil nil t))
(rfn-list (mapcar #'dired-make-relative fn-list))
(dired-one-file ; fluid variable inside dired-create-files
(and (consp fn-list) (null (cdr fn-list)) (car fn-list)))
@@ -1852,28 +1879,31 @@ Optional arg HOW-TO determines how to treat the target.
(dired-mark-read-file-name
(concat (if dired-one-file op1 operation) " %s to: ")
target-dir op-symbol arg rfn-list default))))
- (into-dir (cond ((null how-to)
- ;; Allow users to change the letter case of
- ;; a directory on a case-insensitive
- ;; filesystem. If we don't test these
- ;; conditions up front, file-directory-p
- ;; below will return t on a case-insensitive
- ;; filesystem, and Emacs will try to move
- ;; foo -> foo/foo, which fails.
- (if (and (file-name-case-insensitive-p (car fn-list))
- (eq op-symbol 'move)
- dired-one-file
- (string= (downcase
- (expand-file-name (car fn-list)))
- (downcase
- (expand-file-name target)))
- (not (string=
- (file-name-nondirectory (car fn-list))
- (file-name-nondirectory target))))
- nil
- (file-directory-p target)))
- ((eq how-to t) nil)
- (t (funcall how-to target)))))
+ (into-dir
+ (progn
+ (unless dired-one-file (dired-maybe-create-dirs target))
+ (cond ((null how-to)
+ ;; Allow users to change the letter case of
+ ;; a directory on a case-insensitive
+ ;; filesystem. If we don't test these
+ ;; conditions up front, file-directory-p
+ ;; below will return t on a case-insensitive
+ ;; filesystem, and Emacs will try to move
+ ;; foo -> foo/foo, which fails.
+ (if (and (file-name-case-insensitive-p (car fn-list))
+ (eq op-symbol 'move)
+ dired-one-file
+ (string= (downcase
+ (expand-file-name (car fn-list)))
+ (downcase
+ (expand-file-name target)))
+ (not (string=
+ (file-name-nondirectory (car fn-list))
+ (file-name-nondirectory target))))
+ nil
+ (file-directory-p target)))
+ ((eq how-to t) nil)
+ (t (funcall how-to target))))))
(if (and (consp into-dir) (functionp (car into-dir)))
(apply (car into-dir) operation rfn-list fn-list target (cdr into-dir))
(if (not (or dired-one-file into-dir))
@@ -1972,6 +2002,19 @@ Optional arg HOW-TO determines how to treat the target.
dired-dirs)))
+
+;; We use this function in `dired-create-directory' and
+;; `dired-create-empty-file'; the return value is the new entry
+;; in the updated Dired buffer.
+(defun dired--find-topmost-parent-dir (filename)
+ "Return the topmost nonexistent parent dir of FILENAME.
+FILENAME is a full file name."
+ (let ((try filename) new)
+ (while (and try (not (file-exists-p try)) (not (equal new try)))
+ (setq new try
+ try (directory-file-name (file-name-directory try))))
+ new))
+
;;;###autoload
(defun dired-create-directory (directory)
"Create a directory called DIRECTORY.
@@ -1980,18 +2023,32 @@ If DIRECTORY already exists, signal an error."
(interactive
(list (read-file-name "Create directory: " (dired-current-directory))))
(let* ((expanded (directory-file-name (expand-file-name directory)))
- (try expanded) new)
+ new)
(if (file-exists-p expanded)
(error "Cannot create directory %s: file exists" expanded))
- ;; Find the topmost nonexistent parent dir (variable `new')
- (while (and try (not (file-exists-p try)) (not (equal new try)))
- (setq new try
- try (directory-file-name (file-name-directory try))))
+ (setq new (dired--find-topmost-parent-dir expanded))
(make-directory expanded t)
(when new
(dired-add-file new)
(dired-move-to-filename))))
+;;;###autoload
+(defun dired-create-empty-file (file)
+ "Create an empty file called FILE.
+ Add a new entry for the new file in the Dired buffer.
+ Parent directories of FILE are created as needed.
+ If FILE already exists, signal an error."
+ (interactive (list (read-file-name "Create empty file: ")))
+ (let* ((expanded (expand-file-name file))
+ new)
+ (if (file-exists-p expanded)
+ (error "Cannot create file %s: file exists" expanded))
+ (setq new (dired--find-topmost-parent-dir expanded))
+ (make-empty-file file 'parents)
+ (when new
+ (dired-add-file new)
+ (dired-move-to-filename))))
+
(defun dired-into-dir-with-symlinks (target)
(and (file-directory-p target)
(not (file-symlink-p target))))
@@ -2506,7 +2563,7 @@ Optional third arg LIMIT (>= 1) is a limit to the length of the
resulting list.
Thus, if SEP is a regexp that only matches itself,
- (mapconcat 'identity (dired-split SEP STRING) SEP)
+ (mapconcat #'identity (dired-split SEP STRING) SEP)
is always equal to STRING."
(let* ((start (string-match pat str))
@@ -2554,7 +2611,7 @@ When called interactively and not on a subdir line, go to this subdir's line."
(defun dired-goto-subdir (dir)
"Go to end of header line of DIR in this dired buffer.
Return value of point on success, otherwise return nil.
-The next char is either \\n, or \\r if DIR is hidden."
+The next char is \\n."
(interactive
(prog1 ; let push-mark display its message
(list (expand-file-name
@@ -2569,8 +2626,8 @@ The next char is either \\n, or \\r if DIR is hidden."
(and elt
(goto-char (dired-get-subdir-min elt))
;; dired-subdir-hidden-p and dired-add-entry depend on point being
- ;; at either \r or \n after this function succeeds.
- (progn (skip-chars-forward "^\r\n")
+ ;; at \n after this function succeeds.
+ (progn (end-of-line)
(point)))))
;;;###autoload
@@ -2643,18 +2700,13 @@ Lower levels are unaffected."
;;; hiding
(defun dired-unhide-subdir ()
- (let (buffer-read-only)
- (subst-char-in-region (dired-subdir-min) (dired-subdir-max) ?\r ?\n)))
-
-(defun dired-hide-check ()
- (or selective-display
- (error "selective-display must be t for subdir hiding to work!")))
+ (with-silent-modifications
+ (dired--unhide (dired-subdir-min) (dired-subdir-max))))
(defun dired-subdir-hidden-p (dir)
- (and selective-display
- (save-excursion
- (dired-goto-subdir dir)
- (= (following-char) ?\r))))
+ (save-excursion
+ (dired-goto-subdir dir)
+ (dired--hidden-p)))
;;;###autoload
(defun dired-hide-subdir (arg)
@@ -2662,8 +2714,7 @@ Lower levels are unaffected."
Optional prefix arg is a repeat factor.
Use \\[dired-hide-all] to (un)hide all directories."
(interactive "p")
- (dired-hide-check)
- (let ((modflag (buffer-modified-p)))
+ (with-silent-modifications
(while (>= (setq arg (1- arg)) 0)
(let* ((cur-dir (dired-current-directory))
(hidden-p (dired-subdir-hidden-p cur-dir))
@@ -2672,12 +2723,11 @@ Use \\[dired-hide-all] to (un)hide all directories."
buffer-read-only)
;; keep header line visible, hide rest
(goto-char (dired-get-subdir-min elt))
- (skip-chars-forward "^\n\r")
+ (end-of-line)
(if hidden-p
- (subst-char-in-region (point) end-pos ?\r ?\n)
- (subst-char-in-region (point) end-pos ?\n ?\r)))
- (dired-next-subdir 1 t))
- (restore-buffer-modified-p modflag)))
+ (dired--unhide (point) end-pos)
+ (dired--hide (point) end-pos)))
+ (dired-next-subdir 1 t))))
;;;###autoload
(defun dired-hide-all (&optional ignored)
@@ -2685,28 +2735,20 @@ Use \\[dired-hide-all] to (un)hide all directories."
If there is already something hidden, make everything visible again.
Use \\[dired-hide-subdir] to (un)hide a particular subdirectory."
(interactive "P")
- (dired-hide-check)
- (let ((modflag (buffer-modified-p))
- buffer-read-only)
- (if (save-excursion
- (goto-char (point-min))
- (search-forward "\r" nil t))
- ;; unhide - bombs on \r in filenames
- (subst-char-in-region (point-min) (point-max) ?\r ?\n)
+ (with-silent-modifications
+ (if (text-property-any (point-min) (point-max) 'invisible 'dired)
+ (dired--unhide (point-min) (point-max))
;; hide
- (let ((pos (point-max)) ; pos of end of last directory
- (alist dired-subdir-alist))
- (while alist ; while there are dirs before pos
- (subst-char-in-region (dired-get-subdir-min (car alist)) ; pos of prev dir
- (save-excursion
- (goto-char pos) ; current dir
- ;; we're somewhere on current dir's line
- (forward-line -1)
- (point))
- ?\n ?\r)
- (setq pos (dired-get-subdir-min (car alist))) ; prev dir gets current dir
- (setq alist (cdr alist)))))
- (restore-buffer-modified-p modflag)))
+ (let ((pos (point-max))) ; pos of end of last directory
+ (dolist (subdir dired-subdir-alist)
+ (let ((start (dired-get-subdir-min subdir)) ; pos of prev dir
+ (end (save-excursion
+ (goto-char pos) ; current dir
+ ;; we're somewhere on current dir's line
+ (forward-line -1)
+ (point))))
+ (dired--hide start end))
+ (setq pos (dired-get-subdir-min subdir))))))) ; prev dir gets current dir
;;;###end dired-ins.el
@@ -2732,8 +2774,8 @@ When off, it uses the original predicate."
nil nil nil
(if dired-isearch-filenames-mode
(add-function :before-while (local 'isearch-filter-predicate)
- #'dired-isearch-filter-filenames
- '((isearch-message-prefix . "filename ")))
+ #'dired-isearch-filter-filenames
+ '((isearch-message-prefix . "filename ")))
(remove-function (local 'isearch-filter-predicate)
#'dired-isearch-filter-filenames))
(when isearch-mode
@@ -2749,13 +2791,15 @@ Intended to be added to `isearch-mode-hook'."
(get-text-property (point) 'dired-filename)))
(define-key isearch-mode-map "\M-sff" 'dired-isearch-filenames-mode)
(dired-isearch-filenames-mode 1)
- (add-hook 'isearch-mode-end-hook 'dired-isearch-filenames-end nil t)))
+ (add-hook 'isearch-mode-end-hook #'dired-isearch-filenames-end nil t)))
(defun dired-isearch-filenames-end ()
"Clean up the Dired file name search after terminating isearch."
(define-key isearch-mode-map "\M-sff" nil)
(dired-isearch-filenames-mode -1)
- (remove-hook 'isearch-mode-end-hook 'dired-isearch-filenames-end t))
+ (remove-hook 'isearch-mode-end-hook #'dired-isearch-filenames-end t)
+ (unless isearch-suspended
+ (custom-reevaluate-setting 'dired-isearch-filenames)))
(defun dired-isearch-filter-filenames (beg end)
"Test whether some part of the current search match is inside a file name.
@@ -2768,15 +2812,15 @@ is part of a file name (i.e., has the text property `dired-filename')."
(defun dired-isearch-filenames ()
"Search for a string using Isearch only in file names in the Dired buffer."
(interactive)
- (let ((dired-isearch-filenames t))
- (isearch-forward nil t)))
+ (setq dired-isearch-filenames t)
+ (isearch-forward nil t))
;;;###autoload
(defun dired-isearch-filenames-regexp ()
"Search for a regexp using Isearch only in file names in the Dired buffer."
(interactive)
- (let ((dired-isearch-filenames t))
- (isearch-forward-regexp nil t)))
+ (setq dired-isearch-filenames t)
+ (isearch-forward-regexp nil t))
;; Functions for searching in tags style among marked files.
@@ -2786,14 +2830,14 @@ is part of a file name (i.e., has the text property `dired-filename')."
"Search for a string through all marked files using Isearch."
(interactive)
(multi-isearch-files
- (dired-get-marked-files nil nil 'dired-nondirectory-p)))
+ (dired-get-marked-files nil nil #'dired-nondirectory-p nil t)))
;;;###autoload
(defun dired-do-isearch-regexp ()
"Search for a regexp through all marked files using Isearch."
(interactive)
(multi-isearch-files-regexp
- (dired-get-marked-files nil nil 'dired-nondirectory-p)))
+ (dired-get-marked-files nil nil 'dired-nondirectory-p nil t)))
;;;###autoload
(defun dired-do-search (regexp)
@@ -2801,7 +2845,11 @@ is part of a file name (i.e., has the text property `dired-filename')."
Stops when a match is found.
To continue searching for next match, use command \\[tags-loop-continue]."
(interactive "sSearch marked files (regexp): ")
- (tags-search regexp '(dired-get-marked-files nil nil 'dired-nondirectory-p)))
+ (fileloop-initialize-search
+ regexp
+ (dired-get-marked-files nil nil #'dired-nondirectory-p)
+ 'default)
+ (fileloop-continue))
;;;###autoload
(defun dired-do-query-replace-regexp (from to &optional delimited)
@@ -2814,13 +2862,16 @@ with the command \\[tags-loop-continue]."
(query-replace-read-args
"Query replace regexp in marked files" t t)))
(list (nth 0 common) (nth 1 common) (nth 2 common))))
- (dolist (file (dired-get-marked-files nil nil 'dired-nondirectory-p))
+ (dolist (file (dired-get-marked-files nil nil #'dired-nondirectory-p nil t))
(let ((buffer (get-file-buffer file)))
(if (and buffer (with-current-buffer buffer
buffer-read-only))
(error "File `%s' is visited read-only" file))))
- (tags-query-replace from to delimited
- '(dired-get-marked-files nil nil 'dired-nondirectory-p)))
+ (fileloop-initialize-replace
+ from to (dired-get-marked-files nil nil #'dired-nondirectory-p)
+ (if (equal from (downcase from)) nil 'default)
+ delimited)
+ (fileloop-continue))
(declare-function xref--show-xrefs "xref")
(declare-function xref-query-replace-in-results "xref")
@@ -2837,11 +2888,11 @@ REGEXP should use constructs supported by your local `grep' command."
(interactive "sSearch marked files (regexp): ")
(require 'grep)
(defvar grep-find-ignored-files)
- (defvar grep-find-ignored-directories)
- (let* ((files (dired-get-marked-files))
+ (declare-function rgrep-find-ignored-directories "grep" (dir))
+ (let* ((files (dired-get-marked-files nil nil nil nil t))
(ignores (nconc (mapcar
- (lambda (s) (concat s "/"))
- grep-find-ignored-directories)
+ #'file-name-as-directory
+ (rgrep-find-ignored-directories default-directory))
grep-find-ignored-files))
(xrefs (mapcan
(lambda (file)
diff --git a/lisp/dired-x.el b/lisp/dired-x.el
index 2f2a32e0a6b..defc541ddc9 100644
--- a/lisp/dired-x.el
+++ b/lisp/dired-x.el
@@ -137,13 +137,8 @@ folding to be used on case-insensitive filesystems only."
(file-name-case-insensitive-p dir)
dired-omit-case-fold))
-;; For backward compatibility
-(define-obsolete-variable-alias 'dired-omit-files-p 'dired-omit-mode "22.1")
(define-minor-mode dired-omit-mode
"Toggle omission of uninteresting files in Dired (Dired-Omit mode).
-With a prefix argument ARG, enable Dired-Omit mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Dired-Omit mode is a buffer-local minor mode. When enabled in a
Dired buffer, Dired does not list files whose filenames match
@@ -194,21 +189,6 @@ toggle between those two."
:type 'boolean
:group 'dired-x)
-(defcustom dired-enable-local-variables t
- "Control use of local-variables lists in Dired.
-This temporarily overrides the value of `enable-local-variables' when
-listing a directory. See also `dired-local-variables-file'."
- :risky t
- :type '(choice (const :tag "Query Unsafe" t)
- (const :tag "Safe Only" :safe)
- (const :tag "Do all" :all)
- (const :tag "Ignore" nil)
- (other :tag "Query" other))
- :group 'dired-x)
-
-(make-obsolete-variable 'dired-enable-local-variables
- "use a standard `dir-locals-file' instead." "24.1")
-
(defcustom dired-guess-shell-gnutar
(catch 'found
(dolist (exe '("tar" "gtar"))
@@ -332,7 +312,6 @@ See also the functions:
`dired-do-find-marked-files'"
(interactive)
;; These must be done in each new dired buffer.
- (dired-hack-local-variables)
(dired-omit-startup))
@@ -466,6 +445,7 @@ See variables `dired-texinfo-unclean-extensions',
dired-tex-unclean-extensions
(list ".dvi"))))
+(defvar archive-superior-buffer)
(defvar tar-superior-buffer)
;;; JUMP.
@@ -482,8 +462,14 @@ Interactively with prefix argument, read FILE-NAME."
(interactive
(list nil (and current-prefix-arg
(read-file-name "Jump to Dired file: "))))
- (if (bound-and-true-p tar-subfile-mode)
- (switch-to-buffer tar-superior-buffer)
+ (cond
+ ((and (bound-and-true-p archive-subfile-mode)
+ (buffer-live-p archive-superior-buffer))
+ (switch-to-buffer archive-superior-buffer))
+ ((and (bound-and-true-p tar-subfile-mode)
+ (buffer-live-p tar-superior-buffer))
+ (switch-to-buffer tar-superior-buffer))
+ (t
;; Expand file-name before `dired-goto-file' call:
;; `dired-goto-file' requires its argument to be an absolute
;; file name; the result of `read-file-name' could be
@@ -511,7 +497,7 @@ Interactively with prefix argument, read FILE-NAME."
;; Toggle omitting, if it is on, and try again.
(when dired-omit-mode
(dired-omit-mode)
- (dired-goto-file file))))))))
+ (dired-goto-file file)))))))))
;;;###autoload
(defun dired-jump-other-window (&optional file-name)
@@ -787,34 +773,6 @@ Also useful for `auto-mode-alist' like this:
;; mechanism is provided for special handling of the working directory in
;; special major modes.
-(define-obsolete-variable-alias 'default-directory-alist
- 'dired-default-directory-alist "24.1")
-
-;; It's easier to add to this alist than redefine function
-;; default-directory while keeping the old information.
-(defconst dired-default-directory-alist
- '((dired-mode . (if (fboundp 'dired-current-directory)
- (dired-current-directory)
- default-directory)))
- "Alist of major modes and their opinion on `default-directory'.
-Each element has the form (MAJOR . EXPRESSION).
-The function `dired-default-directory' evaluates EXPRESSION to
-determine a default directory.")
-
-(put 'dired-default-directory-alist 'risky-local-variable t) ; gets eval'd
-(make-obsolete-variable 'dired-default-directory-alist
- "this feature is due to be removed." "24.1")
-
-(defun dired-default-directory ()
- "Return the `dired-default-directory-alist' entry for the current major-mode.
-If none, return `default-directory'."
- ;; It looks like this was intended to be something of a "general"
- ;; feature, but it only ever seems to have been used in
- ;; dired-smart-shell-command, and doesn't seem worth keeping around.
- (declare (obsolete nil "24.1"))
- (or (eval (cdr (assq major-mode dired-default-directory-alist)))
- default-directory))
-
(defun dired-smart-shell-command (command &optional output-buffer error-buffer)
"Like function `shell-command', but in the current Virtual Dired directory."
(interactive
@@ -831,85 +789,6 @@ If none, return `default-directory'."
(shell-command command output-buffer error-buffer)))
-;;; LOCAL VARIABLES FOR DIRED BUFFERS.
-
-;; Brief Description (This feature is obsolete as of Emacs 24.1)
-;;
-;; * `dired-extra-startup' is part of the `dired-mode-hook'.
-;;
-;; * `dired-extra-startup' calls `dired-hack-local-variables'
-;;
-;; * `dired-hack-local-variables' checks the value of
-;; `dired-local-variables-file'
-;;
-;; * Check if `dired-local-variables-file' is a non-nil string and is a
-;; filename found in the directory of the Dired Buffer being created.
-;;
-;; * If `dired-local-variables-file' satisfies the above, then temporarily
-;; include it in the Dired Buffer at the bottom.
-;;
-;; * Set `enable-local-variables' temporarily to the user variable
-;; `dired-enable-local-variables' and run `hack-local-variables' on the
-;; Dired Buffer.
-
-(defcustom dired-local-variables-file (convert-standard-filename ".dired")
- "Filename, as string, containing local Dired buffer variables to be hacked.
-If this file found in current directory, then it will be inserted into dired
-buffer and `hack-local-variables' will be run. See Info node
-`(emacs)File Variables' for more information on local variables.
-See also `dired-enable-local-variables'."
- :type 'file
- :group 'dired)
-
-(make-obsolete-variable 'dired-local-variables-file 'dir-locals-file "24.1")
-
-(defun dired-hack-local-variables ()
- "Evaluate local variables in `dired-local-variables-file' for Dired buffer."
- (declare (obsolete hack-dir-local-variables-non-file-buffer "24.1"))
- (and (stringp dired-local-variables-file)
- (file-exists-p dired-local-variables-file)
- (let ((opoint (point-max))
- (inhibit-read-only t)
- ;; In case user has `enable-local-variables' set to nil we
- ;; override it locally with dired's variable.
- (enable-local-variables dired-enable-local-variables))
- ;; Insert 'em.
- (save-excursion
- (goto-char opoint)
- (insert "\^L\n")
- (insert-file-contents dired-local-variables-file))
- ;; Hack 'em.
- (unwind-protect
- (let ((buffer-file-name dired-local-variables-file))
- (hack-local-variables))
- ;; Delete this stuff: `eobp' is used to find last subdir by dired.el.
- (delete-region opoint (point-max)))
- ;; Make sure that the mode line shows the proper information.
- (dired-sort-set-mode-line))))
-
-;; Does not seem worth a dedicated command.
-;; See the more general features in files-x.el.
-(defun dired-omit-here-always ()
- "Create `dir-locals-file' setting `dired-omit-mode' to t in `dired-mode'.
-If in a Dired buffer, reverts it."
- (declare (obsolete add-dir-local-variable "24.1"))
- (interactive)
- (if (file-exists-p dired-local-variables-file)
- (error "Old-style dired-local-variables-file `./%s' found;
-replace it with a dir-locals-file `./%s'"
- dired-local-variables-file
- dir-locals-file))
- (if (file-exists-p dir-locals-file)
- (message "File `./%s' already exists." dir-locals-file)
- (add-dir-local-variable 'dired-mode 'subdirs nil)
- (add-dir-local-variable 'dired-mode 'dired-omit-mode t)
- ;; Run extra-hooks and revert directory.
- (when (derived-mode-p 'dired-mode)
- (hack-dir-local-variables-non-file-buffer)
- (dired-extra-startup)
- (dired-revert))))
-
-
;;; GUESS SHELL COMMAND.
;; Brief Description:
@@ -1335,7 +1214,8 @@ displayed this way is restricted by the height of the current window and
To keep Dired buffer displayed, type \\[split-window-below] first.
To display just marked files, type \\[delete-other-windows] first."
(interactive "P")
- (dired-simultaneous-find-file (dired-get-marked-files) noselect))
+ (dired-simultaneous-find-file (dired-get-marked-files nil nil nil nil t)
+ noselect))
(defun dired-simultaneous-find-file (file-list noselect)
"Visit all files in FILE-LIST and display them simultaneously.
diff --git a/lisp/dired.el b/lisp/dired.el
index c831c5e93da..63082fe3927 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -201,8 +201,10 @@ The target is used in the prompt for file copy, rename etc."
; These variables were deleted and the replacements are on files.el.
; We leave aliases behind for back-compatibility.
-(defvaralias 'dired-free-space-program 'directory-free-space-program)
-(defvaralias 'dired-free-space-args 'directory-free-space-args)
+(define-obsolete-variable-alias 'dired-free-space-program
+ 'directory-free-space-program "27.1")
+(define-obsolete-variable-alias 'dired-free-space-args
+ 'directory-free-space-args "27.1")
;;; Hook variables
@@ -323,7 +325,7 @@ The directory name must be absolute, but need not be fully expanded.")
(put 'dired-actual-switches 'safe-local-variable 'dired-safe-switches-p)
-(defvar dired-re-inode-size "[0-9 \t]*[.,0-9]*[BkKMGTPEZY]?[ \t]*"
+(defvar dired-re-inode-size "[0-9 \t]*[.,0-9]*[BkKMGTPEZY]?[ \t]*"
"Regexp for optional initial inode and file size as made by `ls -i -s'.")
;; These regexps must be tested at beginning-of-line, but are also
@@ -362,12 +364,12 @@ This is an alist of the form (SUBDIR . SWITCHES).")
(defvaralias 'dired-move-to-filename-regexp
'directory-listing-before-filename-regexp)
-(defvar dired-subdir-regexp "^. \\([^\n\r]+\\)\\(:\\)[\n\r]"
+(defvar dired-subdir-regexp "^. \\(.+\\)\\(:\\)\n"
"Regexp matching a maybe hidden subdirectory line in `ls -lR' output.
Subexpression 1 is the subdirectory proper, no trailing colon.
The match starts at the beginning of the line and ends after the end
-of the line (\\n or \\r).
-Subexpression 2 must end right before the \\n or \\r.")
+of the line.
+Subexpression 2 must end right before the \\n.")
(defgroup dired-faces nil
"Faces used by Dired."
@@ -546,7 +548,7 @@ Return value is the number of files marked, or nil if none were marked."
(setq count 0)
(when ,msg
(message "%s %ss%s..."
- (cond ((eq dired-marker-char ?\040) "Unmarking")
+ (cond ((eq dired-marker-char ?\s) "Unmarking")
((eq dired-del-marker dired-marker-char)
"Flagging")
(t "Marking"))
@@ -566,7 +568,7 @@ Return value is the number of files marked, or nil if none were marked."
count
,msg
(dired-plural-s count)
- (if (eq dired-marker-char ?\040) "un" "")
+ (if (eq dired-marker-char ?\s) "un" "")
(if (eq dired-marker-char dired-del-marker)
"flagged" "marked"))))
(and (> count 0) count)))
@@ -646,7 +648,7 @@ marked file, return (t FILENAME) instead of (FILENAME)."
;; save-excursion loses, again
(dired-move-to-filename)))
-(defun dired-get-marked-files (&optional localp arg filter distinguish-one-marked)
+(defun dired-get-marked-files (&optional localp arg filter distinguish-one-marked error)
"Return the marked files' names as list of strings.
The list is in the same order as the buffer, that is, the car is the
first marked file.
@@ -663,7 +665,10 @@ Optional third argument FILTER, if non-nil, is a function to select
If DISTINGUISH-ONE-MARKED is non-nil, then if we find just one marked file,
return (t FILENAME) instead of (FILENAME).
-Don't use that together with FILTER."
+Don't use that together with FILTER.
+
+If ERROR is non-nil, signal an error when the list of found files is empty.
+ERROR can be a string with the error message."
(let ((all-of-them
(save-excursion
(delq nil (dired-map-over-marks
@@ -673,13 +678,17 @@ Don't use that together with FILTER."
(when (equal all-of-them '(t))
(setq all-of-them nil))
(if (not filter)
- (if (and distinguish-one-marked (eq (car all-of-them) t))
- all-of-them
- (nreverse all-of-them))
+ (setq result
+ (if (and distinguish-one-marked (eq (car all-of-them) t))
+ all-of-them
+ (nreverse all-of-them)))
(dolist (file all-of-them)
(if (funcall filter file)
- (push file result)))
- result)))
+ (push file result))))
+ (when (and (null result) error)
+ (user-error (if (stringp error) error "No files specified")))
+ result))
+
;; The dired command
@@ -765,6 +774,15 @@ as an argument to `dired-goto-file'."
(file-name-as-directory (abbreviate-file-name filename))
(abbreviate-file-name filename)))))
+(defun dired-grep-read-files ()
+ "Use file at point as the file for grep's default file-name pattern suggestion.
+If a directory or nothing is found at point, return nil."
+ (let ((file-name (dired-file-name-at-point)))
+ (if (and file-name
+ (not (file-directory-p file-name)))
+ file-name)))
+(put 'dired-mode 'grep-read-files 'dired-grep-read-files)
+
;;;###autoload (define-key ctl-x-map "d" 'dired)
;;;###autoload
(defun dired (dirname &optional switches)
@@ -841,17 +859,21 @@ If DIRNAME is already in a Dired buffer, that buffer is used without refresh."
(not (let ((attributes (file-attributes dirname))
(modtime (visited-file-modtime)))
(or (eq modtime 0)
- (not (eq (car attributes) t))
- (equal (nth 5 attributes) modtime)))))
+ (not (eq (file-attribute-type attributes) t))
+ (equal (file-attribute-modification-time attributes) modtime)))))
+
+(defvar auto-revert-remote-files)
(defun dired-buffer-stale-p (&optional noconfirm)
"Return non-nil if current Dired buffer needs updating.
-If NOCONFIRM is non-nil, then this function always returns nil
-for a remote directory. This feature is used by Auto Revert mode."
+If NOCONFIRM is non-nil, then this function returns nil for a
+remote directory, unless `auto-revert-remote-files' is non-nil.
+This feature is used by Auto Revert mode."
(let ((dirname
(if (consp dired-directory) (car dired-directory) dired-directory)))
(and (stringp dirname)
- (not (when noconfirm (file-remote-p dirname)))
+ (not (when noconfirm (and (not auto-revert-remote-files)
+ (file-remote-p dirname))))
(file-readable-p dirname)
;; Do not auto-revert when the dired buffer can be currently
;; written by the user as in `wdired-mode'.
@@ -1079,7 +1101,8 @@ wildcards, erases the buffer, and builds the subdir-alist anew
(dired-build-subdir-alist)
(let ((attributes (file-attributes dirname)))
(if (eq (car attributes) t)
- (set-visited-file-modtime (nth 5 attributes))))
+ (set-visited-file-modtime (file-attribute-modification-time
+ attributes))))
(set-buffer-modified-p nil)
;; No need to narrow since the whole buffer contains just
;; dired-readin's output, nothing else. The hook can
@@ -1255,8 +1278,8 @@ If HDR is non-nil, insert a header line with the directory name."
;; as indicated by `ls-lisp-use-insert-directory-program'.
(not (and (featurep 'ls-lisp)
(null ls-lisp-use-insert-directory-program)))
- (not (and (featurep 'eshell)
- (bound-and-true-p eshell-ls-use-in-dired)))
+ ;; FIXME: Big ugly hack for Eshell's eshell-ls-use-in-dired.
+ (not (bound-and-true-p eshell-ls-use-in-dired))
(or (file-remote-p dir)
(if (eq dired-use-ls-dired 'unspecified)
;; Check whether "ls --dired" gives exit code 0, and
@@ -1433,7 +1456,8 @@ ARG and NOCONFIRM, passed from `revert-buffer', are ignored."
(dolist (dir hidden-subdirs)
(if (dired-goto-subdir dir)
(dired-hide-subdir 1))))
- (unless modflag (restore-buffer-modified-p nil)))
+ (unless modflag (restore-buffer-modified-p nil))
+ (hack-dir-local-variables-non-file-buffer))
;; outside of the let scope
;;; Might as well not override the user if the user changed this.
;;; (setq buffer-read-only t)
@@ -1463,12 +1487,36 @@ change; the point does."
(list w
(dired-get-filename nil t)
(line-number-at-pos (window-point w)))))
- (get-buffer-window-list nil 0 t))))
+ (get-buffer-window-list nil 0 t))
+ ;; For each window that showed the current buffer before, scan its
+ ;; list of previous buffers. For each association thus found save
+ ;; a triple <point, name, line> where 'point' is that window's
+ ;; window-point marker stored in the window's list of previous
+ ;; buffers, 'name' is the filename at the position of 'point' and
+ ;; 'line' is the line number at the position of 'point'.
+ (let ((buffer (current-buffer))
+ prevs)
+ (walk-windows
+ (lambda (window)
+ (let ((prev (assq buffer (window-prev-buffers window))))
+ (when prev
+ (with-current-buffer buffer
+ (save-excursion
+ (goto-char (nth 2 prev))
+ (setq prevs
+ (cons
+ (list (nth 2 prev)
+ (dired-get-filename nil t)
+ (line-number-at-pos (point)))
+ prevs)))))))
+ 'nomini t)
+ prevs)))
(defun dired-restore-positions (positions)
"Restore POSITIONS saved with `dired-save-positions'."
(let* ((buf-file-pos (nth 0 positions))
- (buffer (nth 0 buf-file-pos)))
+ (buffer (nth 0 buf-file-pos))
+ (prevs (nth 2 positions)))
(unless (and (nth 1 buf-file-pos)
(dired-goto-file (nth 1 buf-file-pos)))
(goto-char (point-min))
@@ -1482,13 +1530,26 @@ change; the point does."
(dired-goto-file (nth 1 win-file-pos)))
(goto-char (point-min))
(forward-line (1- (nth 2 win-file-pos)))
- (dired-move-to-filename)))))))
+ (dired-move-to-filename)))))
+ (when prevs
+ (with-current-buffer buffer
+ (save-excursion
+ (dolist (prev prevs)
+ (let ((point (nth 0 prev)))
+ ;; Sanity check of the point marker.
+ (when (and (markerp point)
+ (eq (marker-buffer point) buffer))
+ (unless (and (nth 1 prev)
+ (dired-goto-file (nth 1 prev)))
+ (goto-char (point-min))
+ (forward-line (1- (nth 2 prev))))
+ (dired-move-to-filename)
+ (move-marker point (point) buffer)))))))))
(defun dired-remember-marks (beg end)
"Return alist of files and their marks, from BEG to END."
- (if selective-display ; must unhide to make this work.
- (let ((inhibit-read-only t))
- (subst-char-in-region beg end ?\r ?\n)))
+ (if (dired--find-hidden-pos (point-min) (point-max))
+ (dired--unhide (point-min) (point-max))) ;Must unhide to make this work.
(let (fil chr alist)
(save-excursion
(goto-char beg)
@@ -1515,15 +1576,12 @@ Each element of ALIST looks like (FILE . MARKERCHAR)."
(defun dired-remember-hidden ()
"Return a list of names of subdirs currently hidden."
- (let ((l dired-subdir-alist) dir pos result)
- (while l
- (setq dir (car (car l))
- pos (cdr (car l))
- l (cdr l))
+ (let (result)
+ (pcase-dolist (`(,dir . ,pos) dired-subdir-alist)
(goto-char pos)
- (skip-chars-forward "^\r\n")
- (if (eq (following-char) ?\r)
- (setq result (cons dir result))))
+ (end-of-line)
+ (if (dired--hidden-p)
+ (push dir result)))
result))
(defun dired-insert-old-subdirs (old-subdir-alist)
@@ -1791,6 +1849,9 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST."
(define-key map [menu-bar immediate create-directory]
'(menu-item "Create Directory..." dired-create-directory
:help "Create a directory"))
+ (define-key map [menu-bar immediate create-empty-file]
+ '(menu-item "Create Empty file..." dired-create-empty-file
+ :help "Create an empty file"))
(define-key map [menu-bar immediate wdired-mode]
'(menu-item "Edit File Names" wdired-change-to-wdired-mode
:help "Put a Dired buffer in a mode in which filenames are editable"
@@ -2079,9 +2140,9 @@ Keybindings:
mode-name "Dired"
;; case-fold-search nil
buffer-read-only t
- selective-display t ; for subdirectory hiding
mode-line-buffer-identification
(propertized-buffer-identification "%17b"))
+ (add-to-invisibility-spec '(dired . t))
;; Ignore dired-hide-details-* value of invisible text property by default.
(when (eq buffer-invisibility-spec t)
(setq buffer-invisibility-spec (list t)))
@@ -2104,8 +2165,8 @@ Keybindings:
(when (featurep 'dnd)
(setq-local dnd-protocol-alist
(append dired-dnd-protocol-alist dnd-protocol-alist)))
- (add-hook 'file-name-at-point-functions 'dired-file-name-at-point nil t)
- (add-hook 'isearch-mode-hook 'dired-isearch-filenames-setup nil t)
+ (add-hook 'file-name-at-point-functions #'dired-file-name-at-point nil t)
+ (add-hook 'isearch-mode-hook #'dired-isearch-filenames-setup nil t)
(run-mode-hooks 'dired-mode-hook))
;; Idiosyncratic dired commands that don't deal with marks.
@@ -2201,7 +2262,7 @@ directory in another window."
(let ((raw (dired-get-filename nil t))
file-name)
(if (null raw)
- (error "No file on this line"))
+ (user-error "No file on this line"))
(setq file-name (file-name-sans-versions raw t))
(if (file-exists-p file-name)
file-name
@@ -2210,7 +2271,8 @@ directory in another window."
(error "File no longer exists; type `g' to update Dired buffer")))))
;; Force C-m keybinding rather than `f' or `e' in the mode doc:
-(define-obsolete-function-alias 'dired-advertised-find-file 'dired-find-file "23.2")
+(define-obsolete-function-alias 'dired-advertised-find-file
+ #'dired-find-file "23.2")
(defun dired-find-file ()
"In Dired, visit the file or directory named on this line."
(interactive)
@@ -2346,12 +2408,7 @@ Otherwise, an error occurs in these cases."
(setq start (match-end 0))))))
;; Hence we don't need to worry about converting `\\' back to `\'.
- (setq file (read (concat "\"" file "\"")))
- ;; The above `read' will return a unibyte string if FILE
- ;; contains eight-bit-control/graphic characters.
- (if (and enable-multibyte-characters
- (not (multibyte-string-p file)))
- (setq file (string-to-multibyte file)))))
+ (setq file (read (concat "\"" file "\"")))))
(and file (files--name-absolute-system-p file)
(setq already-absolute t))
(cond
@@ -2463,6 +2520,34 @@ See options: `dired-hide-details-hide-symlink-targets' and
'remove-from-invisibility-spec)
'dired-hide-details-link))
+;;; Functions to hide/unhide text
+
+(defun dired--find-hidden-pos (start end)
+ (text-property-any start end 'invisible 'dired))
+
+(defun dired--hidden-p (&optional pos)
+ (eq (get-char-property (or pos (point)) 'invisible) 'dired))
+
+(defun dired--hide (start end)
+ ;; The old code used selective-display which only works at
+ ;; a line-granularity, so it used start and end positions that where
+ ;; approximate ("anywhere on the line is fine").
+ (save-excursion
+ (put-text-property (progn (goto-char start) (line-end-position))
+ (progn (goto-char end) (line-end-position))
+ 'invisible 'dired)))
+
+(defun dired--unhide (start end)
+ ;; The old code used selective-display which only works at
+ ;; a line-granularity, so it used start and end positions that where
+ ;; approximate ("anywhere on the line is fine").
+ ;; FIXME: This also removes other invisible properties!
+ (save-excursion
+ (remove-text-properties
+ (progn (goto-char start) (line-end-position))
+ (progn (goto-char end) (line-end-position))
+ '(invisible))))
+
;;; Functions for finding the file name in a dired buffer line.
(defvar dired-permission-flags-regexp
@@ -2502,12 +2587,11 @@ Return the position of the beginning of the filename, or nil if none found."
;; This is the UNIX version.
(if (get-text-property (point) 'dired-filename)
(goto-char (next-single-property-change (point) 'dired-filename))
- (let (opoint file-type executable symlink hidden used-F eol)
- (setq used-F (dired-check-switches dired-actual-switches "F" "classify")
- opoint (point)
- eol (line-end-position)
- hidden (and selective-display
- (save-excursion (search-forward "\r" eol t))))
+ (let ((opoint (point))
+ (used-F (dired-check-switches dired-actual-switches "F" "classify"))
+ (eol (line-end-position))
+ (hidden (dired--hidden-p))
+ file-type executable symlink)
(if hidden
nil
(save-excursion ;; Find out what kind of file this is:
@@ -2744,7 +2828,7 @@ You can then feed the file name(s) to other commands with \\[yank]."
(if pos
(progn
(goto-char pos)
- (or no-skip (skip-chars-forward "^\n\r"))
+ (or no-skip (end-of-line))
(point))
(if no-error-if-not-found
nil ; return nil if not found
@@ -3033,10 +3117,10 @@ TRASH non-nil means to trash the file instead of deleting, provided
("no" ?n "skip to next")
("all" ?! "delete all remaining directories with no more questions")
("quit" ?q "exit")))
- ('"all" (setq recursive 'always dired-recursive-deletes recursive))
- ('"yes" (if (eq recursive 'top) (setq recursive 'always)))
- ('"no" (setq recursive nil))
- ('"quit" (keyboard-quit))
+ ("all" (setq recursive 'always dired-recursive-deletes recursive))
+ ("yes" (if (eq recursive 'top) (setq recursive 'always)))
+ ("no" (setq recursive nil))
+ ("quit" (keyboard-quit))
(_ (keyboard-quit))))) ; catch all unknown answers
(setq recursive nil)) ; Empty dir or recursive is nil.
(delete-directory file recursive trash))))
@@ -3095,7 +3179,7 @@ non-empty directories is allowed."
(dired-recursive-deletes dired-recursive-deletes)
(trashing (and trash delete-by-moving-to-trash)))
;; canonicalize file list for pop up
- (setq files (nreverse (mapcar #'dired-make-relative files)))
+ (setq files (mapcar #'dired-make-relative files))
(if (dired-mark-pop-up
" *Deletions*" 'delete files dired-deletion-confirmer
(format "%s %s "
@@ -3136,17 +3220,17 @@ non-empty directories is allowed."
(dired-move-to-filename))
(defun dired-fun-in-all-buffers (directory file fun &rest args)
- ;; In all buffers dired'ing DIRECTORY, run FUN with ARGS.
- ;; If the buffer has a wildcard pattern, check that it matches FILE.
- ;; (FILE does not include a directory component.)
- ;; FILE may be nil, in which case ignore it.
- ;; Return list of buffers where FUN succeeded (i.e., returned non-nil).
+ "In all buffers dired'ing DIRECTORY, run FUN with ARGS.
+If the buffer has a wildcard pattern, check that it matches FILE.
+(FILE does not include a directory component.)
+FILE may be nil, in which case ignore it.
+Return list of buffers where FUN succeeded (i.e., returned non-nil)."
(let (success-list)
- (dolist (buf (dired-buffers-for-dir (expand-file-name directory)
- file))
+ (dolist (buf (dired-buffers-for-dir (expand-file-name directory) file))
(with-current-buffer buf
(if (apply fun args)
- (setq success-list (cons (buffer-name buf) success-list)))))
+ (push buf success-list))))
+ ;; FIXME: AFAICT, this return value is not used by any of the callers!
success-list))
;; Delete the entry for FILE from
@@ -3379,7 +3463,7 @@ no ARGth marked file is found before this line."
(and (dired-goto-file file)
(progn
(beginning-of-line)
- (if (not (equal ?\040 (following-char)))
+ (if (not (equal ?\s (following-char)))
(following-char))))))
(defun dired-mark-files-in-region (start end)
@@ -3437,7 +3521,7 @@ If looking at a subdir, unmark all its files except `.' and `..'.
If the region is active in Transient Mark mode, unmark all files
in the active region."
(interactive (list current-prefix-arg t))
- (let ((dired-marker-char ?\040))
+ (let ((dired-marker-char ?\s))
(dired-mark arg interactive)))
(defun dired-flag-file-deletion (arg &optional interactive)
@@ -3476,11 +3560,11 @@ As always, hidden subdirs are not affected."
;; use subst instead of insdel because it does not move
;; the gap and thus should be faster and because
;; other characters are left alone automatically
- (apply 'subst-char-in-region
+ (apply #'subst-char-in-region
(point) (1+ (point))
- (if (eq ?\040 (following-char)) ; SPC
- (list ?\040 dired-marker-char)
- (list dired-marker-char ?\040))))
+ (if (eq ?\s (following-char))
+ (list ?\s dired-marker-char)
+ (list dired-marker-char ?\s))))
(forward-line 1)))))
;;; Commands to mark or flag files based on their characteristics or names.
@@ -3511,7 +3595,7 @@ object files--just `.o' will mark more than you might think."
(dired-get-filename nil t) t))
"\\'"))))
'dired-regexp-history)
- (if current-prefix-arg ?\040)))
+ (if current-prefix-arg ?\s)))
(let ((dired-marker-char (or marker-char dired-marker-char)))
(dired-mark-if
(and (not (looking-at-p dired-re-dot))
@@ -3534,7 +3618,7 @@ since it was last visited."
(list (read-regexp (concat (if current-prefix-arg "Unmark" "Mark")
" files containing (regexp): ")
nil 'dired-regexp-history)
- (if current-prefix-arg ?\040)))
+ (if current-prefix-arg ?\s)))
(let ((dired-marker-char (or marker-char dired-marker-char)))
(dired-mark-if
(and (not (looking-at-p dired-re-dot))
@@ -3571,14 +3655,14 @@ The match is against the non-directory part of the filename. Use `^'
"Mark all symbolic links.
With prefix argument, unmark or unflag all those files."
(interactive "P")
- (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char)))
+ (let ((dired-marker-char (if unflag-p ?\s dired-marker-char)))
(dired-mark-if (looking-at-p dired-re-sym) "symbolic link")))
(defun dired-mark-directories (unflag-p)
"Mark all directory file lines except `.' and `..'.
With prefix argument, unmark or unflag all those files."
(interactive "P")
- (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char)))
+ (let ((dired-marker-char (if unflag-p ?\s dired-marker-char)))
(dired-mark-if (and (looking-at-p dired-re-dir)
(not (looking-at-p dired-re-dot)))
"directory file")))
@@ -3587,7 +3671,7 @@ With prefix argument, unmark or unflag all those files."
"Mark all executable files.
With prefix argument, unmark or unflag all those files."
(interactive "P")
- (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char)))
+ (let ((dired-marker-char (if unflag-p ?\s dired-marker-char)))
(dired-mark-if (looking-at-p dired-re-exe) "executable file")))
;; dired-x.el has a dired-mark-sexp interactive command: mark
@@ -3597,7 +3681,7 @@ With prefix argument, unmark or unflag all those files."
"Flag for deletion files whose names suggest they are auto save files.
A prefix argument says to unmark or unflag those files instead."
(interactive "P")
- (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker)))
+ (let ((dired-marker-char (if unflag-p ?\s dired-del-marker)))
(dired-mark-if
;; It is less than general to check for # here,
;; but it's the only way this runs fast enough.
@@ -3836,7 +3920,7 @@ The idea is to set this buffer-locally in special Dired buffers.")
(force-mode-line-update)))
(define-obsolete-function-alias 'dired-sort-set-modeline
- 'dired-sort-set-mode-line "24.3")
+ #'dired-sort-set-mode-line "24.3")
(defun dired-sort-toggle-or-edit (&optional arg)
"Toggle sorting by date, and refresh the Dired buffer.
@@ -4078,7 +4162,7 @@ Ask means pop up a menu for the user to select one of copy, move or link."
(dired dired-dir)
;; The following elements of `misc-data' are the keys
;; from `dired-subdir-alist'.
- (mapc 'dired-maybe-insert-subdir (cdr misc-data))
+ (mapc #'dired-maybe-insert-subdir (cdr misc-data))
(current-buffer))
(message "Desktop: Directory %s no longer exists." dir)
(when desktop-missing-file-warning (sit-for 1))
diff --git a/lisp/dirtrack.el b/lisp/dirtrack.el
index e811ccfa846..0925a4de12a 100644
--- a/lisp/dirtrack.el
+++ b/lisp/dirtrack.el
@@ -184,9 +184,6 @@ and ends with a forward slash."
;;;###autoload
(define-minor-mode dirtrack-mode
"Toggle directory tracking in shell buffers (Dirtrack mode).
-With a prefix argument ARG, enable Dirtrack mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
This method requires that your shell prompt contain the current
working directory at all times, and that you set the variable
@@ -205,10 +202,7 @@ directory."
"23.1")
(define-obsolete-variable-alias 'dirtrack-debug 'dirtrack-debug-mode "23.1")
(define-minor-mode dirtrack-debug-mode
- "Toggle Dirtrack debugging.
-With a prefix argument ARG, enable Dirtrack debugging if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil."
+ "Toggle Dirtrack debugging."
nil nil nil
(if dirtrack-debug-mode
(display-buffer (get-buffer-create dirtrack-debug-buffer))))
diff --git a/lisp/disp-table.el b/lisp/disp-table.el
index f10fc0ebdc7..4a597506774 100644
--- a/lisp/disp-table.el
+++ b/lisp/disp-table.el
@@ -175,8 +175,8 @@ in the default way after this call."
(defun standard-display-g1 (c sc)
"Display character C as character SC in the g1 character set.
This function assumes that your terminal uses the SO/SI characters;
-it is meaningless for an X frame."
- (if (memq window-system '(x w32 ns))
+it is meaningless for a graphical frame."
+ (if (display-graphic-p)
(error "Cannot use string glyphs in a windowing system"))
(or standard-display-table
(setq standard-display-table (make-display-table)))
@@ -186,9 +186,9 @@ it is meaningless for an X frame."
;;;###autoload
(defun standard-display-graphic (c gc)
"Display character C as character GC in graphics character set.
-This function assumes VT100-compatible escapes; it is meaningless for an
-X frame."
- (if (memq window-system '(x w32 ns))
+This function assumes VT100-compatible escapes; it is meaningless
+for a graphical frame."
+ (if (display-graphic-p)
(error "Cannot use string glyphs in a windowing system"))
(or standard-display-table
(setq standard-display-table (make-display-table)))
@@ -226,7 +226,7 @@ X frame."
char
(let ((fid (face-id face)))
(if (< fid 64) ; we have 32 - 3(LSB) - 1(SIGN) - 22(CHAR) = 6 bits for face id
- (logior char (lsh fid 22))
+ (logior char (ash fid 22))
(cons char fid)))))
;;;###autoload
@@ -239,7 +239,7 @@ X frame."
;;;###autoload
(defun glyph-face (glyph)
"Return the face of glyph code GLYPH, or nil if glyph has default face."
- (let ((face-id (if (consp glyph) (cdr glyph) (lsh glyph -22))))
+ (let ((face-id (if (consp glyph) (cdr glyph) (ash glyph -22))))
(and (> face-id 0)
(catch 'face
(dolist (face (face-list))
@@ -276,7 +276,7 @@ in `.emacs'."
(progn
(standard-display-default
(unibyte-char-to-multibyte 160) (unibyte-char-to-multibyte 255))
- (unless (or (memq window-system '(x w32 ns)))
+ (unless (display-graphic-p)
(and (terminal-coding-system)
(set-terminal-coding-system nil))))
@@ -289,7 +289,7 @@ in `.emacs'."
;; unless some other has been specified.
(if (equal current-language-environment "English")
(set-language-environment "latin-1"))
- (unless (or noninteractive (memq window-system '(x w32 ns)))
+ (unless (or noninteractive (display-graphic-p))
;; Send those codes literally to a character-based terminal.
;; If we are using single-byte characters,
;; it doesn't matter which coding system we use.
diff --git a/lisp/dnd.el b/lisp/dnd.el
index 73703863e6b..459a7238dcd 100644
--- a/lisp/dnd.el
+++ b/lisp/dnd.el
@@ -130,6 +130,7 @@ Return nil if URI is not a local file."
(match-string 0 sysname)
sysname))))
(when (and hostname
+ (not (eq system-type 'windows-nt))
(or (string-equal "localhost" hostname)
(string-equal (downcase sysname) hostname)
(string-equal sysname-no-dot hostname)))
diff --git a/lisp/doc-view.el b/lisp/doc-view.el
index 4b21401e94c..a7069072603 100644
--- a/lisp/doc-view.el
+++ b/lisp/doc-view.el
@@ -155,12 +155,13 @@
(defcustom doc-view-ghostscript-program "gs"
"Program to convert PS and PDF files to PNG."
- :type 'file
- :group 'doc-view)
+ :type 'file)
(defcustom doc-view-pdfdraw-program
(cond
((executable-find "pdfdraw") "pdfdraw")
+ ((executable-find "mudraw") "mudraw")
+ ((executable-find "mutool") "mutool")
(t "mudraw"))
"Name of MuPDF's program to convert PDF files to PNG."
:type 'file
@@ -182,17 +183,20 @@
(defcustom doc-view-ghostscript-options
'("-dSAFER" ;; Avoid security problems when rendering files from untrusted
;; sources.
- "-dNOPAUSE" "-sDEVICE=png16m" "-dTextAlphaBits=4"
+ "-dNOPAUSE" "-dTextAlphaBits=4"
"-dBATCH" "-dGraphicsAlphaBits=4" "-dQUIET")
"A list of options to give to ghostscript."
- :type '(repeat string)
- :group 'doc-view)
+ :type '(repeat string))
+
+(defcustom doc-view-ghostscript-device "png16m"
+ "Output device to give to ghostscript."
+ :type 'string
+ :version "27.1")
(defcustom doc-view-resolution 100
"Dots per inch resolution used to render the documents.
Higher values result in larger images."
- :type 'number
- :group 'doc-view)
+ :type 'number)
(defcustom doc-view-scale-internally t
"Whether we should try to rescale images ourselves.
@@ -207,8 +211,7 @@ scaling."
Has only an effect if `doc-view-scale-internally' is non-nil and support for
scaling is compiled into emacs."
:version "24.1"
- :type 'number
- :group 'doc-view)
+ :type 'number)
(defcustom doc-view-dvipdfm-program "dvipdfm"
"Program to convert DVI files to PDF.
@@ -218,8 +221,7 @@ converted to PNG.
If this and `doc-view-dvipdf-program' are set,
`doc-view-dvipdf-program' will be preferred."
- :type 'file
- :group 'doc-view)
+ :type 'file)
(defcustom doc-view-dvipdf-program "dvipdf"
"Program to convert DVI files to PDF.
@@ -229,8 +231,7 @@ converted to PNG.
If this and `doc-view-dvipdfm-program' are set,
`doc-view-dvipdf-program' will be preferred."
- :type 'file
- :group 'doc-view)
+ :type 'file)
(define-obsolete-variable-alias 'doc-view-unoconv-program
'doc-view-odf->pdf-converter-program
@@ -245,8 +246,7 @@ If this and `doc-view-dvipdfm-program' are set,
Needed for viewing OpenOffice.org (and MS Office) files."
:version "24.4"
- :type 'file
- :group 'doc-view)
+ :type 'file)
(defcustom doc-view-odf->pdf-converter-function
(cond
@@ -267,22 +267,19 @@ Needed for viewing OpenOffice.org (and MS Office) files."
"Program to convert PS files to PDF.
PS files will be converted to PDF before searching is possible."
- :type 'file
- :group 'doc-view)
+ :type 'file)
(defcustom doc-view-pdftotext-program "pdftotext"
"Program to convert PDF files to plain text.
Needed for searching."
- :type 'file
- :group 'doc-view)
+ :type 'file)
(defcustom doc-view-cache-directory
(expand-file-name (format "docview%d" (user-uid))
temporary-file-directory)
"The base directory, where the PNG images will be saved."
- :type 'directory
- :group 'doc-view)
+ :type 'directory)
(defvar doc-view-conversion-buffer " *doc-view conversion output*"
"The buffer where messages from the converter programs go to.")
@@ -293,8 +290,7 @@ After such a refresh newly converted pages will be available for
viewing. If set to nil there won't be any refreshes and the
pages won't be displayed before conversion of the whole document
has finished."
- :type 'integer
- :group 'doc-view)
+ :type 'integer)
(defcustom doc-view-continuous nil
"In Continuous mode reaching the page edge advances to next/previous page.
@@ -302,7 +298,6 @@ When non-nil, scrolling a line upward at the bottom edge of the page
moves to the next page, and scrolling a line downward at the top edge
of the page moves to the previous page."
:type 'boolean
- :group 'doc-view
:version "23.2")
;;;; Internal Variables
@@ -354,9 +349,6 @@ of the page moves to the previous page."
(defvar doc-view--pending-cache-flush nil
"Only used internally.")
-(defvar doc-view--previous-major-mode nil
- "Only used internally.")
-
(defvar doc-view--buffer-file-name nil
"Only used internally.
The file name used for conversion. Normally it's the same as
@@ -415,6 +407,7 @@ Typically \"page-%s.png\".")
(define-key map "W" 'doc-view-fit-width-to-window)
(define-key map "H" 'doc-view-fit-height-to-window)
(define-key map "P" 'doc-view-fit-page-to-window)
+ (define-key map "F" 'doc-view-fit-window-to-page) ;F = frame
;; Killing the buffer (and the process)
(define-key map (kbd "K") 'doc-view-kill-proc)
;; Slicing the image
@@ -432,22 +425,20 @@ Typically \"page-%s.png\".")
(define-key map (kbd "C-c C-c") 'doc-view-toggle-display)
;; Open a new buffer with doc's text contents
(define-key map (kbd "C-c C-t") 'doc-view-open-text)
- ;; Reconvert the current document. Don't just use revert-buffer
- ;; because that resets the scale factor, the page number, ...
- (define-key map (kbd "g") 'doc-view-revert-buffer)
- (define-key map (kbd "r") 'doc-view-revert-buffer)
+ (define-key map (kbd "r") 'revert-buffer)
map)
"Keymap used by `doc-view-mode' when displaying a doc as a set of images.")
-(defun doc-view-revert-buffer (&optional ignore-auto noconfirm)
- "Like `revert-buffer', but preserves the buffer's current modes."
- (interactive (list (not current-prefix-arg)))
+(define-obsolete-function-alias 'doc-view-revert-buffer #'revert-buffer "27.1")
+(defvar revert-buffer-preserve-modes)
+(defun doc-view--revert-buffer (orig-fun &rest args)
+ "Preserve the buffer's current mode and check PDF sanity."
(if (< undo-outer-limit (* 2 (buffer-size)))
;; It's normal for this operation to result in a very large undo entry.
(setq-local undo-outer-limit (* 2 (buffer-size))))
(cl-labels ((revert ()
- (let (revert-buffer-function)
- (revert-buffer ignore-auto noconfirm 'preserve-modes))))
+ (let ((revert-buffer-preserve-modes t))
+ (apply orig-fun args))))
(if (and (eq 'pdf doc-view-doc-type)
(executable-find "pdfinfo"))
;; We don't want to revert if the PDF file is corrupted which
@@ -455,7 +446,7 @@ Typically \"page-%s.png\".")
;; file. (TODO: We'd like to have something like that also
;; for other types, at least PS, but I don't know a good way
;; to test if a PS file is complete.)
- (if (= 0 (call-process (executable-find "pdfinfo") nil nil nil
+ (if (= 0 (call-process "pdfinfo" nil nil nil
doc-view--buffer-file-name))
(revert)
(when (called-interactively-p 'interactive)
@@ -495,12 +486,14 @@ Typically \"page-%s.png\".")
;;;; Navigation Commands
+;; FIXME: The doc-view-current-* definitions below are macros because they
+;; map to accessors which we want to use via `setf' as well!
(defmacro doc-view-current-page (&optional win)
`(image-mode-window-get 'page ,win))
-(defmacro doc-view-current-info () `(image-mode-window-get 'info))
-(defmacro doc-view-current-overlay () `(image-mode-window-get 'overlay))
-(defmacro doc-view-current-image () `(image-mode-window-get 'image))
-(defmacro doc-view-current-slice () `(image-mode-window-get 'slice))
+(defmacro doc-view-current-info () '(image-mode-window-get 'info))
+(defmacro doc-view-current-overlay () '(image-mode-window-get 'overlay))
+(defmacro doc-view-current-image () '(image-mode-window-get 'image))
+(defmacro doc-view-current-slice () '(image-mode-window-get 'slice))
(defun doc-view-last-page-number ()
(length doc-view--current-files))
@@ -686,7 +679,7 @@ at the top edge of the page moves to the previous page."
(file-error
(error
(format "Unable to use temporary directory %s: %s"
- dir (mapconcat 'identity (cdr error) " "))))))))
+ dir (mapconcat #'identity (cdr error) " "))))))))
(defun doc-view--current-cache-dir ()
"Return the directory where the png files of the current doc should be saved.
@@ -875,6 +868,38 @@ min {(window-width / image-width), (window-height / image-height)} times."
(setf (doc-view-current-slice) new-slice)
(doc-view-goto-page (doc-view-current-page))))))
+(defun doc-view-fit-window-to-page ()
+ "Resize selected window so it just fits the current page.
+Resize the containing frame if needed."
+ (interactive)
+ (let* ((slice (doc-view-current-slice))
+ (img-width (if slice (nth 2 slice)
+ (car (image-display-size
+ (image-get-display-property) t))))
+ (img-height (if slice (nth 3 slice)
+ (cdr (image-display-size
+ (image-get-display-property) t))))
+ (win-width (- (nth 2 (window-inside-pixel-edges))
+ (nth 0 (window-inside-pixel-edges))))
+ (win-height (- (nth 3 (window-inside-pixel-edges))
+ (nth 1 (window-inside-pixel-edges))))
+ (width-diff (- img-width win-width))
+ (height-diff (- img-height win-height))
+ (new-frame-params
+ (append
+ (if (= (window-width) (frame-width))
+ `((width . (text-pixels
+ . ,(+ (frame-text-width) width-diff))))
+ (enlarge-window (/ width-diff (frame-char-width)) 'horiz)
+ nil)
+ (if (= (window-height) (frame-height))
+ `((height . (text-pixels
+ . ,(+ (frame-text-height) height-diff))))
+ (enlarge-window (/ height-diff (frame-char-height)) nil)
+ nil))))
+ (when new-frame-params
+ (modify-frame-parameters (selected-frame) new-frame-params))))
+
(defun doc-view-reconvert-doc ()
"Reconvert the current document.
Should be invoked when the cached images aren't up-to-date."
@@ -909,7 +934,7 @@ Should be invoked when the cached images aren't up-to-date."
(let* ((default-directory (or (unhandled-file-name-directory
default-directory)
(expand-file-name "~/")))
- (proc (apply 'start-process name doc-view-conversion-buffer
+ (proc (apply #'start-process name doc-view-conversion-buffer
program args)))
(push proc doc-view--current-converter-processes)
(setq mode-line-process (list (format ":%s" proc)))
@@ -930,16 +955,31 @@ Should be invoked when the cached images aren't up-to-date."
(list "-o" pdf dvi)
callback)))
+(defun doc-view-pdf-password-protected-ghostscript-p (pdf)
+ "Return non-nil if a PDF file is password-protected.
+The test is performed using `doc-view-ghostscript-program'."
+ (with-temp-buffer
+ (apply #'call-process doc-view-ghostscript-program nil (current-buffer)
+ nil `(,@doc-view-ghostscript-options
+ "-sNODISPLAY"
+ ,pdf))
+ (goto-char (point-min))
+ (search-forward "This file requires a password for access." nil t)))
+
(defun doc-view-pdf->png-converter-ghostscript (pdf png page callback)
- (doc-view-start-process
- "pdf/ps->png" doc-view-ghostscript-program
- `(,@doc-view-ghostscript-options
- ,(format "-r%d" (round doc-view-resolution))
- ,@(if page `(,(format "-dFirstPage=%d" page)))
- ,@(if page `(,(format "-dLastPage=%d" page)))
- ,(concat "-sOutputFile=" png)
- ,pdf)
- callback))
+ (let ((pdf-passwd (if (doc-view-pdf-password-protected-ghostscript-p pdf)
+ (read-passwd "Enter password for PDF file: "))))
+ (doc-view-start-process
+ "pdf/ps->png" doc-view-ghostscript-program
+ `(,@doc-view-ghostscript-options
+ ,(concat "-sDEVICE=" doc-view-ghostscript-device)
+ ,(format "-r%d" (round doc-view-resolution))
+ ,@(if page `(,(format "-dFirstPage=%d" page)))
+ ,@(if page `(,(format "-dLastPage=%d" page)))
+ ,@(if pdf-passwd `(,(format "-sPDFPassword=%s" pdf-passwd)))
+ ,(concat "-sOutputFile=" png)
+ ,pdf)
+ callback)))
(defalias 'doc-view-ps->png-converter-ghostscript
'doc-view-pdf->png-converter-ghostscript)
@@ -960,14 +1000,36 @@ If PAGE is nil, convert the whole document."
,tiff)
callback))
+(defun doc-view-pdfdraw-program-subcommand ()
+ "Return the mutool subcommand replacing mudraw.
+Recent MuPDF distributions replaced 'mudraw' with 'mutool draw'."
+ (when (string-match "mutool[^/\\]*$" doc-view-pdfdraw-program)
+ '("draw")))
+
+(defun doc-view-pdf-password-protected-pdfdraw-p (pdf)
+ "Return non-nil if a PDF file is password-protected.
+The test is performed using `doc-view-pdfdraw-program'."
+ (with-temp-buffer
+ (apply #'call-process doc-view-pdfdraw-program nil (current-buffer) nil
+ `(,@(doc-view-pdfdraw-program-subcommand)
+ ,(concat "-o" null-device)
+ ;; In case PDF isn't password-protected, "draw" only one page.
+ ,pdf "1"))
+ (goto-char (point-min))
+ (search-forward "error: cannot authenticate password" nil t)))
+
(defun doc-view-pdf->png-converter-mupdf (pdf png page callback)
- (doc-view-start-process
- "pdf->png" doc-view-pdfdraw-program
- `(,(concat "-o" png)
- ,(format "-r%d" (round doc-view-resolution))
- ,pdf
- ,@(if page `(,(format "%d" page))))
- callback))
+ (let ((pdf-passwd (if (doc-view-pdf-password-protected-pdfdraw-p pdf)
+ (read-passwd "Enter password for PDF file: "))))
+ (doc-view-start-process
+ "pdf->png" doc-view-pdfdraw-program
+ `(,@(doc-view-pdfdraw-program-subcommand)
+ ,(concat "-o" png)
+ ,(format "-r%d" (round doc-view-resolution))
+ ,@(if pdf-passwd `("-p" ,pdf-passwd))
+ ,pdf
+ ,@(if page `(,(format "%d" page))))
+ callback)))
(defun doc-view-odf->pdf-converter-unoconv (odf callback)
"Convert ODF to PDF asynchronously and call CALLBACK when finished.
@@ -1007,8 +1069,8 @@ is named like ODF with the extension turned to pdf."
"Convert PDF-PS to PNG asynchronously."
(funcall
(pcase doc-view-doc-type
- (`pdf doc-view-pdf->png-converter-function)
- (`djvu #'doc-view-djvu->tiff-converter-ddjvu)
+ ('pdf doc-view-pdf->png-converter-function)
+ ('djvu #'doc-view-djvu->tiff-converter-ddjvu)
(_ #'doc-view-ps->png-converter-ghostscript))
pdf-ps png nil
(let ((resolution doc-view-resolution))
@@ -1077,20 +1139,20 @@ Start by converting PAGES, and then the rest."
"Convert the current document to text and call CALLBACK when done."
(make-directory (doc-view--current-cache-dir) t)
(pcase doc-view-doc-type
- (`pdf
+ ('pdf
;; Doc is a PDF, so convert it to TXT
(doc-view-pdf->txt doc-view--buffer-file-name txt callback))
- (`ps
+ ('ps
;; Doc is a PS, so convert it to PDF (which will be converted to
;; TXT thereafter).
(let ((pdf (doc-view-current-cache-doc-pdf)))
(doc-view-ps->pdf doc-view--buffer-file-name pdf
(lambda () (doc-view-pdf->txt pdf txt callback)))))
- (`dvi
+ ('dvi
;; Doc is a DVI. This means that a doc.pdf already exists in its
;; cache subdirectory.
(doc-view-pdf->txt (doc-view-current-cache-doc-pdf) txt callback))
- (`odf
+ ('odf
;; Doc is some ODF (or MS Office) doc. This means that a doc.pdf
;; already exists in its cache subdirectory.
(doc-view-pdf->txt (doc-view-current-cache-doc-pdf) txt callback))
@@ -1131,13 +1193,13 @@ Those files are saved in the directory given by the function
(doc-view--current-cache-dir))))
(make-directory (doc-view--current-cache-dir) t)
(pcase doc-view-doc-type
- (`dvi
+ ('dvi
;; DVI files have to be converted to PDF before Ghostscript can process
;; it.
(let ((pdf (doc-view-current-cache-doc-pdf)))
(doc-view-dvi->pdf doc-view--buffer-file-name pdf
(lambda () (doc-view-pdf/ps->png pdf png-file)))))
- (`odf
+ ('odf
;; ODF files have to be converted to PDF before Ghostscript can
;; process it.
(let ((pdf (doc-view-current-cache-doc-pdf))
@@ -1150,11 +1212,11 @@ Those files are saved in the directory given by the function
;; file name. It's named like the input file with the
;; extension replaced by pdf.
(funcall doc-view-odf->pdf-converter-function doc-view--buffer-file-name
- (lambda ()
- ;; Rename to doc.pdf
- (rename-file opdf pdf)
- (doc-view-pdf/ps->png pdf png-file)))))
- ((or `pdf `djvu)
+ (lambda ()
+ ;; Rename to doc.pdf
+ (rename-file opdf pdf)
+ (doc-view-pdf/ps->png pdf png-file)))))
+ ((or 'pdf 'djvu)
(let ((pages (doc-view-active-pages)))
;; Convert doc to bitmap images starting with the active pages.
(doc-view-document->bitmap doc-view--buffer-file-name png-file pages)))
@@ -1220,7 +1282,8 @@ dragging it to its bottom-right corner. See also
(save-match-data
(when (string-match (concat "%%BoundingBox: "
"\\([[:digit:]]+\\) \\([[:digit:]]+\\) "
- "\\([[:digit:]]+\\) \\([[:digit:]]+\\)") o)
+ "\\([[:digit:]]+\\) \\([[:digit:]]+\\)")
+ o)
(mapcar #'string-to-number
(list (match-string 1 o)
(match-string 2 o)
@@ -1304,10 +1367,10 @@ ARGS is a list of image descriptors."
(let* ((image (if (and file (file-readable-p file))
(if (not (and doc-view-scale-internally
(fboundp 'imagemagick-types)))
- (apply 'create-image file doc-view--image-type nil args)
+ (apply #'create-image file doc-view--image-type nil args)
(unless (member :width args)
(setq args `(,@args :width ,doc-view-image-width)))
- (apply 'create-image file 'imagemagick nil args))))
+ (apply #'create-image file 'imagemagick nil args))))
(slice (doc-view-current-slice))
(img-width (and image (car (image-size image))))
(displayed-img-width (if (and image slice)
@@ -1413,6 +1476,14 @@ For now these keys are useful:
(interactive)
(tooltip-show (doc-view-current-info)))
+;; We define an own major mode for DocView's text display so that we
+;; can easily distinguish when we want to toggle back because
+;; text-mode is a likely candidate for a default major-mode
+;; (bug#34451).
+(define-derived-mode doc-view--text-view-mode text-mode "DV/Text"
+ "View mode used in DocView's text buffers."
+ (view-mode))
+
(defun doc-view-open-text ()
"Display the current doc's contents as text."
(interactive)
@@ -1424,15 +1495,22 @@ For now these keys are useful:
(buffer-undo-list t)
(dv-bfn doc-view--buffer-file-name))
(erase-buffer)
+ ;; FIXME: Replacing the buffer's PDF content with its txt rendering
+ ;; is pretty risky. We should probably use *another*
+ ;; buffer instead, so there's much less risk of
+ ;; overwriting the PDF file with some text rendering.
(set-buffer-multibyte t)
(insert-file-contents txt)
- (text-mode)
+ (doc-view--text-view-mode)
(setq-local doc-view--buffer-file-name dv-bfn)
(set-buffer-modified-p nil)
(doc-view-minor-mode)
(add-hook 'write-file-functions
(lambda ()
- (when (eq major-mode 'text-mode)
+ ;; FIXME: If the user changes major mode and then
+ ;; saves the buffer, the PDF file will be clobbered
+ ;; with its txt rendering!
+ (when (eq major-mode 'doc-view--text-view-mode)
(error "Cannot save text contents of document %s"
buffer-file-name)))
nil t))
@@ -1456,7 +1534,7 @@ For now these keys are useful:
;; normal mode.
(doc-view-fallback-mode)
(doc-view-minor-mode 1))
- ((eq major-mode 'text-mode)
+ ((eq major-mode 'doc-view--text-view-mode)
(let ((buffer-undo-list t))
;; We're currently viewing the document's text contents, so switch
;; back to .
@@ -1698,7 +1776,7 @@ If BACKWARD is non-nil, jump to the previous match."
"Find the right single-page converter for the current document type"
(pcase-let ((`(,conv-function ,type ,extension)
(pcase doc-view-doc-type
- (`djvu (list #'doc-view-djvu->tiff-converter-ddjvu 'tiff "tif"))
+ ('djvu (list #'doc-view-djvu->tiff-converter-ddjvu 'tiff "tif"))
(_ (list doc-view-pdf->png-converter-function 'png "png")))))
(setq-local doc-view-single-page-converter-function conv-function)
(setq-local doc-view--image-type type)
@@ -1728,7 +1806,7 @@ If BACKWARD is non-nil, jump to the previous match."
;; window-parameters in the window-state(s) and then restoring this
;; window-state should call us back (to interpret/use those parameters).
(doc-view-goto-page page)
- (when slice (apply 'doc-view-set-slice slice))
+ (when slice (apply #'doc-view-set-slice slice))
(current-buffer))))
(add-to-list 'desktop-buffer-mode-handlers
@@ -1752,12 +1830,7 @@ toggle between displaying the document or editing it as text.
;; returns nil for tar members.
(doc-view-fallback-mode)
- (let* ((prev-major-mode (if (derived-mode-p 'doc-view-mode)
- doc-view--previous-major-mode
- (unless (eq major-mode 'fundamental-mode)
- major-mode))))
- (kill-all-local-variables)
- (setq-local doc-view--previous-major-mode prev-major-mode))
+ (major-mode-suspend)
(dolist (var doc-view-saved-settings)
(set (make-local-variable (car var)) (cdr var)))
@@ -1797,22 +1870,22 @@ toggle between displaying the document or editing it as text.
(when (not (string= doc-view--buffer-file-name buffer-file-name))
(write-region nil nil doc-view--buffer-file-name))
- (setq-local revert-buffer-function #'doc-view-revert-buffer)
+ (add-function :around (local 'revert-buffer-function) #'doc-view--revert-buffer)
(add-hook 'change-major-mode-hook
(lambda ()
(doc-view-kill-proc)
(remove-overlays (point-min) (point-max) 'doc-view t))
nil t)
- (add-hook 'clone-indirect-buffer-hook 'doc-view-clone-buffer-hook nil t)
- (add-hook 'kill-buffer-hook 'doc-view-kill-proc nil t)
- (setq-local desktop-save-buffer 'doc-view-desktop-save-buffer)
+ (add-hook 'clone-indirect-buffer-hook #'doc-view-clone-buffer-hook nil t)
+ (add-hook 'kill-buffer-hook #'doc-view-kill-proc nil t)
+ (setq-local desktop-save-buffer #'doc-view-desktop-save-buffer)
(remove-overlays (point-min) (point-max) 'doc-view t) ;Just in case.
;; Keep track of display info ([vh]scroll, page number, overlay,
;; ...) for each window in which this document is shown.
(add-hook 'image-mode-new-window-functions
- 'doc-view-new-window-function nil t)
+ #'doc-view-new-window-function nil t)
(image-mode-setup-winprops)
(setq-local mode-line-position
@@ -1828,7 +1901,7 @@ toggle between displaying the document or editing it as text.
#'doc-view-scroll-down-or-previous-page))
(setq-local cursor-type nil)
(use-local-map doc-view-mode-map)
- (add-hook 'after-revert-hook 'doc-view-reconvert-doc nil t)
+ (add-hook 'after-revert-hook #'doc-view-reconvert-doc nil t)
(setq-local bookmark-make-record-function
#'doc-view-bookmark-make-record)
(setq mode-name "DocView"
@@ -1849,14 +1922,7 @@ toggle between displaying the document or editing it as text.
'(doc-view-resolution
image-mode-winprops-alist)))))
(remove-overlays (point-min) (point-max) 'doc-view t)
- (if doc-view--previous-major-mode
- (funcall doc-view--previous-major-mode)
- (let ((auto-mode-alist
- (rassq-delete-all
- 'doc-view-mode-maybe
- (rassq-delete-all 'doc-view-mode
- (copy-alist auto-mode-alist)))))
- (normal-mode)))
+ (major-mode-restore '(doc-view-mode-maybe doc-view-mode))
(when vars
(setq-local doc-view-saved-settings vars))))
@@ -1875,13 +1941,9 @@ to the next best mode."
;;;###autoload
(define-minor-mode doc-view-minor-mode
"Toggle displaying buffer via Doc View (Doc View minor mode).
-With a prefix argument ARG, enable Doc View minor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
See the command `doc-view-mode' for more information on this mode."
- nil " DocView" doc-view-minor-mode-map
- :group 'doc-view
+ :lighter " DocView"
(when doc-view-minor-mode
(add-hook 'change-major-mode-hook (lambda () (doc-view-minor-mode -1)) nil t)
(message
@@ -1899,6 +1961,84 @@ See the command `doc-view-mode' for more information on this mode."
(interactive)
(dired doc-view-cache-directory))
+;;;; Presentation mode
+
+(defvar doc-view-presentation-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\e" 'doc-view-presentation-exit)
+ (define-key map "q" 'doc-view-presentation-exit)
+ ;; (define-key map "C" 'doc-view-convert-all-pages)
+ map))
+
+(defvar-local doc-view-presentation--src-data nil)
+
+(defun doc-view-presentation-exit ()
+ "Leave Doc-View's presentation mode."
+ (interactive)
+ (doc-view-presentation-mode -1))
+
+(define-minor-mode doc-view-presentation-mode
+ "Minor mode used while in presentation mode."
+ :init-value nil :keymap doc-view-presentation-mode-map
+ (if doc-view-presentation-mode
+ (progn
+ (set (make-local-variable 'mode-line-format) nil)
+ (doc-view-fit-page-to-window)
+ ;; (doc-view-convert-all-pages)
+ )
+ (kill-local-variable 'mode-line-format)
+ (let ((pn (doc-view-current-page))
+ (win (selected-window)))
+ (doc-view-presentation--propagate-pn doc-view-presentation--src-data pn)
+ (setq doc-view-presentation--src-data nil)
+ (with-selected-window win
+ (if (and (one-window-p) (window-dedicated-p))
+ (delete-frame))))))
+
+(defun doc-view-presentation--propagate-pn (src-data pn)
+ (when src-data
+ (let ((win (car src-data)))
+ (when (and (window-live-p win)
+ (eq (current-buffer) (window-buffer win)))
+ (select-window win))
+ (when (eq (doc-view-current-page) (cdr src-data))
+ (doc-view-goto-page pn)))))
+
+(defun doc-view-presentation ()
+ "Put Doc-View in presentation mode."
+ (interactive)
+ (let* ((src-data (cons (selected-window) (doc-view-current-page)))
+ (mal (display-monitor-attributes-list))
+ (monitor-top 0)
+ (monitor-left 0)
+ (monitor-height (display-pixel-height))
+ (monitor-width (display-pixel-width)))
+ (dolist (attrs mal)
+ (when (memq (selected-frame) (alist-get 'frames attrs))
+ (let ((geom (alist-get 'geometry attrs)))
+ (when geom
+ (setq monitor-top (nth 0 geom))
+ (setq monitor-left (nth 1 geom))
+ (setq monitor-width (nth 2 geom))
+ (setq monitor-height (nth 3 geom))))))
+ (let ((frame (make-frame
+ `((minibuffer . nil)
+ (fullscreen . fullboth)
+ (height . ,(ceiling monitor-height (frame-char-height)))
+ ;; Don't use `ceiling' here since doc-view will center the
+ ;; image instead.
+ (width . ,(ceiling monitor-width (frame-char-width)))
+ (name . "Doc-View-Presentation")
+ (top . ,monitor-top) (left . ,monitor-left) (user-position . t)
+ (vertical-scroll-bars . nil)
+ (left-fringe . 0) (right-fringe . 0)
+ (menu-bar-lines . 0)
+ (tool-bar-lines . 0)))))
+ (select-window (frame-root-window frame))
+ (setq doc-view-presentation--src-data src-data)
+ (set-window-dedicated-p (selected-window) t)
+ (doc-view-presentation-mode 1))))
+
;;;; Bookmark integration
diff --git a/lisp/dom.el b/lisp/dom.el
index eb4603a7f2f..e4da63d8476 100644
--- a/lisp/dom.el
+++ b/lisp/dom.el
@@ -78,15 +78,21 @@ A typical attribute is `href'."
(defun dom-texts (node &optional separator)
"Return all textual data under NODE concatenated with SEPARATOR in-between."
- (mapconcat
- 'identity
- (mapcar
- (lambda (elem)
- (if (stringp elem)
- elem
- (dom-texts elem separator)))
- (dom-children node))
- (or separator " ")))
+ (if (eq (dom-tag node) 'script)
+ ""
+ (mapconcat
+ 'identity
+ (mapcar
+ (lambda (elem)
+ (cond
+ ((stringp elem)
+ elem)
+ ((eq (dom-tag elem) 'script)
+ "")
+ (t
+ (dom-texts elem separator))))
+ (dom-children node))
+ (or separator " "))))
(defun dom-child-by-tag (dom tag)
"Return the first child of DOM that is of type TAG."
diff --git a/lisp/dos-fns.el b/lisp/dos-fns.el
index 7031dfdda6d..c575dd413fc 100644
--- a/lisp/dos-fns.el
+++ b/lisp/dos-fns.el
@@ -212,9 +212,7 @@ returned unaltered."
;; Override settings chosen at startup.
(defun dos-set-default-process-coding-system ()
(setq default-process-coding-system
- (if (default-value 'enable-multibyte-characters)
- '(undecided-dos . undecided-dos)
- '(raw-text-dos . raw-text-dos))))
+ '(undecided-dos . undecided-dos)))
(add-hook 'before-init-hook 'dos-set-default-process-coding-system)
@@ -271,7 +269,7 @@ returned unaltered."
(car where)
(if (zerop (cdr where))
(logior (logand tem 65280) value)
- (logior (logand tem 255) (lsh value 8))))))
+ (logior (logand tem 255) (ash value 8))))))
((numberp where)
(aset regs where (logand value 65535))))))
regs)
diff --git a/lisp/dos-w32.el b/lisp/dos-w32.el
index b84d85bab15..0c04b8fa7f2 100644
--- a/lisp/dos-w32.el
+++ b/lisp/dos-w32.el
@@ -342,7 +342,7 @@ filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"."
w32-direct-print-region-use-command-dot-com
;; file-attributes fails on LPT ports on Windows 9x but
;; not on NT, so handle both cases for safety.
- (eq (or (nth 7 (file-attributes printer)) 0) 0))
+ (eq (or (file-attribute-size (file-attributes printer)) 0) 0))
(write-region start end tempfile nil 0)
(let ((w32-quote-process-args nil))
(call-process "command.com" nil errbuf nil "/c"
diff --git a/lisp/double.el b/lisp/double.el
index 54b4b51b4b6..a5e7dcdc4a8 100644
--- a/lisp/double.el
+++ b/lisp/double.el
@@ -150,9 +150,6 @@ but not `C-u X' or `ESC X' since the X is not the prefix key."
;;;###autoload
(define-minor-mode double-mode
"Toggle special insertion on double keypresses (Double mode).
-With a prefix argument ARG, enable Double mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
When Double mode is enabled, some keys will insert different
strings when pressed twice. See `double-map' for details."
diff --git a/lisp/ecomplete.el b/lisp/ecomplete.el
index c54c110867b..d9f34ef0c00 100644
--- a/lisp/ecomplete.el
+++ b/lisp/ecomplete.el
@@ -1,4 +1,4 @@
-;;; ecomplete.el --- electric completion of addresses and the like
+;;; ecomplete.el --- electric completion of addresses and the like -*- lexical-binding:t -*-
;; Copyright (C) 2006-2019 Free Software Foundation, Inc.
@@ -53,22 +53,32 @@
;;; Code:
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defgroup ecomplete nil
"Electric completion of email addresses and the like."
:group 'mail)
-(defcustom ecomplete-database-file "~/.ecompleterc"
+(defcustom ecomplete-database-file
+ (locate-user-emacs-file "ecompleterc" "~/.ecompleterc")
"The name of the file to store the ecomplete data."
- :group 'ecomplete
:type 'file)
(defcustom ecomplete-database-file-coding-system 'iso-2022-7bit
"Coding system used for writing the ecomplete database file."
- :type '(symbol :tag "Coding system")
- :group 'ecomplete)
+ :type '(symbol :tag "Coding system"))
+
+(defcustom ecomplete-sort-predicate 'ecomplete-decay
+ "Predicate to use when sorting matched.
+The predicate is called with two parameters that represent the
+completion. Each parameter is a list where the first element is
+the times the completion has been used, the second is the
+timestamp of the most recent usage, and the third item is the
+string that was matched."
+ :type '(radio (function-item :tag "Sort by usage and newness" ecomplete-decay)
+ (function-item :tag "Sort by times used" ecomplete-usage)
+ (function-item :tag "Sort by newness" ecomplete-newness)
+ (function :tag "Other")))
;;; Internal variables.
@@ -86,7 +96,7 @@
(defun ecomplete-add-item (type key text)
"Add item TEXT of TYPE to the database, using KEY as the identifier."
(let ((elems (assq type ecomplete-database))
- (now (string-to-number (format-time-string "%s")))
+ (now (encode-time nil 'integer))
entry)
(unless elems
(push (setq elems (list type)) ecomplete-database))
@@ -103,13 +113,13 @@
(with-temp-buffer
(let ((coding-system-for-write ecomplete-database-file-coding-system))
(insert "(")
- (loop for (type . elems) in ecomplete-database
- do
- (insert (format "(%s\n" type))
- (dolist (entry elems)
- (prin1 entry (current-buffer))
- (insert "\n"))
- (insert ")\n"))
+ (cl-loop for (type . elems) in ecomplete-database
+ do
+ (insert (format "(%s\n" type))
+ (dolist (entry elems)
+ (prin1 entry (current-buffer))
+ (insert "\n"))
+ (insert ")\n"))
(insert ")")
(write-region (point-min) (point-max)
ecomplete-database-file nil 'silent))))
@@ -119,11 +129,10 @@
(match (regexp-quote match))
(candidates
(sort
- (loop for (key count time text) in elems
- when (string-match match text)
- collect (list count time text))
- (lambda (l1 l2)
- (> (car l1) (car l2))))))
+ (cl-loop for (_key count time text) in elems
+ when (string-match match text)
+ collect (list count time text))
+ ecomplete-sort-predicate)))
(when (> (length candidates) 10)
(setcdr (nthcdr 10 candidates) nil))
(unless (zerop (length candidates))
@@ -156,22 +165,22 @@ matches."
nil)
(setq highlight (ecomplete-highlight-match-line matches line))
(let ((local-map (make-sparse-keymap))
+ (prev-func (lambda () (setq line (max (1- line) 0))))
+ (next-func (lambda () (setq line (min (1+ line) max-lines))))
selected)
(define-key local-map (kbd "RET")
(lambda () (setq selected (nth line (split-string matches "\n")))))
- (define-key local-map (kbd "M-n")
- (lambda () (setq line (min (1+ line) max-lines))))
- (define-key local-map (kbd "M-p")
- (lambda () (setq line (max (1- line) 0))))
+ (define-key local-map (kbd "M-n") next-func)
+ (define-key local-map (kbd "<down>") next-func)
+ (define-key local-map (kbd "M-p") prev-func)
+ (define-key local-map (kbd "<up>") prev-func)
(let ((overriding-local-map local-map))
(while (and (null selected)
(setq command (read-key-sequence highlight))
(lookup-key local-map command))
(apply (key-binding command) nil)
(setq highlight (ecomplete-highlight-match-line matches line))))
- (if selected
- (message selected)
- (message "Abort"))
+ (message (or selected "Abort"))
selected)))))
(defun ecomplete-highlight-match-line (matches line)
@@ -189,6 +198,46 @@ matches."
(forward-char 1)))
(buffer-string)))
+(defun ecomplete-usage (l1 l2)
+ (> (car l1) (car l2)))
+
+(defun ecomplete-newness (l1 l2)
+ (> (cadr l1) (cadr l2)))
+
+(defun ecomplete-decay (l1 l2)
+ (> (ecomplete-decay-1 l1) (ecomplete-decay-1 l2)))
+
+(defun ecomplete-decay-1 (elem)
+ ;; We subtract 5% from the item for each week it hasn't been used.
+ (/ (car elem)
+ (expt 1.05 (/ (float-time (time-since (cadr elem)))
+ (* 7 24 60 60)))))
+
+;; `ecomplete-get-matches' uses substring matching, so also use the `substring'
+;; style by default.
+(add-to-list 'completion-category-defaults
+ '(ecomplete (styles basic substring)))
+
+(defun ecomplete-completion-table (type)
+ "Return a completion-table suitable for TYPE."
+ (lambda (string pred action)
+ (pcase action
+ (`(boundaries . ,_) nil)
+ ('metadata `(metadata (category . ecomplete)
+ (display-sort-function . ,#'identity)
+ (cycle-sort-function . ,#'identity)))
+ (_
+ (let* ((elems (cdr (assq type ecomplete-database)))
+ (candidates
+ (mapcar (lambda (x) (nth 2 x))
+ (sort
+ (cl-loop for x in elems
+ when (string-prefix-p string (nth 3 x)
+ completion-ignore-case)
+ collect (cdr x))
+ ecomplete-sort-predicate))))
+ (complete-with-action action candidates string pred))))))
+
(provide 'ecomplete)
;;; ecomplete.el ends here
diff --git a/lisp/edmacro.el b/lisp/edmacro.el
index a5b5276a1e1..b480b2330a8 100644
--- a/lisp/edmacro.el
+++ b/lisp/edmacro.el
@@ -547,7 +547,7 @@ doubt, use whitespace."
?\M-\^@ ?\s-\^@ ?\S-\^@)
when (/= (logand ch bit) 0)
concat (format "%c-" pf))
- (let ((ch2 (logand ch (1- (lsh 1 18)))))
+ (let ((ch2 (logand ch (1- (ash 1 18)))))
(cond ((<= ch2 32)
(pcase ch2
(0 "NUL") (9 "TAB") (10 "LFD")
@@ -623,12 +623,16 @@ This function assumes that the events can be stored in a string."
(push (vector 'menu-bar (car ev)) result))
;; It would be nice to do pop-up menus, too, but not enough
;; info is recorded in macros to make this possible.
- (noerror
- ;; Just ignore mouse events.
+ ((or (mouse-event-p ev) (mouse-movement-p ev)
+ (memq (event-basic-type ev)
+ (list mouse-wheel-down-event mouse-wheel-up-event
+ mouse-wheel-right-event
+ mouse-wheel-left-event)))
nil)
+ (noerror nil)
(t
- (error "Macros with mouse clicks are not %s"
- "supported by this command"))))
+ (error "`edmacro-fix-menu-commands': Unsupported event: %S"
+ ev))))
;; Reverse them again and make them back into a vector.
(vconcat (nreverse result)))
macro))
diff --git a/lisp/elec-pair.el b/lisp/elec-pair.el
index b8a243b38a9..3be09d87b4f 100644
--- a/lisp/elec-pair.el
+++ b/lisp/elec-pair.el
@@ -155,6 +155,13 @@ return value is considered instead."
(const :tag "Newline" ?\n))
(list character)))
+(defvar-local electric-pair-skip-whitespace-function
+ #'electric-pair--skip-whitespace
+ "Function to use to skip whitespace forward.
+Before attempting a skip, if `electric-pair-skip-whitespace' is
+non-nil, this function is called. It move point to a new buffer
+position, presumably skipping only whitespace in between.")
+
(defun electric-pair--skip-whitespace ()
"Skip whitespace forward, not crossing comment or string boundaries."
(let ((saved (point))
@@ -220,7 +227,14 @@ inside a comment or string."
(defun electric-pair--insert (char)
(let ((last-command-event char)
(blink-matching-paren nil)
- (electric-pair-mode nil))
+ (electric-pair-mode nil)
+ ;; When adding the "closer" delimiter, a job his function is
+ ;; frequently used for, we don't want to munch any extra
+ ;; newlines above us. That would be the default behaviour of
+ ;; `electric-layout-mode', which potentially kicked in before
+ ;; us to add these newlines, and is probably about to kick in
+ ;; again after we add the closer.
+ (electric-layout-allow-duplicate-newlines t))
(self-insert-command 1)))
(cl-defmacro electric-pair--with-uncached-syntax ((table &optional start) &rest body)
@@ -398,6 +412,15 @@ strings."
(let ((ppss (electric-pair--syntax-ppss (point) '(comment))))
(memq (nth 3 ppss) (list t char))))
+(defmacro electric-pair--save-literal-point-excursion (&rest body)
+ ;; FIXME: need this instead of `save-excursion' when functions in
+ ;; BODY, such as `electric-pair-inhibit-if-helps-balance' and
+ ;; `electric-pair-skip-if-helps-balance' modify and restore the
+ ;; buffer in a way that modifies the marker used by save-excursion.
+ (let ((point (make-symbol "point")))
+ `(let ((,point (point)))
+ (unwind-protect (progn ,@body) (goto-char ,point)))))
+
(defun electric-pair-inhibit-if-helps-balance (char)
"Return non-nil if auto-pairing of CHAR would hurt parentheses' balance.
@@ -406,24 +429,28 @@ some list calculations, finally restoring the situation as if nothing
happened."
(pcase (electric-pair-syntax-info char)
(`(,syntax ,pair ,_ ,s-or-c)
- (unwind-protect
- (progn
- (delete-char -1)
- (cond ((eq ?\( syntax)
- (let* ((pair-data
- (electric-pair--balance-info 1 s-or-c))
- (outermost (cdr pair-data)))
- (cond ((car outermost)
- nil)
- (t
- (eq (cdr outermost) pair)))))
- ((eq syntax ?\")
- (electric-pair--unbalanced-strings-p char))))
- (insert-char char)))))
+ (catch 'done
+ ;; FIXME: modify+undo is *very* tricky business. We used to
+ ;; use `delete-char' followed by `insert', but this changed the
+ ;; position some markers. The real fix would be to compute the
+ ;; result without having to modify the buffer at all.
+ (atomic-change-group
+ (delete-char -1)
+ (throw
+ 'done
+ (cond ((eq ?\( syntax)
+ (let* ((pair-data
+ (electric-pair--balance-info 1 s-or-c))
+ (outermost (cdr pair-data)))
+ (cond ((car outermost)
+ nil)
+ (t
+ (eq (cdr outermost) pair)))))
+ ((eq syntax ?\")
+ (electric-pair--unbalanced-strings-p char)))))))))
(defun electric-pair-skip-if-helps-balance (char)
"Return non-nil if skipping CHAR would benefit parentheses' balance.
-
Works by first removing the character from the buffer, then doing
some list calculations, finally restoring the situation as if nothing
happened."
@@ -445,7 +472,7 @@ happened."
(not (eq (cdr outermost) pair)))))))
((eq syntax ?\")
(electric-pair--inside-string-p char))))
- (insert-char char)))))
+ (insert char)))))
(defun electric-pair-default-skip-self (char)
(if electric-pair-preserve-balance
@@ -491,7 +518,9 @@ happened."
((and (memq syntax '(?\) ?\" ?\$))
(and (or unconditional
(if (functionp electric-pair-skip-self)
- (funcall electric-pair-skip-self last-command-event)
+ (electric-pair--save-literal-point-excursion
+ (goto-char pos)
+ (funcall electric-pair-skip-self last-command-event))
electric-pair-skip-self))
(save-excursion
(when (and (not (and unconditional
@@ -501,7 +530,7 @@ happened."
(functionp electric-pair-skip-whitespace))
(funcall electric-pair-skip-whitespace)
electric-pair-skip-whitespace)))
- (electric-pair--skip-whitespace))
+ (funcall electric-pair-skip-whitespace-function))
(eq (char-after) last-command-event))))
;; This is too late: rather than insert&delete we'd want to only
;; skip (or insert in overwrite mode). The difference is in what
@@ -509,17 +538,19 @@ happened."
;; be visible to other post-self-insert-hook. We'll just have to
;; live with it for now.
(when skip-whitespace-info
- (electric-pair--skip-whitespace))
+ (funcall electric-pair-skip-whitespace-function))
(delete-region (1- pos) (if (eq skip-whitespace-info 'chomp)
(point)
pos))
(forward-char))
;; Insert matching pair.
- ((and (memq syntax `(?\( ?\" ?\$))
+ ((and (memq syntax '(?\( ?\" ?\$))
(not overwrite-mode)
(or unconditional
- (not (funcall electric-pair-inhibit-predicate
- last-command-event))))
+ (not (electric-pair--save-literal-point-excursion
+ (goto-char pos)
+ (funcall electric-pair-inhibit-predicate
+ last-command-event)))))
(save-excursion (electric-pair--insert pair)))))
(_
(when (and (if (functionp electric-pair-open-newline-between-pairs)
@@ -533,7 +564,12 @@ happened."
(matching-paren (char-after))))
(save-excursion (newline 1 t)))))))
-(put 'electric-pair-post-self-insert-function 'priority 20)
+;; Prioritize this to kick in after
+;; `electric-layout-post-self-insert-function': that considerably
+;; simplifies interoperation when `electric-pair-mode',
+;; `electric-layout-mode' and `electric-indent-mode' are used
+;; together. Use `vc-region-history' on these lines for more info.
+(put 'electric-pair-post-self-insert-function 'priority 50)
(defun electric-pair-will-use-region ()
(and (use-region-p)
@@ -574,9 +610,6 @@ ARG and KILLP are passed directly to
;;;###autoload
(define-minor-mode electric-pair-mode
"Toggle automatic parens pairing (Electric Pair mode).
-With a prefix argument ARG, enable Electric Pair mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Electric Pair mode is a global minor mode. When enabled, typing
an open parenthesis automatically inserts the corresponding
diff --git a/lisp/electric.el b/lisp/electric.el
index 3fc1fbbbcaa..07da2f1d9e7 100644
--- a/lisp/electric.el
+++ b/lisp/electric.el
@@ -198,8 +198,8 @@ relative order must be maintained within it."
(setq-default post-self-insert-hook
(sort (default-value 'post-self-insert-hook)
#'(lambda (fn1 fn2)
- (< (or (get fn1 'priority) 0)
- (or (get fn2 'priority) 0))))))
+ (< (or (if (symbolp fn1) (get fn1 'priority)) 0)
+ (or (if (symbolp fn2) (get fn2 'priority)) 0))))))
;;; Electric indentation.
@@ -223,9 +223,9 @@ Python does not lend itself to fully automatic indentation.")
(defvar electric-indent-functions-without-reindent
'(indent-relative indent-to-left-margin indent-relative-maybe
- py-indent-line coffee-indent-line org-indent-line yaml-indent-line
- haskell-indentation-indent-line haskell-indent-cycle haskell-simple-indent
- yaml-indent-line)
+ indent-relative-first-indent-point py-indent-line coffee-indent-line
+ org-indent-line yaml-indent-line haskell-indentation-indent-line
+ haskell-indent-cycle haskell-simple-indent yaml-indent-line)
"List of indent functions that can't reindent.
If `indent-line-function' is one of those, then `electric-indent-mode' will
not try to reindent lines. It is normally better to make the major
@@ -260,32 +260,42 @@ or comment."
(or (memq act '(nil no-indent))
;; In a string or comment.
(unless (eq act 'do-indent) (nth 8 (syntax-ppss))))))))
- ;; For newline, we want to reindent both lines and basically behave like
- ;; reindent-then-newline-and-indent (whose code we hence copied).
- (let ((at-newline (<= pos (line-beginning-position))))
- (when at-newline
- (let ((before (copy-marker (1- pos) t)))
- (save-excursion
- (unless (or (memq indent-line-function
- electric-indent-functions-without-reindent)
- electric-indent-inhibit)
- ;; Don't reindent the previous line if the indentation function
- ;; is not a real one.
- (goto-char before)
- (indent-according-to-mode))
- ;; We are at EOL before the call to indent-according-to-mode, and
- ;; after it we usually are as well, but not always. We tried to
- ;; address it with `save-excursion' but that uses a normal marker
- ;; whereas we need `move after insertion', so we do the
- ;; save/restore by hand.
- (goto-char before)
- (when (eolp)
- ;; Remove the trailing whitespace after indentation because
- ;; indentation may (re)introduce the whitespace.
- (delete-horizontal-space t)))))
- (unless (and electric-indent-inhibit
- (not at-newline))
- (indent-according-to-mode))))))
+ ;; If we error during indent, silently give up since this is an
+ ;; automatic action that the user didn't explicitly request.
+ ;; But we don't want to suppress errors from elsewhere in *this*
+ ;; function, hence the `condition-case' and `throw' (Bug#18764).
+ (catch 'indent-error
+ ;; For newline, we want to reindent both lines and basically
+ ;; behave like reindent-then-newline-and-indent (whose code we
+ ;; hence copied).
+ (let ((at-newline (<= pos (line-beginning-position))))
+ (when at-newline
+ (let ((before (copy-marker (1- pos) t)))
+ (save-excursion
+ (unless
+ (or (memq indent-line-function
+ electric-indent-functions-without-reindent)
+ electric-indent-inhibit)
+ ;; Don't reindent the previous line if the
+ ;; indentation function is not a real one.
+ (goto-char before)
+ (condition-case-unless-debug ()
+ (indent-according-to-mode)
+ (error (throw 'indent-error nil)))
+ ;; The goal here will be to remove the trailing
+ ;; whitespace after reindentation of the previous line
+ ;; because that may have (re)introduced it.
+ (goto-char before)
+ ;; We were at EOL in marker `before' before the call
+ ;; to `indent-according-to-mode' but after we may
+ ;; not be (Bug#15767).
+ (when (and (eolp))
+ (delete-horizontal-space t))))))
+ (unless (and electric-indent-inhibit
+ (not at-newline))
+ (condition-case-unless-debug ()
+ (indent-according-to-mode)
+ (error (throw 'indent-error nil)))))))))
(put 'electric-indent-post-self-insert-function 'priority 60)
@@ -314,9 +324,6 @@ column specified by the function `current-left-margin'."
;;;###autoload
(define-minor-mode electric-indent-mode
"Toggle on-the-fly reindentation (Electric Indent mode).
-With a prefix argument ARG, enable Electric Indent mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
When enabled, this reindents whenever the hook `electric-indent-functions'
returns non-nil, or if you insert a character from `electric-indent-chars'.
@@ -355,54 +362,122 @@ use `electric-indent-local-mode'."
(defvar electric-layout-rules nil
"List of rules saying where to automatically insert newlines.
-Each rule has the form (CHAR . WHERE) where CHAR is the char that
-was just inserted and WHERE specifies where to insert newlines
-and can be: nil, `before', `after', `around', `after-stay', or a
-function of no arguments that returns one of those symbols.
+Each rule has the form (CHAR . WHERE), the rule matching if the
+character just inserted was CHAR. WHERE specifies where to
+insert newlines, and can be:
+
+* one of the symbols `before', `after', `around', `after-stay',
+ or nil.
+
+* a list of the preceding symbols, processed in order of
+ appearance to insert multiple newlines;
+
+* a function of no arguments that returns one of the previous
+ values.
+
+Each symbol specifies where, in relation to the position POS of
+the character inserted, the newline character(s) should be
+inserted. `after-stay' means insert a newline after POS but stay
+in the same place.
-The symbols specify where in relation to CHAR the newline
-character(s) should be inserted. `after-stay' means insert a
-newline after CHAR but stay in the same place.")
+Instead of the (CHAR . WHERE) form, a rule can also be just a
+function of a single argument, the character just inserted. It
+is called at that position, and should return a value compatible with
+WHERE if the rule matches, or nil if it doesn't match.
+
+If multiple rules match, only first one is executed.")
+
+;; TODO: Make this a defcustom?
+(defvar electric-layout-allow-duplicate-newlines nil
+ "If non-nil, allow duplication of `before' newlines.")
(defun electric-layout-post-self-insert-function ()
- (let* ((rule (cdr (assq last-command-event electric-layout-rules)))
- pos)
+ (when electric-layout-mode
+ (electric-layout-post-self-insert-function-1)))
+
+;; for edebug's sake, a separate function
+(defun electric-layout-post-self-insert-function-1 ()
+ (let* ((pos (electric--after-char-pos))
+ probe
+ (rules electric-layout-rules)
+ (rule
+ (catch 'done
+ (when pos
+ (while (setq probe (pop rules))
+ (cond ((and (consp probe)
+ (eq (car probe) last-command-event))
+ (throw 'done (cdr probe)))
+ ((functionp probe)
+ (let ((res
+ (save-excursion
+ (goto-char pos)
+ (funcall probe last-command-event))))
+ (when res (throw 'done res))))))))))
(when (and rule
- (setq pos (electric--after-char-pos))
;; Not in a string or comment.
(not (nth 8 (save-excursion (syntax-ppss pos)))))
- (let ((end (point-marker))
- (sym (if (functionp rule) (funcall rule) rule)))
- (set-marker-insertion-type end (not (eq sym 'after-stay)))
- (goto-char pos)
- (pcase sym
- ;; FIXME: we used `newline' down here which called
- ;; self-insert-command and ran post-self-insert-hook recursively.
- ;; It happened to make electric-indent-mode work automatically with
- ;; electric-layout-mode (at the cost of re-indenting lines
- ;; multiple times), but I'm not sure it's what we want.
- ;;
- ;; FIXME: check eolp before inserting \n?
- (`before (goto-char (1- pos)) (skip-chars-backward " \t")
- (unless (bolp) (insert "\n")))
- (`after (insert "\n"))
- (`after-stay (save-excursion
- (let ((electric-layout-rules nil))
- (newline 1 t))))
- (`around (save-excursion
- (goto-char (1- pos)) (skip-chars-backward " \t")
- (unless (bolp) (insert "\n")))
- (insert "\n"))) ; FIXME: check eolp before inserting \n?
- (goto-char end)))))
+ (goto-char pos)
+ (when (functionp rule) (setq rule (funcall rule)))
+ (dolist (sym (if (symbolp rule) (list rule) rule))
+ (let* ((nl-after
+ (lambda ()
+ ;; FIXME: we use `newline', which calls
+ ;; `self-insert-command' and ran
+ ;; `post-self-insert-hook' recursively. It happened
+ ;; to make `electric-indent-mode' work automatically
+ ;; with `electric-layout-mode' (at the cost of
+ ;; re-indenting lines multiple times), but I'm not
+ ;; sure it's what we want.
+ ;;
+ ;; JT@19/02/22: Indeed in the case of `before'
+ ;; newlines, re-indentation is prevented.
+ ;;
+ ;; FIXME: when `newline'ing, we exceptionally
+ ;; prevent a specific behaviour of
+ ;; `eletric-pair-mode', that of opening an extra
+ ;; newline between newly inserted matching paris.
+ ;; In theory that behaviour should be provided by
+ ;; `electric-layout-mode' instead, which should be
+ ;; possible given the current API.
+ ;;
+ ;; FIXME: check eolp before inserting \n?
+ (let ((electric-layout-mode nil)
+ (electric-pair-open-newline-between-pairs nil))
+ (newline 1 t))))
+ (nl-before
+ (lambda ()
+ (save-excursion
+ (goto-char (1- pos))
+ ;; Normally, we don't duplicate newlines, but when
+ ;; we're being called for i.e. a closer brace for
+ ;; `electric-pair-mode' generally make sense. So
+ ;; consult `electric-layout-allow-duplicate-newlines'
+ (unless (and (not electric-layout-allow-duplicate-newlines)
+ (progn (skip-chars-backward " \t")
+ (bolp)))
+ ;; FIXME: JT@19/03/22: Make sure the `before'
+ ;; newline being inserted here does not trigger
+ ;; reindentation. It doesn't seem to be our job
+ ;; to do so and it break with `cc-mode's
+ ;; indentation function. Later on we can add a
+ ;; before-and-maybe-indent, or if the user
+ ;; really wants to reindent, then
+ ;; `last-command-event' should be in
+ ;; `electric-indent-chars'.
+ (let ((electric-indent-inhibit t))
+ (funcall nl-after)))))))
+ (pcase sym
+ ('before (funcall nl-before))
+ ('after (funcall nl-after))
+ ('after-stay (save-excursion (funcall nl-after)))
+ ('around (funcall nl-before) (funcall nl-after))))))))
(put 'electric-layout-post-self-insert-function 'priority 40)
;;;###autoload
(define-minor-mode electric-layout-mode
"Automatically insert newlines around some chars.
-With a prefix argument ARG, enable Electric Layout mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
The variable `electric-layout-rules' says when and how to insert newlines."
:global t :group 'electricity
(cond (electric-layout-mode
@@ -413,6 +488,19 @@ The variable `electric-layout-rules' says when and how to insert newlines."
(remove-hook 'post-self-insert-hook
#'electric-layout-post-self-insert-function))))
+;;;###autoload
+(define-minor-mode electric-layout-local-mode
+ "Toggle `electric-layout-mode' only in this buffer."
+ :variable (buffer-local-value 'electric-layout-mode (current-buffer))
+ (cond
+ ((eq electric-layout-mode (default-value 'electric-layout-mode))
+ (kill-local-variable 'electric-layout-mode))
+ ((not (default-value 'electric-layout-mode))
+ ;; Locally enabled, but globally disabled.
+ (electric-layout-mode 1) ; Setup the hooks.
+ (setq-default electric-layout-mode nil) ; But keep it globally disabled.
+ )))
+
;;; Electric quoting.
(defcustom electric-quote-comment t
@@ -451,6 +539,14 @@ whitespace, opening parenthesis, or quote and leaves \\=` alone."
:version "26.1"
:type 'boolean :safe #'booleanp :group 'electricity)
+(defcustom electric-quote-replace-double nil
+ "Non-nil means to replace \" with an electric double quote.
+Emacs replaces \" with an opening double quote after a line
+break, whitespace, opening parenthesis, or quote, and with a
+closing double quote otherwise."
+ :version "26.1"
+ :type 'boolean :safe #'booleanp :group 'electricity)
+
(defvar electric-quote-inhibit-functions ()
"List of functions that should inhibit electric quoting.
When the variable `electric-quote-mode' is non-nil, Emacs will
@@ -461,13 +557,17 @@ substitution is inhibited. The functions are called after the
after the inserted character. The functions in this hook should
not move point or change the current buffer.")
+(defvar electric-pair-text-pairs)
+
(defun electric-quote-post-self-insert-function ()
"Function that `electric-quote-mode' adds to `post-self-insert-hook'.
This requotes when a quoting key is typed."
(when (and electric-quote-mode
(or (eq last-command-event ?\')
(and (not electric-quote-context-sensitive)
- (eq last-command-event ?\`)))
+ (eq last-command-event ?\`))
+ (and electric-quote-replace-double
+ (eq last-command-event ?\")))
(not (run-hook-with-args-until-success
'electric-quote-inhibit-functions))
(if (derived-mode-p 'text-mode)
@@ -488,9 +588,12 @@ This requotes when a quoting key is typed."
(save-excursion
(let ((backtick ?\`))
(if (or (eq last-command-event ?\`)
- (and electric-quote-context-sensitive
+ (and (or electric-quote-context-sensitive
+ (and electric-quote-replace-double
+ (eq last-command-event ?\")))
(save-excursion
(backward-char)
+ (skip-syntax-backward "\\")
(or (bobp) (bolp)
(memq (char-before) (list q< q<<))
(memq (char-syntax (char-before))
@@ -506,22 +609,25 @@ This requotes when a quoting key is typed."
(setq last-command-event q<<))
((search-backward (string backtick) (1- (point)) t)
(replace-match (string q<))
- (setq last-command-event q<)))
+ (setq last-command-event q<))
+ ((search-backward "\"" (1- (point)) t)
+ (replace-match (string q<<))
+ (setq last-command-event q<<)))
(cond ((search-backward (string q> ?') (- (point) 2) t)
(replace-match (string q>>))
(setq last-command-event q>>))
((search-backward "'" (1- (point)) t)
(replace-match (string q>))
- (setq last-command-event q>))))))))))
+ (setq last-command-event q>))
+ ((search-backward "\"" (1- (point)) t)
+ (replace-match (string q>>))
+ (setq last-command-event q>>))))))))))
(put 'electric-quote-post-self-insert-function 'priority 10)
;;;###autoload
(define-minor-mode electric-quote-mode
"Toggle on-the-fly requoting (Electric Quote mode).
-With a prefix argument ARG, enable Electric Quote mode if
-ARG is positive, and disable it otherwise. If called from Lisp,
-enable the mode if ARG is omitted or nil.
When enabled, as you type this replaces \\=` with ‘, \\=' with ’,
\\=`\\=` with “, and \\='\\=' with ”. This occurs only in comments, strings,
diff --git a/lisp/elide-head.el b/lisp/elide-head.el
index 82d08190a63..c1678c003db 100644
--- a/lisp/elide-head.el
+++ b/lisp/elide-head.el
@@ -52,7 +52,7 @@
(defcustom elide-head-headers-to-hide
'(("is free software[:;] you can redistribute it" . ; GNU boilerplate
"\\(Boston, MA 0211\\(1-1307\\|0-1301\\), USA\\|\
-If not, see <http://www\\.gnu\\.org/licenses/>\\)\\.")
+If not, see <https?://www\\.gnu\\.org/licenses/>\\)\\.")
("The Regents of the University of California\\. All rights reserved\\." .
"SUCH DAMAGE\\.") ; BSD
("Permission is hereby granted, free of charge" . ; X11
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el
index 3ab7e1fe988..2034f33d0e6 100644
--- a/lisp/emacs-lisp/advice.el
+++ b/lisp/emacs-lisp/advice.el
@@ -1514,7 +1514,7 @@
;; `ad-return-value' in a piece of after advice. For example:
;;
;; (defmacro foom (x)
-;; (` (list (, x))))
+;; `(list ,x))
;; foom
;;
;; (foom '(a))
@@ -1547,8 +1547,8 @@
;; (defadvice foom (after fg-print-x act)
;; "Print the value of X."
;; (setq ad-return-value
-;; (` (progn (print (, x))
-;; (, ad-return-value)))))
+;; `(progn (print ,x)
+;; ,ad-return-value)))
;; foom
;;
;; (macroexpand '(foom '(a)))
@@ -1575,7 +1575,6 @@
;; ==============================
(require 'macroexp)
-;; At run-time also, since ad-do-advised-functions returns code that uses it.
(eval-when-compile (require 'cl-lib))
;; @@ Variable definitions:
@@ -1662,18 +1661,14 @@ generates a copy of TREE."
;; (this list is maintained as a completion table):
(defvar ad-advised-functions nil)
-(defmacro ad-pushnew-advised-function (function)
+(defun ad-pushnew-advised-function (function)
"Add FUNCTION to `ad-advised-functions' unless its already there."
- `(if (not (assoc (symbol-name ,function) ad-advised-functions))
- (setq ad-advised-functions
- (cons (list (symbol-name ,function))
- ad-advised-functions))))
+ (add-to-list 'ad-advised-functions (symbol-name function)))
-(defmacro ad-pop-advised-function (function)
+(defun ad-pop-advised-function (function)
"Remove FUNCTION from `ad-advised-functions'."
- `(setq ad-advised-functions
- (delq (assoc (symbol-name ,function) ad-advised-functions)
- ad-advised-functions)))
+ (setq ad-advised-functions
+ (delete (symbol-name function) ad-advised-functions)))
(defmacro ad-do-advised-functions (varform &rest body)
"`dolist'-style iterator that maps over advised functions.
@@ -1683,14 +1678,14 @@ On each iteration VAR will be bound to the name of an advised function
\(a symbol)."
(declare (indent 1))
`(dolist (,(car varform) ad-advised-functions)
- (setq ,(car varform) (intern (car ,(car varform))))
+ (setq ,(car varform) (intern ,(car varform)))
,@body))
-(defun ad-get-advice-info (function)
+(defsubst ad-get-advice-info (function)
(get function 'ad-advice-info))
-(defmacro ad-get-advice-info-macro (function)
- `(get ,function 'ad-advice-info))
+(define-obsolete-function-alias 'ad-get-advice-info-macro
+ #'ad-get-advice-info "27.1")
(defsubst ad-set-advice-info (function advice-info)
(cond
@@ -1702,13 +1697,12 @@ On each iteration VAR will be bound to the name of an advised function
#'ad--defalias-fset)))
(put function 'ad-advice-info advice-info))
-(defmacro ad-copy-advice-info (function)
- `(copy-tree (get ,function 'ad-advice-info)))
+(defsubst ad-copy-advice-info (function)
+ (copy-tree (get function 'ad-advice-info)))
-(defmacro ad-is-advised (function)
+(defalias 'ad-is-advised #'ad-get-advice-info
"Return non-nil if FUNCTION has any advice info associated with it.
-This does not mean that the advice is also active."
- `(ad-get-advice-info-macro ,function))
+This does not mean that the advice is also active.")
(defun ad-initialize-advice-info (function)
"Initialize the advice info for FUNCTION.
@@ -1716,19 +1710,19 @@ Assumes that FUNCTION has not yet been advised."
(ad-pushnew-advised-function function)
(ad-set-advice-info function (list (cons 'active nil))))
-(defmacro ad-get-advice-info-field (function field)
+(defsubst ad-get-advice-info-field (function field)
"Retrieve the value of the advice info FIELD of FUNCTION."
- `(cdr (assq ,field (ad-get-advice-info-macro ,function))))
+ (cdr (assq field (ad-get-advice-info function))))
(defun ad-set-advice-info-field (function field value)
"Destructively modify VALUE of the advice info FIELD of FUNCTION."
- (and (ad-is-advised function)
- (cond ((assq field (ad-get-advice-info-macro function))
- ;; A field with that name is already present:
- (rplacd (assq field (ad-get-advice-info-macro function)) value))
- (t;; otherwise, create a new field with that name:
- (nconc (ad-get-advice-info-macro function)
- (list (cons field value)))))))
+ (let ((info (ad-get-advice-info function)))
+ (and info
+ (cond ((assq field info)
+ ;; A field with that name is already present:
+ (rplacd (assq field info) value))
+ (t;; otherwise, create a new field with that name:
+ (nconc info (list (cons field value))))))))
;; Don't make this a macro so we can use it as a predicate:
(defun ad-is-active (function)
@@ -1849,7 +1843,7 @@ function at point for which PREDICATE returns non-nil)."
(require 'help)
(function-called-at-point))))
(and function
- (assoc (symbol-name function) ad-advised-functions)
+ (member (symbol-name function) ad-advised-functions)
(or (null predicate)
(funcall predicate function))
function))
@@ -1939,9 +1933,9 @@ be used to prompt for the function."
;; @@ Finding, enabling, adding and removing pieces of advice:
;; ===========================================================
-(defmacro ad-find-advice (function class name)
+(defsubst ad-find-advice (function class name)
"Find the first advice of FUNCTION in CLASS with NAME."
- `(assq ,name (ad-get-advice-info-field ,function ,class)))
+ (assq name (ad-get-advice-info-field function class)))
(defun ad-advice-position (function class name)
"Return position of first advice of FUNCTION in CLASS with NAME."
@@ -2109,34 +2103,33 @@ the cache-id will clear the cache."
;; @@ Accessing and manipulating function definitions:
;; ===================================================
-(defmacro ad-macrofy (definition)
+(defsubst ad-macrofy (definition)
"Take a lambda function DEFINITION and make a macro out of it."
- `(cons 'macro ,definition))
+ (cons 'macro definition))
-(defmacro ad-lambdafy (definition)
- "Take a macro function DEFINITION and make a lambda out of it."
- `(cdr ,definition))
+(defalias 'ad-lambdafy #'cdr
+ "Take a macro function DEFINITION and make a lambda out of it.")
-(defmacro ad-lambda-p (definition)
+(defsubst ad-lambda-p (definition)
;;"non-nil if DEFINITION is a lambda expression."
- `(eq (car-safe ,definition) 'lambda))
+ (eq (car-safe definition) 'lambda))
;; see ad-make-advice for the format of advice definitions:
-(defmacro ad-advice-p (definition)
+(defsubst ad-advice-p (definition)
;;"non-nil if DEFINITION is a piece of advice."
- `(eq (car-safe ,definition) 'advice))
+ (eq (car-safe definition) 'advice))
-(defmacro ad-compiled-p (definition)
+(defsubst ad-compiled-p (definition)
"Return non-nil if DEFINITION is a compiled byte-code object."
- `(or (byte-code-function-p ,definition)
- (and (macrop ,definition)
- (byte-code-function-p (ad-lambdafy ,definition)))))
+ (or (byte-code-function-p definition)
+ (and (macrop definition)
+ (byte-code-function-p (ad-lambdafy definition)))))
-(defmacro ad-compiled-code (compiled-definition)
+(defsubst ad-compiled-code (compiled-definition)
"Return the byte-code object of a COMPILED-DEFINITION."
- `(if (macrop ,compiled-definition)
- (ad-lambdafy ,compiled-definition)
- ,compiled-definition))
+ (if (macrop compiled-definition)
+ (ad-lambdafy compiled-definition)
+ compiled-definition))
(defun ad-lambda-expression (definition)
"Return the lambda expression of a function/macro/advice DEFINITION."
@@ -2697,15 +2690,15 @@ should be modified. The assembled function will be returned."
;; the added efficiency. The validation itself is also pretty cheap, certainly
;; a lot cheaper than reconstructing an advised definition.
-(defmacro ad-get-cache-definition (function)
- `(car (ad-get-advice-info-field ,function 'cache)))
+(defsubst ad-get-cache-definition (function)
+ (car (ad-get-advice-info-field function 'cache)))
-(defmacro ad-get-cache-id (function)
- `(cdr (ad-get-advice-info-field ,function 'cache)))
+(defsubst ad-get-cache-id (function)
+ (cdr (ad-get-advice-info-field function 'cache)))
-(defmacro ad-set-cache (function definition id)
- `(ad-set-advice-info-field
- ,function 'cache (cons ,definition ,id)))
+(defsubst ad-set-cache (function definition id)
+ (ad-set-advice-info-field
+ function 'cache (cons definition id)))
(defun ad-clear-cache (function)
"Clears a previously cached advised definition of FUNCTION.
@@ -2813,7 +2806,7 @@ advised definition from scratch."
;; advised definition will be generated.
(defun ad-preactivate-advice (function advice class position)
- "Preactivate FUNCTION and returns the constructed cache."
+ "Preactivate FUNCTION and return the constructed cache."
(let* ((advicefunname (ad-get-advice-info-field function 'advicefunname))
(old-advice (symbol-function advicefunname))
(old-advice-info (ad-copy-advice-info function))
@@ -3098,9 +3091,8 @@ deactivation, which might run hooks and get into other trouble."
;; Completion alist of valid `defadvice' flags
-(defvar ad-defadvice-flags
- '(("protect") ("disable") ("activate")
- ("compile") ("preactivate")))
+(defconst ad-defadvice-flags
+ '("protect" "disable" "activate" "compile" "preactivate"))
;;;###autoload
(defmacro defadvice (function args &rest body)
@@ -3180,7 +3172,7 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...)
(let ((completion
(try-completion (symbol-name flag) ad-defadvice-flags)))
(cond ((eq completion t) flag)
- ((assoc completion ad-defadvice-flags)
+ ((member completion ad-defadvice-flags)
(intern completion))
(t (error "defadvice: Invalid or ambiguous flag: %s"
flag))))))
@@ -3221,7 +3213,7 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...)
For any members of FUNCTIONS that are not currently advised the rebinding will
be a noop. Any modifications done to the definitions of FUNCTIONS will be
undone on exit of this macro."
- (declare (indent 1))
+ (declare (indent 1) (obsolete nil "27.1"))
(let* ((index -1)
;; Make let-variables to store current definitions:
(current-bindings
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el
index 2268d427c35..19e1e93621d 100644
--- a/lisp/emacs-lisp/autoload.el
+++ b/lisp/emacs-lisp/autoload.el
@@ -146,7 +146,7 @@ expression, in which case we want to handle forms differently."
t))))
;; Add the usage form at the end where describe-function-1
;; can recover it.
- (when (listp args) (setq doc (help-add-fundoc-usage doc args)))
+ (when (consp args) (setq doc (help-add-fundoc-usage doc args)))
;; (message "autoload of %S" (nth 1 form))
`(autoload ,(nth 1 form) ,file ,doc ,interactive ,type)))
@@ -182,13 +182,13 @@ expression, in which case we want to handle forms differently."
(let* ((macrop (memq car '(defmacro cl-defmacro defmacro*)))
(name (nth 1 form))
(args (pcase car
- ((or `defun `defmacro
- `defun* `defmacro* `cl-defun `cl-defmacro
- `define-overloadable-function)
+ ((or 'defun 'defmacro
+ 'defun* 'defmacro* 'cl-defun 'cl-defmacro
+ 'define-overloadable-function)
(nth 2 form))
- (`define-skeleton '(&optional str arg))
- ((or `define-generic-mode `define-derived-mode
- `define-compilation-mode)
+ ('define-skeleton '(&optional str arg))
+ ((or 'define-generic-mode 'define-derived-mode
+ 'define-compilation-mode)
nil)
(_ t)))
(body (nthcdr (or (function-get car 'doc-string-elt) 3) form))
@@ -324,6 +324,7 @@ put the output in."
(setcdr p nil)
(princ "\n(" outbuf)
(let ((print-escape-newlines t)
+ (print-escape-control-characters t)
(print-quoted t)
(print-escape-nonascii t))
(dolist (elt form)
@@ -348,6 +349,7 @@ put the output in."
outbuf))
(terpri outbuf)))
(let ((print-escape-newlines t)
+ (print-escape-control-characters t)
(print-quoted t)
(print-escape-nonascii t))
(print form outbuf)))))))
@@ -605,7 +607,8 @@ Don't try to split prefixes that are already longer than that.")
nil))))
prefixes)))
`(if (fboundp 'register-definition-prefixes)
- (register-definition-prefixes ,file ',(delq nil strings)))))))
+ (register-definition-prefixes ,file ',(sort (delq nil strings)
+ 'string<)))))))
(defun autoload--setup-output (otherbuf outbuf absfile load-name)
(let ((outbuf
@@ -657,6 +660,21 @@ Don't try to split prefixes that are already longer than that.")
(defvar autoload-builtin-package-versions nil)
+(defvar autoload-ignored-definitions
+ '("define-obsolete-function-alias"
+ "define-obsolete-variable-alias"
+ "define-category" "define-key"
+ "defgroup" "defface" "defadvice"
+ "def-edebug-spec"
+ ;; Hmm... this is getting ugly:
+ "define-widget"
+ "define-erc-module"
+ "define-erc-response-handler"
+ "defun-rcirc-command")
+ "List of strings naming definitions to ignore for prefixes.
+More specifically those definitions will not be considered for the
+`register-definition-prefixes' call.")
+
;; When called from `generate-file-autoloads' we should ignore
;; `generated-autoload-file' altogether. When called from
;; `update-file-autoloads' we don't know `outbuf'. And when called from
@@ -755,17 +773,8 @@ FILE's modification time."
(looking-at "(\\(def[^ ]+\\) ['(]*\\([^' ()\"\n]+\\)[\n \t]")
(not (member
(match-string 1)
- '("define-obsolete-function-alias"
- "define-obsolete-variable-alias"
- "define-category" "define-key"
- "defgroup" "defface" "defadvice"
- "def-edebug-spec"
- ;; Hmm... this is getting ugly:
- "define-widget"
- "define-erc-module"
- "define-erc-response-handler"
- "defun-rcirc-command"))))
- (push (match-string 2) defs))
+ autoload-ignored-definitions)))
+ (push (match-string-no-properties 2) defs))
(forward-sexp 1)
(forward-line 1)))))))
@@ -810,7 +819,8 @@ FILE's modification time."
(marker-buffer other-output-start)
"actual autoloads are elsewhere" load-name relfile
(if autoload-timestamps
- (nth 5 (file-attributes absfile))
+ (file-attribute-modification-time
+ (file-attributes absfile))
autoload--non-timestamp))
(insert ";;; Generated autoloads from " relfile "\n")))
(insert generate-autoload-section-trailer)))))))
@@ -846,7 +856,8 @@ FILE's modification time."
;; `emacs-internal' instead.
nil nil 'emacs-mule-unix)
(if autoload-timestamps
- (nth 5 (file-attributes relfile))
+ (file-attribute-modification-time
+ (file-attributes relfile))
autoload--non-timestamp)))
(insert ";;; Generated autoloads from " relfile "\n")))
(insert generate-autoload-section-trailer))))
@@ -859,7 +870,7 @@ FILE's modification time."
;; If the entries were added to some other buffer, then the file
;; doesn't add entries to OUTFILE.
otherbuf))
- (nth 5 (file-attributes absfile))))
+ (file-attribute-modification-time (file-attributes absfile))))
(error
;; Probably unbalanced parens in forward-sexp. In that case, the
;; condition is scan-error, and the signal data includes point
@@ -940,7 +951,8 @@ removes any prior now out-of-date autoload entries."
(existing-buffer (if buffer-file-name buf))
(output-file (autoload-generated-file))
(output-time (if (file-exists-p output-file)
- (nth 5 (file-attributes output-file))))
+ (file-attribute-modification-time
+ (file-attributes output-file))))
(found nil))
(with-current-buffer (autoload-find-generated-file)
;; This is to make generated-autoload-file have Unix EOLs, so
@@ -962,7 +974,8 @@ removes any prior now out-of-date autoload entries."
;; Check if it is up to date.
(let ((begin (match-beginning 0))
(last-time (nth 4 form))
- (file-time (nth 5 (file-attributes file))))
+ (file-time (file-attribute-modification-time
+ (file-attributes file))))
(if (and (or (null existing-buffer)
(not (buffer-modified-p existing-buffer)))
(cond
@@ -1055,7 +1068,8 @@ write its autoloads into the specified file instead."
generated-autoload-file))
(output-time
(if (file-exists-p generated-autoload-file)
- (nth 5 (file-attributes generated-autoload-file)))))
+ (file-attribute-modification-time
+ (file-attributes generated-autoload-file)))))
(with-current-buffer (autoload-find-generated-file)
(save-excursion
@@ -1076,7 +1090,8 @@ write its autoloads into the specified file instead."
(if (member last-time (list t autoload--non-timestamp))
(setq last-time output-time))
(dolist (file file)
- (let ((file-time (nth 5 (file-attributes file))))
+ (let ((file-time (file-attribute-modification-time
+ (file-attributes file))))
(when (and file-time
(not (time-less-p last-time file-time)))
;; file unchanged
@@ -1095,7 +1110,8 @@ write its autoloads into the specified file instead."
t autoload--non-timestamp))
output-time
oldtime))
- (nth 5 (file-attributes file))))
+ (file-attribute-modification-time
+ (file-attributes file))))
;; File hasn't changed.
nil)
(t
@@ -1143,9 +1159,6 @@ write its autoloads into the specified file instead."
;; file-local autoload-generated-file settings.
(autoload-save-buffers))))
-(define-obsolete-function-alias 'update-autoloads-from-directories
- 'update-directory-autoloads "22.1")
-
;;;###autoload
(defun batch-update-autoloads ()
"Update loaddefs.el autoloads in batch mode.
diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el
new file mode 100644
index 00000000000..60d146e24a8
--- /dev/null
+++ b/lisp/emacs-lisp/backtrace.el
@@ -0,0 +1,918 @@
+;;; backtrace.el --- generic major mode for Elisp backtraces -*- lexical-binding: t -*-
+
+;; Copyright (C) 2018-2019 Free Software Foundation, Inc.
+
+;; Author: Gemini Lasswell
+;; Keywords: lisp, tools, maint
+;; Version: 1.0
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file defines Backtrace mode, a generic major mode for displaying
+;; Elisp stack backtraces, which can be used as is or inherited from
+;; by another mode.
+
+;; For usage information, see the documentation of `backtrace-mode'.
+
+;;; Code:
+
+(eval-when-compile (require 'cl-lib))
+(eval-when-compile (require 'pcase))
+(eval-when-compile (require 'subr-x)) ; if-let
+(require 'find-func)
+(require 'help-mode) ; Define `help-function-def' button type.
+(require 'lisp-mode)
+
+;;; Options
+
+(defgroup backtrace nil
+ "Viewing of Elisp backtraces."
+ :group 'lisp)
+
+(defcustom backtrace-fontify t
+ "If non-nil, fontify Backtrace buffers.
+Set to nil to disable fontification, which may be necessary in
+order to debug the code that does fontification."
+ :type 'boolean
+ :group 'backtrace
+ :version "27.1")
+
+(defcustom backtrace-line-length 5000
+ "Target length for lines in Backtrace buffers.
+Backtrace mode will attempt to abbreviate printing of backtrace
+frames to make them shorter than this, but success is not
+guaranteed. If set to nil or zero, Backtrace mode will not
+abbreviate the forms it prints."
+ :type 'integer
+ :group 'backtrace
+ :version "27.1")
+
+;;; Backtrace frame data structure
+
+(cl-defstruct
+ (backtrace-frame
+ (:constructor backtrace-make-frame))
+ evald ; Non-nil if argument evaluation is complete.
+ fun ; The function called/to call in this frame.
+ args ; Either evaluated or unevaluated arguments to the function.
+ flags ; A plist, possible properties are :debug-on-exit and :source-available.
+ locals ; An alist containing variable names and values.
+ buffer ; If non-nil, the buffer in use by eval-buffer or eval-region.
+ pos ; The position in the buffer.
+ )
+
+(cl-defun backtrace-get-frames
+ (&optional base &key (constructor #'backtrace-make-frame))
+ "Collect all frames of current backtrace into a list.
+The list will contain objects made by CONSTRUCTOR, which
+defaults to `backtrace-make-frame' and which, if provided, should
+be the constructor of a structure which includes
+`backtrace-frame'. If non-nil, BASE should be a function, and
+frames before its nearest activation frame are discarded."
+ (let ((frames nil)
+ (eval-buffers eval-buffer-list))
+ (mapbacktrace (lambda (evald fun args flags)
+ (push (funcall constructor
+ :evald evald :fun fun
+ :args args :flags flags)
+ frames))
+ (or base 'backtrace-get-frames))
+ (setq frames (nreverse frames))
+ ;; Add local variables to each frame, and the buffer position
+ ;; to frames containing eval-buffer or eval-region.
+ (dotimes (idx (length frames))
+ (let ((frame (nth idx frames)))
+ ;; `backtrace--locals' gives an error when idx is 0. But the
+ ;; locals for frame 0 are not needed, because when we get here
+ ;; from debug-on-entry, the locals aren't bound yet, and when
+ ;; coming from Edebug or ERT there is an Edebug or ERT
+ ;; function at frame 0.
+ (when (> idx 0)
+ (setf (backtrace-frame-locals frame)
+ (backtrace--locals idx (or base 'backtrace-get-frames))))
+ (when (and eval-buffers (memq (backtrace-frame-fun frame)
+ '(eval-buffer eval-region)))
+ ;; This will get the wrong result if there are two nested
+ ;; eval-region calls for the same buffer. That's not a very
+ ;; useful case.
+ (with-current-buffer (pop eval-buffers)
+ (setf (backtrace-frame-buffer frame) (current-buffer))
+ (setf (backtrace-frame-pos frame) (point))))))
+ frames))
+
+;; Button definition for jumping to a buffer position.
+
+(define-button-type 'backtrace-buffer-pos
+ 'action #'backtrace--pop-to-buffer-pos
+ 'help-echo "mouse-2, RET: Show reading position")
+
+(defun backtrace--pop-to-buffer-pos (button)
+ "Pop to the buffer and position for the BUTTON at point."
+ (let* ((buffer (button-get button 'backtrace-buffer))
+ (pos (button-get button 'backtrace-pos)))
+ (if (buffer-live-p buffer)
+ (progn
+ (pop-to-buffer buffer)
+ (goto-char (max (point-min) (min (point-max) pos))))
+ (message "Buffer has been killed"))))
+
+;; Font Locking support
+
+(defconst backtrace--font-lock-keywords
+ '((backtrace--match-ellipsis-in-string
+ (1 'button prepend)))
+ "Expressions to fontify in Backtrace mode.
+Fontify these in addition to the expressions Emacs Lisp mode
+fontifies.")
+
+(defconst backtrace-font-lock-keywords
+ (append lisp-el-font-lock-keywords-for-backtraces
+ backtrace--font-lock-keywords)
+ "Default expressions to highlight in Backtrace mode.")
+(defconst backtrace-font-lock-keywords-1
+ (append lisp-el-font-lock-keywords-for-backtraces-1
+ backtrace--font-lock-keywords)
+ "Subdued level highlighting for Backtrace mode.")
+(defconst backtrace-font-lock-keywords-2
+ (append lisp-el-font-lock-keywords-for-backtraces-2
+ backtrace--font-lock-keywords)
+ "Gaudy level highlighting for Backtrace mode.")
+
+(defun backtrace--match-ellipsis-in-string (bound)
+ ;; Fontify ellipses within strings as buttons.
+ ;; This is necessary because ellipses are text property buttons
+ ;; instead of overlay buttons, which is done because there could
+ ;; be a large number of them.
+ (when (re-search-forward "\\(\\.\\.\\.\\)\"" bound t)
+ (and (get-text-property (- (point) 2) 'cl-print-ellipsis)
+ (get-text-property (- (point) 3) 'cl-print-ellipsis)
+ (get-text-property (- (point) 4) 'cl-print-ellipsis))))
+
+;;; Xref support
+
+(defun backtrace--xref-backend () 'elisp)
+
+;;; Backtrace mode variables
+
+(defvar-local backtrace-frames nil
+ "Stack frames displayed in the current Backtrace buffer.
+This should be a list of `backtrace-frame' objects.")
+
+(defvar-local backtrace-view nil
+ "A plist describing how to render backtrace frames.
+Possible entries are :show-flags, :show-locals and :print-circle.")
+
+(defvar-local backtrace-insert-header-function nil
+ "Function for inserting a header for the current Backtrace buffer.
+If nil, no header will be created. Note that Backtrace buffers
+are fontified as in Emacs Lisp Mode, the header text included.")
+
+(defvar backtrace-revert-hook nil
+ "Hook run before reverting a Backtrace buffer.
+This is commonly used to recompute `backtrace-frames'.")
+
+(defvar-local backtrace-print-function #'cl-prin1
+ "Function used to print values in the current Backtrace buffer.")
+
+(defvar-local backtrace-goto-source-functions nil
+ "Abnormal hook used to jump to the source code for the current frame.
+Each hook function is called with no argument, and should return
+non-nil if it is able to switch to the buffer containing the
+source code. Execution of the hook will stop if one of the
+functions returns non-nil. When adding a function to this hook,
+you should also set the :source-available flag for the backtrace
+frames where the source code location is known.")
+
+(defvar backtrace-mode-map
+ (let ((map (copy-keymap special-mode-map)))
+ (set-keymap-parent map button-buffer-map)
+ (define-key map "n" 'backtrace-forward-frame)
+ (define-key map "p" 'backtrace-backward-frame)
+ (define-key map "v" 'backtrace-toggle-locals)
+ (define-key map "#" 'backtrace-toggle-print-circle)
+ (define-key map "s" 'backtrace-goto-source)
+ (define-key map "\C-m" 'backtrace-help-follow-symbol)
+ (define-key map "+" 'backtrace-multi-line)
+ (define-key map "-" 'backtrace-single-line)
+ (define-key map "." 'backtrace-expand-ellipses)
+ (define-key map [follow-link] 'mouse-face)
+ (define-key map [mouse-2] 'mouse-select-window)
+ (easy-menu-define nil map ""
+ '("Backtrace"
+ ["Next Frame" backtrace-forward-frame
+ :help "Move cursor forwards to the start of a backtrace frame"]
+ ["Previous Frame" backtrace-backward-frame
+ :help "Move cursor backwards to the start of a backtrace frame"]
+ "--"
+ ["Show Variables" backtrace-toggle-locals
+ :style toggle
+ :active (backtrace-get-index)
+ :selected (plist-get (backtrace-get-view) :show-locals)
+ :help "Show or hide the local variables for the frame at point"]
+ ["Expand \"...\"s" backtrace-expand-ellipses
+ :help "Expand all the abbreviated forms in the current frame"]
+ ["Show on Multiple Lines" backtrace-multi-line
+ :help "Use line breaks and indentation to make a form more readable"]
+ ["Show on Single Line" backtrace-single-line]
+ "--"
+ ["Go to Source" backtrace-goto-source
+ :active (and (backtrace-get-index)
+ (plist-get (backtrace-frame-flags
+ (nth (backtrace-get-index) backtrace-frames))
+ :source-available))
+ :help "Show the source code for the current frame"]
+ ["Help for Symbol" backtrace-help-follow-symbol
+ :help "Show help for symbol at point"]
+ ["Describe Backtrace Mode" describe-mode
+ :help "Display documentation for backtrace-mode"]))
+ map)
+ "Local keymap for `backtrace-mode' buffers.")
+
+(defconst backtrace--flags-width 2
+ "Width in characters of the flags for a backtrace frame.")
+
+;;; Navigation and Text Properties
+
+;; This mode uses the following text properties:
+;; backtrace-index: The index into the buffer-local variable
+;; `backtrace-frames' for the frame at point, or nil if outside of a
+;; frame (in the buffer header).
+;; backtrace-view: A plist describing how the frame is printed. See
+;; the docstring for the buffer-local variable `backtrace-view.
+;; backtrace-section: The part of a frame which point is in. Either
+;; `func' or `locals'. At the moment just used to show and hide the
+;; local variables. Derived modes which do additional printing
+;; could define their own frame sections.
+;; backtrace-form: A value applied to each printed representation of a
+;; top-level s-expression, which needs to be different for sexps
+;; printed adjacent to each other, so the limits can be quickly
+;; found for pretty-printing.
+
+(defsubst backtrace-get-index (&optional pos)
+ "Return the index of the backtrace frame at POS.
+The value is an index into `backtrace-frames', or nil.
+POS, if omitted or nil, defaults to point."
+ (get-text-property (or pos (point)) 'backtrace-index))
+
+(defsubst backtrace-get-section (&optional pos)
+ "Return the section of a backtrace frame at POS.
+POS, if omitted or nil, defaults to point."
+ (get-text-property (or pos (point)) 'backtrace-section))
+
+(defsubst backtrace-get-view (&optional pos)
+ "Return the view plist of the backtrace frame at POS.
+POS, if omitted or nil, defaults to point."
+ (get-text-property (or pos (point)) 'backtrace-view))
+
+(defsubst backtrace-get-form (&optional pos)
+ "Return the backtrace form data for the form printed at POS.
+POS, if omitted or nil, defaults to point."
+ (get-text-property (or pos (point)) 'backtrace-form))
+
+(defun backtrace-get-frame-start (&optional pos)
+ "Return the beginning position of the frame at POS in the buffer.
+POS, if omitted or nil, defaults to point."
+ (let ((posn (or pos (point))))
+ (if (or (= (point-min) posn)
+ (not (eq (backtrace-get-index posn)
+ (backtrace-get-index (1- posn)))))
+ posn
+ (previous-single-property-change posn 'backtrace-index nil (point-min)))))
+
+(defun backtrace-get-frame-end (&optional pos)
+ "Return the position of the end of the frame at POS in the buffer.
+POS, if omitted or nil, defaults to point."
+ (next-single-property-change (or pos (point))
+ 'backtrace-index nil (point-max)))
+
+(defun backtrace-forward-frame ()
+ "Move forward to the beginning of the next frame."
+ (interactive)
+ (let ((max (backtrace-get-frame-end)))
+ (when (= max (point-max))
+ (user-error "No next stack frame"))
+ (goto-char max)))
+
+(defun backtrace-backward-frame ()
+ "Move backward to the start of a stack frame."
+ (interactive)
+ (let ((current-index (backtrace-get-index))
+ (min (backtrace-get-frame-start)))
+ (if (or (and (/= (point) (point-max)) (null current-index))
+ (= min (point-min))
+ (and (= min (point))
+ (null (backtrace-get-index (1- min)))))
+ (user-error "No previous stack frame"))
+ (if (= min (point))
+ (goto-char (backtrace-get-frame-start (1- min)))
+ (goto-char min))))
+
+;; Other Backtrace mode commands
+
+(defun backtrace-revert (&rest _ignored)
+ "The `revert-buffer-function' for `backtrace-mode'.
+It runs `backtrace-revert-hook', then calls `backtrace-print'."
+ (interactive)
+ (unless (derived-mode-p 'backtrace-mode)
+ (error "The current buffer is not in Backtrace mode"))
+ (run-hooks 'backtrace-revert-hook)
+ (backtrace-print t))
+
+(defmacro backtrace--with-output-variables (view &rest body)
+ "Bind output variables according to VIEW and execute BODY."
+ (declare (indent 1))
+ `(let ((print-escape-control-characters t)
+ (print-escape-newlines t)
+ (print-circle (plist-get ,view :print-circle))
+ (standard-output (current-buffer)))
+ ,@body))
+
+(defun backtrace-toggle-locals (&optional all)
+ "Toggle the display of local variables for the backtrace frame at point.
+With prefix argument ALL, toggle the value of :show-locals in
+`backtrace-view', which affects all of the backtrace frames in
+the buffer."
+ (interactive "P")
+ (if all
+ (let ((pos (make-marker))
+ (visible (not (plist-get backtrace-view :show-locals))))
+ (setq backtrace-view (plist-put backtrace-view :show-locals visible))
+ (set-marker-insertion-type pos t)
+ (set-marker pos (point))
+ (goto-char (point-min))
+ ;; Skip the header.
+ (unless (backtrace-get-index)
+ (goto-char (backtrace-get-frame-end)))
+ (while (< (point) (point-max))
+ (backtrace--set-frame-locals-visible visible)
+ (goto-char (backtrace-get-frame-end)))
+ (goto-char pos)
+ (when (invisible-p pos)
+ (goto-char (backtrace-get-frame-start))))
+ (let ((index (backtrace-get-index)))
+ (unless index
+ (user-error "Not in a stack frame"))
+ (backtrace--set-frame-locals-visible
+ (not (plist-get (backtrace-get-view) :show-locals))))))
+
+(defun backtrace--set-frame-locals-visible (visible)
+ "Set the visibility of the local vars for the frame at point to VISIBLE."
+ (let ((pos (point))
+ (index (backtrace-get-index))
+ (start (backtrace-get-frame-start))
+ (end (backtrace-get-frame-end))
+ (view (copy-sequence (backtrace-get-view)))
+ (inhibit-read-only t))
+ (setq view (plist-put view :show-locals visible))
+ (goto-char (backtrace-get-frame-start))
+ (while (not (or (= (point) end)
+ (eq (backtrace-get-section) 'locals)))
+ (goto-char (next-single-property-change (point)
+ 'backtrace-section nil end)))
+ (cond
+ ((and (= (point) end) visible)
+ ;; The locals section doesn't exist so create it.
+ (let ((standard-output (current-buffer)))
+ (backtrace--with-output-variables view
+ (backtrace--print-locals
+ (nth index backtrace-frames) view))
+ (add-text-properties end (point) `(backtrace-index ,index))
+ (goto-char pos)))
+ ((/= (point) end)
+ ;; The locals section does exist, so add or remove the overlay.
+ (backtrace--set-locals-visible-overlay (point) end visible)
+ (goto-char (if (invisible-p pos) start pos))))
+ (add-text-properties start (backtrace-get-frame-end)
+ `(backtrace-view ,view))))
+
+(defun backtrace--set-locals-visible-overlay (beg end visible)
+ (backtrace--change-button-skip beg end (not visible))
+ (if visible
+ (remove-overlays beg end 'invisible t)
+ (let ((o (make-overlay beg end)))
+ (overlay-put o 'invisible t)
+ (overlay-put o 'evaporate t))))
+
+(defun backtrace--change-button-skip (beg end value)
+ "Change the skip property on all buttons between BEG and END.
+Set it to VALUE unless the button is a `backtrace-ellipsis' button."
+ (let ((inhibit-read-only t))
+ (setq beg (next-button beg))
+ (while (and beg (< beg end))
+ (unless (eq (button-type beg) 'backtrace-ellipsis)
+ (button-put beg 'skip value))
+ (setq beg (next-button beg)))))
+
+(defun backtrace-toggle-print-circle (&optional all)
+ "Toggle `print-circle' for the backtrace frame at point.
+With prefix argument ALL, toggle the value of :print-circle in
+`backtrace-view', which affects all of the backtrace frames in
+the buffer."
+ (interactive "P")
+ (backtrace--toggle-feature :print-circle all))
+
+(defun backtrace--toggle-feature (feature all)
+ "Toggle FEATURE for the current backtrace frame or for the buffer.
+FEATURE should be one of the options in `backtrace-view'. If ALL
+is non-nil, toggle FEATURE for all frames in the buffer. After
+toggling the feature, reprint the affected frame(s). Afterwards
+position point at the start of the frame it was in before."
+ (if all
+ (let ((index (backtrace-get-index))
+ (pos (point))
+ (at-end (= (point) (point-max)))
+ (value (not (plist-get backtrace-view feature))))
+ (setq backtrace-view (plist-put backtrace-view feature value))
+ (goto-char (point-min))
+ ;; Skip the header.
+ (unless (backtrace-get-index)
+ (goto-char (backtrace-get-frame-end)))
+ (while (< (point) (point-max))
+ (backtrace--set-feature feature value)
+ (goto-char (backtrace-get-frame-end)))
+ (if (not index)
+ (goto-char (if at-end (point-max) pos))
+ (goto-char (point-min))
+ (while (and (not (eql index (backtrace-get-index)))
+ (< (point) (point-max)))
+ (goto-char (backtrace-get-frame-end)))))
+ (let ((index (backtrace-get-index)))
+ (unless index
+ (user-error "Not in a stack frame"))
+ (backtrace--set-feature feature
+ (not (plist-get (backtrace-get-view) feature))))))
+
+(defun backtrace--set-feature (feature value)
+ "Set FEATURE in the view plist of the frame at point to VALUE.
+Reprint the frame with the new view plist."
+ (let ((inhibit-read-only t)
+ (view (copy-sequence (backtrace-get-view)))
+ (index (backtrace-get-index))
+ (min (backtrace-get-frame-start))
+ (max (backtrace-get-frame-end)))
+ (setq view (plist-put view feature value))
+ (delete-region min max)
+ (goto-char min)
+ (backtrace-print-frame (nth index backtrace-frames) view)
+ (add-text-properties min (point)
+ `(backtrace-index ,index backtrace-view ,view))
+ (goto-char min)))
+
+(defun backtrace-expand-ellipsis (button)
+ "Expand display of the elided form at BUTTON."
+ (interactive)
+ (goto-char (button-start button))
+ (unless (get-text-property (point) 'cl-print-ellipsis)
+ (if (and (> (point) (point-min))
+ (get-text-property (1- (point)) 'cl-print-ellipsis))
+ (backward-char)
+ (user-error "No ellipsis to expand here")))
+ (let* ((end (next-single-property-change (point) 'cl-print-ellipsis))
+ (begin (previous-single-property-change end 'cl-print-ellipsis))
+ (value (get-text-property begin 'cl-print-ellipsis))
+ (props (backtrace-get-text-properties begin))
+ (inhibit-read-only t))
+ (backtrace--with-output-variables (backtrace-get-view)
+ (delete-region begin end)
+ (insert (cl-print-to-string-with-limit #'cl-print-expand-ellipsis value
+ backtrace-line-length))
+ (setq end (point))
+ (goto-char begin)
+ (while (< (point) end)
+ (let ((next (next-single-property-change (point) 'cl-print-ellipsis
+ nil end)))
+ (when (get-text-property (point) 'cl-print-ellipsis)
+ (make-text-button (point) next :type 'backtrace-ellipsis))
+ (goto-char next)))
+ (goto-char begin)
+ (add-text-properties begin end props))))
+
+(defun backtrace-expand-ellipses (&optional no-limit)
+ "Expand display of all \"...\"s in the backtrace frame at point.
+\\<backtrace-mode-map>
+Each ellipsis will be limited to `backtrace-line-length'
+characters in its expansion. With optional prefix argument
+NO-LIMIT, do not limit the number of characters. Note that with
+or without the argument, using this command can result in very
+long lines and very poor display performance. If this happens
+and is a problem, use `\\[revert-buffer]' to return to the
+initial state of the Backtrace buffer."
+ (interactive "P")
+ (save-excursion
+ (let ((start (backtrace-get-frame-start))
+ (end (backtrace-get-frame-end))
+ (backtrace-line-length (unless no-limit backtrace-line-length)))
+ (goto-char end)
+ (while (> (point) start)
+ (let ((next (previous-single-property-change (point) 'cl-print-ellipsis
+ nil start)))
+ (when (get-text-property (point) 'cl-print-ellipsis)
+ (push-button (point)))
+ (goto-char next))))))
+
+(defun backtrace-multi-line ()
+ "Show the top level s-expression at point on multiple lines with indentation."
+ (interactive)
+ (backtrace--reformat-sexp #'backtrace--multi-line))
+
+(defun backtrace--multi-line ()
+ "Pretty print the current buffer, then remove the trailing newline."
+ (set-syntax-table emacs-lisp-mode-syntax-table)
+ (pp-buffer)
+ (goto-char (1- (point-max)))
+ (delete-char 1))
+
+(defun backtrace-single-line ()
+ "Show the top level s-expression at point on one line."
+ (interactive)
+ (backtrace--reformat-sexp #'backtrace--single-line))
+
+(defun backtrace--single-line ()
+ "Replace line breaks and following indentation with spaces.
+Works on the current buffer."
+ (goto-char (point-min))
+ (while (re-search-forward "\n[[:blank:]]*" nil t)
+ (replace-match " ")))
+
+(defun backtrace--reformat-sexp (format-function)
+ "Reformat the top level sexp at point.
+Locate the top level sexp at or following point on the same line,
+and reformat it with FORMAT-FUNCTION, preserving the location of
+point within the sexp. If no sexp is found before the end of
+the line or buffer, signal an error.
+
+FORMAT-FUNCTION will be called without arguments, with the
+current buffer set to a temporary buffer containing only the
+content of the sexp."
+ (let* ((orig-pos (point))
+ (pos (point))
+ (tag (backtrace-get-form pos))
+ (end (next-single-property-change pos 'backtrace-form))
+ (begin (previous-single-property-change end 'backtrace-form
+ nil (point-min))))
+ (unless tag
+ (when (or (= end (point-max)) (> end (point-at-eol)))
+ (user-error "No form here to reformat"))
+ (goto-char end)
+ (setq pos end
+ end (next-single-property-change pos 'backtrace-form)
+ begin (previous-single-property-change end 'backtrace-form
+ nil (point-min))))
+ (let* ((offset (when (>= orig-pos begin) (- orig-pos begin)))
+ (offset-marker (when offset (make-marker)))
+ (content (buffer-substring begin end))
+ (props (backtrace-get-text-properties begin))
+ (inhibit-read-only t))
+ (delete-region begin end)
+ (insert (with-temp-buffer
+ (insert content)
+ (when offset
+ (set-marker-insertion-type offset-marker t)
+ (set-marker offset-marker (+ (point-min) offset)))
+ (funcall format-function)
+ (when offset
+ (setq offset (- (marker-position offset-marker) (point-min))))
+ (buffer-string)))
+ (when offset
+ (set-marker offset-marker (+ begin offset)))
+ (save-excursion
+ (goto-char begin)
+ (indent-sexp))
+ (add-text-properties begin (point) props)
+ (if offset
+ (goto-char (marker-position offset-marker))
+ (goto-char orig-pos)))))
+
+(defun backtrace-get-text-properties (pos)
+ "Return a plist of backtrace-mode's text properties at POS."
+ (apply #'append
+ (mapcar (lambda (prop)
+ (list prop (get-text-property pos prop)))
+ '(backtrace-section backtrace-index backtrace-view
+ backtrace-form))))
+
+(defun backtrace-goto-source ()
+ "If its location is known, jump to the source code for the frame at point."
+ (interactive)
+ (let* ((index (or (backtrace-get-index) (user-error "Not in a stack frame")))
+ (frame (nth index backtrace-frames))
+ (source-available (plist-get (backtrace-frame-flags frame)
+ :source-available)))
+ (unless (and source-available
+ (catch 'done
+ (dolist (func backtrace-goto-source-functions)
+ (when (funcall func)
+ (throw 'done t)))))
+ (user-error "Source code location not known"))))
+
+(defun backtrace-help-follow-symbol (&optional pos)
+ "Follow cross-reference at POS, defaulting to point.
+For the cross-reference format, see `help-make-xrefs'."
+ (interactive "d")
+ (unless pos
+ (setq pos (point)))
+ (unless (push-button pos)
+ ;; Check if the symbol under point is a function or variable.
+ (let ((sym
+ (intern
+ (save-excursion
+ (goto-char pos) (skip-syntax-backward "w_")
+ (buffer-substring (point)
+ (progn (skip-syntax-forward "w_")
+ (point)))))))
+ (when (or (boundp sym) (fboundp sym) (facep sym))
+ (describe-symbol sym)))))
+
+;; Print backtrace frames
+
+(defun backtrace-print (&optional remember-pos)
+ "Populate the current Backtrace mode buffer.
+This erases the buffer and inserts printed representations of the
+frames. Optional argument REMEMBER-POS, if non-nil, means to
+move point to the entry with the same ID element as the current
+line and recenter window line accordingly."
+ (let ((inhibit-read-only t)
+ entry-index saved-pt window-line)
+ (and remember-pos
+ (setq entry-index (backtrace-get-index))
+ (when (eq (window-buffer) (current-buffer))
+ (setq window-line
+ (count-screen-lines (window-start) (point)))))
+ (erase-buffer)
+ (when backtrace-insert-header-function
+ (funcall backtrace-insert-header-function))
+ (dotimes (idx (length backtrace-frames))
+ (let ((beg (point))
+ (elt (nth idx backtrace-frames)))
+ (and entry-index
+ (equal entry-index idx)
+ (setq entry-index nil
+ saved-pt (point)))
+ (backtrace-print-frame elt backtrace-view)
+ (add-text-properties
+ beg (point)
+ `(backtrace-index ,idx backtrace-view ,backtrace-view))))
+ (set-buffer-modified-p nil)
+ ;; If REMEMBER-POS was specified, move to the "old" location.
+ (if saved-pt
+ (progn (goto-char saved-pt)
+ (when window-line
+ (recenter window-line)))
+ (goto-char (point-min)))))
+
+;; Define button type used for ...'s.
+;; Set skip property so you don't have to TAB through 100 of them to
+;; get to the next function name.
+(define-button-type 'backtrace-ellipsis
+ 'skip t 'action #'backtrace-expand-ellipsis
+ 'help-echo "mouse-2, RET: expand this ellipsis")
+
+(defun backtrace-print-to-string (obj &optional limit)
+ "Return a printed representation of OBJ formatted for backtraces.
+Attempt to get the length of the returned string under LIMIT
+charcters with appropriate settings of `print-level' and
+`print-length.' LIMIT defaults to `backtrace-line-length'."
+ (backtrace--with-output-variables backtrace-view
+ (backtrace--print-to-string obj limit)))
+
+(defun backtrace--print-to-string (sexp &optional limit)
+ ;; This is for use by callers who wrap the call with
+ ;; backtrace--with-output-variables.
+ (setq limit (or limit backtrace-line-length))
+ (with-temp-buffer
+ (insert (cl-print-to-string-with-limit #'backtrace--print sexp limit))
+ ;; Add a unique backtrace-form property.
+ (put-text-property (point-min) (point) 'backtrace-form (gensym))
+ ;; Make buttons from all the "..."s. Since there might be many of
+ ;; them, use text property buttons.
+ (goto-char (point-min))
+ (while (< (point) (point-max))
+ (let ((end (next-single-property-change (point) 'cl-print-ellipsis
+ nil (point-max))))
+ (when (get-text-property (point) 'cl-print-ellipsis)
+ (make-text-button (point) end :type 'backtrace-ellipsis))
+ (goto-char end)))
+ (buffer-string)))
+
+(defun backtrace-print-frame (frame view)
+ "Insert a backtrace FRAME at point formatted according to VIEW.
+Tag the sections of the frame with the `backtrace-section' text
+property for use by navigation."
+ (backtrace--with-output-variables view
+ (backtrace--print-flags frame view)
+ (backtrace--print-func-and-args frame view)
+ (backtrace--print-locals frame view)))
+
+(defun backtrace--print-flags (frame view)
+ "Print the flags of a backtrace FRAME if enabled in VIEW."
+ (let ((beg (point))
+ (flag (plist-get (backtrace-frame-flags frame) :debug-on-exit))
+ (source (plist-get (backtrace-frame-flags frame) :source-available)))
+ (when (plist-get view :show-flags)
+ (when source (insert ">"))
+ (when flag (insert "*")))
+ (insert (make-string (- backtrace--flags-width (- (point) beg)) ?\s))
+ (put-text-property beg (point) 'backtrace-section 'func)))
+
+(defun backtrace--print-func-and-args (frame _view)
+ "Print the function, arguments and buffer position of a backtrace FRAME.
+Format it according to VIEW."
+ (let* ((beg (point))
+ (evald (backtrace-frame-evald frame))
+ (fun (backtrace-frame-fun frame))
+ (args (backtrace-frame-args frame))
+ (def (find-function-advised-original fun))
+ (fun-file (or (symbol-file fun 'defun)
+ (and (subrp def)
+ (not (eq 'unevalled (cdr (subr-arity def))))
+ (find-lisp-object-file-name fun def))))
+ (fun-pt (point)))
+ (cond
+ ((and evald (not debugger-stack-frame-as-list))
+ (if (atom fun)
+ (funcall backtrace-print-function fun)
+ (insert
+ (backtrace--print-to-string fun (when args (/ backtrace-line-length 2)))))
+ (if args
+ (insert (backtrace--print-to-string
+ args (max (truncate (/ backtrace-line-length 5))
+ (- backtrace-line-length (- (point) beg)))))
+ ;; The backtrace-form property is so that backtrace-multi-line
+ ;; will find it. backtrace-multi-line doesn't do anything
+ ;; useful with it, just being consistent.
+ (let ((start (point)))
+ (insert "()")
+ (put-text-property start (point) 'backtrace-form t))))
+ (t
+ (let ((fun-and-args (cons fun args)))
+ (insert (backtrace--print-to-string fun-and-args)))
+ (cl-incf fun-pt)))
+ (when fun-file
+ (make-text-button fun-pt (+ fun-pt
+ (length (backtrace--print-to-string fun)))
+ :type 'help-function-def
+ 'help-args (list fun fun-file)))
+ ;; After any frame that uses eval-buffer, insert a comment that
+ ;; states the buffer position it's reading at.
+ (when (backtrace-frame-pos frame)
+ (insert " ; Reading at ")
+ (let ((pos (point)))
+ (insert (format "buffer position %d" (backtrace-frame-pos frame)))
+ (make-button pos (point) :type 'backtrace-buffer-pos
+ 'backtrace-buffer (backtrace-frame-buffer frame)
+ 'backtrace-pos (backtrace-frame-pos frame))))
+ (insert "\n")
+ (put-text-property beg (point) 'backtrace-section 'func)))
+
+(defun backtrace--print-locals (frame view)
+ "Print a backtrace FRAME's local variables according to VIEW.
+Print them only if :show-locals is non-nil in the VIEW plist."
+ (when (plist-get view :show-locals)
+ (let* ((beg (point))
+ (locals (backtrace-frame-locals frame)))
+ (if (null locals)
+ (insert " [no locals]\n")
+ (pcase-dolist (`(,symbol . ,value) locals)
+ (insert " ")
+ (backtrace--print symbol)
+ (insert " = ")
+ (insert (backtrace--print-to-string value))
+ (insert "\n")))
+ (put-text-property beg (point) 'backtrace-section 'locals))))
+
+(defun backtrace--print (obj &optional stream)
+ "Attempt to print OBJ to STREAM using `backtrace-print-function'.
+Fall back to `prin1' if there is an error."
+ (condition-case err
+ (funcall backtrace-print-function obj stream)
+ (error
+ (message "Error in backtrace printer: %S" err)
+ (prin1 obj stream))))
+
+(defun backtrace-update-flags ()
+ "Update the display of the flags in the backtrace frame at point."
+ (let ((view (backtrace-get-view))
+ (begin (backtrace-get-frame-start)))
+ (when (plist-get view :show-flags)
+ (save-excursion
+ (goto-char begin)
+ (let ((props (backtrace-get-text-properties begin))
+ (inhibit-read-only t)
+ (standard-output (current-buffer)))
+ (delete-char backtrace--flags-width)
+ (backtrace--print-flags (nth (backtrace-get-index) backtrace-frames)
+ view)
+ (add-text-properties begin (point) props))))))
+
+(defun backtrace--filter-visible (beg end &optional _delete)
+ "Return the visible text between BEG and END."
+ (let ((result ""))
+ (while (< beg end)
+ (let ((next (next-single-char-property-change beg 'invisible)))
+ (unless (get-char-property beg 'invisible)
+ (setq result (concat result (buffer-substring beg (min end next)))))
+ (setq beg next)))
+ result))
+
+;;; The mode definition
+
+(define-derived-mode backtrace-mode special-mode "Backtrace"
+ "Generic major mode for examining an Elisp stack backtrace.
+This mode can be used directly, or other major modes can be
+derived from it, using `define-derived-mode'.
+
+In this major mode, the buffer contains some optional lines of
+header text followed by backtrace frames, each consisting of one
+or more whole lines.
+
+Letters in this mode do not insert themselves; instead they are
+commands.
+\\<backtrace-mode-map>
+\\{backtrace-mode-map}
+
+A mode which inherits from Backtrace mode, or a command which
+creates a backtrace-mode buffer, should usually do the following:
+
+ - Set `backtrace-revert-hook', if the buffer contents need
+ to be specially recomputed prior to `revert-buffer'.
+ - Maybe set `backtrace-insert-header-function' to a function to create
+ header text for the buffer.
+ - Set `backtrace-frames' (see below).
+ - Maybe modify `backtrace-view' (see below).
+ - Maybe set `backtrace-print-function'.
+
+A command which creates or switches to a Backtrace mode buffer,
+such as `ert-results-pop-to-backtrace-for-test-at-point', should
+initialize `backtrace-frames' to a list of `backtrace-frame'
+objects (`backtrace-get-frames' is provided for that purpose, if
+desired), and may optionally modify `backtrace-view', which is a
+plist describing the appearance of the backtrace. Finally, it
+should call `backtrace-print'.
+
+`backtrace-print' calls `backtrace-insert-header-function'
+followed by `backtrace-print-frame', once for each stack frame."
+ :syntax-table emacs-lisp-mode-syntax-table
+ (when backtrace-fontify
+ (setq font-lock-defaults
+ '((backtrace-font-lock-keywords
+ backtrace-font-lock-keywords-1
+ backtrace-font-lock-keywords-2)
+ nil nil nil nil
+ (font-lock-syntactic-face-function
+ . lisp-font-lock-syntactic-face-function))))
+ (setq truncate-lines t)
+ (buffer-disable-undo)
+ ;; In debug.el, from 1998 to 2009 this was set to nil, reason stated
+ ;; was because of bytecode. Since 2009 it's been set to t, but the
+ ;; default is t so I think this isn't necessary.
+ ;; (set-buffer-multibyte t)
+ (setq-local revert-buffer-function #'backtrace-revert)
+ (setq-local filter-buffer-substring-function #'backtrace--filter-visible)
+ (setq-local indent-line-function 'lisp-indent-line)
+ (setq-local indent-region-function 'lisp-indent-region)
+ (add-hook 'xref-backend-functions #'backtrace--xref-backend nil t))
+
+(put 'backtrace-mode 'mode-class 'special)
+
+;;; Backtrace printing
+
+;;;###autoload
+(defun backtrace ()
+ "Print a trace of Lisp function calls currently active.
+Output stream used is value of `standard-output'."
+ (princ (backtrace-to-string (backtrace-get-frames 'backtrace)))
+ nil)
+
+(defun backtrace-to-string(&optional frames)
+ "Format FRAMES, a list of `backtrace-frame' objects, for output.
+Return the result as a string. If FRAMES is nil, use all
+function calls currently active."
+ (unless frames (setq frames (backtrace-get-frames 'backtrace-to-string)))
+ (let ((backtrace-fontify nil))
+ (with-temp-buffer
+ (backtrace-mode)
+ (setq backtrace-view '(:show-flags t)
+ backtrace-frames frames
+ backtrace-print-function #'cl-prin1)
+ (backtrace-print)
+ (substring-no-properties (filter-buffer-substring (point-min)
+ (point-max))))))
+
+(provide 'backtrace)
+
+;;; backtrace.el ends here
diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el
index 9c2def7af6d..5b5cda36156 100644
--- a/lisp/emacs-lisp/benchmark.el
+++ b/lisp/emacs-lisp/benchmark.el
@@ -34,13 +34,11 @@
(defmacro benchmark-elapse (&rest forms)
"Return the time in seconds elapsed for execution of FORMS."
(declare (indent 0) (debug t))
- (let ((t1 (make-symbol "t1"))
- (t2 (make-symbol "t2")))
- `(let (,t1 ,t2)
+ (let ((t1 (make-symbol "t1")))
+ `(let (,t1)
(setq ,t1 (current-time))
,@forms
- (setq ,t2 (current-time))
- (float-time (time-subtract ,t2 ,t1)))))
+ (float-time (time-since ,t1)))))
;;;###autoload
(defmacro benchmark-run (&optional repetitions &rest forms)
@@ -52,7 +50,7 @@ Return a list of the total elapsed time for execution, the number of
garbage collections that ran, and the time taken by garbage collection.
See also `benchmark-run-compiled'."
(declare (indent 1) (debug t))
- (unless (natnump repetitions)
+ (unless (or (natnump repetitions) (and repetitions (symbolp repetitions)))
(setq forms (cons repetitions forms)
repetitions 1))
(let ((i (make-symbol "i"))
@@ -60,7 +58,7 @@ See also `benchmark-run-compiled'."
(gc (make-symbol "gc")))
`(let ((,gc gc-elapsed)
(,gcs gcs-done))
- (list ,(if (> repetitions 1)
+ (list ,(if (or (symbolp repetitions) (> repetitions 1))
;; Take account of the loop overhead.
`(- (benchmark-elapse (dotimes (,i ,repetitions)
,@forms))
@@ -76,17 +74,17 @@ This is like `benchmark-run', but what is timed is a funcall of the
byte code obtained by wrapping FORMS in a `lambda' and compiling the
result. The overhead of the `lambda's is accounted for."
(declare (indent 1) (debug t))
- (unless (natnump repetitions)
+ (unless (or (natnump repetitions) (and repetitions (symbolp repetitions)))
(setq forms (cons repetitions forms)
repetitions 1))
(let ((i (make-symbol "i"))
(gcs (make-symbol "gcs"))
(gc (make-symbol "gc"))
(code (byte-compile `(lambda () ,@forms)))
- (lambda-code (byte-compile `(lambda ()))))
+ (lambda-code (byte-compile '(lambda ()))))
`(let ((,gc gc-elapsed)
(,gcs gcs-done))
- (list ,(if (> repetitions 1)
+ (list ,(if (or (symbolp repetitions) (> repetitions 1))
;; Take account of the loop overhead.
`(- (benchmark-elapse (dotimes (,i ,repetitions)
(funcall ,code)))
@@ -103,7 +101,7 @@ the command prompts for the form to benchmark.
For non-interactive use see also `benchmark-run' and
`benchmark-run-compiled'."
(interactive "p\nxForm: ")
- (let ((result (eval `(benchmark-run ,repetitions ,form))))
+ (let ((result (eval `(benchmark-run ,repetitions ,form) t)))
(if (zerop (nth 1 result))
(message "Elapsed time: %fs" (car result))
(message "Elapsed time: %fs (%fs in %d GCs)" (car result)
diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el
index fcfbec427e2..33ab2f5c1c1 100644
--- a/lisp/emacs-lisp/bindat.el
+++ b/lisp/emacs-lisp/bindat.el
@@ -205,22 +205,22 @@
(setq bindat-idx (1+ bindat-idx))))
(defun bindat--unpack-u16 ()
- (logior (lsh (bindat--unpack-u8) 8) (bindat--unpack-u8)))
+ (logior (ash (bindat--unpack-u8) 8) (bindat--unpack-u8)))
(defun bindat--unpack-u24 ()
- (logior (lsh (bindat--unpack-u16) 8) (bindat--unpack-u8)))
+ (logior (ash (bindat--unpack-u16) 8) (bindat--unpack-u8)))
(defun bindat--unpack-u32 ()
- (logior (lsh (bindat--unpack-u16) 16) (bindat--unpack-u16)))
+ (logior (ash (bindat--unpack-u16) 16) (bindat--unpack-u16)))
(defun bindat--unpack-u16r ()
- (logior (bindat--unpack-u8) (lsh (bindat--unpack-u8) 8)))
+ (logior (bindat--unpack-u8) (ash (bindat--unpack-u8) 8)))
(defun bindat--unpack-u24r ()
- (logior (bindat--unpack-u16r) (lsh (bindat--unpack-u8) 16)))
+ (logior (bindat--unpack-u16r) (ash (bindat--unpack-u8) 16)))
(defun bindat--unpack-u32r ()
- (logior (bindat--unpack-u16r) (lsh (bindat--unpack-u16r) 16)))
+ (logior (bindat--unpack-u16r) (ash (bindat--unpack-u16r) 16)))
(defun bindat--unpack-item (type len &optional vectype)
(if (eq type 'ip)
@@ -250,7 +250,7 @@
(if (/= 0 (logand m j))
(setq bits (cons bnum bits)))
(setq bnum (1- bnum)
- j (lsh j -1)))))
+ j (ash j -1)))))
bits))
((eq type 'str)
(let ((s (substring bindat-raw bindat-idx (+ bindat-idx len))))
@@ -459,30 +459,30 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(setq bindat-idx (1+ bindat-idx)))
(defun bindat--pack-u16 (v)
- (aset bindat-raw bindat-idx (logand (lsh v -8) 255))
+ (aset bindat-raw bindat-idx (logand (ash v -8) 255))
(aset bindat-raw (1+ bindat-idx) (logand v 255))
(setq bindat-idx (+ bindat-idx 2)))
(defun bindat--pack-u24 (v)
- (bindat--pack-u8 (lsh v -16))
+ (bindat--pack-u8 (ash v -16))
(bindat--pack-u16 v))
(defun bindat--pack-u32 (v)
- (bindat--pack-u16 (lsh v -16))
+ (bindat--pack-u16 (ash v -16))
(bindat--pack-u16 v))
(defun bindat--pack-u16r (v)
- (aset bindat-raw (1+ bindat-idx) (logand (lsh v -8) 255))
+ (aset bindat-raw (1+ bindat-idx) (logand (ash v -8) 255))
(aset bindat-raw bindat-idx (logand v 255))
(setq bindat-idx (+ bindat-idx 2)))
(defun bindat--pack-u24r (v)
(bindat--pack-u16r v)
- (bindat--pack-u8 (lsh v -16)))
+ (bindat--pack-u8 (ash v -16)))
(defun bindat--pack-u32r (v)
(bindat--pack-u16r v)
- (bindat--pack-u16r (lsh v -16)))
+ (bindat--pack-u16r (ash v -16)))
(defun bindat--pack-item (v type len &optional vectype)
(if (eq type 'ip)
@@ -515,7 +515,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(if (memq bnum v)
(setq m (logior m j)))
(setq bnum (1- bnum)
- j (lsh j -1))))
+ j (ash j -1))))
(bindat--pack-u8 m))))
((memq type '(str strz))
(let ((l (length v)) (i 0))
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 9f9ea8a43ce..44cca6136c0 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -255,7 +255,7 @@
(setq fn (or (symbol-function name)
(cdr (assq name byte-compile-function-environment)))))
(pcase fn
- (`nil
+ ('nil
(byte-compile-warn "attempt to inline `%s' before it was defined"
name)
form)
@@ -436,11 +436,6 @@
(cons (byte-optimize-form (nth 1 form) for-effect)
(byte-optimize-body (cdr (cdr form)) t)))
(byte-optimize-form (nth 1 form) for-effect)))
- ((eq fn 'prog2)
- (cons 'prog2
- (cons (byte-optimize-form (nth 1 form) t)
- (cons (byte-optimize-form (nth 2 form) for-effect)
- (byte-optimize-body (cdr (cdr (cdr form))) t)))))
((memq fn '(save-excursion save-restriction save-current-buffer))
;; those subrs which have an implicit progn; it's not quite good
@@ -635,7 +630,7 @@
(setq form (car (last (cdr form)))))
(cond ((consp form)
(pcase (car form)
- (`quote (cadr form))
+ ('quote (cadr form))
;; Can't use recursion in a defsubst.
;; (`progn (byte-compile-trueconstp (car (last (cdr form)))))
))
@@ -649,22 +644,22 @@
(setq form (car (last (cdr form)))))
(cond ((consp form)
(pcase (car form)
- (`quote (null (cadr form)))
+ ('quote (null (cadr form)))
;; Can't use recursion in a defsubst.
;; (`progn (byte-compile-nilconstp (car (last (cdr form)))))
))
((not (symbolp form)) nil)
((null form))))
-;; If the function is being called with constant numeric args,
+;; If the function is being called with constant integer args,
;; evaluate as much as possible at compile-time. This optimizer
-;; assumes that the function is associative, like + or *.
+;; assumes that the function is associative, like min or max.
(defun byte-optimize-associative-math (form)
(let ((args nil)
(constants nil)
(rest (cdr form)))
(while rest
- (if (numberp (car rest))
+ (if (integerp (car rest))
(setq constants (cons (car rest) constants))
(setq args (cons (car rest) args)))
(setq rest (cdr rest)))
@@ -678,187 +673,134 @@
(apply (car form) constants))
form)))
-;; If the function is being called with constant numeric args,
-;; evaluate as much as possible at compile-time. This optimizer
-;; assumes that the function satisfies
-;; (op x1 x2 ... xn) == (op ...(op (op x1 x2) x3) ...xn)
-;; like - and /.
-(defun byte-optimize-nonassociative-math (form)
- (if (or (not (numberp (car (cdr form))))
- (not (numberp (car (cdr (cdr form))))))
- form
- (let ((constant (car (cdr form)))
- (rest (cdr (cdr form))))
- (while (numberp (car rest))
- (setq constant (funcall (car form) constant (car rest))
- rest (cdr rest)))
- (if rest
- (cons (car form) (cons constant rest))
- constant))))
-
-;;(defun byte-optimize-associative-two-args-math (form)
-;; (setq form (byte-optimize-associative-math form))
-;; (if (consp form)
-;; (byte-optimize-two-args-left form)
-;; form))
-
-;;(defun byte-optimize-nonassociative-two-args-math (form)
-;; (setq form (byte-optimize-nonassociative-math form))
-;; (if (consp form)
-;; (byte-optimize-two-args-right form)
-;; form))
-
-(defun byte-optimize-approx-equal (x y)
- (<= (* (abs (- x y)) 100) (abs (+ x y))))
-
-;; Collect all the constants from FORM, after the STARTth arg,
-;; and apply FUN to them to make one argument at the end.
-;; For functions that can handle floats, that optimization
-;; can be incorrect because reordering can cause an overflow
-;; that would otherwise be avoided by encountering an arg that is a float.
-;; We avoid this problem by (1) not moving float constants and
-;; (2) not moving anything if it would cause an overflow.
-(defun byte-optimize-delay-constants-math (form start fun)
- ;; Merge all FORM's constants from number START, call FUN on them
- ;; and put the result at the end.
- (let ((rest (nthcdr (1- start) form))
- (orig form)
- ;; t means we must check for overflow.
- (overflow (memq fun '(+ *))))
- (while (cdr (setq rest (cdr rest)))
- (if (integerp (car rest))
- (let (constants)
- (setq form (copy-sequence form)
- rest (nthcdr (1- start) form))
- (while (setq rest (cdr rest))
- (cond ((integerp (car rest))
- (setq constants (cons (car rest) constants))
- (setcar rest nil))))
- ;; If necessary, check now for overflow
- ;; that might be caused by reordering.
- (if (and overflow
- ;; We have overflow if the result of doing the arithmetic
- ;; on floats is not even close to the result
- ;; of doing it on integers.
- (not (byte-optimize-approx-equal
- (apply fun (mapcar 'float constants))
- (float (apply fun constants)))))
- (setq form orig)
- (setq form (nconc (delq nil form)
- (list (apply fun (nreverse constants)))))))))
- form))
-
-(defsubst byte-compile-butlast (form)
- (nreverse (cdr (reverse form))))
+;; Portable Emacs integers fall in this range.
+(defconst byte-opt--portable-max #x1fffffff)
+(defconst byte-opt--portable-min (- -1 byte-opt--portable-max))
+
+;; True if N is a number that works the same on all Emacs platforms.
+;; Portable Emacs fixnums are exactly representable as floats on all
+;; Emacs platforms, and (except for -0.0) any floating-point number
+;; that equals one of these integers must be the same on all
+;; platforms. Although other floating-point numbers such as 0.5 are
+;; also portable, it can be tricky to characterize them portably so
+;; they are not optimized.
+(defun byte-opt--portable-numberp (n)
+ (and (numberp n)
+ (<= byte-opt--portable-min n byte-opt--portable-max)
+ (= n (floor n))
+ (not (and (floatp n) (zerop n)
+ (condition-case () (< (/ n) 0) (error))))))
+
+;; Use OP to reduce any leading prefix of portable numbers in the list
+;; (cons ACCUM ARGS) down to a single portable number, and return the
+;; resulting list A of arguments. The idea is that applying OP to A
+;; is equivalent to (but likely more efficient than) applying OP to
+;; (cons ACCUM ARGS), on any Emacs platform. Do not make any special
+;; provision for (- X) or (/ X); for example, it is the caller’s
+;; responsibility that (- 1 0) should not be "optimized" to (- 1).
+(defun byte-opt--arith-reduce (op accum args)
+ (when (byte-opt--portable-numberp accum)
+ (let (accum1)
+ (while (and (byte-opt--portable-numberp (car args))
+ (byte-opt--portable-numberp
+ (setq accum1 (condition-case ()
+ (funcall op accum (car args))
+ (error))))
+ (= accum1 (funcall op (float accum) (car args))))
+ (setq accum accum1)
+ (setq args (cdr args)))))
+ (cons accum args))
(defun byte-optimize-plus (form)
- ;; Don't call `byte-optimize-delay-constants-math' (bug#1334).
- ;;(setq form (byte-optimize-delay-constants-math form 1 '+))
- (if (memq 0 form) (setq form (delq 0 (copy-sequence form))))
- ;; For (+ constants...), byte-optimize-predicate does the work.
- (when (memq nil (mapcar 'numberp (cdr form)))
+ (let ((args (remq 0 (byte-opt--arith-reduce #'+ 0 (cdr form)))))
(cond
+ ;; (+) -> 0
+ ((null args) 0)
+ ;; (+ n) -> n, where n is a number
+ ((and (null (cdr args)) (numberp (car args))) (car args))
;; (+ x 1) --> (1+ x) and (+ x -1) --> (1- x).
- ((and (= (length form) 3)
- (or (memq (nth 1 form) '(1 -1))
- (memq (nth 2 form) '(1 -1))))
- (let (integer other)
- (if (memq (nth 1 form) '(1 -1))
- (setq integer (nth 1 form) other (nth 2 form))
- (setq integer (nth 2 form) other (nth 1 form)))
- (setq form
- (list (if (eq integer 1) '1+ '1-) other))))
- ;; Here, we could also do
- ;; (+ x y ... 1) --> (1+ (+ x y ...))
- ;; (+ x y ... -1) --> (1- (+ x y ...))
- ;; The resulting bytecode is smaller, but is it faster? -- cyd
- ))
- (byte-optimize-predicate form))
+ ((and (null (cddr args)) (or (memq 1 args) (memq -1 args)))
+ (let* ((arg1 (car args)) (arg2 (cadr args))
+ (integer-is-first (memq arg1 '(1 -1)))
+ (integer (if integer-is-first arg1 arg2))
+ (other (if integer-is-first arg2 arg1)))
+ (list (if (eq integer 1) '1+ '1-) other)))
+ ;; not further optimized
+ ((equal args (cdr form)) form)
+ (t (cons '+ args)))))
(defun byte-optimize-minus (form)
- ;; Don't call `byte-optimize-delay-constants-math' (bug#1334).
- ;;(setq form (byte-optimize-delay-constants-math form 2 '+))
- ;; Remove zeros.
- (when (and (nthcdr 3 form)
- (memq 0 (cddr form)))
- (setq form (nconc (list (car form) (cadr form))
- (delq 0 (copy-sequence (cddr form)))))
- ;; After the above, we must turn (- x) back into (- x 0)
- (or (cddr form)
- (setq form (nconc form (list 0)))))
- ;; For (- constants..), byte-optimize-predicate does the work.
- (when (memq nil (mapcar 'numberp (cdr form)))
- (cond
- ;; (- x 1) --> (1- x)
- ((equal (nthcdr 2 form) '(1))
- (setq form (list '1- (nth 1 form))))
- ;; (- x -1) --> (1+ x)
- ((equal (nthcdr 2 form) '(-1))
- (setq form (list '1+ (nth 1 form))))
- ;; (- 0 x) --> (- x)
- ((and (eq (nth 1 form) 0)
- (= (length form) 3))
- (setq form (list '- (nth 2 form))))
- ;; Here, we could also do
- ;; (- x y ... 1) --> (1- (- x y ...))
- ;; (- x y ... -1) --> (1+ (- x y ...))
- ;; The resulting bytecode is smaller, but is it faster? -- cyd
- ))
- (byte-optimize-predicate form))
-
-(defun byte-optimize-multiply (form)
- (setq form (byte-optimize-delay-constants-math form 1 '*))
- ;; For (* constants..), byte-optimize-predicate does the work.
- (when (memq nil (mapcar 'numberp (cdr form)))
- ;; After `byte-optimize-predicate', if there is a INTEGER constant
- ;; in FORM, it is in the last element.
- (let ((last (car (reverse (cdr form)))))
+ (let ((args (cdr form)))
+ (if (and (cdr args)
+ (null (cdr (setq args (byte-opt--arith-reduce
+ #'- (car args) (cdr args)))))
+ (numberp (car args)))
+ ;; The entire argument list reduced to a constant; return it.
+ (car args)
+ ;; Remove non-leading zeros, except for (- x 0).
+ (when (memq 0 (cdr args))
+ (setq args (cons (car args) (or (remq 0 (cdr args)) (list 0)))))
(cond
- ;; Would handling (* ... 0) here cause floating point errors?
- ;; See bug#1334.
- ((eq 1 last) (setq form (byte-compile-butlast form)))
- ((eq -1 last)
- (setq form (list '- (if (nthcdr 3 form)
- (byte-compile-butlast form)
- (nth 1 form))))))))
- (byte-optimize-predicate form))
+ ;; (- x 1) --> (1- x)
+ ((equal (cdr args) '(1))
+ (list '1- (car args)))
+ ;; (- x -1) --> (1+ x)
+ ((equal (cdr args) '(-1))
+ (list '1+ (car args)))
+ ;; (- n) -> -n, where n and -n are portable numbers.
+ ;; This must be done separately since byte-opt--arith-reduce
+ ;; is not applied to (- n).
+ ((and (null (cdr args))
+ (byte-opt--portable-numberp (car args))
+ (byte-opt--portable-numberp (- (car args))))
+ (- (car args)))
+ ;; not further optimized
+ ((equal args (cdr form)) form)
+ (t (cons '- args))))))
+
+(defun byte-optimize-1+ (form)
+ (let ((args (cdr form)))
+ (when (null (cdr args))
+ (let ((n (car args)))
+ (when (and (byte-opt--portable-numberp n)
+ (byte-opt--portable-numberp (1+ n)))
+ (setq form (1+ n))))))
+ form)
+
+(defun byte-optimize-1- (form)
+ (let ((args (cdr form)))
+ (when (null (cdr args))
+ (let ((n (car args)))
+ (when (and (byte-opt--portable-numberp n)
+ (byte-opt--portable-numberp (1- n)))
+ (setq form (1- n))))))
+ form)
-(defun byte-optimize-divide (form)
- (setq form (byte-optimize-delay-constants-math form 2 '*))
- ;; After `byte-optimize-predicate', if there is a INTEGER constant
- ;; in FORM, it is in the last element.
- (let ((last (car (reverse (cdr (cdr form))))))
+(defun byte-optimize-multiply (form)
+ (let* ((args (remq 1 (byte-opt--arith-reduce #'* 1 (cdr form)))))
(cond
- ;; Runtime error (leave it intact).
- ((or (null last)
- (eq last 0)
- (memql 0.0 (cddr form))))
- ;; No constants in expression
- ((not (numberp last)))
- ;; For (* constants..), byte-optimize-predicate does the work.
- ((null (memq nil (mapcar 'numberp (cdr form)))))
- ;; (/ x y.. 1) --> (/ x y..)
- ((and (eq last 1) (nthcdr 3 form))
- (setq form (byte-compile-butlast form)))
- ;; (/ x -1), (/ x .. -1) --> (- x), (- (/ x ..))
- ((eq last -1)
- (setq form (list '- (if (nthcdr 3 form)
- (byte-compile-butlast form)
- (nth 1 form)))))))
- (byte-optimize-predicate form))
-
-(defun byte-optimize-logmumble (form)
- (setq form (byte-optimize-delay-constants-math form 1 (car form)))
- (byte-optimize-predicate
- (cond ((memq 0 form)
- (setq form (if (eq (car form) 'logand)
- (cons 'progn (cdr form))
- (delq 0 (copy-sequence form)))))
- ((and (eq (car-safe form) 'logior)
- (memq -1 form))
- (cons 'progn (cdr form)))
- (form))))
+ ;; (*) -> 1
+ ((null args) 1)
+ ;; (* n) -> n, where n is a number
+ ((and (null (cdr args)) (numberp (car args))) (car args))
+ ;; not further optimized
+ ((equal args (cdr form)) form)
+ (t (cons '* args)))))
+(defun byte-optimize-divide (form)
+ (let ((args (cdr form)))
+ (if (and (cdr args)
+ (null (cdr (setq args (byte-opt--arith-reduce
+ #'/ (car args) (cdr args)))))
+ (numberp (car args)))
+ ;; The entire argument list reduced to a constant; return it.
+ (car args)
+ ;; Remove non-leading 1s, except for (/ x 1).
+ (when (memq 1 (cdr args))
+ (setq args (cons (car args) (or (remq 1 (cdr args)) (list 1)))))
+ (if (equal args (cdr form))
+ form
+ (cons '/ args)))))
(defun byte-optimize-binary-predicate (form)
(cond
@@ -892,7 +834,24 @@
(if (= 1 (length (cdr form))) "" "s"))
form))
+(defun byte-optimize-memq (form)
+ ;; (memq foo '(bar)) => (and (eq foo 'bar) '(bar))
+ (if (/= (length (cdr form)) 2)
+ (byte-compile-warn "memq called with %d arg%s, but requires 2"
+ (length (cdr form))
+ (if (= 1 (length (cdr form))) "" "s"))
+ (let ((list (nth 2 form)))
+ (when (and (eq (car-safe list) 'quote)
+ (listp (setq list (cadr list)))
+ (= (length list) 1))
+ (setq form (byte-optimize-and
+ `(and ,(byte-optimize-predicate
+ `(eq ,(nth 1 form) ',(nth 0 list)))
+ ',list)))))
+ (byte-optimize-predicate form)))
+
(put 'identity 'byte-optimizer 'byte-optimize-identity)
+(put 'memq 'byte-optimizer 'byte-optimize-memq)
(put '+ 'byte-optimizer 'byte-optimize-plus)
(put '* 'byte-optimizer 'byte-optimize-multiply)
@@ -911,21 +870,21 @@
(put '> 'byte-optimizer 'byte-optimize-predicate)
(put '<= 'byte-optimizer 'byte-optimize-predicate)
(put '>= 'byte-optimizer 'byte-optimize-predicate)
-(put '1+ 'byte-optimizer 'byte-optimize-predicate)
-(put '1- 'byte-optimizer 'byte-optimize-predicate)
+(put '1+ 'byte-optimizer 'byte-optimize-1+)
+(put '1- 'byte-optimizer 'byte-optimize-1-)
(put 'not 'byte-optimizer 'byte-optimize-predicate)
(put 'null 'byte-optimizer 'byte-optimize-predicate)
-(put 'memq 'byte-optimizer 'byte-optimize-predicate)
(put 'consp 'byte-optimizer 'byte-optimize-predicate)
(put 'listp 'byte-optimizer 'byte-optimize-predicate)
(put 'symbolp 'byte-optimizer 'byte-optimize-predicate)
(put 'stringp 'byte-optimizer 'byte-optimize-predicate)
(put 'string< 'byte-optimizer 'byte-optimize-predicate)
-(put 'string-lessp 'byte-optimizer 'byte-optimize-predicate)
+(put 'string-lessp 'byte-optimizer 'byte-optimize-predicate)
+(put 'proper-list-p 'byte-optimizer 'byte-optimize-predicate)
-(put 'logand 'byte-optimizer 'byte-optimize-logmumble)
-(put 'logior 'byte-optimizer 'byte-optimize-logmumble)
-(put 'logxor 'byte-optimizer 'byte-optimize-logmumble)
+(put 'logand 'byte-optimizer 'byte-optimize-predicate)
+(put 'logior 'byte-optimizer 'byte-optimize-predicate)
+(put 'logxor 'byte-optimizer 'byte-optimize-predicate)
(put 'lognot 'byte-optimizer 'byte-optimize-predicate)
(put 'car 'byte-optimizer 'byte-optimize-predicate)
@@ -933,7 +892,6 @@
(put 'car-safe 'byte-optimizer 'byte-optimize-predicate)
(put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate)
-
;; I'm not convinced that this is necessary. Doesn't the optimizer loop
;; take care of this? - Jamie
;; I think this may some times be necessary to reduce ie (quote 5) to 5,
@@ -967,8 +925,7 @@
;; Throw away nil's, and simplify if less than 2 args.
;; If there is a literal non-nil constant in the args to `or', throw away all
;; following forms.
- (if (memq nil form)
- (setq form (delq nil (copy-sequence form))))
+ (setq form (remq nil form))
(let ((rest form))
(while (cdr (setq rest (cdr rest)))
(if (byte-compile-trueconstp (car rest))
@@ -985,9 +942,8 @@
(let (rest)
;; This must be first, to reduce (cond (t ...) (nil)) to (progn t ...)
(while (setq rest (assq nil (cdr form)))
- (setq form (delq rest (copy-sequence form))))
- (if (memq nil (cdr form))
- (setq form (delq nil (copy-sequence form))))
+ (setq form (remq rest form)))
+ (setq form (remq nil form))
(setq rest form)
(while (setq rest (cdr rest))
(cond ((byte-compile-trueconstp (car-safe (car rest)))
@@ -1022,8 +978,7 @@
;; (if <test> <then> nil) ==> (if <test> <then>)
(let ((clause (nth 1 form)))
(cond ((and (eq (car-safe clause) 'progn)
- ;; `clause' is a proper list.
- (null (cdr (last clause))))
+ (proper-list-p clause))
(if (null (cddr clause))
;; A trivial `progn'.
(byte-optimize-if `(if ,(cadr clause) ,@(nthcdr 2 form)))
@@ -1186,6 +1141,7 @@
char-equal char-to-string char-width compare-strings
compare-window-configurations concat coordinates-in-window-p
copy-alist copy-sequence copy-marker cos count-lines
+ current-time-string current-time-zone
decode-char
decode-time default-boundp default-value documentation downcase
elt encode-char exp expt encode-time error-message-string
@@ -1199,8 +1155,9 @@
hash-table-count
int-to-string intern-soft
keymap-parent
- length local-variable-if-set-p local-variable-p log log10 logand
- logb logior lognot logxor lsh langinfo
+ length line-beginning-position line-end-position
+ local-variable-if-set-p local-variable-p locale-info
+ log log10 logand logb logcount logior lognot logxor lsh
make-list make-string make-symbol marker-buffer max member memq min
minibuffer-selected-window minibuffer-window
mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string
@@ -1210,7 +1167,7 @@
radians-to-degrees rassq rassoc read-from-string regexp-quote
region-beginning region-end reverse round
sin sqrt string string< string= string-equal string-lessp string-to-char
- string-to-int string-to-number substring
+ string-to-number substring
sxhash sxhash-equal sxhash-eq sxhash-eql
symbol-function symbol-name symbol-plist symbol-value string-make-unibyte
string-make-multibyte string-as-multibyte string-as-unibyte
@@ -1234,23 +1191,22 @@
window-width zerop))
(side-effect-and-error-free-fns
'(arrayp atom
- bobp bolp bool-vector-p
+ bignump bobp bolp bool-vector-p
buffer-end buffer-list buffer-size buffer-string bufferp
car-safe case-table-p cdr-safe char-or-string-p characterp
charsetp commandp cons consp
current-buffer current-global-map current-indentation
current-local-map current-minor-mode-maps current-time
- current-time-string current-time-zone
eobp eolp eq equal eventp
- floatp following-char framep
+ fixnump floatp following-char framep
get-largest-window get-lru-window
hash-table-p
identity ignore integerp integer-or-marker-p interactive-p
invocation-directory invocation-name
keymapp keywordp
- line-beginning-position line-end-position list listp
+ list listp
make-marker mark mark-marker markerp max-char
- memory-limit minibuffer-window
+ memory-limit
mouse-movement-p
natnump nlistp not null number-or-marker-p numberp
one-window-p overlayp
@@ -1275,13 +1231,24 @@
nil)
-;; pure functions are side-effect free functions whose values depend
-;; only on their arguments. For these functions, calls with constant
-;; arguments can be evaluated at compile time. This may shift run time
-;; errors to compile time.
+;; Pure functions are side-effect free functions whose values depend
+;; only on their arguments, not on the platform. For these functions,
+;; calls with constant arguments can be evaluated at compile time.
+;; This may shift runtime errors to compile time. For example, logand
+;; is pure since its results are machine-independent, whereas ash is
+;; not pure because (ash 1 29)'s value depends on machine word size.
+;;
+;; When deciding whether a function is pure, do not worry about
+;; mutable strings or markers, as they are so unlikely in real code
+;; that they are not worth worrying about. Thus string-to-char is
+;; pure even though it might return different values if a string is
+;; changed, and logand is pure even though it might return different
+;; values if a marker is moved.
(let ((pure-fns
- '(concat symbol-name regexp-opt regexp-quote string-to-syntax)))
+ '(% concat logand logcount logior lognot logxor
+ regexp-opt regexp-quote
+ string-to-char string-to-syntax symbol-name)))
(while pure-fns
(put (car pure-fns) 'pure t)
(setq pure-fns (cdr pure-fns)))
@@ -1312,7 +1279,7 @@
(setq bytedecomp-ptr (1+ bytedecomp-ptr))
(+ (aref bytes bytedecomp-ptr)
(progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
- (lsh (aref bytes bytedecomp-ptr) 8))))
+ (ash (aref bytes bytedecomp-ptr) 8))))
(t tem)))) ;Offset was in opcode.
((>= bytedecomp-op byte-constant)
(prog1 (- bytedecomp-op byte-constant) ;Offset in opcode.
@@ -1326,7 +1293,7 @@
(setq bytedecomp-ptr (1+ bytedecomp-ptr))
(+ (aref bytes bytedecomp-ptr)
(progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
- (lsh (aref bytes bytedecomp-ptr) 8))))
+ (ash (aref bytes bytedecomp-ptr) 8))))
((and (>= bytedecomp-op byte-listN)
(<= bytedecomp-op byte-discardN))
(setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;Offset in next byte.
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 3e9e0808b57..b638b56be1f 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -116,7 +116,10 @@ If `error-free', drop calls even if `byte-compile-delete-errors' is nil.")
(if (not (eq (car-safe compiler-function) 'lambda))
`(eval-and-compile
(function-put ',f 'compiler-macro #',compiler-function))
- (let ((cfname (intern (concat (symbol-name f) "--anon-cmacro"))))
+ (let ((cfname (intern (concat (symbol-name f) "--anon-cmacro")))
+ ;; Avoid cadr/cddr so we can use `compiler-macro' before
+ ;; defining cadr/cddr.
+ (data (cdr compiler-function)))
`(progn
(eval-and-compile
(function-put ',f 'compiler-macro #',cfname))
@@ -125,8 +128,8 @@ If `error-free', drop calls even if `byte-compile-delete-errors' is nil.")
;; if needed.
:autoload-end
(eval-and-compile
- (defun ,cfname (,@(cadr compiler-function) ,@args)
- ,@(cddr compiler-function))))))))
+ (defun ,cfname (,@(car data) ,@args)
+ ,@(cdr data))))))))
(list 'doc-string
#'(lambda (f _args pos)
(list 'function-put (list 'quote f)
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 9ea4179b68d..8bbe6292d9d 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -124,17 +124,11 @@
(require 'backquote)
(require 'macroexp)
(require 'cconv)
-(require 'cl-lib)
-
-;; During bootstrap, cl-loaddefs.el is not created yet, so loading cl-lib
-;; doesn't setup autoloads for things like cl-every, which is why we have to
-;; require cl-extra as well (bug#18804).
-(or (fboundp 'cl-every)
- (require 'cl-extra))
-
-(or (fboundp 'defsubst)
- ;; This really ought to be loaded already!
- (load "byte-run"))
+(eval-when-compile (require 'compile))
+;; Refrain from using cl-lib at run-time here, since it otherwise prevents
+;; us from emitting warnings when compiling files which use cl-lib without
+;; requiring it! (bug#30635)
+(eval-when-compile (require 'cl-lib))
;; The feature of compiling in a specific target Emacs version
;; has been turned off because compile time options are a bad idea.
@@ -842,7 +836,7 @@ all the arguments.
(defmacro byte-compile-push-bytecode-const2 (opcode const2 bytes pc)
"Push OPCODE and the two-byte constant CONST2 onto BYTES, and add 3 to PC.
CONST2 may be evaluated multiple times."
- `(byte-compile-push-bytecodes ,opcode (logand ,const2 255) (lsh ,const2 -8)
+ `(byte-compile-push-bytecodes ,opcode (logand ,const2 255) (ash ,const2 -8)
,bytes ,pc))
(defun byte-compile-lapcode (lap)
@@ -932,9 +926,9 @@ CONST2 may be evaluated multiple times."
;; Splits PC's value into 2 bytes. The jump address is
;; "reconstructed" by the `FETCH2' macro in `bytecode.c'.
(setcar (cdr bytes-tail) (logand pc 255))
- (setcar bytes-tail (lsh pc -8))
+ (setcar bytes-tail (ash pc -8))
;; FIXME: Replace this by some workaround.
- (if (> (car bytes-tail) 255) (error "Bytecode overflow")))
+ (or (<= 0 (car bytes-tail) 255) (error "Bytecode overflow")))
;; Similarly, replace TAGs in all jump tables with the correct PC index.
(dolist (hash-table byte-compile-jump-tables)
@@ -1013,6 +1007,24 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
;;; byte compiler messages
+(defun emacs-lisp-compilation-file-name-or-buffer (str)
+ "Return file name or buffer given by STR.
+If STR is a \"normal\" filename, just return it.
+If STR is something like \"Buffer foo.el\", return #<buffer foo.el>
+\(if it is still live) or the string \"foo.el\" otherwise."
+ (if (string-match "Buffer \\(.*\\)\\'" str)
+ (or (get-buffer (match-string-no-properties 1 str))
+ (match-string-no-properties 1 str))
+ str))
+
+(defconst emacs-lisp-compilation-parse-errors-filename-function
+ 'emacs-lisp-compilation-file-name-or-buffer
+ "The value for `compilation-parse-errors-filename-function' for when
+we go into emacs-lisp-compilation-mode.")
+
+(define-compilation-mode emacs-lisp-compilation-mode "elisp-compile"
+ "The variant of `compilation-mode' used for emacs-lisp error buffers")
+
(defvar byte-compile-current-form nil)
(defvar byte-compile-dest-file nil)
(defvar byte-compile-current-file nil)
@@ -1172,7 +1184,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(with-current-buffer (get-buffer-create byte-compile-log-buffer)
(goto-char (point-max))
(let* ((inhibit-read-only t)
- (dir (and byte-compile-current-file
+ (dir (and (stringp byte-compile-current-file)
(file-name-directory byte-compile-current-file)))
(was-same (equal default-directory dir))
pt)
@@ -1187,10 +1199,10 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(insert "\f\nCompiling "
(if (stringp byte-compile-current-file)
(concat "file " byte-compile-current-file)
- (concat "buffer "
+ (concat "in buffer "
(buffer-name byte-compile-current-file)))
" at " (current-time-string) "\n")
- (insert "\f\nCompiling no file at " (current-time-string) "\n"))
+ (insert "\f\nCompiling internal form(s) at " (current-time-string) "\n"))
(when dir
(setq default-directory dir)
(unless was-same
@@ -1199,7 +1211,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(setq byte-compile-last-logged-file byte-compile-current-file
byte-compile-last-warned-form nil)
;; Do this after setting default-directory.
- (unless (derived-mode-p 'compilation-mode) (compilation-mode))
+ (unless (derived-mode-p 'compilation-mode)
+ (emacs-lisp-compilation-mode))
(compilation-forget-errors)
pt))))
@@ -1737,8 +1750,8 @@ that already has a `.elc' file."
(file-name-nondirectory source))))
(progn (cl-incf
(pcase (byte-recompile-file source force arg)
- (`no-byte-compile skip-count)
- (`t file-count)
+ ('no-byte-compile skip-count)
+ ('t file-count)
(_ fail-count)))
(or noninteractive
(message "Checking %s..." directory))
@@ -1988,7 +2001,7 @@ With argument ARG, insert value in current buffer after the form."
(save-excursion
(end-of-defun)
(beginning-of-defun)
- (let* ((byte-compile-current-file nil)
+ (let* ((byte-compile-current-file (current-buffer))
(byte-compile-current-buffer (current-buffer))
(byte-compile-read-position (point))
(byte-compile-last-position byte-compile-read-position)
@@ -2069,14 +2082,8 @@ With argument ARG, insert value in current buffer after the form."
(not (eobp)))
(setq byte-compile-read-position (point)
byte-compile-last-position byte-compile-read-position)
- (let* ((lread--old-style-backquotes nil)
- (lread--unescaped-character-literals nil)
+ (let* ((lread--unescaped-character-literals nil)
(form (read inbuffer)))
- ;; Warn about the use of old-style backquotes.
- (when lread--old-style-backquotes
- (byte-compile-warn "!! The file uses old-style backquotes !!
-This functionality has been obsolete for more than 10 years already
-and will be removed soon. See (elisp)Backquote in the manual."))
(when lread--unescaped-character-literals
(byte-compile-warn
"unescaped character literals %s detected!"
@@ -2439,6 +2446,16 @@ list that represents a doc string reference.
(defun byte-compile-file-form-defvar-function (form)
(pcase-let (((or `',name (let name nil)) (nth 1 form)))
(if name (byte-compile--declare-var name)))
+ ;; Variable aliases are better declared before the corresponding variable,
+ ;; since it makes it more likely that only one of the two vars has a value
+ ;; before the `defvaralias' gets executed, which avoids the need to
+ ;; merge values.
+ (pcase form
+ (`(defvaralias ,_ ',newname . ,_)
+ (when (memq newname byte-compile-bound-variables)
+ (if (byte-compile-warning-enabled-p 'suspicious)
+ (byte-compile-warn
+ "Alias for `%S' should be declared before its referent" newname)))))
(byte-compile-keep-pending form))
(put 'custom-declare-variable 'byte-hunk-handler
@@ -2484,9 +2501,8 @@ list that represents a doc string reference.
(put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn)
(put 'prog1 'byte-hunk-handler 'byte-compile-file-form-progn)
-(put 'prog2 'byte-hunk-handler 'byte-compile-file-form-progn)
(defun byte-compile-file-form-progn (form)
- (mapc 'byte-compile-file-form (cdr form))
+ (mapc #'byte-compile-file-form (cdr form))
;; Return nil so the forms are not output twice.
nil)
@@ -2498,6 +2514,12 @@ list that represents a doc string reference.
(mapc 'byte-compile-file-form (cdr form))
nil))
+;; Automatically evaluate define-obsolete-function-alias etc at top-level.
+(put 'make-obsolete 'byte-hunk-handler 'byte-compile-file-form-make-obsolete)
+(defun byte-compile-file-form-make-obsolete (form)
+ (prog1 (byte-compile-keep-pending form)
+ (apply 'make-obsolete (mapcar 'eval (cdr form)))))
+
;; This handler is not necessary, but it makes the output from dont-compile
;; and similar macros cleaner.
(put 'eval 'byte-hunk-handler 'byte-compile-file-form-eval)
@@ -2744,15 +2766,12 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(macroexp--const-symbol-p arg t))
(error "Invalid lambda variable %s" arg))
((eq arg '&rest)
- (unless (cdr list)
- (error "&rest without variable name"))
(when (cddr list)
- (error "Garbage following &rest VAR in lambda-list")))
+ (error "Garbage following &rest VAR in lambda-list"))
+ (when (memq (cadr list) '(&optional &rest))
+ (error "%s following &rest in lambda-list" (cadr list))))
((eq arg '&optional)
- (when (or (null (cdr list))
- (memq (cadr list) '(&optional &rest)))
- (error "Variable name missing after &optional"))
- (when (memq '&optional (cddr list))
+ (when (memq '&optional (cdr list))
(error "Duplicate &optional")))
((memq arg vars)
(byte-compile-warn "repeated variable %s in lambda-list" arg))
@@ -2793,8 +2812,8 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(if (> mandatory 127)
(byte-compile-report-error "Too many (>127) mandatory arguments")
(logior mandatory
- (lsh nonrest 8)
- (lsh rest 7)))))
+ (ash nonrest 8)
+ (ash rest 7)))))
(defun byte-compile-lambda (fun &optional add-lambda reserved-csts)
@@ -2845,9 +2864,10 @@ for symbols generated by the byte compiler itself."
(setq form (cdr form)))
(setq form (car form)))
(if (and (eq (car-safe form) 'list)
- ;; The spec is evalled in callint.c in dynamic-scoping
- ;; mode, so just leaving the form unchanged would mean
- ;; it won't be eval'd in the right mode.
+ ;; For code using lexical-binding, form is not
+ ;; valid lisp, but rather an intermediate form
+ ;; which may include "calls" to
+ ;; internal-make-closure (Bug#29988).
(not lexical-binding))
nil
(setq int `(interactive ,newform)))))
@@ -3118,7 +3138,13 @@ for symbols generated by the byte compiler itself."
(when (assq var byte-compile-lexical-variables)
(byte-compile-report-error
(format-message "%s cannot use lexical var `%s'" fn var))))))
- (when (macroexp--const-symbol-p fn)
+ ;; Warn about using obsolete hooks.
+ (if (memq fn '(add-hook remove-hook))
+ (let ((hook (car-safe (cdr form))))
+ (if (eq (car-safe hook) 'quote)
+ (byte-compile-check-variable (cadr hook) nil))))
+ (when (and (byte-compile-warning-enabled-p 'suspicious)
+ (macroexp--const-symbol-p fn))
(byte-compile-warn "`%s' called as a function" fn))
(when (and (byte-compile-warning-enabled-p 'interactive-only)
interactive-only)
@@ -3251,7 +3277,7 @@ for symbols generated by the byte compiler itself."
(fun (car form))
(fargs (aref fun 0))
(start-depth byte-compile-depth)
- (fmax2 (if (numberp fargs) (lsh fargs -7))) ;2*max+rest.
+ (fmax2 (if (numberp fargs) (ash fargs -7))) ;2*max+rest.
;; (fmin (if (numberp fargs) (logand fargs 127)))
(alen (length (cdr form)))
(dynbinds ())
@@ -3270,8 +3296,8 @@ for symbols generated by the byte compiler itself."
(cl-assert (listp fargs))
(while fargs
(pcase (car fargs)
- (`&optional (setq fargs (cdr fargs)))
- (`&rest (setq fmax2 (+ (* 2 (length dynbinds)) 1))
+ ('&optional (setq fargs (cdr fargs)))
+ ('&rest (setq fmax2 (+ (* 2 (length dynbinds)) 1))
(push (cadr fargs) dynbinds)
(setq fargs nil))
(_ (push (pop fargs) dynbinds))))
@@ -3318,8 +3344,8 @@ for symbols generated by the byte compiler itself."
(not (memq var byte-compile-not-obsolete-vars))
(not (memq var byte-compile-global-not-obsolete-vars))
(or (pcase (nth 1 od)
- (`set (not (eq access-type 'reference)))
- (`get (eq access-type 'reference))
+ ('set (not (eq access-type 'reference)))
+ ('get (eq access-type 'reference))
(_ t)))))
(byte-compile-warn-obsolete var))))
@@ -3507,7 +3533,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
(byte-defop-compiler (>= byte-geq) 2-and)
(byte-defop-compiler get 2)
(byte-defop-compiler nth 2)
-(byte-defop-compiler substring 2-3)
+(byte-defop-compiler substring 1-3)
(byte-defop-compiler (move-marker byte-set-marker) 2-3)
(byte-defop-compiler set-marker 2-3)
(byte-defop-compiler match-beginning 1)
@@ -3575,7 +3601,8 @@ These implicitly `and' together a bunch of two-arg bytecodes."
(cond
((< l 3) (byte-compile-form `(progn ,(nth 1 form) t)))
((= l 3) (byte-compile-two-args form))
- ((cl-every #'macroexp-copyable-p (nthcdr 2 form))
+ ;; Don't use `cl-every' here (see comment where we require cl-lib).
+ ((not (memq nil (mapcar #'macroexp-copyable-p (nthcdr 2 form))))
(byte-compile-form `(and (,(car form) ,(nth 1 form) ,(nth 2 form))
(,(car form) ,@(nthcdr 2 form)))))
(t (byte-compile-normal-call form)))))
@@ -3882,7 +3909,6 @@ discarding."
(byte-defop-compiler-1 setq)
-(byte-defop-compiler-1 setq-default)
(byte-defop-compiler-1 quote)
(defun byte-compile-setq (form)
@@ -3907,34 +3933,20 @@ discarding."
(byte-compile-form nil byte-compile--for-effect)))
(setq byte-compile--for-effect nil)))
-(defun byte-compile-setq-default (form)
- (setq form (cdr form))
- (if (null form) ; (setq-default), with no arguments
- (byte-compile-form nil byte-compile--for-effect)
- (if (> (length form) 2)
- (let ((setters ()))
- (while (consp form)
- (push `(setq-default ,(pop form) ,(pop form)) setters))
- (byte-compile-form (cons 'progn (nreverse setters))))
- (let ((var (car form)))
- (and (or (not (symbolp var))
- (macroexp--const-symbol-p var t))
- (byte-compile-warning-enabled-p 'constants)
- (byte-compile-warn
- "variable assignment to %s `%s'"
- (if (symbolp var) "constant" "nonvariable")
- (prin1-to-string var)))
- (byte-compile-normal-call `(set-default ',var ,@(cdr form)))))))
-
(byte-defop-compiler-1 set-default)
(defun byte-compile-set-default (form)
(let ((varexp (car-safe (cdr-safe form))))
(if (eq (car-safe varexp) 'quote)
- ;; If the varexp is constant, compile it as a setq-default
- ;; so we get more warnings.
- (byte-compile-setq-default `(setq-default ,(car-safe (cdr varexp))
- ,@(cddr form)))
- (byte-compile-normal-call form))))
+ ;; If the varexp is constant, check the var's name.
+ (let ((var (car-safe (cdr varexp))))
+ (and (or (not (symbolp var))
+ (macroexp--const-symbol-p var t))
+ (byte-compile-warning-enabled-p 'constants)
+ (byte-compile-warn
+ "variable assignment to %s `%s'"
+ (if (symbolp var) "constant" "nonvariable")
+ (prin1-to-string var)))))
+ (byte-compile-normal-call form)))
(defun byte-compile-quote (form)
(byte-compile-constant (car (cdr form))))
@@ -3958,7 +3970,6 @@ discarding."
(byte-defop-compiler-1 inline byte-compile-progn)
(byte-defop-compiler-1 progn)
(byte-defop-compiler-1 prog1)
-(byte-defop-compiler-1 prog2)
(byte-defop-compiler-1 if)
(byte-defop-compiler-1 cond)
(byte-defop-compiler-1 and)
@@ -3975,11 +3986,6 @@ discarding."
(byte-compile-form-do-effect (car (cdr form)))
(byte-compile-body (cdr (cdr form)) t))
-(defun byte-compile-prog2 (form)
- (byte-compile-form (nth 1 form) t)
- (byte-compile-form-do-effect (nth 2 form))
- (byte-compile-body (cdr (cdr (cdr form))) t))
-
(defmacro byte-compile-goto-if (cond discard tag)
`(byte-compile-goto
(if ,cond
@@ -4723,7 +4729,7 @@ binding slots have been popped."
arg)
;; `lam' is the lambda expression in `fun' (or nil if not
;; recognized).
- ((or `(,(or `quote `function) ,lam) (let lam nil))
+ ((or `(,(or 'quote 'function) ,lam) (let lam nil))
fun)
;; `arglist' is the list of arguments (or t if not recognized).
;; `body' is the body of `lam' (or t if not recognized).
@@ -4910,18 +4916,18 @@ invoked interactively."
(setq byte-compile-call-tree
(sort byte-compile-call-tree
(pcase byte-compile-call-tree-sort
- (`callers
+ ('callers
(lambda (x y) (< (length (nth 1 x))
- (length (nth 1 y)))))
- (`calls
+ (length (nth 1 y)))))
+ ('calls
(lambda (x y) (< (length (nth 2 x))
- (length (nth 2 y)))))
- (`calls+callers
+ (length (nth 2 y)))))
+ ('calls+callers
(lambda (x y) (< (+ (length (nth 1 x))
- (length (nth 2 x)))
- (+ (length (nth 1 y))
- (length (nth 2 y))))))
- (`name
+ (length (nth 2 x)))
+ (+ (length (nth 1 y))
+ (length (nth 2 y))))))
+ ('name
(lambda (x y) (string< (car x) (car y))))
(_ (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode"
byte-compile-call-tree-sort))))))
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 80f6b06a289..58ca9d5f57e 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -206,7 +206,6 @@ Returns a form where all lambdas don't have any free variables."
(cl-assert (equal body (caar cconv-freevars-alist)))
(let* ((fvs (cdr (pop cconv-freevars-alist)))
(body-new '())
- (letbind '())
(envector ())
(i 0)
(new-env ()))
@@ -227,25 +226,8 @@ Returns a form where all lambdas don't have any free variables."
(setq envector (nreverse envector))
(setq new-env (nreverse new-env))
- (dolist (arg args)
- (if (not (member (cons (list arg) parentform) cconv-captured+mutated))
- (if (assq arg new-env) (push `(,arg) new-env))
- (push `(,arg . (car-safe ,arg)) new-env)
- (push `(,arg (list ,arg)) letbind)))
-
- (setq body-new (mapcar (lambda (form)
- (cconv-convert form new-env nil))
- body))
-
- (when letbind
- (let ((special-forms '()))
- ;; Keep special forms at the beginning of the body.
- (while (or (stringp (car body-new)) ;docstring.
- (memq (car-safe (car body-new)) '(interactive declare)))
- (push (pop body-new) special-forms))
- (setq body-new
- `(,@(nreverse special-forms) (let ,letbind . ,body-new)))))
-
+ (setq body-new (cconv--convert-funcbody
+ args body new-env parentform))
(cond
((not (or envector docstring)) ;If no freevars - do nothing.
`(function (lambda ,args . ,body-new)))
@@ -279,6 +261,30 @@ Returns a form where all lambdas don't have any free variables."
(nthcdr 3 mapping)))))
new-env))
+(defun cconv--convert-funcbody (funargs funcbody env parentform)
+ "Run `cconv-convert' on FUNCBODY, the forms of a lambda expression.
+PARENTFORM is the form containing the lambda expression. ENV is a
+lexical environment (same format as for `cconv-convert'), not
+including FUNARGS, the function's argument list. Return a list
+of converted forms."
+ (let ((letbind ()))
+ (dolist (arg funargs)
+ (if (not (member (cons (list arg) parentform) cconv-captured+mutated))
+ (if (assq arg env) (push `(,arg . nil) env))
+ (push `(,arg . (car-safe ,arg)) env)
+ (push `(,arg (list ,arg)) letbind)))
+ (setq funcbody (mapcar (lambda (form)
+ (cconv-convert form env nil))
+ funcbody))
+ (if letbind
+ (let ((special-forms '()))
+ ;; Keep special forms at the beginning of the body.
+ (while (or (stringp (car funcbody)) ;docstring.
+ (memq (car-safe (car funcbody)) '(interactive declare)))
+ (push (pop funcbody) special-forms))
+ `(,@(nreverse special-forms) (let ,letbind . ,funcbody)))
+ funcbody)))
+
(defun cconv-convert (form env extend)
;; This function actually rewrites the tree.
"Return FORM with all its lambdas changed so they are closed.
@@ -292,6 +298,9 @@ ENV is a list where each entry takes the shape either:
environment's Nth slot.
(VAR . (apply-partially F ARG1 ARG2 ..)): VAR has been λ-lifted and takes
additional arguments ARGs.
+ (VAR . nil): VAR is accessed normally. This is the same as VAR
+ being absent from ENV, but an explicit nil entry is useful
+ for shadowing VAR for a specific scope.
EXTEND is a list of variables which might need to be accessed even from places
where they are shadowed, because some part of ENV causes them to be used at
places where they originally did not directly appear."
@@ -313,7 +322,7 @@ places where they originally did not directly appear."
;; so we never touch it(unless we enter to the other closure).
;;(if (listp form) (print (car form)) form)
(pcase form
- (`(,(and letsym (or `let* `let)) ,binders . ,body)
+ (`(,(and letsym (or 'let* 'let)) ,binders . ,body)
; let and let* special forms
(let ((binders-new '())
@@ -360,10 +369,8 @@ places where they originally did not directly appear."
(not (memq fv funargs)))
(push `(,fv . (car-safe ,fv)) funcbody-env)))
`(function (lambda ,funcvars .
- ,(mapcar (lambda (form)
- (cconv-convert
- form funcbody-env nil))
- funcbody)))))
+ ,(cconv--convert-funcbody
+ funargs funcbody funcbody-env value)))))
;; Check if it needs to be turned into a "ref-cell".
((member (cons binder form) cconv-captured+mutated)
@@ -447,10 +454,13 @@ places where they originally did not directly appear."
(`(function . ,_) form)
;defconst, defvar
- (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,forms)
+ (`(,(and sym (or 'defconst 'defvar)) ,definedsymbol . ,forms)
`(,sym ,definedsymbol
- . ,(mapcar (lambda (form) (cconv-convert form env extend))
- forms)))
+ . ,(when (consp forms)
+ (cons (cconv-convert (car forms) env extend)
+ ;; The rest (i.e. docstring, of any) is not evaluated,
+ ;; and may be an invalid expression (e.g. ($# . 678)).
+ (cdr forms)))))
;condition-case
((and `(condition-case ,var ,protected-form . ,handlers)
@@ -486,8 +496,8 @@ places where they originally did not directly appear."
`((let ((,var (list ,var))) ,@body))))))
handlers))))
- (`(,(and head (or (and `catch (guard byte-compile--use-old-handlers))
- `unwind-protect))
+ (`(,(and head (or (and 'catch (guard byte-compile--use-old-handlers))
+ 'unwind-protect))
,form . ,body)
`(,head ,(cconv-convert form env extend)
:fun-body ,(cconv--convert-function () body env form)))
@@ -516,7 +526,7 @@ places where they originally did not directly appear."
`(progn . ,(nreverse prognlist))
(car prognlist)))))
- (`(,(and (or `funcall `apply) callsym) ,fun . ,args)
+ (`(,(and (or 'funcall 'apply) callsym) ,fun . ,args)
;; These are not special forms but we treat them separately for the needs
;; of lambda lifting.
(let ((mapping (cdr (assq fun env))))
@@ -546,7 +556,7 @@ places where they originally did not directly appear."
(`(,func . ,forms)
;; First element is function or whatever function-like forms are: or, and,
- ;; if, catch, progn, prog1, prog2, while, until
+ ;; if, catch, progn, prog1, while, until
`(,func . ,(mapcar (lambda (form)
(cconv-convert form env extend))
forms)))
@@ -645,7 +655,7 @@ This function does not return anything but instead fills the
and updates the data stored in ENV."
(pcase form
; let special form
- (`(,(and (or `let* `let) letsym) ,binders . ,body-forms)
+ (`(,(and (or 'let* 'let) letsym) ,binders . ,body-forms)
(let ((orig-env env)
(newvars nil)
@@ -729,18 +739,18 @@ and updates the data stored in ENV."
form "variable"))))
;; FIXME: The bytecode for unwind-protect forces us to wrap the unwind.
- (`(,(or (and `catch (guard byte-compile--use-old-handlers))
- `unwind-protect)
+ (`(,(or (and 'catch (guard byte-compile--use-old-handlers))
+ 'unwind-protect)
,form . ,body)
(cconv-analyze-form form env)
(cconv--analyze-function () body env form))
(`(defvar ,var) (push var byte-compile-bound-variables))
- (`(,(or `defconst `defvar) ,var ,value . ,_)
+ (`(,(or 'defconst 'defvar) ,var ,value . ,_)
(push var byte-compile-bound-variables)
(cconv-analyze-form value env))
- (`(,(or `funcall `apply) ,fun . ,args)
+ (`(,(or 'funcall 'apply) ,fun . ,args)
;; Here we ignore fun because funcall and apply are the only two
;; functions where we can pass a candidate for lambda lifting as
;; argument. So, if we see fun elsewhere, we'll delete it from
diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el
index 708f41237b5..9c29297da02 100644
--- a/lisp/emacs-lisp/chart.el
+++ b/lisp/emacs-lisp/chart.el
@@ -704,7 +704,7 @@ SORT-PRED if desired."
(cntlst nil))
(save-excursion
(goto-char (point-min))
- (while (re-search-forward "\\-[A-Z][a-z][a-z] +\\(\\w+\\)@\\w+" nil t)
+ (while (re-search-forward "-[A-Z][a-z][a-z] +\\(\\w+\\)@\\w+" nil t)
(let* ((nam (buffer-substring (match-beginning 1) (match-end 1)))
(m (member nam nmlst)))
(message "Scanned username %s" nam)
diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el
index 72fb47ba679..fa6f85c588d 100644
--- a/lisp/emacs-lisp/checkdoc.el
+++ b/lisp/emacs-lisp/checkdoc.el
@@ -171,8 +171,10 @@
(defvar checkdoc-version "0.6.1"
"Release version of checkdoc you are currently running.")
+(require 'cl-lib)
(require 'help-mode) ;; for help-xref-info-regexp
(require 'thingatpt) ;; for handy thing-at-point-looking-at
+(require 'lisp-mnt)
(defvar compilation-error-regexp-alist)
(defvar compilation-mode-font-lock-keywords)
@@ -436,23 +438,6 @@ be re-created.")
st)
"Syntax table used by checkdoc in document strings.")
-;;; Compatibility
-;;
-(defalias 'checkdoc-make-overlay
- (if (featurep 'xemacs) #'make-extent #'make-overlay))
-(defalias 'checkdoc-overlay-put
- (if (featurep 'xemacs) #'set-extent-property #'overlay-put))
-(defalias 'checkdoc-delete-overlay
- (if (featurep 'xemacs) #'delete-extent #'delete-overlay))
-(defalias 'checkdoc-overlay-start
- (if (featurep 'xemacs) #'extent-start #'overlay-start))
-(defalias 'checkdoc-overlay-end
- (if (featurep 'xemacs) #'extent-end #'overlay-end))
-(defalias 'checkdoc-mode-line-update
- (if (featurep 'xemacs) #'redraw-modeline #'force-mode-line-update))
-(defalias 'checkdoc-char=
- (if (featurep 'xemacs) #'char= #'=))
-
;;; User level commands
;;
;;;###autoload
@@ -475,32 +460,31 @@ the users will view as each check is completed."
tmp)
(checkdoc-display-status-buffer status)
;; check the comments
- (if (not buffer-file-name)
- (setcar status "Not checked")
- (if (checkdoc-file-comments-engine)
- (setcar status "Errors")
- (setcar status "Ok")))
- (setcar (cdr status) "Checking...")
+ (setf (nth 0 status)
+ (cond
+ ((not buffer-file-name) "Not checked")
+ ((checkdoc-file-comments-engine) "Errors")
+ (t "Ok")))
+ (setf (nth 1 status) "Checking...")
(checkdoc-display-status-buffer status)
;; Check the documentation
(setq tmp (checkdoc-interactive nil t))
- (if tmp
- (setcar (cdr status) (format "%d Errors" (length tmp)))
- (setcar (cdr status) "Ok"))
- (setcar (cdr (cdr status)) "Checking...")
+ (setf (nth 1 status)
+ (if tmp (format "%d Errors" (length tmp)) "Ok"))
+ (setf (nth 2 status) "Checking...")
(checkdoc-display-status-buffer status)
;; Check the message text
- (if (setq tmp (checkdoc-message-interactive nil t))
- (setcar (cdr (cdr status)) (format "%d Errors" (length tmp)))
- (setcar (cdr (cdr status)) "Ok"))
- (setcar (cdr (cdr (cdr status))) "Checking...")
+ (setf (nth 2 status)
+ (if (setq tmp (checkdoc-message-interactive nil t))
+ (format "%d Errors" (length tmp))
+ "Ok"))
+ (setf (nth 3 status) "Checking...")
(checkdoc-display-status-buffer status)
;; Rogue spacing
- (if (condition-case nil
- (checkdoc-rogue-spaces nil t)
- (error t))
- (setcar (cdr (cdr (cdr status))) "Errors")
- (setcar (cdr (cdr (cdr status))) "Ok"))
+ (setf (nth 3 status)
+ (if (ignore-errors (checkdoc-rogue-spaces nil t))
+ "Errors"
+ "Ok"))
(checkdoc-display-status-buffer status)))
(defun checkdoc-display-status-buffer (check)
@@ -592,16 +576,16 @@ style."
(while err-list
(goto-char (cdr (car err-list)))
;; The cursor should be just in front of the offending doc string
- (if (stringp (car (car err-list)))
- (setq cdo (save-excursion (checkdoc-make-overlay
+ (setq cdo (if (stringp (car (car err-list)))
+ (save-excursion (make-overlay
(point) (progn (forward-sexp 1)
- (point)))))
- (setq cdo (checkdoc-make-overlay
+ (point))))
+ (make-overlay
(checkdoc-error-start (car (car err-list)))
(checkdoc-error-end (car (car err-list))))))
(unwind-protect
(progn
- (checkdoc-overlay-put cdo 'face 'highlight)
+ (overlay-put cdo 'face 'highlight)
;; Make sure the whole doc string is visible if possible.
(sit-for 0)
(if (and (= (following-char) ?\")
@@ -627,10 +611,10 @@ style."
(if (not (integerp c)) (setq c ??))
(cond
;; Exit condition
- ((checkdoc-char= c ?\C-g) (signal 'quit nil))
+ ((eq c ?\C-g) (signal 'quit nil))
;; Request an auto-fix
- ((or (checkdoc-char= c ?y) (checkdoc-char= c ?f))
- (checkdoc-delete-overlay cdo)
+ ((memq c '(?y ?f))
+ (delete-overlay cdo)
(setq cdo nil)
(goto-char (cdr (car err-list)))
;; `automatic-then-never' tells the autofix function
@@ -659,7 +643,7 @@ style."
"No Additional style errors. Continuing...")
(sit-for 2))))))
;; Move to the next error (if available)
- ((or (checkdoc-char= c ?n) (checkdoc-char= c ?\s))
+ ((memq c '(?n ?\s))
(let ((ne (funcall findfunc nil)))
(if (not ne)
(if showstatus
@@ -671,7 +655,7 @@ style."
(sit-for 2))
(setq err-list (cons ne err-list)))))
;; Go backwards in the list of errors
- ((or (checkdoc-char= c ?p) (checkdoc-char= c ?\C-?))
+ ((memq c '(?p ?\C-?))
(if (/= (length err-list) 1)
(progn
(setq err-list (cdr err-list))
@@ -680,10 +664,10 @@ style."
(message "No Previous Errors.")
(sit-for 2)))
;; Edit the buffer recursively.
- ((checkdoc-char= c ?e)
+ ((eq c ?e)
(checkdoc-recursive-edit
(checkdoc-error-text (car (car err-list))))
- (checkdoc-delete-overlay cdo)
+ (delete-overlay cdo)
(setq err-list (cdr err-list)) ;back up the error found.
(beginning-of-defun)
(let ((ne (funcall findfunc nil)))
@@ -695,7 +679,7 @@ style."
(sit-for 2))
(setq err-list (cons ne err-list)))))
;; Quit checkdoc
- ((checkdoc-char= c ?q)
+ ((eq c ?q)
(setq returnme err-list
err-list nil
begin (point)))
@@ -723,7 +707,7 @@ style."
"C-h - Toggle this help buffer.")))
(shrink-window-if-larger-than-buffer
(get-buffer-window "*Checkdoc Help*"))))))
- (if cdo (checkdoc-delete-overlay cdo)))))
+ (if cdo (delete-overlay cdo)))))
(goto-char begin)
(if (get-buffer "*Checkdoc Help*") (kill-buffer "*Checkdoc Help*"))
(message "Checkdoc: Done.")
@@ -1146,6 +1130,15 @@ Prefix argument is the same as for `checkdoc-defun'"
;; features and behaviors, so we need some ways of specifying
;; them, and making them easier to use in the wacked-out interfaces
;; people are requesting
+
+(cl-defstruct (checkdoc-error
+ (:constructor nil)
+ (:constructor checkdoc--create-error (text start end &optional unfixable)))
+ (text nil :read-only t)
+ (start nil :read-only t)
+ (end nil :read-only t)
+ (unfixable nil :read-only t))
+
(defvar checkdoc-create-error-function #'checkdoc--create-error-for-checkdoc
"Function called when Checkdoc encounters an error.
Should accept as arguments (TEXT START END &optional UNFIXABLE).
@@ -1154,7 +1147,7 @@ TEXT is the descriptive text of the error. START and END define the region
it is sensible to highlight when describing the problem.
Optional argument UNFIXABLE means that the error has no auto-fix available.
-A list of the form (TEXT START END UNFIXABLE) is returned if we are not
+An object of type `checkdoc-error' is returned if we are not
generating a buffered list of errors.")
(defun checkdoc-create-error (text start end &optional unfixable)
@@ -1170,27 +1163,7 @@ TEXT, START, END and UNFIXABLE conform to
(if checkdoc-generate-compile-warnings-flag
(progn (checkdoc-error start text)
nil)
- (list text start end unfixable)))
-
-(defun checkdoc-error-text (err)
- "Return the text specified in the checkdoc ERR."
- ;; string-p part is for backwards compatibility
- (if (stringp err) err (car err)))
-
-(defun checkdoc-error-start (err)
- "Return the start point specified in the checkdoc ERR."
- ;; string-p part is for backwards compatibility
- (if (stringp err) nil (nth 1 err)))
-
-(defun checkdoc-error-end (err)
- "Return the end point specified in the checkdoc ERR."
- ;; string-p part is for backwards compatibility
- (if (stringp err) nil (nth 2 err)))
-
-(defun checkdoc-error-unfixable (err)
- "Return the t if we cannot autofix the error specified in the checkdoc ERR."
- ;; string-p part is for backwards compatibility
- (if (stringp err) nil (nth 3 err)))
+ (checkdoc--create-error text start end unfixable)))
;;; Minor Mode specification
;;
@@ -1264,9 +1237,6 @@ TEXT, START, END and UNFIXABLE conform to
;;;###autoload
(define-minor-mode checkdoc-minor-mode
"Toggle automatic docstring checking (Checkdoc minor mode).
-With a prefix argument ARG, enable Checkdoc minor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
In Checkdoc minor mode, the usual bindings for `eval-defun' which is
bound to \\<checkdoc-minor-mode-map>\\[checkdoc-eval-defun] and `checkdoc-eval-current-buffer' are overridden to include
@@ -1341,7 +1311,7 @@ See the style guide in the Emacs Lisp manual for more details."
(if (and (not (nth 1 fp)) ; not a variable
(or (nth 2 fp) ; is interactive
checkdoc-force-docstrings-flag) ;or we always complain
- (not (checkdoc-char= (following-char) ?\"))) ; no doc string
+ (not (eq (following-char) ?\"))) ; no doc string
;; Sometimes old code has comments where the documentation should
;; be. Let's see if we can find the comment, and offer to turn it
;; into documentation for them.
@@ -1470,9 +1440,9 @@ regexp short cuts work. FP is the function defun information."
(if (> (point) e) (goto-char e)) ;of the form (defun n () "doc" nil)
(forward-char -1)
(cond
- ((and (checkdoc-char= (following-char) ?\")
+ ((and (eq (following-char) ?\")
;; A backslashed double quote at the end of a sentence
- (not (checkdoc-char= (preceding-char) ?\\)))
+ (not (eq (preceding-char) ?\\)))
;; We might have to add a period in this case
(forward-char -1)
(if (looking-at "[.!?]")
@@ -1541,7 +1511,7 @@ may require more formatting")
(line-end-position))))))))
;; Continuation of above. Make sure our sentence is capitalized.
(save-excursion
- (skip-chars-forward "\"\\*")
+ (skip-chars-forward "\"*")
(if (looking-at "[a-z]")
(if (checkdoc-autofix-ask-replace
(match-beginning 0) (match-end 0)
@@ -1795,7 +1765,7 @@ function,command,variable,option or symbol." ms1))))))
(let ((lim (save-excursion
(end-of-line)
;; check string-continuation
- (if (checkdoc-char= (preceding-char) ?\\)
+ (if (eq (preceding-char) ?\\)
(line-end-position 2)
(point))))
(rs nil) replace original (case-fold-search t))
@@ -2236,21 +2206,10 @@ News agents may remove it"
;;
(defvar generate-autoload-cookie)
-(eval-when-compile (require 'lisp-mnt)) ; expand silly defsubsts
-(declare-function lm-summary "lisp-mnt" (&optional file))
-(declare-function lm-section-start "lisp-mnt" (header &optional after))
-(declare-function lm-section-end "lisp-mnt" (header))
-
(defun checkdoc-file-comments-engine ()
"Return a message list if this file does not match the Emacs standard.
This checks for style only, such as the first line, Commentary:,
Code:, and others referenced in the style guide."
- (if (featurep 'lisp-mnt)
- nil
- (require 'lisp-mnt)
- ;; Old XEmacs don't have `lm-commentary-mark'
- (if (and (not (fboundp 'lm-commentary-mark)) (fboundp 'lm-commentary))
- (defalias 'lm-commentary-mark #'lm-commentary)))
(save-excursion
(let* ((f1 (file-name-nondirectory (buffer-file-name)))
(fn (file-name-sans-extension f1))
@@ -2311,7 +2270,7 @@ Code:, and others referenced in the style guide."
(if (or (not checkdoc-force-history-flag)
(file-exists-p "ChangeLog")
(file-exists-p "../ChangeLog")
- (and (fboundp 'lm-history-mark) (funcall #'lm-history-mark)))
+ (lm-history-mark))
nil
(progn
(goto-char (or (lm-commentary-mark) (point-min)))
@@ -2592,12 +2551,12 @@ This function returns non-nil if the text was replaced.
This function will not modify `match-data'."
(if (and checkdoc-autofix-flag
(not (eq checkdoc-autofix-flag 'never)))
- (let ((o (checkdoc-make-overlay start end))
+ (let ((o (make-overlay start end))
(ret nil)
(md (match-data)))
(unwind-protect
(progn
- (checkdoc-overlay-put o 'face 'highlight)
+ (overlay-put o 'face 'highlight)
(if (or (eq checkdoc-autofix-flag 'automatic)
(eq checkdoc-autofix-flag 'automatic-then-never)
(and (eq checkdoc-autofix-flag 'semiautomatic)
@@ -2614,9 +2573,9 @@ This function will not modify `match-data'."
(insert replacewith)
(if checkdoc-bouncy-flag (sit-for 0))
(setq ret t)))
- (checkdoc-delete-overlay o)
+ (delete-overlay o)
(set-match-data md))
- (checkdoc-delete-overlay o)
+ (delete-overlay o)
(set-match-data md))
(if (eq checkdoc-autofix-flag 'automatic-then-never)
(setq checkdoc-autofix-flag 'never))
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index b0f9cfdcfa0..a2400a0ba37 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -438,9 +438,7 @@ as an integer unless JUNK-ALLOWED is non-nil."
;; Random numbers.
(defun cl--random-time ()
- (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0))
- (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i))))
- v))
+ (car (encode-time nil t)))
;;;###autoload (autoload 'cl-random-state-p "cl-extra")
(cl-defstruct (cl--random-state
@@ -472,7 +470,7 @@ Optional second arg STATE is a random-state object."
(n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j))))))
(if (integerp lim)
(if (<= lim 512) (% n lim)
- (if (> lim 8388607) (setq n (+ (lsh n 9) (cl-random 512 state))))
+ (if (> lim 8388607) (setq n (+ (ash n 9) (cl-random 512 state))))
(let ((mask 1023))
(while (< mask (1- lim)) (setq mask (1+ (+ mask mask))))
(if (< (setq n (logand n mask)) lim) n (cl-random lim state))))
@@ -576,9 +574,9 @@ too large if positive or too small if negative)."
"Concatenate, into a sequence of type TYPE, the argument SEQUENCEs.
\n(fn TYPE SEQUENCE...)"
(pcase type
- (`vector (apply #'vconcat sequences))
- (`string (apply #'concat sequences))
- (`list (apply #'append (append sequences '(nil))))
+ ('vector (apply #'vconcat sequences))
+ ('string (apply #'concat sequences))
+ ('list (apply #'append (append sequences '(nil))))
(_ (error "Not a sequence type name: %S" type))))
;;; List functions.
@@ -596,10 +594,10 @@ too large if positive or too small if negative)."
;;;###autoload
(defun cl-list-length (x)
"Return the length of list X. Return nil if list is circular."
- (let ((n 0) (fast x) (slow x))
- (while (and (cdr fast) (not (and (eq fast slow) (> n 0))))
- (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow)))
- (if fast (if (cdr fast) nil (1+ n)) n)))
+ (cl-check-type x list)
+ (condition-case nil
+ (length x)
+ (circular-list)))
;;;###autoload
(defun cl-tailp (sublist list)
@@ -742,7 +740,7 @@ including `cl-block' and `cl-eval-when'."
(with-eval-after-load 'find-func
(defvar find-function-regexp-alist)
(add-to-list 'find-function-regexp-alist
- `(define-type . cl--typedef-regexp)))
+ '(define-type . cl--typedef-regexp)))
(define-button-type 'cl-help-type
:supertype 'help-function-def
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 3cdfba3f723..f104d80b032 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -345,6 +345,9 @@ the specializer used will be the one returned by BODY."
. ,(lambda () spec-args))
macroexpand-all-environment)))
(require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'.
+ (when (interactive-form (cadr fun))
+ (message "Interactive forms unsupported in generic functions: %S"
+ (interactive-form (cadr fun))))
;; First macroexpand away the cl-function stuff (e.g. &key and
;; destructuring args, `declare' and whatnot).
(pcase (macroexpand fun macroenv)
@@ -808,22 +811,26 @@ methods.")
;; able to preload cl-generic without also preloading the byte-compiler,
;; So we use `eval-when-compile' so as not keep it available longer than
;; strictly needed.
-(defmacro cl--generic-prefill-dispatchers (arg-or-context specializer)
+(defmacro cl--generic-prefill-dispatchers (arg-or-context &rest specializers)
(unless (integerp arg-or-context)
(setq arg-or-context `(&context . ,arg-or-context)))
(unless (fboundp 'cl--generic-get-dispatcher)
(require 'cl-generic))
(let ((fun (cl--generic-get-dispatcher
- `(,arg-or-context ,@(cl-generic-generalizers specializer)
- ,cl--generic-t-generalizer))))
+ `(,arg-or-context
+ ,@(apply #'append
+ (mapcar #'cl-generic-generalizers specializers))
+ ,cl--generic-t-generalizer))))
;; Recompute dispatch at run-time, since the generalizers may be slightly
;; different (e.g. byte-compiled rather than interpreted).
;; FIXME: There is a risk that the run-time generalizer is not equivalent
;; to the compile-time one, in which case `fun' may not be correct
;; any more!
- `(let ((dispatch `(,',arg-or-context
- ,@(cl-generic-generalizers ',specializer)
- ,cl--generic-t-generalizer)))
+ `(let ((dispatch
+ `(,',arg-or-context
+ ,@(apply #'append
+ (mapcar #'cl-generic-generalizers ',specializers))
+ ,cl--generic-t-generalizer)))
;; (message "Prefilling for %S with \n%S" dispatch ',fun)
(puthash dispatch ',fun cl--generic-dispatchers)))))
@@ -931,7 +938,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'."
(add-to-list 'find-function-regexp-alist
`(cl-defmethod . ,#'cl--generic-search-method))
(add-to-list 'find-function-regexp-alist
- `(cl-defgeneric . cl--generic-find-defgeneric-regexp)))
+ '(cl-defgeneric . cl--generic-find-defgeneric-regexp)))
(defun cl--generic-method-info (method)
(let* ((specializers (cl--generic-method-specializers method))
@@ -1156,45 +1163,19 @@ These match if the argument is `eql' to VAL."
;;; Dispatch on "system types".
-(defconst cl--generic-typeof-types
- ;; Hand made from the source code of `type-of'.
- '((integer number number-or-marker atom)
- (symbol atom) (string array sequence atom)
- (cons list sequence)
- ;; Markers aren't `numberp', yet they are accepted wherever integers are
- ;; accepted, pretty much.
- (marker number-or-marker atom)
- (overlay atom) (float number atom) (window-configuration atom)
- (process atom) (window atom) (subr atom) (compiled-function function atom)
- (buffer atom) (char-table array sequence atom)
- (bool-vector array sequence atom)
- (frame atom) (hash-table atom) (terminal atom)
- (thread atom) (mutex atom) (condvar atom)
- (font-spec atom) (font-entity atom) (font-object atom)
- (vector array sequence atom)
- ;; Plus, really hand made:
- (null symbol list sequence atom))
- "Alist of supertypes.
-Each element has the form (TYPE . SUPERTYPES) where TYPE is one of
-the symbols returned by `type-of', and SUPERTYPES is the list of its
-supertypes from the most specific to least specific.")
-
-(defconst cl--generic-all-builtin-types
- (delete-dups (copy-sequence (apply #'append cl--generic-typeof-types))))
-
(cl-generic-define-generalizer cl--generic-typeof-generalizer
;; FIXME: We could also change `type-of' to return `null' for nil.
10 (lambda (name &rest _) `(if ,name (type-of ,name) 'null))
(lambda (tag &rest _)
- (and (symbolp tag) (assq tag cl--generic-typeof-types))))
+ (and (symbolp tag) (assq tag cl--typeof-types))))
(cl-defmethod cl-generic-generalizers :extra "typeof" (type)
"Support for dispatch on builtin types.
-See the full list and their hierarchy in `cl--generic-typeof-types'."
+See the full list and their hierarchy in `cl--typeof-types'."
;; FIXME: Add support for other types accepted by `cl-typep' such
;; as `character', `face', `function', ...
(or
- (and (memq type cl--generic-all-builtin-types)
+ (and (memq type cl--all-builtin-types)
(progn
;; FIXME: While this wrinkle in the semantics can be occasionally
;; problematic, this warning is more often annoying than helpful.
@@ -1205,6 +1186,7 @@ See the full list and their hierarchy in `cl--generic-typeof-types'."
(cl-call-next-method)))
(cl--generic-prefill-dispatchers 0 integer)
+(cl--generic-prefill-dispatchers 0 cl--generic-generalizer integer)
;;; Dispatch on major mode.
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index 0f5f3c78695..3a9280fae62 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -365,13 +365,6 @@ SEQ, this is like `mapcar'. With several, it is like the Common Lisp
(cl--defalias 'cl-second 'cadr)
(cl--defalias 'cl-rest 'cdr)
-(defun cl-endp (x)
- "Return true if X is the empty list; false if it is a cons.
-Signal an error if X is not a list."
- (if (listp x)
- (null x)
- (signal 'wrong-type-argument (list 'listp x 'x))))
-
(cl--defalias 'cl-third 'cl-caddr "Return the third element of the list X.")
(cl--defalias 'cl-fourth 'cl-cadddr "Return the fourth element of the list X.")
@@ -531,8 +524,9 @@ If ALIST is non-nil, the new pairs are prepended to it."
;; Some more Emacs-related place types.
(gv-define-simple-setter buffer-file-name set-visited-file-name t)
(gv-define-setter buffer-modified-p (flag &optional buf)
- `(with-current-buffer ,buf
- (set-buffer-modified-p ,flag)))
+ (macroexp-let2 nil buffer `(or ,buf (current-buffer))
+ `(with-current-buffer ,buffer
+ (set-buffer-modified-p ,flag))))
(gv-define-simple-setter buffer-name rename-buffer t)
(gv-define-setter buffer-string (store)
`(insert (prog1 ,store (erase-buffer))))
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index b594887ee72..16e9bd6a750 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -498,7 +498,7 @@ its argument list allows full Common Lisp conventions."
;; `&aux' args aren't arguments, so let's just drop them from the
;; usage info.
(setq arglist (cl-subseq arglist 0 aux))))
- (if (cdr-safe (last arglist)) ;Not a proper list.
+ (if (not (proper-list-p arglist))
(let* ((last (last arglist))
(tail (cdr last)))
(unwind-protect
@@ -555,7 +555,7 @@ its argument list allows full Common Lisp conventions."
(if (memq '&environment args) (error "&environment used incorrectly"))
(let ((restarg (memq '&rest args))
(safety (if (cl--compiling-file) cl--optimize-safety 3))
- (keys nil)
+ (keys t)
(laterarg nil) (exactarg nil) minarg)
(or num (setq num 0))
(setq restarg (if (listp (cadr restarg))
@@ -610,6 +610,7 @@ its argument list allows full Common Lisp conventions."
(+ ,num (length ,restarg)))))
cl--bind-forms)))
(while (and (eq (car args) '&key) (pop args))
+ (unless (listp keys) (setq keys nil))
(while (and args (not (memq (car args) cl--lambda-list-keywords)))
(let ((arg (pop args)))
(or (consp arg) (setq arg (list arg)))
@@ -648,23 +649,32 @@ its argument list allows full Common Lisp conventions."
`'(nil ,(cl--const-expr-val def))
`(list nil ,def))))))))
(push karg keys)))))
- (setq keys (nreverse keys))
+ (when (consp keys) (setq keys (nreverse keys)))
(or (and (eq (car args) '&allow-other-keys) (pop args))
- (null keys) (= safety 0)
- (let* ((var (make-symbol "--cl-keys--"))
- (allow '(:allow-other-keys))
- (check `(while ,var
- (cond
- ((memq (car ,var) ',(append keys allow))
- (setq ,var (cdr (cdr ,var))))
- ((car (cdr (memq (quote ,@allow) ,restarg)))
- (setq ,var nil))
- (t
- (error
- ,(format "Keyword argument %%s not one of %s"
- keys)
- (car ,var)))))))
- (push `(let ((,var ,restarg)) ,check) cl--bind-forms)))
+ (= safety 0)
+ (cond
+ ((eq keys t) nil) ;No &keys at all
+ ((null keys) ;A &key but no actual keys specified.
+ (push `(when ,restarg
+ (error ,(format "Keyword argument %%s not one of %s"
+ keys)
+ (car ,restarg)))
+ cl--bind-forms))
+ (t
+ (let* ((var (make-symbol "--cl-keys--"))
+ (allow '(:allow-other-keys))
+ (check `(while ,var
+ (cond
+ ((memq (car ,var) ',(append keys allow))
+ (setq ,var (cdr (cdr ,var))))
+ ((car (cdr (memq (quote ,@allow) ,restarg)))
+ (setq ,var nil))
+ (t
+ (error
+ ,(format "Keyword argument %%s not one of %s"
+ keys)
+ (car ,var)))))))
+ (push `(let ((,var ,restarg)) ,check) cl--bind-forms)))))
(cl--do-&aux args)
nil)))
@@ -884,7 +894,7 @@ This is compatible with Common Lisp, but note that `defun' and
(defvar cl--loop-name)
(defvar cl--loop-result) (defvar cl--loop-result-explicit)
(defvar cl--loop-result-var) (defvar cl--loop-steps)
-(defvar cl--loop-symbol-macs)
+(defvar cl--loop-symbol-macs) (defvar cl--loop-guard-cond)
(defun cl--loop-set-iterator-function (kind iterator)
(if cl--loop-iterator-function
@@ -953,7 +963,7 @@ For more details, see Info node `(cl)Loop Facility'.
(cl--loop-accum-var nil) (cl--loop-accum-vars nil)
(cl--loop-initially nil) (cl--loop-finally nil)
(cl--loop-iterator-function nil) (cl--loop-first-flag nil)
- (cl--loop-symbol-macs nil))
+ (cl--loop-symbol-macs nil) (cl--loop-guard-cond nil))
;; Here is more or less how those dynbind vars are used after looping
;; over cl--parse-loop-clause:
;;
@@ -988,7 +998,24 @@ For more details, see Info node `(cl)Loop Facility'.
(list (or cl--loop-result-explicit
cl--loop-result))))
(ands (cl--loop-build-ands (nreverse cl--loop-body)))
- (while-body (nconc (cadr ands) (nreverse cl--loop-steps)))
+ (while-body
+ (nconc
+ (cadr ands)
+ (if (or (not cl--loop-guard-cond) (not cl--loop-first-flag))
+ (nreverse cl--loop-steps)
+ ;; Right after update the loop variable ensure that the loop
+ ;; condition, i.e. (car ands), is still satisfied; otherwise,
+ ;; set `cl--loop-first-flag' nil and skip the remaining
+ ;; body forms (#Bug#29799).
+ ;;
+ ;; (last cl--loop-steps) updates the loop var
+ ;; (car (butlast cl--loop-steps)) sets `cl--loop-first-flag' nil
+ ;; (nreverse (cdr (butlast cl--loop-steps))) are the
+ ;; remaining body forms.
+ (append (last cl--loop-steps)
+ `((and ,(car ands)
+ ,@(nreverse (cdr (butlast cl--loop-steps)))))
+ `(,(car (butlast cl--loop-steps)))))))
(body (append
(nreverse cl--loop-initially)
(list (if cl--loop-iterator-function
@@ -1309,11 +1336,13 @@ For more details, see Info node `(cl)Loop Facility'.
((memq word '(across across-ref))
(let ((temp-vec (make-symbol "--cl-vec--"))
+ (temp-len (make-symbol "--cl-len--"))
(temp-idx (make-symbol "--cl-idx--")))
(push (list temp-vec (pop cl--loop-args)) loop-for-bindings)
+ (push (list temp-len `(length ,temp-vec)) loop-for-bindings)
(push (list temp-idx -1) loop-for-bindings)
(push `(< (setq ,temp-idx (1+ ,temp-idx))
- (length ,temp-vec))
+ ,temp-len)
cl--loop-body)
(if (eq word 'across-ref)
(push (list var `(aref ,temp-vec ,temp-idx))
@@ -1328,6 +1357,7 @@ For more details, see Info node `(cl)Loop Facility'.
(error "Expected `of'"))))
(seq (cl--pop2 cl--loop-args))
(temp-seq (make-symbol "--cl-seq--"))
+ (temp-len (make-symbol "--cl-len--"))
(temp-idx
(if (eq (car cl--loop-args) 'using)
(if (and (= (length (cadr cl--loop-args)) 2)
@@ -1338,16 +1368,19 @@ For more details, see Info node `(cl)Loop Facility'.
(push (list temp-seq seq) loop-for-bindings)
(push (list temp-idx 0) loop-for-bindings)
(if ref
- (let ((temp-len (make-symbol "--cl-len--")))
+ (progn
(push (list temp-len `(length ,temp-seq))
loop-for-bindings)
(push (list var `(elt ,temp-seq ,temp-idx))
cl--loop-symbol-macs)
(push `(< ,temp-idx ,temp-len) cl--loop-body))
+ ;; Evaluate seq length just if needed, that is, when seq is not a cons.
+ (push (list temp-len (or (consp seq) `(length ,temp-seq)))
+ loop-for-bindings)
(push (list var nil) loop-for-bindings)
(push `(and ,temp-seq
(or (consp ,temp-seq)
- (< ,temp-idx (length ,temp-seq))))
+ (< ,temp-idx ,temp-len)))
cl--loop-body)
(push (list var `(if (consp ,temp-seq)
(pop ,temp-seq)
@@ -1492,10 +1525,11 @@ For more details, see Info node `(cl)Loop Facility'.
,(cl--loop-let (nreverse loop-for-sets) 'setq ands)
t)
cl--loop-body))
- (if loop-for-steps
- (push (cons (if ands 'cl-psetq 'setq)
- (apply 'append (nreverse loop-for-steps)))
- cl--loop-steps))))
+ (when loop-for-steps
+ (setq cl--loop-guard-cond t)
+ (push (cons (if ands 'cl-psetq 'setq)
+ (apply 'append (nreverse loop-for-steps)))
+ cl--loop-steps))))
((eq word 'repeat)
(let ((temp (make-symbol "--cl-var--")))
@@ -1868,7 +1902,7 @@ Labels have lexical scope and dynamic extent."
(push (nreverse block) blocks)
(setq block (list label-or-stmt))))
(unless (eq 'go (car-safe (car-safe block)))
- (push `(go cl--exit) block))
+ (push '(go cl--exit) block))
(push (nreverse block) blocks))
(let ((catch-tag (make-symbol "cl--tagbody-tag"))
(cl--tagbody-alist cl--tagbody-alist))
@@ -2084,10 +2118,7 @@ This is like `cl-flet', but for macros instead of functions.
\(fn ((NAME ARGLIST BODY...) ...) FORM...)"
(declare (indent 1)
- (debug
- ((&rest (&define name (&rest arg) cl-declarations-or-string
- def-body))
- cl-declarations body)))
+ (debug (cl-macrolet-expr)))
(if (cdr bindings)
`(cl-macrolet (,(car bindings)) (cl-macrolet ,(cdr bindings) ,@body))
(if (null bindings) (macroexp-progn body)
@@ -2099,23 +2130,15 @@ This is like `cl-flet', but for macros instead of functions.
(eval `(cl-function (lambda ,@(cdr res))) t))
macroexpand-all-environment))))))
-(defconst cl--old-macroexpand
- (if (and (boundp 'cl--old-macroexpand)
- (eq (symbol-function 'macroexpand)
- #'cl--sm-macroexpand))
- cl--old-macroexpand
- (symbol-function 'macroexpand)))
-
-(defun cl--sm-macroexpand (exp &optional env)
- "Special macro expander used inside `cl-symbol-macrolet'.
-This function replaces `macroexpand' during macro expansion
-of `cl-symbol-macrolet', and does the same thing as `macroexpand'
-except that it additionally expands symbol macros."
+(defun cl--sm-macroexpand (orig-fun exp &optional env)
+ "Special macro expander advice used inside `cl-symbol-macrolet'.
+This function extends `macroexpand' during macro expansion
+of `cl-symbol-macrolet' to additionally expand symbol macros."
(let ((macroexpand-all-environment env)
(venv (alist-get :cl-symbol-macros env)))
(while
(progn
- (setq exp (funcall cl--old-macroexpand exp env))
+ (setq exp (funcall orig-fun exp env))
(pcase exp
((pred symbolp)
;; Perform symbol-macro expansion.
@@ -2124,7 +2147,7 @@ except that it additionally expands symbol macros."
(setq exp (cadr symval)))))
(`(setq . ,_)
;; Convert setq to setf if required by symbol-macro expansion.
- (let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f env))
+ (let* ((args (mapcar (lambda (f) (macroexpand f env))
(cdr exp)))
(p args))
(while (and p (symbolp (car p))) (setq p (cddr p)))
@@ -2132,60 +2155,102 @@ except that it additionally expands symbol macros."
(setq exp (cons 'setq args))
;; Don't loop further.
nil)))
- (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare))
- ;; CL's symbol-macrolet treats re-bindings as candidates for
- ;; expansion (turning the let into a letf if needed), contrary to
- ;; Common-Lisp where such re-bindings hide the symbol-macro.
- (let ((letf nil) (found nil) (nbs ()))
- (dolist (binding bindings)
- (let* ((var (if (symbolp binding) binding (car binding)))
- (sm (assq var venv)))
- (push (if (not (cdr sm))
- binding
- (let ((nexp (cadr sm)))
- (setq found t)
- (unless (symbolp nexp) (setq letf t))
- (cons nexp (cdr-safe binding))))
- nbs)))
- (when found
- (setq exp `(,(if letf
- (if (eq (car exp) 'let) 'cl-letf 'cl-letf*)
- (car exp))
- ,(nreverse nbs)
- ,@body)))))
- ;; FIXME: The behavior of CL made sense in a dynamically scoped
- ;; language, but for lexical scoping, Common-Lisp's behavior might
- ;; make more sense (and indeed, CL behaves like Common-Lisp w.r.t
- ;; lexical-let), so maybe we should adjust the behavior based on
- ;; the use of lexical-binding.
+ ;; CL's symbol-macrolet used to treat re-bindings as candidates for
+ ;; expansion (turning the let into a letf if needed), contrary to
+ ;; Common-Lisp where such re-bindings hide the symbol-macro.
+ ;; Not sure if there actually is code out there which depends
+ ;; on this behavior (haven't found any yet).
+ ;; Such code should explicitly use `cl-letf' instead, I think.
+ ;;
;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare))
- ;; (let ((nbs ()) (found nil))
+ ;; (let ((letf nil) (found nil) (nbs ()))
;; (dolist (binding bindings)
;; (let* ((var (if (symbolp binding) binding (car binding)))
- ;; (name (symbol-name var))
- ;; (val (and found (consp binding) (eq 'let* (car exp))
- ;; (list (macroexpand-all (cadr binding)
- ;; env)))))
- ;; (push (if (assq name env)
- ;; ;; This binding should hide its symbol-macro,
- ;; ;; but given the way macroexpand-all works, we
- ;; ;; can't prevent application of `env' to the
- ;; ;; sub-expressions, so we need to α-rename this
- ;; ;; variable instead.
- ;; (let ((nvar (make-symbol
- ;; (copy-sequence name))))
- ;; (setq found t)
- ;; (push (list name nvar) env)
- ;; (cons nvar (or val (cdr-safe binding))))
- ;; (if val (cons var val) binding))
+ ;; (sm (assq var venv)))
+ ;; (push (if (not (cdr sm))
+ ;; binding
+ ;; (let ((nexp (cadr sm)))
+ ;; (setq found t)
+ ;; (unless (symbolp nexp) (setq letf t))
+ ;; (cons nexp (cdr-safe binding))))
;; nbs)))
;; (when found
- ;; (setq exp `(,(car exp)
+ ;; (setq exp `(,(if letf
+ ;; (if (eq (car exp) 'let) 'cl-letf 'cl-letf*)
+ ;; (car exp))
;; ,(nreverse nbs)
- ;; ,@(macroexp-unprogn
- ;; (macroexpand-all (macroexp-progn body)
- ;; env)))))
- ;; nil))
+ ;; ,@body)))))
+ ;;
+ ;; We implement the Common-Lisp behavior, instead (see bug#26073):
+ ;; The behavior of CL made sense in a dynamically scoped
+ ;; language, but nowadays, lexical scoping semantics is more often
+ ;; expected.
+ (`(,(or 'let 'let*) . ,(or `(,bindings . ,body) dontcare))
+ (let ((nbs ()) (found nil))
+ (dolist (binding bindings)
+ (let* ((var (if (symbolp binding) binding (car binding)))
+ (val (and found (consp binding) (eq 'let* (car exp))
+ (list (macroexpand-all (cadr binding)
+ env)))))
+ (push (if (assq var venv)
+ ;; This binding should hide "its" surrounding
+ ;; symbol-macro, but given the way macroexpand-all
+ ;; works (i.e. the `env' we receive as input will
+ ;; be (re)applied to the code we return), we can't
+ ;; prevent application of `env' to the
+ ;; sub-expressions, so we need to α-rename this
+ ;; variable instead.
+ (let ((nvar (make-symbol (symbol-name var))))
+ (setq found t)
+ (push (list var nvar) venv)
+ (push (cons :cl-symbol-macros venv) env)
+ (cons nvar (or val (cdr-safe binding))))
+ (if val (cons var val) binding))
+ nbs)))
+ (when found
+ (setq exp `(,(car exp)
+ ,(nreverse nbs)
+ ,@(macroexp-unprogn
+ (macroexpand-all (macroexp-progn body)
+ env)))))
+ nil))
+ ;; Do the same as for `let' but for variables introduced
+ ;; via other means, such as `lambda' and `condition-case'.
+ (`(function (lambda ,args . ,body))
+ (let ((nargs ()) (found nil))
+ (dolist (var args)
+ (push (cond
+ ((memq var '(&optional &rest)) var)
+ ((assq var venv)
+ (let ((nvar (make-symbol (symbol-name var))))
+ (setq found t)
+ (push (list var nvar) venv)
+ (push (cons :cl-symbol-macros venv) env)
+ nvar))
+ (t var))
+ nargs))
+ (when found
+ (setq exp `(function
+ (lambda ,(nreverse nargs)
+ . ,(mapcar (lambda (exp)
+ (macroexpand-all exp env))
+ body)))))
+ nil))
+ ((and `(condition-case ,var ,exp . ,clauses)
+ (guard (assq var venv)))
+ (let ((nvar (make-symbol (symbol-name var))))
+ (push (list var nvar) venv)
+ (push (cons :cl-symbol-macros venv) env)
+ (setq exp
+ `(condition-case ,nvar ,(macroexpand-all exp env)
+ . ,(mapcar
+ (lambda (clause)
+ `(,(car clause)
+ . ,(mapcar (lambda (exp)
+ (macroexpand-all exp env))
+ (cdr clause))))
+ clauses)))
+ nil))
)))
exp))
@@ -2197,16 +2262,18 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
\(fn ((NAME EXPANSION) ...) FORM...)"
(declare (indent 1) (debug ((&rest (symbolp sexp)) cl-declarations body)))
- (let ((previous-macroexpand (symbol-function 'macroexpand))
- (malformed-bindings nil))
+ (let ((malformed-bindings nil)
+ (advised (advice-member-p #'cl--sm-macroexpand 'macroexpand)))
(dolist (binding bindings)
(unless (and (consp binding) (symbolp (car binding))
(consp (cdr binding)) (null (cddr binding)))
(push binding malformed-bindings)))
(unwind-protect
(progn
- (fset 'macroexpand #'cl--sm-macroexpand)
- (let* ((venv (cdr (assq :cl-symbol-macros macroexpand-all-environment)))
+ (unless advised
+ (advice-add 'macroexpand :around #'cl--sm-macroexpand))
+ (let* ((venv (cdr (assq :cl-symbol-macros
+ macroexpand-all-environment)))
(expansion
(macroexpand-all (macroexp-progn body)
(cons (cons :cl-symbol-macros
@@ -2218,7 +2285,8 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
(nreverse malformed-bindings))
expansion)
expansion)))
- (fset 'macroexpand previous-macroexpand))))
+ (unless advised
+ (advice-remove 'macroexpand #'cl--sm-macroexpand)))))
;;; Multiple values.
@@ -2469,10 +2537,11 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
(pcase-let ((`(,vold ,_getter ,setter ,_vnew) x))
(funcall setter vold)))
binds))))
- (let ((binding (car bindings)))
- (gv-letplace (getter setter) (car binding)
+ (let* ((binding (car bindings))
+ (place (macroexpand (car binding) macroexpand-all-environment)))
+ (gv-letplace (getter setter) place
(macroexp-let2 nil vnew (cadr binding)
- (if (symbolp (car binding))
+ (if (symbolp place)
;; Special-case for simple variables.
(cl--letf (cdr bindings)
(cons `(,getter ,(if (cdr binding) vnew getter))
@@ -2499,7 +2568,9 @@ the PLACE is not modified before executing BODY.
(declare (indent 1) (debug ((&rest [&or (symbolp form)
(gate gv-place &optional form)])
body)))
- (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings)))
+ (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings))
+ (not (assq (caar bindings)
+ (alist-get :cl-symbol-macros macroexpand-all-environment))))
`(let ,bindings ,@body)
(cl--letf bindings () () body)))
@@ -2616,6 +2687,9 @@ The function's arguments should be treated as immutable.
;; for bootstrapping reasons.
(defvar cl--struct-default-parent nil)
+(defvar cl--struct-inline t
+ "If non-nil, `cl-defstruct' will define inlinable functions.")
+
;;;###autoload
(defmacro cl-defstruct (struct &rest descs)
"Define a struct type.
@@ -2627,7 +2701,7 @@ You can use the accessors to set the corresponding slots, via `setf'.
NAME may instead take the form (NAME OPTIONS...), where each
OPTION is either a single keyword or (KEYWORD VALUE) where
KEYWORD can be one of :conc-name, :constructor, :copier, :predicate,
-:type, :named, :initial-offset, :print-function, or :include.
+:type, :named, :initial-offset, :print-function, :noinline, or :include.
Each SLOT may instead take the form (SNAME SDEFAULT SOPTIONS...), where
SDEFAULT is the default value of that slot and SOPTIONS are keyword-value
@@ -2686,9 +2760,14 @@ non-nil value, that slot cannot be set via `setf'.
(include-name nil)
(type nil) ;nil here means not specified explicitly.
(named nil)
+ (cldefsym (if cl--struct-inline 'cl-defsubst 'cl-defun))
+ (defsym (if cl--struct-inline 'cl-defsubst 'defun))
(forms nil)
(docstring (if (stringp (car descs)) (pop descs)))
pred-form pred-check)
+ ;; Can't use `cl-check-type' yet.
+ (unless (cl--struct-name-p name)
+ (signal 'wrong-type-argument (list 'cl-struct-name-p name 'name)))
(setq descs (cons '(cl-tag-slot)
(mapcar (function (lambda (x) (if (consp x) x (list x))))
descs)))
@@ -2729,6 +2808,8 @@ non-nil value, that slot cannot be set via `setf'.
(error "Invalid :type specifier: %s" type)))
((eq opt :named)
(setq named t))
+ ((eq opt :noinline)
+ (setq defsym 'defun) (setq cldefsym 'cl-defun))
((eq opt :initial-offset)
(setq descs (nconc (make-list (car args) '(cl-skip-slot))
descs)))
@@ -2787,7 +2868,7 @@ non-nil value, that slot cannot be set via `setf'.
(cons 'and (cl-cdddr pred-form))
`(,predicate cl-x))))
(when pred-form
- (push `(cl-defsubst ,predicate (cl-x)
+ (push `(,defsym ,predicate (cl-x)
(declare (side-effect-free error-free))
,(if (eq (car pred-form) 'and)
(append pred-form '(t))
@@ -2810,7 +2891,7 @@ non-nil value, that slot cannot be set via `setf'.
(push (pop desc) defaults)
;; The arg "cl-x" is referenced by name in eg pred-form
;; and pred-check, so changing it is not straightforward.
- (push `(cl-defsubst ,accessor (cl-x)
+ (push `(,defsym ,accessor (cl-x)
,(format "Access slot \"%s\" of `%s' struct CL-X."
slot struct)
(declare (side-effect-free t))
@@ -2881,7 +2962,7 @@ non-nil value, that slot cannot be set via `setf'.
(let* ((anames (cl--arglist-args args))
(make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d)))
slots defaults)))
- (push `(cl-defsubst ,cname
+ (push `(,cldefsym ,cname
(&cl-defs (nil ,@descs) ,@args)
,(if (stringp doc) doc
(format "Constructor for objects of type `%s'." name))
@@ -2947,7 +3028,7 @@ the form NAME which is a shorthand for (NAME NAME)."
(defun cl--defstruct-predicate (type)
(let ((cons (assq (cl-struct-sequence-type type)
- `((list . consp)
+ '((list . consp)
(vector . vectorp)
(nil . recordp)))))
(if cons
@@ -3281,7 +3362,7 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc."
(put ',name 'cl-deftype-handler
(cl-function (lambda (&cl-defs ('*) ,@arglist) ,@body)))))
-(cl-deftype extended-char () `(and character (not base-char)))
+(cl-deftype extended-char () '(and character (not base-char)))
;;; Additional functions that we can now define because we've defined
;;; `cl-defsubst' and `cl-typep'.
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index e3de8e16ae2..4bd22facc2f 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -50,6 +50,39 @@
(apply #'error string (append sargs args))
(signal 'cl-assertion-failed `(,form ,@sargs)))))
+(defconst cl--typeof-types
+ ;; Hand made from the source code of `type-of'.
+ '((integer number number-or-marker atom)
+ (symbol atom) (string array sequence atom)
+ (cons list sequence)
+ ;; Markers aren't `numberp', yet they are accepted wherever integers are
+ ;; accepted, pretty much.
+ (marker number-or-marker atom)
+ (overlay atom) (float number atom) (window-configuration atom)
+ (process atom) (window atom) (subr atom) (compiled-function function atom)
+ (module-function function atom)
+ (buffer atom) (char-table array sequence atom)
+ (bool-vector array sequence atom)
+ (frame atom) (hash-table atom) (terminal atom)
+ (thread atom) (mutex atom) (condvar atom)
+ (font-spec atom) (font-entity atom) (font-object atom)
+ (vector array sequence atom)
+ (user-ptr atom)
+ ;; Plus, really hand made:
+ (null symbol list sequence atom))
+ "Alist of supertypes.
+Each element has the form (TYPE . SUPERTYPES) where TYPE is one of
+the symbols returned by `type-of', and SUPERTYPES is the list of its
+supertypes from the most specific to least specific.")
+
+(defconst cl--all-builtin-types
+ (delete-dups (copy-sequence (apply #'append cl--typeof-types))))
+
+(defun cl--struct-name-p (name)
+ "Return t if NAME is a valid structure name for `cl-defstruct'."
+ (and name (symbolp name) (not (keywordp name))
+ (not (memq name cl--all-builtin-types))))
+
;; When we load this (compiled) file during pre-loading, the cl--struct-class
;; code below will need to access the `cl-struct' info, since it's considered
;; already as its parent (because `cl-struct' was defined while the file was
@@ -61,7 +94,7 @@
(fset 'cl--make-slot-desc
;; To break circularity, we pre-define the slot constructor by hand.
;; It's redefined a bit further down as part of the cl-defstruct of
- ;; cl--slot-descriptor.
+ ;; cl-slot-descriptor.
;; BEWARE: Obviously, it's important to keep the two in sync!
(lambda (name &optional initform type props)
(record 'cl-slot-descriptor
@@ -110,6 +143,7 @@
;;;###autoload
(defun cl-struct-define (name docstring parent type named slots children-sym
tag print)
+ (cl-check-type name cl--struct-name)
(unless type
;; Legacy defstruct, using tagged vectors. Enable backward compatibility.
(cl-old-struct-compat-mode 1))
@@ -194,7 +228,7 @@
(name nil :type symbol) ;The type name.
(docstring nil :type string)
(parents nil :type (list-of cl--class)) ;The included struct.
- (slots nil :type (vector cl--slot-descriptor))
+ (slots nil :type (vector cl-slot-descriptor))
(index-table nil :type hash-table)
(tag nil :type symbol) ;Placed in cl-tag-slot. Holds the struct-class object.
(type nil :type (memq (vector list)))
diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 51437de0d4f..5fe3dd1b912 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -55,10 +55,19 @@ call other entry points instead, such as `cl-prin1'."
;; we should only use it for objects which don't have nesting.
(prin1 object stream))
+(cl-defgeneric cl-print-object-contents (_object _start _stream)
+ "Dispatcher to print the contents of OBJECT on STREAM.
+Print the contents starting with the item at START, without
+delimiters."
+ ;; Every cl-print-object method which can print an ellipsis should
+ ;; have a matching cl-print-object-contents method to expand an
+ ;; ellipsis.
+ (error "Missing cl-print-object-contents method"))
+
(cl-defmethod cl-print-object ((object cons) stream)
(if (and cl-print--depth (natnump print-level)
(> cl-print--depth print-level))
- (princ "..." stream)
+ (cl-print-insert-ellipsis object 0 stream)
(let ((car (pop object))
(count 1))
(if (and print-quoted
@@ -84,23 +93,60 @@ call other entry points instead, such as `cl-prin1'."
(princ " " stream)
(if (or (not (natnump print-length)) (> print-length count))
(cl-print-object (pop object) stream)
- (princ "..." stream)
+ (cl-print-insert-ellipsis object print-length stream)
(setq object nil))
(cl-incf count))
(when object
(princ " . " stream) (cl-print-object object stream))
(princ ")" stream)))))
+(cl-defmethod cl-print-object-contents ((object cons) _start stream)
+ (let ((count 0))
+ (while (and (consp object)
+ (not (cond
+ (cl-print--number-table
+ (numberp (gethash object cl-print--number-table)))
+ ((memq object cl-print--currently-printing))
+ (t (push object cl-print--currently-printing)
+ nil))))
+ (unless (zerop count)
+ (princ " " stream))
+ (if (or (not (natnump print-length)) (> print-length count))
+ (cl-print-object (pop object) stream)
+ (cl-print-insert-ellipsis object print-length stream)
+ (setq object nil))
+ (cl-incf count))
+ (when object
+ (princ " . " stream) (cl-print-object object stream))))
+
(cl-defmethod cl-print-object ((object vector) stream)
- (princ "[" stream)
- (let ((count (length object)))
- (dotimes (i (if (natnump print-length)
- (min print-length count) count))
- (unless (zerop i) (princ " " stream))
- (cl-print-object (aref object i) stream))
- (when (and (natnump print-length) (< print-length count))
- (princ " ..." stream)))
- (princ "]" stream))
+ (if (and cl-print--depth (natnump print-level)
+ (> cl-print--depth print-level))
+ (cl-print-insert-ellipsis object 0 stream)
+ (princ "[" stream)
+ (let* ((len (length object))
+ (limit (if (natnump print-length)
+ (min print-length len) len)))
+ (dotimes (i limit)
+ (unless (zerop i) (princ " " stream))
+ (cl-print-object (aref object i) stream))
+ (when (< limit len)
+ (princ " " stream)
+ (cl-print-insert-ellipsis object limit stream)))
+ (princ "]" stream)))
+
+(cl-defmethod cl-print-object-contents ((object vector) start stream)
+ (let* ((len (length object))
+ (limit (if (natnump print-length)
+ (min (+ start print-length) len) len))
+ (i start))
+ (while (< i limit)
+ (unless (= i start) (princ " " stream))
+ (cl-print-object (aref object i) stream)
+ (cl-incf i))
+ (when (< limit len)
+ (princ " " stream)
+ (cl-print-insert-ellipsis object limit stream))))
(cl-defmethod cl-print-object ((object hash-table) stream)
(princ "#<hash-table " stream)
@@ -109,7 +155,7 @@ call other entry points instead, such as `cl-prin1'."
(princ (hash-table-count object) stream)
(princ "/" stream)
(princ (hash-table-size object) stream)
- (princ (format " 0x%x" (sxhash object)) stream)
+ (princ (format " %#x" (sxhash object)) stream)
(princ ">" stream))
(define-button-type 'help-byte-code
@@ -166,7 +212,7 @@ into a button whose action shows the function's disassembly.")
(let ((button-start (and cl-print-compiled-button
(bufferp stream)
(with-current-buffer stream (point)))))
- (princ (format "#<bytecode 0x%x>" (sxhash object)) stream)
+ (princ (format "#<bytecode %#x>" (sxhash object)) stream)
(when (eq cl-print-compiled 'static)
(princ " " stream)
(cl-print-object (aref object 2) stream))
@@ -199,21 +245,135 @@ into a button whose action shows the function's disassembly.")
(princ ")" stream)))
(cl-defmethod cl-print-object ((object cl-structure-object) stream)
- (princ "#s(" stream)
+ (if (and cl-print--depth (natnump print-level)
+ (> cl-print--depth print-level))
+ (cl-print-insert-ellipsis object 0 stream)
+ (princ "#s(" stream)
+ (let* ((class (cl-find-class (type-of object)))
+ (slots (cl--struct-class-slots class))
+ (len (length slots))
+ (limit (if (natnump print-length)
+ (min print-length len) len)))
+ (princ (cl--struct-class-name class) stream)
+ (dotimes (i limit)
+ (let ((slot (aref slots i)))
+ (princ " :" stream)
+ (princ (cl--slot-descriptor-name slot) stream)
+ (princ " " stream)
+ (cl-print-object (aref object (1+ i)) stream)))
+ (when (< limit len)
+ (princ " " stream)
+ (cl-print-insert-ellipsis object limit stream)))
+ (princ ")" stream)))
+
+(cl-defmethod cl-print-object-contents ((object cl-structure-object) start stream)
(let* ((class (cl-find-class (type-of object)))
(slots (cl--struct-class-slots class))
- (count (length slots)))
- (princ (cl--struct-class-name class) stream)
- (dotimes (i (if (natnump print-length)
- (min print-length count) count))
+ (len (length slots))
+ (limit (if (natnump print-length)
+ (min (+ start print-length) len) len))
+ (i start))
+ (while (< i limit)
(let ((slot (aref slots i)))
- (princ " :" stream)
+ (unless (= i start) (princ " " stream))
+ (princ ":" stream)
(princ (cl--slot-descriptor-name slot) stream)
(princ " " stream)
- (cl-print-object (aref object (1+ i)) stream)))
- (when (and (natnump print-length) (< print-length count))
- (princ " ..." stream)))
- (princ ")" stream))
+ (cl-print-object (aref object (1+ i)) stream))
+ (cl-incf i))
+ (when (< limit len)
+ (princ " " stream)
+ (cl-print-insert-ellipsis object limit stream))))
+
+(cl-defmethod cl-print-object ((object string) stream)
+ (unless stream (setq stream standard-output))
+ (let* ((has-properties (or (text-properties-at 0 object)
+ (next-property-change 0 object)))
+ (len (length object))
+ (limit (if (natnump print-length) (min print-length len) len)))
+ (if (and has-properties
+ cl-print--depth
+ (natnump print-level)
+ (> cl-print--depth print-level))
+ (cl-print-insert-ellipsis object 0 stream)
+ ;; Print all or part of the string
+ (when has-properties
+ (princ "#(" stream))
+ (if (= limit len)
+ (prin1 (if has-properties (substring-no-properties object) object)
+ stream)
+ (let ((part (concat (substring-no-properties object 0 limit) "...")))
+ (prin1 part stream)
+ (when (bufferp stream)
+ (with-current-buffer stream
+ (cl-print-propertize-ellipsis object limit
+ (- (point) 4)
+ (- (point) 1) stream)))))
+ ;; Print the property list.
+ (when has-properties
+ (let* ((interval-limit (and (natnump print-length)
+ (max 1 (/ print-length 3))))
+ (interval-count 0)
+ (start-pos (if (text-properties-at 0 object)
+ 0 (next-property-change 0 object)))
+ (end-pos (next-property-change start-pos object len)))
+ (while (and (or (null interval-limit)
+ (< interval-count interval-limit))
+ (< start-pos len))
+ (let ((props (text-properties-at start-pos object)))
+ (when props
+ (princ " " stream) (princ start-pos stream)
+ (princ " " stream) (princ end-pos stream)
+ (princ " " stream) (cl-print-object props stream)
+ (cl-incf interval-count))
+ (setq start-pos end-pos
+ end-pos (next-property-change start-pos object len))))
+ (when (< start-pos len)
+ (princ " " stream)
+ (cl-print-insert-ellipsis object (list start-pos) stream)))
+ (princ ")" stream)))))
+
+(cl-defmethod cl-print-object-contents ((object string) start stream)
+ ;; If START is an integer, it is an index into the string, and the
+ ;; ellipsis that needs to be expanded is part of the string. If
+ ;; START is a cons, its car is an index into the string, and the
+ ;; ellipsis that needs to be expanded is in the property list.
+ (let* ((len (length object)))
+ (if (atom start)
+ ;; Print part of the string.
+ (let* ((limit (if (natnump print-length)
+ (min (+ start print-length) len) len))
+ (substr (substring-no-properties object start limit))
+ (printed (prin1-to-string substr))
+ (trimmed (substring printed 1 (1- (length printed)))))
+ (princ trimmed)
+ (when (< limit len)
+ (cl-print-insert-ellipsis object limit stream)))
+
+ ;; Print part of the property list.
+ (let* ((first t)
+ (interval-limit (and (natnump print-length)
+ (max 1 (/ print-length 3))))
+ (interval-count 0)
+ (start-pos (car start))
+ (end-pos (next-property-change start-pos object len)))
+ (while (and (or (null interval-limit)
+ (< interval-count interval-limit))
+ (< start-pos len))
+ (let ((props (text-properties-at start-pos object)))
+ (when props
+ (if first
+ (setq first nil)
+ (princ " " stream))
+ (princ start-pos stream)
+ (princ " " stream) (princ end-pos stream)
+ (princ " " stream) (cl-print-object props stream)
+ (cl-incf interval-count))
+ (setq start-pos end-pos
+ end-pos (next-property-change start-pos object len))))
+ (when (< start-pos len)
+ (princ " " stream)
+ (cl-print-insert-ellipsis object (list start-pos) stream))))))
;;; Circularity and sharing.
@@ -275,8 +435,17 @@ into a button whose action shows the function's disassembly.")
(push cdr stack)
(push car stack))
((pred stringp)
- ;; We presumably won't print its text-properties.
- nil)
+ (let* ((len (length object))
+ (start (if (text-properties-at 0 object)
+ 0 (next-property-change 0 object)))
+ (end (and start
+ (next-property-change start object len))))
+ (while (and start (< start len))
+ (let ((props (text-properties-at start object)))
+ (when props
+ (push props stack))
+ (setq start end
+ end (next-property-change start object len))))))
((or (pred arrayp) (pred byte-code-function-p))
;; FIXME: Inefficient for char-tables!
(dotimes (i (length object))
@@ -291,6 +460,48 @@ into a button whose action shows the function's disassembly.")
(cl-print--find-sharing object print-number-table)))
print-number-table))
+(defun cl-print-insert-ellipsis (object start stream)
+ "Print \"...\" to STREAM with the `cl-print-ellipsis' text property.
+Save state in the text property in order to print the elided part
+of OBJECT later. START should be 0 if the whole OBJECT is being
+elided, otherwise it should be an index or other pointer into the
+internals of OBJECT which can be passed to
+`cl-print-object-contents' at a future time."
+ (unless stream (setq stream standard-output))
+ (let ((ellipsis-start (and (bufferp stream)
+ (with-current-buffer stream (point)))))
+ (princ "..." stream)
+ (when ellipsis-start
+ (with-current-buffer stream
+ (cl-print-propertize-ellipsis object start ellipsis-start (point)
+ stream)))))
+
+(defun cl-print-propertize-ellipsis (object start beg end stream)
+ "Add the `cl-print-ellipsis' property between BEG and END.
+STREAM should be a buffer. OBJECT and START are as described in
+`cl-print-insert-ellipsis'."
+ (let ((value (list object start cl-print--number-table
+ cl-print--currently-printing)))
+ (with-current-buffer stream
+ (put-text-property beg end 'cl-print-ellipsis value stream))))
+
+;;;###autoload
+(defun cl-print-expand-ellipsis (value stream)
+ "Print the expansion of an ellipsis to STREAM.
+VALUE should be the value of the `cl-print-ellipsis' text property
+which was attached to the ellipsis by `cl-prin1'."
+ (let ((cl-print--depth 1)
+ (object (nth 0 value))
+ (start (nth 1 value))
+ (cl-print--number-table (nth 2 value))
+ (print-number-table (nth 2 value))
+ (cl-print--currently-printing (nth 3 value)))
+ (when (eq object (car cl-print--currently-printing))
+ (pop cl-print--currently-printing))
+ (if (equal start 0)
+ (cl-print-object object stream)
+ (cl-print-object-contents object start stream))))
+
;;;###autoload
(defun cl-prin1 (object &optional stream)
"Print OBJECT on STREAM according to its type.
@@ -298,12 +509,13 @@ Output is further controlled by the variables
`cl-print-readably', `cl-print-compiled', along with output
variables for the standard printing functions. See Info
node `(elisp)Output Variables'."
- (cond
- (cl-print-readably (prin1 object stream))
- ((not print-circle) (cl-print-object object stream))
- (t
- (let ((cl-print--number-table (cl-print--preprocess object)))
- (cl-print-object object stream)))))
+ (if cl-print-readably
+ (prin1 object stream)
+ (with-demoted-errors "cl-prin1: %S"
+ (if (not print-circle)
+ (cl-print-object object stream)
+ (let ((cl-print--number-table (cl-print--preprocess object)))
+ (cl-print-object object stream))))))
;;;###autoload
(defun cl-prin1-to-string (object)
@@ -312,5 +524,45 @@ node `(elisp)Output Variables'."
(cl-prin1 object (current-buffer))
(buffer-string)))
+;;;###autoload
+(defun cl-print-to-string-with-limit (print-function value limit)
+ "Return a string containing a printed representation of VALUE.
+Attempt to get the length of the returned string under LIMIT
+characters with appropriate settings of `print-level' and
+`print-length.' Use PRINT-FUNCTION to print, which should take
+the arguments VALUE and STREAM and which should respect
+`print-length' and `print-level'. LIMIT may be nil or zero in
+which case PRINT-FUNCTION will be called with `print-level' and
+`print-length' bound to nil.
+
+Use this function with `cl-prin1' to print an object,
+abbreviating it with ellipses to fit within a size limit. Use
+this function with `cl-prin1-expand-ellipsis' to expand an
+ellipsis, abbreviating the expansion to stay within a size
+limit."
+ (setq limit (and (natnump limit)
+ (not (zerop limit))
+ limit))
+ ;; Since this is used by the debugger when stack space may be
+ ;; limited, if you increase print-level here, add more depth in
+ ;; call_debugger (bug#31919).
+ (let* ((print-length (when limit (min limit 50)))
+ (print-level (when limit (min 8 (truncate (log limit)))))
+ (delta (when limit
+ (max 1 (truncate (/ print-length print-level))))))
+ (with-temp-buffer
+ (catch 'done
+ (while t
+ (erase-buffer)
+ (funcall print-function value (current-buffer))
+ ;; Stop when either print-level is too low or the value is
+ ;; successfully printed in the space allowed.
+ (when (or (not limit)
+ (< (- (point-max) (point-min)) limit)
+ (= print-level 2))
+ (throw 'done (buffer-string)))
+ (cl-decf print-level)
+ (cl-decf print-length delta))))))
+
(provide 'cl-print)
;;; cl-print.el ends here
diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el
index 31ad8111858..3eb6ea16daf 100644
--- a/lisp/emacs-lisp/cl-seq.el
+++ b/lisp/emacs-lisp/cl-seq.el
@@ -113,6 +113,13 @@
(defvar cl-key)
;;;###autoload
+(defun cl-endp (x)
+ "Return true if X is the empty list; false if it is a cons.
+Signal an error if X is not a list."
+ (cl-check-type x list)
+ (null x))
+
+;;;###autoload
(defun cl-reduce (cl-func cl-seq &rest cl-keys)
"Reduce two-argument FUNCTION across SEQ.
\nKeywords supported: :start :end :from-end :initial-value :key
diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el
index 58cda67e2ba..2726bbc1f3f 100644
--- a/lisp/emacs-lisp/copyright.el
+++ b/lisp/emacs-lisp/copyright.el
@@ -186,9 +186,10 @@ skips to the end of all the years."
(substring copyright-current-year -2))
(if (or noquery
(save-window-excursion
- (switch-to-buffer (current-buffer))
- ;; Fixes some point-moving oddness (bug#2209).
+ ;; switch-to-buffer might move point when
+ ;; switch-to-buffer-preserve-window-point is non-nil.
(save-excursion
+ (switch-to-buffer (current-buffer))
(y-or-n-p (if replace
(concat "Replace copyright year(s) by "
copyright-current-year "? ")
diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el
index cfae02817f4..40567e141d3 100644
--- a/lisp/emacs-lisp/crm.el
+++ b/lisp/emacs-lisp/crm.el
@@ -263,7 +263,8 @@ with empty strings removed."
(input (read-from-minibuffer
prompt initial-input map
nil hist def inherit-input-method)))
- (and def (string-equal input "") (setq input def))
+ (when (and def (string-equal input ""))
+ (setq input (if (consp def) (car def) def)))
;; Remove empty strings in the list of read strings.
(split-string input crm-separator t)))
(remove-hook 'choose-completion-string-functions
diff --git a/lisp/emacs-lisp/cursor-sensor.el b/lisp/emacs-lisp/cursor-sensor.el
index a21d78998ac..66b940f7fb3 100644
--- a/lisp/emacs-lisp/cursor-sensor.el
+++ b/lisp/emacs-lisp/cursor-sensor.el
@@ -160,7 +160,7 @@ By convention, this is a list of symbols where each symbol stands for the
(setcdr old nil))
(if (or (and (null new) (null (cdr old)))
(and (eq new (cdr old))
- (eq (next-single-property-change
+ (eq (next-single-char-property-change
start 'cursor-sensor-functions nil end)
end)))
;; Clearly nothing to do.
@@ -172,7 +172,7 @@ By convention, this is a list of symbols where each symbol stands for the
(let ((pos start)
(missing nil))
(while (< pos end)
- (setq pos (next-single-property-change
+ (setq pos (next-single-char-property-change
pos 'cursor-sensor-functions
nil end))
(unless (memq f (get-char-property
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
index abfbfa81511..8989aa07196 100644
--- a/lisp/emacs-lisp/debug.el
+++ b/lisp/emacs-lisp/debug.el
@@ -27,6 +27,8 @@
;;; Code:
+(require 'cl-lib)
+(require 'backtrace)
(require 'button)
(defgroup debugger nil
@@ -132,6 +134,25 @@ where CAUSE can be:
- exit: called because of exit of a flagged function.
- error: called because of `debug-on-error'.")
+(cl-defstruct (debugger--buffer-state
+ (:constructor debugger--save-buffer-state
+ (&aux (mode major-mode)
+ (header backtrace-insert-header-function)
+ (frames backtrace-frames)
+ (content (buffer-string))
+ (pos (point)))))
+ mode header frames content pos)
+
+(defun debugger--restore-buffer-state (state)
+ (unless (derived-mode-p (debugger--buffer-state-mode state))
+ (funcall (debugger--buffer-state-mode state)))
+ (setq backtrace-insert-header-function (debugger--buffer-state-header state)
+ backtrace-frames (debugger--buffer-state-frames state))
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (insert (debugger--buffer-state-content state)))
+ (goto-char (debugger--buffer-state-pos state)))
+
;;;###autoload
(setq debugger 'debug)
;;;###autoload
@@ -144,16 +165,36 @@ You may call with no args, or you may pass nil as the first arg and
any other args you like. In that case, the list of args after the
first will be printed into the backtrace buffer."
(interactive)
- (if inhibit-redisplay
- ;; Don't really try to enter debugger within an eval from redisplay.
- debugger-value
+ (cond
+ (inhibit-redisplay
+ ;; Don't really try to enter debugger within an eval from redisplay.
+ debugger-value)
+ ((and (eq t (framep (selected-frame)))
+ (equal "initial_terminal" (terminal-name)))
+ ;; We're in the initial-frame (where `message' just outputs to stdout) so
+ ;; there's no tty or GUI frame to display the backtrace and interact with
+ ;; it: just dump a backtrace to stdout.
+ ;; This happens for example while handling an error in code from
+ ;; early-init.el with --debug-init.
+ (message "Error: %S" args)
+ (let ((print-escape-newlines t)
+ (print-escape-control-characters t)
+ (print-level 8)
+ (print-length 50)
+ (skip t)) ;Skip the first frame (i.e. the `debug' frame)!
+ (mapbacktrace (lambda (_evald func args _flags)
+ (if skip
+ (setq skip nil)
+ (message " %S" (cons func args))))
+ 'debug)))
+ (t
(unless noninteractive
(message "Entering debugger..."))
(let (debugger-value
(debugger-previous-state
(if (get-buffer "*Backtrace*")
(with-current-buffer (get-buffer "*Backtrace*")
- (list major-mode (buffer-string)))))
+ (debugger--save-buffer-state))))
(debugger-args args)
(debugger-buffer (get-buffer-create "*Backtrace*"))
(debugger-old-buffer (current-buffer))
@@ -195,14 +236,37 @@ first will be printed into the backtrace buffer."
;; Place an extra debug-on-exit for macro's.
(when (eq 'lambda (car-safe (cadr (backtrace-frame 4))))
(backtrace-debug 5 t)))
+ (with-current-buffer debugger-buffer
+ (unless (derived-mode-p 'debugger-mode)
+ (debugger-mode))
+ (debugger-setup-buffer debugger-args)
+ (when noninteractive
+ ;; If the backtrace is long, save the beginning
+ ;; and the end, but discard the middle.
+ (when (> (count-lines (point-min) (point-max))
+ debugger-batch-max-lines)
+ (goto-char (point-min))
+ (forward-line (/ 2 debugger-batch-max-lines))
+ (let ((middlestart (point)))
+ (goto-char (point-max))
+ (forward-line (- (/ 2 debugger-batch-max-lines)
+ debugger-batch-max-lines))
+ (delete-region middlestart (point)))
+ (insert "...\n"))
+ (goto-char (point-min))
+ (message "%s" (buffer-string))
+ (kill-emacs -1)))
(pop-to-buffer
debugger-buffer
`((display-buffer-reuse-window
- display-buffer-in-previous-window)
- . (,(when (and (window-live-p debugger-previous-window)
- (frame-visible-p
- (window-frame debugger-previous-window)))
- `(previous-window . ,debugger-previous-window)))))
+ display-buffer-in-previous-window
+ display-buffer-below-selected)
+ . ((window-min-height . 10)
+ (window-height . fit-window-to-buffer)
+ ,@(when (and (window-live-p debugger-previous-window)
+ (frame-visible-p
+ (window-frame debugger-previous-window)))
+ `((previous-window . ,debugger-previous-window))))))
(setq debugger-window (selected-window))
(if (eq debugger-previous-window debugger-window)
(when debugger-jumping-flag
@@ -215,24 +279,6 @@ first will be printed into the backtrace buffer."
(window-total-height debugger-window)))
(error nil)))
(setq debugger-previous-window debugger-window))
- (debugger-mode)
- (debugger-setup-buffer debugger-args)
- (when noninteractive
- ;; If the backtrace is long, save the beginning
- ;; and the end, but discard the middle.
- (when (> (count-lines (point-min) (point-max))
- debugger-batch-max-lines)
- (goto-char (point-min))
- (forward-line (/ 2 debugger-batch-max-lines))
- (let ((middlestart (point)))
- (goto-char (point-max))
- (forward-line (- (/ 2 debugger-batch-max-lines)
- debugger-batch-max-lines))
- (delete-region middlestart (point)))
- (insert "...\n"))
- (goto-char (point-min))
- (message "%s" (buffer-string))
- (kill-emacs -1))
(message "")
(let ((standard-output nil)
(buffer-read-only t))
@@ -259,127 +305,100 @@ first will be printed into the backtrace buffer."
(setq debugger-previous-window nil))
;; Restore previous state of debugger-buffer in case we were
;; in a recursive invocation of the debugger, otherwise just
- ;; erase the buffer and put it into fundamental mode.
+ ;; erase the buffer.
(when (buffer-live-p debugger-buffer)
(with-current-buffer debugger-buffer
- (let ((inhibit-read-only t))
- (erase-buffer)
- (if (null debugger-previous-state)
- (fundamental-mode)
- (insert (nth 1 debugger-previous-state))
- (funcall (nth 0 debugger-previous-state))))))
+ (if debugger-previous-state
+ (debugger--restore-buffer-state debugger-previous-state)
+ (setq backtrace-insert-header-function nil)
+ (setq backtrace-frames nil)
+ (backtrace-print))))
(with-timeout-unsuspend debugger-with-timeout-suspend)
(set-match-data debugger-outer-match-data)))
(setq debug-on-next-call debugger-step-after-exit)
- debugger-value)))
+ debugger-value))))
-
-(defun debugger-insert-backtrace (frames do-xrefs)
- "Format and insert the backtrace FRAMES at point.
-Make functions into cross-reference buttons if DO-XREFS is non-nil."
- (let ((standard-output (current-buffer))
- (eval-buffers eval-buffer-list))
- (require 'help-mode) ; Define `help-function-def' button type.
- (pcase-dolist (`(,evald ,fun ,args ,flags) frames)
- (insert (if (plist-get flags :debug-on-exit)
- "* " " "))
- (let ((fun-file (and do-xrefs (symbol-file fun 'defun)))
- (fun-pt (point)))
- (cond
- ((and evald (not debugger-stack-frame-as-list))
- (funcall debugger-print-function fun)
- (if args (funcall debugger-print-function args) (princ "()")))
- (t
- (funcall debugger-print-function (cons fun args))
- (cl-incf fun-pt)))
- (when fun-file
- (make-text-button fun-pt (+ fun-pt (length (symbol-name fun)))
- :type 'help-function-def
- 'help-args (list fun fun-file))))
- ;; After any frame that uses eval-buffer, insert a line that
- ;; states the buffer position it's reading at.
- (when (and eval-buffers (memq fun '(eval-buffer eval-region)))
- (insert (format " ; Reading at buffer position %d"
- ;; This will get the wrong result if there are
- ;; two nested eval-region calls for the same
- ;; buffer. That's not a very useful case.
- (with-current-buffer (pop eval-buffers)
- (point)))))
- (insert "\n"))))
+(defun debugger--print (obj &optional stream)
+ (condition-case err
+ (funcall debugger-print-function obj stream)
+ (error
+ (message "Error in debug printer: %S" err)
+ (prin1 obj stream))))
(defun debugger-setup-buffer (args)
"Initialize the `*Backtrace*' buffer for entry to the debugger.
-That buffer should be current already."
- (setq buffer-read-only nil)
- (erase-buffer)
- (set-buffer-multibyte t) ;Why was it nil ? -stef
- (setq buffer-undo-list t)
+That buffer should be current already and in debugger-mode."
+ (setq backtrace-frames (nthcdr
+ ;; Remove debug--implement-debug-on-entry and the
+ ;; advice's `apply' frame.
+ (if (eq (car args) 'debug) 3 1)
+ (backtrace-get-frames 'debug)))
+ (when (eq (car-safe args) 'exit)
+ (setq debugger-value (nth 1 args))
+ (setf (cl-getf (backtrace-frame-flags (car backtrace-frames))
+ :debug-on-exit)
+ nil))
+
+ (setq backtrace-view (plist-put backtrace-view :show-flags t)
+ backtrace-insert-header-function (lambda ()
+ (debugger--insert-header args))
+ backtrace-print-function debugger-print-function)
+ (backtrace-print)
+ ;; Place point on "stack frame 0" (bug#15101).
+ (goto-char (point-min))
+ (search-forward ":" (line-end-position) t)
+ (when (and (< (point) (line-end-position))
+ (= (char-after) ?\s))
+ (forward-char)))
+
+(defun debugger--insert-header (args)
+ "Insert the header for the debugger's Backtrace buffer.
+Include the reason for debugger entry from ARGS."
(insert "Debugger entered")
- (let ((frames (nthcdr
- ;; Remove debug--implement-debug-on-entry and the
- ;; advice's `apply' frame.
- (if (eq (car args) 'debug) 3 1)
- (backtrace-frames 'debug)))
- (print-escape-newlines t)
- (print-escape-control-characters t)
- ;; If you increase print-level, add more depth in call_debugger.
- (print-level 8)
- (print-length 50)
- (pos (point)))
- (pcase (car args)
- ;; lambda is for debug-on-call when a function call is next.
- ;; debug is for debug-on-entry function called.
- ((or `lambda `debug)
- (insert "--entering a function:\n")
- (setq pos (1- (point))))
- ;; Exiting a function.
- (`exit
- (insert "--returning value: ")
- (setq pos (point))
- (setq debugger-value (nth 1 args))
- (funcall debugger-print-function debugger-value (current-buffer))
- (setf (cl-getf (nth 3 (car frames)) :debug-on-exit) nil)
- (insert ?\n))
- ;; Watchpoint triggered.
- ((and `watchpoint (let `(,symbol ,newval . ,details) (cdr args)))
- (insert
- "--"
- (pcase details
- (`(makunbound nil) (format "making %s void" symbol))
- (`(makunbound ,buffer) (format "killing local value of %s in buffer %s"
- symbol buffer))
- (`(defvaralias ,_) (format "aliasing %s to %s" symbol newval))
- (`(let ,_) (format "let-binding %s to %S" symbol newval))
- (`(unlet ,_) (format "ending let-binding of %s" symbol))
- (`(set nil) (format "setting %s to %S" symbol newval))
- (`(set ,buffer) (format "setting %s in buffer %s to %S"
- symbol buffer newval))
- (_ (error "unrecognized watchpoint triggered %S" (cdr args))))
- ": ")
- (setq pos (point))
- (insert ?\n))
- ;; Debugger entered for an error.
- (`error
- (insert "--Lisp error: ")
- (setq pos (point))
- (funcall debugger-print-function (nth 1 args) (current-buffer))
- (insert ?\n))
- ;; debug-on-call, when the next thing is an eval.
- (`t
- (insert "--beginning evaluation of function call form:\n")
- (setq pos (1- (point))))
- ;; User calls debug directly.
- (_
- (insert ": ")
- (setq pos (point))
- (funcall debugger-print-function
- (if (eq (car args) 'nil)
- (cdr args) args)
- (current-buffer))
- (insert ?\n)))
- (debugger-insert-backtrace frames t)
- ;; Place point on "stack frame 0" (bug#15101).
- (goto-char pos)))
+ (pcase (car args)
+ ;; lambda is for debug-on-call when a function call is next.
+ ;; debug is for debug-on-entry function called.
+ ((or 'lambda 'debug)
+ (insert "--entering a function:\n"))
+ ;; Exiting a function.
+ ('exit
+ (insert "--returning value: ")
+ (insert (backtrace-print-to-string debugger-value))
+ (insert ?\n))
+ ;; Watchpoint triggered.
+ ((and 'watchpoint (let `(,symbol ,newval . ,details) (cdr args)))
+ (insert
+ "--"
+ (pcase details
+ ('(makunbound nil) (format "making %s void" symbol))
+ (`(makunbound ,buffer) (format "killing local value of %s in buffer %s"
+ symbol buffer))
+ (`(defvaralias ,_) (format "aliasing %s to %s" symbol newval))
+ (`(let ,_) (format "let-binding %s to %s" symbol
+ (backtrace-print-to-string newval)))
+ (`(unlet ,_) (format "ending let-binding of %s" symbol))
+ ('(set nil) (format "setting %s to %s" symbol
+ (backtrace-print-to-string newval)))
+ (`(set ,buffer) (format "setting %s in buffer %s to %s"
+ symbol buffer
+ (backtrace-print-to-string newval)))
+ (_ (error "unrecognized watchpoint triggered %S" (cdr args))))
+ ": ")
+ (insert ?\n))
+ ;; Debugger entered for an error.
+ ('error
+ (insert "--Lisp error: ")
+ (insert (backtrace-print-to-string (nth 1 args)))
+ (insert ?\n))
+ ;; debug-on-call, when the next thing is an eval.
+ ('t
+ (insert "--beginning evaluation of function call form:\n"))
+ ;; User calls debug directly.
+ (_
+ (insert ": ")
+ (insert (backtrace-print-to-string (if (eq (car args) 'nil)
+ (cdr args) args)))
+ (insert ?\n))))
(defun debugger-step-through ()
@@ -399,12 +418,12 @@ Enter another debugger on next entry to eval, apply or funcall."
(unless debugger-may-continue
(error "Cannot continue"))
(message "Continuing.")
- (save-excursion
- ;; Check to see if we've flagged some frame for debug-on-exit, in which
- ;; case we'll probably come back to the debugger soon.
- (goto-char (point-min))
- (if (re-search-forward "^\\* " nil t)
- (setq debugger-will-be-back t)))
+
+ ;; Check to see if we've flagged some frame for debug-on-exit, in which
+ ;; case we'll probably come back to the debugger soon.
+ (dolist (frame backtrace-frames)
+ (when (plist-get (backtrace-frame-flags frame) :debug-on-exit)
+ (setq debugger-will-be-back t)))
(exit-recursive-edit))
(defun debugger-return-value (val)
@@ -418,13 +437,12 @@ will be used, such as in a debug on exit from a frame."
"from an error" "at function entrance")))
(setq debugger-value val)
(princ "Returning " t)
- (prin1 debugger-value)
- (save-excursion
+ (debugger--print debugger-value)
;; Check to see if we've flagged some frame for debug-on-exit, in which
;; case we'll probably come back to the debugger soon.
- (goto-char (point-min))
- (if (re-search-forward "^\\* " nil t)
- (setq debugger-will-be-back t)))
+ (dolist (frame backtrace-frames)
+ (when (plist-get (backtrace-frame-flags frame) :debug-on-exit)
+ (setq debugger-will-be-back t)))
(exit-recursive-edit))
(defun debugger-jump ()
@@ -446,63 +464,40 @@ removes itself from that hook."
(defun debugger-frame-number (&optional skip-base)
"Return number of frames in backtrace before the one point points at."
- (save-excursion
- (beginning-of-line)
- (if (looking-at " *;;;\\|[a-z]")
- (error "This line is not a function call"))
- (let ((opoint (point))
- (count 0))
- (unless skip-base
+ (let ((index (backtrace-get-index))
+ (count 0))
+ (unless index
+ (error "This line is not a function call"))
+ (unless skip-base
(while (not (eq (cadr (backtrace-frame count)) 'debug))
(setq count (1+ count)))
;; Skip debug--implement-debug-on-entry frame.
(when (eq 'debug--implement-debug-on-entry
(cadr (backtrace-frame (1+ count))))
(setq count (+ 2 count))))
- (goto-char (point-min))
- (when (looking-at "Debugger entered--\\(Lisp error\\|returning value\\):")
- (goto-char (match-end 0))
- (forward-sexp 1))
- (forward-line 1)
- (while (progn
- (forward-char 2)
- (cond ((debugger--locals-visible-p)
- (goto-char (next-single-char-property-change
- (point) 'locals-visible)))
- ((= (following-char) ?\()
- (forward-sexp 1))
- (t
- (forward-sexp 2)))
- (forward-line 1)
- (<= (point) opoint))
- (if (looking-at " *;;;")
- (forward-line 1))
- (setq count (1+ count)))
- count)))
+ (+ count index)))
(defun debugger-frame ()
"Request entry to debugger when this frame exits.
Applies to the frame whose line point is on in the backtrace."
(interactive)
(backtrace-debug (debugger-frame-number) t)
- (beginning-of-line)
- (if (= (following-char) ? )
- (let ((inhibit-read-only t))
- (delete-char 1)
- (insert ?*)))
- (beginning-of-line))
+ (setf
+ (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames))
+ :debug-on-exit)
+ t)
+ (backtrace-update-flags))
(defun debugger-frame-clear ()
"Do not enter debugger when this frame exits.
Applies to the frame whose line point is on in the backtrace."
(interactive)
(backtrace-debug (debugger-frame-number) nil)
- (beginning-of-line)
- (if (= (following-char) ?*)
- (let ((inhibit-read-only t))
- (delete-char 1)
- (insert ? )))
- (beginning-of-line))
+ (setf
+ (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames))
+ :debug-on-exit)
+ nil)
+ (backtrace-update-flags))
(defmacro debugger-env-macro (&rest body)
"Run BODY in original environment."
@@ -533,73 +528,14 @@ The environment used is the one when entering the activation frame at point."
(debugger-env-macro
(let ((val (backtrace-eval exp nframe base)))
(prog1
- (prin1 val t)
+ (debugger--print val t)
(let ((str (eval-expression-print-format val)))
(if str (princ str t))))))))
-(defun debugger--locals-visible-p ()
- "Are the local variables of the current stack frame visible?"
- (save-excursion
- (move-to-column 2)
- (get-text-property (point) 'locals-visible)))
-
-(defun debugger--insert-locals (locals)
- "Insert the local variables LOCALS at point."
- (cond ((null locals)
- (insert "\n [no locals]"))
- (t
- (let ((print-escape-newlines t))
- (dolist (s+v locals)
- (let ((symbol (car s+v))
- (value (cdr s+v)))
- (insert "\n ")
- (prin1 symbol (current-buffer))
- (insert " = ")
- (prin1 value (current-buffer))))))))
-
-(defun debugger--show-locals ()
- "For the frame at point, insert locals and add text properties."
- (let* ((nframe (1+ (debugger-frame-number 'skip-base)))
- (base (debugger--backtrace-base))
- (locals (backtrace--locals nframe base))
- (inhibit-read-only t))
- (save-excursion
- (let ((start (progn
- (move-to-column 2)
- (point))))
- (end-of-line)
- (debugger--insert-locals locals)
- (add-text-properties start (point) '(locals-visible t))))))
-
-(defun debugger--hide-locals ()
- "Delete local variables and remove the text property."
- (let* ((col (current-column))
- (end (progn
- (move-to-column 2)
- (next-single-char-property-change (point) 'locals-visible)))
- (start (previous-single-char-property-change end 'locals-visible))
- (inhibit-read-only t))
- (remove-text-properties start end '(locals-visible))
- (goto-char start)
- (end-of-line)
- (delete-region (point) end)
- (move-to-column col)))
-
-(defun debugger-toggle-locals ()
- "Show or hide local variables of the current stack frame."
- (interactive)
- (cond ((debugger--locals-visible-p)
- (debugger--hide-locals))
- (t
- (debugger--show-locals))))
-
(defvar debugger-mode-map
- (let ((map (make-keymap))
- (menu-map (make-sparse-keymap)))
- (set-keymap-parent map button-buffer-map)
- (suppress-keymap map)
- (define-key map "-" 'negative-argument)
+ (let ((map (make-keymap)))
+ (set-keymap-parent map backtrace-mode-map)
(define-key map "b" 'debugger-frame)
(define-key map "c" 'debugger-continue)
(define-key map "j" 'debugger-jump)
@@ -607,63 +543,47 @@ The environment used is the one when entering the activation frame at point."
(define-key map "u" 'debugger-frame-clear)
(define-key map "d" 'debugger-step-through)
(define-key map "l" 'debugger-list-functions)
- (define-key map "h" 'describe-mode)
- (define-key map "q" 'top-level)
+ (define-key map "q" 'debugger-quit)
(define-key map "e" 'debugger-eval-expression)
- (define-key map "v" 'debugger-toggle-locals) ; "v" is for "variables".
- (define-key map " " 'next-line)
(define-key map "R" 'debugger-record-expression)
- (define-key map "\C-m" 'debug-help-follow)
(define-key map [mouse-2] 'push-button)
- (define-key map [menu-bar debugger] (cons "Debugger" menu-map))
- (define-key menu-map [deb-top]
- '(menu-item "Quit" top-level
- :help "Quit debugging and return to top level"))
- (define-key menu-map [deb-s0] '("--"))
- (define-key menu-map [deb-descr]
- '(menu-item "Describe Debugger Mode" describe-mode
- :help "Display documentation for debugger-mode"))
- (define-key menu-map [deb-hfol]
- '(menu-item "Help Follow" debug-help-follow
- :help "Follow cross-reference"))
- (define-key menu-map [deb-nxt]
- '(menu-item "Next Line" next-line
- :help "Move cursor down"))
- (define-key menu-map [deb-s1] '("--"))
- (define-key menu-map [deb-lfunc]
- '(menu-item "List debug on entry functions" debugger-list-functions
- :help "Display a list of all the functions now set to debug on entry"))
- (define-key menu-map [deb-fclear]
- '(menu-item "Cancel debug frame" debugger-frame-clear
- :help "Do not enter debugger when this frame exits"))
- (define-key menu-map [deb-frame]
- '(menu-item "Debug frame" debugger-frame
- :help "Request entry to debugger when this frame exits"))
- (define-key menu-map [deb-s2] '("--"))
- (define-key menu-map [deb-ret]
- '(menu-item "Return value..." debugger-return-value
- :help "Continue, specifying value to return."))
- (define-key menu-map [deb-rec]
- '(menu-item "Display and Record Expression" debugger-record-expression
- :help "Display a variable's value and record it in `*Backtrace-record*' buffer"))
- (define-key menu-map [deb-eval]
- '(menu-item "Eval Expression..." debugger-eval-expression
- :help "Eval an expression, in an environment like that outside the debugger"))
- (define-key menu-map [deb-jump]
- '(menu-item "Jump" debugger-jump
- :help "Continue to exit from this frame, with all debug-on-entry suspended"))
- (define-key menu-map [deb-cont]
- '(menu-item "Continue" debugger-continue
- :help "Continue, evaluating this expression without stopping"))
- (define-key menu-map [deb-step]
- '(menu-item "Step through" debugger-step-through
- :help "Proceed, stepping through subexpressions of this expression"))
+ (easy-menu-define nil map ""
+ '("Debugger"
+ ["Step through" debugger-step-through
+ :help "Proceed, stepping through subexpressions of this expression"]
+ ["Continue" debugger-continue
+ :help "Continue, evaluating this expression without stopping"]
+ ["Jump" debugger-jump
+ :help "Continue to exit from this frame, with all debug-on-entry suspended"]
+ ["Eval Expression..." debugger-eval-expression
+ :help "Eval an expression, in an environment like that outside the debugger"]
+ ["Display and Record Expression" debugger-record-expression
+ :help "Display a variable's value and record it in `*Backtrace-record*' buffer"]
+ ["Return value..." debugger-return-value
+ :help "Continue, specifying value to return."]
+ "--"
+ ["Debug frame" debugger-frame
+ :help "Request entry to debugger when this frame exits"]
+ ["Cancel debug frame" debugger-frame-clear
+ :help "Do not enter debugger when this frame exits"]
+ ["List debug on entry functions" debugger-list-functions
+ :help "Display a list of all the functions now set to debug on entry"]
+ "--"
+ ["Next Line" next-line
+ :help "Move cursor down"]
+ ["Help for Symbol" backtrace-help-follow-symbol
+ :help "Show help for symbol at point"]
+ ["Describe Debugger Mode" describe-mode
+ :help "Display documentation for debugger-mode"]
+ "--"
+ ["Quit" debugger-quit
+ :help "Quit debugging and return to top level"]))
map))
(put 'debugger-mode 'mode-class 'special)
-(define-derived-mode debugger-mode fundamental-mode "Debugger"
- "Mode for backtrace buffers, selected in debugger.
+(define-derived-mode debugger-mode backtrace-mode "Debugger"
+ "Mode for debugging Emacs Lisp using a backtrace.
\\<debugger-mode-map>
A line starts with `*' if exiting that frame will call the debugger.
Type \\[debugger-frame] or \\[debugger-frame-clear] to set or remove the `*'.
@@ -677,8 +597,6 @@ which functions will enter the debugger when called.
Complete list of commands:
\\{debugger-mode-map}"
- (setq truncate-lines t)
- (set-syntax-table emacs-lisp-mode-syntax-table)
(add-hook 'kill-buffer-hook
(lambda () (if (> (recursion-depth) 0) (top-level)))
nil t)
@@ -705,27 +623,6 @@ Complete list of commands:
(buffer-substring (line-beginning-position 0)
(line-end-position 0)))))
-(defun debug-help-follow (&optional pos)
- "Follow cross-reference at POS, defaulting to point.
-
-For the cross-reference format, see `help-make-xrefs'."
- (interactive "d")
- ;; Ideally we'd just do (call-interactively 'help-follow) except that this
- ;; assumes we're already in a *Help* buffer and reuses it, so it ends up
- ;; incorrectly "reusing" the *Backtrace* buffer to show the help info.
- (unless pos
- (setq pos (point)))
- (unless (push-button pos)
- ;; check if the symbol under point is a function or variable
- (let ((sym
- (intern
- (save-excursion
- (goto-char pos) (skip-syntax-backward "w_")
- (buffer-substring (point)
- (progn (skip-syntax-forward "w_")
- (point)))))))
- (when (or (boundp sym) (fboundp sym) (facep sym))
- (describe-symbol sym)))))
;; When you change this, you may also need to change the number of
;; frames that the debugger skips.
@@ -826,6 +723,13 @@ To specify a nil argument interactively, exit with an empty minibuffer."
;;(princ "be set to debug on entry, even if it is in the list.")
)))))
+(defun debugger-quit ()
+ "Quit debugging and return to the top level."
+ (interactive)
+ (if (= (recursion-depth) 0)
+ (quit-window)
+ (top-level)))
+
(defun debug--implement-debug-watch (symbol newval op where)
"Conditionally call the debugger.
This function is called when SYMBOL's value is modified."
diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el
index c6c4430efd3..6db0584b987 100644
--- a/lisp/emacs-lisp/derived.el
+++ b/lisp/emacs-lisp/derived.el
@@ -193,10 +193,10 @@ See Info node `(elisp)Derived Modes' for more details."
;; Process the keyword args.
(while (keywordp (car body))
(pcase (pop body)
- (`:group (setq group (pop body)))
- (`:abbrev-table (setq abbrev (pop body)) (setq declare-abbrev nil))
- (`:syntax-table (setq syntax (pop body)) (setq declare-syntax nil))
- (`:after-hook (setq after-hook (pop body)))
+ (:group (setq group (pop body)))
+ (:abbrev-table (setq abbrev (pop body)) (setq declare-abbrev nil))
+ (:syntax-table (setq syntax (pop body)) (setq declare-syntax nil))
+ (:after-hook (setq after-hook (pop body)))
(_ (pop body))))
(setq docstring (derived-mode-make-docstring
@@ -281,25 +281,10 @@ No problems result if this variable is not bound.
; Splice in the body (if any).
,@body
)
- ;; Run the hooks, if any.
- (run-mode-hooks ',hook)
- ,@(when after-hook
- `((if delay-mode-hooks
- (push (lambda () ,after-hook) delayed-after-hook-functions)
- ,after-hook)))))))
-
-;; PUBLIC: find the ultimate class of a derived mode.
-
-(defun derived-mode-class (mode)
- "Find the class of a major MODE.
-A mode's class is the first ancestor which is NOT a derived mode.
-Use the `derived-mode-parent' property of the symbol to trace backwards.
-Since major-modes might all derive from `fundamental-mode', this function
-is not very useful."
- (declare (obsolete derived-mode-p "22.1"))
- (while (get mode 'derived-mode-parent)
- (setq mode (get mode 'derived-mode-parent)))
- mode)
+ ,@(when after-hook
+ `((push (lambda () ,after-hook) delayed-after-hook-functions)))
+ ;; Run the hooks (and delayed-after-hook-functions), if any.
+ (run-mode-hooks ',hook)))))
;;; PRIVATE
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index 4aa12ceec60..be531aab849 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -81,6 +81,26 @@ replacing its case-insensitive matches with the literal string in LIGHTER."
;; space.)
(replace-regexp-in-string (regexp-quote lighter) lighter name t t))))
+(defconst easy-mmode--arg-docstring
+ "
+
+If called interactively, enable %s if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.")
+
+(defun easy-mmode--mode-docstring (doc mode-pretty-name keymap-sym)
+ (let ((doc (or doc (format "Toggle %s on or off.
+
+\\{%s}" mode-pretty-name keymap-sym))))
+ (if (string-match-p "\\bARG\\b" doc)
+ doc
+ (let ((argdoc (format easy-mmode--arg-docstring
+ mode-pretty-name)))
+ (replace-regexp-in-string "\\(\n\n\\|\\'\\)\\(.\\|\n\\)*\\'"
+ (concat argdoc "\\1")
+ doc nil nil 1)))))
+
;;;###autoload
(defalias 'easy-mmode-define-minor-mode 'define-minor-mode)
;;;###autoload
@@ -101,7 +121,9 @@ non-positive integer, and enables the mode otherwise (including
if the argument is omitted or nil or a positive integer).
If DOC is nil, give the mode command a basic doc-string
-documenting what its argument does.
+documenting what its argument does. If the word \"ARG\" does not
+appear in DOC, a paragraph is added to DOC explaining
+usage of the mode argument.
Optional INIT-VALUE is the initial value of the mode's variable.
Optional LIGHTER is displayed in the mode line when the mode is on.
@@ -195,30 +217,30 @@ For example, you could write
(while (keywordp (setq keyw (car body)))
(setq body (cdr body))
(pcase keyw
- (`:init-value (setq init-value (pop body)))
- (`:lighter (setq lighter (purecopy (pop body))))
- (`:global (setq globalp (pop body))
- (when (and globalp (symbolp mode))
- (setq setter `(setq-default ,mode))
- (setq getter `(default-value ',mode))))
- (`:extra-args (setq extra-args (pop body)))
- (`:set (setq set (list :set (pop body))))
- (`:initialize (setq initialize (list :initialize (pop body))))
- (`:group (setq group (nconc group (list :group (pop body)))))
- (`:type (setq type (list :type (pop body))))
- (`:require (setq require (pop body)))
- (`:keymap (setq keymap (pop body)))
- (`:variable (setq variable (pop body))
- (if (not (and (setq tmp (cdr-safe variable))
- (or (symbolp tmp)
- (functionp tmp))))
- ;; PLACE is not of the form (GET . SET).
- (progn
- (setq setter `(setf ,variable))
- (setq getter variable))
- (setq getter (car variable))
- (setq setter `(funcall #',(cdr variable)))))
- (`:after-hook (setq after-hook (pop body)))
+ (:init-value (setq init-value (pop body)))
+ (:lighter (setq lighter (purecopy (pop body))))
+ (:global (setq globalp (pop body))
+ (when (and globalp (symbolp mode))
+ (setq setter `(setq-default ,mode))
+ (setq getter `(default-value ',mode))))
+ (:extra-args (setq extra-args (pop body)))
+ (:set (setq set (list :set (pop body))))
+ (:initialize (setq initialize (list :initialize (pop body))))
+ (:group (setq group (nconc group (list :group (pop body)))))
+ (:type (setq type (list :type (pop body))))
+ (:require (setq require (pop body)))
+ (:keymap (setq keymap (pop body)))
+ (:variable (setq variable (pop body))
+ (if (not (and (setq tmp (cdr-safe variable))
+ (or (symbolp tmp)
+ (functionp tmp))))
+ ;; PLACE is not of the form (GET . SET).
+ (progn
+ (setq setter `(setf ,variable))
+ (setq getter variable))
+ (setq getter (car variable))
+ (setq setter `(funcall #',(cdr variable)))))
+ (:after-hook (setq after-hook (pop body)))
(_ (push keyw extra-keywords) (push (pop body) extra-keywords))))
(setq keymap-sym (if (and keymap (symbolp keymap)) keymap
@@ -270,12 +292,7 @@ or call the function `%s'."))))
;; The actual function.
(defun ,modefun (&optional arg ,@extra-args)
- ,(or doc
- (format (concat "Toggle %s on or off.
-With a prefix argument ARG, enable %s if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'.
-\\{%s}") pretty-name pretty-name keymap-sym))
+ ,(easy-mmode--mode-docstring doc pretty-name keymap-sym)
;; Use `toggle' rather than (if ,mode 0 1) so that using
;; repeat-command still does the toggling correctly.
(interactive (list (or current-prefix-arg 'toggle)))
@@ -390,16 +407,10 @@ on if the hook has explicitly disabled it."
(while (keywordp (setq keyw (car keys)))
(setq keys (cdr keys))
(pcase keyw
- (`:group (setq group (nconc group (list :group (pop keys)))))
- (`:global (setq keys (cdr keys)))
+ (:group (setq group (nconc group (list :group (pop keys)))))
+ (:global (setq keys (cdr keys)))
(_ (push keyw extra-keywords) (push (pop keys) extra-keywords))))
- (unless group
- ;; We might as well provide a best-guess default group.
- (setq group
- `(:group ',(intern (replace-regexp-in-string
- "-mode\\'" "" (symbol-name mode))))))
-
`(progn
(progn
:autoload-end
@@ -516,11 +527,11 @@ Valid keywords and arguments are:
(let ((key (pop args))
(val (pop args)))
(pcase key
- (`:name (setq name val))
- (`:dense (setq dense val))
- (`:inherit (setq inherit val))
- (`:suppress (setq suppress val))
- (`:group)
+ (:name (setq name val))
+ (:dense (setq dense val))
+ (:inherit (setq inherit val))
+ (:suppress (setq suppress val))
+ (:group)
(_ (message "Unknown argument %s in defmap" key)))))
(unless (keymapp m)
(setq bs (append m bs))
@@ -549,6 +560,7 @@ Valid keywords and arguments are:
"Define a constant M whose value is the result of `easy-mmode-define-keymap'.
The M, BS, and ARGS arguments are as per that function. DOC is
the constant's documentation."
+ (declare (indent 1))
`(defconst ,m
(easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args))
,doc))
@@ -575,6 +587,7 @@ the constant's documentation."
(defmacro easy-mmode-defsyntax (st css doc &rest args)
"Define variable ST as a syntax-table.
CSS contains a list of syntax specifications of the form (CHAR . SYNTAX)."
+ (declare (indent 1))
`(progn
(autoload 'easy-mmode-define-syntax "easy-mmode")
(defconst ,st (easy-mmode-define-syntax ,css ,(cons 'list args)) ,doc)))
@@ -605,15 +618,15 @@ BODY is executed after moving to the destination location."
(when-narrowed
(lambda (body)
(if (null narrowfun) body
- `(let ((was-narrowed
- (prog1 (or (< (- (point-max) (point-min)) (buffer-size)))
- (widen))))
+ `(let ((was-narrowed (prog1 (buffer-narrowed-p) (widen))))
,body
(when was-narrowed (funcall #',narrowfun)))))))
(unless name (setq name base-name))
+ ;; FIXME: Move most of those functions's bodies to helper functions!
`(progn
(defun ,next-sym (&optional count)
- ,(format "Go to the next COUNT'th %s." name)
+ ,(format "Go to the next COUNT'th %s.
+Interactively, COUNT is the prefix numeric argument, and defaults to 1." name)
(interactive "p")
(unless count (setq count 1))
(if (< count 0) (,prev-sym (- count))
@@ -631,11 +644,17 @@ BODY is executed after moving to the destination location."
`(re-search-forward ,re nil t 2)))
(point-max))))
(unless (pos-visible-in-window-p endpt nil t)
- (recenter '(0)))))))
+ (let ((ws (window-start)))
+ (recenter '(0))
+ (if (< (window-start) ws)
+ ;; recenter scrolled in the wrong direction!
+ (set-window-start nil ws))))))))
,@body))
(put ',next-sym 'definition-name ',base)
(defun ,prev-sym (&optional count)
- ,(format "Go to the previous COUNT'th %s" (or name base-name))
+ ,(format "Go to the previous COUNT'th %s.
+Interactively, COUNT is the prefix numeric argument, and defaults to 1."
+ (or name base-name))
(interactive "p")
(unless count (setq count 1))
(if (< count 0) (,next-sym (- count))
diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el
index 255a0436203..5bf046d41db 100644
--- a/lisp/emacs-lisp/easymenu.el
+++ b/lisp/emacs-lisp/easymenu.el
@@ -226,14 +226,14 @@ possibly preceded by keyword pairs as described in `easy-menu-define'."
(let ((arg (cadr menu-items)))
(setq menu-items (cddr menu-items))
(pcase keyword
- (`:filter
+ (:filter
(setq filter (lambda (menu)
(easy-menu-filter-return (funcall arg menu)
menu-name))))
- ((or `:enable `:active) (setq enable (or arg ''nil)))
- (`:label (setq label arg))
- (`:help (setq help arg))
- ((or `:included `:visible) (setq visible (or arg ''nil))))))
+ ((or :enable :active) (setq enable (or arg ''nil)))
+ (:label (setq label arg))
+ (:help (setq help arg))
+ ((or :included :visible) (setq visible (or arg ''nil))))))
(if (equal visible ''nil)
nil ; Invisible menu entry, return nil.
(if (and visible (not (easy-menu-always-true-p visible)))
@@ -325,15 +325,15 @@ ITEM defines an item as in `easy-menu-define'."
(setq arg (aref item (1+ count)))
(setq count (+ 2 count))
(pcase keyword
- ((or `:included `:visible) (setq visible (or arg ''nil)))
- (`:key-sequence (setq cache arg cache-specified t))
- (`:keys (setq keys arg no-name nil))
- (`:label (setq label arg))
- ((or `:active `:enable) (setq active (or arg ''nil)))
- (`:help (setq prop (cons :help (cons arg prop))))
- (`:suffix (setq suffix arg))
- (`:style (setq style arg))
- (`:selected (setq selected (or arg ''nil)))))
+ ((or :included :visible) (setq visible (or arg ''nil)))
+ (:key-sequence (setq cache arg cache-specified t))
+ (:keys (setq keys arg no-name nil))
+ (:label (setq label arg))
+ ((or :active :enable) (setq active (or arg ''nil)))
+ (:help (setq prop (cons :help (cons arg prop))))
+ (:suffix (setq suffix arg))
+ (:style (setq style arg))
+ (:selected (setq selected (or arg ''nil)))))
(if suffix
(setq label
(if (stringp suffix)
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 144bd3286ba..6dfcc24493d 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -52,6 +52,7 @@
;;; Code:
+(require 'backtrace)
(require 'macroexp)
(require 'cl-lib)
(eval-when-compile (require 'pcase))
@@ -206,8 +207,7 @@ Use this with caution since it is not debugged."
"Non-nil if Edebug should unwrap results of expressions.
That is, Edebug will try to remove its own instrumentation from the result.
This is useful when debugging macros where the results of expressions
-are instrumented expressions. But don't do this when results might be
-circular or an infinite loop will result."
+are instrumented expressions."
:type 'boolean
:group 'edebug)
@@ -373,6 +373,8 @@ Return the result of the last expression in BODY."
(t (split-window (minibuffer-selected-window)))))
(set-window-buffer window buffer)
(select-window window)
+ (unless (memq (framep (selected-frame)) '(nil t pc))
+ (x-focus-frame (selected-frame)))
(set-window-hscroll window 0)) ;; should this be??
(defun edebug-get-displayed-buffer-points ()
@@ -894,8 +896,7 @@ circular objects. Let `read' read everything else."
(while (and (>= (following-char) ?0) (<= (following-char) ?9))
(forward-char 1))
(let ((n (string-to-number (buffer-substring start (point)))))
- (when (and read-circle
- (<= n most-positive-fixnum))
+ (when read-circle
(cond
((eq ?= (following-char))
;; Make a placeholder for #n# to use temporarily.
@@ -910,7 +911,7 @@ circular objects. Let `read' read everything else."
(throw 'return (setf (cdr elem) obj)))))
((eq ?# (following-char))
;; #n# returns a previously read object.
- (let ((elem (assq n edebug-read-objects)))
+ (let ((elem (assoc n edebug-read-objects)))
(when (consp elem)
(forward-char 1)
(throw 'return (cdr elem))))))))))
@@ -1066,6 +1067,32 @@ circular objects. Let `read' read everything else."
(defvar edebug-error-point nil)
(defvar edebug-best-error nil)
+;; Functions which may be used to extend Edebug's functionality. See
+;; Testcover for an example.
+(defvar edebug-after-instrumentation-function #'identity
+ "Function to run on code after instrumentation for debugging.
+The function is called with one argument, a FORM which has just
+been instrumented for Edebugging, and it should return either FORM
+or a replacement form to use in its place.")
+
+(defvar edebug-new-definition-function #'edebug-new-definition
+ "Function to call after Edebug wraps a new definition.
+After Edebug has initialized its own data, this function is
+called with one argument, the symbol associated with the
+definition, which may be the actual symbol defined or one
+generated by Edebug.")
+
+(defvar edebug-behavior-alist
+ '((edebug edebug-default-enter edebug-slow-before edebug-slow-after))
+ "Alist describing the runtime behavior of Edebug's instrumented code.
+Each definition instrumented by Edebug will have a
+`edebug-behavior' property which is a key to this alist. When
+the instrumented code is running, Edebug will look here for the
+implementations of `edebug-enter', `edebug-before', and
+`edebug-after'. Edebug's instrumentation may be used for a new
+purpose by adding an entry to this alist, and setting
+`edebug-new-definition-function' to a function which sets
+`edebug-behavior' for the definition.")
(defun edebug-read-and-maybe-wrap-form ()
;; Read a form and wrap it with edebug calls, if the conditions are right.
@@ -1125,53 +1152,55 @@ circular objects. Let `read' read everything else."
(eq 'symbol (edebug-next-token-class)))
(read (current-buffer))))))
;;;(message "all defs: %s all forms: %s" edebug-all-defs edebug-all-forms)
- (cond
- (defining-form-p
- (if (or edebug-all-defs edebug-all-forms)
- ;; If it is a defining form and we are edebugging defs,
- ;; then let edebug-list-form start it.
- (let ((cursor (edebug-new-cursor
- (list (edebug-read-storing-offsets (current-buffer)))
- (list edebug-offsets))))
- (car
- (edebug-make-form-wrapper
- cursor
- (edebug-before-offset cursor)
- (1- (edebug-after-offset cursor))
- (list (cons (symbol-name def-kind) (cdr spec))))))
-
- ;; Not edebugging this form, so reset the symbol's edebug
- ;; property to be just a marker at the definition's source code.
- ;; This only works for defs with simple names.
- (put def-name 'edebug (point-marker))
- ;; Also nil out dependent defs.
- '(mapcar (function
- (lambda (def)
- (put def-name 'edebug nil)))
- (get def-name 'edebug-dependents))
- (edebug-read-sexp)))
-
- ;; If all forms are being edebugged, explicitly wrap it.
- (edebug-all-forms
- (let ((cursor (edebug-new-cursor
- (list (edebug-read-storing-offsets (current-buffer)))
- (list edebug-offsets))))
- (edebug-make-form-wrapper
- cursor
- (edebug-before-offset cursor)
- (edebug-after-offset cursor)
- nil)))
-
- ;; Not a defining form, and not edebugging.
- (t (edebug-read-sexp)))
- ))
-
+ (let ((result
+ (cond
+ (defining-form-p
+ (if (or edebug-all-defs edebug-all-forms)
+ ;; If it is a defining form and we are edebugging defs,
+ ;; then let edebug-list-form start it.
+ (let ((cursor (edebug-new-cursor
+ (list (edebug-read-storing-offsets (current-buffer)))
+ (list edebug-offsets))))
+ (car
+ (edebug-make-form-wrapper
+ cursor
+ (edebug-before-offset cursor)
+ (1- (edebug-after-offset cursor))
+ (list (cons (symbol-name def-kind) (cdr spec))))))
+
+ ;; Not edebugging this form, so reset the symbol's edebug
+ ;; property to be just a marker at the definition's source code.
+ ;; This only works for defs with simple names.
+ (put def-name 'edebug (point-marker))
+ ;; Also nil out dependent defs.
+ '(mapcar (function
+ (lambda (def)
+ (put def-name 'edebug nil)))
+ (get def-name 'edebug-dependents))
+ (edebug-read-sexp)))
+
+ ;; If all forms are being edebugged, explicitly wrap it.
+ (edebug-all-forms
+ (let ((cursor (edebug-new-cursor
+ (list (edebug-read-storing-offsets (current-buffer)))
+ (list edebug-offsets))))
+ (edebug-make-form-wrapper
+ cursor
+ (edebug-before-offset cursor)
+ (edebug-after-offset cursor)
+ nil)))
+
+ ;; Not a defining form, and not edebugging.
+ (t (edebug-read-sexp)))))
+ (funcall edebug-after-instrumentation-function result))))
(defvar edebug-def-args) ; args of defining form.
(defvar edebug-def-interactive) ; is it an emacs interactive function?
(defvar edebug-inside-func) ;; whether code is inside function context.
;; Currently def-form sets this to nil; def-body sets it to t.
+(defvar edebug--cl-macrolet-defs) ;; Fully defined below.
+
(defun edebug-interactive-p-name ()
;; Return a unique symbol for the variable used to store the
;; status of interactive-p for this function.
@@ -1237,25 +1266,59 @@ circular objects. Let `read' read everything else."
(defun edebug-unwrap (sexp)
"Return the unwrapped SEXP or return it as is if it is not wrapped.
The SEXP might be the result of wrapping a body, which is a list of
-expressions; a `progn' form will be returned enclosing these forms."
- (if (consp sexp)
- (cond
- ((eq 'edebug-after (car sexp))
- (nth 3 sexp))
- ((eq 'edebug-enter (car sexp))
- (macroexp-progn (nthcdr 2 (nth 1 (nth 3 sexp)))))
- (t sexp);; otherwise it is not wrapped, so just return it.
- )
- sexp))
+expressions; a `progn' form will be returned enclosing these forms.
+Does not unwrap inside vectors, records, structures, or hash tables."
+ (pcase sexp
+ (`(edebug-after ,_before-form ,_after-index ,form)
+ form)
+ (`(lambda ,args (edebug-enter ',_sym ,_arglist
+ (function (lambda nil . ,body))))
+ `(lambda ,args ,@body))
+ (`(closure ,env ,args (edebug-enter ',_sym ,_arglist
+ (function (lambda nil . ,body))))
+ `(closure ,env ,args ,@body))
+ (`(edebug-enter ',_sym ,_args (function (lambda nil . ,body)))
+ (macroexp-progn body))
+ (_ sexp)))
(defun edebug-unwrap* (sexp)
"Return the SEXP recursively unwrapped."
+ (let ((ht (make-hash-table :test 'eq)))
+ (edebug--unwrap1 sexp ht)))
+
+(defun edebug--unwrap1 (sexp hash-table)
+ "Unwrap SEXP using HASH-TABLE of things already unwrapped.
+HASH-TABLE contains the results of unwrapping cons cells within
+SEXP, which are reused to avoid infinite loops when SEXP is or
+contains a circular object."
(let ((new-sexp (edebug-unwrap sexp)))
(while (not (eq sexp new-sexp))
(setq sexp new-sexp
new-sexp (edebug-unwrap sexp)))
(if (consp new-sexp)
- (mapcar #'edebug-unwrap* new-sexp)
+ (let ((result (gethash new-sexp hash-table nil)))
+ (unless result
+ (let ((remainder new-sexp)
+ current)
+ (setq result (cons nil nil)
+ current result)
+ (while
+ (progn
+ (puthash remainder current hash-table)
+ (setf (car current)
+ (edebug--unwrap1 (car remainder) hash-table))
+ (setq remainder (cdr remainder))
+ (cond
+ ((atom remainder)
+ (setf (cdr current)
+ (edebug--unwrap1 remainder hash-table))
+ nil)
+ ((gethash remainder hash-table nil)
+ (setf (cdr current) (gethash remainder hash-table nil))
+ nil)
+ (t (setq current
+ (setf (cdr current) (cons nil nil)))))))))
+ result)
new-sexp)))
@@ -1333,7 +1396,6 @@ expressions; a `progn' form will be returned enclosing these forms."
;; (message "defining: %s" edebug-def-name) (sit-for 2)
(edebug-make-top-form-data-entry form-data-entry)
- (message "Edebug: %s" edebug-def-name)
;;(debug edebug-def-name)
;; Destructively reverse edebug-offset-list and make vector from it.
@@ -1359,9 +1421,16 @@ expressions; a `progn' form will be returned enclosing these forms."
edebug-offset-list
edebug-top-window-data
))
+
+ (funcall edebug-new-definition-function edebug-def-name)
result
)))
+(defun edebug-new-definition (def-name)
+ "Set up DEF-NAME to use Edebug's instrumentation functions."
+ (put def-name 'edebug-behavior 'edebug)
+ (message "Edebug: %s" def-name))
+
(defun edebug-clear-frequency-count (name)
;; Create initial frequency count vector.
@@ -1431,6 +1500,11 @@ expressions; a `progn' form will be returned enclosing these forms."
;; Helper for edebug-list-form
(let ((spec (get-edebug-spec head)))
(cond
+ ;; Treat cl-macrolet bindings like macros with no spec.
+ ((member head edebug--cl-macrolet-defs)
+ (if edebug-eval-macro-args
+ (edebug-forms cursor)
+ (edebug-sexps cursor)))
(spec
(cond
((consp spec)
@@ -1619,6 +1693,9 @@ expressions; a `progn' form will be returned enclosing these forms."
;; (function . edebug-match-function)
(lambda-expr . edebug-match-lambda-expr)
(cl-generic-method-args . edebug-match-cl-generic-method-args)
+ (cl-macrolet-expr . edebug-match-cl-macrolet-expr)
+ (cl-macrolet-name . edebug-match-cl-macrolet-name)
+ (cl-macrolet-body . edebug-match-cl-macrolet-body)
(&not . edebug-match-&not)
(&key . edebug-match-&key)
(place . edebug-match-place)
@@ -1922,6 +1999,43 @@ expressions; a `progn' form will be returned enclosing these forms."
(edebug-move-cursor cursor)
(list args)))
+(defvar edebug--cl-macrolet-defs nil
+ "List of symbols found within the bindings of enclosing `cl-macrolet' forms.")
+(defvar edebug--current-cl-macrolet-defs nil
+ "List of symbols found within the bindings of the current `cl-macrolet' form.")
+
+(defun edebug-match-cl-macrolet-expr (cursor)
+ "Match a `cl-macrolet' form at CURSOR."
+ (let (edebug--current-cl-macrolet-defs)
+ (edebug-match cursor
+ '((&rest (&define cl-macrolet-name cl-macro-list
+ cl-declarations-or-string
+ def-body))
+ cl-declarations cl-macrolet-body))))
+
+(defun edebug-match-cl-macrolet-name (cursor)
+ "Match the name in a `cl-macrolet' binding at CURSOR.
+Collect the names in `edebug--cl-macrolet-defs' where they
+will be checked by `edebug-list-form-args' and treated as
+macros without a spec."
+ (let ((name (edebug-top-element-required cursor "Expected name")))
+ (when (not (symbolp name))
+ (edebug-no-match cursor "Bad name:" name))
+ ;; Change edebug-def-name to avoid conflicts with
+ ;; names at global scope.
+ (setq edebug-def-name (gensym "edebug-anon"))
+ (edebug-move-cursor cursor)
+ (push name edebug--current-cl-macrolet-defs)
+ (list name)))
+
+(defun edebug-match-cl-macrolet-body (cursor)
+ "Match the body of a `cl-macrolet' expression at CURSOR.
+Put the definitions collected in `edebug--current-cl-macrolet-defs'
+into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'."
+ (let ((edebug--cl-macrolet-defs (nconc edebug--current-cl-macrolet-defs
+ edebug--cl-macrolet-defs)))
+ (edebug-match-body cursor)))
+
(defun edebug-match-arg (cursor)
;; set the def-args bound in edebug-defining-form
(let ((edebug-arg (edebug-top-element-required cursor "Expected arg")))
@@ -2051,7 +2165,6 @@ expressions; a `progn' form will be returned enclosing these forms."
(def-edebug-spec let* let)
(def-edebug-spec setq (&rest symbolp form))
-(def-edebug-spec setq-default setq)
(def-edebug-spec cond (&rest (&rest form)))
@@ -2181,7 +2294,21 @@ error is signaled again."
;;; Entering Edebug
-(defun edebug-enter (function args body)
+(defun edebug-enter (func args body)
+ "Enter Edebug for a function.
+FUNC should be the symbol with the Edebug information, ARGS is
+the list of arguments and BODY is the code.
+
+Look up the `edebug-behavior' for FUNC in `edebug-behavior-alist'
+and run its entry function, and set up `edebug-before' and
+`edebug-after'."
+ (cl-letf* ((behavior (get func 'edebug-behavior))
+ (functions (cdr (assoc behavior edebug-behavior-alist)))
+ ((symbol-function #'edebug-before) (nth 1 functions))
+ ((symbol-function #'edebug-after) (nth 2 functions)))
+ (funcall (nth 0 functions) func args body)))
+
+(defun edebug-default-enter (function args body)
;; Entering FUNC. The arguments are ARGS, and the body is BODY.
;; Setup edebug variables and evaluate BODY. This function is called
;; when a function evaluated with edebug-eval-top-level-form is entered.
@@ -2202,6 +2329,7 @@ error is signaled again."
(debugger edebug-debugger) ; only while edebug is active.
(edebug-outside-debug-on-error debug-on-error)
(edebug-outside-debug-on-quit debug-on-quit)
+ (outside-frame (selected-frame))
;; Binding these may not be the right thing to do.
;; We want to allow the global values to be changed.
(debug-on-error (or debug-on-error edebug-on-error))
@@ -2212,7 +2340,10 @@ error is signaled again."
edebug-initial-mode
edebug-execution-mode)
edebug-next-execution-mode nil)
- (edebug-enter function args body))))
+ (edebug-default-enter function args body))
+ (if (and (frame-live-p outside-frame)
+ (not (memq (framep outside-frame) '(nil t pc))))
+ (x-focus-frame outside-frame))))
(let* ((edebug-data (get function 'edebug))
(edebug-def-mark (car edebug-data)) ; mark at def start
@@ -2331,22 +2462,27 @@ MSG is printed after `::::} '."
value
(edebug-debugger after-index 'after value)
)))
-
(defun edebug-fast-after (_before-index _after-index value)
;; Do nothing but return the value.
value)
(defun edebug-run-slow ()
- (defalias 'edebug-before 'edebug-slow-before)
- (defalias 'edebug-after 'edebug-slow-after))
+ "Set up Edebug's normal behavior."
+ (setf (cdr (assq 'edebug edebug-behavior-alist))
+ '(edebug-default-enter edebug-slow-before edebug-slow-after)))
;; This is not used, yet.
(defun edebug-run-fast ()
- (defalias 'edebug-before 'edebug-fast-before)
- (defalias 'edebug-after 'edebug-fast-after))
-
-(edebug-run-slow)
+ "Disable Edebug without de-instrumenting code."
+ (setf (cdr (assq 'edebug edebug-behavior-alist))
+ '(edebug-default-enter edebug-fast-before edebug-fast-after)))
+(defalias 'edebug-before nil
+ "Function called by Edebug before a form is evaluated.
+See `edebug-behavior-alist' for implementations.")
+(defalias 'edebug-after nil
+ "Function called by Edebug after a form is evaluated.
+See `edebug-behavior-alist' for implementations.")
(defun edebug--update-coverage (after-index value)
(let ((old-result (aref edebug-coverage after-index)))
@@ -2516,6 +2652,8 @@ MSG is printed after `::::} '."
(edebug-eval-display eval-result-list)
;; The evaluation list better not have deleted edebug-window-data.
(select-window (car edebug-window-data))
+ (if (not (memq (framep (selected-frame)) '(nil t pc)))
+ (x-focus-frame (selected-frame)))
(set-buffer edebug-buffer)
(setq edebug-buffer-outside-point (point))
@@ -3463,9 +3601,7 @@ Return the result of the last expression."
"Evaluate an expression in the outside environment.
If interactive, prompt for the expression.
Print result in minibuffer."
- (interactive (list (read-from-minibuffer
- "Eval: " nil read-expression-map t
- 'read-expression-history)))
+ (interactive (list (read--expression "Eval: ")))
(princ
(edebug-outside-excursion
(setq values (cons (edebug-eval expr) values))
@@ -3495,14 +3631,14 @@ This prints the value into current buffer."
;;; Edebug Minor Mode
+(define-obsolete-variable-alias 'gud-inhibit-global-bindings
+ 'edebug-inhibit-emacs-lisp-mode-bindings "24.3")
+
(defvar edebug-inhibit-emacs-lisp-mode-bindings nil
"If non-nil, inhibit Edebug bindings on the C-x C-a key.
By default, loading the `edebug' library causes these bindings to
be installed in `emacs-lisp-mode-map'.")
-(define-obsolete-variable-alias 'gud-inhibit-global-bindings
- 'edebug-inhibit-emacs-lisp-mode-bindings "24.3")
-
;; Global GUD bindings for all emacs-lisp-mode buffers.
(unless edebug-inhibit-emacs-lisp-mode-bindings
(define-key emacs-lisp-mode-map "\C-x\C-a\C-s" 'edebug-step-mode)
@@ -3560,7 +3696,7 @@ be installed in `emacs-lisp-mode-map'.")
;; misc
(define-key map "?" 'edebug-help)
- (define-key map "d" 'edebug-backtrace)
+ (define-key map "d" 'edebug-pop-to-backtrace)
(define-key map "-" 'negative-argument)
@@ -3818,8 +3954,10 @@ Global commands prefixed by `global-edebug-prefix':
;; (setq debugger 'debug) ; use the standard debugger
;; Note that debug and its utilities must be byte-compiled to work,
-;; since they depend on the backtrace looking a certain way. But
-;; edebug is not dependent on this, yet.
+;; since they depend on the backtrace looking a certain way. Edebug
+;; will work if not byte-compiled, but it will not be able correctly
+;; remove its instrumentation from backtraces unless it is
+;; byte-compiled.
(defun edebug (&optional arg-mode &rest args)
"Replacement for `debug'.
@@ -3849,49 +3987,136 @@ Otherwise call `debug' normally."
(apply #'debug arg-mode args)
))
-
-(defun edebug-backtrace ()
- "Display a non-working backtrace. Better than nothing..."
+;;; Backtrace buffer
+
+(defvar-local edebug-backtrace-frames nil
+ "Stack frames of the current Edebug Backtrace buffer without instrumentation.
+This should be a list of `edebug---frame' objects.")
+(defvar-local edebug-instrumented-backtrace-frames nil
+ "Stack frames of the current Edebug Backtrace buffer with instrumentation.
+This should be a list of `edebug---frame' objects.")
+
+;; Data structure for backtrace frames with information
+;; from Edebug instrumentation found in the backtrace.
+(cl-defstruct
+ (edebug--frame
+ (:constructor edebug--make-frame)
+ (:include backtrace-frame))
+ def-name before-index after-index)
+
+(defun edebug-pop-to-backtrace ()
+ "Display the current backtrace in a `backtrace-mode' window."
(interactive)
(if (or (not edebug-backtrace-buffer)
(null (buffer-name edebug-backtrace-buffer)))
(setq edebug-backtrace-buffer
- (generate-new-buffer "*Backtrace*"))
+ (generate-new-buffer "*Edebug Backtrace*"))
;; Else, could just display edebug-backtrace-buffer.
)
- (with-output-to-temp-buffer (buffer-name edebug-backtrace-buffer)
- (setq edebug-backtrace-buffer standard-output)
- (let ((print-escape-newlines t)
- (print-length 50) ; FIXME cf edebug-safe-prin1-to-string
- last-ok-point)
- (backtrace)
-
- ;; Clean up the backtrace.
- ;; Not quite right for current edebug scheme.
- (set-buffer edebug-backtrace-buffer)
- (setq truncate-lines t)
- (goto-char (point-min))
- (setq last-ok-point (point))
- (if t (progn
-
- ;; Delete interspersed edebug internals.
- (while (re-search-forward "^ (?edebug" nil t)
- (beginning-of-line)
- (cond
- ((looking-at "^ (edebug-after")
- ;; Previous lines may contain code, so just delete this line.
- (setq last-ok-point (point))
- (forward-line 1)
- (delete-region last-ok-point (point)))
-
- ((looking-at (if debugger-stack-frame-as-list
- "^ (edebug"
- "^ edebug"))
- (forward-line 1)
- (delete-region last-ok-point (point))
- )))
- )))))
+ (pop-to-buffer edebug-backtrace-buffer)
+ (unless (derived-mode-p 'backtrace-mode)
+ (backtrace-mode)
+ (add-hook 'backtrace-goto-source-functions 'edebug--backtrace-goto-source))
+ (setq edebug-instrumented-backtrace-frames
+ (backtrace-get-frames 'edebug-debugger
+ :constructor #'edebug--make-frame)
+ edebug-backtrace-frames (edebug--strip-instrumentation
+ edebug-instrumented-backtrace-frames)
+ backtrace-frames edebug-backtrace-frames)
+ (backtrace-print)
+ (goto-char (point-min)))
+
+(defun edebug--strip-instrumentation (frames)
+ "Return a new list of backtrace frames with instrumentation removed.
+Remove frames for Edebug's functions and the lambdas in
+`edebug-enter' wrappers. Fill in the def-name, before-index
+and after-index fields in both FRAMES and the returned list
+of deinstrumented frames, for those frames where the source
+code location is known."
+ (let (skip-next-lambda def-name before-index after-index results
+ (index (length frames)))
+ (dolist (frame (reverse frames))
+ (let ((new-frame (copy-edebug--frame frame))
+ (fun (edebug--frame-fun frame))
+ (args (edebug--frame-args frame)))
+ (cl-decf index)
+ (pcase fun
+ ('edebug-enter
+ (setq skip-next-lambda t
+ def-name (nth 0 args)))
+ ('edebug-after
+ (setq before-index (if (consp (nth 0 args))
+ (nth 1 (nth 0 args))
+ (nth 0 args))
+ after-index (nth 1 args)))
+ ((pred edebug--symbol-not-prefixed-p)
+ (edebug--unwrap-frame new-frame)
+ (edebug--add-source-info new-frame def-name before-index after-index)
+ (edebug--add-source-info frame def-name before-index after-index)
+ (push new-frame results)
+ (setq before-index nil
+ after-index nil))
+ (`(,(or 'lambda 'closure) . ,_)
+ (unless skip-next-lambda
+ (edebug--unwrap-frame new-frame)
+ (edebug--add-source-info frame def-name before-index after-index)
+ (edebug--add-source-info new-frame def-name before-index after-index)
+ (push new-frame results))
+ (setq before-index nil
+ after-index nil
+ skip-next-lambda nil)))))
+ results))
+
+(defun edebug--symbol-not-prefixed-p (sym)
+ "Return non-nil if SYM is a symbol not prefixed by \"edebug-\"."
+ (and (symbolp sym)
+ (not (string-prefix-p "edebug-" (symbol-name sym)))))
+
+(defun edebug--unwrap-frame (frame)
+ "Remove Edebug's instrumentation from FRAME.
+Strip it from the function and any unevaluated arguments."
+ (setf (edebug--frame-fun frame) (edebug-unwrap* (edebug--frame-fun frame)))
+ (unless (edebug--frame-evald frame)
+ (let (results)
+ (dolist (arg (edebug--frame-args frame))
+ (push (edebug-unwrap* arg) results))
+ (setf (edebug--frame-args frame) (nreverse results)))))
+
+(defun edebug--add-source-info (frame def-name before-index after-index)
+ "Update FRAME with the additional info needed by an edebug--frame.
+Save DEF-NAME, BEFORE-INDEX and AFTER-INDEX in FRAME."
+ (when (and before-index def-name)
+ (setf (edebug--frame-flags frame)
+ (plist-put (copy-sequence (edebug--frame-flags frame))
+ :source-available t)))
+ (setf (edebug--frame-def-name frame) (and before-index def-name))
+ (setf (edebug--frame-before-index frame) before-index)
+ (setf (edebug--frame-after-index frame) after-index))
+
+(defun edebug--backtrace-goto-source ()
+ (let* ((index (backtrace-get-index))
+ (frame (nth index backtrace-frames)))
+ (when (edebug--frame-def-name frame)
+ (let* ((data (get (edebug--frame-def-name frame) 'edebug))
+ (marker (nth 0 data))
+ (offsets (nth 2 data)))
+ (pop-to-buffer (marker-buffer marker))
+ (goto-char (+ (marker-position marker)
+ (aref offsets (edebug--frame-before-index frame))))))))
+
+(defun edebug-backtrace-show-instrumentation ()
+ "Show Edebug's instrumentation in an Edebug Backtrace buffer."
+ (interactive)
+ (unless (eq backtrace-frames edebug-instrumented-backtrace-frames)
+ (setq backtrace-frames edebug-instrumented-backtrace-frames)
+ (revert-buffer)))
+(defun edebug-backtrace-hide-instrumentation ()
+ "Hide Edebug's instrumentation in an Edebug Backtrace buffer."
+ (interactive)
+ (unless (eq backtrace-frames edebug-backtrace-frames)
+ (setq backtrace-frames edebug-backtrace-frames)
+ (revert-buffer)))
;;; Trace display
@@ -4065,7 +4290,7 @@ It is removed when you hit any char."
["Bounce to Current Point" edebug-bounce-point t]
["View Outside Windows" edebug-view-outside t]
["Previous Result" edebug-previous-result t]
- ["Show Backtrace" edebug-backtrace t]
+ ["Show Backtrace" edebug-pop-to-backtrace t]
["Display Freq Count" edebug-display-freq-count t])
("Eval"
diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
index 7a9f905c6fe..3a0109877e7 100644
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -498,7 +498,7 @@ instance."
(cl-defmethod eieio-object-name-string ((obj eieio-named))
"Return a string which is OBJ's name."
(or (slot-value obj 'object-name)
- (symbol-name (eieio-object-class obj))))
+ (cl-call-next-method)))
(cl-defmethod eieio-object-set-name-string ((obj eieio-named) name)
"Set the string which is OBJ's NAME."
diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el
index 6d70e03381a..ea5a2839691 100644
--- a/lisp/emacs-lisp/eieio-compat.el
+++ b/lisp/emacs-lisp/eieio-compat.el
@@ -182,11 +182,11 @@ Summary:
;; `no-applicable-method', which have slightly different calling
;; convention than their cl-generic counterpart.
(pcase method
- (`no-next-method
+ ('no-next-method
(setq method 'cl-no-next-method)
(setq specializers `(generic method ,@specializers))
(lambda (_generic _method &rest args) (apply code args)))
- (`no-applicable-method
+ ('no-applicable-method
(setq method 'cl-no-applicable-method)
(setq specializers `(generic ,@specializers))
(lambda (generic arg &rest args)
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index f879a3999fb..31ee6c5bfd4 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -388,9 +388,9 @@ See `defclass' for more information."
;; Clean up the meaning of protection.
(setq prot
(pcase prot
- ((or 'nil 'public ':public) nil)
- ((or 'protected ':protected) 'protected)
- ((or 'private ':private) 'private)
+ ((or 'nil 'public :public) nil)
+ ((or 'protected :protected) 'protected)
+ ((or 'private :private) 'private)
(_ (signal 'invalid-slot-type (list :protection prot)))))
;; The default type specifier is supposed to be t, meaning anything.
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el
index e93d317d936..193f92bc2ce 100644
--- a/lisp/emacs-lisp/eieio-opt.el
+++ b/lisp/emacs-lisp/eieio-opt.el
@@ -327,7 +327,7 @@ current expansion depth."
(defun eieio-sb-expand (text class indent)
"For button TEXT, expand CLASS at the current location.
Argument INDENT is the depth of indentation."
- (cond ((string-match "+" text) ;we have to expand this file
+ (cond ((string-match "\\+" text) ;we have to expand this file
(speedbar-change-expand-button-char ?-)
(speedbar-with-writable
(save-excursion
diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el
index 52dd6fea3fc..2dd9a5eda64 100644
--- a/lisp/emacs-lisp/eieio-speedbar.el
+++ b/lisp/emacs-lisp/eieio-speedbar.el
@@ -348,7 +348,7 @@ The object is at indentation level INDENT."
(defun eieio-speedbar-object-expand (text token indent)
"Expand object represented by TEXT.
TOKEN is the object. INDENT is the current indentation level."
- (cond ((string-match "+" text) ;we have to expand this file
+ (cond ((string-match "\\+" text) ;we have to expand this file
(speedbar-change-expand-button-char ?-)
(oset token expanded t)
(speedbar-with-writable
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 38436d1f944..b6ec191e2ba 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -377,9 +377,21 @@ contents of field NAME is matched against PAT, or they can be of
(define-obsolete-function-alias
'object-class-fast #'eieio-object-class "24.4")
+;; In the past, every EIEIO object had a `name' field, so we had the
+;; two methods `eieio-object-name-string' and
+;; `eieio-object-set-name-string' "for free". Since this field is
+;; very rarely used, we got rid of it and instead we keep it in a weak
+;; hash-tables, for those very rare objects that use it.
+;; Really, those rare objects should inherit from `eieio-named' instead!
+(defconst eieio--object-names (make-hash-table :test #'eq :weakness 'key))
+
(cl-defgeneric eieio-object-name-string (obj)
"Return a string which is OBJ's name."
- (declare (obsolete eieio-named "25.1")))
+ (or (gethash obj eieio--object-names)
+ (format "%s-%x" (eieio-object-class obj) (sxhash-eq obj))))
+
+(define-obsolete-function-alias
+ 'object-name-string #'eieio-object-name-string "24.4")
(defun eieio-object-name (obj &optional extra)
"Return a printed representation for object OBJ.
@@ -389,21 +401,9 @@ If EXTRA, include that in the string returned to represent the symbol."
(eieio-object-name-string obj) (or extra "")))
(define-obsolete-function-alias 'object-name #'eieio-object-name "24.4")
-(defconst eieio--object-names (make-hash-table :test #'eq :weakness 'key))
-
-;; In the past, every EIEIO object had a `name' field, so we had the two method
-;; below "for free". Since this field is very rarely used, we got rid of it
-;; and instead we keep it in a weak hash-tables, for those very rare objects
-;; that use it.
-(cl-defmethod eieio-object-name-string (obj)
- (or (gethash obj eieio--object-names)
- (symbol-name (eieio-object-class obj))))
-(define-obsolete-function-alias
- 'object-name-string #'eieio-object-name-string "24.4")
-
-(cl-defmethod eieio-object-set-name-string (obj name)
+(cl-defgeneric eieio-object-set-name-string (obj name)
"Set the string which is OBJ's NAME."
- (declare (obsolete eieio-named "25.1"))
+ (declare (obsolete "inherit from `eieio-named' and use (setf (slot-value OBJ \\='object-name) NAME) instead" "25.1"))
(cl-check-type name string)
(setf (gethash obj eieio--object-names) name))
(define-obsolete-function-alias
@@ -847,7 +847,16 @@ to prepend a space."
(princ (object-print object) stream))
(defvar eieio-print-depth 0
- "When printing, keep track of the current indentation depth.")
+ "The current indentation depth while printing.
+Ignored if `eieio-print-indentation' is nil.")
+
+(defvar eieio-print-indentation t
+ "When non-nil, indent contents of printed objects.")
+
+(defvar eieio-print-object-name t
+ "When non-nil write the object name in `object-write'.
+Does not affect objects subclassing `eieio-named'. Note that
+Emacs<26 requires that object names be present.")
(cl-defgeneric object-write (this &optional comment)
"Write out object THIS to the current stream.
@@ -859,10 +868,11 @@ This writes out the vector version of this object. Complex and recursive
object are discouraged from being written.
If optional COMMENT is non-nil, include comments when outputting
this object."
- (when comment
+ (when (and comment eieio-print-object-name)
(princ ";; Object ")
(princ (eieio-object-name-string this))
- (princ "\n")
+ (princ "\n"))
+ (when comment
(princ comment)
(princ "\n"))
(let* ((cl (eieio-object-class this))
@@ -871,12 +881,14 @@ this object."
;; It should look like this:
;; (<constructor> <name> <slot> <slot> ... )
;; Each slot's slot is writen using its :writer.
- (princ (make-string (* eieio-print-depth 2) ? ))
+ (when eieio-print-indentation
+ (princ (make-string (* eieio-print-depth 2) ? )))
(princ "(")
(princ (symbol-name (eieio--class-constructor (eieio-object-class this))))
- (princ " ")
- (prin1 (eieio-object-name-string this))
- (princ "\n")
+ (when eieio-print-object-name
+ (princ " ")
+ (prin1 (eieio-object-name-string this))
+ (princ "\n"))
;; Loop over all the public slots
(let ((slots (eieio--class-slots cv))
(eieio-print-depth (1+ eieio-print-depth)))
@@ -889,7 +901,8 @@ this object."
(unless (or (not i) (equal v (cl--slot-descriptor-initform slot)))
(unless (bolp)
(princ "\n"))
- (princ (make-string (* eieio-print-depth 2) ? ))
+ (when eieio-print-indentation
+ (princ (make-string (* eieio-print-depth 2) ? )))
(princ (symbol-name i))
(if (alist-get :printer (cl--slot-descriptor-props slot))
;; Use our public printer
@@ -904,7 +917,7 @@ this object."
"\n" " "))
(eieio-override-prin1 v))))))))
(princ ")")
- (when (= eieio-print-depth 0)
+ (when (zerop eieio-print-depth)
(princ "\n"))))
(defun eieio-override-prin1 (thing)
@@ -942,14 +955,16 @@ this object."
(progn
(princ "'")
(prin1 list))
- (princ (make-string (* eieio-print-depth 2) ? ))
+ (when eieio-print-indentation
+ (princ (make-string (* eieio-print-depth 2) ? )))
(princ "(list")
(let ((eieio-print-depth (1+ eieio-print-depth)))
(while list
(princ "\n")
(if (eieio-object-p (car list))
(object-write (car list))
- (princ (make-string (* eieio-print-depth 2) ? ))
+ (when eieio-print-indentation
+ (princ (make-string (* eieio-print-depth) ? )))
(eieio-override-prin1 (car list)))
(setq list (cdr list))))
(princ ")")))
diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el
index 37db28f2a50..188d99e14cb 100644
--- a/lisp/emacs-lisp/eldoc.el
+++ b/lisp/emacs-lisp/eldoc.el
@@ -177,9 +177,6 @@ printed after commands contained in this obarray."
;;;###autoload
(define-minor-mode eldoc-mode
"Toggle echo area display of Lisp objects at point (ElDoc mode).
-With a prefix argument ARG, enable ElDoc mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable ElDoc mode
-if ARG is omitted or nil.
ElDoc mode is a buffer-local minor mode. When enabled, the echo
area displays information about a function or variable in the
@@ -360,12 +357,15 @@ return any documentation.")
;; This is run from post-command-hook or some idle timer thing,
;; so we need to be careful that errors aren't ignored.
(with-demoted-errors "eldoc error: %s"
- (and (or (eldoc-display-message-p)
- ;; Erase the last message if we won't display a new one.
- (when eldoc-last-message
- (eldoc-message nil)
- nil))
- (eldoc-message (funcall eldoc-documentation-function)))))
+ (if (not (eldoc-display-message-p))
+ ;; Erase the last message if we won't display a new one.
+ (when eldoc-last-message
+ (eldoc-message nil))
+ (let ((non-essential t))
+ ;; Only keep looking for the info as long as the user hasn't
+ ;; requested our attention. This also locally disables inhibit-quit.
+ (while-no-input
+ (eldoc-message (funcall eldoc-documentation-function)))))))
;; If the entire line cannot fit in the echo area, the symbol name may be
;; truncated or eliminated entirely from the output to make room for the
diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el
index a80d769415d..3f49b51acdd 100644
--- a/lisp/emacs-lisp/elint.el
+++ b/lisp/emacs-lisp/elint.el
@@ -463,21 +463,9 @@ Return nil if there are no more forms, t otherwise."
;; Import variable definitions
((memq (car form) '(require cc-require cc-require-when-compile))
(let ((name (eval (cadr form)))
- (file (eval (nth 2 form)))
- (elint-doing-cl (bound-and-true-p elint-doing-cl)))
+ (file (eval (nth 2 form))))
(unless (memq name elint-features)
(add-to-list 'elint-features name)
- ;; cl loads cl-macs in an opaque manner.
- ;; Since cl-macs requires cl, we can just process cl-macs.
- ;; FIXME: AFAIK, `cl' now behaves properly and does not need any
- ;; special treatment any more. Can someone who understands this
- ;; code confirm? --Stef
- (and (eq name 'cl) (not elint-doing-cl)
- ;; We need cl if elint-form is to be able to expand cl macros.
- (require 'cl)
- (setq name 'cl-macs
- file nil
- elint-doing-cl t)) ; blech
(setq elint-env (elint-add-required-env elint-env name file))))))
elint-env)
@@ -1107,7 +1095,7 @@ Marks the function with their arguments, and returns a list of variables."
(set-buffer (get-buffer-create docbuf))
(insert-file-contents-literally
(expand-file-name internal-doc-file-name doc-directory)))
- (while (re-search-forward "\\([VF]\\)" nil t)
+ (while (re-search-forward "\^_\\([VF]\\)" nil t)
(when (setq sym (intern-soft (buffer-substring (point)
(line-end-position))))
(if (string-equal (match-string 1) "V")
@@ -1116,7 +1104,7 @@ Marks the function with their arguments, and returns a list of variables."
(if (boundp sym) (setq vars (cons sym vars)))
;; Function.
(when (fboundp sym)
- (when (re-search-forward "\\(^(fn.*)\\)?" nil t)
+ (when (re-search-forward "\\(^(fn.*)\\)?\^_" nil t)
(backward-char 1)
;; FIXME distinguish no args from not found.
(and (setq args (match-string 1))
diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el
index 2e83dce063d..f0dcb51af89 100644
--- a/lisp/emacs-lisp/elp.el
+++ b/lisp/emacs-lisp/elp.el
@@ -383,14 +383,13 @@ original definition, use \\[elp-restore-function] or \\[elp-restore-all]."
;; and return the results.
(setq result (apply func args))
;; we are recording times
- (let (enter-time exit-time)
+ (let (enter-time)
;; increment the call-counter
(cl-incf (aref info 0))
(setq enter-time (current-time)
- result (apply func args)
- exit-time (current-time))
+ result (apply func args))
;; calculate total time in function
- (cl-incf (aref info 1) (elp-elapsed-time enter-time exit-time))
+ (cl-incf (aref info 1) (elp-elapsed-time enter-time nil))
))
;; turn off recording if this is the master function
(if (and elp-master
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 6293abfeefa..20d013b0797 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -60,6 +60,7 @@
(require 'cl-lib)
(require 'button)
(require 'debug)
+(require 'backtrace)
(require 'easymenu)
(require 'ewoc)
(require 'find-func)
@@ -472,18 +473,6 @@ Errors during evaluation are caught and handled like nil."
;; buffer. Perhaps explanations should be reported through `ert-info'
;; rather than as part of the condition.
-(defun ert--proper-list-p (x)
- "Return non-nil if X is a proper list, nil otherwise."
- (cl-loop
- for firstp = t then nil
- for fast = x then (cddr fast)
- for slow = x then (cdr slow) do
- (when (null fast) (cl-return t))
- (when (not (consp fast)) (cl-return nil))
- (when (null (cdr fast)) (cl-return t))
- (when (not (consp (cdr fast))) (cl-return nil))
- (when (and (not firstp) (eq fast slow)) (cl-return nil))))
-
(defun ert--explain-format-atom (x)
"Format the atom X for `ert--explain-equal'."
(pcase x
@@ -494,17 +483,17 @@ Errors during evaluation are caught and handled like nil."
(defun ert--explain-equal-rec (a b)
"Return a programmer-readable explanation of why A and B are not `equal'.
Returns nil if they are."
- (if (not (equal (type-of a) (type-of b)))
+ (if (not (eq (type-of a) (type-of b)))
`(different-types ,a ,b)
(pcase-exhaustive a
((pred consp)
- (let ((a-proper-p (ert--proper-list-p a))
- (b-proper-p (ert--proper-list-p b)))
- (if (not (eql (not a-proper-p) (not b-proper-p)))
+ (let ((a-length (proper-list-p a))
+ (b-length (proper-list-p b)))
+ (if (not (eq (not a-length) (not b-length)))
`(one-list-proper-one-improper ,a ,b)
- (if a-proper-p
- (if (not (equal (length a) (length b)))
- `(proper-lists-of-different-length ,(length a) ,(length b)
+ (if a-length
+ (if (/= a-length b-length)
+ `(proper-lists-of-different-length ,a-length ,b-length
,a ,b
first-mismatch-at
,(cl-mismatch a b :test 'equal))
@@ -523,7 +512,7 @@ Returns nil if they are."
(cl-assert (equal a b) t)
nil))))))))
((pred arrayp)
- (if (not (equal (length a) (length b)))
+ (if (/= (length a) (length b))
`(arrays-of-different-length ,(length a) ,(length b)
,a ,b
,@(unless (char-table-p a)
@@ -676,6 +665,7 @@ and is displayed in front of the value of MESSAGE-FORM."
(cl-defstruct ert-test-result
(messages nil)
(should-forms nil)
+ (duration 0)
)
(cl-defstruct (ert-test-passed (:include ert-test-result)))
(cl-defstruct (ert-test-result-with-condition (:include ert-test-result))
@@ -688,13 +678,6 @@ and is displayed in front of the value of MESSAGE-FORM."
(cl-defstruct (ert-test-aborted-with-non-local-exit
(:include ert-test-result)))
-(defun ert--print-backtrace (backtrace do-xrefs)
- "Format the backtrace BACKTRACE to the current buffer."
- (let ((print-escape-newlines t)
- (print-level 8)
- (print-length 50))
- (debugger-insert-backtrace backtrace do-xrefs)))
-
;; A container for the state of the execution of a single test and
;; environment data needed during its execution.
(cl-defstruct ert--test-execution-info
@@ -743,7 +726,7 @@ run. ARGS are the arguments to `debugger'."
;; use.
;;
;; Grab the frames above the debugger.
- (backtrace (cdr (backtrace-frames debugger)))
+ (backtrace (cdr (backtrace-get-frames debugger)))
(infos (reverse ert--infos)))
(setf (ert--test-execution-info-result info)
(cl-ecase type
@@ -988,7 +971,7 @@ contained in UNIVERSE."
test
(ert-test-most-recent-result test))))
universe))
- (:unexpected (ert-select-tests `(not :expected) universe))
+ (:unexpected (ert-select-tests '(not :expected) universe))
((pred stringp)
(pcase-exhaustive universe
(`t (mapcar #'ert-get-test
@@ -1230,6 +1213,11 @@ SELECTOR is the selector that was used to select TESTS."
(ert-run-test test)
(setf (aref (ert--stats-test-end-times stats) pos) (current-time))
(let ((result (ert-test-most-recent-result test)))
+ (setf (ert-test-result-duration result)
+ (float-time
+ (time-subtract
+ (aref (ert--stats-test-end-times stats) pos)
+ (aref (ert--stats-test-start-times stats) pos))))
(ert--stats-set-test-and-result stats pos test result)
(funcall listener 'test-ended stats test result))
(setf (ert--stats-current-test stats) nil))))
@@ -1333,6 +1321,9 @@ RESULT must be an `ert-test-result-with-condition'."
;;; Running tests in batch mode.
+(defvar ert-quiet nil
+ "Non-nil makes ERT only print important information in batch mode.")
+
;;;###autoload
(defun ert-run-tests-batch (&optional selector)
"Run the tests specified by SELECTOR, printing results to the terminal.
@@ -1349,16 +1340,18 @@ Returns the stats object."
(lambda (event-type &rest event-args)
(cl-ecase event-type
(run-started
- (cl-destructuring-bind (stats) event-args
- (message "Running %s tests (%s)"
- (length (ert--stats-tests stats))
- (ert--format-time-iso8601 (ert--stats-start-time stats)))))
+ (unless ert-quiet
+ (cl-destructuring-bind (stats) event-args
+ (message "Running %s tests (%s, selector `%S')"
+ (length (ert--stats-tests stats))
+ (ert--format-time-iso8601 (ert--stats-start-time stats))
+ selector))))
(run-ended
(cl-destructuring-bind (stats abortedp) event-args
(let ((unexpected (ert-stats-completed-unexpected stats))
(skipped (ert-stats-skipped stats))
(expected-failures (ert--stats-failed-expected stats)))
- (message "\n%sRan %s tests, %s results as expected%s%s (%s)%s\n"
+ (message "\n%sRan %s tests, %s results as expected%s%s (%s, %f sec)%s\n"
(if (not abortedp)
""
"Aborted: ")
@@ -1371,6 +1364,10 @@ Returns the stats object."
""
(format ", %s skipped" skipped))
(ert--format-time-iso8601 (ert--stats-end-time stats))
+ (float-time
+ (time-subtract
+ (ert--stats-end-time stats)
+ (ert--stats-start-time stats)))
(if (zerop expected-failures)
""
(format "\n%s expected failures" expected-failures)))
@@ -1403,9 +1400,8 @@ Returns the stats object."
(ert-test-result-with-condition
(message "Test %S backtrace:" (ert-test-name test))
(with-temp-buffer
- (ert--print-backtrace
- (ert-test-result-with-condition-backtrace result)
- nil)
+ (insert (backtrace-to-string
+ (ert-test-result-with-condition-backtrace result)))
(if (not ert-batch-backtrace-right-margin)
(message "%s"
(buffer-substring-no-properties (point-min)
@@ -1438,16 +1434,18 @@ Returns the stats object."
(ert-test-name test)))
(ert-test-quit
(message "Quit during %S" (ert-test-name test)))))
- (let* ((max (prin1-to-string (length (ert--stats-tests stats))))
- (format-string (concat "%9s %"
- (prin1-to-string (length max))
- "s/" max " %S")))
- (message format-string
- (ert-string-for-test-result result
- (ert-test-result-expected-p
- test result))
- (1+ (ert--stats-test-pos stats test))
- (ert-test-name test)))))))
+ (unless ert-quiet
+ (let* ((max (prin1-to-string (length (ert--stats-tests stats))))
+ (format-string (concat "%9s %"
+ (prin1-to-string (length max))
+ "s/" max " %S (%f sec)")))
+ (message format-string
+ (ert-string-for-test-result result
+ (ert-test-result-expected-p
+ test result))
+ (1+ (ert--stats-test-pos stats test))
+ (ert-test-name test)
+ (ert-test-result-duration result))))))))
nil))
;;;###autoload
@@ -1474,20 +1472,23 @@ the tests)."
(kill-emacs 2))))
-(defun ert-summarize-tests-batch-and-exit ()
+(defun ert-summarize-tests-batch-and-exit (&optional high)
"Summarize the results of testing.
Expects to be called in batch mode, with logfiles as command-line arguments.
The logfiles should have the `ert-run-tests-batch' format. When finished,
-this exits Emacs, with status as per `ert-run-tests-batch-and-exit'."
+this exits Emacs, with status as per `ert-run-tests-batch-and-exit'.
+
+If HIGH is a natural number, the HIGH long lasting tests are summarized."
(or noninteractive
(user-error "This function is only for use in batch mode"))
+ (or (natnump high) (setq high 0))
;; Better crash loudly than attempting to recover from undefined
;; behavior.
(setq attempt-stack-overflow-recovery nil
attempt-orderly-shutdown-on-fatal-signal nil)
(let ((nlogs (length command-line-args-left))
(ntests 0) (nrun 0) (nexpected 0) (nunexpected 0) (nskipped 0)
- nnotrun logfile notests badtests unexpected skipped)
+ nnotrun logfile notests badtests unexpected skipped tests)
(with-temp-buffer
(while (setq logfile (pop command-line-args-left))
(erase-buffer)
@@ -1510,7 +1511,15 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\
(when (match-string 5)
(push logfile skipped)
(setq nskipped (+ nskipped
- (string-to-number (match-string 5)))))))))
+ (string-to-number (match-string 5)))))
+ (unless (zerop high)
+ (goto-char (point-min))
+ (while (< (point) (point-max))
+ (if (looking-at "^\\s-+\\w+\\s-+[[:digit:]]+/[[:digit:]]+\\s-+\\S-+\\s-+(\\([.[:digit:]]+\\)\\s-+sec)$")
+ (push (cons (string-to-number (match-string 1))
+ (match-string 0))
+ tests))
+ (forward-line)))))))
(setq nnotrun (- ntests nrun))
(message "\nSUMMARY OF TEST RESULTS")
(message "-----------------------")
@@ -1530,10 +1539,23 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\
(mapc (lambda (l) (message " %s" l)) notests))
(when badtests
(message "%d files did not finish:" (length badtests))
- (mapc (lambda (l) (message " %s" l)) badtests))
+ (mapc (lambda (l) (message " %s" l)) badtests)
+ (if (getenv "EMACS_HYDRA_CI")
+ (with-temp-buffer
+ (dolist (f badtests)
+ (erase-buffer)
+ (insert-file-contents f)
+ (message "Contents of unfinished file %s:" f)
+ (message "-----\n%s\n-----" (buffer-string))))))
(when unexpected
(message "%d files contained unexpected results:" (length unexpected))
(mapc (lambda (l) (message " %s" l)) unexpected))
+ (unless (or (null tests) (zerop high))
+ (message "\nLONG-RUNNING TESTS")
+ (message "------------------")
+ (setq tests (sort tests (lambda (x y) (> (car x) (car y)))))
+ (when (< high (length tests)) (setcdr (nthcdr (1- high) tests) nil))
+ (message "%s" (mapconcat 'cdr tests "\n")))
;; More details on hydra, where the logs are harder to get to.
(when (and (getenv "EMACS_HYDRA_CI")
(not (zerop (+ nunexpected nskipped))))
@@ -1541,7 +1563,8 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\
(message "-------")
(with-temp-buffer
(dolist (x (list (list skipped "skipped" "SKIPPED")
- (list unexpected "unexpected" "FAILED")))
+ (list unexpected "unexpected"
+ "\\(?:FAILED\\|PASSED\\)")))
(mapc (lambda (l)
(erase-buffer)
(insert-file-contents l)
@@ -1799,13 +1822,13 @@ determines how frequently the progress display is updated.")
(force-mode-line-update)
(redisplay t)
(setf (ert--stats-next-redisplay stats)
- (+ (float-time) ert-test-run-redisplay-interval-secs)))
+ (float-time (time-add nil ert-test-run-redisplay-interval-secs))))
(defun ert--results-update-stats-display-maybe (ewoc stats)
"Call `ert--results-update-stats-display' if not called recently.
EWOC and STATS are arguments for `ert--results-update-stats-display'."
- (when (>= (float-time) (ert--stats-next-redisplay stats))
+ (unless (time-less-p nil (ert--stats-next-redisplay stats))
(ert--results-update-stats-display ewoc stats)))
(defun ert--tests-running-mode-line-indicator ()
@@ -2421,20 +2444,20 @@ To be used in the ERT results buffer."
(cl-etypecase result
(ert-test-passed (error "Test passed, no backtrace available"))
(ert-test-result-with-condition
- (let ((backtrace (ert-test-result-with-condition-backtrace result))
- (buffer (get-buffer-create "*ERT Backtrace*")))
+ (let ((buffer (get-buffer-create "*ERT Backtrace*")))
(pop-to-buffer buffer)
- (let ((inhibit-read-only t))
- (buffer-disable-undo)
- (erase-buffer)
- (ert-simple-view-mode)
- (set-buffer-multibyte t) ; mimic debugger-setup-buffer
- (setq truncate-lines t)
- (ert--print-backtrace backtrace t)
- (goto-char (point-min))
- (insert (substitute-command-keys "Backtrace for test `"))
- (ert-insert-test-name-button (ert-test-name test))
- (insert (substitute-command-keys "':\n"))))))))
+ (unless (derived-mode-p 'backtrace-mode)
+ (backtrace-mode))
+ (setq backtrace-insert-header-function
+ (lambda () (ert--insert-backtrace-header (ert-test-name test)))
+ backtrace-frames (ert-test-result-with-condition-backtrace result))
+ (backtrace-print)
+ (goto-char (point-min)))))))
+
+(defun ert--insert-backtrace-header (name)
+ (insert (substitute-command-keys "Backtrace for test `"))
+ (ert-insert-test-name-button name)
+ (insert (substitute-command-keys "':\n")))
(defun ert-results-pop-to-messages-for-test-at-point ()
"Display the part of the *Messages* buffer generated during the test at point.
@@ -2544,8 +2567,6 @@ To be used in the ERT results buffer."
(defun ert-describe-test (test-or-test-name)
"Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)."
(interactive (list (ert-read-test-name-at-point "Describe test")))
- (when (< emacs-major-version 24)
- (user-error "Requires Emacs 24 or later"))
(let (test-name
test-definition)
(cl-etypecase test-or-test-name
@@ -2582,7 +2603,9 @@ To be used in the ERT results buffer."
(insert (substitute-command-keys
(or (ert-test-documentation test-definition)
"It is not documented."))
- "\n")))))))
+ "\n")
+ ;; For describe-symbol-backends.
+ (buffer-string)))))))
(defun ert-results-describe-test-at-point ()
"Display the documentation of the test at point.
@@ -2594,6 +2617,11 @@ To be used in the ERT results buffer."
;;; Actions on load/unload.
+(require 'help-mode)
+(add-to-list 'describe-symbol-backends
+ `("ERT test" ,#'ert-test-boundp
+ ,(lambda (s _b _f) (ert-describe-test s))))
+
(add-to-list 'find-function-regexp-alist '(ert--test . ert--find-test-regexp))
(add-to-list 'minor-mode-alist '(ert--current-run-stats
(:eval
@@ -2608,7 +2636,7 @@ To be used in the ERT results buffer."
'ert--activate-font-lock-keywords)
nil)
-(defvar ert-unload-hook '())
+(defvar ert-unload-hook ())
(add-hook 'ert-unload-hook #'ert--unload-function)
diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el
index c454d150aaf..c33b46501ff 100644
--- a/lisp/emacs-lisp/ewoc.el
+++ b/lisp/emacs-lisp/ewoc.el
@@ -500,7 +500,7 @@ Return the node (or nil if we just passed the last node)."
(defun ewoc-goto-node (ewoc node)
"Move point to NODE in EWOC."
- (ewoc--set-buffer-bind-dll ewoc
+ (with-current-buffer (ewoc--buffer ewoc)
(goto-char (ewoc--node-start-marker node))
(if goal-column (move-to-column goal-column))
(setf (ewoc--last-node ewoc) node)))
diff --git a/lisp/emacs-lisp/faceup.el b/lisp/emacs-lisp/faceup.el
new file mode 100644
index 00000000000..7527f532c57
--- /dev/null
+++ b/lisp/emacs-lisp/faceup.el
@@ -0,0 +1,1180 @@
+;;; faceup.el --- Markup language for faces and font-lock regression testing -*- lexical-binding: t -*-
+
+;; Copyright (C) 2013-2019 Free Software Foundation, Inc.
+
+;; Author: Anders Lindgren
+;; Version: 0.0.6
+;; Created: 2013-01-21
+;; Keywords: faces languages
+;; URL: https://github.com/Lindydancer/faceup
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Emacs is capable of highlighting buffers based on language-specific
+;; `font-lock' rules. This package makes it possible to perform
+;; regression test for packages that provide font-lock rules.
+;;
+;; The underlying idea is to convert text with highlights ("faces")
+;; into a plain text representation using the Faceup markup
+;; language. This language is semi-human readable, for example:
+;;
+;; «k:this» is a keyword
+;;
+;; By comparing the current highlight with a highlight performed with
+;; stable versions of a package, it's possible to automatically find
+;; problems that otherwise would have been hard to spot.
+;;
+;; This package is designed to be used in conjunction with Ert, the
+;; standard Emacs regression test system.
+;;
+;; The Faceup markup language is a generic markup language, regression
+;; testing is merely one way to use it.
+
+;; Regression test examples:
+;;
+;; This section describes the two typical ways regression testing with
+;; this package is performed.
+;;
+;;
+;; Full source file highlighting:
+;;
+;; The most straight-forward way to perform regression testing is to
+;; collect a number of representative source files. From each source
+;; file, say `alpha.mylang', you can use `M-x faceup-write-file RET'
+;; to generate a Faceup file named `alpha.mylang.faceup', this file
+;; use the Faceup markup language to represent the text with
+;; highlights and is used as a reference in future tests.
+;;
+;; An Ert test case can be defined as follows:
+;;
+;; (require 'faceup)
+;;
+;; (defvar mylang-font-lock-test-dir (faceup-this-file-directory))
+;;
+;; (defun mylang-font-lock-test-apps (file)
+;; "Test that the mylang FILE is fontifies as the .faceup file describes."
+;; (faceup-test-font-lock-file 'mylang-mode
+;; (concat mylang-font-lock-test-dir file)))
+;; (faceup-defexplainer mylang-font-lock-test-apps)
+;;
+;; (ert-deftest mylang-font-lock-file-test ()
+;; (should (mylang-font-lock-test-apps "apps/FirstApp/alpha.mylang"))
+;; ;; ... Add more test files here ...
+;; )
+;;
+;; To execute the tests, run something like `M-x ert RET t RET'.
+;;
+;;
+;; Source snippets:
+;;
+;; To test smaller snippets of code, you can use the
+;; `faceup-test-font-lock-string'. It takes a major mode and a string
+;; written using the Faceup markup language. The functions strips away
+;; the Faceup markup, inserts the plain text into a temporary buffer,
+;; highlights it, converts the result back into the Faceup markup
+;; language, and finally compares the result with the original Faceup
+;; string.
+;;
+;; For example:
+;;
+;; (defun mylang-font-lock-test (faceup)
+;; (faceup-test-font-lock-string 'mylang-mode faceup))
+;; (faceup-defexplainer mylang-font-lock-test)
+;;
+;; (ert-deftest mylang-font-lock-test-simple ()
+;; "Simple MyLang font-lock tests."
+;; (should (mylang-font-lock-test "«k:this» is a keyword"))
+;; (should (mylang-font-lock-test "«k:function» «f:myfunc» («v:var»)")))
+;;
+
+;; Executing the tests:
+;;
+;; Once the tests have been defined, you can use `M-x ert RET t RET'
+;; to execute them. Hopefully, you will be given the "all clear".
+;; However, if there is a problem, you will be presented with
+;; something like:
+;;
+;; F mylang-font-lock-file-test
+;; (ert-test-failed
+;; ((should
+;; (mylang-font-lock-test-apps "apps/FirstApp/alpha.mylang"))
+;; :form
+;; (mylang-font-lock-test-apps "apps/FirstApp/alpha.mylang")
+;; :value nil :explanation
+;; ((on-line 2
+;; ("but_«k:this»_is_not_a_keyword")
+;; ("but_this_is_not_a_keyword")))))
+;;
+;; You should read this that on line 2, the old font-lock rules
+;; highlighted `this' inside `but_this_is_not_a_keyword' (which is
+;; clearly wrong), whereas the new doesn't. Of course, if this is the
+;; desired result (for example, the result of a recent change) you can
+;; simply regenerate the .faceup file and store it as the reference
+;; file for the future.
+
+;; The Faceup markup language:
+;;
+;; The Faceup markup language is designed to be human-readable and
+;; minimalistic.
+;;
+;; The two special characters `«' and `»' marks the start and end of a
+;; range of a face.
+;;
+;;
+;; Compact format for special faces:
+;;
+;; The compact format `«<LETTER>:text»' is used for a number of common
+;; faces. For example, `«U:abc»' means that the text `abc' is
+;; underlined.
+;;
+;; See `faceup-face-short-alist' for the known faces and the
+;; corresponding letter.
+;;
+;;
+;; Full format:
+;;
+;; The format `«:<NAME OF FACE>:text»' is used use to encode other
+;; faces.
+;;
+;; For example `«:my-special-face:abc»' meanst that `abc' has the face
+;; `my-special-face'.
+;;
+;;
+;; Anonymous faces:
+;;
+;; An "anonymous face" is when the `face' property contains a property
+;; list (plist) on the form `(:key value)'. This is represented using
+;; a variant of the full format: `«:(:key value):text»'.
+;;
+;; For example, `«:(:background "red"):abc»' represent the text `abc'
+;; with a red background.
+;;
+;;
+;; Multiple properties:
+;;
+;; In case a text contains more than one face property, they are
+;; represented using nested sections.
+;;
+;; For example:
+;;
+;; * `«B:abc«U:def»»' represent the text `abcdef' that is both *bold*
+;; and *underlined*.
+;;
+;; * `«W:abc«U:def»ghi»' represent the text `abcdefghi' where the
+;; entire text is in *warning* face and `def' is *underlined*.
+;;
+;; In case two faces partially overlap, the ranges will be split when
+;; represented in Faceup. For example:
+;;
+;; * `«B:abc«U:def»»«U:ghi»' represent the text `abcdefghi' where
+;; `abcdef' is bold and `defghi' is underlined.
+;;
+;;
+;; Escaping start and end markers:
+;;
+;; Any occurrence of the start or end markers in the original text
+;; will be escaped using the start marker in the Faceup
+;; representation. In other words, the sequences `««' and `«»'
+;; represent a start and end marker, respectively.
+;;
+;;
+;; Other properties:
+;;
+;; In addition to representing the `face' property (or, more
+;; correctly, the value of `faceup-default-property') other properties
+;; can be encoded. The variable `faceup-properties' contains a list of
+;; properties to track. If a property behaves like the `face'
+;; property, it is encoded as described above, with the addition of
+;; the property name placed in parentheses, for example:
+;; `«(my-face)U:abd»'.
+;;
+;; The variable `faceup-face-like-properties' contains a list of
+;; properties considered face-like.
+;;
+;; Properties that are not considered face-like are always encoded
+;; using the full format and the don't nest. For example:
+;; `«(my-fibonacci-property):(1 1 2 3 5 8):abd»'.
+;;
+;; Examples of properties that could be tracked are:
+;;
+;; * `font-lock-face' -- an alias to `face' when `font-lock-mode' is
+;; enabled.
+;;
+;; * `syntax-table' -- used by a custom `syntax-propertize' to
+;; override the default syntax table.
+;;
+;; * `help-echo' -- provides tooltip text displayed when the mouse is
+;; held over a text.
+
+;; Reference section:
+;;
+;; Faceup commands and functions:
+;;
+;; `M-x faceup-write-file RET' - generate a Faceup file based on the
+;; current buffer.
+;;
+;; `M-x faceup-view-file RET' - view the current buffer converted to
+;; Faceup.
+;;
+;; `faceup-markup-{string,buffer}' - convert text with properties to
+;; the Faceup markup language.
+;;
+;; `faceup-render-view-buffer' - convert buffer with Faceup markup to
+;; a buffer with real text properties and display it.
+;;
+;; `faceup-render-string' - return string with real text properties
+;; from a string with Faceup markup.
+;;
+;; `faceup-render-to-{buffer,string}' - convert buffer with Faceup
+;; markup to a buffer/string with real text properties.
+;;
+;; `faceup-clean-{buffer,string}' - remove Faceup markup from buffer
+;; or string.
+;;
+;;
+;; Regression test support:
+;;
+;; The following functions can be used as Ert test functions, or can
+;; be used to implement new Ert test functions.
+;;
+;; `faceup-test-equal' - Test function, work like Ert:s `equal', but
+;; more ergonomically when reporting multi-line string errors.
+;; Concretely, it breaks down multi-line strings into lines and
+;; reports which line number the error occurred on and the content of
+;; that line.
+;;
+;; `faceup-test-font-lock-buffer' - Test that a buffer is highlighted
+;; according to a reference Faceup text, for a specific major mode.
+;;
+;; `faceup-test-font-lock-string' - Test that a text with Faceup
+;; markup is refontified to match the original Faceup markup.
+;;
+;; `faceup-test-font-lock-file' - Test that a file is highlighted
+;; according to a reference .faceup file.
+;;
+;; `faceup-defexplainer' - Macro, define an explainer function and set
+;; the `ert-explainer' property on the original function, for
+;; functions based on the above test functions.
+;;
+;; `faceup-this-file-directory' - Macro, the directory of the current
+;; file.
+
+;; Real-world examples:
+;;
+;; The following are examples of real-world package that use faceup to
+;; test their font-lock keywords.
+;;
+;; * [cmake-font-lock](https://github.com/Lindydancer/cmake-font-lock)
+;; an advanced set of font-lock keywords for the CMake language
+;;
+;; * [objc-font-lock](https://github.com/Lindydancer/objc-font-lock)
+;; highlight Objective-C function calls.
+;;
+
+;; Other Font Lock Tools:
+;;
+;; This package is part of a suite of font-lock tools. The other
+;; tools in the suite are:
+;;
+;;
+;; Font Lock Studio:
+;;
+;; Interactive debugger for font-lock keywords (Emacs syntax
+;; highlighting rules).
+;;
+;; Font Lock Studio lets you *single-step* Font Lock keywords --
+;; matchers, highlights, and anchored rules, so that you can see what
+;; happens when a buffer is fontified. You can set *breakpoints* on
+;; or inside rules and *run* until one has been hit. When inside a
+;; rule, matches are *visualized* using a palette of background
+;; colors. The *explainer* can describe a rule in plain-text English.
+;; Tight integration with *Edebug* allows you to step into Lisp
+;; expressions that are part of the Font Lock keywords.
+;;
+;;
+;; Font Lock Profiler:
+;;
+;; A profiler for font-lock keywords. This package measures time and
+;; counts the number of times each part of a font-lock keyword is
+;; used. For matchers, it counts the total number and the number of
+;; successful matches.
+;;
+;; The result is presented in table that can be sorted by count or
+;; time. The table can be expanded to include each part of the
+;; font-lock keyword.
+;;
+;; In addition, this package can generate a log of all font-lock
+;; events. This can be used to verify font-lock implementations,
+;; concretely, this is used for back-to-back tests of the real
+;; font-lock engine and Font Lock Studio, an interactive debugger for
+;; font-lock keywords.
+;;
+;;
+;; Highlight Refontification:
+;;
+;; Minor mode that visualizes how font-lock refontifies a buffer.
+;; This is useful when developing or debugging font-lock keywords,
+;; especially for keywords that span multiple lines.
+;;
+;; The background of the buffer is painted in a rainbow of colors,
+;; where each band in the rainbow represent a region of the buffer
+;; that has been refontified. When the buffer is modified, the
+;; rainbow is updated.
+;;
+;;
+;; Face Explorer:
+;;
+;; Library and tools for faces and text properties.
+;;
+;; This library is useful for packages that convert syntax highlighted
+;; buffers to other formats. The functions can be used to determine
+;; how a face or a face text property looks, in terms of primitive
+;; face attributes (e.g. foreground and background colors). Two sets
+;; of functions are provided, one for existing frames and one for
+;; fictitious displays, like 8 color tty.
+;;
+;; In addition, the following tools are provided:
+;;
+;; - `face-explorer-list-faces' -- list all available faces. Like
+;; `list-faces-display' but with information on how a face is
+;; defined. In addition, a sample for the selected frame and for a
+;; fictitious display is shown.
+;;
+;; - `face-explorer-describe-face' -- Print detailed information on
+;; how a face is defined, and list all underlying definitions.
+;;
+;; - `face-explorer-describe-face-prop' -- Describe the `face' text
+;; property at the point in terms of primitive face attributes.
+;; Also show how it would look on a fictitious display.
+;;
+;; - `face-explorer-list-display-features' -- Show which features a
+;; display supports. Most graphical displays support all, or most,
+;; features. However, many tty:s don't support, for example,
+;; strike-through. Using specially constructed faces, the resulting
+;; buffer will render differently in different displays, e.g. a
+;; graphical frame and a tty connected using `emacsclient -nw'.
+;;
+;; - `face-explorer-list-face-prop-examples' -- Show a buffer with an
+;; assortment of `face' text properties. A sample text is shown in
+;; four variants: Native, a manually maintained reference vector,
+;; the result of `face-explorer-face-prop-attributes' and
+;; `face-explorer-face-prop-attributes-for-fictitious-display'. Any
+;; package that convert a buffer to another format (like HTML, ANSI,
+;; or LaTeX) could use this buffer to ensure that everything work as
+;; intended.
+;;
+;; - `face-explorer-list-overlay-examples' -- Show a buffer with a
+;; number of examples of overlays, some are mixed with `face' text
+;; properties. Any package that convert a buffer to another format
+;; (like HTML, ANSI, or LaTeX) could use this buffer to ensure that
+;; everything work as intended.
+;;
+;; - `face-explorer-tooltip-mode' -- Minor mode that shows tooltips
+;; containing text properties and overlays at the mouse pointer.
+;;
+;; - `face-explorer-simulate-display-mode' -- Minor mode for make a
+;; buffer look like it would on a fictitious display. Using this
+;; you can, for example, see how a theme would look in using dark or
+;; light background, a 8 color tty, or on a grayscale graphical
+;; monitor.
+;;
+;;
+;; Font Lock Regression Suite:
+;;
+;; A collection of example source files for a large number of
+;; programming languages, with ERT tests to ensure that syntax
+;; highlighting does not accidentally change.
+;;
+;; For each source file, font-lock reference files are provided for
+;; various Emacs versions. The reference files contains a plain-text
+;; representation of source file with syntax highlighting, using the
+;; format "faceup".
+;;
+;; Of course, the collection source file can be used for other kinds
+;; of testing, not limited to font-lock regression testing.
+
+;;; Code:
+
+
+(defvar faceup-default-property 'face
+ "The property that should be represented in Faceup without the (prop) part.")
+
+(defvar faceup-properties '(face)
+ "List of properties that should be converted to the Faceup format.
+
+Only face-like property use the short format. All other use the
+non-nesting full format. (See `faceup-face-like-properties'.)" )
+
+
+(defvar faceup-face-like-properties '(face font-lock-face)
+ "List of properties that behave like `face'.
+
+The following properties are assumed about face-like properties:
+
+* Elements are either symbols or property lists, or lists thereof.
+
+* A plain element and a list containing the same element are
+ treated as equal
+
+* Property lists and sequences of property lists are considered
+ equal. For example:
+
+ ((:underline t :foreground \"red\"))
+
+ and
+
+ ((:underline t) (:foreground \"red\"))
+
+Face-like properties are converted to faceup in a nesting fashion.
+
+For example, the string AAAXXXAAA (where the property `prop' has
+the value `(a)' on the A:s and `(a b)' on the X:s) is converted
+as follows, when treated as a face-like property:
+
+ «(prop):a:AAA«(prop):b:XXX»AAAA»
+
+When treated as a non-face-like property:
+
+ «(prop):(a):AAA»«(prop):(a b):XXX»«(prop):(a):AAA»")
+
+
+(defvar faceup-markup-start-char ?«)
+(defvar faceup-markup-end-char ?»)
+
+(defvar faceup-face-short-alist
+ '(;; Generic faces (uppercase letters)
+ (bold . "B")
+ (bold-italic . "Q")
+ (default . "D")
+ (error . "E")
+ (highlight . "H")
+ (italic . "I")
+ (underline . "U")
+ (warning . "W")
+ ;; font-lock-specific faces (lowercase letters)
+ (font-lock-builtin-face . "b")
+ (font-lock-comment-delimiter-face . "m")
+ (font-lock-comment-face . "x")
+ (font-lock-constant-face . "c")
+ (font-lock-doc-face . "d")
+ (font-lock-function-name-face . "f")
+ (font-lock-keyword-face . "k")
+ (font-lock-negation-char-face . "n")
+ (font-lock-preprocessor-face . "p")
+ (font-lock-regexp-grouping-backslash . "h")
+ (font-lock-regexp-grouping-construct . "o")
+ (font-lock-string-face . "s")
+ (font-lock-type-face . "t")
+ (font-lock-variable-name-face . "v")
+ (font-lock-warning-face . "w"))
+ "Alist from faces to one-character representation.")
+
+
+;; Plain: «W....»
+;; Nested: «W...«W...»»
+
+;; Overlapping: xxxxxxxxxx
+;; yyyyyyyyyyyy
+;; «X..«Y..»»«Y...»
+
+
+(defun faceup-markup-string (s)
+ "Return the faceup version of the string S."
+ (with-temp-buffer
+ (insert s)
+ (faceup-markup-buffer)))
+
+
+;;;###autoload
+(defun faceup-view-buffer ()
+ "Display the faceup representation of the current buffer."
+ (interactive)
+ (let ((buffer (get-buffer-create "*FaceUp*")))
+ (with-current-buffer buffer
+ (delete-region (point-min) (point-max)))
+ (faceup-markup-to-buffer buffer)
+ (display-buffer buffer)))
+
+
+;;;###autoload
+(defun faceup-write-file (&optional file-name confirm)
+ "Save the faceup representation of the current buffer to the file FILE-NAME.
+
+Unless a name is given, the file will be named xxx.faceup, where
+xxx is the file name associated with the buffer.
+
+If optional second arg CONFIRM is non-nil, this function
+asks for confirmation before overwriting an existing file.
+Interactively, confirmation is required unless you supply a prefix argument."
+ (interactive
+ (let ((suggested-name (and (buffer-file-name)
+ (concat (buffer-file-name)
+ ".faceup"))))
+ (list (read-file-name "Write faceup file: "
+ default-directory
+ suggested-name
+ nil
+ (file-name-nondirectory suggested-name))
+ (not current-prefix-arg))))
+ (unless file-name
+ (setq file-name (concat (buffer-file-name) ".faceup")))
+ (let ((buffer (current-buffer)))
+ (with-temp-buffer
+ (faceup-markup-to-buffer (current-buffer) buffer)
+ ;; Note: Must set `require-final-newline' inside
+ ;; `with-temp-buffer', otherwise the value will be overridden by
+ ;; the buffers local value.
+ ;;
+ ;; Clear `window-size-change-functions' as a workaround for
+ ;; Emacs bug#19576 (`write-file' saves the wrong buffer if a
+ ;; function in the list change current buffer).
+ (let ((require-final-newline nil)
+ (window-size-change-functions '()))
+ (write-file file-name confirm)))))
+
+
+(defun faceup-markup-buffer ()
+ "Return a string with the content of the buffer using faceup markup."
+ (let ((buf (current-buffer)))
+ (with-temp-buffer
+ (faceup-markup-to-buffer (current-buffer) buf)
+ (buffer-substring-no-properties (point-min) (point-max)))))
+
+
+;; Idea:
+;;
+;; Typically, only one face is used. However, when two faces are used,
+;; the one of top is typically shorter. Hence, the faceup variant
+;; should treat the inner group of nested ranges the upper (i.e. the
+;; one towards the front.) For example:
+;;
+;; «f:aaaaaaa«U:xxxx»aaaaaa»
+
+(defun faceup-copy-and-quote (start end to-buffer)
+ "Quote and insert the text between START and END into TO-BUFFER."
+ (let ((not-markup (concat "^"
+ (make-string 1 faceup-markup-start-char)
+ (make-string 1 faceup-markup-end-char))))
+ (save-excursion
+ (goto-char start)
+ (while (< (point) end)
+ (let ((old (point)))
+ (skip-chars-forward not-markup end)
+ (let ((s (buffer-substring-no-properties old (point))))
+ (with-current-buffer to-buffer
+ (insert s))))
+ ;; Quote stray markup characters.
+ (unless (= (point) end)
+ (let ((next-char (following-char)))
+ (with-current-buffer to-buffer
+ (insert faceup-markup-start-char)
+ (insert next-char)))
+ (forward-char))))))
+
+
+;; A face (string or symbol) can be on the top level.
+;;
+;; A face text property can be a arbitrary deep lisp structure. Each
+;; list in the tree structure contains faces (symbols or strings) up
+;; to the first keyword, e.g. :foreground, thereafter the list is
+;; considered a property list, regardless of the content. A special
+;; case are `(foreground-color . COLOR)' and `(background-color
+;; . COLOR)', old forms used to represent the foreground and
+;; background colors, respectively.
+;;
+;; Some of this is undocumented, and took some effort to reverse
+;; engineer.
+(defun faceup-normalize-face-property (value)
+ "Normalize VALUES into a list of faces and (KEY VALUE) entries."
+ (cond ((null value)
+ '())
+ ((symbolp value)
+ (list value))
+ ((stringp value)
+ (list (intern value)))
+ ((consp value)
+ (cond ((eq (car value) 'foreground-color)
+ (list (list :foreground (cdr value))))
+ ((eq (car value) 'background-color)
+ (list (list :background (cdr value))))
+ (t
+ ;; A list
+ (if (keywordp (car value))
+ ;; Once a keyword has been seen, the rest of the
+ ;; list is treated as a property list, regardless
+ ;; of what it contains.
+ (let ((res '()))
+ (while value
+ (let ((key (pop value))
+ (val (pop value)))
+ (when (keywordp key)
+ (push (list key val) res))))
+ res)
+ (append
+ (faceup-normalize-face-property (car value))
+ (faceup-normalize-face-property (cdr value)))))))
+ (t
+ (error "Unexpected text property %s" value))))
+
+
+(defun faceup-get-text-properties (pos)
+ "Alist of properties and values at POS.
+
+Face-like properties are normalized -- value is a list of
+faces (symbols) and short (KEY VALUE) lists. The list is
+reversed to that later elements take precedence over earlier."
+ (let ((res '()))
+ (dolist (prop faceup-properties)
+ (let ((value (get-text-property pos prop)))
+ (when value
+ (when (memq prop faceup-face-like-properties)
+ ;; Normalize face-like properties.
+ (setq value (reverse (faceup-normalize-face-property value))))
+ (push (cons prop value) res))))
+ res))
+
+
+(defun faceup-markup-to-buffer (to-buffer &optional buffer)
+ "Convert content of BUFFER to faceup form and insert in TO-BUFFER."
+ (save-excursion
+ (if buffer
+ (set-buffer buffer))
+ ;; Font-lock often only fontifies the visible sections. This
+ ;; ensures that the entire buffer is fontified before converting
+ ;; it.
+ (if (and font-lock-mode
+ ;; Prevent clearing out face attributes explicitly
+ ;; inserted by functions like `list-faces-display'.
+ ;; (Font-lock mode is enabled, for some reason, in those
+ ;; buffers.)
+ (not (and (eq major-mode 'help-mode)
+ (not font-lock-defaults))))
+ (font-lock-fontify-region (point-min) (point-max)))
+ (let ((last-pos (point-min))
+ (pos nil)
+ ;; List of (prop . value), representing open faceup blocks.
+ (state '()))
+ (while (setq pos (faceup-next-property-change pos))
+ ;; Insert content.
+ (faceup-copy-and-quote last-pos pos to-buffer)
+ (setq last-pos pos)
+ (let ((prop-values (faceup-get-text-properties pos)))
+ (let ((next-state '()))
+ (setq state (reverse state))
+ ;; Find all existing sequences that should continue.
+ (let ((cont t))
+ (while (and state
+ prop-values
+ cont)
+ (let* ((prop (car (car state)))
+ (value (cdr (car state)))
+ (pair (assq prop prop-values)))
+ (if (memq prop faceup-face-like-properties)
+ ;; Element by element.
+ (if (equal value (car (cdr pair)))
+ (setcdr pair (cdr (cdr pair)))
+ (setq cont nil))
+ ;; Full value.
+ ;;
+ ;; Note: Comparison is done by `eq', since (at
+ ;; least) the `display' property treats
+ ;; eq-identical values differently than when
+ ;; comparing using `equal'. See "Display Specs
+ ;; That Replace The Text" in the elisp manual.
+ (if (eq value (cdr pair))
+ (setq prop-values (delq pair prop-values))
+ (setq cont nil))))
+ (when cont
+ (push (pop state) next-state))))
+ ;; End values that should not be included in the next state.
+ (while state
+ (with-current-buffer to-buffer
+ (insert (make-string 1 faceup-markup-end-char)))
+ (pop state))
+ ;; Start new ranges.
+ (with-current-buffer to-buffer
+ (while prop-values
+ (let ((pair (pop prop-values)))
+ (if (memq (car pair) faceup-face-like-properties)
+ ;; Face-like.
+ (dolist (element (cdr pair))
+ (insert (make-string 1 faceup-markup-start-char))
+ (unless (eq (car pair) faceup-default-property)
+ (insert "(")
+ (insert (symbol-name (car pair)))
+ (insert "):"))
+ (if (symbolp element)
+ (let ((short
+ (assq element faceup-face-short-alist)))
+ (if short
+ (insert (cdr short) ":")
+ (insert ":" (symbol-name element) ":")))
+ (insert ":")
+ (prin1 element (current-buffer))
+ (insert ":"))
+ (push (cons (car pair) element) next-state))
+ ;; Not face-like.
+ (insert (make-string 1 faceup-markup-start-char))
+ (insert "(")
+ (insert (symbol-name (car pair)))
+ (insert "):")
+ (prin1 (cdr pair) (current-buffer))
+ (insert ":")
+ (push pair next-state)))))
+ ;; Insert content.
+ (setq state next-state))))
+ ;; Insert whatever is left after the last face change.
+ (faceup-copy-and-quote last-pos (point-max) to-buffer))))
+
+
+
+;; Some basic facts:
+;;
+;; (get-text-property (point-max) ...) always return nil. To check the
+;; last character in the buffer, use (- (point-max) 1).
+;;
+;; If a text has more than one face, the first one in the list
+;; takes precedence, when being viewed in Emacs.
+;;
+;; (let ((s "ABCDEF"))
+;; (set-text-properties 1 4
+;; '(face (font-lock-warning-face font-lock-variable-name-face)) s)
+;; (insert s))
+;;
+;; => ABCDEF
+;;
+;; Where DEF is drawn in "warning" face.
+
+
+(defun faceup-has-any-text-property (pos)
+ "True if any properties in `faceup-properties' are defined at POS."
+ (let ((res nil))
+ (dolist (prop faceup-properties)
+ (when (get-text-property pos prop)
+ (setq res t)))
+ res))
+
+
+(defun faceup-next-single-property-change (pos)
+ "Next position a property in `faceup-properties' changes after POS, or nil."
+ (let ((res nil))
+ (dolist (prop faceup-properties)
+ (let ((next (next-single-property-change pos prop)))
+ (when next
+ (setq res (if res
+ (min res next)
+ next)))))
+ res))
+
+
+(defun faceup-next-property-change (pos)
+ "Next position after POS where one of the tracked properties change.
+
+If POS is nil, also include `point-min' in the search.
+If last character contains a tracked property, return `point-max'.
+
+See `faceup-properties' for a list of tracked properties."
+ (if (eq pos (point-max))
+ ;; Last search returned `point-max'. There is no more to search
+ ;; for.
+ nil
+ (if (and (null pos)
+ (faceup-has-any-text-property (point-min)))
+ ;; `pos' is `nil' and the character at `point-min' contains a
+ ;; tracked property, return `point-min'.
+ (point-min)
+ (unless pos
+ ;; Start from the beginning.
+ (setq pos (point-min)))
+ ;; Do a normal search. Compensate for that
+ ;; `next-single-property-change' does not include the end of the
+ ;; buffer, even when a property reach it.
+ (let ((res (faceup-next-single-property-change pos)))
+ (if (and (not res) ; No more found.
+ (not (eq pos (point-max))) ; Not already at the end.
+ (not (eq (point-min) (point-max))) ; Not an empty buffer.
+ (faceup-has-any-text-property (- (point-max) 1)))
+ ;; If a property goes all the way to the end of the
+ ;; buffer, return `point-max'.
+ (point-max)
+ res)))))
+
+
+;; ----------------------------------------------------------------------
+;; Renderer
+;;
+
+;; Functions to convert from the faceup textual representation to text
+;; with real properties.
+
+(defun faceup-render-string (faceup)
+ "Return string with properties from FACEUP written with Faceup markup."
+ (with-temp-buffer
+ (insert faceup)
+ (faceup-render-to-string)))
+
+
+;;;###autoload
+(defun faceup-render-view-buffer (&optional buffer)
+ "Convert BUFFER containing Faceup markup to a new buffer and display it."
+ (interactive)
+ (with-current-buffer (or buffer (current-buffer))
+ (let ((dest-buffer (get-buffer-create "*FaceUp rendering*")))
+ (with-current-buffer dest-buffer
+ (delete-region (point-min) (point-max)))
+ (faceup-render-to-buffer dest-buffer)
+ (display-buffer dest-buffer))))
+
+
+(defun faceup-render-to-string (&optional buffer)
+ "Convert BUFFER containing faceup markup to a string with faces."
+ (unless buffer
+ (setq buffer (current-buffer)))
+ (with-temp-buffer
+ (faceup-render-to-buffer (current-buffer) buffer)
+ (buffer-substring (point-min) (point-max))))
+
+
+(defun faceup-render-to-buffer (to-buffer &optional buffer)
+ "Convert BUFFER containing faceup markup into text with faces in TO-BUFFER."
+ (with-current-buffer (or buffer (current-buffer))
+ (goto-char (point-min))
+ (let ((last-point (point))
+ (state '()) ; List of (prop . element)
+ (not-markup (concat
+ "^"
+ (make-string 1 faceup-markup-start-char)
+ (make-string 1 faceup-markup-end-char))))
+ (while (progn
+ (skip-chars-forward not-markup)
+ (if (not (eq last-point (point)))
+ (let ((text (buffer-substring-no-properties
+ last-point (point)))
+ (prop-elements-alist '()))
+ ;; Accumulate all values for each property.
+ (dolist (prop-element state)
+ (let ((property (car prop-element))
+ (element (cdr prop-element)))
+ (let ((pair (assq property prop-elements-alist)))
+ (unless pair
+ (setq pair (cons property '()))
+ (push pair prop-elements-alist))
+ (push element (cdr pair)))))
+ ;; Apply all properties.
+ (dolist (pair prop-elements-alist)
+ (let ((property (car pair))
+ (elements (reverse (cdr pair))))
+ ;; Create one of:
+ ;; (property element) or
+ ;; (property (element element ...))
+ (when (eq (length elements) 1)
+ ;; This ensures that non-face-like
+ ;; properties are restored to their
+ ;; original state.
+ (setq elements (car elements)))
+ (add-text-properties 0 (length text)
+ (list property elements)
+ text)))
+ (with-current-buffer to-buffer
+ (insert text))
+ (setq last-point (point))))
+ (not (eobp)))
+ (if (eq (following-char) faceup-markup-start-char)
+ ;; Start marker.
+ (progn
+ (forward-char)
+ (if (or (eq (following-char) faceup-markup-start-char)
+ (eq (following-char) faceup-markup-end-char))
+ ;; Escaped markup character.
+ (progn
+ (setq last-point (point))
+ (forward-char))
+ ;; Markup sequence.
+ (let ((property faceup-default-property))
+ (when (eq (following-char) ?\( )
+ (forward-char) ; "("
+ (let ((p (point)))
+ (forward-sexp)
+ (setq property (intern (buffer-substring p (point)))))
+ (forward-char)) ; ")"
+ (let ((element
+ (if (eq (following-char) ?:)
+ ;; :element:
+ (progn
+ (forward-char)
+ (prog1
+ (let ((p (point)))
+ (forward-sexp)
+ ;; Note: (read (current-buffer))
+ ;; doesn't work, as it reads more
+ ;; than a sexp.
+ (read (buffer-substring p (point))))
+ (forward-char)))
+ ;; X:
+ (prog1
+ (car (rassoc (buffer-substring-no-properties
+ (point) (+ (point) 1))
+ faceup-face-short-alist))
+ (forward-char 2)))))
+ (push (cons property element) state)))
+ (setq last-point (point))))
+ ;; End marker.
+ (pop state)
+ (forward-char)
+ (setq last-point (point)))))))
+
+;; ----------------------------------------------------------------------
+
+;;;###autoload
+(defun faceup-clean-buffer ()
+ "Remove faceup markup from buffer."
+ (interactive)
+ (goto-char (point-min))
+ (let ((not-markup (concat
+ "^"
+ (make-string 1 faceup-markup-start-char)
+ (make-string 1 faceup-markup-end-char))))
+ (while (progn (skip-chars-forward not-markup)
+ (not (eobp)))
+ (if (eq (following-char) faceup-markup-end-char)
+ ;; End markers are always on their own.
+ (delete-char 1)
+ ;; Start marker.
+ (delete-char 1)
+ (if (or (eq (following-char) faceup-markup-start-char)
+ (eq (following-char) faceup-markup-end-char))
+ ;; Escaped markup character, delete the escape and skip
+ ;; the original character.
+ (forward-char)
+ ;; Property name (if present)
+ (if (eq (following-char) ?\( )
+ (let ((p (point)))
+ (forward-sexp)
+ (delete-region p (point))))
+ ;; Markup sequence.
+ (if (eq (following-char) ?:)
+ ;; :value:
+ (let ((p (point)))
+ (forward-char)
+ (forward-sexp)
+ (unless (eobp)
+ (forward-char))
+ (delete-region p (point)))
+ ;; X:
+ (delete-char 1) ; The one-letter form.
+ (delete-char 1))))))) ; The colon.
+
+
+(defun faceup-clean-string (s)
+ "Remove faceup markup from string S."
+ (with-temp-buffer
+ (insert s)
+ (faceup-clean-buffer)
+ (buffer-substring (point-min) (point-max))))
+
+
+;; ----------------------------------------------------------------------
+;; Regression test support
+;;
+
+(defvar faceup-test-explain nil
+ "When non-nil, tester functions returns a text description on failure.
+
+Of course, this only work for test functions aware of this
+variable, like `faceup-test-equal' and functions based on this
+function.
+
+This is intended to be used to simplify `ert' explain functions,
+which could be defined as:
+
+ (defun my-test (args...) ...)
+ (defun my-test-explain (args...)
+ (let ((faceup-test-explain t))
+ (the-test args...)))
+ (put 'my-test 'ert-explainer 'my-test-explain)
+
+Alternative, you can use the macro `faceup-defexplainer' as follows:
+
+ (defun my-test (args...) ...)
+ (faceup-defexplainer my-test)
+
+Test functions, like `faceup-test-font-lock-buffer', built on top
+of `faceup-test-equal', and other functions that adhere to this
+variable, can easily define their own explainer functions.")
+
+;;;###autoload
+(defmacro faceup-defexplainer (function)
+ "Define an Ert explainer function for FUNCTION.
+
+FUNCTION must return an explanation when the test fails and
+`faceup-test-explain' is set."
+ (let ((name (intern (concat (symbol-name function) "-explainer"))))
+ `(progn
+ (defun ,name (&rest args)
+ (let ((faceup-test-explain t))
+ (apply (quote ,function) args)))
+ (put (quote ,function) 'ert-explainer (quote ,name)))))
+
+
+;; ------------------------------
+;; Multi-line string support.
+;;
+
+(defun faceup-test-equal (lhs rhs)
+ "Compares two (multi-line) strings, LHS and RHS, for equality.
+
+This is intended to be used in Ert regression test rules.
+
+When `faceup-test-explain' is non-nil, instead of returning nil
+on inequality, a list is returned with a explanation what
+differs. Currently, this function reports 1) if the number of
+lines in the strings differ. 2) the lines and the line numbers on
+which the string differed.
+
+For example:
+ (let ((a \"ABC\\nDEF\\nGHI\")
+ (b \"ABC\\nXXX\\nGHI\\nZZZ\")
+ (faceup-test-explain t))
+ (message \"%s\" (faceup-test-equal a b)))
+
+ ==> (4 3 number-of-lines-differ (on-line 2 (DEF) (XXX)))
+
+When used in an `ert' rule, the output is as below:
+
+ (ert-deftest faceup-test-equal-example ()
+ (let ((a \"ABC\\nDEF\\nGHI\")
+ (b \"ABC\\nXXX\\nGHI\\nZZZ\"))
+ (should (faceup-test-equal a b))))
+
+ F faceup-test-equal-example
+ (ert-test-failed
+ ((should
+ (faceup-test-equal a b))
+ :form
+ (faceup-test-equal \"ABC\\nDEF\\nGHI\" \"ABC\\nXXX\\nGHI\\nZZZ\")
+ :value nil :explanation
+ (4 3 number-of-lines-differ
+ (on-line 2
+ (\"DEF\")
+ (\"XXX\")))))"
+ (if (equal lhs rhs)
+ t
+ (if faceup-test-explain
+ (let ((lhs-lines (split-string lhs "\n"))
+ (rhs-lines (split-string rhs "\n"))
+ (explanation '())
+ (line 1))
+ (unless (= (length lhs-lines) (length rhs-lines))
+ (setq explanation (list 'number-of-lines-differ
+ (length lhs-lines) (length rhs-lines))))
+ (while lhs-lines
+ (let ((one (pop lhs-lines))
+ (two (pop rhs-lines)))
+ (unless (equal one two)
+ (setq explanation
+ (cons (list 'on-line line (list one) (list two))
+ explanation)))
+ (setq line (+ line 1))))
+ (nreverse explanation))
+ nil)))
+
+(faceup-defexplainer faceup-test-equal)
+
+
+;; ------------------------------
+;; Font-lock regression test support.
+;;
+
+(defun faceup-test-font-lock-buffer (mode faceup &optional buffer)
+ "Verify that BUFFER is fontified as FACEUP for major mode MODE.
+
+If BUFFER is not specified the current buffer is used.
+
+Note that the major mode of the buffer is set to MODE and that
+the buffer is fontified.
+
+If MODE is a list, the first element is the major mode, the
+remaining are additional functions to call, e.g. minor modes."
+ (save-excursion
+ (if buffer
+ (set-buffer buffer))
+ (if (listp mode)
+ (dolist (m mode)
+ (funcall m))
+ (funcall mode))
+ (font-lock-fontify-region (point-min) (point-max))
+ (let ((result (faceup-markup-buffer)))
+ (faceup-test-equal faceup result))))
+
+(faceup-defexplainer faceup-test-font-lock-buffer)
+
+
+(defun faceup-test-font-lock-string (mode faceup)
+ "True if FACEUP is re-fontified as the faceup markup for major mode MODE.
+
+The string FACEUP is stripped from markup, inserted into a
+buffer, the requested major mode activated, the buffer is
+fontified, the result is again converted to the faceup form, and
+compared with the original string."
+ (with-temp-buffer
+ (insert faceup)
+ (faceup-clean-buffer)
+ (faceup-test-font-lock-buffer mode faceup)))
+
+(faceup-defexplainer faceup-test-font-lock-string)
+
+
+(defun faceup-test-font-lock-file (mode file &optional faceup-file)
+ "Verify that FILE is fontified as FACEUP-FILE for major mode MODE.
+
+If FACEUP-FILE is omitted, FILE.faceup is used."
+ (unless faceup-file
+ (setq faceup-file (concat file ".faceup")))
+ (let ((faceup (with-temp-buffer
+ (insert-file-contents faceup-file)
+ (buffer-substring-no-properties (point-min) (point-max)))))
+ (with-temp-buffer
+ (insert-file-contents file)
+ (faceup-test-font-lock-buffer mode faceup))))
+
+(faceup-defexplainer faceup-test-font-lock-file)
+
+
+;; ------------------------------
+;; Get current file directory. Test cases can use this to locate test
+;; files.
+;;
+
+(defun faceup-this-file-directory ()
+ "The directory of the file where the call to this function is located in.
+Intended to be called when a file is loaded."
+ (expand-file-name
+ (if load-file-name
+ ;; File is being loaded.
+ (file-name-directory load-file-name)
+ ;; File is being evaluated using, for example, `eval-buffer'.
+ default-directory)))
+
+
+;; ----------------------------------------------------------------------
+;; The end
+;;
+
+(provide 'faceup)
+
+;;; faceup.el ends here
diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el
index 9d1e43b0fe8..b63d4d4e0a9 100644
--- a/lisp/emacs-lisp/find-func.el
+++ b/lisp/emacs-lisp/find-func.el
@@ -368,28 +368,30 @@ The search is done in the source for library LIBRARY."
(concat "\\\\?"
(regexp-quote (symbol-name symbol))))))
(case-fold-search))
- (with-syntax-table emacs-lisp-mode-syntax-table
- (goto-char (point-min))
- (if (if (functionp regexp)
- (funcall regexp symbol)
- (or (re-search-forward regexp nil t)
- ;; `regexp' matches definitions using known forms like
- ;; `defun', or `defvar'. But some functions/variables
- ;; are defined using special macros (or functions), so
- ;; if `regexp' can't find the definition, we look for
- ;; something of the form "(SOMETHING <symbol> ...)".
- ;; This fails to distinguish function definitions from
- ;; variable declarations (or even uses thereof), but is
- ;; a good pragmatic fallback.
- (re-search-forward
- (concat "^([^ ]+" find-function-space-re "['(]?"
- (regexp-quote (symbol-name symbol))
- "\\_>")
- nil t)))
- (progn
- (beginning-of-line)
- (cons (current-buffer) (point)))
- (cons (current-buffer) nil))))))))
+ (save-restriction
+ (widen)
+ (with-syntax-table emacs-lisp-mode-syntax-table
+ (goto-char (point-min))
+ (if (if (functionp regexp)
+ (funcall regexp symbol)
+ (or (re-search-forward regexp nil t)
+ ;; `regexp' matches definitions using known forms like
+ ;; `defun', or `defvar'. But some functions/variables
+ ;; are defined using special macros (or functions), so
+ ;; if `regexp' can't find the definition, we look for
+ ;; something of the form "(SOMETHING <symbol> ...)".
+ ;; This fails to distinguish function definitions from
+ ;; variable declarations (or even uses thereof), but is
+ ;; a good pragmatic fallback.
+ (re-search-forward
+ (concat "^([^ ]+" find-function-space-re "['(]?"
+ (regexp-quote (symbol-name symbol))
+ "\\_>")
+ nil t)))
+ (progn
+ (beginning-of-line)
+ (cons (current-buffer) (point)))
+ (cons (current-buffer) nil)))))))))
(defun find-function-library (function &optional lisp-only verbose)
"Return the pair (ORIG-FUNCTION . LIBRARY) for FUNCTION.
@@ -464,6 +466,7 @@ If TYPE is nil, defaults using `function-called-at-point',
otherwise uses `variable-at-point'."
(let* ((symb1 (cond ((null type) (function-called-at-point))
((eq type 'defvar) (variable-at-point))
+ ((eq type 'defface) (face-at-point t))
(t (variable-at-point t))))
(symb (unless (eq symb1 0) symb1))
(predicate (cdr (assq type '((nil . fboundp)
diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el
index 0f4149eacd5..caf5fed154b 100644
--- a/lisp/emacs-lisp/generator.el
+++ b/lisp/emacs-lisp/generator.el
@@ -213,8 +213,8 @@ don't yield.")
;; Process `and'.
- (`(and) ; (and) -> t
- (cps--transform-1 t next-state))
+ ('(and) ; (and) -> t
+ (cps--transform-1 t next-state))
(`(and ,condition) ; (and CONDITION) -> CONDITION
(cps--transform-1 condition next-state))
(`(and ,condition . ,rest)
@@ -246,8 +246,8 @@ don't yield.")
;; Process `cond': transform into `if' or `or' depending on the
;; precise kind of the condition we're looking at.
- (`(cond) ; (cond) -> nil
- (cps--transform-1 nil next-state))
+ ('(cond) ; (cond) -> nil
+ (cps--transform-1 nil next-state))
(`(cond (,condition) . ,rest)
(cps--transform-1 `(or ,condition (cond ,@rest))
next-state))
@@ -281,14 +281,14 @@ don't yield.")
;; Process `progn' and `inline': they are identical except for the
;; name, which has some significance to the byte compiler.
- (`(inline) (cps--transform-1 nil next-state))
+ ('(inline) (cps--transform-1 nil next-state))
(`(inline ,form) (cps--transform-1 form next-state))
(`(inline ,form . ,rest)
(cps--transform-1 form
(cps--transform-1 `(inline ,@rest)
next-state)))
- (`(progn) (cps--transform-1 nil next-state))
+ ('(progn) (cps--transform-1 nil next-state))
(`(progn ,form) (cps--transform-1 form next-state))
(`(progn ,form . ,rest)
(cps--transform-1 form
@@ -345,7 +345,7 @@ don't yield.")
;; Process `or'.
- (`(or) (cps--transform-1 nil next-state))
+ ('(or) (cps--transform-1 nil next-state))
(`(or ,condition) (cps--transform-1 condition next-state))
(`(or ,condition . ,rest)
(cps--transform-1
@@ -374,13 +374,6 @@ don't yield.")
`(setf ,cps--value-symbol ,temp-var-symbol
,cps--state-symbol ,next-state))))))))
- ;; Process `prog2'.
-
- (`(prog2 ,form1 ,form2 . ,body)
- (cps--transform-1
- `(progn ,form1 (prog1 ,form2 ,@body))
- next-state))
-
;; Process `unwind-protect': If we're inside an unwind-protect, we
;; have a block of code UNWINDFORMS which we would like to run
;; whenever control flows away from the main piece of code,
@@ -567,8 +560,11 @@ modified copy."
(unless ,normal-exit-symbol
,@unwind-forms))))))
-(put 'iter-end-of-sequence 'error-conditions '(iter-end-of-sequence))
-(put 'iter-end-of-sequence 'error-message "iteration terminated")
+(define-error 'iter-end-of-sequence "Iteration terminated"
+ ;; FIXME: This was not defined originally as an `error' condition, so
+ ;; we reproduce this by passing itself as the parent, which avoids the
+ ;; default `error' parent. Maybe it *should* be in the `error' category?
+ 'iter-end-of-sequence)
(defun cps--make-close-iterator-form (terminal-state)
(if cps--cleanup-table-symbol
@@ -643,11 +639,11 @@ modified copy."
,(cps--make-close-iterator-form terminal-state)))))
(t (error "unknown iterator operation %S" op))))))
,(when finalizer-symbol
- `(funcall iterator
- :stash-finalizer
- (make-finalizer
- (lambda ()
- (iter-close iterator)))))
+ '(funcall iterator
+ :stash-finalizer
+ (make-finalizer
+ (lambda ()
+ (iter-close iterator)))))
iterator))))
(defun iter-yield (value)
@@ -700,6 +696,14 @@ of values. Callers can retrieve each value using `iter-next'."
`(lambda ,arglist
,(cps-generate-evaluator body)))
+(defmacro iter-make (&rest body)
+ "Return a new iterator."
+ (declare (debug t))
+ (cps-generate-evaluator body))
+
+(defconst iter-empty (lambda (_op _val) (signal 'iter-end-of-sequence nil))
+ "Trivial iterator that always signals the end of sequence.")
+
(defun iter-next (iterator &optional yield-result)
"Extract a value from an iterator.
YIELD-RESULT becomes the return value of `iter-yield' in the
diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el
index 4ef9ab694bb..678d384da4a 100644
--- a/lisp/emacs-lisp/generic.el
+++ b/lisp/emacs-lisp/generic.el
@@ -96,8 +96,6 @@
;; Internal Variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define-obsolete-variable-alias 'generic-font-lock-defaults
- 'generic-font-lock-keywords "22.1")
(defvar generic-font-lock-keywords nil
"Keywords for `font-lock-defaults' in a generic mode.")
(make-variable-buffer-local 'generic-font-lock-keywords)
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index deeb833e1f8..4ea3ce84fc6 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -217,6 +217,8 @@ to be pure and copyable. Example use:
(declare (indent 2) (debug (&define name sexp body)))
`(gv-define-expander ,name
(lambda (do &rest args)
+ (declare-function
+ gv--defsetter "gv" (name setter do args &optional vars))
(gv--defsetter ',name (lambda ,arglist ,@body) do args))))
;;;###autoload
@@ -303,11 +305,14 @@ The return value is the last VAL in the list.
(lambda (do before index place)
(gv-letplace (getter setter) place
(funcall do `(edebug-after ,before ,index ,getter)
- setter))))
+ (lambda (store)
+ `(progn (edebug-after ,before ,index ,getter)
+ ,(funcall setter store)))))))
;;; The common generalized variables.
(gv-define-simple-setter aref aset)
+(gv-define-simple-setter char-table-range set-char-table-range)
(gv-define-simple-setter car setcar)
(gv-define-simple-setter cdr setcdr)
;; FIXME: add compiler-macros for `cXXr' instead!
diff --git a/lisp/emacs-lisp/inline.el b/lisp/emacs-lisp/inline.el
index 1bccf2e0576..70dbff2147d 100644
--- a/lisp/emacs-lisp/inline.el
+++ b/lisp/emacs-lisp/inline.el
@@ -259,7 +259,7 @@ See Info node `(elisp)Defining Functions' for more details."
`(error ,@args))
(defun inline--warning (&rest _args)
- `(throw 'inline--just-use
+ '(throw 'inline--just-use
;; FIXME: This would inf-loop by calling us right back when
;; macroexpand-all recurses to expand inline--form.
;; (macroexp--warn-and-return (format ,@args)
diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el
index 6cad17a4a1b..91c76158a31 100644
--- a/lisp/emacs-lisp/lisp-mnt.el
+++ b/lisp/emacs-lisp/lisp-mnt.el
@@ -1,4 +1,4 @@
-;;; lisp-mnt.el --- utility functions for Emacs Lisp maintainers
+;;; lisp-mnt.el --- utility functions for Emacs Lisp maintainers -*- lexical-binding:t -*-
;; Copyright (C) 1992, 1994, 1997, 2000-2019 Free Software Foundation,
;; Inc.
@@ -137,34 +137,28 @@ in your Lisp package:
The @(#) construct is used by unix what(1) and
then $identifier: doc string $ is used by GNU ident(1)"
- :type 'regexp
- :group 'lisp-mnt)
+ :type 'regexp)
(defcustom lm-copyright-prefix "^\\(;+[ \t]\\)+Copyright (C) "
"Prefix that is ignored before the dates in a copyright.
Leading comment characters and whitespace should be in regexp group 1."
- :type 'regexp
- :group 'lisp-mnt)
+ :type 'regexp)
(defcustom lm-comment-column 16
"Column used for placing formatted output."
- :type 'integer
- :group 'lisp-mnt)
+ :type 'integer)
(defcustom lm-any-header ".*"
"Regexp which matches start of any section."
- :type 'regexp
- :group 'lisp-mnt)
+ :type 'regexp)
(defcustom lm-commentary-header "Commentary\\|Documentation"
"Regexp which matches start of documentation section."
- :type 'regexp
- :group 'lisp-mnt)
+ :type 'regexp)
(defcustom lm-history-header "Change ?Log\\|History"
"Regexp which matches the start of code log section."
- :type 'regexp
- :group 'lisp-mnt)
+ :type 'regexp)
;;; Functions:
@@ -236,26 +230,26 @@ a section."
(while (forward-comment 1))
(point))))))))
-(defsubst lm-code-start ()
+(defun lm-code-start ()
"Return the buffer location of the `Code' start marker."
(lm-section-start "Code"))
(defalias 'lm-code-mark 'lm-code-start)
-(defsubst lm-commentary-start ()
+(defun lm-commentary-start ()
"Return the buffer location of the `Commentary' start marker."
(lm-section-start lm-commentary-header))
(defalias 'lm-commentary-mark 'lm-commentary-start)
-(defsubst lm-commentary-end ()
+(defun lm-commentary-end ()
"Return the buffer location of the `Commentary' section end."
(lm-section-end lm-commentary-header))
-(defsubst lm-history-start ()
+(defun lm-history-start ()
"Return the buffer location of the `History' start marker."
(lm-section-start lm-history-header))
(defalias 'lm-history-mark 'lm-history-start)
-(defsubst lm-copyright-mark ()
+(defun lm-copyright-mark ()
"Return the buffer location of the `Copyright' line."
(save-excursion
(let ((case-fold-search t))
@@ -385,7 +379,7 @@ Each element of the list is a cons; the car is the full name,
the cdr is an email address."
(lm-with-file file
(let ((authorlist (lm-header-multiline "author")))
- (mapcar 'lm-crack-address authorlist))))
+ (mapcar #'lm-crack-address authorlist))))
(defun lm-maintainer (&optional file)
"Return the maintainer of file FILE, or current buffer if FILE is nil.
@@ -453,7 +447,7 @@ each line."
(lm-with-file file
(let ((keywords (lm-header-multiline "keywords")))
(and keywords
- (mapconcat 'downcase keywords " ")))))
+ (mapconcat #'downcase keywords " ")))))
(defun lm-keywords-list (&optional file)
"Return list of keywords given in file FILE."
@@ -507,7 +501,7 @@ absent, return nil."
"Insert, at column COL, list of STRINGS."
(if (> (current-column) col) (insert "\n"))
(move-to-column col t)
- (apply 'insert strings))
+ (apply #'insert strings))
(defun lm-verify (&optional file showok verbose non-fsf-ok)
"Check that the current buffer (or FILE if given) is in proper format.
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 57f57175c51..4c7a8bea3fb 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -461,11 +461,6 @@ This will generate compile-time constants from BINDINGS."
(throw 'found t)))))))
(1 'font-lock-regexp-grouping-backslash prepend)
(3 'font-lock-regexp-grouping-construct prepend))
- ;; This is too general -- rms.
- ;; A user complained that he has functions whose names start with `do'
- ;; and that they get the wrong color.
- ;; ;; CL `with-' and `do-' constructs
- ;;("(\\(\\(do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face)
(lisp--match-hidden-arg
(0 '(face font-lock-warning-face
help-echo "Hidden behind deeper element; move to another line?")))
@@ -491,6 +486,11 @@ This will generate compile-time constants from BINDINGS."
(,(concat "[`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)"
lisp-mode-symbol-regexp "\\)['’]")
(1 font-lock-constant-face prepend))
+ ;; Uninterned symbols, e.g., (defpackage #:my-package ...)
+ ;; must come before keywords below to have effect
+ (,(concat "\\(#:\\)\\(" lisp-mode-symbol-regexp "\\)")
+ (1 font-lock-comment-delimiter-face)
+ (2 font-lock-doc-face))
;; Constant values.
(,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>")
(0 font-lock-builtin-face))
@@ -500,8 +500,10 @@ This will generate compile-time constants from BINDINGS."
;; This is too general -- rms.
;; A user complained that he has functions whose names start with `do'
;; and that they get the wrong color.
- ;; ;; CL `with-' and `do-' constructs
- ;;("(\\(\\(do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face)
+ ;; That user has violated the http://www.cliki.net/Naming+conventions:
+ ;; CL (but not EL!) `with-' (context) and `do-' (iteration)
+ (,(concat "(\\(\\(do-\\|with-\\)" lisp-mode-symbol-regexp "\\)")
+ (1 font-lock-keyword-face))
(lisp--match-hidden-arg
(0 '(face font-lock-warning-face
help-echo "Hidden behind deeper element; move to another line?")))
@@ -515,6 +517,16 @@ This will generate compile-time constants from BINDINGS."
(defvar lisp-cl-font-lock-keywords lisp-cl-font-lock-keywords-1
"Default expressions to highlight in Lisp modes.")
+;; Support backtrace mode.
+(defconst lisp-el-font-lock-keywords-for-backtraces lisp-el-font-lock-keywords
+ "Default highlighting from Emacs Lisp mod used in Backtrace mode.")
+(defconst lisp-el-font-lock-keywords-for-backtraces-1 lisp-el-font-lock-keywords-1
+ "Subdued highlighting from Emacs Lisp mode used in Backtrace mode.")
+(defconst lisp-el-font-lock-keywords-for-backtraces-2
+ (remove (assoc 'lisp--match-hidden-arg lisp-el-font-lock-keywords-2)
+ lisp-el-font-lock-keywords-2)
+ "Gaudy highlighting from Emacs Lisp mode used in Backtrace mode.")
+
(defun lisp-string-in-doc-position-p (listbeg startpos)
"Return true if a doc string may occur at STARTPOS inside a list.
LISTBEG is the position of the start of the innermost list
@@ -871,9 +883,7 @@ by more than one line to cross a string literal."
(interactive)
(let ((pos (- (point-max) (point)))
(indent (progn (beginning-of-line)
- (or indent (calculate-lisp-indent (lisp-ppss)))))
- (shift-amt nil)
- (beg (progn (beginning-of-line) (point))))
+ (or indent (calculate-lisp-indent (lisp-ppss))))))
(skip-chars-forward " \t")
(if (or (null indent) (looking-at "\\s<\\s<\\s<"))
;; Don't alter indentation of a ;;; comment line
@@ -885,11 +895,7 @@ by more than one line to cross a string literal."
;; as comment lines, not as code.
(progn (indent-for-comment) (forward-char -1))
(if (listp indent) (setq indent (car indent)))
- (setq shift-amt (- indent (current-column)))
- (if (zerop shift-amt)
- nil
- (delete-region beg (point))
- (indent-to indent)))
+ (indent-line-to indent))
;; If initial point was within line's indentation,
;; position after the indentation. Else stay at same point in text.
(if (> (- (point-max) pos) (point))
@@ -1177,7 +1183,6 @@ Lisp function does not specify a special indentation."
(put 'autoload 'lisp-indent-function 'defun) ;Elisp
(put 'progn 'lisp-indent-function 0)
(put 'prog1 'lisp-indent-function 1)
-(put 'prog2 'lisp-indent-function 2)
(put 'save-excursion 'lisp-indent-function 0) ;Elisp
(put 'save-restriction 'lisp-indent-function 0) ;Elisp
(put 'save-current-buffer 'lisp-indent-function 0) ;Elisp
diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el
index 0fe18b6e94c..d10d5f0d101 100644
--- a/lisp/emacs-lisp/lisp.el
+++ b/lisp/emacs-lisp/lisp.el
@@ -339,12 +339,18 @@ is called as a function to find the defun's beginning."
((or defun-prompt-regexp open-paren-in-column-0-is-defun-start)
(and (< arg 0) (not (eobp)) (forward-char 1))
- (and (re-search-backward (if defun-prompt-regexp
- (concat (if open-paren-in-column-0-is-defun-start
- "^\\s(\\|" "")
- "\\(?:" defun-prompt-regexp "\\)\\s(")
- "^\\s(")
- nil 'move arg)
+ (and (let (found)
+ (while
+ (and (setq found
+ (re-search-backward
+ (if defun-prompt-regexp
+ (concat (if open-paren-in-column-0-is-defun-start
+ "^\\s(\\|" "")
+ "\\(?:" defun-prompt-regexp "\\)\\s(")
+ "^\\s(")
+ nil 'move arg))
+ (nth 8 (syntax-ppss))))
+ found)
(progn (goto-char (1- (match-end 0)))
t)))
@@ -717,11 +723,13 @@ This command assumes point is not in a string or comment."
(interactive "P")
(insert-pair arg ?\( ?\)))
-(defun delete-pair ()
- "Delete a pair of characters enclosing the sexp that follows point."
- (interactive)
- (save-excursion (forward-sexp 1) (delete-char -1))
- (delete-char 1))
+(defun delete-pair (&optional arg)
+ "Delete a pair of characters enclosing ARG sexps following point.
+A negative ARG deletes a pair of characters around preceding ARG sexps."
+ (interactive "p")
+ (unless arg (setq arg 1))
+ (save-excursion (forward-sexp arg) (delete-char (if (> arg 0) -1 1)))
+ (delete-char (if (> arg 0) 1 -1)))
(defun raise-sexp (&optional arg)
"Raise ARG sexps higher up the tree."
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index eabd5041978..9af75320ec0 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -94,7 +94,7 @@ each clause."
clause)))
(defun macroexp--compiler-macro (handler form)
- (condition-case err
+ (condition-case-unless-debug err
(apply handler form (cdr form))
(error
(message "Compiler-macro error for %S: %S" (car form) err)
@@ -222,15 +222,15 @@ Assumes the caller has bound `macroexpand-all-environment'."
(cddr form))
(cdr form))
form))
- (`(,(or `defvar `defconst) . ,_) (macroexp--all-forms form 2))
+ (`(,(or 'defvar 'defconst) . ,_) (macroexp--all-forms form 2))
(`(function ,(and f `(lambda . ,_)))
(macroexp--cons 'function
(macroexp--cons (macroexp--all-forms f 2)
nil
(cdr form))
form))
- (`(,(or `function `quote) . ,_) form)
- (`(,(and fun (or `let `let*)) . ,(or `(,bindings . ,body) dontcare))
+ (`(,(or 'function 'quote) . ,_) form)
+ (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) dontcare))
(macroexp--cons fun
(macroexp--cons (macroexp--all-clauses bindings 1)
(macroexp--all-forms body)
@@ -249,14 +249,14 @@ Assumes the caller has bound `macroexpand-all-environment'."
;; here, so that any code that cares about the difference will
;; see the same transformation.
;; First arg is a function:
- (`(,(and fun (or `funcall `apply `mapcar `mapatoms `mapconcat `mapc))
+ (`(,(and fun (or 'funcall 'apply 'mapcar 'mapatoms 'mapconcat 'mapc))
',(and f `(lambda . ,_)) . ,args)
(macroexp--warn-and-return
(format "%s quoted with ' rather than with #'"
(list 'lambda (nth 1 f) '...))
(macroexp--expand-all `(,fun ,f . ,args))))
;; Second arg is a function:
- (`(,(and fun (or `sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args)
+ (`(,(and fun (or 'sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args)
(macroexp--warn-and-return
(format "%s quoted with ' rather than with #'"
(list 'lambda (nth 1 f) '...))
@@ -406,7 +406,7 @@ cases where EXP is a constant."
"Bind each binding in BINDINGS as `macroexp-let2' does."
(declare (indent 2) (debug (sexp (&rest (sexp form)) body)))
(pcase-exhaustive bindings
- (`nil (macroexp-progn body))
+ ('nil (macroexp-progn body))
(`((,var ,exp) . ,tl)
`(macroexp-let2 ,test ,var ,exp
(macroexp-let2* ,test ,tl ,@body)))))
diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el
index 6bd209538bf..a688330b74a 100644
--- a/lisp/emacs-lisp/map-ynp.el
+++ b/lisp/emacs-lisp/map-ynp.el
@@ -192,34 +192,30 @@ Returns the number of actions taken."
(funcall actor elt)
(setq actions (1+ actions))))))
((eq def 'help)
- (with-output-to-temp-buffer "*Help*"
+ (with-help-window (help-buffer)
(princ
- (let ((object (if help (nth 0 help) "object"))
- (objects (if help (nth 1 help) "objects"))
- (action (if help (nth 2 help) "act on")))
+ (let ((object (or (nth 0 help) "object"))
+ (objects (or (nth 1 help) "objects"))
+ (action (or (nth 2 help) "act on")))
(concat
- (format-message "\
+ (format-message
+ "\
Type SPC or `y' to %s the current %s;
DEL or `n' to skip the current %s;
-RET or `q' to give up on the %s (skip all remaining %s);
+RET or `q' to skip the current and all remaining %s;
C-g to quit (cancel the whole command);
! to %s all remaining %s;\n"
- action object object action objects action
- objects)
- (mapconcat (function
- (lambda (elt)
- (format "%s to %s"
- (single-key-description
- (nth 0 elt))
- (nth 2 elt))))
+ action object object objects action objects)
+ (mapconcat (lambda (elt)
+ (format "%s to %s;\n"
+ (single-key-description
+ (nth 0 elt))
+ (nth 2 elt)))
action-alist
- ";\n")
- (if action-alist ";\n")
- (format "or . (period) to %s \
-the current %s and exit."
- action object))))
- (with-current-buffer standard-output
- (help-mode)))
+ "")
+ (format
+ "or . (period) to %s the current %s and exit."
+ action object)))))
(funcall try-again))
((and (symbolp def) (commandp def))
diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el
index 47de28f8f9e..54e802edf4f 100644
--- a/lisp/emacs-lisp/map.el
+++ b/lisp/emacs-lisp/map.el
@@ -4,7 +4,8 @@
;; Author: Nicolas Petton <nicolas@petton.fr>
;; Keywords: convenience, map, hash-table, alist, array
-;; Version: 1.2
+;; Version: 2.0
+;; Package-Requires: ((emacs "25"))
;; Package: map
;; Maintainer: emacs-devel@gnu.org
@@ -92,17 +93,21 @@ Returns the result of evaluating the form associated with MAP-VAR's type."
`(cond ((listp ,map-var) ,(plist-get args :list))
((hash-table-p ,map-var) ,(plist-get args :hash-table))
((arrayp ,map-var) ,(plist-get args :array))
- (t (error "Unsupported map: %s" ,map-var)))))
+ (t (error "Unsupported map type `%S': %S"
+ (type-of ,map-var) ,map-var)))))
-(defun map-elt (map key &optional default testfn)
+(define-error 'map-not-inplace "Cannot modify map in-place")
+
+(defsubst map--plist-p (list)
+ (and (consp list) (not (listp (car list)))))
+
+(cl-defgeneric map-elt (map key &optional default testfn)
"Lookup KEY in MAP and return its associated value.
If KEY is not found, return DEFAULT which defaults to nil.
-If MAP is a list, `eql' is used to lookup KEY. Optional argument
-TESTFN, if non-nil, means use its function definition instead of
-`eql'.
+TESTFN is deprecated. Its default depends on the MAP argument.
-MAP can be a list, hash-table or array."
+In the base definition, MAP can be an alist, hash-table, or array."
(declare
(gv-expander
(lambda (do)
@@ -110,17 +115,23 @@ MAP can be a list, hash-table or array."
(macroexp-let2* nil
;; Eval them once and for all in the right order.
((key key) (default default) (testfn testfn))
- `(if (listp ,mgetter)
- ;; Special case the alist case, since it can't be handled by the
- ;; map--put function.
- ,(gv-get `(alist-get ,key (gv-synthetic-place
- ,mgetter ,msetter)
- ,default nil ,testfn)
- do)
- ,(funcall do `(map-elt ,mgetter ,key ,default)
- (lambda (v) `(map--put ,mgetter ,key ,v)))))))))
+ (funcall do `(map-elt ,mgetter ,key ,default)
+ (lambda (v)
+ `(condition-case nil
+ ;; Silence warnings about the hidden 4th arg.
+ (with-no-warnings (map-put! ,mgetter ,key ,v ,testfn))
+ (map-not-inplace
+ ,(funcall msetter
+ `(map-insert ,mgetter ,key ,v))))))))))
+ ;; `testfn' is deprecated.
+ (advertised-calling-convention (map key &optional default) "27.1"))
(map--dispatch map
- :list (alist-get key map default nil testfn)
+ :list (if (map--plist-p map)
+ (let ((res (plist-get map key)))
+ (if (and default (null res) (not (plist-member map key)))
+ default
+ res))
+ (alist-get key map default nil testfn))
:hash-table (gethash key map default)
:array (if (and (>= key 0) (< key (seq-length map)))
(seq-elt map key)
@@ -133,16 +144,34 @@ with VALUE.
When MAP is a list, test equality with TESTFN if non-nil, otherwise use `eql'.
MAP can be a list, hash-table or array."
+ (declare (obsolete "use map-put! or (setf (map-elt ...) ...) instead" "27.1"))
`(setf (map-elt ,map ,key nil ,testfn) ,value))
-(defun map-delete (map key)
- "Delete KEY from MAP and return MAP.
-No error is signaled if KEY is not a key of MAP. If MAP is an
-array, store nil at the index KEY.
-
-MAP can be a list, hash-table or array."
+(defun map--plist-delete (map key)
+ (let ((tail map) last)
+ (while (consp tail)
+ (cond
+ ((not (equal key (car tail)))
+ (setq last tail)
+ (setq tail (cddr last)))
+ (last
+ (setq tail (cddr tail))
+ (setf (cddr last) tail))
+ (t
+ (cl-assert (eq tail map))
+ (setq map (cddr map))
+ (setq tail map))))
+ map))
+
+(cl-defgeneric map-delete (map key)
+ "Delete KEY in-place from MAP and return MAP.
+No error is signaled if KEY is not a key of MAP.
+If MAP is an array, store nil at the index KEY."
(map--dispatch map
- :list (setf (alist-get key map nil t) nil)
+ ;; FIXME: Signal map-not-inplace i.s.o returning a different list?
+ :list (if (map--plist-p map)
+ (setq map (map--plist-delete map key))
+ (setf (alist-get key map nil t) nil))
:hash-table (remhash key map)
:array (and (>= key 0)
(<= key (seq-length map))
@@ -160,120 +189,133 @@ Map can be a nested map composed of alists, hash-tables and arrays."
map)
default))
-(defun map-keys (map)
+(cl-defgeneric map-keys (map)
"Return the list of keys in MAP.
-
-MAP can be a list, hash-table or array."
+The default implementation delegates to `map-apply'."
(map-apply (lambda (key _) key) map))
-(defun map-values (map)
+(cl-defgeneric map-values (map)
"Return the list of values in MAP.
-
-MAP can be a list, hash-table or array."
+The default implementation delegates to `map-apply'."
(map-apply (lambda (_ value) value) map))
-(defun map-pairs (map)
+(cl-defgeneric map-pairs (map)
"Return the elements of MAP as key/value association lists.
-
-MAP can be a list, hash-table or array."
+The default implementation delegates to `map-apply'."
(map-apply #'cons map))
-(defun map-length (map)
- "Return the length of MAP.
-
-MAP can be a list, hash-table or array."
- (length (map-keys map)))
-
-(defun map-copy (map)
- "Return a copy of MAP.
-
-MAP can be a list, hash-table or array."
+(cl-defgeneric map-length (map)
+ ;; FIXME: Should we rename this to `map-size'?
+ "Return the number of elements in the map.
+The default implementation counts `map-keys'."
+ (cond
+ ((hash-table-p map) (hash-table-count map))
+ ((listp map)
+ ;; FIXME: What about repeated/shadowed keys?
+ (if (map--plist-p map) (/ (length map) 2) (length map)))
+ ((arrayp map) (length map))
+ (t (length (map-keys map)))))
+
+(cl-defgeneric map-copy (map)
+ "Return a copy of MAP."
+ ;; FIXME: Clarify how deep is the copy!
(map--dispatch map
- :list (seq-copy map)
+ :list (seq-copy map) ;FIXME: Probably not deep enough for alists!
:hash-table (copy-hash-table map)
:array (seq-copy map)))
-(defun map-apply (function map)
+(cl-defgeneric map-apply (function map)
"Apply FUNCTION to each element of MAP and return the result as a list.
FUNCTION is called with two arguments, the key and the value.
+The default implementation delegates to `map-do'."
+ (let ((res '()))
+ (map-do (lambda (k v) (push (funcall function k v) res)) map)
+ (nreverse res)))
-MAP can be a list, hash-table or array."
- (funcall (map--dispatch map
- :list #'map--apply-alist
- :hash-table #'map--apply-hash-table
- :array #'map--apply-array)
- function
- map))
-
-(defun map-do (function map)
+(cl-defgeneric map-do (function map)
"Apply FUNCTION to each element of MAP and return nil.
-FUNCTION is called with two arguments, the key and the value."
- (funcall (map--dispatch map
- :list #'map--do-alist
- :hash-table #'maphash
- :array #'map--do-array)
- function
- map))
-
-(defun map-keys-apply (function map)
- "Return the result of applying FUNCTION to each key of MAP.
+FUNCTION is called with two arguments, the key and the value.")
-MAP can be a list, hash-table or array."
+;; FIXME: I wish there was a way to avoid this η-redex!
+(cl-defmethod map-do (function (map hash-table)) (maphash function map))
+
+(cl-defgeneric map-keys-apply (function map)
+ "Return the result of applying FUNCTION to each key of MAP.
+The default implementation delegates to `map-apply'."
(map-apply (lambda (key _)
(funcall function key))
map))
-(defun map-values-apply (function map)
+(cl-defgeneric map-values-apply (function map)
"Return the result of applying FUNCTION to each value of MAP.
-
-MAP can be a list, hash-table or array."
+The default implementation delegates to `map-apply'."
(map-apply (lambda (_ val)
(funcall function val))
map))
-(defun map-filter (pred map)
+(cl-defgeneric map-filter (pred map)
"Return an alist of key/val pairs for which (PRED key val) is non-nil in MAP.
-
-MAP can be a list, hash-table or array."
+The default implementation delegates to `map-apply'."
(delq nil (map-apply (lambda (key val)
(if (funcall pred key val)
(cons key val)
nil))
map)))
-(defun map-remove (pred map)
+(cl-defgeneric map-remove (pred map)
"Return an alist of the key/val pairs for which (PRED key val) is nil in MAP.
-
-MAP can be a list, hash-table or array."
+The default implementation delegates to `map-filter'."
(map-filter (lambda (key val) (not (funcall pred key val)))
map))
-(defun mapp (map)
- "Return non-nil if MAP is a map (list, hash-table or array)."
+(cl-defgeneric mapp (map)
+ "Return non-nil if MAP is a map (alist, hash-table, array, ...)."
(or (listp map)
(hash-table-p map)
(arrayp map)))
-(defun map-empty-p (map)
+(cl-defgeneric map-empty-p (map)
"Return non-nil if MAP is empty.
+The default implementation delegates to `map-length'."
+ (zerop (map-length map)))
+
+(cl-defmethod map-empty-p ((map list))
+ (null map))
+
+(cl-defgeneric map-contains-key (map key &optional testfn)
+ ;; FIXME: The test function to use generally depends on the map object,
+ ;; so specifying `testfn' here is problematic: e.g. for hash-tables
+ ;; we shouldn't use `gethash' unless `testfn' is the same as the map's own
+ ;; test function!
+ "Return non-nil If and only if MAP contains KEY.
+TESTFN is deprecated. Its default depends on MAP.
+The default implementation delegates to `map-do'."
+ (unless testfn (setq testfn #'equal))
+ (catch 'map--catch
+ (map-do (lambda (k _v)
+ (if (funcall testfn key k) (throw 'map--catch t)))
+ map)
+ nil))
-MAP can be a list, hash-table or array."
- (map--dispatch map
- :list (null map)
- :array (seq-empty-p map)
- :hash-table (zerop (hash-table-count map))))
-
-(defun map-contains-key (map key &optional testfn)
- "If MAP contain KEY return KEY, nil otherwise.
-Equality is defined by TESTFN if non-nil or by `equal' if nil.
-
-MAP can be a list, hash-table or array."
- (seq-contains (map-keys map) key testfn))
-
-(defun map-some (pred map)
- "Return a non-nil if (PRED key val) is non-nil for any key/value pair in MAP.
-
-MAP can be a list, hash-table or array."
+(cl-defmethod map-contains-key ((map list) key &optional testfn)
+ (let ((v '(nil)))
+ (not (eq v (alist-get key map v nil (or testfn #'equal))))))
+
+(cl-defmethod map-contains-key ((map array) key &optional _testfn)
+ (and (integerp key)
+ (>= key 0)
+ (< key (length map))))
+
+(cl-defmethod map-contains-key ((map hash-table) key &optional _testfn)
+ (let ((v '(nil)))
+ (not (eq v (gethash key map v)))))
+
+(cl-defgeneric map-some (pred map)
+ "Return the first non-nil (PRED key val) in MAP.
+The default implementation delegates to `map-apply'."
+ ;; FIXME: Not sure if there's much benefit to defining it as defgeneric,
+ ;; since as defined, I can't think of a map-type where we could provide an
+ ;; algorithmically more efficient algorithm than the default.
(catch 'map--break
(map-apply (lambda (key value)
(let ((result (funcall pred key value)))
@@ -282,10 +324,12 @@ MAP can be a list, hash-table or array."
map)
nil))
-(defun map-every-p (pred map)
+(cl-defgeneric map-every-p (pred map)
"Return non-nil if (PRED key val) is non-nil for all elements of the map MAP.
-
-MAP can be a list, hash-table or array."
+The default implementation delegates to `map-apply'."
+ ;; FIXME: Not sure if there's much benefit to defining it as defgeneric,
+ ;; since as defined, I can't think of a map-type where we could provide an
+ ;; algorithmically more efficient algorithm than the default.
(catch 'map--break
(map-apply (lambda (key value)
(or (funcall pred key value)
@@ -294,9 +338,7 @@ MAP can be a list, hash-table or array."
t))
(defun map-merge (type &rest maps)
- "Merge into a map of type TYPE all the key/value pairs in MAPS.
-
-MAP can be a list, hash-table or array."
+ "Merge into a map of type TYPE all the key/value pairs in MAPS."
(let ((result (map-into (pop maps) type)))
(while maps
;; FIXME: When `type' is `list', we get an O(N^2) behavior.
@@ -310,7 +352,7 @@ MAP can be a list, hash-table or array."
(defun map-merge-with (type function &rest maps)
"Merge into a map of type TYPE all the key/value pairs in MAPS.
-When two maps contain the same key, call FUNCTION on the two
+When two maps contain the same key (`eql'), call FUNCTION on the two
values and use the value returned by it.
MAP can be a list, hash-table or array."
(let ((result (map-into (pop maps) type))
@@ -318,49 +360,80 @@ MAP can be a list, hash-table or array."
(while maps
(map-apply (lambda (key value)
(cl-callf (lambda (old)
- (if (eq old not-found)
+ (if (eql old not-found)
value
(funcall function old value)))
(map-elt result key not-found)))
(pop maps)))
result))
-(defun map-into (map type)
- "Convert the map MAP into a map of type TYPE.
-
-TYPE can be one of the following symbols: list or hash-table.
-MAP can be a list, hash-table or array."
- (pcase type
- (`list (map-pairs map))
- (`hash-table (map--into-hash-table map))
- (_ (error "Not a map type name: %S" type))))
-
-(defun map--put (map key v)
+(cl-defgeneric map-into (map type)
+ "Convert the map MAP into a map of type TYPE.")
+;; FIXME: I wish there was a way to avoid this η-redex!
+(cl-defmethod map-into (map (_type (eql list))) (map-pairs map))
+(cl-defmethod map-into (map (_type (eql alist))) (map-pairs map))
+(cl-defmethod map-into (map (_type (eql plist)))
+ (let ((plist '()))
+ (map-do (lambda (k v) (setq plist `(,k ,v ,@plist))) map)
+ plist))
+
+(cl-defgeneric map-put! (map key value &optional testfn)
+ "Associate KEY with VALUE in MAP.
+If KEY is already present in MAP, replace the associated value
+with VALUE.
+This operates by modifying MAP in place.
+If it cannot do that, it signals the `map-not-inplace' error.
+If you want to insert an element without modifying MAP, use `map-insert'."
+ ;; `testfn' only exists for backward compatibility with `map-put'!
+ (declare (advertised-calling-convention (map key value) "27.1"))
(map--dispatch map
- :list (let ((p (assoc key map)))
- (if p (setcdr p v)
- (error "No place to change the mapping for %S" key)))
- :hash-table (puthash key v map)
- :array (aset map key v)))
-
-(defun map--apply-alist (function map)
- "Private function used to apply FUNCTION over MAP, MAP being an alist."
- (seq-map (lambda (pair)
- (funcall function
- (car pair)
- (cdr pair)))
- map))
-
-(defun map--apply-hash-table (function map)
- "Private function used to apply FUNCTION over MAP, MAP being a hash-table."
+ :list
+ (if (map--plist-p map)
+ (plist-put map key value)
+ (let ((oldmap map))
+ (setf (alist-get key map key nil (or testfn #'equal)) value)
+ (unless (eq oldmap map)
+ (signal 'map-not-inplace (list oldmap)))))
+ :hash-table (puthash key value map)
+ ;; FIXME: If `key' is too large, should we signal `map-not-inplace'
+ ;; and let `map-insert' grow the array?
+ :array (aset map key value)))
+
+(define-error 'map-inplace "Can only modify map in place")
+
+(cl-defgeneric map-insert (map key value)
+ "Return a new map like MAP except that it associates KEY with VALUE.
+This does not modify MAP.
+If you want to insert an element in place, use `map-put!'."
+ (if (listp map)
+ (if (map--plist-p map)
+ `(,key ,value ,@map)
+ (cons (cons key value) map))
+ ;; FIXME: Should we signal an error or use copy+put! ?
+ (signal 'map-inplace (list map))))
+
+;; There shouldn't be old source code referring to `map--put', yet we do
+;; need to keep it for backward compatibility with .elc files where the
+;; expansion of `setf' may call this function.
+(define-obsolete-function-alias 'map--put #'map-put! "27.1")
+
+(cl-defmethod map-apply (function (map list))
+ (if (map--plist-p map)
+ (cl-call-next-method)
+ (seq-map (lambda (pair)
+ (funcall function
+ (car pair)
+ (cdr pair)))
+ map)))
+
+(cl-defmethod map-apply (function (map hash-table))
(let (result)
(maphash (lambda (key value)
(push (funcall function key value) result))
map)
(nreverse result)))
-(defun map--apply-array (function map)
- "Private function used to apply FUNCTION over MAP, MAP being an array."
+(cl-defmethod map-apply (function (map array))
(let ((index 0))
(seq-map (lambda (elt)
(prog1
@@ -368,22 +441,27 @@ MAP can be a list, hash-table or array."
(setq index (1+ index))))
map)))
-(defun map--do-alist (function alist)
+(cl-defmethod map-do (function (map list))
"Private function used to iterate over ALIST using FUNCTION."
- (seq-do (lambda (pair)
- (funcall function
- (car pair)
- (cdr pair)))
- alist))
-
-(defun map--do-array (function array)
+ (if (map--plist-p map)
+ (while map
+ (funcall function (pop map) (pop map)))
+ (seq-do (lambda (pair)
+ (funcall function
+ (car pair)
+ (cdr pair)))
+ map)))
+
+(cl-defmethod map-do (function (array array))
"Private function used to iterate over ARRAY using FUNCTION."
(seq-do-indexed (lambda (elt index)
(funcall function index elt))
array))
-(defun map--into-hash-table (map)
+(cl-defmethod map-into (map (_type (eql hash-table)))
"Convert MAP into a hash-table."
+ ;; FIXME: Just knowing we want a hash-table is insufficient, since that
+ ;; doesn't tell us the test function to use with it!
(let ((ht (make-hash-table :size (map-length map)
:test 'equal)))
(map-apply (lambda (key value)
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el
index 9e058f3c60e..2278e389cef 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -36,18 +36,23 @@
;;; Code:
+;; The autoloads.el mechanism which adds package--builtin-versions
+;; maintenance to loaddefs.el doesn't work for preloaded packages (such
+;; as this one), so we have to do it by hand!
+(push (purecopy '(nadvice 1 0)) package--builtin-versions)
+
;;;; Lightweight advice/hook
(defvar advice--where-alist
'((:around "\300\301\302\003#\207" 5)
(:before "\300\301\002\"\210\300\302\002\"\207" 4)
(:after "\300\302\002\"\300\301\003\"\210\207" 5)
- (:override "\300\301\"\207" 4)
+ (:override "\300\301\002\"\207" 4)
(:after-until "\300\302\002\"\206\013\000\300\301\002\"\207" 4)
(:after-while "\300\302\002\"\205\013\000\300\301\002\"\207" 4)
(:before-until "\300\301\002\"\206\013\000\300\302\002\"\207" 4)
(:before-while "\300\301\002\"\205\013\000\300\302\002\"\207" 4)
- (:filter-args "\300\302\301!\"\207" 5)
- (:filter-return "\301\300\302\"!\207" 5))
+ (:filter-args "\300\302\301\003!\"\207" 5)
+ (:filter-return "\301\300\302\003\"!\207" 5))
"List of descriptions of how to add a function.
Each element has the form (WHERE BYTECODE STACK) where:
WHERE is a keyword indicating where the function is added.
@@ -241,6 +246,8 @@ different, but `function-equal' will hopefully ignore those differences.")
(if (local-variable-p var) (symbol-value var)
(setq advice--buffer-local-function-sample
;; This function acts like the t special value in buffer-local hooks.
+ ;; FIXME: Provide an `advice-bottom' function that's like
+ ;; `advice-cd*r' but also follows through this proxy.
(lambda (&rest args) (apply (default-value var) args)))))
(eval-and-compile
diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el
index a207ece885f..1486aeb3738 100644
--- a/lisp/emacs-lisp/package-x.el
+++ b/lisp/emacs-lisp/package-x.el
@@ -202,8 +202,8 @@ if it exists."
(split-version (package-desc-version pkg-desc))
(commentary
(pcase file-type
- (`single (lm-commentary))
- (`tar nil))) ;; FIXME: Get it from the README file.
+ ('single (lm-commentary))
+ ('tar nil))) ;; FIXME: Get it from the README file.
(extras (package-desc-extras pkg-desc))
(pkg-version (package-version-join split-version))
(pkg-buffer (current-buffer)))
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 1a185de4a52..61cf6906971 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -101,7 +101,7 @@
;; Michael Olson <mwolson@member.fsf.org>
;; Sebastian Tennant <sebyte@smolny.plus.com>
;; Stefan Monnier <monnier@iro.umontreal.ca>
-;; Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Phil Hagelberg <phil@hagelb.org>
;;; ToDo:
@@ -143,8 +143,8 @@
;;; Code:
+(require 'cl-lib)
(eval-when-compile (require 'subr-x))
-(eval-when-compile (require 'cl-lib))
(eval-when-compile (require 'epg)) ;For setf accessors.
(require 'seq)
@@ -161,29 +161,34 @@
;;; Customization options
;;;###autoload
(defcustom package-enable-at-startup t
- "Whether to activate installed packages when Emacs starts.
-If non-nil, packages are activated after reading the init file
-and before `after-init-hook'. Activation is not done if
-`user-init-file' is nil (e.g. Emacs was started with \"-q\").
+ "Whether to make installed packages available when Emacs starts.
+If non-nil, packages are made available before reading the init
+file (but after reading the early init file). This means that if
+you wish to set this variable, you must do so in the early init
+file. Regardless of the value of this variable, packages are not
+made available if `user-init-file' is nil (e.g. Emacs was started
+with \"-q\").
Even if the value is nil, you can type \\[package-initialize] to
-activate the package system at any time."
+make installed packages available at any time, or you can
+call (package-initialize) in your init-file."
:type 'boolean
:version "24.1")
(defcustom package-load-list '(all)
- "List of packages for `package-initialize' to load.
+ "List of packages for `package-initialize' to make available.
Each element in this list should be a list (NAME VERSION), or the
-symbol `all'. The symbol `all' says to load the latest installed
-versions of all packages not specified by other elements.
+symbol `all'. The symbol `all' says to make available the latest
+installed versions of all packages not specified by other
+elements.
For an element (NAME VERSION), NAME is a package name (a symbol).
VERSION should be t, a string, or nil.
-If VERSION is t, the most recent version is activated.
-If VERSION is a string, only that version is ever loaded.
+If VERSION is t, the most recent version is made available.
+If VERSION is a string, only that version is ever made available.
Any other version, even if newer, is silently ignored.
Hence, the package is \"held\" at that version.
-If VERSION is nil, the package is not loaded (it is \"disabled\")."
+If VERSION is nil, the package is not made available (it is \"disabled\")."
:type '(repeat (choice (const all)
(list :tag "Specific package"
(symbol :tag "Package name")
@@ -482,7 +487,7 @@ This is, approximately, the inverse of `version-to-list'.
str-list))))
(if (equal "." (car str-list))
(pop str-list))
- (apply 'concat (nreverse str-list)))))
+ (apply #'concat (nreverse str-list)))))
(defun package-desc-full-name (pkg-desc)
(format "%s-%s"
@@ -491,9 +496,9 @@ This is, approximately, the inverse of `version-to-list'.
(defun package-desc-suffix (pkg-desc)
(pcase (package-desc-kind pkg-desc)
- (`single ".el")
- (`tar ".tar")
- (`dir "")
+ ('single ".el")
+ ('tar ".tar")
+ ('dir "")
(kind (error "Unknown package kind: %s" kind))))
(defun package-desc--keywords (pkg-desc)
@@ -604,6 +609,12 @@ updates `package-alist'."
(when (file-directory-p pkg-dir)
(package-load-descriptor pkg-dir))))))))
+(defun package--alist ()
+ "Return `package-alist', after computing it if needed."
+ (or package-alist
+ (progn (package-load-all-descriptors)
+ package-alist)))
+
(defun define-package (_name-string _version-string
&optional _docstring _requirements
&rest _extra-properties)
@@ -676,13 +687,17 @@ PKG-DESC is a `package-desc' object."
(defvar Info-directory-list)
(declare-function info-initialize "info" ())
+(defvar package--quickstart-pkgs t
+ "If set to a list, we're computing the set of pkgs to activate.")
+
(defun package--load-files-for-activation (pkg-desc reload)
"Load files for activating a package given by PKG-DESC.
Load the autoloads file, and ensure `load-path' is setup. If
RELOAD is non-nil, also load all files in the package that
correspond to previously loaded files."
- (let* ((loaded-files-list (when reload
- (package--list-loaded-files (package-desc-dir pkg-desc)))))
+ (let* ((loaded-files-list
+ (when reload
+ (package--list-loaded-files (package-desc-dir pkg-desc)))))
;; Add to load path, add autoloads, and activate the package.
(package--activate-autoloads-and-load-path pkg-desc)
;; Call `load' on all files in `package-desc-dir' already present in
@@ -718,7 +733,10 @@ correspond to previously loaded files (those returned by
(message "Unable to activate package `%s'.\nRequired package `%s-%s' is unavailable"
name (car req) (package-version-join (cadr req)))
(throw 'exit nil))))
- (package--load-files-for-activation pkg-desc reload)
+ (if (listp package--quickstart-pkgs)
+ ;; We're only collecting the set of packages to activate!
+ (push pkg-desc package--quickstart-pkgs)
+ (package--load-files-for-activation pkg-desc reload))
;; Add info node.
(when (file-exists-p (expand-file-name "dir" pkg-dir))
;; FIXME: not the friendliest, but simple.
@@ -738,7 +756,8 @@ DIR, sorted by most recently loaded last."
(let* ((history (delq nil
(mapcar (lambda (x)
(let ((f (car x)))
- (and f (file-name-sans-extension f))))
+ (and (stringp f)
+ (file-name-sans-extension f))))
load-history)))
(dir (file-truename dir))
;; List all files that have already been loaded.
@@ -825,7 +844,7 @@ untar into a directory named DIR; otherwise, signal an error."
(tar-untar-buffer))
(defun package--alist-to-plist-args (alist)
- (mapcar 'macroexp-quote
+ (mapcar #'macroexp-quote
(apply #'nconc
(mapcar (lambda (pair) (list (car pair) (cdr pair))) alist))))
(defun package-unpack (pkg-desc)
@@ -834,7 +853,7 @@ untar into a directory named DIR; otherwise, signal an error."
(dirname (package-desc-full-name pkg-desc))
(pkg-dir (expand-file-name dirname package-user-dir)))
(pcase (package-desc-kind pkg-desc)
- (`dir
+ ('dir
(make-directory pkg-dir t)
(let ((file-list
(directory-files
@@ -848,12 +867,12 @@ untar into a directory named DIR; otherwise, signal an error."
;; things simple by ensuring we're one of them.
(setf (package-desc-kind pkg-desc)
(if (> (length file-list) 1) 'tar 'single))))
- (`tar
+ ('tar
(make-directory package-user-dir t)
;; FIXME: should we delete PKG-DIR if it exists?
(let* ((default-directory (file-name-as-directory package-user-dir)))
(package-untar-buffer dirname)))
- (`single
+ ('single
(let ((el-file (expand-file-name (format "%s.el" name) pkg-dir)))
(make-directory pkg-dir t)
(package--write-file-no-coding el-file)))
@@ -886,7 +905,9 @@ untar into a directory named DIR; otherwise, signal an error."
(print-length nil))
(write-region
(concat
- ";;; -*- no-byte-compile: t -*-\n"
+ ";;; Generated package description from "
+ (replace-regexp-in-string "-pkg\\.el\\'" ".el" pkg-file)
+ " -*- no-byte-compile: t -*-\n"
(prin1-to-string
(nconc
(list 'define-package
@@ -961,17 +982,12 @@ This assumes that `pkg-desc' has already been activated with
(defun package-read-from-string (str)
"Read a Lisp expression from STR.
Signal an error if the entire string was not used."
- (let* ((read-data (read-from-string str))
- (more-left
- (condition-case nil
- ;; The call to `ignore' suppresses a compiler warning.
- (progn (ignore (read-from-string
- (substring str (cdr read-data))))
- t)
- (end-of-file nil))))
- (if more-left
- (error "Can't read whole string")
- (car read-data))))
+ (pcase-let ((`(,expr . ,offset) (read-from-string str)))
+ (condition-case ()
+ ;; The call to `ignore' suppresses a compiler warning.
+ (progn (ignore (read-from-string str offset))
+ (error "Can't read whole string"))
+ (end-of-file expr))))
(defun package--prepare-dependencies (deps)
"Turn DEPS into an acceptable list of dependencies.
@@ -994,6 +1010,7 @@ is wrapped around any parts requiring it."
(declare-function lm-header "lisp-mnt" (header))
(declare-function lm-homepage "lisp-mnt" (&optional file))
+(declare-function lm-keywords-list "lisp-mnt" (&optional file))
(declare-function lm-maintainer "lisp-mnt" (&optional file))
(declare-function lm-authors "lisp-mnt" (&optional file))
@@ -1009,6 +1026,8 @@ boundaries."
(let ((file-name (match-string-no-properties 1))
(desc (match-string-no-properties 2))
(start (line-beginning-position)))
+ ;; The terminating comment format could be extended to accept a
+ ;; generic string that is not in English.
(unless (search-forward (concat ";;; " file-name ".el ends here"))
(error "Package lacks a terminating comment"))
;; Try to include a trailing newline.
@@ -1022,6 +1041,7 @@ boundaries."
(pkg-version
(or (package-strip-rcs-id (lm-header "package-version"))
(package-strip-rcs-id (lm-header "version"))))
+ (keywords (lm-keywords-list))
(homepage (lm-homepage)))
(unless pkg-version
(error
@@ -1033,6 +1053,7 @@ boundaries."
(package-read-from-string requires-str)))
:kind 'single
:url homepage
+ :keywords keywords
:maintainer (lm-maintainer)
:authors (lm-authors)))))
@@ -1436,45 +1457,59 @@ If successful, set `package-archive-contents'."
;; available on disk.
(defvar package--initialized nil)
-(defvar package--init-file-ensured nil
- "Whether we know the init file has package-initialize.")
-
;;;###autoload
(defun package-initialize (&optional no-activate)
"Load Emacs Lisp packages, and activate them.
The variable `package-load-list' controls which packages to load.
If optional arg NO-ACTIVATE is non-nil, don't activate packages.
-If `user-init-file' does not mention `(package-initialize)', add
-it to the file.
If called as part of loading `user-init-file', set
`package-enable-at-startup' to nil, to prevent accidentally
loading packages twice.
+
It is not necessary to adjust `load-path' or `require' the
individual packages after calling `package-initialize' -- this is
-taken care of by `package-initialize'."
+taken care of by `package-initialize'.
+
+If `package-initialize' is called twice during Emacs startup,
+signal a warning, since this is a bad idea except in highly
+advanced use cases. To suppress the warning, remove the
+superfluous call to `package-initialize' from your init-file. If
+you have code which must run before `package-initialize', put
+that code in the early init-file."
(interactive)
+ (when (and package--initialized (not after-init-time))
+ (lwarn '(package reinitialization) :warning
+ "Unnecessary call to `package-initialize' in init file"))
(setq package-alist nil)
- (if after-init-time
- (package--ensure-init-file)
- ;; If `package-initialize' is before we finished loading the init
- ;; file, it's obvious we don't need to ensure-init.
- (setq package--init-file-ensured t
- ;; And likely we don't need to run it again after init.
- package-enable-at-startup nil))
+ (setq package-enable-at-startup nil)
(package-load-all-descriptors)
(package-read-all-archive-contents)
- (unless no-activate
- (dolist (elt package-alist)
- (condition-case err
- (package-activate (car elt))
- ;; Don't let failure of activation of a package arbitrarily stop
- ;; activation of further packages.
- (error (message "%s" (error-message-string err))))))
(setq package--initialized t)
+ (unless no-activate
+ (package-activate-all))
;; This uses `package--mapc' so it must be called after
;; `package--initialized' is t.
(package--build-compatibility-table))
+(defvar package-quickstart-file)
+
+;;;###autoload
+(defun package-activate-all ()
+ "Activate all installed packages.
+The variable `package-load-list' controls which packages to load."
+ (setq package-enable-at-startup nil)
+ (if (file-readable-p package-quickstart-file)
+ ;; Skip load-source-file-function which would slow us down by a factor
+ ;; 2 (this assumes we were careful to save this file so it doesn't need
+ ;; any decoding).
+ (let ((load-source-file-function nil))
+ (load package-quickstart-file nil 'nomessage))
+ (dolist (elt (package--alist))
+ (condition-case err
+ (package-activate (car elt))
+ ;; Don't let failure of activation of a package arbitrarily stop
+ ;; activation of further packages.
+ (error (message "%s" (error-message-string err)))))))
;;;; Populating `package-archive-contents' from archives
;; This subsection populates the variables listed above from the
@@ -1530,7 +1565,7 @@ similar to an entry in `package-alist'. Save the cached copy to
(let* ((location (cdr archive))
(name (car archive))
(content (buffer-string))
- (dir (expand-file-name (format "archives/%s" name) package-user-dir))
+ (dir (expand-file-name (concat "archives/" name) package-user-dir))
(local-file (expand-file-name file dir)))
(when (listp (read content))
(make-directory dir t)
@@ -1869,18 +1904,25 @@ If PACKAGE is a symbol, it is the package name and MIN-VERSION
should be a version list.
If PACKAGE is a `package-desc' object, MIN-VERSION is ignored."
- (unless package--initialized (error "package.el is not yet initialized!"))
- (if (package-desc-p package)
- (let ((dir (package-desc-dir package)))
+ (cond
+ ((package-desc-p package)
+ (let ((dir (package-desc-dir package)))
(and (stringp dir)
- (file-exists-p dir)))
+ (file-exists-p dir))))
+ ((and (not package--initialized)
+ (null min-version)
+ package-activated-list)
+ ;; We used the quickstart: make it possible to use package-installed-p
+ ;; even before package is fully initialized.
+ (memq package package-activated-list))
+ (t
(or
- (let ((pkg-descs (cdr (assq package package-alist))))
+ (let ((pkg-descs (cdr (assq package (package--alist)))))
(and pkg-descs
(version-list-<= min-version
(package-desc-version (car pkg-descs)))))
;; Also check built-in packages.
- (package-built-in-p package min-version))))
+ (package-built-in-p package min-version)))))
(defun package-download-transaction (packages)
"Download and install all the packages in PACKAGES.
@@ -1890,64 +1932,6 @@ PACKAGES are satisfied, i.e. that PACKAGES is computed
using `package-compute-transaction'."
(mapc #'package-install-from-archive packages))
-(defun package--ensure-init-file ()
- "Ensure that the user's init file has `package-initialize'.
-`package-initialize' doesn't have to be called, as long as it is
-present somewhere in the file, even as a comment. If it is not,
-add a call to it along with some explanatory comments."
- ;; Don't mess with the init-file from "emacs -Q".
- (when (and (stringp user-init-file)
- (not package--init-file-ensured)
- (file-readable-p user-init-file)
- (file-writable-p user-init-file))
- (let* ((buffer (find-buffer-visiting user-init-file))
- buffer-name
- (contains-init
- (if buffer
- (with-current-buffer buffer
- (save-excursion
- (save-restriction
- (widen)
- (goto-char (point-min))
- (re-search-forward "(package-initialize\\_>" nil 'noerror))))
- ;; Don't visit the file if we don't have to.
- (with-temp-buffer
- (insert-file-contents user-init-file)
- (goto-char (point-min))
- (re-search-forward "(package-initialize\\_>" nil 'noerror)))))
- (unless contains-init
- (with-current-buffer (or buffer
- (let ((delay-mode-hooks t)
- (find-file-visit-truename t))
- (find-file-noselect user-init-file)))
- (when buffer
- (setq buffer-name (buffer-file-name))
- (set-visited-file-name (file-chase-links user-init-file)))
- (save-excursion
- (save-restriction
- (widen)
- (goto-char (point-min))
- (while (and (looking-at-p "[[:blank:]]*\\(;\\|$\\)")
- (not (eobp)))
- (forward-line 1))
- (insert
- "\n"
- ";; Added by Package.el. This must come before configurations of\n"
- ";; installed packages. Don't delete this line. If you don't want it,\n"
- ";; just comment it out by adding a semicolon to the start of the line.\n"
- ";; You may delete these explanatory comments.\n"
- "(package-initialize)\n")
- (unless (looking-at-p "$")
- (insert "\n"))
- (let ((file-precious-flag t))
- (save-buffer))
- (if buffer
- (progn
- (set-visited-file-name buffer-name)
- (set-buffer-modified-p nil))
- (kill-buffer (current-buffer)))))))))
- (setq package--init-file-ensured t))
-
;;;###autoload
(defun package-install (pkg &optional dont-select)
"Install the package PKG.
@@ -1989,7 +1973,9 @@ to install it but still mark it as selected."
(package-compute-transaction (list pkg)
(package-desc-reqs pkg)))
(package-compute-transaction () (list (list pkg))))))
- (package-download-transaction transaction)
+ (progn
+ (package-download-transaction transaction)
+ (package--quickstart-maybe-refresh))
(message "`%s' is already installed" name))))
(defun package-strip-rcs-id (str)
@@ -2073,12 +2059,12 @@ If some packages are not installed propose to install them."
(cond
(available
(when (y-or-n-p
- (format "%s packages will be installed:\n%s, proceed?"
+ (format "Packages to install: %d (%s), proceed? "
(length available)
- (mapconcat #'symbol-name available ", ")))
+ (mapconcat #'symbol-name available " ")))
(mapc (lambda (p) (package-install p 'dont-select)) available)))
((> difference 0)
- (message "%s packages are not available (the rest already installed), maybe you need to `M-x package-refresh-contents'"
+ (message "Packages that are not available: %d (the rest is already installed), maybe you need to `M-x package-refresh-contents'"
difference))
(t
(message "All your packages are already installed"))))))
@@ -2104,16 +2090,12 @@ If NOSAVE is non-nil, the package is not removed from
`package-selected-packages'."
(interactive
(progn
- ;; Initialize the package system to get the list of package
- ;; symbols for completion.
- (unless package--initialized
- (package-initialize t))
(let* ((package-table
(mapcar
(lambda (p) (cons (package-desc-full-name p) p))
(delq nil
(mapcar (lambda (p) (unless (package-built-in-p p) p))
- (apply #'append (mapcar #'cdr package-alist))))))
+ (apply #'append (mapcar #'cdr (package--alist)))))))
(package-name (completing-read "Delete package: "
(mapcar #'car package-table)
nil t)))
@@ -2148,6 +2130,9 @@ If NOSAVE is non-nil, the package is not removed from
(add-hook 'post-command-hook #'package-menu--post-refresh)
(delete-directory dir t)
;; Remove NAME-VERSION.signed and NAME-readme.txt files.
+ ;;
+ ;; NAME-readme.txt files are no longer created, but they
+ ;; may be left around from an earlier install.
(dolist (suffix '(".signed" "readme.txt"))
(let* ((version (package-version-join (package-desc-version pkg-desc)))
(file (concat (if (string= suffix ".signed")
@@ -2161,7 +2146,9 @@ If NOSAVE is non-nil, the package is not removed from
(delete pkg-desc pkgs)
(unless (cdr pkgs)
(setq package-alist (delq pkgs package-alist))))
- (message "Package `%s' deleted." (package-desc-full-name pkg-desc))))))
+ (package--quickstart-maybe-refresh)
+ (message "Package `%s' deleted."
+ (package-desc-full-name pkg-desc))))))
;;;###autoload
(defun package-reinstall (pkg)
@@ -2195,9 +2182,9 @@ will be deleted."
(let ((removable (package--removable-packages)))
(if removable
(when (y-or-n-p
- (format "%s packages will be deleted:\n%s, proceed? "
+ (format "Packages to delete: %d (%s), proceed? "
(length removable)
- (mapconcat #'symbol-name removable ", ")))
+ (mapconcat #'symbol-name removable " ")))
(mapc (lambda (p)
(package-delete (cadr (assq p package-alist)) t))
removable))
@@ -2216,12 +2203,12 @@ will be deleted."
;; Load the package list if necessary (but don't activate them).
(unless package--initialized
(package-initialize t))
- (let ((packages (append (mapcar 'car package-alist)
- (mapcar 'car package-archive-contents)
- (mapcar 'car package--builtins))))
+ (let ((packages (append (mapcar #'car package-alist)
+ (mapcar #'car package-archive-contents)
+ (mapcar #'car package--builtins))))
(unless (memq guess packages)
(setq guess nil))
- (setq packages (mapcar 'symbol-name packages))
+ (setq packages (mapcar #'symbol-name packages))
(let ((val
(completing-read (if guess
(format "Describe package (default %s): "
@@ -2256,6 +2243,45 @@ Otherwise no newline is inserted."
(declare-function lm-commentary "lisp-mnt" (&optional file))
+(defun package--get-description (desc)
+ "Return a string containing the long description of the package DESC.
+The description is read from the installed package files."
+ ;; Installed packages have nil for kind, so we look for README
+ ;; first, then fall back to the Commentary header.
+
+ ;; We don’t include README.md here, because that is often the home
+ ;; page on a site like github, and not suitable as the package long
+ ;; description.
+ (let ((files '("README-elpa" "README-elpa.md" "README" "README.rst" "README.org"))
+ file
+ (srcdir (package-desc-dir desc))
+ result)
+ (while (and files
+ (not result))
+ (setq file (pop files))
+ (when (file-readable-p (expand-file-name file srcdir))
+ ;; Found a README.
+ (with-temp-buffer
+ (insert-file-contents (expand-file-name file srcdir))
+ (setq result (buffer-string)))))
+
+ (or
+ result
+
+ ;; Look for Commentary header.
+ (let ((mainsrcfile (expand-file-name (format "%s.el" (package-desc-name desc))
+ srcdir)))
+ (when (file-readable-p mainsrcfile)
+ (with-temp-buffer
+ (insert (or (lm-commentary mainsrcfile) ""))
+ (goto-char (point-min))
+ (when (re-search-forward "^;;; Commentary:\n" nil t)
+ (replace-match ""))
+ (while (re-search-forward "^\\(;+ ?\\)" nil t)
+ (replace-match ""))
+ (buffer-string))))
+ )))
+
(defun describe-package-1 (pkg)
(require 'lisp-mnt)
(let* ((desc (or
@@ -2284,12 +2310,10 @@ Otherwise no newline is inserted."
(setq status "available obsolete"))
(when incompatible-reason
(setq status "incompatible"))
- (prin1 name)
- (princ " is ")
- (princ (if (memq (aref status 0) '(?a ?e ?i ?o ?u)) "an " "a "))
- (princ status)
- (princ " package.\n\n")
+ (princ (format "Package %S is %s.\n\n" name status))
+ ;; TODO: Remove the string decorations and reformat the strings
+ ;; for future l10n.
(package--print-help-section "Status")
(cond (built-in
(insert (propertize (capitalize status)
@@ -2431,7 +2455,8 @@ Otherwise no newline is inserted."
(insert "\n")
(if built-in
- ;; For built-in packages, insert the commentary.
+ ;; For built-in packages, get the description from the
+ ;; Commentary header.
(let ((fn (locate-file (format "%s.el" name) load-path
load-file-rep-suffixes))
(opoint (point)))
@@ -2442,27 +2467,26 @@ Otherwise no newline is inserted."
(replace-match ""))
(while (re-search-forward "^\\(;+ ?\\)" nil t)
(replace-match ""))))
- (let* ((basename (format "%s-readme.txt" name))
- (readme (expand-file-name basename package-user-dir))
- readme-string)
- ;; For elpa packages, try downloading the commentary. If that
- ;; fails, try an existing readme file in `package-user-dir'.
- (cond ((and (package-desc-archive desc)
- (package--with-response-buffer (package-archive-base desc)
- :file basename :noerror t
- (save-excursion
- (goto-char (point-max))
- (unless (bolp)
- (insert ?\n)))
- (write-region nil nil
- (expand-file-name readme package-user-dir)
- nil 'silent)
- (setq readme-string (buffer-string))
- t))
- (insert readme-string))
- ((file-readable-p readme)
- (insert-file-contents readme)
- (goto-char (point-max))))))))
+
+ (if (package-installed-p desc)
+ ;; For installed packages, get the description from the installed files.
+ (insert (package--get-description desc))
+
+ ;; For non-built-in, non-installed packages, get description from the archive.
+ (let* ((basename (format "%s-readme.txt" name))
+ readme-string)
+
+ (package--with-response-buffer (package-archive-base desc)
+ :file basename :noerror t
+ (save-excursion
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert ?\n)))
+ (setq readme-string (buffer-string))
+ t)
+ (insert (or readme-string
+ "This package does not provide a description.")))
+ ))))
(defun package-install-button-action (button)
(let ((pkg-desc (button-get button 'package-desc)))
@@ -2491,7 +2515,7 @@ Otherwise no newline is inserted."
:background "light grey"
:foreground "black")
'link)))
- (apply 'insert-text-button button-text 'face button-face 'follow-link t
+ (apply #'insert-text-button button-text 'face button-face 'follow-link t
props)))
@@ -2519,7 +2543,7 @@ Otherwise no newline is inserted."
(easy-menu-define package-menu-mode-menu package-menu-mode-map
"Menu for `package-menu-mode'."
- `("Package"
+ '("Package"
["Describe Package" package-menu-describe-package :help "Display information about this package"]
["Help" package-menu-quick-help :help "Show short key binding help for package-menu-mode"]
"--"
@@ -2572,7 +2596,7 @@ Letters do not insert themselves; instead, they are commands.
("Description" 0 nil)])
(setq tabulated-list-padding 2)
(setq tabulated-list-sort-key (cons "Status" nil))
- (add-hook 'tabulated-list-revert-hook 'package-menu--refresh nil t)
+ (add-hook 'tabulated-list-revert-hook #'package-menu--refresh nil t)
(tabulated-list-init-header))
(defmacro package--push (pkg-desc status listname)
@@ -2671,9 +2695,9 @@ Installed obsolete packages are always displayed.")
(user-error "The current buffer is not a Package Menu"))
(setq package-menu--hide-packages
(not package-menu--hide-packages))
- (message "%s packages" (if package-menu--hide-packages
- "Hiding obsolete or unwanted"
- "Displaying all"))
+ (if package-menu--hide-packages
+ (message "Hiding obsolete or unwanted packages")
+ (message "Displaying all packages"))
(revert-buffer nil 'no-confirm))
(defun package--remove-hidden (pkg-list)
@@ -2699,12 +2723,11 @@ to their archives."
((not package-menu-hide-low-priority)
pkg-list)
((eq package-menu-hide-low-priority 'archive)
- (let* ((max-priority most-negative-fixnum)
- (out))
+ (let (max-priority out)
(while pkg-list
(let ((p (pop pkg-list)))
(let ((priority (package-desc-priority p)))
- (if (< priority max-priority)
+ (if (and max-priority (< priority max-priority))
(setq pkg-list nil)
(push p out)
(setq max-priority priority)))))
@@ -2844,7 +2867,7 @@ shown."
(package-menu--refresh packages keywords)
(setf (car (aref tabulated-list-format 0))
(if keywords
- (let ((filters (mapconcat 'identity keywords ",")))
+ (let ((filters (mapconcat #'identity keywords ",")))
(concat "Package[" filters "]"))
"Package"))
(if keywords
@@ -2937,17 +2960,17 @@ PKG is a `package-desc' object.
Return (PKG-DESC [NAME VERSION STATUS DOC])."
(let* ((status (package-desc-status pkg))
(face (pcase status
- (`"built-in" 'package-status-built-in)
- (`"external" 'package-status-external)
- (`"available" 'package-status-available)
- (`"avail-obso" 'package-status-avail-obso)
- (`"new" 'package-status-new)
- (`"held" 'package-status-held)
- (`"disabled" 'package-status-disabled)
- (`"installed" 'package-status-installed)
- (`"dependency" 'package-status-dependency)
- (`"unsigned" 'package-status-unsigned)
- (`"incompat" 'package-status-incompat)
+ ("built-in" 'package-status-built-in)
+ ("external" 'package-status-external)
+ ("available" 'package-status-available)
+ ("avail-obso" 'package-status-avail-obso)
+ ("new" 'package-status-new)
+ ("held" 'package-status-held)
+ ("disabled" 'package-status-disabled)
+ ("installed" 'package-status-installed)
+ ("dependency" 'package-status-dependency)
+ ("unsigned" 'package-status-unsigned)
+ ("incompat" 'package-status-incompat)
(_ 'font-lock-warning-face)))) ; obsolete.
(list pkg
`[(,(symbol-name (package-desc-name pkg))
@@ -2997,11 +3020,11 @@ If optional arg BUTTON is non-nil, describe its associated package."
(let ((hidden
(cl-remove-if-not (lambda (e) (string-match re (symbol-name (car e))))
package-archive-contents)))
- (message (substitute-command-keys
- (concat "Hiding %s packages, type `\\[package-menu-toggle-hiding]'"
- " to toggle or `\\[customize-variable] RET package-hidden-regexps'"
- " to customize it"))
- (length hidden)))))
+ (message "Packages to hide: %d. Type `%s' to toggle or `%s' to customize"
+ (length hidden)
+ (substitute-command-keys "\\[package-menu-toggle-hidding]")
+ (substitute-command-keys "\\[customize-variable] RET package-hidden-regexps")))))
+
(defun package-menu-describe-package (&optional button)
"Describe the current package.
@@ -3136,7 +3159,7 @@ Implementation of `package-menu-mark-upgrades'."
(setq package-menu--mark-upgrades-pending nil)
(let ((upgrades (package-menu--find-upgrades)))
(if (null upgrades)
- (message "No packages to upgrade.")
+ (message "No packages to upgrade")
(widen)
(save-excursion
(goto-char (point-min))
@@ -3149,9 +3172,9 @@ Implementation of `package-menu-mark-upgrades'."
(package-menu-mark-install))
(t
(package-menu-mark-delete))))))
- (message "%d package%s marked for upgrading."
- (length upgrades)
- (if (= (length upgrades) 1) "" "s")))))
+ (message "Packages marked for upgrading: %d"
+ (length upgrades)))))
+
(defun package-menu-mark-upgrades ()
"Mark all upgradable packages in the Package Menu.
@@ -3174,17 +3197,12 @@ immediately."
PACKAGES is a list of `package-desc' objects.
Formats the returned string to be usable in a minibuffer
prompt (see `package-menu--prompt-transaction-p')."
- (cond
- ;; None
- ((not packages) "")
- ;; More than 1
- ((cdr packages)
- (format "these %d packages (%s)"
- (length packages)
- (mapconcat #'package-desc-full-name packages ", ")))
- ;; Exactly 1
- (t (format-message "package `%s'"
- (package-desc-full-name (car packages))))))
+ ;; The case where `package' is empty is handled in
+ ;; `package-menu--prompt-transaction-p' below.
+ (format "%d (%s)"
+ (length packages)
+ (mapconcat #'package-desc-full-name packages " ")))
+
(defun package-menu--prompt-transaction-p (delete install upgrade)
"Prompt the user about DELETE, INSTALL, and UPGRADE.
@@ -3192,16 +3210,14 @@ DELETE, INSTALL, and UPGRADE are lists of `package-desc' objects.
Either may be nil, but not all."
(y-or-n-p
(concat
- (when delete "Delete ")
- (package-menu--list-to-prompt delete)
- (when (and delete install)
- (if upgrade "; " "; and "))
- (when install "Install ")
- (package-menu--list-to-prompt install)
- (when (and upgrade (or install delete)) "; and ")
- (when upgrade "Upgrade ")
- (package-menu--list-to-prompt upgrade)
- "? ")))
+ (when delete
+ (format "Packages to delete: %s. " (package-menu--list-to-prompt delete)))
+ (when install
+ (format "Packages to install: %s. " (package-menu--list-to-prompt install)))
+ (when upgrade
+ (format "Packages to upgrade: %s. " (package-menu--list-to-prompt upgrade)))
+ "Proceed? ")))
+
(defun package-menu--partition-transaction (install delete)
"Return an alist describing an INSTALL DELETE transaction.
@@ -3285,25 +3301,24 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm."
(when (or noquery
(package-menu--prompt-transaction-p .delete .install .upgrade))
(let ((message-template
- (concat "Package menu: Operation %s ["
- (when .delete (format "Delet__ %s" (length .delete)))
- (when (and .delete .install) "; ")
- (when .install (format "Install__ %s" (length .install)))
- (when (and .upgrade (or .install .delete)) "; ")
- (when .upgrade (format "Upgrad__ %s" (length .upgrade)))
+ (concat "[ "
+ (when .delete
+ (format "Delete %d " (length .delete)))
+ (when .install
+ (format "Install %d " (length .install)))
+ (when .upgrade
+ (format "Upgrade %d " (length .upgrade)))
"]")))
- (message (replace-regexp-in-string "__" "ing" message-template) "started")
+ (message "Operation %s started" message-template)
;; Packages being upgraded are not marked as selected.
(package--update-selected-packages .install .delete)
(package-menu--perform-transaction install-list delete-list)
(when package-selected-packages
(if-let* ((removable (package--removable-packages)))
- (message "Package menu: Operation finished. %d packages %s"
- (length removable)
- (substitute-command-keys
- "are no longer needed, type `\\[package-autoremove]' to remove them"))
- (message (replace-regexp-in-string "__" "ed" message-template)
- "finished"))))))))
+ (message "Operation finished. Packages that are no longer needed: %d. Type `%s' to remove them"
+ (length removable)
+ (substitute-command-keys "\\[package-autoremove]"))
+ (message "Operation %s finished" message-template))))))))
(defun package-menu--version-predicate (A B)
(let ((vA (or (aref (cadr A) 1) '(0)))
@@ -3370,11 +3385,10 @@ Store this list in `package-menu--new-package-list'."
(defun package-menu--find-and-notify-upgrades ()
"Notify the user of upgradable packages."
(when-let* ((upgrades (package-menu--find-upgrades)))
- (message "%d package%s can be upgraded; type `%s' to mark %s for upgrading."
- (length upgrades)
- (if (= (length upgrades) 1) "" "s")
- (substitute-command-keys "\\[package-menu-mark-upgrades]")
- (if (= (length upgrades) 1) "it" "them"))))
+ (message "Packages that can be upgraded: %d; type `%s' to mark for upgrading."
+ (length upgrades)
+ (substitute-command-keys "\\[package-menu-mark-upgrades]"))))
+
(defun package-menu--post-refresh ()
"If there's a *Packages* buffer, revert it and check for new packages and upgrades.
@@ -3489,6 +3503,131 @@ The list is displayed in a buffer named `*Packages*'."
(interactive)
(list-packages t))
+;;;###autoload
+(defun package-get-version ()
+ "Return the version number of the package in which this is used.
+Assumes it is used from an Elisp file placed inside the top-level directory
+of an installed ELPA package.
+The return value is a string (or nil in case we can't find it)."
+ ;; In a sense, this is a lie, but it does just what we want: precompute
+ ;; the version at compile time and hardcodes it into the .elc file!
+ (declare (pure t))
+ ;; Hack alert!
+ (let ((file
+ (or (if (boundp 'byte-compile-current-file) byte-compile-current-file)
+ load-file-name
+ buffer-file-name)))
+ (cond
+ ((null file) nil)
+ ;; Packages are normally installed into directories named "<pkg>-<vers>",
+ ;; so get the version number from there.
+ ((string-match "/[^/]+-\\([0-9]\\(?:[0-9.]\\|pre\\|beta\\|alpha\\|snapshot\\)+\\)/[^/]+\\'" file)
+ (match-string 1 file))
+ ;; For packages run straight from the an elpa.git clone, there's no
+ ;; "-<vers>" in the directory name, so we have to fetch the version
+ ;; the hard way.
+ (t
+ (let* ((pkgdir (file-name-directory file))
+ (pkgname (file-name-nondirectory (directory-file-name pkgdir)))
+ (mainfile (expand-file-name (concat pkgname ".el") pkgdir)))
+ (when (file-readable-p mainfile)
+ (require 'lisp-mnt)
+ (with-temp-buffer
+ (insert-file-contents mainfile)
+ (or (lm-header "package-version")
+ (lm-header "version")))))))))
+
+;;;; Quickstart: precompute activation actions for faster start up.
+
+;; Activating packages via `package-initialize' is costly: for N installed
+;; packages, it needs to read all N <pkg>-pkg.el files first to decide
+;; which packages to activate, and then again N <pkg>-autoloads.el files.
+;; To speed this up, we precompute a mega-autoloads file which is the
+;; concatenation of all those <pkg>-autoloads.el, so we can activate
+;; all packages by loading this one file (and hence without initializing
+;; package.el).
+
+;; Other than speeding things up, this also offers a bootstrap feature:
+;; it lets us activate packages according to `package-load-list' and
+;; `package-user-dir' even before those vars are set.
+
+(defcustom package-quickstart nil
+ "Precompute activation actions to speed up startup.
+This requires the use of `package-quickstart-refresh' every time the
+activations need to be changed, such as when `package-load-list' is modified."
+ :type 'boolean
+ :version "27.1")
+
+(defcustom package-quickstart-file
+ (locate-user-emacs-file "package-quickstart.el")
+ "Location of the file used to speed up activation of packages at startup."
+ :type 'file
+ :version "27.1")
+
+(defun package--quickstart-maybe-refresh ()
+ (if package-quickstart
+ ;; FIXME: Delay refresh in case we're installing/deleting
+ ;; several packages!
+ (package-quickstart-refresh)
+ (delete-file package-quickstart-file)))
+
+(defun package-quickstart-refresh ()
+ "(Re)Generate the `package-quickstart-file'."
+ (interactive)
+ (package-initialize 'no-activate)
+ (require 'info)
+ (let ((package--quickstart-pkgs ())
+ ;; Pretend we haven't activated anything yet!
+ (package-activated-list ())
+ ;; Make sure we can load this file without load-source-file-function.
+ (coding-system-for-write 'emacs-internal)
+ (Info-directory-list '("")))
+ (dolist (elt package-alist)
+ (condition-case err
+ (package-activate (car elt))
+ ;; Don't let failure of activation of a package arbitrarily stop
+ ;; activation of further packages.
+ (error (message "%s" (error-message-string err)))))
+ (setq package--quickstart-pkgs (nreverse package--quickstart-pkgs))
+ (with-temp-file package-quickstart-file
+ (emacs-lisp-mode) ;For `syntax-ppss'.
+ (insert ";;; Quickstart file to activate all packages at startup -*- lexical-binding:t -*-\n")
+ (insert ";; ¡¡ This file is autogenerated by `package-quickstart-refresh', DO NOT EDIT !!\n\n")
+ (dolist (pkg package--quickstart-pkgs)
+ (let* ((file
+ ;; Prefer uncompiled files (and don't accept .so files).
+ (let ((load-suffixes '(".el" ".elc")))
+ (locate-library (package--autoloads-file-name pkg))))
+ (pfile (prin1-to-string file)))
+ (insert "(let ((load-file-name " pfile "))\n")
+ (insert-file-contents file)
+ ;; Fixup the special #$ reader form and throw away comments.
+ (while (re-search-forward "#\\$\\|^;\\(.*\n\\)" nil 'move)
+ (unless (nth 8 (syntax-ppss))
+ (replace-match (if (match-end 1) "" pfile) t t)))
+ (unless (bolp) (insert "\n"))
+ (insert ")\n")))
+ (pp `(setq package-activated-list
+ (append ',(mapcar #'package-desc-name package--quickstart-pkgs)
+ package-activated-list))
+ (current-buffer))
+ (let ((info-dirs (butlast Info-directory-list)))
+ (when info-dirs
+ (pp `(progn (require 'info)
+ (info-initialize)
+ (setq Info-directory-list
+ (append ',info-dirs Info-directory-list)))
+ (current-buffer))))
+ ;; Use `\s' instead of a space character, so this code chunk is not
+ ;; mistaken for an actual file-local section of package.el.
+ (insert "
+;; Local\sVariables:
+;; version-control: never
+;;\sno-byte-compile: t
+;; no-update-autoloads: t
+;; End:
+"))))
+
(provide 'package)
;;; package.el ends here
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 7859860c560..a644453a948 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -63,6 +63,7 @@
;; FIXME: Now that macroexpansion is also performed when loading an interpreted
;; file, this is not a real problem any more.
(defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq))
+;; (defconst pcase--memoize (make-hash-table :test 'eq))
;; (defconst pcase--memoize-1 (make-hash-table :test 'eq))
;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal))
@@ -175,7 +176,9 @@ Emacs Lisp manual for more information and examples."
;; FIXME: Obviously, this will collide with nadvice's use of
;; function-documentation if we happen to advise `pcase'.
+;;;###autoload
(put 'pcase 'function-documentation '(pcase--make-docstring))
+;;;###autoload
(defun pcase--make-docstring ()
(let* ((main (documentation (symbol-function 'pcase) 'raw))
(ud (help-split-fundoc main 'pcase)))
@@ -782,7 +785,7 @@ Otherwise, it defers to REST which is a list of branches of the form
((eq 'or (caar matches))
(let* ((alts (cdar matches))
(var (if (eq (caar alts) 'match) (cadr (car alts))))
- (simples '()) (others '()) (memq-ok t))
+ (simples '()) (others '()) (memql-ok t))
(when var
(dolist (alt alts)
(if (and (eq (car alt) 'match) (eq var (cadr alt))
@@ -790,16 +793,16 @@ Otherwise, it defers to REST which is a list of branches of the form
(eq (car-safe upat) 'quote)))
(let ((val (cadr (cddr alt))))
(unless (or (integerp val) (symbolp val))
- (setq memq-ok nil))
+ (setq memql-ok nil))
(push (cadr (cddr alt)) simples))
(push alt others))))
(cond
((null alts) (error "Please avoid it") (pcase--u rest))
- ;; Yes, we can use `memq' (or `member')!
+ ;; Yes, we can use `memql' (or `member')!
((> (length simples) 1)
(pcase--u1 (cons `(match ,var
. (pred (pcase--flip
- ,(if memq-ok #'memq #'member)
+ ,(if memql-ok #'memql #'member)
',simples)))
(cdr matches))
code vars
@@ -887,7 +890,8 @@ Otherwise, it defers to REST which is a list of branches of the form
(else-rest (cdr splitrest)))
(pcase--if (cond
((null val) `(null ,sym))
- ((or (integerp val) (symbolp val))
+ ((integerp val) `(eql ,sym ,val))
+ ((symbolp val)
(if (pcase--self-quoting-p val)
`(eq ,sym ,val)
`(eq ,sym ',val)))
@@ -936,7 +940,7 @@ QPAT can take the following forms:
,PAT matches if the `pcase' pattern PAT matches.
SYMBOL matches if EXPVAL is `equal' to SYMBOL.
KEYWORD likewise for KEYWORD.
- INTEGER likewise for INTEGER.
+ NUMBER likewise for NUMBER.
STRING likewise for STRING.
The list or vector QPAT is a template. The predicate formed
@@ -966,7 +970,10 @@ The predicate is the logical-AND of:
`(and (pred consp)
(app car ,(list '\` (car qpat)))
(app cdr ,(list '\` (cdr qpat)))))
- ((or (stringp qpat) (integerp qpat) (symbolp qpat)) `',qpat)
+ ((or (stringp qpat) (numberp qpat) (symbolp qpat)) `',qpat)
+ ;; In all other cases just raise an error so we can't break
+ ;; backward compatibility when adding \` support for other
+ ;; compounded values that are not `consp'
(t (error "Unknown QPAT: %S" qpat))))
(provide 'pcase)
diff --git a/lisp/emacs-lisp/radix-tree.el b/lisp/emacs-lisp/radix-tree.el
index 519087ca3e7..75d9874b431 100644
--- a/lisp/emacs-lisp/radix-tree.el
+++ b/lisp/emacs-lisp/radix-tree.el
@@ -74,7 +74,7 @@
(cmp (compare-strings prefix nil nil key i ni)))
(if (eq t cmp)
(pcase (radix-tree--remove ptree key ni)
- (`nil rtree)
+ ('nil rtree)
(`((,pprefix . ,pptree))
`((,(concat prefix pprefix) . ,pptree) . ,rtree))
(nptree `((,prefix . ,nptree) . ,rtree)))
@@ -237,6 +237,8 @@ PREFIX is only used internally."
(radix-tree-iter-mappings tree (lambda (_k _v) (setq i (1+ i))))
i))
+(declare-function map-apply "map" (function map))
+
(defun radix-tree-from-map (map)
;; Aka (cl-defmethod map-into (map (type (eql radix-tree)))) ...)
(require 'map)
diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el
index 63786c1508c..d883752d712 100644
--- a/lisp/emacs-lisp/regexp-opt.el
+++ b/lisp/emacs-lisp/regexp-opt.el
@@ -84,11 +84,14 @@
;;; Code:
;;;###autoload
-(defun regexp-opt (strings &optional paren)
+(defun regexp-opt (strings &optional paren keep-order)
"Return a regexp to match a string in the list STRINGS.
-Each string should be unique in STRINGS and should not contain
-any regexps, quoted or not. Optional PAREN specifies how the
-returned regexp is surrounded by grouping constructs.
+Each member of STRINGS is treated as a fixed string, not as a regexp.
+Optional PAREN specifies how the returned regexp is surrounded by
+grouping constructs.
+
+If STRINGS is the empty list, the return value is a regexp that
+never matches anything.
The optional argument PAREN can be any of the following:
@@ -111,8 +114,14 @@ nil
necessary to ensure that a postfix operator appended to it will
apply to the whole expression.
-The resulting regexp is equivalent to but usually more efficient
-than that of a simplified version:
+The optional argument KEEP-ORDER, if nil or omitted, allows the
+returned regexp to match the strings in any order. If non-nil,
+the match is guaranteed to be performed in the order given, as if
+the strings were made into a regexp by joining them with the
+`\\|' operator.
+
+Up to reordering, the resulting regexp is equivalent to but
+usually more efficient than that of a simplified version:
(defun simplified-regexp-opt (strings &optional paren)
(let ((parens
@@ -133,7 +142,19 @@ than that of a simplified version:
(open (cond ((stringp paren) paren) (paren "\\(")))
(sorted-strings (delete-dups
(sort (copy-sequence strings) 'string-lessp)))
- (re (regexp-opt-group sorted-strings (or open t) (not open))))
+ (re
+ (cond
+ ;; No strings: return a\` which cannot match anything.
+ ((null strings)
+ (concat (or open "\\(?:") "a\\`\\)"))
+ ;; If we cannot reorder, give up all attempts at
+ ;; optimisation. There is room for improvement (Bug#34641).
+ ((and keep-order (regexp-opt--contains-prefix sorted-strings))
+ (concat (or open "\\(?:")
+ (mapconcat #'regexp-quote strings "\\|")
+ "\\)"))
+ (t
+ (regexp-opt-group sorted-strings (or open t) (not open))))))
(cond ((eq paren 'words)
(concat "\\<" re "\\>"))
((eq paren 'symbols)
@@ -313,6 +334,22 @@ CHARS should be a list of characters."
(concat "[" dash caret "]"))
(concat "[" bracket charset caret dash "]"))))
+
+(defun regexp-opt--contains-prefix (strings)
+ "Whether STRINGS contains a proper prefix of one of its other elements.
+STRINGS must be a list of sorted strings without duplicates."
+ (let ((s strings))
+ ;; In a lexicographically sorted list, a string always immediately
+ ;; succeeds one of its prefixes.
+ (while (and (cdr s)
+ (not (string-equal
+ (car s)
+ (substring (cadr s) 0 (min (length (car s))
+ (length (cadr s)))))))
+ (setq s (cdr s)))
+ (cdr s)))
+
+
(provide 'regexp-opt)
;;; regexp-opt.el ends here
diff --git a/lisp/emacs-lisp/ring.el b/lisp/emacs-lisp/ring.el
index cfbe4eb9ef8..c7d0268a77f 100644
--- a/lisp/emacs-lisp/ring.el
+++ b/lisp/emacs-lisp/ring.el
@@ -189,17 +189,28 @@ Raise error if ITEM is not in the RING."
(defun ring-extend (ring x)
"Increase the size of RING by X."
(when (and (integerp x) (> x 0))
- (let* ((hd (car ring))
- (length (ring-length ring))
- (size (ring-size ring))
- (old-vec (cddr ring))
- (new-vec (make-vector (+ size x) nil)))
- (setcdr ring (cons length new-vec))
- ;; If the ring is wrapped, the existing elements must be written
- ;; out in the right order.
- (dotimes (j length)
- (aset new-vec j (aref old-vec (mod (+ hd j) size))))
- (setcar ring 0))))
+ (ring-resize ring (+ x (ring-size ring)))))
+
+(defun ring-resize (ring size)
+ "Set the size of RING to SIZE.
+If the new size is smaller, then the oldest items in the ring are
+discarded."
+ (when (integerp size)
+ (let ((length (ring-length ring))
+ (new-vec (make-vector size nil)))
+ (if (= length 0)
+ (setcdr ring (cons 0 new-vec))
+ (let* ((hd (car ring))
+ (old-size (ring-size ring))
+ (old-vec (cddr ring))
+ (copy-length (min size length))
+ (copy-hd (mod (+ hd (- length copy-length)) length)))
+ (setcdr ring (cons copy-length new-vec))
+ ;; If the ring is wrapped, the existing elements must be written
+ ;; out in the right order.
+ (dotimes (j copy-length)
+ (aset new-vec j (aref old-vec (mod (+ copy-hd j) old-size))))
+ (setcar ring 0))))))
(defun ring-insert+extend (ring item &optional grow-p)
"Like `ring-insert', but if GROW-P is non-nil, then enlarge ring.
diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el
index a16c5da053a..fdd24317c6a 100644
--- a/lisp/emacs-lisp/rx.el
+++ b/lisp/emacs-lisp/rx.el
@@ -1,4 +1,4 @@
-;;; rx.el --- sexp notation for regular expressions
+;;; rx.el --- sexp notation for regular expressions -*- lexical-binding: t -*-
;; Copyright (C) 2001-2019 Free Software Foundation, Inc.
@@ -106,6 +106,8 @@
;;; Code:
+(require 'cl-lib)
+
;; FIXME: support macros.
(defvar rx-constituents ;Not `const' because some modes extend it.
@@ -244,7 +246,9 @@ regular expressions.")
(defconst rx-categories
- '((consonant . ?0)
+ '((space-for-indent . ?\s)
+ (base . ?.)
+ (consonant . ?0)
(base-vowel . ?1)
(upper-diacritical-mark . ?2)
(lower-diacritical-mark . ?3)
@@ -263,7 +267,9 @@ regular expressions.")
(japanese-hiragana-two-byte . ?H)
(indian-two-byte . ?I)
(japanese-katakana-two-byte . ?K)
+ (strong-left-to-right . ?L)
(korean-hangul-two-byte . ?N)
+ (strong-right-to-left . ?R)
(cyrillic-two-byte . ?Y)
(combining-diacritic . ?^)
(ascii . ?a)
@@ -387,7 +393,7 @@ FORM is of the form `(and FORM1 ...)'."
(rx-group-if
(if (memq nil (mapcar 'stringp (cdr form)))
(mapconcat (lambda (x) (rx-form x '|)) (cdr form) "\\|")
- (regexp-opt (cdr form)))
+ (regexp-opt (cdr form) nil t))
(and (memq rx-parent '(: * t)) rx-parent)))
@@ -423,6 +429,13 @@ Only both edges of each range is checked."
;; set L list of all ranges
(mapc (lambda (e) (cond ((stringp e) (push e str))
((numberp e) (push (cons e e) l))
+ ;; Ranges between ASCII and raw bytes are split,
+ ;; to prevent accidental inclusion of Unicode
+ ;; characters later on.
+ ((and (<= (car e) #x7f)
+ (>= (cdr e) #x3fff80))
+ (push (cons (car e) #x7f) l)
+ (push (cons #x3fff80 (cdr e)) l))
(t (push e l))))
args)
;; condense overlapped ranges in L
@@ -447,28 +460,38 @@ Only both edges of each range is checked."
(defun rx-check-any-string (str)
- "Check string argument STR for Rx `any'."
- (let ((i 0)
- c1 c2 l)
- (if (= 0 (length str))
- (error "String arg for Rx `any' must not be empty"))
- (while (string-match ".-." str i)
- ;; string before range: convert it to characters
- (if (< i (match-beginning 0))
- (setq l (nconc
- l
- (append (substring str i (match-beginning 0)) nil))))
- ;; range
- (setq i (match-end 0)
- c1 (aref str (match-beginning 0))
- c2 (aref str (1- i)))
- (cond
- ((< c1 c2) (setq l (nconc l (list (cons c1 c2)))))
- ((= c1 c2) (setq l (nconc l (list c1))))))
- ;; rest?
- (if (< i (length str))
- (setq l (nconc l (append (substring str i) nil))))
- l))
+ "Turn the `any' argument string STR into a list of characters.
+The original order is not preserved. Ranges, \"A-Z\", become pairs, (?A . ?Z)."
+ (let ((decode-char
+ ;; Make sure raw bytes are decoded as such, to avoid confusion with
+ ;; U+0080..U+00FF.
+ (if (multibyte-string-p str)
+ #'identity
+ (lambda (c) (if (<= #x80 c #xff)
+ (+ c #x3fff00)
+ c))))
+ (len (length str))
+ (i 0)
+ (ret nil))
+ (if (= 0 len)
+ (error "String arg for Rx `any' must not be empty"))
+ (while (< i len)
+ (cond ((and (< i (- len 2))
+ (= (aref str (+ i 1)) ?-))
+ ;; Range.
+ (let ((start (funcall decode-char (aref str i)))
+ (end (funcall decode-char (aref str (+ i 2)))))
+ (cond ((< start end) (push (cons start end) ret))
+ ((= start end) (push start ret))
+ (t
+ (error "Rx character range `%c-%c' is reversed"
+ start end)))
+ (setq i (+ i 3))))
+ (t
+ ;; Single character.
+ (push (funcall decode-char (aref str i)) ret)
+ (setq i (+ i 1)))))
+ ret))
(defun rx-check-any (arg)
@@ -483,7 +506,10 @@ Only both edges of each range is checked."
(null (string-match "\\`\\[\\[:[-a-z]+:\\]\\]\\'" translation)))
(error "Invalid char class `%s' in Rx `any'" arg))
(list (substring translation 1 -1)))) ; strip outer brackets
- ((and (integerp (car-safe arg)) (integerp (cdr-safe arg)))
+ ((and (characterp (car-safe arg)) (characterp (cdr-safe arg)))
+ (unless (<= (car arg) (cdr arg))
+ (error "Rx character range `%c-%c' is reversed"
+ (car arg) (cdr arg)))
(list arg))
((stringp arg) (rx-check-any-string arg))
((error
@@ -589,7 +615,7 @@ ARG is optional."
(rx-check form)
(let ((result (rx-form (cadr form) '!))
case-fold-search)
- (cond ((string-match "\\`\\[^" result)
+ (cond ((string-match "\\`\\[\\^" result)
(cond
((equal result "[^]") "[^^]")
((and (= (length result) 4) (null (eq rx-parent '!)))
@@ -724,8 +750,8 @@ If OP is anything else, produce a greedy regexp if `rx-greedy-flag'
is non-nil."
(rx-check form)
(setq form (rx-trans-forms form))
- (let ((suffix (cond ((memq (car form) '(* + ?\s)) "")
- ((memq (car form) '(*? +? ??)) "?")
+ (let ((suffix (cond ((memq (car form) '(* + \? ?\s)) "")
+ ((memq (car form) '(*? +? \?? ??)) "?")
(rx-greedy-flag "")
(t "?")))
(op (cond ((memq (car form) '(* *? 0+ zero-or-more)) "*")
@@ -767,7 +793,7 @@ of all atomic regexps."
((= l 3) (string-match "\\`\\(?:\\\\[cCsS_]\\|\\[[^^]\\]\\)" r))
((null lax)
(cond
- ((string-match "\\`\\[^?\]?\\(?:\\[:[a-z]+:]\\|[^]]\\)*\\]\\'" r))
+ ((string-match "\\`\\[\\^?]?\\(?:\\[:[a-z]+:]\\|[^]]\\)*]\\'" r))
((string-match "\\`\\\\(\\(?:[^\\]\\|\\\\[^)]\\)*\\\\)\\'" r)))))))
@@ -828,33 +854,34 @@ If FORM is `(minimal-match FORM1)', non-greedy versions of `*',
(rx-group-if (cadr form) rx-parent))
-(defun rx-form (form &optional rx-parent)
+(defun rx-form (form &optional parent)
"Parse and produce code for regular expression FORM.
FORM is a regular expression in sexp form.
-RX-PARENT shows which type of expression calls and controls putting of
+PARENT shows which type of expression calls and controls putting of
shy groups around the result and some more in other functions."
- (cond
- ((stringp form)
- (rx-group-if (regexp-quote form)
- (if (and (eq rx-parent '*) (< 1 (length form)))
- rx-parent)))
- ((integerp form)
- (regexp-quote (char-to-string form)))
- ((symbolp form)
- (let ((info (rx-info form nil)))
- (cond ((stringp info)
- info)
- ((null info)
- (error "Unknown rx form `%s'" form))
- (t
- (funcall (nth 0 info) form)))))
- ((consp form)
- (let ((info (rx-info (car form) 'head)))
- (unless (consp info)
- (error "Unknown rx form `%s'" (car form)))
- (funcall (nth 0 info) form)))
- (t
- (error "rx syntax error at `%s'" form))))
+ (let ((rx-parent parent))
+ (cond
+ ((stringp form)
+ (rx-group-if (regexp-quote form)
+ (if (and (eq parent '*) (< 1 (length form)))
+ parent)))
+ ((integerp form)
+ (regexp-quote (char-to-string form)))
+ ((symbolp form)
+ (let ((info (rx-info form nil)))
+ (cond ((stringp info)
+ info)
+ ((null info)
+ (error "Unknown rx form `%s'" form))
+ (t
+ (funcall (nth 0 info) form)))))
+ ((consp form)
+ (let ((info (rx-info (car form) 'head)))
+ (unless (consp info)
+ (error "Unknown rx form `%s'" (car form)))
+ (funcall (nth 0 info) form)))
+ (t
+ (error "rx syntax error at `%s'" form)))))
;;;###autoload
@@ -895,6 +922,7 @@ CHAR
matches any character in SET .... SET may be a character or string.
Ranges of characters can be specified as `A-Z' in strings.
Ranges may also be specified as conses like `(?A . ?Z)'.
+ Reversed ranges like `Z-A' and `(?Z . ?A)' are not permitted.
SET may also be the name of a character class: `digit',
`control', `hex-digit', `blank', `graph', `print', `alnum',
@@ -955,7 +983,7 @@ CHAR
matches 0 through 9.
`control', `cntrl'
- matches ASCII control characters.
+ matches any character whose code is in the range 0-31.
`hex-digit', `hex', `xdigit'
matches 0 through 9, a through f and A through F.
@@ -1042,7 +1070,9 @@ CHAR
matches a character with category CATEGORY. CATEGORY must be
either a character to use for C, or one of the following symbols.
- `consonant' (\\c0 in string notation)
+ `space-for-indent' (\\c\\s in string notation)
+ `base' (\\c.)
+ `consonant' (\\c0)
`base-vowel' (\\c1)
`upper-diacritical-mark' (\\c2)
`lower-diacritical-mark' (\\c3)
@@ -1060,7 +1090,9 @@ CHAR
`japanese-hiragana-two-byte' (\\cH)
`indian-two-byte' (\\cI)
`japanese-katakana-two-byte' (\\cK)
+ `strong-left-to-right' (\\cL)
`korean-hangul-two-byte' (\\cN)
+ `strong-right-to-left' (\\cR)
`cyrillic-two-byte' (\\cY)
`combining-diacritic' (\\c^)
`ascii' (\\ca)
diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el
index 5f3d224e1f8..3413cd1513c 100644
--- a/lisp/emacs-lisp/seq.el
+++ b/lisp/emacs-lisp/seq.el
@@ -4,7 +4,7 @@
;; Author: Nicolas Petton <nicolas@petton.fr>
;; Keywords: sequences
-;; Version: 2.20
+;; Version: 2.21
;; Package: seq
;; Maintainer: emacs-devel@gnu.org
@@ -110,6 +110,14 @@ name to be bound to the rest of SEQUENCE."
"Return the number of elements of SEQUENCE."
(length sequence))
+(defun seq-first (sequence)
+ "Return the first element of SEQUENCE."
+ (seq-elt sequence 0))
+
+(defun seq-rest (sequence)
+ "Return a sequence of the elements of SEQUENCE except the first one."
+ (seq-drop sequence 1))
+
(cl-defgeneric seq-do (function sequence)
"Apply FUNCTION to each element of SEQUENCE, presumably for side effects.
Return SEQUENCE."
@@ -348,6 +356,7 @@ found or not."
count))
(cl-defgeneric seq-contains (sequence elt &optional testfn)
+ (declare (obsolete seq-contains-p "27.1"))
"Return the first element in SEQUENCE that is equal to ELT.
Equality is defined by TESTFN if non-nil or by `equal' if nil."
(seq-some (lambda (e)
@@ -355,11 +364,20 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil."
e))
sequence))
+(cl-defgeneric seq-contains-p (sequence elt &optional testfn)
+ "Return non-nil if SEQUENCE contains an element equal to ELT.
+Equality is defined by TESTFN if non-nil or by `equal' if nil."
+ (catch 'seq--break
+ (seq-doseq (e sequence)
+ (when (funcall (or testfn #'equal) e elt)
+ (throw 'seq--break t)))
+ nil))
+
(cl-defgeneric seq-set-equal-p (sequence1 sequence2 &optional testfn)
"Return non-nil if SEQUENCE1 and SEQUENCE2 contain the same elements, regardless of order.
Equality is defined by TESTFN if non-nil or by `equal' if nil."
- (and (seq-every-p (lambda (item1) (seq-contains sequence2 item1 testfn)) sequence1)
- (seq-every-p (lambda (item2) (seq-contains sequence1 item2 testfn)) sequence2)))
+ (and (seq-every-p (lambda (item1) (seq-contains-p sequence2 item1 testfn)) sequence1)
+ (seq-every-p (lambda (item2) (seq-contains-p sequence1 item2 testfn)) sequence2)))
(cl-defgeneric seq-position (sequence elt &optional testfn)
"Return the index of the first element in SEQUENCE that is equal to ELT.
@@ -377,7 +395,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil."
TESTFN is used to compare elements, or `equal' if TESTFN is nil."
(let ((result '()))
(seq-doseq (elt sequence)
- (unless (seq-contains result elt testfn)
+ (unless (seq-contains-p result elt testfn)
(setq result (cons elt result))))
(nreverse result)))
@@ -402,7 +420,7 @@ negative integer or 0, nil is returned."
"Return a list of the elements that appear in both SEQUENCE1 and SEQUENCE2.
Equality is defined by TESTFN if non-nil or by `equal' if nil."
(seq-reduce (lambda (acc elt)
- (if (seq-contains sequence2 elt testfn)
+ (if (seq-contains-p sequence2 elt testfn)
(cons elt acc)
acc))
(seq-reverse sequence1)
@@ -412,9 +430,9 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil."
"Return a list of the elements that appear in SEQUENCE1 but not in SEQUENCE2.
Equality is defined by TESTFN if non-nil or by `equal' if nil."
(seq-reduce (lambda (acc elt)
- (if (not (seq-contains sequence2 elt testfn))
- (cons elt acc)
- acc))
+ (if (seq-contains-p sequence2 elt testfn)
+ acc
+ (cons elt acc)))
(seq-reverse sequence1)
'()))
diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el
index 636a90d0d27..85adbe3dd12 100644
--- a/lisp/emacs-lisp/shadow.el
+++ b/lisp/emacs-lisp/shadow.el
@@ -78,7 +78,7 @@ See the documentation for `list-load-path-shadows' for further information."
shadows ; List of shadowings, to be returned.
files ; File names ever seen, with dirs.
dir ; The dir being currently scanned.
- dir-case-insensitive ; `file-name-case-insentive-p' for dir.
+ dir-case-insensitive ; `file-name-case-insensitive-p' of dir.
curr-files ; This dir's Emacs Lisp files.
orig-dir ; Where the file was first seen.
files-seen-this-dir ; Files seen so far in this dir.
@@ -161,8 +161,8 @@ See the documentation for `list-load-path-shadows' for further information."
(or (equal (file-truename f1) (file-truename f2))
;; As a quick test, avoiding spawning a process, compare file
;; sizes.
- (and (= (nth 7 (file-attributes f1))
- (nth 7 (file-attributes f2)))
+ (and (= (file-attribute-size (file-attributes f1))
+ (file-attribute-size (file-attributes f2)))
(eq 0 (call-process "cmp" nil nil nil "-s" f1 f2))))))))
(defvar load-path-shadows-font-lock-keywords
diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el
index d0c6cac79fa..92b639d71e2 100644
--- a/lisp/emacs-lisp/smie.el
+++ b/lisp/emacs-lisp/smie.el
@@ -533,9 +533,9 @@ PREC2 is a table as returned by `smie-precs->prec2' or
(setq y (cons nil (cons nil nil)))
(push (cons (cdr k) y) table))
(pcase v
- (`= (push (cons x y) eqs))
- (`< (push (cons x y) csts))
- (`> (push (cons y x) csts))
+ ('= (push (cons x y) eqs))
+ ('< (push (cons x y) csts))
+ ('> (push (cons y x) csts))
(_ (error "SMIE error: prec2 has %S↦%S which ∉ {<,+,>}"
k v))))))
prec2)
@@ -612,8 +612,8 @@ PREC2 is a table as returned by `smie-precs->prec2' or
(dolist (x (gethash :smie-open/close-alist prec2))
(let* ((token (car x))
(cons (pcase (cdr x)
- (`closer (cddr (assoc token table)))
- (`opener (cdr (assoc token table))))))
+ ('closer (cddr (assoc token table)))
+ ('opener (cdr (assoc token table))))))
;; `cons' can be nil for openers/closers which only contain
;; "atomic" elements.
(when cons
@@ -1856,9 +1856,9 @@ KEYWORDS are additional arguments, which can use the following keywords:
(let ((k (pop keywords))
(v (pop keywords)))
(pcase k
- (`:forward-token
+ (:forward-token
(set (make-local-variable 'smie-forward-token-function) v))
- (`:backward-token
+ (:backward-token
(set (make-local-variable 'smie-backward-token-function) v))
(_ (message "smie-setup: ignoring unknown keyword %s" k)))))
(let ((ca (cdr (assq :smie-closer-alist grammar))))
diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index 15c9a824d39..b9ffe6a6fc6 100644
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -152,8 +152,8 @@ are non-nil, then the result is non-nil."
(let (res)
(if varlist
`(let* ,(setq varlist (internal--build-bindings varlist))
- (if ,(setq res (caar (last varlist)))
- ,@(or body `(,res))))
+ (when ,(setq res (caar (last varlist)))
+ ,@(or body `(,res))))
`(let* () ,@(or body '(t))))))
(defmacro if-let (spec then &rest else)
@@ -208,7 +208,7 @@ The variable list SPEC is the same as in `if-let'."
(defsubst string-join (strings &optional separator)
"Join all STRINGS using SEPARATOR."
- (mapconcat 'identity strings separator))
+ (mapconcat #'identity strings separator))
(define-obsolete-function-alias 'string-reverse 'reverse "25.1")
@@ -216,17 +216,17 @@ The variable list SPEC is the same as in `if-let'."
"Trim STRING of leading string matching REGEXP.
REGEXP defaults to \"[ \\t\\n\\r]+\"."
- (if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+")"\\)") string)
- (replace-match "" t t string)
+ (if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string)
+ (substring string (match-end 0))
string))
(defsubst string-trim-right (string &optional regexp)
"Trim STRING of trailing string matching REGEXP.
REGEXP defaults to \"[ \\t\\n\\r]+\"."
- (if (string-match (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'") string)
- (replace-match "" t t string)
- string))
+ (let ((i (string-match-p (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'")
+ string)))
+ (if i (substring string 0 i) string)))
(defsubst string-trim (string &optional trim-left trim-right)
"Trim STRING of leading and trailing strings matching TRIM-LEFT and TRIM-RIGHT.
@@ -250,6 +250,35 @@ TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"."
(substring string 0 (- (length string) (length suffix)))
string))
+(defun replace-region-contents (beg end replace-fn
+ &optional max-secs max-costs)
+ "Replace the region between BEG and END using REPLACE-FN.
+REPLACE-FN runs on the current buffer narrowed to the region. It
+should return either a string or a buffer replacing the region.
+
+The replacement is performed using `replace-buffer-contents'
+which also describes the MAX-SECS and MAX-COSTS arguments and the
+return value.
+
+Note: If the replacement is a string, it'll be placed in a
+temporary buffer so that `replace-buffer-contents' can operate on
+it. Therefore, if you already have the replacement in a buffer,
+it makes no sense to convert it to a string using
+`buffer-substring' or similar."
+ (save-excursion
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char (point-min))
+ (let ((repl (funcall replace-fn)))
+ (if (bufferp repl)
+ (replace-buffer-contents repl max-secs max-costs)
+ (let ((source-buffer (current-buffer)))
+ (with-temp-buffer
+ (insert repl)
+ (let ((tmp-buffer (current-buffer)))
+ (set-buffer source-buffer)
+ (replace-buffer-contents tmp-buffer max-secs max-costs)))))))))
+
(provide 'subr-x)
;;; subr-x.el ends here
diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el
index f27596f77c7..d09d6c12254 100644
--- a/lisp/emacs-lisp/syntax.el
+++ b/lisp/emacs-lisp/syntax.el
@@ -176,7 +176,7 @@ Note: back-references in REGEXPs do not work."
(re
(mapconcat
(lambda (rule)
- (let* ((orig-re (eval (car rule)))
+ (let* ((orig-re (eval (car rule) t))
(re orig-re))
(when (and (assq 0 rule) (cdr rules))
;; If there's more than 1 rule, and the rule want to apply
@@ -190,7 +190,7 @@ Note: back-references in REGEXPs do not work."
(cond
((assq 0 rule) (if (zerop offset) t
`(match-beginning ,offset)))
- ((null (cddr rule))
+ ((and (cdr rule) (null (cddr rule)))
`(match-beginning ,(+ offset (car (cadr rule)))))
(t
`(or ,@(mapcar
@@ -434,14 +434,20 @@ These are valid when the buffer has no restriction.")
(setcdr cell cache)))
))
+;;; FIXME: Explain this variable. Currently only its last (5th) slot is used.
+;;; Perhaps the other slots should be removed?
(defvar syntax-ppss-stats
- [(0 . 0.0) (0 . 0.0) (0 . 0.0) (0 . 0.0) (0 . 0.0) (1 . 2500.0)])
+ [(0 . 0) (0 . 0) (0 . 0) (0 . 0) (0 . 0) (2 . 2500)])
(defun syntax-ppss-stats ()
(mapcar (lambda (x)
(condition-case nil
- (cons (car x) (truncate (/ (cdr x) (car x))))
+ (cons (car x) (/ (cdr x) (car x)))
(error nil)))
syntax-ppss-stats))
+(defun syntax-ppss--update-stats (i old new)
+ (let ((pair (aref syntax-ppss-stats i)))
+ (cl-incf (car pair))
+ (cl-incf (cdr pair) (- new old))))
(defvar-local syntax-ppss-table nil
"Syntax-table to use during `syntax-ppss', if any.")
@@ -486,11 +492,10 @@ running the hook."
(if (and old-pos (< (- pos old-pos)
;; The time to use syntax-begin-function and
;; find PPSS is assumed to be about 2 * distance.
- (* 2 (/ (cdr (aref syntax-ppss-stats 5))
- (1+ (car (aref syntax-ppss-stats 5)))))))
+ (let ((pair (aref syntax-ppss-stats 5)))
+ (/ (* 2 (cdr pair)) (car pair)))))
(progn
- (cl-incf (car (aref syntax-ppss-stats 0)))
- (cl-incf (cdr (aref syntax-ppss-stats 0)) (- pos old-pos))
+ (syntax-ppss--update-stats 0 old-pos pos)
(parse-partial-sexp old-pos pos nil nil old-ppss))
(cond
@@ -506,8 +511,7 @@ running the hook."
(setq pt-min (or (syntax-ppss-toplevel-pos old-ppss)
(nth 2 old-ppss)))
(<= pt-min pos) (< (- pos pt-min) syntax-ppss-max-span))
- (cl-incf (car (aref syntax-ppss-stats 1)))
- (cl-incf (cdr (aref syntax-ppss-stats 1)) (- pos pt-min))
+ (syntax-ppss--update-stats 1 pt-min pos)
(setq ppss (parse-partial-sexp pt-min pos)))
;; The OLD-* data can't be used. Consult the cache.
(t
@@ -529,14 +533,18 @@ running the hook."
;; Setup the before-change function if necessary.
(unless (or ppss-cache ppss-last)
+ ;; We should be either the very last function on
+ ;; before-change-functions or the very first on
+ ;; after-change-functions.
+ ;; Note: combine-change-calls-1 needs to be kept in sync
+ ;; with this!
(add-hook 'before-change-functions
'syntax-ppss-flush-cache t t))
;; Use the best of OLD-POS and CACHE.
(if (or (not old-pos) (< old-pos pt-min))
(setq pt-best pt-min ppss-best ppss)
- (cl-incf (car (aref syntax-ppss-stats 4)))
- (cl-incf (cdr (aref syntax-ppss-stats 4)) (- pos old-pos))
+ (syntax-ppss--update-stats 4 old-pos pos)
(setq pt-best old-pos ppss-best old-ppss))
;; Use the `syntax-begin-function' if available.
@@ -556,21 +564,18 @@ running the hook."
(not (memq (get-text-property (point) 'face)
'(font-lock-string-face font-lock-doc-face
font-lock-comment-face))))
- (cl-incf (car (aref syntax-ppss-stats 5)))
- (cl-incf (cdr (aref syntax-ppss-stats 5)) (- pos (point)))
+ (syntax-ppss--update-stats 5 (point) pos)
(setq pt-best (point) ppss-best nil))
(cond
;; Quick case when we found a nearby pos.
((< (- pos pt-best) syntax-ppss-max-span)
- (cl-incf (car (aref syntax-ppss-stats 2)))
- (cl-incf (cdr (aref syntax-ppss-stats 2)) (- pos pt-best))
+ (syntax-ppss--update-stats 2 pt-best pos)
(setq ppss (parse-partial-sexp pt-best pos nil nil ppss-best)))
;; Slow case: compute the state from some known position and
;; populate the cache so we won't need to do it again soon.
(t
- (cl-incf (car (aref syntax-ppss-stats 3)))
- (cl-incf (cdr (aref syntax-ppss-stats 3)) (- pos pt-min))
+ (syntax-ppss--update-stats 3 pt-min pos)
;; If `pt-min' is too far, add a few intermediate entries.
(while (> (- pos pt-min) (* 2 syntax-ppss-max-span))
diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el
index 6fdca2cd083..b23ce21027b 100644
--- a/lisp/emacs-lisp/tabulated-list.el
+++ b/lisp/emacs-lisp/tabulated-list.el
@@ -36,6 +36,43 @@
;;; Code:
+(defgroup tabulated-list nil
+ "Tabulated-list customization group."
+ :group 'convenience
+ :group 'display)
+
+(defcustom tabulated-list-gui-sort-indicator-asc ?▼
+ "Indicator for columns sorted in ascending order, for GUI frames.
+See `tabulated-list-tty-sort-indicator-asc' for the indicator used on
+text-mode frames."
+ :group 'tabulated-list
+ :type 'character
+ :version "27.1")
+
+(defcustom tabulated-list-gui-sort-indicator-desc ?▲
+ "Indicator for columns sorted in descending order, for GUI frames.
+See `tabulated-list-tty-sort-indicator-desc' for the indicator used on
+text-mode frames."
+ :group 'tabulated-list
+ :type 'character
+ :version "27.1")
+
+(defcustom tabulated-list-tty-sort-indicator-asc ?v
+ "Indicator for columns sorted in ascending order, for text-mode frames.
+See `tabulated-list-gui-sort-indicator-asc' for the indicator used on GUI
+frames."
+ :group 'tabulated-list
+ :type 'character
+ :version "27.1")
+
+(defcustom tabulated-list-tty-sort-indicator-desc ?^
+ "Indicator for columns sorted in ascending order, for text-mode frames.
+See `tabulated-list-gui-sort-indicator-asc' for the indicator used on GUI
+frames."
+ :group 'tabulated-list
+ :type 'character
+ :version "27.1")
+
;; The reason `tabulated-list-format' and other variables are
;; permanent-local is to make it convenient to switch to a different
;; major mode, switch back, and have the original Tabulated List data
@@ -151,8 +188,10 @@ If ADVANCE is non-nil, move forward by one line afterwards."
(forward-line)))
(defvar tabulated-list-mode-map
- (let ((map (copy-keymap special-mode-map)))
- (set-keymap-parent map button-buffer-map)
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map (make-composed-keymap
+ button-buffer-map
+ special-mode-map))
(define-key map "n" 'next-line)
(define-key map "p" 'previous-line)
(define-key map "S" 'tabulated-list-sort)
@@ -172,14 +211,20 @@ If ADVANCE is non-nil, move forward by one line afterwards."
map)
"Local keymap for `tabulated-list-mode' sort buttons.")
-(defvar tabulated-list-glyphless-char-display
+(defun tabulated-list-make-glyphless-char-display-table ()
+ "Make the `glyphless-char-display' table used for text-mode frames.
+This table is used for displaying the sorting indicators, see
+variables `tabulated-list-tty-sort-indicator-asc' and
+`tabulated-list-tty-sort-indicator-desc' for more information."
(let ((table (make-char-table 'glyphless-char-display nil)))
(set-char-table-parent table glyphless-char-display)
- ;; Some text terminals can't display the Unicode arrows; be safe.
- (aset table 9650 (cons nil "^"))
- (aset table 9660 (cons nil "v"))
- table)
- "The `glyphless-char-display' table in Tabulated List buffers.")
+ (aset table
+ tabulated-list-gui-sort-indicator-desc
+ (cons nil (char-to-string tabulated-list-tty-sort-indicator-desc)))
+ (aset table
+ tabulated-list-gui-sort-indicator-asc
+ (cons nil (char-to-string tabulated-list-tty-sort-indicator-asc)))
+ table))
(defvar tabulated-list--header-string nil
"Holds the header if `tabulated-list-use-header-line' is nil.
@@ -229,8 +274,11 @@ Populated by `tabulated-list-init-header'.")
(concat label
(cond
((> (+ 2 (length label)) width) "")
- ((cdr tabulated-list-sort-key) " ▲")
- (t " ▼")))
+ ((cdr tabulated-list-sort-key)
+ (format " %c"
+ tabulated-list-gui-sort-indicator-desc))
+ (t (format " %c"
+ tabulated-list-gui-sort-indicator-asc))))
'face 'bold
'tabulated-list-column-name label
button-props))
@@ -653,7 +701,8 @@ as the ewoc pretty-printer."
(setq-local truncate-lines t)
(setq-local buffer-undo-list t)
(setq-local revert-buffer-function #'tabulated-list-revert)
- (setq-local glyphless-char-display tabulated-list-glyphless-char-display)
+ (setq-local glyphless-char-display
+ (tabulated-list-make-glyphless-char-display-table))
;; Avoid messing up the entries' display just because the first
;; column of the first entry happens to begin with a R2L letter.
(setq bidi-paragraph-direction 'left-to-right)
diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el
index 675598fd228..29b481849e2 100644
--- a/lisp/emacs-lisp/tcover-ses.el
+++ b/lisp/emacs-lisp/tcover-ses.el
@@ -39,464 +39,464 @@
;;;Here are some macros that exercise SES. Set `pause' to t if you want the
;;;macros to pause after each step.
(let* ((pause nil)
- (x (if pause "q" ""))
- (y "ses-test.ses\r<"))
+ (x (if pause "\^Xq" ""))
+ (y "\^X\^Fses-test.ses\r\^[<"))
;;Fiddle with the existing spreadsheet
(fset 'ses-exercise-example
- (concat "" data-directory "ses-example.ses\r<"
- x "10"
- x " "
- x ""
- x "pses-center\r"
- x "p\r"
- x "\t\t"
- x "\r A9 B9\r"
- x ""
- x "\r 2\r"
- x ""
+ (concat "\^X\^F" data-directory "ses-example.ses\r\^[<"
+ x "\^U10\^N"
+ x "\^K"
+ x "\^_"
+ x "\^P\^P\^Fpses-center\r"
+ x "\^Fp\r"
+ x "\^U\^P\t\t"
+ x "\r\^B A9 B9\r"
+ x "\^U\^N\^B\^B\^B"
+ x "\r\^A\^K2\r"
+ x "\^N\^N\^F"
x "50\r"
- x "4"
- x " "
- x ""
- x "(+ o\0"
- x "-1o \r"
- x ""
+ x "\^U4\^_"
+ x "\^C\^[\^L"
+ x "\^_"
+ x "(+ \^Xo\^N\^N\^F\0\^F\^F"
+ x "\^U-1\^Xo\^C\^R \^C\^S\r\^B"
+ x "\^_"
x))
;;Create a new spreadsheet
(fset 'ses-exercise-new
(concat y
- x "\"%.8g\"\r"
+ x "\^C\^P\"%.8g\"\r"
x "2\r"
- x ""
- x ""
- x "2"
+ x "\^O"
+ x "\^P"
+ x "\^U2\^O"
x "\"Header\r"
- x "(sqrt 1\r"
- x "pses-center\r"
+ x "(sqrt 1\r\^B"
+ x "pses-center\r\^F"
x "\t"
- x "(+ A2 A3\r"
- x "(* B2 A3\r"
- x "2"
- x "\rB3\r"
- x ""
+ x "\^P(+ A2 A3\r"
+ x "\^F(* B2 A3\r"
+ x "\^U2\^C\^[\^H"
+ x "\r\^?\^?\^?B3\r"
+ x "\^X\^S"
x))
;;Basic cell display
(fset 'ses-exercise-display
- (concat y ":(revert-buffer t t)\r"
- x ""
- x "\"Very long\r"
+ (concat y "\^[:(revert-buffer t t)\r"
+ x "\^E"
+ x "\"Very long\r\^B"
x "w3\r"
x "w3\r"
- x "(/ 1 0\r"
- x "234567\r"
- x "5w"
- x "\t1\r"
- x ""
- x "234567\r"
- x "\t"
- x ""
- x "345678\r"
- x "3w"
- x "\0>"
- x ""
- x ""
- x ""
- x ""
- x ""
- x ""
- x ""
- x "1\r"
- x ""
- x ""
- x "\"1234567-1234567-1234567\r"
- x "123\r"
- x "2"
- x "\"1234567-1234567-1234567\r"
- x "123\r"
- x "w8\r"
- x "\"1234567\r"
- x "w5\r"
+ x "(/ 1 0\r\^B"
+ x "234567\r\^B"
+ x "\^U5w"
+ x "\t1\r\^B"
+ x "\^B\^C\^C"
+ x "\^F234567\r\^B"
+ x "\t\^D\^B"
+ x "\^B\^C\^C"
+ x "345678\r\^B"
+ x "\^U3w"
+ x "\0\^[>"
+ x "\^C\^C"
+ x "\^X\^X"
+ x "\^E"
+ x "\^X\^X\^A"
+ x "\^E"
+ x "\^F\^E"
+ x "\^C\^C"
+ x "1\r\^B"
+ x "\^C\^C\^F"
+ x "\^E"
+ x "\^B\^B\^B\"1234567-1234567-1234567\r\^B"
+ x "123\r\^B"
+ x "\^U2\^O"
+ x "\^N\"1234567-1234567-1234567\r\^B"
+ x "123\r\^B"
+ x "\^F\^Fw8\r"
+ x "\^B\^B\"1234567\r"
+ x "\^N\^Bw5\r"
x))
;;Cell formulas
(fset 'ses-exercise-formulas
- (concat y ":(revert-buffer t t)\r"
+ (concat y "\^[:(revert-buffer t t)\r"
x "\t\t"
x "\t"
- x "(* B1 B2 D1\r"
- x "(* B2 B3\r"
- x "(apply '+ (ses-range B1 B3)\r"
- x "(apply 'ses+ (ses-range B1 B3)\r"
- x "(apply 'ses+ (ses-range A2 A3)\r"
- x "(mapconcat'number-to-string(ses-range B2 B4) \"-\"\r"
- x "(apply 'concat (reverse (ses-range A3 D3))\r"
- x "(* (+ A2 A3) (ses+ B2 B3)\r"
- x ""
- x "2"
- x "5\t"
- x "(apply 'ses+ (ses-range E1 E2)\r"
- x "(apply 'ses+ (ses-range A5 B5)\r"
- x "(apply 'ses+ (ses-range E1 F1)\r"
- x "(apply 'ses+ (ses-range D1 E1)\r"
+ x "(* B1 B2 D1\r\^B"
+ x "(* B2 B3\r\^B"
+ x "\^N(apply '+ (ses-range B1 B3)\r\^B"
+ x "(apply 'ses+ (ses-range B1 B3)\r\^B"
+ x "\^N(apply 'ses+ (ses-range A2 A3)\r\^B"
+ x "\^N(mapconcat'number-to-string(ses-range B2 B4) \"-\"\r\^B"
+ x "\^B(apply 'concat (reverse (ses-range A3 D3))\r\^B"
+ x "\^B(* (+ A2 A3) (ses+ B2 B3)\r\^B"
+ x "\^N"
+ x "\^U2\^O"
+ x "\^U5\t"
+ x "\^P(apply 'ses+ (ses-range E1 E2)\r\^B"
+ x "\^P(apply 'ses+ (ses-range A5 B5)\r\^B"
+ x "\^P(apply 'ses+ (ses-range E1 F1)\r\^B"
+ x "\^P(apply 'ses+ (ses-range D1 E1)\r\^B"
x "\t"
- x "(ses-average (ses-range A2 A5)\r"
- x "(apply 'ses+ (ses-range A5 A6)\r"
- x "k"
- x " "
- x ""
- x "2"
- x "3 "
- x "o"
- x "2o"
- x "3k"
- x "(ses-average (ses-range B3 E3)\r"
- x "k"
- x "12345678\r"
+ x "(ses-average (ses-range A2 A5)\r\^B"
+ x "\^N(apply 'ses+ (ses-range A5 A6)\r\^B"
+ x "\^B\^B\^[k"
+ x "\^N\^N\^K"
+ x "\^P\^P\^P\^O"
+ x "\^N\^U2\^O"
+ x "\^P\^U3\^K"
+ x "\^B\^B\^B\^[o"
+ x "\^F\^U2\^[o"
+ x "\^B\^U3\^[k"
+ x "\^F(ses-average (ses-range B3 E3)\r\^B"
+ x "\^B\^[k"
+ x "\^N\^P12345678\r\^B"
x))
;;Recalculating and reconstructing
(fset 'ses-exercise-recalc
- (concat y ":(revert-buffer t t)\r"
- x " "
+ (concat y "\^[:(revert-buffer t t)\r"
+ x "\^C\^[\^L"
x "\t\t"
- x ""
- x "(/ 1 0\r"
- x ""
+ x "\^C\^C"
+ x "(/ 1 0\r\^B"
+ x "\^C\^C"
x "\n"
- x ""
- x "\"%.6g\"\r"
- x " "
- x ">nw"
- x "\0>xdelete-region\r"
- x " "
- x "8"
- x "\0>xdelete-region\r"
- x " "
- x ""
- x " k"
- x " "
- x "\"Very long\r"
- x ""
- x "\r\r"
- x ""
- x "o"
- x ""
- x "\"Very long2\r"
- x "o"
- x ""
- x "\rC3\r"
- x "\rC2\r"
- x "\0"
- x "\rC4\r"
- x "\rC2\r"
- x "\0"
- x ""
- x "xses-mode\r"
- x "<"
- x "2k"
+ x "\^C\^C"
+ x "\^C\^P\"%.6g\"\r"
+ x "\^C\^[\^L"
+ x "\^[>\^Xnw\^F\^F\^F"
+ x "\0\^[>\^[xdelete-region\r"
+ x "\^C\^[\^L"
+ x "\^U8\^N"
+ x "\0\^[>\^[xdelete-region\r"
+ x "\^C\^[\^L"
+ x "\^C\^N"
+ x "\^N\^K\^B\^[k"
+ x "\^C\^L"
+ x "\^B\"Very long\r"
+ x "\^P\^C\^T"
+ x "\^B\r\r"
+ x "\^N\^C\^T"
+ x "\^F\^[o"
+ x "\^F\^C\^T"
+ x "\^B\^B\"Very long2\r"
+ x "\^B\^[o\^F"
+ x "\^C\^T"
+ x "\r\^?\^?\^?C3\r"
+ x "\^N\r\^?\^?\^?C2\r"
+ x "\^P\0\^N\^F\^C\^C"
+ x "\r\^?\^?C4\r"
+ x "\^N\^N\r\^?\^?\^?C2\r"
+ x "\^F\0\^B\^P\^P"
+ x "\^C\^C"
+ x "\^[xses-mode\r"
+ x "\^[<\^O"
+ x "\^U2\^[k"
x))
;;Header line
(fset 'ses-exercise-header-row
- (concat y ":(revert-buffer t t)\r"
- x "<"
- x ">"
- x "6<"
- x ">"
- x "7<"
- x ">"
- x "8<"
- x "2<"
- x ">"
- x "3w"
- x "10<"
- x ">"
- x "2 "
+ (concat y "\^[:(revert-buffer t t)\r"
+ x "\^X<"
+ x "\^X>"
+ x "\^U6\^X<"
+ x "\^X>"
+ x "\^U7\^X<"
+ x "\^X>"
+ x "\^U8\^X<"
+ x "\^U2\^X<"
+ x "\^X>"
+ x "\^F\^U3w\^B"
+ x "\^U10\^X<"
+ x "\^X>"
+ x "\^U2\^K"
x))
;;Detecting unsafe formulas and printers
(fset 'ses-exercise-unsafe
- (concat y ":(revert-buffer t t)\r"
+ (concat y "\^[:(revert-buffer t t)\r"
x "p(lambda (x) (delete-file x))\rn"
x "p(lambda (x) (delete-file \"ses-nothing\"))\ry"
- x "\0n"
- x "(delete-file \"x\"\rn"
- x "(delete-file \"ses-nothing\"\ry"
- x "\0n"
- x "(open-network-stream \"x\" nil \"localhost\" \"smtp\"\ry"
- x "\0n"
+ x "\0\^F\^W\^Yn"
+ x "\^N(delete-file \"x\"\rn"
+ x "(delete-file \"ses-nothing\"\ry\^B"
+ x "\0\^F\^W\^Yn"
+ x "(open-network-stream \"x\" nil \"localhost\" \"smtp\"\ry\^B"
+ x "\0\^F\^W\^Yn"
x))
;;Inserting and deleting rows
(fset 'ses-exercise-rows
- (concat y ":(revert-buffer t t)\r"
- x ""
- x "\"%s=\"\r"
- x "20"
- x "p\"%s+\"\r"
- x ""
- x "123456789\r"
- x "\021"
- x ""
- x " "
- x "(not B25\r"
- x "k"
+ (concat y "\^[:(revert-buffer t t)\r"
+ x "\^N\^F"
+ x "\^C\^P\"%s=\"\r"
+ x "\^U20\^O"
+ x "\^[p\"%s+\"\r"
+ x "\^N\^O"
+ x "123456789\r\^B"
+ x "\0\^U21\^N\^F"
+ x "\^C\^C"
+ x "\^[\^L"
+ x "\^P\^P(not B25\r\^B"
+ x "\^N\^[k"
x "jA3\r"
- x "19 "
- x " "
- x "100" ;Make this approx your CPU speed in MHz
+ x "\^U19\^K"
+ x "\^P\^F\^K"
+ x "\^U100\^O" ;Make this approx your CPU speed in MHz
x))
;;Inserting and deleting columns
(fset 'ses-exercise-columns
- (concat y ":(revert-buffer t t)\r"
- x "\"%s@\"\r"
- x "o"
- x ""
- x "o"
- x " "
- x "k"
+ (concat y "\^[:(revert-buffer t t)\r"
+ x "\^C\^P\"%s@\"\r"
+ x "\^[o"
+ x "\^O"
+ x "\^[o"
+ x "\^K"
+ x "\^[k"
x "w8\r"
- x "p\"%.7s*\"\r"
- x "o"
- x ""
- x "2o"
- x "3k"
- x "\"%.6g\"\r"
- x "26o"
- x "\026\t"
- x "26o"
- x "0\r"
- x "26\t"
- x "400"
- x "50k"
- x "\0D"
+ x "\^[p\"%.7s*\"\r"
+ x "\^[o"
+ x "\^F"
+ x "\^U2\^[o"
+ x "\^U3\^[k"
+ x "\^C\^P\"%.6g\"\r"
+ x "\^U26\^[o"
+ x "\0\^U26\t"
+ x "\^U26\^[o"
+ x "\^C\^[\^H0\r"
+ x "\^U26\t"
+ x "\^U400\^B"
+ x "\^U50\^[k"
+ x "\0\^N\^N\^F\^F\^C\^[\^SD"
x))
(fset 'ses-exercise-editing
- (concat y ":(revert-buffer t t)\r"
- x "1\r"
- x "('x\r"
- x ""
- x ""
+ (concat y "\^[:(revert-buffer t t)\r"
+ x "\^N\^N\^N1\r\^B"
+ x "\^F(\^B'\^Fx\r\^B"
+ x "\^B\^P\^P\^P\^O"
+ x "\^_"
x "\r\r"
x "w9\r"
- x "\r.5\r"
- x "\r 10\r"
+ x "\^N\r\^B.5\r"
+ x "\^N\^F\r\^B 10\r"
x "w12\r"
- x "\r'\r"
- x "\r\r"
+ x "\r\^A'\r"
+ x "\r\^A\^D\r"
x "jA4\r"
- x "(+ A2 100\r"
- x "3\r"
+ x "(+ A2 100\r\^B"
+ x "\^P\^P3\r\^B"
x "jB1\r"
- x "(not A1\r"
- x "\"Very long\r"
- x ""
- x "h"
- x "H"
- x ""
- x ">\t"
- x ""
- x ""
- x "2"
- x ""
- x "o"
- x "h"
- x "\0"
- x "\"Also very long\r"
- x "H"
- x "\0'\r"
- x "'Trial\r"
- x "'qwerty\r"
- x "(concat o<\0"
- x "-1o\r"
- x "(apply '+ o<\0-1o\r"
- x "2"
- x "-2"
- x "-2"
- x "2"
- x " "
- x "H"
- x "\0"
- x "\"Another long one\r"
- x "H"
- x ""
- x "<"
- x ""
- x ">"
- x "\0"
+ x "(not A1\r\^B"
+ x "\^B\"Very long\r\^B"
+ x "\^C\^C"
+ x "\^[h"
+ x "\^[H"
+ x "\^C\^C"
+ x "\^[>\t"
+ x "\^P\^P\^D"
+ x "\^P\^D"
+ x "\^F\^F\^U2\^?"
+ x "\^P\^?"
+ x "\^[o"
+ x "\^[h"
+ x "\0\^O\^F"
+ x "\"Also very long\r\^B"
+ x "\^N\^F\^[H"
+ x "\0'\r\^B"
+ x "'Trial\r\^B"
+ x "\^N\^B'qwerty\r\^B"
+ x "\^F(concat \^Xo\^[<\0\^N\^N"
+ x "\^U-1\^Xo\^C\^R\r\^B"
+ x "(apply '+ \^Xo\^[<\0\^N\^F\^U-1\^Xo\^C\^S\r\^B"
+ x "\^P\^U2\^?"
+ x "\^U-2\^?"
+ x "\^U-2\^D"
+ x "\^U2\^D"
+ x "\^B\^P\^P\^K"
+ x "\^N\^F\^[H"
+ x "\^B\^P\0\^O"
+ x "\"Another long one\r\^B"
+ x "\^N\^N\^F\^[H"
+ x "\^A\^P\^E"
+ x "\^C\^C\^[<"
+ x "\^N\^E"
+ x "\^[>\^P\^O"
+ x "\0\^E\^F\^E"
x))
;;Sorting of columns
(fset 'ses-exercise-sort-column
- (concat y ":(revert-buffer t t)\r"
+ (concat y "\^[:(revert-buffer t t)\r"
x "\"Very long\r"
- x "99\r"
- x "o13\r"
+ x "\^F99\r"
+ x "\^F\^[o13\r"
x "(+ A3 B3\r"
x "7\r8\r(* A4 B4\r"
- x "\0A\r"
- x "\0B\r"
- x "\0C\r"
- x "o"
- x "\0C\r"
+ x "\0\^P\^P\^P\^C\^[\^SA\r"
+ x "\^N\0\^P\^P\^P\^C\^[\^SB\r"
+ x "\^P\^P\^F\0\^N\^N\^F\^F\^C\^[\^SC\r"
+ x "\^F\^[o\^P\^O"
+ x "\^B\0\^N\^N\^N\^U\^C\^[\^SC\r"
x))
;;Simple cell printers
(fset 'ses-exercise-cell-printers
- (concat y ":(revert-buffer t t)\r"
- x "\"4\t76\r"
- x "\"4\n7\r"
+ (concat y "\^[:(revert-buffer t t)\r"
+ x "\^F\"4\^Q\t76\r\^B"
+ x "\"4\^Q\n7\r\^B"
x "p\"{%S}\"\r"
x "p(\"[%s]\")\r"
x "p(\"<%s>\")\r"
- x "\0"
+ x "\^B\0\^F\^F"
x "p\r"
x "pnil\r"
x "pses-dashfill\r"
- x "48\r"
+ x "48\r\^B"
x "\t"
- x "\0p\r"
- x "p\r"
+ x "\^B\0\^Fp\r"
+ x "\^Fp\r"
x "pses-dashfill\r"
- x "\0pnil\r"
- x "5\r"
+ x "\^B\0\^F\^Fpnil\r"
+ x "5\r\^B"
x "pses-center\r"
- x "\"%s\"\r"
+ x "\^C\^P\"%s\"\r"
x "w8\r"
- x "p\r"
- x "p\"%.7g@\"\r"
- x "\r"
- x "\"%.6g#\"\r"
- x "\"%.6g.\"\r"
- x "\"%.6g.\"\r"
- x "pidentity\r"
- x "6\r"
- x "\"UPCASE\r"
- x "pdowncase\r"
- x "(* 3 4\r"
- x "p(lambda (x) '(\"Hi\"))\r"
- x "p(lambda (x) '(\"Bye\"))\r"
+ x "\^[p\r"
+ x "\^[p\"%.7g@\"\r"
+ x "\^C\^P\r"
+ x "\^C\^P\"%.6g#\"\r"
+ x "\^C\^P\"%.6g.\"\r"
+ x "\^C\^P\"%.6g.\"\r"
+ x "\^[pidentity\r"
+ x "6\r\^B"
+ x "\^N\"UPCASE\r\^B"
+ x "\^[pdowncase\r"
+ x "(* 3 4\r\^B"
+ x "p(lambda\^Q (x)\^Q '(\"Hi\"))\r"
+ x "p(lambda\^Q (x)\^Q '(\"Bye\"))\r"
x))
;;Spanning cell printers
(fset 'ses-exercise-spanning-printers
- (concat y ":(revert-buffer t t)\r"
- x "p\"%.6g*\"\r"
+ (concat y "\^[:(revert-buffer t t)\r"
+ x "\^[p\"%.6g*\"\r"
x "pses-dashfill-span\r"
- x "5\r"
+ x "5\r\^B"
x "pses-tildefill-span\r"
- x "\"4\r"
- x "p\"$%s\"\r"
- x "p(\"$%s\")\r"
- x "8\r"
- x "p(\"!%s!\")\r"
- x "\t\"12345678\r"
+ x "\"4\r\^B"
+ x "\^[p\"$%s\"\r"
+ x "\^[p(\"$%s\")\r"
+ x "8\r\^B"
+ x "\^[p(\"!%s!\")\r"
+ x "\t\"12345678\r\^B"
x "pses-dashfill-span\r"
- x "\"23456789\r"
+ x "\"23456789\r\^B"
x "\t"
- x "(not t\r"
- x "w6\r"
- x "\"5\r"
- x "o"
- x "k"
- x "k"
+ x "(not t\r\^B"
+ x "\^Bw6\r"
+ x "\"5\r\^B"
+ x "\^N\^F\^[o"
+ x "\^[k"
+ x "\^[k"
x "\t"
- x ""
- x "o"
- x "2k"
- x "k"
+ x "\^B\^P\^C\^C"
+ x "\^[o"
+ x "\^N\^U2\^[k"
+ x "\^B\^B\^[k"
x))
;;Cut/copy/paste - within same buffer
(fset 'ses-exercise-paste-1buf
- (concat y ":(revert-buffer t t)\r"
- x "\0w"
- x ""
- x "o"
- x "\"middle\r"
- x "\0"
- x "w"
- x "\0"
- x "w"
- x ""
- x ""
- x "2y"
- x "y"
- x "y"
- x ">"
- x "y"
- x ">y"
- x "<"
+ (concat y "\^[:(revert-buffer t t)\r"
+ x "\^N\0\^F\^[w"
+ x "\^C\^C\^P\^F\^Y"
+ x "\^N\^[o"
+ x "\"middle\r\^B"
+ x "\0\^F\^N\^F"
+ x "\^[w"
+ x "\^P\0\^F"
+ x "\^[w"
+ x "\^C\^C\^F\^N"
+ x "\^Y"
+ x "\^U2\^Yy"
+ x "\^F\^U\^Yy"
+ x "\^P\^P\^F\^U\^Yy"
+ x "\^[>"
+ x "\^Yy"
+ x "\^[>\^Yy"
+ x "\^[<"
x "p\"<%s>\"\r"
- x "pses-dashfill\r"
- x "\0"
- x ""
- x ""
- x "y"
- x "\r\0w"
- x "\r"
- x "3(+ G2 H1\r"
- x "\0w"
- x ">"
- x ""
- x "8(ses-average (ses-range G2 H2)\r"
- x "\0k"
- x "7"
- x ""
- x "(ses-average (ses-range E7 E9)\r"
- x "\0 "
- x ""
- x "(ses-average (ses-range E7 F7)\r"
- x "\0k"
- x ""
- x "(ses-average (ses-range D6 E6)\r"
- x "\0k"
- x ""
- x "2"
- x "\"Line A\r"
+ x "\^Fpses-dashfill\r"
+ x "\^B\0\^F\^F\^F\^N\^N\^N"
+ x "\^W"
+ x "\^_"
+ x "\^U\^Yy"
+ x "\r\0\^B\^B\^B\^[w"
+ x "\r\^F\^Y"
+ x "\^U3\^P(+ G2 H1\r"
+ x "\0\^B\^[w"
+ x "\^C\^C\^[>\^B"
+ x "\^Y"
+ x "\^B\^U8\^P(ses-average (ses-range G2 H2)\r\^B"
+ x "\0\^F\^W\^[k"
+ x "\^U7\^N"
+ x "\^Y"
+ x "\^P\^B(ses-average (ses-range E7 E9)\r\^B"
+ x "\0\^F\^W\^K"
+ x "\^N\^Y"
+ x "\^B\^B\^P(ses-average (ses-range E7 F7)\r\^B"
+ x "\0\^F\^W\^[k"
+ x "\^F\^Y"
+ x "\^B\^B\^P(ses-average (ses-range D6 E6)\r\^B"
+ x "\0\^F\^W\^[k"
+ x "\^F\^Y"
+ x "\^A\^U2\^O"
+ x "\"Line A\r\^B"
x "pses-tildefill-span\r"
- x "\"Subline A(1)\r"
+ x "\^N\^F\"Subline A(1)\r\^B"
x "pses-dashfill-span\r"
- x "\0w"
- x ""
- x ""
- x "\0w"
- x ""
+ x "\^B\^P\0\^N\^N\^N\^[w\^C\^C"
+ x "\^A\^P\^P\^P\^P\^P\^P"
+ x "\^Y"
+ x "\0\^N\^F\^F\^[w\^C\^C"
+ x "\^F\^Y"
x))
;;Cut/copy/paste - between two buffers
(fset 'ses-exercise-paste-2buf
- (concat y ":(revert-buffer t t)\r"
- x "o\"middle\r\0"
- x ""
- x "4bses-test.txt\r"
- x " "
- x "\"xxx\0"
- x "wo"
- x ""
- x ""
- x "o\"\0"
- x "wo"
- x "o123.45\0"
- x "o"
- x "o1 \0"
- x "o"
- x ">y"
- x "o symb\0"
- x "oy2y"
- x "o1\t\0"
- x "o"
- x "w9\np\"<%s>\"\n"
- x "o\n2\t\"3\nxxx\t5\n\0"
- x "oy"
+ (concat y "\^[:(revert-buffer t t)\r"
+ x "\^F\^N\^[o\"middle\r\^B\0\^F\^N\^F"
+ x "\^W"
+ x "\^X4bses-test.txt\r"
+ x " \^A\^Y"
+ x "\^E\"xxx\0\^B\^B\^B\^B"
+ x "\^[w\^Xo"
+ x "\^_"
+ x "\^Y"
+ x "\^Xo\^E\"\0\^B\^B\^B\^B\^B"
+ x "\^[w\^Xo\^Y"
+ x "\^Xo123.45\0\^B\^B\^B\^B\^B\^B"
+ x "\^W\^Xo\^Y"
+ x "\^Xo1 \^B\^B\0\^F\^F\^F\^F\^F\^F\^F"
+ x "\^W\^Xo\^Y"
+ x "\^[>\^Yy"
+ x "\^F\^Xo symb\0\^B\^B\^B\^B"
+ x "\^W\^Xo\^U\^Y\^[y\^U2\^[y"
+ x "\^Xo1\t\0\^B\^B"
+ x "\^W\^Xo\^B\^Y"
+ x "w9\n\^[p\"<%s>\"\n"
+ x "\^Xo\n2\t\"3\nxxx\t5\n\0\^P\^P"
+ x "\^W\^Xo\^Yy"
x))
;;Export text, import it back
(fset 'ses-exercise-import-export
- (concat y ":(revert-buffer t t)\r"
- x "\0xt"
- x "4bses-test.txt\r"
- x "\n-1o"
- x "xTo-1o"
- x "'crunch\r"
- x "pses-center-span\r"
- x "\0xT"
- x "o\n-1o"
- x "\0y"
- x "\0xt"
- x "\0y"
- x "12345678\r"
- x "'bunch\r"
- x "\0xtxT"
+ (concat y "\^[:(revert-buffer t t)\r"
+ x "\^N\^N\^F\0\^Fxt"
+ x "\^X4bses-test.txt\r"
+ x "\n\^Y\^U-1\^Xo"
+ x "xT\^Xo\^Y\^U-1\^Xo"
+ x "\^C\^C\^F'crunch\r\^B"
+ x "\^P\^P\^Ppses-center-span\r"
+ x "\0\^N\^N\^N\^NxT"
+ x "\^Xo\n\^Y\^U-1\^Xo"
+ x "\0\^Yy"
+ x "\^F\0\^B\^P\^Pxt"
+ x "\^N\^N\0\^U\^Yy"
+ x "12345678\r\^B"
+ x "\^F\^F'bunch\r"
+ x "\0\^P\^PxtxT"
x)))
(defun ses-exercise-macros ()
@@ -565,10 +565,10 @@ spreadsheet files with invalid formatting."
(let ((curcell '(A1 . A2))) (ses-check-curcell 'end))
(let ((curcell '(A1 . A2))) (ses-sort-column "B"))
(let ((curcell '(C1 . D2))) (ses-sort-column "B"))
- (execute-kbd-macro "jB10\n2")
+ (execute-kbd-macro "jB10\n\^U2\^D")
(execute-kbd-macro [?j ?B ?9 ?\n ?\C-@ ?\C-f ?\C-f cut])
- (progn (kill-new "x") (execute-kbd-macro ">n"))
- (execute-kbd-macro "\0w")))
+ (progn (kill-new "x") (execute-kbd-macro "\^[>\^Yn"))
+ (execute-kbd-macro "\^B\0\^[w")))
(condition-case nil
(progn
(eval x)
@@ -589,7 +589,7 @@ spreadsheet files with invalid formatting."
(defun ses-exercise-invalid-spreadsheets ()
"Execute code paths that detect invalid spreadsheet files."
;;Detect invalid spreadsheets
- (let ((p&d "\n\n \n(ses-cell A1 nil nil nil nil)\n\n")
+ (let ((p&d "\n\n\^L\n(ses-cell A1 nil nil nil nil)\n\n")
(cw "(ses-column-widths [7])\n")
(cp "(ses-column-printers [ses-center])\n")
(dp "(ses-default-printer \"%.7g\")\n")
@@ -603,12 +603,12 @@ spreadsheet files with invalid formatting."
"(1 2 x)"
"(1 2 -1)"
"(3 1 1)"
- "\n\n (2 1 1)"
- "\n\n \n(ses-cell)(2 1 1)"
- "\n\n \n(x)\n(2 1 1)"
- "\n\n\n \n(ses-cell A2)\n(2 2 2)"
- "\n\n\n \n(ses-cell B1)\n(2 2 2)"
- "\n\n \n(ses-cell A1 nil nil nil nil)\n(2 1 1)"
+ "\n\n\^L(2 1 1)"
+ "\n\n\^L\n(ses-cell)(2 1 1)"
+ "\n\n\^L\n(x)\n(2 1 1)"
+ "\n\n\n\^L\n(ses-cell A2)\n(2 2 2)"
+ "\n\n\n\^L\n(ses-cell B1)\n(2 2 2)"
+ "\n\n\^L\n(ses-cell A1 nil nil nil nil)\n(2 1 1)"
(concat p&d "(x)\n(x)\n(x)\n(x)\n" p11)
(concat p&d "(ses-column-widths)(x)\n(x)\n(x)\n" p11)
(concat p&d cw "(x)\n(x)\n(x)\n(2 1 1)")
@@ -671,7 +671,7 @@ spreadsheet files with invalid formatting."
(ses-exercise-invalid-spreadsheets)
;;Upgrade of old-style spreadsheet
(with-temp-buffer
- (insert " \n\n \n(ses-cell A1 nil nil nil nil)\n\n(ses-column-widths [7])\n(ses-column-printers [nil])\n(ses-default-printer \"%.7g\")\n\n( ;Global parameters (these are read first)\n 1 ;SES file-format\n 1 ;numrows\n 1 ;numcols\n)\n\n")
+ (insert " \n\n\^L\n(ses-cell A1 nil nil nil nil)\n\n(ses-column-widths [7])\n(ses-column-printers [nil])\n(ses-default-printer \"%.7g\")\n\n( ;Global parameters (these are read first)\n 1 ;SES file-format\n 1 ;numrows\n 1 ;numcols\n)\n\n")
(ses-load))
;;ses-vector-delete is always called from buffer-undo-list with the same
;;symbol as argument. We'll give it a different one here.
diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el
index 3ede465fcc5..1ea12859c24 100644
--- a/lisp/emacs-lisp/testcover.el
+++ b/lisp/emacs-lisp/testcover.el
@@ -33,7 +33,9 @@
;; that has a splotch.
;; * Basic algorithm: use `edebug' to mark up the function text with
-;; instrumentation callbacks, then replace edebug's callbacks with ours.
+;; instrumentation callbacks, walk the instrumented code looking for
+;; forms which don't return or always return the same value, then use
+;; Edebug's before and after hooks to replace its code coverage with ours.
;; * To show good coverage, we want to see two values for every form, except
;; functions that always return the same value and `defconst' variables
;; need show only one value for good coverage. To avoid the brown
@@ -47,11 +49,10 @@
;; function being called is capable of returning in other cases.
;; Problems:
-;; * To detect different values, we store the form's result in a vector and
-;; compare the next result using `equal'. We don't copy the form's
-;; result, so if caller alters it (`setcar', etc.) we'll think the next
-;; call has the same value! Also, equal thinks two strings are the same
-;; if they differ only in properties.
+;; * `equal', which is used to compare the results of repeatedly executing
+;; a form, has a couple of shortcomings. It considers strings to be the same
+;; if they only differ in properties, and it raises an error when asked to
+;; compare circular lists.
;; * Because we have only a "1value" class and no "always nil" class, we have
;; to treat as potentially 1-valued any `and' whose last term is 1-valued,
;; in case the last term is always nil. Example:
@@ -62,6 +63,7 @@
;; error if these "potentially" 1-valued forms actually return differing
;; values.
+(eval-when-compile (require 'cl-lib))
(require 'edebug)
(provide 'testcover)
@@ -89,16 +91,14 @@ these. This list is quite incomplete!"
buffer-disable-undo buffer-enable-undo current-global-map
deactivate-mark delete-backward-char delete-char delete-region ding
forward-char function* insert insert-and-inherit kill-all-local-variables
- kill-line kill-paragraph kill-region kill-sexp lambda
+ kill-line kill-paragraph kill-region kill-sexp
minibuffer-complete-and-exit narrow-to-region next-line push-mark
put-text-property run-hooks set-match-data signal
substitute-key-definition suppress-keymap undo use-local-map while widen
yank)
- "Functions that always return the same value. No brown splotch is shown
-for these. This list is quite incomplete! Notes: Nobody ever changes the
-current global map. The macro `lambda' is self-evaluating, hence always
-returns the same value (the function it defines may return varying values
-when called)."
+ "Functions that always return the same value, according to `equal'.
+No brown splotch is shown for these. This list is quite
+incomplete! Notes: Nobody ever changes the current global map."
:group 'testcover
:type '(repeat symbol))
@@ -111,7 +111,7 @@ them as having returned nil just before calling them."
(defcustom testcover-compose-functions
'(+ - * / = append length list make-keymap make-sparse-keymap
- mapcar message propertize replace-regexp-in-string
+ message propertize replace-regexp-in-string
run-with-idle-timer set-buffer-modified-p)
"Functions that are 1-valued if all their args are either constants or
calls to one of the `testcover-1value-functions', so if that's true then no
@@ -186,19 +186,18 @@ call to one of the `testcover-1value-functions'."
;;;###autoload
(defun testcover-start (filename &optional byte-compile)
- "Uses edebug to instrument all macros and functions in FILENAME, then
-changes the instrumentation from edebug to testcover--much faster, no
-problems with type-ahead or post-command-hook, etc. If BYTE-COMPILE is
-non-nil, byte-compiles each function after instrumenting."
+ "Use Edebug to instrument for coverage all macros and functions in FILENAME.
+If BYTE-COMPILE is non-nil, byte compile each function after instrumenting."
(interactive "fStart covering file: ")
- (let ((buf (find-file filename))
- (load-read-function load-read-function))
- (add-function :around load-read-function
- #'testcover--read)
- (setq edebug-form-data nil
- testcover-module-constants nil
- testcover-module-1value-functions nil)
- (eval-buffer buf))
+ (let ((buf (find-file filename)))
+ (setq edebug-form-data nil
+ testcover-module-constants nil
+ testcover-module-1value-functions nil
+ testcover-module-potentially-1value-functions nil)
+ (let ((edebug-all-defs t)
+ (edebug-after-instrumentation-function #'testcover-after-instrumentation)
+ (edebug-new-definition-function #'testcover-init-definition))
+ (eval-buffer buf)))
(when byte-compile
(dolist (x (reverse edebug-form-data))
(when (fboundp (car x))
@@ -209,229 +208,10 @@ non-nil, byte-compiles each function after instrumenting."
(defun testcover-this-defun ()
"Start coverage on function under point."
(interactive)
- (let ((x (let ((edebug-all-defs t))
- (symbol-function (eval-defun nil)))))
- (testcover-reinstrument x)
- x))
-
-(defun testcover--read (orig &optional stream)
- "Read a form using edebug, changing edebug callbacks to testcover callbacks."
- (or stream (setq stream standard-input))
- (if (eq stream (current-buffer))
- (let ((x (let ((edebug-all-defs t))
- (edebug-read-and-maybe-wrap-form))))
- (testcover-reinstrument x)
- x)
- (funcall (or orig #'read) stream)))
-
-(defun testcover-reinstrument (form)
- "Reinstruments FORM to use testcover instead of edebug. This
-function modifies the list that FORM points to. Result is nil if
-FORM should return multiple values, t if should always return same
-value, `maybe' if either is acceptable."
- (let ((fun (car-safe form))
- id val)
- (cond
- ((not fun) ;Atom
- (when (or (not (symbolp form))
- (memq form testcover-constants)
- (memq form testcover-module-constants))
- t))
- ((consp fun) ;Embedded list
- (testcover-reinstrument fun)
- (testcover-reinstrument-list (cdr form))
- nil)
- ((or (memq fun testcover-1value-functions)
- (memq fun testcover-module-1value-functions))
- ;;Should always return same value
- (testcover-reinstrument-list (cdr form))
- t)
- ((or (memq fun testcover-potentially-1value-functions)
- (memq fun testcover-module-potentially-1value-functions))
- ;;Might always return same value
- (testcover-reinstrument-list (cdr form))
- 'maybe)
- ((memq fun testcover-progn-functions)
- ;;1-valued if last argument is
- (testcover-reinstrument-list (cdr form)))
- ((memq fun testcover-prog1-functions)
- ;;1-valued if first argument is
- (testcover-reinstrument-list (cddr form))
- (testcover-reinstrument (cadr form)))
- ((memq fun testcover-compose-functions)
- ;;1-valued if all arguments are. Potentially 1-valued if all
- ;;arguments are either definitely or potentially.
- (testcover-reinstrument-compose (cdr form) 'testcover-reinstrument))
- ((eq fun 'edebug-enter)
- ;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS))
- ;; => (testcover-enter 'SYM #'(lambda nil FORMS))
- (setcar form 'testcover-enter)
- (setcdr (nthcdr 1 form) (nthcdr 3 form))
- (let ((testcover-vector (get (cadr (cadr form)) 'edebug-coverage)))
- (testcover-reinstrument-list (nthcdr 2 (cadr (nth 2 form))))))
- ((eq fun 'edebug-after)
- ;;(edebug-after (edebug-before XXX) YYY FORM)
- ;; => (testcover-after YYY FORM), mark XXX as ok-coverage
- (unless (eq (cadr form) 0)
- (aset testcover-vector (cadr (cadr form)) 'ok-coverage))
- (setq id (nth 2 form))
- (setcdr form (nthcdr 2 form))
- (setq val (testcover-reinstrument (nth 2 form)))
- (setcar form (if (eq val t)
- 'testcover-1value
- 'testcover-after))
- (when val
- ;;1-valued or potentially 1-valued
- (aset testcover-vector id '1value))
- (cond
- ((memq (car-safe (nth 2 form)) testcover-noreturn-functions)
- ;;This function won't return, so set the value in advance
- ;;(edebug-after (edebug-before XXX) YYY FORM)
- ;; => (progn (edebug-after YYY nil) FORM)
- (setcar (cdr form) `(,(car form) ,id nil))
- (setcar form 'progn)
- (aset testcover-vector id '1value)
- (setq val t))
- ((eq (car-safe (nth 2 form)) '1value)
- ;;This function is always supposed to return the same value
- (setq val t)
- (aset testcover-vector id '1value)
- (setcar form 'testcover-1value)))
- val)
- ((eq fun 'defun)
- (setq val (testcover-reinstrument-list (nthcdr 3 form)))
- (when (eq val t)
- (push (cadr form) testcover-module-1value-functions))
- (when (eq val 'maybe)
- (push (cadr form) testcover-module-potentially-1value-functions)))
- ((memq fun '(defconst defcustom))
- ;;Define this symbol as 1-valued
- (push (cadr form) testcover-module-constants)
- (testcover-reinstrument-list (cddr form)))
- ((memq fun '(dotimes dolist))
- ;;Always returns third value from SPEC
- (testcover-reinstrument-list (cddr form))
- (setq val (testcover-reinstrument-list (cadr form)))
- (if (nth 2 (cadr form))
- val
- ;;No third value, always returns nil
- t))
- ((memq fun '(let let*))
- ;;Special parsing for second argument
- (mapc 'testcover-reinstrument-list (cadr form))
- (testcover-reinstrument-list (cddr form)))
- ((eq fun 'if)
- ;;Potentially 1-valued if both THEN and ELSE clauses are
- (testcover-reinstrument (cadr form))
- (let ((then (testcover-reinstrument (nth 2 form)))
- (else (testcover-reinstrument-list (nthcdr 3 form))))
- (and then else 'maybe)))
- ((eq fun 'cond)
- ;;Potentially 1-valued if all clauses are
- (when (testcover-reinstrument-compose (cdr form)
- 'testcover-reinstrument-list)
- 'maybe))
- ((eq fun 'condition-case)
- ;;Potentially 1-valued if BODYFORM is and all HANDLERS are
- (let ((body (testcover-reinstrument (nth 2 form)))
- (errs (testcover-reinstrument-compose
- (mapcar #'cdr (nthcdr 3 form))
- 'testcover-reinstrument-list)))
- (and body errs 'maybe)))
- ((eq fun 'quote)
- ;;Don't reinstrument what's inside!
- ;;This doesn't apply within a backquote
- t)
- ((eq fun '\`)
- ;;Quotes are not special within backquotes
- (let ((testcover-1value-functions
- (cons 'quote testcover-1value-functions)))
- (testcover-reinstrument (cadr form))))
- ((eq fun '\,)
- ;;In commas inside backquotes, quotes are special again
- (let ((testcover-1value-functions
- (remq 'quote testcover-1value-functions)))
- (testcover-reinstrument (cadr form))))
- ((eq fun '1value)
- ;;Hack - pretend the arg is 1-valued here
- (cond
- ((symbolp (cadr form))
- ;;A pseudoconstant variable
- t)
- ((and (eq (car (cadr form)) 'edebug-after)
- (symbolp (nth 3 (cadr form))))
- ;;Reference to pseudoconstant
- (aset testcover-vector (nth 2 (cadr form)) '1value)
- (setcar (cdr form) `(testcover-1value ,(nth 2 (cadr form))
- ,(nth 3 (cadr form))))
- t)
- (t
- (setq id (car (if (eq (car (cadr form)) 'edebug-after)
- (nth 3 (cadr form))
- (cadr form))))
- (let ((testcover-1value-functions
- (cons id testcover-1value-functions)))
- (testcover-reinstrument (cadr form))))))
- ((eq fun 'noreturn)
- ;;Hack - pretend the arg has no return
- (cond
- ((symbolp (cadr form))
- ;;A pseudoconstant variable
- 'maybe)
- ((and (eq (car (cadr form)) 'edebug-after)
- (symbolp (nth 3 (cadr form))))
- ;;Reference to pseudoconstant
- (aset testcover-vector (nth 2 (cadr form)) '1value)
- (setcar (cdr form) `(progn (testcover-after ,(nth 2 (cadr form)) nil)
- ,(nth 3 (cadr form))))
- 'maybe)
- (t
- (setq id (car (if (eq (car (cadr form)) 'edebug-after)
- (nth 3 (cadr form))
- (cadr form))))
- (let ((testcover-noreturn-functions
- (cons id testcover-noreturn-functions)))
- (testcover-reinstrument (cadr form))))))
- ((and (eq fun 'apply)
- (eq (car-safe (cadr form)) 'quote)
- (symbolp (cadr (cadr form))))
- ;;Apply of a constant symbol. Process as 1value or noreturn
- ;;depending on symbol.
- (setq fun (cons (cadr (cadr form)) (cddr form))
- val (testcover-reinstrument fun))
- (setcdr (cdr form) (cdr fun))
- val)
- (t ;Some other function or weird thing
- (testcover-reinstrument-list (cdr form))
- nil))))
-
-(defun testcover-reinstrument-list (list)
- "Reinstruments each form in LIST to use testcover instead of edebug.
-This function modifies the forms in LIST. Result is `testcover-reinstrument's
-value for the last form in LIST. If the LIST is empty, its evaluation will
-always be nil, so we return t for 1-valued."
- (let ((result t))
- (while (consp list)
- (setq result (testcover-reinstrument (pop list))))
- result))
-
-(defun testcover-reinstrument-compose (list fun)
- "For a compositional function, the result is 1-valued if all
-arguments are, potentially 1-valued if all arguments are either
-definitely or potentially 1-valued, and multi-valued otherwise.
-FUN should be `testcover-reinstrument' for compositional functions,
- `testcover-reinstrument-list' for clauses in a `cond'."
- (let ((result t))
- (mapc #'(lambda (x)
- (setq x (funcall fun x))
- (cond
- ((eq result t)
- (setq result x))
- ((eq result 'maybe)
- (when (not x)
- (setq result nil)))))
- list)
- result))
+ (let ((edebug-all-defs t)
+ (edebug-after-instrumentation-function #'testcover-after-instrumentation)
+ (edebug-new-definition-function #'testcover-init-definition))
+ (eval-defun nil)))
(defun testcover-end (filename)
"Turn off instrumentation of all macros and functions in FILENAME."
@@ -444,48 +224,108 @@ FUN should be `testcover-reinstrument' for compositional functions,
;;; Accumulate coverage data
;;;=========================================================================
-(defun testcover-enter (testcover-sym testcover-fun)
- "Internal function for coverage testing. Invokes TESTCOVER-FUN while
-binding `testcover-vector' to the code-coverage vector for TESTCOVER-SYM
-\(the name of the current function)."
- (let ((testcover-vector (get testcover-sym 'edebug-coverage)))
- (funcall testcover-fun)))
-
-(defun testcover-after (idx val)
- "Internal function for coverage testing. Returns VAL after installing it in
-`testcover-vector' at offset IDX."
- (declare (gv-expander (lambda (do)
- (gv-letplace (getter setter) val
- (funcall do getter
- (lambda (store)
- `(progn (testcover-after ,idx ,getter)
- ,(funcall setter store))))))))
- (cond
- ((eq (aref testcover-vector idx) 'unknown)
- (aset testcover-vector idx val))
- ((not (condition-case ()
- (equal (aref testcover-vector idx) val)
- ;; TODO: Actually check circular lists for equality.
- (circular-list nil)))
- (aset testcover-vector idx 'ok-coverage)))
- val)
-
-(defun testcover-1value (idx val)
- "Internal function for coverage testing. Returns VAL after installing it in
-`testcover-vector' at offset IDX. Error if FORM does not always return the
-same value during coverage testing."
- (cond
- ((eq (aref testcover-vector idx) '1value)
- (aset testcover-vector idx (cons '1value val)))
- ((not (and (eq (car-safe (aref testcover-vector idx)) '1value)
- (condition-case ()
- (equal (cdr (aref testcover-vector idx)) val)
- ;; TODO: Actually check circular lists for equality.
- (circular-list nil))))
- (error "Value of form marked with `1value' does vary: %s" val)))
- val)
-
-
+(defun testcover-after-instrumentation (form)
+ "Analyze FORM for code coverage."
+ (testcover-analyze-coverage form)
+ form)
+
+(defun testcover-init-definition (sym)
+ "Mark SYM as under test coverage."
+ (message "Testcover: %s" sym)
+ (put sym 'edebug-behavior 'testcover))
+
+(defun testcover-enter (func _args body)
+ "Begin execution of a function under coverage testing.
+Bind `testcover-vector' to the code-coverage vector for FUNC and
+return the result of evaluating BODY."
+ (let ((testcover-vector (get func 'edebug-coverage)))
+ (funcall body)))
+
+(defun testcover-before (before-index)
+ "Update code coverage before a form is evaluated.
+BEFORE-INDEX is the form's index into the code-coverage vector."
+ (let ((before-entry (aref testcover-vector before-index)))
+ (when (eq (car-safe before-entry) 'noreturn)
+ (let* ((after-index (cdr before-entry)))
+ (aset testcover-vector after-index 'ok-coverage)))))
+
+(defun testcover-after (_before-index after-index value)
+ "Update code coverage with the result of a form's evaluation.
+AFTER-INDEX is the form's index into the code-coverage
+vector. Return VALUE."
+ (let ((old-result (aref testcover-vector after-index)))
+ (cond
+ ((eq 'unknown old-result)
+ (aset testcover-vector after-index (testcover--copy-object value)))
+ ((eq 'maybe old-result)
+ (aset testcover-vector after-index 'ok-coverage))
+ ((eq '1value old-result)
+ (aset testcover-vector after-index
+ (cons old-result (testcover--copy-object value))))
+ ((and (eq (car-safe old-result) '1value)
+ (not (condition-case ()
+ (equal (cdr old-result) value)
+ (circular-list t))))
+ (error "Value of form expected to be constant does vary, from %s to %s"
+ old-result value))
+ ;; Test if a different result.
+ ((not (condition-case ()
+ (equal value old-result)
+ (circular-list nil)))
+ (aset testcover-vector after-index 'ok-coverage))))
+ value)
+
+;; Add these behaviors to Edebug.
+(unless (assoc 'testcover edebug-behavior-alist)
+ (push '(testcover testcover-enter testcover-before testcover-after)
+ edebug-behavior-alist))
+
+(defun testcover--copy-object (obj)
+ "Make a copy of OBJ.
+If OBJ is a cons cell, copy both its car and its cdr.
+Contrast to `copy-tree' which does the same but fails on circular
+structures, and `copy-sequence', which copies only along the
+cdrs. Copy vectors as well as conses."
+ (let ((ht (make-hash-table :test 'eq)))
+ (testcover--copy-object1 obj t ht)))
+
+(defun testcover--copy-object1 (obj vecp hash-table)
+ "Make a copy of OBJ, using a HASH-TABLE of objects already copied.
+If OBJ is a cons cell, this recursively copies its car and
+iteratively copies its cdr. When VECP is non-nil, copy
+vectors as well as conses."
+ (if (and (atom obj) (or (not vecp) (not (vectorp obj))))
+ obj
+ (let ((copy (gethash obj hash-table nil)))
+ (unless copy
+ (cond
+ ((consp obj)
+ (let* ((rest obj) current)
+ (setq copy (cons nil nil)
+ current copy)
+ (while
+ (progn
+ (puthash rest current hash-table)
+ (setf (car current)
+ (testcover--copy-object1 (car rest) vecp hash-table))
+ (setq rest (cdr rest))
+ (cond
+ ((atom rest)
+ (setf (cdr current)
+ (testcover--copy-object1 rest vecp hash-table))
+ nil)
+ ((gethash rest hash-table nil)
+ (setf (cdr current) (gethash rest hash-table nil))
+ nil)
+ (t (setq current
+ (setf (cdr current) (cons nil nil)))))))))
+ (t ; (and vecp (vectorp obj)) is true due to test in if above.
+ (setq copy (copy-sequence obj))
+ (puthash obj copy hash-table)
+ (dotimes (i (length copy))
+ (aset copy i
+ (testcover--copy-object1 (aref copy i) vecp hash-table))))))
+ copy)))
;;;=========================================================================
;;; Display the coverage data as color splotches on your code.
@@ -517,12 +357,13 @@ eliminated by adding more test cases."
(while (> len 0)
(setq len (1- len)
data (aref coverage len))
- (when (and (not (eq data 'ok-coverage))
- (not (eq (car-safe data) '1value))
- (setq j (+ def-mark (aref points len))))
+ (when (and (not (eq data 'ok-coverage))
+ (not (memq (car-safe data)
+ '(1value maybe noreturn)))
+ (setq j (+ def-mark (aref points len))))
(setq ov (make-overlay (1- j) j))
(overlay-put ov 'face
- (if (memq data '(unknown 1value))
+ (if (memq data '(unknown maybe 1value))
'testcover-nohits
'testcover-1value))))
(set-buffer-modified-p changed))))
@@ -553,4 +394,286 @@ coverage tests. This function creates many overlays."
(goto-char (next-overlay-change (point)))
(end-of-line))
+
+;;; Coverage Analysis
+
+;; The top level function for initializing code coverage is
+;; `testcover-analyze-coverage', which recursively walks the form it is
+;; passed, which should have already been instrumented by
+;; edebug-read-and-maybe-wrap-form, and initializes the associated
+;; code coverage vectors, which should have already been created by
+;; `edebug-clear-coverage'.
+;;
+;; The purpose of the analysis is to identify forms which can only
+;; ever return a single value. These forms can be considered to have
+;; adequate code coverage even if only executed once. In addition,
+;; forms which will never return, such as error signals, can be
+;; identified and treated correctly.
+;;
+;; The code coverage vector entries for the beginnings of forms will
+;; be changed to `ok-coverage.', except for the beginnings of forms
+;; which should never return, which will be changed to
+;; (noreturn . AFTER-INDEX) so that testcover-before can set the entry
+;; for the end of the form just before it is executed.
+;;
+;; Entries for the ends of forms may be changed to `1value' if
+;; analysis determines the form will only ever return a single value,
+;; or `maybe' if the form could potentially only ever return a single
+;; value.
+;;
+;; An example of a potentially 1-valued form is an `and' whose last
+;; term is 1-valued, in case the last term is always nil. Example:
+;;
+;; (and (< (point) 1000) (forward-char 10))
+;;
+;; This form always returns nil. Similarly, `or', `if', and `cond'
+;; are treated as potentially 1-valued if all clauses are, in case
+;; those values are always nil. Unlike truly 1-valued functions, it
+;; is not an error if these "potentially" 1-valued forms actually
+;; return differing values.
+
+(defun testcover-analyze-coverage (form)
+ "Analyze FORM and initialize coverage vectors for definitions found within.
+Return 1value, maybe or nil depending on if the form is determined
+to return only a single value, potentially return only a single value,
+or return multiple values."
+ (pcase form
+ (`(edebug-enter ',sym ,_ (function (lambda nil . ,body)))
+ (let ((testcover-vector (get sym 'edebug-coverage)))
+ (testcover-analyze-coverage-progn body)))
+
+ (`(edebug-after ,(and before-form
+ (or `(edebug-before ,before-id) before-id))
+ ,after-id ,wrapped-form)
+ (testcover-analyze-coverage-edebug-after
+ form before-form before-id after-id wrapped-form))
+
+ (`(defconst ,sym . ,args)
+ (push sym testcover-module-constants)
+ (testcover-analyze-coverage-progn args)
+ '1value)
+
+ (`(defun ,name ,_ . ,doc-and-body)
+ (let ((val (testcover-analyze-coverage-progn doc-and-body)))
+ (cl-case val
+ ((1value) (push name testcover-module-1value-functions))
+ ((maybe) (push name testcover-module-potentially-1value-functions)))
+ nil))
+
+ (`(quote . ,_)
+ ;; A quoted form is 1value. Edebug could have instrumented
+ ;; something inside the form if an Edebug spec contained a quote.
+ ;; It's also possible that the quoted form is a circular object.
+ ;; To avoid infinite recursion, don't examine quoted objects.
+ ;; This will cause the coverage marks on an instrumented quoted
+ ;; form to look odd. See bug#25316.
+ '1value)
+
+ (`(\` ,bq-form)
+ (testcover-analyze-coverage-backquote-form bq-form))
+
+ ((or 't 'nil (pred keywordp))
+ '1value)
+
+ ((pred vectorp)
+ (testcover-analyze-coverage-compose (append form nil)
+ #'testcover-analyze-coverage))
+
+ ((pred symbolp)
+ nil)
+
+ ((pred atom)
+ '1value)
+
+ (_
+ ;; Whatever we have here, it's not wrapped, so treat it as a list of forms.
+ (testcover-analyze-coverage-compose form #'testcover-analyze-coverage))))
+
+(defun testcover-analyze-coverage-progn (forms)
+ "Analyze FORMS, which should be a list of forms, for code coverage.
+Analyze all the forms in FORMS and return 1value, maybe or nil
+depending on the analysis of the last one. Find the coverage
+vectors referenced by `edebug-enter' forms nested within FORMS and
+update them with the results of the analysis."
+ (let ((result '1value))
+ (while (consp forms)
+ (setq result (testcover-analyze-coverage (pop forms))))
+ result))
+
+(defun testcover-analyze-coverage-edebug-after (_form before-form before-id
+ after-id wrapped-form
+ &optional wrapper)
+ "Analyze a _FORM wrapped by `edebug-after' for code coverage.
+_FORM should be either:
+ (edebug-after (edebug-before BEFORE-ID) AFTER-ID WRAPPED-FORM)
+or:
+ (edebug-after 0 AFTER-ID WRAPPED-FORM)
+
+where BEFORE-FORM is bound to either (edebug-before BEFORE-ID) or
+0. WRAPPER may be 1value or noreturn, and if so it forces the
+form to be treated accordingly."
+ (let (val)
+ (unless (eql before-form 0)
+ (aset testcover-vector before-id 'ok-coverage))
+
+ (setq val (testcover-analyze-coverage-wrapped-form wrapped-form))
+ (when (or (eq wrapper '1value) val)
+ ;; The form is 1-valued or potentially 1-valued.
+ (aset testcover-vector after-id (or val '1value)))
+
+ (cond
+ ((or (eq wrapper 'noreturn)
+ (memq (car-safe wrapped-form) testcover-noreturn-functions))
+ ;; This function won't return, so indicate to testcover-before that
+ ;; it should record coverage.
+ (aset testcover-vector before-id (cons 'noreturn after-id))
+ (aset testcover-vector after-id '1value)
+ (setq val '1value))
+
+ ((eq (car-safe wrapped-form) '1value)
+ ;; This function is always supposed to return the same value.
+ (setq val '1value)
+ (aset testcover-vector after-id '1value)))
+ val))
+
+(defun testcover-analyze-coverage-wrapped-form (form)
+ "Analyze a FORM for code coverage which was wrapped by `edebug-after'.
+FORM is treated as if it will be evaluated."
+ (pcase form
+ ((pred keywordp)
+ '1value)
+ ((pred symbolp)
+ (when (or (memq form testcover-constants)
+ (memq form testcover-module-constants))
+ '1value))
+ ((pred atom)
+ '1value)
+ (`(\` ,bq-form)
+ (testcover-analyze-coverage-backquote-form bq-form))
+ (`(defconst ,sym ,val . ,_)
+ (push sym testcover-module-constants)
+ (testcover-analyze-coverage val)
+ '1value)
+ (`(,(or 'dotimes 'dolist) (,_ ,expr . ,result) . ,body)
+ ;; These always return RESULT if provided.
+ (testcover-analyze-coverage expr)
+ (testcover-analyze-coverage-progn body)
+ (let ((val (testcover-analyze-coverage-progn result)))
+ ;; If the third value is not present, the loop always returns nil.
+ (if result val '1value)))
+ (`(,(or 'let 'let*) ,bindings . ,body)
+ (testcover-analyze-coverage-progn bindings)
+ (testcover-analyze-coverage-progn body))
+ (`(if ,test ,then-form . ,else-body)
+ ;; `if' is potentially 1-valued if both THEN and ELSE clauses are.
+ (testcover-analyze-coverage test)
+ (let ((then (testcover-analyze-coverage then-form))
+ (else (testcover-analyze-coverage else-body)))
+ (and then else 'maybe)))
+ (`(cond . ,clauses)
+ ;; `cond' is potentially 1-valued if all clauses are.
+ (when (testcover-analyze-coverage-compose clauses #'testcover-analyze-coverage-progn)
+ 'maybe))
+ (`(condition-case ,_ ,body-form . ,handlers)
+ ;; `condition-case' is potentially 1-valued if BODY-FORM is and all
+ ;; HANDLERS are.
+ (let ((body (testcover-analyze-coverage body-form))
+ (errs (testcover-analyze-coverage-compose
+ (mapcar #'cdr handlers)
+ #'testcover-analyze-coverage-progn)))
+ (and body errs 'maybe)))
+ (`(apply (quote ,(and func (pred symbolp))) . ,args)
+ ;; Process application of a constant symbol as 1value or noreturn
+ ;; depending on the symbol.
+ (let ((temp-form (cons func args)))
+ (testcover-analyze-coverage-wrapped-form temp-form)))
+ (`(,(and func (or '1value 'noreturn)) ,inner-form)
+ ;; 1value and noreturn change how the edebug-after they wrap is handled.
+ (let ((val (if (eq func '1value) '1value 'maybe)))
+ (pcase inner-form
+ (`(edebug-after ,(and before-form
+ (or `(edebug-before ,before-id) before-id))
+ ,after-id ,wrapped-form)
+ (testcover-analyze-coverage-edebug-after inner-form before-form
+ before-id after-id
+ wrapped-form func))
+ (_ (testcover-analyze-coverage inner-form)))
+ val))
+ (`(,func . ,args)
+ (testcover-analyze-coverage-wrapped-application func args))))
+
+(defun testcover-analyze-coverage-wrapped-application (func args)
+ "Analyze the application of FUNC to ARGS for code coverage."
+ (cond
+ ((eq func 'quote) '1value)
+ ((or (memq func testcover-1value-functions)
+ (memq func testcover-module-1value-functions))
+ ;; The function should always return the same value.
+ (testcover-analyze-coverage-progn args)
+ '1value)
+ ((or (memq func testcover-potentially-1value-functions)
+ (memq func testcover-module-potentially-1value-functions))
+ ;; The function might always return the same value.
+ (testcover-analyze-coverage-progn args)
+ 'maybe)
+ ((memq func testcover-progn-functions)
+ ;; The function is 1-valued if the last argument is.
+ (testcover-analyze-coverage-progn args))
+ ((memq func testcover-prog1-functions)
+ ;; The function is 1-valued if first argument is.
+ (testcover-analyze-coverage-progn (cdr args))
+ (testcover-analyze-coverage (car args)))
+ ((memq func testcover-compose-functions)
+ ;; The function is 1-valued if all arguments are, and potentially
+ ;; 1-valued if all arguments are either definitely or potentially.
+ (testcover-analyze-coverage-compose args #'testcover-analyze-coverage))
+ (t (testcover-analyze-coverage-progn args)
+ nil)))
+
+(defun testcover-coverage-combine (result val)
+ "Combine RESULT with VAL and return the new result.
+If either argument is nil, return nil, otherwise if either
+argument is maybe, return maybe. Return 1value only if both arguments
+are 1value."
+ (cl-case val
+ (1value result)
+ (maybe (and result 'maybe))
+ (nil nil)))
+
+(defun testcover-analyze-coverage-compose (forms func)
+ "Analyze a list of FORMS for code coverage using FUNC.
+The list is 1valued if all of its constituent elements are also 1valued."
+ (let ((result '1value))
+ (while (consp forms)
+ (setq result (testcover-coverage-combine result (funcall func (car forms))))
+ (setq forms (cdr forms)))
+ (when forms
+ (setq result (testcover-coverage-combine result (funcall func forms))))
+ result))
+
+(defun testcover-analyze-coverage-backquote (bq-list)
+ "Analyze BQ-LIST, the body of a backquoted list, for code coverage."
+ (let ((result '1value))
+ (while (consp bq-list)
+ (let ((form (car bq-list))
+ val)
+ (if (memq form (list '\, '\,@))
+ ;; Correctly handle `(foo bar . ,(baz).
+ (progn
+ (setq val (testcover-analyze-coverage (cdr bq-list)))
+ (setq bq-list nil))
+ (setq val (testcover-analyze-coverage-backquote-form form))
+ (setq bq-list (cdr bq-list)))
+ (setq result (testcover-coverage-combine result val))))
+ result))
+
+(defun testcover-analyze-coverage-backquote-form (form)
+ "Analyze a single FORM from a backquoted list for code coverage."
+ (cond
+ ((vectorp form) (testcover-analyze-coverage-backquote (append form nil)))
+ ((atom form) '1value)
+ ((memq (car form) (list '\, '\,@))
+ (testcover-analyze-coverage (cadr form)))
+ (t (testcover-analyze-coverage-backquote form))))
+
;; testcover.el ends here.
diff --git a/lisp/emacs-lisp/text-property-search.el b/lisp/emacs-lisp/text-property-search.el
new file mode 100644
index 00000000000..41ca07057e0
--- /dev/null
+++ b/lisp/emacs-lisp/text-property-search.el
@@ -0,0 +1,206 @@
+;;; text-property-search.el --- search for text properties -*- lexical-binding:t -*-
+
+;; Copyright (C) 2018-2019 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: convenience
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-when-compile (require 'cl-lib))
+
+(cl-defstruct (prop-match)
+ beginning end value)
+
+(defun text-property-search-forward (property &optional value predicate
+ not-immediate)
+ "Search for the next region that has text property PROPERTY set to VALUE.
+If not found, the return value is nil. If found, point will be
+placed at the end of the region and an object describing the
+match is returned.
+
+PREDICATE is called with two values. The first is the VALUE
+parameter. The second is the value of PROPERTY. This predicate
+should return non-nil if there is a match.
+
+Some convenience values for PREDICATE can also be used. `t'
+means the same as `equal'. `nil' means almost the same as \"not
+equal\", but will also end the match if the value of PROPERTY
+changes. See the manual for extensive examples.
+
+If `not-immediate', if the match is under point, it will not be
+returned, but instead the next instance is returned, if any.
+
+The return value (if a match is made) is a `prop-match'
+structure. The accessors available are
+`prop-match-beginning'/`prop-match-end' (the region in the buffer
+that's matching), and `prop-match-value' (the value of PROPERTY
+at the start of the region)."
+ (interactive
+ (list
+ (let ((string (completing-read "Search for property: " obarray)))
+ (when (> (length string) 0)
+ (intern string obarray)))))
+ (cond
+ ;; No matches at the end of the buffer.
+ ((eobp)
+ nil)
+ ;; We're standing in the property we're looking for, so find the
+ ;; end.
+ ((and (text-property--match-p value (get-text-property (point) property)
+ predicate)
+ (not not-immediate))
+ (text-property--find-end-forward (point) property value predicate))
+ (t
+ (let ((origin (point))
+ (ended nil)
+ pos)
+ ;; Fix the next candidate.
+ (while (not ended)
+ (setq pos (next-single-property-change (point) property))
+ (if (not pos)
+ (progn
+ (goto-char origin)
+ (setq ended t))
+ (goto-char pos)
+ (if (text-property--match-p value (get-text-property (point) property)
+ predicate)
+ (setq ended
+ (text-property--find-end-forward
+ (point) property value predicate))
+ ;; Skip past this section of non-matches.
+ (setq pos (next-single-property-change (point) property))
+ (unless pos
+ (goto-char origin)
+ (setq ended t)))))
+ (and (not (eq ended t))
+ ended)))))
+
+(defun text-property--find-end-forward (start property value predicate)
+ (let (end)
+ (if (and value
+ (null predicate))
+ ;; This is the normal case: We're looking for areas where the
+ ;; values aren't, so we aren't interested in sub-areas where the
+ ;; property has different values, all non-matching value.
+ (let ((ended nil))
+ (while (not ended)
+ (setq end (next-single-property-change (point) property))
+ (if (not end)
+ (progn
+ (goto-char (point-max))
+ (setq end (point)
+ ended t))
+ (goto-char end)
+ (unless (text-property--match-p
+ value (get-text-property (point) property) predicate)
+ (setq ended t)))))
+ ;; End this at the first place the property changes value.
+ (setq end (next-single-property-change (point) property nil (point-max)))
+ (goto-char end))
+ (make-prop-match :beginning start
+ :end end
+ :value (get-text-property start property))))
+
+
+(defun text-property-search-backward (property &optional value predicate
+ not-immediate)
+ "Search for the previous region that has text property PROPERTY set to VALUE.
+See `text-property-search-forward' for further documentation."
+ (interactive
+ (list
+ (let ((string (completing-read "Search for property: " obarray)))
+ (when (> (length string) 0)
+ (intern string obarray)))))
+ (cond
+ ;; We're at the start of the buffer; no previous matches.
+ ((bobp)
+ nil)
+ ;; We're standing in the property we're looking for, so find the
+ ;; end.
+ ((and (text-property--match-p
+ value (get-text-property (1- (point)) property)
+ predicate)
+ (not not-immediate))
+ (text-property--find-end-backward (1- (point)) property value predicate))
+ (t
+ (let ((origin (point))
+ (ended nil)
+ pos)
+ (forward-char -1)
+ ;; Fix the next candidate.
+ (while (not ended)
+ (setq pos (previous-single-property-change (point) property))
+ (if (not pos)
+ (progn
+ (goto-char origin)
+ (setq ended t))
+ (goto-char (1- pos))
+ (if (text-property--match-p value (get-text-property (point) property)
+ predicate)
+ (setq ended
+ (text-property--find-end-backward
+ (point) property value predicate))
+ ;; Skip past this section of non-matches.
+ (setq pos (previous-single-property-change (point) property))
+ (unless pos
+ (goto-char origin)
+ (setq ended t)))))
+ (and (not (eq ended t))
+ ended)))))
+
+(defun text-property--find-end-backward (start property value predicate)
+ (let (end)
+ (if (and value
+ (null predicate))
+ ;; This is the normal case: We're looking for areas where the
+ ;; values aren't, so we aren't interested in sub-areas where the
+ ;; property has different values, all non-matching value.
+ (let ((ended nil))
+ (while (not ended)
+ (setq end (previous-single-property-change (point) property))
+ (if (not end)
+ (progn
+ (goto-char (point-min))
+ (setq end (point)
+ ended t))
+ (goto-char (1- end))
+ (unless (text-property--match-p
+ value (get-text-property (point) property) predicate)
+ (goto-char end)
+ (setq ended t)))))
+ ;; End this at the first place the property changes value.
+ (setq end (previous-single-property-change
+ (point) property nil (point-min)))
+ (goto-char end))
+ (make-prop-match :beginning end
+ :end (1+ start)
+ :value (get-text-property end property))))
+
+(defun text-property--match-p (value prop-value predicate)
+ (cond
+ ((eq predicate t)
+ (setq predicate #'equal))
+ ((eq predicate nil)
+ (setq predicate (lambda (val p-val)
+ (not (equal val p-val))))))
+ (funcall predicate value prop-value))
+
+(provide 'text-property-search)
diff --git a/lisp/emacs-lisp/thunk.el b/lisp/emacs-lisp/thunk.el
index 7a3b17999ca..e1370c45911 100644
--- a/lisp/emacs-lisp/thunk.el
+++ b/lisp/emacs-lisp/thunk.el
@@ -29,9 +29,9 @@
;; Thunk provides functions and macros to delay the evaluation of
;; forms.
;;
-;; Use `thunk-delay' to delay the evaluation of a form, and
-;; `thunk-force' to evaluate it. The result of the evaluation is
-;; cached, and only happens once.
+;; Use `thunk-delay' to delay the evaluation of a form (requires
+;; lexical-binding), and `thunk-force' to evaluate it. The result of
+;; the evaluation is cached, and only happens once.
;;
;; Here is an example of a form which evaluation is delayed:
;;
@@ -41,12 +41,19 @@
;; following:
;;
;; (thunk-force delayed)
+;;
+;; This file also defines macros `thunk-let' and `thunk-let*' that are
+;; analogous to `let' and `let*' but provide lazy evaluation of
+;; bindings by using thunks implicitly (i.e. in the expansion).
;;; Code:
+(require 'cl-lib)
+
(defmacro thunk-delay (&rest body)
"Delay the evaluation of BODY."
(declare (debug t))
+ (cl-assert lexical-binding)
(let ((forced (make-symbol "forced"))
(val (make-symbol "val")))
`(let (,forced ,val)
@@ -68,5 +75,60 @@ with the same DELAYED argument."
"Return non-nil if DELAYED has been evaluated."
(funcall delayed t))
+(defmacro thunk-let (bindings &rest body)
+ "Like `let' but create lazy bindings.
+
+BINDINGS is a list of elements of the form (SYMBOL EXPRESSION).
+Any binding EXPRESSION is not evaluated before the variable
+SYMBOL is used for the first time when evaluating the BODY.
+
+It is not allowed to set `thunk-let' or `thunk-let*' bound
+variables.
+
+Using `thunk-let' and `thunk-let*' requires `lexical-binding'."
+ (declare (indent 1) (debug let))
+ (cl-callf2 mapcar
+ (lambda (binding)
+ (pcase binding
+ (`(,(pred symbolp) ,_) binding)
+ (_ (signal 'error (cons "Bad binding in thunk-let"
+ (list binding))))))
+ bindings)
+ (cl-callf2 mapcar
+ (pcase-lambda (`(,var ,binding))
+ (list (make-symbol (concat (symbol-name var) "-thunk"))
+ var binding))
+ bindings)
+ `(let ,(mapcar
+ (pcase-lambda (`(,thunk-var ,_var ,binding))
+ `(,thunk-var (thunk-delay ,binding)))
+ bindings)
+ (cl-symbol-macrolet
+ ,(mapcar (pcase-lambda (`(,thunk-var ,var ,_binding))
+ `(,var (thunk-force ,thunk-var)))
+ bindings)
+ ,@body)))
+
+(defmacro thunk-let* (bindings &rest body)
+ "Like `let*' but create lazy bindings.
+
+BINDINGS is a list of elements of the form (SYMBOL EXPRESSION).
+Any binding EXPRESSION is not evaluated before the variable
+SYMBOL is used for the first time when evaluating the BODY.
+
+It is not allowed to set `thunk-let' or `thunk-let*' bound
+variables.
+
+Using `thunk-let' and `thunk-let*' requires `lexical-binding'."
+ (declare (indent 1) (debug let))
+ (cl-reduce
+ (lambda (expr binding) `(thunk-let (,binding) ,expr))
+ (nreverse bindings)
+ :initial-value (macroexp-progn body)))
+
+;; (defalias 'lazy-let #'thunk-let)
+;; (defalias 'lazy-let* #'thunk-let*)
+
+
(provide 'thunk)
;;; thunk.el ends here
diff --git a/lisp/emacs-lisp/timer-list.el b/lisp/emacs-lisp/timer-list.el
index c9b2fae7d91..81e2f91c0e5 100644
--- a/lisp/emacs-lisp/timer-list.el
+++ b/lisp/emacs-lisp/timer-list.el
@@ -37,16 +37,14 @@
;; Idle.
(if (aref timer 7) "*" " ")
;; Next time.
- (let ((time (float-time (list (aref timer 1)
- (aref timer 2)
- (aref timer 3)))))
+ (let ((time (list (aref timer 1)
+ (aref timer 2)
+ (aref timer 3))))
(format "%.2f"
- (if (aref timer 7)
- time
- (- (float-time (list (aref timer 1)
- (aref timer 2)
- (aref timer 3)))
- (float-time)))))
+ (float-time
+ (if (aref timer 7)
+ time
+ (time-subtract time nil)))))
;; Repeat.
(let ((repeat (aref timer 4)))
(cond
diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el
index 29abc35916e..f706d9bc626 100644
--- a/lisp/emacs-lisp/timer.el
+++ b/lisp/emacs-lisp/timer.el
@@ -57,17 +57,11 @@
(defun timer--time-setter (timer time)
(timer--check timer)
- (setf (timer--high-seconds timer) (pop time))
- (let ((low time) (usecs 0) (psecs 0))
- (when (consp time)
- (setq low (pop time))
- (when time
- (setq usecs (pop time))
- (when time
- (setq psecs (car time)))))
- (setf (timer--low-seconds timer) low)
- (setf (timer--usecs timer) usecs)
- (setf (timer--psecs timer) psecs)
+ (let ((lt (encode-time time 'list)))
+ (setf (timer--high-seconds timer) (nth 0 lt))
+ (setf (timer--low-seconds timer) (nth 1 lt))
+ (setf (timer--usecs timer) (nth 2 lt))
+ (setf (timer--psecs timer) (nth 3 lt))
time))
;; Pseudo field `time'.
@@ -80,7 +74,7 @@
(defun timer-set-time (timer time &optional delta)
"Set the trigger time of TIMER to TIME.
-TIME must be in the internal format returned by, e.g., `current-time'.
+TIME must be a Lisp time value.
If optional third argument DELTA is a positive number, make the timer
fire repeatedly that many seconds apart."
(setf (timer--time timer) time)
@@ -94,7 +88,7 @@ SECS may be an integer, floating point number, or the internal
time format returned by, e.g., `current-idle-time'.
If optional third argument REPEAT is non-nil, make the timer
fire each time Emacs is idle for that many seconds."
- (setf (timer--time timer) (if (consp secs) secs (seconds-to-time secs)))
+ (setf (timer--time timer) secs)
(setf (timer--repeat-delay timer) repeat)
timer)
@@ -102,24 +96,20 @@ fire each time Emacs is idle for that many seconds."
"Yield the next value after TIME that is an integral multiple of SECS.
More precisely, the next value, after TIME, that is an integral multiple
of SECS seconds since the epoch. SECS may be a fraction."
- (let* ((trillion 1e12)
- (time-sec (+ (nth 1 time)
- (* 65536.0 (nth 0 time))))
- (delta-sec (mod (- time-sec) secs))
- (next-sec (+ time-sec (ffloor delta-sec)))
- (next-sec-psec (ffloor (* trillion (mod delta-sec 1))))
- (sub-time-psec (+ (or (nth 3 time) 0)
- (* 1e6 (nth 2 time))))
- (psec-diff (- sub-time-psec next-sec-psec)))
- (if (and (<= next-sec time-sec) (< 0 psec-diff))
- (setq next-sec-psec (+ sub-time-psec
- (mod (- psec-diff) (* trillion secs)))))
- (setq next-sec (+ next-sec (floor next-sec-psec trillion)))
- (setq next-sec-psec (mod next-sec-psec trillion))
- (list (floor next-sec 65536)
- (floor (mod next-sec 65536))
- (floor next-sec-psec 1000000)
- (floor (mod next-sec-psec 1000000)))))
+ (let* ((ticks-hz (if (and (consp time) (integerp (car time))
+ (integerp (cdr time)) (< 0 (cdr time)))
+ time
+ (encode-time time 1000000000000)))
+ (ticks (car ticks-hz))
+ (hz (cdr ticks-hz))
+ trunc-s-ticks)
+ (while (let ((s-ticks (* secs hz)))
+ (setq trunc-s-ticks (truncate s-ticks))
+ (/= s-ticks trunc-s-ticks))
+ (setq ticks (ash ticks 1))
+ (setq hz (ash hz 1)))
+ (let ((more-ticks (+ ticks trunc-s-ticks)))
+ (encode-time (cons (- more-ticks (% more-ticks trunc-s-ticks)) hz)))))
(defun timer-relative-time (time secs &optional usecs psecs)
"Advance TIME by SECS seconds and optionally USECS microseconds
@@ -141,20 +131,6 @@ omitted, they are treated as zero."
(setf (timer--time timer)
(timer-relative-time (timer--time timer) secs usecs psecs)))
-(defun timer-set-time-with-usecs (timer time usecs &optional delta)
- "Set the trigger time of TIMER to TIME plus USECS.
-TIME must be in the internal format returned by, e.g., `current-time'.
-The microsecond count from TIME is ignored, and USECS is used instead.
-If optional fourth argument DELTA is a positive number, make the timer
-fire repeatedly that many seconds apart."
- (declare (obsolete "use `timer-set-time' and `timer-inc-time' instead."
- "22.1"))
- (setf (timer--time timer) time)
- (setf (timer--usecs timer) usecs)
- (setf (timer--psecs timer) 0)
- (setf (timer--repeat-delay timer) (and (numberp delta) (> delta 0) delta))
- timer)
-
(defun timer-set-function (timer function &optional args)
"Make TIMER call FUNCTION with optional ARGS when triggering."
(timer--check timer)
@@ -273,8 +249,8 @@ how many will really happen."
(defun timer-until (timer time)
"Calculate number of seconds from when TIMER will run, until TIME.
TIMER is a timer, and stands for the time when its next repeat is scheduled.
-TIME is a time-list."
- (- (float-time time) (float-time (timer--time timer))))
+TIME is a Lisp time value."
+ (float-time (time-subtract time (timer--time timer))))
(defun timer-event-handler (timer)
"Call the handler for the timer TIMER.
@@ -305,7 +281,7 @@ This function is called, by name, directly by the C code."
;; perhaps because Emacs was suspended for a long time,
;; limit how many times things get repeated.
(if (and (numberp timer-max-repeats)
- (< 0 (timer-until timer nil)))
+ (time-less-p nil (timer--time timer)))
(let ((repeats (/ (timer-until timer nil)
(timer--repeat-delay timer))))
(if (> repeats timer-max-repeats)
diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el
index 36d1fe3cfd2..d20b751d88a 100644
--- a/lisp/emacs-lisp/unsafep.el
+++ b/lisp/emacs-lisp/unsafep.el
@@ -93,7 +93,7 @@ in the parse.")
(put 'unsafep-vars 'risky-local-variable t)
;;Side-effect-free functions from subr.el
-(dolist (x '(assoc-default assoc-ignore-case butlast last match-string
+(dolist (x '(assoc-default butlast last match-string
match-string-no-properties member-ignore-case remove remq))
(put x 'side-effect-free t))
diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el
index 8e5ae6be365..13ca605dd00 100644
--- a/lisp/emacs-lisp/warnings.el
+++ b/lisp/emacs-lisp/warnings.el
@@ -68,6 +68,7 @@ Each element looks like (ALIAS . LEVEL) and defines ALIAS as
equivalent to LEVEL. LEVEL must be defined in `warning-levels';
it may not itself be an alias.")
+(defvaralias 'display-warning-minimum-level 'warning-minimum-level)
(defcustom warning-minimum-level :warning
"Minimum severity level for displaying the warning buffer.
If a warning's severity level is lower than this,
@@ -77,8 +78,8 @@ is not immediately displayed. See also `warning-minimum-log-level'."
:type '(choice (const :emergency) (const :error)
(const :warning) (const :debug))
:version "22.1")
-(defvaralias 'display-warning-minimum-level 'warning-minimum-level)
+(defvaralias 'log-warning-minimum-level 'warning-minimum-log-level)
(defcustom warning-minimum-log-level :warning
"Minimum severity level for logging a warning.
If a warning severity level is lower than this,
@@ -89,7 +90,6 @@ because warnings not logged aren't displayed either."
:type '(choice (const :emergency) (const :error)
(const :warning) (const :debug))
:version "22.1")
-(defvaralias 'log-warning-minimum-level 'warning-minimum-log-level)
(defcustom warning-suppress-log-types nil
"List of warning types that should not be logged.
@@ -241,11 +241,15 @@ See also `warning-series', `warning-prefix-function' and
(old (get-buffer buffer-name))
(buffer (or old (get-buffer-create buffer-name)))
(level-info (assq level warning-levels))
+ ;; `newline' may be unbound during bootstrap.
+ (newline (if (fboundp 'newline) #'newline
+ (lambda () (insert "\n"))))
start end)
(with-current-buffer buffer
;; If we created the buffer, disable undo.
(unless old
- (special-mode)
+ (when (fboundp 'special-mode) ; Undefined during bootstrap.
+ (special-mode))
(setq buffer-read-only t)
(setq buffer-undo-list t))
(goto-char (point-max))
@@ -256,7 +260,7 @@ See also `warning-series', `warning-prefix-function' and
(funcall warning-series)))))
(let ((inhibit-read-only t))
(unless (bolp)
- (newline))
+ (funcall newline))
(setq start (point))
(if warning-prefix-function
(setq level-info (funcall warning-prefix-function
@@ -264,7 +268,7 @@ See also `warning-series', `warning-prefix-function' and
(insert (format (nth 1 level-info)
(format warning-type-format typename))
message)
- (newline)
+ (funcall newline)
(when (and warning-fill-prefix (not (string-match "\n" message)))
(let ((fill-prefix warning-fill-prefix)
(fill-column 78))
diff --git a/lisp/emacs-lock.el b/lisp/emacs-lock.el
index 47ab615d976..0cded29193a 100644
--- a/lisp/emacs-lock.el
+++ b/lisp/emacs-lock.el
@@ -88,6 +88,9 @@ The functions get one argument, the first locked buffer found."
:group 'emacs-lock
:version "24.3")
+(define-obsolete-variable-alias 'emacs-lock-from-exiting
+ 'emacs-lock-mode "24.1")
+
(defvar-local emacs-lock-mode nil
"If non-nil, the current buffer is locked.
It can be one of the following values:
@@ -185,16 +188,11 @@ Return a value appropriate for `kill-buffer-query-functions' (which see)."
;; anything else (turn off)
mode))))
-(define-obsolete-variable-alias 'emacs-lock-from-exiting
- 'emacs-lock-mode "24.1")
-
;;;###autoload
(define-minor-mode emacs-lock-mode
"Toggle Emacs Lock mode in the current buffer.
If called with a plain prefix argument, ask for the locking mode
-to be used. With any other prefix ARG, turn mode on if ARG is
-positive, off otherwise. If called from Lisp, enable the mode if
-ARG is omitted or nil.
+to be used.
Initially, if the user does not pass an explicit locking mode, it
defaults to `emacs-lock-default-locking-mode' (which see);
diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el
index e0efd46ea27..105e1ab43d8 100644
--- a/lisp/emulation/cua-base.el
+++ b/lisp/emulation/cua-base.el
@@ -39,7 +39,7 @@
;; C-v -> paste
;;
;; The tricky part is the handling of the C-x and C-c keys which
-;; are normally used as prefix keys for most of emacs' built-in
+;; are normally used as prefix keys for most of Emacs' built-in
;; commands. With CUA they still do!!!
;;
;; Only when the region is currently active (and highlighted since
@@ -69,7 +69,7 @@
;; [C-space] to start the region and use unshifted movement keys to extend
;; it. To cancel the region, use [C-space] or [C-g].
-;; If you prefer to use the standard emacs cut, copy, paste, and undo
+;; If you prefer to use the standard Emacs cut, copy, paste, and undo
;; bindings, customize cua-enable-cua-keys to nil.
@@ -138,7 +138,7 @@
;; cua-mode's superior rectangle support uses a true visual
;; representation of the selected rectangle, i.e. it highlights the
;; actual part of the buffer that is currently selected as part of the
-;; rectangle. Unlike emacs' traditional rectangle commands, the
+;; rectangle. Unlike Emacs' traditional rectangle commands, the
;; selected rectangle always as straight left and right edges, even
;; when those are in the middle of a TAB character or beyond the end
;; of the current line. And it does this without actually modifying
@@ -427,7 +427,7 @@ and after the region marked by the rectangle to search."
(defcustom cua-rectangle-modifier-key 'meta
"Modifier key used for rectangle commands bindings.
-On non-window systems, always use the meta modifier.
+On non-window systems, use `cua-rectangle-terminal-modifier-key'.
Must be set prior to enabling CUA."
:type '(choice (const :tag "Meta key" meta)
(const :tag "Alt key" alt)
@@ -435,6 +435,16 @@ Must be set prior to enabling CUA."
(const :tag "Super key" super))
:group 'cua)
+(defcustom cua-rectangle-terminal-modifier-key 'meta
+ "Modifier key used for rectangle commands bindings in terminals.
+Must be set prior to enabling CUA."
+ :type '(choice (const :tag "Meta key" meta)
+ (const :tag "Alt key" alt)
+ (const :tag "Hyper key" hyper)
+ (const :tag "Super key" super))
+ :group 'cua
+ :version "27.1")
+
(defcustom cua-enable-rectangle-auto-help t
"If non-nil, automatically show help for region, rectangle and global mark."
:type 'boolean
@@ -710,7 +720,8 @@ a cons (TYPE . COLOR), then both properties are affected."
;; C-x binding after the first C-x C-x was rewritten to just C-x).
(prefix-command-preserve-state)
;; Push the key back on the event queue
- (setq unread-command-events (cons key unread-command-events))))
+ (setq unread-command-events (cons (cons 'no-record key)
+ unread-command-events))))
(defun cua--prefix-override-handler ()
"Start timer waiting for prefix key to be followed by another key.
@@ -852,8 +863,6 @@ With numeric prefix arg, copy to register 0-9 instead."
(if (fboundp 'cua--cancel-rectangle)
(cua--cancel-rectangle)))
-(declare-function x-clipboard-yank "../term/x-win" ())
-
(put 'cua-paste 'delete-selection 'yank)
(defun cua-paste (arg)
"Paste last cut or copied region or rectangle.
@@ -884,10 +893,8 @@ If global mark is active, copy from register or one character."
((consp regtxt) (cua--insert-rectangle regtxt))
((stringp regtxt) (insert-for-yank regtxt))
(t (message "Unknown data in register %c" cua--register))))
- ((eq this-original-command 'clipboard-yank)
- (clipboard-yank))
- ((eq this-original-command 'x-clipboard-yank)
- (x-clipboard-yank))
+ ((memq this-original-command '(clipboard-yank x-clipboard-yank))
+ (funcall this-original-command))
(t (yank arg)))))))
@@ -1051,7 +1058,6 @@ If ARG is the atom `-', scroll downward by nearly full screen."
(scroll-up arg)
(end-of-buffer (goto-char (point-max)))))))
-(put 'cua-scroll-up 'CUA 'move)
(put 'cua-scroll-up 'isearch-scroll t)
(defun cua-scroll-down (&optional arg)
@@ -1072,7 +1078,6 @@ If ARG is the atom `-', scroll upward by nearly full screen."
(scroll-down arg)
(beginning-of-buffer (goto-char (point-min)))))))
-(put 'cua-scroll-down 'CUA 'move)
(put 'cua-scroll-down 'isearch-scroll t)
;;; Cursor indications
@@ -1242,10 +1247,9 @@ If ARG is the atom `-', scroll upward by nearly full screen."
(defun cua--init-keymaps ()
;; Cache actual rectangle modifier key.
(setq cua--rectangle-modifier-key
- (if (and cua-rectangle-modifier-key
- (memq window-system '(x)))
- cua-rectangle-modifier-key
- 'meta))
+ (if (eq (framep (selected-frame)) t)
+ cua-rectangle-terminal-modifier-key
+ cua-rectangle-modifier-key))
;; C-return always toggles rectangle mark
(define-key cua-global-keymap cua-rectangle-mark-key 'cua-set-rectangle-mark)
(unless (eq cua--rectangle-modifier-key 'meta)
@@ -1322,9 +1326,6 @@ If ARG is the atom `-', scroll upward by nearly full screen."
;;;###autoload
(define-minor-mode cua-mode
"Toggle Common User Access style editing (CUA mode).
-With a prefix argument ARG, enable CUA mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
CUA mode is a global minor mode. When enabled, typed text
replaces the active selection, and you can use C-z, C-x, C-c, and
diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el
index 39db89bc29f..f52ce72a6d8 100644
--- a/lisp/emulation/viper-cmd.el
+++ b/lisp/emulation/viper-cmd.el
@@ -45,8 +45,6 @@
(defvar undo-beg-posn)
(defvar undo-end-posn)
-(eval-and-compile
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest _))))
;; end pacifier
@@ -131,9 +129,6 @@
;; define viper-vi-command-p
(viper-test-com-defun viper-vi-command)
-;; Where viper saves mark. This mark is resurrected by m^
-(defvar viper-saved-mark nil)
-
;; Contains user settings for vars affected by viper-set-expert-level function.
;; Not a user option.
(defvar viper-saved-user-settings nil)
@@ -753,7 +748,7 @@ Vi's prefix argument will be used. Otherwise, the prefix argument passed to
(unwind-protect
(progn
(setq com
- (key-binding (setq key (viper-read-key-sequence nil))))
+ (key-binding (setq key (read-key-sequence nil))))
;; In case of binding indirection--chase definitions.
;; Have to do it here because we execute this command under
;; different keymaps, so command-execute may not do the
@@ -1129,7 +1124,7 @@ as a Meta key and any number of multiple escapes are allowed."
;; it is an error.
(progn
;; new com is (CHAR . OLDCOM)
- (if (viper-memq-char char '(?# ?\")) (error "Viper bell"))
+ (if (viper-memq-char char '(?# ?\")) (user-error viper-ViperBell))
(setq com (cons char com))
(setq cont nil))
;; If com is nil we set com as char, and read more. Again, if char is
@@ -1148,7 +1143,7 @@ as a Meta key and any number of multiple escapes are allowed."
(let ((reg (read-char)))
(if (viper-valid-register reg)
(setq viper-use-register reg)
- (error "Viper bell"))
+ (user-error viper-ViperBell))
(setq char (read-char))))
(t
(setq com char)
@@ -1170,7 +1165,7 @@ as a Meta key and any number of multiple escapes are allowed."
(viper-regsuffix-command-p char)
(viper= char ?!) ; bang command
(viper= char ?g) ; the gg command (like G0)
- (error "Viper bell"))
+ (user-error viper-ViperBell))
(setq cmd-to-exec-at-end
(viper-exec-form-in-vi
`(key-binding (char-to-string ,char)))))
@@ -1204,7 +1199,7 @@ as a Meta key and any number of multiple escapes are allowed."
((equal com '(?= . ?=)) (viper-line (cons value ?=)))
;; gg acts as G0
((equal (car com) ?g) (viper-goto-line 0))
- (t (error "Viper bell")))))
+ (t (user-error viper-ViperBell)))))
(if cmd-to-exec-at-end
(progn
@@ -2454,7 +2449,7 @@ These keys are ESC, RET, and LineFeed."
(if (eq this-command 'viper-intercept-ESC-key)
(setq com 'viper-exit-insert-state)
(viper-set-unread-command-events last-input-event)
- (setq com (key-binding (viper-read-key-sequence nil))))
+ (setq com (key-binding (read-key-sequence nil))))
(condition-case conds
(command-execute com)
@@ -2614,9 +2609,9 @@ On reaching end of line, stop and signal error."
;; the forward motion before the 'viper-execute-com', but, of
;; course, 'dl' doesn't work on an empty line, so we have to
;; catch that condition before 'viper-execute-com'
- (if (and (eolp) (bolp)) (error "Viper bell") (forward-char val))
+ (if (and (eolp) (bolp)) (user-error viper-ViperBell) (forward-char val))
(if com (viper-execute-com 'viper-forward-char val com))
- (if (eolp) (progn (backward-char 1) (error "Viper bell"))))
+ (if (eolp) (progn (backward-char 1) (user-error viper-ViperBell))))
(forward-char val)
(if com (viper-execute-com 'viper-forward-char val com)))))
@@ -2631,7 +2626,7 @@ On reaching beginning of line, stop and signal error."
(if com (viper-move-marker-locally 'viper-com-point (point)))
(if viper-ex-style-motion
(progn
- (if (bolp) (error "Viper bell") (backward-char val))
+ (if (bolp) (user-error viper-ViperBell) (backward-char val))
(if com (viper-execute-com 'viper-backward-char val com)))
(backward-char val)
(if com (viper-execute-com 'viper-backward-char val com)))))
@@ -2958,7 +2953,7 @@ On reaching beginning of line, stop and signal error."
(if com (viper-execute-com 'viper-goto-col val com))
(save-excursion
(end-of-line)
- (if (> val (current-column)) (error "Viper bell")))
+ (if (> val (current-column)) (user-error viper-ViperBell)))
))
@@ -3089,7 +3084,7 @@ If point is on a widget or a button, simulate clicking on that widget/button."
;; If FORWARD then search is forward, otherwise backward. OFFSET is used to
;; adjust point after search.
(defun viper-find-char (arg char forward offset)
- (or (char-or-string-p char) (error "Viper bell"))
+ (or (char-or-string-p char) (user-error viper-ViperBell))
(let ((arg (if forward arg (- arg)))
(cmd (if (eq viper-intermediate-command 'viper-repeat)
(nth 5 viper-d-com)
@@ -3429,7 +3424,7 @@ controlled by the sign of prefix numeric value."
(if com (viper-move-marker-locally 'viper-com-point (point)))
(backward-sexp 1)
(if com (viper-execute-com 'viper-paren-match nil com)))
- (t (error "Viper bell"))))))
+ (t (user-error viper-ViperBell))))))
(defun viper-toggle-parse-sexp-ignore-comments ()
(interactive)
@@ -4006,7 +4001,7 @@ Null string will repeat previous search."
(let ((reg viper-use-register))
(setq viper-use-register nil)
(error viper-EmptyRegister reg))
- (error "Viper bell")))
+ (user-error viper-ViperBell)))
(setq viper-use-register nil)
(if (viper-end-with-a-newline-p text)
(progn
@@ -4056,7 +4051,7 @@ Null string will repeat previous search."
(let ((reg viper-use-register))
(setq viper-use-register nil)
(error viper-EmptyRegister reg))
- (error "Viper bell")))
+ (user-error viper-ViperBell)))
(setq viper-use-register nil)
(if (viper-end-with-a-newline-p text) (beginning-of-line))
(viper-set-destructive-command
@@ -4101,7 +4096,7 @@ Null string will repeat previous search."
(> val (viper-chars-in-region (point) (viper-line-pos 'end))))
(setq val (viper-chars-in-region (point) (viper-line-pos 'end))))
(if (and viper-ex-style-motion (eolp))
- (if (bolp) (error "Viper bell") (setq val 0))) ; not bol---simply back 1 ch
+ (if (bolp) (user-error viper-ViperBell) (setq val 0))) ; not bol---simply back 1 ch
(save-excursion
(viper-forward-char-carefully val)
(setq end-del-pos (point)))
@@ -4371,7 +4366,7 @@ and regexp replace."
((viper= char ?,) (viper-cycle-through-mark-ring))
((viper= char ?^) (push-mark viper-saved-mark t t))
((viper= char ?D) (mark-defun))
- (t (error "Viper bell"))
+ (t (user-error viper-ViperBell))
)))
;; Algorithm: If first invocation of this command save mark on ring, goto
@@ -4470,7 +4465,7 @@ One can use \\=`\\=` and \\='\\=' to temporarily jump 1 step back."
(switch-to-buffer buff)
(goto-char viper-com-point)
(viper-change-state-to-vi)
- (error "Viper bell")))))
+ (user-error viper-ViperBell)))))
((and (not skip-white) (viper= char ?`))
(if com (viper-move-marker-locally 'viper-com-point (point)))
(if (and (viper-same-line (point) viper-last-jump)
diff --git a/lisp/emulation/viper-ex.el b/lisp/emulation/viper-ex.el
index 02a912eeb59..45b91cd9c0e 100644
--- a/lisp/emulation/viper-ex.el
+++ b/lisp/emulation/viper-ex.el
@@ -427,18 +427,18 @@ reversed."
(forward-char 1)
(setq ex-token-type 'whole))
((= char ?+)
- (cond ((or (looking-at "+[-+]") (looking-at "+[\n|]"))
+ (cond ((looking-at "\\+[-+\n|]")
(forward-char 1)
(insert "1")
(backward-char 1)
(setq ex-token-type 'plus))
- ((looking-at "+[0-9]")
+ ((looking-at "\\+[0-9]")
(forward-char 1)
(setq ex-token-type 'plus))
(t
(error viper-BadAddress))))
((= char ?-)
- (cond ((or (looking-at "-[-+]") (looking-at "-[\n|]"))
+ (cond ((looking-at "-[-+\n|]")
(forward-char 1)
(insert "1")
(backward-char 1)
@@ -455,7 +455,7 @@ reversed."
(while (and (not (eolp)) cont)
;;(re-search-forward "[^/]*/")
(re-search-forward "[^/]*\\(/\\|\n\\)")
- (if (not (looking-back "[^\\\\]\\(\\\\\\\\\\)*\\\\/"
+ (if (not (looking-back "[^\\]\\(\\\\\\\\\\)*\\\\/"
(line-beginning-position 0)))
(setq cont nil))))
(backward-char 1)
@@ -469,7 +469,7 @@ reversed."
(while (and (not (eolp)) cont)
;;(re-search-forward "[^\\?]*\\?")
(re-search-forward "[^\\?]*\\(\\?\\|\n\\)")
- (if (not (looking-back "[^\\\\]\\(\\\\\\\\\\)*\\\\\\?"
+ (if (not (looking-back "[^\\]\\(\\\\\\\\\\)*\\\\\\?"
(line-beginning-position 0)))
(setq cont nil))
(backward-char 1)
@@ -548,9 +548,13 @@ reversed."
(setq viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name))
(set-buffer viper-ex-work-buf)
(goto-char (point-max)))
- (cond ((looking-back quit-regex1) (exit-minibuffer))
- ((looking-back stay-regex) (insert " "))
- ((looking-back quit-regex2) (exit-minibuffer))
+ (cond ((looking-back quit-regex1 (line-beginning-position))
+ (exit-minibuffer))
+ ;; Almost certainly point-min should be line-beginning-position,
+ ;; but probably the two are identical anyway, and who really cares?
+ ((looking-back stay-regex (point-min)) (insert " "))
+ ((looking-back quit-regex2 (line-beginning-position))
+ (exit-minibuffer))
(t (insert " ")))))
(declare-function viper-tmp-insert-at-eob "viper-cmd" (msg))
@@ -561,7 +565,7 @@ reversed."
(let (save-pos dist compl-list string-to-complete completion-result)
(save-excursion
- (setq dist (skip-chars-backward "[a-zA-Z!=>&~]")
+ (setq dist (skip-chars-backward "a-zA-Z!=>&~")
save-pos (point)))
(if (or (= dist 0)
@@ -740,7 +744,7 @@ reversed."
(error
"Global regexp must be inside matching non-alphanumeric chars"))
((= c ??) (error "`?' is not an allowed pattern delimiter here")))
- (if (looking-at "[^\\\\\n]")
+ (if (looking-at "[^\\\n]")
(progn
(forward-char 1)
(set-mark (point))
@@ -753,7 +757,7 @@ reversed."
(error "Missing closing delimiter for global regexp")
(goto-char (point-max))))
(if (not (looking-back
- (format "[^\\\\]\\(\\\\\\\\\\)*\\\\%c" c)
+ (format "[^\\]\\(\\\\\\\\\\)*\\\\%c" c)
(line-beginning-position 0)))
(setq cont nil)
;; we are at an escaped delimiter: unescape it and continue
@@ -1236,7 +1240,7 @@ reversed."
(read-string "[Hit return to confirm] ")
(quit
(save-excursion (kill-buffer " *delete text*"))
- (error "Viper bell")))
+ (user-error viper-ViperBell)))
(save-excursion (kill-buffer " *delete text*")))
(if ex-buffer
(cond ((viper-valid-register ex-buffer '(Letter))
@@ -1682,7 +1686,7 @@ reversed."
(message ":set <Variable> [= <Value>]")
(or batch (sit-for 2))
- (while (string-match "^[ \\t\\n]*$"
+ (while (string-match "^[ \t\n]*$"
(setq str
(completing-read ":set " ex-variable-alist)))
(message ":set <Variable> [= <Value>]")
diff --git a/lisp/emulation/viper-init.el b/lisp/emulation/viper-init.el
index 0ad9a7a373c..5a80804e757 100644
--- a/lisp/emulation/viper-init.el
+++ b/lisp/emulation/viper-init.el
@@ -268,6 +268,7 @@ that deletes a file.")
(defconst viper-BadAddress "Ill-formed address" "")
(defconst viper-FirstAddrExceedsSecond "First address exceeds second" "")
(defconst viper-NoFileSpecified "No file specified" "")
+(defconst viper-ViperBell "Viper bell" "")
;; Is t until viper-mode executes for the very first time.
;; Prevents recursive descend into startup messages.
diff --git a/lisp/emulation/viper-keym.el b/lisp/emulation/viper-keym.el
index c0b7a5b5c9c..8bb75d65afa 100644
--- a/lisp/emulation/viper-keym.el
+++ b/lisp/emulation/viper-keym.el
@@ -1,4 +1,4 @@
-;;; viper-keym.el --- Viper keymaps
+;;; viper-keym.el --- Viper keymaps -*- lexical-binding:t -*-
;; Copyright (C) 1994-1997, 2000-2019 Free Software Foundation, Inc.
@@ -32,8 +32,6 @@
(defvar viper-ex-style-editing)
(defvar viper-ex-style-motion)
-(eval-and-compile
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
;; end pacifier
(require 'viper-util)
@@ -84,10 +82,6 @@ major mode in effect."
(defvar viper-insert-intercept-map (make-sparse-keymap))
(defvar viper-emacs-intercept-map (make-sparse-keymap))
-;; keymap used to zap all keymaps other than function-key-map,
-;; device-function-key-map, etc.
-(defvar viper-overriding-map (make-sparse-keymap))
-
(viper-deflocalvar viper-vi-local-user-map (make-sparse-keymap)
"Keymap for user-defined local bindings.
Useful for changing bindings such as ZZ in certain major modes.
diff --git a/lisp/emulation/viper-macs.el b/lisp/emulation/viper-macs.el
index 90d33d5fa7b..37ab81d78ef 100644
--- a/lisp/emulation/viper-macs.el
+++ b/lisp/emulation/viper-macs.el
@@ -1,4 +1,4 @@
-;;; viper-macs.el --- functions implementing keyboard macros for Viper
+;;; viper-macs.el --- functions implementing keyboard macros for Viper -*- lexical-binding:t -*-
;; Copyright (C) 1994-1997, 2000-2019 Free Software Foundation, Inc.
@@ -174,7 +174,7 @@ a key is a symbol, e.g., `a', `\\1', `f2', etc., or a list, e.g.,
(prin1-to-string (viper-display-macro key-seq))
"")))
(message "%s" message)
- (setq event (viper-read-key))
+ (setq event (read-key))
;;(setq event (viper-read-event))
(setq key
(if (viper-mouse-event-p event)
@@ -251,7 +251,7 @@ a key is a symbol, e.g., `a', `\\1', `f2', etc., or a list, e.g.,
(viper-display-macro key-seq))
"")))
(message "%s" message)
- (setq event (viper-read-key))
+ (setq event (read-key))
;;(setq event (viper-read-event))
(setq key
(if (viper-mouse-event-p event)
@@ -867,15 +867,18 @@ mistakes in macro names to be passed to this function is to use
;; A fast keysequence is one that is terminated by a pause longer than
;; viper-fast-keyseq-timeout.
(defun viper-read-fast-keysequence (event macro-alist)
+ ;; FIXME: Do we still need this? Now that the discrimination between the ESC
+ ;; key and the ESC byte sent as part of terminal escape sequences is performed
+ ;; in the input-decode-map, I suspect that we don't need this hack any more.
(let ((lis (vector event))
next-event)
(while (and (viper-fast-keysequence-p)
(viper-keyseq-is-a-possible-macro lis macro-alist))
;; Seems that viper-read-event is more robust here. We need to be able to
;; place these events on unread-command-events list. If we use
- ;; viper-read-key then events will be converted to keys, and sometimes
+ ;; read-key then events will be converted to keys, and sometimes
;; (e.g., (control \[)) those keys differ from the corresponding events.
- ;; So, do not use (setq next-event (viper-read-key))
+ ;; So, do not use (setq next-event (read-key))
(setq next-event (viper-read-event))
(or (viper-mouse-event-p next-event)
(setq lis (vconcat lis (vector next-event)))))
diff --git a/lisp/emulation/viper-util.el b/lisp/emulation/viper-util.el
index 04edc90c88a..a7e7af3bf85 100644
--- a/lisp/emulation/viper-util.el
+++ b/lisp/emulation/viper-util.el
@@ -1,4 +1,4 @@
-;;; viper-util.el --- Utilities used by viper.el
+;;; viper-util.el --- Utilities used by viper.el -*- lexical-binding:t -*-
;; Copyright (C) 1994-1997, 1999-2019 Free Software Foundation, Inc.
@@ -28,7 +28,6 @@
;; Compiler pacifier
-(defvar viper-overriding-map)
(defvar viper-minibuffer-current-face)
(defvar viper-minibuffer-insert-face)
(defvar viper-minibuffer-vi-face)
@@ -39,13 +38,9 @@
(defvar ex-unix-type-shell-options)
(defvar viper-ex-tmp-buf-name)
(defvar viper-syntax-preference)
-(defvar viper-saved-mark)
(require 'ring)
-(eval-and-compile
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
-
;; end pacifier
(require 'viper-init)
@@ -635,15 +630,15 @@ Otherwise return the normal value."
;;; Saving settings in custom file
-;; Save the current setting of VAR in CUSTOM-FILE.
+;; Save the current setting of VAR in FILE.
;; If given, MESSAGE is a message to be displayed after that.
;; This message is erased after 2 secs, if erase-msg is non-nil.
-;; Arguments: var message custom-file &optional erase-message
-(defun viper-save-setting (var message custom-file &optional erase-msg)
+;; Arguments: var message file &optional erase-message
+(defun viper-save-setting (var message file &optional erase-msg)
(let* ((var-name (symbol-name var))
(var-val (if (boundp var) (eval var)))
(regexp (format "^[^;]*%s[ \t\n]*[a-zA-Z---_']*[ \t\n)]" var-name))
- (buf (find-file-noselect (substitute-in-file-name custom-file)))
+ (buf (find-file-noselect (substitute-in-file-name file)))
)
(message "%s" (or message ""))
(with-current-buffer buf
@@ -665,12 +660,12 @@ Otherwise return the normal value."
(message "")))
))
-;; Save STRING in CUSTOM-FILE. If PATTERN is non-nil, remove strings that
+;; Save STRING in FILE. If PATTERN is non-nil, remove strings that
;; match this pattern.
-(defun viper-save-string-in-file (string custom-file &optional pattern)
- (let ((buf (find-file-noselect (substitute-in-file-name custom-file))))
+(defun viper-save-string-in-file (string file &optional pattern)
+ (let ((buf (find-file-noselect (substitute-in-file-name file))))
(with-current-buffer buf
- (let (buffer-read-only)
+ (let ((inhibit-read-only t))
(goto-char (point-min))
(if pattern (delete-matching-lines pattern))
(goto-char (point-max))
@@ -886,6 +881,9 @@ Otherwise return the normal value."
(if (featurep 'xemacs) (mark-marker t)
(mark-marker)))
+(defvar viper-saved-mark nil
+ "Where viper saves mark. This mark is resurrected by m^.")
+
;; like (set-mark-command nil) but doesn't push twice, if (car mark-ring)
;; is the same as (mark t).
(defsubst viper-set-mark-if-necessary ()
@@ -945,48 +943,6 @@ Otherwise return the normal value."
event))
(read-event))))
-;; Viperized read-key-sequence
-(defun viper-read-key-sequence (prompt &optional continue-echo)
- (let (inhibit-quit event keyseq)
- (setq keyseq (read-key-sequence prompt continue-echo))
- (setq event (if (featurep 'xemacs)
- (elt keyseq 0) ; XEmacs returns vector of events
- (elt (listify-key-sequence keyseq) 0)))
- (if (viper-ESC-event-p event)
- (let (unread-command-events)
- (if (viper-fast-keysequence-p)
- (let ((viper-vi-global-user-minor-mode nil)
- (viper-vi-local-user-minor-mode nil)
- (viper-vi-intercept-minor-mode nil)
- (viper-insert-intercept-minor-mode nil)
- (viper-replace-minor-mode nil) ; actually unnecessary
- (viper-insert-global-user-minor-mode nil)
- (viper-insert-local-user-minor-mode nil))
- ;; Note: set unread-command-events only after testing for fast
- ;; keysequence. Otherwise, viper-fast-keysequence-p will be
- ;; always t -- whether there is anything after ESC or not
- (viper-set-unread-command-events keyseq)
- (setq keyseq (read-key-sequence nil)))
- (viper-set-unread-command-events keyseq)
- (setq keyseq (read-key-sequence nil)))))
- keyseq))
-
-
-;; This function lets function-key-map convert key sequences into logical
-;; keys. This does a better job than viper-read-event when it comes to kbd
-;; macros, since it enables certain macros to be shared between X and TTY modes
-;; by correctly mapping key sequences for Left/Right/... (on an ascii
-;; terminal) into logical keys left, right, etc.
-(defun viper-read-key () ;; FIXME: Use `read-key'?
- (let ((overriding-local-map viper-overriding-map)
- (inhibit-quit t)
- help-char key)
- (use-global-map viper-overriding-map)
- (unwind-protect
- (setq key (elt (viper-read-key-sequence nil) 0))
- (use-global-map global-map))
- key))
-
;; Emacs has a bug in eventp, which causes (eventp nil) to return (nil)
;; instead of nil, if '(nil) was previously inadvertently assigned to
diff --git a/lisp/emulation/viper.el b/lisp/emulation/viper.el
index 274c4543e51..d6912ee3675 100644
--- a/lisp/emulation/viper.el
+++ b/lisp/emulation/viper.el
@@ -937,8 +937,13 @@ Two differences:
(if (and (eq viper-current-state 'vi-state)
;; Do not use called-interactively-p here. XEmacs does not have it
;; and interactive-p is just fine.
- ;; (called-interactively-p 'interactive))
- (interactive-p))
+ (if (featurep 'xemacs)
+ (interactive-p)
+ ;; Respect the spirit of the above comment, though it
+ ;; seems pointless, since XE doesn't have advice-add or
+ ;; lexical binding or any other of the newer features
+ ;; this file uses.
+ (called-interactively-p 'interactive)))
(beep 1)
(apply orig-fun args))))
@@ -1052,108 +1057,6 @@ Two differences:
(setq global-mode-string
(append '("" viper-mode-string) (cdr global-mode-string))))
- (if (featurep 'xemacs)
- ;; XEmacs
- (defadvice describe-key (before viper-describe-key-ad protect activate)
- "Force to read key via `viper-read-key-sequence'."
- (interactive (list (viper-read-key-sequence "Describe key: "))))
- ;; Emacs
- (viper--advice-add 'describe-key :before
- (lambda (&rest _)
- "Force to read key via `viper-read-key-sequence'."
- (interactive (let ((key (viper-read-key-sequence
- "Describe key (or click or menu item): ")))
- (list key
- (prefix-numeric-value current-prefix-arg)
- ;; If KEY is a down-event, read also the
- ;; corresponding up-event.
- (and (vectorp key)
- (let ((last-idx (1- (length key))))
- (and (eventp (aref key last-idx))
- (memq 'down (event-modifiers
- (aref key last-idx)))))
- (or (and (eventp (aref key 0))
- (memq 'down (event-modifiers
- (aref key 0)))
- ;; For the C-down-mouse-2 popup menu,
- ;; there is no subsequent up-event
- (= (length key) 1))
- (and (> (length key) 1)
- (eventp (aref key 1))
- (memq 'down (event-modifiers (aref key 1)))))
- (read-event)))))
- nil))
-
- ) ; (if (featurep 'xemacs)
-
- (if (featurep 'xemacs)
- ;; XEmacs
- (defadvice describe-key-briefly
- (before viper-describe-key-briefly-ad protect activate)
- "Force to read key via `viper-read-key-sequence'."
- (interactive (list (viper-read-key-sequence "Describe key briefly: "))))
- ;; Emacs
- (viper--advice-add 'describe-key-briefly :before
- (lambda (&rest _)
- "Force to read key via `viper-read-key-sequence'."
- (interactive (let ((key (viper-read-key-sequence
- "Describe key (or click or menu item): ")))
- ;; If KEY is a down-event, read and discard the
- ;; corresponding up-event.
- (and (vectorp key)
- (let ((last-idx (1- (length key))))
- (and (eventp (aref key last-idx))
- (memq 'down (event-modifiers (aref key last-idx)))))
- (read-event))
- (list key
- (if current-prefix-arg
- (prefix-numeric-value current-prefix-arg))
- 1)))
- nil))
- ) ; (if (featurep 'xemacs)
-
- ;; FIXME: The default already uses read-file-name, so it looks like this
- ;; advice is not needed any more.
- ;; (defadvice find-file (before viper-add-suffix-advice activate)
- ;; "Use `read-file-name' for reading arguments."
- ;; (interactive (cons (read-file-name "Find file: " nil default-directory)
- ;; ;; XEmacs: if Mule & prefix arg, ask for coding system
- ;; (cond ((and (featurep 'xemacs) (featurep 'mule))
- ;; (list
- ;; (and current-prefix-arg
- ;; (read-coding-system "Coding-system: "))))
- ;; ;; Emacs: do wildcards
- ;; ((and (featurep 'emacs) (boundp 'find-file-wildcards))
- ;; (list find-file-wildcards))))
- ;; ))
- ;; (defadvice find-file-other-window (before viper-add-suffix-advice activate)
- ;; "Use `read-file-name' for reading arguments."
- ;; (interactive (cons (read-file-name "Find file in other window: "
- ;; nil default-directory)
- ;; ;; XEmacs: if Mule & prefix arg, ask for coding system
- ;; (cond ((and (featurep 'xemacs) (featurep 'mule))
- ;; (list
- ;; (and current-prefix-arg
- ;; (read-coding-system "Coding-system: "))))
- ;; ;; Emacs: do wildcards
- ;; ((and (featurep 'emacs) (boundp 'find-file-wildcards))
- ;; (list find-file-wildcards))))
- ;; ))
- ;; (defadvice find-file-other-frame (before viper-add-suffix-advice activate)
- ;; "Use `read-file-name' for reading arguments."
- ;; (interactive (cons (read-file-name "Find file in other frame: "
- ;; nil default-directory)
- ;; ;; XEmacs: if Mule & prefix arg, ask for coding system
- ;; (cond ((and (featurep 'xemacs) (featurep 'mule))
- ;; (list
- ;; (and current-prefix-arg
- ;; (read-coding-system "Coding-system: "))))
- ;; ;; Emacs: do wildcards
- ;; ((and (featurep 'emacs) (boundp 'find-file-wildcards))
- ;; (list find-file-wildcards))))
- ;; ))
-
-
(viper--advice-add 'read-file-name :around
(lambda (orig-fun &rest args)
"Tell `exit-minibuffer' to run `viper-file-add-suffix' as a hook."
diff --git a/lisp/env.el b/lisp/env.el
index 2b8f30660c2..5a4130eb3be 100644
--- a/lisp/env.el
+++ b/lisp/env.el
@@ -113,11 +113,11 @@ Changes ENV by side-effect, and returns its new value."
(not keep-empty)
env
(stringp (car env))
- (string-match pattern (car env)))
+ (string-match-p pattern (car env)))
(cdr env)
;; Try to find existing entry for VARIABLE in ENV.
(while (and scan (stringp (car scan)))
- (when (string-match pattern (car scan))
+ (when (string-match-p pattern (car scan))
(if value
(setcar scan (concat variable "=" value))
(if keep-empty
@@ -184,7 +184,7 @@ a side-effect."
(setq variable (encode-coding-string variable locale-coding-system)))
(if (and value (multibyte-string-p value))
(setq value (encode-coding-string value locale-coding-system)))
- (if (string-match "=" variable)
+ (if (string-match-p "=" variable)
(error "Environment variable name `%s' contains `='" variable))
(if (string-equal "TZ" variable)
(set-time-zone-rule value))
diff --git a/lisp/epa-file.el b/lisp/epa-file.el
index 4d5f3b30a34..35cd1ecfded 100644
--- a/lisp/epa-file.el
+++ b/lisp/epa-file.el
@@ -147,7 +147,6 @@ encryption is used."
context
(cons #'epa-progress-callback-function
(format "Decrypting %s" file)))
- (setf (epg-context-pinentry-mode context) epa-pinentry-mode)
(unwind-protect
(progn
(if replace
@@ -236,7 +235,6 @@ encryption is used."
(cons #'epa-progress-callback-function
(format "Encrypting %s" file)))
(setf (epg-context-armor context) epa-armor)
- (setf (epg-context-pinentry-mode context) epa-pinentry-mode)
(condition-case error
(setq string
(epg-encrypt-string
diff --git a/lisp/epa-hook.el b/lisp/epa-hook.el
index 91d8d2b178f..cb9d997bb8f 100644
--- a/lisp/epa-hook.el
+++ b/lisp/epa-hook.el
@@ -83,10 +83,7 @@ May either be a string or a list of strings.")
(auto-save-mode 0)))
(define-minor-mode auto-encryption-mode
- "Toggle automatic file encryption/decryption (Auto Encryption mode).
-With a prefix argument ARG, enable Auto Encryption mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil."
+ "Toggle automatic file encryption/decryption (Auto Encryption mode)."
:global t :init-value t :group 'epa-file :version "23.1"
;; We'd like to use custom-initialize-set here so the setup is done
;; before dumping, but at the point where the defcustom is evaluated,
diff --git a/lisp/epa-mail.el b/lisp/epa-mail.el
index 882c4f60cad..1bb8d9bfde1 100644
--- a/lisp/epa-mail.el
+++ b/lisp/epa-mail.el
@@ -47,10 +47,7 @@
;;;###autoload
(define-minor-mode epa-mail-mode
- "A minor-mode for composing encrypted/clearsigned mails.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil."
+ "A minor-mode for composing encrypted/clearsigned mails."
nil " epa-mail" epa-mail-mode-map)
(defun epa-mail--find-usable-key (keys usage)
@@ -95,7 +92,7 @@ The buffer is expected to contain a mail message."
(forward-line))
(setq epa-last-coding-system-specified
(or coding-system-for-write
- (epa--select-safe-coding-system (point) (point-max))))
+ (select-safe-coding-system (point) (point-max))))
(let ((verbose current-prefix-arg))
(list (point) (point-max)
(if verbose
@@ -111,7 +108,7 @@ If no one is selected, default secret key is used. "
(defun epa-mail-default-recipients ()
"Return the default list of encryption recipients for a mail buffer."
- (let ((config (epg-configuration))
+ (let ((config (epg-find-configuration 'OpenPGP))
recipients-string real-recipients)
(save-excursion
(goto-char (point-min))
@@ -153,7 +150,7 @@ If no one is selected, default secret key is used. "
(mapcar
(lambda (recipient)
(let ((tem (assoc recipient epa-mail-aliases)))
- (if tem (cdr tem)
+ (if tem (copy-sequence (cdr tem))
(list recipient))))
real-recipients)))
)))
@@ -222,7 +219,7 @@ If no one is selected, symmetric encryption will be performed. "
(setq epa-last-coding-system-specified
(or coding-system-for-write
- (epa--select-safe-coding-system (point) (point-max)))))
+ (select-safe-coding-system (point) (point-max)))))
;; Don't let some read-only text stop us from encrypting.
(let ((inhibit-read-only t))
@@ -238,10 +235,7 @@ The buffer is expected to contain a mail message."
;;;###autoload
(define-minor-mode epa-global-mail-mode
- "Minor mode to hook EasyPG into Mail mode.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil."
+ "Minor mode to hook EasyPG into Mail mode."
:global t :init-value nil :group 'epa-mail :version "23.1"
(remove-hook 'mail-mode-hook 'epa-mail-mode)
(if epa-global-mail-mode
diff --git a/lisp/epa.el b/lisp/epa.el
index e442c12a7d6..c8abff4753f 100644
--- a/lisp/epa.el
+++ b/lisp/epa.el
@@ -56,28 +56,6 @@ If neither t nor nil, ask user for confirmation."
:type 'integer
:group 'epa)
-;; In the doc string below, we say "symbol `error'" to avoid producing
-;; a hyperlink for `error' the function.
-(defcustom epa-pinentry-mode nil
- "The pinentry mode.
-
-GnuPG 2.1 or later has an option to control the behavior of
-Pinentry invocation. The value should be the symbol `error',
-`ask', `cancel', or `loopback'. See the GnuPG manual for the
-meanings.
-
-In epa commands, a particularly useful mode is `loopback', which
-redirects all Pinentry queries to the caller, so Emacs can query
-passphrase through the minibuffer, instead of external Pinentry
-program."
- :type '(choice (const nil)
- (const ask)
- (const cancel)
- (const error)
- (const loopback))
- :group 'epa
- :version "25.1")
-
(defgroup epa-faces nil
"Faces for epa-mode."
:version "23.1"
@@ -307,12 +285,6 @@ You should bind this variable with `let', but do not set it globally.")
(epg-sub-key-id (car (epg-key-sub-key-list
(widget-get widget :value))))))
-(defalias 'epa--encode-coding-string
- (if (fboundp 'encode-coding-string) #'encode-coding-string #'identity))
-
-(defalias 'epa--decode-coding-string
- (if (fboundp 'decode-coding-string) #'decode-coding-string #'identity))
-
(define-derived-mode epa-key-list-mode special-mode "Keys"
"Major mode for `epa-list-keys'."
(buffer-disable-undo)
@@ -565,7 +537,7 @@ If SECRET is non-nil, list secret keys instead of public keys."
(epg-sub-key-creation-time (car pointer)))
(error "????-??-??"))
(if (epg-sub-key-expiration-time (car pointer))
- (format (if (time-less-p (current-time)
+ (format (if (time-less-p nil
(epg-sub-key-expiration-time
(car pointer)))
"\n\tExpires: %s"
@@ -625,12 +597,12 @@ If SECRET is non-nil, list secret keys instead of public keys."
(erase-buffer)
(insert (format
(pcase (epg-context-operation context)
- (`decrypt "Error while decrypting with \"%s\":")
- (`verify "Error while verifying with \"%s\":")
- (`sign "Error while signing with \"%s\":")
- (`encrypt "Error while encrypting with \"%s\":")
- (`import-keys "Error while importing keys with \"%s\":")
- (`export-keys "Error while exporting keys with \"%s\":")
+ ('decrypt "Error while decrypting with \"%s\":")
+ ('verify "Error while verifying with \"%s\":")
+ ('sign "Error while signing with \"%s\":")
+ ('encrypt "Error while encrypting with \"%s\":")
+ ('import-keys "Error while importing keys with \"%s\":")
+ ('export-keys "Error while exporting keys with \"%s\":")
(_ "Error while executing \"%s\":\n\n"))
(epg-context-program context))
"\n\n"
@@ -701,7 +673,6 @@ If you do not specify PLAIN-FILE, this functions prompts for the value to use."
#'epa-progress-callback-function
(format "Decrypting %s..."
(file-name-nondirectory decrypt-file))))
- (setf (epg-context-pinentry-mode context) epa-pinentry-mode)
(message "Decrypting %s..." (file-name-nondirectory decrypt-file))
(condition-case error
(epg-decrypt-file context decrypt-file plain-file)
@@ -797,7 +768,6 @@ If no one is selected, default secret key is used. "
#'epa-progress-callback-function
(format "Signing %s..."
(file-name-nondirectory file))))
- (setf (epg-context-pinentry-mode context) epa-pinentry-mode)
(message "Signing %s..." (file-name-nondirectory file))
(condition-case error
(epg-sign-file context file signature mode)
@@ -828,7 +798,6 @@ If no one is selected, symmetric encryption will be performed. ")))
#'epa-progress-callback-function
(format "Encrypting %s..."
(file-name-nondirectory file))))
- (setf (epg-context-pinentry-mode context) epa-pinentry-mode)
(message "Encrypting %s..." (file-name-nondirectory file))
(condition-case error
(epg-encrypt-file context file recipients cipher)
@@ -871,7 +840,6 @@ For example:
(cons
#'epa-progress-callback-function
"Decrypting..."))
- (setf (epg-context-pinentry-mode context) epa-pinentry-mode)
(message "Decrypting...")
(condition-case error
(setq plain (epg-decrypt-string context (buffer-substring start end)))
@@ -879,7 +847,7 @@ For example:
(epa-display-error context)
(signal (car error) (cdr error))))
(message "Decrypting...done")
- (setq plain (epa--decode-coding-string
+ (setq plain (decode-coding-string
plain
(or coding-system-for-read
(get-text-property start 'epa-coding-system-used)
@@ -973,7 +941,7 @@ For example:
(condition-case error
(setq plain (epg-verify-string
context
- (epa--encode-coding-string
+ (encode-coding-string
(buffer-substring start end)
(or coding-system-for-write
(get-text-property start 'epa-coding-system-used)))))
@@ -981,7 +949,7 @@ For example:
(epa-display-error context)
(signal (car error) (cdr error))))
(message "Verifying...done")
- (setq plain (epa--decode-coding-string
+ (setq plain (decode-coding-string
plain
(or coding-system-for-read
(get-text-property start 'epa-coding-system-used)
@@ -1029,12 +997,6 @@ See the reason described in the `epa-verify-region' documentation."
(error "No cleartext tail"))
(epa-verify-region cleartext-start cleartext-end))))))
-(defalias 'epa--select-safe-coding-system
- (if (fboundp 'select-safe-coding-system)
- #'select-safe-coding-system
- (lambda (_from _to)
- buffer-file-coding-system)))
-
;;;###autoload
(defun epa-sign-region (start end signers mode)
"Sign the current region between START and END by SIGNERS keys selected.
@@ -1057,7 +1019,7 @@ For example:
(let ((verbose current-prefix-arg))
(setq epa-last-coding-system-specified
(or coding-system-for-write
- (epa--select-safe-coding-system
+ (select-safe-coding-system
(region-beginning) (region-end))))
(list (region-beginning) (region-end)
(if verbose
@@ -1082,11 +1044,10 @@ If no one is selected, default secret key is used. "
(cons
#'epa-progress-callback-function
"Signing..."))
- (setf (epg-context-pinentry-mode context) epa-pinentry-mode)
(message "Signing...")
(condition-case error
(setq signature (epg-sign-string context
- (epa--encode-coding-string
+ (encode-coding-string
(buffer-substring start end)
epa-last-coding-system-specified)
mode))
@@ -1098,7 +1059,7 @@ If no one is selected, default secret key is used. "
(goto-char start)
(add-text-properties (point)
(progn
- (insert (epa--decode-coding-string
+ (insert (decode-coding-string
signature
(or coding-system-for-read
epa-last-coding-system-specified)))
@@ -1146,7 +1107,7 @@ For example:
sign)
(setq epa-last-coding-system-specified
(or coding-system-for-write
- (epa--select-safe-coding-system
+ (select-safe-coding-system
(region-beginning) (region-end))))
(list (region-beginning) (region-end)
(epa-select-keys context
@@ -1171,11 +1132,10 @@ If no one is selected, symmetric encryption will be performed. ")
(cons
#'epa-progress-callback-function
"Encrypting..."))
- (setf (epg-context-pinentry-mode context) epa-pinentry-mode)
(message "Encrypting...")
(condition-case error
(setq cipher (epg-encrypt-string context
- (epa--encode-coding-string
+ (encode-coding-string
(buffer-substring start end)
epa-last-coding-system-specified)
recipients
@@ -1340,7 +1300,6 @@ If no one is selected, default public key is exported. ")))
;; (cons
;; #'epa-progress-callback-function
;; "Signing keys..."))
-;; (setf (epg-context-pinentry-mode context) epa-pinentry-mode)
;; (message "Signing keys...")
;; (epg-sign-keys context keys local)
;; (message "Signing keys...done")))
diff --git a/lisp/epg-config.el b/lisp/epg-config.el
index 6b93cf7e27b..4502f90874f 100644
--- a/lisp/epg-config.el
+++ b/lisp/epg-config.el
@@ -48,44 +48,64 @@
Setting this variable directly does not take effect;
instead use \\[customize] (see the info node `Easy Customization')."
:version "25.1"
- :group 'epg
:type 'string)
(defcustom epg-gpgsm-program "gpgsm"
"The `gpgsm' executable.
Setting this variable directly does not take effect;
instead use \\[customize] (see the info node `Easy Customization')."
- :group 'epg
:type 'string)
(defcustom epg-gpgconf-program "gpgconf"
"The `gpgconf' executable."
:version "25.1"
- :group 'epg
:type 'string)
(defcustom epg-gpg-home-directory nil
"The directory which contains the configuration files of `epg-gpg-program'."
- :group 'epg
:type '(choice (const :tag "Default" nil) directory))
(defcustom epg-passphrase-coding-system nil
"Coding system to use with messages from `epg-gpg-program'."
- :group 'epg
:type 'symbol)
+(define-obsolete-variable-alias
+ 'epa-pinentry-mode 'epg-pinentry-mode "27.1")
+
+;; In the doc string below, we say "symbol `error'" to avoid producing
+;; a hyperlink for `error' the function.
+(defcustom epg-pinentry-mode nil
+ "The pinentry mode.
+
+GnuPG 2.1 or later has an option to control the behavior of
+Pinentry invocation. The value should be the symbol `error',
+`ask', `cancel', or `loopback'. See the GnuPG manual for the
+meanings.
+
+A particularly useful mode is `loopback', which redirects all
+Pinentry queries to the caller, so Emacs can query passphrase
+through the minibuffer, instead of external Pinentry program."
+ :type '(choice (const nil)
+ (const ask)
+ (const cancel)
+ (const error)
+ (const loopback))
+ :version "27.1")
+
(defcustom epg-debug nil
"If non-nil, debug output goes to the \" *epg-debug*\" buffer.
Note that the buffer name starts with a space."
- :group 'epg
:type 'boolean)
(defconst epg-gpg-minimum-version "1.4.3")
+(defconst epg-gpg2-minimum-version "2.1.6")
(defconst epg-config--program-alist
`((OpenPGP
epg-gpg-program
- ("gpg2" . "2.1.6") ("gpg" . ,epg-gpg-minimum-version))
+ ("gpg2" . ,epg-gpg2-minimum-version)
+ ("gpg" . ((,epg-gpg-minimum-version . "2.0")
+ ,epg-gpg2-minimum-version)))
(CMS
epg-gpgsm-program
("gpgsm" . "2.0.4")))
@@ -211,14 +231,26 @@ version requirement is met."
(epg-config--make-gpg-configuration epg-gpg-program))
;;;###autoload
-(defun epg-check-configuration (config &optional minimum-version)
- "Verify that a sufficient version of GnuPG is installed."
+(defun epg-check-configuration (config &optional req-versions)
+ "Verify that a sufficient version of GnuPG is installed.
+CONFIG should be a `epg-configuration' object (a plist).
+REQ-VERSIONS should be a list with elements of the form (MIN
+. MAX) where MIN and MAX are version strings indicating a
+semi-open range of acceptable versions. REQ-VERSIONS may also be
+a single minimum version string."
(let ((version (alist-get 'version config)))
(unless (stringp version)
(error "Undetermined version: %S" version))
- (unless (version<= (or minimum-version
- epg-gpg-minimum-version)
- version)
+ (catch 'version-ok
+ (pcase-dolist ((or `(,min . ,max)
+ (and min (let max nil)))
+ (if (listp req-versions) req-versions
+ (list req-versions)))
+ (when (and (version<= (or min epg-gpg-minimum-version)
+ version)
+ (or (null max)
+ (version< version max)))
+ (throw 'version-ok t)))
(error "Unsupported version: %s" version))))
;;;###autoload
diff --git a/lisp/epg.el b/lisp/epg.el
index 539dcf3ca22..e06cc06a7d1 100644
--- a/lisp/epg.el
+++ b/lisp/epg.el
@@ -174,10 +174,6 @@
(file nil :read-only t)
(string nil :read-only t))
-(defmacro epg--gv-nreverse (place)
- (gv-letplace (getter setter) place
- (funcall setter `(nreverse ,getter))))
-
(cl-defstruct (epg-context
(:constructor nil)
(:constructor epg-context--make
@@ -211,7 +207,7 @@
output-file
result
operation
- pinentry-mode
+ (pinentry-mode epg-pinentry-mode)
(error-output "")
error-buffer)
@@ -612,7 +608,9 @@ callback data (if any)."
;; for more details.
(when (and agent-info (string-match "\\(.*\\):[0-9]+:[0-9]+" agent-info))
(setq agent-file (match-string 1 agent-info)
- agent-mtime (or (nth 5 (file-attributes agent-file)) '(0 0 0 0))))
+ agent-mtime (or (file-attribute-modification-time
+ (file-attributes agent-file))
+ '(0 0 0 0))))
(if epg-debug
(save-excursion
(unless epg-debug-buffer
@@ -739,7 +737,9 @@ callback data (if any)."
(if (with-current-buffer (process-buffer (epg-context-process context))
(and epg-agent-file
(time-less-p epg-agent-mtime
- (or (nth 5 (file-attributes epg-agent-file)) 0))))
+ (or (file-attribute-modification-time
+ (file-attributes epg-agent-file))
+ 0))))
(redraw-frame))
(epg-context-set-result-for
context 'error
@@ -764,18 +764,13 @@ callback data (if any)."
(file-exists-p (epg-context-output-file context)))
(delete-file (epg-context-output-file context))))
-(eval-and-compile
- (if (fboundp 'decode-coding-string)
- (defalias 'epg--decode-coding-string 'decode-coding-string)
- (defalias 'epg--decode-coding-string 'identity)))
-
(defun epg--status-USERID_HINT (_context string)
(if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
(let* ((key-id (match-string 1 string))
(user-id (match-string 2 string))
(entry (assoc key-id epg-user-id-alist)))
(condition-case nil
- (setq user-id (epg--decode-coding-string
+ (setq user-id (decode-coding-string
(epg--decode-percent-escape user-id)
'utf-8))
(error))
@@ -794,17 +789,6 @@ callback data (if any)."
(defun epg--status-NEED_PASSPHRASE_PIN (_context _string)
(setq epg-key-id 'PIN))
-(eval-and-compile
- (if (fboundp 'clear-string)
- (defalias 'epg--clear-string 'clear-string)
- (defun epg--clear-string (string)
- (fillarray string 0))))
-
-(eval-and-compile
- (if (fboundp 'encode-coding-string)
- (defalias 'epg--encode-coding-string 'encode-coding-string)
- (defalias 'epg--encode-coding-string 'identity)))
-
(defun epg--status-GET_HIDDEN (context string)
(when (and epg-key-id
(string-match "\\`passphrase\\." string))
@@ -825,16 +809,16 @@ callback data (if any)."
(cdr (epg-context-passphrase-callback context))))
(when passphrase
(setq passphrase-with-new-line (concat passphrase "\n"))
- (epg--clear-string passphrase)
+ (clear-string passphrase)
(setq passphrase nil)
(if epg-passphrase-coding-system
(progn
(setq encoded-passphrase-with-new-line
- (epg--encode-coding-string
+ (encode-coding-string
passphrase-with-new-line
(coding-system-change-eol-conversion
epg-passphrase-coding-system 'unix)))
- (epg--clear-string passphrase-with-new-line)
+ (clear-string passphrase-with-new-line)
(setq passphrase-with-new-line nil))
(setq encoded-passphrase-with-new-line
passphrase-with-new-line
@@ -848,11 +832,11 @@ callback data (if any)."
(epg-context-result-for context 'error)))
(delete-process (epg-context-process context))))
(if passphrase
- (epg--clear-string passphrase))
+ (clear-string passphrase))
(if passphrase-with-new-line
- (epg--clear-string passphrase-with-new-line))
+ (clear-string passphrase-with-new-line))
(if encoded-passphrase-with-new-line
- (epg--clear-string encoded-passphrase-with-new-line))))))
+ (clear-string encoded-passphrase-with-new-line))))))
(defun epg--prompt-GET_BOOL (_context string)
(let ((entry (assoc string epg-prompt-alist)))
@@ -915,7 +899,7 @@ callback data (if any)."
(condition-case nil
(if (eq (epg-context-protocol context) 'CMS)
(setq user-id (epg-dn-from-string user-id))
- (setq user-id (epg--decode-coding-string
+ (setq user-id (decode-coding-string
(epg--decode-percent-escape user-id)
'utf-8)))
(error))
@@ -962,10 +946,7 @@ callback data (if any)."
(cons (cons 'no-seckey string)
(epg-context-result-for context 'error))))
-(defun epg--time-from-seconds (seconds)
- (let ((number-seconds (string-to-number (concat seconds ".0"))))
- (cons (floor (/ number-seconds 65536))
- (floor (mod number-seconds 65536)))))
+(defalias 'epg--time-from-seconds #'string-to-number)
(defun epg--status-ERRSIG (context string)
(if (string-match "\\`\\([^ ]+\\) \\([0-9]+\\) \\([0-9]+\\) \
@@ -1163,7 +1144,7 @@ callback data (if any)."
(defun epg--status-SIG_CREATED (context string)
(if (string-match "\\`\\([DCS]\\) \\([0-9]+\\) \\([0-9]+\\) \
-\\([0-9A-Fa-F][0-9A-Fa-F]\\) \\(.*\\) " string)
+\\([0-9A-Fa-f][0-9A-Fa-f]\\) \\(.*\\) " string)
(epg-context-set-result-for
context 'sign
(cons (epg-make-new-signature
@@ -1196,7 +1177,7 @@ callback data (if any)."
(user-id (match-string 2 string))
(entry (assoc key-id epg-user-id-alist)))
(condition-case nil
- (setq user-id (epg--decode-coding-string
+ (setq user-id (decode-coding-string
(epg--decode-percent-escape user-id)
'utf-8))
(error))
@@ -1353,7 +1334,7 @@ NAME is either a string or a list of strings."
(setq string (replace-match "\\\"" t t string)
index (1+ (match-end 0))))
(condition-case nil
- (setq string (epg--decode-coding-string
+ (setq string (decode-coding-string
(car (read-from-string (concat "\"" string "\"")))
'utf-8))
(error
@@ -1390,70 +1371,14 @@ NAME is either a string or a list of strings."
(setq keys (nreverse keys)
pointer keys)
(while pointer
- (epg--gv-nreverse (epg-key-sub-key-list (car pointer)))
- (setq pointer-1 (epg--gv-nreverse (epg-key-user-id-list (car pointer))))
+ (cl-callf nreverse (epg-key-sub-key-list (car pointer)))
+ (setq pointer-1 (cl-callf nreverse (epg-key-user-id-list (car pointer))))
(while pointer-1
- (epg--gv-nreverse (epg-user-id-signature-list (car pointer-1)))
+ (cl-callf nreverse (epg-user-id-signature-list (car pointer-1)))
(setq pointer-1 (cdr pointer-1)))
(setq pointer (cdr pointer)))
keys))
-(eval-and-compile
- (if (fboundp 'make-temp-file)
- (defalias 'epg--make-temp-file 'make-temp-file)
- (defvar temporary-file-directory)
- ;; stolen from poe.el.
- (defun epg--make-temp-file (prefix)
- "Create a temporary file.
-The returned file name (created by appending some random characters at the end
-of PREFIX, and expanding against `temporary-file-directory' if necessary),
-is guaranteed to point to a newly created empty file.
-You can then use `write-region' to write new data into the file."
- (let ((orig-modes (default-file-modes))
- tempdir tempfile)
- (setq prefix (expand-file-name prefix
- (if (featurep 'xemacs)
- (temp-directory)
- temporary-file-directory)))
- (unwind-protect
- (let (file)
- ;; First, create a temporary directory.
- (set-default-file-modes #o700)
- (while (condition-case ()
- (progn
- (setq tempdir (make-temp-name
- (concat
- (file-name-directory prefix)
- "DIR")))
- ;; return nil or signal an error.
- (make-directory tempdir))
- ;; let's try again.
- (file-already-exists t)))
- ;; Second, create a temporary file in the tempdir.
- ;; There *is* a race condition between `make-temp-name'
- ;; and `write-region', but we don't care it since we are
- ;; in a private directory now.
- (setq tempfile (make-temp-name (concat tempdir "/EMU")))
- (write-region "" nil tempfile nil 'silent)
- ;; Finally, make a hard-link from the tempfile.
- (while (condition-case ()
- (progn
- (setq file (make-temp-name prefix))
- ;; return nil or signal an error.
- (add-name-to-file tempfile file))
- ;; let's try again.
- (file-already-exists t)))
- file)
- (set-default-file-modes orig-modes)
- ;; Cleanup the tempfile.
- (and tempfile
- (file-exists-p tempfile)
- (delete-file tempfile))
- ;; Cleanup the tempdir.
- (and tempdir
- (file-directory-p tempdir)
- (delete-directory tempdir)))))))
-
(defun epg--args-from-sig-notations (notations)
(apply #'nconc
(mapcar
@@ -1517,7 +1442,7 @@ If PLAIN is nil, it returns the result as a string."
(unwind-protect
(progn
(setf (epg-context-output-file context)
- (or plain (epg--make-temp-file "epg-output")))
+ (or plain (make-temp-file "epg-output")))
(epg-start-decrypt context (epg-make-data-from-file cipher))
(epg-wait-for-completion context)
(epg--check-error-for-decrypt context)
@@ -1529,13 +1454,13 @@ If PLAIN is nil, it returns the result as a string."
(defun epg-decrypt-string (context cipher)
"Decrypt a string CIPHER and return the plain text."
- (let ((input-file (epg--make-temp-file "epg-input"))
+ (let ((input-file (make-temp-file "epg-input"))
(coding-system-for-write 'binary))
(unwind-protect
(progn
(write-region cipher nil input-file nil 'quiet)
(setf (epg-context-output-file context)
- (epg--make-temp-file "epg-output"))
+ (make-temp-file "epg-output"))
(epg-start-decrypt context (epg-make-data-from-file input-file))
(epg-wait-for-completion context)
(epg--check-error-for-decrypt context)
@@ -1606,7 +1531,7 @@ which will return a list of `epg-signature' object."
(unwind-protect
(progn
(setf (epg-context-output-file context)
- (or plain (epg--make-temp-file "epg-output")))
+ (or plain (make-temp-file "epg-output")))
(if signed-text
(epg-start-verify context
(epg-make-data-from-file signature)
@@ -1643,10 +1568,10 @@ which will return a list of `epg-signature' object."
(unwind-protect
(progn
(setf (epg-context-output-file context)
- (epg--make-temp-file "epg-output"))
+ (make-temp-file "epg-output"))
(if signed-text
(progn
- (setq input-file (epg--make-temp-file "epg-signature"))
+ (setq input-file (make-temp-file "epg-signature"))
(write-region signature nil input-file nil 'quiet)
(epg-start-verify context
(epg-make-data-from-file input-file)
@@ -1714,7 +1639,7 @@ Otherwise, it makes a cleartext signature."
(unwind-protect
(progn
(setf (epg-context-output-file context)
- (or signature (epg--make-temp-file "epg-output")))
+ (or signature (make-temp-file "epg-output")))
(epg-start-sign context (epg-make-data-from-file plain) mode)
(epg-wait-for-completion context)
(unless (epg-context-result-for context 'sign)
@@ -1734,12 +1659,12 @@ If it is nil or `normal', it makes a normal signature.
Otherwise, it makes a cleartext signature."
(let ((input-file
(unless (eq (epg-context-protocol context) 'CMS)
- (epg--make-temp-file "epg-input")))
+ (make-temp-file "epg-input")))
(coding-system-for-write 'binary))
(unwind-protect
(progn
(setf (epg-context-output-file context)
- (epg--make-temp-file "epg-output"))
+ (make-temp-file "epg-output"))
(if input-file
(write-region plain nil input-file nil 'quiet))
(epg-start-sign context
@@ -1816,7 +1741,7 @@ If RECIPIENTS is nil, it performs symmetric encryption."
(unwind-protect
(progn
(setf (epg-context-output-file context)
- (or cipher (epg--make-temp-file "epg-output")))
+ (or cipher (make-temp-file "epg-output")))
(epg-start-encrypt context (epg-make-data-from-file plain)
recipients sign always-trust)
(epg-wait-for-completion context)
@@ -1841,12 +1766,12 @@ If RECIPIENTS is nil, it performs symmetric encryption."
(let ((input-file
(unless (or (not sign)
(eq (epg-context-protocol context) 'CMS))
- (epg--make-temp-file "epg-input")))
+ (make-temp-file "epg-input")))
(coding-system-for-write 'binary))
(unwind-protect
(progn
(setf (epg-context-output-file context)
- (epg--make-temp-file "epg-output"))
+ (make-temp-file "epg-output"))
(if input-file
(write-region plain nil input-file nil 'quiet))
(epg-start-encrypt context
@@ -1891,7 +1816,7 @@ If you are unsure, use synchronous version of this function
(unwind-protect
(progn
(setf (epg-context-output-file context)
- (or file (epg--make-temp-file "epg-output")))
+ (or file (make-temp-file "epg-output")))
(epg-start-export-keys context keys)
(epg-wait-for-completion context)
(let ((errors (epg-context-result-for context 'error)))
diff --git a/lisp/erc/erc-autoaway.el b/lisp/erc/erc-autoaway.el
index d4fda5c7589..9e224e0b828 100644
--- a/lisp/erc/erc-autoaway.el
+++ b/lisp/erc/erc-autoaway.el
@@ -82,7 +82,7 @@ This is used when `erc-autoaway-idle-method' is 'user."
(unless (erc-autoaway-some-server-buffer)
(remove-hook 'post-command-hook 'erc-autoaway-reset-idle-user)))
-;;;###autoload (autoload 'erc-autoaway-mode "erc-autoaway")
+;;;###autoload(autoload 'erc-autoaway-mode "erc-autoaway")
(define-erc-module autoaway nil
"In ERC autoaway mode, you can be set away automatically.
If `erc-auto-set-away' is set, then you will be set away after
@@ -282,6 +282,7 @@ active server buffer available."
;;; erc-autoaway.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el
index 3e2a9bc4e56..2854cde19cc 100644
--- a/lisp/erc/erc-backend.el
+++ b/lisp/erc/erc-backend.el
@@ -466,14 +466,18 @@ If this is set to nil, never try to reconnect."
The length is specified in `erc-split-line-length'.
Currently this is called by `erc-send-input'."
- (if (< (length longline)
- erc-split-line-length)
- (list longline)
+ (let ((charset (car (erc-coding-system-for-target nil))))
(with-temp-buffer
(insert longline)
+ ;; The line lengths are in octets, not characters (because these
+ ;; are server protocol limits), so we have to first make the
+ ;; text into bytes, then fold the bytes on "word" boundaries,
+ ;; and then make the bytes into text again.
+ (encode-coding-region (point-min) (point-max) charset)
(let ((fill-column erc-split-line-length))
(fill-region (point-min) (point-max)
nil t))
+ (decode-coding-region (point-min) (point-max) charset)
(split-string (buffer-string) "\n"))))
(defun erc-forward-word ()
@@ -644,22 +648,24 @@ Make sure you are in an ERC buffer when running this."
(erc-log-irc-protocol line nil)
(erc-parse-server-response process line)))))))
-(defsubst erc-server-reconnect-p (event)
+(define-inline erc-server-reconnect-p (event)
"Return non-nil if ERC should attempt to reconnect automatically.
EVENT is the message received from the closed connection process."
- (or erc-server-reconnecting
- (and erc-server-auto-reconnect
- (not erc-server-banned)
- ;; make sure we don't infinitely try to reconnect, unless the
- ;; user wants that
- (or (eq erc-server-reconnect-attempts t)
- (and (integerp erc-server-reconnect-attempts)
- (< erc-server-reconnect-count
- erc-server-reconnect-attempts)))
- (or erc-server-timed-out
- (not (string-match "^deleted" event)))
- ;; open-network-stream-nowait error for connection refused
- (if (string-match "^failed with code 111" event) 'nonblocking t))))
+ (inline-letevals (event)
+ (inline-quote
+ (or erc-server-reconnecting
+ (and erc-server-auto-reconnect
+ (not erc-server-banned)
+ ;; make sure we don't infinitely try to reconnect, unless the
+ ;; user wants that
+ (or (eq erc-server-reconnect-attempts t)
+ (and (integerp erc-server-reconnect-attempts)
+ (< erc-server-reconnect-count
+ erc-server-reconnect-attempts)))
+ (or erc-server-timed-out
+ (not (string-match "^deleted" ,event)))
+ ;; open-network-stream-nowait error for connection refused
+ (if (string-match "^failed with code 111" ,event) 'nonblocking t))))))
(defun erc-process-sentinel-2 (event buffer)
"Called when `erc-process-sentinel-1' has detected an unexpected disconnect."
@@ -838,10 +844,9 @@ Additionally, detect whether the IRC process has hung."
erc-server-last-received-time))
(with-current-buffer buf
(if (and erc-server-send-ping-timeout
- (>
- (erc-time-diff (erc-current-time)
- erc-server-last-received-time)
- erc-server-send-ping-timeout))
+ (time-less-p
+ erc-server-send-ping-timeout
+ (time-since erc-server-last-received-time)))
(progn
;; if the process is hung, kill it
(setq erc-server-timed-out t)
@@ -859,16 +864,15 @@ Additionally, detect whether the IRC process has hung."
See `erc-server-flood-margin' for an explanation of the flood
protection algorithm."
(with-current-buffer buffer
- (let ((now (erc-current-time)))
+ (let ((now (current-time)))
(when erc-server-flood-timer
(erc-cancel-timer erc-server-flood-timer)
(setq erc-server-flood-timer nil))
- (when (< erc-server-flood-last-message
- now)
- (setq erc-server-flood-last-message now))
+ (when (time-less-p erc-server-flood-last-message now)
+ (setq erc-server-flood-last-message (erc-emacs-time-to-erc-time now)))
(while (and erc-server-flood-queue
- (< erc-server-flood-last-message
- (+ now erc-server-flood-margin)))
+ (time-less-p erc-server-flood-last-message
+ (time-add now erc-server-flood-margin)))
(let ((msg (caar erc-server-flood-queue))
(encoding (cdar erc-server-flood-queue)))
(setq erc-server-flood-queue (cdr erc-server-flood-queue)
@@ -1064,8 +1068,8 @@ Hands off to helper functions via `erc-call-hooks'."
erc-server-prevent-duplicates)
(let ((m (erc-response.unparsed parsed-response)))
;; duplicate suppression
- (if (< (or (gethash m erc-server-duplicates) 0)
- (- (erc-current-time) erc-server-duplicate-timeout))
+ (if (time-less-p (or (gethash m erc-server-duplicates) 0)
+ (time-since erc-server-duplicate-timeout))
(erc-call-hooks process parsed-response))
(puthash m (erc-current-time) erc-server-duplicates))
;; Hand off to the relevant handler.
@@ -1441,7 +1445,7 @@ add things to `%s' instead."
"Handle pong messages." nil
(let ((time (string-to-number (erc-response.contents parsed))))
(when (> time 0)
- (setq erc-server-lag (erc-time-diff time (erc-current-time)))
+ (setq erc-server-lag (erc-time-diff time nil))
(when erc-verbose-server-ping
(erc-display-message
parsed 'notice proc 'PONG
@@ -1724,7 +1728,7 @@ See `erc-display-server-message'." nil
(cdr (erc-response.command-args parsed))))
(setq time (when on-since
(format-time-string erc-server-timestamp-format
- (erc-string-to-emacs-time on-since))))
+ (string-to-number on-since))))
(erc-update-user-nick nick nick nil nil nil
(and time (format "on since %s" time)))
(if time
@@ -1796,7 +1800,7 @@ See `erc-display-server-message'." nil
(define-erc-response-handler (329)
"Channel creation date." nil
(let ((channel (cadr (erc-response.command-args parsed)))
- (time (erc-string-to-emacs-time
+ (time (string-to-number
(nth 2 (erc-response.command-args parsed)))))
(erc-display-message
parsed 'notice (erc-get-buffer channel proc)
@@ -1838,7 +1842,7 @@ See `erc-display-server-message'." nil
(pcase-let ((`(,channel ,nick ,time)
(cdr (erc-response.command-args parsed))))
(setq time (format-time-string erc-server-timestamp-format
- (erc-string-to-emacs-time time)))
+ (string-to-number time)))
(erc-update-channel-topic channel
(format "\C-o (%s, %s)" nick time)
'append)
diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el
index a381464b8cd..c8aa887a652 100644
--- a/lisp/erc/erc-button.el
+++ b/lisp/erc/erc-button.el
@@ -49,7 +49,7 @@
"Define how text can be turned into clickable buttons."
:group 'erc)
-;;;###autoload (autoload 'erc-button-mode "erc-button" nil t)
+;;;###autoload(autoload 'erc-button-mode "erc-button" nil t)
(define-erc-module button nil
"This mode buttonizes all messages according to `erc-button-alist'."
((add-hook 'erc-insert-modify-hook 'erc-button-add-buttons 'append)
@@ -121,9 +121,13 @@ longer than `erc-fill-column'."
:group 'erc-button
:type 'string)
-(defcustom erc-button-google-url "http://www.google.com/search?q=%s"
- "URL used to browse Google search references.
+(define-obsolete-variable-alias 'erc-button-google-url
+ 'erc-button-search-url "27.1")
+
+(defcustom erc-button-search-url "http://duckduckgo.com/?q=%s"
+ "URL used to search for a term.
%s is replaced by the search string."
+ :version "27.1"
:group 'erc-button
:type 'string)
@@ -148,7 +152,7 @@ longer than `erc-fill-column'."
("Lisp:\\([a-zA-Z.+-]+\\)" 0 t erc-browse-emacswiki-lisp 1)
("\\bGoogle:\\([^ \t\n\r\f]+\\)"
0 t (lambda (keywords)
- (browse-url (format erc-button-google-url keywords)))
+ (browse-url (format erc-button-search-url keywords)))
1)
("\\brfc[#: ]?\\([0-9]+\\)"
0 t (lambda (num)
@@ -545,5 +549,6 @@ and `apropos' for other symbols."
;;; erc-button.el ends here
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: nil
;; End:
diff --git a/lisp/erc/erc-capab.el b/lisp/erc/erc-capab.el
index fa7c83a194c..210a7736cc0 100644
--- a/lisp/erc/erc-capab.el
+++ b/lisp/erc/erc-capab.el
@@ -90,7 +90,7 @@ character not found in IRC nicknames to avoid confusion."
;;; Define module:
-;;;###autoload (autoload 'erc-capab-identify-mode "erc-capab" nil t)
+;;;###autoload(autoload 'erc-capab-identify-mode "erc-capab" nil t)
(define-erc-module capab-identify nil
"Handle dancer-ircd's CAPAB IDENTIFY-MSG and IDENTIFY-CTCP."
;; append so that `erc-server-parameters' is already set by `erc-server-005'
@@ -207,3 +207,7 @@ PARSED is an `erc-parsed' response struct."
(provide 'erc-capab)
;;; erc-capab.el ends here
+
+;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
+;; End:
diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el
index 243816d4c4d..e724e367ab1 100644
--- a/lisp/erc/erc-compat.el
+++ b/lisp/erc/erc-compat.el
@@ -29,7 +29,7 @@
(require 'format-spec)
-;;;###autoload (autoload 'erc-define-minor-mode "erc-compat")
+;;;###autoload(autoload 'erc-define-minor-mode "erc-compat")
(defalias 'erc-define-minor-mode 'define-minor-mode)
(put 'erc-define-minor-mode 'edebug-form-spec 'define-minor-mode)
@@ -161,6 +161,7 @@ If START or END is negative, it counts from the end."
;;; erc-compat.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el
index 2b41c8c705b..a6b7532e1f3 100644
--- a/lisp/erc/erc-dcc.el
+++ b/lisp/erc/erc-dcc.el
@@ -54,9 +54,11 @@
;;; Code:
(require 'erc)
-(eval-when-compile (require 'pcomplete))
+;; Strictly speaking, should only be needed at compile time.
+;; Require at run-time too to silence compiler.
+(require 'pcomplete)
-;;;###autoload (autoload 'erc-dcc-mode "erc-dcc")
+;;;###autoload(autoload 'erc-dcc-mode "erc-dcc")
(define-erc-module dcc nil
"Provide Direct Client-to-Client support for ERC."
((add-hook 'erc-server-401-functions 'erc-dcc-no-such-nick))
@@ -222,14 +224,6 @@ which is big-endian."
(setq i (1- i)))
str))
-(defconst erc-most-positive-int-bytes
- (ceiling (/ (ceiling (/ (log most-positive-fixnum) (log 2))) 8.0))
- "Maximum number of bytes for a fixnum.")
-
-(defconst erc-most-positive-int-msb
- (lsh most-positive-fixnum (- 0 (* 8 (1- erc-most-positive-int-bytes))))
- "Content of the most significant byte of most-positive-fixnum.")
-
(defun erc-unpack-int (str)
"Unpack a packed string into an integer."
(let ((len (length str)))
@@ -240,16 +234,11 @@ which is big-endian."
(when (> start 0)
(setq str (substring str start))
(setq len (- len start))))
- ;; make sure size is not larger than Emacs can handle
- (when (or (> len (min 4 erc-most-positive-int-bytes))
- (and (eq len erc-most-positive-int-bytes)
- (> (aref str 0) erc-most-positive-int-msb)))
- (error "ERC-DCC (erc-unpack-int): packet to send is too large"))
;; unpack
(let ((num 0)
(count 0))
(while (< count len)
- (setq num (+ num (lsh (aref str (- len count 1)) (* 8 count))))
+ (setq num (+ num (ash (aref str (- len count 1)) (* 8 count))))
(setq count (1+ count)))
num)))
@@ -433,23 +422,23 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc."
(when (fboundp 'make-network-process) '("send"))))
(pcomplete-here
(pcase (intern (downcase (pcomplete-arg 1)))
- (`chat (mapcar (lambda (elt) (plist-get elt :nick))
+ ('chat (mapcar (lambda (elt) (plist-get elt :nick))
(erc-remove-if-not
#'(lambda (elt)
(eq (plist-get elt :type) 'CHAT))
erc-dcc-list)))
- (`close (erc-delete-dups
+ ('close (erc-delete-dups
(mapcar (lambda (elt) (symbol-name (plist-get elt :type)))
erc-dcc-list)))
- (`get (mapcar #'erc-dcc-nick
+ ('get (mapcar #'erc-dcc-nick
(erc-remove-if-not
#'(lambda (elt)
(eq (plist-get elt :type) 'GET))
erc-dcc-list)))
- (`send (pcomplete-erc-all-nicks))))
+ ('send (pcomplete-erc-all-nicks))))
(pcomplete-here
(pcase (intern (downcase (pcomplete-arg 2)))
- (`get (mapcar (lambda (elt) (plist-get elt :file))
+ ('get (mapcar (lambda (elt) (plist-get elt :file))
(erc-remove-if-not
#'(lambda (elt)
(and (eq (plist-get elt :type) 'GET)
@@ -457,13 +446,13 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc."
(plist-get elt :nick))
(pcomplete-arg 1))))
erc-dcc-list)))
- (`close (mapcar #'erc-dcc-nick
+ ('close (mapcar #'erc-dcc-nick
(erc-remove-if-not
#'(lambda (elt)
(eq (plist-get elt :type)
(intern (upcase (pcomplete-arg 1)))))
erc-dcc-list)))
- (`send (pcomplete-entries)))))
+ ('send (pcomplete-entries)))))
(defun erc-dcc-do-CHAT-command (proc &optional nick)
(when nick
@@ -649,9 +638,10 @@ that subcommand."
"\"\\(\\(.*?\\(\\\\\"\\)?\\)+?\\)\"\\|\\([^ ]+\\)"
"\\) \\([0-9]+\\) \\([0-9]+\\) *\\([0-9]*\\)"))
-(defsubst erc-dcc-unquote-filename (filename)
- (erc-replace-regexp-in-string "\\\\\\\\" "\\"
- (erc-replace-regexp-in-string "\\\\\"" "\"" filename t t) t t))
+(define-inline erc-dcc-unquote-filename (filename)
+ (inline-quote
+ (erc-replace-regexp-in-string "\\\\\\\\" "\\"
+ (erc-replace-regexp-in-string "\\\\\"" "\"" ,filename t t) t t)))
(defun erc-dcc-handle-ctcp-send (proc query nick login host to)
"This is called if a CTCP DCC SEND subcommand is sent to the client.
@@ -780,8 +770,8 @@ unconfirmed."
:group 'erc-dcc
:type '(choice (const nil) integer))
-(defsubst erc-dcc-get-parent (proc)
- (plist-get (erc-dcc-member :peer proc) :parent))
+(define-inline erc-dcc-get-parent (proc)
+ (inline-quote (plist-get (erc-dcc-member :peer ,proc) :parent)))
(defun erc-dcc-send-block (proc)
"Send one block of data.
@@ -1034,7 +1024,7 @@ transfer is complete."
?s (number-to-string erc-dcc-byte-count)
?t (format "%.0f"
(erc-time-diff (plist-get erc-dcc-entry-data :start-time)
- (erc-current-time)))))
+ nil))))
(kill-buffer (process-buffer proc))
(delete-process proc))
@@ -1094,14 +1084,14 @@ Possible values are: ask, auto, ignore."
(pcomplete-here '("auto" "ask" "ignore")))
(defalias 'pcomplete/erc-mode/SREQ 'pcomplete/erc-mode/CREQ)
+(define-obsolete-variable-alias 'erc-dcc-chat-filter-hook
+ 'erc-dcc-chat-filter-functions "24.3")
+
(defvar erc-dcc-chat-filter-functions '(erc-dcc-chat-parse-output)
"Abnormal hook run after parsing (and maybe inserting) a DCC message.
Each function is called with two arguments: the ERC process and
the unprocessed output.")
-(define-obsolete-variable-alias 'erc-dcc-chat-filter-hook
- 'erc-dcc-chat-filter-functions "24.3")
-
(defvar erc-dcc-chat-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "RET") 'erc-send-current-line)
@@ -1260,5 +1250,6 @@ other client."
;;; erc-dcc.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: nil
;; End:
diff --git a/lisp/erc/erc-desktop-notifications.el b/lisp/erc/erc-desktop-notifications.el
index 66f27d92ebb..41b7420320c 100644
--- a/lisp/erc/erc-desktop-notifications.el
+++ b/lisp/erc/erc-desktop-notifications.el
@@ -1,4 +1,4 @@
-;; erc-desktop-notifications.el -- Send notification on PRIVMSG or mentions
+;; erc-desktop-notifications.el -- Send notification on PRIVMSG or mentions -*- lexical-binding:t -*-
;; Copyright (C) 2012-2019 Free Software Foundation, Inc.
@@ -59,13 +59,19 @@
This will replace the last notification sent with this function."
(dbus-ignore-errors
(setq erc-notifications-last-notification
- (notifications-notify :bus erc-notifications-bus
- :title (xml-escape-string nick)
- :body (xml-escape-string msg)
- :replaces-id erc-notifications-last-notification
- :app-icon erc-notifications-icon))))
-
-(defun erc-notifications-PRIVMSG (proc parsed)
+ (let ((channel (current-buffer)))
+ (notifications-notify :bus erc-notifications-bus
+ :title (format "%s in %s"
+ (xml-escape-string nick)
+ channel)
+ :body (xml-escape-string msg)
+ :replaces-id erc-notifications-last-notification
+ :app-icon erc-notifications-icon
+ :actions '("default" "Switch to buffer")
+ :on-action (lambda (&rest _)
+ (pop-to-buffer channel)))))))
+
+(defun erc-notifications-PRIVMSG (_proc parsed)
(let ((nick (car (erc-parse-user (erc-response.sender parsed))))
(target (car (erc-response.command-args parsed)))
(msg (erc-response.contents parsed)))
@@ -98,3 +104,7 @@ This will replace the last notification sent with this function."
(provide 'erc-desktop-notifications)
;;; erc-desktop-notifications.el ends here
+
+;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
+;; End:
diff --git a/lisp/erc/erc-ezbounce.el b/lisp/erc/erc-ezbounce.el
index 520ee2ddf17..a2c9336826a 100644
--- a/lisp/erc/erc-ezbounce.el
+++ b/lisp/erc/erc-ezbounce.el
@@ -175,3 +175,7 @@ in the alist is nil, prompt for the appropriate values."
(provide 'erc-ezbounce)
;;; erc-ezbounce.el ends here
+
+;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
+;; End:
diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el
index 36187256dc7..934b52a938c 100644
--- a/lisp/erc/erc-fill.el
+++ b/lisp/erc/erc-fill.el
@@ -37,7 +37,7 @@
"Filling means to reformat long lines in different ways."
:group 'erc)
-;;;###autoload (autoload 'erc-fill-mode "erc-fill" nil t)
+;;;###autoload(autoload 'erc-fill-mode "erc-fill" nil t)
(erc-define-minor-mode erc-fill-mode
"Toggle ERC fill mode.
With a prefix argument ARG, enable ERC fill mode if ARG is
@@ -193,5 +193,6 @@ You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'."
;;; erc-fill.el ends here
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: nil
;; End:
diff --git a/lisp/erc/erc-identd.el b/lisp/erc/erc-identd.el
index 385410496a5..d95e0eac0c7 100644
--- a/lisp/erc/erc-identd.el
+++ b/lisp/erc/erc-identd.el
@@ -55,7 +55,7 @@ This can be either a string or a number."
(integer :tag "Port number")
(string :tag "Port string")))
-;;;###autoload (autoload 'erc-identd-mode "erc-identd")
+;;;###autoload(autoload 'erc-identd-mode "erc-identd")
(define-erc-module identd nil
"This mode launches an identd server on port 8113."
((add-hook 'erc-connect-pre-hook 'erc-identd-quickstart)
@@ -115,6 +115,7 @@ The default port is specified by `erc-identd-port'."
;;; erc-identd.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc-imenu.el b/lisp/erc/erc-imenu.el
index be8e0b07235..08f52f13647 100644
--- a/lisp/erc/erc-imenu.el
+++ b/lisp/erc/erc-imenu.el
@@ -131,6 +131,7 @@ Don't rely on this function, read it first!"
;;; erc-imenu.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc-join.el b/lisp/erc/erc-join.el
index 83f7a045575..896521eaf0a 100644
--- a/lisp/erc/erc-join.el
+++ b/lisp/erc/erc-join.el
@@ -39,7 +39,7 @@
"Enable autojoining."
:group 'erc)
-;;;###autoload (autoload 'erc-autojoin-mode "erc-join" nil t)
+;;;###autoload(autoload 'erc-autojoin-mode "erc-join" nil t)
(define-erc-module autojoin nil
"Makes ERC autojoin on connects and reconnects."
((add-hook 'erc-after-connect 'erc-autojoin-channels)
@@ -215,6 +215,7 @@ This function is run from `erc-nickserv-identified-hook'."
;;; erc-join.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc-list.el b/lisp/erc/erc-list.el
index f354ff5ae09..d8d9e17c95a 100644
--- a/lisp/erc/erc-list.el
+++ b/lisp/erc/erc-list.el
@@ -55,7 +55,7 @@
(defvar erc-list-server-buffer nil)
;; Define module:
-;;;###autoload (autoload 'erc-list-mode "erc-list")
+;;;###autoload(autoload 'erc-list-mode "erc-list")
(define-erc-module list nil
"List channels nicely in a separate buffer."
((remove-hook 'erc-server-321-functions 'erc-server-321-message)
@@ -225,6 +225,7 @@ to RFC and send the LIST header (#321) at start of list transmission."
;;; erc-list.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el
index 59d157576dc..4153f5c57bd 100644
--- a/lisp/erc/erc-log.el
+++ b/lisp/erc/erc-log.el
@@ -122,7 +122,7 @@ custom function which returns the directory part and set
(function :tag "Other function")))
(defcustom erc-truncate-buffer-on-save nil
- "Truncate any ERC (channel, query, server) buffer when it is saved."
+ "Erase the contents of any ERC (channel, query, server) buffer when it is saved."
:group 'erc-log
:type 'boolean)
@@ -215,7 +215,7 @@ The function should take one argument, which is the text to filter."
(const :tag "No filtering" nil)))
-;;;###autoload (autoload 'erc-log-mode "erc-log" nil t)
+;;;###autoload(autoload 'erc-log-mode "erc-log" nil t)
(define-erc-module log nil
"Automatically logs things you receive on IRC into files.
Files are stored in `erc-log-channels-directory'; file name
@@ -344,18 +344,19 @@ If BUFFER is nil, the value of `current-buffer' is used.
This is determined by `erc-generate-log-file-name-function'.
The result is converted to lowercase, as IRC is case-insensitive"
(unless buffer (setq buffer (current-buffer)))
- (let ((target (or (buffer-name buffer) (erc-default-target)))
- (nick (erc-current-nick))
- (server erc-session-server)
- (port erc-session-port))
- (expand-file-name
- (erc-log-standardize-name
- (funcall erc-generate-log-file-name-function
- buffer target nick server port))
- (if (functionp erc-log-channels-directory)
- (funcall erc-log-channels-directory
- buffer target nick server port)
- erc-log-channels-directory))))
+ (with-current-buffer buffer
+ (let ((target (or (buffer-name buffer) (erc-default-target)))
+ (nick (erc-current-nick))
+ (server erc-session-server)
+ (port erc-session-port))
+ (expand-file-name
+ (erc-log-standardize-name
+ (funcall erc-generate-log-file-name-function
+ buffer target nick server port))
+ (if (functionp erc-log-channels-directory)
+ (funcall erc-log-channels-directory
+ buffer target nick server port)
+ erc-log-channels-directory)))))
(defun erc-generate-log-file-name-with-date (buffer &rest ignore)
"This function computes a short log file name.
@@ -456,6 +457,7 @@ You can save every individual message by putting this function on
;;; erc-log.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el
index 250266c82e6..cc4b4a88f11 100644
--- a/lisp/erc/erc-match.el
+++ b/lisp/erc/erc-match.el
@@ -44,7 +44,7 @@ Group containing all things concerning pattern matching in ERC
messages."
:group 'erc)
-;;;###autoload (autoload 'erc-match-mode "erc-match")
+;;;###autoload(autoload 'erc-match-mode "erc-match")
(define-erc-module match nil
"This mode checks whether messages match certain patterns. If so,
they are hidden or highlighted. This is controlled via the variables
@@ -601,7 +601,7 @@ See `erc-log-match-format'."
'timestamp))))
(away-time (erc-emacs-time-to-erc-time (erc-away-time))))
(when (and away-time last-msg-time
- (erc-time-gt last-msg-time away-time))
+ (time-less-p away-time last-msg-time))
(erc-display-message
nil 'notice 'active
(format "You have logged messages waiting in \"%s\"."
@@ -648,6 +648,7 @@ This function is meant to be called from `erc-text-matched-hook'."
;;; erc-match.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc-menu.el b/lisp/erc/erc-menu.el
index 5696306342c..8173829797b 100644
--- a/lisp/erc/erc-menu.el
+++ b/lisp/erc/erc-menu.el
@@ -107,7 +107,7 @@
"Internal variable used to keep track of whether we've defined the
ERC menu yet.")
-;;;###autoload (autoload 'erc-menu-mode "erc-menu" nil t)
+;;;###autoload(autoload 'erc-menu-mode "erc-menu" nil t)
(define-erc-module menu nil
"Enable a menu in ERC buffers."
((unless erc-menu-defined
@@ -148,6 +148,7 @@ ERC menu yet.")
;;; erc-menu.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc-netsplit.el b/lisp/erc/erc-netsplit.el
index a2f271f2f4b..87c3a61b663 100644
--- a/lisp/erc/erc-netsplit.el
+++ b/lisp/erc/erc-netsplit.el
@@ -38,7 +38,7 @@ netsplit happens, and filters the QUIT messages. It also keeps
track of netsplits, so that it can filter the JOIN messages on a netjoin too."
:group 'erc)
-;;;###autoload (autoload 'erc-netsplit-mode "erc-netsplit")
+;;;###autoload(autoload 'erc-netsplit-mode "erc-netsplit")
(define-erc-module netsplit nil
"This mode hides quit/join messages if a netsplit occurs."
((erc-netsplit-install-message-catalogs)
@@ -205,6 +205,7 @@ join from that split has been detected or not.")
;;; erc-netsplit.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc-notify.el b/lisp/erc/erc-notify.el
index 19045a6d1bf..45dae899900 100644
--- a/lisp/erc/erc-notify.el
+++ b/lisp/erc/erc-notify.el
@@ -92,7 +92,7 @@ strings."
(notify_on . "Detected %n on IRC network %m")
(notify_off . "%n has left IRC network %m"))))
-;;;###autoload (autoload 'erc-notify-mode "erc-notify" nil t)
+;;;###autoload(autoload 'erc-notify-mode "erc-notify" nil t)
(define-erc-module notify nil
"Periodically check for the online status of certain users and report
changes."
@@ -253,6 +253,7 @@ with args, toggle notify status of people."
;;; erc-notify.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc-page.el b/lisp/erc/erc-page.el
index 7f1378c7243..cb57883ae6f 100644
--- a/lisp/erc/erc-page.el
+++ b/lisp/erc/erc-page.el
@@ -30,7 +30,7 @@
(require 'erc)
-;;;###autoload (autoload 'erc-page-mode "erc-page")
+;;;###autoload(autoload 'erc-page-mode "erc-page")
(define-erc-module page ctcp-page
"Process CTCP PAGE requests from IRC."
nil nil)
@@ -107,6 +107,7 @@ receive pages if `erc-page-mode' is on."
;;; erc-page.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc-pcomplete.el b/lisp/erc/erc-pcomplete.el
index a67787fb6f9..dd2da85d0e8 100644
--- a/lisp/erc/erc-pcomplete.el
+++ b/lisp/erc/erc-pcomplete.el
@@ -60,7 +60,7 @@ the most recent speakers are listed first."
:group 'erc-pcomplete
:type 'boolean)
-;;;###autoload (autoload 'erc-completion-mode "erc-pcomplete" nil t)
+;;;###autoload(autoload 'erc-completion-mode "erc-pcomplete" nil t)
(define-erc-module pcomplete Completion
"In ERC Completion mode, the TAB key does completion whenever possible."
((add-hook 'erc-mode-hook 'pcomplete-erc-setup)
@@ -284,5 +284,6 @@ up to where point is right now."
;;; erc-pcomplete.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: nil
;; End:
diff --git a/lisp/erc/erc-replace.el b/lisp/erc/erc-replace.el
index 80ff99cc975..2e0e54a030f 100644
--- a/lisp/erc/erc-replace.el
+++ b/lisp/erc/erc-replace.el
@@ -77,7 +77,7 @@ It replaces text according to `erc-replace-alist'."
(eval to))))))
erc-replace-alist))
-;;;###autoload (autoload 'erc-replace-mode "erc-replace")
+;;;###autoload(autoload 'erc-replace-mode "erc-replace")
(define-erc-module replace nil
"This mode replaces incoming text according to `erc-replace-alist'."
((add-hook 'erc-insert-modify-hook
@@ -90,6 +90,7 @@ It replaces text according to `erc-replace-alist'."
;;; erc-replace.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc-ring.el b/lisp/erc/erc-ring.el
index 8ec9f8ffa25..5459d8b01e5 100644
--- a/lisp/erc/erc-ring.el
+++ b/lisp/erc/erc-ring.el
@@ -42,7 +42,7 @@
"An input ring for ERC."
:group 'erc)
-;;;###autoload (autoload 'erc-ring-mode "erc-ring" nil t)
+;;;###autoload(autoload 'erc-ring-mode "erc-ring" nil t)
(define-erc-module ring nil
"Stores input in a ring so that previous commands and messages can
be recalled using M-p and M-n."
@@ -146,5 +146,6 @@ containing a password."
;;; erc-ring.el ends here
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: nil
;; End:
diff --git a/lisp/erc/erc-services.el b/lisp/erc/erc-services.el
index b6bceff205c..886ba60eb47 100644
--- a/lisp/erc/erc-services.el
+++ b/lisp/erc/erc-services.el
@@ -1,4 +1,4 @@
-;;; erc-services.el --- Identify to NickServ
+;;; erc-services.el --- Identify to NickServ -*- lexical-binding:t -*-
;; Copyright (C) 2002-2004, 2006-2019 Free Software Foundation, Inc.
@@ -89,7 +89,7 @@ Possible settings are:.
latter.
nil - Disables automatic Nickserv identification.
-You can also use M-x erc-nickserv-identify-mode to change modes."
+You can also use \\[erc-nickserv-identify-mode] to change modes."
:group 'erc-services
:type '(choice (const autodetect)
(const nick-change)
@@ -101,7 +101,7 @@ You can also use M-x erc-nickserv-identify-mode to change modes."
(when (featurep 'erc-services)
(erc-nickserv-identify-mode val))))
-;;;###autoload (autoload 'erc-services-mode "erc-services" nil t)
+;;;###autoload(autoload 'erc-services-mode "erc-services" nil t)
(define-erc-module services nickserv
"This mode automates communication with services."
((erc-nickserv-identify-mode erc-nickserv-identify-mode))
@@ -214,7 +214,7 @@ Example of use:
"identify" nil nil nil)
(Azzurra
"NickServ!service@azzurra.org"
- "/ns\\s-IDENTIFY\\s-password"
+ "\^B/ns\\s-IDENTIFY\\s-password\^B"
"NickServ"
"IDENTIFY" nil nil nil)
(BitlBee
@@ -223,7 +223,7 @@ Example of use:
"identify" nil nil nil)
(BRASnet
"NickServ!services@brasnet.org"
- "/NickServ\\s-IDENTIFY\\s-senha"
+ "\^B/NickServ\\s-IDENTIFY\\s-\^_senha\^_\^B"
"NickServ"
"IDENTIFY" nil "" nil)
(DALnet
@@ -262,7 +262,7 @@ Example of use:
nil
"NickServ"
"IDENTIFY" nil nil
- "You\\s-are\\s-successfully\\s-identified\\s-as\\s-")
+ "You\\s-are\\s-successfully\\s-identified\\s-as\\s-\^B")
(Rizon
"NickServ!service@rizon.net"
"This\\s-nickname\\s-is\\s-registered\\s-and\\s-protected."
@@ -275,7 +275,7 @@ Example of use:
"auth" t nil nil)
(SlashNET
"NickServ!services@services.slashnet.org"
- "/msg\\s-NickServ\\s-IDENTIFY\\s-password"
+ "/msg\\s-NickServ\\s-IDENTIFY\\s-\^_password"
"NickServ@services.slashnet.org"
"IDENTIFY" nil nil nil))
"Alist of NickServer details, sorted by network.
@@ -312,26 +312,33 @@ The last two elements are optional."
(const :tag "Do not try to detect success" nil)))))
-(defsubst erc-nickserv-alist-sender (network &optional entry)
- (nth 1 (or entry (assoc network erc-nickserv-alist))))
+(define-inline erc-nickserv-alist-sender (network &optional entry)
+ (inline-letevals (network entry)
+ (inline-quote (nth 1 (or ,entry (assoc ,network erc-nickserv-alist))))))
-(defsubst erc-nickserv-alist-regexp (network &optional entry)
- (nth 2 (or entry (assoc network erc-nickserv-alist))))
+(define-inline erc-nickserv-alist-regexp (network &optional entry)
+ (inline-letevals (network entry)
+ (inline-quote (nth 2 (or ,entry (assoc ,network erc-nickserv-alist))))))
-(defsubst erc-nickserv-alist-nickserv (network &optional entry)
- (nth 3 (or entry (assoc network erc-nickserv-alist))))
+(define-inline erc-nickserv-alist-nickserv (network &optional entry)
+ (inline-letevals (network entry)
+ (inline-quote (nth 3 (or ,entry (assoc ,network erc-nickserv-alist))))))
-(defsubst erc-nickserv-alist-ident-keyword (network &optional entry)
- (nth 4 (or entry (assoc network erc-nickserv-alist))))
+(define-inline erc-nickserv-alist-ident-keyword (network &optional entry)
+ (inline-letevals (network entry)
+ (inline-quote (nth 4 (or ,entry (assoc ,network erc-nickserv-alist))))))
-(defsubst erc-nickserv-alist-use-nick-p (network &optional entry)
- (nth 5 (or entry (assoc network erc-nickserv-alist))))
+(define-inline erc-nickserv-alist-use-nick-p (network &optional entry)
+ (inline-letevals (network entry)
+ (inline-quote (nth 5 (or ,entry (assoc ,network erc-nickserv-alist))))))
-(defsubst erc-nickserv-alist-ident-command (network &optional entry)
- (nth 6 (or entry (assoc network erc-nickserv-alist))))
+(define-inline erc-nickserv-alist-ident-command (network &optional entry)
+ (inline-letevals (network entry)
+ (inline-quote (nth 6 (or ,entry (assoc ,network erc-nickserv-alist))))))
-(defsubst erc-nickserv-alist-identified-regexp (network &optional entry)
- (nth 7 (or entry (assoc network erc-nickserv-alist))))
+(define-inline erc-nickserv-alist-identified-regexp (network &optional entry)
+ (inline-letevals (network entry)
+ (inline-quote (nth 7 (or ,entry (assoc ,network erc-nickserv-alist))))))
;; Functions:
@@ -341,7 +348,7 @@ Hooks are called with arguments (NETWORK NICK)."
:group 'erc-services
:type 'hook)
-(defun erc-nickserv-identification-autodetect (proc parsed)
+(defun erc-nickserv-identification-autodetect (_proc parsed)
"Check for NickServ's successful identification notice.
Make sure it is the real NickServ for this network and that it has
specifically confirmed a successful identification attempt.
@@ -361,7 +368,7 @@ If this is the case, run `erc-nickserv-identified-hook'."
(run-hook-with-args 'erc-nickserv-identified-hook network nick)
nil)))
-(defun erc-nickserv-identify-autodetect (proc parsed)
+(defun erc-nickserv-identify-autodetect (_proc parsed)
"Identify to NickServ when an identify request is received.
Make sure it is the real NickServ for this network.
If `erc-prompt-for-nickserv-password' is non-nil, prompt the user for the
@@ -383,7 +390,7 @@ password for this nickname, otherwise try to send it automatically."
(erc-nickserv-call-identify-function nick)
nil))))
-(defun erc-nickserv-identify-on-connect (server nick)
+(defun erc-nickserv-identify-on-connect (_server nick)
"Identify to Nickserv after the connection to the server is established."
(unless (or (and (null erc-nickserv-passwords)
(null erc-prompt-for-nickserv-password))
@@ -391,7 +398,7 @@ password for this nickname, otherwise try to send it automatically."
(erc-nickserv-alist-regexp (erc-network))))
(erc-nickserv-call-identify-function nick)))
-(defun erc-nickserv-identify-on-nick-change (nick old-nick)
+(defun erc-nickserv-identify-on-nick-change (nick _old-nick)
"Identify to Nickserv whenever your nick changes."
(unless (or (and (null erc-nickserv-passwords)
(null erc-prompt-for-nickserv-password))
@@ -400,9 +407,9 @@ password for this nickname, otherwise try to send it automatically."
(erc-nickserv-call-identify-function nick)))
(defun erc-nickserv-call-identify-function (nickname)
- "Call `erc-nickserv-identify' interactively or run it with NICKNAME's
-password.
-The action is determined by the value of `erc-prompt-for-nickserv-password'."
+ "Call `erc-nickserv-identify'.
+Either call it interactively or run it with NICKNAME's password,
+depending on the value of `erc-prompt-for-nickserv-password'."
(if erc-prompt-for-nickserv-password
(call-interactively 'erc-nickserv-identify)
(when erc-nickserv-passwords
@@ -411,6 +418,8 @@ The action is determined by the value of `erc-prompt-for-nickserv-password'."
(nth 1 (assoc (erc-network)
erc-nickserv-passwords))))))))
+(defvar erc-auto-discard-away)
+
;;;###autoload
(defun erc-nickserv-identify (password)
"Send an \"identify <PASSWORD>\" message to NickServ.
@@ -444,6 +453,7 @@ When called interactively, read the password using `read-passwd'."
;;; erc-services.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc-sound.el b/lisp/erc/erc-sound.el
index 984ff49d43f..34f7ce62c74 100644
--- a/lisp/erc/erc-sound.el
+++ b/lisp/erc/erc-sound.el
@@ -46,7 +46,7 @@
(require 'erc)
-;;;###autoload (autoload 'erc-sound-mode "erc-sound")
+;;;###autoload(autoload 'erc-sound-mode "erc-sound")
(define-erc-module sound ctcp-sound
"In ERC sound mode, the client will respond to CTCP SOUND requests
and play sound files as requested."
@@ -145,6 +145,7 @@ See also `play-sound-file'."
;;; erc-sound.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el
index 0324383300b..0a1e38fe248 100644
--- a/lisp/erc/erc-speedbar.el
+++ b/lisp/erc/erc-speedbar.el
@@ -140,7 +140,7 @@ This will add a speedbar major display mode."
t))))
(defun erc-speedbar-expand-server (text server indent)
- (cond ((string-match "+" text)
+ (cond ((string-match "\\+" text)
(speedbar-change-expand-button-char ?-)
(if (speedbar-with-writable
(save-excursion
@@ -185,7 +185,7 @@ This will add a speedbar major display mode."
"For the line matching TEXT, in CHANNEL, expand or contract a line.
INDENT is the current indentation level."
(cond
- ((string-match "+" text)
+ ((string-match "\\+" text)
(speedbar-change-expand-button-char ?-)
(speedbar-with-writable
(save-excursion
@@ -285,7 +285,7 @@ is only done when the channel is actually expanded already."
(erc-speedbar-expand-channel "+" buffer 1)))))
(defun erc-speedbar-expand-user (text token indent)
- (cond ((string-match "+" text)
+ (cond ((string-match "\\+" text)
(speedbar-change-expand-button-char ?-)
(speedbar-with-writable
(save-excursion
@@ -361,6 +361,7 @@ The INDENT level is ignored."
;;; erc-speedbar.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc-spelling.el b/lisp/erc/erc-spelling.el
index cc519b28da5..69a83fa032b 100644
--- a/lisp/erc/erc-spelling.el
+++ b/lisp/erc/erc-spelling.el
@@ -33,7 +33,7 @@
(require 'erc)
(require 'flyspell)
-;;;###autoload (autoload 'erc-spelling-mode "erc-spelling" nil t)
+;;;###autoload(autoload 'erc-spelling-mode "erc-spelling" nil t)
(define-erc-module spelling nil
"Enable flyspell mode in ERC buffers."
;; Use erc-connect-pre-hook instead of erc-mode-hook as pre-hook is
@@ -109,3 +109,7 @@ The cadr is the beginning and the caddr is the end."
(provide 'erc-spelling)
;;; erc-spelling.el ends here
+
+;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
+;; End:
diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el
index 4495883734f..860fdbb77ce 100644
--- a/lisp/erc/erc-stamp.el
+++ b/lisp/erc/erc-stamp.el
@@ -158,7 +158,7 @@ from entering them and instead jump over them."
"ERC timestamp face."
:group 'erc-faces)
-;;;###autoload (autoload 'erc-timestamp-mode "erc-stamp" nil t)
+;;;###autoload(autoload 'erc-timestamp-mode "erc-stamp" nil t)
(define-erc-module stamp timestamp
"This mode timestamps messages in the channel buffers."
((add-hook 'erc-mode-hook #'erc-munge-invisibility-spec)
@@ -417,6 +417,7 @@ enabled when the message was inserted."
;;; erc-stamp.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el
index d53668e2666..e51e6056fb9 100644
--- a/lisp/erc/erc-track.el
+++ b/lisp/erc/erc-track.el
@@ -495,9 +495,6 @@ START is the minimum length of the name used."
;;;###autoload
(define-minor-mode erc-track-minor-mode
"Toggle mode line display of ERC activity (ERC Track minor mode).
-With a prefix argument ARG, enable ERC Track minor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
ERC Track minor mode is a global minor mode. It exists for the
sole purpose of providing the C-c C-SPC and C-c C-@ keybindings.
@@ -542,7 +539,7 @@ keybindings will not do anything useful."
;;; Module
-;;;###autoload (autoload 'erc-track-mode "erc-track" nil t)
+;;;###autoload(autoload 'erc-track-mode "erc-track" nil t)
(define-erc-module track nil
"This mode tracks ERC channel buffers with activity."
;; Enable:
@@ -633,8 +630,8 @@ only consider active buffers visible.")
(if erc-track-when-inactive
(when erc-buffer-activity; could be nil
(and (erc-track-get-buffer-window buffer erc-track-visibility)
- (<= (erc-time-diff erc-buffer-activity (erc-current-time))
- erc-buffer-activity-timeout)))
+ (not (time-less-p erc-buffer-activity-timeout
+ (erc-time-diff erc-buffer-activity nil)))))
(erc-track-get-buffer-window buffer erc-track-visibility)))
;;; Tracking the channel modifications
@@ -643,7 +640,7 @@ only consider active buffers visible.")
(unless (minibuffer-window-active-p (minibuffer-window))
;; delay this until command has finished to make sure window is
;; actually visible before clearing activity
- (add-hook 'post-command-hook 'erc-modified-channels-update)))
+ (erc-modified-channels-update)))
(defvar erc-modified-channels-update-inside nil
"Variable to prevent running `erc-modified-channels-update' multiple
@@ -672,8 +669,7 @@ ARGS are ignored."
(erc-modified-channels-remove-buffer buffer))))
erc-modified-channels-alist)
(when removed-channel
- (erc-modified-channels-display)))
- (remove-hook 'post-command-hook 'erc-modified-channels-update)))
+ (erc-modified-channels-display)))))
(defvar erc-track-mouse-face (if (featurep 'xemacs)
'modeline-mousable
@@ -932,14 +928,14 @@ relative to `erc-track-switch-direction'"
offset)
(when (< arg 0)
(setq dir (pcase dir
- (`oldest 'newest)
- (`newest 'oldest)
- (`mostactive 'leastactive)
- (`leastactive 'mostactive)
- (`importance 'oldest)))
+ ('oldest 'newest)
+ ('newest 'oldest)
+ ('mostactive 'leastactive)
+ ('leastactive 'mostactive)
+ ('importance 'oldest)))
(setq arg (- arg)))
(setq offset (pcase dir
- ((or `oldest `leastactive)
+ ((or 'oldest 'leastactive)
(- (length erc-modified-channels-alist) arg))
(_ (1- arg))))
;; normalize out of range user input
@@ -974,6 +970,7 @@ switch back to the last non-ERC buffer visited. Next is defined by
;;; erc-track.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc-truncate.el b/lisp/erc/erc-truncate.el
index 7ff99c8dc4f..04174295520 100644
--- a/lisp/erc/erc-truncate.el
+++ b/lisp/erc/erc-truncate.el
@@ -43,7 +43,7 @@ Used only when auto-truncation is enabled.
:group 'erc-truncate
:type 'integer)
-;;;###autoload (autoload 'erc-truncate-mode "erc-truncate" nil t)
+;;;###autoload(autoload 'erc-truncate-mode "erc-truncate" nil t)
(define-erc-module truncate nil
"Truncate a query buffer if it gets too large.
This prevents the query buffer from getting too large, which can
@@ -112,6 +112,7 @@ Meant to be used in hooks, like `erc-insert-post-hook'."
;;; erc-truncate.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc-xdcc.el b/lisp/erc/erc-xdcc.el
index 07e7ac1be16..162b22e15c6 100644
--- a/lisp/erc/erc-xdcc.el
+++ b/lisp/erc/erc-xdcc.el
@@ -61,7 +61,7 @@ being evaluated and should return strings."
:group 'erc-dcc
:type '(repeat (repeat :tag "Message" (choice string sexp))))
-;;;###autoload (autoload 'erc-xdcc-mode "erc-xdcc")
+;;;###autoload(autoload 'erc-xdcc-mode "erc-xdcc")
(define-erc-module xdcc nil
"Act as an XDCC file-server."
nil nil)
@@ -133,6 +133,7 @@ being evaluated and should return strings."
;;; erc-xdcc.el ends here
;;
;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index feee89d7fea..d1fa5c7f120 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -62,17 +62,17 @@
;;; History:
;;
-(defconst erc-version-string (format "\C-bERC\C-b (IRC client for Emacs %s)" emacs-version)
- "ERC version. This is used by function `erc-version'.")
-
;;; Code:
+(load "erc-loaddefs" nil t)
+
(eval-when-compile (require 'cl-lib))
(require 'font-lock)
(require 'pp)
(require 'thingatpt)
(require 'auth-source)
(require 'erc-compat)
+(eval-when-compile (require 'subr-x))
(defvar erc-official-location
"https://www.emacswiki.org/emacs/ERC (mailing list: erc-discuss@gnu.org)"
@@ -399,25 +399,28 @@ If no server buffer exists, return nil."
;; This is useful for ordered name completion.
(last-message-time nil))
-(defsubst erc-get-channel-user (nick)
+(define-inline erc-get-channel-user (nick)
"Find the (USER . CHANNEL-DATA) element corresponding to NICK
in the current buffer's `erc-channel-users' hash table."
- (gethash (erc-downcase nick) erc-channel-users))
+ (inline-quote (gethash (erc-downcase ,nick) erc-channel-users)))
-(defsubst erc-get-server-user (nick)
+(define-inline erc-get-server-user (nick)
"Find the USER corresponding to NICK in the current server's
`erc-server-users' hash table."
- (erc-with-server-buffer
- (gethash (erc-downcase nick) erc-server-users)))
+ (inline-letevals (nick)
+ (inline-quote (erc-with-server-buffer
+ (gethash (erc-downcase ,nick) erc-server-users)))))
-(defsubst erc-add-server-user (nick user)
+(define-inline erc-add-server-user (nick user)
"This function is for internal use only.
Adds USER with nickname NICK to the `erc-server-users' hash table."
- (erc-with-server-buffer
- (puthash (erc-downcase nick) user erc-server-users)))
+ (inline-letevals (nick user)
+ (inline-quote
+ (erc-with-server-buffer
+ (puthash (erc-downcase ,nick) ,user erc-server-users)))))
-(defsubst erc-remove-server-user (nick)
+(define-inline erc-remove-server-user (nick)
"This function is for internal use only.
Removes the user with nickname NICK from the `erc-server-users'
@@ -425,8 +428,10 @@ hash table. This user is not removed from the
`erc-channel-users' lists of other buffers.
See also: `erc-remove-user'."
- (erc-with-server-buffer
- (remhash (erc-downcase nick) erc-server-users)))
+ (inline-letevals (nick)
+ (inline-quote
+ (erc-with-server-buffer
+ (remhash (erc-downcase ,nick) erc-server-users)))))
(defun erc-change-user-nickname (user new-nick)
"This function is for internal use only.
@@ -497,45 +502,55 @@ Removes all users in the current channel. This is called by
erc-channel-users)
(clrhash erc-channel-users)))
-(defsubst erc-channel-user-owner-p (nick)
+(define-inline erc-channel-user-owner-p (nick)
"Return non-nil if NICK is an owner of the current channel."
- (and nick
- (hash-table-p erc-channel-users)
- (let ((cdata (erc-get-channel-user nick)))
- (and cdata (cdr cdata)
- (erc-channel-user-owner (cdr cdata))))))
-
-(defsubst erc-channel-user-admin-p (nick)
+ (inline-letevals (nick)
+ (inline-quote
+ (and ,nick
+ (hash-table-p erc-channel-users)
+ (let ((cdata (erc-get-channel-user ,nick)))
+ (and cdata (cdr cdata)
+ (erc-channel-user-owner (cdr cdata))))))))
+
+(define-inline erc-channel-user-admin-p (nick)
"Return non-nil if NICK is an admin in the current channel."
- (and nick
+ (inline-letevals (nick)
+ (inline-quote
+ (and ,nick
(hash-table-p erc-channel-users)
- (let ((cdata (erc-get-channel-user nick)))
+ (let ((cdata (erc-get-channel-user ,nick)))
(and cdata (cdr cdata)
- (erc-channel-user-admin (cdr cdata))))))
+ (erc-channel-user-admin (cdr cdata))))))))
-(defsubst erc-channel-user-op-p (nick)
+(define-inline erc-channel-user-op-p (nick)
"Return non-nil if NICK is an operator in the current channel."
- (and nick
+ (inline-letevals (nick)
+ (inline-quote
+ (and ,nick
(hash-table-p erc-channel-users)
- (let ((cdata (erc-get-channel-user nick)))
+ (let ((cdata (erc-get-channel-user ,nick)))
(and cdata (cdr cdata)
- (erc-channel-user-op (cdr cdata))))))
+ (erc-channel-user-op (cdr cdata))))))))
-(defsubst erc-channel-user-halfop-p (nick)
+(define-inline erc-channel-user-halfop-p (nick)
"Return non-nil if NICK is a half-operator in the current channel."
- (and nick
+ (inline-letevals (nick)
+ (inline-quote
+ (and ,nick
(hash-table-p erc-channel-users)
- (let ((cdata (erc-get-channel-user nick)))
+ (let ((cdata (erc-get-channel-user ,nick)))
(and cdata (cdr cdata)
- (erc-channel-user-halfop (cdr cdata))))))
+ (erc-channel-user-halfop (cdr cdata))))))))
-(defsubst erc-channel-user-voice-p (nick)
+(define-inline erc-channel-user-voice-p (nick)
"Return non-nil if NICK has voice in the current channel."
- (and nick
+ (inline-letevals (nick)
+ (inline-quote
+ (and ,nick
(hash-table-p erc-channel-users)
- (let ((cdata (erc-get-channel-user nick)))
+ (let ((cdata (erc-get-channel-user ,nick)))
(and cdata (cdr cdata)
- (erc-channel-user-voice (cdr cdata))))))
+ (erc-channel-user-voice (cdr cdata))))))))
(defun erc-get-channel-user-list ()
"Return a list of users in the current channel. Each element
@@ -1260,7 +1275,7 @@ erc-NAME-enable, and erc-NAME-disable.
Example:
- ;;;###autoload (autoload \\='erc-replace-mode \"erc-replace\")
+ ;;;###autoload(autoload \\='erc-replace-mode \"erc-replace\")
(define-erc-module replace nil
\"This mode replaces incoming text according to `erc-replace-alist'.\"
((add-hook \\='erc-insert-modify-hook
@@ -1343,10 +1358,11 @@ capabilities."
(add-hook hook fun nil t)
fun))
-(defsubst erc-log (string)
+(define-inline erc-log (string)
"Logs STRING if logging is on (see `erc-log-p')."
- (when erc-log-p
- (erc-log-aux string)))
+ (inline-quote
+ (when erc-log-p
+ (erc-log-aux ,string))))
(defun erc-server-buffer ()
"Return the server buffer for the current buffer's process.
@@ -1590,18 +1606,18 @@ symbol, it may have these values:
(dolist (candidate (list buf-name (concat buf-name "/" server)))
(if (and (not buffer-name)
erc-reuse-buffers
- (get-buffer candidate)
- (or target
+ (or (not (get-buffer candidate))
+ (or target
+ (with-current-buffer (get-buffer candidate)
+ (and (erc-server-buffer-p)
+ (not (erc-server-process-alive)))))
(with-current-buffer (get-buffer candidate)
- (and (erc-server-buffer-p)
- (not (erc-server-process-alive)))))
- (with-current-buffer (get-buffer candidate)
- (and (string= erc-session-server server)
- (erc-port-equal erc-session-port port))))
+ (and (string= erc-session-server server)
+ (erc-port-equal erc-session-port port)))))
(setq buffer-name candidate)))
;; if buffer-name is unset, neither candidate worked out for us,
;; fallback to the old <N> uniquification method:
- (or buffer-name (generate-new-buffer-name buf-name)) ))
+ (or buffer-name (generate-new-buffer-name (concat buf-name "/" server)))))
(defun erc-get-buffer-create (server port target)
"Create a new buffer based on the arguments."
@@ -1924,15 +1940,15 @@ removed from the list will be disabled."
(defun erc-setup-buffer (buffer)
"Consults `erc-join-buffer' to find out how to display `BUFFER'."
(pcase erc-join-buffer
- (`window
+ ('window
(if (active-minibuffer-window)
(display-buffer buffer)
(switch-to-buffer-other-window buffer)))
- (`window-noselect
+ ('window-noselect
(display-buffer buffer))
- (`bury
+ ('bury
nil)
- (`frame
+ ('frame
(when (or (not erc-reuse-frames)
(not (get-buffer-window buffer t)))
(let ((frame (make-frame (or erc-frame-alist
@@ -2506,10 +2522,7 @@ Returns NICK unmodified unless `erc-lurker-trim-nicks' is
non-nil."
(if erc-lurker-trim-nicks
(replace-regexp-in-string
- (format "[%s]"
- (mapconcat (lambda (char)
- (regexp-quote (char-to-string char)))
- erc-lurker-ignore-chars ""))
+ (regexp-opt-charset (string-to-list erc-lurker-ignore-chars))
"" nick)
nick))
@@ -2549,10 +2562,8 @@ consumption for long-lived IRC or Emacs sessions."
(maphash
(lambda (nick last-PRIVMSG-time)
(when
- (> (float-time (time-subtract
- (current-time)
- last-PRIVMSG-time))
- erc-lurker-threshold-time)
+ (time-less-p erc-lurker-threshold-time
+ (time-since last-PRIVMSG-time))
(remhash nick hash)))
hash)
(if (zerop (hash-table-count hash))
@@ -2617,9 +2628,8 @@ server within `erc-lurker-threshold-time'. See also
(gethash (erc-lurker-maybe-trim nick)
(gethash server erc-lurker-state (make-hash-table)))))
(or (null last-PRIVMSG-time)
- (> (float-time
- (time-subtract (current-time) last-PRIVMSG-time))
- erc-lurker-threshold-time))))
+ (time-less-p erc-lurker-threshold-time
+ (time-since last-PRIVMSG-time)))))
(defcustom erc-common-server-suffixes
'(("openprojects.net\\'" . "OPN")
@@ -3398,7 +3408,7 @@ Otherwise leave the channel indicated by LINE."
(defun erc-cmd-PING (recipient)
"Ping RECIPIENT."
- (let ((time (format "%f" (erc-current-time))))
+ (let ((time (format-time-string "%s.%6N")))
(erc-log (format "cmd: PING: %s" time))
(erc-cmd-CTCP recipient "PING" time)))
@@ -3677,8 +3687,10 @@ be displayed."
((string-match "^\\s-*\\([&#+!]\\S-+\\)\\s-\\(.*\\)$" topic)
(let ((ch (match-string 1 topic))
(topic (match-string 2 topic)))
- (erc-log (format "cmd: TOPIC [%s]: %s" ch topic))
- (erc-server-send (format "TOPIC %s :%s" ch topic) nil ch))
+ ;; Ignore all-whitespace topics.
+ (unless (equal (string-trim topic) "")
+ (erc-log (format "cmd: TOPIC [%s]: %s" ch topic))
+ (erc-server-send (format "TOPIC %s :%s" ch topic) nil ch)))
t)
;; /topic #channel
((string-match "^\\s-*\\([&#+!]\\S-+\\)" topic)
@@ -4270,7 +4282,7 @@ and as second argument the event parsed as a vector."
(defun erc-is-message-ctcp-and-not-action-p (message)
"Check if MESSAGE is a CTCP message or not."
(and (erc-is-message-ctcp-p message)
- (not (string-match "^\C-a\\ACTION.*\C-a$" message))))
+ (not (string-match "^\C-aACTION.*\C-a$" message))))
(defun erc-format-privmessage (nick msg privp msgp)
"Format a PRIVMSG in an insertable fashion."
@@ -4476,7 +4488,7 @@ See also: `erc-echo-notice-in-user-buffers',
(mapcar #'upcase
(cdr (split-string mode)))))
erc-channel-banlist)))
- ((string-match "^+" mode)
+ ((string-match "^\\+" mode)
;; Add the banned mask(s) to the ban list
(mapc
(lambda (mask)
@@ -4624,7 +4636,7 @@ See also `erc-display-message'."
(user-full-name)
(user-login-name)
(system-name))))
- (ns (erc-time-diff erc-server-last-sent-time (erc-current-time))))
+ (ns (erc-time-diff erc-server-last-sent-time nil)))
(when (> ns 0)
(setq s (concat s " Idle for " (erc-sec-to-time ns))))
(erc-send-ctcp-notice nick s)))
@@ -4713,8 +4725,7 @@ See also `erc-display-message'."
nil
(let ((time (match-string 1 msg)))
(condition-case nil
- (let ((delta (erc-time-diff (string-to-number time)
- (erc-current-time))))
+ (let ((delta (erc-time-diff (string-to-number time) nil)))
(erc-display-message
nil 'notice 'active
'CTCP-PING ?n nick
@@ -4772,10 +4783,7 @@ If non-nil, return from being away."
(erc-default-target)
(if away-time
(format "is back (gone for %s)"
- (erc-sec-to-time
- (erc-time-diff
- (erc-emacs-time-to-erc-time away-time)
- (erc-current-time))))
+ (erc-sec-to-time (erc-time-diff away-time nil)))
"is back")))))))))
(erc-update-mode-line)))
@@ -5367,10 +5375,10 @@ submitted line to be intentional."
(defun erc-send-current-line ()
"Parse current line and send it to IRC."
(interactive)
- (let ((now (float-time)))
+ (let ((now (current-time)))
(if (or (not erc-accidental-paste-threshold-seconds)
- (< erc-accidental-paste-threshold-seconds
- (- now erc-last-input-time)))
+ (time-less-p erc-accidental-paste-threshold-seconds
+ (time-subtract now erc-last-input-time)))
(save-restriction
(widen)
(if (< (point) (erc-beg-of-input-line))
@@ -6020,23 +6028,20 @@ non-nil value is found.
;; time routines
-(defun erc-string-to-emacs-time (string)
- "Convert the long number represented by STRING into an Emacs format.
-Returns a list of the form (HIGH LOW), compatible with Emacs time format."
- (let* ((n (string-to-number (concat string ".0"))))
- (list (truncate (/ n 65536))
- (truncate (mod n 65536)))))
+(define-obsolete-function-alias 'erc-string-to-emacs-time 'string-to-number
+ "27.1")
(defalias 'erc-emacs-time-to-erc-time 'float-time)
(defalias 'erc-current-time 'float-time)
(defun erc-time-diff (t1 t2)
- "Return the time difference in seconds between T1 and T2."
- (abs (- t2 t1)))
+ "Return the absolute value of the difference in seconds between T1 and T2."
+ (abs (float-time (time-subtract t1 t2))))
(defun erc-time-gt (t1 t2)
"Check whether T1 > T2."
- (> t1 t2))
+ (declare (obsolete time-less-p "27.1"))
+ (time-less-p t2 t1))
(defun erc-sec-to-time (ns)
"Convert NS to a time string HH:MM.SS."
diff --git a/lisp/eshell/em-alias.el b/lisp/eshell/em-alias.el
index dbffd52aa76..c465d464d6a 100644
--- a/lisp/eshell/em-alias.el
+++ b/lisp/eshell/em-alias.el
@@ -90,7 +90,7 @@
;;; Code:
-(require 'eshell)
+(require 'esh-mode)
;;;###autoload
(progn
@@ -141,12 +141,12 @@ file named by `eshell-aliases-file'.")
(defvar eshell-failed-commands-alist nil
"An alist of command name failures.")
-(defun eshell-alias-initialize ()
+(defun eshell-alias-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the alias handling code."
(make-local-variable 'eshell-failed-commands-alist)
- (add-hook 'eshell-alternate-command-hook 'eshell-fix-bad-commands t t)
+ (add-hook 'eshell-alternate-command-hook #'eshell-fix-bad-commands t t)
(eshell-read-aliases-list)
- (add-hook 'eshell-named-command-hook 'eshell-maybe-replace-by-alias t t)
+ (add-hook 'eshell-named-command-hook #'eshell-maybe-replace-by-alias t t)
(make-local-variable 'eshell-complex-commands)
(add-to-list 'eshell-complex-commands 'eshell-command-aliased-p))
diff --git a/lisp/eshell/em-banner.el b/lisp/eshell/em-banner.el
index 4a0b265ae0e..c284c1bd70d 100644
--- a/lisp/eshell/em-banner.el
+++ b/lisp/eshell/em-banner.el
@@ -71,7 +71,7 @@ This can be any sexp, and should end with at least two newlines."
:type 'hook
:group 'eshell-banner)
-(defun eshell-banner-initialize ()
+(defun eshell-banner-initialize () ;Called from `eshell-mode' via intern-soft!
"Output a welcome banner on initialization."
;; it's important to use `eshell-interactive-print' rather than
;; `insert', because `insert' doesn't know how to interact with the
diff --git a/lisp/eshell/em-basic.el b/lisp/eshell/em-basic.el
index 346fb1c17b0..72a4e6bf801 100644
--- a/lisp/eshell/em-basic.el
+++ b/lisp/eshell/em-basic.el
@@ -118,7 +118,7 @@ or `eshell-printn' for display."
(defun eshell/printnl (&rest args)
"Print out each of the arguments, separated by newlines."
- (let ((elems (eshell-flatten-list args)))
+ (let ((elems (flatten-tree args)))
(while elems
(eshell-printn (eshell-echo (list (car elems))))
(setq elems (cdr elems)))))
diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el
index f834882f7b6..e3bfd8d9d48 100644
--- a/lisp/eshell/em-cmpl.el
+++ b/lisp/eshell/em-cmpl.el
@@ -244,7 +244,7 @@ to writing a completion function."
(let ((completion-at-point-functions '(lisp-completion-at-point)))
(completion-at-point)))
-(defun eshell-cmpl-initialize ()
+(defun eshell-cmpl-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the completions module."
(set (make-local-variable 'pcomplete-command-completion-function)
eshell-command-completion-function)
@@ -262,8 +262,9 @@ to writing a completion function."
eshell-cmpl-ignore-case)
(set (make-local-variable 'pcomplete-autolist)
eshell-cmpl-autolist)
- (set (make-local-variable 'pcomplete-suffix-list)
- eshell-cmpl-suffix-list)
+ (if (boundp 'pcomplete-suffix-list)
+ (set (make-local-variable 'pcomplete-suffix-list)
+ eshell-cmpl-suffix-list))
(set (make-local-variable 'pcomplete-recexact)
eshell-cmpl-recexact)
(set (make-local-variable 'pcomplete-man-function)
@@ -287,9 +288,10 @@ to writing a completion function."
(function
(lambda ()
(set (make-local-variable 'comint-file-name-quote-list)
- eshell-special-chars-outside-quoting))) nil t)
- (add-hook 'pcomplete-quote-arg-hook 'eshell-quote-backslash nil t)
- (define-key eshell-mode-map [(meta tab)] 'eshell-complete-lisp-symbol)
+ eshell-special-chars-outside-quoting)))
+ nil t)
+ (add-hook 'pcomplete-quote-arg-hook #'eshell-quote-backslash nil t)
+ ;;(define-key eshell-mode-map [(meta tab)] 'eshell-complete-lisp-symbol) ; Redundant
(define-key eshell-mode-map [(meta control ?i)] 'eshell-complete-lisp-symbol)
(define-key eshell-command-map [(meta ?h)] 'eshell-completion-help)
(define-key eshell-command-map [tab] 'pcomplete-expand-and-complete)
@@ -297,15 +299,14 @@ to writing a completion function."
'pcomplete-expand-and-complete)
(define-key eshell-command-map [space] 'pcomplete-expand)
(define-key eshell-command-map [? ] 'pcomplete-expand)
- (define-key eshell-mode-map [tab] 'eshell-pcomplete)
- (define-key eshell-mode-map [(control ?i)] 'eshell-pcomplete)
+ ;;(define-key eshell-mode-map [tab] 'completion-at-point) ;Redundant!
+ (define-key eshell-mode-map [(control ?i)] 'completion-at-point)
(add-hook 'completion-at-point-functions
#'pcomplete-completions-at-point nil t)
;; jww (1999-10-19): Will this work on anything but X?
- (if (featurep 'xemacs)
- (define-key eshell-mode-map [iso-left-tab] 'pcomplete-reverse)
- (define-key eshell-mode-map [backtab] 'pcomplete-reverse))
- (define-key eshell-mode-map [(meta ??)] 'pcomplete-list))
+ (define-key eshell-mode-map
+ (if (featurep 'xemacs) [iso-left-tab] [backtab]) 'pcomplete-reverse)
+ (define-key eshell-mode-map [(meta ??)] 'completion-help-at-point))
(defun eshell-completion-command-name ()
"Return the command name, possibly sans globbing."
@@ -437,38 +438,28 @@ to writing a completion function."
(setq comps-in-path (cdr comps-in-path)))
(setq paths (cdr paths)))
;; Add aliases which are currently visible, and Lisp functions.
- (pcomplete-uniqify-list
+ (pcomplete-uniquify-list
(if glob-name
completions
(setq completions
- (append (and (eshell-using-module 'eshell-alias)
- (funcall (symbol-function 'eshell-alias-completions)
- filename))
+ (append (if (fboundp 'eshell-alias-completions)
+ (eshell-alias-completions filename))
(eshell-winnow-list
(mapcar
(function
(lambda (name)
(substring name 7)))
(all-completions (concat "eshell/" filename)
- obarray 'functionp))
+ obarray #'functionp))
nil '(eshell-find-alias-function))
completions))
(append (and (or eshell-show-lisp-completions
(and eshell-show-lisp-alternatives
(null completions)))
- (all-completions filename obarray 'functionp))
+ (all-completions filename obarray #'functionp))
completions)))))))
-(defun eshell-pcomplete (&optional interactively)
- "Eshell wrapper for `pcomplete'."
- (interactive "p")
- ;; Pretend to be pcomplete so that cycling works (bug#13293).
- (setq this-command 'pcomplete)
- (condition-case nil
- (if interactively
- (call-interactively 'pcomplete)
- (pcomplete))
- (text-read-only (completion-at-point)))) ; Workaround for bug#12838.
+(define-obsolete-function-alias 'eshell-pcomplete #'completion-at-point "27.1")
(provide 'em-cmpl)
diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el
index 4d8debb954f..c28fd72f45c 100644
--- a/lisp/eshell/em-dirs.el
+++ b/lisp/eshell/em-dirs.el
@@ -42,7 +42,8 @@
;;; Code:
-(require 'eshell)
+(require 'esh-mode) ;For eshell-directory-name
+(require 'esh-var) ;For eshell-variable-aliases-list
(require 'ring)
(require 'esh-opt)
@@ -62,12 +63,11 @@ they lack somewhat in feel from the typical shell equivalents."
(defcustom eshell-dirs-load-hook nil
"A hook that gets run when `eshell-dirs' is loaded."
:version "24.1" ; removed eshell-dirs-initialize
- :type 'hook
- :group 'eshell-dirs)
+ :type 'hook)
(defcustom eshell-pwd-convert-function (if (eshell-under-windows-p)
- 'expand-file-name
- 'identity)
+ #'expand-file-name
+ #'identity)
"The function used to normalize the value of Eshell's `pwd'.
The value returned by `pwd' is also used when recording the
last-visited directory in the last-dir-ring, so it will affect the
@@ -75,8 +75,7 @@ form of the list used by `cd ='."
:type '(radio (function-item file-truename)
(function-item expand-file-name)
(function-item identity)
- (function :tag "Other"))
- :group 'eshell-dirs)
+ (function :tag "Other")))
(defcustom eshell-ask-to-save-last-dir 'always
"Determine if the last-dir-ring should be automatically saved.
@@ -88,63 +87,53 @@ If set to t, always ask if any Eshell buffers are open at exit time.
If set to `always', the list-dir-ring will always be saved, silently."
:type '(choice (const :tag "Never" nil)
(const :tag "Ask" t)
- (const :tag "Always save" always))
- :group 'eshell-dirs)
+ (const :tag "Always save" always)))
(defcustom eshell-cd-shows-directory nil
"If non-nil, using `cd' will report the directory it changes to."
- :type 'boolean
- :group 'eshell-dirs)
+ :type 'boolean)
(defcustom eshell-cd-on-directory t
"If non-nil, do a cd if a directory is in command position."
- :type 'boolean
- :group 'eshell-dirs)
+ :type 'boolean)
(defcustom eshell-directory-change-hook nil
"A hook to run when the current directory changes."
- :type 'hook
- :group 'eshell-dirs)
+ :type 'hook)
(defcustom eshell-list-files-after-cd nil
"If non-nil, call \"ls\" with any remaining args after doing a cd.
This is provided for convenience, since the same effect is easily
achieved by adding a function to `eshell-directory-change-hook' that
calls \"ls\" and references `eshell-last-arguments'."
- :type 'boolean
- :group 'eshell-dirs)
+ :type 'boolean)
(defcustom eshell-pushd-tohome nil
"If non-nil, make pushd with no arg behave as `pushd ~' (like `cd').
This mirrors the optional behavior of tcsh."
- :type 'boolean
- :group 'eshell-dirs)
+ :type 'boolean)
(defcustom eshell-pushd-dextract nil
"If non-nil, make \"pushd +n\" pop the nth dir to the stack top.
This mirrors the optional behavior of tcsh."
- :type 'boolean
- :group 'eshell-dirs)
+ :type 'boolean)
(defcustom eshell-pushd-dunique nil
"If non-nil, make pushd only add unique directories to the stack.
This mirrors the optional behavior of tcsh."
- :type 'boolean
- :group 'eshell-dirs)
+ :type 'boolean)
(defcustom eshell-dirtrack-verbose t
"If non-nil, show the directory stack following directory change.
This is effective only if directory tracking is enabled."
- :type 'boolean
- :group 'eshell-dirs)
+ :type 'boolean)
(defcustom eshell-last-dir-ring-file-name
(expand-file-name "lastdir" eshell-directory-name)
"If non-nil, name of the file to read/write the last-dir-ring.
See also `eshell-read-last-dir-ring' and `eshell-write-last-dir-ring'.
If it is nil, the last-dir-ring will not be written to disk."
- :type 'file
- :group 'eshell-dirs)
+ :type 'file)
(defcustom eshell-last-dir-ring-size 32
"If non-nil, the size of the directory history ring.
@@ -164,13 +153,11 @@ directories gets pushed, and its size is unlimited.
explicitly very much, but every once in a while would like to return to
a previously visited directory without having to type in the whole
thing again."
- :type 'integer
- :group 'eshell-dirs)
+ :type 'integer)
(defcustom eshell-last-dir-unique t
"If non-nil, `eshell-last-dir-ring' contains only unique entries."
- :type 'boolean
- :group 'eshell-dirs)
+ :type 'boolean)
;;; Internal Variables:
@@ -183,44 +170,46 @@ Thus, this does not include the current directory.")
;;; Functions:
-(defun eshell-dirs-initialize ()
+(defun eshell-dirs-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the builtin functions for Eshell."
(make-local-variable 'eshell-variable-aliases-list)
(setq eshell-variable-aliases-list
(append
eshell-variable-aliases-list
- '(("-" (lambda (indices)
- (if (not indices)
- (unless (ring-empty-p eshell-last-dir-ring)
- (expand-file-name
- (ring-ref eshell-last-dir-ring 0)))
- (expand-file-name
- (eshell-apply-indices eshell-last-dir-ring indices)))))
- ("+" "PWD")
- ("PWD" (lambda (indices)
- (expand-file-name (eshell/pwd))) t)
- ("OLDPWD" (lambda (indices)
+ `(("-" ,(lambda (indices)
+ (if (not indices)
(unless (ring-empty-p eshell-last-dir-ring)
(expand-file-name
- (ring-ref eshell-last-dir-ring 0)))) t))))
+ (ring-ref eshell-last-dir-ring 0)))
+ (expand-file-name
+ (eshell-apply-indices eshell-last-dir-ring indices)))))
+ ("+" "PWD")
+ ("PWD" ,(lambda (_indices)
+ (expand-file-name (eshell/pwd)))
+ t)
+ ("OLDPWD" ,(lambda (_indices)
+ (unless (ring-empty-p eshell-last-dir-ring)
+ (expand-file-name
+ (ring-ref eshell-last-dir-ring 0))))
+ t))))
(when eshell-cd-on-directory
(make-local-variable 'eshell-interpreter-alist)
(setq eshell-interpreter-alist
- (cons (cons #'(lambda (file args)
+ (cons (cons #'(lambda (file _args)
(eshell-lone-directory-p file))
'eshell-dirs-substitute-cd)
eshell-interpreter-alist)))
(add-hook 'eshell-parse-argument-hook
- 'eshell-parse-user-reference nil t)
+ #'eshell-parse-user-reference nil t)
(if (eshell-under-windows-p)
(add-hook 'eshell-parse-argument-hook
- 'eshell-parse-drive-letter nil t))
+ #'eshell-parse-drive-letter nil t))
(when (eshell-using-module 'eshell-cmpl)
(add-hook 'pcomplete-try-first-hook
- 'eshell-complete-user-reference nil t))
+ #'eshell-complete-user-reference nil t))
(make-local-variable 'eshell-dirstack)
(make-local-variable 'eshell-last-dir-ring)
@@ -230,9 +219,9 @@ Thus, this does not include the current directory.")
(unless eshell-last-dir-ring
(setq eshell-last-dir-ring (make-ring eshell-last-dir-ring-size)))
- (add-hook 'eshell-exit-hook 'eshell-write-last-dir-ring nil t)
+ (add-hook 'eshell-exit-hook #'eshell-write-last-dir-ring nil t)
- (add-hook 'kill-emacs-hook 'eshell-save-some-last-dir))
+ (add-hook 'kill-emacs-hook #'eshell-save-some-last-dir))
(defun eshell-save-some-last-dir ()
"Save the list-dir-ring for any open Eshell buffers."
@@ -259,7 +248,7 @@ Thus, this does not include the current directory.")
(if (> (length args) 1)
(error "%s: command not found" (car args))
(throw 'eshell-replace-command
- (eshell-parse-command "cd" (eshell-flatten-list args)))))
+ (eshell-parse-command "cd" (flatten-tree args)))))
(defun eshell-parse-user-reference ()
"An argument beginning with ~ is a filename to be expanded."
@@ -272,7 +261,7 @@ Thus, this does not include the current directory.")
(defun eshell-parse-drive-letter ()
"An argument beginning with X:[^/] is a drive letter reference."
(when (and (not eshell-current-argument)
- (looking-at "\\([A-Za-z]:\\)\\([^/\\\\]\\|\\'\\)"))
+ (looking-at "\\([A-Za-z]:\\)\\([^/\\]\\|\\'\\)"))
(goto-char (match-end 1))
(let* ((letter (match-string 1))
(regexp (concat "\\`" letter))
@@ -282,7 +271,7 @@ Thus, this does not include the current directory.")
(defvar pcomplete-stub)
(defvar pcomplete-last-completion-raw)
(declare-function pcomplete-actual-arg "pcomplete")
-(declare-function pcomplete-uniqify-list "pcomplete")
+(declare-function pcomplete-uniquify-list "pcomplete")
(defun eshell-complete-user-reference ()
"If there is a user reference, complete it."
@@ -293,47 +282,48 @@ Thus, this does not include the current directory.")
(throw 'pcomplete-completions
(progn
(eshell-read-user-names)
- (pcomplete-uniqify-list
+ (pcomplete-uniquify-list
(mapcar
(function
(lambda (user)
(file-name-as-directory (cdr user))))
eshell-user-names)))))))
-(defun eshell/pwd (&rest args)
+(defun eshell/pwd (&rest _args)
"Change output from `pwd' to be cleaner."
(let* ((path default-directory)
(len (length path)))
(if (and (> len 1)
(eq (aref path (1- len)) ?/)
(not (and (eshell-under-windows-p)
- (string-match "\\`[A-Za-z]:[\\\\/]\\'" path))))
+ (string-match "\\`[A-Za-z]:[\\/]\\'" path))))
(setq path (substring path 0 (1- (length path)))))
- (if eshell-pwd-convert-function
- (funcall eshell-pwd-convert-function path)
- path)))
+ (funcall (or eshell-pwd-convert-function #'identity) path)))
-(defun eshell-expand-multiple-dots (path)
+(defun eshell-expand-multiple-dots (filename)
+ ;; FIXME: This advice recommendation is rather odd: it's somewhat
+ ;; dangerous and it claims not to work with minibuffer-completion, which
+ ;; makes it much less interesting.
"Convert `...' to `../..', `....' to `../../..', etc..
With the following piece of advice, you can make this functionality
available in most of Emacs, with the exception of filename completion
in the minibuffer:
- (defadvice expand-file-name
- (before translate-multiple-dots
- (filename &optional directory) activate)
- (setq filename (eshell-expand-multiple-dots filename)))"
- (while (string-match "\\(?:^\\|/\\)\\.\\.\\(\\.+\\)\\(?:$\\|/\\)" path)
- (let* ((extra-dots (match-string 1 path))
+ (advice-add 'expand-file-name :around #'my-expand-multiple-dots)
+ (defun my-expand-multiple-dots (orig-fun filename &rest args)
+ (apply orig-fun (eshell-expand-multiple-dots filename) args))"
+ (while (string-match "\\(?:\\`\\|/\\)\\.\\.\\(\\.+\\)\\(?:\\'\\|/\\)"
+ filename)
+ (let* ((extra-dots (match-string 1 filename))
(len (length extra-dots))
replace-text)
(while (> len 0)
(setq replace-text (concat replace-text "/..")
len (1- len)))
- (setq path
- (replace-match replace-text t t path 1))))
- path)
+ (setq filename
+ (replace-match replace-text t t filename 1))))
+ filename)
(defun eshell-find-previous-directory (regexp)
"Find the most recent last-dir matching REGEXP."
@@ -351,7 +341,7 @@ in the minibuffer:
(defun eshell/cd (&rest args) ; all but first ignored
"Alias to extend the behavior of `cd'."
- (setq args (eshell-flatten-list args))
+ (setq args (flatten-tree args))
(let ((path (car args))
(subpath (car (cdr args)))
(case-fold-search (eshell-under-windows-p))
@@ -550,15 +540,16 @@ in the minibuffer:
(defun eshell-write-last-dir-ring ()
"Write the buffer's `eshell-last-dir-ring' to a history file."
- (let ((file eshell-last-dir-ring-file-name))
+ (let* ((file eshell-last-dir-ring-file-name)
+ (resolved-file (if (stringp file) (file-truename file))))
(cond
((or (null file)
(equal file "")
(null eshell-last-dir-ring)
(ring-empty-p eshell-last-dir-ring))
nil)
- ((not (file-writable-p file))
- (message "Cannot write last-dir-ring file %s" file))
+ ((not (file-writable-p resolved-file))
+ (message "Cannot write last-dir-ring file %s" resolved-file))
(t
(let* ((ring eshell-last-dir-ring)
(index (ring-length ring)))
@@ -568,7 +559,7 @@ in the minibuffer:
(insert (ring-ref ring index) ?\n))
(insert (eshell/pwd) ?\n)
(eshell-with-private-file-modes
- (write-region (point-min) (point-max) file nil
+ (write-region (point-min) (point-max) resolved-file nil
'no-message))))))))
(provide 'em-dirs)
diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el
index f03243a6af4..99c52ea0d30 100644
--- a/lisp/eshell/em-glob.el
+++ b/lisp/eshell/em-glob.el
@@ -125,7 +125,7 @@ This option slows down recursive glob processing by quite a bit."
;;; Functions:
-(defun eshell-glob-initialize ()
+(defun eshell-glob-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the extended globbing code."
;; it's important that `eshell-glob-chars-list' come first
(when (boundp 'eshell-special-chars-outside-quoting)
diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el
index f0aee6909ea..614faaa131e 100644
--- a/lisp/eshell/em-hist.el
+++ b/lisp/eshell/em-hist.el
@@ -59,6 +59,7 @@
(require 'ring)
(require 'esh-opt)
+(require 'esh-mode)
(require 'em-pred)
(require 'eshell)
@@ -192,7 +193,6 @@ element, regardless of any text on the command line. In that case,
(defvar eshell-isearch-map
(let ((map (copy-keymap isearch-mode-map)))
(define-key map [(control ?m)] 'eshell-isearch-return)
- (define-key map [return] 'eshell-isearch-return)
(define-key map [(control ?r)] 'eshell-isearch-repeat-backward)
(define-key map [(control ?s)] 'eshell-isearch-repeat-forward)
(define-key map [(control ?g)] 'eshell-isearch-abort)
@@ -216,14 +216,11 @@ Returns non-nil if INPUT is blank."
Returns nil if INPUT is prepended by blank space, otherwise non-nil."
(not (string-match-p "\\`\\s-+" input)))
-(defun eshell-hist-initialize ()
+(defun eshell-hist-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the history management code for one Eshell buffer."
- (add-hook 'eshell-expand-input-functions
- 'eshell-expand-history-references nil t)
-
(when (eshell-using-module 'eshell-cmpl)
(add-hook 'pcomplete-try-first-hook
- 'eshell-complete-history-reference nil t))
+ #'eshell-complete-history-reference nil t))
(if (and (eshell-using-module 'eshell-rebind)
(not eshell-non-interactive-p))
@@ -238,11 +235,13 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil."
(lambda ()
(if (>= (point) eshell-last-output-end)
(setq overriding-terminal-local-map
- eshell-isearch-map)))) nil t)
+ eshell-isearch-map))))
+ nil t)
(add-hook 'isearch-mode-end-hook
(function
(lambda ()
- (setq overriding-terminal-local-map nil))) nil t))
+ (setq overriding-terminal-local-map nil)))
+ nil t))
(define-key eshell-mode-map [up] 'eshell-previous-matching-input-from-input)
(define-key eshell-mode-map [down] 'eshell-next-matching-input-from-input)
(define-key eshell-mode-map [(control up)] 'eshell-previous-input)
@@ -291,17 +290,17 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil."
(if eshell-history-file-name
(eshell-read-history nil t))
- (add-hook 'eshell-exit-hook 'eshell-write-history nil t))
+ (add-hook 'eshell-exit-hook #'eshell-write-history nil t))
(unless eshell-history-ring
(setq eshell-history-ring (make-ring eshell-history-size)))
- (add-hook 'eshell-exit-hook 'eshell-write-history nil t)
+ (add-hook 'eshell-exit-hook #'eshell-write-history nil t)
- (add-hook 'kill-emacs-hook 'eshell-save-some-history)
+ (add-hook 'kill-emacs-hook #'eshell-save-some-history)
(make-local-variable 'eshell-input-filter-functions)
- (add-hook 'eshell-input-filter-functions 'eshell-add-to-history nil t)
+ (add-hook 'eshell-input-filter-functions #'eshell-add-to-history nil t)
(define-key eshell-command-map [(control ?l)] 'eshell-list-history)
(define-key eshell-command-map [(control ?x)] 'eshell-get-next-from-history))
@@ -469,15 +468,16 @@ lost if `eshell-history-ring' is not empty. If
Useful within process sentinels.
See also `eshell-read-history'."
- (let ((file (or filename eshell-history-file-name)))
+ (let* ((file (or filename eshell-history-file-name))
+ (resolved-file (if (stringp file) (file-truename file))))
(cond
((or (null file)
(equal file "")
(null eshell-history-ring)
(ring-empty-p eshell-history-ring))
nil)
- ((not (file-writable-p file))
- (message "Cannot write history file %s" file))
+ ((not (file-writable-p resolved-file))
+ (message "Cannot write history file %s" resolved-file))
(t
(let* ((ring eshell-history-ring)
(index (ring-length ring)))
@@ -492,7 +492,7 @@ See also `eshell-read-history'."
(insert (substring-no-properties (ring-ref ring index)) ?\n)
(subst-char-in-region start (1- (point)) ?\n ?\177)))
(eshell-with-private-file-modes
- (write-region (point-min) (point-max) file append
+ (write-region (point-min) (point-max) resolved-file append
'no-message))))))))
(defun eshell-list-history ()
@@ -584,21 +584,30 @@ See also `eshell-read-history'."
(defun eshell-expand-history-references (beg end)
"Parse and expand any history references in current input."
- (let ((result (eshell-hist-parse-arguments beg end)))
+ (let ((result (eshell-hist-parse-arguments beg end))
+ (full-line (buffer-substring-no-properties beg end)))
(when result
(let ((textargs (nreverse (nth 0 result)))
(posb (nreverse (nth 1 result)))
- (pose (nreverse (nth 2 result))))
+ (pose (nreverse (nth 2 result)))
+ (full-line-subst (eshell-history-substitution full-line)))
(save-excursion
- (while textargs
- (let ((str (eshell-history-reference (car textargs))))
- (unless (eq str (car textargs))
- (goto-char (car posb))
- (insert-and-inherit str)
- (delete-char (- (car pose) (car posb)))))
- (setq textargs (cdr textargs)
- posb (cdr posb)
- pose (cdr pose))))))))
+ (if full-line-subst
+ ;; Found a ^foo^bar substitution
+ (progn
+ (goto-char beg)
+ (insert-and-inherit full-line-subst)
+ (delete-char (- end beg)))
+ ;; Try to expand other substitutions
+ (while textargs
+ (let ((str (eshell-history-reference (car textargs))))
+ (unless (eq str (car textargs))
+ (goto-char (car posb))
+ (insert-and-inherit str)
+ (delete-char (- (car pose) (car posb)))))
+ (setq textargs (cdr textargs)
+ posb (cdr posb)
+ pose (cdr pose)))))))))
(defvar pcomplete-stub)
(defvar pcomplete-last-completion-raw)
@@ -633,20 +642,31 @@ See also `eshell-read-history'."
(setq history (cdr history)))
(cdr fhist)))))))
+(defun eshell-history-substitution (line)
+ "Expand quick hist substitutions formatted as ^foo^bar^.
+Returns nil if string does not match quick substitution format,
+and acts like !!:s/foo/bar/ otherwise."
+ ;; `^string1^string2^'
+ ;; Quick Substitution. Repeat the last command, replacing
+ ;; STRING1 with STRING2. Equivalent to `!!:s/string1/string2/'
+ (when (and (eshell-using-module 'eshell-pred)
+ (string-match
+ "^\\^\\([^^]+\\)\\^\\([^^]+\\)\\(?:\\^\\(.*\\)\\)?$"
+ line))
+ ;; Save trailing match as `eshell-history-reference' runs string-match.
+ (let ((matched-end (match-string 3 line)))
+ (concat
+ (eshell-history-reference
+ (format "!!:s/%s/%s/"
+ (match-string 1 line)
+ (match-string 2 line)))
+ matched-end))))
+
(defun eshell-history-reference (reference)
"Expand directory stack REFERENCE.
The syntax used here was taken from the Bash info manual.
Returns the resultant reference, or the same string REFERENCE if none
matched."
- ;; `^string1^string2^'
- ;; Quick Substitution. Repeat the last command, replacing
- ;; STRING1 with STRING2. Equivalent to `!!:s/string1/string2/'
- (if (and (eshell-using-module 'eshell-pred)
- (string-match "\\^\\([^^]+\\)\\^\\([^^]+\\)\\^?\\s-*$"
- reference))
- (setq reference (format "!!:s/%s/%s/"
- (match-string 1 reference)
- (match-string 2 reference))))
;; `!'
;; Start a history substitution, except when followed by a
;; space, tab, the end of the line, = or (.
@@ -736,7 +756,7 @@ matched."
(setq nth (eshell-hist-word-reference nth)))
(unless (numberp mth)
(setq mth (eshell-hist-word-reference mth)))
- (cons (mapconcat 'identity (eshell-sublist textargs nth mth) " ")
+ (cons (mapconcat #'identity (eshell-sublist textargs nth mth) " ")
end))))
(defun eshell-hist-parse-modifier (hist reference)
diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el
index a4118a0da30..89969d32582 100644
--- a/lisp/eshell/em-ls.el
+++ b/lisp/eshell/em-ls.el
@@ -29,7 +29,8 @@
(require 'cl-lib)
(require 'esh-util)
(require 'esh-opt)
-(eval-when-compile (require 'eshell))
+(require 'esh-proc)
+(require 'esh-cmd)
;;;###autoload
(progn
@@ -183,9 +184,9 @@ really need to stick around for very long."
"The face used for highlighting junk file names.")
(defsubst eshell-ls-filetype-p (attrs type)
- "Test whether ATTRS specifies a directory."
- (if (nth 8 attrs)
- (eq (aref (nth 8 attrs) 0) type)))
+ "Test whether ATTRS specifies a file of type TYPE."
+ (if (file-attribute-modes attrs)
+ (eq (aref (file-attribute-modes attrs) 0) type)))
(defmacro eshell-ls-applicable (attrs index func file)
"Test whether, for ATTRS, the user can do what corresponds to INDEX.
@@ -193,8 +194,8 @@ ATTRS is a string of file modes. See `file-attributes'.
If we cannot determine the answer using ATTRS (e.g., if we need
to know what group the user is in), compute the return value by
calling FUNC with FILE as an argument."
- `(let ((owner (nth 2 ,attrs))
- (modes (nth 8 ,attrs)))
+ `(let ((owner (file-attribute-user-id ,attrs))
+ (modes (file-attribute-modes ,attrs)))
(cond ((cond ((numberp owner)
(= owner (user-uid)))
((stringp owner)
@@ -346,7 +347,7 @@ instead."
"ls" (if eshell-ls-initial-args
(list eshell-ls-initial-args args)
args)
- `((?a "all" nil show-all
+ '((?a "all" nil show-all
"do not ignore entries starting with .")
(?A "almost-all" nil show-almost-all
"do not list implied . and ..")
@@ -437,7 +438,7 @@ Sort entries alphabetically across.")
(defsubst eshell-ls-size-string (attrs size-width)
"Return the size string for ATTRS length, using SIZE-WIDTH."
- (let* ((str (eshell-ls-printable-size (nth 7 attrs) t))
+ (let* ((str (eshell-ls-printable-size (file-attribute-size attrs) t))
(len (length str)))
(if (< len size-width)
(concat (make-string (- size-width len) ? ) str)
@@ -503,19 +504,19 @@ whose cdr is the list of file attributes."
(if numeric-uid-gid
"%s%4d %-8s %-8s "
"%s%4d %-14s %-8s ")
- (or (nth 8 attrs) "??????????")
- (or (nth 1 attrs) 0)
- (or (let ((user (nth 2 attrs)))
+ (or (file-attribute-modes attrs) "??????????")
+ (or (file-attribute-link-number attrs) 0)
+ (or (let ((user (file-attribute-user-id attrs)))
(and (stringp user)
(eshell-substring user 14)))
- (nth 2 attrs)
+ (file-attribute-user-id attrs)
"")
- (or (let ((group (nth 3 attrs)))
+ (or (let ((group (file-attribute-group-id attrs)))
(and (stringp group)
(eshell-substring group 8)))
- (nth 3 attrs)
+ (file-attribute-group-id attrs)
""))
- (let* ((str (eshell-ls-printable-size (nth 7 attrs)))
+ (let* ((str (eshell-ls-printable-size (file-attribute-size attrs)))
(len (length str)))
;; Let file sizes shorter than 9 align neatly.
(if (< len (or size-width 8))
@@ -585,12 +586,12 @@ relative to that directory."
(let ((total 0.0))
(setq size-width 0)
(dolist (e entries)
- (if (nth 7 (cdr e))
- (setq total (+ total (nth 7 (cdr e)))
+ (if (file-attribute-size (cdr e))
+ (setq total (+ total (file-attribute-size (cdr e)))
size-width
(max size-width
(length (eshell-ls-printable-size
- (nth 7 (cdr e))
+ (file-attribute-size (cdr e))
(not
;; If we are under -l, count length
;; of sizes in bytes, not in blocks.
@@ -700,7 +701,7 @@ Each member of FILES is either a string or a cons cell of the form
(if (not show-size)
(setq display-files (mapcar 'eshell-ls-annotate files))
(dolist (file files)
- (let* ((str (eshell-ls-printable-size (nth 7 (cdr file)) t))
+ (let* ((str (eshell-ls-printable-size (file-attribute-size (cdr file)) t))
(len (length str)))
(if (< len size-width)
(setq str (concat (make-string (- size-width len) ? ) str)))
@@ -766,14 +767,14 @@ need to be printed."
(if show-size
(max size-width
(length (eshell-ls-printable-size
- (nth 7 (cdr entry)) t))))))
+ (file-attribute-size (cdr entry)) t))))))
(setq dirs (cons entry dirs)))
(setq files (cons entry files)
size-width
(if show-size
(max size-width
(length (eshell-ls-printable-size
- (nth 7 (cdr entry)) t)))))))
+ (file-attribute-size (cdr entry)) t)))))))
(when files
(eshell-ls-files (eshell-ls-sort-entries files)
size-width show-recursive)
diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el
index bfabda0ec77..9bc856a2966 100644
--- a/lisp/eshell/em-pred.el
+++ b/lisp/eshell/em-pred.el
@@ -46,9 +46,7 @@
;;; Code:
-(require 'esh-util)
-(require 'esh-arg)
-(eval-when-compile (require 'eshell))
+(require 'esh-mode)
;;;###autoload
(progn
@@ -89,10 +87,12 @@ ordinary strings."
(?t . (eshell-pred-file-mode 1000)) ; sticky bit
(?U . #'(lambda (file) ; owned by effective uid
(if (file-exists-p file)
- (= (nth 2 (file-attributes file)) (user-uid)))))
+ (= (file-attribute-user-id (file-attributes file))
+ (user-uid)))))
;; (?G . #'(lambda (file) ; owned by effective gid
;; (if (file-exists-p file)
- ;; (= (nth 2 (file-attributes file)) (user-uid)))))
+ ;; (= (file-attribute-user-id (file-attributes file))
+ ;; (user-uid)))))
(?* . #'(lambda (file)
(and (file-regular-p file)
(not (file-symlink-p file))
@@ -131,7 +131,7 @@ The format of each entry is
(?e . #'(lambda (lst) (mapcar 'file-name-extension lst)))
(?t . #'(lambda (lst) (mapcar 'file-name-nondirectory lst)))
(?q . #'(lambda (lst) (mapcar 'eshell-escape-arg lst)))
- (?u . #'(lambda (lst) (eshell-uniqify-list lst)))
+ (?u . #'(lambda (lst) (eshell-uniquify-list lst)))
(?o . #'(lambda (lst) (sort lst 'string-lessp)))
(?O . #'(lambda (lst) (nreverse (sort lst 'string-lessp))))
(?j . (eshell-join-members))
@@ -245,10 +245,10 @@ EXAMPLES:
(lambda ()
(insert eshell-modifier-help-string)))))
-(defun eshell-pred-initialize ()
+(defun eshell-pred-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the predicate/modifier code."
(add-hook 'eshell-parse-argument-hook
- 'eshell-parse-arg-modifier t t)
+ #'eshell-parse-arg-modifier t t)
(define-key eshell-command-map [(meta ?q)] 'eshell-display-predicate-help)
(define-key eshell-command-map [(meta ?m)] 'eshell-display-modifier-help))
@@ -419,9 +419,8 @@ resultant list of strings."
(forward-char))
(if (looking-at "[0-9]+")
(progn
- (setq when (- (float-time)
- (* (string-to-number (match-string 0))
- quantum)))
+ (setq when (time-since (* (string-to-number (match-string 0))
+ quantum)))
(goto-char (match-end 0)))
(setq open (char-after))
(if (setq close (memq open '(?\( ?\[ ?\< ?\{)))
@@ -436,17 +435,17 @@ resultant list of strings."
(attrs (file-attributes file)))
(unless attrs
(error "Cannot stat file `%s'" file))
- (setq when (float-time (nth attr-index attrs))))
+ (setq when (nth attr-index attrs)))
(goto-char (1+ end)))
`(lambda (file)
(let ((attrs (file-attributes file)))
(if attrs
(,(if (eq qual ?-)
- '<
+ 'time-less-p
(if (eq qual ?+)
- '>
- '=)) ,when (float-time
- (nth ,attr-index attrs))))))))
+ '(lambda (a b) (time-less-p b a))
+ 'time-equal-p))
+ ,when (nth ,attr-index attrs)))))))
(defun eshell-pred-file-type (type)
"Return a test which tests that the file is of a certain TYPE.
@@ -460,7 +459,7 @@ that `ls -l' will show in the first column of its display. "
`(lambda (file)
(let ((attrs (eshell-file-attributes (directory-file-name file))))
(if attrs
- (memq (aref (nth 8 attrs) 0)
+ (memq (aref (file-attribute-modes attrs) 0)
,(if (eq type ?%)
'(?b ?c)
(list 'quote (list type))))))))
@@ -489,7 +488,8 @@ that `ls -l' will show in the first column of its display. "
'<
(if (eq qual ?+)
'>
- '=)) (nth 1 attrs) ,amount))))))
+ '=))
+ (file-attribute-link-number attrs) ,amount))))))
(defun eshell-pred-file-size ()
"Return a predicate to test whether a file is of a given size."
@@ -518,7 +518,8 @@ that `ls -l' will show in the first column of its display. "
'<
(if (eq qual ?+)
'>
- '=)) (nth 7 attrs) ,amount))))))
+ '=))
+ (file-attribute-size attrs) ,amount))))))
(defun eshell-pred-substitute (&optional repeat)
"Return a modifier function that will substitute matches."
@@ -545,7 +546,8 @@ that `ls -l' will show in the first column of its display. "
(function
(lambda (str)
(if (string-match ,match str)
- (setq str (replace-match ,replace t nil str)))
+ (setq str (replace-match ,replace t nil str))
+ (error (concat str ": substitution failed")))
str)) lst)))))
(defun eshell-include-members (&optional invert-p)
diff --git a/lisp/eshell/em-prompt.el b/lisp/eshell/em-prompt.el
index 3d15a441610..adc68b6c856 100644
--- a/lisp/eshell/em-prompt.el
+++ b/lisp/eshell/em-prompt.el
@@ -80,7 +80,6 @@ re-entered for it to take effect."
For highlighting other kinds of strings -- similar to shell mode's
behavior -- simply use an output filer which changes text properties."
:group 'eshell-prompt)
-(define-obsolete-face-alias 'eshell-prompt-face 'eshell-prompt "22.1")
(defcustom eshell-before-prompt-hook nil
"A list of functions to call before outputting the prompt."
@@ -100,7 +99,7 @@ arriving, or after."
;;; Functions:
-(defun eshell-prompt-initialize ()
+(defun eshell-prompt-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the prompting code."
(unless eshell-non-interactive-p
(add-hook 'eshell-post-command-hook 'eshell-emit-prompt nil t)
diff --git a/lisp/eshell/em-rebind.el b/lisp/eshell/em-rebind.el
index 9cb16174f20..a817edbcc99 100644
--- a/lisp/eshell/em-rebind.el
+++ b/lisp/eshell/em-rebind.el
@@ -145,7 +145,7 @@ This is default behavior of shells like bash."
;;; Functions:
-(defun eshell-rebind-initialize ()
+(defun eshell-rebind-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the inputting code."
(unless eshell-non-interactive-p
(add-hook 'eshell-mode-hook 'eshell-setup-input-keymap nil t)
diff --git a/lisp/eshell/em-script.el b/lisp/eshell/em-script.el
index b8a5ecd9002..4a3b84e10e3 100644
--- a/lisp/eshell/em-script.el
+++ b/lisp/eshell/em-script.el
@@ -23,8 +23,7 @@
;;; Code:
-(require 'eshell)
-(require 'esh-opt)
+(require 'esh-mode)
;;;###autoload
(progn
@@ -57,11 +56,11 @@ This includes when running `eshell-command'."
;;; Functions:
-(defun eshell-script-initialize ()
+(defun eshell-script-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the script parsing code."
(make-local-variable 'eshell-interpreter-alist)
(setq eshell-interpreter-alist
- (cons (cons #'(lambda (file args)
+ (cons (cons #'(lambda (file _args)
(string= (file-name-nondirectory file)
"eshell"))
'eshell/source)
@@ -73,13 +72,14 @@ This includes when running `eshell-command'."
;; to ruin it for other modules
(let (eshell-inside-quote-regexp
eshell-outside-quote-regexp)
- (and (not eshell-non-interactive-p)
+ (and (not (bound-and-true-p eshell-non-interactive-p))
eshell-login-script
(file-readable-p eshell-login-script)
(eshell-do-eval
(list 'eshell-commands
(catch 'eshell-replace-command
- (eshell-source-file eshell-login-script))) t))
+ (eshell-source-file eshell-login-script)))
+ t))
(and eshell-rc-script
(file-readable-p eshell-rc-script)
(eshell-do-eval
diff --git a/lisp/eshell/em-smart.el b/lisp/eshell/em-smart.el
index 420f8850504..c7965b4187c 100644
--- a/lisp/eshell/em-smart.el
+++ b/lisp/eshell/em-smart.el
@@ -166,7 +166,7 @@ The options are `begin', `after' or `end'."
;;; Functions:
-(defun eshell-smart-initialize ()
+(defun eshell-smart-initialize () ;Called from `eshell-mode' via intern-soft!
"Setup Eshell smart display."
(unless eshell-non-interactive-p
;; override a few variables, since they would interfere with the
diff --git a/lisp/eshell/em-term.el b/lisp/eshell/em-term.el
index 1013bd2b89a..dea90405ad7 100644
--- a/lisp/eshell/em-term.el
+++ b/lisp/eshell/em-term.el
@@ -147,7 +147,7 @@ behavior for short-lived processes, see bug#18108."
;;; Functions:
-(defun eshell-term-initialize ()
+(defun eshell-term-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the `term' interface code."
(make-local-variable 'eshell-interpreter-alist)
(setq eshell-interpreter-alist
@@ -175,7 +175,7 @@ allowed."
(let* (eshell-interpreter-alist
(interp (eshell-find-interpreter (car args) (cdr args)))
(program (car interp))
- (args (eshell-flatten-list
+ (args (flatten-tree
(eshell-stringify-list (append (cdr interp)
(cdr args)))))
(term-buf
@@ -191,7 +191,7 @@ allowed."
(term-exec term-buf program program nil args)
(let ((proc (get-buffer-process term-buf)))
(if (and proc (eq 'run (process-status proc)))
- (set-process-sentinel proc 'eshell-term-sentinel)
+ (set-process-sentinel proc #'eshell-term-sentinel)
(error "Failed to invoke visual command")))
(term-char-mode)
(if eshell-escape-control-x
diff --git a/lisp/eshell/em-tramp.el b/lisp/eshell/em-tramp.el
index 81324800aef..c7916360ee6 100644
--- a/lisp/eshell/em-tramp.el
+++ b/lisp/eshell/em-tramp.el
@@ -26,6 +26,7 @@
;;; Code:
(require 'esh-util)
+(require 'esh-cmd)
(eval-when-compile
(require 'esh-mode)
@@ -45,7 +46,7 @@
:tag "TRAMP Eshell features"
:group 'eshell-module))
-(defun eshell-tramp-initialize ()
+(defun eshell-tramp-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the TRAMP-using commands code."
(when (eshell-using-module 'eshell-cmpl)
(add-hook 'pcomplete-try-first-hook
@@ -61,7 +62,7 @@
"Alias \"su\" to call TRAMP.
Uses the system su through TRAMP's su method."
- (setq args (eshell-stringify-list (eshell-flatten-list args)))
+ (setq args (eshell-stringify-list (flatten-tree args)))
(let ((orig-args (copy-tree args)))
(eshell-eval-using-options
"su" args
@@ -99,13 +100,14 @@ Become another USER during a login session.")
"Alias \"sudo\" to call Tramp.
Uses the system sudo through TRAMP's sudo method."
- (setq args (eshell-stringify-list (eshell-flatten-list args)))
+ (setq args (eshell-stringify-list (flatten-tree args)))
(let ((orig-args (copy-tree args)))
(eshell-eval-using-options
"sudo" args
'((?h "help" nil nil "show this usage screen")
(?u "user" t user "execute a command as another USER")
:show-usage
+ :parse-leading-options-only
:usage "[(-u | --user) USER] COMMAND
Execute a COMMAND as the superuser or another USER.")
(throw 'eshell-external
diff --git a/lisp/eshell/em-unix.el b/lisp/eshell/em-unix.el
index b4ad5a6532c..25221817218 100644
--- a/lisp/eshell/em-unix.el
+++ b/lisp/eshell/em-unix.el
@@ -35,8 +35,7 @@
;;; Code:
-(require 'eshell)
-(require 'esh-opt)
+(require 'esh-mode)
(require 'pcomplete)
;;;###autoload
@@ -140,7 +139,7 @@ Otherwise, Emacs will attempt to use rsh to invoke du on the remote machine."
;;; Functions:
-(defun eshell-unix-initialize ()
+(defun eshell-unix-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the UNIX support/emulation code."
(when (eshell-using-module 'eshell-cmpl)
(add-hook 'pcomplete-try-first-hook
@@ -231,7 +230,7 @@ Otherwise, Emacs will attempt to use rsh to invoke du on the remote machine."
This is implemented to call either `delete-file', `kill-buffer',
`kill-process', or `unintern', depending on the nature of the
argument."
- (setq args (eshell-flatten-list args))
+ (setq args (flatten-tree args))
(eshell-eval-using-options
"rm" args
'((?h "help" nil nil "show this usage screen")
@@ -370,12 +369,14 @@ Remove the DIRECTORY(ies), if they are empty.")
(or (not (eshell-under-windows-p))
(eq system-type 'ms-dos))
(setq attr (eshell-file-attributes (car files)))
- (nth 10 attr-target) (nth 10 attr)
- ;; Use equal, not -, since the inode and the device could
- ;; cons cells.
- (equal (nth 10 attr-target) (nth 10 attr))
- (nth 11 attr-target) (nth 11 attr)
- (equal (nth 11 attr-target) (nth 11 attr)))
+ (file-attribute-inode-number attr-target)
+ (file-attribute-inode-number attr)
+ (equal (file-attribute-inode-number attr-target)
+ (file-attribute-inode-number attr))
+ (file-attribute-device-number attr-target)
+ (file-attribute-device-number attr)
+ (equal (file-attribute-device-number attr-target)
+ (file-attribute-device-number attr)))
(eshell-error (format-message "%s: `%s' and `%s' are the same file\n"
command (car files) target)))
(t
@@ -397,16 +398,16 @@ Remove the DIRECTORY(ies), if they are empty.")
(let (eshell-warn-dot-directories)
(if (and (not deep)
(eq func 'rename-file)
- ;; Use equal, since the device might be a
- ;; cons cell.
- (equal (nth 11 (eshell-file-attributes
- (file-name-directory
- (directory-file-name
- (expand-file-name source)))))
- (nth 11 (eshell-file-attributes
- (file-name-directory
- (directory-file-name
- (expand-file-name target)))))))
+ (equal (file-attribute-device-number
+ (eshell-file-attributes
+ (file-name-directory
+ (directory-file-name
+ (expand-file-name source)))))
+ (file-attribute-device-number
+ (eshell-file-attributes
+ (file-name-directory
+ (directory-file-name
+ (expand-file-name target)))))))
(apply 'eshell-funcalln func source target args)
(unless (file-directory-p target)
(if em-verbose
@@ -479,7 +480,7 @@ Remove the DIRECTORY(ies), if they are empty.")
(error "%s: missing destination file or directory" ,command))
(if (= len 1)
(nconc args '(".")))
- (setq args (eshell-stringify-list (eshell-flatten-list args)))
+ (setq args (eshell-stringify-list (flatten-tree args)))
(if (and ,(not (equal command "ln"))
(string-match eshell-tar-regexp (car (last args)))
(or (> (length args) 2)
@@ -604,7 +605,7 @@ with `--symbolic'. When creating hard links, each TARGET must exist.")
"Implementation of cat in Lisp.
If in a pipeline, or the file is not a regular file, directory or
symlink, then revert to the system's definition of cat."
- (setq args (eshell-stringify-list (eshell-flatten-list args)))
+ (setq args (eshell-stringify-list (flatten-tree args)))
(if (or eshell-in-pipeline-p
(catch 'special
(dolist (arg args)
@@ -612,7 +613,8 @@ symlink, then revert to the system's definition of cat."
(> (length arg) 0)
(eq (aref arg 0) ?-))
(let ((attrs (eshell-file-attributes arg)))
- (and attrs (memq (aref (nth 8 attrs) 0)
+ (and attrs
+ (memq (aref (file-attribute-modes attrs) 0)
'(?d ?l ?-)))))
(throw 'special t)))))
(let ((ext-cat (eshell-search-path "cat")))
@@ -667,7 +669,7 @@ Fallback to standard make when called synchronously."
(compile (concat "make " (eshell-flatten-and-stringify args))))
(throw 'eshell-replace-command
(eshell-parse-command "*make" (eshell-stringify-list
- (eshell-flatten-list args))))))
+ (flatten-tree args))))))
(put 'eshell/make 'eshell-no-numeric-conversions t)
@@ -702,7 +704,7 @@ available..."
(erase-buffer)
(occur-mode)
(let ((files (eshell-stringify-list
- (eshell-flatten-list (cdr args))))
+ (flatten-tree (cdr args))))
(inhibit-redisplay t)
string)
(when (car args)
@@ -747,11 +749,11 @@ external command."
(throw 'eshell-replace-command
(eshell-parse-command (concat "*" command)
(eshell-stringify-list
- (eshell-flatten-list args))))
+ (flatten-tree args))))
(let* ((args (mapconcat 'identity
(mapcar 'shell-quote-argument
(eshell-stringify-list
- (eshell-flatten-list args)))
+ (flatten-tree args)))
" "))
(cmd (progn
(set-text-properties 0 (length args)
@@ -843,19 +845,19 @@ external command."
(unless (string-match "\\`\\.\\.?\\'" (caar entries))
(let* ((entry (concat path "/"
(caar entries)))
- (symlink (and (stringp (cadr (car entries)))
- (cadr (car entries)))))
+ (symlink (and (stringp (file-attribute-type (cdar entries)))
+ (file-attribute-type (cdar entries)))))
(unless (or (and symlink (not dereference-links))
(and only-one-filesystem
(/= only-one-filesystem
- (nth 12 (car entries)))))
+ (file-attribute-device-number (cdar entries)))))
(if symlink
(setq entry symlink))
(setq size
(+ size
- (if (eq t (cadr (car entries)))
+ (if (eq t (car (cdar entries)))
(eshell-du-sum-directory entry (1+ depth))
- (let ((file-size (nth 8 (car entries))))
+ (let ((file-size (file-attribute-size (cdar entries))))
(prog1
file-size
(if show-all
@@ -873,7 +875,7 @@ external command."
(defun eshell/du (&rest args)
"Implementation of \"du\" in Lisp, passing ARGS."
(setq args (if args
- (eshell-stringify-list (eshell-flatten-list args))
+ (eshell-stringify-list (flatten-tree args))
'(".")))
(let ((ext-du (eshell-search-path "du")))
(if (and ext-du
@@ -926,7 +928,7 @@ Summarize disk usage of each FILE, recursively for directories.")
(while args
(if only-one-filesystem
(setq only-one-filesystem
- (nth 11 (eshell-file-attributes
+ (file-attribute-device-number (eshell-file-attributes
(file-name-as-directory (car args))))))
(setq size (+ size (eshell-du-sum-directory
(directory-file-name (car args)) 0)))
@@ -940,7 +942,8 @@ Summarize disk usage of each FILE, recursively for directories.")
(defvar eshell-time-start nil)
(defun eshell-show-elapsed-time ()
- (let ((elapsed (format "%.3f secs\n" (- (float-time) eshell-time-start))))
+ (let ((elapsed (format "%.3f secs\n"
+ (float-time (time-since eshell-time-start)))))
(set-text-properties 0 (length elapsed) '(face bold) elapsed)
(eshell-interactive-print elapsed))
(remove-hook 'eshell-post-command-hook 'eshell-show-elapsed-time t))
@@ -973,9 +976,9 @@ Show wall-clock time elapsed during execution of COMMAND.")
(eshell-parse-command (car time-args)
;;; https://lists.gnu.org/r/bug-gnu-emacs/2007-08/msg00205.html
(eshell-stringify-list
- (eshell-flatten-list (cdr time-args))))))))
+ (flatten-tree (cdr time-args))))))))
-(defun eshell/whoami (&rest args)
+(defun eshell/whoami (&rest _args)
"Make \"whoami\" Tramp aware."
(or (file-remote-p default-directory 'user) (user-login-name)))
@@ -997,7 +1000,7 @@ Show wall-clock time elapsed during execution of COMMAND.")
(defun eshell/diff (&rest args)
"Alias \"diff\" to call Emacs `diff' function."
- (let ((orig-args (eshell-stringify-list (eshell-flatten-list args))))
+ (let ((orig-args (eshell-stringify-list (flatten-tree args))))
(if (or eshell-plain-diff-behavior
(not (and (eshell-interactive-output-p)
(not eshell-in-pipeline-p)
@@ -1053,7 +1056,7 @@ Show wall-clock time elapsed during execution of COMMAND.")
(string-match "^-" (car args))))
(throw 'eshell-replace-command
(eshell-parse-command "*locate" (eshell-stringify-list
- (eshell-flatten-list args))))
+ (flatten-tree args))))
(save-selected-window
(let ((locate-history-list (list (car args))))
(locate-with-filter (car args) (cadr args))))))
diff --git a/lisp/eshell/em-xtra.el b/lisp/eshell/em-xtra.el
index d4e5f1a092c..602e8417520 100644
--- a/lisp/eshell/em-xtra.el
+++ b/lisp/eshell/em-xtra.el
@@ -25,8 +25,10 @@
(require 'esh-util)
(eval-when-compile
- (require 'eshell)
- (require 'pcomplete))
+ (require 'eshell))
+;; Strictly speaking, should only be needed at compile time.
+;; Require at run-time too to silence compiler.
+(require 'pcomplete)
(require 'compile)
;; There are no items in this custom group, but eshell modules (ab)use
@@ -49,7 +51,7 @@ naturally accessible within Emacs."
"Implementation of expr, using the calc package."
(if (not (fboundp 'calc-eval))
(throw 'eshell-replace-command
- (eshell-parse-command "*expr" (eshell-flatten-list args)))
+ (eshell-parse-command "*expr" (flatten-tree args)))
;; to fool the byte-compiler...
(let ((func 'calc-eval))
(funcall func (eshell-flatten-and-stringify args)))))
diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el
index 360202b6539..026edc59808 100644
--- a/lisp/eshell/esh-arg.el
+++ b/lisp/eshell/esh-arg.el
@@ -25,9 +25,9 @@
;; hook `eshell-parse-argument-hook'. For a good example of this, see
;; `eshell-parse-drive-letter', defined in eshell-dirs.el.
-(provide 'esh-arg)
+;;; Code:
-(require 'esh-mode)
+(require 'esh-util)
(defgroup eshell-arg nil
"Argument parsing involves transforming the arguments passed on the
@@ -36,6 +36,48 @@ yield the values intended."
:tag "Argument parsing"
:group 'eshell)
+;;; Internal Variables:
+
+(defvar eshell-current-argument nil)
+(defvar eshell-current-modifiers nil)
+(defvar eshell-arg-listified nil)
+(defvar eshell-nested-argument nil)
+(defvar eshell-current-quoted nil)
+(defvar eshell-inside-quote-regexp nil)
+(defvar eshell-outside-quote-regexp nil)
+
+;;; User Variables:
+
+(defcustom eshell-arg-load-hook nil
+ "A hook that gets run when `eshell-arg' is loaded."
+ :version "24.1" ; removed eshell-arg-initialize
+ :type 'hook
+ :group 'eshell-arg)
+
+(defcustom eshell-delimiter-argument-list '(?\; ?& ?\| ?\> ?\s ?\t ?\n)
+ "List of characters to recognize as argument separators."
+ :type '(repeat character)
+ :group 'eshell-arg)
+
+(defcustom eshell-special-chars-inside-quoting '(?\\ ?\")
+ "Characters which are still special inside double quotes."
+ :type '(repeat character)
+ :group 'eshell-arg)
+
+(defcustom eshell-special-chars-outside-quoting
+ (append eshell-delimiter-argument-list '(?# ?! ?\\ ?\" ?\'))
+ "Characters that require escaping outside of double quotes.
+Without escaping them, they will introduce a change in the argument."
+ :type '(repeat character)
+ :group 'eshell-arg)
+
+(defsubst eshell-arg-delimiter (&optional pos)
+ "Return non-nil if POS is an argument delimiter.
+If POS is nil, the location of point is checked."
+ (let ((pos (or pos (point))))
+ (or (= pos (point-max))
+ (memq (char-after pos) eshell-delimiter-argument-list))))
+
(defcustom eshell-parse-argument-hook
(list
;; a term such as #<buffer NAME>, or #<process NAME> is a buffer
@@ -113,47 +155,13 @@ treated as a literal character."
:type 'hook
:group 'eshell-arg)
-;;; Code:
-
-;;; User Variables:
-
-(defcustom eshell-arg-load-hook nil
- "A hook that gets run when `eshell-arg' is loaded."
- :version "24.1" ; removed eshell-arg-initialize
- :type 'hook
- :group 'eshell-arg)
-
-(defcustom eshell-delimiter-argument-list '(?\; ?& ?\| ?\> ?\s ?\t ?\n)
- "List of characters to recognize as argument separators."
- :type '(repeat character)
- :group 'eshell-arg)
-
-(defcustom eshell-special-chars-inside-quoting '(?\\ ?\")
- "Characters which are still special inside double quotes."
- :type '(repeat character)
- :group 'eshell-arg)
-
-(defcustom eshell-special-chars-outside-quoting
- (append eshell-delimiter-argument-list '(?# ?! ?\\ ?\" ?\'))
- "Characters that require escaping outside of double quotes.
-Without escaping them, they will introduce a change in the argument."
- :type '(repeat character)
- :group 'eshell-arg)
-
-;;; Internal Variables:
-
-(defvar eshell-current-argument nil)
-(defvar eshell-current-modifiers nil)
-(defvar eshell-arg-listified nil)
-(defvar eshell-nested-argument nil)
-(defvar eshell-current-quoted nil)
-(defvar eshell-inside-quote-regexp nil)
-(defvar eshell-outside-quote-regexp nil)
-
;;; Functions:
-(defun eshell-arg-initialize ()
+(defun eshell-arg-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the argument parsing code."
+ ;; This is supposedly run after enabling esh-mode, when eshell-mode-map
+ ;; already exists.
+ (defvar eshell-command-map)
(define-key eshell-command-map [(meta ?b)] 'eshell-insert-buffer-name)
(set (make-local-variable 'eshell-inside-quote-regexp) nil)
(set (make-local-variable 'eshell-outside-quote-regexp) nil))
@@ -195,13 +203,6 @@ Without escaping them, they will introduce a change in the argument."
(setq eshell-current-argument argument))
(throw 'eshell-arg-done t))
-(defsubst eshell-arg-delimiter (&optional pos)
- "Return non-nil if POS is an argument delimiter.
-If POS is nil, the location of point is checked."
- (let ((pos (or pos (point))))
- (or (= pos (point-max))
- (memq (char-after pos) eshell-delimiter-argument-list))))
-
(defun eshell-quote-argument (string)
"Return STRING with magic characters quoted.
Magic characters are those in `eshell-special-chars-outside-quoting'."
@@ -405,4 +406,5 @@ If the form has no `type', the syntax is parsed as if `type' were
(char-to-string (char-after)))))
(goto-char end)))))))
+(provide 'esh-arg)
;;; esh-arg.el ends here
diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el
index 8e1e936b63f..6e03bda22b7 100644
--- a/lisp/eshell/esh-cmd.el
+++ b/lisp/eshell/esh-cmd.el
@@ -105,6 +105,8 @@
(require 'eldoc))
(require 'esh-arg)
(require 'esh-proc)
+(require 'esh-module)
+(require 'esh-io)
(require 'esh-ext)
(eval-when-compile
@@ -122,24 +124,20 @@ however."
(defcustom eshell-prefer-lisp-functions nil
"If non-nil, prefer Lisp functions to external commands."
- :type 'boolean
- :group 'eshell-cmd)
+ :type 'boolean)
(defcustom eshell-lisp-regexp "\\([(`]\\|#'\\)"
"A regexp which, if matched at beginning of an argument, means Lisp.
Such arguments will be passed to `read', and then evaluated."
- :type 'regexp
- :group 'eshell-cmd)
+ :type 'regexp)
(defcustom eshell-pre-command-hook nil
"A hook run before each interactive command is invoked."
- :type 'hook
- :group 'eshell-cmd)
+ :type 'hook)
(defcustom eshell-post-command-hook nil
"A hook run after each interactive command is invoked."
- :type 'hook
- :group 'eshell-cmd)
+ :type 'hook)
(defcustom eshell-prepare-command-hook nil
"A set of functions called to prepare a named command.
@@ -149,8 +147,7 @@ the value of these symbols if necessary.
To prevent a command from executing at all, set
`eshell-last-command-name' to nil."
- :type 'hook
- :group 'eshell-cmd)
+ :type 'hook)
(defcustom eshell-named-command-hook nil
"A set of functions called before a named command is invoked.
@@ -165,7 +162,7 @@ In order to substitute an alternate command form for execution, the
hook function should throw it using the tag `eshell-replace-command'.
For example:
- (add-hook \\='eshell-named-command-hook \\='subst-with-cd)
+ (add-hook \\='eshell-named-command-hook #\\='subst-with-cd)
(defun subst-with-cd (command args)
(throw \\='eshell-replace-command
(eshell-parse-command \"cd\" args)))
@@ -173,8 +170,7 @@ For example:
Although useless, the above code will cause any non-glob, non-Lisp
command (i.e., `ls' as opposed to `*ls' or `(ls)') to be replaced by a
call to `cd' using the arguments that were passed to the function."
- :type 'hook
- :group 'eshell-cmd)
+ :type 'hook)
(defcustom eshell-pre-rewrite-command-hook
'(eshell-no-command-conversion
@@ -182,8 +178,7 @@ call to `cd' using the arguments that were passed to the function."
"A hook run before command rewriting begins.
The terms of the command to be rewritten is passed as arguments, and
may be modified in place. Any return value is ignored."
- :type 'hook
- :group 'eshell-cmd)
+ :type 'hook)
(defcustom eshell-rewrite-command-hook
'(eshell-rewrite-for-command
@@ -202,8 +197,7 @@ so by adding a function to this hook. The first function to return a
substitute command form is the one used. Each function is passed the
command's full argument list, which is a list of sexps (typically
forms or strings)."
- :type 'hook
- :group 'eshell-cmd)
+ :type 'hook)
(defvar eshell-post-rewrite-command-function #'identity
"Function run after command rewriting is finished.
@@ -228,16 +222,14 @@ If an entry is a function, it will be called with the name, and should
return non-nil if the command is complex."
:type '(repeat :tag "Commands"
(choice (string :tag "Name")
- (function :tag "Predicate")))
- :group 'eshell-cmd)
+ (function :tag "Predicate"))))
;;; User Variables:
(defcustom eshell-cmd-load-hook nil
"A hook that gets run when `eshell-cmd' is loaded."
:version "24.1" ; removed eshell-cmd-initialize
- :type 'hook
- :group 'eshell-cmd)
+ :type 'hook)
(defcustom eshell-debug-command nil
"If non-nil, enable Eshell debugging code.
@@ -247,9 +239,8 @@ you must re-load `esh-cmd.el'."
:initialize 'custom-initialize-default
:set (lambda (symbol value)
(set symbol value)
- (load-library "esh-cmd"))
- :type 'boolean
- :group 'eshell-cmd)
+ (load "esh-cmd"))
+ :type 'boolean)
(defcustom eshell-deferrable-commands
'(eshell-named-command
@@ -259,16 +250,14 @@ you must re-load `esh-cmd.el'."
If they return a process object, execution of the calling Eshell
command will wait for completion (in the background) before finishing
the command."
- :type '(repeat function)
- :group 'eshell-cmd)
+ :type '(repeat function))
(defcustom eshell-subcommand-bindings
'((eshell-in-subcommand-p t)
(default-directory default-directory)
(process-environment (eshell-copy-environment)))
"A list of `let' bindings for subcommand environments."
- :type 'sexp
- :group 'eshell-cmd)
+ :type 'sexp)
(put 'risky-local-variable 'eshell-subcommand-bindings t)
@@ -298,7 +287,7 @@ otherwise t.")
"Return currently running command process, if non-Lisp."
eshell-last-async-proc)
-(defun eshell-cmd-initialize ()
+(defun eshell-cmd-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the Eshell command processing module."
(set (make-local-variable 'eshell-current-command) nil)
(set (make-local-variable 'eshell-command-name) nil)
@@ -307,7 +296,7 @@ otherwise t.")
(set (make-local-variable 'eshell-last-command-name) nil)
(set (make-local-variable 'eshell-last-async-proc) nil)
- (add-hook 'eshell-kill-hook 'eshell-resume-command nil t)
+ (add-hook 'eshell-kill-hook #'eshell-resume-command nil t)
;; make sure that if a command is over, and no process is being
;; waited for, that `eshell-current-command' is set to nil. This
@@ -317,16 +306,17 @@ otherwise t.")
(function
(lambda ()
(setq eshell-current-command nil
- eshell-last-async-proc nil))) nil t)
+ eshell-last-async-proc nil)))
+ nil t)
(add-hook 'eshell-parse-argument-hook
- 'eshell-parse-subcommand-argument nil t)
+ #'eshell-parse-subcommand-argument nil t)
(add-hook 'eshell-parse-argument-hook
- 'eshell-parse-lisp-argument nil t)
+ #'eshell-parse-lisp-argument nil t)
(when (eshell-using-module 'eshell-cmpl)
(add-hook 'pcomplete-try-first-hook
- 'eshell-complete-lisp-symbols nil t)))
+ #'eshell-complete-lisp-symbols nil t)))
(defun eshell-complete-lisp-symbols ()
"If there is a user reference, complete it."
@@ -724,6 +714,8 @@ ensconced in a list."
eshell-current-subjob-p)
,object))
+(defvar eshell-this-command-hook nil)
+
(defmacro eshell-trap-errors (object)
"Trap any errors that occur, so they are not entirely fatal.
Also, the variable `eshell-this-command-hook' is available for the
@@ -736,9 +728,9 @@ this grossness will be made to disappear by using `call/cc'..."
(eshell-condition-case err
(prog1
,object
- (run-hooks 'eshell-this-command-hook))
+ (mapc #'funcall eshell-this-command-hook))
(error
- (run-hooks 'eshell-this-command-hook)
+ (mapc #'funcall eshell-this-command-hook)
(eshell-errorn (error-message-string err))
(eshell-close-handles 1)))))
@@ -816,7 +808,7 @@ This is used on systems where async subprocesses are not supported."
;; The last process in the pipe should get its handles
;; redirected as we found them before running the pipe.
,(if (null (cdr pipeline))
- `(progn
+ '(progn
(setq eshell-current-handles tail-handles)
(setq eshell-in-pipeline-p nil)))
(let ((result ,(car pipeline)))
@@ -1059,16 +1051,8 @@ be finished later after the completion of an asynchronous subprocess."
((eq (car form) 'setcdr)
(setcar (cdr args) (eshell-do-eval (cadr args) synchronous-p))
(eval form))
- ((memq (car form) '(let catch condition-case unwind-protect))
- ;; `let', `condition-case' and `unwind-protect' have to be
- ;; handled specially, because we only want to call
- ;; `eshell-do-eval' on their first form.
- ;;
- ;; NOTE: This requires obedience by all forms which this
- ;; function might encounter, that they do not contain
- ;; other special forms.
- (if (and (eq (car form) 'let)
- (not (eq (car (cadr args)) 'eshell-do-eval)))
+ ((eq (car form) 'let)
+ (if (not (eq (car (cadr args)) 'eshell-do-eval))
(eshell-manipulate "evaluating let args"
(dolist (letarg (car args))
(if (and (listp letarg)
@@ -1076,6 +1060,21 @@ be finished later after the completion of an asynchronous subprocess."
(setcdr letarg
(list (eshell-do-eval
(cadr letarg) synchronous-p)))))))
+ (cl-progv
+ (mapcar (lambda (binding) (if (consp binding) (car binding) binding))
+ (car args))
+ ;; These expressions should all be constants now.
+ (mapcar (lambda (binding) (if (consp binding) (eval (cadr binding))))
+ (car args))
+ (eshell-do-eval (macroexp-progn (cdr args)) synchronous-p)))
+ ((memq (car form) '(catch condition-case unwind-protect))
+ ;; `condition-case' and `unwind-protect' have to be
+ ;; handled specially, because we only want to call
+ ;; `eshell-do-eval' on their first form.
+ ;;
+ ;; NOTE: This requires obedience by all forms which this
+ ;; function might encounter, that they do not contain
+ ;; other special forms.
(unless (eq (car form) 'unwind-protect)
(setq args (cdr args)))
(unless (eq (caar args) 'eshell-do-eval)
@@ -1158,10 +1157,9 @@ be finished later after the completion of an asynchronous subprocess."
(setq name (substring name 1)
direct t))
(if (and (not direct)
- (eshell-using-module 'eshell-alias)
+ (fboundp 'eshell-lookup-alias)
(setq alias
- (funcall (symbol-function 'eshell-lookup-alias)
- name)))
+ (eshell-lookup-alias name)))
(setq program
(concat name " is an alias, defined as \""
(cadr alias) "\"")))
@@ -1341,7 +1339,7 @@ messages, and errors."
(eshell-print "\n"))
(eshell-close-handles 0 (list 'quote result)))))
-(defalias 'eshell-lisp-command* 'eshell-lisp-command)
+(defalias 'eshell-lisp-command* #'eshell-lisp-command)
(provide 'esh-cmd)
diff --git a/lisp/eshell/esh-ext.el b/lisp/eshell/esh-ext.el
index fccdb73b31e..978fc55c4de 100644
--- a/lisp/eshell/esh-ext.el
+++ b/lisp/eshell/esh-ext.el
@@ -31,17 +31,12 @@
;;; Code:
-(provide 'esh-ext)
-
(require 'esh-util)
-(eval-when-compile
- (require 'cl-lib)
- (require 'esh-io)
- (require 'esh-cmd))
+(eval-when-compile (require 'cl-lib))
+(require 'esh-io)
(require 'esh-arg)
(require 'esh-opt)
-(require 'esh-proc)
(defgroup eshell-ext nil
"External commands are invoked when operating system executables are
@@ -177,9 +172,9 @@ external version."
;;; Functions:
-(defun eshell-ext-initialize ()
+(defun eshell-ext-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the external command handling code."
- (add-hook 'eshell-named-command-hook 'eshell-explicit-command nil t))
+ (add-hook 'eshell-named-command-hook #'eshell-explicit-command nil t))
(defun eshell-explicit-command (command args)
"If a command name begins with `*', call it externally always.
@@ -193,8 +188,6 @@ This bypasses all Lisp functions and aliases."
(error "%s: external command not found"
(substring command 1))))))
-(autoload 'eshell-close-handles "esh-io")
-
(defun eshell-remote-command (command args)
"Insert output from a remote COMMAND, using ARGS.
A remote command is something that executes on a different machine.
@@ -211,7 +204,7 @@ causing the user to wonder if anything's really going on..."
(progn
(setq exitcode
(shell-command
- (mapconcat 'shell-quote-argument
+ (mapconcat #'shell-quote-argument
(append (list command) args) " ")
outbuf errbuf))
(eshell-print (with-current-buffer outbuf (buffer-string)))
@@ -222,7 +215,7 @@ causing the user to wonder if anything's really going on..."
(defun eshell-external-command (command args)
"Insert output from an external COMMAND, using ARGS."
- (setq args (eshell-stringify-list (eshell-flatten-list args)))
+ (setq args (eshell-stringify-list (flatten-tree args)))
(let ((interp (eshell-find-interpreter
command
args
@@ -235,6 +228,8 @@ causing the user to wonder if anything's really going on..."
(cl-assert interp)
(if (functionp (car interp))
(apply (car interp) (append (cdr interp) args))
+ (require 'esh-proc)
+ (declare-function eshell-gather-process-output "esh-proc" (command args))
(eshell-gather-process-output
(car interp) (append (cdr interp) args)))))
@@ -249,7 +244,7 @@ Adds the given PATH to $PATH.")
(if args
(progn
(setq eshell-path-env (getenv "PATH")
- args (mapconcat 'identity args path-separator)
+ args (mapconcat #'identity args path-separator)
eshell-path-env
(if prepend
(concat args path-separator eshell-path-env)
@@ -336,4 +331,5 @@ line of the form #!<interp>."
(cdr interp)))))
(or interp (list fullname)))))))
+(provide 'esh-ext)
;;; esh-ext.el ends here
diff --git a/lisp/eshell/esh-io.el b/lisp/eshell/esh-io.el
index c33e7325a82..ce1d021384d 100644
--- a/lisp/eshell/esh-io.el
+++ b/lisp/eshell/esh-io.el
@@ -68,8 +68,6 @@
;;; Code:
-(provide 'esh-io)
-
(require 'esh-arg)
(require 'esh-util)
@@ -171,7 +169,7 @@ not be added to this variable."
;;; Functions:
-(defun eshell-io-initialize ()
+(defun eshell-io-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the I/O subsystem code."
(add-hook 'eshell-parse-argument-hook
'eshell-parse-redirection nil t)
@@ -511,4 +509,5 @@ Returns what was actually sent, or nil if nothing was sent."
(eshell-output-object-to-target object (car target))
(setq target (cdr target))))))
+(provide 'esh-io)
;;; esh-io.el ends here
diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el
index be6123f21ba..cff29bed1b6 100644
--- a/lisp/eshell/esh-mode.el
+++ b/lisp/eshell/esh-mode.el
@@ -58,13 +58,10 @@
;;; Code:
-(provide 'esh-mode)
-
(require 'esh-util)
(require 'esh-module)
(require 'esh-cmd)
-(require 'esh-io)
-(require 'esh-var)
+(require 'esh-arg) ;For eshell-parse-arguments
(defgroup eshell-mode nil
"This module contains code for handling input from the user."
@@ -182,10 +179,11 @@ inserted. They return the string as it should be inserted."
:group 'eshell-mode)
(defcustom eshell-password-prompt-regexp
- (format "\\(%s\\).*:\\s *\\'" (regexp-opt password-word-equivalents))
+ (format "\\(%s\\)[^::៖]*[::៖]\\s *\\'" (regexp-opt password-word-equivalents))
"Regexp matching prompts for passwords in the inferior process.
This is used by `eshell-watch-for-password-prompt'."
:type 'regexp
+ :version "27.1"
:group 'eshell-mode)
(defcustom eshell-skip-prompt-function nil
@@ -201,6 +199,12 @@ This is used by `eshell-watch-for-password-prompt'."
:type 'boolean
:group 'eshell-mode)
+(defcustom eshell-directory-name
+ (locate-user-emacs-file "eshell/" ".eshell/")
+ "The directory where Eshell control files should be kept."
+ :type 'directory
+ :group 'eshell)
+
(defvar eshell-first-time-p t
"A variable which is non-nil the first time Eshell is loaded.")
@@ -291,7 +295,7 @@ and the hook `eshell-exit-hook'."
;; It's fine to run this unconditionally since it can be customized
;; via the `eshell-kill-processes-on-exit' variable.
(and (fboundp 'eshell-query-kill-processes)
- (not (memq 'eshell-query-kill-processes eshell-exit-hook))
+ (not (memq #'eshell-query-kill-processes eshell-exit-hook))
(eshell-query-kill-processes))
(run-hooks 'eshell-exit-hook))
@@ -333,7 +337,6 @@ and the hook `eshell-exit-hook'."
(define-key eshell-command-map [(control ?b)] 'eshell-backward-argument)
(define-key eshell-command-map [(control ?e)] 'eshell-show-maximum-output)
(define-key eshell-command-map [(control ?f)] 'eshell-forward-argument)
- (define-key eshell-command-map [return] 'eshell-copy-old-input)
(define-key eshell-command-map [(control ?m)] 'eshell-copy-old-input)
(define-key eshell-command-map [(control ?o)] 'eshell-kill-output)
(define-key eshell-command-map [(control ?r)] 'eshell-show-output)
@@ -409,23 +412,23 @@ and the hook `eshell-exit-hook'."
(when (and load-hook (boundp load-hook))
(if (memq initfunc (symbol-value load-hook)) (setq initfunc nil))
(run-hooks load-hook))
- ;; So we don't need the -initialize functions on the hooks (b#5375).
+ ;; So we don't need the -initialize functions on the hooks (bug#5375).
(and initfunc (fboundp initfunc) (funcall initfunc))))
(if eshell-send-direct-to-subprocesses
- (add-hook 'pre-command-hook 'eshell-intercept-commands t t))
+ (add-hook 'pre-command-hook #'eshell-intercept-commands t t))
(if eshell-scroll-to-bottom-on-input
- (add-hook 'pre-command-hook 'eshell-preinput-scroll-to-bottom t t))
+ (add-hook 'pre-command-hook #'eshell-preinput-scroll-to-bottom t t))
(when eshell-scroll-show-maximum-output
(set (make-local-variable 'scroll-conservatively) 1000))
(when eshell-status-in-mode-line
- (add-hook 'eshell-pre-command-hook 'eshell-command-started nil t)
- (add-hook 'eshell-post-command-hook 'eshell-command-finished nil t))
+ (add-hook 'eshell-pre-command-hook #'eshell-command-started nil t)
+ (add-hook 'eshell-post-command-hook #'eshell-command-finished nil t))
- (add-hook 'kill-buffer-hook 'eshell-kill-buffer-function t t)
+ (add-hook 'kill-buffer-hook #'eshell-kill-buffer-function t t)
(if eshell-first-time-p
(run-hooks 'eshell-first-time-mode-hook))
@@ -450,10 +453,10 @@ and the hook `eshell-exit-hook'."
(if eshell-send-direct-to-subprocesses
(progn
(setq eshell-send-direct-to-subprocesses nil)
- (remove-hook 'pre-command-hook 'eshell-intercept-commands t)
+ (remove-hook 'pre-command-hook #'eshell-intercept-commands t)
(message "Sending subprocess input on RET"))
(setq eshell-send-direct-to-subprocesses t)
- (add-hook 'pre-command-hook 'eshell-intercept-commands t t)
+ (add-hook 'pre-command-hook #'eshell-intercept-commands t t)
(message "Sending subprocess input directly")))
(defun eshell-self-insert-command ()
@@ -542,7 +545,7 @@ and the hook `eshell-exit-hook'."
"Push a mark at the end of the last input text."
(push-mark (1- eshell-last-input-end) t))
-(custom-add-option 'eshell-pre-command-hook 'eshell-push-command-mark)
+(custom-add-option 'eshell-pre-command-hook #'eshell-push-command-mark)
(defsubst eshell-goto-input-start ()
"Goto the start of the last command input.
@@ -550,7 +553,7 @@ Putting this function on `eshell-pre-command-hook' will mimic Plan 9's
9term behavior."
(goto-char eshell-last-input-start))
-(custom-add-option 'eshell-pre-command-hook 'eshell-push-command-mark)
+(custom-add-option 'eshell-pre-command-hook #'eshell-goto-input-start)
(defsubst eshell-interactive-print (string)
"Print STRING to the eshell display buffer."
@@ -884,8 +887,7 @@ If SCROLLBACK is non-nil, clear the scrollback contents."
(interactive)
(if scrollback
(eshell/clear-scrollback)
- (let ((eshell-input-filter-functions
- (remq 'eshell-add-to-history eshell-input-filter-functions)))
+ (let ((eshell-input-filter-functions nil))
(insert (make-string (window-size) ?\n))
(eshell-send-input))))
@@ -1021,4 +1023,5 @@ This function could be in the list `eshell-output-filter-functions'."
(custom-add-option 'eshell-output-filter-functions
'eshell-handle-ansi-color)
+(provide 'esh-mode)
;;; esh-mode.el ends here
diff --git a/lisp/eshell/esh-module.el b/lisp/eshell/esh-module.el
index 2583044a446..1911a49a3a4 100644
--- a/lisp/eshell/esh-module.el
+++ b/lisp/eshell/esh-module.el
@@ -22,9 +22,6 @@
;;; Code:
-(provide 'esh-module)
-
-(require 'eshell)
(require 'esh-util)
(defgroup eshell-module nil
@@ -101,4 +98,5 @@ customization group. Example: `eshell-cmpl' for that module."
(unload-feature module)
(message "Unloading %s...done" (symbol-name module))))))
+(provide 'esh-module)
;;; esh-module.el ends here
diff --git a/lisp/eshell/esh-opt.el b/lisp/eshell/esh-opt.el
index 6f37a29004a..3ea5873cafd 100644
--- a/lisp/eshell/esh-opt.el
+++ b/lisp/eshell/esh-opt.el
@@ -23,9 +23,6 @@
;;; Code:
-(provide 'esh-opt)
-
-(require 'esh-ext)
;; Unused.
;; (defgroup eshell-opt nil
@@ -36,6 +33,10 @@
;;; User Functions:
+;; Macro expansion of eshell-eval-using-options refers to eshell-stringify-list
+;; defined in esh-util.
+(require 'esh-util)
+
(defmacro eshell-eval-using-options (name macro-args options &rest body-forms)
"Process NAME's MACRO-ARGS using a set of command line OPTIONS.
After doing so, stores settings in local symbols as declared by OPTIONS;
@@ -77,9 +78,13 @@ arguments, some do not. The recognized :KEYWORDS are:
arguments.
:preserve-args
- If present, do not pass MACRO-ARGS through `eshell-flatten-list'
+ If present, do not pass MACRO-ARGS through `flatten-tree'
and `eshell-stringify-list'.
+:parse-leading-options-only
+ If present, do not parse dash or switch arguments after the first
+positional argument. Instead, treat them as positional arguments themselves.
+
For example, OPTIONS might look like:
((?C nil nil multi-column \"multi-column display\")
@@ -95,14 +100,14 @@ BODY-FORMS. If instead an external command is run (because of
an unknown option), the tag `eshell-external' will be thrown with
the new process for its value.
-Lastly, any remaining arguments will be available in a locally
-interned variable `args' (created using a `let' form)."
+Lastly, any remaining arguments will be available in the locally
+let-bound variable `args'."
(declare (debug (form form sexp body)))
`(let* ((temp-args
,(if (memq ':preserve-args (cadr options))
macro-args
(list 'eshell-stringify-list
- (list 'eshell-flatten-list macro-args))))
+ (list 'flatten-tree macro-args))))
(processed-args (eshell--do-opts ,name ,options temp-args))
,@(delete-dups
(delq nil (mapcar (lambda (opt)
@@ -111,6 +116,8 @@ interned variable `args' (created using a `let' form)."
;; `options' is of the form (quote OPTS).
(cadr options))))
(args processed-args))
+ ;; Silence unused lexical variable warning if body does not use `args'.
+ (ignore args)
,@body-forms))
;;; Internal Functions:
@@ -121,6 +128,8 @@ interned variable `args' (created using a `let' form)."
(defun eshell--do-opts (name options args)
"Helper function for `eshell-eval-using-options'.
This code doesn't really need to be macro expanded everywhere."
+ (require 'esh-ext)
+ (declare-function eshell-external-command "esh-ext" (command args))
(let ((ext-command
(catch 'eshell-ext-command
(let ((usage-msg
@@ -139,6 +148,8 @@ This code doesn't really need to be macro expanded everywhere."
(defun eshell-show-usage (name options)
"Display the usage message for NAME, using OPTIONS."
+ (require 'esh-ext)
+ (declare-function eshell-search-path "esh-ext" (name))
(let ((usage (format "usage: %s %s\n\n" name
(cadr (memq ':usage options))))
(extcmd (memq ':external options))
@@ -194,11 +205,7 @@ will be modified."
(if (eq (nth 2 opt) t)
(if (> ai (length eshell--args))
(error "%s: missing option argument" name)
- (prog1 (nth ai eshell--args)
- (if (> ai 0)
- (setcdr (nthcdr (1- ai) eshell--args)
- (nthcdr (1+ ai) eshell--args))
- (setq eshell--args (cdr eshell--args)))))
+ (pop (nthcdr ai eshell--args)))
(or (nth 2 opt) t)))))
(defun eshell--process-option (name switch kind ai options opt-vals)
@@ -243,18 +250,22 @@ switch is unrecognized."
(list sym)))))
options)))
(ai 0) arg
- (eshell--args args))
- (while (< ai (length eshell--args))
+ (eshell--args args)
+ (pos-argument-found nil))
+ (while (and (< ai (length eshell--args))
+ ;; Abort if we saw the first pos argument and option is set
+ (not (and pos-argument-found
+ (memq :parse-leading-options-only options))))
(setq arg (nth ai eshell--args))
(if (not (and (stringp arg)
(string-match "^-\\(-\\)?\\(.*\\)" arg)))
- (setq ai (1+ ai))
+ ;; Positional argument found, skip
+ (setq ai (1+ ai)
+ pos-argument-found t)
+ ;; dash or switch argument found, parse
(let* ((dash (match-string 1 arg))
(switch (match-string 2 arg)))
- (if (= ai 0)
- (setq eshell--args (cdr eshell--args))
- (setcdr (nthcdr (1- ai) eshell--args)
- (nthcdr (1+ ai) eshell--args)))
+ (pop (nthcdr ai eshell--args))
(if dash
(if (> (length switch) 0)
(eshell--process-option name switch 1 ai options opt-vals)
@@ -267,4 +278,5 @@ switch is unrecognized."
(setq index (1+ index))))))))
(nconc (mapcar #'cdr opt-vals) eshell--args)))
+(provide 'esh-opt)
;;; esh-opt.el ends here
diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el
index 33ec19ae36d..d538ae32b37 100644
--- a/lisp/eshell/esh-proc.el
+++ b/lisp/eshell/esh-proc.el
@@ -23,9 +23,7 @@
;;; Code:
-(provide 'esh-proc)
-
-(require 'esh-cmd)
+(require 'esh-io)
(defgroup eshell-proc nil
"When Eshell invokes external commands, it always does so
@@ -118,14 +116,17 @@ information, for example."
Runs `eshell-reset-after-proc' and `eshell-kill-hook', passing arguments
PROC and STATUS to functions on the latter."
;; Was there till 24.1, but it is not optional.
- (if (memq 'eshell-reset-after-proc eshell-kill-hook)
- (setq eshell-kill-hook (delq 'eshell-reset-after-proc eshell-kill-hook)))
+ (if (memq #'eshell-reset-after-proc eshell-kill-hook)
+ (setq eshell-kill-hook (delq #'eshell-reset-after-proc eshell-kill-hook)))
(eshell-reset-after-proc status)
(run-hook-with-args 'eshell-kill-hook proc status))
-(defun eshell-proc-initialize ()
+(defun eshell-proc-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the process handling code."
(make-local-variable 'eshell-process-list)
+ ;; This is supposedly run after enabling esh-mode, when eshell-command-map
+ ;; already exists.
+ (defvar eshell-command-map)
(define-key eshell-command-map [(meta ?i)] 'eshell-insert-process)
(define-key eshell-command-map [(control ?c)] 'eshell-interrupt-process)
(define-key eshell-command-map [(control ?k)] 'eshell-kill-process)
@@ -139,9 +140,11 @@ PROC and STATUS to functions on the latter."
"Reset the command input location after a process terminates.
The signals which will cause this to happen are matched by
`eshell-reset-signals'."
- (if (and (stringp status)
- (string-match eshell-reset-signals status))
- (eshell-reset)))
+ (when (and (stringp status)
+ (string-match eshell-reset-signals status))
+ (require 'esh-mode)
+ (declare-function eshell-reset "esh-mode" (&optional no-hooks))
+ (eshell-reset)))
(defun eshell-wait-for-process (&rest procs)
"Wait until PROC has successfully completed."
@@ -158,7 +161,7 @@ The signals which will cause this to happen are matched by
(defalias 'eshell/wait 'eshell-wait-for-process)
-(defun eshell/jobs (&rest args)
+(defun eshell/jobs (&rest _args)
"List processes, if there are any."
(and (fboundp 'process-list)
(process-list)
@@ -167,7 +170,8 @@ The signals which will cause this to happen are matched by
(defun eshell/kill (&rest args)
"Kill processes.
Usage: kill [-<signal>] <pid>|<process> ...
-Accepts PIDs and process objects."
+Accepts PIDs and process objects. Optionally accept signals
+and signal names."
;; If the first argument starts with a dash, treat it as the signal
;; specifier.
(let ((signum 'SIGINT))
@@ -178,12 +182,12 @@ Accepts PIDs and process objects."
((string-match "\\`-[[:digit:]]+\\'" arg)
(setq signum (abs (string-to-number arg))))
((string-match "\\`-\\([[:upper:]]+\\|[[:lower:]]+\\)\\'" arg)
- (setq signum (abs (string-to-number arg)))))
+ (setq signum (intern (substring arg 1)))))
(setq args (cdr args))))
(while args
(let ((arg (if (eshell-processp (car args))
(process-id (car args))
- (car args))))
+ (string-to-number (car args)))))
(when arg
(cond
((null arg)
@@ -198,6 +202,8 @@ Accepts PIDs and process objects."
(setq args (cdr args))))
nil)
+(put 'eshell/kill 'eshell-no-numeric-conversions t)
+
(defun eshell-read-process-name (prompt)
"Read the name of a process from the minibuffer, using completion.
The prompt will be set to PROMPT."
@@ -206,7 +212,8 @@ The prompt will be set to PROMPT."
(function
(lambda (proc)
(cons (process-name proc) t)))
- (process-list)) nil t))
+ (process-list))
+ nil t))
(defun eshell-insert-process (process)
"Insert the name of PROCESS into the current buffer at point."
@@ -217,10 +224,12 @@ The prompt will be set to PROMPT."
(defsubst eshell-record-process-object (object)
"Record OBJECT as now running."
- (if (and (eshell-processp object)
- eshell-current-subjob-p)
- (eshell-interactive-print
- (format "[%s] %d\n" (process-name object) (process-id object))))
+ (when (and (eshell-processp object)
+ eshell-current-subjob-p)
+ (require 'esh-mode)
+ (declare-function eshell-interactive-print "esh-mode" (string))
+ (eshell-interactive-print
+ (format "[%s] %d\n" (process-name object) (process-id object))))
(setq eshell-process-list
(cons (list object eshell-current-handles
eshell-current-subjob-p nil nil)
@@ -251,7 +260,7 @@ the full name of a command, otherwise just the nondirectory part must match.")
(defun eshell-needs-pipe-p (command)
"Return non-nil if COMMAND needs `process-connection-type' to be nil.
See `eshell-needs-pipe'."
- (and eshell-in-pipeline-p
+ (and (bound-and-true-p eshell-in-pipeline-p)
(not (eq eshell-in-pipeline-p 'first))
;; FIXME should this return non-nil for anything that is
;; neither 'first nor 'last? See bug#1388 discussion.
@@ -264,6 +273,8 @@ See `eshell-needs-pipe'."
(defun eshell-gather-process-output (command args)
"Gather the output from COMMAND + ARGS."
+ (require 'esh-var)
+ (declare-function eshell-environment-variables "esh-var" ())
(unless (and (file-executable-p command)
(file-regular-p (file-truename command)))
(error "%s: not an executable file" command))
@@ -280,14 +291,14 @@ See `eshell-needs-pipe'."
(unless (eshell-needs-pipe-p command)
process-connection-type))
(command (file-local-name (expand-file-name command))))
- (apply 'start-file-process
+ (apply #'start-file-process
(file-name-nondirectory command) nil command args)))
(eshell-record-process-object proc)
(set-process-buffer proc (current-buffer))
- (if (eshell-interactive-output-p)
- (set-process-filter proc 'eshell-output-filter)
- (set-process-filter proc 'eshell-insertion-filter))
- (set-process-sentinel proc 'eshell-sentinel)
+ (set-process-filter proc (if (eshell-interactive-output-p)
+ #'eshell-output-filter
+ #'eshell-insertion-filter))
+ (set-process-sentinel proc #'eshell-sentinel)
(run-hook-with-args 'eshell-exec-hook proc)
(when (fboundp 'process-coding-system)
(let ((coding-systems (process-coding-system proc)))
@@ -322,14 +333,14 @@ See `eshell-needs-pipe'."
(set-buffer oldbuf)
(run-hook-with-args 'eshell-exec-hook command)
(setq exit-status
- (apply 'call-process-region
+ (apply #'call-process-region
(append (list eshell-last-sync-output-start (point)
command t
eshell-scratch-buffer nil)
args)))
;; When in a pipeline, record the place where the output of
;; this process will begin.
- (and eshell-in-pipeline-p
+ (and (bound-and-true-p eshell-in-pipeline-p)
(set-marker eshell-last-sync-output-start (point)))
;; Simulate the effect of the process filter.
(when (numberp exit-status)
@@ -346,11 +357,14 @@ See `eshell-needs-pipe'."
(setq lbeg lend)
(set-buffer proc-buf))
(set-buffer oldbuf))
+ (require 'esh-mode)
+ (declare-function eshell-update-markers "esh-mode" (pmark))
+ (defvar eshell-last-output-end) ;Defined in esh-mode.el.
(eshell-update-markers eshell-last-output-end)
;; Simulate the effect of eshell-sentinel.
(eshell-close-handles (if (numberp exit-status) exit-status -1))
(eshell-kill-process-function command exit-status)
- (or eshell-in-pipeline-p
+ (or (bound-and-true-p eshell-in-pipeline-p)
(setq eshell-last-sync-output-start nil))
(if (not (numberp exit-status))
(error "%s: external command failed: %s" command exit-status))
@@ -495,7 +509,7 @@ See the variable `eshell-kill-processes-on-exit'."
(buffer-name))))
(eshell-round-robin-kill
(if (eq eshell-kill-processes-on-exit 'every)
- (format-message "Kill Eshell child process `%s'? "))))
+ "Kill Eshell child process `%s'? ")))
(let ((buf (get-buffer "*Process List*")))
(if (and buf (buffer-live-p buf))
(kill-buffer buf)))
@@ -537,7 +551,11 @@ See the variable `eshell-kill-processes-on-exit'."
(defun eshell-send-eof-to-process ()
"Send EOF to process."
(interactive)
+ (require 'esh-mode)
+ (declare-function eshell-send-input "esh-mode"
+ (&optional use-region queue-p no-newline))
(eshell-send-input nil nil t)
(eshell-process-interact 'process-send-eof))
+(provide 'esh-proc)
;;; esh-proc.el ends here
diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el
index f8dd6f08f45..6f355c70a42 100644
--- a/lisp/eshell/esh-util.el
+++ b/lisp/eshell/esh-util.el
@@ -285,17 +285,9 @@ Prepend remote identification of `default-directory', if any."
,@forms)
(setq list-iter (cdr list-iter)))))
-(defun eshell-flatten-list (args)
- "Flatten any lists within ARGS, so that there are no sublists."
- (let ((new-list (list t)))
- (dolist (a args)
- (if (and (listp a)
- (listp (cdr a)))
- (nconc new-list (eshell-flatten-list a))
- (nconc new-list (list a))))
- (cdr new-list)))
-
-(defun eshell-uniqify-list (l)
+(define-obsolete-function-alias 'eshell-flatten-list #'flatten-tree "27.1")
+
+(defun eshell-uniquify-list (l)
"Remove occurring multiples in L. You probably want to sort first."
(let ((m l))
(while m
@@ -305,6 +297,9 @@ Prepend remote identification of `default-directory', if any."
(setcdr m (cddr m)))
(setq m (cdr m))))
l)
+(define-obsolete-function-alias
+ 'eshell-uniqify-list
+ 'eshell-uniquify-list "27.1")
(defun eshell-stringify (object)
"Convert OBJECT into a string value."
@@ -327,7 +322,7 @@ Prepend remote identification of `default-directory', if any."
(defsubst eshell-flatten-and-stringify (&rest args)
"Flatten and stringify all of the ARGS into a single string."
- (mapconcat 'eshell-stringify (eshell-flatten-list args) " "))
+ (mapconcat 'eshell-stringify (flatten-tree args) " "))
(defsubst eshell-directory-files (regexp &optional directory)
"Return a list of files in the given DIRECTORY matching REGEXP."
@@ -444,7 +439,7 @@ list."
(not (symbol-value timestamp-var))
(time-less-p
(symbol-value timestamp-var)
- (nth 5 (file-attributes file))))
+ (file-attribute-modification-time (file-attributes file))))
(progn
(set result-var (eshell-read-passwd-file file))
(set timestamp-var (current-time))))
@@ -483,24 +478,22 @@ list."
(insert-file-contents (or filename eshell-hosts-file))
(goto-char (point-min))
(while (re-search-forward
- "^\\([^#[:space:]]+\\)\\s-+\\(\\S-+\\)\\(\\s-*\\(\\S-+\\)\\)?" nil t)
- (if (match-string 1)
- (cl-pushnew (match-string 1) hosts :test #'equal))
- (if (match-string 2)
- (cl-pushnew (match-string 2) hosts :test #'equal))
- (if (match-string 4)
- (cl-pushnew (match-string 4) hosts :test #'equal))))
- (sort hosts #'string-lessp)))
+ ;; "^ \t\\([^# \t\n]+\\)[ \t]+\\([^ \t\n]+\\)\\([ \t]*\\([^ \t\n]+\\)\\)?"
+ "^[ \t]*\\([^# \t\n]+\\)[ \t]+\\([^ \t\n].+\\)" nil t)
+ (push (cons (match-string 1)
+ (split-string (match-string 2)))
+ hosts)))
+ (nreverse hosts)))
(defun eshell-read-hosts (file result-var timestamp-var)
- "Read the contents of /etc/passwd for user names."
+ "Read the contents of /etc/hosts for host names."
(if (or (not (symbol-value result-var))
(not (symbol-value timestamp-var))
(time-less-p
(symbol-value timestamp-var)
- (nth 5 (file-attributes file))))
+ (file-attribute-modification-time (file-attributes file))))
(progn
- (set result-var (eshell-read-hosts-file file))
+ (set result-var (apply #'nconc (eshell-read-hosts-file file)))
(set timestamp-var (current-time))))
(symbol-value result-var))
@@ -657,7 +650,7 @@ If NOSORT is non-nil, the list is not sorted--its order is unpredictable.
(setcar (nthcdr 0 moment) 0)
(setcar (nthcdr 1 moment) 0)
(setcar (nthcdr 2 moment) 0))
- (apply 'encode-time moment))
+ (encode-time moment))
(ange-ftp-file-modtime (expand-file-name name dir))))
symlink)
(if (string-match "\\(.+\\) -> \\(.+\\)" name)
diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el
index b3f54cf048d..b08a5d242fe 100644
--- a/lisp/eshell/esh-var.el
+++ b/lisp/eshell/esh-var.el
@@ -105,11 +105,12 @@
;;; Code:
-(provide 'esh-var)
-
(require 'esh-util)
(require 'esh-cmd)
(require 'esh-opt)
+(require 'esh-module)
+(require 'esh-arg)
+(require 'esh-io)
(require 'pcomplete)
(require 'env)
@@ -128,60 +129,55 @@ variable value, a subcommand, or even the result of a Lisp form."
(defcustom eshell-var-load-hook nil
"A list of functions to call when loading `eshell-var'."
:version "24.1" ; removed eshell-var-initialize
- :type 'hook
- :group 'eshell-var)
+ :type 'hook)
(defcustom eshell-prefer-lisp-variables nil
"If non-nil, prefer Lisp variables to environment variables."
- :type 'boolean
- :group 'eshell-var)
+ :type 'boolean)
(defcustom eshell-complete-export-definition t
"If non-nil, completing names for `export' shows current definition."
- :type 'boolean
- :group 'eshell-var)
+ :type 'boolean)
(defcustom eshell-modify-global-environment nil
"If non-nil, using `export' changes Emacs's global environment."
- :type 'boolean
- :group 'eshell-var)
+ :type 'boolean)
(defcustom eshell-variable-name-regexp "[A-Za-z0-9_-]+"
"A regexp identifying what constitutes a variable name reference.
Note that this only applies for `$NAME'. If the syntax `$<NAME>' is
used, then NAME can contain any character, including angle brackets,
if they are quoted with a backslash."
- :type 'regexp
- :group 'eshell-var)
+ :type 'regexp)
(defcustom eshell-variable-aliases-list
- '(;; for eshell.el
- ("COLUMNS" (lambda (indices) (window-width)) t)
- ("LINES" (lambda (indices) (window-height)) t)
+ `(;; for eshell.el
+ ("COLUMNS" ,(lambda (_indices) (window-width)) t)
+ ("LINES" ,(lambda (_indices) (window-height)) t)
;; for eshell-cmd.el
- ("_" (lambda (indices)
- (if (not indices)
- (car (last eshell-last-arguments))
- (eshell-apply-indices eshell-last-arguments
- indices))))
+ ("_" ,(lambda (indices)
+ (if (not indices)
+ (car (last eshell-last-arguments))
+ (eshell-apply-indices eshell-last-arguments
+ indices))))
("?" eshell-last-command-status)
("$" eshell-last-command-result)
("0" eshell-command-name)
- ("1" (lambda (indices) (nth 0 eshell-command-arguments)))
- ("2" (lambda (indices) (nth 1 eshell-command-arguments)))
- ("3" (lambda (indices) (nth 2 eshell-command-arguments)))
- ("4" (lambda (indices) (nth 3 eshell-command-arguments)))
- ("5" (lambda (indices) (nth 4 eshell-command-arguments)))
- ("6" (lambda (indices) (nth 5 eshell-command-arguments)))
- ("7" (lambda (indices) (nth 6 eshell-command-arguments)))
- ("8" (lambda (indices) (nth 7 eshell-command-arguments)))
- ("9" (lambda (indices) (nth 8 eshell-command-arguments)))
- ("*" (lambda (indices)
- (if (not indices)
- eshell-command-arguments
- (eshell-apply-indices eshell-command-arguments
- indices)))))
+ ("1" ,(lambda (_indices) (nth 0 eshell-command-arguments)))
+ ("2" ,(lambda (_indices) (nth 1 eshell-command-arguments)))
+ ("3" ,(lambda (_indices) (nth 2 eshell-command-arguments)))
+ ("4" ,(lambda (_indices) (nth 3 eshell-command-arguments)))
+ ("5" ,(lambda (_indices) (nth 4 eshell-command-arguments)))
+ ("6" ,(lambda (_indices) (nth 5 eshell-command-arguments)))
+ ("7" ,(lambda (_indices) (nth 6 eshell-command-arguments)))
+ ("8" ,(lambda (_indices) (nth 7 eshell-command-arguments)))
+ ("9" ,(lambda (_indices) (nth 8 eshell-command-arguments)))
+ ("*" ,(lambda (indices)
+ (if (not indices)
+ eshell-command-arguments
+ (eshell-apply-indices eshell-command-arguments
+ indices)))))
"This list provides aliasing for variable references.
It is very similar in concept to what `eshell-user-aliases-list' does
for commands. Each member of this defines the name of a command,
@@ -197,14 +193,13 @@ function), and the arguments passed to this function would be the list
'(10 20)', and nil."
:type '(repeat (list string sexp
(choice (const :tag "Copy to environment" t)
- (const :tag "Use only in Eshell" nil))))
- :group 'eshell-var)
+ (const :tag "Use only in Eshell" nil)))))
(put 'eshell-variable-aliases-list 'risky-local-variable t)
;;; Functions:
-(defun eshell-var-initialize ()
+(defun eshell-var-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the variable handle code."
;; Break the association with our parent's environment. Otherwise,
;; changing a variable will affect all of Emacs.
@@ -212,6 +207,9 @@ function), and the arguments passed to this function would be the list
(set (make-local-variable 'process-environment)
(eshell-copy-environment)))
+ ;; This is supposedly run after enabling esh-mode, when eshell-command-map
+ ;; already exists.
+ (defvar eshell-command-map)
(define-key eshell-command-map [(meta ?v)] 'eshell-insert-envvar)
(set (make-local-variable 'eshell-special-chars-inside-quoting)
@@ -219,16 +217,16 @@ function), and the arguments passed to this function would be the list
(set (make-local-variable 'eshell-special-chars-outside-quoting)
(append eshell-special-chars-outside-quoting '(?$)))
- (add-hook 'eshell-parse-argument-hook 'eshell-interpolate-variable t t)
+ (add-hook 'eshell-parse-argument-hook #'eshell-interpolate-variable t t)
(add-hook 'eshell-prepare-command-hook
- 'eshell-handle-local-variables nil t)
+ #'eshell-handle-local-variables nil t)
(when (eshell-using-module 'eshell-cmpl)
(add-hook 'pcomplete-try-first-hook
- 'eshell-complete-variable-reference nil t)
+ #'eshell-complete-variable-reference nil t)
(add-hook 'pcomplete-try-first-hook
- 'eshell-complete-variable-assignment nil t)))
+ #'eshell-complete-variable-assignment nil t)))
(defun eshell-handle-local-variables ()
"Allow for the syntax `VAR=val <command> <args>'."
@@ -343,6 +341,8 @@ This function is explicit for adding to `eshell-parse-argument-hook'."
obarray 'boundp))
(pcomplete-here))))
+;; FIXME the real "env" command does more than this, it runs a program
+;; in a modified environment.
(defun eshell/env (&rest args)
"Implementation of `env' in Lisp."
(eshell-init-print-buffer)
@@ -395,6 +395,8 @@ process any indices that come after the variable reference."
indices (and (not (eobp))
(eq (char-after) ?\[)
(eshell-parse-indices))
+ ;; This is an expression that will be evaluated by `eshell-do-eval',
+ ;; which only support let-binding of dynamically-scoped vars
value `(let ((indices ',indices)) ,value))
(if get-len
`(length ,value)
@@ -417,18 +419,17 @@ Possible options are:
(if (not end)
(throw 'eshell-incomplete ?\{)
(prog1
- (list 'eshell-convert
- (list 'eshell-command-to-value
- (list 'eshell-as-subcommand
- (eshell-parse-command
- (cons (1+ (point)) end)))))
+ `(eshell-convert
+ (eshell-command-to-value
+ (eshell-as-subcommand
+ ,(eshell-parse-command (cons (1+ (point)) end)))))
(goto-char (1+ end))))))
((memq (char-after) '(?\' ?\"))
(let ((name (if (eq (char-after) ?\')
(eshell-parse-literal-quote)
(eshell-parse-double-quote))))
(if name
- (list 'eshell-get-variable (eval name) 'indices))))
+ `(eshell-get-variable ,(eval name) indices))))
((eq (char-after) ?\<)
(let ((end (eshell-find-delimiter ?\< ?\>)))
(if (not end)
@@ -437,37 +438,30 @@ Possible options are:
(cmd (concat (buffer-substring (1+ (point)) end)
" > " temp)))
(prog1
- (list
- 'let (list (list 'eshell-current-handles
- (list 'eshell-create-handles temp
- (list 'quote 'overwrite))))
- (list
- 'progn
- (list 'eshell-as-subcommand
- (eshell-parse-command cmd))
- (list 'ignore
- (list 'nconc 'eshell-this-command-hook
- (list 'list
- (list 'function
- (list 'lambda nil
- (list 'delete-file temp))))))
- (list 'quote temp)))
+ `(let ((eshell-current-handles
+ (eshell-create-handles ,temp 'overwrite)))
+ (progn
+ (eshell-as-subcommand ,(eshell-parse-command cmd))
+ (ignore
+ (nconc eshell-this-command-hook
+ (list (function (lambda ()
+ (delete-file ,temp))))))
+ (quote ,temp)))
(goto-char (1+ end)))))))
((eq (char-after) ?\()
(condition-case nil
- (list 'eshell-command-to-value
- (list 'eshell-lisp-command
- (list 'quote (read (current-buffer)))))
+ `(eshell-command-to-value
+ (eshell-lisp-command
+ ',(read (current-buffer))))
(end-of-file
(throw 'eshell-incomplete ?\())))
((assoc (char-to-string (char-after))
eshell-variable-aliases-list)
(forward-char)
- (list 'eshell-get-variable
- (char-to-string (char-before)) 'indices))
+ `(eshell-get-variable ,(char-to-string (char-before)) indices))
((looking-at eshell-variable-name-regexp)
(prog1
- (list 'eshell-get-variable (match-string 0) 'indices)
+ `(eshell-get-variable ,(match-string 0) indices)
(goto-char (match-end 0))))
(t
(error "Invalid variable reference"))))
@@ -542,7 +536,7 @@ For example, to retrieve the second element of a user's record in
(setq separator (caar indices)
refs (cdr refs)))
(setq value
- (mapcar 'eshell-convert
+ (mapcar #'eshell-convert
(split-string value separator)))))
(cond
((< (length refs) 0)
@@ -628,4 +622,5 @@ For example, to retrieve the second element of a user's record in
(setq pcomplete-stub (substring arg pos))
(throw 'pcomplete-completions (pcomplete-entries)))))
+(provide 'esh-var)
;;; esh-var.el ends here
diff --git a/lisp/eshell/eshell.el b/lisp/eshell/eshell.el
index 45168007565..db20f7d9ec5 100644
--- a/lisp/eshell/eshell.el
+++ b/lisp/eshell/eshell.el
@@ -175,7 +175,10 @@
(eval-when-compile
(require 'cl-lib))
(require 'esh-util)
-(require 'esh-mode)
+(require 'esh-module) ;For eshell-using-module
+(require 'esh-proc) ;For eshell-wait-for-process
+(require 'esh-io) ;For eshell-last-command-status
+(require 'esh-cmd)
(defgroup eshell nil
"Command shell implemented entirely in Emacs Lisp.
@@ -217,12 +220,6 @@ shells such as bash, zsh, rc, 4dos."
:type 'string
:group 'eshell)
-(defcustom eshell-directory-name
- (locate-user-emacs-file "eshell/" ".eshell/")
- "The directory where Eshell control files should be kept."
- :type 'directory
- :group 'eshell)
-
;;;_* Running Eshell
;;
;; There are only three commands used to invoke Eshell. The first two
@@ -256,11 +253,12 @@ buffer selected (or created)."
buf))
(defun eshell-return-exits-minibuffer ()
+ ;; This is supposedly run after enabling esh-mode, when eshell-mode-map
+ ;; already exists.
+ (defvar eshell-mode-map)
(define-key eshell-mode-map [(control ?g)] 'abort-recursive-edit)
- (define-key eshell-mode-map [return] 'exit-minibuffer)
(define-key eshell-mode-map [(control ?m)] 'exit-minibuffer)
(define-key eshell-mode-map [(control ?j)] 'exit-minibuffer)
- (define-key eshell-mode-map [(meta return)] 'exit-minibuffer)
(define-key eshell-mode-map [(meta control ?m)] 'exit-minibuffer))
(defvar eshell-non-interactive-p nil
@@ -275,7 +273,6 @@ non-interactive sessions, such as when using `eshell-command'.")
"Execute the Eshell command string COMMAND.
With prefix ARG, insert output into the current buffer at point."
(interactive)
- (require 'esh-cmd)
(unless arg
(setq arg current-prefix-arg))
(let ((eshell-non-interactive-p t))
@@ -363,7 +360,8 @@ corresponding to a successful execution."
(let ((result (eshell-do-eval
(list 'eshell-commands
(list 'eshell-command-to-value
- (eshell-parse-command command))) t)))
+ (eshell-parse-command command)))
+ t)))
(cl-assert (eq (car result) 'quote))
(if (and status-var (symbolp status-var))
(set status-var eshell-last-command-status))
@@ -404,5 +402,4 @@ Emacs."
(run-hooks 'eshell-load-hook)
(provide 'eshell)
-
;;; eshell.el ends here
diff --git a/lisp/face-remap.el b/lisp/face-remap.el
index 5a1c44f2096..1a0cc646c35 100644
--- a/lisp/face-remap.el
+++ b/lisp/face-remap.el
@@ -229,9 +229,6 @@ Each positive or negative step scales the default face height by this amount."
(define-minor-mode text-scale-mode
"Minor mode for displaying buffer text in a larger/smaller font.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
The amount of scaling is determined by the variable
`text-scale-mode-amount': one step scales the global default
@@ -387,10 +384,9 @@ plist, etc."
;;;###autoload
(define-minor-mode buffer-face-mode
"Minor mode for a buffer-specific default face.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil. When enabled, the face specified by the
-variable `buffer-face-mode-face' is used to display the buffer text."
+
+When enabled, the face specified by the variable
+`buffer-face-mode-face' is used to display the buffer text."
:lighter " BufFace"
(when buffer-face-mode-remapping
(face-remap-remove-relative buffer-face-mode-remapping))
diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index ddba3f20ea5..44b3941b24d 100644
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -188,6 +188,8 @@ it will remove any faces not explicitly in the list."
(let ((map (make-sparse-keymap "Special")))
(define-key map [?s] (cons (purecopy "Remove Special")
'facemenu-remove-special))
+ (define-key map [?c] (cons (purecopy "Charset")
+ 'facemenu-set-charset))
(define-key map [?t] (cons (purecopy "Intangible")
'facemenu-set-intangible))
(define-key map [?v] (cons (purecopy "Invisible")
@@ -433,6 +435,28 @@ This sets the `read-only' text property; it can be undone with
(interactive "r")
(add-text-properties start end '(read-only t)))
+(defun facemenu-set-charset (cset &optional start end)
+ "Apply CHARSET text property to the region or next character typed.
+
+If the region is active (normally true except in Transient
+Mark mode) and nonempty, and there is no prefix argument,
+this command adds CHARSET property to the region. Otherwise, it
+sets the CHARSET property of the character at point."
+ (interactive (list (progn
+ (barf-if-buffer-read-only)
+ (read-charset
+ (format "Use charset (default %s): " (charset-after))
+ (charset-after)))
+ (if (and mark-active (not current-prefix-arg))
+ (region-beginning))
+ (if (and mark-active (not current-prefix-arg))
+ (region-end))))
+ (or start
+ (setq start (min (point) (1- (point-max)))
+ end (1+ start)))
+ (remove-text-properties start end '(charset nil))
+ (put-text-property start end 'charset cset))
+
(defun facemenu-remove-face-props (start end)
"Remove `face' and `mouse-face' text properties."
(interactive "*r") ; error if buffer is read-only despite the next line.
@@ -452,7 +476,7 @@ These special properties include `invisible', `intangible' and `read-only'."
(interactive "*r") ; error if buffer is read-only despite the next line.
(let ((inhibit-read-only t))
(remove-text-properties
- start end '(invisible nil intangible nil read-only nil))))
+ start end '(invisible nil intangible nil read-only nil charset nil))))
(defalias 'facemenu-read-color 'read-color)
@@ -614,7 +638,7 @@ color. The function should accept a single argument, the color name."
(insert " ")
(insert (propertize
(apply 'format "#%02x%02x%02x"
- (mapcar (lambda (c) (lsh c -8))
+ (mapcar (lambda (c) (ash c -8))
color-values))
'mouse-face 'highlight
'help-echo
diff --git a/lisp/faces.el b/lisp/faces.el
index 3ed98f651f1..fa526c35061 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -55,6 +55,7 @@ This means to treat a terminal of type TYPE as if it were of type ALIAS."
:group 'terminals
:version "25.1")
+(declare-function display-graphic-p "frame" (&optional display))
(declare-function xw-defined-colors "term/common-win" (&optional frame))
(defvar help-xref-stack-item)
@@ -1084,27 +1085,27 @@ of a set of discrete values. Value is `integerp' if ATTRIBUTE expects
an integer value."
(let ((valid
(pcase attribute
- (`:family
+ (:family
(if (window-system frame)
(mapcar (lambda (x) (cons x x))
(font-family-list))
;; Only one font on TTYs.
(list (cons "default" "default"))))
- (`:foundry
+ (:foundry
(list nil))
- (`:width
+ (:width
(mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
font-width-table))
- (`:weight
+ (:weight
(mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
font-weight-table))
- (`:slant
+ (:slant
(mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
font-slant-table))
- (`:inverse-video
+ (:inverse-video
(mapcar #'(lambda (x) (cons (symbol-name x) x))
(internal-lisp-face-attribute-values attribute)))
- ((or `:underline `:overline `:strike-through `:box)
+ ((or :underline :overline :strike-through :box)
(if (window-system frame)
(nconc (mapcar #'(lambda (x) (cons (symbol-name x) x))
(internal-lisp-face-attribute-values attribute))
@@ -1112,12 +1113,12 @@ an integer value."
(defined-colors frame)))
(mapcar #'(lambda (x) (cons (symbol-name x) x))
(internal-lisp-face-attribute-values attribute))))
- ((or `:foreground `:background)
+ ((or :foreground :background)
(mapcar #'(lambda (c) (cons c c))
(defined-colors frame)))
- (`:height
+ (:height
'integerp)
- (`:stipple
+ (:stipple
(and (memq (window-system frame) '(x ns)) ; No stipple on w32
(mapcar #'list
(apply #'nconc
@@ -1126,7 +1127,7 @@ an integer value."
(file-directory-p dir)
(directory-files dir)))
x-bitmap-file-path)))))
- (`:inherit
+ (:inherit
(cons '("none" . nil)
(mapcar #'(lambda (c) (cons (symbol-name c) c))
(face-list))))
@@ -1239,7 +1240,7 @@ of a global face. Value is the new attribute value."
;; explicitly in VALID, using color approximation code
;; in tty-colors.el.
(when (and (memq attribute '(:foreground :background))
- (not (memq (window-system frame) '(x w32 ns)))
+ (not (display-graphic-p frame))
(not (member new-value
'("unspecified"
"unspecified-fg" "unspecified-bg"))))
@@ -1833,7 +1834,7 @@ The argument FRAME specifies which frame to try.
The value may be different for frames on different display types.
If FRAME doesn't support colors, the value is nil.
If FRAME is nil, that stands for the selected frame."
- (if (memq (framep (or frame (selected-frame))) '(x w32 ns))
+ (if (display-graphic-p frame)
(xw-defined-colors frame)
(mapcar 'car (tty-color-alist frame))))
(defalias 'x-defined-colors 'defined-colors)
@@ -1877,7 +1878,7 @@ or one of the strings \"unspecified-fg\" or \"unspecified-bg\".
If FRAME is omitted or nil, use the selected frame."
(unless (member color '(unspecified "unspecified-bg" "unspecified-fg"))
- (if (member (framep (or frame (selected-frame))) '(x w32 ns))
+ (if (display-graphic-p frame)
(xw-color-defined-p color frame)
(numberp (tty-color-translate color frame)))))
(defalias 'x-color-defined-p 'color-defined-p)
@@ -1903,7 +1904,7 @@ return value is nil."
(cond
((member color '(unspecified "unspecified-fg" "unspecified-bg"))
nil)
- ((memq (framep (or frame (selected-frame))) '(x w32 ns))
+ ((display-graphic-p frame)
(xw-color-values color frame))
(t
(tty-color-values color frame))))
@@ -1917,7 +1918,7 @@ return value is nil."
The optional argument DISPLAY specifies which display to ask about.
DISPLAY should be either a frame or a display name (a string).
If omitted or nil, that stands for the selected frame's display."
- (if (memq (framep-on-display display) '(x w32 ns))
+ (if (display-graphic-p display)
(xw-display-color-p display)
(tty-display-color-p display)))
(defalias 'x-display-color-p 'display-color-p)
@@ -1928,12 +1929,9 @@ If omitted or nil, that stands for the selected frame's display."
"Return non-nil if frames on DISPLAY can display shades of gray.
DISPLAY should be either a frame or a display name (a string).
If omitted or nil, that stands for the selected frame's display."
- (let ((frame-type (framep-on-display display)))
- (cond
- ((memq frame-type '(x w32 ns))
- (x-display-grayscale-p display))
- (t
- (> (tty-color-gray-shades display) 2)))))
+ (if (display-graphic-p display)
+ (x-display-grayscale-p display)
+ (> (tty-color-gray-shades display) 2)))
(defun read-color (&optional prompt convert-to-RGB allow-empty-name msg)
"Read a color name or RGB triplet.
diff --git a/lisp/ffap.el b/lisp/ffap.el
index 83bd1d65111..36e37e95fe8 100644
--- a/lisp/ffap.el
+++ b/lisp/ffap.el
@@ -104,6 +104,7 @@
;;; Code:
+(eval-when-compile (require 'cl-lib))
(require 'url-parse)
(require 'thingatpt)
diff --git a/lisp/filecache.el b/lisp/filecache.el
index eb4a64b768f..fb099c1802a 100644
--- a/lisp/filecache.el
+++ b/lisp/filecache.el
@@ -1,4 +1,4 @@
-;;; filecache.el --- find files using a pre-loaded cache
+;;; filecache.el --- find files using a pre-loaded cache -*- lexical-binding:t -*-
;; Copyright (C) 1996, 2000-2019 Free Software Foundation, Inc.
@@ -25,16 +25,16 @@
;;
;; The file-cache package is an attempt to make it easy to locate files
;; by name, without having to remember exactly where they are located.
-;; This is very handy when working with source trees. You can also add
+;; This is very handy when working with source trees. You can also add
;; frequently used files to the cache to create a hotlist effect.
;; The cache can be used with any interactive command which takes a
;; filename as an argument.
;;
;; It is worth noting that this package works best when most of the files
;; in the cache have unique names, or (if they have the same name) exist in
-;; only a few directories. The worst case is many files all with
+;; only a few directories. The worst case is many files all with
;; the same name and in different directories, for example a big source tree
-;; with a Makefile in each directory. In such a case, you should probably
+;; with a Makefile in each directory. In such a case, you should probably
;; use an alternate strategy to find the files.
;;
;; ADDING FILES TO THE CACHE:
@@ -49,11 +49,11 @@
;; `file-cache-delete-regexps' to eliminate unwanted files:
;;
;; * `file-cache-add-directory': Adds the files in a directory to the
-;; cache. You can also specify a regular expression to match the files
+;; cache. You can also specify a regular expression to match the files
;; which should be added.
;;
;; * `file-cache-add-directory-list': Same as above, but acts on a list
-;; of directories. You can use `load-path', `exec-path' and the like.
+;; of directories. You can use `load-path', `exec-path' and the like.
;;
;; * `file-cache-add-directory-using-find': Uses the `find' command to
;; add a directory tree to the cache.
@@ -65,7 +65,7 @@
;; add all files matching a pattern to the cache.
;;
;; Use the function `file-cache-clear-cache' to remove all items from the
-;; cache. There are a number of `file-cache-delete' functions provided
+;; cache. There are a number of `file-cache-delete' functions provided
;; as well, but in general it is probably better to not worry too much
;; about extra files in the cache.
;;
@@ -76,7 +76,7 @@
;; FINDING FILES USING THE CACHE:
;;
;; You can use the file-cache with any function that expects a filename as
-;; an argument. For example:
+;; an argument. For example:
;;
;; 1) Invoke a function which expects a filename as an argument:
;; M-x find-file
@@ -160,13 +160,11 @@ File names which match these expressions will not be added to the cache.
Note that the functions `file-cache-add-file' and `file-cache-add-file-list'
do not use this variable."
:version "25.1" ; added "/\\.#"
- :type '(repeat regexp)
- :group 'file-cache)
+ :type '(repeat regexp))
(defcustom file-cache-find-command "find"
"External program used by `file-cache-add-directory-using-find'."
- :type 'string
- :group 'file-cache)
+ :type 'string)
(defcustom file-cache-find-command-posix-flag 'not-defined
"Set to t, if `file-cache-find-command' handles wildcards POSIX style.
@@ -178,30 +176,25 @@ Under Windows operating system where Cygwin is available, this value
should be t."
:type '(choice (const :tag "Yes" t)
(const :tag "No" nil)
- (const :tag "Unknown" not-defined))
- :group 'file-cache)
+ (const :tag "Unknown" not-defined)))
(defcustom file-cache-locate-command "locate"
"External program used by `file-cache-add-directory-using-locate'."
- :type 'string
- :group 'file-cache)
+ :type 'string)
;; Minibuffer messages
(defcustom file-cache-no-match-message " [File Cache: No match]"
"Message to display when there is no completion."
- :type 'string
- :group 'file-cache)
+ :type 'string)
(defcustom file-cache-sole-match-message " [File Cache: sole completion]"
"Message to display when there is only one completion."
- :type 'string
- :group 'file-cache)
+ :type 'string)
(defcustom file-cache-non-unique-message
" [File Cache: complete but not unique]"
"Message to display when there is a non-unique completion."
- :type 'string
- :group 'file-cache)
+ :type 'string)
(defcustom file-cache-completion-ignore-case
(if (memq system-type '(ms-dos windows-nt cygwin))
@@ -209,8 +202,7 @@ should be t."
completion-ignore-case)
"If non-nil, file-cache completion should ignore case.
Defaults to the value of `completion-ignore-case'."
- :type 'boolean
- :group 'file-cache)
+ :type 'boolean)
(defcustom file-cache-case-fold-search
(if (memq system-type '(ms-dos windows-nt cygwin))
@@ -218,15 +210,13 @@ Defaults to the value of `completion-ignore-case'."
case-fold-search)
"If non-nil, file-cache completion should ignore case.
Defaults to the value of `case-fold-search'."
- :type 'boolean
- :group 'file-cache)
+ :type 'boolean)
(defcustom file-cache-ignore-case
(memq system-type '(ms-dos windows-nt cygwin))
"Non-nil means ignore case when checking completions in the file cache.
Defaults to nil on DOS and Windows, and t on other systems."
- :type 'boolean
- :group 'file-cache)
+ :type 'boolean)
(defvar file-cache-multiple-directory-message nil)
@@ -235,18 +225,10 @@ Defaults to nil on DOS and Windows, and t on other systems."
;; switch-to-completions in simple.el expects
(defcustom file-cache-completions-buffer "*Completions*"
"Buffer to display completions when using the file cache."
- :type 'string
- :group 'file-cache)
+ :type 'string)
-(defcustom file-cache-buffer "*File Cache*"
- "Buffer to hold the cache of file names."
- :type 'string
- :group 'file-cache)
-
-(defcustom file-cache-buffer-default-regexp "^.+$"
- "Regexp to match files in `file-cache-buffer'."
- :type 'regexp
- :group 'file-cache)
+(defvar file-cache-buffer-default-regexp "^.+$"
+ "Regexp to match files in find and locate's output.")
(defvar file-cache-last-completion nil)
@@ -362,36 +344,31 @@ Find is run in DIRECTORY."
(if (eq file-cache-find-command-posix-flag 'not-defined)
(setq file-cache-find-command-posix-flag
(executable-command-find-posix-p file-cache-find-command))))
- (set-buffer (get-buffer-create file-cache-buffer))
- (erase-buffer)
- (call-process file-cache-find-command nil
- (get-buffer file-cache-buffer) nil
- dir "-name"
- (if (memq system-type '(windows-nt cygwin))
- (if file-cache-find-command-posix-flag
- "\\*"
- "'*'")
- "*")
- "-print")
- (file-cache-add-from-file-cache-buffer)))
+ (with-temp-buffer
+ (call-process file-cache-find-command nil t nil
+ dir "-name"
+ (if (memq system-type '(windows-nt cygwin))
+ (if file-cache-find-command-posix-flag
+ "\\*"
+ "'*'")
+ "*")
+ "-print")
+ (file-cache--add-from-buffer))))
;;;###autoload
(defun file-cache-add-directory-using-locate (string)
"Use the `locate' command to add files to the file cache.
STRING is passed as an argument to the locate command."
(interactive "sAdd files using locate string: ")
- (set-buffer (get-buffer-create file-cache-buffer))
- (erase-buffer)
- (call-process file-cache-locate-command nil
- (get-buffer file-cache-buffer) nil
- string)
- (file-cache-add-from-file-cache-buffer))
+ (with-temp-buffer
+ (call-process file-cache-locate-command nil t nil string)
+ (file-cache--add-from-buffer)))
(autoload 'find-lisp-find-files "find-lisp")
;;;###autoload
(defun file-cache-add-directory-recursively (dir &optional regexp)
- "Adds DIR and any subdirectories to the file-cache.
+ "Add DIR and any subdirectories to the file-cache.
This function does not use any external programs.
If the optional REGEXP argument is non-nil, only files which match it
will be added to the cache. Note that the REGEXP is applied to the
@@ -408,22 +385,16 @@ files in each directory, not to the directory list itself."
(file-cache-add-file file)))
(find-lisp-find-files dir (or regexp "^"))))
-(defun file-cache-add-from-file-cache-buffer (&optional regexp)
- "Add any entries found in the file cache buffer.
+(defun file-cache--add-from-buffer ()
+ "Add any entries found in the current buffer.
Each entry matches the regular expression `file-cache-buffer-default-regexp'
or the optional REGEXP argument."
- (set-buffer file-cache-buffer)
(dolist (elt file-cache-filter-regexps)
(goto-char (point-min))
(delete-matching-lines elt))
(goto-char (point-min))
- (let ((full-filename))
- (while (re-search-forward
- (or regexp file-cache-buffer-default-regexp)
- (point-max) t)
- (setq full-filename (buffer-substring-no-properties
- (match-beginning 0) (match-end 0)))
- (file-cache-add-file full-filename))))
+ (while (re-search-forward file-cache-buffer-default-regexp nil t)
+ (file-cache-add-file (match-string-no-properties 0))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Functions to delete from the cache
@@ -566,68 +537,65 @@ the directories that the name is available in. With a prefix argument,
the name is considered already unique; only the second substitution
\(directories) is done."
(interactive "P")
- (let*
- (
- (completion-ignore-case file-cache-completion-ignore-case)
- (case-fold-search file-cache-case-fold-search)
- (string (file-name-nondirectory (minibuffer-contents)))
- (completion-string (try-completion string file-cache-alist))
- (completion-list)
- (len)
- (file-cache-string))
+ (let* ((completion-ignore-case file-cache-completion-ignore-case)
+ (case-fold-search file-cache-case-fold-search)
+ (string (file-name-nondirectory (minibuffer-contents)))
+ (completion (completion-try-completion
+ string file-cache-alist nil 0)))
(cond
;; If it's the only match, replace the original contents
- ((or arg (eq completion-string t))
- (setq file-cache-string (file-cache-file-name string))
- (if (string= file-cache-string (minibuffer-contents))
- (minibuffer-message file-cache-sole-match-message)
- (delete-minibuffer-contents)
- (insert file-cache-string)
- (if file-cache-multiple-directory-message
- (minibuffer-message file-cache-multiple-directory-message))))
+ ((or arg (eq completion t))
+ (let ((file-name (file-cache-file-name string)))
+ (if (string= file-name (minibuffer-contents))
+ (minibuffer-message file-cache-sole-match-message)
+ (delete-minibuffer-contents)
+ (insert file-name)
+ (if file-cache-multiple-directory-message
+ (minibuffer-message file-cache-multiple-directory-message)))))
;; If it's the longest match, insert it
- ((stringp completion-string)
- ;; If we've already inserted a unique string, see if the user
- ;; wants to use that one
- (if (and (string= string completion-string)
- (assoc-string string file-cache-alist
- file-cache-ignore-case))
- (if (and (eq last-command this-command)
- (string= file-cache-last-completion completion-string))
- (progn
- (delete-minibuffer-contents)
- (insert (file-cache-file-name completion-string))
- (setq file-cache-last-completion nil))
- (minibuffer-message file-cache-non-unique-message)
- (setq file-cache-last-completion string))
- (setq file-cache-last-completion string)
- (setq completion-list (all-completions string file-cache-alist)
- len (length completion-list))
- (if (> len 1)
- (progn
- (goto-char (point-max))
- (insert
- (substring completion-string (length string)))
- ;; Add our own setup function to the Completions Buffer
- (let ((completion-setup-hook
- (append completion-setup-hook
- (list 'file-cache-completion-setup-function))))
- (with-output-to-temp-buffer file-cache-completions-buffer
- (display-completion-list
- (completion-hilit-commonality completion-list
- (length string))))))
- (setq file-cache-string (file-cache-file-name completion-string))
- (if (string= file-cache-string (minibuffer-contents))
- (minibuffer-message file-cache-sole-match-message)
- (delete-minibuffer-contents)
- (insert file-cache-string)
- (if file-cache-multiple-directory-message
- (minibuffer-message file-cache-multiple-directory-message)))
- )))
+ ((consp completion)
+ (let ((newstring (car completion))
+ (newpoint (cdr completion)))
+ ;; If we've already inserted a unique string, see if the user
+ ;; wants to use that one
+ (if (and (string= string newstring)
+ (assoc-string string file-cache-alist
+ file-cache-ignore-case))
+ (if (and (eq last-command this-command)
+ (string= file-cache-last-completion newstring))
+ (progn
+ (delete-minibuffer-contents)
+ (insert (file-cache-file-name newstring))
+ (setq file-cache-last-completion nil))
+ (minibuffer-message file-cache-non-unique-message)
+ (setq file-cache-last-completion string))
+ (setq file-cache-last-completion string)
+ (let* ((completion-list (completion-all-completions
+ newstring file-cache-alist nil newpoint))
+ (base-size (cdr (last completion-list))))
+ (when base-size
+ (setcdr (last completion-list) nil))
+ (if (> (length completion-list) 1)
+ (progn
+ (delete-region (- (point-max) (length string)) (point-max))
+ (save-excursion (insert newstring))
+ (forward-char newpoint)
+ (with-output-to-temp-buffer file-cache-completions-buffer
+ (display-completion-list completion-list)
+ ;; Add our own setup function to the Completions Buffer
+ (file-cache-completion-setup-function)))
+ (let ((file-name (file-cache-file-name newstring)))
+ (if (string= file-name (minibuffer-contents))
+ (minibuffer-message file-cache-sole-match-message)
+ (delete-minibuffer-contents)
+ (insert file-name)
+ (if file-cache-multiple-directory-message
+ (minibuffer-message
+ file-cache-multiple-directory-message)))))))))
;; No match
- ((eq completion-string nil)
+ ((eq completion nil)
(minibuffer-message file-cache-no-match-message)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -647,7 +615,7 @@ the name is considered already unique; only the second substitution
(file-cache-minibuffer-complete nil)))
(define-obsolete-function-alias 'file-cache-mouse-choose-completion
- 'file-cache-choose-completion "23.2")
+ #'file-cache-choose-completion "23.2")
(defun file-cache-complete ()
"Complete the word at point, using the filecache."
diff --git a/lisp/fileloop.el b/lisp/fileloop.el
new file mode 100644
index 00000000000..2e77811a576
--- /dev/null
+++ b/lisp/fileloop.el
@@ -0,0 +1,217 @@
+;;; fileloop.el --- Operations on multiple files -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018-2019 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Support functions for operations like search or query&replace applied to
+;; several files. This code was largely inspired&extracted from an earlier
+;; version of etags.el.
+
+;; TODO:
+;; - Maybe it would make sense to replace the fileloop--* vars with a single
+;; global var holding a struct, and then stash those structs into a history
+;; of past operations, so you can perform a fileloop-search while in the
+;; middle of a fileloop-replace and later go back to that
+;; fileloop-replace.
+;; - Make multi-isearch work on top of this library (might require changes
+;; to this library, of course).
+
+;;; Code:
+
+(require 'generator)
+
+(defgroup fileloop nil
+ "Operations on multiple files."
+ :group 'tools)
+
+(defcustom fileloop-revert-buffers 'silent
+ "Whether to revert files during fileloop operation.
+ `silent' means to only do it if `revert-without-query' is applicable;
+ t means to offer to do it for all applicable files;
+ nil means never to do it"
+ :type '(choice (const silent) (const t) (const nil)))
+
+;; FIXME: This already exists in GNU ELPA's iterator.el. Maybe it should move
+;; to generator.el?
+(iter-defun fileloop--list-to-iterator (list)
+ (while list (iter-yield (pop list))))
+
+(defvar fileloop--iterator iter-empty)
+(defvar fileloop--scan-function
+ (lambda () (user-error "No operation in progress")))
+(defvar fileloop--operate-function #'ignore)
+(defvar fileloop--freshly-initialized nil)
+
+;;;###autoload
+(defun fileloop-initialize (files scan-function operate-function)
+ "Initialize a new round of operation on several files.
+FILES can be either a list of file names, or an iterator (used with `iter-next')
+which returns a file name at each step.
+SCAN-FUNCTION is a function called with no argument inside a buffer
+and it should return non-nil if that buffer has something on which to operate.
+OPERATE-FUNCTION is a function called with no argument; it is expected
+to perform the operation on the current file buffer and when done
+should return non-nil to mean that we should immediately continue
+operating on the next file and nil otherwise."
+ (setq fileloop--iterator
+ (if (and (listp files) (not (functionp files)))
+ (fileloop--list-to-iterator files)
+ files))
+ (setq fileloop--scan-function scan-function)
+ (setq fileloop--operate-function operate-function)
+ (setq fileloop--freshly-initialized t))
+
+(defun fileloop-next-file (&optional novisit)
+ ;; FIXME: Should we provide an interactive command, like tags-next-file?
+ (let ((next (condition-case nil
+ (iter-next fileloop--iterator)
+ (iter-end-of-sequence nil))))
+ (unless next
+ (and novisit
+ (get-buffer " *next-file*")
+ (kill-buffer " *next-file*"))
+ (user-error "All files processed"))
+ (let* ((buffer (get-file-buffer next))
+ (new (not buffer)))
+ ;; Optionally offer to revert buffers
+ ;; if the files have changed on disk.
+ (and buffer fileloop-revert-buffers
+ (not (verify-visited-file-modtime buffer))
+ (if (eq fileloop-revert-buffers 'silent)
+ (and (not (buffer-modified-p buffer))
+ (let ((revertible nil))
+ (dolist (re revert-without-query)
+ (when (string-match-p re next)
+ (setq revertible t)))
+ revertible))
+ (y-or-n-p
+ (format
+ (if (buffer-modified-p buffer)
+ "File %s changed on disk. Discard your edits? "
+ "File %s changed on disk. Reread from disk? ")
+ next)))
+ (with-current-buffer buffer
+ (revert-buffer t t)))
+ (if (not (and new novisit))
+ (set-buffer (find-file-noselect next))
+ ;; Like find-file, but avoids random warning messages.
+ (set-buffer (get-buffer-create " *next-file*"))
+ (kill-all-local-variables)
+ (erase-buffer)
+ (setq new next)
+ (insert-file-contents new nil))
+ new)))
+
+(defun fileloop-continue ()
+ "Continue last multi-file operation."
+ (interactive)
+ (let (new
+ ;; Non-nil means we have finished one file
+ ;; and should not scan it again.
+ file-finished
+ original-point
+ (messaged nil))
+ (while
+ (progn
+ ;; Scan files quickly for the first or next interesting one.
+ ;; This starts at point in the current buffer.
+ (while (or fileloop--freshly-initialized file-finished
+ (save-restriction
+ (widen)
+ (not (funcall fileloop--scan-function))))
+ ;; If nothing was found in the previous file, and
+ ;; that file isn't in a temp buffer, restore point to
+ ;; where it was.
+ (when original-point
+ (goto-char original-point))
+
+ (setq file-finished nil)
+ (setq new (fileloop-next-file t))
+
+ ;; If NEW is non-nil, we got a temp buffer,
+ ;; and NEW is the file name.
+ (when (or messaged
+ (and (not fileloop--freshly-initialized)
+ (> baud-rate search-slow-speed)
+ (setq messaged t)))
+ (message "Scanning file %s..." (or new buffer-file-name)))
+
+ (setq fileloop--freshly-initialized nil)
+ (setq original-point (if new nil (point)))
+ (goto-char (point-min)))
+
+ ;; If we visited it in a temp buffer, visit it now for real.
+ (if new
+ (let ((pos (point)))
+ (erase-buffer)
+ (set-buffer (find-file-noselect new))
+ (setq new nil) ;No longer in a temp buffer.
+ (widen)
+ (goto-char pos))
+ (push-mark original-point t))
+
+ (switch-to-buffer (current-buffer))
+
+ ;; Now operate on the file.
+ ;; If value is non-nil, continue to scan the next file.
+ (save-restriction
+ (widen)
+ (funcall fileloop--operate-function)))
+ (setq file-finished t))))
+
+;;;###autoload
+(defun fileloop-initialize-search (regexp files case-fold)
+ (let ((last-buffer (current-buffer)))
+ (fileloop-initialize
+ files
+ (lambda ()
+ (let ((case-fold-search
+ (if (memq case-fold '(t nil)) case-fold case-fold-search)))
+ (re-search-forward regexp nil t)))
+ (lambda ()
+ (unless (eq last-buffer (current-buffer))
+ (setq last-buffer (current-buffer))
+ (message "Scanning file %s...found" buffer-file-name))
+ nil))))
+
+;;;###autoload
+(defun fileloop-initialize-replace (from to files case-fold &optional delimited)
+ "Initialize a new round of query&replace on several files.
+FROM is a regexp and TO is the replacement to use.
+FILES describes the file, as in `fileloop-initialize'.
+CASE-FOLD can be t, nil, or `default', the latter one meaning to obey
+the default setting of `case-fold-search'.
+DELIMITED if non-nil means replace only word-delimited matches."
+ ;; FIXME: Not sure how the delimited-flag interacts with the regexp-flag in
+ ;; `perform-replace', so I just try to mimic the old code.
+ (fileloop-initialize
+ files
+ (lambda ()
+ (let ((case-fold-search
+ (if (memql case-fold '(nil t)) case-fold case-fold-search)))
+ (if (re-search-forward from nil t)
+ ;; When we find a match, move back
+ ;; to the beginning of it so perform-replace
+ ;; will see it.
+ (goto-char (match-beginning 0)))))
+ (lambda ()
+ (perform-replace from to t t delimited nil multi-query-replace-map))))
+
+(provide 'fileloop)
+;;; fileloop.el ends here
diff --git a/lisp/filenotify.el b/lisp/filenotify.el
index 101ddb6be09..3f9bb960a9b 100644
--- a/lisp/filenotify.el
+++ b/lisp/filenotify.el
@@ -45,11 +45,11 @@ could use another implementation.")
(:constructor nil)
(:constructor
file-notify--watch-make (directory filename callback)))
- ;; Watched directory
+ ;; Watched directory.
directory
;; Watched relative filename, nil if watching the directory.
filename
- ;; Function to propagate events to
+ ;; Function to propagate events to.
callback)
(defun file-notify--watch-absolute-filename (watch)
@@ -114,7 +114,7 @@ Could be different from the directory watched by the backend library."
(when-let* ((watch (gethash (car event) file-notify-descriptors)))
(directory-file-name
(expand-file-name
- (or (and (stringp (nth 2 event)) (nth 2 event)) "")
+ (or (and (stringp (nth 2 event)) (nth 2 event)) "")
(file-notify--watch-directory watch)))))
;; Only `gfilenotify' could return two file names.
@@ -240,13 +240,14 @@ EVENT is the cadr of the event in `file-notify-handle-event'
(file-notify--watch-filename watch)
(file-name-nondirectory file1)))))
;;(message
- ;;"file-notify-callback %S %S %S %S %S"
- ;;desc action file file1 watch)
- (if file1
- (funcall (file-notify--watch-callback watch)
- `(,desc ,action ,file ,file1))
- (funcall (file-notify--watch-callback watch)
- `(,desc ,action ,file))))
+ ;;"file-notify-callback %S %S %S %S %S %S %S"
+ ;;desc action file file1 watch
+ ;;(file-notify--event-watched-file event)
+ ;;(file-notify--watch-directory watch))
+ (funcall (file-notify--watch-callback watch)
+ (if file1
+ `(,desc ,action ,file ,file1)
+ `(,desc ,action ,file))))
;; Send `stopped' event.
(when (or stopped
@@ -307,15 +308,12 @@ FILE is the name of the file whose event is being reported."
(unless (functionp callback)
(signal 'wrong-type-argument `(,callback)))
- (let* ((quoted (file-name-quoted-p file))
- (file (file-name-unquote file))
- (file-name-handler-alist (if quoted nil file-name-handler-alist))
- (handler (find-file-name-handler file 'file-notify-add-watch))
- (dir (directory-file-name
- (if (file-directory-p file)
- file
- (file-name-directory file))))
- desc func l-flags)
+ (let ((handler (find-file-name-handler file 'file-notify-add-watch))
+ (dir (directory-file-name
+ (if (file-directory-p file)
+ file
+ (file-name-directory file))))
+ desc func l-flags)
(unless (file-directory-p dir)
(signal 'file-notify-error `("Directory does not exist" ,dir)))
@@ -366,6 +364,10 @@ FILE is the name of the file whose event is being reported."
func (if (eq file-notify--library 'kqueue) file dir)
l-flags 'file-notify-callback)))
+ ;; We do not want to enter quoted file names into the hash.
+ (setq file (file-name-unquote file)
+ dir (file-name-unquote dir))
+
;; Modify `file-notify-descriptors'.
(let ((watch (file-notify--watch-make
dir
@@ -419,11 +421,9 @@ DESCRIPTOR should be an object returned by `file-notify-add-watch'."
descriptor))
t))))
-
;; TODO:
-;; * Watching a /dir/file may receive events for dir.
-;; (This may be the desired behavior.)
-;; * Watching a file in an already watched directory
+
+;; * Watching a file in an already watched directory.
;; If the file is created and *then* a watch is added to that file, the
;; watch might receive events which occurred prior to it being created,
;; due to the way events are propagated during idle time. Note: This
diff --git a/lisp/files-x.el b/lisp/files-x.el
index 1e4efa01f63..b71e9204f32 100644
--- a/lisp/files-x.el
+++ b/lisp/files-x.el
@@ -30,6 +30,8 @@
;;; Code:
+(eval-when-compile (require 'subr-x)) ; for string-trim-right
+
;;; Commands to add/delete file-local/directory-local variables.
@@ -484,7 +486,7 @@ from the MODE alist ignoring the input argument VALUE."
(if (memq variable '(mode eval))
(cdr mode-assoc)
(assq-delete-all variable (cdr mode-assoc))))))
- (assq-delete-all mode variables)))
+ (assoc-delete-all mode variables)))
(setq variables
(cons `(,mode . ((,variable . ,value)))
variables))))
@@ -492,15 +494,34 @@ from the MODE alist ignoring the input argument VALUE."
;; Insert modified alist of directory-local variables.
(insert ";;; Directory Local Variables\n")
(insert ";;; For more information see (info \"(emacs) Directory Variables\")\n\n")
- (pp (sort variables
- (lambda (a b)
- (cond
- ((null (car a)) t)
- ((null (car b)) nil)
- ((and (symbolp (car a)) (stringp (car b))) t)
- ((and (symbolp (car b)) (stringp (car a))) nil)
- (t (string< (car a) (car b))))))
- (current-buffer)))))
+ (princ (dir-locals-to-string
+ (sort variables
+ (lambda (a b)
+ (cond
+ ((null (car a)) t)
+ ((null (car b)) nil)
+ ((and (symbolp (car a)) (stringp (car b))) t)
+ ((and (symbolp (car b)) (stringp (car a))) nil)
+ (t (string< (car a) (car b)))))))
+ (current-buffer))
+ (goto-char (point-min))
+ (indent-sexp))))
+
+(defun dir-locals-to-string (variables)
+ "Output alists of VARIABLES to string in dotted pair notation syntax."
+ (format "(%s)" (mapconcat
+ (lambda (mode-variables)
+ (format "(%S . %s)"
+ (car mode-variables)
+ (format "(%s)" (mapconcat
+ (lambda (variable-value)
+ (format "(%S . %s)"
+ (car variable-value)
+ (string-trim-right
+ (pp-to-string
+ (cdr variable-value)))))
+ (cdr mode-variables) "\n"))))
+ variables "\n")))
;;;###autoload
(defun add-dir-local-variable (mode variable value)
@@ -561,7 +582,7 @@ changed by the user.")
(setq ignored-local-variables
(cons 'connection-local-variables-alist ignored-local-variables))
-(defvar connection-local-profile-alist '()
+(defvar connection-local-profile-alist nil
"Alist mapping connection profiles to variable lists.
Each element in this list has the form (PROFILE VARIABLES).
PROFILE is the name of a connection profile (a symbol).
@@ -569,7 +590,7 @@ VARIABLES is a list that declares connection-local variables for
PROFILE. An element in VARIABLES is an alist whose elements are
of the form (VAR . VALUE).")
-(defvar connection-local-criteria-alist '()
+(defvar connection-local-criteria-alist nil
"Alist mapping connection criteria to connection profiles.
Each element in this list has the form (CRITERIA PROFILES).
CRITERIA is a plist identifying a connection and the application
@@ -664,7 +685,12 @@ This does nothing if `enable-connection-local-variables' is nil."
;; Loop over variables.
(dolist (variable (connection-local-get-profile-variables profile))
(unless (assq (car variable) connection-local-variables-alist)
- (push variable connection-local-variables-alist))))))
+ (push variable connection-local-variables-alist))))
+ ;; Push them to `file-local-variables-alist'. Connection-local
+ ;; variables do not appear from external files. So we can regard
+ ;; them as safe.
+ (let ((enable-local-variables :all))
+ (hack-local-variables-filter connection-local-variables-alist nil))))
;;;###autoload
(defun hack-connection-local-variables-apply (criteria)
@@ -676,24 +702,35 @@ will not be changed."
(copy-tree connection-local-variables-alist)))
(hack-local-variables-apply)))
+(defsubst connection-local-criteria-for-default-directory ()
+ "Return a connection-local criteria, which represents `default-directory'."
+ (when (file-remote-p default-directory)
+ `(:application tramp
+ :protocol ,(file-remote-p default-directory 'method)
+ :user ,(file-remote-p default-directory 'user)
+ :machine ,(file-remote-p default-directory 'host))))
+
;;;###autoload
-(defmacro with-connection-local-profiles (profiles &rest body)
- "Apply connection-local variables according to PROFILES in current buffer.
+(defmacro with-connection-local-variables (&rest body)
+ "Apply connection-local variables according to `default-directory'.
Execute BODY, and unwind connection-local variables."
- (declare (indent 1) (debug t))
- `(let ((enable-connection-local-variables t)
- (old-buffer-local-variables (buffer-local-variables))
- connection-local-variables-alist connection-local-criteria-alist)
- (apply 'connection-local-set-profiles nil ,profiles)
- (hack-connection-local-variables-apply nil)
- (unwind-protect
- (progn ,@body)
- ;; Cleanup.
- (dolist (variable connection-local-variables-alist)
- (let ((elt (assq (car variable) old-buffer-local-variables)))
- (if elt
- (set (make-local-variable (car elt)) (cdr elt))
- (kill-local-variable (car variable))))))))
+ (declare (debug t))
+ `(if (file-remote-p default-directory)
+ (let ((enable-connection-local-variables t)
+ (old-buffer-local-variables (buffer-local-variables))
+ connection-local-variables-alist)
+ (hack-connection-local-variables-apply
+ (connection-local-criteria-for-default-directory))
+ (unwind-protect
+ (progn ,@body)
+ ;; Cleanup.
+ (dolist (variable connection-local-variables-alist)
+ (let ((elt (assq (car variable) old-buffer-local-variables)))
+ (if elt
+ (set (make-local-variable (car elt)) (cdr elt))
+ (kill-local-variable (car variable)))))))
+ ;; No connection-local variables to apply.
+ ,@body))
diff --git a/lisp/files.el b/lisp/files.el
index d7ed2487862..b81550e297c 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -423,14 +423,10 @@ idle for `auto-save-visited-interval' seconds."
(define-minor-mode auto-save-visited-mode
"Toggle automatic saving to file-visiting buffers on or off.
-With a prefix argument ARG, enable regular saving of all buffers
-visiting a file if ARG is positive, and disable it otherwise.
+
Unlike `auto-save-mode', this mode will auto-save buffer contents
to the visited files directly and will also run all save-related
-hooks. See Info node `Saving' for details of the save process.
-
-If called from Lisp, enable the mode if ARG is omitted or nil,
-and toggle it if ARG is `toggle'."
+hooks. See Info node `Saving' for details of the save process."
:group 'auto-save
:global t
(when auto-save--timer (cancel-timer auto-save--timer))
@@ -478,7 +474,7 @@ location of point in the current buffer."
:group 'find-file)
;;;It is not useful to make this a local variable.
-;;;(put 'find-file-not-found-hooks 'permanent-local t)
+;;;(put 'find-file-not-found-functions 'permanent-local t)
(define-obsolete-variable-alias 'find-file-not-found-hooks
'find-file-not-found-functions "22.1")
(defvar find-file-not-found-functions nil
@@ -488,7 +484,8 @@ Variable `buffer-file-name' is already set up.
The functions are called in the order given until one of them returns non-nil.")
;;;It is not useful to make this a local variable.
-;;;(put 'find-file-hooks 'permanent-local t)
+;;;(put 'find-file-hook 'permanent-local t)
+;; I found some external files still using the obsolete form in 2018.
(define-obsolete-variable-alias 'find-file-hooks 'find-file-hook "22.1")
(defcustom find-file-hook nil
"List of functions to be called after a buffer is loaded from a file.
@@ -500,6 +497,7 @@ for the file's directory."
:options '(auto-insert)
:version "22.1")
+;; I found some external files still using the obsolete form in 2018.
(define-obsolete-variable-alias 'write-file-hooks 'write-file-functions "22.1")
(defvar write-file-functions nil
"List of functions to be called before saving a buffer to a file.
@@ -519,11 +517,13 @@ node `(elisp)Saving Buffers'.) To perform various checks or
updates before the buffer is saved, use `before-save-hook'.")
(put 'write-file-functions 'permanent-local t)
+;; I found some files still using the obsolete form in 2018.
(defvar local-write-file-hooks nil)
(make-variable-buffer-local 'local-write-file-hooks)
(put 'local-write-file-hooks 'permanent-local t)
(make-obsolete-variable 'local-write-file-hooks 'write-file-functions "22.1")
+;; I found some files still using the obsolete form in 2018.
(define-obsolete-variable-alias 'write-contents-hooks
'write-contents-functions "22.1")
(defvar write-contents-functions nil
@@ -758,9 +758,10 @@ nil (meaning `default-directory') as the associated list element."
;; do end up using a superficially different directory.
(setq dir (expand-file-name dir))
(if (not (file-directory-p dir))
- (if (file-exists-p dir)
- (error "%s is not a directory" dir)
- (error "%s: no such directory" dir))
+ (error (if (file-exists-p dir)
+ "%s is not a directory"
+ "%s: no such directory")
+ dir)
(unless (file-accessible-directory-p dir)
(error "Cannot cd to %s: Permission denied" dir))
(setq default-directory dir)
@@ -868,7 +869,7 @@ This function will normally skip directories, so if you want it to find
directories, make sure the PREDICATE function returns `dir-ok' for them.
PREDICATE can also be an integer to pass to the `access' system call,
-in which case file-name handlers are ignored. This usage is deprecated.
+in which case file name handlers are ignored. This usage is deprecated.
For compatibility, PREDICATE can also be one of the symbols
`executable', `readable', `writable', or `exists', or a list of
one or more of those symbols."
@@ -975,7 +976,8 @@ the function needs to examine, starting with FILE."
(null file)
(string-match locate-dominating-stop-dir-regexp file)))
(setq try (if (stringp name)
- (file-exists-p (expand-file-name name file))
+ (and (file-directory-p file)
+ (file-exists-p (expand-file-name name file)))
(funcall name file)))
(cond (try (setq root file))
((equal file (setq file (file-name-directory
@@ -1007,7 +1009,7 @@ directory if it does not exist."
;; Make sure `user-emacs-directory' exists,
;; unless we're in batch mode or dumping Emacs.
(or noninteractive
- purify-flag
+ dump-mode
(let (errtype)
(if (file-directory-p user-emacs-directory)
(or (file-accessible-directory-p user-emacs-directory)
@@ -1030,13 +1032,33 @@ customize the variable `user-emacs-directory-warning'."
errtype user-emacs-directory)))))
bestname))))
+(defun exec-path ()
+ "Return list of directories to search programs to run in remote subprocesses.
+The remote host is identified by `default-directory'. For remote
+hosts which do not support subprocesses, this returns `nil'.
+If `default-directory' is a local directory, this function returns
+the value of the variable `exec-path'."
+ (let ((handler (find-file-name-handler default-directory 'exec-path)))
+ (if handler
+ (funcall handler 'exec-path)
+ exec-path)))
-(defun executable-find (command)
+(defun executable-find (command &optional remote)
"Search for COMMAND in `exec-path' and return the absolute file name.
-Return nil if COMMAND is not found anywhere in `exec-path'."
- ;; Use 1 rather than file-executable-p to better match the behavior of
- ;; call-process.
- (locate-file command exec-path exec-suffixes 1))
+Return nil if COMMAND is not found anywhere in `exec-path'. If
+REMOTE is non-nil, search on the remote host indicated by
+`default-directory' instead."
+ (if (and remote (file-remote-p default-directory))
+ (let ((res (locate-file
+ command
+ (mapcar
+ (lambda (x) (concat (file-remote-p default-directory) x))
+ (exec-path))
+ exec-suffixes 'file-executable-p)))
+ (when (stringp res) (file-local-name res)))
+ ;; Use 1 rather than file-executable-p to better match the
+ ;; behavior of call-process.
+ (locate-file command exec-path exec-suffixes 1)))
(defun load-library (library)
"Load the Emacs Lisp library named LIBRARY.
@@ -1138,10 +1160,11 @@ consecutive checks. For example:
(defun display-time-file-nonempty-p (file)
(let ((remote-file-name-inhibit-cache (- display-time-interval 5)))
(and (file-exists-p file)
- (< 0 (nth 7 (file-attributes (file-chase-links file)))))))"
+ (< 0 (file-attribute-size
+ (file-attributes (file-chase-links file)))))))"
:group 'files
:version "24.1"
- :type `(choice
+ :type '(choice
(const :tag "Do not inhibit file name cache" nil)
(const :tag "Do not use file name cache" t)
(integer :tag "Do not use file name cache"
@@ -1179,10 +1202,11 @@ names beginning with `~'."
"Splice DIRNAME to FILE like the operating system would.
If FILE is relative, return DIRNAME concatenated to FILE.
Otherwise return FILE, quoted as needed if DIRNAME and FILE have
-different handlers; although this quoting is dubious if DIRNAME
-is magic, it is not clear what would be better. This function
-differs from `expand-file-name' in that DIRNAME must be a
-directory name and leading `~' and `/:' are not special in FILE."
+different file name handlers; although this quoting is dubious if
+DIRNAME is magic, it is not clear what would be better. This
+function differs from `expand-file-name' in that DIRNAME must be
+a directory name and leading `~' and `/:' are not special in
+FILE."
(let ((unquoted (if (files--name-absolute-system-p file)
file
(concat dirname file))))
@@ -1816,7 +1840,11 @@ killed."
(setq buffer-file-truename nil)
;; Likewise for dired buffers.
(setq dired-directory nil)
- (find-file filename wildcards))
+ ;; Don't use `find-file' because it may end up using another window
+ ;; in some corner cases, e.g. when the selected window is
+ ;; softly-dedicated.
+ (let ((newbuf (find-file-noselect filename nil nil wildcards)))
+ (switch-to-buffer (if (consp newbuf) (car newbuf) newbuf))))
(when (eq obuf (current-buffer))
;; This executes if find-file gets an error
;; and does not really find anything.
@@ -1878,7 +1906,7 @@ afterwards (so long as the home directory does not change;
if you want to permanently change your home directory after having
started Emacs, set `abbreviated-home-dir' to nil so it will be recalculated)."
;; Get rid of the prefixes added by the automounter.
- (save-match-data
+ (save-match-data ;FIXME: Why?
(if (and automount-dir-prefix
(string-match automount-dir-prefix filename)
(file-exists-p (file-name-directory
@@ -1901,12 +1929,13 @@ started Emacs, set `abbreviated-home-dir' to nil so it will be recalculated)."
(unless abbreviated-home-dir
(put 'abbreviated-home-dir 'home (expand-file-name "~"))
(setq abbreviated-home-dir
- (let ((abbreviated-home-dir "$foo"))
- (setq abbreviated-home-dir
+ (let* ((abbreviated-home-dir "\\`\\'.") ;Impossible regexp.
+ (regexp
(concat "\\`"
- (abbreviate-file-name
- (get 'abbreviated-home-dir 'home))
- "\\(/\\|\\'\\)"))
+ (regexp-quote
+ (abbreviate-file-name
+ (get 'abbreviated-home-dir 'home)))
+ "\\(/\\|\\'\\)")))
;; Depending on whether default-directory does or
;; doesn't include non-ASCII characters, the value
;; of abbreviated-home-dir could be multibyte or
@@ -1914,9 +1943,9 @@ started Emacs, set `abbreviated-home-dir' to nil so it will be recalculated)."
;; it. Note that this function is called for the
;; first time (from startup.el) when
;; locale-coding-system is already set up.
- (if (multibyte-string-p abbreviated-home-dir)
- abbreviated-home-dir
- (decode-coding-string abbreviated-home-dir
+ (if (multibyte-string-p regexp)
+ regexp
+ (decode-coding-string regexp
(if (eq system-type 'windows-nt)
'utf-8
locale-coding-system))))))
@@ -1929,22 +1958,22 @@ started Emacs, set `abbreviated-home-dir' to nil so it will be recalculated)."
;; is likely temporary (eg for testing).
;; FIXME Is it even worth caching abbreviated-home-dir?
;; Ref: https://debbugs.gnu.org/19657#20
- (if (and (string-match abbreviated-home-dir filename)
- ;; If the home dir is just /, don't change it.
- (not (and (= (match-end 0) 1)
- (= (aref filename 0) ?/)))
- ;; MS-DOS root directories can come with a drive letter;
- ;; Novell Netware allows drive letters beyond `Z:'.
- (not (and (memq system-type '(ms-dos windows-nt cygwin))
- (save-match-data
- (string-match "^[a-zA-`]:/$" filename))))
- (equal (get 'abbreviated-home-dir 'home)
- (save-match-data (expand-file-name "~"))))
- (setq filename
- (concat "~"
- (match-string 1 filename)
- (substring filename (match-end 0)))))
- filename)))
+ (let (mb1)
+ (if (and (string-match abbreviated-home-dir filename)
+ (setq mb1 (match-beginning 1))
+ ;; If the home dir is just /, don't change it.
+ (not (and (= (match-end 0) 1)
+ (= (aref filename 0) ?/)))
+ ;; MS-DOS root directories can come with a drive letter;
+ ;; Novell Netware allows drive letters beyond `Z:'.
+ (not (and (memq system-type '(ms-dos windows-nt cygwin))
+ (string-match "\\`[a-zA-`]:/\\'" filename)))
+ (equal (get 'abbreviated-home-dir 'home)
+ (expand-file-name "~")))
+ (setq filename
+ (concat "~"
+ (substring filename mb1))))
+ filename))))
(defun find-buffer-visiting (filename &optional predicate)
"Return the buffer visiting file FILENAME (a string).
@@ -2019,15 +2048,47 @@ think it does, because \"free\" is pretty hard to define in practice."
:version "25.1"
:type '(choice integer (const :tag "Never issue warning" nil)))
-(defun abort-if-file-too-large (size op-type filename)
+(declare-function x-popup-dialog "menu.c" (position contents &optional header))
+
+(defun files--ask-user-about-large-file (size op-type filename offer-raw)
+ (let ((prompt (format "File %s is large (%s), really %s?"
+ (file-name-nondirectory filename)
+ (file-size-human-readable size) op-type)))
+ (if (not offer-raw)
+ (if (y-or-n-p prompt) nil 'abort)
+ (let* ((use-dialog (and (display-popup-menus-p)
+ last-input-event
+ (listp last-nonmenu-event)
+ use-dialog-box))
+ (choice
+ (if use-dialog
+ (x-popup-dialog t `(,prompt
+ ("Yes" . ?y)
+ ("No" . ?n)
+ ("Open literally" . ?l)))
+ (read-char-choice
+ (concat prompt " (y)es or (n)o or (l)iterally ")
+ '(?y ?Y ?n ?N ?l ?L)))))
+ (cond ((memq choice '(?y ?Y)) nil)
+ ((memq choice '(?l ?L)) 'raw)
+ (t 'abort))))))
+
+(defun abort-if-file-too-large (size op-type filename &optional offer-raw)
"If file SIZE larger than `large-file-warning-threshold', allow user to abort.
-OP-TYPE specifies the file operation being performed (for message to user)."
- (when (and large-file-warning-threshold size
- (> size large-file-warning-threshold)
- (not (y-or-n-p (format "File %s is large (%s), really %s? "
- (file-name-nondirectory filename)
- (file-size-human-readable size) op-type))))
- (user-error "Aborted")))
+OP-TYPE specifies the file operation being performed (for message
+to user). If OFFER-RAW is true, give user the additional option
+to open the file literally. If the user chooses this option,
+`abort-if-file-too-large' returns the symbol `raw'. Otherwise, it
+returns nil or exits non-locally."
+ (let ((choice (and large-file-warning-threshold size
+ (> size large-file-warning-threshold)
+ ;; No point in warning if we can't read it.
+ (file-readable-p filename)
+ (files--ask-user-about-large-file
+ size op-type filename offer-raw))))
+ (when (eq choice 'abort)
+ (user-error "Aborted"))
+ choice))
(defun warn-maybe-out-of-memory (size)
"Warn if an attempt to open file of SIZE bytes may run out of memory."
@@ -2107,8 +2168,11 @@ the various files."
(setq buf other))))
;; Check to see if the file looks uncommonly large.
(when (not (or buf nowarn))
- (abort-if-file-too-large (nth 7 attributes) "open" filename)
- (warn-maybe-out-of-memory (nth 7 attributes)))
+ (when (eq (abort-if-file-too-large
+ (file-attribute-size attributes) "open" filename t)
+ 'raw)
+ (setf rawfile t))
+ (warn-maybe-out-of-memory (file-attribute-size attributes)))
(if buf
;; We are using an existing buffer.
(let (nonexistent)
@@ -2243,8 +2307,7 @@ Do you want to revisit the file normally now? ")
(kill-local-variable 'cursor-type)
(let ((inhibit-read-only t))
(erase-buffer))
- (and (default-value 'enable-multibyte-characters)
- (not rawfile)
+ (and (not rawfile)
(set-buffer-multibyte t))
(if rawfile
(condition-case ()
@@ -2272,9 +2335,9 @@ Do you want to revisit the file normally now? ")
;; If they fail too, set error.
(setq error t)))))
;; Record the file's truename, and maybe use that as visited name.
- (if (equal filename buffer-file-name)
- (setq buffer-file-truename truename)
- (setq buffer-file-truename
+ (setq buffer-file-truename
+ (if (equal filename buffer-file-name)
+ truename
(abbreviate-file-name (file-truename buffer-file-name))))
(setq buffer-file-number number)
(if find-file-visit-truename
@@ -2313,7 +2376,8 @@ This function ensures that none of these modifications will take place."
;; FIXME: Yuck!! We should turn insert-file-contents-literally
;; into a file operation instead!
(append '(jka-compr-handler image-file-handler epa-file-handler)
- inhibit-file-name-handlers))
+ (and (eq inhibit-file-name-operation 'insert-file-contents)
+ inhibit-file-name-handlers)))
(inhibit-file-name-operation 'insert-file-contents))
(insert-file-contents filename visit beg end replace)))
@@ -2322,7 +2386,8 @@ This function ensures that none of these modifications will take place."
(signal 'file-error (list "Opening input file" "Is a directory"
filename)))
;; Check whether the file is uncommonly large
- (abort-if-file-too-large (nth 7 (file-attributes filename)) "insert" filename)
+ (abort-if-file-too-large (file-attribute-size (file-attributes filename))
+ "insert" filename)
(let* ((buffer (find-buffer-visiting (abbreviate-file-name (file-truename filename))
#'buffer-modified-p))
(tem (funcall insert-func filename)))
@@ -2640,9 +2705,8 @@ ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|CBR\\|7Z\\)\\'" . archive-mo
("\\.dbk\\'" . xml-mode)
("\\.dtd\\'" . sgml-mode)
("\\.ds\\(ss\\)?l\\'" . dsssl-mode)
- ("\\.jsm?\\'" . javascript-mode)
+ ("\\.js[mx]?\\'" . javascript-mode)
("\\.json\\'" . javascript-mode)
- ("\\.jsx\\'" . js-jsx-mode)
("\\.[ds]?vh?\\'" . verilog-mode)
("\\.by\\'" . bovine-grammar-mode)
("\\.wy\\'" . wisent-grammar-mode)
@@ -3331,7 +3395,7 @@ n -- to ignore the local variables list.")
;; Display the buffer and read a choice.
(save-window-excursion
- (pop-to-buffer buf)
+ (pop-to-buffer buf '(display-buffer--maybe-at-bottom))
(let* ((exit-chars '(?y ?n ?\s ?\C-g ?\C-v))
(prompt (format "Please type %s%s: "
(if offer-save "y, n, or !" "y or n")
@@ -3402,6 +3466,8 @@ return as the symbol specifying the mode."
(let* ((key (intern (match-string 1)))
(val (save-restriction
(narrow-to-region (point) end)
+ ;; As a defensive measure, we do not allow
+ ;; circular data in the file-local data.
(let ((read-circle nil))
(read (current-buffer)))))
;; It is traditional to ignore
@@ -3523,6 +3589,11 @@ local variables, but directory-local variables may still be applied."
result)
(unless (eq handle-mode t)
(setq file-local-variables-alist nil)
+ (when (file-remote-p default-directory)
+ (with-demoted-errors "Connection-local variables error: %s"
+ ;; Note this is a no-op if enable-local-variables is nil.
+ (hack-connection-local-variables
+ (connection-local-criteria-for-default-directory))))
(with-demoted-errors "Directory-local variables error: %s"
;; Note this is a no-op if enable-local-variables is nil.
(hack-dir-local-variables)))
@@ -3611,6 +3682,8 @@ local variables, but directory-local variables may still be applied."
;; Read the variable value.
(skip-chars-forward "^:")
(forward-char 1)
+ ;; As a defensive measure, we do not allow
+ ;; circular data in the file-local data.
(let ((read-circle nil))
(setq val (read (current-buffer))))
(if (eq handle-mode t)
@@ -3641,7 +3714,8 @@ local variables, but directory-local variables may still be applied."
(push (cons (if (eq var 'eval)
'eval
(indirect-variable var))
- val) result))))))
+ val)
+ result))))))
(forward-line 1))))))))
;; Now we've read all the local variables.
;; If HANDLE-MODE is t, return whether the mode was specified.
@@ -3777,13 +3851,13 @@ It is dangerous if either of these conditions are met:
If VAR is `mode', call `VAL-mode' as a function unless it's
already the major mode."
(pcase var
- (`mode
+ ('mode
(let ((mode (intern (concat (downcase (symbol-name val))
"-mode"))))
(unless (eq (indirect-function mode)
(indirect-function major-mode))
(funcall mode))))
- (`eval
+ ('eval
(pcase val
(`(add-hook ',hook . ,_) (hack-one-local-variable--obsolete hook)))
(save-excursion (eval val)))
@@ -3807,8 +3881,8 @@ Each element in this list has the form (DIR CLASS MTIME).
DIR is the name of the directory.
CLASS is the name of a variable class (a symbol).
MTIME is the recorded modification time of the directory-local
-variables file associated with this entry. This time is a list
-of integers (the same format as `file-attributes'), and is
+variables file associated with this entry. This time is a Lisp
+timestamp (the same format as `current-time'), and is
used to test whether the cache entry is still valid.
Alternatively, MTIME can be nil, which means the entry is always
considered valid.")
@@ -3956,6 +4030,8 @@ those in the first."
(dolist (f (list file-2 file-1))
(when (and f
(file-readable-p f)
+ ;; FIXME: Aren't file-regular-p and
+ ;; file-directory-p mutually exclusive?
(file-regular-p f)
(not (file-directory-p f)))
(push f out)))
@@ -4012,7 +4088,9 @@ This function returns either:
(equal (nth 2 dir-elt)
(let ((latest 0))
(dolist (f cached-files latest)
- (let ((f-time (nth 5 (file-attributes f))))
+ (let ((f-time
+ (file-attribute-modification-time
+ (file-attributes f))))
(if (time-less-p latest f-time)
(setq latest f-time)))))))))
;; This cache entry is OK.
@@ -4026,33 +4104,45 @@ This function returns either:
;; No cache entry.
locals-dir)))
+(declare-function map-merge-with "map" (type function &rest maps))
+(declare-function map-merge "map" (type &rest maps))
+
(defun dir-locals-read-from-dir (dir)
"Load all variables files in DIR and register a new class and instance.
DIR is the absolute name of a directory which must contain at
least one dir-local file (which is a file holding variables to
apply).
Return the new class name, which is a symbol named DIR."
- (require 'map)
(let* ((class-name (intern dir))
(files (dir-locals--all-files dir))
- (read-circle nil)
;; If there was a problem, use the values we could get but
;; don't let the cache prevent future reads.
(latest 0) (success 0)
(variables))
(with-demoted-errors "Error reading dir-locals: %S"
(dolist (file files)
- (let ((file-time (nth 5 (file-attributes file))))
+ (let ((file-time (file-attribute-modification-time
+ (file-attributes file))))
(if (time-less-p latest file-time)
(setq latest file-time)))
(with-temp-buffer
(insert-file-contents file)
- (condition-case-unless-debug nil
- (setq variables
+ (let ((newvars
+ (condition-case-unless-debug nil
+ ;; As a defensive measure, we do not allow
+ ;; circular data in the file/dir-local data.
+ (let ((read-circle nil))
+ (read (current-buffer)))
+ (end-of-file nil))))
+ (setq variables
+ ;; Try and avoid loading `map' since that also loads cl-lib
+ ;; which then might hamper bytecomp warnings (bug#30635).
+ (if (not (and newvars variables))
+ (or newvars variables)
+ (require 'map)
(map-merge-with 'list (lambda (a b) (map-merge 'list a b))
variables
- (read (current-buffer))))
- (end-of-file nil))))
+ newvars))))))
(setq success latest))
(dir-locals-set-class-variables class-name variables)
(dir-locals-set-directory-class dir class-name success)
@@ -4390,7 +4480,7 @@ BACKUPNAME is the backup file name, which is the old file renamed."
(let ((attr (file-attributes
real-file-name
'integer)))
- (<= (nth 2 attr)
+ (<= (file-attribute-user-id attr)
copy-when-priv-mismatch))))
(not (file-ownership-preserved-p real-file-name
t)))))
@@ -4482,32 +4572,36 @@ the group would be preserved too."
;; Return t if the file doesn't exist, since it's true that no
;; information would be lost by an (attempted) delete and create.
(or (null attributes)
- (and (or (= (nth 2 attributes) (user-uid))
+ (and (or (= (file-attribute-user-id attributes) (user-uid))
;; Files created on Windows by Administrator (RID=500)
;; have the Administrators group (RID=544) recorded as
;; their owner. Rewriting them will still preserve the
;; owner.
(and (eq system-type 'windows-nt)
- (= (user-uid) 500) (= (nth 2 attributes) 544)))
+ (= (user-uid) 500)
+ (= (file-attribute-user-id attributes) 544)))
(or (not group)
;; On BSD-derived systems files always inherit the parent
;; directory's group, so skip the group-gid test.
(memq system-type '(berkeley-unix darwin gnu/kfreebsd))
- (= (nth 3 attributes) (group-gid)))
+ (= (file-attribute-group-id attributes) (group-gid)))
(let* ((parent (or (file-name-directory file) "."))
(parent-attributes (file-attributes parent 'integer)))
(and parent-attributes
;; On some systems, a file created in a setuid directory
;; inherits that directory's owner.
(or
- (= (nth 2 parent-attributes) (user-uid))
- (string-match "^...[^sS]" (nth 8 parent-attributes)))
+ (= (file-attribute-user-id parent-attributes)
+ (user-uid))
+ (string-match
+ "^...[^sS]"
+ (file-attribute-modes parent-attributes)))
;; On many systems, a file created in a setgid directory
;; inherits that directory's group. On some systems
;; this happens even if the setgid bit is not set.
(or (not group)
- (= (nth 3 parent-attributes)
- (nth 3 attributes)))))))))))
+ (= (file-attribute-group-id parent-attributes)
+ (file-attribute-group-id attributes)))))))))))
(defun file-name-sans-extension (filename)
"Return FILENAME sans final \"extension\".
@@ -4546,8 +4640,8 @@ extension, the value is \"\"."
"")))))
(defun file-name-base (&optional filename)
- "Return the base name of the FILENAME: no directory, no extension.
-FILENAME defaults to `buffer-file-name'."
+ "Return the base name of the FILENAME: no directory, no extension."
+ (declare (advertised-calling-convention (filename) "27.1"))
(file-name-sans-extension
(file-name-nondirectory (or filename (buffer-file-name)))))
@@ -5227,9 +5321,14 @@ about certain files that you'd usually rather not save."
(defun save-some-buffers (&optional arg pred)
"Save some modified file-visiting buffers. Asks user about each one.
-You can answer `y' to save, `n' not to save, `C-r' to look at the
-buffer in question with `view-buffer' before deciding or `d' to
-view the differences using `diff-buffer-with-file'.
+You can answer `y' or SPC to save, `n' or DEL not to save, `C-r'
+to look at the buffer in question with `view-buffer' before
+deciding, `d' to view the differences using
+`diff-buffer-with-file', `!' to save the buffer and all remaining
+buffers without any further querying, `.' to save only the
+current buffer and skip the remaining ones and `q' or RET to exit
+the function without saving any more buffers. `C-h' displays a
+help message describing these options.
This command first saves any buffers where `buffer-save-without-query' is
non-nil, without asking.
@@ -5459,6 +5558,21 @@ raised."
(dolist (dir create-list)
(files--ensure-directory dir)))))))
+(defun make-empty-file (filename &optional parents)
+ "Create an empty file FILENAME.
+Optional arg PARENTS, if non-nil then creates parent dirs as needed.
+
+If called interactively, then PARENTS is non-nil."
+ (interactive
+ (let ((filename (read-file-name "Create empty file: ")))
+ (list filename t)))
+ (when (and (file-exists-p filename) (null parents))
+ (signal 'file-already-exists `("File exists" ,filename)))
+ (let ((paren-dir (file-name-directory filename)))
+ (when (and paren-dir (not (file-exists-p paren-dir)))
+ (make-directory paren-dir parents)))
+ (write-region "" nil filename nil 0))
+
(defconst directory-files-no-dot-files-regexp
"^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"
"Regexp matching any file name except \".\" and \"..\".")
@@ -5647,7 +5761,8 @@ into NEWNAME instead."
;; Set directory attributes.
(let ((modes (file-modes directory))
- (times (and keep-time (nth 5 (file-attributes directory)))))
+ (times (and keep-time (file-attribute-modification-time
+ (file-attributes directory)))))
(if modes (set-file-modes newname modes))
(if times (set-file-times newname times))))))
@@ -5926,14 +6041,18 @@ an auto-save file."
(interactive "FRecover file: ")
(setq file (expand-file-name file))
(if (auto-save-file-name-p (file-name-nondirectory file))
- (error "%s is an auto-save file" (abbreviate-file-name file)))
+ (user-error "%s is an auto-save file" (abbreviate-file-name file)))
(let ((file-name (let ((buffer-file-name file))
(make-auto-save-file-name))))
- (cond ((if (file-exists-p file)
+ (cond ((and (file-exists-p file)
+ (not (file-exists-p file-name)))
+ (error "Auto save file %s does not exist"
+ (abbreviate-file-name file-name)))
+ ((if (file-exists-p file)
(not (file-newer-than-file-p file-name file))
(not (file-exists-p file-name)))
- (error "Auto-save file %s not current"
- (abbreviate-file-name file-name)))
+ (user-error "Auto-save file %s not current"
+ (abbreviate-file-name file-name)))
((with-temp-buffer-window
"*Directory*" nil
#'(lambda (window _value)
@@ -6196,7 +6315,7 @@ See also `auto-save-file-name-p'."
;; We do this on all platforms, because even if we are not
;; running on DOS/Windows, the current directory may be on a
;; mounted VFAT filesystem, such as a USB memory stick.
- (while (string-match "[^A-Za-z0-9-_.~#+]" buffer-name limit)
+ (while (string-match "[^A-Za-z0-9_.~#+-]" buffer-name limit)
(let* ((character (aref buffer-name (match-beginning 0)))
(replacement
;; For multibyte characters, this will produce more than
@@ -6461,58 +6580,32 @@ if you want to specify options, use `directory-free-space-args'.
A value of nil disables this feature.
-If the function `file-system-info' is defined, it is always used in
-preference to the program given by this variable."
+This variable is obsolete; Emacs no longer uses it."
:type '(choice (string :tag "Program") (const :tag "None" nil))
:group 'dired)
+(make-obsolete-variable 'directory-free-space-program
+ "ignored, as Emacs uses `file-system-info' instead"
+ "27.1")
(defcustom directory-free-space-args
(purecopy (if (eq system-type 'darwin) "-k" "-Pk"))
"Options to use when running `directory-free-space-program'."
:type 'string
:group 'dired)
+(make-obsolete-variable 'directory-free-space-args
+ "ignored, as Emacs uses `file-system-info' instead"
+ "27.1")
(defun get-free-disk-space (dir)
"Return the amount of free space on directory DIR's file system.
The return value is a string describing the amount of free
space (normally, the number of free 1KB blocks).
-This function calls `file-system-info' if it is available, or
-invokes the program specified by `directory-free-space-program'
-and `directory-free-space-args'. If the system call or program
-is unsuccessful, or if DIR is a remote directory, this function
-returns nil."
- (unless (file-remote-p (expand-file-name dir))
- ;; Try to find the number of free blocks. Non-Posix systems don't
- ;; always have df, but might have an equivalent system call.
- (if (fboundp 'file-system-info)
- (let ((fsinfo (file-system-info dir)))
- (if fsinfo
- (format "%.0f" (/ (nth 2 fsinfo) 1024))))
- (setq dir (expand-file-name dir))
- (save-match-data
- (with-temp-buffer
- (when (and directory-free-space-program
- ;; Avoid failure if the default directory does
- ;; not exist (Bug#2631, Bug#3911).
- (let ((default-directory
- (locate-dominating-file dir 'file-directory-p)))
- (eq (process-file directory-free-space-program
- nil t nil
- directory-free-space-args
- (file-relative-name dir))
- 0)))
- ;; Assume that the "available" column is before the
- ;; "capacity" column. Find the "%" and scan backward.
- (goto-char (point-min))
- (forward-line 1)
- (when (re-search-forward
- "[[:space:]]+[^[:space:]]+%[^%]*$"
- (line-end-position) t)
- (goto-char (match-beginning 0))
- (let ((endpt (point)))
- (skip-chars-backward "^[:space:]")
- (buffer-substring-no-properties (point) endpt)))))))))
+If DIR's free space cannot be obtained, this function returns nil."
+ (save-match-data
+ (let ((avail (nth 2 (file-system-info dir))))
+ (if avail
+ (format "%.0f" (/ avail 1024))))))
;; The following expression replaces `dired-move-to-filename-regexp'.
(defvar directory-listing-before-filename-regexp
@@ -6659,7 +6752,7 @@ Valid wildcards are '*', '?', '[abc]' and '[a-z]'."
;; dired-after-subdir-garbage (defines what a "total" line is)
;; - variable dired-subdir-regexp
;; - may be passed "--dired" as the first argument in SWITCHES.
-;; Filename handlers might have to remove this switch if their
+;; File name handlers might have to remove this switch if their
;; "ls" command does not support it.
(defun insert-directory (file switches &optional wildcard full-directory-p)
"Insert directory listing for FILE, formatted according to SWITCHES.
@@ -6962,8 +7055,9 @@ if any returns nil. If `confirm-kill-emacs' is non-nil, calls it."
(setq active t))
(setq processes (cdr processes)))
(or (not active)
- (with-current-buffer-window
- (get-buffer-create "*Process List*") nil
+ (with-displayed-buffer-window
+ (get-buffer-create "*Process List*")
+ '(display-buffer--maybe-at-bottom)
#'(lambda (window _value)
(with-selected-window window
(unwind-protect
@@ -7003,20 +7097,28 @@ only these files will be asked to be saved."
;; We depend on being the last handler on the list,
;; so that anything else which does need handling
;; has been handled already.
-;; So it is safe for us to inhibit *all* magic file name handlers.
+;; So it is safe for us to inhibit *all* magic file name handlers for
+;; operations, which return a file name. See Bug#29579.
(defun file-name-non-special (operation &rest arguments)
- (let ((file-name-handler-alist nil)
- (default-directory
- ;; Some operations respect file name handlers in
- ;; `default-directory'. Because core function like
- ;; `call-process' don't care about file name handlers in
- ;; `default-directory', we here have to resolve the
- ;; directory into a local one. For `process-file',
- ;; `start-file-process', and `shell-command', this fixes
- ;; Bug#25949.
- (if (memq operation '(insert-directory process-file start-file-process
- shell-command))
+ (let (;; In general, we don't want any file name handler. For some
+ ;; few cases, operations with two file name arguments which
+ ;; might be bound to different file name handlers, we still
+ ;; need this.
+ (saved-file-name-handler-alist file-name-handler-alist)
+ file-name-handler-alist
+ ;; Some operations respect file name handlers in
+ ;; `default-directory'. Because core function like
+ ;; `call-process' don't care about file name handlers in
+ ;; `default-directory', we here have to resolve the directory
+ ;; into a local one. For `process-file',
+ ;; `start-file-process', and `shell-command', this fixes
+ ;; Bug#25949.
+ (default-directory
+ (if (memq operation
+ '(insert-directory process-file start-file-process
+ make-process shell-command
+ temporary-file-directory))
(directory-file-name
(expand-file-name
(unhandled-file-name-directory default-directory)))
@@ -7024,35 +7126,55 @@ only these files will be asked to be saved."
;; Get a list of the indices of the args which are file names.
(file-arg-indices
(cdr (or (assq operation
- ;; The first six are special because they
- ;; return a file name. We want to include the /:
- ;; in the return value.
- ;; So just avoid stripping it in the first place.
- '((expand-file-name . nil)
- (file-name-directory . nil)
- (file-name-as-directory . nil)
- (directory-file-name . nil)
- (file-name-sans-versions . nil)
- (find-backup-file-name . nil)
- ;; `identity' means just return the first arg
- ;; not stripped of its quoting.
+ '(;; The first seven are special because they
+ ;; return a file name. We want to include
+ ;; the /: in the return value. So just
+ ;; avoid stripping it in the first place.
+ (directory-file-name)
+ (expand-file-name)
+ (file-name-as-directory)
+ (file-name-directory)
+ (file-name-sans-versions)
+ (file-remote-p)
+ (find-backup-file-name)
+ ;; `identity' means just return the first
+ ;; arg not stripped of its quoting.
(substitute-in-file-name identity)
;; `add' means add "/:" to the result.
(file-truename add 0)
+ ;;`insert-file-contents' needs special handling.
(insert-file-contents insert-file-contents 0)
;; `unquote-then-quote' means set buffer-file-name
;; temporarily to unquoted filename.
(verify-visited-file-modtime unquote-then-quote)
+ ;; Unquote `buffer-file-name' temporarily.
+ (make-auto-save-file-name buffer-file-name)
+ (set-visited-file-modtime buffer-file-name)
+ ;; Use a temporary local copy.
+ (copy-file local-copy)
+ (rename-file local-copy)
+ (copy-directory local-copy)
;; List the arguments which are filenames.
- (file-name-completion 1)
- (file-name-all-completions 1)
+ (file-name-completion 0 1)
+ (file-name-all-completions 0 1)
+ (file-equal-p 0 1)
+ (file-newer-than-file-p 0 1)
(write-region 2 5)
- (rename-file 0 1)
- (copy-file 0 1)
+ (file-in-directory-p 0 1)
(make-symbolic-link 0 1)
- (add-name-to-file 0 1)))
- ;; For all other operations, treat the first argument only
- ;; as the file name.
+ (add-name-to-file 0 1)
+ ;; These file-notify-* operations take a
+ ;; descriptor.
+ (file-notify-rm-watch)
+ (file-notify-valid-p)
+ ;; `make-process' uses keyword arguments and
+ ;; doesn't mangle its filenames in any way.
+ ;; It already strips /: from the binary
+ ;; filename, so we don't have to do this
+ ;; here.
+ (make-process)))
+ ;; For all other operations, treat the first
+ ;; argument only as the file name.
'(nil 0))))
method
;; Copy ARGUMENTS so we can replace elements in it.
@@ -7060,26 +7182,25 @@ only these files will be asked to be saved."
(if (symbolp (car file-arg-indices))
(setq method (pop file-arg-indices)))
;; Strip off the /: from the file names that have it.
- (save-match-data
+ (save-match-data ;FIXME: Why?
(while (consp file-arg-indices)
(let ((pair (nthcdr (car file-arg-indices) arguments)))
- (and (car pair)
- (string-match "\\`/:" (car pair))
- (setcar pair
- (if (= (length (car pair)) 2)
- "/"
- (substring (car pair) 2)))))
+ (when (car pair)
+ (setcar pair (file-name-unquote (car pair) t))))
(setq file-arg-indices (cdr file-arg-indices))))
(pcase method
- (`identity (car arguments))
- (`add (file-name-quote (apply operation arguments)))
- (`insert-file-contents
+ ('identity (car arguments))
+ ('add (file-name-quote (apply operation arguments) t))
+ ('buffer-file-name
+ (let ((buffer-file-name (file-name-unquote buffer-file-name t)))
+ (apply operation arguments)))
+ ('insert-file-contents
(let ((visit (nth 1 arguments)))
(unwind-protect
(apply operation arguments)
(when (and visit buffer-file-name)
- (setq buffer-file-name (concat "/:" buffer-file-name))))))
- (`unquote-then-quote
+ (setq buffer-file-name (file-name-quote buffer-file-name t))))))
+ ('unquote-then-quote
;; We can't use `cl-letf' with `(buffer-local-value)' here
;; because it wouldn't work during bootstrapping.
(let ((buffer (current-buffer)))
@@ -7087,32 +7208,73 @@ only these files will be asked to be saved."
;; `verify-visited-file-modtime' action, which takes a buffer
;; as only optional argument.
(with-current-buffer (or (car arguments) buffer)
- (let ((buffer-file-name (substring buffer-file-name 2)))
+ (let ((buffer-file-name (file-name-unquote buffer-file-name t)))
;; Make sure to hide the temporary buffer change from the
;; underlying operation.
(with-current-buffer buffer
(apply operation arguments))))))
+ ('local-copy
+ (let* ((file-name-handler-alist saved-file-name-handler-alist)
+ (source (car arguments))
+ (target (car (cdr arguments)))
+ (prefix (expand-file-name
+ "file-name-non-special" temporary-file-directory))
+ tmpfile)
+ (cond
+ ;; If source is remote, we must create a local copy.
+ ((file-remote-p source)
+ (setq tmpfile (make-temp-name prefix))
+ (apply operation source tmpfile (cddr arguments))
+ (setq source tmpfile))
+ ;; If source is quoted, and the unquoted source looks
+ ;; remote, we must create a local copy.
+ ((file-name-quoted-p source t)
+ (setq source (file-name-unquote source t))
+ (when (file-remote-p source)
+ (setq tmpfile (make-temp-name prefix))
+ (let (file-name-handler-alist)
+ (apply operation source tmpfile (cddr arguments)))
+ (setq source tmpfile))))
+ ;; If target is quoted, and the unquoted target looks remote,
+ ;; we must disable the file name handler.
+ (when (file-name-quoted-p target t)
+ (setq target (file-name-unquote target t))
+ (when (file-remote-p target)
+ (setq file-name-handler-alist nil)))
+ ;; Do it.
+ (setcar arguments source)
+ (setcar (cdr arguments) target)
+ (apply operation arguments)
+ ;; Cleanup.
+ (when (and tmpfile (file-exists-p tmpfile))
+ (if (file-directory-p tmpfile)
+ (delete-directory tmpfile 'recursive) (delete-file tmpfile)))))
(_
(apply operation arguments)))))
-(defsubst file-name-quoted-p (name)
+(defsubst file-name-quoted-p (name &optional top)
"Whether NAME is quoted with prefix \"/:\".
-If NAME is a remote file name, check the local part of NAME."
- (string-prefix-p "/:" (file-local-name name)))
+If NAME is a remote file name and TOP is nil, check the local part of NAME."
+ (let ((file-name-handler-alist (unless top file-name-handler-alist)))
+ (string-prefix-p "/:" (file-local-name name))))
-(defsubst file-name-quote (name)
+(defsubst file-name-quote (name &optional top)
"Add the quotation prefix \"/:\" to file NAME.
-If NAME is a remote file name, the local part of NAME is quoted.
-If NAME is already a quoted file name, NAME is returned unchanged."
- (if (file-name-quoted-p name)
- name
- (concat (file-remote-p name) "/:" (file-local-name name))))
-
-(defsubst file-name-unquote (name)
+If NAME is a remote file name and TOP is nil, the local part of
+NAME is quoted. If NAME is already a quoted file name, NAME is
+returned unchanged."
+ (let ((file-name-handler-alist (unless top file-name-handler-alist)))
+ (if (file-name-quoted-p name top)
+ name
+ (concat (file-remote-p name) "/:" (file-local-name name)))))
+
+(defsubst file-name-unquote (name &optional top)
"Remove quotation prefix \"/:\" from file NAME, if any.
-If NAME is a remote file name, the local part of NAME is unquoted."
- (let ((localname (file-local-name name)))
- (when (file-name-quoted-p localname)
+If NAME is a remote file name and TOP is nil, the local part of
+NAME is unquoted."
+ (let* ((file-name-handler-alist (unless top file-name-handler-alist))
+ (localname (file-local-name name)))
+ (when (file-name-quoted-p localname top)
(setq
localname (if (= (length localname) 2) "/" (substring localname 2))))
(concat (file-remote-p name) localname)))
@@ -7213,7 +7375,7 @@ based on existing mode bits, as in \"og+rX-w\"."
(let* ((modes (or (if orig-file (file-modes orig-file) 0)
(error "File not found")))
(modestr (and (stringp orig-file)
- (nth 8 (file-attributes orig-file))))
+ (file-attribute-modes (file-attributes orig-file))))
(default
(and (stringp modestr)
(string-match "^.\\(...\\)\\(...\\)\\(...\\)$" modestr)
@@ -7262,7 +7424,10 @@ Otherwise, trash FILENAME using the freedesktop.org conventions,
like the GNOME, KDE and XFCE desktop environments. Emacs only
moves files to \"home trash\", ignoring per-volume trashcans."
(interactive "fMove file to trash: ")
- (cond (trash-directory
+ ;; If `system-move-file-to-trash' is defined, use it.
+ (cond ((fboundp 'system-move-file-to-trash)
+ (system-move-file-to-trash filename))
+ (trash-directory
;; If `trash-directory' is non-nil, move the file there.
(let* ((trash-dir (expand-file-name trash-directory))
(fn (directory-file-name (expand-file-name filename)))
@@ -7281,9 +7446,6 @@ Otherwise, trash FILENAME using the freedesktop.org conventions,
(setq new-fn (car (find-backup-file-name new-fn)))))
(let (delete-by-moving-to-trash)
(rename-file fn new-fn))))
- ;; If `system-move-file-to-trash' is defined, use it.
- ((fboundp 'system-move-file-to-trash)
- (system-move-file-to-trash filename))
;; Otherwise, use the freedesktop.org method, as specified at
;; http://freedesktop.org/wiki/Specifications/trash-spec
(t
@@ -7393,27 +7555,24 @@ returned."
(defsubst file-attribute-access-time (attributes)
"The last access time in ATTRIBUTES returned by `file-attributes'.
-This a list of integers (HIGH LOW USEC PSEC) in the same style
-as (current-time)."
+This a Lisp timestamp in the style of `current-time'."
(nth 4 attributes))
(defsubst file-attribute-modification-time (attributes)
"The modification time in ATTRIBUTES returned by `file-attributes'.
This is the time of the last change to the file's contents, and
-is a list of integers (HIGH LOW USEC PSEC) in the same style
-as (current-time)."
+is a Lisp timestamp in the style of `current-time'."
(nth 5 attributes))
(defsubst file-attribute-status-change-time (attributes)
"The status modification time in ATTRIBUTES returned by `file-attributes'.
This is the time of last change to the file's attributes: owner
-and group, access mode bits, etc, and is a list of integers (HIGH
-LOW USEC PSEC) in the same style as (current-time)."
+and group, access mode bits, etc., and is a Lisp timestamp in the
+style of `current-time'."
(nth 6 attributes))
(defsubst file-attribute-size (attributes)
- "The size (in bytes) in ATTRIBUTES returned by `file-attributes'.
-This is a floating point number if the size is too large for an integer."
+ "The integer size (in bytes) in ATTRIBUTES returned by `file-attributes'."
(nth 7 attributes))
(defsubst file-attribute-modes (attributes)
@@ -7423,20 +7582,12 @@ This is a string of ten letters or dashes as in ls -l."
(defsubst file-attribute-inode-number (attributes)
"The inode number in ATTRIBUTES returned by `file-attributes'.
-If it is larger than what an Emacs integer can hold, this is of
-the form (HIGH . LOW): first the high bits, then the low 16 bits.
-If even HIGH is too large for an Emacs integer, this is instead
-of the form (HIGH MIDDLE . LOW): first the high bits, then the
-middle 24 bits, and finally the low 16 bits."
+It is a nonnegative integer."
(nth 10 attributes))
(defsubst file-attribute-device-number (attributes)
"The file system device number in ATTRIBUTES returned by `file-attributes'.
-If it is larger than what an Emacs integer can hold, this is of
-the form (HIGH . LOW): first the high bits, then the low 16 bits.
-If even HIGH is too large for an Emacs integer, this is instead
-of the form (HIGH MIDDLE . LOW): first the high bits, then the
-middle 24 bits, and finally the low 16 bits."
+It is an integer."
(nth 11 attributes))
(defun file-attribute-collect (attributes &rest attr-names)
diff --git a/lisp/filesets.el b/lisp/filesets.el
index ea626867d5d..b74b4a8a400 100644
--- a/lisp/filesets.el
+++ b/lisp/filesets.el
@@ -242,8 +242,7 @@ key is supported."
(defun filesets-set-config (fileset var val)
"Set-default wrapper function."
(filesets-reset-fileset fileset)
- (set-default var val))
-; (customize-set-variable var val))
+ (customize-set-variable var val))
; (filesets-build-menu))
;; It seems this is a workaround for the XEmacs issue described in the
@@ -566,7 +565,7 @@ including directory trees to the menu can take a lot of memory."
:group 'filesets)
(defcustom filesets-commands
- `(("Isearch"
+ '(("Isearch"
multi-isearch-files
(filesets-cmd-isearch-getargs))
("Isearch (regexp)"
@@ -1287,10 +1286,10 @@ on-close-all ... Not used"
(filesets-get-external-viewer filename)))))
(filesets-alist-get def
(pcase event
- (`on-open-all ':ignore-on-open-all)
- (`on-grep ':ignore-on-read-text)
- (`on-cmd nil)
- (`on-close-all nil))
+ ('on-open-all ':ignore-on-open-all)
+ ('on-grep ':ignore-on-read-text)
+ ('on-cmd nil)
+ ('on-close-all nil))
nil t)))
(defun filesets-filetype-get-prop (property filename &optional entry)
@@ -1560,7 +1559,7 @@ SAVE-FUNCTION takes no argument, but works on the current buffer."
(defun filesets-get-fileset-from-name (name &optional mode)
"Get fileset definition for NAME."
(pcase mode
- ((or `:ingroup `:tree) name)
+ ((or :ingroup :tree) name)
(_ (assoc name filesets-data))))
diff --git a/lisp/find-dired.el b/lisp/find-dired.el
index 00df68d8f1b..ef137be9bbf 100644
--- a/lisp/find-dired.el
+++ b/lisp/find-dired.el
@@ -144,7 +144,7 @@ use in place of \"-ls\" as the final argument."
;; Check that it's really a directory.
(or (file-directory-p dir)
(error "find-dired needs a directory: %s" dir))
- (switch-to-buffer (get-buffer-create "*Find*"))
+ (pop-to-buffer-same-window (get-buffer-create "*Find*"))
;; See if there's still a `find' running, and offer to kill
;; it first, if it is.
@@ -175,7 +175,7 @@ use in place of \"-ls\" as the final argument."
" " args " "
(shell-quote-argument ")")
" "))
- (if (string-match "\\`\\(.*\\) {} \\(\\\\;\\|+\\)\\'"
+ (if (string-match "\\`\\(.*\\) {} \\(\\\\;\\|\\+\\)\\'"
(car find-ls-option))
(format "%s %s %s"
(match-string 1 (car find-ls-option))
@@ -295,7 +295,7 @@ specifies what to use in place of \"-ls\" as the final argument."
(l-opt (and (consp find-ls-option)
(string-match "l" (cdr find-ls-option))))
(ls-regexp (concat "^ +[^ \t\r\n]+\\( +[^ \t\r\n]+\\) +"
- "[^ \t\r\n]+ +[^ \t\r\n]+\\( +[0-9]+\\)")))
+ "[^ \t\r\n]+ +[^ \t\r\n]+\\( +[^[:space:]]+\\)")))
(goto-char beg)
(insert string)
(goto-char beg)
diff --git a/lisp/find-lisp.el b/lisp/find-lisp.el
index b356a74619c..073e2bc573f 100644
--- a/lisp/find-lisp.el
+++ b/lisp/find-lisp.el
@@ -300,24 +300,24 @@ It is a function which takes two arguments, the directory and its parent."
"Format one line of long ls output for file FILE-NAME.
FILE-ATTR and FILE-SIZE give the file's attributes and size.
SWITCHES and TIME-INDEX give the full switch list and time data."
- (let ((file-type (nth 0 file-attr)))
+ (let ((file-type (file-attribute-type file-attr)))
(concat (if (memq ?i switches) ; inode number
- (format "%6d " (nth 10 file-attr)))
+ (format "%6d " (file-attribute-inode-number file-attr)))
;; nil is treated like "" in concat
(if (memq ?s switches) ; size in K
- (format "%4d " (1+ (/ (nth 7 file-attr) 1024))))
- (nth 8 file-attr) ; permission bits
+ (format "%4d " (1+ (/ (file-attribute-size file-attr) 1024))))
+ (file-attribute-modes file-attr)
(format " %3d %-8s %-8s %8d "
- (nth 1 file-attr) ; no. of links
- (if (numberp (nth 2 file-attr))
- (int-to-string (nth 2 file-attr))
- (nth 2 file-attr)) ; uid
+ (file-attribute-link-number file-attr)
+ (if (numberp (file-attribute-user-id file-attr))
+ (int-to-string (file-attribute-user-id file-attr))
+ (file-attribute-user-id file-attr))
(if (eq system-type 'ms-dos)
"root" ; everything is root on MSDOS.
- (if (numberp (nth 3 file-attr))
- (int-to-string (nth 3 file-attr))
- (nth 3 file-attr))) ; gid
- (nth 7 file-attr) ; size in bytes
+ (if (numberp (file-attribute-group-id file-attr))
+ (int-to-string (file-attribute-group-id file-attr))
+ (file-attribute-group-id file-attr)))
+ (file-attribute-size file-attr)
)
(find-lisp-format-time file-attr switches now)
" "
@@ -342,16 +342,11 @@ list of ls option letters of which c and u are recognized). Use
the same method as \"ls\" to decide whether to show time-of-day or
year, depending on distance between file date and NOW."
(let* ((time (nth (find-lisp-time-index switches) file-attr))
- (diff16 (- (car time) (car now)))
- (diff (+ (ash diff16 16) (- (car (cdr time)) (car (cdr now)))))
- (past-cutoff (- (* 6 30 24 60 60))) ; 6 30-day months
+ (diff (encode-time (time-subtract time now) 'integer))
+ (past-cutoff -15778476) ; 1/2 of a Gregorian year
(future-cutoff (* 60 60))) ; 1 hour
(format-time-string
- (if (and
- (<= past-cutoff diff) (<= diff future-cutoff)
- ;; Sanity check in case `diff' computation overflowed.
- (<= (1- (ash past-cutoff -16)) diff16)
- (<= diff16 (1+ (ash future-cutoff -16))))
+ (if (<= past-cutoff diff future-cutoff)
"%b %e %H:%M"
"%b %e %Y")
time)))
diff --git a/lisp/foldout.el b/lisp/foldout.el
index ae0eb0ff2b3..3ef88fe686a 100644
--- a/lisp/foldout.el
+++ b/lisp/foldout.el
@@ -209,10 +209,6 @@
(require 'outline)
-;; something has gone very wrong if outline-minor-mode isn't bound now.
-(if (not (boundp 'outline-minor-mode))
- (error "Can't find outline-minor-mode"))
-
(defvar foldout-fold-list nil
"List of start and end markers for the folds currently entered.
An end marker of nil means the fold ends after (point-max).")
diff --git a/lisp/follow.el b/lisp/follow.el
index 2ab44b21dd5..acc2b26c550 100644
--- a/lisp/follow.el
+++ b/lisp/follow.el
@@ -187,8 +187,8 @@
;; Implementation:
;;
;; The main method by which Follow mode aligns windows is via the
-;; function `follow-post-command-hook', which is run after each
-;; command. This "fixes up" the alignment of other windows which are
+;; function `follow-pre-redisplay-function', which is run before each
+;; redisplay. This "fixes up" the alignment of other windows which are
;; showing the same Follow mode buffer, on the same frame as the
;; selected window. It does not try to deal with buffers other than
;; the buffer of the selected frame, or windows on other frames.
@@ -311,6 +311,17 @@ are \" Fw\", or simply \"\"."
(remove-hook 'find-file-hook 'follow-find-file-hook))
(set-default symbol value)))
+(defcustom follow-hide-ghost-cursors t ; Maybe this should be nil.
+ "When non-nil, Follow mode attempts to hide the obtrusive cursors
+in the non-selected windows of a window group.
+
+This variable takes effect when `follow-mode' is initialized.
+
+Due to limitations in Emacs, this only operates on the followers
+of the selected window."
+ :type 'boolean
+ :group 'follow)
+
(defvar follow-cache-command-list
'(next-line previous-line forward-char backward-char right-char left-char)
"List of commands that don't require recalculation.
@@ -383,9 +394,6 @@ This is typically set by explicit scrolling commands.")
;;;###autoload
(define-minor-mode follow-mode
"Toggle Follow mode.
-With a prefix argument ARG, enable Follow mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Follow mode is a minor mode that combines windows into one tall
virtual window. This is accomplished by two main techniques:
@@ -421,7 +429,7 @@ Keys specific to Follow mode:
(if follow-mode
(progn
(add-hook 'compilation-filter-hook 'follow-align-compilation-windows t t)
- (add-hook 'post-command-hook 'follow-post-command-hook t)
+ (add-function :before pre-redisplay-function 'follow-pre-redisplay-function)
(add-hook 'window-size-change-functions 'follow-window-size-change t)
(add-hook 'after-change-functions 'follow-after-change nil t)
(add-hook 'isearch-update-post-hook 'follow-post-command-hook nil t)
@@ -430,6 +438,8 @@ Keys specific to Follow mode:
(when isearch-lazy-highlight
(setq-local isearch-lazy-highlight 'all-windows))
+ (when follow-hide-ghost-cursors
+ (setq-local cursor-in-non-selected-windows nil))
(setq window-group-start-function 'follow-window-start)
(setq window-group-end-function 'follow-window-end)
@@ -448,7 +458,7 @@ Keys specific to Follow mode:
(setq following (buffer-local-value 'follow-mode (car buffers))
buffers (cdr buffers)))
(unless following
- (remove-hook 'post-command-hook 'follow-post-command-hook)
+ (remove-function pre-redisplay-function 'follow-pre-redisplay-function)
(remove-hook 'window-size-change-functions 'follow-window-size-change)))
(kill-local-variable 'move-to-window-group-line-function)
@@ -459,6 +469,8 @@ Keys specific to Follow mode:
(kill-local-variable 'window-group-end-function)
(kill-local-variable 'window-group-start-function)
+ (kill-local-variable 'cursor-in-non-selected-windows)
+
(remove-hook 'ispell-update-post-hook 'follow-post-command-hook t)
(remove-hook 'replace-update-post-hook 'follow-post-command-hook t)
(remove-hook 'isearch-update-post-hook 'follow-post-command-hook t)
@@ -1263,10 +1275,31 @@ non-first windows in Follow mode."
(not (eq win top)))) ;; Loop while this is true.
(set-buffer orig-buffer))))
-;;; Post Command Hook
+;;; Pre Display Function
+
+(defvar follow-prev-buffer nil
+ "The buffer current at the last call to `follow-adjust-window' or nil.
+follow-mode is not necessarily enabled in this buffer.")
-;; The magic little box. This function is called after every command.
+;; This function is added to `pre-display-function' and is thus called
+;; before each redisplay operation. It supersedes (2018-09) the
+;; former use of the post command hook, and now does the right thing
+;; when a program calls `redisplay' or `sit-for'.
+(defun follow-pre-redisplay-function (wins)
+ (if (or (eq wins t)
+ (null wins)
+ (and (listp wins)
+ (memq (selected-window) wins)))
+ (follow-post-command-hook)))
+
+;;; Post Command Hook
+
+;; The magic little box. This function was formerly called after every
+;; command. It is now called before each redisplay operation (see
+;; `follow-pre-redisplay-function' above), and at the end of several
+;; search/replace commands. It retains its historical name.
+;;
;; This is not as complicated as it seems. It is simply a list of common
;; display situations and the actions to take, plus commands for redrawing
;; the screen if it should be unaligned.
@@ -1287,9 +1320,33 @@ non-first windows in Follow mode."
(setq follow-windows-start-end-cache nil))
(follow-adjust-window win)))))
+;; NOTE: to debug follow-mode with edebug, it is helpful to add
+;; `follow-post-command-hook' to `post-command-hook' temporarily. Do
+;; this locally to the target buffer with, say,:
+;; M-: (add-hook 'post-command-hook 'follow-post-command-hook t t)
+;; .
+
(defun follow-adjust-window (win)
;; Adjust the window WIN and its followers.
(cl-assert (eq (window-buffer win) (current-buffer)))
+
+ ;; Have we moved out of or into a follow-mode window group?
+ ;; If so, attend to the visibility of the cursors.
+ (when (not (eq (current-buffer) follow-prev-buffer))
+ ;; Do we need to switch off cursor handling in the previous buffer?
+ (when (buffer-live-p follow-prev-buffer)
+ (with-current-buffer follow-prev-buffer
+ (when (and follow-mode
+ (local-variable-p 'cursor-in-non-selected-windows))
+ (setq cursor-in-non-selected-windows
+ (default-value 'cursor-in-non-selected-windows)))))
+ ;; Do we need to switch on cursor handling in the current buffer?
+ (when (and follow-mode
+ (local-variable-p 'cursor-in-non-selected-windows))
+ (setq cursor-in-non-selected-windows nil))
+ (when (buffer-live-p (current-buffer))
+ (setq follow-prev-buffer (current-buffer))))
+
(when (and follow-mode
(not (window-minibuffer-p win)))
(let ((windows (follow-all-followers win)))
diff --git a/lisp/font-core.el b/lisp/font-core.el
index 8e190bb2ade..6b26f0cb92e 100644
--- a/lisp/font-core.el
+++ b/lisp/font-core.el
@@ -78,9 +78,6 @@ It will be passed one argument, which is the current value of
(define-minor-mode font-lock-mode
"Toggle syntax highlighting in this buffer (Font Lock mode).
-With a prefix argument ARG, enable Font Lock mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
When Font Lock mode is enabled, text is fontified as you type it:
diff --git a/lisp/font-lock.el b/lisp/font-lock.el
index d3828cf6b47..1475911195a 100644
--- a/lisp/font-lock.el
+++ b/lisp/font-lock.el
@@ -1,4 +1,4 @@
-;;; font-lock.el --- Electric font lock mode
+;;; font-lock.el --- Electric font lock mode -*- lexical-binding:t -*-
;; Copyright (C) 1992-2019 Free Software Foundation, Inc.
@@ -327,6 +327,9 @@ If a number, only buffers greater than this size have fontification messages."
(defvar font-lock-type-face 'font-lock-type-face
"Face name to use for type and class names.")
+(define-obsolete-variable-alias
+ 'font-lock-reference-face 'font-lock-constant-face "20.3")
+
(defvar font-lock-constant-face 'font-lock-constant-face
"Face name to use for constant and label names.")
@@ -340,9 +343,6 @@ This can be an \"!\" or the \"n\" in \"ifndef\".")
(defvar font-lock-preprocessor-face 'font-lock-preprocessor-face
"Face name to use for preprocessor directives.")
-(define-obsolete-variable-alias
- 'font-lock-reference-face 'font-lock-constant-face "20.3")
-
;; Fontification variables:
(defvar font-lock-keywords nil
@@ -631,10 +631,7 @@ Major/minor modes can set this variable if they know which option applies.")
(declare (indent 0) (debug t))
`(let ((inhibit-point-motion-hooks t))
(with-silent-modifications
- ,@body)))
- ;;
- ;; Shut up the byte compiler.
- (defvar font-lock-face-attributes)) ; Obsolete but respected if set.
+ ,@body))))
(defvar-local font-lock-set-defaults nil) ; Whether we have set up defaults.
@@ -659,7 +656,7 @@ be enabled."
(cond (font-lock-fontified
nil)
((or (null max-size) (> max-size (buffer-size)))
- (font-lock-fontify-buffer))
+ (with-no-warnings (font-lock-fontify-buffer)))
(font-lock-verbose
(message "Fontifying %s...buffer size greater than font-lock-maximum-size"
(buffer-name)))))))
@@ -929,9 +926,9 @@ The value of this variable is used when Font Lock mode is turned on."
(defun font-lock-turn-on-thing-lock ()
(pcase (font-lock-value-in-major-mode font-lock-support-mode)
- (`fast-lock-mode (fast-lock-mode t))
- (`lazy-lock-mode (lazy-lock-mode t))
- (`jit-lock-mode
+ ('fast-lock-mode (fast-lock-mode t))
+ ('lazy-lock-mode (lazy-lock-mode t))
+ ('jit-lock-mode
;; Prepare for jit-lock
(remove-hook 'after-change-functions
#'font-lock-after-change-function t)
@@ -1096,14 +1093,10 @@ accessible portion of the current buffer."
(or beg (point-min)) (or end (point-max)))))
(defvar font-lock-ensure-function
- (lambda (_beg _end)
+ (lambda (beg end)
(unless font-lock-fontified
- (font-lock-default-fontify-buffer)
- (unless font-lock-mode
- ;; If font-lock is not enabled, we don't have the hooks in place to
- ;; track modifications, so a subsequent call to font-lock-ensure can't
- ;; assume that the fontification is still valid.
- (setq font-lock-fontified nil))))
+ (save-excursion
+ (font-lock-fontify-region (or beg (point-min)) (or end (point-max))))))
"Function to make sure a region has been fontified.
Called with two arguments BEG and END.")
@@ -1787,7 +1780,7 @@ If SYNTACTIC-KEYWORDS is non-nil, it means these keywords are used for
(cons t (cons keywords
(mapcar #'font-lock-compile-keyword keywords))))
(if (and (not syntactic-keywords)
- (let ((beg-function syntax-begin-function))
+ (let ((beg-function (with-no-warnings syntax-begin-function)))
(or (eq beg-function #'beginning-of-defun)
(if (symbolp beg-function)
(get beg-function 'font-lock-syntax-paren-check))))
diff --git a/lisp/format-spec.el b/lisp/format-spec.el
index db6b8768088..4455c594286 100644
--- a/lisp/format-spec.el
+++ b/lisp/format-spec.el
@@ -24,8 +24,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
-
(defun format-spec (format specification)
"Return a string based on FORMAT and SPECIFICATION.
FORMAT is a string containing `format'-like specs like \"bash %u %k\",
diff --git a/lisp/format.el b/lisp/format.el
index 811b1dd1bfa..93f131bbcca 100644
--- a/lisp/format.el
+++ b/lisp/format.el
@@ -84,7 +84,7 @@
iso-sgml2iso iso-iso2sgml t nil)
(rot13 ,(purecopy "rot13")
nil
- ,(purecopy "tr a-mn-z n-za-m") ,(purecopy "tr a-mn-z n-za-m") t nil)
+ rot13-region rot13-region t nil)
(duden ,(purecopy "Duden Ersatzdarstellung")
nil
,(purecopy "diac") iso-iso2duden t nil)
@@ -539,13 +539,7 @@ Compare using `equal'."
(setq tail next)))
(cons acopy bcopy)))
-(defun format-proper-list-p (list)
- "Return t if LIST is a proper list.
-A proper list is a list ending with a nil cdr, not with an atom "
- (when (listp list)
- (while (consp list)
- (setq list (cdr list)))
- (null list)))
+(define-obsolete-function-alias 'format-proper-list-p 'proper-list-p "27.1")
(defun format-reorder (items order)
"Arrange ITEMS to follow partial ORDER.
@@ -1005,12 +999,10 @@ either strings, or lists of the form (PARAMETER VALUE)."
;; If either old or new is a list, have to treat both that way.
(if (and (or (listp old) (listp new))
(not (get prop 'format-list-atomic-p)))
- (if (or (not (format-proper-list-p old))
- (not (format-proper-list-p new)))
+ (if (not (and (proper-list-p old)
+ (proper-list-p new)))
(format-annotate-atomic-property-change prop-alist old new)
- (let* ((old (if (listp old) old (list old)))
- (new (if (listp new) new (list new)))
- close open)
+ (let (close open)
(while old
(setq close
(append (car (format-annotate-atomic-property-change
diff --git a/lisp/frame.el b/lisp/frame.el
index a0e62e1d69d..b5c936a51eb 100644
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -129,22 +129,107 @@ appended when the minibuffer frame is created."
;; Gildea@x.org says it is ok to ask questions before terminating.
(save-buffers-kill-emacs))))
-(defun handle-focus-in (_event)
+(defun frame-focus-state (&optional frame)
+ "Return FRAME's last known focus state.
+If nil or omitted, FRAME defaults to the selected frame.
+
+Return nil if the frame is definitely known not be focused, t if
+the frame is known to be focused, and `unknown' if we don't know."
+ (let* ((frame (or frame (selected-frame)))
+ (tty-top-frame (tty-top-frame frame)))
+ (if (not tty-top-frame)
+ (frame-parameter frame 'last-focus-update)
+ ;; All tty frames are frame-visible-p if the terminal is
+ ;; visible, so check whether the frame is the top tty frame
+ ;; before checking visibility.
+ (cond ((not (eq tty-top-frame frame)) nil)
+ ((not (frame-visible-p frame)) nil)
+ (t (let ((tty-focus-state
+ (terminal-parameter frame 'tty-focus-state)))
+ (cond ((eq tty-focus-state 'focused) t)
+ ((eq tty-focus-state 'defocused) nil)
+ (t 'unknown))))))))
+
+(defvar after-focus-change-function #'ignore
+ "Function called after frame focus may have changed.
+
+This function is called with no arguments when Emacs notices that
+the set of focused frames may have changed. Code wanting to do
+something when frame focus changes should use `add-function' to
+add a function to this one, and in this added function, re-scan
+the set of focused frames, calling `frame-focus-state' to
+retrieve the last known focus state of each frame. Focus events
+are delivered asynchronously, and frame input focus according to
+an external system may not correspond to the notion of the Emacs
+selected frame. Multiple frames may appear to have input focus
+simultaneously due to focus event delivery differences, the
+presence of multiple Emacs terminals, and other factors, and code
+should be robust in the face of this situation.
+
+Depending on window system, focus events may also be delivered
+repeatedly and with different focus states before settling to the
+expected values. Code relying on focus notifications should
+\"debounce\" any user-visible updates arising from focus changes,
+perhaps by deferring work until redisplay.
+
+This function may be called in arbitrary contexts, including from
+inside `read-event', so take the same care as you might when
+writing a process filter.")
+
+(defvar focus-in-hook nil
+ "Normal hook run when a frame gains focus.
+The frame gaining focus is selected at the time this hook is run.
+
+This hook is obsolete. Despite its name, this hook may be run in
+situations other than when a frame obtains input focus: for
+example, we also run this hook when switching the selected frame
+internally to handle certain input events (like mouse wheel
+scrolling) even when the user's notion of input focus
+hasn't changed.
+
+Prefer using `after-focus-change-function'.")
+(make-obsolete-variable
+ 'focus-in-hook "after-focus-change-function" "27.1" 'set)
+
+(defvar focus-out-hook nil
+ "Normal hook run when all frames lost input focus.
+
+This hook is obsolete; see `focus-in-hook'. Depending on timing,
+this hook may be delivered when a frame does in fact have focus.
+Prefer `after-focus-change-function'.")
+(make-obsolete-variable
+ 'focus-out-hook "after-focus-change-function" "27.1" 'set)
+
+(defun handle-focus-in (event)
"Handle a focus-in event.
-Focus-in events are usually bound to this function.
-Focus-in events occur when a frame has focus, but a switch-frame event
-is not generated.
-This function runs the hook `focus-in-hook'."
+Focus-in events are bound to this function; do not change this
+binding. Focus-in events occur when a frame receives focus from
+the window system."
+ ;; N.B. tty focus goes down a different path; see xterm.el.
(interactive "e")
- (run-hooks 'focus-in-hook))
-
-(defun handle-focus-out (_event)
+ (unless (eq (car-safe event) 'focus-in)
+ (error "handle-focus-in should handle focus-in events"))
+ (let ((frame (nth 1 event)))
+ (when (frame-live-p frame)
+ (internal-handle-focus-in event)
+ (setf (frame-parameter frame 'last-focus-update) t)
+ (run-hooks 'focus-in-hook)))
+ (funcall after-focus-change-function))
+
+(defun handle-focus-out (event)
"Handle a focus-out event.
-Focus-out events are usually bound to this function.
-Focus-out events occur when no frame has focus.
-This function runs the hook `focus-out-hook'."
+Focus-out events are bound to this function; do not change this
+binding. Focus-out events occur when a frame loses focus, but
+that's not the whole story: see `after-focus-change-function'."
+ ;; N.B. tty focus goes down a different path; see xterm.el.
(interactive "e")
- (run-hooks 'focus-out-hook))
+ (unless (eq (car event) 'focus-out)
+ (error "handle-focus-out should handle focus-out events"))
+ (let ((frame (nth 1 event)))
+ (when (frame-live-p frame)
+ (setf (frame-parameter frame 'last-focus-update) nil)
+ (run-hooks 'focus-out-hook)))
+ (funcall after-focus-change-function))
(defun handle-move-frame (event)
"Handle a move-frame event.
@@ -231,10 +316,15 @@ there (in decreasing order of priority)."
;; want to use save-excursion here, because that may also try to set
;; the buffer of the selected window, which fails when the selected
;; window is the minibuffer.
- (let ((old-buffer (current-buffer))
- (window-system-frame-alist
- (cdr (assq initial-window-system
- window-system-default-frame-alist))))
+ (let* ((old-buffer (current-buffer))
+ (window-system-frame-alist
+ (cdr (assq initial-window-system
+ window-system-default-frame-alist)))
+ (minibuffer
+ (cdr (or (assq 'minibuffer initial-frame-alist)
+ (assq 'minibuffer window-system-frame-alist)
+ (assq 'minibuffer default-frame-alist)
+ '(minibuffer . t)))))
(when (and frame-notice-user-settings
(null frame-initial-frame))
@@ -325,11 +415,7 @@ there (in decreasing order of priority)."
;; default-frame-alist in the parameters of the screen we
;; create here, so that its new value, gleaned from the user's
;; init file, will be applied to the existing screen.
- (if (not (eq (cdr (or (assq 'minibuffer initial-frame-alist)
- (assq 'minibuffer window-system-frame-alist)
- (assq 'minibuffer default-frame-alist)
- '(minibuffer . t)))
- t))
+ (if (not (eq minibuffer t))
;; Create the new frame.
(let (parms new)
;; MS-Windows needs this to avoid inflooping below.
@@ -357,7 +443,15 @@ there (in decreasing order of priority)."
parms
nil))
- ;; Get rid of `reverse', because that was handled
+ (when (eq minibuffer 'child-frame)
+ ;; When the minibuffer shall be shown in a child frame,
+ ;; remove the 'minibuffer' parameter from PARMS. It
+ ;; will get assigned by the usual routines to the child
+ ;; frame's root window below.
+ (setq parms (cons '(minibuffer)
+ (delq (assq 'minibuffer parms) parms))))
+
+ ;; Get rid of `reverse', because that was handled
;; when we first made the frame.
(setq parms (cons '(reverse) (delq (assq 'reverse parms) parms)))
@@ -380,7 +474,18 @@ there (in decreasing order of priority)."
;; the only frame with a minibuffer. If it is, create a
;; new one.
(or (delq frame-initial-frame (minibuffer-frame-list))
- (make-initial-minibuffer-frame nil))
+ (and (eq minibuffer 'child-frame)
+ ;; Create a minibuffer child frame and parent it
+ ;; immediately. Take any other parameters for
+ ;; the child frame from 'minibuffer-frame-list'.
+ (let* ((minibuffer-frame-alist
+ (cons `(parent-frame . ,new) minibuffer-frame-alist)))
+ (make-initial-minibuffer-frame nil)
+ ;; With a minibuffer child frame we do not want
+ ;; to select the minibuffer frame initially as
+ ;; we do for standard minibuffer-only frames.
+ (select-frame new)))
+ (make-initial-minibuffer-frame nil))
;; If the initial frame is serving as a surrogate
;; minibuffer frame for any frames, we need to wean them
@@ -559,9 +664,39 @@ Return nil if we don't know how to interpret DISPLAY."
(defun make-frame-on-display (display &optional parameters)
"Make a frame on display DISPLAY.
The optional argument PARAMETERS specifies additional frame parameters."
- (interactive "sMake frame on display: ")
+ (interactive (list (completing-read
+ (format "Make frame on display: ")
+ (delete-dups
+ (mapcar (lambda (frame)
+ (frame-parameter frame 'display))
+ (frame-list))))))
(make-frame (cons (cons 'display display) parameters)))
+(defun make-frame-on-monitor (monitor &optional display parameters)
+ "Make a frame on monitor MONITOR.
+The optional argument DISPLAY can be a display name, and the optional
+argument PARAMETERS specifies additional frame parameters."
+ (interactive
+ (list
+ (let* ((default (cdr (assq 'name (frame-monitor-attributes)))))
+ (completing-read
+ (format "Make frame on monitor (default %s): " default)
+ (or (delq nil (mapcar (lambda (a)
+ (cdr (assq 'name a)))
+ (display-monitor-attributes-list)))
+ '(""))
+ nil nil nil nil default))))
+ (let* ((monitor-workarea
+ (catch 'done
+ (dolist (a (display-monitor-attributes-list display))
+ (when (equal (cdr (assq 'name a)) monitor)
+ (throw 'done (cdr (assq 'workarea a)))))))
+ (geometry-parameters
+ (when monitor-workarea
+ `((top . ,(nth 1 monitor-workarea))
+ (left . ,(nth 0 monitor-workarea))))))
+ (make-frame (append geometry-parameters parameters))))
+
(declare-function x-close-connection "xfns.c" (terminal))
(defun close-display-connection (display)
@@ -616,9 +751,6 @@ frame.")
(defvar after-setting-font-hook nil
"Functions to run after a frame's font has been changed.")
-;; Alias, kept temporarily.
-(define-obsolete-function-alias 'new-frame 'make-frame "22.1")
-
(defvar frame-inherited-parameters '()
"Parameters `make-frame' copies from the selected to the new frame.")
@@ -681,7 +813,7 @@ the new frame according to its own rules."
(t window-system)))
(oldframe (selected-frame))
(params parameters)
- frame)
+ frame child-frame)
(unless (get w 'window-system-initialized)
(let ((window-system w)) ;Hack attack!
@@ -697,17 +829,44 @@ the new frame according to its own rules."
(dolist (p default-frame-alist)
(unless (assq (car p) params)
(push p params)))
- ;; Now make the frame.
- (run-hooks 'before-make-frame-hook)
;; (setq frame-size-history '(1000))
- (setq frame (let ((window-system w)) ;Hack attack!
+ (when (eq (cdr (or (assq 'minibuffer params) '(minibuffer . t)))
+ 'child-frame)
+ ;; If the 'minibuffer' parameter equals 'child-frame' make a
+ ;; frame without minibuffer first using the root window of
+ ;; 'default-minibuffer-frame' as its minibuffer window
+ (setq child-frame t)
+ (setq params (cons '(minibuffer)
+ (delq (assq 'minibuffer params) params))))
+
+ ;; Now make the frame.
+ (run-hooks 'before-make-frame-hook)
+
+ (setq frame (let ((window-system w)) ; Hack attack!
(frame-creation-function params)))
+
+ (when child-frame
+ ;; When we want to equip the new frame with a minibuffer-only
+ ;; child frame, make that frame and reparent it immediately.
+ (setq child-frame
+ (make-frame
+ (append
+ `((display . ,display) (minibuffer . only)
+ (parent-frame . ,frame))
+ minibuffer-frame-alist)))
+ (when (frame-live-p child-frame)
+ ;; Have the 'minibuffer' parameter of our new frame refer to
+ ;; its child frame's root window.
+ (set-frame-parameter
+ frame 'minibuffer (frame-root-window child-frame))))
+
(normal-erase-is-backspace-setup-frame frame)
- ;; Inherit the original frame's parameters.
+ ;; Inherit original frame's parameters unless they are overridden
+ ;; by explicit parameters.
(dolist (param frame-inherited-parameters)
- (unless (assq param parameters) ;Overridden by explicit parameters.
+ (unless (assq param parameters)
(let ((val (frame-parameter oldframe param)))
(when val (set-frame-parameter frame param val)))))
@@ -815,7 +974,7 @@ recently selected windows nor the buffer list."
(select-frame frame norecord)
(raise-frame frame)
;; Ensure, if possible, that FRAME gets input focus.
- (when (memq (window-system frame) '(x w32 ns))
+ (when (display-multi-frame-p frame)
(x-focus-frame frame))
;; Move mouse cursor if necessary.
(cond
@@ -868,16 +1027,15 @@ that variable should be nil."
"Do whatever is right to suspend the current frame.
Calls `suspend-emacs' if invoked from the controlling tty device,
`suspend-tty' from a secondary tty device, and
-`iconify-or-deiconify-frame' from an X frame."
+`iconify-or-deiconify-frame' from a graphical frame."
(interactive)
- (let ((type (framep (selected-frame))))
- (cond
- ((memq type '(x ns w32)) (iconify-or-deiconify-frame))
- ((eq type t)
- (if (controlling-tty-p)
- (suspend-emacs)
- (suspend-tty)))
- (t (suspend-emacs)))))
+ (cond
+ ((display-multi-frame-p) (iconify-or-deiconify-frame))
+ ((eq (framep (selected-frame)) t)
+ (if (controlling-tty-p)
+ (suspend-emacs)
+ (suspend-tty)))
+ (t (suspend-emacs))))
(defun make-frame-names-alist ()
;; Only consider the frames on the same display.
@@ -958,7 +1116,7 @@ face specs for the new background mode."
(default-bg-mode
(if (or (window-system frame)
(and tty-type
- (string-match "^\\(xterm\\|\\rxvt\\|dtterm\\|eterm\\)"
+ (string-match "^\\(xterm\\|rxvt\\|dtterm\\|eterm\\)"
tty-type)))
'light
'dark))
@@ -1005,9 +1163,23 @@ face specs for the new background mode."
;; most faces are unmodified).
(dolist (face (face-list))
(and (not (get face 'face-override-spec))
- (not (face-spec-match-p face
- (face-user-default-spec face)
- (selected-frame)))
+ (not (and
+ ;; If the face was not yet realized for the
+ ;; frame, face-spec-match-p will signal an
+ ;; error, so treat such a missing face as
+ ;; having a mismatched spec; the call to
+ ;; face-spec-recalc below will then realize
+ ;; the face for the frame. This happens
+ ;; during startup with -rv on the command
+ ;; line for the initial frame, because frames
+ ;; are not recorded in the pdump file.
+ (assq face (frame-face-alist))
+ (face-spec-match-p face
+ (face-user-default-spec face)
+ ;; FIXME: why selected-frame and
+ ;; not the frame that is the
+ ;; argument to this function?
+ (selected-frame))))
(push face locally-modified-faces)))
;; Now change to the new frame parameters
(modify-frame-parameters frame params)
@@ -1149,8 +1321,6 @@ FRAME defaults to the selected frame."
(declare-function x-list-fonts "xfaces.c"
(pattern &optional face frame maximum width))
-(define-obsolete-function-alias 'set-default-font 'set-frame-font "23.1")
-
(defun set-frame-font (font &optional keep-size frames)
"Set the default font to FONT.
When called interactively, prompt for the name of a font, and use
@@ -1304,9 +1474,6 @@ To get the frame's current border color, use `frame-parameters'."
(define-minor-mode auto-raise-mode
"Toggle whether or not selected frames should auto-raise.
-With a prefix argument ARG, enable Auto Raise mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Auto Raise mode does nothing under most window managers, which
switch focus on mouse clicks. It only has an effect if your
@@ -1324,9 +1491,6 @@ often have their own auto-raise feature."
(define-minor-mode auto-lower-mode
"Toggle whether or not the selected frame should auto-lower.
-With a prefix argument ARG, enable Auto Lower mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Auto Lower mode does nothing under most window managers, which
switch focus on mouse clicks. It only has an effect if your
@@ -1535,7 +1699,10 @@ keys and their meanings."
(or frame (setq frame (selected-frame)))
(cl-loop for attributes in (display-monitor-attributes-list frame)
for frames = (cdr (assq 'frames attributes))
- if (memq frame frames) return attributes))
+ if (memq frame frames) return attributes
+ ;; On broken frames monitor attributes,
+ ;; fall back to the last monitor.
+ finally return attributes))
(defun frame-monitor-attribute (attribute &optional frame x y)
"Return the value of ATTRIBUTE on FRAME's monitor.
@@ -1673,20 +1840,17 @@ for FRAME."
(let* ((frame (window-normalize-frame frame))
(root (frame-root-window frame))
(mini (minibuffer-window frame))
- (mini-height-before-size-change 0)
+ (mini-old-height 0)
(mini-height 0))
;; FRAME's minibuffer window counts iff it's on FRAME and FRAME is
;; not a minibuffer-only frame.
(when (and (eq (window-frame mini) frame) (not (eq mini root)))
- (setq mini-height-before-size-change
- (window-pixel-height-before-size-change mini))
+ (setq mini-old-height (window-old-pixel-height mini))
(setq mini-height (window-pixel-height mini)))
;; Return non-nil when either the width of the root or the sum of
;; the heights of root and minibuffer window changed.
- (or (/= (window-pixel-width-before-size-change root)
- (window-pixel-width root))
- (/= (+ (window-pixel-height-before-size-change root)
- mini-height-before-size-change)
+ (or (/= (window-old-pixel-width root) (window-pixel-width root))
+ (/= (+ (window-old-pixel-height root) mini-old-height)
(+ (window-pixel-height root) mini-height)))))
;;;; Frame/display capabilities.
@@ -1749,6 +1913,7 @@ frame's display)."
(fboundp 'image-mask-p)
(fboundp 'image-size)))
+(defalias 'display-blink-cursor-p 'display-graphic-p)
(defalias 'display-multi-frame-p 'display-graphic-p)
(defalias 'display-multi-font-p 'display-graphic-p)
@@ -1770,6 +1935,16 @@ frame's display)."
(t
nil))))
+(defun display-symbol-keys-p (&optional display)
+ "Return non-nil if DISPLAY supports symbol names as keys.
+This means that, for example, DISPLAY can differentiate between
+the keybinding RET and [return]."
+ (let ((frame-type (framep-on-display display)))
+ (or (memq frame-type '(x w32 ns pc))
+ ;; MS-DOS and MS-Windows terminals have built-in support for
+ ;; function (symbol) keys
+ (memq system-type '(ms-dos windows-nt)))))
+
(declare-function x-display-screens "xfns.c" (&optional terminal))
(defun display-screens (&optional display)
@@ -1926,7 +2101,7 @@ If DISPLAY is omitted or nil, it defaults to the selected frame's display."
((eq frame-type 'pc)
4)
(t
- (truncate (log (length (tty-color-alist)) 2))))))
+ (logb (length (tty-color-alist)))))))
(declare-function x-display-color-cells "xfns.c" (&optional terminal))
@@ -2123,10 +2298,6 @@ a live frame and defaults to the selected one."
(delete-frame this))
(setq this next))))
-;; miscellaneous obsolescence declarations
-(define-obsolete-variable-alias 'delete-frame-hook
- 'delete-frame-functions "22.1")
-
;;; Window dividers.
(defgroup window-divider nil
@@ -2231,9 +2402,6 @@ all divider widths to zero."
(define-minor-mode window-divider-mode
"Display dividers between windows (Window Divider mode).
-With a prefix argument ARG, enable Window Divider mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
The option `window-divider-default-places' specifies on which
side of a window dividers are displayed. The options
@@ -2332,7 +2500,6 @@ command starts, by installing a pre-command hook."
(blink-cursor-suspend)
(add-hook 'post-command-hook 'blink-cursor-check)))
-
(defun blink-cursor-end ()
"Stop cursor blinking.
This is installed as a pre-command hook by `blink-cursor-start'.
@@ -2354,22 +2521,37 @@ frame receives focus."
(cancel-timer blink-cursor-idle-timer)
(setq blink-cursor-idle-timer nil)))
+(defun blink-cursor--should-blink ()
+ "Determine whether we should be blinking.
+Returns whether we have any focused non-TTY frame."
+ (and blink-cursor-mode
+ (let ((frame-list (frame-list))
+ (any-graphical-focused nil))
+ (while frame-list
+ (let ((frame (pop frame-list)))
+ (when (and (display-graphic-p frame) (frame-focus-state frame))
+ (setf any-graphical-focused t)
+ (setf frame-list nil))))
+ any-graphical-focused)))
+
(defun blink-cursor-check ()
"Check if cursor blinking shall be restarted.
-This is done when a frame gets focus. Blink timers may be stopped by
-`blink-cursor-suspend'."
- (when (and blink-cursor-mode
- (not blink-cursor-idle-timer))
- (remove-hook 'post-command-hook 'blink-cursor-check)
- (blink-cursor--start-idle-timer)))
-
-(define-obsolete-variable-alias 'blink-cursor 'blink-cursor-mode "22.1")
+This is done when a frame gets focus. Blink timers may be
+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)
+ (blink-cursor--start-idle-timer))
+ should-blink))
+
+(defun blink-cursor--rescan-frames (&optional _ign)
+ "Called when the set of focused frames changes or when we delete a frame."
+ (unless (blink-cursor-check)
+ (blink-cursor-suspend)))
(define-minor-mode blink-cursor-mode
"Toggle cursor blinking (Blink Cursor mode).
-With a prefix argument ARG, enable Blink Cursor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
If the value of `blink-cursor-blinks' is positive (10 by default),
the cursor stops blinking after that number of blinks, if Emacs
@@ -2382,24 +2564,23 @@ terminals, cursor blinking is controlled by the terminal."
:init-value (not (or noninteractive
no-blinking-cursor
(eq system-type 'ms-dos)
- (not (memq window-system '(x w32 ns)))))
+ (not (display-blink-cursor-p))))
:initialize 'custom-initialize-delay
:group 'cursor
:global t
(blink-cursor-suspend)
- (remove-hook 'focus-in-hook #'blink-cursor-check)
- (remove-hook 'focus-out-hook #'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-hook 'focus-in-hook #'blink-cursor-check)
- (add-hook 'focus-out-hook #'blink-cursor-suspend)
+ (add-function :after after-focus-change-function #'blink-cursor--rescan-frames)
+ (add-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames)
(blink-cursor--start-idle-timer)))
-
;; Frame maximization/fullscreen
-(defun toggle-frame-maximized ()
- "Toggle maximization state of selected frame.
+(defun toggle-frame-maximized (&optional frame)
+ "Toggle maximization state of FRAME.
Maximize selected frame or un-maximize if it is already maximized.
If the frame is in fullscreen state, don't change its state, but
@@ -2414,19 +2595,19 @@ transitions from one fullscreen state to another.
See also `toggle-frame-fullscreen'."
(interactive)
- (let ((fullscreen (frame-parameter nil 'fullscreen)))
+ (let ((fullscreen (frame-parameter frame 'fullscreen)))
(cond
((memq fullscreen '(fullscreen fullboth))
- (set-frame-parameter nil 'fullscreen-restore 'maximized))
+ (set-frame-parameter frame 'fullscreen-restore 'maximized))
((eq fullscreen 'maximized)
- (set-frame-parameter nil 'fullscreen nil))
+ (set-frame-parameter frame 'fullscreen nil))
(t
- (set-frame-parameter nil 'fullscreen 'maximized)))))
+ (set-frame-parameter frame 'fullscreen 'maximized)))))
-(defun toggle-frame-fullscreen ()
- "Toggle fullscreen state of selected frame.
-Make selected frame fullscreen or restore its previous size if it
-is already fullscreen.
+(defun toggle-frame-fullscreen (&optional frame)
+ "Toggle fullscreen state of FRAME.
+Make selected frame fullscreen or restore its previous size
+if it is already fullscreen.
Before making the frame fullscreen remember the current value of
the frame's `fullscreen' parameter in the `fullscreen-restore'
@@ -2441,18 +2622,19 @@ transitions from one fullscreen state to another.
See also `toggle-frame-maximized'."
(interactive)
- (let ((fullscreen (frame-parameter nil 'fullscreen)))
+ (let ((fullscreen (frame-parameter frame 'fullscreen)))
(if (memq fullscreen '(fullscreen fullboth))
- (let ((fullscreen-restore (frame-parameter nil 'fullscreen-restore)))
+ (let ((fullscreen-restore (frame-parameter frame 'fullscreen-restore)))
(if (memq fullscreen-restore '(maximized fullheight fullwidth))
- (set-frame-parameter nil 'fullscreen fullscreen-restore)
- (set-frame-parameter nil 'fullscreen nil)))
+ (set-frame-parameter frame 'fullscreen fullscreen-restore)
+ (set-frame-parameter frame 'fullscreen nil)))
(modify-frame-parameters
- nil `((fullscreen . fullboth) (fullscreen-restore . ,fullscreen))))
+ frame `((fullscreen . fullboth) (fullscreen-restore . ,fullscreen))))
;; Manipulating a frame without waiting for the fullscreen
;; animation to complete can cause a crash, or other unexpected
;; behavior, on macOS (bug#28496).
(when (featurep 'cocoa) (sleep-for 0.5))))
+
;;;; Key bindings
diff --git a/lisp/frameset.el b/lisp/frameset.el
index 5fdcc0d2c8a..3bc73751c0e 100644
--- a/lisp/frameset.el
+++ b/lisp/frameset.el
@@ -675,7 +675,7 @@ nil while the filtering is done to restore it."
;; of a frameset, so we must copy parameters to avoid inadvertent
;; modifications.
(pcase (cdr (assq (car current) filter-alist))
- (`nil
+ ('nil
(push (if saving current (copy-tree current)) filtered))
(:never
nil)
@@ -800,22 +800,17 @@ Internal use only."
(cons nil
(and mb-frame
(frameset-frame-id mb-frame)))))))))
- ;; Now store text-pixel width and height if it differs from the calculated
- ;; width and height and the frame is not fullscreen.
+ ;; Now store text-pixel width and height if `frame-resize-pixelwise'
+ ;; is set. (Bug#30141)
(dolist (frame frame-list)
- (unless (frame-parameter frame 'fullscreen)
- (unless (eq (* (frame-parameter frame 'width)
- (frame-char-width frame))
- (frame-text-width frame))
- (set-frame-parameter
- frame 'frameset--text-pixel-width
- (frame-text-width frame)))
- (unless (eq (* (frame-parameter frame 'height)
- (frame-char-height frame))
- (frame-text-height frame))
- (set-frame-parameter
- frame 'frameset--text-pixel-height
- (frame-text-height frame))))))
+ (when (and frame-resize-pixelwise
+ (not (frame-parameter frame 'fullscreen)))
+ (set-frame-parameter
+ frame 'frameset--text-pixel-width
+ (frame-text-width frame))
+ (set-frame-parameter
+ frame 'frameset--text-pixel-height
+ (frame-text-height frame)))))
;;;###autoload
(cl-defun frameset-save (frame-list
@@ -908,7 +903,7 @@ NOTE: This only works for non-iconified frames."
(< fr-right left) (> fr-right right)
(< fr-top top) (> fr-top bottom)))
;; Displaced to the left, right, above or below the screen.
- (`t (or (> fr-left right)
+ ('t (or (> fr-left right)
(< fr-right left)
(> fr-top bottom)
(< fr-bottom top)))
@@ -1200,11 +1195,11 @@ All keyword parameters default to nil."
;; will decide which ones can be reused, and how to deal with any leftover.
(frameset--reuse-list
(pcase reuse-frames
- (`t
+ ('t
frames)
- (`nil
+ ('nil
nil)
- (`match
+ ('match
(cl-loop for (state) in (frameset-states frameset)
when (frameset-frame-with-id (frameset-cfg-id state) frames)
collect it))
@@ -1369,11 +1364,11 @@ Called from `jump-to-register'. Internal use only."
;; iconify frames
(lambda (frame action)
(pcase action
- (`rejected (iconify-frame frame))
+ ('rejected (iconify-frame frame))
;; In the unexpected case that a frame was a candidate
;; (matching frame id) and yet not restored, remove it
;; because it is in fact a duplicate.
- (`ignored (delete-frame frame))))))
+ ('ignored (delete-frame frame))))))
;; Restore selected frame, buffer and point.
(let ((frame (frameset-frame-with-id (aref data 1)))
diff --git a/lisp/fringe.el b/lisp/fringe.el
index 31d80a8a77d..92387a21571 100644
--- a/lisp/fringe.el
+++ b/lisp/fringe.el
@@ -1,4 +1,4 @@
-;;; fringe.el --- fringe setup and control
+;;; fringe.el --- fringe setup and control -*- lexical-binding:t -*-
;; Copyright (C) 2002-2019 Free Software Foundation, Inc.
@@ -291,6 +291,24 @@ SIDE must be the symbol `left' or `right'."
0)
(float (frame-char-width))))
+;;;###autoload
+(unless (fboundp 'define-fringe-bitmap)
+ (defun define-fringe-bitmap (_bitmap _bits &optional _height _width _align)
+ "Define fringe bitmap BITMAP from BITS of size HEIGHT x WIDTH.
+BITMAP is a symbol identifying the new fringe bitmap.
+BITS is either a string or a vector of integers.
+HEIGHT is height of bitmap. If HEIGHT is nil, use length of BITS.
+WIDTH must be an integer between 1 and 16, or nil which defaults to 8.
+Optional fifth arg ALIGN may be one of ‘top’, ‘center’, or ‘bottom’,
+indicating the positioning of the bitmap relative to the rows where it
+is used; the default is to center the bitmap. Fifth arg may also be a
+list (ALIGN PERIODIC) where PERIODIC non-nil specifies that the bitmap
+should be repeated.
+If BITMAP already exists, the existing definition is replaced."
+ ;; This is a fallback for non-GUI builds.
+ ;; The real implementation is in src/fringe.c.
+ ))
+
(provide 'fringe)
;;; fringe.el ends here
diff --git a/lisp/generic-x.el b/lisp/generic-x.el
index 52d0a19cb06..c430be78ab7 100644
--- a/lisp/generic-x.el
+++ b/lisp/generic-x.el
@@ -241,30 +241,11 @@ This hook will be installed if the variable
spice-generic-mode)
"List of generic modes that are not defined by default.")
-(defcustom generic-define-mswindows-modes
- (memq system-type '(windows-nt ms-dos))
- "Non-nil means the modes in `generic-mswindows-modes' will be defined.
-This is a list of MS-Windows specific generic modes. This variable
-only affects the default value of `generic-extras-enable-list'."
- :group 'generic-x
- :type 'boolean
- :version "22.1")
-(make-obsolete-variable 'generic-define-mswindows-modes 'generic-extras-enable-list "22.1")
-
-(defcustom generic-define-unix-modes
- (not (memq system-type '(windows-nt ms-dos)))
- "Non-nil means the modes in `generic-unix-modes' will be defined.
-This is a list of Unix specific generic modes. This variable only
-affects the default value of `generic-extras-enable-list'."
- :group 'generic-x
- :type 'boolean
- :version "22.1")
-(make-obsolete-variable 'generic-define-unix-modes 'generic-extras-enable-list "22.1")
-
(defcustom generic-extras-enable-list
(append generic-default-modes
- (if generic-define-mswindows-modes generic-mswindows-modes)
- (if generic-define-unix-modes generic-unix-modes)
+ (if (memq system-type '(windows-nt ms-dos))
+ generic-mswindows-modes
+ generic-unix-modes)
nil)
"List of generic modes to define.
Each entry in the list should be a symbol. If you set this variable
@@ -313,7 +294,7 @@ your changes into effect."
nil
nil
;; Hostname ? user date request return-code number-of-bytes
- '(("^\\([-a-zA-z0-9.]+\\) - [-A-Za-z]+ \\(\\[.*\\]\\)"
+ '(("^\\([-a-zA-Z0-9.]+\\) - [-A-Za-z]+ \\(\\[.*\\]\\)"
(1 font-lock-constant-face)
(2 font-lock-variable-name-face)))
'("access_log\\'")
@@ -1509,7 +1490,8 @@ like an INI file. You can add this hook to `find-file-hook'."
'("^\\([^:]+\\):\\([^:]*\\):\\([0-9]+\\):\\(.*\\)$"
(1 font-lock-type-face)
(4 font-lock-variable-name-face))))
- '("/etc/passwd\\'" "/etc/group\\'")
+ ;; /etc/passwd- is a backup file for /etc/passwd, so is group- and shadow-
+ '("/etc/passwd-?\\'" "/etc/group-?\\'" "/etc/shadow-?\\'")
(list
(function
(lambda ()
@@ -1610,7 +1592,6 @@ like an INI file. You can add this hook to `find-file-hook'."
(t (:weight bold)))
"Font Lock mode face used to highlight TABs."
:group 'generic-x)
-(define-obsolete-face-alias 'show-tabs-tab-face 'show-tabs-tab "22.1")
(defface show-tabs-space
'((((class grayscale) (background light)) (:background "DimGray" :weight bold))
@@ -1620,7 +1601,6 @@ like an INI file. You can add this hook to `find-file-hook'."
(t (:weight bold)))
"Font Lock mode face used to highlight spaces."
:group 'generic-x)
-(define-obsolete-face-alias 'show-tabs-space-face 'show-tabs-space "22.1")
(define-generic-mode show-tabs-generic-mode
nil ;; no comment char
diff --git a/lisp/gnus/canlock.el b/lisp/gnus/canlock.el
index 1961a1100be..7edc91a2a46 100644
--- a/lisp/gnus/canlock.el
+++ b/lisp/gnus/canlock.el
@@ -41,9 +41,6 @@
;;; Code:
-(eval-when-compile
- (require 'cl))
-
(require 'sha1)
(defvar mail-header-separator)
diff --git a/lisp/gnus/deuglify.el b/lisp/gnus/deuglify.el
index 35b53af724d..2fdc34e3e18 100644
--- a/lisp/gnus/deuglify.el
+++ b/lisp/gnus/deuglify.el
@@ -299,8 +299,12 @@ It is run after `gnus-article-prepare-hook'."
;; it. Calling `gnus-article-prepare-display' on an already
;; prepared article removes all MIME parts. I'm unsure whether
;; this is a bug or not.
- (gnus-article-highlight t)
- (gnus-treat-article nil)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (article-goto-body)
+ (narrow-to-region (point) (point-max))
+ (gnus-treat-article nil)))
(gnus-run-hooks 'gnus-article-prepare-hook
'gnus-outlook-display-hook)))
diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el
index 068d8d7c835..9f7d2c9df7d 100644
--- a/lisp/gnus/gnus-agent.el
+++ b/lisp/gnus/gnus-agent.el
@@ -31,8 +31,7 @@
(require 'gnus-srvr)
(require 'gnus-util)
(require 'timer)
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(autoload 'gnus-server-update-server "gnus-srvr")
(autoload 'gnus-agent-customize-category "gnus-cus")
@@ -226,7 +225,9 @@ NOTES:
(defvar gnus-agent-overview-buffer nil)
(defvar gnus-category-predicate-cache nil)
(defvar gnus-category-group-cache nil)
-(defvar gnus-agent-spam-hashtb nil)
+(defvar gnus-agent-spam-hashtb nil
+ "Cache of message subjects for spam messages.
+Actually a hash table holding subjects mapped to t.")
(defvar gnus-agent-file-name nil)
(defvar gnus-agent-file-coding-system 'raw-text)
(defvar gnus-agent-file-loading-cache nil)
@@ -275,7 +276,7 @@ NOTES:
(defmacro gnus-agent-with-refreshed-group (group &rest body)
"Performs the body then updates the group's line in the group
buffer. Automatically blocks multiple updates due to recursion."
-`(prog1 (let ((gnus-agent-inhibit-update-total-fetched-for t)) ,@body)
+ `(prog1 (let ((gnus-agent-inhibit-update-total-fetched-for t)) ,@body)
(when (and gnus-agent-need-update-total-fetched-for
(not gnus-agent-inhibit-update-total-fetched-for))
(with-current-buffer gnus-group-buffer
@@ -310,9 +311,10 @@ buffer. Automatically blocks multiple updates due to recursion."
(defun gnus-agent-cat-set-property (category property value)
(if value
(setcdr (or (assq property category)
- (let ((cell (cons property nil)))
+ (let ((cell (cons property nil)))
(setcdr category (cons cell (cdr category)))
- cell)) value)
+ cell))
+ value)
(let ((category category))
(while (cond ((eq property (caadr category))
(setcdr category (cddr category))
@@ -332,9 +334,9 @@ manipulated as follows:
`(progn (defmacro ,name (category)
(list 'cdr (list 'assq '',prop-name category)))
- (defsetf ,name (category) (value)
- (list 'gnus-agent-cat-set-property
- category '',prop-name value))))
+ (gv-define-setter ,name (value category)
+ (list 'gnus-agent-cat-set-property
+ category '',prop-name value))))
)
(defmacro gnus-agent-cat-name (category)
@@ -361,11 +363,7 @@ manipulated as follows:
(gnus-agent-cat-defaccessor
gnus-agent-cat-enable-undownloaded-faces agent-enable-undownloaded-faces)
-
-;; This form may expand to code that uses CL functions at run-time,
-;; but that's OK since those functions will only ever be called from
-;; something like `setf', so only when CL is loaded anyway.
-(defsetf gnus-agent-cat-groups gnus-agent-set-cat-groups)
+(gv-define-simple-setter gnus-agent-cat-groups gnus-agent-set-cat-groups)
(defun gnus-agent-set-cat-groups (category groups)
(unless (eq groups 'ignore)
@@ -381,7 +379,8 @@ manipulated as follows:
(setcdr (or (assq 'agent-groups category)
(let ((cell (cons 'agent-groups nil)))
(setcdr category (cons cell (cdr category)))
- cell)) new-g))
+ cell))
+ new-g))
(t
(let ((groups groups))
(while groups
@@ -398,7 +397,8 @@ manipulated as follows:
(setcdr (or (assq 'agent-groups category)
(let ((cell (cons 'agent-groups nil)))
(setcdr category (cons cell (cdr category)))
- cell)) groups))))))
+ cell))
+ groups))))))
(defsubst gnus-agent-cat-make (name &optional default-agent-predicate)
(list name `(agent-predicate . ,(or default-agent-predicate 'false))))
@@ -647,8 +647,8 @@ minor mode in all Gnus buffers."
(defun gnus-agent-queue-setup (&optional group-name)
"Make sure the queue group exists.
Optional arg GROUP-NAME allows another group to be specified."
- (unless (gnus-gethash (format "nndraft:%s" (or group-name "queue"))
- gnus-newsrc-hashtb)
+ (unless (gethash (format "nndraft:%s" (or group-name "queue"))
+ gnus-newsrc-hashtb)
(gnus-request-create-group (or group-name "queue") '(nndraft ""))
(let ((gnus-level-default-subscribed 1))
(gnus-subscribe-group (format "nndraft:%s" (or group-name "queue"))
@@ -1108,7 +1108,7 @@ downloadable."
gnus-newsgroup-cached)
(setq articles (gnus-sorted-ndifference
(gnus-sorted-ndifference
- (gnus-copy-sequence articles)
+ (copy-tree articles)
gnus-newsgroup-downloadable)
gnus-newsgroup-cached)))
@@ -1123,7 +1123,7 @@ downloadable."
(when gnus-newsgroup-processable
(setq gnus-newsgroup-downloadable
(let* ((dl gnus-newsgroup-downloadable)
- (processable (sort (gnus-copy-sequence gnus-newsgroup-processable) '<))
+ (processable (sort (copy-tree gnus-newsgroup-processable) '<))
(gnus-newsgroup-downloadable processable))
(gnus-agent-summary-fetch-group)
@@ -1335,11 +1335,11 @@ downloaded into the agent."
(when (re-search-forward
(concat "^" (regexp-quote group) " ") nil t)
(save-excursion
- (setq oactive-max (read (current-buffer)) ;; max
+ (setq oactive-max (read (current-buffer)) ;; max
oactive-min (read (current-buffer)))) ;; min
(gnus-delete-line)))
(when active
- (insert (format "%S %d %d y\n" (intern group)
+ (insert (format "%s %d %d y\n" group
(max (or oactive-max (cdr active)) (cdr active))
(min (or oactive-min (car active)) (car active))))
(goto-char (point-max))
@@ -1513,7 +1513,7 @@ downloaded into the agent."
(let* ((fetched-articles (list nil))
(tail-fetched-articles fetched-articles)
(dir (gnus-agent-group-pathname group))
- (date (time-to-days (current-time)))
+ (date (time-to-days nil))
(case-fold-search t)
pos crosses
(file-name-coding-system nnmail-pathname-coding-system))
@@ -1560,11 +1560,8 @@ downloaded into the agent."
(skip-chars-forward " ")
(setq crosses nil)
(while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) *")
- (push (cons (buffer-substring (match-beginning 1)
- (match-end 1))
- (string-to-number
- (buffer-substring (match-beginning 2)
- (match-end 2))))
+ (push (cons (match-string 1)
+ (string-to-number (match-string 2)))
crosses)
(goto-char (match-end 0)))
(gnus-agent-crosspost crosses (caar pos) date)))
@@ -1608,7 +1605,8 @@ downloaded into the agent."
(number-to-string have-this)))
(size-file
(float (or (and gnus-agent-total-fetched-hashtb
- (nth 7 (file-attributes file-name)))
+ (file-attribute-size
+ (file-attributes file-name)))
0)))
(file-name-coding-system
nnmail-pathname-coding-system))
@@ -2101,12 +2099,16 @@ doesn't exist, to valid the overview buffer."
(let* (alist
(file-name-coding-system nnmail-pathname-coding-system)
(file-attributes (directory-files-and-attributes
- (gnus-agent-article-name ""
- gnus-agent-read-agentview) nil "^[0-9]+$" t)))
+ (gnus-agent-article-name
+ "" gnus-agent-read-agentview)
+ nil "^[0-9]+$" t)))
(while file-attributes
(let ((fa (pop file-attributes)))
- (unless (nth 1 fa)
- (push (cons (string-to-number (nth 0 fa)) (time-to-days (nth 5 fa))) alist))))
+ (unless (file-attribute-type (cdr fa))
+ (push (cons (string-to-number (car fa))
+ (time-to-days
+ (file-attribute-access-time (cdr fa))))
+ alist))))
alist)
(file-error nil))))))
@@ -2161,7 +2163,10 @@ doesn't exist, to valid the overview buffer."
(gnus-agent-update-view-total-fetched-for group nil)))
-(defvar gnus-agent-article-local nil)
+;; FIXME: Why would this be a hash table? Wouldn't a simple alist or
+;; something suffice?
+(defvar gnus-agent-article-local nil
+ "Hashtable holding information about a group.")
(defvar gnus-agent-article-local-times nil)
(defvar gnus-agent-file-loading-local nil)
@@ -2173,14 +2178,14 @@ article counts for each of the method's subscribed groups."
(zerop gnus-agent-article-local-times)
(not (gnus-methods-equal-p
gnus-command-method
- (symbol-value (intern "+method" gnus-agent-article-local)))))
+ (gethash "+method" gnus-agent-article-local))))
(setq gnus-agent-article-local
(gnus-cache-file-contents
(gnus-agent-lib-file "local")
'gnus-agent-file-loading-local
- 'gnus-agent-read-and-cache-local))
+ #'gnus-agent-read-and-cache-local))
(when gnus-agent-article-local-times
- (incf gnus-agent-article-local-times)))
+ (cl-incf gnus-agent-article-local-times)))
gnus-agent-article-local))
(defun gnus-agent-read-and-cache-local (file)
@@ -2188,14 +2193,15 @@ article counts for each of the method's subscribed groups."
gnus-agent-article-local. If that variable had `dirty' (also known as
modified) original contents, they are first saved to their own file."
(if (and gnus-agent-article-local
- (symbol-value (intern "+dirty" gnus-agent-article-local)))
+ (gethash "+dirty" gnus-agent-article-local))
(gnus-agent-save-local))
(gnus-agent-read-local file))
(defun gnus-agent-read-local (file)
"Load FILE and do a `read' there."
- (let ((my-obarray (gnus-make-hashtable (count-lines (point-min)
- (point-max))))
+ (let ((hashtb (gnus-make-hashtable
+ (count-lines (point-min)
+ (point-max))))
(line 1))
(with-temp-buffer
(condition-case nil
@@ -2204,7 +2210,8 @@ modified) original contents, they are first saved to their own file."
(file-error))
(goto-char (point-min))
- ;; Skip any comments at the beginning of the file (the only place where they may appear)
+ ;; Skip any comments at the beginning of the file (the only
+ ;; place where they may appear)
(while (= (following-char) ?\;)
(forward-line 1)
(setq line (1+ line)))
@@ -2214,33 +2221,32 @@ modified) original contents, they are first saved to their own file."
(let (group
min
max
- (cur (current-buffer))
- (obarray my-obarray))
+ (cur (current-buffer)))
(setq group (read cur)
min (read cur)
max (read cur))
- (when (stringp group)
- (setq group (intern group my-obarray)))
+ (unless (stringp group)
+ (setq group (symbol-name group)))
;; NOTE: The '+ 0' ensure that min and max are both numerics.
- (set group (cons (+ 0 min) (+ 0 max))))
+ (puthash group (cons (+ 0 min) (+ 0 max)) hashtb))
(error
(gnus-message 3 "Warning - invalid agent local: %s on line %d: %s"
file line (error-message-string err))))
(forward-line 1)
(setq line (1+ line))))
- (set (intern "+dirty" my-obarray) nil)
- (set (intern "+method" my-obarray) gnus-command-method)
- my-obarray))
+ (puthash "+dirty" nil hashtb)
+ (puthash "+method" gnus-command-method hashtb)
+ hashtb))
(defun gnus-agent-save-local (&optional force)
"Save gnus-agent-article-local under it method's agent.lib directory."
- (let ((my-obarray gnus-agent-article-local))
- (when (and my-obarray
- (or force (symbol-value (intern "+dirty" my-obarray))))
- (let* ((gnus-command-method (symbol-value (intern "+method" my-obarray)))
+ (let ((hashtb gnus-agent-article-local))
+ (when (and hashtb
+ (or force (gethash "+dirty" hashtb)))
+ (let* ((gnus-command-method (gethash "+method" hashtb))
;; NOTE: gnus-command-method is used within gnus-agent-lib-file.
(dest (gnus-agent-lib-file "local")))
(gnus-make-directory (gnus-agent-lib-file ""))
@@ -2248,31 +2254,30 @@ modified) original contents, they are first saved to their own file."
(let ((coding-system-for-write gnus-agent-file-coding-system)
(file-name-coding-system nnmail-pathname-coding-system))
(with-temp-file dest
- (let ((gnus-command-method (symbol-value (intern "+method" my-obarray)))
+ ;; FIXME: Why are we letting this again?
+ (let ((gnus-command-method (gethash "+method" hashtb))
print-level print-length
(standard-output (current-buffer)))
- (mapatoms (lambda (symbol)
- (cond ((not (boundp symbol))
- nil)
- ((member (symbol-name symbol) '("+dirty" "+method"))
- nil)
- (t
- (let ((range (symbol-value symbol)))
- (when range
- (prin1 symbol)
- (princ " ")
- (princ (car range))
- (princ " ")
- (princ (cdr range))
- (princ "\n"))))))
- my-obarray))))))))
+ (maphash (lambda (group active)
+ (cond ((null active)
+ nil)
+ ((member group '("+dirty" "+method"))
+ nil)
+ (t
+ (when active
+ (prin1 group)
+ (princ " ")
+ (princ (car active))
+ (princ " ")
+ (princ (cdr active))
+ (princ "\n")))))
+ hashtb))))))))
(defun gnus-agent-get-local (group &optional gmane method)
(let* ((gmane (or gmane (gnus-group-real-name group)))
(gnus-command-method (or method (gnus-find-method-for-group group)))
(local (gnus-agent-load-local))
- (symb (intern gmane local))
- (minmax (and (boundp symb) (symbol-value symb))))
+ (minmax (gethash gmane local)))
(unless minmax
;; Bind these so that gnus-agent-load-alist doesn't change the
;; current alist (i.e. gnus-agent-article-alist)
@@ -2291,24 +2296,23 @@ modified) original contents, they are first saved to their own file."
(let* ((gmane (or gmane (gnus-group-real-name group)))
(gnus-command-method (or method (gnus-find-method-for-group group)))
(local (or local (gnus-agent-load-local)))
- (symb (intern gmane local))
- (minmax (and (boundp symb) (symbol-value symb))))
+ (minmax (gethash gmane local)))
(if (cond ((and minmax
(or (not (eq min (car minmax)))
(not (eq max (cdr minmax))))
min
max)
- (setcar minmax min)
- (setcdr minmax max)
+ (setcar (gethash gmane local) min)
+ (setcdr (gethash gmane local) max)
t)
(minmax
nil)
((and min max)
- (set symb (cons min max))
+ (puthash gmane (cons min max) local)
t)
(t
- (unintern symb local)))
- (set (intern "+dirty" local) t))))
+ (remhash gmane local)))
+ (puthash "+dirty" t local))))
(defun gnus-agent-article-name (article group)
(expand-file-name article
@@ -2575,9 +2579,6 @@ modified) original contents, they are first saved to their own file."
;;; Agent Category Mode
;;;
-(defvar gnus-category-mode-hook nil
- "Hook run in `gnus-category-mode' buffers.")
-
(defvar gnus-category-line-format " %(%20c%): %g\n"
"Format of category lines.
@@ -2603,17 +2604,16 @@ General format specifiers can also be used. See Info node
(defvar gnus-tmp-groups)
(defvar gnus-category-line-format-alist
- `((?c gnus-tmp-name ?s)
+ '((?c gnus-tmp-name ?s)
(?g gnus-tmp-groups ?d)))
(defvar gnus-category-mode-line-format-alist
- `((?u user-defined ?s)))
+ '((?u user-defined ?s)))
(defvar gnus-category-line-format-spec nil)
(defvar gnus-category-mode-line-format-spec nil)
(defvar gnus-category-mode-map nil)
-(put 'gnus-category-mode 'mode-class 'special)
(unless gnus-category-mode-map
(setq gnus-category-mode-map (make-sparse-keymap))
@@ -2655,9 +2655,8 @@ General format specifiers can also be used. See Info node
(gnus-run-hooks 'gnus-category-menu-hook)))
-(define-derived-mode gnus-category-mode fundamental-mode "Category"
+(define-derived-mode gnus-category-mode gnus-mode "Category"
"Major mode for listing and editing agent categories.
-
All normal editing commands are switched off.
\\<gnus-category-mode-map>
For more in-depth information on this mode, read the manual
@@ -2672,8 +2671,7 @@ The following commands are available:
(gnus-set-default-directory)
(setq mode-line-process nil)
(buffer-disable-undo)
- (setq truncate-lines t)
- (setq buffer-read-only t))
+ (setq truncate-lines t))
(defalias 'gnus-category-position-point 'gnus-goto-colon)
@@ -2833,7 +2831,7 @@ The following commands are available:
"Copy the current category."
(interactive (list (gnus-category-name) (intern (read-string "New name: "))))
(let ((info (assq category gnus-category-alist)))
- (push (let ((newcat (gnus-copy-sequence info)))
+ (push (let ((newcat (copy-tree info)))
(setf (gnus-agent-cat-name newcat) to)
(setf (gnus-agent-cat-groups newcat) nil)
newcat)
@@ -2884,8 +2882,8 @@ The following commands are available:
nil
(let ((string (gnus-simplify-subject (mail-header-subject gnus-headers))))
(prog1
- (gnus-gethash string gnus-agent-spam-hashtb)
- (gnus-sethash string t gnus-agent-spam-hashtb)))))
+ (gethash string gnus-agent-spam-hashtb)
+ (puthash string t gnus-agent-spam-hashtb)))))
(defun gnus-agent-short-p ()
"Say whether an article is short or not."
@@ -2941,7 +2939,7 @@ The following commands are available:
'or)
((memq (car predicate) gnus-category-not)
'not))
- ,@(mapcar 'gnus-category-make-function-1 (cdr predicate))))
+ ,@(mapcar #'gnus-category-make-function-1 (cdr predicate))))
(t
(error "Unknown predicate type: %s" predicate))))
@@ -2967,7 +2965,7 @@ return read articles, nil when it is known to always return read
articles, and t_nil when the function may return both read and unread
articles."
(let ((func (car function))
- (args (mapcar 'gnus-function-implies-unread-1 (cdr function))))
+ (args (mapcar #'gnus-function-implies-unread-1 (cdr function))))
(cond ((eq func 'and)
(cond ((memq t args) ; if any argument returns only unread articles
;; then that argument constrains the result to only unread articles.
@@ -3013,13 +3011,13 @@ articles."
(unless gnus-category-group-cache
(setq gnus-category-group-cache (gnus-make-hashtable 1000))
(let ((cs gnus-category-alist)
- groups cat)
- (while (setq cat (pop cs))
+ groups)
+ (dolist (cat cs)
(setq groups (gnus-agent-cat-groups cat))
- (while groups
- (gnus-sethash (pop groups) cat gnus-category-group-cache)))))
- (or (gnus-gethash group gnus-category-group-cache)
- (assq 'default gnus-category-alist)))
+ (dolist (g groups)
+ (puthash g cat gnus-category-group-cache)))))
+ (gethash group gnus-category-group-cache
+ (assq 'default gnus-category-alist)))
(defvar gnus-agent-expire-current-dirs)
(defvar gnus-agent-expire-stats)
@@ -3059,7 +3057,7 @@ FORCE is equivalent to setting the expiration predicates to true."
(count-lines (point-min) (point-max))))))
(save-excursion
(gnus-agent-expire-group-1
- group overview (gnus-gethash-safe group orig)
+ group overview (gethash group orig)
articles force))))
(kill-buffer overview))))
(gnus-message 4 "%s" (gnus-agent-expire-done-message)))))
@@ -3089,7 +3087,7 @@ FORCE is equivalent to setting the expiration predicates to true."
(nov-entries-deleted 0)
(info (gnus-get-info group))
(alist gnus-agent-article-alist)
- (day (- (time-to-days (current-time))
+ (day (- (time-to-days nil)
(gnus-agent-find-parameter group 'agent-days-until-old)))
(specials (if (and alist
(not force))
@@ -3153,38 +3151,37 @@ FORCE is equivalent to setting the expiration predicates to true."
(nov-file (concat dir ".overview"))
(cnt 0)
(completed -1)
- dlist
- type)
-
- ;; The normal article alist contains elements that look like
- ;; (article# . fetch_date) I need to combine other
- ;; information with this list. For example, a flag indicating
- ;; that a particular article MUST BE KEPT. To do this, I'm
- ;; going to transform the elements to look like (article#
- ;; fetch_date keep_flag NOV_entry_position) Later, I'll reverse
- ;; the process to generate the expired article alist.
-
- ;; Convert the alist elements to (article# fetch_date nil
- ;; nil).
- (setq dlist (mapcar (lambda (e)
- (list (car e) (cdr e) nil nil)) alist))
-
- ;; Convert the keep lists to elements that look like (article#
- ;; nil keep_flag nil) then append it to the expanded dlist
- ;; These statements are sorted by ascending precedence of the
- ;; keep_flag.
- (setq dlist (nconc dlist
- (mapcar (lambda (e)
- (list e nil 'unread nil))
- unreads)))
- (setq dlist (nconc dlist
- (mapcar (lambda (e)
- (list e nil 'marked nil))
- marked)))
- (setq dlist (nconc dlist
- (mapcar (lambda (e)
- (list e nil 'special nil))
- specials)))
+ type
+
+ ;; The normal article alist contains elements that look like
+ ;; (article# . fetch_date) I need to combine other
+ ;; information with this list. For example, a flag indicating
+ ;; that a particular article MUST BE KEPT. To do this, I'm
+ ;; going to transform the elements to look like (article#
+ ;; fetch_date keep_flag NOV_entry_position) Later, I'll reverse
+ ;; the process to generate the expired article alist.
+ (dlist
+ (nconc
+ ;; Convert the alist elements to (article# fetch_date nil nil).
+ (mapcar (lambda (e)
+ (list (car e) (cdr e) nil nil))
+ alist)
+
+ ;; Convert the keep lists to elements that look like (article#
+ ;; nil keep_flag nil) then append it to the expanded dlist
+ ;; These statements are sorted by ascending precedence of the
+ ;; keep_flag.
+ (mapcar (lambda (e)
+ (list e nil 'unread nil))
+ unreads)
+
+ (mapcar (lambda (e)
+ (list e nil 'marked nil))
+ marked)
+
+ (mapcar (lambda (e)
+ (list e nil 'special nil))
+ specials))))
(set-buffer overview)
(erase-buffer)
@@ -3352,10 +3349,11 @@ missing NOV entry. Run gnus-agent-regenerate-group to restore it.")))
(ignore-errors ; Just being paranoid.
(let* ((file-name (nnheader-concat dir (number-to-string
article-number)))
- (size (float (nth 7 (file-attributes file-name)))))
- (incf bytes-freed size)
- (incf size-files-deleted size)
- (incf files-deleted)
+ (size (float (file-attribute-size
+ (file-attributes file-name)))))
+ (cl-incf bytes-freed size)
+ (cl-incf size-files-deleted size)
+ (cl-incf files-deleted)
(delete-file file-name))
(push "expired cached article" actions))
(setf (nth 1 entry) nil)
@@ -3368,13 +3366,13 @@ missing NOV entry. Run gnus-agent-regenerate-group to restore it.")))
marker
(- marker position-offset)))
- (incf nov-entries-deleted)
+ (cl-incf nov-entries-deleted)
(let* ((from (point-at-bol))
(to (progn (forward-line 1) (point)))
(freed (- to from)))
- (incf bytes-freed freed)
- (incf position-offset freed)
+ (cl-incf bytes-freed freed)
+ (cl-incf position-offset freed)
(delete-region from to)))
;; If considering all articles is set, I can only
@@ -3392,7 +3390,7 @@ article alist" type) actions))
(when actions
(gnus-agent-message 8 "gnus-agent-expire: %s:%d: %s"
decoded article-number
- (mapconcat 'identity actions ", ")))))
+ (mapconcat #'identity actions ", ")))))
(t
(gnus-agent-message
10 "gnus-agent-expire: %s:%d: Article kept as \
@@ -3431,9 +3429,9 @@ expiration tests failed." decoded article-number)
(when (boundp 'gnus-agent-expire-stats)
(let ((stats gnus-agent-expire-stats))
- (incf (nth 2 stats) bytes-freed)
- (incf (nth 1 stats) files-deleted)
- (incf (nth 0 stats) nov-entries-deleted)))
+ (cl-incf (nth 2 stats) bytes-freed)
+ (cl-incf (nth 1 stats) files-deleted)
+ (cl-incf (nth 0 stats) nov-entries-deleted)))
(gnus-agent-update-files-total-fetched-for group (- size-files-deleted)))))))
@@ -3476,9 +3474,7 @@ articles in every agentized group? "))
(count-lines (point-min) (point-max))))))
(dolist (expiring-group (gnus-groups-from-server
gnus-command-method))
- (let* ((active
- (gnus-gethash-safe expiring-group orig)))
-
+ (let ((active (gethash expiring-group orig)))
(when active
(save-excursion
(gnus-agent-expire-group-1
@@ -3508,83 +3504,80 @@ articles in every agentized group? "))
(defun gnus-agent-expire-unagentized-dirs ()
(when (and gnus-agent-expire-unagentized-dirs
(boundp 'gnus-agent-expire-current-dirs))
- (let* ((keep (gnus-make-hashtable))
- (file-name-coding-system nnmail-pathname-coding-system))
-
- (gnus-sethash gnus-agent-directory t keep)
+ (let ((file-name-coding-system nnmail-pathname-coding-system)
+ ;; Another hash table that could just be a list.
+ (keep (gnus-make-hashtable 20))
+ to-remove)
+ (puthash gnus-agent-directory t keep)
(dolist (dir gnus-agent-expire-current-dirs)
(when (and (stringp dir)
(file-directory-p dir))
- (while (not (gnus-gethash dir keep))
- (gnus-sethash dir t keep)
+ (while (not (gethash dir keep))
+ (puthash dir t keep)
(setq dir (file-name-directory (directory-file-name dir))))))
- (let* (to-remove
- checker
- (checker
- (function
- (lambda (d)
- "Given a directory, check it and its subdirectories for
- membership in the keep hash. If it isn't found, add
- it to to-remove."
- (let ((files (directory-files d))
- file)
- (while (setq file (pop files))
- (cond ((equal file ".") ; Ignore self
- nil)
- ((equal file "..") ; Ignore parent
- nil)
- ((equal file ".overview")
- ;; Directory must contain .overview to be
- ;; agent's cache of a group.
- (let ((d (file-name-as-directory d))
- r)
- ;; Search ancestor's for last directory NOT
- ;; found in keep hash.
- (while (not (gnus-gethash
- (setq d (file-name-directory d)) keep))
- (setq r d
- d (directory-file-name d)))
- ;; if ANY ancestor was NOT in keep hash and
- ;; it's not already in to-remove, add it to
- ;; to-remove.
- (if (and r
- (not (member r to-remove)))
- (push r to-remove))))
- ((file-directory-p (setq file (nnheader-concat d file)))
- (funcall checker file)))))))))
- (funcall checker (expand-file-name gnus-agent-directory))
-
- (when (and to-remove
- (or gnus-expert-user
- (gnus-y-or-n-p
- "gnus-agent-expire has identified local directories that are\
+ (cl-labels ((checker
+ (d)
+ ;; Given a directory, check it and its subdirectories
+ ;; for membership in the keep list. If it isn't found,
+ ;; add it to to-remove.
+ (let ((files (directory-files d))
+ file)
+ (while (setq file (pop files))
+ (cond ((equal file ".") ; Ignore self
+ nil)
+ ((equal file "..") ; Ignore parent
+ nil)
+ ((equal file ".overview")
+ ;; Directory must contain .overview to be
+ ;; agent's cache of a group.
+ (let ((d (file-name-as-directory d))
+ r)
+ ;; Search ancestors for last directory NOT
+ ;; found in keep.
+ (while (not (gethash (setq d (file-name-directory d)) keep))
+ (setq r d
+ d (directory-file-name d)))
+ ;; if ANY ancestor was NOT in keep hash and
+ ;; it's not already in to-remove, add it to
+ ;; to-remove.
+ (if (and r
+ (not (member r to-remove)))
+ (push r to-remove))))
+ ((file-directory-p (setq file (nnheader-concat d file)))
+ (checker file)))))))
+ (checker (expand-file-name gnus-agent-directory)))
+
+ (when (and to-remove
+ (or gnus-expert-user
+ (gnus-y-or-n-p
+ "gnus-agent-expire has identified local directories that are\
not currently required by any agentized group. Do you wish to consider\
deleting them?")))
- (while to-remove
- (let ((dir (pop to-remove)))
- (if (or gnus-expert-user
- (gnus-y-or-n-p (format "Delete %s? " dir)))
- (let* (delete-recursive
- files f
- (delete-recursive
- (function
- (lambda (f-or-d)
- (ignore-errors
- (if (file-directory-p f-or-d)
- (condition-case nil
- (delete-directory f-or-d)
- (file-error
- (setq files (directory-files f-or-d))
- (while files
- (setq f (pop files))
- (or (member f '("." ".."))
- (funcall delete-recursive
- (nnheader-concat
- f-or-d f))))
- (delete-directory f-or-d)))
- (delete-file f-or-d)))))))
- (funcall delete-recursive dir))))))))))
+ (while to-remove
+ (let ((dir (pop to-remove)))
+ (if (or gnus-expert-user
+ (gnus-y-or-n-p (format "Delete %s? " dir)))
+ (let* (delete-recursive
+ files f
+ (delete-recursive
+ (function
+ (lambda (f-or-d)
+ (ignore-errors
+ (if (file-directory-p f-or-d)
+ (condition-case nil
+ (delete-directory f-or-d)
+ (file-error
+ (setq files (directory-files f-or-d))
+ (while files
+ (setq f (pop files))
+ (or (member f '("." ".."))
+ (funcall delete-recursive
+ (nnheader-concat
+ f-or-d f))))
+ (delete-directory f-or-d)))
+ (delete-file f-or-d)))))))
+ (funcall delete-recursive dir)))))))))
;;;###autoload
(defun gnus-agent-batch ()
@@ -3630,7 +3623,7 @@ If CACHED-HEADER is nil, articles are only excluded if the article itself
has been fetched."
;; Logically equivalent to: (gnus-sorted-difference articles (mapcar
- ;; 'car gnus-agent-article-alist))
+ ;; #'car gnus-agent-article-alist))
;; Functionally, I don't need to construct a temp list using mapcar.
@@ -3805,7 +3798,7 @@ has been fetched."
(buffer-read-only nil)
(file-name-coding-system nnmail-pathname-coding-system))
(when (and (file-exists-p file)
- (> (nth 7 (file-attributes file)) 0))
+ (> (file-attribute-size (file-attributes file)) 0))
(erase-buffer)
(gnus-kill-all-overlays)
(let ((coding-system-for-read gnus-cache-coding-system))
@@ -3824,7 +3817,7 @@ has been fetched."
;; be expired later.
(gnus-agent-load-alist group)
(gnus-agent-save-alist group (list article)
- (time-to-days (current-time))))))
+ (time-to-days nil)))))
(defun gnus-agent-regenerate-group (group &optional reread)
"Regenerate GROUP.
@@ -3950,9 +3943,11 @@ If REREAD is not nil, downloaded articles are marked as unread."
;; This entry in the overview has been downloaded
(push (cons (car downloaded)
(time-to-days
- (nth 5 (file-attributes
- (concat dir (number-to-string
- (car downloaded))))))) alist)
+ (file-attribute-modification-time
+ (file-attributes
+ (concat dir (number-to-string
+ (car downloaded)))))))
+ alist)
(setq downloaded (cdr downloaded))
(setq nov-arts (cdr nov-arts)))
(t
@@ -4100,8 +4095,8 @@ agent has fetched."
;; if null, gnus-agent-group-pathname will calc method.
(let* ((gnus-command-method method)
(path (or path (gnus-agent-group-pathname group)))
- (entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb)
- (gnus-sethash path (make-list 3 0)
+ (entry (or (gethash path gnus-agent-total-fetched-hashtb)
+ (puthash path (make-list 3 0)
gnus-agent-total-fetched-hashtb)))
(file-name-coding-system nnmail-pathname-coding-system))
(when (file-exists-p path)
@@ -4110,26 +4105,28 @@ agent has fetched."
(let ((sum 0.0)
file)
(while (setq file (pop delta))
- (incf sum (float (or (nth 7 (file-attributes
- (nnheader-concat
- path
- (if (numberp file)
- (number-to-string file)
- file)))) 0))))
+ (cl-incf sum (float (or (file-attribute-size
+ (file-attributes
+ (nnheader-concat
+ path
+ (if (numberp file)
+ (number-to-string file)
+ file))))
+ 0))))
(setq delta sum))
(let ((sum (- (nth 2 entry)))
(info (directory-files-and-attributes
path nil "^-?[0-9]+$" t))
file)
(while (setq file (pop info))
- (incf sum (float (or (nth 8 file) 0))))
+ (cl-incf sum (float (or (file-attribute-size (cdr file)) 0))))
(setq delta sum))))
(setq gnus-agent-need-update-total-fetched-for t)
- (incf (nth 2 entry) delta))))))
+ (cl-incf (nth 2 entry) delta))))))
(defun gnus-agent-update-view-total-fetched-for
- (group agent-over &optional method path)
+ (group agent-over &optional method path)
"Update, or set, the total disk space used by the .agentview and
.overview files. These files are calculated separately as they can be
modified."
@@ -4139,15 +4136,15 @@ modified."
;; if null, gnus-agent-group-pathname will calc method.
(let* ((gnus-command-method method)
(path (or path (gnus-agent-group-pathname group)))
- (entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb)
- (gnus-sethash path (make-list 3 0)
- gnus-agent-total-fetched-hashtb)))
+ (entry (or (gethash path gnus-agent-total-fetched-hashtb)
+ (puthash path (make-list 3 0)
+ gnus-agent-total-fetched-hashtb)))
(file-name-coding-system nnmail-pathname-coding-system)
- (size (or (nth 7 (file-attributes
- (nnheader-concat
- path (if agent-over
- ".overview"
- ".agentview"))))
+ (size (or (file-attribute-size (file-attributes
+ (nnheader-concat
+ path (if agent-over
+ ".overview"
+ ".agentview"))))
0)))
(setq gnus-agent-need-update-total-fetched-for t)
(setf (nth (if agent-over 1 0) entry) size)))))
@@ -4156,12 +4153,13 @@ modified."
"Get the total disk space used by the specified GROUP."
(unless (equal group "dummy.group")
(unless gnus-agent-total-fetched-hashtb
- (setq gnus-agent-total-fetched-hashtb (gnus-make-hashtable 1024)))
+ (setq gnus-agent-total-fetched-hashtb
+ (gnus-make-hashtable 1000)))
;; if null, gnus-agent-group-pathname will calc method.
(let* ((gnus-command-method method)
(path (gnus-agent-group-pathname group))
- (entry (gnus-gethash path gnus-agent-total-fetched-hashtb)))
+ (entry (gethash path gnus-agent-total-fetched-hashtb)))
(if entry
(apply '+ entry)
(let ((gnus-agent-inhibit-update-total-fetched-for (not no-inhibit)))
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index 4eb6249490e..baa8a244c07 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -24,8 +24,7 @@
;;; Code:
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defvar tool-bar-map)
(defvar w3m-minor-mode-map)
@@ -199,9 +198,9 @@ Possible values in this list are:
`newsgroups' Newsgroup identical to Gnus group.
`to-address' To identical to To-address.
`to-list' To identical to To-list.
- `cc-list' CC identical to To-list.
- `followup-to' Followup-to identical to Newsgroups.
- `reply-to' Reply-to identical to From.
+ `cc-list' Cc identical to To-list.
+ `followup-to' Followup-To identical to Newsgroups.
+ `reply-to' Reply-To identical to From.
`date' Date less than four days old.
`long-to' To and/or Cc longer than 1024 characters.
`many-to' Multiple To and/or Cc."
@@ -209,9 +208,9 @@ Possible values in this list are:
(const :tag "Newsgroups identical to Gnus group." newsgroups)
(const :tag "To identical to To-address." to-address)
(const :tag "To identical to To-list." to-list)
- (const :tag "CC identical to To-list." cc-list)
- (const :tag "Followup-to identical to Newsgroups." followup-to)
- (const :tag "Reply-to identical to From." reply-to)
+ (const :tag "Cc identical to To-list." cc-list)
+ (const :tag "Followup-To identical to Newsgroups." followup-to)
+ (const :tag "Reply-To identical to From." reply-to)
(const :tag "Date less than four days old." date)
(const :tag "To and/or Cc longer than 1024 characters." long-to)
(const :tag "Multiple To and/or Cc headers." many-to))
@@ -279,7 +278,7 @@ This can also be a list of the above values."
"String or function to be executed to display an X-Face header.
If it is a string, the command will be executed in a sub-shell
asynchronously. The compressed face will be piped to this command."
- :type `(choice string
+ :type '(choice string
(function-item gnus-display-x-face-in-from)
function)
:version "21.1"
@@ -761,9 +760,6 @@ Obsolete; use the face `gnus-signature' for customizations instead."
"Face used for highlighting a signature in the article buffer."
:group 'gnus-article-highlight
:group 'gnus-article-signature)
-;; backward-compatibility alias
-(put 'gnus-signature-face 'face-alias 'gnus-signature)
-(put 'gnus-signature-face 'obsolete-face "22.1")
(defface gnus-header-from
'((((class color)
@@ -777,9 +773,6 @@ Obsolete; use the face `gnus-signature' for customizations instead."
"Face used for displaying from headers."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
-;; backward-compatibility alias
-(put 'gnus-header-from-face 'face-alias 'gnus-header-from)
-(put 'gnus-header-from-face 'obsolete-face "22.1")
(defface gnus-header-subject
'((((class color)
@@ -793,9 +786,6 @@ Obsolete; use the face `gnus-signature' for customizations instead."
"Face used for displaying subject headers."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
-;; backward-compatibility alias
-(put 'gnus-header-subject-face 'face-alias 'gnus-header-subject)
-(put 'gnus-header-subject-face 'obsolete-face "22.1")
(defface gnus-header-newsgroups
'((((class color)
@@ -811,9 +801,6 @@ In the default setup this face is only used for crossposted
articles."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
-;; backward-compatibility alias
-(put 'gnus-header-newsgroups-face 'face-alias 'gnus-header-newsgroups)
-(put 'gnus-header-newsgroups-face 'obsolete-face "22.1")
(defface gnus-header-name
'((((class color)
@@ -827,9 +814,6 @@ articles."
"Face used for displaying header names."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
-;; backward-compatibility alias
-(put 'gnus-header-name-face 'face-alias 'gnus-header-name)
-(put 'gnus-header-name-face 'obsolete-face "22.1")
(defface gnus-header-content
'((((class color)
@@ -842,9 +826,6 @@ articles."
(:italic t))) "Face used for displaying header content."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
-;; backward-compatibility alias
-(put 'gnus-header-content-face 'face-alias 'gnus-header-content)
-(put 'gnus-header-content-face 'obsolete-face "22.1")
(defcustom gnus-header-face-alist
'(("From" nil gnus-header-from)
@@ -1645,6 +1626,12 @@ resources when reading email groups (and therefore stops
tracking), but allows loading external resources when reading
from NNTP newsgroups and the like.
+People controlling these external resources won't be able to tell
+that any one person in particular has read the message (since
+it's in a public venue, many people will end up loading that
+resource), but they'll be able to tell that somebody from your IP
+address has accessed the resource.
+
This can also be a function to be evaluated. If so, it will be
called with the group name as the parameter, and should return a
regexp."
@@ -1826,7 +1813,7 @@ Initialized from `text-mode-syntax-table'.")
(if (looking-at (car list))
(setq list nil)
(setq list (cdr list))
- (incf i)))
+ (cl-incf i)))
i))
(defun article-hide-headers (&optional _arg _delete)
@@ -1966,7 +1953,7 @@ always hide."
(when (and cc to-list
(ignore-errors
(gnus-string-equal
- ;; only one address in CC
+ ;; only one address in Cc
(nth 1 (mail-extract-address-components cc))
to-list)))
(gnus-article-hide-header "cc"))))
@@ -2236,7 +2223,7 @@ unfolded."
(dolist (elem gnus-article-image-alist)
(gnus-delete-images (car elem))))))
-(autoload 'w3m-toggle-inline-images "w3m")
+(declare-function w3m-toggle-inline-images "w3m")
(defun gnus-article-show-images ()
"Show any images that are in the HTML-rendered article buffer.
@@ -2246,10 +2233,12 @@ This only works if the article in question is HTML."
(save-restriction
(widen)
(if (eq mm-text-html-renderer 'w3m)
- (w3m-toggle-inline-images)
+ (progn
+ (require 'w3m)
+ (w3m-toggle-inline-images))
(dolist (region (gnus-find-text-property-region (point-min) (point-max)
'image-displayer))
- (destructuring-bind (start end function) region
+ (cl-destructuring-bind (start end function) region
(funcall function (get-text-property start 'image-url)
start end)))))))
@@ -2946,7 +2935,8 @@ message header will be added to the bodies of the \"text/html\" parts."
(encode-coding-string
title coding))
body content))
- (setq eheader (string-as-unibyte (buffer-string))
+ (setq eheader (encode-coding-string
+ (buffer-string) 'utf-8)
body content)))
(erase-buffer)
(mm-disable-multibyte)
@@ -3029,9 +3019,6 @@ articles to verify whether you have read the message. As
browser without eliminating these \"web bugs\" you should only
use it for mails from trusted senders.
-If you always want to display HTML parts in the browser, set
-`mm-text-html-renderer' to nil.
-
This command creates temporary files to pass HTML contents including
images if any to the browser, and deletes them when exiting the group
\(if you want)."
@@ -3553,18 +3540,11 @@ possible values."
(concat "Date: " (message-make-date time)))
;; Convert to Universal Time.
((eq type 'ut)
- (concat "Date: "
- (substring
- (message-make-date
- (let* ((e (parse-time-string date))
- (tm (apply 'encode-time e))
- (ms (car tm))
- (ls (- (cadr tm) (car (current-time-zone time)))))
- (cond ((< ls 0) (list (1- ms) (+ ls 65536)))
- ((> ls 65535) (list (1+ ms) (- ls 65536)))
- (t (list ms ls)))))
- 0 -5)
- "UT"))
+ (let ((system-time-locale "C"))
+ (format-time-string
+ "Date: %a, %d %b %Y %T UT"
+ (encode-time (parse-time-string date))
+ t)))
;; Get the original date from the article.
((eq type 'original)
(concat "Date: " (if (string-match "\n+$" date)
@@ -3582,13 +3562,7 @@ possible values."
(concat "Date: " (format-time-string format time)))))
;; ISO 8601.
((eq type 'iso8601)
- (let ((tz (car (current-time-zone time))))
- (concat
- "Date: "
- (format-time-string "%Y%m%dT%H%M%S" time)
- (format "%s%02d%02d"
- (if (> tz 0) "+" "-") (/ (abs tz) 3600)
- (/ (% (abs tz) 3600) 60)))))
+ (format-time-string "Date: %Y%m%dT%H%M%S%z" time))
;; Do a lapsed format.
((eq type 'lapsed)
(concat "Date: " (article-lapsed-string time)))
@@ -3636,19 +3610,14 @@ possible values."
(defun article-lapsed-string (time &optional max-segments)
;; If the date is seriously mangled, the timezone functions are
;; liable to bug out, so we ignore all errors.
- (let* ((now (current-time))
- (real-time (time-subtract now time))
- (real-sec (and real-time
- (+ (* (float (car real-time)) 65536)
- (cadr real-time))))
- (sec (and real-time (abs real-sec)))
+ (let* ((real-time (time-since time))
+ (real-sec (float-time real-time))
+ (sec (abs real-sec))
(segments 0)
num prev)
(unless max-segments
(setq max-segments (length article-time-units)))
(cond
- ((null real-time)
- "Unknown")
((zerop sec)
"Now")
(t
@@ -4402,8 +4371,6 @@ If variable `gnus-use-long-file-name' is non-nil, it is
;;; Gnus article mode
;;;
-(put 'gnus-article-mode 'mode-class 'special)
-
(set-keymap-parent gnus-article-mode-map widget-keymap)
(gnus-define-keys gnus-article-mode-map
@@ -4481,9 +4448,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is
(defvar bookmark-make-record-function)
(defvar shr-put-image-function)
-(define-derived-mode gnus-article-mode fundamental-mode "Article"
+(define-derived-mode gnus-article-mode gnus-mode "Article"
"Major mode for displaying an article.
-
All normal editing commands are switched off.
The following commands are available in addition to all summary mode
@@ -4524,8 +4490,7 @@ commands:
(setq cursor-in-non-selected-windows nil))
(gnus-set-default-directory)
(buffer-disable-undo)
- (setq buffer-read-only t
- show-trailing-whitespace nil)
+ (setq show-trailing-whitespace nil)
(mm-enable-multibyte))
(defun gnus-article-setup-buffer ()
@@ -4725,6 +4690,11 @@ If ALL-HEADERS is non-nil, no headers are hidden."
(forward-line -1))
(set-window-point (get-buffer-window (current-buffer)) (point))
(gnus-configure-windows 'article)
+ ;; Make sure the article begins with the top of the header.
+ (let ((window (get-buffer-window gnus-article-buffer)))
+ (when window
+ (with-current-buffer (window-buffer window)
+ (set-window-point window (point-min)))))
(gnus-run-hooks 'gnus-article-prepare-hook)
t))))))
@@ -5168,7 +5138,7 @@ Deleting parts may malfunction or destroy the article; continue? "))
"`----\n"))
(setcdr data
(cdr (mm-make-handle
- nil `("text/plain" (charset . gnus-decoded)) nil nil
+ nil '("text/plain" (charset . gnus-decoded)) nil nil
(list "attachment")
(format "Deleted attachment (%s bytes)" bsize))))))
;; (set-buffer gnus-summary-buffer)
@@ -5228,7 +5198,7 @@ available media-types."
(gnus-completing-read
"View as MIME type"
(if pred
- (gnus-remove-if-not pred (mailcap-mime-types))
+ (seq-filter pred (mailcap-mime-types))
(mailcap-mime-types))
nil nil nil
(car default)))))
@@ -6696,7 +6666,7 @@ not have a face in `gnus-article-boring-faces'."
(interactive "P")
(gnus-article-check-buffer)
(let ((nosaves
- '("q" "Q" "c" "r" "\C-c\C-f" "m" "a" "f" "WDD" "WDW"
+ '("q" "Q" "r" "\C-c\C-f" "m" "a" "f" "WDD" "WDW"
"Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
"=" "^" "\M-^" "|"))
(nosave-but-article
@@ -6762,7 +6732,8 @@ not have a face in `gnus-article-boring-faces'."
;; We disable the pick minor mode commands.
(setq func (let (gnus-pick-mode)
(key-binding keys t)))
- (when (get func 'disabled)
+ (when (and (symbolp func)
+ (get func 'disabled))
(error "Function %s disabled" func))
(if (and func
(functionp func)
@@ -7060,9 +7031,8 @@ If given a prefix, show the hidden text instead."
;; equivalent of string-make-multibyte which amount to decoding
;; with locale-coding-system, causing failure of
;; subsequent decoding.
- (insert (string-to-multibyte
- (with-current-buffer gnus-original-article-buffer
- (buffer-substring (point-min) (point-max)))))
+ (insert (with-current-buffer gnus-original-article-buffer
+ (buffer-substring (point-min) (point-max))))
'article)
;; Check the backlog.
((and gnus-keep-backlog
@@ -7406,9 +7376,8 @@ groups."
:group 'gnus-article-buttons
:type 'regexp)
-;; Regexp suggested by Felix Wiemann in <87oeuomcz9.fsf@news2.ososo.de>
(defcustom gnus-button-valid-localpart-regexp
- "[a-z0-9$%(*-=?[_][^<>\")!;:,{}\n\t @]*"
+ "[-a-z0-9$%(*+./=?[_][^<>\")!;:,{}\n\t @]*"
"Regular expression that matches a localpart of mail addresses or MIDs."
:version "22.1"
:group 'gnus-article-buttons
@@ -8238,7 +8207,7 @@ url is put as the `gnus-button-url' overlay property on the button."
(defun gnus-button-handle-news (url)
"Fetch a news URL."
- (destructuring-bind (_scheme server port group message-id _articles)
+ (cl-destructuring-bind (_scheme server port group message-id _articles)
(gnus-parse-news-url url)
(cond
(message-id
diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el
index f256635b40b..4e2723e8d27 100644
--- a/lisp/gnus/gnus-async.el
+++ b/lisp/gnus/gnus-async.el
@@ -24,7 +24,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'gnus)
(require 'gnus-sum)
@@ -84,7 +84,6 @@ that was fetched."
(defvar gnus-async-article-alist nil)
(defvar gnus-async-article-semaphore '(nil))
(defvar gnus-async-fetch-list nil)
-(defvar gnus-async-hashtb nil)
(defvar gnus-async-current-prefetch-group nil)
(defvar gnus-async-current-prefetch-article nil)
(defvar gnus-async-timer nil)
@@ -127,14 +126,11 @@ that was fetched."
(defun gnus-async-close ()
(gnus-kill-buffer gnus-async-prefetch-article-buffer)
(gnus-kill-buffer gnus-async-prefetch-headers-buffer)
- (setq gnus-async-hashtb nil
- gnus-async-article-alist nil
+ (setq gnus-async-article-alist nil
gnus-async-header-prefetched nil))
(defun gnus-async-set-buffer ()
- (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t)
- (unless gnus-async-hashtb
- (setq gnus-async-hashtb (gnus-make-hashtable 1023))))
+ (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t))
(defun gnus-async-halt-prefetch ()
"Stop prefetching."
@@ -183,7 +179,7 @@ that was fetched."
d)
(while (and (setq d (pop data))
(if (numberp n)
- (natnump (decf n))
+ (natnump (cl-decf n))
n))
(unless (or (gnus-async-prefetched-article-entry
group (setq article (gnus-data-number d)))
@@ -242,13 +238,10 @@ that was fetched."
(when gnus-async-post-fetch-function
(funcall gnus-async-post-fetch-function summary))))
(gnus-async-with-semaphore
- (setq
- gnus-async-article-alist
- (cons (list (intern (format "%s-%d" group article)
- gnus-async-hashtb)
- mark (point-max-marker)
- group article)
- gnus-async-article-alist))))
+ (push (list (format "%s-%d" group article)
+ mark (point-max-marker)
+ group article)
+ gnus-async-article-alist)))
(if (not (gnus-buffer-live-p summary))
(gnus-async-with-semaphore
(setq gnus-async-fetch-list nil))
@@ -290,7 +283,7 @@ that was fetched."
;; should check time-since-last-output, which
;; needs to be done in nntp.el.
(while (eq article gnus-async-current-prefetch-article)
- (incf tries)
+ (cl-incf tries)
(when (nntp-accept-process-output proc)
(setq tries 0))
(when (and (not nntp-have-messaged)
@@ -314,8 +307,7 @@ that was fetched."
(set-marker (caddr entry) nil))
(gnus-async-with-semaphore
(setq gnus-async-article-alist
- (delq entry gnus-async-article-alist))
- (unintern (car entry) gnus-async-hashtb)))
+ (delete entry gnus-async-article-alist))))
(defun gnus-async-prefetch-remove-group (group)
"Remove all articles belonging to GROUP from the prefetch buffer."
@@ -331,9 +323,8 @@ that was fetched."
"Return the entry for ARTICLE in GROUP if it has been prefetched."
(let ((entry (save-excursion
(gnus-async-set-buffer)
- (assq (intern-soft (format "%s-%d" group article)
- gnus-async-hashtb)
- gnus-async-article-alist))))
+ (assoc (format "%s-%d" group article)
+ gnus-async-article-alist))))
;; Perhaps something has emptied the buffer?
(if (and entry
(= (cadr entry) (caddr entry)))
@@ -342,7 +333,7 @@ that was fetched."
(set-marker (cadr entry) nil)
(set-marker (caddr entry) nil))
(setq gnus-async-article-alist
- (delq entry gnus-async-article-alist))
+ (delete entry gnus-async-article-alist))
nil)
entry)))
diff --git a/lisp/gnus/gnus-bcklg.el b/lisp/gnus/gnus-bcklg.el
index c5c85289555..c5a0e3ec4f0 100644
--- a/lisp/gnus/gnus-bcklg.el
+++ b/lisp/gnus/gnus-bcklg.el
@@ -22,19 +22,16 @@
;;; Commentary:
-;;; Code:
+;; The backlog caches the text of a certain number of read articles in
+;; a separate buffer, so they can be retrieved quickly if the user
+;; opens them again. Also see `gnus-keep-backlog'.
-(eval-when-compile (require 'cl))
+;;; Code:
(require 'gnus)
-;;;
-;;; Buffering of read articles.
-;;;
-
(defvar gnus-backlog-buffer " *Gnus Backlog*")
-(defvar gnus-backlog-articles nil)
-(defvar gnus-backlog-hashtb nil)
+(defvar gnus-backlog-articles '())
(defun gnus-backlog-buffer ()
"Return the backlog buffer."
@@ -44,11 +41,6 @@
(setq buffer-read-only t)
(get-buffer gnus-backlog-buffer))))
-(defun gnus-backlog-setup ()
- "Initialize backlog variables."
- (unless gnus-backlog-hashtb
- (setq gnus-backlog-hashtb (gnus-make-hashtable 1024))))
-
(gnus-add-shutdown 'gnus-backlog-shutdown 'gnus)
(defun gnus-backlog-shutdown ()
@@ -56,46 +48,42 @@
(interactive)
(when (get-buffer gnus-backlog-buffer)
(gnus-kill-buffer gnus-backlog-buffer))
- (setq gnus-backlog-hashtb nil
- gnus-backlog-articles nil))
+ (setq gnus-backlog-articles nil))
(defun gnus-backlog-enter-article (group number buffer)
(when (and (numberp number)
(not (gnus-virtual-group-p group)))
- (gnus-backlog-setup)
- (let ((ident (intern (concat group ":" (int-to-string number))
- gnus-backlog-hashtb))
+ (let ((ident (format "%s:%d" group number))
b)
- (if (memq ident gnus-backlog-articles)
- () ; It's already kept.
- ;; Remove the oldest article, if necessary.
- (and (numberp gnus-keep-backlog)
- (>= (length gnus-backlog-articles) gnus-keep-backlog)
- (gnus-backlog-remove-oldest-article))
- (push ident gnus-backlog-articles)
- ;; Insert the new article.
- (with-current-buffer (gnus-backlog-buffer)
- (let (buffer-read-only)
- (goto-char (point-max))
- (unless (bolp)
- (insert "\n"))
- (setq b (point))
- (insert-buffer-substring buffer)
- ;; Tag the beginning of the article with the ident.
- (if (> (point-max) b)
- (put-text-property b (1+ b) 'gnus-backlog ident)
- (gnus-error 3 "Article %d is blank" number))))))))
+ (unless (member ident gnus-backlog-articles) ; It's already kept.
+ ;; Remove the oldest article, if necessary.
+ (and (numberp gnus-keep-backlog)
+ (>= (length gnus-backlog-articles) gnus-keep-backlog)
+ (gnus-backlog-remove-oldest-article))
+ (push ident gnus-backlog-articles)
+ ;; Insert the new article.
+ (with-current-buffer (gnus-backlog-buffer)
+ (let (buffer-read-only)
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert "\n"))
+ (setq b (point))
+ (insert-buffer-substring buffer)
+ ;; Tag the beginning of the article with the ident.
+ (if (> (point-max) b)
+ (put-text-property b (1+ b) 'gnus-backlog ident)
+ (gnus-error 3 "Article %d is blank" number))))))))
(defun gnus-backlog-remove-oldest-article ()
(with-current-buffer (gnus-backlog-buffer)
(goto-char (point-min))
- (if (zerop (buffer-size))
- () ; The buffer is empty.
+ (unless (zerop (buffer-size)) ; The buffer is empty.
(let ((ident (get-text-property (point) 'gnus-backlog))
buffer-read-only)
;; Remove the ident from the list of articles.
(when ident
- (setq gnus-backlog-articles (delq ident gnus-backlog-articles)))
+ (setq gnus-backlog-articles
+ (delete ident gnus-backlog-articles)))
;; Delete the article itself.
(delete-region
(point) (next-single-property-change
@@ -104,42 +92,40 @@
(defun gnus-backlog-remove-article (group number)
"Remove article NUMBER in GROUP from the backlog."
(when (numberp number)
- (gnus-backlog-setup)
- (let ((ident (intern (concat group ":" (int-to-string number))
- gnus-backlog-hashtb))
- beg end)
- (when (memq ident gnus-backlog-articles)
+ (let ((ident (format "%s:%d" group number))
+ beg)
+ (when (member ident gnus-backlog-articles)
;; It was in the backlog.
(with-current-buffer (gnus-backlog-buffer)
- (let (buffer-read-only)
- (when (setq beg (text-property-any
- (point-min) (point-max) 'gnus-backlog
- ident))
- ;; Find the end (i. e., the beginning of the next article).
- (setq end
- (next-single-property-change
- (1+ beg) 'gnus-backlog (current-buffer) (point-max)))
- (delete-region beg end)
- ;; Return success.
- t))
- (setq gnus-backlog-articles (delq ident gnus-backlog-articles)))))))
+ (save-excursion
+ (let (buffer-read-only)
+ (goto-char (point-min))
+ (when (setq beg (gnus-text-property-search
+ 'gnus-backlog ident))
+ ;; Find the end (i. e., the beginning of the next article).
+ (goto-char
+ (next-single-property-change
+ (1+ beg) 'gnus-backlog (current-buffer) (point-max)))
+ (delete-region beg (point))
+ ;; Return success.
+ t)))
+ (setq gnus-backlog-articles
+ (delete ident gnus-backlog-articles)))))))
(defun gnus-backlog-request-article (group number &optional buffer)
(when (and (numberp number)
(not (gnus-virtual-group-p group)))
- (gnus-backlog-setup)
- (let ((ident (intern (concat group ":" (int-to-string number))
- gnus-backlog-hashtb))
+ (let ((ident (format "%s:%d" group number))
beg end)
- (when (memq ident gnus-backlog-articles)
+ (when (member ident gnus-backlog-articles)
;; It was in the backlog.
(with-current-buffer (gnus-backlog-buffer)
- (if (not (setq beg (text-property-any
- (point-min) (point-max) 'gnus-backlog
- ident)))
+ (if (not (setq beg (gnus-text-property-search
+ 'gnus-backlog ident)))
;; It wasn't in the backlog after all.
(ignore
- (setq gnus-backlog-articles (delq ident gnus-backlog-articles)))
+ (setq gnus-backlog-articles
+ (delete ident gnus-backlog-articles)))
;; Find the end (i. e., the beginning of the next article).
(setq end
(next-single-property-change
diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el
index a30ae38abb6..5e6483d1053 100644
--- a/lisp/gnus/gnus-cache.el
+++ b/lisp/gnus/gnus-cache.el
@@ -24,7 +24,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'gnus)
(require 'gnus-sum)
@@ -272,7 +272,7 @@ it's not cached."
(defun gnus-cache-possibly-alter-active (group active)
"Alter the ACTIVE info for GROUP to reflect the articles in the cache."
(when gnus-cache-active-hashtb
- (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb)))
+ (let ((cache-active (gethash group gnus-cache-active-hashtb)))
(when cache-active
(when (< (car cache-active) (car active))
(setcar active (car cache-active)))
@@ -522,7 +522,7 @@ system for example was used.")
(gnus-delete-line)))
(unless (setq gnus-newsgroup-cached
(delq article gnus-newsgroup-cached))
- (gnus-sethash gnus-newsgroup-name nil gnus-cache-active-hashtb)
+ (remhash gnus-newsgroup-name gnus-cache-active-hashtb)
(setq gnus-cache-active-altered t))
(gnus-summary-update-secondary-mark article)
t)))
@@ -542,8 +542,8 @@ system for example was used.")
(progn
(gnus-cache-update-active group (car articles) t)
(gnus-cache-update-active group (car (last articles))))
- (when (gnus-gethash group gnus-cache-active-hashtb)
- (gnus-sethash group nil gnus-cache-active-hashtb)
+ (when (gethash group gnus-cache-active-hashtb)
+ (remhash group gnus-cache-active-hashtb)
(setq gnus-cache-active-altered t)))
articles)))
@@ -642,7 +642,8 @@ $ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache"
"Read the cache active file."
(gnus-make-directory gnus-cache-directory)
(if (or (not (file-exists-p gnus-cache-active-file))
- (zerop (nth 7 (file-attributes gnus-cache-active-file)))
+ (zerop (file-attribute-size
+ (file-attributes gnus-cache-active-file)))
force)
;; There is no active file, so we generate one.
(gnus-cache-generate-active)
@@ -665,13 +666,16 @@ $ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache"
;; Mark the active hashtb as unaltered.
(setq gnus-cache-active-altered nil)))
+;; FIXME: Why is there a `gnus-cache-possibly-alter-active',
+;; `gnus-cache-possibly-update-active', and
+;; `gnus-cache-update-active'? Do we really need all three?
(defun gnus-cache-possibly-update-active (group active)
"Update active info bounds of GROUP with ACTIVE if necessary.
The update is performed if ACTIVE contains a higher or lower bound
than the current."
(let ((lower t) (higher t))
(if gnus-cache-active-hashtb
- (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb)))
+ (let ((cache-active (gethash group gnus-cache-active-hashtb)))
(when cache-active
(unless (< (car active) (car cache-active))
(setq lower nil))
@@ -686,10 +690,10 @@ than the current."
(defun gnus-cache-update-active (group number &optional low)
"Update the upper bound of the active info of GROUP to NUMBER.
If LOW, update the lower bound instead."
- (let ((active (gnus-gethash group gnus-cache-active-hashtb)))
+ (let ((active (gethash group gnus-cache-active-hashtb)))
(if (null active)
;; We just create a new active entry for this group.
- (gnus-sethash group (cons number number) gnus-cache-active-hashtb)
+ (puthash group (cons number number) gnus-cache-active-hashtb)
;; Update the lower or upper bound.
(if low
(setcar active number)
@@ -733,10 +737,10 @@ If LOW, update the lower bound instead."
;; FIXME: this is kind of a workaround. The active file should
;; be updated at the time articles are cached. It will make
;; `gnus-cache-unified-group-names' needless.
- (gnus-sethash (or (cdr (assoc group gnus-cache-unified-group-names))
- group)
- (cons (car nums) (gnus-last-element nums))
- gnus-cache-active-hashtb))
+ (puthash (or (cdr (assoc group gnus-cache-unified-group-names))
+ group)
+ (cons (car nums) (car (last nums)))
+ gnus-cache-active-hashtb))
;; Go through all the other files.
(dolist (file alphs)
(when (and (file-directory-p file)
@@ -797,13 +801,13 @@ supported."
(unless gnus-cache-active-hashtb
(gnus-cache-read-active))
(let* ((old-group-hash-value
- (gnus-gethash old-group gnus-cache-active-hashtb))
+ (gethash old-group gnus-cache-active-hashtb))
(new-group-hash-value
- (gnus-gethash new-group gnus-cache-active-hashtb))
+ (gethash new-group gnus-cache-active-hashtb))
(delta
(or old-group-hash-value new-group-hash-value)))
- (gnus-sethash new-group old-group-hash-value gnus-cache-active-hashtb)
- (gnus-sethash old-group nil gnus-cache-active-hashtb)
+ (puthash new-group old-group-hash-value gnus-cache-active-hashtb)
+ (puthash old-group nil gnus-cache-active-hashtb)
(if no-save
(setq gnus-cache-active-altered delta)
@@ -825,8 +829,8 @@ supported."
(let ((no-save gnus-cache-active-hashtb))
(unless gnus-cache-active-hashtb
(gnus-cache-read-active))
- (let* ((group-hash-value (gnus-gethash group gnus-cache-active-hashtb)))
- (gnus-sethash group nil gnus-cache-active-hashtb)
+ (let* ((group-hash-value (gethash group gnus-cache-active-hashtb)))
+ (remhash group gnus-cache-active-hashtb)
(if no-save
(setq gnus-cache-active-altered group-hash-value)
@@ -848,13 +852,13 @@ supported."
(when gnus-cache-total-fetched-hashtb
(gnus-cache-with-refreshed-group
group
- (let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb)
- (gnus-sethash group (make-vector 2 0)
- gnus-cache-total-fetched-hashtb)))
+ (let* ((entry (or (gethash group gnus-cache-total-fetched-hashtb)
+ (puthash group (make-vector 2 0)
+ gnus-cache-total-fetched-hashtb)))
size)
(if file
- (setq size (or (nth 7 (file-attributes file)) 0))
+ (setq size (or (file-attribute-size (file-attributes file)) 0))
(let* ((file-name-coding-system nnmail-pathname-coding-system)
(files (directory-files (gnus-cache-file-name group "")
t nil t))
@@ -862,22 +866,22 @@ supported."
(setq size 0.0)
(while (setq file (pop files))
(setq attrs (file-attributes file))
- (unless (nth 0 attrs)
- (incf size (float (nth 7 attrs)))))))
+ (unless (file-attribute-type attrs)
+ (cl-incf size (float (file-attribute-size attrs)))))))
(setq gnus-cache-need-update-total-fetched-for t)
- (incf (nth 1 entry) (if subtract (- size) size))))))
+ (cl-incf (nth 1 entry) (if subtract (- size) size))))))
(defun gnus-cache-update-overview-total-fetched-for (group file)
(when gnus-cache-total-fetched-hashtb
(gnus-cache-with-refreshed-group
group
- (let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb)
- (gnus-sethash group (make-list 2 0)
+ (let* ((entry (or (gethash group gnus-cache-total-fetched-hashtb)
+ (puthash group (make-list 2 0)
gnus-cache-total-fetched-hashtb)))
(file-name-coding-system nnmail-pathname-coding-system)
- (size (or (nth 7 (file-attributes
+ (size (or (file-attribute-size (file-attributes
(or file
(gnus-cache-file-name group ".overview"))))
0)))
@@ -887,22 +891,21 @@ supported."
(defun gnus-cache-rename-group-total-fetched-for (old-group new-group)
"Record of disk space used by OLD-GROUP now associated with NEW-GROUP."
(when gnus-cache-total-fetched-hashtb
- (let ((entry (gnus-gethash old-group gnus-cache-total-fetched-hashtb)))
- (gnus-sethash new-group entry gnus-cache-total-fetched-hashtb)
- (gnus-sethash old-group nil gnus-cache-total-fetched-hashtb))))
+ (let ((entry (gethash old-group gnus-cache-total-fetched-hashtb)))
+ (puthash new-group entry gnus-cache-total-fetched-hashtb)
+ (remhash old-group gnus-cache-total-fetched-hashtb))))
(defun gnus-cache-delete-group-total-fetched-for (group)
"Delete record of disk space used by GROUP being deleted."
(when gnus-cache-total-fetched-hashtb
- (gnus-sethash group nil gnus-cache-total-fetched-hashtb)))
+ (remhash group gnus-cache-total-fetched-hashtb)))
(defun gnus-cache-total-fetched-for (group &optional no-inhibit)
"Get total disk space used by the cache for the specified GROUP."
(unless (equal group "dummy.group")
(unless gnus-cache-total-fetched-hashtb
- (setq gnus-cache-total-fetched-hashtb (gnus-make-hashtable 1024)))
-
- (let* ((entry (gnus-gethash group gnus-cache-total-fetched-hashtb)))
+ (setq gnus-cache-total-fetched-hashtb (gnus-make-hashtable 1000)))
+ (let* ((entry (gethash group gnus-cache-total-fetched-hashtb)))
(if entry
(apply '+ entry)
(let ((gnus-cache-inhibit-update-total-fetched-for (not no-inhibit)))
diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el
index d8b6df70bd4..7e431e79fc7 100644
--- a/lisp/gnus/gnus-cite.el
+++ b/lisp/gnus/gnus-cite.el
@@ -23,8 +23,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
-
(require 'gnus)
(require 'gnus-range)
(require 'gnus-art)
@@ -136,9 +134,6 @@ the envelope From line."
(defface gnus-cite-attribution '((t (:italic t)))
"Face used for attribution lines."
:group 'gnus-cite)
-;; backward-compatibility alias
-(put 'gnus-cite-attribution-face 'face-alias 'gnus-cite-attribution)
-(put 'gnus-cite-attribution-face 'obsolete-face "22.1")
(defcustom gnus-cite-attribution-face 'gnus-cite-attribution
"Face used for attribution lines.
@@ -157,9 +152,6 @@ It is merged with the face for the cited text belonging to the attribution."
(:italic t)))
"Citation face."
:group 'gnus-cite)
-;; backward-compatibility alias
-(put 'gnus-cite-face-1 'face-alias 'gnus-cite-1)
-(put 'gnus-cite-face-1 'obsolete-face "22.1")
(defface gnus-cite-2 '((((class color)
(background dark))
@@ -171,9 +163,6 @@ It is merged with the face for the cited text belonging to the attribution."
(:italic t)))
"Citation face."
:group 'gnus-cite)
-;; backward-compatibility alias
-(put 'gnus-cite-face-2 'face-alias 'gnus-cite-2)
-(put 'gnus-cite-face-2 'obsolete-face "22.1")
(defface gnus-cite-3 '((((class color)
(background dark))
@@ -185,9 +174,6 @@ It is merged with the face for the cited text belonging to the attribution."
(:italic t)))
"Citation face."
:group 'gnus-cite)
-;; backward-compatibility alias
-(put 'gnus-cite-face-3 'face-alias 'gnus-cite-3)
-(put 'gnus-cite-face-3 'obsolete-face "22.1")
(defface gnus-cite-4 '((((class color)
(background dark))
@@ -199,9 +185,6 @@ It is merged with the face for the cited text belonging to the attribution."
(:italic t)))
"Citation face."
:group 'gnus-cite)
-;; backward-compatibility alias
-(put 'gnus-cite-face-4 'face-alias 'gnus-cite-4)
-(put 'gnus-cite-face-4 'obsolete-face "22.1")
(defface gnus-cite-5 '((((class color)
(background dark))
@@ -213,9 +196,6 @@ It is merged with the face for the cited text belonging to the attribution."
(:italic t)))
"Citation face."
:group 'gnus-cite)
-;; backward-compatibility alias
-(put 'gnus-cite-face-5 'face-alias 'gnus-cite-5)
-(put 'gnus-cite-face-5 'obsolete-face "22.1")
(defface gnus-cite-6 '((((class color)
(background dark))
@@ -227,9 +207,6 @@ It is merged with the face for the cited text belonging to the attribution."
(:italic t)))
"Citation face."
:group 'gnus-cite)
-;; backward-compatibility alias
-(put 'gnus-cite-face-6 'face-alias 'gnus-cite-6)
-(put 'gnus-cite-face-6 'obsolete-face "22.1")
(defface gnus-cite-7 '((((class color)
(background dark))
@@ -241,9 +218,6 @@ It is merged with the face for the cited text belonging to the attribution."
(:italic t)))
"Citation face."
:group 'gnus-cite)
-;; backward-compatibility alias
-(put 'gnus-cite-face-7 'face-alias 'gnus-cite-7)
-(put 'gnus-cite-face-7 'obsolete-face "22.1")
(defface gnus-cite-8 '((((class color)
(background dark))
@@ -255,9 +229,6 @@ It is merged with the face for the cited text belonging to the attribution."
(:italic t)))
"Citation face."
:group 'gnus-cite)
-;; backward-compatibility alias
-(put 'gnus-cite-face-8 'face-alias 'gnus-cite-8)
-(put 'gnus-cite-face-8 'obsolete-face "22.1")
(defface gnus-cite-9 '((((class color)
(background dark))
@@ -269,9 +240,6 @@ It is merged with the face for the cited text belonging to the attribution."
(:italic t)))
"Citation face."
:group 'gnus-cite)
-;; backward-compatibility alias
-(put 'gnus-cite-face-9 'face-alias 'gnus-cite-9)
-(put 'gnus-cite-face-9 'obsolete-face "22.1")
(defface gnus-cite-10 '((((class color)
(background dark))
@@ -283,9 +251,6 @@ It is merged with the face for the cited text belonging to the attribution."
(:italic t)))
"Citation face."
:group 'gnus-cite)
-;; backward-compatibility alias
-(put 'gnus-cite-face-10 'face-alias 'gnus-cite-10)
-(put 'gnus-cite-face-10 'obsolete-face "22.1")
(defface gnus-cite-11 '((((class color)
(background dark))
@@ -297,9 +262,6 @@ It is merged with the face for the cited text belonging to the attribution."
(:italic t)))
"Citation face."
:group 'gnus-cite)
-;; backward-compatibility alias
-(put 'gnus-cite-face-11 'face-alias 'gnus-cite-11)
-(put 'gnus-cite-face-11 'obsolete-face "22.1")
(defcustom gnus-cite-face-list
'(gnus-cite-1 gnus-cite-2 gnus-cite-3 gnus-cite-4 gnus-cite-5 gnus-cite-6
@@ -378,7 +340,7 @@ in a boring face, then the pages will be skipped."
;; TAG: Is a Supercite tag, if any.
(defvar gnus-cited-opened-text-button-line-format-alist
- `((?b (marker-position beg) ?d)
+ '((?b (marker-position beg) ?d)
(?e (marker-position end) ?d)
(?n (count-lines beg end) ?d)
(?l (- end beg) ?d)))
@@ -519,8 +481,13 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps
(defun gnus-article-fill-cited-article (&optional width long-lines)
"Do word wrapping in the current article.
If WIDTH (the numerical prefix), use that text width when
-filling. If LONG-LINES, only fill sections that have lines
-longer than the frame width."
+filling.
+
+If LONG-LINES, only fill sections that have lines longer than the
+frame width.
+
+Sections that are heuristically interpreted as not being
+text (i.e., computer code and the like) will not be folded."
(interactive "P")
(with-current-buffer gnus-article-buffer
(let ((buffer-read-only nil)
@@ -540,8 +507,6 @@ longer than the frame width."
use-hard-newlines)
(unless do-fill
(setq do-fill (gnus-article-foldable-buffer (cdar marks))))
- ;; Note: the XEmacs version of `fill-region' inserts a newline
- ;; unless the region ends with a newline.
(when do-fill
(if (not long-lines)
(fill-region (point-min) (point-max))
@@ -660,7 +625,7 @@ always hide."
(point)
(progn (eval gnus-cited-closed-text-button-line-format-spec)
(point))
- `gnus-article-toggle-cited-text
+ 'gnus-article-toggle-cited-text
(list (cons beg end) start))
(point))
'article-type 'annotation)
@@ -710,7 +675,7 @@ means show, nil means toggle."
gnus-cited-opened-text-button-line-format-spec
gnus-cited-closed-text-button-line-format-spec))
(point))
- `gnus-article-toggle-cited-text
+ 'gnus-article-toggle-cited-text
args)
(point))
'article-type 'annotation)))))
@@ -1163,7 +1128,7 @@ Returns nil if there is no such line before LIMIT, t otherwise."
(let ((cdepth (min (length (apply 'concat
(split-string
(match-string-no-properties 0)
- "[ \t [:alnum:]]+")))
+ "[\t [:alnum:]]+")))
gnus-message-max-citation-depth))
(mlist (make-list (* (1+ gnus-message-max-citation-depth) 2) nil))
(start (point-at-bol))
diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el
index e6cf39c0525..485f815d9b9 100644
--- a/lisp/gnus/gnus-cloud.el
+++ b/lisp/gnus/gnus-cloud.el
@@ -28,7 +28,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
(require 'parse-time)
(require 'nnimap)
@@ -80,7 +79,7 @@ against the basename of files in said directory."
(defcustom gnus-cloud-method nil
"The IMAP select method used to store the cloud data.
-See also `gnus-server-toggle-cloud-method-server' for an
+See also `gnus-server-set-cloud-method-server' for an
easy interactive way to set this from the Server buffer."
:group 'gnus-cloud
:type '(radio (const :tag "Not set" nil)
@@ -229,7 +228,7 @@ easy interactive way to set this from the Server buffer."
Use old data if FORCE-OLDER is not nil."
(let* ((contents (plist-get elem :contents))
(date (or (plist-get elem :timestamp) "0"))
- (now (gnus-cloud-timestamp (current-time)))
+ (now (gnus-cloud-timestamp nil))
(newer (string-lessp date now))
(group-info (gnus-get-info group)))
(if (and contents
@@ -340,7 +339,8 @@ Use old data if FORCE-OLDER is not nil."
(format-time-string "%FT%T%z" time))
(defun gnus-cloud-file-new-p (file full)
- (let ((timestamp (gnus-cloud-timestamp (nth 5 (file-attributes file))))
+ (let ((timestamp (gnus-cloud-timestamp (file-attribute-modification-time
+ (file-attributes file))))
(old (cadr (assoc file gnus-cloud-file-timestamps))))
(when (or full
(null old)
@@ -368,6 +368,8 @@ Use old data if FORCE-OLDER is not nil."
(interactive)
(gnus-cloud-upload-data t))
+(autoload 'gnus-group-refresh-group "gnus-group")
+
(defun gnus-cloud-upload-data (&optional full)
"Upload data (newsrc and files) to the Gnus Cloud.
When FULL is t, upload everything, not just a difference from the last full."
@@ -498,7 +500,7 @@ Otherwise, returns the Gnus Cloud data chunks."
(gnus-method-to-server
(gnus-find-method-for-group (gnus-info-group info))))
- (push `(:type :newsrc-data :name ,(gnus-info-group info) :contents ,info :timestamp ,(gnus-cloud-timestamp (current-time)))
+ (push `(:type :newsrc-data :name ,(gnus-info-group info) :contents ,info :timestamp ,(gnus-cloud-timestamp nil))
infos)))
infos))
diff --git a/lisp/gnus/gnus-cus.el b/lisp/gnus/gnus-cus.el
index 66fa3e0590f..d56066e6168 100644
--- a/lisp/gnus/gnus-cus.el
+++ b/lisp/gnus/gnus-cus.el
@@ -406,7 +406,7 @@ category."))
;; every duplicate ends up being displayed. So, rather than
;; display them, remove them from the list.
- (let ((tmp (setq values (gnus-copy-sequence values)))
+ (let ((tmp (setq values (copy-tree values)))
elem)
(while (cdr tmp)
(while (setq elem (assq (caar tmp) (cdr tmp)))
diff --git a/lisp/gnus/gnus-delay.el b/lisp/gnus/gnus-delay.el
index b15187bcbc7..aabf23924a0 100644
--- a/lisp/gnus/gnus-delay.el
+++ b/lisp/gnus/gnus-delay.el
@@ -98,19 +98,15 @@ DELAY is a string, giving the length of the time. Possible values are:
(setq hour (string-to-number (match-string 1 delay))
minute (string-to-number (match-string 2 delay)))
;; Use current time, except...
- (setq deadline (apply 'vector (decode-time)))
+ (setq deadline (decode-time))
;; ... for minute and hour.
- (aset deadline 1 minute)
- (aset deadline 2 hour)
- ;; Convert to seconds.
- (setq deadline (float-time (apply 'encode-time
- (append deadline nil))))
+ (setq deadline (apply #'encode-time (car deadline) minute hour
+ (nthcdr 3 deadline)))
;; If this time has passed already, add a day.
- (when (< deadline (float-time))
- (setq deadline (+ 86400 deadline))) ; 86400 secs/day
+ (when (time-less-p deadline nil)
+ (setq deadline (time-add 86400 deadline))) ; 86400 secs/day
;; Convert seconds to date header.
- (setq deadline (message-make-date
- (seconds-to-time deadline))))
+ (setq deadline (message-make-date deadline)))
((string-match "\\([0-9]+\\)\\s-*\\([mhdwMY]\\)" delay)
(setq num (match-string 1 delay))
(setq unit (match-string 2 delay))
@@ -128,8 +124,7 @@ DELAY is a string, giving the length of the time. Possible values are:
(setq delay (* num 60 60)))
(t
(setq delay (* num 60))))
- (setq deadline (message-make-date
- (seconds-to-time (+ (float-time) delay)))))
+ (setq deadline (message-make-date (time-add nil delay))))
(t (error "Malformed delay `%s'" delay)))
(message-add-header (format "%s: %s" gnus-delay-header deadline)))
(set-buffer-modified-p t)
@@ -164,11 +159,8 @@ DELAY is a string, giving the length of the time. Possible values are:
nil t)
(progn
(setq deadline (nnheader-header-value))
- (setq deadline (apply 'encode-time
- (parse-time-string deadline)))
- (setq deadline (time-since deadline))
- (when (and (>= (nth 0 deadline) 0)
- (>= (nth 1 deadline) 0))
+ (setq deadline (encode-time (parse-time-string deadline)))
+ (unless (time-less-p nil deadline)
(message "Sending delayed article %d" article)
(gnus-draft-send article group)
(message "Sending delayed article %d...done" article)))
diff --git a/lisp/gnus/gnus-demon.el b/lisp/gnus/gnus-demon.el
index 5709c50eb16..6c5e0b7f5d0 100644
--- a/lisp/gnus/gnus-demon.el
+++ b/lisp/gnus/gnus-demon.el
@@ -24,7 +24,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'gnus)
(require 'gnus-int)
@@ -93,7 +93,7 @@ Emacs has been idle for IDLE `gnus-demon-timestep's."
(defun gnus-demon-idle-since ()
"Return the number of seconds since when Emacs is idle."
- (float-time (or (current-idle-time) '(0 0 0))))
+ (float-time (or (current-idle-time) 0)))
(defun gnus-demon-run-callback (func &optional idle time special)
"Run FUNC if Emacs has been idle for longer than IDLE seconds.
@@ -101,7 +101,7 @@ If not, and a TIME is given, restart a new idle timer, so FUNC
can be called at the next opportunity. Such a special idle run is
marked with SPECIAL."
(unless gnus-inhibit-demon
- (block run-callback
+ (cl-block run-callback
(when (eq idle t)
(setq idle 0.001))
(cond (special
@@ -117,7 +117,7 @@ marked with SPECIAL."
(run-with-idle-timer idle nil
'gnus-demon-run-callback
func idle time t))))
- (return-from run-callback)))
+ (cl-return-from run-callback)))
(with-local-quit
(ignore-errors
(funcall func))))))
@@ -192,11 +192,9 @@ marked with SPECIAL."
(elt nowParts 6)
(elt nowParts 7)
(elt nowParts 8)))
- ;; calculate number of seconds between NOW and THEN
- (diff (+ (* 65536 (- (car then) (car now)))
- (- (cadr then) (cadr now)))))
- ;; return number of timesteps in the number of seconds
- (round (/ diff gnus-demon-timestep))))
+ (diff (float-time (time-subtract then now))))
+ ;; Return number of timesteps in the number of seconds.
+ (round diff gnus-demon-timestep)))
(gnus-add-shutdown 'gnus-demon-cancel 'gnus)
diff --git a/lisp/gnus/gnus-diary.el b/lisp/gnus/gnus-diary.el
index 51e39958798..ceb0d4a30da 100644
--- a/lisp/gnus/gnus-diary.el
+++ b/lisp/gnus/gnus-diary.el
@@ -159,32 +159,29 @@ There are currently two built-in format functions:
;; Code partly stolen from article-make-date-line
(let* ((extras (mail-header-extra header))
(sched (gnus-diary-header-schedule extras))
- (occur (nndiary-next-occurrence sched (current-time)))
(now (current-time))
+ (occur (nndiary-next-occurrence sched now))
(real-time (time-subtract occur now)))
- (if (null real-time)
- "?????"
- (let* ((sec (+ (* (float (car real-time)) 65536) (cadr real-time)))
- (past (< sec 0))
- delay)
- (and past (setq sec (- sec)))
- (unless (zerop sec)
- ;; This is a bit convoluted, but basically we go through the time
- ;; units for years, weeks, etc, and divide things to see whether
- ;; that results in positive answers.
- (let ((units `((year . ,(* 365.25 24 3600))
- (month . ,(* 31 24 3600))
- (week . ,(* 7 24 3600))
- (day . ,(* 24 3600))
- (hour . 3600)
- (minute . 60)))
- unit num)
- (while (setq unit (pop units))
- (unless (zerop (setq num (ffloor (/ sec (cdr unit)))))
- (setq delay (append delay `((,(floor num) . ,(car unit))))))
- (setq sec (- sec (* num (cdr unit)))))))
- (funcall gnus-diary-delay-format-function past delay)))
- ))
+ (let* ((sec (encode-time real-time 'integer))
+ (past (< sec 0))
+ delay)
+ (and past (setq sec (- sec)))
+ (unless (zerop sec)
+ ;; This is a bit convoluted, but basically we go through the time
+ ;; units for years, weeks, etc, and divide things to see whether
+ ;; that results in positive answers.
+ (let ((units `((year . ,(round (* 365.25 24 3600)))
+ (month . ,(* 31 24 3600))
+ (week . ,(* 7 24 3600))
+ (day . ,(* 24 3600))
+ (hour . 3600)
+ (minute . 60)))
+ unit num)
+ (while (setq unit (pop units))
+ (unless (zerop (setq num (floor sec (cdr unit))))
+ (setq delay (append delay `((,num . ,(car unit))))))
+ (setq sec (mod sec (cdr unit))))))
+ (funcall gnus-diary-delay-format-function past delay))))
;; #### NOTE: Gnus sometimes gives me a HEADER not corresponding to any
;; message, with all fields set to nil here. I don't know what it is for, and
diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el
index e1686e0f7c1..ad1aa62a346 100644
--- a/lisp/gnus/gnus-draft.el
+++ b/lisp/gnus/gnus-draft.el
@@ -30,7 +30,6 @@
(require 'gnus-msg)
(require 'nndraft)
(require 'gnus-agent)
-(eval-when-compile (require 'cl))
;;; Draft minor mode
diff --git a/lisp/gnus/gnus-dup.el b/lisp/gnus/gnus-dup.el
index 8342ca86b67..4981614a17f 100644
--- a/lisp/gnus/gnus-dup.el
+++ b/lisp/gnus/gnus-dup.el
@@ -1,4 +1,4 @@
-;;; gnus-dup.el --- suppression of duplicate articles in Gnus
+;;; gnus-dup.el --- suppression of duplicate articles in Gnus -*- lexical-binding: t -*-
;; Copyright (C) 1996-2019 Free Software Foundation, Inc.
@@ -29,8 +29,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
-
(require 'gnus)
(require 'gnus-art)
@@ -46,7 +44,7 @@ seen in the same session."
:type 'boolean)
(defcustom gnus-duplicate-list-length 10000
- "The number of Message-IDs to keep in the duplicate suppression list."
+ "The maximum number of duplicate Message-IDs to keep track of."
:group 'gnus-duplicate
:type 'integer)
@@ -57,10 +55,14 @@ seen in the same session."
;;; Internal variables
-(defvar gnus-dup-list nil)
-(defvar gnus-dup-hashtb nil)
+(defvar gnus-dup-list nil
+ "List of seen message IDs, as strings.")
+
+(defvar gnus-dup-hashtb nil
+ "Hash table of seen message IDs, for fast lookup.")
-(defvar gnus-dup-list-dirty nil)
+(defvar gnus-dup-list-dirty nil
+ "Non-nil if `gnus-dup-list' needs to be saved.")
;;;
;;; Starting and stopping
@@ -80,10 +82,10 @@ seen in the same session."
(if gnus-save-duplicate-list
(gnus-dup-read)
(setq gnus-dup-list nil))
- (setq gnus-dup-hashtb (gnus-make-hashtable gnus-duplicate-list-length))
+ (setq gnus-dup-hashtb (gnus-make-hashtable))
;; Enter all Message-IDs into the hash table.
- (let ((obarray gnus-dup-hashtb))
- (mapc 'intern gnus-dup-list)))
+ (dolist (g gnus-dup-list)
+ (puthash g t gnus-dup-hashtb)))
(defun gnus-dup-read ()
"Read the duplicate suppression list."
@@ -105,7 +107,7 @@ seen in the same session."
(defun gnus-dup-enter-articles ()
"Enter articles from the current group for future duplicate suppression."
- (unless gnus-dup-list
+ (unless gnus-dup-hashtb
(gnus-dup-open))
(setq gnus-dup-list-dirty t) ; mark list for saving
(let (msgid)
@@ -118,29 +120,30 @@ seen in the same session."
(not (= (gnus-data-mark datum) gnus-canceled-mark))
(setq msgid (mail-header-id (gnus-data-header datum)))
(not (nnheader-fake-message-id-p msgid))
- (not (intern-soft msgid gnus-dup-hashtb)))
+ (not (gethash msgid gnus-dup-hashtb)))
(push msgid gnus-dup-list)
- (intern msgid gnus-dup-hashtb))))
- ;; Chop off excess Message-IDs from the list.
- (let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list)))
+ (puthash msgid t gnus-dup-hashtb))))
+ ;; Remove excess Message-IDs from the list and hash table.
+ (let* ((dups (cons nil gnus-dup-list))
+ (end (nthcdr gnus-duplicate-list-length dups)))
(when end
- (mapc (lambda (id) (unintern id gnus-dup-hashtb)) (cdr end))
- (setcdr end nil))))
+ (mapc (lambda (id) (remhash id gnus-dup-hashtb)) (cdr end))
+ (setcdr end nil))
+ (setq gnus-dup-list (cdr dups))))
(defun gnus-dup-suppress-articles ()
"Mark duplicate articles as read."
- (unless gnus-dup-list
+ (unless gnus-dup-hashtb
(gnus-dup-open))
(gnus-message 8 "Suppressing duplicates...")
(let ((auto (and gnus-newsgroup-auto-expire
(memq gnus-duplicate-mark gnus-auto-expirable-marks)))
number)
(dolist (header gnus-newsgroup-headers)
- (when (and (intern-soft (mail-header-id header) gnus-dup-hashtb)
- (gnus-summary-article-unread-p (mail-header-number header)))
- (setq gnus-newsgroup-unreads
- (delq (setq number (mail-header-number header))
- gnus-newsgroup-unreads))
+ (when (and (gethash (mail-header-id header) gnus-dup-hashtb)
+ (setq number (mail-header-number header))
+ (gnus-summary-article-unread-p number))
+ (setq gnus-newsgroup-unreads (delq number gnus-newsgroup-unreads))
(if (not auto)
(push (cons number gnus-duplicate-mark) gnus-newsgroup-reads)
(push number gnus-newsgroup-expirable)
@@ -149,12 +152,13 @@ seen in the same session."
(defun gnus-dup-unsuppress-article (article)
"Stop suppression of ARTICLE."
- (let* ((header (gnus-data-header (gnus-data-find article)))
- (id (when header (mail-header-id header))))
- (when id
+ (let (header id)
+ (when (and gnus-dup-hashtb
+ (setq header (gnus-data-header (gnus-data-find article)))
+ (setq id (mail-header-id header)))
(setq gnus-dup-list-dirty t)
(setq gnus-dup-list (delete id gnus-dup-list))
- (unintern id gnus-dup-hashtb))))
+ (remhash id gnus-dup-hashtb))))
(provide 'gnus-dup)
diff --git a/lisp/gnus/gnus-fun.el b/lisp/gnus/gnus-fun.el
index d57180fe5ad..8b710512be8 100644
--- a/lisp/gnus/gnus-fun.el
+++ b/lisp/gnus/gnus-fun.el
@@ -24,9 +24,6 @@
;;; Code:
-(eval-when-compile
- (require 'cl))
-
(require 'mm-util)
(require 'gnus-util)
(require 'gnus)
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el
index bcff8621925..0956dc46d05 100644
--- a/lisp/gnus/gnus-group.el
+++ b/lisp/gnus/gnus-group.el
@@ -24,10 +24,7 @@
;;; Code:
-(eval-when-compile
- (require 'cl))
-(defvar tool-bar-mode)
-
+(require 'cl-lib)
(require 'gnus)
(require 'gnus-start)
(require 'nnmail)
@@ -41,11 +38,14 @@
(eval-when-compile
(require 'mm-url)
+ (require 'subr-x)
(let ((features (cons 'gnus-group features)))
(require 'gnus-sum))
(unless (boundp 'gnus-cache-active-hashtb)
(defvar gnus-cache-active-hashtb nil)))
+(defvar tool-bar-mode)
+
(autoload 'gnus-agent-total-fetched-for "gnus-agent")
(autoload 'gnus-cache-total-fetched-for "gnus-cache")
@@ -497,7 +497,7 @@ simple manner."
(defvar gnus-tmp-number-of-unread)
(defvar gnus-group-line-format-alist
- `((?M gnus-tmp-marked-mark ?c)
+ '((?M gnus-tmp-marked-mark ?c)
(?S gnus-tmp-subscribed ?c)
(?L gnus-tmp-level ?d)
(?N (cond ((eq number t) "*" )
@@ -545,7 +545,7 @@ simple manner."
))
(defvar gnus-group-mode-line-format-alist
- `((?S gnus-tmp-news-server ?s)
+ '((?S gnus-tmp-news-server ?s)
(?M gnus-tmp-news-method ?s)
(?u gnus-tmp-user-defined ?s)
(?: gnus-tmp-colon ?s)))
@@ -568,8 +568,6 @@ simple manner."
;;; Gnus group mode
;;;
-(put 'gnus-group-mode 'mode-class 'special)
-
(gnus-define-keys gnus-group-mode-map
" " gnus-group-read-group
"=" gnus-group-select-group
@@ -783,7 +781,7 @@ simple manner."
(easy-menu-define
gnus-group-reading-menu gnus-group-mode-map ""
- `("Group"
+ '("Group"
["Read" gnus-group-read-group
:included (not (gnus-topic-mode-p))
:active (gnus-group-group-name)]
@@ -950,7 +948,7 @@ simple manner."
(easy-menu-define
gnus-group-misc-menu gnus-group-mode-map ""
- `("Gnus"
+ '("Gnus"
["Send a mail" gnus-group-mail t]
["Send a message (mail or news)" gnus-group-post-news t]
["Create a local message" gnus-group-news t]
@@ -1086,6 +1084,8 @@ See `gmm-tool-bar-from-list' for the format of the list."
(defvar image-load-path)
(defvar tool-bar-map)
+(declare-function image-load-path-for-library "image"
+ (library image &optional path no-error))
(defun gnus-group-make-tool-bar (&optional force)
"Make a group mode tool bar from `gnus-group-tool-bar'.
@@ -1105,9 +1105,8 @@ When FORCE, rebuild the tool bar."
(set (make-local-variable 'tool-bar-map) map))))
gnus-group-tool-bar-map)
-(define-derived-mode gnus-group-mode fundamental-mode "Group"
+(define-derived-mode gnus-group-mode gnus-mode "Group"
"Major mode for reading news.
-
All normal editing commands are switched off.
\\<gnus-group-mode-map>
The group buffer lists (some of) the groups available. For instance,
@@ -1130,8 +1129,7 @@ The following commands are available:
(setq mode-line-process nil)
(buffer-disable-undo)
(setq truncate-lines t)
- (setq buffer-read-only t
- show-trailing-whitespace nil)
+ (setq show-trailing-whitespace nil)
(gnus-set-default-directory)
(gnus-update-format-specifications nil 'group 'group-mode)
(gnus-update-group-mark-positions)
@@ -1145,14 +1143,14 @@ The following commands are available:
(let ((gnus-process-mark ?\200)
(gnus-group-update-hook nil)
(gnus-group-marked '("dummy.group"))
- (gnus-active-hashtb (make-vector 10 0)))
+ (gnus-active-hashtb (gnus-make-hashtable 10)))
(gnus-set-active "dummy.group" '(0 . 0))
(gnus-set-work-buffer)
(gnus-group-insert-group-line "dummy.group" 0 nil 0 nil)
(goto-char (point-min))
(setq gnus-group-mark-positions
(list (cons 'process (and (search-forward
- (string-to-multibyte "\200") nil t)
+ (string gnus-process-mark) nil t)
(- (point) (point-min) 1))))))))
(defun gnus-mouse-pick-group (e)
@@ -1189,6 +1187,9 @@ The following commands are available:
(unless (derived-mode-p 'gnus-group-mode)
(gnus-group-mode)))
+;; FIXME: If we never have to coerce group names to unibyte now, how
+;; much of this is necessary? How much encoding/decoding do we still
+;; have to do?
(defun gnus-group-name-charset (method group)
(unless method
(setq method (gnus-find-method-for-group group)))
@@ -1270,20 +1271,14 @@ Also see the `gnus-group-use-permanent-levels' variable."
;; has disappeared in the new listing, try to find the next
;; one. If no next one can be found, just leave point at the
;; first newsgroup in the buffer.
- (when (not (gnus-goto-char
- (text-property-any
- (point-min) (point-max)
- 'gnus-group (gnus-intern-safe
- group gnus-active-hashtb))))
- (let ((newsrc (cdddr (gnus-group-entry group))))
- (while (and newsrc
- (not (gnus-goto-char
- (text-property-any
- (point-min) (point-max) 'gnus-group
- (gnus-intern-safe
- (caar newsrc) gnus-active-hashtb)))))
- (setq newsrc (cdr newsrc)))
- (unless newsrc
+ (when (not (gnus-text-property-search
+ 'gnus-group group nil 'goto))
+ (let ((groups (cdr-safe (member group gnus-group-list))))
+ (while (and groups
+ (not (gnus-text-property-search
+ 'gnus-group (car groups) 'forward 'goto)))
+ (setq groups (cdr groups)))
+ (unless groups
(goto-char (point-max))
(forward-line -1)))))))
;; Adjust cursor point.
@@ -1316,7 +1311,6 @@ If REGEXP is a function, list dead groups that the function returns non-nil;
if it is a string, only list groups matching REGEXP."
(set-buffer gnus-group-buffer)
(let ((buffer-read-only nil)
- (newsrc (cdr gnus-newsrc-alist))
(lowest (or lowest 1))
(not-in-list (and gnus-group-listed-groups
(copy-sequence gnus-group-listed-groups)))
@@ -1324,12 +1318,11 @@ if it is a string, only list groups matching REGEXP."
(erase-buffer)
(when (or (< lowest gnus-level-zombie)
gnus-group-listed-groups)
- ;; List living groups.
- (while newsrc
- (setq info (car newsrc)
+ ;; List living groups, according to order in `gnus-group-list'.
+ (dolist (g (cdr gnus-group-list))
+ (setq info (gnus-get-info g)
group (gnus-info-group info)
params (gnus-info-params info)
- newsrc (cdr newsrc)
unread (gnus-group-unread group))
(when not-in-list
(setq not-in-list (delete group not-in-list)))
@@ -1359,6 +1352,8 @@ if it is a string, only list groups matching REGEXP."
(and gnus-permanently-visible-groups
(string-match gnus-permanently-visible-groups
group))
+ ;; Marked groups are always visible.
+ (member group gnus-group-marked)
(memq 'visible params)
(cdr (assq 'visible params)))))))
(gnus-group-insert-group-line
@@ -1394,39 +1389,35 @@ if it is a string, only list groups matching REGEXP."
;; List zombies and killed lists somewhat faster, which was
;; suggested by Jack Vinson <vinson@unagi.cis.upenn.edu>. It does
;; this by ignoring the group format specification altogether.
- (let (group)
- (if (> (length groups) gnus-group-listing-limit)
- (while groups
- (setq group (pop groups))
- (when (gnus-group-prepare-logic
- group
- (or (not regexp)
- (and (stringp regexp) (string-match regexp group))
- (and (functionp regexp) (funcall regexp group))))
- (add-text-properties
- (point) (prog1 (1+ (point))
- (insert " " mark " *: "
- (gnus-group-decoded-name group)
- "\n"))
- (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb)
- 'gnus-unread t
- 'gnus-level level))))
- (while groups
- (setq group (pop groups))
+ (if (nthcdr gnus-group-listing-limit groups)
+ (dolist (group groups)
(when (gnus-group-prepare-logic
group
- (or (not regexp)
- (and (stringp regexp) (string-match regexp group))
- (and (functionp regexp) (funcall regexp group))))
- (gnus-group-insert-group-line
- group level nil
- (let ((active (gnus-active group)))
- (if active
- (if (zerop (cdr active))
- 0
- (- (1+ (cdr active)) (car active)))
- nil))
- (gnus-method-simplify (gnus-find-method-for-group group))))))))
+ (cond ((not regexp))
+ ((stringp regexp) (string-match-p regexp group))
+ ((functionp regexp) (funcall regexp group))))
+ (add-text-properties
+ (point) (prog1 (1+ (point))
+ (insert " " mark " *: "
+ (gnus-group-decoded-name group)
+ "\n"))
+ (list 'gnus-group group
+ 'gnus-unread t
+ 'gnus-level level))))
+ (dolist (group groups)
+ (when (gnus-group-prepare-logic
+ group
+ (cond ((not regexp))
+ ((stringp regexp) (string-match-p regexp group))
+ ((functionp regexp) (funcall regexp group))))
+ (gnus-group-insert-group-line
+ group level nil
+ (let ((active (gnus-active group)))
+ (and active
+ (if (zerop (cdr active))
+ 0
+ (- (cdr active) (car active) -1))))
+ (gnus-method-simplify (gnus-find-method-for-group group)))))))
(defun gnus-group-update-group-line ()
"Update the current line in the group buffer."
@@ -1439,7 +1430,7 @@ if it is a string, only list groups matching REGEXP."
(not (gnus-ephemeral-group-p group))
(gnus-dribble-enter
(concat "(gnus-group-set-info '"
- (gnus-prin1-to-string (nth 2 entry))
+ (gnus-prin1-to-string (nth 1 entry))
")")
(concat "^(gnus-group-set-info '(\"" (regexp-quote group) "\"")))
(setq gnus-group-indentation (gnus-group-group-indentation))
@@ -1456,7 +1447,7 @@ if it is a string, only list groups matching REGEXP."
(if entry
(progn
;; (Un)subscribed group.
- (setq info (nth 2 entry))
+ (setq info (nth 1 entry))
(gnus-group-insert-group-line
group (gnus-info-level info) (gnus-info-marks info)
(or (car entry) t) (gnus-info-method info)))
@@ -1473,7 +1464,7 @@ if it is a string, only list groups matching REGEXP."
(gnus-method-simplify (gnus-find-method-for-group group))))))
(defun gnus-number-of-unseen-articles-in-group (group)
- (let* ((info (nth 2 (gnus-group-entry group)))
+ (let* ((info (nth 1 (gnus-group-entry group)))
(marked (gnus-info-marks info))
(seen (cdr (assq 'seen marked)))
(active (gnus-active group)))
@@ -1532,7 +1523,7 @@ if it is a string, only list groups matching REGEXP."
(int-to-string (max 0 (- gnus-tmp-number-total number)))
"*"))
(gnus-tmp-subscribed
- (cond ((<= gnus-tmp-level gnus-level-subscribed) ? )
+ (cond ((<= gnus-tmp-level gnus-level-subscribed) ?\s)
((<= gnus-tmp-level gnus-level-unsubscribed) ?U)
((= gnus-tmp-level gnus-level-zombie) ?Z)
(t ?K)))
@@ -1545,13 +1536,13 @@ if it is a string, only list groups matching REGEXP."
(gnus-tmp-newsgroup-description
(if gnus-description-hashtb
(or (gnus-group-name-decode
- (gnus-gethash gnus-tmp-group gnus-description-hashtb)
+ (gethash gnus-tmp-group gnus-description-hashtb)
group-name-charset) "")
""))
(gnus-tmp-moderated
(if (and gnus-moderated-hashtb
- (gnus-gethash gnus-tmp-group gnus-moderated-hashtb))
- ?m ? ))
+ (gethash gnus-tmp-group gnus-moderated-hashtb))
+ ?m ?\s))
(gnus-tmp-moderated-string
(if (eq gnus-tmp-moderated ?m) "(m)" ""))
(gnus-tmp-group-icon (gnus-group-get-icon gnus-tmp-group))
@@ -1565,18 +1556,18 @@ if it is a string, only list groups matching REGEXP."
(if (and (numberp number)
(zerop number)
(cdr (assq 'tick gnus-tmp-marked)))
- ?* ? ))
+ ?* ?\s))
(gnus-tmp-summary-live
(if (and (not gnus-group-is-exiting-p)
(gnus-buffer-live-p (gnus-summary-buffer-name
gnus-tmp-group)))
- ?* ? ))
+ ?* ?\s))
(gnus-tmp-process-marked
(if (member gnus-tmp-group gnus-group-marked)
- gnus-process-mark ? ))
+ gnus-process-mark ?\s))
(buffer-read-only nil)
beg end
- gnus-tmp-header) ; passed as parameter to user-funcs.
+ gnus-tmp-header) ; passed as parameter to user-funcs.
(beginning-of-line)
(setq beg (point))
(add-text-properties
@@ -1586,7 +1577,7 @@ if it is a string, only list groups matching REGEXP."
(let ((gnus-tmp-decoded-group (gnus-group-name-decode
gnus-tmp-group group-name-charset)))
(eval gnus-group-line-format-spec)))
- `(gnus-group ,(gnus-intern-safe gnus-tmp-group gnus-active-hashtb)
+ `(gnus-group ,gnus-tmp-group
gnus-unread ,(if (numberp number)
(string-to-number gnus-tmp-number-of-unread)
t)
@@ -1620,7 +1611,7 @@ Some value are bound so the form can use them."
(when list
(let* ((entry (gnus-group-entry group))
(active (gnus-active group))
- (info (nth 2 entry))
+ (info (nth 1 entry))
(method (inline (gnus-server-get-method
group (gnus-info-method info))))
(marked (gnus-info-marks info))
@@ -1691,9 +1682,7 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated."
;; The buffer may be narrowed.
(save-restriction
(widen)
- (let ((ident (gnus-intern-safe group gnus-active-hashtb))
- (loc (point-min))
- found buffer-read-only)
+ (let (found buffer-read-only)
(unless info-unchanged
;; Enter the current status into the dribble buffer.
(let ((entry (gnus-group-entry group)))
@@ -1701,37 +1690,33 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated."
(not (gnus-ephemeral-group-p group)))
(gnus-dribble-enter
(concat "(gnus-group-set-info '"
- (gnus-prin1-to-string (nth 2 entry))
+ (gnus-prin1-to-string (nth 1 entry))
")")
(concat "^(gnus-group-set-info '(\""
(regexp-quote group) "\"")))))
- ;; Find all group instances. If topics are in use, each group
- ;; may be listed in more than once.
- (while (setq loc (text-property-any
- loc (point-max) 'gnus-group ident))
+ ;; Find all group instances. If topics are in use, groups
+ ;; may be listed more than once.
+ (goto-char (point-min))
+ (while (gnus-text-property-search
+ 'gnus-group group 'forward 'goto)
(setq found t)
- (goto-char loc)
(let ((gnus-group-indentation (gnus-group-group-indentation)))
(gnus-delete-line)
(gnus-group-insert-group-line-info group)
(save-excursion
(forward-line -1)
- (gnus-run-hooks 'gnus-group-update-group-hook)))
- (setq loc (1+ loc)))
+ (gnus-run-hooks 'gnus-group-update-group-hook))))
(unless (or found visible-only)
;; No such line in the buffer, find out where it's supposed to
;; go, and insert it there (or at the end of the buffer).
(if gnus-goto-missing-group-function
(funcall gnus-goto-missing-group-function group)
- (let ((entry (cddr (gnus-group-entry group))))
- (while (and entry (car entry)
+ (let ((entry (cdr (member group gnus-group-list))))
+ (goto-char (point-min))
+ (while (and (car-safe entry)
(not
- (gnus-goto-char
- (text-property-any
- (point-min) (point-max)
- 'gnus-group (gnus-intern-safe
- (caar entry)
- gnus-active-hashtb)))))
+ (gnus-text-property-search
+ 'gnus-group (car entry) 'forward 'goto)))
(setq entry (cdr entry)))
(or entry (goto-char (point-max)))))
;; Finally insert the line.
@@ -1779,10 +1764,8 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated."
(defun gnus-group-group-name ()
"Get the name of the newsgroup on the current line."
(let ((group (get-text-property (point-at-bol) 'gnus-group)))
- (when group
- (if (stringp group)
- group
- (symbol-name group)))))
+ (cond ((stringp group) group)
+ (group (symbol-name group)))))
(defun gnus-group-group-level ()
"Get the level of the newsgroup on the current line."
@@ -1802,7 +1785,7 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated."
(defun gnus-group-new-mail (group)
(if (nnmail-new-mail-p (gnus-group-real-name group))
gnus-new-mail-mark
- ? ))
+ ?\s))
(defun gnus-group-level (group)
"Return the estimated level of GROUP."
@@ -1892,13 +1875,13 @@ If FIRST-TOO, the current line is also eligible as a target."
(if unmark
(progn
(setq gnus-group-marked (delete group gnus-group-marked))
- (insert-char ? 1 t))
+ (insert-char ?\s 1 t))
(setq gnus-group-marked
(cons group (delete group gnus-group-marked)))
(insert-char gnus-process-mark 1 t)))
(unless no-advance
(gnus-group-next-group 1))
- (decf n))
+ (cl-decf n))
(gnus-group-position-point)
n))
@@ -2063,7 +2046,7 @@ that group."
(unless group
(error "No group on current line"))
(setq marked (gnus-info-marks
- (nth 2 (setq entry (gnus-group-entry group)))))
+ (nth 1 (setq entry (gnus-group-entry group)))))
;; This group might be a dead group. In that case we have to get
;; the number of unread articles from `gnus-active-hashtb'.
(setq number
@@ -2138,6 +2121,7 @@ be permanent."
(let ((group (gnus-group-group-name)))
(when group
(gnus-group-decoded-name group)))
+ ;; FIXME: Use rx.
(let ((regexp "[][\C-@-\t\v-*,/:-@\\^`{-\C-?]*\
\\(nn[a-z]+\\(?:\\+[^][\C-@-*,/:-@\\^`{-\C-?]+\\)?:\
[^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)*\
@@ -2176,34 +2160,39 @@ be permanent."
(defun gnus-group-completing-read (&optional prompt collection
require-match initial-input hist
def)
- "Read a group name with completion. Non-ASCII group names are allowed.
-The arguments are the same as `completing-read' except that COLLECTION
-and HIST default to `gnus-active-hashtb' and `gnus-group-history'
-respectively if they are omitted. Regards COLLECTION as a hash table
-if it is not a list."
+ "Read a group name with completion.
+Non-ASCII group names are allowed. The arguments are the same as
+`completing-read' except that COLLECTION and HIST default to
+`gnus-active-hashtb' and `gnus-group-history' respectively if
+they are omitted. Can handle COLLECTION as a list, hash table,
+or vector."
(or collection (setq collection gnus-active-hashtb))
- (let (choices group)
- (if (listp collection)
- (dolist (symbol collection)
- (setq group (symbol-name symbol))
- (push (if (string-match "[^\000-\177]" group)
- (gnus-group-decoded-name group)
- group)
- choices))
- (mapatoms (lambda (symbol)
- (setq group (symbol-name symbol))
- (push (if (string-match "[^\000-\177]" group)
- (gnus-group-decoded-name group)
- group)
- choices))
- collection))
- (setq group (gnus-completing-read (or prompt "Group") (nreverse choices)
- require-match initial-input
- (or hist 'gnus-group-history)
- def))
- (unless (if (listp collection)
- (member group (mapcar 'symbol-name collection))
- (symbol-value (intern-soft group collection)))
+ (let* ((choices
+ (mapcar
+ (lambda (g)
+ (if (string-match "[^\000-\177]" g)
+ (gnus-group-decoded-name g)
+ g))
+ (cond ((listp collection)
+ collection)
+ ((vectorp collection)
+ (mapatoms #'symbol-name collection))
+ ((hash-table-p collection)
+ (hash-table-keys collection)))))
+ (group
+ (gnus-completing-read (or prompt "Group") (reverse choices)
+ require-match initial-input
+ (or hist 'gnus-group-history)
+ def)))
+ (unless (cond ((and (listp collection)
+ (symbolp (car collection)))
+ (member group (mapcar 'symbol-name collection)))
+ ((listp collection)
+ (member group collection))
+ ((vectorp collection)
+ (symbol-value (intern-soft group collection)))
+ ((hash-table-p collection)
+ (gethash group collection)))
(setq group
(encode-coding-string
group (gnus-group-name-charset nil group))))
@@ -2281,7 +2270,8 @@ Return the name of the group if selection was successful."
(nnheader-init-server-buffer)
;; Necessary because of funky inlining.
(require 'gnus-cache)
- (setq gnus-newsrc-hashtb (gnus-make-hashtable)))
+ (setq gnus-newsrc-hashtb (gnus-make-hashtable 100)
+ gnus-active-hashtb (gnus-make-hashtable 100)))
;; Transform the select method into a unique server.
(when (stringp method)
(setq method (gnus-server-to-method method)))
@@ -2298,23 +2288,23 @@ Return the name of the group if selection was successful."
(gnus-group-prefixed-name (gnus-group-real-name group)
method))))
(gnus-set-active group nil)
- (gnus-sethash
+ (puthash
group
- `(-1 nil (,group
- ,gnus-level-default-subscribed nil nil ,method
- ,(cons
- (cons 'quit-config
- (cond
- (quit-config
- quit-config)
- ((assq gnus-current-window-configuration
- gnus-buffer-configuration)
- (cons gnus-summary-buffer
- gnus-current-window-configuration))
- (t
- (cons (current-buffer)
- (current-window-configuration)))))
- parameters)))
+ `(-1 (,group
+ ,gnus-level-default-subscribed nil nil ,method
+ ,(cons
+ (cons 'quit-config
+ (cond
+ (quit-config
+ quit-config)
+ ((assq gnus-current-window-configuration
+ gnus-buffer-configuration)
+ (cons gnus-summary-buffer
+ gnus-current-window-configuration))
+ (t
+ (cons (current-buffer)
+ (current-window-configuration)))))
+ parameters)))
gnus-newsrc-hashtb)
(push method gnus-ephemeral-servers)
(when (gnus-buffer-live-p gnus-group-buffer)
@@ -2548,65 +2538,68 @@ If PROMPT (the prefix) is a number, use the prompt specified in
(when (equal group "")
(error "Empty group name"))
- (unless (gnus-ephemeral-group-p group)
- ;; Either go to the line in the group buffer...
- (unless (gnus-group-goto-group group)
- ;; ... or insert the line.
- (gnus-group-update-group group)
- (gnus-group-goto-group group)))
- ;; Adjust cursor point.
- (gnus-group-position-point))
+ (prog1
+ (unless (gnus-ephemeral-group-p group)
+ ;; Either go to the line in the group buffer...
+ (unless (gnus-group-goto-group group)
+ ;; ... or insert the line.
+ (gnus-group-update-group group)
+ (gnus-group-goto-group group)))
+ ;; Adjust cursor point.
+ (gnus-group-position-point)))
(defun gnus-group-goto-group (group &optional far test-marked)
"Goto to newsgroup GROUP.
If FAR, it is likely that the group is not on the current line.
If TEST-MARKED, the line must be marked."
(when group
- (beginning-of-line)
- (cond
- ;; It's quite likely that we are on the right line, so
- ;; we check the current line first.
- ((and (not far)
- (eq (get-text-property (point) 'gnus-group)
- (gnus-intern-safe group gnus-active-hashtb))
- (or (not test-marked) (gnus-group-mark-line-p)))
- (point))
- ;; Previous and next line are also likely, so we check them as well.
- ((and (not far)
- (save-excursion
- (forward-line -1)
- (and (eq (get-text-property (point) 'gnus-group)
- (gnus-intern-safe group gnus-active-hashtb))
- (or (not test-marked) (gnus-group-mark-line-p)))))
- (forward-line -1)
- (point))
- ((and (not far)
- (save-excursion
- (forward-line 1)
- (and (eq (get-text-property (point) 'gnus-group)
- (gnus-intern-safe group gnus-active-hashtb))
- (or (not test-marked) (gnus-group-mark-line-p)))))
- (forward-line 1)
- (point))
- (test-marked
- (goto-char (point-min))
- (let (found)
- (while (and (not found)
- (gnus-goto-char
- (text-property-any
- (point) (point-max)
- 'gnus-group
- (gnus-intern-safe group gnus-active-hashtb))))
- (if (gnus-group-mark-line-p)
- (setq found t)
- (forward-line 1)))
- found))
- (t
- ;; Search through the entire buffer.
- (gnus-goto-char
- (text-property-any
- (point-min) (point-max)
- 'gnus-group (gnus-intern-safe group gnus-active-hashtb)))))))
+ (let ((start (point))
+ (active (and (or
+ ;; Some kind of group may be only there.
+ (gnus-active group)
+ ;; All groups (but with exception) are there.
+ (gnus-group-entry group))
+ group)))
+ (beginning-of-line)
+ (cond
+ ;; It's quite likely that we are on the right line, so
+ ;; we check the current line first.
+ ((and (not far)
+ (equal (get-text-property (point) 'gnus-group) active)
+ (or (not test-marked) (gnus-group-mark-line-p)))
+ (point))
+ ;; Previous and next line are also likely, so we check them as well.
+ ((and (not far)
+ (save-excursion
+ (forward-line -1)
+ (and (equal (get-text-property (point) 'gnus-group) active)
+ (or (not test-marked) (gnus-group-mark-line-p)))))
+ (forward-line -1)
+ (point))
+ ((and (not far)
+ (save-excursion
+ (forward-line 1)
+ (and (equal (get-text-property (point) 'gnus-group) active)
+ (or (not test-marked) (gnus-group-mark-line-p)))))
+ (forward-line 1)
+ (point))
+ (test-marked
+ (goto-char (point-min))
+ (let (found)
+ (while (and (not found)
+ (gnus-text-property-search
+ 'gnus-group active 'forward 'goto))
+ (if (gnus-group-mark-line-p)
+ (setq found t)
+ (forward-line 1)))
+ found))
+ (t
+ ;; Search through the entire buffer.
+ (if (gnus-text-property-search
+ 'gnus-group active nil 'goto)
+ (point)
+ (goto-char start)
+ nil))))))
(defun gnus-group-next-group (n &optional silent)
"Go to next N'th newsgroup.
@@ -2771,9 +2764,7 @@ server."
(gnus-group-change-level
(setq info (list t nname gnus-level-default-subscribed nil nil meth))
gnus-level-default-subscribed gnus-level-killed
- (and (gnus-group-group-name)
- (gnus-group-entry (gnus-group-group-name)))
- t)
+ (gnus-group-group-name) t)
;; Make it active.
(gnus-set-active nname (cons 1 0))
(unless (gnus-ephemeral-group-p name)
@@ -2833,6 +2824,7 @@ If FORCE (the prefix) is non-nil, all the articles in the group will
be deleted. This is \"deleted\" as in \"removed forever from the face
of the Earth\". There is no undo. The user will be prompted before
doing the deletion.
+
Note that you also have to specify FORCE if you want the group to
be removed from the server, even when it's empty."
(interactive
@@ -2844,12 +2836,11 @@ be removed from the server, even when it's empty."
(error "This back end does not support group deletion"))
(prog1
(let ((group-decoded (gnus-group-decoded-name group)))
- (if (and (not no-prompt)
- (not (gnus-yes-or-no-p
- (format
- "Do you really want to delete %s%s? "
- group-decoded (if force " and all its contents" "")))))
- () ; Whew!
+ (when (or no-prompt
+ (gnus-yes-or-no-p
+ (format
+ "Do you really want to delete %s%s? "
+ group-decoded (if force " and all its contents" ""))))
(gnus-message 6 "Deleting group %s..." group-decoded)
(if (not (gnus-request-delete-group group force))
(gnus-error 3 "Couldn't delete group %s" group-decoded)
@@ -2998,7 +2989,7 @@ and NEW-NAME will be prompted for."
;; Set the info.
(if (not (and info new-group))
(gnus-group-set-info form (or new-group group) part)
- (setq info (gnus-copy-sequence info))
+ (setq info (copy-tree info))
(setcar info new-group)
(unless (gnus-server-equal method "native")
(unless (nthcdr 3 info)
@@ -3021,7 +3012,7 @@ and NEW-NAME will be prompted for."
;; Don't use `caddr' here since macros within the `interactive'
;; form won't be expanded.
(car (cddr entry)))))
- (setq method (gnus-copy-sequence method))
+ (setq method (copy-tree method))
(let (entry)
(while (setq entry (memq (assq 'eval method) method))
(setcar entry (eval (cadar entry)))))
@@ -3230,7 +3221,7 @@ mail messages or news articles in files that have numeric names."
;; Subscribe the new group after the group on the current line.
(gnus-subscribe-group pgroup (gnus-group-group-name) method)
(gnus-group-update-group pgroup)
- (forward-line -1)
+ (forward-line)
(gnus-group-position-point)))
(defun gnus-group-enter-directory (dir)
@@ -3553,7 +3544,7 @@ Obeys the process/prefix convention."
(gnus-request-set-mark ,group ',action)
(gnus-info-set-marks ',info ',(gnus-info-marks info) t)
(gnus-info-set-read ',info ',(gnus-info-read info))
- (when (gnus-group-goto-group ,group)
+ (when (gnus-group-jump-to-group ,group)
(gnus-get-unread-articles-in-group ',info ',(gnus-active group) t)
(gnus-group-update-group-line))))
(setq action (mapcar (lambda (el) (list (nth 0 el) 'del (nth 2 el)))
@@ -3623,7 +3614,7 @@ The return value is the number of articles that were marked as read,
or nil if no action could be taken."
(let* ((entry (gnus-group-entry group))
(num (car entry))
- (marks (gnus-info-marks (nth 2 entry)))
+ (marks (gnus-info-marks (nth 1 entry)))
(unread (gnus-sequence-of-unread-articles group)))
;; Remove entries for this group.
(nnmail-purge-split-history (gnus-group-real-name group))
@@ -3805,8 +3796,7 @@ group line."
(or (and (member group gnus-zombie-list)
gnus-level-zombie)
gnus-level-killed)
- (when (gnus-group-group-name)
- (gnus-group-entry (gnus-group-group-name))))
+ (gnus-group-group-name))
(unless silent
(gnus-group-update-group group)))
(t (error "No such newsgroup: %s" group)))
@@ -3877,10 +3867,12 @@ of groups killed."
`(progn
(gnus-group-goto-group ,(gnus-group-group-name))
(gnus-group-yank-group)))
- (push (cons (car entry) (nth 2 entry))
+ (push (cons (car entry) (nth 1 entry))
gnus-list-of-killed-groups))
(gnus-group-change-level
(if entry entry group) gnus-level-killed (if entry nil level))
+ ;; FIXME: Since the group has already been removed from
+ ;; `gnus-newsrc-hashtb', this check will always return nil.
(when (numberp (gnus-group-unread group))
(gnus-request-update-group-status group 'unsubscribe))
(message "Killed group %s" (gnus-group-decoded-name group)))
@@ -3898,7 +3890,7 @@ of groups killed."
group gnus-level-killed 3))
(cond
((setq entry (gnus-group-entry group))
- (push (cons (car entry) (nth 2 entry))
+ (push (cons (car entry) (nth 1 entry))
gnus-list-of-killed-groups)
(setcdr (cdr entry) (cdddr entry)))
((member group gnus-zombie-list)
@@ -3921,7 +3913,7 @@ yanked) a list of yanked groups is returned."
(interactive "p")
(setq arg (or arg 1))
(let (info group prev out)
- (while (>= (decf arg) 0)
+ (while (>= (cl-decf arg) 0)
(when (not (setq info (pop gnus-list-of-killed-groups)))
(error "No more newsgroups to yank"))
(push (setq group (nth 1 info)) out)
@@ -3931,9 +3923,7 @@ yanked) a list of yanked groups is returned."
;; first newsgroup.
(setq prev (gnus-group-group-name))
(gnus-group-change-level
- info (gnus-info-level (cdr info)) gnus-level-killed
- (and prev (gnus-group-entry prev))
- t)
+ info (gnus-info-level (cdr info)) gnus-level-killed prev t)
(gnus-group-insert-group-line-info group)
(gnus-request-update-group-status group 'subscribe)
(gnus-undo-register
@@ -4017,28 +4007,15 @@ entail asking the server for the groups."
(gnus-agent gnus-plugged)); If we're actually plugged, store the active file in the agent.
(gnus-read-active-file)))
;; Find all groups and sort them.
- (let ((groups
- (sort
- (let (list)
- (mapatoms
- (lambda (sym)
- (and (boundp sym)
- (symbol-value sym)
- (push (symbol-name sym) list)))
- gnus-active-hashtb)
- list)
- 'string<))
- (buffer-read-only nil)
- group)
+ (let ((buffer-read-only nil))
(erase-buffer)
- (while groups
- (setq group (pop groups))
+ (dolist (group (sort (hash-table-keys gnus-active-hashtb) #'string<))
(add-text-properties
(point) (prog1 (1+ (point))
(insert " *: "
(gnus-group-decoded-name group)
"\n"))
- (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb)
+ (list 'gnus-group group
'gnus-unread t
'gnus-level (inline (gnus-group-level group)))))
(goto-char (point-min))))
@@ -4102,9 +4079,14 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
(gnus-group-remove-mark group)
;; Bypass any previous denials from the server.
(gnus-remove-denial (setq method (gnus-find-method-for-group group)))
- (if (or (and (not dont-scan)
- (gnus-request-group-scan group (gnus-get-info group)))
- (gnus-activate-group group (if dont-scan nil 'scan) nil method))
+ (if (if (and (not dont-scan)
+ ;; Prefer request-group-scan if the backend supports it.
+ (gnus-check-backend-function 'request-group-scan group))
+ (progn
+ ;; Ensure that the server is already open.
+ (gnus-activate-group group nil nil method)
+ (gnus-request-group-scan group (gnus-get-info group)))
+ (gnus-activate-group group (if dont-scan nil 'scan) nil method))
(let ((info (gnus-get-info group))
(active (gnus-active group)))
(when info
@@ -4117,6 +4099,7 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
method (gnus-group-real-name group) active))
(gnus-group-update-group group nil t))
(gnus-error 3 "%s error: %s" group (gnus-status-message group))))
+ (gnus-run-hooks 'gnus-after-getting-new-news-hook)
(when beg
(goto-char beg))
(when gnus-goto-next-group-when-activating
@@ -4132,17 +4115,17 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
desc)
(when (and force
gnus-description-hashtb)
- (gnus-sethash mname nil gnus-description-hashtb))
+ (remhash mname gnus-description-hashtb))
(unless group
(error "No group name given"))
(when (or (and gnus-description-hashtb
;; We check whether this group's method has been
;; queried for a description file.
- (gnus-gethash mname gnus-description-hashtb))
+ (gethash mname gnus-description-hashtb))
(setq desc (gnus-group-get-description group))
(gnus-read-descriptions-file method))
(gnus-message 1 "%s"
- (or desc (gnus-gethash group gnus-description-hashtb)
+ (or desc (gethash group gnus-description-hashtb)
"No description available")))))
;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
@@ -4155,12 +4138,8 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
(gnus-read-all-descriptions-files)))
(error "Couldn't request descriptions file"))
(let ((buffer-read-only nil)
- b groups)
- (mapatoms
- (lambda (group)
- (push (symbol-name group) groups))
- gnus-description-hashtb)
- (setq groups (sort groups 'string<))
+ (groups (sort (hash-table-keys gnus-description-hashtb)))
+ b)
(erase-buffer)
(dolist (group groups)
(setq b (point))
@@ -4183,20 +4162,16 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
(obuf (current-buffer))
groups des)
;; Go through all newsgroups that are known to Gnus.
- (mapatoms
- (lambda (group)
- (and (symbol-name group)
- (string-match regexp (symbol-name group))
- (symbol-value group)
- (push (symbol-name group) groups)))
+ (maphash
+ (lambda (g-name _)
+ (and (string-match regexp g-name)
+ (push g-name groups)))
gnus-active-hashtb)
;; Also go through all descriptions that are known to Gnus.
(when search-description
- (mapatoms
- (lambda (group)
- (and (string-match regexp (symbol-value group))
- (push (symbol-name group) groups)))
- gnus-description-hashtb))
+ (dolist (g-name (hash-table-keys gnus-description-hashtb))
+ (when (string-match regexp g-name)
+ (push g-name groups))))
(if (not groups)
(gnus-message 3 "No groups matched \"%s\"." regexp)
;; Print out all the groups.
@@ -4212,8 +4187,8 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
(let ((charset (gnus-group-name-charset nil prev)))
(insert (gnus-group-name-decode prev charset) "\n")
(when (and gnus-description-hashtb
- (setq des (gnus-gethash (car groups)
- gnus-description-hashtb)))
+ (setq des (gethash (car groups)
+ gnus-description-hashtb)))
(insert " " (gnus-group-name-decode des charset) "\n"))))
(setq groups (cdr groups)))
(goto-char (point-min))))
@@ -4367,6 +4342,9 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting."
gnus-expert-user
(gnus-y-or-n-p "Are you sure you want to quit reading news? "))
(gnus-run-hooks 'gnus-exit-gnus-hook)
+ ;; Check whether we have any unsaved Message buffers and offer to
+ ;; save them.
+ (gnus--abort-on-unsaved-message-buffers)
;; Offer to save data from non-quitted summary buffers.
(gnus-offer-save-summaries)
;; Save the newsrc file(s).
@@ -4378,6 +4356,18 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting."
;; Allow the user to do things after cleaning up.
(gnus-run-hooks 'gnus-after-exiting-gnus-hook)))
+(defun gnus--abort-on-unsaved-message-buffers ()
+ (dolist (buffer (gnus-buffers))
+ (when (gnus-buffer-exists-p buffer)
+ (with-current-buffer buffer
+ (when (and (derived-mode-p 'message-mode)
+ (buffer-modified-p)
+ (not (y-or-n-p
+ (format "Message buffer %s unsaved, continue exit? "
+ (buffer-name)))))
+ (error "Gnus exit aborted due to unsaved %s buffer"
+ (buffer-name)))))))
+
(defun gnus-group-quit ()
"Quit reading news without updating .newsrc.eld or .newsrc.
The hook `gnus-exit-gnus-hook' is called before actually exiting."
@@ -4443,7 +4433,7 @@ and the second element is the address."
(let* ((entry (gnus-group-entry
(or method-only-group (gnus-info-group info))))
(part-info info)
- (info (if method-only-group (nth 2 entry) info))
+ (info (if method-only-group (nth 1 entry) info))
method)
(when method-only-group
(unless entry
@@ -4485,7 +4475,7 @@ and the second element is the address."
;; can do the update.
(if entry
(progn
- (setcar (nthcdr 2 entry) info)
+ (setcar (nthcdr 1 entry) info)
(when (and (not (eq (car entry) t))
(gnus-active (gnus-info-group info)))
(setcar entry (length
@@ -4553,8 +4543,7 @@ and the second element is the address."
This function can be used in hooks like `gnus-select-group-hook'
or `gnus-group-catchup-group-hook'."
(when gnus-newsgroup-name
- (let ((time (current-time)))
- (setcdr (cdr time) nil)
+ (let ((time (encode-time nil 'integer)))
(gnus-group-set-parameter gnus-newsgroup-name 'timestamp time))))
(defsubst gnus-group-timestamp (group)
@@ -4563,11 +4552,11 @@ or `gnus-group-catchup-group-hook'."
(defun gnus-group-timestamp-delta (group)
"Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number."
- (let* ((time (or (gnus-group-timestamp group)
- (list 0 0)))
- (delta (time-subtract (current-time) time)))
- (+ (* (nth 0 delta) 65536.0)
- (nth 1 delta))))
+ ;; FIXME: This should return a Lisp integer, not a Lisp float,
+ ;; since it is always an integer.
+ (let* ((time (or (gnus-group-timestamp group) 0))
+ (delta (time-since time)))
+ (float-time delta)))
(defun gnus-group-timestamp-string (group)
"Return a string of the timestamp for GROUP."
@@ -4595,11 +4584,11 @@ This command may read the active file."
(assq 'cache marks)))
lowest
#'(lambda (group)
- (or (gnus-gethash group
- gnus-cache-active-hashtb)
+ (or (gethash group
+ gnus-cache-active-hashtb)
;; Cache active file might use "."
;; instead of ":".
- (gnus-gethash
+ (gethash
(mapconcat 'identity
(split-string group ":")
".")
diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el
index 964bda46c17..f36c3897876 100644
--- a/lisp/gnus/gnus-html.el
+++ b/lisp/gnus/gnus-html.el
@@ -28,8 +28,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
-
(require 'gnus-art)
(eval-when-compile (require 'mm-decode))
@@ -99,11 +97,7 @@ fit these criteria."
(not (file-exists-p (url-cache-create-filename url))))
(t (let ((cache-time (url-is-cached url)))
(if cache-time
- (time-less-p
- (time-add
- cache-time
- ttl)
- (current-time))
+ (time-less-p (time-add cache-time ttl) nil)
t)))))
;;;###autoload
diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el
index f79ce368437..28020a1fd0b 100644
--- a/lisp/gnus/gnus-icalendar.el
+++ b/lisp/gnus/gnus-icalendar.el
@@ -1,4 +1,4 @@
-;;; gnus-icalendar.el --- reply to iCalendar meeting requests
+;;; gnus-icalendar.el --- reply to iCalendar meeting requests -*- lexical-binding:t -*-
;; Copyright (C) 2013-2019 Free Software Foundation, Inc.
@@ -40,7 +40,7 @@
(require 'gnus-sum)
(require 'gnus-art)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defun gnus-icalendar-find-if (pred seq)
(catch 'found
@@ -147,7 +147,7 @@
(icalendar--get-event-property-attributes
event field) zone-map))
(dtdate-dec (icalendar--decode-isodatetime dtdate nil dtdate-zone)))
- (apply 'encode-time dtdate-dec)))
+ (encode-time dtdate-dec)))
(defun gnus-icalendar-event--find-attendee (ical name-or-email)
(let* ((event (car (icalendar--all-events ical)))
@@ -169,7 +169,7 @@
(defun gnus-icalendar-event--get-attendee-names (ical)
(let* ((event (car (icalendar--all-events ical)))
- (attendee-props (gnus-remove-if-not
+ (attendee-props (seq-filter
(lambda (p) (eq (car p) 'ATTENDEE))
(caddr event))))
@@ -180,7 +180,7 @@
(or (plist-get (cadr prop) 'CN)
(replace-regexp-in-string "^.*MAILTO:" "" (caddr prop))))
(attendees-by-type (type)
- (gnus-remove-if-not
+ (seq-filter
(lambda (p) (string= (attendee-role p) type))
attendee-props))
(attendee-names-by-type
@@ -238,13 +238,13 @@
"\\\\n" "\n" (substring-no-properties value))))))
(accumulate-args
(mapping)
- (destructuring-bind (slot . ical-property) mapping
+ (cl-destructuring-bind (slot . ical-property) mapping
(setq args (append (list
(intern (concat ":" (symbol-name slot)))
(map-property ical-property))
args)))))
(mapc #'accumulate-args prop-map)
- (apply 'make-instance event-class args))))
+ (apply #'make-instance event-class args))))
(defun gnus-icalendar-event-from-buffer (buf &optional attendee-name-or-email)
"Parse RFC5545 iCalendar in buffer BUF and return an event object.
@@ -301,7 +301,8 @@ status will be retrieved from the first matching attendee record."
((string= key "DTSTAMP") (update-dtstamp))
((member key '("ORGANIZER" "DTSTART" "DTEND"
"LOCATION" "DURATION" "SEQUENCE"
- "RECURRENCE-ID" "UID")) line)
+ "RECURRENCE-ID" "UID"))
+ line)
(t nil))))
(when new-line
(push new-line reply-event-lines))))))
@@ -352,9 +353,9 @@ on the IDENTITIES list."
;;;
;;; gnus-icalendar-org
-;;;
-;;; TODO: this is an optional feature, and it's only available with org-mode
-;;; 7+, so will need to properly handle emacsen with no/outdated org-mode
+;;
+;; TODO: this is an optional feature, and it's only available with org-mode
+;; 7+, so will need to properly handle emacsen with no/outdated org-mode
(require 'org)
(require 'org-capture)
@@ -367,23 +368,19 @@ on the IDENTITIES list."
(defcustom gnus-icalendar-org-capture-file nil
"Target Org file for storing captured calendar events."
- :type '(choice (const nil) file)
- :group 'gnus-icalendar-org)
+ :type '(choice (const nil) file))
(defcustom gnus-icalendar-org-capture-headline nil
"Target outline in `gnus-icalendar-org-capture-file' for storing captured events."
- :type '(repeat string)
- :group 'gnus-icalendar-org)
+ :type '(repeat string))
(defcustom gnus-icalendar-org-template-name "used by gnus-icalendar-org"
"Org-mode template name."
- :type '(string)
- :group 'gnus-icalendar-org)
+ :type '(string))
(defcustom gnus-icalendar-org-template-key "#"
"Org-mode template hotkey."
- :type '(string)
- :group 'gnus-icalendar-org)
+ :type '(string))
(defvar gnus-icalendar-org-enabled-p nil)
@@ -413,13 +410,12 @@ Return nil for non-recurring EVENT."
(end-time (format-time-string "%H:%M" end))
(end-at-midnight (string= end-time "00:00"))
(start-end-date-diff
- (/ (float-time (time-subtract
- (org-time-string-to-time end-date)
- (org-time-string-to-time start-date)))
- 86400))
+ (time-to-number-of-days (time-subtract
+ (org-time-string-to-time end-date)
+ (org-time-string-to-time start-date))))
(org-repeat (gnus-icalendar-event:org-repeat event))
(repeat (if org-repeat (concat " " org-repeat) ""))
- (time-1-day '(0 86400)))
+ (time-1-day 86400))
;; NOTE: special care is needed with appointments ending at midnight
;; (typically all-day events): the end time has to be changed to 23:59 to
@@ -443,7 +439,7 @@ Return nil for non-recurring EVENT."
;; A 0:0 - A .:. -> A 0:0-.:. (default 1)
;; A 0:0 - A+n .:. -> A - A+n .:.
((and start-at-midnight
- (plusp start-end-date-diff)) (format "<%s>--<%s %s>" start-date end-date end-time))
+ (cl-plusp start-end-date-diff)) (format "<%s>--<%s %s>" start-date end-date end-time))
;; default
;; A .:. - A .:. -> A .:.-.:.
;; A .:. - B .:.
@@ -655,10 +651,7 @@ is searched."
(defun gnus-icalendar-show-org-agenda (event)
(let* ((time-delta (time-subtract (gnus-icalendar-event:end-time event)
(gnus-icalendar-event:start-time event)))
- (duration-days (1+ (/ (+ (* (car time-delta) (expt 2 16))
- (cadr time-delta))
- 86400))))
-
+ (duration-days (1+ (floor (encode-time time-delta 'integer) 86400))))
(org-agenda-list nil (gnus-icalendar-event:start event) duration-days)))
(cl-defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-request) reply-status)
@@ -666,7 +659,7 @@ is searched."
(gnus-icalendar--update-org-event event reply-status)
(gnus-icalendar:org-event-save event reply-status)))
-(cl-defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-cancel) reply-status)
+(cl-defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-cancel) _reply-status)
(when (gnus-icalendar-find-org-event-file event)
(gnus-icalendar--cancel-org-event event)))
@@ -689,8 +682,7 @@ is searched."
(defcustom gnus-icalendar-reply-bufname "*CAL*"
"Buffer used for building iCalendar invitation reply."
- :type '(string)
- :group 'gnus-icalendar)
+ :type '(string))
(defcustom gnus-icalendar-additional-identities nil
"We need to know your identity to make replies to calendar requests work.
@@ -706,17 +698,13 @@ Your identity is guessed automatically from the variables
If you need even more aliases you can define them here. It really
only makes sense to define names or email addresses."
- :type '(repeat string)
- :group 'gnus-icalendar)
+ :type '(repeat string))
-(make-variable-buffer-local
- (defvar gnus-icalendar-reply-status nil))
+(defvar-local gnus-icalendar-reply-status nil)
-(make-variable-buffer-local
- (defvar gnus-icalendar-event nil))
+(defvar-local gnus-icalendar-event nil)
-(make-variable-buffer-local
- (defvar gnus-icalendar-handle nil))
+(defvar-local gnus-icalendar-handle nil)
(defun gnus-icalendar-identities ()
"Return list of regexp-quoted names and email addresses belonging to the user.
@@ -742,7 +730,8 @@ These will be used to retrieve the RSVP information from ical events."
(cadr x))))
(with-slots (organizer summary description location recur uid
- method rsvp participation-type) event
+ method rsvp participation-type)
+ event
(let ((headers `(("Summary" ,summary)
("Location" ,(or location ""))
("Time" ,(gnus-icalendar-event:org-timestamp event))
@@ -848,7 +837,7 @@ These will be used to retrieve the RSVP information from ical events."
("Tentative" gnus-icalendar-reply (,handle tentative ,event))
("Decline" gnus-icalendar-reply (,handle declined ,event)))))
-(cl-defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event-reply) handle)
+(cl-defmethod gnus-icalendar-event:inline-reply-buttons ((_event gnus-icalendar-event-reply) _handle)
"No buttons for REPLY events."
nil)
@@ -857,7 +846,7 @@ These will be used to retrieve the RSVP information from ical events."
(gnus-icalendar--get-org-event-reply-status event))
"Not replied yet"))
-(cl-defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event-reply))
+(cl-defmethod gnus-icalendar-event:inline-reply-status ((_event gnus-icalendar-event-reply))
"No reply status for REPLY events."
nil)
@@ -884,7 +873,7 @@ These will be used to retrieve the RSVP information from ical events."
(when org-entry-exists-p
`("Show Org Entry" gnus-icalendar--show-org-event ,event))))))
-
+;;;###autoload
(defun gnus-icalendar-mm-inline (handle)
(let ((event (gnus-icalendar-event-from-handle handle (gnus-icalendar-identities))))
@@ -896,7 +885,7 @@ These will be used to retrieve the RSVP information from ical events."
(buttons)
(when buttons
(mapc (lambda (x)
- (apply 'gnus-icalendar-insert-button x)
+ (apply #'gnus-icalendar-insert-button x)
(insert " "))
buttons)
(insert "\n\n"))))
@@ -977,6 +966,9 @@ These will be used to retrieve the RSVP information from ical events."
(defvar gnus-mime-action-alist) ; gnus-art
(defun gnus-icalendar-setup ()
+ ;; FIXME: Get rid of this!
+ ;; The three add-to-list are now redundant (good), but I think the rest
+ ;; is still not automatically setup.
(add-to-list 'mm-inlined-types "text/calendar")
(add-to-list 'mm-automatic-display "text/calendar")
(add-to-list 'mm-inline-media-tests '("text/calendar" gnus-icalendar-mm-inline identity))
@@ -991,7 +983,7 @@ These will be used to retrieve the RSVP information from ical events."
(require 'gnus-art)
(add-to-list 'gnus-mime-action-alist
- (cons "save calendar event" 'gnus-icalendar-save-event)
+ (cons "save calendar event" #'gnus-icalendar-save-event)
t))
(provide 'gnus-icalendar)
diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el
index b4e9b625ca8..e23e53b1ef5 100644
--- a/lisp/gnus/gnus-int.el
+++ b/lisp/gnus/gnus-int.el
@@ -24,8 +24,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
-
(require 'gnus)
(require 'message)
(require 'gnus-range)
@@ -259,7 +257,8 @@ If it is down, start it up (again)."
(insert (format-time-string "%H:%M:%S")
(format " %.2fs %s %S\n"
(if (numberp gnus-backend-trace-elapsed)
- (- (float-time) gnus-backend-trace-elapsed)
+ (float-time
+ (time-since gnus-backend-trace-elapsed))
0)
type form))
(setq gnus-backend-trace-elapsed (float-time)))))
diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el
index 95ff5a81a8b..a7ded393034 100644
--- a/lisp/gnus/gnus-kill.el
+++ b/lisp/gnus/gnus-kill.el
@@ -25,17 +25,10 @@
;;; Code:
-(eval-when-compile (require 'cl))
-
(require 'gnus)
(require 'gnus-art)
(require 'gnus-range)
-(defcustom gnus-kill-file-mode-hook nil
- "Hook for Gnus kill file mode."
- :group 'gnus-score-kill
- :type 'hook)
-
(defcustom gnus-kill-expiry-days 7
"Number of days before expiring unused kill file entries."
:group 'gnus-score-kill
diff --git a/lisp/gnus/gnus-logic.el b/lisp/gnus/gnus-logic.el
index fa9d9306963..90f74205209 100644
--- a/lisp/gnus/gnus-logic.el
+++ b/lisp/gnus/gnus-logic.el
@@ -24,7 +24,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'gnus)
(require 'gnus-score)
@@ -162,9 +162,9 @@
(funcall type (or (aref gnus-advanced-headers index) 0) match)))
(defun gnus-advanced-date (index match type)
- (let ((date (apply 'encode-time (parse-time-string
- (aref gnus-advanced-headers index))))
- (match (apply 'encode-time (parse-time-string match))))
+ (let ((date (encode-time (parse-time-string
+ (aref gnus-advanced-headers index))))
+ (match (encode-time (parse-time-string match))))
(cond
((eq type 'at)
(equal date match))
diff --git a/lisp/gnus/gnus-ml.el b/lisp/gnus/gnus-ml.el
index 8cca3d65b9a..6a264e099a6 100644
--- a/lisp/gnus/gnus-ml.el
+++ b/lisp/gnus/gnus-ml.el
@@ -28,7 +28,6 @@
(require 'gnus)
(require 'gnus-msg)
-(eval-when-compile (require 'cl))
;;; Mailing list minor mode
diff --git a/lisp/gnus/gnus-mlspl.el b/lisp/gnus/gnus-mlspl.el
index edc70667ba1..e9c0de968b3 100644
--- a/lisp/gnus/gnus-mlspl.el
+++ b/lisp/gnus/gnus-mlspl.el
@@ -24,7 +24,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-sum)
(require 'gnus-group)
@@ -183,7 +182,8 @@ Calling (gnus-group-split-fancy nil nil \"mail.others\") returns:
(to-list (cdr (assoc 'to-list params)))
(extra-aliases (cdr (assoc 'extra-aliases params)))
(split-regexp (cdr (assoc 'split-regexp params)))
- (split-exclude (cdr (assoc 'split-exclude params))))
+ (split-exclude (cdr (assoc 'split-exclude params)))
+ (match-list (cdr (assoc 'match-list params))))
(when (or to-address to-list extra-aliases split-regexp)
;; regexp-quote to-address, to-list and extra-aliases
;; and add them all to split-regexp
@@ -203,16 +203,28 @@ Calling (gnus-group-split-fancy nil nil \"mail.others\") returns:
"\\|")
"\\)"))
;; Now create the new SPLIT
- (push (append
- (list 'any split-regexp)
+ (let ((split-regexp-with-list-ids
+ (replace-regexp-in-string "@" "[@.]" split-regexp t t))
+ (exclude
;; Generate RESTRICTs for SPLIT-EXCLUDEs.
(if (listp split-exclude)
(apply #'append
(mapcar (lambda (arg) (list '- arg))
split-exclude))
- (list '- split-exclude))
- (list group-clean))
- split)
+ (list '- split-exclude))))
+
+ (if match-list
+ ;; Match RFC2919 IDs or mail addresses
+ (push (append
+ (list 'list split-regexp-with-list-ids)
+ exclude
+ (list group-clean))
+ split)
+ (push (append
+ (list 'any split-regexp)
+ exclude
+ (list group-clean))
+ split)))
;; If it matches the empty string, it is a catch-all
(when (string-match split-regexp "")
(setq catch-all nil)))))))))
diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el
index 5c5e7abd443..b6d649d7603 100644
--- a/lisp/gnus/gnus-msg.el
+++ b/lisp/gnus/gnus-msg.el
@@ -25,7 +25,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'gnus)
(require 'message)
@@ -393,6 +393,7 @@ Thank you for your help in stamping out bugs.
"N" gnus-summary-followup-to-mail-with-original
"m" gnus-summary-mail-other-window
"u" gnus-uu-post-news
+ "A" gnus-summary-attach-article
"\M-c" gnus-summary-mail-crosspost-complaint
"Br" gnus-summary-reply-broken-reply-to
"BR" gnus-summary-reply-broken-reply-to-with-original
@@ -535,7 +536,7 @@ instead."
(progn
(message "Gnus not running; using plain Message mode")
(message-mail to subject other-headers continue
- nil yank-action send-actions return-action))
+ switch-action yank-action send-actions return-action))
(let ((buf (current-buffer))
;; Don't use posting styles corresponding to any existing group.
(group-name gnus-newsgroup-name)
@@ -1037,7 +1038,7 @@ header line with the old Message-ID."
(gnus-inews-yank-articles yank))))))
(defun gnus-msg-treat-broken-reply-to (&optional force)
- "Remove the Reply-to header if broken-reply-to."
+ "Remove the Reply-To header if broken-reply-to."
(when (or force
(gnus-group-find-parameter
gnus-newsgroup-name 'broken-reply-to))
@@ -1113,11 +1114,11 @@ If SILENT, don't prompt the user."
((and (eq gnus-post-method 'current)
(not (memq (car group-method) gnus-discouraged-post-methods))
(gnus-get-function group-method 'request-post t))
- (assert (not arg))
+ (cl-assert (not arg))
group-method)
;; Use gnus-post-method.
((listp gnus-post-method) ;A method...
- (assert (not (listp (car gnus-post-method)))) ;... not a list of methods.
+ (cl-assert (not (listp (car gnus-post-method)))) ;... not a list of methods.
gnus-post-method)
;; Use the normal select method (nil or native).
(t gnus-select-method))))
@@ -1482,7 +1483,7 @@ See `gnus-summary-mail-forward' for ARG."
(not (member group (message-tokenize-header
followup-to ", ")))))
(if followup-to
- (gnus-message 1 "Followup-to restricted")
+ (gnus-message 1 "Followup-To restricted")
(gnus-message 1 "Not a crossposted article"))
(set-buffer gnus-summary-buffer)
(gnus-summary-reply-with-original 1)
@@ -1541,7 +1542,7 @@ If YANK is non-nil, include the original article."
(X-Debbugs-Version
. ,(format "%s" (gnus-continuum-version))))))
(when gnus-bug-create-help-buffer
- (push `(gnus-bug-kill-buffer) message-send-actions))
+ (push '(gnus-bug-kill-buffer) message-send-actions))
(goto-char (point-min))
(message-goto-body)
(insert "\n\n\n\n\n")
@@ -2000,6 +2001,36 @@ this is a reply."
(insert "From: " (message-make-from) "\n"))))
nil 'local)))))
+(defun gnus-summary-attach-article (n)
+ "Attach the current article(s) to an outgoing Message buffer.
+If any current in-progress Message buffers exist, the articles
+can be attached to them. If not, a new Message buffer is
+created.
+
+This command uses the process/prefix convention, so if you
+process-mark several articles, they will all be attached."
+ (interactive "P")
+ (let ((buffers (message-buffers))
+ destination)
+ ;; Set up the destination mail composition buffer.
+ (if (and buffers
+ (y-or-n-p "Attach files to existing mail composition buffer? "))
+ (setq destination
+ (if (= (length buffers) 1)
+ (get-buffer (car buffers))
+ (gnus-completing-read "Attach to buffer"
+ buffers t nil nil (car buffers))))
+ (gnus-summary-mail-other-window)
+ (setq destination (current-buffer)))
+ (gnus-summary-iterate n
+ (gnus-summary-select-article)
+ (set-buffer destination)
+ ;; Attach at the end of the buffer.
+ (save-excursion
+ (goto-char (point-max))
+ (message-forward-make-body-mime gnus-original-article-buffer)))
+ (gnus-configure-windows 'message t)))
+
(provide 'gnus-msg)
;;; gnus-msg.el ends here
diff --git a/lisp/gnus/gnus-picon.el b/lisp/gnus/gnus-picon.el
index 7182e10cc63..18b46a1c12f 100644
--- a/lisp/gnus/gnus-picon.el
+++ b/lisp/gnus/gnus-picon.el
@@ -37,7 +37,7 @@
;;
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'gnus)
(require 'gnus-art)
@@ -211,7 +211,7 @@ replacement is added."
(gnus-article-goto-header header)
(mail-header-narrow-to-field)
- (case gnus-picon-style
+ (cl-case gnus-picon-style
(right
(when (= (length addresses) 1)
(setq len (apply '+ (mapcar (lambda (x)
diff --git a/lisp/gnus/gnus-range.el b/lisp/gnus/gnus-range.el
index 2fc7e6d8143..b775def9a0d 100644
--- a/lisp/gnus/gnus-range.el
+++ b/lisp/gnus/gnus-range.el
@@ -24,8 +24,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
-
;;; List and range functions
(defsubst gnus-range-normalize (range)
@@ -38,17 +36,9 @@ If RANGE is a single range, return (RANGE). Otherwise, return RANGE."
(while (cdr list)
(setq list (cdr list)))
(car list))
+(make-obsolete 'gnus-last-element "use `car' of `last' instead." "27.1")
-(defun gnus-copy-sequence (list)
- "Do a complete, total copy of a list."
- (let (out)
- (while (consp list)
- (if (consp (car list))
- (push (gnus-copy-sequence (pop list)) out)
- (push (pop list) out)))
- (if list
- (nconc (nreverse out) list)
- (nreverse out))))
+(define-obsolete-function-alias 'gnus-copy-sequence 'copy-tree "27.1")
(defun gnus-set-difference (list1 list2)
"Return a list of elements of LIST1 that do not appear in LIST2."
@@ -455,7 +445,7 @@ modified."
(if (or (null range1) (null range2))
range1
(let (out r1 r2 r1_min r1_max r2_min r2_max
- (range2 (gnus-copy-sequence range2)))
+ (range2 (copy-tree range2)))
(setq range1 (if (listp (cdr range1)) range1 (list range1))
range2 (sort (if (listp (cdr range2)) range2 (list range2))
(lambda (e1 e2)
diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el
index 80d73b5c21a..634cf926cea 100644
--- a/lisp/gnus/gnus-registry.el
+++ b/lisp/gnus/gnus-registry.el
@@ -76,7 +76,8 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
+(eval-when-compile (require 'subr-x))
(require 'gnus)
(require 'gnus-int)
@@ -165,12 +166,7 @@ nnmairix groups are specifically excluded because they are ephemeral."
(defvar gnus-registry-misc-menus nil) ; ugly way to keep the menus
-(make-obsolete-variable 'gnus-registry-clean-empty nil "23.4")
-(make-obsolete-variable 'gnus-registry-use-long-group-names nil "23.4")
-(make-obsolete-variable 'gnus-registry-max-track-groups nil "23.4")
-(make-obsolete-variable 'gnus-registry-entry-caching nil "23.4")
-(make-obsolete-variable 'gnus-registry-trim-articles-without-groups nil "23.4")
-;; FIXME it was simply deleted.
+;; It was simply deleted.
(make-obsolete-variable 'gnus-registry-max-pruned-entries nil "25.1")
(defcustom gnus-registry-track-extra '(subject sender recipient)
@@ -372,7 +368,7 @@ This is not required after changing `gnus-registry-cache-file'."
(grouphashtb (registry-lookup-secondary db 'group))
(old-size (registry-size db)))
(registry-reindex db)
- (loop for k being the hash-keys of grouphashtb
+ (cl-loop for k being the hash-keys of grouphashtb
using (hash-values v)
when (gnus-registry-ignore-group-p k)
do (registry-delete db v nil))
@@ -443,14 +439,14 @@ This is not required after changing `gnus-registry-cache-file'."
(sender ,sender)
(recipient ,@recipients)
(subject ,subject)))
- (when (second kv)
- (let ((new (or (assq (first kv) entry)
- (list (first kv)))))
+ (when (cadr kv)
+ (let ((new (or (assq (car kv) entry)
+ (list (car kv)))))
(dolist (toadd (cdr kv))
(unless (member toadd new)
(setq new (append new (list toadd)))))
(setq entry (cons new
- (assq-delete-all (first kv) entry))))))
+ (assq-delete-all (car kv) entry))))))
(gnus-message 10 "Gnus registry: new entry for %s is %S"
id
entry)
@@ -504,7 +500,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
:subject subject
:log-agent "Gnus registry fancy splitting with parent")))
-(defun* gnus-registry--split-fancy-with-parent-internal
+(cl-defun gnus-registry--split-fancy-with-parent-internal
(&rest spec
&key references refstr sender subject recipients log-agent
&allow-other-keys)
@@ -524,7 +520,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
log-agent refstr)
(dolist (reference (nreverse references))
(gnus-message 9 "%s is looking up %s" log-agent reference)
- (loop for group in (gnus-registry-get-id-key reference 'group)
+ (cl-loop for group in (gnus-registry-get-id-key reference 'group)
when (gnus-registry-follow-group-p group)
do
(progn
@@ -547,7 +543,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(gnus-registry-get-id-key reference 'group))
(registry-lookup-secondary-value db 'subject subject)))))
(setq found
- (loop for group in groups
+ (cl-loop for group in groups
when (gnus-registry-follow-group-p group)
do (gnus-message
;; warn more if gnus-registry-track-extra
@@ -574,7 +570,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(gnus-registry-get-id-key reference 'group))
(registry-lookup-secondary-value db 'sender sender)))))
(setq found
- (loop for group in groups
+ (cl-loop for group in groups
when (gnus-registry-follow-group-p group)
do (gnus-message
;; warn more if gnus-registry-track-extra
@@ -604,7 +600,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(registry-lookup-secondary-value
db 'recipient recp)))))
(setq found
- (loop for group in groups
+ (cl-loop for group in groups
when (gnus-registry-follow-group-p group)
do (gnus-message
;; warn more if gnus-registry-track-extra
@@ -640,7 +636,7 @@ possible. Uses `gnus-registry-split-strategy'."
out chosen)
;; the strategy can be nil, in which case chosen is nil
(setq chosen
- (case gnus-registry-split-strategy
+ (cl-case gnus-registry-split-strategy
;; default, take only one-element lists into chosen
((nil)
(and (= (length groups) 1)
@@ -692,7 +688,7 @@ possible. Uses `gnus-registry-split-strategy'."
10
"%s: stripped group %s to %s"
log-agent group short-name))
- (pushnew short-name out :test #'equal))
+ (cl-pushnew short-name out :test #'equal))
;; else...
(gnus-message
7
@@ -844,21 +840,17 @@ Addresses without a name will say \"noname\"."
nil))
(defun gnus-registry-fetch-sender-fast (article)
- (gnus-registry-fetch-header-fast "from" article))
+ (when-let* ((data (and (numberp article)
+ (assoc article (gnus-data-list nil)))))
+ (mail-header-from (gnus-data-header data))))
(defun gnus-registry-fetch-recipients-fast (article)
- (gnus-registry-sort-addresses
- (or (ignore-errors (gnus-registry-fetch-header-fast "Cc" article)) "")
- (or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) "")))
-
-(defun gnus-registry-fetch-header-fast (article header)
- "Fetch the HEADER quickly, using the internal gnus-data-list function."
- (if (and (numberp article)
- (assoc article (gnus-data-list nil)))
- (gnus-string-remove-all-properties
- (cdr (assq header (gnus-data-header
- (assoc article (gnus-data-list nil))))))
- nil))
+ (when-let* ((data (and (numberp article)
+ (assoc article (gnus-data-list nil))))
+ (extra (mail-header-extra (gnus-data-header data))))
+ (gnus-registry-sort-addresses
+ (or (cdr (assq 'Cc extra)) "")
+ (or (cdr (assq 'To extra)) ""))))
;; registry marks glue
(defun gnus-registry-do-marks (type function)
@@ -1089,7 +1081,7 @@ only the last one's marks are returned."
(expected (length old))
entry)
(while (car-safe old)
- (incf count)
+ (cl-incf count)
;; don't use progress reporters for backwards compatibility
(when (and (< 0 expected)
(= 0 (mod count 100)))
@@ -1099,7 +1091,7 @@ only the last one's marks are returned."
old (cdr-safe old))
(let* ((id (car-safe entry))
(rest (cdr-safe entry))
- (groups (loop for p in rest
+ (groups (cl-loop for p in rest
when (stringp p)
collect p))
extra-cell key val)
@@ -1235,7 +1227,7 @@ from your existing entries."
(when extra
(let ((db gnus-registry-db))
(registry-reindex db)
- (loop for k being the hash-keys of (oref db data)
+ (cl-loop for k being the hash-keys of (oref db data)
using (hash-value v)
do (let ((newv (delq nil (mapcar #'(lambda (entry)
(unless (member (car entry) extra)
diff --git a/lisp/gnus/gnus-salt.el b/lisp/gnus/gnus-salt.el
index 0c17b5e2777..58c05e0716a 100644
--- a/lisp/gnus/gnus-salt.el
+++ b/lisp/gnus/gnus-salt.el
@@ -24,7 +24,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'gnus)
(require 'gnus-sum)
@@ -131,7 +131,7 @@ It accepts the same format specs that `gnus-summary-line-format' does."
(defvar gnus-pick-line-number 1)
(defun gnus-pick-line-number ()
"Return the current line number."
- (incf gnus-pick-line-number))
+ (cl-incf gnus-pick-line-number))
(defun gnus-pick-start-reading (&optional catch-up)
"Start reading the picked articles.
@@ -396,11 +396,6 @@ Two predefined functions are available:
(function :tag "Other" nil))
:group 'gnus-summary-tree)
-(defcustom gnus-tree-mode-hook nil
- "Hook run in tree mode buffers."
- :type 'hook
- :group 'gnus-summary-tree)
-
;;; Internal variables.
(defvar gnus-tmp-name)
@@ -411,7 +406,7 @@ Two predefined functions are available:
(defvar gnus-tmp-subject)
(defvar gnus-tree-line-format-alist
- `((?n gnus-tmp-name ?s)
+ '((?n gnus-tmp-name ?s)
(?f gnus-tmp-from ?s)
(?N gnus-tmp-number ?d)
(?\[ gnus-tmp-open-bracket ?c)
@@ -445,8 +440,6 @@ Two predefined functions are available:
'undefined 'gnus-tree-read-summary-keys map)
map))
-(put 'gnus-tree-mode 'mode-class 'special)
-
(defun gnus-tree-make-menu-bar ()
(unless (boundp 'gnus-tree-menu)
(easy-menu-define
@@ -454,7 +447,7 @@ Two predefined functions are available:
'("Tree"
["Select article" gnus-tree-select-article t]))))
-(define-derived-mode gnus-tree-mode fundamental-mode "Tree"
+(define-derived-mode gnus-tree-mode gnus-mode "Tree"
"Major mode for displaying thread trees."
(gnus-set-format 'tree-mode)
(gnus-set-format 'tree t)
@@ -552,7 +545,7 @@ Two predefined functions are available:
(not (one-window-p)))
(let ((windows 0)
tot-win-height)
- (walk-windows (lambda (_window) (incf windows)))
+ (walk-windows (lambda (_window) (cl-incf windows)))
(setq tot-win-height
(- (frame-height)
(* window-min-height (1- windows))
@@ -734,7 +727,7 @@ it in the environment specified by BINDINGS."
(insert (make-string len ? )))))
(defsubst gnus-tree-forward-line (n)
- (while (>= (decf n) 0)
+ (while (>= (cl-decf n) 0)
(unless (zerop (forward-line 1))
(end-of-line)
(insert "\n")))
@@ -784,7 +777,7 @@ it in the environment specified by BINDINGS."
(progn
(goto-char (point-min))
(end-of-line)
- (incf gnus-tmp-indent))
+ (cl-incf gnus-tmp-indent))
;; Recurse downwards in all children of this article.
(while thread
(gnus-generate-vertical-tree
diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el
index 4759a2864c6..2faf0f951db 100644
--- a/lisp/gnus/gnus-score.el
+++ b/lisp/gnus/gnus-score.el
@@ -25,7 +25,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'gnus)
(require 'gnus-sum)
@@ -514,7 +514,7 @@ of the last successful match.")
"f" gnus-score-edit-file
"F" gnus-score-flush-cache
"t" gnus-score-find-trace
- "w" gnus-score-find-favourite-words)
+ "w" gnus-score-find-favorite-words)
;; Summary score file commands
@@ -921,7 +921,7 @@ EXTRA is the possible non-standard header."
(interactive (list (gnus-completing-read "Header"
(mapcar
'car
- (gnus-remove-if-not
+ (seq-filter
(lambda (x) (fboundp (nth 2 x)))
gnus-header-index))
t)
@@ -1078,11 +1078,11 @@ EXTRA is the possible non-standard header."
"Return the score of the current article.
With prefix ARG, return the total score of the current (sub)thread."
(interactive "P")
- (gnus-message 1 "%s" (if arg
- (gnus-thread-total-score
- (gnus-id-to-thread
- (mail-header-id (gnus-summary-article-header))))
- (gnus-summary-article-score))))
+ (message "%s" (if arg
+ (gnus-thread-total-score
+ (gnus-id-to-thread
+ (mail-header-id (gnus-summary-article-header))))
+ (gnus-summary-article-score))))
(defun gnus-score-change-score-file (file)
"Change current score alist."
@@ -1238,7 +1238,7 @@ If FORMAT, also format the current score file."
(or (not decay)
(gnus-decay-scores alist decay)))
(gnus-score-set 'touched '(t) alist)
- (gnus-score-set 'decay (list (time-to-days (current-time))) alist))
+ (gnus-score-set 'decay (list (time-to-days nil)) alist))
;; We do not respect eval and files atoms from global score
;; files.
(when (and files (not global))
@@ -1501,7 +1501,7 @@ If FORMAT, also format the current score file."
(when (and gnus-summary-default-score
scores)
(let* ((entries gnus-header-index)
- (now (date-to-day (current-time-string)))
+ (now (time-to-days nil))
(expire (and gnus-score-expiry-days
(- now gnus-score-expiry-days)))
(headers gnus-newsgroup-headers)
@@ -1751,8 +1751,7 @@ score in `gnus-newsgroup-scored' by SCORE."
(mm-display-inline handle)
(goto-char (point-max))))))
- (let ( ;(mm-text-html-renderer 'w3m-standalone)
- (handles (mm-dissect-buffer t)))
+ (let ((handles (mm-dissect-buffer t)))
(save-excursion
(article-goto-body)
(delete-region (point) (point-max))
@@ -2235,8 +2234,7 @@ score in `gnus-newsgroup-scored' by SCORE."
(let* ((score (or (nth 1 kill) gnus-score-interactive-default-score))
(date (nth 2 kill))
found)
- (when (setq arts (intern-soft (nth 0 kill) hashtb))
- (setq arts (symbol-value arts))
+ (when (setq arts (gethash (nth 0 kill) hashtb))
(setq found t)
(if trace
(while (setq art (pop arts))
@@ -2274,11 +2272,11 @@ score in `gnus-newsgroup-scored' by SCORE."
(with-syntax-table gnus-adaptive-word-syntax-table
(while (re-search-forward "\\b\\w+\\b" nil t)
(setq val
- (gnus-gethash
+ (gethash
(setq word (downcase (buffer-substring
(match-beginning 0) (match-end 0))))
hashtb))
- (gnus-sethash
+ (puthash
word
(append (get-text-property (point-at-eol) 'articles) val)
hashtb)))
@@ -2290,7 +2288,7 @@ score in `gnus-newsgroup-scored' by SCORE."
"."))
gnus-default-ignored-adaptive-words)))
(while ignored
- (gnus-sethash (pop ignored) nil hashtb)))))
+ (remhash (pop ignored) hashtb)))))
(defun gnus-score-string< (a1 a2)
;; Compare headers in articles A2 and A2.
@@ -2318,7 +2316,7 @@ score in `gnus-newsgroup-scored' by SCORE."
(when (or (not (listp gnus-newsgroup-adaptive))
(memq 'line gnus-newsgroup-adaptive))
(save-excursion
- (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist))
+ (let* ((malist (copy-tree gnus-adaptive-score-alist))
(alist malist)
(date (current-time-string))
(data gnus-newsgroup-data)
@@ -2381,7 +2379,7 @@ score in `gnus-newsgroup-scored' by SCORE."
(memq 'word gnus-newsgroup-adaptive))
(with-temp-buffer
(let* ((hashtb (gnus-make-hashtable 1000))
- (date (date-to-day (current-time-string)))
+ (date (time-to-days nil))
(data gnus-newsgroup-data)
word d score val)
(with-syntax-table gnus-adaptive-word-syntax-table
@@ -2401,8 +2399,8 @@ score in `gnus-newsgroup-scored' by SCORE."
(goto-char (point-min))
(while (re-search-forward "\\b\\w+\\b" nil t)
;; Put the word and score into the hashtb.
- (setq val (gnus-gethash (setq word (match-string 0))
- hashtb))
+ (setq val (gethash (setq word (match-string 0))
+ hashtb))
(when (or (not gnus-adaptive-word-length-limit)
(> (length word)
gnus-adaptive-word-length-limit))
@@ -2410,7 +2408,7 @@ score in `gnus-newsgroup-scored' by SCORE."
(if (and gnus-adaptive-word-minimum
(< val gnus-adaptive-word-minimum))
(setq val gnus-adaptive-word-minimum))
- (gnus-sethash word val hashtb)))
+ (puthash word val hashtb)))
(erase-buffer))))
;; Make all the ignorable words ignored.
(let ((ignored (append gnus-ignored-adaptive-words
@@ -2421,16 +2419,14 @@ score in `gnus-newsgroup-scored' by SCORE."
"."))
gnus-default-ignored-adaptive-words)))
(while ignored
- (gnus-sethash (pop ignored) nil hashtb)))
+ (remhash (pop ignored) hashtb)))
;; Now we have all the words and scores, so we
;; add these rules to the ADAPT file.
(set-buffer gnus-summary-buffer)
- (mapatoms
- (lambda (word)
- (when (symbol-value word)
- (gnus-summary-score-entry
- "subject" (symbol-name word) 'w (symbol-value word)
- date nil t)))
+ (maphash
+ (lambda (word val)
+ (gnus-summary-score-entry
+ "subject" word 'w val date nil t))
hashtb))))))
(defun gnus-score-edit-done ()
@@ -2517,7 +2513,7 @@ the score file and its full name, including the directory.")
(set-buffer gnus-summary-buffer)
(setq gnus-newsgroup-scored old-scored)))
-(defun gnus-score-find-favourite-words ()
+(defun gnus-score-find-favorite-words ()
"List words used in scoring."
(interactive)
(let ((alists (gnus-score-load-files (gnus-all-score-files)))
@@ -2553,6 +2549,9 @@ the score file and its full name, including the directory.")
(pop rules))
(goto-char (point-min))
(gnus-configure-windows 'score-words))))
+(define-obsolete-function-alias
+ 'gnus-score-find-favourite-words
+ 'gnus-score-find-favorite-words "27.1")
(defun gnus-summary-rescore ()
"Redo the entire scoring process in the current summary."
@@ -2673,7 +2672,8 @@ the score file and its full name, including the directory.")
(gnus-file-newer-than gnus-kill-files-directory
(car gnus-score-file-list)))
(setq gnus-score-file-list
- (cons (nth 5 (file-attributes gnus-kill-files-directory))
+ (cons (file-attribute-modification-time
+ (file-attributes gnus-kill-files-directory))
(nreverse
(directory-files
gnus-kill-files-directory t
@@ -2731,8 +2731,10 @@ GROUP using BNews sys file syntax."
(insert (car sfiles))
(goto-char (point-min))
;; First remove the suffix itself.
- (when (re-search-forward (concat "." score-regexp) nil t)
- (replace-match "" t t)
+ (when (re-search-forward score-regexp nil t)
+ (unless (= (match-end 0) (match-beginning 0)) ; non-empty suffix
+ (replace-match "" t t)
+ (delete-char -1)) ; remove the "." before the suffix
(goto-char (point-min))
(if (looking-at (regexp-quote kill-dir))
;; If the file name was just "SCORE", `klen' is one character
@@ -3060,7 +3062,7 @@ If ADAPT, return the home adaptive file instead."
(defun gnus-decay-scores (alist day)
"Decay non-permanent scores in ALIST."
- (let ((times (- (time-to-days (current-time)) day))
+ (let ((times (- (time-to-days nil) day))
kill entry updated score n)
(unless (zerop times) ;Done decays today already?
(while (setq entry (pop alist))
@@ -3072,7 +3074,7 @@ If ADAPT, return the home adaptive file instead."
(setq score (or (nth 1 kill)
gnus-score-interactive-default-score)
n times)
- (while (natnump (decf n))
+ (while (natnump (cl-decf n))
(setq score (funcall gnus-decay-score-function score)))
(setcdr kill (cons score
(cdr (cdr kill)))))))))
diff --git a/lisp/gnus/gnus-spec.el b/lisp/gnus/gnus-spec.el
index d96e9f2aed7..b236f0a4018 100644
--- a/lisp/gnus/gnus-spec.el
+++ b/lisp/gnus/gnus-spec.el
@@ -24,7 +24,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defvar gnus-newsrc-file-version)
(require 'gnus)
@@ -271,9 +271,7 @@ Return a list of updated types."
(insert " ")))
(insert-char ? (max (- ,column (current-column)) 0))))))
-(defun gnus-correct-length (string)
- "Return the correct width of STRING."
- (apply #'+ (mapcar #'char-width string)))
+(define-obsolete-function-alias 'gnus-correct-length 'string-width "27.1")
(defun gnus-correct-substring (string start &optional end)
(let ((wstart 0)
@@ -285,15 +283,15 @@ Return a list of updated types."
;; Find the start position.
(while (and (< seek length)
(< wseek start))
- (incf wseek (char-width (aref string seek)))
- (incf seek))
+ (cl-incf wseek (char-width (aref string seek)))
+ (cl-incf seek))
(setq wstart seek)
;; Find the end position.
(while (and (<= seek length)
(or (not end)
(<= wseek end)))
- (incf wseek (char-width (aref string seek)))
- (incf seek))
+ (cl-incf wseek (char-width (aref string seek)))
+ (cl-incf seek))
(setq wend seek)
(substring string wstart (1- wend))))
diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el
index f4464ad140c..76a0f7d0fdb 100644
--- a/lisp/gnus/gnus-srvr.el
+++ b/lisp/gnus/gnus-srvr.el
@@ -24,7 +24,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'gnus)
(require 'gnus-start)
@@ -36,11 +36,6 @@
(autoload 'gnus-group-make-nnir-group "nnir")
-(defcustom gnus-server-mode-hook nil
- "Hook run in `gnus-server-mode' buffers."
- :group 'gnus-server
- :type 'hook)
-
(defcustom gnus-server-exit-hook nil
"Hook run when exiting the server buffer."
:group 'gnus-server
@@ -92,7 +87,7 @@ If nil, a faster, but more primitive, buffer is used instead."
(defvar gnus-inserted-opened-servers nil)
(defvar gnus-server-line-format-alist
- `((?h gnus-tmp-how ?s)
+ '((?h gnus-tmp-how ?s)
(?n gnus-tmp-name ?s)
(?w gnus-tmp-where ?s)
(?s gnus-tmp-status ?s)
@@ -100,7 +95,7 @@ If nil, a faster, but more primitive, buffer is used instead."
(?c gnus-tmp-cloud ?s)))
(defvar gnus-server-mode-line-format-alist
- `((?S gnus-tmp-news-server ?s)
+ '((?S gnus-tmp-news-server ?s)
(?M gnus-tmp-news-method ?s)
(?u gnus-tmp-user-defined ?s)))
@@ -108,7 +103,7 @@ If nil, a faster, but more primitive, buffer is used instead."
(defvar gnus-server-mode-line-format-spec nil)
(defvar gnus-server-killed-servers nil)
-(defvar gnus-server-mode-map)
+(defvar gnus-server-mode-map nil)
(defcustom gnus-server-menu-hook nil
"Hook run after the creation of the server mode menu."
@@ -142,7 +137,7 @@ If nil, a faster, but more primitive, buffer is used instead."
["Offline" gnus-server-offline-server t]
["Deny" gnus-server-deny-server t]
["Toggle Cloud Sync for this server" gnus-server-toggle-cloud-server t]
- ["Toggle Cloud Sync Host" gnus-server-toggle-cloud-method-server t]
+ ["Toggle Cloud Sync Host" gnus-server-set-cloud-method-server t]
"---"
["Open All" gnus-server-open-all-servers t]
["Close All" gnus-server-close-all-servers t]
@@ -150,11 +145,8 @@ If nil, a faster, but more primitive, buffer is used instead."
(gnus-run-hooks 'gnus-server-menu-hook)))
-(defvar gnus-server-mode-map nil)
-(put 'gnus-server-mode 'mode-class 'special)
-
(unless gnus-server-mode-map
- (setq gnus-server-mode-map (make-sparse-keymap))
+ (setq gnus-server-mode-map (make-keymap))
(suppress-keymap gnus-server-mode-map)
(gnus-define-keys gnus-server-mode-map
@@ -189,7 +181,7 @@ If nil, a faster, but more primitive, buffer is used instead."
"z" gnus-server-compact-server
"i" gnus-server-toggle-cloud-server
- "I" gnus-server-toggle-cloud-method-server
+ "I" gnus-server-set-cloud-method-server
"\C-c\C-i" gnus-info-find-node
"\C-c\C-b" gnus-bug))
@@ -200,9 +192,6 @@ If nil, a faster, but more primitive, buffer is used instead."
(t (:bold t)))
"Face used for displaying AGENTIZED servers"
:group 'gnus-server-visual)
-;; backward-compatibility alias
-(put 'gnus-server-agent-face 'face-alias 'gnus-server-agent)
-(put 'gnus-server-agent-face 'obsolete-face "22.1")
(defface gnus-server-cloud
'((((class color) (background light)) (:foreground "ForestGreen" :bold t))
@@ -224,9 +213,6 @@ If nil, a faster, but more primitive, buffer is used instead."
(t (:bold t)))
"Face used for displaying OPENED servers"
:group 'gnus-server-visual)
-;; backward-compatibility alias
-(put 'gnus-server-opened-face 'face-alias 'gnus-server-opened)
-(put 'gnus-server-opened-face 'obsolete-face "22.1")
(defface gnus-server-closed
'((((class color) (background light)) (:foreground "Steel Blue" :italic t))
@@ -235,9 +221,6 @@ If nil, a faster, but more primitive, buffer is used instead."
(t (:italic t)))
"Face used for displaying CLOSED servers"
:group 'gnus-server-visual)
-;; backward-compatibility alias
-(put 'gnus-server-closed-face 'face-alias 'gnus-server-closed)
-(put 'gnus-server-closed-face 'obsolete-face "22.1")
(defface gnus-server-denied
'((((class color) (background light)) (:foreground "Red" :bold t))
@@ -245,9 +228,6 @@ If nil, a faster, but more primitive, buffer is used instead."
(t (:inverse-video t :bold t)))
"Face used for displaying DENIED servers"
:group 'gnus-server-visual)
-;; backward-compatibility alias
-(put 'gnus-server-denied-face 'face-alias 'gnus-server-denied)
-(put 'gnus-server-denied-face 'obsolete-face "22.1")
(defface gnus-server-offline
'((((class color) (background light)) (:foreground "Orange" :bold t))
@@ -255,9 +235,6 @@ If nil, a faster, but more primitive, buffer is used instead."
(t (:inverse-video t :bold t)))
"Face used for displaying OFFLINE servers"
:group 'gnus-server-visual)
-;; backward-compatibility alias
-(put 'gnus-server-offline-face 'face-alias 'gnus-server-offline)
-(put 'gnus-server-offline-face 'obsolete-face "22.1")
(defvar gnus-server-font-lock-keywords
'(("(\\(agent\\))" 1 'gnus-server-agent)
@@ -268,9 +245,8 @@ If nil, a faster, but more primitive, buffer is used instead."
("(\\(offline\\))" 1 'gnus-server-offline)
("(\\(denied\\))" 1 'gnus-server-denied)))
-(defun gnus-server-mode ()
+(define-derived-mode gnus-server-mode gnus-mode "Server"
"Major mode for listing and editing servers.
-
All normal editing commands are switched off.
\\<gnus-server-mode-map>
For more in-depth information on this mode, read the manual
@@ -279,23 +255,16 @@ For more in-depth information on this mode, read the manual
The following commands are available:
\\{gnus-server-mode-map}"
- ;; FIXME: Use define-derived-mode.
- (interactive)
(when (gnus-visual-p 'server-menu 'menu)
(gnus-server-make-menu-bar))
- (kill-all-local-variables)
(gnus-simplify-mode-line)
- (setq major-mode 'gnus-server-mode)
- (setq mode-name "Server")
(gnus-set-default-directory)
(setq mode-line-process nil)
- (use-local-map gnus-server-mode-map)
(buffer-disable-undo)
(setq truncate-lines t)
- (setq buffer-read-only t)
(set (make-local-variable 'font-lock-defaults)
- '(gnus-server-font-lock-keywords t))
- (gnus-run-mode-hooks 'gnus-server-mode-hook))
+ '(gnus-server-font-lock-keywords t)))
+
(defun gnus-server-insert-server-line (name method)
(let* ((gnus-tmp-name name)
@@ -335,21 +304,15 @@ The following commands are available:
(defun gnus-enter-server-buffer ()
"Set up the server buffer."
- (gnus-server-setup-buffer)
(gnus-configure-windows 'server)
;; Usually `gnus-configure-windows' will finish with the
;; `gnus-server-buffer' selected as the current buffer, but not always (I
;; bumped into it when starting from a dedicated *Group* frame, and
;; gnus-configure-windows opened *Server* into its own dedicated frame).
- (with-current-buffer (get-buffer gnus-server-buffer)
+ (with-current-buffer (get-buffer-create gnus-server-buffer)
+ (gnus-server-mode)
(gnus-server-prepare)))
-(defun gnus-server-setup-buffer ()
- "Initialize the server buffer."
- (unless (get-buffer gnus-server-buffer)
- (with-current-buffer (gnus-get-buffer-create gnus-server-buffer)
- (gnus-server-mode))))
-
(defun gnus-server-prepare ()
(gnus-set-format 'server-mode)
(gnus-set-format 'server t)
@@ -452,7 +415,8 @@ The following commands are available:
(if server (error "No such server: %s" server)
(error "No server on the current line")))
(unless (assoc server gnus-server-alist)
- (error "Read-only server %s" server))
+ (error "Server %s must be deleted from your configuration files"
+ server))
(gnus-dribble-touch)
(let ((buffer-read-only nil))
(gnus-delete-line))
@@ -608,7 +572,7 @@ The following commands are available:
(error "%s already exists" to))
(unless (gnus-server-to-method from)
(error "%s: no such server" from))
- (let ((to-entry (cons from (gnus-copy-sequence
+ (let ((to-entry (cons from (copy-tree
(gnus-server-to-method from)))))
(setcar to-entry to)
(setcar (nthcdr 2 to-entry) to)
@@ -642,7 +606,8 @@ The following commands are available:
(unless server
(error "No server on current line"))
(unless (assoc server gnus-server-alist)
- (error "This server can't be edited"))
+ (error "Server %s must be edited in your configuration files"
+ server))
(let ((info (cdr (assoc server gnus-server-alist))))
(gnus-close-server info)
(gnus-edit-form
@@ -661,8 +626,8 @@ The following commands are available:
(let ((info (gnus-server-to-method server)))
(gnus-edit-form
info "Showing the server."
- `(lambda (form)
- (gnus-server-position-point))
+ (lambda (form)
+ (gnus-server-position-point))
'edit-server)))
(defun gnus-server-scan-server (server)
@@ -730,9 +695,7 @@ claim them."
function
(repeat function)))
-(defvar gnus-browse-mode-hook nil)
(defvar gnus-browse-mode-map nil)
-(put 'gnus-browse-mode 'mode-class 'special)
(unless gnus-browse-mode-map
(setq gnus-browse-mode-map (make-keymap))
@@ -821,12 +784,11 @@ claim them."
(while (not (eobp))
(ignore-errors
(push (cons
- (string-as-unibyte
- (buffer-substring
- (point)
- (progn
- (skip-chars-forward "^ \t")
- (point))))
+ (buffer-substring
+ (point)
+ (progn
+ (skip-chars-forward "^ \t")
+ (point)))
(let ((last (read cur)))
(cons (read cur) last)))
groups))
@@ -834,19 +796,18 @@ claim them."
(while (not (eobp))
(ignore-errors
(push (cons
- (string-as-unibyte
- (if (eq (char-after) ?\")
- (read cur)
- (let ((p (point)) (name ""))
- (skip-chars-forward "^ \t\\\\")
- (setq name (buffer-substring p (point)))
- (while (eq (char-after) ?\\)
- (setq p (1+ (point)))
- (forward-char 2)
- (skip-chars-forward "^ \t\\\\")
- (setq name (concat name (buffer-substring
- p (point)))))
- name)))
+ (if (eq (char-after) ?\")
+ (read cur)
+ (let ((p (point)) (name ""))
+ (skip-chars-forward "^ \t\\\\")
+ (setq name (buffer-substring p (point)))
+ (while (eq (char-after) ?\\)
+ (setq p (1+ (point)))
+ (forward-char 2)
+ (skip-chars-forward "^ \t\\\\")
+ (setq name (concat name (buffer-substring
+ p (point)))))
+ name))
(let ((last (read cur)))
(cons (read cur) last)))
groups))
@@ -912,9 +873,8 @@ claim them."
(gnus-message 5 "Connecting to %s...done" (nth 1 method))
t))))
-(define-derived-mode gnus-browse-mode fundamental-mode "Browse Server"
+(define-derived-mode gnus-browse-mode gnus-mode "Browse Server"
"Major mode for browsing a foreign server.
-
All normal editing commands are switched off.
\\<gnus-browse-mode-map>
@@ -933,14 +893,17 @@ buffer.
(setq mode-line-process nil)
(buffer-disable-undo)
(setq truncate-lines t)
- (gnus-set-default-directory)
- (setq buffer-read-only t))
+ (gnus-set-default-directory))
(defun gnus-browse-read-group (&optional no-article number)
"Enter the group at the current line.
If NUMBER, fetch this number of articles."
(interactive "P")
- (let ((group (gnus-browse-group-name)))
+ (let* ((full-name (gnus-browse-group-name))
+ (group (if (gnus-native-method-p
+ (gnus-find-method-for-group full-name))
+ (gnus-group-short-name full-name)
+ full-name)))
(if (or (not (gnus-get-info group))
(gnus-ephemeral-group-p group))
(unless (gnus-group-read-ephemeral-group
@@ -982,7 +945,7 @@ how new groups will be entered into the group buffer."
(not (eobp))
(gnus-browse-unsubscribe-group)
(zerop (gnus-browse-next-group ward)))
- (decf arg))
+ (cl-decf arg))
(gnus-group-position-point)
(when (/= 0 arg)
(gnus-message 7 "No more newsgroups"))
@@ -1127,7 +1090,7 @@ Requesting compaction of %s... (this may take a long time)"
(and original (gnus-kill-buffer original))))))
(defun gnus-server-toggle-cloud-server ()
- "Make the server under point be replicated in the Emacs Cloud."
+ "Toggle whether the server under point is replicated in the Emacs Cloud."
(interactive)
(let ((server (gnus-server-server-name)))
(unless server
@@ -1147,7 +1110,7 @@ Requesting compaction of %s... (this may take a long time)"
"Replication of %s in the cloud will stop")
server)))
-(defun gnus-server-toggle-cloud-method-server ()
+(defun gnus-server-set-cloud-method-server ()
"Set the server under point to host the Emacs Cloud."
(interactive)
(let ((server (gnus-server-server-name)))
@@ -1157,7 +1120,7 @@ Requesting compaction of %s... (this may take a long time)"
(error "The server under point can't host the Emacs Cloud"))
(when (not (string-equal gnus-cloud-method server))
- (custom-set-variables '(gnus-cloud-method server))
+ (customize-set-variable 'gnus-cloud-method server)
;; Note we can't use `Custom-save' here.
(when (gnus-yes-or-no-p
(format "The new cloud host server is %S now. Save it? " server))
diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el
index a52cdbcbf2e..2beb685822f 100644
--- a/lisp/gnus/gnus-start.el
+++ b/lisp/gnus/gnus-start.el
@@ -36,8 +36,7 @@
(autoload 'gnus-agent-save-local "gnus-agent")
(autoload 'gnus-agent-possibly-alter-active "gnus-agent")
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defvar gnus-agent-covered-methods)
(defvar gnus-agent-file-loading-local)
@@ -544,29 +543,21 @@ Can be used to turn version control on or off."
(message "Descend hierarchy %s? ([y]nsq): "
(substring prefix 1 (1- (length prefix)))))
(cond ((= ans ?n)
- (while (and groups
- (setq group (car groups)
- real-group (gnus-group-real-name group))
- (string-match prefix real-group))
- (push group gnus-killed-list)
- (gnus-sethash group group gnus-killed-hashtb)
- (setq groups (cdr groups)))
+ (dolist (g groups)
+ (when (string-match prefix (gnus-group-real-name g))
+ (push g gnus-killed-list)
+ (puthash g t gnus-killed-hashtb)))
(setq starts (cdr starts)))
((= ans ?s)
- (while (and groups
- (setq group (car groups)
- real-group (gnus-group-real-name group))
- (string-match prefix real-group))
- (gnus-sethash group group gnus-killed-hashtb)
- (gnus-subscribe-alphabetically (car groups))
- (setq groups (cdr groups)))
+ (dolist (g groups)
+ (when (string-match prefix (gnus-group-real-name g))
+ (puthash g t gnus-killed-hashtb)
+ (gnus-subscribe-alphabetically g)))
(setq starts (cdr starts)))
((= ans ?q)
- (while groups
- (setq group (car groups))
- (push group gnus-killed-list)
- (gnus-sethash group group gnus-killed-hashtb)
- (setq groups (cdr groups))))
+ (dolist (g groups)
+ (push g gnus-killed-list)
+ (puthash g t gnus-killed-hashtb)))
(t nil)))
(message "Subscribe %s? ([n]yq)" (car groups))
(while (not (memq (setq ans (read-char-exclusive))
@@ -576,16 +567,14 @@ Can be used to turn version control on or off."
(setq group (car groups))
(cond ((= ans ?y)
(gnus-subscribe-alphabetically (car groups))
- (gnus-sethash group group gnus-killed-hashtb))
+ (puthash group t gnus-killed-hashtb))
((= ans ?q)
- (while groups
- (setq group (car groups))
- (push group gnus-killed-list)
- (gnus-sethash group group gnus-killed-hashtb)
- (setq groups (cdr groups))))
+ (dolist (g groups)
+ (push g gnus-killed-list)
+ (puthash g t gnus-killed-hashtb)))
(t
(push group gnus-killed-list)
- (gnus-sethash group group gnus-killed-hashtb)))
+ (puthash group t gnus-killed-hashtb)))
(setq groups (cdr groups)))))))
(defun gnus-subscribe-randomly (newsgroup)
@@ -648,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 (gnus-group-entry (or next "dummy.group")))
+ gnus-level-killed (or next "dummy.group"))
(gnus-request-update-group-status newsgroup 'subscribe)
(gnus-message 5 "Subscribe newsgroup: %s" newsgroup)
(run-hook-with-args 'gnus-subscribe-newsgroup-functions newsgroup)
@@ -697,6 +686,7 @@ the first newsgroup."
gnus-agent-file-loading-cache nil
gnus-server-method-cache nil
gnus-newsrc-alist nil
+ gnus-group-list nil
gnus-newsrc-hashtb nil
gnus-killed-list nil
gnus-zombie-list nil
@@ -1019,7 +1009,7 @@ If LEVEL is non-nil, the news will be set up at level LEVEL."
(eq gnus-read-active-file 'some))
(gnus-update-active-hashtb-from-killed))
(unless gnus-active-hashtb
- (setq gnus-active-hashtb (gnus-make-hashtable 4096)))
+ (setq gnus-active-hashtb (gnus-make-hashtable 4000)))
;; Initialize the cache.
(when gnus-use-cache
(gnus-cache-open))
@@ -1109,7 +1099,7 @@ for new groups, and subscribe the new groups as zombies."
(gnus-ask-server-for-new-groups)
;; Go through the active hashtb and look for new groups.
(let ((groups 0)
- group new-newsgroups)
+ new-newsgroups)
(gnus-message 5 "Looking for new newsgroups...")
(unless gnus-have-read-active-file
(gnus-read-active-file))
@@ -1118,30 +1108,26 @@ for new groups, and subscribe the new groups as zombies."
(gnus-make-hashtable-from-killed))
;; Go though every newsgroup in `gnus-active-hashtb' and compare
;; with `gnus-newsrc-hashtb' and `gnus-killed-hashtb'.
- (mapatoms
- (lambda (sym)
- (if (or (null (setq group (symbol-name sym)))
- (not (boundp sym))
- (null (symbol-value sym))
- (gnus-gethash group gnus-killed-hashtb)
- (gnus-gethash group gnus-newsrc-hashtb))
- ()
- (let ((do-sub (gnus-matches-options-n group)))
+ (maphash
+ (lambda (g-name active)
+ (unless (or (gethash g-name gnus-killed-hashtb)
+ (gethash g-name gnus-newsrc-hashtb))
+ (let ((do-sub (gnus-matches-options-n g-name)))
(cond
((eq do-sub 'subscribe)
(setq groups (1+ groups))
- (gnus-sethash group group gnus-killed-hashtb)
+ (puthash g-name t gnus-killed-hashtb)
(gnus-call-subscribe-functions
- gnus-subscribe-options-newsgroup-method group))
+ gnus-subscribe-options-newsgroup-method g-name))
((eq do-sub 'ignore)
nil)
(t
(setq groups (1+ groups))
- (gnus-sethash group group gnus-killed-hashtb)
+ (puthash g-name t gnus-killed-hashtb)
(if gnus-subscribe-hierarchical-interactive
- (push group new-newsgroups)
+ (push g-name new-newsgroups)
(gnus-call-subscribe-functions
- gnus-subscribe-newsgroup-method group)))))))
+ gnus-subscribe-newsgroup-method g-name)))))))
gnus-active-hashtb)
(when new-newsgroups
(gnus-subscribe-hierarchical-interactive new-newsgroups))
@@ -1214,36 +1200,32 @@ for new groups, and subscribe the new groups as zombies."
;; Enter all the new groups into a hashtable.
(gnus-active-to-gnus-format method hashtb 'ignore))
;; Now all new groups from `method' are in `hashtb'.
- (mapatoms
- (lambda (group-sym)
- (if (or (null (setq group (symbol-name group-sym)))
- (not (boundp group-sym))
- (null (symbol-value group-sym))
- (gnus-gethash group gnus-newsrc-hashtb)
- (member group gnus-zombie-list)
- (member group gnus-killed-list))
- ;; The group is already known.
- ()
+ (maphash
+ (lambda (g-name val)
+ (unless (or (null val) ; The group is already known.
+ (gethash g-name gnus-newsrc-hashtb)
+ (member g-name gnus-zombie-list)
+ (member g-name gnus-killed-list))
;; Make this group active.
- (when (symbol-value group-sym)
- (gnus-set-active group (symbol-value group-sym)))
+ (when val
+ (gnus-set-active g-name val))
;; Check whether we want it or not.
- (let ((do-sub (gnus-matches-options-n group)))
+ (let ((do-sub (gnus-matches-options-n g-name)))
(cond
((eq do-sub 'subscribe)
- (incf groups)
- (gnus-sethash group group gnus-killed-hashtb)
+ (cl-incf groups)
+ (puthash g-name group gnus-killed-hashtb)
(gnus-call-subscribe-functions
- gnus-subscribe-options-newsgroup-method group))
+ gnus-subscribe-options-newsgroup-method g-name))
((eq do-sub 'ignore)
nil)
(t
- (incf groups)
- (gnus-sethash group group gnus-killed-hashtb)
+ (cl-incf groups)
+ (puthash g-name group gnus-killed-hashtb)
(if gnus-subscribe-hierarchical-interactive
- (push group new-newsgroups)
+ (push g-name new-newsgroups)
(gnus-call-subscribe-functions
- gnus-subscribe-newsgroup-method group)))))))
+ gnus-subscribe-newsgroup-method g-name)))))))
hashtb))
(when new-newsgroups
(gnus-subscribe-hierarchical-interactive new-newsgroups)))
@@ -1264,29 +1246,28 @@ for new groups, and subscribe the new groups as zombies."
gnus-level-default-subscribed gnus-level-killed previous t)
t)
-;; `gnus-group-change-level' is the fundamental function for changing
-;; subscription levels of newsgroups. This might mean just changing
-;; from level 1 to 2, which is pretty trivial, from 2 to 6 or back
-;; again, which subscribes/unsubscribes a group, which is equally
-;; trivial. Changing from 1-7 to 8-9 means that you kill a group, and
-;; from 8-9 to 1-7 means that you remove the group from the list of
-;; killed (or zombie) groups and add them to the (kinda) subscribed
-;; groups. And last but not least, moving from 8 to 9 and 9 to 8,
-;; which is trivial.
-;; ENTRY can either be a string (newsgroup name) or a list (if
-;; FROMKILLED is t, it's a list on the format (NUM INFO-LIST),
-;; otherwise it's a list in the format of the `gnus-newsrc-hashtb'
-;; entries.
-;; LEVEL is the new level of the group, OLDLEVEL is the old level and
-;; PREVIOUS is the group (in hashtb entry format) to insert this group
-;; after.
+
(defun gnus-group-change-level (entry level &optional oldlevel
previous fromkilled)
+ "Change level of group ENTRY to LEVEL.
+This is the fundamental function for changing subscription levels
+of newsgroups. This might mean just changing from level 1 to 2,
+which is pretty trivial, from 2 to 6 or back again, which
+subscribes/unsubscribes a group, which is equally trivial.
+Changing from 1-7 to 8-9 means that you kill a group, and from
+8-9 to 1-7 means that you remove the group from the list of
+killed (or zombie) groups and add them to the (kinda) subscribed
+groups. And last but not least, moving from 8 to 9 and 9 to 8,
+which is trivial. ENTRY can either be a string (newsgroup name)
+or a list (if FROMKILLED is t, it's a list on the format (NUM
+INFO-LIST), otherwise it's a list in the format of the
+`gnus-newsrc-hashtb' entries. LEVEL is the new level of the
+group, OLDLEVEL is the old level and PREVIOUS is the group (a
+string name) to insert this group after."
(let (group info active num)
- ;; Glean what info we can from the arguments
+ ;; Glean what info we can from the arguments.
(if (consp entry)
- (if fromkilled (setq group (nth 1 entry))
- (setq group (car (nth 2 entry))))
+ (setq group (if fromkilled (nth 1 entry) (car (nth 1 entry))))
(setq group entry))
(when (and (stringp entry)
oldlevel
@@ -1294,21 +1275,17 @@ for new groups, and subscribe the new groups as zombies."
(setq entry (gnus-group-entry entry)))
(if (and (not oldlevel)
(consp entry))
- (setq oldlevel (gnus-info-level (nth 2 entry)))
+ (setq oldlevel (gnus-info-level (nth 1 entry)))
(setq oldlevel (or oldlevel gnus-level-killed)))
(when (stringp previous)
(setq previous (gnus-group-entry previous)))
-
- (if (and (>= oldlevel gnus-level-zombie)
- (gnus-group-entry group))
- ;; We are trying to subscribe a group that is already
- ;; subscribed.
- () ; Do nothing.
-
+ ;; Group is already subscribed.
+ (unless (and (>= oldlevel gnus-level-zombie)
+ (gnus-group-entry group))
(unless (gnus-ephemeral-group-p group)
(gnus-dribble-enter
(format "(gnus-group-change-level %S %S %S %S %S)"
- group level oldlevel (car (nth 2 previous)) fromkilled)))
+ group level oldlevel previous fromkilled)))
;; Then we remove the newgroup from any old structures, if needed.
;; If the group was killed, we remove it from the killed or zombie
@@ -1322,11 +1299,10 @@ for new groups, and subscribe the new groups as zombies."
(t
(when (and (>= level gnus-level-zombie)
entry)
- (gnus-sethash (car (nth 2 entry)) nil gnus-newsrc-hashtb)
- (when (nth 3 entry)
- (setcdr (gnus-group-entry (car (nth 3 entry)))
- (cdr entry)))
- (setcdr (cdr entry) (cdddr entry)))))
+ (remhash (car (nth 1 entry)) gnus-newsrc-hashtb)
+ (setq gnus-group-list (remove group gnus-group-list))
+ (setq gnus-newsrc-alist (delq (assoc group gnus-newsrc-alist)
+ gnus-newsrc-alist)))))
;; Finally we enter (if needed) the list where it is supposed to
;; go, and change the subscription level. If it is to be killed,
@@ -1334,12 +1310,13 @@ for new groups, and subscribe the new groups as zombies."
(cond
((>= level gnus-level-zombie)
;; Remove from the hash table.
- (gnus-sethash group nil gnus-newsrc-hashtb)
+ (remhash group gnus-newsrc-hashtb)
+ (setq gnus-group-list (remove group gnus-group-list))
(if (= level gnus-level-zombie)
(push group gnus-zombie-list)
(if (= oldlevel gnus-level-killed)
;; Remove from active hashtb.
- (unintern group gnus-active-hashtb)
+ (remhash group gnus-active-hashtb)
;; Don't add it into killed-list if it was killed.
(push group gnus-killed-list))))
(t
@@ -1350,7 +1327,7 @@ for new groups, and subscribe the new groups as zombies."
;; It was alive, and it is going to stay alive, so we
;; just change the level and don't change any pointers or
;; hash table entries.
- (setcar (cdaddr entry) level)
+ (setcar (cdadr entry) level)
(if (listp entry)
(setq info (cdr entry)
num (car entry))
@@ -1365,23 +1342,16 @@ for new groups, and subscribe the new groups as zombies."
(if method
(setq info (list group level nil nil method))
(setq info (list group level nil)))))
- (unless previous
- (setq previous
- (let ((p gnus-newsrc-alist))
- (while (cddr p)
- (setq p (cdr p)))
- p)))
- (setq entry (cons info (cddr previous)))
- (if (cdr previous)
- (progn
- (setcdr (cdr previous) entry)
- (gnus-sethash group (cons num (cdr previous))
- gnus-newsrc-hashtb))
- (setcdr previous entry)
- (gnus-sethash group (cons num previous)
- gnus-newsrc-hashtb))
- (when (cdr entry)
- (setcdr (gnus-group-entry (caadr entry)) entry))
+ ;; Add group. The exact ordering only matters for
+ ;; `gnus-group-list', though we need to keep the dummy group
+ ;; at the head of `gnus-newsrc-alist'.
+ (push info (cdr gnus-newsrc-alist))
+ (puthash group (list num info) gnus-newsrc-hashtb)
+ (let* ((prev-idx (seq-position gnus-group-list (caadr previous)))
+ (idx (if prev-idx
+ (1+ prev-idx)
+ (length gnus-group-list))))
+ (push group (nthcdr idx gnus-group-list)))
(gnus-dribble-enter
(format "(gnus-group-set-info '%S)" info)
(concat "^(gnus-group-set-info '(\"" (regexp-quote group) "\"")))))
@@ -1456,7 +1426,7 @@ newsgroup."
(defun gnus-cache-possibly-alter-active (group active)
"Alter the ACTIVE info for GROUP to reflect the articles in the cache."
(when gnus-cache-active-hashtb
- (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb)))
+ (let ((cache-active (gethash group gnus-cache-active-hashtb)))
(when cache-active
(when (< (car cache-active) (car active))
(setcar active (car cache-active)))
@@ -1700,7 +1670,7 @@ backend check whether the group actually exists."
;; aren't equal (and that need extension; i.e., they are async).
(let ((methods nil))
(dolist (elem type-cache)
- (destructuring-bind (method method-type infos dummy) elem
+ (cl-destructuring-bind (method method-type infos dummy) elem
(let ((gnus-opened-servers methods))
(when (and (gnus-similar-server-opened method)
(gnus-check-backend-function
@@ -1723,7 +1693,7 @@ backend check whether the group actually exists."
;; Clear out all the early methods.
(dolist (elem type-cache)
- (destructuring-bind (method method-type infos dummy) elem
+ (cl-destructuring-bind (method method-type infos dummy) elem
(when (and method
infos
(gnus-check-backend-function
@@ -1740,7 +1710,7 @@ backend check whether the group actually exists."
(let ((done-methods nil)
sanity-spec)
(dolist (elem type-cache)
- (destructuring-bind (method method-type infos dummy) elem
+ (cl-destructuring-bind (method method-type infos dummy) elem
(setq sanity-spec (list (car method) (cadr method)))
(when (and method infos
(not (gnus-method-denied-p method)))
@@ -1771,7 +1741,7 @@ backend check whether the group actually exists."
;; Do the rest of the retrieval.
(dolist (elem type-cache)
- (destructuring-bind (method method-type infos early-data) elem
+ (cl-destructuring-bind (method method-type infos early-data) elem
(when (and method infos
(not (gnus-method-denied-p method)))
(let ((updatep (gnus-check-backend-function
@@ -1795,11 +1765,11 @@ backend check whether the group actually exists."
;; are in the secondary select list.
((eq type 'secondary)
(let ((i 2))
- (block nil
- (dolist (smethod gnus-secondary-select-methods)
+ (cl-block nil
+ (cl-dolist (smethod gnus-secondary-select-methods)
(when (equal method smethod)
- (return i))
- (incf i))
+ (cl-return i))
+ (cl-incf i))
i)))
;; Just say that all foreign groups have the same rank.
(t
@@ -1838,19 +1808,24 @@ backend check whether the group actually exists."
(dolist (info infos)
(gnus-activate-group (gnus-info-group info) nil nil method t))))))
-;; Create a hash table out of the newsrc alist. The `car's of the
-;; alist elements are used as keys.
(defun gnus-make-hashtable-from-newsrc-alist ()
+ "Create a hash table from `gnus-newsrc-alist'.
+The keys are group names, and values are a cons of (unread info),
+where unread is an integer count of calculated unread
+messages (or nil), and info is a regular gnus info entry.
+
+The info element is shared with the same element of
+`gnus-newrc-alist', so as to conserve space."
(let ((alist gnus-newsrc-alist)
(ohashtb gnus-newsrc-hashtb)
- prev info method rest methods)
+ info method gname rest methods)
(setq gnus-newsrc-hashtb (gnus-make-hashtable (length alist)))
(setq alist
- (setq prev (setq gnus-newsrc-alist
- (if (equal (caar gnus-newsrc-alist)
- "dummy.group")
- gnus-newsrc-alist
- (cons (list "dummy.group" 0 nil) alist)))))
+ (setq gnus-newsrc-alist
+ (if (equal (caar gnus-newsrc-alist)
+ "dummy.group")
+ gnus-newsrc-alist
+ (cons (list "dummy.group" 0 nil) alist))))
(while alist
(setq info (car alist))
;; Make the same select-methods identical Lisp objects.
@@ -1859,17 +1834,18 @@ backend check whether the group actually exists."
(gnus-info-set-method info (car rest))
(push method methods)))
;; Check for duplicates.
- (if (gnus-gethash (car info) gnus-newsrc-hashtb)
+ (if (gethash (car info) gnus-newsrc-hashtb)
;; Remove this entry from the alist.
- (setcdr prev (cddr prev))
- (gnus-sethash
+ (setcdr alist (cddr alist))
+ (puthash
(car info)
;; Preserve number of unread articles in groups.
- (cons (and ohashtb (car (gnus-gethash (car info) ohashtb)))
- prev)
+ (list (and ohashtb (car (gethash (car info) ohashtb)))
+ info)
gnus-newsrc-hashtb)
- (setq prev alist))
+ (push (car info) gnus-group-list))
(setq alist (cdr alist)))
+ (setq gnus-group-list (nreverse gnus-group-list))
;; Make the same select-methods in `gnus-server-alist' identical
;; as well.
(while methods
@@ -1884,10 +1860,10 @@ backend check whether the group actually exists."
(setq gnus-killed-hashtb
(gnus-make-hashtable
(+ (length gnus-killed-list) (length gnus-zombie-list))))
- (while lists
- (setq list (symbol-value (pop lists)))
- (while list
- (gnus-sethash (car list) (pop list) gnus-killed-hashtb)))))
+ (dolist (g (append gnus-killed-list gnus-zombie-list))
+ ;; NOTE: We have lost the ordering that used to be kept in this
+ ;; variable.
+ (puthash g t gnus-killed-hashtb))))
(defun gnus-parse-active ()
"Parse active info in the nntp server buffer."
@@ -1901,7 +1877,7 @@ backend check whether the group actually exists."
(defun gnus-make-articles-unread (group articles)
"Mark ARTICLES in GROUP as unread."
- (let* ((info (nth 2 (or (gnus-group-entry group)
+ (let* ((info (nth 1 (or (gnus-group-entry group)
(gnus-group-entry
(gnus-group-real-name group)))))
(ranges (gnus-info-read info))
@@ -1925,7 +1901,7 @@ backend check whether the group actually exists."
"Mark ascending ARTICLES in GROUP as unread."
(let* ((entry (or (gnus-group-entry group)
(gnus-group-entry (gnus-group-real-name group))))
- (info (nth 2 entry))
+ (info (nth 1 entry))
(ranges (gnus-info-read info))
(r ranges)
modified)
@@ -1988,17 +1964,11 @@ backend check whether the group actually exists."
;; Insert the change into the group buffer and the dribble file.
(gnus-group-update-group group t))))
-;; Enter all dead groups into the hashtb.
(defun gnus-update-active-hashtb-from-killed ()
- (let ((hashtb (setq gnus-active-hashtb (gnus-make-hashtable 4096)))
- (lists (list gnus-killed-list gnus-zombie-list))
- killed)
- (while lists
- (setq killed (car lists))
- (while killed
- (gnus-sethash (string-as-unibyte (car killed)) nil hashtb)
- (setq killed (cdr killed)))
- (setq lists (cdr lists)))))
+ (let ((hashtb (setq gnus-active-hashtb
+ (gnus-make-hashtable 4000))))
+ (dolist (g (append gnus-killed-list gnus-zombie-list))
+ (remhash g hashtb))))
(defun gnus-get-killed-groups ()
"Go through the active hashtb and mark all unknown groups as killed."
@@ -2009,20 +1979,16 @@ backend check whether the group actually exists."
(unless gnus-killed-hashtb
(gnus-make-hashtable-from-killed))
;; Go through all newsgroups that are known to Gnus - enlarge kill list.
- (mapatoms
- (lambda (sym)
- (let ((groups 0)
- (group (symbol-name sym)))
- (if (or (null group)
- (gnus-gethash group gnus-killed-hashtb)
- (gnus-gethash group gnus-newsrc-hashtb))
- ()
- (let ((do-sub (gnus-matches-options-n group)))
- (if (or (eq do-sub 'subscribe) (eq do-sub 'ignore))
- ()
+ (maphash
+ (lambda (g-name active)
+ (let ((groups 0))
+ (unless (or (gethash g-name gnus-killed-hashtb)
+ (gethash g-name gnus-newsrc-hashtb))
+ (let ((do-sub (gnus-matches-options-n g-name)))
+ (unless (or (eq do-sub 'subscribe) (eq do-sub 'ignore))
(setq groups (1+ groups))
- (push group gnus-killed-list)
- (gnus-sethash group group gnus-killed-hashtb))))))
+ (push g-name gnus-killed-list)
+ (puthash g-name t gnus-killed-hashtb))))))
gnus-active-hashtb)
(gnus-dribble-touch))
@@ -2135,11 +2101,13 @@ backend check whether the group actually exists."
(not (equal method gnus-select-method)))
gnus-active-hashtb
(setq gnus-active-hashtb
- (if (equal method gnus-select-method)
- (gnus-make-hashtable
- (count-lines (point-min) (point-max)))
- (gnus-make-hashtable 4096))))))
+ (gnus-make-hashtable
+ (if (equal method gnus-select-method)
+ (count-lines (point-min) (point-max))
+ 4000))))))
group max min)
+ (unless gnus-moderated-hashtb
+ (setq gnus-moderated-hashtb (gnus-make-hashtable 100)))
;; Delete unnecessary lines.
(goto-char (point-min))
(cond
@@ -2149,12 +2117,6 @@ backend check whether the group actually exists."
(delete-matching-lines (concat "^to\\.\\|" gnus-ignored-newsgroups))))
(goto-char (point-min))
- (unless (re-search-forward "[\\\"]" nil t)
- ;; Make the group names readable as a lisp expression even if they
- ;; contain special characters.
- (goto-char (point-max))
- (while (re-search-backward "[][';?()#]" nil t)
- (insert ?\\)))
;; Let the Gnus agent save the active file.
(when (and gnus-agent real-active (gnus-online method))
@@ -2174,49 +2136,41 @@ backend check whether the group actually exists."
(insert prefix)
(zerop (forward-line 1)))))))
;; Store the active file in a hash table.
- ;; Use a unibyte buffer in order to make `read' read non-ASCII
- ;; group names (which have been encoded) as unibyte strings.
- (mm-with-unibyte-buffer
+
+ (with-temp-buffer
(insert-buffer-substring cur)
(setq cur (current-buffer))
(goto-char (point-min))
(while (not (eobp))
(condition-case ()
- (progn
- (narrow-to-region (point) (point-at-eol))
- ;; group gets set to a symbol interned in the hash table
- ;; (what a hack!!) - jwz
- (setq group (let ((obarray hashtb)) (read cur)))
- ;; ### The extended group name scheme makes
- ;; the previous optimization strategy sort of pointless...
- (when (stringp group)
- (setq group (intern group hashtb)))
- (if (and (numberp (setq max (read cur)))
- (numberp (setq min (read cur)))
- (progn
- (skip-chars-forward " \t")
- (not
- (or (eq (char-after) ?=)
- (eq (char-after) ?x)
- (eq (char-after) ?j)))))
- (progn
- (set group (cons min max))
- ;; if group is moderated, stick in moderation table
- (when (eq (char-after) ?m)
- (unless gnus-moderated-hashtb
- (setq gnus-moderated-hashtb (gnus-make-hashtable)))
- (gnus-sethash (symbol-name group) t
- gnus-moderated-hashtb)))
- (set group nil)))
+ (if (and (stringp (progn
+ (setq group (read cur)
+ group
+ (encode-coding-string
+ (cond ((numberp group)
+ (number-to-string group))
+ ((symbolp group)
+ (symbol-name group))
+ ((stringp group)
+ group))
+ 'latin-1))))
+ (numberp (setq max (read cur)))
+ (numberp (setq min (read cur)))
+ (null (progn
+ (skip-chars-forward " \t")
+ (memq (char-after)
+ '(?= ?x ?j)))))
+ (progn (puthash group (cons min max) hashtb)
+ ;; If group is moderated, stick it in the
+ ;; moderation cache.
+ (when (eq (char-after) ?m)
+ (puthash group t gnus-moderated-hashtb)))
+ (setq group nil))
(error
- (and group
- (symbolp group)
- (set group nil))
(unless ignore-errors
(gnus-message 3 "Warning - invalid active: %s"
(buffer-substring
(point-at-bol) (point-at-eol))))))
- (widen)
(forward-line 1)))))
(defun gnus-groups-to-gnus-format (method &optional hashtb real-active)
@@ -2244,35 +2198,23 @@ backend check whether the group actually exists."
(gnus-active-to-gnus-format method hashtb nil real-active))
(goto-char (point-min))
- ;; We split this into to separate loops, one with the prefix
- ;; and one without to speed the reading up somewhat.
- (if prefix
- (let (min max opoint group)
- (while (not (eobp))
- (condition-case ()
- (progn
- (read cur) (read cur)
- (setq min (read cur)
- max (read cur)
- opoint (point))
- (skip-chars-forward " \t")
- (insert prefix)
- (goto-char opoint)
- (set (let ((obarray hashtb)) (read cur))
- (cons min max)))
- (error (and group (symbolp group) (set group nil))))
- (forward-line 1)))
- (let (min max group)
- (while (not (eobp))
- (condition-case ()
- (when (eq (char-after) ?2)
- (read cur) (read cur)
- (setq min (read cur)
- max (read cur))
- (set (setq group (let ((obarray hashtb)) (read cur)))
- (cons min max)))
- (error (and group (symbolp group) (set group nil))))
- (forward-line 1)))))))
+ (let (min max group)
+ (while (not (eobp))
+ (condition-case ()
+ (when (eq (char-after) ?2)
+ (read cur) (read cur)
+ (setq min (read cur)
+ max (read cur)
+ group (read cur)
+ group (if (numberp group)
+ (number-to-string group)
+ (symbol-name group)))
+ (puthash (if prefix
+ (concat prefix group)
+ group)
+ (cons min max) hashtb))
+ (error (remhash group hashtb)))
+ (forward-line 1))))))
(defun gnus-read-newsrc-file (&optional force)
"Read startup file.
@@ -2456,10 +2398,6 @@ If FORCE is non-nil, the .newsrc file is read."
(setq gnus-format-specs gnus-default-format-specs)))
(when gnus-newsrc-assoc
(setq gnus-newsrc-alist gnus-newsrc-assoc))))
- (dolist (elem gnus-newsrc-alist)
- ;; Protect against broken .newsrc.el files.
- (when (car elem)
- (setcar elem (string-as-unibyte (car elem)))))
(gnus-make-hashtable-from-newsrc-alist)
(when (file-newer-than-file-p file ding-file)
;; Old format quick file
@@ -2539,16 +2477,11 @@ If FORCE is non-nil, the .newsrc file is read."
(setq gnus-newsrc-options-n nil)
(unless gnus-active-hashtb
- (setq gnus-active-hashtb (gnus-make-hashtable 4096)))
+ (setq gnus-active-hashtb (gnus-make-hashtable 4000)))
(let ((buf (current-buffer))
(already-read (> (length gnus-newsrc-alist) 1))
- group subscribed options-symbol newsrc Options-symbol
- symbol reads num1)
+ group subscribed newsrc reads num1)
(goto-char (point-min))
- ;; We intern the symbol `options' in the active hashtb so that we
- ;; can `eq' against it later.
- (set (setq options-symbol (intern "options" gnus-active-hashtb)) nil)
- (set (setq Options-symbol (intern "Options" gnus-active-hashtb)) nil)
(while (not (eobp))
;; We first read the first word on the line by narrowing and
@@ -2559,15 +2492,16 @@ If FORCE is non-nil, the .newsrc file is read."
(point)
(progn (skip-chars-forward "^ \t!:\n") (point)))
(goto-char (point-min))
- (setq symbol
+ (setq group
(and (/= (point-min) (point-max))
- (let ((obarray gnus-active-hashtb)) (read buf))))
+ (read buf))
+ group (if (numberp group)
+ (number-to-string group)
+ (symbol-name group)))
(widen)
- ;; Now, the symbol we have read is either `options' or a group
- ;; name. If it is an options line, we just add it to a string.
(cond
- ((or (eq symbol options-symbol)
- (eq symbol Options-symbol))
+ ;; It's possible that "group" is actually an options line.
+ ((string-equal (downcase group) "options")
(setq gnus-newsrc-options
;; This concatting is quite inefficient, but since our
;; thorough studies show that approx 99.37% of all
@@ -2581,19 +2515,13 @@ If FORCE is non-nil, the .newsrc file is read."
(point-at-bol))
(point)))))
(forward-line -1))
- (symbol
- ;; Group names can be just numbers.
- (when (numberp symbol)
- (setq symbol (intern (int-to-string symbol) gnus-active-hashtb)))
- (unless (boundp symbol)
- (set symbol nil))
+ (group
;; It was a group name.
(setq subscribed (eq (char-after) ?:)
- group (symbol-name symbol)
reads nil)
(if (eolp)
;; If the line ends here, this is clearly a buggy line, so
- ;; we put point a the beginning of line and let the cond
+ ;; we put point at the beginning of line and let the cond
;; below do the error handling.
(beginning-of-line)
;; We skip to the beginning of the ranges.
@@ -2632,7 +2560,7 @@ If FORCE is non-nil, the .newsrc file is read."
;; It was just a simple number, so we add it to the
;; list of ranges.
(push num1 reads))
- ;; If the next char in ?\n, then we have reached the end
+ ;; If the next char is ?\n, then we have reached the end
;; of the line and return nil.
(not (eq (char-after) ?\n)))
((eq (char-after) ?\n)
@@ -2661,7 +2589,8 @@ If FORCE is non-nil, the .newsrc file is read."
(let ((info (gnus-get-info group))
level)
(if info
- ;; There is an entry for this file in the alist.
+ ;; There is an entry for this file in
+ ;; `gnus-newsrc-hashtb'.
(progn
(gnus-info-set-read info (nreverse reads))
;; We update the level very gently. In fact, we
@@ -2689,8 +2618,7 @@ If FORCE is non-nil, the .newsrc file is read."
(setq newsrc (nreverse newsrc))
- (if (not already-read)
- ()
+ (unless already-read
;; We now have two newsrc lists - `newsrc', which is what we
;; have read from .newsrc, and `gnus-newsrc-alist', which is
;; what we've read from .newsrc.eld. We have to merge these
@@ -2787,9 +2715,10 @@ If FORCE is non-nil, the .newsrc file is read."
(defvar gnus-save-newsrc-file-last-timestamp nil)
(defun gnus-save-newsrc-file (&optional force)
- "Save .newsrc file."
- ;; Note: We cannot save .newsrc file if all newsgroups are removed
- ;; from the variable gnus-newsrc-alist.
+ "Save .newsrc file.
+Use the group string names in `gnus-group-list' to pull info
+values from `gnus-newsrc-hashtb', and write a new value of
+`gnus-newsrc-alist'."
(when (and (or gnus-newsrc-alist gnus-killed-list)
gnus-current-startup-file)
;; Save agent range limits for the currently active method.
@@ -2829,78 +2758,89 @@ If FORCE is non-nil, the .newsrc file is read."
(erase-buffer)
(gnus-message 5 "Saving %s.eld..." gnus-current-startup-file)
- ;; check timestamp of `gnus-current-startup-file'.eld against
- ;; `gnus-save-newsrc-file-last-timestamp'
- (let* ((checkfile (concat gnus-current-startup-file ".eld"))
- (mtime (nth 5 (file-attributes checkfile))))
- (when (and gnus-save-newsrc-file-last-timestamp
- (time-less-p gnus-save-newsrc-file-last-timestamp
- mtime))
- (unless (y-or-n-p
+ ;; Check timestamp of `gnus-current-startup-file'.eld against
+ ;; `gnus-save-newsrc-file-last-timestamp'.
+ (if (let* ((checkfile (concat gnus-current-startup-file ".eld"))
+ (mtime (file-attribute-modification-time
+ (file-attributes checkfile))))
+ (and gnus-save-newsrc-file-last-timestamp
+ (time-less-p gnus-save-newsrc-file-last-timestamp
+ mtime)
+ (not
+ (y-or-n-p
(format "%s was updated externally after %s, save?"
checkfile
(format-time-string
- "%c"
- gnus-save-newsrc-file-last-timestamp)))
- (error "Couldn't save %s: updated externally" checkfile))))
-
- (if gnus-save-startup-file-via-temp-buffer
+ "%c"
+ gnus-save-newsrc-file-last-timestamp))))))
+ (gnus-message
+ 4 "Didn't save %s: updated externally"
+ (concat gnus-current-startup-file ".eld"))
+ (if gnus-save-startup-file-via-temp-buffer
+ (let ((coding-system-for-write gnus-ding-file-coding-system)
+ (standard-output (current-buffer)))
+ (gnus-gnus-to-quick-newsrc-format)
+ (gnus-run-hooks 'gnus-save-quick-newsrc-hook)
+ (save-buffer)
+ (setq gnus-save-newsrc-file-last-timestamp
+ (file-attribute-modification-time
+ (file-attributes buffer-file-name))))
(let ((coding-system-for-write gnus-ding-file-coding-system)
- (standard-output (current-buffer)))
- (gnus-gnus-to-quick-newsrc-format)
- (gnus-run-hooks 'gnus-save-quick-newsrc-hook)
- (save-buffer)
- (setq gnus-save-newsrc-file-last-timestamp
- (nth 5 (file-attributes buffer-file-name))))
- (let ((coding-system-for-write gnus-ding-file-coding-system)
- (version-control gnus-backup-startup-file)
- (startup-file (concat gnus-current-startup-file ".eld"))
- (working-dir (file-name-directory gnus-current-startup-file))
- working-file
- (i -1))
- ;; Generate the name of a non-existent file.
- (while (progn (setq working-file
- (format
- (if (and (eq system-type 'ms-dos)
- (not (gnus-long-file-names)))
- "%s#%d.tm#" ; MSDOS limits files to 8+3
- "%s#tmp#%d")
- working-dir (setq i (1+ i))))
- (file-exists-p working-file)))
-
- (unwind-protect
- (progn
- (gnus-with-output-to-file working-file
- (gnus-gnus-to-quick-newsrc-format)
- (gnus-run-hooks 'gnus-save-quick-newsrc-hook))
-
- ;; These bindings will mislead the current buffer
- ;; into thinking that it is visiting the startup
- ;; file.
- (let ((buffer-backed-up nil)
- (buffer-file-name startup-file)
- (file-precious-flag t)
- (setmodes (file-modes startup-file)))
- ;; Backup the current version of the startup file.
- (backup-buffer)
-
- ;; Replace the existing startup file with the temp file.
- (rename-file working-file startup-file t)
- (gnus-set-file-modes startup-file setmodes)
- (setq gnus-save-newsrc-file-last-timestamp
- (nth 5 (file-attributes startup-file)))))
- (condition-case nil
- (delete-file working-file)
- (file-error nil)))))
-
- (gnus-kill-buffer (current-buffer))
- (gnus-message
- 5 "Saving %s.eld...done" gnus-current-startup-file))
+ (version-control gnus-backup-startup-file)
+ (startup-file (concat gnus-current-startup-file ".eld"))
+ (working-dir (file-name-directory gnus-current-startup-file))
+ working-file
+ (i -1))
+ ;; Generate the name of a non-existent file.
+ (while (progn (setq working-file
+ (format
+ (if (and (eq system-type 'ms-dos)
+ (not (gnus-long-file-names)))
+ "%s#%d.tm#" ; MSDOS limits files to 8+3
+ "%s#tmp#%d")
+ working-dir (setq i (1+ i))))
+ (file-exists-p working-file)))
+
+ (unwind-protect
+ (progn
+ (gnus-with-output-to-file working-file
+ (gnus-gnus-to-quick-newsrc-format)
+ (gnus-run-hooks 'gnus-save-quick-newsrc-hook))
+
+ ;; These bindings will mislead the current buffer
+ ;; into thinking that it is visiting the startup
+ ;; file.
+ (let ((buffer-backed-up nil)
+ (buffer-file-name startup-file)
+ (file-precious-flag t)
+ (setmodes (file-modes startup-file)))
+ ;; Backup the current version of the startup file.
+ (backup-buffer)
+
+ ;; Replace the existing startup file with the temp file.
+ (rename-file working-file startup-file t)
+ (gnus-set-file-modes startup-file setmodes)
+ (setq gnus-save-newsrc-file-last-timestamp
+ (file-attribute-modification-time
+ (file-attributes startup-file)))))
+ (condition-case nil
+ (delete-file working-file)
+ (file-error nil)))))
+
+ (gnus-kill-buffer (current-buffer))
+ (gnus-message
+ 5 "Saving %s.eld...done" gnus-current-startup-file)))
(gnus-dribble-delete-file)
(gnus-group-set-mode-line)))))
(defun gnus-gnus-to-quick-newsrc-format (&optional minimal name &rest specific-variables)
- "Print Gnus variables such as `gnus-newsrc-alist' in Lisp format."
+ "Print Gnus variables such as `gnus-newsrc-alist' in Lisp format.
+Unless optional argument MINIMAL is non-nil, print human-readable
+information in the header of the file, including the file
+version. If NAME is present, print that as part of the header.
+
+Variables printed are either the variables specified in
+SPECIFIC-VARIABLES, or those in `gnus-variable-list'."
(princ (format ";; -*- mode:emacs-lisp; coding: %s; -*-\n"
gnus-ding-file-coding-system))
(if name
@@ -2934,9 +2874,18 @@ If FORCE is non-nil, the .newsrc file is read."
;; Remove the `gnus-killed-list' from the list of variables
;; to be saved, if required.
(delq 'gnus-killed-list (copy-sequence gnus-variable-list)))))
- ;; Peel off the "dummy" group.
- (gnus-newsrc-alist (cdr gnus-newsrc-alist))
variable)
+ ;; A bit of a fake-out here: the original value of
+ ;; `gnus-newsrc-alist' isn't written to file, instead it is
+ ;; constructed at the last minute by combining the group
+ ;; ordering in `gnus-group-list' with the group infos from
+ ;; `gnus-newsrc-hashtb'.
+ (set (nth (seq-position gnus-variable-list 'gnus-newsrc-alist)
+ gnus-variable-list)
+ (mapcar (lambda (g)
+ (nth 1 (gethash g gnus-newsrc-hashtb)))
+ (delete "dummy.group" gnus-group-list)))
+
;; Insert the variables into the file.
(while variables
(when (and (boundp (setq variable (pop variables)))
@@ -2961,8 +2910,8 @@ If FORCE is non-nil, the .newsrc file is read."
(interactive (list (gnus-y-or-n-p "write foreign groups too? ")))
;; Generate and save the .newsrc file.
(with-current-buffer (create-file-buffer gnus-current-startup-file)
- (let ((newsrc (cdr gnus-newsrc-alist))
- (standard-output (current-buffer))
+ (let ((standard-output (current-buffer))
+ (groups (delete "dummy.group" (copy-sequence gnus-group-list)))
info ranges range method)
(setq buffer-file-name gnus-current-startup-file)
(setq default-directory (file-name-directory buffer-file-name))
@@ -2976,13 +2925,14 @@ If FORCE is non-nil, the .newsrc file is read."
(when gnus-newsrc-options
(insert gnus-newsrc-options))
;; Write subscribed and unsubscribed.
- (while (setq info (pop newsrc))
- ;; Don't write foreign groups to .newsrc.
+ (dolist (g-name groups)
+ (setq info (nth 1 (gnus-group-entry g-name)))
+ ;; Maybe don't write foreign groups to .newsrc.
(when (or (null (setq method (gnus-info-method info)))
(equal method "native")
(inline (gnus-server-equal method gnus-select-method))
foreign-ok)
- (insert (gnus-info-group info)
+ (insert g-name
(if (> (gnus-info-level info) gnus-level-subscribed)
"!" ":"))
(when (setq ranges (gnus-info-read info))
@@ -3061,11 +3011,12 @@ If FORCE is non-nil, the .newsrc file is read."
(with-current-buffer (gnus-get-buffer-create " *gnus slave*")
(setq slave-files
(sort (mapcar (lambda (file)
- (list (nth 5 (file-attributes file)) file))
+ (list (file-attribute-modification-time
+ (file-attributes file))
+ file))
slave-files)
(lambda (f1 f2)
- (or (< (caar f1) (caar f2))
- (< (nth 1 (car f1)) (nth 1 (car f2)))))))
+ (time-less-p (car f1) (car f2)))))
(while slave-files
(erase-buffer)
(setq file (nth 1 (car slave-files)))
@@ -3109,10 +3060,10 @@ If FORCE is non-nil, the .newsrc file is read."
;; to avoid trying to re-read after a failed read.
(unless gnus-description-hashtb
(setq gnus-description-hashtb
- (gnus-make-hashtable (length gnus-active-hashtb))))
+ (gnus-make-hashtable (hash-table-size gnus-active-hashtb))))
;; Mark this method's desc file as read.
- (gnus-sethash (gnus-group-prefixed-name "" method) "Has read"
- gnus-description-hashtb)
+ (puthash (gnus-group-prefixed-name "" method) "Has read"
+ gnus-description-hashtb)
(gnus-message 5 "Reading descriptions file via %s..." (car method))
(cond
@@ -3148,29 +3099,26 @@ If FORCE is non-nil, the .newsrc file is read."
(zerop (forward-line 1)))))))
(goto-char (point-min))
(while (not (eobp))
- ;; If we get an error, we set group to 0, which is not a
- ;; symbol...
(setq group
(condition-case ()
- (let ((obarray gnus-description-hashtb))
- ;; Group is set to a symbol interned in this
- ;; hash table.
- (read nntp-server-buffer))
- (error 0)))
+ (read nntp-server-buffer)
+ (error nil)))
(skip-chars-forward " \t")
- ;; ... which leads to this line being effectively ignored.
- (when (symbolp group)
+ (when group
+ (setq group (if (numberp group)
+ (number-to-string group)
+ (symbol-name group)))
(let* ((str (buffer-substring
(point) (progn (end-of-line) (point))))
- (name (symbol-name group))
(charset
- (or (gnus-group-name-charset method name)
- (gnus-parameter-charset name)
+ (or (gnus-group-name-charset method group)
+ (gnus-parameter-charset group)
gnus-default-charset)))
;; Fixme: Don't decode in unibyte mode.
+ ;; Double fixme: We're not in unibyte mode, are we?
(when (and str charset)
(setq str (decode-coding-string str charset)))
- (set group str)))
+ (puthash group str gnus-description-hashtb)))
(forward-line 1))))
(gnus-message 5 "Reading descriptions file...done")
t))))
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index 9c95934ee02..b8aa302f11a 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -24,10 +24,37 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(require 'cl-lib)
(defvar tool-bar-mode)
+(defvar gnus-category-predicate-alist)
+(defvar gnus-category-predicate-cache)
+(defvar gnus-inhibit-article-treatments)
+(defvar gnus-inhibit-demon)
+(defvar gnus-tmp-article-number)
+(defvar gnus-tmp-closing-bracket)
+(defvar gnus-tmp-current)
+(defvar gnus-tmp-dummy)
+(defvar gnus-tmp-expirable)
+(defvar gnus-tmp-from)
+(defvar gnus-tmp-group-name)
(defvar gnus-tmp-header)
+(defvar gnus-tmp-indentation)
+(defvar gnus-tmp-level)
+(defvar gnus-tmp-lines)
+(defvar gnus-tmp-number)
+(defvar gnus-tmp-opening-bracket)
+(defvar gnus-tmp-process)
+(defvar gnus-tmp-replied)
+(defvar gnus-tmp-score)
+(defvar gnus-tmp-score-char)
+(defvar gnus-tmp-subject)
+(defvar gnus-tmp-subject-or-nil)
+(defvar gnus-tmp-unread)
+(defvar gnus-tmp-unread-and-unselected)
+(defvar gnus-tmp-unread-and-unticked)
+(defvar gnus-tmp-user-defined)
+(defvar gnus-use-article-prefetch)
(require 'gnus)
(require 'gnus-group)
@@ -39,6 +66,8 @@
(require 'gmm-utils)
(require 'mm-decode)
(require 'nnoo)
+(eval-when-compile
+ (require 'subr-x))
(autoload 'gnus-summary-limit-include-cached "gnus-cache" nil t)
(autoload 'gnus-cache-write-active "gnus-cache")
@@ -782,7 +811,7 @@ score file."
:group 'gnus-score-default
:type 'integer)
-(defun gnus-widget-reversible-match (widget value)
+(defun gnus-widget-reversible-match (_widget value)
"Ignoring WIDGET, convert VALUE to internal form.
VALUE should have the form `FOO' or `(not FOO)', where FOO is an symbol."
;; (debug value)
@@ -792,7 +821,7 @@ VALUE should have the form `FOO' or `(not FOO)', where FOO is an symbol."
(eq (nth 0 value) 'not)
(symbolp (nth 1 value)))))
-(defun gnus-widget-reversible-to-internal (widget value)
+(defun gnus-widget-reversible-to-internal (_widget value)
"Ignoring WIDGET, convert VALUE to internal form.
VALUE should have the form `FOO' or `(not FOO)', where FOO is an atom.
FOO is converted to (FOO nil) and (not FOO) is converted to (FOO t)."
@@ -801,7 +830,7 @@ FOO is converted to (FOO nil) and (not FOO) is converted to (FOO t)."
(list value nil)
(list (nth 1 value) t)))
-(defun gnus-widget-reversible-to-external (widget value)
+(defun gnus-widget-reversible-to-external (_widget value)
"Ignoring WIDGET, convert VALUE to external form.
VALUE should have the form `(FOO nil)' or `(FOO t)', where FOO is an atom.
\(FOO nil) is converted to FOO and (FOO t) is converted to (not FOO)."
@@ -946,13 +975,6 @@ This variable is local to the summary buffers."
:type '(choice (const :tag "off" nil)
integer))
-(defcustom gnus-summary-mode-hook nil
- "A hook for Gnus summary mode.
-This hook is run before any variables are set in the summary buffer."
- :options '(turn-on-gnus-mailing-list-mode gnus-pick-mode)
- :group 'gnus-summary-various
- :type 'hook)
-
(defcustom gnus-summary-menu-hook nil
"Hook run after the creation of the summary mode menu."
:group 'gnus-summary-visual
@@ -1267,9 +1289,13 @@ For example: ((1 . cn-gb-2312) (2 . big5))."
:type 'boolean
:group 'gnus-summary-marks)
-(defcustom gnus-alter-articles-to-read-function nil
- "Function to be called to alter the list of articles to be selected."
- :type '(choice (const nil) function)
+(defcustom gnus-alter-articles-to-read-function
+ (lambda (_group article-list) article-list)
+ "Function to be called to alter the list of articles to be selected.
+This option defaults to a lambda form that simply returns the
+list of articles unchanged. Use `add-function' to set one or
+more custom filter functions."
+ :type 'function
:group 'gnus-summary)
(defcustom gnus-orphan-score nil
@@ -1364,7 +1390,15 @@ the normal Gnus MIME machinery."
(defvar gnus-current-crosspost-group nil)
(defvar gnus-newsgroup-display nil)
-(defvar gnus-newsgroup-dependencies nil)
+(defvar gnus-newsgroup-dependencies nil
+ "A hash table holding dependencies between messages.")
+;; Dependencies are held in a tree structure: a list with the root
+;; message as car, and each immediate child a sublist (perhaps
+;; containing further sublists). Each message is represented as a
+;; vector of headers. Each message's list can be looked up in the
+;; dependency table using the message's Message-ID as the key. The
+;; root key is the string "none".
+
(defvar gnus-newsgroup-adaptive nil)
(defvar gnus-summary-display-article-function nil)
(defvar gnus-summary-highlight-line-function nil
@@ -1378,7 +1412,8 @@ the normal Gnus MIME machinery."
(?A (car (cdr (funcall gnus-extract-address-components gnus-tmp-from)))
?s)
(?a (or (car (funcall gnus-extract-address-components gnus-tmp-from))
- gnus-tmp-from) ?s)
+ gnus-tmp-from)
+ ?s)
(?F gnus-tmp-from ?s)
(?x ,(macroexpand '(mail-header-xref gnus-tmp-header)) ?s)
(?D ,(macroexpand '(mail-header-date gnus-tmp-header)) ?s)
@@ -1390,12 +1425,15 @@ the normal Gnus MIME machinery."
(?k (gnus-summary-line-message-size gnus-tmp-header) ?s)
(?L gnus-tmp-lines ?s)
(?Z (or (nnir-article-rsv (mail-header-number gnus-tmp-header))
- 0) ?d)
+ 0)
+ ?d)
(?G (or (nnir-article-group (mail-header-number gnus-tmp-header))
- "") ?s)
+ "")
+ ?s)
(?g (or (gnus-group-short-name
(nnir-article-group (mail-header-number gnus-tmp-header)))
- "") ?s)
+ "")
+ ?s)
(?O gnus-tmp-downloaded ?c)
(?I gnus-tmp-indentation ?s)
(?T (if (= gnus-tmp-level 0) "" (make-string (frame-width) ? )) ?s)
@@ -1420,18 +1458,19 @@ the normal Gnus MIME machinery."
(?P (gnus-pick-line-number) ?d)
(?B gnus-tmp-thread-tree-header-string ?s)
(user-date (gnus-user-date
- ,(macroexpand '(mail-header-date gnus-tmp-header))) ?s))
+ ,(macroexpand '(mail-header-date gnus-tmp-header)))
+ ?s))
"An alist of format specifications that can appear in summary lines.
These are paired with what variables they correspond with, along with
the type of the variable (string, integer, character, etc).")
(defvar gnus-summary-dummy-line-format-alist
- `((?S gnus-tmp-subject ?s)
+ '((?S gnus-tmp-subject ?s)
(?N gnus-tmp-number ?d)
(?u gnus-tmp-user-defined ?s)))
(defvar gnus-summary-mode-line-format-alist
- `((?G gnus-tmp-group-name ?s)
+ '((?G gnus-tmp-group-name ?s)
(?g (gnus-short-group-name gnus-tmp-group-name) ?s)
(?p (gnus-group-real-name gnus-tmp-group-name) ?s)
(?A gnus-tmp-article-number ?d)
@@ -1665,6 +1704,7 @@ For example:
(eval-when-compile
;; Bind features so that require will believe that gnus-sum has
;; already been loaded (avoids infinite recursion)
+ (with-no-warnings (defvar features)) ;Not just a local variable.
(let ((features (cons 'gnus-sum features)))
(require 'gnus-art)))
@@ -1838,8 +1878,6 @@ increase the score of each group you read."
;;; Gnus summary mode
;;;
-(put 'gnus-summary-mode 'mode-class 'special)
-
(defvar gnus-article-commands-menu)
;; Non-orthogonal keys
@@ -2367,7 +2405,7 @@ increase the score of each group you read."
["Edit current score file" gnus-score-edit-current-scores t]
["Edit score file..." gnus-score-edit-file t]
["Trace score" gnus-score-find-trace t]
- ["Find words" gnus-score-find-favourite-words t]
+ ["Find words" gnus-score-find-favorite-words t]
["Rescore buffer" gnus-summary-rescore t]
["Increase score..." gnus-summary-increase-score t]
["Lower score..." gnus-summary-lower-score t]))))
@@ -2600,7 +2638,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs))))
(easy-menu-define
gnus-summary-post-menu gnus-summary-mode-map ""
- `("Post"
+ '("Post"
["Send a message (mail or news)" gnus-summary-post-news
:help "Compose a new message (mail or news)"]
["Followup" gnus-summary-followup
@@ -2626,6 +2664,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs))))
["Resend message edit" gnus-summary-resend-message-edit t]
["Send bounced mail" gnus-summary-resend-bounced-mail t]
["Send a mail" gnus-summary-mail-other-window t]
+ ["Attach article to outgoing message" gnus-summary-attach-article t]
["Create a local message" gnus-summary-news-other-window t]
["Uuencode and post" gnus-uu-post-news
:help "Post a uuencoded article"]
@@ -2660,7 +2699,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs))))
(easy-menu-define
gnus-summary-misc-menu gnus-summary-mode-map ""
- `("Gnus"
+ '("Gnus"
("Mark Read"
["Mark as read" gnus-summary-mark-as-read-forward t]
["Mark same subject and select"
@@ -2941,6 +2980,8 @@ See `gmm-tool-bar-from-list' for the format of the list."
(defvar image-load-path)
(defvar tool-bar-map)
+(declare-function image-load-path-for-library "image"
+ (library image &optional path no-error))
(defun gnus-summary-make-tool-bar (&optional force)
"Make a summary mode tool bar from `gnus-summary-tool-bar'.
@@ -3045,10 +3086,13 @@ When FORCE, rebuild the tool bar."
(defvar bidi-paragraph-direction)
-(defun gnus-summary-mode (&optional group)
- "Major mode for reading articles.
+(defvar gnus-summary-mode-group nil
+ "Variable for communication with `gnus-summary-mode'.
+Allows the `gnus-newsgroup-name' local variable to be set before
+the summary mode hooks are run.")
-All normal editing commands are switched off.
+(define-derived-mode gnus-summary-mode gnus-mode "Summary"
+ "Major mode for reading articles.
\\<gnus-summary-mode-map>
Each line in this buffer represents one article. To read an
article, you can, for instance, type `\\[gnus-summary-next-page]'. To move forwards
@@ -3065,24 +3109,17 @@ buffer; read the info pages for more information (`\\[gnus-info-find-node]').
The following commands are available:
\\{gnus-summary-mode-map}"
- ;; FIXME: Use define-derived-mode.
- (interactive)
- (kill-all-local-variables)
(let ((gnus-summary-local-variables gnus-newsgroup-variables))
(gnus-summary-make-local-variables))
(gnus-summary-make-local-variables)
- (setq gnus-newsgroup-name group)
+ (setq gnus-newsgroup-name gnus-summary-mode-group)
(when (gnus-visual-p 'summary-menu 'menu)
(gnus-summary-make-menu-bar)
(gnus-summary-make-tool-bar))
(gnus-make-thread-indent-array)
(gnus-simplify-mode-line)
- (setq major-mode 'gnus-summary-mode)
- (setq mode-name "Summary")
- (use-local-map gnus-summary-mode-map)
(buffer-disable-undo)
- (setq buffer-read-only t
- show-trailing-whitespace nil
+ (setq show-trailing-whitespace nil
truncate-lines t
bidi-paragraph-direction 'left-to-right)
(add-to-invisibility-spec '(gnus-sum . t))
@@ -3093,29 +3130,26 @@ The following commands are available:
(make-local-variable 'gnus-summary-dummy-line-format)
(make-local-variable 'gnus-summary-dummy-line-format-spec)
(make-local-variable 'gnus-summary-mark-positions)
+ (make-local-variable 'gnus-article-buffer)
+ (make-local-variable 'gnus-article-current)
+ (make-local-variable 'gnus-original-article-buffer)
(add-hook 'pre-command-hook 'gnus-set-global-variables nil t)
- (gnus-run-mode-hooks 'gnus-summary-mode-hook)
- (turn-on-gnus-mailing-list-mode)
(mm-enable-multibyte)
(set (make-local-variable 'bookmark-make-record-function)
- 'gnus-summary-bookmark-make-record)
- (gnus-update-format-specifications nil 'summary 'summary-mode 'summary-dummy)
- (gnus-update-summary-mark-positions))
+ 'gnus-summary-bookmark-make-record))
(defun gnus-summary-make-local-variables ()
"Make all the local summary buffer variables."
- (let (global)
- (dolist (local gnus-summary-local-variables)
- (if (consp local)
- (progn
- (if (eq (cdr local) 'global)
- ;; Copy the global value of the variable.
- (setq global (symbol-value (car local)))
- ;; Use the value from the list.
- (setq global (eval (cdr local))))
- (set (make-local-variable (car local)) global))
- ;; Simple nil-valued local variable.
- (set (make-local-variable local) nil)))))
+ (dolist (local gnus-summary-local-variables)
+ (if (consp local)
+ (let ((global (if (eq (cdr local) 'global)
+ ;; Copy the global value of the variable.
+ (symbol-value (car local))
+ ;; Use the value from the list.
+ (eval (cdr local)))))
+ (set (make-local-variable (car local)) global))
+ ;; Simple nil-valued local variable.
+ (set (make-local-variable local) nil))))
;; Summary data functions.
@@ -3471,8 +3505,11 @@ display only a single character."
(current-buffer))))))
(defun gnus-summary-setup-buffer (group)
- "Initialize summary buffer.
-If the setup was successful, non-nil is returned."
+ "Initialize summary buffer for GROUP.
+This function does all setup work that relies on the specific
+value of GROUP, and puts the buffer in `gnus-summary-mode'.
+
+Returns non-nil if the setup was successful."
(let ((buffer (gnus-summary-buffer-name group))
(dead-name (concat "*Dead Summary "
(gnus-group-decoded-name group) "*")))
@@ -3486,13 +3523,15 @@ If the setup was successful, non-nil is returned."
(not gnus-newsgroup-prepared))
(set-buffer (gnus-get-buffer-create buffer))
(setq gnus-summary-buffer (current-buffer))
- (gnus-summary-mode group)
+ (let ((gnus-summary-mode-group group))
+ (gnus-summary-mode))
(when (gnus-group-quit-config group)
(set (make-local-variable 'gnus-single-article-buffer) nil))
- (make-local-variable 'gnus-article-buffer)
- (make-local-variable 'gnus-article-current)
- (make-local-variable 'gnus-original-article-buffer)
- (setq gnus-newsgroup-name group)
+ (turn-on-gnus-mailing-list-mode)
+ ;; These functions don't currently depend on GROUP, but might in
+ ;; the future.
+ (gnus-update-format-specifications nil 'summary 'summary-mode 'summary-dummy)
+ (gnus-update-summary-mark-positions)
;; Set any local variables in the group parameters.
(gnus-summary-set-local-parameters gnus-newsgroup-name)
t)))
@@ -3517,13 +3556,12 @@ buffer that was in action when the last article was fetched."
(score-file gnus-current-score-file)
(default-charset gnus-newsgroup-charset)
vlist)
- (let ((locals gnus-newsgroup-variables))
- (while locals
- (if (consp (car locals))
- (push (eval (caar locals)) vlist)
- (push (eval (car locals)) vlist))
- (setq locals (cdr locals)))
- (setq vlist (nreverse vlist)))
+ (dolist (local gnus-newsgroup-variables)
+ (push (eval (if (consp local) (car local)
+ local)
+ t)
+ vlist))
+ (setq vlist (nreverse vlist))
(with-temp-buffer
(setq gnus-newsgroup-name name
gnus-newsgroup-marked marked
@@ -3538,12 +3576,11 @@ buffer that was in action when the last article was fetched."
gnus-reffed-article-number reffed
gnus-current-score-file score-file
gnus-newsgroup-charset default-charset)
- (let ((locals gnus-newsgroup-variables))
- (while locals
- (if (consp (car locals))
- (set (caar locals) (pop vlist))
- (set (car locals) (pop vlist)))
- (setq locals (cdr locals))))))))
+ (dolist (local gnus-newsgroup-variables)
+ (set (if (consp local)
+ (car local)
+ local)
+ (pop vlist)))))))
(defun gnus-summary-article-unread-p (article)
"Say whether ARTICLE is unread or not."
@@ -3631,19 +3668,23 @@ buffer that was in action when the last article was fetched."
pos)))
(setq gnus-summary-mark-positions pos))))
-(defun gnus-summary-insert-dummy-line (gnus-tmp-subject gnus-tmp-number)
+(defun gnus-summary-insert-dummy-line (subject number)
"Insert a dummy root in the summary buffer."
(beginning-of-line)
(add-text-properties
- (point) (progn (eval gnus-summary-dummy-line-format-spec) (point))
- (list 'gnus-number gnus-tmp-number 'gnus-intangible gnus-tmp-number)))
+ (point) (let ((gnus-tmp-subject subject)
+ (gnus-tmp-number number))
+ (eval gnus-summary-dummy-line-format-spec t)
+ (point))
+ (list 'gnus-number number 'gnus-intangible number)))
(defun gnus-summary-extract-address-component (from)
(or (car (funcall gnus-extract-address-components from))
from))
-(defun gnus-summary-from-or-to-or-newsgroups (header gnus-tmp-from)
- (let ((mail-parse-charset gnus-newsgroup-charset)
+(defun gnus-summary-from-or-to-or-newsgroups (header from)
+ (let ((gnus-tmp-from from)
+ (mail-parse-charset gnus-newsgroup-charset)
;; Is it really necessary to do this next part for each summary line?
;; Luckily, doesn't seem to slow things down much.
(mail-parse-ignored-charsets
@@ -3670,25 +3711,31 @@ buffer that was in action when the last article was fetched."
(and
(memq 'Newsgroups gnus-extra-headers)
(eq (car (gnus-find-method-for-group
- gnus-newsgroup-name)) 'nntp)
+ gnus-newsgroup-name))
+ 'nntp)
(gnus-group-real-name gnus-newsgroup-name))))
(concat gnus-summary-newsgroup-prefix newsgroups)))))
(bidi-string-mark-left-to-right
(inline
(gnus-summary-extract-address-component gnus-tmp-from))))))
-(defun gnus-summary-insert-line (gnus-tmp-header
- gnus-tmp-level gnus-tmp-current
- undownloaded gnus-tmp-unread gnus-tmp-replied
- gnus-tmp-expirable gnus-tmp-subject-or-nil
- &optional gnus-tmp-dummy gnus-tmp-score
- gnus-tmp-process)
- (if (>= gnus-tmp-level (length gnus-thread-indent-array))
+(defun gnus-summary-insert-line (header level current undownloaded
+ unread replied expirable subject-or-nil
+ &optional dummy score process)
+ (if (>= level (length gnus-thread-indent-array))
(gnus-make-thread-indent-array (max (* 2 (length gnus-thread-indent-array))
- gnus-tmp-level)))
- (let* ((gnus-tmp-indentation (aref gnus-thread-indent-array gnus-tmp-level))
+ level)))
+ (let* ((gnus-tmp-header header)
+ (gnus-tmp-level level)
+ (gnus-tmp-current current)
+ (gnus-tmp-unread unread)
+ (gnus-tmp-expirable expirable)
+ (gnus-tmp-subject-or-nil subject-or-nil)
+ (gnus-tmp-dummy dummy)
+ (gnus-tmp-process process)
+ (gnus-tmp-indentation (aref gnus-thread-indent-array gnus-tmp-level))
(gnus-tmp-lines (mail-header-lines gnus-tmp-header))
- (gnus-tmp-score (or gnus-tmp-score gnus-summary-default-score 0))
+ (gnus-tmp-score (or score gnus-summary-default-score 0))
(gnus-tmp-score-char
(if (or (null gnus-summary-default-score)
(<= (abs (- gnus-tmp-score gnus-summary-default-score))
@@ -3701,7 +3748,7 @@ buffer that was in action when the last article was fetched."
(cond (gnus-tmp-process gnus-process-mark)
((memq gnus-tmp-current gnus-newsgroup-cached)
gnus-cached-mark)
- (gnus-tmp-replied gnus-replied-mark)
+ (replied gnus-replied-mark)
((memq gnus-tmp-current gnus-newsgroup-forwarded)
gnus-forwarded-mark)
((memq gnus-tmp-current gnus-newsgroup-saved)
@@ -3804,7 +3851,7 @@ the thread are to be displayed."
1)
(t 0))))
(when (and level (zerop level) gnus-tmp-new-adopts)
- (incf number
+ (cl-incf number
(apply '+ (mapcar
'gnus-summary-number-of-articles-in-thread
gnus-tmp-new-adopts))))
@@ -3857,20 +3904,20 @@ respectively."
Returns \" ? \" if there's bad input or if another error occurs.
Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"."
(condition-case ()
- (let* ((messy-date (float-time (gnus-date-get-time messy-date)))
- (now (float-time))
+ (let* ((messy-date (gnus-date-get-time messy-date))
+ (now (current-time))
;;If we don't find something suitable we'll use this one
(my-format "%b %d '%y"))
- (let* ((difference (- now messy-date))
+ (let* ((difference (time-subtract now messy-date))
(templist gnus-user-date-format-alist)
(top (eval (caar templist))))
- (while (if (numberp top) (< top difference) (not top))
+ (while (if (numberp top) (time-less-p top difference) (not top))
(progn
(setq templist (cdr templist))
(setq top (eval (caar templist)))))
(if (stringp (cdr (car templist)))
(setq my-format (cdr (car templist)))))
- (format-time-string (eval my-format) (seconds-to-time messy-date)))
+ (format-time-string (eval my-format) messy-date))
(error " ? ")))
(defun gnus-summary-set-local-parameters (group)
@@ -3928,9 +3975,18 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(defun gnus-summary-read-group-1 (group show-all no-article
kill-buffer no-display
&optional select-articles)
+ "Display articles and threads in a Summary buffer for GROUP."
+ ;; This function calls `gnus-summary-setup-buffer' to create the
+ ;; buffer, put it in `gnus-summary-mode', and set local variables;
+ ;; `gnus-select-newsgroup' to update the group's active and marks
+ ;; from the server; and `gnus-summary-prepare' to actually insert
+ ;; lines for articles. The rest of the function is mostly concerned
+ ;; with limiting and positioning and windowing and other visual
+ ;; effects.
+
;; Killed foreign groups can't be entered.
;; (when (and (not (gnus-group-native-p group))
- ;; (not (gnus-gethash group gnus-newsrc-hashtb)))
+ ;; (not (gethash group gnus-newsrc-hashtb)))
;; (error "Dead non-native groups can't be entered"))
(gnus-message 7 "Retrieving newsgroup: %s..."
(gnus-group-decoded-name group))
@@ -3993,7 +4049,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(spam-initialize))
;; Save the active value in effect when the group was entered.
(setq gnus-newsgroup-active
- (gnus-copy-sequence
+ (copy-tree
(gnus-active gnus-newsgroup-name)))
(setq gnus-newsgroup-highest (cdr gnus-newsgroup-active))
;; You can change the summary buffer in some way with this hook.
@@ -4160,7 +4216,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
"Gather threads by looking at Subject headers."
(if (not gnus-summary-make-false-root)
threads
- (let ((hashtb (gnus-make-hashtable 1024))
+ (let ((hashtb (gnus-make-hashtable 1000))
(prev threads)
(result threads)
subject hthread whole-subject)
@@ -4169,7 +4225,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(setq whole-subject (mail-header-subject
(caar threads)))))
(when subject
- (if (setq hthread (gnus-gethash subject hashtb))
+ (if (setq hthread (gethash subject hashtb))
(progn
;; We enter a dummy root into the thread, if we
;; haven't done that already.
@@ -4183,24 +4239,24 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(setcdr prev (cdr threads))
(setq threads prev))
;; Enter this thread into the hash table.
- (gnus-sethash subject
- (if gnus-summary-make-false-root-always
- (progn
- ;; If you want a dummy root above all
- ;; threads...
- (setcar threads (list whole-subject
- (car threads)))
- threads)
- threads)
- hashtb)))
+ (puthash subject
+ (if gnus-summary-make-false-root-always
+ (progn
+ ;; If you want a dummy root above all
+ ;; threads...
+ (setcar threads (list whole-subject
+ (car threads)))
+ threads)
+ threads)
+ hashtb)))
(setq prev threads)
(setq threads (cdr threads)))
result)))
(defun gnus-gather-threads-by-references (threads)
"Gather threads by looking at References headers."
- (let ((idhashtb (gnus-make-hashtable 1024))
- (thhashtb (gnus-make-hashtable 1024))
+ (let ((idhashtb (gnus-make-hashtable 1000))
+ (thhashtb (gnus-make-hashtable 1000))
(prev threads)
(result threads)
ids references id gthread gid entered ref)
@@ -4211,11 +4267,11 @@ If SELECT-ARTICLES, only select those articles from GROUP."
entered nil)
(while (setq ref (pop ids))
(setq ids (delete ref ids))
- (if (not (setq gid (gnus-gethash ref idhashtb)))
+ (if (not (setq gid (gethash ref idhashtb)))
(progn
- (gnus-sethash ref id idhashtb)
- (gnus-sethash id threads thhashtb))
- (setq gthread (gnus-gethash gid thhashtb))
+ (puthash ref id idhashtb)
+ (puthash id threads thhashtb))
+ (setq gthread (gethash gid thhashtb))
(unless entered
;; We enter a dummy root into the thread, if we
;; haven't done that already.
@@ -4227,7 +4283,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(setcdr (car gthread)
(nconc (cdar gthread) (list (car threads)))))
;; Add it into the thread hash table.
- (gnus-sethash id gthread thhashtb)
+ (puthash id gthread thhashtb)
(setq entered t)
;; Remove it from the list of threads.
(setcdr prev (cdr threads))
@@ -4260,12 +4316,12 @@ If SELECT-ARTICLES, only select those articles from GROUP."
;; We have found a loop.
(let (ref-dep)
(setcdr thread (delq (car th) (cdr thread)))
- (if (boundp (setq ref-dep (intern "none"
- gnus-newsgroup-dependencies)))
- (setcdr (symbol-value ref-dep)
- (nconc (cdr (symbol-value ref-dep))
+ (if (setq ref-dep (gethash "none"
+ gnus-newsgroup-dependencies))
+ (setcdr ref-dep
+ (nconc (cdr ref-dep)
(list (car th))))
- (set ref-dep (list nil (car th))))
+ (puthash ref-dep (list nil (car th)) gnus-newsgroup-dependencies))
(setq infloop 1
stack nil))
;; Push all the subthreads onto the stack.
@@ -4276,68 +4332,72 @@ If SELECT-ARTICLES, only select those articles from GROUP."
"Go through the dependency hashtb and find the roots. Return all threads."
(let (threads)
(while (catch 'infloop
- (mapatoms
- (lambda (refs)
+ (maphash
+ (lambda (_id refs)
;; Deal with self-referencing References loops.
- (when (and (car (symbol-value refs))
+ (when (and (car refs)
(not (zerop
(apply
'+
(mapcar
(lambda (thread)
(gnus-thread-loop-p
- (car (symbol-value refs)) thread))
- (cdr (symbol-value refs)))))))
+ (car refs) thread))
+ (cdr refs))))))
(setq threads nil)
(throw 'infloop t))
- (unless (car (symbol-value refs))
+ (unless (car refs)
;; These threads do not refer back to any other
;; articles, so they're roots.
- (setq threads (append (cdr (symbol-value refs)) threads))))
+ (setq threads (append (cdr refs) threads))))
gnus-newsgroup-dependencies)))
threads))
;; Build the thread tree.
(defsubst gnus-dependencies-add-header (header dependencies force-new)
"Enter HEADER into the DEPENDENCIES table if it is not already there.
-
If FORCE-NEW is not nil, enter HEADER into the DEPENDENCIES table even
if it was already present.
-If `gnus-summary-ignore-duplicates' is nil then duplicate Message-IDs
-will not be entered in the DEPENDENCIES table. Otherwise duplicate
-Message-IDs will be renamed to a unique Message-ID before being
-entered.
+If `gnus-summary-ignore-duplicates' is non-nil then duplicate
+Message-IDs will not be entered in the DEPENDENCIES table.
+Otherwise duplicate Message-IDs will be renamed to a unique
+Message-ID before being entered.
Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
(let* ((id (mail-header-id header))
- (id-dep (and id (intern id dependencies)))
+ ;; An "id-dep" is a list holding the vector headers of this
+ ;; message, plus equivalent "id-deps" for each immediate
+ ;; child message.
+ (id-dep (and id (gethash id dependencies)))
parent-id ref ref-dep ref-header replaced)
;; Enter this `header' in the `dependencies' table.
(cond
- ((not id-dep)
+ ((null id)
+ ;; Omit this article altogether if there is no Message-ID.
(setq header nil))
- ;; The first two cases do the normal part: enter a new `header'
- ;; in the `dependencies' table.
- ((not (boundp id-dep))
- (set id-dep (list header)))
- ((null (car (symbol-value id-dep)))
- (setcar (symbol-value id-dep) header))
-
+ ;; Enter a new id and `header' in the `dependencies' table.
+ ((null id-dep)
+ (setq id-dep (puthash id (list header) dependencies)))
+ ;; A child message has already added this id, just insert the header.
+ ((null (car id-dep))
+ (setcar (gethash id dependencies) header)
+ (setq id-dep (gethash id dependencies)))
;; From here the `header' was already present in the
;; `dependencies' table.
(force-new
;; Overrides an existing entry;
;; just set the header part of the entry.
- (setcar (symbol-value id-dep) header)
+ (setcar (gethash id dependencies) header)
(setq replaced t))
;; Renames the existing `header' to a unique Message-ID.
((not gnus-summary-ignore-duplicates)
;; An article with this Message-ID has already been seen.
;; We rename the Message-ID.
- (set (setq id-dep (intern (setq id (nnmail-message-id)) dependencies))
- (list header))
+ (setq id-dep (puthash (setq id (nnmail-message-id))
+ (list header)
+ dependencies))
(mail-header-set-id header id))
;; The last case ignores an existing entry, except it adds any
@@ -4347,8 +4407,8 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
;; table was *not* modified.
(t
(mail-header-set-xref
- (car (symbol-value id-dep))
- (concat (or (mail-header-xref (car (symbol-value id-dep)))
+ (car id-dep)
+ (concat (or (mail-header-xref (car id-dep))
"")
(or (mail-header-xref header) "")))
(setq header nil)))
@@ -4358,23 +4418,27 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
(setq parent-id (gnus-parent-id (mail-header-references header)))
(setq ref parent-id)
(while (and ref
- (setq ref-dep (intern-soft ref dependencies))
- (boundp ref-dep)
- (setq ref-header (car (symbol-value ref-dep))))
+ (setq ref-dep (gethash ref dependencies))
+ (setq ref-header (car-safe ref-dep)))
(if (string= id ref)
;; Yuk! This is a reference loop. Make the article be a
;; root article.
(progn
- (mail-header-set-references (car (symbol-value id-dep)) "none")
+ (mail-header-set-references (car id-dep) "none")
(setq ref nil)
(setq parent-id nil))
(setq ref (gnus-parent-id (mail-header-references ref-header)))))
- (setq ref-dep (intern (or parent-id "none") dependencies))
- (if (boundp ref-dep)
- (setcdr (symbol-value ref-dep)
- (nconc (cdr (symbol-value ref-dep))
- (list (symbol-value id-dep))))
- (set ref-dep (list nil (symbol-value id-dep)))))
+ (setq ref (or parent-id "none")
+ ref-dep (gethash ref dependencies))
+ ;; Add `header' to its parent's list of children, creating that
+ ;; list if the parent isn't yet registered in the dependency
+ ;; table.
+ (if ref-dep
+ (setcdr (gethash ref dependencies)
+ (nconc (cdr ref-dep)
+ (list id-dep)))
+ (puthash ref (list nil id-dep)
+ dependencies)))
header))
(defun gnus-extract-message-id-from-in-reply-to (string)
@@ -4406,7 +4470,7 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
(setq end (1+ (point)))
(when (search-backward "<" nil t)
(setq new-child (buffer-substring (point) end))
- (push (list (incf generation)
+ (push (list (cl-incf generation)
child (setq child new-child)
subject date)
relations)))
@@ -4427,7 +4491,7 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
(push gnus-reffed-article-number gnus-newsgroup-sparse)
(push (cons gnus-reffed-article-number gnus-sparse-mark)
gnus-newsgroup-reads)
- (decf gnus-reffed-article-number)))
+ (cl-decf gnus-reffed-article-number)))
(gnus-message 7 "Making sparse threads...done")))
(defun gnus-build-old-threads ()
@@ -4436,16 +4500,15 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
;; build complete threads - if the roots haven't been expired by the
;; server, that is.
(let ((mail-parse-charset gnus-newsgroup-charset)
- id heads)
- (mapatoms
- (lambda (refs)
- (when (not (car (symbol-value refs)))
- (setq heads (cdr (symbol-value refs)))
+ heads)
+ (maphash
+ (lambda (id refs)
+ (when (not (car refs))
+ (setq heads (cdr refs))
(while heads
(if (memq (mail-header-number (caar heads))
gnus-newsgroup-dormant)
(setq heads (cdr heads))
- (setq id (symbol-name refs))
(while (and (setq id (gnus-build-get-header id))
(not (car (gnus-id-to-thread id)))))
(setq heads nil)))))
@@ -4461,7 +4524,6 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
;; on the beginning of the line.
(defsubst gnus-nov-parse-line (number dependencies &optional force-new)
(let ((eol (point-at-eol))
- (buffer (current-buffer))
header references in-reply-to)
;; overview: [num subject from date id refs chars lines misc]
@@ -4720,13 +4782,14 @@ If LINE, insert the rebuilt thread starting on line LINE."
(setq parent (gnus-parent-id references)))
(car (gnus-id-to-thread parent))
nil))
- (decf generation))
+ (cl-decf generation))
(and (not (eq headers in-headers))
headers)))
(defun gnus-id-to-thread (id)
"Return the (sub-)thread where ID appears."
- (gnus-gethash id gnus-newsgroup-dependencies))
+ (when (hash-table-p gnus-newsgroup-dependencies)
+ (gethash id gnus-newsgroup-dependencies)))
(defun gnus-id-to-article (id)
"Return the article number of ID."
@@ -4772,7 +4835,7 @@ If LINE, insert the rebuilt thread starting on line LINE."
(let (headers thread last-id)
;; First go up in this thread until we find the root.
(setq last-id (gnus-root-id id)
- headers (message-flatten-list (gnus-id-to-thread last-id)))
+ headers (flatten-tree (gnus-id-to-thread last-id)))
;; We have now found the real root of this thread. It might have
;; been gathered into some loose thread, so we have to search
;; through the threads to find the thread we wanted.
@@ -4915,8 +4978,16 @@ Note that THREAD must never, ever be anything else than a variable -
using some other form will lead to serious barfage."
(or (symbolp thread) (signal 'wrong-type-argument '(symbolp thread)))
;; (8% speedup to gnus-summary-prepare, just for fun :-)
- (list 'byte-code "\10\211:\203\17\0\211@;\203\16\0A@@\207"
- (vector thread) 2))
+ (cond
+ ((and (boundp 'lexical-binding) lexical-binding)
+ ;; FIXME: This version could be a "defsubst" rather than a macro.
+ `(#[257 "\211:\203\16\0\211@;\203\15\0A@@\207"
+ [] 2]
+ ,thread))
+ (t
+ ;; Not sure how XEmacs handles these things, so let's keep the old code.
+ (list 'byte-code "\10\211:\203\17\0\211@;\203\16\0A@@\207"
+ (vector thread) 2))))
(defsubst gnus-article-sort-by-number (h1 h2)
"Sort articles by article number."
@@ -5068,7 +5139,7 @@ Unscored articles will be counted as having a score of zero."
"Return the highest article number in THREAD."
(apply 'max (mapcar (lambda (header)
(mail-header-number header))
- (message-flatten-list thread))))
+ (flatten-tree thread))))
(defun gnus-article-sort-by-most-recent-date (h1 h2)
"Sort articles by number."
@@ -5088,7 +5159,7 @@ Unscored articles will be counted as having a score of zero."
(mapcar (lambda (header) (float-time
(gnus-date-get-time
(mail-header-date header))))
- (message-flatten-list thread))))
+ (flatten-tree thread))))
(defun gnus-thread-total-score-1 (root)
;; This function find the total score of the thread below ROOT.
@@ -5464,7 +5535,7 @@ or a straight list of headers."
(nthcdr 1 thread))
stack))
(push (if (nth 1 thread) 1 0) tree-stack)
- (incf gnus-tmp-level)
+ (cl-incf gnus-tmp-level)
(setq threads (if thread-end nil (cdar thread)))
(if gnus-summary-display-while-building
(if building-count
@@ -5579,7 +5650,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(if (eq (car (gnus-find-method-for-group group)) 'nnvirtual)
t
gnus-summary-ignore-duplicates))
- (info (nth 2 entry))
+ (info (nth 1 entry))
charset articles fetched-articles cached)
(unless (gnus-check-server
@@ -5598,7 +5669,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(decode-coding-string group charset)
(decode-coding-string (gnus-status-message group) charset))))
- (unless (gnus-request-group group t nil (gnus-get-info group))
+ (unless (gnus-request-group group t nil info)
(when (derived-mode-p 'gnus-summary-mode)
(gnus-kill-buffer (current-buffer)))
(error "Couldn't request group %s: %s"
@@ -5738,7 +5809,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(mail-header-number (car gnus-newsgroup-headers))
gnus-newsgroup-end
(mail-header-number
- (gnus-last-element gnus-newsgroup-headers))))
+ (car (last gnus-newsgroup-headers)))))
;; GROUP is successfully selected.
(or gnus-newsgroup-headers t)))))
@@ -5915,7 +5986,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(setq articles (nthcdr (- number select) articles))))
(setq gnus-newsgroup-unselected
(gnus-sorted-difference gnus-newsgroup-unreads articles))
- (when gnus-alter-articles-to-read-function
+ (when (functionp gnus-alter-articles-to-read-function)
(setq articles
(sort
(funcall gnus-alter-articles-to-read-function
@@ -5947,7 +6018,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(min (car active))
(max (cdr active))
(types gnus-article-mark-lists)
- marks var articles article mark mark-type
+ var articles article mark mark-type
bgn end)
;; Hack to avoid adjusting marks for imap.
(when (eq (car (gnus-find-method-for-group (gnus-info-group info)))
@@ -6077,12 +6148,12 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(del
(gnus-list-range-intersection
gnus-newsgroup-articles
- (gnus-remove-from-range (gnus-copy-sequence old) list)))
+ (gnus-remove-from-range (copy-tree old) list)))
(add
(gnus-list-range-intersection
gnus-newsgroup-articles
(gnus-remove-from-range
- (gnus-copy-sequence list) old))))
+ (copy-tree list) old))))
(when add
(push (list add 'add (list (cdr type))) delta-marks))
(when del
@@ -6112,7 +6183,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(let ((i 5))
(while (and (> i 2)
(not (nth i info)))
- (when (nthcdr (decf i) info)
+ (when (nthcdr (cl-decf i) info)
(setcdr (nthcdr i info) nil)))))))
(defun gnus-set-mode-line (where)
@@ -6201,22 +6272,21 @@ The resulting hash table is returned, or nil if no Xrefs were found."
(setq number
(string-to-number (substring xrefs (match-beginning 2)
(match-end 2))))
- (if (setq entry (gnus-gethash group xref-hashtb))
+ (if (setq entry (gethash group xref-hashtb))
(setcdr entry (cons number (cdr entry)))
- (gnus-sethash group (cons number nil) xref-hashtb)))))
+ (puthash group (cons number nil) xref-hashtb)))))
(and start xref-hashtb)))
(defun gnus-mark-xrefs-as-read (from-newsgroup headers unreads)
"Look through all the headers and mark the Xrefs as read."
(let ((virtual (gnus-virtual-group-p from-newsgroup))
- name info xref-hashtb idlist method nth4)
+ name info xref-hashtb method nth4)
(with-current-buffer gnus-group-buffer
(when (setq xref-hashtb
(gnus-create-xref-hashtb from-newsgroup headers unreads))
- (mapatoms
- (lambda (group)
- (unless (string= from-newsgroup (setq name (symbol-name group)))
- (setq idlist (symbol-value group))
+ (maphash
+ (lambda (group idlist)
+ (unless (string= from-newsgroup group)
;; Dead groups are not updated.
(and (prog1
(setq info (gnus-get-info name))
@@ -6242,7 +6312,7 @@ The resulting hash table is returned, or nil if no Xrefs were found."
(defun gnus-compute-read-articles (group articles)
(let* ((entry (gnus-group-entry group))
- (info (nth 2 entry))
+ (info (nth 1 entry))
(active (gnus-active group))
ninfo)
(when entry
@@ -6279,7 +6349,7 @@ The resulting hash table is returned, or nil if no Xrefs were found."
"Update the info of GROUP to say that ARTICLES are read."
(let* ((num 0)
(entry (gnus-group-entry group))
- (info (nth 2 entry))
+ (info (nth 1 entry))
(active (gnus-active group))
(set-marks
(gnus-method-option-p
@@ -6304,6 +6374,7 @@ The resulting hash table is returned, or nil if no Xrefs were found."
(when ,set-marks
(gnus-request-set-mark
,group (list (list ',range 'del '(read)))))
+ (gnus-group-jump-to-group ,group)
(gnus-group-update-group ,group t))))
;; Add the read articles to the range.
(gnus-info-set-read info range)
@@ -6652,7 +6723,7 @@ current article will be taken into consideration."
(if backward
(gnus-summary-find-prev nil article)
(gnus-summary-find-next nil article)))
- (decf n)))
+ (cl-decf n)))
(nreverse articles)))
((and (and transient-mark-mode mark-active) (mark))
(message "region active")
@@ -7057,12 +7128,20 @@ buffer."
(or (get-buffer-window gnus-article-buffer)
(eq gnus-current-article (gnus-summary-article-number))
(gnus-summary-show-article))
- (gnus-configure-windows
- (if gnus-widen-article-window
- 'only-article
- 'article)
- t)
- (select-window (get-buffer-window gnus-article-buffer))))
+ (let ((point (with-current-buffer gnus-article-buffer
+ (point))))
+ (gnus-configure-windows
+ (if gnus-widen-article-window
+ 'only-article
+ 'article)
+ t)
+ (select-window (get-buffer-window gnus-article-buffer))
+ ;; If we've just selected the message, place point at the start of
+ ;; the body because that's probably where we want to be.
+ (if (not (= point (point-min)))
+ (goto-char point)
+ (article-goto-body)
+ (forward-char -1)))))
(defun gnus-summary-universal-argument (arg)
"Perform any operation on all articles that are process/prefixed."
@@ -7275,12 +7354,13 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(if quit-config
(gnus-handle-ephemeral-exit quit-config)
(goto-char group-point)
+ (unless leave-hidden
+ (gnus-configure-windows 'group 'force))
;; If gnus-group-buffer is already displayed, make sure we also move
;; the cursor in the window that displays it.
(let ((win (get-buffer-window (current-buffer) 0)))
- (if win (set-window-point win (point))))
- (unless leave-hidden
- (gnus-configure-windows 'group 'force)))
+ (goto-char group-point)
+ (if win (set-window-point win (point)))))
;; If we have several article buffers, we kill them at exit.
(unless single-article-buffer
@@ -7344,7 +7424,7 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(setq gnus-newsgroup-name nil)
(unless (gnus-ephemeral-group-p group)
(gnus-group-update-group group nil t))
- (when (equal (gnus-group-group-name) group)
+ (when (gnus-group-goto-group group)
(gnus-group-next-unread-group 1))
(gnus-article-stop-animations)
(when quit-config
@@ -7454,7 +7534,7 @@ The state which existed when entering the ephemeral is reset."
(with-current-buffer buffer
(gnus-deaden-summary))))))
-(defun gnus-summary-wake-up-the-dead (&rest args)
+(defun gnus-summary-wake-up-the-dead (&rest _)
"Wake up the dead summary buffer."
(interactive)
(gnus-dead-summary-mode -1)
@@ -7680,6 +7760,12 @@ Given a prefix, will force an `article' buffer configuration."
(gnus-article-setup-buffer))
(gnus-set-global-variables)
(with-current-buffer gnus-article-buffer
+ ;; The buffer may be non-empty and even narrowed, so go back to
+ ;; a sane state.
+ (widen)
+ ;; We're going to erase the buffer anyway so do it now: it can save us from
+ ;; uselessly performing multibyte-conversion of the current content.
+ (let ((inhibit-read-only t)) (erase-buffer))
(setq gnus-article-charset gnus-newsgroup-charset)
(setq gnus-article-ignored-charsets gnus-newsgroup-ignored-charsets)
(mm-enable-multibyte))
@@ -7711,7 +7797,7 @@ be displayed."
(unless (derived-mode-p 'gnus-summary-mode)
(set-buffer gnus-summary-buffer))
(let ((article (or article (gnus-summary-article-number)))
- (all-headers (not (not all-headers))) ;Must be t or nil.
+ (all-headers (and all-headers t)) ; Must be t or nil.
gnus-summary-display-article-function)
(and (not pseudo)
(gnus-summary-article-pseudo-p article)
@@ -7797,7 +7883,8 @@ If BACKWARD, the previous article is selected instead of the next."
(cond
((or (not gnus-auto-select-next)
(not cmd))
- (gnus-message 7 "No more%s articles" (if unread " unread" "")))
+ (unless (eq gnus-auto-select-next 'quietly)
+ (gnus-message 6 "No more%s articles" (if unread " unread" ""))))
((or (eq gnus-auto-select-next 'quietly)
(and (eq gnus-auto-select-next 'slightly-quietly)
push)
@@ -7806,10 +7893,11 @@ If BACKWARD, the previous article is selected instead of the next."
;; Select quietly.
(if (gnus-ephemeral-group-p gnus-newsgroup-name)
(gnus-summary-exit)
- (gnus-message 7 "No more%s articles (%s)..."
- (if unread " unread" "")
- (if group (concat "selecting " group)
- "exiting"))
+ (unless (eq gnus-auto-select-next 'quietly)
+ (gnus-message 6 "No more%s articles (%s)..."
+ (if unread " unread" "")
+ (if group (concat "selecting " group)
+ "exiting")))
(gnus-summary-next-group nil group backward)))
(t
(when (numberp last-input-event)
@@ -7821,7 +7909,7 @@ If BACKWARD, the previous article is selected instead of the next."
(gnus-summary-walk-group-buffer
gnus-newsgroup-name cmd unread backward point))))))))
-(defun gnus-summary-walk-group-buffer (from-group cmd unread backward start)
+(defun gnus-summary-walk-group-buffer (_from-group cmd unread backward start)
(let ((keystrokes '((?\C-n (gnus-group-next-unread-group 1))
(?\C-p (gnus-group-prev-unread-group 1))))
(cursor-in-echo-area t)
@@ -8115,7 +8203,7 @@ score higher than the default score."
"Select the first unread subject that has a score over the default score."
(interactive)
(let ((data gnus-newsgroup-data)
- article score)
+ article)
(while (and (setq article (gnus-data-number (car data)))
(or (gnus-data-read-p (car data))
(not (> (gnus-summary-article-score article)
@@ -8528,7 +8616,7 @@ If UNREPLIED (the prefix), limit to unreplied articles."
(gnus-summary-limit gnus-newsgroup-replied))
(gnus-summary-position-point))
-(defun gnus-summary-limit-exclude-marks (marks &optional reverse)
+(defun gnus-summary-limit-exclude-marks (marks &optional _reverse)
"Exclude articles that are marked with MARKS (e.g. \"DK\").
If REVERSE, limit the summary buffer to articles that are marked
with MARKS. MARKS can either be a string of marks or a list of marks.
@@ -8556,14 +8644,22 @@ Returns how many articles were removed."
(gnus-summary-limit articles))
(gnus-summary-position-point)))
-(defun gnus-summary-limit-to-score (score)
- "Limit to articles with score at or above SCORE."
- (interactive "NLimit to articles with score of at least: ")
+(defun gnus-summary-limit-to-score (score &optional below)
+ "Limit to articles with score at or above SCORE.
+
+With a prefix argument, limit to articles with score at or below
+SCORE."
+ (interactive (list (string-to-number
+ (read-string
+ (format "Limit to articles with score of at %s: "
+ (if current-prefix-arg "most" "least"))))))
(let ((data gnus-newsgroup-data)
- articles)
+ (compare (if (or below current-prefix-arg) #'<= #'>=))
+ articles)
(while data
- (when (>= (gnus-summary-article-score (gnus-data-number (car data)))
- score)
+ (when (funcall compare (gnus-summary-article-score
+ (gnus-data-number (car data)))
+ score)
(push (gnus-data-number (car data)) articles))
(setq data (cdr data)))
(prog1
@@ -8756,7 +8852,7 @@ If ALL, mark even excluded ticked and dormants as read."
(let ((num 0))
(while threads
(when (memq (mail-header-number (caar threads)) gnus-newsgroup-limit)
- (incf num))
+ (cl-incf num))
(pop threads))
(< num 2)))
@@ -8821,11 +8917,11 @@ fetch-old-headers verbiage, and so on."
(null gnus-thread-expunge-below)))
(push gnus-newsgroup-limit gnus-newsgroup-limits)
(setq gnus-newsgroup-limit nil)
- (mapatoms
- (lambda (node)
- (unless (car (symbol-value node))
+ (maphash
+ (lambda (_id deps)
+ (unless (car deps)
;; These threads have no parents -- they are roots.
- (let ((nodes (cdr (symbol-value node)))
+ (let ((nodes (cdr deps))
thread)
(while nodes
(if (and gnus-thread-expunge-below
@@ -8888,7 +8984,7 @@ fetch-old-headers verbiage, and so on."
gnus-summary-expunge-below))
;; We increase the expunge-tally here, but that has
;; nothing to do with the limits, really.
- (incf gnus-newsgroup-expunged-tally)
+ (cl-incf gnus-newsgroup-expunged-tally)
;; We also mark as read here, if that's wanted.
(when (and gnus-summary-mark-below
(< score gnus-summary-mark-below))
@@ -8913,7 +9009,7 @@ fetch-old-headers verbiage, and so on."
(defun gnus-expunge-thread (thread)
"Mark all articles in THREAD as read."
(let* ((number (mail-header-number (car thread))))
- (incf gnus-newsgroup-expunged-tally)
+ (cl-incf gnus-newsgroup-expunged-tally)
;; We also mark as read here, if that's wanted.
(setq gnus-newsgroup-unreads
(delq number gnus-newsgroup-unreads))
@@ -8965,7 +9061,7 @@ The difference between N and the number of articles fetched is returned."
(gnus-message 1 "No references in article %d"
(gnus-summary-article-number))
(setq error t))
- (decf n))
+ (cl-decf n))
(gnus-summary-position-point)
n))
@@ -8981,7 +9077,7 @@ Return the number of articles fetched."
(error "No References in the current article")
;; For each Message-ID in the References header...
(while (string-match "<[^>]*>" ref)
- (incf n)
+ (cl-incf n)
;; ... fetch that article.
(gnus-summary-refer-article
(prog1 (match-string 0 ref)
@@ -9480,6 +9576,9 @@ fetched headers for, whether they are displayed or not."
(func `(lambda (h) (,(intern (concat "mail-header-" header)) h)))
(case-fold-search t))
(dolist (header gnus-newsgroup-headers)
+ ;; FIXME: when called from gnus-summary-limit-include-thread via
+ ;; gnus-summary-limit-include-matching-articles, `regexp' is a decoded
+ ;; string whereas the header isn't decoded.
(when (string-match regexp (funcall func header))
(push (mail-header-number header) articles)))
(nreverse articles)))
@@ -9494,7 +9593,7 @@ be taken into consideration. If NOT-CASE-FOLD, case won't be folded
in the comparisons. If NOT-MATCHING, return a list of all articles that
not match REGEXP on HEADER."
(let ((case-fold-search (not not-case-fold))
- articles d func)
+ articles func)
(if (consp header)
(if (eq (car header) 'extra)
(setq func
@@ -9614,6 +9713,10 @@ to save in."
(gnus-summary-remove-process-mark article))
(ps-despool filename))
+(defvar ps-right-header)
+(defvar ps-left-header)
+(defvar shr-ignore-cache)
+
(defun gnus-print-buffer ()
(let ((ps-left-header
(list
@@ -9839,7 +9942,7 @@ prefix specifies how many places to rotate each letter forward."
;; Create buttons and stuff...
(gnus-treat-article nil))
-(defun gnus-summary-idna-message (&optional arg)
+(defun gnus-summary-idna-message (&optional _arg)
"Decode IDNA encoded domain names in the current articles.
IDNA encoded domain names looks like `xn--bar'. If a string
remain unencoded after running this function, it is likely an
@@ -9847,7 +9950,7 @@ invalid IDNA string (`xn--bar' is invalid).
You must have GNU Libidn (URL `https://www.gnu.org/software/libidn/')
installed for this command to work."
- (interactive "P")
+ (interactive)
(gnus-summary-select-article)
(let ((mail-header-separator ""))
(gnus-eval-in-buffer-window gnus-article-buffer
@@ -9859,9 +9962,9 @@ installed for this command to work."
(replace-match (puny-decode-domain (match-string 1))))
(set-window-start (get-buffer-window (current-buffer)) start))))))
-(defun gnus-summary-morse-message (&optional arg)
+(defun gnus-summary-morse-message (&optional _arg)
"Morse decode the current article."
- (interactive "P")
+ (interactive)
(gnus-summary-select-article)
(let ((mail-header-separator ""))
(gnus-eval-in-buffer-window gnus-article-buffer
@@ -9919,11 +10022,11 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
(cond ((and (eq action 'move)
(not (gnus-check-backend-function
'request-move-article gnus-newsgroup-name)))
- (error "The current group does not support article moving"))
+ (user-error "The current group does not support article moving"))
((and (eq action 'crosspost)
(not (gnus-check-backend-function
'request-replace-article gnus-newsgroup-name)))
- (error "The current group does not support article editing")))
+ (user-error "The current group does not support article editing")))
(let ((articles (gnus-summary-work-articles n))
(prefix (if (gnus-check-backend-function
'request-move-article gnus-newsgroup-name)
@@ -9940,8 +10043,7 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
(unless (assq action names)
(error "Unknown action %s" action))
;; Read the newsgroup name.
- (when (and (not to-newsgroup)
- (not select-method))
+ (unless (or to-newsgroup select-method)
(if (and gnus-move-split-methods
(not
(and (memq gnus-current-article articles)
@@ -9986,6 +10088,7 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
(or (car select-method)
(gnus-group-decoded-name to-newsgroup))
articles)
+ ;; This `while' is not equivalent to a `dolist' (bug#33653#134).
(while articles
(setq article (pop articles))
;; Set any marks that may have changed in the summary buffer.
@@ -9996,8 +10099,9 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
(cond
;; Move the article.
((eq action 'move)
- ;; Remove this article from future suppression.
- (gnus-dup-unsuppress-article article)
+ (when gnus-suppress-duplicates
+ ;; Remove this article from future suppression.
+ (gnus-dup-unsuppress-article article))
(let* ((from-method (gnus-find-method-for-group
gnus-newsgroup-name))
(to-method (or select-method
@@ -10188,7 +10292,7 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
to-newsgroup
select-method))
- ;;;!!!Why is this necessary?
+ ;;!!!Why is this necessary?
(set-buffer gnus-summary-buffer)
(when (eq action 'move)
@@ -10314,16 +10418,19 @@ latter case, they will be copied into the relevant groups."
(unless (re-search-forward "^date:" nil t)
(goto-char (point-max))
(setq atts (file-attributes file))
- (insert "Date: " (message-make-date (nth 5 atts)) "\n")))
+ (insert "Date: " (message-make-date
+ (file-attribute-modification-time atts))
+ "\n")))
;; This doesn't look like an article, so we fudge some headers.
(setq atts (file-attributes file)
lines (count-lines (point-min) (point-max)))
(insert "From: " (read-string "From: ") "\n"
"Subject: " (read-string "Subject: ") "\n"
- "Date: " (message-make-date (nth 5 atts)) "\n"
+ "Date: " (message-make-date
+ (file-attribute-modification-time atts)) "\n"
"Message-ID: " (message-make-message-id) "\n"
"Lines: " (int-to-string lines) "\n"
- "Chars: " (int-to-string (nth 7 atts)) "\n\n"))
+ "Chars: " (int-to-string (file-attribute-size atts)) "\n\n"))
(setq group-art (gnus-request-accept-article group nil t))
(kill-buffer (current-buffer)))
(setq gnus-newsgroup-active (gnus-activate-group group))
@@ -10551,7 +10658,7 @@ groups."
(let ((mbl mml-buffer-list))
(setq mml-buffer-list nil)
(let ((rfc2047-quote-decoded-words-containing-tspecials t))
- (mime-to-mml ,'current-handles))
+ (mime-to-mml ',current-handles))
(let ((mbl1 mml-buffer-list))
(setq mml-buffer-list mbl)
(set (make-local-variable 'mml-buffer-list) mbl1))
@@ -10839,8 +10946,8 @@ the actual number of articles unmarked is returned."
(set var (cons article (symbol-value var)))
(if (memq type '(processable cached replied forwarded recent saved))
(gnus-summary-update-secondary-mark article)
- ;;; !!! This is bogus. We should find out what primary
- ;;; !!! mark we want to set.
+ ;; !!! This is bogus. We should find out what primary
+ ;; !!! mark we want to set.
(gnus-summary-update-mark gnus-del-mark 'unread)))))
(defun gnus-summary-mark-as-expirable (n)
@@ -11143,7 +11250,7 @@ If NO-EXPIRE, auto-expiry will be inhibited."
(re-search-backward "[\n\r]" (point-at-bol) 'move-to-limit)
(when forward
(when (looking-at "\r")
- (incf forward))
+ (cl-incf forward))
(when (<= (+ forward (point)) (point-max))
;; Go to the right position on the line.
(goto-char (+ forward (point)))
@@ -11723,7 +11830,7 @@ will not be hidden."
(let ((end nil)
(count 0))
(while (not end)
- (incf count)
+ (cl-incf count)
(when (zerop (mod count 1000))
(message "Hiding all threads... %d" count))
(when (or (not predicate)
@@ -11795,7 +11902,7 @@ If SILENT, don't output messages."
(n (abs n)))
(while (and (> n 0)
(gnus-summary-go-to-next-thread backward))
- (decf n))
+ (cl-decf n))
(unless silent
(gnus-summary-position-point))
(when (and (not silent) (/= 0 n))
@@ -11963,16 +12070,16 @@ Argument REVERSE means reverse order."
(interactive "P")
(gnus-summary-sort 'chars reverse))
-(defun gnus-summary-sort-by-mark (&optional reverse)
+(defun gnus-summary-sort-by-marks (&optional reverse)
"Sort the summary buffer by article marks.
Argument REVERSE means reverse order."
(interactive "P")
(gnus-summary-sort 'marks reverse))
-(defun gnus-summary-sort-by-original (&optional reverse)
+(defun gnus-summary-sort-by-original (&optional _reverse)
"Sort the summary buffer using the default sorting method.
Argument REVERSE means reverse order."
- (interactive "P")
+ (interactive)
(let* ((inhibit-read-only t)
(gnus-summary-prepare-hook nil))
;; We do the sorting by regenerating the threads.
@@ -11982,7 +12089,8 @@ Argument REVERSE means reverse order."
(defun gnus-summary-sort (predicate reverse)
"Sort summary buffer by PREDICATE. REVERSE means reverse order."
- (let* ((thread (intern (format "gnus-thread-sort-by-%s" predicate)))
+ (let* ((current (gnus-summary-article-number))
+ (thread (intern (format "gnus-thread-sort-by-%s" predicate)))
(article (intern (format "gnus-article-sort-by-%s" predicate)))
(gnus-thread-sort-functions
(if (not reverse)
@@ -12001,7 +12109,9 @@ Argument REVERSE means reverse order."
;; We do the sorting by regenerating the threads.
(gnus-summary-prepare)
;; Hide subthreads if needed.
- (gnus-summary-maybe-hide-threads)))
+ (gnus-summary-maybe-hide-threads)
+ ;; Restore point.
+ (gnus-summary-goto-subject current)))
;; Summary saving commands.
@@ -12255,12 +12365,11 @@ save those articles instead."
(nreverse split-name)))
(defun gnus-valid-move-group-p (group)
- (and (symbolp group)
- (boundp group)
- (symbol-name group)
- (symbol-value group)
- (gnus-get-function (gnus-find-method-for-group
- (symbol-name group)) 'request-accept-article t)))
+ (when (and (stringp group)
+ (null (string-empty-p group)))
+ (gnus-get-function (gnus-find-method-for-group
+ group)
+ 'request-accept-article t)))
(defun gnus-read-move-group-name (prompt default articles prefix)
"Read a group name."
@@ -12271,17 +12380,20 @@ save those articles instead."
(if (> (length articles) 1)
(format "these %d articles" (length articles))
"this article")))
+ (valid-names
+ (seq-filter #'gnus-valid-move-group-p
+ (hash-table-keys gnus-active-hashtb)))
(to-newsgroup
(cond
((null split-name)
(gnus-group-completing-read
prom
- (gnus-remove-if-not 'gnus-valid-move-group-p gnus-active-hashtb t)
+ valid-names
nil prefix nil default))
((= 1 (length split-name))
(gnus-group-completing-read
prom
- (gnus-remove-if-not 'gnus-valid-move-group-p gnus-active-hashtb t)
+ valid-names
nil prefix 'gnus-group-history (car split-name)))
(t
(gnus-completing-read
@@ -12293,7 +12405,7 @@ save those articles instead."
(string= to-newsgroup prefix))
(setq to-newsgroup default))
(unless to-newsgroup
- (error "No group name entered"))
+ (user-error "No group name entered"))
(setq encoded (encode-coding-string
to-newsgroup
(gnus-group-name-charset to-method to-newsgroup)))
@@ -12305,7 +12417,7 @@ save those articles instead."
(gnus-activate-group encoded nil nil to-method)
(gnus-subscribe-group encoded))
(error "Couldn't create group %s" to-newsgroup)))
- (error "No such group: %s" to-newsgroup))
+ (user-error "No such group: %s" to-newsgroup))
encoded)))
(defvar gnus-summary-save-parts-counter)
@@ -12360,7 +12472,7 @@ If REVERSE, save parts that do not match TYPE."
(cdr gnus-article-current)
gnus-summary-save-parts-counter))))
dir)))
- (incf gnus-summary-save-parts-counter)
+ (cl-incf gnus-summary-save-parts-counter)
(unless (file-exists-p file)
(mm-save-part-to-file handle file))))))
@@ -12533,7 +12645,7 @@ If REVERSE, save parts that do not match TYPE."
;; article numbers for this article.
(mail-header-set-number header gnus-reffed-article-number))
(with-current-buffer gnus-summary-buffer
- (decf gnus-reffed-article-number)
+ (cl-decf gnus-reffed-article-number)
(gnus-remove-header (mail-header-number header))
(push header gnus-newsgroup-headers)
(setq gnus-current-headers header)
@@ -12603,14 +12715,21 @@ If REVERSE, save parts that do not match TYPE."
(c cond)
(list gnus-summary-highlight))
(while list
- (setcdr c (cons (list (caar list) (list 'quote (cdar list)))
- nil))
+ (setcdr c `((,(caar list) ',(cdar list))))
(setq c (cdr c)
list (cdr list)))
- (gnus-byte-compile (list 'lambda nil cond))))))
+ (gnus-byte-compile
+ `(lambda ()
+ (with-no-warnings ;See docstring of gnus-summary-highlight.
+ (defvar score) (defvar default) (defvar default-high)
+ (defvar default-low) (defvar mark) (defvar uncached))
+ ,cond))))))
(defun gnus-summary-highlight-line ()
"Highlight current line according to `gnus-summary-highlight'."
+ (with-no-warnings ;See docstring of gnus-summary-highlight.
+ (defvar score) (defvar default) (defvar default-high) (defvar default-low)
+ (defvar mark) (defvar uncached))
(let* ((beg (point-at-bol))
(article (or (gnus-summary-article-number) gnus-current-article))
(score (or (cdr (assq article
@@ -12692,6 +12811,7 @@ UNREAD is a sorted list."
`(progn
(gnus-info-set-marks ',info ',(gnus-info-marks info) t)
(gnus-info-set-read ',info ',(gnus-info-read info))
+ (gnus-group-jump-to-group ,group)
(gnus-get-unread-articles-in-group ',info
(gnus-active ,group))
(gnus-group-update-group ,group t)
@@ -12916,7 +13036,7 @@ returned."
(mail-header-number (car gnus-newsgroup-headers))
gnus-newsgroup-end
(mail-header-number
- (gnus-last-element gnus-newsgroup-headers))))
+ (car (last gnus-newsgroup-headers)))))
(when gnus-use-scoring
(gnus-possibly-score-headers))))
@@ -13003,12 +13123,12 @@ If ALL is a number, fetch this number of articles."
i new)
(unless new-active
(error "Couldn't fetch new data"))
- (setq gnus-newsgroup-active (gnus-copy-sequence new-active))
+ (setq gnus-newsgroup-active (copy-tree new-active))
(setq i (cdr gnus-newsgroup-active)
gnus-newsgroup-highest i)
(while (> i old-high)
(push i new)
- (decf i))
+ (cl-decf i))
(if (not new)
(message "No gnus is bad news")
(gnus-summary-insert-articles new)
diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el
index f7d1885fd6d..e2c728df8f4 100644
--- a/lisp/gnus/gnus-topic.el
+++ b/lisp/gnus/gnus-topic.el
@@ -25,12 +25,14 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'gnus)
(require 'gnus-group)
(require 'gnus-start)
(require 'gnus-util)
+(eval-when-compile
+ (require 'subr-x))
(defgroup gnus-topic nil
"Group topics."
@@ -85,7 +87,7 @@ See Info node `(gnus)Formatting Variables'."
(defvar gnus-topic-inhibit-change-level nil)
(defconst gnus-topic-line-format-alist
- `((?n name ?s)
+ '((?n name ?s)
(?v visible ?s)
(?i indentation ?s)
(?g number-of-groups ?d)
@@ -99,8 +101,7 @@ See Info node `(gnus)Formatting Variables'."
(defun gnus-group-topic-name ()
"The name of the topic on the current line."
- (let ((topic (get-text-property (point-at-bol) 'gnus-topic)))
- (and topic (symbol-name topic))))
+ (get-text-property (point-at-bol) 'gnus-topic))
(defun gnus-group-topic-level ()
"The level of the topic on the current line."
@@ -128,7 +129,7 @@ See Info node `(gnus)Formatting Variables'."
number)
(while entries
(when (numberp (setq number (car (pop entries))))
- (incf total number)))
+ (cl-incf total number)))
total))
(defun gnus-group-topic (group)
@@ -144,8 +145,7 @@ See Info node `(gnus)Formatting Variables'."
(defun gnus-topic-goto-topic (topic)
(when topic
- (gnus-goto-char (text-property-any (point-min) (point-max)
- 'gnus-topic (intern topic)))))
+ (gnus-text-property-search 'gnus-topic topic nil 'goto)))
(defun gnus-topic-jump-to-topic (topic)
"Go to TOPIC."
@@ -167,8 +167,7 @@ See Info node `(gnus)Formatting Variables'."
(point) 'gnus-topic))
(get-text-property (max (1- (point)) (point-min))
'gnus-topic))))))
- (when result
- (symbol-name result))))
+ result))
(defun gnus-current-topics (&optional topic)
"Return a list of all current topics, lowest in hierarchy first.
@@ -195,7 +194,7 @@ If RECURSIVE is t, return groups in its subtopics too."
(while groups
(when (setq group (pop groups))
(setq entry (gnus-group-entry group)
- info (nth 2 entry)
+ info (nth 1 entry)
params (gnus-info-params info)
active (gnus-active group)
unread (or (car entry)
@@ -220,6 +219,8 @@ If RECURSIVE is t, return groups in its subtopics too."
;; Check for permanent visibility.
(and gnus-permanently-visible-groups
(string-match gnus-permanently-visible-groups group))
+ ;; Marked groups are always visible.
+ (member group gnus-group-marked)
(memq 'visible params)
(cdr (assq 'visible params)))
;; Add this group to the list of visible groups.
@@ -302,7 +303,7 @@ If RECURSIVE is t, return groups in its subtopics too."
(while (and (not (zerop num))
(setq topic (funcall way topic)))
(when (gnus-topic-goto-topic topic)
- (decf num)))
+ (cl-decf num)))
(unless (zerop num)
(goto-char (point-max)))
num))
@@ -458,9 +459,9 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
(unless gnus-killed-hashtb
(gnus-make-hashtable-from-killed))
(gnus-group-prepare-flat-list-dead
- (gnus-remove-if (lambda (group)
+ (seq-remove (lambda (group)
(or (gnus-group-entry group)
- (gnus-gethash group gnus-killed-hashtb)))
+ (gethash group gnus-killed-hashtb)))
not-in-list)
gnus-level-killed ?K regexp)))
@@ -508,7 +509,7 @@ articles in the topic and its subtopics."
info entry end active tick)
;; Insert any sub-topics.
(while topicl
- (incf unread
+ (cl-incf unread
(gnus-topic-prepare-topic
(pop topicl) (1+ level) list-level predicate
(not visiblep) lowest regexp)))
@@ -534,7 +535,7 @@ articles in the topic and its subtopics."
(funcall regexp entry))
((null regexp) t)
(t nil))))
- (setq info (nth 2 entry))
+ (setq info (nth 1 entry))
(gnus-group-prepare-logic
(gnus-info-group info)
(and (or (not gnus-group-listed-groups)
@@ -555,14 +556,14 @@ articles in the topic and its subtopics."
(car active))
nil)
;; Living groups.
- (when (setq info (nth 2 entry))
+ (when (setq info (nth 1 entry))
(gnus-group-insert-group-line
(gnus-info-group info)
(gnus-info-level info) (gnus-info-marks info)
(car entry) (gnus-info-method info)))))
(when (and (listp entry)
(numberp (car entry)))
- (incf unread (car entry)))
+ (cl-incf unread (car entry)))
(when (listp entry)
(setq tick t))))
(goto-char beg)
@@ -644,7 +645,7 @@ articles in the topic and its subtopics."
(point)
(prog1 (1+ (point))
(eval gnus-topic-line-format-spec))
- (list 'gnus-topic (intern name)
+ (list 'gnus-topic name
'gnus-topic-level level
'gnus-topic-unread unread
'gnus-active active-topic
@@ -728,10 +729,10 @@ articles in the topic and its subtopics."
(cdr gnus-group-list-mode)))
entry)
(while children
- (incf unread (gnus-topic-unread (caar (pop children)))))
+ (cl-incf unread (gnus-topic-unread (caar (pop children)))))
(while (setq entry (pop entries))
(when (numberp (car entry))
- (incf unread (car entry))))
+ (cl-incf unread (car entry))))
(gnus-topic-insert-topic-line
topic t t (car (gnus-topic-find-topology topic)) nil unread)))
@@ -772,10 +773,10 @@ articles in the topic and its subtopics."
(if reads
(setq unread (- (gnus-group-topic-unread) reads))
(while children
- (incf unread (gnus-topic-unread (caar (pop children)))))
+ (cl-incf unread (gnus-topic-unread (caar (pop children)))))
(while (setq entry (pop entries))
(when (numberp (car entry))
- (incf unread (car entry)))))
+ (cl-incf unread (car entry)))))
(setq old-unread (gnus-group-topic-unread))
;; Insert the topic line.
(gnus-topic-insert-topic-line
@@ -842,10 +843,9 @@ articles in the topic and its subtopics."
;; they belong to some topic.
(let* ((tgroups (apply 'append (mapcar 'cdr gnus-topic-alist)))
(entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist)))
- (newsrc (cdr gnus-newsrc-alist))
- group)
- (while newsrc
- (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups)
+ (groups (cdr gnus-group-list)))
+ (dolist (group groups)
+ (unless (member group tgroups)
(setcdr entry (list group))
(setq entry (cdr entry)))))
;; Go through all topics and make sure they contain only living groups.
@@ -886,7 +886,7 @@ articles in the topic and its subtopics."
(while (setq group (pop topic))
(when (and (or (gnus-active group)
(gnus-info-method (gnus-get-info group)))
- (not (gnus-gethash group gnus-killed-hashtb)))
+ (not (gethash group gnus-killed-hashtb)))
(push group filtered-topic)))
(push (cons topic-name (nreverse filtered-topic)) result)))
(setq gnus-topic-alist (nreverse result))))
@@ -896,7 +896,7 @@ articles in the topic and its subtopics."
(with-current-buffer gnus-group-buffer
(let ((inhibit-read-only t))
(unless gnus-topic-inhibit-change-level
- (gnus-group-goto-group (or (car (nth 2 previous)) group))
+ (gnus-group-goto-group (or (car (nth 1 previous)) group))
(when (and gnus-topic-mode
gnus-topic-alist
(not gnus-topic-inhibit-change-level))
@@ -954,7 +954,7 @@ articles in the topic and its subtopics."
(if (not group)
(if (not (memq 'gnus-topic props))
(goto-char (point-max))
- (let ((topic (symbol-name (cadr (memq 'gnus-topic props)))))
+ (let ((topic (cadr (memq 'gnus-topic props))))
(or (gnus-topic-goto-topic topic)
(gnus-topic-goto-topic (gnus-topic-next-topic topic)))))
(if (gnus-group-goto-group group)
@@ -990,12 +990,8 @@ articles in the topic and its subtopics."
;; First we make sure that we have really read the active file.
(when (or force
(not gnus-topic-active-alist))
- (let (groups)
- ;; Get a list of all groups available.
- (mapatoms (lambda (g) (when (symbol-value g)
- (push (symbol-name g) groups)))
- gnus-active-hashtb)
- (setq groups (sort groups 'string<))
+ ;; Get a list of all groups available.
+ (let ((groups (sort (hash-table-keys gnus-active-hashtb) #'string<)))
;; Init the variables.
(setq gnus-topic-active-topology (list (list "" 'visible)))
(setq gnus-topic-active-alist nil)
@@ -1200,7 +1196,7 @@ If performed over a topic line, toggle folding the topic."
(save-excursion
(gnus-message 5 "Expiring groups in %s..." topic)
(let ((gnus-group-marked
- (mapcar (lambda (entry) (car (nth 2 entry)))
+ (mapcar (lambda (entry) (car (nth 1 entry)))
(gnus-topic-find-groups topic gnus-level-killed t
nil t))))
(gnus-group-expire-articles nil))
@@ -1214,7 +1210,7 @@ Also see `gnus-group-catchup'."
(call-interactively 'gnus-group-catchup-current)
(save-excursion
(let* ((groups
- (mapcar (lambda (entry) (car (nth 2 entry)))
+ (mapcar (lambda (entry) (car (nth 1 entry)))
(gnus-topic-find-groups topic gnus-level-killed t
nil t)))
(inhibit-read-only t)
@@ -1447,7 +1443,7 @@ If NON-RECURSIVE (which is the prefix) is t, don't mark its subtopics."
(not non-recursive))))
(while groups
(funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark)
- (gnus-info-group (nth 2 (pop groups)))))))))
+ (gnus-info-group (nth 1 (pop groups)))))))))
(defun gnus-topic-unmark-topic (topic &optional _dummy non-recursive)
"Remove the process mark from all groups in the TOPIC.
diff --git a/lisp/gnus/gnus-undo.el b/lisp/gnus/gnus-undo.el
index c5c920e2ea2..179679a8298 100644
--- a/lisp/gnus/gnus-undo.el
+++ b/lisp/gnus/gnus-undo.el
@@ -43,8 +43,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
-
(require 'gnus-util)
(require 'gnus)
diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el
index ae8cd45672e..6b0f29b0afb 100644
--- a/lisp/gnus/gnus-util.el
+++ b/lisp/gnus/gnus-util.el
@@ -32,16 +32,16 @@
;;; Code:
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'time-date)
+(require 'text-property-search)
(defcustom gnus-completing-read-function 'gnus-emacs-completing-read
"Function use to do completing read."
:version "24.1"
:group 'gnus-meta
- :type `(radio (function-item
+ :type '(radio (function-item
:doc "Use Emacs standard `completing-read' function."
gnus-emacs-completing-read)
(function-item
@@ -105,13 +105,6 @@ This is a compatibility function for different Emacsen."
(put 'gnus-eval-in-buffer-window 'lisp-indent-function 1)
(put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body))
-(defmacro gnus-intern-safe (string hashtable)
- "Get hash value. Arguments are STRING and HASHTABLE."
- `(let ((symbol (intern ,string ,hashtable)))
- (or (boundp symbol)
- (set symbol nil))
- symbol))
-
(defsubst gnus-goto-char (point)
(and point (goto-char point)))
@@ -142,7 +135,7 @@ This is a compatibility function for different Emacsen."
"Extract address components from a From header.
Given an RFC-822 (or later) address FROM, extract name and address.
Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). Much more simple
-solution than `mail-extract-address-components', which works much better, but
+solution than `mail-header-parse-address', which works much better, but
is slower."
(let (name address)
;; First find the address - the thing with the @ in it. This may
@@ -200,6 +193,36 @@ is slower."
(search-forward ":" eol t)
(point)))))
+(defun gnus-text-property-search (prop value &optional forward-only goto end)
+ "Search current buffer for text property PROP with VALUE.
+Behaves like a combination of `text-property-any' and
+`text-property-search-forward'. Searches for the beginning of a
+text property `equal' to VALUE. Returns the value of point at
+the beginning of the matching text property span.
+
+If FORWARD-ONLY is non-nil, only search forward from point.
+
+If GOTO is non-nil, move point to the beginning of that span
+instead.
+
+If END is non-nil, use the end of the span instead."
+ (let* ((start (point))
+ (found (progn
+ (unless forward-only
+ (goto-char (point-min)))
+ (text-property-search-forward
+ prop value #'equal)))
+ (target (when found
+ (if end
+ (prop-match-end found)
+ (prop-match-beginning found)))))
+ (when target
+ (if goto
+ (goto-char target)
+ (prog1
+ target
+ (goto-char start))))))
+
(declare-function gnus-find-method-for-group "gnus" (group &optional info))
(declare-function gnus-group-name-decode "gnus-group" (string charset))
(declare-function gnus-group-name-charset "gnus-group" (method group))
@@ -278,10 +301,7 @@ Symbols are also allowed; their print names are used instead."
;;; Time functions.
(defun gnus-file-newer-than (file date)
- (let ((fdate (nth 5 (file-attributes file))))
- (or (> (car fdate) (car date))
- (and (= (car fdate) (car date))
- (> (nth 1 fdate) (nth 1 date))))))
+ (time-less-p date (file-attribute-modification-time (file-attributes file))))
;;; Keymap macros.
@@ -394,22 +414,9 @@ Cache the result as a text property stored in DATE."
"Quote all \"%\"'s in STRING."
(replace-regexp-in-string "%" "%%" string))
-;; Make a hash table (default and minimum size is 256).
-;; Optional argument HASHSIZE specifies the table size.
-(defun gnus-make-hashtable (&optional hashsize)
- (make-vector (if hashsize (max (gnus-create-hash-size hashsize) 256) 256) 0))
-
-;; Make a number that is suitable for hashing; bigger than MIN and
-;; equal to some 2^x. Many machines (such as sparcs) do not have a
-;; hardware modulo operation, so they implement it in software. On
-;; many sparcs over 50% of the time to intern is spent in the modulo.
-;; Yes, it's slower than actually computing the hash from the string!
-;; So we use powers of 2 so people can optimize the modulo to a mask.
-(defun gnus-create-hash-size (min)
- (let ((i 1))
- (while (< i min)
- (setq i (* 2 i)))
- i))
+(defsubst gnus-make-hashtable (&optional size)
+ "Make a hash table of SIZE, testing on `equal'."
+ (make-hash-table :size (or size 300) :test #'equal))
(defcustom gnus-verbose 6
"Integer that says how verbose Gnus should be.
@@ -1117,41 +1124,9 @@ ARG is passed to the first function."
(with-current-buffer gnus-group-buffer
(eq major-mode 'gnus-group-mode))))
-(defun gnus-remove-if (predicate sequence &optional hash-table-p)
- "Return a copy of SEQUENCE with all items satisfying PREDICATE removed.
-SEQUENCE should be a list, a vector, or a string. Returns always a list.
-If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table."
- (let (out)
- (if hash-table-p
- (mapatoms (lambda (symbol)
- (unless (funcall predicate symbol)
- (push symbol out)))
- sequence)
- (unless (listp sequence)
- (setq sequence (append sequence nil)))
- (while sequence
- (unless (funcall predicate (car sequence))
- (push (car sequence) out))
- (setq sequence (cdr sequence))))
- (nreverse out)))
-
-(defun gnus-remove-if-not (predicate sequence &optional hash-table-p)
- "Return a copy of SEQUENCE with all items not satisfying PREDICATE removed.
-SEQUENCE should be a list, a vector, or a string. Returns always a list.
-If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table."
- (let (out)
- (if hash-table-p
- (mapatoms (lambda (symbol)
- (when (funcall predicate symbol)
- (push symbol out)))
- sequence)
- (unless (listp sequence)
- (setq sequence (append sequence nil)))
- (while sequence
- (when (funcall predicate (car sequence))
- (push (car sequence) out))
- (setq sequence (cdr sequence))))
- (nreverse out)))
+(define-obsolete-function-alias 'gnus-remove-if 'seq-remove "27.1")
+
+(define-obsolete-function-alias 'gnus-remove-if-not 'seq-filter "27.1")
(defun gnus-grep-in-list (word list)
"Find if a WORD matches any regular expression in the given LIST."
@@ -1210,18 +1185,16 @@ If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table."
;; The buffer should be in the unibyte mode because group names
;; are ASCII text or encoded non-ASCII text (i.e., unibyte).
(mm-disable-multibyte)
- (mapatoms
- (lambda (sym)
- (when (and sym
- (boundp sym)
- (symbol-value sym))
- (insert (format "%S %d %d y\n"
+ (maphash
+ (lambda (group active)
+ (when active
+ (insert (format "%s %d %d y\n"
(if full-names
- sym
- (intern (gnus-group-real-name (symbol-name sym))))
- (or (cdr (symbol-value sym))
- (car (symbol-value sym)))
- (car (symbol-value sym))))))
+ group
+ (gnus-group-real-name group))
+ (or (cdr active)
+ (car active))
+ (car active)))))
hashtb)
(goto-char (point-max))
(while (search-backward "\\." nil t)
@@ -1440,7 +1413,7 @@ SPEC is a predicate specifier that contains stuff like `or', `and',
(symbol-value history) collection))
filtered-choices)
(dolist (x choices)
- (setq filtered-choices (adjoin x filtered-choices)))
+ (setq filtered-choices (cl-adjoin x filtered-choices)))
(nreverse filtered-choices))))))
(unwind-protect
(progn
@@ -1467,7 +1440,7 @@ SPEC is a predicate specifier that contains stuff like `or', `and',
(defun gnus-cache-file-contents (file variable function)
"Cache the contents of FILE in VARIABLE. The contents come from FUNCTION."
- (let ((time (nth 5 (file-attributes file)))
+ (let ((time (file-attribute-modification-time (file-attributes file)))
contents value)
(if (or (null (setq value (symbol-value variable)))
(not (equal (car value) file))
@@ -1648,8 +1621,7 @@ empty directories from OLD-PATH."
"Rescale IMAGE to SIZE if possible.
SIZE is in format (WIDTH . HEIGHT). Return a new image.
Sizes are in pixels."
- (if (or (not (fboundp 'imagemagick-types))
- (not (get-buffer-window (current-buffer))))
+ (if (not (fboundp 'imagemagick-types))
image
(let ((new-width (car size))
(new-height (cdr size)))
diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el
index 9907bb5cf5b..253ee24f32c 100644
--- a/lisp/gnus/gnus-uu.el
+++ b/lisp/gnus/gnus-uu.el
@@ -26,7 +26,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'gnus)
(require 'gnus-art)
@@ -2047,7 +2047,7 @@ If no file has been included, the user will be asked for a file."
(setq length (count-lines (point-min) (point-max)))
(setq parts (/ length gnus-uu-post-length))
(unless (< (% length gnus-uu-post-length) 4)
- (incf parts)))
+ (cl-incf parts)))
(when gnus-uu-post-separate-description
(forward-line -1))
@@ -2106,7 +2106,7 @@ If no file has been included, the user will be asked for a file."
(insert-buffer-substring uubuf beg end)
(insert beg-line "\n")
(setq beg end)
- (incf i)
+ (cl-incf i)
(goto-char (point-min))
(re-search-forward
(concat "^" (regexp-quote mail-header-separator) "$") nil t)
diff --git a/lisp/gnus/gnus-vm.el b/lisp/gnus/gnus-vm.el
index 98a362f6426..6042365c74f 100644
--- a/lisp/gnus/gnus-vm.el
+++ b/lisp/gnus/gnus-vm.el
@@ -34,12 +34,6 @@
(require 'gnus)
(require 'gnus-msg)
-(eval-when-compile
- (require 'cl))
-
-(autoload 'vm-mode "vm")
-(autoload 'vm-save-message "vm")
-
(defvar gnus-vm-inhibit-window-system nil
"Inhibit loading `win-vm' if using a window-system.
Has to be set before gnus-vm is loaded.")
@@ -49,6 +43,8 @@ Has to be set before gnus-vm is loaded.")
(when window-system
(require 'win-vm))))
+(declare-function vm-mode "ext:vm" (&optional read-only))
+
(defun gnus-vm-make-folder (&optional buffer)
(require 'vm)
(let ((article (or buffer (current-buffer)))
@@ -81,6 +77,8 @@ save those articles instead."
(let ((gnus-default-article-saver 'gnus-summary-save-in-vm))
(gnus-summary-save-article arg)))
+(declare-function vm-save-message "ext:vm-save" (folder &optional count))
+
(defun gnus-summary-save-in-vm (&optional folder)
(interactive)
(require 'vm)
diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el
index 4df6b039a4c..5f7154c5456 100644
--- a/lisp/gnus/gnus-win.el
+++ b/lisp/gnus/gnus-win.el
@@ -24,7 +24,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'gnus)
(require 'gnus-util)
@@ -312,7 +312,7 @@ See the Gnus manual for an explanation of the syntax used.")
;; Select the frame in question and do more splits there.
(select-frame frame)
(setq fresult (or (gnus-configure-frame (elt subs i)) fresult))
- (incf i))
+ (cl-incf i))
;; Select the frame that has the selected buffer.
(when fresult
(select-frame (window-frame fresult)))))
@@ -344,7 +344,7 @@ See the Gnus manual for an explanation of the syntax used.")
((eq type 'vertical)
(setq s (max s window-min-height))))
(setcar (cdar comp-subs) s)
- (incf total s)))
+ (cl-incf total s)))
;; Take care of the "1.0" spec.
(if rest
(setcar (cdr rest) (- len total))
@@ -513,7 +513,7 @@ should have point."
(memq frame '(t 0 visible)))
(car
(let ((frames (frames-on-display-list)))
- (gnus-remove-if (lambda (win) (not (memq (window-frame win)
+ (seq-remove (lambda (win) (not (memq (window-frame win)
frames)))
(get-buffer-window-list buffer nil frame)))))
(t
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index c3a57800e39..989347c9fd1 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -1,4 +1,4 @@
-;;; gnus.el --- a newsreader for GNU Emacs
+;;; gnus.el --- a newsreader for GNU Emacs -*- lexical-binding:t -*-
;; Copyright (C) 1987-1990, 1993-1998, 2000-2019 Free Software
;; Foundation, Inc.
@@ -29,10 +29,12 @@
(run-hooks 'gnus-load-hook)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib)
+ (require 'subr-x))
(require 'wid-edit)
(require 'mm-util)
(require 'nnheader)
+(require 'seq)
;; These are defined afterwards with gnus-define-group-parameter
(defvar gnus-ham-process-destinations)
@@ -335,21 +337,6 @@ be set in `.emacs' instead."
;; We define these group faces here to avoid the display
;; update forced when creating new faces.
-(defface gnus-group-news-1
- '((((class color)
- (background dark))
- (:foreground "PaleTurquoise" :bold t))
- (((class color)
- (background light))
- (:foreground "ForestGreen" :bold t))
- (t
- ()))
- "Level 1 newsgroup face."
- :group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-news-1-face 'face-alias 'gnus-group-news-1)
-(put 'gnus-group-news-1-face 'obsolete-face "22.1")
-
(defface gnus-group-news-1-empty
'((((class color)
(background dark))
@@ -361,24 +348,11 @@ be set in `.emacs' instead."
()))
"Level 1 empty newsgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-news-1-empty-face 'face-alias 'gnus-group-news-1-empty)
-(put 'gnus-group-news-1-empty-face 'obsolete-face "22.1")
-(defface gnus-group-news-2
- '((((class color)
- (background dark))
- (:foreground "turquoise" :bold t))
- (((class color)
- (background light))
- (:foreground "CadetBlue4" :bold t))
- (t
- ()))
- "Level 2 newsgroup face."
+(defface gnus-group-news-1
+ '((t (:inherit gnus-group-news-1-empty :bold t)))
+ "Level 1 newsgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-news-2-face 'face-alias 'gnus-group-news-2)
-(put 'gnus-group-news-2-face 'obsolete-face "22.1")
(defface gnus-group-news-2-empty
'((((class color)
@@ -391,24 +365,11 @@ be set in `.emacs' instead."
()))
"Level 2 empty newsgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-news-2-empty-face 'face-alias 'gnus-group-news-2-empty)
-(put 'gnus-group-news-2-empty-face 'obsolete-face "22.1")
-(defface gnus-group-news-3
- '((((class color)
- (background dark))
- (:bold t))
- (((class color)
- (background light))
- (:bold t))
- (t
- ()))
- "Level 3 newsgroup face."
+(defface gnus-group-news-2
+ '((t (:inherit gnus-group-news-2-empty :bold t)))
+ "Level 2 newsgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-news-3-face 'face-alias 'gnus-group-news-3)
-(put 'gnus-group-news-3-face 'obsolete-face "22.1")
(defface gnus-group-news-3-empty
'((((class color)
@@ -421,24 +382,11 @@ be set in `.emacs' instead."
()))
"Level 3 empty newsgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-news-3-empty-face 'face-alias 'gnus-group-news-3-empty)
-(put 'gnus-group-news-3-empty-face 'obsolete-face "22.1")
-(defface gnus-group-news-4
- '((((class color)
- (background dark))
- (:bold t))
- (((class color)
- (background light))
- (:bold t))
- (t
- ()))
- "Level 4 newsgroup face."
+(defface gnus-group-news-3
+ '((t (:inherit gnus-group-news-3-empty :bold t)))
+ "Level 3 newsgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-news-4-face 'face-alias 'gnus-group-news-4)
-(put 'gnus-group-news-4-face 'obsolete-face "22.1")
(defface gnus-group-news-4-empty
'((((class color)
@@ -451,24 +399,11 @@ be set in `.emacs' instead."
()))
"Level 4 empty newsgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-news-4-empty-face 'face-alias 'gnus-group-news-4-empty)
-(put 'gnus-group-news-4-empty-face 'obsolete-face "22.1")
-(defface gnus-group-news-5
- '((((class color)
- (background dark))
- (:bold t))
- (((class color)
- (background light))
- (:bold t))
- (t
- ()))
- "Level 5 newsgroup face."
+(defface gnus-group-news-4
+ '((t (:inherit gnus-group-news-4-empty :bold t)))
+ "Level 4 newsgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-news-5-face 'face-alias 'gnus-group-news-5)
-(put 'gnus-group-news-5-face 'obsolete-face "22.1")
(defface gnus-group-news-5-empty
'((((class color)
@@ -481,24 +416,11 @@ be set in `.emacs' instead."
()))
"Level 5 empty newsgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-news-5-empty-face 'face-alias 'gnus-group-news-5-empty)
-(put 'gnus-group-news-5-empty-face 'obsolete-face "22.1")
-(defface gnus-group-news-6
- '((((class color)
- (background dark))
- (:bold t))
- (((class color)
- (background light))
- (:bold t))
- (t
- ()))
- "Level 6 newsgroup face."
+(defface gnus-group-news-5
+ '((t (:inherit gnus-group-news-5-empty :bold t)))
+ "Level 5 newsgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-news-6-face 'face-alias 'gnus-group-news-6)
-(put 'gnus-group-news-6-face 'obsolete-face "22.1")
(defface gnus-group-news-6-empty
'((((class color)
@@ -511,24 +433,11 @@ be set in `.emacs' instead."
()))
"Level 6 empty newsgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-news-6-empty-face 'face-alias 'gnus-group-news-6-empty)
-(put 'gnus-group-news-6-empty-face 'obsolete-face "22.1")
-(defface gnus-group-news-low
- '((((class color)
- (background dark))
- (:foreground "DarkTurquoise" :bold t))
- (((class color)
- (background light))
- (:foreground "DarkGreen" :bold t))
- (t
- ()))
- "Low level newsgroup face."
+(defface gnus-group-news-6
+ '((t (:inherit gnus-group-news-6-empty :bold t)))
+ "Level 6 newsgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-news-low-face 'face-alias 'gnus-group-news-low)
-(put 'gnus-group-news-low-face 'obsolete-face "22.1")
(defface gnus-group-news-low-empty
'((((class color)
@@ -541,24 +450,11 @@ be set in `.emacs' instead."
()))
"Low level empty newsgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-news-low-empty-face 'face-alias 'gnus-group-news-low-empty)
-(put 'gnus-group-news-low-empty-face 'obsolete-face "22.1")
-(defface gnus-group-mail-1
- '((((class color)
- (background dark))
- (:foreground "#e1ffe1" :bold t))
- (((class color)
- (background light))
- (:foreground "DeepPink3" :bold t))
- (t
- (:bold t)))
- "Level 1 mailgroup face."
+(defface gnus-group-news-low
+ '((t (:inherit gnus-group-news-low-empty :bold t)))
+ "Low level newsgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-mail-1-face 'face-alias 'gnus-group-mail-1)
-(put 'gnus-group-mail-1-face 'obsolete-face "22.1")
(defface gnus-group-mail-1-empty
'((((class color)
@@ -568,27 +464,14 @@ be set in `.emacs' instead."
(background light))
(:foreground "DeepPink3"))
(t
- (:italic t :bold t)))
+ (:italic t)))
"Level 1 empty mailgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-mail-1-empty-face 'face-alias 'gnus-group-mail-1-empty)
-(put 'gnus-group-mail-1-empty-face 'obsolete-face "22.1")
-(defface gnus-group-mail-2
- '((((class color)
- (background dark))
- (:foreground "DarkSeaGreen1" :bold t))
- (((class color)
- (background light))
- (:foreground "HotPink3" :bold t))
- (t
- (:bold t)))
- "Level 2 mailgroup face."
+(defface gnus-group-mail-1
+ '((t (:inherit gnus-group-mail-1-empty :bold t)))
+ "Level 1 mailgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-mail-2-face 'face-alias 'gnus-group-mail-2)
-(put 'gnus-group-mail-2-face 'obsolete-face "22.1")
(defface gnus-group-mail-2-empty
'((((class color)
@@ -598,27 +481,14 @@ be set in `.emacs' instead."
(background light))
(:foreground "HotPink3"))
(t
- (:bold t)))
+ (:italic t)))
"Level 2 empty mailgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-mail-2-empty-face 'face-alias 'gnus-group-mail-2-empty)
-(put 'gnus-group-mail-2-empty-face 'obsolete-face "22.1")
-(defface gnus-group-mail-3
- '((((class color)
- (background dark))
- (:foreground "aquamarine1" :bold t))
- (((class color)
- (background light))
- (:foreground "magenta4" :bold t))
- (t
- (:bold t)))
- "Level 3 mailgroup face."
+(defface gnus-group-mail-2
+ '((t (:inherit gnus-group-mail-2-empty :bold t)))
+ "Level 2 mailgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-mail-3-face 'face-alias 'gnus-group-mail-3)
-(put 'gnus-group-mail-3-face 'obsolete-face "22.1")
(defface gnus-group-mail-3-empty
'((((class color)
@@ -631,24 +501,11 @@ be set in `.emacs' instead."
()))
"Level 3 empty mailgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-mail-3-empty-face 'face-alias 'gnus-group-mail-3-empty)
-(put 'gnus-group-mail-3-empty-face 'obsolete-face "22.1")
-(defface gnus-group-mail-low
- '((((class color)
- (background dark))
- (:foreground "aquamarine2" :bold t))
- (((class color)
- (background light))
- (:foreground "DeepPink4" :bold t))
- (t
- (:bold t)))
- "Low level mailgroup face."
+(defface gnus-group-mail-3
+ '((t (:inherit gnus-group-mail-3-empty :bold t)))
+ "Level 3 mailgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-mail-low-face 'face-alias 'gnus-group-mail-low)
-(put 'gnus-group-mail-low-face 'obsolete-face "22.1")
(defface gnus-group-mail-low-empty
'((((class color)
@@ -661,57 +518,23 @@ be set in `.emacs' instead."
(:bold t)))
"Low level empty mailgroup face."
:group 'gnus-group)
-;; backward-compatibility alias
-(put 'gnus-group-mail-low-empty-face 'face-alias 'gnus-group-mail-low-empty)
-(put 'gnus-group-mail-low-empty-face 'obsolete-face "22.1")
+
+(defface gnus-group-mail-low
+ '((t (:inherit gnus-group-mail-low-empty :bold t)))
+ "Low level mailgroup face."
+ :group 'gnus-group)
;; Summary mode faces.
(defface gnus-summary-selected '((t (:underline t)))
"Face used for selected articles."
:group 'gnus-summary)
-;; backward-compatibility alias
-(put 'gnus-summary-selected-face 'face-alias 'gnus-summary-selected)
-(put 'gnus-summary-selected-face 'obsolete-face "22.1")
(defface gnus-summary-cancelled
'((((class color))
(:foreground "yellow" :background "black")))
"Face used for canceled articles."
:group 'gnus-summary)
-;; backward-compatibility alias
-(put 'gnus-summary-cancelled-face 'face-alias 'gnus-summary-cancelled)
-(put 'gnus-summary-cancelled-face 'obsolete-face "22.1")
-
-(defface gnus-summary-high-ticked
- '((((class color)
- (background dark))
- (:foreground "pink" :bold t))
- (((class color)
- (background light))
- (:foreground "firebrick" :bold t))
- (t
- (:bold t)))
- "Face used for high interest ticked articles."
- :group 'gnus-summary)
-;; backward-compatibility alias
-(put 'gnus-summary-high-ticked-face 'face-alias 'gnus-summary-high-ticked)
-(put 'gnus-summary-high-ticked-face 'obsolete-face "22.1")
-
-(defface gnus-summary-low-ticked
- '((((class color)
- (background dark))
- (:foreground "pink" :italic t))
- (((class color)
- (background light))
- (:foreground "firebrick" :italic t))
- (t
- (:italic t)))
- "Face used for low interest ticked articles."
- :group 'gnus-summary)
-;; backward-compatibility alias
-(put 'gnus-summary-low-ticked-face 'face-alias 'gnus-summary-low-ticked)
-(put 'gnus-summary-low-ticked-face 'obsolete-face "22.1")
(defface gnus-summary-normal-ticked
'((((class color)
@@ -724,39 +547,16 @@ be set in `.emacs' instead."
()))
"Face used for normal interest ticked articles."
:group 'gnus-summary)
-;; backward-compatibility alias
-(put 'gnus-summary-normal-ticked-face 'face-alias 'gnus-summary-normal-ticked)
-(put 'gnus-summary-normal-ticked-face 'obsolete-face "22.1")
-(defface gnus-summary-high-ancient
- '((((class color)
- (background dark))
- (:foreground "SkyBlue" :bold t))
- (((class color)
- (background light))
- (:foreground "RoyalBlue" :bold t))
- (t
- (:bold t)))
- "Face used for high interest ancient articles."
+(defface gnus-summary-high-ticked
+ '((t (:inherit gnus-summary-normal-ticked :bold t)))
+ "Face used for high interest ticked articles."
:group 'gnus-summary)
-;; backward-compatibility alias
-(put 'gnus-summary-high-ancient-face 'face-alias 'gnus-summary-high-ancient)
-(put 'gnus-summary-high-ancient-face 'obsolete-face "22.1")
-(defface gnus-summary-low-ancient
- '((((class color)
- (background dark))
- (:foreground "SkyBlue" :italic t))
- (((class color)
- (background light))
- (:foreground "RoyalBlue" :italic t))
- (t
- (:italic t)))
- "Face used for low interest ancient articles."
+(defface gnus-summary-low-ticked
+ '((t (:inherit gnus-summary-normal-ticked :italic t)))
+ "Face used for low interest ticked articles."
:group 'gnus-summary)
-;; backward-compatibility alias
-(put 'gnus-summary-low-ancient-face 'face-alias 'gnus-summary-low-ancient)
-(put 'gnus-summary-low-ancient-face 'obsolete-face "22.1")
(defface gnus-summary-normal-ancient
'((((class color)
@@ -769,35 +569,16 @@ be set in `.emacs' instead."
()))
"Face used for normal interest ancient articles."
:group 'gnus-summary)
-;; backward-compatibility alias
-(put 'gnus-summary-normal-ancient-face 'face-alias 'gnus-summary-normal-ancient)
-(put 'gnus-summary-normal-ancient-face 'obsolete-face "22.1")
-(defface gnus-summary-high-undownloaded
- '((((class color)
- (background light))
- (:bold t :foreground "cyan4"))
- (((class color) (background dark))
- (:bold t :foreground "LightGray"))
- (t (:inverse-video t :bold t)))
- "Face used for high interest uncached articles."
+(defface gnus-summary-high-ancient
+ '((t (:inherit gnus-summary-normal-ancient :bold t)))
+ "Face used for high interest ancient articles."
:group 'gnus-summary)
-;; backward-compatibility alias
-(put 'gnus-summary-high-undownloaded-face 'face-alias 'gnus-summary-high-undownloaded)
-(put 'gnus-summary-high-undownloaded-face 'obsolete-face "22.1")
-(defface gnus-summary-low-undownloaded
- '((((class color)
- (background light))
- (:italic t :foreground "cyan4" :bold nil))
- (((class color) (background dark))
- (:italic t :foreground "LightGray" :bold nil))
- (t (:inverse-video t :italic t)))
- "Face used for low interest uncached articles."
+(defface gnus-summary-low-ancient
+ '((t (:inherit gnus-summary-normal-ancient :italic t)))
+ "Face used for low interest ancient articles."
:group 'gnus-summary)
-;; backward-compatibility alias
-(put 'gnus-summary-low-undownloaded-face 'face-alias 'gnus-summary-low-undownloaded)
-(put 'gnus-summary-low-undownloaded-face 'obsolete-face "22.1")
(defface gnus-summary-normal-undownloaded
'((((class color)
@@ -808,70 +589,32 @@ be set in `.emacs' instead."
(t (:inverse-video t)))
"Face used for normal interest uncached articles."
:group 'gnus-summary)
-;; backward-compatibility alias
-(put 'gnus-summary-normal-undownloaded-face 'face-alias 'gnus-summary-normal-undownloaded)
-(put 'gnus-summary-normal-undownloaded-face 'obsolete-face "22.1")
-(defface gnus-summary-high-unread
- '((t
- (:bold t)))
- "Face used for high interest unread articles."
+(defface gnus-summary-high-undownloaded
+ '((t (:inherit gnus-summary-normal-undownloaded :bold t)))
+ "Face used for high interest uncached articles."
:group 'gnus-summary)
-;; backward-compatibility alias
-(put 'gnus-summary-high-unread-face 'face-alias 'gnus-summary-high-unread)
-(put 'gnus-summary-high-unread-face 'obsolete-face "22.1")
-(defface gnus-summary-low-unread
- '((t
- (:italic t)))
- "Face used for low interest unread articles."
+(defface gnus-summary-low-undownloaded
+ '((t (:inherit gnus-summary-normal-undownloaded :italic t)))
+ "Face used for low interest uncached articles."
:group 'gnus-summary)
-;; backward-compatibility alias
-(put 'gnus-summary-low-unread-face 'face-alias 'gnus-summary-low-unread)
-(put 'gnus-summary-low-unread-face 'obsolete-face "22.1")
(defface gnus-summary-normal-unread
'((t
()))
"Face used for normal interest unread articles."
:group 'gnus-summary)
-;; backward-compatibility alias
-(put 'gnus-summary-normal-unread-face 'face-alias 'gnus-summary-normal-unread)
-(put 'gnus-summary-normal-unread-face 'obsolete-face "22.1")
-(defface gnus-summary-high-read
- '((((class color)
- (background dark))
- (:foreground "PaleGreen"
- :bold t))
- (((class color)
- (background light))
- (:foreground "DarkGreen"
- :bold t))
- (t
- (:bold t)))
- "Face used for high interest read articles."
+(defface gnus-summary-high-unread
+ '((t (:inherit gnus-summary-normal-unread :bold t)))
+ "Face used for high interest unread articles."
:group 'gnus-summary)
-;; backward-compatibility alias
-(put 'gnus-summary-high-read-face 'face-alias 'gnus-summary-high-read)
-(put 'gnus-summary-high-read-face 'obsolete-face "22.1")
-(defface gnus-summary-low-read
- '((((class color)
- (background dark))
- (:foreground "PaleGreen"
- :italic t))
- (((class color)
- (background light))
- (:foreground "DarkGreen"
- :italic t))
- (t
- (:italic t)))
- "Face used for low interest read articles."
+(defface gnus-summary-low-unread
+ '((t (:inherit gnus-summary-normal-unread :italic t)))
+ "Face used for low interest unread articles."
:group 'gnus-summary)
-;; backward-compatibility alias
-(put 'gnus-summary-low-read-face 'face-alias 'gnus-summary-low-read)
-(put 'gnus-summary-low-read-face 'obsolete-face "22.1")
(defface gnus-summary-normal-read
'((((class color)
@@ -884,10 +627,23 @@ be set in `.emacs' instead."
()))
"Face used for normal interest read articles."
:group 'gnus-summary)
-;; backward-compatibility alias
-(put 'gnus-summary-normal-read-face 'face-alias 'gnus-summary-normal-read)
-(put 'gnus-summary-normal-read-face 'obsolete-face "22.1")
+(defface gnus-summary-high-read
+ '((t (:inherit gnus-summary-normal-read :bold t)))
+ "Face used for high interest read articles."
+ :group 'gnus-summary)
+
+(defface gnus-summary-low-read
+ '((t (:inherit gnus-summary-normal-read :italic t)))
+ "Face used for low interest read articles."
+ :group 'gnus-summary)
+
+;;; Base gnus-mode
+
+(define-derived-mode gnus-mode special-mode nil
+ "Base mode from which all other gnus modes derive.
+This does nothing but derive from `special-mode', and should not
+be used directly.")
;;;
;;; Gnus buffers
@@ -946,9 +702,6 @@ be set in `.emacs' instead."
()))
"Face for the splash screen."
:group 'gnus-start)
-;; backward-compatibility alias
-(put 'gnus-splash-face 'face-alias 'gnus-splash)
-(put 'gnus-splash-face 'obsolete-face "22.1")
(defun gnus-splash ()
(save-excursion
@@ -1006,6 +759,7 @@ be set in `.emacs' instead."
(cdr (assq gnus-logo-color-style gnus-logo-color-alist))
"Colors used for the Gnus logo.")
+(defvar image-load-path)
(declare-function image-size "image.c" (spec &optional pixels frame))
(defun gnus-group-startup-message (&optional x y)
@@ -1106,12 +860,11 @@ be set in `.emacs' instead."
(cons (car list) (list :type type :data data)))
list)))
-(eval-when (load)
- (let ((command (format "%s" this-command)))
- (when (string-match "gnus" command)
- (if (string-match "gnus-other-frame" command)
- (gnus-get-buffer-create gnus-group-buffer)
- (gnus-splash)))))
+(let ((command (format "%s" this-command)))
+ (when (string-match "gnus" command)
+ (if (eq 'gnus-other-frame this-command)
+ (gnus-get-buffer-create gnus-group-buffer)
+ (gnus-splash))))
;;; Do the rest.
@@ -2479,7 +2232,7 @@ Disabling the agent may result in noticeable loss of performance."
:group 'gnus-agent
:type 'boolean)
-(defcustom gnus-other-frame-function 'gnus
+(defcustom gnus-other-frame-function #'gnus
"Function called by the command `gnus-other-frame' when starting Gnus."
:group 'gnus-start
:type '(choice (function-item gnus)
@@ -2487,7 +2240,9 @@ Disabling the agent may result in noticeable loss of performance."
(function-item gnus-slave)
(function-item gnus-slave-no-server)))
-(defcustom gnus-other-frame-resume-function 'gnus-group-get-new-news
+(declare-function gnus-group-get-new-news "gnus-group")
+
+(defcustom gnus-other-frame-resume-function #'gnus-group-get-new-news
"Function called by the command `gnus-other-frame' when resuming Gnus."
:version "24.4"
:group 'gnus-start
@@ -2555,7 +2310,7 @@ a string, be sure to use a valid format, see RFC 2616."
)
(defvar gnus-agent-target-move-group-header "X-Gnus-Agent-Move-To")
(defvar gnus-draft-meta-information-header "X-Draft-From")
-(defvar gnus-group-get-parameter-function 'gnus-group-get-parameter)
+(defvar gnus-group-get-parameter-function #'gnus-group-get-parameter)
(defvar gnus-original-article-buffer " *Original Article*")
(defvar gnus-newsgroup-name nil)
(defvar gnus-ephemeral-servers nil)
@@ -2592,7 +2347,9 @@ a string, be sure to use a valid format, see RFC 2616."
(defvar gnus-group-history nil)
(defvar gnus-server-alist nil
- "List of available servers.")
+ "Servers created by Gnus, or via the server buffer.
+Servers defined in the user's config files do not appear here.
+This variable is persisted in the user's .newsrc.eld file.")
(defcustom gnus-cache-directory
(nnheader-concat gnus-directory "cache/")
@@ -2697,28 +2454,37 @@ such as a mark that says whether an article is stored in the cache
gnus-registry.el will populate this if it's loaded.")
(defvar gnus-newsrc-hashtb nil
- "Hashtable of `gnus-newsrc-alist'.")
+ "Hash table of `gnus-newsrc-alist'.")
+
+(defvar gnus-group-list nil
+ "Ordered list of group names as strings.
+This variable only exists to provide easy access to the ordering
+of `gnus-newsrc-alist'.")
(defvar gnus-killed-list nil
"List of killed newsgroups.")
(defvar gnus-killed-hashtb nil
- "Hash table equivalent of `gnus-killed-list'.")
+ "Hash table equivalent of `gnus-killed-list'.
+This is a hash table purely for the fast membership test: values
+are always t.")
(defvar gnus-zombie-list nil
"List of almost dead newsgroups.")
(defvar gnus-description-hashtb nil
- "Descriptions of newsgroups.")
+ "Hash table mapping group names to their descriptions.")
(defvar gnus-list-of-killed-groups nil
"List of newsgroups that have recently been killed by the user.")
(defvar gnus-active-hashtb nil
- "Hashtable of active articles.")
+ "Hash table mapping group names to their active entry.")
(defvar gnus-moderated-hashtb nil
- "Hashtable of moderated newsgroups.")
+ "Hash table of moderated groups.
+This is a hash table purely for the fast membership test: values
+are always t.")
;; Save window configuration.
(defvar gnus-prev-winconf nil)
@@ -2755,7 +2521,6 @@ gnus-registry.el will populate this if it's loaded.")
(nthcdr 3 package)
(cdr package)))))
'(("info" :interactive t Info-goto-node)
- ("pp" pp-to-string)
("qp" quoted-printable-decode-region quoted-printable-decode-string)
("ps-print" ps-print-preprint)
("message" :interactive t
@@ -2902,7 +2667,6 @@ gnus-registry.el will populate this if it's loaded.")
gnus-check-reasonable-setup)
("gnus-dup" gnus-dup-suppress-articles gnus-dup-unsuppress-article
gnus-dup-enter-articles)
- ("gnus-range" gnus-copy-sequence)
("gnus-eform" gnus-edit-form)
("gnus-logic" gnus-score-advanced)
("gnus-undo" gnus-undo-mode gnus-undo-register)
@@ -3016,7 +2780,7 @@ See Info node `(gnus)Formatting Variables'."
(defun gnus-suppress-keymap (keymap)
(suppress-keymap keymap)
- (let ((keys `([delete] "\177" "\M-u"))) ;[mouse-2]
+ (let ((keys '([delete] "\177" "\M-u"))) ;[mouse-2]
(while keys
(define-key keymap (pop keys) 'undefined))))
@@ -3046,36 +2810,21 @@ See Info node `(gnus)Formatting Variables'."
(defun gnus-header-from (header)
(mail-header-from header))
-(defmacro gnus-gethash (string hashtable)
- "Get hash value of STRING in HASHTABLE."
- `(symbol-value (intern-soft ,string ,hashtable)))
-
-(defmacro gnus-gethash-safe (string hashtable)
- "Get hash value of STRING in HASHTABLE.
-Return nil if not defined."
- `(let ((sym (intern-soft ,string ,hashtable)))
- (and (boundp sym) (symbol-value sym))))
-
-(defmacro gnus-sethash (string value hashtable)
- "Set hash value. Arguments are STRING, VALUE, and HASHTABLE."
- `(set (intern ,string ,hashtable) ,value))
-(put 'gnus-sethash 'edebug-form-spec '(form form form))
-
(defmacro gnus-group-unread (group)
"Get the currently computed number of unread articles in GROUP."
- `(car (gnus-gethash ,group gnus-newsrc-hashtb)))
+ `(car (gethash ,group gnus-newsrc-hashtb)))
(defmacro gnus-group-entry (group)
"Get the newsrc entry for GROUP."
- `(gnus-gethash ,group gnus-newsrc-hashtb))
+ `(gethash ,group gnus-newsrc-hashtb))
(defmacro gnus-active (group)
"Get active info on GROUP."
- `(gnus-gethash ,group gnus-active-hashtb))
+ `(gethash ,group gnus-active-hashtb))
(defmacro gnus-set-active (group active)
"Set GROUP's active info."
- `(gnus-sethash ,group ,active gnus-active-hashtb))
+ `(puthash ,group ,active gnus-active-hashtb))
;; Info access macros.
@@ -3139,10 +2888,10 @@ Return nil if not defined."
(setcar rank (cons (car rank) ,score)))))
(defmacro gnus-get-info (group)
- `(nth 2 (gnus-gethash ,group gnus-newsrc-hashtb)))
+ `(nth 1 (gethash ,group gnus-newsrc-hashtb)))
(defun gnus-set-info (group info)
- (setcar (nthcdr 2 (gnus-gethash group gnus-newsrc-hashtb))
+ (setcdr (gethash group gnus-newsrc-hashtb)
info))
@@ -3179,9 +2928,9 @@ with a `subscribed' parameter."
(or (gnus-group-fast-parameter group 'to-address)
(gnus-group-fast-parameter group 'to-list))))
(when address
- (add-to-list 'addresses address))))
+ (cl-pushnew address addresses :test #'equal))))
(when addresses
- (list (mapconcat 'regexp-quote addresses "\\|")))))
+ (list (mapconcat #'regexp-quote addresses "\\|")))))
(defmacro gnus-string-or (&rest strings)
"Return the first element of STRINGS that is a non-blank string.
@@ -3234,6 +2983,8 @@ If ARG, insert string at point."
minor least)
(format "%d.%02d%02d" major minor least))))))
+(defvar gnus-info-buffer)
+
(defun gnus-info-find-node (&optional nodename)
"Find Info documentation of Gnus."
(interactive)
@@ -3253,7 +3004,7 @@ If ARG, insert string at point."
(defvar gnus-current-prefix-symbols nil
"List of current prefix symbols.")
-(defun gnus-interactive (string &optional params)
+(defun gnus-interactive (string)
"Return a list that can be fed to `interactive'.
See `interactive' for full documentation.
@@ -3345,9 +3096,9 @@ g -- Group name."
(setq out (delq 'gnus-prefix-nil out))
(nreverse out)))
-(defun gnus-symbolic-argument (&optional arg)
+(defun gnus-symbolic-argument ()
"Read a symbolic argument and a command, and then execute command."
- (interactive "P")
+ (interactive)
(let* ((in-command (this-command-keys))
(command in-command)
gnus-current-prefix-symbols
@@ -3429,7 +3180,7 @@ that that variable is buffer-local to the summary buffers."
(defun gnus-kill-ephemeral-group (group)
"Remove ephemeral GROUP from relevant structures."
- (gnus-sethash group nil gnus-newsrc-hashtb))
+ (remhash group gnus-newsrc-hashtb))
(defun gnus-simplify-mode-line ()
"Make mode lines a bit simpler."
@@ -3463,16 +3214,15 @@ that that variable is buffer-local to the summary buffers."
(throw 'server-name (car name-method))))
gnus-server-method-cache))
- (mapc
- (lambda (server-alist)
- (mapc (lambda (name-method)
- (when (gnus-methods-equal-p (cdr name-method) method)
- (unless (member name-method gnus-server-method-cache)
- (push name-method gnus-server-method-cache))
- (throw 'server-name (car name-method))))
- server-alist))
- (list gnus-server-alist
- gnus-predefined-server-alist))
+ (dolist (server-alist
+ (list gnus-server-alist
+ gnus-predefined-server-alist))
+ (mapc (lambda (name-method)
+ (when (gnus-methods-equal-p (cdr name-method) method)
+ (unless (member name-method gnus-server-method-cache)
+ (push name-method gnus-server-method-cache))
+ (throw 'server-name (car name-method))))
+ server-alist))
(let* ((name (if (member (cadr method) '(nil ""))
(format "%s" (car method))
@@ -3574,26 +3324,26 @@ that that variable is buffer-local to the summary buffers."
(let ((p1 (copy-sequence (cddr m1)))
(p2 (copy-sequence (cddr m2)))
e1 e2)
- (block nil
+ (cl-block nil
(while (setq e1 (pop p1))
(unless (setq e2 (assq (car e1) p2))
;; The parameter doesn't exist in p2.
- (return nil))
+ (cl-return nil))
(setq p2 (delq e2 p2))
(unless (equal e1 e2)
(if (not (and (stringp (cadr e1))
(stringp (cadr e2))))
- (return nil)
+ (cl-return nil)
;; Special-case string parameter comparison so that we
;; can uniquify them.
(let ((s1 (cadr e1))
(s2 (cadr e2)))
- (when (string-match "/$" s1)
+ (when (string-match "/\\'" s1)
(setq s1 (directory-file-name s1)))
- (when (string-match "/$" s2)
+ (when (string-match "/\\'" s2)
(setq s2 (directory-file-name s2)))
(unless (equal s1 s2)
- (return nil))))))
+ (cl-return nil))))))
;; If p2 now is empty, they were equal.
(null p2))))
@@ -3981,8 +3731,7 @@ If SCORE is nil, add 1 to the score of GROUP."
"Collapse GROUP name LEVELS.
Select methods are stripped and any remote host name is stripped down to
just the host name."
- (let* ((name "")
- (foreign "")
+ (let* ((foreign "")
(depth 0)
(skip 1)
(levels (or levels
@@ -3997,7 +3746,7 @@ just the host name."
;; otherwise collapse to select method.
(let* ((colon (string-match ":" group))
(server (and colon (substring group 0 colon)))
- (plus (and server (string-match "+" server))))
+ (plus (and server (string-match "\\+" server))))
(when server
(if plus
(setq foreign (substring server (+ 1 plus)
@@ -4024,13 +3773,13 @@ just the host name."
gsep "."))
(setq levels (- glen levels))
(dolist (g glist)
- (push (if (>= (decf levels) 0)
+ (push (if (>= (cl-decf levels) 0)
(if (zerop (length g))
""
(substring g 0 1))
g)
res))
- (concat foreign (mapconcat 'identity (nreverse res) gsep))))))
+ (concat foreign (mapconcat #'identity (nreverse res) gsep))))))
(defun gnus-narrow-to-body ()
"Narrow to the body of an article."
@@ -4272,7 +4021,7 @@ Allow completion over sensible values."
gnus-server-alist))
(method
(gnus-completing-read
- prompt (mapcar 'car servers)
+ prompt (mapcar #'car servers)
t nil 'gnus-method-history)))
(cond
((equal method "")
@@ -4385,13 +4134,13 @@ current display is used."
(progn (switch-to-buffer gnus-group-buffer)
(funcall gnus-other-frame-resume-function arg))
(funcall gnus-other-frame-function arg)
- (add-hook 'gnus-exit-gnus-hook 'gnus-delete-gnus-frame)
+ (add-hook 'gnus-exit-gnus-hook #'gnus-delete-gnus-frame)
;; One might argue that `gnus-delete-gnus-frame' should not be called
;; from `gnus-suspend-gnus-hook', but, on the other hand, one might
;; argue that it should. No matter what you think, for the sake of
;; those who want it to be called from it, please keep (defun
;; gnus-delete-gnus-frame) even if you remove the next `add-hook'.
- (add-hook 'gnus-suspend-gnus-hook 'gnus-delete-gnus-frame)))))
+ (add-hook 'gnus-suspend-gnus-hook #'gnus-delete-gnus-frame)))))
;;;###autoload
(defun gnus (&optional arg dont-connect slave)
diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el
index 7251286f9b7..7514e64e7c2 100644
--- a/lisp/gnus/mail-source.el
+++ b/lisp/gnus/mail-source.el
@@ -26,7 +26,7 @@
(require 'format-spec)
(eval-when-compile
- (require 'cl)
+ (require 'cl-lib)
(require 'imap))
(autoload 'auth-source-search "auth-source")
(autoload 'pop3-movemail "pop3")
@@ -439,7 +439,7 @@ the `mail-source-keyword-map' variable."
;; the msname is the mail-source parameter
(dolist (msname '(:server :user :port))
;; the asname is the auth-source parameter
- (let* ((asname (case msname
+ (let* ((asname (cl-case msname
(:server :host) ; auth-source uses :host
(t msname)))
;; this is the mail-source default
@@ -602,7 +602,8 @@ If CONFIRM is non-nil, ask for confirmation before removing a file."
(let* ((ffile (car files))
(bfile (replace-regexp-in-string "\\`.*/\\([^/]+\\)\\'" "\\1"
ffile))
- (filetime (nth 5 (file-attributes ffile))))
+ (filetime (file-attribute-modification-time
+ (file-attributes ffile))))
(setq files (cdr files))
(when (and (> (time-to-number-of-days (time-subtract now filetime))
diff)
@@ -618,7 +619,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
(defun mail-source-callback (callback info)
"Call CALLBACK on the mail file. Pass INFO on to CALLBACK."
(if (or (not (file-exists-p mail-source-crash-box))
- (zerop (nth 7 (file-attributes mail-source-crash-box))))
+ (zerop (file-attribute-size
+ (file-attributes mail-source-crash-box))))
(progn
(when (file-exists-p mail-source-crash-box)
(delete-file mail-source-crash-box))
@@ -645,9 +647,9 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
;; Don't check for old incoming files more than once per day to
;; save a lot of file accesses.
(when (or (null mail-source-incoming-last-checked-time)
- (> (float-time
- (time-since mail-source-incoming-last-checked-time))
- (* 24 60 60)))
+ (time-less-p
+ (* 24 60 60)
+ (time-since mail-source-incoming-last-checked-time)))
(setq mail-source-incoming-last-checked-time (current-time))
(mail-source-delete-old-incoming
mail-source-delete-incoming
@@ -670,7 +672,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
((not (file-exists-p from))
;; There is no inbox.
(setq to nil))
- ((zerop (nth 7 (file-attributes from)))
+ ((zerop (file-attribute-size (file-attributes from)))
;; Empty file.
(setq to nil))
(t
@@ -790,7 +792,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
(when (and (file-regular-p file)
(funcall predicate file)
(mail-source-movemail file mail-source-crash-box))
- (incf found (mail-source-callback callback file))
+ (cl-incf found (mail-source-callback callback file))
(mail-source-run-script postscript (format-spec-make ?t path))
(mail-source-delete-crash-box)))
found)))
@@ -1045,7 +1047,7 @@ This only works when `display-time' is enabled."
(insert "\001\001\001\001\n"))
(delete-file file)
nil))))
- (incf found (mail-source-callback callback file))
+ (cl-incf found (mail-source-callback callback file))
(mail-source-delete-crash-box)))))
found)))
@@ -1120,7 +1122,7 @@ This only works when `display-time' is enabled."
(replace-match ">From "))
(goto-char (point-max))))
(nnheader-ms-strip-cr))
- (incf found (mail-source-callback callback server))
+ (cl-incf found (mail-source-callback callback server))
(mail-source-delete-crash-box)
(when (and remove fetchflag)
(setq remove (nreverse remove))
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index d260bdb2a2c..c8b6f0ee685 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -28,9 +28,7 @@
;;; Code:
-(eval-when-compile
- (require 'cl))
-
+(require 'cl-lib)
(require 'mailheader)
(require 'gmm-utils)
(require 'mail-utils)
@@ -158,7 +156,7 @@ If this variable is nil, no such courtesy message will be added."
:group 'message-interface
:type 'regexp)
-(defcustom message-from-style mail-from-style
+(defcustom message-from-style 'angles
"Specifies how \"From\" headers look.
If nil, they contain just the return address like:
@@ -170,12 +168,16 @@ If `angles', they look like:
Otherwise, most addresses look like `angles', but they look like
`parens' if `angles' would need quoting and `parens' would not."
- :version "23.2"
+ :version "27.1"
:type '(choice (const :tag "simple" nil)
(const parens)
(const angles)
(const default))
:group 'message-headers)
+(make-obsolete-variable
+ 'message-from-style
+ "Only the `angles' value is valid according to RFC2822" "27.1")
+
(defcustom message-insert-canlock t
"Whether to insert a Cancel-Lock header in news postings."
@@ -550,10 +552,15 @@ The provided functions are:
(function-item message-forward-subject-name-subject)
(repeat :tag "List of functions" function)))
-(defcustom message-forward-as-mime t
+(defcustom message-forward-as-mime nil
"Non-nil means forward messages as an inline/rfc822 MIME section.
-Otherwise, directly inline the old message in the forwarded message."
- :version "21.1"
+Otherwise, directly inline the old message in the forwarded
+message.
+
+When forwarding as MIME, certain MIME-related headers in the
+forwarded message may be removed/altered to ensure that the
+resulting mail is syntactically valid."
+ :version "27.1"
:group 'message-forwarding
:link '(custom-manual "(message)Forwarding")
:type 'boolean)
@@ -605,6 +612,9 @@ 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 only consulted when forwarding \"normally\", not
+when forwarding as MIME or the like.
+
This may also be a list of regexps."
:version "21.1"
:group 'message-forwarding
@@ -615,11 +625,12 @@ This may also be a list of regexps."
(widget-editable-list-match widget value)))
regexp))
-(defcustom message-forward-included-headers nil
+(defcustom message-forward-included-headers
+ '("^From:" "^Subject:" "^Date:")
"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."
- :version "25.1"
+ :version "27.1"
:group 'message-forwarding
:type '(repeat :value-to-internal (lambda (widget value)
(custom-split-regexp-maybe value))
@@ -1241,13 +1252,13 @@ called and its result is inserted."
;; Ease the transition from mail-mode to message-mode. See bugs#4431, 5555.
(concat (if (and (boundp 'mail-default-reply-to)
(stringp mail-default-reply-to))
- (format "Reply-to: %s\n" mail-default-reply-to))
+ (format "Reply-To: %s\n" mail-default-reply-to))
(if (and (boundp 'mail-self-blind)
mail-self-blind)
- (format "BCC: %s\n" user-mail-address))
+ (format "Bcc: %s\n" user-mail-address))
(if (and (boundp 'mail-archive-file-name)
(stringp mail-archive-file-name))
- (format "FCC: %s\n" mail-archive-file-name))
+ (format "Fcc: %s\n" mail-archive-file-name))
mail-default-headers)
"A string of header lines to be inserted in outgoing mails."
:version "23.2"
@@ -1277,7 +1288,7 @@ called and its result is inserted."
;; According to RFC 822 and its successors, the field name must
;; consist of printable US-ASCII characters other than colon,
;; i.e., decimal 33-56 and 59-126.
- '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:"))
+ '(looking-at "[ \t]\\|[][!\"#$%&'()*+,./0-9;<=>?@A-Z\\^_`a-z{|}~-]+:"))
"Set this non-nil if the system's mailer runs the header and body together.
\(This problem exists on Sunos 4 when sendmail is run in remote mode.)
The value should be an expression to test whether the problem will
@@ -1340,7 +1351,8 @@ If nil, Message won't auto-save."
:link '(custom-manual "(message)Various Message Variables")
:type '(choice directory (const :tag "Don't auto-save" nil)))
-(defcustom message-default-charset (and (not (mm-multibyte-p)) 'iso-8859-1)
+(defcustom message-default-charset (and (not enable-multibyte-characters)
+ 'iso-8859-1)
"Default charset used in non-MULE Emacsen.
If nil, you might be asked to input the charset."
:version "21.1"
@@ -1435,8 +1447,6 @@ starting with `not' and followed by regexps."
:bold t :italic t))
"Face used for displaying To headers."
:group 'message-faces)
-(define-obsolete-face-alias 'message-header-to-face
- 'message-header-to "22.1")
(defface message-header-cc
'((((class color)
@@ -1449,8 +1459,6 @@ starting with `not' and followed by regexps."
:bold t))
"Face used for displaying Cc headers."
:group 'message-faces)
-(define-obsolete-face-alias 'message-header-cc-face
- 'message-header-cc "22.1")
(defface message-header-subject
'((((class color)
@@ -1463,8 +1471,6 @@ starting with `not' and followed by regexps."
:bold t))
"Face used for displaying Subject headers."
:group 'message-faces)
-(define-obsolete-face-alias 'message-header-subject-face
- 'message-header-subject "22.1")
(defface message-header-newsgroups
'((((class color)
@@ -1477,8 +1483,6 @@ starting with `not' and followed by regexps."
:bold t :italic t))
"Face used for displaying Newsgroups headers."
:group 'message-faces)
-(define-obsolete-face-alias 'message-header-newsgroups-face
- 'message-header-newsgroups "22.1")
(defface message-header-other
'((((class color)
@@ -1491,8 +1495,6 @@ starting with `not' and followed by regexps."
:bold t :italic t))
"Face used for displaying other headers."
:group 'message-faces)
-(define-obsolete-face-alias 'message-header-other-face
- 'message-header-other "22.1")
(defface message-header-name
'((((class color)
@@ -1505,8 +1507,6 @@ starting with `not' and followed by regexps."
:bold t))
"Face used for displaying header names."
:group 'message-faces)
-(define-obsolete-face-alias 'message-header-name-face
- 'message-header-name "22.1")
(defface message-header-xheader
'((((class color)
@@ -1519,8 +1519,6 @@ starting with `not' and followed by regexps."
:bold t))
"Face used for displaying X-Header headers."
:group 'message-faces)
-(define-obsolete-face-alias 'message-header-xheader-face
- 'message-header-xheader "22.1")
(defface message-separator
'((((class color)
@@ -1533,8 +1531,6 @@ starting with `not' and followed by regexps."
:bold t))
"Face used for displaying the separator."
:group 'message-faces)
-(define-obsolete-face-alias 'message-separator-face
- 'message-separator "22.1")
(defface message-cited-text
'((((class color)
@@ -1547,8 +1543,6 @@ starting with `not' and followed by regexps."
:bold t))
"Face used for displaying cited text names."
:group 'message-faces)
-(define-obsolete-face-alias 'message-cited-text-face
- 'message-cited-text "22.1")
(defface message-mml
'((((class color)
@@ -1561,53 +1555,50 @@ starting with `not' and followed by regexps."
:bold t))
"Face used for displaying MML."
:group 'message-faces)
-(define-obsolete-face-alias 'message-mml-face
- 'message-mml "22.1")
-(defun message-font-lock-make-header-matcher (regexp)
- (let ((form
- `(lambda (limit)
- (let ((start (point)))
- (save-restriction
- (widen)
- (goto-char (point-min))
- (if (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "$")
- nil t)
- (setq limit (min limit (match-beginning 0))))
- (goto-char start))
- (and (< start limit)
- (re-search-forward ,regexp limit t))))))
- (if (featurep 'bytecomp)
- (byte-compile form)
- form)))
+(defun message-match-to-eoh (_limit)
+ (let ((start (point)))
+ (rfc822-goto-eoh)
+ ;; Typical situation: some temporary change causes the header to be
+ ;; incorrect, so EOH comes earlier than intended: the last lines of the
+ ;; intended headers are now not considered part of the header any more,
+ ;; so they don't have the multiline property set. When the change is
+ ;; completed and the header has its correct shape again, the lack of the
+ ;; multiline property means we won't rehighlight the last lines of
+ ;; the header.
+ (if (< (point) start)
+ nil ;No header within start..limit.
+ ;; Here we disregard LIMIT so that we may extend the area again.
+ (set-match-data (list start (point)))
+ (point))))
(defvar message-font-lock-keywords
(let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?"))
- `((,(message-font-lock-make-header-matcher
- (concat "^\\([Tt]o:\\)" content))
- (1 'message-header-name)
- (2 'message-header-to nil t))
- (,(message-font-lock-make-header-matcher
- (concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content))
- (1 'message-header-name)
- (2 'message-header-cc nil t))
- (,(message-font-lock-make-header-matcher
- (concat "^\\([Ss]ubject:\\)" content))
- (1 'message-header-name)
- (2 'message-header-subject nil t))
- (,(message-font-lock-make-header-matcher
- (concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content))
- (1 'message-header-name)
- (2 'message-header-newsgroups nil t))
- (,(message-font-lock-make-header-matcher
- (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content))
- (1 'message-header-name)
- (2 'message-header-xheader))
- (,(message-font-lock-make-header-matcher
- (concat "^\\([A-Z][^: \n\t]+:\\)" content))
- (1 'message-header-name)
- (2 'message-header-other nil t))
+ `((message-match-to-eoh
+ (,(concat "^\\([Tt]o:\\)" content)
+ (progn (goto-char (match-beginning 0)) (match-end 0)) nil
+ (1 'message-header-name)
+ (2 'message-header-to nil t))
+ (,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content)
+ (progn (goto-char (match-beginning 0)) (match-end 0)) nil
+ (1 'message-header-name)
+ (2 'message-header-cc nil t))
+ (,(concat "^\\([Ss]ubject:\\)" content)
+ (progn (goto-char (match-beginning 0)) (match-end 0)) nil
+ (1 'message-header-name)
+ (2 'message-header-subject nil t))
+ (,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)
+ (progn (goto-char (match-beginning 0)) (match-end 0)) nil
+ (1 'message-header-name)
+ (2 'message-header-newsgroups nil t))
+ (,(concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content)
+ (progn (goto-char (match-beginning 0)) (match-end 0)) nil
+ (1 'message-header-name)
+ (2 'message-header-xheader))
+ (,(concat "^\\([A-Z][^: \n\t]+:\\)" content)
+ (progn (goto-char (match-beginning 0)) (match-end 0)) nil
+ (1 'message-header-name)
+ (2 'message-header-other nil t)))
,@(if (and mail-header-separator
(not (equal mail-header-separator "")))
`((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
@@ -1861,7 +1852,7 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'."
"Alist of header names/filler functions.")
(defvar message-header-format-alist
- `((From)
+ '((From)
(Newsgroups)
(To)
(Cc)
@@ -2435,7 +2426,7 @@ Return the number of headers removed."
(looking-at "[!-9;-~]+:"))
(looking-at regexp))
(progn
- (incf number)
+ (cl-incf number)
(when first
(setq last t))
(delete-region
@@ -2460,10 +2451,10 @@ Return the number of headers removed."
(save-excursion
(goto-char (point-min))
(while (re-search-forward regexp nil t)
- (incf count)))
+ (cl-incf count)))
(while (> count 1)
(message-remove-header header nil t)
- (decf count))))
+ (cl-decf count))))
(defun message-narrow-to-headers ()
"Narrow the buffer to the head of the message."
@@ -2606,6 +2597,36 @@ PGG manual, depending on the value of `mml2015-use'."
(t
'message)))))
+(defun message-all-recipients ()
+ "Return a list of all recipients in the message, looking at TO, Cc and Bcc.
+
+Each recipient is in the format of `mail-extract-address-components'."
+ (mapcan (lambda (header)
+ (let ((header-value (message-fetch-field header)))
+ (and
+ header-value
+ (mail-extract-address-components header-value t))))
+ '("To" "Cc" "Bcc")))
+
+(defun message-all-epg-keys-available-p ()
+ "Return non-nil if the pgp keyring has a public key for each recipient."
+ (require 'epa)
+ (let ((context (epg-make-context epa-protocol)))
+ (catch 'break
+ (dolist (recipient (message-all-recipients))
+ (let ((recipient-email (cadr recipient)))
+ (when (and recipient-email (not (epg-list-keys context recipient-email)))
+ (throw 'break nil))))
+ t)))
+
+(defun message-sign-encrypt-if-all-keys-available ()
+ "Add MML tag to encrypt message when there is a key for each recipient.
+
+Consider adding this function to `message-send-hook' to
+systematically send encrypted emails when possible."
+ (when (message-all-epg-keys-available-p)
+ (mml-secure-message-sign-encrypt)))
+
;;;
@@ -2694,7 +2715,7 @@ PGG manual, depending on the value of `mml2015-use'."
(easy-menu-define
message-mode-menu message-mode-map "Message Menu."
- `("Message"
+ '("Message"
["Yank Original" message-yank-original message-reply-buffer]
["Fill Yanked Message" message-fill-yanked-message t]
["Insert Signature" message-insert-signature t]
@@ -2728,7 +2749,7 @@ PGG manual, depending on the value of `mml2015-use'."
(easy-menu-define
message-mode-field-menu message-mode-map ""
- `("Field"
+ '("Field"
["To" message-goto-to t]
["From" message-goto-from t]
["Subject" message-goto-subject t]
@@ -2843,8 +2864,7 @@ See also `message-forbidden-properties'."
(message-display-abbrev))
(when (and message-strip-special-text-properties
(message-tamago-not-in-use-p begin))
- (let ((buffer-read-only nil)
- (inhibit-read-only t))
+ (let ((inhibit-read-only t))
(remove-text-properties begin end message-forbidden-properties))))
(defvar message-smileys '(":-)" ":)"
@@ -2951,7 +2971,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)."
(easy-menu-add message-mode-menu message-mode-map)
(easy-menu-add message-mode-field-menu message-mode-map)
;; Mmmm... Forbidden properties...
- (add-hook 'after-change-functions 'message-strip-forbidden-properties
+ (add-hook 'after-change-functions #'message-strip-forbidden-properties
nil 'local)
;; Allow mail alias things.
(cond
@@ -2959,7 +2979,9 @@ M-RET `message-newline-and-reformat' (break the line and reformat)."
(mail-abbrevs-setup))
((message-mail-alias-type-p 'ecomplete)
(ecomplete-setup)))
- (add-hook 'completion-at-point-functions 'message-completion-function nil t)
+ ;; FIXME: merge the completion tables from ecomplete/bbdb/...?
+ ;;(add-hook 'completion-at-point-functions #'message-ecomplete-capf nil t)
+ (add-hook 'completion-at-point-functions #'message-completion-function nil t)
(unless buffer-file-name
(message-set-auto-save-file-name))
(unless (buffer-base-buffer)
@@ -3093,17 +3115,15 @@ M-RET `message-newline-and-reformat' (break the line and reformat)."
(push-mark)
(message-position-on-field "Summary" "Subject"))
-(defun message-goto-body ()
- "Move point to the beginning of the message body."
- (interactive)
- (when (and (called-interactively-p 'any)
- (looking-at "[ \t]*\n"))
+(define-obsolete-function-alias 'message-goto-body-1 'message-goto-body "27.1")
+(defun message-goto-body (&optional interactive)
+ "Move point to the beginning of the message body.
+Returns point."
+ (interactive "p")
+ (when interactive
+ (when (looking-at "[ \t]*\n")
(expand-abbrev))
- (push-mark)
- (message-goto-body-1))
-
-(defun message-goto-body-1 ()
- "Go to the body and return point."
+ (push-mark))
(goto-char (point-min))
(or (search-forward (concat "\n" mail-header-separator "\n") nil t)
;; If the message is mangled, find the end of the headers the
@@ -3122,12 +3142,12 @@ M-RET `message-newline-and-reformat' (break the line and reformat)."
"Return t if point is in the message body."
(>= (point)
(save-excursion
- (message-goto-body-1))))
+ (message-goto-body))))
-(defun message-goto-eoh ()
+(defun message-goto-eoh (&optional interactive)
"Move point to the end of the headers."
- (interactive)
- (message-goto-body)
+ (interactive "p")
+ (message-goto-body interactive)
(forward-line -1))
(defun message-goto-signature ()
@@ -3218,13 +3238,13 @@ or in the synonym headers, defined by `message-header-synonyms'."
(dolist (header headers)
(let* ((header-name (symbol-name (car header)))
(new-header (cdr header))
- (synonyms (loop for synonym in message-header-synonyms
- when (memq (car header) synonym) return synonym))
+ (synonyms (cl-loop for synonym in message-header-synonyms
+ when (memq (car header) synonym) return synonym))
(old-header
- (loop for synonym in synonyms
- for old-header = (mail-fetch-field (symbol-name synonym))
- when (and old-header (string-match new-header old-header))
- return synonym)))
+ (cl-loop for synonym in synonyms
+ for old-header = (mail-fetch-field (symbol-name synonym))
+ when (and old-header (string-match new-header old-header))
+ return synonym)))
(if old-header
(message "already have `%s' in `%s'" new-header old-header)
(when (and (message-position-on-field header-name)
@@ -3544,7 +3564,7 @@ Note that this should not be used in newsgroups."
(message-remove-header "Disposition-Notification-To"))
(message-goto-eoh)
(insert (format "Disposition-Notification-To: %s\n"
- (or (message-field-value "Reply-to")
+ (or (message-field-value "Reply-To")
(message-field-value "From")
(message-make-from))))))
@@ -3585,7 +3605,7 @@ text was killed."
"Create a rot table with offset N."
(let ((i -1)
(table (make-string 256 0)))
- (while (< (incf i) 256)
+ (while (< (cl-incf i) 256)
(aset table i i))
(concat
(substring table 0 ?A)
@@ -3753,13 +3773,13 @@ To use this automatically, you may add this function to
(goto-char (mark t))
(insert-before-markers ?\n)
(goto-char pt))))
- (case message-cite-reply-position
- (above
+ (pcase message-cite-reply-position
+ ('above
(message-goto-body)
(insert body-text)
(insert (if (bolp) "\n" "\n\n"))
(message-goto-body))
- (below
+ ('below
(message-goto-signature)))
;; Add a `message-setup-very-last-hook' here?
;; Add `gnus-article-highlight-citation' here?
@@ -4277,7 +4297,7 @@ conformance."
(point-max))))
(setq char (char-after)))
(when (or (< char 128)
- (and (mm-multibyte-p)
+ (and enable-multibyte-characters
(memq (char-charset char)
'(eight-bit-control eight-bit-graphic
;; Emacs 23, Bug#1770:
@@ -4309,7 +4329,7 @@ conformance."
(while (not (eobp))
(when (let ((char (char-after)))
(or (< char 128)
- (and (mm-multibyte-p)
+ (and enable-multibyte-characters
;; FIXME: Wrong for Emacs 23 (unicode) and for
;; things like undecodable utf-8 (in Emacs 21?).
;; Should at least use find-coding-systems-region.
@@ -4382,7 +4402,7 @@ This function could be useful in `message-setup-hook'."
(if (string= encoded bog)
""
(format " (%s)" encoded))))))
- (error "Bogus address"))))))))
+ (user-error "Bogus address"))))))))
(custom-add-option 'message-setup-hook 'message-check-recipients)
@@ -4604,9 +4624,9 @@ This function could be useful in `message-setup-hook'."
(with-current-buffer mailbuf
message-courtesy-message)))
;; Let's make sure we encoded all the body.
- (assert (save-excursion
- (goto-char (point-min))
- (not (re-search-forward "[^\000-\377]" nil t))))
+ (cl-assert (save-excursion
+ (goto-char (point-min))
+ (not (re-search-forward "[^\000-\377]" nil t))))
(mm-disable-multibyte)
(if (or (not message-send-mail-partially-limit)
(< (buffer-size) message-send-mail-partially-limit)
@@ -4671,9 +4691,11 @@ that instead."
(message-send-mail-with-sendmail))
((equal (car method) "smtp")
(require 'smtpmail)
- (let ((smtpmail-smtp-server (nth 1 method))
- (smtpmail-smtp-service (nth 2 method))
- (smtpmail-smtp-user (or (nth 3 method) smtpmail-smtp-user)))
+ (let* ((smtpmail-smtp-server (nth 1 method))
+ (service (nth 2 method))
+ (port (string-to-number service))
+ (smtpmail-smtp-service (if (> port 0) port service))
+ (smtpmail-smtp-user (or (nth 3 method) smtpmail-smtp-user)))
(message-smtpmail-send-it)))
(t
(error "Unknown method %s" method))))))
@@ -4760,7 +4782,7 @@ to find out how to use this."
(replace-match "\n")
(run-hooks 'message-send-mail-hook)
;; send the message
- (case
+ (pcase
(let ((coding-system-for-write message-send-coding-system))
(apply
'call-process-region (point-min) (point-max)
@@ -4791,7 +4813,7 @@ to find out how to use this."
(100 (error "qmail-inject reported permanent failure"))
(111 (error "qmail-inject reported transient failure"))
;; should never happen
- (t (error "qmail-inject reported unknown failure"))))
+ (_ (error "qmail-inject reported unknown failure"))))
(defvar mh-previous-window-config)
@@ -5314,7 +5336,9 @@ Otherwise, generate and save a value for `canlock-password' first."
;; Check for control characters.
(message-check 'control-chars
(if (re-search-forward
- (string-to-multibyte "[\000-\007\013\015-\032\034-\037\200-\237]")
+ (eval-when-compile
+ (decode-coding-string "[\000-\007\013\015-\032\034-\037\200-\237]"
+ 'binary))
nil t)
(y-or-n-p
"The article contains control characters. Really post? ")
@@ -5375,6 +5399,17 @@ Otherwise, generate and save a value for `canlock-password' first."
(message "Denied posting -- only quoted text.")
nil)))))))
+(defun message--rotate-fixnum-left (n)
+ "Rotate the fixnum N left by one bit in a fixnum word.
+The result is a fixnum."
+ (logior (if (natnump n) 0 1)
+ (ash (cond ((< (ash most-positive-fixnum -1) n)
+ (logior n most-negative-fixnum))
+ ((< n (ash most-negative-fixnum -1))
+ (logand n most-positive-fixnum))
+ (n))
+ 1)))
+
(defun message-checksum ()
"Return a \"checksum\" for the current buffer."
(let ((sum 0))
@@ -5384,7 +5419,7 @@ Otherwise, generate and save a value for `canlock-password' first."
(concat "^" (regexp-quote mail-header-separator) "$"))
(while (not (eobp))
(when (not (looking-at "[ \t\n]"))
- (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1)
+ (setq sum (logxor (message--rotate-fixnum-left sum)
(char-after))))
(forward-char 1)))
sum))
@@ -5416,7 +5451,7 @@ Otherwise, generate and save a value for `canlock-password' first."
(concat "^" (regexp-quote mail-header-separator) "$")
nil t)
(replace-match "" t t ))
- ;; Process FCC operations.
+ ;; Process Fcc operations.
(while list
(setq file (pop list))
(if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file)
@@ -5506,7 +5541,7 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'."
(let* ((cur (decode-time))
(nday (+ days (nth 3 cur))))
(setf (nth 3 cur) nday)
- (message-make-date (apply 'encode-time cur))))
+ (message-make-date (encode-time cur))))
(defun message-make-message-id ()
"Make a unique Message-ID."
@@ -5539,7 +5574,7 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'."
;; Instead we use this randomly inited counter.
(setq message-unique-id-char
(% (1+ (or message-unique-id-char
- (logand (random most-positive-fixnum) (1- (lsh 1 20)))))
+ (random (ash 1 20))))
;; (current-time) returns 16-bit ints,
;; and 2^16*25 just fits into 4 digits i base 36.
(* 25 25)))
@@ -5554,9 +5589,9 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'."
user)
(message-number-base36 (user-uid) -1))
(message-number-base36 (+ (car tm)
- (lsh (% message-unique-id-char 25) 16)) 4)
+ (ash (% message-unique-id-char 25) 16)) 4)
(message-number-base36 (+ (nth 1 tm)
- (lsh (/ message-unique-id-char 25) 16)) 4)
+ (ash (/ message-unique-id-char 25) 16)) 4)
;; Append a given name, because while the generated ID is unique
;; to this newsreader, other newsreaders might otherwise generate
;; the same ID via another algorithm.
@@ -5840,10 +5875,10 @@ subscribed address (and not the additional To and Cc header contents)."
message-subscribed-address-functions))))
(save-match-data
(let ((list
- (loop for recipient in recipients
- when (loop for regexp in mft-regexps
- thereis (string-match regexp recipient))
- return recipient)))
+ (cl-loop for recipient in recipients
+ when (cl-loop for regexp in mft-regexps
+ thereis (string-match regexp recipient))
+ return recipient)))
(when list
(if only-show-subscribed
list
@@ -6192,7 +6227,7 @@ they are."
(when (> count maxcount)
(let ((surplus (- count maxcount)))
(message-shorten-1 refs cut surplus)
- (decf count surplus)))
+ (cl-decf count surplus)))
;; When sending via news, make sure the total folded length will
;; be less than 998 characters. This is to cater to broken INN
@@ -6717,9 +6752,9 @@ The function is called with one parameter, a cons cell ..."
;; Gmane renames "To". Look at "Original-To", too, if it is present in
;; message-header-synonyms.
(setq to (or (message-fetch-field "to")
- (and (loop for synonym in message-header-synonyms
- when (memq 'Original-To synonym)
- return t)
+ (and (cl-loop for synonym in message-header-synonyms
+ when (memq 'Original-To synonym)
+ return t)
(message-fetch-field "original-to")))
cc (message-fetch-field "cc")
extra (when message-extra-wide-headers
@@ -6857,6 +6892,9 @@ want to get rid of this query permanently.")))
(setq recipients (delq recip recipients))))))))
(setq recipients (message-prune-recipients recipients))
+ (setq recipients
+ (cl-loop for (id . address) in recipients
+ collect (cons id (message--alter-repeat-address address))))
;; Build the header alist. Allow the user to be asked whether
;; or not to reply to all recipients in a wide reply.
@@ -6887,6 +6925,15 @@ want to get rid of this query permanently.")))
(setq recipients (delq recipient recipients))))))))
recipients)
+(defun message--alter-repeat-address (address)
+ "Transform an address on the form \"\"foo@bar.com\"\" <foo@bar.com>\".
+The first bit will be elided if a match is made."
+ (let ((bits (gnus-extract-address-components address)))
+ (if (equal (car bits) (cadr bits))
+ (car bits)
+ ;; Return the original address if we don't have repetition.
+ address)))
+
(defcustom message-simplify-subject-functions
'(message-strip-list-identifiers
message-strip-subject-re
@@ -7401,7 +7448,8 @@ Optional DIGEST will use digest to forward."
(when message-forward-included-headers
(message-remove-header
(if (listp message-forward-included-headers)
- (regexp-opt message-forward-included-headers)
+ (mapconcat #'identity (cons "^$" message-forward-included-headers)
+ "\\|")
message-forward-included-headers)
t nil t)))))
@@ -7420,7 +7468,7 @@ Optional DIGEST will use digest to forward."
;; Consider there is no illegible text.
(add-text-properties
b (point)
- `(no-illegible-text t rear-nonsticky t start-open t))))
+ '(no-illegible-text t rear-nonsticky t start-open t))))
(defun message-forward-make-body-mml (forward-buffer)
(insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")
@@ -7875,6 +7923,8 @@ See `gmm-tool-bar-from-list' for the format of the list."
:group 'message)
(defvar image-load-path)
+(declare-function image-load-path-for-library "image"
+ (library image &optional path no-error))
(defun message-make-tool-bar (&optional force)
"Make a message mode tool bar from `message-tool-bar-list'.
@@ -7901,6 +7951,7 @@ When FORCE, rebuild the tool bar."
:type 'regexp)
(defcustom message-completion-alist
+ ;; FIXME: Make it possible to use the standard completion UI.
(list (cons message-newgroups-header-regexp 'message-expand-group)
'("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name)
'("^\\(Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):"
@@ -7973,18 +8024,11 @@ regular text mode tabbing command."
(skip-chars-backward "^, \t\n") (point))))
(completion-ignore-case t)
(e (progn (skip-chars-forward "^,\t\n ") (point)))
- group collection)
- (when (and (boundp 'gnus-active-hashtb)
- gnus-active-hashtb)
- (mapatoms
- (lambda (symbol)
- (setq group (symbol-name symbol))
- (push (if (string-match "[^\000-\177]" group)
- (gnus-group-decoded-name group)
- group)
- collection))
- gnus-active-hashtb))
- (completion-in-region b e collection)))
+ (collection (when (and (boundp 'gnus-active-hashtb)
+ gnus-active-hashtb)
+ (hash-table-keys gnus-active-hashtb))))
+ (when collection
+ (completion-in-region b e collection))))
(defun message-expand-name ()
(cond ((and (memq 'eudc message-expand-name-databases)
@@ -8009,7 +8053,7 @@ regular text mode tabbing command."
If SHOW is non-nil, the arguments TEXT... are displayed in a temp buffer.
The following arguments may contain lists of values."
(if (and show
- (setq text (message-flatten-list text)))
+ (setq text (flatten-tree text)))
(save-window-excursion
(with-output-to-temp-buffer " *MESSAGE information message*"
(with-current-buffer " *MESSAGE information message*"
@@ -8019,15 +8063,7 @@ The following arguments may contain lists of values."
(funcall ask question))
(funcall ask question)))
-(defun message-flatten-list (list)
- "Return a new, flat list that contains all elements of LIST.
-
-\(message-flatten-list \\='(1 (2 3 (4 5 (6))) 7))
-=> (1 2 3 4 5 6 7)"
- (cond ((consp list)
- (apply 'append (mapcar 'message-flatten-list list)))
- (list
- (list list))))
+(define-obsolete-function-alias 'message-flatten-list #'flatten-tree "27.1")
(defun message-generate-new-buffer-clone-locals (name &optional varstr)
"Create and return a buffer with name based on NAME using `generate-new-buffer'.
@@ -8124,11 +8160,12 @@ From headers in the original article."
(message-tokenize-header
(mail-strip-quoted-names
(mapconcat 'message-fetch-reply-field fields ","))))
- (email (cond ((functionp message-alternative-emails)
- (car (cl-remove-if-not message-alternative-emails emails)))
- (t (loop for email in emails
- if (string-match-p message-alternative-emails email)
- return email)))))
+ (email
+ (cond ((functionp message-alternative-emails)
+ (car (cl-remove-if-not message-alternative-emails emails)))
+ (t (cl-loop for email in emails
+ if (string-match-p message-alternative-emails email)
+ return email)))))
(unless (or (not email) (equal email user-mail-address))
(message-remove-header "From")
(goto-char (point-max))
@@ -8224,16 +8261,19 @@ From headers in the original article."
(autoload 'ecomplete-display-matches "ecomplete")
+(defun message--in-tocc-p ()
+ (and (memq (char-after (point-at-bol)) '(?C ?T ?\t ? ))
+ (message-point-in-header-p)
+ (save-excursion
+ (beginning-of-line)
+ (while (and (memq (char-after) '(?\t ? ))
+ (zerop (forward-line -1))))
+ (looking-at "To:\\|Cc:"))))
+
(defun message-display-abbrev (&optional choose)
"Display the next possible abbrev for the text before point."
(interactive (list t))
- (when (and (memq (char-after (point-at-bol)) '(?C ?T ?\t ? ))
- (message-point-in-header-p)
- (save-excursion
- (beginning-of-line)
- (while (and (memq (char-after) '(?\t ? ))
- (zerop (forward-line -1))))
- (looking-at "To:\\|Cc:")))
+ (when (message--in-tocc-p)
(let* ((end (point))
(start (save-excursion
(and (re-search-backward "[\n\t ]" nil t)
@@ -8246,6 +8286,20 @@ From headers in the original article."
(delete-region start end)
(insert match)))))
+(defun message-ecomplete-capf ()
+ "Return completion data for email addresses in Ecomplete.
+Meant for use on `completion-at-point-functions'."
+ (when (and (bound-and-true-p ecomplete-database)
+ (fboundp 'ecomplete-completion-table)
+ (message--in-tocc-p))
+ (let ((end (save-excursion
+ (skip-chars-forward "^, \t\n")
+ (point)))
+ (start (save-excursion
+ (skip-chars-backward "^, \t\n")
+ (point))))
+ `(,start ,end ,(ecomplete-completion-table 'mail)))))
+
;; To send pre-formatted letters like the example below, you can use
;; `message-send-form-letter':
;; --8<---------------cut here---------------start------------->8---
@@ -8353,6 +8407,9 @@ even if NEW-VALUE is empty."
(message-position-on-field header))
(insert new-value))))
+(make-obsolete-variable
+ 'message-recipients-without-full-name
+ "Recipients are simplified by default" "27.1")
(defcustom message-recipients-without-full-name
(list "ding@gnus.org"
"bugs@gnus.org"
@@ -8368,6 +8425,7 @@ Used in `message-simplify-recipients'."
:version "23.1" ;; No Gnus
:group 'message-headers)
+(make-obsolete 'message-simplify-recipients nil "27.1")
(defun message-simplify-recipients ()
(interactive)
(dolist (hdr '("Cc" "To"))
diff --git a/lisp/gnus/mm-bodies.el b/lisp/gnus/mm-bodies.el
index 298127a3f44..e1e1a12cc59 100644
--- a/lisp/gnus/mm-bodies.el
+++ b/lisp/gnus/mm-bodies.el
@@ -262,7 +262,7 @@ decoding. If it is nil, default to `mail-parse-charset'."
(setq coding-system
(mm-charset-to-coding-system mail-parse-charset)))
(when (and charset coding-system
- (mm-multibyte-p)
+ enable-multibyte-characters
(or (not (eq coding-system 'ascii))
(setq coding-system mail-parse-charset)))
(decode-coding-region (point-min) (point-max) coding-system))
@@ -289,7 +289,7 @@ decoding. If it is nil, default to `mail-parse-charset'."
(setq coding-system
(mm-charset-to-coding-system mail-parse-charset)))
(when (and charset coding-system
- (mm-multibyte-p)
+ enable-multibyte-characters
(or (not (eq coding-system 'ascii))
(setq coding-system mail-parse-charset)))
(decode-coding-string string coding-system)))
diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el
index 21552abae73..3f255419e7e 100644
--- a/lisp/gnus/mm-decode.el
+++ b/lisp/gnus/mm-decode.el
@@ -1,4 +1,4 @@
-;;; mm-decode.el --- Functions for decoding MIME things
+;;; mm-decode.el --- Functions for decoding MIME things -*- lexical-binding:t -*-
;; Copyright (C) 1998-2019 Free Software Foundation, Inc.
@@ -25,7 +25,7 @@
(require 'mail-parse)
(require 'mm-bodies)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(autoload 'gnus-map-function "gnus-util")
@@ -118,8 +118,7 @@
((executable-find "w3m") 'gnus-w3m)
((executable-find "links") 'links)
((executable-find "lynx") 'lynx)
- ((locate-library "html2text") 'html2text)
- (t nil))
+ ((locate-library "html2text") 'html2text))
"Render of HTML contents.
It is one of defined renderer types, or a rendering function.
The defined renderer types are:
@@ -129,9 +128,8 @@ The defined renderer types are:
`w3m-standalone': use plain w3m;
`links': use links;
`lynx': use lynx;
-`html2text': use html2text;
-nil : use external viewer (default web browser)."
- :version "24.1"
+`html2text': use html2text."
+ :version "27.1"
:type '(choice (const shr)
(const gnus-w3m)
(const w3m :tag "emacs-w3m")
@@ -139,7 +137,6 @@ nil : use external viewer (default web browser)."
(const links)
(const lynx)
(const html2text)
- (const nil :tag "External viewer")
(function))
:group 'mime-display)
@@ -193,45 +190,45 @@ before the external MIME handler is invoked."
:group 'mime-display)
(defcustom mm-inline-media-tests
- '(("image/p?jpeg"
+ `(("image/p?jpeg"
mm-inline-image
- (lambda (handle)
+ ,(lambda (handle)
(mm-valid-and-fit-image-p 'jpeg handle)))
("image/png"
mm-inline-image
- (lambda (handle)
+ ,(lambda (handle)
(mm-valid-and-fit-image-p 'png handle)))
("image/gif"
mm-inline-image
- (lambda (handle)
+ ,(lambda (handle)
(mm-valid-and-fit-image-p 'gif handle)))
("image/tiff"
mm-inline-image
- (lambda (handle)
+ ,(lambda (handle)
(mm-valid-and-fit-image-p 'tiff handle)))
("image/xbm"
mm-inline-image
- (lambda (handle)
+ ,(lambda (handle)
(mm-valid-and-fit-image-p 'xbm handle)))
("image/x-xbitmap"
mm-inline-image
- (lambda (handle)
+ ,(lambda (handle)
(mm-valid-and-fit-image-p 'xbm handle)))
("image/xpm"
mm-inline-image
- (lambda (handle)
+ ,(lambda (handle)
(mm-valid-and-fit-image-p 'xpm handle)))
("image/x-xpixmap"
mm-inline-image
- (lambda (handle)
+ ,(lambda (handle)
(mm-valid-and-fit-image-p 'xpm handle)))
("image/bmp"
mm-inline-image
- (lambda (handle)
+ ,(lambda (handle)
(mm-valid-and-fit-image-p 'bmp handle)))
("image/x-portable-bitmap"
mm-inline-image
- (lambda (handle)
+ ,(lambda (handle)
(mm-valid-and-fit-image-p 'pbm handle)))
("text/plain" mm-inline-text identity)
("text/enriched" mm-inline-text identity)
@@ -249,13 +246,14 @@ before the external MIME handler is invoked."
("text/x-org" mm-display-org-inline identity)
("text/html"
mm-inline-text-html
- (lambda (handle)
+ ,(lambda (_handle)
mm-text-html-renderer))
("text/x-vcard"
mm-inline-text-vcard
- (lambda (handle)
+ ,(lambda (_handle)
(or (featurep 'vcard)
(locate-library "vcard"))))
+ ("text/calendar" gnus-icalendar-mm-inline identity)
("message/delivery-status" mm-inline-text identity)
("message/rfc822" mm-inline-message identity)
("message/partial" mm-inline-partial identity)
@@ -264,13 +262,13 @@ before the external MIME handler is invoked."
("application/x-.?tar\\(-.*\\)?" mm-archive-dissect-and-inline identity)
("application/zip" mm-archive-dissect-and-inline identity)
("audio/wav" mm-inline-audio
- (lambda (handle)
- (and (or (featurep 'nas-sound) (featurep 'native-sound))
+ ,(lambda (_handle)
+ (and (fboundp 'device-sound-enabled-p)
(device-sound-enabled-p))))
("audio/au"
mm-inline-audio
- (lambda (handle)
- (and (or (featurep 'nas-sound) (featurep 'native-sound))
+ ,(lambda (_handle)
+ (and (fboundp 'device-sound-enabled-p)
(device-sound-enabled-p))))
("application/pgp-signature" ignore identity)
("application/x-pkcs7-signature" ignore identity)
@@ -282,7 +280,7 @@ before the external MIME handler is invoked."
("multipart/related" ignore identity)
("image/.*"
mm-inline-image
- (lambda (handle)
+ ,(lambda (handle)
(and (mm-valid-image-format-p 'imagemagick)
(mm-with-unibyte-buffer
(mm-insert-part handle)
@@ -323,15 +321,18 @@ type inline."
(defcustom mm-keep-viewer-alive-types
'("application/postscript" "application/msword" "application/vnd.ms-excel"
- "application/pdf" "application/x-dvi")
- "List of media types for which the external viewer will not be killed
-when selecting a different article."
- :version "22.1"
+ "application/pdf" "application/x-dvi"
+ "application/vnd.*")
+ "Media types for viewers not to be killed when selecting a different article.
+Instead the viewers will be killed on Gnus exit instead. This is
+a list of regexps."
+ :version "27.1"
:type '(repeat regexp)
:group 'mime-display)
(defcustom mm-automatic-display
'("text/plain" "text/enriched" "text/richtext" "text/html" "text/x-verbatim"
+ "text/calendar"
"text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*"
"message/rfc822" "text/x-patch" "text/dns" "application/pgp-signature"
"application/emacs-lisp" "application/x-emacs-lisp"
@@ -761,7 +762,7 @@ MIME-Version header before proceeding."
(defun mm-copy-to-buffer ()
"Copy the contents of the current buffer to a fresh buffer."
(let ((obuf (current-buffer))
- (mb (mm-multibyte-p))
+ (mb enable-multibyte-characters)
beg)
(goto-char (point-min))
(search-forward-regexp "^\n" nil 'move) ;; There might be no body.
@@ -773,15 +774,16 @@ MIME-Version header before proceeding."
(insert-buffer-substring obuf beg)
(current-buffer))))
-(defun mm-display-parts (handle &optional no-default)
- (if (stringp (car handle))
- (mapcar 'mm-display-parts (cdr handle))
- (if (bufferp (car handle))
- (save-restriction
- (narrow-to-region (point) (point))
- (mm-display-part handle)
- (goto-char (point-max)))
- (mapcar 'mm-display-parts handle))))
+(defun mm-display-parts (handle)
+ (cond
+ ((stringp (car handle)) (mapcar #'mm-display-parts (cdr handle)))
+ ((bufferp (car handle))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (mm-display-part handle)
+ (goto-char (point-max))))
+ (t
+ (mapcar #'mm-display-parts handle))))
(autoload 'mailcap-parse-mailcaps "mailcap")
(autoload 'mailcap-mime-info "mailcap")
@@ -890,6 +892,7 @@ external if displayed external."
(when method
(message "Viewing with %s" method))
(let ((mm (current-buffer))
+ (attachment-filename (mm-handle-filename handle))
(non-viewer (assq 'non-viewer
(mailcap-mime-info
(mm-handle-media-type handle) t))))
@@ -899,6 +902,9 @@ external if displayed external."
(when (and (boundp 'gnus-summary-buffer)
(bufferp gnus-summary-buffer)
(buffer-name gnus-summary-buffer))
+ (when attachment-filename
+ (with-current-buffer mm
+ (rename-buffer (format "*mm* %s" attachment-filename) t)))
;; So that we pop back to the right place, sort of.
(switch-to-buffer gnus-summary-buffer)
(switch-to-buffer mm))
@@ -961,15 +967,15 @@ external if displayed external."
mm-external-terminal-program
"-e" shell-file-name
shell-command-switch command)
- `(lambda (process state)
- (if (eq 'exit (process-status process))
- (run-at-time
- 60.0 nil
- (lambda ()
- (ignore-errors (delete-file ,file))
- (ignore-errors (delete-directory
- ,(file-name-directory
- file))))))))
+ (lambda (process _state)
+ (if (eq 'exit (process-status process))
+ (run-at-time
+ 60.0 nil
+ (lambda ()
+ (ignore-errors (delete-file file))
+ (ignore-errors (delete-directory
+ (file-name-directory
+ file))))))))
(require 'term)
(require 'gnus-win)
(set-buffer
@@ -982,13 +988,13 @@ external if displayed external."
(term-char-mode)
(set-process-sentinel
(get-buffer-process buffer)
- `(lambda (process state)
- (when (eq 'exit (process-status process))
- (ignore-errors (delete-file ,file))
- (ignore-errors
- (delete-directory ,(file-name-directory file)))
- (gnus-configure-windows
- ',gnus-current-window-configuration))))
+ (let ((wc gnus-current-window-configuration))
+ (lambda (process _state)
+ (when (eq 'exit (process-status process))
+ (ignore-errors (delete-file file))
+ (ignore-errors
+ (delete-directory (file-name-directory file)))
+ (gnus-configure-windows wc)))))
(gnus-configure-windows 'display-term))
(mm-handle-set-external-undisplayer handle (cons file buffer))
(add-to-list 'mm-temp-files-to-be-deleted file t))
@@ -1032,34 +1038,29 @@ external if displayed external."
shell-command-switch command)
(set-process-sentinel
(get-buffer-process buffer)
- (lexical-let ((outbuf outbuf)
- (file file)
- (buffer buffer)
- (command command)
- (handle handle))
- (lambda (process state)
- (when (eq (process-status process) 'exit)
- (run-at-time
- 60.0 nil
- (lambda ()
- (ignore-errors (delete-file file))
- (ignore-errors (delete-directory
- (file-name-directory file)))))
- (when (buffer-live-p outbuf)
- (with-current-buffer outbuf
- (let ((buffer-read-only nil)
- (point (point)))
- (forward-line 2)
- (let ((start (point)))
- (mm-insert-inline
- handle (with-current-buffer buffer
- (buffer-string)))
- (put-text-property start (point)
- 'face 'mm-command-output))
- (goto-char point))))
- (when (buffer-live-p buffer)
- (kill-buffer buffer)))
- (message "Displaying %s...done" command)))))
+ (lambda (process _state)
+ (when (eq (process-status process) 'exit)
+ (run-at-time
+ 60.0 nil
+ (lambda ()
+ (ignore-errors (delete-file file))
+ (ignore-errors (delete-directory
+ (file-name-directory file)))))
+ (when (buffer-live-p outbuf)
+ (with-current-buffer outbuf
+ (let ((buffer-read-only nil)
+ (point (point)))
+ (forward-line 2)
+ (let ((start (point)))
+ (mm-insert-inline
+ handle (with-current-buffer buffer
+ (buffer-string)))
+ (put-text-property start (point)
+ 'face 'mm-command-output))
+ (goto-char point))))
+ (when (buffer-live-p buffer)
+ (kill-buffer buffer)))
+ (message "Displaying %s...done" command))))
(mm-handle-set-external-undisplayer
handle (cons file buffer))
(add-to-list 'mm-temp-files-to-be-deleted file t))
@@ -1170,9 +1171,9 @@ external if displayed external."
(goto-char (point-min))))
(defun mm-assoc-string-match (alist type)
- (dolist (elem alist)
+ (cl-dolist (elem alist)
(when (string-match (car elem) type)
- (return elem))))
+ (cl-return elem))))
(defun mm-automatic-display-p (handle)
"Say whether the user wants HANDLE to be displayed automatically."
@@ -1302,8 +1303,6 @@ are ignored."
'gnus-decoded)
(with-current-buffer (mm-handle-buffer handle)
(buffer-string)))
- ((mm-multibyte-p)
- (string-to-multibyte (mm-get-part handle no-cache)))
(t
(mm-get-part handle no-cache)))))
(save-restriction
@@ -1448,8 +1447,7 @@ text/html\\(?:;\\s-*charset=\\([^\t\n\r \"'>]+\\)\\)?[^>]*>" nil t)
(defun mm-pipe-part (handle &optional cmd)
"Pipe HANDLE to a process.
Use CMD as the process."
- (let ((name (mail-content-type-get (mm-handle-type handle) 'name))
- (command (or cmd
+ (let ((command (or cmd
(read-shell-command
"Shell command on MIME part: " mm-last-shell-command))))
(mm-with-unibyte-buffer
@@ -1784,6 +1782,9 @@ If RECURSIVE, search recursively."
(declare-function shr-insert-document "shr" (dom))
(defvar shr-blocked-images)
(defvar shr-use-fonts)
+(defvar shr-width)
+(defvar shr-content-function)
+(defvar shr-inhibit-images)
(defun mm-shr (handle)
;; Require since we bind its variables.
@@ -1840,13 +1841,14 @@ text/html;\\s-*charset=\\([^\t\n\r \"'>]+\\)[^>]*>" nil t)
(mm-convert-shr-links)
(mm-handle-set-undisplayer
handle
- `(lambda ()
- (let ((inhibit-read-only t))
- (delete-region ,(point-min-marker)
- ,(point-max-marker))))))))
+ (let ((min (point-min-marker))
+ (max (point-max-marker)))
+ (lambda ()
+ (let ((inhibit-read-only t))
+ (delete-region min max))))))))
(defvar shr-image-map)
-
+(defvar shr-map)
(autoload 'widget-convert-button "wid-edit")
(defvar widget-keymap)
@@ -1860,12 +1862,15 @@ text/html;\\s-*charset=\\([^\t\n\r \"'>]+\\)[^>]*>" nil t)
(widget-convert-button
'url-link start end
:help-echo (get-text-property start 'help-echo)
- :keymap (setq keymap (copy-keymap shr-image-map))
+ :keymap (setq keymap (copy-keymap
+ (if (mm-images-in-region-p start end)
+ shr-image-map
+ shr-map)))
(get-text-property start 'shr-url))
;; Mask keys that launch `widget-button-click'.
;; Those bindings are provided by `widget-keymap'
;; that is a parent of `gnus-article-mode-map'.
- (dolist (key (where-is-internal #'widget-button-click widget-keymap))
+ (dolist (key (where-is-internal 'widget-button-click widget-keymap))
(unless (lookup-key keymap key)
(define-key keymap key #'ignore)))
;; Avoid `shr-next-link' and `shr-previous-link' in `keymap' so
diff --git a/lisp/gnus/mm-encode.el b/lisp/gnus/mm-encode.el
index 9e395b05433..7d1040961fd 100644
--- a/lisp/gnus/mm-encode.el
+++ b/lisp/gnus/mm-encode.el
@@ -23,7 +23,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'mail-parse)
(autoload 'mailcap-extension-to-mime "mailcap")
(autoload 'mm-body-7-or-8 "mm-bodies")
@@ -204,7 +204,7 @@ This is either `base64' or `quoted-printable'."
(goto-char (point-min))
(skip-chars-forward "\x20-\x7f\r\n\t" limit)
(while (< (point) limit)
- (incf n8bit)
+ (cl-incf n8bit)
(forward-char 1)
(skip-chars-forward "\x20-\x7f\r\n\t" limit))
(if (or (< (* 6 n8bit) (- limit (point-min)))
diff --git a/lisp/gnus/mm-extern.el b/lisp/gnus/mm-extern.el
index 32ba831a0da..c3054432d51 100644
--- a/lisp/gnus/mm-extern.el
+++ b/lisp/gnus/mm-extern.el
@@ -1,4 +1,4 @@
-;;; mm-extern.el --- showing message/external-body
+;;; mm-extern.el --- showing message/external-body -*- lexical-binding:t -*-
;; Copyright (C) 2000-2019 Free Software Foundation, Inc.
@@ -24,8 +24,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
-
(require 'mm-util)
(require 'mm-decode)
(require 'mm-url)
@@ -33,13 +31,13 @@
(defvar gnus-article-mime-handles)
(defvar mm-extern-function-alist
- '((local-file . mm-extern-local-file)
- (url . mm-extern-url)
- (anon-ftp . mm-extern-anon-ftp)
- (ftp . mm-extern-ftp)
-;;; (tftp . mm-extern-tftp)
- (mail-server . mm-extern-mail-server)
-;;; (afs . mm-extern-afs))
+ `((local-file . ,#'mm-extern-local-file)
+ (url . ,#'mm-extern-url)
+ (anon-ftp . ,#'mm-extern-anon-ftp)
+ (ftp . ,#'mm-extern-ftp)
+ ;; (tftp . ,#'mm-extern-tftp)
+ (mail-server . ,#'mm-extern-mail-server)
+ ;; (afs . ,#'mm-extern-afs))
))
(defvar mm-extern-anonymous "anonymous")
@@ -72,7 +70,6 @@
(name (cdr (assq 'name params)))
(site (cdr (assq 'site params)))
(directory (cdr (assq 'directory params)))
- (mode (cdr (assq 'mode params)))
(path (concat "/" (or mm-extern-anonymous
(read-string (format "ID for %s: " site)))
"@" site ":" directory "/" name))
@@ -86,7 +83,7 @@
(let (mm-extern-anonymous)
(mm-extern-anon-ftp handle)))
-(declare-function message-goto-body "message" ())
+(declare-function message-goto-body "message" (&optional interactive))
(defun mm-extern-mail-server (handle)
(require 'message)
diff --git a/lisp/gnus/mm-partial.el b/lisp/gnus/mm-partial.el
index c2bd58ac5ec..c68ab4a7c13 100644
--- a/lisp/gnus/mm-partial.el
+++ b/lisp/gnus/mm-partial.el
@@ -24,8 +24,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
-
(require 'gnus-sum)
(require 'mm-util)
(require 'mm-decode)
diff --git a/lisp/gnus/mm-url.el b/lisp/gnus/mm-url.el
index 62462d0b360..b53a1bcd303 100644
--- a/lisp/gnus/mm-url.el
+++ b/lisp/gnus/mm-url.el
@@ -28,7 +28,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'mm-util)
(require 'gnus)
@@ -318,7 +318,7 @@ If FOLLOW-REFRESH is non-nil, redirect refresh url in META."
(done nil)
(first t)
result)
- (while (and (not (zerop (decf times)))
+ (while (and (not (zerop (cl-decf times)))
(not done))
(with-timeout (mm-url-timeout)
(unless first
diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el
index bbaab536f1a..00a8a532d27 100644
--- a/lisp/gnus/mm-util.el
+++ b/lisp/gnus/mm-util.el
@@ -1,4 +1,4 @@
-;;; mm-util.el --- Utility functions for Mule and low level things
+;;; mm-util.el --- Utility functions for Mule and low level things -*- lexical-binding:t -*-
;; Copyright (C) 1998-2019 Free Software Foundation, Inc.
@@ -23,7 +23,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'mail-prsvr)
(require 'timer)
@@ -241,7 +241,7 @@ superset of iso-8859-1."
(widget-convert
'list
`(set :inline t :format "%v" ,@(nreverse rest))
- `(repeat :inline t :tag "Other options"
+ '(repeat :inline t :tag "Other options"
(cons :format "%v"
(symbol :size 3 :format "(%v")
(symbol :size 3 :format " . %v)\n")))))))
@@ -431,7 +431,7 @@ mail with multiple parts is preferred to sending a Unicode one.")
(#x94 . #x201D) (#x95 . #x2022) (#x96 . #x2013) (#x97 . #x2014)
(#x98 . #x02DC) (#x99 . #x2122) (#x9A . #x0161) (#x9B . #x203A)
(#x9C . #x0153) (#x9E . #x017E) (#x9F . #x0178)))
- "*Alist of extra numeric entities and characters other than ISO 10646.
+ "Alist of extra numeric entities and characters other than ISO 10646.
This table is used for decoding extra numeric entities to characters,
like \"&#128;\" to the euro sign, mainly in html messages."
:type '(alist :key-type character :value-type character)
@@ -521,7 +521,7 @@ If POS is out of range, the value is nil."
enable-multibyte-characters)
(defun mm-iso-8859-x-to-15-region (&optional b e)
- (let (charset item c inconvertible)
+ (let (item c inconvertible)
(save-restriction
(if e (narrow-to-region b e))
(goto-char (point-min))
@@ -559,7 +559,7 @@ nil means ASCII, a single-element list represents an appropriate MIME
charset, and a longer list means no appropriate charset."
(let (charsets)
;; The return possibilities of this function are a mess...
- (or (and (mm-multibyte-p)
+ (or (and enable-multibyte-characters
mm-use-find-coding-systems-region
;; Find the mime-charset of the most preferred coding
;; system that has one.
@@ -597,7 +597,7 @@ charset, and a longer list means no appropriate charset."
;; We're not multibyte, or a single coding system won't cover it.
(setq charsets
(delete-dups
- (mapcar 'mm-mime-charset
+ (mapcar #'mm-mime-charset
(delq 'ascii
(mm-find-charset-region b e))))))
(if (and (> (length charsets) 1)
@@ -612,45 +612,23 @@ charset, and a longer list means no appropriate charset."
charsets))
(defmacro mm-with-unibyte-buffer (&rest forms)
- "Create a temporary buffer, and evaluate FORMS there like `progn'.
-Use unibyte mode for this."
+ "Create a temporary unibyte buffer, and evaluate FORMS there like `progn'."
+ (declare (indent 0) (debug t))
`(with-temp-buffer
(mm-disable-multibyte)
,@forms))
-(put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
-(put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
(defmacro mm-with-multibyte-buffer (&rest forms)
- "Create a temporary buffer, and evaluate FORMS there like `progn'.
-Use multibyte mode for this."
+ "Create a temporary multibyte buffer, and evaluate FORMS there like `progn'."
+ (declare (indent 0) (debug t))
`(with-temp-buffer
(mm-enable-multibyte)
,@forms))
-(put 'mm-with-multibyte-buffer 'lisp-indent-function 0)
-(put 'mm-with-multibyte-buffer 'edebug-form-spec '(body))
-
-(defmacro mm-with-unibyte-current-buffer (&rest forms)
- "Evaluate FORMS with current buffer temporarily made unibyte.
-
-Note: We recommend not using this macro any more; there should be
-better ways to do a similar thing. The previous version of this macro
-bound the default value of `enable-multibyte-characters' to nil while
-evaluating FORMS but it is no longer done. So, some programs assuming
-it if any may malfunction."
- (declare (obsolete nil "25.1") (indent 0) (debug t))
- (let ((multibyte (make-symbol "multibyte")))
- `(let ((,multibyte enable-multibyte-characters))
- (when ,multibyte
- (set-buffer-multibyte nil))
- (prog1
- (progn ,@forms)
- (when ,multibyte
- (set-buffer-multibyte t))))))
(defun mm-find-charset-region (b e)
"Return a list of Emacs charsets in the region B to E."
(cond
- ((mm-multibyte-p)
+ (enable-multibyte-characters
;; Remove composition since the base charsets have been included.
;; Remove eight-bit-*, treat them as ascii.
(let ((css (find-charset-region b e)))
@@ -699,21 +677,26 @@ to advanced Emacs features, such as file-name-handlers, format decoding,
`find-file-hook', etc.
If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'.
This function ensures that none of these modifications will take place."
- (letf* ((format-alist nil)
- (auto-mode-alist (if inhibit nil (mm-auto-mode-alist)))
- ((default-value 'major-mode) 'fundamental-mode)
- (enable-local-variables nil)
- (after-insert-file-functions nil)
- (enable-local-eval nil)
- (inhibit-file-name-operation (if inhibit
- 'insert-file-contents
- inhibit-file-name-operation))
- (inhibit-file-name-handlers
- (if inhibit
- (append mm-inhibit-file-name-handlers
- inhibit-file-name-handlers)
- inhibit-file-name-handlers))
- (find-file-hook nil))
+ (cl-letf* ((format-alist nil)
+ ;; FIXME: insert-file-contents doesn't look at auto-mode-alist,
+ ;; nor at (default-value 'major-mode)!
+ (auto-mode-alist (if inhibit nil (mm-auto-mode-alist)))
+ ((default-value 'major-mode) 'fundamental-mode)
+ ;; FIXME: neither enable-local-variables nor enable-local-eval are
+ ;; run by insert-file-contents, AFAICT?!
+ (enable-local-variables nil)
+ (after-insert-file-functions nil)
+ (enable-local-eval nil)
+ (inhibit-file-name-operation (if inhibit
+ 'insert-file-contents
+ inhibit-file-name-operation))
+ (inhibit-file-name-handlers
+ (if inhibit
+ (append mm-inhibit-file-name-handlers
+ inhibit-file-name-handlers)
+ inhibit-file-name-handlers))
+ ;; FIXME: insert-file-contents doesn't run find-file-hook anyway!
+ (find-file-hook nil))
(insert-file-contents filename visit beg end replace)))
(defun mm-append-to-file (start end filename &optional codesys inhibit)
@@ -838,7 +821,7 @@ decompressed data. The buffer's multibyteness must be turned off."
prog t (list t err-file) nil args)
jka-compr-acceptable-retval-list)
(erase-buffer)
- (insert (mapconcat 'identity
+ (insert (mapconcat #'identity
(split-string
(prog2
(insert-file-contents err-file)
@@ -849,7 +832,7 @@ decompressed data. The buffer's multibyteness must be turned off."
"\n")
(setq err-msg
(format "Error while executing \"%s %s < %s\""
- prog (mapconcat 'identity args " ")
+ prog (mapconcat #'identity args " ")
filename)))
(setq retval (buffer-string)))
(error
@@ -899,6 +882,19 @@ gzip, bzip2, etc. are allowed."
(when decomp
(kill-buffer (current-buffer)))))))
+(defun mm-images-in-region-p (start end)
+ (let ((found nil))
+ (save-excursion
+ (goto-char start)
+ (while (and (not found)
+ (< (point) end))
+ (let ((display (get-text-property (point) 'display)))
+ (when (and (consp display)
+ (eq (car display) 'image))
+ (setq found t)))
+ (forward-char 1)))
+ found))
+
(provide 'mm-util)
;;; mm-util.el ends here
diff --git a/lisp/gnus/mm-uu.el b/lisp/gnus/mm-uu.el
index c0da31fb568..a00d64015f2 100644
--- a/lisp/gnus/mm-uu.el
+++ b/lisp/gnus/mm-uu.el
@@ -24,7 +24,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
(require 'mail-parse)
(require 'nnheader)
(require 'mm-decode)
diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el
index 03e1e11813f..1e1d264b994 100644
--- a/lisp/gnus/mm-view.el
+++ b/lisp/gnus/mm-view.el
@@ -22,7 +22,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'mail-parse)
(require 'mailcap)
(require 'mm-bodies)
@@ -318,6 +318,8 @@
(if entry
(setq func (cdr entry)))
(cond
+ ((null func)
+ (mm-insert-inline handle (mm-get-part handle)))
((functionp func)
(funcall func handle))
(t
@@ -452,7 +454,7 @@
"Insert HANDLE inline fontifying with MODE.
If MODE is not set, try to find mode automatically."
(let ((charset (mail-content-type-get (mm-handle-type handle) 'charset))
- text coding-system)
+ text coding-system ovs)
(unless (eq charset 'gnus-decoded)
(mm-with-unibyte-buffer
(mm-insert-part handle)
@@ -474,34 +476,46 @@ If MODE is not set, try to find mode automatically."
(mm-decode-string text charset))
(t
text)))
- (require 'font-lock)
- ;; I find font-lock a bit too verbose.
- (let ((font-lock-verbose nil)
- (font-lock-support-mode nil)
+ (let ((font-lock-verbose nil) ; font-lock is a bit too verbose.
(enable-local-variables nil))
- ;; Disable support modes, e.g., jit-lock, lazy-lock, etc.
- ;; Note: XEmacs people use `font-lock-mode-hook' to run those modes.
+ ;; We used to set font-lock-mode-hook to nil to avoid enabling
+ ;; support modes, but now that we use font-lock-ensure, support modes
+ ;; aren't a problem any more. So we could probably get rid of this
+ ;; setting now, but it seems harmless and potentially still useful.
(set (make-local-variable 'font-lock-mode-hook) nil)
(setq buffer-file-name (mm-handle-filename handle))
(with-demoted-errors
- (if mode
- (save-window-excursion
- (switch-to-buffer (current-buffer))
- (funcall mode))
+ (if mode
+ (save-window-excursion
+ ;; According to Katsumi Yamaoka <yamaoka@jpl.org>, org-mode
+ ;; requires the buffer to be temporarily displayed here, but
+ ;; I could not reproduce this problem. Furthermore, if
+ ;; there's such a problem, we should fix org-mode rather than
+ ;; use switch-to-buffer which can have undesirable
+ ;; side-effects!
+ ;;(switch-to-buffer (current-buffer))
+ (funcall mode))
(let ((auto-mode-alist
(delq (rassq 'doc-view-mode-maybe auto-mode-alist)
(copy-sequence auto-mode-alist))))
- (set-auto-mode)))
- ;; The mode function might have already turned on font-lock.
+ (set-auto-mode)
+ (setq mode major-mode)))
;; Do not fontify if the guess mode is fundamental.
- (unless (or font-lock-mode
- (eq major-mode 'fundamental-mode))
+ (unless (eq major-mode 'fundamental-mode)
(font-lock-ensure))))
(setq text (buffer-string))
+ (when (eq mode 'diff-mode)
+ (setq ovs (mapcar (lambda (ov) (list ov (overlay-start ov)
+ (overlay-end ov)))
+ (overlays-in (point-min) (point-max)))))
;; Set buffer unmodified to avoid confirmation when killing the
;; buffer.
(set-buffer-modified-p nil))
- (mm-insert-inline handle text)))
+ (let ((b (- (point) (save-restriction (widen) (point-min)))))
+ (mm-insert-inline handle text)
+ (dolist (ov ovs)
+ (move-overlay (nth 0 ov) (+ (nth 1 ov) b)
+ (+ (nth 2 ov) b) (current-buffer))))))
;; Shouldn't these functions check whether the user even wants to use
;; font-lock? Also, it would be nice to change for the size of the
@@ -563,7 +577,7 @@ If MODE is not set, try to find mode automatically."
(error "Could not identify PKCS#7 type")))))
(defun mm-view-pkcs7 (handle &optional from)
- (case (mm-view-pkcs7-get-type handle)
+ (cl-case (mm-view-pkcs7-get-type handle)
(enveloped (mm-view-pkcs7-decrypt handle from))
(signed (mm-view-pkcs7-verify handle))
(otherwise (error "Unknown or unimplemented PKCS#7 type"))))
diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el
index 4fca4ce67b7..db7489fbf1c 100644
--- a/lisp/gnus/mml-sec.el
+++ b/lisp/gnus/mml-sec.el
@@ -23,7 +23,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(require 'cl-lib)
(require 'gnus-util)
(require 'epg)
@@ -167,9 +167,9 @@ You can also customize or set `mml-signencrypt-style-alist' instead."
(if (or (eq style 'separate)
(eq style 'combined))
;; valid style setting?
- (setf (second style-item) style)
+ (setf (cadr style-item) style)
;; otherwise, just return the current value
- (second style-item))
+ (cadr style-item))
(message "Warning, attempt to set invalid signencrypt style"))))
;;; Security functions
@@ -554,7 +554,7 @@ customized in this variable."
"For CONTEXT, USAGE, and NAME record fingerprint(s) of KEYS.
If optional SAVE is not nil, save customized fingerprints.
Return keys."
- (assert keys)
+ (cl-assert keys)
(let* ((usage-prefs (mml-secure-cust-usage-lookup context usage))
(curr-fprs (cdr (assoc name (cdr usage-prefs))))
(key-fprs (mapcar 'mml-secure-fingerprint keys))
@@ -647,6 +647,7 @@ The passphrase is read and cached."
(when passphrase
(let ((password-cache-expiry (mml-secure-cache-expiry-interval
(epg-context-protocol context))))
+ ;; FIXME test passphrase works before caching it.
(password-cache-add password-cache-key-id passphrase))
(mml-secure-add-secret-key-id password-cache-key-id)
(copy-sequence passphrase)))))
@@ -905,7 +906,7 @@ If no one is selected, symmetric encryption will be performed. "
(defun mml-secure-epg-encrypt (protocol cont &optional sign)
;; Based on code appearing inside mml2015-epg-encrypt.
(let* ((context (epg-make-context protocol))
- (config (epg-configuration))
+ (config (epg-find-configuration 'OpenPGP))
(sender (message-options-get 'message-sender))
(recipients (mml-secure-recipients protocol context config sender))
(signer-names (mml-secure-signer-names protocol sender))
diff --git a/lisp/gnus/mml-smime.el b/lisp/gnus/mml-smime.el
index 1e61ebf8699..78fac8ac301 100644
--- a/lisp/gnus/mml-smime.el
+++ b/lisp/gnus/mml-smime.el
@@ -24,7 +24,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'smime)
(require 'mm-decode)
@@ -238,7 +238,7 @@ Whether the passphrase is cached at all is controlled by
;; todo: try dns/ldap automatically first, before prompting user
(let (certs done)
(while (not done)
- (ecase (read (gnus-completing-read
+ (cl-ecase (read (gnus-completing-read
"Fetch certificate from"
'("dns" "ldap" "file") t nil nil
"ldap"))
diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el
index d5588971e59..f6d358dfc09 100644
--- a/lisp/gnus/mml.el
+++ b/lisp/gnus/mml.el
@@ -27,8 +27,9 @@
(require 'mm-encode)
(require 'mm-decode)
(require 'mml-sec)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(eval-when-compile (require 'url))
+(eval-when-compile (require 'gnus-util))
(autoload 'message-make-message-id "message")
(declare-function gnus-setup-posting-charset "gnus-msg" (group))
@@ -548,6 +549,9 @@ be \"related\" or \"alternate\"."
">")))))))
cont))))
+(autoload 'image-property "image")
+
+;; FIXME presumably (built-in) ImageMagick could replace exiftool?
(defun mml--possibly-alter-image (file-name image)
(if (or (null image)
(not (consp image))
@@ -795,12 +799,12 @@ be \"related\" or \"alternate\"."
(if (setq recipients (cdr (assq 'recipients cont)))
(message-options-set 'message-recipients recipients))
(let ((style (mml-signencrypt-style
- (first (or sign-item encrypt-item)))))
+ (car (or sign-item encrypt-item)))))
;; check if: we're both signing & encrypting, both methods
;; are the same (why would they be different?!), and that
;; the signencrypt style allows for combined operation.
- (if (and sign-item encrypt-item (equal (first sign-item)
- (first encrypt-item))
+ (if (and sign-item encrypt-item (equal (car sign-item)
+ (car encrypt-item))
(equal style 'combined))
(funcall (nth 1 encrypt-item) cont t)
;; otherwise, revert to the old behavior.
@@ -812,7 +816,7 @@ be \"related\" or \"alternate\"."
(defun mml-compute-boundary (cont)
"Return a unique boundary that does not exist in CONT."
(let ((mml-boundary (funcall mml-boundary-function
- (incf mml-multipart-number))))
+ (cl-incf mml-multipart-number))))
(unless mml-inhibit-compute-boundary
;; This function tries again and again until it has found
;; a unique boundary.
@@ -832,7 +836,7 @@ be \"related\" or \"alternate\"."
(when (re-search-forward (concat "^--" (regexp-quote mml-boundary))
nil t)
(setq mml-boundary (funcall mml-boundary-function
- (incf mml-multipart-number)))
+ (cl-incf mml-multipart-number)))
(throw 'not-unique nil))))
((eq (car cont) 'multipart)
(mapc 'mml-compute-boundary-1 (cddr cont))))
@@ -1151,7 +1155,7 @@ If HANDLES is non-nil, use it instead reparsing the buffer."
(easy-menu-define
mml-menu mml-mode-map ""
- `("Attachments"
+ '("Attachments"
["Attach File..." mml-attach-file :help "Attach a file at point"]
["Attach Buffer..." mml-attach-buffer
:help "Attach a buffer to the outgoing message"]
@@ -1544,7 +1548,6 @@ Should be adopted if code in `message-send-mail' is changed."
(defvar mml-preview-buffer nil)
-(autoload 'gnus-make-hashtable "gnus-util")
(autoload 'widget-button-press "wid-edit" nil t)
(declare-function widget-event-point "wid-edit" (event))
;; If gnus-buffer-configuration is bound this is loaded.
diff --git a/lisp/gnus/mml1991.el b/lisp/gnus/mml1991.el
index cb155266994..ce282ec65fb 100644
--- a/lisp/gnus/mml1991.el
+++ b/lisp/gnus/mml1991.el
@@ -25,9 +25,7 @@
;;; Code:
-(eval-when-compile
- (require 'cl)
- (require 'mm-util))
+(eval-when-compile (require 'mm-util))
(require 'mm-encode)
(require 'mml-sec)
@@ -277,6 +275,8 @@ Whether the passphrase is cached at all is controlled by
(mm-decode-content-transfer-encoding cte)))
(let* ((pair (mml-secure-epg-sign 'OpenPGP 'clear))
(signature (car pair)))
+ (unless (stringp signature)
+ (error "Signature failed"))
(delete-region (point-min) (point-max))
(insert
(with-temp-buffer
diff --git a/lisp/gnus/mml2015.el b/lisp/gnus/mml2015.el
index 13db3eac686..d7876a3aef0 100644
--- a/lisp/gnus/mml2015.el
+++ b/lisp/gnus/mml2015.el
@@ -27,7 +27,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'mm-decode)
(require 'mm-util)
(require 'mml)
@@ -237,7 +237,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'."
(setq result
(concat
result
- (case n-slice
+ (cl-case n-slice
(1 slice)
(otherwise (concat " " slice))))))
result))
@@ -958,6 +958,8 @@ If set, it overrides the setting of `mml2015-sign-with-sender'."
(let* ((pair (mml-secure-epg-sign 'OpenPGP t))
(signature (car pair))
(micalg (cdr pair)))
+ (unless (stringp signature)
+ (error "Signature failed"))
(goto-char (point-min))
(insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
boundary))
diff --git a/lisp/gnus/nnagent.el b/lisp/gnus/nnagent.el
index f70a384ff11..64f3a861810 100644
--- a/lisp/gnus/nnagent.el
+++ b/lisp/gnus/nnagent.el
@@ -26,7 +26,6 @@
(require 'nnheader)
(require 'nnoo)
-(eval-when-compile (require 'cl))
(require 'gnus-agent)
(require 'nnml)
diff --git a/lisp/gnus/nnbabyl.el b/lisp/gnus/nnbabyl.el
index fe027b40930..3b316454107 100644
--- a/lisp/gnus/nnbabyl.el
+++ b/lisp/gnus/nnbabyl.el
@@ -35,7 +35,7 @@
5 "Ignore rmail errors from this file, you don't have rmail")))
(require 'nnmail)
(require 'nnoo)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(nnoo-declare nnbabyl)
@@ -103,7 +103,7 @@
(insert ".\n"))
(and (numberp nnmail-large-newsgroup)
(> number nnmail-large-newsgroup)
- (zerop (% (incf count) 20))
+ (zerop (% (cl-incf count) 20))
(nnheader-message 5 "nnbabyl: Receiving headers... %d%%"
(floor (* count 100.0) number))))
@@ -624,7 +624,7 @@
(defun nnbabyl-check-mbox ()
"Go through the nnbabyl mbox and make sure that no article numbers are reused."
(interactive)
- (let ((idents (make-vector 1000 0))
+ (let ((idents (gnus-make-hashtable 1000))
id)
(save-excursion
(when (or (not nnbabyl-mbox-buffer)
@@ -633,13 +633,13 @@
(set-buffer nnbabyl-mbox-buffer)
(goto-char (point-min))
(while (re-search-forward "^X-Gnus-Newsgroup: \\([^ ]+\\) " nil t)
- (if (intern-soft (setq id (match-string 1)) idents)
+ (if (gethash (setq id (match-string 1)) idents)
(progn
(delete-region (point-at-bol) (progn (forward-line 1) (point)))
(nnheader-message 7 "Moving %s..." id)
(nnbabyl-save-mail
(nnmail-article-group 'nnbabyl-active-number)))
- (intern id idents)))
+ (puthash id t idents)))
(when (buffer-modified-p (current-buffer))
(save-buffer))
(nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el
index 5589ab20226..c8b7eed9870 100644
--- a/lisp/gnus/nndiary.el
+++ b/lisp/gnus/nndiary.el
@@ -83,7 +83,6 @@
(require 'nnoo)
(require 'nnheader)
(require 'nnmail)
-(eval-when-compile (require 'cl))
(require 'gnus-start)
(require 'gnus-sum)
@@ -233,7 +232,7 @@ through all nnml directories and generate nov databases for them
all. This may very well take some time.")
(defvoo nndiary-prepare-save-mail-hook nil
- "*Hook run narrowed to an article before saving.")
+ "Hook run narrowed to an article before saving.")
(defvoo nndiary-inhibit-expiry nil
"If non-nil, inhibit expiry.")
@@ -1279,28 +1278,28 @@ all. This may very well take some time.")
(push
(cond ((eq (cdr reminder) 'minute)
(time-subtract
- (apply 'encode-time 0 (nthcdr 1 date-elts))
- (seconds-to-time (* (car reminder) 60.0))))
+ (apply #'encode-time 0 (nthcdr 1 date-elts))
+ (encode-time (* (car reminder) 60.0))))
((eq (cdr reminder) 'hour)
(time-subtract
- (apply 'encode-time 0 0 (nthcdr 2 date-elts))
- (seconds-to-time (* (car reminder) 3600.0))))
+ (apply #'encode-time 0 0 (nthcdr 2 date-elts))
+ (encode-time (* (car reminder) 3600.0))))
((eq (cdr reminder) 'day)
(time-subtract
- (apply 'encode-time 0 0 0 (nthcdr 3 date-elts))
- (seconds-to-time (* (car reminder) 86400.0))))
+ (apply #'encode-time 0 0 0 (nthcdr 3 date-elts))
+ (encode-time (* (car reminder) 86400.0))))
((eq (cdr reminder) 'week)
(time-subtract
- (apply 'encode-time 0 0 0 monday (nthcdr 4 date-elts))
- (seconds-to-time (* (car reminder) 604800.0))))
+ (apply #'encode-time 0 0 0 monday (nthcdr 4 date-elts))
+ (encode-time (* (car reminder) 604800.0))))
((eq (cdr reminder) 'month)
(time-subtract
- (apply 'encode-time 0 0 0 1 (nthcdr 4 date-elts))
- (seconds-to-time (* (car reminder) 18748800.0))))
+ (apply #'encode-time 0 0 0 1 (nthcdr 4 date-elts))
+ (encode-time (* (car reminder) 18748800.0))))
((eq (cdr reminder) 'year)
(time-subtract
- (apply 'encode-time 0 0 0 1 1 (nthcdr 5 date-elts))
- (seconds-to-time (* (car reminder) 400861056.0)))))
+ (apply #'encode-time 0 0 0 1 1 (nthcdr 5 date-elts))
+ (encode-time (* (car reminder) 400861056.0)))))
res))
(sort res 'time-less-p)))
@@ -1532,7 +1531,7 @@ all. This may very well take some time.")
;; past. A permanent schedule never expires.
(and sched
(setq sched (nndiary-last-occurrence sched))
- (time-less-p sched (current-time))))
+ (time-less-p sched nil)))
;; else
(nnheader-report 'nndiary "Could not read file %s" file)
nil)
diff --git a/lisp/gnus/nndir.el b/lisp/gnus/nndir.el
index 44487f422d0..82502dfbd19 100644
--- a/lisp/gnus/nndir.el
+++ b/lisp/gnus/nndir.el
@@ -28,7 +28,6 @@
(require 'nnmh)
(require 'nnml)
(require 'nnoo)
-(eval-when-compile (require 'cl))
(nnoo-declare nndir
nnml nnmh)
@@ -38,7 +37,7 @@
nnml-current-directory nnmh-current-directory)
(defvoo nndir-nov-is-evil nil
- "*Non-nil means that nndir will never retrieve NOV headers."
+ "Non-nil means that nndir will never retrieve NOV headers."
nnml-nov-is-evil)
diff --git a/lisp/gnus/nndoc.el b/lisp/gnus/nndoc.el
index f17dcb96c3e..532ba11fa09 100644
--- a/lisp/gnus/nndoc.el
+++ b/lisp/gnus/nndoc.el
@@ -33,19 +33,19 @@
(require 'nnoo)
(require 'gnus-util)
(require 'mm-util)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(nnoo-declare nndoc)
(defvoo nndoc-article-type 'guess
- "*Type of the file.
+ "Type of the file.
One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
`rfc934', `rfc822-forward', `mime-parts', `standard-digest',
`slack-digest', `clari-briefs', `nsmail', `outlook', `oe-dbx',
`mailman', `exim-bounce', or `guess'.")
(defvoo nndoc-post-type 'mail
- "*Whether the nndoc group is `mail' or `post'.")
+ "Whether the nndoc group is `mail' or `post'.")
(defvoo nndoc-open-document-hook 'nnheader-ms-strip-cr
"Hook run after opening a document.
@@ -701,7 +701,7 @@ from the document.")
(defun nndoc-lanl-gov-announce-type-p ()
(when (let ((case-fold-search nil))
- (re-search-forward "^\\\\\\\\\n\\(Paper\\( (\\*cross-listing\\*)\\)?: [a-zA-Z-\\.]+/[0-9]+\\|arXiv:\\)" nil t))
+ (re-search-forward "^\\\\\\\\\n\\(Paper\\( (\\*cross-listing\\*)\\)?: [a-zA-Z\\.-]+/[0-9]+\\|arXiv:\\)" nil t))
t))
(defun nndoc-transform-lanl-gov-announce (article)
@@ -732,7 +732,7 @@ from the document.")
(save-restriction
(narrow-to-region (car entry) (nth 1 entry))
(goto-char (point-min))
- (when (looking-at "^\\(Paper.*: \\|arXiv:\\)\\([0-9a-zA-Z-\\./]+\\)")
+ (when (looking-at "^\\(Paper.*: \\|arXiv:\\)\\([0-9a-zA-Z\\./-]+\\)")
(setq subject (concat " (" (match-string 2) ")"))
(when (re-search-forward "^From: \\(.*\\)" nil t)
(setq from (concat "<"
@@ -765,13 +765,13 @@ from the document.")
(looking-at "JMF"))
(defun nndoc-oe-dbx-type-p ()
- (looking-at (string-to-multibyte "\317\255\022\376")))
+ (looking-at "\317\255\022\376"))
(defun nndoc-read-little-endian ()
(+ (prog1 (char-after) (forward-char 1))
- (lsh (prog1 (char-after) (forward-char 1)) 8)
- (lsh (prog1 (char-after) (forward-char 1)) 16)
- (lsh (prog1 (char-after) (forward-char 1)) 24)))
+ (ash (prog1 (char-after) (forward-char 1)) 8)
+ (ash (prog1 (char-after) (forward-char 1)) 16)
+ (ash (prog1 (char-after) (forward-char 1)) 24)))
(defun nndoc-oe-dbx-decode-block ()
(list
@@ -788,7 +788,7 @@ from the document.")
(setq blk (nndoc-oe-dbx-decode-block)))
(while (and blk (> (car blk) 0) (or (zerop (nth 3 blk))
(> (nth 3 blk) p)))
- (push (list (incf i) p nil nil nil 0) nndoc-dissection-alist)
+ (push (list (cl-incf i) p nil nil nil 0) nndoc-dissection-alist)
(while (and (> (car blk) 0) (> (nth 3 blk) p))
(goto-char (1+ (nth 3 blk)))
(setq blk (nndoc-oe-dbx-decode-block)))
@@ -927,7 +927,7 @@ from the document.")
(and (re-search-backward nndoc-file-end nil t)
(beginning-of-line)))))
(setq body-end (point))
- (push (list (incf i) head-begin head-end body-begin body-end
+ (push (list (cl-incf i) head-begin head-end body-begin body-end
(count-lines body-begin body-end))
nndoc-dissection-alist)))))
(setq nndoc-dissection-alist (nreverse nndoc-dissection-alist))))
@@ -1040,7 +1040,7 @@ PARENT is the message-ID of the parent summary line, or nil for none."
(replace-match line t t summary-insert)
(concat summary-insert line)))))
;; Generate dissection information for this entity.
- (push (list (incf nndoc-mime-split-ordinal)
+ (push (list (cl-incf nndoc-mime-split-ordinal)
head-begin head-end body-begin body-end
(count-lines body-begin body-end)
article-insert summary-insert)
@@ -1078,7 +1078,7 @@ PARENT is the message-ID of the parent summary line, or nil for none."
part-begin part-end article-insert
(concat position
(and position ".")
- (format "%d" (incf part-counter)))
+ (format "%d" (cl-incf part-counter)))
message-id)))))))))
;;;###autoload
diff --git a/lisp/gnus/nndraft.el b/lisp/gnus/nndraft.el
index 0f7df3b4f4b..bc475ee2951 100644
--- a/lisp/gnus/nndraft.el
+++ b/lisp/gnus/nndraft.el
@@ -31,7 +31,6 @@
(require 'nnmh)
(require 'nnoo)
(require 'mm-util)
-(eval-when-compile (require 'cl))
;; The nnoo-import at the end, I think.
(declare-function nndraft-request-list "nndraft" (&rest args) t)
diff --git a/lisp/gnus/nneething.el b/lisp/gnus/nneething.el
index 39e8d6ef66d..f64007aaf79 100644
--- a/lisp/gnus/nneething.el
+++ b/lisp/gnus/nneething.el
@@ -25,7 +25,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'mailcap)
(require 'nnheader)
@@ -101,7 +101,7 @@ included.")
(nneething-insert-head file)
(insert ".\n"))
- (incf count)
+ (cl-incf count)
(and large
(zerop (% count 20))
@@ -215,8 +215,9 @@ included.")
(setq nneething-map
(mapcar (lambda (n)
(list (cdr n) (car n)
- (nth 5 (file-attributes
- (nneething-file-name (car n))))))
+ (file-attribute-modification-time
+ (file-attributes
+ (nneething-file-name (car n))))))
nneething-map)))
;; Remove files matching the exclusion regexp.
(when nneething-exclude-files
@@ -244,7 +245,7 @@ included.")
(while map
(if (and (member (cadr (car map)) files)
;; We also remove files that have changed mod times.
- (equal (nth 5 (file-attributes
+ (equal (file-attribute-modification-time (file-attributes
(nneething-file-name (cadr (car map)))))
(cadr (cdar map))))
(progn
@@ -262,7 +263,7 @@ included.")
(setq touched t)
(setcdr nneething-active (1+ (cdr nneething-active)))
(push (list (cdr nneething-active) (car files)
- (nth 5 (file-attributes
+ (file-attribute-modification-time (file-attributes
(nneething-file-name (car files)))))
nneething-map))
(setq files (cdr files)))
@@ -318,15 +319,17 @@ included.")
"Subject: " (file-name-nondirectory file) (or extra-msg "") "\n"
"Message-ID: <nneething-" (nneething-encode-file-name file)
"@" (system-name) ">\n"
- (if (equal '(0 0) (nth 5 atts)) ""
- (concat "Date: " (current-time-string (nth 5 atts)) "\n"))
+ (if (time-equal-p 0 (file-attribute-modification-time atts)) ""
+ (concat "Date: "
+ (current-time-string (file-attribute-modification-time atts))
+ "\n"))
(or (when buffer
(with-current-buffer buffer
(when (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t)
(concat "From: " (match-string 0) "\n"))))
- (nneething-from-line (nth 2 atts) file))
- (if (> (string-to-number (int-to-string (nth 7 atts))) 0)
- (concat "Chars: " (int-to-string (nth 7 atts)) "\n")
+ (nneething-from-line (file-attribute-user-id atts) file))
+ (if (> (file-attribute-size atts) 0)
+ (concat "Chars: " (int-to-string (file-attribute-size atts)) "\n")
"")
(if buffer
(with-current-buffer buffer
diff --git a/lisp/gnus/nnfolder.el b/lisp/gnus/nnfolder.el
index 867bd8dc20e..1c83045e45e 100644
--- a/lisp/gnus/nnfolder.el
+++ b/lisp/gnus/nnfolder.el
@@ -32,7 +32,6 @@
(require 'message)
(require 'nnmail)
(require 'nnoo)
-(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-util)
(require 'gnus-range)
@@ -863,7 +862,7 @@ deleted. Point is left where the deleted region was."
(mm-enable-multibyte) ;; Use multibyte buffer for future copying.
(buffer-disable-undo)
(if (equal (cadr (assoc group nnfolder-scantime-alist))
- (nth 5 (file-attributes file)))
+ (file-attribute-modification-time (file-attributes file)))
;; This looks up-to-date, so we don't do any scanning.
(if (file-exists-p file)
buffer
@@ -878,17 +877,17 @@ deleted. Point is left where the deleted region was."
(delete-char 1))
(nnmail-activate 'nnfolder)
;; Read in the file.
- (let ((delim "^From ")
- (marker (concat "\n" nnfolder-article-marker))
- (number "[0-9]+")
- (active (or (cadr (assoc group nnfolder-group-alist))
- (cons 1 0)))
- (scantime (assoc group nnfolder-scantime-alist))
- (minid most-positive-fixnum)
- maxid start end newscantime
- novbuf articles newnum
- buffer-read-only)
- (setq maxid (cdr active))
+ (let* ((delim "^From ")
+ (marker (concat "\n" nnfolder-article-marker))
+ (number "[0-9]+")
+ (active (or (cadr (assoc group nnfolder-group-alist))
+ (cons 1 0)))
+ (scantime (assoc group nnfolder-scantime-alist))
+ (minid (cdr active))
+ maxid start end newscantime
+ novbuf articles newnum
+ buffer-read-only)
+ (setq maxid minid)
(unless (or gnus-nov-is-evil nnfolder-nov-is-evil
(and (file-exists-p nov)
@@ -959,7 +958,7 @@ deleted. Point is left where the deleted region was."
(while (not (= end (point-max)))
(setq start (marker-position end))
(goto-char end)
- ;; There may be more than one "From " line, so we skip past
+ ;; There may be more than one "From " line, so we skip past
;; them.
(while (looking-at delim)
(forward-line 1))
diff --git a/lisp/gnus/nngateway.el b/lisp/gnus/nngateway.el
index 2bc2e37f896..92e36a2e4f9 100644
--- a/lisp/gnus/nngateway.el
+++ b/lisp/gnus/nngateway.el
@@ -24,7 +24,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
(require 'nnoo)
(require 'message)
diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el
index dec32361cae..090b8420842 100644
--- a/lisp/gnus/nnheader.el
+++ b/lisp/gnus/nnheader.el
@@ -26,7 +26,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defvar nnmail-extra-headers)
(defvar gnus-newsgroup-name)
@@ -237,7 +237,7 @@ on your system, you could say something like:
(format "fake+none+%s+%d" gnus-newsgroup-name number)
(format "fake+none+%s+%s"
gnus-newsgroup-name
- (int-to-string (incf nnheader-fake-message-id)))))
+ (int-to-string (cl-incf nnheader-fake-message-id)))))
(defsubst nnheader-fake-message-id-p (id)
(save-match-data ; regular message-id's are <.*>
@@ -408,7 +408,7 @@ on your system, you could say something like:
`(let ((id (nnheader-nov-field)))
(if (string-match "^<[^>]+>$" id)
,(if nnheader-uniquify-message-id
- `(if (string-match "__[^@]+@" id)
+ '(if (string-match "__[^@]+@" id)
(concat (substring id 0 (match-beginning 0))
(substring id (1- (match-end 0))))
id)
@@ -612,7 +612,7 @@ the line could be found."
(while (and (eq nnheader-head-chop-length
(nth 1 (mm-insert-file-contents
file nil beg
- (incf beg nnheader-head-chop-length))))
+ (cl-incf beg nnheader-head-chop-length))))
;; CRLF or CR might be used for the line-break code.
(prog1 (not (re-search-forward "\n\r?\n\\|\r\r" nil t))
(goto-char (point-max)))
@@ -784,7 +784,7 @@ If FULL, translate everything."
(when (setq trans (cdr (assq (aref leaf i)
nnheader-file-name-translation-alist)))
(aset leaf i trans))
- (incf i))
+ (cl-incf i))
(concat path leaf))))
(defun nnheader-report (backend &rest args)
@@ -896,7 +896,7 @@ without formatting."
(defun nnheader-file-size (file)
"Return the file size of FILE or 0."
- (or (nth 7 (file-attributes file)) 0))
+ (or (file-attribute-size (file-attributes file)) 0))
(defun nnheader-find-etc-directory (package &optional file first)
"Go through `load-path' and find the \"../etc/PACKAGE\" directory.
@@ -951,7 +951,7 @@ find-file-hook, etc.
(mm-insert-file-contents filename visit beg end replace)))
(defun nnheader-insert-nov-file (file first)
- (let ((size (nth 7 (file-attributes file)))
+ (let ((size (file-attribute-size (file-attributes file)))
(cutoff (* 32 1024)))
(when size
(if (< size cutoff)
@@ -973,7 +973,7 @@ find-file-hook, etc.
(defun nnheader-find-file-noselect (&rest args)
"Open a file with some variables bound.
See `find-file-noselect' for the arguments."
- (letf* ((format-alist nil)
+ (cl-letf* ((format-alist nil)
(auto-mode-alist (mm-auto-mode-alist))
((default-value 'major-mode) 'fundamental-mode)
(enable-local-variables nil)
@@ -1042,12 +1042,7 @@ See `find-file-noselect' for the arguments."
;; When changing this function, consider changing `pop3-accept-process-output'
;; as well.
(defun nnheader-accept-process-output (process)
- (accept-process-output
- process
- (truncate nnheader-read-timeout)
- (truncate (* (- nnheader-read-timeout
- (truncate nnheader-read-timeout))
- 1000))))
+ (accept-process-output process nnheader-read-timeout))
(defun nnheader-update-marks-actions (backend-marks actions)
(dolist (action actions)
@@ -1071,19 +1066,16 @@ See `find-file-noselect' for the arguments."
(defmacro nnheader-insert-buffer-substring (buffer &optional start end)
"Copy string from unibyte buffer to multibyte current buffer."
- `(if enable-multibyte-characters
- (insert (with-current-buffer ,buffer
- (string-to-multibyte
- ,(if (or start end)
- `(buffer-substring (or ,start (point-min))
- (or ,end (point-max)))
- '(buffer-string)))))
- (insert-buffer-substring ,buffer ,start ,end)))
+ `(insert (with-current-buffer ,buffer
+ ,(if (or start end)
+ `(buffer-substring (or ,start (point-min))
+ (or ,end (point-max)))
+ '(buffer-string)))))
(defvar nnheader-last-message-time '(0 0))
(defun nnheader-message-maybe (&rest args)
(let ((now (current-time)))
- (when (> (float-time (time-subtract now nnheader-last-message-time)) 1)
+ (when (time-less-p 1 (time-subtract now nnheader-last-message-time))
(setq nnheader-last-message-time now)
(apply 'nnheader-message args))))
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index 5e26e7babd1..ac1d28644f7 100644
--- a/lisp/gnus/nnimap.el
+++ b/lisp/gnus/nnimap.el
@@ -27,7 +27,7 @@
;;; Code:
(eval-when-compile
- (require 'cl)
+ (require 'cl-lib)
(require 'subr-x))
(require 'nnheader)
@@ -36,7 +36,6 @@
(require 'nnoo)
(require 'netrc)
(require 'utf7)
-(require 'tls)
(require 'parse-time)
(require 'nnmail)
@@ -56,6 +55,13 @@
If nnimap-stream is `ssl', this will default to `imaps'. If not,
it will default to `imap'.")
+(defvoo nnimap-use-namespaces nil
+ "Whether to use IMAP namespaces.
+If in Gnus your folder names in all start with (e.g.) `INBOX',
+you probably want to set this to t. The effects of this are
+purely cosmetic, but changing this variable will affect the
+names of your nnimap groups. ")
+
(defvoo nnimap-stream 'undecided
"How nnimap talks to the IMAP server.
The value should be either `undecided', `ssl' or `tls',
@@ -111,6 +117,8 @@ some servers.")
(defvoo nnimap-current-infos nil)
+(defvoo nnimap-namespace nil)
+
(defun nnimap-decode-gnus-group (group)
(decode-coding-string group 'utf-8))
@@ -144,7 +152,7 @@ textual parts.")
(defvar nnimap-keepalive-timer nil)
(defvar nnimap-process-buffers nil)
-(defstruct nnimap
+(cl-defstruct nnimap
group process commands capabilities select-result newlinep server
last-command-time greeting examined stream-type initial-resync)
@@ -167,6 +175,19 @@ textual parts.")
(defvar nnimap-inhibit-logging nil)
+(defun nnimap-group-to-imap (group)
+ "Convert Gnus group name to IMAP mailbox name."
+ (let* ((inbox (if nnimap-namespace
+ (substring nnimap-namespace 0 -1) nil)))
+ (utf7-encode
+ (cond ((or (not inbox)
+ (string-equal group inbox))
+ group)
+ ((string-prefix-p "#" group)
+ (substring group 1))
+ (t
+ (concat nnimap-namespace group))) t)))
+
(defun nnimap-buffer ()
(nnimap-find-process-buffer nntp-server-buffer))
@@ -212,23 +233,24 @@ textual parts.")
(defun nnimap-transform-headers ()
(goto-char (point-min))
(let (article lines size string labels)
- (block nil
+ (cl-block nil
(while (not (eobp))
(while (not (looking-at "\\* [0-9]+ FETCH"))
(delete-region (point) (progn (forward-line 1) (point)))
(when (eobp)
- (return)))
+ (cl-return)))
(goto-char (match-end 0))
;; Unfold quoted {number} strings.
- (while (re-search-forward
- "[^]][ (]{\\([0-9]+\\)}\r?\n"
- (save-excursion
- ;; Start of the header section.
- (or (re-search-forward "] {[0-9]+}\r?\n" nil t)
- ;; Start of the next FETCH.
- (re-search-forward "\\* [0-9]+ FETCH" nil t)
- (point-max)))
- t)
+ (while (or (looking-at "[ (]{\\([0-9]+\\)}\r?\n")
+ (re-search-forward
+ "[^]][ (]{\\([0-9]+\\)}\r?\n"
+ (save-excursion
+ ;; Start of the header section.
+ (or (re-search-forward "] {[0-9]+}\r?\n" nil t)
+ ;; Start of the next FETCH.
+ (re-search-forward "\\* [0-9]+ FETCH" nil t)
+ (point-max)))
+ t))
(setq size (string-to-number (match-string 1)))
(delete-region (+ (match-beginning 0) 2) (point))
(setq string (buffer-substring (point) (+ (point) size)))
@@ -364,12 +386,12 @@ textual parts.")
(with-current-buffer buffer
(when (and nnimap-object
(nnimap-last-command-time nnimap-object)
- (> (float-time
- (time-subtract
- now
- (nnimap-last-command-time nnimap-object)))
- ;; More than five minutes since the last command.
- (* 5 60)))
+ (time-less-p
+ ;; More than five minutes since the last command.
+ (* 5 60)
+ (time-subtract
+ now
+ (nnimap-last-command-time nnimap-object))))
(ignore-errors ;E.g. "buffer foo has no process".
(nnimap-send-command "NOOP"))))))))
@@ -381,7 +403,7 @@ textual parts.")
(setq nnimap-stream 'ssl))
(let ((stream
(if (eq nnimap-stream 'undecided)
- (loop for type in '(ssl network)
+ (cl-loop for type in '(ssl network)
for stream = (let ((nnimap-stream type))
(nnimap-open-connection-1 buffer))
while (eq stream 'no-connect)
@@ -391,8 +413,11 @@ textual parts.")
nil
stream)))
+;; This is only needed for Windows XP or earlier
(defun nnimap-map-port (port)
- (if (equal port "imaps")
+ (if (and (eq system-type 'windows-nt)
+ (<= (car (x-server-version)) 5)
+ (equal port "imaps"))
"993"
port))
@@ -442,7 +467,8 @@ textual parts.")
(props (cdr stream-list))
(greeting (plist-get props :greeting))
(capabilities (plist-get props :capabilities))
- (stream-type (plist-get props :type)))
+ (stream-type (plist-get props :type))
+ (server (nnoo-current-server 'nnimap)))
(when (and stream (not (memq (process-status stream) '(open run))))
(setq stream nil))
@@ -475,9 +501,7 @@ textual parts.")
;; the virtual server name and the address
(nnimap-credentials
(gnus-delete-duplicates
- (list
- (nnoo-current-server 'nnimap)
- nnimap-address))
+ (list server nnimap-address))
ports
nnimap-user))))
(setq nnimap-object nil)
@@ -496,8 +520,17 @@ textual parts.")
(dolist (response (cddr (nnimap-command "CAPABILITY")))
(when (string= "CAPABILITY" (upcase (car response)))
(setf (nnimap-capabilities nnimap-object)
- (mapcar #'upcase (cdr response))))))
- ;; If the login failed, then forget the credentials
+ (mapcar #'upcase (cdr response)))))
+ (when (and nnimap-use-namespaces
+ (nnimap-capability "NAMESPACE"))
+ (erase-buffer)
+ (nnimap-wait-for-response (nnimap-send-command "NAMESPACE"))
+ (let ((response (nnimap-last-response-string)))
+ (when (string-match
+ "^\\*\\W+NAMESPACE\\W+((\"\\([^\"\n]+\\)\"\\W+\"\\(.\\)\"))\\W+"
+ response)
+ (setq nnimap-namespace (match-string 1 response))))))
+ ;; If the login failed, then forget the credentials
;; that are now possibly cached.
(dolist (host (list (nnoo-current-server 'nnimap)
nnimap-address))
@@ -522,6 +555,7 @@ textual parts.")
((and (not (nnimap-capability "LOGINDISABLED"))
(eq (nnimap-stream-type nnimap-object) 'tls)
(or (null nnimap-authenticator)
+ (eq nnimap-authenticator 'anonymous)
(eq nnimap-authenticator 'login)))
(nnimap-command "LOGIN %S %S" user password))
((and (nnimap-capability "AUTH=CRAM-MD5")
@@ -541,6 +575,7 @@ textual parts.")
(nnimap-wait-for-response sequence)))
((and (not (nnimap-capability "LOGINDISABLED"))
(or (null nnimap-authenticator)
+ (eq nnimap-authenticator 'anonymous)
(eq nnimap-authenticator 'login)))
(nnimap-command "LOGIN %S %S" user password))
((and (nnimap-capability "AUTH=PLAIN")
@@ -772,7 +807,7 @@ textual parts.")
(insert "\n--" boundary "--\n")))
(defun nnimap-find-wanted-parts (structure)
- (message-flatten-list (nnimap-find-wanted-parts-1 structure "")))
+ (flatten-tree (nnimap-find-wanted-parts-1 structure "")))
(defun nnimap-find-wanted-parts-1 (structure prefix)
(let ((num 1)
@@ -794,7 +829,7 @@ textual parts.")
(equal id "1")
(string-match nnimap-fetch-partial-articles type))
(push id parts))))
- (incf num)))
+ (cl-incf num)))
(nreverse parts)))
(deffoo nnimap-request-group (group &optional server dont-check info)
@@ -835,7 +870,7 @@ textual parts.")
(with-current-buffer (nnimap-buffer)
(erase-buffer)
(let ((group-sequence
- (nnimap-send-command "SELECT %S" (utf7-encode group t)))
+ (nnimap-send-command "SELECT %S" (nnimap-group-to-imap group)))
(flag-sequence
(nnimap-send-command "UID FETCH 1:* FLAGS")))
(setf (nnimap-group nnimap-object) group)
@@ -868,13 +903,13 @@ textual parts.")
(setq group (nnimap-decode-gnus-group group))
(when (nnimap-change-group nil server)
(with-current-buffer (nnimap-buffer)
- (car (nnimap-command "CREATE %S" (utf7-encode group t))))))
+ (car (nnimap-command "CREATE %S" (nnimap-group-to-imap group))))))
(deffoo nnimap-request-delete-group (group &optional _force server)
(setq group (nnimap-decode-gnus-group group))
(when (nnimap-change-group nil server)
(with-current-buffer (nnimap-buffer)
- (car (nnimap-command "DELETE %S" (utf7-encode group t))))))
+ (car (nnimap-command "DELETE %S" (nnimap-group-to-imap group))))))
(deffoo nnimap-request-rename-group (group new-name &optional server)
(setq group (nnimap-decode-gnus-group group))
@@ -882,7 +917,7 @@ textual parts.")
(with-current-buffer (nnimap-buffer)
(nnimap-unselect-group)
(car (nnimap-command "RENAME %S %S"
- (utf7-encode group t) (utf7-encode new-name t))))))
+ (nnimap-group-to-imap group) (nnimap-group-to-imap new-name))))))
(defun nnimap-unselect-group ()
;; Make sure we don't have this group open read/write by asking
@@ -942,7 +977,7 @@ textual parts.")
"UID COPY %d %S"))
(result (nnimap-command
command article
- (utf7-encode internal-move-group t))))
+ (nnimap-group-to-imap internal-move-group))))
(when (and (car result) (not can-move))
(nnimap-delete-article article))
(cons internal-move-group
@@ -1009,7 +1044,7 @@ textual parts.")
"UID MOVE %s %S"
"UID COPY %s %S")
(nnimap-article-ranges (gnus-compress-sequence articles))
- (utf7-encode (gnus-group-real-name nnmail-expiry-target) t))
+ (nnimap-group-to-imap (gnus-group-real-name nnmail-expiry-target)))
(set (if can-move 'deleted-articles 'articles-to-delete) articles))))
t)
(t
@@ -1134,7 +1169,7 @@ If LIMIT, first try to limit the search to the N last articles."
(unsubscribe "UNSUBSCRIBE")))))
(when command
(with-current-buffer (nnimap-buffer)
- (nnimap-command "%s %S" (cadr command) (utf7-encode group t)))))))
+ (nnimap-command "%s %S" (cadr command) (nnimap-group-to-imap group)))))))
(deffoo nnimap-request-set-mark (group actions &optional server)
(setq group (nnimap-decode-gnus-group group))
@@ -1145,7 +1180,7 @@ If LIMIT, first try to limit the search to the N last articles."
;; Just send all the STORE commands without waiting for
;; response. If they're successful, they're successful.
(dolist (action actions)
- (destructuring-bind (range action marks) action
+ (cl-destructuring-bind (range action marks) action
(let ((flags (nnimap-marks-to-flags marks)))
(when flags
(setq sequence (nnimap-send-command
@@ -1171,8 +1206,8 @@ If LIMIT, first try to limit the search to the N last articles."
;; We don't really care about the article number, because
;; that's determined by the IMAP server later. So just
;; return the group name.
- `(lambda (group)
- (list (list group)))))))
+ (lambda (group)
+ (list (list group)))))))
(setq group (nnimap-decode-gnus-group group))
(when (nnimap-change-group nil server)
(nnmail-check-syntax)
@@ -1189,7 +1224,7 @@ If LIMIT, first try to limit the search to the N last articles."
(nnimap-unselect-group))
(erase-buffer)
(setq sequence (nnimap-send-command
- "APPEND %S {%d}" (utf7-encode group t)
+ "APPEND %S {%d}" (nnimap-group-to-imap group)
(length message)))
(unless nnimap-streaming
(nnimap-wait-for-connection "^[+]"))
@@ -1269,8 +1304,12 @@ If LIMIT, first try to limit the search to the N last articles."
(defun nnimap-get-groups ()
(erase-buffer)
- (let ((sequence (nnimap-send-command "LIST \"\" \"*\""))
- groups)
+ (let* ((sequence (nnimap-send-command "LIST \"\" \"*\""))
+ (prefix nnimap-namespace)
+ (prefix-len (if prefix (length prefix) nil))
+ (inbox (if prefix
+ (substring prefix 0 -1) nil))
+ groups)
(nnimap-wait-for-response sequence)
(subst-char-in-region (point-min) (point-max)
?\\ ?% t)
@@ -1287,11 +1326,16 @@ If LIMIT, first try to limit the search to the N last articles."
(skip-chars-backward " \r\"")
(point)))))
(unless (member '%NoSelect flags)
- (push (utf7-decode (if (stringp group)
- group
- (format "%s" group))
- t)
- groups))))
+ (let* ((group (utf7-decode (if (stringp group) group
+ (format "%s" group)) t))
+ (group (cond ((or (not prefix)
+ (equal inbox group))
+ group)
+ ((string-prefix-p prefix group)
+ (substring group prefix-len))
+ (t
+ (concat "#" group)))))
+ (push group groups)))))
(nreverse groups)))
(defun nnimap-get-responses (sequences)
@@ -1317,7 +1361,7 @@ If LIMIT, first try to limit the search to the N last articles."
(dolist (group groups)
(setf (nnimap-examined nnimap-object) group)
(push (list (nnimap-send-command "EXAMINE %S"
- (utf7-encode group t))
+ (nnimap-group-to-imap group))
group)
sequences))
(nnimap-wait-for-response (caar sequences))
@@ -1389,7 +1433,7 @@ If LIMIT, first try to limit the search to the N last articles."
unexist)
(push
(list (nnimap-send-command "EXAMINE %S (%s (%s %s))"
- (utf7-encode group t)
+ (nnimap-group-to-imap group)
(nnimap-quirk "QRESYNC")
uidvalidity modseq)
'qresync
@@ -1408,10 +1452,10 @@ If LIMIT, first try to limit the search to the N last articles."
(if (and active uidvalidity unexist)
;; Fetch the last 100 flags.
(setq start (max 1 (- (cdr active) 100)))
- (incf (nnimap-initial-resync nnimap-object))
+ (cl-incf (nnimap-initial-resync nnimap-object))
(setq start 1))
(push (list (nnimap-send-command "%s %S" command
- (utf7-encode group t))
+ (nnimap-group-to-imap group))
(nnimap-send-command "UID FETCH %d:* FLAGS" start)
start group command)
sequences))))
@@ -1472,7 +1516,7 @@ If LIMIT, first try to limit the search to the N last articles."
(nnimap-update-info info marks)))))
(defun nnimap-update-info (info marks)
- (destructuring-bind (existing flags high low uidnext start-article
+ (cl-destructuring-bind (existing flags high low uidnext start-article
permanent-flags uidvalidity
vanished highestmodseq) marks
(cond
@@ -1544,6 +1588,8 @@ If LIMIT, first try to limit the search to the N last articles."
info existing (nnimap-imap-ranges-to-gnus-ranges vanished) flags)
;; Do normal non-QRESYNC flag updates.
;; Update the list of read articles.
+ (unless start-article
+ (setq start-article 1))
(let* ((unread
(gnus-compress-sequence
(gnus-set-difference
@@ -1725,7 +1771,7 @@ If LIMIT, first try to limit the search to the N last articles."
(let (start end articles groups uidnext elems permanent-flags
uidvalidity vanished highestmodseq)
(dolist (elem sequences)
- (destructuring-bind (group-sequence flag-sequence totalp group command)
+ (cl-destructuring-bind (group-sequence flag-sequence totalp group command)
elem
(setq start (point))
(when (and
@@ -1843,7 +1889,7 @@ Return the server's response to the SELECT or EXAMINE command."
(if read-only
"EXAMINE"
"SELECT")
- (utf7-encode group t))))
+ (nnimap-group-to-imap group))))
(when (car result)
(setf (nnimap-group nnimap-object) group
(nnimap-select-result nnimap-object) result)
@@ -1861,7 +1907,9 @@ Return the server's response to the SELECT or EXAMINE command."
(setq nnimap-connection-alist (delq entry nnimap-connection-alist))
nil))))
-(defvar nnimap-sequence 0)
+;; Leave room for `open-network-stream' to issue a couple of IMAP
+;; commands before nnimap starts.
+(defvar nnimap-sequence 5)
(defun nnimap-send-command (&rest args)
(setf (nnimap-last-command-time nnimap-object) (current-time))
@@ -1869,7 +1917,7 @@ Return the server's response to the SELECT or EXAMINE command."
(get-buffer-process (current-buffer))
(nnimap-log-command
(format "%d %s%s\n"
- (incf nnimap-sequence)
+ (cl-incf nnimap-sequence)
(apply #'format args)
(if (nnimap-newlinep nnimap-object)
""
@@ -2099,7 +2147,7 @@ Return the server's response to the SELECT or EXAMINE command."
(dolist (spec specs)
(when (and (not (member (car spec) groups))
(not (eq (car spec) 'junk)))
- (nnimap-command "CREATE %S" (utf7-encode (car spec) t))))
+ (nnimap-command "CREATE %S" (nnimap-group-to-imap (car spec)))))
;; Then copy over all the messages.
(erase-buffer)
(dolist (spec specs)
@@ -2115,7 +2163,7 @@ Return the server's response to the SELECT or EXAMINE command."
"UID MOVE %s %S"
"UID COPY %s %S")
(nnimap-article-ranges ranges)
- (utf7-encode group t))
+ (nnimap-group-to-imap group))
ranges)
sequences)))))
;; Wait for the last COPY response...
@@ -2166,7 +2214,7 @@ Return the server's response to the SELECT or EXAMINE command."
(let ((specs nil)
entry)
(dolist (elem list)
- (destructuring-bind (article spec) elem
+ (cl-destructuring-bind (article spec) elem
(dolist (group (delete nil (mapcar #'car spec)))
(unless (setq entry (assoc group specs))
(push (setq entry (list group)) specs))
@@ -2178,12 +2226,12 @@ Return the server's response to the SELECT or EXAMINE command."
(defun nnimap-transform-split-mail ()
(goto-char (point-min))
(let (article bytes)
- (block nil
+ (cl-block nil
(while (not (eobp))
(while (not (looking-at "\\* [0-9]+ FETCH.+UID \\([0-9]+\\)"))
(delete-region (point) (progn (forward-line 1) (point)))
(when (eobp)
- (return)))
+ (cl-return)))
(setq article (match-string 1)
bytes (nnimap-get-length))
(delete-region (line-beginning-position) (line-end-position))
diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el
index 05b2f0aa8a7..37a38a58d46 100644
--- a/lisp/gnus/nnir.el
+++ b/lisp/gnus/nnir.el
@@ -30,7 +30,7 @@
;;; Commentary:
;; What does it do? Well, it allows you to search your mail using
-;; some search engine (imap, namazu, swish-e, gmane and others -- see
+;; some search engine (imap, namazu, swish-e and others -- see
;; later) by typing `G G' in the Group buffer. You will then get a
;; buffer which shows all articles matching the query, sorted by
;; Retrieval Status Value (score).
@@ -518,6 +518,24 @@ that it is for notmuch, not Namazu."
:type '(regexp)
:group 'nnir)
+(defcustom nnir-notmuch-filter-group-names-function nil
+ "Whether and how to use Gnus group names as \"path:\" search terms.
+When nil, the groups being searched in are not used as notmuch
+:path search terms. It's still possible to use \"path:\" terms
+manually within the search query, however.
+
+When a function, map this function over all the group names. To
+use the group names unchanged, set to (lambda (g) g). Multiple
+transforms (for instance, converting \".\" to \"/\") can be added
+like so:
+
+\(add-function :filter-return
+ nnir-notmuch-filter-group-names-function
+ (lambda (g) (replace-regexp-in-string \"\\\\.\" \"/\" g)))"
+ :version "27.1"
+ :type '(choice function
+ nil))
+
;;; Developer Extension Variable:
(defvar nnir-engines
@@ -530,8 +548,6 @@ that it is for notmuch, not Namazu."
nnir-imap-search-argument-history ; the history to use
,nnir-imap-default-search-key ; default
)))
- (gmane nnir-run-gmane
- ((gmane-author . "Gmane Author: ")))
(swish++ nnir-run-swish++
((swish++-group . "Swish++ Group spec (regexp): ")))
(swish-e nnir-run-swish-e
@@ -561,7 +577,7 @@ needs the variables `nnir-namazu-program',
Add an entry here when adding a new search engine.")
-(defcustom nnir-method-default-engines '((nnimap . imap) (nntp . gmane))
+(defcustom nnir-method-default-engines '((nnimap . imap))
"Alist of default search engines keyed by server method."
:version "24.1"
:group 'nnir
@@ -641,10 +657,10 @@ skips all prompting."
(let ((backend (car (gnus-server-to-method server))))
(if backend
(nnoo-change-server backend server definitions)
- (add-hook 'gnus-summary-mode-hook 'nnir-mode)
+ (add-hook 'gnus-summary-prepared-hook 'nnir-mode)
(nnoo-change-server 'nnir server definitions))))
-(deffoo nnir-request-group (group &optional server dont-check info)
+(deffoo nnir-request-group (group &optional server dont-check _info)
(nnir-possibly-change-group group server)
(let ((pgroup (gnus-group-guess-full-name-from-command-method group))
length)
@@ -669,7 +685,9 @@ skips all prompting."
group)))) ; group name
nnir-artlist)
-(deffoo nnir-retrieve-headers (articles &optional group server fetch-old)
+(defvar gnus-inhibit-demon)
+
+(deffoo nnir-retrieve-headers (articles &optional _group _server _fetch-old)
(with-current-buffer nntp-server-buffer
(let ((gnus-inhibit-demon t)
(articles-by-group (nnir-categorize
@@ -716,6 +734,8 @@ skips all prompting."
(mapc 'nnheader-insert-nov headers)
'nov)))
+(defvar gnus-article-decode-hook)
+
(deffoo nnir-request-article (article &optional group server to-buffer)
(nnir-possibly-change-group group server)
(if (and (stringp article)
@@ -753,7 +773,7 @@ skips all prompting."
(cons artfullgroup artno)))))))
(deffoo nnir-request-move-article (article group server accept-form
- &optional last internal-move-group)
+ &optional last _internal-move-group)
(nnir-possibly-change-group group server)
(let* ((artfullgroup (nnir-article-group article))
(artno (nnir-article-number article))
@@ -803,7 +823,8 @@ skips all prompting."
(error "Can't warp to a pseudo-article")))
(backend-article-group (nnir-article-group cur))
(backend-article-number (nnir-article-number cur))
- (quit-config (gnus-ephemeral-group-p gnus-newsgroup-name)))
+; (quit-config (gnus-ephemeral-group-p gnus-newsgroup-name))
+ )
;; what should we do here? we could leave all the buffers around
;; and assume that we have to exit from them one by one. or we can
@@ -818,7 +839,7 @@ skips all prompting."
(gnus-summary-read-group-1 backend-article-group t t nil
nil (list backend-article-number))))
-(deffoo nnir-request-update-mark (group article mark)
+(deffoo nnir-request-update-mark (_group article mark)
(let ((artgroup (nnir-article-group article))
(artnumber (nnir-article-number article)))
(or (and artgroup
@@ -956,7 +977,7 @@ details on the language and supported extensions."
(save-excursion
(let ((qstring (cdr (assq 'query query)))
(server (cadr (gnus-server-to-method srv)))
- (defs (nth 2 (gnus-server-to-method srv)))
+;; (defs (nth 2 (gnus-server-to-method srv)))
(criteria (or (cdr (assq 'criteria query))
(cdr (assoc nnir-imap-default-search-key
nnir-imap-search-arguments))))
@@ -1164,7 +1185,7 @@ returning the one at the supplied position."
(defun nnir-imap-end-of-input ()
"Are we at the end of input?"
- (skip-chars-forward "[[:blank:]]")
+ (skip-chars-forward "[:blank:]")
(looking-at "$"))
@@ -1177,7 +1198,7 @@ returning the one at the supplied position."
;; - article number
;; - file size
;; - group
-(defun nnir-run-swish++ (query server &optional group)
+(defun nnir-run-swish++ (query server &optional _group)
"Run QUERY against swish++.
Returns a vector of (group name, file name) pairs (also vectors,
actually).
@@ -1267,7 +1288,7 @@ Windows NT 4.0."
(nnir-artitem-rsv y)))))))))
;; Swish-E interface.
-(defun nnir-run-swish-e (query server &optional group)
+(defun nnir-run-swish-e (query server &optional _group)
"Run given query against swish-e.
Returns a vector of (group name, file name) pairs (also vectors,
actually).
@@ -1433,7 +1454,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0."
)))
;; Namazu interface
-(defun nnir-run-namazu (query server &optional group)
+(defun nnir-run-namazu (query server &optional _group)
"Run given query against Namazu. Returns a vector of (group name, file name)
pairs (also vectors, actually).
@@ -1502,23 +1523,31 @@ Tested with Namazu 2.0.6 on a GNU/Linux system."
(> (nnir-artitem-rsv x)
(nnir-artitem-rsv y)))))))))
-(defun nnir-run-notmuch (query server &optional group)
+(defun nnir-run-notmuch (query server &optional groups)
"Run QUERY against notmuch.
Returns a vector of (group name, file name) pairs (also vectors,
-actually)."
-
- ;; (when group
- ;; (error "The notmuch backend cannot search specific groups"))
+actually). If GROUPS is a list of group names, use them to
+construct path: search terms (see the variable
+`nnir-notmuch-filter-group-names-function')."
(save-excursion
- (let ( (qstring (cdr (assq 'query query)))
- (groupspec (cdr (assq 'notmuch-group query)))
+ (let* ((qstring (cdr (assq 'query query)))
(prefix (nnir-read-server-parm 'nnir-notmuch-remove-prefix server))
artlist
(article-pattern (if (string-match "\\`nnmaildir:"
(gnus-group-server server))
- ":[0-9]+"
- "^[0-9]+$"))
+ ":[0-9]+"
+ "^[0-9]+$"))
+ (groups (when nnir-notmuch-filter-group-names-function
+ (delq nil
+ (mapcar nnir-notmuch-filter-group-names-function
+ (mapcar #'gnus-group-short-name groups)))))
+ (pathquery (when groups
+ (concat " ("
+ (mapconcat (lambda (g)
+ (format "path:%s" g))
+ groups " or")
+ ")")))
artno dirnam filenam)
(when (equal "" qstring)
@@ -1527,10 +1556,14 @@ actually)."
(set-buffer (get-buffer-create nnir-tmp-buffer))
(erase-buffer)
- (if groupspec
- (message "Doing notmuch query %s on %s..." qstring groupspec)
+ (if groups
+ (message "Doing notmuch query %s on %s..."
+ qstring (mapconcat #'identity groups " "))
(message "Doing notmuch query %s..." qstring))
+ (when groups
+ (setq qstring (concat qstring pathquery)))
+
(let* ((cp-list `( ,nnir-notmuch-program
nil ; input from /dev/null
t ; output
@@ -1568,10 +1601,7 @@ actually)."
(when (string-match article-pattern artno)
(when (not (null dirnam))
- ;; maybe limit results to matching groups.
- (when (or (not groupspec)
- (string-match groupspec dirnam))
- (nnir-add-result dirnam artno "" prefix server artlist)))))
+ (nnir-add-result dirnam artno "" prefix server artlist))))
(message "Massaging notmuch output...done")
@@ -1662,54 +1692,6 @@ actually)."
(declare-function mm-url-insert "mm-url" (url &optional follow-refresh))
(declare-function mm-url-encode-www-form-urlencoded "mm-url" (pairs))
-;; gmane interface
-(defun nnir-run-gmane (query srv &optional groups)
- "Run a search against a gmane back-end server."
- (let* ((case-fold-search t)
- (qstring (cdr (assq 'query query)))
- (server (cadr (gnus-server-to-method srv)))
- (groupspec (mapconcat
- (lambda (x)
- (if (string-match-p "gmane" x)
- (format "group:%s" (gnus-group-short-name x))
- (error "Can't search non-gmane groups: %s" x)))
- groups " "))
- (authorspec
- (if (assq 'gmane-author query)
- (format "author:%s" (cdr (assq 'gmane-author query))) ""))
- (search (format "%s %s %s"
- qstring groupspec authorspec))
- (gnus-inhibit-demon t)
- artlist)
- (require 'mm-url)
- (with-current-buffer (get-buffer-create nnir-tmp-buffer)
- (erase-buffer)
- (mm-url-insert
- (concat
- "http://search.gmane.org/nov.php"
- "?"
- (mm-url-encode-www-form-urlencoded
- `(("query" . ,search)
- ("HITSPERPAGE" . "999")))))
- (set-buffer-multibyte t)
- (decode-coding-region (point-min) (point-max) 'utf-8)
- (goto-char (point-min))
- (forward-line 1)
- (while (not (eobp))
- (unless (or (eolp) (looking-at "\x0d"))
- (let ((header (nnheader-parse-nov)))
- (let ((xref (mail-header-xref header))
- (xscore (string-to-number (cdr (assoc 'X-Score
- (mail-header-extra header))))))
- (when (string-match " \\([^:]+\\)[:/]\\([0-9]+\\)" xref)
- (push
- (vector
- (gnus-group-prefixed-name (match-string 1 xref) srv)
- (string-to-number (match-string 2 xref)) xscore)
- artlist)))))
- (forward-line 1)))
- (apply #'vector (nreverse (delete-dups artlist)))))
-
;;; Util Code:
(defun gnus-nnir-group-p (group)
@@ -1809,8 +1791,7 @@ article came from is also searched."
groups)
(gnus-request-list method)
(with-current-buffer nntp-server-buffer
- (let ((cur (current-buffer))
- name)
+ (let ((cur (current-buffer)))
(goto-char (point-min))
(unless (or (null nnir-ignored-newsgroups)
(string= nnir-ignored-newsgroups ""))
@@ -1818,31 +1799,29 @@ article came from is also searched."
(if (eq (car method) 'nntp)
(while (not (eobp))
(ignore-errors
- (push (string-as-unibyte
- (gnus-group-full-name
- (buffer-substring
- (point)
- (progn
- (skip-chars-forward "^ \t")
- (point)))
- method))
+ (push (gnus-group-full-name
+ (buffer-substring
+ (point)
+ (progn
+ (skip-chars-forward "^ \t")
+ (point)))
+ method)
groups))
(forward-line))
(while (not (eobp))
(ignore-errors
- (push (string-as-unibyte
- (if (eq (char-after) ?\")
- (gnus-group-full-name (read cur) method)
- (let ((p (point)) (name ""))
- (skip-chars-forward "^ \t\\\\")
- (setq name (buffer-substring p (point)))
- (while (eq (char-after) ?\\)
- (setq p (1+ (point)))
- (forward-char 2)
- (skip-chars-forward "^ \t\\\\")
- (setq name (concat name (buffer-substring
- p (point)))))
- (gnus-group-full-name name method))))
+ (push (if (eq (char-after) ?\")
+ (gnus-group-full-name (read cur) method)
+ (let ((p (point)) (name ""))
+ (skip-chars-forward "^ \t\\\\")
+ (setq name (buffer-substring p (point)))
+ (while (eq (char-after) ?\\)
+ (setq p (1+ (point)))
+ (forward-char 2)
+ (skip-chars-forward "^ \t\\\\")
+ (setq name (concat name (buffer-substring
+ p (point)))))
+ (gnus-group-full-name name method)))
groups))
(forward-line)))))
groups))
@@ -1851,7 +1830,7 @@ article came from is also searched."
(declare-function gnus-registry-action "gnus-registry"
(action data-header from &optional to method))
-(defun nnir-registry-action (action data-header from &optional to method)
+(defun nnir-registry-action (action data-header _from &optional to method)
"Call `gnus-registry-action' with the original article group."
(gnus-registry-action
action
@@ -1886,7 +1865,7 @@ article came from is also searched."
(gnus-group-find-parameter pgroup)))))
-(deffoo nnir-request-create-group (group &optional server args)
+(deffoo nnir-request-create-group (group &optional _server args)
(message "Creating nnir group %s" group)
(let* ((group (gnus-group-prefixed-name group '(nnir "nnir")))
(specs (assq 'nnir-specs args))
@@ -1907,13 +1886,13 @@ article came from is also searched."
(nnir-request-update-info group (gnus-get-info group)))
t)
-(deffoo nnir-request-delete-group (group &optional force server)
+(deffoo nnir-request-delete-group (_group &optional _force _server)
t)
-(deffoo nnir-request-list (&optional server)
+(deffoo nnir-request-list (&optional _server)
t)
-(deffoo nnir-request-scan (group method)
+(deffoo nnir-request-scan (_group _method)
t)
(deffoo nnir-request-close ()
diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el
index c52bc03e109..b6dbbea74cc 100644
--- a/lisp/gnus/nnmail.el
+++ b/lisp/gnus/nnmail.el
@@ -24,7 +24,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'gnus) ; for macro gnus-kill-buffer, at least
(require 'nnheader)
@@ -488,7 +488,8 @@ Example:
(to . "to\\|cc\\|apparently-to\\|resent-to\\|resent-cc")
(from . "from\\|sender\\|resent-from")
(nato . "to\\|cc\\|resent-to\\|resent-cc")
- (naany . "from\\|to\\|cc\\|sender\\|resent-from\\|resent-to\\|resent-cc"))
+ (naany . "from\\|to\\|cc\\|sender\\|resent-from\\|resent-to\\|resent-cc")
+ (list . "list-id\\|list-post\\|x-mailing-list\\|x-beenthere\\|x-loop"))
"Alist of abbreviations allowed in `nnmail-split-fancy'."
:group 'nnmail-split
:type '(repeat (cons :format "%v" symbol regexp)))
@@ -662,10 +663,10 @@ nn*-request-list should have been called before calling this function."
(narrow-to-region (point) (point-at-eol))
(setq group (read buffer))
(unless (stringp group)
- (setq group (symbol-name group)))
+ (setq group (encode-coding-string (symbol-name group) 'latin-1)))
(if (and (numberp (setq max (read buffer)))
(numberp (setq min (read buffer))))
- (push (list (string-as-unibyte group) (cons min max))
+ (push (list group (cons min max))
group-assoc)))
(error nil))
(widen)
@@ -723,7 +724,7 @@ If SOURCE is a directory spec, try to return the group name component."
;; Skip all the headers in case there are more "From "s...
(or (search-forward "\n\n" nil t)
(search-forward-regexp "^[^:]*\\( .*\\|\\)$" nil t)
- (search-forward " "))
+ (search-forward "\^_\^L"))
(point)))
;; Unquote the ">From " line, if any.
(goto-char (point-min))
@@ -763,7 +764,7 @@ If SOURCE is a directory spec, try to return the group name component."
(if (or (= (+ (point) content-length) (point-max))
(save-excursion
(goto-char (+ (point) content-length))
- (looking-at "")))
+ (looking-at "\^_")))
(progn
(goto-char (+ (point) content-length))
(setq do-search nil))
@@ -772,7 +773,7 @@ If SOURCE is a directory spec, try to return the group name component."
;; Go to the beginning of the next article - or to the end
;; of the buffer.
(when do-search
- (if (re-search-forward "^" nil t)
+ (if (re-search-forward "^\^_" nil t)
(goto-char (match-beginning 0))
(goto-char (1- (point-max)))))
(delete-char 1) ; delete ^_
@@ -781,7 +782,7 @@ If SOURCE is a directory spec, try to return the group name component."
(narrow-to-region start (point))
(goto-char (point-min))
(nnmail-check-duplication message-id func artnum-func)
- (incf count)
+ (cl-incf count)
(setq end (point-max))))
(goto-char end))
count))
@@ -927,7 +928,7 @@ If SOURCE is a directory spec, try to return the group name component."
(save-restriction
(narrow-to-region start (point))
(goto-char (point-min))
- (incf count)
+ (cl-incf count)
(nnmail-check-duplication message-id func artnum-func)
(setq end (point-max))))
(goto-char end)))
@@ -980,7 +981,7 @@ If SOURCE is a directory spec, try to return the group name component."
(save-restriction
(narrow-to-region start (point))
(goto-char (point-min))
- (incf count)
+ (cl-incf count)
(nnmail-check-duplication message-id func artnum-func junk-func)
(setq end (point-max))))
(goto-char end)
@@ -1248,11 +1249,11 @@ Return the number of characters in the body."
(progn (forward-line 1) (point))))
(insert (format "Xref: %s" (system-name)))
(while group-alist
- (insert (if (mm-multibyte-p)
- (string-as-multibyte
- (format " %s:%d" (caar group-alist) (cdar group-alist)))
- (string-as-unibyte
- (format " %s:%d" (caar group-alist) (cdar group-alist)))))
+ (insert (if enable-multibyte-characters
+ (format " %s:%d" (caar group-alist) (cdar group-alist))
+ (encode-coding-string
+ (format " %s:%d" (caar group-alist) (cdar group-alist))
+ 'utf-8)))
(setq group-alist (cdr group-alist)))
(insert "\n")))
@@ -1533,7 +1534,8 @@ See the documentation for the variable `nnmail-split-fancy' for details."
(and (setq file (ignore-errors
(symbol-value (intern (format "%s-active-file"
backend)))))
- (setq file-time (nth 5 (file-attributes file)))
+ (setq file-time (file-attribute-modification-time
+ (file-attributes file)))
(or (not
(setq timestamp
(condition-case ()
@@ -1541,11 +1543,8 @@ See the documentation for the variable `nnmail-split-fancy' for details."
(format "%s-active-timestamp"
backend)))
(error 'none))))
- (not (consp timestamp))
- (equal timestamp '(0 0))
- (> (nth 0 file-time) (nth 0 timestamp))
- (and (= (nth 0 file-time) (nth 0 timestamp))
- (> (nth 1 file-time) (nth 1 timestamp))))))
+ (eq timestamp 'none)
+ (time-less-p timestamp file-time))))
(save-excursion
(or (eq timestamp 'none)
(set (intern (format "%s-active-timestamp" backend))
@@ -1836,8 +1835,8 @@ be called once per group or once for all groups."
((error quit)
(message "Mail source %s failed: %s" source cond)
0)))
- (incf total new)
- (incf i)))
+ (cl-incf total new)
+ (cl-incf i)))
;; If we did indeed read any incoming spools, we save all info.
(if (zerop total)
(when mail-source-plugged
@@ -1883,7 +1882,7 @@ If TIME is nil, then return the cutoff time for oldness instead."
(setq days (days-to-time days))
;; Compare the time with the current time.
(if (null time)
- (time-subtract (current-time) days)
+ (time-since days)
(ignore-errors (time-less-p days (time-since time)))))))))
(declare-function gnus-group-mark-article-read "gnus-group" (group article))
@@ -1899,7 +1898,7 @@ If TIME is nil, then return the cutoff time for oldness instead."
(unless (eq target 'delete)
(when (or (gnus-request-group target nil nil (gnus-get-info target))
(gnus-request-create-group target))
- (let ((group-art (gnus-request-accept-article target nil nil t)))
+ (let ((group-art (gnus-request-accept-article target nil t t)))
(when (and (consp group-art)
(cdr group-art))
(gnus-group-mark-article-read target (cdr group-art))))))))
@@ -2034,7 +2033,7 @@ If TIME is nil, then return the cutoff time for oldness instead."
"Remove all instances of GROUP from `nnmail-split-history'."
(let ((history nnmail-split-history))
(while history
- (setcar history (gnus-remove-if (lambda (e) (string= (car e) group))
+ (setcar history (seq-remove (lambda (e) (string= (car e) group))
(car history)))
(pop history))
(setq nnmail-split-history (delq nil nnmail-split-history))))
diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el
index 272240f5a9f..9d02773d6f2 100644
--- a/lisp/gnus/nnmaildir.el
+++ b/lisp/gnus/nnmaildir.el
@@ -69,7 +69,8 @@
(require 'nnmail)
(eval-when-compile
- (require 'cl))
+ (require 'cl-lib)
+ (require 'subr-x))
(defconst nnmaildir-version "Gnus")
@@ -136,11 +137,10 @@ This variable is set by `nnmaildir-request-article'.")
(defconst nnmaildir--delivery-pid (concat "P" (number-to-string (emacs-pid))))
(defvar nnmaildir--delivery-count nil)
-;; An obarry containing symbols whose names are server names and whose values
-;; are servers:
-(defvar nnmaildir--servers (make-vector 3 0))
-;; The current server:
-(defvar nnmaildir--cur-server nil)
+(defvar nnmaildir--servers nil
+ "Alist mapping server name strings to servers.")
+(defvar nnmaildir--cur-server nil
+ "The current server.")
;; A copy of nnmail-extra-headers
(defvar nnmaildir--extra nil)
@@ -165,34 +165,34 @@ This variable is set by `nnmaildir-request-article'.")
(defmacro nnmaildir--nov-set-mtime (nov value) `(aset ,nov 3 ,value))
(defmacro nnmaildir--nov-set-extra (nov value) `(aset ,nov 4 ,value))
-(defstruct nnmaildir--art
+(cl-defstruct nnmaildir--art
(prefix nil :type string) ;; "time.pid.host"
(suffix nil :type string) ;; ":2,flags"
(num nil :type natnum) ;; article number
(msgid nil :type string) ;; "<mess.age@id>"
(nov nil :type vector)) ;; cached nov structure, or nil
-(defstruct nnmaildir--grp
- (name nil :type string) ;; "group.name"
- (new nil :type list) ;; new/ modtime
- (cur nil :type list) ;; cur/ modtime
- (min 1 :type natnum) ;; minimum article number
- (count 0 :type natnum) ;; count of articles
- (nlist nil :type list) ;; list of articles, ordered descending by number
- (flist nil :type vector) ;; obarray mapping filename prefix->article
- (mlist nil :type vector) ;; obarray mapping message-id->article
- (cache nil :type vector) ;; nov cache
- (index nil :type natnum) ;; index of next cache entry to replace
- (mmth nil :type vector)) ;; obarray mapping mark name->dir modtime
+(cl-defstruct nnmaildir--grp
+ (name nil :type string) ;; "group.name"
+ (new nil :type list) ;; new/ modtime
+ (cur nil :type list) ;; cur/ modtime
+ (min 1 :type natnum) ;; minimum article number
+ (count 0 :type natnum) ;; count of articles
+ (nlist nil :type list) ;; list of articles, ordered descending by number
+ (flist nil :type hash-table) ;; hash table mapping filename prefix->article
+ (mlist nil :type hash-table) ;; hash table mapping message-id->article
+ (cache nil :type vector) ;; nov cache
+ (index nil :type natnum) ;; index of next cache entry to replace
+ (mmth nil :type hash-table)) ;; hash table mapping mark name->dir modtime
; ("Mark Mod Time Hash")
-(defstruct nnmaildir--srv
+(cl-defstruct nnmaildir--srv
(address nil :type string) ;; server address string
(method nil :type list) ;; (nnmaildir "address" ...)
(prefix nil :type string) ;; "nnmaildir+address:"
(dir nil :type string) ;; "/expanded/path/to/server/dir/"
(ls nil :type function) ;; directory-files function
- (groups nil :type vector) ;; obarray mapping group name->group
+ (groups nil :type hash-table) ;; hash table mapping group name->group
(curgrp nil :type nnmaildir--grp) ;; current group, or nil
(error nil :type string) ;; last error message, or nil
(mtime nil :type list) ;; modtime of dir
@@ -239,17 +239,17 @@ This variable is set by `nnmaildir-request-article'.")
(setf (nnmaildir--grp-count group) count)
(setf (nnmaildir--grp-nlist group) new-nlist)
(setcdr nlist-pre nlist-post)
- (unintern prefix flist)
- (unintern msgid mlist))))
+ (remhash prefix flist)
+ (remhash msgid mlist))))
(defun nnmaildir--nlist-art (group num)
(let ((entry (assq num (nnmaildir--grp-nlist group))))
(if entry
(cdr entry))))
(defmacro nnmaildir--flist-art (list file)
- `(symbol-value (intern-soft ,file ,list)))
+ `(gethash ,file ,list))
(defmacro nnmaildir--mlist-art (list msgid)
- `(symbol-value (intern-soft ,msgid ,list)))
+ `(gethash ,msgid ,list))
(defun nnmaildir--pgname (server gname)
(let ((prefix (nnmaildir--srv-prefix server)))
@@ -319,15 +319,15 @@ This variable is set by `nnmaildir-request-article'.")
(setq attr (file-attributes
(concat dir (number-to-string number-opened))))
(or attr (throw 'return (1- number-opened)))
- (setq ino-opened (nth 10 attr)
- nlink (nth 1 attr)
+ (setq ino-opened (file-attribute-inode-number attr)
+ nlink (file-attribute-link-number attr)
number-linked (+ number-opened nlink))
(if (or (< nlink 1) (< number-linked nlink))
(signal 'error '("Arithmetic overflow")))
(setq attr (file-attributes
(concat dir (number-to-string number-linked))))
(or attr (throw 'return (1- number-linked)))
- (unless (equal ino-opened (nth 10 attr))
+ (unless (equal ino-opened (file-attribute-inode-number attr))
(setq number-opened number-linked))))))
;; Make the given server, if non-nil, be the current server. Then make the
@@ -338,12 +338,12 @@ This variable is set by `nnmaildir-request-article'.")
(if (null server)
(unless (setq server nnmaildir--cur-server)
(throw 'return nil))
- (unless (setq server (intern-soft server nnmaildir--servers))
+ (unless (setq server (alist-get server nnmaildir--servers
+ nil nil #'equal))
(throw 'return nil))
- (setq server (symbol-value server)
- nnmaildir--cur-server server))
+ (setq nnmaildir--cur-server server))
(let ((groups (nnmaildir--srv-groups server)))
- (when groups
+ (when (and groups (null (hash-table-empty-p groups)))
(unless (nnmaildir--srv-method server)
(setf (nnmaildir--srv-method server)
(or (gnus-server-to-method
@@ -351,7 +351,7 @@ This variable is set by `nnmaildir-request-article'.")
(throw 'return nil))))
(if (null group)
(nnmaildir--srv-curgrp server)
- (symbol-value (intern-soft group groups)))))))
+ (gethash group groups))))))
(defun nnmaildir--tab-to-space (string)
(let ((pos 0))
@@ -393,8 +393,8 @@ This variable is set by `nnmaildir-request-article'.")
(setq make-new-file nil
previous-number-link 0))
(let* ((attr (file-attributes path-open))
- (nlink (nth 1 attr)))
- (setq ino-open (nth 10 attr)
+ (nlink (file-attribute-link-number attr)))
+ (setq ino-open (file-attribute-inode-number attr)
number-link (+ number-open nlink))
(if (or (< nlink 1) (< number-link nlink))
(signal 'error '("Arithmetic overflow"))))
@@ -413,7 +413,7 @@ This variable is set by `nnmaildir-request-article'.")
number-open number-link))
((nnmaildir--eexist-p err)
(let ((attr (file-attributes path-link)))
- (unless (equal (nth 10 attr) ino-open)
+ (unless (equal (file-attribute-inode-number attr) ino-open)
(setq number-open number-link
number-link 0))))
(t (signal (car err) (cdr err)))))))))
@@ -438,8 +438,8 @@ This variable is set by `nnmaildir-request-article'.")
(unless attr
(nnmaildir--expired-article group article)
(throw 'return nil))
- (setq mtime (nth 5 attr)
- attr (nth 7 attr)
+ (setq mtime (file-attribute-modification-time attr)
+ attr (file-attribute-size attr)
nov (nnmaildir--art-nov article)
dir (nnmaildir--nndir dir)
novdir (nnmaildir--nov-dir dir)
@@ -575,15 +575,15 @@ This variable is set by `nnmaildir-request-article'.")
(if insert-nlist
(setcdr nlist (cons (cons num article) nlist-cdr))
(setf (nnmaildir--grp-nlist group) nlist))
- (set (intern (nnmaildir--art-prefix article)
- (nnmaildir--grp-flist group))
- article)
- (set (intern (nnmaildir--art-msgid article)
- (nnmaildir--grp-mlist group))
- article)
- (set (intern (nnmaildir--grp-name group)
- (nnmaildir--srv-groups server))
- group))
+ (puthash (nnmaildir--art-prefix article)
+ article
+ (nnmaildir--grp-flist group))
+ (puthash (nnmaildir--art-msgid article)
+ article
+ (nnmaildir--grp-mlist group))
+ (puthash (nnmaildir--grp-name group)
+ group
+ (nnmaildir--srv-groups server)))
(nnmaildir--cache-nov group article nov)
t)))
@@ -651,9 +651,6 @@ This variable is set by `nnmaildir-request-article'.")
(if (< (car entry) low) (throw 'iterate-loop nil))
(funcall func (cdr entry)))))))
-(defun nnmaildir--up2-1 (n)
- (if (zerop n) 1 (1- (lsh 1 (1+ (logb n))))))
-
(defun nnmaildir--system-name ()
(replace-regexp-in-string
":" "\\072"
@@ -678,19 +675,20 @@ This variable is set by `nnmaildir-request-article'.")
(nnmaildir--srv-groups nnmaildir--cur-server)
t))
-(defun nnmaildir-open-server (server &optional defs)
- (let ((x server)
- dir size)
+(defun nnmaildir-open-server (server-string &optional defs)
+ (let ((server (alist-get server-string nnmaildir--servers
+ nil nil #'equal))
+ dir size x)
(catch 'return
- (setq server (intern-soft x nnmaildir--servers))
(if server
- (and (setq server (symbol-value server))
- (nnmaildir--srv-groups server)
+ (and (nnmaildir--srv-groups server)
(setq nnmaildir--cur-server server)
(throw 'return t))
- (setq server (make-nnmaildir--srv :address x))
+ (setq server (make-nnmaildir--srv :address server-string))
(let ((inhibit-quit t))
- (set (intern x nnmaildir--servers) server)))
+ (setf (alist-get server-string nnmaildir--servers
+ nil nil #'equal)
+ server)))
(setq dir (assq 'directory defs))
(unless dir
(setf (nnmaildir--srv-error server)
@@ -714,8 +712,7 @@ This variable is set by `nnmaildir-request-article'.")
(concat "Not a function: " (prin1-to-string x)))
(throw 'return nil)))
(setf (nnmaildir--srv-ls server) x)
- (setq size (length (funcall x dir nil "\\`[^.]" 'nosort))
- size (nnmaildir--up2-1 size))
+ (setq size (length (funcall x dir nil "\\`[^.]" 'nosort)))
(and (setq x (assq 'get-new-mail defs))
(setq x (cdr x))
(car x)
@@ -735,7 +732,8 @@ This variable is set by `nnmaildir-request-article'.")
x (file-name-as-directory x))
(setf (nnmaildir--srv-target-prefix server) x))
(setf (nnmaildir--srv-target-prefix server) "")))
- (setf (nnmaildir--srv-groups server) (make-vector size 0))
+ (setf (nnmaildir--srv-groups server)
+ (gnus-make-hashtable size))
(setq nnmaildir--cur-server server)
t)))
@@ -765,7 +763,7 @@ This variable is set by `nnmaildir-request-article'.")
(defun nnmaildir--scan (gname scan-msgs groups _method srv-dir srv-ls)
(catch 'return
- (let ((36h-ago (- (car (current-time)) 2))
+ (let ((36h-ago (time-since 129600))
absdir nndir tdir ndir cdir nattr cattr isnew pgname read-only ls
files num dir flist group x)
(setq absdir (nnmaildir--srvgrp-dir srv-dir gname)
@@ -795,29 +793,33 @@ This variable is set by `nnmaildir-request-article'.")
(setq read-only (nnmaildir--param pgname 'read-only)
ls (or (nnmaildir--param pgname 'directory-files) srv-ls))
(unless read-only
- (setq x (nth 11 (file-attributes tdir)))
- (unless (and (equal x (nth 11 nattr)) (equal x (nth 11 cattr)))
+ (setq x (file-attribute-device-number (file-attributes tdir)))
+ (unless (and (equal x (file-attribute-device-number nattr))
+ (equal x (file-attribute-device-number cattr)))
(setf (nnmaildir--srv-error nnmaildir--cur-server)
(concat "Maildir spans filesystems: " absdir))
(throw 'return nil))
(dolist (file (funcall ls tdir 'full "\\`[^.]" 'nosort))
(setq x (file-attributes file))
- (if (or (> (cadr x) 1) (< (car (nth 4 x)) 36h-ago))
+ (if (or (> (file-attribute-link-number x) 1)
+ (time-less-p (file-attribute-access-time x) 36h-ago))
(delete-file file))))
(or scan-msgs
isnew
(throw 'return t))
- (setq nattr (nth 5 nattr))
+ (setq nattr (file-attribute-modification-time nattr))
(if (equal nattr (nnmaildir--grp-new group))
(setq nattr nil))
(if read-only (setq dir (and (or isnew nattr) ndir))
(when (or isnew nattr)
(dolist (file (funcall ls ndir nil "\\`[^.]" 'nosort))
(setq x (concat ndir file))
- (and (time-less-p (nth 5 (file-attributes x)) (current-time))
+ (and (time-less-p (file-attribute-modification-time
+ (file-attributes x))
+ nil)
(rename-file x (concat cdir (nnmaildir--ensure-suffix file)))))
(setf (nnmaildir--grp-new group) nattr))
- (setq cattr (nth 5 (file-attributes cdir)))
+ (setq cattr (file-attribute-modification-time (file-attributes cdir)))
(if (equal cattr (nnmaildir--grp-cur group))
(setq cattr nil))
(setq dir (and (or isnew cattr) cdir)))
@@ -830,10 +832,10 @@ This variable is set by `nnmaildir-request-article'.")
(cons (match-string 1 f) (match-string 2 f)))
files)))
(when isnew
- (setq num (nnmaildir--up2-1 (length files)))
- (setf (nnmaildir--grp-flist group) (make-vector num 0))
- (setf (nnmaildir--grp-mlist group) (make-vector num 0))
- (setf (nnmaildir--grp-mmth group) (make-vector 1 0))
+ (setq num (length files))
+ (setf (nnmaildir--grp-flist group) (gnus-make-hashtable num))
+ (setf (nnmaildir--grp-mlist group) (gnus-make-hashtable num))
+ (setf (nnmaildir--grp-mmth group) (gnus-make-hashtable 1))
(setq num (nnmaildir--param pgname 'nov-cache-size))
(if (numberp num) (if (< num 1) (setq num 1))
(setq num 16
@@ -856,10 +858,10 @@ This variable is set by `nnmaildir-request-article'.")
;; then look in marks directories
(not (file-exists-p (concat cdir prefix)))
(file-exists-p (concat ndir prefix)))
- (incf num)))))
+ (cl-incf num)))))
(setf (nnmaildir--grp-cache group) (make-vector num nil))
(let ((inhibit-quit t))
- (set (intern gname groups) group))
+ (puthash gname group groups))
(or scan-msgs (throw 'return t)))
(setq flist (nnmaildir--grp-flist group)
files (mapcar
@@ -898,49 +900,46 @@ This variable is set by `nnmaildir-request-article'.")
groups (nnmaildir--srv-groups nnmaildir--cur-server)
target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server))
(nnmaildir--with-work-buffer
- (save-match-data
- (if (stringp scan-group)
- (if (nnmaildir--scan scan-group t groups method srv-dir srv-ls)
- (if (nnmaildir--srv-gnm nnmaildir--cur-server)
- (nnmail-get-new-mail 'nnmaildir nil nil scan-group))
- (unintern scan-group groups))
- (setq x (nth 5 (file-attributes srv-dir))
- scan-group (null scan-group))
- (if (equal x (nnmaildir--srv-mtime nnmaildir--cur-server))
- (if scan-group
- (mapatoms (lambda (sym)
- (nnmaildir--scan (symbol-name sym) t groups
- method srv-dir srv-ls))
- groups))
- (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort)
- dirs (if (zerop (length target-prefix))
- dirs
- (gnus-remove-if
- (lambda (dir)
- (and (>= (length dir) (length target-prefix))
- (string= (substring dir 0
- (length target-prefix))
- target-prefix)))
- dirs))
- seen (nnmaildir--up2-1 (length dirs))
- seen (make-vector seen 0))
- (dolist (grp-dir dirs)
- (if (nnmaildir--scan grp-dir scan-group groups method srv-dir
- srv-ls)
- (intern grp-dir seen)))
- (setq x nil)
- (mapatoms (lambda (group)
- (setq group (symbol-name group))
- (unless (intern-soft group seen)
- (setq x (cons group x))))
- groups)
- (dolist (grp x)
- (unintern grp groups))
- (setf (nnmaildir--srv-mtime nnmaildir--cur-server)
- (nth 5 (file-attributes srv-dir))))
- (and scan-group
- (nnmaildir--srv-gnm nnmaildir--cur-server)
- (nnmail-get-new-mail 'nnmaildir nil nil))))))
+ (save-match-data
+ (if (stringp scan-group)
+ (if (nnmaildir--scan scan-group t groups method srv-dir srv-ls)
+ (when (nnmaildir--srv-gnm nnmaildir--cur-server)
+ (nnmail-get-new-mail 'nnmaildir nil nil scan-group))
+ (remhash scan-group groups))
+ (setq x (file-attribute-modification-time (file-attributes srv-dir))
+ scan-group (null scan-group))
+ (if (equal x (nnmaildir--srv-mtime nnmaildir--cur-server))
+ (when scan-group
+ (maphash (lambda (group-name _group)
+ (nnmaildir--scan group-name t groups
+ method srv-dir srv-ls))
+ groups))
+ (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort)
+ dirs (if (zerop (length target-prefix))
+ dirs
+ (seq-remove
+ (lambda (dir)
+ (and (>= (length dir) (length target-prefix))
+ (string= (substring dir 0
+ (length target-prefix))
+ target-prefix)))
+ dirs)))
+ (dolist (grp-dir dirs)
+ (when (nnmaildir--scan grp-dir scan-group groups
+ method srv-dir srv-ls)
+ (push grp-dir seen)))
+ (setq x nil)
+ (maphash (lambda (gname _group)
+ (unless (member gname seen)
+ (push gname x)))
+ groups)
+ (dolist (grp x)
+ (remhash grp groups))
+ (setf (nnmaildir--srv-mtime nnmaildir--cur-server)
+ (file-attribute-modification-time (file-attributes srv-dir))))
+ (and scan-group
+ (nnmaildir--srv-gnm nnmaildir--cur-server)
+ (nnmail-get-new-mail 'nnmaildir nil nil))))))
t)
(defun nnmaildir-request-list (&optional server)
@@ -949,10 +948,9 @@ This variable is set by `nnmaildir-request-article'.")
(nnmaildir--prepare server nil)
(nnmaildir--with-nntp-buffer
(erase-buffer)
- (mapatoms (lambda (group)
- (setq pgname (symbol-name group)
- pgname (nnmaildir--pgname nnmaildir--cur-server pgname)
- group (symbol-value group)
+ (maphash (lambda (gname group)
+ (setq pgname (nnmaildir--pgname nnmaildir--cur-server gname)
+
ro (nnmaildir--param pgname 'read-only))
(insert (replace-regexp-in-string
" " "\\ "
@@ -994,7 +992,7 @@ This variable is set by `nnmaildir-request-article'.")
(curdir (nnmaildir--cur
(nnmaildir--srvgrp-dir
(nnmaildir--srv-dir nnmaildir--cur-server) gname)))
- (curdir-mtime (nth 5 (file-attributes curdir)))
+ (curdir-mtime (file-attribute-modification-time (file-attributes curdir)))
pgname flist always-marks never-marks old-marks dir
all-marks marks ranges markdir read ls
old-mmth new-mmth mtime existing missing deactivate-mark)
@@ -1032,8 +1030,7 @@ This variable is set by `nnmaildir-request-article'.")
(append
(mapcar 'cdr nnmaildir-flag-mark-mapping)
(mapcar 'intern (funcall ls dir nil "\\`[^.]" 'nosort))))
- new-mmth (nnmaildir--up2-1 (length all-marks))
- new-mmth (make-vector new-mmth 0)
+ new-mmth (make-hash-table :size (length all-marks))
old-mmth (nnmaildir--grp-mmth group))
(dolist (mark all-marks)
(setq markdir (nnmaildir--subdir dir (symbol-name mark))
@@ -1047,7 +1044,7 @@ This variable is set by `nnmaildir-request-article'.")
;; a filename flag, get the later of the mtimes for markdir and
;; curdir, otherwise only the markdir counts.
(setq mtime
- (let ((markdir-mtime (nth 5 (file-attributes markdir))))
+ (let ((markdir-mtime (file-attribute-modification-time (file-attributes markdir))))
(cond
((null (nnmaildir--mark-to-flag mark))
markdir-mtime)
@@ -1060,8 +1057,8 @@ This variable is set by `nnmaildir-request-article'.")
curdir-mtime)
(t
markdir-mtime))))
- (set (intern (symbol-name mark) new-mmth) mtime)
- (when (equal mtime (symbol-value (intern-soft (symbol-name mark) old-mmth)))
+ (puthash mark mtime new-mmth)
+ (when (equal mtime (gethash mark old-mmth))
(setq ranges (assq mark old-marks))
(if ranges (setq ranges (cdr ranges)))
(throw 'got-ranges nil))
@@ -1123,7 +1120,7 @@ This variable is set by `nnmaildir-request-article'.")
(nnmaildir--prepare server nil)
(catch 'return
(let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server))
- srv-dir dir groups)
+ srv-dir dir)
(when (zerop (length gname))
(setf (nnmaildir--srv-error nnmaildir--cur-server)
"Invalid (empty) group name")
@@ -1137,8 +1134,8 @@ This variable is set by `nnmaildir-request-article'.")
(concat "Invalid characters (null, tab, or /) in group name: "
gname))
(throw 'return nil))
- (setq groups (nnmaildir--srv-groups nnmaildir--cur-server))
- (when (intern-soft gname groups)
+ (when (gethash
+ gname (nnmaildir--srv-groups nnmaildir--cur-server))
(setf (nnmaildir--srv-error nnmaildir--cur-server)
(concat "Group already exists: " gname))
(throw 'return nil))
@@ -1183,7 +1180,7 @@ This variable is set by `nnmaildir-request-article'.")
new-name))
(throw 'return nil))
(if (string-equal gname new-name) (throw 'return t))
- (when (intern-soft new-name
+ (when (gethash new-name
(nnmaildir--srv-groups nnmaildir--cur-server))
(setf (nnmaildir--srv-error nnmaildir--cur-server)
(concat "Group already exists: " new-name))
@@ -1196,16 +1193,18 @@ This variable is set by `nnmaildir-request-article'.")
(setf (nnmaildir--srv-error nnmaildir--cur-server)
(concat "Error renaming link: " (prin1-to-string err)))
(throw 'return nil)))
+ ;; FIXME: Why are we making copies of the group and the groups
+ ;; hashtable? Why not just set the group's new name, and puthash the
+ ;; group under that new name?
(setq x (nnmaildir--srv-groups nnmaildir--cur-server)
- groups (make-vector (length x) 0))
- (mapatoms (lambda (sym)
- (unless (eq (symbol-value sym) group)
- (set (intern (symbol-name sym) groups)
- (symbol-value sym))))
+ groups (gnus-make-hashtable (hash-table-size x)))
+ (maphash (lambda (gname g)
+ (unless (eq g group)
+ (puthash gname g groups)))
x)
(setq group (copy-sequence group))
(setf (nnmaildir--grp-name group) new-name)
- (set (intern new-name groups) group)
+ (puthash new-name group groups)
(setf (nnmaildir--srv-groups nnmaildir--cur-server) groups)
t)))
@@ -1228,7 +1227,7 @@ This variable is set by `nnmaildir-request-article'.")
(throw 'return nil))
(if (eq group (nnmaildir--srv-curgrp nnmaildir--cur-server))
(setf (nnmaildir--srv-curgrp nnmaildir--cur-server) nil))
- (unintern gname (nnmaildir--srv-groups nnmaildir--cur-server))
+ (remhash gname (nnmaildir--srv-groups nnmaildir--cur-server))
(if (not force)
(progn
(setq grp-dir (directory-file-name grp-dir))
@@ -1329,10 +1328,9 @@ This variable is set by `nnmaildir-request-article'.")
article (nnmaildir--mlist-art list num-msgid))
(if article (setq num-msgid (nnmaildir--art-num article))
(catch 'found
- (mapatoms
- (lambda (group-sym)
- (setq group (symbol-value group-sym)
- list (nnmaildir--grp-mlist group)
+ (maphash
+ (lambda (_gname group)
+ (setq list (nnmaildir--grp-mlist group)
article (nnmaildir--mlist-art list num-msgid))
(when article
(setq num-msgid (nnmaildir--art-num article))
@@ -1464,9 +1462,7 @@ This variable is set by `nnmaildir-request-article'.")
(unless (string-equal nnmaildir--delivery-time file)
(setq nnmaildir--delivery-time file
nnmaildir--delivery-count 0))
- (when (and (consp (cdr time))
- (consp (cddr time)))
- (setq file (concat file "M" (number-to-string (caddr time)))))
+ (setq file (concat file (format-time-string "M%6N" time)))
(setq file (concat file nnmaildir--delivery-pid)
file (concat file "Q" (number-to-string nnmaildir--delivery-count))
file (concat file "." (nnmaildir--system-name))
@@ -1521,7 +1517,7 @@ This variable is set by `nnmaildir-request-article'.")
(setq groups (nnmaildir--srv-groups nnmaildir--cur-server)
ga (car group-art) group-art (cdr group-art)
gname (car ga))
- (or (intern-soft gname groups)
+ (or (gethash gname groups)
(nnmaildir-request-create-group gname)
(throw 'return nil)) ;; not that nnmail bothers to check :(
(unless (nnmaildir-request-accept-article gname)
@@ -1538,7 +1534,7 @@ This variable is set by `nnmaildir-request-article'.")
(mapcar
(lambda (ga)
(setq gname (car ga))
- (and (or (intern-soft gname groups)
+ (and (or (gethash gname groups)
(nnmaildir-request-create-group gname))
(nnmaildir-request-accept-article gname)
ga))
@@ -1552,7 +1548,7 @@ This variable is set by `nnmaildir-request-article'.")
(defun nnmaildir-request-expire-articles (ranges &optional gname server force)
(let ((no-force (not force))
(group (nnmaildir--prepare server gname))
- pgname time boundary bound-iter high low target dir nlist
+ pgname time boundary high low target dir nlist
didnt nnmaildir--file nnmaildir-article-file-name
deactivate-mark)
(catch 'return
@@ -1576,14 +1572,7 @@ This variable is set by `nnmaildir-request-article'.")
(when no-force
(unless (integerp time) ;; handle 'never
(throw 'return (gnus-uncompress-range ranges)))
- (setq boundary (current-time)
- high (- (car boundary) (/ time 65536))
- low (- (cadr boundary) (% time 65536)))
- (if (< low 0)
- (setq low (+ low 65536)
- high (1- high)))
- (setcar (cdr boundary) low)
- (setcar boundary high))
+ (setq boundary (time-since time)))
(setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
dir (nnmaildir--srvgrp-dir dir gname)
dir (nnmaildir--cur dir)
@@ -1601,15 +1590,8 @@ This variable is set by `nnmaildir-request-article'.")
((null time)
(nnmaildir--expired-article group article))
((and no-force
- (progn
- (setq time (nth 5 time)
- bound-iter boundary)
- (while (and bound-iter time
- (= (car bound-iter) (car time)))
- (setq bound-iter (cdr bound-iter)
- time (cdr time)))
- (and bound-iter time
- (car-less-than-car bound-iter time))))
+ (time-less-p boundary
+ (file-attribute-modification-time time)))
(setq didnt (cons (nnmaildir--art-num article) didnt)))
(t
(setq nnmaildir-article-file-name nnmaildir--file
@@ -1732,7 +1714,7 @@ This variable is set by `nnmaildir-request-article'.")
(setq ranges (car action)
todo-marks (caddr action))
(dolist (mark todo-marks)
- (pushnew mark all-marks :test #'equal))
+ (cl-pushnew mark all-marks :test #'equal))
(if (numberp (cdr ranges)) (setq ranges (list ranges)))
(nnmaildir--nlist-iterate nlist ranges
(cond ((eq 'del (cadr action)) del-action)
@@ -1762,39 +1744,38 @@ This variable is set by `nnmaildir-request-article'.")
(lambda (dir)
(cons dir (funcall ls dir nil "\\`[^.]" 'nosort)))
dirs)
- files (funcall ls msgdir nil "\\`[^.]" 'nosort)
- flist (nnmaildir--up2-1 (length files))
- flist (make-vector flist 0))
+ files (funcall ls msgdir nil "\\`[^.]" 'nosort))
(save-match-data
(dolist (file files)
(string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file)
- (intern (match-string 1 file) flist)))
+ (push (match-string 1 file) flist)))
(dolist (dir dirs)
(setq files (cdr dir)
dir (file-name-as-directory (car dir)))
(dolist (file files)
- (unless (or (intern-soft file flist) (string= file ":"))
+ (unless (or (member file flist) (string= file ":"))
(setq file (concat dir file))
(delete-file file))))
t)))
(defun nnmaildir-close-server (&optional server)
- (defvar flist) (defvar ls) (defvar dirs) (defvar dir)
- (defvar files) (defvar file) (defvar x)
- (let (flist ls dirs dir files file x)
- (nnmaildir--prepare server nil)
- (when nnmaildir--cur-server
- (setq server nnmaildir--cur-server
- nnmaildir--cur-server nil)
- (unintern (nnmaildir--srv-address server) nnmaildir--servers)))
+ "Close SERVER, or the current maildir server."
+ (when (nnmaildir--prepare server nil)
+ (setq server nnmaildir--cur-server
+ nnmaildir--cur-server nil)
+
+ ;; This slightly obscure invocation of `alist-get' removes SERVER from
+ ;; `nnmaildir-servers'.
+ (setf (alist-get (nnmaildir--srv-address server)
+ nnmaildir--servers server 'remove #'equal)
+ server))
t)
(defun nnmaildir-request-close ()
- (let (servers buffer)
- (mapatoms (lambda (server)
- (setq servers (cons (symbol-name server) servers)))
- nnmaildir--servers)
- (mapc 'nnmaildir-close-server servers)
+ (let ((servers
+ (mapcar #'car nnmaildir--servers))
+ buffer)
+ (mapc #'nnmaildir-close-server servers)
(setq buffer (get-buffer " *nnmaildir work*"))
(if buffer (kill-buffer buffer))
(setq buffer (get-buffer " *nnmaildir nov*"))
diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el
index 31c84bdc794..501ea1d3903 100644
--- a/lisp/gnus/nnmairix.el
+++ b/lisp/gnus/nnmairix.el
@@ -134,8 +134,6 @@
;;; Code:
-(eval-when-compile (require 'cl)) ;For (pop (cdr ogroup)).
-
(require 'nnoo)
(require 'gnus-group)
(require 'gnus-sum)
@@ -1776,7 +1774,7 @@ If VERSION is a string: must be contained in mairix version output."
(setq versionstring
(let* ((commandsplit (split-string nnmairix-mairix-command))
(args (append (list (car commandsplit))
- `(nil t nil) (cdr commandsplit) '("-V"))))
+ '(nil t nil) (cdr commandsplit) '("-V"))))
(apply 'call-process args)
(goto-char (point-min))
(re-search-forward "mairix.*")
diff --git a/lisp/gnus/nnmbox.el b/lisp/gnus/nnmbox.el
index 843a8df5af8..bba41336dd9 100644
--- a/lisp/gnus/nnmbox.el
+++ b/lisp/gnus/nnmbox.el
@@ -33,7 +33,6 @@
(require 'nnmail)
(require 'nnoo)
(require 'gnus-range)
-(eval-when-compile (require 'cl))
(nnoo-declare nnmbox)
diff --git a/lisp/gnus/nnmh.el b/lisp/gnus/nnmh.el
index a9cc1505184..f4b36dc007f 100644
--- a/lisp/gnus/nnmh.el
+++ b/lisp/gnus/nnmh.el
@@ -33,7 +33,6 @@
(require 'nnmail)
(require 'gnus-start)
(require 'nnoo)
-(eval-when-compile (require 'cl))
(nnoo-declare nnmh)
@@ -211,8 +210,10 @@ as unread by Gnus.")
min rdir num subdirectoriesp file)
;; Recurse down directories.
(setq subdirectoriesp
- ;; nth 1 of file-attributes always 1 on MS Windows :(
- (/= (nth 1 (file-attributes (file-truename dir))) 2))
+ ;; link number always 1 on MS Windows :(
+ (/= (file-attribute-link-number
+ (file-attributes (file-truename dir)))
+ 2))
(dolist (rdir files)
(if (or (not subdirectoriesp)
(file-regular-p rdir))
@@ -242,12 +243,11 @@ as unread by Gnus.")
(file-truename (file-name-as-directory
(expand-file-name nnmh-toplev))))
dir)
- (string-to-multibyte ;Why? Isn't it multibyte already?
- (encode-coding-string
- (nnheader-replace-chars-in-string
- (substring dir (match-end 0))
- ?/ ?.)
- nnmail-pathname-coding-system)))
+ (encode-coding-string
+ (nnheader-replace-chars-in-string
+ (substring dir (match-end 0))
+ ?/ ?.)
+ nnmail-pathname-coding-system))
(or max 0)
(or min 1))))))
t)
@@ -265,7 +265,8 @@ as unread by Gnus.")
(while (and articles is-old)
(setq article (concat dir (int-to-string (car articles))))
- (when (setq mod-time (nth 5 (file-attributes article)))
+ (when (setq mod-time (file-attribute-modification-time
+ (file-attributes article)))
(if (and (nnmh-deletable-article-p newsgroup (car articles))
(setq is-old
(nnmail-expired-article-p newsgroup mod-time force)))
@@ -536,8 +537,8 @@ as unread by Gnus.")
art)
(while (setq art (pop arts))
(when (not (equal
- (nth 5 (file-attributes
- (concat dir (int-to-string (car art)))))
+ (file-attribute-modification-time
+ (file-attributes (concat dir (int-to-string (car art)))))
(cdr art)))
(setq articles (delq art articles))
(push (car art) new))))
@@ -548,8 +549,9 @@ as unread by Gnus.")
(mapcar
(lambda (art)
(cons art
- (nth 5 (file-attributes
- (concat dir (int-to-string art))))))
+ (file-attribute-modification-time
+ (file-attributes
+ (concat dir (int-to-string art))))))
new)))
;; Make Gnus mark all new articles as unread.
(when new
diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el
index fc68f8b5130..205e9e48034 100644
--- a/lisp/gnus/nnml.el
+++ b/lisp/gnus/nnml.el
@@ -35,7 +35,6 @@
(require 'nnheader)
(require 'nnmail)
(require 'nnoo)
-(eval-when-compile (require 'cl))
;; FIXME first is unused in this file.
(autoload 'gnus-article-unpropagatable-p "gnus-sum")
@@ -260,7 +259,7 @@ non-nil.")
(t
(nnheader-re-read-dir nnml-current-directory)
(nnmail-activate 'nnml)
- (let ((active (nth 1 (assoc group nnml-group-alist))))
+ (let ((active (nth 1 (assoc-string group nnml-group-alist))))
(if (not active)
(nnheader-report 'nnml "No such group: %s" decoded)
(nnheader-report 'nnml "Selected group %s" decoded)
@@ -296,7 +295,7 @@ non-nil.")
(nnheader-report 'nnml "%s is a file"
(directory-file-name (nnml-group-pathname group
nil server))))
- ((assoc group nnml-group-alist)
+ ((assoc-string group nnml-group-alist)
t)
(t
(let (active)
@@ -345,7 +344,8 @@ non-nil.")
(while (and articles is-old)
(if (and (setq article (nnml-article-to-file
(setq number (pop articles))))
- (setq mod-time (nth 5 (file-attributes article)))
+ (setq mod-time (file-attribute-modification-time
+ (file-attributes article)))
(nnml-deletable-article-p group number)
(setq is-old (nnmail-expired-article-p group mod-time force
nnml-inhibit-expiry)))
@@ -379,7 +379,7 @@ non-nil.")
(nnml-nov-delete-article group number))
(push number rest)))
(push number rest)))
- (let ((active (nth 1 (assoc group nnml-group-alist))))
+ (let ((active (nth 1 (assoc-string group nnml-group-alist))))
(when active
(setcar active (or (and active-articles
(apply 'min active-articles))
@@ -520,7 +520,7 @@ non-nil.")
(nnheader-report 'nnml "No such directory: %s/" file))
;; Remove the group from all structures.
(setq nnml-group-alist
- (delq (assoc group nnml-group-alist) nnml-group-alist)
+ (delq (assoc-string group nnml-group-alist) nnml-group-alist)
nnml-current-group nil
nnml-current-directory nil)
;; Save the active file.
@@ -549,7 +549,7 @@ non-nil.")
(when (<= (length (directory-files old-dir)) 2)
(ignore-errors (delete-directory old-dir)))
;; That went ok, so we change the internal structures.
- (let ((entry (assoc group nnml-group-alist)))
+ (let ((entry (assoc-string group nnml-group-alist)))
(when entry
(setcar entry new-name))
(setq nnml-current-directory nil
@@ -597,7 +597,7 @@ non-nil.")
(when (setq path (nnml-article-to-file article))
(when (file-writable-p path)
(or (not nnmail-keep-last-article)
- (not (eq (cdr (nth 1 (assoc group nnml-group-alist)))
+ (not (eq (cdr (nth 1 (assoc-string group nnml-group-alist)))
article)))))))
;; Find an article number in the current group given the Message-ID.
@@ -742,7 +742,7 @@ article number. This function is called narrowed to an article."
"Compute the next article number in GROUP on SERVER."
(let* ((encoded (if nnmail-group-names-not-encoded-p
(nnml-encoded-group-name group server)))
- (active (cadr (assoc (or encoded group) nnml-group-alist))))
+ (active (cadr (assoc-string (or encoded group) nnml-group-alist))))
;; The group wasn't known to nnml, so we just create an active
;; entry for it.
(unless active
@@ -783,7 +783,7 @@ article number. This function is called narrowed to an article."
(cdr nnml-incremental-nov-buffer-alist)))))
(defun nnml-open-incremental-nov (group)
- (or (cdr (assoc group nnml-incremental-nov-buffer-alist))
+ (or (cdr (assoc-string group nnml-incremental-nov-buffer-alist))
(let ((buffer (nnml-get-nov-buffer group t)))
(push (cons group buffer) nnml-incremental-nov-buffer-alist)
buffer)))
diff --git a/lisp/gnus/nnoo.el b/lisp/gnus/nnoo.el
index 143c69d5363..0cf2362b36a 100644
--- a/lisp/gnus/nnoo.el
+++ b/lisp/gnus/nnoo.el
@@ -25,7 +25,7 @@
;;; Code:
(require 'nnheader)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defvar nnoo-definition-alist nil)
(defvar nnoo-state-alist nil)
@@ -142,7 +142,7 @@
(if (numberp (nth i (cdr m)))
(push `(nth ,i args) margs)
(push (nth i (cdr m)) margs))
- (incf i))
+ (cl-incf i))
(eval `(deffoo ,(nnoo-symbol backend (nnoo-rest-symbol (car m)))
(&rest args)
(nnoo-parent-function ',backend ',(car m)
diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el
index 01cf7c08c98..0bfecb28e09 100644
--- a/lisp/gnus/nnrss.el
+++ b/lisp/gnus/nnrss.el
@@ -24,7 +24,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'gnus)
(require 'nnoo)
@@ -49,7 +49,7 @@
"Where nnrss will save its files.")
(defvoo nnrss-ignore-article-fields '(slash:comments)
- "*List of fields that should be ignored when comparing RSS articles.
+ "List of fields that should be ignored when comparing RSS articles.
Some RSS feeds update article fields during their lives, e.g. to
indicate the number of comments or the number of times the
articles have been seen. However, if there is a difference
@@ -340,10 +340,10 @@ for decoding when the cdr that the data specify is not available.")
(let (elem)
;; There may be two or more entries in `nnrss-group-alist' since
;; this function didn't delete them formerly.
- (while (setq elem (assoc group nnrss-group-alist))
+ (while (setq elem (assoc-string group nnrss-group-alist))
(setq nnrss-group-alist (delq elem nnrss-group-alist))))
(setq nnrss-server-data
- (delq (assoc group nnrss-server-data) nnrss-server-data))
+ (delq (assoc-string group nnrss-server-data) nnrss-server-data))
(nnrss-save-server-data server)
(ignore-errors
(let ((file-name-coding-system nnmail-pathname-coding-system))
@@ -355,8 +355,8 @@ for decoding when the cdr that the data specify is not available.")
(with-current-buffer nntp-server-buffer
(erase-buffer)
(dolist (elem nnrss-group-alist)
- (if (third elem)
- (insert (car elem) "\t" (third elem) "\n"))))
+ (if (nth 2 elem)
+ (insert (car elem) "\t" (nth 2 elem) "\n"))))
t)
(deffoo nnrss-retrieve-groups (groups &optional server)
@@ -367,7 +367,7 @@ for decoding when the cdr that the data specify is not available.")
(with-current-buffer nntp-server-buffer
(erase-buffer)
(dolist (group groups)
- (let ((elem (assoc (gnus-group-decoded-name group) nnrss-server-data)))
+ (let ((elem (assoc-string (gnus-group-decoded-name group) nnrss-server-data)))
(insert (format "%S %s 1 y\n" group (or (cadr elem) 0)))))
'active))
@@ -454,7 +454,7 @@ which RSS 2.0 allows."
(cond ((null date)) ; do nothing for this case
;; if the date is just digits (unix time stamp):
((string-match "^[0-9]+$" date)
- (setq given (seconds-to-time (string-to-number date))))
+ (setq given (encode-time (string-to-number date))))
;; RFC 822
((string-match " [0-9]+ " date)
(setq vector (timezone-parse-date date)
@@ -539,7 +539,7 @@ which RSS 2.0 allows."
(if (hash-table-p nnrss-group-hashtb)
(clrhash nnrss-group-hashtb)
(setq nnrss-group-hashtb (make-hash-table :test 'equal)))
- (let ((pair (assoc group nnrss-server-data)))
+ (let ((pair (assoc-string group nnrss-server-data)))
(setq nnrss-group-max (or (cadr pair) 0))
(setq nnrss-group-min (+ nnrss-group-max 1)))
(let ((file (nnrss-make-filename group server))
@@ -625,7 +625,7 @@ which RSS 2.0 allows."
;;; Snarf functions
(defun nnrss-make-hash-index (item)
(gnus-message 9 "nnrss: Making hash index of %s" (gnus-prin1-to-string item))
- (setq item (gnus-remove-if
+ (setq item (seq-remove
(lambda (field)
(when (listp field)
(memq (car field) nnrss-ignore-article-fields)))
@@ -644,8 +644,8 @@ which RSS 2.0 allows."
(concat group ".xml"))
nnrss-directory))))
(setq xml (nnrss-fetch file t))
- (setq url (or (nth 2 (assoc group nnrss-server-data))
- (second (assoc group nnrss-group-alist))))
+ (setq url (or (nth 2 (assoc-string group nnrss-server-data))
+ (cadr (assoc-string group nnrss-group-alist))))
(unless url
(setq url
(cdr
@@ -653,7 +653,7 @@ which RSS 2.0 allows."
(nnrss-discover-feed
(read-string
(format "URL to search for %s: " group) "http://")))))
- (let ((pair (assoc group nnrss-server-data)))
+ (let ((pair (assoc-string group nnrss-server-data)))
(if pair
(setcdr (cdr pair) (list url))
(push (list group nnrss-group-max url) nnrss-server-data)))
@@ -691,7 +691,7 @@ which RSS 2.0 allows."
(if (and len (integerp (setq len (string-to-number len))))
;; actually already in `ls-lisp-format-file-size' but
;; probably not worth to require it for one function
- (do ((size (/ len 1.0) (/ size 1024.0))
+ (cl-do ((size (/ len 1.0) (/ size 1024.0))
(post-fixes (list "" "k" "M" "G" "T" "P" "E")
(cdr post-fixes)))
((< size 1024)
@@ -705,7 +705,7 @@ which RSS 2.0 allows."
(setq enclosure (list url name len type))))
(push
(list
- (incf nnrss-group-max)
+ (cl-incf nnrss-group-max)
(current-time)
url
(and subject (nnrss-mime-encode-string subject))
@@ -721,7 +721,7 @@ which RSS 2.0 allows."
(setq extra nil))
(when changed
(nnrss-save-group-data group server)
- (let ((pair (assoc group nnrss-server-data)))
+ (let ((pair (assoc-string group nnrss-server-data)))
(if pair
(setcar (cdr pair) nnrss-group-max)
(push (list group nnrss-group-max) nnrss-server-data)))
@@ -792,7 +792,7 @@ It is useful when `(setq nnrss-use-local t)'."
(insert "RSSDIR='" (expand-file-name nnrss-directory) "'\n")
(dolist (elem nnrss-server-data)
(let ((url (or (nth 2 elem)
- (second (assoc (car elem) nnrss-group-alist)))))
+ (cadr (assoc-string (car elem) nnrss-group-alist)))))
(insert "$WGET -q -O \"$RSSDIR\"/'"
(nnrss-translate-file-chars (concat (car elem) ".xml"))
"' '" url "'\n"))))
diff --git a/lisp/gnus/nnspool.el b/lisp/gnus/nnspool.el
index 30bc466ad43..767631c6859 100644
--- a/lisp/gnus/nnspool.el
+++ b/lisp/gnus/nnspool.el
@@ -29,17 +29,17 @@
(require 'nnheader)
(require 'nntp)
(require 'nnoo)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
;; Probably this entire thing should be obsolete.
;; It's only used to init nnspool-spool-directory, so why not just
;; set that variable's default directly?
(eval-and-compile
+ (defvaralias 'news-path 'news-directory)
(defvar news-directory (if (file-exists-p "/usr/spool/news/")
"/usr/spool/news/"
"/var/spool/news/")
- "The root directory below which all news files are stored.")
- (defvaralias 'news-path 'news-directory))
+ "The root directory below which all news files are stored."))
;; Ditto re obsolescence.
(defvar news-inews-program
@@ -105,7 +105,7 @@ If nil, nnspool will load the entire file into a buffer and process it
there.")
(defvoo nnspool-rejected-article-hook nil
- "*A hook that will be run when an article has been rejected by the server.")
+ "A hook that will be run when an article has been rejected by the server.")
(defvoo nnspool-file-coding-system nnheader-file-coding-system
"Coding system for nnspool.")
@@ -172,7 +172,7 @@ there.")
(delete-region (point) (point-max)))
(and do-message
- (zerop (% (incf count) 20))
+ (zerop (% (cl-incf count) 20))
(nnheader-message 5 "nnspool: Receiving headers... %d%%"
(floor (* count 100.0) number))))
@@ -305,25 +305,18 @@ there.")
(while (and (not (looking-at
"\\([^ ]+\\) +\\([0-9]+\\)[0-9][0-9][0-9] "))
(zerop (forward-line -1))))
- ;; We require nnheader which requires gnus-util.
- (let ((seconds (float-time (date-to-time date)))
+ (let ((seconds (encode-time (date-to-time date) 'integer))
groups)
;; Go through lines and add the latest groups to a list.
(while (and (looking-at "\\([^ ]+\\) +[0-9]+ ")
(progn
- ;; We insert a .0 to make the list reader
- ;; interpret the number as a float. It is far
- ;; too big to be stored in a lisp integer.
- (goto-char (1- (match-end 0)))
- (insert ".0")
- (> (progn
- (goto-char (match-end 1))
- (read (current-buffer)))
- seconds))
- (push (buffer-substring
- (match-beginning 1) (match-end 1))
- groups)
- (zerop (forward-line -1))))
+ (goto-char (match-end 1))
+ (< seconds (read (current-buffer))))
+ (progn
+ (push (buffer-substring
+ (match-beginning 1) (match-end 1))
+ groups)
+ (zerop (forward-line -1)))))
(erase-buffer)
(dolist (group groups)
(insert group " 0 0 y\n")))
diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el
index cbd0e85e694..e2fa1d85a36 100644
--- a/lisp/gnus/nntp.el
+++ b/lisp/gnus/nntp.el
@@ -33,7 +33,7 @@
(nnoo-declare nntp)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(autoload 'auth-source-search "auth-source")
@@ -48,7 +48,7 @@
"Port number on the physical nntp server.")
(defvoo nntp-server-opened-hook '(nntp-send-mode-reader)
- "*Hook used for sending commands to the server at startup.
+ "Hook used for sending commands to the server at startup.
The default value is `nntp-send-mode-reader', which makes an innd
server spawn an nnrpd server.")
@@ -94,7 +94,7 @@ For indirect connections:
- `nntp-open-via-telnet-and-telnet'")
(defvoo nntp-never-echoes-commands nil
- "*Non-nil means the nntp server never echoes commands.
+ "Non-nil means the nntp server never echoes commands.
It is reported that some nntps server doesn't echo commands. So, you
may want to set this to non-nil in the method for such a server setting
`nntp-open-connection-function' to `nntp-open-ssl-stream' for example.
@@ -103,102 +103,102 @@ variable overrides the nil value of this variable.")
(defvoo nntp-open-connection-functions-never-echo-commands
'(nntp-open-network-stream)
- "*List of functions that never echo commands.
+ "List of functions that never echo commands.
Add or set a function which you set to `nntp-open-connection-function'
to this list if it does not echo commands. Note that a non-nil value
of the `nntp-never-echoes-commands' variable overrides this variable.")
(defvoo nntp-pre-command nil
- "*Pre-command to use with the various nntp-open-via-* methods.
+ "Pre-command to use with the various nntp-open-via-* methods.
This is where you would put \"runsocks\" or stuff like that.")
(defvoo nntp-telnet-command "telnet"
- "*Telnet command used to connect to the nntp server.
+ "Telnet command used to connect to the nntp server.
This command is used by the methods `nntp-open-telnet-stream',
`nntp-open-via-rlogin-and-telnet' and `nntp-open-via-telnet-and-telnet'.")
(defvoo nntp-telnet-switches '("-8")
- "*Switches given to the telnet command `nntp-telnet-command'.")
+ "Switches given to the telnet command `nntp-telnet-command'.")
(defvoo nntp-end-of-line "\r\n"
- "*String to use on the end of lines when talking to the NNTP server.
+ "String to use on the end of lines when talking to the NNTP server.
This is \"\\r\\n\" by default, but should be \"\\n\" when using an indirect
connection method (nntp-open-via-*).")
(defvoo nntp-via-rlogin-command "rsh"
- "*Rlogin command used to connect to an intermediate host.
+ "Rlogin command used to connect to an intermediate host.
This command is used by the methods `nntp-open-via-rlogin-and-telnet'
and `nntp-open-via-rlogin-and-netcat'. The default is \"rsh\", but \"ssh\"
is a popular alternative.")
(defvoo nntp-via-rlogin-command-switches nil
- "*Switches given to the rlogin command `nntp-via-rlogin-command'.
+ "Switches given to the rlogin command `nntp-via-rlogin-command'.
If you use \"ssh\" for `nntp-via-rlogin-command', you may set this to
\(\"-C\") in order to compress all data connections, otherwise set this
to \(\"-t\" \"-e\" \"none\") or (\"-C\" \"-t\" \"-e\" \"none\") if the telnet
command requires a pseudo-tty allocation on an intermediate host.")
(defvoo nntp-via-telnet-command "telnet"
- "*Telnet command used to connect to an intermediate host.
+ "Telnet command used to connect to an intermediate host.
This command is used by the `nntp-open-via-telnet-and-telnet' method.")
(defvoo nntp-via-telnet-switches '("-8")
- "*Switches given to the telnet command `nntp-via-telnet-command'.")
+ "Switches given to the telnet command `nntp-via-telnet-command'.")
(defvoo nntp-netcat-command "nc"
- "*Netcat command used to connect to the nntp server.
+ "Netcat command used to connect to the nntp server.
This command is used by the `nntp-open-netcat-stream' and
`nntp-open-via-rlogin-and-netcat' methods.")
(defvoo nntp-netcat-switches nil
- "*Switches given to the netcat command `nntp-netcat-command'.")
+ "Switches given to the netcat command `nntp-netcat-command'.")
(defvoo nntp-via-user-name nil
- "*User name to log in on an intermediate host with.
+ "User name to log in on an intermediate host with.
This variable is used by the various nntp-open-via-* methods.")
(defvoo nntp-via-user-password nil
- "*Password to use to log in on an intermediate host with.
+ "Password to use to log in on an intermediate host with.
This variable is used by the `nntp-open-via-telnet-and-telnet' method.")
(defvoo nntp-via-address nil
- "*Address of an intermediate host to connect to.
+ "Address of an intermediate host to connect to.
This variable is used by the various nntp-open-via-* methods.")
(defvoo nntp-via-envuser nil
- "*Whether both telnet client and server support the ENVIRON option.
+ "Whether both telnet client and server support the ENVIRON option.
If non-nil, there will be no prompt for a login name.")
(defvoo nntp-via-shell-prompt "bash\\|[$>] *\r?$"
- "*Regular expression to match the shell prompt on an intermediate host.
+ "Regular expression to match the shell prompt on an intermediate host.
This variable is used by the `nntp-open-via-telnet-and-telnet' method.")
(defvoo nntp-large-newsgroup 50
- "*The number of articles which indicates a large newsgroup.
+ "The number of articles which indicates a large newsgroup.
If the number of articles is greater than the value, verbose
messages will be shown to indicate the current status.")
(defvoo nntp-maximum-request 400
- "*The maximum number of the requests sent to the NNTP server at one time.
+ "The maximum number of the requests sent to the NNTP server at one time.
If Emacs hangs up while retrieving headers, set the variable to a
lower value.")
(defvoo nntp-nov-is-evil nil
- "*If non-nil, nntp will never attempt to use XOVER when talking to the server.")
+ "If non-nil, nntp will never attempt to use XOVER when talking to the server.")
(defvoo nntp-xover-commands '("XOVER" "XOVERVIEW")
- "*List of strings that are used as commands to fetch NOV lines from a server.
+ "List of strings that are used as commands to fetch NOV lines from a server.
The strings are tried in turn until a positive response is gotten. If
none of the commands are successful, nntp will just grab headers one
by one.")
(defvoo nntp-nov-gap 5
- "*Maximum allowed gap between two articles.
+ "Maximum allowed gap between two articles.
If the gap between two consecutive articles is bigger than this
variable, split the XOVER request into two requests.")
(defvoo nntp-xref-number-is-evil nil
- "*If non-nil, Gnus never trusts article numbers in the Xref header.
+ "If non-nil, Gnus never trusts article numbers in the Xref header.
Some news servers, e.g., ones running Diablo, run multiple engines
having the same articles but article numbers are not kept synchronized
between them. If you connect to such a server, set this to a non-nil
@@ -206,7 +206,7 @@ value, and Gnus never uses article numbers (that appear in the Xref
header and vary by which engine is chosen) to refer to articles.")
(defvoo nntp-prepare-server-hook nil
- "*Hook run before a server is opened.
+ "Hook run before a server is opened.
If can be used to set up a server remotely, for instance. Say you
have an account at the machine \"other.machine\". This machine has
access to an NNTP server that you can't access locally. You could
@@ -237,11 +237,11 @@ server there that you can connect to. See also
(defvoo nntp-connection-timeout nil
- "*Number of seconds to wait before an nntp connection times out.
+ "Number of seconds to wait before an nntp connection times out.
If this variable is nil, which is the default, no timers are set.")
(defvoo nntp-prepare-post-hook nil
- "*Hook run just before posting an article. It is supposed to be used
+ "Hook run just before posting an article. It is supposed to be used
to insert Cancel-Lock headers.")
(defvoo nntp-server-list-active-group 'try
@@ -342,9 +342,7 @@ retried once before actually displaying the error report."
`(let ((string (buffer-substring ,start ,end)))
(with-current-buffer ,buffer
(erase-buffer)
- (insert (if enable-multibyte-characters
- (string-to-multibyte string)
- string))
+ (insert string)
(goto-char (point-min))
nil)))
@@ -565,7 +563,7 @@ retried once before actually displaying the error report."
(nntp-find-connection-buffer nntp-server-buffer)))
(nntp-encode-text)
;; Make sure we did not forget to encode some of the content.
- (assert (save-excursion (goto-char (point-min))
+ (cl-assert (save-excursion (goto-char (point-min))
(not (re-search-forward "[^\000-\377]" nil t))))
(mm-disable-multibyte)
(process-send-region (nntp-find-connection nntp-server-buffer)
@@ -701,7 +699,7 @@ command whose response triggered the error."
;; `articles' is either a list of article numbers
;; or a list of article IDs.
article))
- (incf count)
+ (cl-incf count)
;; Every 400 requests we have to read the stream in
;; order to avoid deadlocks.
(when (or (null articles) ;All requests have been sent.
@@ -713,7 +711,7 @@ command whose response triggered the error."
;; Count replies.
(while (nntp-next-result-arrived-p)
(setq last-point (point))
- (incf received))
+ (cl-incf received))
(< received count))
;; If number of headers is greater than 100, give
;; informative messages.
@@ -786,7 +784,7 @@ command whose response triggered the error."
"^[.]"
"^[0-9]")
nil t)
- (incf received))
+ (cl-incf received))
(setq last-point (point))
(< received count)))
(nntp-accept-response))
@@ -851,7 +849,7 @@ command whose response triggered the error."
(throw 'done nil))
;; Send the command to the server.
(nntp-send-command nil command (pop groups))
- (incf count)
+ (cl-incf count)
;; Every 400 requests we have to read the stream in
;; order to avoid deadlocks.
(when (or (null groups) ;All requests have been sent.
@@ -865,7 +863,7 @@ command whose response triggered the error."
(goto-char last-point)
;; Count replies.
(while (re-search-forward "^[0-9]" nil t)
- (incf received))
+ (cl-incf received))
(setq last-point (point))
(< received count)))
(nntp-accept-response))))
@@ -937,7 +935,7 @@ command whose response triggered the error."
;; `articles' is either a list of article numbers
;; or a list of article IDs.
article))
- (incf count)
+ (cl-incf count)
;; Every 400 requests we have to read the stream in
;; order to avoid deadlocks.
(when (or (null articles) ;All requests have been sent.
@@ -950,7 +948,7 @@ command whose response triggered the error."
(while (nntp-next-result-arrived-p)
(aset map received (cons (aref map received) (point)))
(setq last-point (point))
- (incf received))
+ (cl-incf received))
(< received count))
;; If number of headers is greater than 100, give
;; informative messages.
@@ -1572,7 +1570,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the
;; Count replies.
(while (re-search-forward "^\\([0-9][0-9][0-9]\\) .*\n"
nil t)
- (incf received)
+ (cl-incf received)
(setq status (match-string 1))
(if (string-match "^[45]" status)
(setq status 'error)
@@ -1743,26 +1741,26 @@ If SEND-IF-FORCE, only send authinfo to the server if the
;; ==========================================================================
(defvoo nntp-open-telnet-envuser nil
- "*If non-nil, telnet session (client and server both) will support the ENVIRON option and not prompt for login name.")
+ "If non-nil, telnet session (client and server both) will support the ENVIRON option and not prompt for login name.")
(defvoo nntp-telnet-shell-prompt "bash\\|[$>] *\r?$"
- "*Regular expression to match the shell prompt on the remote machine.")
+ "Regular expression to match the shell prompt on the remote machine.")
(defvoo nntp-rlogin-program "rsh"
- "*Program used to log in on remote machines.
+ "Program used to log in on remote machines.
The default is \"rsh\", but \"ssh\" is a popular alternative.")
(defvoo nntp-rlogin-parameters '("telnet" "-8" "${NNTPSERVER:=news}" "nntp")
- "*Parameters to `nntp-open-rlogin'.
+ "Parameters to `nntp-open-rlogin'.
That function may be used as `nntp-open-connection-function'. In that
case, this list will be used as the parameter list given to rsh.")
(defvoo nntp-rlogin-user-name nil
- "*User name on remote system when using the rlogin connect method.")
+ "User name on remote system when using the rlogin connect method.")
(defvoo nntp-telnet-parameters
'("exec" "telnet" "-8" "${NNTPSERVER:=news}" "nntp")
- "*Parameters to `nntp-open-telnet'.
+ "Parameters to `nntp-open-telnet'.
That function may be used as `nntp-open-connection-function'. In that
case, this list will be executed as a command after logging in
via telnet.")
diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el
index 310ab9425a6..c80bbf61875 100644
--- a/lisp/gnus/nnvirtual.el
+++ b/lisp/gnus/nnvirtual.el
@@ -38,7 +38,7 @@
(require 'gnus-start)
(require 'gnus-sum)
(require 'gnus-msg)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(nnoo-declare nnvirtual)
@@ -234,14 +234,12 @@ component group will show up when you enter the virtual group.")
nnvirtual-mapping-marks nil
nnvirtual-info-installed nil)
(when nnvirtual-component-regexp
- ;; Go through the newsrc alist and find all component groups.
- (let ((newsrc (cdr gnus-newsrc-alist))
- group)
- (while (setq group (car (pop newsrc)))
- (when (string-match nnvirtual-component-regexp group) ; Match
- ;; Add this group to the list of component groups.
- (setq nnvirtual-component-groups
- (cons group (delete group nnvirtual-component-groups)))))))
+ ;; Go through the list of groups and find all component groups.
+ (dolist (group (cdr gnus-group-list))
+ (when (string-match nnvirtual-component-regexp group) ; Match
+ ;; Add this group to the list of component groups.
+ (setq nnvirtual-component-groups
+ (cons group (delete group nnvirtual-component-groups))))))
(if (not nnvirtual-component-groups)
(nnheader-report 'nnvirtual "No component groups: %s" server)
t)))
@@ -372,7 +370,7 @@ component group will show up when you enter the virtual group.")
(defun nnvirtual-convert-headers ()
"Convert HEAD headers into NOV headers."
(with-current-buffer nntp-server-buffer
- (let* ((dependencies (make-vector 100 0))
+ (let* ((dependencies (make-hash-table :test #'equal))
(headers (gnus-get-newsgroup-headers dependencies)))
(erase-buffer)
(mapc 'nnheader-insert-nov headers))))
@@ -774,13 +772,13 @@ based on the marks on the component groups."
;; We need to convert the unreads to reads. We compress the
;; sequence as we go, otherwise it could be huge.
- (while (and (<= (incf i) nnvirtual-mapping-len)
+ (while (and (<= (cl-incf i) nnvirtual-mapping-len)
unreads)
(if (= i (car unreads))
(setq unreads (cdr unreads))
;; try to get a range.
(setq beg i)
- (while (and (<= (incf i) nnvirtual-mapping-len)
+ (while (and (<= (cl-incf i) nnvirtual-mapping-len)
(not (= i (car unreads)))))
(setq i (- i 1))
(if (= i beg)
diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el
index cbef67ee1de..7b87502d0e0 100644
--- a/lisp/gnus/nnweb.el
+++ b/lisp/gnus/nnweb.el
@@ -24,7 +24,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'nnoo)
(require 'message)
@@ -33,9 +33,7 @@
(require 'nnmail)
(require 'mm-util)
(require 'mm-url)
-(eval-and-compile
- (ignore-errors
- (require 'url)))
+(require 'url)
(nnoo-declare nnweb)
@@ -111,7 +109,7 @@ Valid types include `google', `dejanews', and `gmane'.")
(deffoo nnweb-request-scan (&optional group server)
(nnweb-possibly-change-server group server)
(if nnweb-ephemeral-p
- (setq nnweb-hashtb (gnus-make-hashtable 4095))
+ (setq nnweb-hashtb (gnus-make-hashtable 4000))
(unless nnweb-articles
(nnweb-read-overview group)))
(funcall (nnweb-definition 'map))
@@ -231,11 +229,11 @@ Valid types include `google', `dejanews', and `gmane'.")
(nnheader-insert-nov (cadr (pop articles)))))))
(defun nnweb-set-hashtb (header data)
- (gnus-sethash (nnweb-identifier (mail-header-xref header))
+ (puthash (nnweb-identifier (mail-header-xref header))
data nnweb-hashtb))
(defun nnweb-get-hashtb (url)
- (gnus-gethash (nnweb-identifier url) nnweb-hashtb))
+ (gethash (nnweb-identifier url) nnweb-hashtb))
(defun nnweb-identifier (ident)
(funcall (nnweb-definition 'identifier) ident))
@@ -270,7 +268,7 @@ Valid types include `google', `dejanews', and `gmane'.")
(unless nnweb-group-alist
(nnweb-read-active))
(unless nnweb-hashtb
- (setq nnweb-hashtb (gnus-make-hashtable 4095)))
+ (setq nnweb-hashtb (make-hash-table :size 4000 :test #'equal)))
(when group
(setq nnweb-group group)))
@@ -362,11 +360,11 @@ Valid types include `google', `dejanews', and `gmane'.")
(current-time-string)))
(setq From (match-string 4)))
(widen)
- (incf i)
+ (cl-incf i)
(unless (nnweb-get-hashtb url)
(push
(list
- (incf (cdr active))
+ (cl-incf (cdr active))
(make-full-mail-header
(cdr active) (if Newsgroups
(concat "(" Newsgroups ") " Subject)
@@ -398,7 +396,7 @@ Valid types include `google', `dejanews', and `gmane'.")
(nconc nnweb-articles (nnweb-google-parse-1)))
;; Check if there are more articles to fetch
(goto-char (point-min))
- (incf i 100)
+ (cl-incf i 100)
(if (or (not (re-search-forward
"<a [^>]+href=\"\n?\\([^>\" \n\t]+\\)[^<]*<img[^>]+src=[^>]+next"
nil t))
@@ -478,7 +476,7 @@ Valid types include `google', `dejanews', and `gmane'.")
(rfc2047-encode-string subject))
(unless (nnweb-get-hashtb (mail-header-xref header))
- (mail-header-set-number header (incf (cdr active)))
+ (mail-header-set-number header (cl-incf (cdr active)))
(push (list (mail-header-number header) header) map)
(nnweb-set-hashtb (cadar map) (car map))))))
(forward-line 1)))
@@ -525,10 +523,6 @@ Valid types include `google', `dejanews', and `gmane'.")
(defun nnweb-insert-html (parse)
"Insert HTML based on a w3 parse tree."
(if (stringp parse)
- ;; We used to call nnheader-string-as-multibyte here, but it cannot
- ;; be right, so I removed it. If a bug shows up because of this change,
- ;; please do not blindly revert the change, but help me find the real
- ;; cause of the bug instead. --Stef
(insert parse)
(insert "<" (symbol-name (car parse)) " ")
(insert (mapconcat
diff --git a/lisp/gnus/score-mode.el b/lisp/gnus/score-mode.el
index 83b966bef1c..8ba1eae1abc 100644
--- a/lisp/gnus/score-mode.el
+++ b/lisp/gnus/score-mode.el
@@ -24,7 +24,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
(require 'mm-util) ; for mm-universal-coding-system
(require 'gnus-util) ; for gnus-pp, gnus-run-mode-hooks
@@ -85,7 +84,7 @@ This mode is an extended emacs-lisp mode.
(defun gnus-score-edit-insert-date ()
"Insert date in numerical format."
(interactive)
- (princ (time-to-days (current-time)) (current-buffer)))
+ (princ (time-to-days nil) (current-buffer)))
(defun gnus-score-pretty-print ()
"Format the current score file."
diff --git a/lisp/gnus/smiley.el b/lisp/gnus/smiley.el
index d41d67f915f..fb1e8de9c06 100644
--- a/lisp/gnus/smiley.el
+++ b/lisp/gnus/smiley.el
@@ -47,7 +47,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
(require 'nnheader)
(require 'gnus-art)
diff --git a/lisp/gnus/smime.el b/lisp/gnus/smime.el
index b8db52752b2..9a38a6c6976 100644
--- a/lisp/gnus/smime.el
+++ b/lisp/gnus/smime.el
@@ -234,10 +234,12 @@ must be set in `ldap-host-parameters-alist'."
If `cache-key' and `password-cache' is non-nil then cache the
password under `cache-key'."
(let ((passphrase
- (password-read-and-add
+ (password-read
"Passphrase for secret key (RET for no passphrase): " cache-key)))
(if (string= passphrase "")
nil
+ ;; FIXME test passphrase works before caching it.
+ (and passphrase cache-key (password-cache-add cache-key passphrase))
passphrase)))
;; OpenSSL wrappers.
diff --git a/lisp/gnus/spam-stat.el b/lisp/gnus/spam-stat.el
index f5ec440a97f..6cf43df2a25 100644
--- a/lisp/gnus/spam-stat.el
+++ b/lisp/gnus/spam-stat.el
@@ -77,13 +77,13 @@
;; Learn spam: (spam-stat-process-spam-directory "~/Mail/mail/spam")
;; Learn non-spam: (spam-stat-process-non-spam-directory "~/Mail/mail/misc")
;; Save table: (spam-stat-save)
-;; File size: (nth 7 (file-attributes spam-stat-file))
+;; File size: (file-attribute-size (file-attributes spam-stat-file))
;; Number of words: (hash-table-count spam-stat)
;; Test spam: (spam-stat-test-directory "~/Mail/mail/spam")
;; Test non-spam: (spam-stat-test-directory "~/Mail/mail/misc")
;; Reduce table size: (spam-stat-reduce-size)
;; Save table: (spam-stat-save)
-;; File size: (nth 7 (file-attributes spam-stat-file))
+;; File size: (file-attribute-size (file-attributes spam-stat-file))
;; Number of words: (hash-table-count spam-stat)
;; Test spam: (spam-stat-test-directory "~/Mail/mail/spam")
;; Test non-spam: (spam-stat-test-directory "~/Mail/mail/misc")
@@ -424,7 +424,8 @@ spam-stat (spam-stat-to-hash-table '(" spam-stat-ngood spam-stat-nbad))
(insert ")))"))))
(message "Saved %s." spam-stat-file)
(setq spam-stat-dirty nil
- spam-stat-last-saved-at (nth 5 (file-attributes spam-stat-file)))))
+ spam-stat-last-saved-at (file-attribute-modification-time
+ (file-attributes spam-stat-file)))))
(defun spam-stat-load ()
"Read the `spam-stat' hash table from disk."
@@ -434,12 +435,14 @@ spam-stat (spam-stat-to-hash-table '(" spam-stat-ngood spam-stat-nbad))
((or (not (boundp 'spam-stat-last-saved-at))
(null spam-stat-last-saved-at)
(not (equal spam-stat-last-saved-at
- (nth 5 (file-attributes spam-stat-file)))))
+ (file-attribute-modification-time
+ (file-attributes spam-stat-file)))))
(progn
(load-file spam-stat-file)
(setq spam-stat-dirty nil
spam-stat-last-saved-at
- (nth 5 (file-attributes spam-stat-file)))))
+ (file-attribute-modification-time
+ (file-attributes spam-stat-file)))))
(t (message "Spam stat file not loaded: no change in disk.")))))
(defun spam-stat-to-hash-table (entries)
@@ -561,8 +564,10 @@ check the variable `spam-stat-score-data'."
(dolist (f files)
(when (and (file-readable-p f)
(file-regular-p f)
- (> (nth 7 (file-attributes f)) 0)
- (< (time-to-number-of-days (time-since (nth 5 (file-attributes f))))
+ (> (file-attribute-size (file-attributes f)) 0)
+ (< (time-to-number-of-days
+ (time-since (file-attribute-modification-time
+ (file-attributes f))))
spam-stat-process-directory-age))
(setq count (1+ count))
(message "Reading %s: %.2f%%" dir (/ count max))
@@ -607,7 +612,7 @@ display non-spam files; otherwise display spam files."
(dolist (f files)
(when (and (file-readable-p f)
(file-regular-p f)
- (> (nth 7 (file-attributes f)) 0))
+ (> (file-attribute-size (file-attributes f)) 0))
(setq count (1+ count))
(message "Reading %.2f%%, score %.2f"
(/ count max) (/ score count))
diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el
index 76fa0f89183..4d31d0a1f1c 100644
--- a/lisp/gnus/spam.el
+++ b/lisp/gnus/spam.el
@@ -38,8 +38,6 @@
;;{{{ compilation directives and autoloads/requires
-(eval-when-compile (require 'cl))
-
(require 'message) ;for the message-fetch-field functions
(require 'gnus-sum)
(require 'gnus-uu) ; because of key prefix issues
@@ -51,6 +49,8 @@
;; for nnimap-split-download-body-default
(eval-when-compile (require 'nnimap))
+(eval-when-compile (require 'cl-lib))
+
;; autoload query-dig
(autoload 'query-dig "dig")
@@ -366,9 +366,6 @@ Only meaningful if you enable `spam-use-blackholes'."
(t :inverse-video t))
"Face for spam-marked articles."
:group 'spam)
-;; backward-compatibility alias
-(put 'spam-face 'face-alias 'spam)
-(put 'spam-face 'obsolete-face "22.1")
(defcustom spam-face 'spam
"Face for spam-marked articles."
@@ -1167,12 +1164,12 @@ backends)."
(defun spam-article-sort-by-spam-status (h1 h2)
"Sort articles by score."
(let (result)
- (dolist (header (spam-necessary-extra-headers))
+ (cl-dolist (header (spam-necessary-extra-headers))
(let ((s1 (spam-summary-score h1 header))
(s2 (spam-summary-score h2 header)))
(unless (= s1 s2)
(setq result (< s1 s2))
- (return))))
+ (cl-return))))
result))
(defvar spam-spamassassin-score-regexp
@@ -1208,14 +1205,14 @@ Note this has to be fast."
With SPECIFIC-HEADER, returns only that header's score.
Will not return a nil score."
(let (score)
- (dolist (header
+ (cl-dolist (header
(if specific-header
(list specific-header)
(spam-necessary-extra-headers)))
(setq score
(spam-extra-header-to-number header headers))
(when score
- (return)))
+ (cl-return)))
(or score 0)))
(defun spam-generic-score (&optional recheck)
@@ -1247,73 +1244,40 @@ Will not return a nil score."
(setq found backend)))
found))
-(defvar spam-list-of-processors
- ;; note the nil processors are not defined in gnus.el
- '((gnus-group-spam-exit-processor-bogofilter spam spam-use-bogofilter)
- (gnus-group-spam-exit-processor-bsfilter spam spam-use-bsfilter)
- (gnus-group-spam-exit-processor-blacklist spam spam-use-blacklist)
- (gnus-group-spam-exit-processor-ifile spam spam-use-ifile)
- (gnus-group-spam-exit-processor-stat spam spam-use-stat)
- (gnus-group-spam-exit-processor-spamoracle spam spam-use-spamoracle)
- (gnus-group-spam-exit-processor-spamassassin spam spam-use-spamassassin)
- (gnus-group-spam-exit-processor-report-gmane spam spam-use-gmane) ;; Buggy?
- (gnus-group-ham-exit-processor-ifile ham spam-use-ifile)
- (gnus-group-ham-exit-processor-bogofilter ham spam-use-bogofilter)
- (gnus-group-ham-exit-processor-bsfilter ham spam-use-bsfilter)
- (gnus-group-ham-exit-processor-stat ham spam-use-stat)
- (gnus-group-ham-exit-processor-whitelist ham spam-use-whitelist)
- (gnus-group-ham-exit-processor-BBDB ham spam-use-BBDB)
- (gnus-group-ham-exit-processor-copy ham spam-use-ham-copy)
- (gnus-group-ham-exit-processor-spamassassin ham spam-use-spamassassin)
- (gnus-group-ham-exit-processor-spamoracle ham spam-use-spamoracle))
- "The OBSOLETE `spam-list-of-processors' list.
-This list contains pairs associating the obsolete ham/spam exit
-processor variables with a classification and a spam-use-*
-variable. When the processor variable is nil, just the
-classification and spam-use-* check variable are used. This is
-superseded by the new spam backend code, so it's only consulted
-for backwards compatibility.")
-(make-obsolete-variable 'spam-list-of-processors nil "22.1")
-
(defun spam-group-processor-p (group backend &optional classification)
"Checks if GROUP has a BACKEND with CLASSIFICATION registered.
-Also accepts the obsolete processors, which can be found in
-gnus.el and in spam-list-of-processors. In the case of mover
-backends, checks the setting of `spam-summary-exit-behavior' in
-addition to the set values for the group."
+In the case of mover backends, checks the setting of
+`spam-summary-exit-behavior' in addition to the set values for the group."
(if (and (stringp group)
(symbolp backend))
- (let ((old-style (assq backend spam-list-of-processors))
- (parameters (nth 0 (gnus-parameter-spam-process group)))
+ (let ((parameters (nth 0 (gnus-parameter-spam-process group)))
found)
- (if old-style ; old-style processor
- (spam-group-processor-p group (nth 2 old-style) (nth 1 old-style))
- ;; now search for the parameter
- (dolist (parameter parameters)
- (when (and (null found)
- (listp parameter)
- (eq classification (nth 0 parameter))
- (eq backend (nth 1 parameter)))
- (setq found t)))
-
- ;; now, if the parameter was not found, do the
- ;; spam-summary-exit-behavior-logic for mover backends
- (unless found
- (when (spam-backend-mover-p backend)
- (setq
- found
- (cond
- ((eq spam-summary-exit-behavior 'move-all) t)
- ((eq spam-summary-exit-behavior 'move-none) nil)
- ((eq spam-summary-exit-behavior 'default)
- (or (eq classification 'spam) ;move spam out of all groups
- ;; move ham out of spam groups
- (and (eq classification 'ham)
- (spam-group-spam-contents-p group))))
- (t (gnus-error 5 "Unknown spam-summary-exit-behavior: %s"
- spam-summary-exit-behavior))))))
-
- found))
+ ;; now search for the parameter
+ (dolist (parameter parameters)
+ (when (and (null found)
+ (listp parameter)
+ (eq classification (nth 0 parameter))
+ (eq backend (nth 1 parameter)))
+ (setq found t)))
+
+ ;; now, if the parameter was not found, do the
+ ;; spam-summary-exit-behavior-logic for mover backends
+ (unless found
+ (when (spam-backend-mover-p backend)
+ (setq
+ found
+ (cond
+ ((eq spam-summary-exit-behavior 'move-all) t)
+ ((eq spam-summary-exit-behavior 'move-none) nil)
+ ((eq spam-summary-exit-behavior 'default)
+ (or (eq classification 'spam) ;move spam out of all groups
+ ;; move ham out of spam groups
+ (and (eq classification 'ham)
+ (spam-group-spam-contents-p group))))
+ (t (gnus-error 5 "Unknown spam-summary-exit-behavior: %s"
+ spam-summary-exit-behavior))))))
+
+ found)
nil))
;;}}}
@@ -1697,10 +1661,10 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
article-cannot-be-faked)
- (dolist (backend methods)
+ (cl-dolist (backend methods)
(when (spam-backend-statistical-p backend)
(setq article-cannot-be-faked t)
- (return)))
+ (cl-return)))
(when (memq 'default methods)
(setq article-cannot-be-faked t))
@@ -1785,7 +1749,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
;; eliminate duplicates
(dolist (article (copy-sequence ulist))
(when (memq article rlist)
- (incf delcount)
+ (cl-incf delcount)
(setq rlist (delq article rlist))
(setq ulist (delq article ulist))))
@@ -2173,7 +2137,7 @@ See `spam-ifile-database'."
(apply 'call-process-region
(point-min) (point-max) spam-ifile-program
nil temp-buffer-name nil "-c"
- (if db-param `(,db-param "-q") `("-q"))))
+ (if db-param `(,db-param "-q") '("-q"))))
;; check the return now (we're back in the temp buffer)
(goto-char (point-min))
(if (not (eobp))
@@ -2202,7 +2166,7 @@ Uses `gnus-newsgroup-name' if category is nil (for ham registration)."
(point-min) (point-max) spam-ifile-program
nil nil nil
add-or-delete-option category
- (if db `(,db "-h") `("-h"))))))
+ (if db `(,db "-h") '("-h"))))))
(defun spam-ifile-register-spam-routine (articles &optional unregister)
(spam-ifile-register-with-ifile articles spam-ifile-spam-category unregister))
@@ -2335,10 +2299,10 @@ With a non-nil REMOVE, remove the ADDRESSES."
(when (stringp from)
(spam-filelist-build-cache type)
(let (found)
- (dolist (address (gethash type spam-caches))
+ (cl-dolist (address (gethash type spam-caches))
(when (and address (string-match address from))
(setq found t)
- (return)))
+ (cl-return)))
found)))
;;; returns t if the sender is in the whitelist, nil or
@@ -2509,7 +2473,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
(point-min) (point-max)
spam-bogofilter-program
nil temp-buffer-name nil
- (if db `("-d" ,db "-v") `("-v"))))
+ (if db `("-d" ,db "-v") '("-v"))))
(setq return (spam-check-bogofilter-headers score))))
return)
(gnus-error 5 "`spam.el' doesn't support obsolete bogofilter versions")))
@@ -2537,7 +2501,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
(point-min) (point-max)
spam-bogofilter-program
nil nil nil switch
- (if db `("-d" ,db "-v") `("-v")))))))
+ (if db `("-d" ,db "-v") '("-v")))))))
(gnus-error 5 "`spam.el' doesn't support obsolete bogofilter versions")))
(defun spam-bogofilter-register-spam-routine (articles &optional unregister)
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index a7812e3b4b5..06b4ec8c209 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -68,12 +68,15 @@ The functions will receive the function name as argument.")
(defun help--loaded-p (file)
"Try and figure out if FILE has already been loaded."
+ ;; FIXME: this regexp business is not good enough: for file
+ ;; `toto', it will say `toto' is loaded when in reality it was
+ ;; just cedet/semantic/toto that has been loaded.
(or (let ((feature (intern-soft file)))
(and feature (featurep feature)))
(let* ((re (load-history-regexp file))
(done nil))
(dolist (x load-history)
- (and (car x) (string-match-p re (car x)) (setq done t)))
+ (and (stringp (car x)) (string-match-p re (car x)) (setq done t)))
done)))
(defun help--load-prefixes (prefixes)
@@ -83,11 +86,9 @@ The functions will receive the function name as argument.")
(dolist (file files)
;; FIXME: Should we scan help-definition-prefixes to remove
;; other prefixes of the same file?
- ;; FIXME: this regexp business is not good enough: for file
- ;; `toto', it will say `toto' is loaded when in reality it was
- ;; just cedet/semantic/toto that has been loaded.
(unless (help--loaded-p file)
- (load file 'noerror 'nomessage)))))
+ (with-demoted-errors "while loading: %S"
+ (load file 'noerror 'nomessage))))))
(defun help--symbol-completion-table (string pred action)
(let ((prefixes (radix-tree-prefixes (help-definition-prefixes) string)))
@@ -181,8 +182,8 @@ KIND should be `var' for a variable or `subr' for a subroutine."
(expand-file-name internal-doc-file-name doc-directory)))
(let ((file (catch 'loop
(while t
- (let ((pnt (search-forward (concat "" name "\n"))))
- (re-search-backward "S\\(.*\\)")
+ (let ((pnt (search-forward (concat "\^_" name "\n"))))
+ (re-search-backward "\^_S\\(.*\\)")
(let ((file (match-string 1)))
(if (member file build-files)
(throw 'loop file)
@@ -520,7 +521,7 @@ FILE is the file where FUNCTION was probably defined."
(target (cons t function))
found)
(while (and load-hist (not found))
- (and (caar load-hist)
+ (and (stringp (caar load-hist))
(equal (file-name-sans-extension (caar load-hist)) file)
(setq found (member target (cdar load-hist))))
(setq load-hist (cdr load-hist)))
@@ -642,6 +643,8 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)."
(concat beg "Lisp macro"))
((byte-code-function-p def)
(concat beg "compiled Lisp function"))
+ ((module-function-p def)
+ (concat beg "module function"))
((eq (car-safe def) 'lambda)
(concat beg "Lisp function"))
((eq (car-safe def) 'closure)
@@ -721,6 +724,10 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)."
((invalid-function void-function) doc-raw))))
(run-hook-with-args 'help-fns-describe-function-functions function)
(insert "\n" (or doc "Not documented.")))
+ (when (or (function-get function 'pure)
+ (function-get function 'side-effect-free))
+ (insert "\nThis function does not change global state, "
+ "including the match data."))
;; Avoid asking the user annoying questions if she decides
;; to save the help buffer, when her locale's codeset
;; isn't UTF-8.
@@ -1135,7 +1142,7 @@ current buffer and the selected frame, respectively."
(format
"Describe symbol (default %s): " v-or-f)
"Describe symbol: ")
- obarray
+ #'help--symbol-completion-table
(lambda (vv)
(cl-some (lambda (x) (funcall (nth 1 x) vv))
describe-symbol-backends))
@@ -1287,7 +1294,7 @@ BUFFER should be a buffer or a buffer name."
".AU Richard M. Stallman\n")
(insert-file-contents file)
(let (notfirst)
- (while (search-forward "" nil 'move)
+ (while (search-forward "\^_" nil 'move)
(if (= (following-char) ?S)
(delete-region (1- (point)) (line-end-position))
(delete-char -1)
@@ -1320,12 +1327,12 @@ BUFFER should be a buffer or a buffer name."
(insert "@")
(forward-char 1))
(goto-char (point-min))
- (while (search-forward "" nil t)
+ (while (search-forward "\^_" nil t)
(when (/= (following-char) ?S)
(setq type (char-after)
name (buffer-substring (1+ (point)) (line-end-position))
doc (buffer-substring (line-beginning-position 2)
- (if (search-forward "" nil 'move)
+ (if (search-forward "\^_" nil 'move)
(1- (point))
(point)))
alist (cons (list name type doc) alist))
diff --git a/lisp/help-mode.el b/lisp/help-mode.el
index be488ea80ca..6cc3f0d4f71 100644
--- a/lisp/help-mode.el
+++ b/lisp/help-mode.el
@@ -203,12 +203,18 @@ The format is (FUNCTION ARGS...).")
(help-C-file-name (indirect-function fun) 'fun)))
;; Don't use find-function-noselect because it follows
;; aliases (which fails for built-in functions).
- (let ((location
- (find-function-search-for-symbol fun type file)))
+ (let* ((location
+ (find-function-search-for-symbol fun type file))
+ (position (cdr location)))
(pop-to-buffer (car location))
(run-hooks 'find-function-after-hook)
- (if (cdr location)
- (goto-char (cdr location))
+ (if position
+ (progn
+ ;; Widen the buffer if necessary to go to this position.
+ (when (or (< position (point-min))
+ (> position (point-max)))
+ (widen))
+ (goto-char position))
(message "Unable to find location in file")))))
'help-echo (purecopy "mouse-2, RET: find function's definition"))
@@ -219,6 +225,7 @@ The format is (FUNCTION ARGS...).")
(if (and file (file-readable-p file))
(progn
(pop-to-buffer (find-file-noselect file))
+ (widen)
(goto-char (point-min))
(if (re-search-forward
(format "^[ \t]*(\\(cl-\\)?define-compiler-macro[ \t]+%s"
@@ -234,12 +241,18 @@ The format is (FUNCTION ARGS...).")
'help-function (lambda (var &optional file)
(when (eq file 'C-source)
(setq file (help-C-file-name var 'var)))
- (let ((location (find-variable-noselect var file)))
+ (let* ((location (find-variable-noselect var file))
+ (position (cdr location)))
(pop-to-buffer (car location))
(run-hooks 'find-function-after-hook)
- (if (cdr location)
- (goto-char (cdr location))
- (message "Unable to find location in file"))))
+ (if position
+ (progn
+ ;; Widen the buffer if necessary to go to this position.
+ (when (or (< position (point-min))
+ (> position (point-max)))
+ (widen))
+ (goto-char position))
+ (message "Unable to find location in file"))))
'help-echo (purecopy "mouse-2, RET: find variable's definition"))
(define-button-type 'help-face-def
@@ -248,12 +261,18 @@ The format is (FUNCTION ARGS...).")
(require 'find-func)
;; Don't use find-function-noselect because it follows
;; aliases (which fails for built-in functions).
- (let ((location
- (find-function-search-for-symbol fun 'defface file)))
+ (let* ((location
+ (find-function-search-for-symbol fun 'defface file))
+ (position (cdr location)))
(pop-to-buffer (car location))
- (if (cdr location)
- (goto-char (cdr location))
- (message "Unable to find location in file"))))
+ (if position
+ (progn
+ ;; Widen the buffer if necessary to go to this position.
+ (when (or (< position (point-min))
+ (> position (point-max)))
+ (widen))
+ (goto-char position))
+ (message "Unable to find location in file"))))
'help-echo (purecopy "mouse-2, RET: find face's definition"))
(define-button-type 'help-package
@@ -402,7 +421,15 @@ it does not already exist."
(or (and (boundp symbol) (not (keywordp symbol)))
(get symbol 'variable-documentation)))
,#'describe-variable)
- ("face" ,#'facep ,(lambda (s _b _f) (describe-face s)))))
+ ("face" ,#'facep ,(lambda (s _b _f) (describe-face s))))
+ "List of providers of information about symbols.
+Each element has the form (NAME TESTFUN DESCFUN) where:
+ NAME is a string naming a category of object, such as \"type\" or \"face\".
+ TESTFUN is a predicate which takes a symbol and returns non-nil if the
+ symbol is such an object.
+ DESCFUN is a function which takes three arguments (a symbol, a buffer,
+ and a frame), inserts the description of that symbol in the current buffer
+ and returns that text as well.")
;;;###autoload
(defun help-make-xrefs (&optional buffer)
diff --git a/lisp/help.el b/lisp/help.el
index c23d4d8fe54..d1f473517d5 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -1,4 +1,4 @@
-;;; help.el --- help commands for Emacs
+;;; help.el --- help commands for Emacs -*- lexical-binding:t -*-
;; Copyright (C) 1985-1986, 1993-1994, 1998-2019 Free Software
;; Foundation, Inc.
@@ -67,6 +67,7 @@
(define-key map "\C-n" 'view-emacs-news)
(define-key map "\C-o" 'describe-distribution)
(define-key map "\C-p" 'view-emacs-problems)
+ (define-key map "\C-s" 'search-forward-help-for-help)
(define-key map "\C-t" 'view-emacs-todo)
(define-key map "\C-w" 'describe-no-warranty)
@@ -240,6 +241,7 @@ C-m How to order printed Emacs manuals.
C-n News of recent Emacs changes.
C-o Emacs ordering and distribution information.
C-p Info about known Emacs problems.
+C-s Search forward \"help window\".
C-t Emacs TODO list.
C-w Information on absence of warranty for GNU Emacs."
help-map)
@@ -308,8 +310,6 @@ If that doesn't give a function, return nil."
(interactive)
(browse-url "https://www.gnu.org/gnu/thegnuproject.html"))
-(define-obsolete-function-alias 'describe-project 'describe-gnu-project "22.2")
-
(defun describe-no-warranty ()
"Display info on all the kinds of warranty Emacs does NOT have."
(interactive)
@@ -413,9 +413,6 @@ With argument, display info only for the selected version."
(interactive "P")
(view-help-file "TODO"))
-(define-obsolete-function-alias 'view-todo 'view-emacs-todo "22.2")
-
-
(defun view-echo-area-messages ()
"View the log of recent echo-area messages: the `*Messages*' buffer.
The number of messages retained in that buffer
@@ -428,13 +425,11 @@ is specified by the variable `message-log-max'."
(defun view-order-manuals ()
"Display information on how to buy printed copies of Emacs manuals."
(interactive)
-;; (view-help-file "ORDERS")
(info "(emacs)Printed Books"))
(defun view-emacs-FAQ ()
"Display the Emacs Frequently Asked Questions (FAQ) file."
(interactive)
- ;; (find-file-read-only (expand-file-name "FAQ" data-directory))
(info "(efaq)"))
(defun view-emacs-problems ()
@@ -447,7 +442,8 @@ is specified by the variable `message-log-max'."
(interactive)
(view-help-file "DEBUG"))
-;; This used to visit MORE.STUFF; maybe it should just be removed.
+;; This used to visit a plain text file etc/MORE.STUFF;
+;; maybe this command should just be removed.
(defun view-external-packages ()
"Display info on where to get more Emacs packages."
(interactive)
@@ -455,6 +451,8 @@ is specified by the variable `message-log-max'."
(defun view-lossage ()
"Display last few input keystrokes and the commands run.
+For convenience this uses the same format as
+`edit-last-kbd-macro'.
To record all your input, use `open-dribble-file'."
(interactive)
@@ -465,8 +463,8 @@ To record all your input, use `open-dribble-file'."
(princ (mapconcat (lambda (key)
(cond
((and (consp key) (null (car key)))
- (format "[%s]\n" (if (symbolp (cdr key)) (cdr key)
- "anonymous-command")))
+ (format ";; %s\n" (if (symbolp (cdr key)) (cdr key)
+ "anonymous-command")))
((or (integerp key) (symbolp key) (listp key))
(single-key-description key))
(t
@@ -475,11 +473,11 @@ To record all your input, use `open-dribble-file'."
" "))
(with-current-buffer standard-output
(goto-char (point-min))
- (while (not (eobp))
- (move-to-column 50)
- (unless (eolp)
- (fill-region (line-beginning-position) (line-end-position)))
- (forward-line 1))
+ (let ((comment-start ";; ")
+ (comment-column 24))
+ (while (not (eobp))
+ (comment-indent)
+ (forward-line 1)))
;; jidanni wants to see the last keystrokes immediately.
(set-marker help-window-point-marker (point)))))
@@ -593,19 +591,27 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer."
string
(format "%s (translated from %s)" string otherstring))))))
+(defun help--binding-undefined-p (defn)
+ (or (null defn) (integerp defn) (equal defn 'undefined)))
+
(defun help--analyze-key (key untranslated)
"Get information about KEY its corresponding UNTRANSLATED events.
Returns a list of the form (BRIEF-DESC DEFN EVENT MOUSE-MSG)."
(if (numberp untranslated)
- (setq untranslated (this-single-command-raw-keys)))
- (let* ((event (aref key (if (and (symbolp (aref key 0))
- (> (length key) 1)
- (consp (aref key 1)))
- 1
- 0)))
+ (error "Missing `untranslated'!"))
+ (let* ((event (when (> (length key) 0)
+ (aref key (if (and (symbolp (aref key 0))
+ (> (length key) 1)
+ (consp (aref key 1)))
+ ;; Look at the second event when the first
+ ;; is a pseudo-event like `mode-line' or
+ ;; `left-fringe'.
+ 1
+ 0))))
(modifiers (event-modifiers event))
(mouse-msg (if (or (memq 'click modifiers) (memq 'down modifiers)
- (memq 'drag modifiers)) " at that spot" ""))
+ (memq 'drag modifiers))
+ " at that spot" ""))
(defn (key-binding key t)))
;; Handle the case where we faked an entry in "Select and Paste" menu.
(when (and (eq defn nil)
@@ -621,27 +627,47 @@ Returns a list of the form (BRIEF-DESC DEFN EVENT MOUSE-MSG)."
(list
;; Now describe the key, perhaps as changed.
(let ((key-desc (help-key-description key untranslated)))
- (if (or (null defn) (integerp defn) (equal defn 'undefined))
+ (if (help--binding-undefined-p defn)
(format "%s%s is undefined" key-desc mouse-msg)
(format "%s%s runs the command %S" key-desc mouse-msg defn)))
defn event mouse-msg)))
-(defun describe-key-briefly (&optional key insert untranslated)
- "Print the name of the function KEY invokes. KEY is a string.
+(defun help--filter-info-list (info-list i)
+ "Drop the undefined keys."
+ (or
+ ;; Remove all `undefined' keys.
+ (delq nil (mapcar (lambda (x)
+ (unless (help--binding-undefined-p (nth i x)) x))
+ info-list))
+ ;; If nothing left, then keep one (the last one).
+ (last info-list)))
+
+(defun describe-key-briefly (&optional key-list insert untranslated)
+ "Print the name of the functions KEY-LIST invokes.
+KEY-LIST is a list of pairs (SEQ . RAW-SEQ) of key sequences, where
+RAW-SEQ is the untranslated form of the key sequence SEQ.
If INSERT (the prefix arg) is non-nil, insert the message in the buffer.
-If non-nil, UNTRANSLATED is a vector of the untranslated events.
-It can also be a number in which case the untranslated events from
-the last key hit are used.
-If KEY is a menu item or a tool-bar button that is disabled, this command
-temporarily enables it to allow getting help on disabled items and buttons."
+While reading KEY-LIST interactively, this command temporarily enables
+menu items or tool-bar buttons that are disabled to allow getting help
+on them."
+ (declare (advertised-calling-convention (key-list &optional insert) "27.1"))
(interactive
;; Ignore mouse movement events because it's too easy to miss the
;; message while moving the mouse.
- (pcase-let ((`(,key ,_up-event) (help-read-key-sequence 'no-mouse-movement)))
- `(,key ,current-prefix-arg 1)))
- (princ (car (help--analyze-key key untranslated))
- (if insert (current-buffer) standard-output)))
+ (let ((key-list (help--read-key-sequence 'no-mouse-movement)))
+ `(,key-list ,current-prefix-arg)))
+ (when (arrayp key-list)
+ ;; Old calling convention, changed
+ (setq key-list (list (cons key-list
+ (if (numberp untranslated)
+ (this-single-command-raw-keys)
+ untranslated)))))
+ (let* ((info-list (mapcar (lambda (kr)
+ (help--analyze-key (car kr) (cdr kr)))
+ key-list))
+ (msg (mapconcat #'car (help--filter-info-list info-list 1) "\n")))
+ (if insert (insert msg) (message "%s" msg))))
(defun help--key-binding-keymap (key &optional accept-default no-remap position)
"Return a keymap holding a binding for KEY within current keymaps.
@@ -688,8 +714,7 @@ function `key-binding'."
(format "%s-map" mode)))))
minor-mode-map-alist))
(list 'global-map
- (intern-soft (format "%s-map" major-mode)))))
- found)
+ (intern-soft (format "%s-map" major-mode))))))
;; Look into these advertised symbols first.
(dolist (sym advertised-syms)
(when (and
@@ -706,225 +731,137 @@ function `key-binding'."
(throw 'found x))))
nil)))))
-(defun help-read-key-sequence (&optional no-mouse-movement)
- "Reads a key sequence from the user.
-Returns a list of the form (KEY UP-EVENT), where KEY is the key
-sequence, and UP-EVENT is the up-event that was discarded by
-reading KEY, or nil.
+(defun help--read-key-sequence (&optional no-mouse-movement)
+ "Read a key sequence from the user.
+Usually reads a single key sequence, except when that sequence might
+hide another one (e.g. a down event, where the user is interested
+in getting info about the up event, or a click event, where the user
+wants to get info about the double click).
+Return a list of elements of the form (SEQ . RAW-SEQ), where SEQ is a key
+sequence, and RAW-SEQ is its untranslated form.
If NO-MOUSE-MOVEMENT is non-nil, ignore key sequences starting
with `mouse-movement' events."
(let ((enable-disabled-menus-and-buttons t)
(cursor-in-echo-area t)
saved-yank-menu)
(unwind-protect
- (let (key keys down-ev discarded-up)
+ (let (last-modifiers key-list)
;; If yank-menu is empty, populate it temporarily, so that
;; "Select and Paste" menu can generate a complete event.
(when (null (cdr yank-menu))
(setq saved-yank-menu (copy-sequence yank-menu))
(menu-bar-update-yank-menu "(any string)" nil))
(while
- (pcase (setq key (read-key-sequence "\
+ ;; Read at least one key-sequence.
+ (or (null key-list)
+ ;; After a down event, also read the (presumably) following
+ ;; up-event.
+ (memq 'down last-modifiers)
+ ;; After a click, see if a double click is on the way.
+ (and (memq 'click last-modifiers)
+ (not (sit-for (/ double-click-time 1000.0) t))))
+ (let* ((seq (read-key-sequence "\
Describe the following key, mouse click, or menu item: "))
- ((and (pred vectorp) (let `(,key0 . ,_) (aref key 0))
- (guard (symbolp key0)) (let keyname (symbol-name key0)))
- (or
- (and no-mouse-movement
- (string-match "mouse-movement" keyname))
- (progn (push key keys) nil)
- (and (string-match "\\(mouse\\|down\\|click\\|drag\\)"
- keyname)
- (progn
- ;; Discard events (e.g. <help-echo>) which might
- ;; spuriously trigger the `sit-for'.
- (sleep-for 0.01)
- (while (read-event nil nil 0.01))
- (not (sit-for
- (if (numberp double-click-time)
- (/ double-click-time 1000.0)
- 3.0)
- t))))))))
- ;; When we have a sequence of mouse events, discard the most
- ;; recent ones till we find one with a binding.
- (let ((keys-1 keys))
- (while (and keys-1
- (not (key-binding (car keys-1))))
- ;; If we discard the last event, and this was a mouse
- ;; up, remember this.
- (if (and (eq keys-1 keys)
- (vectorp (car keys-1))
- (let* ((last-idx (1- (length (car keys-1))))
- (last (aref (car keys-1) last-idx)))
- (and (eventp last)
- (memq 'click (event-modifiers last)))))
- (setq discarded-up t))
- (setq keys-1 (cdr keys-1)))
- (if keys-1
- (setq key (car keys-1))))
- (list
- key
- ;; If KEY is a down-event, read and include the
- ;; corresponding up-event. Note that there are also
- ;; down-events on scroll bars and mode lines: the actual
- ;; event then is in the second element of the vector.
- (and (not discarded-up) ; Don't attempt to ignore the up-event twice.
- (vectorp key)
- (let ((last-idx (1- (length key))))
- (and (eventp (aref key last-idx))
- (memq 'down (event-modifiers (aref key last-idx)))))
- (or (and (eventp (setq down-ev (aref key 0)))
- (memq 'down (event-modifiers down-ev))
- ;; However, for the C-down-mouse-2 popup
- ;; menu, there is no subsequent up-event. In
- ;; this case, the up-event is the next
- ;; element in the supplied vector.
- (= (length key) 1))
- (and (> (length key) 1)
- (eventp (setq down-ev (aref key 1)))
- (memq 'down (event-modifiers down-ev))))
- (if (and (terminal-parameter nil 'xterm-mouse-mode)
- (equal (terminal-parameter nil 'xterm-mouse-last-down)
- down-ev))
- (aref (read-key-sequence-vector nil) 0)
- (read-event)))))
+ (raw-seq (this-single-command-raw-keys))
+ (keyn (when (> (length seq) 0)
+ (aref seq (1- (length seq)))))
+ (base (event-basic-type keyn))
+ (modifiers (event-modifiers keyn)))
+ (cond
+ ((zerop (length seq))) ;FIXME: Can this happen?
+ ((and no-mouse-movement (eq base 'mouse-movement)) nil)
+ ((eq base 'help-echo) nil)
+ (t
+ (setq last-modifiers modifiers)
+ (push (cons seq raw-seq) key-list)))))
+ (nreverse key-list))
;; Put yank-menu back as it was, if we changed it.
(when saved-yank-menu
(setq yank-menu (copy-sequence saved-yank-menu))
(fset 'yank-menu (cons 'keymap yank-menu))))))
-(defun help-downify-mouse-event-type (base)
- "Add \"down-\" to BASE if it is not already there.
-BASE is a symbol, a mouse event type. If the modification is done,
-return the new symbol. Otherwise return nil."
- (let ((base-s (symbol-name base)))
- ;; Note: the order of the components in the following string is
- ;; determined by `apply_modifiers_uncached' in src/keyboard.c.
- (string-match "\\(A-\\)?\
-\\(C-\\)?\
-\\(H-\\)?\
-\\(M-\\)?\
-\\(S-\\)?\
-\\(s-\\)?\
-\\(double-\\)?\
-\\(triple-\\)?\
-\\(up-\\)?\
-\\(\\(down-\\)?\\)\
-\\(drag-\\)?" base-s)
- (when (and (null (match-beginning 11)) ; "down-"
- (null (match-beginning 12))) ; "drag-"
- (intern (replace-match "down-" t t base-s 10)) )))
-
-(defun describe-key (&optional key untranslated up-event)
- "Display documentation of the function invoked by KEY.
-KEY can be any kind of a key sequence; it can include keyboard events,
+(defun describe-key (&optional key-list buffer up-event)
+ "Display documentation of the function invoked by KEY-LIST.
+KEY-LIST can be any kind of a key sequence; it can include keyboard events,
mouse events, and/or menu events. When calling from a program,
-pass KEY as a string or a vector.
-
-If non-nil, UNTRANSLATED is a vector of the corresponding untranslated events.
-It can also be a number, in which case the untranslated events from
-the last key sequence entered are used.
-UP-EVENT is the up-event that was discarded by reading KEY, or nil.
-
-If KEY is a menu item or a tool-bar button that is disabled, this command
-temporarily enables it to allow getting help on disabled items and buttons."
- (interactive
- (pcase-let ((`(,key ,up-event) (help-read-key-sequence)))
- `(,key ,(prefix-numeric-value current-prefix-arg) ,up-event)))
- (pcase-let ((`(,brief-desc ,defn ,event ,mouse-msg)
- (help--analyze-key key untranslated))
- (defn-up nil) (defn-up-tricky nil)
- (key-locus-up nil) (key-locus-up-tricky nil)
- (mouse-1-remapped nil) (mouse-1-tricky nil)
- (ev-type nil))
- (if (or (null defn)
- (integerp defn)
- (equal defn 'undefined))
- (message "%s" brief-desc)
- (help-setup-xref (list #'describe-function defn)
- (called-interactively-p 'interactive))
- ;; Need to do this before erasing *Help* buffer in case event
- ;; is a mouse click in an existing *Help* buffer.
- (when up-event
- (setq ev-type (event-basic-type up-event))
- (let ((sequence (vector up-event)))
- (when (and (eq ev-type 'mouse-1)
- mouse-1-click-follows-link
- (not (eq mouse-1-click-follows-link 'double))
- (setq mouse-1-remapped
- (mouse-on-link-p (event-start up-event))))
- (setq mouse-1-tricky (and (integerp mouse-1-click-follows-link)
- (> mouse-1-click-follows-link 0)))
- (cond ((stringp mouse-1-remapped)
- (setq sequence mouse-1-remapped))
- ((vectorp mouse-1-remapped)
- (setcar up-event (elt mouse-1-remapped 0)))
- (t (setcar up-event 'mouse-2))))
- (setq defn-up (key-binding sequence nil nil (event-start up-event)))
- (setq key-locus-up (help--binding-locus sequence (event-start up-event)))
- (when mouse-1-tricky
- (setq sequence (vector up-event))
- (aset sequence 0 'mouse-1)
- (setq defn-up-tricky (key-binding sequence nil nil (event-start up-event)))
- (setq key-locus-up-tricky (help--binding-locus sequence (event-start up-event))))))
+pass KEY-LIST as a list of elements (SEQ . RAW-SEQ) where SEQ is
+a key-sequence and RAW-SEQ is its untranslated form.
+
+While reading KEY-LIST interactively, this command temporarily enables
+menu items or tool-bar buttons that are disabled to allow getting help
+on them.
+
+BUFFER is the buffer in which to lookup those keys; it defaults to the
+current buffer."
+ (declare (advertised-calling-convention (key-list &optional buffer) "27.1"))
+ (interactive (list (help--read-key-sequence)))
+ (when (arrayp key-list)
+ ;; Compatibility with old calling convention.
+ (setq key-list (cons (list key-list) (if up-event (list up-event))))
+ (when buffer
+ (let ((raw (if (numberp buffer) (this-single-command-raw-keys) buffer)))
+ (setf (cdar (last key-list)) raw)))
+ (setq buffer nil))
+ (let* ((buf (or buffer (current-buffer)))
+ (on-link
+ (mapcar (lambda (kr)
+ (let ((raw (cdr kr)))
+ (and (not (memq mouse-1-click-follows-link '(nil double)))
+ (> (length raw) 0)
+ (eq (car-safe (aref raw 0)) 'mouse-1)
+ (with-current-buffer buf
+ (mouse-on-link-p (event-start (aref raw 0)))))))
+ key-list))
+ (info-list
+ (help--filter-info-list
+ (with-current-buffer buf
+ (mapcar (lambda (x)
+ (pcase-let* ((`(,seq . ,raw-seq) x)
+ (`(,brief-desc ,defn ,event ,_mouse-msg)
+ (help--analyze-key seq raw-seq))
+ (locus
+ (help--binding-locus
+ seq (event-start event))))
+ `(,seq ,brief-desc ,defn ,locus)))
+ key-list))
+ 2)))
+ (help-setup-xref (list (lambda (key-list buf)
+ (describe-key key-list
+ (if (buffer-live-p buf) buf)))
+ key-list buf)
+ (called-interactively-p 'interactive))
+ (if (and (<= (length info-list) 1)
+ (help--binding-undefined-p (nth 2 (car info-list))))
+ (message "%s" (nth 1 (car info-list)))
(with-help-window (help-buffer)
- (princ brief-desc)
- (let ((key-locus (help--binding-locus key (event-start event))))
- (when key-locus
- (princ (format " (found in %s)" key-locus))))
- (princ ", which is ")
- (describe-function-1 defn)
- (when (vectorp key)
- (let* ((last (1- (length key)))
- (elt (aref key last))
- (elt-1 (if (listp elt) (copy-sequence elt) elt))
- key-1 down-event-type)
- (when (and (listp elt-1)
- (symbolp (car elt-1))
- (setq down-event-type (help-downify-mouse-event-type
- (car elt-1))))
- (setcar elt-1 down-event-type)
- (setq key-1 (vector elt-1))
- (when (key-binding key-1)
- (princ (format "
-
-For documentation of the corresponding mouse down event <%s>,
-click and hold the mouse button longer than %s second(s)."
- down-event-type (if (numberp double-click-time)
- (/ double-click-time 1000.0)
- 3)))))))
- (when up-event
- (unless (or (null defn-up)
- (integerp defn-up)
- (equal defn-up 'undefined))
- (princ (format "
-
------------------ up-event %s----------------
-
-%s%s%s runs the command %S%s, which is "
- (if mouse-1-tricky "(short click) " "")
- (key-description (vector up-event))
- mouse-msg
- (if mouse-1-remapped
- " is remapped to <mouse-2>, which" "")
- defn-up (if key-locus-up
- (format " (found in %s)" key-locus-up)
- "")))
- (describe-function-1 defn-up))
- (unless (or (null defn-up-tricky)
- (integerp defn-up-tricky)
- (eq defn-up-tricky 'undefined))
- (princ (format "
-
------------------ up-event (long click) ----------------
-
-Pressing <%S>%s for longer than %d milli-seconds
-runs the command %S%s, which is "
- ev-type mouse-msg
- mouse-1-click-follows-link
- defn-up-tricky (if key-locus-up-tricky
- (format " (found in %s)" key-locus-up-tricky)
- "")))
- (describe-function-1 defn-up-tricky)))))))
+ (when (> (length info-list) 1)
+ ;; FIXME: Make this into clickable hyperlinks.
+ (princ "There were several key-sequences:\n\n")
+ (princ (mapconcat (lambda (info)
+ (pcase-let ((`(,_seq ,brief-desc ,_defn ,_locus)
+ info))
+ (concat " " brief-desc)))
+ info-list
+ "\n"))
+ (when (delq nil on-link)
+ (princ "\n\nThose are influenced by `mouse-1-click-follows-link'"))
+ (princ "\n\nThey're all described below."))
+ (pcase-dolist (`(,_seq ,brief-desc ,defn ,locus)
+ info-list)
+ (when defn
+ (when (> (length info-list) 1)
+ (with-current-buffer standard-output
+ (insert "\n\n"
+ ;; FIXME: Can't use eval-when-compile because purified
+ ;; strings lose their text properties :-(
+ (propertize "\n" 'face '(:height 0.1 :inverse-video t))
+ "\n")))
+
+ (princ brief-desc)
+ (when locus
+ (princ (format " (found in %s)" locus)))
+ (princ ", which is ")
+ (describe-function-1 defn)))))))
(defun describe-mode (&optional buffer)
"Display documentation of current major mode and minor modes.
@@ -970,6 +907,10 @@ documentation for the major and minor modes of that buffer."
(push (list fmode pretty-minor-mode
(format-mode-line (assq mode minor-mode-alist)))
minor-modes)))))
+ ;; Narrowing is not a minor mode, but its indicator is part of
+ ;; mode-line-modes.
+ (when (buffer-narrowed-p)
+ (push '(narrow-to-region "Narrow" " Narrow") minor-modes))
(setq minor-modes
(sort minor-modes
(lambda (a b) (string-lessp (cadr a) (cadr b)))))
@@ -1029,6 +970,13 @@ documentation for the major and minor modes of that buffer."
;; For the sake of IELM and maybe others
nil)
+(defun search-forward-help-for-help ()
+ "Search forward \"help window\"."
+ (interactive)
+ ;; Move cursor to the "help window".
+ (pop-to-buffer " *Metahelp*")
+ ;; Do incremental search forward.
+ (isearch-forward nil t))
(defun describe-minor-mode (minor-mode)
"Display documentation of a minor mode given as MINOR-MODE.
@@ -1118,9 +1066,12 @@ is currently activated with completion."
(setq minor-modes (cdr minor-modes)))))
result))
+(declare-function x-display-pixel-height "xfns.c" (&optional terminal))
+(declare-function x-display-pixel-width "xfns.c" (&optional terminal))
+
;;; Automatic resizing of temporary buffers.
(defcustom temp-buffer-max-height
- (lambda (buffer)
+ (lambda (_buffer)
(if (and (display-graphic-p) (eq (selected-window) (frame-root-window)))
(/ (x-display-pixel-height) (frame-char-height) 2)
(/ (- (frame-height) 2) 2)))
@@ -1137,7 +1088,7 @@ function is called, the window to be resized is selected."
:version "24.3")
(defcustom temp-buffer-max-width
- (lambda (buffer)
+ (lambda (_buffer)
(if (and (display-graphic-p) (eq (selected-window) (frame-root-window)))
(/ (x-display-pixel-width) (frame-char-width) 2)
(/ (- (frame-width) 2) 2)))
@@ -1155,9 +1106,6 @@ function is called, the window to be resized is selected."
(define-minor-mode temp-buffer-resize-mode
"Toggle auto-resizing temporary buffer windows (Temp Buffer Resize Mode).
-With a prefix argument ARG, enable Temp Buffer Resize mode if ARG
-is positive, and disable it otherwise. If called from Lisp,
-enable the mode if ARG is omitted or nil.
When Temp Buffer Resize mode is enabled, the windows in which we
show a temporary buffer are automatically resized in height to
diff --git a/lisp/hexl.el b/lisp/hexl.el
index 000e79566a2..c1c2d70daf5 100644
--- a/lisp/hexl.el
+++ b/lisp/hexl.el
@@ -58,53 +58,45 @@
(const 16)
(const 32)
(const 64))
- :group 'hexl
:version "24.3")
(defcustom hexl-program "hexl"
"The program that will hexlify and dehexlify its stdin.
`hexl-program' will always be concatenated with `hexl-options'
and \"-de\" when dehexlifying a buffer."
- :type 'string
- :group 'hexl)
+ :type 'string)
(defcustom hexl-iso ""
"If your Emacs can handle ISO characters, this should be set to
\"-iso\" otherwise it should be \"\"."
- :type 'string
- :group 'hexl)
+ :type 'string)
(defcustom hexl-options (format "-hex %s" hexl-iso)
"Space separated options to `hexl-program' that suit your needs.
Quoting cannot be used, so the arguments cannot themselves contain spaces.
If you wish to set the `-group-by-X-bits' options, set `hexl-bits' instead,
as that will override any bit grouping options set here."
- :type 'string
- :group 'hexl)
+ :type 'string)
(defcustom hexl-follow-ascii t
"If non-nil then highlight the ASCII character corresponding to point."
:type 'boolean
- :group 'hexl
:version "20.3")
(defcustom hexl-mode-hook '(hexl-follow-line hexl-activate-ruler)
"Normal hook run when entering Hexl mode."
:type 'hook
- :options '(hexl-follow-line hexl-activate-ruler eldoc-mode)
- :group 'hexl)
+ :options '(hexl-follow-line hexl-activate-ruler eldoc-mode))
(defface hexl-address-region
'((t (:inherit header-line)))
- "Face used in address area of Hexl mode buffer."
- :group 'hexl)
+ "Face used in address area of Hexl mode buffer.")
(defface hexl-ascii-region
'((t (:inherit header-line)))
- "Face used in ASCII area of Hexl mode buffer."
- :group 'hexl)
+ "Face used in ASCII area of Hexl mode buffer.")
-(defvar hexl-max-address 0
+(defvar-local hexl-max-address 0
"Maximum offset into hexl buffer.")
(defvar hexl-mode-map
@@ -252,24 +244,6 @@ as that will override any bit grouping options set here."
"The length of a hexl display line (varies with `hexl-bits')."
(+ 60 (/ 128 (or hexl-bits 16))))
-(defun hexl-mode--minor-mode-p (var)
- (memq var '(ruler-mode hl-line-mode)))
-
-(defun hexl-mode--setq-local (var val)
- ;; `var' can be either a symbol or a pair, in which case the `car'
- ;; is the getter function and the `cdr' is the corresponding setter.
- (unless (or (member var hexl-mode--old-var-vals)
- (assoc var hexl-mode--old-var-vals))
- (push (if (or (consp var) (boundp var))
- (cons var
- (if (consp var) (funcall (car var)) (symbol-value var)))
- var)
- hexl-mode--old-var-vals))
- (cond
- ((consp var) (funcall (cdr var) val))
- ((hexl-mode--minor-mode-p var) (funcall var (if val 1 -1)))
- (t (set (make-local-variable var) val))))
-
;;;###autoload
(defun hexl-mode (&optional arg)
"\\<hexl-mode-map>A mode for editing binary files in hex dump format.
@@ -364,35 +338,33 @@ You can use \\[hexl-find-file] to visit a file in Hexl mode.
(or (bolp) (setq original-point (1- original-point))))
(hexlify-buffer)
(restore-buffer-modified-p modified))
- (set (make-local-variable 'hexl-max-address)
- (+ (* (/ (1- (buffer-size)) (hexl-line-displen)) 16) 15))
+ (setq hexl-max-address
+ (+ (* (/ (1- (buffer-size)) (hexl-line-displen)) 16) 15))
(condition-case nil
(hexl-goto-address original-point)
(error nil)))
- ;; We do not turn off the old major mode; instead we just
- ;; override most of it. That way, we can restore it perfectly.
+ (let ((max-address hexl-max-address))
+ (major-mode-suspend)
+ (setq hexl-max-address max-address))
- (hexl-mode--setq-local '(current-local-map . use-local-map) hexl-mode-map)
+ (use-local-map hexl-mode-map)
- (hexl-mode--setq-local 'mode-name "Hexl")
- (hexl-mode--setq-local 'isearch-search-fun-function
- 'hexl-isearch-search-function)
- (hexl-mode--setq-local 'major-mode 'hexl-mode)
+ (setq-local mode-name "Hexl")
+ (setq-local isearch-search-fun-function #'hexl-isearch-search-function)
+ (setq-local major-mode 'hexl-mode)
- (hexl-mode--setq-local '(syntax-table . set-syntax-table)
- (standard-syntax-table))
+ ;; (set-syntax-table (standard-syntax-table))
- (add-hook 'write-contents-functions 'hexl-save-buffer nil t)
+ (add-hook 'write-contents-functions #'hexl-save-buffer nil t)
- (hexl-mode--setq-local 'require-final-newline nil)
+ (setq-local require-final-newline nil)
- (hexl-mode--setq-local 'font-lock-defaults '(hexl-font-lock-keywords t))
+ (setq-local font-lock-defaults '(hexl-font-lock-keywords t))
- (hexl-mode--setq-local 'revert-buffer-function
- #'hexl-revert-buffer-function)
- (add-hook 'change-major-mode-hook 'hexl-maybe-dehexlify-buffer nil t)
+ (setq-local revert-buffer-function #'hexl-revert-buffer-function)
+ (add-hook 'change-major-mode-hook #'hexl-maybe-dehexlify-buffer nil t)
;; Set a callback function for eldoc.
(add-function :before-until (local 'eldoc-documentation-function)
@@ -401,7 +373,7 @@ You can use \\[hexl-find-file] to visit a file in Hexl mode.
(eldoc-remove-command "hexl-save-buffer"
"hexl-current-address")
- (if hexl-follow-ascii (hexl-follow-ascii 1)))
+ (if hexl-follow-ascii (hexl-follow-ascii-mode 1)))
(run-mode-hooks 'hexl-mode-hook))
@@ -469,6 +441,7 @@ and edit the file in `hexl-mode'."
(hexl-mode)))
(defun hexl-revert-buffer-function (_ignore-auto _noconfirm)
+ ;; FIXME: We don't obey revert-buffer-preserve-modes!
(let ((coding-system-for-read 'no-conversion)
revert-buffer-function)
;; Call the original `revert-buffer' without code conversion; also
@@ -481,7 +454,7 @@ and edit the file in `hexl-mode'."
;; already hexl-mode.
;; 2. reset change-major-mode-hook in case that `hexl-mode'
;; previously added hexl-maybe-dehexlify-buffer to it.
- (remove-hook 'change-major-mode-hook 'hexl-maybe-dehexlify-buffer t)
+ (remove-hook 'change-major-mode-hook #'hexl-maybe-dehexlify-buffer t)
(setq major-mode 'fundamental-mode)
(hexl-mode)))
@@ -494,7 +467,7 @@ With arg, don't unhexlify buffer."
(inhibit-read-only t)
(original-point (1+ (hexl-current-address))))
(dehexlify-buffer)
- (remove-hook 'write-contents-functions 'hexl-save-buffer t)
+ (remove-hook 'write-contents-functions #'hexl-save-buffer t)
(restore-buffer-modified-p modified)
(goto-char original-point)
;; Maybe adjust point for the removed CR characters.
@@ -504,27 +477,8 @@ With arg, don't unhexlify buffer."
(or (bobp) (setq original-point (1+ original-point))))
(goto-char original-point)))
- (remove-hook 'change-major-mode-hook 'hexl-maybe-dehexlify-buffer t)
- (remove-hook 'post-command-hook 'hexl-follow-ascii-find t)
- (setq hexl-ascii-overlay nil)
-
- (let ((mms ()))
- (dolist (varval hexl-mode--old-var-vals)
- (let* ((bound (consp varval))
- (var (if bound (car varval) varval))
- (val (cdr-safe varval)))
- (cond
- ((consp var) (funcall (cdr var) val))
- ((hexl-mode--minor-mode-p var) (push (cons var val) mms))
- (bound (set (make-local-variable var) val))
- (t (kill-local-variable var)))))
- (kill-local-variable 'hexl-mode--old-var-vals)
- ;; Enable/disable minor modes. Do it after having reset the other vars,
- ;; since some of them may affect the minor modes.
- (dolist (mm mms)
- (funcall (car mm) (if (cdr mm) 1 -1))))
-
- (force-mode-line-update))
+ (remove-hook 'change-major-mode-hook #'hexl-maybe-dehexlify-buffer t)
+ (major-mode-restore))
(defun hexl-maybe-dehexlify-buffer ()
"Convert a hexl format buffer to binary.
@@ -534,7 +488,7 @@ Ask the user for confirmation."
(inhibit-read-only t)
(original-point (1+ (hexl-current-address))))
(dehexlify-buffer)
- (remove-hook 'write-contents-functions 'hexl-save-buffer t)
+ (remove-hook 'write-contents-functions #'hexl-save-buffer t)
(restore-buffer-modified-p modified)
(goto-char original-point))))
@@ -1041,48 +995,49 @@ Embedded whitespace, dashes, and periods in the string are ignored."
(error "Decimal number out of range")
(hexl-insert-multibyte-char num arg))))
-(defun hexl-follow-ascii (&optional arg)
- "Toggle following ASCII in Hexl buffers.
-With prefix ARG, turn on following if and only if ARG is positive.
+(define-minor-mode hexl-follow-ascii-mode
+ "Minor mode to follow ASCII in current Hexl buffer.
+
When following is enabled, the ASCII character corresponding to the
element under the point is highlighted.
-Customize the variable `hexl-follow-ascii' to disable this feature."
- (interactive "P")
+The default activation is controlled by `hexl-follow-ascii'."
+ :global nil
+ (if hexl-follow-ascii-mode
+ ;; turn it on
+ (progn
+ (unless hexl-ascii-overlay
+ (setq hexl-ascii-overlay (make-overlay (point) (point)))
+ (overlay-put hexl-ascii-overlay 'face 'highlight))
+ (add-hook 'post-command-hook #'hexl-follow-ascii-find nil t))
+ ;; turn it off
+ (when hexl-ascii-overlay
+ (delete-overlay hexl-ascii-overlay)
+ (setq hexl-ascii-overlay nil))
+ (remove-hook 'post-command-hook #'hexl-follow-ascii-find t)))
+
+(define-minor-mode hexl-follow-ascii
+ "Toggle following ASCII in Hexl buffers.
+Like `hexl-follow-ascii-mode' but remembers the choice globally."
+ :global t
(let ((on-p (if arg
(> (prefix-numeric-value arg) 0)
(not hexl-ascii-overlay))))
-
- (if on-p
- ;; turn it on
- (if (not hexl-ascii-overlay)
- (progn
- (setq hexl-ascii-overlay (make-overlay 1 1)
- hexl-follow-ascii t)
- (overlay-put hexl-ascii-overlay 'face 'highlight)
- (add-hook 'post-command-hook 'hexl-follow-ascii-find nil t)))
- ;; turn it off
- (if hexl-ascii-overlay
- (progn
- (delete-overlay hexl-ascii-overlay)
- (setq hexl-ascii-overlay nil
- hexl-follow-ascii nil)
- (remove-hook 'post-command-hook 'hexl-follow-ascii-find t)
- )))))
+ (hexl-follow-ascii-mode (if on-p 1 -1))
+ ;; Remember this choice globally for later use.
+ (setq hexl-follow-ascii hexl-follow-ascii-mode)))
(defun hexl-activate-ruler ()
"Activate `ruler-mode'."
(require 'ruler-mode)
- (hexl-mode--setq-local 'ruler-mode-ruler-function
- #'hexl-mode-ruler)
- (hexl-mode--setq-local 'ruler-mode t))
+ (setq-local ruler-mode-ruler-function #'hexl-mode-ruler)
+ (ruler-mode 1))
(defun hexl-follow-line ()
"Activate `hl-line-mode'."
(require 'hl-line)
- (hexl-mode--setq-local 'hl-line-range-function
- #'hexl-highlight-line-range)
- (hexl-mode--setq-local 'hl-line-face 'highlight)
- (hexl-mode--setq-local 'hl-line-mode t))
+ (setq-local hl-line-range-function #'hexl-highlight-line-range)
+ (setq-local hl-line-face 'highlight) ;FIXME: Why?
+ (hl-line-mode 1))
(defun hexl-highlight-line-range ()
"Return the range of address region for the point.
@@ -1134,7 +1089,7 @@ This function is assumed to be used as callback function for `hl-line-mode'."
;; startup stuff.
(easy-menu-define hexl-menu hexl-mode-map "Hexl Mode menu"
- `("Hexl"
+ '("Hexl"
:help "Hexl-specific Features"
["Backward short" hexl-backward-short
diff --git a/lisp/hfy-cmap.el b/lisp/hfy-cmap.el
index 310805652f2..a34efa60b4e 100644
--- a/lisp/hfy-cmap.el
+++ b/lisp/hfy-cmap.el
@@ -1,15 +1,15 @@
-;;; hfy-cmap.el --- Fallback colour name -> rgb mapping for `htmlfontify'
+;;; hfy-cmap.el --- Fallback color name -> rgb mapping for `htmlfontify'
;; Copyright (C) 2002-2003, 2009-2019 Free Software Foundation, Inc.
;; Emacs Lisp Archive Entry
;; Package: htmlfontify
;; Filename: hfy-cmap.el
-;; Keywords: colour, rgb
+;; Keywords: color, rgb
;; Author: Vivek Dasmohapatra <vivek@etla.org>
;; Maintainer: Vivek Dasmohapatra <vivek@etla.org>
;; Created: 2002-01-20
-;; Description: fallback code for colour name -> rgb mapping
+;; Description: fallback code for color name -> rgb mapping
;; URL: http://rtfm.etla.org/emacs/htmlfontify/
;; Last-Updated: Sat 2003-02-15 03:49:32 +0000
@@ -32,7 +32,11 @@
;;; Code:
-(defconst hfy-fallback-colour-map
+(define-obsolete-variable-alias
+ 'hfy-fallback-colour-map
+ 'hfy-fallback-color-map "27.1")
+
+(defconst hfy-fallback-color-map
'(("snow" 65535 64250 64250)
("ghost white" 63736 63736 65535)
("GhostWhite" 63736 63736 65535)
@@ -786,7 +790,11 @@
("light green" 37008 61166 37008)
("LightGreen" 37008 61166 37008)) )
-(defvar hfy-rgb-txt-colour-map nil)
+(define-obsolete-variable-alias
+ 'hfy-rgb-txt-colour-map
+ 'hfy-rgb-txt-color-map "27.1")
+
+(defvar hfy-rgb-txt-color-map nil)
(defvar hfy-rgb-load-path
(list "/etc/X11"
@@ -806,8 +814,8 @@
(defun htmlfontify-load-rgb-file (&optional file)
"Load an X11 style rgb.txt FILE.
Search `hfy-rgb-load-path' if FILE is not specified.
-Loads the variable `hfy-rgb-txt-colour-map', which is used by
-`hfy-fallback-colour-values'."
+Loads the variable `hfy-rgb-txt-color-map', which is used by
+`hfy-fallback-color-values'."
(interactive
(list
(read-file-name "rgb.txt (equivalent) file: " "" nil t (hfy-rgb-file))))
@@ -822,25 +830,28 @@ Loads the variable `hfy-rgb-txt-colour-map', which is used by
(htmlfontify-unload-rgb-file)
(while (/= end-of-rgb 1)
(if (looking-at hfy-rgb-regex)
- (setq hfy-rgb-txt-colour-map
+ (setq hfy-rgb-txt-color-map
(cons (list (match-string 4)
(string-to-number (match-string 1))
(string-to-number (match-string 2))
(string-to-number (match-string 3)))
- hfy-rgb-txt-colour-map)) )
+ hfy-rgb-txt-color-map)) )
(setq end-of-rgb (forward-line)))
(kill-buffer rgb-buffer)))))
(defun htmlfontify-unload-rgb-file ()
"Unload the current color name -> rgb translation map."
(interactive)
- (setq hfy-rgb-txt-colour-map nil))
+ (setq hfy-rgb-txt-color-map nil))
;;;###autoload
-(defun hfy-fallback-colour-values (colour-string)
+(defun hfy-fallback-color-values (color-string)
"Use a fallback method for obtaining the rgb values for a color."
- (cdr (assoc-string colour-string (or hfy-rgb-txt-colour-map
- hfy-fallback-colour-map))) )
+ (cdr (assoc-string color-string (or hfy-rgb-txt-color-map
+ hfy-fallback-color-map))) )
+(define-obsolete-function-alias
+ 'hfy-fallback-colour-values
+ 'hfy-fallback-color-values "27.1")
(provide 'hfy-cmap)
diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el
index b02fbc905b5..c2568a518cb 100644
--- a/lisp/hi-lock.el
+++ b/lisp/hi-lock.el
@@ -177,6 +177,26 @@ Instead, each hi-lock command will cycle through the faces in
"Face for hi-lock mode."
:group 'hi-lock-faces)
+(defface hi-salmon
+ '((((min-colors 88) (background dark))
+ (:background "light salmon" :foreground "black"))
+ (((background dark)) (:background "red" :foreground "black"))
+ (((min-colors 88)) (:background "light salmon"))
+ (t (:background "red")))
+ "Face for hi-lock mode."
+ :group 'hi-lock-faces
+ :version "27.1")
+
+(defface hi-aquamarine
+ '((((min-colors 88) (background dark))
+ (:background "aquamarine" :foreground "black"))
+ (((background dark)) (:background "blue" :foreground "black"))
+ (((min-colors 88)) (:background "aquamarine"))
+ (t (:background "blue")))
+ "Face for hi-lock mode."
+ :group 'hi-lock-faces
+ :version "27.1")
+
(defface hi-black-b
'((t (:weight bold)))
"Face for hi-lock mode."
@@ -189,13 +209,13 @@ Instead, each hi-lock command will cycle through the faces in
:group 'hi-lock-faces)
(defface hi-green-b
- '((((min-colors 88)) (:weight bold :foreground "green1"))
+ '((((min-colors 88)) (:weight bold :foreground "green3"))
(t (:weight bold :foreground "green")))
"Face for hi-lock mode."
:group 'hi-lock-faces)
(defface hi-red-b
- '((((min-colors 88)) (:weight bold :foreground "red1"))
+ '((((min-colors 88)) (:weight bold :foreground "firebrick2"))
(t (:weight bold :foreground "red")))
"Face for hi-lock mode."
:group 'hi-lock-faces)
@@ -216,8 +236,8 @@ Instead, each hi-lock command will cycle through the faces in
(define-obsolete-variable-alias 'hi-lock-face-history
'hi-lock-face-defaults "23.1")
(defvar hi-lock-face-defaults
- '("hi-yellow" "hi-pink" "hi-green" "hi-blue" "hi-black-b"
- "hi-blue-b" "hi-red-b" "hi-green-b" "hi-black-hb")
+ '("hi-yellow" "hi-pink" "hi-green" "hi-blue" "hi-salmon" "hi-aquamarine"
+ "hi-black-b" "hi-blue-b" "hi-red-b" "hi-green-b" "hi-black-hb")
"Default faces for hi-lock interactive functions.")
(define-obsolete-variable-alias 'hi-lock-regexp-history
@@ -289,9 +309,6 @@ a library is being loaded.")
;;;###autoload
(define-minor-mode hi-lock-mode
"Toggle selective highlighting of patterns (Hi Lock mode).
-With a prefix argument ARG, enable Hi Lock mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Hi Lock mode is automatically enabled when you invoke any of the
highlighting commands listed below, such as \\[highlight-regexp].
@@ -432,10 +449,12 @@ highlighting will not update as you type."
;;;###autoload
(defalias 'highlight-regexp 'hi-lock-face-buffer)
;;;###autoload
-(defun hi-lock-face-buffer (regexp &optional face)
+(defun hi-lock-face-buffer (regexp &optional face subexp)
"Set face of each match of REGEXP to FACE.
Interactively, prompt for REGEXP using `read-regexp', then FACE.
-Use the global history list for FACE.
+Use the global history list for FACE. Limit face setting to the
+corresponding SUBEXP (interactively, the prefix argument) of REGEXP.
+If SUBEXP is omitted or nil, the entire REGEXP is highlighted.
Use Font lock mode, if enabled, to highlight REGEXP. Otherwise,
use overlays for highlighting. If overlays are used, the
@@ -444,10 +463,11 @@ highlighting will not update as you type."
(list
(hi-lock-regexp-okay
(read-regexp "Regexp to highlight" 'regexp-history-last))
- (hi-lock-read-face-name)))
+ (hi-lock-read-face-name)
+ current-prefix-arg))
(or (facep face) (setq face 'hi-yellow))
(unless hi-lock-mode (hi-lock-mode 1))
- (hi-lock-set-pattern regexp face))
+ (hi-lock-set-pattern regexp face subexp))
;;;###autoload
(defalias 'highlight-phrase 'hi-lock-face-phrase-buffer)
@@ -559,7 +579,7 @@ then remove all hi-lock highlighting."
(x-popup-menu
t
(cons
- `keymap
+ 'keymap
(cons "Select Pattern to Unhighlight"
(mapcar (lambda (pattern)
(list (car pattern)
@@ -689,11 +709,14 @@ with completion and history."
(add-to-list 'hi-lock-face-defaults face t))
(intern face)))
-(defun hi-lock-set-pattern (regexp face)
- "Highlight REGEXP with face FACE."
+(defun hi-lock-set-pattern (regexp face &optional subexp)
+ "Highlight SUBEXP of REGEXP with face FACE.
+If omitted or nil, SUBEXP defaults to zero, i.e. the entire
+REGEXP is highlighted."
;; Hashcons the regexp, so it can be passed to remove-overlays later.
(setq regexp (hi-lock--hashcons regexp))
- (let ((pattern (list regexp (list 0 (list 'quote face) 'prepend)))
+ (setq subexp (or subexp 0))
+ (let ((pattern (list regexp (list subexp (list 'quote face) 'prepend)))
(no-matches t))
;; Refuse to highlight a text that is already highlighted.
(if (assoc regexp hi-lock-interactive-patterns)
@@ -715,7 +738,8 @@ with completion and history."
(goto-char search-start)
(while (re-search-forward regexp search-end t)
(when no-matches (setq no-matches nil))
- (let ((overlay (make-overlay (match-beginning 0) (match-end 0))))
+ (let ((overlay (make-overlay (match-beginning subexp)
+ (match-end subexp))))
(overlay-put overlay 'hi-lock-overlay t)
(overlay-put overlay 'hi-lock-overlay-regexp regexp)
(overlay-put overlay 'face face))
diff --git a/lisp/hilit-chg.el b/lisp/hilit-chg.el
index d4d83902d97..272f7584bbe 100644
--- a/lisp/hilit-chg.el
+++ b/lisp/hilit-chg.el
@@ -204,9 +204,6 @@
:group 'highlight-changes)
;; A (not very good) default list of colors to rotate through.
-(define-obsolete-variable-alias 'highlight-changes-colours
- 'highlight-changes-colors "22.1")
-
(defcustom highlight-changes-colors
(if (eq (frame-parameter nil 'background-mode) 'light)
;; defaults for light background:
@@ -322,9 +319,6 @@ remove it from existing buffers."
;;;###autoload
(define-minor-mode highlight-changes-mode
"Toggle highlighting changes in this buffer (Highlight Changes mode).
-With a prefix argument ARG, enable Highlight Changes mode if ARG
-is positive, and disable it otherwise. If called from Lisp,
-enable the mode if ARG is omitted or nil.
When Highlight Changes is enabled, changes are marked with a text
property. Normally they are displayed in a distinctive face, but
@@ -363,9 +357,6 @@ buffer with the contents of a file
;;;###autoload
(define-minor-mode highlight-changes-visible-mode
"Toggle visibility of highlighting due to Highlight Changes mode.
-With a prefix argument ARG, enable Highlight Changes Visible mode
-if ARG is positive, and disable it otherwise. If called from
-Lisp, enable the mode if ARG is omitted or nil.
Highlight Changes Visible mode only has an effect when Highlight
Changes mode is on. When enabled, the changed text is displayed
diff --git a/lisp/hl-line.el b/lisp/hl-line.el
index 3abebe6c690..1c09bc26f68 100644
--- a/lisp/hl-line.el
+++ b/lisp/hl-line.el
@@ -132,9 +132,6 @@ This variable is expected to be made buffer-local by modes.")
;;;###autoload
(define-minor-mode hl-line-mode
"Toggle highlighting of the current line (Hl-Line mode).
-With a prefix argument ARG, enable Hl-Line mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Hl-Line mode is a buffer-local minor mode. If
`hl-line-sticky-flag' is non-nil, Hl-Line mode highlights the
@@ -203,9 +200,6 @@ such overlays in all buffers except the current one."
;;;###autoload
(define-minor-mode global-hl-line-mode
"Toggle line highlighting in all buffers (Global Hl-Line mode).
-With a prefix argument ARG, enable Global Hl-Line mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
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
diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el
index 93e8a8a1f79..9fc029ec583 100644
--- a/lisp/htmlfontify.el
+++ b/lisp/htmlfontify.el
@@ -448,6 +448,7 @@ and so on."
(background (choice (const :tag "Dark" dark )
(const :tag "Bright" light ))) ))
+(define-obsolete-variable-alias 'hfy-optimisations 'hfy-optimizations "25.1")
(defcustom hfy-optimizations (list 'keep-overlays)
"Optimizations to turn on: So far, the following have been implemented:\n
merge-adjacent-tags: If two (or more) span tags are adjacent, identical and
@@ -483,7 +484,6 @@ which can never slow you down, but may result in incomplete fontification."
(const :tag "body-text-only" body-text-only ))
:group 'htmlfontify
:tag "optimizations")
-(define-obsolete-variable-alias 'hfy-optimisations 'hfy-optimizations "25.1")
(defvar hfy-tags-cache nil
"Alist of the form:\n
@@ -584,22 +584,23 @@ therefore no longer care about) will be invalid at any time.\n
(if (memq elt set-b) (setq interq (cons elt interq))))
interq))
-(defun hfy-colour-vals (colour)
- "Where COLOUR is a color name or #XXXXXX style triplet, return a
+(defun hfy-color-vals (color)
+ "Where COLOR is a color name or #XXXXXX style triplet, return a
list of three (16 bit) rgb values for said color.\n
-If a window system is unavailable, calls `hfy-fallback-colour-values'."
- (if (string-match hfy-triplet-regex colour)
+If a window system is unavailable, calls `hfy-fallback-color-values'."
+ (if (string-match hfy-triplet-regex color)
(mapcar
- (lambda (x) (* (string-to-number (match-string x colour) 16) 257))
+ (lambda (x) (* (string-to-number (match-string x color) 16) 257))
'(1 2 3))
- ;;(message ">> %s" colour)
+ ;;(message ">> %s" color)
(if window-system
(if (fboundp 'color-values)
- (color-values colour)
+ (color-values color)
;;(message "[%S]" window-system)
- (x-color-values colour))
+ (x-color-values color))
;; blarg - tty colors are no good - go fetch some X colors:
- (hfy-fallback-colour-values colour))))
+ (hfy-fallback-color-values color))))
+(define-obsolete-function-alias 'hfy-colour-vals 'hfy-color-vals "27.1")
(defvar hfy-cperl-mode-kludged-p nil)
@@ -738,7 +739,7 @@ FILE is the name of the file being rendered, in case it is needed."
"Replace the end of a CSS style declaration STYLE-STRING with the contents
of the variable `hfy-src-doc-link-style', removing text matching the regex
`hfy-src-doc-link-unstyle' first, if necessary."
- ;;(message "hfy-colour-vals");;DBUG
+ ;;(message "hfy-color-vals");;DBUG
(if (string-match hfy-src-doc-link-unstyle style-string)
(setq style-string (replace-match "" 'fixed-case 'literal style-string)))
(if (and (not (string-match hfy-src-doc-link-style style-string))
@@ -751,19 +752,19 @@ of the variable `hfy-src-doc-link-style', removing text matching the regex
;; utility functions - cast emacs style specification values into their
;; css2 equivalents:
-(defun hfy-triplet (colour)
- "Takes a COLOUR name (string) and return a CSS rgb(R, G, B) triplet string.
+(defun hfy-triplet (color)
+ "Takes a COLOR name (string) and return a CSS rgb(R, G, B) triplet string.
Uses the definition of \"white\" to map the numbers to the 0-255 range, so
if you've redefined white, (esp. if you've redefined it to have a triplet
member lower than that of the color you are processing) strange things
may happen."
- ;;(message "hfy-colour-vals");;DBUG
+ ;;(message "hfy-color-vals");;DBUG
;; TODO? Can we do somehow do better than this?
(cond
- ((equal colour "unspecified-fg") (setq colour "black"))
- ((equal colour "unspecified-bg") (setq colour "white")))
- (let ((white (mapcar (lambda (I) (float (1+ I))) (hfy-colour-vals "white")))
- (rgb16 (mapcar (lambda (I) (float (1+ I))) (hfy-colour-vals colour))))
+ ((equal color "unspecified-fg") (setq color "black"))
+ ((equal color "unspecified-bg") (setq color "white")))
+ (let ((white (mapcar (lambda (I) (float (1+ I))) (hfy-color-vals "white")))
+ (rgb16 (mapcar (lambda (I) (float (1+ I))) (hfy-color-vals color))))
(if rgb16
;;(apply 'format "rgb(%d, %d, %d)"
;; Use #rrggbb instead, it is smaller
@@ -774,8 +775,9 @@ may happen."
'(0 1 2))))))
(defun hfy-family (family) (list (cons "font-family" family)))
-(defun hfy-bgcol (colour) (list (cons "background" (hfy-triplet colour))))
-(defun hfy-colour (colour) (list (cons "color" (hfy-triplet colour))))
+(defun hfy-bgcol (color) (list (cons "background" (hfy-triplet color))))
+(defun hfy-color (color) (list (cons "color" (hfy-triplet color))))
+(define-obsolete-function-alias 'hfy-colour 'hfy-color "27.1")
(defun hfy-width (width) (list (cons "font-stretch" (symbol-name width))))
(defcustom hfy-font-zoom 1.05
@@ -825,17 +827,17 @@ regular specifiers."
(let ((tag (car spec))
(val (cadr spec)))
(cons (cl-case tag
- (:color (cons "colour" val))
+ (:color (cons "color" val))
(:width (cons "width" val))
(:style (cons "style" val)))
(hfy-box-to-border-assoc (cddr spec))))))
(defun hfy-box-to-style (spec)
(let* ((css (hfy-box-to-border-assoc spec))
- (col (cdr (assoc "colour" css)))
+ (col (cdr (assoc "color" css)))
(s (cdr (assoc "style" css))))
(list
- (if col (cons "border-color" (cdr (assoc "colour" css))))
+ (if col (cons "border-color" (cdr (assoc "color" css))))
(cons "border-width" (format "%dpx" (or (cdr (assoc "width" css)) 1)))
(cons "border-style" (cl-case s
(released-button "outset")
@@ -1014,7 +1016,7 @@ merged by the user - `hfy-flatten-style' should do this."
(:width (hfy-width val))
(:weight (hfy-weight val))
(:slant (hfy-slant val))
- (:foreground (hfy-colour val))
+ (:foreground (hfy-color val))
(:background (hfy-bgcol val))
(:box (hfy-box val))
(:height (hfy-size val))
@@ -1828,10 +1830,11 @@ fontified. This is a simple convenience wrapper around
(noninteractive
(message "hfy batch mode (%s:%S)"
(or (buffer-file-name) (buffer-name)) major-mode)
- (if (fboundp 'font-lock-ensure)
+ (if (fboundp 'font-lock-ensure) ; Emacs >= 25.1
(font-lock-ensure)
(when font-lock-defaults
- (font-lock-fontify-buffer))))
+ ; Silence "interactive use only" warning on Emacs >= 25.1.
+ (with-no-warnings (font-lock-fontify-buffer)))))
((fboundp #'jit-lock-fontify-now)
(message "hfy jit-lock mode (%S %S)" window-system major-mode)
(jit-lock-fontify-now))
diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el
index 2e33d10c4c0..1b69574a392 100644
--- a/lisp/ibuf-ext.el
+++ b/lisp/ibuf-ext.el
@@ -403,10 +403,7 @@ format. See `ibuffer-update-saved-filters-format' and
;;;###autoload
(define-minor-mode ibuffer-auto-mode
- "Toggle use of Ibuffer's auto-update facility (Ibuffer Auto mode).
-With a prefix argument ARG, enable Ibuffer Auto mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil."
+ "Toggle use of Ibuffer's auto-update facility (Ibuffer Auto mode)."
nil nil nil
(unless (derived-mode-p 'ibuffer-mode)
(error "This buffer is not in Ibuffer mode"))
@@ -726,7 +723,7 @@ specification, with the same structure as an element of the list
(not
(not
(pcase (car filter)
- (`or
+ ('or
;;; ATTN: Short-circuiting alternative with parallel structure w/`and
;;(catch 'has-match
;; (dolist (filter-spec (cdr filter) nil)
@@ -735,12 +732,12 @@ specification, with the same structure as an element of the list
(memq t (mapcar #'(lambda (x)
(ibuffer-included-in-filter-p buf x))
(cdr filter))))
- (`and
+ ('and
(catch 'no-match
(dolist (filter-spec (cdr filter) t)
(unless (ibuffer-included-in-filter-p buf filter-spec)
(throw 'no-match nil)))))
- (`saved
+ ('saved
(let ((data (assoc (cdr filter) ibuffer-saved-filters)))
(unless data
(ibuffer-filter-disable t)
@@ -1033,8 +1030,11 @@ group definitions by setting `ibuffer-filter-groups' to nil."
(ibuffer-jump-to-buffer (buffer-name buf)))))
(defun ibuffer-push-filter (filter-specification)
- "Add FILTER-SPECIFICATION to `ibuffer-filtering-qualifiers'."
- (push filter-specification ibuffer-filtering-qualifiers))
+ "Add FILTER-SPECIFICATION to `ibuffer-filtering-qualifiers'.
+If FILTER-SPECIFICATION is already in the list then return nil. Otherwise,
+return the updated list."
+ (unless (member filter-specification ibuffer-filtering-qualifiers)
+ (push filter-specification ibuffer-filtering-qualifiers)))
;;;###autoload
(defun ibuffer-decompose-filter ()
@@ -1051,14 +1051,14 @@ turned into separate filters, like [name: foo] and [mode: bar-mode]."
(tail (cdr filters))
(value
(pcase (caar filters)
- ((or `or 'and) (nconc head tail))
- (`saved
+ ((or 'or 'and) (nconc head tail))
+ ('saved
(let ((data (assoc head ibuffer-saved-filters)))
(unless data
(ibuffer-filter-disable)
(error "Unknown saved filter %s" head))
(append (cdr data) tail)))
- (`not (cons (ibuffer-unary-operand (car filters)) tail))
+ ('not (cons (ibuffer-unary-operand (car filters)) tail))
(_
(error "Filter type %s is not compound" (caar filters))))))
(setq ibuffer-filtering-qualifiers value))
@@ -1197,12 +1197,12 @@ Interactively, prompt for NAME, and use the current filters."
(defun ibuffer-format-qualifier-1 (qualifier)
(pcase (car qualifier)
- (`saved
+ ('saved
(concat " [filter: " (cdr qualifier) "]"))
- (`or
+ ('or
(concat " [OR" (mapconcat #'ibuffer-format-qualifier
(cdr qualifier) "") "]"))
- (`and
+ ('and
(concat " [AND" (mapconcat #'ibuffer-format-qualifier
(cdr qualifier) "") "]"))
(_
@@ -1228,28 +1228,33 @@ If INCLUDE-PARENTS is non-nil then include parent modes."
;;;###autoload (autoload 'ibuffer-filter-by-mode "ibuf-ext")
(define-ibuffer-filter mode
- "Limit current view to buffers with major mode QUALIFIER."
+ "Limit current view to buffers with major mode(s) specified by QUALIFIER.
+QUALIFIER is the mode name as a symbol or a list of symbols.
+Called interactively, accept a comma separated list of mode names."
(:description "major mode"
:reader
(let* ((buf (ibuffer-current-buffer))
(default (if (and buf (buffer-live-p buf))
(symbol-name (buffer-local-value
'major-mode buf)))))
- (intern
- (completing-read
+ (mapcar #'intern
+ (completing-read-multiple
(if default
(format "Filter by major mode (default %s): " default)
"Filter by major mode: ")
obarray
- #'(lambda (e)
- (string-match "-mode\\'" (symbol-name e)))
- t nil nil default))))
+ (lambda (e)
+ (string-match "-mode\\'" (if (symbolp e) (symbol-name e) e)))
+ t nil nil default)))
+ :accept-list t)
(eq qualifier (buffer-local-value 'major-mode buf)))
;;;###autoload (autoload 'ibuffer-filter-by-used-mode "ibuf-ext")
(define-ibuffer-filter used-mode
- "Limit current view to buffers with major mode QUALIFIER.
-Called interactively, this function allows selection of modes
+ "Limit current view to buffers with major mode(s) specified by QUALIFIER.
+QUALIFIER is the mode name as a symbol or a list of symbols.
+
+Called interactively, accept a comma separated list of mode names
currently used by buffers."
(:description "major mode in use"
:reader
@@ -1257,23 +1262,29 @@ currently used by buffers."
(default (if (and buf (buffer-live-p buf))
(symbol-name (buffer-local-value
'major-mode buf)))))
- (intern
- (completing-read
+ (mapcar #'intern
+ (completing-read-multiple
(if default
(format "Filter by major mode (default %s): " default)
"Filter by major mode: ")
- (ibuffer-list-buffer-modes) nil t nil nil default))))
+ (ibuffer-list-buffer-modes) nil t nil nil default)))
+ :accept-list t)
(eq qualifier (buffer-local-value 'major-mode buf)))
;;;###autoload (autoload 'ibuffer-filter-by-derived-mode "ibuf-ext")
(define-ibuffer-filter derived-mode
- "Limit current view to buffers whose major mode inherits from QUALIFIER."
+ "Limit current view to buffers with major mode(s) specified by QUALIFIER.
+QUALIFIER is the mode name as a symbol or a list of symbols.
+ Restrict the view to buffers whose major mode derivates
+ from modes specified by QUALIFIER.
+Called interactively, accept a comma separated list of mode names."
(:description "derived mode"
- :reader
- (intern
- (completing-read "Filter by derived mode: "
- (ibuffer-list-buffer-modes t)
- nil t)))
+ :reader
+ (mapcar #'intern
+ (completing-read-multiple "Filter by derived mode: "
+ (ibuffer-list-buffer-modes t)
+ nil t))
+ :accept-list t)
(with-current-buffer buf (derived-mode-p qualifier)))
;;;###autoload (autoload 'ibuffer-filter-by-name "ibuf-ext")
@@ -1283,6 +1294,12 @@ currently used by buffers."
:reader (read-from-minibuffer "Filter by name (regexp): "))
(string-match qualifier (buffer-name buf)))
+;;;###autoload (autoload 'ibuffer-filter-by-process "ibuf-ext")
+(define-ibuffer-filter process
+ "Limit current view to buffers running a process."
+ (:description "process")
+ (get-buffer-process buf))
+
;;;###autoload (autoload 'ibuffer-filter-by-starred-name "ibuf-ext")
(define-ibuffer-filter starred-name
"Limit current view to buffers with name beginning and ending
@@ -1931,11 +1948,10 @@ Otherwise buffers whose name matches an element of
(ibuffer-mark-on-buffer
#'(lambda (buf)
(with-current-buffer buf
- ;; hacked from midnight.el
(when buffer-display-time
- (let* ((now (float-time))
- (then (float-time buffer-display-time)))
- (> (- now then) (* 60 60 ibuffer-old-time))))))))
+ (time-less-p
+ (* 60 60 ibuffer-old-time)
+ (time-since buffer-display-time)))))))
;;;###autoload
(defun ibuffer-mark-special-buffers ()
diff --git a/lisp/ibuf-macs.el b/lisp/ibuf-macs.el
index 69184604d0b..2b28f18da5c 100644
--- a/lisp/ibuf-macs.el
+++ b/lisp/ibuf-macs.el
@@ -280,14 +280,18 @@ buffer object.
;;;###autoload
(cl-defmacro define-ibuffer-filter (name documentation
- (&key
- reader
- description)
- &rest body)
+ (&key
+ reader
+ description
+ accept-list)
+ &rest body)
"Define a filter named NAME.
DOCUMENTATION is the documentation of the function.
READER is a form which should read a qualifier from the user.
DESCRIPTION is a short string describing the filter.
+ACCEPT-LIST is a boolean; if non-nil, the filter accepts either
+a single condition or a list of them; in the latter
+case the filter is the `or' composition of the conditions.
BODY should contain forms which will be evaluated to test whether or
not a particular buffer should be displayed or not. The forms in BODY
@@ -296,26 +300,41 @@ bound to the current value of the filter.
\(fn NAME DOCUMENTATION (&key READER DESCRIPTION) &rest BODY)"
(declare (indent 2) (doc-string 2))
- (let ((fn-name (intern (concat "ibuffer-filter-by-" (symbol-name name)))))
+ (let ((fn-name (intern (concat "ibuffer-filter-by-" (symbol-name name))))
+ (filter (make-symbol "ibuffer-filter"))
+ (qualifier-str (make-symbol "ibuffer-qualifier-str")))
`(progn
(defun ,fn-name (qualifier)
- ,(or documentation "This filter is not documented.")
- (interactive (list ,reader))
- (ibuffer-push-filter (cons ',name qualifier))
- (message "%s"
- (format ,(concat (format "Filter by %s added: " description)
- " %s")
- qualifier))
- (ibuffer-update nil t))
+ ,(or documentation "This filter is not documented.")
+ (interactive (list ,reader))
+ (let ((,filter (cons ',name qualifier))
+ (,qualifier-str qualifier))
+ ,(when accept-list
+ `(progn
+ (unless (listp qualifier) (setq qualifier (list qualifier)))
+ ;; Reject equivalent filters: (or f1 f2) is same as (or f2 f1).
+ (setq qualifier (sort (delete-dups qualifier) #'string-lessp))
+ (setq ,filter (cons ',name (car qualifier)))
+ (setq ,qualifier-str
+ (mapconcat (lambda (m) (if (symbolp m) (symbol-name m) m))
+ qualifier ","))
+ (when (cdr qualifier) ; Compose individual filters with `or'.
+ (setq ,filter `(or ,@(mapcar (lambda (m) (cons ',name m)) qualifier))))))
+ (if (null (ibuffer-push-filter ,filter))
+ (message ,(format "Filter by %s already applied: %%s" description)
+ ,qualifier-str)
+ (message ,(format "Filter by %s added: %%s" description)
+ ,qualifier-str)
+ (ibuffer-update nil t))))
(push (list ',name ,description
- (lambda (buf qualifier)
- (condition-case nil
- (progn ,@body)
- (error (ibuffer-pop-filter)
- (when (eq ',name 'predicate)
- (error "Wrong filter predicate: %S"
- qualifier))))))
- ibuffer-filtering-alist)
+ (lambda (buf qualifier)
+ (condition-case nil
+ (progn ,@body)
+ (error (ibuffer-pop-filter)
+ (when (eq ',name 'predicate)
+ (error "Wrong filter predicate: %S"
+ qualifier))))))
+ ibuffer-filtering-alist)
:autoload-end)))
(provide 'ibuf-macs)
diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el
index 66a7087b9b8..2d3c140536c 100644
--- a/lisp/ibuffer.el
+++ b/lisp/ibuffer.el
@@ -150,12 +150,12 @@ elisp byte-compiler."
:group 'ibuffer)
(defcustom ibuffer-fontification-alist
- `((10 buffer-read-only font-lock-constant-face)
+ '((10 buffer-read-only font-lock-constant-face)
(15 (and buffer-file-name
(string-match ibuffer-compressed-file-name-regexp
buffer-file-name))
font-lock-doc-face)
- (20 (string-match "^*" (buffer-name)) font-lock-keyword-face)
+ (20 (string-match "^\\*" (buffer-name)) font-lock-keyword-face)
(25 (and (string-match "^ " (buffer-name))
(null buffer-file-name))
italic)
@@ -224,14 +224,6 @@ view of the buffers."
:group 'ibuffer)
(defvar ibuffer-sorting-reversep nil)
-(defcustom ibuffer-elide-long-columns nil
- "If non-nil, then elide column entries which exceed their max length."
- :type 'boolean
- :group 'ibuffer)
-(make-obsolete-variable 'ibuffer-elide-long-columns
- "use the :elide argument of `ibuffer-formats'."
- "22.1")
-
(defcustom ibuffer-eliding-string "..."
"The string to use for eliding long columns."
:type 'string
@@ -349,15 +341,11 @@ directory, like `default-directory'."
:type 'regexp
:group 'ibuffer)
-(define-obsolete-variable-alias 'ibuffer-hooks 'ibuffer-hook "22.1")
-
(defcustom ibuffer-hook nil
"Hook run when `ibuffer' is called."
:type 'hook
:group 'ibuffer)
-(define-obsolete-variable-alias 'ibuffer-mode-hooks 'ibuffer-mode-hook "22.1")
-
(defcustom ibuffer-mode-hook nil
"Hook run upon entry into `ibuffer-mode'."
:type 'hook
@@ -522,6 +510,7 @@ directory, like `default-directory'."
(define-key map (kbd "/ m") 'ibuffer-filter-by-used-mode)
(define-key map (kbd "/ M") 'ibuffer-filter-by-derived-mode)
(define-key map (kbd "/ n") 'ibuffer-filter-by-name)
+ (define-key map (kbd "/ E") 'ibuffer-filter-by-process)
(define-key map (kbd "/ *") 'ibuffer-filter-by-starred-name)
(define-key map (kbd "/ f") 'ibuffer-filter-by-filename)
(define-key map (kbd "/ b") 'ibuffer-filter-by-basename)
@@ -956,7 +945,6 @@ directory, like `default-directory'."
(defvar ibuffer-compiled-formats nil)
(defvar ibuffer-cached-formats nil)
(defvar ibuffer-cached-eliding-string nil)
-(defvar ibuffer-cached-elide-long-columns 0)
(defvar ibuffer-sorting-functions-alist nil
"An alist of functions which describe how to sort buffers.
@@ -1603,7 +1591,7 @@ If point is on a group name, this function operates on that group."
(defun ibuffer-compile-make-eliding-form (strvar elide from-end-p)
(let ((ellipsis (propertize ibuffer-eliding-string 'font-lock-face 'bold)))
- (if (or elide (with-no-warnings ibuffer-elide-long-columns))
+ (if elide
`(if (> strlen 5)
,(if from-end-p
;; FIXME: this should probably also be using
@@ -1625,8 +1613,8 @@ If point is on a group name, this function operates on that group."
`(truncate-string-to-width ,strvar ,maxvar nil ?\s)))
(defun ibuffer-compile-make-format-form (strvar widthform alignment)
- (let* ((left `(make-string tmp2 ?\s))
- (right `(make-string (- tmp1 tmp2) ?\s)))
+ (let* ((left '(make-string tmp2 ?\s))
+ (right '(make-string (- tmp1 tmp2) ?\s)))
`(progn
(setq tmp1 ,widthform
tmp2 (/ tmp1 2))
@@ -1749,7 +1737,7 @@ If point is on a group name, this function operates on that group."
outforms)
(push `(setq str ,callform
,@(when strlen-used
- `(strlen (string-width str))))
+ '(strlen (string-width str))))
outforms)
(setq outforms
(append outforms
@@ -1803,9 +1791,6 @@ If point is on a group name, this function operates on that group."
(not (eq ibuffer-cached-formats ibuffer-formats))
(null ibuffer-cached-eliding-string)
(not (equal ibuffer-cached-eliding-string ibuffer-eliding-string))
- (eql 0 ibuffer-cached-elide-long-columns)
- (not (eql ibuffer-cached-elide-long-columns
- (with-no-warnings ibuffer-elide-long-columns)))
(and ext-loaded
(not (eq ibuffer-cached-filter-formats
ibuffer-filter-format-alist))
@@ -1814,8 +1799,7 @@ If point is on a group name, this function operates on that group."
(message "Formats have changed, recompiling...")
(ibuffer-recompile-formats)
(setq ibuffer-cached-formats ibuffer-formats
- ibuffer-cached-eliding-string ibuffer-eliding-string
- ibuffer-cached-elide-long-columns (with-no-warnings ibuffer-elide-long-columns))
+ ibuffer-cached-eliding-string ibuffer-eliding-string)
(when ext-loaded
(setq ibuffer-cached-filter-formats ibuffer-filter-format-alist))
(message "Formats have changed, recompiling...done"))))
@@ -2221,7 +2205,7 @@ the value of point at the beginning of the line for that buffer."
strname
(propertize strname 'mouse-face 'highlight 'keymap hmap)))
strname)))))
- (add-text-properties opos (point) `(ibuffer-title-header t))
+ (add-text-properties opos (point) '(ibuffer-title-header t))
(insert "\n")
;; Add the underlines
(let ((str (save-excursion
@@ -2271,7 +2255,7 @@ the value of point at the beginning of the line for that buffer."
align)
summary))))))
(point))
- `(ibuffer-summary t)))))
+ '(ibuffer-summary t)))))
(defun ibuffer-redisplay (&optional silent)
@@ -2760,7 +2744,6 @@ will be inserted before the group at point."
(set (make-local-variable 'ibuffer-compiled-formats) nil)
(set (make-local-variable 'ibuffer-cached-formats) nil)
(set (make-local-variable 'ibuffer-cached-eliding-string) nil)
- (set (make-local-variable 'ibuffer-cached-elide-long-columns) nil)
(set (make-local-variable 'ibuffer-current-format) nil)
(set (make-local-variable 'ibuffer-did-modification) nil)
(set (make-local-variable 'ibuffer-tmp-hide-regexps) nil)
diff --git a/lisp/icomplete.el b/lisp/icomplete.el
index aaacce154f8..10fd3a698c5 100644
--- a/lisp/icomplete.el
+++ b/lisp/icomplete.el
@@ -1,4 +1,4 @@
-;;; icomplete.el --- minibuffer completion incremental feedback
+;;; icomplete.el --- minibuffer completion incremental feedback -*- lexical-binding: t -*-
;; Copyright (C) 1992-1994, 1997, 1999, 2001-2019 Free Software
;; Foundation, Inc.
@@ -145,7 +145,7 @@ icompletion is occurring."
(defvar icomplete-minibuffer-map
(let ((map (make-sparse-keymap)))
- (define-key map [?\M-\t] 'minibuffer-force-complete)
+ (define-key map [?\M-\t] 'icomplete-force-complete)
(define-key map [?\C-j] 'icomplete-force-complete-and-exit)
(define-key map [?\C-.] 'icomplete-forward-completions)
(define-key map [?\C-,] 'icomplete-backward-completions)
@@ -162,6 +162,12 @@ the default otherwise."
(minibuffer-force-complete-and-exit)
(minibuffer-complete-and-exit)))
+(defun icomplete-force-complete ()
+ "Complete the icomplete minibuffer."
+ (interactive)
+ ;; We're not at all interested in cycling here (bug#34077).
+ (minibuffer-force-complete nil nil 'dont-cycle))
+
(defun icomplete-forward-completions ()
"Step forward completions by one entry.
Second entry becomes the first and can be selected with
@@ -194,9 +200,6 @@ Last entry becomes the first and can be selected with
;;;###autoload
(define-minor-mode icomplete-mode
"Toggle incremental minibuffer completion (Icomplete mode).
-With a prefix argument ARG, enable Icomplete mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
When this global minor mode is enabled, typing in the minibuffer
continuously displays a list of possible completions that match
@@ -371,8 +374,21 @@ If there are multiple possibilities, `icomplete-separator' separates them.
The displays for unambiguous matches have ` [Matched]' appended
\(whether complete or not), or ` [No matches]', if no eligible
matches exist."
- (let* ((minibuffer-completion-table candidates)
- (minibuffer-completion-predicate predicate)
+ (let* ((ignored-extension-re
+ (and minibuffer-completing-file-name
+ icomplete-with-completion-tables
+ completion-ignored-extensions
+ (concat "\\(?:\\`\\.\\./\\|"
+ (regexp-opt completion-ignored-extensions)
+ "\\)\\'")))
+ (minibuffer-completion-table candidates)
+ (minibuffer-completion-predicate
+ (if ignored-extension-re
+ (lambda (cand)
+ (and (not (string-match ignored-extension-re cand))
+ (or (null predicate)
+ (funcall predicate cand))))
+ predicate))
(md (completion--field-metadata (icomplete--field-beg)))
(comps (completion-all-sorted-completions
(icomplete--field-beg) (icomplete--field-end)))
@@ -383,11 +399,8 @@ matches exist."
;; `concat'/`mapconcat' is the slow part.
(if (not (consp comps))
(progn ;;(debug (format "Candidates=%S field=%S" candidates name))
- (format " %sNo matches%s" open-bracket close-bracket))
+ (format " %sNo matches%s" open-bracket close-bracket))
(if last (setcdr last nil))
- (when (and minibuffer-completing-file-name
- icomplete-with-completion-tables)
- (setq comps (completion-pcm--filename-try-filter comps)))
(let* ((most-try
(if (and base-size (> base-size 0))
(completion-try-completion
@@ -473,11 +486,11 @@ matches exist."
(if prefix-len (substring (car comps) prefix-len) (car comps))
comps (cdr comps))
(setq prospects-len
- (+ (string-width comp)
- (string-width icomplete-separator)
- prospects-len))
- (if (< prospects-len prospects-max)
- (push comp prospects)
+ (+ (string-width comp)
+ (string-width icomplete-separator)
+ prospects-len))
+ (if (< prospects-len prospects-max)
+ (push comp prospects)
(setq limit t))))
(setq prospects (nreverse prospects))
;; Decorate first of the prospects.
diff --git a/lisp/ido.el b/lisp/ido.el
index 73a6be08c22..08540145815 100644
--- a/lisp/ido.el
+++ b/lisp/ido.el
@@ -1135,6 +1135,9 @@ selected.")
(defvar ido-current-directory nil
"Current directory for `ido-find-file'.")
+(defvar ido-predicate nil
+ "Current completion predicate.")
+
(defvar ido-auto-merge-timer nil
"Delay timer for auto merge.")
@@ -1512,22 +1515,20 @@ Removes badly formatted data and ignored directories."
(files (cdr (cdr (car l)))))
(and
(stringp dir)
- (consp time)
- (cond
- ((integerp (car time))
- (and (/= (car time) 0)
- (integerp (car (cdr time)))
- (/= (car (cdr time)) 0)
- (ido-may-cache-directory dir)))
- ((eq (car time) 'ftp)
- (and (numberp (cdr time))
- (ido-is-ftp-directory dir)
- (ido-cache-ftp-valid (cdr time))))
- ((eq (car time) 'unc)
- (and (numberp (cdr time))
- (ido-is-unc-host dir)
- (ido-cache-unc-valid (cdr time))))
- (t nil))
+ (if (condition-case nil
+ (not (time-equal-p time 0))
+ (error))
+ (ido-may-cache-directory dir)
+ (and
+ (consp time)
+ (numberp (cdr time))
+ (cond
+ ((eq (car time) 'ftp)
+ (and (ido-is-ftp-directory dir)
+ (ido-cache-ftp-valid (cdr time))))
+ ((eq (car time) 'unc)
+ (and (ido-is-unc-host dir)
+ (ido-cache-unc-valid (cdr time)))))))
(let ((s files) (ok t))
(while s
(if (stringp (car s))
@@ -1579,10 +1580,7 @@ Removes badly formatted data and ignored directories."
(add-hook 'choose-completion-string-functions 'ido-choose-completion-string))
(define-minor-mode ido-everywhere
- "Toggle use of Ido for all buffer/file reading.
-With a prefix argument ARG, enable this feature if ARG is
-positive, and disable it otherwise. If called from Lisp,
-enable the mode if ARG is omitted or nil."
+ "Toggle use of Ido for all buffer/file reading."
:global t
:group 'ido
(remove-function read-file-name-function #'ido-read-file-name)
@@ -1690,27 +1688,27 @@ is enabled then some keybindings are changed in the keymap."
(when viper-p
(define-key map [remap viper-intercept-ESC-key] 'ignore))
(pcase ido-cur-item
- ((or `file `dir)
- (when ido-context-switch-command
- (define-key map "\C-x\C-b" ido-context-switch-command)
- (define-key map "\C-x\C-d" 'ignore))
- (when viper-p
- (define-key map [remap viper-backward-char]
- 'ido-delete-backward-updir)
- (define-key map [remap viper-del-backward-char-in-insert]
- 'ido-delete-backward-updir)
- (define-key map [remap viper-delete-backward-word]
- 'ido-delete-backward-word-updir))
- (set-keymap-parent map
- (if (eq ido-cur-item 'file)
- ido-file-completion-map
- ido-file-dir-completion-map)))
- (`buffer
- (when ido-context-switch-command
- (define-key map "\C-x\C-f" ido-context-switch-command))
- (set-keymap-parent map ido-buffer-completion-map))
- (_
- (set-keymap-parent map ido-common-completion-map)))
+ ((or 'file 'dir)
+ (when ido-context-switch-command
+ (define-key map "\C-x\C-b" ido-context-switch-command)
+ (define-key map "\C-x\C-d" 'ignore))
+ (when viper-p
+ (define-key map [remap viper-backward-char]
+ 'ido-delete-backward-updir)
+ (define-key map [remap viper-del-backward-char-in-insert]
+ 'ido-delete-backward-updir)
+ (define-key map [remap viper-delete-backward-word]
+ 'ido-delete-backward-word-updir))
+ (set-keymap-parent map
+ (if (eq ido-cur-item 'file)
+ ido-file-completion-map
+ ido-file-dir-completion-map)))
+ ('buffer
+ (when ido-context-switch-command
+ (define-key map "\C-x\C-f" ido-context-switch-command))
+ (set-keymap-parent map ido-buffer-completion-map))
+ (_
+ (set-keymap-parent map ido-common-completion-map)))
(setq ido-completion-map map)))
(defun ido-final-slash (dir &optional fix-it)
@@ -1750,7 +1748,8 @@ is enabled then some keybindings are changed in the keymap."
(ido-final-slash dir)
(not (ido-is-unc-host dir))
(file-directory-p dir)
- (> (nth 7 (file-attributes (file-truename dir))) ido-max-directory-size))))
+ (> (file-attribute-size (file-attributes (file-truename dir)))
+ ido-max-directory-size))))
(defun ido-set-current-directory (dir &optional subdir no-merge)
;; Set ido's current directory to DIR or DIR/SUBDIR
@@ -1793,11 +1792,8 @@ is enabled then some keybindings are changed in the keymap."
(defun ido-record-command (command arg)
"Add (COMMAND ARG) to `command-history' if `ido-record-commands' is non-nil."
- (if ido-record-commands ; FIXME: use `when' instead of `if'?
- (let ((cmd (list command arg)))
- (if (or (not command-history) ; FIXME: ditto
- (not (equal cmd (car command-history))))
- (setq command-history (cons cmd command-history))))))
+ (when ido-record-commands
+ (add-to-history 'command-history (list command arg))))
(defun ido-make-prompt (item prompt)
;; Make the prompt for ido-read-internal
@@ -3487,6 +3483,11 @@ it is put to the start of the list."
(if ido-temp-list
(nconc ido-temp-list ido-current-buffers)
(setq ido-temp-list ido-current-buffers))
+ (if ido-predicate
+ (setq ido-temp-list (seq-filter
+ (lambda (name)
+ (funcall ido-predicate (cons name (get-buffer name))))
+ ido-temp-list)))
(if default
(setq ido-temp-list
(cons default (delete default ido-temp-list))))
@@ -3608,7 +3609,7 @@ Uses and updates `ido-dir-file-cache'."
(ftp (ido-is-ftp-directory dir))
(unc (ido-is-unc-host dir))
(attr (if (or ftp unc) nil (file-attributes dir)))
- (mtime (nth 5 attr))
+ (mtime (file-attribute-modification-time attr))
valid)
(when cached ; should we use the cached entry ?
(cond
@@ -3620,8 +3621,7 @@ Uses and updates `ido-dir-file-cache'."
(ido-cache-unc-valid (cdr ctime)))))
(t
(if attr
- (setq valid (and (= (car ctime) (car mtime))
- (= (car (cdr ctime)) (car (cdr mtime))))))))
+ (setq valid (time-equal-p ctime mtime)))))
(unless valid
(setq ido-dir-file-cache (delq cached ido-dir-file-cache)
cached nil)))
@@ -3788,13 +3788,13 @@ frame, rather than all frames, regardless of value of `ido-all-frames'."
(not (and (eq ido-cur-item 'buffer)
ido-buffer-disable-smart-matches))
(not ido-enable-regexp)
- (not (string-match "$\\'" rex0))
+ (not (string-match "\\$\\'" rex0))
(concat "\\`" rex0 (if slash "/" "") "\\'")))
(suffix-re (and do-full slash
(not (and (eq ido-cur-item 'buffer)
ido-buffer-disable-smart-matches))
(not ido-enable-regexp)
- (not (string-match "$\\'" rex0))
+ (not (string-match "\\$\\'" rex0))
(concat rex0 "/\\'")))
(prefix-re (and full-re (not ido-enable-prefix)
(concat "\\`" rexq)))
@@ -3965,8 +3965,24 @@ If `ido-change-word-sub' cannot be found in WORD, return nil."
(exit-minibuffer)
t))
+;; This is a shameless copy of `switch-to-completions'.
+(defun ido-switch-to-completions ()
+ "Select the window showing `ido-completion-buffer'."
+ (interactive)
+ (let ((window (or (get-buffer-window ido-completion-buffer 0)
+ ;; Make sure we have a completions window.
+ (progn (ido-completion-help)
+ (get-buffer-window ido-completion-buffer 0)))))
+ (when window
+ (select-window window)
+ ;; In the new buffer, go to the first completion.
+ ;; FIXME: Perhaps this should be done in `ido-completion-help'.
+ (when (bobp)
+ (next-completion 1)))))
+
+
(defun ido-completion-help ()
- "Show possible completions in a \"*File Completions*\" buffer."
+ "Show possible completions in the `ido-completion-buffer'."
(interactive)
(setq ido-rescan nil)
(let ((temp-buf (and ido-completion-buffer
@@ -4852,10 +4868,13 @@ Modified from `icomplete-completions'."
Return the name of a buffer selected.
PROMPT is the prompt to give to the user. DEFAULT if given is the default
buffer to be selected, which will go to the front of the list.
-If REQUIRE-MATCH is non-nil, an existing buffer must be selected."
+If REQUIRE-MATCH is non-nil, an existing buffer must be selected.
+Optional arg PREDICATE if non-nil is a function limiting the
+buffers that can be considered."
(let* ((ido-current-directory nil)
(ido-directory-nonreadable nil)
(ido-directory-too-big nil)
+ (ido-predicate predicate)
(ido-context-switch-command 'ignore)
(buf (ido-read-internal 'buffer prompt 'ido-buffer-history default require-match)))
(if (eq ido-exit 'fallback)
diff --git a/lisp/ielm.el b/lisp/ielm.el
index 43a586eb32d..82aff9901ba 100644
--- a/lisp/ielm.el
+++ b/lisp/ielm.el
@@ -115,12 +115,12 @@ such as `edebug-defun' to work with such inputs."
:type 'boolean
:group 'ielm)
+(defvaralias 'inferior-emacs-lisp-mode-hook 'ielm-mode-hook)
(defcustom ielm-mode-hook nil
"Hooks to be run when IELM (`inferior-emacs-lisp-mode') is started."
:options '(eldoc-mode)
:type 'hook
:group 'ielm)
-(defvaralias 'inferior-emacs-lisp-mode-hook 'ielm-mode-hook)
(defvar * nil
"Most recent value evaluated in IELM.")
@@ -165,6 +165,7 @@ This variable is buffer-local.")
"*** Welcome to IELM *** Type (describe-mode) for help.\n"
"Message to display when IELM is started.")
+(defvaralias 'inferior-emacs-lisp-mode-map 'ielm-map)
(defvar ielm-map
(let ((map (make-sparse-keymap)))
(define-key map "\t" 'ielm-tab)
@@ -183,7 +184,6 @@ This variable is buffer-local.")
(define-key map "\C-c\C-v" 'ielm-print-working-buffer)
map)
"Keymap for IELM mode.")
-(defvaralias 'inferior-emacs-lisp-mode-map 'ielm-map)
(easy-menu-define ielm-menu ielm-map
"IELM mode menu."
@@ -384,7 +384,7 @@ nonempty, then flushes the buffer."
(set-match-data ielm-match-data)
(save-excursion
(with-temp-buffer
- (condition-case err
+ (condition-case-unless-debug err
(unwind-protect
;; The next let form creates default
;; bindings for *, ** and ***. But
@@ -436,15 +436,26 @@ nonempty, then flushes the buffer."
(goto-char pmark)
(unless error-type
- (condition-case nil
+ (condition-case err
;; Self-referential objects cause loops in the printer, so
;; trap quits here. May as well do errors, too
(unless for-effect
- (setq output (concat output (pp-to-string result)
- (let ((str (eval-expression-print-format result)))
- (if str (propertize str 'font-lock-face 'shadow))))))
- (error (setq error-type "IELM Error")
- (setq result "Error during pretty-printing (bug in pp)"))
+ (let* ((ielmbuf (current-buffer))
+ (aux (let ((str (eval-expression-print-format result)))
+ (if str (propertize str 'font-lock-face 'shadow)))))
+ (setq output (with-temp-buffer
+ (let ((tmpbuf (current-buffer)))
+ ;; Use print settings (e.g. print-circle,
+ ;; print-gensym, etc...) from the
+ ;; right buffer!
+ (with-current-buffer ielmbuf
+ (cl-prin1 result tmpbuf))
+ (pp-buffer)
+ (concat (buffer-string) aux))))))
+ (error
+ (setq error-type "IELM Error")
+ (setq result (format "Error during pretty-printing (bug in pp): %S"
+ err)))
(quit (setq error-type "IELM Error")
(setq result "Quit during pretty-printing"))))
(if error-type
@@ -517,9 +528,6 @@ causes output to be directed to the ielm buffer.
set to a different value during evaluation. You can use (princ
VALUE) or (pp VALUE) to write to the ielm buffer.
-Expressions evaluated by IELM are not subject to `debug-on-quit' or
-`debug-on-error'.
-
The behavior of IELM may be customized with the following variables:
* To stop beeping on error, set `ielm-noisy' to nil.
* If you don't like the prompt, you can change it by setting `ielm-prompt'.
@@ -604,17 +612,19 @@ Customized bindings may be defined in `ielm-map', which currently contains:
;;; User command
;;;###autoload
-(defun ielm nil
+(defun ielm (&optional buf-name)
"Interactively evaluate Emacs Lisp expressions.
-Switches to the buffer `*ielm*', or creates it if it does not exist.
+Switches to the buffer named BUF-NAME if provided (`*ielm*' by default),
+or creates it if it does not exist.
See `inferior-emacs-lisp-mode' for details."
(interactive)
- (let (old-point)
- (unless (comint-check-proc "*ielm*")
- (with-current-buffer (get-buffer-create "*ielm*")
+ (let (old-point
+ (buf-name (or buf-name "*ielm*")))
+ (unless (comint-check-proc buf-name)
+ (with-current-buffer (get-buffer-create buf-name)
(unless (zerop (buffer-size)) (setq old-point (point)))
(inferior-emacs-lisp-mode)))
- (pop-to-buffer-same-window "*ielm*")
+ (pop-to-buffer-same-window buf-name)
(when old-point (push-mark old-point))))
(provide 'ielm)
diff --git a/lisp/image-dired.el b/lisp/image-dired.el
index 9d4e45639ae..c9b31e9f1f8 100644
--- a/lisp/image-dired.el
+++ b/lisp/image-dired.el
@@ -587,8 +587,9 @@ Create the thumbnails directory if it does not exist."
(let* ((thumb-file (image-dired-thumb-name file))
(thumb-attr (file-attributes thumb-file)))
(when (or (not thumb-attr)
- (time-less-p (nth 5 thumb-attr)
- (nth 5 (file-attributes file))))
+ (time-less-p (file-attribute-modification-time thumb-attr)
+ (file-attribute-modification-time
+ (file-attributes file))))
(image-dired-create-thumb file thumb-file))
(create-image thumb-file)
;; (list 'image :type 'jpeg
@@ -752,7 +753,8 @@ Increase at own risk.")
(let* ((width (int-to-string (image-dired-thumb-size 'width)))
(height (int-to-string (image-dired-thumb-size 'height)))
(modif-time (format-time-string
- "%s" (nth 5 (file-attributes original-file))))
+ "%s" (file-attribute-modification-time
+ (file-attributes original-file))))
(thumbnail-nq8-file (replace-regexp-in-string ".png\\'" "-nq8.png"
thumbnail-file))
(spec
@@ -2652,8 +2654,8 @@ tags to their respective image file. Internal function used by
;; (mapcar
;; (lambda (f)
;; (let ((fattribs (file-attributes f)))
-;; ;; Get last access time and file size
-;; `(,(nth 4 fattribs) ,(nth 7 fattribs) ,f)))
+;; `(,(file-attribute-access-time fattribs)
+;; ,(file-attribute-size fattribs) ,f)))
;; (directory-files (image-dired-dir) t ".+\\.thumb\\..+$"))
;; ;; Sort function. Compare time between two files.
;; (lambda (l1 l2)
diff --git a/lisp/image-file.el b/lisp/image-file.el
index 46358b6eae7..bc5ef446bb2 100644
--- a/lisp/image-file.el
+++ b/lisp/image-file.el
@@ -179,9 +179,6 @@ Optional argument ARGS are the arguments to call FUNCTION with."
;;;###autoload
(define-minor-mode auto-image-file-mode
"Toggle visiting of image files as images (Auto Image File mode).
-With a prefix argument ARG, enable Auto Image File mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
An image file is one whose name has an extension in
`image-file-name-extensions', or matches a regexp in
diff --git a/lisp/image-mode.el b/lisp/image-mode.el
index 3666009c7e0..fa1362c471b 100644
--- a/lisp/image-mode.el
+++ b/lisp/image-mode.el
@@ -53,7 +53,7 @@ See `image-mode-winprops'.")
It is called with one argument, the initial WINPROPS.")
;; FIXME this doesn't seem mature yet. Document in manual when it is.
-(defvar image-transform-resize nil
+(defvar-local image-transform-resize nil
"The image resize operation.
Its value should be one of the following:
- nil, meaning no resizing.
@@ -61,10 +61,10 @@ Its value should be one of the following:
- `fit-width', meaning to fit the image to the window width.
- A number, which is a scale factor (the default size is 1).")
-(defvar image-transform-scale 1.0
+(defvar-local image-transform-scale 1.0
"The scale factor of the image being displayed.")
-(defvar image-transform-rotation 0.0
+(defvar-local image-transform-rotation 0.0
"Rotation angle for the image in the current Image mode buffer.")
(defvar image-transform-right-angle-fudge 0.0001
@@ -145,7 +145,7 @@ otherwise it defaults to t, used for times when the buffer is not displayed."
(unless (listp image-mode-winprops-alist)
(setq image-mode-winprops-alist nil))
(add-hook 'window-configuration-change-hook
- 'image-mode-reapply-winprops nil t))
+ #'image-mode-reapply-winprops nil t))
;;; Image scrolling functions
@@ -412,9 +412,6 @@ call."
(defvar-local image-multi-frame nil
"Non-nil if image for the current Image mode buffer has multiple frames.")
-(defvar image-mode-previous-major-mode nil
- "Internal variable to keep the previous non-image major mode.")
-
(defvar image-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "\C-c\C-c" 'image-toggle-display)
@@ -551,7 +548,7 @@ Key bindings:
(unless (display-images-p)
(error "Display does not support images"))
- (kill-all-local-variables)
+ (major-mode-suspend)
(setq major-mode 'image-mode)
(if (not (image-get-display-property))
@@ -575,8 +572,8 @@ Key bindings:
;; Keep track of [vh]scroll when switching buffers
(image-mode-setup-winprops)
- (add-hook 'change-major-mode-hook 'image-toggle-display-text nil t)
- (add-hook 'after-revert-hook 'image-after-revert-hook nil t)
+ (add-hook 'change-major-mode-hook #'image-toggle-display-text nil t)
+ (add-hook 'after-revert-hook #'image-after-revert-hook nil t)
(run-mode-hooks 'image-mode-hook)
(let ((image (image-get-display-property))
(msg1 (substitute-command-keys
@@ -620,9 +617,6 @@ mouse-3: Previous frame"
;;;###autoload
(define-minor-mode image-minor-mode
"Toggle Image minor mode in this buffer.
-With a prefix argument ARG, enable Image minor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Image minor mode provides the key \\<image-mode-map>\\[image-toggle-display],
to switch back to `image-mode' and display an image file as the
@@ -641,26 +635,7 @@ A non-mage major mode found from `auto-mode-alist' or fundamental mode
displays an image file as text."
;; image-mode-as-text = normal-mode + image-minor-mode
(let ((previous-image-type image-type)) ; preserve `image-type'
- (if image-mode-previous-major-mode
- ;; Restore previous major mode that was already found by this
- ;; function and cached in `image-mode-previous-major-mode'
- (funcall image-mode-previous-major-mode)
- (let ((auto-mode-alist
- (delq nil (mapcar
- (lambda (elt)
- (unless (memq (or (car-safe (cdr elt)) (cdr elt))
- '(image-mode image-mode-maybe image-mode-as-text))
- elt))
- auto-mode-alist)))
- (magic-fallback-mode-alist
- (delq nil (mapcar
- (lambda (elt)
- (unless (memq (or (car-safe (cdr elt)) (cdr elt))
- '(image-mode image-mode-maybe image-mode-as-text))
- elt))
- magic-fallback-mode-alist))))
- (normal-mode)
- (setq-local image-mode-previous-major-mode major-mode)))
+ (major-mode-restore '(image-mode image-mode-maybe image-mode-as-text))
;; Restore `image-type' after `kill-all-local-variables' in `normal-mode'.
(setq image-type previous-image-type)
;; Enable image minor mode with `C-c C-c'.
@@ -717,6 +692,7 @@ on these modes."
Remove text properties that display the image."
(let ((inhibit-read-only t)
(buffer-undo-list t)
+ (create-lockfiles nil) ; avoid changing dir mtime by lock_file
(modified (buffer-modified-p)))
(remove-list-of-text-properties (point-min) (point-max)
'(display read-nonsticky ;; intangible
@@ -749,16 +725,20 @@ was inserted."
(not (and (boundp 'epa-file-encrypt-to)
(local-variable-p
'epa-file-encrypt-to))))))
- (file-or-data (if data-p
- (string-make-unibyte
- (buffer-substring-no-properties (point-min) (point-max)))
- filename))
+ (file-or-data
+ (if data-p
+ (let ((str
+ (buffer-substring-no-properties (point-min) (point-max))))
+ (if enable-multibyte-characters
+ (encode-coding-string str buffer-file-coding-system)
+ str))
+ filename))
;; If we have a `fit-width' or a `fit-height', don't limit
;; the size of the image to the window size.
(edges (and (null image-transform-resize)
(window-inside-pixel-edges
(get-buffer-window (current-buffer)))))
- (type (if (fboundp 'imagemagick-types)
+ (type (if (image--imagemagick-wanted-p filename)
'imagemagick
(image-type file-or-data nil data-p)))
;; :scale 1: If we do not set this, create-image will apply
@@ -782,7 +762,7 @@ was inserted."
rear-nonsticky (display) ;; intangible
read-only t front-sticky (read-only)))
- (let ((buffer-file-truename nil)) ; avoid changing dir mtime by lock_file
+ (let ((create-lockfiles nil)) ; avoid changing dir mtime by lock_file
(add-text-properties (point-min) (point-max) props)
(restore-buffer-modified-p modified))
;; Inhibit the cursor when the buffer contains only an image,
@@ -805,6 +785,13 @@ was inserted."
(if (called-interactively-p 'any)
(message "Repeat this command to go back to displaying the file as text"))))
+(defun image--imagemagick-wanted-p (filename)
+ (and (fboundp 'imagemagick-types)
+ (not (eq imagemagick-types-inhibit t))
+ (not (and filename (file-name-extension filename)
+ (memq (intern (upcase (file-name-extension filename)) obarray)
+ imagemagick-types-inhibit)))))
+
(defun image-toggle-hex-display ()
"Toggle between image and hex display."
(interactive)
diff --git a/lisp/image.el b/lisp/image.el
index 9d2045de610..6da3a0b6cd0 100644
--- a/lisp/image.el
+++ b/lisp/image.el
@@ -29,6 +29,7 @@
"Image support."
:group 'multimedia)
+(declare-function image-flush "image.c" (spec &optional frame))
(defalias 'image-refresh 'image-flush)
(defconst image-type-header-regexps
@@ -247,6 +248,7 @@ 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."
(setq data (ignore-errors (string-to-unibyte data)))
@@ -259,7 +261,7 @@ We accept the tag Exif because that is the same format."
(setq i (1+ i))
(when (>= (+ i 2) len)
(throw 'jfif nil))
- (let ((nbytes (+ (lsh (aref data (+ i 1)) 8)
+ (let ((nbytes (+ (ash (aref data (+ i 1)) 8)
(aref data (+ i 2))))
(code (aref data i)))
(when (and (>= code #xe0) (<= code #xef))
@@ -802,19 +804,22 @@ If the image has a non-nil :speed property, it acts as a multiplier
for the animation speed. A negative value means to animate in reverse."
(when (and (buffer-live-p (plist-get (cdr image) :animate-buffer))
;; Delayed more than two seconds more than expected.
- (or (<= (- (float-time) target-time) 2)
+ (or (time-less-p (time-since target-time) 2)
(progn
(message "Stopping animation; animation possibly too big")
nil)))
(image-show-frame image n t)
(let* ((speed (image-animate-get-speed image))
- (time (float-time))
+ (time (current-time))
(animation (image-multi-frame-p image))
+ (time-to-load-image (time-since time))
+ (stated-delay-time (/ (or (cdr animation)
+ image-default-frame-delay)
+ (float (abs speed))))
;; Subtract off the time we took to load the image from the
;; stated delay time.
- (delay (max (+ (* (or (cdr animation) image-default-frame-delay)
- (/ 1.0 (abs speed)))
- time (- (float-time)))
+ (delay (max (float-time (time-subtract stated-delay-time
+ time-to-load-image))
image-minimum-frame-delay))
done)
(setq n (if (< speed 0)
@@ -980,17 +985,19 @@ default is 20%."
0.8)))
(defun image--get-image ()
- (let ((image (get-text-property (point) 'display)))
+ "Return the image at point."
+ (let ((image (get-char-property (point) 'display)))
(unless (eq (car-safe image) 'image)
(error "No image under point"))
image))
(defun image--get-imagemagick-and-warn ()
- (unless (fboundp 'imagemagick-types)
- (error "Cannot rescale images without ImageMagick support"))
+ (unless (or (fboundp 'imagemagick-types) (image-scaling-p))
+ (error "Cannot rescale images on this terminal"))
(let ((image (image--get-image)))
(image-flush image)
- (plist-put (cdr image) :type 'imagemagick)
+ (when (fboundp 'imagemagick-types)
+ (plist-put (cdr image) :type 'imagemagick))
image))
(defun image--change-size (factor)
@@ -1010,6 +1017,8 @@ default is 20%."
(setq new (nconc new (list key val))))))
new)))
+(declare-function image-size "image.c" (spec &optional pixels frame))
+
(defun image--current-scaling (image new-image)
;; The image may be scaled due to many reasons (:scale, :max-width,
;; etc), so find out what the current scaling is based on the
@@ -1032,10 +1041,7 @@ default is 20%."
(defun image-save ()
"Save the image under point."
(interactive)
- (let ((image (get-text-property (point) 'display)))
- (when (or (not (consp image))
- (not (eq (car image) 'image)))
- (error "No image under point"))
+ (let ((image (image--get-image)))
(with-temp-buffer
(let ((file (plist-get (cdr image) :file)))
(if file
diff --git a/lisp/image/gravatar.el b/lisp/image/gravatar.el
index 2b106ba0675..cf61119ab2e 100644
--- a/lisp/image/gravatar.el
+++ b/lisp/image/gravatar.el
@@ -77,11 +77,7 @@
(not (file-exists-p (url-cache-create-filename url))))
(t (let ((cache-time (url-is-cached url)))
(if cache-time
- (time-less-p
- (time-add
- cache-time
- gravatar-cache-ttl)
- (current-time))
+ (time-less-p (time-add cache-time gravatar-cache-ttl) nil)
t)))))
(defun gravatar-get-data ()
diff --git a/lisp/imenu.el b/lisp/imenu.el
index a4732df6d97..df39ff3c07d 100644
--- a/lisp/imenu.el
+++ b/lisp/imenu.el
@@ -59,7 +59,7 @@
;;; Code:
-(eval-when-compile (require 'cl-lib))
+(require 'cl-lib)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -102,14 +102,7 @@ This might not yet be honored by all index-building functions."
:group 'imenu
:version "26.2")
-(defvar imenu-always-use-completion-buffer-p nil)
-(make-obsolete-variable 'imenu-always-use-completion-buffer-p
- 'imenu-use-popup-menu "22.1")
-
-(defcustom imenu-use-popup-menu
- (if imenu-always-use-completion-buffer-p
- (not (eq imenu-always-use-completion-buffer-p 'never))
- 'on-mouse)
+(defcustom imenu-use-popup-menu 'on-mouse
"Use a popup menu rather than a minibuffer prompt.
If nil, always use a minibuffer prompt.
If t, always use a popup menu,
@@ -119,8 +112,7 @@ If `on-mouse' use a popup menu when `imenu' was invoked with the mouse."
(other :tag "Always" t))
:group 'imenu)
-(defcustom imenu-eager-completion-buffer
- (not (eq imenu-always-use-completion-buffer-p 'never))
+(defcustom imenu-eager-completion-buffer t
"If non-nil, eagerly popup the completion buffer."
:type 'boolean
:group 'imenu
@@ -827,7 +819,8 @@ depending on PATTERNS."
;; Insert the item unless it is already present.
(unless (or (member item (cdr menu))
(and imenu-generic-skip-comments-and-strings
- (nth 8 (syntax-ppss))))
+ (save-excursion
+ (goto-char start) (nth 8 (syntax-ppss)))))
(setcdr menu
(cons item (cdr menu)))))
;; Go to the start of the match, to make sure we
@@ -839,9 +832,14 @@ depending on PATTERNS."
(dolist (item index-alist)
(when (listp item)
(setcdr item (sort (cdr item) 'imenu--sort-by-position))))
+ ;; Remove any empty menus. That can happen because of skipping
+ ;; things inside comments or strings.
+ (setq index-alist (cl-delete-if
+ (lambda (it) (and (consp it) (null (cdr it))))
+ index-alist))
(let ((main-element (assq nil index-alist)))
(nconc (delq main-element (delq 'dummy index-alist))
- (cdr main-element)))))
+ (cdr main-element)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
diff --git a/lisp/indent.el b/lisp/indent.el
index 8a0f8378653..bf87d6af760 100644
--- a/lisp/indent.el
+++ b/lisp/indent.el
@@ -65,15 +65,17 @@ e.g., `c-tab-always-indent', and do not respect this variable."
"Indent line in proper way for current major mode.
Normally, this is done by calling the function specified by the
variable `indent-line-function'. However, if the value of that
-variable is `indent-relative' or `indent-relative-maybe', handle
-it specially (since those functions are used for tabbing); in
-that case, indent by aligning to the previous non-blank line."
+variable is `indent-relative' or `indent-relative-first-indent-point',
+handle it specially (since those functions are used for tabbing);
+in that case, indent by aligning to the previous non-blank line."
(interactive)
(save-restriction
(widen)
(syntax-propertize (line-end-position))
(if (memq indent-line-function
- '(indent-relative indent-relative-maybe))
+ '(indent-relative
+ indent-relative-maybe
+ indent-relative-first-indent-point))
;; These functions are used for tabbing, but can't be used for
;; indenting. Replace with something ad-hoc.
(let ((column (save-excursion
@@ -292,7 +294,8 @@ indentation by specifying a large negative ARG."
"Indent current line to COLUMN.
This function removes or adds spaces and tabs at beginning of line
only if necessary. It leaves point at end of indentation."
- (back-to-indentation)
+ (beginning-of-line 1)
+ (skip-chars-forward " \t")
(let ((cur-col (current-column)))
(cond ((< cur-col column)
(if (>= (- column (* (/ cur-col tab-width) tab-width)) tab-width)
@@ -300,8 +303,13 @@ only if necessary. It leaves point at end of indentation."
(progn (skip-chars-backward " ") (point))))
(indent-to column))
((> cur-col column) ; too far right (after tab?)
- (delete-region (progn (move-to-column column t) (point))
- (progn (backward-to-indentation 0) (point)))))))
+ (delete-region (progn (move-to-column column t) (point))
+ ;; The `move-to-column' call may replace
+ ;; tabs with spaces, so we can't reuse the
+ ;; previous start point.
+ (progn (beginning-of-line 1)
+ (skip-chars-forward " \t")
+ (point)))))))
(defun current-left-margin ()
"Return the left margin to use for this line.
diff --git a/lisp/info-look.el b/lisp/info-look.el
index 045776b6bc9..1d761c70e19 100644
--- a/lisp/info-look.el
+++ b/lisp/info-look.el
@@ -619,7 +619,8 @@ Return nil if there is nothing appropriate in the buffer near point."
beg end)
(cond
((and (memq (get-char-property (point) 'face)
- '(custom-variable-tag custom-variable-tag-face))
+ '(custom-variable-tag custom-variable-obsolete
+ custom-variable-tag-face))
(setq beg (previous-single-char-property-change
(point) 'face nil (line-beginning-position)))
(setq end (next-single-char-property-change
diff --git a/lisp/info-xref.el b/lisp/info-xref.el
index e8750a7db72..c55398b73f9 100644
--- a/lisp/info-xref.el
+++ b/lisp/info-xref.el
@@ -71,7 +71,7 @@ you should set this variable to nil."
(defun info-xref-lock-file-p (filename)
"Return non-nil if FILENAME is an Emacs lock file.
A lock file is \".#foo.txt\" etc per `lock-buffer'."
- (string-match "\\(\\`\\|\\/\\)\\.#" filename))
+ (string-match "\\(\\`\\|/\\)\\.#" filename))
(defun info-xref-subfile-p (filename)
"Return t if FILENAME is an info subfile.
diff --git a/lisp/info.el b/lisp/info.el
index 301f6ece145..f3b413a2f9f 100644
--- a/lisp/info.el
+++ b/lisp/info.el
@@ -642,21 +642,23 @@ Do the right thing if the file has been compressed or zipped."
(insert-file-contents-literally fullname visit)
(let ((inhibit-read-only t)
(coding-system-for-write 'no-conversion)
- (inhibit-null-byte-detection t) ; Index nodes include null bytes
+ (inhibit-nul-byte-detection t) ; Index nodes include null bytes
(default-directory (or (file-name-directory fullname)
default-directory)))
(or (consp decoder)
(setq decoder (list decoder)))
(apply #'call-process-region (point-min) (point-max)
(car decoder) t t nil (cdr decoder))))
- (let ((inhibit-null-byte-detection t)) ; Index nodes include null bytes
+ (let ((inhibit-nul-byte-detection t)) ; Index nodes include null bytes
(insert-file-contents fullname visit)))
;; Clear the caches of modified Info files.
(let* ((attribs-old (cdr (assoc fullname Info-file-attributes)))
- (modtime-old (and attribs-old (nth 5 attribs-old)))
+ (modtime-old (and attribs-old
+ (file-attribute-modification-time attribs-old)))
(attribs-new (and (stringp fullname) (file-attributes fullname)))
- (modtime-new (and attribs-new (nth 5 attribs-new))))
+ (modtime-new (and attribs-new
+ (file-attribute-modification-time attribs-new))))
(when (and modtime-old modtime-new
(time-less-p modtime-old modtime-new))
(setq Info-index-nodes (remove (assoc (or Info-current-file filename)
@@ -877,10 +879,13 @@ In standalone mode, \\<Info-mode-map>\\[Info-exit] exits Emacs itself."
(forward-line 1) ; does the line after delimiter match REGEXP?
(re-search-backward regexp beg t))))
-(defun Info-find-file (filename &optional noerror)
+(defun Info-find-file (filename &optional noerror no-pop-to-dir)
"Return expanded FILENAME, or t if FILENAME is \"dir\".
Optional second argument NOERROR, if t, means if file is not found
-just return nil (no error)."
+just return nil (no error).
+
+If NO-POP-TO-DIR, don't try to pop to the info buffer if we can't
+find a node."
;; Convert filename to lower case if not found as specified.
;; Expand it.
(cond
@@ -939,7 +944,8 @@ just return nil (no error)."
(if noerror
(setq filename nil)
;; If there is no previous Info file, go to the directory.
- (unless Info-current-file
+ (when (and (not no-pop-to-dir)
+ (not Info-current-file))
(Info-directory))
(user-error "Info file %s does not exist" filename)))
filename))))
@@ -1371,7 +1377,7 @@ is non-nil)."
;; Index nodes include null bytes. DIR
;; files should not have indices, but who
;; knows...
- (let ((inhibit-null-byte-detection t))
+ (let ((inhibit-nul-byte-detection t))
(insert-file-contents file)
(setq Info-dir-file-name file)
(push (current-buffer) buffers)
@@ -1525,7 +1531,7 @@ is non-nil)."
(save-restriction
(narrow-to-region start (point))
(goto-char (point-min))
- (while (re-search-forward "^* \\([^:\n]+:\\(:\\|[^.\n]+\\).\\)" nil 'move)
+ (while (re-search-forward "^\\* \\([^:\n]+:\\(:\\|[^.\n]+\\).\\)" nil 'move)
;; Fold case straight away; `member-ignore-case' here wasteful.
(let ((x (downcase (match-string 1))))
(if (member x seen)
@@ -1596,7 +1602,7 @@ is non-nil)."
"Unescape double quotes and backslashes in VALUE."
(let ((start 0)
(unquote value))
- (while (string-match "[^\\\"]*\\(\\\\\\)[\\\\\"]" unquote start)
+ (while (string-match "[^\\\"]*\\(\\\\\\)[\\\"]" unquote start)
(setq unquote (replace-match "" t t unquote 1))
(setq start (- (match-end 0) 1)))
unquote))
@@ -1613,7 +1619,7 @@ escaped (\\\",\\\\)."
(let ((start 0)
(parameter-alist))
(while (string-match
- "\\s *\\([^=]+\\)=\\(?:\\([^\\s \"]+\\)\\|\\(?:\"\\(\\(?:[^\\\"]\\|\\\\[\\\\\"]\\)*\\)\"\\)\\)"
+ "\\s *\\([^=]+\\)=\\(?:\\([^\\s \"]+\\)\\|\\(?:\"\\(\\(?:[^\\\"]\\|\\\\[\\\"]\\)*\\)\"\\)\\)"
parameter-string start)
(setq start (match-end 0))
(push (cons (match-string 1 parameter-string)
@@ -1877,7 +1883,7 @@ See `completing-read' for a description of arguments and usage."
(lambda (string pred action)
(complete-with-action
action
- (Info-build-node-completions (Info-find-file file1))
+ (Info-build-node-completions (Info-find-file file1 nil t))
string pred))
nodename predicate code))))
;; Otherwise use Info-read-node-completion-table.
@@ -2022,7 +2028,7 @@ If DIRECTION is `backward', search in the reverse direction."
Info-isearch-initial-node
bound
(and found (> found opoint-min) (< found opoint-max)))
- (signal 'user-search-failed (list regexp "(end of node)")))
+ (signal 'user-search-failed (list regexp "end of node")))
;; If no subfiles, give error now.
(unless (or found Info-current-subfile)
@@ -2728,7 +2734,7 @@ Because of ambiguities, this should be concatenated with something like
(user-error "No menu in this node"))
(cond
((eq (car-safe action) 'boundaries) nil)
- ((eq action 'metadata) `(metadata (category . info-menu)))
+ ((eq action 'metadata) '(metadata (category . info-menu)))
((eq action 'lambda)
(re-search-forward
(concat "\n\\* +" (regexp-quote string) ":") nil t))
@@ -3934,8 +3940,8 @@ If FORK is a string, it is the name to use for the new buffer."
If FORK is non-nil, it is passed to `Info-goto-node'."
(let (node)
(cond
- ((setq node (Info-get-token (point) "[hf]t?tps?://"
- "\\([hf]t?tps?://[^ \t\n\"`‘({<>})’']+\\)"))
+ ((setq node (Info-get-token (point) "\\(?:f\\(?:ile\\|tp\\)\\|https?\\)://"
+ "\\(\\(?:f\\(?:ile\\|tp\\)\\|https?\\)://[^ \t\n\"`‘({<>})’']+\\)"))
(browse-url node)
(setq node t))
((setq node (Info-get-token (point) "\\*note[ \n\t]+"
@@ -4762,7 +4768,7 @@ first line or header line, and for breadcrumb links.")
;; This is a serious problem for trying to handle multiple
;; frame types at once. We want this text to be invisible
;; on frames that can display the font above.
- (when (memq (framep (selected-frame)) '(x pc w32 ns))
+ (when (display-multi-font-p)
(add-text-properties (1- (match-beginning 2)) (match-end 2)
'(invisible t front-sticky nil rear-nonsticky t))))))
@@ -5198,7 +5204,7 @@ The INDENT level is ignored."
TEXT is the text of the button we clicked on, a + or - item.
TOKEN is data related to this node (NAME . FILE).
INDENT is the current indentation depth."
- (cond ((string-match "+" text) ;we have to expand this file
+ (cond ((string-match "\\+" text) ;we have to expand this file
(speedbar-change-expand-button-char ?-)
(if (speedbar-with-writable
(save-excursion
diff --git a/lisp/international/ccl.el b/lisp/international/ccl.el
index 7f8aa7dda37..51626f51618 100644
--- a/lisp/international/ccl.el
+++ b/lisp/international/ccl.el
@@ -184,11 +184,19 @@
(defvar ccl-current-ic 0
"The current index for `ccl-program-vector'.")
+;; The CCL compiled codewords are 28bits, but the CCL implementation
+;; assumes that the codewords are sign-extended, so that data constants in
+;; the upper part of the codeword are signed. This function truncates a
+;; codeword to 28bits, and then sign extends the result to a fixnum.
+(defun ccl-fixnum (code)
+ "Convert a CCL code word to a fixnum value."
+ (- (logxor (logand code #x0fffffff) #x08000000) #x08000000))
+
(defun ccl-embed-data (data &optional ic)
"Embed integer DATA in `ccl-program-vector' at `ccl-current-ic' and
increment it. If IC is specified, embed DATA at IC."
(if ic
- (aset ccl-program-vector ic data)
+ (aset ccl-program-vector ic (ccl-fixnum data))
(let ((len (length ccl-program-vector)))
(if (>= ccl-current-ic len)
(let ((new (make-vector (* len 2) nil)))
@@ -196,7 +204,7 @@ increment it. If IC is specified, embed DATA at IC."
(setq len (1- len))
(aset new len (aref ccl-program-vector len)))
(setq ccl-program-vector new))))
- (aset ccl-program-vector ccl-current-ic data)
+ (aset ccl-program-vector ccl-current-ic (ccl-fixnum data))
(setq ccl-current-ic (1+ ccl-current-ic))))
(defun ccl-embed-symbol (symbol prop)
@@ -230,7 +238,8 @@ proper index number for SYMBOL. PROP should be
`ccl-program-vector' at IC without altering the other bit field."
(let ((relative (- ccl-current-ic (1+ ic))))
(aset ccl-program-vector ic
- (logior (aref ccl-program-vector ic) (ash relative 8)))))
+ (logior (aref ccl-program-vector ic)
+ (ccl-fixnum (ash relative 8))))))
(defun ccl-embed-code (op reg data &optional reg2)
"Embed CCL code for the operation OP and arguments REG and DATA in
@@ -986,7 +995,8 @@ is a list of CCL-BLOCKs."
(defun ccl-get-next-code ()
"Return a CCL code in `ccl-code' at `ccl-current-ic'."
(prog1
- (aref ccl-code ccl-current-ic)
+ (let ((code (aref ccl-code ccl-current-ic)))
+ (if (numberp code) (ccl-fixnum code) code))
(setq ccl-current-ic (1+ ccl-current-ic))))
(defun ccl-dump-1 ()
@@ -1142,9 +1152,9 @@ is a list of CCL-BLOCKs."
(progn
(insert (logand code #xFFFFFF))
(setq i (1+ i)))
- (insert (format "%c" (lsh code -16)))
+ (insert (format "%c" (ash code -16)))
(if (< (1+ i) len)
- (insert (format "%c" (logand (lsh code -8) 255))))
+ (insert (format "%c" (logand (ash code -8) 255))))
(if (< (+ i 2) len)
(insert (format "%c" (logand code 255))))
(setq i (+ i 3)))))
diff --git a/lisp/international/characters.el b/lisp/international/characters.el
index cdd8ba7c403..012827ba1c6 100644
--- a/lisp/international/characters.el
+++ b/lisp/international/characters.el
@@ -987,11 +987,12 @@ with L, LRE, or LRO Unicode bidi character type.")
(#x103D . #x103E)
(#x1058 . #x1059)
(#x105E . #x1160)
- (#x1171 . #x1074)
+ (#x1071 . #x1074)
(#x1082 . #x1082)
(#x1085 . #x1086)
(#x108D . #x108D)
(#x109D . #x109D)
+ (#x1160 . #x11FF)
(#x135D . #x135F)
(#x1712 . #x1714)
(#x1732 . #x1734)
@@ -1081,6 +1082,7 @@ with L, LRE, or LRO Unicode bidi character type.")
(#xABE5 . #xABE5)
(#xABE8 . #xABE8)
(#xABED . #xABED)
+ (#xD7B0 . #xD7FB)
(#xFB1E . #xFB1E)
(#xFE00 . #xFE0F)
(#xFE20 . #xFE2F)
@@ -1217,10 +1219,11 @@ with L, LRE, or LRO Unicode bidi character type.")
(#xFE30 . #xFE6F)
(#xFF01 . #xFF60)
(#xFFE0 . #xFFE6)
- (#x16FE0 . #x16FE1)
- (#x17000 . #x187F1)
+ (#x16FE0 . #x16FE3)
+ (#x17000 . #x187F7)
(#x18800 . #x18AF2)
- (#x1B000 . #x1B11E)
+ (#x1B000 . #x1B152)
+ (#x1B164 . #x1B167)
(#x1B170 . #x1B2FB)
(#x1F004 . #x1F004)
(#x1F0CF . #x1F0CF)
@@ -1250,17 +1253,22 @@ with L, LRE, or LRO Unicode bidi character type.")
(#x1F680 . #x1F6C5)
(#x1F6CC . #x1F6CC)
(#x1F6D0 . #x1F6D2)
+ (#x1F6D5 . #x1F6D5)
(#x1F6EB . #x1F6EC)
- (#x1F6F4 . #x1F6F9)
- (#x1F910 . #x1F93E)
- (#x1F940 . #x1F970)
+ (#x1F6F4 . #x1F6FA)
+ (#x1F7E0 . #x1F7EB)
+ (#x1F90D . #x1F971)
(#x1F973 . #x1F976)
- (#x1F97A . #x1F97A)
- (#x1F97C . #x1F9A2)
- (#x1F9B0 . #x1F9B9)
- (#x1F9C0 . #x1F9C2)
- (#x1F9D0 . #x1F9FF)
+ (#x1F97A . #x1F9A2)
+ (#x1F9A5 . #x1F9AA)
+ (#x1F9AE . #x1F9CA)
+ (#x1F9CD . #x1F9FF)
+ (#x1FA00 . #x1FA53)
(#x1FA60 . #x1FA6D)
+ (#x1FA70 . #x1FA73)
+ (#x1FA78 . #x1FA7A)
+ (#x1FA80 . #x1FA82)
+ (#x1FA90 . #x1FA95)
(#x20000 . #x2FFFF)
(#x30000 . #x3FFFF))))
(dolist (elt l)
@@ -1334,7 +1342,7 @@ Setup char-width-table appropriate for non-CJK language environment."
;; Setting char-script-table.
-(if purify-flag
+(if dump-mode
;; While dumping, we can't use require, and international is not
;; in load-path.
(load "international/charscript")
diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el
index c90d4f53bd9..0413646dfb3 100644
--- a/lisp/international/fontset.el
+++ b/lisp/international/fontset.el
@@ -222,6 +222,7 @@
(hanifi-rohingya #x10D00)
(old-sogdian #x10F00)
(sogdian #x10F30)
+ (elymaic #x10fe0)
(mahajani #x11150)
(sinhala-archaic-number #x111E1)
(khojki #x11200)
@@ -234,6 +235,7 @@
(takri #x11680)
(dogra #x11800)
(warang-citi #x118A1)
+ (nandinagari #x119a0)
(zanabazar-square #x11A00)
(soyombo #x11A50)
(pau-cin-hau #x11AC0)
@@ -257,15 +259,19 @@
(ancient-greek-musical-notation #x1D200)
(tai-xuan-jing-symbol #x1D300)
(counting-rod-numeral #x1D360)
+ (nyiakeng-puachue-hmong #x1e100)
+ (wancho #x1e2c0)
(mende-kikakui #x1E810)
(adlam #x1E900)
+ (indic-siyaq-number #x1ec71)
+ (ottoman-siyaq-number #x1ed01)
(mahjong-tile #x1F000)
(domino-tile #x1F030)))
(defvar otf-script-alist)
-;; The below was synchronized with the latest Jul 23, 2017 version of
-;; https://www.microsoft.com/typography/otspec/scripttags.htm.
+;; The below was synchronized with the latest Aug 16, 2018 version of
+;; https://docs.microsoft.com/en-us/typography/opentype/spec/scripttags
(setq otf-script-alist
'((adlm . adlam)
(ahom . ahom)
@@ -300,6 +306,7 @@
(dsrt . deseret)
(deva . devanagari)
(dev2 . devanagari)
+ (dogr . dogra)
(dupl . duployan-shorthand)
(egyp . egyptian)
(elba . elbasan)
@@ -311,11 +318,13 @@
(grek . greek)
(gujr . gujarati)
(gjr2 . gujarati)
+ (gong . gunjala-gondi)
(guru . gurmukhi)
(gur2 . gurmukhi)
(hani . han)
(hang . hangul)
(jamo . hangul)
+ (rohg . hanifi-rohingya)
(hano . hanunoo)
(hatr . hatran)
(hebr . hebrew)
@@ -324,9 +333,9 @@
(prti . inscriptional-parthian)
(java . javanese)
(kthi . kaithi)
- (kana . kana) ; Hiragana
(knda . kannada)
(knd2 . kannada)
+ (kana . kana) ; Hiragana
(kali . kayah-li)
(khar . kharoshthi)
(khmr . khmer)
@@ -342,12 +351,15 @@
(lyci . lycian)
(lydi . lydian)
(mahj . mahajani)
+ (maka . makasar)
(marc . marchen)
(mlym . malayalam)
(mlm2 . malayalam)
(mand . mandaic)
(mani . manichaean)
+ (gonm . masaram-gondi)
(math . mathematical)
+ (medf . medefaidrin)
(mtei . meetei-mayek)
(mend . mende-kikakui)
(merc . meroitic)
@@ -363,12 +375,14 @@
(nbat . nabataean)
(newa . newa)
(nko\ . nko)
+ (nshu . nushu)
(ogam . ogham)
(olck . ol-chiki)
(ital . old_italic)
(xpeo . old_persian)
(narb . old-north-arabian)
(perm . old-permic)
+ (sogo . old-sogdian)
(sarb . old-south-arabian)
(orkh . old-turkic)
(orya . oriya)
@@ -392,7 +406,9 @@
(sidd . siddham)
(sgnw . sutton-sign-writing)
(sinh . sinhala)
+ (sogd . sogdian)
(sora . sora-sompeng)
+ (soyo . soyombo)
(sund . sundanese)
(sylo . syloti_nagri)
(syrc . syriac)
@@ -416,7 +432,8 @@
(ugar . ugaritic)
(vai\ . vai)
(wara . warang-citi)
- (yi\ \ . yi)))
+ (yi\ \ . yi)
+ (zanb . zanabazar-square)))
;; Set standard fontname specification of characters in the default
;; fontset to find an appropriate font for each script/charset. The
@@ -487,7 +504,7 @@
(data (list (vconcat (mapcar 'car cjk))))
(i 0))
(dolist (elt cjk)
- (let ((mask (lsh 1 i)))
+ (let ((mask (ash 1 i)))
(map-charset-chars
#'(lambda (range _arg)
(let ((from (car range)) (to (cdr range)))
@@ -876,7 +893,7 @@
(spec (cdr target-spec)))
(if (integerp spec)
(dotimes (i (length registries))
- (if (> (logand spec (lsh 1 i)) 0)
+ (if (> (logand spec (ash 1 i)) 0)
(set-fontset-font "fontset-default" target
(cons nil (aref registries i))
nil 'append)))
@@ -1164,6 +1181,8 @@ given from DEFAULT-SPEC."
(setcar (cdr elt) spec)))
fontlist))
+(defvar fontset-alias-alist)
+
(defun fontset-name-p (fontset)
"Return non-nil if FONTSET is valid as fontset name.
A valid fontset name should conform to XLFD (X Logical Font Description)
@@ -1240,11 +1259,12 @@ Done when `mouse-set-font' is called."
(latin-iso8859-15 . latin)
(latin-iso8859-16 . latin)
(latin-jisx0201 . latin)
+ (thai-iso8859-11 . thai)
(thai-tis620 . thai)
(cyrillic-iso8859-5 . cyrillic)
(arabic-iso8859-6 . arabic)
- (greek-iso8859-7 . latin)
- (hebrew-iso8859-8 . latin)
+ (greek-iso8859-7 . greek)
+ (hebrew-iso8859-8 . hebrew)
(katakana-jisx0201 . kana)
(chinese-gb2312 . han)
(chinese-gbk . han)
diff --git a/lisp/international/iso-ascii.el b/lisp/international/iso-ascii.el
index 4441241a658..395e6c4dcd0 100644
--- a/lisp/international/iso-ascii.el
+++ b/lisp/international/iso-ascii.el
@@ -163,10 +163,7 @@
(iso-ascii-display 255 "\"y") ; small y with diaeresis or umlaut mark
(define-minor-mode iso-ascii-mode
- "Toggle ISO-ASCII mode.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil."
+ "Toggle ISO-ASCII mode."
:variable ((eq standard-display-table iso-ascii-display-table)
. (lambda (v)
(setq standard-display-table
diff --git a/lisp/international/ja-dic-cnv.el b/lisp/international/ja-dic-cnv.el
index 78d2cd5aced..578cd63a590 100644
--- a/lisp/international/ja-dic-cnv.el
+++ b/lisp/international/ja-dic-cnv.el
@@ -32,15 +32,15 @@
;; input method (e.g. quail-japanese) can utilize the dictionary.
;; The format of SKK dictionary is quite simple. Each line has the
-;; form "KANASTRING /CONV1/CONV2/.../" which means KANASTRING ($B2>L>J8(B
-;; $B;zNs(B) can be converted to one of CONVi. CONVi is a Kanji ($B4A;z(B)
-;; and Kana ($B2>L>(B) mixed string.
+;; form "KANASTRING /CONV1/CONV2/.../" which means KANASTRING (仮名文
+;; 字列) can be converted to one of CONVi. CONVi is a Kanji (漢字)
+;; and Kana (仮名) mixed string.
;;
-;; KANASTRING may have a trailing ASCII letter for Okurigana ($BAw$j2>L>(B)
+;; KANASTRING may have a trailing ASCII letter for Okurigana (送り仮名)
;; information. For instance, the trailing letter `k' means that one
-;; of the following Okurigana is allowed: $B$+$-$/$1$3(B. So, in that
-;; case, the string "KANASTRING$B$/(B" can be converted to one of "CONV1$B$/(B",
-;; CONV2$B$/(B, ...
+;; of the following Okurigana is allowed: かきくけこ. So, in that
+;; case, the string "KANASTRINGく" can be converted to one of "CONV1く",
+;; CONV2く, ...
;;; Code:
@@ -76,25 +76,25 @@
(defconst skkdic-postfix-list '(skkdic-postfix-list))
(defconst skkdic-postfix-data
- '(("$B$$$-(B" "$B9T(B")
- ("$B$,$+$j(B" "$B78(B")
- ("$B$,$/(B" "$B3X(B")
- ("$B$,$o(B" "$B@n(B")
- ("$B$7$c(B" "$B<R(B")
- ("$B$7$e$&(B" "$B=8(B")
- ("$B$7$g$&(B" "$B>^(B" "$B>k(B")
- ("$B$8$g$&(B" "$B>k(B")
- ("$B$;$s(B" "$B@~(B")
- ("$B$@$1(B" "$B3Y(B")
- ("$B$A$c$/(B" "$BCe(B")
- ("$B$F$s(B" "$BE9(B")
- ("$B$H$&$2(B" "$BF=(B")
- ("$B$I$*$j(B" "$BDL$j(B")
- ("$B$d$^(B" "$B;3(B")
- ("$B$P$7(B" "$B66(B")
- ("$B$O$D(B" "$BH/(B")
- ("$B$b$/(B" "$BL\(B")
- ("$B$f$-(B" "$B9T(B")))
+ '(("いき" "行")
+ ("がかり" "係")
+ ("がく" "学")
+ ("がわ" "川")
+ ("しゃ" "社")
+ ("しゅう" "集")
+ ("しょう" "賞" "城")
+ ("じょう" "城")
+ ("せん" "線")
+ ("だけ" "岳")
+ ("ちゃく" "着")
+ ("てん" "店")
+ ("とうげ" "峠")
+ ("どおり" "通り")
+ ("やま" "山")
+ ("ばし" "橋")
+ ("はつ" "発")
+ ("もく" "目")
+ ("ゆき" "行")))
(defun skkdic-convert-postfix (skkbuf buf)
(message "Processing POSTFIX entries ...")
@@ -124,7 +124,7 @@
(setq l (cdr l)))))
;; Search postfix entries.
- (while (re-search-forward "^[#<>?]\\(\\(\\cH\\|$B!<(B\\)+\\) " nil t)
+ (while (re-search-forward "^[#<>?]\\(\\(\\cH\\|ー\\)+\\) " nil t)
(let ((kana (match-string-no-properties 1))
str candidates)
(while (looking-at "/[#0-9 ]*\\([^/\n]*\\)/")
@@ -157,7 +157,7 @@
(insert ";; Setting prefix entries.\n"
"(skkdic-set-prefix\n"))
(save-excursion
- (while (re-search-forward "^\\(\\(\\cH\\|$B!<(B\\)+\\)[<>?] " nil t)
+ (while (re-search-forward "^\\(\\(\\cH\\|ー\\)+\\)[<>?] " nil t)
(let ((kana (match-string-no-properties 1))
str candidates)
(while (looking-at "/\\([^/\n]+\\)/")
@@ -275,7 +275,7 @@
(let ((progress (make-progress-reporter "Collecting OKURI-NASI entries"
(point) (point-max)
nil 10)))
- (while (re-search-forward "^\\(\\(\\cH\\|$B!<(B\\)+\\) \\(/\\cj.*\\)/$"
+ (while (re-search-forward "^\\(\\(\\cH\\|ー\\)+\\) \\(/\\cj.*\\)/$"
nil t)
(let ((kana (match-string-no-properties 1))
(candidates (skkdic-get-candidate-list (match-beginning 3)
@@ -452,7 +452,7 @@ To get complete usage, invoke:
(aset vec i
(if (< ch 128) ; CH is an ASCII letter for OKURIGANA,
(- ch) ; represented by a negative code.
- (if (= ch ?$B!<(B) ; `$B!<(B' is represented by 0.
+ (if (= ch ?ー) ; `ー' is represented by 0.
0
(- (logand (encode-char ch 'japanese-jisx0208) #xFF) 32))))
(setq i (1+ i)))
@@ -541,9 +541,4 @@ To get complete usage, invoke:
map)))
(provide 'ja-dic-cnv)
-
-;; Local Variables:
-;; coding: iso-2022-7bit
-;; End:
-
;;; ja-dic-cnv.el ends here
diff --git a/lisp/international/ja-dic-utl.el b/lisp/international/ja-dic-utl.el
index 86ba3749df8..498fb23f707 100644
--- a/lisp/international/ja-dic-utl.el
+++ b/lisp/international/ja-dic-utl.el
@@ -53,23 +53,23 @@
"Nested alist for OKURI-NASI entries of SKK dictionary.")
(defconst skkdic-okurigana-table
- '((?$B$!(B . ?a) (?$B$"(B . ?a) (?$B$#(B . ?i) (?$B$$(B . ?i) (?$B$%(B . ?u)
- (?$B$&(B . ?u) (?$B$'(B . ?e) (?$B$((B . ?e) (?$B$)(B . ?o) (?$B$*(B . ?o)
- (?$B$+(B . ?k) (?$B$,(B . ?g) (?$B$-(B . ?k) (?$B$.(B . ?g) (?$B$/(B . ?k)
- (?$B$0(B . ?g) (?$B$1(B . ?k) (?$B$2(B . ?g) (?$B$3(B . ?k) (?$B$4(B . ?g)
- (?$B$5(B . ?s) (?$B$6(B . ?z) (?$B$7(B . ?s) (?$B$8(B . ?j) (?$B$9(B . ?s)
- (?$B$:(B . ?z) (?$B$;(B . ?s) (?$B$<(B . ?z) (?$B$=(B . ?s) (?$B$>(B . ?z)
- (?$B$?(B . ?t) (?$B$@(B . ?d) (?$B$A(B . ?t) (?$B$B(B . ?d) (?$B$C(B . ?t)
- (?$B$D(B . ?t) (?$B$E(B . ?d) (?$B$F(B . ?t) (?$B$G(B . ?d) (?$B$H(B . ?t) (?$B$I(B . ?d)
- (?$B$J(B . ?n) (?$B$K(B . ?n) (?$B$L(B . ?n) (?$B$M(B . ?n) (?$B$N(B . ?n)
- (?$B$O(B . ?h) (?$B$P(B . ?b) (?$B$Q(B . ?p) (?$B$R(B . ?h) (?$B$S(B . ?b)
- (?$B$T(B . ?p) (?$B$U(B . ?h) (?$B$V(B . ?b) (?$B$W(B . ?p) (?$B$X(B . ?h)
- (?$B$Y(B . ?b) (?$B$Z(B . ?p) (?$B$[(B . ?h) (?$B$\(B . ?b) (?$B$](B . ?p)
- (?$B$^(B . ?m) (?$B$_(B . ?m) (?$B$`(B . ?m) (?$B$a(B . ?m) (?$B$b(B . ?m)
- (?$B$c(B . ?y) (?$B$d(B . ?y) (?$B$e(B . ?y) (?$B$f(B . ?y) (?$B$g(B . ?y) (?$B$h(B . ?y)
- (?$B$i(B . ?r) (?$B$j(B . ?r) (?$B$k(B . ?r) (?$B$l(B . ?r) (?$B$m(B . ?r)
- (?$B$o(B . ?w) (?$B$p(B . ?w) (?$B$q(B . ?w) (?$B$r(B . ?w)
- (?$B$s(B . ?n)
+ '((?ぁ . ?a) (?あ . ?a) (?ぃ . ?i) (?い . ?i) (?ぅ . ?u)
+ (?う . ?u) (?ぇ . ?e) (?え . ?e) (?ぉ . ?o) (?お . ?o)
+ (?か . ?k) (?が . ?g) (?き . ?k) (?ぎ . ?g) (?く . ?k)
+ (?ぐ . ?g) (?け . ?k) (?げ . ?g) (?こ . ?k) (?ご . ?g)
+ (?さ . ?s) (?ざ . ?z) (?し . ?s) (?じ . ?j) (?す . ?s)
+ (?ず . ?z) (?せ . ?s) (?ぜ . ?z) (?そ . ?s) (?ぞ . ?z)
+ (?た . ?t) (?だ . ?d) (?ち . ?t) (?ぢ . ?d) (?っ . ?t)
+ (?つ . ?t) (?づ . ?d) (?て . ?t) (?で . ?d) (?と . ?t) (?ど . ?d)
+ (?な . ?n) (?に . ?n) (?ぬ . ?n) (?ね . ?n) (?の . ?n)
+ (?は . ?h) (?ば . ?b) (?ぱ . ?p) (?ひ . ?h) (?び . ?b)
+ (?ぴ . ?p) (?ふ . ?h) (?ぶ . ?b) (?ぷ . ?p) (?へ . ?h)
+ (?べ . ?b) (?ぺ . ?p) (?ほ . ?h) (?ぼ . ?b) (?ぽ . ?p)
+ (?ま . ?m) (?み . ?m) (?む . ?m) (?め . ?m) (?も . ?m)
+ (?ゃ . ?y) (?や . ?y) (?ゅ . ?y) (?ゆ . ?y) (?ょ . ?y) (?よ . ?y)
+ (?ら . ?r) (?り . ?r) (?る . ?r) (?れ . ?r) (?ろ . ?r)
+ (?わ . ?w) (?ゐ . ?w) (?ゑ . ?w) (?を . ?w)
+ (?ん . ?n)
)
"Alist of Okuriganas vs trailing ASCII letters in OKURI-ARI entry.")
@@ -125,14 +125,14 @@ LEIM is available from the same ftp directory as Emacs.")))
;; At first, generate vector VEC from SEQ for looking up SKK
;; alists. Nth element in VEC corresponds to Nth element in SEQ.
;; The values are decided as follows.
- ;; If SEQ[N] is `$B!<(B', VEC[N] is 0,
+ ;; If SEQ[N] is `ー', VEC[N] is 0,
;; else if SEQ[N] is a Hiragana character, VEC[N] is:
;; ((The 2nd position code of SEQ[N]) - 32),
;; else VEC[N] is 128.
(while (< i len)
(let ((ch (aref seq i))
code)
- (cond ((= ch ?$B!<(B)
+ (cond ((= ch ?ー)
(aset vec i 0))
((and (>= ch (car skkdic-jisx0208-hiragana-block))
(<= ch (cdr skkdic-jisx0208-hiragana-block)))
@@ -218,9 +218,4 @@ LEIM is available from the same ftp directory as Emacs.")))
;;
(provide 'ja-dic-utl)
-
-;; Local Variables:
-;; coding: iso-2022-7bit
-;; End:
-
;;; ja-dic-utl.el ends here
diff --git a/lisp/international/kinsoku.el b/lisp/international/kinsoku.el
index 376d23b1fa6..690a80e6595 100644
--- a/lisp/international/kinsoku.el
+++ b/lisp/international/kinsoku.el
@@ -1,4 +1,4 @@
-;;; kinsoku.el --- `Kinsoku' processing funcs -*- coding: iso-2022-7bit; -*-
+;;; kinsoku.el --- `Kinsoku' processing funcs
;; Copyright (C) 1997, 2001-2019 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -62,19 +62,19 @@ The value 0 means there's no limitation.")
idx (1+ idx)))
str2)
;; Katakana JISX0201
- "(I!#'()*+,-./0^_(B"
+ "。」ァィゥェォャュョッー゙゚"
;; Japanese JISX0208
- "$B!"!#!$!%!&!'!(!)!*!+!,!-!.!/!0!1!2!3!4!5!6!7!8!9!:!;!<!=!>(B\
-$B!?!@!A!B!C!D!E!G!I!K!M!O!Q!S!U!W!Y![!k!l!m!n(B\
-$B$!$#$%$'$)$C$c$e$g$n%!%#%%%'%)%C%c%e%g%n%u%v(B"
+ "、。,.・:;?!゛゜´`¨^ ̄_ヽヾゝゞ〃仝々〆〇ー—‐\
+/\〜‖|…‥’”)〕]}〉》」』】°′″℃\
+ぁぃぅぇぉっゃゅょゎァィゥェォッャュョヮヵヶ"
;; Chinese GB2312
- "$A!"!##.#,!$!%!&!'!(!)!*!+!,!-!/!1#)!3!5!7!9!;!=(B\
-$A!?#;#:#?#!!@!A!B!C!c!d!e!f#/#\#"#_#~#|(e(B"
+ "、。.,・ˉˇ¨〃々―~‖…’”)〕〉》」』〗\
+】;:?!±×÷∶°′″℃/\"_ ̄|ㄥ"
;; Chinese BIG5
- "$(0!"!#!$!%!&!'!(!)!*!+!,!-!.!/!0!1!2(B\
-$(0!3!4!5!6!7!8!9!:!;!<!=!?!A!C!E!G!I!K(B\
-$(0!M!O!Q!S!U!W!Y![!]!_!a!c!e!g!i!k!q(B\
-$(0"#"$"%"&"'"(")"*"+","2"3"4"j"k"l"x%7(B"))
+ ",、。.‧;:?!︰…‥﹐﹑﹒·﹔\
+﹕﹖﹗|–︱—︳╴︴﹏)︶}︸〕︺】\
+︼》︾〉﹀」﹂』﹄﹚﹜﹞’”〞′〃\
+¯ ̄_ˍ﹉﹊﹍﹎﹋﹌×÷±℃℉﹩°ㄥ"))
(len (length kinsoku-bol))
(idx 0)
ch)
@@ -102,16 +102,16 @@ The value 0 means there's no limitation.")
idx (1+ idx)))
str2)
;; JISX0201 Katakana
- "(I"(B"
+ "「"
;; Japanese JISX0208
- "$B!F!H!J!L!N!P!R!T!V!X!Z!k!l!m!n!w!x(B"
+ "‘“(〔[{〈《「『【°′″℃@§"
;; Chinese GB2312
- "$A!.!0#"#(!2!4!6!8!:!<!>!c!d!e#@!f!l(B\
-$A(E(F(G(H(I(J(K(L(M(N(O(P(Q(R(S(T(U(V(W(X(Y(h(B\
-\$(0!>!@!B!D!F!H!J!L!N!P!R!T!V!X!Z!\!^!`!b(B"
+ "‘“"(〔〈《「『〖【°′″@℃§\
+ㄅㄆㄇㄈㄉㄊㄋㄌㄍㄎㄏㄐㄑㄒㄓㄔㄕㄖㄗㄘㄙㄨ\
+\(︵{︷〔︹【︻《︽〈︿「﹁『﹃﹙﹛﹝"
;; Chinese BIG5
- "$(0!d!f!h!j!k!q!p"i"j"k"n"x$u$v$w$x$y$z${(B\
-$(0$|$}$~%!%"%#%$%%%&%'%(%)%*%+%:(B"))
+ "‘“〝‵′〃§@℃℉﹫°ㄅㄆㄇㄈㄉㄊㄋ\
+ㄌㄍㄎㄏㄐㄑㄒㄓㄔㄕㄖㄗㄘㄙㄨ"))
(len (length kinsoku-eol))
(idx 0)
ch)
diff --git a/lisp/international/kkc.el b/lisp/international/kkc.el
index df56ce26161..6691ee9eb9b 100644
--- a/lisp/international/kkc.el
+++ b/lisp/international/kkc.el
@@ -1,4 +1,4 @@
-;;; kkc.el --- Kana Kanji converter -*- coding: iso-2022-7bit; -*-
+;;; kkc.el --- Kana Kanji converter
;; Copyright (C) 1997-1998, 2001-2019 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -36,7 +36,7 @@
(require 'ja-dic-utl)
-(defvar kkc-input-method-title "$B4A(B"
+(defvar kkc-input-method-title "漢"
"String denoting KKC input method.
This string is shown at mode line when users are in KKC mode.")
diff --git a/lisp/international/latin1-disp.el b/lisp/international/latin1-disp.el
index 6aa633fb42a..1b7bc49a6be 100644
--- a/lisp/international/latin1-disp.el
+++ b/lisp/international/latin1-disp.el
@@ -201,10 +201,6 @@ character set: `latin-2', `hebrew' etc."
(char (and info (decode-char (car (remq 'ascii info)) ?\ ))))
(and char (char-displayable-p char))))
-;; Backwards compatibility.
-(define-obsolete-function-alias 'latin1-char-displayable-p
- 'char-displayable-p "22.1")
-
(defun latin1-display-setup (set &optional force)
"Set up Latin-1 display for characters in the given SET.
SET must be a member of `latin1-display-sets'. Normally, check
diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el
index 0be0f0fee2d..dfa9e4e6c8c 100644
--- a/lisp/international/mule-cmds.el
+++ b/lisp/international/mule-cmds.el
@@ -136,8 +136,7 @@
(expand-file-name "HELLO" data-directory))
:help "Demonstrate various character sets"))
(bindings--define-key map [set-various-coding-system]
- `(menu-item "Set Coding Systems" ,set-coding-system-map
- :enable (default-value 'enable-multibyte-characters)))
+ `(menu-item "Set Coding Systems" ,set-coding-system-map))
(bindings--define-key map [separator-input-method] menu-bar-separator)
(bindings--define-key map [describe-input-method]
@@ -282,9 +281,7 @@ wrong, use this command again to toggle back to the right mode."
(defun view-hello-file ()
"Display the HELLO file, which lists many languages and characters."
(interactive)
- ;; We have to decode the file in any environment.
- (let ((coding-system-for-read 'iso-2022-7bit))
- (view-file (expand-file-name "HELLO" data-directory))))
+ (view-file (expand-file-name "HELLO" data-directory)))
(defun universal-coding-system-argument (coding-system)
"Execute an I/O command using the specified coding system."
@@ -303,8 +300,7 @@ wrong, use this command again to toggle back to the right mode."
(cmd (key-binding keyseq))
prefix)
;; read-key-sequence ignores quit, so make an explicit check.
- ;; Like many places, this assumes quit == C-g, but it need not be.
- (if (equal last-input-event ?\C-g)
+ (if (equal last-input-event (nth 3 (current-input-mode)))
(keyboard-quit))
(when (memq cmd '(universal-argument digit-argument))
(call-interactively cmd)
@@ -317,16 +313,16 @@ wrong, use this command again to toggle back to the right mode."
(let ((current-prefix-arg prefix-arg)
;; Have to bind `last-command-event' here so that
;; `digit-argument', for instance, can compute the
- ;; prefix arg.
+ ;; `prefix-arg'.
(last-command-event (aref keyseq 0)))
(call-interactively cmd)))
;; This is the final call to `universal-argument-other-key', which
- ;; set's the final `prefix-arg.
+ ;; sets the final `prefix-arg'.
(let ((current-prefix-arg prefix-arg))
(call-interactively cmd))
- ;; Read the command to execute with the given prefix arg.
+ ;; Read the command to execute with the given `prefix-arg'.
(setq prefix prefix-arg
keyseq (read-key-sequence nil t)
cmd (key-binding keyseq)))
@@ -355,8 +351,7 @@ This also sets the following values:
(if (eq system-type 'darwin)
;; The file-name coding system on Darwin systems is always utf-8.
(setq default-file-name-coding-system 'utf-8-unix)
- (if (and (default-value 'enable-multibyte-characters)
- (or (not coding-system)
+ (if (and (or (not coding-system)
(coding-system-get coding-system 'ascii-compatible-p)))
(setq default-file-name-coding-system
(coding-system-change-eol-conversion coding-system 'unix))))
@@ -456,8 +451,8 @@ non-nil, it is used to sort CODINGS instead."
;; E: 1 if not XXX-with-esc
;; II: if iso-2022 based, 0..3, else 1.
(logior
- (lsh (if (eq base most-preferred) 1 0) 7)
- (lsh
+ (ash (if (eq base most-preferred) 1 0) 7)
+ (ash
(let ((mime (coding-system-get base :mime-charset)))
;; Prefer coding systems corresponding to a
;; MIME charset.
@@ -473,9 +468,9 @@ non-nil, it is used to sort CODINGS instead."
(t 3))
0))
5)
- (lsh (if (memq base lang-preferred) 1 0) 4)
- (lsh (if (memq base from-priority) 1 0) 3)
- (lsh (if (string-match-p "-with-esc\\'"
+ (ash (if (memq base lang-preferred) 1 0) 4)
+ (ash (if (memq base from-priority) 1 0) 3)
+ (ash (if (string-match-p "-with-esc\\'"
(symbol-name base))
0 1) 2)
(if (eq (coding-system-type base) 'iso-2022)
@@ -992,6 +987,11 @@ It is highly recommended to fix it before writing to a file."
;; If all the defaults failed, ask a user.
(when (not coding-system)
+ ;; If UTF-8 is in CODINGS, but is not its first member, make
+ ;; it the first one, so it is offered as the default.
+ (and (memq 'utf-8 codings) (not (eq 'utf-8 (car codings)))
+ (setq codings (append '(utf-8) (delq 'utf-8 codings))))
+
(setq coding-system (select-safe-coding-system-interactively
from to codings unsafe rejected (car codings))))
@@ -1158,10 +1158,7 @@ see `language-info-alist'."
((eq key 'nonascii-translation)
(set-language-environment-nonascii-translation lang-env))
((eq key 'charset)
- (set-language-environment-charset lang-env))
- ((and (not (default-value 'enable-multibyte-characters))
- (or (eq key 'unibyte-syntax) (eq key 'unibyte-display)))
- (set-language-environment-unibyte lang-env)))))
+ (set-language-environment-charset lang-env)))))
(defun set-language-info-internal (lang-env key info)
"Internal use only.
@@ -1333,7 +1330,7 @@ This is the input method activated automatically by the command
`toggle-input-method' (\\[toggle-input-method])."
:link '(custom-manual "(emacs)Input Methods")
:group 'mule
- :type `(choice (const nil)
+ :type '(choice (const nil)
mule-input-method-string)
:set-after '(current-language-environment))
@@ -1471,12 +1468,7 @@ If INPUT-METHOD is nil, deactivate any current input method."
(defun deactivate-input-method ()
"Turn off the current input method."
(when current-input-method
- (if input-method-history
- (unless (string= current-input-method (car input-method-history))
- (setq input-method-history
- (cons current-input-method
- (delete current-input-method input-method-history))))
- (setq input-method-history (list current-input-method)))
+ (add-to-history 'input-method-history current-input-method)
(unwind-protect
(progn
(setq input-method-function nil
@@ -1800,6 +1792,9 @@ The default status is as follows:
(setq default-sendmail-coding-system 'iso-latin-1)
;; On Darwin systems, this should be utf-8-unix, but when this file is loaded
;; that is not yet defined, so we set it in set-locale-environment instead.
+ ;; [Actually, it seems to work fine to use utf-8-unix here, and not just
+ ;; on Darwin. The previous comment seems to be outdated?
+ ;; See patch at https://debbugs.gnu.org/15803 ]
(setq default-file-name-coding-system 'iso-latin-1-unix)
;; Preserve eol-type from existing default-process-coding-systems.
;; On non-unix-like systems in particular, these may have been set
@@ -1897,9 +1892,6 @@ the new language environment, it runs `set-language-environment-hook'."
(set-language-environment-input-method language-name)
(set-language-environment-nonascii-translation language-name)
(set-language-environment-charset language-name)
- ;; Unibyte setups if necessary.
- (unless (default-value 'enable-multibyte-characters)
- (set-language-environment-unibyte language-name))
(let ((func (get-language-info language-name 'setup-function)))
(if (functionp func)
@@ -1951,7 +1943,7 @@ See `set-language-info-alist' for use in programs."
(set-language-info-alist (car elt) (cdr elt)))
;; re-set the environment in case its parameters changed
(set-language-environment current-language-environment)))
- :type `(alist
+ :type '(alist
:key-type (string :tag "Language environment"
:completions
(lambda (string pred action)
@@ -1978,28 +1970,22 @@ See `set-language-info-alist' for use in programs."
(defun standard-display-european-internal ()
;; Actually set up direct output of non-ASCII characters.
(standard-display-8bit (if (eq window-system 'pc) 128 160) 255)
- ;; Unibyte Emacs on MS-DOS wants to display all 8-bit characters with
- ;; the native font, and codes 160 and 146 stand for something very
- ;; different there.
- (or (and (eq window-system 'pc) (not (default-value
- 'enable-multibyte-characters)))
- (progn
- ;; Most X fonts used to do the wrong thing for latin-1 code 160.
- (unless (and (eq window-system 'x)
- ;; XFree86 4 has fixed the fonts.
- (string= "The XFree86 Project, Inc" (x-server-vendor))
- (> (aref (number-to-string (nth 2 (x-server-version))) 0)
- ?3))
- ;; Make non-line-break space display as a plain space.
- (aset standard-display-table (unibyte-char-to-multibyte 160) [32]))
- ;; Most Windows programs send out apostrophes as \222. Most X fonts
- ;; don't contain a character at that position. Map it to the ASCII
- ;; apostrophe. [This is actually RIGHT SINGLE QUOTATION MARK,
- ;; U+2019, normally from the windows-1252 character set. XFree 4
- ;; fonts probably have the appropriate glyph at this position,
- ;; so they could use standard-display-8bit. It's better to use a
- ;; proper windows-1252 coding system. --fx]
- (aset standard-display-table (unibyte-char-to-multibyte 146) [39]))))
+ ;; Most X fonts used to do the wrong thing for latin-1 code 160.
+ (unless (and (eq window-system 'x)
+ ;; XFree86 4 has fixed the fonts.
+ (string= "The XFree86 Project, Inc" (x-server-vendor))
+ (> (aref (number-to-string (nth 2 (x-server-version))) 0)
+ ?3))
+ ;; Make non-line-break space display as a plain space.
+ (aset standard-display-table (unibyte-char-to-multibyte 160) [32]))
+ ;; Most Windows programs send out apostrophes as \222. Most X fonts
+ ;; don't contain a character at that position. Map it to the ASCII
+ ;; apostrophe. [This is actually RIGHT SINGLE QUOTATION MARK,
+ ;; U+2019, normally from the windows-1252 character set. XFree 4
+ ;; fonts probably have the appropriate glyph at this position,
+ ;; so they could use standard-display-8bit. It's better to use a
+ ;; proper windows-1252 coding system. --fx]
+ (aset standard-display-table (unibyte-char-to-multibyte 146) [39]))
(defun set-language-environment-coding-systems (language-name)
"Do various coding system setups for language environment LANGUAGE-NAME."
@@ -2035,10 +2021,8 @@ See `set-language-info-alist' for use in programs."
(let ((input-method (get-language-info language-name 'input-method)))
(when input-method
(setq default-input-method input-method)
- (if input-method-history
- (setq input-method-history
- (cons input-method
- (delete input-method input-method-history)))))))
+ (when input-method-history
+ (add-to-history 'input-method-history input-method)))))
(defun set-language-environment-nonascii-translation (language-name)
"Do unibyte/multibyte translation setup for language environment LANGUAGE-NAME."
@@ -2197,22 +2181,27 @@ See `set-language-info-alist' for use in programs."
(defconst locale-language-names
(purecopy
'(
- ;; Locale names of the form LANGUAGE[_TERRITORY][.CODESET][@MODIFIER]
- ;; as specified in the Single Unix Spec, Version 2.
- ;; LANGUAGE is a language code taken from ISO 639:1988 (E/F)
- ;; with additions from ISO 639/RA Newsletter No.1/1989;
- ;; see Internet RFC 2165 (1997-06) and
- ;; http://www.evertype.com/standards/iso639/iso639-en.html
- ;; TERRITORY is a country code taken from ISO 3166
- ;; http://www.din.de/gremien/nas/nabd/iso3166ma/codlstp1/en_listp1.html.
- ;; CODESET and MODIFIER are implementation-dependent.
+ ;; Locale names of the form LANGUAGE[_TERRITORY][.CODESET][@MODIFIER]
+ ;; as specified in the Single Unix Spec, Version 2.
+ ;; LANGUAGE is a language code taken from ISO 639:1988 (E/F)
+ ;; with additions from ISO 639/RA Newsletter No.1/1989;
+ ;; see Internet RFC 2165 (1997-06) and
+ ;; http://www.evertype.com/standards/iso639/iso639-en.html
+ ;; TERRITORY is a country code taken from ISO 3166
+ ;; http://www.din.de/gremien/nas/nabd/iso3166ma/codlstp1/en_listp1.html.
+ ;; CODESET and MODIFIER are implementation-dependent.
+
+ ;; Language names for which there are no locales (yet) are
+ ;; commented out.
;; jasonr comments: MS Windows uses three letter codes for
;; languages instead of the two letter ISO codes that POSIX
- ;; uses. In most cases the first two letters are the same, so
- ;; most of the regexps in locale-language-names work. Japanese
- ;; and Chinese are exceptions, which are listed in the
- ;; non-standard section at the bottom of locale-language-names.
+ ;; uses. In most cases the first two letters are the same, so
+ ;; most of the regexps in locale-language-names work. Japanese,
+ ;; Chinese, and some others are exceptions, which are listed in the
+ ;; non-standard section at the bottom of locale-language-names, or
+ ;; in the main section, if otherwise we would pick up the wrong
+ ;; entry (because the first matching entry is used).
("aa_DJ" . "Latin-1") ; Afar
("aa" . "UTF-8")
@@ -2220,11 +2209,12 @@ See `set-language-info-alist' for use in programs."
("af" . "Latin-1") ; Afrikaans
("am" "Ethiopic" utf-8) ; Amharic
("an" . "Latin-9") ; Aragonese
+ ("arn" . "UTF-8") ; MS-Windows Mapudungun, Mapuche
("ar" . "Arabic")
- ; as Assamese
+ ("as" . "UTF-8") ; Assamese
; ay Aymara
("az" . "UTF-8") ; Azerbaijani
- ; ba Bashkir
+ ("ba" . "UTF-8") ; Bashkir, Cyrillic script
("be" "Belarusian" cp1251) ; Belarusian [Byelorussian until early 1990s]
("bg" "Bulgarian" cp1251) ; Bulgarian
; bh Bihari
@@ -2235,12 +2225,12 @@ See `set-language-info-alist' for use in programs."
("bs" . "Latin-2") ; Bosnian
("byn" . "UTF-8") ; Bilin; Blin
("ca" "Catalan" iso-8859-1) ; Catalan
- ; co Corsican
+ ("co" . "UTF-8") ; Corsican
("cs" "Czech" iso-8859-2)
("cy" "Welsh" iso-8859-14)
("da" . "Latin-1") ; Danish
("de" "German" iso-8859-1)
- ; dv Divehi
+ ("dv" . "UTF-8") ; Divehi
; dz Bhutani
("ee" . "Latin-4") ; Ewe
("el" "Greek" iso-8859-7)
@@ -2254,6 +2244,8 @@ See `set-language-info-alist' for use in programs."
("et" . "Latin-9") ; Estonian
("eu" . "Latin-1") ; Basque
("fa" "Persian" utf-8) ; Persian
+ ("fil" . "UTF-8") ; Filipino
+ ("fpo" . "UTF-8") ; MS-Windows Filipino
("fi" . "Latin-9") ; Finnish
("fj" . "Latin-1") ; Fiji
("fo" . "Latin-1") ; Faroese
@@ -2262,6 +2254,7 @@ See `set-language-info-alist' for use in programs."
("ga" . "Latin-1") ; Irish Gaelic (new orthography)
("gd" . "Latin-9") ; Scots Gaelic
("gez" "Ethiopic" utf-8) ; Geez
+ ("gla" . "Latin-9") ; MS-Windows Scots Gaelic
("gl" . "Latin-1") ; Gallegan; Galician
; gn Guarani
("gu" "Gujarati" utf-8) ; Gujarati
@@ -2272,27 +2265,33 @@ See `set-language-info-alist' for use in programs."
("hni_IN" . "UTF-8") ; Chhattisgarhi
("hr" "Croatian" iso-8859-2) ; Croatian
("hu" . "Latin-2") ; Hungarian
- ; hy Armenian
+ ("hy" . "UTF-8") ; Armenian
; ia Interlingua
("id" . "Latin-1") ; Indonesian
; ie Interlingue
- ; ik Inupiak
+ ("ig" . "UTF-8") ; Igbo (Nigeria)
+ ("ibo" . "UTF-8") ; MS-Windows Igbo
+ ; ik Inupiak, Inupiaq
("is" . "Latin-1") ; Icelandic
("it" "Italian" iso-8859-1) ; Italian
; iu Inuktitut
("iw" "Hebrew" iso-8859-8)
("ja" "Japanese" euc-jp)
; jw Javanese
+ ("kal" . "Latin-1") ; MS-Windows Greenlandic
("ka" "Georgian" georgian-ps) ; Georgian
- ; kk Kazakh
+ ("kk" . "UTF-8") ; Kazakh
("kl" . "Latin-1") ; Greenlandic
("km" "Khmer" utf-8) ; Cambodian, Khmer
+ ("knk" "Devanagari" utf-8) ; MS-Windows Konkani
+ ("kok" "Devanagari" utf-8) ; Konkani
("kn" "Kannada" utf-8)
("ko" "Korean" euc-kr)
("ks" . "UTF-8") ; Kashmiri
; ku Kurdish
("kw" . "Latin-1") ; Cornish
("ky" . "UTF-8") ; Kirghiz
+ ("lao" "Lao" utf-8) ; MS-Windows Lao
("la" . "Latin-1") ; Latin
("lb" . "Latin-1") ; Luxemburgish
("lg" . "Latin-6") ; Ganda, a.k.a. Luganda
@@ -2303,18 +2302,22 @@ See `set-language-info-alist' for use in programs."
; mg Malagasy
("mi" . "Latin-7") ; Maori
("mk" "Cyrillic-ISO" iso-8859-5) ; Macedonian
+ ("mlt" . "Latin-3") ; MS-Windows Maltese
("ml" "Malayalam" utf-8)
("mn" . "UTF-8") ; Mongolian
- ; mo Moldavian
+ ; mo Moldavian (retired)
+ ("mri" . "Latin-7") ; MS-Windows Maori
("mr" "Devanagari" utf-8) ; Marathi
("ms" . "Latin-1") ; Malay
("mt" . "Latin-3") ; Maltese
+ ("mym" "Malayalam" utf-8) ; MS-Windows Malayalam
("my" "Burmese" utf-8) ; Burmese
; na Nauru
("nb" . "Latin-1") ; Norwegian
("ne" "Devanagari" utf-8) ; Nepali
("nl" "Dutch" iso-8859-1)
("nn" . "Latin-1") ; Norwegian Nynorsk
+ ("non" . "Latin-1") ; MS-Windows Norwegian Nynorsk
("no" . "Latin-1") ; Norwegian
("nr_ZA" . "UTF-8") ; South Ndebele
("nso_ZA" . "UTF-8") ; Pedi
@@ -2324,7 +2327,8 @@ See `set-language-info-alist' for use in programs."
("or" "Oriya" utf-8)
("pa" "Punjabi" utf-8) ; Punjabi
("pl" "Polish" iso-8859-2) ; Polish
- ; ps Pashto, Pushto
+ ("ps" . "UTF-8") ; Pashto, Pushto
+ ("pas" . "UTF-8") ; MS-Windows Pashto
("pt_BR" "Brazilian Portuguese" iso-8859-1) ; Brazilian Portuguese
("pt" . "Latin-1") ; Portuguese
; qu Quechua
@@ -2334,7 +2338,7 @@ See `set-language-info-alist' for use in programs."
("ru_RU.koi8r" "Cyrillic-KOI8" koi8-r)
("ru_RU" "Russian" iso-8859-5)
("ru_UA" "Russian" koi8-u)
- ; rw Kinyarwanda
+ ("rw" . "UTF-8") ; Kinyarwanda
("sa" . "Devanagari") ; Sanskrit
; sd Sindhi
("se" . "UTF-8") ; Northern Sami
@@ -2355,6 +2359,7 @@ See `set-language-info-alist' for use in programs."
; su Sundanese
("sv" "Swedish" iso-8859-1) ; Swedish
("sw" . "Latin-1") ; Swahili
+ ("taj" "Tajik" koi8-t) ; MS-Windows Tajik w/Cyrillic script
("ta" "Tamil" utf-8)
("te" "Telugu" utf-8) ; Telugu
("tg" "Tajik" koi8-t)
@@ -2364,15 +2369,17 @@ See `set-language-info-alist' for use in programs."
("th" "Thai" iso-8859-11)
("ti" "Ethiopic" utf-8) ; Tigrinya
("tig_ER" . "UTF-8") ; Tigre
- ; tk Turkmen
+ ("tk" . "Latin-5") ; Turkmen
+ ("tuk" . "Latin-5") ; MS-Windows Turkmen
("tl" . "Latin-1") ; Tagalog
("tn" . "Latin-9") ; Setswana, Tswana
; to Tonga
("tr" "Turkish" iso-8859-9)
+ ("tsn" . "Latin-9") ; MS-Windows Tswana
("ts" . "Latin-1") ; Tsonga
("tt" . "UTF-8") ; Tatar
; tw Twi
- ; ug Uighur
+ ("ug" . "UTF-8") ; Uighur
("uk" "Ukrainian" koi8-u)
("ur" . "UTF-8") ; Urdu
("uz_UZ@cyrillic" . "UTF-8"); Uzbek
@@ -2381,10 +2388,10 @@ See `set-language-info-alist' for use in programs."
("vi" "Vietnamese" utf-8)
; vo Volapuk
("wa" . "Latin-1") ; Walloon
- ; wo Wolof
+ ("wo" . "UTF-8") ; Wolof
("xh" . "Latin-1") ; Xhosa
("yi" . "Windows-1255") ; Yiddish
- ; yo Yoruba
+ ("yo" . "UTF-8") ; Yoruba
; za Zhuang
("zh_HK" . "Chinese-Big5")
; zh_HK/BIG5-HKSCS \
@@ -2394,6 +2401,9 @@ See `set-language-info-alist' for use in programs."
("zh_CN.GB18030" "Chinese-GB18030")
("zh_CN.UTF-8" . "Chinese-GBK")
("zh_CN" . "Chinese-GB")
+ ("zhh" . "Chinese-Big5") ; MS-Windows Chinese (Hong Kong S.A.R.)
+ ("zhi" . "Chinese-GBK") ; MS-Windows Chinese (Singapore)
+ ("zhm" . "Chinese-Big5") ; MS-Windows Chinese (Macao S.A.R.)
("zh" . "Chinese-GB")
("zu" . "Latin-1") ; Zulu
@@ -2411,12 +2421,23 @@ See `set-language-info-alist' for use in programs."
("sp" . "Cyrillic-ISO") ; Serbian (Cyrillic alphabet), e.g. X11R6.4
("su" . "Latin-1") ; Finnish, e.g. Solaris 2.6
("jp" . "Japanese") ; e.g. MS Windows
- ("chs" . "Chinese-GBK") ; MS Windows Chinese Simplified
- ("cht" . "Chinese-BIG5") ; MS Windows Chinese Traditional
+ ("chs" . "Chinese-GBK") ; MS Windows Chinese Simplified (PRC)
+ ("cht" . "Chinese-BIG5") ; MS Windows Chinese Traditional (Taiwan)
("gbz" . "UTF-8") ; MS Windows Dari Persian
("div" . "UTF-8") ; MS Windows Divehi (Maldives)
("wee" . "Latin-2") ; MS Windows Lower Sorbian
("wen" . "Latin-2") ; MS Windows Upper Sorbian
+ ("ind" . "Latin-1") ; MS-Windows Indonesian
+ ("sme" . "UTF-8") ; MS-Windows Northern Sami (Norway)
+ ("smf" . "UTF-8") ; MS-Windows Northern Sami (Sweden)
+ ("smg" . "UTF-8") ; MS-Windows Northern Sami (Finland)
+ ("kdi" "Kannada" utf-8) ; MS-Windows Kannada
+ ("mar" "Devanagari" utf-8) ; MS-Windows Marathi
+ ("khm" "Khmer" utf-8) ; MS-Windows Khmer
+ ("iri" . "Latin-1") ; MS-Windows Irish Gaelic
+ ; mwk MS-Windows Mohawk (Canada)
+ ("uig" . "UTF-8") ; MS-Windows Uighur
+ ("kin" . "UTF-8") ; MS-Windows Kinyarwanda
))
"Alist of locale regexps vs the corresponding languages and coding systems.
Each element has this form:
@@ -2675,12 +2696,8 @@ See also `locale-charset-language-names', `locale-language-names',
(unless frame
(set-language-environment language-name))
- ;; If the default enable-multibyte-characters is nil,
- ;; we are using single-byte characters,
- ;; so the display table and terminal coding system are irrelevant.
- (when (default-value 'enable-multibyte-characters)
- (set-display-table-and-terminal-coding-system
- language-name coding-system frame))
+ (set-display-table-and-terminal-coding-system
+ language-name coding-system frame)
;; Set the `keyboard-coding-system' if appropriate (tty
;; only). At least X and MS Windows can generate
@@ -2722,10 +2739,20 @@ See also `locale-charset-language-names', `locale-language-names',
(output-coding
(if noninteractive
(intern (format "cp%d" (w32-get-console-output-codepage)))
- code-page-coding)))
- (when (coding-system-p code-page-coding)
+ code-page-coding))
+ (multibyte-code-page-coding
+ (or (and (boundp 'w32-multibyte-code-page)
+ (not (zerop w32-multibyte-code-page))
+ (intern (format "cp%d" w32-multibyte-code-page)))
+ code-page-coding))
+ (locale-coding
+ (if noninteractive
+ code-page-coding
+ multibyte-code-page-coding)))
+ (when (and (coding-system-p code-page-coding)
+ (coding-system-p locale-coding))
(or output-coding (setq output-coding code-page-coding))
- (unless frame (setq locale-coding-system code-page-coding))
+ (unless frame (setq locale-coding-system locale-coding))
(set-keyboard-coding-system code-page-coding frame)
(set-terminal-coding-system output-coding frame)
(setq default-file-name-coding-system ansi-code-page-coding))))
@@ -2747,7 +2774,6 @@ See also `locale-charset-language-names', `locale-language-names',
(let ((paper (locale-info 'paper))
locale)
(if paper
- ;; This will always be null at the time of writing.
(cond
((equal paper '(216 279))
(setq ps-paper-type 'letter))
@@ -2950,12 +2976,13 @@ on encoding."
(#x14400 . #x14646)
;; (#x14647 . #x167FF) unused
(#x16800 . #x16F9F)
- (#x16FE0 . #x16FE0)
+ (#x16FE0 . #x16FE3)
;; (#x17000 . #x187FF) Tangut Ideographs
;; (#x18800 . #x18AFF) Tangut Components
;; (#x18B00 . #x1AFFF) unused
- (#x1B000 . #x1B12F)
- ;; (#x1B130 . #x1B16F) unused
+ (#x1B000 . #x1B11F)
+ ;; (#x1B120 . #x1B14F) unused
+ (#x1B150 . #x1B16F)
(#x1B170 . #x1B2FF)
;; (#x1B300 . #x1BBFF) unused
(#x1BC00 . #x1BCAF)
diff --git a/lisp/international/mule-conf.el b/lisp/international/mule-conf.el
index 6db795739de..c84dc819d1c 100644
--- a/lisp/international/mule-conf.el
+++ b/lisp/international/mule-conf.el
@@ -222,20 +222,19 @@
;; Can this be shared with 8859-11?
;; N.b. not all of these are defined in Unicode.
(define-charset 'thai-tis620
- "TIS620.2533"
+ "MULE charset for TIS620.2533"
:short-name "TIS620.2533"
:iso-final-char ?T
:emacs-mule-id 133
:code-space [32 127]
:code-offset #x0E00)
-;; Fixme: doc for this, c.f. above
(define-charset 'tis620-2533
- "TIS620.2533"
+ "TIS620.2533, a.k.a. TIS-620. Like `thai-iso8859-11', but without NBSP."
:short-name "TIS620.2533"
:ascii-compatible-p t
:code-space [0 255]
- :superset '(ascii eight-bit-control (thai-tis620 . 128)))
+ :superset '(ascii (thai-tis620 . 128)))
(define-charset 'jisx0201
"JISX0201"
@@ -1067,6 +1066,15 @@
:mime-charset 'ebcdic-uk
:map "EBCDICUK")
+(define-charset 'ibm038
+ "International version of EBCDIC"
+ :short-name "IBM038"
+ :code-space [0 255]
+ :mime-charset 'ibm038
+ :map "IBM038")
+(define-charset-alias 'ebcdic-int 'ibm038)
+(define-charset-alias 'cp038 'ibm038)
+
(define-charset 'ibm1047
;; Says groff:
"IBM1047, `EBCDIC Latin 1/Open Systems' used by OS/390 Unix."
@@ -1576,6 +1584,61 @@ for decoding and encoding files, process I/O, etc."
(aset latin-extra-code-table ?\225 t)
(aset latin-extra-code-table ?\226 t)
+(defcustom password-word-equivalents
+ '("password" "passcode" "passphrase" "pass phrase"
+ ; These are sorted according to the GNU en_US locale.
+ "암호" ; ko
+ "パスワード" ; ja
+ "ପ୍ରବେଶ ସଙ୍କେତ" ; or
+ "ពាក្យសម្ងាត់" ; km
+ "adgangskode" ; da
+ "contraseña" ; es
+ "contrasenya" ; ca
+ "geslo" ; sl
+ "hasło" ; pl
+ "heslo" ; cs, sk
+ "iphasiwedi" ; zu
+ "jelszó" ; hu
+ "lösenord" ; sv
+ "lozinka" ; hr, sr
+ "mật khẩu" ; vi
+ "mot de passe" ; fr
+ "parola" ; tr
+ "pasahitza" ; eu
+ "passord" ; nb
+ "passwort" ; de
+ "pasvorto" ; eo
+ "salasana" ; fi
+ "senha" ; pt
+ "slaptažodis" ; lt
+ "wachtwoord" ; nl
+ "كلمة السر" ; ar
+ "ססמה" ; he
+ "лозинка" ; sr
+ "пароль" ; kk, ru, uk
+ "गुप्तशब्द" ; mr
+ "शब्दकूट" ; hi
+ "પાસવર્ડ" ; gu
+ "సంకేతపదము" ; te
+ "ਪਾਸਵਰਡ" ; pa
+ "ಗುಪ್ತಪದ" ; kn
+ "கடவுச்சொல்" ; ta
+ "അടയാളവാക്ക്" ; ml
+ "গুপ্তশব্দ" ; as
+ "পাসওয়ার্ড" ; bn_IN
+ "රහස්පදය" ; si
+ "密码" ; zh_CN
+ "密碼" ; zh_TW
+ )
+ "List of words equivalent to \"password\".
+This is used by Shell mode and other parts of Emacs to recognize
+password prompts, including prompts in languages other than
+English. Different case choices should not be assumed to be
+included; callers should bind `case-fold-search' to t."
+ :type '(repeat string)
+ :version "24.4"
+ :group 'processes)
+
;; The old code-pages library is obsoleted by coding systems based on
;; the charsets defined in this file but might be required by user
;; code.
diff --git a/lisp/international/mule-diag.el b/lisp/international/mule-diag.el
index d6ac8944d78..472529ffc05 100644
--- a/lisp/international/mule-diag.el
+++ b/lisp/international/mule-diag.el
@@ -1104,8 +1104,6 @@ system which uses fontsets)."
(insert "Version of this emacs:\n " (emacs-version) "\n\n")
(insert "Configuration options:\n " system-configuration-options "\n\n")
(insert "Multibyte characters awareness:\n"
- (format " default: %S\n" (default-value
- 'enable-multibyte-characters))
(format " current-buffer: %S\n\n" enable-multibyte-characters))
(insert "Current language environment: " current-language-environment
"\n\n")
diff --git a/lisp/international/mule-util.el b/lisp/international/mule-util.el
index 2526f1ee324..8ad212796a5 100644
--- a/lisp/international/mule-util.el
+++ b/lisp/international/mule-util.el
@@ -342,7 +342,7 @@ per-character basis, this may not be accurate."
(let ((eol-offset 0)
;; Make sure we terminate, even if BYTE falls right in the middle
;; of a CRLF or some other weird corner case.
- (omin 0) (omax most-positive-fixnum)
+ (omin 0) omax
pos lines)
(while
(progn
@@ -355,9 +355,9 @@ per-character basis, this may not be accurate."
(setq pos (point-max))))
;; Adjust POS for DOS EOL format.
(setq lines (1- (line-number-at-pos pos)))
- (and (not (= lines eol-offset)) (> omax omin)))
+ (and (not (= lines eol-offset)) (or (not omax) (> omax omin))))
(if (> lines eol-offset)
- (setq omax (min (1- omax) lines)
+ (setq omax (if omax (min (1- omax) lines) lines)
eol-offset omax)
(setq omin (max (1+ omin) lines)
eol-offset omin)))
@@ -393,17 +393,17 @@ QUALITY can be:
japanese-cp932 korean-cp949)))
(setq type 'single-byte))
(pcase type
- (`utf-8
+ ('utf-8
(when (coding-system-get coding-system :bom)
(setq byte (max 0 (- byte 3))))
(if (= eol 1)
(filepos-to-bufferpos--dos (+ pm byte) #'byte-to-position)
(byte-to-position (+ pm byte))))
- (`single-byte
+ ('single-byte
(if (= eol 1)
(filepos-to-bufferpos--dos (+ pm byte) #'identity)
(+ pm byte)))
- ((and `utf-16
+ ((and 'utf-16
;; FIXME: For utf-16, we could use the same approach as used for
;; dos EOLs (counting the number of non-BMP chars instead of the
;; number of lines).
@@ -419,8 +419,8 @@ QUALITY can be:
(+ pm byte)))
(_
(pcase quality
- (`approximate (byte-to-position (+ pm byte)))
- (`exact
+ ('approximate (byte-to-position (+ pm byte)))
+ ('exact
;; Rather than assume that the file exists and still holds the right
;; data, we reconstruct it based on the buffer's content.
(let ((buf (current-buffer)))
@@ -470,7 +470,7 @@ QUALITY can be:
japanese-cp932 korean-cp949)))
(setq type 'single-byte))
(pcase type
- (`utf-8
+ ('utf-8
(setq byte (position-bytes position))
(when (null byte)
(if (<= position 0)
@@ -482,9 +482,9 @@ QUALITY can be:
(if (coding-system-get coding-system :bom) 3 0)
;; Account for CR in CRLF pairs.
lineno))
- (`single-byte
+ ('single-byte
(+ position -1 lineno))
- ((and `utf-16
+ ((and 'utf-16
;; FIXME: For utf-16, we could use the same approach as used for
;; dos EOLs (counting the number of non-BMP chars instead of the
;; number of lines).
@@ -498,8 +498,8 @@ QUALITY can be:
lineno))
(_
(pcase quality
- (`approximate (+ (position-bytes position) -1 lineno))
- (`exact
+ ('approximate (+ (position-bytes position) -1 lineno))
+ ('exact
;; Rather than assume that the file exists and still holds the right
;; data, we reconstruct its relevant portion.
(let ((buf (current-buffer)))
diff --git a/lisp/international/mule.el b/lisp/international/mule.el
index cc0658dc3f4..ba30fee4961 100644
--- a/lisp/international/mule.el
+++ b/lisp/international/mule.el
@@ -343,7 +343,7 @@ Return t if file exists."
;; Have the original buffer current while we eval.
(eval-buffer buffer nil
;; This is compatible with what `load' does.
- (if purify-flag file fullname)
+ (if dump-mode file fullname)
nil t))
(let (kill-buffer-hook kill-buffer-query-functions)
(kill-buffer buffer)))
@@ -819,10 +819,10 @@ VALUE is a CCL program name defined by `define-ccl-program'. The
CCL program reads a character sequence and writes a byte sequence
as an encoding result.
-`:inhibit-null-byte-detection'
+`:inhibit-nul-byte-detection'
VALUE non-nil means Emacs ignore null bytes on code detection.
-See the variable `inhibit-null-byte-detection'. This attribute
+See the variable `inhibit-nul-byte-detection'. This attribute
is meaningful only when `:coding-type' is `undecided'.
`:inhibit-iso-escape-detection'
@@ -867,7 +867,7 @@ non-ASCII files. This attribute is meaningful only when
:ccl-encoder
:valids))
((eq coding-type 'undecided)
- '(:inhibit-null-byte-detection
+ '(:inhibit-nul-byte-detection
:inhibit-iso-escape-detection
:prefer-utf-8))))))
@@ -911,7 +911,7 @@ non-ASCII files. This attribute is meaningful only when
(i 0))
(dolist (elt coding-system-iso-2022-flags)
(if (memq elt flags)
- (setq bits (logior bits (lsh 1 i))))
+ (setq bits (logior bits (ash 1 i))))
(setq i (1+ i)))
(setcdr (assq :flags spec-attrs) bits))))
@@ -920,8 +920,8 @@ non-ASCII files. This attribute is meaningful only when
(cons :name (cons name (cons :docstring (cons (purecopy docstring)
props)))))
(setcdr (assq :plist common-attrs) props)
- (apply 'define-coding-system-internal
- name (mapcar 'cdr (append common-attrs spec-attrs)))))
+ (apply #'define-coding-system-internal
+ name (mapcar #'cdr (append common-attrs spec-attrs)))))
(defun coding-system-doc-string (coding-system)
"Return the documentation string for CODING-SYSTEM."
@@ -1514,6 +1514,7 @@ DECODING is the coding system to be used to decode input from the process,
ENCODING is the coding system to be used to encode output to the process.
For a list of possible coding systems, use \\[list-coding-systems]."
+ (declare (interactive-only set-process-coding-system))
(interactive
"zCoding-system for output from the process: \nzCoding-system for input to the process: ")
(let ((proc (get-buffer-process (current-buffer))))
@@ -2554,7 +2555,7 @@ This function is intended to be added to `auto-coding-functions'."
;; (allowing for whitespace at bob). Note: 'DOCTYPE NETSCAPE' is
;; useful for Mozilla bookmark files.
(when (and (re-search-forward "\\`[[:space:]\n]*\\(<!doctype[[:space:]\n]+\\(html\\|netscape\\)\\|<html\\)" size t)
- (re-search-forward "<meta\\s-+\\(http-equiv=[\"']?content-type[\"']?\\s-+content=[\"']text/\\sw+;\\s-*\\)?charset=[\"']?\\(.+?\\)[\"'\\s-/>]" size t))
+ (re-search-forward "<meta\\s-+\\(http-equiv=[\"']?content-type[\"']?\\s-+content=[\"']text/\\sw+;\\s-*\\)?charset=[\"']?\\(.+?\\)[\"'[:space:]/>]" size t))
(let* ((match (match-string 2))
(sym (intern (downcase match))))
(if (coding-system-p sym)
diff --git a/lisp/international/quail.el b/lisp/international/quail.el
index f1fb5f7c605..3266b93b446 100644
--- a/lisp/international/quail.el
+++ b/lisp/international/quail.el
@@ -568,7 +568,7 @@ While this input method is active, the variable
(quail-delete-overlays)
(setq describe-current-input-method-function nil)
(quail-hide-guidance)
- (remove-hook 'post-command-hook 'quail-show-guidance t)
+ (remove-hook 'post-command-hook #'quail-show-guidance t)
(run-hooks 'quail-deactivate-hook))
(kill-local-variable 'input-method-function))
;; Let's activate Quail input method.
@@ -579,19 +579,18 @@ While this input method is active, the variable
(setq name (car (car quail-package-alist)))
(error "No Quail package loaded"))
(quail-select-package name)))
- (setq deactivate-current-input-method-function 'quail-deactivate)
- (setq describe-current-input-method-function 'quail-help)
+ (setq deactivate-current-input-method-function #'quail-deactivate)
+ (setq describe-current-input-method-function #'quail-help)
(quail-delete-overlays)
(setq quail-guidance-str "")
(quail-show-guidance)
;; If we are in minibuffer, turn off the current input method
;; before exiting.
(when (eq (selected-window) (minibuffer-window))
- (add-hook 'minibuffer-exit-hook 'quail-exit-from-minibuffer)
- (add-hook 'post-command-hook 'quail-show-guidance nil t))
+ (add-hook 'minibuffer-exit-hook #'quail-exit-from-minibuffer)
+ (add-hook 'post-command-hook #'quail-show-guidance nil t))
(run-hooks 'quail-activate-hook)
- (make-local-variable 'input-method-function)
- (setq input-method-function 'quail-input-method)))
+ (setq-local input-method-function #'quail-input-method)))
(define-obsolete-variable-alias
'quail-inactivate-hook
@@ -1367,9 +1366,7 @@ If STR has `advice' text property, append the following special event:
(let ((start (overlay-start overlay))
(end (overlay-end overlay)))
(if (< start end)
- (prog1
- (string-to-list (buffer-substring start end))
- (delete-region start end)))))
+ (string-to-list (delete-and-extract-region start end)))))
(defsubst quail-delete-region ()
"Delete the text in the current translation region of Quail."
@@ -1394,12 +1391,13 @@ Return the input string."
(generated-events nil) ;FIXME: What is this?
(input-method-function nil)
(modified-p (buffer-modified-p))
- last-command-event last-command this-command)
+ last-command-event last-command this-command inhibit-record)
(setq quail-current-key ""
quail-current-str ""
quail-translating t)
(if key
- (setq unread-command-events (cons key unread-command-events)))
+ (setq unread-command-events (cons key unread-command-events)
+ inhibit-record t))
(while quail-translating
(set-buffer-modified-p modified-p)
(quail-show-guidance)
@@ -1408,8 +1406,13 @@ Return the input string."
(or input-method-previous-message "")
quail-current-str
quail-guidance-str)))
+ ;; We inhibit record_char only for the first key,
+ ;; because it was already recorded before read_char
+ ;; called quail-input-method.
+ (inhibit--record-char inhibit-record)
(keyseq (read-key-sequence prompt nil nil t))
(cmd (lookup-key (quail-translation-keymap) keyseq)))
+ (setq inhibit-record nil)
(if (if key
(and (commandp cmd) (not (eq cmd 'quail-other-command)))
(eq cmd 'quail-self-insert-command))
@@ -1453,14 +1456,15 @@ Return the input string."
(generated-events nil) ;FIXME: What is this?
(input-method-function nil)
(modified-p (buffer-modified-p))
- last-command-event last-command this-command)
+ last-command-event last-command this-command inhibit-record)
(setq quail-current-key ""
quail-current-str ""
quail-translating t
quail-converting t
quail-conversion-str "")
(if key
- (setq unread-command-events (cons key unread-command-events)))
+ (setq unread-command-events (cons key unread-command-events)
+ inhibit-record t))
(while quail-converting
(set-buffer-modified-p modified-p)
(or quail-translating
@@ -1476,8 +1480,13 @@ Return the input string."
quail-conversion-str
quail-current-str
quail-guidance-str)))
+ ;; We inhibit record_char only for the first key,
+ ;; because it was already recorded before read_char
+ ;; called quail-input-method.
+ (inhibit--record-char inhibit-record)
(keyseq (read-key-sequence prompt nil nil t))
(cmd (lookup-key (quail-conversion-keymap) keyseq)))
+ (setq inhibit-record nil)
(if (if key (commandp cmd) (eq cmd 'quail-self-insert-command))
(progn
(setq last-command-event (aref keyseq (1- (length keyseq)))
diff --git a/lisp/international/titdic-cnv.el b/lisp/international/titdic-cnv.el
index ac5a0e8861d..e6065fb0f76 100644
--- a/lisp/international/titdic-cnv.el
+++ b/lisp/international/titdic-cnv.el
@@ -1,4 +1,4 @@
-;;; titdic-cnv.el --- convert cxterm dictionary (TIT format) to Quail package -*- coding:iso-2022-7bit; -*-
+;;; titdic-cnv.el --- convert cxterm dictionary (TIT format) to Quail package -*- coding: utf-8-emacs; lexical-binding:t -*-
;; Copyright (C) 1997-1998, 2000-2019 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -83,9 +83,9 @@
;; how to select a translation from a list of candidates.
(defvar quail-cxterm-package-ext-info
- '(("chinese-4corner" "$(0(?-F(B")
- ("chinese-array30" "$(0#R#O(B")
- ("chinese-ccdospy" "$AKuF4(B"
+ '(("chinese-4corner" "四角")
+ ("chinese-array30" "30")
+ ("chinese-ccdospy" "缩拼"
"Pinyin base input method for Chinese charset GB2312 (`chinese-gb2312').
Pinyin is the standard Roman transliteration method for Chinese.
@@ -94,10 +94,10 @@ method `chinese-py'.
This input method works almost the same way as `chinese-py'. The
difference is that you type a single key for these Pinyin spelling.
- Pinyin: zh en eng ang ch an ao ai ong sh ing yu($A(9(B)
+ Pinyin: zh en eng ang ch an ao ai ong sh ing yu(ü)
keyseq: a f g h i j k l s u y v
For example:
- Chinese: $A0!(B $A9{(B $AVP(B $AND(B $A9b(B $ASq(B $AH+(B
+ Chinese: 啊 果 中 文 光 玉 全
Pinyin: a guo zhong wen guang yu quan
Keyseq: a1 guo4 as1 wf4 guh1 yu..6 qvj6
@@ -106,14 +106,14 @@ For example:
For double-width GB2312 characters corresponding to ASCII, use the
input method `chinese-qj'.")
- ("chinese-ecdict" "$(05CKH(B"
+ ("chinese-ecdict" "英漢"
"In this input method, you enter a Chinese (Big5) character or word
by typing the corresponding English word. For example, if you type
-\"computer\", \"$(0IZH+(B\" is input.
+\"computer\", \"電腦\" is input.
\\<quail-translation-docstring>")
- ("chinese-etzy" "$(06/0D(B"
+ ("chinese-etzy" "倚注"
"Zhuyin base input method for Chinese Big5 characters (`chinese-big5-1',
`chinese-big5-2').
@@ -122,20 +122,20 @@ compose one Chinese character.
In this input method, you enter a Chinese character by first typing
keys corresponding to Zhuyin symbols (see the above table) followed by
-SPC, 1, 2, 3, or 4 specifying a tone (SPC:$(0?v(N(B, 1:$(0M=Vy(B, 2:$(0Dm(N(B, 3: $(0&9Vy(B,
-4:$(0(+Vy(B).
+SPC, 1, 2, 3, or 4 specifying a tone (SPC:陰平, 1:輕聲, 2:陽平, 3: 上聲,
+4:去聲).
\\<quail-translation-docstring>")
- ("chinese-punct-b5" "$(0O:(BB"
+ ("chinese-punct-b5" "標B"
"Input method for Chinese punctuation and symbols of Big5
\(`chinese-big5-1' and `chinese-big5-2').")
- ("chinese-punct" "$A1j(BG"
+ ("chinese-punct" "标G"
"Input method for Chinese punctuation and symbols of GB2312
\(`chinese-gb2312').")
- ("chinese-py-b5" "$(03<(BB"
+ ("chinese-py-b5" "拼B"
"Pinyin base input method for Chinese Big5 characters
\(`chinese-big5-1', `chinese-big5-2').
@@ -153,28 +153,28 @@ method `chinese-qj-b5'.
The input method `chinese-py' and `chinese-tonepy' are also Pinyin
based, but for the character set GB2312 (`chinese-gb2312').")
- ("chinese-qj-b5" "$(0)A(BB")
+ ("chinese-qj-b5" "全B")
- ("chinese-qj" "$AH+(BG")
+ ("chinese-qj" "全G")
- ("chinese-sw" "$AJWN2(B"
+ ("chinese-sw" "首尾"
"Radical base input method for Chinese charset GB2312 (`chinese-gb2312').
In this input method, you enter a Chinese character by typing two
-keys. The first key corresponds to the first ($AJW(B) radical, the second
-key corresponds to the last ($AN2(B) radical. The correspondence of keys
+keys. The first key corresponds to the first (首) radical, the second
+key corresponds to the last (尾) radical. The correspondence of keys
and radicals is as below:
first radical:
a b c d e f g h i j k l m n o p q r s t u v w x y z
- $APD(B $AZ"(B $AJ,(B $AX<(B $A;p(B $A?Z(B $A^P(B $Ac_(B $AZ%(B $A\3(B $AXi(B $AD>(B $Alj(B $Ab;(B $ATB(B $Afy(B $AJ/(B $AMu(B $A0K(B $AX/(B $AHU(B $AeA(B $Aak(B $AVq(B $AR;(B $AHK(B
+ 心 冖 尸 丶 火 口 扌 氵 讠 艹 亻 木 礻 饣 月 纟 石 王 八 丿 日 辶 犭 竹 一 人
last radical:
a b c d e f g h i j k l m n o p q r s t u v w x y z
- $ASV(B $AI=(B $AMA(B $A56(B $AZb(B $A?Z(B $ARB(B $Aqb(B $A4s(B $A6!(B $A[L(B $Ala(B $AJ.(B $A4u(B $AXg(B $ACE(B $A=q(B $AX-(B $AE.(B $ARR(B $A`m(B $AP!(B $A3'(B $A3f(B $A_.(B $A27(B
+ 又 山 土 刀 阝 口 衣 疋 大 丁 厶 灬 十 歹 冂 门 今 丨 女 乙 囗 小 厂 虫 弋 卜
\\<quail-translation-docstring>")
- ("chinese-tonepy" "$A5wF4(B"
+ ("chinese-tonepy" "调拼"
"Pinyin base input method for Chinese charset GB2312 (`chinese-gb2312').
Pinyin is the standard roman transliteration method for Chinese.
@@ -183,18 +183,18 @@ method `chinese-py'.
This input method works almost the same way as `chinese-py'. The
difference is that you must type 1..5 after each Pinyin spelling to
-specify a tone (1:$ARuF=(B, 2:$AQtF=(B, 3:$AIOIy(B, 4$AOBIy(B, 5:$AGaIy(B).
+specify a tone (1:阴平, 2:阳平, 3:上声, 4下声, 5:轻声).
\\<quail-translation-docstring>
-For instance, to input $ADc(B, you type \"n i 3 3\", the first \"n i\" is
+For instance, to input 你, you type \"n i 3 3\", the first \"n i\" is
a Pinyin, the next \"3\" specifies tone, and the last \"3\" selects
the third character from the candidate list.
For double-width GB2312 characters corresponding to ASCII, use the
input method `chinese-qj'.")
- ("chinese-zozy" "$(0I\0D(B"
+ ("chinese-zozy" "零注"
"Zhuyin base input method for Chinese Big5 characters (`chinese-big5-1',
`chinese-big5-2').
@@ -203,8 +203,8 @@ compose a Chinese character.
In this input method, you enter a Chinese character by first typing
keys corresponding to Zhuyin symbols (see the above table) followed by
-SPC, 6, 3, 4, or 7 specifying a tone (SPC:$(0?v(N(B, 6:$(0Dm(N(B, 3:$(0&9Vy(B, 4:$(0(+Vy(B,
-7:$(0M=Vy(B).
+SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲,
+7:輕聲).
\\<quail-translation-docstring>")))
@@ -348,7 +348,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:$(0?v(N(B, 6:$(0Dm(N(B, 3:$(0&9Vy
(princ (nth 2 (assoc tit-encode tit-encode-list)))
(princ "\" \"")
(princ (or title
- (if (string-match "[:$A!K$(0!(!J(B]+\\([^:$A!K$(0!(!K(B]+\\)" tit-prompt)
+ (if (string-match "[:∷:【]+\\([^:∷:】]+\\)" tit-prompt)
(substring tit-prompt (match-beginning 1) (match-end 1))
tit-prompt)))
(princ "\"\n"))
@@ -417,9 +417,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:$(0?v(N(B, 6:$(0Dm(N(B, 3:$(0&9Vy
;; function call.
(defun tit-process-body ()
(message "Formatting translation rules...")
- (let* ((template (list nil nil))
- (second (cdr template))
- (prev-key "")
+ (let* ((prev-key "")
ch key translations pos)
(princ "(quail-define-rules\n")
(while (null (eobp))
@@ -500,8 +498,7 @@ the generated Quail package is saved."
(goto-char (point-min))
(decode-coding-region (point-min) (point-max) coding-system)
;; Explicitly set eol format to `unix'.
- (setq coding-system-for-write
- (coding-system-change-eol-conversion coding-system 'unix))
+ (setq coding-system-for-write 'utf-8-unix)
(remove-text-properties (point-min) (point-max) '(charset nil)))
(set-buffer-multibyte t)
@@ -522,7 +519,6 @@ the generated Quail package is saved."
(princ ";; Local Variables:\n")
(princ ";; version-control: never\n")
(princ ";; no-update-autoloads: t\n")
- (princ (format ";; coding: %s\n" coding-system-for-write))
(princ ";; End:\n"))))))
;;;###autoload
@@ -581,7 +577,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
;; )
(defvar quail-misc-package-ext-info
- '(("chinese-b5-tsangchi" "$(06A(BB"
+ '(("chinese-b5-tsangchi" "倉B"
"cangjie-table.b5" big5 "tsang-b5.el"
tsang-b5-converter
"\
@@ -591,7 +587,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
;; # unmodified versions is granted without royalty provided
;; # this notice is preserved.")
- ("chinese-b5-quick" "$(0X|(BB"
+ ("chinese-b5-quick" "簡B"
"cangjie-table.b5" big5 "quick-b5.el"
quick-b5-converter
"\
@@ -601,7 +597,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
;; # unmodified versions is granted without royalty provided
;; # this notice is preserved.")
- ("chinese-cns-tsangchi" "$(GT?(BC"
+ ("chinese-cns-tsangchi" "倉C"
"cangjie-table.cns" iso-2022-cn-ext "tsang-cns.el"
tsang-cns-converter
"\
@@ -611,7 +607,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
;; # unmodified versions is granted without royalty provided
;; # this notice is preserved.")
- ("chinese-cns-quick" "$(Gv|(BC"
+ ("chinese-cns-quick" "簡C"
"cangjie-table.cns" iso-2022-cn-ext "quick-cns.el"
quick-cns-converter
"\
@@ -621,7 +617,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
;; # unmodified versions is granted without royalty provided
;; # this notice is preserved.")
- ("chinese-py" "$AF4(BG"
+ ("chinese-py" "拼G"
"pinyin.map" cn-gb-2312 "PY.el"
py-converter
"\
@@ -649,7 +645,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
;; You should have received a copy of the GNU General Public License along with
;; CCE. If not, see <https://www.gnu.org/licenses/>.")
- ("chinese-ziranma" "$AWTH;(B"
+ ("chinese-ziranma" "自然"
"ziranma.cin" cn-gb-2312 "ZIRANMA.el"
ziranma-converter
"\
@@ -677,7 +673,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
;; You should have received a copy of the GNU General Public License along with
;; CCE. If not, see <https://www.gnu.org/licenses/>.")
- ("chinese-ctlau" "$AAuTA(B"
+ ("chinese-ctlau" "刘粤"
"CTLau.html" cn-gb-2312 "CTLau.el"
ctlau-gb-converter
"\
@@ -702,7 +698,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
;; # You should have received a copy of the GNU General Public License
;; # along with this program. If not, see <https://www.gnu.org/licenses/>.")
- ("chinese-ctlaub" "$(0N,Gn(B"
+ ("chinese-ctlaub" "劉粵"
"CTLau-b5.html" big5 "CTLau-b5.el"
ctlau-b5-converter
"\
@@ -732,38 +728,38 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
;; dictionary in the buffer DICBUF. The input method name of the
;; Quail package is NAME, and the title string is TITLE.
-;; TSANG-P is non-nil, generate $(06AQo(B input method. Otherwise
-;; generate $(0X|/y(B (simple version of $(06AQo(B). If BIG5-P is non-nil, the
+;; TSANG-P is non-nil, generate 倉頡 input method. Otherwise
+;; generate 簡易 (simple version of 倉頡). If BIG5-P is non-nil, the
;; input method is for inputting Big5 characters. Otherwise the input
;; method is for inputting CNS characters.
-(defun tsang-quick-converter (dicbuf name title tsang-p big5-p)
- (let ((fulltitle (if tsang-p (if big5-p "$(06AQo(B" "$(GT?on(B")
- (if big5-p "$(0X|/y(B" "$(Gv|Mx(B")))
+(defun tsang-quick-converter (dicbuf tsang-p big5-p)
+ (let ((fulltitle (if tsang-p (if big5-p "倉頡" "倉頡")
+ (if big5-p "簡易" "簡易")))
dic)
(goto-char (point-max))
(if big5-p
- (insert (format "\"$(0&d'GTT&,!J(B%s$(0!K(BBIG5
+ (insert (format "\"中文輸入【%s】BIG5
- $(0KHM$(B%s$(0TT&,WoOu(B
+ 漢語%s輸入鍵盤
- [Q $(0'D(B] [W $(0(q(B] [E $(0'V(B] [R $(0&H(B] [T $(0'>(B] [Y $(0&4(B] [U $(0&U(B] [I $(0'B(B] [O $(0&*(B] [P $(0'A(B]
+ [Q 手] [W 田] [E 水] [R 口] [T 廿] [Y 卜] [U 山] [I 戈] [O 人] [P 心]
- [A $(0'K(B] [S $(0&T(B] [D $(0'N(B] [F $(0'W(B] [G $(0&I(B] [H $(0*M(B] [J $(0&3(B] [L $(0&d(B]
+ [A 日] [S 尸] [D 木] [F 火] [G 土] [H 竹] [J 十] [L 中]
- [Z ] [X $(0[E(B] [C $(01[(B] [V $(0&M(B] [B $(0'M(B] [N $(0&_(B] [M $(0&"(B]
+ [Z ] [X 難] [C 金] [V 女] [B 月] [N 弓] [M 一]
\\\\<quail-translation-docstring>\"\n"
fulltitle fulltitle))
- (insert (format "\"$(GDcEFrSD+!J(B%s$(G!K(BCNS
+ (insert (format "\"中文輸入【%s】CNS
- $(GiGk#(B%s$(GrSD+uomu(B
+ 漢語%s輸入鍵盤
- [Q $(GEC(B] [W $(GFp(B] [E $(GEU(B] [R $(GDG(B] [T $(GE=(B] [Y $(GD3(B] [U $(GDT(B] [I $(GEA(B] [O $(GD)(B] [P $(GE@(B]
+ [Q 手] [W 田] [E 水] [R 口] [T 廿] [Y 卜] [U 山] [I 戈] [O 人] [P 心]
- [A $(GEJ(B] [S $(GDS(B] [D $(GEM(B] [F $(GEV(B] [G $(GDH(B] [H $(GHL(B] [J $(GD2(B] [L $(GDc(B]
+ [A 日] [S 尸] [D 木] [F 火] [G 土] [H 竹] [J 十] [L 中]
- [Z ] [X $(GyE(B] [C $(GOZ(B] [V $(GDL(B] [B $(GEL(B] [N $(GD^(B] [M $(GD!(B]
+ [Z ] [X 難] [C 金] [V 女] [B 月] [N 弓] [M 一]
\\\\<quail-translation-docstring>\"\n"
fulltitle fulltitle)))
@@ -782,7 +778,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
(while (not (eobp))
(forward-char 5)
(let ((trans (char-to-string (following-char)))
- key slot)
+ key)
(re-search-forward "\\([A-Z]+\\)\r*$" nil t)
(setq key (downcase
(if (or tsang-p
@@ -799,63 +795,63 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
(setq dic (sort dic (function (lambda (x y) (string< (car x ) (car y))))))
(dolist (elt dic)
(insert (format "(%S\t%S)\n" (car elt) (cdr elt))))
- (let ((punctuation '((";" "$(0!'!2!"!#!.!/(B" "$(G!'!2!"!#!.!/(B")
- (":" "$(0!(!+!3!%!$!&!0!1(B" "$(G!(!+!3!%!$!&!0!1(B")
- ("'" "$(0!e!d(B" "$(G!e!d(B")
- ("\"" "$(0!g!f!h!i!q(B" "$(G!g!f!h!i!q(B")
- ("\\" "$(0"`"b#M(B" "$(G"`"b#M(B")
- ("|" "$(0!6!8!:"^(B" "$(G!6!8!:"^(B")
- ("/" "$(0"_"a#L(B" "$(G"_"a#L(B")
- ("?" "$(0!)!4(B" "$(G!)!4(B")
- ("<" "$(0!R"6"A!T"H(B" "$(G!R"6"A!T"H(B")
- (">" "$(0!S"7"B!U(B" "$(G!S"7"B!U(B")
- ("[" "$(0!F!J!b!H!L!V!Z!X!\(B" "$(G!F!J!b!H!L!V!Z!X!\(B")
- ("]" "$(0!G!K!c!I!M!W![!Y!](B" "$(G!G!K!c!I!M!W![!Y!](B")
- ("{" "$(0!B!`!D(B " "$(G!B!`!D(B ")
- ("}" "$(0!C!a!E(B" "$(G!C!a!E(B")
- ("`" "$(0!j!k(B" "$(G!j!k(B")
- ("~" "$(0"D"+",!<!=(B" "$(G"D"+",!<!=(B")
- ("!" "$(0!*!5(B" "$(G!*!5(B")
- ("@" "$(0"i"n(B" "$(G"i"n(B")
- ("#" "$(0!l"-(B" "$(G!l"-(B")
- ("$" "$(0"c"l(B" "$(G"c"l(B")
- ("%" "$(0"h"m(B" "$(G"h"m(B")
- ("&" "$(0!m".(B" "$(G!m".(B")
- ("*" "$(0!n"/!o!w!x(B" "$(G!n"/!o!w!x(B")
- ("(" "$(0!>!^!@(B" "$(G!>!^!@(B")
- (")" "$(0!?!_!A(B" "$(G!?!_!A(B")
- ("-" "$(0!7!9"#"$"1"@(B" "$(G!7!9"#"$"1"@(B")
- ("_" "$(0"%"&(B" "$(G"%"&(B")
- ("=" "$(0"8"C(B" "$(G"8"C(B")
- ("+" "$(0"0"?(B" "$(G"0"?(B"))))
+ (let ((punctuation '((";" ";﹔,、﹐﹑" ";﹔,、﹐﹑")
+ (":" ":︰﹕.。‧﹒·" ":︰﹕.。・﹒·")
+ ("'" "’‘" "’‘")
+ ("\"" "”“〝〞〃" "”“〝〞〃")
+ ("\\" "\﹨╲" "\﹨╲")
+ ("|" "|︱︳∣" "︱︲|")
+ ("/" "/∕╱" "/∕╱")
+ ("?" "?﹖" "?﹖")
+ ("<" "〈<﹤︿∠" "〈<﹤︿∠")
+ (">" "〉>﹥﹀" "〉>﹦﹀")
+ ("[" "〔【﹝︹︻「『﹁﹃" "〔【﹝︹︻「『﹁﹃")
+ ("]" "〕】﹞︺︼」』﹂﹄" "〕】﹞︺︼」』﹂﹄")
+ ("{" "{﹛︷ " "{﹛︷ ")
+ ("}" "}﹜︸" "}﹜︸")
+ ("`" "‵′" "′‵")
+ ("~" "~﹋﹌︴﹏" "∼﹋﹌")
+ ("!" "!﹗" "!﹗")
+ ("@" "@﹫" "@﹫")
+ ("#" "#﹟" "#﹟")
+ ("$" "$﹩" "$﹩")
+ ("%" "%﹪" "%﹪")
+ ("&" "&﹠" "&﹠")
+ ("*" "*﹡※☆★" "*﹡※☆★")
+ ("(" "(﹙︵" "(﹙︵")
+ (")" ")﹚︶" ")﹚︶")
+ ("-" "–—¯ ̄-﹣" "—–‾-﹣")
+ ("_" "_ˍ" "_")
+ ("=" "=﹦" "=﹥")
+ ("+" "+﹢" "+﹢"))))
(dolist (elt punctuation)
(insert (format "(%S %S)\n" (concat "z" (car elt))
(if big5-p (nth 1 elt) (nth 2 elt))))))
(insert ")\n")))
-(defun tsang-b5-converter (dicbuf name title)
- (tsang-quick-converter dicbuf name title t t))
+(defun tsang-b5-converter (dicbuf)
+ (tsang-quick-converter dicbuf t t))
-(defun quick-b5-converter (dicbuf name title)
- (tsang-quick-converter dicbuf name title nil t))
+(defun quick-b5-converter (dicbuf)
+ (tsang-quick-converter dicbuf nil t))
-(defun tsang-cns-converter (dicbuf name title)
- (tsang-quick-converter dicbuf name title t nil))
+(defun tsang-cns-converter (dicbuf)
+ (tsang-quick-converter dicbuf t nil))
-(defun quick-cns-converter (dicbuf name title)
- (tsang-quick-converter dicbuf name title nil nil))
+(defun quick-cns-converter (dicbuf)
+ (tsang-quick-converter dicbuf nil nil))
;; Generate a code of a Quail package in the current buffer from
;; Pinyin dictionary in the buffer DICBUF. The input method name of
;; the Quail package is NAME, and the title string is TITLE.
-(defun py-converter (dicbuf name title)
+(defun py-converter (dicbuf)
(goto-char (point-max))
- (insert (format "%S\n" "$A::WVJdHk!KF4Rt!K(B
+ (insert (format "%S\n" "汉字输入∷拼音∷
- $AF4Rt7=08(B
+ 拼音方案
- $AP!P4S"NDWVD84z1m!8F4Rt!97{:E#,(B \"u(yu) $ATrSC(B u: $A1mJ>!C(B
+ 小写英文字母代表「拼音」符号, \"u(yu) 则用 u: 表示∶
Pinyin base input method for Chinese charset GB2312 (`chinese-gb2312').
@@ -869,14 +865,14 @@ character. The sequence is made by the combination of the initials
iang ing iong u ua uo uai ui uan un uan ueng yu yue yuan yun
(Note: In the correct Pinyin writing, the sequence \"yu\" in the last
- four finals should be written by the character u-umlaut `$A(9(B'.)
+ four finals should be written by the character u-umlaut `ü'.)
With this input method, you enter a Chinese character by first
entering its pinyin spelling.
\\<quail-translation-docstring>
-For instance, to input $ADc(B, you type \"n i C-n 3\". The first \"n i\"
+For instance, to input 你, you type \"n i C-n 3\". The first \"n i\"
is a Pinyin, \"C-n\" selects the next group of candidates (each group
contains at most 10 characters), \"3\" select the third character in
that group.
@@ -924,14 +920,14 @@ method `chinese-tonepy' with which you must specify tones by digits
;; Ziranma dictionary in the buffer DICBUF. The input method name of
;; the Quail package is NAME, and the title string is TITLE.
-(defun ziranma-converter (dicbuf name title)
+(defun ziranma-converter (dicbuf)
(let (dic)
(with-current-buffer dicbuf
(goto-char (point-min))
(search-forward "\n%keyname end")
(forward-line 1)
(let ((table (make-hash-table :test 'equal))
- elt pos key trans val)
+ pos key trans val)
(while (not (eobp))
(setq pos (point))
(skip-chars-forward "^ \t")
@@ -959,22 +955,22 @@ method `chinese-tonepy' with which you must specify tones by digits
table)))
(setq dic (sort dic (function (lambda (x y) (string< (car x) (car y))))))
(goto-char (point-max))
- (insert (format "%S\n" "$A::WVJdHk!K!>WTH;!?!K(B
-
- $A<|EL6TUU1m(B:
- $A)3)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)7(B
- $A)'#Q(B $A)'#W(B $A)'#E(B $A)'#R(B $A)'#T(B $A)'#Y(B $A)'#U(Bsh$A)'#I(Bch$A)'#O(B $A)'#P(B $A)'(B
- $A)'(B iu$A)'(B ua$A)'(B e$A)'(B uan$A)'(B ue$A)'(B uai$A)'(B u$A)'(B i$A)'(B o$A)'(B un$A)'(B
- $A)'(B $A)'(B ia$A)'(B $A)'(B van$A)'(B ve$A)'(B ing$A)'(B $A)'(B $A)'(B uo$A)'(B vn$A)'(B
- $A);)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)?(B
- $A)'#A(B $A)'#S(B $A)'#D(B $A)'#F(B $A)'#G(B $A)'#H(B $A)'#J(B $A)'#K(B $A)'#L(B $A)'(B
- $A)'(B a$A)'(Biong$A)'(Buang$A)'(B en$A)'(B eng$A)'(B ang$A)'(B an$A)'(B ao$A)'(B ai$A)'(B
- $A)'(B $A)'(B ong$A)'(Biang$A)'(B $A)'(B ng$A)'(B $A)'(B $A)'(B $A)'(B $A)'(B
- $A);)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)%)7(B
- $A)'#Z(B $A)'#X(B $A)'#C(B $A)'#V(Bzh$A)'#B(B $A)'#N(B $A)'#M(B $A)'#,(B $A)'#.(B $A)'(B $A#/(B $A)'(B
- $A)'(B ei$A)'(B ie$A)'(B iao$A)'(B ui$A)'(B ou$A)'(B in$A)'(B ian$A)'G0R3)':sR3)'7{:E)'(B
- $A)'(B $A)'(B $A)'(B $A)'(B v$A)'(B $A)'(B $A)'(B $A)'(B $A)'(B $A)'(B $A)'(B
- $A);)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)?(B
+ (insert (format "%S\n" "汉字输入∷【自然】∷
+
+ 键盘对照表:
+ ┏━━┳━━┳━━┳━━┳━━┳━━┳━━┳━━┳━━┳━━┓
+ ┃Q ┃W ┃E ┃R ┃T ┃Y ┃Ush┃Ich┃O ┃P ┃
+ ┃ iu┃ ua┃ e┃ uan┃ ue┃ uai┃ u┃ i┃ o┃ un┃
+ ┃ ┃ ia┃ ┃ van┃ ve┃ ing┃ ┃ ┃ uo┃ vn┃
+ ┗┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┛
+ ┃A ┃S ┃D ┃F ┃G ┃H ┃J ┃K ┃L ┃
+ ┃ a┃iong┃uang┃ en┃ eng┃ ang┃ an┃ ao┃ ai┃
+ ┃ ┃ ong┃iang┃ ┃ ng┃ ┃ ┃ ┃ ┃
+ ┗┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━━┓
+ ┃Z ┃X ┃C ┃Vzh┃B ┃N ┃M ┃, ┃. ┃ / ┃
+ ┃ ei┃ ie┃ iao┃ ui┃ ou┃ in┃ ian┃前页┃后页┃符号┃
+ ┃ ┃ ┃ ┃ v┃ ┃ ┃ ┃ ┃ ┃ ┃
+ ┗━━┻━━┻━━┻━━┻━━┻━━┻━━┻━━┻━━┻━━┛
Pinyin base input method for Chinese GB2312 characters (`chinese-gb2312').
@@ -986,34 +982,34 @@ method `chinese-py'.
Unlike the standard spelling of Pinyin, in this input method all
initials and finals are assigned to single keys (see the above table).
For instance, the initial \"ch\" is assigned to the key `i', the final
-\"iu\" is assigned to the key `q', and tones 1, 2, 3, 4, and $AGaIy(B are
+\"iu\" is assigned to the key `q', and tones 1, 2, 3, 4, and 轻声 are
assigned to the keys `q', `w', `e', `r', `t' respectively.
\\<quail-translation-docstring>
To input one-letter words, you type 4 keys, the first two for the
Pinyin of the letter, next one for tone, and the last one is always a
-quote ('). For instance, \"vsq'\" input $AVP(B. Exceptions are these
+quote ('). For instance, \"vsq'\" input 中. Exceptions are these
letters. You can input them just by typing a single key.
- Character: $A04(B $A2;(B $A4N(B $A5D(B $A6~(B $A7"(B $A8v(B $A:M(B $A3v(B $A<0(B $A?I(B $AAK(B $AC;(B
+ Character: 按 不 次 的 二 发 个 和 出 及 可 了 没
Key: a b c d e f g h i j k l m
- Character: $ADc(B $AE7(B $AF,(B $AF_(B $AHK(B $AH}(B $AK{(B $AJG(B $AWE(B $ANR(B $AP!(B $AR;(B $ATZ(B
+ Character: 你 欧 片 七 人 三 他 是 着 我 小 一 在
Key: n o p q r s t u v w x y z
To input two-letter words, you have two ways. One way is to type 4
keys, two for the first Pinyin, two for the second Pinyin. For
-instance, \"vsgo\" inputs $AVP9z(B. Another way is to type 3 keys: 2
+instance, \"vsgo\" inputs 中国. Another way is to type 3 keys: 2
initials of two letters, and quote ('). For instance, \"vg'\" also
-inputs $AVP9z(B.
+inputs 中国.
To input three-letter words, you type 4 keys: initials of three
-letters, and the last is quote ('). For instance, \"bjy'2\" inputs $A11(B
-$A>)Q<(B (the last `2' is to select one of the candidates).
+letters, and the last is quote ('). For instance, \"bjy'2\" inputs 北
+京鸭 (the last `2' is to select one of the candidates).
To input words of more than three letters, you type 4 keys, initials
of the first three letters and the last letter. For instance,
-\"bjdt\" inputs $A11>)5gJSL((B.
+\"bjdt\" inputs 北京电视台.
To input symbols and punctuation, type `/' followed by one of `a' to
`z', then select one of the candidates."))
@@ -1033,7 +1029,7 @@ To input symbols and punctuation, type `/' followed by one of `a' to
;; method name of the Quail package is NAME, and the title string is
;; TITLE. DESCRIPTION is the string shown by describe-input-method.
-(defun ctlau-converter (dicbuf name title description)
+(defun ctlau-converter (dicbuf description)
(goto-char (point-max))
(insert (format "%S\n" description))
(insert " '((\"\C-?\" . quail-delete-last-char)
@@ -1043,7 +1039,7 @@ To input symbols and punctuation, type `/' followed by one of `a' to
(\"<\" . quail-prev-translation))
nil nil nil nil)\n\n")
(insert "(quail-define-rules\n")
- (let (dicbuf-start dicbuf-end key-start key (pos (point)))
+ (let (dicbuf-start dicbuf-end key-start (pos (point)))
;; Find the dictionary, which starts below a horizontal rule and
;; ends at the second to last line in the HTML file.
(with-current-buffer dicbuf
@@ -1060,7 +1056,7 @@ To input symbols and punctuation, type `/' followed by one of `a' to
;; which the file is converted have no Big5 equivalent. Go
;; through and delete them.
(goto-char pos)
- (while (search-forward "$(0!{(B" nil t)
+ (while (search-forward "□" nil t)
(delete-char -1))
;; Uppercase keys in dictionary need to be downcased. Backslashes
;; at the beginning of keys need to be turned into double
@@ -1082,33 +1078,33 @@ To input symbols and punctuation, type `/' followed by one of `a' to
(forward-line 1)))
(insert ")\n"))
-(defun ctlau-gb-converter (dicbuf name title)
- (ctlau-converter dicbuf name title
-"$A::WVJdHk!KAuN}OiJ=TARt!K(B
+(defun ctlau-gb-converter (dicbuf)
+ (ctlau-converter dicbuf
+"汉字输入∷刘锡祥式粤音∷
- $AAuN}OiJ=TASoW"Rt7=08(B
+ 刘锡祥式粤语注音方案
Sidney Lau's Cantonese transcription scheme as described in his book
\"Elementary Cantonese\", The Government Printer, Hong Kong, 1972.
- This file was prepared by Fung Fung Lee ($A@n7c7e(B).
+ This file was prepared by Fung Fung Lee (李枫峰).
Originally converted from CTCPS3.tit
Last modified: June 2, 1993.
Some infrequent GB characters are accessed by typing \\, followed by
- the Cantonese romanization of the respective radical ($A2?JW(B)."))
+ the Cantonese romanization of the respective radical (部首)."))
-(defun ctlau-b5-converter (dicbuf name title)
- (ctlau-converter dicbuf name title
-"$(0KH)tTT&,!(N,Tg>A*#Gn5x!((B
+(defun ctlau-b5-converter (dicbuf)
+ (ctlau-converter dicbuf
+"漢字輸入:劉錫祥式粵音:
- $(0N,Tg>A*#GnM$0D5x'J7{(B
+ 劉錫祥式粵語注音方案
Sidney Lau's Cantonese transcription scheme as described in his book
\"Elementary Cantonese\", The Government Printer, Hong Kong, 1972.
- This file was prepared by Fung Fung Lee ($(0,XFS76(B).
+ This file was prepared by Fung Fung Lee (李楓峰).
Originally converted from CTCPS3.tit
Last modified: June 2, 1993.
Some infrequent characters are accessed by typing \\, followed by
- the Cantonese romanization of the respective radical ($(0?f5}(B)."))
+ the Cantonese romanization of the respective radical (部首)."))
(declare-function dos-8+3-filename "dos-fns.el" (filename))
@@ -1122,8 +1118,7 @@ the generated Quail package is saved."
(let ((tail quail-misc-package-ext-info)
coding-system-for-write
slot
- name title dicfile coding quailfile converter copyright
- dicbuf)
+ name title dicfile coding quailfile converter copyright)
(while tail
(setq slot (car tail)
dicfile (nth 2 slot)
@@ -1148,8 +1143,7 @@ the generated Quail package is saved."
copyright (nth 6 slot))
(message "Converting %s to %s..." dicfile quailfile)
;; Explicitly set eol format to `unix'.
- (setq coding-system-for-write
- (coding-system-change-eol-conversion coding 'unix))
+ (setq coding-system-for-write 'utf-8-unix)
(with-temp-file (expand-file-name quailfile dirname)
(insert (format-message ";; Quail package `%s'\n" name))
(insert (format-message
@@ -1174,11 +1168,10 @@ the generated Quail package is saved."
(insert-file-contents filename)
(let ((dicbuf (current-buffer)))
(with-current-buffer dstbuf
- (funcall converter dicbuf name title)))))
+ (funcall converter dicbuf)))))
(insert ";; Local Variables:\n"
";; version-control: never\n"
";; no-update-autoloads: t\n"
- (format ";; coding: %s\n" coding)
";; End:\n\n"
";;; " quailfile " ends here\n"))
(message "Converting %s to %s...done" dicfile quailfile))
@@ -1210,6 +1203,38 @@ to store generated Quail packages."
(miscdic-convert filename dir))))
(kill-emacs 0))
+(defun pinyin-convert ()
+ "Convert text file pinyin.map into an elisp library.
+The library is named pinyin.el, and contains the constant
+`pinyin-character-map'."
+ (let ((src-file (car command-line-args-left))
+ (dst-file (cadr command-line-args-left))
+ (coding-system-for-write 'utf-8-unix))
+ (with-temp-file dst-file
+ (insert ";; This file is automatically generated from pinyin.map,\
+ by the\n;; function pinyin-convert.\n\n")
+ (insert "(defconst pinyin-character-map\n'(")
+ (let ((pos (point)))
+ (insert-file-contents src-file)
+ (goto-char pos)
+ (re-search-forward "^[a-z]")
+ (beginning-of-line)
+ (delete-region pos (point))
+ (while (not (eobp))
+ (insert "(\"")
+ (skip-chars-forward "a-z")
+ (insert "\" . \"")
+ (delete-char 1)
+ (end-of-line)
+ (while (= (preceding-char) ?\r)
+ (delete-char -1))
+ (insert "\")")
+ (forward-line 1)))
+ (insert ")\n\"An alist holding correspondences between pinyin syllables\
+ and\nChinese characters.\")\n\n")
+ (insert "(provide 'pinyin)\n"))
+ (kill-emacs 0)))
+
;; Prevent "Local Variables" above confusing Emacs.
diff --git a/lisp/international/ucs-normalize.el b/lisp/international/ucs-normalize.el
index 9d55470d948..6f1e770c09c 100644
--- a/lisp/international/ucs-normalize.el
+++ b/lisp/international/ucs-normalize.el
@@ -109,7 +109,9 @@
(defconst ucs-normalize-version "1.2")
-(eval-when-compile (require 'cl-lib))
+(eval-when-compile
+ (require 'cl-lib)
+ (require 'regexp-opt))
(declare-function nfd "ucs-normalize" (char))
diff --git a/lisp/isearch.el b/lisp/isearch.el
index 25d6ad591eb..6280afebdc5 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -54,6 +54,7 @@
;;; Code:
(eval-when-compile (require 'cl-lib))
+(declare-function tmm-menubar-keymap "tmm.el")
;; Some additional options and constants.
@@ -67,8 +68,18 @@
(defcustom search-exit-option t
- "Non-nil means random control characters terminate incremental search."
- :type 'boolean)
+ "Defines what control characters do in incremental search.
+If t, random control and meta characters terminate the search
+and are then executed normally.
+If `edit', edit the search string instead of exiting.
+If `append', the characters which you type that are not interpreted by
+the incremental search are simply appended to the search string.
+If nil, run the command without exiting Isearch."
+ :type '(choice (const :tag "Terminate incremental search" t)
+ (const :tag "Edit the search string" edit)
+ (const :tag "Append control characters to the search string" append)
+ (const :tag "Don't terminate incremental search" nil))
+ :version "27.1")
(defcustom search-slow-window-lines 1
"Number of lines in slow search display windows.
@@ -287,9 +298,9 @@ are `word-search-regexp' \(`\\[isearch-toggle-word]'), `isearch-symbol-regexp'
(defcustom isearch-lazy-highlight t
"Controls the lazy-highlighting during incremental search.
-When non-nil, all text in the buffer matching the current search
-string is highlighted lazily (see `lazy-highlight-initial-delay'
-and `lazy-highlight-interval').
+When non-nil, all text currently visible on the screen
+matching the current search string is highlighted lazily
+(see `lazy-highlight-initial-delay' and `lazy-highlight-interval').
When multiple windows display the current buffer, the
highlighting is displayed only on the selected window, unless
@@ -299,6 +310,16 @@ this variable is set to the symbol `all-windows'."
:group 'lazy-highlight
:group 'isearch)
+(defcustom isearch-lazy-count nil
+ "Show match numbers in the search prompt.
+When both this option and `isearch-lazy-highlight' are non-nil,
+show the current match number and the total number of matches
+in the buffer (or its restriction)."
+ :type 'boolean
+ :group 'lazy-count
+ :group 'isearch
+ :version "27.1")
+
;;; Lazy highlight customization.
(defgroup lazy-highlight nil
@@ -308,10 +329,6 @@ this variable is set to the symbol `all-windows'."
:group 'isearch
:group 'matching)
-(define-obsolete-variable-alias 'isearch-lazy-highlight-cleanup
- 'lazy-highlight-cleanup
- "22.1")
-
(defcustom lazy-highlight-cleanup t
"Controls whether to remove extra highlighting after a search.
If this is nil, extra highlighting can be \"manually\" removed with
@@ -319,28 +336,16 @@ If this is nil, extra highlighting can be \"manually\" removed with
:type 'boolean
:group 'lazy-highlight)
-(define-obsolete-variable-alias 'isearch-lazy-highlight-initial-delay
- 'lazy-highlight-initial-delay
- "22.1")
-
(defcustom lazy-highlight-initial-delay 0.25
"Seconds to wait before beginning to lazily highlight all matches."
:type 'number
:group 'lazy-highlight)
-(define-obsolete-variable-alias 'isearch-lazy-highlight-interval
- 'lazy-highlight-interval
- "22.1")
-
(defcustom lazy-highlight-interval 0 ; 0.0625
"Seconds between lazily highlighting successive matches."
:type 'number
:group 'lazy-highlight)
-(define-obsolete-variable-alias 'isearch-lazy-highlight-max-at-a-time
- 'lazy-highlight-max-at-a-time
- "22.1")
-
(defcustom lazy-highlight-max-at-a-time nil ; 20 (bug#25751)
"Maximum matches to highlight at a time (for `lazy-highlight').
Larger values may reduce Isearch's responsiveness to user input;
@@ -350,6 +355,27 @@ A value of nil means highlight all matches shown on the screen."
(integer :tag "Some"))
:group 'lazy-highlight)
+(defcustom lazy-highlight-buffer-max-at-a-time 20
+ "Maximum matches to highlight at a time (for `lazy-highlight-buffer').
+Larger values may reduce Isearch's responsiveness to user input;
+smaller values make matches highlight slowly.
+A value of nil means highlight all matches in the buffer."
+ :type '(choice (const :tag "All" nil)
+ (integer :tag "Some"))
+ :group 'lazy-highlight
+ :version "27.1")
+
+(defcustom lazy-highlight-buffer nil
+ "Controls the lazy-highlighting of the full buffer.
+When non-nil, all text in the buffer matching the current search
+string is highlighted lazily (see `lazy-highlight-initial-delay',
+`lazy-highlight-interval' and `lazy-highlight-buffer-max-at-a-time').
+This is useful when `lazy-highlight-cleanup' is customized to nil
+and doesn't remove full-buffer highlighting after a search."
+ :type 'boolean
+ :group 'lazy-highlight
+ :version "27.1")
+
(defface lazy-highlight
'((((class color) (min-colors 88) (background light))
(:background "paleturquoise"))
@@ -364,6 +390,29 @@ A value of nil means highlight all matches shown on the screen."
:group 'lazy-highlight
:group 'basic-faces)
+;;; Lazy count customization.
+
+(defgroup lazy-count nil
+ "Lazy counting feature for reporting the number of matches."
+ :prefix "lazy-count-"
+ :version "27.1"
+ :group 'isearch
+ :group 'matching)
+
+(defcustom lazy-count-prefix-format "%s/%s "
+ "Format of the current/total number of matches for the prompt prefix."
+ :type '(choice (const :tag "No prefix" nil)
+ (string :tag "Prefix format string" "%s/%s "))
+ :group 'lazy-count
+ :version "27.1")
+
+(defcustom lazy-count-suffix-format nil
+ "Format of the current/total number of matches for the prompt suffix."
+ :type '(choice (const :tag "No suffix" nil)
+ (string :tag "Suffix format string" " [%s of %s]"))
+ :group 'lazy-count
+ :version "27.1")
+
;; Define isearch help map.
@@ -434,6 +483,170 @@ This is like `describe-bindings', but displays only Isearch keys."
;; Define isearch-mode keymap.
+(defun isearch-tmm-menubar ()
+ "Run `tmm-menubar' while `isearch-mode' is enabled."
+ (interactive)
+ (require 'tmm)
+ (run-hooks 'menu-bar-update-hook)
+ (let ((command nil))
+ (let ((menu-bar (tmm-menubar-keymap)))
+ (with-isearch-suspended
+ (setq command (let ((isearch-mode t)) ; Show bindings from
+ ; `isearch-mode-map' in
+ ; tmm's prompt.
+ (tmm-prompt menu-bar nil nil t)))))
+ (call-interactively command)))
+
+(defvar isearch-menu-bar-commands
+ '(isearch-tmm-menubar menu-bar-open mouse-minor-mode-menu)
+ "List of commands that can open a menu during Isearch.")
+
+(defvar isearch-menu-bar-yank-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [isearch-yank-pop]
+ '(menu-item "Previous kill" isearch-yank-pop
+ :help "Replace previous yanked kill on search string"))
+ (define-key map [isearch-yank-kill]
+ '(menu-item "Current kill" isearch-yank-kill
+ :help "Append current kill to search string"))
+ (define-key map [isearch-yank-line]
+ '(menu-item "Rest of line" isearch-yank-line
+ :help "Yank the rest of the current line on search string"))
+ (define-key map [isearch-yank-symbol-or-char]
+ '(menu-item "Symbol/char"
+ isearch-yank-symbol-or-char
+ :help "Yank next symbol or char on search string"))
+ (define-key map [isearch-yank-word-or-char]
+ '(menu-item "Word/char"
+ isearch-yank-word-or-char
+ :help "Yank next word or char on search string"))
+ (define-key map [isearch-yank-char]
+ '(menu-item "Char" isearch-yank-char
+ :help "Yank char at point on search string"))
+ map))
+
+(defvar isearch-menu-bar-map
+ (let ((map (make-sparse-keymap "Isearch")))
+ (define-key map [isearch-complete]
+ '(menu-item "Complete current search string" isearch-complete
+ :help "Complete current search string over search history"))
+ (define-key map [isearch-complete-separator]
+ '(menu-item "--"))
+ (define-key map [isearch-query-replace-regexp]
+ '(menu-item "Replace search string as regexp" isearch-query-replace-regexp
+ :help "Replace matches for current search string as regexp"))
+ (define-key map [isearch-query-replace]
+ '(menu-item "Replace search string" isearch-query-replace
+ :help "Replace matches for current search string"))
+ (define-key map [isearch-occur]
+ '(menu-item "Show all matches for search string" isearch-occur
+ :help "Show all matches for current search string"))
+ (define-key map [isearch-highlight-regexp]
+ '(menu-item "Highlight all matches for search string"
+ isearch-highlight-regexp
+ :help "Highlight all matches for current search string"))
+ (define-key map [isearch-search-replace-separator]
+ '(menu-item "--"))
+ (define-key map [isearch-toggle-specified-input-method]
+ '(menu-item "Turn on specific input method"
+ isearch-toggle-specified-input-method
+ :help "Turn on specific input method for search"))
+ (define-key map [isearch-toggle-input-method]
+ '(menu-item "Toggle input method" isearch-toggle-input-method
+ :help "Toggle input method for search"))
+ (define-key map [isearch-input-method-separator]
+ '(menu-item "--"))
+ (define-key map [isearch-char-by-name]
+ '(menu-item "Search for char by name" isearch-char-by-name
+ :help "Search for character by name"))
+ (define-key map [isearch-quote-char]
+ '(menu-item "Search for literal char" isearch-quote-char
+ :help "Search for literal char"))
+ (define-key map [isearch-special-char-separator]
+ '(menu-item "--"))
+ (define-key map [isearch-toggle-word]
+ '(menu-item "Word matching" isearch-toggle-word
+ :help "Word matching"
+ :button (:toggle
+ . (eq isearch-regexp-function 'word-search-regexp))))
+ (define-key map [isearch-toggle-symbol]
+ '(menu-item "Symbol matching" isearch-toggle-symbol
+ :help "Symbol matching"
+ :button (:toggle
+ . (eq isearch-regexp-function
+ 'isearch-symbol-regexp))))
+ (define-key map [isearch-toggle-regexp]
+ '(menu-item "Regexp matching" isearch-toggle-regexp
+ :help "Regexp matching"
+ :button (:toggle . isearch-regexp)))
+ (define-key map [isearch-toggle-invisible]
+ '(menu-item "Invisible text matching" isearch-toggle-invisible
+ :help "Invisible text matching"
+ :button (:toggle . isearch-invisible)))
+ (define-key map [isearch-toggle-char-fold]
+ '(menu-item "Character folding matching" isearch-toggle-char-fold
+ :help "Character folding matching"
+ :button (:toggle
+ . (eq isearch-regexp-function
+ 'char-fold-to-regexp))))
+ (define-key map [isearch-toggle-case-fold]
+ '(menu-item "Case folding matching" isearch-toggle-case-fold
+ :help "Case folding matching"
+ :button (:toggle . isearch-case-fold-search)))
+ (define-key map [isearch-toggle-lax-whitespace]
+ '(menu-item "Lax whitespace matching" isearch-toggle-lax-whitespace
+ :help "Lax whitespace matching"
+ :button (:toggle . isearch-lax-whitespace)))
+ (define-key map [isearch-toggle-separator]
+ '(menu-item "--"))
+ (define-key map [isearch-yank-menu]
+ `(menu-item "Yank on search string" ,isearch-menu-bar-yank-map))
+ (define-key map [isearch-edit-string]
+ '(menu-item "Edit current search string" isearch-edit-string
+ :help "Edit current search string"))
+ (define-key map [isearch-ring-retreat]
+ '(menu-item "Edit previous search string" isearch-ring-retreat
+ :help "Edit previous search string in Isearch history"))
+ (define-key map [isearch-ring-advance]
+ '(menu-item "Edit next search string" isearch-ring-advance
+ :help "Edit next search string in Isearch history"))
+ (define-key map [isearch-del-char]
+ '(menu-item "Delete last char from search string" isearch-del-char
+ :help "Delete last character from search string"))
+ (define-key map [isearch-delete-char]
+ '(menu-item "Undo last input item" isearch-delete-char
+ :help "Undo the effect of the last Isearch command"))
+ (define-key map [isearch-end-of-buffer]
+ '(menu-item "Go to last match" isearch-end-of-buffer
+ :help "Go to last occurrence of current search string"))
+ (define-key map [isearch-beginning-of-buffer]
+ '(menu-item "Go to first match" isearch-beginning-of-buffer
+ :help "Go to first occurrence of current search string"))
+ (define-key map [isearch-repeat-backward]
+ '(menu-item "Repeat search backward" isearch-repeat-backward
+ :help "Repeat current search backward"))
+ (define-key map [isearch-repeat-forward]
+ '(menu-item "Repeat search forward" isearch-repeat-forward
+ :help "Repeat current search forward"))
+ (define-key map [isearch-nonincremental]
+ '(menu-item "Nonincremental search" isearch-exit
+ :help "Start nonincremental search"
+ :visible (string-equal isearch-string "")))
+ (define-key map [isearch-exit]
+ '(menu-item "Finish search" isearch-exit
+ :help "Finish search leaving point where it is"
+ :visible (not (string-equal isearch-string ""))))
+ (define-key map [isearch-abort]
+ '(menu-item "Remove characters not found" isearch-abort
+ :help "Quit current search"
+ :visible (not isearch-success)))
+ (define-key map [isearch-cancel]
+ `(menu-item "Cancel search" isearch-cancel
+ :help "Cancel current search and return to starting point"
+ :filter ,(lambda (binding)
+ (if isearch-success 'isearch-abort binding))))
+ map))
+
(defvar isearch-mode-map
(let ((i 0)
(map (make-keymap)))
@@ -483,11 +696,15 @@ This is like `describe-bindings', but displays only Isearch keys."
(define-key map [?\S-\ ] 'isearch-printing-char)
(define-key map "\C-w" 'isearch-yank-word-or-char)
- (define-key map "\M-\C-w" 'isearch-del-char)
+ (define-key map "\M-\C-w" 'isearch-yank-symbol-or-char)
+ (define-key map "\M-\C-d" 'isearch-del-char)
(define-key map "\M-\C-y" 'isearch-yank-char)
(define-key map "\C-y" 'isearch-yank-kill)
(define-key map "\M-s\C-e" 'isearch-yank-line)
+ (define-key map "\M-s\M-<" 'isearch-beginning-of-buffer)
+ (define-key map "\M-s\M->" 'isearch-end-of-buffer)
+
(define-key map (char-to-string help-char) isearch-help-map)
(define-key map [help] isearch-help-map)
(define-key map [f1] isearch-help-map)
@@ -523,6 +740,8 @@ This is like `describe-bindings', but displays only Isearch keys."
(define-key map "\M-r" 'isearch-toggle-regexp)
(define-key map "\M-e" 'isearch-edit-string)
+ (put 'isearch-toggle-case-fold :advertised-binding "\M-sc")
+ (put 'isearch-toggle-regexp :advertised-binding "\M-sr")
(put 'isearch-edit-string :advertised-binding "\M-se")
(define-key map "\M-se" 'isearch-edit-string)
@@ -537,9 +756,59 @@ This is like `describe-bindings', but displays only Isearch keys."
;; characters to the search string. See iso-transl.el.
(define-key map "\C-x8\r" 'isearch-char-by-name)
+ (define-key map [menu-bar search-menu]
+ (list 'menu-item "Isearch" isearch-menu-bar-map))
+ (define-key map [remap tmm-menubar] 'isearch-tmm-menubar)
+
map)
"Keymap for `isearch-mode'.")
+(defvar isearch-tool-bar-old-map nil
+ "Variable holding the old local value of `tool-bar-map', if any.")
+
+(defun isearch-tool-bar-image (image-name)
+ "Return an image specification for IMAGE-NAME."
+ (eval (tool-bar--image-expression image-name)))
+
+(defvar isearch-tool-bar-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [isearch-describe-mode]
+ (list 'menu-item "Help" 'isearch-describe-mode
+ :help "Get help for Isearch"
+ :image '(isearch-tool-bar-image "help")))
+ (define-key map [isearch-occur]
+ (list 'menu-item "Show hits" 'isearch-occur
+ :help "Show each search hit"
+ :image '(isearch-tool-bar-image "index")))
+ (define-key map [isearch-query-replace]
+ (list 'menu-item "Replace" 'isearch-query-replace
+ :help "Replace search string"
+ :image '(isearch-tool-bar-image "search-replace")))
+ (define-key map [isearch-delete-char]
+ (list 'menu-item "Undo" 'isearch-delete-char
+ :help "Undo last input item"
+ :image '(isearch-tool-bar-image "undo")))
+ (define-key map [isearch-exit]
+ (list 'menu-item "Finish" 'isearch-exit
+ :help "Finish search leaving point where it is"
+ :image '(isearch-tool-bar-image "exit")
+ :visible '(not (string-equal isearch-string ""))))
+ (define-key map [isearch-cancel]
+ (list 'menu-item "Abort" 'isearch-cancel
+ :help "Abort search"
+ :image '(isearch-tool-bar-image "close")
+ :filter (lambda (binding)
+ (if isearch-success 'isearch-abort binding))))
+ (define-key map [isearch-repeat-forward]
+ (list 'menu-item "Repeat forward" 'isearch-repeat-forward
+ :help "Repeat search forward"
+ :image '(isearch-tool-bar-image "right-arrow")))
+ (define-key map [isearch-repeat-backward]
+ (list 'menu-item "Repeat backward" 'isearch-repeat-backward
+ :help "Repeat search backward"
+ :image '(isearch-tool-bar-image "left-arrow")))
+ map))
+
(defvar minibuffer-local-isearch-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map minibuffer-local-map)
@@ -558,6 +827,9 @@ This is like `describe-bindings', but displays only Isearch keys."
(defvar isearch-forward nil) ; Searching in the forward direction.
(defvar isearch-regexp nil) ; Searching for a regexp.
+;; We still support setting this to t for backwards compatibility.
+(define-obsolete-variable-alias 'isearch-word
+ 'isearch-regexp-function "25.1")
(defvar isearch-regexp-function nil
"Regexp-based search mode for words/symbols.
If the value is a function (e.g. `isearch-symbol-regexp'), it is
@@ -569,9 +841,6 @@ specifies the prefix string displayed in the search message.
This variable is set and changed during isearch. To change the
default behavior used for searches, see `search-default-mode'
instead.")
-;; We still support setting this to t for backwards compatibility.
-(define-obsolete-variable-alias 'isearch-word
- 'isearch-regexp-function "25.1")
(defvar isearch-lax-whitespace t
"If non-nil, a space will match a sequence of whitespace chars.
@@ -592,7 +861,7 @@ variable by the command `isearch-toggle-lax-whitespace'.")
(defvar isearch-cmds nil
"Stack of search status elements.
Each element is an `isearch--state' struct where the slots are
- [STRING MESSAGE POINT SUCCESS FORWARD OTHER-END WORD
+ [STRING MESSAGE POINT SUCCESS FORWARD OTHER-END WORD/REGEXP-FUNCTION
ERROR WRAPPED BARRIER CASE-FOLD-SEARCH POP-FUN]")
(defvar isearch-string "") ; The current search string.
@@ -670,11 +939,19 @@ Each element is an `isearch--state' struct where the slots are
;; Minor-mode-alist changes - kind of redundant with the
;; echo area, but if isearching in multiple windows, it can be useful.
+;; Also, clicking the mode-line indicator pops up
+;; `isearch-menu-bar-map'.
(or (assq 'isearch-mode minor-mode-alist)
(nconc minor-mode-alist
(list '(isearch-mode isearch-mode))))
+;; We add an entry for `isearch-mode' to `minor-mode-map-alist' so
+;; that `isearch-menu-bar-map' can show on the menu bar.
+(or (assq 'isearch-mode minor-mode-map-alist)
+ (nconc minor-mode-map-alist
+ (list (cons 'isearch-mode isearch-mode-map))))
+
(defvar-local isearch-mode nil) ;; Name of the minor mode, if non-nil.
(define-key global-map "\C-s" 'isearch-forward)
@@ -700,6 +977,8 @@ Type \\[isearch-exit] to exit, leaving point at location found.
Type LFD (C-j) to match end of line.
Type \\[isearch-repeat-forward] to search again forward,\
\\[isearch-repeat-backward] to search again backward.
+Type \\[isearch-beginning-of-buffer] to go to the first match,\
+ \\[isearch-end-of-buffer] to go to the last match.
Type \\[isearch-yank-word-or-char] to yank next word or character in buffer
onto the end of the search string, and search for it.
Type \\[isearch-del-char] to delete character from end of search string.
@@ -829,21 +1108,26 @@ as a regexp. See the command `isearch-forward-regexp' for more information."
(interactive "P\np")
(isearch-mode nil (null not-regexp) nil (not no-recursive-edit)))
-(defun isearch-forward-symbol-at-point ()
+(defun isearch-forward-symbol-at-point (&optional arg)
"Do incremental search forward for a symbol found near point.
Like ordinary incremental search except that the symbol found at point
is added to the search string initially as a regexp surrounded
by symbol boundary constructs \\_< and \\_>.
-See the command `isearch-forward-symbol' for more information."
- (interactive)
+See the command `isearch-forward-symbol' for more information.
+With a prefix argument, search for ARGth symbol forward if ARG is
+positive, or search for ARGth symbol backward if ARG is negative."
+ (interactive "P")
(isearch-forward-symbol nil 1)
- (let ((bounds (find-tag-default-bounds)))
+ (let ((bounds (find-tag-default-bounds))
+ (count (and arg (prefix-numeric-value arg))))
(cond
(bounds
(when (< (car bounds) (point))
(goto-char (car bounds)))
(isearch-yank-string
- (buffer-substring-no-properties (car bounds) (cdr bounds))))
+ (buffer-substring-no-properties (car bounds) (cdr bounds)))
+ (when count
+ (isearch-repeat-forward count)))
(t
(setq isearch-error "No symbol at point")
(isearch-push-state)
@@ -915,11 +1199,18 @@ used to set the value of `isearch-regexp-function'."
isearch-input-method-local-p (local-variable-p 'input-method-function)
regexp-search-ring-yank-pointer nil
+ isearch-pre-scroll-point nil
+ isearch-pre-move-point nil
+
;; Save the original value of `minibuffer-message-timeout', and
;; set it to nil so that isearch's messages don't get timed out.
isearch-original-minibuffer-message-timeout minibuffer-message-timeout
minibuffer-message-timeout nil)
+ (if (local-variable-p 'tool-bar-map)
+ (setq isearch-tool-bar-old-map tool-bar-map))
+ (setq-local tool-bar-map isearch-tool-bar-map)
+
;; We must bypass input method while reading key. When a user type
;; printable character, appropriate input method is turned on in
;; minibuffer to read multibyte characters.
@@ -957,7 +1248,7 @@ used to set the value of `isearch-regexp-function'."
(add-hook 'pre-command-hook 'isearch-pre-command-hook)
(add-hook 'post-command-hook 'isearch-post-command-hook)
- (add-hook 'mouse-leave-buffer-hook 'isearch-done)
+ (add-hook 'mouse-leave-buffer-hook 'isearch-mouse-leave-buffer)
(add-hook 'kbd-macro-termination-hook 'isearch-done)
;; isearch-mode can be made modal (in the sense of not returning to
@@ -1045,17 +1336,16 @@ For a failing search, NOPUSH is t.
For going to the minibuffer to edit the search string,
NOPUSH is t and EDIT is t."
- (if isearch-resume-in-command-history
- (let ((command `(isearch-resume ,isearch-string ,isearch-regexp
- ,isearch-regexp-function ,isearch-forward
- ,isearch-message
- ',isearch-case-fold-search)))
- (unless (equal (car command-history) command)
- (setq command-history (cons command command-history)))))
+ (when isearch-resume-in-command-history
+ (add-to-history 'command-history
+ `(isearch-resume ,isearch-string ,isearch-regexp
+ ,isearch-regexp-function ,isearch-forward
+ ,isearch-message
+ ',isearch-case-fold-search)))
(remove-hook 'pre-command-hook 'isearch-pre-command-hook)
(remove-hook 'post-command-hook 'isearch-post-command-hook)
- (remove-hook 'mouse-leave-buffer-hook 'isearch-done)
+ (remove-hook 'mouse-leave-buffer-hook 'isearch-mouse-leave-buffer)
(remove-hook 'kbd-macro-termination-hook 'isearch-done)
(setq isearch-lazy-highlight-start nil)
(when (buffer-live-p isearch--current-buffer)
@@ -1070,6 +1360,7 @@ NOPUSH is t and EDIT is t."
(setq minibuffer-message-timeout isearch-original-minibuffer-message-timeout)
(isearch-dehighlight)
(lazy-highlight-cleanup lazy-highlight-cleanup)
+ (setq isearch-lazy-highlight-last-string nil)
(let ((found-start (window-group-start))
(found-point (point)))
(when isearch-window-configuration
@@ -1087,6 +1378,12 @@ NOPUSH is t and EDIT is t."
(setq input-method-function isearch-input-method-function)
(kill-local-variable 'input-method-function))
+ (if isearch-tool-bar-old-map
+ (progn
+ (setq-local tool-bar-map isearch-tool-bar-old-map)
+ (setq isearch-tool-bar-old-map nil))
+ (kill-local-variable 'tool-bar-map))
+
(force-mode-line-update)
;; If we ended in the middle of some intangible text,
@@ -1119,22 +1416,45 @@ NOPUSH is t and EDIT is t."
(and (not edit) isearch-recursive-edit (exit-recursive-edit)))
+(defvar isearch-mouse-commands '(mouse-minor-mode-menu)
+ "List of mouse commands that are allowed during Isearch.")
+
+(defun isearch-mouse-leave-buffer ()
+ "Exit Isearch unless the mouse command is allowed in Isearch.
+
+Mouse commands are allowed in Isearch if they have a non-nil
+`isearch-scroll' property or if they are listed in
+`isearch-mouse-commands'."
+ (unless (or (memq this-command isearch-mouse-commands)
+ (eq (get this-command 'isearch-scroll) t))
+ (isearch-done)))
+
(defun isearch-update-ring (string &optional regexp)
"Add STRING to the beginning of the search ring.
REGEXP if non-nil says use the regexp search ring."
- (add-to-history
- (if regexp 'regexp-search-ring 'search-ring)
- string
- (if regexp regexp-search-ring-max search-ring-max)))
-
-;; Switching buffers should first terminate isearch-mode.
-;; ;; For Emacs 19, the frame switch event is handled.
-;; (defun isearch-switch-frame-handler ()
-;; (interactive) ;; Is this necessary?
-;; ;; First terminate isearch-mode.
-;; (isearch-done)
-;; (isearch-clean-overlays)
-;; (handle-switch-frame (car (cdr last-command-event))))
+ (let ((history-delete-duplicates t))
+ (add-to-history
+ (if regexp 'regexp-search-ring 'search-ring)
+ (isearch-string-propertize string)
+ (if regexp regexp-search-ring-max search-ring-max)
+ t)))
+
+(defun isearch-string-propertize (string &optional properties)
+ "Add isearch properties to the isearch string."
+ (unless properties
+ (setq properties `(isearch-case-fold-search ,isearch-case-fold-search))
+ (unless isearch-regexp
+ (setq properties (append properties `(isearch-regexp-function ,isearch-regexp-function)))))
+ (apply 'propertize string properties))
+
+(defun isearch-update-from-string-properties (string)
+ "Update isearch properties from the isearch string"
+ (when (plist-member (text-properties-at 0 string) 'isearch-case-fold-search)
+ (setq isearch-case-fold-search
+ (get-text-property 0 'isearch-case-fold-search string)))
+ (when (plist-member (text-properties-at 0 string) 'isearch-regexp-function)
+ (setq isearch-regexp-function
+ (get-text-property 0 'isearch-regexp-function string))))
;; The search status structure and stack.
@@ -1228,13 +1548,16 @@ If MSG is non-nil, use variable `isearch-message', otherwise `isearch-string'."
(length succ-msg)
0))))
+(define-obsolete-variable-alias 'isearch-new-word
+ 'isearch-new-regexp-function "25.1")
+
(defvar isearch-new-regexp-function nil
"Holds the next `isearch-regexp-function' inside `with-isearch-suspended'.
If this is set inside code wrapped by the macro
`with-isearch-suspended', then the value set will be used as the
`isearch-regexp-function' once isearch resumes.")
-(define-obsolete-variable-alias 'isearch-new-word
- 'isearch-new-regexp-function "25.1")
+
+(defvar isearch-suspended nil)
(defmacro with-isearch-suspended (&rest body)
"Exit Isearch mode, run BODY, and reinvoke the pending search.
@@ -1302,6 +1625,8 @@ You can update the global isearch variables by setting new values to
isearch-original-minibuffer-message-timeout)
old-point old-other-end)
+ (setq isearch-suspended t)
+
;; Actually terminate isearching until editing is done.
;; This is so that the user can do anything without failure,
;; like switch buffers and start another isearch, and return.
@@ -1316,6 +1641,8 @@ You can update the global isearch variables by setting new values to
(unwind-protect
(progn ,@body)
+ (setq isearch-suspended nil)
+
;; Always resume isearching by restarting it.
(isearch-mode isearch-forward
isearch-regexp
@@ -1334,6 +1661,8 @@ You can update the global isearch variables by setting new values to
multi-isearch-file-list multi-isearch-file-list-new
multi-isearch-buffer-list multi-isearch-buffer-list-new)
+ (isearch-update-from-string-properties isearch-string)
+
;; Restore the minibuffer message before moving point.
(funcall (or isearch-message-function #'isearch-message) nil t)
@@ -1365,7 +1694,11 @@ You can update the global isearch variables by setting new values to
;; Reinvoke the pending search.
(isearch-search)
- (isearch-push-state) ; this pushes the correct state
+ ;; If no code has changed the search parameters, then pushing
+ ;; a new state of Isearch should not be necessary.
+ (unless (and isearch-cmds
+ (equal (car isearch-cmds) (isearch--get-state)))
+ (isearch-push-state)) ; this pushes the correct state
(isearch-update)
(if isearch-nonincremental
(progn
@@ -1377,6 +1710,7 @@ You can update the global isearch variables by setting new values to
(message "")))))
(quit ; handle abort-recursive-edit
+ (setq isearch-suspended nil)
(isearch-abort) ;; outside of let to restore outside global values
)))
@@ -1399,7 +1733,9 @@ The following additional command keys are active while editing.
(history-add-new-input nil)
;; Binding minibuffer-history-symbol to nil is a work-around
;; for some incompatibility with gmhist.
- (minibuffer-history-symbol))
+ (minibuffer-history-symbol)
+ ;; Search string might have meta information on text properties.
+ (minibuffer-allow-text-properties t))
(setq isearch-new-string
(read-from-minibuffer
(isearch-message-prefix nil isearch-nonincremental)
@@ -1468,8 +1804,8 @@ Use `isearch-exit' to quit without signaling."
(isearch-pop-state))
(isearch-update)))
-(defun isearch-repeat (direction)
- ;; Utility for isearch-repeat-forward and -backward.
+(defun isearch-repeat (direction &optional count)
+ ;; Utility for isearch-repeat-forward and isearch-repeat-backward.
(if (eq isearch-forward (eq direction 'forward))
;; C-s in forward or C-r in reverse.
(if (equal isearch-string "")
@@ -1500,32 +1836,105 @@ Use `isearch-exit' to quit without signaling."
(if (equal isearch-string "")
(setq isearch-success t)
- (if (and isearch-success
- (equal (point) isearch-other-end)
- (not isearch-just-started))
- ;; If repeating a search that found
- ;; an empty string, ensure we advance.
- (if (if isearch-forward (eobp) (bobp))
- ;; If there's nowhere to advance to, fail (and wrap next time).
- (progn
- (setq isearch-success nil)
- (ding))
- (forward-char (if isearch-forward 1 -1))
+ ;; For the case when count > 1, don't keep intermediate states
+ ;; added to isearch-cmds by isearch-push-state in this loop.
+ (let ((isearch-cmds isearch-cmds))
+ (while (<= 0 (setq count (1- (or count 1))))
+ (if (and isearch-success
+ (equal (point) isearch-other-end)
+ (not isearch-just-started))
+ ;; If repeating a search that found
+ ;; an empty string, ensure we advance.
+ (if (if isearch-forward (eobp) (bobp))
+ ;; If there's nowhere to advance to, fail (and wrap next time).
+ (progn
+ (setq isearch-success nil)
+ (ding))
+ (forward-char (if isearch-forward 1 -1))
+ (isearch-search))
(isearch-search))
- (isearch-search)))
+ (when (> count 0)
+ ;; Update isearch-cmds, so if isearch-search fails later,
+ ;; it can restore old successful state from isearch-cmds.
+ (isearch-push-state))
+ ;; Stop looping on failure.
+ (when (or (not isearch-success) isearch-error)
+ (setq count 0)))))
(isearch-push-state)
(isearch-update))
-(defun isearch-repeat-forward ()
- "Repeat incremental search forwards."
- (interactive)
- (isearch-repeat 'forward))
-
-(defun isearch-repeat-backward ()
- "Repeat incremental search backwards."
- (interactive)
- (isearch-repeat 'backward))
+(defun isearch-repeat-forward (&optional arg)
+ "Repeat incremental search forwards.
+With a numeric argument, repeat the search ARG times.
+A negative argument searches backwards.
+\\<isearch-mode-map>
+This command finds the next relative occurrence of the current
+search string. To find the absolute occurrence from the beginning
+of the buffer, type \\[isearch-beginning-of-buffer] with a numeric argument."
+ (interactive "P")
+ (if arg
+ (let ((count (prefix-numeric-value arg)))
+ (cond ((< count 0)
+ (isearch-repeat-backward (abs count))
+ ;; Reverse the direction back
+ (isearch-repeat 'forward))
+ (t
+ ;; Take into account one iteration to reverse direction
+ (when (not isearch-forward) (setq count (1+ count)))
+ (isearch-repeat 'forward count))))
+ (isearch-repeat 'forward)))
+
+(defun isearch-repeat-backward (&optional arg)
+ "Repeat incremental search backwards.
+With a numeric argument, repeat the search ARG times.
+A negative argument searches forwards.
+\\<isearch-mode-map>
+This command finds the next relative occurrence of the current
+search string. To find the absolute occurrence from the end
+of the buffer, type \\[isearch-end-of-buffer] with a numeric argument."
+ (interactive "P")
+ (if arg
+ (let ((count (prefix-numeric-value arg)))
+ (cond ((< count 0)
+ (isearch-repeat-forward (abs count))
+ ;; Reverse the direction back
+ (isearch-repeat 'backward))
+ (t
+ ;; Take into account one iteration to reverse direction
+ (when isearch-forward (setq count (1+ count)))
+ (isearch-repeat 'backward count))))
+ (isearch-repeat 'backward)))
+
+(defun isearch-beginning-of-buffer (&optional arg)
+ "Go to the first occurrence of the current search string.
+Move point to the beginning of the buffer and search forwards from the top.
+\\<isearch-mode-map>
+With a numeric argument, go to the ARGth absolute occurrence counting from
+the beginning of the buffer. To find the next relative occurrence forwards,
+type \\[isearch-repeat-forward] with a numeric argument."
+ (interactive "p")
+ (if (and arg (< arg 0))
+ (isearch-end-of-buffer (abs arg))
+ ;; For the case when the match is at bobp,
+ ;; don't forward char in isearch-repeat
+ (setq isearch-just-started t)
+ (goto-char (point-min))
+ (isearch-repeat 'forward arg)))
+
+(defun isearch-end-of-buffer (&optional arg)
+ "Go to the last occurrence of the current search string.
+Move point to the end of the buffer and search backwards from the bottom.
+\\<isearch-mode-map>
+With a numeric argument, go to the ARGth absolute occurrence counting from
+the end of the buffer. To find the next relative occurrence backwards,
+type \\[isearch-repeat-backward] with a numeric argument."
+ (interactive "p")
+ (if (and arg (< arg 0))
+ (isearch-beginning-of-buffer (abs arg))
+ (setq isearch-just-started t)
+ (goto-char (point-max))
+ (isearch-repeat 'backward arg)))
;;; Toggles for `isearch-regexp-function' and `search-default-mode'.
@@ -1568,7 +1977,6 @@ Turning on word search turns off regexp mode.")
Turning on symbol search turns off regexp mode.")
(isearch-define-mode-toggle char-fold "'" char-fold-to-regexp "\
Turning on character-folding turns off regexp mode.")
-(put 'char-fold-to-regexp 'isearch-message-prefix "char-fold ")
(isearch-define-mode-toggle regexp "r" nil nil
(setq isearch-regexp (not isearch-regexp))
@@ -1577,10 +1985,10 @@ Turning on character-folding turns off regexp mode.")
(defun isearch--momentary-message (string)
"Print STRING at the end of the isearch prompt for 1 second"
(let ((message-log-max nil))
- (message "%s%s [%s]"
+ (message "%s%s%s"
(isearch-message-prefix nil isearch-nonincremental)
isearch-message
- string))
+ (propertize (format " [%s]" string) 'face 'minibuffer-prompt)))
(sit-for 1))
(isearch-define-mode-toggle lax-whitespace " " nil
@@ -1767,8 +2175,6 @@ the beginning or the end of the string need not match a symbol boundary."
(if (string-match-p (format "%s\\'" not-word-symbol-re) string) not-word-symbol-re
(unless lax "\\_>")))))))
-(put 'isearch-symbol-regexp 'isearch-message-prefix "symbol ")
-
;; Search with lax whitespace
(defun search-forward-lax-whitespace (string &optional bound noerror count)
@@ -1827,7 +2233,9 @@ replacements from Isearch is `M-s w ... M-%'."
;; `exit-recursive-edit' in `isearch-done' that terminates
;; the execution of this command when it is non-nil.
;; We call `exit-recursive-edit' explicitly at the end below.
- (isearch-recursive-edit nil))
+ (isearch-recursive-edit nil)
+ (isearch-string-propertized
+ (isearch-string-propertize isearch-string)))
(isearch-done nil t)
(isearch-clean-overlays)
(if (and isearch-other-end
@@ -1840,20 +2248,20 @@ replacements from Isearch is `M-s w ... M-%'."
(< (mark) (point))))))
(goto-char isearch-other-end))
(set query-replace-from-history-variable
- (cons isearch-string
+ (cons isearch-string-propertized
(symbol-value query-replace-from-history-variable)))
(perform-replace
- isearch-string
+ isearch-string-propertized
(query-replace-read-to
- isearch-string
+ isearch-string-propertized
(concat "Query replace"
(isearch--describe-regexp-mode (or delimited isearch-regexp-function) t)
(if backward " backward" "")
- (if (and transient-mark-mode mark-active) " in region" ""))
+ (if (use-region-p) " in region" ""))
isearch-regexp)
t isearch-regexp (or delimited isearch-regexp-function) nil nil
- (if (and transient-mark-mode mark-active) (region-beginning))
- (if (and transient-mark-mode mark-active) (region-end))
+ (if (use-region-p) (region-beginning))
+ (if (use-region-p) (region-end))
backward))
(and isearch-recursive-edit (exit-recursive-edit)))
@@ -1916,7 +2324,8 @@ characters in that string."
'isearch-regexp-function-descr
(isearch--describe-regexp-mode isearch-regexp-function))
regexp)
- nlines)))
+ nlines
+ (if (use-region-p) (region-bounds)))))
(declare-function hi-lock-read-face-name "hi-lock" ())
@@ -2014,6 +2423,7 @@ If search string is empty, just beep."
(defun isearch-yank-kill ()
"Pull string from kill ring into search string."
(interactive)
+ (unless isearch-mode (isearch-mode t))
(isearch-yank-string (current-kill 0)))
(defun isearch-yank-pop ()
@@ -2087,22 +2497,26 @@ If optional ARG is non-nil, pull in the next ARG characters."
(interactive "p")
(isearch-yank-internal (lambda () (forward-char arg) (point))))
-(declare-function subword-forward "subword" (&optional arg))
-(defun isearch-yank-word-or-char ()
- "Pull next character, subword or word from buffer into search string.
-Subword is used when `subword-mode' is activated. "
- (interactive)
+(defun isearch--yank-char-or-syntax (syntax-list fn)
(isearch-yank-internal
(lambda ()
- (if (or (= (char-syntax (or (char-after) 0)) ?w)
- (= (char-syntax (or (char-after (1+ (point))) 0)) ?w))
- (if (or (and (boundp 'subword-mode) subword-mode)
- (and (boundp 'superword-mode) superword-mode))
- (subword-forward 1)
- (forward-word 1))
+ (if (or (memq (char-syntax (or (char-after) 0)) syntax-list)
+ (memq (char-syntax (or (char-after (1+ (point))) 0))
+ syntax-list))
+ (funcall fn 1)
(forward-char 1))
(point))))
+(defun isearch-yank-word-or-char ()
+ "Pull next character or word from buffer into search string."
+ (interactive)
+ (isearch--yank-char-or-syntax '(?w) 'forward-word))
+
+(defun isearch-yank-symbol-or-char ()
+ "Pull next character or symbol from buffer into search string."
+ (interactive)
+ (isearch--yank-char-or-syntax '(?w ?_) 'forward-symbol))
+
(defun isearch-yank-word (&optional arg)
"Pull next word from buffer into search string.
If optional ARG is non-nil, pull in the next ARG words."
@@ -2306,6 +2720,12 @@ to the barrier."
(put 'split-window-right 'isearch-scroll t)
(put 'split-window-below 'isearch-scroll t)
(put 'enlarge-window 'isearch-scroll t)
+(put 'enlarge-window-horizontally 'isearch-scroll t)
+(put 'shrink-window-horizontally 'isearch-scroll t)
+(put 'shrink-window 'isearch-scroll t)
+;; The next two commands don't exit Isearch in isearch-mouse-leave-buffer
+(put 'mouse-drag-mode-line 'isearch-scroll t)
+(put 'mouse-drag-vertical-line 'isearch-scroll t)
;; Aliases for split-window-*
(put 'split-window-vertically 'isearch-scroll t)
@@ -2320,9 +2740,13 @@ to the barrier."
(defcustom isearch-allow-scroll nil
"Whether scrolling is allowed during incremental search.
If non-nil, scrolling commands can be used in Isearch mode.
-However, the current match will never scroll offscreen.
-If nil, scrolling commands will first cancel Isearch mode."
- :type 'boolean
+However, you cannot scroll far enough that the current match is
+no longer visible (is off screen). But if the value is `unlimited'
+that limitation is removed and you can scroll any distance off screen.
+If nil, scrolling commands exit Isearch mode."
+ :type '(choice (const :tag "Scrolling exits Isearch" nil)
+ (const :tag "Scrolling with current match on screen" t)
+ (const :tag "Scrolling with current match off screen" unlimited))
:group 'isearch)
(defcustom isearch-allow-prefix t
@@ -2384,6 +2808,22 @@ the bottom."
(goto-char isearch-point))
(defvar isearch-pre-scroll-point nil)
+(defvar isearch-pre-move-point nil)
+
+(defcustom isearch-yank-on-move nil
+ "Motion keys yank text to the search string while you move the cursor.
+If `shift', extend the search string by motion commands while holding down
+the shift key. The search string is extended by yanking text that
+ends at the new position after moving point in the current buffer.
+If t, extend the search string without the shift key pressed.
+To enable motion commands, put the `isearch-move' property on their
+symbols to `enabled', or to disable an automatically detected
+shift-translated command, use the property value `disabled'."
+ :type '(choice (const :tag "Motion keys exit Isearch" nil)
+ (const :tag "Motion keys extend the search string" t)
+ (const :tag "Shifted motion keys extend the search string" shift))
+ :group 'isearch
+ :version "27.1")
(defun isearch-pre-command-hook ()
"Decide whether to exit Isearch mode before executing the command.
@@ -2391,8 +2831,9 @@ Don't exit Isearch if the key sequence that invoked this command
is bound in `isearch-mode-map', or if the invoked command is
a prefix argument command (when `isearch-allow-prefix' is non-nil),
or it is a scrolling command (when `isearch-allow-scroll' is non-nil).
-Otherwise, exit Isearch (when `search-exit-option' is non-nil)
-before the command is executed globally with terminated Isearch."
+Otherwise, exit Isearch (when `search-exit-option' is t)
+before the command is executed globally with terminated Isearch.
+See more for options in `search-exit-option'."
(let* ((key (this-single-command-keys))
(main-event (aref key 0)))
(cond
@@ -2400,7 +2841,12 @@ before the command is executed globally with terminated Isearch."
;; `set-transient-map' thingy like `universal-argument--mode'.
((not (eq overriding-terminal-local-map isearch--saved-overriding-local-map)))
;; Don't exit Isearch for isearch key bindings.
- ((commandp (lookup-key isearch-mode-map key nil)))
+ ((or (commandp (lookup-key isearch-mode-map key nil))
+ (commandp
+ (lookup-key
+ `(keymap (tool-bar menu-item nil ,isearch-tool-bar-map)) key))))
+ ;; Allow key bindings that open a menubar.
+ ((memq this-command isearch-menu-bar-commands))
;; Optionally edit the search string instead of exiting.
((eq search-exit-option 'edit)
(setq this-command 'isearch-edit-string))
@@ -2413,29 +2859,63 @@ before the command is executed globally with terminated Isearch."
(or (eq (get this-command 'isearch-scroll) t)
(eq (get this-command 'scroll-command) t))))
(when isearch-allow-scroll
- (setq isearch-pre-scroll-point (point))))
+ (unless (eq isearch-allow-scroll 'unlimited)
+ (setq isearch-pre-scroll-point (point)))))
;; A mouse click on the isearch message starts editing the search string.
((and (eq (car-safe main-event) 'down-mouse-1)
(window-minibuffer-p (posn-window (event-start main-event))))
;; Swallow the up-event.
(read-event)
(setq this-command 'isearch-edit-string))
+ ;; Don't terminate the search for motion commands.
+ ((and isearch-yank-on-move
+ (symbolp this-command)
+ (not (eq (get this-command 'isearch-move) 'disabled))
+ (or (eq (get this-command 'isearch-move) 'enabled)
+ (and (eq isearch-yank-on-move t)
+ (stringp (nth 1 (interactive-form this-command)))
+ (string-match-p "^\\^"
+ (nth 1 (interactive-form this-command))))
+ (and (eq isearch-yank-on-move 'shift)
+ this-command-keys-shift-translated)))
+ (setq this-command-keys-shift-translated nil)
+ (setq isearch-pre-move-point (point)))
+ ;; Append control characters to the search string
+ ((eq search-exit-option 'append)
+ (unless (memq nil (mapcar (lambda (k) (characterp k)) key))
+ (isearch-process-search-string key key))
+ (setq this-command 'ignore))
;; Other characters terminate the search and are then executed normally.
(search-exit-option
(isearch-done)
- (isearch-clean-overlays))
- ;; If search-exit-option is nil, run the command without exiting Isearch.
- (t
- (isearch-process-search-string key key)))))
+ (isearch-clean-overlays)))))
(defun isearch-post-command-hook ()
- (when isearch-pre-scroll-point
- (let ((ab-bel (isearch-string-out-of-window isearch-pre-scroll-point)))
- (if ab-bel
- (isearch-back-into-window (eq ab-bel 'above) isearch-pre-scroll-point)
- (goto-char isearch-pre-scroll-point)))
- (setq isearch-pre-scroll-point nil)
- (isearch-update)))
+ (when isearch-pre-scroll-point
+ (let ((ab-bel (isearch-string-out-of-window isearch-pre-scroll-point)))
+ (if ab-bel
+ (isearch-back-into-window (eq ab-bel 'above) isearch-pre-scroll-point)
+ (goto-char isearch-pre-scroll-point)))
+ (setq isearch-pre-scroll-point nil)
+ (isearch-update))
+ (when (eq isearch-allow-scroll 'unlimited)
+ (when isearch-lazy-highlight
+ (isearch-lazy-highlight-new-loop)))
+ (when isearch-pre-move-point
+ (when (not (eq isearch-pre-move-point (point)))
+ (let ((string (buffer-substring-no-properties
+ (or isearch-other-end isearch-opoint) (point))))
+ (if isearch-regexp (setq string (regexp-quote string)))
+ (setq isearch-string string)
+ (setq isearch-message (mapconcat 'isearch-text-char-description
+ string ""))
+ (setq isearch-yank-flag t)
+ (setq isearch-forward (<= (or isearch-other-end isearch-opoint) (point)))
+ (when isearch-forward
+ (goto-char isearch-pre-move-point))
+ (isearch-search-and-update)))
+ (setq isearch-pre-move-point nil))
+ (force-mode-line-update))
(defun isearch-quote-char (&optional count)
"Quote special characters for incremental search.
@@ -2520,7 +3000,8 @@ Search is updated accordingly."
length)))
(setq isearch-string (nth yank-pointer ring)
isearch-message (mapconcat 'isearch-text-char-description
- isearch-string "")))))
+ isearch-string ""))
+ (isearch-update-from-string-properties isearch-string))))
(defun isearch-ring-adjust (advance)
;; Helper for isearch-ring-advance and isearch-ring-retreat
@@ -2634,12 +3115,16 @@ the word mode."
(cond
;; 1. Do not use a description on the default search mode,
;; but only if the default search mode is non-nil.
- ((or (and search-default-mode
- (equal search-default-mode regexp-function))
- ;; Special case where `search-default-mode' is t
- ;; (defaults to regexp searches).
- (and (eq search-default-mode t)
- (eq search-default-mode isearch-regexp))) "")
+ ((and (or (and search-default-mode
+ (equal search-default-mode regexp-function))
+ ;; Special case where `search-default-mode' is t
+ ;; (defaults to regexp searches).
+ (and (eq search-default-mode t)
+ (eq search-default-mode isearch-regexp)))
+ ;; Also do not omit description in case of error
+ ;; in default non-literal search.
+ (or isearch-success (not (or regexp-function isearch-regexp))))
+ "")
;; 2. Use the `isearch-message-prefix' set for
;; `regexp-function' if available.
(regexp-function
@@ -2682,6 +3167,8 @@ the word mode."
(< (point) isearch-opoint)))
"over")
(if isearch-wrapped "wrapped ")
+ (if (and (not isearch-success) (not isearch-case-fold-search))
+ "case-sensitive ")
(let ((prefix ""))
(advice-function-mapc
(lambda (_ props)
@@ -2705,15 +3192,41 @@ the word mode."
(concat " [" current-input-method-title "]: "))
": ")
)))
- (propertize (concat (upcase (substring m 0 1)) (substring m 1))
+ (propertize (concat (isearch-lazy-count-format)
+ (upcase (substring m 0 1)) (substring m 1))
'face 'minibuffer-prompt)))
(defun isearch-message-suffix (&optional c-q-hack)
- (concat (if c-q-hack "^Q" "")
- (if isearch-error
- (concat " [" isearch-error "]")
- "")
- (or isearch-message-suffix-add "")))
+ (propertize (concat (if c-q-hack "^Q" "")
+ (isearch-lazy-count-format 'suffix)
+ (if isearch-error
+ (concat " [" isearch-error "]")
+ "")
+ (or isearch-message-suffix-add ""))
+ 'face 'minibuffer-prompt))
+
+(defun isearch-lazy-count-format (&optional suffix-p)
+ "Format the current match number and the total number of matches.
+When SUFFIX-P is non-nil, the returned string is indended for
+isearch-message-suffix prompt. Otherwise, for isearch-message-prefix."
+ (let ((format-string (if suffix-p
+ lazy-count-suffix-format
+ lazy-count-prefix-format)))
+ (if (and format-string
+ isearch-lazy-count
+ isearch-lazy-count-current
+ (not isearch-error)
+ (not isearch-suspended))
+ (format format-string
+ (if isearch-forward
+ isearch-lazy-count-current
+ (if (eq isearch-lazy-count-current 0)
+ 0
+ (- isearch-lazy-count-total
+ isearch-lazy-count-current
+ -1)))
+ (or isearch-lazy-count-total "?"))
+ "")))
;; Searching
@@ -2736,11 +3249,8 @@ Can be changed via `isearch-search-fun-function' for special needs."
(defun isearch--lax-regexp-function-p ()
"Non-nil if next regexp-function call should be lax."
- (not (or isearch-nonincremental
- (null (car isearch-cmds))
- (eq (length isearch-string)
- (length (isearch--state-string
- (car isearch-cmds)))))))
+ (or (memq this-command '(isearch-printing-char isearch-del-char))
+ isearch-yank-flag))
(defun isearch-search-fun-default ()
"Return default functions to use for the search."
@@ -2752,25 +3262,18 @@ Can be changed via `isearch-search-fun-function' for special needs."
(isearch-regexp isearch-regexp-lax-whitespace)
(t isearch-lax-whitespace))
search-whitespace-regexp)))
- (condition-case er
- (funcall
- (if isearch-forward #'re-search-forward #'re-search-backward)
- (cond (isearch-regexp-function
- (let ((lax (and (not bound) (isearch--lax-regexp-function-p))))
- (when lax
- (setq isearch-adjusted t))
- (if (functionp isearch-regexp-function)
- (funcall isearch-regexp-function string lax)
- (word-search-regexp string lax))))
- (isearch-regexp string)
- (t (regexp-quote string)))
- bound noerror count)
- (search-failed
- (signal (car er)
- (let ((prefix (get isearch-regexp-function 'isearch-message-prefix)))
- (if (and isearch-regexp-function (stringp prefix))
- (list (format "%s [using %ssearch]" string prefix))
- (cdr er)))))))))
+ (funcall
+ (if isearch-forward #'re-search-forward #'re-search-backward)
+ (cond (isearch-regexp-function
+ (let ((lax (and (not bound) (isearch--lax-regexp-function-p))))
+ (when lax
+ (setq isearch-adjusted t))
+ (if (functionp isearch-regexp-function)
+ (funcall isearch-regexp-function string lax)
+ (word-search-regexp string lax))))
+ (isearch-regexp string)
+ (t (regexp-quote string)))
+ bound noerror count))))
(defun isearch-search-string (string bound noerror)
"Search for the first occurrence of STRING or its translation.
@@ -2857,7 +3360,7 @@ Optional third argument, if t, means if fail just return nil (no error).
(setq isearch-error (car (cdr lossage)))
(cond
((string-match
- "\\`Premature \\|\\`Unmatched \\|\\`Invalid "
+ "\\`Premature \\|\\`Unmatched "
isearch-error)
(setq isearch-error "incomplete input"))
((and (not isearch-regexp)
@@ -2896,8 +3399,6 @@ Optional third argument, if t, means if fail just return nil (no error).
(funcall (overlay-get ov 'isearch-open-invisible-temporary) ov nil)
;; Store the values for the `invisible' property, and then set it to nil.
;; This way the text hidden by this overlay becomes visible.
-
- ;; In 19.34 this does not exist so I cannot test it.
(overlay-put ov 'isearch-invisible (overlay-get ov 'invisible))
(overlay-put ov 'invisible nil)))
@@ -3127,15 +3628,23 @@ since they have special meaning in a regexp."
(defvar isearch-lazy-highlight-window-group nil)
(defvar isearch-lazy-highlight-window-start nil)
(defvar isearch-lazy-highlight-window-end nil)
+(defvar isearch-lazy-highlight-window-start-changed nil)
+(defvar isearch-lazy-highlight-window-end-changed nil)
+(defvar isearch-lazy-highlight-point-min nil)
+(defvar isearch-lazy-highlight-point-max nil)
+(defvar isearch-lazy-highlight-buffer nil)
(defvar isearch-lazy-highlight-case-fold-search nil)
(defvar isearch-lazy-highlight-regexp nil)
(defvar isearch-lazy-highlight-lax-whitespace nil)
(defvar isearch-lazy-highlight-regexp-lax-whitespace nil)
-(defvar isearch-lazy-highlight-regexp-function nil)
(define-obsolete-variable-alias 'isearch-lazy-highlight-word
'isearch-lazy-highlight-regexp-function "25.1")
+(defvar isearch-lazy-highlight-regexp-function nil)
(defvar isearch-lazy-highlight-forward nil)
(defvar isearch-lazy-highlight-error nil)
+(defvar isearch-lazy-count-current nil)
+(defvar isearch-lazy-count-total nil)
+(defvar isearch-lazy-count-hash (make-hash-table))
(defun lazy-highlight-cleanup (&optional force procrastinate)
"Stop lazy highlighting and remove extra highlighting from current buffer.
@@ -3153,10 +3662,6 @@ This function is called when exiting an incremental search if
(cancel-timer isearch-lazy-highlight-timer)
(setq isearch-lazy-highlight-timer nil)))
-(define-obsolete-function-alias 'isearch-lazy-highlight-cleanup
- 'lazy-highlight-cleanup
- "22.1")
-
(defun isearch-lazy-highlight-new-loop (&optional beg end)
"Cleanup any previous `lazy-highlight' loop and begin a new one.
BEG and END specify the bounds within which highlighting should occur.
@@ -3179,17 +3684,46 @@ by other Emacs features."
isearch-lax-whitespace))
(not (eq isearch-lazy-highlight-regexp-lax-whitespace
isearch-regexp-lax-whitespace))
- (not (= (window-group-start)
- isearch-lazy-highlight-window-start))
- (not (= (window-group-end) ; Window may have been split/joined.
- isearch-lazy-highlight-window-end))
(not (eq isearch-forward
isearch-lazy-highlight-forward))
;; In case we are recovering from an error.
(not (equal isearch-error
- isearch-lazy-highlight-error))))
+ isearch-lazy-highlight-error))
+ (if lazy-highlight-buffer
+ (not (= (point-min)
+ isearch-lazy-highlight-point-min))
+ (setq isearch-lazy-highlight-window-start-changed
+ (not (= (window-group-start)
+ isearch-lazy-highlight-window-start))))
+ (if lazy-highlight-buffer
+ (not (= (point-max)
+ isearch-lazy-highlight-point-max))
+ (setq isearch-lazy-highlight-window-end-changed
+ (not (= (window-group-end) ; Window may have been split/joined.
+ isearch-lazy-highlight-window-end))))))
;; something important did indeed change
(lazy-highlight-cleanup t (not (equal isearch-string ""))) ;stop old timer
+ (when isearch-lazy-count
+ (when (or (equal isearch-string "")
+ ;; Check if this place was reached by a condition above
+ ;; other than changed window boundaries (that shouldn't
+ ;; reset the counter)
+ (and (not isearch-lazy-highlight-window-start-changed)
+ (not isearch-lazy-highlight-window-end-changed))
+ ;; Also check for changes in buffer boundaries in
+ ;; a possibly narrowed buffer in case lazy-highlight-buffer
+ ;; is nil, thus the same check was not performed above
+ (not (= (point-min)
+ isearch-lazy-highlight-point-min))
+ (not (= (point-max)
+ isearch-lazy-highlight-point-max)))
+ ;; Reset old counter before going to count new numbers
+ (clrhash isearch-lazy-count-hash)
+ (setq isearch-lazy-count-current nil
+ isearch-lazy-count-total nil)
+ (funcall (or isearch-message-function #'isearch-message))))
+ (setq isearch-lazy-highlight-window-start-changed nil)
+ (setq isearch-lazy-highlight-window-end-changed nil)
(setq isearch-lazy-highlight-error isearch-error)
;; It used to check for `(not isearch-error)' here, but actually
;; lazy-highlighting might find matches to highlight even when
@@ -3200,6 +3734,9 @@ by other Emacs features."
isearch-lazy-highlight-window-group (selected-window-group)
isearch-lazy-highlight-window-start (window-group-start)
isearch-lazy-highlight-window-end (window-group-end)
+ isearch-lazy-highlight-point-min (point-min)
+ isearch-lazy-highlight-point-max (point-max)
+ isearch-lazy-highlight-buffer lazy-highlight-buffer
;; Start lazy-highlighting at the beginning of the found
;; match (`isearch-other-end'). If no match, use point.
;; One of the next two variables (depending on search direction)
@@ -3217,12 +3754,31 @@ by other Emacs features."
isearch-lazy-highlight-regexp-lax-whitespace isearch-regexp-lax-whitespace
isearch-lazy-highlight-regexp-function isearch-regexp-function
isearch-lazy-highlight-forward isearch-forward)
+ ;; Extend start/end to match whole string at point (bug#19353)
+ (if isearch-lazy-highlight-forward
+ (setq isearch-lazy-highlight-start
+ (min (+ isearch-lazy-highlight-start
+ (1- (length isearch-lazy-highlight-last-string)))
+ (point-max)))
+ (setq isearch-lazy-highlight-end
+ (max (- isearch-lazy-highlight-end
+ (1- (length isearch-lazy-highlight-last-string)))
+ (point-min))))
(unless (equal isearch-string "")
(setq isearch-lazy-highlight-timer
(run-with-idle-timer lazy-highlight-initial-delay nil
- 'isearch-lazy-highlight-start)))))
-
-(defun isearch-lazy-highlight-search ()
+ 'isearch-lazy-highlight-start))))
+ ;; Update the current match number only in isearch-mode and
+ ;; unless isearch-mode is used specially with isearch-message-function
+ (when (and isearch-lazy-count isearch-mode (null isearch-message-function))
+ ;; Update isearch-lazy-count-current only when it was already set
+ ;; at the end of isearch-lazy-highlight-buffer-update
+ (when isearch-lazy-count-current
+ (setq isearch-lazy-count-current
+ (gethash (point) isearch-lazy-count-hash 0))
+ (isearch-message))))
+
+(defun isearch-lazy-highlight-search (string bound)
"Search ahead for the next or previous match, for lazy highlighting.
Attempt to do the search exactly the way the pending Isearch would."
(condition-case nil
@@ -3236,24 +3792,10 @@ Attempt to do the search exactly the way the pending Isearch would."
(isearch-forward isearch-lazy-highlight-forward)
(search-invisible nil) ; don't match invisible text
(retry t)
- (success nil)
- (bound (if isearch-lazy-highlight-forward
- (min (or isearch-lazy-highlight-end-limit (point-max))
- (if isearch-lazy-highlight-wrapped
- (+ isearch-lazy-highlight-start
- ;; Extend bound to match whole string at point
- (1- (length isearch-lazy-highlight-last-string)))
- (window-group-end)))
- (max (or isearch-lazy-highlight-start-limit (point-min))
- (if isearch-lazy-highlight-wrapped
- (- isearch-lazy-highlight-end
- ;; Extend bound to match whole string at point
- (1- (length isearch-lazy-highlight-last-string)))
- (window-group-start))))))
+ (success nil))
;; Use a loop like in `isearch-search'.
(while retry
- (setq success (isearch-search-string
- isearch-lazy-highlight-last-string bound t))
+ (setq success (isearch-search-string string bound t))
;; Clear RETRY unless the search predicate says
;; to skip this search hit.
(if (or (not success)
@@ -3265,6 +3807,17 @@ Attempt to do the search exactly the way the pending Isearch would."
success)
(error nil)))
+(defun isearch-lazy-highlight-match (mb me)
+ (let ((ov (make-overlay mb me)))
+ (push ov isearch-lazy-highlight-overlays)
+ ;; 1000 is higher than ediff's 100+,
+ ;; but lower than isearch main overlay's 1001
+ (overlay-put ov 'priority 1000)
+ (overlay-put ov 'face 'lazy-highlight)
+ (unless (or (eq isearch-lazy-highlight 'all-windows)
+ isearch-lazy-highlight-buffer)
+ (overlay-put ov 'window (selected-window)))))
+
(defun isearch-lazy-highlight-start ()
"Start a new lazy-highlight updating loop."
(lazy-highlight-cleanup t) ;remove old overlays
@@ -3274,19 +3827,32 @@ Attempt to do the search exactly the way the pending Isearch would."
"Update highlighting of other matches for current search."
(let ((max lazy-highlight-max-at-a-time)
(looping t)
- nomore)
+ nomore window-start window-end)
(with-local-quit
(save-selected-window
(if (and (window-live-p isearch-lazy-highlight-window)
(not (memq (selected-window) isearch-lazy-highlight-window-group)))
(select-window isearch-lazy-highlight-window))
+ (setq window-start (window-group-start))
+ (setq window-end (window-group-end))
(save-excursion
(save-match-data
(goto-char (if isearch-lazy-highlight-forward
isearch-lazy-highlight-end
isearch-lazy-highlight-start))
(while looping
- (let ((found (isearch-lazy-highlight-search)))
+ (let* ((bound (if isearch-lazy-highlight-forward
+ (min (or isearch-lazy-highlight-end-limit (point-max))
+ (if isearch-lazy-highlight-wrapped
+ isearch-lazy-highlight-start
+ window-end))
+ (max (or isearch-lazy-highlight-start-limit (point-min))
+ (if isearch-lazy-highlight-wrapped
+ isearch-lazy-highlight-end
+ window-start))))
+ (found (isearch-lazy-highlight-search
+ isearch-lazy-highlight-last-string
+ bound)))
(when max
(setq max (1- max))
(if (<= max 0)
@@ -3298,24 +3864,17 @@ Attempt to do the search exactly the way the pending Isearch would."
(if isearch-lazy-highlight-forward
(if (= mb (if isearch-lazy-highlight-wrapped
isearch-lazy-highlight-start
- (window-group-end)))
+ window-end))
(setq found nil)
(forward-char 1))
(if (= mb (if isearch-lazy-highlight-wrapped
isearch-lazy-highlight-end
- (window-group-start)))
+ window-start))
(setq found nil)
(forward-char -1)))
;; non-zero-length match
- (let ((ov (make-overlay mb me)))
- (push ov isearch-lazy-highlight-overlays)
- ;; 1000 is higher than ediff's 100+,
- ;; but lower than isearch main overlay's 1001
- (overlay-put ov 'priority 1000)
- (overlay-put ov 'face 'lazy-highlight)
- (unless (eq isearch-lazy-highlight 'all-windows)
- (overlay-put ov 'window (selected-window)))))
+ (isearch-lazy-highlight-match mb me))
;; Remember the current position of point for
;; the next call of `isearch-lazy-highlight-update'
;; when `lazy-highlight-max-at-a-time' is too small.
@@ -3331,17 +3890,100 @@ Attempt to do the search exactly the way the pending Isearch would."
(setq isearch-lazy-highlight-wrapped t)
(if isearch-lazy-highlight-forward
(progn
- (setq isearch-lazy-highlight-end (window-group-start))
+ (setq isearch-lazy-highlight-end window-start)
(goto-char (max (or isearch-lazy-highlight-start-limit (point-min))
- (window-group-start))))
- (setq isearch-lazy-highlight-start (window-group-end))
+ window-start)))
+ (setq isearch-lazy-highlight-start window-end)
(goto-char (min (or isearch-lazy-highlight-end-limit (point-max))
- (window-group-end))))))))
- (unless nomore
+ window-end)))))))
+ (if nomore
+ (when (or isearch-lazy-highlight-buffer
+ (and isearch-lazy-count (null isearch-lazy-count-current)))
+ (if isearch-lazy-highlight-forward
+ (setq isearch-lazy-highlight-end (point-min))
+ (setq isearch-lazy-highlight-start (point-max)))
+ (run-at-time lazy-highlight-interval nil
+ 'isearch-lazy-highlight-buffer-update))
(setq isearch-lazy-highlight-timer
(run-at-time lazy-highlight-interval nil
'isearch-lazy-highlight-update)))))))))
+(defun isearch-lazy-highlight-buffer-update ()
+ "Update highlighting of other matches in the full buffer."
+ (let ((max lazy-highlight-buffer-max-at-a-time)
+ (looping t)
+ nomore window-start window-end
+ (opoint (point)))
+ (with-local-quit
+ (save-selected-window
+ (if (and (window-live-p isearch-lazy-highlight-window)
+ (not (memq (selected-window) isearch-lazy-highlight-window-group)))
+ (select-window isearch-lazy-highlight-window))
+ (setq window-start (window-group-start))
+ (setq window-end (window-group-end))
+ (save-excursion
+ (save-match-data
+ (goto-char (if isearch-lazy-highlight-forward
+ isearch-lazy-highlight-end
+ isearch-lazy-highlight-start))
+ (while looping
+ (let* ((bound (if isearch-lazy-highlight-forward
+ (or isearch-lazy-highlight-end-limit (point-max))
+ (or isearch-lazy-highlight-start-limit (point-min))))
+ (found (isearch-lazy-highlight-search
+ isearch-lazy-highlight-last-string
+ bound)))
+ (when max
+ (setq max (1- max))
+ (if (<= max 0)
+ (setq looping nil)))
+ (if found
+ (let ((mb (match-beginning 0))
+ (me (match-end 0)))
+ (if (= mb me) ;zero-length match
+ (if isearch-lazy-highlight-forward
+ (if (= mb (point-max))
+ (setq found nil)
+ (forward-char 1))
+ (if (= mb (point-min))
+ (setq found nil)
+ (forward-char -1)))
+ (when isearch-lazy-count
+ (setq isearch-lazy-count-total
+ (1+ (or isearch-lazy-count-total 0)))
+ (puthash (if isearch-lazy-highlight-forward me mb)
+ isearch-lazy-count-total
+ isearch-lazy-count-hash))
+ ;; Don't highlight the match when this loop is used
+ ;; only to count matches or when matches were already
+ ;; highlighted within the current window boundaries
+ ;; by isearch-lazy-highlight-update
+ (unless (or (not isearch-lazy-highlight-buffer)
+ (and (>= mb window-start) (<= me window-end)))
+ ;; non-zero-length match
+ (isearch-lazy-highlight-match mb me)))
+ ;; Remember the current position of point for
+ ;; the next call of `isearch-lazy-highlight-update'
+ ;; when `lazy-highlight-buffer-max-at-a-time' is too small.
+ (if isearch-lazy-highlight-forward
+ (setq isearch-lazy-highlight-end (point))
+ (setq isearch-lazy-highlight-start (point)))))
+
+ ;; not found or zero-length match at the search bound
+ (if (not found)
+ (setq looping nil
+ nomore t))))
+ (if nomore
+ (when (and isearch-lazy-count isearch-mode (null isearch-message-function))
+ (unless isearch-lazy-count-total
+ (setq isearch-lazy-count-total 0))
+ (setq isearch-lazy-count-current
+ (gethash opoint isearch-lazy-count-hash 0))
+ (isearch-message))
+ (setq isearch-lazy-highlight-timer
+ (run-at-time lazy-highlight-interval nil
+ 'isearch-lazy-highlight-buffer-update)))))))))
+
(defun isearch-resume (string regexp word forward message case-fold)
"Resume an incremental search.
STRING is the string or regexp searched for.
diff --git a/lisp/jit-lock.el b/lisp/jit-lock.el
index 9f325c8259c..48998a81fe7 100644
--- a/lisp/jit-lock.el
+++ b/lisp/jit-lock.el
@@ -266,6 +266,7 @@ If you need to debug code run from jit-lock, see `jit-lock-debug-mode'."
(define-minor-mode jit-lock-debug-mode
"Minor mode to help debug code run from jit-lock.
+
When this minor mode is enabled, jit-lock runs as little code as possible
during redisplay and moves the rest to a timer, where things
like `debug-on-error' and Edebug can be used."
diff --git a/lisp/jka-cmpr-hook.el b/lisp/jka-cmpr-hook.el
index 1b6e5902b90..3aa84f45b0d 100644
--- a/lisp/jka-cmpr-hook.el
+++ b/lisp/jka-cmpr-hook.el
@@ -347,9 +347,6 @@ variables. Setting this through Custom does that automatically."
(define-minor-mode auto-compression-mode
"Toggle Auto Compression mode.
-With a prefix argument ARG, enable Auto Compression mode if ARG
-is positive, and disable it otherwise. If called from Lisp,
-enable the mode if ARG is omitted or nil.
Auto Compression mode is a global minor mode. When enabled,
compressed files are automatically uncompressed for reading, and
diff --git a/lisp/json.el b/lisp/json.el
index 1a455e3851b..44b3c33df7c 100644
--- a/lisp/json.el
+++ b/lisp/json.el
@@ -49,10 +49,13 @@
;; 2008-02-21 - Installed in GNU Emacs.
;; 2011-10-17 - Patch `json-alist-p' and `json-plist-p' to avoid recursion -tzz
;; 2012-10-25 - Added pretty-printed reformatting -Ryan Crum (ryan@ryancrum.org)
+;; 2019-02-02 - Pretty-printing now uses replace-region-contents and support for
+;; minimization -tsdh
;;; Code:
(require 'map)
+(require 'subr-x)
;; Parameters
@@ -370,7 +373,7 @@ representation will be parsed correctly."
(defun json--decode-utf-16-surrogates (high low)
"Return the code point represented by the UTF-16 surrogates HIGH and LOW."
- (+ (lsh (- high #xD800) 10) (- low #xDC00) #x10000))
+ (+ (ash (- high #xD800) 10) (- low #xDC00) #x10000))
(defun json-read-escaped-char ()
"Read the JSON string escaped character at point."
@@ -523,8 +526,8 @@ Please see the documentation of `json-object-type' and `json-key-type'."
;; Skip over the "}"
(json-advance)
(pcase json-object-type
- (`alist (nreverse elements))
- (`plist (json--plist-reverse elements))
+ ('alist (nreverse elements))
+ ('plist (json--plist-reverse elements))
(_ elements))))
;; Hash table encoding
@@ -609,8 +612,7 @@ Please see the documentation of `json-object-type' and `json-key-type'."
"Return a JSON representation of LIST.
Tries to DWIM: simple lists become JSON arrays, while alists and plists
become JSON objects."
- (cond ((null list) "null")
- ((json-alist-p list) (json-encode-alist list))
+ (cond ((json-alist-p list) (json-encode-alist list))
((json-plist-p list) (json-encode-plist list))
((listp list) (json-encode-array list))
(t
@@ -642,8 +644,8 @@ become JSON objects."
;; Skip over the "]"
(json-advance)
(pcase json-array-type
- (`vector (nreverse (vconcat elements)))
- (`list (nreverse elements)))))
+ ('vector (nreverse (vconcat elements)))
+ ('list (nreverse elements)))))
;; Array encoding
@@ -723,42 +725,58 @@ Advances point just past JSON object."
((stringp object) (json-encode-string object))
((keywordp object) (json-encode-string
(substring (symbol-name object) 1)))
+ ((listp object) (json-encode-list object))
((symbolp object) (json-encode-string
(symbol-name object)))
((numberp object) (json-encode-number object))
((arrayp object) (json-encode-array object))
((hash-table-p object) (json-encode-hash-table object))
- ((listp object) (json-encode-list object))
(t (signal 'json-error (list object)))))
-;; Pretty printing
-
-(defun json-pretty-print-buffer ()
- "Pretty-print current buffer."
- (interactive)
- (json-pretty-print (point-min) (point-max)))
-
-(defun json-pretty-print (begin end)
- "Pretty-print selected region."
- (interactive "r")
- (atomic-change-group
- (let ((json-encoding-pretty-print t)
- ;; Ensure that ordering is maintained
- (json-object-type 'alist)
- (txt (delete-and-extract-region begin end)))
- (insert (json-encode (json-read-from-string txt))))))
-
-(defun json-pretty-print-buffer-ordered ()
- "Pretty-print current buffer with object keys ordered."
- (interactive)
+;; Pretty printing & minimizing
+
+(defun json-pretty-print-buffer (&optional minimize)
+ "Pretty-print current buffer.
+With prefix argument MINIMIZE, minimize it instead."
+ (interactive "P")
+ (json-pretty-print (point-min) (point-max) minimize))
+
+(defvar json-pretty-print-max-secs 2.0
+ "Maximum time for `json-pretty-print's comparison.
+The function `json-pretty-print' uses `replace-region-contents'
+(which see) passing the value of this variable as argument
+MAX-SECS.")
+
+(defun json-pretty-print (begin end &optional minimize)
+ "Pretty-print selected region.
+With prefix argument MINIMIZE, minimize it instead."
+ (interactive "r\nP")
+ (let ((json-encoding-pretty-print (null minimize))
+ ;; Distinguish an empty objects from 'null'
+ (json-null :json-null)
+ ;; Ensure that ordering is maintained
+ (json-object-type 'alist))
+ (replace-region-contents
+ begin end
+ (lambda () (json-encode (json-read)))
+ json-pretty-print-max-secs
+ ;; FIXME: What's a good value here? Can we use something better,
+ ;; e.g., by deriving a value from the size of the region?
+ 64)))
+
+(defun json-pretty-print-buffer-ordered (&optional minimize)
+ "Pretty-print current buffer with object keys ordered.
+With prefix argument MINIMIZE, minimize it instead."
+ (interactive "P")
(let ((json-encoding-object-sort-predicate 'string<))
- (json-pretty-print-buffer)))
+ (json-pretty-print-buffer minimize)))
-(defun json-pretty-print-ordered (begin end)
- "Pretty-print the region with object keys ordered."
- (interactive "r")
+(defun json-pretty-print-ordered (begin end &optional minimize)
+ "Pretty-print the region with object keys ordered.
+With prefix argument MINIMIZE, minimize it instead."
+ (interactive "r\nP")
(let ((json-encoding-object-sort-predicate 'string<))
- (json-pretty-print begin end)))
+ (json-pretty-print begin end minimize)))
(provide 'json)
diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el
new file mode 100644
index 00000000000..c02e6859743
--- /dev/null
+++ b/lisp/jsonrpc.el
@@ -0,0 +1,700 @@
+;;; jsonrpc.el --- JSON-RPC library -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018-2019 Free Software Foundation, Inc.
+
+;; Author: João Távora <joaotavora@gmail.com>
+;; Maintainer: João Távora <joaotavora@gmail.com>
+;; Keywords: processes, languages, extensions
+;; Package-Requires: ((emacs "25.2"))
+;; Version: 1.0.7
+
+;; This is an Elpa :core package. Don't use functionality that is not
+;; compatible with Emacs 25.2.
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This library implements the JSONRPC 2.0 specification as described
+;; in http://www.jsonrpc.org/. As the name suggests, JSONRPC is a
+;; generic Remote Procedure Call protocol designed around JSON
+;; objects. To learn how to write JSONRPC programs with this library,
+;; see Info node `(elisp)JSONRPC'."
+;;
+;; This library was originally extracted from eglot.el, an Emacs LSP
+;; client, which you should see for an example usage.
+;;
+;;; Code:
+
+(require 'cl-lib)
+(require 'json)
+(require 'eieio)
+(eval-when-compile (require 'subr-x))
+(require 'warnings)
+(require 'pcase)
+(require 'ert) ; to escape a `condition-case-unless-debug'
+(require 'array) ; xor
+
+
+;;; Public API
+;;;
+
+(defclass jsonrpc-connection ()
+ ((name
+ :accessor jsonrpc-name
+ :initarg :name
+ :documentation "A name for the connection")
+ (-request-dispatcher
+ :accessor jsonrpc--request-dispatcher
+ :initform #'ignore
+ :initarg :request-dispatcher
+ :documentation "Dispatcher for remotely invoked requests.")
+ (-notification-dispatcher
+ :accessor jsonrpc--notification-dispatcher
+ :initform #'ignore
+ :initarg :notification-dispatcher
+ :documentation "Dispatcher for remotely invoked notifications.")
+ (last-error
+ :accessor jsonrpc-last-error
+ :documentation "Last JSONRPC error message received from endpoint.")
+ (-request-continuations
+ :initform (make-hash-table)
+ :accessor jsonrpc--request-continuations
+ :documentation "A hash table of request ID to continuation lambdas.")
+ (-events-buffer
+ :accessor jsonrpc--events-buffer
+ :documentation "A buffer pretty-printing the JSONRPC events")
+ (-events-buffer-scrollback-size
+ :initarg :events-buffer-scrollback-size
+ :accessor jsonrpc--events-buffer-scrollback-size
+ :documentation "Max size of events buffer. 0 disables, nil means infinite.")
+ (-deferred-actions
+ :initform (make-hash-table :test #'equal)
+ :accessor jsonrpc--deferred-actions
+ :documentation "Map (DEFERRED BUF) to (FN TIMER ID). FN is\
+a saved DEFERRED `async-request' from BUF, to be sent not later\
+than TIMER as ID.")
+ (-next-request-id
+ :initform 0
+ :accessor jsonrpc--next-request-id
+ :documentation "Next number used for a request"))
+ :documentation "Base class representing a JSONRPC connection.
+The following initargs are accepted:
+
+:NAME (mandatory), a string naming the connection
+
+:REQUEST-DISPATCHER (optional), a function of three
+arguments (CONN METHOD PARAMS) for handling JSONRPC requests.
+CONN is a `jsonrpc-connection' object, method is a symbol, and
+PARAMS is a plist representing a JSON object. The function is
+expected to return a JSONRPC result, a plist of (:result
+RESULT) or signal an error of type `jsonrpc-error'.
+
+:NOTIFICATION-DISPATCHER (optional), a function of three
+arguments (CONN METHOD PARAMS) for handling JSONRPC
+notifications. CONN, METHOD and PARAMS are the same as in
+:REQUEST-DISPATCHER.")
+
+;;; API mandatory
+(cl-defgeneric jsonrpc-connection-send (conn &key id method params result error)
+ "Send a JSONRPC message to connection CONN.
+ID, METHOD, PARAMS, RESULT and ERROR. ")
+
+;;; API optional
+(cl-defgeneric jsonrpc-shutdown (conn)
+ "Shutdown the JSONRPC connection CONN.")
+
+;;; API optional
+(cl-defgeneric jsonrpc-running-p (conn)
+ "Tell if the JSONRPC connection CONN is still running.")
+
+;;; API optional
+(cl-defgeneric jsonrpc-connection-ready-p (connection what)
+ "Tell if CONNECTION is ready for WHAT in current buffer.
+If it isn't, a request which was passed a value to the
+`:deferred' keyword argument will be deferred to the future.
+WHAT is whatever was passed the as the value to that argument.
+
+By default, all connections are ready for sending all requests
+immediately."
+ (:method (_s _what) ;; by default all connections are ready
+ t))
+
+
+;;; Convenience
+;;;
+(cl-defmacro jsonrpc-lambda (cl-lambda-list &body body)
+ (declare (indent 1) (debug (sexp &rest form)))
+ (let ((e (cl-gensym "jsonrpc-lambda-elem")))
+ `(lambda (,e) (apply (cl-function (lambda ,cl-lambda-list ,@body)) ,e))))
+
+(defun jsonrpc-events-buffer (connection)
+ "Get or create JSONRPC events buffer for CONNECTION."
+ (let* ((probe (jsonrpc--events-buffer connection))
+ (buffer (or (and (buffer-live-p probe)
+ probe)
+ (let ((buffer (get-buffer-create
+ (format "*%s events*"
+ (jsonrpc-name connection)))))
+ (with-current-buffer buffer
+ (buffer-disable-undo)
+ (read-only-mode t)
+ (setf (jsonrpc--events-buffer connection) buffer))
+ buffer))))
+ buffer))
+
+(defun jsonrpc-forget-pending-continuations (connection)
+ "Stop waiting for responses from the current JSONRPC CONNECTION."
+ (clrhash (jsonrpc--request-continuations connection)))
+
+(defun jsonrpc-connection-receive (connection message)
+ "Process MESSAGE just received from CONNECTION.
+This function will destructure MESSAGE and call the appropriate
+dispatcher in CONNECTION."
+ (cl-destructuring-bind (&key method id error params result _jsonrpc)
+ message
+ (let (continuations)
+ (jsonrpc--log-event connection message 'server)
+ (setf (jsonrpc-last-error connection) error)
+ (cond
+ (;; A remote request
+ (and method id)
+ (let* ((debug-on-error (and debug-on-error (not (ert-running-test))))
+ (reply
+ (condition-case-unless-debug _ignore
+ (condition-case oops
+ `(:result ,(funcall (jsonrpc--request-dispatcher connection)
+ connection (intern method) params))
+ (jsonrpc-error
+ `(:error
+ (:code
+ ,(or (alist-get 'jsonrpc-error-code (cdr oops)) -32603)
+ :message ,(or (alist-get 'jsonrpc-error-message
+ (cdr oops))
+ "Internal error")))))
+ (error
+ '(:error (:code -32603 :message "Internal error"))))))
+ (apply #'jsonrpc--reply connection id reply)))
+ (;; A remote notification
+ method
+ (funcall (jsonrpc--notification-dispatcher connection)
+ connection (intern method) params))
+ (;; A remote response
+ (setq continuations
+ (and id (gethash id (jsonrpc--request-continuations connection))))
+ (let ((timer (nth 2 continuations)))
+ (when timer (cancel-timer timer)))
+ (remhash id (jsonrpc--request-continuations connection))
+ (if error (funcall (nth 1 continuations) error)
+ (funcall (nth 0 continuations) result))))
+ (jsonrpc--call-deferred connection))))
+
+
+;;; Contacting the remote endpoint
+;;;
+(defun jsonrpc-error (&rest args)
+ "Error out with FORMAT and ARGS.
+If invoked inside a dispatcher function, this function is suitable
+for replying to the remote endpoint with an error message.
+
+ARGS can be of the form (FORMAT-STRING . MOREARGS) for replying
+with a -32603 error code and a message formed by formatting
+FORMAT-STRING with MOREARGS.
+
+Alternatively ARGS can be plist representing a JSONRPC error
+object, using the keywords `:code', `:message' and `:data'."
+ (if (stringp (car args))
+ (let ((msg
+ (apply #'format-message (car args) (cdr args))))
+ (signal 'jsonrpc-error
+ `(,msg
+ (jsonrpc-error-code . ,32603)
+ (jsonrpc-error-message . ,msg))))
+ (cl-destructuring-bind (&key code message data) args
+ (signal 'jsonrpc-error
+ `(,(format "[jsonrpc] error ")
+ (jsonrpc-error-code . ,code)
+ (jsonrpc-error-message . ,message)
+ (jsonrpc-error-data . ,data))))))
+
+(cl-defun jsonrpc-async-request (connection
+ method
+ params
+ &rest args
+ &key _success-fn _error-fn
+ _timeout-fn
+ _timeout _deferred)
+ "Make a request to CONNECTION, expecting a reply, return immediately.
+The JSONRPC request is formed by METHOD, a symbol, and PARAMS a
+JSON object.
+
+The caller can expect SUCCESS-FN or ERROR-FN to be called with a
+JSONRPC `:result' or `:error' object, respectively. If this
+doesn't happen after TIMEOUT seconds (defaults to
+`jsonrpc-request-timeout'), the caller can expect TIMEOUT-FN to be
+called with no arguments. The default values of SUCCESS-FN,
+ERROR-FN and TIMEOUT-FN simply log the events into
+`jsonrpc-events-buffer'.
+
+If DEFERRED is non-nil, maybe defer the request to a future time
+when the server is thought to be ready according to
+`jsonrpc-connection-ready-p' (which see). The request might
+never be sent at all, in case it is overridden in the meantime by
+a new request with identical DEFERRED and for the same buffer.
+However, in that situation, the original timeout is kept.
+
+Returns nil."
+ (apply #'jsonrpc--async-request-1 connection method params args)
+ nil)
+
+(cl-defun jsonrpc-request (connection
+ method params &key
+ deferred timeout
+ cancel-on-input
+ cancel-on-input-retval)
+ "Make a request to CONNECTION, wait for a reply.
+Like `jsonrpc-async-request' for CONNECTION, METHOD and PARAMS,
+but synchronous.
+
+Except in the case of a non-nil CANCEL-ON-INPUT (explained
+below), this function doesn't exit until anything interesting
+happens (success reply, error reply, or timeout). Furthermore,
+it only exits locally (returning the JSONRPC result object) if
+the request is successful, otherwise it exits non-locally with an
+error of type `jsonrpc-error'.
+
+DEFERRED is passed to `jsonrpc-async-request', which see.
+
+If CANCEL-ON-INPUT is non-nil and the user inputs something while
+the functino is waiting, then it exits immediately, returning
+CANCEL-ON-INPUT-RETVAL. Any future replies (normal or error) are
+ignored."
+ (let* ((tag (cl-gensym "jsonrpc-request-catch-tag")) id-and-timer
+ cancelled
+ (retval
+ (unwind-protect
+ (catch tag
+ (setq
+ id-and-timer
+ (jsonrpc--async-request-1
+ connection method params
+ :success-fn (lambda (result)
+ (unless cancelled
+ (throw tag `(done ,result))))
+ :error-fn
+ (jsonrpc-lambda
+ (&key code message data)
+ (unless cancelled
+ (throw tag `(error (jsonrpc-error-code . ,code)
+ (jsonrpc-error-message . ,message)
+ (jsonrpc-error-data . ,data)))))
+ :timeout-fn
+ (lambda ()
+ (unless cancelled
+ (throw tag '(error (jsonrpc-error-message . "Timed out")))))
+ :deferred deferred
+ :timeout timeout))
+ (cond (cancel-on-input
+ (while (sit-for 30))
+ (setq cancelled t)
+ `(cancelled ,cancel-on-input-retval))
+ (t (while t (accept-process-output nil 30)))))
+ ;; In normal operation, cancellation is handled by the
+ ;; timeout function and response filter, but we still have
+ ;; to protect against user-quit (C-g) or the
+ ;; `cancel-on-input' case.
+ (pcase-let* ((`(,id ,timer) id-and-timer))
+ (remhash id (jsonrpc--request-continuations connection))
+ (remhash (list deferred (current-buffer))
+ (jsonrpc--deferred-actions connection))
+ (when timer (cancel-timer timer))))))
+ (when (eq 'error (car retval))
+ (signal 'jsonrpc-error
+ (cons
+ (format "request id=%s failed:" (car id-and-timer))
+ (cdr retval))))
+ (cadr retval)))
+
+(cl-defun jsonrpc-notify (connection method params)
+ "Notify CONNECTION of something, don't expect a reply."
+ (jsonrpc-connection-send connection
+ :method method
+ :params params))
+
+(defconst jrpc-default-request-timeout 10
+ "Time in seconds before timing out a JSONRPC request.")
+
+
+;;; Specfic to `jsonrpc-process-connection'
+;;;
+
+(defclass jsonrpc-process-connection (jsonrpc-connection)
+ ((-process
+ :initarg :process :accessor jsonrpc--process
+ :documentation "Process object wrapped by the this connection.")
+ (-expected-bytes
+ :accessor jsonrpc--expected-bytes
+ :documentation "How many bytes declared by server")
+ (-on-shutdown
+ :accessor jsonrpc--on-shutdown
+ :initform #'ignore
+ :initarg :on-shutdown
+ :documentation "Function run when the process dies."))
+ :documentation "A JSONRPC connection over an Emacs process.
+The following initargs are accepted:
+
+:PROCESS (mandatory), a live running Emacs process object or a
+function of no arguments producing one such object. The process
+represents either a pipe connection to locally running process or
+a stream connection to a network host. The remote endpoint is
+expected to understand JSONRPC messages with basic HTTP-style
+enveloping headers such as \"Content-Length:\".
+
+:ON-SHUTDOWN (optional), a function of one argument, the
+connection object, called when the process dies .")
+
+(cl-defmethod initialize-instance ((conn jsonrpc-process-connection) slots)
+ (cl-call-next-method)
+ (let* ((proc (plist-get slots :process))
+ (proc (if (functionp proc) (funcall proc) proc))
+ (buffer (get-buffer-create (format "*%s output*" (process-name proc))))
+ (stderr (get-buffer-create (format "*%s stderr*" (process-name proc)))))
+ (setf (jsonrpc--process conn) proc)
+ (set-process-buffer proc buffer)
+ (process-put proc 'jsonrpc-stderr stderr)
+ (set-process-filter proc #'jsonrpc--process-filter)
+ (set-process-sentinel proc #'jsonrpc--process-sentinel)
+ (with-current-buffer (process-buffer proc)
+ (set-marker (process-mark proc) (point-min))
+ (let ((inhibit-read-only t)) (erase-buffer) (read-only-mode t) proc))
+ (process-put proc 'jsonrpc-connection conn)))
+
+(cl-defmethod jsonrpc-connection-send ((connection jsonrpc-process-connection)
+ &rest args
+ &key
+ _id
+ method
+ _params
+ _result
+ _error
+ _partial)
+ "Send MESSAGE, a JSON object, to CONNECTION."
+ (when method
+ (plist-put args :method
+ (cond ((keywordp method) (substring (symbol-name method) 1))
+ ((and method (symbolp method)) (symbol-name method)))))
+ (let* ( (message `(:jsonrpc "2.0" ,@args))
+ (json (jsonrpc--json-encode message))
+ (headers
+ `(("Content-Length" . ,(format "%d" (string-bytes json)))
+ ;; ("Content-Type" . "application/vscode-jsonrpc; charset=utf-8")
+ )))
+ (process-send-string
+ (jsonrpc--process connection)
+ (cl-loop for (header . value) in headers
+ concat (concat header ": " value "\r\n") into header-section
+ finally return (format "%s\r\n%s" header-section json)))
+ (jsonrpc--log-event connection message 'client)))
+
+(defun jsonrpc-process-type (conn)
+ "Return the `process-type' of JSONRPC connection CONN."
+ (process-type (jsonrpc--process conn)))
+
+(cl-defmethod jsonrpc-running-p ((conn jsonrpc-process-connection))
+ "Return non-nil if JSONRPC connection CONN is running."
+ (process-live-p (jsonrpc--process conn)))
+
+(cl-defmethod jsonrpc-shutdown ((conn jsonrpc-process-connection)
+ &optional cleanup)
+ "Wait for JSONRPC connection CONN to shutdown.
+With optional CLEANUP, kill any associated buffers. "
+ (unwind-protect
+ (cl-loop
+ with proc = (jsonrpc--process conn) for i from 0
+ while (not (process-get proc 'jsonrpc-sentinel-cleanup-started))
+ unless (zerop i) do
+ (jsonrpc--warn "Sentinel for %s still hasn't run, deleting it!" proc)
+ do
+ (delete-process proc)
+ (accept-process-output nil 0.1))
+ (when cleanup
+ (kill-buffer (process-buffer (jsonrpc--process conn)))
+ (kill-buffer (jsonrpc-stderr-buffer conn)))))
+
+(defun jsonrpc-stderr-buffer (conn)
+ "Get CONN's standard error buffer, if any."
+ (process-get (jsonrpc--process conn) 'jsonrpc-stderr))
+
+
+;;; Private stuff
+;;;
+(define-error 'jsonrpc-error "jsonrpc-error")
+
+(defun jsonrpc--json-read ()
+ "Read JSON object in buffer, move point to end of buffer."
+ ;; TODO: I guess we can make these macros if/when jsonrpc.el
+ ;; goes into Emacs core.
+ (cond ((fboundp 'json-parse-buffer) (json-parse-buffer
+ :object-type 'plist
+ :null-object nil
+ :false-object :json-false))
+ (t (let ((json-object-type 'plist))
+ (json-read)))))
+
+(defun jsonrpc--json-encode (object)
+ "Encode OBJECT into a JSON string."
+ (cond ((fboundp 'json-serialize) (json-serialize
+ object
+ :false-object :json-false
+ :null-object nil))
+ (t (let ((json-false :json-false)
+ (json-null nil))
+ (json-encode object)))))
+
+(cl-defun jsonrpc--reply (connection id &key (result nil result-supplied-p) error)
+ "Reply to CONNECTION's request ID with RESULT or ERROR."
+ (jsonrpc-connection-send connection :id id :result result :error error))
+
+(defun jsonrpc--call-deferred (connection)
+ "Call CONNECTION's deferred actions, who may again defer themselves."
+ (when-let ((actions (hash-table-values (jsonrpc--deferred-actions connection))))
+ (jsonrpc--debug connection `(:maybe-run-deferred
+ ,(mapcar (apply-partially #'nth 2) actions)))
+ (mapc #'funcall (mapcar #'car actions))))
+
+(defun jsonrpc--process-sentinel (proc change)
+ "Called when PROC undergoes CHANGE."
+ (let ((connection (process-get proc 'jsonrpc-connection)))
+ (jsonrpc--debug connection `(:message "Connection state changed" :change ,change))
+ (when (not (process-live-p proc))
+ (with-current-buffer (jsonrpc-events-buffer connection)
+ (let ((inhibit-read-only t))
+ (insert "\n----------b---y---e---b---y---e----------\n")))
+ ;; Cancel outstanding timers
+ (maphash (lambda (_id triplet)
+ (pcase-let ((`(,_success ,_error ,timeout) triplet))
+ (when timeout (cancel-timer timeout))))
+ (jsonrpc--request-continuations connection))
+ (process-put proc 'jsonrpc-sentinel-cleanup-started t)
+ (unwind-protect
+ ;; Call all outstanding error handlers
+ (maphash (lambda (_id triplet)
+ (pcase-let ((`(,_success ,error ,_timeout) triplet))
+ (funcall error '(:code -1 :message "Server died"))))
+ (jsonrpc--request-continuations connection))
+ (jsonrpc--message "Server exited with status %s" (process-exit-status proc))
+ (delete-process proc)
+ (funcall (jsonrpc--on-shutdown connection) connection)))))
+
+(defun jsonrpc--process-filter (proc string)
+ "Called when new data STRING has arrived for PROC."
+ (when (buffer-live-p (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
+ (let* ((inhibit-read-only t)
+ (connection (process-get proc 'jsonrpc-connection))
+ (expected-bytes (jsonrpc--expected-bytes connection)))
+ ;; Insert the text, advancing the process marker.
+ ;;
+ (save-excursion
+ (goto-char (process-mark proc))
+ (insert string)
+ (set-marker (process-mark proc) (point)))
+ ;; Loop (more than one message might have arrived)
+ ;;
+ (unwind-protect
+ (let (done)
+ (while (not done)
+ (cond
+ ((not expected-bytes)
+ ;; Starting a new message
+ ;;
+ (setq expected-bytes
+ (and (search-forward-regexp
+ "\\(?:.*: .*\r\n\\)*Content-Length: \
+*\\([[:digit:]]+\\)\r\n\\(?:.*: .*\r\n\\)*\r\n"
+ (+ (point) 100)
+ t)
+ (string-to-number (match-string 1))))
+ (unless expected-bytes
+ (setq done :waiting-for-new-message)))
+ (t
+ ;; Attempt to complete a message body
+ ;;
+ (let ((available-bytes (- (position-bytes (process-mark proc))
+ (position-bytes (point)))))
+ (cond
+ ((>= available-bytes
+ expected-bytes)
+ (let* ((message-end (byte-to-position
+ (+ (position-bytes (point))
+ expected-bytes))))
+ (unwind-protect
+ (save-restriction
+ (narrow-to-region (point) message-end)
+ (let* ((json-message
+ (condition-case-unless-debug oops
+ (jsonrpc--json-read)
+ (error
+ (jsonrpc--warn "Invalid JSON: %s %s"
+ (cdr oops) (buffer-string))
+ nil))))
+ (when json-message
+ ;; Process content in another
+ ;; buffer, shielding proc buffer from
+ ;; tamper
+ (with-temp-buffer
+ (jsonrpc-connection-receive connection
+ json-message)))))
+ (goto-char message-end)
+ (delete-region (point-min) (point))
+ (setq expected-bytes nil))))
+ (t
+ ;; Message is still incomplete
+ ;;
+ (setq done :waiting-for-more-bytes-in-this-message))))))))
+ ;; Saved parsing state for next visit to this filter
+ ;;
+ (setf (jsonrpc--expected-bytes connection) expected-bytes))))))
+
+(cl-defun jsonrpc--async-request-1 (connection
+ method
+ params
+ &rest args
+ &key success-fn error-fn timeout-fn
+ (timeout jrpc-default-request-timeout)
+ (deferred nil))
+ "Does actual work for `jsonrpc-async-request'.
+
+Return a list (ID TIMER). ID is the new request's ID, or nil if
+the request was deferred. TIMER is a timer object set (or nil, if
+TIMEOUT is nil)."
+ (pcase-let* ((buf (current-buffer)) (point (point))
+ (`(,_ ,timer ,old-id)
+ (and deferred (gethash (list deferred buf)
+ (jsonrpc--deferred-actions connection))))
+ (id (or old-id (cl-incf (jsonrpc--next-request-id connection))))
+ (make-timer
+ (lambda ( )
+ (when timeout
+ (run-with-timer
+ timeout nil
+ (lambda ()
+ (remhash id (jsonrpc--request-continuations connection))
+ (remhash (list deferred buf)
+ (jsonrpc--deferred-actions connection))
+ (if timeout-fn (funcall timeout-fn)
+ (jsonrpc--debug
+ connection `(:timed-out ,method :id ,id
+ :params ,params)))))))))
+ (when deferred
+ (if (jsonrpc-connection-ready-p connection deferred)
+ ;; Server is ready, we jump below and send it immediately.
+ (remhash (list deferred buf) (jsonrpc--deferred-actions connection))
+ ;; Otherwise, save in `eglot--deferred-actions' and exit non-locally
+ (unless old-id
+ (jsonrpc--debug connection `(:deferring ,method :id ,id :params
+ ,params)))
+ (puthash (list deferred buf)
+ (list (lambda ()
+ (when (buffer-live-p buf)
+ (with-current-buffer buf
+ (save-excursion (goto-char point)
+ (apply #'jsonrpc-async-request
+ connection
+ method params args)))))
+ (or timer (setq timer (funcall make-timer))) id)
+ (jsonrpc--deferred-actions connection))
+ (cl-return-from jsonrpc--async-request-1 (list id timer))))
+ ;; Really send it
+ ;;
+ (jsonrpc-connection-send connection
+ :id id
+ :method method
+ :params params)
+ (puthash id
+ (list (or success-fn
+ (jsonrpc-lambda (&rest _ignored)
+ (jsonrpc--debug
+ connection (list :message "success ignored"
+ :id id))))
+ (or error-fn
+ (jsonrpc-lambda (&key code message &allow-other-keys)
+ (jsonrpc--debug
+ connection (list
+ :message
+ (format "error ignored, status set (%s)"
+ message)
+ :id id :error code))))
+ (setq timer (funcall make-timer)))
+ (jsonrpc--request-continuations connection))
+ (list id timer)))
+
+(defun jsonrpc--message (format &rest args)
+ "Message out with FORMAT with ARGS."
+ (message "[jsonrpc] %s" (apply #'format format args)))
+
+(defun jsonrpc--debug (server format &rest args)
+ "Debug message for SERVER with FORMAT and ARGS."
+ (jsonrpc--log-event
+ server (if (stringp format)`(:message ,(format format args)) format)))
+
+(defun jsonrpc--warn (format &rest args)
+ "Warning message with FORMAT and ARGS."
+ (apply #'jsonrpc--message (concat "(warning) " format) args)
+ (let ((warning-minimum-level :error))
+ (display-warning 'jsonrpc
+ (apply #'format format args)
+ :warning)))
+
+(defun jsonrpc--log-event (connection message &optional type)
+ "Log a JSONRPC-related event.
+CONNECTION is the current connection. MESSAGE is a JSON-like
+plist. TYPE is a symbol saying if this is a client or server
+originated."
+ (let ((max (jsonrpc--events-buffer-scrollback-size connection)))
+ (when (or (null max) (cl-plusp max))
+ (with-current-buffer (jsonrpc-events-buffer connection)
+ (cl-destructuring-bind (&key method id error &allow-other-keys) message
+ (let* ((inhibit-read-only t)
+ (subtype (cond ((and method id) 'request)
+ (method 'notification)
+ (id 'reply)
+ (t 'message)))
+ (type
+ (concat (format "%s" (or type 'internal))
+ (if type
+ (format "-%s" subtype)))))
+ (goto-char (point-max))
+ (prog1
+ (let ((msg (format "%s%s%s %s:\n%s\n"
+ type
+ (if id (format " (id:%s)" id) "")
+ (if error " ERROR" "")
+ (current-time-string)
+ (pp-to-string message))))
+ (when error
+ (setq msg (propertize msg 'face 'error)))
+ (insert-before-markers msg))
+ ;; Trim the buffer if it's too large
+ (when max
+ (save-excursion
+ (goto-char (point-min))
+ (while (> (buffer-size) max)
+ (delete-region (point) (progn (forward-line 1)
+ (forward-sexp 1)
+ (forward-line 2)
+ (point)))))))))))))
+
+(provide 'jsonrpc)
+;;; jsonrpc.el ends here
diff --git a/lisp/kmacro.el b/lisp/kmacro.el
index 72d7091df17..fc34e167084 100644
--- a/lisp/kmacro.el
+++ b/lisp/kmacro.el
@@ -124,13 +124,11 @@
(defcustom kmacro-call-mouse-event 'S-mouse-3
"The mouse event used by kmacro to call a macro.
Set to nil if no mouse binding is desired."
- :type 'symbol
- :group 'kmacro)
+ :type 'symbol)
(defcustom kmacro-ring-max 8
"Maximum number of keyboard macros to save in macro ring."
- :type 'integer
- :group 'kmacro)
+ :type 'integer)
(defcustom kmacro-execute-before-append t
@@ -141,32 +139,27 @@ execute the macro.
Otherwise, a single \\[universal-argument] prefix does not execute the
macro, while more than one \\[universal-argument] prefix causes the
macro to be executed before appending to it."
- :type 'boolean
- :group 'kmacro)
+ :type 'boolean)
(defcustom kmacro-repeat-no-prefix t
"Allow repeating certain macro commands without entering the C-x C-k prefix."
- :type 'boolean
- :group 'kmacro)
+ :type 'boolean)
(defcustom kmacro-call-repeat-key t
"Allow repeating macro call using last key or a specific key."
:type '(choice (const :tag "Disabled" nil)
(const :tag "Last key" t)
(character :tag "Character" :value ?e)
- (symbol :tag "Key symbol" :value RET))
- :group 'kmacro)
+ (symbol :tag "Key symbol" :value RET)))
(defcustom kmacro-call-repeat-with-arg nil
"Repeat macro call with original arg when non-nil; repeat once if nil."
- :type 'boolean
- :group 'kmacro)
+ :type 'boolean)
(defcustom kmacro-step-edit-mini-window-height 0.75
"Override `max-mini-window-height' when step edit keyboard macro."
- :type 'number
- :group 'kmacro)
+ :type 'number)
;; Keymap
@@ -271,7 +264,7 @@ the last increment."
(if kmacro-initial-counter-value
(setq kmacro-counter kmacro-initial-counter-value
kmacro-initial-counter-value nil))
- (if (and arg (listp arg))
+ (if (consp arg)
(insert (format kmacro-counter-format kmacro-last-counter))
(insert (format kmacro-counter-format kmacro-counter))
(kmacro-add-counter (prefix-numeric-value arg))))
@@ -290,8 +283,8 @@ the last increment."
(defun kmacro-display-counter (&optional value)
"Display current counter value."
(unless value (setq value kmacro-counter))
- (message "New macro counter value: %s (%d)" (format kmacro-counter-format value) value))
-
+ (message "New macro counter value: %s (%d)"
+ (format kmacro-counter-format value) value))
(defun kmacro-set-counter (arg)
"Set the value of `kmacro-counter' to ARG, or prompt for value if no argument.
@@ -794,19 +787,18 @@ If kbd macro currently being defined end it before activating it."
(defun kmacro-extract-lambda (mac)
"Extract kmacro from a kmacro lambda form."
- (and (consp mac)
- (eq (car mac) 'lambda)
+ (and (eq (car-safe mac) 'lambda)
(setq mac (assoc 'kmacro-exec-ring-item mac))
- (consp (cdr mac))
- (consp (car (cdr mac)))
- (consp (cdr (car (cdr mac))))
- (setq mac (car (cdr (car (cdr mac)))))
+ (setq mac (car-safe (cdr-safe (car-safe (cdr-safe mac)))))
(listp mac)
(= (length mac) 3)
(arrayp (car mac))
mac))
+(defalias 'kmacro-p #'kmacro-extract-lambda
+ "Return non-nil if MAC is a kmacro keyboard macro.")
+
(defun kmacro-bind-to-key (_arg)
"When not defining or executing a macro, offer to bind last macro to a key.
The key sequences [C-x C-k 0] through [C-x C-k 9] and [C-x C-k A]
@@ -835,7 +827,7 @@ The ARG parameter is unused."
(and (>= ch ?A) (<= ch ?Z))))
(setq key-seq (concat "\C-x\C-k" key-seq)
ok t))))
- (when (and (not (equal key-seq ""))
+ (when (and (not (equal key-seq "\^G"))
(or ok
(not (setq cmd (key-binding key-seq)))
(stringp cmd)
@@ -847,6 +839,13 @@ The ARG parameter is unused."
(kmacro-lambda-form (kmacro-ring-head)))
(message "Keyboard macro bound to %s" (format-kbd-macro key-seq))))))
+(defun kmacro-keyboard-macro-p (symbol)
+ "Return non-nil if SYMBOL is the name of some sort of keyboard macro."
+ (let ((f (symbol-function symbol)))
+ (when f
+ (or (stringp f)
+ (vectorp f)
+ (kmacro-p f)))))
(defun kmacro-name-last-macro (symbol)
"Assign a name to the last keyboard macro defined.
@@ -857,14 +856,18 @@ Such a \"function\" cannot be called from Lisp, but it is a valid editor command
(or last-kbd-macro
(error "No keyboard macro defined"))
(and (fboundp symbol)
- (not (get symbol 'kmacro))
- (not (stringp (symbol-function symbol)))
- (not (vectorp (symbol-function symbol)))
+ (not (kmacro-keyboard-macro-p symbol))
(error "Function %s is already defined and not a keyboard macro"
symbol))
(if (string-equal symbol "")
(error "No command name given"))
+ ;; FIXME: Use plain old `last-kbd-macro' for kmacros where it doesn't
+ ;; make a difference?
(fset symbol (kmacro-lambda-form (kmacro-ring-head)))
+ ;; This used to be used to detect when a symbol corresponds to a kmacro.
+ ;; Nowadays it's unused because we used `kmacro-p' instead to see if the
+ ;; symbol's function definition matches that of a kmacro, which is more
+ ;; reliable.
(put symbol 'kmacro t))
@@ -1223,7 +1226,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1',
(setq kmacro-step-edit-key-index next-index)))
(defun kmacro-step-edit-pre-command ()
- (remove-hook 'post-command-hook 'kmacro-step-edit-post-command)
+ (remove-hook 'post-command-hook #'kmacro-step-edit-post-command)
(when kmacro-step-edit-active
(cond
((eq kmacro-step-edit-active 'ignore)
@@ -1243,17 +1246,17 @@ following additional answers: `insert', `insert-1', `replace', `replace-1',
(setq kmacro-step-edit-appending nil
kmacro-step-edit-active 'ignore)))))
(when (eq kmacro-step-edit-active t)
- (add-hook 'post-command-hook 'kmacro-step-edit-post-command t)))
+ (add-hook 'post-command-hook #'kmacro-step-edit-post-command t)))
(defun kmacro-step-edit-minibuf-setup ()
- (remove-hook 'pre-command-hook 'kmacro-step-edit-pre-command t)
+ (remove-hook 'pre-command-hook #'kmacro-step-edit-pre-command t)
(when kmacro-step-edit-active
- (add-hook 'pre-command-hook 'kmacro-step-edit-pre-command nil t)))
+ (add-hook 'pre-command-hook #'kmacro-step-edit-pre-command nil t)))
(defun kmacro-step-edit-post-command ()
- (remove-hook 'pre-command-hook 'kmacro-step-edit-pre-command)
+ (remove-hook 'pre-command-hook #'kmacro-step-edit-pre-command)
(when kmacro-step-edit-active
- (add-hook 'pre-command-hook 'kmacro-step-edit-pre-command nil nil)
+ (add-hook 'pre-command-hook #'kmacro-step-edit-pre-command nil nil)
(if kmacro-step-edit-key-index
(setq executing-kbd-macro-index kmacro-step-edit-key-index)
(setq kmacro-step-edit-key-index executing-kbd-macro-index))))
@@ -1276,9 +1279,9 @@ To customize possible responses, change the \"bindings\" in `kmacro-step-edit-ma
(pre-command-hook pre-command-hook)
(post-command-hook post-command-hook)
(minibuffer-setup-hook minibuffer-setup-hook))
- (add-hook 'pre-command-hook 'kmacro-step-edit-pre-command nil)
- (add-hook 'post-command-hook 'kmacro-step-edit-post-command t)
- (add-hook 'minibuffer-setup-hook 'kmacro-step-edit-minibuf-setup t)
+ (add-hook 'pre-command-hook #'kmacro-step-edit-pre-command nil)
+ (add-hook 'post-command-hook #'kmacro-step-edit-post-command t)
+ (add-hook 'minibuffer-setup-hook #'kmacro-step-edit-minibuf-setup t)
(call-last-kbd-macro nil nil)
(when (and kmacro-step-edit-replace
kmacro-step-edit-new-macro
diff --git a/lisp/language/china-util.el b/lisp/language/china-util.el
index 70710bac18a..16385651335 100644
--- a/lisp/language/china-util.el
+++ b/lisp/language/china-util.el
@@ -168,7 +168,7 @@ Return the length of resulting text."
;; ESC ESC -> ESC
(delete-char 1)
(forward-char -1)
- (if (looking-at iso2022-gb-designation)
+ (if (looking-at "\e\\$A")
(progn
(delete-region (match-beginning 0) (match-end 0))
(insert hz-gb-designation)
diff --git a/lisp/language/cyrillic.el b/lisp/language/cyrillic.el
index 7e714a43e3e..75d4249423c 100644
--- a/lisp/language/cyrillic.el
+++ b/lisp/language/cyrillic.el
@@ -95,7 +95,7 @@
(define-coding-system-alias 'cp878 'cyrillic-koi8)
(set-language-info-alist
- "Cyrillic-KOI8" `((charset koi8)
+ "Cyrillic-KOI8" '((charset koi8)
(coding-system cyrillic-koi8)
(coding-priority cyrillic-koi8 cyrillic-iso-8bit)
(ctext-non-standard-encodings "koi8-r")
@@ -131,7 +131,7 @@ Support for Russian using koi8-r and the russian-computer input method.")
:mime-charset 'koi8-u)
(set-language-info-alist
- "Ukrainian" `((charset koi8-u)
+ "Ukrainian" '((charset koi8-u)
(coding-system koi8-u)
(coding-priority koi8-u)
(nonascii-translation . koi8-u)
@@ -151,7 +151,7 @@ Support for Russian using koi8-r and the russian-computer input method.")
(define-coding-system-alias 'alternativnyj 'cyrillic-alternativnyj)
(set-language-info-alist
- "Cyrillic-ALT" `((charset alternativnyj)
+ "Cyrillic-ALT" '((charset alternativnyj)
(coding-system cyrillic-alternativnyj)
(coding-priority cyrillic-alternativnyj)
(nonascii-translation . alternativnyj)
@@ -229,7 +229,7 @@ Support for Russian using koi8-r and the russian-computer input method.")
;; '("Cyrillic"))
(set-language-info-alist
- "Tajik" `((coding-system koi8-t)
+ "Tajik" '((coding-system koi8-t)
(coding-priority koi8-t)
(nonascii-translation . cyrillic-koi8-t)
(charset koi8-t)
@@ -239,7 +239,7 @@ Support for Russian using koi8-r and the russian-computer input method.")
'("Cyrillic"))
(set-language-info-alist
- "Bulgarian" `((coding-system windows-1251)
+ "Bulgarian" '((coding-system windows-1251)
(coding-priority windows-1251)
(nonascii-translation . windows-1251)
(charset windows-1251)
@@ -250,7 +250,7 @@ Support for Russian using koi8-r and the russian-computer input method.")
'("Cyrillic"))
(set-language-info-alist
- "Belarusian" `((coding-system windows-1251)
+ "Belarusian" '((coding-system windows-1251)
(coding-priority windows-1251)
(nonascii-translation . windows-1251)
(charset windows-1251)
@@ -262,7 +262,7 @@ Support for Russian using koi8-r and the russian-computer input method.")
'("Cyrillic"))
(set-language-info-alist
- "Ukrainian" `((coding-system koi8-u)
+ "Ukrainian" '((coding-system koi8-u)
(coding-priority koi8-u)
(input-method . "ukrainian-computer")
(documentation
diff --git a/lisp/language/english.el b/lisp/language/english.el
index ee458760dab..09ed423f2cc 100644
--- a/lisp/language/english.el
+++ b/lisp/language/english.el
@@ -62,6 +62,14 @@ Nothing special is needed to handle English.")
:mnemonic ?*)
(define-coding-system-alias 'cp1047 'ibm1047)
+(define-coding-system 'ibm038
+ "International version of EBCDIC"
+ :coding-type 'charset
+ :charset-list '(ibm038)
+ :mnemonic ?*)
+(define-coding-system-alias 'ebcdic-int 'ibm038)
+(define-coding-system-alias 'cp038 'ibm038)
+
;; Make "ASCII" an alias of "English" language environment.
(set-language-info-alist
"ASCII" (cdr (assoc "English" language-info-alist)))
diff --git a/lisp/language/ethio-util.el b/lisp/language/ethio-util.el
index afc2239fbf5..04b15ddd9a8 100644
--- a/lisp/language/ethio-util.el
+++ b/lisp/language/ethio-util.el
@@ -804,7 +804,7 @@ The 2nd and 3rd arguments BEGIN and END specify the region."
;; Special Ethiopic punctuation.
(goto-char (point-min))
- (while (re-search-forward "\\ce[»\\.\\?]\\|«\\ce" nil t)
+ (while (re-search-forward "\\ce[».?]\\|«\\ce" nil t)
(cond
((= (setq ch (preceding-char)) ?\»)
(delete-char -1)
diff --git a/lisp/language/european.el b/lisp/language/european.el
index a5bec8cf017..8c38175972f 100644
--- a/lisp/language/european.el
+++ b/lisp/language/european.el
@@ -541,7 +541,7 @@ method and applying Turkish case rules for the characters i, I, ı, İ.")))
'("European"))
(set-language-info-alist
- "Welsh" `((coding-system utf-8 latin-8) ; the input method is Unicode-based
+ "Welsh" '((coding-system utf-8 latin-8) ; the input method is Unicode-based
(coding-priority utf-8 latin-8)
(nonascii-translation . iso-8859-14)
(input-method . "welsh")
@@ -558,7 +558,7 @@ method and applying Turkish case rules for the characters i, I, ı, İ.")))
'("European"))
(set-language-info-alist
- "Latin-7" `((coding-system latin-7)
+ "Latin-7" '((coding-system latin-7)
(coding-priority latin-7)
(nonascii-translation . iso-8859-13)
(input-method . "latin-prefix")
@@ -566,7 +566,7 @@ method and applying Turkish case rules for the characters i, I, ı, İ.")))
'("European"))
(set-language-info-alist
- "Lithuanian" `((coding-system latin-7 windows-1257)
+ "Lithuanian" '((coding-system latin-7 windows-1257)
(coding-priority latin-7)
(nonascii-translation . iso-8859-13)
(input-method . "lithuanian-keyboard")
@@ -574,7 +574,7 @@ method and applying Turkish case rules for the characters i, I, ı, İ.")))
'("European"))
(set-language-info-alist
- "Latvian" `((coding-system latin-7 windows-1257)
+ "Latvian" '((coding-system latin-7 windows-1257)
(coding-priority latin-7)
(nonascii-translation . iso-8859-13)
(input-method . "latvian-keyboard")
diff --git a/lisp/language/georgian.el b/lisp/language/georgian.el
index 41c1ead8ca3..2c3d3fbc87b 100644
--- a/lisp/language/georgian.el
+++ b/lisp/language/georgian.el
@@ -37,7 +37,7 @@
:charset-list '(georgian-academy))
(set-language-info-alist
- "Georgian" `((coding-system georgian-ps)
+ "Georgian" '((coding-system georgian-ps)
(coding-priority georgian-ps)
(input-method . "georgian")
(nonascii-translation . georgian-ps)
diff --git a/lisp/language/japan-util.el b/lisp/language/japan-util.el
index fd27ae220bd..b1eb3d9127b 100644
--- a/lisp/language/japan-util.el
+++ b/lisp/language/japan-util.el
@@ -1,4 +1,4 @@
-;;; japan-util.el --- utilities for Japanese -*- coding: iso-2022-7bit; -*-
+;;; japan-util.el --- utilities for Japanese
;; Copyright (C) 2001-2019 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -29,36 +29,34 @@
;;;###autoload
(defun setup-japanese-environment-internal ()
- ;; By default, we use 'japanese-iso-8bit for file names. But, the
- ;; following prefer-coding-system will override it.
- (if (memq system-type '(windows-nt ms-dos cygwin))
- (prefer-coding-system 'japanese-shift-jis)
- (prefer-coding-system 'japanese-iso-8bit))
+ (prefer-coding-system (if (memq system-type '(windows-nt ms-dos cygwin))
+ 'japanese-shift-jis
+ 'utf-8))
(use-cjk-char-width-table 'ja_JP))
(defconst japanese-kana-table
- '((?$B$"(B ?$B%"(B ?(I1(B) (?$B$$(B ?$B%$(B ?(I2(B) (?$B$&(B ?$B%&(B ?(I3(B) (?$B$((B ?$B%((B ?(I4(B) (?$B$*(B ?$B%*(B ?(I5(B)
- (?$B$+(B ?$B%+(B ?(I6(B) (?$B$-(B ?$B%-(B ?(I7(B) (?$B$/(B ?$B%/(B ?(I8(B) (?$B$1(B ?$B%1(B ?(I9(B) (?$B$3(B ?$B%3(B ?(I:(B)
- (?$B$5(B ?$B%5(B ?(I;(B) (?$B$7(B ?$B%7(B ?(I<(B) (?$B$9(B ?$B%9(B ?(I=(B) (?$B$;(B ?$B%;(B ?(I>(B) (?$B$=(B ?$B%=(B ?(I?(B)
- (?$B$?(B ?$B%?(B ?(I@(B) (?$B$A(B ?$B%A(B ?(IA(B) (?$B$D(B ?$B%D(B ?(IB(B) (?$B$F(B ?$B%F(B ?(IC(B) (?$B$H(B ?$B%H(B ?(ID(B)
- (?$B$J(B ?$B%J(B ?(IE(B) (?$B$K(B ?$B%K(B ?(IF(B) (?$B$L(B ?$B%L(B ?(IG(B) (?$B$M(B ?$B%M(B ?(IH(B) (?$B$N(B ?$B%N(B ?(II(B)
- (?$B$O(B ?$B%O(B ?(IJ(B) (?$B$R(B ?$B%R(B ?(IK(B) (?$B$U(B ?$B%U(B ?(IL(B) (?$B$X(B ?$B%X(B ?(IM(B) (?$B$[(B ?$B%[(B ?(IN(B)
- (?$B$^(B ?$B%^(B ?(IO(B) (?$B$_(B ?$B%_(B ?(IP(B) (?$B$`(B ?$B%`(B ?(IQ(B) (?$B$a(B ?$B%a(B ?(IR(B) (?$B$b(B ?$B%b(B ?(IS(B)
- (?$B$d(B ?$B%d(B ?(IT(B) (?$B$f(B ?$B%f(B ?(IU(B) (?$B$h(B ?$B%h(B ?(IV(B)
- (?$B$i(B ?$B%i(B ?(IW(B) (?$B$j(B ?$B%j(B ?(IX(B) (?$B$k(B ?$B%k(B ?(IY(B) (?$B$l(B ?$B%l(B ?(IZ(B) (?$B$m(B ?$B%m(B ?(I[(B)
- (?$B$o(B ?$B%o(B ?(I\(B) (?$B$p(B ?$B%p(B "(I2(B") (?$B$q(B ?$B%q(B "(I4(B") (?$B$r(B ?$B%r(B ?(I&(B)
- (?$B$s(B ?$B%s(B ?(I](B)
- (?$B$,(B ?$B%,(B "(I6^(B") (?$B$.(B ?$B%.(B "(I7^(B") (?$B$0(B ?$B%0(B "(I8^(B") (?$B$2(B ?$B%2(B "(I9^(B") (?$B$4(B ?$B%4(B "(I:^(B")
- (?$B$6(B ?$B%6(B "(I;^(B") (?$B$8(B ?$B%8(B "(I<^(B") (?$B$:(B ?$B%:(B "(I=^(B") (?$B$<(B ?$B%<(B "(I>^(B") (?$B$>(B ?$B%>(B "(I?^(B")
- (?$B$@(B ?$B%@(B "(I@^(B") (?$B$B(B ?$B%B(B "(IA^(B") (?$B$E(B ?$B%E(B "(IB^(B") (?$B$G(B ?$B%G(B "(IC^(B") (?$B$I(B ?$B%I(B "(ID^(B")
- (?$B$P(B ?$B%P(B "(IJ^(B") (?$B$S(B ?$B%S(B "(IK^(B") (?$B$V(B ?$B%V(B "(IL^(B") (?$B$Y(B ?$B%Y(B "(IM^(B") (?$B$\(B ?$B%\(B "(IN^(B")
- (?$B$Q(B ?$B%Q(B "(IJ_(B") (?$B$T(B ?$B%T(B "(IK_(B") (?$B$W(B ?$B%W(B "(IL_(B") (?$B$Z(B ?$B%Z(B "(IM_(B") (?$B$](B ?$B%](B "(IN_(B")
- (?$B$!(B ?$B%!(B ?(I'(B) (?$B$#(B ?$B%#(B ?(I((B) (?$B$%(B ?$B%%(B ?(I)(B) (?$B$'(B ?$B%'(B ?(I*(B) (?$B$)(B ?$B%)(B ?(I+(B)
- (?$B$C(B ?$B%C(B ?(I/(B)
- (?$B$c(B ?$B%c(B ?(I,(B) (?$B$e(B ?$B%e(B ?(I-(B) (?$B$g(B ?$B%g(B ?(I.(B)
- (?$B$n(B ?$B%n(B "(I\(B")
- (?$B!5(B ?$B!3(B) (?$B!6(B ?$B!4(B)
- ("$B$&!+(B" ?$B%t(B "(I3^(B") (nil ?$B%u(B "(I6(B") (nil ?$B%v(B "(I9(B"))
+ '((?あ ?ア ?ア) (?い ?イ ?イ) (?う ?ウ ?ウ) (?え ?エ ?エ) (?お ?オ ?オ)
+ (?か ?カ ?カ) (?き ?キ ?キ) (?く ?ク ?ク) (?け ?ケ ?ケ) (?こ ?コ ?コ)
+ (?さ ?サ ?サ) (?し ?シ ?シ) (?す ?ス ?ス) (?せ ?セ ?セ) (?そ ?ソ ?ソ)
+ (?た ?タ ?タ) (?ち ?チ ?チ) (?つ ?ツ ?ツ) (?て ?テ ?テ) (?と ?ト ?ト)
+ (?な ?ナ ?ナ) (?に ?ニ ?ニ) (?ぬ ?ヌ ?ヌ) (?ね ?ネ ?ネ) (?の ?ノ ?ノ)
+ (?は ?ハ ?ハ) (?ひ ?ヒ ?ヒ) (?ふ ?フ ?フ) (?へ ?ヘ ?ヘ) (?ほ ?ホ ?ホ)
+ (?ま ?マ ?マ) (?み ?ミ ?ミ) (?む ?ム ?ム) (?め ?メ ?メ) (?も ?モ ?モ)
+ (?や ?ヤ ?ヤ) (?ゆ ?ユ ?ユ) (?よ ?ヨ ?ヨ)
+ (?ら ?ラ ?ラ) (?り ?リ ?リ) (?る ?ル ?ル) (?れ ?レ ?レ) (?ろ ?ロ ?ロ)
+ (?わ ?ワ ?ワ) (?ゐ ?ヰ "イ") (?ゑ ?ヱ "エ") (?を ?ヲ ?ヲ)
+ (?ん ?ン ?ン)
+ (?が ?ガ "ガ") (?ぎ ?ギ "ギ") (?ぐ ?グ "グ") (?げ ?ゲ "ゲ") (?ご ?ゴ "ゴ")
+ (?ざ ?ザ "ザ") (?じ ?ジ "ジ") (?ず ?ズ "ズ") (?ぜ ?ゼ "ゼ") (?ぞ ?ゾ "ゾ")
+ (?だ ?ダ "ダ") (?ぢ ?ヂ "ヂ") (?づ ?ヅ "ヅ") (?で ?デ "デ") (?ど ?ド "ド")
+ (?ば ?バ "バ") (?び ?ビ "ビ") (?ぶ ?ブ "ブ") (?べ ?ベ "ベ") (?ぼ ?ボ "ボ")
+ (?ぱ ?パ "パ") (?ぴ ?ピ "ピ") (?ぷ ?プ "プ") (?ぺ ?ペ "ペ") (?ぽ ?ポ "ポ")
+ (?ぁ ?ァ ?ァ) (?ぃ ?ィ ?ィ) (?ぅ ?ゥ ?ゥ) (?ぇ ?ェ ?ェ) (?ぉ ?ォ ?ォ)
+ (?っ ?ッ ?ッ)
+ (?ゃ ?ャ ?ャ) (?ゅ ?ュ ?ュ) (?ょ ?ョ ?ョ)
+ (?ゎ ?ヮ "ワ")
+ (?ゝ ?ヽ) (?ゞ ?ヾ)
+ ("う゛" ?ヴ "ヴ") (nil ?ヵ "カ") (nil ?ヶ "ケ"))
"Japanese JISX0208 Kana character table.
Each element is of the form (HIRAGANA KATAKANA HANKAKU-KATAKANA), where
HIRAGANA and KATAKANA belong to `japanese-jisx0208',
@@ -98,15 +96,15 @@ HANKAKU-KATAKANA belongs to `japanese-jisx0201-kana'.")
(put-char-code-property jisx0201 'jisx0208 katakana)))))
(defconst japanese-symbol-table
- '((?\$B!!(B ?\ ) (?$B!$(B ?, ?(I$(B) (?$B!%(B ?. ?(I!(B) (?$B!"(B ?, ?(I$(B) (?$B!#(B ?. ?(I!(B) (?$B!&(B nil ?(I%(B)
- (?$B!'(B ?:) (?$B!((B ?\;) (?$B!)(B ??) (?$B!*(B ?!) (?$B!+(B nil ?(I^(B) (?$B!,(B nil ?(I_(B)
- (?$B!-(B ?') (?$B!.(B ?`) (?$B!0(B ?^) (?$B!2(B ?_) (?$B!<(B ?- ?(I0(B) (?$B!=(B ?-) (?$B!>(B ?-)
- (?$B!?(B ?/) (?$B!@(B ?\\) (?$B!A(B ?~) (?$B!C(B ?|) (?$B!F(B ?`) (?$B!G(B ?') (?$B!H(B ?\") (?$B!I(B ?\")
- (?\$B!J(B ?\() (?\$B!K(B ?\)) (?\$B!N(B ?\[) (?\$B!O(B ?\]) (?\$B!P(B ?{) (?\$B!Q(B ?})
- (?$B!R(B ?<) (?$B!S(B ?>) (?\$B!V(B nil ?\(I"(B) (?\$B!W(B nil ?\(I#(B)
- (?$B!\(B ?+) (?$B!](B ?-) (?$B!a(B ?=) (?$B!c(B ?<) (?$B!d(B ?>)
- (?$B!l(B ?') (?$B!m(B ?\") (?$B!o(B ?\\) (?$B!p(B ?$) (?$B!s(B ?%) (?$B!t(B ?#) (?$B!u(B ?&) (?$B!v(B ?*)
- (?$B!w(B ?@)
+ '((?\  ?\ ) (?, ?, ?、) (?. ?. ?。) (?、 ?, ?、) (?。 ?. ?。) (?・ nil ?・)
+ (?: ?:) (?; ?\;) (?? ??) (?! ?!) (?゛ nil ?゙) (?゜ nil ?゚)
+ (?´ ?') (?` ?`) (?^ ?^) (?_ ?_) (?ー ?- ?ー) (?— ?-) (?‐ ?-)
+ (?/ ?/) (?\ ?\\) (?〜 ?~) (?| ?|) (?‘ ?`) (?’ ?') (?“ ?\") (?” ?\")
+ (?\( ?\() (?\) ?\)) (?\[ ?\[) (?\] ?\]) (?\{ ?{) (?\} ?})
+ (?〈 ?<) (?〉 ?>) (?\「 nil ?\「) (?\」 nil ?\」)
+ (?+ ?+) (?− ?-) (?= ?=) (?< ?<) (?> ?>)
+ (?′ ?') (?″ ?\") (?¥ ?\\) (?$ ?$) (?% ?%) (?# ?#) (?& ?&) (?* ?*)
+ (?@ ?@)
;; cp932-2-byte
(#x2015 ?-) (#xFF5E ?~) (#xFF0D ?-))
"Japanese JISX0208 and CP932 symbol character table.
@@ -134,18 +132,18 @@ and HANKAKU belongs to `japanese-jisx0201-kana'.")
(put-char-code-property jisx0201 'jisx0208 jisx0208))))))
(defconst japanese-alpha-numeric-table
- '((?$B#0(B . ?0) (?$B#1(B . ?1) (?$B#2(B . ?2) (?$B#3(B . ?3) (?$B#4(B . ?4)
- (?$B#5(B . ?5) (?$B#6(B . ?6) (?$B#7(B . ?7) (?$B#8(B . ?8) (?$B#9(B . ?9)
- (?$B#A(B . ?A) (?$B#B(B . ?B) (?$B#C(B . ?C) (?$B#D(B . ?D) (?$B#E(B . ?E)
- (?$B#F(B . ?F) (?$B#G(B . ?G) (?$B#H(B . ?H) (?$B#I(B . ?I) (?$B#J(B . ?J)
- (?$B#K(B . ?K) (?$B#L(B . ?L) (?$B#M(B . ?M) (?$B#N(B . ?N) (?$B#O(B . ?O)
- (?$B#P(B . ?P) (?$B#Q(B . ?Q) (?$B#R(B . ?R) (?$B#S(B . ?S) (?$B#T(B . ?T)
- (?$B#U(B . ?U) (?$B#V(B . ?V) (?$B#W(B . ?W) (?$B#X(B . ?X) (?$B#Y(B . ?Y) (?$B#Z(B . ?Z)
- (?$B#a(B . ?a) (?$B#b(B . ?b) (?$B#c(B . ?c) (?$B#d(B . ?d) (?$B#e(B . ?e)
- (?$B#f(B . ?f) (?$B#g(B . ?g) (?$B#h(B . ?h) (?$B#i(B . ?i) (?$B#j(B . ?j)
- (?$B#k(B . ?k) (?$B#l(B . ?l) (?$B#m(B . ?m) (?$B#n(B . ?n) (?$B#o(B . ?o)
- (?$B#p(B . ?p) (?$B#q(B . ?q) (?$B#r(B . ?r) (?$B#s(B . ?s) (?$B#t(B . ?t)
- (?$B#u(B . ?u) (?$B#v(B . ?v) (?$B#w(B . ?w) (?$B#x(B . ?x) (?$B#y(B . ?y) (?$B#z(B . ?z))
+ '((?0 . ?0) (?1 . ?1) (?2 . ?2) (?3 . ?3) (?4 . ?4)
+ (?5 . ?5) (?6 . ?6) (?7 . ?7) (?8 . ?8) (?9 . ?9)
+ (?A . ?A) (?B . ?B) (?C . ?C) (?D . ?D) (?E . ?E)
+ (?F . ?F) (?G . ?G) (?H . ?H) (?I . ?I) (?J . ?J)
+ (?K . ?K) (?L . ?L) (?M . ?M) (?N . ?N) (?O . ?O)
+ (?P . ?P) (?Q . ?Q) (?R . ?R) (?S . ?S) (?T . ?T)
+ (?U . ?U) (?V . ?V) (?W . ?W) (?X . ?X) (?Y . ?Y) (?Z . ?Z)
+ (?a . ?a) (?b . ?b) (?c . ?c) (?d . ?d) (?e . ?e)
+ (?f . ?f) (?g . ?g) (?h . ?h) (?i . ?i) (?j . ?j)
+ (?k . ?k) (?l . ?l) (?m . ?m) (?n . ?n) (?o . ?o)
+ (?p . ?p) (?q . ?q) (?r . ?r) (?s . ?s) (?t . ?t)
+ (?u . ?u) (?v . ?v) (?w . ?w) (?x . ?x) (?y . ?y) (?z . ?z))
"Japanese JISX0208 alpha numeric character table.
Each element is of the form (ALPHA-NUMERIC . ASCII), where ALPHA-NUMERIC
belongs to `japanese-jisx0208', ASCII belongs to `ascii'.")
diff --git a/lisp/language/japanese.el b/lisp/language/japanese.el
index 9c41a26f36c..fabeab89c12 100644
--- a/lisp/language/japanese.el
+++ b/lisp/language/japanese.el
@@ -1,4 +1,4 @@
-;;; japanese.el --- support for Japanese -*- coding: iso-2022-7bit -*-
+;;; japanese.el --- support for Japanese
;; Copyright (C) 1997, 2001-2019 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -210,7 +210,7 @@ eucJP-ms is defined in <http://www.opengroup.or.jp/jvc/cde/appendix.html>."
iso-2022-jp-2)
(input-method . "japanese")
(features japan-util)
- (sample-text . "Japanese ($BF|K\8l(B) $B$3$s$K$A$O(B, (I:]FAJ(B")
+ (sample-text . "Japanese (日本語) こんにちは, コンニチハ")
(documentation . t)))
(let ((map
diff --git a/lisp/language/thai-util.el b/lisp/language/thai-util.el
index ee2cf7398ad..d0f664951e9 100644
--- a/lisp/language/thai-util.el
+++ b/lisp/language/thai-util.el
@@ -256,11 +256,10 @@ positions (integers or markers) specifying the region."
(define-minor-mode thai-word-mode
"Minor mode to make word-oriented commands aware of Thai words.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil. The commands affected are
-\\[forward-word], \\[backward-word], \\[kill-word], \\[backward-kill-word],
-\\[transpose-words], and \\[fill-paragraph]."
+
+The commands affected are \\[forward-word], \\[backward-word],
+\\[kill-word], \\[backward-kill-word], \\[transpose-words], and
+\\[fill-paragraph]."
:global t :group 'mule
(cond (thai-word-mode
;; This enables linebreak between Thai characters.
diff --git a/lisp/language/tibetan.el b/lisp/language/tibetan.el
index dac7a9519eb..4be25cecab9 100644
--- a/lisp/language/tibetan.el
+++ b/lisp/language/tibetan.el
@@ -451,7 +451,7 @@
;;; (includes some punctuation conversion rules)
;;;
(defconst tibetan-precomposition-rule-alist
- `(("ཕྱྭ" . "")
+ '(("ཕྱྭ" . "")
("གྲྭ" . "")
("ཚྭ" . "")
("རྩྭ" . "")
diff --git a/lisp/language/utf-8-lang.el b/lisp/language/utf-8-lang.el
index d31c1a8c5de..d4897c95964 100644
--- a/lisp/language/utf-8-lang.el
+++ b/lisp/language/utf-8-lang.el
@@ -25,24 +25,24 @@
;;; Code:
(set-language-info-alist
- "UTF-8" `((coding-system utf-8)
+ "UTF-8" '((coding-system utf-8)
(coding-priority utf-8)
(charset unicode-bmp unicode)
-;; Presumably not relevant now.
-;; (setup-function
-;; . (lambda ()
-;; ;; Use Unicode font under Windows. Jason Rumney fecit.
-;; (if (and (fboundp 'w32-add-charset-info)
-;; (not (boundp 'w32-unicode-charset-defined)))
-;; (w32-add-charset-info "iso10646-1" 'w32-charset-ansi t))))
-;; Is this appropriate?
-;; (exit-function
-;; . (lambda ()
-;; (if (and (fboundp 'w32-add-charset-info)
-;; (not (boundp 'w32-unicode-charset-defined)))
-;; (setq w32-charset-info-alist
-;; (delete (assoc "iso10646-1")
-;; w32-charset-info-alist)))))
+ ;; Presumably not relevant now.
+ ;; (setup-function
+ ;; . (lambda ()
+ ;; ;; Use Unicode font under Windows. Jason Rumney fecit.
+ ;; (if (and (fboundp 'w32-add-charset-info)
+ ;; (not (boundp 'w32-unicode-charset-defined)))
+ ;; (w32-add-charset-info "iso10646-1" 'w32-charset-ansi t))))
+ ;; Is this appropriate?
+ ;; (exit-function
+ ;; . (lambda ()
+ ;; (if (and (fboundp 'w32-add-charset-info)
+ ;; (not (boundp 'w32-unicode-charset-defined)))
+ ;; (setq w32-charset-info-alist
+ ;; (delete (assoc "iso10646-1")
+ ;; w32-charset-info-alist)))))
(input-method . "rfc1345") ; maybe not the best choice
(documentation . "\
This language environment is a generic one for the Unicode character set
diff --git a/lisp/language/vietnamese.el b/lisp/language/vietnamese.el
index bceefe04cc5..432dd3eb54e 100644
--- a/lisp/language/vietnamese.el
+++ b/lisp/language/vietnamese.el
@@ -72,9 +72,9 @@
(define-coding-system-alias 'viqr 'vietnamese-viqr)
(set-language-info-alist
- "Vietnamese" `((charset viscii)
+ "Vietnamese" '((charset viscii)
(coding-system vietnamese-viscii vietnamese-vscii
- vietnamese-tcvn vietnamese-viqr windows-1258)
+ vietnamese-tcvn vietnamese-viqr windows-1258)
(nonascii-translation . viscii)
(coding-priority vietnamese-viscii)
(input-method . "vietnamese-viqr")
diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el
index 3903463c8a1..ccf2cdc87e0 100644
--- a/lisp/ldefs-boot.el
+++ b/lisp/ldefs-boot.el
@@ -33,25 +33,17 @@ Quit current game \\[5x5-quit-game]
\(fn &optional SIZE)" t nil)
(autoload '5x5-crack-randomly "5x5" "\
-Attempt to crack 5x5 using random solutions.
-
-\(fn)" t nil)
+Attempt to crack 5x5 using random solutions." t nil)
(autoload '5x5-crack-mutating-current "5x5" "\
-Attempt to crack 5x5 by mutating the current solution.
-
-\(fn)" t nil)
+Attempt to crack 5x5 by mutating the current solution." t nil)
(autoload '5x5-crack-mutating-best "5x5" "\
-Attempt to crack 5x5 by mutating the best solution.
-
-\(fn)" t nil)
+Attempt to crack 5x5 by mutating the best solution." t nil)
(autoload '5x5-crack-xor-mutate "5x5" "\
Attempt to crack 5x5 by xoring the current and best solution.
-Mutate the result.
-
-\(fn)" t nil)
+Mutate the result." t nil)
(autoload '5x5-crack "5x5" "\
Attempt to find a solution for 5x5.
@@ -99,9 +91,7 @@ Ada mode is the major mode for editing Ada code.
;;; Generated autoloads from progmodes/ada-stmt.el
(autoload 'ada-header "ada-stmt" "\
-Insert a descriptive header at the top of the file.
-
-\(fn)" t nil)
+Insert a descriptive header at the top of the file." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ada-stmt" '("ada-")))
@@ -149,9 +139,7 @@ ChangeLog entry, one element will be chosen at random.")
(custom-autoload 'add-log-mailing-address "add-log" t)
(autoload 'prompt-for-change-log-name "add-log" "\
-Prompt for a change log name.
-
-\(fn)" nil nil)
+Prompt for a change log name." nil nil)
(autoload 'find-change-log "add-log" "\
Find a change log file for \\[add-change-log-entry] and return the name.
@@ -176,12 +164,18 @@ Optional arg BUFFER-FILE overrides `buffer-file-name'.
\(fn &optional FILE-NAME BUFFER-FILE)" nil nil)
(autoload 'add-change-log-entry "add-log" "\
-Find change log file, and add an entry for today and an item for this file.
-Optional arg WHOAMI (interactive prefix) non-nil means prompt for user
-name and email (stored in `add-log-full-name' and `add-log-mailing-address').
-
-Second arg FILE-NAME is file name of the change log.
-If nil, use the value of `change-log-default-name'.
+Find ChangeLog buffer, add an entry for today and an item for this file.
+Optional arg WHOAMI (interactive prefix) non-nil means prompt for
+user name and email (stored in `add-log-full-name'
+and `add-log-mailing-address').
+
+Second arg CHANGELOG-FILE-NAME is the file name of the change log.
+If nil, use the value of `change-log-default-name'. If the file
+thus named exists, it is used for the new entry. If it doesn't
+exist, it is created, unless `add-log-dont-create-changelog-file' is t,
+in which case a suitably named buffer that doesn't visit any file
+is used for keeping entries pertaining to CHANGELOG-FILE-NAME's
+directory.
Third arg OTHER-WINDOW non-nil means visit in other window.
@@ -204,7 +198,7 @@ notices.
Today's date is calculated according to `add-log-time-zone-rule' if
non-nil, otherwise in local time.
-\(fn &optional WHOAMI FILE-NAME OTHER-WINDOW NEW-ENTRY PUT-NEW-ENTRY-ON-NEW-LINE)" t nil)
+\(fn &optional WHOAMI CHANGELOG-FILE-NAME OTHER-WINDOW NEW-ENTRY PUT-NEW-ENTRY-ON-NEW-LINE)" t nil)
(autoload 'add-change-log-entry-other-window "add-log" "\
Find change log file in other window and add entry and item.
@@ -236,9 +230,7 @@ identifiers followed by `:' or `='. See variables
`add-log-current-defun-header-regexp' and
`add-log-current-defun-function'.
-Has a preference of looking backwards.
-
-\(fn)" nil nil)
+Has a preference of looking backwards." nil nil)
(autoload 'change-log-merge "add-log" "\
Merge the contents of change log file OTHER-LOG with this buffer.
@@ -251,7 +243,7 @@ old-style time formats for entries are supported.
\(fn OTHER-LOG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "add-log" '("change-log-" "add-log-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "add-log" '("add-log-" "change-log-")))
;;;***
@@ -484,16 +476,12 @@ to be colored.
\(fn BEG END TITLE &optional RULES EXCLUDE-RULES)" t nil)
(autoload 'align-unhighlight-rule "align" "\
-Remove any highlighting that was added by `align-highlight-rule'.
-
-\(fn)" t nil)
+Remove any highlighting that was added by `align-highlight-rule'." t nil)
(autoload 'align-newline-and-indent "align" "\
A replacement function for `newline-and-indent', aligning as it goes.
The alignment is done by calling `align' on the region that was
-indented.
-
-\(fn)" t nil)
+indented." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "align" '("align-")))
@@ -517,9 +505,7 @@ Establishes allout processing as part of visiting a file if
`allout-auto-activation' is non-nil, or removes it otherwise.
The proper way to use this is through customizing the setting of
-`allout-auto-activation'.
-
-\(fn)" nil nil)
+`allout-auto-activation'." nil nil)
(defvar allout-auto-activation nil "\
Configure allout outline mode auto-activation.
@@ -570,20 +556,16 @@ With value nil, inhibit any automatic allout-mode activation.")
(put 'allout-layout 'safe-local-variable (lambda (x) (or (numberp x) (listp x) (memq x '(: * + -)))))
-(put 'allout-passphrase-verifier-string 'safe-local-variable 'stringp)
-
-(put 'allout-passphrase-hint-string 'safe-local-variable 'stringp)
-
(autoload 'allout-mode-p "allout" "\
-Return t if `allout-mode' is active in current buffer.
-
-\(fn)" nil t)
+Return t if `allout-mode' is active in current buffer." nil t)
(autoload 'allout-mode "allout" "\
Toggle Allout outline mode.
-With a prefix argument ARG, enable Allout outline mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Allout mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
\\<allout-mode-map-value>
Allout outline mode is a minor mode that provides extensive
@@ -894,9 +876,11 @@ See `allout-widgets-mode' for allout widgets mode features.")
(autoload 'allout-widgets-mode "allout-widgets" "\
Toggle Allout Widgets mode.
-With a prefix argument ARG, enable Allout Widgets mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Allout-Widgets mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Allout Widgets mode is an extension of Allout mode that provides
graphical decoration of outline structure. It is meant to
@@ -941,7 +925,7 @@ directory, so that Emacs will know its current contents.
\(fn OPERATION &rest ARGS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ange-ftp" '("ange-ftp-" "internal-ange-ftp-mode" "ftp-error")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ange-ftp" '("ange-ftp-" "ftp-error" "internal-ange-ftp-mode")))
;;;***
@@ -984,9 +968,7 @@ the buffer *Birthday-Present-for-Name*.
(push (purecopy '(ansi-color 3 4 2)) package--builtin-versions)
(autoload 'ansi-color-for-comint-mode-on "ansi-color" "\
-Set `ansi-color-for-comint-mode' to t.
-
-\(fn)" t nil)
+Set `ansi-color-for-comint-mode' to t." t nil)
(autoload 'ansi-color-process-output "ansi-color" "\
Maybe translate SGR control sequences of comint output into text properties.
@@ -1027,9 +1009,7 @@ the rules.
If the file for a super-grammar cannot be determined, special file names
are used according to variable `antlr-unknown-file-formats' and a
commentary with value `antlr-help-unknown-file-text' is added. The
-*Help* buffer always starts with the text in `antlr-help-rules-intro'.
-
-\(fn)" t nil)
+*Help* buffer always starts with the text in `antlr-help-rules-intro'." t nil)
(autoload 'antlr-mode "antlr-mode" "\
Major mode for editing ANTLR grammar files.
@@ -1038,9 +1018,7 @@ Major mode for editing ANTLR grammar files.
(autoload 'antlr-set-tabs "antlr-mode" "\
Use ANTLR's convention for TABs according to `antlr-tab-offset-alist'.
-Used in `antlr-mode'. Also a useful function in `java-mode-hook'.
-
-\(fn)" nil nil)
+Used in `antlr-mode'. Also a useful function in `java-mode-hook'." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "antlr-mode" '("antlr-")))
@@ -1294,7 +1272,7 @@ Entering array mode calls the function `array-mode-hook'.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "array" '("array-" "untabify-backward" "move-to-column-untabify" "current-line" "xor" "limit-index")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "array" '("array-" "current-line" "limit-index" "move-to-column-untabify" "untabify-backward" "xor")))
;;;***
@@ -1304,7 +1282,12 @@ Entering array mode calls the function `array-mode-hook'.
(autoload 'artist-mode "artist" "\
Toggle Artist mode.
-With argument ARG, turn Artist mode on if ARG is positive.
+
+If called interactively, enable Artist mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
Artist lets you draw lines, squares, rectangles and poly-lines,
ellipses and circles with your mouse and/or keyboard.
@@ -1552,12 +1535,10 @@ let-binding.")
;;;### (autoloads nil "auth-source-pass" "auth-source-pass.el" (0
;;;;;; 0 0 0))
;;; Generated autoloads from auth-source-pass.el
-(push (purecopy '(auth-source-pass 2 0 0)) package--builtin-versions)
+(push (purecopy '(auth-source-pass 4 0 1)) package--builtin-versions)
(autoload 'auth-source-pass-enable "auth-source-pass" "\
-Enable auth-source-password-store.
-
-\(fn)" nil nil)
+Enable auth-source-password-store." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "auth-source-pass" '("auth-source-pass-")))
@@ -1575,9 +1556,6 @@ for a description of this minor mode.")
(autoload 'autoarg-mode "autoarg" "\
Toggle Autoarg mode, a global minor mode.
-With a prefix argument ARG, enable Autoarg mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
\\<autoarg-mode-map>
In Autoarg mode, digits are bound to `digit-argument', i.e. they
@@ -1611,9 +1589,11 @@ or call the function `autoarg-kp-mode'.")
(autoload 'autoarg-kp-mode "autoarg" "\
Toggle Autoarg-KP mode, a global minor mode.
-With a prefix argument ARG, enable Autoarg-KP mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Autoarg-Kp mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
\\<autoarg-kp-mode-map>
This is similar to `autoarg-mode' but rebinds the keypad keys
@@ -1644,9 +1624,7 @@ Major mode for editing Autoconf configure.ac files.
(autoload 'auto-insert "autoinsert" "\
Insert default contents into new files if variable `auto-insert' is non-nil.
-Matches the visited file name against the elements of `auto-insert-alist'.
-
-\(fn)" t nil)
+Matches the visited file name against the elements of `auto-insert-alist'." t nil)
(autoload 'define-auto-insert "autoinsert" "\
Associate CONDITION with (additional) ACTION in `auto-insert-alist'.
@@ -1667,9 +1645,11 @@ or call the function `auto-insert-mode'.")
(autoload 'auto-insert-mode "autoinsert" "\
Toggle Auto-insert mode, a global minor mode.
-With a prefix argument ARG, enable Auto-insert mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Auto-Insert mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
When Auto-insert mode is enabled, when new files are created you can
insert a template for the file depending on the mode of the buffer.
@@ -1726,11 +1706,9 @@ write its autoloads into the specified file instead.
Update loaddefs.el autoloads in batch mode.
Calls `update-directory-autoloads' on the command line arguments.
Definitions are written to `generated-autoload-file' (which
-should be non-nil).
-
-\(fn)" nil nil)
+should be non-nil)." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "autoload" '("autoload-" "generate" "no-update-autoloads" "make-autoload")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "autoload" '("autoload-" "generate" "make-autoload" "no-update-autoloads")))
;;;***
@@ -1739,9 +1717,11 @@ should be non-nil).
(autoload 'auto-revert-mode "autorevert" "\
Toggle reverting buffer when the file changes (Auto-Revert Mode).
-With a prefix argument ARG, enable Auto-Revert Mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Auto-Revert mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Auto-Revert Mode is a minor mode that affects only the current
buffer. When enabled, it reverts the buffer when the file on
@@ -1760,15 +1740,15 @@ without being changed in the part that is already in the buffer.
Turn on Auto-Revert Mode.
This function is designed to be added to hooks, for example:
- (add-hook \\='c-mode-hook #\\='turn-on-auto-revert-mode)
-
-\(fn)" nil nil)
+ (add-hook \\='c-mode-hook #\\='turn-on-auto-revert-mode)" nil nil)
(autoload 'auto-revert-tail-mode "autorevert" "\
Toggle reverting tail of buffer when the file grows.
-With a prefix argument ARG, enable Auto-Revert Tail Mode if ARG
-is positive, and disable it otherwise. If called from Lisp,
-enable the mode if ARG is omitted or nil.
+
+If called interactively, enable Auto-Revert-Tail mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
When Auto-Revert Tail Mode is enabled, the tail of the file is
constantly followed, as with the shell command `tail -f'. This
@@ -1791,9 +1771,7 @@ Use `auto-revert-mode' for changes other than appends!
Turn on Auto-Revert Tail Mode.
This function is designed to be added to hooks, for example:
- (add-hook \\='my-logfile-mode-hook #\\='turn-on-auto-revert-tail-mode)
-
-\(fn)" nil nil)
+ (add-hook \\='my-logfile-mode-hook #\\='turn-on-auto-revert-tail-mode)" nil nil)
(defvar global-auto-revert-mode nil "\
Non-nil if Global Auto-Revert mode is enabled.
@@ -1807,9 +1785,11 @@ or call the function `global-auto-revert-mode'.")
(autoload 'global-auto-revert-mode "autorevert" "\
Toggle Global Auto-Revert Mode.
-With a prefix argument ARG, enable Global Auto-Revert Mode if ARG
-is positive, and disable it otherwise. If called from Lisp,
-enable the mode if ARG is omitted or nil.
+
+If called interactively, enable Global Auto-Revert mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Global Auto-Revert Mode is a global minor mode that reverts any
buffer associated with a file when the file changes on disk. Use
@@ -1882,6 +1862,19 @@ definition of \"random distance\".)
;;;***
+;;;### (autoloads nil "backtrace" "emacs-lisp/backtrace.el" (0 0
+;;;;;; 0 0))
+;;; Generated autoloads from emacs-lisp/backtrace.el
+(push (purecopy '(backtrace 1 0)) package--builtin-versions)
+
+(autoload 'backtrace "backtrace" "\
+Print a trace of Lisp function calls currently active.
+Output stream used is value of `standard-output'." nil nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "backtrace" '("backtrace-")))
+
+;;;***
+
;;;### (autoloads nil "bat-mode" "progmodes/bat-mode.el" (0 0 0 0))
;;; Generated autoloads from progmodes/bat-mode.el
@@ -1909,9 +1902,7 @@ Run script using `bat-run' and `bat-run-args'.
(autoload 'battery "battery" "\
Display battery status information in the echo area.
The text being displayed in the echo area is controlled by the variables
-`battery-echo-area-format' and `battery-status-function'.
-
-\(fn)" t nil)
+`battery-echo-area-format' and `battery-status-function'." t nil)
(defvar display-battery-mode nil "\
Non-nil if Display-Battery mode is enabled.
@@ -1925,9 +1916,11 @@ or call the function `display-battery-mode'.")
(autoload 'display-battery-mode "battery" "\
Toggle battery status display in mode line (Display Battery mode).
-With a prefix argument ARG, enable Display Battery mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Display-Battery mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
The text displayed in the mode line is controlled by
`battery-mode-line-format' and `battery-status-function'.
@@ -1983,7 +1976,7 @@ For non-interactive use see also `benchmark-run' and
;;;### (autoloads nil "bib-mode" "textmodes/bib-mode.el" (0 0 0 0))
;;; Generated autoloads from textmodes/bib-mode.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bib-mode" '("bib-" "unread-bib" "mark-bib" "return-key-bib" "addbib")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bib-mode" '("addbib" "bib-" "mark-bib" "return-key-bib" "unread-bib")))
;;;***
@@ -2243,7 +2236,7 @@ a reflection.
\(fn NUM)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "blackbox" '("blackbox-" "bb-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "blackbox" '("bb-" "blackbox-")))
;;;***
@@ -2254,7 +2247,7 @@ a reflection.
(define-key ctl-x-r-map "M" 'bookmark-set-no-overwrite)
(define-key ctl-x-r-map "l" 'bookmark-bmenu-list)
-(defvar bookmark-map (let ((map (make-sparse-keymap))) (define-key map "x" 'bookmark-set) (define-key map "m" 'bookmark-set) (define-key map "M" 'bookmark-set-no-overwrite) (define-key map "j" 'bookmark-jump) (define-key map "g" 'bookmark-jump) (define-key map "o" 'bookmark-jump-other-window) (define-key map "i" 'bookmark-insert) (define-key map "e" 'edit-bookmarks) (define-key map "f" 'bookmark-insert-location) (define-key map "r" 'bookmark-rename) (define-key map "d" 'bookmark-delete) (define-key map "l" 'bookmark-load) (define-key map "w" 'bookmark-write) (define-key map "s" 'bookmark-save) map) "\
+(defvar bookmark-map (let ((map (make-sparse-keymap))) (define-key map "x" 'bookmark-set) (define-key map "m" 'bookmark-set) (define-key map "M" 'bookmark-set-no-overwrite) (define-key map "j" 'bookmark-jump) (define-key map "g" 'bookmark-jump) (define-key map "o" 'bookmark-jump-other-window) (define-key map "5" 'bookmark-jump-other-frame) (define-key map "i" 'bookmark-insert) (define-key map "e" 'edit-bookmarks) (define-key map "f" 'bookmark-insert-location) (define-key map "r" 'bookmark-rename) (define-key map "d" 'bookmark-delete) (define-key map "l" 'bookmark-load) (define-key map "w" 'bookmark-write) (define-key map "s" 'bookmark-save) map) "\
Keymap containing bindings to bookmark functions.
It is not bound to any key by default: to bind it
so that you have a bookmark prefix, just use `global-set-key' and bind a
@@ -2345,6 +2338,11 @@ Jump to BOOKMARK in another window. See `bookmark-jump' for more.
\(fn BOOKMARK)" t nil)
+(autoload 'bookmark-jump-other-frame "bookmark" "\
+Jump to BOOKMARK in another frame. See `bookmark-jump' for more.
+
+\(fn BOOKMARK)" t nil)
+
(autoload 'bookmark-relocate "bookmark" "\
Relocate BOOKMARK-NAME to another file, reading file name with minibuffer.
@@ -2403,9 +2401,7 @@ probably because we were called from there.
\(fn BOOKMARK-NAME &optional BATCH)" t nil)
(autoload 'bookmark-write "bookmark" "\
-Write bookmarks to a file (reading the file name with the minibuffer).
-
-\(fn)" t nil)
+Write bookmarks to a file (reading the file name with the minibuffer)." t nil)
(function-put 'bookmark-write 'interactive-only 'bookmark-save)
@@ -2452,18 +2448,14 @@ unique numeric suffixes \"<2>\", \"<3>\", etc.
Display a list of existing bookmarks.
The list is displayed in a buffer named `*Bookmark List*'.
The leftmost column displays a D if the bookmark is flagged for
-deletion, or > if it is flagged for displaying.
-
-\(fn)" t nil)
+deletion, or > if it is flagged for displaying." t nil)
(defalias 'list-bookmarks 'bookmark-bmenu-list)
(defalias 'edit-bookmarks 'bookmark-bmenu-list)
(autoload 'bookmark-bmenu-search "bookmark" "\
-Incremental search of bookmarks, hiding the non-matches as we go.
-
-\(fn)" t nil)
+Incremental search of bookmarks, hiding the non-matches as we go." t nil)
(defvar menu-bar-bookmark-map (let ((map (make-sparse-keymap "Bookmark functions"))) (bindings--define-key map [load] '(menu-item "Load a Bookmark File..." bookmark-load :help "Load bookmarks from a bookmark file)")) (bindings--define-key map [write] '(menu-item "Save Bookmarks As..." bookmark-write :help "Write bookmarks to a file (reading the file name with the minibuffer)")) (bindings--define-key map [save] '(menu-item "Save Bookmarks" bookmark-save :help "Save currently defined bookmarks")) (bindings--define-key map [edit] '(menu-item "Edit Bookmark List" bookmark-bmenu-list :help "Display a list of existing bookmarks")) (bindings--define-key map [delete] '(menu-item "Delete Bookmark..." bookmark-delete :help "Delete a bookmark from the bookmark list")) (bindings--define-key map [rename] '(menu-item "Rename Bookmark..." bookmark-rename :help "Change the name of a bookmark")) (bindings--define-key map [locate] '(menu-item "Insert Location..." bookmark-locate :help "Insert the name of the file associated with a bookmark")) (bindings--define-key map [insert] '(menu-item "Insert Contents..." bookmark-insert :help "Insert the text of the file pointed to by a bookmark")) (bindings--define-key map [set] '(menu-item "Set Bookmark..." bookmark-set :help "Set a bookmark named inside a file.")) (bindings--define-key map [jump] '(menu-item "Jump to Bookmark..." bookmark-jump :help "Jump to a bookmark (a point in some file)")) map))
@@ -2507,9 +2499,7 @@ narrowed.
\(fn &optional BUFFER)" t nil)
(autoload 'browse-url-of-dired-file "browse-url" "\
-In Dired, ask a WWW browser to display the file named on this line.
-
-\(fn)" t nil)
+In Dired, ask a WWW browser to display the file named on this line." t nil)
(autoload 'browse-url-of-region "browse-url" "\
Ask a WWW browser to display the current region.
@@ -2646,8 +2636,10 @@ used instead of `browse-url-new-window-flag'.
(autoload 'browse-url-emacs "browse-url" "\
Ask Emacs to load URL into a buffer and show it in another window.
+Optional argument SAME-WINDOW non-nil means show the URL in the
+currently selected window instead.
-\(fn URL &optional NEW-WINDOW)" t nil)
+\(fn URL &optional SAME-WINDOW)" t nil)
(autoload 'browse-url-gnome-moz "browse-url" "\
Ask Mozilla/Netscape to load URL via the GNOME program `gnome-moz-remote'.
@@ -2830,21 +2822,15 @@ from `browse-url-elinks-wrapper'.
(autoload 'bs-cycle-next "bs" "\
Select next buffer defined by buffer cycling.
The buffers taking part in buffer cycling are defined
-by buffer configuration `bs-cycle-configuration-name'.
-
-\(fn)" t nil)
+by buffer configuration `bs-cycle-configuration-name'." t nil)
(autoload 'bs-cycle-previous "bs" "\
Select previous buffer defined by buffer cycling.
The buffers taking part in buffer cycling are defined
-by buffer configuration `bs-cycle-configuration-name'.
-
-\(fn)" t nil)
+by buffer configuration `bs-cycle-configuration-name'." t nil)
(autoload 'bs-customize "bs" "\
-Customization of group bs for Buffer Selection Menu.
-
-\(fn)" t nil)
+Customization of group bs for Buffer Selection Menu." t nil)
(autoload 'bs-show "bs" "\
Make a menu of buffers so you can manipulate buffers or the buffer list.
@@ -2881,9 +2867,7 @@ columns on its right towards the left.
\\[bubbles-set-game-easy] sets the difficulty to easy.
\\[bubbles-set-game-medium] sets the difficulty to medium.
\\[bubbles-set-game-difficult] sets the difficulty to difficult.
-\\[bubbles-set-game-hard] sets the difficulty to hard.
-
-\(fn)" t nil)
+\\[bubbles-set-game-hard] sets the difficulty to hard." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bubbles" '("bubbles-")))
@@ -2899,15 +2883,22 @@ columns on its right towards the left.
(autoload 'bug-reference-mode "bug-reference" "\
Toggle hyperlinking bug references in the buffer (Bug Reference mode).
-With a prefix argument ARG, enable Bug Reference mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Bug-Reference mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
\(fn &optional ARG)" t nil)
(autoload 'bug-reference-prog-mode "bug-reference" "\
Like `bug-reference-mode', but only buttonize in comments and strings.
+If called interactively, enable Bug-Reference-Prog mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
\(fn &optional ARG)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bug-reference" '("bug-reference-")))
@@ -3016,9 +3007,7 @@ invoked interactively.
(autoload 'batch-byte-compile-if-not-done "bytecomp" "\
Like `byte-compile-file' but doesn't recompile if already up to date.
Use this from the command line, with `-batch';
-it won't work in an interactive Emacs.
-
-\(fn)" nil nil)
+it won't work in an interactive Emacs." nil nil)
(autoload 'batch-byte-compile "bytecomp" "\
Run `byte-compile-file' on the files remaining on the command line.
@@ -3042,7 +3031,7 @@ and corresponding effects.
\(fn &optional ARG)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bytecomp" '("batch-byte-compile-file" "byte-" "no-byte-compile" "displaying-byte-compile-warnings" "emacs-lisp-file-regexp")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bytecomp" '("batch-byte-compile-file" "byte-" "displaying-byte-compile-warnings" "emacs-lisp-" "no-byte-compile")))
;;;***
@@ -3050,7 +3039,7 @@ and corresponding effects.
;;;;;; 0))
;;; Generated autoloads from calendar/cal-bahai.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-bahai" '("diary-bahai-" "calendar-bahai-" "holiday-bahai")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-bahai" '("calendar-bahai-" "diary-bahai-" "holiday-bahai")))
;;;***
@@ -3060,7 +3049,7 @@ and corresponding effects.
(put 'calendar-chinese-time-zone 'risky-local-variable t)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-china" '("diary-chinese-" "calendar-chinese-" "holiday-chinese")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-china" '("calendar-chinese-" "diary-chinese-" "holiday-chinese")))
;;;***
@@ -3068,7 +3057,7 @@ and corresponding effects.
;;;;;; 0 0))
;;; Generated autoloads from calendar/cal-coptic.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-coptic" '("diary-" "calendar-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-coptic" '("calendar-" "diary-")))
;;;***
@@ -3081,7 +3070,7 @@ and corresponding effects.
(put 'calendar-current-time-zone-cache 'risky-local-variable t)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-dst" '("dst-" "calendar-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-dst" '("calendar-" "dst-")))
;;;***
@@ -3089,7 +3078,7 @@ and corresponding effects.
;;;;;; 0 0))
;;; Generated autoloads from calendar/cal-french.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-french" '("diary-french-date" "calendar-french-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-french" '("calendar-french-" "diary-french-date")))
;;;***
@@ -3104,7 +3093,7 @@ from the cursor position.
\(fn DEATH-DATE START-YEAR END-YEAR)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-hebrew" '("diary-hebrew-" "calendar-hebrew-" "holiday-hebrew")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-hebrew" '("calendar-hebrew-" "diary-hebrew-" "holiday-hebrew")))
;;;***
@@ -3119,14 +3108,14 @@ from the cursor position.
;;;;;; 0))
;;; Generated autoloads from calendar/cal-islam.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-islam" '("diary-islamic-" "calendar-islamic-" "holiday-islamic")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-islam" '("calendar-islamic-" "diary-islamic-" "holiday-islamic")))
;;;***
;;;### (autoloads nil "cal-iso" "calendar/cal-iso.el" (0 0 0 0))
;;; Generated autoloads from calendar/cal-iso.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-iso" '("diary-iso-date" "calendar-iso-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-iso" '("calendar-iso-" "diary-iso-date")))
;;;***
@@ -3134,7 +3123,7 @@ from the cursor position.
;;;;;; 0 0))
;;; Generated autoloads from calendar/cal-julian.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-julian" '("diary-" "calendar-" "holiday-julian")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-julian" '("calendar-" "diary-" "holiday-julian")))
;;;***
@@ -3142,7 +3131,7 @@ from the cursor position.
;;;;;; 0))
;;; Generated autoloads from calendar/cal-mayan.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-mayan" '("diary-mayan-date" "calendar-mayan-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-mayan" '("calendar-mayan-" "diary-mayan-date")))
;;;***
@@ -3164,7 +3153,7 @@ from the cursor position.
;;;;;; 0 0))
;;; Generated autoloads from calendar/cal-persia.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-persia" '("diary-persian-date" "calendar-persian-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-persia" '("calendar-persian-" "diary-persian-date")))
;;;***
@@ -3266,7 +3255,7 @@ See Info node `(calc)Defining Functions'.
(function-put 'defmath 'doc-string-elt '3)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc" '("math-" "calc" "var-" "inexact-result" "defcalcmodevar")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc" '("calc" "defcalcmodevar" "inexact-result" "math-" "var-")))
;;;***
@@ -3274,35 +3263,35 @@ See Info node `(calc)Defining Functions'.
;;;;;; (0 0 0 0))
;;; Generated autoloads from calc/calc-aent.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-aent" '("math-" "calc")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-aent" '("calc" "math-")))
;;;***
;;;### (autoloads nil "calc-alg" "calc/calc-alg.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-alg.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-alg" '("math-" "calc")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-alg" '("calc" "math-")))
;;;***
;;;### (autoloads nil "calc-arith" "calc/calc-arith.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-arith.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-arith" '("math-" "calc")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-arith" '("calc" "math-")))
;;;***
;;;### (autoloads nil "calc-bin" "calc/calc-bin.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-bin.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-bin" '("math-" "calc")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-bin" '("calc" "math-")))
;;;***
;;;### (autoloads nil "calc-comb" "calc/calc-comb.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-comb.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-comb" '("math-" "calc")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-comb" '("calc" "math-")))
;;;***
@@ -3338,7 +3327,7 @@ See Info node `(calc)Defining Functions'.
;;;### (autoloads nil "calc-forms" "calc/calc-forms.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-forms.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-forms" '("math-" "calc" "var-TimeZone")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-forms" '("calc" "math-" "var-TimeZone")))
;;;***
@@ -3387,7 +3376,7 @@ See Info node `(calc)Defining Functions'.
;;;### (autoloads nil "calc-lang" "calc/calc-lang.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-lang.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-lang" '("math-" "calc-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-lang" '("calc-" "math-")))
;;;***
@@ -3401,7 +3390,7 @@ See Info node `(calc)Defining Functions'.
;;;### (autoloads nil "calc-map" "calc/calc-map.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-map.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-map" '("math-" "calc")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-map" '("calc" "math-")))
;;;***
@@ -3458,14 +3447,14 @@ See Info node `(calc)Defining Functions'.
;;;### (autoloads nil "calc-prog" "calc/calc-prog.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-prog.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-prog" '("math-" "calc" "var-q")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-prog" '("calc" "math-" "var-q")))
;;;***
;;;### (autoloads nil "calc-rewr" "calc/calc-rewr.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-rewr.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-rewr" '("math-" "calc")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-rewr" '("calc" "math-")))
;;;***
@@ -3486,7 +3475,7 @@ See Info node `(calc)Defining Functions'.
;;;### (autoloads nil "calc-stat" "calc/calc-stat.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-stat.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-stat" '("math-" "calc")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-stat" '("calc" "math-")))
;;;***
@@ -3500,7 +3489,7 @@ See Info node `(calc)Defining Functions'.
;;;### (autoloads nil "calc-stuff" "calc/calc-stuff.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-stuff.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-stuff" '("math-" "calc")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-stuff" '("calc" "math-")))
;;;***
@@ -3533,7 +3522,7 @@ See Info node `(calc)Defining Functions'.
;;;### (autoloads nil "calc-vec" "calc/calc-vec.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-vec.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-vec" '("math-" "calc")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-vec" '("calc" "math-")))
;;;***
@@ -3555,14 +3544,14 @@ See Info node `(calc)Defining Functions'.
;;;### (autoloads nil "calcalg3" "calc/calcalg3.el" (0 0 0 0))
;;; Generated autoloads from calc/calcalg3.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calcalg3" '("math-" "calc")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calcalg3" '("calc" "math-")))
;;;***
;;;### (autoloads nil "calccomp" "calc/calccomp.el" (0 0 0 0))
;;; Generated autoloads from calc/calccomp.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calccomp" '("math-" "calcFunc-c")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calccomp" '("calcFunc-c" "math-")))
;;;***
@@ -3578,9 +3567,7 @@ See Info node `(calc)Defining Functions'.
(autoload 'calculator "calculator" "\
Run the Emacs calculator.
-See the documentation for `calculator-mode' for more information.
-
-\(fn)" t nil)
+See the documentation for `calculator-mode' for more information." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calculator" '("calculator-")))
@@ -3626,7 +3613,7 @@ This function is suitable for execution in an init file.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calendar" '("calendar-" "solar-sunrises-buffer" "lunar-phases-buffer" "diary-" "holiday-buffer")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calendar" '("calendar-" "diary-" "holiday-buffer" "lunar-phases-buffer" "solar-sunrises-buffer")))
;;;***
@@ -3659,7 +3646,7 @@ it fails.
;;;### (autoloads nil "cc-awk" "progmodes/cc-awk.el" (0 0 0 0))
;;; Generated autoloads from progmodes/cc-awk.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-awk" '("c-awk-" "awk-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-awk" '("awk-" "c-awk-")))
;;;***
@@ -3681,7 +3668,7 @@ it fails.
;;;### (autoloads nil "cc-defs" "progmodes/cc-defs.el" (0 0 0 0))
;;; Generated autoloads from progmodes/cc-defs.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-defs" '("cc-bytecomp-compiling-or-loading" "c-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-defs" '("c-" "cc-bytecomp-compiling-or-loading")))
;;;***
@@ -3690,9 +3677,7 @@ it fails.
;;; Generated autoloads from progmodes/cc-engine.el
(autoload 'c-guess-basic-syntax "cc-engine" "\
-Return the syntactic context of the current line.
-
-\(fn)" nil nil)
+Return the syntactic context of the current line." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-engine" '("c-")))
@@ -3701,7 +3686,7 @@ Return the syntactic context of the current line.
;;;### (autoloads nil "cc-fonts" "progmodes/cc-fonts.el" (0 0 0 0))
;;; Generated autoloads from progmodes/cc-fonts.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-fonts" '("autodoc-" "java" "gtkdoc-font-lock-" "c++-font-lock-keywords" "c-" "pike-font-lock-keywords" "idl-font-lock-keywords" "objc-font-lock-keywords")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-fonts" '("autodoc-" "c++-font-lock-keywords" "c-" "gtkdoc-font-lock-" "idl-font-lock-keywords" "java" "objc-font-lock-keywords" "pike-font-lock-keywords")))
;;;***
@@ -3821,6 +3806,7 @@ the absolute file name of the file if STYLE-NAME is nil.
;;;### (autoloads nil "cc-mode" "progmodes/cc-mode.el" (0 0 0 0))
;;; Generated autoloads from progmodes/cc-mode.el
+(push (purecopy '(cc-mode 5 33 1)) package--builtin-versions)
(autoload 'c-initialize-cc-mode "cc-mode" "\
Initialize CC Mode for use in the current buffer.
@@ -3869,9 +3855,7 @@ should be used.
This function attempts to use file contents to determine whether
the code is C or C++ and based on that chooses whether to enable
-`c-mode' or `c++-mode'.
-
-\(fn)" nil nil)
+`c-mode' or `c++-mode'." nil nil)
(autoload 'c++-mode "cc-mode" "\
Major mode for editing C++ code.
@@ -3990,7 +3974,7 @@ Key bindings:
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-mode" '("c++-mode-" "c-" "awk-mode-map" "pike-mode-" "idl-mode-" "java-mode-" "objc-mode-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-mode" '("awk-mode-map" "c++-mode-" "c-" "idl-mode-" "java-mode-" "objc-mode-" "pike-mode-")))
;;;***
@@ -4054,7 +4038,7 @@ and exists only for compatibility reasons.
(put 'c-backslash-column 'safe-local-variable 'integerp)
(put 'c-file-style 'safe-local-variable 'string-or-null-p)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-vars" '("c++-" "c-" "pike-" "idl-" "java-" "objc-" "awk-mode-hook" "defcustom-c-stylevar")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-vars" '("awk-mode-hook" "c++-" "c-" "defcustom-c-stylevar" "idl-" "java-" "objc-" "pike-")))
;;;***
@@ -4444,9 +4428,7 @@ to the action header.
\(fn)" t nil)
(autoload 'cfengine-auto-mode "cfengine" "\
-Choose `cfengine2-mode' or `cfengine3-mode' by buffer contents.
-
-\(fn)" t nil)
+Choose `cfengine2-mode' or `cfengine3-mode' by buffer contents." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cfengine" '("cfengine")))
@@ -4524,9 +4506,7 @@ Return t when OBJ is a list of strings.
(autoload 'checkdoc "checkdoc" "\
Interactively check the entire buffer for style errors.
The current status of the check will be displayed in a buffer which
-the users will view as each check is completed.
-
-\(fn)" t nil)
+the users will view as each check is completed." t nil)
(autoload 'checkdoc-interactive "checkdoc" "\
Interactively check the current buffer for doc string errors.
@@ -4554,9 +4534,7 @@ checkdoc status window instead of the usual behavior.
Evaluate and check documentation for the current buffer.
Evaluation is done first because good documentation for something that
doesn't work is just not useful. Comments, doc strings, and rogue
-spacing are all verified.
-
-\(fn)" t nil)
+spacing are all verified." t nil)
(autoload 'checkdoc-current-buffer "checkdoc" "\
Check current buffer for document, comment, error style, and rogue spaces.
@@ -4614,9 +4592,7 @@ Optional argument TAKE-NOTES causes all errors to be logged.
Evaluate the current form with `eval-defun' and check its documentation.
Evaluation is done first so the form will be read before the
documentation is checked. If there is a documentation error, then the display
-of what was evaluated will be overwritten by the diagnostic message.
-
-\(fn)" t nil)
+of what was evaluated will be overwritten by the diagnostic message." t nil)
(autoload 'checkdoc-defun "checkdoc" "\
Examine the doc string of the function or variable under point.
@@ -4630,71 +4606,55 @@ space at the end of each line.
(autoload 'checkdoc-ispell "checkdoc" "\
Check the style and spelling of everything interactively.
Calls `checkdoc' with spell-checking turned on.
-Prefix argument is the same as for `checkdoc'
-
-\(fn)" t nil)
+Prefix argument is the same as for `checkdoc'" t nil)
(autoload 'checkdoc-ispell-current-buffer "checkdoc" "\
Check the style and spelling of the current buffer.
Calls `checkdoc-current-buffer' with spell-checking turned on.
-Prefix argument is the same as for `checkdoc-current-buffer'
-
-\(fn)" t nil)
+Prefix argument is the same as for `checkdoc-current-buffer'" t nil)
(autoload 'checkdoc-ispell-interactive "checkdoc" "\
Check the style and spelling of the current buffer interactively.
Calls `checkdoc-interactive' with spell-checking turned on.
-Prefix argument is the same as for `checkdoc-interactive'
-
-\(fn)" t nil)
+Prefix argument is the same as for `checkdoc-interactive'" t nil)
(autoload 'checkdoc-ispell-message-interactive "checkdoc" "\
Check the style and spelling of message text interactively.
Calls `checkdoc-message-interactive' with spell-checking turned on.
-Prefix argument is the same as for `checkdoc-message-interactive'
-
-\(fn)" t nil)
+Prefix argument is the same as for `checkdoc-message-interactive'" t nil)
(autoload 'checkdoc-ispell-message-text "checkdoc" "\
Check the style and spelling of message text interactively.
Calls `checkdoc-message-text' with spell-checking turned on.
-Prefix argument is the same as for `checkdoc-message-text'
-
-\(fn)" t nil)
+Prefix argument is the same as for `checkdoc-message-text'" t nil)
(autoload 'checkdoc-ispell-start "checkdoc" "\
Check the style and spelling of the current buffer.
Calls `checkdoc-start' with spell-checking turned on.
-Prefix argument is the same as for `checkdoc-start'
-
-\(fn)" t nil)
+Prefix argument is the same as for `checkdoc-start'" t nil)
(autoload 'checkdoc-ispell-continue "checkdoc" "\
Check the style and spelling of the current buffer after point.
Calls `checkdoc-continue' with spell-checking turned on.
-Prefix argument is the same as for `checkdoc-continue'
-
-\(fn)" t nil)
+Prefix argument is the same as for `checkdoc-continue'" t nil)
(autoload 'checkdoc-ispell-comments "checkdoc" "\
Check the style and spelling of the current buffer's comments.
Calls `checkdoc-comments' with spell-checking turned on.
-Prefix argument is the same as for `checkdoc-comments'
-
-\(fn)" t nil)
+Prefix argument is the same as for `checkdoc-comments'" t nil)
(autoload 'checkdoc-ispell-defun "checkdoc" "\
Check the style and spelling of the current defun with Ispell.
Calls `checkdoc-defun' with spell-checking turned on.
-Prefix argument is the same as for `checkdoc-defun'
-
-\(fn)" t nil)
+Prefix argument is the same as for `checkdoc-defun'" t nil)
(autoload 'checkdoc-minor-mode "checkdoc" "\
Toggle automatic docstring checking (Checkdoc minor mode).
-With a prefix argument ARG, enable Checkdoc minor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Checkdoc minor mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
In Checkdoc minor mode, the usual bindings for `eval-defun' which is
bound to \\<checkdoc-minor-mode-map>\\[checkdoc-eval-defun] and `checkdoc-eval-current-buffer' are overridden to include
@@ -4705,9 +4665,7 @@ checking of documentation strings.
\(fn &optional ARG)" t nil)
(autoload 'checkdoc-package-keywords "checkdoc" "\
-Find package keywords that aren't in `finder-known-keywords'.
-
-\(fn)" t nil)
+Find package keywords that aren't in `finder-known-keywords'." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "checkdoc" '("checkdoc-")))
@@ -4724,9 +4682,7 @@ Return the length of resulting text.
\(fn BEG END)" t nil)
(autoload 'decode-hz-buffer "china-util" "\
-Decode HZ/ZW encoded text in the current buffer.
-
-\(fn)" t nil)
+Decode HZ/ZW encoded text in the current buffer." t nil)
(autoload 'encode-hz-region "china-util" "\
Encode the text in the current region to HZ.
@@ -4735,9 +4691,7 @@ Return the length of resulting text.
\(fn BEG END)" t nil)
(autoload 'encode-hz-buffer "china-util" "\
-Encode the text in the current buffer to HZ.
-
-\(fn)" t nil)
+Encode the text in the current buffer to HZ." t nil)
(autoload 'post-read-decode-hz "china-util" "\
@@ -4749,7 +4703,7 @@ Encode the text in the current buffer to HZ.
\(fn FROM TO)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "china-util" '("hz/zw-start-gb" "hz-" "decode-hz-line-continuation" "zw-start-gb" "iso2022-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "china-util" '("decode-hz-line-continuation" "hz-" "hz/zw-start-gb" "iso2022-" "zw-start-gb")))
;;;***
@@ -4771,9 +4725,7 @@ The number of commands listed is controlled by `list-command-history-max'.
Calls value of `list-command-history-filter' (if non-nil) on each history
element to judge if that element should be excluded from the list.
-The buffer is left in Command History mode.
-
-\(fn)" t nil)
+The buffer is left in Command History mode." t nil)
(autoload 'command-history "chistory" "\
Examine commands from `command-history' in a buffer.
@@ -4786,18 +4738,16 @@ and digits provide prefix arguments. Tab does not indent.
\\{command-history-map}
This command always recompiles the Command History listing
-and runs the normal hook `command-history-hook'.
+and runs the normal hook `command-history-hook'." t nil)
-\(fn)" t nil)
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "chistory" '("command-history-" "list-command-history-" "default-command-history-filter")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "chistory" '("command-history-" "default-command-history-filter" "list-command-history-")))
;;;***
;;;### (autoloads nil "cl" "emacs-lisp/cl.el" (0 0 0 0))
;;; Generated autoloads from emacs-lisp/cl.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl" '("cl-" "defsetf" "define-" "lexical-let" "labels" "flet")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl" '("cl-" "define-" "defsetf" "flet" "labels" "lexical-let")))
;;;***
@@ -4898,7 +4848,7 @@ instead.
\(fn INDENT-POINT STATE)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl-indent" '("lisp-" "common-lisp-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl-indent" '("common-lisp-" "lisp-")))
;;;***
@@ -4934,6 +4884,11 @@ This can be needed when using code byte-compiled using the old
macro-expansion of `cl-defstruct' that used vectors objects instead
of record objects.
+If called interactively, enable Cl-Old-Struct-Compat mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
\(fn &optional ARG)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl-lib" '("cl-")))
@@ -4961,6 +4916,13 @@ call other entry points instead, such as `cl-prin1'.
\(fn OBJECT STREAM)" nil nil)
+(autoload 'cl-print-expand-ellipsis "cl-print" "\
+Print the expansion of an ellipsis to STREAM.
+VALUE should be the value of the `cl-print-ellipsis' text property
+which was attached to the ellipsis by `cl-prin1'.
+
+\(fn VALUE STREAM)" nil nil)
+
(autoload 'cl-prin1 "cl-print" "\
Print OBJECT on STREAM according to its type.
Output is further controlled by the variables
@@ -4975,6 +4937,24 @@ Return a string containing the `cl-prin1'-printed representation of OBJECT.
\(fn OBJECT)" nil nil)
+(autoload 'cl-print-to-string-with-limit "cl-print" "\
+Return a string containing a printed representation of VALUE.
+Attempt to get the length of the returned string under LIMIT
+characters with appropriate settings of `print-level' and
+`print-length.' Use PRINT-FUNCTION to print, which should take
+the arguments VALUE and STREAM and which should respect
+`print-length' and `print-level'. LIMIT may be nil or zero in
+which case PRINT-FUNCTION will be called with `print-level' and
+`print-length' bound to nil.
+
+Use this function with `cl-prin1' to print an object,
+abbreviating it with ellipses to fit within a size limit. Use
+this function with `cl-prin1-expand-ellipsis' to expand an
+ellipsis, abbreviating the expansion to stay within a size
+limit.
+
+\(fn PRINT-FUNCTION VALUE LIMIT)" nil nil)
+
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl-print" '("cl-print-" "help-byte-code")))
;;;***
@@ -5027,7 +5007,7 @@ is run).
\(fn CMD)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cmuscheme" '("cmuscheme-load-hook" "switch-to-scheme" "scheme-" "inferior-scheme-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cmuscheme" '("cmuscheme-load-hook" "inferior-scheme-" "scheme-" "switch-to-scheme")))
;;;***
@@ -5151,7 +5131,7 @@ REGEXP-GROUP is the regular expression group in REGEXP to use.
\(fn PROCESS COMMAND REGEXP REGEXP-GROUP)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "comint" '("comint-" "shell-strip-ctrl-m" "send-invisible")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "comint" '("comint-")))
;;;***
@@ -5232,11 +5212,6 @@ The function receives one argument, the name of the major mode of the
compilation buffer. It should return a string.
If nil, compute the name with `(concat \"*\" (downcase major-mode) \"*\")'.")
-(defvar compilation-finish-function nil "\
-Function to call when a compilation process finishes.
-It is called with two arguments: the compilation buffer, and a string
-describing how the process finished.")
-
(defvar compilation-finish-functions nil "\
Functions to call when a compilation process finishes.
Each function is called with two arguments: the compilation buffer,
@@ -5352,9 +5327,11 @@ Runs `compilation-mode-hook' with `run-mode-hooks' (which see).
(autoload 'compilation-shell-minor-mode "compile" "\
Toggle Compilation Shell minor mode.
-With a prefix argument ARG, enable Compilation Shell minor mode
-if ARG is positive, and disable it otherwise. If called from
-Lisp, enable the mode if ARG is omitted or nil.
+
+If called interactively, enable Compilation-Shell minor mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
When Compilation Shell minor mode is enabled, all the
error-parsing commands of the Compilation major mode are
@@ -5365,9 +5342,11 @@ See `compilation-mode'.
(autoload 'compilation-minor-mode "compile" "\
Toggle Compilation minor mode.
-With a prefix argument ARG, enable Compilation minor mode if ARG
-is positive, and disable it otherwise. If called from Lisp,
-enable the mode if ARG is omitted or nil.
+
+If called interactively, enable Compilation minor mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
When Compilation minor mode is enabled, all the error-parsing
commands of Compilation major mode are available. See
@@ -5381,7 +5360,7 @@ This is the value of `next-error-function' in Compilation buffers.
\(fn N &optional RESET)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "compile" '("compil" "kill-compilation" "define-compilation-mode" "recompile")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "compile" '("compil" "define-compilation-mode" "kill-compilation" "recompile")))
;;;***
@@ -5400,13 +5379,15 @@ or call the function `dynamic-completion-mode'.")
(autoload 'dynamic-completion-mode "completion" "\
Toggle dynamic word-completion on or off.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
+
+If called interactively, enable Dynamic-Completion mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "completion" '("inside-locate-completion-entry" "interactive-completion-string-reader" "initialize-completions" "current-completion-source" "cdabbrev-" "clear-all-completions" "check-completion-length" "complet" "cmpl-" "use-completion-" "list-all-completions" "symbol-" "set-c" "save" "kill-" "accept-completion" "add-" "*lisp-def-regexp*" "*c-def-regexp*" "delete-completion" "find-" "make-c" "num-cmpl-sources" "next-cdabbrev" "reset-cdabbrev" "enable-completion")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "completion" '("*c-def-regexp*" "*lisp-def-regexp*" "accept-completion" "add-" "cdabbrev-" "check-completion-length" "clear-all-completions" "cmpl-" "complet" "current-completion-source" "delete-completion" "enable-completion" "find-" "initialize-completions" "inside-locate-completion-entry" "interactive-completion-string-reader" "kill-" "list-all-completions" "make-c" "next-cdabbrev" "num-cmpl-sources" "reset-cdabbrev" "save" "set-c" "symbol-" "use-completion-")))
;;;***
@@ -5443,9 +5424,7 @@ doesn't have enough contents to decide, this is identical to
See also `conf-space-mode', `conf-colon-mode', `conf-javaprop-mode',
`conf-ppd-mode' and `conf-xdefaults-mode'.
-\\{conf-mode-map}
-
-\(fn)" t nil)
+\\{conf-mode-map}" t nil)
(autoload 'conf-unix-mode "conf-mode" "\
Conf Mode starter for Unix style Conf files.
@@ -5637,9 +5616,7 @@ interactively.
Convert 2 digit years to 4 digit years.
Uses heuristic: year >= 50 means 19xx, < 50 means 20xx.
If `copyright-year-ranges' (which see) is non-nil, also
-independently replaces consecutive years with a range.
-
-\(fn)" t nil)
+independently replaces consecutive years with a range." t nil)
(autoload 'copyright "copyright" "\
Insert a copyright by $ORGANIZATION notice at cursor.
@@ -5764,7 +5741,7 @@ It is possible to show this help automatically after some idle time.
This is regulated by variable `cperl-lazy-help-time'. Default with
`cperl-hairy' (if the value of `cperl-lazy-help-time' is nil) is 5
secs idle time . It is also possible to switch this on/off from the
-menu, or via \\[cperl-toggle-autohelp]. Requires `run-with-idle-timer'.
+menu, or via \\[cperl-toggle-autohelp].
Use \\[cperl-lineup] to vertically lineup some construction - put the
beginning of the region at the start of construction, and make region
@@ -5849,9 +5826,7 @@ Run `perldoc' on WORD.
\(fn WORD)" t nil)
(autoload 'cperl-perldoc-at-point "cperl-mode" "\
-Run a `perldoc' on the word around point.
-
-\(fn)" t nil)
+Run a `perldoc' on the word around point." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cperl-mode" '("cperl-" "pod2man-program")))
@@ -5869,9 +5844,7 @@ A prefix arg suppresses display of that buffer.
\(fn ARG)" t nil)
(autoload 'cpp-parse-edit "cpp" "\
-Edit display information for cpp conditionals.
-
-\(fn)" t nil)
+Edit display information for cpp conditionals." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cpp" '("cpp-")))
@@ -5965,9 +5938,11 @@ or call the function `cua-mode'.")
(autoload 'cua-mode "cua-base" "\
Toggle Common User Access style editing (CUA mode).
-With a prefix argument ARG, enable CUA mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
+
+If called interactively, enable Cua mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
CUA mode is a global minor mode. When enabled, typed text
replaces the active selection, and you can use C-z, C-x, C-c, and
@@ -6012,6 +5987,11 @@ Enable CUA selection mode without the C-z/C-x/C-c/C-v bindings.
Toggle the region as rectangular.
Activates the region if needed. Only lasts until the region is deactivated.
+If called interactively, enable Cua-Rectangle-Mark mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
\(fn &optional ARG)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cua-rect" '("cua-")))
@@ -6030,6 +6010,11 @@ By convention, this is a list of symbols where each symbol stands for the
(autoload 'cursor-intangible-mode "cursor-sensor" "\
Keep cursor outside of any `cursor-intangible' text property.
+If called interactively, enable Cursor-Intangible mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
\(fn &optional ARG)" t nil)
(autoload 'cursor-sensor-mode "cursor-sensor" "\
@@ -6040,6 +6025,11 @@ where WINDOW is the affected window, OLDPOS is the last known position of
the cursor and DIR can be `entered' or `left' depending on whether the cursor
is entering the area covered by the text-property property or leaving it.
+If called interactively, enable Cursor-Sensor mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
\(fn &optional ARG)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cursor-sensor" '("cursor-sensor-")))
@@ -6133,9 +6123,7 @@ the resulting list value now. Otherwise, add an entry to
Select a customization buffer which you can use to set user options.
User options are structured into \"groups\".
Initially the top-level group `Emacs' and its immediate subgroups
-are shown; the contents of those subgroups are initially hidden.
-
-\(fn)" t nil)
+are shown; the contents of those subgroups are initially hidden." t nil)
(autoload 'customize-mode "cus-edit" "\
Customize options related to a major or minor mode.
@@ -6238,19 +6226,13 @@ suggest to customize that face, if it's customizable.
\(fn &optional FACE)" t nil)
(autoload 'customize-unsaved "cus-edit" "\
-Customize all options and faces set in this session but not saved.
-
-\(fn)" t nil)
+Customize all options and faces set in this session but not saved." t nil)
(autoload 'customize-rogue "cus-edit" "\
-Customize all user variables modified outside customize.
-
-\(fn)" t nil)
+Customize all user variables modified outside customize." t nil)
(autoload 'customize-saved "cus-edit" "\
-Customize all saved options and faces.
-
-\(fn)" t nil)
+Customize all saved options and faces." t nil)
(autoload 'customize-apropos "cus-edit" "\
Customize loaded options, faces and groups matching PATTERN.
@@ -6283,9 +6265,7 @@ Customize all loaded groups matching REGEXP.
(autoload 'custom-prompt-customize-unsaved-options "cus-edit" "\
Prompt user to customize any unsaved customization options.
Return non-nil if user chooses to customize, for use in
-`kill-emacs-query-functions'.
-
-\(fn)" nil nil)
+`kill-emacs-query-functions'." nil nil)
(autoload 'custom-buffer-create "cus-edit" "\
Create a buffer containing OPTIONS.
@@ -6349,14 +6329,10 @@ and hence will not set `custom-file' to that file either.")
(custom-autoload 'custom-file "cus-edit" t)
(autoload 'custom-save-all "cus-edit" "\
-Save all customizations in `custom-file'.
-
-\(fn)" nil nil)
+Save all customizations in `custom-file'." nil nil)
(autoload 'customize-save-customized "cus-edit" "\
-Save all user options which have been set in this session.
-
-\(fn)" t nil)
+Save all user options which have been set in this session." t nil)
(autoload 'custom-menu-create "cus-edit" "\
Create menu for customization group SYMBOL.
@@ -6430,16 +6406,17 @@ Mode used for cvs status output.
(autoload 'cwarn-mode "cwarn" "\
Minor mode that highlights suspicious C and C++ constructions.
+If called interactively, enable Cwarn mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
Suspicious constructs are highlighted using `font-lock-warning-face'.
Note, in addition to enabling this minor mode, the major mode must
be included in the variable `cwarn-configuration'. By default C and
C++ modes are included.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
-
\(fn &optional ARG)" t nil)
(define-obsolete-function-alias 'turn-on-cwarn-mode 'cwarn-mode "24.1")
@@ -6466,7 +6443,7 @@ See `cwarn-mode' for more information on Cwarn mode.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cwarn" '("turn-on-cwarn-mode-if-enabled" "cwarn-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cwarn" '("cwarn-" "turn-on-cwarn-mode-if-enabled")))
;;;***
@@ -6532,7 +6509,7 @@ buffers accepted by the function pointed out by variable
`dabbrev-friend-buffer-function', if `dabbrev-check-other-buffers'
says so. Then, if `dabbrev-check-all-buffers' is non-nil, look in
all the other buffers, subject to constraints specified
-by `dabbrev-ignored-buffer-names' and `dabbrev-ignored-regexps'.
+by `dabbrev-ignored-buffer-names' and `dabbrev-ignored-buffer-regexps'.
A positive prefix argument, N, says to take the Nth backward *distinct*
possibility. A negative argument says search forward.
@@ -6788,9 +6765,7 @@ To specify a nil argument interactively, exit with an empty minibuffer.
;;; Generated autoloads from play/decipher.el
(autoload 'decipher "decipher" "\
-Format a buffer of ciphertext for cryptanalysis and enter Decipher mode.
-
-\(fn)" t nil)
+Format a buffer of ciphertext for cryptanalysis and enter Decipher mode." t nil)
(autoload 'decipher-mode "decipher" "\
Major mode for decrypting monoalphabetic substitution ciphers.
@@ -6806,9 +6781,7 @@ The most useful commands are:
\\[decipher-frequency-count] Display the frequency of each ciphertext letter
\\[decipher-adjacency-list] Show adjacency list for current letter (lists letters appearing next to it)
\\[decipher-make-checkpoint] Save the current cipher alphabet (checkpoint)
-\\[decipher-restore-checkpoint] Restore a saved cipher alphabet (checkpoint)
-
-\(fn)" t nil)
+\\[decipher-restore-checkpoint] Restore a saved cipher alphabet (checkpoint)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "decipher" '("decipher-")))
@@ -6819,9 +6792,7 @@ The most useful commands are:
(push (purecopy '(delim-col 2 1)) package--builtin-versions)
(autoload 'delimit-columns-customize "delim-col" "\
-Customization of `columns' group.
-
-\(fn)" t nil)
+Customization of `columns' group." t nil)
(autoload 'delimit-columns-region "delim-col" "\
Prettify all columns in a text region.
@@ -6858,12 +6829,11 @@ or call the function `delete-selection-mode'.")
(autoload 'delete-selection-mode "delsel" "\
Toggle Delete Selection mode.
-Interactively, with a prefix argument, enable
-Delete Selection mode if the prefix argument is positive,
-and disable it otherwise. If called from Lisp, toggle
-the mode if ARG is `toggle', disable the mode if ARG is
-a non-positive integer, and enable the mode otherwise
-\(including if ARG is omitted or nil or a positive integer).
+
+If called interactively, enable Delete-Selection mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
When Delete Selection mode is enabled, typed text replaces the selection
if the selection is active. Otherwise, typed text is just inserted at
@@ -7001,9 +6971,7 @@ of `eldoc-echo-area-use-multiline-p' variable and width of
minibuffer window for width limit.
This function is meant to be used as a value of
-`eldoc-documentation-function' variable.
-
-\(fn)" nil nil)
+`eldoc-documentation-function' variable." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "descr-text" '("describe-")))
@@ -7024,9 +6992,11 @@ or call the function `desktop-save-mode'.")
(autoload 'desktop-save-mode "desktop" "\
Toggle desktop saving (Desktop Save mode).
-With a prefix argument ARG, enable Desktop Save mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode if ARG
-is omitted or nil.
+
+If called interactively, enable Desktop-Save mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
When Desktop Save mode is enabled, the state of Emacs is saved from
one session to another. In particular, Emacs will save the desktop when
@@ -7160,9 +7130,7 @@ a regular expression in the list `desktop-clear-preserve-buffers'.
Furthermore, it clears the variables listed in `desktop-globals-to-clear'.
When called interactively and `desktop-restore-frames' is non-nil, it also
deletes all frames except the selected one (and its minibuffer frame,
-if different).
-
-\(fn)" t nil)
+if different)." t nil)
(autoload 'desktop-save "desktop" "\
Save the desktop in a desktop file.
@@ -7194,9 +7162,7 @@ without further confirmation.
(autoload 'desktop-remove "desktop" "\
Delete desktop file in `desktop-dirname'.
-This function also sets `desktop-dirname' to nil.
-
-\(fn)" t nil)
+This function also sets `desktop-dirname' to nil." t nil)
(autoload 'desktop-read "desktop" "\
Read and process the desktop file in directory DIRNAME.
@@ -7209,14 +7175,6 @@ It returns t if a desktop file was loaded, nil otherwise.
\(fn &optional DIRNAME)" t nil)
-(autoload 'desktop-load-default "desktop" "\
-Load the `default' start-up library manually.
-Also inhibit further loading of it.
-
-\(fn)" nil nil)
-
-(make-obsolete 'desktop-load-default 'desktop-save-mode '"22.1")
-
(autoload 'desktop-change-dir "desktop" "\
Change to desktop saved in DIRNAME.
Kill the desktop as specified by variables `desktop-save-mode' and
@@ -7226,14 +7184,10 @@ directory DIRNAME.
\(fn DIRNAME)" t nil)
(autoload 'desktop-save-in-desktop-dir "desktop" "\
-Save the desktop in directory `desktop-dirname'.
-
-\(fn)" t nil)
+Save the desktop in directory `desktop-dirname'." t nil)
(autoload 'desktop-revert "desktop" "\
-Revert to the last loaded desktop.
-
-\(fn)" t nil)
+Revert to the last loaded desktop." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "desktop" '("desktop-")))
@@ -7265,9 +7219,7 @@ NODISPLAY is non-nil, don't redisplay the article buffer.
\(fn &optional NODISPLAY)" t nil)
(autoload 'gnus-article-outlook-deuglify-article "deuglify" "\
-Deuglify broken Outlook (Express) articles and redisplay.
-
-\(fn)" t nil)
+Deuglify broken Outlook (Express) articles and redisplay." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "deuglify" '("gnus-")))
@@ -7321,7 +7273,7 @@ Major mode for editing the diary file.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "diary-lib" '("diary-" "calendar-mark-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "diary-lib" '("calendar-mark-" "diary-")))
;;;***
@@ -7391,15 +7343,17 @@ You can also switch between context diff and unified diff with \\[diff-context->
or vice versa with \\[diff-unified->context] and you can also reverse the direction of
a diff with \\[diff-reverse-direction].
- \\{diff-mode-map}
+\\{diff-mode-map}
\(fn)" t nil)
(autoload 'diff-minor-mode "diff-mode" "\
Toggle Diff minor mode.
-With a prefix argument ARG, enable Diff minor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Diff minor mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
\\{diff-minor-mode-map}
@@ -7418,7 +7372,7 @@ Optional arguments are passed to `dig-invoke'.
\(fn DOMAIN &optional QUERY-TYPE QUERY-CLASS QUERY-OPTION DIG-OPTION SERVER)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dig" '("query-dig" "dig-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dig" '("dig-" "query-dig")))
;;;***
@@ -7575,9 +7529,11 @@ Keybindings:
(autoload 'dirtrack-mode "dirtrack" "\
Toggle directory tracking in shell buffers (Dirtrack mode).
-With a prefix argument ARG, enable Dirtrack mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Dirtrack mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
This method requires that your shell prompt contain the current
working directory at all times, and that you set the variable
@@ -7622,9 +7578,7 @@ redefine OBJECT if it is a symbol.
;;; Generated autoloads from disp-table.el
(autoload 'make-display-table "disp-table" "\
-Return a new, empty display table.
-
-\(fn)" nil nil)
+Return a new, empty display table." nil nil)
(autoload 'display-table-slot "disp-table" "\
Return the value of the extra slot in DISPLAY-TABLE named SLOT.
@@ -7648,9 +7602,7 @@ Describe the display table DT in a help buffer.
\(fn DT)" nil nil)
(autoload 'describe-current-display-table "disp-table" "\
-Describe the display table in use in the selected window and buffer.
-
-\(fn)" t nil)
+Describe the display table in use in the selected window and buffer." t nil)
(autoload 'standard-display-8bit "disp-table" "\
Display characters representing raw bytes in the range L to H literally.
@@ -7749,6 +7701,11 @@ in `.emacs'.
Toggle display of line numbers in the buffer.
This uses `display-line-numbers' internally.
+If called interactively, enable Display-Line-Numbers mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
To change the type of line numbers displayed by default,
customize `display-line-numbers-type'. To change the type while
the mode is on, set `display-line-numbers' directly.
@@ -7843,9 +7800,7 @@ Turning on DNS mode runs `dns-mode-hook'.
(defalias 'zone-mode 'dns-mode)
(autoload 'dns-mode-soa-increment-serial "dns-mode" "\
-Locate SOA record and increment the serial field.
-
-\(fn)" t nil)
+Locate SOA record and increment the serial field." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dns-mode" '("dns-mode-")))
@@ -7869,22 +7824,20 @@ and DVI files (as PNG images) in Emacs buffers.
You can use \\<doc-view-mode-map>\\[doc-view-toggle-display] to
toggle between displaying the document or editing it as text.
-\\{doc-view-mode-map}
-
-\(fn)" t nil)
+\\{doc-view-mode-map}" t nil)
(autoload 'doc-view-mode-maybe "doc-view" "\
Switch to `doc-view-mode' if possible.
If the required external tools are not available, then fallback
-to the next best mode.
-
-\(fn)" nil nil)
+to the next best mode." nil nil)
(autoload 'doc-view-minor-mode "doc-view" "\
Toggle displaying buffer via Doc View (Doc View minor mode).
-With a prefix argument ARG, enable Doc View minor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Doc-View minor mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
See the command `doc-view-mode' for more information on this mode.
@@ -7903,9 +7856,7 @@ See the command `doc-view-mode' for more information on this mode.
;;; Generated autoloads from play/doctor.el
(autoload 'doctor "doctor" "\
-Switch to *doctor* buffer and start giving psychotherapy.
-
-\(fn)" t nil)
+Switch to *doctor* buffer and start giving psychotherapy." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "doctor" '("doc" "make-doctor-variables")))
@@ -7935,7 +7886,7 @@ Switch to *doctor* buffer and start giving psychotherapy.
;;;### (autoloads nil "dos-w32" "dos-w32.el" (0 0 0 0))
;;; Generated autoloads from dos-w32.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dos-w32" '("w32-" "file-name-buffer-file-type-alist" "find-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dos-w32" '("file-name-buffer-file-type-alist" "find-" "w32-")))
;;;***
@@ -7944,9 +7895,11 @@ Switch to *doctor* buffer and start giving psychotherapy.
(autoload 'double-mode "double" "\
Toggle special insertion on double keypresses (Double mode).
-With a prefix argument ARG, enable Double mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Double mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
When Double mode is enabled, some keys will insert different
strings when pressed twice. See `double-map' for details.
@@ -7962,9 +7915,7 @@ strings when pressed twice. See `double-map' for details.
(push (purecopy '(dunnet 2 2)) package--builtin-versions)
(autoload 'dunnet "dunnet" "\
-Switch to *dungeon* buffer and start game.
-
-\(fn)" t nil)
+Switch to *dungeon* buffer and start game." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dunnet" '("dun" "obj-special")))
@@ -8001,7 +7952,9 @@ non-positive integer, and enables the mode otherwise (including
if the argument is omitted or nil or a positive integer).
If DOC is nil, give the mode command a basic doc-string
-documenting what its argument does.
+documenting what its argument does. If the word \"ARG\" does not
+appear in DOC, a paragraph is added to DOC explaining
+usage of the mode argument.
Optional INIT-VALUE is the initial value of the mode's variable.
Optional LIGHTER is displayed in the mode line when the mode is on.
@@ -8114,12 +8067,16 @@ the constant's documentation.
\(fn M BS DOC &rest ARGS)" nil t)
+(function-put 'easy-mmode-defmap 'lisp-indent-function '1)
+
(autoload 'easy-mmode-defsyntax "easy-mmode" "\
Define variable ST as a syntax-table.
CSS contains a list of syntax specifications of the form (CHAR . SYNTAX).
\(fn ST CSS DOC &rest ARGS)" nil t)
+(function-put 'easy-mmode-defsyntax 'lisp-indent-function '1)
+
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "easy-mmode" '("easy-mmode-")))
;;;***
@@ -8261,7 +8218,7 @@ To implement dynamic menus, either call this from
\(fn PATH NAME ITEMS &optional BEFORE MAP)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "easymenu" '("easy-menu-" "add-submenu")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "easymenu" '("add-submenu" "easy-menu-")))
;;;***
@@ -8319,9 +8276,7 @@ To implement dynamic menus, either call this from
(push (purecopy '(ebnf2ps 4 4)) package--builtin-versions)
(autoload 'ebnf-customize "ebnf2ps" "\
-Customization for ebnf group.
-
-\(fn)" t nil)
+Customization for ebnf group." t nil)
(autoload 'ebnf-print-directory "ebnf2ps" "\
Generate and print a PostScript syntactic chart image of DIRECTORY.
@@ -8348,7 +8303,7 @@ See also `ebnf-print-buffer'.
(autoload 'ebnf-print-buffer "ebnf2ps" "\
Generate and print a PostScript syntactic chart image of the buffer.
-When called with a numeric prefix argument (C-u), prompts the user for
+When called with a numeric prefix argument (\\[universal-argument]), prompts the user for
the name of a file to save the PostScript image in, instead of sending
it to the printer.
@@ -8392,9 +8347,7 @@ Generate and spool a PostScript syntactic chart image of the buffer.
Like `ebnf-print-buffer' except that the PostScript image is saved in a
local buffer to be sent to the printer later.
-Use the command `ebnf-despool' to send the spooled images to the printer.
-
-\(fn)" t nil)
+Use the command `ebnf-despool' to send the spooled images to the printer." t nil)
(autoload 'ebnf-spool-region "ebnf2ps" "\
Generate a PostScript syntactic chart image of the region and spool locally.
@@ -8444,9 +8397,7 @@ The EPS file name has the following form:
file name used in this case will be \"ebnf--A_B_+_C.eps\".
WARNING: This function does *NOT* ask any confirmation to override existing
- files.
-
-\(fn)" t nil)
+ files." t nil)
(autoload 'ebnf-eps-region "ebnf2ps" "\
Generate a PostScript syntactic chart image of the region in an EPS file.
@@ -8470,7 +8421,7 @@ WARNING: This function does *NOT* ask any confirmation to override existing
\(fn FROM TO)" t nil)
-(defalias 'ebnf-despool 'ps-despool)
+(defalias 'ebnf-despool #'ps-despool)
(autoload 'ebnf-syntax-directory "ebnf2ps" "\
Do a syntactic analysis of the files in DIRECTORY.
@@ -8495,9 +8446,7 @@ See also `ebnf-syntax-buffer'.
\(fn FILE &optional DO-NOT-KILL-BUFFER-WHEN-DONE)" t nil)
(autoload 'ebnf-syntax-buffer "ebnf2ps" "\
-Do a syntactic analysis of the current buffer.
-
-\(fn)" t nil)
+Do a syntactic analysis of the current buffer." t nil)
(autoload 'ebnf-syntax-region "ebnf2ps" "\
Do a syntactic analysis of a region.
@@ -8505,9 +8454,7 @@ Do a syntactic analysis of a region.
\(fn FROM TO)" t nil)
(autoload 'ebnf-setup "ebnf2ps" "\
-Return the current ebnf2ps setup.
-
-\(fn)" nil nil)
+Return the current ebnf2ps setup." nil nil)
(autoload 'ebnf-find-style "ebnf2ps" "\
Return style definition if NAME is already defined; otherwise, return nil.
@@ -8573,9 +8520,7 @@ Returns the old style symbol.
See also `ebnf-push-style'.
-See `ebnf-style-database' documentation.
-
-\(fn)" t nil)
+See `ebnf-style-database' documentation." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebnf2ps" '("ebnf-")))
@@ -8597,9 +8542,7 @@ Tree mode key bindings:
\(fn)" t nil)
(autoload 'ebrowse-electric-choose-tree "ebrowse" "\
-Return a buffer containing a tree or nil if no tree found or canceled.
-
-\(fn)" t nil)
+Return a buffer containing a tree or nil if no tree found or canceled." t nil)
(autoload 'ebrowse-member-mode "ebrowse" "\
Major mode for Ebrowse member buffers.
@@ -8607,54 +8550,34 @@ Major mode for Ebrowse member buffers.
\(fn)" t nil)
(autoload 'ebrowse-tags-view-declaration "ebrowse" "\
-View declaration of member at point.
-
-\(fn)" t nil)
+View declaration of member at point." t nil)
(autoload 'ebrowse-tags-find-declaration "ebrowse" "\
-Find declaration of member at point.
-
-\(fn)" t nil)
+Find declaration of member at point." t nil)
(autoload 'ebrowse-tags-view-definition "ebrowse" "\
-View definition of member at point.
-
-\(fn)" t nil)
+View definition of member at point." t nil)
(autoload 'ebrowse-tags-find-definition "ebrowse" "\
-Find definition of member at point.
-
-\(fn)" t nil)
+Find definition of member at point." t nil)
(autoload 'ebrowse-tags-find-declaration-other-window "ebrowse" "\
-Find declaration of member at point in other window.
-
-\(fn)" t nil)
+Find declaration of member at point in other window." t nil)
(autoload 'ebrowse-tags-view-definition-other-window "ebrowse" "\
-View definition of member at point in other window.
-
-\(fn)" t nil)
+View definition of member at point in other window." t nil)
(autoload 'ebrowse-tags-find-definition-other-window "ebrowse" "\
-Find definition of member at point in other window.
-
-\(fn)" t nil)
+Find definition of member at point in other window." t nil)
(autoload 'ebrowse-tags-find-declaration-other-frame "ebrowse" "\
-Find definition of member at point in other frame.
-
-\(fn)" t nil)
+Find definition of member at point in other frame." t nil)
(autoload 'ebrowse-tags-view-definition-other-frame "ebrowse" "\
-View definition of member at point in other frame.
-
-\(fn)" t nil)
+View definition of member at point in other frame." t nil)
(autoload 'ebrowse-tags-find-definition-other-frame "ebrowse" "\
-Find definition of member at point in other frame.
-
-\(fn)" t nil)
+Find definition of member at point in other frame." t nil)
(autoload 'ebrowse-tags-complete-symbol "ebrowse" "\
Perform completion on the C++ symbol preceding point.
@@ -8706,14 +8629,10 @@ Prefix arg ARG says how much.
\(fn ARG)" t nil)
(autoload 'ebrowse-electric-position-menu "ebrowse" "\
-List positions in the position stack in an electric buffer.
-
-\(fn)" t nil)
+List positions in the position stack in an electric buffer." t nil)
(autoload 'ebrowse-save-tree "ebrowse" "\
-Save current tree in same file it was loaded from.
-
-\(fn)" t nil)
+Save current tree in same file it was loaded from." t nil)
(autoload 'ebrowse-save-tree-as "ebrowse" "\
Write the current tree data structure to a file.
@@ -8723,11 +8642,9 @@ Otherwise, FILE-NAME specifies the file to save the tree in.
\(fn &optional FILE-NAME)" t nil)
(autoload 'ebrowse-statistics "ebrowse" "\
-Display statistics for a class tree.
-
-\(fn)" t nil)
+Display statistics for a class tree." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebrowse" '("electric-buffer-menu-mode-hook" "ebrowse-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebrowse" '("ebrowse-" "electric-buffer-menu-mode-hook")))
;;;***
@@ -8762,7 +8679,7 @@ Run hooks in `electric-buffer-menu-mode-hook' on entry.
\(fn ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebuff-menu" '("electric-buffer-" "Electric-buffer-menu-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebuff-menu" '("Electric-buffer-menu-" "electric-buffer-")))
;;;***
@@ -8783,9 +8700,7 @@ With prefix arg NOCONFIRM, execute current line as-is without editing.
;;; Generated autoloads from ecomplete.el
(autoload 'ecomplete-setup "ecomplete" "\
-Read the .ecompleterc file.
-
-\(fn)" nil nil)
+Read the .ecompleterc file." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ecomplete" '("ecomplete-")))
@@ -8807,16 +8722,18 @@ or call the function `global-ede-mode'.")
(autoload 'global-ede-mode "ede" "\
Toggle global EDE (Emacs Development Environment) mode.
-With a prefix argument ARG, enable global EDE mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Global Ede mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
This global minor mode enables `ede-minor-mode' in all buffers in
an EDE controlled project.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede" '("project-try-ede" "ede" "global-ede-mode-map")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede" '("ede" "global-ede-mode-map" "project-try-ede")))
;;;***
@@ -8863,7 +8780,7 @@ an EDE controlled project.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/ede/custom.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/custom" '("eieio-ede-old-variables" "ede-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/custom" '("ede-" "eieio-ede-old-variables")))
;;;***
@@ -8979,7 +8896,7 @@ an EDE controlled project.
;;;;;; 0 0 0))
;;; Generated autoloads from cedet/ede/proj-comp.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/proj-comp" '("proj-comp-insert-variable-once" "ede-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/proj-comp" '("ede-" "proj-comp-insert-variable-once")))
;;;***
@@ -9141,21 +9058,15 @@ If the current defun is actually a call to `defvar' or `defcustom',
evaluating it this way resets the variable using its initial value
expression even if the variable already has some other value.
\(Normally `defvar' and `defcustom' do not alter the value if there
-already is one.)
-
-\(fn)" t nil)
+already is one.)" t nil)
(autoload 'edebug-all-defs "edebug" "\
-Toggle edebugging of all definitions.
-
-\(fn)" t nil)
+Toggle edebugging of all definitions." t nil)
(autoload 'edebug-all-forms "edebug" "\
-Toggle edebugging of all forms.
-
-\(fn)" t nil)
+Toggle edebugging of all forms." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "edebug" '("edebug" "get-edebug-spec" "global-edebug-" "cancel-edebug-on-entry")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "edebug" '("cancel-edebug-on-entry" "edebug" "get-edebug-spec" "global-edebug-")))
;;;***
@@ -9184,9 +9095,7 @@ arguments after setting up the Ediff buffers.
(autoload 'ediff-current-file "ediff" "\
Start ediff between current buffer and its file on disk.
This command can be used instead of `revert-buffer'. If there is
-nothing to revert then this command fails.
-
-\(fn)" t nil)
+nothing to revert then this command fails." t nil)
(autoload 'ediff-backup "ediff" "\
Run Ediff on FILE and its backup file.
@@ -9448,9 +9357,7 @@ arguments after setting up the Ediff buffers.
(autoload 'ediff-version "ediff" "\
Return string describing the version of Ediff.
-When called interactively, displays the version.
-
-\(fn)" t nil)
+When called interactively, displays the version." t nil)
(autoload 'ediff-documentation "ediff" "\
Display Ediff's manual.
@@ -9459,44 +9366,28 @@ With optional NODE, goes to that node.
\(fn &optional NODE)" t nil)
(autoload 'ediff-files-command "ediff" "\
-Call `ediff-files' with the next two command line arguments.
-
-\(fn)" nil nil)
+Call `ediff-files' with the next two command line arguments." nil nil)
(autoload 'ediff3-files-command "ediff" "\
-Call `ediff3-files' with the next three command line arguments.
-
-\(fn)" nil nil)
+Call `ediff3-files' with the next three command line arguments." nil nil)
(autoload 'ediff-merge-command "ediff" "\
-Call `ediff-merge-files' with the next two command line arguments.
-
-\(fn)" nil nil)
+Call `ediff-merge-files' with the next two command line arguments." nil nil)
(autoload 'ediff-merge-with-ancestor-command "ediff" "\
-Call `ediff-merge-files-with-ancestor' with the next three command line arguments.
-
-\(fn)" nil nil)
+Call `ediff-merge-files-with-ancestor' with the next three command line arguments." nil nil)
(autoload 'ediff-directories-command "ediff" "\
-Call `ediff-directories' with the next three command line arguments.
-
-\(fn)" nil nil)
+Call `ediff-directories' with the next three command line arguments." nil nil)
(autoload 'ediff-directories3-command "ediff" "\
-Call `ediff-directories3' with the next four command line arguments.
-
-\(fn)" nil nil)
+Call `ediff-directories3' with the next four command line arguments." nil nil)
(autoload 'ediff-merge-directories-command "ediff" "\
-Call `ediff-merge-directories' with the next three command line arguments.
-
-\(fn)" nil nil)
+Call `ediff-merge-directories' with the next three command line arguments." nil nil)
(autoload 'ediff-merge-directories-with-ancestor-command "ediff" "\
-Call `ediff-merge-directories-with-ancestor' with the next four command line arguments.
-
-\(fn)" nil nil)
+Call `ediff-merge-directories-with-ancestor' with the next four command line arguments." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ediff" '("ediff-")))
@@ -9512,10 +9403,7 @@ Call `ediff-merge-directories-with-ancestor' with the next four command line arg
;;;### (autoloads nil "ediff-help" "vc/ediff-help.el" (0 0 0 0))
;;; Generated autoloads from vc/ediff-help.el
-(autoload 'ediff-customize "ediff-help" "\
-
-
-\(fn)" t nil)
+(autoload 'ediff-customize "ediff-help" nil t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ediff-help" '("ediff-")))
@@ -9539,9 +9427,7 @@ Call `ediff-merge-directories-with-ancestor' with the next four command line arg
;;; Generated autoloads from vc/ediff-mult.el
(autoload 'ediff-show-registry "ediff-mult" "\
-Display Ediff's registry.
-
-\(fn)" t nil)
+Display Ediff's registry." t nil)
(defalias 'eregistry 'ediff-show-registry)
@@ -9562,16 +9448,12 @@ Display Ediff's registry.
(autoload 'ediff-toggle-multiframe "ediff-util" "\
Switch from multiframe display to single-frame display and back.
To change the default, set the variable `ediff-window-setup-function',
-which see.
-
-\(fn)" t nil)
+which see." t nil)
(autoload 'ediff-toggle-use-toolbar "ediff-util" "\
Enable or disable Ediff toolbar.
Works only in versions of Emacs that support toolbars.
-To change the default, set the variable `ediff-use-toolbar-p', which see.
-
-\(fn)" t nil)
+To change the default, set the variable `ediff-use-toolbar-p', which see." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ediff-util" '("ediff-")))
@@ -9654,9 +9536,7 @@ Argument BOTTOM is the bottom margin in number of lines or percent of window.
\(fn TOP BOTTOM)" t nil)
(autoload 'edt-emulation-on "edt" "\
-Turn on EDT Emulation.
-
-\(fn)" t nil)
+Turn on EDT Emulation." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "edt" '("edt-")))
@@ -9727,7 +9607,7 @@ BUFFER is put back into its original major mode.
\(fn FUN &optional NAME)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ehelp" '("electric-" "ehelp-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ehelp" '("ehelp-" "electric-")))
;;;***
@@ -9735,7 +9615,7 @@ BUFFER is put back into its original major mode.
;;; Generated autoloads from emacs-lisp/eieio.el
(push (purecopy '(eieio 1 4)) package--builtin-versions)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio" '("eieio-" "oref" "oset" "obj" "find-class" "set-slot-value" "same-class-p" "slot-" "child-of-class-p" "with-slots" "defclass")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio" '("child-of-class-p" "defclass" "eieio-" "find-class" "obj" "oref" "oset" "same-class-p" "set-slot-value" "slot-" "with-slots")))
;;;***
@@ -9751,7 +9631,7 @@ BUFFER is put back into its original major mode.
;;;;;; "emacs-lisp/eieio-compat.el" (0 0 0 0))
;;; Generated autoloads from emacs-lisp/eieio-compat.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio-compat" '("no-" "next-method-p" "generic-p" "eieio--generic-static-symbol-specializers")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio-compat" '("eieio--generic-static-symbol-specializers" "generic-p" "next-method-p" "no-")))
;;;***
@@ -9770,7 +9650,7 @@ It creates an autoload function for CNAME's constructor.
\(fn CNAME SUPERCLASSES FILENAME DOC)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio-core" '("eieio-" "invalid-slot-" "inconsistent-class-hierarchy" "unbound-slot" "class-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio-core" '("class-" "eieio-" "inconsistent-class-hierarchy" "invalid-slot-" "unbound-slot")))
;;;***
@@ -9821,9 +9701,11 @@ or call the function `electric-pair-mode'.")
(autoload 'electric-pair-mode "elec-pair" "\
Toggle automatic parens pairing (Electric Pair mode).
-With a prefix argument ARG, enable Electric Pair mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Electric-Pair mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Electric Pair mode is a global minor mode. When enabled, typing
an open parenthesis automatically inserts the corresponding
@@ -9838,6 +9720,11 @@ To toggle the mode in a single buffer, use `electric-pair-local-mode'.
(autoload 'electric-pair-local-mode "elec-pair" "\
Toggle `electric-pair-mode' only in this buffer.
+If called interactively, enable Electric-Pair-Local mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
\(fn &optional ARG)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "elec-pair" '("electric-pair-")))
@@ -9877,15 +9764,11 @@ A complicated directory may require a lot of memory.
(autoload 'elint-current-buffer "elint" "\
Lint the current buffer.
-If necessary, this first calls `elint-initialize'.
-
-\(fn)" t nil)
+If necessary, this first calls `elint-initialize'." t nil)
(autoload 'elint-defun "elint" "\
Lint the function at point.
-If necessary, this first calls `elint-initialize'.
-
-\(fn)" t nil)
+If necessary, this first calls `elint-initialize'." t nil)
(autoload 'elint-initialize "elint" "\
Initialize elint.
@@ -9927,9 +9810,7 @@ For example, to instrument all ELP functions, do the following:
Display current profiling results.
If `elp-reset-after-results' is non-nil, then current profiling
information for all instrumented functions is reset after results are
-displayed.
-
-\(fn)" t nil)
+displayed." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "elp" '("elp-")))
@@ -10067,7 +9948,7 @@ displayed.
;;;;;; (0 0 0 0))
;;; Generated autoloads from eshell/em-xtra.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-xtra" '("pcomplete/bcc" "eshell/")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-xtra" '("eshell/" "pcomplete/bcc")))
;;;***
@@ -10077,9 +9958,7 @@ displayed.
(autoload 'emacs-lock-mode "emacs-lock" "\
Toggle Emacs Lock mode in the current buffer.
If called with a plain prefix argument, ask for the locking mode
-to be used. With any other prefix ARG, turn mode on if ARG is
-positive, off otherwise. If called from Lisp, enable the mode if
-ARG is omitted or nil.
+to be used.
Initially, if the user does not pass an explicit locking mode, it
defaults to `emacs-lock-default-locking-mode' (which see);
@@ -10099,7 +9978,7 @@ some major modes from being locked under some circumstances.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "emacs-lock" '("toggle-emacs-lock" "emacs-lock-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "emacs-lock" '("emacs-lock-" "toggle-emacs-lock")))
;;;***
@@ -10141,15 +10020,9 @@ Run Emerge on two buffers, giving another buffer as the ancestor.
\(fn BUFFER-A BUFFER-B BUFFER-ANCESTOR &optional STARTUP-HOOKS QUIT-HOOKS)" t nil)
-(autoload 'emerge-files-command "emerge" "\
+(autoload 'emerge-files-command "emerge" nil nil nil)
-
-\(fn)" nil nil)
-
-(autoload 'emerge-files-with-ancestor-command "emerge" "\
-
-
-\(fn)" nil nil)
+(autoload 'emerge-files-with-ancestor-command "emerge" nil nil nil)
(autoload 'emerge-files-remote "emerge" "\
@@ -10188,9 +10061,10 @@ Minor mode for editing text/enriched files.
These are files with embedded formatting information in the MIME standard
text/enriched format.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
+If called interactively, enable Enriched mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Turning the mode on or off runs `enriched-mode-hook'.
@@ -10411,24 +10285,16 @@ Insert selected KEYS after the point.
;;; Generated autoloads from epa-dired.el
(autoload 'epa-dired-do-decrypt "epa-dired" "\
-Decrypt marked files.
-
-\(fn)" t nil)
+Decrypt marked files." t nil)
(autoload 'epa-dired-do-verify "epa-dired" "\
-Verify marked files.
-
-\(fn)" t nil)
+Verify marked files." t nil)
(autoload 'epa-dired-do-sign "epa-dired" "\
-Sign marked files.
-
-\(fn)" t nil)
+Sign marked files." t nil)
(autoload 'epa-dired-do-encrypt "epa-dired" "\
-Encrypt marked files.
-
-\(fn)" t nil)
+Encrypt marked files." t nil)
;;;***
@@ -10440,15 +10306,9 @@ Encrypt marked files.
\(fn OPERATION &rest ARGS)" nil nil)
-(autoload 'epa-file-enable "epa-file" "\
-
-
-\(fn)" t nil)
-
-(autoload 'epa-file-disable "epa-file" "\
-
+(autoload 'epa-file-enable "epa-file" nil t nil)
-\(fn)" t nil)
+(autoload 'epa-file-disable "epa-file" nil t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "epa-file" '("epa-")))
@@ -10459,25 +10319,23 @@ Encrypt marked files.
(autoload 'epa-mail-mode "epa-mail" "\
A minor-mode for composing encrypted/clearsigned mails.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
+
+If called interactively, enable epa-mail mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
\(fn &optional ARG)" t nil)
(autoload 'epa-mail-decrypt "epa-mail" "\
Decrypt OpenPGP armors in the current buffer.
-The buffer is expected to contain a mail message.
-
-\(fn)" t nil)
+The buffer is expected to contain a mail message." t nil)
(function-put 'epa-mail-decrypt 'interactive-only 't)
(autoload 'epa-mail-verify "epa-mail" "\
Verify OpenPGP cleartext signed messages in the current buffer.
-The buffer is expected to contain a mail message.
-
-\(fn)" t nil)
+The buffer is expected to contain a mail message." t nil)
(function-put 'epa-mail-verify 'interactive-only 't)
@@ -10506,9 +10364,7 @@ SIGNERS is a list of keys to sign the message with.
(autoload 'epa-mail-import-keys "epa-mail" "\
Import keys in the OpenPGP armor format in the current buffer.
-The buffer is expected to contain a mail message.
-
-\(fn)" t nil)
+The buffer is expected to contain a mail message." t nil)
(function-put 'epa-mail-import-keys 'interactive-only 't)
@@ -10524,9 +10380,11 @@ or call the function `epa-global-mail-mode'.")
(autoload 'epa-global-mail-mode "epa-mail" "\
Minor mode to hook EasyPG into Mail mode.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
+
+If called interactively, enable Epa-Global-Mail mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
\(fn &optional ARG)" t nil)
@@ -10564,16 +10422,19 @@ version requirement is met.
\(fn PROTOCOL &optional NO-CACHE PROGRAM-ALIST)" nil nil)
(autoload 'epg-configuration "epg-config" "\
-Return a list of internal configuration parameters of `epg-gpg-program'.
-
-\(fn)" nil nil)
+Return a list of internal configuration parameters of `epg-gpg-program'." nil nil)
(make-obsolete 'epg-configuration 'epg-find-configuration '"25.1")
(autoload 'epg-check-configuration "epg-config" "\
Verify that a sufficient version of GnuPG is installed.
+CONFIG should be a `epg-configuration' object (a plist).
+REQ-VERSIONS should be a list with elements of the form (MIN
+. MAX) where MIN and MAX are version strings indicating a
+semi-open range of acceptable versions. REQ-VERSIONS may also be
+a single minimum version string.
-\(fn CONFIG &optional MINIMUM-VERSION)" nil nil)
+\(fn CONFIG &optional REQ-VERSIONS)" nil nil)
(autoload 'epg-expand-group "epg-config" "\
Look at CONFIG and try to expand GROUP.
@@ -10589,9 +10450,7 @@ Look at CONFIG and try to expand GROUP.
(push (purecopy '(erc 5 3)) package--builtin-versions)
(autoload 'erc-select-read-args "erc" "\
-Prompt the user for values of nick, server, port, and password.
-
-\(fn)" nil nil)
+Prompt the user for values of nick, server, port, and password." nil nil)
(autoload 'erc "erc" "\
ERC is a powerful, modular, and extensible IRC client.
@@ -10631,14 +10490,13 @@ Otherwise, connect to HOST:PORT as USER and /join CHANNEL.
\(fn HOST PORT CHANNEL USER PASSWORD)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc" '("erc-" "define-erc-module")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc" '("define-erc-module" "erc-")))
;;;***
-;;;### (autoloads nil "erc-autoaway" "erc/erc-autoaway.el" (0 0 0
-;;;;;; 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-autoaway"
+;;;;;; "erc/erc-autoaway.el" (0 0 0 0))
;;; Generated autoloads from erc/erc-autoaway.el
- (autoload 'erc-autoaway-mode "erc-autoaway")
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-autoaway" '("erc-auto")))
@@ -10651,144 +10509,57 @@ Otherwise, connect to HOST:PORT as USER and /join CHANNEL.
;;;***
-;;;### (autoloads nil "erc-button" "erc/erc-button.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-button" "erc/erc-button.el"
+;;;;;; (0 0 0 0))
;;; Generated autoloads from erc/erc-button.el
- (autoload 'erc-button-mode "erc-button" nil t)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-button" '("erc-")))
;;;***
-;;;### (autoloads nil "erc-capab" "erc/erc-capab.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-capab" "erc/erc-capab.el"
+;;;;;; (0 0 0 0))
;;; Generated autoloads from erc/erc-capab.el
- (autoload 'erc-capab-identify-mode "erc-capab" nil t)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-capab" '("erc-capab-identify-")))
;;;***
-;;;### (autoloads nil "erc-compat" "erc/erc-compat.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-compat" "erc/erc-compat.el"
+;;;;;; (0 0 0 0))
;;; Generated autoloads from erc/erc-compat.el
- (autoload 'erc-define-minor-mode "erc-compat")
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-compat" '("erc-")))
;;;***
-;;;### (autoloads nil "erc-dcc" "erc/erc-dcc.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-dcc" "erc/erc-dcc.el"
+;;;;;; (0 0 0 0))
;;; Generated autoloads from erc/erc-dcc.el
- (autoload 'erc-dcc-mode "erc-dcc")
-
-(autoload 'erc-cmd-DCC "erc-dcc" "\
-Parser for /dcc command.
-This figures out the dcc subcommand and calls the appropriate routine to
-handle it. The function dispatched should be named \"erc-dcc-do-FOO-command\",
-where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc.
-
-\(fn CMD &rest ARGS)" nil nil)
-
-(autoload 'pcomplete/erc-mode/DCC "erc-dcc" "\
-Provides completion for the /DCC command.
-
-\(fn)" nil nil)
-
-(defvar erc-ctcp-query-DCC-hook '(erc-ctcp-query-DCC) "\
-Hook variable for CTCP DCC queries.")
-
-(autoload 'erc-ctcp-query-DCC "erc-dcc" "\
-The function called when a CTCP DCC request is detected by the client.
-It examines the DCC subcommand, and calls the appropriate routine for
-that subcommand.
-
-\(fn PROC NICK LOGIN HOST TO QUERY)" nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-dcc" '("erc-" "pcomplete/erc-mode/")))
;;;***
-;;;### (autoloads nil "erc-desktop-notifications" "erc/erc-desktop-notifications.el"
-;;;;;; (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-desktop-notifications"
+;;;;;; "erc/erc-desktop-notifications.el" (0 0 0 0))
;;; Generated autoloads from erc/erc-desktop-notifications.el
-(autoload 'erc-notifications-mode "erc-desktop-notifications" "" t)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-desktop-notifications" '("erc-notifications-")))
;;;***
-;;;### (autoloads nil "erc-ezbounce" "erc/erc-ezbounce.el" (0 0 0
-;;;;;; 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-ezbounce"
+;;;;;; "erc/erc-ezbounce.el" (0 0 0 0))
;;; Generated autoloads from erc/erc-ezbounce.el
-(autoload 'erc-cmd-ezb "erc-ezbounce" "\
-Send EZB commands to the EZBouncer verbatim.
-
-\(fn LINE &optional FORCE)" nil nil)
-
-(autoload 'erc-ezb-get-login "erc-ezbounce" "\
-Return an appropriate EZBounce login for SERVER and PORT.
-Look up entries in `erc-ezb-login-alist'. If the username or password
-in the alist is nil, prompt for the appropriate values.
-
-\(fn SERVER PORT)" nil nil)
-
-(autoload 'erc-ezb-lookup-action "erc-ezbounce" "\
-
-
-\(fn MESSAGE)" nil nil)
-
-(autoload 'erc-ezb-notice-autodetect "erc-ezbounce" "\
-React on an EZBounce NOTICE request.
-
-\(fn PROC PARSED)" nil nil)
-
-(autoload 'erc-ezb-identify "erc-ezbounce" "\
-Identify to the EZBouncer server.
-
-\(fn MESSAGE)" nil nil)
-
-(autoload 'erc-ezb-init-session-list "erc-ezbounce" "\
-Reset the EZBounce session list to nil.
-
-\(fn MESSAGE)" nil nil)
-
-(autoload 'erc-ezb-end-of-session-list "erc-ezbounce" "\
-Indicate the end of the EZBounce session listing.
-
-\(fn MESSAGE)" nil nil)
-
-(autoload 'erc-ezb-add-session "erc-ezbounce" "\
-Add an EZBounce session to the session list.
-
-\(fn MESSAGE)" nil nil)
-
-(autoload 'erc-ezb-select "erc-ezbounce" "\
-Select an IRC server to use by EZBounce, in ERC style.
-
-\(fn MESSAGE)" nil nil)
-
-(autoload 'erc-ezb-select-session "erc-ezbounce" "\
-Select a detached EZBounce session.
-
-\(fn)" nil nil)
-
-(autoload 'erc-ezb-initialize "erc-ezbounce" "\
-Add EZBouncer convenience functions to ERC.
-
-\(fn)" nil nil)
-
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-ezbounce" '("erc-ezb-")))
;;;***
-;;;### (autoloads nil "erc-fill" "erc/erc-fill.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-fill" "erc/erc-fill.el"
+;;;;;; (0 0 0 0))
;;; Generated autoloads from erc/erc-fill.el
- (autoload 'erc-fill-mode "erc-fill" nil t)
-
-(autoload 'erc-fill "erc-fill" "\
-Fill a region using the function referenced in `erc-fill-function'.
-You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'.
-
-\(fn)" nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-fill" '("erc-")))
@@ -10808,44 +10579,25 @@ You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'.
;;;***
-;;;### (autoloads nil "erc-identd" "erc/erc-identd.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-identd" "erc/erc-identd.el"
+;;;;;; (0 0 0 0))
;;; Generated autoloads from erc/erc-identd.el
- (autoload 'erc-identd-mode "erc-identd")
-
-(autoload 'erc-identd-start "erc-identd" "\
-Start an identd server listening to port 8113.
-Port 113 (auth) will need to be redirected to port 8113 on your
-machine -- using iptables, or a program like redir which can be
-run from inetd. The idea is to provide a simple identd server
-when you need one, without having to install one globally on your
-system.
-
-\(fn &optional PORT)" t nil)
-
-(autoload 'erc-identd-stop "erc-identd" "\
-
-
-\(fn &rest IGNORE)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-identd" '("erc-identd-")))
;;;***
-;;;### (autoloads nil "erc-imenu" "erc/erc-imenu.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-imenu" "erc/erc-imenu.el"
+;;;;;; (0 0 0 0))
;;; Generated autoloads from erc/erc-imenu.el
-(autoload 'erc-create-imenu-index "erc-imenu" "\
-
-
-\(fn)" nil nil)
-
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-imenu" '("erc-unfill-notice")))
;;;***
-;;;### (autoloads nil "erc-join" "erc/erc-join.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-join" "erc/erc-join.el"
+;;;;;; (0 0 0 0))
;;; Generated autoloads from erc/erc-join.el
- (autoload 'erc-autojoin-mode "erc-join" nil t)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-join" '("erc-")))
@@ -10854,114 +10606,45 @@ system.
;;;### (autoloads nil "erc-lang" "erc/erc-lang.el" (0 0 0 0))
;;; Generated autoloads from erc/erc-lang.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-lang" '("erc-cmd-LANG" "language" "iso-638-languages")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-lang" '("erc-cmd-LANG" "iso-638-languages" "language")))
;;;***
-;;;### (autoloads nil "erc-list" "erc/erc-list.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-list" "erc/erc-list.el"
+;;;;;; (0 0 0 0))
;;; Generated autoloads from erc/erc-list.el
- (autoload 'erc-list-mode "erc-list")
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-list" '("erc-")))
;;;***
-;;;### (autoloads nil "erc-log" "erc/erc-log.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-log" "erc/erc-log.el"
+;;;;;; (0 0 0 0))
;;; Generated autoloads from erc/erc-log.el
- (autoload 'erc-log-mode "erc-log" nil t)
-
-(autoload 'erc-logging-enabled "erc-log" "\
-Return non-nil if logging is enabled for BUFFER.
-If BUFFER is nil, the value of `current-buffer' is used.
-Logging is enabled if `erc-log-channels-directory' is non-nil, the directory
-is writable (it will be created as necessary) and
-`erc-enable-logging' returns a non-nil value.
-
-\(fn &optional BUFFER)" nil nil)
-
-(autoload 'erc-save-buffer-in-logs "erc-log" "\
-Append BUFFER contents to the log file, if logging is enabled.
-If BUFFER is not provided, current buffer is used.
-Logging is enabled if `erc-logging-enabled' returns non-nil.
-
-This is normally done on exit, to save the unsaved portion of the
-buffer, since only the text that runs off the buffer limit is logged
-automatically.
-
-You can save every individual message by putting this function on
-`erc-insert-post-hook'.
-
-\(fn &optional BUFFER)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-log" '("erc-")))
;;;***
-;;;### (autoloads nil "erc-match" "erc/erc-match.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-match" "erc/erc-match.el"
+;;;;;; (0 0 0 0))
;;; Generated autoloads from erc/erc-match.el
- (autoload 'erc-match-mode "erc-match")
-
-(autoload 'erc-add-pal "erc-match" "\
-Add pal interactively to `erc-pals'.
-
-\(fn)" t nil)
-
-(autoload 'erc-delete-pal "erc-match" "\
-Delete pal interactively to `erc-pals'.
-
-\(fn)" t nil)
-
-(autoload 'erc-add-fool "erc-match" "\
-Add fool interactively to `erc-fools'.
-
-\(fn)" t nil)
-
-(autoload 'erc-delete-fool "erc-match" "\
-Delete fool interactively to `erc-fools'.
-
-\(fn)" t nil)
-
-(autoload 'erc-add-keyword "erc-match" "\
-Add keyword interactively to `erc-keywords'.
-
-\(fn)" t nil)
-
-(autoload 'erc-delete-keyword "erc-match" "\
-Delete keyword interactively to `erc-keywords'.
-
-\(fn)" t nil)
-
-(autoload 'erc-add-dangerous-host "erc-match" "\
-Add dangerous-host interactively to `erc-dangerous-hosts'.
-
-\(fn)" t nil)
-
-(autoload 'erc-delete-dangerous-host "erc-match" "\
-Delete dangerous-host interactively to `erc-dangerous-hosts'.
-
-\(fn)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-match" '("erc-")))
;;;***
-;;;### (autoloads nil "erc-menu" "erc/erc-menu.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-menu" "erc/erc-menu.el"
+;;;;;; (0 0 0 0))
;;; Generated autoloads from erc/erc-menu.el
- (autoload 'erc-menu-mode "erc-menu" nil t)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-menu" '("erc-menu-")))
;;;***
-;;;### (autoloads nil "erc-netsplit" "erc/erc-netsplit.el" (0 0 0
-;;;;;; 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-netsplit"
+;;;;;; "erc/erc-netsplit.el" (0 0 0 0))
;;; Generated autoloads from erc/erc-netsplit.el
- (autoload 'erc-netsplit-mode "erc-netsplit")
-
-(autoload 'erc-cmd-WHOLEFT "erc-netsplit" "\
-Show who's gone.
-
-\(fn)" nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-netsplit" '("erc-")))
@@ -10974,189 +10657,114 @@ Show who's gone.
(autoload 'erc-determine-network "erc-networks" "\
Return the name of the network or \"Unknown\" as a symbol. Use the
server parameter NETWORK if provided, otherwise parse the server name and
-search for a match in `erc-networks-alist'.
-
-\(fn)" nil nil)
+search for a match in `erc-networks-alist'." nil nil)
(autoload 'erc-server-select "erc-networks" "\
-Interactively select a server to connect to using `erc-server-alist'.
-
-\(fn)" t nil)
+Interactively select a server to connect to using `erc-server-alist'." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-networks" '("erc-")))
;;;***
-;;;### (autoloads nil "erc-notify" "erc/erc-notify.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-notify" "erc/erc-notify.el"
+;;;;;; (0 0 0 0))
;;; Generated autoloads from erc/erc-notify.el
- (autoload 'erc-notify-mode "erc-notify" nil t)
-
-(autoload 'erc-cmd-NOTIFY "erc-notify" "\
-Change `erc-notify-list' or list current notify-list members online.
-Without args, list the current list of notified people online,
-with args, toggle notify status of people.
-
-\(fn &rest ARGS)" nil nil)
-
-(autoload 'pcomplete/erc-mode/NOTIFY "erc-notify" "\
-
-
-\(fn)" nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-notify" '("erc-")))
;;;***
-;;;### (autoloads nil "erc-page" "erc/erc-page.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-page" "erc/erc-page.el"
+;;;;;; (0 0 0 0))
;;; Generated autoloads from erc/erc-page.el
- (autoload 'erc-page-mode "erc-page")
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-page" '("erc-")))
;;;***
-;;;### (autoloads nil "erc-pcomplete" "erc/erc-pcomplete.el" (0 0
-;;;;;; 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-pcomplete"
+;;;;;; "erc/erc-pcomplete.el" (0 0 0 0))
;;; Generated autoloads from erc/erc-pcomplete.el
- (autoload 'erc-completion-mode "erc-pcomplete" nil t)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-pcomplete" '("pcomplete" "erc-pcomplet")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-pcomplete" '("erc-pcomplet" "pcomplete")))
;;;***
-;;;### (autoloads nil "erc-replace" "erc/erc-replace.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-replace"
+;;;;;; "erc/erc-replace.el" (0 0 0 0))
;;; Generated autoloads from erc/erc-replace.el
- (autoload 'erc-replace-mode "erc-replace")
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-replace" '("erc-replace-")))
;;;***
-;;;### (autoloads nil "erc-ring" "erc/erc-ring.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-ring" "erc/erc-ring.el"
+;;;;;; (0 0 0 0))
;;; Generated autoloads from erc/erc-ring.el
- (autoload 'erc-ring-mode "erc-ring" nil t)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-ring" '("erc-")))
;;;***
-;;;### (autoloads nil "erc-services" "erc/erc-services.el" (0 0 0
-;;;;;; 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-services"
+;;;;;; "erc/erc-services.el" (0 0 0 0))
;;; Generated autoloads from erc/erc-services.el
- (autoload 'erc-services-mode "erc-services" nil t)
-
-(autoload 'erc-nickserv-identify-mode "erc-services" "\
-Set up hooks according to which MODE the user has chosen.
-
-\(fn MODE)" t nil)
-
-(autoload 'erc-nickserv-identify "erc-services" "\
-Send an \"identify <PASSWORD>\" message to NickServ.
-When called interactively, read the password using `read-passwd'.
-
-\(fn PASSWORD)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-services" '("erc-")))
;;;***
-;;;### (autoloads nil "erc-sound" "erc/erc-sound.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-sound" "erc/erc-sound.el"
+;;;;;; (0 0 0 0))
;;; Generated autoloads from erc/erc-sound.el
- (autoload 'erc-sound-mode "erc-sound")
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-sound" '("erc-")))
;;;***
-;;;### (autoloads nil "erc-speedbar" "erc/erc-speedbar.el" (0 0 0
-;;;;;; 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-speedbar"
+;;;;;; "erc/erc-speedbar.el" (0 0 0 0))
;;; Generated autoloads from erc/erc-speedbar.el
-(autoload 'erc-speedbar-browser "erc-speedbar" "\
-Initialize speedbar to display an ERC browser.
-This will add a speedbar major display mode.
-
-\(fn)" t nil)
-
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-speedbar" '("erc-")))
;;;***
-;;;### (autoloads nil "erc-spelling" "erc/erc-spelling.el" (0 0 0
-;;;;;; 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-spelling"
+;;;;;; "erc/erc-spelling.el" (0 0 0 0))
;;; Generated autoloads from erc/erc-spelling.el
- (autoload 'erc-spelling-mode "erc-spelling" nil t)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-spelling" '("erc-spelling-")))
;;;***
-;;;### (autoloads nil "erc-stamp" "erc/erc-stamp.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-stamp" "erc/erc-stamp.el"
+;;;;;; (0 0 0 0))
;;; Generated autoloads from erc/erc-stamp.el
- (autoload 'erc-timestamp-mode "erc-stamp" nil t)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-stamp" '("erc-")))
;;;***
-;;;### (autoloads nil "erc-track" "erc/erc-track.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-track" "erc/erc-track.el"
+;;;;;; (0 0 0 0))
;;; Generated autoloads from erc/erc-track.el
-(defvar erc-track-minor-mode nil "\
-Non-nil if Erc-Track minor mode is enabled.
-See the `erc-track-minor-mode' command
-for a description of this minor mode.")
-
-(custom-autoload 'erc-track-minor-mode "erc-track" nil)
-
-(autoload 'erc-track-minor-mode "erc-track" "\
-Toggle mode line display of ERC activity (ERC Track minor mode).
-With a prefix argument ARG, enable ERC Track minor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
-
-ERC Track minor mode is a global minor mode. It exists for the
-sole purpose of providing the C-c C-SPC and C-c C-@ keybindings.
-Make sure that you have enabled the track module, otherwise the
-keybindings will not do anything useful.
-
-\(fn &optional ARG)" t nil)
- (autoload 'erc-track-mode "erc-track" nil t)
-
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-track" '("erc-")))
;;;***
-;;;### (autoloads nil "erc-truncate" "erc/erc-truncate.el" (0 0 0
-;;;;;; 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-truncate"
+;;;;;; "erc/erc-truncate.el" (0 0 0 0))
;;; Generated autoloads from erc/erc-truncate.el
- (autoload 'erc-truncate-mode "erc-truncate" nil t)
-
-(autoload 'erc-truncate-buffer-to-size "erc-truncate" "\
-Truncates the buffer to the size SIZE.
-If BUFFER is not provided, the current buffer is assumed. The deleted
-region is logged if `erc-logging-enabled' returns non-nil.
-
-\(fn SIZE &optional BUFFER)" nil nil)
-
-(autoload 'erc-truncate-buffer "erc-truncate" "\
-Truncates the current buffer to `erc-max-buffer-size'.
-Meant to be used in hooks, like `erc-insert-post-hook'.
-
-\(fn)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-truncate" '("erc-max-buffer-size")))
;;;***
-;;;### (autoloads nil "erc-xdcc" "erc/erc-xdcc.el" (0 0 0 0))
+;;;### (autoloads "actual autoloads are elsewhere" "erc-xdcc" "erc/erc-xdcc.el"
+;;;;;; (0 0 0 0))
;;; Generated autoloads from erc/erc-xdcc.el
- (autoload 'erc-xdcc-mode "erc-xdcc")
-
-(autoload 'erc-xdcc-add-file "erc-xdcc" "\
-Add a file to `erc-xdcc-files'.
-
-\(fn FILE)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-xdcc" '("erc-")))
@@ -11239,9 +10847,7 @@ Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test).
(put 'ert-with-test-buffer 'lisp-indent-function 1)
(autoload 'ert-kill-all-test-buffers "ert-x" "\
-Kill all test buffers that are still live.
-
-\(fn)" t nil)
+Kill all test buffers that are still live." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ert-x" '("ert-")))
@@ -11455,14 +11061,9 @@ Returns t if it visits a tags table, or nil if there are no more in the list.
Return a list of files in the current tags table.
Assumes the tags table is the current buffer. The file names are returned
as they appeared in the `etags' command that created the table, usually
-without directory names.
-
-\(fn)" nil nil)
-
-(autoload 'tags-lazy-completion-table "etags" "\
+without directory names." nil nil)
-
-\(fn)" nil nil)
+(autoload 'tags-lazy-completion-table "etags" nil nil nil)
(defun tags-completion-at-point-function ()
(if (or tags-table-list tags-file-name)
(progn
@@ -11586,7 +11187,9 @@ See documentation of variable `tags-file-name'.
(defalias 'pop-tag-mark 'xref-pop-marker-stack)
-(autoload 'next-file "etags" "\
+(defalias 'next-file 'tags-next-file)
+
+(autoload 'tags-next-file "etags" "\
Select next file among files in current tags table.
A first argument of t (prefix arg, if interactive) initializes to the
@@ -11606,40 +11209,32 @@ Continue last \\[tags-search] or \\[tags-query-replace] command.
Used noninteractively with non-nil argument to begin such a command (the
argument is passed to `next-file', which see).
-Two variables control the processing we do on each file: the value of
-`tags-loop-scan' is a form to be executed on each file to see if it is
-interesting (it returns non-nil if so) and `tags-loop-operate' is a form to
-evaluate to operate on an interesting file. If the latter evaluates to
-nil, we exit; otherwise we scan the next file.
-
\(fn &optional FIRST-TIME)" t nil)
+(make-obsolete 'tags-loop-continue 'fileloop-continue '"27.1")
+
(autoload 'tags-search "etags" "\
Search through all files listed in tags table for match for REGEXP.
Stops when a match is found.
To continue searching for next match, use command \\[tags-loop-continue].
-If FILE-LIST-FORM is non-nil, it should be a form that, when
-evaluated, will return a list of file names. The search will be
-restricted to these files.
+If FILES if non-nil should be a list or an iterator returning the files to search.
+The search will be restricted to these files.
Also see the documentation of the `tags-file-name' variable.
-\(fn REGEXP &optional FILE-LIST-FORM)" t nil)
+\(fn REGEXP &optional FILES)" t nil)
(autoload 'tags-query-replace "etags" "\
Do `query-replace-regexp' of FROM with TO on all files listed in tags table.
Third arg DELIMITED (prefix arg) means replace only word-delimited matches.
If you exit (\\[keyboard-quit], RET or q), you can resume the query replace
with the command \\[tags-loop-continue].
-Fourth arg FILE-LIST-FORM non-nil means initialize the replacement loop.
+For non-interactive use, superceded by `fileloop-initialize-replace'.
-If FILE-LIST-FORM is non-nil, it is a form to evaluate to
-produce the list of files to search.
+\(fn FROM TO &optional DELIMITED FILES)" t nil)
-See also the documentation of the variable `tags-file-name'.
-
-\(fn FROM TO &optional DELIMITED FILE-LIST-FORM)" t nil)
+(set-advertised-calling-convention 'tags-query-replace '(from to &optional delimited) '"27.1")
(autoload 'list-tags "etags" "\
Display list of tags in file FILE.
@@ -11659,24 +11254,17 @@ Display list of all tags in tags table REGEXP matches.
(autoload 'select-tags-table "etags" "\
Select a tags table file from a menu of those you have already used.
The list of tags tables to select from is stored in `tags-table-set-list';
-see the doc of that variable if you want to add names to the list.
-
-\(fn)" t nil)
+see the doc of that variable if you want to add names to the list." t nil)
(autoload 'complete-tag "etags" "\
Perform tags completion on the text around point.
Completes to the set of names listed in the current tags table.
The string to complete is chosen in the same way as the default
-for \\[find-tag] (which see).
+for \\[find-tag] (which see)." t nil)
-\(fn)" t nil)
-
-(autoload 'etags--xref-backend "etags" "\
+(autoload 'etags--xref-backend "etags" nil nil nil)
-
-\(fn)" nil nil)
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "etags" '("xref-" "etags-" "snarf-tag-function" "select-tags-table-" "tag" "file-of-tag" "find-tag-" "list-tags-function" "last-tag" "initialize-new-tags-table" "verify-tags-table-function" "goto-tag-location-function" "next-file-list" "default-tags-table-function")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "etags" '("default-tags-table-function" "etags-" "file-of-tag" "find-tag-" "goto-tag-location-function" "initialize-new-tags-table" "last-tag" "list-tags-function" "select-tags-table-" "snarf-tag-function" "tag" "verify-tags-table-function" "xref-")))
;;;***
@@ -11684,10 +11272,7 @@ for \\[find-tag] (which see).
;;;;;; 0 0))
;;; Generated autoloads from language/ethio-util.el
-(autoload 'setup-ethiopic-environment-internal "ethio-util" "\
-
-
-\(fn)" nil nil)
+(autoload 'setup-ethiopic-environment-internal "ethio-util" nil nil nil)
(autoload 'ethio-sera-to-fidel-buffer "ethio-util" "\
Convert the current buffer from SERA to FIDEL.
@@ -11776,9 +11361,7 @@ The markers \"<sera>\" and \"</sera>\" themselves are not deleted.
\(fn &optional FORCE)" t nil)
(autoload 'ethio-modify-vowel "ethio-util" "\
-Modify the vowel of the FIDEL that is under the cursor.
-
-\(fn)" t nil)
+Modify the vowel of the FIDEL that is under the cursor." t nil)
(autoload 'ethio-replace-space "ethio-util" "\
Replace ASCII spaces with Ethiopic word separators in the region.
@@ -11801,14 +11384,10 @@ This function is deprecated.
\(fn ARG)" t nil)
(autoload 'ethio-fidel-to-tex-buffer "ethio-util" "\
-Convert each fidel characters in the current buffer into a fidel-tex command.
-
-\(fn)" t nil)
+Convert each fidel characters in the current buffer into a fidel-tex command." t nil)
(autoload 'ethio-tex-to-fidel-buffer "ethio-util" "\
-Convert fidel-tex commands in the current buffer into fidel chars.
-
-\(fn)" t nil)
+Convert fidel-tex commands in the current buffer into fidel chars." t nil)
(autoload 'ethio-fidel-to-java-buffer "ethio-util" "\
Convert Ethiopic characters into the Java escape sequences.
@@ -11817,24 +11396,16 @@ Each escape sequence is of the form \\uXXXX, where XXXX is the
character's codepoint (in hex) in Unicode.
If `ethio-java-save-lowercase' is non-nil, use [0-9a-f].
-Otherwise, [0-9A-F].
-
-\(fn)" nil nil)
+Otherwise, [0-9A-F]." nil nil)
(autoload 'ethio-java-to-fidel-buffer "ethio-util" "\
-Convert the Java escape sequences into corresponding Ethiopic characters.
-
-\(fn)" nil nil)
+Convert the Java escape sequences into corresponding Ethiopic characters." nil nil)
(autoload 'ethio-find-file "ethio-util" "\
-Transliterate file content into Ethiopic depending on filename suffix.
-
-\(fn)" nil nil)
+Transliterate file content into Ethiopic depending on filename suffix." nil nil)
(autoload 'ethio-write-file "ethio-util" "\
-Transliterate Ethiopic characters in ASCII depending on the file extension.
-
-\(fn)" nil nil)
+Transliterate Ethiopic characters in ASCII depending on the file extension." nil nil)
(autoload 'ethio-insert-ethio-space "ethio-util" "\
Insert the Ethiopic word delimiter (the colon-like character).
@@ -11847,7 +11418,7 @@ With ARG, insert that many delimiters.
\(fn POS TO FONT-OBJECT STRING)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ethio-util" '("exit-ethiopic-environment" "ethio-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ethio-util" '("ethio-" "exit-ethiopic-environment")))
;;;***
@@ -11897,11 +11468,11 @@ queries the server for the existing fields and displays a corresponding form.
(autoload 'eudc-load-eudc "eudc" "\
Load the Emacs Unified Directory Client.
-This does nothing except loading eudc by autoload side-effect.
+This does nothing except loading eudc by autoload side-effect." t nil)
-\(fn)" t nil)
+(defvar eudc-tools-menu (let ((map (make-sparse-keymap "Directory Servers"))) (define-key map [phone] `(menu-item ,(purecopy "Get Phone") eudc-get-phone :help ,(purecopy "Get the phone field of name from the directory server"))) (define-key map [email] `(menu-item ,(purecopy "Get Email") eudc-get-email :help ,(purecopy "Get the email field of NAME from the directory server"))) (define-key map [separator-eudc-email] menu-bar-separator) (define-key map [expand-inline] `(menu-item ,(purecopy "Expand Inline Query") eudc-expand-inline :help ,(purecopy "Query the directory server, and expand the query string before point"))) (define-key map [query] `(menu-item ,(purecopy "Query with Form") eudc-query-form :help ,(purecopy "Display a form to query the directory server"))) (define-key map [separator-eudc-query] menu-bar-separator) (define-key map [new] `(menu-item ,(purecopy "New Server") eudc-set-server :help ,(purecopy "Set the directory server to SERVER using PROTOCOL"))) (define-key map [load] `(menu-item ,(purecopy "Load Hotlist of Servers") eudc-load-eudc :help ,(purecopy "Load the Emacs Unified Directory Client"))) map))
-(cond ((not (featurep 'xemacs)) (defvar eudc-tools-menu (let ((map (make-sparse-keymap "Directory Servers"))) (define-key map [phone] `(menu-item ,(purecopy "Get Phone") eudc-get-phone :help ,(purecopy "Get the phone field of name from the directory server"))) (define-key map [email] `(menu-item ,(purecopy "Get Email") eudc-get-email :help ,(purecopy "Get the email field of NAME from the directory server"))) (define-key map [separator-eudc-email] menu-bar-separator) (define-key map [expand-inline] `(menu-item ,(purecopy "Expand Inline Query") eudc-expand-inline :help ,(purecopy "Query the directory server, and expand the query string before point"))) (define-key map [query] `(menu-item ,(purecopy "Query with Form") eudc-query-form :help ,(purecopy "Display a form to query the directory server"))) (define-key map [separator-eudc-query] menu-bar-separator) (define-key map [new] `(menu-item ,(purecopy "New Server") eudc-set-server :help ,(purecopy "Set the directory server to SERVER using PROTOCOL"))) (define-key map [load] `(menu-item ,(purecopy "Load Hotlist of Servers") eudc-load-eudc :help ,(purecopy "Load the Emacs Unified Directory Client"))) map)) (fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu))) (t (let ((menu '("Directory Servers" ["Load Hotlist of Servers" eudc-load-eudc t] ["New Server" eudc-set-server t] ["---" nil nil] ["Query with Form" eudc-query-form t] ["Expand Inline Query" eudc-expand-inline t] ["---" nil nil] ["Get Email" eudc-get-email t] ["Get Phone" eudc-get-phone t]))) (if (not (featurep 'eudc-autoloads)) (if (featurep 'xemacs) (if (and (featurep 'menubar) (not (featurep 'infodock))) (add-submenu '("Tools") menu)) (require 'easymenu) (cond ((fboundp 'easy-menu-add-item) (easy-menu-add-item nil '("tools") (easy-menu-create-menu (car menu) (cdr menu)))) ((fboundp 'easy-menu-create-keymaps) (define-key global-map [menu-bar tools eudc] (cons "Directory Servers" (easy-menu-create-keymaps "Directory Servers" (cdr menu)))))))))))
+(fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu))
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eudc" '("eudc-")))
@@ -11949,14 +11520,10 @@ Display a button for the JPEG DATA.
(autoload 'eudc-insert-record-at-point-into-bbdb "eudc-export" "\
Insert record at point into the BBDB database.
-This function can only be called from a directory query result buffer.
-
-\(fn)" t nil)
+This function can only be called from a directory query result buffer." t nil)
(autoload 'eudc-try-bbdb-insert "eudc-export" "\
-Call `eudc-insert-record-at-point-into-bbdb' if on a record.
-
-\(fn)" t nil)
+Call `eudc-insert-record-at-point-into-bbdb' if on a record." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eudc-export" '("eudc-")))
@@ -11967,9 +11534,7 @@ Call `eudc-insert-record-at-point-into-bbdb' if on a record.
;;; Generated autoloads from net/eudc-hotlist.el
(autoload 'eudc-edit-hotlist "eudc-hotlist" "\
-Edit the hotlist of directory servers in a specialized buffer.
-
-\(fn)" t nil)
+Edit the hotlist of directory servers in a specialized buffer." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eudc-hotlist" '("eudc-hotlist-")))
@@ -12047,7 +11612,10 @@ Fetch URL and render the page.
If the input doesn't look like an URL or a domain name, the
word(s) will be searched for via `eww-search-prefix'.
-\(fn URL)" t nil)
+If called with a prefix ARG, use a new buffer instead of reusing
+the default EWW buffer.
+
+\(fn URL &optional ARG)" t nil)
(defalias 'browse-web 'eww)
(autoload 'eww-open-file "eww" "\
@@ -12060,9 +11628,7 @@ Search the web for the text between BEG and END.
If region is active (and not whitespace), search the web for
the text between BEG and END. Else, prompt the user for a search
string. See the `eww-search-prefix' variable for the search
-engine used.
-
-\(fn)" t nil)
+engine used." t nil)
(autoload 'eww-mode "eww" "\
Mode for browsing the web.
@@ -12075,9 +11641,7 @@ Mode for browsing the web.
\(fn URL &optional NEW-WINDOW)" nil nil)
(autoload 'eww-list-bookmarks "eww" "\
-Display the bookmarks.
-
-\(fn)" t nil)
+Display the bookmarks." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eww" '("eww-")))
@@ -12113,9 +11677,7 @@ executable.
(autoload 'executable-make-buffer-file-executable-if-script-p "executable" "\
Make file executable according to umask if not already executable.
If file already has any execute bits set at all, do not change existing
-file modes.
-
-\(fn)" nil nil)
+file modes." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "executable" '("executable-")))
@@ -12150,21 +11712,15 @@ If ARG is omitted, point is placed at the end of the expanded text.
(autoload 'expand-abbrev-hook "expand" "\
Abbrev hook used to do the expansion job of expand abbrevs.
-See `expand-add-abbrevs'. Value is non-nil if expansion was done.
-
-\(fn)" nil nil)
+See `expand-add-abbrevs'. Value is non-nil if expansion was done." nil nil)
(autoload 'expand-jump-to-previous-slot "expand" "\
Move the cursor to the previous slot in the last abbrev expansion.
-This is used only in conjunction with `expand-add-abbrevs'.
-
-\(fn)" t nil)
+This is used only in conjunction with `expand-add-abbrevs'." t nil)
(autoload 'expand-jump-to-next-slot "expand" "\
Move the cursor to the next slot in the last abbrev expansion.
-This is used only in conjunction with `expand-add-abbrevs'.
-
-\(fn)" t nil)
+This is used only in conjunction with `expand-add-abbrevs'." t nil)
(define-key abbrev-map "p" 'expand-jump-to-previous-slot)
(define-key abbrev-map "n" 'expand-jump-to-next-slot)
@@ -12361,10 +11917,14 @@ a top-level keymap, `text-scale-increase' or
(autoload 'buffer-face-mode "face-remap" "\
Minor mode for a buffer-specific default face.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil. When enabled, the face specified by the
-variable `buffer-face-mode-face' is used to display the buffer text.
+
+If called interactively, enable Buffer-Face mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
+When enabled, the face specified by the variable
+`buffer-face-mode-face' is used to display the buffer text.
\(fn &optional ARG)" t nil)
@@ -12405,7 +11965,46 @@ Besides the choice of face, it is the same as `buffer-face-mode'.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "face-remap" '("buffer-face-mode-" "text-scale-m" "face-" "internal-lisp-face-attributes")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "face-remap" '("buffer-face-mode-" "face-" "internal-lisp-face-attributes" "text-scale-m")))
+
+;;;***
+
+;;;### (autoloads nil "faceup" "emacs-lisp/faceup.el" (0 0 0 0))
+;;; Generated autoloads from emacs-lisp/faceup.el
+(push (purecopy '(faceup 0 0 6)) package--builtin-versions)
+
+(autoload 'faceup-view-buffer "faceup" "\
+Display the faceup representation of the current buffer." t nil)
+
+(autoload 'faceup-write-file "faceup" "\
+Save the faceup representation of the current buffer to the file FILE-NAME.
+
+Unless a name is given, the file will be named xxx.faceup, where
+xxx is the file name associated with the buffer.
+
+If optional second arg CONFIRM is non-nil, this function
+asks for confirmation before overwriting an existing file.
+Interactively, confirmation is required unless you supply a prefix argument.
+
+\(fn &optional FILE-NAME CONFIRM)" t nil)
+
+(autoload 'faceup-render-view-buffer "faceup" "\
+Convert BUFFER containing Faceup markup to a new buffer and display it.
+
+\(fn &optional BUFFER)" t nil)
+
+(autoload 'faceup-clean-buffer "faceup" "\
+Remove faceup markup from buffer." t nil)
+
+(autoload 'faceup-defexplainer "faceup" "\
+Define an Ert explainer function for FUNCTION.
+
+FUNCTION must return an explanation when the test fails and
+`faceup-test-explain' is set.
+
+\(fn FUNCTION)" nil t)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "faceup" '("faceup-")))
;;;***
@@ -12416,9 +12015,7 @@ Besides the choice of face, it is the same as `buffer-face-mode'.
(autoload 'feedmail-send-it "feedmail" "\
Send the current mail buffer using the Feedmail package.
This is a suitable value for `send-mail-function'. It can be used
-with various lower-level mechanisms to provide features such as queueing.
-
-\(fn)" nil nil)
+with various lower-level mechanisms to provide features such as queueing." nil nil)
(autoload 'feedmail-run-the-queue-no-prompts "feedmail" "\
Like `feedmail-run-the-queue', but suppress confirmation prompts.
@@ -12518,16 +12115,12 @@ If `dired-at-point-require-prefix' is set, the prefix meaning is reversed.
(autoload 'ffap-guess-file-name-at-point "ffap" "\
Try to get a file name at point.
-This hook is intended to be put in `file-name-at-point-functions'.
-
-\(fn)" nil nil)
+This hook is intended to be put in `file-name-at-point-functions'." nil nil)
(autoload 'ffap-bindings "ffap" "\
-Evaluate the forms in variable `ffap-bindings'.
-
-\(fn)" t nil)
+Evaluate the forms in variable `ffap-bindings'." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ffap" '("find-file-literally-at-point" "ffap-" "dired-at-point-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ffap" '("dired-at-point-" "ffap-" "find-file-literally-at-point")))
;;;***
@@ -12568,7 +12161,7 @@ STRING is passed as an argument to the locate command.
\(fn STRING)" t nil)
(autoload 'file-cache-add-directory-recursively "filecache" "\
-Adds DIR and any subdirectories to the file-cache.
+Add DIR and any subdirectories to the file-cache.
This function does not use any external programs.
If the optional REGEXP argument is non-nil, only files which match it
will be added to the cache. Note that the REGEXP is applied to the
@@ -12590,6 +12183,41 @@ the name is considered already unique; only the second substitution
;;;***
+;;;### (autoloads nil "fileloop" "fileloop.el" (0 0 0 0))
+;;; Generated autoloads from fileloop.el
+
+(autoload 'fileloop-initialize "fileloop" "\
+Initialize a new round of operation on several files.
+FILES can be either a list of file names, or an iterator (used with `iter-next')
+which returns a file name at each step.
+SCAN-FUNCTION is a function called with no argument inside a buffer
+and it should return non-nil if that buffer has something on which to operate.
+OPERATE-FUNCTION is a function called with no argument; it is expected
+to perform the operation on the current file buffer and when done
+should return non-nil to mean that we should immediately continue
+operating on the next file and nil otherwise.
+
+\(fn FILES SCAN-FUNCTION OPERATE-FUNCTION)" nil nil)
+
+(autoload 'fileloop-initialize-search "fileloop" "\
+
+
+\(fn REGEXP FILES CASE-FOLD)" nil nil)
+
+(autoload 'fileloop-initialize-replace "fileloop" "\
+Initialize a new round of query&replace on several files.
+FROM is a regexp and TO is the replacement to use.
+FILES describes the file, as in `fileloop-initialize'.
+CASE-FOLD can be t, nil, or `default', the latter one meaning to obey
+the default setting of `case-fold-search'.
+DELIMITED if non-nil means replace only word-delimited matches.
+
+\(fn FROM TO FILES CASE-FOLD &optional DELIMITED)" nil nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "fileloop" '("fileloop-")))
+
+;;;***
+
;;;### (autoloads nil "filenotify" "filenotify.el" (0 0 0 0))
;;; Generated autoloads from filenotify.el
@@ -12656,19 +12284,13 @@ Delete all MODE settings of file-local VARIABLE from .dir-locals.el.
\(fn MODE VARIABLE)" t nil)
(autoload 'copy-file-locals-to-dir-locals "files-x" "\
-Copy file-local variables to .dir-locals.el.
-
-\(fn)" t nil)
+Copy file-local variables to .dir-locals.el." t nil)
(autoload 'copy-dir-locals-to-file-locals "files-x" "\
-Copy directory-local variables to the Local Variables list.
-
-\(fn)" t nil)
+Copy directory-local variables to the Local Variables list." t nil)
(autoload 'copy-dir-locals-to-file-locals-prop-line "files-x" "\
-Copy directory-local variables to the -*- line.
-
-\(fn)" t nil)
+Copy directory-local variables to the -*- line." t nil)
(defvar enable-connection-local-variables t "\
Non-nil means enable use of connection-local variables.")
@@ -12709,15 +12331,13 @@ will not be changed.
\(fn CRITERIA)" nil nil)
-(autoload 'with-connection-local-profiles "files-x" "\
-Apply connection-local variables according to PROFILES in current buffer.
+(autoload 'with-connection-local-variables "files-x" "\
+Apply connection-local variables according to `default-directory'.
Execute BODY, and unwind connection-local variables.
-\(fn PROFILES &rest BODY)" nil t)
-
-(function-put 'with-connection-local-profiles 'lisp-indent-function '1)
+\(fn &rest BODY)" nil t)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "files-x" '("hack-connection-local-variables" "connection-local-" "modify-" "read-file-local-variable")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "files-x" '("connection-local-" "dir-locals-to-string" "hack-connection-local-variables" "modify-" "read-file-local-variable")))
;;;***
@@ -12726,9 +12346,7 @@ Execute BODY, and unwind connection-local variables.
(autoload 'filesets-init "filesets" "\
Filesets initialization.
-Set up hooks, load the cache file -- if existing -- and build the menu.
-
-\(fn)" nil nil)
+Set up hooks, load the cache file -- if existing -- and build the menu." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "filesets" '("filesets-")))
@@ -12794,7 +12412,7 @@ specifies what to use in place of \"-ls\" as the final argument.
\(fn DIR REGEXP)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "find-dired" '("find-" "lookfor-dired" "kill-find")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "find-dired" '("find-" "kill-find" "lookfor-dired")))
;;;***
@@ -12886,7 +12504,7 @@ Visit the file you click on in another window.
\(fn EVENT)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "find-file" '("ff-" "modula2-other-file-alist" "cc-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "find-file" '("cc-" "ff-" "modula2-other-file-alist")))
;;;***
@@ -13060,19 +12678,13 @@ See `find-function-on-key'.
\(fn KEY)" t nil)
(autoload 'find-function-at-point "find-func" "\
-Find directly the function at point in the other window.
-
-\(fn)" t nil)
+Find directly the function at point in the other window." t nil)
(autoload 'find-variable-at-point "find-func" "\
-Find directly the variable at point in the other window.
-
-\(fn)" t nil)
+Find directly the variable at point in the other window." t nil)
(autoload 'find-function-setup-keys "find-func" "\
-Define some key bindings for the find-function family of functions.
-
-\(fn)" nil nil)
+Define some key bindings for the find-function family of functions." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "find-func" '("find-" "read-library-name")))
@@ -13105,9 +12717,7 @@ Change the filter on a `find-lisp-find-dired' buffer to REGEXP.
(push (purecopy '(finder 1 0)) package--builtin-versions)
(autoload 'finder-list-keywords "finder" "\
-Display descriptions of the keywords in the Finder buffer.
-
-\(fn)" t nil)
+Display descriptions of the keywords in the Finder buffer." t nil)
(autoload 'finder-commentary "finder" "\
Display FILE's commentary section.
@@ -13116,9 +12726,7 @@ FILE should be in a form suitable for passing to `locate-library'.
\(fn FILE)" t nil)
(autoload 'finder-by-keyword "finder" "\
-Find packages matching a given keyword.
-
-\(fn)" t nil)
+Find packages matching a given keyword." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "finder" '("finder-" "generated-finder-keywords-file")))
@@ -13166,7 +12774,7 @@ to get the effect of a C-q.
;;;### (autoloads nil "flymake" "progmodes/flymake.el" (0 0 0 0))
;;; Generated autoloads from progmodes/flymake.el
-(push (purecopy '(flymake 0 3)) package--builtin-versions)
+(push (purecopy '(flymake 1 0 5)) package--builtin-versions)
(autoload 'flymake-log "flymake" "\
Log, at level LEVEL, the message MSG formatted with ARGS.
@@ -13179,10 +12787,16 @@ generated it.
(autoload 'flymake-make-diagnostic "flymake" "\
Make a Flymake diagnostic for BUFFER's region from BEG to END.
-TYPE is a key to `flymake-diagnostic-types-alist' and TEXT is a
-description of the problem detected in this region.
+TYPE is a key to symbol and TEXT is a description of the problem
+detected in this region. DATA is any object that the caller
+wishes to attach to the created diagnostic for later retrieval.
+
+OVERLAY-PROPERTIES is an an alist of properties attached to the
+created diagnostic, overriding the default properties and any
+properties of `flymake-overlay-control' of the diagnostic's
+type.
-\(fn BUFFER BEG END TYPE TEXT)" nil nil)
+\(fn BUFFER BEG END TYPE TEXT &optional DATA OVERLAY-PROPERTIES)" nil nil)
(autoload 'flymake-diagnostics "flymake" "\
Get Flymake diagnostics in region determined by BEG and END.
@@ -13202,9 +12816,11 @@ region is invalid.
(autoload 'flymake-mode "flymake" "\
Toggle Flymake mode on or off.
-With a prefix argument ARG, enable Flymake mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'.
+
+If called interactively, enable Flymake mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Flymake is an Emacs minor mode for on-the-fly syntax checking.
Flymake collects diagnostic information from multiple sources,
@@ -13223,7 +12839,9 @@ The commands `flymake-goto-next-error' and
diagnostics annotated in the buffer.
The visual appearance of each type of diagnostic can be changed
-in the variable `flymake-diagnostic-types-alist'.
+by setting properties `flymake-overlay-control', `flymake-bitmap'
+and `flymake-severity' on the symbols of diagnostic types (like
+`:error', `:warning' and `:note').
Activation or deactivation of backends used by Flymake in each
buffer happens via the special hook
@@ -13239,23 +12857,35 @@ special *Flymake log* buffer.
\(fn &optional ARG)" t nil)
(autoload 'flymake-mode-on "flymake" "\
-Turn Flymake mode on.
-
-\(fn)" nil nil)
+Turn Flymake mode on." nil nil)
(autoload 'flymake-mode-off "flymake" "\
-Turn Flymake mode off.
-
-\(fn)" nil nil)
+Turn Flymake mode off." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "flymake" '("flymake-")))
;;;***
+;;;### (autoloads nil "flymake-cc" "progmodes/flymake-cc.el" (0 0
+;;;;;; 0 0))
+;;; Generated autoloads from progmodes/flymake-cc.el
+
+(autoload 'flymake-cc "flymake-cc" "\
+Flymake backend for GNU-style C compilers.
+This backend uses `flymake-cc-command' (which see) to launch a
+process that is passed the current buffer's contents via stdin.
+REPORT-FN is Flymake's callback.
+
+\(fn REPORT-FN &rest ARGS)" nil nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "flymake-cc" '("flymake-cc-")))
+
+;;;***
+
;;;### (autoloads nil "flymake-proc" "progmodes/flymake-proc.el"
;;;;;; (0 0 0 0))
;;; Generated autoloads from progmodes/flymake-proc.el
-(push (purecopy '(flymake-proc 0 3)) package--builtin-versions)
+(push (purecopy '(flymake-proc 1 0)) package--builtin-versions)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "flymake-proc" '("flymake-proc-")))
@@ -13265,16 +12895,16 @@ Turn Flymake mode off.
;;; Generated autoloads from textmodes/flyspell.el
(autoload 'flyspell-prog-mode "flyspell" "\
-Turn on `flyspell-mode' for comments and strings.
-
-\(fn)" t nil)
+Turn on `flyspell-mode' for comments and strings." t nil)
(defvar flyspell-mode nil "Non-nil if Flyspell mode is enabled.")
(autoload 'flyspell-mode "flyspell" "\
Toggle on-the-fly spell checking (Flyspell mode).
-With a prefix argument ARG, enable Flyspell mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Flyspell mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Flyspell mode is a buffer-local minor mode. When enabled, it
spawns a single Ispell process and checks each word. The default
@@ -13305,19 +12935,13 @@ in your init file.
\(fn &optional ARG)" t nil)
(autoload 'turn-on-flyspell "flyspell" "\
-Unconditionally turn on Flyspell mode.
-
-\(fn)" nil nil)
+Unconditionally turn on Flyspell mode." nil nil)
(autoload 'turn-off-flyspell "flyspell" "\
-Unconditionally turn off Flyspell mode.
-
-\(fn)" nil nil)
+Unconditionally turn off Flyspell mode." nil nil)
(autoload 'flyspell-mode-off "flyspell" "\
-Turn Flyspell mode off.
-
-\(fn)" nil nil)
+Turn Flyspell mode off." nil nil)
(autoload 'flyspell-region "flyspell" "\
Flyspell text between BEG and END.
@@ -13328,9 +12952,7 @@ of a misspelled word removed when you've corrected it.
\(fn BEG END)" t nil)
(autoload 'flyspell-buffer "flyspell" "\
-Flyspell whole buffer.
-
-\(fn)" t nil)
+Flyspell whole buffer." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "flyspell" '("flyspell-" "mail-mode-flyspell-verify" "make-flyspell-overlay" "sgml-mode-flyspell-verify" "tex")))
@@ -13348,20 +12970,18 @@ Flyspell whole buffer.
;;; Generated autoloads from follow.el
(autoload 'turn-on-follow-mode "follow" "\
-Turn on Follow mode. Please see the function `follow-mode'.
-
-\(fn)" nil nil)
+Turn on Follow mode. Please see the function `follow-mode'." nil nil)
(autoload 'turn-off-follow-mode "follow" "\
-Turn off Follow mode. Please see the function `follow-mode'.
-
-\(fn)" nil nil)
+Turn off Follow mode. Please see the function `follow-mode'." nil nil)
(autoload 'follow-mode "follow" "\
Toggle Follow mode.
-With a prefix argument ARG, enable Follow mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Follow mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Follow mode is a minor mode that combines windows into one tall
virtual window. This is accomplished by two main techniques:
@@ -13472,7 +13092,7 @@ selected if the original window is the first one in the frame.
;;;;;; 0))
;;; Generated autoloads from international/fontset.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "fontset" '("charset-script-alist" "create-" "set" "standard-fontset-spec" "fontset-" "generate-fontset-menu" "xlfd-" "x-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "fontset" '("charset-script-alist" "create-" "fontset-" "generate-fontset-menu" "set" "standard-fontset-spec" "x-" "xlfd-")))
;;;***
@@ -13482,9 +13102,11 @@ selected if the original window is the first one in the frame.
(autoload 'footnote-mode "footnote" "\
Toggle Footnote mode.
-With a prefix argument ARG, enable Footnote mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Footnote mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Footnote mode is a buffer-local minor mode. If enabled, it
provides footnote support for `message-mode'. To get started,
@@ -13493,7 +13115,7 @@ play around with the following keys:
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "footnote" '("footnote-" "Footnote-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "footnote" '("footnote-")))
;;;***
@@ -13869,6 +13491,8 @@ Interactively, reads the register using `register-read-with-preview'.
;;;### (autoloads nil "fringe" "fringe.el" (0 0 0 0))
;;; Generated autoloads from fringe.el
+(unless (fboundp 'define-fringe-bitmap) (defun define-fringe-bitmap (_bitmap _bits &optional _height _width _align) "Define fringe bitmap BITMAP from BITS of size HEIGHT x WIDTH.\nBITMAP is a symbol identifying the new fringe bitmap.\nBITS is either a string or a vector of integers.\nHEIGHT is height of bitmap. If HEIGHT is nil, use length of BITS.\nWIDTH must be an integer between 1 and 16, or nil which defaults to 8.\nOptional fifth arg ALIGN may be one of ‘top’, ‘center’, or ‘bottom’,\nindicating the positioning of the bitmap relative to the rows where it\nis used; the default is to center the bitmap. Fifth arg may also be a\nlist (ALIGN PERIODIC) where PERIODIC non-nil specifies that the bitmap\nshould be repeated.\nIf BITMAP already exists, the existing definition is replaced."))
+
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "fringe" '("fringe-" "set-fringe-")))
;;;***
@@ -13906,6 +13530,11 @@ being transferred. This list may grow up to a size of
`gdb-debug-log-max' after which the oldest element (at the end of
the list) is deleted every time a new one is added (at the front).
+If called interactively, enable Gdb-Enable-Debug mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
\(fn &optional ARG)" t nil)
(autoload 'gdb "gdb-mi" "\
@@ -13968,7 +13597,7 @@ detailed description of this mode.
\(fn COMMAND-LINE)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gdb-mi" '("gdb" "gud-" "def-gdb-" "breakpoint-" "nil")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gdb-mi" '("breakpoint" "def-gdb-" "gdb" "gud-" "hollow-right-triangle" "nil")))
;;;***
@@ -14065,7 +13694,7 @@ regular expression that can be used as an element of
;;;### (autoloads nil "generic-x" "generic-x.el" (0 0 0 0))
;;; Generated autoloads from generic-x.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "generic-x" '("generic-" "default-generic-mode")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "generic-x" '("default-generic-mode" "generic-")))
;;;***
@@ -14074,10 +13703,14 @@ regular expression that can be used as an element of
(autoload 'glasses-mode "glasses" "\
Minor mode for making identifiers likeThis readable.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil. When this mode is active, it tries to
-add virtual separators (like underscores) at places they belong to.
+
+If called interactively, enable Glasses mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
+When this mode is active, it tries to add virtual
+separators (like underscores) at places they belong to.
\(fn &optional ARG)" t nil)
@@ -14137,7 +13770,7 @@ DEFAULT-MAP specifies the default key map for ICON-LIST.
\(fn ICON-LIST ZAP-LIST DEFAULT-MAP)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gmm-utils" '("gmm-" "defun-gmm")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gmm-utils" '("defun-gmm" "gmm-")))
;;;***
@@ -14197,14 +13830,10 @@ prompt the user for the name of an NNTP server to use.
;;; Generated autoloads from gnus/gnus-agent.el
(autoload 'gnus-unplugged "gnus-agent" "\
-Start Gnus unplugged.
-
-\(fn)" t nil)
+Start Gnus unplugged." t nil)
(autoload 'gnus-plugged "gnus-agent" "\
-Start Gnus plugged.
-
-\(fn)" t nil)
+Start Gnus plugged." t nil)
(autoload 'gnus-slave-unplugged "gnus-agent" "\
Read news as a slave unplugged.
@@ -14220,14 +13849,10 @@ customize gnus-agent to nil.
This will modify the `gnus-setup-news-hook', and
`message-send-mail-real-function' variables, and install the Gnus agent
-minor mode in all Gnus buffers.
-
-\(fn)" t nil)
+minor mode in all Gnus buffers." t nil)
(autoload 'gnus-agent-possibly-save-gcc "gnus-agent" "\
-Save GCC if Gnus is unplugged.
-
-\(fn)" nil nil)
+Save GCC if Gnus is unplugged." nil nil)
(autoload 'gnus-agent-rename-group "gnus-agent" "\
Rename fully-qualified OLD-GROUP as NEW-GROUP.
@@ -14248,9 +13873,7 @@ supported.
\(fn GROUP)" nil nil)
(autoload 'gnus-agent-get-undownloaded-list "gnus-agent" "\
-Construct list of articles that have not been downloaded.
-
-\(fn)" nil nil)
+Construct list of articles that have not been downloaded." nil nil)
(autoload 'gnus-agent-possibly-alter-active "gnus-agent" "\
Possibly expand a group's active range to include articles
@@ -14266,14 +13889,10 @@ variables. Returns the first non-nil value found.
\(fn GROUP SYMBOL)" nil nil)
(autoload 'gnus-agent-batch-fetch "gnus-agent" "\
-Start Gnus and fetch session.
-
-\(fn)" t nil)
+Start Gnus and fetch session." t nil)
(autoload 'gnus-agent-batch "gnus-agent" "\
-Start Gnus, send queue and fetch session.
-
-\(fn)" t nil)
+Start Gnus, send queue and fetch session." t nil)
(autoload 'gnus-agent-regenerate "gnus-agent" "\
Regenerate all agent covered files.
@@ -14289,11 +13908,9 @@ CLEAN is obsolete and ignored.
;;; Generated autoloads from gnus/gnus-art.el
(autoload 'gnus-article-prepare-display "gnus-art" "\
-Make the current buffer look like a nice article.
+Make the current buffer look like a nice article." nil nil)
-\(fn)" nil nil)
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-art" '("gnus-" "article-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-art" '("article-" "gnus-")))
;;;***
@@ -14316,9 +13933,7 @@ Make the current buffer look like a nice article.
;;; Generated autoloads from gnus/gnus-bookmark.el
(autoload 'gnus-bookmark-set "gnus-bookmark" "\
-Set a bookmark for this article.
-
-\(fn)" t nil)
+Set a bookmark for this article." t nil)
(autoload 'gnus-bookmark-jump "gnus-bookmark" "\
Jump to a Gnus bookmark (BMK-NAME).
@@ -14329,9 +13944,7 @@ Jump to a Gnus bookmark (BMK-NAME).
Display a list of existing Gnus bookmarks.
The list is displayed in a buffer named `*Gnus Bookmark List*'.
The leftmost column displays a D if the bookmark is flagged for
-deletion, or > if it is flagged for displaying.
-
-\(fn)" t nil)
+deletion, or > if it is flagged for displaying." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-bookmark" '("gnus-bookmark-")))
@@ -14344,9 +13957,7 @@ deletion, or > if it is flagged for displaying.
Go through all groups and put the articles into the cache.
Usage:
-$ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache
-
-\(fn)" t nil)
+$ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache" t nil)
(autoload 'gnus-cache-generate-active "gnus-cache" "\
Generate the cache active file.
@@ -14383,7 +13994,7 @@ supported.
;;;### (autoloads nil "gnus-cite" "gnus/gnus-cite.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-cite.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-cite" '("turn-o" "gnus-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-cite" '("gnus-" "turn-o")))
;;;***
@@ -14397,7 +14008,7 @@ supported.
;;;### (autoloads nil "gnus-cus" "gnus/gnus-cus.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-cus.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-cus" '("gnus-" "category-fields")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-cus" '("category-fields" "gnus-")))
;;;***
@@ -14420,9 +14031,7 @@ DELAY is a string, giving the length of the time. Possible values are:
\(fn DELAY)" t nil)
(autoload 'gnus-delay-send-queue "gnus-delay" "\
-Send all the delayed messages that are due now.
-
-\(fn)" t nil)
+Send all the delayed messages that are due now." t nil)
(autoload 'gnus-delay-initialize "gnus-delay" "\
Initialize the gnus-delay package.
@@ -14466,9 +14075,7 @@ Checking delayed messages is skipped if optional arg NO-CHECK is non-nil.
;;; Generated autoloads from gnus/gnus-dired.el
(autoload 'turn-on-gnus-dired-mode "gnus-dired" "\
-Convenience method to turn on gnus-dired-mode.
-
-\(fn)" t nil)
+Convenience method to turn on gnus-dired-mode." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-dired" '("gnus-dired-")))
@@ -14478,9 +14085,7 @@ Convenience method to turn on gnus-dired-mode.
;;; Generated autoloads from gnus/gnus-draft.el
(autoload 'gnus-draft-reminder "gnus-draft" "\
-Reminder user if there are unsent drafts.
-
-\(fn)" t nil)
+Reminder user if there are unsent drafts." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-draft" '("gnus-")))
@@ -14513,14 +14118,10 @@ Return file from DIR with extension EXT, omitting matches of OMIT, processed by
(autoload 'gnus-random-x-face "gnus-fun" "\
Return X-Face header data chosen randomly from `gnus-x-face-directory'.
-Files matching `gnus-x-face-omit-files' are not considered.
-
-\(fn)" t nil)
+Files matching `gnus-x-face-omit-files' are not considered." t nil)
(autoload 'gnus-insert-random-x-face-header "gnus-fun" "\
-Insert a random X-Face header from `gnus-x-face-directory'.
-
-\(fn)" t nil)
+Insert a random X-Face header from `gnus-x-face-directory'." t nil)
(autoload 'gnus-x-face-from-file "gnus-fun" "\
Insert an X-Face header based on an image FILE.
@@ -14554,14 +14155,10 @@ FILE should be a PNG file that's 48x48 and smaller than or equal to
(autoload 'gnus-random-face "gnus-fun" "\
Return randomly chosen Face from `gnus-face-directory'.
-Files matching `gnus-face-omit-files' are not considered.
-
-\(fn)" t nil)
+Files matching `gnus-face-omit-files' are not considered." t nil)
(autoload 'gnus-insert-random-face-header "gnus-fun" "\
-Insert a random Face header from `gnus-face-directory'.
-
-\(fn)" nil nil)
+Insert a random Face header from `gnus-face-directory'." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-fun" '("gnus-")))
@@ -14627,6 +14224,11 @@ Pop up a frame and enter GROUP.
;;;;;; 0 0 0))
;;; Generated autoloads from gnus/gnus-icalendar.el
+(autoload 'gnus-icalendar-mm-inline "gnus-icalendar" "\
+
+
+\(fn HANDLE)" nil nil)
+
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-icalendar" '("gnus-icalendar")))
;;;***
@@ -14645,9 +14247,7 @@ Pop up a frame and enter GROUP.
(autoload 'gnus-batch-score "gnus-kill" "\
Run batched scoring.
-Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score
-
-\(fn)" t nil)
+Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-kill" '("gnus-")))
@@ -14670,10 +14270,7 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score
;;;### (autoloads nil "gnus-ml" "gnus/gnus-ml.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-ml.el
-(autoload 'turn-on-gnus-mailing-list-mode "gnus-ml" "\
-
-
-\(fn)" nil nil)
+(autoload 'turn-on-gnus-mailing-list-mode "gnus-ml" nil nil nil)
(autoload 'gnus-mailing-list-insinuate "gnus-ml" "\
Setup group parameters from List-Post header.
@@ -14684,6 +14281,11 @@ If FORCE is non-nil, replace the old ones.
(autoload 'gnus-mailing-list-mode "gnus-ml" "\
Minor mode for providing mailing-list commands.
+If called interactively, enable Gnus-Mailing-List mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
\\{gnus-mailing-list-mode-map}
\(fn &optional ARG)" t nil)
@@ -14732,9 +14334,7 @@ instead. This variable is set by `gnus-group-split-setup'.
Use information from group parameters in order to split mail.
See `gnus-group-split-fancy' for more information.
-`gnus-group-split' is a valid value for `nnmail-split-methods'.
-
-\(fn)" nil nil)
+`gnus-group-split' is a valid value for `nnmail-split-methods'." nil nil)
(autoload 'gnus-group-split-fancy "gnus-mlspl" "\
Uses information from group parameters in order to split mail.
@@ -14832,9 +14432,7 @@ or equal to `gnus-notifications-minimum-level' and send a
notification using `notifications-notify' for it.
This is typically a function to add in
-`gnus-after-getting-new-news-hook'
-
-\(fn)" nil nil)
+`gnus-after-getting-new-news-hook'" nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-notifications" '("gnus-notifications-")))
@@ -14845,21 +14443,15 @@ This is typically a function to add in
(autoload 'gnus-treat-from-picon "gnus-picon" "\
Display picons in the From header.
-If picons are already displayed, remove them.
-
-\(fn)" t nil)
+If picons are already displayed, remove them." t nil)
(autoload 'gnus-treat-mail-picon "gnus-picon" "\
Display picons in the Cc and To headers.
-If picons are already displayed, remove them.
-
-\(fn)" t nil)
+If picons are already displayed, remove them." t nil)
(autoload 'gnus-treat-newsgroups-picon "gnus-picon" "\
Display picons in the Newsgroups and Followup-To headers.
-If picons are already displayed, remove them.
-
-\(fn)" t nil)
+If picons are already displayed, remove them." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-picon" '("gnus-picon-")))
@@ -14939,14 +14531,10 @@ Add NUM into sorted LIST by side effect.
;;; Generated autoloads from gnus/gnus-registry.el
(autoload 'gnus-registry-initialize "gnus-registry" "\
-Initialize the Gnus registry.
-
-\(fn)" t nil)
+Initialize the Gnus registry." t nil)
(autoload 'gnus-registry-install-hooks "gnus-registry" "\
-Install the registry hooks.
-
-\(fn)" t nil)
+Install the registry hooks." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-registry" '("gnus-")))
@@ -14982,22 +14570,15 @@ Update the Sieve script in gnus-sieve-file, by replacing the region
between gnus-sieve-region-start and gnus-sieve-region-end with
\(gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost), then
execute gnus-sieve-update-shell-command.
-See the documentation for these variables and functions for details.
-
-\(fn)" t nil)
+See the documentation for these variables and functions for details." t nil)
(autoload 'gnus-sieve-generate "gnus-sieve" "\
Generate the Sieve script in gnus-sieve-file, by replacing the region
between gnus-sieve-region-start and gnus-sieve-region-end with
\(gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost).
-See the documentation for these variables and functions for details.
-
-\(fn)" t nil)
-
-(autoload 'gnus-sieve-article-add-rule "gnus-sieve" "\
+See the documentation for these variables and functions for details." t nil)
-
-\(fn)" t nil)
+(autoload 'gnus-sieve-article-add-rule "gnus-sieve" nil t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-sieve" '("gnus-sieve-")))
@@ -15150,8 +14731,6 @@ Use \\[describe-mode] for more info.
;;;### (autoloads nil "goto-addr" "net/goto-addr.el" (0 0 0 0))
;;; Generated autoloads from net/goto-addr.el
-(define-obsolete-function-alias 'goto-address-at-mouse 'goto-address-at-point "22.1")
-
(autoload 'goto-address-at-point "goto-addr" "\
Send to the e-mail address or load the URL at point.
Send mail to address at point. See documentation for
@@ -15168,22 +14747,27 @@ By default, goto-address binds `goto-address-at-point' to mouse-2 and C-c RET
only on URLs and e-mail addresses.
Also fontifies the buffer appropriately (see `goto-address-fontify-p' and
-`goto-address-highlight-p' for more information).
-
-\(fn)" t nil)
+`goto-address-highlight-p' for more information)." t nil)
(put 'goto-address 'safe-local-eval-function t)
(autoload 'goto-address-mode "goto-addr" "\
Minor mode to buttonize URLs and e-mail addresses in the current buffer.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
+
+If called interactively, enable Goto-Address mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
\(fn &optional ARG)" t nil)
(autoload 'goto-address-prog-mode "goto-addr" "\
Like `goto-address-mode', but only for comments and strings.
+If called interactively, enable Goto-Address-Prog mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
\(fn &optional ARG)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "goto-addr" '("goto-address-")))
@@ -15241,7 +14825,7 @@ List of hook functions run by `grep-process-setup' (see `run-hooks').")
(custom-autoload 'grep-setup-hook "grep" t)
-(defconst grep-regexp-alist `((,(concat "^\\(?:" "\\(?1:[^
+(defconst grep-regexp-alist `((,(concat "^\\(?:" "\\(?1:[^\0\n]+\\)\\(?3:\0\\)\\(?2:[0-9]+\\):" "\\|" "\\(?1:" "\\(?:[a-zA-Z]:\\)?" "[^\n:]+?[^\n/:]\\):[\11 ]*\\(?2:[1-9][0-9]*\\)[\11 ]*:" "\\)") 1 2 (,(lambda nil (when grep-highlight-matches (let* ((beg (match-end 0)) (end (save-excursion (goto-char beg) (line-end-position))) (mbeg (text-property-any beg end 'font-lock-face grep-match-face))) (when mbeg (- mbeg beg))))) \, (lambda nil (when grep-highlight-matches (let* ((beg (match-end 0)) (end (save-excursion (goto-char beg) (line-end-position))) (mbeg (text-property-any beg end 'font-lock-face grep-match-face)) (mend (and mbeg (next-single-property-change mbeg 'font-lock-face nil end)))) (when mend (- mend beg)))))) nil nil (3 '(face nil display ":"))) ("^Binary file \\(.+\\) matches$" 1 nil nil 0 1)) "\
Regexp used to match grep hits.
See `compilation-error-regexp-alist' for format details.")
@@ -15276,14 +14860,9 @@ History list for grep-find.")
(autoload 'grep-process-setup "grep" "\
Setup compilation variables and buffer for `grep'.
-Set up `compilation-exit-message-function' and run `grep-setup-hook'.
-
-\(fn)" nil nil)
-
-(autoload 'grep-compute-defaults "grep" "\
+Set up `compilation-exit-message-function' and run `grep-setup-hook'." nil nil)
-
-\(fn)" nil nil)
+(autoload 'grep-compute-defaults "grep" nil nil nil)
(autoload 'grep-mode "grep" "\
Sets `grep-last-buffer' and `compilation-window-height'.
@@ -15378,14 +14957,14 @@ file name to `*.gz', and sets `grep-highlight-matches' to `always'.
(defalias 'rzgrep 'zrgrep)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "grep" '("rgrep-" "grep-" "kill-grep")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "grep" '("grep-" "kill-grep" "rgrep-")))
;;;***
;;;### (autoloads nil "gssapi" "gnus/gssapi.el" (0 0 0 0))
;;; Generated autoloads from gnus/gssapi.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gssapi" '("open-gssapi-stream" "gssapi-program")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gssapi" '("gssapi-program" "open-gssapi-stream")))
;;;***
@@ -15483,9 +15062,11 @@ or call the function `gud-tooltip-mode'.")
(autoload 'gud-tooltip-mode "gud" "\
Toggle the display of GUD tooltips.
-With a prefix argument ARG, enable the feature if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-it if ARG is omitted or nil.
+
+If called interactively, enable Gud-Tooltip mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
\(fn &optional ARG)" t nil)
@@ -15608,9 +15189,7 @@ and `handwrite-13pt' set up for various sizes of output.
Variables: `handwrite-linespace' (default 12)
`handwrite-fontsize' (default 11)
`handwrite-numlines' (default 60)
- `handwrite-pagenumbering' (default nil)
-
-\(fn)" t nil)
+ `handwrite-pagenumbering' (default nil)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "handwrite" '("handwrite-" "menu-bar-handwrite-map")))
@@ -15637,17 +15216,13 @@ Towers of Hanoi, UNIX doomsday version.
Displays 32-ring towers that have been progressing at one move per
second since 1970-01-01 00:00:00 GMT.
-Repent before ring 31 moves.
-
-\(fn)" t nil)
+Repent before ring 31 moves." t nil)
(autoload 'hanoi-unix-64 "hanoi" "\
Like hanoi-unix, but pretend to have a 64-bit clock.
This is, necessarily (as of Emacs 20.3), a crock. When the
current-time interface is made s2G-compliant, hanoi.el will need
-to be updated.
-
-\(fn)" t nil)
+to be updated." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hanoi" '("hanoi-")))
@@ -15714,9 +15289,7 @@ can also be t, if that is the value of the `kbd-help' property.
Return the keyboard help string at point.
If the `kbd-help' text or overlay property at point produces a
string, return it. Otherwise, use the `help-echo' property.
-If this produces no string either, return nil.
-
-\(fn)" nil nil)
+If this produces no string either, return nil." nil nil)
(autoload 'display-local-help "help-at-pt" "\
Display local help in the echo area.
@@ -15733,15 +15306,11 @@ mainly meant for use from Lisp.
(autoload 'help-at-pt-cancel-timer "help-at-pt" "\
Cancel any timer set by `help-at-pt-set-timer'.
-This disables `help-at-pt-display-when-idle'.
-
-\(fn)" t nil)
+This disables `help-at-pt-display-when-idle'." t nil)
(autoload 'help-at-pt-set-timer "help-at-pt" "\
Enable `help-at-pt-display-when-idle'.
-This is done by setting a timer, if none is currently active.
-
-\(fn)" t nil)
+This is done by setting a timer, if none is currently active." t nil)
(defvar help-at-pt-display-when-idle 'never "\
Automatically show local help on point-over.
@@ -15822,7 +15391,7 @@ different regions. With numeric argument ARG, behaves like
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "help-at-pt" '("scan-buf-move-hook" "help-at-pt-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "help-at-pt" '("help-at-pt-" "scan-buf-move-hook")))
;;;***
@@ -15912,7 +15481,7 @@ Produce a texinfo buffer with sorted doc-strings from the DOC file.
\(fn FILE)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "help-fns" '("help-" "describe-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "help-fns" '("describe-" "help-")))
;;;***
@@ -15944,14 +15513,10 @@ Commands:
\(fn)" t nil)
(autoload 'help-mode-setup "help-mode" "\
-Enter Help Mode in the current buffer.
-
-\(fn)" nil nil)
+Enter Help Mode in the current buffer." nil nil)
(autoload 'help-mode-finish "help-mode" "\
-Finalize Help Mode setup in current buffer.
-
-\(fn)" nil nil)
+Finalize Help Mode setup in current buffer." nil nil)
(autoload 'help-setup-xref "help-mode" "\
Invoked from commands using the \"*Help*\" buffer to install some xref info.
@@ -15973,9 +15538,7 @@ If `help-xref-following' is non-nil, this is the name of the
current buffer. Signal an error if this buffer is not derived
from `help-mode'.
Otherwise, return \"*Help*\", creating a buffer with that name if
-it does not already exist.
-
-\(fn)" nil nil)
+it does not already exist." nil nil)
(autoload 'help-make-xrefs "help-mode" "\
Parse and hyperlink documentation cross-references in the given BUFFER.
@@ -16031,7 +15594,7 @@ BOOKMARK is a bookmark name or a bookmark record.
\(fn BOOKMARK)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "help-mode" '("help-" "describe-symbol-backends")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "help-mode" '("describe-symbol-backends" "help-")))
;;;***
@@ -16039,14 +15602,10 @@ BOOKMARK is a bookmark name or a bookmark record.
;;; Generated autoloads from emacs-lisp/helper.el
(autoload 'Helper-describe-bindings "helper" "\
-Describe local key bindings of current mode.
-
-\(fn)" t nil)
+Describe local key bindings of current mode." t nil)
(autoload 'Helper-help "helper" "\
-Provide help for current mode.
-
-\(fn)" t nil)
+Provide help for current mode." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "helper" '("Helper-")))
@@ -16055,7 +15614,7 @@ Provide help for current mode.
;;;### (autoloads nil "hex-util" "hex-util.el" (0 0 0 0))
;;; Generated autoloads from hex-util.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hex-util" '("encode-hex-string" "decode-hex-string")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hex-util" '("decode-hex-string" "encode-hex-string")))
;;;***
@@ -16147,11 +15706,9 @@ and edit the file in `hexl-mode'.
(autoload 'hexlify-buffer "hexl" "\
Convert a binary buffer to hexl format.
-This discards the buffer's undo information.
-
-\(fn)" t nil)
+This discards the buffer's undo information." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hexl" '("hexl-" "dehexlify-buffer")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hexl" '("dehexlify-buffer" "hexl-")))
;;;***
@@ -16168,9 +15725,11 @@ This discards the buffer's undo information.
(autoload 'hi-lock-mode "hi-lock" "\
Toggle selective highlighting of patterns (Hi Lock mode).
-With a prefix argument ARG, enable Hi Lock mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Hi-Lock mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Hi Lock mode is automatically enabled when you invoke any of the
highlighting commands listed below, such as \\[highlight-regexp].
@@ -16271,13 +15830,15 @@ highlighting will not update as you type.
(autoload 'hi-lock-face-buffer "hi-lock" "\
Set face of each match of REGEXP to FACE.
Interactively, prompt for REGEXP using `read-regexp', then FACE.
-Use the global history list for FACE.
+Use the global history list for FACE. Limit face setting to the
+corresponding SUBEXP (interactively, the prefix argument) of REGEXP.
+If SUBEXP is omitted or nil, the entire REGEXP is highlighted.
Use Font lock mode, if enabled, to highlight REGEXP. Otherwise,
use overlays for highlighting. If overlays are used, the
highlighting will not update as you type.
-\(fn REGEXP &optional FACE)" t nil)
+\(fn REGEXP &optional FACE SUBEXP)" t nil)
(defalias 'highlight-phrase 'hi-lock-face-phrase-buffer)
@@ -16305,9 +15866,7 @@ unless you use a prefix argument.
Uses `find-tag-default-as-symbol-regexp' to retrieve the symbol at point.
This uses Font lock mode if it is enabled; otherwise it uses overlays,
-in which case the highlighting will not update as you type.
-
-\(fn)" t nil)
+in which case the highlighting will not update as you type." t nil)
(defalias 'unhighlight-regexp 'hi-lock-unface-buffer)
@@ -16325,9 +15884,7 @@ Write interactively added patterns, if any, into buffer at point.
Interactively added patterns are those normally specified using
`highlight-regexp' and `highlight-lines-matching-regexp'; they can
-be found in variable `hi-lock-interactive-patterns'.
-
-\(fn)" t nil)
+be found in variable `hi-lock-interactive-patterns'." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hi-lock" '("hi-lock-" "turn-on-hi-lock-if-enabled")))
@@ -16338,9 +15895,11 @@ be found in variable `hi-lock-interactive-patterns'.
(autoload 'hide-ifdef-mode "hideif" "\
Toggle features to hide/show #ifdef blocks (Hide-Ifdef mode).
-With a prefix argument ARG, enable Hide-Ifdef mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Hide-Ifdef mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Hide-Ifdef mode is a buffer-local minor mode for use with C and
C-like major modes. When enabled, code within #ifdef constructs
@@ -16378,7 +15937,7 @@ Several variables affect how the hiding is done:
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hideif" '("hif-" "hide-ifdef" "show-ifdef" "previous-ifdef" "next-ifdef" "up-ifdef" "down-ifdef" "backward-ifdef" "forward-ifdef" "intern-safe")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hideif" '("backward-ifdef" "down-ifdef" "forward-ifdef" "hide-ifdef" "hif-" "intern-safe" "next-ifdef" "previous-ifdef" "show-ifdef" "up-ifdef")))
;;;***
@@ -16415,9 +15974,11 @@ whitespace. Case does not matter.")
(autoload 'hs-minor-mode "hideshow" "\
Minor mode to selectively hide/show code and comment blocks.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
+
+If called interactively, enable Hs minor mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
When hideshow minor mode is on, the menu bar is augmented with hideshow
commands and the hideshow commands are enabled.
@@ -16438,9 +15999,7 @@ Key bindings:
\(fn &optional ARG)" t nil)
(autoload 'turn-off-hideshow "hideshow" "\
-Unconditionally turn off `hs-minor-mode'.
-
-\(fn)" nil nil)
+Unconditionally turn off `hs-minor-mode'." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hideshow" '("hs-")))
@@ -16451,9 +16010,11 @@ Unconditionally turn off `hs-minor-mode'.
(autoload 'highlight-changes-mode "hilit-chg" "\
Toggle highlighting changes in this buffer (Highlight Changes mode).
-With a prefix argument ARG, enable Highlight Changes mode if ARG
-is positive, and disable it otherwise. If called from Lisp,
-enable the mode if ARG is omitted or nil.
+
+If called interactively, enable Highlight-Changes mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
When Highlight Changes is enabled, changes are marked with a text
property. Normally they are displayed in a distinctive face, but
@@ -16474,9 +16035,11 @@ buffer with the contents of a file
(autoload 'highlight-changes-visible-mode "hilit-chg" "\
Toggle visibility of highlighting due to Highlight Changes mode.
-With a prefix argument ARG, enable Highlight Changes Visible mode
-if ARG is positive, and disable it otherwise. If called from
-Lisp, enable the mode if ARG is omitted or nil.
+
+If called interactively, enable Highlight-Changes-Visible mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Highlight Changes Visible mode only has an effect when Highlight
Changes mode is on. When enabled, the changed text is displayed
@@ -16496,14 +16059,10 @@ This allows you to manually remove highlighting from uninteresting changes.
\(fn BEG END)" t nil)
(autoload 'highlight-changes-next-change "hilit-chg" "\
-Move to the beginning of the next change, if in Highlight Changes mode.
-
-\(fn)" t nil)
+Move to the beginning of the next change, if in Highlight Changes mode." t nil)
(autoload 'highlight-changes-previous-change "hilit-chg" "\
-Move to the beginning of the previous change, if in Highlight Changes mode.
-
-\(fn)" t nil)
+Move to the beginning of the previous change, if in Highlight Changes mode." t nil)
(autoload 'highlight-changes-rotate-faces "hilit-chg" "\
Rotate the faces if in Highlight Changes mode and the changes are visible.
@@ -16517,9 +16076,7 @@ You can automatically rotate colors when the buffer is saved by adding
this function to `write-file-functions' as a buffer-local value. To do
this, eval the following in the buffer to be saved:
- (add-hook \\='write-file-functions \\='highlight-changes-rotate-faces nil t)
-
-\(fn)" t nil)
+ (add-hook \\='write-file-functions \\='highlight-changes-rotate-faces nil t)" t nil)
(autoload 'highlight-compare-buffers "hilit-chg" "\
Compare two buffers and highlight the differences.
@@ -16576,7 +16133,7 @@ See `highlight-changes-mode' for more information on Highlight-Changes mode.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hilit-chg" '("highlight-" "hilit-chg-" "global-highlight-changes")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hilit-chg" '("global-highlight-changes" "highlight-" "hilit-chg-")))
;;;***
@@ -16610,7 +16167,7 @@ argument VERBOSE non-nil makes the function verbose.
\(fn TRY-LIST &optional VERBOSE)" nil t)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hippie-exp" '("hippie-expand-" "he-" "try-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hippie-exp" '("he-" "hippie-expand-" "try-")))
;;;***
@@ -16619,9 +16176,11 @@ argument VERBOSE non-nil makes the function verbose.
(autoload 'hl-line-mode "hl-line" "\
Toggle highlighting of the current line (Hl-Line mode).
-With a prefix argument ARG, enable Hl-Line mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Hl-Line mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Hl-Line mode is a buffer-local minor mode. If
`hl-line-sticky-flag' is non-nil, Hl-Line mode highlights the
@@ -16649,9 +16208,11 @@ or call the function `global-hl-line-mode'.")
(autoload 'global-hl-line-mode "hl-line" "\
Toggle line highlighting in all buffers (Global Hl-Line mode).
-With a prefix argument ARG, enable Global Hl-Line mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Global Hl-Line mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
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
@@ -16662,7 +16223,7 @@ and `global-hl-line-maybe-unhighlight' on `post-command-hook'.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hl-line" '("hl-line-" "global-hl-line-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hl-line" '("global-hl-line-" "hl-line-")))
;;;***
@@ -16788,7 +16349,7 @@ The optional LABEL is used to label the buffer created.
(defalias 'holiday-list 'list-holidays)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "holidays" '("holiday-" "calendar-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "holidays" '("calendar-" "holiday-")))
;;;***
@@ -16832,7 +16393,7 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'.
;;;;;; (0 0 0 0))
;;; Generated autoloads from ibuf-ext.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ibuf-ext" '("ibuffer-" "file" "shell-command-" "starred-name" "size" "alphabetic" "major-mode" "mod" "print" "predicate" "content" "view-and-eval" "visiting-file" "derived-mode" "directory" "basename" "name" "used-mode" "query-replace" "rename-uniquely" "revert" "replace-regexp" "eval")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ibuf-ext" '("alphabetic" "basename" "content" "derived-mode" "directory" "eval" "file" "ibuffer-" "major-mode" "mod" "name" "predicate" "print" "process" "query-replace" "rename-uniquely" "replace-regexp" "revert" "shell-command-" "size" "starred-name" "used-mode" "view-and-eval" "visiting-file")))
;;;***
@@ -16931,6 +16492,9 @@ Define a filter named NAME.
DOCUMENTATION is the documentation of the function.
READER is a form which should read a qualifier from the user.
DESCRIPTION is a short string describing the filter.
+ACCEPT-LIST is a boolean; if non-nil, the filter accepts either
+a single condition or a list of them; in the latter
+case the filter is the `or' composition of the conditions.
BODY should contain forms which will be evaluated to test whether or
not a particular buffer should be displayed or not. The forms in BODY
@@ -16990,7 +16554,7 @@ If optional arg OTHER-WINDOW is non-nil, then use another window.
\(fn &optional OTHER-WINDOW)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ibuffer" '("ibuffer-" "filename" "process" "mark" "mod" "size" "name" "locked" "read-only")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ibuffer" '("filename" "ibuffer-" "locked" "mark" "mod" "name" "process" "read-only" "size")))
;;;***
@@ -17031,7 +16595,7 @@ Extract iCalendar events from current buffer.
This function searches the current buffer for the first iCalendar
object, reads it and adds all VEVENT elements to the diary
-DIARY-FILE.
+DIARY-FILENAME.
It will ask for each appointment whether to add it to the diary
unless DO-NOT-ASK is non-nil. When called interactively,
@@ -17044,7 +16608,7 @@ Return code t means that importing worked well, return code nil
means that an error has occurred. Error messages will be in the
buffer `*icalendar-errors*'.
-\(fn &optional DIARY-FILE DO-NOT-ASK NON-MARKING)" t nil)
+\(fn &optional DIARY-FILENAME DO-NOT-ASK NON-MARKING)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "icalendar" '("icalendar-")))
@@ -17065,9 +16629,11 @@ or call the function `icomplete-mode'.")
(autoload 'icomplete-mode "icomplete" "\
Toggle incremental minibuffer completion (Icomplete mode).
-With a prefix argument ARG, enable Icomplete mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Icomplete mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
When this global minor mode is enabled, typing in the minibuffer
continuously displays a list of possible completions that match
@@ -17130,7 +16696,7 @@ with no args, if that value is non-nil.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "icon" '("indent-icon-exp" "icon-" "electric-icon-brace" "end-of-icon-defun" "beginning-of-icon-defun" "mark-icon-function" "calculate-icon-indent")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "icon" '("beginning-of-icon-defun" "calculate-icon-indent" "electric-icon-brace" "end-of-icon-defun" "icon-" "indent-icon-exp" "mark-icon-function")))
;;;***
@@ -17172,7 +16738,7 @@ See also the variable `idlwave-shell-prompt-pattern'.
\(Type \\[describe-mode] in the shell buffer for a list of commands.)
-\(fn &optional ARG QUICK)" t nil)
+\(fn &optional ARG)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "idlw-shell" '("idlwave-")))
@@ -17377,51 +16943,37 @@ RET Select the buffer at the front of the list of matches.
\\[ido-completion-help] Show list of matching buffers in separate window.
\\[ido-enter-find-file] Drop into `ido-find-file'.
\\[ido-kill-buffer-at-head] Kill buffer at head of buffer list.
-\\[ido-toggle-ignore] Toggle ignoring buffers listed in `ido-ignore-buffers'.
-
-\(fn)" t nil)
+\\[ido-toggle-ignore] Toggle ignoring buffers listed in `ido-ignore-buffers'." t nil)
(autoload 'ido-switch-buffer-other-window "ido" "\
Switch to another buffer and show it in another window.
The buffer name is selected interactively by typing a substring.
-For details of keybindings, see `ido-switch-buffer'.
-
-\(fn)" t nil)
+For details of keybindings, see `ido-switch-buffer'." t nil)
(autoload 'ido-display-buffer "ido" "\
Display a buffer in another window but don't select it.
The buffer name is selected interactively by typing a substring.
-For details of keybindings, see `ido-switch-buffer'.
-
-\(fn)" t nil)
+For details of keybindings, see `ido-switch-buffer'." t nil)
(autoload 'ido-display-buffer-other-frame "ido" "\
Display a buffer preferably in another frame.
The buffer name is selected interactively by typing a substring.
-For details of keybindings, see `ido-switch-buffer'.
-
-\(fn)" t nil)
+For details of keybindings, see `ido-switch-buffer'." t nil)
(autoload 'ido-kill-buffer "ido" "\
Kill a buffer.
The buffer name is selected interactively by typing a substring.
-For details of keybindings, see `ido-switch-buffer'.
-
-\(fn)" t nil)
+For details of keybindings, see `ido-switch-buffer'." t nil)
(autoload 'ido-insert-buffer "ido" "\
Insert contents of a buffer in current buffer after point.
The buffer name is selected interactively by typing a substring.
-For details of keybindings, see `ido-switch-buffer'.
-
-\(fn)" t nil)
+For details of keybindings, see `ido-switch-buffer'." t nil)
(autoload 'ido-switch-buffer-other-frame "ido" "\
Switch to another buffer and show it in another frame.
The buffer name is selected interactively by typing a substring.
-For details of keybindings, see `ido-switch-buffer'.
-
-\(fn)" t nil)
+For details of keybindings, see `ido-switch-buffer'." t nil)
(autoload 'ido-find-file-in-dir "ido" "\
Switch to another file starting from DIR.
@@ -17469,100 +17021,72 @@ RET Select the file at the front of the list of matches.
\\[ido-toggle-case] Toggle case-sensitive searching of file names.
\\[ido-toggle-literal] Toggle literal reading of this file.
\\[ido-completion-help] Show list of matching files in separate window.
-\\[ido-toggle-ignore] Toggle ignoring files listed in `ido-ignore-files'.
-
-\(fn)" t nil)
+\\[ido-toggle-ignore] Toggle ignoring files listed in `ido-ignore-files'." t nil)
(autoload 'ido-find-file-other-window "ido" "\
Switch to another file and show it in another window.
The file name is selected interactively by typing a substring.
-For details of keybindings, see `ido-find-file'.
-
-\(fn)" t nil)
+For details of keybindings, see `ido-find-file'." t nil)
(autoload 'ido-find-alternate-file "ido" "\
Find another file, select its buffer, kill previous buffer.
The file name is selected interactively by typing a substring.
-For details of keybindings, see `ido-find-file'.
-
-\(fn)" t nil)
+For details of keybindings, see `ido-find-file'." t nil)
(autoload 'ido-find-alternate-file-other-window "ido" "\
Find file as a replacement for the file in the next window.
The file name is selected interactively by typing a substring.
-For details of keybindings, see `ido-find-file'.
-
-\(fn)" t nil)
+For details of keybindings, see `ido-find-file'." t nil)
(autoload 'ido-find-file-read-only "ido" "\
Edit file read-only with name obtained via minibuffer.
The file name is selected interactively by typing a substring.
-For details of keybindings, see `ido-find-file'.
-
-\(fn)" t nil)
+For details of keybindings, see `ido-find-file'." t nil)
(autoload 'ido-find-file-read-only-other-window "ido" "\
Edit file read-only in other window with name obtained via minibuffer.
The file name is selected interactively by typing a substring.
-For details of keybindings, see `ido-find-file'.
-
-\(fn)" t nil)
+For details of keybindings, see `ido-find-file'." t nil)
(autoload 'ido-find-file-read-only-other-frame "ido" "\
Edit file read-only in other frame with name obtained via minibuffer.
The file name is selected interactively by typing a substring.
-For details of keybindings, see `ido-find-file'.
-
-\(fn)" t nil)
+For details of keybindings, see `ido-find-file'." t nil)
(autoload 'ido-display-file "ido" "\
Display a file in another window but don't select it.
The file name is selected interactively by typing a substring.
-For details of keybindings, see `ido-find-file'.
-
-\(fn)" t nil)
+For details of keybindings, see `ido-find-file'." t nil)
(autoload 'ido-find-file-other-frame "ido" "\
Switch to another file and show it in another frame.
The file name is selected interactively by typing a substring.
-For details of keybindings, see `ido-find-file'.
-
-\(fn)" t nil)
+For details of keybindings, see `ido-find-file'." t nil)
(autoload 'ido-write-file "ido" "\
Write current buffer to a file.
The file name is selected interactively by typing a substring.
-For details of keybindings, see `ido-find-file'.
-
-\(fn)" t nil)
+For details of keybindings, see `ido-find-file'." t nil)
(autoload 'ido-insert-file "ido" "\
Insert contents of file in current buffer.
The file name is selected interactively by typing a substring.
-For details of keybindings, see `ido-find-file'.
-
-\(fn)" t nil)
+For details of keybindings, see `ido-find-file'." t nil)
(autoload 'ido-dired "ido" "\
Call `dired' the Ido way.
The directory is selected interactively by typing a substring.
-For details of keybindings, see `ido-find-file'.
-
-\(fn)" t nil)
+For details of keybindings, see `ido-find-file'." t nil)
(autoload 'ido-dired-other-window "ido" "\
\"Edit\" a directory. Like `ido-dired' but selects in another window.
The directory is selected interactively by typing a substring.
-For details of keybindings, see `ido-find-file'.
-
-\(fn)" t nil)
+For details of keybindings, see `ido-find-file'." t nil)
(autoload 'ido-dired-other-frame "ido" "\
\"Edit\" a directory. Like `ido-dired' but makes a new frame.
The directory is selected interactively by typing a substring.
-For details of keybindings, see `ido-find-file'.
-
-\(fn)" t nil)
+For details of keybindings, see `ido-find-file'." t nil)
(autoload 'ido-read-buffer "ido" "\
Ido replacement for the built-in `read-buffer'.
@@ -17570,6 +17094,8 @@ Return the name of a buffer selected.
PROMPT is the prompt to give to the user. DEFAULT if given is the default
buffer to be selected, which will go to the front of the list.
If REQUIRE-MATCH is non-nil, an existing buffer must be selected.
+Optional arg PREDICATE if non-nil is a function limiting the
+buffers that can be considered.
\(fn PROMPT &optional DEFAULT REQUIRE-MATCH PREDICATE)" nil nil)
@@ -17614,12 +17140,13 @@ DEF, if non-nil, is the default value.
(autoload 'ielm "ielm" "\
Interactively evaluate Emacs Lisp expressions.
-Switches to the buffer `*ielm*', or creates it if it does not exist.
+Switches to the buffer named BUF-NAME if provided (`*ielm*' by default),
+or creates it if it does not exist.
See `inferior-emacs-lisp-mode' for details.
-\(fn)" t nil)
+\(fn &optional BUF-NAME)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ielm" '("inferior-emacs-lisp-mode" "ielm-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ielm" '("ielm-" "inferior-emacs-lisp-mode")))
;;;***
@@ -17637,9 +17164,12 @@ See `inferior-emacs-lisp-mode' for details.
(autoload 'iimage-mode "iimage" "\
Toggle Iimage mode on or off.
-With a prefix argument ARG, enable Iimage mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'.
+
+If called interactively, enable Iimage mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
\\{iimage-mode-map}
\(fn &optional ARG)" t nil)
@@ -17661,9 +17191,7 @@ be determined.
(autoload 'image-type-from-buffer "image" "\
Determine the image type from data in the current buffer.
Value is a symbol specifying the image type or nil if type cannot
-be determined.
-
-\(fn)" nil nil)
+be determined." nil nil)
(autoload 'image-type-from-file-header "image" "\
Determine the type of image file FILE from its first few bytes.
@@ -17704,9 +17232,7 @@ The buffer is considered to contain an auto-detectable image if
its beginning matches an image type in `image-type-header-regexps',
and that image type is present in `image-type-auto-detectable' with a
non-nil value. If that value is non-nil, but not t, then the image type
-must be available.
-
-\(fn)" nil nil)
+must be available." nil nil)
(autoload 'create-image "image" "\
Create an image.
@@ -17842,9 +17368,7 @@ Emacs visits them in Image mode. They are also added to
`image-type-file-name-regexps', so that the `image-type' function
recognizes these files as having image type `imagemagick'.
-If Emacs is compiled without ImageMagick support, this does nothing.
-
-\(fn)" nil nil)
+If Emacs is compiled without ImageMagick support, this does nothing." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "image" '("image")))
@@ -17930,33 +17454,30 @@ With prefix argument ARG, remove tag from file at point.
\(fn ARG)" t nil)
(autoload 'image-dired-jump-thumbnail-buffer "image-dired" "\
-Jump to thumbnail buffer.
-
-\(fn)" t nil)
+Jump to thumbnail buffer." t nil)
(autoload 'image-dired-minor-mode "image-dired" "\
Setup easy-to-use keybindings for the commands to be used in dired mode.
Note that n, p and <down> and <up> will be hijacked and bound to
`image-dired-dired-x-line'.
+If called interactively, enable Image-Dired minor mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
\(fn &optional ARG)" t nil)
(define-obsolete-function-alias 'image-dired-setup-dired-keybindings 'image-dired-minor-mode "26.1")
(autoload 'image-dired-display-thumbs-append "image-dired" "\
-Append thumbnails to `image-dired-thumbnail-buffer'.
-
-\(fn)" t nil)
+Append thumbnails to `image-dired-thumbnail-buffer'." t nil)
(autoload 'image-dired-display-thumb "image-dired" "\
-Shorthand for `image-dired-display-thumbs' with prefix argument.
-
-\(fn)" t nil)
+Shorthand for `image-dired-display-thumbs' with prefix argument." t nil)
(autoload 'image-dired-dired-display-external "image-dired" "\
-Display file at point using an external viewer.
-
-\(fn)" t nil)
+Display file at point using an external viewer." t nil)
(autoload 'image-dired-dired-display-image "image-dired" "\
Display current image file.
@@ -17966,9 +17487,7 @@ With prefix argument ARG, display image in its original size.
\(fn &optional ARG)" t nil)
(autoload 'image-dired-dired-comment-files "image-dired" "\
-Add comment to current or marked files in dired.
-
-\(fn)" t nil)
+Add comment to current or marked files in dired." t nil)
(autoload 'image-dired-mark-tagged-files "image-dired" "\
Use regexp to mark files with matching tag.
@@ -17976,16 +17495,12 @@ A `tag' is a keyword, a piece of meta data, associated with an
image file and stored in image-dired's database file. This command
lets you input a regexp and this will be matched against all tags
on all image files in the database file. The files that have a
-matching tag will be marked in the dired buffer.
-
-\(fn)" t nil)
+matching tag will be marked in the dired buffer." t nil)
(autoload 'image-dired-dired-edit-comment-and-tags "image-dired" "\
Edit comment and tags of current or marked image files.
Edit comment and tags for all marked image files in an
-easy-to-use form.
-
-\(fn)" t nil)
+easy-to-use form." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "image-dired" '("image-dired-")))
@@ -18019,9 +17534,7 @@ the variable is set using \\[customize].")
(custom-autoload 'image-file-name-regexps "image-file" nil)
(autoload 'image-file-name-regexp "image-file" "\
-Return a regular expression matching image-file filenames.
-
-\(fn)" nil nil)
+Return a regular expression matching image-file filenames." nil nil)
(autoload 'insert-image-file "image-file" "\
Insert the image file FILE into the current buffer.
@@ -18042,9 +17555,11 @@ or call the function `auto-image-file-mode'.")
(autoload 'auto-image-file-mode "image-file" "\
Toggle visiting of image files as images (Auto Image File mode).
-With a prefix argument ARG, enable Auto Image File mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Auto-Image-File mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
An image file is one whose name has an extension in
`image-file-name-extensions', or matches a regexp in
@@ -18065,15 +17580,15 @@ You can use \\<image-mode-map>\\[image-toggle-display] or \\<image-mode-map>\\[i
to toggle between display as an image and display as text or hex.
Key bindings:
-\\{image-mode-map}
-
-\(fn)" t nil)
+\\{image-mode-map}" t nil)
(autoload 'image-minor-mode "image-mode" "\
Toggle Image minor mode in this buffer.
-With a prefix argument ARG, enable Image minor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Image minor mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Image minor mode provides the key \\<image-mode-map>\\[image-toggle-display],
to switch back to `image-mode' and display an image file as the
@@ -18084,9 +17599,7 @@ actual image.
(autoload 'image-mode-to-text "image-mode" "\
Set a non-image mode as major mode in combination with image minor mode.
A non-mage major mode found from `auto-mode-alist' or fundamental mode
-displays an image file as text.
-
-\(fn)" nil nil)
+displays an image file as text." nil nil)
(autoload 'image-bookmark-jump "image-mode" "\
@@ -18229,9 +17742,7 @@ See the command `imenu' for more information.
(autoload 'imenu-add-menubar-index "imenu" "\
Add an Imenu \"Index\" entry on the menu bar for the current buffer.
-A trivial interface to `imenu-add-to-menubar' suitable for use in a hook.
-
-\(fn)" t nil)
+A trivial interface to `imenu-add-to-menubar' suitable for use in a hook." t nil)
(autoload 'imenu "imenu" "\
Jump to a place in the buffer chosen using a buffer menu or mouse menu.
@@ -18316,7 +17827,7 @@ the environment variable INFOPATH is set.
Although this is a customizable variable, that is mainly for technical
reasons. Normally, you should either set INFOPATH or customize
-`Info-additional-directory-list', rather than changing this variable." :initialize (quote custom-initialize-delay) :type (quote (repeat directory)) :group (quote info))
+`Info-additional-directory-list', rather than changing this variable." :initialize 'custom-initialize-delay :type '(repeat directory) :group 'info)
(autoload 'info-other-window "info" "\
Like `info' but show the Info buffer in another window.
@@ -18349,21 +17860,15 @@ See a list of available Info commands in `Info-mode'.
\(fn &optional FILE-OR-NODE BUFFER)" t nil)
(autoload 'info-emacs-manual "info" "\
-Display the Emacs manual in Info mode.
-
-\(fn)" t nil)
+Display the Emacs manual in Info mode." t nil)
(autoload 'info-emacs-bug "info" "\
-Display the \"Reporting Bugs\" section of the Emacs manual in Info mode.
-
-\(fn)" t nil)
+Display the \"Reporting Bugs\" section of the Emacs manual in Info mode." t nil)
(autoload 'info-standalone "info" "\
Run Emacs as a standalone Info reader.
Usage: emacs -f info-standalone [filename]
-In standalone mode, \\<Info-mode-map>\\[Info-exit] exits Emacs itself.
-
-\(fn)" nil nil)
+In standalone mode, \\<Info-mode-map>\\[Info-exit] exits Emacs itself." nil nil)
(autoload 'Info-on-current-buffer "info" "\
Use Info mode to browse the current Info buffer.
@@ -18373,9 +17878,7 @@ otherwise, that defaults to `Top'.
\(fn &optional NODENAME)" t nil)
(autoload 'Info-directory "info" "\
-Go to the Info directory node.
-
-\(fn)" t nil)
+Go to the Info directory node." t nil)
(autoload 'Info-index "info" "\
Look up a string TOPIC in the index for this manual and go to that entry.
@@ -18487,9 +17990,7 @@ the variable `Info-file-list-for-emacs'.
(autoload 'Info-speedbar-browser "info" "\
Initialize speedbar to display an Info node browser.
-This will add a speedbar major display mode.
-
-\(fn)" t nil)
+This will add a speedbar major display mode." t nil)
(autoload 'Info-bookmark-jump "info" "\
This implements the `handler' function interface for the record
@@ -18506,7 +18007,7 @@ completion alternatives to currently visited manuals.
\(fn MANUAL)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "info" '("info-" "Info-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "info" '("Info-" "info-")))
;;;***
@@ -18517,9 +18018,7 @@ completion alternatives to currently visited manuals.
Throw away all cached data.
This command is useful if the user wants to start at the beginning without
quitting Emacs, for example, after some Info documents were updated on the
-system.
-
-\(fn)" t nil)
+system." t nil)
(put 'info-lookup-symbol 'info-file "emacs")
(autoload 'info-lookup-symbol "info-look" "\
@@ -18602,9 +18101,7 @@ info files don't necessarily have a \".info\" extension and in
particular the Emacs manuals normally don't. If you have a
source code directory in `Info-directory-list' then a lot of
extraneous files might be read. This will be time consuming but
-should be harmless.
-
-\(fn)" t nil)
+should be harmless." t nil)
(autoload 'info-xref-check-all-custom "info-xref" "\
Check info references in all customize groups and variables.
@@ -18613,9 +18110,7 @@ of the `custom-links' for a variable.
Any `custom-load' autoloads in variables are loaded in order to
get full link information. This will be a lot of Lisp packages
-and can take a long time.
-
-\(fn)" t nil)
+and can take a long time." t nil)
(autoload 'info-xref-docstrings "info-xref" "\
Check docstring info node references in source files.
@@ -18669,23 +18164,17 @@ should be saved in place of the original visited file.
The subfiles are written in the same directory the original file is
in, with names generated by appending `-' and a number to the original
file name. The indirect file still functions as an Info file, but it
-contains just the tag table and a directory of subfiles.
-
-\(fn)" t nil)
+contains just the tag table and a directory of subfiles." t nil)
(autoload 'Info-validate "informat" "\
Check current buffer for validity as an Info file.
-Check that every node pointer points to an existing node.
-
-\(fn)" t nil)
+Check that every node pointer points to an existing node." t nil)
(autoload 'batch-info-validate "informat" "\
Runs `Info-validate' on the files remaining on the command line.
Must be used only with -batch, and kills Emacs on completion.
Each file will be processed even if an error occurred previously.
-For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\"
-
-\(fn)" nil nil)
+For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\"" nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "informat" '("Info-validate-")))
@@ -18729,14 +18218,10 @@ Only checks one based on which kind of Emacs is being run.
;;; Generated autoloads from international/isearch-x.el
(autoload 'isearch-toggle-specified-input-method "isearch-x" "\
-Select an input method and turn it on in interactive search.
-
-\(fn)" t nil)
+Select an input method and turn it on in interactive search." t nil)
(autoload 'isearch-toggle-input-method "isearch-x" "\
-Toggle input method in interactive search.
-
-\(fn)" t nil)
+Toggle input method in interactive search." t nil)
(autoload 'isearch-process-search-multibyte-characters "isearch-x" "\
@@ -18755,9 +18240,7 @@ Toggle input method in interactive search.
Active isearchb mode for subsequent alphanumeric keystrokes.
Executing this command again will terminate the search; or, if
the search has not yet begun, will toggle to the last buffer
-accessed via isearchb.
-
-\(fn)" t nil)
+accessed via isearchb." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "isearchb" '("isearchb")))
@@ -18856,9 +18339,7 @@ Warn that format is write-only.
\(fn &rest IGNORE)" t nil)
(autoload 'iso-cvt-define-menu "iso-cvt" "\
-Add submenus to the File menu, to convert to and from various formats.
-
-\(fn)" t nil)
+Add submenus to the File menu, to convert to and from various formats." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "iso-cvt" '("iso-")))
@@ -18887,18 +18368,12 @@ If nil, the default personal dictionary for your spelling checker is used.")
(put 'ispell-local-dictionary 'safe-local-variable 'string-or-null-p)
-(defvar ispell-menu-map nil "\
+(defconst ispell-menu-map (let ((map (make-sparse-keymap "Spell"))) (define-key map [ispell-change-dictionary] `(menu-item ,(purecopy "Change Dictionary...") ispell-change-dictionary :help ,(purecopy "Supply explicit dictionary file name"))) (define-key map [ispell-kill-ispell] `(menu-item ,(purecopy "Kill Process") (lambda nil (interactive) (ispell-kill-ispell nil 'clear)) :enable (and (boundp 'ispell-process) ispell-process (eq (ispell-process-status) 'run)) :help ,(purecopy "Terminate Ispell subprocess"))) (define-key map [ispell-pdict-save] `(menu-item ,(purecopy "Save Dictionary") (lambda nil (interactive) (ispell-pdict-save t t)) :help ,(purecopy "Save personal dictionary"))) (define-key map [ispell-customize] `(menu-item ,(purecopy "Customize...") (lambda nil (interactive) (customize-group 'ispell)) :help ,(purecopy "Customize spell checking options"))) (define-key map [ispell-help] `(menu-item ,(purecopy "Help") (lambda nil (interactive) (describe-function 'ispell-help)) :help ,(purecopy "Show standard Ispell keybindings and commands"))) (define-key map [flyspell-mode] `(menu-item ,(purecopy "Automatic spell checking (Flyspell)") flyspell-mode :help ,(purecopy "Check spelling while you edit the text") :button (:toggle bound-and-true-p flyspell-mode))) (define-key map [ispell-complete-word] `(menu-item ,(purecopy "Complete Word") ispell-complete-word :help ,(purecopy "Complete word at cursor using dictionary"))) (define-key map [ispell-complete-word-interior-frag] `(menu-item ,(purecopy "Complete Word Fragment") ispell-complete-word-interior-frag :help ,(purecopy "Complete word fragment at cursor"))) (define-key map [ispell-continue] `(menu-item ,(purecopy "Continue Spell-Checking") ispell-continue :enable (and (boundp 'ispell-region-end) (marker-position ispell-region-end) (equal (marker-buffer ispell-region-end) (current-buffer))) :help ,(purecopy "Continue spell checking last region"))) (define-key map [ispell-word] `(menu-item ,(purecopy "Spell-Check Word") ispell-word :help ,(purecopy "Spell-check word at cursor"))) (define-key map [ispell-comments-and-strings] `(menu-item ,(purecopy "Spell-Check Comments") ispell-comments-and-strings :help ,(purecopy "Spell-check only comments and strings"))) (define-key map [ispell-region] `(menu-item ,(purecopy "Spell-Check Region") ispell-region :enable mark-active :help ,(purecopy "Spell-check text in marked region"))) (define-key map [ispell-message] `(menu-item ,(purecopy "Spell-Check Message") ispell-message :visible (eq major-mode 'mail-mode) :help ,(purecopy "Skip headers and included message text"))) (define-key map [ispell-buffer] `(menu-item ,(purecopy "Spell-Check Buffer") ispell-buffer :help ,(purecopy "Check spelling of selected buffer"))) map) "\
Key map for ispell menu.")
-(defvar ispell-menu-map-needed (unless ispell-menu-map 'reload))
-
-(if ispell-menu-map-needed (progn (setq ispell-menu-map (make-sparse-keymap "Spell")) (define-key ispell-menu-map [ispell-change-dictionary] `(menu-item ,(purecopy "Change Dictionary...") ispell-change-dictionary :help ,(purecopy "Supply explicit dictionary file name"))) (define-key ispell-menu-map [ispell-kill-ispell] `(menu-item ,(purecopy "Kill Process") (lambda nil (interactive) (ispell-kill-ispell nil 'clear)) :enable (and (boundp 'ispell-process) ispell-process (eq (ispell-process-status) 'run)) :help ,(purecopy "Terminate Ispell subprocess"))) (define-key ispell-menu-map [ispell-pdict-save] `(menu-item ,(purecopy "Save Dictionary") (lambda nil (interactive) (ispell-pdict-save t t)) :help ,(purecopy "Save personal dictionary"))) (define-key ispell-menu-map [ispell-customize] `(menu-item ,(purecopy "Customize...") (lambda nil (interactive) (customize-group 'ispell)) :help ,(purecopy "Customize spell checking options"))) (define-key ispell-menu-map [ispell-help] `(menu-item ,(purecopy "Help") (lambda nil (interactive) (describe-function 'ispell-help)) :help ,(purecopy "Show standard Ispell keybindings and commands"))) (define-key ispell-menu-map [flyspell-mode] `(menu-item ,(purecopy "Automatic spell checking (Flyspell)") flyspell-mode :help ,(purecopy "Check spelling while you edit the text") :button (:toggle bound-and-true-p flyspell-mode))) (define-key ispell-menu-map [ispell-complete-word] `(menu-item ,(purecopy "Complete Word") ispell-complete-word :help ,(purecopy "Complete word at cursor using dictionary"))) (define-key ispell-menu-map [ispell-complete-word-interior-frag] `(menu-item ,(purecopy "Complete Word Fragment") ispell-complete-word-interior-frag :help ,(purecopy "Complete word fragment at cursor")))))
-
-(if ispell-menu-map-needed (progn (define-key ispell-menu-map [ispell-continue] `(menu-item ,(purecopy "Continue Spell-Checking") ispell-continue :enable (and (boundp 'ispell-region-end) (marker-position ispell-region-end) (equal (marker-buffer ispell-region-end) (current-buffer))) :help ,(purecopy "Continue spell checking last region"))) (define-key ispell-menu-map [ispell-word] `(menu-item ,(purecopy "Spell-Check Word") ispell-word :help ,(purecopy "Spell-check word at cursor"))) (define-key ispell-menu-map [ispell-comments-and-strings] `(menu-item ,(purecopy "Spell-Check Comments") ispell-comments-and-strings :help ,(purecopy "Spell-check only comments and strings")))))
-
-(if ispell-menu-map-needed (progn (define-key ispell-menu-map [ispell-region] `(menu-item ,(purecopy "Spell-Check Region") ispell-region :enable mark-active :help ,(purecopy "Spell-check text in marked region"))) (define-key ispell-menu-map [ispell-message] `(menu-item ,(purecopy "Spell-Check Message") ispell-message :visible (eq major-mode 'mail-mode) :help ,(purecopy "Skip headers and included message text"))) (define-key ispell-menu-map [ispell-buffer] `(menu-item ,(purecopy "Spell-Check Buffer") ispell-buffer :help ,(purecopy "Check spelling of selected buffer"))) (fset 'ispell-menu-map (symbol-value 'ispell-menu-map))))
+(fset 'ispell-menu-map (symbol-value 'ispell-menu-map))
-(defvar ispell-skip-region-alist `((ispell-words-keyword forward-line) (ispell-dictionary-keyword forward-line) (ispell-pdict-keyword forward-line) (ispell-parsing-keyword forward-line) (,(purecopy "^---*BEGIN PGP [A-Z ]*--*") \, (purecopy "^---*END PGP [A-Z ]*--*")) (,(purecopy "^begin [0-9][0-9][0-9] [^ ]+$") \, (purecopy "\nend\n")) (,(purecopy "^%!PS-Adobe-[123].0") \, (purecopy "\n%%EOF\n")) (,(purecopy "^---* \\(Start of \\)?[Ff]orwarded [Mm]essage") \, (purecopy "^---* End of [Ff]orwarded [Mm]essage"))) "\
+(defvar ispell-skip-region-alist `((ispell-words-keyword forward-line) (ispell-dictionary-keyword forward-line) (ispell-pdict-keyword forward-line) (ispell-parsing-keyword forward-line) (,(purecopy "^---*BEGIN PGP [A-Z ]*--*") \, (purecopy "^---*END PGP [A-Z ]*--*")) (,(purecopy "^begin [0-9][0-9][0-9] [^ \11]+$") \, (purecopy "\nend\n")) (,(purecopy "^%!PS-Adobe-[123].0") \, (purecopy "\n%%EOF\n")) (,(purecopy "^---* \\(Start of \\)?[Ff]orwarded [Mm]essage") \, (purecopy "^---* End of [Ff]orwarded [Mm]essage"))) "\
Alist expressing beginning and end of regions not to spell check.
The alist key must be a regular expression.
Valid forms include:
@@ -18907,7 +18382,7 @@ Valid forms include:
(KEY REGEXP) - skip to end of REGEXP. REGEXP must be a string.
(KEY FUNCTION ARGS) - FUNCTION called with ARGS returns end of region.")
-(defvar ispell-tex-skip-alists (purecopy '((("\\\\addcontentsline" ispell-tex-arg-end 2) ("\\\\add\\(tocontents\\|vspace\\)" ispell-tex-arg-end) ("\\\\\\([aA]lph\\|arabic\\)" ispell-tex-arg-end) ("\\\\cref" ispell-tex-arg-end) ("\\\\bibliographystyle" ispell-tex-arg-end) ("\\\\makebox" ispell-tex-arg-end 0) ("\\\\e?psfig" ispell-tex-arg-end) ("\\\\document\\(class\\|style\\)" . "\\\\begin[ \n]*{[ \n]*document[ \n]*}")) (("\\(figure\\|table\\)\\*?" ispell-tex-arg-end 0) ("list" ispell-tex-arg-end 2) ("program" . "\\\\end[ \n]*{[ \n]*program[ \n]*}") ("verbatim\\*?" . "\\\\end[ \n]*{[ \n]*verbatim\\*?[ \n]*}")))) "\
+(defvar ispell-tex-skip-alists (purecopy '((("\\\\addcontentsline" ispell-tex-arg-end 2) ("\\\\add\\(tocontents\\|vspace\\)" ispell-tex-arg-end) ("\\\\\\([aA]lph\\|arabic\\)" ispell-tex-arg-end) ("\\\\cref" ispell-tex-arg-end) ("\\\\bibliographystyle" ispell-tex-arg-end) ("\\\\makebox" ispell-tex-arg-end 0) ("\\\\e?psfig" ispell-tex-arg-end) ("\\\\document\\(class\\|style\\)" . "\\\\begin[ \11\n]*{[ \11\n]*document[ \11\n]*}")) (("\\(figure\\|table\\)\\*?" ispell-tex-arg-end 0) ("list" ispell-tex-arg-end 2) ("program" . "\\\\end[ \11\n]*{[ \11\n]*program[ \11\n]*}") ("verbatim\\*?" . "\\\\end[ \11\n]*{[ \11\n]*verbatim\\*?[ \11\n]*}")))) "\
Lists of regions to be skipped in TeX mode.
First list is used raw.
Second list has key placed inside \\begin{}.
@@ -18915,7 +18390,7 @@ Second list has key placed inside \\begin{}.
Delete or add any regions you want to be automatically selected
for skipping in latex mode.")
-(defconst ispell-html-skip-alists '(("<[cC][oO][dD][eE]\\>[^>]*>" "</[cC][oO][dD][eE]*>") ("<[sS][cC][rR][iI][pP][tT]\\>[^>]*>" "</[sS][cC][rR][iI][pP][tT]>") ("<[aA][pP][pP][lL][eE][tT]\\>[^>]*>" "</[aA][pP][pP][lL][eE][tT]>") ("<[vV][eE][rR][bB]\\>[^>]*>" "<[vV][eE][rR][bB]\\>[^>]*>") ("<[tT][tT]/" "/") ("<[^ \n>]" ">") ("&[^ \n;]" "[; \n]")) "\
+(defconst ispell-html-skip-alists '(("<[cC][oO][dD][eE]\\>[^>]*>" "</[cC][oO][dD][eE]*>") ("<[sS][cC][rR][iI][pP][tT]\\>[^>]*>" "</[sS][cC][rR][iI][pP][tT]>") ("<[aA][pP][pP][lL][eE][tT]\\>[^>]*>" "</[aA][pP][pP][lL][eE][tT]>") ("<[vV][eE][rR][bB]\\>[^>]*>" "<[vV][eE][rR][bB]\\>[^>]*>") ("<[tT][tT]/" "/") ("<[^ \11\n>]" ">") ("&[^ \11\n;]" "[; \11\n]")) "\
Lists of start and end keys to skip in HTML buffers.
Same format as `ispell-skip-region-alist'.
Note - substrings of other matches must come last
@@ -18983,9 +18458,7 @@ SPC: Accept word this time.
`m': Place typed-in value in personal dictionary, then recheck current word.
`C-l': Redraw screen.
`C-r': Recursive edit.
-`C-z': Suspend Emacs or iconify frame.
-
-\(fn)" nil nil)
+`C-z': Suspend Emacs or iconify frame." nil nil)
(autoload 'ispell-kill-ispell "ispell" "\
Kill current Ispell process (so that you may start a fresh one).
@@ -19011,14 +18484,10 @@ amount for last line processed.
\(fn REG-START REG-END &optional RECHECKP SHIFT)" t nil)
(autoload 'ispell-comments-and-strings "ispell" "\
-Check comments and strings in the current buffer for spelling errors.
-
-\(fn)" t nil)
+Check comments and strings in the current buffer for spelling errors." t nil)
(autoload 'ispell-buffer "ispell" "\
-Check the current buffer for spelling errors interactively.
-
-\(fn)" t nil)
+Check the current buffer for spelling errors interactively." t nil)
(autoload 'ispell-buffer-with-debug "ispell" "\
`ispell-buffer' with some output sent to `ispell-debug-buffer' buffer.
@@ -19027,9 +18496,7 @@ If APPEND is non-n il, append the info to previous buffer if exists.
\(fn &optional APPEND)" t nil)
(autoload 'ispell-continue "ispell" "\
-Continue a halted spelling session beginning with the current word.
-
-\(fn)" t nil)
+Continue a halted spelling session beginning with the current word." t nil)
(autoload 'ispell-complete-word "ispell" "\
Try to complete the word before or at point.
@@ -19041,9 +18508,7 @@ Standard ispell choices are then available.
\(fn &optional INTERIOR-FRAG)" t nil)
(autoload 'ispell-complete-word-interior-frag "ispell" "\
-Completes word matching character sequence inside a word.
-
-\(fn)" t nil)
+Completes word matching character sequence inside a word." t nil)
(autoload 'ispell "ispell" "\
Interactively check a region or buffer for spelling errors.
@@ -19053,15 +18518,15 @@ that region. Otherwise spell-check the buffer.
Ispell dictionaries are not distributed with Emacs. If you are
looking for a dictionary, please see the distribution of the GNU ispell
program, or do an Internet search; there are various dictionaries
-available on the net.
-
-\(fn)" t nil)
+available on the net." t nil)
(autoload 'ispell-minor-mode "ispell" "\
Toggle last-word spell checking (Ispell minor mode).
-With a prefix argument ARG, enable Ispell minor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable ISpell minor mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Ispell minor mode is a buffer-local minor mode. When enabled,
typing SPC or RET warns you if the previous word is incorrectly
@@ -19094,11 +18559,9 @@ in your init file:
You can bind this to the key C-c i in GNUS or mail by adding to
`news-reply-mode-hook' or `mail-mode-hook' the following lambda expression:
- (function (lambda () (local-set-key \"\\C-ci\" \\='ispell-message)))
-
-\(fn)" t nil)
+ (function (lambda () (local-set-key \"\\C-ci\" \\='ispell-message)))" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ispell" '("ispell-" "check-ispell-version")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ispell" '("check-ispell-version" "ispell-")))
;;;***
@@ -19106,7 +18569,7 @@ You can bind this to the key C-c i in GNUS or mail by adding to
;;;;;; (0 0 0 0))
;;; Generated autoloads from international/ja-dic-cnv.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ja-dic-cnv" '("skkdic-" "batch-skkdic-convert" "ja-dic-filename")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ja-dic-cnv" '("batch-skkdic-convert" "ja-dic-filename" "skkdic-")))
;;;***
@@ -19122,10 +18585,7 @@ You can bind this to the key C-c i in GNUS or mail by adding to
;;;;;; 0 0))
;;; Generated autoloads from language/japan-util.el
-(autoload 'setup-japanese-environment-internal "japan-util" "\
-
-
-\(fn)" nil nil)
+(autoload 'setup-japanese-environment-internal "japan-util" nil nil nil)
(autoload 'japanese-katakana "japan-util" "\
Convert argument to Katakana and return that.
@@ -19215,11 +18675,9 @@ It is not recommended to set this variable permanently to anything but nil.")
Uninstall jka-compr.
This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
and `inhibit-local-variables-suffixes' that were added
-by `jka-compr-installed'.
+by `jka-compr-installed'." nil nil)
-\(fn)" nil nil)
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "jka-compr" '("jka-compr-" "compression-error")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "jka-compr" '("compression-error" "jka-compr-")))
;;;***
@@ -19260,6 +18718,14 @@ locally, like so:
;;;***
+;;;### (autoloads nil "jsonrpc" "jsonrpc.el" (0 0 0 0))
+;;; Generated autoloads from jsonrpc.el
+(push (purecopy '(jsonrpc 1 0 7)) package--builtin-versions)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "jsonrpc" '("jrpc-default-request-timeout" "jsonrpc-")))
+
+;;;***
+
;;;### (autoloads nil "kermit" "kermit.el" (0 0 0 0))
;;; Generated autoloads from kermit.el
@@ -19497,12 +18963,9 @@ If kbd macro currently being defined end it before activating it.
The kind of Korean keyboard for Korean input method.
\"\" for 2, \"3\" for 3.")
-(autoload 'setup-korean-environment-internal "korea-util" "\
+(autoload 'setup-korean-environment-internal "korea-util" nil nil nil)
-
-\(fn)" nil nil)
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "korea-util" '("exit-korean-environment" "korean-key-bindings" "isearch-" "quail-hangul-switch-" "toggle-korean-input-method")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "korea-util" '("exit-korean-environment" "isearch-" "korean-key-bindings" "quail-hangul-switch-" "toggle-korean-input-method")))
;;;***
@@ -19738,9 +19201,11 @@ generations (this defaults to 1).
(autoload 'linum-mode "linum" "\
Toggle display of line numbers in the left margin (Linum mode).
-With a prefix argument ARG, enable Linum mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
+
+If called interactively, enable Linum mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Linum mode is a buffer-local minor mode.
@@ -19809,7 +19274,7 @@ something strange, such as redefining an Emacs function.
\(fn FEATURE &optional FORCE)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "loadhist" '("loadhist-" "unload-" "read-feature" "feature-" "file-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "loadhist" '("feature-" "file-" "loadhist-" "read-feature" "unload-")))
;;;***
@@ -19962,9 +19427,7 @@ argument.")
(autoload 'lpr-buffer "lpr" "\
Print buffer contents without pagination or page headers.
See the variables `lpr-switches' and `lpr-command'
-for customization of the printer command.
-
-\(fn)" t nil)
+for customization of the printer command." t nil)
(autoload 'print-buffer "lpr" "\
Paginate and print buffer contents.
@@ -19978,9 +19441,7 @@ Otherwise, the switches in `lpr-headers-switches' are used
in the print command itself; we expect them to request pagination.
See the variables `lpr-switches' and `lpr-command'
-for further customization of the printer command.
-
-\(fn)" t nil)
+for further customization of the printer command." t nil)
(autoload 'lpr-region "lpr" "\
Print region contents without pagination or page headers.
@@ -20032,7 +19493,7 @@ This function is suitable for execution in an init file.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "lunar" '("lunar-" "diary-lunar-phases" "calendar-lunar-phases")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "lunar" '("calendar-lunar-phases" "diary-lunar-phases" "lunar-")))
;;;***
@@ -20051,13 +19512,7 @@ A major mode to edit m4 macro files.
;;;### (autoloads nil "macros" "macros.el" (0 0 0 0))
;;; Generated autoloads from macros.el
-(autoload 'name-last-kbd-macro "macros" "\
-Assign a name to the last keyboard macro defined.
-Argument SYMBOL is the name to define.
-The symbol's function definition becomes the keyboard macro string.
-Such a \"function\" cannot be called from Lisp, but it is a valid editor command.
-
-\(fn SYMBOL)" t nil)
+(defalias 'name-last-kbd-macro #'kmacro-name-last-macro)
(autoload 'insert-kbd-macro "macros" "\
Insert in buffer the definition of kbd macro MACRONAME, as Lisp code.
@@ -20159,6 +19614,12 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible
\(This feature exists so that the clever caller might be able to avoid
consing a string.)
+This function is primarily meant for when you're displaying the
+result to the user: Many prettifications are applied to the
+result returned. If you want to decode an address for further
+non-display use, you should probably use
+`mail-header-parse-address' instead.
+
\(fn ADDRESS &optional ALL)" nil nil)
(autoload 'what-domain "mail-extr" "\
@@ -20174,14 +19635,9 @@ Convert mail domain DOMAIN to the country it corresponds to.
;;; Generated autoloads from mail/mail-hist.el
(autoload 'mail-hist-define-keys "mail-hist" "\
-Define keys for accessing mail header history. For use in hooks.
-
-\(fn)" nil nil)
-
-(autoload 'mail-hist-enable "mail-hist" "\
+Define keys for accessing mail header history. For use in hooks." nil nil)
-
-\(fn)" nil nil)
+(autoload 'mail-hist-enable "mail-hist" nil nil nil)
(defvar mail-hist-keep-history t "\
Non-nil means keep a history for headers and text of outgoing mail.")
@@ -20193,9 +19649,7 @@ Put headers and contents of this message into mail header history.
Each header has its own independent history, as does the body of the
message.
-This function normally would be called when the message is sent.
-
-\(fn)" nil nil)
+This function normally would be called when the message is sent." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mail-hist" '("mail-hist-")))
@@ -20238,7 +19692,7 @@ Regexp specifying addresses to prune from a reply message.
If this is nil, it is set the first time you compose a reply, to
a value which excludes your own email address.
-Matching addresses are excluded from the CC field in replies, and
+Matching addresses are excluded from the Cc field in replies, and
also the To field, unless this would leave an empty To field.")
(custom-autoload 'mail-dont-reply-to-names "mail-utils" t)
@@ -20314,9 +19768,11 @@ or call the function `mail-abbrevs-mode'.")
(autoload 'mail-abbrevs-mode "mailabbrev" "\
Toggle abbrev expansion of mail aliases (Mail Abbrevs mode).
-With a prefix argument ARG, enable Mail Abbrevs mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Mail-Abbrevs mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Mail Abbrevs mode is a global minor mode. When enabled,
abbrev-like expansion is performed when editing certain mail
@@ -20326,9 +19782,7 @@ the entries in your `mail-personal-alias-file'.
\(fn &optional ARG)" t nil)
(autoload 'mail-abbrevs-setup "mailabbrev" "\
-Initialize use of the `mailabbrev' package.
-
-\(fn)" nil nil)
+Initialize use of the `mailabbrev' package." nil nil)
(autoload 'build-mail-abbrevs "mailabbrev" "\
Read mail aliases from personal mail alias file and set `mail-abbrevs'.
@@ -20347,7 +19801,7 @@ double-quotes.
\(fn NAME DEFINITION &optional FROM-MAILRC-FILE)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mailabbrev" '("merge-mail-abbrevs" "mail-" "rebuild-mail-abbrevs")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mailabbrev" '("mail-" "merge-mail-abbrevs" "rebuild-mail-abbrevs")))
;;;***
@@ -20368,7 +19822,7 @@ If `angles', they look like:
(autoload 'expand-mail-aliases "mailalias" "\
Expand all mail aliases in suitable header fields found between BEG and END.
If interactive, expand in header fields.
-Suitable header fields are `To', `From', `CC' and `BCC', `Reply-to', and
+Suitable header fields are `To', `From', `Cc' and `Bcc', `Reply-To', and
their `Resent-' variants.
Optional second arg EXCLUDE may be a regular expression defining text to be
@@ -20389,9 +19843,7 @@ if it is quoted with double-quotes.
(autoload 'mail-completion-at-point-function "mailalias" "\
Compute completion data for mail aliases.
-For use on `completion-at-point-functions'.
-
-\(fn)" nil nil)
+For use on `completion-at-point-functions'." nil nil)
(autoload 'mail-complete "mailalias" "\
Perform completion on header field or word preceding point.
@@ -20402,7 +19854,7 @@ current header, calls `mail-complete-function' and passes prefix ARG if any.
(make-obsolete 'mail-complete 'mail-completion-at-point-function '"24.1")
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mailalias" '("mail-" "build-mail-aliases")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mailalias" '("build-mail-aliases" "mail-")))
;;;***
@@ -20419,9 +19871,7 @@ current header, calls `mail-complete-function' and passes prefix ARG if any.
(autoload 'mailclient-send-it "mailclient" "\
Pass current buffer on to the system's mail client.
Suitable value for `send-mail-function'.
-The mail client is taken to be the handler of mailto URLs.
-
-\(fn)" nil nil)
+The mail client is taken to be the handler of mailto URLs." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mailclient" '("mailclient-")))
@@ -20573,9 +20023,7 @@ An adapted `makefile-mode' that knows about imake.
(autoload 'make-command-summary "makesum" "\
Make a summary of current key bindings in the buffer *Summary*.
-Previous contents of that buffer are killed first.
-
-\(fn)" t nil)
+Previous contents of that buffer are killed first." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "makesum" '("double-column")))
@@ -20648,9 +20096,9 @@ Default bookmark handler for Man buffers.
;;;### (autoloads nil "map" "emacs-lisp/map.el" (0 0 0 0))
;;; Generated autoloads from emacs-lisp/map.el
-(push (purecopy '(map 1 2)) package--builtin-versions)
+(push (purecopy '(map 2 0)) package--builtin-versions)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "map" '("map")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "map" '("map-")))
;;;***
@@ -20660,9 +20108,11 @@ Default bookmark handler for Man buffers.
(autoload 'master-mode "master" "\
Toggle Master mode.
-With a prefix argument ARG, enable Master mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Master mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
When Master mode is enabled, you can scroll the slave buffer
using the following commands:
@@ -20694,9 +20144,11 @@ or call the function `minibuffer-depth-indicate-mode'.")
(autoload 'minibuffer-depth-indicate-mode "mb-depth" "\
Toggle Minibuffer Depth Indication mode.
-With a prefix argument ARG, enable Minibuffer Depth Indication
-mode if ARG is positive, and disable it otherwise. If called
-from Lisp, enable the mode if ARG is omitted or nil.
+
+If called interactively, enable Minibuffer-Depth-Indicate mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Minibuffer Depth Indication mode is a global minor mode. When
enabled, any recursive use of the minibuffer will show the
@@ -20801,14 +20253,10 @@ If ARG, allow editing of the cancellation message.
(autoload 'message-supersede "message" "\
Start composing a message to supersede the current message.
This is done simply by taking the old article and adding a Supersedes
-header line with the old Message-ID.
-
-\(fn)" t nil)
+header line with the old Message-ID." t nil)
(autoload 'message-recover "message" "\
-Reread contents of current buffer from its last auto-save file.
-
-\(fn)" t nil)
+Reread contents of current buffer from its last auto-save file." t nil)
(autoload 'message-forward "message" "\
Forward the current message via mail.
@@ -20828,9 +20276,7 @@ Optional DIGEST will use digest to forward.
\(fn FORWARD-BUFFER)" nil nil)
(autoload 'message-insinuate-rmail "message" "\
-Let RMAIL use message to forward.
-
-\(fn)" t nil)
+Let RMAIL use message to forward." t nil)
(autoload 'message-resend "message" "\
Resend the current article to ADDRESS.
@@ -20841,9 +20287,7 @@ Resend the current article to ADDRESS.
Re-mail the current message.
This only makes sense if the current message is a bounce message that
contains some mail you have written which has been bounced back to
-you.
-
-\(fn)" t nil)
+you." t nil)
(autoload 'message-mail-other-window "message" "\
Like `message-mail' command, but display mail buffer in another window.
@@ -20899,7 +20343,7 @@ Major mode for editing MetaPost sources.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "meta-mode" '("meta" "font-lock-match-meta-declaration-item-and-skip-to-next")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "meta-mode" '("font-lock-match-meta-declaration-item-and-skip-to-next" "meta")))
;;;***
@@ -20908,9 +20352,7 @@ Major mode for editing MetaPost sources.
(autoload 'metamail-interpret-header "metamail" "\
Interpret a header part of a MIME message in current buffer.
-Its body part is not interpreted at all.
-
-\(fn)" t nil)
+Its body part is not interpreted at all." t nil)
(autoload 'metamail-interpret-body "metamail" "\
Interpret a body part of a MIME message in current buffer.
@@ -20951,7 +20393,7 @@ redisplayed as output is inserted.
;;;### (autoloads nil "mh-acros" "mh-e/mh-acros.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-acros.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-acros" '("mh-" "with-mh-folder-updating" "defun-mh" "defmacro-mh")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-acros" '("defmacro-mh" "defun-mh" "mh-" "with-mh-folder-updating")))
;;;***
@@ -20974,15 +20416,11 @@ redisplayed as output is inserted.
(autoload 'mh-smail "mh-comp" "\
Compose a message with the MH mail system.
-See `mh-send' for more details on composing mail.
-
-\(fn)" t nil)
+See `mh-send' for more details on composing mail." t nil)
(autoload 'mh-smail-other-window "mh-comp" "\
Compose a message with the MH mail system in other window.
-See `mh-send' for more details on composing mail.
-
-\(fn)" t nil)
+See `mh-send' for more details on composing mail." t nil)
(autoload 'mh-smail-batch "mh-comp" "\
Compose a message with the MH mail system.
@@ -21053,9 +20491,7 @@ Quit editing and delete draft message.
If for some reason you are not happy with the draft, you can use
this command to kill the draft buffer and delete the draft
message. Use the command \\[kill-buffer] if you don't want to
-delete the draft message.
-
-\(fn)" t nil)
+delete the draft message." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-comp" '("mh-")))
@@ -21079,11 +20515,9 @@ delete the draft message.
(put 'mh-lib-progs 'risky-local-variable t)
(autoload 'mh-version "mh-e" "\
-Display version information about MH-E and the MH mail handling system.
-
-\(fn)" t nil)
+Display version information about MH-E and the MH mail handling system." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-e" '("mh-" "defgroup-mh" "defcustom-mh" "defface-mh")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-e" '("defcustom-mh" "defface-mh" "defgroup-mh" "mh-")))
;;;***
@@ -21324,6 +20758,11 @@ or call the function `midnight-mode'.")
(autoload 'midnight-mode "midnight" "\
Non-nil means run `midnight-hook' at midnight.
+If called interactively, enable Midnight mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
\(fn &optional ARG)" t nil)
(autoload 'clean-buffer-list "midnight" "\
@@ -21336,9 +20775,7 @@ The relevant variables are `clean-buffer-list-delay-general',
While processing buffers, this procedure displays messages containing
the current date/time, buffer name, how many seconds ago it was
displayed (can be nil if the buffer was never displayed) and its
-lifetime, i.e., its \"age\" when it will be purged.
-
-\(fn)" t nil)
+lifetime, i.e., its \"age\" when it will be purged." t nil)
(autoload 'midnight-delay-set "midnight" "\
Modify `midnight-timer' according to `midnight-delay'.
@@ -21347,7 +20784,7 @@ to its second argument TM.
\(fn SYMB TM)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "midnight" '("midnight-" "clean-buffer-list-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "midnight" '("clean-buffer-list-" "midnight-")))
;;;***
@@ -21366,9 +20803,11 @@ or call the function `minibuffer-electric-default-mode'.")
(autoload 'minibuffer-electric-default-mode "minibuf-eldef" "\
Toggle Minibuffer Electric Default mode.
-With a prefix argument ARG, enable Minibuffer Electric Default
-mode if ARG is positive, and disable it otherwise. If called
-from Lisp, enable the mode if ARG is omitted or nil.
+
+If called interactively, enable Minibuffer-Electric-Default mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Minibuffer Electric Default mode is a global minor mode. When
enabled, minibuffer prompts that show a default value only show
@@ -21403,14 +20842,10 @@ Ignores CHAR at point.
\(fn ARG CHAR)" t nil)
(autoload 'mark-beginning-of-buffer "misc" "\
-Set mark at the beginning of the buffer.
-
-\(fn)" t nil)
+Set mark at the beginning of the buffer." t nil)
(autoload 'mark-end-of-buffer "misc" "\
-Set mark at the end of the buffer.
-
-\(fn)" t nil)
+Set mark at the end of the buffer." t nil)
(autoload 'upcase-char "misc" "\
Uppercasify ARG chars starting from point. Point doesn't move.
@@ -21437,9 +20872,7 @@ upper atmosphere. These cause momentary pockets of higher-pressure
air to form, which act as lenses that deflect incoming cosmic rays,
focusing them to strike the drive platter and flip the desired bit.
You can type `M-x butterfly C-M-c' to run it. This is a permuted
-variation of `C-x M-c M-butterfly' from url `http://xkcd.com/378/'.
-
-\(fn)" t nil)
+variation of `C-x M-c M-butterfly' from url `http://xkcd.com/378/'." t nil)
(autoload 'list-dynamic-libraries "misc" "\
Display a list of all dynamic libraries known to Emacs.
@@ -21500,9 +20933,7 @@ Sequence of files visited by multiple file buffers Isearch.")
(autoload 'multi-isearch-setup "misearch" "\
Set up isearch to search multiple buffers.
-Intended to be added to `isearch-mode-hook'.
-
-\(fn)" nil nil)
+Intended to be added to `isearch-mode-hook'." nil nil)
(autoload 'multi-isearch-buffers "misearch" "\
Start multi-buffer Isearch on a list of BUFFERS.
@@ -21542,7 +20973,7 @@ whose file names match the specified wildcard.
\(fn FILES)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "misearch" '("multi-isearch-" "misearch-unload-function")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "misearch" '("misearch-unload-function" "multi-isearch-")))
;;;***
@@ -21685,9 +21116,7 @@ Assume text has been decoded if DECODED is non-nil.
;;; Generated autoloads from gnus/mml.el
(autoload 'mml-to-mime "mml" "\
-Translate the current buffer from MML to MIME.
-
-\(fn)" nil nil)
+Translate the current buffer from MML to MIME." nil nil)
(autoload 'mml-attach-file "mml" "\
Attach a file to the outgoing MIME message.
@@ -21776,10 +21205,7 @@ will be computed and used.
\(fn CONT)" nil nil)
-(autoload 'mml2015-self-encrypt "mml2015" "\
-
-
-\(fn)" nil nil)
+(autoload 'mml2015-self-encrypt "mml2015" nil nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mml2015" '("mml2015-")))
@@ -21790,7 +21216,7 @@ will be computed and used.
(put 'define-overloadable-function 'doc-string-elt 3)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mode-local" '("make-obsolete-overload" "mode-local-" "deactivate-mode-local-bindings" "def" "describe-mode-local-" "xref-mode-local-" "overload-" "fetch-overload" "function-overload-p" "set" "with-mode-local" "activate-mode-local-bindings" "new-mode-local-bindings" "get-mode-local-parent")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mode-local" '("activate-mode-local-bindings" "deactivate-mode-local-bindings" "def" "describe-mode-local-" "fetch-overload" "function-overload-p" "get-mode-local-parent" "make-obsolete-overload" "mode-local-" "new-mode-local-bindings" "overload-" "set" "with-mode-local" "xref-mode-local-")))
;;;***
@@ -21825,7 +21251,7 @@ followed by the first character of the construct.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "modula2" '("m3-font-lock-keywords" "m2-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "modula2" '("m2-" "m3-font-lock-keywords")))
;;;***
@@ -21852,7 +21278,7 @@ Convert NATO phonetic alphabet in region to ordinary ASCII text.
\(fn BEG END)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "morse" '("nato-alphabet" "morse-code")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "morse" '("morse-code" "nato-alphabet")))
;;;***
@@ -21916,9 +21342,7 @@ To test this function, evaluate:
;;; Generated autoloads from mpc.el
(autoload 'mpc "mpc" "\
-Main entry point for MPC.
-
-\(fn)" t nil)
+Main entry point for MPC." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mpc" '("mpc-" "tag-browser-tagtypes")))
@@ -21928,9 +21352,7 @@ Main entry point for MPC.
;;; Generated autoloads from play/mpuz.el
(autoload 'mpuz "mpuz" "\
-Multiplication puzzle with GNU Emacs.
-
-\(fn)" t nil)
+Multiplication puzzle with GNU Emacs." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mpuz" '("mpuz-")))
@@ -21951,9 +21373,11 @@ or call the function `msb-mode'.")
(autoload 'msb-mode "msb" "\
Toggle Msb mode.
-With a prefix argument ARG, enable Msb mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
+
+If called interactively, enable Msb mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
This mode overrides the binding(s) of `mouse-buffer-menu' to provide a
different buffer menu using the function `msb'.
@@ -22037,14 +21461,10 @@ in place of `..':
`default-process-coding-system' for read
eol-type of `default-process-coding-system' for read
`default-process-coding-system' for write
- eol-type of `default-process-coding-system'
-
-\(fn)" t nil)
+ eol-type of `default-process-coding-system'" t nil)
(autoload 'describe-current-coding-system "mule-diag" "\
-Display coding systems currently used, in detail.
-
-\(fn)" t nil)
+Display coding systems currently used, in detail." t nil)
(autoload 'list-coding-systems "mule-diag" "\
Display a list of all coding systems.
@@ -22056,9 +21476,7 @@ but still contains full information about each coding system.
\(fn &optional ARG)" t nil)
(autoload 'list-coding-categories "mule-diag" "\
-Display a list of all coding categories.
-
-\(fn)" nil nil)
+Display a list of all coding categories." nil nil)
(autoload 'describe-font "mule-diag" "\
Display information about a font whose name is FONTNAME.
@@ -22081,9 +21499,7 @@ see the function `describe-fontset' for the format of the list.
\(fn ARG)" t nil)
(autoload 'list-input-methods "mule-diag" "\
-Display information about all input methods.
-
-\(fn)" t nil)
+Display information about all input methods." t nil)
(autoload 'mule-diag "mule-diag" "\
Display diagnosis of the multilingual environment (Mule).
@@ -22091,9 +21507,7 @@ Display diagnosis of the multilingual environment (Mule).
This shows various information related to the current multilingual
environment, including lists of input methods, coding systems,
character sets, and fontsets (if Emacs is running under a window
-system which uses fontsets).
-
-\(fn)" t nil)
+system which uses fontsets)." t nil)
(autoload 'font-show-log "mule-diag" "\
Show log of font listing and opening.
@@ -22102,7 +21516,7 @@ The default is 20. If LIMIT is negative, do not limit the listing.
\(fn &optional LIMIT)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mule-diag" '("insert-section" "list-" "print-" "describe-font-internal" "charset-history" "non-iso-charset-alist" "sort-listed-character-sets")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mule-diag" '("charset-history" "describe-font-internal" "insert-section" "list-" "non-iso-charset-alist" "print-" "sort-listed-character-sets")))
;;;***
@@ -22273,29 +21687,19 @@ QUALITY can be:
;;; Generated autoloads from net/net-utils.el
(autoload 'ifconfig "net-utils" "\
-Run `ifconfig-program' and display diagnostic output.
-
-\(fn)" t nil)
+Run `ifconfig-program' and display diagnostic output." t nil)
(autoload 'iwconfig "net-utils" "\
-Run `iwconfig-program' and display diagnostic output.
-
-\(fn)" t nil)
+Run `iwconfig-program' and display diagnostic output." t nil)
(autoload 'netstat "net-utils" "\
-Run `netstat-program' and display diagnostic output.
-
-\(fn)" t nil)
+Run `netstat-program' and display diagnostic output." t nil)
(autoload 'arp "net-utils" "\
-Run `arp-program' and display diagnostic output.
-
-\(fn)" t nil)
+Run `arp-program' and display diagnostic output." t nil)
(autoload 'route "net-utils" "\
-Run `route-program' and display diagnostic output.
-
-\(fn)" t nil)
+Run `route-program' and display diagnostic output." t nil)
(autoload 'traceroute "net-utils" "\
Run `traceroute-program' for TARGET.
@@ -22320,9 +21724,7 @@ This command uses `nslookup-program' for looking up the DNS information.
\(fn HOST &optional NAME-SERVER)" t nil)
(autoload 'nslookup "net-utils" "\
-Run `nslookup-program'.
-
-\(fn)" t nil)
+Run `nslookup-program'." t nil)
(autoload 'dns-lookup-host "net-utils" "\
Look up the DNS information for HOST (name or IP address).
@@ -22364,10 +21766,7 @@ The port is deduced from `network-connection-service-alist'.
\(fn ARG SEARCH-STRING)" t nil)
-(autoload 'whois-reverse-lookup "net-utils" "\
-
-
-\(fn)" t nil)
+(autoload 'whois-reverse-lookup "net-utils" nil t nil)
(autoload 'network-connection-to-service "net-utils" "\
Open a network connection to SERVICE on HOST.
@@ -22380,7 +21779,7 @@ Open a network connection to HOST on PORT.
\(fn HOST PORT)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "net-utils" '("nslookup-" "net" "whois-" "ftp-" "finger-X.500-host-regexps" "route-program" "run-network-program" "smbclient" "ifconfig-program" "iwconfig-program" "ipconfig" "dig-program" "dns-lookup-program" "arp-program" "ping-program" "traceroute-program")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "net-utils" '("arp-program" "dig-program" "dns-lookup-program" "finger-X.500-host-regexps" "ftp-" "ifconfig-program" "ipconfig" "iwconfig-program" "net" "nslookup-" "ping-program" "route-program" "run-network-program" "smbclient" "traceroute-program" "whois-")))
;;;***
@@ -22514,9 +21913,7 @@ gnutls-boot (as returned by `gnutls-boot-parameters').
(autoload 'newsticker-running-p "newst-backend" "\
Check whether newsticker is running.
Return t if newsticker is running, nil otherwise. Newsticker is
-considered to be running if the newsticker timer list is not empty.
-
-\(fn)" nil nil)
+considered to be running if the newsticker timer list is not empty." nil nil)
(autoload 'newsticker-start "newst-backend" "\
Start the newsticker.
@@ -22536,9 +21933,7 @@ Run `newsticker-start-hook' if newsticker was not running already.
;;; Generated autoloads from net/newst-plainview.el
(autoload 'newsticker-plainview "newst-plainview" "\
-Start newsticker plainview.
-
-\(fn)" t nil)
+Start newsticker plainview." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "newst-plainview" '("newsticker-")))
@@ -22549,9 +21944,7 @@ Start newsticker plainview.
;;; Generated autoloads from net/newst-reader.el
(autoload 'newsticker-show-news "newst-reader" "\
-Start reading news. You may want to bind this to a key.
-
-\(fn)" t nil)
+Start reading news. You may want to bind this to a key." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "newst-reader" '("newsticker-")))
@@ -22565,16 +21958,12 @@ Start reading news. You may want to bind this to a key.
Check whether newsticker's actual ticker is running.
Return t if ticker is running, nil otherwise. Newsticker is
considered to be running if the newsticker timer list is not
-empty.
-
-\(fn)" nil nil)
+empty." nil nil)
(autoload 'newsticker-start-ticker "newst-ticker" "\
Start newsticker's ticker (but not the news retrieval).
Start display timer for the actual ticker if wanted and not
-running already.
-
-\(fn)" t nil)
+running already." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "newst-ticker" '("newsticker-")))
@@ -22585,9 +21974,7 @@ running already.
;;; Generated autoloads from net/newst-treeview.el
(autoload 'newsticker-treeview "newst-treeview" "\
-Start newsticker treeview.
-
-\(fn)" t nil)
+Start newsticker treeview." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "newst-treeview" '("newsticker-")))
@@ -22668,9 +22055,7 @@ symbol in the alist.
(autoload 'nnfolder-generate-active-file "nnfolder" "\
Look for mbox folders in the nnfolder directory and make them into groups.
-This command does not work if you use short group names.
-
-\(fn)" t nil)
+This command does not work if you use short group names." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnfolder" '("nnfolder-")))
@@ -22686,21 +22071,21 @@ This command does not work if you use short group names.
;;;### (autoloads nil "nnheader" "gnus/nnheader.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnheader.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnheader" '("nntp-" "nnheader-" "mail-header-" "make-" "gnus-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnheader" '("gnus-" "mail-header-" "make-" "nnheader-" "nntp-")))
;;;***
;;;### (autoloads nil "nnimap" "gnus/nnimap.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnimap.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnimap" '("nnimap")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnimap" '("nnimap-")))
;;;***
;;;### (autoloads nil "nnir" "gnus/nnir.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnir.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnir" '("nnir-" "gnus-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnir" '("gnus-" "nnir-")))
;;;***
@@ -22761,7 +22146,7 @@ Generate NOV databases in all nnml directories.
;;;### (autoloads nil "nnoo" "gnus/nnoo.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnoo.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnoo" '("nnoo-" "defvoo" "deffoo")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnoo" '("deffoo" "defvoo" "nnoo-")))
;;;***
@@ -22817,8 +22202,6 @@ Generate NOV databases in all nnml directories.
;;;### (autoloads nil "novice" "novice.el" (0 0 0 0))
;;; Generated autoloads from novice.el
-(define-obsolete-variable-alias 'disabled-command-hook 'disabled-command-function "22.1")
-
(defvar disabled-command-function 'disabled-command-function "\
Function to call to handle disabled commands.
If nil, the feature is disabled, i.e., all commands work normally.")
@@ -22868,7 +22251,7 @@ closing requests for requests that are used in matched pairs.
;;;### (autoloads nil "nsm" "net/nsm.el" (0 0 0 0))
;;; Generated autoloads from net/nsm.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nsm" '("network-security-level" "nsm-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nsm" '("network-security-" "nsm-")))
;;;***
@@ -22938,11 +22321,10 @@ The Emacs commands that normally operate on balanced expressions will
operate on XML markup items. Thus \\[forward-sexp] will move forward
across one markup item; \\[backward-sexp] will move backward across
one markup item; \\[kill-sexp] will kill the following markup item;
-\\[mark-sexp] will mark the following markup item. By default, each
-tag each treated as a single markup item; to make the complete element
-be treated as a single markup item, set the variable
-`nxml-sexp-element-flag' to t. For more details, see the function
-`nxml-forward-balanced-item'.
+\\[mark-sexp] will mark the following markup item. By default, the
+complete element is treated as a single markup item; to make each tag be
+treated as a separate markup item, set the variable `nxml-sexp-element-flag'
+to nil. For more details, see the function `nxml-forward-balanced-item'.
\\[nxml-backward-up-element] and \\[nxml-down-element] move up and down the element structure.
@@ -23059,7 +22441,7 @@ Many aspects this mode can be customized using
;;;### (autoloads nil "ob-coq" "org/ob-coq.el" (0 0 0 0))
;;; Generated autoloads from org/ob-coq.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-coq" '("org-babel-" "coq-program-name")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-coq" '("coq-program-name" "org-babel-")))
;;;***
@@ -23139,7 +22521,7 @@ Many aspects this mode can be customized using
;;;### (autoloads nil "ob-gnuplot" "org/ob-gnuplot.el" (0 0 0 0))
;;; Generated autoloads from org/ob-gnuplot.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-gnuplot" '("org-babel-" "*org-babel-gnuplot-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-gnuplot" '("*org-babel-gnuplot-" "org-babel-")))
;;;***
@@ -23210,7 +22592,7 @@ Many aspects this mode can be customized using
;;;### (autoloads nil "ob-lilypond" "org/ob-lilypond.el" (0 0 0 0))
;;; Generated autoloads from org/ob-lilypond.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-lilypond" '("org-babel-" "lilypond-mode")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-lilypond" '("lilypond-mode" "org-babel-")))
;;;***
@@ -23416,6 +22798,10 @@ Many aspects this mode can be customized using
;;;### (autoloads nil "octave" "progmodes/octave.el" (0 0 0 0))
;;; Generated autoloads from progmodes/octave.el
+ (add-to-list 'auto-mode-alist '("\\.m\\'" . octave-maybe-mode))
+
+(autoload 'octave-maybe-mode "octave" "\
+Select `octave-mode' if the current buffer seems to hold Octave code." nil nil)
(autoload 'octave-mode "octave" "\
Major mode for editing Octave code.
@@ -23449,7 +22835,7 @@ startup file, `~/.emacs-octave'.
(defalias 'run-octave 'inferior-octave)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "octave" '("octave-" "inferior-octave-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "octave" '("inferior-octave-" "octave-")))
;;;***
@@ -23525,14 +22911,10 @@ FULL is given.
\(fn &optional HERE FULL MESSAGE)" t nil)
(autoload 'turn-on-orgtbl "org" "\
-Unconditionally turn on `orgtbl-mode'.
-
-\(fn)" nil nil)
+Unconditionally turn on `orgtbl-mode'." nil nil)
(autoload 'org-clock-persistence-insinuate "org" "\
-Set up hooks for clock persistence.
-
-\(fn)" nil nil)
+Set up hooks for clock persistence." nil nil)
(autoload 'org-mode "org" "\
Outline-based notes management and organizer, alias
@@ -23622,17 +23004,18 @@ modes. The following keys behave as if Org mode were active, if
the cursor is on a headline, or on a plain list item (both as
defined by Org mode).
+If called interactively, enable OrgStruct mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
\(fn &optional ARG)" t nil)
(autoload 'turn-on-orgstruct "org" "\
-Unconditionally turn on `orgstruct-mode'.
-
-\(fn)" nil nil)
+Unconditionally turn on `orgstruct-mode'." nil nil)
(autoload 'turn-on-orgstruct++ "org" "\
-Unconditionally turn on `orgstruct++-mode'.
-
-\(fn)" nil nil)
+Unconditionally turn on `orgstruct++-mode'." nil nil)
(autoload 'org-run-like-in-org-mode "org" "\
Run a command, pretending that the current buffer is in Org mode.
@@ -23662,18 +23045,14 @@ active region.
(autoload 'org-insert-link-global "org" "\
Insert a link like Org mode does.
-This command can be called in any mode to insert a link in Org syntax.
-
-\(fn)" t nil)
+This command can be called in any mode to insert a link in Org syntax." t nil)
(autoload 'org-open-at-point-global "org" "\
Follow a link or time-stamp like Org mode does.
This command can be called in any mode to follow an external link
or a time-stamp that has Org mode syntax. Its behavior is
undefined when called on internal links (e.g., fuzzy links).
-Raise an error when there is nothing to follow.
-
-\(fn)" t nil)
+Raise an error when there is nothing to follow. " t nil)
(autoload 'org-open-link-from-string "org" "\
Open a link in the string S, as if it was in Org mode.
@@ -23692,9 +23071,7 @@ With `\\[universal-argument] \\[universal-argument]' prefix, restrict available
(autoload 'org-cycle-agenda-files "org" "\
Cycle through the files in `org-agenda-files'.
If the current buffer visits an agenda file, find the next one in the list.
-If the current buffer does not, find the first agenda file.
-
-\(fn)" t nil)
+If the current buffer does not, find the first agenda file." t nil)
(autoload 'org-submit-bug-report "org" "\
Submit a bug report on Org via mail.
@@ -23703,9 +23080,7 @@ Don't hesitate to report any problems or inaccurate documentation.
If you don't have setup sending mail from (X)Emacs, please copy the
output buffer into your mail program, as it gives us important
-information about your Org version and configuration.
-
-\(fn)" t nil)
+information about your Org version and configuration." t nil)
(autoload 'org-reload "org" "\
Reload all Org Lisp files.
@@ -23714,9 +23089,7 @@ With prefix arg UNCOMPILED, load the uncompiled versions.
\(fn &optional UNCOMPILED)" t nil)
(autoload 'org-customize "org" "\
-Call the customize function with org as argument.
-
-\(fn)" t nil)
+Call the customize function with org as argument." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org" '("org" "turn-on-org-cdlatex")))
@@ -23954,9 +23327,7 @@ in the file. Otherwise, restriction will be to the current subtree.
(autoload 'org-calendar-goto-agenda "org-agenda" "\
Compute the Org agenda for the calendar date displayed at the cursor.
-This is a command that has to be installed in `calendar-mode-map'.
-
-\(fn)" t nil)
+This is a command that has to be installed in `calendar-mode-map'." t nil)
(autoload 'org-agenda-to-appt "org-agenda" "\
Activate appointments found in `org-agenda-files'.
@@ -24068,9 +23439,7 @@ of the day at point (if any) or the current HH:MM time.
\(fn &optional GOTO KEYS)" t nil)
(autoload 'org-capture-import-remember-templates "org-capture" "\
-Set `org-capture-templates' to be similar to `org-remember-templates'.
-
-\(fn)" t nil)
+Set `org-capture-templates' to be similar to `org-remember-templates'." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-capture" '("org-")))
@@ -24088,14 +23457,9 @@ Set `org-capture-templates' to be similar to `org-remember-templates'.
;;; Generated autoloads from org/org-colview.el
(autoload 'org-columns-remove-overlays "org-colview" "\
-Remove all currently active column overlays.
-
-\(fn)" t nil)
+Remove all currently active column overlays." t nil)
-(autoload 'org-columns-get-format-and-top-level "org-colview" "\
-
-
-\(fn)" nil nil)
+(autoload 'org-columns-get-format-and-top-level "org-colview" nil nil nil)
(autoload 'org-columns "org-colview" "\
Turn on column view on an Org mode file.
@@ -24141,14 +23505,10 @@ PARAMS is a property list of parameters:
\(fn PARAMS)" nil nil)
(autoload 'org-columns-insert-dblock "org-colview" "\
-Create a dynamic block capturing a column view table.
-
-\(fn)" t nil)
+Create a dynamic block capturing a column view table." t nil)
(autoload 'org-agenda-columns "org-colview" "\
-Turn on or update column view in the agenda.
-
-\(fn)" t nil)
+Turn on or update column view in the agenda." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-colview" '("org-")))
@@ -24158,9 +23518,7 @@ Turn on or update column view in the agenda.
;;; Generated autoloads from org/org-compat.el
(autoload 'org-check-version "org-compat" "\
-Try very hard to provide sensible version strings.
-
-\(fn)" nil t)
+Try very hard to provide sensible version strings." nil t)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-compat" '("org-")))
@@ -24200,9 +23558,7 @@ Try very hard to provide sensible version strings.
;;; Generated autoloads from org/org-duration.el
(autoload 'org-duration-set-regexps "org-duration" "\
-Set duration related regexps.
-
-\(fn)" t nil)
+Set duration related regexps." t nil)
(autoload 'org-duration-p "org-duration" "\
Non-nil when string S is a time duration.
@@ -24483,15 +23839,11 @@ Load FILE with optional arguments NOERROR and MUSTSUFFIX.
(autoload 'org-release "org-version" "\
The release version of Org.
-Inserted by installing Org mode or when a release is made.
-
-\(fn)" nil nil)
+Inserted by installing Org mode or when a release is made." nil nil)
(autoload 'org-git-version "org-version" "\
The Git version of Org mode.
-Inserted by installing Org or when a release is made.
-
-\(fn)" nil nil)
+Inserted by installing Org or when a release is made." nil nil)
;;;***
@@ -24534,9 +23886,11 @@ Turning on outline mode calls the value of `text-mode-hook' and then of
(autoload 'outline-minor-mode "outline" "\
Toggle Outline minor mode.
-With a prefix argument ARG, enable Outline minor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Outline minor mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
See the command `outline-mode' for more information on this mode.
@@ -24648,13 +24002,17 @@ See the command `outline-mode' for more information on this mode.
(push (purecopy '(package 1 1 0)) package--builtin-versions)
(defvar package-enable-at-startup t "\
-Whether to activate installed packages when Emacs starts.
-If non-nil, packages are activated after reading the init file
-and before `after-init-hook'. Activation is not done if
-`user-init-file' is nil (e.g. Emacs was started with \"-q\").
+Whether to make installed packages available when Emacs starts.
+If non-nil, packages are made available before reading the init
+file (but after reading the early init file). This means that if
+you wish to set this variable, you must do so in the early init
+file. Regardless of the value of this variable, packages are not
+made available if `user-init-file' is nil (e.g. Emacs was started
+with \"-q\").
Even if the value is nil, you can type \\[package-initialize] to
-activate the package system at any time.")
+make installed packages available at any time, or you can
+call (package-initialize) in your init-file.")
(custom-autoload 'package-enable-at-startup "package" t)
@@ -24662,17 +24020,27 @@ activate the package system at any time.")
Load Emacs Lisp packages, and activate them.
The variable `package-load-list' controls which packages to load.
If optional arg NO-ACTIVATE is non-nil, don't activate packages.
-If `user-init-file' does not mention `(package-initialize)', add
-it to the file.
If called as part of loading `user-init-file', set
`package-enable-at-startup' to nil, to prevent accidentally
loading packages twice.
+
It is not necessary to adjust `load-path' or `require' the
individual packages after calling `package-initialize' -- this is
taken care of by `package-initialize'.
+If `package-initialize' is called twice during Emacs startup,
+signal a warning, since this is a bad idea except in highly
+advanced use cases. To suppress the warning, remove the
+superfluous call to `package-initialize' from your init-file. If
+you have code which must run before `package-initialize', put
+that code in the early init-file.
+
\(fn &optional NO-ACTIVATE)" t nil)
+(autoload 'package-activate-all "package" "\
+Activate all installed packages.
+The variable `package-load-list' controls which packages to load." nil nil)
+
(autoload 'package-import-keyring "package" "\
Import keys from FILE.
@@ -24711,9 +24079,7 @@ Specially, if current buffer is a directory, the -pkg.el
description file is not mandatory, in which case the information
is derived from the main .el file in the directory.
-Downloads and installs required packages as needed.
-
-\(fn)" t nil)
+Downloads and installs required packages as needed." t nil)
(autoload 'package-install-file "package" "\
Install a package from a file.
@@ -24724,9 +24090,7 @@ directory.
(autoload 'package-install-selected-packages "package" "\
Ensure packages in `package-selected-packages' are installed.
-If some packages are not installed propose to install them.
-
-\(fn)" t nil)
+If some packages are not installed propose to install them." t nil)
(autoload 'package-reinstall "package" "\
Reinstall package PKG.
@@ -24740,9 +24104,7 @@ Remove packages that are no more needed.
Packages that are no more needed by other packages in
`package-selected-packages' and their dependencies
-will be deleted.
-
-\(fn)" t nil)
+will be deleted." t nil)
(autoload 'describe-package "package" "\
Display the full documentation of PACKAGE (a symbol).
@@ -24761,7 +24123,15 @@ short description.
(defalias 'package-list-packages 'list-packages)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "package" '("package-" "define-package" "describe-package-1" "bad-signature")))
+(autoload 'package-get-version "package" "\
+Return the version number of the package in which this is used.
+Assumes it is used from an Elisp file placed inside the top-level directory
+of an installed ELPA package.
+The return value is a string (or nil in case we can't find it)." nil nil)
+
+(function-put 'package-get-version 'pure 't)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "package" '("bad-signature" "define-package" "describe-package-1" "package-")))
;;;***
@@ -24776,7 +24146,7 @@ short description.
;;;### (autoloads nil "page-ext" "textmodes/page-ext.el" (0 0 0 0))
;;; Generated autoloads from textmodes/page-ext.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "page-ext" '("previous-page" "pages-" "sort-pages-" "original-page-delimiter" "add-new-page" "next-page" "ctl-x-ctl-p-map")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "page-ext" '("add-new-page" "ctl-x-ctl-p-map" "next-page" "original-page-delimiter" "pages-" "previous-page" "sort-pages-")))
;;;***
@@ -24795,9 +24165,11 @@ or call the function `show-paren-mode'.")
(autoload 'show-paren-mode "paren" "\
Toggle visualization of matching parens (Show Paren mode).
-With a prefix argument ARG, enable Show Paren mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Show-Paren mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Show Paren mode is a global minor mode. When enabled, any
matching parenthesis is highlighted in `show-paren-style' after
@@ -24821,7 +24193,8 @@ STRING should be something resembling an RFC 822 (or later) date-time, e.g.,
somewhat liberal in what format it accepts, and will attempt to
return a \"likely\" value even for somewhat malformed strings.
The values returned are identical to those of `decode-time', but
-any values that are unknown are returned as nil.
+any unknown values other than DST are returned as nil, and an
+unknown DST value is returned as -1.
\(fn STRING)" nil nil)
@@ -24876,7 +24249,7 @@ See also the user variables `pascal-type-keywords', `pascal-start-keywords' and
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pascal" '("pascal-" "electric-pascal-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pascal" '("electric-pascal-" "pascal-")))
;;;***
@@ -24951,6 +24324,10 @@ Emacs Lisp manual for more information and examples.
(function-put 'pcase 'lisp-indent-function '1)
+(put 'pcase 'function-documentation '(pcase--make-docstring))
+
+(autoload 'pcase--make-docstring "pcase" nil nil nil)
+
(autoload 'pcase-exhaustive "pcase" "\
The exhaustive version of `pcase' (which see).
If EXP fails to match any of the patterns in CASES, an error is signaled.
@@ -25038,9 +24415,7 @@ for the result of evaluating EXP (first arg to `pcase').
;;; Generated autoloads from pcmpl-cvs.el
(autoload 'pcomplete/cvs "pcmpl-cvs" "\
-Completion rules for the `cvs' command.
-
-\(fn)" nil nil)
+Completion rules for the `cvs' command." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcmpl-cvs" '("pcmpl-cvs-")))
@@ -25050,29 +24425,19 @@ Completion rules for the `cvs' command.
;;; Generated autoloads from pcmpl-gnu.el
(autoload 'pcomplete/gzip "pcmpl-gnu" "\
-Completion for `gzip'.
-
-\(fn)" nil nil)
+Completion for `gzip'." nil nil)
(autoload 'pcomplete/bzip2 "pcmpl-gnu" "\
-Completion for `bzip2'.
-
-\(fn)" nil nil)
+Completion for `bzip2'." nil nil)
(autoload 'pcomplete/make "pcmpl-gnu" "\
-Completion for GNU `make'.
-
-\(fn)" nil nil)
+Completion for GNU `make'." nil nil)
(autoload 'pcomplete/tar "pcmpl-gnu" "\
-Completion for the GNU tar utility.
-
-\(fn)" nil nil)
+Completion for the GNU tar utility." nil nil)
(autoload 'pcomplete/find "pcmpl-gnu" "\
-Completion for the GNU find utility.
-
-\(fn)" nil nil)
+Completion for the GNU find utility." nil nil)
(defalias 'pcomplete/gdb 'pcomplete/xargs)
@@ -25084,21 +24449,15 @@ Completion for the GNU find utility.
;;; Generated autoloads from pcmpl-linux.el
(autoload 'pcomplete/kill "pcmpl-linux" "\
-Completion for GNU/Linux `kill', using /proc filesystem.
-
-\(fn)" nil nil)
+Completion for GNU/Linux `kill', using /proc filesystem." nil nil)
(autoload 'pcomplete/umount "pcmpl-linux" "\
-Completion for GNU/Linux `umount'.
-
-\(fn)" nil nil)
+Completion for GNU/Linux `umount'." nil nil)
(autoload 'pcomplete/mount "pcmpl-linux" "\
-Completion for GNU/Linux `mount'.
+Completion for GNU/Linux `mount'." nil nil)
-\(fn)" nil nil)
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcmpl-linux" '("pcomplete-pare-list" "pcmpl-linux-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcmpl-linux" '("pcmpl-linux-" "pcomplete-pare-list")))
;;;***
@@ -25106,9 +24465,7 @@ Completion for GNU/Linux `mount'.
;;; Generated autoloads from pcmpl-rpm.el
(autoload 'pcomplete/rpm "pcmpl-rpm" "\
-Completion for the `rpm' command.
-
-\(fn)" nil nil)
+Completion for the `rpm' command." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcmpl-rpm" '("pcmpl-rpm-")))
@@ -25118,54 +24475,36 @@ Completion for the `rpm' command.
;;; Generated autoloads from pcmpl-unix.el
(autoload 'pcomplete/cd "pcmpl-unix" "\
-Completion for `cd'.
-
-\(fn)" nil nil)
+Completion for `cd'." nil nil)
(defalias 'pcomplete/pushd 'pcomplete/cd)
(autoload 'pcomplete/rmdir "pcmpl-unix" "\
-Completion for `rmdir'.
-
-\(fn)" nil nil)
+Completion for `rmdir'." nil nil)
(autoload 'pcomplete/rm "pcmpl-unix" "\
-Completion for `rm'.
-
-\(fn)" nil nil)
+Completion for `rm'." nil nil)
(autoload 'pcomplete/xargs "pcmpl-unix" "\
-Completion for `xargs'.
-
-\(fn)" nil nil)
+Completion for `xargs'." nil nil)
(defalias 'pcomplete/time 'pcomplete/xargs)
(autoload 'pcomplete/which "pcmpl-unix" "\
-Completion for `which'.
-
-\(fn)" nil nil)
+Completion for `which'." nil nil)
(autoload 'pcomplete/chown "pcmpl-unix" "\
-Completion for the `chown' command.
-
-\(fn)" nil nil)
+Completion for the `chown' command." nil nil)
(autoload 'pcomplete/chgrp "pcmpl-unix" "\
-Completion for the `chgrp' command.
-
-\(fn)" nil nil)
+Completion for the `chgrp' command." nil nil)
(autoload 'pcomplete/ssh "pcmpl-unix" "\
-Completion rules for the `ssh' command.
-
-\(fn)" nil nil)
+Completion rules for the `ssh' command." nil nil)
(autoload 'pcomplete/scp "pcmpl-unix" "\
Completion rules for the `scp' command.
-Includes files as well as host names followed by a colon.
-
-\(fn)" nil nil)
+Includes files as well as host names followed by a colon." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcmpl-unix" '("pcmpl-")))
@@ -25175,23 +24514,17 @@ Includes files as well as host names followed by a colon.
;;; Generated autoloads from pcmpl-x.el
(autoload 'pcomplete/tlmgr "pcmpl-x" "\
-Completion for the `tlmgr' command.
-
-\(fn)" nil nil)
+Completion for the `tlmgr' command." nil nil)
(autoload 'pcomplete/ack "pcmpl-x" "\
Completion for the `ack' command.
Start an argument with `-' to complete short options and `--' for
-long options.
-
-\(fn)" nil nil)
+long options." nil nil)
(defalias 'pcomplete/ack-grep 'pcomplete/ack)
(autoload 'pcomplete/ag "pcmpl-x" "\
-Completion for the `ag' command.
-
-\(fn)" nil nil)
+Completion for the `ag' command." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcmpl-x" '("pcmpl-x-")))
@@ -25208,36 +24541,24 @@ completion functions list (it should occur fairly early in the list).
\(fn &optional INTERACTIVELY)" t nil)
(autoload 'pcomplete-reverse "pcomplete" "\
-If cycling completion is in use, cycle backwards.
-
-\(fn)" t nil)
+If cycling completion is in use, cycle backwards." t nil)
(autoload 'pcomplete-expand-and-complete "pcomplete" "\
Expand the textual value of the current argument.
-This will modify the current buffer.
-
-\(fn)" t nil)
+This will modify the current buffer." t nil)
(autoload 'pcomplete-continue "pcomplete" "\
-Complete without reference to any cycling completions.
-
-\(fn)" t nil)
+Complete without reference to any cycling completions." t nil)
(autoload 'pcomplete-expand "pcomplete" "\
Expand the textual value of the current argument.
-This will modify the current buffer.
-
-\(fn)" t nil)
+This will modify the current buffer." t nil)
(autoload 'pcomplete-help "pcomplete" "\
-Display any help information relative to the current argument.
-
-\(fn)" t nil)
+Display any help information relative to the current argument." t nil)
(autoload 'pcomplete-list "pcomplete" "\
-Show the list of possible completions for the current argument.
-
-\(fn)" t nil)
+Show the list of possible completions for the current argument." t nil)
(autoload 'pcomplete-comint-setup "pcomplete" "\
Setup a comint buffer to use pcomplete.
@@ -25248,9 +24569,7 @@ this is `comint-dynamic-complete-functions'.
\(fn COMPLETEF-SYM)" nil nil)
(autoload 'pcomplete-shell-setup "pcomplete" "\
-Setup `shell-mode' to use pcomplete.
-
-\(fn)" nil nil)
+Setup `shell-mode' to use pcomplete." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcomplete" '("pcomplete-")))
@@ -25327,7 +24646,7 @@ Anything else means to do it only if the prefix arg is equal to this value.")
(defun cvs-dired-noselect (dir) "\
Run `cvs-examine' if DIR is a CVS administrative directory.
-The exact behavior is determined also by `cvs-dired-use-hook'." (when (stringp dir) (setq dir (directory-file-name dir)) (when (and (string= "CVS" (file-name-nondirectory dir)) (file-readable-p (expand-file-name "Entries" dir)) cvs-dired-use-hook (if (eq cvs-dired-use-hook (quote always)) (not current-prefix-arg) (equal current-prefix-arg cvs-dired-use-hook))) (save-excursion (funcall cvs-dired-action (file-name-directory dir) t t)))))
+The exact behavior is determined also by `cvs-dired-use-hook'." (when (stringp dir) (setq dir (directory-file-name dir)) (when (and (string= "CVS" (file-name-nondirectory dir)) (file-readable-p (expand-file-name "Entries" dir)) cvs-dired-use-hook (if (eq cvs-dired-use-hook 'always) (not current-prefix-arg) (equal current-prefix-arg cvs-dired-use-hook))) (save-excursion (funcall cvs-dired-action (file-name-directory dir) t t)))))
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcvs" '("cvs-" "defun-cvs-mode")))
@@ -25432,7 +24751,7 @@ Turning on Perl mode runs the normal hook `perl-mode-hook'.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "perl-mode" '("perl-" "mark-perl-function" "indent-perl-exp")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "perl-mode" '("indent-perl-exp" "mark-perl-function" "perl-")))
;;;***
@@ -25508,9 +24827,7 @@ by supplying an argument.
Entry to this mode calls the value of `picture-mode-hook' if non-nil.
Note that Picture mode commands will work outside of Picture mode, but
-they are not by default assigned to keys.
-
-\(fn)" t nil)
+they are not by default assigned to keys." t nil)
(defalias 'edit-picture 'picture-mode)
@@ -25518,6 +24835,13 @@ they are not by default assigned to keys.
;;;***
+;;;### (autoloads nil "pinyin" "language/pinyin.el" (0 0 0 0))
+;;; Generated autoloads from language/pinyin.el
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pinyin" '("pinyin-character-map")))
+
+;;;***
+
;;;### (autoloads nil "pixel-scroll" "pixel-scroll.el" (0 0 0 0))
;;; Generated autoloads from pixel-scroll.el
@@ -25533,9 +24857,11 @@ or call the function `pixel-scroll-mode'.")
(autoload 'pixel-scroll-mode "pixel-scroll" "\
A minor mode to scroll text pixel-by-pixel.
-With a prefix argument ARG, enable Pixel Scroll mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable Pixel Scroll mode
-if ARG is omitted or nil.
+
+If called interactively, enable Pixel-Scroll mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
\(fn &optional ARG)" t nil)
@@ -25583,9 +24909,7 @@ Move left and right bats and try to bounce the ball to your opponent.
pong-mode keybindings:\\<pong-mode-map>
-\\{pong-mode-map}
-
-\(fn)" t nil)
+\\{pong-mode-map}" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pong" '("pong-")))
@@ -25615,9 +24939,7 @@ to make output that `read' can handle, whenever this is possible.
\(fn OBJECT)" nil nil)
(autoload 'pp-buffer "pp" "\
-Prettify the current buffer with printed representation of a Lisp object.
-
-\(fn)" nil nil)
+Prettify the current buffer with printed representation of a Lisp object." nil nil)
(autoload 'pp "pp" "\
Output the pretty-printed representation of OBJECT, any Lisp object.
@@ -25879,16 +25201,12 @@ See also documentation for `pr-list-directory'.
(autoload 'pr-printify-buffer "printing" "\
Replace nonprinting characters in buffer with printable representations.
The printable representations use ^ (for ASCII control characters) or hex.
-The characters tab, linefeed, space, return and formfeed are not affected.
-
-\(fn)" t nil)
+The characters tab, linefeed, space, return and formfeed are not affected." t nil)
(autoload 'pr-printify-region "printing" "\
Replace nonprinting characters in region with printable representations.
The printable representations use ^ (for ASCII control characters) or hex.
-The characters tab, linefeed, space, return and formfeed are not affected.
-
-\(fn)" t nil)
+The characters tab, linefeed, space, return and formfeed are not affected." t nil)
(autoload 'pr-txt-directory "printing" "\
Print directory using text printer.
@@ -25904,19 +25222,13 @@ See also documentation for `pr-list-directory'.
\(fn &optional DIR FILE-REGEXP)" t nil)
(autoload 'pr-txt-buffer "printing" "\
-Print buffer using text printer.
-
-\(fn)" t nil)
+Print buffer using text printer." t nil)
(autoload 'pr-txt-region "printing" "\
-Print region using text printer.
-
-\(fn)" t nil)
+Print region using text printer." t nil)
(autoload 'pr-txt-mode "printing" "\
-Print major mode using text printer.
-
-\(fn)" t nil)
+Print major mode using text printer." t nil)
(autoload 'pr-despool-preview "printing" "\
Preview spooled PostScript.
@@ -26014,9 +25326,7 @@ file name.
\(fn N-UP IFILENAME &optional OFILENAME)" t nil)
(autoload 'pr-toggle-file-duplex "printing" "\
-Toggle duplex for PostScript file.
-
-\(fn)" t nil)
+Toggle duplex for PostScript file." t nil)
(autoload 'pr-toggle-file-tumble "printing" "\
Toggle tumble for PostScript file.
@@ -26024,34 +25334,22 @@ Toggle tumble for PostScript file.
If tumble is off, produces a printing suitable for binding on the left or
right.
If tumble is on, produces a printing suitable for binding at the top or
-bottom.
-
-\(fn)" t nil)
+bottom." t nil)
(autoload 'pr-toggle-file-landscape "printing" "\
-Toggle landscape for PostScript file.
-
-\(fn)" t nil)
+Toggle landscape for PostScript file." t nil)
(autoload 'pr-toggle-ghostscript "printing" "\
-Toggle printing using ghostscript.
-
-\(fn)" t nil)
+Toggle printing using ghostscript." t nil)
(autoload 'pr-toggle-faces "printing" "\
-Toggle printing with faces.
-
-\(fn)" t nil)
+Toggle printing with faces." t nil)
(autoload 'pr-toggle-spool "printing" "\
-Toggle spooling.
-
-\(fn)" t nil)
+Toggle spooling." t nil)
(autoload 'pr-toggle-duplex "printing" "\
-Toggle duplex.
-
-\(fn)" t nil)
+Toggle duplex." t nil)
(autoload 'pr-toggle-tumble "printing" "\
Toggle tumble.
@@ -26059,54 +25357,34 @@ Toggle tumble.
If tumble is off, produces a printing suitable for binding on the left or
right.
If tumble is on, produces a printing suitable for binding at the top or
-bottom.
-
-\(fn)" t nil)
+bottom." t nil)
(autoload 'pr-toggle-landscape "printing" "\
-Toggle landscape.
-
-\(fn)" t nil)
+Toggle landscape." t nil)
(autoload 'pr-toggle-upside-down "printing" "\
-Toggle upside-down.
-
-\(fn)" t nil)
+Toggle upside-down." t nil)
(autoload 'pr-toggle-line "printing" "\
-Toggle line number.
-
-\(fn)" t nil)
+Toggle line number." t nil)
(autoload 'pr-toggle-zebra "printing" "\
-Toggle zebra stripes.
-
-\(fn)" t nil)
+Toggle zebra stripes." t nil)
(autoload 'pr-toggle-header "printing" "\
-Toggle printing header.
-
-\(fn)" t nil)
+Toggle printing header." t nil)
(autoload 'pr-toggle-header-frame "printing" "\
-Toggle printing header frame.
-
-\(fn)" t nil)
+Toggle printing header frame." t nil)
(autoload 'pr-toggle-lock "printing" "\
-Toggle menu lock.
-
-\(fn)" t nil)
+Toggle menu lock." t nil)
(autoload 'pr-toggle-region "printing" "\
-Toggle whether the region is automagically detected.
-
-\(fn)" t nil)
+Toggle whether the region is automagically detected." t nil)
(autoload 'pr-toggle-mode "printing" "\
-Toggle auto mode.
-
-\(fn)" t nil)
+Toggle auto mode." t nil)
(autoload 'pr-customize "printing" "\
Customization of the `printing' group.
@@ -26124,19 +25402,13 @@ Help for the printing package.
\(fn &rest IGNORE)" t nil)
(autoload 'pr-ps-name "printing" "\
-Interactively select a PostScript printer.
-
-\(fn)" t nil)
+Interactively select a PostScript printer." t nil)
(autoload 'pr-txt-name "printing" "\
-Interactively select a text printer.
-
-\(fn)" t nil)
+Interactively select a text printer." t nil)
(autoload 'pr-ps-utility "printing" "\
-Interactively select a PostScript utility.
-
-\(fn)" t nil)
+Interactively select a PostScript utility." t nil)
(autoload 'pr-show-ps-setup "printing" "\
Show current ps-print settings.
@@ -26242,7 +25514,7 @@ are both set to t.
\(fn &optional SELECT-PRINTER)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "printing" '("pr-" "lpr-setup")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "printing" '("lpr-setup" "pr-")))
;;;***
@@ -26329,16 +25601,26 @@ pattern to search for.
(autoload 'project-find-file "project" "\
Visit a file (with completion) in the current project's roots.
The completion default is the filename at point, if one is
-recognized.
-
-\(fn)" t nil)
+recognized." t nil)
(autoload 'project-or-external-find-file "project" "\
Visit a file (with completion) in the current project's roots or external roots.
The completion default is the filename at point, if one is
-recognized.
+recognized." t nil)
-\(fn)" t nil)
+(autoload 'project-search "project" "\
+Search for REGEXP in all the files of the project.
+Stops when a match is found.
+To continue searching for next match, use command \\[fileloop-continue].
+
+\(fn REGEXP)" t nil)
+
+(autoload 'project-query-replace-regexp "project" "\
+Search for REGEXP in all the files of the project.
+Stops when a match is found.
+To continue searching for next match, use command \\[fileloop-continue].
+
+\(fn FROM TO)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "project" '("project-")))
@@ -26375,7 +25657,7 @@ With prefix argument ARG, restart the Prolog process if running before.
\(fn ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "prolog" '("prolog-" "mercury-mode-map")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "prolog" '("mercury-mode-map" "prolog-")))
;;;***
@@ -26482,9 +25764,7 @@ Any other value is treated as t.")
(custom-autoload 'ps-print-color-p "ps-print" t)
(autoload 'ps-print-customize "ps-print" "\
-Customization of ps-print group.
-
-\(fn)" t nil)
+Customization of ps-print group." t nil)
(autoload 'ps-print-buffer "ps-print" "\
Generate and print a PostScript image of the buffer.
@@ -26526,9 +25806,7 @@ Generate and spool a PostScript image of the buffer.
Like `ps-print-buffer' except that the PostScript image is saved in a local
buffer to be sent to the printer later.
-Use the command `ps-despool' to send the spooled images to the printer.
-
-\(fn)" t nil)
+Use the command `ps-despool' to send the spooled images to the printer." t nil)
(autoload 'ps-spool-buffer-with-faces "ps-print" "\
Generate and spool a PostScript image of the buffer.
@@ -26536,9 +25814,7 @@ Like the command `ps-spool-buffer', but includes font, color, and underline
information in the generated image. This command works only if you are using
a window system, so it has a way to determine color values.
-Use the command `ps-despool' to send the spooled images to the printer.
-
-\(fn)" t nil)
+Use the command `ps-despool' to send the spooled images to the printer." t nil)
(autoload 'ps-spool-region "ps-print" "\
Generate a PostScript image of the region and spool locally.
@@ -26575,9 +25851,7 @@ image in a file with that name.
Display the correspondence between a line length and a font size.
Done using the current ps-print setup.
Try: pr -t file | awk \\='{printf \"%3d %s
-\", length($0), $0}\\=' | sort -r | head
-
-\(fn)" t nil)
+\", length($0), $0}\\=' | sort -r | head" t nil)
(autoload 'ps-nb-pages-buffer "ps-print" "\
Display number of pages to print this buffer, for various font heights.
@@ -26592,9 +25866,7 @@ The table depends on the current ps-print setup.
\(fn NB-LINES)" t nil)
(autoload 'ps-setup "ps-print" "\
-Return the current PostScript-generation setup.
-
-\(fn)" nil nil)
+Return the current PostScript-generation setup." nil nil)
(autoload 'ps-extend-face-list "ps-print" "\
Extend face in ALIST-SYM.
@@ -26683,7 +25955,7 @@ Optional argument FACE specifies the face to do the highlighting.
;;;### (autoloads nil "python" "progmodes/python.el" (0 0 0 0))
;;; Generated autoloads from progmodes/python.el
-(push (purecopy '(python 0 25 2)) package--builtin-versions)
+(push (purecopy '(python 0 26 1)) package--builtin-versions)
(add-to-list 'auto-mode-alist (cons (purecopy "\\.py[iw]?\\'") 'python-mode))
@@ -26716,7 +25988,7 @@ Major mode for editing Python files.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "python" '("python-" "run-python-internal" "inferior-python-mode")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "python" '("inferior-python-mode" "python-" "run-python-internal")))
;;;***
@@ -26745,9 +26017,7 @@ them into characters should be done separately.
;;; Generated autoloads from international/quail.el
(autoload 'quail-title "quail" "\
-Return the title of the current Quail package.
-
-\(fn)" nil nil)
+Return the title of the current Quail package." nil nil)
(autoload 'quail-use-package "quail" "\
Start using Quail package PACKAGE-NAME.
@@ -26992,7 +26262,7 @@ HELP-TEXT is a text set in `hangul-input-method-help-text'.
\(fn INPUT-METHOD FUNC HELP-TEXT &rest ARGS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/hangul" '("hangul" "alphabetp" "notzerop")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/hangul" '("alphabetp" "hangul" "notzerop")))
;;;***
@@ -27083,7 +26353,7 @@ While this input method is active, the variable
;;;### (autoloads nil "quickurl" "net/quickurl.el" (0 0 0 0))
;;; Generated autoloads from net/quickurl.el
-(defconst quickurl-reread-hook-postfix "\n;; Local Variables:\n;; eval: (progn (require 'quickurl) (add-hook 'local-write-file-hooks (lambda () (quickurl-read) nil)))\n;; End:\n" "\
+(defconst quickurl-reread-hook-postfix "\n;; Local Variables:\n;; eval: (progn (require 'quickurl) (add-hook 'write-file-functions (lambda () (quickurl-read) nil) nil t))\n;; End:\n" "\
Example `quickurl-postfix' text that adds a local variable to the
`quickurl-url-file' so that if you edit it by hand it will ensure that
`quickurl-urls' is updated with the new URL list.
@@ -27131,9 +26401,7 @@ Browse the URL, with `completing-read' prompt, associated with LOOKUP.
\(fn LOOKUP)" t nil)
(autoload 'quickurl-edit-urls "quickurl" "\
-Pull `quickurl-url-file' into a buffer for hand editing.
-
-\(fn)" t nil)
+Pull `quickurl-url-file' into a buffer for hand editing." t nil)
(autoload 'quickurl-list-mode "quickurl" "\
A mode for browsing the quickurl URL list.
@@ -27145,9 +26413,7 @@ The key bindings for `quickurl-list-mode' are:
\(fn)" t nil)
(autoload 'quickurl-list "quickurl" "\
-Display `quickurl-list' as a formatted list using `quickurl-list-mode'.
-
-\(fn)" t nil)
+Display `quickurl-list' as a formatted list using `quickurl-list-mode'." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quickurl" '("quickurl-")))
@@ -27192,13 +26458,15 @@ or call the function `rcirc-track-minor-mode'.")
(autoload 'rcirc-track-minor-mode "rcirc" "\
Global minor mode for tracking activity in rcirc buffers.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
+
+If called interactively, enable Rcirc-Track minor mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rcirc" '("rcirc-" "defun-rcirc-command" "set-rcirc-" "with-rcirc-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rcirc" '("defun-rcirc-command" "rcirc-" "set-rcirc-" "with-rcirc-")))
;;;***
@@ -27215,11 +26483,9 @@ the regexp builder. It displays a buffer named \"*RE-Builder*\"
in another window, initially containing an empty regexp.
As you edit the regexp in the \"*RE-Builder*\" buffer, the
-matching parts of the target buffer will be highlighted.
+matching parts of the target buffer will be highlighted." t nil)
-\(fn)" t nil)
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "re-builder" '("reb-" "re-builder-unload-function")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "re-builder" '("re-builder-unload-function" "reb-")))
;;;***
@@ -27238,9 +26504,11 @@ or call the function `recentf-mode'.")
(autoload 'recentf-mode "recentf" "\
Toggle \"Open Recent\" menu (Recentf mode).
-With a prefix argument ARG, enable Recentf mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-Recentf mode if ARG is omitted or nil.
+
+If called interactively, enable Recentf mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
When Recentf mode is enabled, a \"Open Recent\" submenu is
displayed in the \"File\" menu, containing a list of files that
@@ -27306,9 +26574,7 @@ Copy the region-rectangle and save it as the last killed one.
\(fn START END)" t nil)
(autoload 'yank-rectangle "rect" "\
-Yank the last killed rectangle with upper left corner at point.
-
-\(fn)" t nil)
+Yank the last killed rectangle with upper left corner at point." t nil)
(autoload 'insert-rectangle "rect" "\
Insert text of RECTANGLE with upper left corner at point.
@@ -27390,11 +26656,17 @@ with a prefix argument, prompt for START-AT and FORMAT.
(autoload 'rectangle-mark-mode "rect" "\
Toggle the region as rectangular.
+
+If called interactively, enable Rectangle-Mark mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
Activates the region if needed. Only lasts until the region is deactivated.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rect" '("rectangle-" "clear-rectangle-line" "spaces-string" "string-rectangle-" "delete-" "ope" "killed-rectangle" "extract-rectangle-" "apply-on-rectangle")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rect" '("apply-on-rectangle" "clear-rectangle-line" "delete-" "extract-rectangle-" "killed-rectangle" "ope" "rectangle-" "spaces-string" "string-rectangle-")))
;;;***
@@ -27417,9 +26689,11 @@ Activates the region if needed. Only lasts until the region is deactivated.
(autoload 'refill-mode "refill" "\
Toggle automatic refilling (Refill mode).
-With a prefix argument ARG, enable Refill mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Refill mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Refill mode is a buffer-local minor mode. When enabled, the
current paragraph is refilled as you edit. Self-inserting
@@ -27442,13 +26716,16 @@ For true \"word wrap\" behavior, use `visual-line-mode' instead.
(autoload 'reftex-index-phrases-mode "reftex-index" nil t)
(autoload 'turn-on-reftex "reftex" "\
-Turn on RefTeX mode.
-
-\(fn)" nil nil)
+Turn on RefTeX mode." nil nil)
(autoload 'reftex-mode "reftex" "\
Minor mode with distinct support for \\label, \\ref and \\cite in LaTeX.
+If called interactively, enable Reftex mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
\\<reftex-mode-map>A Table of Contents of the entire (multifile) document with browsing
capabilities is available with `\\[reftex-toc]'.
@@ -27481,9 +26758,7 @@ on the menu bar.
(autoload 'reftex-reset-scanning-information "reftex" "\
Reset the symbols containing information from buffer scanning.
-This enforces rescanning the buffer on next use.
-
-\(fn)" nil nil)
+This enforces rescanning the buffer on next use." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "reftex" '("reftex-")))
@@ -27579,9 +26854,12 @@ This enforces rescanning the buffer on next use.
(autoload 'regexp-opt "regexp-opt" "\
Return a regexp to match a string in the list STRINGS.
-Each string should be unique in STRINGS and should not contain
-any regexps, quoted or not. Optional PAREN specifies how the
-returned regexp is surrounded by grouping constructs.
+Each member of STRINGS is treated as a fixed string, not as a regexp.
+Optional PAREN specifies how the returned regexp is surrounded by
+grouping constructs.
+
+If STRINGS is the empty list, the return value is a regexp that
+never matches anything.
The optional argument PAREN can be any of the following:
@@ -27604,8 +26882,14 @@ nil
necessary to ensure that a postfix operator appended to it will
apply to the whole expression.
-The resulting regexp is equivalent to but usually more efficient
-than that of a simplified version:
+The optional argument KEEP-ORDER, if nil or omitted, allows the
+returned regexp to match the strings in any order. If non-nil,
+the match is guaranteed to be performed in the order given, as if
+the strings were made into a regexp by joining them with the
+`\\|' operator.
+
+Up to reordering, the resulting regexp is equivalent to but
+usually more efficient than that of a simplified version:
(defun simplified-regexp-opt (strings &optional paren)
(let ((parens
@@ -27618,7 +26902,7 @@ than that of a simplified version:
(mapconcat \\='regexp-quote strings \"\\\\|\")
(cdr parens))))
-\(fn STRINGS &optional PAREN)" nil nil)
+\(fn STRINGS &optional PAREN KEEP-ORDER)" nil nil)
(autoload 'regexp-opt-depth "regexp-opt" "\
Return the depth of REGEXP.
@@ -27666,14 +26950,10 @@ Call `remember' in another frame.
(autoload 'remember-clipboard "remember" "\
Remember the contents of the current clipboard.
-Most useful for remembering things from other applications.
-
-\(fn)" t nil)
+Most useful for remembering things from other applications." t nil)
(autoload 'remember-diary-extract-entries "remember" "\
-Extract diary entries from the region.
-
-\(fn)" nil nil)
+Extract diary entries from the region." nil nil)
(autoload 'remember-notes "remember" "\
Return the notes buffer, creating it if needed, and maybe switch to it.
@@ -27793,9 +27073,11 @@ first comment line visible (if point is in a comment).
(autoload 'reveal-mode "reveal" "\
Toggle uncloaking of invisible text near point (Reveal mode).
-With a prefix argument ARG, enable Reveal mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-Reveal mode if ARG is omitted or nil.
+
+If called interactively, enable Reveal mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Reveal mode is a buffer-local minor mode. When enabled, it
reveals invisible text around point.
@@ -27816,9 +27098,10 @@ or call the function `global-reveal-mode'.")
Toggle Reveal mode in all buffers (Global Reveal mode).
Reveal mode renders invisible text around point visible again.
-With a prefix argument ARG, enable Global Reveal mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+If called interactively, enable Global Reveal mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
\(fn &optional ARG)" t nil)
@@ -28120,9 +27403,7 @@ Instead, these commands are available:
\\[rmail-summary-by-recipients] Summarize only messages with particular recipient(s).
\\[rmail-summary-by-regexp] Summarize only messages with particular regexp(s).
\\[rmail-summary-by-topic] Summarize only messages with subject line regexp(s).
-\\[rmail-toggle-header] Toggle display of complete header.
-
-\(fn)" t nil)
+\\[rmail-toggle-header] Toggle display of complete header." t nil)
(autoload 'rmail-input "rmail" "\
Run Rmail on file FILENAME.
@@ -28134,7 +27415,7 @@ Set PASSWORD to be used for retrieving mail from a POP or IMAP server.
\(fn PASSWORD)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rmail" '("rmail-" "mail-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rmail" '("mail-" "rmail-")))
;;;***
@@ -28191,9 +27472,15 @@ buffer, updates it accordingly.
This command always outputs the complete message header, even if
the header display is currently pruned.
+If `rmail-output-reset-deleted-flag' is non-nil, the message's
+deleted flag is reset in the message appended to the destination
+file. Otherwise, the appended message will remain marked as
+deleted if it was deleted before invoking this command.
+
Optional prefix argument COUNT (default 1) says to output that
many consecutive messages, starting with the current one (ignoring
-deleted messages). If `rmail-delete-after-output' is non-nil, deletes
+deleted messages, unless `rmail-output-reset-deleted-flag' is
+non-nil). If `rmail-delete-after-output' is non-nil, deletes
messages after output.
The optional third argument NOATTRIBUTE, if non-nil, says not to
@@ -28339,9 +27626,7 @@ Return a pattern.
(autoload 'rng-nxml-mode-init "rng-nxml" "\
Initialize `nxml-mode' to take advantage of `rng-validate-mode'.
This is typically called from `nxml-mode-hook'.
-Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil.
-
-\(fn)" t nil)
+Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rng-nxml" '("rng-")))
@@ -28499,14 +27784,10 @@ To terminate the ROT13 display, delete that window. As long as that window
is not deleted, any buffer displayed in it will become instantly encoded
in ROT13.
-See also `toggle-rot13-mode'.
-
-\(fn)" t nil)
+See also `toggle-rot13-mode'." t nil)
(autoload 'toggle-rot13-mode "rot13" "\
-Toggle the use of ROT13 encoding for the current window.
-
-\(fn)" t nil)
+Toggle the use of ROT13 encoding for the current window." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rot13" '("rot13-")))
@@ -28530,9 +27811,11 @@ highlighting.
(autoload 'rst-minor-mode "rst" "\
Toggle ReST minor mode.
-With a prefix argument ARG, enable ReST minor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Rst minor mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
When ReST minor mode is enabled, the ReST mode keybindings
are installed on top of the major mode bindings. Use this
@@ -28579,9 +27862,11 @@ Use the command `ruler-mode' to change this variable.")
(autoload 'ruler-mode "ruler-mode" "\
Toggle display of ruler in header line (Ruler mode).
-With a prefix argument ARG, enable Ruler mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
+
+If called interactively, enable Ruler mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
\(fn &optional ARG)" t nil)
@@ -28628,6 +27913,7 @@ CHAR
matches any character in SET .... SET may be a character or string.
Ranges of characters can be specified as `A-Z' in strings.
Ranges may also be specified as conses like `(?A . ?Z)'.
+ Reversed ranges like `Z-A' and `(?Z . ?A)' are not permitted.
SET may also be the name of a character class: `digit',
`control', `hex-digit', `blank', `graph', `print', `alnum',
@@ -28688,7 +27974,7 @@ CHAR
matches 0 through 9.
`control', `cntrl'
- matches ASCII control characters.
+ matches any character whose code is in the range 0-31.
`hex-digit', `hex', `xdigit'
matches 0 through 9, a through f and A through F.
@@ -28775,7 +28061,9 @@ CHAR
matches a character with category CATEGORY. CATEGORY must be
either a character to use for C, or one of the following symbols.
- `consonant' (\\c0 in string notation)
+ `space-for-indent' (\\c\\s in string notation)
+ `base' (\\c.)
+ `consonant' (\\c0)
`base-vowel' (\\c1)
`upper-diacritical-mark' (\\c2)
`lower-diacritical-mark' (\\c3)
@@ -28793,7 +28081,9 @@ CHAR
`japanese-hiragana-two-byte' (\\cH)
`indian-two-byte' (\\cI)
`japanese-katakana-two-byte' (\\cK)
+ `strong-left-to-right' (\\cL)
`korean-hangul-two-byte' (\\cN)
+ `strong-right-to-left' (\\cR)
`cyrillic-two-byte' (\\cY)
`combining-diacritic' (\\c^)
`ascii' (\\ca)
@@ -28965,9 +28255,11 @@ or call the function `savehist-mode'.")
(autoload 'savehist-mode "savehist" "\
Toggle saving of minibuffer history (Savehist mode).
-With a prefix argument ARG, enable Savehist mode if ARG is
-positive, and disable it otherwise. If called from Lisp,
-also enable the mode if ARG is omitted or nil.
+
+If called interactively, enable Savehist mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
When Savehist mode is enabled, minibuffer history is saved
to `savehist-file' periodically and when exiting Emacs. When
@@ -29019,6 +28311,11 @@ Non-nil means automatically save place in each file.
This means when you visit a file, point goes to the last place
where it was when you previously visited the same file.
+If called interactively, enable Save-Place mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
\(fn &optional ARG)" t nil)
(autoload 'save-place-local-mode "saveplace" "\
@@ -29027,8 +28324,10 @@ If this mode is enabled, point is recorded when you kill the buffer
or exit Emacs. Visiting this file again will go to that position,
even in a later Emacs session.
-If called with a prefix arg, the mode is enabled if and only if
-the argument is positive.
+If called interactively, enable Save-Place-Local mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
To save places automatically in all files, put this in your init
file:
@@ -29037,14 +28336,14 @@ file:
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "saveplace" '("save-place" "load-save-place-alist-from-file")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "saveplace" '("load-save-place-alist-from-file" "save-place")))
;;;***
;;;### (autoloads nil "sb-image" "sb-image.el" (0 0 0 0))
;;; Generated autoloads from sb-image.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sb-image" '("speedbar-" "defimage-speedbar")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sb-image" '("defimage-speedbar" "speedbar-")))
;;;***
@@ -29085,7 +28384,7 @@ that variable's value is a string.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "scheme" '("scheme-" "dsssl-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "scheme" '("dsssl-" "scheme-")))
;;;***
@@ -29119,9 +28418,11 @@ or call the function `scroll-all-mode'.")
(autoload 'scroll-all-mode "scroll-all" "\
Toggle shared scrolling in same-frame windows (Scroll-All mode).
-With a prefix argument ARG, enable Scroll-All mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Scroll-All mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
When Scroll-All mode is enabled, scrolling commands invoked in
one window apply to all visible windows in the same frame.
@@ -29135,7 +28436,7 @@ one window apply to all visible windows in the same frame.
;;;### (autoloads nil "scroll-bar" "scroll-bar.el" (0 0 0 0))
;;; Generated autoloads from scroll-bar.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "scroll-bar" '("set-scroll-bar-mode" "scroll-bar-" "toggle-" "horizontal-scroll-bar" "get-scroll-bar-mode" "previous-scroll-bar-mode")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "scroll-bar" '("get-scroll-bar-mode" "horizontal-scroll-bar" "previous-scroll-bar-mode" "scroll-bar-" "set-scroll-bar-mode" "toggle-")))
;;;***
@@ -29144,12 +28445,16 @@ one window apply to all visible windows in the same frame.
(autoload 'scroll-lock-mode "scroll-lock" "\
Buffer-local minor mode for pager-like scrolling.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil. When enabled, keys that normally move
-point by line or paragraph will scroll the buffer by the
-respective amount of lines instead and point will be kept
-vertically fixed relative to window boundaries during scrolling.
+
+If called interactively, enable Scroll-Lock mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
+When enabled, keys that normally move point by line or paragraph
+will scroll the buffer by the respective amount of lines instead
+and point will be kept vertically fixed relative to window
+boundaries during scrolling.
\(fn &optional ARG)" t nil)
@@ -29208,9 +28513,11 @@ or call the function `semantic-mode'.")
(autoload 'semantic-mode "semantic" "\
Toggle parser features (Semantic mode).
-With a prefix argument ARG, enable Semantic mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-Semantic mode if ARG is omitted or nil.
+
+If called interactively, enable Semantic mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
In Semantic mode, Emacs parses the buffers you visit for their
semantic content. This information is used by a variety of
@@ -29222,7 +28529,7 @@ Semantic mode.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic" '("semantic-" "bovinate")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic" '("bovinate" "semantic-")))
;;;***
@@ -29278,7 +28585,7 @@ Semantic mode.
;;;;;; "cedet/semantic/bovine/c.el" (0 0 0 0))
;;; Generated autoloads from cedet/semantic/bovine/c.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine/c" '("semantic" "c++-mode" "c-mode")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine/c" '("c++-mode" "c-mode" "semantic")))
;;;***
@@ -29294,7 +28601,7 @@ Semantic mode.
;;;;;; "cedet/semantic/bovine/el.el" (0 0 0 0))
;;; Generated autoloads from cedet/semantic/bovine/el.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine/el" '("lisp-mode" "emacs-lisp-mode" "semantic-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine/el" '("emacs-lisp-mode" "lisp-mode" "semantic-")))
;;;***
@@ -29323,7 +28630,7 @@ Major mode for editing Bovine grammars.
;;;;;; "cedet/semantic/bovine/make.el" (0 0 0 0))
;;; Generated autoloads from cedet/semantic/bovine/make.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine/make" '("semantic-" "makefile-mode")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine/make" '("makefile-mode" "semantic-")))
;;;***
@@ -29379,7 +28686,7 @@ Major mode for editing Bovine grammars.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/db-ebrowse.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-ebrowse" '("semanticdb-" "c++-mode")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-ebrowse" '("c++-mode" "semanticdb-")))
;;;***
@@ -29387,7 +28694,7 @@ Major mode for editing Bovine grammars.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/db-el.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-el" '("semanticdb-" "emacs-lisp-mode")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-el" '("emacs-lisp-mode" "semanticdb-")))
;;;***
@@ -29419,7 +28726,7 @@ Major mode for editing Bovine grammars.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/db-javascript.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-javascript" '("semanticdb-" "javascript-mode")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-javascript" '("javascript-mode" "semanticdb-")))
;;;***
@@ -29475,7 +28782,7 @@ Major mode for editing Bovine grammars.
;;;;;; "cedet/semantic/decorate/mode.el" (0 0 0 0))
;;; Generated autoloads from cedet/semantic/decorate/mode.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/decorate/mode" '("semantic-" "define-semantic-decoration-style")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/decorate/mode" '("define-semantic-decoration-style" "semantic-")))
;;;***
@@ -29483,7 +28790,7 @@ Major mode for editing Bovine grammars.
;;;;;; "cedet/semantic/dep.el" (0 0 0 0))
;;; Generated autoloads from cedet/semantic/dep.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/dep" '("semantic-" "defcustom-mode-local-semantic-dependency-system-include-path")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/dep" '("defcustom-mode-local-semantic-dependency-system-include-path" "semantic-")))
;;;***
@@ -29579,7 +28886,7 @@ Major mode for editing Bovine grammars.
;;;;;; "cedet/semantic/idle.el" (0 0 0 0))
;;; Generated autoloads from cedet/semantic/idle.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/idle" '("semantic-" "global-semantic-idle-summary-mode" "define-semantic-idle-service")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/idle" '("define-semantic-idle-service" "global-semantic-idle-summary-mode" "semantic-")))
;;;***
@@ -29603,7 +28910,7 @@ Major mode for editing Bovine grammars.
;;;;;; "cedet/semantic/lex.el" (0 0 0 0))
;;; Generated autoloads from cedet/semantic/lex.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/lex" '("semantic-" "define-lex")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/lex" '("define-lex" "semantic-")))
;;;***
@@ -29611,7 +28918,7 @@ Major mode for editing Bovine grammars.
;;;;;; "cedet/semantic/lex-spp.el" (0 0 0 0))
;;; Generated autoloads from cedet/semantic/lex-spp.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/lex-spp" '("semantic-lex-" "define-lex-spp-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/lex-spp" '("define-lex-spp-" "semantic-lex-")))
;;;***
@@ -29619,7 +28926,7 @@ Major mode for editing Bovine grammars.
;;;;;; "cedet/semantic/mru-bookmark.el" (0 0 0 0))
;;; Generated autoloads from cedet/semantic/mru-bookmark.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/mru-bookmark" '("semantic-" "global-semantic-mru-bookmark-mode")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/mru-bookmark" '("global-semantic-mru-bookmark-mode" "semantic-")))
;;;***
@@ -29771,7 +29078,7 @@ Major mode for editing Bovine grammars.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/wisent.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/wisent" '("wisent-" "define-wisent-lexer")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/wisent" '("define-wisent-lexer" "wisent-")))
;;;***
@@ -29816,7 +29123,7 @@ Major mode for editing Wisent grammars.
;;;;;; "cedet/semantic/wisent/python.el" (0 0 0 0))
;;; Generated autoloads from cedet/semantic/wisent/python.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/wisent/python" '("wisent-python-" "semantic-" "python-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/wisent/python" '("python-" "semantic-" "wisent-python-")))
;;;***
@@ -29824,14 +29131,14 @@ Major mode for editing Wisent grammars.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/wisent/wisent.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/wisent/wisent" '("wisent-" "$region" "$nterm" "$action")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/wisent/wisent" '("$action" "$nterm" "$region" "wisent-")))
;;;***
;;;### (autoloads nil "sendmail" "mail/sendmail.el" (0 0 0 0))
;;; Generated autoloads from mail/sendmail.el
-(defvar mail-from-style 'default "\
+(defvar mail-from-style 'angles "\
Specifies how \"From:\" fields look.
If nil, they contain just the return address like:
@@ -29859,9 +29166,9 @@ variable `feedmail-deduce-envelope-from'.")
(custom-autoload 'mail-specify-envelope-from "sendmail" t)
(defvar mail-self-blind nil "\
-Non-nil means insert BCC to self in messages to be sent.
+Non-nil means insert Bcc to self in messages to be sent.
This is done when the message is initialized,
-so you can remove or alter the BCC field to override the default.")
+so you can remove or alter the Bcc field to override the default.")
(custom-autoload 'mail-self-blind "sendmail" t)
@@ -29894,7 +29201,7 @@ be a Babyl file.")
(custom-autoload 'mail-archive-file-name "sendmail" t)
(defvar mail-default-reply-to nil "\
-Address to insert as default Reply-to field of outgoing messages.
+Address to insert as default Reply-To field of outgoing messages.
If nil, it will be initialized from the REPLYTO environment variable
when you first send mail.")
@@ -29946,7 +29253,7 @@ instead of no action.")
(custom-autoload 'mail-citation-hook "sendmail" t)
-(defvar mail-citation-prefix-regexp (purecopy "\\([ ]*\\(\\w\\|[_.]\\)+>+\\|[ ]*[]>|]\\)+") "\
+(defvar mail-citation-prefix-regexp (purecopy "\\([ \11]*\\(\\w\\|[_.]\\)+>+\\|[ \11]*[]>|]\\)+") "\
Regular expression to match a citation prefix plus whitespace.
It should match whatever sort of citation prefixes you want to handle,
with whitespace before and after; it should also match just whitespace.
@@ -29988,9 +29295,7 @@ before you edit the message, so you can edit or delete the lines.")
(autoload 'sendmail-query-once "sendmail" "\
Query for `send-mail-function' and send mail with it.
-This also saves the value of `send-mail-function' via Customize.
-
-\(fn)" nil nil)
+This also saves the value of `send-mail-function' via Customize." nil nil)
(define-mail-user-agent 'sendmail-user-agent 'sendmail-user-agent-compose 'mail-send-and-exit)
@@ -30008,8 +29313,8 @@ Like Text Mode but with these additional commands:
Here are commands that move to a header field (and create it if there isn't):
\\[mail-to] move to To: \\[mail-subject] move to Subj:
- \\[mail-bcc] move to BCC: \\[mail-cc] move to CC:
- \\[mail-fcc] move to FCC: \\[mail-reply-to] move to Reply-To:
+ \\[mail-bcc] move to Bcc: \\[mail-cc] move to Cc:
+ \\[mail-fcc] move to Fcc: \\[mail-reply-to] move to Reply-To:
\\[mail-mail-reply-to] move to Mail-Reply-To:
\\[mail-mail-followup-to] move to Mail-Followup-To:
\\[mail-text] move to message text.
@@ -30062,13 +29367,13 @@ Various special commands starting with C-c are available in sendmail mode
to move to message header fields:
\\{mail-mode-map}
-If `mail-self-blind' is non-nil, a BCC to yourself is inserted
+If `mail-self-blind' is non-nil, a Bcc to yourself is inserted
when the message is initialized.
If `mail-default-reply-to' is non-nil, it should be an address (a string);
-a Reply-to: field with that address is inserted.
+a Reply-To: field with that address is inserted.
-If `mail-archive-file-name' is non-nil, an FCC field with that file name
+If `mail-archive-file-name' is non-nil, an Fcc field with that file name
is inserted.
The normal hook `mail-setup-hook' is run after the message is
@@ -30113,7 +29418,7 @@ Like `mail' command, but display mail buffer in another frame.
;;;### (autoloads nil "seq" "emacs-lisp/seq.el" (0 0 0 0))
;;; Generated autoloads from emacs-lisp/seq.el
-(push (purecopy '(seq 2 20)) package--builtin-versions)
+(push (purecopy '(seq 2 21)) package--builtin-versions)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "seq" '("seq-")))
@@ -30128,20 +29433,6 @@ Like `mail' command, but display mail buffer in another frame.
(put 'server-auth-dir 'risky-local-variable t)
-(defvar server-name "server" "\
-The name of the Emacs server, if this Emacs process creates one.
-The command `server-start' makes use of this. It should not be
-changed while a server is running.
-If this is a file name with no leading directories, Emacs will
-create a socket file by that name under `server-socket-dir'
-if `server-use-tcp' is nil, else under `server-auth-dir'.
-If this is an absolute file name, it specifies where the socket
-file will be created. To have emacsclient connect to the same
-socket, use the \"-s\" switch for local non-TCP sockets, and
-the \"-f\" switch otherwise.")
-
-(custom-autoload 'server-name "server" t)
-
(autoload 'server-start "server" "\
Allow this Emacs process to be a server for client processes.
This starts a server communications subprocess through which client
@@ -30183,9 +29474,11 @@ or call the function `server-mode'.")
(autoload 'server-mode "server" "\
Toggle Server mode.
-With a prefix argument ARG, enable Server mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-Server mode if ARG is omitted or nil.
+
+If called interactively, enable Server mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Server mode runs a process that accepts commands from the
`emacsclient' program. See Info node `Emacs server' and
@@ -30244,11 +29537,9 @@ part):
\\{ses-mode-print-map}
These are active only in the minibuffer, when entering or editing a
formula:
-\\{ses-mode-edit-map}
+\\{ses-mode-edit-map}" t nil)
-\(fn)" t nil)
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ses" '("ses" "noreturn" "1value")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ses" '("1value" "noreturn" "ses")))
;;;***
@@ -30456,9 +29747,7 @@ sites in the cluster.
Declare a single file to be shared between sites.
It may have different filenames on each site. When this file is edited, the
new version will be copied to each of the other locations. Sites can be
-specific hostnames, or names of clusters (see `shadow-define-cluster').
-
-\(fn)" t nil)
+specific hostnames, or names of clusters (see `shadow-define-cluster')." t nil)
(autoload 'shadow-define-regexp-group "shadowfile" "\
Make each of a group of files be shared between hosts.
@@ -30466,14 +29755,10 @@ Prompts for regular expression; files matching this are shared between a list
of sites, which are also prompted for. The filenames must be identical on all
hosts (if they aren't, use `shadow-define-literal-group' instead of this
function). Each site can be either a hostname or the name of a cluster (see
-`shadow-define-cluster').
-
-\(fn)" t nil)
+`shadow-define-cluster')." t nil)
(autoload 'shadow-initialize "shadowfile" "\
-Set up file shadowing.
-
-\(fn)" t nil)
+Set up file shadowing." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "shadowfile" '("shadow")))
@@ -30525,7 +29810,7 @@ Otherwise, one argument `-i' is passed to the shell.
\(fn &optional BUFFER)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "shell" '("shell-" "dirs" "explicit-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "shell" '("dirs" "explicit-" "shell-")))
;;;***
@@ -30808,18 +30093,19 @@ buffer names.
(autoload 'smerge-mode "smerge-mode" "\
Minor mode to simplify editing output from the diff3 program.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
+
+If called interactively, enable Smerge mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
\\{smerge-mode-map}
\(fn &optional ARG)" t nil)
(autoload 'smerge-start-session "smerge-mode" "\
Turn on `smerge-mode' and move point to first conflict marker.
-If no conflict maker is found, turn off `smerge-mode'.
-
-\(fn)" t nil)
+If no conflict maker is found, turn off `smerge-mode'." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "smerge-mode" '("smerge-")))
@@ -30847,7 +30133,7 @@ interactively. If there's no argument, do it at the current buffer.
\(fn &optional BUFFER)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "smiley" '("smiley-" "gnus-smiley-file-types")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "smiley" '("gnus-smiley-file-types" "smiley-")))
;;;***
@@ -30861,15 +30147,10 @@ interactively. If there's no argument, do it at the current buffer.
;;;### (autoloads nil "smtpmail" "mail/smtpmail.el" (0 0 0 0))
;;; Generated autoloads from mail/smtpmail.el
-(autoload 'smtpmail-send-it "smtpmail" "\
-
-
-\(fn)" nil nil)
+(autoload 'smtpmail-send-it "smtpmail" nil nil nil)
(autoload 'smtpmail-send-queued-mail "smtpmail" "\
-Send mail that was queued as a result of setting `smtpmail-queue-mail'.
-
-\(fn)" t nil)
+Send mail that was queued as a result of setting `smtpmail-queue-mail'." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "smtpmail" '("smtpmail-")))
@@ -30892,9 +30173,7 @@ Snake mode keybindings:
\\[snake-move-left] Makes the snake move left
\\[snake-move-right] Makes the snake move right
\\[snake-move-up] Makes the snake move up
-\\[snake-move-down] Makes the snake move down
-
-\(fn)" t nil)
+\\[snake-move-down] Makes the snake move down" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "snake" '("snake-")))
@@ -30911,9 +30190,7 @@ Comments start with -- and end with newline or another --.
Delete converts tabs to spaces as it moves back.
\\{snmp-mode-map}
Turning on snmp-mode runs the hooks in `snmp-common-mode-hook', then
-`snmp-mode-hook'.
-
-\(fn)" t nil)
+`snmp-mode-hook'." t nil)
(autoload 'snmpv2-mode "snmp-mode" "\
Major mode for editing SNMPv2 MIBs.
@@ -30923,9 +30200,7 @@ Comments start with -- and end with newline or another --.
Delete converts tabs to spaces as it moves back.
\\{snmp-mode-map}
Turning on snmp-mode runs the hooks in `snmp-common-mode-hook',
-then `snmpv2-mode-hook'.
-
-\(fn)" t nil)
+then `snmpv2-mode-hook'." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "snmp-mode" '("snmp")))
@@ -30933,7 +30208,7 @@ then `snmpv2-mode-hook'.
;;;### (autoloads nil "soap-client" "net/soap-client.el" (0 0 0 0))
;;; Generated autoloads from net/soap-client.el
-(push (purecopy '(soap-client 3 1 4)) package--builtin-versions)
+(push (purecopy '(soap-client 3 1 5)) package--builtin-versions)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "soap-client" '("soap-")))
@@ -30967,7 +30242,7 @@ This function is suitable for execution in an init file.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "solar" '("solar-" "diary-sunrise-sunset" "calendar-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "solar" '("calendar-" "diary-sunrise-sunset" "solar-")))
;;;***
@@ -31278,16 +30553,12 @@ Customize `spam-report-url-ping-function' to use this function.
Add spam-report support to the Agent.
Spam reports will be queued with \\[spam-report-url-to-file] when
the Agent is unplugged, and will be submitted in a batch when the
-Agent is plugged.
-
-\(fn)" t nil)
+Agent is plugged." t nil)
(autoload 'spam-report-deagentize "spam-report" "\
Remove spam-report support from the Agent.
Spam reports will be queued with the method used when
-\\[spam-report-agentize] was run.
-
-\(fn)" t nil)
+\\[spam-report-agentize] was run." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "spam-report" '("spam-report-")))
@@ -31325,9 +30596,7 @@ supported at a time.
(autoload 'speedbar-get-focus "speedbar" "\
Change frame focus to or from the speedbar frame.
If the selected frame is not speedbar, then speedbar frame is
-selected. If the speedbar frame is active, then select the attached frame.
-
-\(fn)" t nil)
+selected. If the speedbar frame is active, then select the attached frame." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "speedbar" '("speedbar-")))
@@ -31337,14 +30606,10 @@ selected. If the speedbar frame is active, then select the attached frame.
;;; Generated autoloads from play/spook.el
(autoload 'spook "spook" "\
-Adds that special touch of class to your outgoing mail.
-
-\(fn)" t nil)
+Adds that special touch of class to your outgoing mail." t nil)
(autoload 'snarf-spooks "spook" "\
-Return a vector containing the lines from `spook-phrases-file'.
-
-\(fn)" nil nil)
+Return a vector containing the lines from `spook-phrases-file'." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "spook" '("spook-phrase")))
@@ -31588,6 +30853,39 @@ The default comes from `process-coding-system-alist' and
\(fn &optional BUFFER)" t nil)
+(autoload 'sql-mariadb "sql" "\
+Run mysql by MariaDB as an inferior process.
+
+MariaDB is free software.
+
+If buffer `*SQL*' exists but no process is running, make a new process.
+If buffer exists and a process is running, just switch to buffer
+`*SQL*'.
+
+Interpreter used comes from variable `sql-mariadb-program'. Login uses
+the variables `sql-user', `sql-password', `sql-database', and
+`sql-server' as defaults, if set. Additional command line parameters
+can be stored in the list `sql-mariadb-options'.
+
+The buffer is put in SQL interactive mode, giving commands for sending
+input. See `sql-interactive-mode'.
+
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-mariadb]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
+To specify a coding system for converting non-ASCII characters
+in the input and output to the process, use \\[universal-coding-system-argument]
+before \\[sql-mariadb]. You can also specify this with \\[set-buffer-process-coding-system]
+in the SQL buffer, after you start the process.
+The default comes from `process-coding-system-alist' and
+`default-process-coding-system'.
+
+\(Type \\[describe-mode] in the SQL buffer for a list of commands.)
+
+\(fn &optional BUFFER)" t nil)
+
(autoload 'sql-solid "sql" "\
Run solsql by Solid as an inferior process.
@@ -31707,8 +31005,7 @@ The default comes from `process-coding-system-alist' and
your might try undecided-dos as a coding system. If this doesn't help,
Try to set `comint-output-filter-functions' like this:
-\(setq comint-output-filter-functions (append comint-output-filter-functions
- \\='(comint-strip-ctrl-m)))
+\(add-hook 'comint-output-filter-functions #\\='comint-strip-ctrl-m 'append)
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)
@@ -31989,7 +31286,7 @@ Major-mode for writing SRecode macros.
;;;;;; 0 0 0))
;;; Generated autoloads from cedet/srecode/table.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/table" '("srecode-" "object-sort-list")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/table" '("object-sort-list" "srecode-")))
;;;***
@@ -32009,31 +31306,6 @@ Major-mode for writing SRecode macros.
;;;***
-;;;### (autoloads nil "starttls" "net/starttls.el" (0 0 0 0))
-;;; Generated autoloads from net/starttls.el
-
-(autoload 'starttls-open-stream "starttls" "\
-Open a TLS connection for a port to a host.
-Returns a subprocess object to represent the connection.
-Input and output work as for subprocesses; `delete-process' closes it.
-Args are NAME BUFFER HOST PORT.
-NAME is name for process. It is modified if necessary to make it unique.
-BUFFER is the buffer (or `buffer-name') to associate with the process.
- Process output goes at end of that buffer, unless you specify
- a filter function to handle the output.
- BUFFER may be also nil, meaning that this process is not associated
- with any buffer
-Third arg is name of the host to connect to, or its IP address.
-Fourth arg PORT is an integer specifying a port to connect to.
-If `starttls-use-gnutls' is nil, this may also be a service name, but
-GnuTLS requires a port number.
-
-\(fn NAME BUFFER HOST PORT)" nil nil)
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "starttls" '("starttls-")))
-
-;;;***
-
;;;### (autoloads nil "strokes" "strokes.el" (0 0 0 0))
;;; Generated autoloads from strokes.el
@@ -32086,14 +31358,10 @@ Displays the command which STROKE maps to, reading STROKE interactively.
\(fn STROKE)" t nil)
(autoload 'strokes-help "strokes" "\
-Get instruction on using the Strokes package.
-
-\(fn)" t nil)
+Get instruction on using the Strokes package." t nil)
(autoload 'strokes-load-user-strokes "strokes" "\
-Load user-defined strokes from file named by `strokes-file'.
-
-\(fn)" t nil)
+Load user-defined strokes from file named by `strokes-file'." t nil)
(autoload 'strokes-list-strokes "strokes" "\
Pop up a buffer containing an alphabetical listing of strokes in STROKES-MAP.
@@ -32115,9 +31383,11 @@ or call the function `strokes-mode'.")
(autoload 'strokes-mode "strokes" "\
Toggle Strokes mode, a global minor mode.
-With a prefix argument ARG, enable Strokes mode if ARG is
-positive, and disable it otherwise. If called from Lisp,
-enable the mode if ARG is omitted or nil.
+
+If called interactively, enable Strokes mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
\\<strokes-mode-map>
Strokes are pictographic mouse gestures which invoke commands.
@@ -32142,9 +31412,7 @@ Optional FORCE non-nil will ignore the buffer's read-only status.
\(fn &optional BUFFER FORCE)" t nil)
(autoload 'strokes-compose-complex-stroke "strokes" "\
-Read a complex stroke and insert its glyph into the current buffer.
-
-\(fn)" t nil)
+Read a complex stroke and insert its glyph into the current buffer." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "strokes" '("strokes-")))
@@ -32164,16 +31432,14 @@ Studlify-case the current word, or COUNT words if given an argument.
\(fn COUNT)" t nil)
(autoload 'studlify-buffer "studly" "\
-Studlify-case the current buffer.
-
-\(fn)" t nil)
+Studlify-case the current buffer." t nil)
;;;***
;;;### (autoloads nil "subr-x" "emacs-lisp/subr-x.el" (0 0 0 0))
;;; Generated autoloads from emacs-lisp/subr-x.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "subr-x" '("string-" "hash-table-" "when-let" "internal--" "if-let" "and-let*" "thread-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "subr-x" '("and-let*" "hash-table-" "if-let" "internal--" "replace-region-contents" "string-" "thread-" "when-let")))
;;;***
@@ -32184,9 +31450,11 @@ Studlify-case the current buffer.
(autoload 'subword-mode "subword" "\
Toggle subword movement and editing (Subword mode).
-With a prefix argument ARG, enable Subword mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Subword mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Subword mode is a buffer-local minor mode. Enabling it changes
the definition of a word so that word-based commands stop inside
@@ -32232,9 +31500,11 @@ See `subword-mode' for more information on Subword mode.
(autoload 'superword-mode "subword" "\
Toggle superword movement and editing (Superword mode).
-With a prefix argument ARG, enable Superword mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Superword mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Superword mode is a buffer-local minor mode. Enabling it changes
the definition of words such that symbols characters are treated
@@ -32267,7 +31537,7 @@ See `superword-mode' for more information on Superword mode.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "subword" '("superword-mode-map" "subword-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "subword" '("subword-" "superword-mode-map")))
;;;***
@@ -32297,9 +31567,7 @@ original message but it does require a few things:
The region need not be active (and typically isn't when this
function is called). Also, the hook `sc-pre-hook' is run before,
-and `sc-post-hook' is run after the guts of this function.
-
-\(fn)" nil nil)
+and `sc-post-hook' is run after the guts of this function." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "supercite" '("sc-")))
@@ -32329,9 +31597,11 @@ or call the function `gpm-mouse-mode'.")
(autoload 'gpm-mouse-mode "t-mouse" "\
Toggle mouse support in GNU/Linux consoles (GPM Mouse mode).
-With a prefix argument ARG, enable GPM Mouse mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Gpm-Mouse mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
This allows the use of the mouse when operating on a GNU/Linux console,
in the same way as you can use the mouse under X11.
@@ -32537,10 +31807,7 @@ all the table specific features.
\(fn &optional ARG)" t nil)
-(autoload 'table-unrecognize "table" "\
-
-
-\(fn)" t nil)
+(autoload 'table-unrecognize "table" nil t nil)
(autoload 'table-recognize-region "table" "\
Recognize all tables within region.
@@ -32564,10 +31831,7 @@ the table specific features.
\(fn &optional ARG)" t nil)
-(autoload 'table-unrecognize-table "table" "\
-
-
-\(fn)" t nil)
+(autoload 'table-unrecognize-table "table" nil t nil)
(autoload 'table-recognize-cell "table" "\
Recognize a table cell that contains current point.
@@ -32579,10 +31843,7 @@ plain text and loses all the table specific features.
\(fn &optional FORCE NO-COPY ARG)" t nil)
-(autoload 'table-unrecognize-cell "table" "\
-
-
-\(fn)" t nil)
+(autoload 'table-unrecognize-cell "table" nil t nil)
(autoload 'table-heighten-cell "table" "\
Heighten the current cell by N lines by expanding the cell vertically.
@@ -32673,15 +31934,11 @@ DIRECTION is one of symbols; right, left, above or below.
(autoload 'table-split-cell-vertically "table" "\
Split current cell vertically.
-Creates a cell above and a cell below the current point location.
-
-\(fn)" t nil)
+Creates a cell above and a cell below the current point location." t nil)
(autoload 'table-split-cell-horizontally "table" "\
Split current cell horizontally.
-Creates a cell on the left and a cell on the right of the current point location.
-
-\(fn)" t nil)
+Creates a cell on the left and a cell on the right of the current point location." t nil)
(autoload 'table-split-cell "table" "\
Split current cell in ORIENTATION.
@@ -32729,6 +31986,11 @@ location is indicated by `table-word-continuation-char'. This
variable's value can be toggled by \\[table-fixed-width-mode] at
run-time.
+If called interactively, enable Table-Fixed-Width mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
\(fn &optional ARG)" t nil)
(autoload 'table-query-dimension "table" "\
@@ -32943,11 +32205,9 @@ companion command to `table-capture' this way.
Convert a table into plain text by removing the frame from a table.
Remove the frame from a table and deactivate the table. This command
converts a table into plain text without frames. It is a companion to
-`table-capture' which does the opposite process.
-
-\(fn)" t nil)
+`table-capture' which does the opposite process." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "table" '("table-" "*table--")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "table" '("*table--" "table-")))
;;;***
@@ -32967,9 +32227,7 @@ Connect to display DISPLAY for the Emacs talk group.
\(fn DISPLAY)" t nil)
(autoload 'talk "talk" "\
-Connect to the Emacs talk group from the current X display or tty frame.
-
-\(fn)" t nil)
+Connect to the Emacs talk group from the current X display or tty frame." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "talk" '("talk-")))
@@ -33046,7 +32304,7 @@ Prefix argument means invert sense of `tcl-use-smart-word-finder'.
\(fn COMMAND &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tcl" '("tcl-" "calculate-tcl-indent" "inferior-tcl-" "indent-tcl-exp" "add-log-tcl-defun" "run-tcl" "switch-to-tcl")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tcl" '("add-log-tcl-defun" "calculate-tcl-indent" "indent-tcl-exp" "inferior-tcl-" "run-tcl" "switch-to-tcl" "tcl-")))
;;;***
@@ -33089,7 +32347,7 @@ Normally input is edited in Emacs and sent a line at a time.
\(fn HOST)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "telnet" '("telnet-" "send-process-next-char")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "telnet" '("send-process-next-char" "telnet-")))
;;;***
@@ -33142,7 +32400,7 @@ use in that buffer.
\(fn PORT SPEED)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "term" '("serial-" "term-" "ansi-term-color-vector" "explicit-shell-file-name")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "term" '("ansi-term-color-vector" "explicit-shell-file-name" "serial-" "term-")))
;;;***
@@ -33151,17 +32409,13 @@ use in that buffer.
;;; Generated autoloads from emacs-lisp/testcover.el
(autoload 'testcover-start "testcover" "\
-Uses edebug to instrument all macros and functions in FILENAME, then
-changes the instrumentation from edebug to testcover--much faster, no
-problems with type-ahead or post-command-hook, etc. If BYTE-COMPILE is
-non-nil, byte-compiles each function after instrumenting.
+Use Edebug to instrument for coverage all macros and functions in FILENAME.
+If BYTE-COMPILE is non-nil, byte compile each function after instrumenting.
\(fn FILENAME &optional BYTE-COMPILE)" t nil)
(autoload 'testcover-this-defun "testcover" "\
-Start coverage on function under point.
-
-\(fn)" t nil)
+Start coverage on function under point." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "testcover" '("testcover-")))
@@ -33188,7 +32442,7 @@ tetris-mode keybindings:
\\[tetris-rotate-next] Rotates the shape anticlockwise
\\[tetris-move-bottom] Drops the shape to the bottom of the playing area
-\(fn)" t nil)
+" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tetris" '("tetris-")))
@@ -33343,9 +32597,7 @@ Tries to determine (by looking at the beginning of the file) whether
this file is for plain TeX, LaTeX, or SliTeX and calls `plain-tex-mode',
`latex-mode', or `slitex-mode', respectively. If it cannot be determined,
such as if there are no commands in the file, the value of `tex-default-mode'
-says which mode to use.
-
-\(fn)" t nil)
+says which mode to use." t nil)
(defalias 'TeX-mode 'tex-mode)
@@ -33483,17 +32735,14 @@ Entering SliTeX mode runs the hook `text-mode-hook', then the hook
\(fn)" t nil)
-(autoload 'tex-start-shell "tex-mode" "\
-
-
-\(fn)" nil nil)
+(autoload 'tex-start-shell "tex-mode" nil nil nil)
(autoload 'doctex-mode "tex-mode" "\
Major mode to edit DocTeX files.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tex-mode" '("tex-" "doctex-font-lock-" "latex-" "plain-tex-mode-map")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tex-mode" '("doctex-font-lock-" "latex-" "plain-tex-mode-map" "tex-")))
;;;***
@@ -33632,6 +32881,14 @@ value of `texinfo-mode-hook'.
;;;***
+;;;### (autoloads nil "text-property-search" "emacs-lisp/text-property-search.el"
+;;;;;; (0 0 0 0))
+;;; Generated autoloads from emacs-lisp/text-property-search.el
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "text-property-search" '("text-property-")))
+
+;;;***
+
;;;### (autoloads nil "thai-util" "language/thai-util.el" (0 0 0
;;;;;; 0))
;;; Generated autoloads from language/thai-util.el
@@ -33649,9 +32906,7 @@ Compose Thai characters in STRING and return the resulting string.
\(fn STRING)" nil nil)
(autoload 'thai-compose-buffer "thai-util" "\
-Compose Thai characters in the current buffer.
-
-\(fn)" t nil)
+Compose Thai characters in the current buffer." t nil)
(autoload 'thai-composition-function "thai-util" "\
@@ -33677,7 +32932,7 @@ Compose Thai characters in the current buffer.
Move forward to the end of the Nth next THING.
THING should be a symbol specifying a type of syntactic entity.
Possibilities include `symbol', `list', `sexp', `defun',
-`filename', `url', `email', `word', `sentence', `whitespace',
+`filename', `url', `email', `uuid', `word', `sentence', `whitespace',
`line', and `page'.
\(fn THING &optional N)" nil nil)
@@ -33686,7 +32941,7 @@ Possibilities include `symbol', `list', `sexp', `defun',
Determine the start and end buffer locations for the THING at point.
THING should be a symbol specifying a type of syntactic entity.
Possibilities include `symbol', `list', `sexp', `defun',
-`filename', `url', `email', `word', `sentence', `whitespace',
+`filename', `url', `email', `uuid', `word', `sentence', `whitespace',
`line', and `page'.
See the file `thingatpt.el' for documentation on how to define a
@@ -33701,7 +32956,7 @@ positions of the thing found.
Return the THING at point.
THING should be a symbol specifying a type of syntactic entity.
Possibilities include `symbol', `list', `sexp', `defun',
-`filename', `url', `email', `word', `sentence', `whitespace',
+`filename', `url', `email', `uuid', `word', `sentence', `whitespace',
`line', `number', and `page'.
When the optional argument NO-PROPERTIES is non-nil,
@@ -33713,19 +32968,13 @@ a symbol as a valid THING.
\(fn THING &optional NO-PROPERTIES)" nil nil)
(autoload 'sexp-at-point "thingatpt" "\
-Return the sexp at point, or nil if none is found.
-
-\(fn)" nil nil)
+Return the sexp at point, or nil if none is found." nil nil)
(autoload 'symbol-at-point "thingatpt" "\
-Return the symbol at point, or nil if none is found.
-
-\(fn)" nil nil)
+Return the symbol at point, or nil if none is found." nil nil)
(autoload 'number-at-point "thingatpt" "\
-Return the number at point, or nil if none is found.
-
-\(fn)" nil nil)
+Return the number at point, or nil if none is found." nil nil)
(autoload 'list-at-point "thingatpt" "\
Return the Lisp list at point, or nil if none is found.
@@ -33734,7 +32983,25 @@ treated as white space.
\(fn &optional IGNORE-COMMENT-OR-STRING)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "thingatpt" '("form-at-point" "thing-at-point-" "sentence-at-point" "word-at-point" "in-string-p" "end-of-thing" "beginning-of-thing")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "thingatpt" '("beginning-of-thing" "define-thing-chars" "end-of-thing" "filename" "form-at-point" "in-string-p" "sentence-at-point" "thing-at-point-" "word-at-point")))
+
+;;;***
+
+;;;### (autoloads nil "thread" "thread.el" (0 0 0 0))
+;;; Generated autoloads from thread.el
+
+(autoload 'thread-handle-event "thread" "\
+Handle thread events, propagated by `thread-signal'.
+An EVENT has the format
+ (thread-event THREAD ERROR-SYMBOL DATA)
+
+\(fn EVENT)" t nil)
+
+(autoload 'list-threads "thread" "\
+Display a list of threads." t nil)
+ (put 'list-threads 'disabled "Beware: manually canceling threads can ruin your Emacs session.")
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "thread" '("thread-list-")))
;;;***
@@ -33754,21 +33021,15 @@ and SAME-WINDOW to show thumbs in the same window.
\(fn DIR &optional REG SAME-WINDOW)" t nil)
(autoload 'thumbs-dired-show-marked "thumbs" "\
-In dired, make a thumbs buffer with marked files.
-
-\(fn)" t nil)
+In dired, make a thumbs buffer with marked files." t nil)
(autoload 'thumbs-dired-show "thumbs" "\
-In dired, make a thumbs buffer with all files in current directory.
-
-\(fn)" t nil)
+In dired, make a thumbs buffer with all files in current directory." t nil)
(defalias 'thumbs 'thumbs-show-from-dir)
(autoload 'thumbs-dired-setroot "thumbs" "\
-In dired, call the setroot program on the image at point.
-
-\(fn)" t nil)
+In dired, call the setroot program on the image at point." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "thumbs" '("thumbs-")))
@@ -33829,15 +33090,11 @@ are decomposed into normal Tibetan character sequences.
(autoload 'tibetan-decompose-buffer "tibet-util" "\
Decomposes Tibetan characters in the buffer into their components.
-See also the documentation of the function `tibetan-decompose-region'.
-
-\(fn)" t nil)
+See also the documentation of the function `tibetan-decompose-region'." t nil)
(autoload 'tibetan-compose-buffer "tibet-util" "\
Composes Tibetan character components in the buffer.
-See also docstring of the function tibetan-compose-region.
-
-\(fn)" t nil)
+See also docstring of the function tibetan-compose-region." t nil)
(autoload 'tibetan-post-read-conversion "tibet-util" "\
@@ -33904,13 +33161,16 @@ Otherwise, if
`tildify-space-string' variable,
remove the hard space and leave only the space character.
-This function is meant to be used as a `post-self-insert-hook'.
-
-\(fn)" t nil)
+This function is meant to be used as a `post-self-insert-hook'." t nil)
(autoload 'tildify-mode "tildify" "\
Adds electric behavior to space character.
+If called interactively, enable Tildify mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
When space is inserted into a buffer in a position where hard space is required
instead (determined by `tildify-space-pattern' and `tildify-space-predicates'),
that space character is replaced by a hard space specified by
@@ -33940,9 +33200,7 @@ Enable display of time, load level, and mail flag in mode lines.
This display updates automatically every minute.
If `display-time-day-and-date' is non-nil, the current day and date
are displayed as well.
-This runs the normal hook `display-time-hook' after each update.
-
-\(fn)" t nil)
+This runs the normal hook `display-time-hook' after each update." t nil)
(defvar display-time-mode nil "\
Non-nil if Display-Time mode is enabled.
@@ -33956,9 +33214,11 @@ or call the function `display-time-mode'.")
(autoload 'display-time-mode "time" "\
Toggle display of time, load level, and mail flag in mode lines.
-With a prefix argument ARG, enable Display Time mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-it if ARG is omitted or nil.
+
+If called interactively, enable Display-Time mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
When Display Time mode is enabled, it updates every minute (you
can control the number of seconds between updates by customizing
@@ -33971,9 +33231,7 @@ runs the normal hook `display-time-hook' after each update.
(autoload 'display-time-world "time" "\
Enable updating display of times in various time zones.
`display-time-world-list' specifies the zones.
-To turn off the world time display, go to that window and type `q'.
-
-\(fn)" t nil)
+To turn off the world time display, go to that window and type `q'." t nil)
(autoload 'emacs-uptime "time" "\
Return a string giving the uptime of this instance of Emacs.
@@ -33983,11 +33241,9 @@ For example, the Unix uptime command format is \"%D, %z%2h:%.2m\".
\(fn &optional FORMAT)" t nil)
(autoload 'emacs-init-time "time" "\
-Return a string giving the duration of the Emacs initialization.
-
-\(fn)" t nil)
+Return a string giving the duration of the Emacs initialization." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "time" '("display-time-" "time--display-world-list" "legacy-style-world-list" "zoneinfo-style-world-list")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "time" '("display-time-" "legacy-style-world-list" "time--display-world-list" "zoneinfo-style-world-list")))
;;;***
@@ -34004,10 +33260,7 @@ If DATE lacks timezone information, GMT is assumed.
(defalias 'time-to-seconds 'float-time)
-(autoload 'seconds-to-time "time-date" "\
-Convert SECONDS to a time value.
-
-\(fn SECONDS)" nil nil)
+(defalias 'seconds-to-time 'encode-time)
(autoload 'days-to-time "time-date" "\
Convert DAYS into a time value.
@@ -34079,8 +33332,6 @@ The \"%z\" specifier does not print anything. When it is used, specifiers
must be given in order of decreasing size. To the left of \"%z\", nothing
is output until the first non-zero unit is encountered.
-This function does not work for SECONDS greater than `most-positive-fixnum'.
-
\(fn STRING SECONDS)" nil nil)
(autoload 'seconds-to-string "time-date" "\
@@ -34088,7 +33339,7 @@ Convert the time interval in seconds to a short string.
\(fn DELAY)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "time-date" '("seconds-to-string" "time-" "encode-time-value" "with-decoded-time-value")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "time-date" '("encode-time-value" "seconds-to-string" "time-" "with-decoded-time-value")))
;;;***
@@ -34120,9 +33371,7 @@ The format of the time stamp is set by the variable `time-stamp-pattern' or
`time-stamp-format'. The variables `time-stamp-pattern',
`time-stamp-line-limit', `time-stamp-start', `time-stamp-end',
`time-stamp-count', and `time-stamp-inserts-lines' control finding
-the template.
-
-\(fn)" t nil)
+the template." t nil)
(autoload 'time-stamp-toggle-active "time-stamp" "\
Toggle `time-stamp-active', setting whether \\[time-stamp] updates a buffer.
@@ -34208,15 +33457,11 @@ working on.
(autoload 'timeclock-query-out "timeclock" "\
Ask the user whether to clock out.
-This is a useful function for adding to `kill-emacs-query-functions'.
-
-\(fn)" nil nil)
+This is a useful function for adding to `kill-emacs-query-functions'." nil nil)
(autoload 'timeclock-reread-log "timeclock" "\
Re-read the timeclock, to account for external changes.
-Returns the new value of `timeclock-discrepancy'.
-
-\(fn)" t nil)
+Returns the new value of `timeclock-discrepancy'." t nil)
(autoload 'timeclock-workday-remaining-string "timeclock" "\
Return a string representing the amount of time left today.
@@ -34289,14 +33534,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\".
\(fn &optional FORCE)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "titdic-cnv" '("batch-miscdic-convert" "miscdic-convert" "ctlau-" "ziranma-converter" "py-converter" "quail-" "quick-" "tit-" "tsang-")))
-
-;;;***
-
-;;;### (autoloads nil "tls" "net/tls.el" (0 0 0 0))
-;;; Generated autoloads from net/tls.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tls" '("open-tls-stream" "tls-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "titdic-cnv" '("batch-miscdic-convert" "ctlau-" "miscdic-convert" "pinyin-convert" "py-converter" "quail-" "quick-" "tit-" "tsang-" "ziranma-converter")))
;;;***
@@ -34337,8 +33575,10 @@ MENU is like the MENU argument to `x-popup-menu': either a
keymap or an alist of alists.
DEFAULT-ITEM, if non-nil, specifies an initial default choice.
Its value should be an event that has a binding in MENU.
+NO-EXECUTE, if non-nil, means to return the command the user selects
+instead of executing it.
-\(fn MENU &optional IN-POPUP DEFAULT-ITEM)" nil nil)
+\(fn MENU &optional IN-POPUP DEFAULT-ITEM NO-EXECUTE)" nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tmm" '("tmm-")))
@@ -34549,12 +33789,13 @@ the output buffer or changing the window configuration.
(defalias 'trace-function 'trace-function-foreground)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "trace" '("untrace-" "trace-" "inhibit-trace")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "trace" '("inhibit-trace" "trace-" "untrace-")))
;;;***
;;;### (autoloads nil "tramp" "net/tramp.el" (0 0 0 0))
;;; Generated autoloads from net/tramp.el
+(push (purecopy '(tramp 2 4 2 -1)) package--builtin-versions)
(defvar tramp-mode t "\
Whether Tramp is enabled.
@@ -34572,6 +33813,11 @@ This regexp should match Tramp file names but no other file
names. When calling `tramp-register-file-name-handlers', the
initial value is overwritten by the car of `tramp-file-name-structure'.")
+(defvar tramp-ignored-file-name-regexp nil "\
+Regular expression matching file names that are not under Tramp’s control.")
+
+(custom-autoload 'tramp-ignored-file-name-regexp "tramp" t)
+
(defconst tramp-autoload-file-name-regexp (concat "\\`/" (if (memq system-type '(cygwin windows-nt)) "\\(-\\|[^/|:]\\{2,\\}\\)" "[^/|:]+") ":") "\
Regular expression matching file names handled by Tramp autoload.
It must match the initial `tramp-syntax' settings. It should not
@@ -34579,22 +33825,20 @@ match file names at root of the underlying local file system,
like \"/sys\" or \"/C:\".")
(defun tramp-autoload-file-name-handler (operation &rest args) "\
-Load Tramp file name handler, and perform OPERATION." (if tramp-mode (let ((default-directory temporary-file-directory)) (load "tramp" (quote noerror) (quote nomessage))) (tramp-unload-file-name-handlers)) (apply operation args))
+Load Tramp file name handler, and perform OPERATION." (tramp-unload-file-name-handlers) (if tramp-mode (let ((default-directory temporary-file-directory)) (load "tramp" 'noerror 'nomessage))) (apply operation args))
(defun tramp-register-autoload-file-name-handlers nil "\
-Add Tramp file name handlers to `file-name-handler-alist' during autoload." (add-to-list (quote file-name-handler-alist) (cons tramp-autoload-file-name-regexp (quote tramp-autoload-file-name-handler))) (put (quote tramp-autoload-file-name-handler) (quote safe-magic) t))
+Add Tramp file name handlers to `file-name-handler-alist' during autoload." (add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp 'tramp-autoload-file-name-handler)) (put 'tramp-autoload-file-name-handler 'safe-magic t))
(tramp-register-autoload-file-name-handlers)
(defun tramp-unload-file-name-handlers nil "\
-Unload Tramp file name handlers from `file-name-handler-alist'." (dolist (fnh (quote (tramp-file-name-handler tramp-completion-file-name-handler tramp-autoload-file-name-handler))) (let ((a1 (rassq fnh file-name-handler-alist))) (setq file-name-handler-alist (delq a1 file-name-handler-alist)))))
+Unload Tramp file name handlers from `file-name-handler-alist'." (dolist (fnh file-name-handler-alist) (when (and (symbolp (cdr fnh)) (string-prefix-p "tramp-" (symbol-name (cdr fnh)))) (setq file-name-handler-alist (delq fnh file-name-handler-alist)))))
(defvar tramp-completion-mode nil "\
If non-nil, external packages signal that they are in file name completion.")
(autoload 'tramp-unload-tramp "tramp" "\
-Discard Tramp from loading remote files.
-
-\(fn)" t nil)
+Discard Tramp from loading remote files." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp" '("tramp-" "with-")))
@@ -34607,6 +33851,37 @@ Discard Tramp from loading remote files.
;;;***
+;;;### (autoloads nil "tramp-archive" "net/tramp-archive.el" (0 0
+;;;;;; 0 0))
+;;; Generated autoloads from net/tramp-archive.el
+
+(defvar tramp-archive-enabled (featurep 'dbusbind) "\
+Non-nil when file archive support is available.")
+
+(defconst tramp-archive-suffixes '("7z" "apk" "ar" "cab" "CAB" "cpio" "deb" "depot" "exe" "iso" "jar" "lzh" "LZH" "msu" "MSU" "mtree" "odb" "odf" "odg" "odp" "ods" "odt" "pax" "rar" "rpm" "shar" "tar" "tbz" "tgz" "tlz" "txz" "warc" "xar" "xpi" "xps" "zip" "ZIP") "\
+List of suffixes which indicate a file archive.
+It must be supported by libarchive(3).")
+
+(defconst tramp-archive-compression-suffixes '("bz2" "gz" "lrz" "lz" "lz4" "lzma" "lzo" "uu" "xz" "Z") "\
+List of suffixes which indicate a compressed file.
+It must be supported by libarchive(3).")
+
+(defmacro tramp-archive-autoload-file-name-regexp nil "\
+Regular expression matching archive file names." '(concat "\\`" "\\(" ".+" "\\." (regexp-opt tramp-archive-suffixes) "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*" "\\)" "\\(" "/" ".*" "\\)" "\\'"))
+
+(defalias 'tramp-archive-autoload-file-name-handler #'tramp-autoload-file-name-handler)
+
+(defun tramp-register-archive-file-name-handler nil "\
+Add archive file name handler to `file-name-handler-alist'." (when tramp-archive-enabled (add-to-list 'file-name-handler-alist (cons (tramp-archive-autoload-file-name-regexp) #'tramp-archive-autoload-file-name-handler)) (put 'tramp-archive-autoload-file-name-handler 'safe-magic t)))
+
+(add-hook 'after-init-hook #'tramp-register-archive-file-name-handler)
+
+(add-hook 'tramp-archive-unload-hook (lambda nil (remove-hook 'after-init-hook #'tramp-register-archive-file-name-handler)))
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-archive" '("tramp-" "with-parsed-tramp-archive-file-name")))
+
+;;;***
+
;;;### (autoloads nil "tramp-cache" "net/tramp-cache.el" (0 0 0 0))
;;; Generated autoloads from net/tramp-cache.el
@@ -34632,11 +33907,6 @@ Discard Tramp from loading remote files.
;;;### (autoloads nil "tramp-ftp" "net/tramp-ftp.el" (0 0 0 0))
;;; Generated autoloads from net/tramp-ftp.el
-(autoload 'tramp-ftp-enable-ange-ftp "tramp-ftp" "\
-Reenable Ange-FTP, when Tramp is unloaded.
-
-\(fn)" nil nil)
-
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-ftp" '("tramp-")))
;;;***
@@ -34644,7 +33914,23 @@ Reenable Ange-FTP, when Tramp is unloaded.
;;;### (autoloads nil "tramp-gvfs" "net/tramp-gvfs.el" (0 0 0 0))
;;; Generated autoloads from net/tramp-gvfs.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-gvfs" '("tramp-" "with-tramp-dbus-call-method")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-gvfs" '("tramp-" "with-tramp-dbus-")))
+
+;;;***
+
+;;;### (autoloads nil "tramp-integration" "net/tramp-integration.el"
+;;;;;; (0 0 0 0))
+;;; Generated autoloads from net/tramp-integration.el
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-integration" '("tramp-")))
+
+;;;***
+
+;;;### (autoloads nil "tramp-rclone" "net/tramp-rclone.el" (0 0 0
+;;;;;; 0))
+;;; Generated autoloads from net/tramp-rclone.el
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-rclone" '("tramp-rclone-")))
;;;***
@@ -34662,6 +33948,14 @@ Reenable Ange-FTP, when Tramp is unloaded.
;;;***
+;;;### (autoloads nil "tramp-sudoedit" "net/tramp-sudoedit.el" (0
+;;;;;; 0 0 0))
+;;; Generated autoloads from net/tramp-sudoedit.el
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-sudoedit" '("tramp-sudoedit-")))
+
+;;;***
+
;;;### (autoloads nil "tramp-uu" "net/tramp-uu.el" (0 0 0 0))
;;; Generated autoloads from net/tramp-uu.el
@@ -34671,7 +33965,6 @@ Reenable Ange-FTP, when Tramp is unloaded.
;;;### (autoloads nil "trampver" "net/trampver.el" (0 0 0 0))
;;; Generated autoloads from net/trampver.el
-(push (purecopy '(tramp 2 3 5 26 2)) package--builtin-versions)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "trampver" '("tramp-")))
@@ -34744,9 +34037,7 @@ Associate another buffer with this one in two-column minor mode.
Can also be used to associate a just previously visited file, by
accepting the proposed default buffer.
-\(See \\[describe-mode] .)
-
-\(fn)" t nil)
+\(See \\[describe-mode] .)" t nil)
(autoload '2C-split "two-column" "\
Split a two-column text at point, into two buffers in two-column minor mode.
@@ -34789,6 +34080,11 @@ or call the function `type-break-mode'.")
Enable or disable typing-break mode.
This is a minor mode, but it is global to all buffers by default.
+If called interactively, enable Type-Break mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
+
When this mode is enabled, the user is encouraged to take typing breaks at
appropriate intervals; either after a specified amount of time or when the
user has exceeded a keystroke threshold. When the time arrives, the user
@@ -34797,9 +34093,6 @@ again in a short period of time. The idea is to give the user enough time
to find a good breaking point in his or her work, but be sufficiently
annoying to discourage putting typing breaks off indefinitely.
-A negative prefix argument disables this mode.
-No argument or any non-negative argument enables it.
-
The user may enable or disable this mode by setting the variable of the
same name, though setting it in that way doesn't reschedule a break or
reset the keystroke counter.
@@ -34868,16 +34161,12 @@ During the break, a demo selected from the functions listed in
`type-break-demo-functions' is run.
After the typing break is finished, the next break is scheduled
-as per the function `type-break-schedule'.
-
-\(fn)" t nil)
+as per the function `type-break-schedule'." t nil)
(autoload 'type-break-statistics "type-break" "\
Print statistics about typing breaks in a temporary buffer.
This includes the last time a typing break was taken, when the next one is
-scheduled, the keystroke thresholds and the current keystroke count, etc.
-
-\(fn)" t nil)
+scheduled, the keystroke thresholds and the current keystroke count, etc." t nil)
(autoload 'type-break-guesstimate-keystroke-threshold "type-break" "\
Guess values for the minimum/maximum keystroke threshold for typing breaks.
@@ -35027,9 +34316,7 @@ Convert old-style Rmail Babyl files to mbox format.
Specify the input Rmail Babyl file names as command line arguments.
For each Rmail file, the corresponding output file name
is made by adding `.mail' at the end.
-For example, invoke `emacs -batch -f batch-unrmail RMAIL'.
-
-\(fn)" nil nil)
+For example, invoke `emacs -batch -f batch-unrmail RMAIL'." nil nil)
(autoload 'unrmail "unrmail" "\
Convert old-style Rmail Babyl file FILE to mbox format file TO-FILE.
@@ -35051,7 +34338,7 @@ UNSAFEP-VARS is a list of symbols with local bindings.
\(fn FORM &optional UNSAFEP-VARS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "unsafep" '("unsafep-" "safe-functions")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "unsafep" '("safe-functions" "unsafep-")))
;;;***
@@ -35323,9 +34610,11 @@ or call the function `url-handler-mode'.")
(autoload 'url-handler-mode "url-handlers" "\
Toggle using `url' library for URL filenames (URL Handler mode).
-With a prefix argument ARG, enable URL Handler mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Url-Handler mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
\(fn &optional ARG)" t nil)
@@ -35607,9 +34896,7 @@ parses to
;;; Generated autoloads from url/url-privacy.el
(autoload 'url-setup-privacy-info "url-privacy" "\
-Setup variables that expose info about you and your system.
-
-\(fn)" t nil)
+Setup variables that expose info about you and your system." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-privacy" '("url-device-type")))
@@ -35824,6 +35111,15 @@ This uses `url-current-object', set locally to the buffer.
\(fn &optional NO-SHOW)" t nil)
+(autoload 'url-domain "url-util" "\
+Return the domain of the host of the URL.
+Return nil if this can't be determined.
+
+For instance, this function will return \"fsf.co.uk\" if the host in URL
+is \"www.fsf.co.uk\".
+
+\(fn URL)" nil nil)
+
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-util" '("url-")))
;;;***
@@ -35866,7 +35162,7 @@ The buffer in question is current when this function is called.
\(fn FN)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "userlock" '("ask-user-about-" "userlock--check-content-unchanged" "file-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "userlock" '("ask-user-about-" "file-" "userlock--check-content-unchanged")))
;;;***
@@ -36011,7 +35307,12 @@ first backend that could register the file is used.
\(fn &optional VC-FILESET COMMENT)" t nil)
(autoload 'vc-version-diff "vc" "\
-Report diffs between revisions of the fileset in the repository history.
+Report diffs between REV1 and REV2 revisions of the fileset.
+
+\(fn FILES REV1 REV2)" t nil)
+
+(autoload 'vc-root-version-diff "vc" "\
+Report diffs between REV1 and REV2 revisions of the whole tree.
\(fn FILES REV1 REV2)" t nil)
@@ -36026,6 +35327,12 @@ saving the buffer.
\(fn &optional HISTORIC NOT-URGENT)" t nil)
+(autoload 'vc-diff-mergebase "vc" "\
+Report diffs between the merge base of REV1 and REV2 revisions.
+The merge base is a common ancestor between REV1 and REV2 revisions.
+
+\(fn FILES REV1 REV2)" t nil)
+
(autoload 'vc-version-ediff "vc" "\
Show differences between revisions of the fileset in the
repository history using ediff.
@@ -36057,9 +35364,7 @@ saving the buffer.
(autoload 'vc-root-dir "vc" "\
Return the root directory for the current VC tree.
-Return nil if the root directory cannot be identified.
-
-\(fn)" nil nil)
+Return nil if the root directory cannot be identified." nil nil)
(autoload 'vc-revision-other-window "vc" "\
Visit revision REV of the current file in another window.
@@ -36071,9 +35376,7 @@ If `F.~REV~' already exists, use it instead of checking it out again.
(autoload 'vc-insert-headers "vc" "\
Insert headers into a file for use with a version control system.
Headers desired are inserted at point, and are pulled from
-the variable `vc-BACKEND-header'.
-
-\(fn)" t nil)
+the variable `vc-BACKEND-header'." t nil)
(autoload 'vc-merge "vc" "\
Perform a version control merge operation.
@@ -36087,9 +35390,7 @@ between two revisions into the current fileset. This asks for
two revisions to merge from in the minibuffer. If the first
revision is a branch number, then merge all changes from that
branch. If the first revision is empty, merge the most recent
-changes from the current branch.
-
-\(fn)" t nil)
+changes from the current branch." t nil)
(autoload 'vc-message-unresolved-conflicts "vc" "\
Display a message indicating unresolved conflicts in FILENAME.
@@ -36098,6 +35399,9 @@ Display a message indicating unresolved conflicts in FILENAME.
(defalias 'vc-resolve-conflicts 'smerge-ediff)
+(autoload 'vc-find-conflicted-file "vc" "\
+Visit the next conflicted file in the current project." t nil)
+
(autoload 'vc-create-tag "vc" "\
Descending recursively from DIR, make a tag called NAME.
For each registered file, the working revision becomes part of
@@ -36117,6 +35421,7 @@ If NAME is empty, it refers to the latest revisions of the current branch.
If locking is used for the files in DIR, then there must not be any
locked files at or below DIR (but if NAME is empty, locked files are
allowed and simply skipped).
+This function runs the hook `vc-retrieve-tag-hook' when finished.
\(fn DIR NAME)" t nil)
@@ -36156,6 +35461,12 @@ When called interactively with a prefix argument, prompt for REMOTE-LOCATION.
\(fn &optional REMOTE-LOCATION)" t nil)
+(autoload 'vc-log-mergebase "vc" "\
+Show a log of changes between the merge base of REV1 and REV2 revisions.
+The merge base is a common ancestor between REV1 and REV2 revisions.
+
+\(fn FILES REV1 REV2)" t nil)
+
(autoload 'vc-region-history "vc" "\
Show the history of the region between FROM and TO.
@@ -36167,9 +35478,7 @@ mark.
(autoload 'vc-revert "vc" "\
Revert working copies of the selected fileset to their repository contents.
This asks for confirmation if the buffer contents are not identical
-to the working revision (except for keyword expansion).
-
-\(fn)" t nil)
+to the working revision (except for keyword expansion)." t nil)
(define-obsolete-function-alias 'vc-revert-buffer 'vc-revert "23.1")
@@ -36476,7 +35785,7 @@ For a description of possible values, see `vc-check-master-templates'.")
(defun vc-sccs-search-project-dir (_dirname basename) "\
Return the name of a master file in the SCCS project directory.
Does not check whether the file exists but returns nil if it does not
-find any project directory." (let ((project-dir (getenv "PROJECTDIR")) dirs dir) (when project-dir (if (file-name-absolute-p project-dir) (setq dirs (quote ("SCCS" ""))) (setq dirs (quote ("src/SCCS" "src" "source/SCCS" "source"))) (setq project-dir (expand-file-name (concat "~" project-dir)))) (while (and (not dir) dirs) (setq dir (expand-file-name (car dirs) project-dir)) (unless (file-directory-p dir) (setq dir nil) (setq dirs (cdr dirs)))) (and dir (expand-file-name (concat "s." basename) dir)))))
+find any project directory." (let ((project-dir (getenv "PROJECTDIR")) dirs dir) (when project-dir (if (file-name-absolute-p project-dir) (setq dirs '("SCCS" "")) (setq dirs '("src/SCCS" "src" "source/SCCS" "source")) (setq project-dir (expand-file-name (concat "~" project-dir)))) (while (and (not dir) dirs) (setq dir (expand-file-name (car dirs) project-dir)) (unless (file-directory-p dir) (setq dir nil) (setq dirs (cdr dirs)))) (and dir (expand-file-name (concat "s." basename) dir)))))
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vc-sccs" '("vc-sccs-")))
@@ -36718,7 +36027,7 @@ Key bindings specific to `verilog-mode-map' are:
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "verilog-mode" '("vl-" "verilog-" "electric-verilog-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "verilog-mode" '("electric-verilog-" "verilog-" "vl-")))
;;;***
@@ -37296,9 +36605,7 @@ positions (integers or markers) specifying the stretch of the region.
\(fn FROM TO)" t nil)
(autoload 'viet-decode-viqr-buffer "viet-util" "\
-Convert `VIQR' mnemonics of the current buffer to Vietnamese characters.
-
-\(fn)" t nil)
+Convert `VIQR' mnemonics of the current buffer to Vietnamese characters." t nil)
(autoload 'viet-encode-viqr-region "viet-util" "\
Convert Vietnamese characters of the current region to `VIQR' mnemonics.
@@ -37308,9 +36615,7 @@ positions (integers or markers) specifying the stretch of the region.
\(fn FROM TO)" t nil)
(autoload 'viet-encode-viqr-buffer "viet-util" "\
-Convert Vietnamese characters of the current buffer to `VIQR' mnemonics.
-
-\(fn)" t nil)
+Convert Vietnamese characters of the current buffer to `VIQR' mnemonics." t nil)
(autoload 'viqr-post-read-conversion "viet-util" "\
@@ -37461,9 +36766,11 @@ own View-like bindings.
(autoload 'view-mode "view" "\
Toggle View mode, a minor mode for viewing text but not editing it.
-With a prefix argument ARG, enable View mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable View mode
-if ARG is omitted or nil.
+
+If called interactively, enable View mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
When View mode is enabled, commands that do not change the buffer
contents are available as usual. Kill commands insert text in
@@ -37576,11 +36883,9 @@ This function runs the normal hook `view-mode-hook'.
\(fn &optional QUIT-RESTORE EXIT-ACTION)" nil nil)
(autoload 'View-exit-and-edit "view" "\
-Exit View mode and make the current buffer editable.
-
-\(fn)" t nil)
+Exit View mode and make the current buffer editable." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "view" '("view-" "View-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "view" '("View-" "view-")))
;;;***
@@ -37590,16 +36895,12 @@ Exit View mode and make the current buffer editable.
(autoload 'toggle-viper-mode "viper" "\
Toggle Viper on/off.
-If Viper is enabled, turn it off. Otherwise, turn it on.
-
-\(fn)" t nil)
+If Viper is enabled, turn it off. Otherwise, turn it on." t nil)
(autoload 'viper-mode "viper" "\
-Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'.
-
-\(fn)" t nil)
+Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper" '("viper-" "set-viper-state-in-major-mode" "this-major-mode-requires-vi-state")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper" '("set-viper-state-in-major-mode" "this-major-mode-requires-vi-state" "viper-")))
;;;***
@@ -37630,7 +36931,7 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'.
;;;;;; 0 0))
;;; Generated autoloads from emulation/viper-keym.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper-keym" '("viper-" "ex-read-filename-map")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper-keym" '("ex-read-filename-map" "viper-")))
;;;***
@@ -37638,7 +36939,7 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'.
;;;;;; 0 0))
;;; Generated autoloads from emulation/viper-macs.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper-macs" '("viper-" "ex-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper-macs" '("ex-" "viper-")))
;;;***
@@ -37775,7 +37076,7 @@ this is equivalent to `display-warning', using
\(fn MESSAGE &rest ARGS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "warnings" '("warning-" "log-warning-minimum-level" "display-warning-minimum-level")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "warnings" '("display-warning-minimum-level" "log-warning-minimum-level" "warning-")))
;;;***
@@ -37791,9 +37092,7 @@ buffer, the target of the links, and the permission bits of the
files. After typing \\[wdired-finish-edit], Emacs modifies the files and
directories to reflect your edits.
-See `wdired-mode'.
-
-\(fn)" t nil)
+See `wdired-mode'." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "wdired" '("wdired-")))
@@ -37809,9 +37108,7 @@ See the documentation for the `webjump-sites' variable for how to customize the
hotlist.
Please submit bug reports and other feedback to the author, Neil W. Van Dyke
-<nwv@acm.org>.
-
-\(fn)" t nil)
+<nwv@acm.org>." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "webjump" '("webjump-")))
@@ -37837,9 +37134,11 @@ or call the function `which-function-mode'.")
(autoload 'which-function-mode "which-func" "\
Toggle mode line display of current function (Which Function mode).
-With a prefix argument ARG, enable Which Function mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Which-Function mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Which Function mode is a global minor mode. When enabled, the
current function name is continuously displayed in the mode line,
@@ -37857,11 +37156,11 @@ in certain major modes.
(autoload 'whitespace-mode "whitespace" "\
Toggle whitespace visualization (Whitespace mode).
-With a prefix argument ARG, enable Whitespace mode if ARG is
-positive, and disable it otherwise.
-If called from Lisp, also enables the mode if ARG is omitted or nil,
-and toggles it if ARG is `toggle'.
+If called interactively, enable Whitespace mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
See also `whitespace-style', `whitespace-newline' and
`whitespace-display-mappings'.
@@ -37870,11 +37169,11 @@ See also `whitespace-style', `whitespace-newline' and
(autoload 'whitespace-newline-mode "whitespace" "\
Toggle newline visualization (Whitespace Newline mode).
-With a prefix argument ARG, enable Whitespace Newline mode if ARG
-is positive, and disable it otherwise.
-If called from Lisp, also enables the mode if ARG is omitted or nil,
-and toggles it if ARG is `toggle'.
+If called interactively, enable Whitespace-Newline mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Use `whitespace-newline-mode' only for NEWLINE visualization
exclusively. For other visualizations, including NEWLINE
@@ -37897,11 +37196,11 @@ or call the function `global-whitespace-mode'.")
(autoload 'global-whitespace-mode "whitespace" "\
Toggle whitespace visualization globally (Global Whitespace mode).
-With a prefix argument ARG, enable Global Whitespace mode if ARG
-is positive, and disable it otherwise.
-If called from Lisp, also enables the mode if ARG is omitted or nil,
-and toggles it if ARG is `toggle'.
+If called interactively, enable Global Whitespace mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
See also `whitespace-style', `whitespace-newline' and
`whitespace-display-mappings'.
@@ -37920,11 +37219,11 @@ or call the function `global-whitespace-newline-mode'.")
(autoload 'global-whitespace-newline-mode "whitespace" "\
Toggle global newline visualization (Global Whitespace Newline mode).
-With a prefix argument ARG, enable Global Whitespace Newline mode
-if ARG is positive, and disable it otherwise.
-If called from Lisp, also enables the mode if ARG is omitted or nil,
-and toggles it if ARG is `toggle'.
+If called interactively, enable Global Whitespace-Newline mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Use `global-whitespace-newline-mode' only for NEWLINE
visualization exclusively. For other visualizations, including
@@ -38130,9 +37429,7 @@ The problems cleaned up are:
`space-after-tab::space', replace TABs by SPACEs.
See `whitespace-style', `indent-tabs-mode' and `tab-width' for
-documentation.
-
-\(fn)" t nil)
+documentation." t nil)
(autoload 'whitespace-cleanup-region "whitespace" "\
Cleanup some blank problems at region.
@@ -38246,9 +37543,11 @@ Show widget browser for WIDGET in other window.
(autoload 'widget-minor-mode "wid-browse" "\
Minor mode for traversing widgets.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
+
+If called interactively, enable Widget minor mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
\(fn &optional ARG)" t nil)
@@ -38286,15 +37585,13 @@ Call `insert' with ARGS even if surrounding text is read only.
\(fn &rest ARGS)" nil nil)
-(defvar widget-keymap (let ((map (make-sparse-keymap))) (define-key map " " 'widget-forward) (define-key map " " 'widget-backward) (define-key map [(shift tab)] 'widget-backward) (put 'widget-backward :advertised-binding [(shift tab)]) (define-key map [backtab] 'widget-backward) (define-key map [down-mouse-2] 'widget-button-click) (define-key map [down-mouse-1] 'widget-button-click) (define-key map [(control 109)] 'widget-button-press) map) "\
+(defvar widget-keymap (let ((map (make-sparse-keymap))) (define-key map "\11" 'widget-forward) (define-key map "\33\11" 'widget-backward) (define-key map [(shift tab)] 'widget-backward) (put 'widget-backward :advertised-binding [(shift tab)]) (define-key map [backtab] 'widget-backward) (define-key map [down-mouse-2] 'widget-button-click) (define-key map [down-mouse-1] 'widget-button-click) (define-key map [(control 109)] 'widget-button-press) map) "\
Keymap containing useful binding for buffers containing widgets.
Recommended as a parent keymap for modes using widgets.
Note that such modes will need to require wid-edit.")
(autoload 'widget-setup "wid-edit" "\
-Setup current buffer so editing string widgets works.
-
-\(fn)" nil nil)
+Setup current buffer so editing string widgets works." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "wid-edit" '("widget-")))
@@ -38309,7 +37606,8 @@ With no prefix argument, or with prefix argument equal to zero,
\"left\" is relative to the position of point in the window; otherwise
it is relative to the top edge (for positive ARG) or the bottom edge
\(for negative ARG) of the current window.
-If no window is at the desired location, an error is signaled.
+If no window is at the desired location, an error is signaled
+unless `windmove-create-window' is non-nil and a new window is created.
\(fn &optional ARG)" t nil)
@@ -38319,7 +37617,8 @@ With no prefix argument, or with prefix argument equal to zero, \"up\"
is relative to the position of point in the window; otherwise it is
relative to the left edge (for positive ARG) or the right edge (for
negative ARG) of the current window.
-If no window is at the desired location, an error is signaled.
+If no window is at the desired location, an error is signaled
+unless `windmove-create-window' is non-nil and a new window is created.
\(fn &optional ARG)" t nil)
@@ -38329,7 +37628,8 @@ With no prefix argument, or with prefix argument equal to zero,
\"right\" is relative to the position of point in the window;
otherwise it is relative to the top edge (for positive ARG) or the
bottom edge (for negative ARG) of the current window.
-If no window is at the desired location, an error is signaled.
+If no window is at the desired location, an error is signaled
+unless `windmove-create-window' is non-nil and a new window is created.
\(fn &optional ARG)" t nil)
@@ -38339,16 +37639,114 @@ With no prefix argument, or with prefix argument equal to zero,
\"down\" is relative to the position of point in the window; otherwise
it is relative to the left edge (for positive ARG) or the right edge
\(for negative ARG) of the current window.
-If no window is at the desired location, an error is signaled.
+If no window is at the desired location, an error is signaled
+unless `windmove-create-window' is non-nil and a new window is created.
\(fn &optional ARG)" t nil)
(autoload 'windmove-default-keybindings "windmove" "\
Set up keybindings for `windmove'.
-Keybindings are of the form MODIFIER-{left,right,up,down}.
-Default MODIFIER is `shift'.
+Keybindings are of the form MODIFIERS-{left,right,up,down},
+where MODIFIERS is either a list of modifiers or a single modifier.
+Default value of MODIFIERS is `shift'.
+
+\(fn &optional MODIFIERS)" t nil)
+
+(autoload 'windmove-display-left "windmove" "\
+Display the next buffer in window to the left of the current one.
+See the logic of the prefix ARG in `windmove-display-in-direction'.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'windmove-display-up "windmove" "\
+Display the next buffer in window above the current one.
+See the logic of the prefix ARG in `windmove-display-in-direction'.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'windmove-display-right "windmove" "\
+Display the next buffer in window to the right of the current one.
+See the logic of the prefix ARG in `windmove-display-in-direction'.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'windmove-display-down "windmove" "\
+Display the next buffer in window below the current one.
+See the logic of the prefix ARG in `windmove-display-in-direction'.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'windmove-display-same-window "windmove" "\
+Display the next buffer in the same window.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'windmove-display-default-keybindings "windmove" "\
+Set up keybindings for directional buffer display.
+Keys are bound to commands that display the next buffer in the specified
+direction. Keybindings are of the form MODIFIERS-{left,right,up,down},
+where MODIFIERS is either a list of modifiers or a single modifier.
+Default value of MODIFIERS is `shift-meta'.
+
+\(fn &optional MODIFIERS)" t nil)
+
+(autoload 'windmove-delete-left "windmove" "\
+Delete the window to the left of the current one.
+If prefix ARG is `C-u', delete the selected window and
+select the window that was to the left of the current one.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'windmove-delete-up "windmove" "\
+Delete the window above the current one.
+If prefix ARG is `C-u', delete the selected window and
+select the window that was above the current one.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'windmove-delete-right "windmove" "\
+Delete the window to the right of the current one.
+If prefix ARG is `C-u', delete the selected window and
+select the window that was to the right of the current one.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'windmove-delete-down "windmove" "\
+Delete the window below the current one.
+If prefix ARG is `C-u', delete the selected window and
+select the window that was below the current one.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'windmove-delete-default-keybindings "windmove" "\
+Set up keybindings for directional window deletion.
+Keys are bound to commands that delete windows in the specified
+direction. Keybindings are of the form PREFIX MODIFIERS-{left,right,up,down},
+where PREFIX is a prefix key and MODIFIERS is either a list of modifiers or
+a single modifier. Default value of PREFIX is `C-x' and MODIFIERS is `shift'.
+
+\(fn &optional PREFIX MODIFIERS)" t nil)
+
+(autoload 'windmove-swap-states-left "windmove" "\
+Swap the states with the window on the left from the current one." t nil)
-\(fn &optional MODIFIER)" t nil)
+(autoload 'windmove-swap-states-up "windmove" "\
+Swap the states with the window above from the current one." t nil)
+
+(autoload 'windmove-swap-states-down "windmove" "\
+Swap the states with the window below from the current one." t nil)
+
+(autoload 'windmove-swap-states-right "windmove" "\
+Swap the states with the window on the right from the current one." t nil)
+
+(autoload 'windmove-swap-states-default-keybindings "windmove" "\
+Set up keybindings for directional window swap states.
+Keys are bound to commands that swap the states of the selected window
+with the window in the specified direction. Keybindings are of the form
+MODIFIERS-{left,right,up,down}, where MODIFIERS is either a list of modifiers
+or a single modifier. Default value of MODIFIERS is `shift-super'.
+
+\(fn &optional MODIFIERS)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "windmove" '("windmove-")))
@@ -38369,9 +37767,11 @@ or call the function `winner-mode'.")
(autoload 'winner-mode "winner" "\
Toggle Winner mode on or off.
-With a prefix argument ARG, enable Winner mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'.
+
+If called interactively, enable Winner mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Winner mode is a global minor mode that records the changes in
the window configuration (i.e. how the frames are partitioned
@@ -38413,9 +37813,7 @@ should be a topic string and non-nil RE-CACHE forces re-caching.
\(fn &optional TOPIC RE-CACHE)" t nil)
(autoload 'woman-dired-find-file "woman" "\
-In dired, run the WoMan man-page browser on this file.
-
-\(fn)" t nil)
+In dired, run the WoMan man-page browser on this file." t nil)
(autoload 'woman-find-file "woman" "\
Find, decode and browse a specific UN*X man-page source file FILE-NAME.
@@ -38433,7 +37831,7 @@ Default bookmark handler for Woman buffers.
\(fn BOOKMARK)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "woman" '("woman" "WoMan-" "menu-bar-manuals-menu" "set-woman-file-regexp")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "woman" '("WoMan-" "menu-bar-manuals-menu" "set-woman-file-regexp" "woman")))
;;;***
@@ -38505,6 +37903,12 @@ Both features can be combined by providing a cons cell
\(fn &optional BEG END BUFFER PARSE-DTD PARSE-NS)" nil nil)
+(autoload 'xml-remove-comments "xml" "\
+Remove XML/HTML comments in the region between BEG and END.
+All text between the <!-- ... --> markers will be removed.
+
+\(fn BEG END)" nil nil)
+
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "xml" '("xml-")))
;;;***
@@ -38532,20 +37936,13 @@ If LIMIT is non-nil, then do not consider characters beyond LIMIT.
;;;### (autoloads nil "xref" "progmodes/xref.el" (0 0 0 0))
;;; Generated autoloads from progmodes/xref.el
-(autoload 'xref-find-backend "xref" "\
-
-
-\(fn)" nil nil)
+(autoload 'xref-find-backend "xref" nil nil nil)
(autoload 'xref-pop-marker-stack "xref" "\
-Pop back to where \\[xref-find-definitions] was last invoked.
-
-\(fn)" t nil)
+Pop back to where \\[xref-find-definitions] was last invoked." t nil)
(autoload 'xref-marker-stack-empty-p "xref" "\
-Return t if the marker stack is empty; nil otherwise.
-
-\(fn)" nil nil)
+Return t if the marker stack is empty; nil otherwise." nil nil)
(autoload 'xref-find-definitions "xref" "\
Find the definition of the identifier at point.
@@ -38579,6 +37976,12 @@ is nil, prompt only if there's no usable symbol at point.
\(fn IDENTIFIER)" t nil)
+(autoload 'xref-find-definitions-at-mouse "xref" "\
+Find the definition of identifier at or around mouse click.
+This command is intended to be bound to a mouse event.
+
+\(fn EVENT)" t nil)
+
(autoload 'xref-find-apropos "xref" "\
Find all meaningful symbols that match PATTERN.
The argument has the same meaning as in `apropos'.
@@ -38605,7 +38008,7 @@ IGNORES is a list of glob patterns.
;;;### (autoloads nil "xscheme" "progmodes/xscheme.el" (0 0 0 0))
;;; Generated autoloads from progmodes/xscheme.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "xscheme" '("xscheme-" "start-scheme" "scheme-" "exit-scheme-interaction-mode" "verify-xscheme-buffer" "local-" "global-set-scheme-interaction-buffer" "run-scheme" "reset-scheme" "default-xscheme-runlight")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "xscheme" '("default-xscheme-runlight" "exit-scheme-interaction-mode" "global-set-scheme-interaction-buffer" "local-" "reset-scheme" "run-scheme" "scheme-" "start-scheme" "verify-xscheme-buffer" "xscheme-")))
;;;***
@@ -38631,9 +38034,11 @@ or call the function `xterm-mouse-mode'.")
(autoload 'xterm-mouse-mode "xt-mouse" "\
Toggle XTerm mouse mode.
-With a prefix argument ARG, enable XTerm mouse mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+
+If called interactively, enable Xterm-Mouse mode if ARG is positive, and
+disable it if ARG is zero or negative. If called from Lisp,
+also enable the mode if ARG is omitted or nil, and toggle it
+if ARG is `toggle'; disable the mode otherwise.
Turn it on to use Emacs mouse commands, and off to use xterm mouse commands.
This works in terminal emulators compatible with xterm. It only
@@ -38671,9 +38076,7 @@ Yenc decode region between START and END using an internal decoder.
\(fn START END)" t nil)
(autoload 'yenc-extract-filename "yenc" "\
-Extract file name from an yenc header.
-
-\(fn)" nil nil)
+Extract file name from an yenc header." nil nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "yenc" '("yenc-")))
@@ -38690,9 +38093,7 @@ Extract file name from an yenc header.
;;; Generated autoloads from play/zone.el
(autoload 'zone "zone" "\
-Zone out, completely.
-
-\(fn)" t nil)
+Zone out, completely." t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "zone" '("zone-")))
@@ -38743,45 +38144,63 @@ Zone out, completely.
;;;;;; "emacs-lisp/eieio-opt.el" "emacs-lisp/eldoc.el" "emacs-lisp/float-sup.el"
;;;;;; "emacs-lisp/lisp-mode.el" "emacs-lisp/lisp.el" "emacs-lisp/macroexp.el"
;;;;;; "emacs-lisp/map-ynp.el" "emacs-lisp/nadvice.el" "emacs-lisp/syntax.el"
-;;;;;; "emacs-lisp/timer.el" "env.el" "epa-hook.el" "eshell/em-alias.el"
-;;;;;; "eshell/em-banner.el" "eshell/em-basic.el" "eshell/em-cmpl.el"
-;;;;;; "eshell/em-dirs.el" "eshell/em-glob.el" "eshell/em-hist.el"
-;;;;;; "eshell/em-ls.el" "eshell/em-pred.el" "eshell/em-prompt.el"
-;;;;;; "eshell/em-rebind.el" "eshell/em-script.el" "eshell/em-smart.el"
-;;;;;; "eshell/em-term.el" "eshell/em-tramp.el" "eshell/em-unix.el"
-;;;;;; "eshell/em-xtra.el" "facemenu.el" "faces.el" "files.el" "font-core.el"
-;;;;;; "font-lock.el" "format.el" "frame.el" "help.el" "hfy-cmap.el"
-;;;;;; "ibuf-ext.el" "indent.el" "international/characters.el" "international/charscript.el"
+;;;;;; "emacs-lisp/timer.el" "env.el" "epa-hook.el" "erc/erc-autoaway.el"
+;;;;;; "erc/erc-button.el" "erc/erc-capab.el" "erc/erc-compat.el"
+;;;;;; "erc/erc-dcc.el" "erc/erc-desktop-notifications.el" "erc/erc-ezbounce.el"
+;;;;;; "erc/erc-fill.el" "erc/erc-identd.el" "erc/erc-imenu.el"
+;;;;;; "erc/erc-join.el" "erc/erc-list.el" "erc/erc-log.el" "erc/erc-match.el"
+;;;;;; "erc/erc-menu.el" "erc/erc-netsplit.el" "erc/erc-notify.el"
+;;;;;; "erc/erc-page.el" "erc/erc-pcomplete.el" "erc/erc-replace.el"
+;;;;;; "erc/erc-ring.el" "erc/erc-services.el" "erc/erc-sound.el"
+;;;;;; "erc/erc-speedbar.el" "erc/erc-spelling.el" "erc/erc-stamp.el"
+;;;;;; "erc/erc-track.el" "erc/erc-truncate.el" "erc/erc-xdcc.el"
+;;;;;; "eshell/em-alias.el" "eshell/em-banner.el" "eshell/em-basic.el"
+;;;;;; "eshell/em-cmpl.el" "eshell/em-dirs.el" "eshell/em-glob.el"
+;;;;;; "eshell/em-hist.el" "eshell/em-ls.el" "eshell/em-pred.el"
+;;;;;; "eshell/em-prompt.el" "eshell/em-rebind.el" "eshell/em-script.el"
+;;;;;; "eshell/em-smart.el" "eshell/em-term.el" "eshell/em-tramp.el"
+;;;;;; "eshell/em-unix.el" "eshell/em-xtra.el" "facemenu.el" "faces.el"
+;;;;;; "files.el" "font-core.el" "font-lock.el" "format.el" "frame.el"
+;;;;;; "help.el" "hfy-cmap.el" "ibuf-ext.el" "indent.el" "international/characters.el"
+;;;;;; "international/charprop.el" "international/charscript.el"
;;;;;; "international/cp51932.el" "international/eucjp-ms.el" "international/mule-cmds.el"
-;;;;;; "international/mule-conf.el" "international/mule.el" "isearch.el"
-;;;;;; "jit-lock.el" "jka-cmpr-hook.el" "language/burmese.el" "language/cham.el"
-;;;;;; "language/chinese.el" "language/cyrillic.el" "language/czech.el"
-;;;;;; "language/english.el" "language/ethiopic.el" "language/european.el"
-;;;;;; "language/georgian.el" "language/greek.el" "language/hebrew.el"
-;;;;;; "language/indian.el" "language/japanese.el" "language/khmer.el"
-;;;;;; "language/korean.el" "language/lao.el" "language/misc-lang.el"
-;;;;;; "language/romanian.el" "language/sinhala.el" "language/slovak.el"
-;;;;;; "language/tai-viet.el" "language/thai.el" "language/tibetan.el"
-;;;;;; "language/utf-8-lang.el" "language/vietnamese.el" "ldefs-boot.el"
-;;;;;; "leim/ja-dic/ja-dic.el" "leim/leim-list.el" "leim/quail/4Corner.el"
-;;;;;; "leim/quail/ARRAY30.el" "leim/quail/CCDOSPY.el" "leim/quail/CTLau-b5.el"
-;;;;;; "leim/quail/CTLau.el" "leim/quail/ECDICT.el" "leim/quail/ETZY.el"
-;;;;;; "leim/quail/PY-b5.el" "leim/quail/PY.el" "leim/quail/Punct-b5.el"
-;;;;;; "leim/quail/Punct.el" "leim/quail/QJ-b5.el" "leim/quail/QJ.el"
-;;;;;; "leim/quail/SW.el" "leim/quail/TONEPY.el" "leim/quail/ZIRANMA.el"
-;;;;;; "leim/quail/ZOZY.el" "leim/quail/arabic.el" "leim/quail/croatian.el"
-;;;;;; "leim/quail/cyril-jis.el" "leim/quail/cyrillic.el" "leim/quail/czech.el"
-;;;;;; "leim/quail/georgian.el" "leim/quail/greek.el" "leim/quail/hanja-jis.el"
-;;;;;; "leim/quail/hanja.el" "leim/quail/hanja3.el" "leim/quail/hebrew.el"
-;;;;;; "leim/quail/ipa-praat.el" "leim/quail/latin-alt.el" "leim/quail/latin-ltx.el"
-;;;;;; "leim/quail/latin-post.el" "leim/quail/latin-pre.el" "leim/quail/persian.el"
-;;;;;; "leim/quail/programmer-dvorak.el" "leim/quail/py-punct.el"
-;;;;;; "leim/quail/pypunct-b5.el" "leim/quail/quick-b5.el" "leim/quail/quick-cns.el"
-;;;;;; "leim/quail/rfc1345.el" "leim/quail/sgml-input.el" "leim/quail/slovak.el"
-;;;;;; "leim/quail/symbol-ksc.el" "leim/quail/tamil-dvorak.el" "leim/quail/tsang-b5.el"
-;;;;;; "leim/quail/tsang-cns.el" "leim/quail/vntelex.el" "leim/quail/vnvni.el"
-;;;;;; "leim/quail/welsh.el" "loadup.el" "mail/blessmail.el" "mail/rmailedit.el"
-;;;;;; "mail/rmailkwd.el" "mail/rmailmm.el" "mail/rmailmsc.el" "mail/rmailsort.el"
+;;;;;; "international/mule-conf.el" "international/mule.el" "international/uni-bidi.el"
+;;;;;; "international/uni-brackets.el" "international/uni-category.el"
+;;;;;; "international/uni-combining.el" "international/uni-comment.el"
+;;;;;; "international/uni-decimal.el" "international/uni-decomposition.el"
+;;;;;; "international/uni-digit.el" "international/uni-lowercase.el"
+;;;;;; "international/uni-mirrored.el" "international/uni-name.el"
+;;;;;; "international/uni-numeric.el" "international/uni-old-name.el"
+;;;;;; "international/uni-titlecase.el" "international/uni-uppercase.el"
+;;;;;; "isearch.el" "jit-lock.el" "jka-cmpr-hook.el" "language/burmese.el"
+;;;;;; "language/cham.el" "language/chinese.el" "language/cyrillic.el"
+;;;;;; "language/czech.el" "language/english.el" "language/ethiopic.el"
+;;;;;; "language/european.el" "language/georgian.el" "language/greek.el"
+;;;;;; "language/hebrew.el" "language/indian.el" "language/japanese.el"
+;;;;;; "language/khmer.el" "language/korean.el" "language/lao.el"
+;;;;;; "language/misc-lang.el" "language/romanian.el" "language/sinhala.el"
+;;;;;; "language/slovak.el" "language/tai-viet.el" "language/thai.el"
+;;;;;; "language/tibetan.el" "language/utf-8-lang.el" "language/vietnamese.el"
+;;;;;; "ldefs-boot.el" "leim/ja-dic/ja-dic.el" "leim/leim-list.el"
+;;;;;; "leim/quail/4Corner.el" "leim/quail/ARRAY30.el" "leim/quail/CCDOSPY.el"
+;;;;;; "leim/quail/CTLau-b5.el" "leim/quail/CTLau.el" "leim/quail/ECDICT.el"
+;;;;;; "leim/quail/ETZY.el" "leim/quail/PY-b5.el" "leim/quail/PY.el"
+;;;;;; "leim/quail/Punct-b5.el" "leim/quail/Punct.el" "leim/quail/QJ-b5.el"
+;;;;;; "leim/quail/QJ.el" "leim/quail/SW.el" "leim/quail/TONEPY.el"
+;;;;;; "leim/quail/ZIRANMA.el" "leim/quail/ZOZY.el" "leim/quail/arabic.el"
+;;;;;; "leim/quail/croatian.el" "leim/quail/cyril-jis.el" "leim/quail/cyrillic.el"
+;;;;;; "leim/quail/czech.el" "leim/quail/georgian.el" "leim/quail/greek.el"
+;;;;;; "leim/quail/hanja-jis.el" "leim/quail/hanja.el" "leim/quail/hanja3.el"
+;;;;;; "leim/quail/hebrew.el" "leim/quail/ipa-praat.el" "leim/quail/latin-alt.el"
+;;;;;; "leim/quail/latin-ltx.el" "leim/quail/latin-post.el" "leim/quail/latin-pre.el"
+;;;;;; "leim/quail/persian.el" "leim/quail/programmer-dvorak.el"
+;;;;;; "leim/quail/py-punct.el" "leim/quail/pypunct-b5.el" "leim/quail/quick-b5.el"
+;;;;;; "leim/quail/quick-cns.el" "leim/quail/rfc1345.el" "leim/quail/sami.el"
+;;;;;; "leim/quail/sgml-input.el" "leim/quail/slovak.el" "leim/quail/symbol-ksc.el"
+;;;;;; "leim/quail/tamil-dvorak.el" "leim/quail/tsang-b5.el" "leim/quail/tsang-cns.el"
+;;;;;; "leim/quail/vntelex.el" "leim/quail/vnvni.el" "leim/quail/welsh.el"
+;;;;;; "loadup.el" "mail/blessmail.el" "mail/rmailedit.el" "mail/rmailkwd.el"
+;;;;;; "mail/rmailmm.el" "mail/rmailmsc.el" "mail/rmailsort.el"
;;;;;; "mail/rmailsum.el" "mail/undigest.el" "menu-bar.el" "mh-e/mh-gnus.el"
;;;;;; "mh-e/mh-loaddefs.el" "minibuffer.el" "mouse.el" "net/tramp-loaddefs.el"
;;;;;; "newcomment.el" "obarray.el" "org/ob-core.el" "org/ob-keys.el"
diff --git a/lisp/leim/quail/cyril-jis.el b/lisp/leim/quail/cyril-jis.el
index 0214a51d74e..67271ab3c47 100644
--- a/lisp/leim/quail/cyril-jis.el
+++ b/lisp/leim/quail/cyril-jis.el
@@ -32,114 +32,110 @@
;;; Code:
(quail-define-package
- "cyrillic-jis-russian" "Cyrillic" "$B'('+(B" nil
- "$B'+'8'5','&'/(B keyboard layout same as JCUKEN (JIS X0208.1983 encoding)"
+ "cyrillic-jis-russian" "Cyrillic" "ЖЙ" nil
+ "ЙЦУКЕН keyboard layout same as JCUKEN (JIS X0208.1983 encoding)"
nil t t t t nil nil nil nil nil t)
-;; 1! 2@ 3# 4" 5: 6, 7. 8* 9( 0) -_ =+ ,L!(B
-;; ,L9(B ,LF(B ,LC(B ,L:(B ,L5(B ,L=(B ,L3(B ,LH(B ,LI(B ,L7(B ,LE(B ,Lj(B
-;; ,LD(B ,LK(B ,L2(B ,L0(B ,L?(B ,L@(B ,L>(B ,L;(B ,L4(B ,L6(B ,LM(B
-;; ,LO(B ,LG(B ,LA(B ,L<(B ,L8(B ,LB(B ,LL(B ,L1(B ,LN(B /?
+;; 1! 2@ 3# 4" 5: 6, 7. 8* 9( 0) -_ =+ Ё
+;; Й Ц У К Е Н Г Ш Щ З Х ъ
+;; Ф Ы В А П Р О Л Д Ж Э
+;; Я Ч С М И Т Ь Б Ю /?
(quail-define-rules
- ("1" ?$B#1(B)
- ("2" ?$B#2(B)
- ("3" ?$B#3(B)
- ("4" ?$B#4(B)
- ("5" ?$B#5(B)
- ("6" ?$B#6(B)
- ("7" ?$B#7(B)
- ("8" ?$B#8(B)
- ("9" ?$B#9(B)
- ("0" ?$B#0(B)
- ("-" ?$B!](B)
- ("=" ?$B!a(B)
- ("`" ?$B'W(B)
- ("q" ?$B'[(B)
- ("w" ?$B'h(B)
- ("e" ?$B'e(B)
- ("r" ?$B'\(B)
- ("t" ?$B'V(B)
- ("y" ?$B'_(B)
- ("u" ?$B'T(B)
- ("i" ?$B'j(B)
- ("o" ?$B'k(B)
- ("p" ?$B'Y(B)
- ("[" ?$B'g(B)
- ("]" ?$B'l(B)
- ("a" ?$B'f(B)
- ("s" ?$B'm(B)
- ("d" ?$B'S(B)
- ("f" ?$B'Q(B)
- ("g" ?$B'a(B)
- ("h" ?$B'b(B)
- ("j" ?$B'`(B)
- ("k" ?$B'](B)
- ("l" ?$B'U(B)
- (";" ?$B'X(B)
- ("'" ?$B'o(B)
- ("\\" ?$B!@(B)
- ("z" ?$B'q(B)
- ("x" ?$B'i(B)
- ("c" ?$B'c(B)
- ("v" ?$B'^(B)
- ("b" ?$B'Z(B)
- ("n" ?$B'd(B)
- ("m" ?$B'n(B)
- ("," ?$B'R(B)
- ("." ?$B'p(B)
- ("/" ?$B!?(B)
+ ("1" ?1)
+ ("2" ?2)
+ ("3" ?3)
+ ("4" ?4)
+ ("5" ?5)
+ ("6" ?6)
+ ("7" ?7)
+ ("8" ?8)
+ ("9" ?9)
+ ("0" ?0)
+ ("-" ?−)
+ ("=" ?=)
+ ("`" ?ё)
+ ("q" ?й)
+ ("w" ?ц)
+ ("e" ?у)
+ ("r" ?к)
+ ("t" ?е)
+ ("y" ?н)
+ ("u" ?г)
+ ("i" ?ш)
+ ("o" ?щ)
+ ("p" ?з)
+ ("[" ?х)
+ ("]" ?ъ)
+ ("a" ?ф)
+ ("s" ?ы)
+ ("d" ?в)
+ ("f" ?а)
+ ("g" ?п)
+ ("h" ?р)
+ ("j" ?о)
+ ("k" ?л)
+ ("l" ?д)
+ (";" ?ж)
+ ("'" ?э)
+ ("\\" ?\)
+ ("z" ?я)
+ ("x" ?ч)
+ ("c" ?с)
+ ("v" ?м)
+ ("b" ?и)
+ ("n" ?т)
+ ("m" ?ь)
+ ("," ?б)
+ ("." ?ю)
+ ("/" ?/)
- ("!" ?$B!*(B)
- ("@" ?$B!w(B)
- ("#" ?$B!t(B)
- ("$" ?$B!I(B)
- ("%" ?$B!'(B)
- ("^" ?$B!$(B)
- ("&" ?$B!%(B)
- ("*" ?$B!v(B)
- ("(" ?$B!J(B)
- (")" ?$B!K(B)
- ("_" ?$B!2(B)
- ("+" ?$B!\(B)
- ("~" ?$B''(B)
- ("Q" ?$B'+(B)
- ("W" ?$B'8(B)
- ("E" ?$B'5(B)
- ("R" ?$B',(B)
- ("T" ?$B'&(B)
- ("Y" ?$B'/(B)
- ("U" ?$B'$(B)
- ("I" ?$B':(B)
- ("O" ?$B';(B)
- ("P" ?$B')(B)
- ("{" ?$B'7(B)
- ("}" ?$B'<(B)
- ("A" ?$B'6(B)
- ("S" ?$B'=(B)
- ("D" ?$B'#(B)
- ("F" ?$B'!(B)
- ("G" ?$B'1(B)
- ("H" ?$B'2(B)
- ("J" ?$B'0(B)
- ("K" ?$B'-(B)
- ("L" ?$B'%(B)
- (":" ?$B'((B)
- ("\"" ?$B'?(B)
- ("|" ?$B!C(B)
- ("Z" ?$B'A(B)
- ("X" ?$B'9(B)
- ("C" ?$B'3(B)
- ("V" ?$B'.(B)
- ("B" ?$B'*(B)
- ("N" ?$B'4(B)
- ("M" ?$B'>(B)
- ("<" ?$B'"(B)
- (">" ?$B'@(B)
- ("?" ?$B!)(B))
-
-;; Local Variables:
-;; coding: iso-2022-7bit
-;; End:
+ ("!" ?!)
+ ("@" ?@)
+ ("#" ?#)
+ ("$" ?”)
+ ("%" ?:)
+ ("^" ?,)
+ ("&" ?.)
+ ("*" ?*)
+ ("(" ?()
+ (")" ?))
+ ("_" ?_)
+ ("+" ?+)
+ ("~" ?Ё)
+ ("Q" ?Й)
+ ("W" ?Ц)
+ ("E" ?У)
+ ("R" ?К)
+ ("T" ?Е)
+ ("Y" ?Н)
+ ("U" ?Г)
+ ("I" ?Ш)
+ ("O" ?Щ)
+ ("P" ?З)
+ ("{" ?Х)
+ ("}" ?Ъ)
+ ("A" ?Ф)
+ ("S" ?Ы)
+ ("D" ?В)
+ ("F" ?А)
+ ("G" ?П)
+ ("H" ?Р)
+ ("J" ?О)
+ ("K" ?Л)
+ ("L" ?Д)
+ (":" ?Ж)
+ ("\"" ?Э)
+ ("|" ?|)
+ ("Z" ?Я)
+ ("X" ?Ч)
+ ("C" ?С)
+ ("V" ?М)
+ ("B" ?И)
+ ("N" ?Т)
+ ("M" ?Ь)
+ ("<" ?Б)
+ (">" ?Ю)
+ ("?" ??))
;;; cyril-jis.el ends here
diff --git a/lisp/leim/quail/hanja-jis.el b/lisp/leim/quail/hanja-jis.el
index 79730b816ef..6f753259456 100644
--- a/lisp/leim/quail/hanja-jis.el
+++ b/lisp/leim/quail/hanja-jis.el
@@ -1,4 +1,4 @@
-;;; hanja-jis.el --- Quail package for inputting Korean Hanja (JISX0208) -*-coding: iso-2022-7bit;-*-
+;;; hanja-jis.el --- Quail package for inputting Korean Hanja (JISX0208)
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007, 2008, 2009, 2010, 2011
@@ -29,499 +29,499 @@
(require 'quail)
(quail-define-package
- "korean-hanja-jis" "Korean" "$B4A(B2" t
- "2$(C9z=D(BJIS$B4A;z(B: $B3:aD$(CGO4B(B $B4A;z$(C@G(B $B1$$(C@;(B $(CGQ1[(B2$(C9z$B<0$(C@87N(B $B8F=P$(CGO?)(B $BA*Z$(B"
+ "korean-hanja-jis" "Korean" "漢2" t
+ "2벌식JIS漢字: 該當하는 漢字의 韻을 한글2벌式으로 呼出하여 選擇"
nil nil nil nil nil nil t)
(quail-define-rules
- ("rk" "$B1]2>2@2A2B2C2D2E2G2H2K2M2N2Q2T2W2X2`2o3976P$PqQ+RjS'[H[I`]aPcwgWhSkEkhlKlhmF(B")
- ("rkr" "$B3F3J3L3P3Q3S3U5Q5S9oH9RJS>T=WmXBZ([d]W`Bk4l;r((B")
- ("rks" "$B064%4&4)4/43444B4G4H4J4N4V:&:):1?{U!XLYc[8[K[Y[e`CarcCecgek]s*su(B")
- ("rkf" "$B2p3e3i3k3l7GP"[+brcqf;iypbpv(B")
- ("rka" "$B4*4.46484:4;4E4F4U7g848::0QaT,T0VHY"Y~\m]>^@aQbWeHiTm^nGoHs|(B")
- ("rkq" "$B2!389C9gL(R:b5fpo^(B")
- ("rkd" "$B2,3`6/607D9/959>9G9K9P9V9]9_9dFzP6Q,S3U*V>XMY,[:[|aEbee,eZf5i(jvlora(B")
- ("ro" "$B2B2U2p2r2~3'3)3+3,3.313435383;8DP"P$PCQsXAXhYb\4^taNb5k;(B")
- ("ror" "$B5RS=(B")
- ("rod" "$B9#99dkf=f>o3(B")
- ("ri" "$B2X(B")
- ("rir" "$BnS(B")
- ("rj" "$B5n5o5p5q5r5t5w5x<V?x?~P`PbTRZ!Z)Z*]0_Yc@d(gplwn1nSnj(B")
- ("rjs" "$B4%6R7o7r7z80X4Ykg'iJkim!qZ(B")
- ("rjf" "$B3i7G7f8pC4KqPu[?[\]ccq(B")
- ("rja" "$B4;7p7u8!84Q-QxQyQzQ{\}b[g@sX(B")
- ("rjq" "$B5h619e=&Qg(B")
- ("rp" "$B7F7GPuX\br(B")
- ("rur" "$B2>3J3V3W7b7cPqYH\|g-h#k.ojqnr/rps&(B")
- ("rus" "$B3_3o7x8#8$8(8*8+8/G{KzLzPWVtWz[G`Fa+d*f0l$s$(B")
- ("ruf" "$B5K7@7h7i7k7mLRQSY1YIYMe~r!(B")
- ("rua" "$B3y7s8,XDY:]>d/heni(B")
- ("ruq" "$B3fKKXDnw(B")
- ("rud" "$B5~6%6*6-6@6C797B7D7I7J7P7T7U7Y7Z7[7_9.999<9E9L:"P7Q?QDQHQmR&R'S+WMX]\{_i`{a9a[b~e%e4e;fVfzh3krmKmtpopts](B")
- ("rP" "$B2|3#3&3,5(787<7@7K7L7N7O7Q7R7W7\:fFOU|W@X)[G^da8b#c4d"e;eki)kSl0r!s1(B")
- ("rh" "$B6l8E8G8H8I8K8N8O8S8T8V8Z8[8\8]9F9M9Q9b9i9p;)<J?,C!ONPFQYQjRmZ?ZJZ^[W[][^\I\_]xa`b(bPb\cLd2f*f6fxiVjCk8kFkUlKmcn~pQrurzsi(B")
- ("rhr" "$B6J9p9r9s9tC+H#S-ZO[g\`mXq~(B")
- ("rhs" "$B:$:%:+:-:.TgVBW}[~^xhBjnrArJs.(B")
- ("rhf" "$B3j9|\K]qs3(B")
- ("rhd" "$B6!6&62636u8x8y9&9)95969WPeW0YJ[}\Jd3iOi^i_lop_(B")
- ("rhk" "$B1;2I2J2L2[2]2a8S8X8YFiTFTnTrXyfxhTixjglvpy(B")
- ("rhkr" "$B3G3TZ2Z<[v\Zayb_oWp9(B")
- ("rhks" "$B4'4142474=4>4C4I4P4Q4S4X4[4\6z?{P%QN]Y^ub9eEeGf%k7oQopsA(B")
- ("rhkf" "$B3g3hH&I0Qi[XfZ(B")
- ("rhkd" "$B3H6)688w9-9[9\T]W"Z2[%[&[Z^+bhc~d!e&e-fykToJ(B")
- ("rho" "$B3]757SS%XyYL[Jjh(B")
- ("rhl" "$B2q2t2u2x2z2}3!P*PzTUW_XC\G`skK(B")
- ("rhlr" "$Bg2qE(B")
- ("rhld" "$B9(9I9O9l^3mDo)(B")
- ("ry" "$B3I3P3S3z5j6#6+6,65666:6>8r8s9'9*9;9J9Y9Z;->7R{UHYxZJ\r_$`Db)c#c\fKg1i`m]n[q-qaqb(B")
- ("rn" "$B11192$2%2*3C555V5W5X5_5a5d5e5f5l5q6e6f6g6h6i6j6k6m6n6o6p6q7)8{8}9$949=9B9XC!G#H7KUP}QJR"R?RkSRU=UBUdVOV}V~WaW|XvY+Yl[M[N]?]X]\a.aLbZc`d@gOgQgqhgiUjMjdk2kMkpmsn)n9nlplq'qDq\r-szs}(B")
- ("rnr" "$B5E5F5G6I9m9qSxT"[xdxkqlr(B")
- ("rns" "$B7/727374[ub0b1c[f:je(B")
- ("rnf" "$B6~7!7"KYPcRPVA(B")
- ("rnd" "$B5\5]5gcVm;(B")
- ("rnjs" "$B4+4,5s7q7t7w7}7~8"R%R0RKT!X+[{\^bGe<ipq"(B")
- ("rnjf" "$B7!OOP-RP`Um,om(B")
- ("rnp" "$B4y5"50B|DYQ\R<[z]$]Eb'dOgLkLlnm,q9q?(B")
- ("rnl" "$B5"5.5455S@[z]Eb's}(B")
- ("rnlr" "$BDOVn(B")
- ("rb" "$B0*1.5,5j6+6e7=7>:"DPTwYdYw\\b#bkcad}eYj_lbm|oaqDr-(B")
- ("rbs" "$B556Q6]d0nbsKs}(B")
- ("rbf" "$B5L(B")
- ("rmr" "$B2D3W6K7`7a7d9nP4QnUqV![yh{n<(B")
- ("rms" "$B6O6P6R6T6Z6\6`6a:,Xi\]`wbbhAk3ncq<(B")
- ("rmf" "$B7@k?(B")
- ("rma" "$B6S6W6X6Y6^6_6b8i:#SaZ"jPsX(B")
- ("rmq" "$B075Z5^5b5h5i5kV)(B")
- ("rmd" "$B919NOJOKQ>Wqbb(B")
- ("rl" "$B0k4k4l4o4p4q4s4t4v4w4z4{4|4}4~5!5$5%5&5'5*5-5/5253585;5=5@5o778J8k8p:j:k:l<(B6H)IIL'P4PXQCQpSOSZT-TtV?W1YVZ\Zz[.[9[L[w\H]c]f]k^?aCc2cEe:f3f4fMk+k1kxl1leq@qVqgr?sJ(B")
- ("rlr" "$B5J(B")
- ("rls" "$B6[(B")
- ("rlf" "$B5H5K5MPKYI(B")
- ("rla" "$B6b(B")
- ("Rlr" "$B5J(B")
- ("sk" "$BF`FaFqQ5U1XoY.Y<Y=[kdy(B")
- ("skr" "$BBz(B")
- ("sks" "$BCHFqZ:_kl_(B")
- ("skf" "$BFhYT^:(B")
- ("ska" "$BCKFnFoSGU3n((B")
- ("skq" "$BG<jU(B")
- ("skd" "$BG9L<[((B")
- ("so" "$BBQF`FbFwG5G6G=mr(B")
- ("sid" "$B>nUP(B")
- ("su" "$B=wY<Y=h'(B")
- ("sus" "$BG/G2bzmY(B")
- ("suf" "$BYT^:(B")
- ("sua" "$BG0WwY@\,(B")
- ("suq" "$B@]G1Ypm:oR(B")
- ("sud" "$BG+Sf_?`Xfd(B")
- ("sP" "$BG)Zc(B")
- ("sh" "$BEXE[E\G>RsUWVfW8`obug*gBqN(B")
- ("shd" "$BG;G?G@Q/(B")
- ("shk" "$B<6(B")
- ("shl" "$BG:G>X=g*q/(B")
- ("sy" "$BE.G"U>Yz\vo?o_r)(B")
- ("sn" "$BfU(B")
- ("sns" "$BUD(B")
- ("snf" "$BRefmkD(B")
- ("sb" "$BI3WY`=nf(B")
- ("sbr" "$BWYjHjI(B")
- ("smd" "$BG=(B")
- ("sl" "$BE%FtG)G*Wb_>_Pg7(B")
- ("slr" "$BE.F?(B")
- ("slf" "$BFtWbZc(B")
- ("sla" "$BDBWl(B")
- ("ek" "$BB?BgCcTl(B")
- ("eks" "$B1_C"C0C1C4C6C;C<C=C@CACCCDCECGCICJFNFXP9SET%WAXIXUZR\g^Z`NaUeKh[iijXj{j|nBs((B")
- ("ekf" "$BC#RtU'WeZ%_}`\m}orpZpg(B")
- ("eka" "$BC4C8C9C?CLF^S7S8T`XkY?]__,_8abb>g<i!k)k}q5(B")
- ("ekq" "$B7#EkEzF'Quh)(B")
- ("ekd" "$BE^EbEdEvE|F2F5Q8Vq[c\+^oaDbUc'j0j;j}oFs^(B")
- ("eo" "$B10BPBRBSBTBWB^B_BbBcBeBgFXT2UtVhZ,Z-`^gJi7o>p0(B")
- ("ejr" "$BFAW\(B")
- ("eh" "$B0p?^D)D7EHEIEKELEOEQERESETEUEYE]EaEgEhEiEmEnEpEqEsExE~F(F+F3F:F;R[T&V:Y[Y\YqZ.[7[m\*]%]9^9^mbQcKe6eBeCe{h8h9k/lum%mmokpkqC(B")
- ("ehr" "$B<3FBFDFEFFFGFHFI`1`9`We{l&qqsb(B")
- ("ehs" "$B=cFUFWFXFYFZF[F\Z}_wa&n,q+(B")
- ("ehf" "$BFMF\Rt[S(B")
- ("ehd" "$B4R6ME_E`ElEoF!F/F0F1F4F6F7F8F9F<Q*\u_.aVdig^gtr<s)sj(B")
- ("en" "$B1%3u?`EMENEZEwF&F,FIP5Y5ceflh:iQjEjFl&nFr((B")
- ("ens" "$BFVF[F\F_g=n,(B")
- ("emr" "$BF@(B")
- ("emd" "$BEPEtEuEyF#F%F*F-VS\t^naVc$d[d\eX(B")
- ("fk" "$B;IMeMfMgSIXqapaziGn6oUozq`(B")
- ("fkr" "$B3J3ZMlMmMnMoS>\[_``8`dqQ(B")
- ("fks" "$BMpMqMsMvP,UO]3_Q_s`%k&oVolsB(B")
- ("fkf" "$BQoSIT?T@dzme(B")
- ("fka" "$BMrMtMuMwQ0U:Z0]4dWeqe|k"k5nN(B")
- ("fkq" "$B@"O9YG[VgDgEoM(B")
- ("fkd" "$BBlBmO-O/O1O2O5O:[-`f`gh>j'lplt(B")
- ("fo" "$BPTWR(B")
- ("fod" "$BNd(B")
- ("fir" "$BN+N,Z6a@(B")
- ("fid" "$BL:N+N<N>NBNCNHNINJNLPoQ@QZSJdmdnjllpltmQmRr4(B")
- ("fu" "$B023BEWK{N7N8N9NeNoO$O?Q6R/S:W*[q]-`4`5avbjdze8eFg0gFh-i<iCiZjBoLocqfqk(B")
- ("fur" "$BNONqNrV'[6]+],]._Ma|c*m`mapNr/(B")
- ("fus" "$BNgNmNxNyNzN{N}N~O!O"O#SXXxYcZ;\Bf_gHmSo:rY(B")
- ("fuf" "$BNsNtNuNvQXY`^0(B")
- ("fua" "$B3yNwN|R=T~ZL_2_R(B")
- ("fuq" "$BND`Zr'(B")
- ("fud" "$BNNNaNbNfNgNhNjNkNmNnNpSz]2_:f9fYiYpMryst(B")
- ("fP" "$BK-NcNiNlc9h-nTp1rg(B")
- ("fh" "$B02:mH'IyN:O%O&O'O(O)O*O+O4O7R)S$Y}[E_#_3_I_N`$atb:gbgcgdiCmJmboNoOq!qfrisC(B")
- ("fhr" "$B3Q9w</C+NPO<O=O?[rbqc3m\(B")
- ("fhs" "$BO@^M(B")
- ("fhd" "$BBlBmN5N6O.O6O8S/T;Tb[0\Y`|dFiDp/(B")
- ("fhl" "$B@%MjMkN]O(Q4T^Z']*azb}d]f#fPi2iAkQlO(B")
- ("fy" "$BN;N=N@NANENFNKUlW!Y|["_yegfXhznRoAs>(B")
- ("fyd" "$BN5N6iD(B")
- ("fn" "$B<HN^N_O,O0O3Q$\l`4`5aqdMe_e`j3jzo;o{qp(B")
- ("fnl" "$BN^^%(B")
- ("fb" "$BI5LxN-N.N/N0N1N2N\N]N_N`R-ShT^W!ZX\X^%_H`eaneYe`g{nvo9pEq:(B")
- ("fbr" "$BN&O;R-Y$hz(B")
- ("fbs" "$BNQNXO@PUVFVG\2^MeE(B")
- ("fbf" "$B7*N'N(N*XKdE(B")
- ("fbd" "$BN4VWcc(B")
- ("fmr" "$BO>P>pU(B")
- ("fma" "$BQ[W)XnhR(B")
- ("fmd" "$B0=I)KSN?NGNMVE\AhQi3(B")
- ("fl" "$B3=8qA8C,DsKiMxMyMzM{M|M}M~N!N"N#N$N%NRNoP]P^X&Xm_"`4`5crdaf@h.h=imjBkJl>nZqkr5rEsW(B")
- ("fls" "$BNUNYNZN[RgX'iBm8m9nC(B")
- ("fla" "$BNSNTNVNWaepC(B")
- ("flq" "$B3^N)N3g~(B")
- ("ak" "$BGMGOK`KaKbKcSWU@Vw`uadb{j1j2(B")
- ("akr" "$BGyG|KFKkKlLNUki8(B")
- ("aks" "$B17HTHUHZJZK|K}K~L!L"OQRDRXV]VoW>W?Xp^`_TbVe\h_jGktm*mNo8q=r#(B")
- ("akf" "$BKuKvKwbFcBg}k$p\pi(B")
- ("akd" "$BK4K:K;K>LQLVX1f&f(gjh+hOj<j=nzr3(B")
- ("ao" "$BGMG^G_G`GaGcGdJrK?KdKeKfKgKhL%Ug`pgugvlNn2pJ(B")
- ("aor" "$BG|G~I4L.`Sfwl=lBoyq^sN(B")
- ("aod" "$B0:K(LALTLUQ3]ba0hNsf(B")
- ("aur" "$BQLQQVm]qf2k,(B")
- ("aus" "$BJYL2LHLILJLKLLLMP[QKU_^^b@bTeDsQ(B")
- ("auf" "$BJNLG(B")
- ("aud" "$B;.L=L>L?L@LCLDZy\U^rbTh,j&nIsf(B")
- ("aP" "$BjV(B")
- ("ah" "$B18243}G|InJgJhJiJkJlK9K?KAKEKFKHKlL0L6L7LNLOLSLWU(ZV`S`pa(b&bHcjdwfNfnhOkuqxr|(B")
- ("ahr" "$BI$KRKTLZL\Q^[7]teYg|s/(B")
- ("ahf" "$BKWL^]G]s(B")
- ("ahd" "$BL4LXQOTm[$[/](_Bb^ga(B")
- ("ay" "$B1,@&G-I@IAICIDIEJhL/ZbZe^]b?eMg{i8(B")
- ("an" "$B@&I5IoIpIqIsJjJlK4K?KEKGL3L5L6L7L8L9LPU(V`W'XcXlYEZ[\>bHeYhOj]kX(B")
- ("anr" "$BKAKOK|L[`Tfn(B")
- ("ans" "$B2cJ-J8J9JZLHLdLfLgLhPnQfX$XpY_e$(B")
- ("anf" "$BJ*L^(B")
- ("al" "$B3aFfHxHyH}H~JFL#L$LBLoU;VKW9W=_>_Pdve[i/m?sHsSs`(B")
- ("als" "$BIRL1LeV1X>XbZa^#eNf+o\sf(B")
- ("alf" "$BL)L*\ikm(B")
- ("qkr" "$B9}GmGnGoGqGsGtGuGvGwGzG}JmKPKQP8YsYv\w^p`a`yg.p;qPr0rX(B")
- ("qks" "$BH<H>H?H@HBHCHIHJHKHLHRHSHWHXJ1JVJ[YBZ5\Q_/amcme+fvj6k'm*(B")
- ("qkf" "$BH-H.H/H0H1H4KVUVX#Y6Y{^_b"b$cAlmq{r1(B")
- ("qkd" "$BJoJ|J}K'K,K.K5K7K8K<K@KBKCKIR9RMUxVsWEWGZU[D\V^qb|cmg/gVhpiSkno%qwr7(B")
- ("qo" "$BGPGRGSGUGVGXGZG[G\G]GeGfGrKLT/WQX`YA^\_d`jfujj(B")
- ("qor" "$B3|GFGlGoGpGrGuI4PQVg[1`aa)cndjr0(B")
- ("qjs" "$BH(H?HKHMHQHVHYK]ZYZZ\h_/_xc)effLg8j[o@s=(B")
- ("qjf" "$BH2H3H5H6f/(B")
- ("qja" "$BHAHEHFHHHOK^[p^"c{gw(B")
- ("qjq" "$BK!`k(B")
- ("qur" "$BI{I}JHJIJJJKQ|Z&]!`za2i0j~m2mdospH(B")
- ("qus" "$BHPJQJTJUJXJ[MhQ~RFY(Y7ZN]repg&jokfmgn4n5qX(B")
- ("quf" "$BHcJDJLJMP(Z~sh(B")
- ("qud" "$BIBIMISJ:J;J<JAJBL_V"Vu[D\V_[c=cme3m~q6qX(B")
- ("qh" "$BD=F>IVIaIcIhJ]JbJcJdJeJnJsJuTHUoUph^jppfse(B")
- ("qhr" "$BIzI{I|I}I~J!J"J#J$KMKNKPR6Z=Z>\w]M_Ad9h*hyiui}j`m.mUmVqFrX(B")
- ("qhs" "$BK\TqlL(B")
- ("qhd" "$B0)HFIuJpJtJvJwJ{K%K)K*K/K1K@^"_bcsdK(B")
- ("qn" "$B3x4L<C@lG]H]ITIUIVIWIXIYIZI\I^I_I`IbIcIdIeIfIgIiIjIkIlImIoItIzI{I|J#J$JmJsK6P=PZPmP|RuS_T4UUU[Y8YC[T[U[o\T]M^pf)g%gYgxijk>lRlgmUn>n]rjrksOsPse(B")
- ("qnr" "$BKL(B")
- ("qns" "$BBNHRH[J,J.J/J0J1J2J3J4J5J6J7K[K_RfW][C]d]p_9`6a'a=cic|gnlL(B")
- ("qnf" "$BITJ&J'J(J)PGWJWgYD[,`Ac1q|sd(B")
- ("qnd" "$BC*J+JxJ~K2TDW:boe^(B")
- ("qmr" "$BR6(B")
- ("ql" "$B7%H[H\H]H^H_HaHbHcHeHfHgHjHkHlHnHpHqHsHtHwHzH{H|I!J(JOP#PlR8SgU&U9U{X`[,\R`Aa]acbNbgc0c>dDdcdue#f1fGg#g$g>hKhoitjkl"l@lAlLl]nAp)pBp[pfqorL(B")
- ("qls" "$BIFIKILINIOIPIQLFUMZ/]']R_@eoi@p~r&(B")
- ("qld" "$BI9QRQVQ_U2Xaf[qHqU(B")
- ("tk" "$B278%:3:6:;:=:>:?:@:p;E;G;H;J;K;L;M;N;U;W;[;`;b;d;e;l;r;t;v;w;{<%<-<K<L<M<N<O<P<R<S<U<X<Y?)?ZFcGAL&L,LcP/PXQPRSSNTzU0UmWP[O[h\L]y^/^V_C_S`:`[aBc+c,codAdBdCe/fSfhgRh5iImfnanmqJqKrBr^sM(B")
- ("tkr" "$B:o:s:w?tSVZK\N`#oK(B")
- ("tks" "$B;1;3;5;6;9;:;;;@IGQh[<]haMedlioYo[(B")
- ("tkf" "$B;&;';5hq(B")
- ("tka" "$B;0;2?9?yRTWD^zdsexf.glhujN(B")
- ("tkq" "$B07=BA^Yg]=_'_(p@q%(B")
- ("tkd" "$B7,8~=}=~>&>(>0>2>E>M>X>\>]>^>e>o>uAPASAVA[AjAzA|BlBmErF=FKH"MMRVUCURVyV{XS\k]O`.a3fFjak<ksrh(B")
- ("to" "$B:I<%^/_Sg(lPp{rT(B")
- ("tor" "$B:I:p:w?'T'XG\ecQi,(B")
- ("tod" "$B1y>J@7@8`Ocy(B")
- ("tid" "$Bq.(B")
- ("tj" "$B5P:T=k=l=n=o=p=q=r=s=v=x=y=z={?p@3@4@>@@@BAMD)L;P0ScTPTfVYY3ZFZGd.e1fTf]fqsUsk(B")
- ("tjr" "$B3c<.<M<a<b@J@K@N@O@P@YM<^Hb,hnirj.jinYnq(B")
- ("tjs" "$B4T@f@g@h@k@p@q@v@z@{@~A"A#A%A*A-A/A1A5A6A7C1OKQ"SEUIUvX:^/`!a}c8e@fAgUiElqpG(B")
- ("tjf" "$B1L6}7@@^@_@b@c@eC-FQSwYM\8]u^Xe(e2eJi-jxsv(B")
- ("tja" "$BA!A.UQZ{]@]S]Tcxeyezj9k~lXnu(B")
- ("tjq" "$B=&>D@"@]RYSqXRXwYpfcm:oRq#(B")
- ("tjd" "$B>J>k@+@-@.@1@9@;@<@?@CX9Zp`Od-fag)(B")
- ("tp" "$B:P:Y:{@$@*@G@b@vLcWB^/ih(B")
- ("th" "$B037+:i<D=j>$>%>,>.>/><>?>B>C>F>K>P>R>S>dA:AAABAGAIAJALA]A_AcAgA{B}I%R#SbU?XG[`\f][]{^j_O_va4d,dTg[hvi+i?l!lsmvn:n[nyp<ppq[rCrM(B")
- ("thr" "$B0@B+B.B/B0B3V$etkll^(B")
- ("ths" "$B;AB9B;B=C'(B")
- ("thf" "$BN(j+(B")
- ("thd" "$B>>>YAWAwW~[@^DcpgNiOkVo1psr"(B")
- ("thkf" "$B:~(B")
- ("tho" "$B:?:U:~;&;/^/_S`tbl(B")
- ("thl" "$B?h?jTj(B")
- ("tn" "$B<i<j<l<m<s<u<w<x<y<z<{<|<}=$=%=(=+=/=2=7=C=I?\?b?c?e?g?k?o?p?q?tA\AiB5C(C/D\JfLyM"N(RWS4SUSVT1ThU?V-X{YSZ@ZK]U]z^,^l^{_|`Yc.cOdXdoe5e7elf7f{g!g;h%h5hki.j-l(l3n.nHnsnxo5p$p+qrr$(B")
- ("tnr" "$B=G=H=I=J=L=M=N=OPhUY`GfihChr(B")
- ("tns" "$B=V=X=Y=[=\=]=^=_=b=c=d=f=gFkWNWv^-d#d$f|h&hsh|kNkYo>s((B")
- ("tnf" "$B=Q=RN(WuX|[2(B")
- ("tnd" "$B?r?shE(B")
- ("tnl" "$BPfPg^C(B")
- ("tmf" "$BI(`niMi|(B")
- ("tmq" "$B<>=&=,=1_<jyp.(B")
- ("tmd" "$B>!>#>5>:>g>h>jANFlGhP+QtR4[Fejj$o~(B")
- ("tl" "$B0;3A:|;&;H;O;S;T;\;k;m;n;x;{;~<(<,<E<F@'DsLpRQSASOS]UyU}W#W6WtYy`JfBg(gShahikkl5l9p{(B")
- ("tlr" "$B6t<0<1>}>~?!?"?#?)?*B)Uf_omHq3(B")
- ("tls" "$B:g?-?.?1?5?7?=?@?B?C?E?H?I?U?V?WC$GjH8RqS"UbXFY;Zo_~iglYpur`(B")
- ("tlf" "$B<:<<<=<BUi\Cj)(B")
- ("tla" "$B;2?3?4?<?D?R?SRTWZ\;]n_)_Dh~o=(B")
- ("tlq" "$B=&=:===BDTRARB_'_(a#cgdb(B")
- ("Tkd" "$BAPRV(B")
- ("Tl" "$B;a(B")
- ("dk" "$B0!0"0$2d2e2f2g2j2k2m2n368f;yP3Q;S(U.U4V6[s`Ha^h0jKk(kCn{o<rms!s"(B")
- ("dkr" "$B0!0-0.0/3Y3Z3\DWOLP3RxTAVVVjX(X3\[hUhVh`k`n?s-sys{(B")
- ("dks" "$B0B0D0F0H4_4c4f4g4i8APtZg]Vpzr=rnro(B")
- ("dkf" "$B060D1ZX~Y!]"]1]Fk@mBn!odpK(B")
- ("dka" "$B0C0E0G1^264`4b4dVIV^h?k^pws_sa(B")
- ("dkq" "$B0(052!3{R}TZ`@(B")
- ("dkd" "$B1{6D97Wi]J]vc?pYrs(B")
- ("do" "$B0%0&0'3336373eS1SNS`T<V=[#]7b-bJbYbvc(ghi=oup'pKpOq>(B")
- ("dor" "$B1U3[LkLqY/YUf~mCoup'(B")
- ("dod" "$BSm]/f"rts@(B")
- ("di" "$B<M<P<Y<c<fG8LiLjLkLlLmLnYh\?s,(B")
- ("dir" "$B0s<c<eLsLtLvU>Ynd`h`hji;oPs4s~(B")
- ("did" "$B>\>m>n>w>y>zMHMLMMMNMSM[M\PSTaUPWyZ7ZfZx\k_!_G_laZagaxc:cUjwl*nVqh(B")
- ("dj" "$B1w5y5z5{8f8lS0S}S~^Kq,qGrNsw(B")
- ("djr" "$B2/21225?M^\z(B")
- ("djs" "$B1a8@8AGgI'PpUA_adN(B")
- ("djf" "$B]"]1(B")
- ("dja" "$B1b1f264`4d8387Q7RLSnV^Vx^;f,ofqd(B")
- ("djq" "$B6H(B")
- ("dp" "$BWk]P(B")
- ("du" "$BFrG!M=M>M?M@MAMBP.]C^.aBe1gMgPh'i1ikl%q1(B")
- ("dur" "$B0W0h1V1X5U<MKrLrLuXdehinl#o`ogp?qcrH(B")
- ("dus" "$B0v1c1d1h1i1l1m1o1t8&8'<!A3FPFpG3J%RdSkU+U/WzYPYa\=])^'^2^7^=_]d'gCh/icj@l'(B")
- ("duf" "$B0v1Y1\@bG.ReSYsv(B")
- ("dua" "$B1^1j1k1p1v@wL-QG\ygfgroeqyr6rPsEsa(B")
- ("duq" "$B1^MUSq[!pT(B")
- ("dud" "$B1D1E1F1G1I1J1K1M1N1O1P1Q1S7J7^RiS[TJU$U%Zu\3\F^s_J`r`}`~ewj>lWn;pD(B")
- ("dP" "$B0e1C1H1L1T4"7X7];y<IM@MBP)P.PdQ;Q<St[*]u`IbKbOcRfJghi"i#i:iRjcl%l?p?rIsL(B")
- ("dh" "$B0-1(1*1w1x1|2(8^8`8a8b8c8d8g8h8mP~S*SKSSTITTT|U<UhWXX(XeZDZm_4_r_z`3`iiej(n+o2rbsg(B")
- ("dhr" "$B0$206L9vM`(B")
- ("dhs" "$B292:X2aicSi%i>jrr[r\(B")
- ("dhf" "$BQ:\Eg,(B")
- ("dhd" "$B2'MJTYW+a%a1a~c<hcp6s0(B")
- ("dhk" "$B0#122i3?4$7&RwSyc]hbiwkBkw(B")
- ("dhks" "$B08404K4P4X4a4e4hOPOROSU6^1_5iol2op(B")
- ("dhkf" "$B[)(B")
- ("dhkd" "$B1}2"2&9DUwWH[>]j(B")
- ("dho" "$B0#3?OARwbdiw(B")
- ("dhl" "$B0Z307(VLV[`Pbvi'r>(B")
- ("dy" "$B1z3Z6F9x>qD8F+LsMEMIMKMRMTMWMXMZQ'TpU-UKULVRVvWTWUY9YjYz\[\v]H_$`"`vcXc_eeh}j4kon-n3qAs8t!t#t$(B")
- ("dyr" "$B?+C+M]M_MaV;^ieUhljs(B")
- ("dyd" "$B23B{M&M/M0MCMFMGMOMPMQMVMYP\XJXY\Wa5f`gNill}o0ps(B")
- ("dn" "$B0r1&1'1)1*1+2$2%5m6h6r6s6v6w6x6y?uKtL`M$M%M'M+M4M9P2P}R^R_VJ\d]?]XaOb3c;c<d~foi9kpsIsz(B")
- ("dnr" "$B000jR(TT_4_z(B")
- ("dns" "$B0w1$1>1?1@Zt]N_pe"fQp(pq(B")
- ("dnf" "$B080S1516]5_q(B")
- ("dnd" "$B7'M:(B")
- ("dnjs" "$B080w1!1`1e1g1n1q1r1s1u3@4j85868;I2QMT$T(U6UcXE^S`)gkiojOkdmWn|ovp((B")
- ("dnjf" "$B1[7nXz[)denh(B")
- ("dnl" "$B010L0N0O0Q0R0S0V0Y0^0_0`0b0c161R4m56OAQ&S@SxT#Vk^O`*a_eOh<ivjLm{pjr2(B")
- ("db" "$B0T0]0d:y<t=@D\FSFjFyF}G(KnL{L|L}L~M!M"M#M(M)M*M-M.M1M2M3M5M6M7MDPRQASHS|U^ViXoYfYiZA\@^a^b`qahdre7g+gLhPi$iXj!j"j@k!k0kglzl|n'nXo+pds[sl(B")
- ("dbr" "$B0i4!FyS|]Zdx(B")
- ("dbs" "$B0t0}1<=aUzlVnJ(B")
- ("dbf" "$Bffrr(B")
- ("dbd" "$B=?M;e0(B")
- ("dms" "$B1#286dRaT-T7X@X[]V`;p,su(B")
- ("dmf" "$B255?(B")
- ("dma" "$B0{0|0~1"2;5?6cR_U5V@];pF(B")
- ("dmq" "$B5cM,M8X%(B")
- ("dmd" "$B1~5?6EBkGhXfg?j$m@mA(B")
- ("dml" "$B0M0U0X0a365#57595<5?5A5B5C5DODPaV=VTVXXt]:_q`Hbcc&ePg_nPq>(B")
- ("dl" "$B0;0J0K0P0W0[0\1B;\<$<)<*<X?)BBBfCPFRFsFvP1U)UuVaW3W4W^^&`ba-aXfggokHlFlHlIm_mnp0(B")
- ("dlr" "$B1WMbMcVXW5[;fDkjs2(B")
- ("dls" "$B0u0v0x0y0z1l?M?N?O?YFRG&G'LbP@PAQ9QcTEUTW.]e^P_]h!h;iNpW(B")
- ("dlf" "$B0l0m0n0oF|P!PETejRn_o-(B")
- ("dla" "$B1A?QDBG$G%L-U,WljSjT(B")
- ("dlq" "$B9~F{F~R]T)rl(B")
- ("dld" "$B>jP;QtUT(B")
- ("wk" "$B040q:4:8:::^:n;F;I;P;Q;R;Z;g;p;q;s;z;|<"<'<+<Q<T@F@QDSI&PwQ}RoR~UZWs^h_Ua*aSbDbEdggsh$hti4i5k9lGlZl`r8s:sn(B")
- ("wkr" "$B:n:r<[<]<^<_<`?]?}SpU"UeZQ[P_Zd+e?ginLs'(B")
- ("wks" "$B;7;DV#X}\"]L_%b7(B")
- ("wka" "$B;=;C@xC9V*_*_+d>dQjDlQo4(B")
- ("wkq" "$B;(AYA^C}SrYgd4p7p8(B")
- ("wkd" "$B>">)>->1>8>@>O>Q>U>_>c>f>l>s>uATAqArAuB!B"D"D%D2D9F5P?TGTVTcTyT}U#UrVQW2\u\~^J^y`-`/`R`xaog6gGgIg`h7hIi,i6jfl[l\o6rc(B")
- ("wo" "$B:F:H:K:M:R:X:[:\:_:`:b<F@FB8^hc7eRexl9lZsn(B")
- ("wod" "$BA9AdAhAyVDVl`'bUd7d8kZo#(B")
- ("wj" "$B093n5O<Q=m=s=t={=|A;A@CtCuCvCwCxCyDcDlDqE!EKGgH$LYPJRrW7Y3[A[R\:]|_L`2aTbicle*f8fTgsiWk:kIl7m0p3sr(B")
- ("wjr" "$B2.<Z<d@Q@R@S@V@W@XB1C`CdD$D_E&E(E)E*E+E,E-LvR*W/_U`?a{c!d{gii4k6mlmqmx(B")
- ("wjs" "$B<2=W@o@r@s@y@}A'A,A0A4B7C.DQE5E6E8E;E>E?EAEBECEDEEG{H*KjMdQ#QrR4RdSsT{UsV\W%X"X}Y%ZBZS]a^!_E`0a/aYaub!c"d%d5d?euf?fHg"lcm7mYm[nonto"oCp4pSp|q4qBs6s7t"(B")
- ("wjf" "$B=`@Z@[@^@`@a@dCbLERERGRzY#ZqZr^6cffOlkmE(B")
- ("wja" "$B0>@jA2E9E@FQG4V3dRpAsVsZ(B")
- ("wjq" "$B@\D3XR\&\7\D]~^XfcrW(B")
- ("wjd" "$B0f;*>=>Z>`>p>t>{@,@/@0@5@:@EBGCzD.D:DbDdDeDgDhDjDmDnDrDuDvDwDxDzD{E"E#E$FTKoLwMdP'RZVlY]ZW[l^F^[a6aKbMcWf^hGj:mwn&nDnKoFp=pP(B")
- ("wp" "$B1-:O:Q:W:]:^=t=|@)@=@F@^BhBiBjDiDkDoDpDsDtD}P_Q1Q}Z+Zq_;bDbEbIgAi5lZm3pIpmpnsn(B")
- ("wh" "$B3v7+:x;4<D=u><>H>[>rA;A<ADAEAFAHAKA`AaAbAeAfAgAlAtAxB$BdC{C|D$D&D+D,D/D4D7D8D;DUD^D_D`FXGBH%POPYS^SdWIXNXTXjY2Y4Zj[j[t\'\*_6`,bic/cGcZc^cud|e6f-fTfrg]iskGkPl!ldm/oXp:qt(B")
- ("whr" "$BB-B2dHhwo7(B")
- ("whs" "$BB:YO(B")
- ("whf" "$B@[B4OHR@`L(B")
- ("whd" "$B<o<p=!=*=>=D>a>bAnI"P:WOXQ\#\$\b^JdpeTj*l{m'm)oG(B")
- ("whk" "$B:4:8:A:B:C(B")
- ("whl" "$B:a(B")
- ("wy" "$Bn[(B")
- ("wn" "$B3t:n<g<k<n<r<v<~=#='=.=5=;=K?_AUAvB-B2ChCkClCmCpCqCrCsD4D]I*L+P&PMPvQ2QISUW$ZlaFaGcGdVdZe!eBfthwiakOlam4mTn$oIsG(B")
- ("wnr" "$B4!C]dx(B")
- ("wns" "$B1==S=T=W=Y=`=c=eFVH;KpQ.RETSWvX"X6^4_=b/jAm-mu(B")
- ("wnd" "$B=0=ECfCg(B")
- ("wmr" "$BB(B1(B")
- ("wmf" "$B6{(B")
- ("wma" "$BWc(B")
- ("wmq" "$B=4=AIxM,\7eI(B")
- ("wmd" "$B3(9y>I>Z>xA9A=A>A}A~B#D'YN\t__kz(B")
- ("wl" "$B4t5@;V;X;Y;];^;_;c;f;h;i;j;o;}<1<A<G?%B~CNCOCRCSCXCYDRDlDqEVG7S!T.TMVcW7Yu[L]ma\c-fMfsgSk:lDlSlflym5mIn/owr?s9(B")
- ("wlr" "$B?%?&D>SDcFcM(B")
- ("wls" "$B?0?6?8?:?>???A?G?J?L?P?T?XC$DADCDDDEE6FxKyPVSQZi]I_~`_a+a;b8bCbSeVgKhmjWlcmGo/(B")
- ("wlf" "$B<8<;<@<ACaCbE3IHLEPERzSDT9Ve[_fOg4g5lDlkmE(B")
- ("wla" "$BD?ZPnErq(B")
- ("wlq" "$B<9=4=8=AeI(B")
- ("wld" "$B@!D'D(_-(B")
- ("ck" "$B3n:!:5:7:9:<<V<W<ZOMPNSMV+VMY-Ym[3\Lbxd4gsm"n`(B")
- ("ckr" "$B:q:u:x@NB*ByCeCxY'eSm0oXsqsx(B")
- ("cks" "$B;8;<;>;?;A@qRUZ9`&cbdlesl-lUo4oSoTqB(B")
- ("ckf" "$B;!;";$;%QkY)`\e'(B")
- ("cka" "$B;2;4;BA2Q(Q)RTTOVPVZXNXOXPXrXs\ackk{k|l)l+q](B")
- ("ckd" "$B>'>+>3>4>;>T?zAOARAdAkAsD*D1H+PiQlRRX0XHYoZHZd^E^k^}`KalcYgZm#r.(B")
- ("co" "$B:9:D:L:N:S:V:W:Z<F@UMi\Me=hql8n`pV(B")
- ("cor" "$B:p:t:u:v:}@UA<QFSTY>[Pbyd)dG(B")
- ("cj" "$B:J=h@(A@Q]X.^Ge1hF(B")
- ("cjr" "$B;I<\@I@L@M@TD=QqRhWFZ3^~akinljm$m(m6p"s5(B")
- ("cjs" "$B0+6N6z6|;=@i@n@q@t@u@|A$A&A(A)A+C)E7PBPjQdSCV_Z#[a\9^I^Y_Ea$chh(lMlxoqotph(B")
- ("cjf" "$BDVE/E0E1E2E4FLFmS5V%YZmPnno$oDoEq8(B")
- ("cja" "$B84@mE:E<Q!W[Ww\a\y]~b]dSdUd^d_j9k-k[k~(B")
- ("cjq" "$B>*>9>vC}D!D-D5E=aHaIaJbLjymLmM(B")
- ("cjd" "$B;*;,@2@6@A@DD#D0W,W-fehGiq(B")
- ("cp" "$B@ZBNBXBZBaDVDfDyD|D~FeFmSFSiSjYZ\<^8^|bIbfh\hxjim<m=n*pLqsqv(B")
- ("ch" "$B7-=i>%>6>7>A>G>K>L>S>V>d?]A?ACApD6D8ICQvR#R+V%V9X!X7X^[B\%^W_VcDggkWl:mknLndqzs<ss(B")
- ("chr" "$B<q>|?$?(?tB%B0SvV$ZKb`badHifk=m1o7qq(B")
- ("chs" "$B1%@#B<WVn7(B")
- ("chd" "$B=>=FAQAZAmAoC~DMF4G,N5N6P:PxR2WOWdX;eAeTfb(B")
- ("chl" "$B:E:GVCYt\c^/(B")
- ("cn" "$B0,1/3b<h<q="=%=)=-=6=9=P?[?d?m?n?u?v?wAFC\CjDFDGDHDIDJGkOISBU7U9VdX/YXYY\6\d^Wa,b2cTd6dHeWf\gmhZn@p%p2pcqWqerUsF(B")
- ("cnr" "$B1/<3<4=3=K=LC[C\C^C_C`M.\egXm&(B")
- ("cns" "$B=UDXrV(B")
- ("cnf" "$B=P[2sY(B")
- ("cnd" "$B2-=<=F>WCiCnCoMCQU`>g^j5(B")
- ("cnp" "$BX,X-X8aahDlT(B")
- ("cnl" "$B<h<q="=-?a?f?i?l@HOIS\U8X8Ye\r]^aafCf\g9hDk9nMqe(B")
- ("cmr" "$BB&B'B,D=P<X<Z`(B")
- ("cms" "$Bsp(B")
- ("cma" "$Boo(B")
- ("cmd" "$BA=A>AX(B")
- ("cl" "$B:7:9;u<#<&>}?"?%CMCQCTCUCVCWCZD'D>FePLRHRNSPTiV5VbVpVz[i_ua7a?awbtcPcze#e>eLfWiPjul8lemOo!p5r5rKrvrwscso(B")
- ("clr" "$BB'B,D<R,RNVzX<ZE(B")
- ("cls" "$B?Fk%sp(B")
- ("clf" "$B<7<?(B")
- ("cla" "$B5N?/?2?;?KC9D@KmUjWZZP\;o*o,ooqT(B")
- ("clq" "$Bj/(B")
- ("cld" "$B>NGicJjYqU(B")
- ("cho" "$B2wTo`V(B")
- ("xk" "$B<XB>BBBCBDBEBFBGBHBIBJBKBLBMCSOMPIS#TXU`YYYe[4\s]}g!m>qLrx(B")
- ("xkr" "$BBnBoBqBsBtBuBvBwBxByE'EYPkS6Y>[Q_7ner0(B")
- ("xks" "$BBMC2C3C7C:C>CBCFF]FgW<X_Z:]QjX(B")
- ("xkf" "$BC%C&(B")
- ("xka" "$BC5C?b>lE(B")
- ("xkq" "$BEcEkYr\PpaperW(B")
- ("xkd" "$BEfErE|F"Vfb;j#(B")
- ("xo" "$B@GB@BABUBVBYB[B]BaBfBgG=KXLaQ<\(cze)ihkHq&qM(B")
- ("xor" "$BBpBrBtZ$_7(B")
- ("xh" "$BEFEGEQEZEeF$Q=h9(B")
- ("xhs" "$Bjt(B")
- ("xhd" "$B23DKDLE{E}HuWxXV(B")
- ("xhl" "$B?dBOB\B`DHDIDJFXjtpx(B")
- ("xn" "$BEJEjF)F.L{Pye5o+qmr,(B")
- ("xmr" "$BB_FCXW(B")
- ("vk" "$B?|GCGDGEGGGHGIGJGKGLGNHmHvT3WfZ4[1`(``bncvfRg8hJh]jZllox(B")
- ("vks" "$B:d:eH=HDHGHNR!]ra"ng(B")
- ("vkf" "$B;+H,R\[5n\(B")
- ("vo" "$B143-GIGTGWGXG\GbH4HmI#PPUVX#Y6ZT[1]o`cp>(B")
- ("vod" "$BC*K#K5KDW:WEZU_0b|e^(B")
- ("vir" "$BX?(B")
- ("vus" "$BJ?JPJRJSJTJWJXJ\Y(fIgyi~jokfqY(B")
- ("vua" "$BlJ(B")
- ("vud" "$BDZI>IMJ?Wh^$bogyhLr9(B")
- ("vP" "$B3AGQGYJ>J@JCJDJEKJUJVrW&ZIZMasi0qo(B")
- ("vh" "$B1:3s3wGxGzI[I]IrJ^J_J`JaJqJyJzK"K$K&K+K0K=R1R5R7RvS.T5YF[T_F_\aWb.f}gTgzj\jqmynppRq0q}r:rDsR(B")
- ("vhr" "$BGxGzI}K=_F(B")
- ("vy" "$B<]I6I7I8I:I;I<I=I?QwUEXX]Ke]q(q)q*q_qjqurd(B")
- ("vns" "$BJ,(B")
- ("vna" "$BIJcHcI(B")
- ("vnd" "$BIvIwK-afkel4q$qH(B")
- ("vb" "$BI7(B")
- ("vl" "$BH`HdHhHiHmHoHrllmdox(B")
- ("vlf" "$B2^HfHgI$I%I+I,I-I.J'J)PGYDdJkvm+s+(B")
- ("vlq" "$BI/I}K3^"(B")
- ("gk" "$B2<2?2F2O2Y2\2b2l3E<6ROR`V|^Q`leKf!kEl.n"o(rQ(B")
- ("gkr" "$B2)3X5TDaT[U\U]^A`Bajkbl;s?(B")
- ("gks" "$B4(4@4A4M4W4Z8B:(UFUGW{Y*YRZ][e_K`Cb*f'n8qSqlsm(B")
- ("gkf" "$B323d3e3mR$bRiys\(B")
- ("gka" "$B4O4Y4^H!MtQbRyS2S?VH]#^>eHh1n8nro|pwq2rRsD(B")
- ("gkq" "$B389^9gH:RnR}^eb4b5b6hdonr{(B")
- ("gkd" "$B7e9+91939:9A9R9T9_9`FzP6PDRbWqe}fjobprr*(B")
- ("go" "$B0g2r3#3$3*3/31323:3<:zPsT6TnTxUXW(Xh\4i&j7k;k_n0nOqO(B")
- ("gor" "$B3/3Kbkk*mJ(B")
- ("god" "$B0I8v9,9Te.jbr}(B")
- ("gid" "$B5}6?6A6B8~9aSlq.(B")
- ("gj" "$B135u5vTR[[]A^w(B")
- ("gjs" "$B7{8%8.YW`[(B")
- ("gjf" "$B]<iyj8(B")
- ("gja" "$B8183VUp*qd(B")
- ("gur" "$B3E3R3W7CTu^)r+(B")
- ("gus" "$B0<7|8)8+8-82898<8=8>8?9`JGPWRl^-aRbAeQidjJnkp}(B")
- ("guf" "$B7j7l>iJGLRUSk#pv(B")
- ("gua" "$B7y(B")
- ("guq" "$B0A3p6"6(6.64696<KKOFTsV7XDYQ^5`Ed)d:h2nwo}p!(B")
- ("gud" "$B3>5|7:7;7?7A7U7V7e9UTk_W_X`rfzj%mj(B")
- ("gP" "$B7E7RQBR>TxWBX*b=c4l~nQp^(B")
- ("gh" "$B3O8C8F8L8M8P8Q8R8U8W8[8_8c8j8n8o9%9@9f9h9j9k:c;)<JD[QTTdW`Y&Z_Zn\5]]]l^v^w`7`ha!b(b+hYhfiHiKizn=o.q7(B")
- ("ghr" "$B0?9s9tOGUeZO(B")
- ("ghs" "$B:':*:+:.:2[~\!^U^g_c`m(B")
- ("ghf" "$B3K9z9{]Gcts3(B")
- ("ghq" "$B3f(B")
- ("ghd" "$B909?9H9cR|]g]wkAobr*(B")
- ("ghk" "$B2=2P2R2S2V2Z2_2h3q3r7$CtOBOCS;V<aAdqo&(B")
- ("ghkr" "$B3H3M3N3OZ2Z<ayb_j?p9(B")
- ("ghks" "$B4-45494<4?4D4T4]88OKT(TvUaUnXu]D^R^S_eb*bAbbl,l6oBqir%r](B")
- ("ghkf" "$B1[3h3j;#`Qbwi]l/ohoi(B")
- ("ghkd" "$B2+677;92989D9SKZQWQ`WSWrX5Zh^T^f_jd;dPfki{n#p&rS(B")
- ("gho" "$B2h7S`VaA(B")
- ("ghl" "$B2q2s2u2v2y2z2{3"3%=ZI0OEPrQER;TUWKXg[X\G^Neig:h"i'i\kKkRmorf(B")
- ("ghlr" "$B2h3D3MaA(B")
- ("ghld" "$B2#909U9li*mDo)sT(B")
- ("gy" "$B6G8s8z9;9Z:hP{S,SeSoZCZ|[f^B_^`+qaqb(B")
- ("gn" "$B0r5`8e8t8u8|9!9"PHRcSLSR^A_h`Md<kMmp(B")
- ("gns" "$B7.7071FkR._m_nhXnU(B")
- ("gnd" "$Bi*(B")
- ("gnjs" "$B3~7vCHX:Zwh@kcl,(B")
- ("gnp" "$BCnRCS<TL_{(B")
- ("gnl" "$B4x5+51WCY&Zv]`ka(B")
- ("gb" "$B5Y7H7MC\Z8_^iLl<(B")
- ("gbr" "$BC\(B")
- ("gbf" "$BWukys;(B")
- ("gbd" "$B6$6'6;R3Wo^((B")
- ("gmr" "$B9un^(B")
- ("gms" "$B6U:/WLWWYWnW(B")
- ("gmf" "$B5%5IKxV(k?(B")
- ("gma" "$B6V7g(B")
- ("gmq" "$B5[]@^*b%fE(B")
- ("gmd" "$B6=Fz(B")
- ("gml" "$B4n4r4u5)5:5>I1Q%RzS)S`XAXZY&Zk[']8_f_g_t`!`:c6f<nZrF(B")
- ("glf" "$B5Merk#pvs\(B")
- ("unknown" "$B4#<5DNFJFdFuJ=KsL]QeRIRpS&S9SuS{T*T+T8T:T>TBTCTKTNTQTWT\T_UNU~V&V,V-V.V/V0V2V4V8VNW;WjWnWpY0YKY^Z1Zs[=[b[n\)\-\.\/\0\1\O\S\j\n\o\p\q\x]&]6]B]i^<^L^c_&_1`<a:a<a>b<bBbXbmbpbsc%c5cNcdc}d&d1d=dIdLdYdddfdhdte9eaebemenevf$g3g\h4h6hHhMhWhhiFi[ibj,jQj^jmk\lCmZmhmimzn%n}o'oZo]p#p-pXp]p`q;qIqRr;r@rGrOrZr_rer~s#s%(B"))
+ ("rk" "榎仮伽価佳加可嘉嫁家暇架歌珂稼苛茄迦駕街袈个假價呵哥枷柯珈痂笳舸葭訶謌賈跏軻")
+ ("rkr" "各格殻覚角較閣却脚刻塙卻咯埆恪愨擱桷殼狢覺貉鬥")
+ ("rks" "斡乾侃刊姦干幹澗看竿簡肝間墾懇艮菅奸慳揀杆柬栞桿狠癇稈繝艱諫鶫齦")
+ ("rkf" "介喝渇葛褐掲丐曷碣竭羯蝎鞨頡")
+ ("rka" "勘堪感憾敢柑甘監鑑欠鹸減紺凵坎坩嵌戡撼橄歉淦疳瞰緘蚶轗酣鑒龕")
+ ("rkq" "押蓋甲合岬匣盖胛閘")
+ ("rkd" "岡橿強彊慶康控江糠綱腔講鋼降剛虹亢僵啌姜崗慷扛杠棡疆矼絳繦羌薑襁跫鱇")
+ ("ro" "佳箇介解改皆芥開階凱咳慨概蓋鎧個丐个价剴愾懈揩楷漑疥盖觧")
+ ("ror" "客喀")
+ ("rod" "坑更粳羹羮鏗")
+ ("ri" "茄")
+ ("rir" "醵")
+ ("rj" "去居巨拒拠渠距鋸車据裾俥倨墟據擧舉欅炬秬筥苣踞遽醵鉅")
+ ("rjs" "乾巾件健建鍵愆搴腱虔謇蹇騫")
+ ("rjf" "渇掲傑乞担桝偈杰桀气竭")
+ ("rja" "柑倹剣検鹸儉劍劔劒剱檢瞼臉黔")
+ ("rjq" "笈怯劫拾刧")
+ ("rp" "憩掲偈憇碣")
+ ("rur" "仮格隔革撃激假挌檄膈茖覡闃骼鬲鴃鵙")
+ ("rus" "樫鰹堅牽犬絹肩見遣縛繭鑓俔幵悁枅狷甄筧羂譴鵑")
+ ("ruf" "桔契決潔結訣孟决抉拮挈缺髻")
+ ("rua" "鎌兼謙慊拑歉箝蒹鉗")
+ ("ruq" "恰頬慊鋏")
+ ("rud" "京競卿境鏡驚傾径慶敬景経茎荊警軽頚鯨庚更梗硬耕頃亰竸冂冏剄勁勍哽徑憬檠煢瓊畊痙磬絅經綮耿脛莖謦輕逕竟頸黥")
+ ("rP" "戒械界階季係啓契桂渓稽系継繋計鶏堺届屆彑悸枅溪畍癸禊笄綮繼薊誡谿髻鷄")
+ ("rh" "苦古固姑孤庫故枯袴股菰鈷雇顧鼓稿考膏高拷告皐縞尻叩藁估凅刳呱攷敲杲柧桍栲槁槹沽痼皋睾瞽稾箍罟羔胯蛄蠱觚詁誥賈辜錮靠鴣鵁皷")
+ ("rhr" "曲告穀酷鵠谷硲哭斛梏槲轂髷")
+ ("rhs" "困坤昆梱混壼崑悃棍滾菎褌鯀鯤鶤")
+ ("rhf" "滑骨榾汨鶻")
+ ("rhd" "供共恐恭空公功孔工控攻貢倥廾拱椌槓箜蚣蛩蛬跫鞏")
+ ("rhk" "瓜寡科果菓課過袴誇跨鍋堝夥夸戈胯萪蝌裹踝顆")
+ ("rhkr" "廓郭擴攫椁槨癨矍钁霍")
+ ("rhks" "冠官寛慣棺款潅管莞観貫関館舘串菅丱冦毋灌盥綸綰罐觀鑵關鸛")
+ ("rhkf" "括活筈桧刮檜聒")
+ ("rhkd" "拡匡狂光広鉱砿壙廣擴曠昿框洸礦筐筺絋絖胱誑鑛")
+ ("rho" "掛卦罫咼戈挂枴褂")
+ ("rhl" "会塊壊怪恢拐魁乖傀壞恠愧槐瑰詼")
+ ("rhlr" "膕馘")
+ ("rhld" "宏紘肱轟浤軣鍠")
+ ("ry" "撹覚較噛糾僑叫喬教橋矯蕎交佼孝巧校絞郊酵鮫招咬嬌攪敲橇澆狡皎磽窖翹膠蛟轎釖餃驕驍")
+ ("rn" "臼厩欧殴鴎鈎亀丘久仇救求灸球究旧拒九倶句区狗玖矩躯駆駈駒具粂勾口垢拘構溝購叩韮鳩釦傴冓劬區咎嘔媾嫗寇嶇廐廏怐惧懼扣搆柩枸歐毆毬甌疚瞿窶篝舅舊苟蒟蚯衢裘覯詬謳逑遘邱鉤韭颶馗驅鬮齲龜")
+ ("rnr" "掬菊鞠局麹国囗國椈鬻鞫跼")
+ ("rns" "君群軍郡桾皸皹窘羣裙")
+ ("rnf" "屈掘窟堀倔厥崛")
+ ("rnd" "宮弓窮穹躬")
+ ("rnjs" "勧巻挙倦券圏拳捲権劵勸卷圈惓椦權眷綣蜷顴")
+ ("rnjf" "掘蕨亅厥獗蹶闕")
+ ("rnp" "机帰軌凧潰几匱椢櫃歸皈簣臾詭跪蹶餽饋")
+ ("rnl" "帰貴鬼亀喟椢歸皈龜")
+ ("rnlr" "掴幗")
+ ("rb" "葵窺規糾叫九圭珪頃槻奎揆摎樛癸硅竅糺繆袿赳逵閨馗鬮")
+ ("rbs" "亀均菌箘鈞麕龜")
+ ("rbf" "橘")
+ ("rmr" "可革極劇戟隙克亟剋尅屐棘蕀郤")
+ ("rms" "僅勤巾斤筋芹謹近根懃槿瑾矜菫覲釿饉")
+ ("rmf" "契訖")
+ ("rma" "錦琴禁禽衿襟金檎今噤擒衾黔")
+ ("rmq" "扱及急汲笈級給岌")
+ ("rmd" "恒肯亙亘兢恆矜")
+ ("rl" "磯企伎器基奇寄岐幾忌旗既期棋棄機気汽畿祈紀記起飢騎妓技欺祇居祁己碁乞崎埼碕示其肌鰭箕亟俟冀剞嗜噐圻竒嵜弃掎旡曁朞杞枳棊榿气氣沂淇畸祺稘綺羈羇耆覊覬譏豈跂饑騏驥鮨麒")
+ ("rlr" "喫")
+ ("rls" "緊")
+ ("rlf" "吉桔詰佶拮")
+ ("rla" "金")
+ ("Rlr" "喫")
+ ("sk" "奈那難儺娜懦扨拏拿梛糯")
+ ("skr" "諾")
+ ("sks" "暖難攤煖赧")
+ ("skf" "捺捏涅")
+ ("ska" "男南楠喃娚遖")
+ ("skq" "納衲")
+ ("skd" "嚢娘曩")
+ ("so" "耐奈内匂乃廼能迺")
+ ("sid" "嬢孃")
+ ("su" "女拏拿茹")
+ ("sus" "年撚碾輾")
+ ("suf" "捏涅")
+ ("sua" "念恬拈棯")
+ ("suq" "摂捻攝躡鑷")
+ ("sud" "寧嚀濘獰聹")
+ ("sP" "禰昵")
+ ("sh" "努奴怒脳呶孥帑弩瑙碯腦臑駑")
+ ("shd" "濃膿農儂")
+ ("shk" "雫")
+ ("shl" "悩脳惱腦餒")
+ ("sy" "溺尿嫋撓橈鐃閙鬧")
+ ("sn" "耨")
+ ("sns" "嫩")
+ ("snf" "吶肭訥")
+ ("sb" "紐忸狃鈕")
+ ("sbr" "忸衄衂")
+ ("smd" "能")
+ ("sl" "泥尼禰祢怩濔瀰膩")
+ ("slr" "溺匿")
+ ("slf" "尼怩昵")
+ ("sla" "賃恁")
+ ("ek" "多大茶夛")
+ ("eks" "円但丹単担旦短端箪胆蛋鍛団壇断檀段椴敦亶單團彖愽慱斷槫湍猯疸緞葮蜑袒襌褝鄲鶉")
+ ("ekf" "達咄妲怛撻燵獺逹闥靼韃")
+ ("eka" "担淡湛耽談曇啖啗壜憺擔毯潭澹痰眈膽蕁覃譚餤")
+ ("ekq" "沓搭答踏剳荅")
+ ("ekd" "党唐塘当糖堂撞儻幢档棠溏當瞠礑螳蟷襠鐺黨")
+ ("eo" "碓対岱帯待戴袋貸隊黛代大敦垈對帶擡抬玳臺薹鐓隶")
+ ("ejr" "徳悳")
+ ("eh" "稲図挑跳堵塗屠徒渡菟賭途都鍍度倒刀島嶋悼桃梼盗淘涛祷到逃陶導萄道叨圖嶌掏掉搗擣朷檮棹櫂盜濤滔睹稻絛綢綯纛荼莵覩跿蹈迯闍韜饕")
+ ("ehr" "竺涜督禿篤毒独読牘犢獨纛讀髑黷")
+ ("ehs" "純噸惇敦沌豚遁頓暾燉瓲遯飩")
+ ("ehf" "突頓咄柮")
+ ("ehd" "諌桐冬凍東棟董働動同憧洞瞳童胴銅僮橦潼疼粡艟苳鮗鶇鼕")
+ ("en" "吋兜逗斗杜土痘豆頭読亠抖竇肚荳蚪蠹蠧讀酘鬥")
+ ("ens" "屯遁頓鈍臀遯")
+ ("emr" "得")
+ ("emd" "登灯燈等藤謄鐙騰嶝橙滕疼磴籐籘縢")
+ ("fk" "刺羅螺裸喇懶瘰癩蘿邏鑼陏騾")
+ ("fkr" "格楽洛絡落酪咯樂烙犖珞駱")
+ ("fks" "乱卵欄蘭亂嬾欒瀾燗爛襴鑾闌鸞")
+ ("fkf" "剌喇埒埓糲辣")
+ ("fka" "嵐濫藍覧儖婪攬欖籃繿纜襤覽醂")
+ ("fkq" "摺蝋拉柆臘臈鑞")
+ ("fkd" "滝瀧廊朗榔浪狼郎朖琅瑯莨螂跟踉")
+ ("fo" "來徠")
+ ("fod" "冷")
+ ("fir" "掠略擽畧")
+ ("fid" "椋掠亮両梁涼糧良諒量倆兩凉喨粱粮裲跟踉輛輌魎")
+ ("fu" "芦蛎砺麿侶慮旅励麗呂録儷勵唳廬梠櫚犂犁癘礪糲絽綟膂臚茘藜蘆蠣蠡鑢閭驢驪")
+ ("fur" "力暦歴屶朸櫟檪櫪瀝癧礫轢轣靂鬲")
+ ("fus" "怜零恋憐漣煉練聯蓮連錬嗹戀揀攣楝聨臠輦鏈鰊")
+ ("fuf" "列劣烈裂冽捩洌")
+ ("fua" "鎌廉簾匳奩斂濂瀲")
+ ("fuq" "猟獵鬣")
+ ("fud" "領令伶嶺怜玲苓鈴零霊齢囹櫺澪羚聆蛉靈鴒齡")
+ ("fP" "豊例礼隷禮茘醴隸鱧")
+ ("fh" "芦鷺櫨蕗虜魯櫓炉賂路露労牢老勞咾撈枦滷潦濾瀘爐癆盧艪艫舮蘆輅轤鑪鈩顱驢鱸鹵")
+ ("fhr" "角漉鹿谷緑麓禄録梺碌祿轆")
+ ("fhs" "論淪")
+ ("fhd" "滝瀧竜龍弄篭聾哢垰壟朧槞瓏籠蘢隴")
+ ("fhl" "瀬頼雷塁賂儡壘擂櫑癩磊籟罍耒蕾藾誄賚")
+ ("fy" "了僚寮料療瞭遼寥廖撩暸燎繚聊蓼醪鐐鷯")
+ ("fyd" "竜龍蘢")
+ ("fn" "屡涙累婁楼漏僂樓犂犁瘻簍縷縲螻褸鏤陋髏")
+ ("fnl" "涙泪")
+ ("fb" "謬柳劉流溜琉留硫瑠塁累類勠嚠壘廖旒榴泪瀏璢瘤繆縲茆鉚鏐霤餾")
+ ("fbr" "陸六勠戮蓼")
+ ("fbs" "倫輪論侖崙崘棆淪綸")
+ ("fbf" "栗律率葎慄篥")
+ ("fbd" "隆嶐窿")
+ ("fmr" "肋仂勒")
+ ("fma" "凛廩懍菻")
+ ("fmd" "綾菱睦凌稜陵崚楞蔆薐")
+ ("fl" "浬鯉糎狸提哩利吏履李梨理璃痢裏裡里離厘麗俚俐悧罹漓犂犁竰籬羸莅莉蜊蠡詈貍釐驪魑鯏黐")
+ ("fls" "燐隣鱗麟吝悋藺躙躪鄰")
+ ("fla" "林淋琳臨痳霖")
+ ("flq" "笠立粒苙")
+ ("ak" "罵馬摩磨魔麻嘛媽麼瑪痲碼蟇蟆")
+ ("akr" "漠莫貌幕膜摸寞藐")
+ ("aks" "鰻挽晩蛮娩万慢満漫蔓湾卍曼巒幔彎弯懣滿灣瞞縵萬蠻謾蹣輓鏝饅鬘")
+ ("akf" "抹末沫眛秣茉襪靺韈")
+ ("akd" "亡忘忙望妄網惘网罔芒茫莽蠎蟒鋩魍")
+ ("ao" "罵媒梅楳煤買売呆某埋妹昧枚毎魅寐瑁苺莓賣邁霾")
+ ("aor" "莫麦百脈獏脉貊貘陌驀麥")
+ ("aod" "虻萌盟猛盲儚氓甍萠黽")
+ ("aur" "冖冪幎汨羃覓")
+ ("aus" "勉眠免棉綿緬面麺俛冕宀湎眄瞑緜麪")
+ ("auf" "蔑滅")
+ ("aud" "皿冥名命明銘鳴暝榠溟瞑茗螟酩黽")
+ ("aP" "袂")
+ ("ah" "姥牡茅莫侮募墓慕暮母帽某冒謀貌鉾膜粍牟矛摸模毛耗姆旄獏瑁瓱皃眸竓糢耄冐莽謨髦鴾")
+ ("ahr" "匹牧穆木目凩朷沐繆苜鶩")
+ ("ahf" "没勿歿沒")
+ ("ahd" "夢蒙冢梦曚朦檬濛矇艨")
+ ("ay" "卯畝猫廟描秒苗錨墓妙杳昴渺眇緲茆藐")
+ ("an" "畝謬撫武舞蕪戊母亡某謀貿務無牟矛霧鵡茂姆巫廡憮懋拇无楙眸繆莽袤誣")
+ ("anr" "冒墨万黙默冐")
+ ("ans" "蚊吻文聞娩免問紋門匁們刎悗懣捫紊")
+ ("anf" "物勿")
+ ("al" "梶謎尾微眉美米味未迷弥媚嵋弭彌濔瀰糜縻薇躾麋靡黴")
+ ("als" "敏民悶岷愍憫旻泯緡罠閔黽")
+ ("alf" "密蜜樒謐")
+ ("qkr" "狛剥博拍泊箔粕舶薄迫爆駁簿撲朴亳搏摶樸溥珀璞膊雹駮魄鰒")
+ ("qks" "伴半反叛搬斑班畔繁般頒飯盤磐扮返弁拌攀槃潘瘢竝絆胖蟠襷蹣")
+ ("qkf" "鉢溌発醗髪抜勃孛悖拔撥渤癶發秡跋髮魃")
+ ("qkd" "倣放方芳訪邦傍坊妨房棒紡肪防匚厖尨幇彭彷旁枋榜滂磅竝膀舫蒡蚌謗錺髣魴")
+ ("qo" "俳拝排杯盃背輩配倍培賠陪白北坏徘憊拜湃焙琲胚裴")
+ ("qor" "栢覇伯拍柏白舶百佰帛霸珀瓸竡粨魄")
+ ("qjs" "幡反繁藩煩番蕃翻旛旙樊潘燔礬繙飜膰袢鐇鷭")
+ ("qjf" "伐罰筏閥罸")
+ ("qja" "帆氾汎犯範凡梵泛笵范")
+ ("qjq" "法琺")
+ ("qur" "副幅僻壁癖碧劈擘檗璧甓薜襞躄辟闢霹")
+ ("qus" "釆変編辺便弁来辨卞扁抃變汳辮胼褊諞辯邊邉駢")
+ ("quf" "批閉別瞥丿暼鼈")
+ ("qud" "病浜瓶丙併兵柄並餅屏并枋榜炳秉竝絣迸餠駢")
+ ("qh" "捗鴇埠普父譜保歩甫補輔菩報宝堡寶寳葆褓鞴黼")
+ ("qhr" "伏副復幅服福腹複覆僕卜撲匐攴攵樸殕濮箙茯蔔蝠蝮袱蹼輻輹馥鰒")
+ ("qhs" "本夲賁")
+ ("qhd" "逢汎封俸奉峰峯捧縫蓬蜂鋒鳳棒泛烽笂篷")
+ ("qn" "釜缶蔀専培否不付埠夫婦富冨府扶敷斧浮父符腐膚芙負賦赴阜附撫部伏副復複覆簿報剖仆俘俯傅咐嘸坿孚孵抔拊枹柎桴榑殕溥罘腑艀苻蜉訃賻趺輻郛釡鳧鳬麩麸黼")
+ ("qnr" "北")
+ ("qns" "体頒匪分噴墳憤扮焚奮粉糞紛雰奔盆吩忿枌氛汾濆犇瓰畚竕笨芬賁")
+ ("qnf" "不弗払沸仏佛彿怫拂朏狒祓髴黻")
+ ("qnd" "棚鮒崩朋鵬堋弸硼繃")
+ ("qmr" "匐")
+ ("ql" "轡匪卑否妃庇悲扉批斐比泌碑秘緋肥誹費非飛備枇毘琵鼻沸箆丕俾匕嚊妣婢屁憊朏榧狒痞痺睥砒祕秕篦粃糒紕羆翡脾腓臂菲蓖蜚裨譬貔豼賁贔鄙隗霏鞁鞴髀鯡")
+ ("qls" "鋲彬斌瀕貧賓頻牝嬪擯檳殯濱繽蘋顰鬢")
+ ("qld" "氷冫冰凭娉憑聘馮騁")
+ ("tk" "卸献些唆沙砂詐鎖裟咋仕伺使司史嗣四士師思斯死獅私糸詞賜飼事似寺璽辞舎写射捨赦斜社紗謝蛇邪食笥乍覗巳蓑貰亊俟冩厶嗄奢娑寫徙柤梭槎泗洒渣瀉灑犧獻畭祀祠竢篩簑簔絲耜肆舍莎乕辭釶鉈駟駛鯊鰤麝")
+ ("tkr" "削朔索数嗽數槊爍鑠")
+ ("tks" "傘山撒散珊産算酸蒜刪杣汕疝繖跚閂閊")
+ ("tkf" "殺薩撒蔡")
+ ("tka" "三参森杉參彡滲糂纔罧芟蔘衫")
+ ("tkq" "扱渋挿插歃澁澀霎颯")
+ ("tkd" "桑向傷償商嘗尚床湘祥裳詳象賞上常状双喪爽想相霜像滝瀧湯峠橡箱様雙嫦孀庠廂慯樣殤牀甞翔裃觴謫鱶")
+ ("to" "塞璽洒灑腮賽顋鰓")
+ ("tor" "塞咋索色嗇愬槭穡薔")
+ ("tod" "甥省牲生猩笙")
+ ("tid" "餉")
+ ("tj" "黍犀暑曙庶緒署書薯藷叙序徐恕鋤瑞棲栖西誓逝鼠挑婿舒噬墅壻嶼抒敍敘筮絮耡聟胥黎鼡")
+ ("tjr" "潟汐射釈錫席惜昔析石碩夕淅皙蓆蜥螫裼釋鉐")
+ ("tjs" "還蝉仙先宣扇撰洗煽旋線羨腺船選銑鮮善禅繕膳単亘僊單嬋尠愃洒燹癬禪綫譱舩蘚跣霰")
+ ("tjf" "洩屑契折設説雪舌鱈苫囓挈楔泄渫紲絏緤薛褻齧")
+ ("tja" "繊閃孅暹歙殲殱笘纖纎蟾譫贍銛")
+ ("tjq" "拾渉摺摂燮囁慴懾攝聶躡鑷顳")
+ ("tjd" "省城姓性成星盛聖声誠醒惺晟猩筬聲腥")
+ ("tp" "歳細笹世勢税説洗貰彗洒蛻")
+ ("th" "鯵繰咲篠所召哨宵小少昭梢沼消焼硝笑紹肖鞘塑疏疎素蘇訴遡掃掻巣燥騒蛸疋劭嘯嫂愬梳樔毟泝溯瀟燒甦筱簫艘蔬蕭蘓譟踈逍邵釖銷霄韶騷鮹鰺")
+ ("thr" "粟束速俗属続屬續謖贖")
+ ("ths" "餐孫損遜巽")
+ ("thf" "率蟀")
+ ("thd" "松訟宋送悚枩淞竦舂蚣誦鎹頌鬆")
+ ("thkf" "刷")
+ ("tho" "鎖砕刷殺晒洒灑瑣碎")
+ ("thl" "粋衰夊")
+ ("tn" "守手殊狩首受寿授樹綬需囚収修愁秀繍蒐讐酬獣宿須垂帥水睡遂随瑞髄数捜痩袖竪誰嬬穂薮輸率叟售嗾嗽埀壽嫂岫戍搜收數殳泅洙溲漱燧獸祟穗籔粹綉綏繻羞脩隋膸茱莎蓚藪雖讎豎隨酥銖銹鏥陲隧髓鬚")
+ ("tnr" "叔夙宿淑縮粛塾熟俶孰倏肅菽蓿")
+ ("tns" "瞬舜駿循旬楯殉淳盾純巡醇順馴徇恂洵筍笋脣荀蓴蕣詢諄鐓鶉")
+ ("tnf" "術述率恤戌朮")
+ ("tnd" "崇嵩菘")
+ ("tnl" "倅伜淬")
+ ("tmf" "膝瑟虱蝨")
+ ("tmq" "湿拾習襲濕褶隰")
+ ("tmd" "勝升承昇丞乗剰僧縄蝿乘剩甸枡繩蠅陞")
+ ("tl" "飴柿匙殺使始屍市施視詩試侍寺時示蒔偲柴是提矢厮啻嗜嘶尸屎廝弑恃撕猜翅腮舐葹蓍諡豕豺顋")
+ ("tlr" "喰式識埴飾拭植殖食蝕息寔熄軾餝")
+ ("tls" "榊伸信娠慎新申神紳臣薪身辛腎訊迅辰矧噺呻哂宸愼抻晨燼蜃贐頤鰰")
+ ("tlf" "失室悉実實榁蟋")
+ ("tla" "参審心深芯尋甚參忱椹沁潯瀋蕈鐔")
+ ("tlq" "拾什十渋辻卅丗澁澀瓧竍籵")
+ ("Tkd" "双雙")
+ ("Tl" "氏")
+ ("dk" "亜唖阿俄峨我牙芽蛾雅餓涯御児亞兒哦娥婀峩椏猗痾莪衙襾訝錏鐚鴉鵝鵞")
+ ("dkr" "亜悪握渥岳楽顎鍔鰐亞咢堊嶽幄惡愕樂萼蕚葯諤鄂鶚齷齶")
+ ("dks" "安按案鞍岸眼贋雁顔諺偐晏殷顏鮟鴈鳫")
+ ("dkf" "斡按謁戛戞蘗蘖歹訐軋遏閼靄")
+ ("dka" "庵暗闇厭俺巌癌岩嵒巖菴諳頷黯黶")
+ ("dkq" "姶圧押鴨哈壓狎")
+ ("dkd" "央仰昂怏殃泱秧鞅鴦")
+ ("do" "哀愛挨崖涯碍喝啀嗄噫埃崕曖欸皚睚瞹磑礙艾藹阨隘靄靉饐")
+ ("dor" "液額夜厄扼掖腋軛阨隘")
+ ("dod" "嚶櫻罌鶯鸚")
+ ("di" "射斜邪若惹埜也冶夜爺耶野揶椰鵺")
+ ("dir" "鰯若弱約薬躍嫋搦籥葯蒻藥鑰鶸龠")
+ ("did" "詳壌嬢穣譲醸揚楊様洋羊陽養佯壤孃恙攘昜暘樣漾瀁煬痒瘍癢禳穰襄讓釀驤")
+ ("dj" "於漁禦魚御語唹圄圉淤飫馭鯲齬")
+ ("djr" "億憶臆疑抑檍")
+ ("djs" "堰言諺這彦偃嫣焉篶")
+ ("djf" "蘗蘖")
+ ("dja" "奄掩俺巌岩験厳儼厂嚴巖广淹罨閹驗")
+ ("djq" "業")
+ ("dp" "恚殪")
+ ("du" "汝如予余与誉輿預豫歟洳畭絮舁與茹蕷蜍譽餘")
+ ("dur" "易域疫駅逆射亦役訳懌繹蜴譯閠閾霓驛鯣")
+ ("dus" "咽宴延沿演煙燕縁鉛研硯次然鳶軟燃淵吮嚥妍娟悁捐掾椽櫞衍涓涎渊烟筵臙莚蜒蠕讌")
+ ("duf" "咽悦閲説熱吶噎齧")
+ ("dua" "厭炎焔艶塩染稔冉檐艷苒閻髯魘鯰鹽黶")
+ ("duq" "厭葉囁曄靨")
+ ("dud" "営嬰影映栄永泳瑛盈穎頴英詠景迎咏營塋佞侫暎楹榮潁瀛瑩瓔珱纓蠑贏郢霙")
+ ("dP" "医叡曳洩鋭刈詣芸児蕊誉預乂豫倪兒兌囈曵泄猊睨睿穢翳艾蘂蕋藝蚋裔譽貎霓鯢麑")
+ ("dh" "悪烏迂於汚奥襖五伍午呉吾娯悟梧誤傲唔嗚嗷塢墺奧媼寤忤惡懊敖晤澳熬燠牾珸蜈螯遨鏖鰲鼇")
+ ("dhr" "阿屋玉獄沃")
+ ("dhs" "温穏慍瘟穩薀蘊褞鰮鰛")
+ ("dhf" "兀榲膃")
+ ("dhd" "翁擁壅廱瓮甕癰禺蓊雍鶲")
+ ("dhk" "娃渦臥蛙瓦窪哇囮窩萵蝸訛譌")
+ ("dhks" "宛完緩莞関玩翫頑椀碗腕婉浣澣蜿豌關")
+ ("dhkf" "曰")
+ ("dhkd" "往旺王皇尢徃枉汪")
+ ("dho" "娃蛙倭哇矮蝸")
+ ("dhl" "畏外隈嵬巍猥磑薈鮠")
+ ("dy" "凹楽尭腰擾銚陶約妖揺曜窯耀要謡遥僥夭姚嬲嫐嶢幺徭徼拗搖撓樂橈殀澆燿瑶窈窰繞蕘蟯謠遶邀饒鷂堯遙瑤")
+ ("dyr" "辱谷慾欲浴峪溽縟蓐褥")
+ ("dyd" "桶茸勇湧涌傭容庸溶熔用蓉踊俑慂慵榕甬聳舂蛹踴鎔頌")
+ ("dn" "芋右宇羽迂雨欧殴牛区愚虞偶寓遇隅枢又尤佑優友憂祐郵于傴吁吽嵎樞歐毆疣盂禹禺紆肬藕謳麌齲")
+ ("dnr" "旭郁勗墺澳燠")
+ ("dns" "員韻云運雲暈殞熕紜耘隕韵")
+ ("dnf" "宛尉欝蔚鬱熨")
+ ("dnd" "熊雄")
+ ("dnjs" "宛員院園怨援猿苑薗遠鴛垣願元原源媛冤圓圜婉寃愿湲爰芫蜿袁諢轅鋺阮隕")
+ ("dnjf" "越月戉曰粤鉞")
+ ("dnl" "葦位偉囲委威尉慰為緯胃萎謂違蔚衛危偽倭僞喟囗圍幃渭爲痿縅莠蝟衞逶韋魏")
+ ("db" "惟維遺桜儒柔嬬酉楢肉乳濡鮪愉愈油癒諭輸唯宥幽悠有柚猶猷由裕誘遊幼侑兪喩囿孺帷懦揉揄攸楡渝游瑜瘉糅綏腴臾萸蕕蚰蝓蝣蠕襦覦諛蹂踰逾釉鍮鞣黝鼬")
+ ("dbr" "育粥肉囿毓鬻")
+ ("dbs" "允胤閏潤尹贇酳")
+ ("dbf" "聿鴪")
+ ("dbd" "戎融絨")
+ ("dms" "隠恩銀听圻垠慇憖殷犹隱齦")
+ ("dmf" "乙疑")
+ ("dma" "飲淫蔭陰音疑吟吽婬崟飮霪")
+ ("dmq" "泣揖邑悒")
+ ("dmd" "応疑凝鷹蝿應膺蠅軅軈")
+ ("dml" "依意椅衣涯毅儀宜擬疑義蟻誼議歪倚崕嶬嶷懿欹熨猗矣礒縊艤醫饐")
+ ("dl" "飴以伊夷易異移餌施爾而耳蛇食詑台弛寅二迩弍姨尓已彝彜怡洟珥甅痍肄苡詒貽貳貮轜邇隶")
+ ("dlr" "益翌翼嶷弋杙翊謚鷁")
+ ("dls" "印咽因姻引煙人仁刃靭寅忍認籾仞仭儿刄堙孕廴氤湮烟茵荵蚓靱")
+ ("dlf" "一壱溢逸日弌佚壹衵釼鎰")
+ ("dla" "荏壬賃任妊稔姙恁衽袵")
+ ("dlq" "込廿入叺圦鳰")
+ ("dld" "剰仍剩孕")
+ ("wk" "梓茨佐左査剤作仔刺姉姿子孜紫諮資雌字慈滋磁自煮者斉積柘髭偖劑呰咨孳恣滓炙瓷疵眥眦粢苴茲蔗藉薺觜貲齎赭鮓鷓齊")
+ ("wkr" "作昨勺杓灼爵酌酢雀嚼妁寉斫柞炸筰綽芍醋鵲")
+ ("wks" "桟残孱戔棧殘潺盞")
+ ("wka" "蚕暫潜湛岑潛濳箴簪蠶賺鏨")
+ ("wkq" "雑匝挿喋囃插箚襍雜")
+ ("wkd" "匠奨将庄掌樟章粧蒋醤障丈場杖状壮荘葬装臓蔵帳張腸長撞仗塲墻壯奘奬妝將嶂弉橦檣淙漿爿牆獎璋瘴膓臟臧艢莊萇薔藏裝贓賍鏘鱆")
+ ("wo" "再哉宰才災斎裁載在材財柴斉存滓齋縡纔豺齎齊")
+ ("wod" "噌槍争鎗崢幀爭瞠箏筝諍錚")
+ ("wj" "姐且杵煮渚藷諸鋤除岨狙樗瀦猪苧著貯低底抵邸屠這箸儲佇咀弖抒杼柢楮沮潴牴疽砠竚紵羝耡苴蛆觝詆豬躇雎齟")
+ ("wjr" "荻借寂積籍績赤跡蹟賊逐嫡弔吊摘敵滴的笛適鏑躍勣廸炙狄癪磧糴芍藉覿迪迹逖")
+ ("wjs" "鴫竣戦栓栴煎箭詮銭前全揃樽佃典填展纏転顛伝殿澱田電縛畑槙淀傳剪甸吮囀奠專巓廛悛戔戰畋旃氈沺濺牋甎痊癜癲磚筌箋篆纒羶翦腆趁躔輾轉鈿銓錢鐫雋靦顫餞饌鷆鷏槇")
+ ("wjf" "準切拙折窃節絶窒姪凖卩咥截晢晰浙竊耋跌軼")
+ ("wja" "鮎占漸店点苫粘岾簟霑黏點")
+ ("wjq" "接蝶慴椄楫楪沾渫聶鰈")
+ ("wjd" "井鯖晶証鉦情浄錠征政整正精静打丁町頂亭停偵貞呈定庭廷挺汀碇禎程艇訂鄭釘鼎瀞柾靖淀丼叮幀掟旌梃淨渟甼疔睛穽聢菁蟶逞遉酊酲鐺霆靜")
+ ("wp" "鵜栽済祭際剤諸除制製斉折第醍題堤帝弟悌提梯蹄俤儕劑擠晢濟眥眦睇臍薺齎躋霽齏韲齊")
+ ("wh" "竃繰錯惨篠助昭照詔条岨措祖租粗組阻操早曹槽漕燥糟藻遭造鯛兆凋弔彫朝潮眺調跳銚鳥蔦爪吊釣敦蚤肇佻俎嘲噪徂慘慥懆找抓晁條梍棗棹澡爼砠祚稠窕竈笊糶絛罩耡胙艚蜩詛誂譟趙躁鑿雕髞")
+ ("whr" "足族簇蔟鏃")
+ ("whs" "尊拵")
+ ("whf" "拙卒枠卆猝")
+ ("whd" "種腫宗終従縦鍾鐘綜柊从從慫棕椶樅淙粽縱螽踵蹤踪鑁")
+ ("whk" "佐左坐座挫")
+ ("whl" "罪")
+ ("wy" "釖")
+ ("wn" "株作主朱珠酒呪周州洲舟週住祝厨奏走足族宙昼柱注註酎鋳駐調紬肘湊丶侏做儔冑嗾廚晝疇畴稠籌籀紂綢胄蔟蛛誅赱躊輳遒鑄麈")
+ ("wnr" "粥竹鬻")
+ ("wns" "噂俊峻竣駿準純遵屯隼鱒儁凖墫恂悛惷浚濬皴蠢蹲逡")
+ ("wnd" "衆重中仲")
+ ("wmr" "即賊")
+ ("wmf" "櫛")
+ ("wma" "怎")
+ ("wmq" "輯汁葺揖楫緝")
+ ("wmd" "絵甑症証蒸噌曾曽増憎贈徴拯橙烝證")
+ ("wl" "岐祇志指支旨枝止祉紙肢脂至誌持識質芝織只知地智池蜘遅漬底抵砥之咫址塒帋弖摯枳沚痣祗耆胝舐觝貭贄趾踟躓輊遲阯鮨鷙")
+ ("wlr" "織職直喞稙稷")
+ ("wls" "唇振晋榛疹真秦診進震塵尽陣辰珍鎮陳津填賑侭儘嗔晉殄燼珎甄畛盡眞瞋縉臻蓁袗趁軫鎭")
+ ("wlf" "叱嫉疾質秩窒迭蛭姪佚咥喞垤帙桎耋膣腟貭跌軼")
+ ("wla" "朕斟酖鴆")
+ ("wlq" "執輯集汁緝")
+ ("wld" "澄徴懲澂")
+ ("ck" "且此叉嵯差瑳車遮借詫侘嗟岔嵳扠搓朿槎磋箚苴蹉釵")
+ ("ckr" "搾窄錯昔捉濁着著戳縒躇鑿齣齪")
+ ("cks" "燦纂讃賛餐撰簒攅爨竄粲纉讚贊鏨鑽鑚饌")
+ ("ckf" "察拶擦札刹扎獺紮")
+ ("cka" "参惨斬漸僭僣參塹嶄巉慘慙慚懺懴槧站譖譛讒讖驂")
+ ("ckd" "唱娼廠彰昌菖椙創倉槍窓蒼暢脹畠倡剏厰悵愴搶敞昶淌滄漲猖瘡窗艙蹌鬯")
+ ("co" "差債彩採采砦祭菜柴責莱寨綵蔡豸釵靫")
+ ("cor" "咋柵窄策冊責措册嘖拆柞磔筴簀")
+ ("cj" "妻処凄狙處悽淒絮萋")
+ ("cjr" "刺尺隻戚斥脊捗剔呎彳擲滌瘠蜴跖蹐蹠躑陟鶺")
+ ("cjs" "茜粁串釧蚕千川撰泉浅穿舛薦賎践遷辿天仟倩刋喘巛擅栫楾淺湶濺瓩竏荐賤踐闡阡韆")
+ ("cjf" "綴哲徹撤轍鉄凸畷啜屮掣輟銕錣鐵鐡餮")
+ ("cja" "鹸尖添甜僉忝恬槧檐沾瞻簷簽籤籖蟾覘諂譫")
+ ("cjq" "妾捷畳喋帖牒諜貼疊疉疂睫褶輒輙")
+ ("cjd" "鯖錆晴清請青庁聴廳廰聽菁蜻")
+ ("cp" "切体替滞逮綴剃締諦逓薙畷啼嚔嚏掣楴涕滯睇砌蒂蔕裼躰軆遞靆體髢")
+ ("ch" "鍬初哨抄招樵焦硝礁肖蕉鞘酢楚礎草超銚秒剿劭勦屮峭悄愀憔杪椒湫炒稍艸誚貂迢醋鈔髫鷦齠")
+ ("chr" "趣嘱燭触数促属囑屬數矗矚簇蜀觸躅鏃髑")
+ ("chs" "吋寸村忖邨")
+ ("chd" "従銃叢惣総聡寵塚憧葱竜龍从偬匆從怱愡總縱聰")
+ ("chl" "催最崔摧榱洒")
+ ("cn" "穐丑鰍取趣就愁秋臭酋醜出諏推錐錘枢趨雛粗畜抽墜椎槌追鎚萩鷲啾娵婢帚惆掫捶楸樞湫甃皺龝箒簇縋聚芻蒭鄒陬隹鞦騅驟鰌麁")
+ ("cnr" "丑竺軸蹴祝縮築畜筑蓄逐柚槭舳蹙")
+ ("cns" "春椿鰆")
+ ("cnf" "出朮黜")
+ ("cnd" "沖充銃衝忠虫衷傭冲狆艟蟲")
+ ("cnp" "悴忰惴瘁萃贅")
+ ("cnl" "取趣就臭吹炊翠酔脆鷲嘴娶惴揣橇毳瘁翆聚膵萃觜醉驟")
+ ("cmr" "側則測捗仄惻昃")
+ ("cms" "齔")
+ ("cma" "闖")
+ ("cmd" "曾曽層")
+ ("cl" "嵯差歯治痔埴植織値恥痴稚置致馳徴直薙侈卮厠嗤夂峙巵幟廁梔熾畄畤癡碪穉笞紕緇緻耻蚩褫豸跂輜錙雉魑鯔鴟鵄黹齒")
+ ("clr" "則測勅飭厠廁惻敕")
+ ("cls" "親襯齔")
+ ("clf" "七漆")
+ ("cla" "砧侵寝浸針湛沈枕寢忱斟椹鍼鍖闖駸")
+ ("clq" "蟄")
+ ("cld" "称秤稱袮騁")
+ ("cho" "快夬獪")
+ ("xk" "蛇他詑唾堕妥惰打柁舵楕陀駄騨池詫佗咤墮它捶揣朶橢沱隋躱駝鴕")
+ ("xkr" "卓啄托拓沢濯琢託鐸濁擢度倬啅拆柝澤鈬魄")
+ ("xks" "騨嘆坦歎炭綻誕弾呑灘彈憚攤殫袒")
+ ("xkf" "奪脱")
+ ("xka" "探耽眈貪")
+ ("xkq" "塔搭搨榻鞜鞳鰈")
+ ("xkd" "宕湯糖蕩帑盪蝪")
+ ("xo" "税太汰怠態泰胎苔逮台大能殆戻兌棣笞紿蛻詒颱駘")
+ ("xor" "宅択沢擇澤")
+ ("xh" "兎吐菟土套討兔莵")
+ ("xhs" "褪")
+ ("xhd" "桶痛通筒統樋恫慟")
+ ("xhl" "推堆腿退槌追鎚敦褪頽")
+ ("xn" "妬投透闘愉偸綉鍮骰鬪")
+ ("xmr" "貸特慝")
+ ("vk" "頗巴把播杷波派琶破婆芭罷簸坡怕擺霸爬玻碆笆耙膰菠葩袙跛陂")
+ ("vks" "坂阪判板版販辧汳瓣鈑")
+ ("vkf" "捌八叭杁釟")
+ ("vo" "唄貝派敗牌背倍狽抜罷稗佩孛悖拔旆霸沛珮霈")
+ ("vod" "棚烹傍膨弸彭旁澎磅繃")
+ ("vir" "愎")
+ ("vus" "平偏片篇編遍便鞭扁翩苹蝙褊諞騙")
+ ("vua" "貶")
+ ("vud" "坪評浜平怦泙硼苹萍鮃")
+ ("vP" "柿廃肺幣弊蔽閉陛吠嬖幤廢敝斃癈薜髀")
+ ("vh" "浦鞄蒲曝爆布怖葡舗鋪圃捕包庖抱泡砲胞褒飽暴勹匍匏咆哺垉抛枹瀑炮疱皰脯舖苞袍襃逋鉋靤餔髱鮑鯆麭")
+ ("vhr" "曝爆幅暴瀑")
+ ("vy" "杓俵彪標漂瓢票表豹剽嫖慓殍縹飄飃飆驃驫髟鰾")
+ ("vns" "分")
+ ("vna" "品稟禀")
+ ("vnd" "楓風豊瘋諷豐颪馮")
+ ("vb" "彪")
+ ("vl" "彼披疲皮罷被避跛辟陂")
+ ("vlf" "嘩比泌匹疋弼必畢筆払仏佛拂篳譁蹕鵯")
+ ("vlq" "逼幅乏泛")
+ ("gk" "下何夏河荷蝦霞賀嚇雫厦呀廈渮瑕緞罅訶谺遐鍜鰕")
+ ("gkr" "鴬学虐鶴壑學斈涸狢瘧謔貉鷽")
+ ("gks" "寒汗漢翰閑韓限恨嫺嫻悍扞捍旱桿瀚狠皖罕邯駻骭鼾")
+ ("gkf" "害割喝轄劼瞎蝎黠")
+ ("gka" "艦陥含函濫凾咸啣喊嵌檻涵緘莟邯銜陷頷餡鰔鹹")
+ ("gkq" "蓋閤合蛤呷哈溘盍盖盒葢闔鴿")
+ ("gkd" "桁巷恒抗杭港航行降項虹亢伉吭恆缸肛閧頏鬨")
+ ("go" "亥解械海蟹劾咳害該骸鮭偕垓夥奚孩廨懈楷薤蠏觧諧邂醢駭")
+ ("gor" "劾核硅覈輅")
+ ("god" "杏倖幸行絎裄鵆")
+ ("gid" "享郷響饗向香嚮餉")
+ ("gj" "嘘虚許墟栩歔滸")
+ ("gjs" "憲献軒掀獻")
+ ("gjf" "歇蝎蠍")
+ ("gja" "険験嶮險驗")
+ ("gur" "嚇赫革恵奕洫鬩")
+ ("gus" "絢懸県見賢顕弦玄現絃舷項頁俔呟洵痃眩縣蜆衒鉉顯")
+ ("guf" "穴血冗頁孟孑襭頡")
+ ("gua" "嫌")
+ ("guq" "袷叶侠協峡挟狭脅頬脇夾峽慊挾浹狹筴篋莢鋏陜陝")
+ ("gud" "馨亨刑兄型形荊蛍桁衡夐炯烱瑩脛螢迥")
+ ("gP" "慧繋兮匸奚彗惠盻禊蹊醯鞋")
+ ("gh" "穫乎呼弧戸湖狐糊胡虎雇互吾瑚護醐好浩号壕濠豪冴皐縞壷冱壺怙戲昊晧楜毫沍滬滸犒琥瓠皋皓葫蒿虍號蝴扈鎬餬")
+ ("ghr" "或酷鵠惑寉斛")
+ ("ghs" "婚昏昆混魂棍棔渾溷焜琿")
+ ("ghf" "核忽惚歿笏鶻")
+ ("ghq" "恰")
+ ("ghd" "弘洪紅鴻哄汞泓訌閧鬨")
+ ("ghk" "化火禍禾花華貨画椛樺靴樗和話啝崋畫糀錵")
+ ("ghkr" "拡獲確穫擴攫癨矍蠖霍")
+ ("ghks" "喚患換桓歓環還丸幻亘圜奐宦寰懽歡渙湲煥皖眩矜讙豢鐶驩鬟鰥")
+ ("ghkf" "越活滑撮猾磆蛞豁闊濶")
+ ("ghkd" "黄況兄慌晃皇荒幌况凰徨恍惶晄湟滉煌篁簧肓蝗遑隍鰉")
+ ("gho" "画罫獪畫")
+ ("ghl" "会回壊廻悔恢懐晦灰准桧賄會囘匯壞徊懷檜槐淮繪膾茴薈蛔詼誨迴鱠")
+ ("ghlr" "画劃獲畫")
+ ("ghld" "横弘衡轟薨軣鍠黌")
+ ("gy" "暁佼効校酵肴傚哮嚆囂效曉梟淆烋爻驕驍")
+ ("gn" "芋朽後侯候厚后喉佝吼嗅嘔涸煦猴篌詬逅")
+ ("gns" "勲薫訓馴勳熏燻葷醺")
+ ("gnd" "薨")
+ ("gnjs" "萱喧暖愃暄萓諠讙")
+ ("gnp" "虫卉喙毀燬")
+ ("gnl" "揮徽輝彙戲暉麾諱")
+ ("gb" "休携畦畜攜烋虧貅")
+ ("gbr" "畜")
+ ("gbf" "恤譎鷸")
+ ("gbd" "兇凶胸匈恟洶")
+ ("gmr" "黒釛")
+ ("gms" "欣痕很忻掀釁")
+ ("gmf" "汽吃迄屹訖")
+ ("gma" "欽欠")
+ ("gmq" "吸歙洽皀翕")
+ ("gmd" "興虹")
+ ("gml" "喜嬉希稀戯犠姫僖咥唏噫愾憙戲晞曦欷煕熈熹燹犧禧羲釐鯑")
+ ("glf" "詰纈襭頡黠")
+ ("unknown" "苅宍栂栃凪弐塀俣杢刔夘咒哘唸囎圀圷圸垳垪埔埖埣塰堽墹墸壗壥嬶屓乢妛岫岻岶岼峅峇峺嵶彁怺恷恊抂挧掵擶暃杤桙梹椥椨椪椚椣椡槝樮櫁樌橲樶橸樢檸欟歛汢渕淕溂潸澑犲畉畆畩蘯眤瞶硴碚碵礇禝穃邃笶筅箟篏簓簗籏粐粭粫糘綛縺繧纃緕纐罎膤艝茣莇菷萢蒄蓙蘰蚫蛯蟐袞袰褄諚戝轌辷迚逧逎鍄錻閇閖陦隲靹鞆鞐饂馼駲鮖鮴鯒鯱鰄鰡鱚鵈鵤鵐"))
;;; hanja-jis.el ends here
diff --git a/lisp/leim/quail/japanese.el b/lisp/leim/quail/japanese.el
index 74f02b141da..d536b5e5c96 100644
--- a/lisp/leim/quail/japanese.el
+++ b/lisp/leim/quail/japanese.el
@@ -1,4 +1,4 @@
-;;; japanese.el --- Quail package for inputting Japanese -*-coding: iso-2022-7bit;-*-
+;;; japanese.el --- Quail package for inputting Japanese
;; Copyright (C) 2001-2019 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -31,7 +31,7 @@
(require 'kkc)
(defvar quail-japanese-use-double-n nil
- "If non-nil, use type \"nn\" to insert $B$s(B.")
+ "If non-nil, use type \"nn\" to insert ん.")
;; Update Quail translation region while considering Japanese bizarre
;; translation rules.
@@ -47,14 +47,14 @@
(setq quail-current-str (aref quail-current-key 0)
control-flag t))
((= (aref quail-current-key 0) ?n)
- (setq quail-current-str ?$B$s(B)
+ (setq quail-current-str ?ん)
(if (and quail-japanese-use-double-n
(> keylen 0)
(= (aref quail-current-key 1) ?n))
(setq control-flag t)))
((and (> keylen 1)
(= (aref quail-current-key 0) (aref quail-current-key 1)))
- (setq quail-current-str ?$B$C(B))
+ (setq quail-current-str ?っ))
(t
(setq quail-current-str (aref quail-current-key 0))))
(if (integerp control-flag)
@@ -84,10 +84,10 @@
(defun quail-japanese-kanji-kkc ()
(interactive)
(when (= (char-before (overlay-end quail-conv-overlay)) ?n)
- ;; The last char is `n'. We had better convert it to `$B$s(B'
+ ;; The last char is `n'. We had better convert it to `ん'
;; before kana-kanji conversion.
(goto-char (1- (overlay-end quail-conv-overlay)))
- (insert ?$B$s(B)
+ (insert ?ん)
(delete-char 1))
(let* ((from (copy-marker (overlay-start quail-conv-overlay)))
(len (- (overlay-end quail-conv-overlay) from)))
@@ -135,113 +135,113 @@
(throw 'quail-tag nil))
(defvar quail-japanese-transliteration-rules
- '(( "a" "$B$"(B") ( "i" "$B$$(B") ( "u" "$B$&(B") ( "e" "$B$((B") ( "o" "$B$*(B")
- ("ka" "$B$+(B") ("ki" "$B$-(B") ("ku" "$B$/(B") ("ke" "$B$1(B") ("ko" "$B$3(B")
- ("sa" "$B$5(B") ("si" "$B$7(B") ("su" "$B$9(B") ("se" "$B$;(B") ("so" "$B$=(B")
- ("ta" "$B$?(B") ("ti" "$B$A(B") ("tu" "$B$D(B") ("te" "$B$F(B") ("to" "$B$H(B")
- ("na" "$B$J(B") ("ni" "$B$K(B") ("nu" "$B$L(B") ("ne" "$B$M(B") ("no" "$B$N(B")
- ("ha" "$B$O(B") ("hi" "$B$R(B") ("hu" "$B$U(B") ("he" "$B$X(B") ("ho" "$B$[(B")
- ("ma" "$B$^(B") ("mi" "$B$_(B") ("mu" "$B$`(B") ("me" "$B$a(B") ("mo" "$B$b(B")
- ("ya" "$B$d(B") ("yu" "$B$f(B") ("yo" "$B$h(B")
- ("ra" "$B$i(B") ("ri" "$B$j(B") ("ru" "$B$k(B") ("re" "$B$l(B") ("ro" "$B$m(B")
- ("la" "$B$i(B") ("li" "$B$j(B") ("lu" "$B$k(B") ("le" "$B$l(B") ("lo" "$B$m(B")
- ("wa" "$B$o(B") ("wi" "$B$p(B") ("wu" "$B$&(B") ("we" "$B$q(B") ("wo" "$B$r(B")
- ("n'" "$B$s(B")
- ("ga" "$B$,(B") ("gi" "$B$.(B") ("gu" "$B$0(B") ("ge" "$B$2(B") ("go" "$B$4(B")
- ("za" "$B$6(B") ("zi" "$B$8(B") ("zu" "$B$:(B") ("ze" "$B$<(B") ("zo" "$B$>(B")
- ("da" "$B$@(B") ("di" "$B$B(B") ("du" "$B$E(B") ("de" "$B$G(B") ("do" "$B$I(B")
- ("ba" "$B$P(B") ("bi" "$B$S(B") ("bu" "$B$V(B") ("be" "$B$Y(B") ("bo" "$B$\(B")
- ("pa" "$B$Q(B") ("pi" "$B$T(B") ("pu" "$B$W(B") ("pe" "$B$Z(B") ("po" "$B$](B")
-
- ("kya" ["$B$-$c(B"]) ("kyu" ["$B$-$e(B"]) ("kye" ["$B$-$'(B"]) ("kyo" ["$B$-$g(B"])
- ("sya" ["$B$7$c(B"]) ("syu" ["$B$7$e(B"]) ("sye" ["$B$7$'(B"]) ("syo" ["$B$7$g(B"])
- ("sha" ["$B$7$c(B"]) ("shu" ["$B$7$e(B"]) ("she" ["$B$7$'(B"]) ("sho" ["$B$7$g(B"])
- ("cha" ["$B$A$c(B"]) ("chu" ["$B$A$e(B"]) ("che" ["$B$A$'(B"]) ("cho" ["$B$A$g(B"])
- ("tya" ["$B$A$c(B"]) ("tyu" ["$B$A$e(B"]) ("tye" ["$B$A$'(B"]) ("tyo" ["$B$A$g(B"])
- ("nya" ["$B$K$c(B"]) ("nyu" ["$B$K$e(B"]) ("nye" ["$B$K$'(B"]) ("nyo" ["$B$K$g(B"])
- ("hya" ["$B$R$c(B"]) ("hyu" ["$B$R$e(B"]) ("hye" ["$B$R$'(B"]) ("hyo" ["$B$R$g(B"])
- ("mya" ["$B$_$c(B"]) ("myu" ["$B$_$e(B"]) ("mye" ["$B$_$'(B"]) ("myo" ["$B$_$g(B"])
- ("rya" ["$B$j$c(B"]) ("ryu" ["$B$j$e(B"]) ("rye" ["$B$j$'(B"]) ("ryo" ["$B$j$g(B"])
- ("lya" ["$B$j$c(B"]) ("lyu" ["$B$j$e(B"]) ("lye" ["$B$j$'(B"]) ("lyo" ["$B$j$g(B"])
- ("gya" ["$B$.$c(B"]) ("gyu" ["$B$.$e(B"]) ("gye" ["$B$.$'(B"]) ("gyo" ["$B$.$g(B"])
- ("zya" ["$B$8$c(B"]) ("zyu" ["$B$8$e(B"]) ("zye" ["$B$8$'(B"]) ("zyo" ["$B$8$g(B"])
- ("jya" ["$B$8$c(B"]) ("jyu" ["$B$8$e(B"]) ("jye" ["$B$8$'(B"]) ("jyo" ["$B$8$g(B"])
- ( "ja" ["$B$8$c(B"]) ( "ju" ["$B$8$e(B"]) ( "je" ["$B$8$'(B"]) ( "jo" ["$B$8$g(B"])
- ("bya" ["$B$S$c(B"]) ("byu" ["$B$S$e(B"]) ("bye" ["$B$S$'(B"]) ("byo" ["$B$S$g(B"])
- ("pya" ["$B$T$c(B"]) ("pyu" ["$B$T$e(B"]) ("pye" ["$B$T$'(B"]) ("pyo" ["$B$T$g(B"])
-
- ("kwa" ["$B$/$n(B"]) ("kwi" ["$B$/$#(B"]) ("kwe" ["$B$/$'(B"]) ("kwo" ["$B$/$)(B"])
- ("tsa" ["$B$D$!(B"]) ("tsi" ["$B$D$#(B"]) ("tse" ["$B$D$'(B"]) ("tso" ["$B$D$)(B"])
- ( "fa" ["$B$U$!(B"]) ( "fi" ["$B$U$#(B"]) ( "fe" ["$B$U$'(B"]) ( "fo" ["$B$U$)(B"])
- ("gwa" ["$B$0$n(B"]) ("gwi" ["$B$0$#(B"]) ("gwe" ["$B$0$'(B"]) ("gwo" ["$B$0$)(B"])
-
- ("dyi" ["$B$G$#(B"]) ("dyu" ["$B$I$%(B"]) ("dye" ["$B$G$'(B"]) ("dyo" ["$B$I$)(B"])
- ("xwi" ["$B$&$#(B"]) ("xwe" ["$B$&$'(B"]) ("xwo" ["$B$&$)(B"])
-
- ("shi" "$B$7(B") ("tyi" ["$B$F$#(B"]) ("chi" "$B$A(B") ("tsu" "$B$D(B") ("ji" "$B$8(B")
- ("fu" "$B$U(B")
- ("ye" ["$B$$$'(B"])
-
- ("va" ["$B%t$!(B"]) ("vi" ["$B%t$#(B"]) ("vu" "$B%t(B") ("ve" ["$B%t$'(B"]) ("vo" ["$B%t$)(B"])
-
- ("xa" "$B$!(B") ("xi" "$B$#(B") ("xu" "$B$%(B") ("xe" "$B$'(B") ("xo" "$B$)(B")
- ("xtu" "$B$C(B") ("xya" "$B$c(B") ("xyu" "$B$e(B") ("xyo" "$B$g(B") ("xwa" "$B$n(B")
- ("xka" "$B%u(B") ("xke" "$B%v(B")
-
- ("1" "$B#1(B") ("2" "$B#2(B") ("3" "$B#3(B") ("4" "$B#4(B") ("5" "$B#5(B")
- ("6" "$B#6(B") ("7" "$B#7(B") ("8" "$B#8(B") ("9" "$B#9(B") ("0" "$B#0(B")
-
- ("!" "$B!*(B") ("@" "$B!w(B") ("#" "$B!t(B") ("$" "$B!p(B") ("%" "$B!s(B")
- ("^" "$B!0(B") ("&" "$B!u(B") ("*" "$B!v(B") ("(" "$B!J(B") (")" "$B!K(B")
- ("-" "$B!<(B") ("=" "$B!a(B") ("`" "$B!.(B") ("\\" "$B!o(B") ("|" "$B!C(B")
- ("_" "$B!2(B") ("+" "$B!\(B") ("~" "$B!1(B") ("[" "$B!V(B") ("]" "$B!W(B")
- ("{" "$B!P(B") ("}" "$B!Q(B") (":" "$B!'(B") (";" "$B!((B") ("\"" "$B!I(B")
- ("'" "$B!G(B") ("." "$B!#(B") ("," "$B!"(B") ("<" "$B!c(B") (">" "$B!d(B")
- ("?" "$B!)(B") ("/" "$B!?(B")
-
- ("z1" "$B!{(B") ("z!" "$B!|(B")
- ("z2" "$B"&(B") ("z@" "$B"'(B")
- ("z3" "$B"$(B") ("z#" "$B"%(B")
- ("z4" "$B""(B") ("z$" "$B"#(B")
- ("z5" "$B!~(B") ("z%" "$B"!(B")
- ("z6" "$B!y(B") ("z^" "$B!z(B")
- ("z7" "$B!}(B") ("z&" "$B!r(B")
- ("z8" "$B!q(B") ("z*" "$B!_(B")
- ("z9" "$B!i(B") ("z(" "$B!Z(B")
- ("z0" "$B!j(B") ("z)" "$B![(B")
- ("z-" "$B!A(B") ("z_" "$B!h(B")
- ("z=" "$B!b(B") ("z+" "$B!^(B")
- ("z\\" "$B!@(B") ("z|" "$B!B(B")
- ("z`" "$B!-(B") ("z~" "$B!/(B")
-
- ("zq" "$B!T(B") ("zQ" "$B!R(B")
- ("zw" "$B!U(B") ("zW" "$B!S(B")
- ("zr" "$B!9(B") ("zR" "$B!8(B")
- ("zt" "$B!:(B") ("zT" "$B!x(B")
- ("zp" "$B")(B") ("zP" "$B",(B")
- ("z[" "$B!X(B") ("z{" "$B!L(B")
- ("z]" "$B!Y(B") ("z}" "$B!M(B")
-
- ("zs" "$B!3(B") ("zS" "$B!4(B")
- ("zd" "$B!5(B") ("zD" "$B!6(B")
- ("zf" "$B!7(B") ("zF" "$B"*(B")
- ("zg" "$B!>(B") ("zG" "$B!=(B")
- ("zh" "$B"+(B")
- ("zj" "$B"-(B")
- ("zk" "$B",(B")
- ("zl" "$B"*(B")
- ("z;" "$B!+(B") ("z:" "$B!,(B")
- ("z'" "$B!F(B") ("z\"" "$B!H(B")
+ '(( "a" "あ") ( "i" "い") ( "u" "う") ( "e" "え") ( "o" "お")
+ ("ka" "か") ("ki" "き") ("ku" "く") ("ke" "け") ("ko" "こ")
+ ("sa" "さ") ("si" "し") ("su" "す") ("se" "せ") ("so" "そ")
+ ("ta" "た") ("ti" "ち") ("tu" "つ") ("te" "て") ("to" "と")
+ ("na" "な") ("ni" "に") ("nu" "ぬ") ("ne" "ね") ("no" "の")
+ ("ha" "は") ("hi" "ひ") ("hu" "ふ") ("he" "へ") ("ho" "ほ")
+ ("ma" "ま") ("mi" "み") ("mu" "む") ("me" "め") ("mo" "も")
+ ("ya" "や") ("yu" "ゆ") ("yo" "よ")
+ ("ra" "ら") ("ri" "り") ("ru" "る") ("re" "れ") ("ro" "ろ")
+ ("la" "ら") ("li" "り") ("lu" "る") ("le" "れ") ("lo" "ろ")
+ ("wa" "わ") ("wi" "ゐ") ("wu" "う") ("we" "ゑ") ("wo" "を")
+ ("n'" "ん")
+ ("ga" "が") ("gi" "ぎ") ("gu" "ぐ") ("ge" "げ") ("go" "ご")
+ ("za" "ざ") ("zi" "じ") ("zu" "ず") ("ze" "ぜ") ("zo" "ぞ")
+ ("da" "だ") ("di" "ぢ") ("du" "づ") ("de" "で") ("do" "ど")
+ ("ba" "ば") ("bi" "び") ("bu" "ぶ") ("be" "べ") ("bo" "ぼ")
+ ("pa" "ぱ") ("pi" "ぴ") ("pu" "ぷ") ("pe" "ぺ") ("po" "ぽ")
+
+ ("kya" ["きゃ"]) ("kyu" ["きゅ"]) ("kye" ["きぇ"]) ("kyo" ["きょ"])
+ ("sya" ["しゃ"]) ("syu" ["しゅ"]) ("sye" ["しぇ"]) ("syo" ["しょ"])
+ ("sha" ["しゃ"]) ("shu" ["しゅ"]) ("she" ["しぇ"]) ("sho" ["しょ"])
+ ("cha" ["ちゃ"]) ("chu" ["ちゅ"]) ("che" ["ちぇ"]) ("cho" ["ちょ"])
+ ("tya" ["ちゃ"]) ("tyu" ["ちゅ"]) ("tye" ["ちぇ"]) ("tyo" ["ちょ"])
+ ("nya" ["にゃ"]) ("nyu" ["にゅ"]) ("nye" ["にぇ"]) ("nyo" ["にょ"])
+ ("hya" ["ひゃ"]) ("hyu" ["ひゅ"]) ("hye" ["ひぇ"]) ("hyo" ["ひょ"])
+ ("mya" ["みゃ"]) ("myu" ["みゅ"]) ("mye" ["みぇ"]) ("myo" ["みょ"])
+ ("rya" ["りゃ"]) ("ryu" ["りゅ"]) ("rye" ["りぇ"]) ("ryo" ["りょ"])
+ ("lya" ["りゃ"]) ("lyu" ["りゅ"]) ("lye" ["りぇ"]) ("lyo" ["りょ"])
+ ("gya" ["ぎゃ"]) ("gyu" ["ぎゅ"]) ("gye" ["ぎぇ"]) ("gyo" ["ぎょ"])
+ ("zya" ["じゃ"]) ("zyu" ["じゅ"]) ("zye" ["じぇ"]) ("zyo" ["じょ"])
+ ("jya" ["じゃ"]) ("jyu" ["じゅ"]) ("jye" ["じぇ"]) ("jyo" ["じょ"])
+ ( "ja" ["じゃ"]) ( "ju" ["じゅ"]) ( "je" ["じぇ"]) ( "jo" ["じょ"])
+ ("bya" ["びゃ"]) ("byu" ["びゅ"]) ("bye" ["びぇ"]) ("byo" ["びょ"])
+ ("pya" ["ぴゃ"]) ("pyu" ["ぴゅ"]) ("pye" ["ぴぇ"]) ("pyo" ["ぴょ"])
+
+ ("kwa" ["くゎ"]) ("kwi" ["くぃ"]) ("kwe" ["くぇ"]) ("kwo" ["くぉ"])
+ ("tsa" ["つぁ"]) ("tsi" ["つぃ"]) ("tse" ["つぇ"]) ("tso" ["つぉ"])
+ ( "fa" ["ふぁ"]) ( "fi" ["ふぃ"]) ( "fe" ["ふぇ"]) ( "fo" ["ふぉ"])
+ ("gwa" ["ぐゎ"]) ("gwi" ["ぐぃ"]) ("gwe" ["ぐぇ"]) ("gwo" ["ぐぉ"])
+
+ ("dyi" ["でぃ"]) ("dyu" ["どぅ"]) ("dye" ["でぇ"]) ("dyo" ["どぉ"])
+ ("xwi" ["うぃ"]) ("xwe" ["うぇ"]) ("xwo" ["うぉ"])
+
+ ("shi" "し") ("tyi" ["てぃ"]) ("chi" "ち") ("tsu" "つ") ("ji" "じ")
+ ("fu" "ふ")
+ ("ye" ["いぇ"])
+
+ ("va" ["ヴぁ"]) ("vi" ["ヴぃ"]) ("vu" "ヴ") ("ve" ["ヴぇ"]) ("vo" ["ヴぉ"])
+
+ ("xa" "ぁ") ("xi" "ぃ") ("xu" "ぅ") ("xe" "ぇ") ("xo" "ぉ")
+ ("xtu" "っ") ("xya" "ゃ") ("xyu" "ゅ") ("xyo" "ょ") ("xwa" "ゎ")
+ ("xka" "ヵ") ("xke" "ヶ")
+
+ ("1" "1") ("2" "2") ("3" "3") ("4" "4") ("5" "5")
+ ("6" "6") ("7" "7") ("8" "8") ("9" "9") ("0" "0")
+
+ ("!" "!") ("@" "@") ("#" "#") ("$" "$") ("%" "%")
+ ("^" "^") ("&" "&") ("*" "*") ("(" "(") (")" ")")
+ ("-" "ー") ("=" "=") ("`" "`") ("\\" "¥") ("|" "|")
+ ("_" "_") ("+" "+") ("~" " ̄") ("[" "「") ("]" "」")
+ ("{" "{") ("}" "}") (":" ":") (";" ";") ("\"" "”")
+ ("'" "’") ("." "。") ("," "、") ("<" "<") (">" ">")
+ ("?" "?") ("/" "/")
+
+ ("z1" "○") ("z!" "●")
+ ("z2" "▽") ("z@" "▼")
+ ("z3" "△") ("z#" "▲")
+ ("z4" "□") ("z$" "■")
+ ("z5" "◇") ("z%" "◆")
+ ("z6" "☆") ("z^" "★")
+ ("z7" "◎") ("z&" "£")
+ ("z8" "¢") ("z*" "×")
+ ("z9" "♂") ("z(" "【")
+ ("z0" "♀") ("z)" "】")
+ ("z-" "〜") ("z_" "∴")
+ ("z=" "≠") ("z+" "±")
+ ("z\\" "\") ("z|" "‖")
+ ("z`" "´") ("z~" "¨")
+
+ ("zq" "《") ("zQ" "〈")
+ ("zw" "》") ("zW" "〉")
+ ("zr" "々") ("zR" "仝")
+ ("zt" "〆") ("zT" "§")
+ ("zp" "〒") ("zP" "↑")
+ ("z[" "『") ("z{" "〔")
+ ("z]" "』") ("z}" "〕")
+
+ ("zs" "ヽ") ("zS" "ヾ")
+ ("zd" "ゝ") ("zD" "ゞ")
+ ("zf" "〃") ("zF" "→")
+ ("zg" "‐") ("zG" "—")
+ ("zh" "←")
+ ("zj" "↓")
+ ("zk" "↑")
+ ("zl" "→")
+ ("z;" "゛") ("z:" "゜")
+ ("z'" "‘") ("z\"" "“")
("zx" [":-"]) ("zX" [":-)"])
- ("zc" "$B!;(B") ("zC" "$B!n(B")
- ("zv" "$B"((B") ("zV" "$B!`(B")
- ("zb" "$B!k(B") ("zB" "$B"+(B")
- ("zn" "$B!l(B") ("zN" "$B"-(B")
- ("zm" "$B!m(B") ("zM" "$B".(B")
- ("z," "$B!E(B") ("z<" "$B!e(B")
- ("z." "$B!D(B") ("z>" "$B!f(B")
- ("z/" "$B!&(B") ("z?" "$B!g(B")
+ ("zc" "〇") ("zC" "℃")
+ ("zv" "※") ("zV" "÷")
+ ("zb" "°") ("zB" "←")
+ ("zn" "′") ("zN" "↓")
+ ("zm" "″") ("zM" "〓")
+ ("z," "‥") ("z<" "≦")
+ ("z." "…") ("z>" "≧")
+ ("z/" "・") ("z?" "∞")
("\\\\" quail-japanese-self-insert-and-switch-to-alpha)
("{{" quail-japanese-self-insert-and-switch-to-alpha)
@@ -252,81 +252,81 @@
))
-;; $B%m!<%^;zF~NO5Z$S2>L>4A;zJQ49$K$h$kF|K\8lF~NO%a%=%C%I(B
+;; ローマ字入力及び仮名漢字変換による日本語入力メソッド
;;
-;; $B$3$NF~NO%a%=%C%I$G$NF|K\8l$NF~NO$OFs$D$N%9%F!<%8!V%m!<%^;z2>L>JQ49!W(B
-;; $B$H!V2>L>4A;zJQ49!W$+$i$J$k!#:G=i$O%m!<%^;z2>L>JQ49$N%9%F!<%8$G!"%9(B
-;; $B%Z!<%9%-!<$r2!$9$3$H$K$h$j!"<!$N%9%F!<%8!V2>L>4A;zJQ49!W$X?J$`!#(B
+;; この入力メソッドでの日本語の入力は二つのステージ「ローマ字仮名変換」
+;; と「仮名漢字変換」からなる。最初はローマ字仮名変換のステージで、ス
+;; ペースキーを押すことにより、次のステージ「仮名漢字変換」へ進む。
;;
-;; $B!V%m!<%^;z2>L>JQ49!W(B
+;; 「ローマ字仮名変換」
;;
-;; $BJ?2>L>$O>.J8;z%-!<!JNs!K$rBG$D$3$H$K$h$jF~NO!#6gFIE@!"3g8LN`$OBP1~(B
-;; $B$9$k1Q;z%-!<$rBG$D$3$H$K$h$jF~NO!#$=$NB>$N%7%s%\%k$O(B `z' $B$KB3$1$F2?(B
-;; $B$l$+$N%-!<$rBG$D$3$H$K$h$jF~NO!#2<$KA4$F$N2DG=$J%-!<%7!<%1%s%9%j%9(B
-;; $B%H%"%C%W$5$l$F$$$k!#F~NO$5$l$?J8;z$O2<@~$G<($5$l$k!#(B
+;; 平仮名は小文字キー(列)を打つことにより入力。句読点、括弧類は対応
+;; する英字キーを打つことにより入力。その他のシンボルは `z' に続けて何
+;; れかのキーを打つことにより入力。下に全ての可能なキーシーケンスリス
+;; トアップされている。入力された文字は下線で示される。
;;
-;; $B$5$i$K0J2<$N%-!<$GFCJL$J=hM}$r9T$&!#(B
+;; さらに以下のキーで特別な処理を行う。
;;
-;; K $BJ?2>L>$rJR2>L>$K!"$"$k$$$OJR2>L>$rJ?2>L>$KJQ49(B
-;; qq $B$3$NF~NO%a%=%C%I$H(B `japanese-ascii' $BF~NO%a%=%C%I$r%H%0%k@ZBX(B
-;; qz `japanese-zenkaku' $BF~NO%a%=%C%I$K%7%U%H(B
-;; qh $B$HBG$F$P85$KLa$k(B
-;; RET $B8=:_$NF~NOJ8;zNs$r3NDj(B
-;; SPC $B2>L>4A;zJQ49$K?J$`(B
+;; K 平仮名を片仮名に、あるいは片仮名を平仮名に変換
+;; qq この入力メソッドと `japanese-ascii' 入力メソッドをトグル切替
+;; qz `japanese-zenkaku' 入力メソッドにシフト
+;; qh と打てば元に戻る
+;; RET 現在の入力文字列を確定
+;; SPC 仮名漢字変換に進む
;;
-;; `japanese-ascii' $BF~NO%a%=%C%I$O(B ASCII $BJ8;z$rF~NO$9$k$N$K;H$&!#$3$l(B
-;; $B$OF~NO%a%=%C%I$r%*%U$K$9$k$N$H$[$H$s$IF1$8$G$"$k!#0[$J$k$N$O(B qq $B$H(B
-;; $BBG$D$3$H$K$h$j!"(B`japanese' $BF~NO%a%=%C%I$KLa$l$kE@$G$"$k!#(B
+;; `japanese-ascii' 入力メソッドは ASCII 文字を入力するのに使う。これ
+;; は入力メソッドをオフにするのとほとんど同じである。異なるのは qq と
+;; 打つことにより、`japanese' 入力メソッドに戻れる点である。
;;
-;; `japanese-zenkaku' $BF~NO%a%=%C%I$OA43Q1Q?t;z$rF~NO$9$k$N$K;H$&!#(B
+;; `japanese-zenkaku' 入力メソッドは全角英数字を入力するのに使う。
;;
-;; $B!V%m!<%^;z2>L>JQ49!W%9%F!<%8$G$N%-!<%7!<%1%s%9$N%j%9%H$O:G8e$KIU$1(B
-;; $B$F$"$k!#(B
+;; 「ローマ字仮名変換」ステージでのキーシーケンスのリストは最後に付け
+;; てある。
;;
-;; $B!V2>L>4A;zJQ49!W(B
+;; 「仮名漢字変換」
;;
-;; $B$3$N%9%F!<%8$G$O!"A0%9%F!<%8$GF~NO$5$l$?J8;zNs$r2>L>4A;zJQ49$9$k!#(B
-;; $BJQ49$5$l$?J8;zNs$O!"CmL\J8@a!JH?E>I=<(!K$H;D$j$NF~NO!J2<@~I=<(!K$K(B
-;; $BJ,$1$i$l$k!#CmL\J8@a$KBP$7$F$O0J2<$N%3%^%s%I$,;H$($k!#(B
+;; このステージでは、前ステージで入力された文字列を仮名漢字変換する。
+;; 変換された文字列は、注目文節(反転表示)と残りの入力(下線表示)に
+;; 分けられる。注目文節に対しては以下のコマンドが使える。
;;
;; SPC, C-n kkc-next
-;; $B<!$NJQ498uJd$rI=<((B
-;; kkc-show-conversion-list-count $B0J>eB3$1$FBG$F$P!"JQ498uJd%j%9(B
-;; $B%H$r%(%3!<%(%j%"$KI=<((B
+;; 次の変換候補を表示
+;; kkc-show-conversion-list-count 以上続けて打てば、変換候補リス
+;; トをエコーエリアに表示
;; C-p kkc-prev
-;; $BA0$NJQ498uJd$rI=<((B
-;; kkc-show-conversion-list-count $B0J>eB3$1$FBG$F$P!"JQ498uJd%j%9(B
-;; $B%H$r%(%3!<%(%j%"$KI=<((B
+;; 前の変換候補を表示
+;; kkc-show-conversion-list-count 以上続けて打てば、変換候補リス
+;; トをエコーエリアに表示
;; l kkc-show-conversion-list-or-next-group
-;; $B:G9b#1#08D$^$G$NJQ498uJd$r%(%3!<%(%j%"$KI=<(!#(B
-;; $BB3$1$FBG$?$l$l$P!"<!$N#1#08uJd$rI=<(!#(B
+;; 最高10個までの変換候補をエコーエリアに表示。
+;; 続けて打たれれば、次の10候補を表示。
;; L kkc-show-conversion-list-or-prev-group
-;; $B:G9b#1#08D$^$G$NJQ498uJd$r%(%3!<%(%j%"$KI=<(!#(B
-;; $BB3$1$FBG$?$l$l$P!"A0$N#1#08uJd$rI=<(!#(B
+;; 最高10個までの変換候補をエコーエリアに表示。
+;; 続けて打たれれば、前の10候補を表示。
;; 0..9 kkc-select-from-list
-;; $BBG$?$l$??t;z$NJQ498uJd$rA*Br(B
+;; 打たれた数字の変換候補を選択
;; H kkc-hiragana
-;; $BCmL\J8@a$rJ?2>L>$KJQ49(B
+;; 注目文節を平仮名に変換
;; K kkc-katakana
-;; $BCmL\J8@a$rJR2>L>$KJQ49(B
+;; 注目文節を片仮名に変換
;; C-o kkc-longer
-;; $BCmL\J8@a$r8e$m$K0lJ8;z?-$P$9(B
+;; 注目文節を後ろに一文字伸ばす
;; C-i kkc-shorter
-;; $BCmL\J8@a$r8e$m$+$i0lJ8;z=L$a$k(B
+;; 注目文節を後ろから一文字縮める
;; C-f kkc-next-phrase
-;; $BCmL\J8@a$r3NDj$5$;$k!#$b$7;D$j$NF~NO$,$^$@$"$l$P!":G=i$NJ8@a$r(B
-;; $BA*Br$7!"$=$l$rCmL\J8@a$H$7!"$=$N:G=i$NJQ498uJd$rI=<($9$k!#(B
+;; 注目文節を確定させる。もし残りの入力がまだあれば、最初の文節を
+;; 選択し、それを注目文節とし、その最初の変換候補を表示する。
;; DEL, C-c kkc-cancel
-;; $B2>L>4A;zJQ49$r%-%c%s%;%k$7!"%m!<%^;z2>L>JQ49$N%9%F!<%8$KLa$k!#(B
+;; 仮名漢字変換をキャンセルし、ローマ字仮名変換のステージに戻る。
;; return kkc-terminate
-;; $BA4J8@a$r3NDj$5$;$k!#(B
+;; 全文節を確定させる。
;; C-SPC, C-@ kkc-first-char-only
-;; $B:G=i$NJ8;z$r3NDj$5$;!";D$j$O:o=|$9$k!#(B
+;; 最初の文字を確定させ、残りは削除する。
;; C-h kkc-help
-;; $B$3$l$i$N%-!<%P%$%s%I$N%j%9%H$rI=<($9$k!#$"(B
+;; これらのキーバインドのリストを表示する。あ
(quail-define-package
- "japanese" "Japanese" "A$B$"(B"
+ "japanese" "Japanese" "Aあ"
nil
"Japanese input method by Roman transliteration and Kana-Kanji conversion.
@@ -433,7 +433,7 @@ Type \"qq\" to go back to previous input method."
(quail-define-rules ("qq" quail-japanese-switch-package))
(quail-define-package
- "japanese-zenkaku" "Japanese" "$B#A(B"
+ "japanese-zenkaku" "Japanese" "A"
nil
"Japanese zenkaku alpha numeric character input method.
---- Special key bindings ----
@@ -445,30 +445,30 @@ qh: shift to the input method `japanese',
(quail-define-rules
-(" " "$B!!(B") ("!" "$B!*(B") ("\"" "$B!m(B") ("#" "$B!t(B")
-("$" "$B!p(B") ("%" "$B!s(B") ("&" "$B!u(B") ("'" "$B!l(B")
-("(" "$B!J(B") (")" "$B!K(B") ("*" "$B!v(B") ("+" "$B!\(B")
-("," "$B!$(B") ("-" "$B!](B") ("." "$B!%(B") ("/" "$B!?(B")
-("0" "$B#0(B") ("1" "$B#1(B") ("2" "$B#2(B") ("3" "$B#3(B")
-("4" "$B#4(B") ("5" "$B#5(B") ("6" "$B#6(B") ("7" "$B#7(B")
-("8" "$B#8(B") ("9" "$B#9(B") (":" "$B!'(B") (";" "$B!((B")
-("<" "$B!c(B") ("=" "$B!a(B") (">" "$B!d(B") ("?" "$B!)(B")
-("@" "$B!w(B") ("A" "$B#A(B") ("B" "$B#B(B") ("C" "$B#C(B")
-("D" "$B#D(B") ("E" "$B#E(B") ("F" "$B#F(B") ("G" "$B#G(B")
-("H" "$B#H(B") ("I" "$B#I(B") ("J" "$B#J(B") ("K" "$B#K(B")
-("L" "$B#L(B") ("M" "$B#M(B") ("N" "$B#N(B") ("O" "$B#O(B")
-("P" "$B#P(B") ("Q" "$B#Q(B") ("R" "$B#R(B") ("S" "$B#S(B")
-("T" "$B#T(B") ("U" "$B#U(B") ("V" "$B#V(B") ("W" "$B#W(B")
-("X" "$B#X(B") ("Y" "$B#Y(B") ("Z" "$B#Z(B") ("[" "$B!N(B")
-("\\" "$B!o(B") ("]" "$B!O(B") ("^" "$B!0(B") ("_" "$B!2(B")
-("`" "$B!F(B") ("a" "$B#a(B") ("b" "$B#b(B") ("c" "$B#c(B")
-("d" "$B#d(B") ("e" "$B#e(B") ("f" "$B#f(B") ("g" "$B#g(B")
-("h" "$B#h(B") ("i" "$B#i(B") ("j" "$B#j(B") ("k" "$B#k(B")
-("l" "$B#l(B") ("m" "$B#m(B") ("n" "$B#n(B") ("o" "$B#o(B")
-("p" "$B#p(B") ("q" "$B#q(B") ("r" "$B#r(B") ("s" "$B#s(B")
-("t" "$B#t(B") ("u" "$B#u(B") ("v" "$B#v(B") ("w" "$B#w(B")
-("x" "$B#x(B") ("y" "$B#y(B") ("z" "$B#z(B") ("{" "$B!P(B")
-("|" "$B!C(B") ("}" "$B!Q(B") ("~" "$B!A(B")
+(" " " ") ("!" "!") ("\"" "″") ("#" "#")
+("$" "$") ("%" "%") ("&" "&") ("'" "′")
+("(" "(") (")" ")") ("*" "*") ("+" "+")
+("," ",") ("-" "−") ("." ".") ("/" "/")
+("0" "0") ("1" "1") ("2" "2") ("3" "3")
+("4" "4") ("5" "5") ("6" "6") ("7" "7")
+("8" "8") ("9" "9") (":" ":") (";" ";")
+("<" "<") ("=" "=") (">" ">") ("?" "?")
+("@" "@") ("A" "A") ("B" "B") ("C" "C")
+("D" "D") ("E" "E") ("F" "F") ("G" "G")
+("H" "H") ("I" "I") ("J" "J") ("K" "K")
+("L" "L") ("M" "M") ("N" "N") ("O" "O")
+("P" "P") ("Q" "Q") ("R" "R") ("S" "S")
+("T" "T") ("U" "U") ("V" "V") ("W" "W")
+("X" "X") ("Y" "Y") ("Z" "Z") ("[" "[")
+("\\" "¥") ("]" "]") ("^" "^") ("_" "_")
+("`" "‘") ("a" "a") ("b" "b") ("c" "c")
+("d" "d") ("e" "e") ("f" "f") ("g" "g")
+("h" "h") ("i" "i") ("j" "j") ("k" "k")
+("l" "l") ("m" "m") ("n" "n") ("o" "o")
+("p" "p") ("q" "q") ("r" "r") ("s" "s")
+("t" "t") ("u" "u") ("v" "v") ("w" "w")
+("x" "x") ("y" "y") ("z" "z") ("{" "{")
+("|" "|") ("}" "}") ("~" "〜")
("qq" quail-japanese-switch-package)
("qh" quail-japanese-switch-package)
@@ -485,7 +485,7 @@ qh: shift to the input method `japanese',
(quail-define-package
"japanese-hankaku-kana"
- "Japanese" "(I1(B"
+ "Japanese" "ア"
nil
"Japanese hankaku katakana input method by Roman transliteration.
---- Special key bindings ----
@@ -514,7 +514,7 @@ qq: toggle between this input method and the input method `japanese-ascii'.
trans)))
(quail-define-package
- "japanese-hiragana" "Japanese" "$B$"(B"
+ "japanese-hiragana" "Japanese" "あ"
nil
"Japanese hiragana input method by Roman transliteration."
nil t t nil nil nil nil nil
@@ -535,7 +535,7 @@ qq: toggle between this input method and the input method `japanese-ascii'.
control-flag)
(quail-define-package
- "japanese-katakana" "Japanese" "$B%"(B"
+ "japanese-katakana" "Japanese" "ア"
nil
"Japanese katakana input method by Roman transliteration."
nil t t nil nil nil nil nil
diff --git a/lisp/leim/quail/latin-post.el b/lisp/leim/quail/latin-post.el
index 60c0fd13709..589978f31be 100644
--- a/lisp/leim/quail/latin-post.el
+++ b/lisp/leim/quail/latin-post.el
@@ -739,6 +739,54 @@ Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\='
("z~~" ["z~"])
)
+;;; Hawaiian postfix input method. It's a small subset of Latin-4
+;;; with the addition of an ʻokina mapping. Hopefully the ʻokina shows
+;;; correctly on most displays.
+
+;;; This reference is an authoritative guide to Hawaiian orthography:
+;;; http://www2.hawaii.edu/~strauch/tips/HawaiianOrthography.html
+
+;;; Initial coding 2018-09-08 Bob Newell, Honolulu, Hawaiʻi
+;;; Comments to bobnewell@bobnewell.net
+
+(quail-define-package
+ "hawaiian-postfix" "Hawaiian Postfix" "H<" t
+ "Hawaiian characters input method with postfix modifiers
+
+ | postfix | examples
+ ------------+---------+----------
+ ʻokina | \\=` | \\=` -> ʻ
+ kahakō | - | a- -> ā
+
+Doubling the postfix separates the letter and postfix. a-- -> a-
+" nil t nil nil nil nil nil nil nil nil t)
+
+(quail-define-rules
+ ("A-" ?Ā)
+ ("E-" ?Ē)
+ ("I~" ?Ĩ)
+ ("O-" ?Ō)
+ ("U-" ?Ū)
+ ("a-" ?ā)
+ ("e-" ?ē)
+ ("i-" ?ī)
+ ("o-" ?ō)
+ ("u-" ?ū)
+ ("`" ?ʻ)
+
+ ("A--" ["A-"])
+ ("E--" ["E-"])
+ ("I--" ["I-"])
+ ("O--" ["O-"])
+ ("U--" ["U-"])
+ ("a--" ["a-"])
+ ("e--" ["e-"])
+ ("i--" ["i-"])
+ ("o--" ["o-"])
+ ("u--" ["u-"])
+ ("``" ["`"])
+ )
+
(quail-define-package
"latin-5-postfix" "Latin-5" "5<" t
"Latin-5 characters input method with postfix modifiers
@@ -1103,6 +1151,7 @@ szz -> sz
("UE" ?Ü)
("ue" ?ü)
("sz" ?ß)
+ ("SZ" ?ẞ)
("AEE" ["AE"])
("aee" ["ae"])
@@ -1111,6 +1160,7 @@ szz -> sz
("UEE" ["UE"])
("uee" ["ue"])
("szz" ["sz"])
+ ("SZZ" ["SZ"])
("ge" ["ge"])
("eue" ["eue"])
("Eue" ["Eue"])
@@ -2184,6 +2234,7 @@ Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\='
("R~" ?Ř)
("S'" ?Ś)
("S," ?Ş)
+ ("S/" ?ẞ)
("S^" ?Ŝ)
("S~" ?Š)
("T," ?Ţ)
diff --git a/lisp/leim/quail/latin-pre.el b/lisp/leim/quail/latin-pre.el
index 150ab10c874..bcf81f4a145 100644
--- a/lisp/leim/quail/latin-pre.el
+++ b/lisp/leim/quail/latin-pre.el
@@ -320,7 +320,7 @@ Key translation rules are:
effect | prefix | examples
------------+--------+------------------
- tilde | ~ | ~a -> ă
+ breve | ~ | ~a -> ă
circumflex | ^ | ^a -> â, ^i -> î
cedilla | , | ,s -> ş, ,t -> ţ
~ | ~ | ~~ -> ~
@@ -342,11 +342,11 @@ Key translation rules are:
effect | prefix | examples
------------+--------+------------------
- tilde | \" | \"a -> â
- circumflex | \\=' | \\='a -> â, \\='i -> î
- cedilla | \\=' | \\='s -> ş, \\='t -> ţ
- \\=' | \\=' | \\='\\=' -> \\='
- \" | \" | \"\" -> \"
+ breve | \\=' | \\='a -> ă
+ circumflex | \" \\=' | \"a -> â \\='i -> î
+ cedilla | \\=' | \\='s -> ş \\='t -> ţ
+ \\=' | \\=' | \\='\\=' -> \\='
+ \" | \" | \"\" -> \"
" nil t nil nil nil nil nil nil nil nil t)
(quail-define-rules
@@ -361,13 +361,14 @@ Key translation rules are:
"german-prefix" "German" "DE>" t
"German (Deutsch) input method with prefix modifiers
Key translation rules are:
- \"A -> Ä -> \"O -> Ö \"U -> Ü \"s -> ß
+ \"A -> Ä -> \"O -> Ö \"S -> ẞ \"U -> Ü \"s -> ß
" nil t nil nil nil nil nil nil nil nil t)
(quail-define-rules
("\"A" ?Ä)
("\"O" ?Ö)
("\"U" ?Ü)
+ ("\"S" ?ẞ)
("\"a" ?ä)
("\"o" ?ö)
("\"u" ?ü)
@@ -605,7 +606,7 @@ Key translation rules are:
circumflex | ^ | ^a -> â
diaeresis | \" | \"a -> ä \"\" -> ¨
cedilla | ~ | ~c -> ç ~s -> ş ~~ -> ¸
- dot above | / . | /g -> ġ .o -> ġ
+ dot above | / . | /g -> ġ .g -> ġ
misc | \" ~ / | \"s -> ß ~g -> ğ ~u -> ŭ /h -> ħ /i -> ı
symbol | ~ | ~\\=` -> ˘ /# -> £ /$ -> ¤ // -> °
" nil t nil nil nil nil nil nil nil nil t)
@@ -1088,15 +1089,15 @@ of characters from a single Latin-N charset.
effect | prefix | examples
------------+--------+----------
- acute | \\=' | \\='a -> á, \\='\\=' -> ´
+ acute | \\=' | \\='a -> á \\='\\=' -> ´
grave | \\=` | \\=`a -> à
circumflex | ^ | ^a -> â
diaeresis | \" | \"a -> ä \"\" -> ¨
tilde | ~ | ~a -> ã
- cedilla | ~ | ~c -> ç
+ cedilla | , ~ | ,c -> ç ~c -> ç
+ caron | ~ | ~c -> č ~g -> ğ
breve | ~ | ~a -> ă
- caron | ~ | ~c -> č
- dot above | ~ / . | ~o -> ġ /o -> ġ .o -> ġ
+ dot above | / . | /g -> ġ .g -> ġ
misc | \" ~ / | \"s -> ß ~d -> ð ~t -> þ /a -> å /e -> æ /o -> ø
symbol | ~ | ~> -> » ~< -> « ~! -> ¡ ~? -> ¿ ~~ -> ¸
symbol | _ / | _o -> º _a -> ª // -> ° /\\ -> × _y -> ¥
@@ -1175,6 +1176,7 @@ of characters from a single Latin-N charset.
("\"E" ?Ë)
("\"I" ?Ï)
("\"O" ?Ö)
+ ("\"S" ?ẞ)
("\"U" ?Ü)
("\"W" ?Ẅ)
("\"Y" ?Ÿ)
@@ -1250,7 +1252,10 @@ of characters from a single Latin-N charset.
("~>" ?\»)
("~?" ?¿)
("~A" ?Ã)
+ ("~A" ?Ă)
("~C" ?Ç)
+ ("~C" ?Č)
+ (",C" ?Ç)
("~D" ?Ð)
("~G" ?Ğ)
("~N" ?Ñ)
@@ -1263,13 +1268,15 @@ of characters from a single Latin-N charset.
("~Z" ?Ž)
("~`" ?˘)
("~a" ?ã)
+ ("~a" ?ă)
("~c" ?ç)
+ ("~c" ?č)
+ (",c" ?ç)
("~d" ?ð)
("~e" ?€)
("~g" ?ğ)
("~n" ?ñ)
("~o" ?õ)
- ("~o" ?ġ)
("~p" ?¶)
("~s" ?§)
("~s" ?ş)
@@ -1283,4 +1290,52 @@ of characters from a single Latin-N charset.
("~~" ?¸)
)
+;;; Hawaiian prefix input method. It's a small subset of Latin-4
+;;; with the addition of an ʻokina mapping. Hopefully the ʻokina shows
+;;; correctly on most displays.
+
+;;; This reference is an authoritative guide to Hawaiian orthography:
+;;; http://www2.hawaii.edu/~strauch/tips/HawaiianOrthography.html
+
+;;; Initial coding 2018-09-08 Bob Newell, Honolulu, Hawaiʻi
+;;; Comments to bobnewell@bobnewell.net
+
+(quail-define-package
+ "hawaiian-prefix" "Hawaiian Prefix" "H>" t
+ "Hawaiian characters input method with postfix modifiers
+
+ | prefix | examples
+ ------------+---------+----------
+ ʻokina | \\=` | \\=` -> ʻ
+ kahakō | - | -a -> ā
+
+Doubling the prefix separates the letter and prefix. --a -> -a
+" nil t nil nil nil nil nil nil nil nil t)
+
+(quail-define-rules
+ ("-A" ?Ā)
+ ("-E" ?Ē)
+ ("~I" ?Ĩ)
+ ("-O" ?Ō)
+ ("-U" ?Ū)
+ ("-a" ?ā)
+ ("-e" ?ē)
+ ("-i" ?ī)
+ ("-o" ?ō)
+ ("-u" ?ū)
+ ("`" ?ʻ)
+
+ ("--A" ["-A"])
+ ("--E" ["-E"])
+ ("--I" ["-I"])
+ ("--O" ["-O"])
+ ("--U" ["-U"])
+ ("--a" ["-a"])
+ ("--e" ["-e"])
+ ("--i" ["-i"])
+ ("--o" ["-o"])
+ ("--u" ["-u"])
+ ("``" ["`"])
+ )
+
;;; latin-pre.el ends here
diff --git a/lisp/leim/quail/py-punct.el b/lisp/leim/quail/py-punct.el
index 35bd79e99b4..eed70a82eec 100644
--- a/lisp/leim/quail/py-punct.el
+++ b/lisp/leim/quail/py-punct.el
@@ -1,4 +1,4 @@
-;;; py-punct.el --- Quail packages for Chinese (pinyin + extra symbols) -*-coding: iso-2022-7bit;-*-
+;;; py-punct.el --- Quail packages for Chinese (pinyin + extra symbols)
;; Copyright (C) 2001-2019 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -35,16 +35,16 @@
(load "quail/Punct")
(quail-define-package
- "chinese-py-punct" "Chinese-GB" "$AF47{(B"
+ "chinese-py-punct" "Chinese-GB" "拼符"
t
- "$A::WVJdHk(B $AF4Rt7=08(B and `v' for $A1j5c7{:EJdHk(B
+ "汉字输入 拼音方案 and `v' for 标点符号输入
This is the combination of the input methods `chinese-py' and `chinese-punct'.
You can enter normal Chinese characters by the same way as `chinese-py'.
And, you can enter symbols by typing `v' followed by any key sequences
defined in `chinese-punct'.
-For instance, typing `v' and `%' insert `$A#%(B'.
+For instance, typing `v' and `%' insert `%'.
")
(setcar (nthcdr 2 quail-current-package)
@@ -55,9 +55,9 @@ For instance, typing `v' and `%' insert `$A#%(B'.
(load "quail/TONEPY")
(quail-define-package
- "chinese-tonepy-punct" "Chinese-GB" "$AF47{(B"
+ "chinese-tonepy-punct" "Chinese-GB" "拼符"
t
- "$A::WVJdHk(B $A4x5wF4Rt7=08(B and `v' for $A1j5c7{:EJdHk(B
+ "汉字输入 带调拼音方案 and `v' for 标点符号输入
This is the combination of the input methods `chinese-tonepy' and
`chinese-punct'.
@@ -66,7 +66,7 @@ You can enter normal Chinese characters by the same way as
`chinese-tonepy'. And, you can enter symbols by typing `v' followed
by any key sequences defined in `chinese-punct'.
-For instance, typing `v' and `%' insert `$A#%(B'.
+For instance, typing `v' and `%' insert `%'.
")
(setcar (nthcdr 2 quail-current-package)
diff --git a/lisp/leim/quail/pypunct-b5.el b/lisp/leim/quail/pypunct-b5.el
index ef5863101d2..45597a4ef6f 100644
--- a/lisp/leim/quail/pypunct-b5.el
+++ b/lisp/leim/quail/pypunct-b5.el
@@ -1,4 +1,4 @@
-;;; pypunct-b5.el --- Quail packages for Chinese (pinyin + extra symbols) -*-coding: iso-2022-7bit;-*-
+;;; pypunct-b5.el --- Quail packages for Chinese (pinyin + extra symbols)
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007, 2008, 2009, 2010, 2011
@@ -34,9 +34,9 @@
(load "quail/Punct-b5")
(quail-define-package
- "chinese-py-punct-b5" "Chinese-BIG5" "$(03<>K(B"
+ "chinese-py-punct-b5" "Chinese-BIG5" "拼符"
t
- "$(0&d'GTT&,!J3<5x!K(B and `v' for $(0O:X5>KHATT&,(B
+ "中文輸入【拼音】 and `v' for 標點符號輸入
This is the combination of the input method `chinese-py-b5' and
`chinese-punct-b5'.
@@ -45,7 +45,7 @@ You can enter normal Chinese characters by the same way as `chinese-py-b5'.
And, you can enter symbols by typing `v' followed by any key sequences
defined in `chinese-punct-b5'.
-For instance, typing `v' and `%' insert `$(0"h(B'.
+For instance, typing `v' and `%' insert `%'.
")
(setcar (nthcdr 2 quail-current-package)
diff --git a/lisp/leim/quail/sami.el b/lisp/leim/quail/sami.el
new file mode 100644
index 00000000000..7cfd0b7348c
--- /dev/null
+++ b/lisp/leim/quail/sami.el
@@ -0,0 +1,755 @@
+;;; sami.el --- Quail package for inputting Sámi -*-coding: utf-8;-*-
+
+;; Copyright (C) 2019 Free Software Foundation, Inc.
+
+;; Author: Wojciech S. Gac <wojciech.s.gac@gmail.com>
+;; Maintainer: Wojciech S. Gac <wojciech.s.gac@gmail.com>>
+;; Keywords: i18n, multilingual, input method, Sámi
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file implements the following input methods for the Sámi
+;; language
+;; - norwegian-sami-prefix
+;; - bergsland-hasselbrink-sami-prefix
+;; - southern-sami-prefix
+;; - ume-sami-prefix
+;; - northern-sami-prefix
+;; - inari-sami-prefix
+;; - skolt-sami-prefix
+;; - kildin-sami-prefix
+
+;;; Code
+
+(require 'quail)
+
+(quail-define-package
+ "norwegian-sami-prefix" "Sámi" "/NSoS" nil
+ "Norwegian Southern Sámi input method
+
+Alphabet (parenthesized letters are used in foreign names):
+А а B b (C c) D d E e F f G g H h
+I i (Ï ï) J j K k L l M m N n O o
+P p (Q q) R r S s T t U u V v (W w)
+(X x) Y y (Z z) Æ æ Ø ø Å å
+"
+ nil t nil nil nil nil nil nil nil nil t)
+
+(quail-define-rules
+ ("А" ?А)
+ ("а" ?а)
+ ("B" ?B)
+ ("b" ?b)
+ ("C" ?C)
+ ("c" ?c)
+ ("D" ?D)
+ ("d" ?d)
+ ("E" ?E)
+ ("e" ?e)
+ ("F" ?F)
+ ("f" ?f)
+ ("G" ?G)
+ ("g" ?g)
+ ("H" ?H)
+ ("h" ?h)
+ ("I" ?I)
+ ("i" ?i)
+ (":I" ?Ï)
+ (":i" ?ï)
+ ("J" ?J)
+ ("j" ?j)
+ ("K" ?K)
+ ("k" ?k)
+ ("L" ?L)
+ ("l" ?l)
+ ("M" ?M)
+ ("m" ?m)
+ ("N" ?N)
+ ("n" ?n)
+ ("O" ?O)
+ ("o" ?o)
+ ("P" ?P)
+ ("p" ?p)
+ ("Q" ?Q)
+ ("q" ?q)
+ ("R" ?R)
+ ("r" ?r)
+ ("S" ?S)
+ ("s" ?s)
+ ("T" ?T)
+ ("t" ?t)
+ ("U" ?U)
+ ("u" ?u)
+ ("V" ?V)
+ ("v" ?v)
+ ("W" ?W)
+ ("w" ?w)
+ ("X" ?X)
+ ("x" ?x)
+ ("Y" ?Y)
+ ("y" ?y)
+ ("Z" ?Z)
+ ("z" ?z)
+ ("AE" ?Æ)
+ ("ae" ?æ)
+ ("/O" ?Ø)
+ ("/o" ?ø)
+ ("/A" ?Å)
+ ("/a" ?å))
+
+(quail-define-package
+ "bergsland-hasselbrink-sami-prefix" "Sámi" "/BHS" nil
+ "Bergsland-Hasselbrink Southern Sámi input method
+
+Alphabet:
+А а Â â Á á B b C c Č č D d Đ đ
+E e F f G g H h I i Î î J j K k
+L l M m N n Ŋ ŋ O o P p R r S s
+Š š T t U u V v Y y Z z Ž ž Ä ä
+Æ æ Ö ö Å å '
+"
+ nil t nil nil nil nil nil nil nil nil t)
+
+(quail-define-rules
+ ("А" ?А)
+ ("а" ?а)
+ ("^A" ?Â)
+ ("^a" ?â)
+ ("'A" ?Á)
+ ("'a" ?á)
+ ("B" ?B)
+ ("b" ?b)
+ ("C" ?C)
+ ("c" ?c)
+ ("^C" ?Č)
+ ("^c" ?č)
+ ("D" ?D)
+ ("d" ?d)
+ ("-D" ?Đ)
+ ("-d" ?đ)
+ ("E" ?E)
+ ("e" ?e)
+ ("F" ?F)
+ ("f" ?f)
+ ("G" ?G)
+ ("g" ?g)
+ ("H" ?H)
+ ("h" ?h)
+ ("I" ?I)
+ ("i" ?i)
+ ("^I" ?Î)
+ ("^i" ?î)
+ ("J" ?J)
+ ("j" ?j)
+ ("K" ?K)
+ ("k" ?k)
+ ("L" ?L)
+ ("l" ?l)
+ ("M" ?M)
+ ("m" ?m)
+ ("N" ?N)
+ ("n" ?n)
+ ("/N" ?Ŋ)
+ ("/n" ?ŋ)
+ ("O" ?O)
+ ("o" ?o)
+ ("P" ?P)
+ ("p" ?p)
+ ("R" ?R)
+ ("r" ?r)
+ ("S" ?S)
+ ("s" ?s)
+ ("^S" ?Š)
+ ("^s" ?š)
+ ("T" ?T)
+ ("t" ?t)
+ ("U" ?U)
+ ("u" ?u)
+ ("V" ?V)
+ ("v" ?v)
+ ("Y" ?Y)
+ ("y" ?y)
+ ("Z" ?Z)
+ ("z" ?z)
+ ("^Z" ?Ž)
+ ("^z" ?ž)
+ (":A" ?Ä)
+ (":a" ?ä)
+ ("AE" ?Æ)
+ ("ae" ?æ)
+ (":O" ?Ö)
+ (":o" ?ö)
+ ("/A" ?Å)
+ ("/a" ?å))
+
+(quail-define-package
+ "southern-sami-prefix" "Sámi" "/SoS" nil
+ "Contemporary Southern Sámi input method
+
+Alphabet (parenthesized letters are used in foreign names):
+А а B b (C c) D d E e F f G g H h
+I i (Ï ï) J j K k L l M m N n O o
+P p (Q q) R r S s T t U u V v (W w)
+(X x) Y y (Z z) Ä ä Ö ö Å å
+"
+ nil t nil nil nil nil nil nil nil nil t)
+
+(quail-define-rules
+ ("А" ?А)
+ ("а" ?а)
+ ("B" ?B)
+ ("b" ?b)
+ ("C" ?C)
+ ("c" ?c)
+ ("D" ?D)
+ ("d" ?d)
+ ("E" ?E)
+ ("e" ?e)
+ ("F" ?F)
+ ("f" ?f)
+ ("G" ?G)
+ ("g" ?g)
+ ("H" ?H)
+ ("h" ?h)
+ ("I" ?I)
+ ("i" ?i)
+ (":I" ?Ï)
+ (":i" ?ï)
+ ("J" ?J)
+ ("j" ?j)
+ ("K" ?K)
+ ("k" ?k)
+ ("L" ?L)
+ ("l" ?l)
+ ("M" ?M)
+ ("m" ?m)
+ ("N" ?N)
+ ("n" ?n)
+ ("O" ?O)
+ ("o" ?o)
+ ("P" ?P)
+ ("p" ?p)
+ ("Q" ?Q)
+ ("q" ?q)
+ ("R" ?R)
+ ("r" ?r)
+ ("S" ?S)
+ ("s" ?s)
+ ("T" ?T)
+ ("t" ?t)
+ ("U" ?U)
+ ("u" ?u)
+ ("V" ?V)
+ ("v" ?v)
+ ("W" ?W)
+ ("w" ?w)
+ ("X" ?X)
+ ("x" ?x)
+ ("Y" ?Y)
+ ("y" ?y)
+ ("Z" ?Z)
+ ("z" ?z)
+ (":A" ?Ä)
+ (":a" ?ä)
+ (":O" ?Ö)
+ (":o" ?ö)
+ ("/A" ?Å)
+ ("/a" ?å))
+
+(quail-define-package
+ "ume-sami-prefix" "Sámi" "/UmS" nil
+ "Ume Sámi input method
+
+Alphabet:
+А а Á á B b D d Đ đ E e F f G g
+H h I i Ï ï J j K k L l M m N n
+Ŋ ŋ O o P p R r S s T t Ŧ ŧ U u
+Ü ü V v Y y Å å Ä ä Ö ö
+"
+ nil t nil nil nil nil nil nil nil nil t)
+
+(quail-define-rules
+ ("А" ?А)
+ ("а" ?а)
+ ("'A" ?Á)
+ ("'a" ?á)
+ ("B" ?B)
+ ("b" ?b)
+ ("D" ?D)
+ ("d" ?d)
+ ("-D" ?Đ)
+ ("-d" ?đ)
+ ("E" ?E)
+ ("e" ?e)
+ ("F" ?F)
+ ("f" ?f)
+ ("G" ?G)
+ ("g" ?g)
+ ("H" ?H)
+ ("h" ?h)
+ ("I" ?I)
+ ("i" ?i)
+ (":I" ?Ï)
+ (":i" ?ï)
+ ("J" ?J)
+ ("j" ?j)
+ ("K" ?K)
+ ("k" ?k)
+ ("L" ?L)
+ ("l" ?l)
+ ("M" ?M)
+ ("m" ?m)
+ ("N" ?N)
+ ("n" ?n)
+ ("/N" ?Ŋ)
+ ("/n" ?ŋ)
+ ("O" ?O)
+ ("o" ?o)
+ ("P" ?P)
+ ("p" ?p)
+ ("R" ?R)
+ ("r" ?r)
+ ("S" ?S)
+ ("s" ?s)
+ ("T" ?T)
+ ("t" ?t)
+ ("-T" ?Ŧ)
+ ("-t" ?ŧ)
+ ("U" ?U)
+ ("u" ?u)
+ (":U" ?Ü)
+ (":u" ?ü)
+ ("V" ?V)
+ ("v" ?v)
+ ("Y" ?Y)
+ ("y" ?y)
+ ("/A" ?Å)
+ ("/a" ?å)
+ (":A" ?Ä)
+ (":a" ?ä)
+ (":O" ?Ö)
+ (":o" ?ö)
+ )
+
+(quail-define-package
+ "northern-sami-prefix" "Sámi" "/NoS" nil
+ "Northern Sámi input method
+
+Alphabet:
+А а Á á B b C c Č č D d Đ đ E e
+F f G g H h I i J j K k L l M m
+N n Ŋ ŋ O o P p R r S s Š š T t
+Ŧ ŧ U u V v Z z Ž ž
+"
+ nil t nil nil nil nil nil nil nil nil t)
+
+(quail-define-rules
+ ("А" ?А)
+ ("а" ?а)
+ ("'A" ?Á)
+ ("'a" ?á)
+ ("B" ?B)
+ ("b" ?b)
+ ("C" ?C)
+ ("c" ?c)
+ ("^C" ?Č)
+ ("^c" ?č)
+ ("D" ?D)
+ ("d" ?d)
+ ("-D" ?Đ)
+ ("-d" ?đ)
+ ("E" ?E)
+ ("e" ?e)
+ ("F" ?F)
+ ("f" ?f)
+ ("G" ?G)
+ ("g" ?g)
+ ("H" ?H)
+ ("h" ?h)
+ ("I" ?I)
+ ("i" ?i)
+ ("J" ?J)
+ ("j" ?j)
+ ("K" ?K)
+ ("k" ?k)
+ ("L" ?L)
+ ("l" ?l)
+ ("M" ?M)
+ ("m" ?m)
+ ("N" ?N)
+ ("n" ?n)
+ ("/N" ?Ŋ)
+ ("/n" ?ŋ)
+ ("O" ?O)
+ ("o" ?o)
+ ("P" ?P)
+ ("p" ?p)
+ ("R" ?R)
+ ("r" ?r)
+ ("S" ?S)
+ ("s" ?s)
+ ("^S" ?Š)
+ ("^s" ?š)
+ ("T" ?T)
+ ("t" ?t)
+ ("-T" ?Ŧ)
+ ("-t" ?ŧ)
+ ("U" ?U)
+ ("u" ?u)
+ ("V" ?V)
+ ("v" ?v)
+ ("Z" ?Z)
+ ("z" ?z)
+ ("^Z" ?Ž)
+ ("^z" ?ž)
+ )
+
+(quail-define-package
+ "inari-sami-prefix" "Sámi" "/InS" nil
+ "Inari Sámi input method
+
+Alphabet (parenthesized letters are used in foreign names only):
+А а Â â B b C c Č č D d Đ đ E e
+F f G g H h I i J j K k L l M m
+N n O o P p (Q q) R r S s Š š T t
+U u V v (W w) (X x) Y y Z z Ž ž Ä ä
+Á á Å å Ö ö
+"
+ nil t nil nil nil nil nil nil nil nil t)
+
+(quail-define-rules
+ ("А" ?А)
+ ("а" ?а)
+ ("^A" ?Â)
+ ("^a" ?â)
+ ("B" ?B)
+ ("b" ?b)
+ ("C" ?C)
+ ("c" ?c)
+ ("^C" ?Č)
+ ("^c" ?č)
+ ("D" ?D)
+ ("d" ?d)
+ ("-D" ?Đ)
+ ("-d" ?đ)
+ ("E" ?E)
+ ("e" ?e)
+ ("F" ?F)
+ ("f" ?f)
+ ("G" ?G)
+ ("g" ?g)
+ ("H" ?H)
+ ("h" ?h)
+ ("I" ?I)
+ ("i" ?i)
+ ("J" ?J)
+ ("j" ?j)
+ ("K" ?K)
+ ("k" ?k)
+ ("L" ?L)
+ ("l" ?l)
+ ("M" ?M)
+ ("m" ?m)
+ ("N" ?N)
+ ("n" ?n)
+ ("O" ?O)
+ ("o" ?o)
+ ("P" ?P)
+ ("p" ?p)
+ ("Q" ?Q)
+ ("q" ?q)
+ ("R" ?R)
+ ("r" ?r)
+ ("S" ?S)
+ ("s" ?s)
+ ("^S" ?Š)
+ ("^s" ?š)
+ ("T" ?T)
+ ("t" ?t)
+ ("U" ?U)
+ ("u" ?u)
+ ("V" ?V)
+ ("v" ?v)
+ ("W" ?W)
+ ("w" ?w)
+ ("X" ?X)
+ ("x" ?x)
+ ("Y" ?Y)
+ ("y" ?y)
+ ("Z" ?Z)
+ ("z" ?z)
+ ("^Z" ?Ž)
+ ("^z" ?ž)
+ (":A" ?Ä)
+ (":a" ?ä)
+ ("'A" ?Á)
+ ("'a" ?á)
+ ("/A" ?Å)
+ ("/a" ?å)
+ (":O" ?Ö)
+ (":o" ?ö))
+
+(quail-define-package
+ "skolt-sami-prefix" "Sámi" "/SkS" nil
+ "Skolt Sámi input method
+
+Alphabet (parenthesized letters are used in foreign names only):
+А а Â â B b C c Č č Ʒ ʒ Ǯ ǯ D d
+Đ đ E e F f G g Ǧ ǧ Ǥ ǥ H h I i
+J j K k Ǩ ǩ L l M m N n Ŋ ŋ O o
+Õ õ P p (Q q) R r S s Š š T t U u
+V v (W w) (X x) (Y y) Z z Ž ž Å å Ä ä
+(Ö ö) ʹ
+"
+ nil t nil nil nil nil nil nil nil nil t)
+
+(quail-define-rules
+ ("A" ?А)
+ ("a" ?а)
+ ("^A" ?Â)
+ ("^a" ?â)
+ ("B" ?B)
+ ("b" ?b)
+ ("C" ?C)
+ ("c" ?c)
+ ("^C" ?Č)
+ ("^c" ?č)
+ ("/X" ?Ʒ)
+ ("/x" ?ʒ)
+ ("^X" ?Ǯ)
+ ("^x" ?ǯ)
+ ("D" ?D)
+ ("d" ?d)
+ ("-D" ?Đ)
+ ("-d" ?đ)
+ ("E" ?E)
+ ("e" ?e)
+ ("F" ?F)
+ ("f" ?f)
+ ("G" ?G)
+ ("g" ?g)
+ ("^G" ?Ǧ)
+ ("^g" ?ǧ)
+ ("-G" ?Ǥ)
+ ("-g" ?ǥ)
+ ("H" ?H)
+ ("h" ?h)
+ ("I" ?I)
+ ("i" ?i)
+ ("J" ?J)
+ ("j" ?j)
+ ("K" ?K)
+ ("k" ?k)
+ ("^K" ?Ǩ)
+ ("^k" ?ǩ)
+ ("L" ?L)
+ ("l" ?l)
+ ("M" ?M)
+ ("m" ?m)
+ ("N" ?N)
+ ("n" ?n)
+ ("/N" ?Ŋ)
+ ("/n" ?ŋ)
+ ("O" ?O)
+ ("o" ?o)
+ ("~O" ?Õ)
+ ("~o" ?õ)
+ ("P" ?P)
+ ("p" ?p)
+ ("Q" ?Q)
+ ("q" ?q)
+ ("R" ?R)
+ ("r" ?r)
+ ("S" ?S)
+ ("s" ?s)
+ ("^S" ?Š)
+ ("^s" ?š)
+ ("T" ?T)
+ ("t" ?t)
+ ("U" ?U)
+ ("u" ?u)
+ ("V" ?V)
+ ("v" ?v)
+ ("W" ?W)
+ ("w" ?w)
+ ("X" ?X)
+ ("x" ?x)
+ ("Y" ?Y)
+ ("y" ?y)
+ ("Z" ?Z)
+ ("z" ?z)
+ ("^Z" ?Ž)
+ ("^z" ?ž)
+ ("/A" ?Å)
+ ("/a" ?å)
+ (":A" ?Ä)
+ (":a" ?ä)
+ (":O" ?Ö)
+ (":o" ?ö))
+
+(quail-define-package
+ "kildin-sami-prefix" "Sámi" "/KiS" nil
+ "Kildin Sámi input method
+
+Alphabet (parenthesized letters are used in foreign names only):
+А а А̄ а̄ Ӓ ӓ Б б В в Г г Д д Е е Е̄ е̄
+Ё ё Ё̄ ё̄ Ж ж З з Һ һ (') И и Ӣ ӣ Й й
+Ј ј (Ҋ ҋ) К к Л л Ӆ ӆ М м Ӎ ӎ Н н Ӊ ӊ
+Ӈ ӈ О о О̄ о̄ П п Р р Ҏ ҏ С с Т т У у
+Ӯ ӯ Ф ф Х х Ц ц Ч ч Ш ш Щ щ Ъ ъ Ы ы
+Ь ь Ҍ ҍ Э э Э̄ э̄ Ӭ ӭ Ю ю Ю̄ ю̄ Я я Я̄ я̄
+")
+
+(quail-define-rules
+ ("1" ?1)
+ ("2" ?2)
+ ("3" ?3)
+ ("4" ?4)
+ ("5" ?5)
+ ("6" ?6)
+ ("7" ?7)
+ ("8" ?8)
+ ("9" ?9)
+ ("0" ?0)
+ ("-" ?-)
+ ("=" ?ч)
+ ("`" ?ю)
+ ("-`" ["ю̄"])
+ ("q" ?я)
+ ("-q" ["я̄"])
+ ("w" ?в)
+ ("e" ?е)
+ ("-e" ["е̄"])
+ ("-@" ["ё̄"])
+ ("r" ?р)
+ ("-r" ?ҏ)
+ ("t" ?т)
+ ("y" ?ы)
+ ("u" ?у)
+ ("-u" ?ӯ)
+ ("i" ?и)
+ ("o" ?о)
+ ("-o" ["о̄"])
+ ("p" ?п)
+ ("[" ?ш)
+ ("]" ?щ)
+ ("a" ?а)
+ ("-a" ["а̄"])
+ (":a" ?ӓ)
+ ("s" ?с)
+ ("d" ?д)
+ ("f" ?ф)
+ ("g" ?г)
+ ("h" ?х)
+ ("/h" ?һ)
+ ("j" ?й)
+ ("-j" ["ӣ"])
+ ("'j" ?ҋ)
+ ("/j" ?ј)
+ ("k" ?к)
+ ("l" ?л)
+ ("'l" ?ӆ)
+ (";" ?\;)
+ ("'" ?')
+ ("\\" ?э)
+ ("-\\" ["э̄"])
+ (":\\" ?ӭ)
+ ("z" ?з)
+ ("x" ?ь)
+ ("-x" ?ҍ)
+ ("c" ?ц)
+ ("v" ?ж)
+ ("b" ?б)
+ ("n" ?н)
+ ("'n" ?ӊ)
+ (",n" ?ӈ)
+ ("m" ?м)
+ ("'m" ?ӎ)
+ ("," ?,)
+ ("." ?.)
+ ("/" ?/)
+
+ ("!" ?!)
+ ("@" ?ё)
+ ("#" ?ъ)
+ ("$" ?Ё)
+ ("%" ?%)
+ ("^" ?^)
+ ("&" ?&)
+ ("*" ?*)
+ ("(" ?\()
+ (")" ?\))
+ ("_" ?_)
+ ("+" ?Ч)
+ ("~" ?Ю)
+ ("-~" ["Ю̄"])
+ ("Q" ?Я)
+ ("-Q" ["Я̄"])
+ ("W" ?В)
+ ("E" ?Е)
+ ("-E" ["Е̄"])
+ ("-$" ["Ё̄"])
+ ("R" ?Р)
+ ("-R" ?Ҏ)
+ ("T" ?Т)
+ ("Y" ?Ы)
+ ("U" ?У)
+ ("-U" ["Ӯ"])
+ ("I" ?И)
+ ("O" ?О)
+ ("-O" ["О̄"])
+ ("P" ?П)
+ ("{" ?Ш)
+ ("}" ?Щ)
+ ("A" ?А)
+ ("-A" ["А̄"])
+ (":A" ?Ӓ)
+ ("S" ?С)
+ ("D" ?Д)
+ ("F" ?Ф)
+ ("G" ?Г)
+ ("H" ?Х)
+ ("/H" ?Һ)
+ ("J" ?Й)
+ ("-J" ["Ӣ"])
+ ("'J" ?Ҋ)
+ ("/J" ?Ј)
+ ("K" ?К)
+ ("L" ?Л)
+ ("'L" ?Ӆ)
+ (":" ?:)
+ ("\"" ?\")
+ ("|" ?Э)
+ ("-|" ["Э̄"])
+ (":|" ?Ӭ)
+ ("Z" ?З)
+ ("X" ?Ь)
+ ("-X" ?Ҍ)
+ ("C" ?Ц)
+ ("V" ?Ж)
+ ("B" ?Б)
+ ("N" ?Н)
+ ("'N" ?Ӊ)
+ (",N" ?Ӈ)
+ ("M" ?М)
+ ("'M" ?Ӎ)
+ ("<" ?<)
+ (">" ?>)
+ ("?" ??))
+
+;;; sami.el ends here
diff --git a/lisp/linum.el b/lisp/linum.el
index 789b5aadd07..0b4b0083ed6 100644
--- a/lisp/linum.el
+++ b/lisp/linum.el
@@ -75,12 +75,10 @@ and you have to scroll or press \\[recenter-top-bottom] to update the numbers."
;;;###autoload
(define-minor-mode linum-mode
"Toggle display of line numbers in the left margin (Linum mode).
-With a prefix argument ARG, enable Linum mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
Linum mode is a buffer-local minor mode."
:lighter "" ; for desktop.el
+ :append-arg-docstring t
(if linum-mode
(progn
(if linum-eager
diff --git a/lisp/loadhist.el b/lisp/loadhist.el
index 64720524d21..4e5d8e0f38d 100644
--- a/lisp/loadhist.el
+++ b/lisp/loadhist.el
@@ -29,6 +29,8 @@
;;; Code:
+(eval-when-compile (require 'cl-lib))
+
(defun feature-symbols (feature)
"Return the file and list of definitions associated with FEATURE.
The value is actually the element of `load-history'
@@ -94,7 +96,8 @@ A library name is equivalent to the file name that `load-library' would load."
(let ((provides (file-provides file))
(dependents nil))
(dolist (x load-history dependents)
- (when (file-set-intersect provides (file-requires (car x)))
+ (when (and (stringp (car x))
+ (file-set-intersect provides (file-requires (car x))))
(push (car x) dependents)))))
(defun read-feature (prompt &optional loaded-p)
@@ -141,8 +144,6 @@ These are symbols with hooklike values whose names don't end in
`-hook' or `-hooks', from which `unload-feature' should try to remove
pertinent symbols.")
-(define-obsolete-variable-alias 'unload-hook-features-list
- 'unload-function-defs-list "22.2")
(defvar unload-function-defs-list nil
"List of definitions in the Lisp library being unloaded.
diff --git a/lisp/loadup.el b/lisp/loadup.el
index 9e5502dcaeb..67e8aa7d40a 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -26,6 +26,9 @@
;; This is loaded into a bare Emacs to make a dumpable one.
+;; Emacs injects the variable `dump-mode' to tell us how to dump.
+;; We unintern it before allowing user code to run.
+
;; If you add a file to be loaded here, keep the following points in mind:
;; i) If the file is no-byte-compile, explicitly load the .el version.
@@ -54,33 +57,58 @@
;; bidi.c needs for its job.
(setq redisplay--inhibit-bidi t)
+(message "dump mode: %s" dump-mode)
+
;; Add subdirectories to the load-path for files that might get
-;; autoloaded when bootstrapping.
+;; autoloaded when bootstrapping or running Emacs normally.
;; This is because PATH_DUMPLOADSEARCH is just "../lisp".
-(if (or (equal (member "bootstrap" command-line-args) '("bootstrap"))
+(if (or (member dump-mode '("bootstrap" "pbootstrap"))
;; FIXME this is irritatingly fragile.
- (and (stringp (nth 4 command-line-args))
- (string-match "^unidata-gen\\(\\.elc?\\)?$"
- (nth 4 command-line-args)))
- (member (nth 7 command-line-args) '("unidata-gen-file"
- "unidata-gen-charprop"))
- (if (fboundp 'dump-emacs)
- (string-match "src/bootstrap-emacs" (nth 0 command-line-args))
- t))
- (let ((dir (car load-path)))
+ (and (stringp (nth 4 command-line-args))
+ (string-match "^unidata-gen\\(\\.elc?\\)?$"
+ (nth 4 command-line-args)))
+ (member (nth 7 command-line-args) '("unidata-gen-file"
+ "unidata-gen-charprop"))
+ (null dump-mode))
+ (progn
+ ;; Find the entry in load-path that contains Emacs elisp and
+ ;; splice some additional directories in there for the benefit
+ ;; of autoload and regular Emacs use.
+ (let ((subdirs '("emacs-lisp"
+ "progmodes"
+ "language"
+ "international"
+ "textmodes"
+ "vc"))
+ (iter load-path))
+ (while iter
+ (let ((dir (car iter))
+ (subdirs subdirs)
+ esubdirs esubdir)
+ (while subdirs
+ (setq esubdir (expand-file-name (car subdirs) dir))
+ (setq subdirs (cdr subdirs))
+ (if (file-directory-p esubdir)
+ (setq esubdirs (cons esubdir esubdirs))
+ (setq subdirs nil esubdirs nil)))
+ (if esubdirs
+ (progn
+ (setcdr iter (nconc (nreverse esubdirs) (cdr iter)))
+ (setq iter nil))
+ (setq iter (cdr iter))
+ (if (null iter)
+ (signal
+ 'error (list
+ (format-message
+ "Could not find elisp load-path: searched %S"
+ load-path))))))))
;; We'll probably overflow the pure space.
(setq purify-flag nil)
;; Value of max-lisp-eval-depth when compiling initially.
- ;; During bootstrapping the byte-compiler is run interpreted when
- ;; compiling itself, which uses a lot more stack than usual.
- (setq max-lisp-eval-depth 2200)
- (setq load-path (list (expand-file-name "." dir)
- (expand-file-name "emacs-lisp" dir)
- (expand-file-name "progmodes" dir)
- (expand-file-name "language" dir)
- (expand-file-name "international" dir)
- (expand-file-name "textmodes" dir)
- (expand-file-name "vc" dir)))))
+ ;; During bootstrapping the byte-compiler is run interpreted
+ ;; when compiling itself, which uses a lot more stack
+ ;; than usual.
+ (setq max-lisp-eval-depth 2200)))
(if (eq t purify-flag)
;; Hash consing saved around 11% of pure space in my tests.
@@ -88,10 +116,7 @@
(message "Using load-path %s" load-path)
-;; This is a poor man's `last', since we haven't loaded subr.el yet.
-(if (and (fboundp 'dump-emacs)
- (or (equal (member "bootstrap" command-line-args) '("bootstrap"))
- (equal (member "dump" command-line-args) '("dump"))))
+(if dump-mode
(progn
;; To reduce the size of dumped Emacs, we avoid making huge char-tables.
(setq inhibit-load-charset-map t)
@@ -350,15 +375,16 @@ lost after dumping")))
;; file primitive. So the only workable solution to support building
;; in non-ASCII directories is to manipulate unibyte strings in the
;; current locale's encoding.
-(if (and (member (car (last command-line-args)) '("dump" "bootstrap"))
- (fboundp 'dump-emacs)
- (multibyte-string-p default-directory))
+(if (and dump-mode (multibyte-string-p default-directory))
(error "default-directory must be unibyte when dumping Emacs!"))
;; Determine which build number to use
;; based on the executables that now exist.
-(if (and (equal (last command-line-args) '("dump"))
- (fboundp 'dump-emacs)
+(if (and (or
+ (and (equal dump-mode "dump")
+ (fboundp 'dump-emacs))
+ (and (equal dump-mode "pdump")
+ (fboundp 'dump-emacs-portable)))
(not (eq system-type 'ms-dos)))
(let* ((base (concat "emacs-" emacs-version "."))
(exelen (if (eq system-type 'windows-nt) -4))
@@ -368,16 +394,18 @@ lost after dumping")))
(string-to-number
(substring name (length base) exelen))))
files)))
- (setq emacs-repository-version (condition-case nil (emacs-repository-get-version)
- (error nil)))
+ (setq emacs-repository-version (ignore-errors (emacs-repository-get-version))
+ emacs-repository-branch (ignore-errors (emacs-repository-get-branch)))
;; A constant, so we shouldn't change it with `setq'.
(defconst emacs-build-number
(if versions (1+ (apply 'max versions)) 1))))
(message "Finding pointers to doc strings...")
-(if (and (fboundp 'dump-emacs)
- (equal (last command-line-args) '("dump")))
+(if (and (or (and (fboundp 'dump-emacs)
+ (equal dump-mode "dump"))
+ (and (fboundp 'dump-emacs-portable)
+ (equal dump-mode "pdump"))))
(Snarf-documentation "DOC")
(condition-case nil
(Snarf-documentation "DOC")
@@ -446,53 +474,69 @@ lost after dumping")))
;; Make sure we will attempt bidi reordering henceforth.
(setq redisplay--inhibit-bidi nil)
-(if (and (fboundp 'dump-emacs)
- (member (car (last command-line-args)) '("dump" "bootstrap")))
- (progn
- ;; Prevent build-time PATH getting stored in the binary.
- ;; Mainly cosmetic, but helpful for Guix. (Bug#20330)
- ;; Do this here, rather than earlier, so that the above code
- ;; can invoke Git commands and the like.
- (setq exec-path nil)
- (message "Dumping under the name emacs")
+(if dump-mode
+ (let ((output (cond ((equal dump-mode "pdump") "emacs.pdmp")
+ ((equal dump-mode "dump") "emacs")
+ ((equal dump-mode "bootstrap") "emacs")
+ ((equal dump-mode "pbootstrap") "bootstrap-emacs.pdmp")
+ (t (error "unrecognized dump mode %s" dump-mode)))))
+ (message "Dumping under the name %s" output)
(condition-case ()
- (delete-file "emacs")
- (file-error nil))
- ;; We used to dump under the name xemacs, but that occasionally
- ;; confused people installing Emacs (they'd install the file
- ;; under the name `xemacs'), and it's inconsistent with every
- ;; other GNU program's build process.
- (dump-emacs "emacs" "temacs")
- (message "%d pure bytes used" pure-bytes-used)
+ (delete-file output)
+ (file-error nil))
+ ;; On MS-Windows, the current directory is not necessarily the
+ ;; same as invocation-directory.
+ (let (success)
+ (unwind-protect
+ (let ((tmp-dump-mode dump-mode)
+ (dump-mode nil))
+ (if (member tmp-dump-mode '("pdump" "pbootstrap"))
+ (dump-emacs-portable (expand-file-name output invocation-directory))
+ (dump-emacs output "temacs")
+ (message "%d pure bytes used" pure-bytes-used))
+ (setq success t))
+ (unless success
+ (ignore-errors
+ (delete-file output)))))
;; Recompute NAME now, so that it isn't set when we dump.
(if (not (or (eq system-type 'ms-dos)
;; Don't bother adding another name if we're just
;; building bootstrap-emacs.
- (equal (last command-line-args) '("bootstrap"))))
- (let ((name (format "emacs-%s.%d" emacs-version emacs-build-number))
- (exe (if (eq system-type 'windows-nt) ".exe" "")))
- (while (string-match "[^-+_.a-zA-Z0-9]+" name)
- (setq name (concat (downcase (substring name 0 (match-beginning 0)))
- "-"
- (substring name (match-end 0)))))
- (setq name (concat name exe))
- (message "Adding name %s" name)
- ;; When this runs on Windows, invocation-directory is not
- ;; necessarily the current directory.
- (add-name-to-file (expand-file-name (concat "emacs" exe)
- invocation-directory)
- (expand-file-name name invocation-directory)
- t)))
+ (member dump-mode '("pbootstrap" "bootstrap"))))
+ (let ((name (format "emacs-%s.%d" emacs-version emacs-build-number))
+ (exe (if (eq system-type 'windows-nt) ".exe" "")))
+ (while (string-match "[^-+_.a-zA-Z0-9]+" name)
+ (setq name (concat (downcase (substring name 0 (match-beginning 0)))
+ "-"
+ (substring name (match-end 0)))))
+ (message "Adding name %s" (concat name exe))
+ ;; When this runs on Windows, invocation-directory is not
+ ;; necessarily the current directory.
+ (add-name-to-file (expand-file-name (concat "emacs" exe)
+ invocation-directory)
+ (expand-file-name (concat name exe)
+ invocation-directory)
+ t)
+ (when (equal dump-mode "pdump")
+ (message "Adding name %s" (concat name ".pdmp"))
+ (add-name-to-file (expand-file-name "emacs.pdmp"
+ invocation-directory)
+ (expand-file-name (concat name ".pdmp")
+ invocation-directory)
+ t))))
(kill-emacs)))
-;; For machines with CANNOT_DUMP defined in config.h,
-;; this file must be loaded each time Emacs is run.
+;; This file must be loaded each time Emacs is run from scratch, e.g., temacs.
;; So run the startup code now. First, remove `-l loadup' from args.
(if (and (member (nth 1 command-line-args) '("-l" "--load"))
(equal (nth 2 command-line-args) "loadup"))
(setcdr command-line-args (nthcdr 3 command-line-args)))
+;; Don't keep `load-file-name' set during the top-level session!
+;; Otherwise, it breaks a lot of code which does things like
+;; (or load-file-name byte-compile-current-file).
+(setq load-file-name nil)
(eval top-level)
diff --git a/lisp/locate.el b/lisp/locate.el
index a43cecb2a63..452f74610fb 100644
--- a/lisp/locate.el
+++ b/lisp/locate.el
@@ -1,4 +1,4 @@
-;;; locate.el --- interface to the locate command
+;;; locate.el --- interface to the locate command -*- lexical-binding:t -*-
;; Copyright (C) 1996, 1998, 2001-2019 Free Software Foundation, Inc.
@@ -261,7 +261,7 @@ that is, with a prefix arg, you get the default behavior."
"Run locate (like this): "
(cons
(concat (car locate-cmd) " "
- (mapconcat 'identity (cdr locate-cmd) " "))
+ (mapconcat #'identity (cdr locate-cmd) " "))
(+ 2 (length (car locate-cmd))))
nil nil 'locate-history-list))
(let* ((default (locate-word-at-point))
@@ -313,7 +313,7 @@ then `locate-post-command-hook'."
(and (not arg) locate-prompt-for-command))))
;; Find the Locate buffer
- (save-window-excursion
+ (save-window-excursion ;FIXME: What window-excursion?
(set-buffer (get-buffer-create locate-buffer-name))
(locate-mode)
(let ((inhibit-read-only t)
@@ -327,7 +327,7 @@ then `locate-post-command-hook'."
(if run-locate-command
(shell-command search-string locate-buffer-name)
- (apply 'call-process locate-cmd nil t nil locate-cmd-args))
+ (apply #'call-process locate-cmd nil t nil locate-cmd-args))
(and filter
(locate-filter-output filter))
@@ -466,8 +466,8 @@ do not work in subdirectories.
;; Avoid clobbering this variable
(make-local-variable 'dired-subdir-alist)
(setq default-directory "/"
- buffer-read-only t
- selective-display t)
+ buffer-read-only t)
+ (add-to-invisibility-spec '(dired . t))
(dired-alist-add-1 default-directory (point-min-marker))
(set (make-local-variable 'dired-directory) "/")
(set (make-local-variable 'dired-subdir-switches) locate-ls-subdir-switches)
@@ -499,9 +499,9 @@ do not work in subdirectories.
(progn
(kill-buffer locate-buffer-name)
(if locate-current-filter
- (error "Locate: no match for %s in database using filter %s"
+ (user-error "Locate: no match for %s in database using filter %s"
search-string locate-current-filter)
- (error "Locate: no match for %s in database" search-string))))
+ (user-error "Locate: no match for %s in database" search-string))))
(locate-insert-header search-string)
@@ -554,7 +554,7 @@ do not work in subdirectories.
locate-regexp-match
(concat locate-regexp-match ":\n"))
- (insert (apply 'format locate-format-string (reverse locate-format-args)))
+ (insert (apply #'format locate-format-string (reverse locate-format-args)))
(save-excursion
(goto-char (point-min))
diff --git a/lisp/lpr.el b/lisp/lpr.el
index 75ccf445eca..436f9e3e021 100644
--- a/lisp/lpr.el
+++ b/lisp/lpr.el
@@ -258,7 +258,7 @@ for further customization of the printer command."
(defun lpr-print-region (start end switches name)
(let ((buf (current-buffer))
- (nswitches (lpr-flatten-list
+ (nswitches (flatten-tree
(mapcar #'lpr-eval-switch ; Dynamic evaluation
switches)))
(switch-string (if switches
@@ -336,23 +336,7 @@ The characters tab, linefeed, space, return and formfeed are not affected."
((consp arg) (apply (car arg) (cdr arg)))
(t nil)))
-;; `lpr-flatten-list' is defined here (copied from "message.el" and
-;; enhanced to handle dotted pairs as well) until we can get some
-;; sensible autoloads, or `flatten-list' gets put somewhere decent.
-
-;; (lpr-flatten-list '((a . b) c (d . e) (f g h) i . j))
-;; => (a b c d e f g h i j)
-
-(defun lpr-flatten-list (&rest list)
- (lpr-flatten-list-1 list))
-
-(defun lpr-flatten-list-1 (list)
- (cond
- ((null list) nil)
- ((consp list)
- (append (lpr-flatten-list-1 (car list))
- (lpr-flatten-list-1 (cdr list))))
- (t (list list))))
+(define-obsolete-function-alias 'lpr-flatten-list #'flatten-tree "27.1")
(provide 'lpr)
diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el
index bb3a2f03f00..1f2c46834ec 100644
--- a/lisp/ls-lisp.el
+++ b/lisp/ls-lisp.el
@@ -385,13 +385,13 @@ not contain `d', so that a full listing is expected."
;; files we are about to display.
(dolist (elt file-alist)
(setq attr (cdr elt)
- fuid (nth 2 attr)
+ fuid (file-attribute-user-id attr)
uid-len (if (stringp fuid) (string-width fuid)
(length (format "%d" fuid)))
- fgid (nth 3 attr)
+ fgid (file-attribute-group-id attr)
gid-len (if (stringp fgid) (string-width fgid)
(length (format "%d" fgid)))
- file-size (nth 7 attr))
+ file-size (file-attribute-size attr))
(if (> uid-len max-uid-len)
(setq max-uid-len uid-len))
(if (> gid-len max-gid-len)
@@ -418,7 +418,7 @@ not contain `d', so that a full listing is expected."
files (cdr files)
short (car elt)
attr (cdr elt)
- file-size (nth 7 attr))
+ file-size (file-attribute-size attr))
(and attr
(setq sum (+ file-size
;; Even if neither SUM nor file's size
@@ -474,10 +474,14 @@ not contain `d', so that a full listing is expected."
(if (memq ?F switches)
(ls-lisp-classify-file file fattr)
file)
- fattr (nth 7 fattr)
- switches time-index))
- (message "%s: doesn't exist or is inaccessible" file)
- (ding) (sit-for 2))))) ; to show user the message!
+ fattr (file-attribute-size fattr)
+ switches time-index))
+ ;; Emulate what we do on Posix hosts when we call access-file
+ ;; in insert-directory.
+ (signal 'file-error
+ (list "Reading directory"
+ "Directory doesn't exist or is inaccessible"
+ file))))))
(declare-function dired-read-dir-and-switches "dired" (str))
(declare-function dired-goto-next-file "dired" ())
@@ -659,10 +663,9 @@ SWITCHES is a list of characters. Default sorting is alphabetic."
(sort (copy-sequence file-alist) ; modifies its argument!
(cond ((memq ?S switches)
(lambda (x y) ; sorted on size
- ;; 7th file attribute is file size
;; Make largest file come first
- (< (nth 7 (cdr y))
- (nth 7 (cdr x)))))
+ (< (file-attribute-size (cdr y))
+ (file-attribute-size (cdr x)))))
((setq index (ls-lisp-time-index switches))
(lambda (x y) ; sorted on time
(time-less-p (nth index (cdr y))
@@ -719,8 +722,8 @@ FATTR is the file attributes returned by `file-attributes' for the file.
The file type indicators are `/' for directories, `@' for symbolic
links, `|' for FIFOs, `=' for sockets, `*' for regular files that
are executable, and nothing for other types of files."
- (let* ((type (car fattr))
- (modestr (nth 8 fattr))
+ (let* ((type (file-attribute-type fattr))
+ (modestr (file-attribute-modes fattr))
(typestr (substring modestr 0 1))
(file-name (propertize filename 'dired-filename t)))
(cond
@@ -773,35 +776,13 @@ FOLLOWED by null and full filename, SOLELY for full alpha sort."
"Format one line of long ls output for file FILE-NAME.
FILE-ATTR and FILE-SIZE give the file's attributes and size.
SWITCHES and TIME-INDEX give the full switch list and time data."
- (let ((file-type (nth 0 file-attr))
+ (let ((file-type (file-attribute-type file-attr))
;; t for directory, string (name linked to)
;; for symbolic link, or nil.
- (drwxrwxrwx (nth 8 file-attr))) ; attribute string ("drwxrwxrwx")
+ (drwxrwxrwx (file-attribute-modes file-attr)))
(concat (if (memq ?i switches) ; inode number
- (let ((inode (nth 10 file-attr)))
- (if (consp inode)
- (if (consp (cdr inode))
- ;; 2^(24+16) = 1099511627776.0, but
- ;; multiplying by it and then adding the
- ;; other members of the cons cell in one go
- ;; loses precision, since a double does not
- ;; have enough significant digits to hold a
- ;; full 64-bit value. So below we split
- ;; 1099511627776 into high 13 and low 5
- ;; digits and compute in two parts.
- (let ((p1 (* (car inode) 10995116.0))
- (p2 (+ (* (car inode) 27776.0)
- (* (cadr inode) 65536.0)
- (cddr inode))))
- (format " %13.0f%05.0f "
- ;; Use floor to emulate integer
- ;; division.
- (+ p1 (floor p2 100000.0))
- (mod p2 100000.0)))
- (format " %18.0f "
- (+ (* (car inode) 65536.0)
- (cdr inode))))
- (format " %18d " inode))))
+ (let ((inode (file-attribute-inode-number file-attr)))
+ (format " %18d " inode)))
;; nil is treated like "" in concat
(if (memq ?s switches) ; size in K, rounded up
;; In GNU ls, -h affects the size in blocks, displayed
@@ -819,14 +800,14 @@ SWITCHES and TIME-INDEX give the full switch list and time data."
(fceiling (/ file-size 1024.0)))))
drwxrwxrwx ; attribute string
(if (memq 'links ls-lisp-verbosity)
- (format "%3d" (nth 1 file-attr))) ; link count
+ (format "%3d" (file-attribute-link-number file-attr)))
;; Numeric uid/gid are more confusing than helpful;
;; Emacs should be able to make strings of them.
;; They tend to be bogus on non-UNIX platforms anyway so
;; optionally hide them.
(if (memq 'uid ls-lisp-verbosity)
;; uid can be a string or an integer
- (let ((uid (nth 2 file-attr)))
+ (let ((uid (file-attribute-user-id file-attr)))
(format (if (stringp uid)
ls-lisp-uid-s-fmt
ls-lisp-uid-d-fmt)
@@ -834,7 +815,7 @@ SWITCHES and TIME-INDEX give the full switch list and time data."
(if (not (memq ?G switches)) ; GNU ls -- shows group by default
(if (or (memq ?g switches) ; UNIX ls -- no group by default
(memq 'gid ls-lisp-verbosity))
- (let ((gid (nth 3 file-attr)))
+ (let ((gid (file-attribute-group-id file-attr)))
(format (if (stringp gid)
ls-lisp-gid-s-fmt
ls-lisp-gid-d-fmt)
diff --git a/lisp/macros.el b/lisp/macros.el
index 27a14694ee6..ba6a840d60c 100644
--- a/lisp/macros.el
+++ b/lisp/macros.el
@@ -1,4 +1,4 @@
-;;; macros.el --- non-primitive commands for keyboard macros
+;;; macros.el --- non-primitive commands for keyboard macros -*- lexical-binding:t -*-
;; Copyright (C) 1985-1987, 1992, 1994-1995, 2001-2019 Free Software
;; Foundation, Inc.
@@ -31,23 +31,10 @@
;;; Code:
+(require 'kmacro)
+
;;;###autoload
-(defun name-last-kbd-macro (symbol)
- "Assign a name to the last keyboard macro defined.
-Argument SYMBOL is the name to define.
-The symbol's function definition becomes the keyboard macro string.
-Such a \"function\" cannot be called from Lisp, but it is a valid editor command."
- (interactive "SName for last kbd macro: ")
- (or last-kbd-macro
- (user-error "No keyboard macro defined"))
- (and (fboundp symbol)
- (not (stringp (symbol-function symbol)))
- (not (vectorp (symbol-function symbol)))
- (user-error "Function %s is already defined and not a keyboard macro"
- symbol))
- (if (string-equal symbol "")
- (user-error "No command name given"))
- (fset symbol last-kbd-macro))
+(defalias 'name-last-kbd-macro #'kmacro-name-last-macro)
;;;###autoload
(defun insert-kbd-macro (macroname &optional keys)
@@ -66,11 +53,7 @@ To save a kbd macro, visit a file of Lisp code such as your `~/.emacs',
use this command, and then save the file."
(interactive (list (intern (completing-read "Insert kbd macro (name): "
obarray
- (lambda (elt)
- (and (fboundp elt)
- (or (stringp (symbol-function elt))
- (vectorp (symbol-function elt))
- (get elt 'kmacro))))
+ #'kmacro-keyboard-macro-p
t))
current-prefix-arg))
(let (definition)
@@ -137,6 +120,9 @@ use this command, and then save the file."
(prin1 char (current-buffer))
(princ (prin1-char char) (current-buffer))))
(insert ?\]))
+ ;; FIXME: For kmacros, we shouldn't write the (lambda ...)
+ ;; gunk but instead we should write something more abstract like
+ ;; (kmacro-create [<keys>] 0 "%d").
(prin1 definition (current-buffer))))
(insert ")\n")
(if keys
diff --git a/lisp/mail/binhex.el b/lisp/mail/binhex.el
index eb00b87f4c1..19fcbaaf475 100644
--- a/lisp/mail/binhex.el
+++ b/lisp/mail/binhex.el
@@ -1,4 +1,4 @@
-;;; binhex.el --- decode BinHex-encoded text
+;;; binhex.el --- decode BinHex-encoded text -*- lexical-binding:t -*-
;; Copyright (C) 1998-2019 Free Software Foundation, Inc.
@@ -29,8 +29,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
-
(eval-and-compile
(defalias 'binhex-char-int
(if (fboundp 'char-int)
@@ -138,9 +136,9 @@ input and write the converted data to its standard output."
(defun binhex-update-crc (crc char &optional count)
(if (null count) (setq count 1))
(while (> count 0)
- (setq crc (logxor (logand (lsh crc 8) 65280)
+ (setq crc (logxor (logand (ash crc 8) 65280)
(aref binhex-crc-table
- (logxor (logand (lsh crc -8) 255)
+ (logxor (logand (ash crc -8) 255)
char)))
count (1- count)))
crc)
@@ -158,14 +156,14 @@ input and write the converted data to its standard output."
(defun binhex-string-big-endian (string)
(let ((ret 0) (i 0) (len (length string)))
(while (< i len)
- (setq ret (+ (lsh ret 8) (binhex-char-int (aref string i)))
+ (setq ret (+ (ash ret 8) (binhex-char-int (aref string i)))
i (1+ i)))
ret))
(defun binhex-string-little-endian (string)
(let ((ret 0) (i 0) (shift 0) (len (length string)))
(while (< i len)
- (setq ret (+ ret (lsh (binhex-char-int (aref string i)) shift))
+ (setq ret (+ ret (ash (binhex-char-int (aref string i)) shift))
i (1+ i)
shift (+ shift 8)))
ret))
@@ -193,7 +191,7 @@ input and write the converted data to its standard output."
(defvar binhex-last-char)
(defvar binhex-repeat)
-(defun binhex-push-char (char &optional count ignored buffer)
+(defun binhex-push-char (char &optional ignored buffer)
(cond
(binhex-repeat
(if (eq char 0)
@@ -241,13 +239,13 @@ If HEADER-ONLY is non-nil only decode header and return filename."
counter (1+ counter)
inputpos (1+ inputpos))
(cond ((= counter 4)
- (binhex-push-char (lsh bits -16) 1 nil work-buffer)
- (binhex-push-char (logand (lsh bits -8) 255) 1 nil
+ (binhex-push-char (ash bits -16) nil work-buffer)
+ (binhex-push-char (logand (ash bits -8) 255) nil
work-buffer)
- (binhex-push-char (logand bits 255) 1 nil
+ (binhex-push-char (logand bits 255) nil
work-buffer)
(setq bits 0 counter 0))
- (t (setq bits (lsh bits 6)))))
+ (t (setq bits (ash bits 6)))))
(if (null file-name-length)
(with-current-buffer work-buffer
(setq file-name-length (char-after (point-min))
@@ -263,12 +261,12 @@ If HEADER-ONLY is non-nil only decode header and return filename."
(setq tmp (and tmp (not (eq inputpos end)))))
(cond
((= counter 3)
- (binhex-push-char (logand (lsh bits -16) 255) 1 nil
+ (binhex-push-char (logand (ash bits -16) 255) nil
work-buffer)
- (binhex-push-char (logand (lsh bits -8) 255) 1 nil
+ (binhex-push-char (logand (ash bits -8) 255) nil
work-buffer))
((= counter 2)
- (binhex-push-char (logand (lsh bits -10) 255) 1 nil
+ (binhex-push-char (logand (ash bits -10) 255) nil
work-buffer))))
(if header-only nil
(binhex-verify-crc work-buffer
@@ -287,7 +285,7 @@ If HEADER-ONLY is non-nil only decode header and return filename."
(defun binhex-decode-region-external (start end)
"Binhex decode region between START and END using external decoder."
(interactive "r")
- (let ((cbuf (current-buffer)) firstline work-buffer status
+ (let ((cbuf (current-buffer)) firstline work-buffer
(file-name (expand-file-name
(concat (binhex-decode-region-internal start end t)
".data")
diff --git a/lisp/mail/blessmail.el b/lisp/mail/blessmail.el
index 42c60c3f6c3..62094bfe2d7 100644
--- a/lisp/mail/blessmail.el
+++ b/lisp/mail/blessmail.el
@@ -49,15 +49,15 @@
(setq attr (file-attributes dirname))
(if (not (eq t (car attr)))
(insert (format "echo %s is not a directory\n" rmail-spool-directory))
- (setq modes (nth 8 attr))
+ (setq modes (file-attribute-modes attr))
(cond ((= ?w (aref modes 8))
;; Nothing needs to be done.
)
((= ?w (aref modes 5))
- (insert "chgrp " (number-to-string (nth 3 attr))
+ (insert "chgrp " (number-to-string (file-attribute-group-id attr))
" $* && chmod g+s $*\n"))
((= ?w (aref modes 2))
- (insert "chown " (number-to-string (nth 2 attr))
+ (insert "chown " (number-to-string (file-attribute-user-id attr))
" $* && chmod u+s $*\n"))
(t
(insert "chown root $* && chmod u+s $*\n"))))
diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el
index 859239405a9..c637e242c42 100644
--- a/lisp/mail/emacsbug.el
+++ b/lisp/mail/emacsbug.el
@@ -69,6 +69,7 @@
(declare-function x-server-vendor "xfns.c" (&optional terminal))
(declare-function x-server-version "xfns.c" (&optional terminal))
(declare-function message-sort-headers "message" ())
+(declare-function w32--os-description "w32-fns" ())
(defvar message-strip-special-text-properties)
(defun report-emacs-bug-can-use-osx-open ()
@@ -116,6 +117,88 @@ This requires either the macOS \"open\" command, or the freedesktop
(concat "mailto:" to)))
(error "Subject, To or body not found")))))
+(defvar report-emacs-bug--os-description nil
+ "Cached value of operating system description.")
+
+(defun report-emacs-bug--os-description ()
+ "Return a string describing the operating system, or nil."
+ (cond ((eq system-type 'darwin)
+ (let (os)
+ (with-temp-buffer
+ (when (eq 0 (ignore-errors
+ (call-process "sw_vers" nil '(t nil) nil)))
+ (dolist (s '("ProductName" "ProductVersion"))
+ (goto-char (point-min))
+ (if (re-search-forward (format "^%s\\s-*:\\s-+\\(.*\\)$" s)
+ nil t)
+ (setq os (concat os " " (match-string 1)))))))
+ os))
+ ((eq system-type 'windows-nt)
+ (or report-emacs-bug--os-description
+ (setq report-emacs-bug--os-description (w32--os-description))))
+ ((eq system-type 'berkeley-unix)
+ (with-temp-buffer
+ (when
+ (or (eq 0 (ignore-errors (call-process "freebsd-version" nil
+ '(t nil) nil "-u")))
+ (progn (erase-buffer)
+ (eq 0 (ignore-errors
+ (call-process "uname" nil
+ '(t nil) nil "-a")))))
+ (unless (zerop (buffer-size))
+ (goto-char (point-min))
+ (buffer-substring (line-beginning-position)
+ (line-end-position))))))
+ ;; TODO Cygwin, Solaris (usg-unix-v).
+ (t
+ (or (let ((file "/etc/os-release"))
+ (and (file-readable-p file)
+ (with-temp-buffer
+ (insert-file-contents file)
+ (if (re-search-forward
+ "^\\sw*PRETTY_NAME=\"?\\(.+?\\)\"?$" nil t)
+ (match-string 1)
+ (let (os)
+ (when (re-search-forward
+ "^\\sw*NAME=\"?\\(.+?\\)\"?$" nil t)
+ (setq os (match-string 1))
+ (if (re-search-forward
+ "^\\sw*VERSION=\"?\\(.+?\\)\"?$" nil t)
+ (setq os (concat os " " (match-string 1))))
+ os))))))
+ (with-temp-buffer
+ (when (eq 0 (ignore-errors
+ (call-process "lsb_release" nil '(t nil)
+ nil "-d")))
+ (goto-char (point-min))
+ (if (looking-at "^\\sw+:\\s-+")
+ (goto-char (match-end 0)))
+ (buffer-substring (point) (line-end-position))))
+ (let ((file "/etc/lsb-release"))
+ (and (file-readable-p file)
+ (with-temp-buffer
+ (insert-file-contents file)
+ (if (re-search-forward
+ "^\\sw*DISTRIB_DESCRIPTION=\"?\\(.*release.*?\\)\"?$" nil t)
+ (match-string 1)))))
+ (catch 'found
+ (dolist (f (append (file-expand-wildcards "/etc/*-release")
+ '("/etc/debian_version")))
+ (and (not (member (file-name-nondirectory f)
+ '("lsb-release" "os-release")))
+ (file-readable-p f)
+ (with-temp-buffer
+ (insert-file-contents f)
+ (if (not (zerop (buffer-size)))
+ (throw 'found
+ (format "%s%s"
+ (if (equal (file-name-nondirectory f)
+ "debian_version")
+ "Debian " "")
+ (buffer-substring
+ (line-beginning-position)
+ (line-end-position)))))))))))))
+
;; It's the default mail mode, so it seems OK to use its features.
(autoload 'message-bogus-recipient-p "message")
(autoload 'message-make-address "message")
@@ -225,6 +308,8 @@ usually do not have translators for other languages.\n\n")))
(if (stringp emacs-repository-version)
(insert "Repository revision: " emacs-repository-version "\n"))
+ (if (stringp emacs-repository-branch)
+ (insert "Repository branch: " emacs-repository-branch "\n"))
(if (fboundp 'x-server-vendor)
(condition-case nil
;; This is used not only for X11 but also W32 and others.
@@ -232,13 +317,9 @@ usually do not have translators for other languages.\n\n")))
"', version "
(mapconcat 'number-to-string (x-server-version) ".") "\n")
(error t)))
- (let ((lsb (with-temp-buffer
- (if (eq 0 (ignore-errors
- (call-process "lsb_release" nil '(t nil)
- nil "-d")))
- (buffer-string)))))
- (if (stringp lsb)
- (insert "System " lsb "\n")))
+ (let ((os (ignore-errors (report-emacs-bug--os-description))))
+ (if (stringp os)
+ (insert "System Description: " os "\n\n")))
(let ((message-buf (get-buffer "*Messages*")))
(if message-buf
(let (beg-pos
@@ -267,11 +348,6 @@ usually do not have translators for other languages.\n\n")))
"LC_ALL" "LC_COLLATE" "LC_CTYPE" "LC_MESSAGES"
"LC_MONETARY" "LC_NUMERIC" "LC_TIME" "LANG" "XMODIFIERS"))
(insert (format " locale-coding-system: %s\n" locale-coding-system))
- ;; Only ~ 0.2% of people from a sample of 3200 changed this from
- ;; the default, t.
- (or (default-value 'enable-multibyte-characters)
- (insert (format " default enable-multibyte-characters: %s\n"
- (default-value 'enable-multibyte-characters))))
(insert "\n")
(insert (format "Major mode: %s\n"
(format-mode-line
diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el
index 27ebe162491..a90d9c46578 100644
--- a/lisp/mail/feedmail.el
+++ b/lisp/mail/feedmail.el
@@ -1,5 +1,6 @@
-;;; feedmail.el --- assist other email packages to massage outgoing messages
-;;; This file is in the public domain.
+;;; feedmail.el --- assist other email packages to massage outgoing messages -*- lexical-binding:t -*-
+
+;; This file is in the public domain.
;; This file is part of GNU Emacs.
@@ -1312,25 +1313,21 @@ There's no trivial way to avoid it. It's unwise to just set the value
of `buffer-file-name' to nil because that will defeat feedmail's file
management features. Instead, arrange for this variable to be set to
the value of `buffer-file-name' before setting that to nil. An easy way
-to do that would be with defadvice on `mail-send' \(undoing the
-assignments in a later advice).
+to do that would be with an advice on `mail-send'.
feedmail will pretend that `buffer-file-name', if nil, has the value
assigned of `feedmail-queue-buffer-file-name' and carry out its normal
activities. feedmail does not restore the non-nil value of
-`buffer-file-name'. For safe bookkeeping, the user should insure that
+`buffer-file-name'. For safe bookkeeping, the user should ensure that
feedmail-queue-buffer-file-name is restored to nil.
-Example `defadvice' for mail-send:
-
- (defadvice mail-send (before feedmail-mail-send-before-advice activate)
- (setq feedmail-queue-buffer-file-name buffer-file-name)
- (setq buffer-file-name nil))
+Example advice for mail-send:
- (defadvice mail-send (after feedmail-mail-send-after-advice activate)
- (if feedmail-queue-buffer-file-name (setq buffer-file-name feedmail-queue-buffer-file-name))
- (setq feedmail-queue-buffer-file-name nil))
-")
+ (advice-add 'mail-send :around #'my-feedmail-mail-send-advice)
+ (defun my-feedmail-mail-send-advice (orig-fun &rest args)
+ (let ((feedmail-queue-buffer-file-name buffer-file-name)
+ (buffer-file-name nil))
+ (apply orig-fun args)))")
;; defvars to make byte-compiler happy(er)
(defvar feedmail-error-buffer nil)
@@ -1396,7 +1393,7 @@ It shows the simple addresses and gets a confirmation. Use as:
When this hook runs, the current buffer is already the appropriate
buffer. It has already had all the header prepping from the standard
package. The next step after running the hook will be to save the
-message via FCC: processing. The hook might be interested in these:
+message via Fcc: processing. The hook might be interested in these:
\(1) `feedmail-prepped-text-buffer' contains the header and body of the
message, ready to go; (2) `feedmail-address-list' contains a list
of simplified recipients of addresses which are to be given to the
@@ -1438,7 +1435,7 @@ internal buffers will be reused and things will get confused."
)
(defcustom feedmail-queue-runner-mode-setter
- (lambda (&optional arg) (mail-mode))
+ (lambda (&optional _) (mail-mode))
"A function to set the proper mode of a message file.
Called when the message is read back out of the queue directory with a single
argument, the optional argument used in the call to
@@ -1474,7 +1471,10 @@ set `mail-header-separator' to the value of
(defcustom feedmail-queue-runner-message-sender
- (lambda (&optional arg) (mail-send))
+ (lambda (&optional _)
+ ;; `mail-send' is not autoloaded, which is why we need the `require'.
+ (require 'sendmail) (declare-function mail-send "sendmail")
+ (mail-send))
"Function to initiate sending a message file.
Called for each message read back out of the queue directory with a
single argument, the optional argument used in the call to
@@ -1607,7 +1607,7 @@ Feeds the buffer to it."
"Function which actually calls sendmail as a subprocess.
Feeds the buffer to it. Probably has some flaws for Resent-* and other
complicated cases. Takes addresses from message headers and
-might disappoint you with BCC: handling. In case of odd results, consult
+might disappoint you with Bcc: handling. In case of odd results, consult
local gurus."
(require 'sendmail)
(feedmail-say-debug ">in-> feedmail-buffer-to-sendmail %s" addr-listoid)
@@ -1737,7 +1737,7 @@ insertion.")
(declare-function vm-mail "ext:vm" (&optional to subject))
-(defun feedmail-vm-mail-mode (&optional arg)
+(defun feedmail-vm-mail-mode (&optional _)
"Make something like a buffer that has been created via `vm-mail'.
The optional argument is ignored and is just for argument compatibility with
`feedmail-queue-runner-mode-setter'. This function is suitable for being
@@ -1745,9 +1745,7 @@ applied to a file after you've just read it from disk: for example, a
feedmail FQM message file from a queue. You could use something like
this:
-\(setq auto-mode-alist
- (cons \\='(\"\\\\.fqm$\" . feedmail-vm-mail-mode) auto-mode-alist))
-"
+ (add-to-list 'auto-mode-alist \\='(\"\\\\.fqm\\\\\\='\" . feedmail-vm-mail-mode))"
(feedmail-say-debug ">in-> feedmail-vm-mail-mode")
(let ((the-buf (current-buffer)))
(vm-mail)
@@ -2150,19 +2148,8 @@ you can set `feedmail-queue-reminder-alist' to nil."
feedmail-prompt-before-queue-user-alist
))
-(defun feedmail-queue-runner-prompt ()
- "Ask whether to queue, send immediately, or return to editing a message, etc."
- (feedmail-say-debug ">in-> feedmail-queue-runner-prompt")
- (feedmail-queue-send-edit-prompt-inner
- feedmail-ask-before-queue-default
- feedmail-ask-before-queue-prompt
- feedmail-ask-before-queue-reprompt
- 'feedmail-message-action-help
- feedmail-prompt-before-queue-standard-alist
- feedmail-prompt-before-queue-user-alist
- ))
(defun feedmail-queue-send-edit-prompt-inner (default prompt reprompt helper
- standard-alist user-alist)
+ standard-alist user-alist)
(feedmail-say-debug ">in-> feedmail-queue-send-edit-prompt-inner")
;; Some implementation ideas here came from the userlock.el code
(or defining-kbd-macro (discard-input))
@@ -2181,6 +2168,8 @@ you can set `feedmail-queue-reminder-alist' to nil."
(let ((inhibit-quit t) (cursor-in-echo-area t) (echo-keystrokes 0))
(read-char-exclusive))))
(if (= user-sez help-char)
+ ;; FIXME: This seems to want to refer to the `helper' argument,
+ ;; but it's quoted so the `helper' arg ends up unused!
(setq answer '(^ . helper))
(if (or (eq user-sez ?\C-m) (eq user-sez ?\C-j) (eq user-sez ?y))
(setq user-sez d-char))
@@ -2209,7 +2198,7 @@ you can set `feedmail-queue-reminder-alist' to nil."
;; emacs convention is that scroll-up moves text up, window down
(feedmail-say-debug ">in-> feedmail-scroll-buffer %s" direction)
(save-selected-window
- (let ((signal-error-on-buffer-boundary nil)
+ (let ((signal-error-on-buffer-boundary nil) ;FIXME: Unknown var!?
(fqm-window (display-buffer (if buffy buffy (current-buffer)))))
(select-window fqm-window)
(if (eq direction 'up)
@@ -2380,7 +2369,7 @@ mapped to mostly alphanumerics for safety."
(defun feedmail-rfc822-date (arg-time)
(feedmail-say-debug ">in-> feedmail-rfc822-date %s" arg-time)
- (let ((time (if arg-time arg-time (current-time)))
+ (let ((time (or arg-time (current-time)))
(system-time-locale "C"))
(concat
(format-time-string "%a, %e %b %Y %T " time)
@@ -2697,8 +2686,10 @@ fiddle-plex, as described in the documentation for the variable
(save-excursion
(if feedmail-enable-spray
(mapcar
- (lambda (feedmail-spray-this-address)
- (let ((spray-buffer (get-buffer-create " *FQM Outgoing Email Spray*")))
+ (lambda (address)
+ (let ((feedmail-spray-this-address address)
+ (spray-buffer
+ (get-buffer-create " *FQM Outgoing Email Spray*")))
(with-current-buffer spray-buffer
(erase-buffer)
;; not life's most efficient methodology, but spraying isn't
@@ -2712,7 +2703,8 @@ fiddle-plex, as described in the documentation for the variable
;; Message-Id:s, but I doubt that anyone cares,
;; practically. If someone complains about it, I'll
;; add it.
- (feedmail-fiddle-list-of-spray-fiddle-plexes feedmail-spray-address-fiddle-plex-list)
+ (feedmail-fiddle-list-of-spray-fiddle-plexes
+ feedmail-spray-address-fiddle-plex-list)
;; this (let ) is just in case some buffer eater
;; is cheating and using the global variable name instead
;; of its argument to find the buffer
@@ -2823,16 +2815,13 @@ return that value."
(defun feedmail-default-date-generator (maybe-file)
"Default function for generating Date: header contents."
(feedmail-say-debug ">in-> feedmail-default-date-generator")
- (when maybe-file
- (feedmail-say-debug (concat "4 cre " (feedmail-rfc822-date (nth 4 (file-attributes maybe-file)))))
- (feedmail-say-debug (concat "5 mod " (feedmail-rfc822-date (nth 5 (file-attributes maybe-file)))))
- (feedmail-say-debug (concat "6 sta " (feedmail-rfc822-date (nth 6 (file-attributes maybe-file))))))
- (let ((date-time))
- (if (and (not feedmail-queue-use-send-time-for-date) maybe-file)
- (setq date-time (nth 5 (file-attributes maybe-file))))
- (feedmail-rfc822-date date-time))
- )
-
+ (let ((attr (and maybe-file (file-attributes maybe-file))))
+ (when attr
+ (feedmail-say-debug (concat "4 cre " (feedmail-rfc822-date (file-attribute-access-time attr))))
+ (feedmail-say-debug (concat "5 mod " (feedmail-rfc822-date (file-attribute-modification-time attr))))
+ (feedmail-say-debug (concat "6 sta " (feedmail-rfc822-date (file-attribute-status-change-time attr)))))
+ (feedmail-rfc822-date (and attr (not feedmail-queue-use-send-time-for-date)
+ (file-attribute-modification-time attr)))))
(defun feedmail-fiddle-date (maybe-file)
"Fiddle Date:. See documentation of `feedmail-date-generator'."
@@ -2882,7 +2871,8 @@ probably not appropriate for you."
(concat (if (equal (match-beginning 1) (match-end 1)) "" "-") end-stuff))
(setq end-stuff (concat "@" end-stuff)))
(if (and (not feedmail-queue-use-send-time-for-message-id) maybe-file)
- (setq date-time (nth 5 (file-attributes maybe-file))))
+ (setq date-time (file-attribute-modification-time
+ (file-attributes maybe-file))))
(format "<%d-%s%s%s>"
(mod (random) 10000)
(format-time-string "%a%d%b%Y%H%M%S" date-time)
@@ -3147,13 +3137,17 @@ been weeded out."
(identity address-list)))
-(defun feedmail-one-last-look (feedmail-prepped-text-buffer)
+(defun feedmail-one-last-look (buffer)
"Offer the user one last chance to give it up."
(feedmail-say-debug ">in-> feedmail-one-last-look")
(save-excursion
+ ;; FIXME: switch-to-buffer may fail or pop up a new frame
+ ;; (in minibuffer-only frames, for example) and save-window-excursion
+ ;; won't delete the newly created frame upon exit!
(save-window-excursion
- (switch-to-buffer feedmail-prepped-text-buffer)
- (if (and (fboundp 'y-or-n-p-with-timeout) (numberp feedmail-confirm-outgoing-timeout))
+ (switch-to-buffer buffer)
+ (if (and (fboundp 'y-or-n-p-with-timeout)
+ (numberp feedmail-confirm-outgoing-timeout))
(y-or-n-p-with-timeout
"FQM: Send this email? "
(abs feedmail-confirm-outgoing-timeout)
diff --git a/lisp/mail/flow-fill.el b/lisp/mail/flow-fill.el
index 8451315a12e..06279d4041c 100644
--- a/lisp/mail/flow-fill.el
+++ b/lisp/mail/flow-fill.el
@@ -1,4 +1,4 @@
-;;; flow-fill.el --- interpret RFC2646 "flowed" text
+;;; flow-fill.el --- interpret RFC2646 "flowed" text -*- lexical-binding:t -*-
;; Copyright (C) 2000-2019 Free Software Foundation, Inc.
@@ -49,7 +49,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
(defcustom fill-flowed-display-column 'fill-column
"Column beyond which format=flowed lines are wrapped, when displayed.
diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el
index be3a878f832..81dc11de763 100644
--- a/lisp/mail/footnote.el
+++ b/lisp/mail/footnote.el
@@ -1,8 +1,9 @@
-;;; footnote.el --- footnote support for message mode
+;;; footnote.el --- footnote support for message mode -*- lexical-binding:t -*-
;; Copyright (C) 1997, 2000-2019 Free Software Foundation, Inc.
-;; Author: Steven L Baur <steve@xemacs.org>
+;; Author: Steven L Baur <steve@xemacs.org> (1997-2011)
+;; Boruch Baum <boruch_baum@gmx.com> (2017-)
;; Keywords: mail, news
;; Version: 0.19
@@ -29,9 +30,36 @@
;; [1] Footnotes look something like this. Along with some decorative
;; stuff.
-;; TODO:
-;; Reasonable Undo support.
-;; more language styles.
+;;;; TODO:
+;; + Reasonable Undo support.
+;; - could use an `apply' entry in the buffer-undo-list to be warned when
+;; a footnote we inserted is removed via undo.
+;; - should try to handle the more general problem of deleting/removing
+;; footnotes via standard editing commands rather than via footnote
+;; commands.
+;; + more language styles.
+;; + The key sequence 'C-c ! a C-y C-c ! b' should auto-fill the
+;; footnote in adaptive fill mode. This does not seem to be a bug in
+;; `adaptive-fill' because it behaves that way on all point movements
+;; + Handle footmode mode elegantly in all modes, even if that means refuses to
+;; accept the burden. For example, in a programming language mode, footnotes
+;; should be commented.
+;; + Manually autofilling the a first footnote should not cause it to
+;; wrap into the footnote section tag
+;; + Current solution adds a second newline after the section tag, so it is
+;; clearly a separate paragraph. There may be stylistic objections to this.
+;; + Footnotes with multiple paragraphs should not have their first
+;; line out-dented.
+;; + Upon leaving footnote area, perform an auto-fill on an entire
+;; footnote (including multiple paragraphs), or on entire footnote area.
+;; + fill-paragraph takes arg REGION, but seemingly only when called
+;; interactively.
+;; + At some point, it became necessary to change `footnote-section-tag-regexp'
+;; to remove its trailing space. (Adaptive fill side-effect?)
+;; + useful for lazy testing
+;; (setq footnote-narrow-to-footnotes-when-editing t)
+;; (setq footnote-section-tag "Footnotes: ")
+;; (setq footnote-section-tag-regexp "Footnotes\\(\\[.\\]\\)?:")
;;; Code:
@@ -92,20 +120,25 @@ After that, changing the prefix key requires manipulating keymaps."
;;; Interface variables that probably shouldn't be changed
-(defcustom footnote-section-tag "Footnotes: "
+(defcustom footnote-section-tag "Footnotes:"
"Tag inserted at beginning of footnote section.
If you set this to the empty string, no tag is inserted and the
value of `footnote-section-tag-regexp' is ignored. Customizing
this variable has no effect on buffers already displaying
footnotes."
+ :version "27.1"
:type 'string
:group 'footnote)
-(defcustom footnote-section-tag-regexp "Footnotes\\(\\[.\\]\\)?: "
+(defcustom footnote-section-tag-regexp
+ ;; Even if `footnote-section-tag' has a trailing space, let's not require it
+ ;; here, since it might be trimmed by various commands.
+ "Footnotes\\(\\[.\\]\\)?:"
"Regexp which indicates the start of a footnote section.
This variable is disregarded when `footnote-section-tag' is the
empty string. Customizing this variable has no effect on buffers
already displaying footnotes."
+ :version "27.1"
:type 'regexp
:group 'footnote)
@@ -124,13 +157,21 @@ has no effect on buffers already displaying footnotes."
:type 'string
:group 'footnote)
-(defcustom footnote-signature-separator (if (boundp 'message-signature-separator)
- message-signature-separator
- "^-- $")
+(defcustom footnote-signature-separator
+ (if (boundp 'message-signature-separator)
+ message-signature-separator
+ "^-- $")
"Regexp used by Footnote mode to recognize signatures."
:type 'regexp
:group 'footnote)
+(defcustom footnote-align-to-fn-text t
+ "How to left-align footnote text.
+If nil, footnote text is to be aligned flush left with left side
+of the footnote number. If non-nil, footnote text is to be aligned
+left with the first character of footnote text."
+ :type 'boolean)
+
;;; Private variables
(defvar footnote-style-number nil
@@ -148,12 +189,14 @@ has no effect on buffers already displaying footnotes."
(defvar footnote-mouse-highlight 'highlight
"Text property name to enable mouse over highlight.")
+(defvar footnote-mode)
+
;;; Default styles
;;; NUMERIC
(defconst footnote-numeric-regexp "[0-9]+"
"Regexp for digits.")
-(defun Footnote-numeric (n)
+(defun footnote--numeric (n)
"Numeric footnote style.
Use Arabic numerals for footnoting."
(int-to-string n))
@@ -165,7 +208,7 @@ Use Arabic numerals for footnoting."
(defconst footnote-english-upper-regexp "[A-Z]+"
"Regexp for upper case English alphabet.")
-(defun Footnote-english-upper (n)
+(defun footnote--english-upper (n)
"Upper case English footnoting.
Wrapping around the alphabet implies successive repetitions of letters."
(let* ((ltr (mod (1- n) (length footnote-english-upper)))
@@ -184,7 +227,7 @@ Wrapping around the alphabet implies successive repetitions of letters."
(defconst footnote-english-lower-regexp "[a-z]+"
"Regexp of lower case English alphabet.")
-(defun Footnote-english-lower (n)
+(defun footnote--english-lower (n)
"Lower case English footnoting.
Wrapping around the alphabet implies successive repetitions of letters."
(let* ((ltr (mod (1- n) (length footnote-english-lower)))
@@ -202,27 +245,28 @@ Wrapping around the alphabet implies successive repetitions of letters."
(50 . "l") (100 . "c") (500 . "d") (1000 . "m"))
"List of roman numerals with their values.")
-(defconst footnote-roman-lower-regexp "[ivxlcdm]+"
+(defconst footnote-roman-lower-regexp
+ (concat "[" (mapconcat #'cdr footnote-roman-lower-list "") "]+")
"Regexp of roman numerals.")
-(defun Footnote-roman-lower (n)
+(defun footnote--roman-lower (n)
"Generic Roman number footnoting."
- (Footnote-roman-common n footnote-roman-lower-list))
+ (footnote--roman-common n footnote-roman-lower-list))
;;; ROMAN UPPER
(defconst footnote-roman-upper-list
- '((1 . "I") (5 . "V") (10 . "X")
- (50 . "L") (100 . "C") (500 . "D") (1000 . "M"))
+ (mapcar (lambda (x) (cons (car x) (upcase (cdr x))))
+ footnote-roman-lower-list)
"List of roman numerals with their values.")
-(defconst footnote-roman-upper-regexp "[IVXLCDM]+"
+(defconst footnote-roman-upper-regexp (upcase footnote-roman-lower-regexp)
"Regexp of roman numerals. Not complete")
-(defun Footnote-roman-upper (n)
+(defun footnote--roman-upper (n)
"Generic Roman number footnoting."
- (Footnote-roman-common n footnote-roman-upper-list))
+ (footnote--roman-common n footnote-roman-upper-list))
-(defun Footnote-roman-common (n footnote-roman-list)
+(defun footnote--roman-common (n footnote-roman-list)
"Lower case Roman footnoting."
(let* ((our-list footnote-roman-list)
(rom-lngth (length our-list))
@@ -257,22 +301,22 @@ Wrapping around the alphabet implies successive repetitions of letters."
;; (message "pairs are: rom-low: %S, rom-high: %S, rom-div: %S"
;; rom-low-pair rom-high-pair rom-div-pair)
(cond
- ((< n 0) (error "Footnote-roman-common called with n < 0"))
+ ((< n 0) (error "footnote--roman-common called with n < 0"))
((= n 0) "")
((= n (car rom-low-pair)) (cdr rom-low-pair))
((= n (car rom-high-pair)) (cdr rom-high-pair))
((= (car rom-low-pair) (car rom-high-pair))
(concat (cdr rom-low-pair)
- (Footnote-roman-common
+ (footnote--roman-common
(- n (car rom-low-pair))
footnote-roman-list)))
((>= rom-div 0) (concat (cdr rom-div-pair) (cdr rom-high-pair)
- (Footnote-roman-common
+ (footnote--roman-common
(- n (- (car rom-high-pair)
(car rom-div-pair)))
footnote-roman-list)))
(t (concat (cdr rom-low-pair)
- (Footnote-roman-common
+ (footnote--roman-common
(- n (car rom-low-pair))
footnote-roman-list)))))))
@@ -285,7 +329,7 @@ Wrapping around the alphabet implies successive repetitions of letters."
(defconst footnote-latin-regexp (concat "[" footnote-latin-string "]")
"Regexp for Latin-1 footnoting characters.")
-(defun Footnote-latin (n)
+(defun footnote--latin (n)
"Latin-1 footnote style.
Use a range of Latin-1 non-ASCII characters for footnoting."
(string (aref footnote-latin-string
@@ -299,7 +343,7 @@ Use a range of Latin-1 non-ASCII characters for footnoting."
(defconst footnote-unicode-regexp (concat "[" footnote-unicode-string "]+")
"Regexp for Unicode footnoting characters.")
-(defun Footnote-unicode (n)
+(defun footnote--unicode (n)
"Unicode footnote style.
Use Unicode characters for footnoting."
(let (modulus result done)
@@ -310,18 +354,72 @@ Use Unicode characters for footnoting."
(push (aref footnote-unicode-string modulus) result))
(apply #'string result)))
+;; Hebrew
+
+(defconst footnote-hebrew-numeric
+ '(
+ ("א" "ב" "ג" "ד" "ה" "ו" "ז" "ח" "ט")
+ ("י" "כ" "ל" "מ" "נ" "ס" "ע" "פ" "צ")
+ ("ק" "ר" "ש" "ת" "תק" "תר" "תש" "תת" "תתק")))
+
+(defconst footnote-hebrew-numeric-regex
+ (let ((numchars (string-to-list
+ (apply #'concat (apply #'append footnote-hebrew-numeric)))))
+ (concat (regexp-opt-charset (cons ?' numchars)) "+")))
+;; (defconst footnote-hebrew-numeric-regex "\\([אבגדהוזחט]'\\)?\\(ת\\)?\\(ת\\)?\\([קרשת]\\)?\\([טיכלמנסעפצ]\\)?\\([אבגדהוזחט]\\)?")
+
+(defun footnote--hebrew-numeric (n)
+ "Supports 9999 footnotes, then rolls over."
+ (let* ((n (+ (mod n 10000) (/ n 10000)))
+ (thousands (/ n 1000))
+ (hundreds (/ (mod n 1000) 100))
+ (tens (/ (mod n 100) 10))
+ (units (mod n 10))
+ (special (cond
+ ((not (= tens 1)) nil)
+ ((= units 5) "טו")
+ ((= units 6) "טז"))))
+ (concat
+ (when (/= 0 thousands)
+ (concat (nth (1- thousands) (nth 0 footnote-hebrew-numeric)) "'"))
+ (when (/= 0 hundreds)
+ (nth (1- hundreds) (nth 2 footnote-hebrew-numeric)))
+ (or special
+ (concat
+ (when (/= 0 tens) (nth (1- tens) (nth 1 footnote-hebrew-numeric)))
+ (when (/= 0 units) (nth (1- units) (nth 0 footnote-hebrew-numeric))))))))
+
+(defconst footnote-hebrew-symbolic
+ '(
+ "א" "ב" "ג" "ד" "ה" "ו" "ז" "ח" "ט" "י" "כ" "ל" "מ" "נ" "ס" "ע" "פ" "צ" "ק" "ר" "ש" "ת"))
+
+(defconst footnote-hebrew-symbolic-regex
+ (concat "[" (apply #'concat footnote-hebrew-symbolic) "]"))
+
+(defun footnote--hebrew-symbolic (n)
+ "Only 22 elements, per the style of eg. 'פירוש שפתי חכמים על רש״י'.
+Proceeds from `י' to `כ', from `צ' to `ק'. After `ת', rolls over to `א'."
+ (nth (mod (1- n) 22) footnote-hebrew-symbolic))
+
;;; list of all footnote styles
(defvar footnote-style-alist
- `((numeric Footnote-numeric ,footnote-numeric-regexp)
- (english-lower Footnote-english-lower ,footnote-english-lower-regexp)
- (english-upper Footnote-english-upper ,footnote-english-upper-regexp)
- (roman-lower Footnote-roman-lower ,footnote-roman-lower-regexp)
- (roman-upper Footnote-roman-upper ,footnote-roman-upper-regexp)
- (latin Footnote-latin ,footnote-latin-regexp)
- (unicode Footnote-unicode ,footnote-unicode-regexp))
+ `((numeric footnote--numeric ,footnote-numeric-regexp)
+ (english-lower footnote--english-lower ,footnote-english-lower-regexp)
+ (english-upper footnote--english-upper ,footnote-english-upper-regexp)
+ (roman-lower footnote--roman-lower ,footnote-roman-lower-regexp)
+ (roman-upper footnote--roman-upper ,footnote-roman-upper-regexp)
+ (latin footnote--latin ,footnote-latin-regexp)
+ (unicode footnote--unicode ,footnote-unicode-regexp)
+ (hebrew-numeric footnote--hebrew-numeric ,footnote-hebrew-numeric-regex)
+ (hebrew-symbolic footnote--hebrew-symbolic ,footnote-hebrew-symbolic-regex))
"Styles of footnote tags available.
-By default only boring Arabic numbers, English letters and Roman Numerals
-are available.")
+By default, Arabic numbers, English letters, Roman Numerals,
+Latin and Unicode superscript characters, and Hebrew numerals
+are available.
+Each element of the list should be of the form (NAME FUNCTION REGEXP)
+where NAME is a symbol, FUNCTION takes a footnote number and
+returns the corresponding representation in that style as a string,
+and REGEXP should be a regexp that matches any output of FUNCTION.")
(defcustom footnote-style 'numeric
"Default style used for footnoting.
@@ -332,6 +430,8 @@ roman-lower == i, ii, iii, iv, v, ...
roman-upper == I, II, III, IV, V, ...
latin == ¹ ² ³ º ª § ¶
unicode == ¹, ², ³, ...
+hebrew-numeric == א, ב, ..., יא, ..., תקא...
+hebrew-symbolic == א, ב, ..., י, כ, ..., צ, ק, ..., ת, א
See also variables `footnote-start-tag' and `footnote-end-tag'.
Note: some characters in the unicode style may not show up
@@ -339,36 +439,46 @@ properly if the default font does not contain those characters.
Customizing this variable has no effect on buffers already
displaying footnotes. To change the style of footnotes in such a
-buffer use the command `Footnote-set-style'."
+buffer use the command `footnote-set-style'."
:type (cons 'choice (mapcar (lambda (x) (list 'const (car x)))
footnote-style-alist))
:group 'footnote)
;;; Style utilities & functions
-(defun Footnote-style-p (style)
+(defun footnote--style-p (style)
"Return non-nil if style is a valid style known to `footnote-mode'."
(assq style footnote-style-alist))
-(defun Footnote-index-to-string (index)
+(defun footnote--index-to-string (index)
"Convert a binary index into a string to display as a footnote.
Conversion is done based upon the current selected style."
- (let ((alist (if (Footnote-style-p footnote-style)
+ (let ((alist (if (footnote--style-p footnote-style)
(assq footnote-style footnote-style-alist)
(nth 0 footnote-style-alist))))
(funcall (nth 1 alist) index)))
-(defun Footnote-current-regexp ()
+(defun footnote--current-regexp ()
"Return the regexp of the index of the current style."
- (concat (nth 2 (or (assq footnote-style footnote-style-alist)
- (nth 0 footnote-style-alist)))
- "*"))
-
-(defun Footnote-refresh-footnotes (&optional index-regexp)
+ (let ((regexp (nth 2 (or (assq footnote-style footnote-style-alist)
+ (nth 0 footnote-style-alist)))))
+ (concat
+ ;; Hack to avoid repetition of repetition.
+ ;; FIXME: I'm not sure the added * makes sense at all; there is
+ ;; always a single number within the footnote-{start,end}-tag pairs.
+ ;; Worse, the code goes on and adds yet another + later on, in
+ ;; footnote-refresh-footnotes, just in case. That makes even less sense.
+ ;; Likely, both the * and the extra + should go away.
+ (if (string-match "[^\\]\\\\\\{2\\}*[*+?]\\'" regexp)
+ (substring regexp 0 -1)
+ regexp)
+ "*")))
+
+(defun footnote--refresh-footnotes (&optional index-regexp)
"Redraw all footnotes.
You must call this or arrange to have this called after changing footnote
styles."
(unless index-regexp
- (setq index-regexp (Footnote-current-regexp)))
+ (setq index-regexp (footnote--current-regexp)))
(save-excursion
;; Take care of the pointers first
(let ((i 0) locn alist)
@@ -387,7 +497,7 @@ styles."
(propertize
(concat
footnote-start-tag
- (Footnote-index-to-string (1+ i))
+ (footnote--index-to-string (1+ i))
footnote-end-tag)
'footnote-number (1+ i) footnote-mouse-highlight t)
nil "\\1"))
@@ -406,13 +516,13 @@ styles."
(propertize
(concat
footnote-start-tag
- (Footnote-index-to-string (1+ i))
+ (footnote--index-to-string (1+ i))
footnote-end-tag)
'footnote-number (1+ i))
nil "\\1"))
(setq i (1+ i))))))
-(defun Footnote-assoc-index (key alist)
+(defun footnote--assoc-index (key alist)
"Give index of key in alist."
(let ((i 0) (max (length alist)) rc)
(while (and (null rc)
@@ -422,33 +532,33 @@ styles."
(setq i (1+ i)))
rc))
-(defun Footnote-cycle-style ()
+(defun footnote-cycle-style ()
"Select next defined footnote style."
(interactive)
- (let ((old (Footnote-assoc-index footnote-style footnote-style-alist))
+ (let ((old (footnote--assoc-index footnote-style footnote-style-alist))
(max (length footnote-style-alist))
idx)
(setq idx (1+ old))
(when (>= idx max)
(setq idx 0))
(setq footnote-style (car (nth idx footnote-style-alist)))
- (Footnote-refresh-footnotes (nth 2 (nth old footnote-style-alist)))))
+ (footnote--refresh-footnotes (nth 2 (nth old footnote-style-alist)))))
-(defun Footnote-set-style (&optional style)
+(defun footnote-set-style (&optional style)
"Select a specific style."
(interactive
(list (intern (completing-read
"Footnote Style: "
- obarray #'Footnote-style-p 'require-match))))
- (let ((old (Footnote-assoc-index footnote-style footnote-style-alist)))
+ obarray #'footnote--style-p 'require-match))))
+ (let ((old (footnote--assoc-index footnote-style footnote-style-alist)))
(setq footnote-style style)
- (Footnote-refresh-footnotes (nth 2 (nth old footnote-style-alist)))))
+ (footnote--refresh-footnotes (nth 2 (nth old footnote-style-alist)))))
;; Internal functions
-(defun Footnote-insert-numbered-footnote (arg &optional mousable)
+(defun footnote--insert-numbered-footnote (arg &optional mousable)
"Insert numbered footnote at (point)."
(let ((string (concat footnote-start-tag
- (Footnote-index-to-string arg)
+ (footnote--index-to-string arg)
footnote-end-tag)))
(insert-before-markers
(if mousable
@@ -456,7 +566,7 @@ styles."
string 'footnote-number arg footnote-mouse-highlight t)
(propertize string 'footnote-number arg)))))
-(defun Footnote-renumber (from to pointer-alist text-alist)
+(defun footnote--renumber (_from to pointer-alist text-alist)
"Renumber a single footnote."
(let* ((posn-list (cdr pointer-alist)))
(setcar pointer-alist to)
@@ -464,49 +574,40 @@ styles."
(while posn-list
(goto-char (car posn-list))
(when (looking-back (concat (regexp-quote footnote-start-tag)
- (Footnote-current-regexp)
+ (footnote--current-regexp)
(regexp-quote footnote-end-tag))
(line-beginning-position))
(replace-match
(propertize
(concat footnote-start-tag
- (Footnote-index-to-string to)
+ (footnote--index-to-string to)
footnote-end-tag)
'footnote-number to footnote-mouse-highlight t)))
(setq posn-list (cdr posn-list)))
(goto-char (cdr text-alist))
(when (looking-at (concat (regexp-quote footnote-start-tag)
- (Footnote-current-regexp)
+ (footnote--current-regexp)
(regexp-quote footnote-end-tag)))
(replace-match
(propertize
(concat footnote-start-tag
- (Footnote-index-to-string to)
+ (footnote--index-to-string to)
footnote-end-tag)
'footnote-number to)))))
-;; Not needed?
-(defun Footnote-narrow-to-footnotes ()
+(defun footnote--narrow-to-footnotes ()
"Restrict text in buffer to show only text of footnotes."
- (interactive) ; testing
- (goto-char (point-max))
- (when (re-search-backward footnote-signature-separator nil t)
- (let ((end (point)))
- (cond
- ((and (not (string-equal footnote-section-tag ""))
- (re-search-backward
- (concat "^" footnote-section-tag-regexp) nil t))
- (narrow-to-region (point) end))
- (footnote-text-marker-alist
- (narrow-to-region (cdar footnote-text-marker-alist) end))))))
+ (interactive) ; testing
+ (narrow-to-region (footnote--get-area-point-min)
+ (footnote--get-area-point-max)))
-(defun Footnote-goto-char-point-max ()
+(defun footnote--goto-char-point-max ()
"Move to end of buffer or prior to start of .signature."
(goto-char (point-max))
(or (re-search-backward footnote-signature-separator nil t)
(point)))
-(defun Footnote-insert-text-marker (arg locn)
+(defun footnote--insert-text-marker (arg locn)
"Insert a marker pointing to footnote ARG, at buffer location LOCN."
(let ((marker (make-marker)))
(unless (assq arg footnote-text-marker-alist)
@@ -514,9 +615,9 @@ styles."
(setq footnote-text-marker-alist
(cons (cons arg marker) footnote-text-marker-alist))
(setq footnote-text-marker-alist
- (Footnote-sort footnote-text-marker-alist)))))
+ (footnote--sort footnote-text-marker-alist)))))
-(defun Footnote-insert-pointer-marker (arg locn)
+(defun footnote--insert-pointer-marker (arg locn)
"Insert a marker pointing to footnote ARG, at buffer location LOCN."
(let ((marker (make-marker))
alist)
@@ -527,14 +628,14 @@ styles."
(setq footnote-pointer-marker-alist
(cons (cons arg (list marker)) footnote-pointer-marker-alist))
(setq footnote-pointer-marker-alist
- (Footnote-sort footnote-pointer-marker-alist)))))
+ (footnote--sort footnote-pointer-marker-alist)))))
-(defun Footnote-insert-footnote (arg)
+(defun footnote--insert-footnote (arg)
"Insert a footnote numbered ARG, at (point)."
(push-mark)
- (Footnote-insert-pointer-marker arg (point))
- (Footnote-insert-numbered-footnote arg t)
- (Footnote-goto-char-point-max)
+ (footnote--insert-pointer-marker arg (point))
+ (footnote--insert-numbered-footnote arg t)
+ (footnote--goto-char-point-max)
(if (cond
((not (string-equal footnote-section-tag ""))
(re-search-backward (concat "^" footnote-section-tag-regexp) nil t))
@@ -542,8 +643,8 @@ styles."
(goto-char (cdar footnote-text-marker-alist))))
(save-restriction
(when footnote-narrow-to-footnotes-when-editing
- (Footnote-narrow-to-footnotes))
- (Footnote-goto-footnote (1- arg)) ; evil, FIXME (less evil now)
+ (footnote--narrow-to-footnotes))
+ (footnote-goto-footnote (1- arg)) ; evil, FIXME (less evil now)
;; (message "Inserting footnote %d" arg)
(unless
(or (eq arg 1)
@@ -552,11 +653,11 @@ styles."
"\n\n"
(concat "\n"
(regexp-quote footnote-start-tag)
- (Footnote-current-regexp)
+ (footnote--current-regexp)
(regexp-quote footnote-end-tag)))
nil t)
(unless (beginning-of-line) t))
- (Footnote-goto-char-point-max)
+ (footnote--goto-char-point-max)
(cond
((not (string-equal footnote-section-tag ""))
(re-search-backward
@@ -570,46 +671,115 @@ styles."
(unless (string-equal footnote-section-tag "")
(insert footnote-section-tag "\n")))
(let ((old-point (point)))
- (Footnote-insert-numbered-footnote arg nil)
- (Footnote-insert-text-marker arg old-point)))
+ (footnote--insert-numbered-footnote arg nil)
+ (footnote--insert-text-marker arg old-point)))
-(defun Footnote-sort (list)
+(defun footnote--sort (list)
(sort list (lambda (e1 e2)
(< (car e1) (car e2)))))
-(defun Footnote-text-under-cursor ()
- "Return the number of footnote if in footnote text.
+(defun footnote--text-under-cursor ()
+ "Return the number of the current footnote if in footnote text.
Return nil if the cursor is not positioned over the text of
a footnote."
- (when (and (let ((old-point (point)))
- (save-excursion
- (save-restriction
- (Footnote-narrow-to-footnotes)
- (and (>= old-point (point-min))
- (<= old-point (point-max))))))
- footnote-text-marker-alist
- (>= (point) (cdar footnote-text-marker-alist)))
- (let ((i 1)
- alist-txt rc)
+ (when (and footnote-text-marker-alist
+ (<= (footnote--get-area-point-min)
+ (point)
+ (footnote--get-area-point-max)))
+ (let ((i 1) alist-txt result)
(while (and (setq alist-txt (nth i footnote-text-marker-alist))
- (null rc))
- (when (< (point) (cdr alist-txt))
- (setq rc (car (nth (1- i) footnote-text-marker-alist))))
- (setq i (1+ i)))
- (when (and (null rc)
- (null alist-txt))
- (setq rc (car (nth (1- i) footnote-text-marker-alist))))
- rc)))
-
-(defun Footnote-under-cursor ()
+ (null result))
+ (when (< (point) (cdr alist-txt))
+ (setq result (car (nth (1- i) footnote-text-marker-alist))))
+ (setq i (1+ i)))
+ (when (and (null result) (null alist-txt))
+ (setq result (car (nth (1- i) footnote-text-marker-alist))))
+ result)))
+
+(defun footnote--under-cursor ()
"Return the number of the footnote underneath the cursor.
Return nil if the cursor is not over a footnote."
(or (get-text-property (point) 'footnote-number)
- (Footnote-text-under-cursor)))
+ (footnote--text-under-cursor)))
+
+(defun footnote--calc-fn-alignment-column ()
+ "Calculate the left alignment for footnote text."
+ ;; FIXME: Maybe it would be better to go to the footnote's beginning and
+ ;; see at which column it starts.
+ (+ footnote-body-tag-spacing
+ (string-width
+ (concat footnote-start-tag footnote-end-tag
+ (footnote--index-to-string
+ (caar (last footnote-text-marker-alist)))))))
+
+(defun footnote--fill-prefix-string ()
+ "Return the fill prefix to be used by footnote mode."
+ ;; TODO: Prefix to this value other prefix strings, such as those
+ ;; designating a comment line, a message response, or a boxquote.
+ (make-string (footnote--calc-fn-alignment-column) ?\s))
+
+(defun footnote--point-in-body-p ()
+ "Return non-nil if point is in the buffer text area,
+i.e. before the beginning of the footnote area."
+ (< (point) (footnote--get-area-point-min)))
+
+(defun footnote--get-area-point-min (&optional before-tag)
+ "Return start of the first footnote.
+If there is no footnote area, returns `point-max'.
+With optional arg BEFORE-TAG, return position of the `footnote-section-tag'
+instead, if applicable."
+ (cond
+ ;; FIXME: Shouldn't we use `footnote--get-area-point-max' instead?
+ ((not footnote-text-marker-alist) (point-max))
+ ((not before-tag) (cdr (car footnote-text-marker-alist)))
+ ((string-equal footnote-section-tag "")
+ (cdr (car footnote-text-marker-alist)))
+ (t
+ (save-excursion
+ (goto-char (cdr (car footnote-text-marker-alist)))
+ (if (re-search-backward (concat "^" footnote-section-tag-regexp) nil t)
+ (match-beginning 0)
+ (message "Footnote section tag not found!")
+ ;; This `else' should never happen, and indicates an error,
+ ;; ie. footnotes already exist and a footnote-section-tag is defined,
+ ;; but the section tag hasn't been found. We choose to assume that the
+ ;; user deleted it intentionally and wants us to behave in this buffer
+ ;; as if the section tag was set "", so we do that, now.
+ ;;(setq footnote-section-tag "")
+ ;;
+ ;; HOWEVER: The rest of footnote mode does not currently honor or
+ ;; account for this.
+ ;;
+ ;; To illustrate the difference in behavior, create a few footnotes,
+ ;; delete the section tag, and create another footnote. Then undo,
+ ;; comment the above line (that sets the tag to ""), re-evaluate this
+ ;; function, and repeat.
+ ;;
+ ;; TODO: integrate sanity checks at reasonable operational points.
+ (cdr (car footnote-text-marker-alist)))))))
+
+(defun footnote--get-area-point-max ()
+ "Return the end of footnote area.
+This is either `point-max' or the start of a `.signature' string, as
+defined by variable `footnote-signature-separator'. If there is no
+footnote area, returns `point-max'."
+ (save-excursion (footnote--goto-char-point-max)))
+
+(defun footnote--adaptive-fill-function (orig-fun)
+ (or
+ (and
+ footnote-mode
+ footnote-align-to-fn-text
+ (footnote--text-under-cursor)
+ ;; (not (footnote--point-in-body-p))
+ ;; (< (point) (footnote--signature-area-start-point))
+ (footnote--fill-prefix-string))
+ ;; If not within a footnote's text, fallback to the default.
+ (funcall orig-fun)))
;;; User functions
-(defun Footnote-make-hole ()
+(defun footnote--make-hole ()
(save-excursion
(let ((i 0)
(notes (length footnote-pointer-marker-alist))
@@ -622,32 +792,32 @@ Return nil if the cursor is not over a footnote."
(setq rc (car alist-ptr)))
(save-excursion
(message "Renumbering from %s to %s"
- (Footnote-index-to-string (car alist-ptr))
- (Footnote-index-to-string
+ (footnote--index-to-string (car alist-ptr))
+ (footnote--index-to-string
(1+ (car alist-ptr))))
- (Footnote-renumber (car alist-ptr)
+ (footnote--renumber (car alist-ptr)
(1+ (car alist-ptr))
alist-ptr
alist-txt)))
(setq i (1+ i)))
rc)))
-(defun Footnote-add-footnote (&optional arg)
+(defun footnote-add-footnote ()
"Add a numbered footnote.
The number the footnote receives is dependent upon the relative location
of any other previously existing footnotes.
If the variable `footnote-narrow-to-footnotes-when-editing' is set,
the buffer is narrowed to the footnote body. The restriction is removed
-by using `Footnote-back-to-message'."
- (interactive "*P")
+by using `footnote-back-to-message'."
+ (interactive "*")
(let ((num
(if footnote-text-marker-alist
(if (< (point) (cl-cadar (last footnote-pointer-marker-alist)))
- (Footnote-make-hole)
+ (footnote--make-hole)
(1+ (caar (last footnote-text-marker-alist))))
1)))
(message "Adding footnote %d" num)
- (Footnote-insert-footnote num)
+ (footnote--insert-footnote num)
(insert-before-markers (make-string footnote-body-tag-spacing ? ))
(let ((opoint (point)))
(save-excursion
@@ -656,18 +826,18 @@ by using `Footnote-back-to-message'."
"\n\n"
"\n"))
(when footnote-narrow-to-footnotes-when-editing
- (Footnote-narrow-to-footnotes)))
+ (footnote--narrow-to-footnotes)))
;; Emacs/XEmacs bug? save-excursion doesn't restore point when using
;; insert-before-markers.
(goto-char opoint))))
-(defun Footnote-delete-footnote (&optional arg)
+(defun footnote-delete-footnote (&optional arg)
"Delete a numbered footnote.
With no parameter, delete the footnote under (point). With ARG specified,
delete the footnote with that number."
(interactive "*P")
(unless arg
- (setq arg (Footnote-under-cursor)))
+ (setq arg (footnote--under-cursor)))
(when (and arg
(or (not footnote-prompt-before-deletion)
(y-or-n-p (format "Really delete footnote %d?" arg))))
@@ -681,7 +851,7 @@ delete the footnote with that number."
(save-excursion
(goto-char (car locn))
(when (looking-back (concat (regexp-quote footnote-start-tag)
- (Footnote-current-regexp)
+ (footnote--current-regexp)
(regexp-quote footnote-end-tag))
(line-beginning-position))
(delete-region (match-beginning 0) (match-end 0))))
@@ -692,20 +862,20 @@ delete the footnote with that number."
(point)
(if footnote-spaced-footnotes
(search-forward "\n\n" nil t)
- (save-restriction
+ (save-restriction ; <= 2017-12 Boruch: WHY?? I see no narrowing / widening here.
(end-of-line)
(next-single-char-property-change
- (point) 'footnote-number nil (Footnote-goto-char-point-max))))))
+ (point) 'footnote-number nil (footnote--goto-char-point-max))))))
(setq footnote-pointer-marker-alist
(delq alist-ptr footnote-pointer-marker-alist))
(setq footnote-text-marker-alist
(delq alist-txt footnote-text-marker-alist))
- (Footnote-renumber-footnotes)
+ (footnote-renumber-footnotes)
(when (and (null footnote-text-marker-alist)
(null footnote-pointer-marker-alist))
(save-excursion
(if (not (string-equal footnote-section-tag ""))
- (let* ((end (Footnote-goto-char-point-max))
+ (let* ((end (footnote--goto-char-point-max))
(start (1- (re-search-backward
(concat "^" footnote-section-tag-regexp)
nil t))))
@@ -715,13 +885,13 @@ delete the footnote with that number."
(delete-region start (if (< end (point-max))
end
(point-max))))
- (Footnote-goto-char-point-max)
+ (footnote--goto-char-point-max)
(when (looking-back "\n\n" (- (point) 2))
(kill-line -1))))))))
-(defun Footnote-renumber-footnotes (&optional arg)
+(defun footnote-renumber-footnotes ()
"Renumber footnotes, starting from 1."
- (interactive "*P")
+ (interactive "*")
(save-excursion
(let ((i 0)
(notes (length footnote-pointer-marker-alist))
@@ -730,16 +900,16 @@ delete the footnote with that number."
(setq alist-ptr (nth i footnote-pointer-marker-alist))
(setq alist-txt (nth i footnote-text-marker-alist))
(unless (= (1+ i) (car alist-ptr))
- (Footnote-renumber (car alist-ptr) (1+ i) alist-ptr alist-txt))
+ (footnote--renumber (car alist-ptr) (1+ i) alist-ptr alist-txt))
(setq i (1+ i))))))
-(defun Footnote-goto-footnote (&optional arg)
+(defun footnote-goto-footnote (&optional arg)
"Jump to the text of a footnote.
With no parameter, jump to the text of the footnote under (point). With ARG
specified, jump to the text of that footnote."
(interactive "P")
(unless arg
- (setq arg (Footnote-under-cursor)))
+ (setq arg (footnote--under-cursor)))
(let ((footnote (assq arg footnote-text-marker-alist)))
(cond
(footnote
@@ -755,13 +925,13 @@ specified, jump to the text of that footnote."
(t
(error "I don't see a footnote here")))))
-(defun Footnote-back-to-message (&optional arg)
+(defun footnote-back-to-message ()
"Move cursor back to footnote referent.
If the cursor is not over the text of a footnote, point is not changed.
If the buffer was narrowed due to `footnote-narrow-to-footnotes-when-editing'
being set it is automatically widened."
- (interactive "P")
- (let ((note (Footnote-text-under-cursor)))
+ (interactive)
+ (let ((note (footnote--text-under-cursor)))
(when note
(when footnote-narrow-to-footnotes-when-editing
(widen))
@@ -769,13 +939,13 @@ being set it is automatically widened."
(defvar footnote-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "a" 'Footnote-add-footnote)
- (define-key map "b" 'Footnote-back-to-message)
- (define-key map "c" 'Footnote-cycle-style)
- (define-key map "d" 'Footnote-delete-footnote)
- (define-key map "g" 'Footnote-goto-footnote)
- (define-key map "r" 'Footnote-renumber-footnotes)
- (define-key map "s" 'Footnote-set-style)
+ (define-key map "a" 'footnote-add-footnote)
+ (define-key map "b" 'footnote-back-to-message)
+ (define-key map "c" 'footnote-cycle-style)
+ (define-key map "d" 'footnote-delete-footnote)
+ (define-key map "g" 'footnote-goto-footnote)
+ (define-key map "r" 'footnote-renumber-footnotes)
+ (define-key map "s" 'footnote-set-style)
map))
(defvar footnote-minor-mode-map
@@ -787,9 +957,6 @@ being set it is automatically widened."
;;;###autoload
(define-minor-mode footnote-mode
"Toggle Footnote mode.
-With a prefix argument ARG, enable Footnote mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Footnote mode is a buffer-local minor mode. If enabled, it
provides footnote support for `message-mode'. To get started,
@@ -798,8 +965,14 @@ play around with the following keys:
:lighter footnote-mode-line-string
:keymap footnote-minor-mode-map
;; (filladapt-mode t)
+ (unless adaptive-fill-function
+ ;; nil and `ignore' have the same semantics for adaptive-fill-function,
+ ;; but only `ignore' behaves correctly with add/remove-function.
+ (setq adaptive-fill-function #'ignore))
+ (remove-function (local 'adaptive-fill-function)
+ #'footnote--adaptive-fill-function)
(when footnote-mode
- ;; (Footnote-setup-keybindings)
+ ;; (footnote-setup-keybindings)
(make-local-variable 'footnote-style)
(make-local-variable 'footnote-body-tag-spacing)
(make-local-variable 'footnote-spaced-footnotes)
@@ -807,7 +980,12 @@ play around with the following keys:
(make-local-variable 'footnote-section-tag-regexp)
(make-local-variable 'footnote-start-tag)
(make-local-variable 'footnote-end-tag)
+ (make-local-variable 'adaptive-fill-function)
+ (add-function :around (local 'adaptive-fill-function)
+ #'footnote--adaptive-fill-function)
+ ;; filladapt is an XEmacs package which AFAIK has never been ported
+ ;; to Emacs.
(when (boundp 'filladapt-token-table)
;; add tokens to filladapt to match footnotes
;; 1] xxxxxxxxxxx x x x or [1] x x x x x x x
diff --git a/lisp/mail/hashcash.el b/lisp/mail/hashcash.el
index 9fdc7ea756c..60689529974 100644
--- a/lisp/mail/hashcash.el
+++ b/lisp/mail/hashcash.el
@@ -1,4 +1,4 @@
-;;; hashcash.el --- Add hashcash payments to email
+;;; hashcash.el --- Add hashcash payments to email -*- lexical-binding:t -*-
;; Copyright (C) 2003-2005, 2007-2019 Free Software Foundation, Inc.
@@ -47,7 +47,7 @@
;;; Code:
-(eval-when-compile (require 'cl)) ; for case
+(eval-when-compile (require 'cl-lib))
(defgroup hashcash nil
"Hashcash configuration."
@@ -133,18 +133,18 @@ For example, you may want to set this to (\"-Z2\") to reduce header length."
(declare-function message-narrow-to-headers-or-head "message" ())
(declare-function message-fetch-field "message" (header &optional not-all))
-(declare-function message-goto-eoh "message" ())
+(declare-function message-goto-eoh "message" (&optional interactive))
(declare-function message-narrow-to-headers "message" ())
(defun hashcash-token-substring ()
(save-excursion
(let ((token ""))
- (loop
+ (cl-loop
(setq token
(concat token (buffer-substring (point) (hashcash-point-at-eol))))
(goto-char (hashcash-point-at-eol))
(forward-char 1)
- (unless (looking-at "[ \t]") (return token))
+ (unless (looking-at "[ \t]") (cl-return token))
(while (looking-at "[ \t]") (forward-char 1))))))
(defun hashcash-payment-required (addr)
@@ -182,8 +182,7 @@ Return immediately. Call CALLBACK with process and result when ready."
(setq hashcash-process-alist (cons
(cons process (current-buffer))
hashcash-process-alist))
- (set-process-filter process `(lambda (process output)
- (funcall ,callback process output))))
+ (set-process-filter process callback))
(funcall callback nil nil)))
(defun hashcash-check-payment (token str val)
@@ -244,8 +243,9 @@ Only start calculation. Results are inserted when ready."
(hashcash-generate-payment-async
(hashcash-payment-to arg)
(hashcash-payment-required arg)
- `(lambda (process payment)
- (hashcash-insert-payment-async-2 ,(current-buffer) process payment)))))
+ (let ((buf (current-buffer)))
+ (lambda (process payment)
+ (hashcash-insert-payment-async-2 buf process payment))))))
(defun hashcash-insert-payment-async-2 (buffer process pay)
(when (buffer-live-p buffer)
@@ -298,7 +298,7 @@ BUFFER defaults to the current buffer."
(let* ((split (split-string token ":"))
(key (if (< (hashcash-version token) 1.2)
(nth 1 split)
- (case (string-to-number (nth 0 split))
+ (pcase (string-to-number (nth 0 split))
(0 (nth 2 split))
(1 (nth 3 split))))))
(cond ((null resource)
diff --git a/lisp/mail/ietf-drums.el b/lisp/mail/ietf-drums.el
index bc0fc2b74e6..29752cb5c28 100644
--- a/lisp/mail/ietf-drums.el
+++ b/lisp/mail/ietf-drums.el
@@ -1,4 +1,4 @@
-;;; ietf-drums.el --- Functions for parsing RFC 2822 headers
+;;; ietf-drums.el --- Functions for parsing RFC 2822 headers -*- lexical-binding:t -*-
;; Copyright (C) 1998-2019 Free Software Foundation, Inc.
@@ -37,7 +37,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defvar ietf-drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177"
"US-ASCII control characters excluding CR, LF and white space.")
@@ -78,10 +78,10 @@ backslash and doublequote.")
(defun ietf-drums-token-to-list (token)
"Translate TOKEN into a list of characters."
(let ((i 0)
- b e c out range)
+ b c out range)
(while (< i (length token))
(setq c (aref token i))
- (incf i)
+ (cl-incf i)
(cond
((eq c ?-)
(if b
@@ -90,7 +90,7 @@ backslash and doublequote.")
(range
(while (<= b c)
(push (make-char 'ascii b) out)
- (incf b))
+ (cl-incf b))
(setq range nil))
((= i (length token))
(push (make-char 'ascii c) out))
@@ -115,7 +115,7 @@ backslash and doublequote.")
(setq c (char-after))
(cond
((eq c ?\")
- (condition-case err
+ (condition-case nil
(forward-sexp 1)
(error (goto-char (point-max)))))
((eq c ?\()
@@ -185,8 +185,12 @@ STRING is assumed to be a string that is extracted from
the Content-Transfer-Encoding header of a mail."
(ietf-drums-remove-garbage (inline (ietf-drums-strip string))))
-(defun ietf-drums-parse-address (string)
- "Parse STRING and return a MAILBOX / DISPLAY-NAME pair."
+(declare-function rfc2047-decode-string "rfc2047" (string &optional address-mime))
+
+(defun ietf-drums-parse-address (string &optional decode)
+ "Parse STRING and return a MAILBOX / DISPLAY-NAME pair.
+If DECODE, the DISPLAY-NAME will have RFC2047 decoding performed
+(that's the \"=?utf...q...=?\") stuff."
(with-temp-buffer
(let (display-name mailbox c display-string)
(ietf-drums-init string)
@@ -236,7 +240,9 @@ the Content-Transfer-Encoding header of a mail."
(cons
(mapconcat 'identity (nreverse display-name) "")
(ietf-drums-get-comment string)))
- (cons mailbox display-string)))))
+ (cons mailbox (if decode
+ (rfc2047-decode-string display-string)
+ display-string))))))
(defun ietf-drums-parse-addresses (string &optional rawp)
"Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs.
@@ -288,7 +294,7 @@ a list of address strings."
(defun ietf-drums-parse-date (string)
"Return an Emacs time spec from STRING."
- (apply 'encode-time (parse-time-string string)))
+ (encode-time (parse-time-string string)))
(defun ietf-drums-narrow-to-header ()
"Narrow to the header section in the current buffer."
diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el
index 9fcc2707d75..cb57d8ea016 100644
--- a/lisp/mail/mail-extr.el
+++ b/lisp/mail/mail-extr.el
@@ -293,7 +293,7 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"."
;; multipart names.
;; #### should . be in here?
(defconst mail-extr-all-letters
- (purecopy (concat mail-extr-all-letters-but-separators "---")))
+ (purecopy (concat mail-extr-all-letters-but-separators "-")))
;; Any character that can start a name.
;; Keep this set as minimal as possible.
@@ -305,19 +305,11 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"."
(defconst mail-extr-leading-garbage "\\W+")
-;; (defconst mail-extr-non-name-chars
-;; (purecopy (concat "^" mail-extr-all-letters ".")))
;; (defconst mail-extr-non-begin-name-chars
;; (purecopy (concat "^" mail-extr-first-letters)))
;; (defconst mail-extr-non-end-name-chars
;; (purecopy (concat "^" mail-extr-last-letters)))
-;; Matches an initial not followed by both a period and a space.
-;; (defconst mail-extr-bad-initials-pattern
-;; (purecopy
-;; (format "\\(\\([^%s]\\|\\`\\)[%s]\\)\\(\\.\\([^ ]\\)\\| \\|\\([^%s .]\\)\\|\\'\\)"
-;; mail-extr-all-letters mail-extr-first-letters mail-extr-all-letters)))
-
;; Matches periods used instead of spaces. Must not match the period
;; following an initial.
(defconst mail-extr-bad-dot-pattern
@@ -654,7 +646,7 @@ Unless NO-REPLACE is true, at each of the positions in LIST-SYMBOL
(< ch ,beg-symbol))
,@(if no-replace
nil
- `((mail-extr-nuke-char-at ch)))
+ '((mail-extr-nuke-char-at ch)))
(setcar temp nil))
(setq temp (cdr temp)))
(setq ,list-symbol (delq nil ,list-symbol))))
@@ -715,7 +707,13 @@ one recipients, all but the first is ignored.
ADDRESS may be a string or a buffer. If it is a buffer, the visible
\(narrowed) portion of the buffer will be interpreted as the address.
\(This feature exists so that the clever caller might be able to avoid
-consing a string.)"
+consing a string.)
+
+This function is primarily meant for when you're displaying the
+result to the user: Many prettifications are applied to the
+result returned. If you want to decode an address for further
+non-display use, you should probably use
+`mail-header-parse-address' instead."
(let ((canonicalization-buffer (get-buffer-create " *canonical address*"))
(extraction-buffer (get-buffer-create " *extract address components*"))
value-list)
diff --git a/lisp/mail/mail-utils.el b/lisp/mail/mail-utils.el
index 0d489499f59..cbcbdfaeb2e 100644
--- a/lisp/mail/mail-utils.el
+++ b/lisp/mail/mail-utils.el
@@ -41,7 +41,7 @@ often correct parser."
If this is nil, it is set the first time you compose a reply, to
a value which excludes your own email address.
-Matching addresses are excluded from the CC field in replies, and
+Matching addresses are excluded from the Cc field in replies, and
also the To field, unless this would leave an empty To field."
:type '(choice regexp (const :tag "Your Name" nil))
:group 'mail)
diff --git a/lisp/mail/mailabbrev.el b/lisp/mail/mailabbrev.el
index ee48b2cd021..d59df88c688 100644
--- a/lisp/mail/mailabbrev.el
+++ b/lisp/mail/mailabbrev.el
@@ -25,7 +25,7 @@
;;; Commentary:
-;; This file ensures that, when the point is in a To:, CC:, BCC:, or From:
+;; This file ensures that, when the point is in a To:, Cc:, Bcc:, or From:
;; field, word-abbrevs are defined for each of your mail aliases. These
;; aliases will be defined from your .mailrc file (or the file specified by
;; `mail-personal-alias-file') if it exists. Your mail aliases will
@@ -134,9 +134,6 @@
;;;###autoload
(define-minor-mode mail-abbrevs-mode
"Toggle abbrev expansion of mail aliases (Mail Abbrevs mode).
-With a prefix argument ARG, enable Mail Abbrevs mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Mail Abbrevs mode is a global minor mode. When enabled,
abbrev-like expansion is performed when editing certain mail
@@ -166,7 +163,8 @@ no aliases, which is represented by this being a table with no entries.)")
(defun mail-abbrevs-sync-aliases ()
(when mail-personal-alias-file
(if (file-exists-p mail-personal-alias-file)
- (let ((modtime (nth 5 (file-attributes mail-personal-alias-file))))
+ (let ((modtime (file-attribute-modification-time
+ (file-attributes mail-personal-alias-file))))
(if (not (equal mail-abbrev-modtime modtime))
(progn
(setq mail-abbrev-modtime modtime)
@@ -179,7 +177,8 @@ no aliases, which is represented by this being a table with no entries.)")
(file-exists-p mail-personal-alias-file))
(progn
(setq mail-abbrev-modtime
- (nth 5 (file-attributes mail-personal-alias-file)))
+ (file-attribute-modification-time
+ (file-attributes mail-personal-alias-file)))
(build-mail-abbrevs)))
(mail-abbrevs-sync-aliases)
(add-function :around (local 'abbrev-expand-function)
@@ -414,7 +413,7 @@ with a space."
;;; Syntax tables and abbrev-expansion
(defcustom mail-abbrev-mode-regexp
- "^\\(Resent-\\)?\\(To\\|From\\|CC\\|BCC\\|Reply-to\\):"
+ "^\\(Resent-\\)?\\(To\\|From\\|Cc\\|Bcc\\|Reply-To\\):"
"Regexp matching mail headers in which mail abbrevs should be expanded.
This string will be handed to `looking-at' with point at the beginning
of the current line; if it matches, abbrev mode will be turned on, otherwise
@@ -477,7 +476,7 @@ of a mail alias. The value is set up, buffer-local, when first needed.")
;; Necessary for `message-read-from-minibuffer' to work.
(window-minibuffer-p))
- ;; We are in a To: (or CC:, or whatever) header or a minibuffer,
+ ;; We are in a To: (or Cc:, or whatever) header or a minibuffer,
;; and should use word-abbrevs to expand mail aliases.
(let ((local-abbrev-table mail-abbrevs))
diff --git a/lisp/mail/mailalias.el b/lisp/mail/mailalias.el
index 981f1450da7..42896c18ebe 100644
--- a/lisp/mail/mailalias.el
+++ b/lisp/mail/mailalias.el
@@ -50,14 +50,14 @@
When t this still needs to be initialized.")
(defvar mail-address-field-regexp
- "^\\(Resent-\\)?\\(To\\|From\\|CC\\|BCC\\|Reply-to\\):")
+ "^\\(Resent-\\)?\\(To\\|From\\|Cc\\|Bcc\\|Reply-To\\):")
(defvar pattern)
(defcustom mail-complete-alist
;; Don't refer to mail-address-field-regexp here;
;; that confuses some things such as cus-dep.el.
- '(("^\\(Resent-\\)?\\(To\\|From\\|CC\\|BCC\\|Reply-to\\):"
+ '(("^\\(Resent-\\)?\\(To\\|From\\|Cc\\|Bcc\\|Reply-To\\):"
. (mail-get-names pattern))
("Newsgroups:" . (if (boundp 'gnus-active-hashtb)
gnus-active-hashtb
@@ -169,7 +169,7 @@ When t this still needs to be initialized.")
(defun expand-mail-aliases (beg end &optional exclude)
"Expand all mail aliases in suitable header fields found between BEG and END.
If interactive, expand in header fields.
-Suitable header fields are `To', `From', `CC' and `BCC', `Reply-to', and
+Suitable header fields are `To', `From', `Cc' and `Bcc', `Reply-To', and
their `Resent-' variants.
Optional second arg EXCLUDE may be a regular expression defining text to be
diff --git a/lisp/mail/mspools.el b/lisp/mail/mspools.el
index 9aaf86d401c..9c8e72e7f48 100644
--- a/lisp/mail/mspools.el
+++ b/lisp/mail/mspools.el
@@ -387,7 +387,7 @@ nil."
(let ((file (concat mspools-folder-directory spool))
size)
(setq file (or (file-symlink-p file) file))
- (setq size (nth 7 (file-attributes file)))
+ (setq size (file-attribute-size (file-attributes file)))
;; size could be nil if the sym-link points to a non-existent file
;; so check this first.
(if (and size (> size 0))
diff --git a/lisp/mail/rfc2047.el b/lisp/mail/rfc2047.el
index a1c65cbe930..118ca8a4c9b 100644
--- a/lisp/mail/rfc2047.el
+++ b/lisp/mail/rfc2047.el
@@ -290,11 +290,10 @@ Should be called narrowed to the head of the message."
(let ((rfc2047-encoding-type 'mime))
(rfc2047-encode-region (point) (point-max))))
((eq method 'default)
- (if (and (default-value 'enable-multibyte-characters)
- mail-parse-charset)
+ (if mail-parse-charset
(encode-coding-region (point) (point-max)
mail-parse-charset)))
- ;; We get this when CC'ing messages to newsgroups with
+ ;; We get this when Cc'ing messages to newsgroups with
;; 8-bit names. The group name mail copy just got
;; unconditionally encoded. Previously, it would ask
;; whether to encode, which was quite confusing for the
@@ -305,18 +304,17 @@ Should be called narrowed to the head of the message."
;; in accordance with changes elsewhere.
((null method)
(rfc2047-encode-region (point) (point-max)))
-;;; ((null method)
-;;; (if (or (message-options-get
-;;; 'rfc2047-encode-message-header-encode-any)
-;;; (message-options-set
-;;; 'rfc2047-encode-message-header-encode-any
-;;; (y-or-n-p
-;;; "Some texts are not encoded. Encode anyway?")))
-;;; (rfc2047-encode-region (point-min) (point-max))
-;;; (error "Cannot send unencoded text")))
+ ;; ((null method)
+ ;; (if (or (message-options-get
+ ;; 'rfc2047-encode-message-header-encode-any)
+ ;; (message-options-set
+ ;; 'rfc2047-encode-message-header-encode-any
+ ;; (y-or-n-p
+ ;; "Some texts are not encoded. Encode anyway?")))
+ ;; (rfc2047-encode-region (point-min) (point-max))
+ ;; (error "Cannot send unencoded text")))
((mm-coding-system-p method)
- (when (default-value 'enable-multibyte-characters)
- (encode-coding-region (point) (point-max) method)))
+ (encode-coding-region (point) (point-max) method))
;; Hm.
(t)))
(goto-char (point-max))))))))
diff --git a/lisp/mail/rfc2231.el b/lisp/mail/rfc2231.el
index 31112a7505a..0a0983c25f8 100644
--- a/lisp/mail/rfc2231.el
+++ b/lisp/mail/rfc2231.el
@@ -1,4 +1,4 @@
-;;; rfc2231.el --- Functions for decoding rfc2231 headers
+;;; rfc2231.el --- Functions for decoding rfc2231 headers -*- lexical-binding:t -*-
;; Copyright (C) 1998-2019 Free Software Foundation, Inc.
@@ -22,7 +22,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'ietf-drums)
(require 'rfc2047)
(autoload 'mm-encode-body "mm-bodies")
@@ -181,7 +181,7 @@ must never cause a Lisp error."
;; Now collect and concatenate continuation parameters.
(let ((cparams nil)
elem)
- (loop for (attribute value part encoded)
+ (cl-loop for (attribute value part encoded)
in (sort parameters (lambda (e1 e2)
(< (or (caddr e1) 0)
(or (caddr e2) 0))))
@@ -291,7 +291,7 @@ the result of this function."
(insert param "*=")
(while (not (eobp))
(insert (if (>= num 0) " " "")
- param "*" (format "%d" (incf num)) "*=")
+ param "*" (format "%d" (cl-incf num)) "*=")
(forward-line 1))))
(spacep
(goto-char (point-min))
diff --git a/lisp/mail/rmail-spam-filter.el b/lisp/mail/rmail-spam-filter.el
index 36e50693fb1..86217e5dd5c 100644
--- a/lisp/mail/rmail-spam-filter.el
+++ b/lisp/mail/rmail-spam-filter.el
@@ -251,7 +251,7 @@ it from rmail file. Called for each new message retrieved by
(setq message-subject (mail-fetch-field "Subject"))
(setq message-content-type (mail-fetch-field "Content-Type"))
(setq message-spam-status (mail-fetch-field "X-Spam-Status")))
- ;; Check for blind CC condition. Set vars such that while
+ ;; Check for blind cc condition. Set vars such that while
;; loop will be bypassed and spam condition will trigger.
(and rsf-no-blind-cc
(null message-recipients)
diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el
index a740c4bfa23..91291b8d330 100644
--- a/lisp/mail/rmail.el
+++ b/lisp/mail/rmail.el
@@ -191,9 +191,6 @@ Its name should end with a slash."
:group 'rmail-retrieve
:type '(choice (const nil) string))
-(define-obsolete-variable-alias 'rmail-pop-password
- 'rmail-remote-password "22.1")
-
(defcustom rmail-remote-password nil
"Password to use when reading mail from a remote server.
This setting is ignored for mailboxes whose URL already contains a password."
@@ -202,9 +199,6 @@ This setting is ignored for mailboxes whose URL already contains a password."
:group 'rmail-retrieve
:version "22.1")
-(define-obsolete-variable-alias 'rmail-pop-password-required
- 'rmail-remote-password-required "22.1")
-
(defcustom rmail-remote-password-required nil
"Non-nil if a password is required when reading mail from a remote server."
:type 'boolean
@@ -857,7 +851,7 @@ that knows the exact ordering of the \\( \\) subexpressions.")
(beginning-of-line) (end-of-line)
(1 font-lock-comment-delimiter-face nil t)
(5 font-lock-comment-face nil t)))
- '("^\\(X-[a-z0-9-]+\\|In-reply-to\\|Date\\):.*\\(\n[ \t]+.*\\)*$"
+ '("^\\(X-[a-z0-9-]+\\|In-Reply-To\\|Date\\):.*\\(\n[ \t]+.*\\)*$"
. 'rmail-header-name))))
"Additional expressions to highlight in Rmail mode.")
@@ -1331,8 +1325,7 @@ Instead, these commands are available:
(let ((finding-rmail-file (not (eq major-mode 'rmail-mode))))
(rmail-mode-2)
(when (and finding-rmail-file
- (null coding-system-for-read)
- (default-value 'enable-multibyte-characters))
+ (null coding-system-for-read))
(let ((rmail-enable-multibyte t))
(rmail-require-mime-maybe)
(rmail-convert-file-maybe)
@@ -1759,7 +1752,7 @@ not be a new one). It returns non-nil if it got any new messages."
(or (eq buffer-undo-list t)
(setq buffer-undo-list nil))
(let ((all-files (if file-name (list file-name) rmail-inbox-list))
- (rmail-enable-multibyte (default-value 'enable-multibyte-characters))
+ (rmail-enable-multibyte t)
found)
(unwind-protect
(progn
@@ -2035,10 +2028,10 @@ Value is the size of the newly read mail after conversion."
"the remote server"
proto)))
((and (file-exists-p tofile)
- (/= 0 (nth 7 (file-attributes tofile))))
+ (/= 0 (file-attribute-size (file-attributes tofile))))
(message "Getting mail from %s..." tofile))
((and (file-exists-p file)
- (/= 0 (nth 7 (file-attributes file))))
+ (/= 0 (file-attribute-size (file-attributes file))))
(message "Getting mail from %s..." file)))
;; Set TOFILE if have not already done so, and
;; rename or copy the file FILE to TOFILE if and as appropriate.
@@ -2582,7 +2575,7 @@ the message. Point is at the beginning of the message."
(save-excursion
(setq deleted-head
(cons (if (and (search-forward (concat rmail-attribute-header ": ") message-end t)
- (looking-at "?D"))
+ (looking-at "\\?D"))
?D
?\s) deleted-head))))
@@ -3400,21 +3393,15 @@ Interactively, empty argument means use same regexp used last time."
(defun rmail-simplified-subject (&optional msgnum)
"Return the simplified subject of message MSGNUM (or current message).
-Simplifying the subject means stripping leading and trailing whitespace,
-and typical reply prefixes such as Re:."
- (let ((subject (or (rmail-get-header "Subject" msgnum) "")))
+Simplifying the subject means stripping leading and trailing
+whitespace, replacing whitespace runs with a single space and
+removing prefixes such as Re:, Fwd: and so on and mailing list
+tags such as [tag]."
+ (let ((subject (or (rmail-get-header "Subject" msgnum) ""))
+ (regexp "\\`[ \t\n]*\\(\\(\\w\\{1,3\\}:\\|\\[[^]]+]\\)[ \t\n]+\\)*"))
(setq subject (rfc2047-decode-string subject))
- (if (string-match "\\`[ \t]+" subject)
- (setq subject (substring subject (match-end 0))))
- (if (string-match rmail-reply-regexp subject)
- (setq subject (substring subject (match-end 0))))
- (if (string-match "[ \t]+\\'" subject)
- (setq subject (substring subject 0 (match-beginning 0))))
- ;; If Subject is long, mailers will break it into several lines at
- ;; arbitrary places, so normalize whitespace by replacing every
- ;; run of whitespace characters with a single space.
- (setq subject (replace-regexp-in-string "[ \t\n]+" " " subject))
- subject))
+ (setq subject (replace-regexp-in-string regexp "" subject))
+ (replace-regexp-in-string "[ \t\n]+" " " subject)))
(defun rmail-simplified-subject-regexp ()
"Return a regular expression matching the current simplified subject.
@@ -3803,7 +3790,7 @@ original message into it."
(defun rmail-reply (just-sender)
"Reply to the current message.
-Normally include CC: to all other recipients of original message;
+Normally include Cc: to all other recipients of original message;
prefix argument means ignore them. While composing the reply,
use \\[mail-yank-original] to yank the original message into it."
(interactive "P")
@@ -3837,7 +3824,7 @@ use \\[mail-yank-original] to yank the original message into it."
(unless just-sender
(if (mail-fetch-field "mail-followup-to" nil t)
;; If this header field is present, use it instead of the
- ;; To and CC fields.
+ ;; To and Cc fields.
(setq to (mail-fetch-field "mail-followup-to" nil t))
(setq cc (or (mail-fetch-field "cc" nil t) "")
to (or (mail-fetch-field "to" nil t) ""))))))
@@ -4140,6 +4127,7 @@ typically for purposes of moderating a list."
"^ *---+ +Original message follows +---+ *$\\|"
"^ *---+ +Your message follows +---+ *$\\|"
"^|? *---+ +Message text follows: +---+ *|?$\\|"
+ "^ *---+ +This is a copy of \\w+ message, including all the headers.*---+ *\n *---+ +The body of the message is [0-9]+ characters long; only the first *\n *---+ +[0-9]+ or so are included here\\. *$\\|"
"^ *---+ +This is a copy of \\w+ message, including all the headers.*---+ *$")
"A regexp that matches the separator before the text of a failed message.")
@@ -4288,7 +4276,7 @@ specifying headers which should not be copied into the new message."
(if mail-self-blind
(if resending
(insert "Resent-Bcc: " (user-login-name) "\n")
- (insert "BCC: " (user-login-name) "\n"))))
+ (insert "Bcc: " (user-login-name) "\n"))))
(goto-char (point-min))
(mail-position-on-field (if resending "Resent-To" "To") t))))))
@@ -4528,7 +4516,7 @@ encoded string (and the same mask) will decode the string."
(if (= curmask 0)
(setq curmask mask))
(setq charmask (% curmask 256))
- (setq curmask (lsh curmask -8))
+ (setq curmask (ash curmask -8))
(aset string-vector i (logxor charmask (aref string-vector i)))
(setq i (1+ i)))
(concat string-vector)))
@@ -4556,6 +4544,9 @@ Argument MIME is non-nil if this is a mime message."
(unless armor-end
(error "Encryption armor beginning has no matching end"))
+ (setq armor-start (move-marker (make-marker) armor-start))
+ (setq armor-end (move-marker (make-marker) armor-end))
+
(goto-char armor-start)
;; Because epa--find-coding-system-for-mime-charset not autoloaded.
@@ -4588,15 +4579,16 @@ Argument MIME is non-nil if this is a mime message."
(mail-unquote-printable-region armor-start
(- (point-max) after-end))))
- ;; Decrypt it, maybe in place, maybe making new buffer.
- (epa-decrypt-region
- armor-start (- (point-max) after-end)
- ;; Call back this function to prepare the output.
- (lambda ()
- (let ((inhibit-read-only t))
- (delete-region armor-start (- (point-max) after-end))
- (goto-char armor-start)
- (current-buffer))))
+ (condition-case nil
+ (epa-decrypt-region
+ armor-start (- (point-max) after-end)
+ ;; Call back this function to prepare the output.
+ (lambda ()
+ (let ((inhibit-read-only t))
+ (delete-region armor-start (- (point-max) after-end))
+ (goto-char armor-start)
+ (current-buffer))))
+ (error nil))
(list armor-start (- (point-max) after-end) mime
armor-end-regexp
@@ -4632,9 +4624,14 @@ Argument MIME is non-nil if this is a mime message."
(goto-char (point-min))
(while (re-search-forward "-----BEGIN PGP MESSAGE-----$" nil t)
(let ((coding-system-for-read coding-system-for-read)
- (case-fold-search t))
-
- (push (rmail-epa-decrypt-1 mime) decrypts)))
+ (case-fold-search t)
+ (armor-start (match-beginning 0)))
+ ;; Don't decrypt an armor that was copied into
+ ;; the message from a message it is a reply to.
+ (or (equal (buffer-substring (line-beginning-position)
+ armor-start)
+ "> ")
+ (push (rmail-epa-decrypt-1 mime) decrypts))))
(when (and decrypts (eq major-mode 'rmail-mode))
(rmail-add-label "decrypt"))
diff --git a/lisp/mail/rmailout.el b/lisp/mail/rmailout.el
index 1a6f4e55fbc..12d37615d6b 100644
--- a/lisp/mail/rmailout.el
+++ b/lisp/mail/rmailout.el
@@ -56,6 +56,13 @@ The function `rmail-delete-unwanted-fields' uses this, ignoring case."
regexp)
:group 'rmail-output)
+(defcustom rmail-output-reset-deleted-flag nil
+ "Non-nil means reset the \"deleted\" flag when outputting a message to a file."
+ :type '(choice (const :tag "Output with the \"deleted\" flag reset" t)
+ (const :tag "Output with the \"deleted\" flag intact" nil))
+ :version "27.1"
+ :group 'rmail-output)
+
(defun rmail-output-read-file-name ()
"Read the file name to use for `rmail-output'.
Set `rmail-default-file' to this name as well as returning it.
@@ -472,9 +479,15 @@ buffer, updates it accordingly.
This command always outputs the complete message header, even if
the header display is currently pruned.
+If `rmail-output-reset-deleted-flag' is non-nil, the message's
+deleted flag is reset in the message appended to the destination
+file. Otherwise, the appended message will remain marked as
+deleted if it was deleted before invoking this command.
+
Optional prefix argument COUNT (default 1) says to output that
many consecutive messages, starting with the current one (ignoring
-deleted messages). If `rmail-delete-after-output' is non-nil, deletes
+deleted messages, unless `rmail-output-reset-deleted-flag' is
+non-nil). If `rmail-delete-after-output' is non-nil, deletes
messages after output.
The optional third argument NOATTRIBUTE, if non-nil, says not to
@@ -533,30 +546,47 @@ from a non-Rmail buffer. In this case, COUNT is ignored."
(if (zerop rmail-total-messages)
(error "No messages to output"))
(let ((orig-count count)
- beg end)
+ beg end delete-attr-reset-p)
(while (> count 0)
- (setq beg (rmail-msgbeg rmail-current-message)
- end (rmail-msgend rmail-current-message))
- ;; All access to the buffer's local variables is now finished...
- (save-excursion
- ;; ... so it is ok to go to a different buffer.
- (if (rmail-buffers-swapped-p) (set-buffer rmail-view-buffer))
- (setq cur (current-buffer))
- (save-restriction
- (widen)
- (with-temp-buffer
- (insert-buffer-substring cur beg end)
- (if babyl-format
- (rmail-output-as-babyl file-name noattribute)
- (rmail-output-as-mbox file-name noattribute)))))
+ (when (and rmail-output-reset-deleted-flag
+ (rmail-message-deleted-p rmail-current-message))
+ (rmail-set-attribute rmail-deleted-attr-index nil)
+ (setq delete-attr-reset-p t))
+ ;; Make sure we undo our messing with the DELETED attribute.
+ (unwind-protect
+ (progn
+ (setq beg (rmail-msgbeg rmail-current-message)
+ end (rmail-msgend rmail-current-message))
+ ;; All access to the buffer's local variables is now finished...
+ (save-excursion
+ ;; ... so it is ok to go to a different buffer.
+ (if (rmail-buffers-swapped-p) (set-buffer rmail-view-buffer))
+ (setq cur (current-buffer))
+ (save-restriction
+ (widen)
+ (with-temp-buffer
+ (insert-buffer-substring cur beg end)
+ (if babyl-format
+ (rmail-output-as-babyl file-name noattribute)
+ (rmail-output-as-mbox file-name noattribute))))))
+ (if delete-attr-reset-p
+ (rmail-set-attribute rmail-deleted-attr-index t)))
(or noattribute ; mark message as "filed"
(rmail-set-attribute rmail-filed-attr-index t))
(setq count (1- count))
(let ((next-message-p
- (if rmail-delete-after-output
- (rmail-delete-forward)
- (if (> count 0)
- (rmail-next-undeleted-message 1))))
+ (if rmail-output-reset-deleted-flag
+ (progn
+ (if rmail-delete-after-output
+ (rmail-delete-message))
+ (if (> count 0)
+ (let ((msgnum rmail-current-message))
+ (rmail-next-message 1)
+ (eq rmail-current-message (1+ msgnum)))))
+ (if rmail-delete-after-output
+ (rmail-delete-forward)
+ (if (> count 0)
+ (rmail-next-undeleted-message 1)))))
(num-appended (- orig-count count)))
(if (and (> count 0) (not next-message-p))
(error "Only %d message%s appended" num-appended
diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el
index 2ed01a00df6..79a322c1d91 100644
--- a/lisp/mail/rmailsum.el
+++ b/lisp/mail/rmailsum.el
@@ -390,8 +390,17 @@ SUBJECT is a regular expression."
;;;###autoload
(defun rmail-summary-by-senders (senders)
"Display a summary of all messages whose \"From\" field matches SENDERS.
-SENDERS is a regular expression."
- (interactive "sSenders to summarize by: ")
+SENDERS is a regular expression. The default for SENDERS matches the
+sender of the current messsage."
+ (interactive
+ (let* ((def (rmail-get-header "From"))
+ ;; We quote the default argument, because if it contains regexp
+ ;; special characters (eg "?"), it can fail to match itself.
+ (sender (regexp-quote def))
+ (prompt (concat "Senders to summarize by (regexp"
+ (if sender ", default this message's sender" "")
+ "): ")))
+ (list (read-string prompt nil nil sender))))
(rmail-new-summary
(concat "senders " senders)
(list 'rmail-summary-by-senders senders) 'rmail-message-senders-p senders))
@@ -1306,11 +1315,7 @@ advance to the next message."
(select-window rmail-buffer-window)
(prog1
;; Is EOB visible in the buffer?
- (save-excursion
- (let ((ht (window-height)))
- (move-to-window-line (- ht 2))
- (end-of-line)
- (eobp)))
+ (pos-visible-in-window-p (point-max))
(select-window rmail-summary-window)))
(if (not rmail-summary-scroll-between-messages)
(error "End of buffer")
@@ -1333,10 +1338,7 @@ move to the previous message."
(select-window rmail-buffer-window)
(prog1
;; Is BOB visible in the buffer?
- (save-excursion
- (move-to-window-line 0)
- (beginning-of-line)
- (bobp))
+ (pos-visible-in-window-p (point-min))
(select-window rmail-summary-window)))
(if (not rmail-summary-scroll-between-messages)
(error "Beginning of buffer")
@@ -1626,7 +1628,7 @@ original message into it."
(defun rmail-summary-reply (just-sender)
"Reply to the current message.
-Normally include CC: to all other recipients of original message;
+Normally include Cc: to all other recipients of original message;
prefix argument means ignore them. While composing the reply,
use \\[mail-yank-original] to yank the original message into it."
(interactive "P")
diff --git a/lisp/mail/sendmail.el b/lisp/mail/sendmail.el
index 21c85dae2cf..93b6c90521b 100644
--- a/lisp/mail/sendmail.el
+++ b/lisp/mail/sendmail.el
@@ -1,4 +1,4 @@
-;;; sendmail.el --- mail sending commands for Emacs
+;;; sendmail.el --- mail sending commands for Emacs -*- lexical-binding:t -*-
;; Copyright (C) 1985-1986, 1992-1996, 1998, 2000-2019 Free Software
;; Foundation, Inc.
@@ -55,7 +55,7 @@
:type 'file)
;;;###autoload
-(defcustom mail-from-style 'default
+(defcustom mail-from-style 'angles
"Specifies how \"From:\" fields look.
If nil, they contain just the return address like:
@@ -72,8 +72,11 @@ Otherwise, most addresses look like `angles', but they look like
(const parens)
(const angles)
(const default))
- :version "20.3"
+ :version "27.1"
:group 'sendmail)
+(make-obsolete-variable
+ 'mail-from-style
+ "only the `angles' value is valid according to RFC2822." "27.1" 'set)
;;;###autoload
(defcustom mail-specify-envelope-from nil
@@ -104,9 +107,9 @@ being sent is used), or nil (in which case the value of
;;;###autoload
(defcustom mail-self-blind nil
- "Non-nil means insert BCC to self in messages to be sent.
+ "Non-nil means insert Bcc to self in messages to be sent.
This is done when the message is initialized,
-so you can remove or alter the BCC field to override the default."
+so you can remove or alter the Bcc field to override the default."
:type 'boolean
:group 'sendmail)
@@ -185,7 +188,7 @@ be a Babyl file."
;;;###autoload
(defcustom mail-default-reply-to nil
- "Address to insert as default Reply-to field of outgoing messages.
+ "Address to insert as default Reply-To field of outgoing messages.
If nil, it will be initialized from the REPLYTO environment variable
when you first send mail."
:type '(choice (const nil) string)
@@ -243,15 +246,6 @@ Used by `mail-yank-original' via `mail-indent-citation'."
:type 'integer
:group 'sendmail)
-(defvar mail-yank-hooks nil
- "Obsolete hook for modifying a citation just inserted in the mail buffer.
-Each hook function can find the citation between (point) and (mark t).
-And each hook function should leave point and mark around the citation
-text as modified.
-This is a normal hook, misnamed for historical reasons.
-It is obsolete and mail agents should no longer use it.")
-(make-obsolete-variable 'mail-yank-hooks 'mail-citation-hook "19.34")
-
;;;###autoload
(defcustom mail-citation-hook nil
"Hook for modifying a citation just inserted in the mail buffer.
@@ -479,7 +473,7 @@ by Emacs.)")
(cite-prefix "[:alpha:]")
(cite-suffix (concat cite-prefix "0-9_.@-`'\"")))
(list '("^\\(To\\|Newsgroups\\):" . font-lock-function-name-face)
- '("^\\(B?CC\\|Reply-to\\|Mail-\\(reply\\|followup\\)-to\\):" . font-lock-keyword-face)
+ '("^\\(B?Cc\\|Reply-To\\|Mail-\\(Reply\\|Followup\\)-To\\):" . font-lock-keyword-face)
'("^\\(Subject:\\)[ \t]*\\(.+\\)?"
(1 font-lock-comment-face)
;; (2 font-lock-type-face nil t)
@@ -499,7 +493,7 @@ by Emacs.)")
(beginning-of-line) (end-of-line)
(1 font-lock-comment-delimiter-face nil t)
(5 font-lock-comment-face nil t)))
- '("^\\(X-[A-Za-z0-9-]+\\|In-reply-to\\):.*\\(\n[ \t]+.*\\)*$"
+ '("^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):.*\\(\n[ \t]+.*\\)*$"
. font-lock-string-face))))
"Additional expressions to highlight in Mail mode.")
@@ -511,9 +505,13 @@ This also saves the value of `send-mail-function' via Customize."
;; If send-mail-function is already setup, we're incorrectly called
;; a second time, probably because someone's using an old value
;; of send-mail-function.
- (when (eq send-mail-function 'sendmail-query-once)
- (sendmail-query-user-about-smtp))
- (funcall send-mail-function))
+ (if (not (eq send-mail-function 'sendmail-query-once))
+ (funcall send-mail-function)
+ (let ((function (sendmail-query-user-about-smtp)))
+ (funcall function)
+ (when (y-or-n-p "Save this mail sending choice?")
+ (setq send-mail-function function)
+ (customize-save-variable 'send-mail-function function)))))
(defun sendmail-query-user-about-smtp ()
(let* ((options `(("mail client" . mailclient-send-it)
@@ -558,12 +556,13 @@ This also saves the value of `send-mail-function' via Customize."
(completing-read
(format "Send mail via (default %s): " (caar options))
options nil 'require-match nil nil (car options))))))
- (customize-save-variable 'send-mail-function
- (cdr (assoc-string choice options t)))))
+ ;; Return the choice.
+ (cdr (assoc-string choice options t))))
(defun sendmail-sync-aliases ()
(when mail-personal-alias-file
- (let ((modtime (nth 5 (file-attributes mail-personal-alias-file))))
+ (let ((modtime (file-attribute-modification-time
+ (file-attributes mail-personal-alias-file))))
(or (equal mail-alias-modtime modtime)
(setq mail-alias-modtime modtime
mail-aliases t)))))
@@ -616,7 +615,7 @@ This also saves the value of `send-mail-function' via Customize."
(kill-local-variable 'buffer-file-coding-system)
;; This doesn't work for enable-multibyte-characters.
;; (kill-local-variable 'enable-multibyte-characters)
- (set-buffer-multibyte (default-value 'enable-multibyte-characters))
+ (set-buffer-multibyte t)
(if current-input-method
(deactivate-input-method))
@@ -644,7 +643,7 @@ This also saves the value of `send-mail-function' via Customize."
(newline))
(if cc
(let ((fill-prefix "\t")
- (address-start (progn (insert "CC: ") (point))))
+ (address-start (progn (insert "Cc: ") (point))))
(insert cc "\n")
(fill-region-as-paragraph address-start (point-max))
(goto-char (point-max))
@@ -654,7 +653,7 @@ This also saves the value of `send-mail-function' via Customize."
(let ((fill-prefix "\t")
(fill-column 78)
(address-start (point)))
- (insert "In-reply-to: " in-reply-to "\n")
+ (insert "In-Reply-To: " in-reply-to "\n")
(fill-region-as-paragraph address-start (point-max))
(goto-char (point-max))
(unless (bolp)
@@ -663,11 +662,11 @@ This also saves the value of `send-mail-function' via Customize."
(if mail-default-headers
(insert mail-default-headers))
(if mail-default-reply-to
- (insert "Reply-to: " mail-default-reply-to "\n"))
+ (insert "Reply-To: " mail-default-reply-to "\n"))
(if mail-self-blind
- (insert "BCC: " user-mail-address "\n"))
+ (insert "Bcc: " user-mail-address "\n"))
(if mail-archive-file-name
- (insert "FCC: " mail-archive-file-name "\n"))
+ (insert "Fcc: " mail-archive-file-name "\n"))
(put-text-property (point)
(progn
(insert mail-header-separator "\n")
@@ -703,8 +702,8 @@ Like Text Mode but with these additional commands:
Here are commands that move to a header field (and create it if there isn't):
\\[mail-to] move to To: \\[mail-subject] move to Subj:
- \\[mail-bcc] move to BCC: \\[mail-cc] move to CC:
- \\[mail-fcc] move to FCC: \\[mail-reply-to] move to Reply-To:
+ \\[mail-bcc] move to Bcc: \\[mail-cc] move to Cc:
+ \\[mail-fcc] move to Fcc: \\[mail-reply-to] move to Reply-To:
\\[mail-mail-reply-to] move to Mail-Reply-To:
\\[mail-mail-followup-to] move to Mail-Followup-To:
\\[mail-text] move to message text.
@@ -786,8 +785,12 @@ Concretely: replace the first blank line in the header with the separator."
(defun mail-sendmail-undelimit-header ()
"Remove header separator to put the message in correct form for sendmail.
Leave point at the start of the delimiter line."
- (rfc822-goto-eoh)
- (delete-region (point) (progn (end-of-line) (point))))
+ (goto-char (point-min))
+ (when (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n")
+ nil t)
+ (replace-match "\n"))
+ (rfc822-goto-eoh))
(defun mail-mode-auto-fill ()
"Carry out Auto Fill for Mail mode.
@@ -911,7 +914,7 @@ the user from the mailer."
(regexp-opt mail-mailing-lists t)
"\\(?:[[:space:];,]\\|\\'\\)"))))
(mail-combine-fields "To")
- (mail-combine-fields "CC")
+ (mail-combine-fields "Cc")
;; If there are mailing lists defined
(when ml
(save-excursion
@@ -1141,7 +1144,7 @@ to combine them into one, and does so if the user says y."
;; Try to preserve alignment of contents of the field
(let ((prefix-length (length (match-string 0))))
(replace-match " ")
- (dotimes (i (1- prefix-length))
+ (dotimes (_ (1- prefix-length))
(insert " ")))))))
(set-marker first-to-end nil))))))
@@ -1226,7 +1229,7 @@ external program defined by `sendmail-program'."
;; the message specially.
(let ((case-fold-search t))
(goto-char (point-min))
- (while (re-search-forward "^Resent-\\(to\\|cc\\|bcc\\):" delimline t)
+ (while (re-search-forward "^Resent-\\(To\\|Cc\\|Bcc\\):" delimline t)
;; Put a list of such addresses in resend-to-addresses.
(setq resend-to-addresses
(save-restriction
@@ -1238,7 +1241,7 @@ external program defined by `sendmail-program'."
(point)))
(append (mail-parse-comma-list)
resend-to-addresses)))
- ;; Delete Resent-BCC ourselves
+ ;; Delete Resent-Bcc ourselves
(if (save-excursion (beginning-of-line)
(looking-at "resent-bcc"))
(delete-region (line-beginning-position)
@@ -1301,9 +1304,9 @@ external program defined by `sendmail-program'."
(goto-char (1+ delimline))
(if (eval mail-mailer-swallows-blank-line)
(newline))
- ;; Find and handle any FCC fields.
+ ;; Find and handle any Fcc fields.
(goto-char (point-min))
- (if (re-search-forward "^FCC:" delimline t)
+ (if (re-search-forward "^Fcc:" delimline t)
(progn
(setq fcc-was-found t)
(mail-do-fcc delimline)))
@@ -1377,8 +1380,8 @@ external program defined by `sendmail-program'."
(autoload 'rmail-output-to-rmail-buffer "rmailout")
(defun mail-do-fcc (header-end)
- "Find and act on any FCC: headers in the current message before HEADER-END.
-If a buffer is visiting the FCC file, append to it before
+ "Find and act on any Fcc: headers in the current message before HEADER-END.
+If a buffer is visiting the Fcc file, append to it before
offering to save it, if it was modified initially. If this is an
Rmail buffer, update Rmail as needed. If there is no buffer,
just append to the file, in Babyl format if necessary."
@@ -1390,7 +1393,7 @@ just append to the file, in Babyl format if necessary."
(save-excursion
(goto-char (point-min))
(let ((case-fold-search t))
- (while (re-search-forward "^FCC:[ \t]*" header-end t)
+ (while (re-search-forward "^Fcc:[ \t]*" header-end t)
(push (buffer-substring (point)
(progn
(end-of-line)
@@ -1469,7 +1472,7 @@ just append to the file, in Babyl format if necessary."
;; If the file is a Babyl file, convert the message to
;; Babyl format. Even though Rmail no longer uses
;; Babyl, this code can remain for the time being, on
- ;; the off-chance one FCCs to a Babyl file that has
+ ;; the off-chance one Fccs to a Babyl file that has
;; not yet been converted to mbox.
(let ((coding-system-for-write
(or rmail-file-coding-system 'emacs-mule)))
@@ -1490,7 +1493,7 @@ just append to the file, in Babyl format if necessary."
(set-visited-file-modtime)))))))))
(defun mail-sent-via ()
- "Make a Sent-via header line from each To or CC header line."
+ "Make a Sent-via header line from each To or Cc header line."
(declare (obsolete "nobody can remember what it is for." "24.1"))
(interactive)
(save-excursion
@@ -1525,7 +1528,7 @@ just append to the file, in Babyl format if necessary."
(mail-position-on-field "Subject"))
(defun mail-cc ()
- "Move point to end of CC field, creating it if necessary."
+ "Move point to end of Cc field, creating it if necessary."
(interactive)
(expand-abbrev)
(or (mail-position-on-field "cc" t)
@@ -1533,20 +1536,20 @@ just append to the file, in Babyl format if necessary."
(insert "\nCC: "))))
(defun mail-bcc ()
- "Move point to end of BCC field, creating it if necessary."
+ "Move point to end of Bcc field, creating it if necessary."
(interactive)
(expand-abbrev)
(or (mail-position-on-field "bcc" t)
(progn (mail-position-on-field "to")
- (insert "\nBCC: "))))
+ (insert "\nBcc: "))))
(defun mail-fcc (folder)
- "Add a new FCC field, with file name completion."
+ "Add a new Fcc field, with file name completion."
(interactive "FFolder carbon copy: ")
(expand-abbrev)
- (or (mail-position-on-field "fcc" t) ;Put new field after exiting FCC.
+ (or (mail-position-on-field "fcc" t) ;Put new field after exiting Fcc.
(mail-position-on-field "to"))
- (insert "\nFCC: " folder))
+ (insert "\nFcc: " folder))
(defun mail-reply-to ()
"Move point to end of Reply-To field, creating it if necessary."
@@ -1717,8 +1720,6 @@ and don't delete any header fields."
(rfc822-goto-eoh)
(point))))))
(run-hooks 'mail-citation-hook)))
- (mail-yank-hooks
- (run-hooks 'mail-yank-hooks))
(t
(mail-indent-citation)))))
;; This is like exchange-point-and-mark, but doesn't activate the mark.
@@ -1787,9 +1788,7 @@ and don't delete any header fields."
(rfc822-goto-eoh)
(point))))))
(run-hooks 'mail-citation-hook))
- (if mail-yank-hooks
- (run-hooks 'mail-yank-hooks)
- (mail-indent-citation))))))))
+ (mail-indent-citation)))))))
(defun mail-split-line ()
"Split current line, moving portion beyond point vertically down.
@@ -1853,13 +1852,13 @@ Various special commands starting with C-c are available in sendmail mode
to move to message header fields:
\\{mail-mode-map}
-If `mail-self-blind' is non-nil, a BCC to yourself is inserted
+If `mail-self-blind' is non-nil, a Bcc to yourself is inserted
when the message is initialized.
If `mail-default-reply-to' is non-nil, it should be an address (a string);
-a Reply-to: field with that address is inserted.
+a Reply-To: field with that address is inserted.
-If `mail-archive-file-name' is non-nil, an FCC field with that file name
+If `mail-archive-file-name' is non-nil, an Fcc field with that file name
is inserted.
The normal hook `mail-setup-hook' is run after the message is
@@ -1958,6 +1957,7 @@ The seventh argument ACTIONS is a list of actions to take
;; Require dired so that dired-trivial-filenames does not get
;; unbound on exit from the let.
(require 'dired)
+ (defvar dired-trivial-filenames)
(let ((dired-trivial-filenames t))
(dired-other-window wildcard (concat dired-listing-switches " -t")))
(rename-buffer "*Auto-saved Drafts*" t)
diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el
index 0043fafb4a0..f31e0b45d20 100644
--- a/lisp/mail/smtpmail.el
+++ b/lisp/mail/smtpmail.el
@@ -1,4 +1,4 @@
-;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail
+;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail -*- lexical-binding:t -*-
;; Copyright (C) 1995-1996, 2001-2019 Free Software Foundation, Inc.
@@ -138,7 +138,7 @@ The commands enables verbose information from the SMTP server."
(defcustom smtpmail-code-conv-from nil
"Coding system for encoding outgoing mail.
Used for the value of `sendmail-coding-system' when
-`select-message-coding-system' is called. "
+`select-message-coding-system' is called."
:type 'coding-system
:group 'smtpmail)
@@ -150,7 +150,8 @@ and sent with `smtpmail-send-queued-mail'."
:group 'smtpmail)
(defcustom smtpmail-queue-dir "~/Mail/queued-mail/"
- "Directory where `smtpmail.el' stores queued mail."
+ "Directory where `smtpmail.el' stores queued mail.
+This directory should not be writable by other users."
:type 'directory
:group 'smtpmail)
@@ -179,9 +180,11 @@ This is relative to `smtpmail-queue-dir'."
;; Buffer-local variable.
(defvar smtpmail-read-point)
-(defconst smtpmail-auth-supported '(cram-md5 plain login)
+(defvar smtpmail-auth-supported '(cram-md5 plain login)
"List of supported SMTP AUTH mechanisms.
-The list is in preference order.")
+The list is in preference order.
+Every element should have a matching `cl-defmethod' for
+for `smtpmail-try-auth-method'.")
(defvar smtpmail-mail-address nil
"Value to use for envelope-from address for mail from ambient buffer.")
@@ -320,11 +323,11 @@ The list is in preference order.")
(goto-char (1+ delimline))
(if (eval mail-mailer-swallows-blank-line)
(newline))
- ;; Find and handle any FCC fields.
+ ;; Find and handle any Fcc fields.
(goto-char (point-min))
- (if (re-search-forward "^FCC:" delimline t)
+ (if (re-search-forward "^Fcc:" delimline t)
;; Force `mail-do-fcc' to use the encoding of the mail
- ;; buffer to encode outgoing messages on FCC files.
+ ;; buffer to encode outgoing messages on Fcc files.
(let ((coding-system-for-write
;; mbox files must have Unix EOLs.
(coding-system-change-eol-conversion
@@ -359,9 +362,7 @@ The list is in preference order.")
smtpmail-queue-dir))
(file-data (convert-standard-filename file-data))
(file-elisp (concat file-data ".el"))
- (buffer-data (create-file-buffer file-data))
- (buffer-elisp (create-file-buffer file-elisp))
- (buffer-scratch "*queue-mail*"))
+ (buffer-data (create-file-buffer file-data)))
(unless (file-exists-p smtpmail-queue-dir)
(make-directory smtpmail-queue-dir t))
(with-current-buffer buffer-data
@@ -376,22 +377,16 @@ The list is in preference order.")
nil t)
(insert-buffer-substring tembuf)
(write-file file-data)
- (set-buffer buffer-elisp)
- (erase-buffer)
- (insert (concat
- "(setq smtpmail-recipient-address-list '"
+ (write-region
+ (concat "(setq smtpmail-recipient-address-list '"
(prin1-to-string smtpmail-recipient-address-list)
- ")\n"))
- (write-file file-elisp)
- (set-buffer (generate-new-buffer buffer-scratch))
- (insert (concat file-data "\n"))
- (append-to-file (point-min)
- (point-max)
- (expand-file-name smtpmail-queue-index-file
- smtpmail-queue-dir)))
- (kill-buffer buffer-scratch)
- (kill-buffer buffer-data)
- (kill-buffer buffer-elisp))))
+ ")\n")
+ nil file-elisp nil 'silent)
+ (write-region (concat file-data "\n") nil
+ (expand-file-name smtpmail-queue-index-file
+ smtpmail-queue-dir)
+ t 'silent))
+ (kill-buffer buffer-data))))
(kill-buffer tembuf)
(if (bufferp errbuf)
(kill-buffer errbuf)))))
@@ -412,7 +407,20 @@ The list is in preference order.")
(while (not (eobp))
(setq file-data (buffer-substring (point) (line-end-position)))
(setq file-elisp (concat file-data ".el"))
- (load file-elisp)
+ ;; FIXME: Avoid `load' which can execute arbitrary code and is hence
+ ;; a source of security holes. Better read the file and extract the
+ ;; data "by hand".
+ ;;(load file-elisp)
+ (with-temp-buffer
+ (insert-file-contents file-elisp)
+ (goto-char (point-min))
+ (pcase (read (current-buffer))
+ (`(setq smtpmail-recipient-address-list ',v)
+ (skip-chars-forward " \n\t")
+ (unless (eobp) (message "Ignoring trailing text in %S"
+ file-elisp))
+ (setq smtpmail-recipient-address-list v))
+ (sexp (error "Unexpected code in %S: %S" file-elisp sexp))))
;; Insert the message literally: it is already encoded as per
;; the MIME headers, and code conversions might guess the
;; encoding wrongly.
@@ -510,8 +518,7 @@ The list is in preference order.")
(user (plist-get auth-info :user))
(password (plist-get auth-info :secret))
(save-function (and ask-for-password
- (plist-get auth-info :save-function)))
- ret)
+ (plist-get auth-info :save-function))))
(when (functionp password)
(setq password (funcall password)))
(when (and user
@@ -532,7 +539,10 @@ The list is in preference order.")
(when (functionp password)
(setq password (funcall password)))
(let ((result (catch 'done
- (smtpmail-try-auth-method process mech user password))))
+ (if (and mech user password)
+ (smtpmail-try-auth-method process mech user password)
+ ;; No mechanism, or no credentials.
+ mech))))
(if (stringp result)
(progn
(auth-source-forget+ :host host :port port)
@@ -541,51 +551,52 @@ The list is in preference order.")
(funcall save-function))
result))))
-(defun smtpmail-try-auth-method (process mech user password)
- (let (ret)
- (cond
- ((or (not mech)
- (not user)
- (not password))
- ;; No mechanism, or no credentials.
- mech)
- ((eq mech 'cram-md5)
- (setq ret (smtpmail-command-or-throw process "AUTH CRAM-MD5"))
- (when (eq (car ret) 334)
- (let* ((challenge (substring (cadr ret) 4))
- (decoded (base64-decode-string challenge))
- (hash (rfc2104-hash 'md5 64 16 password decoded))
- (response (concat user " " hash))
- ;; Osamu Yamane <yamane@green.ocn.ne.jp>:
- ;; SMTP auth fails because the SMTP server identifies
- ;; only the first part of the string (delimited by
- ;; new line characters) as a response from the
- ;; client, and the rest as distinct commands.
-
- ;; In my case, the response string is 80 characters
- ;; long. Without the no-line-break option for
- ;; `base64-encode-string', only the first 76 characters
- ;; are taken as a response to the server, and the
- ;; authentication fails.
- (encoded (base64-encode-string response t)))
- (smtpmail-command-or-throw process encoded))))
- ((eq mech 'login)
- (smtpmail-command-or-throw process "AUTH LOGIN")
- (smtpmail-command-or-throw process (base64-encode-string user t))
- (smtpmail-command-or-throw process (base64-encode-string password t)))
- ((eq mech 'plain)
- ;; We used to send an empty initial request, and wait for an
- ;; empty response, and then send the password, but this
- ;; violate a SHOULD in RFC 2222 paragraph 5.1. Note that this
- ;; is not sent if the server did not advertise AUTH PLAIN in
- ;; the EHLO response. See RFC 2554 for more info.
- (smtpmail-command-or-throw
- process
- (concat "AUTH PLAIN "
- (base64-encode-string (concat "\0" user "\0" password) t))
- 235))
- (t
- (error "Mechanism %s not implemented" mech)))))
+(cl-defgeneric smtpmail-try-auth-method (_process mech _user _password)
+ "Perform authentication of type MECH for USER with PASSWORD.
+MECH should be one of the values in `smtpmail-auth-supported'.
+USER and PASSWORD should be non-nil."
+ (error "Mechanism %S not implemented" mech))
+
+(cl-defmethod smtpmail-try-auth-method
+ (process (_mech (eql cram-md5)) user password)
+ (let ((ret (smtpmail-command-or-throw process "AUTH CRAM-MD5")))
+ (when (eq (car ret) 334)
+ (let* ((challenge (substring (cadr ret) 4))
+ (decoded (base64-decode-string challenge))
+ (hash (rfc2104-hash 'md5 64 16 password decoded))
+ (response (concat user " " hash))
+ ;; Osamu Yamane <yamane@green.ocn.ne.jp>:
+ ;; SMTP auth fails because the SMTP server identifies
+ ;; only the first part of the string (delimited by
+ ;; new line characters) as a response from the
+ ;; client, and the rest as distinct commands.
+
+ ;; In my case, the response string is 80 characters
+ ;; long. Without the no-line-break option for
+ ;; `base64-encode-string', only the first 76 characters
+ ;; are taken as a response to the server, and the
+ ;; authentication fails.
+ (encoded (base64-encode-string response t)))
+ (smtpmail-command-or-throw process encoded)))))
+
+(cl-defmethod smtpmail-try-auth-method
+ (process (_mech (eql login)) user password)
+ (smtpmail-command-or-throw process "AUTH LOGIN")
+ (smtpmail-command-or-throw process (base64-encode-string user t))
+ (smtpmail-command-or-throw process (base64-encode-string password t)))
+
+(cl-defmethod smtpmail-try-auth-method
+ (process (_mech (eql plain)) user password)
+ ;; We used to send an empty initial request, and wait for an
+ ;; empty response, and then send the password, but this
+ ;; violate a SHOULD in RFC 2222 paragraph 5.1. Note that this
+ ;; is not sent if the server did not advertise AUTH PLAIN in
+ ;; the EHLO response. See RFC 2554 for more info.
+ (smtpmail-command-or-throw
+ process
+ (concat "AUTH PLAIN "
+ (base64-encode-string (concat "\0" user "\0" password) t))
+ 235))
(defun smtpmail-response-code (string)
(when string
@@ -664,7 +675,6 @@ Returns an error if the server cannot be contacted."
(and from
(cadr (mail-extract-address-components from))))
(smtpmail-user-mail-address)))
- response-code
process-buffer
result
auth-mechanisms
@@ -681,7 +691,9 @@ Returns an error if the server cannot be contacted."
(setq buffer-undo-list t)
(erase-buffer))
- ;; open the connection to the server
+ ;; Open the connection to the server.
+ ;; FIXME: Should we use raw-text-dos coding system to handle the r\n
+ ;; for us?
(let ((coding-system-for-read 'binary)
(coding-system-for-write 'binary))
(setq result
@@ -718,9 +730,8 @@ Returns an error if the server cannot be contacted."
(throw 'done (format "Connection not allowed: %s" greeting))))
(with-current-buffer process-buffer
- (set-buffer-process-coding-system 'raw-text-unix 'raw-text-unix)
- (make-local-variable 'smtpmail-read-point)
- (setq smtpmail-read-point (point-min))
+ (set-process-coding-system process 'raw-text-unix 'raw-text-unix)
+ (setq-local smtpmail-read-point (point-min))
(let* ((capabilities (plist-get (cdr result) :capabilities))
(code (smtpmail-response-code capabilities)))
@@ -943,8 +954,7 @@ Returns an error if the server cannot be contacted."
(if (and (multibyte-string-p data)
smtpmail-code-conv-from)
- (setq data (string-as-multibyte
- (encode-coding-string data smtpmail-code-conv-from))))
+ (setq data (encode-coding-string data smtpmail-code-conv-from)))
(if smtpmail-debug-info
(insert data "\r\n"))
@@ -990,9 +1000,9 @@ Returns an error if the server cannot be contacted."
;; RESENT-* fields should stop processing of regular fields.
(save-excursion
(setq addr-regexp
- (if (re-search-forward "^Resent-\\(to\\|cc\\|bcc\\):"
+ (if (re-search-forward "^Resent-\\(To\\|Cc\\|Bcc\\):"
header-end t)
- "^Resent-\\(to\\|cc\\|bcc\\):"
+ "^Resent-\\(To\\|Cc\\|Bcc\\):"
"^\\(To:\\|Cc:\\|Bcc:\\)")))
(while (re-search-forward addr-regexp header-end t)
@@ -1025,14 +1035,14 @@ Returns an error if the server cannot be contacted."
(setq smtpmail-recipient-address-list recipient-address-list))))))
(defun smtpmail-do-bcc (header-end)
- "Delete [Resent-]BCC: and their continuation lines from the header area.
-There may be multiple BCC: lines, and each may have arbitrarily
+ "Delete [Resent-]Bcc: and their continuation lines from the header area.
+There may be multiple Bcc: lines, and each may have arbitrarily
many continuation lines."
(let ((case-fold-search t))
(save-excursion
(goto-char (point-min))
- ;; iterate over all BCC: lines
- (while (re-search-forward "^\\(RESENT-\\)?BCC:" header-end t)
+ ;; iterate over all Bcc: lines
+ (while (re-search-forward "^\\(RESENT-\\)?Bcc:" header-end t)
(delete-region (match-beginning 0)
(progn (forward-line 1) (point)))
;; get rid of any continuation lines
diff --git a/lisp/mail/supercite.el b/lisp/mail/supercite.el
index 4809c33abc4..ad69dca8c43 100644
--- a/lisp/mail/supercite.el
+++ b/lisp/mail/supercite.el
@@ -634,12 +634,7 @@ the list should be unique."
(deallocate-event event))
(setq quit-flag nil)
(signal 'quit '())))
- (let ((char
- (if (featurep 'xemacs)
- (let* ((key (and (key-press-event-p event) (event-key event)))
- (char (and key (event-to-character event))))
- char)
- event))
+ (let ((char event)
elt)
(if char (setq char (downcase char)))
(cond
@@ -651,9 +646,7 @@ the list should be unique."
nil)
(t
(message "%s%s" p (single-key-description event))
- (if (featurep 'xemacs)
- (ding nil 'y-or-n-p)
- (ding))
+ (ding)
(discard-input)
(if (eq p prompt)
(setq p (concat "Try again. " prompt)))))))
@@ -1887,8 +1880,7 @@ and `sc-post-hook' is run after the guts of this function."
;; grab point and mark since the region is probably not active when
;; this function gets automatically called. we want point to be a
;; mark so any deleting before point works properly
- (let* ((zmacs-regions nil) ; for XEemacs
- (mark-active t) ; for Emacs
+ (let* ((mark-active t)
(point (point-marker))
(mark (copy-marker (mark-marker))))
diff --git a/lisp/mail/uce.el b/lisp/mail/uce.el
index d0837d90ea1..7225cda6c0e 100644
--- a/lisp/mail/uce.el
+++ b/lisp/mail/uce.el
@@ -338,7 +338,7 @@ You might need to set `uce-mail-reader' before using this."
(if mail-default-headers
(insert mail-default-headers))
(if mail-default-reply-to
- (insert "Reply-to: " mail-default-reply-to "\n"))
+ (insert "Reply-To: " mail-default-reply-to "\n"))
(insert mail-header-separator "\n")
;; Insert all our text. Then go back to the place where we started.
(if to (setq to (point)))
diff --git a/lisp/mail/uudecode.el b/lisp/mail/uudecode.el
index a78202938e4..32e668baab3 100644
--- a/lisp/mail/uudecode.el
+++ b/lisp/mail/uudecode.el
@@ -1,4 +1,4 @@
-;;; uudecode.el -- elisp native uudecode
+;;; uudecode.el -- elisp native uudecode -*- lexical-binding:t -*-
;; Copyright (C) 1998-2019 Free Software Foundation, Inc.
@@ -24,13 +24,10 @@
;;; Code:
-(eval-when-compile (require 'cl))
-
-(eval-and-compile
- (defalias 'uudecode-char-int
- (if (fboundp 'char-int)
- 'char-int
- 'identity)))
+(defalias 'uudecode-char-int
+ (if (fboundp 'char-int)
+ 'char-int
+ 'identity))
(defgroup uudecode nil
"Decoding of uuencoded data."
@@ -78,7 +75,7 @@ input and write the converted data to its standard output."
If FILE-NAME is non-nil, save the result to FILE-NAME. The program
used is specified by `uudecode-decoder-program'."
(interactive "r\nP")
- (let ((cbuf (current-buffer)) tempfile firstline status)
+ (let ((cbuf (current-buffer)) tempfile firstline)
(save-excursion
(goto-char start)
(when (re-search-forward uudecode-begin-line nil t)
@@ -110,7 +107,7 @@ used is specified by `uudecode-decoder-program'."
(insert "begin 600 " (file-name-nondirectory tempfile) "\n")
(insert-buffer-substring cbuf firstline end)
(cd (file-name-directory tempfile))
- (apply 'call-process-region
+ (apply #'call-process-region
(point-min)
(point-max)
uudecode-decoder-program
@@ -128,20 +125,6 @@ used is specified by `uudecode-decoder-program'."
(message "Can not uudecode")))
(ignore-errors (or file-name (delete-file tempfile))))))
-(eval-and-compile
- (defalias 'uudecode-string-to-multibyte
- (cond
- ((featurep 'xemacs)
- 'identity)
- ((fboundp 'string-to-multibyte)
- 'string-to-multibyte)
- (t
- (lambda (string)
- "Return a multibyte string with the same individual chars as string."
- (mapconcat
- (lambda (ch) (string-as-multibyte (char-to-string ch)))
- string ""))))))
-
;;;###autoload
(defun uudecode-decode-region-internal (start end &optional file-name)
"Uudecode region between START and END without using an external program.
@@ -188,12 +171,12 @@ If FILE-NAME is non-nil, save the result to FILE-NAME."
(cond ((= counter 4)
(setq result (cons
(concat
- (char-to-string (lsh bits -16))
- (char-to-string (logand (lsh bits -8) 255))
+ (char-to-string (ash bits -16))
+ (char-to-string (logand (ash bits -8) 255))
(char-to-string (logand bits 255)))
result))
(setq bits 0 counter 0))
- (t (setq bits (lsh bits 6)))))))
+ (t (setq bits (ash bits 6)))))))
(cond
(done)
((> 0 remain)
@@ -205,24 +188,24 @@ If FILE-NAME is non-nil, save the result to FILE-NAME."
((= counter 3)
(setq result (cons
(concat
- (char-to-string (logand (lsh bits -16) 255))
- (char-to-string (logand (lsh bits -8) 255)))
+ (char-to-string (logand (ash bits -16) 255))
+ (char-to-string (logand (ash bits -8) 255)))
result)))
((= counter 2)
(setq result (cons
- (char-to-string (logand (lsh bits -10) 255))
+ (char-to-string (logand (ash bits -10) 255))
result))))
(skip-chars-forward non-data-chars end))
(if file-name
(with-temp-file file-name
(unless (featurep 'xemacs) (set-buffer-multibyte nil))
- (insert (apply 'concat (nreverse result))))
+ (insert (apply #'concat (nreverse result))))
(or (markerp end) (setq end (set-marker (make-marker) end)))
(goto-char start)
(if enable-multibyte-characters
(dolist (x (nreverse result))
- (insert (uudecode-string-to-multibyte x)))
- (insert (apply 'concat (nreverse result))))
+ (insert (decode-coding-string x 'binary)))
+ (insert (apply #'concat (nreverse result))))
(delete-region (point) end))))))
;;;###autoload
diff --git a/lisp/mail/yenc.el b/lisp/mail/yenc.el
index f7a12d6c9e2..75b62c14117 100644
--- a/lisp/mail/yenc.el
+++ b/lisp/mail/yenc.el
@@ -1,4 +1,4 @@
-;;; yenc.el --- elisp native yenc decoder
+;;; yenc.el --- elisp native yenc decoder -*- lexical-binding:t -*-
;; Copyright (C) 2002-2019 Free Software Foundation, Inc.
@@ -32,7 +32,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defconst yenc-begin-line
"^=ybegin.*$")
@@ -97,14 +97,14 @@
(cond ((or (eq char ?\r)
(eq char ?\n)))
((eq char ?=)
- (setq char (char-after (incf first)))
+ (setq char (char-after (cl-incf first)))
(with-current-buffer work-buffer
(insert-char (mod (- char 106) 256) 1)))
(t
(with-current-buffer work-buffer
;;(insert-char (mod (- char 42) 256) 1)
(insert-char (aref yenc-decoding-vector char) 1))))
- (incf first))
+ (cl-incf first))
(setq bytes (buffer-size work-buffer))
(unless (and (= (cdr (assq 'size header-alist)) bytes)
(= (cdr (assq 'size footer-alist)) bytes))
diff --git a/lisp/man.el b/lisp/man.el
index 409fadb66b8..b1d0fd3d17c 100644
--- a/lisp/man.el
+++ b/lisp/man.el
@@ -1157,7 +1157,7 @@ See the variable `Man-notify-method' for the different notification behaviors."
(let ((saved-frame (with-current-buffer man-buffer
Man-original-frame)))
(pcase Man-notify-method
- (`newframe
+ ('newframe
;; Since we run asynchronously, perhaps while Emacs is waiting
;; for input, we must not leave a different buffer current. We
;; can't rely on the editor command loop to reselect the
@@ -1168,25 +1168,25 @@ See the variable `Man-notify-method' for the different notification behaviors."
(set-window-dedicated-p (frame-selected-window frame) t)
(or (display-multi-frame-p frame)
(select-frame frame)))))
- (`pushy
+ ('pushy
(switch-to-buffer man-buffer))
- (`bully
+ ('bully
(and (frame-live-p saved-frame)
(select-frame saved-frame))
(pop-to-buffer man-buffer)
(delete-other-windows))
- (`aggressive
+ ('aggressive
(and (frame-live-p saved-frame)
(select-frame saved-frame))
(pop-to-buffer man-buffer))
- (`friendly
+ ('friendly
(and (frame-live-p saved-frame)
(select-frame saved-frame))
(display-buffer man-buffer 'not-this-window))
- (`polite
+ ('polite
(beep)
(message "Manual buffer %s is ready" (buffer-name man-buffer)))
- (`quiet
+ ('quiet
(message "Manual buffer %s is ready" (buffer-name man-buffer)))
(_ ;; meek
(message ""))
@@ -1538,16 +1538,16 @@ The following key bindings are currently in effect in the buffer:
(set (make-local-variable 'bookmark-make-record-function)
'Man-bookmark-make-record))
-(defsubst Man-build-section-alist ()
+(defun Man-build-section-list ()
"Build the list of manpage sections."
- (setq Man--sections nil)
+ (setq Man--sections ())
(goto-char (point-min))
(let ((case-fold-search nil))
- (while (re-search-forward Man-heading-regexp (point-max) t)
+ (while (re-search-forward Man-heading-regexp nil t)
(let ((section (match-string 1)))
(unless (member section Man--sections)
(push section Man--sections)))
- (forward-line 1)))
+ (forward-line)))
(setq Man--sections (nreverse Man--sections)))
(defsubst Man-build-references-alist ()
@@ -1828,7 +1828,7 @@ Specify which REFERENCE to use; default is based on word at point."
(widen)
(goto-char page-start)
(narrow-to-region page-start page-end)
- (Man-build-section-alist)
+ (Man-build-section-list)
(Man-build-references-alist)
(goto-char (point-min)))))
diff --git a/lisp/master.el b/lisp/master.el
index 671b3357a93..a054d7f597a 100644
--- a/lisp/master.el
+++ b/lisp/master.el
@@ -73,9 +73,6 @@ You can set this variable using `master-set-slave'.")
;;;###autoload
(define-minor-mode master-mode
"Toggle Master mode.
-With a prefix argument ARG, enable Master mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
When Master mode is enabled, you can scroll the slave buffer
using the following commands:
diff --git a/lisp/mb-depth.el b/lisp/mb-depth.el
index 9fecd47b611..61673ee8562 100644
--- a/lisp/mb-depth.el
+++ b/lisp/mb-depth.el
@@ -58,9 +58,6 @@ The prompt should already have been inserted."
;;;###autoload
(define-minor-mode minibuffer-depth-indicate-mode
"Toggle Minibuffer Depth Indication mode.
-With a prefix argument ARG, enable Minibuffer Depth Indication
-mode if ARG is positive, and disable it otherwise. If called
-from Lisp, enable the mode if ARG is omitted or nil.
Minibuffer Depth Indication mode is a global minor mode. When
enabled, any recursive use of the minibuffer will show the
diff --git a/lisp/md4.el b/lisp/md4.el
index ef15e2ce907..7091c206893 100644
--- a/lisp/md4.el
+++ b/lisp/md4.el
@@ -91,15 +91,15 @@ strings containing the character 0."
(let*
((h1 (+ (car a) (,func (car b) (car c) (car d)) (car xk) (car ac)))
(l1 (+ (cdr a) (,func (cdr b) (cdr c) (cdr d)) (cdr xk) (cdr ac)))
- (h2 (logand 65535 (+ h1 (lsh l1 -16))))
+ (h2 (logand 65535 (+ h1 (ash l1 -16))))
(l2 (logand 65535 l1))
;; cyclic shift of 32 bits integer
(h3 (logand 65535 (if (> s 15)
- (+ (lsh h2 (- s 32)) (lsh l2 (- s 16)))
- (+ (lsh h2 s) (lsh l2 (- s 16))))))
+ (+ (ash h2 (- s 32)) (ash l2 (- s 16)))
+ (+ (ash h2 s) (ash l2 (- s 16))))))
(l3 (logand 65535 (if (> s 15)
- (+ (lsh l2 (- s 32)) (lsh h2 (- s 16)))
- (+ (lsh l2 s) (lsh h2 (- s 16)))))))
+ (+ (ash l2 (- s 32)) (ash h2 (- s 16)))
+ (+ (ash l2 s) (ash h2 (- s 16)))))))
(cons h3 l3))))
(md4-make-step md4-round1 md4-F)
@@ -110,7 +110,7 @@ strings containing the character 0."
"Return 32-bit sum of 32-bit integers X and Y."
(let ((h (+ (car x) (car y)))
(l (+ (cdr x) (cdr y))))
- (cons (logand 65535 (+ h (lsh l -16))) (logand 65535 l))))
+ (cons (logand 65535 (+ h (ash l -16))) (logand 65535 l))))
(defsubst md4-and (x y)
(cons (logand (car x) (car y)) (logand (cdr x) (cdr y))))
@@ -185,8 +185,8 @@ The resulting MD4 value is placed in `md4-buffer'."
(let ((int32s (make-vector 16 0)) (i 0) j)
(while (< i 16)
(setq j (* i 4))
- (aset int32s i (cons (+ (aref seq (+ j 2)) (lsh (aref seq (+ j 3)) 8))
- (+ (aref seq j) (lsh (aref seq (1+ j)) 8))))
+ (aset int32s i (cons (+ (aref seq (+ j 2)) (ash (aref seq (+ j 3)) 8))
+ (+ (aref seq j) (ash (aref seq (1+ j)) 8))))
(setq i (1+ i)))
int32s))
@@ -197,7 +197,7 @@ The resulting MD4 value is placed in `md4-buffer'."
"Pack 16 bits integer in 2 bytes string as little endian."
(let ((str (make-string 2 0)))
(aset str 0 (logand int16 255))
- (aset str 1 (lsh int16 -8))
+ (aset str 1 (ash int16 -8))
str))
(defun md4-pack-int32 (int32)
@@ -207,20 +207,20 @@ integers (cons high low)."
(let ((str (make-string 4 0))
(h (car int32)) (l (cdr int32)))
(aset str 0 (logand l 255))
- (aset str 1 (lsh l -8))
+ (aset str 1 (ash l -8))
(aset str 2 (logand h 255))
- (aset str 3 (lsh h -8))
+ (aset str 3 (ash h -8))
str))
(defun md4-unpack-int16 (str)
(if (eq 2 (length str))
- (+ (lsh (aref str 1) 8) (aref str 0))
+ (+ (ash (aref str 1) 8) (aref str 0))
(error "%s is not 2 bytes long" str)))
(defun md4-unpack-int32 (str)
(if (eq 4 (length str))
- (cons (+ (lsh (aref str 3) 8) (aref str 2))
- (+ (lsh (aref str 1) 8) (aref str 0)))
+ (cons (+ (ash (aref str 3) 8) (aref str 2))
+ (+ (ash (aref str 1) 8) (aref str 0)))
(error "%s is not 4 bytes long" str)))
(provide 'md4)
diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el
index 82023cbaa08..4ff60ed9910 100644
--- a/lisp/menu-bar.el
+++ b/lisp/menu-bar.el
@@ -277,6 +277,15 @@
;; The Edit->Search->Incremental Search menu
(defvar menu-bar-i-search-menu
(let ((menu (make-sparse-keymap "Incremental Search")))
+ (bindings--define-key menu [isearch-forward-symbol-at-point]
+ '(menu-item "Forward Symbol at Point..." isearch-forward-symbol-at-point
+ :help "Search forward for a symbol found at point"))
+ (bindings--define-key menu [isearch-forward-symbol]
+ '(menu-item "Forward Symbol..." isearch-forward-symbol
+ :help "Search forward for a symbol as you type it"))
+ (bindings--define-key menu [isearch-forward-word]
+ '(menu-item "Forward Word..." isearch-forward-word
+ :help "Search forward for a word as you type it"))
(bindings--define-key menu [isearch-backward-regexp]
'(menu-item "Backward Regexp..." isearch-backward-regexp
:help "Search backwards for a regular expression as you type it"))
@@ -300,7 +309,7 @@
menu-bar-separator)
(bindings--define-key menu [tags-continue]
- '(menu-item "Continue Tags Search" tags-loop-continue
+ '(menu-item "Continue Tags Search" fileloop-continue
:help "Continue last tags search operation"))
(bindings--define-key menu [tags-srch]
'(menu-item "Search Tagged Files..." tags-search
@@ -349,7 +358,7 @@
(defvar menu-bar-replace-menu
(let ((menu (make-sparse-keymap "Replace")))
(bindings--define-key menu [tags-repl-continue]
- '(menu-item "Continue Replace" tags-loop-continue
+ '(menu-item "Continue Replace" fileloop-continue
:help "Continue last tags replace operation"))
(bindings--define-key menu [tags-repl]
'(menu-item "Replace in Tagged Files..." tags-query-replace
@@ -423,15 +432,15 @@
(let ((menu (make-sparse-keymap "Edit")))
(bindings--define-key menu [props]
- `(menu-item "Text Properties" facemenu-menu))
+ '(menu-item "Text Properties" facemenu-menu))
;; ns-win.el said: Add spell for platform consistency.
(if (featurep 'ns)
(bindings--define-key menu [spell]
- `(menu-item "Spell" ispell-menu-map)))
+ '(menu-item "Spell" ispell-menu-map)))
(bindings--define-key menu [fill]
- `(menu-item "Fill" fill-region
+ '(menu-item "Fill" fill-region
:enable (and mark-active (not buffer-read-only))
:help
"Fill text in region to fit between left and right margin"))
@@ -440,7 +449,7 @@
menu-bar-separator)
(bindings--define-key menu [bookmark]
- `(menu-item "Bookmarks" menu-bar-bookmark-map))
+ '(menu-item "Bookmarks" menu-bar-bookmark-map))
(bindings--define-key menu [goto]
`(menu-item "Go To" ,menu-bar-goto-menu))
@@ -1379,11 +1388,7 @@ mail status in mode line"))
;; It is better not to use backquote here,
;; because that makes a bootstrapping problem
;; if you need to recompile all the Lisp files using interpreted code.
- `(menu-item "Multilingual Environment" ,mule-menu-keymap
- ;; Most of the MULE menu actually does make sense in
- ;; unibyte mode, e.g. language selection.
- ;; :visible '(default-value 'enable-multibyte-characters)
- ))
+ `(menu-item "Multilingual Environment" ,mule-menu-keymap))
;;(setq menu-bar-final-items (cons 'mule menu-bar-final-items))
;;(bindings--define-key menu [preferences]
;; `(menu-item "Preferences" ,menu-bar-preferences-menu
@@ -1697,18 +1702,14 @@ mail status in mode line"))
(bindings--define-key menu [mule-diag]
'(menu-item "Show All of Mule Status" mule-diag
- :visible (default-value 'enable-multibyte-characters)
:help "Display multilingual environment settings"))
(bindings--define-key menu [describe-coding-system-briefly]
'(menu-item "Describe Coding System (Briefly)"
- describe-current-coding-system-briefly
- :visible (default-value 'enable-multibyte-characters)))
+ describe-current-coding-system-briefly))
(bindings--define-key menu [describe-coding-system]
- '(menu-item "Describe Coding System..." describe-coding-system
- :visible (default-value 'enable-multibyte-characters)))
+ '(menu-item "Describe Coding System..." describe-coding-system))
(bindings--define-key menu [describe-input-method]
'(menu-item "Describe Input Method..." describe-input-method
- :visible (default-value 'enable-multibyte-characters)
:help "Keyboard layout for specific input method"))
(bindings--define-key menu [describe-language-environment]
`(menu-item "Describe Language Environment"
@@ -2143,9 +2144,9 @@ It must accept a buffer as its only required argument.")
;; Make the menu of buffers proper.
(setq buffers-menu
(let ((i 0)
- (limit (if (and (integerp buffers-menu-max-size)
- (> buffers-menu-max-size 1))
- buffers-menu-max-size most-positive-fixnum))
+ (limit (and (integerp buffers-menu-max-size)
+ (> buffers-menu-max-size 1)
+ buffers-menu-max-size))
alist)
;; Put into each element of buffer-list
;; the name for actual display,
@@ -2169,7 +2170,7 @@ It must accept a buffer as its only required argument.")
alist)
;; If requested, list only the N most recently
;; selected buffers.
- (when (= limit (setq i (1+ i)))
+ (when (eql limit (setq i (1+ i)))
(setq buffers nil)))))
(list (menu-bar-buffer-vector alist))))
@@ -2293,9 +2294,6 @@ It must accept a buffer as its only required argument.")
(define-minor-mode menu-bar-mode
"Toggle display of a menu bar on each frame (Menu Bar mode).
-With a prefix argument ARG, enable Menu Bar mode if ARG is
-positive, and disable it otherwise. If called from Lisp, also
-enable Menu Bar mode if ARG is omitted or nil.
This command applies to all frames that exist and frames to be
created in the future."
@@ -2432,7 +2430,7 @@ form ((XOFFSET YOFFSET) WINDOW), or nil.
If nil, the current mouse position is used, or nil if there is no mouse."
(pcase position
;; nil -> mouse cursor position
- (`nil
+ ('nil
(let ((mp (mouse-pixel-position)))
(list (list (cadr mp) (cddr mp)) (car mp))))
;; Value returned from `event-end' or `posn-at-point'.
diff --git a/lisp/mh-e/mh-acros.el b/lisp/mh-e/mh-acros.el
index ce5c7a65929..3bbf509989d 100644
--- a/lisp/mh-e/mh-acros.el
+++ b/lisp/mh-e/mh-acros.el
@@ -61,8 +61,8 @@ particular, the expansion of (setf (gethash ...) ...) used
functions in \"cl\" at run time. This macro recognizes that and
loads \"cl\" appropriately."
(if (eq (car (macroexpand '(setf (gethash foo bar) baz))) 'cl-puthash)
- `(require 'cl)
- `(eval-when-compile (require 'cl))))
+ '(require 'cl)
+ '(eval-when-compile (require 'cl))))
;;;###mh-autoload
(defmacro mh-do-in-gnu-emacs (&rest body)
@@ -90,9 +90,10 @@ loads \"cl\" appropriately."
"Create function NAME.
If FUNCTION exists, then NAME becomes an alias for FUNCTION.
Otherwise, create function NAME with ARG-LIST and BODY."
- `(if (fboundp ',function)
- (defalias ',name ',function)
- (defun ,name ,arg-list ,@body)))
+ `(defalias ',name
+ (if (fboundp ',function)
+ ',function
+ (lambda ,arg-list ,@body))))
(put 'defun-mh 'lisp-indent-function 'defun)
(put 'defun-mh 'doc-string-elt 4)
@@ -127,11 +128,11 @@ XEmacs and versions of GNU Emacs before 21.1 require
In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then
check if variable `transient-mark-mode' is active."
(cond ((featurep 'xemacs) ;XEmacs
- `(and (boundp 'zmacs-regions) zmacs-regions (region-active-p)))
+ '(and (boundp 'zmacs-regions) zmacs-regions (region-active-p)))
((not check-transient-mark-mode-flag) ;GNU Emacs
- `(and (boundp 'mark-active) mark-active))
+ '(and (boundp 'mark-active) mark-active))
(t ;GNU Emacs
- `(and (boundp 'transient-mark-mode) transient-mark-mode
+ '(and (boundp 'transient-mark-mode) transient-mark-mode
(boundp 'mark-active) mark-active))))
;; Shush compiler.
@@ -142,6 +143,8 @@ check if variable `transient-mark-mode' is active."
;;;###mh-autoload
(defmacro mh-defstruct (name-spec &rest fields)
+ ;; FIXME: Use `cl-defstruct' instead: shouldn't emit warnings any
+ ;; more nor depend on run-time CL functions.
"Replacement for `defstruct' from the \"cl\" package.
The `defstruct' in the \"cl\" library produces compiler warnings,
and generates code that uses functions present in \"cl\" at
@@ -159,15 +162,17 @@ more details."
(constructor (or (and (consp name-spec)
(cadr (assoc :constructor (cdr name-spec))))
(intern (format "make-%s" struct-name))))
- (field-names (mapcar #'(lambda (x) (if (atom x) x (car x))) fields))
- (field-init-forms (mapcar #'(lambda (x) (and (consp x) (cadr x)))
- fields))
+ (fields (mapcar (lambda (x)
+ (if (atom x)
+ (list x nil)
+ (list (car x) (cadr x))))
+ fields))
+ (field-names (mapcar #'car fields))
(struct (gensym "S"))
(x (gensym "X"))
(y (gensym "Y")))
`(progn
- (defun* ,constructor (&key ,@(mapcar* #'(lambda (x y) (list x y))
- field-names field-init-forms))
+ (defun* ,constructor (&key ,@fields)
(list (quote ,struct-name) ,@field-names))
(defun ,predicate (arg)
(and (consp arg) (eq (car arg) (quote ,struct-name))))
diff --git a/lisp/mh-e/mh-alias.el b/lisp/mh-e/mh-alias.el
index 7b44db60378..c6cdfc40c94 100644
--- a/lisp/mh-e/mh-alias.el
+++ b/lisp/mh-e/mh-alias.el
@@ -78,10 +78,9 @@ If ARG is non-nil, set timestamp with the current time."
(function
(lambda (file)
(when (and file (file-exists-p file))
- (setq stamp (nth 5 (file-attributes file)))
- (or (> (car stamp) (car mh-alias-tstamp))
- (and (= (car stamp) (car mh-alias-tstamp))
- (> (cadr stamp) (cadr mh-alias-tstamp)))))))
+ (setq stamp (file-attribute-modification-time
+ (file-attributes file)))
+ (time-less-p mh-alias-tstamp stamp))))
(mh-alias-filenames t)))))))
(defun mh-alias-filenames (arg)
@@ -339,7 +338,7 @@ NO-COMMA-SWAP is non-nil."
;; Two words -> first.last
(downcase
(format "%s.%s" (match-string 1 string) (match-string 2 string))))
- ((string-match "^\\([-a-zA-Z0-9._]+\\)@[-a-zA-z0-9_]+\\.+[a-zA-Z0-9]+$"
+ ((string-match "^\\([-a-zA-Z0-9._]+\\)@[-a-zA-Z0-9_]+\\.+[a-zA-Z0-9]+$"
string)
;; email only -> downcase username
(downcase (match-string 1 string)))
diff --git a/lisp/mh-e/mh-comp.el b/lisp/mh-e/mh-comp.el
index c51052dc3f4..b96ef745383 100644
--- a/lisp/mh-e/mh-comp.el
+++ b/lisp/mh-e/mh-comp.el
@@ -77,6 +77,14 @@ Default is \"components\".
If not an absolute file name, the file is searched for first in the
user's MH directory, then in the system MH lib directory.")
+(defvar mh-dist-formfile "distcomps"
+ "Name of file to be used as a skeleton for redistributing messages.
+
+Default is \"distcomps\".
+
+If not an absolute file name, the file is searched for first in the
+user's MH directory, then in the system MH lib directory.")
+
(defvar mh-repl-formfile "replcomps"
"Name of file to be used as a skeleton for replying to messages.
@@ -305,24 +313,26 @@ message and scan line."
(file-name buffer-file-name)
(config mh-previous-window-config)
(coding-system-for-write
- (if (and (local-variable-p 'buffer-file-coding-system
- (current-buffer)) ;XEmacs needs two args
- ;; We're not sure why, but buffer-file-coding-system
- ;; tends to get set to undecided-unix.
- (not (memq buffer-file-coding-system
- '(undecided undecided-unix undecided-dos))))
- buffer-file-coding-system
- (or (and (boundp 'sendmail-coding-system) sendmail-coding-system)
- (and (default-boundp 'buffer-file-coding-system)
- (default-value 'buffer-file-coding-system))
- 'iso-latin-1))))
+ (if (fboundp 'select-message-coding-system)
+ (select-message-coding-system) ; Emacs has this since at least 21.1
+ (if (and (local-variable-p 'buffer-file-coding-system
+ (current-buffer)) ;XEmacs needs two args
+ ;; We're not sure why, but buffer-file-coding-system
+ ;; tends to get set to undecided-unix.
+ (not (memq buffer-file-coding-system
+ '(undecided undecided-unix undecided-dos))))
+ buffer-file-coding-system
+ (or (and (boundp 'sendmail-coding-system) sendmail-coding-system)
+ (and (default-boundp 'buffer-file-coding-system)
+ (default-value 'buffer-file-coding-system))
+ 'iso-latin-1)))))
;; Older versions of spost do not support -msgid and -mime.
(unless mh-send-uses-spost-flag
;; Adding a Message-ID field looks good, makes it easier to search for
;; message in your +outbox, and best of all doesn't break threading for
;; the recipient if you reply to a message in your +outbox.
(setq mh-send-args (concat "-msgid " mh-send-args))
- ;; The default BCC encapsulation will make a MIME message unreadable.
+ ;; The default Bcc encapsulation will make a MIME message unreadable.
;; With nmh use the -mime arg to prevent this.
(if (and (mh-variant-p 'nmh)
(mh-goto-header-field "Bcc:")
@@ -411,7 +421,7 @@ See also `mh-send'."
(interactive (list (mh-get-msg-num t)))
(let* ((from-folder mh-current-folder)
(config (current-window-configuration))
- (components-file (mh-bare-components))
+ (components-file (mh-bare-components mh-comp-formfile))
(draft
(cond ((and mh-draft-folder (equal from-folder mh-draft-folder))
(pop-to-buffer (find-file-noselect (mh-msg-filename message))
@@ -602,7 +612,7 @@ See also `mh-compose-forward-as-mime-flag',
(goto-char (mh-mail-header-end))
(while
(re-search-forward
- "^#forw \\[\\([^]]+\\)\\] \\(+\\S-+\\) \\(.*\\)$"
+ "^#forw \\[\\([^]]+\\)\\] \\(\\+\\S-+\\) \\(.*\\)$"
(point-max) t)
(let ((description (if (equal (match-string 1)
"forwarded messages")
@@ -647,15 +657,16 @@ Original message has headers FROM and SUBJECT."
(format mh-forward-subject-format from subject))
;;;###mh-autoload
-(defun mh-redistribute (to cc &optional message)
+(defun mh-redistribute (to cc identity &optional message)
"Redistribute a message.
This command is similar in function to forwarding mail, but it
does not allow you to edit the message, nor does it add your name
to the \"From\" header field. It appears to the recipient as if
the message had come from the original sender. When you run this
-command, you are prompted for the TO and CC recipients. The
-default MESSAGE is the current message.
+command, you are prompted for the TO and CC recipients. You are
+also prompted for the sending IDENTITY to use. The default
+MESSAGE is the current message.
Also investigate the command \\[mh-edit-again] for another way to
redistribute messages.
@@ -666,6 +677,9 @@ The hook `mh-annotate-msg-hook' is run after annotating the
message and scan line."
(interactive (list (mh-read-address "Redist-To: ")
(mh-read-address "Redist-Cc: ")
+ (if mh-identity-list
+ (mh-select-identity mh-identity-default)
+ nil)
(mh-get-msg-num t)))
(or message
(setq message (mh-get-msg-num t)))
@@ -675,14 +689,51 @@ message and scan line."
(if mh-redist-full-contents-flag
(mh-msg-filename message)
nil)
- nil)))
- (mh-goto-header-end 0)
- (insert "Resent-To: " to "\n")
- (if (not (equal cc "")) (insert "Resent-cc: " cc "\n"))
- (mh-clean-msg-header
- (point-min)
- "^Message-Id:\\|^Received:\\|^Return-Path:\\|^Sender:\\|^Date:\\|^From:"
- nil)
+ nil))
+ (from (mh-identity-field identity "From"))
+ (fcc (mh-identity-field identity "Fcc"))
+ (bcc (mh-identity-field identity "Bcc"))
+ comp-fcc comp-to comp-cc comp-bcc)
+ (if mh-redist-full-contents-flag
+ (mh-clean-msg-header
+ (point-min)
+ "^Message-Id:\\|^Received:\\|^Return-Path:\\|^Date:\\|^Resent-.*:"
+ nil))
+ ;; Read fields from the distcomps file and put them in our
+ ;; draft. For "To", "Cc", "Bcc", and "Fcc", multiple headers are
+ ;; combined into a single header with comma-separated entries.
+ ;; For "From", the first value wins, with the identity's "From"
+ ;; trumping anything in the distcomps file.
+ (let ((components-file (mh-bare-components mh-dist-formfile)))
+ (mh-mapc
+ (function
+ (lambda (header-field)
+ (let ((field (car header-field))
+ (value (cdr header-field))
+ (case-fold-search t))
+ (cond
+ ((string-match field "^Resent-Fcc$")
+ (setq comp-fcc value))
+ ((string-match field "^Resent-From$")
+ (or from
+ (setq from value)))
+ ((string-match field "^Resent-To$")
+ (setq comp-to value))
+ ((string-match field "^Resent-Cc$")
+ (setq comp-cc value))
+ ((string-match field "^Resent-Bcc$")
+ (setq comp-bcc value))
+ ((string-match field "^Resent-.*$")
+ (mh-insert-fields field value))))))
+ (mh-components-to-list components-file))
+ (delete-file components-file))
+ (mh-insert-fields "Resent-To:" (mapconcat 'identity (list to comp-to) ", ")
+ "Resent-Cc:" (mapconcat 'identity (list cc comp-cc) ", ")
+ "Resent-Fcc:" (mapconcat 'identity (list fcc
+ comp-fcc) ", ")
+ "Resent-Bcc:" (mapconcat 'identity (list bcc
+ comp-bcc) ", ")
+ "Resent-From:" from)
(save-buffer)
(message "Redistributing...")
(let ((env "mhdist=1"))
@@ -700,7 +751,8 @@ message and scan line."
;; Annotate...
(mh-annotate-msg message folder mh-note-dist
"-component" "Resent:"
- "-text" (format "\"%s %s\"" to cc)))
+ "-text" (format "\"To: %s Cc: %s From: %s\""
+ to cc from)))
(kill-buffer draft)
(message "Redistributing...done"))))
@@ -896,7 +948,7 @@ CONFIG is the window configuration before sending mail."
(message "Composing a message...")
(let ((draft (mh-read-draft
"message"
- (mh-bare-components)
+ (mh-bare-components mh-comp-formfile)
t)))
(mh-insert-fields "To:" to "Subject:" subject "Cc:" cc)
(goto-char (point-max))
@@ -906,23 +958,25 @@ CONFIG is the window configuration before sending mail."
(mh-letter-mode-message)
(mh-letter-adjust-point))))
-(defun mh-bare-components ()
- "Generate a temporary, clean components file and return its path."
- ;; Let comp(1) create the skeleton for us. This is particularly
+(defun mh-bare-components (formfile)
+ "Generate a temporary, clean components file from FORMFILE.
+Return the path to the temporary file."
+ ;; Let comp(1) create the skeleton for us. This is particularly
;; important with nmh-1.5, because its default "components" needs
- ;; some processing before it can be used. Unfortunately, comp(1)
- ;; doesn't have a -build option. So, to avoid the possibility of
- ;; clobbering an existing draft, create a temporary directory and
- ;; use it as the drafts folder. Then copy the skeleton to a regular
- ;; temp file, and return the regular temp file.
+ ;; some processing before it can be used. Unfortunately, comp(1)
+ ;; didn't have a -build option until later versions of nmh. So, to
+ ;; avoid the possibility of clobbering an existing draft, create
+ ;; a temporary directory and use it as the drafts folder. Then
+ ;; copy the skeleton to a regular temp file, and return the
+ ;; regular temp file.
(let (new
(temp-folder (make-temp-file
(concat mh-user-path "draftfolder.") t)))
(mh-exec-cmd "comp" "-nowhatnowproc"
"-draftfolder" (format "+%s"
(file-name-nondirectory temp-folder))
- (if (stringp mh-comp-formfile)
- (list "-form" mh-comp-formfile)))
+ (if (stringp formfile)
+ (list "-form" formfile)))
(setq new (make-temp-file "comp."))
(rename-file (concat temp-folder "/" "1") new t)
;; The temp folder could contain various metadata files. Rather
@@ -1056,6 +1110,7 @@ letter."
(defun mh-insert-x-mailer ()
"Append an X-Mailer field to the header.
The versions of MH-E, Emacs, and MH are shown."
+ (or mh-variant-in-use (mh-variant-set mh-variant))
;; Lazily initialize mh-x-mailer-string.
(when (and mh-insert-x-mailer-flag (null mh-x-mailer-string))
(setq mh-x-mailer-string
diff --git a/lisp/mh-e/mh-compat.el b/lisp/mh-e/mh-compat.el
index d84d3320426..eb173df47c9 100644
--- a/lisp/mh-e/mh-compat.el
+++ b/lisp/mh-e/mh-compat.el
@@ -65,7 +65,8 @@ Simulate NOERROR argument in XEmacs which lacks it."
Case is ignored if CASE-FOLD is non-nil.
This function is used by Emacs versions that lack `assoc-string',
introduced in Emacs 22."
- (if case-fold
+ ;; Test for fboundp is solely to silence compiler for Emacs >= 22.1.
+ (if (and case-fold (fboundp 'assoc-ignore-case))
(assoc-ignore-case key list)
(assoc key list)))
@@ -307,7 +308,8 @@ This function is used by XEmacs that lacks `replace-regexp-in-string'.
The function `replace-in-string' is used instead.
The arguments FIXEDCASE, SUBEXP, and START, used by
`replace-in-string' are ignored."
- (replace-in-string string regexp rep literal))
+ (if (featurep 'xemacs) ; silence Emacs compiler
+ (replace-in-string string regexp rep literal)))
(defun-mh mh-test-completion
test-completion (string collection &optional predicate)
diff --git a/lisp/mh-e/mh-e.el b/lisp/mh-e/mh-e.el
index ee938166931..bc09764656b 100644
--- a/lisp/mh-e/mh-e.el
+++ b/lisp/mh-e/mh-e.el
@@ -410,6 +410,8 @@ gnus-version)
(require 'gnus)
gnus-version)
+(defvar mh-variant)
+
;;;###autoload
(defun mh-version ()
"Display version information about MH-E and the MH mail handling system."
@@ -430,6 +432,7 @@ gnus-version)
;; Emacs version.
(insert (emacs-version) "\n\n")
;; MH version.
+ (or mh-variant-in-use (mh-variant-set mh-variant))
(if mh-variant-in-use
(insert mh-variant-in-use "\n"
" mh-progs:\t" mh-progs "\n"
@@ -876,6 +879,7 @@ variant."
(defun mh-variant-p (&rest variants)
"Return t if variant is any of VARIANTS.
Currently known variants are `MH', `nmh', and `gnu-mh'."
+ (or mh-variant-in-use (mh-variant-set mh-variant))
(let ((variant-in-use
(cadr (assoc 'variant (assoc mh-variant-in-use (mh-variants))))))
(not (null (member variant-in-use variants)))))
@@ -941,6 +945,8 @@ finally GNU mailutils MH."
(when (not (mh-variant-set-variant variant))
(message "Warning: %s variant not found. Autodetecting..." variant)
(mh-variant-set 'autodetect)))
+ ((null valid-list)
+ (message "Unknown variant %s; can't find MH anywhere" variant))
(t
(message "Unknown variant %s; use %s"
variant
@@ -972,6 +978,7 @@ necessary and can actually cause problems."
:set (lambda (symbol value)
(set-default symbol value) ;Done in mh-variant-set-variant!
(mh-variant-set value))
+ :initialize 'custom-initialize-default
:group 'mh-e
:package-version '(MH-E . "8.0"))
diff --git a/lisp/mh-e/mh-folder.el b/lisp/mh-e/mh-folder.el
index e4429df501a..caf40715831 100644
--- a/lisp/mh-e/mh-folder.el
+++ b/lisp/mh-e/mh-folder.el
@@ -519,7 +519,7 @@ font-lock is done highlighting.")
(defmacro mh-remove-xemacs-horizontal-scrollbar ()
"Get rid of the horizontal scrollbar that XEmacs insists on putting in."
(when (featurep 'xemacs)
- `(if (and (featurep 'scrollbar)
+ '(if (and (featurep 'scrollbar)
(fboundp 'set-specifier))
(set-specifier horizontal-scrollbar-visible-p nil
(cons (current-buffer) nil)))))
diff --git a/lisp/mh-e/mh-funcs.el b/lisp/mh-e/mh-funcs.el
index d9b3dc8233f..da7c87ea81b 100644
--- a/lisp/mh-e/mh-funcs.el
+++ b/lisp/mh-e/mh-funcs.el
@@ -357,6 +357,8 @@ Arguments are IGNORED (for `revert-buffer')."
(yes-or-no-p "Undo all commands in folder? "))
(setq mh-delete-list nil
mh-refile-list nil
+ mh-blacklist nil
+ mh-whitelist nil
mh-seq-list nil
mh-next-direction 'forward)
(with-mh-folder-updating (nil)
diff --git a/lisp/mh-e/mh-identity.el b/lisp/mh-e/mh-identity.el
index 8469843e3fc..1d929e8f990 100644
--- a/lisp/mh-e/mh-identity.el
+++ b/lisp/mh-e/mh-identity.el
@@ -132,6 +132,33 @@ valid header field."
'mh-identity-handler-default))
;;;###mh-autoload
+(defun mh-select-identity (default)
+ "Prompt for and return an identity.
+If DEFAULT is non-nil, it will be used if the user doesn't enter a
+different identity.
+
+See `mh-identity-list'."
+ (let (identity)
+ (setq identity
+ (completing-read
+ "Identity: "
+ (cons '("None")
+ (mapcar 'list (mapcar 'car mh-identity-list)))
+ nil t default nil default))
+ (if (eq identity "None")
+ nil
+ identity)))
+
+;;;###mh-autoload
+(defun mh-identity-field (identity field)
+ "Return the specified FIELD of the given IDENTITY.
+
+See `mh-identity-list'."
+ (let* ((pers-list (cadr (assoc identity mh-identity-list)))
+ (value (cdr (assoc field pers-list))))
+ value))
+
+;;;###mh-autoload
(defun mh-insert-identity (identity &optional maybe-insert)
"Insert fields specified by given IDENTITY.
diff --git a/lisp/mh-e/mh-junk.el b/lisp/mh-e/mh-junk.el
index 8266d96ca69..db80f90494e 100644
--- a/lisp/mh-e/mh-junk.el
+++ b/lisp/mh-e/mh-junk.el
@@ -108,8 +108,7 @@ message(s) as specified by the option `mh-junk-disposition'."
(mh-iterate-on-range msg range
(message "Blacklisting message %d..." msg)
(funcall (symbol-function blacklist-func) msg)
- (message "Blacklisting message %d...done" msg))
- (mh-next-msg)))
+ (message "Blacklisting message %d...done" msg))))
;;;###mh-autoload
(defun mh-junk-whitelist (range)
@@ -164,8 +163,7 @@ classified as spam (see the option `mh-junk-program')."
(mh-iterate-on-range msg range
(message "Whitelisting message %d..." msg)
(funcall (symbol-function whitelist-func) msg)
- (message "Whitelisting message %d...done" msg))
- (mh-next-msg)))
+ (message "Whitelisting message %d...done" msg))))
diff --git a/lisp/mh-e/mh-letter.el b/lisp/mh-e/mh-letter.el
index 4906c98bb89..4fc31ed1218 100644
--- a/lisp/mh-e/mh-letter.el
+++ b/lisp/mh-e/mh-letter.el
@@ -60,17 +60,6 @@
(to . mh-alias-letter-expand-alias))
"Alist of header fields and completion functions to use.")
-(defvar mh-yank-hooks nil
- "Obsolete hook for modifying a citation just inserted in the mail buffer.
-
-Each hook function can find the citation between point and mark.
-And each hook function should leave point and mark around the
-citation text as modified.
-
-This is a normal hook, misnamed for historical reasons.
-It is obsolete and is only used if `mail-citation-hook' is nil.")
-(mh-make-obsolete-variable 'mh-yank-hooks 'mail-citation-hook "19.34")
-
;;; Letter Menu
@@ -972,8 +961,6 @@ Otherwise, simply insert MH-INS-STRING before each line."
(sc-cite-original))
(mail-citation-hook
(run-hooks 'mail-citation-hook))
- (mh-yank-hooks ;old hook name
- (run-hooks 'mh-yank-hooks))
(t
(or (bolp) (forward-line 1))
(while (< (point) (point-max))
diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el
index bb7bf826497..9901548b904 100644
--- a/lisp/mh-e/mh-mime.el
+++ b/lisp/mh-e/mh-mime.el
@@ -75,7 +75,7 @@
;;;###mh-autoload
(defmacro mh-buffer-data ()
"Convenience macro to get the MIME data structures of the current buffer."
- `(gethash (current-buffer) mh-globals-hash))
+ '(gethash (current-buffer) mh-globals-hash))
;; Structure to keep track of MIME handles on a per buffer basis.
(mh-defstruct (mh-buffer-data (:conc-name mh-mime-)
diff --git a/lisp/mh-e/mh-search.el b/lisp/mh-e/mh-search.el
index 1a14f4f3dc3..c017baec66b 100644
--- a/lisp/mh-e/mh-search.el
+++ b/lisp/mh-e/mh-search.el
@@ -495,16 +495,16 @@ group of results."
(let ((point (point)))
(forward-line (if backward-flag 0 1))
(cond ((if backward-flag
- (re-search-backward "^+" (point-min) t)
- (re-search-forward "^+" (point-max) t))
+ (re-search-backward "^\\+" (point-min) t)
+ (re-search-forward "^\\+" (point-max) t))
(beginning-of-line))
((and (if backward-flag
(goto-char (point-max))
(goto-char (point-min)))
nil))
((if backward-flag
- (re-search-backward "^+" (point-min) t)
- (re-search-forward "^+" (point-max) t))
+ (re-search-backward "^\\+" (point-min) t)
+ (re-search-forward "^\\+" (point-max) t))
(beginning-of-line))
(t (goto-char point))))))
@@ -1429,7 +1429,7 @@ being the list of messages originally from that folder."
(setq which-func-mode t))
(let ((alist ()))
(goto-char (point-min))
- (while (re-search-forward "^+" nil t)
+ (while (re-search-forward "^\\+" nil t)
(save-excursion
(beginning-of-line)
(push (cons (buffer-substring-no-properties
diff --git a/lisp/mh-e/mh-show.el b/lisp/mh-e/mh-show.el
index 84a7a817065..7dad81dbce5 100644
--- a/lisp/mh-e/mh-show.el
+++ b/lisp/mh-e/mh-show.el
@@ -375,8 +375,8 @@ still visible.\n")
(cond ((not normal-exit)
(set-window-configuration config))
,(if dont-return
- `(t (setq mh-previous-window-config config))
- `((and (get-buffer cur-buffer-name)
+ '(t (setq mh-previous-window-config config))
+ '((and (get-buffer cur-buffer-name)
(window-live-p (get-buffer-window
(get-buffer cur-buffer-name))))
(pop-to-buffer (get-buffer cur-buffer-name) nil)))))))))
@@ -774,7 +774,7 @@ operation."
("^\\(Apparently-To:\\|Newsgroups:\\)\\(.*\\)"
(1 'default)
(2 'mh-show-cc))
- ("^\\(In-reply-to\\|Date\\):\\(.*\\)$"
+ ("^\\(In-Reply-To\\|Date\\):\\(.*\\)$"
(1 'default)
(2 'mh-show-date))
(mh-letter-header-font-lock
diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el
index dd4f6037050..3e89d1b65e9 100644
--- a/lisp/mh-e/mh-speed.el
+++ b/lisp/mh-e/mh-speed.el
@@ -163,7 +163,7 @@ The optional arguments from speedbar are IGNORED."
(speedbar-change-expand-button-char ?-)
(add-text-properties
(mh-line-beginning-position) (1+ (line-beginning-position))
- `(mh-expanded t)))))))
+ '(mh-expanded t)))))))
(defun mh-speed-view (&rest ignored)
"Visits the selected folder just as if you had used \\<mh-folder-mode-map>\\[mh-visit-folder].
@@ -199,7 +199,7 @@ created."
(1+ (mh-line-beginning-position))))
(add-text-properties
(mh-line-beginning-position) (1+ (line-beginning-position))
- `(mh-folder nil mh-expanded nil mh-children-p t mh-level 0))
+ '(mh-folder nil mh-expanded nil mh-children-p t mh-level 0))
(mh-speed-stealth-update t)
(when (> mh-speed-update-interval 0)
(mh-speed-flists nil))))
@@ -568,7 +568,7 @@ The function invalidates the latest ancestor that is present."
(mh-speedbar-change-expand-button-char ?+)
(add-text-properties
(mh-line-beginning-position) (1+ (mh-line-beginning-position))
- `(mh-children-p t)))
+ '(mh-children-p t)))
(when (get-text-property (mh-line-beginning-position) 'mh-expanded)
(mh-speed-toggle))
(setq mh-speed-refresh-flag t))))
diff --git a/lisp/mh-e/mh-thread.el b/lisp/mh-e/mh-thread.el
index 7d35bc61de8..0fc560b90d0 100644
--- a/lisp/mh-e/mh-thread.el
+++ b/lisp/mh-e/mh-thread.el
@@ -647,20 +647,17 @@ Only information about messages in MSG-LIST are added to the tree."
(defun mh-thread-set-tables (folder)
"Use the tables of FOLDER in current buffer."
- (mh-flet
- ((mh-get-table (symbol)
- (with-current-buffer folder
- (symbol-value symbol))))
- (setq mh-thread-id-hash (mh-get-table 'mh-thread-id-hash))
- (setq mh-thread-subject-hash (mh-get-table 'mh-thread-subject-hash))
- (setq mh-thread-id-table (mh-get-table 'mh-thread-id-table))
- (setq mh-thread-id-index-map (mh-get-table 'mh-thread-id-index-map))
- (setq mh-thread-index-id-map (mh-get-table 'mh-thread-index-id-map))
- (setq mh-thread-scan-line-map (mh-get-table 'mh-thread-scan-line-map))
- (setq mh-thread-subject-container-hash
- (mh-get-table 'mh-thread-subject-container-hash))
- (setq mh-thread-duplicates (mh-get-table 'mh-thread-duplicates))
- (setq mh-thread-history (mh-get-table 'mh-thread-history))))
+ (dolist (v '(mh-thread-id-hash
+ mh-thread-subject-hash
+ mh-thread-id-table
+ mh-thread-id-index-map
+ mh-thread-index-id-map
+ mh-thread-scan-line-map
+ mh-thread-subject-container-hash
+ mh-thread-duplicates
+ mh-thread-history))
+ ;; Emacs >= 22.1: (buffer-local-value v folder).
+ (set v (with-current-buffer folder (symbol-value v)))))
(defun mh-thread-process-in-reply-to (reply-to-header)
"Extract message id's from REPLY-TO-HEADER.
diff --git a/lisp/mh-e/mh-utils.el b/lisp/mh-e/mh-utils.el
index 7cba9a5f417..cad62787190 100644
--- a/lisp/mh-e/mh-utils.el
+++ b/lisp/mh-e/mh-utils.el
@@ -177,6 +177,7 @@ been set. This hook can be used the change the value of these
variables if you need to run with different values between MH and
MH-E."
(unless mh-find-path-run
+ (or mh-variant-in-use (mh-variant-set mh-variant))
;; Sanity checks.
(if (and (getenv "MH")
(not (file-readable-p (getenv "MH"))))
diff --git a/lisp/mh-e/mh-xface.el b/lisp/mh-e/mh-xface.el
index 9a03fef1108..ddb001ac8fe 100644
--- a/lisp/mh-e/mh-xface.el
+++ b/lisp/mh-e/mh-xface.el
@@ -197,7 +197,7 @@ The directories are searched for in the order they appear in the list.")
(mh-funcall-if-exists ietf-drums-parse-address
from-field))))
(host (and from
- (string-match "\\([^+]*\\)\\(+.*\\)?@\\(.*\\)" from)
+ (string-match "\\([^+]*\\)\\(\\+.*\\)?@\\(.*\\)" from)
(downcase (match-string 3 from))))
(user (and host (downcase (match-string 1 from))))
(canonical-address (format "%s@%s" user host))
diff --git a/lisp/minibuf-eldef.el b/lisp/minibuf-eldef.el
index 244cfd57b4e..7fd08ab2e99 100644
--- a/lisp/minibuf-eldef.el
+++ b/lisp/minibuf-eldef.el
@@ -163,9 +163,6 @@ been set up by `minibuf-eldef-setup-minibuffer'."
;;;###autoload
(define-minor-mode minibuffer-electric-default-mode
"Toggle Minibuffer Electric Default mode.
-With a prefix argument ARG, enable Minibuffer Electric Default
-mode if ARG is positive, and disable it otherwise. If called
-from Lisp, enable the mode if ARG is omitted or nil.
Minibuffer Electric Default mode is a global minor mode. When
enabled, minibuffer prompts that show a default value only show
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 67c691ca212..dbd24dfa0a3 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -269,7 +269,7 @@ the form (concat S2 S)."
(+ beg (- (length s1) (length s2))))
. ,(and (eq (car-safe res) 'boundaries) (cddr res)))))
((stringp res)
- (if (string-prefix-p s2 string completion-ignore-case)
+ (if (string-prefix-p s2 res completion-ignore-case)
(concat s1 (substring res (length s2)))))
((eq action t)
(let ((bounds (completion-boundaries str table pred "")))
@@ -682,9 +682,9 @@ for use at QPOS."
;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b))
;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun))
(define-obsolete-function-alias
- 'complete-in-turn 'completion-table-in-turn "23.1")
+ 'complete-in-turn #'completion-table-in-turn "23.1")
(define-obsolete-function-alias
- 'dynamic-completion-table 'completion-table-dynamic "23.1")
+ 'dynamic-completion-table #'completion-table-dynamic "23.1")
;;; Minibuffer completion
@@ -702,7 +702,7 @@ If ARGS are provided, then pass MESSAGE through `format-message'."
(if (not (minibufferp (current-buffer)))
(progn
(if args
- (apply 'message message args)
+ (apply #'message message args)
(message "%s" message))
(prog1 (sit-for (or minibuffer-message-timeout 1000000))
(message nil)))
@@ -735,7 +735,8 @@ If ARGS are provided, then pass MESSAGE through `format-message'."
(defun minibuffer-completion-contents ()
"Return the user input in a minibuffer before point as a string.
-In Emacs-22, that was what completion commands operated on."
+In Emacs 22, that was what completion commands operated on.
+If the current buffer is not a minibuffer, return everything before point."
(declare (obsolete nil "24.4"))
(buffer-substring (minibuffer-prompt-end) (point)))
@@ -793,6 +794,11 @@ Additionally the user can use the char \"*\" as a glob pattern.")
I.e. when completing \"foo_bar\" (where _ is the position of point),
it will consider all completions candidates matching the glob
pattern \"*foo*bar*\".")
+ (flex
+ completion-flex-try-completion completion-flex-all-completions
+ "Completion of an in-order subset of characters.
+When completing \"foo\" the glob \"*f*o*o*\" is used, so that
+\"foo\" can complete to \"frodo\".")
(initials
completion-initials-try-completion completion-initials-all-completions
"Completion of acronyms and initialisms.
@@ -840,7 +846,7 @@ styles for specific categories, such as files, buffers, etc."
(defvar completion-category-defaults
'((buffer (styles . (basic substring)))
(unicode-name (styles . (basic substring)))
- (project-file (styles . (basic substring)))
+ (project-file (styles . (substring)))
(info-menu (styles . (basic substring))))
"Default settings for specific completion categories.
Each entry has the shape (CATEGORY . ALIST) where ALIST is
@@ -1008,7 +1014,7 @@ completion candidates than this number."
(defvar-local completion-all-sorted-completions nil)
(defvar-local completion--all-sorted-completions-location nil)
-(defvar completion-cycling nil)
+(defvar completion-cycling nil) ;Function that takes down the cycling map.
(defvar completion-fail-discreetly nil
"If non-nil, stay quiet when there is no match.")
@@ -1040,7 +1046,7 @@ when the buffer's text is already an exact match."
(let* ((string (buffer-substring beg end))
(md (completion--field-metadata beg))
(comp (funcall (or try-completion-function
- 'completion-try-completion)
+ #'completion-try-completion)
string
minibuffer-completion-table
minibuffer-completion-predicate
@@ -1133,7 +1139,7 @@ when the buffer's text is already an exact match."
;; Show the completion table, if requested.
((not exact)
(if (pcase completion-auto-help
- (`lazy (eq this-command last-command))
+ ('lazy (eq this-command last-command))
(_ completion-auto-help))
(minibuffer-completion-help beg end)
(completion--message "Next char not unique")))
@@ -1193,7 +1199,7 @@ scroll the window of possible completions."
(defun completion--cache-all-sorted-completions (beg end comps)
(add-hook 'after-change-functions
- 'completion--flush-all-sorted-completions nil t)
+ #'completion--flush-all-sorted-completions nil t)
(setq completion--all-sorted-completions-location
(cons (copy-marker beg) (copy-marker end)))
(setq completion-all-sorted-completions comps))
@@ -1203,8 +1209,10 @@ scroll the window of possible completions."
(or (> start (cdr completion--all-sorted-completions-location))
(< end (car completion--all-sorted-completions-location))))
(remove-hook 'after-change-functions
- 'completion--flush-all-sorted-completions t)
- (setq completion-cycling nil)
+ #'completion--flush-all-sorted-completions t)
+ ;; Remove the transient map if applicable.
+ (when completion-cycling
+ (funcall (prog1 completion-cycling (setq completion-cycling nil))))
(setq completion-all-sorted-completions nil)))
(defun completion--metadata (string base md-at-point table pred)
@@ -1244,15 +1252,23 @@ scroll the window of possible completions."
(setq all (delete-dups all))
(setq last (last all))
- (setq all (if sort-fun (funcall sort-fun all)
- ;; Prefer shorter completions, by default.
- (sort all (lambda (c1 c2) (< (length c1) (length c2))))))
- ;; Prefer recently used completions.
- (when (minibufferp)
- (let ((hist (symbol-value minibuffer-history-variable)))
- (setq all (sort all (lambda (c1 c2)
- (> (length (member c1 hist))
- (length (member c2 hist))))))))
+ (cond
+ (sort-fun
+ (setq all (funcall sort-fun all)))
+ (t
+ ;; Prefer shorter completions, by default.
+ (setq all (sort all (lambda (c1 c2) (< (length c1) (length c2)))))
+ (if (minibufferp)
+ ;; Prefer recently used completions and put the default, if
+ ;; it exists, on top.
+ (let ((hist (symbol-value minibuffer-history-variable)))
+ (setq all
+ (sort all
+ (lambda (c1 c2)
+ (cond ((equal c1 minibuffer-default) t)
+ ((equal c2 minibuffer-default) nil)
+ (t (> (length (member c1 hist))
+ (length (member c2 hist))))))))))))
;; Cache the result. This is not just for speed, but also so that
;; repeated calls to minibuffer-force-complete can cycle through
;; all possibilities.
@@ -1262,16 +1278,23 @@ scroll the window of possible completions."
(defun minibuffer-force-complete-and-exit ()
"Complete the minibuffer with first of the matches and exit."
(interactive)
- (minibuffer-force-complete)
+ ;; If `completion-cycling' is t, then surely a
+ ;; `minibuffer-force-complete' has already executed. This is not
+ ;; just for speed: the extra rotation caused by the second
+ ;; unnecessary call would mess up the final result value
+ ;; (bug#34116).
+ (unless completion-cycling
+ (minibuffer-force-complete nil nil 'dont-cycle))
(completion--complete-and-exit
(minibuffer-prompt-end) (point-max) #'exit-minibuffer
;; If the previous completion completed to an element which fails
;; test-completion, then we shouldn't exit, but that should be rare.
(lambda () (minibuffer-message "Incomplete"))))
-(defun minibuffer-force-complete (&optional start end)
+(defun minibuffer-force-complete (&optional start end dont-cycle)
"Complete the minibuffer to an exact match.
-Repeated uses step through the possible completions."
+Repeated uses step through the possible completions.
+DONT-CYCLE tells the function not to setup cycling."
(interactive)
(setq minibuffer-scroll-window nil)
;; FIXME: Need to deal with the extra-size issue here as well.
@@ -1284,7 +1307,7 @@ Repeated uses step through the possible completions."
(base (+ start (or (cdr (last all)) 0))))
(cond
((not (consp all))
- (completion--message
+ (completion--message
(if all "No more completions" "No completions")))
((not (consp (cdr all)))
(let ((done (equal (car all) (buffer-substring-no-properties base end))))
@@ -1295,38 +1318,39 @@ Repeated uses step through the possible completions."
(completion--replace base end (car all))
(setq end (+ base (length (car all))))
(completion--done (buffer-substring-no-properties start (point)) 'sole)
- ;; Set cycling after modifying the buffer since the flush hook resets it.
- (setq completion-cycling t)
(setq this-command 'completion-at-point) ;For completion-in-region.
- ;; If completing file names, (car all) may be a directory, so we'd now
- ;; have a new set of possible completions and might want to reset
- ;; completion-all-sorted-completions to nil, but we prefer not to,
- ;; so that repeated calls minibuffer-force-complete still cycle
- ;; through the previous possible completions.
- (let ((last (last all)))
- (setcdr last (cons (car all) (cdr last)))
- (completion--cache-all-sorted-completions start end (cdr all)))
- ;; Make sure repeated uses cycle, even though completion--done might
- ;; have added a space or something that moved us outside of the field.
- ;; (bug#12221).
- (let* ((table minibuffer-completion-table)
- (pred minibuffer-completion-predicate)
- (extra-prop completion-extra-properties)
- (cmd
- (lambda () "Cycle through the possible completions."
- (interactive)
- (let ((completion-extra-properties extra-prop))
- (completion-in-region start (point) table pred)))))
- (set-transient-map
- (let ((map (make-sparse-keymap)))
- (define-key map [remap completion-at-point] cmd)
- (define-key map (vector last-command-event) cmd)
- map)))))))
+ ;; Set cycling after modifying the buffer since the flush hook resets it.
+ (unless dont-cycle
+ ;; If completing file names, (car all) may be a directory, so we'd now
+ ;; have a new set of possible completions and might want to reset
+ ;; completion-all-sorted-completions to nil, but we prefer not to,
+ ;; so that repeated calls minibuffer-force-complete still cycle
+ ;; through the previous possible completions.
+ (let ((last (last all)))
+ (setcdr last (cons (car all) (cdr last)))
+ (completion--cache-all-sorted-completions start end (cdr all)))
+ ;; Make sure repeated uses cycle, even though completion--done might
+ ;; have added a space or something that moved us outside of the field.
+ ;; (bug#12221).
+ (let* ((table minibuffer-completion-table)
+ (pred minibuffer-completion-predicate)
+ (extra-prop completion-extra-properties)
+ (cmd
+ (lambda () "Cycle through the possible completions."
+ (interactive)
+ (let ((completion-extra-properties extra-prop))
+ (completion-in-region start (point) table pred)))))
+ (setq completion-cycling
+ (set-transient-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [remap completion-at-point] cmd)
+ (define-key map (vector last-command-event) cmd)
+ map)))))))))
(defvar minibuffer-confirm-exit-commands
'(completion-at-point minibuffer-complete
minibuffer-complete-word PC-complete PC-complete-word)
- "A list of commands which cause an immediately following
+ "List of commands which cause an immediately following
`minibuffer-complete-and-exit' to ask for extra confirmation.")
(defun minibuffer-complete-and-exit ()
@@ -1539,7 +1563,7 @@ horizontally in alphabetical order, rather than down the screen."
Uses columns to keep the listing readable but compact.
It also eliminates runs of equal strings."
(when (consp strings)
- (let* ((length (apply 'max
+ (let* ((length (apply #'max
(mapcar (lambda (s)
(if (consp s)
(+ (string-width (car s))
@@ -1830,12 +1854,7 @@ variables.")
;; window, mark it as softly-dedicated, so bury-buffer in
;; minibuffer-hide-completions will know whether to
;; delete the window or not.
- (display-buffer-mark-dedicated 'soft)
- ;; Disable `pop-up-windows' temporarily to allow
- ;; `display-buffer--maybe-pop-up-frame-or-window'
- ;; in the display actions below to pop up a frame
- ;; if `pop-up-frames' is non-nil, but not to pop up a window.
- (pop-up-windows nil))
+ (display-buffer-mark-dedicated 'soft))
(with-displayed-buffer-window
"*Completions*"
;; This is a copy of `display-buffer-fallback-action'
@@ -1843,7 +1862,7 @@ variables.")
;; with `display-buffer-at-bottom'.
`((display-buffer--maybe-same-window
display-buffer-reuse-window
- display-buffer--maybe-pop-up-frame-or-window
+ display-buffer--maybe-pop-up-frame
;; Use `display-buffer-below-selected' for inline completions,
;; but not in the minibuffer (e.g. in `eval-expression')
;; for which `display-buffer-at-bottom' is used.
@@ -2105,9 +2124,9 @@ a completion function or god knows what else.")
;; like comint-completion-at-point or mh-letter-completion-at-point, which
;; could be sometimes safe and sometimes misbehaving (and sometimes neither).
(if (pcase which
- (`all t)
- (`safe (member fun completion--capf-safe-funs))
- (`optimist (not (member fun completion--capf-misbehave-funs))))
+ ('all t)
+ ('safe (member fun completion--capf-safe-funs))
+ ('optimist (not (member fun completion--capf-misbehave-funs))))
(let ((res (funcall fun)))
(cond
((and (consp res) (not (functionp res)))
@@ -2278,7 +2297,7 @@ Useful to give the user default values that won't be substituted."
(if (and (not (file-name-quoted-p filename))
(file-name-absolute-p filename)
(string-match-p (if (memq system-type '(windows-nt ms-dos))
- "[/\\\\]~" "/~")
+ "[/\\]~" "/~")
(file-local-name filename)))
(file-name-quote filename)
(minibuffer--double-dollars filename)))
@@ -2292,7 +2311,7 @@ Useful to give the user default values that won't be substituted."
;; We can't reuse env--substitute-vars-regexp because we need to match only
;; potentially-unfinished envvars at end of string.
(concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)"
- "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'"))
+ "\\$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'"))
(defun completion--embedded-envvar-table (string _pred action)
"Completion table for envvars embedded in a string.
@@ -2333,7 +2352,7 @@ same as `substitute-in-file-name'."
(match-beginning 0)))))))
(t
(if (eq (aref string (1- beg)) ?{)
- (setq table (apply-partially 'completion-table-with-terminator
+ (setq table (apply-partially #'completion-table-with-terminator
"}" table)))
;; Even if file-name completion is case-insensitive, we want
;; envvar completion to be case-sensitive.
@@ -2467,7 +2486,7 @@ except that it passes the file name through `substitute-in-file-name'.")
#'completion--file-name-table)
"Internal subroutine for `read-file-name'. Do not call this.")
-(defvar read-file-name-function 'read-file-name-default
+(defvar read-file-name-function #'read-file-name-default
"The function called by `read-file-name' to do its work.
It should accept the same arguments as `read-file-name'.")
@@ -2732,17 +2751,9 @@ See `read-file-name' for the meaning of the arguments."
(if (string= val1 (cadr file-name-history))
(pop file-name-history)
(setcar file-name-history val1)))
- (if add-to-history
- ;; Add the value to the history--but not if it matches
- ;; the last value already there.
- (let ((val1 (minibuffer-maybe-quote-filename val)))
- (unless (and (consp file-name-history)
- (equal (car file-name-history) val1))
- (setq file-name-history
- (cons val1
- (if history-delete-duplicates
- (delete val1 file-name-history)
- file-name-history)))))))
+ (when add-to-history
+ (add-to-history 'file-name-history
+ (minibuffer-maybe-quote-filename val))))
val))))
(defun internal-complete-buffer-except (&optional buffer)
@@ -2750,8 +2761,8 @@ See `read-file-name' for the meaning of the arguments."
BUFFER nil or omitted means use the current buffer.
Like `internal-complete-buffer', but removes BUFFER from the completion list."
(let ((except (if (stringp buffer) buffer (buffer-name buffer))))
- (apply-partially 'completion-table-with-predicate
- 'internal-complete-buffer
+ (apply-partially #'completion-table-with-predicate
+ #'internal-complete-buffer
(lambda (name)
(not (equal (if (consp name) (car name) name) except)))
nil)))
@@ -2968,12 +2979,14 @@ or a symbol, see `completion-pcm--merge-completions'."
(`(,(and s1 (pred stringp)) ,(and s2 (pred stringp)) . ,rest)
(setq p (cons (concat s1 s2) rest)))
(`(,(and p1 (pred symbolp)) ,(and p2 (guard (eq p1 p2))) . ,_)
+ ;; Unused lexical variable warning due to body not using p1, p2.
+ ;; https://debbugs.gnu.org/16771
(setq p (cdr p)))
(`(star ,(pred symbolp) . ,rest) (setq p `(star . ,rest)))
(`(,(pred symbolp) star . ,rest) (setq p `(star . ,rest)))
- (`(point ,(or `any `any-delim) . ,rest) (setq p `(point . ,rest)))
- (`(,(or `any `any-delim) point . ,rest) (setq p `(point . ,rest)))
- (`(any ,(or `any `any-delim) . ,rest) (setq p `(any . ,rest)))
+ (`(point ,(or 'any 'any-delim) . ,rest) (setq p `(point . ,rest)))
+ (`(,(or 'any 'any-delim) point . ,rest) (setq p `(point . ,rest)))
+ (`(any ,(or 'any 'any-delim) . ,rest) (setq p `(any . ,rest)))
(`(,(pred symbolp)) (setq p nil)) ;Implicit terminating `any'.
(_ (push (pop p) n))))
(nreverse n)))
@@ -2999,6 +3012,17 @@ or a symbol, see `completion-pcm--merge-completions'."
(setq re (replace-match "" t t re 1)))
re))
+(defun completion-pcm--pattern-point-idx (pattern)
+ "Return index of subgroup corresponding to `point' element of PATTERN.
+Return nil if there's no such element."
+ (let ((idx nil)
+ (i 0))
+ (dolist (x pattern)
+ (unless (stringp x)
+ (cl-incf i)
+ (if (eq x 'point) (setq idx i))))
+ idx))
+
(defun completion-pcm--all-completions (prefix pattern table pred)
"Find all completions for PATTERN in TABLE obeying PRED.
PATTERN is as returned by `completion-pcm--string->pattern'."
@@ -3028,9 +3052,21 @@ PATTERN is as returned by `completion-pcm--string->pattern'."
(when (string-match-p regex c) (push c poss)))
(nreverse poss))))))
+(defvar flex-score-match-tightness 100
+ "Controls how the `flex' completion style scores its matches.
+
+Value is a positive number. Values smaller than one make the
+scoring formula value matches scattered along the string, while
+values greater than one make the formula value tighter matches.
+I.e \"foo\" matches both strings \"barbazfoo\" and \"fabrobazo\",
+which are of equal length, but only a value greater than one will
+score the former (which has one \"hole\") higher than the
+latter (which has two).")
+
(defun completion-pcm--hilit-commonality (pattern completions)
(when completions
- (let* ((re (completion-pcm--pattern->regex pattern '(point)))
+ (let* ((re (completion-pcm--pattern->regex pattern 'group))
+ (point-idx (completion-pcm--pattern-point-idx pattern))
(case-fold-search completion-ignore-case))
(mapcar
(lambda (str)
@@ -3038,15 +3074,70 @@ PATTERN is as returned by `completion-pcm--string->pattern'."
(setq str (copy-sequence str))
(unless (string-match re str)
(error "Internal error: %s does not match %s" re str))
- (let ((pos (or (match-beginning 1) (match-end 0))))
- (put-text-property 0 pos
+ (let* ((pos (if point-idx (match-beginning point-idx) (match-end 0)))
+ (md (match-data))
+ (start (pop md))
+ (end (pop md))
+ (len (length str))
+ ;; To understand how this works, consider these bad
+ ;; ascii(tm) diagrams showing how the pattern \"foo\"
+ ;; flex-matches \"fabrobazo" and
+ ;; \"barfoobaz\":
+
+ ;; f abr o baz o
+ ;; + --- + --- +
+
+ ;; bar foo baz
+ ;; --- +++ ---
+
+ ;; Where + indicates parts where the pattern matched,
+ ;; - where it didn't match. The score is a number
+ ;; bound by ]0..1]: the higher the better and only a
+ ;; perfect match (pattern equals string) will have
+ ;; score 1. The formula takes the form of a quotient.
+ ;; For the numerator, we use the number of +, i.e. the
+ ;; length of the pattern. For the denominator, it
+ ;; sums (1+ (/ (grouplen - 1)
+ ;; flex-score-match-tightness)) across all groups of
+ ;; -, sums one to that total, and then multiples by
+ ;; the length of the string.
+ (score-numerator 0)
+ (score-denominator 0)
+ (last-b 0)
+ (update-score
+ (lambda (a b)
+ "Update score variables given match range (A B)."
+ (setq
+ score-numerator (+ score-numerator (- b a)))
+ (unless (= a last-b)
+ (setq
+ score-denominator (+ score-denominator
+ 1
+ (/ (- a last-b 1)
+ flex-score-match-tightness
+ 1.0))))
+ (setq
+ last-b b))))
+ (funcall update-score start start)
+ (while md
+ (funcall update-score start (car md))
+ (put-text-property start (pop md)
+ 'font-lock-face 'completions-common-part
+ str)
+ (setq start (pop md)))
+ (funcall update-score len len)
+ (put-text-property start end
'font-lock-face 'completions-common-part
str)
(if (> (length str) pos)
(put-text-property pos (1+ pos)
- 'font-lock-face 'completions-first-difference
- str)))
- str)
+ 'font-lock-face 'completions-first-difference
+ str))
+ (unless (zerop (length str))
+ (put-text-property
+ 0 1 'completion-score
+ (/ score-numerator (* len (1+ score-denominator)) 1.0) str)))
+ str)
completions))))
(defun completion-pcm--find-all-completions (string table pred point
@@ -3327,7 +3418,12 @@ the same set of elements."
;;; Substring completion
;; Mostly derived from the code of `basic' completion.
-(defun completion-substring--all-completions (string table pred point)
+(defun completion-substring--all-completions
+ (string table pred point &optional transform-pattern-fn)
+ "Match the presumed substring STRING to the entries in TABLE.
+Respect PRED and POINT. The pattern used is a PCM-style
+substring pattern, but it be massaged by TRANSFORM-PATTERN-FN, if
+that is non-nil."
(let* ((beforepoint (substring string 0 point))
(afterpoint (substring string point))
(bounds (completion-boundaries beforepoint table pred afterpoint))
@@ -3338,6 +3434,9 @@ the same set of elements."
(pattern (if (not (stringp (car basic-pattern)))
basic-pattern
(cons 'prefix basic-pattern)))
+ (pattern (if transform-pattern-fn
+ (funcall transform-pattern-fn pattern)
+ pattern))
(all (completion-pcm--all-completions prefix pattern table pred)))
(list all pattern prefix suffix (car bounds))))
@@ -3357,6 +3456,52 @@ the same set of elements."
(nconc (completion-pcm--hilit-commonality pattern all)
(length prefix)))))
+;;; "flex" completion, also known as flx/fuzzy/scatter completion
+;; Completes "foo" to "frodo" and "farfromsober"
+
+(defun completion-flex--make-flex-pattern (pattern)
+ "Convert PCM-style PATTERN into PCM-style flex pattern.
+
+This turns
+ (prefix \"foo\" point)
+into
+ (prefix \"f\" any \"o\" any \"o\" any point)
+which is at the core of flex logic. The extra
+'any' is optimized away later on."
+ (mapcan (lambda (elem)
+ (if (stringp elem)
+ (mapcan (lambda (char)
+ (list (string char) 'any))
+ elem)
+ (list elem)))
+ pattern))
+
+(defun completion-flex-try-completion (string table pred point)
+ "Try to flex-complete STRING in TABLE given PRED and POINT."
+ (pcase-let ((`(,all ,pattern ,prefix ,suffix ,_carbounds)
+ (completion-substring--all-completions
+ string table pred point
+ #'completion-flex--make-flex-pattern)))
+ (if minibuffer-completing-file-name
+ (setq all (completion-pcm--filename-try-filter all)))
+ ;; Try some "merging", meaning add as much as possible to the
+ ;; user's pattern without losing any possible matches in `all'.
+ ;; i.e this will augment "cfi" to "config" if all candidates
+ ;; contain the substring "config". FIXME: this still won't
+ ;; augment "foo" to "froo" when matching "frodo" and
+ ;; "farfromsober".
+ (completion-pcm--merge-try pattern all prefix suffix)))
+
+(defun completion-flex-all-completions (string table pred point)
+ "Get flex-completions of STRING in TABLE, given PRED and POINT."
+ (pcase-let ((`(,all ,pattern ,prefix ,_suffix ,_carbounds)
+ (completion-substring--all-completions
+ string table pred point
+ #'completion-flex--make-flex-pattern)))
+ (when all
+ (nconc (completion-pcm--hilit-commonality pattern all)
+ (length prefix)))))
+
;; Initials completion
;; Complete /ums to /usr/monnier/src or lch to list-command-history.
@@ -3399,7 +3544,7 @@ the same set of elements."
(when newstr
(completion-pcm-try-completion newstr table pred (length newstr)))))
-(defvar completing-read-function 'completing-read-default
+(defvar completing-read-function #'completing-read-default
"The function called by `completing-read' to do its work.
It should accept the same arguments as `completing-read'.")
diff --git a/lisp/mouse.el b/lisp/mouse.el
index 3660a1deb24..835eaa32c61 100644
--- a/lisp/mouse.el
+++ b/lisp/mouse.el
@@ -29,6 +29,8 @@
;;; Code:
+(eval-when-compile (require 'rect))
+
;;; Utility functions.
;; Indent track-mouse like progn.
@@ -41,8 +43,7 @@
(defcustom mouse-yank-at-point nil
"If non-nil, mouse yank commands yank at point instead of at click."
- :type 'boolean
- :group 'mouse)
+ :type 'boolean)
(defcustom mouse-drag-copy-region nil
"If non-nil, copy to kill-ring upon mouse adjustments of the region.
@@ -50,16 +51,15 @@
This affects `mouse-save-then-kill' (\\[mouse-save-then-kill]) in
addition to mouse drags."
:type 'boolean
- :version "24.1"
- :group 'mouse)
+ :version "24.1")
(defcustom mouse-1-click-follows-link 450
"Non-nil means that clicking Mouse-1 on a link follows the link.
With the default setting, an ordinary Mouse-1 click on a link
performs the same action as Mouse-2 on that link, while a longer
-Mouse-1 click \(hold down the Mouse-1 button for more than 450
-milliseconds) performs the original Mouse-1 binding \(which
+Mouse-1 click (hold down the Mouse-1 button for more than 450
+milliseconds) performs the original Mouse-1 binding (which
typically sets point where you click the mouse).
If value is an integer, the time elapsed between pressing and
@@ -83,8 +83,7 @@ packages. See `mouse-on-link-p' for details."
:type '(choice (const :tag "Disabled" nil)
(const :tag "Double click" double)
(number :tag "Single click time limit" :value 450)
- (other :tag "Single click" t))
- :group 'mouse)
+ (other :tag "Single click" t)))
(defcustom mouse-1-click-in-non-selected-windows t
"If non-nil, a Mouse-1 click also follows links in non-selected windows.
@@ -93,58 +92,64 @@ If nil, a Mouse-1 click on a link in a non-selected window performs
the normal mouse-1 binding, typically selects the window and sets
point at the click position."
:type 'boolean
- :version "22.1"
- :group 'mouse)
+ :version "22.1")
+
+(defvar mouse--last-down nil)
(defun mouse--down-1-maybe-follows-link (&optional _prompt)
+ (when mouse-1-click-follows-link
+ (setq mouse--last-down (cons (car-safe last-input-event) (current-time))))
+ nil)
+
+(defun mouse--click-1-maybe-follows-link (&optional _prompt)
"Turn `mouse-1' events into `mouse-2' events if follows-link.
-Expects to be bound to `down-mouse-1' in `key-translation-map'."
- (when (and mouse-1-click-follows-link
- (eq (if (eq mouse-1-click-follows-link 'double)
- 'double-down-mouse-1 'down-mouse-1)
- (car-safe last-input-event)))
- (let ((action (mouse-on-link-p (event-start last-input-event))))
- (when (and action
- (or mouse-1-click-in-non-selected-windows
- (eq (selected-window)
- (posn-window (event-start last-input-event)))))
- (let ((timedout
- (sit-for (if (numberp mouse-1-click-follows-link)
- (/ (abs mouse-1-click-follows-link) 1000.0)
- 0))))
- (if (if (and (numberp mouse-1-click-follows-link)
- (>= mouse-1-click-follows-link 0))
- timedout (not timedout))
- nil
- ;; Use read-key so it works for xterm-mouse-mode!
- (let ((event (read-key)))
- (if (eq (car-safe event)
- (if (eq mouse-1-click-follows-link 'double)
- 'double-mouse-1 'mouse-1))
- (progn
- ;; Turn the mouse-1 into a mouse-2 to follow links,
- ;; but only if ‘mouse-on-link-p’ hasn’t returned a
- ;; string or vector (see its docstring).
- (if (or (stringp action) (vectorp action))
- (push (aref action 0) unread-command-events)
- (let ((newup (if (eq mouse-1-click-follows-link 'double)
- 'double-mouse-2 'mouse-2)))
- ;; If mouse-2 has never been done by the user, it
- ;; doesn't have the necessary property to be
- ;; interpreted correctly.
- (unless (get newup 'event-kind)
- (put newup 'event-kind (get (car event) 'event-kind)))
- (push (cons newup (cdr event)) unread-command-events)))
- ;; Don't change the down event, only the up-event
- ;; (bug#18212).
- nil)
- (push event unread-command-events)
- nil))))))))
+Expects to be bound to `(double-)mouse-1' in `key-translation-map'."
+ (and mouse--last-down
+ (pcase mouse-1-click-follows-link
+ ('nil nil)
+ ('double (eq 'double-mouse-1 (car-safe last-input-event)))
+ (_ (and (eq 'mouse-1 (car-safe last-input-event))
+ (or (not (numberp mouse-1-click-follows-link))
+ (funcall (if (< mouse-1-click-follows-link 0)
+ (lambda (a b) (time-less-p b a))
+ #'time-less-p)
+ (time-since (cdr mouse--last-down))
+ (/ (abs mouse-1-click-follows-link) 1000.0))))))
+ (eq (car mouse--last-down)
+ (event-convert-list (list 'down (car-safe last-input-event))))
+ (let* ((action (mouse-on-link-p (event-start last-input-event))))
+ (when (and action
+ (or mouse-1-click-in-non-selected-windows
+ (eq (selected-window)
+ (posn-window (event-start last-input-event)))))
+ ;; Turn the mouse-1 into a mouse-2 to follow links,
+ ;; but only if ‘mouse-on-link-p’ hasn’t returned a
+ ;; string or vector (see its docstring).
+ (if (arrayp action)
+ (vector (aref action 0))
+ (let ((newup (if (eq mouse-1-click-follows-link 'double)
+ 'double-mouse-2 'mouse-2)))
+ ;; If mouse-2 has never been done by the user, it
+ ;; doesn't have the necessary property to be
+ ;; interpreted correctly.
+ (unless (get newup 'event-kind)
+ (put newup 'event-kind
+ (get (car last-input-event) 'event-kind)))
+ ;; Modify the event in-place, otherwise we can get a prefix
+ ;; added again, so a click on the header-line turns
+ ;; into a [header-line header-line mouse-2] :-(.
+ ;; See fake_prefixed_keys in src/keyboard.c's.
+ (setf (car last-input-event) newup)
+ (vector last-input-event)))))))
(define-key key-translation-map [down-mouse-1]
#'mouse--down-1-maybe-follows-link)
(define-key key-translation-map [double-down-mouse-1]
#'mouse--down-1-maybe-follows-link)
+(define-key key-translation-map [mouse-1]
+ #'mouse--click-1-maybe-follows-link)
+(define-key key-translation-map [double-mouse-1]
+ #'mouse--click-1-maybe-follows-link)
;; Provide a mode-specific menu on a mouse button.
@@ -168,7 +173,10 @@ items `Turn Off' and `Help'."
(mouse-menu-non-singleton menu)
(if (fboundp mm-fun) ; bug#20201
`(keymap
- ,indicator
+ ,(format "%s - %s" indicator
+ (capitalize
+ (replace-regexp-in-string
+ "-" " " (format "%S" minor-mode))))
(turn-off menu-item "Turn off minor mode" ,mm-fun)
(help menu-item "Help for minor mode"
(lambda () (interactive)
@@ -921,7 +929,6 @@ Nil means keep point at the position clicked (region end);
non-nil means move point to beginning of region."
:type '(choice (const :tag "Don't move point" nil)
(const :tag "Move point to beginning of region" t))
- :group 'mouse
:version "26.1")
(defun mouse-set-point (event &optional promote-to-region)
@@ -1027,8 +1034,7 @@ this many seconds between scroll steps. Scrolling stops when you move
the mouse back into the window, or release the button.
This variable's value may be non-integral.
Setting this to zero causes Emacs to scroll as fast as it can."
- :type 'number
- :group 'mouse)
+ :type 'number)
(defcustom mouse-scroll-min-lines 1
"The minimum number of lines scrolled by dragging mouse out of window.
@@ -1037,8 +1043,7 @@ scrolling repeatedly. The number of lines scrolled per repetition
is normally equal to the number of lines beyond the window edge that
the mouse has moved. However, it always scrolls at least the number
of lines specified by this variable."
- :type 'integer
- :group 'mouse)
+ :type 'integer)
(defun mouse-scroll-subr (window jump &optional overlay start)
"Scroll the window WINDOW, JUMP lines at a time, until new input arrives.
@@ -1111,6 +1116,10 @@ its value is returned."
(if (consp pos)
(let ((w (posn-window pos)) (pt (posn-point pos))
(str (posn-string pos)))
+ ;; FIXME: When STR has a `category' property and there's another
+ ;; `category' property at PT, we should probably disregard the
+ ;; `category' property at PT while doing the (get-char-property
+ ;; pt property w)!
(or (and str
(get-text-property (cdr str) property (car str)))
;; Mouse clicks in the fringe come with a position in
@@ -1144,19 +1153,15 @@ The resulting value determine whether POS is inside a link:
is a non-nil `mouse-face' property at POS. Return t in this case.
- If the value is a function, FUNC, POS is inside a link if
-the call \(FUNC POS) returns non-nil. Return the return value
-from that call. Arg is \(posn-point POS) if POS is a mouse event.
+the call (FUNC POS) returns non-nil. Return the return value
+from that call. Arg is (posn-point POS) if POS is a mouse event.
- Otherwise, return the value itself.
The return value is interpreted as follows:
-- If it is a string, the mouse-1 event is translated into the
-first character of the string, i.e. the action of the mouse-1
-click is the local or global binding of that character.
-
-- If it is a vector, the mouse-1 event is translated into the
-first element of that vector, i.e. the action of the mouse-1
+- If it is an array, the mouse-1 event is translated into the
+first element of that array, i.e. the action of the mouse-1
click is the local or global binding of that event.
- Otherwise, the mouse-1 event is translated into a mouse-2 event
@@ -1612,8 +1617,8 @@ if `mouse-drag-copy-region' is non-nil)"
(if mouse-drag-copy-region
;; Region already saved in the previous click;
;; don't make a duplicate entry, just delete.
- (delete-region (mark t) (point))
- (kill-region (mark t) (point)))
+ (funcall region-extract-function 'delete-only)
+ (kill-region (mark t) (point) 'region))
(setq mouse-selection-click-count 0)
(setq mouse-save-then-kill-posn nil))
@@ -1638,7 +1643,7 @@ if `mouse-drag-copy-region' is non-nil)"
(mouse-set-region-1)
(when mouse-drag-copy-region
;; Region already copied to kill-ring once, so replace.
- (kill-new (filter-buffer-substring (mark t) (point)) t))
+ (kill-new (funcall region-extract-function nil) t))
;; Arrange for a repeated mouse-3 to kill the region.
(setq mouse-save-then-kill-posn click-pt)))
@@ -1953,8 +1958,7 @@ When there is no region, this function does nothing."
"Number of buffers in one pane (submenu) of the buffer menu.
If we have lots of buffers, divide them into groups of
`mouse-buffer-menu-maxlen' and make a pane (or submenu) for each one."
- :type 'integer
- :group 'mouse)
+ :type 'integer)
(defcustom mouse-buffer-menu-mode-mult 4
"Group the buffers by the major mode groups on \\[mouse-buffer-menu]?
@@ -1964,7 +1968,6 @@ will split the buffer menu by the major modes (see
Set to 1 (or even 0!) if you want to group by major mode always, and to
a large number if you prefer a mixed multitude. The default is 4."
:type 'integer
- :group 'mouse
:version "20.3")
(defvar mouse-buffer-menu-mode-groups
@@ -2362,8 +2365,7 @@ region, text is copied instead of being cut."
modifier))
'(alt super hyper shift control meta))
(other :tag "Enable dragging the region" t))
- :version "26.1"
- :group 'mouse)
+ :version "26.1")
(defcustom mouse-drag-and-drop-region-cut-when-buffers-differ nil
"If non-nil, cut text also when source and destination buffers differ.
@@ -2372,8 +2374,7 @@ the text in the source buffer alone when dropping it in a
different buffer. If this is non-nil, it will cut the text just
as it does when dropping text in the source buffer."
:type 'boolean
- :version "26.1"
- :group 'mouse)
+ :version "26.1")
(defcustom mouse-drag-and-drop-region-show-tooltip 256
"If non-nil, text is shown by a tooltip in a graphic display.
@@ -2383,8 +2384,7 @@ tooltip. If this is an integer (as with the default value of
256), it will show that many characters of the dragged text in
a tooltip."
:type 'integer
- :version "26.1"
- :group 'mouse)
+ :version "26.1")
(defcustom mouse-drag-and-drop-region-show-cursor t
"If non-nil, move point with mouse cursor during dragging.
@@ -2393,16 +2393,14 @@ Otherwise, it will move point together with the mouse cursor and,
in addition, temporarily highlight the original region with the
`mouse-drag-and-drop-region' face."
:type 'boolean
- :version "26.1"
- :group 'mouse)
+ :version "26.1")
(defface mouse-drag-and-drop-region '((t :inherit region))
"Face to highlight original text during dragging.
This face is used by `mouse-drag-and-drop-region' to temporarily
highlight the original region when
`mouse-drag-and-drop-region-show-cursor' is non-nil."
- :version "26.1"
- :group 'mouse)
+ :version "26.1")
(defun mouse-drag-and-drop-region (event)
"Move text in the region to point where mouse is dragged to.
@@ -2424,7 +2422,13 @@ is copied instead of being cut."
(buffer (current-buffer))
(window (selected-window))
(text-from-read-only buffer-read-only)
- (mouse-drag-and-drop-overlay (make-overlay start end))
+ ;; Use multiple overlays to cover cases where the region has more
+ ;; than one boundary.
+ (mouse-drag-and-drop-overlays (mapcar (lambda (bounds)
+ (make-overlay (car bounds)
+ (cdr bounds)))
+ (region-bounds)))
+ (region-noncontiguous (region-noncontiguous-p))
point-to-paste
point-to-paste-read-only
window-to-paste
@@ -2468,7 +2472,7 @@ is copied instead of being cut."
;; Obtain the dragged text in region. When the loop was
;; skipped, value-selection remains nil.
(unless value-selection
- (setq value-selection (buffer-substring start end))
+ (setq value-selection (funcall region-extract-function nil))
(when mouse-drag-and-drop-region-show-tooltip
(let ((text-size mouse-drag-and-drop-region-show-tooltip))
(setq text-tooltip
@@ -2481,12 +2485,14 @@ is copied instead of being cut."
value-selection))))
;; Check if selected text is read-only.
- (setq text-from-read-only (or text-from-read-only
- (get-text-property start 'read-only)
- (not (equal
- (next-single-char-property-change
- start 'read-only nil end)
- end)))))
+ (setq text-from-read-only
+ (or text-from-read-only
+ (catch 'loop
+ (dolist (bound (region-bounds))
+ (when (text-property-not-all
+ (car bound) (cdr bound) 'read-only nil)
+ (throw 'loop t)))))))
+
(setq window-to-paste (posn-window (event-end event)))
(setq point-to-paste (posn-point (event-end event)))
;; Set nil when target buffer is minibuffer.
@@ -2512,13 +2518,34 @@ is copied instead of being cut."
;; the original region. When modifier is pressed, the
;; text will be inserted to inside of the original
;; region.
+ ;;
+ ;; If the region is rectangular, check if the newly inserted
+ ;; rectangular text would intersect the already selected
+ ;; region. If it would, then set "drag-but-negligible" to t.
+ ;; As a special case, allow dragging the region freely anywhere
+ ;; to the left, as this will never trigger its contents to be
+ ;; inserted into the overlays tracking it.
(setq drag-but-negligible
- (and (eq (overlay-buffer mouse-drag-and-drop-overlay)
+ (and (eq (overlay-buffer (car mouse-drag-and-drop-overlays))
buffer-to-paste)
- (<= (overlay-start mouse-drag-and-drop-overlay)
- point-to-paste)
- (<= point-to-paste
- (overlay-end mouse-drag-and-drop-overlay)))))
+ (if region-noncontiguous
+ (let ((dimensions (rectangle-dimensions start end))
+ (start-coordinates
+ (rectangle-position-as-coordinates start))
+ (point-to-paste-coordinates
+ (rectangle-position-as-coordinates
+ point-to-paste)))
+ (and (rectangle-intersect-p
+ start-coordinates dimensions
+ point-to-paste-coordinates dimensions)
+ (not (< (car point-to-paste-coordinates)
+ (car start-coordinates)))))
+ (and (<= (overlay-start
+ (car mouse-drag-and-drop-overlays))
+ point-to-paste)
+ (<= point-to-paste
+ (overlay-end
+ (car mouse-drag-and-drop-overlays))))))))
;; Show a tooltip.
(if mouse-drag-and-drop-region-show-tooltip
@@ -2537,8 +2564,9 @@ is copied instead of being cut."
(t
'bar)))
(when cursor-in-text-area
- (overlay-put mouse-drag-and-drop-overlay
- 'face 'mouse-drag-and-drop-region)
+ (dolist (overlay mouse-drag-and-drop-overlays)
+ (overlay-put overlay
+ 'face 'mouse-drag-and-drop-region))
(deactivate-mark) ; Maintain region in other window.
(mouse-set-point event)))))
@@ -2594,7 +2622,9 @@ is copied instead of being cut."
(select-window window)
(goto-char point)
(setq deactivate-mark nil)
- (activate-mark))
+ (activate-mark)
+ (when region-noncontiguous
+ (rectangle-mark-mode)))
;; Modify buffers.
(t
;; * DESTINATION BUFFER::
@@ -2603,11 +2633,14 @@ is copied instead of being cut."
(setq window-exempt window-to-paste)
(goto-char point-to-paste)
(push-mark)
- (insert value-selection)
+ (insert-for-yank value-selection)
+
;; On success, set the text as region on destination buffer.
(when (not (equal (mark) (point)))
(setq deactivate-mark nil)
- (activate-mark))
+ (activate-mark)
+ (when region-noncontiguous
+ (rectangle-mark-mode)))
;; * SOURCE BUFFER::
;; Set back the original text as region or delete the original
@@ -2617,8 +2650,9 @@ is copied instead of being cut."
;; remove the original text.
(when no-modifier-on-drop
(let (deactivate-mark)
- (delete-region (overlay-start mouse-drag-and-drop-overlay)
- (overlay-end mouse-drag-and-drop-overlay))))
+ (dolist (overlay mouse-drag-and-drop-overlays)
+ (delete-region (overlay-start overlay)
+ (overlay-end overlay)))))
;; When source buffer and destination buffer are different,
;; keep (set back the original text as region) or remove the
;; original text.
@@ -2628,15 +2662,17 @@ is copied instead of being cut."
(if mouse-drag-and-drop-region-cut-when-buffers-differ
;; Remove the dragged text from source buffer like
;; operation `cut'.
- (delete-region (overlay-start mouse-drag-and-drop-overlay)
- (overlay-end mouse-drag-and-drop-overlay))
+ (dolist (overlay mouse-drag-and-drop-overlays)
+ (delete-region (overlay-start overlay)
+ (overlay-end overlay)))
;; Set back the dragged text as region on source buffer
;; like operation `copy'.
(activate-mark))
(select-window window-to-paste))))))
;; Clean up.
- (delete-overlay mouse-drag-and-drop-overlay)
+ (dolist (overlay mouse-drag-and-drop-overlays)
+ (delete-overlay overlay))
;; Restore old states but for the window where the drop
;; occurred. Restore cursor types for all windows.
diff --git a/lisp/mpc.el b/lisp/mpc.el
index 7253843d2f5..8e557ed2b35 100644
--- a/lisp/mpc.el
+++ b/lisp/mpc.el
@@ -1017,7 +1017,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
(text
(if (eq info 'self) (symbol-name tag)
(pcase tag
- ((or `Time `Duration)
+ ((or 'Time 'Duration)
(let ((time (cdr (or (assq 'time info) (assq 'Time info)))))
(setq pred (list nil)) ;Just assume it's never eq.
(when time
@@ -1025,7 +1025,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
(string-match ":" time))
(substring time (match-end 0))
time)))))
- (`Cover
+ ('Cover
(let ((dir (file-name-directory (cdr (assq 'file info)))))
;; (debug)
(push `(equal ',dir (file-name-directory (cdr (assq 'file info)))) pred)
@@ -2403,10 +2403,38 @@ This is used so that they can be compared with `eq', which is needed for
(interactive)
(mpc-cmd-pause "0"))
+(defun mpc-read-seek (prompt)
+ "Read a seek time.
+Returns a string suitable for MPD \"seekcur\" protocol command."
+ (let* ((str (read-from-minibuffer prompt nil nil nil nil nil t))
+ (seconds "\\(?1:[[:digit:]]+\\(?:\\.[[:digit:]]*\\)?\\)")
+ (minsec (concat "\\(?2:[[:digit:]]+\\):" seconds "?"))
+ (hrminsec (concat "\\(?3:[[:digit:]]+\\):\\(?:" minsec "?\\|:\\)"))
+ time sign)
+ (setq str (string-trim str))
+ (when (memq (string-to-char str) '(?+ ?-))
+ (setq sign (string (string-to-char str)))
+ (setq str (substring str 1)))
+ (setq time
+ ;; `string-to-number' returns 0 on failure
+ (cond
+ ((string-match (concat "^" hrminsec "$") str)
+ (+ (* 3600 (string-to-number (match-string 3 str)))
+ (* 60 (string-to-number (or (match-string 2 str) "")))
+ (string-to-number (or (match-string 1 str) ""))))
+ ((string-match (concat "^" minsec "$") str)
+ (+ (* 60 (string-to-number (match-string 2 str)))
+ (string-to-number (match-string 1 str))))
+ ((string-match (concat "^" seconds "$") str)
+ (string-to-number (match-string 1 str)))
+ (t (user-error "Invalid time"))))
+ (setq time (number-to-string time))
+ (if (null sign) time (concat sign time))))
+
(defun mpc-seek-current (pos)
"Seek within current track."
(interactive
- (list (read-string "Position to go ([+-]seconds): ")))
+ (list (mpc-read-seek "Position to go ([+-][[H:]M:]seconds): ")))
(mpc-cmd-seekcur pos))
(defun mpc-toggle-play ()
@@ -2527,7 +2555,6 @@ If stopped, start playback."
(defvar mpc--faster-toggle-forward nil)
(defvar mpc--faster-acceleration 0.5)
(defun mpc--faster-toggle (speedup step)
- (setq speedup (float speedup))
(if mpc--faster-toggle-timer
(mpc--faster-stop)
(mpc-status-refresh) (mpc-proc-sync)
@@ -2554,7 +2581,7 @@ If stopped, start playback."
(setq songtime (string-to-number
(cdr (assq 'time mpc-status))))
(setq songduration (mpc--songduration))
- (setq oldtime (float-time)))
+ (setq oldtime (current-time)))
((and (>= songtime songduration) mpc--faster-toggle-forward)
;; Skip to the beginning of the next song.
(if (not (equal (cdr (assq 'state mpc-status)) "play"))
@@ -2573,14 +2600,16 @@ If stopped, start playback."
(lambda ()
(setq songid (cdr (assq 'songid mpc-status)))
(setq songtime (setq songduration (mpc--songduration)))
- (setq oldtime (float-time))
+ (setq oldtime (current-time))
(mpc-proc-cmd (list "seekid" songid songtime)))))))
(t
(setq speedup (+ speedup mpc--faster-acceleration))
(let ((newstep
- (truncate (* speedup (- (float-time) oldtime)))))
+ (truncate
+ (* speedup
+ (float-time (time-since oldtime))))))
(if (<= newstep 1) (setq newstep 1))
- (setq oldtime (+ oldtime (/ newstep speedup)))
+ (setq oldtime (time-add oldtime (/ newstep speedup)))
(if (not mpc--faster-toggle-forward)
(setq newstep (- newstep)))
(setq songtime (min songduration (+ songtime newstep)))
diff --git a/lisp/msb.el b/lisp/msb.el
index ccc5f54738c..7a1a338fcc1 100644
--- a/lisp/msb.el
+++ b/lisp/msb.el
@@ -1132,9 +1132,6 @@ variable `msb-menu-cond'."
;;;###autoload
(define-minor-mode msb-mode
"Toggle Msb mode.
-With a prefix argument ARG, enable Msb mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
This mode overrides the binding(s) of `mouse-buffer-menu' to provide a
different buffer menu using the function `msb'."
diff --git a/lisp/mwheel.el b/lisp/mwheel.el
index 2186595ddb4..23f491db0fc 100644
--- a/lisp/mwheel.el
+++ b/lisp/mwheel.el
@@ -52,38 +52,25 @@
;; Sync the bindings.
(when (bound-and-true-p mouse-wheel-mode) (mouse-wheel-mode 1)))
-(defvar mouse-wheel-down-button 4)
-(make-obsolete-variable 'mouse-wheel-down-button
- 'mouse-wheel-down-event
- "22.1")
(defcustom mouse-wheel-down-event
(if (or (featurep 'w32-win) (featurep 'ns-win))
'wheel-up
- (intern (format "mouse-%s" mouse-wheel-down-button)))
+ 'mouse-4)
"Event used for scrolling down."
:group 'mouse
:type 'symbol
:set 'mouse-wheel-change-button)
-(defvar mouse-wheel-up-button 5)
-(make-obsolete-variable 'mouse-wheel-up-button
- 'mouse-wheel-up-event
- "22.1")
(defcustom mouse-wheel-up-event
(if (or (featurep 'w32-win) (featurep 'ns-win))
'wheel-down
- (intern (format "mouse-%s" mouse-wheel-up-button)))
+ 'mouse-5)
"Event used for scrolling up."
:group 'mouse
:type 'symbol
:set 'mouse-wheel-change-button)
-(defvar mouse-wheel-click-button 2)
-(make-obsolete-variable 'mouse-wheel-click-button
- 'mouse-wheel-click-event
- "22.1")
-(defcustom mouse-wheel-click-event
- (intern (format "mouse-%s" mouse-wheel-click-button))
+(defcustom mouse-wheel-click-event 'mouse-2
"Event that should be temporarily inhibited after mouse scrolling.
The mouse wheel is typically on the mouse-2 button, so it may easily
happen that text is accidentally yanked into the buffer when
@@ -322,10 +309,7 @@ non-Windows systems."
(defvar mwheel-installed-bindings nil)
(define-minor-mode mouse-wheel-mode
- "Toggle mouse wheel support (Mouse Wheel mode).
-With a prefix argument ARG, enable Mouse Wheel mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil."
+ "Toggle mouse wheel support (Mouse Wheel mode)."
:init-value t
;; We'd like to use custom-initialize-set here so the setup is done
;; before dumping, but at the point where the defcustom is evaluated,
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el
index f400c562939..5af9ea75ed1 100644
--- a/lisp/net/ange-ftp.el
+++ b/lisp/net/ange-ftp.el
@@ -1,4 +1,4 @@
-;;; ange-ftp.el --- transparent FTP support for GNU Emacs
+;;; ange-ftp.el --- transparent FTP support for GNU Emacs -*- lexical-binding:t -*-
;; Copyright (C) 1989-1996, 1998, 2000-2019 Free Software Foundation,
;; Inc.
@@ -1168,7 +1168,7 @@ only return the directory part of FILE."
(ange-ftp-parse-netrc)
(catch 'found-one
(maphash
- (lambda (host val)
+ (lambda (host _val)
(if (ange-ftp-lookup-passwd host user) (throw 'found-one host)))
ange-ftp-user-hashtable)
(save-match-data
@@ -1361,11 +1361,13 @@ only return the directory part of FILE."
(ange-ftp-real-expand-file-name ange-ftp-netrc-filename)))
(setq attr (ange-ftp-real-file-attributes file)))
(if (and attr ; file exists.
- (not (equal (nth 5 attr) ange-ftp-netrc-modtime))) ; file changed
+ (not (equal (file-attribute-modification-time attr)
+ ange-ftp-netrc-modtime))) ; file changed
(save-match-data
(if (or ange-ftp-disable-netrc-security-check
- (and (eq (nth 2 attr) (user-uid)) ; Same uids.
- (string-match ".r..------" (nth 8 attr))))
+ (and (eq (file-attribute-user-id attr) (user-uid)) ; Same uids.
+ (string-match ".r..------"
+ (file-attribute-modes attr))))
(with-current-buffer
;; we are cheating a bit here. I'm trying to do the equivalent
;; of find-file on the .netrc file, but then nuke it afterwards.
@@ -1389,7 +1391,8 @@ only return the directory part of FILE."
(ange-ftp-message "%s either not owned by you or badly protected."
ange-ftp-netrc-filename)
(sit-for 1))
- (setq ange-ftp-netrc-modtime (nth 5 attr))))))
+ (setq ange-ftp-netrc-modtime
+ (file-attribute-modification-time attr))))))
;; Return a list of prefixes of the form 'user@host:' to be used when
;; completion is done in the root directory.
@@ -1399,14 +1402,14 @@ only return the directory part of FILE."
(save-match-data
(let (res)
(maphash
- (lambda (key value)
+ (lambda (key _value)
(if (string-match "\\`[^/]*\\(/\\).*\\'" key)
(let ((host (substring key 0 (match-beginning 1)))
(user (substring key (match-end 1))))
(push (concat user "@" host ":") res))))
ange-ftp-passwd-hashtable)
(maphash
- (lambda (host user) (push (concat host ":") res))
+ (lambda (host _user) (push (concat host ":") res))
ange-ftp-user-hashtable)
(or res (list nil)))))
@@ -1684,7 +1687,7 @@ good, skip, fatal, or unknown."
ange-ftp-process-result
ange-ftp-process-result-line)))))))
-(defun ange-ftp-process-sentinel (proc str)
+(defun ange-ftp-process-sentinel (proc _str)
"When FTP process changes state, nuke all file-entries in cache."
(let ((name (process-name proc)))
(when (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)\\*" name)
@@ -1733,7 +1736,7 @@ good, skip, fatal, or unknown."
(defvar ange-ftp-gwp-running t)
(defvar ange-ftp-gwp-status nil)
-(defun ange-ftp-gwp-sentinel (proc str)
+(defun ange-ftp-gwp-sentinel (_proc _str)
(setq ange-ftp-gwp-running nil))
(defun ange-ftp-gwp-filter (proc str)
@@ -1873,7 +1876,7 @@ been queued with no result. CONT will still be called, however."
(interactive "sHost: ")
(if ange-ftp-nslookup-program
(let ((default-directory
- (if (file-accessible-directory-p default-directory)
+ (if (ange-ftp-real-file-accessible-directory-p default-directory)
default-directory
exec-directory))
;; It would be nice to make process-connection-type nil,
@@ -1916,7 +1919,7 @@ on the gateway machine to do the FTP instead."
;; default-directory.
(file-name-handler-alist)
(default-directory
- (if (file-accessible-directory-p default-directory)
+ (if (ange-ftp-real-file-accessible-directory-p default-directory)
default-directory
exec-directory))
proc)
@@ -2676,7 +2679,7 @@ The main reason for this alist is to deal with file versions in VMS.")
(defmacro ange-ftp-parse-filename ()
;;Extract the filename from the current line of a dired-like listing.
- `(save-match-data
+ '(save-match-data
(let ((eol (progn (end-of-line) (point))))
(beginning-of-line)
(if (re-search-forward directory-listing-before-filename-regexp eol t)
@@ -2725,7 +2728,7 @@ The main reason for this alist is to deal with file versions in VMS.")
;; seem to believe in the F-switch
(if (or (and symlink (string-match "@\\'" file))
(and directory (string-match "/\\'" file))
- (and executable (string-match "*\\'" file))
+ (and executable (string-match "\\*\\'" file))
(and socket (string-match "=\\'" file)))
(setq file (substring file 0 -1)))))
(puthash file (or symlink directory) tbl)
@@ -2758,7 +2761,7 @@ match subdirectories as well.")
(defmacro ange-ftp-dl-parser ()
;; Parse the current buffer, which is assumed to be a descriptive
;; listing, and return a hashtable.
- `(let ((tbl (make-hash-table :test 'equal)))
+ '(let ((tbl (make-hash-table :test 'equal)))
(while (not (eobp))
(puthash
(buffer-substring (point)
@@ -2868,7 +2871,6 @@ NO-ERROR, if a listing for DIRECTORY cannot be obtained."
;; 2. The syntax of FILE and DIR make it impossible that FILE could be a valid
;; subdirectory. This is of course an OS dependent judgment.
-(defvar dired-local-variables-file)
(defmacro ange-ftp-allow-child-lookup (dir file)
`(not
(let* ((efile ,file) ; expand once.
@@ -2877,10 +2879,6 @@ NO-ERROR, if a listing for DIRECTORY cannot be obtained."
(host-type (ange-ftp-host-type
(car parsed))))
(or
- ;; Deal with dired
- (and (boundp 'dired-local-variables-file) ; in the dired-x package
- (stringp dired-local-variables-file)
- (string-equal dired-local-variables-file efile))
;; No dots in dir names in vms.
(and (eq host-type 'vms)
(string-match "\\." efile))
@@ -3247,7 +3245,8 @@ system TYPE.")
;; tell the process filter what size the transfer will be.
(let ((attr (file-attributes temp)))
(if attr
- (ange-ftp-set-xfer-size host user (nth 7 attr))))
+ (ange-ftp-set-xfer-size host user
+ (file-attribute-size attr))))
;; put or append the file.
(let ((result (ange-ftp-send-cmd host user
@@ -3373,6 +3372,13 @@ system TYPE.")
(file-error nil))
(ange-ftp-real-file-symlink-p file)))
+(defun ange-ftp-file-regular-p (file)
+ ;; Reuse Tramp's implementation.
+ (if (ange-ftp-ftp-name file)
+ (and (file-exists-p file)
+ (eq ?- (aref (file-attribute-modes (file-attributes file)) 0)))
+ (ange-ftp-real-file-regular-p file)))
+
(defun ange-ftp-file-exists-p (name)
(setq name (expand-file-name name))
(if (ange-ftp-ftp-name name)
@@ -3404,6 +3410,10 @@ system TYPE.")
file-ent))
(ange-ftp-real-file-directory-p name)))
+(defun ange-ftp-file-accessible-directory-p (name)
+ (and (file-directory-p name)
+ (file-readable-p name)))
+
(defun ange-ftp-directory-files (directory &optional full match
&rest v19-args)
(setq directory (expand-file-name directory))
@@ -3441,9 +3451,9 @@ system TYPE.")
(let ((part (ange-ftp-get-file-part file))
(files (ange-ftp-get-files (file-name-directory file))))
(if (ange-ftp-hash-entry-exists-p part files)
- (let ((host (nth 0 parsed))
- (user (nth 1 parsed))
- (name (nth 2 parsed))
+ (let (;; (host (nth 0 parsed))
+ ;; (user (nth 1 parsed))
+ ;; (name (nth 2 parsed))
(dirp (gethash part files))
(inode (gethash file ange-ftp-inodes-hashtable)))
(unless inode
@@ -3475,8 +3485,8 @@ system TYPE.")
(let ((f1-parsed (ange-ftp-ftp-name f1))
(f2-parsed (ange-ftp-ftp-name f2)))
(if (or f1-parsed f2-parsed)
- (let ((f1-mt (nth 5 (file-attributes f1)))
- (f2-mt (nth 5 (file-attributes f2))))
+ (let ((f1-mt (file-attribute-modification-time (file-attributes f1)))
+ (f2-mt (file-attribute-modification-time (file-attributes f2))))
(cond ((null f1-mt) nil)
((null f2-mt) t)
(t (time-less-p f2-mt f1-mt))))
@@ -3776,7 +3786,8 @@ so return the size on the remote host exactly. See RFC 3659."
;; tell the process filter what size the file is.
(let ((attr (file-attributes (or temp2 filename))))
(if attr
- (ange-ftp-set-xfer-size t-host t-user (nth 7 attr))))
+ (ange-ftp-set-xfer-size t-host t-user
+ (file-attribute-size attr))))
(ange-ftp-send-cmd
t-host
@@ -3829,7 +3840,7 @@ so return the size on the remote host exactly. See RFC 3659."
(ange-ftp-call-cont cont result line)))
(defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists
- keep-date preserve-uid-gid
+ keep-date _preserve-uid-gid
_preserve-selinux-context)
(interactive "fCopy file: \nFCopy %s to file: \np")
(ange-ftp-copy-file-internal filename
@@ -4266,7 +4277,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
nil
t
nil
- "-c"
+ shell-command-switch
(format "compress -f -c < %s > %s" tmp1 tmp2))
(and ange-ftp-process-verbose
(ange-ftp-message "Compressing %s...done" abbr))
@@ -4302,7 +4313,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
nil
t
nil
- "-c"
+ shell-command-switch
(format "uncompress -c < %s > %s" tmp1 tmp2))
(and ange-ftp-process-verbose
(ange-ftp-message "Uncompressing %s...done" abbr))
@@ -4385,10 +4396,13 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
(put 'directory-files-and-attributes 'ange-ftp
'ange-ftp-directory-files-and-attributes)
(put 'file-directory-p 'ange-ftp 'ange-ftp-file-directory-p)
+(put 'file-accessible-directory-p 'ange-ftp
+ 'ange-ftp-file-accessible-directory-p)
(put 'file-writable-p 'ange-ftp 'ange-ftp-file-writable-p)
(put 'file-readable-p 'ange-ftp 'ange-ftp-file-readable-p)
(put 'file-executable-p 'ange-ftp 'ange-ftp-file-executable-p)
(put 'file-symlink-p 'ange-ftp 'ange-ftp-file-symlink-p)
+(put 'file-regular-p 'ange-ftp 'ange-ftp-file-regular-p)
(put 'delete-file 'ange-ftp 'ange-ftp-delete-file)
(put 'verify-visited-file-modtime 'ange-ftp
'ange-ftp-verify-visited-file-modtime)
@@ -4427,6 +4441,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
;; We can handle process-file in a restricted way (just for chown).
;; Nothing possible for `start-file-process'.
+(put 'exec-path 'ange-ftp 'ignore)
+(put 'make-process 'ange-ftp 'ignore)
(put 'process-file 'ange-ftp 'ange-ftp-process-file)
(put 'start-file-process 'ange-ftp 'ignore)
(put 'shell-command 'ange-ftp 'ange-ftp-shell-command)
@@ -4469,6 +4485,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
(ange-ftp-run-real-handler 'directory-files-and-attributes args))
(defun ange-ftp-real-file-directory-p (&rest args)
(ange-ftp-run-real-handler 'file-directory-p args))
+(defun ange-ftp-real-file-accessible-directory-p (&rest args)
+ (ange-ftp-run-real-handler 'file-accessible-directory-p args))
(defun ange-ftp-real-file-writable-p (&rest args)
(ange-ftp-run-real-handler 'file-writable-p args))
(defun ange-ftp-real-file-readable-p (&rest args)
@@ -4477,6 +4495,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
(ange-ftp-run-real-handler 'file-executable-p args))
(defun ange-ftp-real-file-symlink-p (&rest args)
(ange-ftp-run-real-handler 'file-symlink-p args))
+(defun ange-ftp-real-file-regular-p (&rest args)
+ (ange-ftp-run-real-handler 'file-regular-p args))
(defun ange-ftp-real-delete-file (&rest args)
(ange-ftp-run-real-handler 'delete-file args))
(defun ange-ftp-real-verify-visited-file-modtime (&rest args)
@@ -5199,7 +5219,7 @@ Other orders of $ and _ seem to all work just fine.")
";\\([0-9]+\\)$"))
(version 0))
(maphash
- (lambda (name val)
+ (lambda (name _val)
(and (string-match regexp name)
(setq version
(max version
diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el
index cc7c11e4391..aa31e25fa91 100644
--- a/lisp/net/browse-url.el
+++ b/lisp/net/browse-url.el
@@ -713,8 +713,7 @@ Use variable `browse-url-filename-alist' to map filenames to URLs."
(let ((coding (if (equal system-type 'windows-nt)
;; W32 pretends that file names are UTF-8 encoded.
'utf-8
- (and (default-value 'enable-multibyte-characters)
- (or file-name-coding-system
+ (and (or file-name-coding-system
default-file-name-coding-system)))))
(if coding (setq file (encode-coding-string file coding))))
(setq file (browse-url-url-encode-chars file "[*\"()',=;?% ]"))
@@ -1257,18 +1256,16 @@ used instead of `browse-url-new-window-flag'."
(defvar url-handler-regexp)
;;;###autoload
-(defun browse-url-emacs (url &optional _new-window)
- "Ask Emacs to load URL into a buffer and show it in another window."
+(defun browse-url-emacs (url &optional same-window)
+ "Ask Emacs to load URL into a buffer and show it in another window.
+Optional argument SAME-WINDOW non-nil means show the URL in the
+currently selected window instead."
(interactive (browse-url-interactive-arg "URL: "))
(require 'url-handlers)
(let ((file-name-handler-alist
(cons (cons url-handler-regexp 'url-file-handler)
file-name-handler-alist)))
- ;; Ignore `new-window': with all other browsers the URL is always shown
- ;; in another window than the current Emacs one since it's shown in
- ;; another application's window.
- ;; (if new-window (find-file-other-window url) (find-file url))
- (find-file-other-window url)))
+ (if same-window (find-file url) (find-file-other-window url))))
;;;###autoload
(defun browse-url-gnome-moz (url &optional new-window)
diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index 25e5d4dccc3..3820cd49f2b 100644
--- a/lisp/net/dbus.el
+++ b/lisp/net/dbus.el
@@ -41,9 +41,16 @@
(defvar dbus-message-type-method-return)
(defvar dbus-message-type-error)
(defvar dbus-message-type-signal)
-(defvar dbus-debug)
(defvar dbus-registered-objects-table)
+;; The following symbols are defined in dbusbind.c. We need them also
+;; when Emacs is compiled without D-Bus support.
+(unless (boundp 'dbus-error)
+ (define-error 'dbus-error "D-Bus error"))
+
+(unless (boundp 'dbus-debug)
+ (defvar dbus-debug nil))
+
;; Pacify byte compiler.
(eval-when-compile (require 'cl-lib))
diff --git a/lisp/net/dns.el b/lisp/net/dns.el
index f6a804a6e86..4fa87050e57 100644
--- a/lisp/net/dns.el
+++ b/lisp/net/dns.el
@@ -117,7 +117,7 @@ updated. Set this variable to t to disable the check.")
length)
(while (not ended)
(setq length (dns-read-bytes 1))
- (if (= 192 (logand length (lsh 3 6)))
+ (if (= 192 (logand length (ash 3 6)))
(let ((offset (+ (* (logand 63 length) 256)
(dns-read-bytes 1))))
(save-excursion
@@ -144,17 +144,17 @@ If TCP-P, the first two bytes of the package with be the length field."
(dns-write-bytes (dns-get 'id spec) 2)
(dns-write-bytes
(logior
- (lsh (if (dns-get 'response-p spec) 1 0) -7)
- (lsh
+ (ash (if (dns-get 'response-p spec) 1 0) 7)
+ (ash
(cond
((eq (dns-get 'opcode spec) 'query) 0)
((eq (dns-get 'opcode spec) 'inverse-query) 1)
((eq (dns-get 'opcode spec) 'status) 2)
(t (error "No such opcode: %s" (dns-get 'opcode spec))))
- -3)
- (lsh (if (dns-get 'authoritative-p spec) 1 0) -2)
- (lsh (if (dns-get 'truncated-p spec) 1 0) -1)
- (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0)))
+ 3)
+ (ash (if (dns-get 'authoritative-p spec) 1 0) 2)
+ (ash (if (dns-get 'truncated-p spec) 1 0) 1)
+ (ash (if (dns-get 'recursion-desired-p spec) 1 0) 0)))
(dns-write-bytes
(cond
((eq (dns-get 'response-code spec) 'no-error) 0)
@@ -198,20 +198,20 @@ If TCP-P, the first two bytes of the package with be the length field."
(goto-char (point-min))
(push (list 'id (dns-read-bytes 2)) spec)
(let ((byte (dns-read-bytes 1)))
- (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t))
+ (push (list 'response-p (if (zerop (logand byte (ash 1 7))) nil t))
spec)
- (let ((opcode (logand byte (lsh 7 3))))
+ (let ((opcode (logand byte (ash 7 3))))
(push (list 'opcode
(cond ((eq opcode 0) 'query)
((eq opcode 1) 'inverse-query)
((eq opcode 2) 'status)))
spec))
- (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2)))
+ (push (list 'authoritative-p (if (zerop (logand byte (ash 1 2)))
nil t)) spec)
- (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t))
+ (push (list 'truncated-p (if (zerop (logand byte (ash 1 2))) nil t))
spec)
(push (list 'recursion-desired-p
- (if (zerop (logand byte (lsh 1 0))) nil t)) spec))
+ (if (zerop (logand byte (ash 1 0))) nil t)) spec))
(let ((rc (logand (dns-read-bytes 1) 15)))
(push (list 'response-code
(cond
@@ -432,8 +432,9 @@ If REVERSEP, look up an IP address."
tcp-p))
(while (and (zerop (buffer-size))
(> times 0))
- (sit-for (/ step 1000.0))
- (accept-process-output process 0 step)
+ (let ((step-sec (/ step 1000.0)))
+ (sit-for step-sec)
+ (accept-process-output process step-sec))
(setq times (- times step)))
(condition-case nil
(delete-process process)
diff --git a/lisp/net/eudc-bob.el b/lisp/net/eudc-bob.el
index 39b6ca9cdb9..59a4637eb80 100644
--- a/lisp/net/eudc-bob.el
+++ b/lisp/net/eudc-bob.el
@@ -25,8 +25,15 @@
;;; Commentary:
+;; eudc-bob.el presents binary entries in LDAP results in interactive
+;; ways. For example, it will display JPEG binary data as an inline
+;; image in the results buffer. See also
+;; https://tools.ietf.org/html/rfc2798.
+
;;; Usage:
-;; See the corresponding info file
+
+;; The eudc-bob interactive functions are invoked when the user
+;; interacts with an `eudc-query-form' results buffer.
;;; Code:
@@ -148,40 +155,21 @@ display a button."
"Toggle inline display of an image."
(interactive)
(when (eudc-bob-can-display-inline-images)
- (cond ((featurep 'xemacs)
- (let ((overlays (append (overlays-at (1- (point)))
- (overlays-at (point))))
- overlay glyph)
- (setq overlay (car overlays))
- (while (and overlay
- (not (setq glyph (overlay-get overlay 'glyph))))
- (setq overlays (cdr overlays))
- (setq overlay (car overlays)))
- (if overlay
- (if (overlay-get overlay 'end-glyph)
- (progn
- (overlay-put overlay 'end-glyph nil)
- (overlay-put overlay 'invisible nil))
- (overlay-put overlay 'end-glyph glyph)
- (overlay-put overlay 'invisible t)))))
- (t
- (let* ((overlays (append (overlays-at (1- (point)))
- (overlays-at (point))))
- image)
-
- ;; Search overlay with an image.
- (while (and overlays (null image))
- (let ((prop (overlay-get (car overlays) 'eudc-image)))
- (if (eq 'image (car-safe prop))
- (setq image prop)
- (setq overlays (cdr overlays)))))
-
- ;; Toggle that overlay's image display.
- (when overlays
- (let ((overlay (car overlays)))
- (overlay-put overlay 'display
- (if (overlay-get overlay 'display)
- nil image)))))))))
+ (let* ((overlays (append (overlays-at (1- (point)))
+ (overlays-at (point))))
+ image)
+ ;; Search overlay with an image.
+ (while (and overlays (null image))
+ (let ((prop (overlay-get (car overlays) 'eudc-image)))
+ (if (eq 'image (car-safe prop))
+ (setq image prop)
+ (setq overlays (cdr overlays)))))
+ ;; Toggle that overlay's image display.
+ (when overlays
+ (let ((overlay (car overlays)))
+ (overlay-put overlay 'display
+ (if (overlay-get overlay 'display)
+ nil image)))))))
(defun eudc-bob-display-audio (data)
"Display a button for audio DATA."
@@ -265,25 +253,19 @@ display a button."
(interactive "@e")
(run-hooks 'activate-menubar-hook)
(eudc-jump-to-event event)
- (if (featurep 'xemacs)
- (progn
- (run-hooks 'activate-popup-menu-hook)
- (popup-menu (eudc-bob-menu)))
- (let ((result (x-popup-menu t (eudc-bob-menu)))
- command)
- (if result
- (progn
- (setq command (lookup-key (eudc-bob-menu)
- (apply 'vector result)))
- (command-execute command))))))
+ (let ((result (x-popup-menu t (eudc-bob-menu)))
+ command)
+ (if result
+ (progn
+ (setq command (lookup-key (eudc-bob-menu)
+ (apply 'vector result)))
+ (command-execute command)))))
(setq eudc-bob-generic-keymap
(let ((map (make-sparse-keymap)))
(define-key map "s" 'eudc-bob-save-object)
(define-key map "!" 'eudc-bob-pipe-object-to-external-program)
- (define-key map (if (featurep 'xemacs)
- [button3]
- [down-mouse-3]) 'eudc-bob-popup-menu)
+ (define-key map [down-mouse-3] 'eudc-bob-popup-menu)
map))
(setq eudc-bob-image-keymap
@@ -294,25 +276,19 @@ display a button."
(setq eudc-bob-sound-keymap
(let ((map (make-sparse-keymap)))
(define-key map [return] 'eudc-bob-play-sound-at-point)
- (define-key map (if (featurep 'xemacs)
- [button2]
- [down-mouse-2]) 'eudc-bob-play-sound-at-mouse)
+ (define-key map [down-mouse-2] 'eudc-bob-play-sound-at-mouse)
map))
(setq eudc-bob-url-keymap
(let ((map (make-sparse-keymap)))
(define-key map [return] 'browse-url-at-point)
- (define-key map (if (featurep 'xemacs)
- [button2]
- [down-mouse-2]) 'browse-url-at-mouse)
+ (define-key map [down-mouse-2] 'browse-url-at-mouse)
map))
(setq eudc-bob-mail-keymap
(let ((map (make-sparse-keymap)))
(define-key map [return] 'goto-address-at-point)
- (define-key map (if (featurep 'xemacs)
- [button2]
- [down-mouse-2]) 'goto-address-at-point)
+ (define-key map [down-mouse-2] 'goto-address-at-point)
map))
(set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap)
@@ -320,19 +296,18 @@ display a button."
;; If the first arguments can be nil here, then these 3 can be
;; defconsts once more.
-(when (not (featurep 'xemacs))
- (easy-menu-define eudc-bob-generic-menu
- eudc-bob-generic-keymap
- ""
- eudc-bob-generic-menu)
- (easy-menu-define eudc-bob-image-menu
- eudc-bob-image-keymap
- ""
- eudc-bob-image-menu)
- (easy-menu-define eudc-bob-sound-menu
- eudc-bob-sound-keymap
- ""
- eudc-bob-sound-menu))
+(easy-menu-define eudc-bob-generic-menu
+ eudc-bob-generic-keymap
+ ""
+ eudc-bob-generic-menu)
+(easy-menu-define eudc-bob-image-menu
+ eudc-bob-image-keymap
+ ""
+ eudc-bob-image-menu)
+(easy-menu-define eudc-bob-sound-menu
+ eudc-bob-sound-keymap
+ ""
+ eudc-bob-sound-menu)
;;;###autoload
(defun eudc-display-generic-binary (data)
diff --git a/lisp/net/eudc-hotlist.el b/lisp/net/eudc-hotlist.el
index 05ea4903877..19788ba16cc 100644
--- a/lisp/net/eudc-hotlist.el
+++ b/lisp/net/eudc-hotlist.el
@@ -55,11 +55,6 @@ These are the special commands of this mode:
t -- Transpose the server at point and the previous one
q -- Commit the changes and quit.
x -- Quit without committing the changes."
- (when (featurep 'xemacs)
- (setq mode-popup-menu eudc-hotlist-menu)
- (when (featurep 'menubar)
- (set-buffer-menubar current-menubar)
- (add-submenu nil (cons "EUDC-Hotlist" (cdr (cdr eudc-hotlist-menu))))))
(setq buffer-read-only t))
;;;###autoload
@@ -179,10 +174,9 @@ These are the special commands of this mode:
["Save and Quit" eudc-hotlist-quit-edit t]
["Exit without Saving" kill-this-buffer t]))
-(when (not (featurep 'xemacs))
- (easy-menu-define eudc-hotlist-emacs-menu
+(easy-menu-define eudc-hotlist-emacs-menu
eudc-hotlist-mode-map
""
- eudc-hotlist-menu))
+ eudc-hotlist-menu)
;;; eudc-hotlist.el ends here
diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el
index bc550fbc113..3c9c01d0f96 100644
--- a/lisp/net/eudc.el
+++ b/lisp/net/eudc.el
@@ -1,4 +1,4 @@
-;;; eudc.el --- Emacs Unified Directory Client
+;;; eudc.el --- Emacs Unified Directory Client -*- lexical-binding:t -*-
;; Copyright (C) 1998-2019 Free Software Foundation, Inc.
@@ -47,7 +47,7 @@
(require 'wid-edit)
-(eval-when-compile (require 'cl-lib))
+(require 'cl-lib)
(eval-and-compile
(if (not (fboundp 'make-overlay))
@@ -68,6 +68,7 @@
(defvar eudc-mode-map
(let ((map (make-sparse-keymap)))
+ (set-keymap-parent map widget-keymap)
(define-key map "q" 'kill-current-buffer)
(define-key map "x" 'kill-current-buffer)
(define-key map "f" 'eudc-query-form)
@@ -75,7 +76,6 @@
(define-key map "n" 'eudc-move-to-next-record)
(define-key map "p" 'eudc-move-to-previous-record)
map))
-(set-keymap-parent eudc-mode-map widget-keymap)
(defvar mode-popup-menu)
@@ -158,25 +158,6 @@ properties on the list."
(setq plist (cdr (cdr plist))))
default))
-(if (not (fboundp 'split-string))
- (defun split-string (string &optional pattern)
- "Return a list of substrings of STRING which are separated by PATTERN.
-If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
- (or pattern
- (setq pattern "[ \f\t\n\r\v]+"))
- (let (parts (start 0))
- (when (string-match pattern string 0)
- (if (> (match-beginning 0) 0)
- (setq parts (cons (substring string 0 (match-beginning 0)) nil)))
- (setq start (match-end 0))
- (while (and (string-match pattern string start)
- (> (match-end 0) start))
- (setq parts (cons (substring string start (match-beginning 0)) parts)
- start (match-end 0))))
- (nreverse (if (< start (length string))
- (cons (substring string start) parts)
- parts)))))
-
(defun eudc-replace-in-string (str regexp newtext)
"Replace all matches in STR for REGEXP with NEWTEXT.
Value is the new string."
@@ -314,7 +295,7 @@ accordingly. Otherwise it is set to its EUDC default binding"
(defun eudc-update-local-variables ()
"Update all EUDC variables according to their local settings."
(interactive)
- (mapcar 'eudc-update-variable eudc-local-vars))
+ (mapcar #'eudc-update-variable eudc-local-vars))
(eudc-default-set 'eudc-query-function nil)
(eudc-default-set 'eudc-list-attributes-function nil)
@@ -378,7 +359,7 @@ BEG and END delimit the text which is to be replaced."
(let ((replacement))
(setq replacement
(completing-read "Multiple matches found; choose one: "
- (mapcar 'list choices)))
+ (mapcar #'list choices)))
(delete-region beg end)
(insert replacement)))
@@ -415,7 +396,7 @@ underscore characters are replaced by spaces."
(if match
(cdr match)
(capitalize
- (mapconcat 'identity
+ (mapconcat #'identity
(split-string (symbol-name attribute) "_")
" ")))))
@@ -432,7 +413,7 @@ if any, is called to print the value in cdr of FIELD."
(progn
(eval (list (cdr match) val))
(insert "\n"))
- (mapcar
+ (mapc
(function
(lambda (val-elem)
(indent-to col)
@@ -598,9 +579,10 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'."
(setq result
(eudc-add-field-to-records (cons (car field)
(mapconcat
- 'identity
+ #'identity
(cdr field)
- "\n")) result)))
+ "\n"))
+ result)))
((eq 'duplicate method)
(setq result
(eudc-distribute-field-on-records field result)))))))
@@ -613,12 +595,9 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'."
(mapcar
(function
(lambda (rec)
- (if (eval (cons 'and
- (mapcar
- (function
- (lambda (attr)
- (consp (assq attr rec))))
- attrs)))
+ (if (cl-every (lambda (attr)
+ (consp (assq attr rec)))
+ attrs)
rec)))
records)))
@@ -632,25 +611,14 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'."
(defun eudc-distribute-field-on-records (field records)
"Duplicate each individual record in RECORDS according to value of FIELD.
Each copy is added a new field containing one of the values of FIELD."
- (let (result
- (values (cdr field)))
- ;; Uniquify values first
- (while values
- (setcdr values (delete (car values) (cdr values)))
- (setq values (cdr values)))
- (mapc
- (function
- (lambda (value)
- (let ((result-list (copy-sequence records)))
- (setq result-list (eudc-add-field-to-records
- (cons (car field) value)
- result-list))
- (setq result (append result-list result))
- )))
- (cdr field))
+ (let (result)
+ (dolist (value (delete-dups (cdr field))) ;; Uniquify values first.
+ (setq result (nconc (eudc-add-field-to-records
+ (cons (car field) value)
+ records)
+ result)))
result))
-
(define-derived-mode eudc-mode special-mode "EUDC"
"Major mode used in buffers displaying the results of directory queries.
There is no sense in calling this command from a buffer other than
@@ -662,9 +630,7 @@ These are the special commands of EUDC mode:
n -- Move to next record.
p -- Move to previous record.
b -- Insert record at point into the BBDB database."
- (if (not (featurep 'xemacs))
- (easy-menu-define eudc-emacs-menu eudc-mode-map "" (eudc-menu))
- (setq mode-popup-menu (eudc-menu))))
+ (easy-menu-define eudc-emacs-menu eudc-mode-map "" (eudc-menu)))
;;}}}
@@ -776,8 +742,8 @@ otherwise a list of symbols is returned."
(setq query-alist (cdr query-alist)))
query)
(if eudc-protocol-has-default-query-attributes
- (mapconcat 'identity words " ")
- (list (cons 'name (mapconcat 'identity words " ")))))))
+ (mapconcat #'identity words " ")
+ (list (cons 'name (mapconcat #'identity words " ")))))))
(defun eudc-extract-n-word-formats (format-list n)
"Extract a list of N-long formats from FORMAT-LIST.
@@ -836,7 +802,6 @@ see `eudc-inline-expansion-servers'"
"[ \t]+"))
query-formats
response
- response-string
response-strings
(eudc-former-server eudc-server)
(eudc-former-protocol eudc-protocol)
@@ -894,20 +859,18 @@ see `eudc-inline-expansion-servers'"
(error "No match")
;; Process response through eudc-inline-expansion-format
- (while response
- (setq response-string
- (apply 'format
- (car eudc-inline-expansion-format)
- (mapcar (function
- (lambda (field)
- (or (cdr (assq field (car response)))
- "")))
- (eudc-translate-attribute-list
- (cdr eudc-inline-expansion-format)))))
- (if (> (length response-string) 0)
- (setq response-strings
- (cons response-string response-strings)))
- (setq response (cdr response)))
+ (dolist (r response)
+ (let ((response-string
+ (apply #'format
+ (car eudc-inline-expansion-format)
+ (mapcar (function
+ (lambda (field)
+ (or (cdr (assq field r))
+ "")))
+ (eudc-translate-attribute-list
+ (cdr eudc-inline-expansion-format))))))
+ (if (> (length response-string) 0)
+ (push response-string response-strings))))
(if (or
(and replace (not eudc-expansion-overwrites-query))
@@ -923,7 +886,7 @@ see `eudc-inline-expansion-servers'"
(eudc-select response-strings beg end))
((eq eudc-multiple-match-handling-method 'all)
(delete-region beg end)
- (insert (mapconcat 'identity response-strings ", ")))
+ (insert (mapconcat #'identity response-strings ", ")))
((eq eudc-multiple-match-handling-method 'abort)
(error "There is more than one match for the query")))))
(or (and (equal eudc-server eudc-former-server)
@@ -943,10 +906,9 @@ queries the server for the existing fields and displays a corresponding form."
prompts
widget
(width 0)
- inhibit-read-only
pt)
(switch-to-buffer buffer)
- (setq inhibit-read-only t)
+ (let ((inhibit-read-only t))
(erase-buffer)
(kill-all-local-variables)
(make-local-variable 'eudc-form-widget-list)
@@ -960,11 +922,10 @@ queries the server for the existing fields and displays a corresponding form."
(widget-insert "Protocol : " (symbol-name eudc-protocol) "\n")
;; Build the list of prompts
(setq prompts (if eudc-use-raw-directory-names
- (mapcar 'symbol-name (eudc-translate-attribute-list fields))
+ (mapcar #'symbol-name (eudc-translate-attribute-list fields))
(mapcar (function
(lambda (field)
- (or (and (assq field eudc-user-attribute-names-alist)
- (cdr (assq field eudc-user-attribute-names-alist)))
+ (or (cdr (assq field eudc-user-attribute-names-alist))
(capitalize (symbol-name field)))))
fields)))
;; Loop over prompt strings to find the longest one
@@ -1008,7 +969,7 @@ queries the server for the existing fields and displays a corresponding form."
"Quit")
(goto-char pt)
(use-local-map widget-keymap)
- (widget-setup))
+ (widget-setup)))
)
(defun eudc-bookmark-server (server protocol)
@@ -1177,60 +1138,41 @@ queries the server for the existing fields and displays a corresponding form."
eudc-tail-menu)))
(defun eudc-install-menu ()
- (cond
- ((and (featurep 'xemacs) (featurep 'menubar))
- (add-submenu '("Tools") (eudc-menu)))
- ((not (featurep 'xemacs))
- (cond
- ((fboundp 'easy-menu-create-menu)
- (define-key
- global-map
- [menu-bar tools directory-search]
- (cons "Directory Servers"
- (easy-menu-create-menu "Directory Servers" (cdr (eudc-menu))))))
- ((fboundp 'easy-menu-add-item)
- (let ((menu (eudc-menu)))
- (easy-menu-add-item nil '("tools") (easy-menu-create-menu (car menu)
- (cdr menu)))))
- ((fboundp 'easy-menu-create-keymaps)
- (easy-menu-define eudc-menu-map eudc-mode-map "Directory Client Menu" (eudc-menu))
- (define-key
- global-map
- [menu-bar tools eudc]
- (cons "Directory Servers"
- (easy-menu-create-keymaps "Directory Servers"
- (cdr (eudc-menu))))))
- (t
- (error "Unknown version of easymenu"))))
- ))
-
+ (define-key
+ global-map
+ [menu-bar tools directory-search]
+ (cons "Directory Servers"
+ (easy-menu-create-menu "Directory Servers" (cdr (eudc-menu))))))
;;; Load time initializations :
-;;; Load the options file
+;; Load the options file
(if (and (not noninteractive)
(and (locate-library eudc-options-file)
(progn (message "") t)) ; Remove mode line message
(not (featurep 'eudc-options-file)))
(load eudc-options-file))
-;;; Install the full menu
+;; Install the full menu
(unless (featurep 'infodock)
(eudc-install-menu))
-;;; The following installs a short menu for EUDC at XEmacs startup.
+;; The following installs a short menu for EUDC at Emacs startup.
;;;###autoload
(defun eudc-load-eudc ()
"Load the Emacs Unified Directory Client.
This does nothing except loading eudc by autoload side-effect."
(interactive)
+ ;; FIXME: By convention, loading a file should "do nothing significant"
+ ;; since Emacs may occasionally load a file for "frivolous" reasons
+ ;; (e.g. to find a docstring), so having a function which just loads
+ ;; the file doesn't seem very useful.
nil)
;;;###autoload
-(cond
- ((not (featurep 'xemacs))
+(progn
(defvar eudc-tools-menu
(let ((map (make-sparse-keymap "Directory Servers")))
(define-key map [phone]
@@ -1255,34 +1197,6 @@ This does nothing except loading eudc by autoload side-effect."
:help ,(purecopy "Load the Emacs Unified Directory Client")))
map))
(fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu)))
- (t
- (let ((menu '("Directory Servers"
- ["Load Hotlist of Servers" eudc-load-eudc t]
- ["New Server" eudc-set-server t]
- ["---" nil nil]
- ["Query with Form" eudc-query-form t]
- ["Expand Inline Query" eudc-expand-inline t]
- ["---" nil nil]
- ["Get Email" eudc-get-email t]
- ["Get Phone" eudc-get-phone t])))
- (if (not (featurep 'eudc-autoloads))
- (if (featurep 'xemacs)
- (if (and (featurep 'menubar)
- (not (featurep 'infodock)))
- (add-submenu '("Tools") menu))
- (require 'easymenu)
- (cond
- ((fboundp 'easy-menu-add-item)
- (easy-menu-add-item nil '("tools")
- (easy-menu-create-menu (car menu)
- (cdr menu))))
- ((fboundp 'easy-menu-create-keymaps)
- (define-key
- global-map
- [menu-bar tools eudc]
- (cons "Directory Servers"
- (easy-menu-create-keymaps "Directory Servers"
- (cdr menu)))))))))))
;;}}}
diff --git a/lisp/net/eudcb-bbdb.el b/lisp/net/eudcb-bbdb.el
index b99bea0fe8d..f91d0af858d 100644
--- a/lisp/net/eudcb-bbdb.el
+++ b/lisp/net/eudcb-bbdb.el
@@ -47,10 +47,13 @@
BBDB < 3 used `net'; BBDB >= 3 uses `mail'."
;; This just-in-time translation permits upgrading from BBDB 2 to
;; BBDB 3 without restarting Emacs.
- (if (and (eq field-symbol 'net)
- (eudc--using-bbdb-3-or-newer-p))
- 'mail
- field-symbol))
+ (cond ((and (eq field-symbol 'net)
+ (eudc--using-bbdb-3-or-newer-p))
+ 'mail)
+ ((and (eq field-symbol 'company)
+ (eudc--using-bbdb-3-or-newer-p))
+ 'organization)
+ (t field-symbol)))
(defvar eudc-bbdb-attributes-translation-alist
'((name . lastname)
@@ -124,18 +127,31 @@ BBDB < 3 used `net'; BBDB >= 3 uses `mail'."
(declare-function bbdb-record-addresses "ext:bbdb" t) ; via bbdb-defstruct
(declare-function bbdb-records "ext:bbdb"
(&optional dont-check-disk already-in-db-buffer))
+(declare-function bbdb-record-notes "ext:bbdb" t) ; via bbdb-defstruct
+
+;; External, BBDB >= 3.
+(declare-function bbdb-phone-label "ext:bbdb" t) ; via bbdb-defstruct
+(declare-function bbdb-record-phone "ext:bbdb" t) ; via bbdb-defstruct
+(declare-function bbdb-record-address "ext:bbdb" t) ; via bbdb-defstruct
+(declare-function bbdb-record-xfield "ext:bbdb" t) ; via bbdb-defstruct
(defun eudc-bbdb-extract-phones (record)
(require 'bbdb)
(mapcar (function
(lambda (phone)
(if eudc-bbdb-use-locations-as-attribute-names
- (cons (intern (bbdb-phone-location phone))
+ (cons (intern (if (eudc--using-bbdb-3-or-newer-p)
+ (bbdb-phone-label phone)
+ (bbdb-phone-location phone)))
(bbdb-phone-string phone))
(cons 'phones (format "%s: %s"
- (bbdb-phone-location phone)
+ (if (eudc--using-bbdb-3-or-newer-p)
+ (bbdb-phone-label phone)
+ (bbdb-phone-location phone))
(bbdb-phone-string phone))))))
- (bbdb-record-phones record)))
+ (if (eudc--using-bbdb-3-or-newer-p)
+ (bbdb-record-phone record)
+ (bbdb-record-phones record))))
(defun eudc-bbdb-extract-addresses (record)
(require 'bbdb)
@@ -157,7 +173,9 @@ BBDB < 3 used `net'; BBDB >= 3 uses `mail'."
(cons (intern (bbdb-address-location address)) val)
(cons 'addresses (concat (bbdb-address-location address)
"\n" val))))
- (bbdb-record-addresses record))))
+ (if (eudc--using-bbdb-3-or-newer-p)
+ (bbdb-record-address record)
+ (bbdb-record-addresses record)))))
(defun eudc-bbdb-format-record-as-result (record)
"Format the BBDB RECORD as a EUDC query result record.
@@ -176,7 +194,11 @@ The record is filtered according to `eudc-bbdb-current-return-attributes'"
(setq val (eudc-bbdb-extract-phones record)))
((eq attr 'addresses)
(setq val (eudc-bbdb-extract-addresses record)))
- ((memq attr '(firstname lastname aka company net notes))
+ ((eq attr 'notes)
+ (if (eudc--using-bbdb-3-or-newer-p)
+ (setq val (bbdb-record-xfield record 'notes))
+ (setq val (bbdb-record-notes record))))
+ ((memq attr '(firstname lastname aka company net))
(setq val (eval
(list (intern
(concat "bbdb-record-"
diff --git a/lisp/net/eudcb-mab.el b/lisp/net/eudcb-mab.el
index dbee16e1e22..0202b173bb5 100644
--- a/lisp/net/eudcb-mab.el
+++ b/lisp/net/eudcb-mab.el
@@ -53,15 +53,15 @@ RETURN-ATTRS is a list of attributes to return, defaulting to
(let ((fmt-string "%ln:%fn:%p:%e")
(mab-buffer (get-buffer-create " *mab contacts*"))
- (modified (nth 5 (file-attributes eudc-contacts-file)))
+ (modified (file-attribute-modification-time
+ (file-attributes eudc-contacts-file)))
result)
(with-current-buffer mab-buffer
(make-local-variable 'eudc-buffer-time)
(goto-char (point-min))
(when (or (eobp) (time-less-p eudc-buffer-time modified))
(erase-buffer)
- (call-process (executable-find "contacts") nil t nil
- "-H" "-l" "-f" fmt-string)
+ (call-process "contacts" nil t nil "-H" "-l" "-f" fmt-string)
(setq eudc-buffer-time modified))
(goto-char (point-min))
(while (not (eobp))
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index 1cc4557ce1a..3e9334532c6 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -186,17 +186,17 @@ See also `eww-form-checkbox-selected-symbol'."
:group 'eww)
(defface eww-form-text
- '((t (:background "#505050"
- :foreground "white"
- :box (:line-width 1))))
+ '((t :background "#505050"
+ :foreground "white"
+ :box (:line-width 1)))
"Face for eww text inputs."
:version "24.4"
:group 'eww)
(defface eww-form-textarea
- '((t (:background "#C0C0C0"
- :foreground "black"
- :box (:line-width 1))))
+ '((t :background "#C0C0C0"
+ :foreground "black"
+ :box (:line-width 1)))
"Face for eww textarea inputs."
:version "24.4"
:group 'eww)
@@ -218,11 +218,17 @@ See also `eww-form-checkbox-selected-symbol'."
(defvar eww-data nil)
(defvar eww-history nil)
(defvar eww-history-position 0)
+(defvar eww-prompt-history nil)
(defvar eww-local-regex "localhost"
"When this regex is found in the URL, it's not a keyword but an address.")
(defvar eww-link-keymap
+ (let ((map (copy-keymap shr-map)))
+ (define-key map "\r" 'eww-follow-link)
+ map))
+
+(defvar eww-image-link-keymap
(let ((map (copy-keymap shr-image-map)))
(define-key map "\r" 'eww-follow-link)
map))
@@ -241,21 +247,29 @@ This list can be customized via `eww-suggest-uris'."
(nreverse uris)))
;;;###autoload
-(defun eww (url)
+(defun eww (url &optional arg)
"Fetch URL and render the page.
If the input doesn't look like an URL or a domain name, the
-word(s) will be searched for via `eww-search-prefix'."
+word(s) will be searched for via `eww-search-prefix'.
+
+If called with a prefix ARG, use a new buffer instead of reusing
+the default EWW buffer."
(interactive
(let* ((uris (eww-suggested-uris))
(prompt (concat "Enter URL or keywords"
(if uris (format " (default %s)" (car uris)) "")
": ")))
- (list (read-string prompt nil nil uris))))
+ (list (read-string prompt nil 'eww-prompt-history uris)
+ (prefix-numeric-value current-prefix-arg))))
(setq url (eww--dwim-expand-url url))
(pop-to-buffer-same-window
- (if (eq major-mode 'eww-mode)
- (current-buffer)
- (get-buffer-create "*eww*")))
+ (cond
+ ((eq arg 4)
+ (generate-new-buffer "*eww*"))
+ ((eq major-mode 'eww-mode)
+ (current-buffer))
+ (t
+ (get-buffer-create "*eww*"))))
(eww-setup-buffer)
;; Check whether the domain only uses "Highly Restricted" Unicode
;; IDNA characters. If not, transform to punycode to indicate that
@@ -263,8 +277,13 @@ word(s) will be searched for via `eww-search-prefix'."
(let ((parsed (url-generic-parse-url url)))
(when (url-host parsed)
(unless (puny-highly-restrictive-domain-p (url-host parsed))
- (setf (url-host parsed) (puny-encode-domain (url-host parsed)))
- (setq url (url-recreate-url parsed)))))
+ (setf (url-host parsed) (puny-encode-domain (url-host parsed)))))
+ ;; When the URL is on the form "http://a/../../../g", chop off all
+ ;; the leading "/.."s.
+ (when (url-filename parsed)
+ (while (string-match "\\`/[.][.]/" (url-filename parsed))
+ (setf (url-filename parsed) (substring (url-filename parsed) 3))))
+ (setq url (url-recreate-url parsed)))
(plist-put eww-data :url url)
(plist-put eww-data :title "")
(eww-update-header-line-format)
@@ -272,7 +291,7 @@ word(s) will be searched for via `eww-search-prefix'."
(insert (format "Loading %s..." url))
(goto-char (point-min)))
(url-retrieve url 'eww-render
- (list url nil (current-buffer))))
+ (list url nil (current-buffer))))
(defun eww--dwim-expand-url (url)
(setq url (string-trim url))
@@ -349,9 +368,6 @@ Currently this means either text/html or application/xhtml+xml."
"application/xhtml+xml")))
(defun eww-render (status url &optional point buffer encode)
- (let ((redirect (plist-get status :redirect)))
- (when redirect
- (setq url redirect)))
(let* ((headers (eww-parse-headers))
(content-type
(mail-header-parse-content-type
@@ -364,12 +380,19 @@ Currently this means either text/html or application/xhtml+xml."
(eww-detect-charset (eww-html-p (car content-type)))
"utf-8"))))
(data-buffer (current-buffer))
+ (shr-target-id (url-target (url-generic-parse-url url)))
last-coding-system-used)
+ (let ((redirect (plist-get status :redirect)))
+ (when redirect
+ (setq url redirect)))
(with-current-buffer buffer
;; Save the https peer status.
(plist-put eww-data :peer (plist-get status :peer))
;; Make buffer listings more informative.
- (setq list-buffers-directory url))
+ (setq list-buffers-directory url)
+ ;; Let the URL library have a handle to the current URL for
+ ;; referer purposes.
+ (setq url-current-lastloc (url-generic-parse-url url)))
(unwind-protect
(progn
(cond
@@ -447,10 +470,10 @@ Currently this means either text/html or application/xhtml+xml."
(condition-case nil
(decode-coding-region (point) (point-max) encode)
(coding-system-error nil))
- (save-excursion
- ;; Remove CRLF before parsing.
- (while (re-search-forward "\r$" nil t)
- (replace-match "" t t)))
+ (save-excursion
+ ;; Remove CRLF and replace NUL with &#0; before parsing.
+ (while (re-search-forward "\\(\r$\\)\\|\0" nil t)
+ (replace-match (if (match-beginning 1) "" "&#0;") t t)))
(libxml-parse-html-region (point) (point-max))))))
(source (and (null document)
(buffer-substring (point) (point-max)))))
@@ -460,7 +483,6 @@ Currently this means either text/html or application/xhtml+xml."
(plist-put eww-data :dom document)
(let ((inhibit-read-only t)
(inhibit-modification-hooks t)
- (shr-target-id (url-target (url-generic-parse-url url)))
(shr-external-rendering-functions
(append
shr-external-rendering-functions
@@ -547,7 +569,11 @@ Currently this means either text/html or application/xhtml+xml."
(eww-handle-link dom)
(let ((start (point)))
(shr-tag-a dom)
- (put-text-property start (point) 'keymap eww-link-keymap)))
+ (put-text-property start (point)
+ 'keymap
+ (if (mm-images-in-region-p start (point))
+ eww-image-link-keymap
+ eww-link-keymap))))
(defun eww-update-header-line-format ()
(setq header-line-format
@@ -731,7 +757,10 @@ the like."
most-negative-fixnum)
(or (dom-attr result :eww-readability-score)
most-negative-fixnum))
- (setq result highest)))
+ ;; We set a lower bound to how long we accept that the
+ ;; readable portion of the page is going to be.
+ (when (> (length (split-string (dom-texts highest))) 100)
+ (setq result highest))))
result))
(defvar eww-mode-map
@@ -1236,14 +1265,8 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
:eww-form eww-form))
(options nil)
(start (point))
- (max 0)
- opelem)
- (if (eq (dom-tag dom) 'optgroup)
- (dolist (groupelem (dom-children dom))
- (unless (dom-attr groupelem 'disabled)
- (setq opelem (append opelem (list groupelem)))))
- (setq opelem (list dom)))
- (dolist (elem opelem)
+ (max 0))
+ (dolist (elem (dom-non-text-children dom))
(when (eq (dom-tag elem) 'option)
(when (dom-attr elem 'selected)
(nconc menu (list :value (dom-attr elem 'value))))
@@ -1489,7 +1512,8 @@ If EXTERNAL is double prefix, browse in new buffer."
((string-match "^mailto:" url)
(browse-url-mail url))
((and (consp external) (<= (car external) 4))
- (funcall shr-external-browser url))
+ (funcall shr-external-browser url)
+ (shr--blink-link))
;; This is a #target url in the same page as the current one.
((and (url-target (url-generic-parse-url url))
(eww-same-page-p url (plist-get eww-data :url)))
@@ -1515,10 +1539,12 @@ Differences in #targets are ignored."
(kill-new (plist-get eww-data :url)))
(defun eww-download ()
- "Download URL under point to `eww-download-directory'."
+ "Download URL to `eww-download-directory'.
+Use link at point if there is one, else the current page's URL."
(interactive)
(access-file eww-download-directory "Download failed")
- (let ((url (get-text-property (point) 'shr-url)))
+ (let ((url (or (get-text-property (point) 'shr-url)
+ (eww-current-url))))
(if (not url)
(message "No URL under point")
(url-retrieve url 'eww-download-callback (list url)))))
@@ -1651,7 +1677,7 @@ If CHARSET is nil then use UTF-8."
(defun eww-read-bookmarks ()
(let ((file (expand-file-name "eww-bookmarks" eww-bookmarks-directory)))
(setq eww-bookmarks
- (unless (zerop (or (nth 7 (file-attributes file)) 0))
+ (unless (zerop (or (file-attribute-size (file-attributes file)) 0))
(with-temp-buffer
(insert-file-contents file)
(read (current-buffer)))))))
@@ -1797,13 +1823,9 @@ If CHARSET is nil then use UTF-8."
(defun eww-save-history ()
(plist-put eww-data :point (point))
(plist-put eww-data :text (buffer-string))
- (push eww-data eww-history)
- (setq eww-data (list :title ""))
- ;; Don't let the history grow infinitely. We store quite a lot of
- ;; data per page.
- (when-let* ((tail (and eww-history-limit
- (nthcdr eww-history-limit eww-history))))
- (setcdr tail nil)))
+ (let ((history-delete-duplicates nil))
+ (add-to-history 'eww-history eww-data eww-history-limit t))
+ (setq eww-data (list :title "")))
(defvar eww-current-buffer)
diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el
index 0dcffbb9b14..61480f35877 100644
--- a/lisp/net/gnutls.el
+++ b/lisp/net/gnutls.el
@@ -36,6 +36,10 @@
;;; Code:
(require 'cl-lib)
+(require 'puny)
+
+(declare-function network-stream-certificate "network-stream"
+ (host service parameters))
(defgroup gnutls nil
"Emacs interface to the GnuTLS library."
@@ -69,9 +73,9 @@ If the value is a list, it should have the form
((HOST-REGEX FLAGS...) (HOST-REGEX FLAGS...) ...)
where each HOST-REGEX is a regular expression to be matched
-against the hostname, and FLAGS is either t or a list of
-one or more verification flags. The supported flags and the
-corresponding conditions to be tested are:
+against the hostname, on a first-match basis, and FLAGS is either
+t or a list of one or more verification flags. The supported
+flags and the corresponding conditions to be tested are:
:trustfiles -- certificate must be issued by a trusted authority.
:hostname -- hostname must match presented certificate's host name.
@@ -137,7 +141,7 @@ node `(emacs) Network Security'."
(integer :tag "Number of bits" 512))
:group 'gnutls)
-(defun open-gnutls-stream (name buffer host service &optional nowait)
+(defun open-gnutls-stream (name buffer host service &optional parameters)
"Open a SSL/TLS connection for a service to a host.
Returns a subprocess-object to represent the connection.
Input and output work as for subprocesses; `delete-process' closes it.
@@ -148,12 +152,15 @@ BUFFER is the buffer (or `buffer-name') to associate with the process.
a filter function to handle the output.
BUFFER may be also nil, meaning that this process is not associated
with any buffer
-Third arg is name of the host to connect to, or its IP address.
-Fourth arg SERVICE is name of the service desired, or an integer
+Third arg HOST is the name of the host to connect to, or its IP address.
+Fourth arg SERVICE is the name of the service desired, or an integer
specifying a port number to connect to.
-Fifth arg NOWAIT (which is optional) means that the socket should
-be opened asynchronously. The connection process will be
-returned to the caller before TLS negotiation has happened.
+Fifth arg PARAMETERS is an optional list of keyword/value pairs.
+Only :client-certificate and :nowait keywords are recognized, and
+have the same meaning as for `open-network-stream'.
+For historical reasons PARAMETERS can also be a symbol, which is
+interpreted the same as passing a list containing :nowait and the
+value of that symbol.
Usage example:
@@ -167,20 +174,34 @@ This is a very simple wrapper around `gnutls-negotiate'. See its
documentation for the specific parameters you can use to open a
GnuTLS connection, including specifying the credential type,
trust and key files, and priority string."
- (let ((process (open-network-stream
- name buffer host service
- :nowait nowait
- :tls-parameters
- (and nowait
- (cons 'gnutls-x509pki
- (gnutls-boot-parameters
- :type 'gnutls-x509pki
- :hostname host))))))
+ (let* ((parameters
+ (cond ((symbolp parameters)
+ (list :nowait parameters))
+ ((not (cl-evenp (length parameters)))
+ (error "Malformed keyword list"))
+ ((consp parameters)
+ parameters)
+ (t
+ (error "Unknown parameter type"))))
+ (cert (network-stream-certificate host service parameters))
+ (keylist (and cert (list cert)))
+ (nowait (plist-get parameters :nowait))
+ (process (open-network-stream
+ name buffer host service
+ :nowait nowait
+ :tls-parameters
+ (and nowait
+ (cons 'gnutls-x509pki
+ (gnutls-boot-parameters
+ :type 'gnutls-x509pki
+ :keylist keylist
+ :hostname (puny-encode-domain host)))))))
(if nowait
process
(gnutls-negotiate :process process
:type 'gnutls-x509pki
- :hostname host))))
+ :keylist keylist
+ :hostname (puny-encode-domain host)))))
(define-error 'gnutls-error "GnuTLS error")
@@ -303,13 +324,9 @@ defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT."
t)
;; if a list, look for hostname matches
((listp gnutls-verify-error)
- (apply 'append
- (mapcar
- (lambda (check)
- (when (string-match (nth 0 check)
- hostname)
- (nth 1 check)))
- gnutls-verify-error)))
+ (cadr (cl-find-if #'(lambda (x)
+ (string-match (car x) hostname))
+ gnutls-verify-error)))
;; else it's nil
(t nil))))
(min-prime-bits (or min-prime-bits gnutls-min-prime-bits)))
diff --git a/lisp/net/goto-addr.el b/lisp/net/goto-addr.el
index 45627d9b103..c25d7873918 100644
--- a/lisp/net/goto-addr.el
+++ b/lisp/net/goto-addr.el
@@ -98,7 +98,7 @@ A value of t means there is no limit--fontify regardless of the size."
(defvar goto-address-mail-regexp
;; Actually pretty much any char could appear in the username part. -stef
- "[-a-zA-Z0-9=._+]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+"
+ "[-a-zA-Z0-9=._+]+@\\([-a-zA-Z0-9_]+\\.\\)+[a-zA-Z0-9]+"
"A regular expression probably matching an e-mail address.")
(defvar goto-address-url-regexp
@@ -221,10 +221,6 @@ and `goto-address-fontify-p'."
;; snarfed from browse-url.el
;;;###autoload
-(define-obsolete-function-alias
- 'goto-address-at-mouse 'goto-address-at-point "22.1")
-
-;;;###autoload
(defun goto-address-at-point (&optional event)
"Send to the e-mail address or load the URL at point.
Send mail to address at point. See documentation for
@@ -250,7 +246,7 @@ there, then load the URL at or before point."
"Find e-mail address around or before point.
Then search backwards to beginning of line for the start of an e-mail
address. If no e-mail address found, return nil."
- (re-search-backward "[^-_A-z0-9.@]" (line-beginning-position) 'lim)
+ (re-search-backward "[^-_A-Za-z0-9.@]" (line-beginning-position) 'lim)
(if (or (looking-at goto-address-mail-regexp) ; already at start
(and (re-search-forward goto-address-mail-regexp
(line-end-position) 'lim)
@@ -274,10 +270,7 @@ Also fontifies the buffer appropriately (see `goto-address-fontify-p' and
;;;###autoload
(define-minor-mode goto-address-mode
- "Minor mode to buttonize URLs and e-mail addresses in the current buffer.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil."
+ "Minor mode to buttonize URLs and e-mail addresses in the current buffer."
nil
""
nil
diff --git a/lisp/net/hmac-def.el b/lisp/net/hmac-def.el
index c471f691dc3..44db0bbbb24 100644
--- a/lisp/net/hmac-def.el
+++ b/lisp/net/hmac-def.el
@@ -73,7 +73,7 @@ If BIT is non-nil, truncate output to specified bits."
,(if (and bit (< (/ bit 8) L))
`(substring key-xor-opad 0 ,(/ bit 8))
;; return a copy of `key-xor-opad'.
- `(concat key-xor-opad)))
+ '(concat key-xor-opad)))
;; cleanup.
(fillarray key-xor-ipad 0)
(fillarray key-xor-opad 0)))))
diff --git a/lisp/net/imap.el b/lisp/net/imap.el
index dedf5f794a4..9f43c57ffd3 100644
--- a/lisp/net/imap.el
+++ b/lisp/net/imap.el
@@ -1,4 +1,4 @@
-;;; imap.el --- imap library
+;;; imap.el --- imap library -*- lexical-binding:t -*-
;; Copyright (C) 1998-2019 Free Software Foundation, Inc.
@@ -135,20 +135,16 @@
;;; Code:
-(eval-when-compile (require 'cl))
-(eval-and-compile
- ;; For Emacs <22.2 and XEmacs.
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest _r)))
- (autoload 'sasl-find-mechanism "sasl")
- (autoload 'digest-md5-parse-digest-challenge "digest-md5")
- (autoload 'digest-md5-digest-response "digest-md5")
- (autoload 'digest-md5-digest-uri "digest-md5")
- (autoload 'digest-md5-challenge "digest-md5")
- (autoload 'rfc2104-hash "rfc2104")
- (autoload 'utf7-encode "utf7")
- (autoload 'utf7-decode "utf7")
- (autoload 'format-spec "format-spec")
- (autoload 'format-spec-make "format-spec"))
+(eval-when-compile (require 'cl-lib))
+(require 'format-spec)
+(require 'utf7)
+(require 'rfc2104)
+;; Hmm... digest-md5 is not part of Emacs.
+;; FIXME: Should/can we use sasl-digest.el instead?
+(declare-function digest-md5-parse-digest-challenge "ext:digest-md5")
+(declare-function digest-md5-digest-response "ext:digest-md5")
+(declare-function digest-md5-digest-uri "ext:digest-md5")
+(declare-function digest-md5-challenge "ext:digest-md5")
;; User variables.
@@ -1700,18 +1696,6 @@ MAILBOX specifies a mailbox on the server in BUFFER."
(concat "UID STORE " articles
" +FLAGS" (if silent ".SILENT") " (" flags ")"))))))
-;; Cf. http://thread.gmane.org/gmane.emacs.gnus.general/65317/focus=65343
-;; Signal an error if we'd get an integer overflow.
-;;
-;; FIXME: Identify relevant calls to `string-to-number' and replace them with
-;; `imap-string-to-integer'.
-(defun imap-string-to-integer (string &optional base)
- (let ((number (string-to-number string base)))
- (if (> number most-positive-fixnum)
- (error
- (format "String %s cannot be converted to a Lisp integer" number))
- number)))
-
(defun imap-fetch-safe (uids props &optional receive nouidfetch buffer)
"Like `imap-fetch', but DTRT with Exchange 2007 bug.
However, UIDS here is a cons, where the car is the canonical form
@@ -1900,9 +1884,7 @@ on failure."
(setq cmdstr nil)
(if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
(setq command nil) ;; abort command if no cont-req
- (let ((process imap-process)
- (stream imap-stream)
- (eol imap-client-eol))
+ (let ((process imap-process))
(with-current-buffer cmd
(imap-log cmd)
(process-send-region process (point-min)
@@ -1936,18 +1918,14 @@ on failure."
(unless (< len 10)
(setq imap-have-messaged t)
(message "imap read: %dk" len))
- (accept-process-output imap-process
- (truncate imap-read-timeout)
- (truncate (* (- imap-read-timeout
- (truncate imap-read-timeout))
- 1000)))))
+ (accept-process-output imap-process imap-read-timeout)))
;; A process can die _before_ we have processed everything it
;; has to say. Moreover, this can happen in between the call to
;; accept-process-output and the call to process-status in an
;; iteration of the loop above.
(when (and (null imap-continuation)
(< imap-reached-tag tag))
- (accept-process-output imap-process 0 0))
+ (accept-process-output imap-process 0))
(when imap-have-messaged
(message ""))
(and (memq (process-status imap-process) '(open run))
@@ -1956,7 +1934,7 @@ on failure."
'INCOMPLETE
'OK))))))
-(defun imap-sentinel (process string)
+(defun imap-sentinel (process _string)
(delete-process process))
(defun imap-find-next-line ()
@@ -2145,7 +2123,7 @@ Return nil if no complete line has arrived."
(imap-forward)
(nreverse addresses)))
;; With assert, the code might not be eval'd.
- ;; (assert (imap-parse-nil) t "In imap-parse-address-list")
+ ;; (cl-assert (imap-parse-nil) t "In imap-parse-address-list")
(imap-parse-nil)))
;; mailbox = "INBOX" / astring
@@ -2218,72 +2196,72 @@ Return nil if no complete line has arrived."
(defun imap-parse-response ()
"Parse an IMAP command response."
(let (token)
- (case (setq token (read (current-buffer)))
- (+ (setq imap-continuation
- (or (buffer-substring (min (point-max) (1+ (point)))
- (point-max))
- t)))
- (* (case (prog1 (setq token (read (current-buffer)))
- (imap-forward))
- (OK (imap-parse-resp-text))
- (NO (imap-parse-resp-text))
- (BAD (imap-parse-resp-text))
- (BYE (imap-parse-resp-text))
- (FLAGS (imap-mailbox-put 'flags (imap-parse-flag-list)))
- (LIST (imap-parse-data-list 'list))
- (LSUB (imap-parse-data-list 'lsub))
- (SEARCH (imap-mailbox-put
- 'search
- (read (concat "(" (buffer-substring (point) (point-max)) ")"))))
- (STATUS (imap-parse-status))
- (CAPABILITY (setq imap-capability
+ (pcase (setq token (read (current-buffer)))
+ ('+ (setq imap-continuation
+ (or (buffer-substring (min (point-max) (1+ (point)))
+ (point-max))
+ t)))
+ ('* (pcase (prog1 (setq token (read (current-buffer)))
+ (imap-forward))
+ ('OK (imap-parse-resp-text))
+ ('NO (imap-parse-resp-text))
+ ('BAD (imap-parse-resp-text))
+ ('BYE (imap-parse-resp-text))
+ ('FLAGS (imap-mailbox-put 'flags (imap-parse-flag-list)))
+ ('LIST (imap-parse-data-list 'list))
+ ('LSUB (imap-parse-data-list 'lsub))
+ ('SEARCH (imap-mailbox-put
+ 'search
+ (read (concat "(" (buffer-substring (point) (point-max)) ")"))))
+ ('STATUS (imap-parse-status))
+ ('CAPABILITY (setq imap-capability
(read (concat "(" (upcase (buffer-substring
(point) (point-max)))
")"))))
- (ID (setq imap-id (read (buffer-substring (point)
- (point-max)))))
- (ACL (imap-parse-acl))
- (t (case (prog1 (read (current-buffer))
- (imap-forward))
- (EXISTS (imap-mailbox-put 'exists token))
- (RECENT (imap-mailbox-put 'recent token))
- (EXPUNGE t)
- (FETCH (imap-parse-fetch token))
- (t (message "Garbage: %s" (buffer-string)))))))
- (t (let (status)
+ ('ID (setq imap-id (read (buffer-substring (point)
+ (point-max)))))
+ ('ACL (imap-parse-acl))
+ (_ (pcase (prog1 (read (current-buffer))
+ (imap-forward))
+ ('EXISTS (imap-mailbox-put 'exists token))
+ ('RECENT (imap-mailbox-put 'recent token))
+ ('EXPUNGE t)
+ ('FETCH (imap-parse-fetch))
+ (_ (message "Garbage: %s" (buffer-string)))))))
+ (_ (let (status)
(if (not (integerp token))
(message "Garbage: %s" (buffer-string))
- (case (prog1 (setq status (read (current-buffer)))
- (imap-forward))
- (OK (progn
- (setq imap-reached-tag (max imap-reached-tag token))
- (imap-parse-resp-text)))
- (NO (progn
- (setq imap-reached-tag (max imap-reached-tag token))
- (save-excursion
- (imap-parse-resp-text))
- (let (code text)
- (when (eq (char-after) ?\[)
- (setq code (buffer-substring (point)
- (search-forward "]")))
- (imap-forward))
- (setq text (buffer-substring (point) (point-max)))
- (push (list token status code text)
- imap-failed-tags))))
- (BAD (progn
- (setq imap-reached-tag (max imap-reached-tag token))
- (save-excursion
- (imap-parse-resp-text))
- (let (code text)
- (when (eq (char-after) ?\[)
- (setq code (buffer-substring (point)
- (search-forward "]")))
- (imap-forward))
- (setq text (buffer-substring (point) (point-max)))
- (push (list token status code text) imap-failed-tags)
- (error "Internal error, tag %s status %s code %s text %s"
- token status code text))))
- (t (message "Garbage: %s" (buffer-string))))
+ (pcase (prog1 (setq status (read (current-buffer)))
+ (imap-forward))
+ ('OK (progn
+ (setq imap-reached-tag (max imap-reached-tag token))
+ (imap-parse-resp-text)))
+ ('NO (progn
+ (setq imap-reached-tag (max imap-reached-tag token))
+ (save-excursion
+ (imap-parse-resp-text))
+ (let (code text)
+ (when (eq (char-after) ?\[)
+ (setq code (buffer-substring (point)
+ (search-forward "]")))
+ (imap-forward))
+ (setq text (buffer-substring (point) (point-max)))
+ (push (list token status code text)
+ imap-failed-tags))))
+ ('BAD (progn
+ (setq imap-reached-tag (max imap-reached-tag token))
+ (save-excursion
+ (imap-parse-resp-text))
+ (let (code text)
+ (when (eq (char-after) ?\[)
+ (setq code (buffer-substring (point)
+ (search-forward "]")))
+ (imap-forward))
+ (setq text (buffer-substring (point) (point-max)))
+ (push (list token status code text) imap-failed-tags)
+ (error "Internal error, tag %s status %s code %s text %s"
+ token status code text))))
+ (_ (message "Garbage: %s" (buffer-string))))
(when (assq token imap-callbacks)
(funcall (cdr (assq token imap-callbacks)) token status)
(setq imap-callbacks
@@ -2459,7 +2437,7 @@ Return nil if no complete line has arrived."
(search-forward "]" nil t))
section)))
-(defun imap-parse-fetch (response)
+(defun imap-parse-fetch ()
(when (eq (char-after) ?\()
(let (uid flags envelope internaldate rfc822 rfc822header rfc822text
rfc822size body bodydetail bodystructure flags-empty)
@@ -2593,7 +2571,7 @@ Return nil if no complete line has arrived."
(defun imap-parse-flag-list ()
(let (flag-list start)
- (assert (eq (char-after) ?\() nil "In imap-parse-flag-list 1")
+ (cl-assert (eq (char-after) ?\() nil "In imap-parse-flag-list 1")
(while (and (not (eq (char-after) ?\)))
(setq start (progn
(imap-forward)
@@ -2602,7 +2580,7 @@ Return nil if no complete line has arrived."
(point)))
(> (skip-chars-forward "^ )" (point-at-eol)) 0))
(push (buffer-substring start (point)) flag-list))
- (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list 2")
+ (cl-assert (eq (char-after) ?\)) nil "In imap-parse-flag-list 2")
(imap-forward)
(nreverse flag-list)))
@@ -2687,7 +2665,7 @@ Return nil if no complete line has arrived."
(while (eq (char-after) ?\ )
(imap-forward)
(push (imap-parse-body-extension) b-e))
- (assert (eq (char-after) ?\)) nil "In imap-parse-body-extension")
+ (cl-assert (eq (char-after) ?\)) nil "In imap-parse-body-extension")
(imap-forward)
(nreverse b-e))
(or (imap-parse-number)
@@ -2716,7 +2694,7 @@ Return nil if no complete line has arrived."
(push (imap-parse-string-list) dsp)
(imap-forward))
;; With assert, the code might not be eval'd.
- ;; (assert (imap-parse-nil) t "In imap-parse-body-ext")
+ ;; (cl-assert (imap-parse-nil) t "In imap-parse-body-ext")
(imap-parse-nil))
(push (nreverse dsp) ext))
(when (eq (char-after) ?\ ) ;; body-fld-lang
@@ -2813,7 +2791,7 @@ Return nil if no complete line has arrived."
(push (and (imap-parse-nil) nil) body))
(setq body
(append (imap-parse-body-ext) body))) ;; body-ext-...
- (assert (eq (char-after) ?\)) nil "In imap-parse-body")
+ (cl-assert (eq (char-after) ?\)) nil "In imap-parse-body")
(imap-forward)
(nreverse body))
@@ -2879,7 +2857,7 @@ Return nil if no complete line has arrived."
(push (imap-parse-nstring) body) ;; body-fld-md5
(setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part..
- (assert (eq (char-after) ?\)) nil "In imap-parse-body 2")
+ (cl-assert (eq (char-after) ?\)) nil "In imap-parse-body 2")
(imap-forward)
(nreverse body)))))
diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el
index 6e242d77d41..75fc7d62211 100644
--- a/lisp/net/ldap.el
+++ b/lisp/net/ldap.el
@@ -646,13 +646,9 @@ an alist of attribute/value pairs."
(not (equal "" sizelimit)))
(setq arglist (nconc arglist (list (format "-z%s" sizelimit)))))
(if passwd
- ;; Work around Bug#33154, see also Bug#33050. Leaving
- ;; process-connection-type at its default (typically t)
- ;; would probably be fine too, however this is the minimal
- ;; change on the release branch that fixes ldap.el on Darwin
- ;; and leaves other operating systems unchanged.
- (let* ((process-connection-type (eq system-type 'darwin))
- (proc-args (append arglist ldap-ldapsearch-args
+ ;; Leave process-connection-type at its default value. See
+ ;; discussion in Bug#33050.
+ (let* ((proc-args (append arglist ldap-ldapsearch-args
filter))
(proc (apply #'start-process "ldapsearch" buf
ldap-ldapsearch-prog
diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el
index 78400e1dbba..eb4312ef3b5 100644
--- a/lisp/net/mailcap.el
+++ b/lisp/net/mailcap.el
@@ -36,6 +36,14 @@
:version "21.1"
:group 'mime)
+(defcustom mailcap-prefer-mailcap-viewers t
+ "If non-nil, prefer viewers specified in ~/.mailcap.
+If nil, the most specific viewer will be chosen, even if there is
+a general override in ~/.mailcap. For instance, if /etc/mailcap
+has an entry for \"image/gif\", that one will be chosen even if
+you have an entry for \"image/*\" in your ~/.mailcap file."
+ :type 'boolean)
+
(defvar mailcap-parse-args-syntax-table
(let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
(modify-syntax-entry ?' "\"" table)
@@ -419,20 +427,32 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus
((memq system-type mailcap-poor-system-types)
(setq path '("~/.mailcap" "~/mail.cap" "~/etc/mail.cap")))
(t (setq path
- ;; This is per RFC 1524, specifically
- ;; with /usr before /usr/local.
- '("~/.mailcap" "/etc/mailcap" "/usr/etc/mailcap"
- "/usr/local/etc/mailcap"))))
- (dolist (fname (reverse
- (if (stringp path)
- (split-string path path-separator t)
- path)))
- (when (and (file-readable-p fname) (file-regular-p fname))
- (mailcap-parse-mailcap fname)))
+ ;; This is per RFC 1524, specifically with /usr before
+ ;; /usr/local.
+ '("~/.mailcap"
+ ("/etc/mailcap" 'after)
+ ("/usr/etc/mailcap" 'after)
+ ("/usr/local/etc/mailcap" 'after)))))
+ ;; We read the entries from ~/.mailcap before the built-in values,
+ ;; but place the rest of then afterwards as fallback values.
+ (dolist (spec (reverse
+ (if (stringp path)
+ (split-string path path-separator t)
+ path)))
+ (let ((afterp (and (consp spec)
+ (cadr spec)))
+ (file-name (if (stringp spec)
+ spec
+ (car spec))))
+ (when (and (file-readable-p file-name)
+ (file-regular-p file-name))
+ (mailcap-parse-mailcap file-name afterp))))
(setq mailcap-parsed-p t)))
-(defun mailcap-parse-mailcap (fname)
- "Parse out the mailcap file specified by FNAME."
+(defun mailcap-parse-mailcap (fname &optional after)
+ "Parse out the mailcap file specified by FNAME.
+If AFTER, place the entries from the file after the ones that are
+already there."
(let (major ; The major mime type (image/audio/etc)
minor ; The minor mime type (gif, basic, etc)
save-pos ; Misc saved positions used in parsing
@@ -502,7 +522,7 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus
"*" minor))))
(mailcap-parse-mailcap-extras save-pos (point))))
(mailcap-mailcap-entry-passes-test info)
- (mailcap-add-mailcap-entry major minor info))
+ (mailcap-add-mailcap-entry major minor info after))
(beginning-of-line)))))
(defun mailcap-parse-mailcap-extras (st nd)
@@ -685,7 +705,7 @@ to supply to the test."
(push (list otest result) mailcap-viewer-test-cache)
result))))
-(defun mailcap-add-mailcap-entry (major minor info)
+(defun mailcap-add-mailcap-entry (major minor info &optional after)
(let ((old-major (assoc major mailcap-mime-data)))
(if (null old-major) ; New major area
(push (cons major (list (cons minor info))) mailcap-mime-data)
@@ -693,15 +713,23 @@ to supply to the test."
(cond
((or (null cur-minor) ; New minor area, or
(assq 'test info)) ; Has a test, insert at beginning
- (setcdr old-major (cons (cons minor info) (cdr old-major))))
+ (setcdr old-major
+ (if after ; Or after, if specified.
+ (nconc (cdr old-major)
+ (list (cons minor info)))
+ (cons (cons minor info) (cdr old-major)))))
((and (not (assq 'test info)) ; No test info, replace completely
(not (assq 'test cur-minor))
(equal (assq 'viewer info) ; Keep alternative viewer
(assq 'viewer cur-minor)))
- (setcdr cur-minor info))
+ (unless after
+ (setcdr cur-minor info)))
(t
- (setcdr old-major (cons (cons minor info) (cdr old-major))))))
- )))
+ (setcdr old-major
+ (if after
+ (nconc (cdr old-major) (list (cons minor info)))
+ (setcdr old-major
+ (cons (cons minor info) (cdr old-major)))))))))))
(defun mailcap-add (type viewer &optional test)
"Add VIEWER as a handler for TYPE.
@@ -784,18 +812,23 @@ If NO-DECODE is non-nil, don't decode STRING."
(setq passed (list viewer))
;; None found, so heuristically select some applicable viewer
;; from `mailcap-mime-data'.
+ (mailcap-parse-mailcaps)
(setq major (split-string (car ctl) "/"))
(setq minor (cadr major)
major (car major))
(when (setq major-info (cdr (assoc major mailcap-mime-data)))
(when (setq viewers (mailcap-possible-viewers major-info minor))
- (setq info (mapcar (lambda (a) (cons (symbol-name (car a))
- (cdr a)))
+ (setq info (mapcar (lambda (a)
+ (cons (symbol-name (car a)) (cdr a)))
(cdr ctl)))
(dolist (entry viewers)
(when (mailcap-viewer-passes-test entry info)
(push entry passed)))
- (setq passed (sort passed 'mailcap-viewer-lessp))
+ ;; The data is in "logical" order; entries from ~/.mailcap
+ ;; are first, so we don't need to do any sorting if the
+ ;; user wants ~/.mailcap to be preferred.
+ (unless mailcap-prefer-mailcap-viewers
+ (setq passed (sort passed 'mailcap-viewer-lessp)))
(setq viewer (car passed))))
(when (and (stringp (cdr (assq 'viewer viewer)))
passed)
@@ -1006,6 +1039,14 @@ If FORCE, re-parse even if already parsed."
(setq extn (concat "." extn)))
(cdr (assoc (downcase extn) mailcap-mime-extensions)))
+(defun mailcap-file-name-to-mime-type (file-name)
+ "Return the MIME content type based on the FILE-NAME's extension.
+For instance, \"foo.png\" will result in \"image/png\"."
+ (mailcap-extension-to-mime
+ (if (string-match "\\(\\.[^.]+\\)\\'" file-name)
+ (match-string 1 file-name)
+ "")))
+
(defun mailcap-mime-types ()
"Return a list of MIME media types."
(mailcap-parse-mimetypes)
diff --git a/lisp/net/net-utils.el b/lisp/net/net-utils.el
index fc39b91529a..e61d8897651 100644
--- a/lisp/net/net-utils.el
+++ b/lisp/net/net-utils.el
@@ -86,8 +86,6 @@ These options can be used to limit how many ICMP packets are emitted."
:group 'net-utils
:type '(repeat string))
-(define-obsolete-variable-alias 'ipconfig-program 'ifconfig-program "22.2")
-
(defcustom ifconfig-program
(cond ((eq system-type 'windows-nt) "ipconfig")
((executable-find "ifconfig") "ifconfig")
@@ -99,9 +97,6 @@ These options can be used to limit how many ICMP packets are emitted."
:group 'net-utils
:type 'string)
-(define-obsolete-variable-alias 'ipconfig-program-options
- 'ifconfig-program-options "22.2")
-
(defcustom ifconfig-program-options
(cond ((string-match "ipconfig\\'" ifconfig-program) '("/all"))
((string-match "ifconfig\\'" ifconfig-program) '("-a"))
diff --git a/lisp/net/netrc.el b/lisp/net/netrc.el
index e7309850266..93152f4f2c4 100644
--- a/lisp/net/netrc.el
+++ b/lisp/net/netrc.el
@@ -63,12 +63,14 @@
"port"))
alist elem result pair)
(if (and netrc-cache
- (equal (car netrc-cache) (nth 5 (file-attributes file))))
+ (equal (car netrc-cache) (file-attribute-modification-time
+ (file-attributes file))))
(insert (base64-decode-string (rot13-string (cdr netrc-cache))))
(insert-file-contents file)
(when (string-match "\\.gpg\\'" file)
;; Store the contents of the file heavily encrypted in memory.
- (setq netrc-cache (cons (nth 5 (file-attributes file))
+ (setq netrc-cache (cons (file-attribute-modification-time
+ (file-attributes file))
(rot13-string
(base64-encode-string
(buffer-string)))))))
diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el
index 1d247812d9c..2b3292b71ba 100644
--- a/lisp/net/network-stream.el
+++ b/lisp/net/network-stream.el
@@ -42,14 +42,21 @@
;;; Code:
-(require 'tls)
-(require 'starttls)
(require 'auth-source)
(require 'nsm)
(require 'puny)
+(declare-function starttls-available-p "starttls" ())
+(declare-function starttls-negotiate "starttls" (process))
+(declare-function starttls-open-stream "starttls" (name buffer host port))
+
(autoload 'gnutls-negotiate "gnutls")
(autoload 'open-gnutls-stream "gnutls")
+(defvar starttls-extra-arguments)
+(defvar starttls-extra-args)
+(defvar starttls-use-gnutls)
+(defvar starttls-gnutls-program)
+(defvar starttls-program)
;;;###autoload
(defun open-network-stream (name buffer host service &rest parameters)
@@ -190,7 +197,7 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
(car result))))))
(defun network-stream-certificate (host service parameters)
- (let ((spec (plist-get :client-certificate parameters)))
+ (let ((spec (plist-get parameters :client-certificate)))
(cond
((listp spec)
;; Either nil or a list with a key/certificate pair.
@@ -255,7 +262,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
(or (gnutls-available-p)
(and (or require-tls
(plist-get parameters :use-starttls-if-possible))
- (starttls-available-p))))
+ (require 'starttls)
+ (starttls-available-p))))
(not (eq (plist-get parameters :type) 'plain)))
;; If using external STARTTLS, drop this connection and start
;; anew with `starttls-open-stream'.
@@ -295,7 +303,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
(if (gnutls-available-p)
(let ((cert (network-stream-certificate host service parameters)))
(condition-case nil
- (gnutls-negotiate :process stream :hostname host
+ (gnutls-negotiate :process stream
+ :hostname (puny-encode-domain host)
:keylist (and cert (list cert)))
;; If we get a gnutls-specific error (for instance if
;; the certificate the server gives us is completely
@@ -335,7 +344,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
;; See `starttls-available-p'. If this predicate
;; changes to allow running under Windows, the error
;; message below should be amended.
- (if (memq system-type '(windows-nt ms-dos))
+ (if (or (memq system-type '(windows-nt ms-dos))
+ (not (featurep 'starttls)))
(concat "Emacs does not support TLS")
(concat "Emacs does not support TLS, and no external `"
(if starttls-use-gnutls
@@ -366,19 +376,22 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
(goto-char start)
(while (and (memq (process-status stream) '(open run))
(not (re-search-forward end-of-command nil t)))
- (accept-process-output stream 0 50)
+ (accept-process-output stream 0.05)
(goto-char start))
;; Return the data we got back, or nil if the process died.
(unless (= start (point))
(buffer-substring start (point)))))))
+(declare-function open-tls-stream "tls" (name buffer host port))
+
(defun network-stream-open-tls (name buffer host service parameters)
(with-current-buffer buffer
(let* ((start (point-max))
(stream
(if (gnutls-available-p)
(open-gnutls-stream name buffer host service
- (plist-get parameters :nowait))
+ parameters)
+ (require 'tls)
(open-tls-stream name buffer host service)))
(eoc (plist-get parameters :end-of-command)))
(if (plist-get parameters :nowait)
@@ -405,6 +418,9 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
(network-stream-command stream capability-command eo-capa)
'tls)))))))
+(declare-function format-spec "format-spec" (format spec))
+(declare-function format-spec-make "format-spec" (&rest pairs))
+
(defun network-stream-open-shell (name buffer host service parameters)
(require 'format-spec)
(let* ((capability-command (plist-get parameters :capability-command))
diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el
index 96503bae18b..9925a045754 100644
--- a/lisp/net/newst-backend.el
+++ b/lisp/net/newst-backend.el
@@ -1,4 +1,4 @@
-;;; newst-backend.el --- Retrieval backend for newsticker.
+;;; newst-backend.el --- Retrieval backend for newsticker -*- lexical-binding:t -*-
;; Copyright (C) 2003-2019 Free Software Foundation, Inc.
@@ -170,7 +170,7 @@ These were mostly extracted from the Radio Community Server at
http://subhonker6.userland.com/rcsPublic/rssHotlist.
You may add other entries in `newsticker-url-list'."
- :type `(set ,@(mapcar `newsticker--splicer
+ :type `(set ,@(mapcar #'newsticker--splicer
newsticker--raw-url-list-defaults))
:set 'newsticker--set-customvar-retrieval
:group 'newsticker-retrieval)
@@ -603,7 +603,7 @@ name/timer pair to `newsticker--retrieval-timer-list'."
(cons feed-name timer))))))
;;;###autoload
-(defun newsticker-start (&optional do-not-complain-if-running)
+(defun newsticker-start (&optional _do-not-complain-if-running)
"Start the newsticker.
Start the timers for display and retrieval. If the newsticker, i.e. the
timers, are running already a warning message is printed unless
@@ -639,9 +639,8 @@ if newsticker has been running."
(when (fboundp 'newsticker-stop-ticker) ; silence compiler warnings
(newsticker-stop-ticker))
(when (newsticker-running-p)
- (mapc (lambda (name-and-timer)
- (newsticker--stop-feed (car name-and-timer)))
- newsticker--retrieval-timer-list)
+ (dolist (name-and-timer newsticker--retrieval-timer-list)
+ (newsticker--stop-feed (car name-and-timer)))
(setq newsticker--retrieval-timer-list nil)
(run-hooks 'newsticker-stop-hook)
(message "Newsticker stopped!")))
@@ -651,9 +650,8 @@ if newsticker has been running."
This does NOT start the retrieval timers."
(interactive)
;; launch retrieval of news
- (mapc (lambda (item)
- (newsticker-get-news (car item)))
- (append newsticker-url-list-defaults newsticker-url-list)))
+ (dolist (item (append newsticker-url-list-defaults newsticker-url-list))
+ (newsticker-get-news (car item))))
(defun newsticker-save-item (feed item)
"Save FEED ITEM."
@@ -709,7 +707,7 @@ See `newsticker-get-news'."
(let ((buffername (concat " *newsticker-funcall-" feed-name "*")))
(with-current-buffer (get-buffer-create buffername)
(erase-buffer)
- (insert (string-to-multibyte (funcall function feed-name)))
+ (newsticker--insert-bytes (funcall function feed-name))
(newsticker--sentinel-work nil t feed-name function
(current-buffer)))))
@@ -730,10 +728,10 @@ STATUS is the return status as delivered by `url-retrieve', and
FEED-NAME is the name of the feed that the news were retrieved
from."
(let ((buf (get-buffer-create (concat " *newsticker-url-" feed-name "*")))
- (result (string-to-multibyte (buffer-string))))
+ (result (buffer-string)))
(set-buffer buf)
(erase-buffer)
- (insert result)
+ (newsticker--insert-bytes result)
;; remove MIME header
(goto-char (point-min))
(search-forward "\n\n" nil t)
@@ -876,11 +874,12 @@ Argument BUFFER is the buffer of the retrieval process."
(decode-coding-region (point-min) (point-max)
coding-system))
(condition-case errordata
- ;; The xml parser might fail or the xml might be
- ;; bugged
+ ;; The xml parser might fail or the xml might be bugged.
(if (fboundp 'libxml-parse-xml-region)
- (list (libxml-parse-xml-region (point-min) (point-max)
- nil t))
+ (progn
+ (xml-remove-comments (point-min) (point-max))
+ (list (libxml-parse-xml-region (point-min) (point-max)
+ nil)))
(xml-parse-region (point-min) (point-max)))
(error (message "Could not parse %s: %s"
(buffer-name) (cadr errordata))
@@ -1255,9 +1254,6 @@ For the RSS 0.91 specification see URL `http://backend.userland.com/rss091'
or URL `http://my.netscape.com/publish/formats/rss-spec-0.91.html'."
(newsticker--debug-msg "Parsing RSS 0.91 feed %s" name)
(let* ((channelnode (car (xml-get-children topnode 'channel)))
- (pub-date (newsticker--decode-rfc822-date
- (car (xml-node-children
- (car (xml-get-children channelnode 'pubDate))))))
is-new-feed has-new-items)
(setq is-new-feed (newsticker--parse-generic-feed
name time
@@ -1293,7 +1289,7 @@ or URL `http://my.netscape.com/publish/formats/rss-spec-0.91.html'."
(car (xml-node-children
(car (xml-get-children node 'pubDate))))))
;; guid-fn
- (lambda (node)
+ (lambda (_node)
nil)
;; extra-fn
(lambda (node)
@@ -1308,9 +1304,6 @@ same as in `newsticker--parse-atom-1.0'.
For the RSS 0.92 specification see URL `http://backend.userland.com/rss092'."
(newsticker--debug-msg "Parsing RSS 0.92 feed %s" name)
(let* ((channelnode (car (xml-get-children topnode 'channel)))
- (pub-date (newsticker--decode-rfc822-date
- (car (xml-node-children
- (car (xml-get-children channelnode 'pubDate))))))
is-new-feed has-new-items)
(setq is-new-feed (newsticker--parse-generic-feed
name time
@@ -1346,7 +1339,7 @@ For the RSS 0.92 specification see URL `http://backend.userland.com/rss092'."
(car (xml-node-children
(car (xml-get-children node 'pubDate))))))
;; guid-fn
- (lambda (node)
+ (lambda (_node)
nil)
;; extra-fn
(lambda (node)
@@ -1405,7 +1398,7 @@ For the RSS 1.0 specification see URL `http://web.resource.org/rss/1.0/spec'."
(car (xml-node-children
(car (xml-get-children node 'date)))))))
;; guid-fn
- (lambda (node)
+ (lambda (_node)
nil)
;; extra-fn
(lambda (node)
@@ -1486,7 +1479,6 @@ The arguments TITLE, DESC, LINK, and EXTRA-ELEMENTS give the feed's title,
description, link, and extra elements resp."
(let ((title (or title "[untitled]"))
(link (or link ""))
- (old-item nil)
(position 0)
(something-was-added nil))
;; decode numeric entities
@@ -1522,89 +1514,89 @@ The arguments TITLE-FN, DESC-FN, LINK-FN, TIME-FN, GUID-FN, and
EXTRA-FN give functions for extracting title, description, link,
time, guid, and extra-elements resp. They are called with one
argument, which is one of the items in ITEMLIST."
- (let (title desc link
- (old-item nil)
- (position 0)
+ (let ((position 0)
(something-was-added nil))
;; gather all items for this feed
- (mapc (lambda (node)
- (setq position (1+ position))
- (setq title (or (funcall title-fn node) "[untitled]"))
- (setq desc (funcall desc-fn node))
- (setq link (or (funcall link-fn node) ""))
- (setq time (or (funcall time-fn node) time))
- ;; It happened that the title or description
- ;; contained evil HTML code that confused the
- ;; xml parser. Therefore:
- (unless (stringp title)
- (setq title (prin1-to-string title)))
- (unless (or (stringp desc) (not desc))
- (setq desc (prin1-to-string desc)))
- ;; ignore items with empty title AND empty desc
- (when (or (> (length title) 0)
- (> (length desc) 0))
- ;; decode numeric entities
- (setq title (xml-substitute-numeric-entities title))
- (when desc
- (setq desc (xml-substitute-numeric-entities desc)))
- (setq link (xml-substitute-numeric-entities link))
- ;; remove whitespace from title, desc, and link
- (setq title (newsticker--remove-whitespace title))
- (setq desc (newsticker--remove-whitespace desc))
- (setq link (newsticker--remove-whitespace link))
- ;; add data to cache
- ;; do we have this item already?
- (let* ((guid (funcall guid-fn node)))
- ;;(message "guid=%s" guid)
- (setq old-item
- (newsticker--cache-contains newsticker--cache
- (intern name) title
- desc link nil guid)))
- ;; add this item, or mark it as old, or do nothing
- (let ((age1 'new)
- (age2 'old)
- (item-new-p nil))
- (if old-item
- (let ((prev-age (newsticker--age old-item)))
- (unless newsticker-automatically-mark-items-as-old
- ;; Some feeds deliver items multiply, the
- ;; first time we find an 'obsolete-old one in
- ;; the cache, the following times we find an
- ;; 'old one
- (if (memq prev-age '(obsolete-old old))
- (setq age2 'old)
- (setq age2 'new)))
- (if (eq prev-age 'immortal)
- (setq age2 'immortal))
- (setq time (newsticker--time old-item)))
- ;; item was not there
- (setq item-new-p t)
- (setq something-was-added t))
- (let ((extra-elements-with-guid (funcall extra-fn node)))
- (unless (assoc 'guid extra-elements-with-guid)
- (setq extra-elements-with-guid
- (cons `(guid nil ,(funcall guid-fn node))
- extra-elements-with-guid)))
- (setq newsticker--cache
- (newsticker--cache-add
- newsticker--cache (intern name) title desc link
- time age1 position extra-elements-with-guid
- time age2)))
- (when item-new-p
- (let ((item (newsticker--cache-contains
- newsticker--cache (intern name) title
- desc link nil)))
- (if newsticker-auto-mark-filter-list
- (newsticker--run-auto-mark-filter name item))
- (run-hook-with-args
- 'newsticker-new-item-functions name item))))))
- itemlist)
+ (dolist (node itemlist)
+ (setq position (1+ position))
+ (let ((title (or (funcall title-fn node) "[untitled]"))
+ (desc (funcall desc-fn node))
+ (link (or (funcall link-fn node) "")))
+ (setq time (or (funcall time-fn node) time))
+ ;; It happened that the title or description
+ ;; contained evil HTML code that confused the
+ ;; xml parser. Therefore:
+ (unless (stringp title)
+ (setq title (prin1-to-string title)))
+ (unless (or (stringp desc) (not desc))
+ (setq desc (prin1-to-string desc)))
+ ;; ignore items with empty title AND empty desc
+ (when (or (> (length title) 0)
+ (> (length desc) 0))
+ ;; decode numeric entities
+ (setq title (xml-substitute-numeric-entities title))
+ (when desc
+ (setq desc (xml-substitute-numeric-entities desc)))
+ (setq link (xml-substitute-numeric-entities link))
+ ;; remove whitespace from title, desc, and link
+ (setq title (newsticker--remove-whitespace title))
+ (setq desc (newsticker--remove-whitespace desc))
+ (setq link (newsticker--remove-whitespace link))
+ ;; add data to cache
+ ;; do we have this item already?
+ (let ((old-item
+ (let* ((guid (funcall guid-fn node)))
+ ;;(message "guid=%s" guid)
+ (newsticker--cache-contains newsticker--cache
+ (intern name) title
+ desc link nil guid)))
+ (age1 'new)
+ (age2 'old)
+ (item-new-p nil))
+ ;; Add this item, or mark it as old, or do nothing
+ (if old-item
+ (let ((prev-age (newsticker--age old-item)))
+ (unless newsticker-automatically-mark-items-as-old
+ ;; Some feeds deliver items multiply, the
+ ;; first time we find an 'obsolete-old one in
+ ;; the cache, the following times we find an
+ ;; 'old one
+ (if (memq prev-age '(obsolete-old old))
+ (setq age2 'old)
+ (setq age2 'new)))
+ (if (eq prev-age 'immortal)
+ (setq age2 'immortal))
+ (setq time (newsticker--time old-item)))
+ ;; item was not there
+ (setq item-new-p t)
+ (setq something-was-added t))
+ (let ((extra-elements-with-guid (funcall extra-fn node)))
+ (unless (assoc 'guid extra-elements-with-guid)
+ (setq extra-elements-with-guid
+ (cons `(guid nil ,(funcall guid-fn node))
+ extra-elements-with-guid)))
+ (setq newsticker--cache
+ (newsticker--cache-add
+ newsticker--cache (intern name) title desc link
+ time age1 position extra-elements-with-guid
+ time age2)))
+ (when item-new-p
+ (let ((item (newsticker--cache-contains
+ newsticker--cache (intern name) title
+ desc link nil)))
+ (if newsticker-auto-mark-filter-list
+ (newsticker--run-auto-mark-filter name item))
+ (run-hook-with-args
+ 'newsticker-new-item-functions name item)))))))
something-was-added))
;; ======================================================================
;;; Misc
;; ======================================================================
+(defun newsticker--insert-bytes (bytes)
+ (insert (decode-coding-string bytes 'binary)))
+
(defun newsticker--remove-whitespace (string)
"Remove leading and trailing whitespace from STRING."
;; we must have ...+ but not ...* in the regexps otherwise xemacs loops
@@ -1759,12 +1751,11 @@ Sat, 07 Sep 2002 00:00:01 GMT
(setq minute (+ minute offset-minute)))))
(condition-case error-data
(let ((i 1))
- (mapc (lambda (m)
- (if (string= month-name m)
- (setq month i))
- (setq i (1+ i)))
- '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug"
- "Sep" "Oct" "Nov" "Dec"))
+ (dolist (m '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug"
+ "Sep" "Oct" "Nov" "Dec"))
+ (if (string= month-name m)
+ (setq month i))
+ (setq i (1+ i)))
(encode-time second minute hour day month year t))
(error
(message "Cannot decode \"%s\": %s %s" rfc822-string
@@ -1775,22 +1766,19 @@ Sat, 07 Sep 2002 00:00:01 GMT
(defun newsticker--lists-intersect-p (list1 list2)
"Return t if LIST1 and LIST2 share elements."
(let ((result nil))
- (mapc (lambda (elt)
- (if (memq elt list2)
- (setq result t)))
- list1)
+ (dolist (elt list1)
+ (if (memq elt list2)
+ (setq result t)))
result))
(defun newsticker--update-process-ids ()
"Update list of ids of active newsticker processes.
Checks list of active processes against list of newsticker processes."
- (let ((active-procs (process-list))
- (new-list nil))
- (mapc (lambda (proc)
- (let ((id (process-id proc)))
- (if (memq id newsticker--process-ids)
- (setq new-list (cons id new-list)))))
- active-procs)
+ (let ((new-list nil))
+ (dolist (proc (process-list))
+ (let ((id (process-id proc)))
+ (if (memq id newsticker--process-ids)
+ (setq new-list (cons id new-list)))))
(setq newsticker--process-ids new-list))
(force-mode-line-update))
@@ -1811,9 +1799,10 @@ If the file does no exist or if it is older than 24 hours
download it from URL first."
(let ((image-name (concat directory feed-name)))
(if (and (file-exists-p image-name)
- (time-less-p (current-time)
- (time-add (nth 5 (file-attributes image-name))
- (seconds-to-time 86400))))
+ (time-less-p nil
+ (time-add (file-attribute-modification-time
+ (file-attributes image-name))
+ 86400)))
(newsticker--debug-msg "%s: Getting image for %s skipped"
(format-time-string "%A, %H:%M")
feed-name)
@@ -1853,7 +1842,7 @@ Save image as FILENAME in DIRECTORY, download it from URL."
(process-put proc 'nt-feed-name feed-name)
(process-put proc 'nt-filename filename)))))
-(defun newsticker--image-sentinel (process event)
+(defun newsticker--image-sentinel (process _event)
"Sentinel for image-retrieving PROCESS caused by EVENT."
(let* ((p-status (process-status process))
(exit-status (process-exit-status process))
@@ -1914,21 +1903,21 @@ from.
The image is saved in DIRECTORY as FILENAME."
(let ((do-save
(or (not status)
- (let ((status-type (car status))
- (status-details (cdr status)))
- (cond ((eq status-type :redirect)
- ;; don't care about redirects
- t)
- ((eq status-type :error)
- ;; silently ignore errors
- nil))))))
+ ;; (let ((status-type (car status)))
+ ;; (cond ((eq status-type :redirect)
+ ;; ;; don't care about redirects
+ ;; t)
+ ;; ((eq status-type :error)
+ ;; ;; silently ignore errors
+ ;; nil)))
+ (eq (car status) :redirect))))
(when do-save
(let ((buf (get-buffer-create (concat " *newsticker-url-image-" feed-name "-"
directory "*")))
- (result (string-to-multibyte (buffer-string))))
+ (result (buffer-string)))
(set-buffer buf)
(erase-buffer)
- (insert result)
+ (newsticker--insert-bytes result)
;; remove MIME header
(goto-char (point-min))
(search-forward "\n\n")
@@ -2006,9 +1995,8 @@ older than TIME."
(mapc
(lambda (item)
(when (eq (newsticker--age item) old-age)
- (let ((exp-time (time-add (newsticker--time item)
- (seconds-to-time time))))
- (when (time-less-p exp-time (current-time))
+ (let ((exp-time (time-add (newsticker--time item) time)))
+ (when (time-less-p exp-time nil)
(newsticker--debug-msg
"Item `%s' from %s has expired on %s"
(newsticker--title item)
@@ -2020,7 +2008,7 @@ older than TIME."
data)
data)
-(defun newsticker--cache-contains (data feed title desc link age
+(defun newsticker--cache-contains (data feed title desc link _age
&optional guid)
"Check DATA whether FEED contains an item with the given properties.
This function returns the contained item or nil if it is not
@@ -2182,22 +2170,8 @@ well."
(throw 'result nil))
((eq age2 'obsolete)
(throw 'result t)))))
- (let* ((time1 (newsticker--time item1))
- (time2 (newsticker--time item2)))
- (cond ((< (nth 0 time1) (nth 0 time2))
- nil)
- ((> (nth 0 time1) (nth 0 time2))
- t)
- ((< (nth 1 time1) (nth 1 time2))
- nil)
- ((> (nth 1 time1) (nth 1 time2))
- t)
- ((< (or (nth 2 time1) 0) (or (nth 2 time2) 0))
- nil)
- ((> (or (nth 2 time1) 0) (or (nth 2 time2) 0))
- t)
- (t
- nil)))))
+ (time-less-p (newsticker--time item2)
+ (newsticker--time item1))))
(defun newsticker--cache-item-compare-by-title (item1 item2)
"Compare ITEM1 and ITEM2 by comparing their titles."
@@ -2293,9 +2267,8 @@ FEED is a symbol!"
(newsticker--cache-read-version1))
(when (y-or-n-p (format "Delete old newsticker cache file? "))
(delete-file newsticker-cache-filename)))
- (mapc (lambda (f)
- (newsticker--cache-read-feed (car f)))
- (append newsticker-url-list-defaults newsticker-url-list))))
+ (dolist (f (append newsticker-url-list-defaults newsticker-url-list))
+ (newsticker--cache-read-feed (car f)))))
(defun newsticker--cache-read-feed (feed-name)
"Read cache data for feed named FEED-NAME."
@@ -2362,14 +2335,13 @@ Export subscriptions to a buffer in OPML Format."
" <ownerName>" (user-full-name) "</ownerName>\n"
" </head>\n"
" <body>\n"))
- (mapc (lambda (sub)
- (insert " <outline text=\"")
- (insert (newsticker--title sub))
- (insert "\" xmlUrl=\"")
- (insert (xml-escape-string (let ((url (cadr sub)))
- (if (stringp url) url (prin1-to-string url)))))
- (insert "\"/>\n"))
- (append newsticker-url-list newsticker-url-list-defaults))
+ (dolist (sub (append newsticker-url-list newsticker-url-list-defaults))
+ (insert " <outline text=\"")
+ (insert (newsticker--title sub))
+ (insert "\" xmlUrl=\"")
+ (insert (xml-escape-string (let ((url (cadr sub)))
+ (if (stringp url) url (prin1-to-string url)))))
+ (insert "\"/>\n"))
(insert " </body>\n</opml>\n"))
(pop-to-buffer "*OPML Export*")
(when (fboundp 'sgml-mode)
@@ -2409,28 +2381,26 @@ removed."
This function checks the variable `newsticker-auto-mark-filter-list'
for an entry that matches FEED and ITEM."
(let ((case-fold-search t))
- (mapc (lambda (filter)
- (let ((filter-feed (car filter))
- (pattern-list (cadr filter)))
- (when (string-match filter-feed feed)
- (newsticker--do-run-auto-mark-filter item pattern-list))))
- newsticker-auto-mark-filter-list)))
+ (dolist (filter newsticker-auto-mark-filter-list)
+ (let ((filter-feed (car filter))
+ (pattern-list (cadr filter)))
+ (when (string-match filter-feed feed)
+ (newsticker--do-run-auto-mark-filter item pattern-list))))))
(defun newsticker--do-run-auto-mark-filter (item list)
"Actually compare ITEM against the pattern-LIST.
LIST must be an element of `newsticker-auto-mark-filter-list'."
- (mapc (lambda (pattern)
- (let ((place (nth 1 pattern))
- (regexp (nth 2 pattern))
- (title (newsticker--title item))
- (desc (newsticker--desc item)))
- (when (or (eq place 'title) (eq place 'all))
- (when (and title (string-match regexp title))
- (newsticker--process-auto-mark-filter-match item pattern)))
- (when (or (eq place 'description) (eq place 'all))
- (when (and desc (string-match regexp desc))
- (newsticker--process-auto-mark-filter-match item pattern)))))
- list))
+ (dolist (pattern list)
+ (let ((place (nth 1 pattern))
+ (regexp (nth 2 pattern))
+ (title (newsticker--title item))
+ (desc (newsticker--desc item)))
+ (when (or (eq place 'title) (eq place 'all))
+ (when (and title (string-match regexp title))
+ (newsticker--process-auto-mark-filter-match item pattern)))
+ (when (or (eq place 'description) (eq place 'all))
+ (when (and desc (string-match regexp desc))
+ (newsticker--process-auto-mark-filter-match item pattern))))))
(defun newsticker--process-auto-mark-filter-match (item pattern)
"Process ITEM that matches an auto-mark-filter PATTERN."
@@ -2503,7 +2473,7 @@ This function is suited for adding it to `newsticker-new-item-functions'."
;; ======================================================================
;;; Retrieve samples
;; ======================================================================
-(defun newsticker-retrieve-random-message (feed-name)
+(defun newsticker-retrieve-random-message (_feed-name)
"Return an artificial RSS string under the name FEED-NAME."
(concat "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?><rss version=\"0.91\">"
"<channel>"
diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el
index 569383b4a28..4f5c729dd00 100644
--- a/lisp/net/newst-plainview.el
+++ b/lisp/net/newst-plainview.el
@@ -562,7 +562,6 @@ This does NOT start the retrieval timers."
(newsticker--debug-msg "Getting news for %s" (symbol-name feed))
(newsticker-get-news (symbol-name feed)))))
-(unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
(declare-function w3m-toggle-inline-image "ext:w3m" (&optional force no-cache))
(defun newsticker-w3m-show-inline-images ()
diff --git a/lisp/net/newst-treeview.el b/lisp/net/newst-treeview.el
index 3af2c423be9..ece728a8358 100644
--- a/lisp/net/newst-treeview.el
+++ b/lisp/net/newst-treeview.el
@@ -36,6 +36,7 @@
;; ======================================================================
;;; Code:
+(require 'cl-lib)
(require 'newst-reader)
(require 'widget)
(require 'tree-widget)
@@ -258,7 +259,6 @@ their id stays constant."
;; ======================================================================
-(unless (fboundp 'declare-function) (defmacro declare-function (&rest _)))
(declare-function w3m-toggle-inline-images "ext:w3m" (&optional force no-cache))
(defvar w3m-fill-column)
(defvar w3-maximum-line-length)
diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el
index 13e6b08e2fc..6a312e2ebb4 100644
--- a/lisp/net/nsm.el
+++ b/lisp/net/nsm.el
@@ -26,6 +26,7 @@
(require 'cl-lib)
(require 'rmc) ; read-multiple-choice
+(eval-when-compile (require 'subr-x))
(defvar nsm-permanent-host-settings nil)
(defvar nsm-temporary-host-settings nil)
@@ -118,12 +119,10 @@ unencrypted."
process))))))
(defun nsm-check-tls-connection (process host port status settings)
- (let ((process (nsm-check-certificate process host port status settings)))
- (if (and process
- (>= (nsm-level network-security-level) (nsm-level 'high)))
- ;; Do further protocol-level checks if the security is high.
- (nsm-check-protocol process host port status settings)
- process)))
+ (when-let ((process
+ (nsm-check-certificate process host port status settings)))
+ ;; Do further protocol-level checks.
+ (nsm-check-protocol process host port status settings)))
(declare-function gnutls-peer-status-warning-describe "gnutls.c"
(status-symbol))
@@ -182,57 +181,104 @@ unencrypted."
nil)
process))))))
+(defvar network-security-protocol-checks
+ '((diffie-hellman-prime-bits medium 1024)
+ (rc4 medium)
+ (signature-sha1 medium)
+ (intermediate-sha1 medium)
+ (3des high)
+ (ssl medium))
+ "This variable specifies what TLS connection checks to perform.
+It's an alist where the first element is the name of the check,
+the second is the security level where the check kicks in, and the
+optional third element is a parameter supplied to the check.
+
+An element like `(rc4 medium)' will result in the function
+`nsm-protocol-check--rc4' being called with the parameters
+HOST PORT STATUS OPTIONAL-PARAMETER.")
+
(defun nsm-check-protocol (process host port status settings)
- (let ((prime-bits (plist-get status :diffie-hellman-prime-bits))
- (signature-algorithm
- (plist-get (plist-get status :certificate) :signature-algorithm))
- (encryption (format "%s-%s-%s"
- (plist-get status :key-exchange)
- (plist-get status :cipher)
- (plist-get status :mac)))
- (protocol (plist-get status :protocol)))
- (cond
- ((and prime-bits
- (< prime-bits 1024)
- (not (memq :diffie-hellman-prime-bits
- (plist-get settings :conditions)))
- (not
- (nsm-query
- host port status :diffie-hellman-prime-bits
- "The Diffie-Hellman prime bits (%s) used for this connection to %s:%s is less than what is considered safe (%s)."
- prime-bits host port 1024)))
- (delete-process process)
- nil)
- ((and (string-match "\\bRC4\\b" encryption)
- (not (memq :rc4 (plist-get settings :conditions)))
- (not
- (nsm-query
- host port status :rc4
- "The connection to %s:%s uses the RC4 algorithm (%s), which is believed to be unsafe."
- host port encryption)))
- (delete-process process)
- nil)
- ((and (string-match "\\bSHA1\\b" signature-algorithm)
- (not (memq :signature-sha1 (plist-get settings :conditions)))
- (not
- (nsm-query
- host port status :signature-sha1
- "The certificate used to verify the connection to %s:%s uses the SHA1 algorithm (%s), which is believed to be unsafe."
- host port signature-algorithm)))
- (delete-process process)
- nil)
- ((and protocol
- (string-match "SSL" protocol)
- (not (memq :ssl (plist-get settings :conditions)))
- (not
- (nsm-query
- host port status :ssl
- "The connection to %s:%s uses the %s protocol, which is believed to be unsafe."
- host port protocol)))
- (delete-process process)
- nil)
- (t
- process))))
+ (cl-loop for check in network-security-protocol-checks
+ for type = (intern (format ":%s" (car check)) obarray)
+ while process
+ ;; Skip the check if the user has already said that this
+ ;; host is OK for this type of "error".
+ when (and (not (memq type (plist-get settings :conditions)))
+ (>= (nsm-level network-security-level)
+ (nsm-level (cadr check))))
+ do (let ((result
+ (funcall (intern (format "nsm-protocol-check--%s"
+ (car check))
+ obarray)
+ host port status (nth 2 check))))
+ (unless result
+ (delete-process process)
+ (setq process nil))))
+ ;; If a test failed we return nil, otherwise the process object.
+ process)
+
+(defun nsm--encryption (status)
+ (format "%s-%s-%s"
+ (plist-get status :key-exchange)
+ (plist-get status :cipher)
+ (plist-get status :mac)))
+
+(defun nsm-protocol-check--diffie-hellman-prime-bits (host port status bits)
+ (let ((prime-bits (plist-get status :diffie-hellman-prime-bits)))
+ (or (not prime-bits)
+ (>= prime-bits bits)
+ (nsm-query
+ host port status :diffie-hellman-prime-bits
+ "The Diffie-Hellman prime bits (%s) used for this connection to %s:%s is less than what is considered safe (%s)."
+ prime-bits host port bits))))
+
+(defun nsm-protocol-check--3des (host port status _)
+ (or (not (string-match "\\b3DES\\b" (plist-get status :cipher)))
+ (nsm-query
+ host port status :rc4
+ "The connection to %s:%s uses the 3DES cipher (%s), which is believed to be unsafe."
+ host port (plist-get status :cipher))))
+
+(defun nsm-protocol-check--rc4 (host port status _)
+ (or (not (string-match "\\bRC4\\b" (nsm--encryption status)))
+ (nsm-query
+ host port status :rc4
+ "The connection to %s:%s uses the RC4 algorithm (%s), which is believed to be unsafe."
+ host port (nsm--encryption status))))
+
+(defun nsm-protocol-check--signature-sha1 (host port status _)
+ (let ((signature-algorithm
+ (plist-get (plist-get status :certificate) :signature-algorithm)))
+ (or (not (string-match "\\bSHA1\\b" signature-algorithm))
+ (nsm-query
+ host port status :signature-sha1
+ "The certificate used to verify the connection to %s:%s uses the SHA1 algorithm (%s), which is believed to be unsafe."
+ host port signature-algorithm))))
+
+(defun nsm-protocol-check--intermediate-sha1 (host port status _)
+ ;; Skip the first certificate, because that's the host certificate.
+ (cl-loop for certificate in (cdr (plist-get status :certificates))
+ for algo = (plist-get certificate :signature-algorithm)
+ ;; Don't check root certificates -- SHA1 isn't dangerous
+ ;; there.
+ when (and (not (equal (plist-get certificate :issuer)
+ (plist-get certificate :subject)))
+ (string-match "\\bSHA1\\b" algo)
+ (not (nsm-query
+ host port status :intermediate-sha1
+ "An intermediate certificate used to verify the connection to %s:%s uses the SHA1 algorithm (%s), which is believed to be unsafe."
+ host port algo)))
+ do (cl-return nil)
+ finally (cl-return t)))
+
+(defun nsm-protocol-check--ssl (host port status _)
+ (let ((protocol (plist-get status :protocol)))
+ (or (not protocol)
+ (not (string-match "SSL" protocol))
+ (nsm-query
+ host port status :ssl
+ "The connection to %s:%s uses the %s protocol, which is believed to be unsafe."
+ host port protocol))))
(defun nsm-fingerprint (status)
(plist-get (plist-get status :certificate) :public-key-id))
diff --git a/lisp/net/ntlm.el b/lisp/net/ntlm.el
index d3899e45eae..88c561910cb 100644
--- a/lisp/net/ntlm.el
+++ b/lisp/net/ntlm.el
@@ -1,4 +1,4 @@
-;;; ntlm.el --- NTLM (NT LanManager) authentication support
+;;; ntlm.el --- NTLM (NT LanManager) authentication support -*- lexical-binding:t -*-
;; Copyright (C) 2001, 2007-2019 Free Software Foundation, Inc.
@@ -106,7 +106,7 @@ is not given."
(request-flags (concat (make-string 1 7) (make-string 1 130)
(make-string 1 8) (make-string 1 0)))
;0x07 0x82 0x08 0x00
- lu ld off-d off-u)
+ )
(when (and user (string-match "@" user))
(unless domain
(setq domain (substring user (1+ (match-beginning 0)))))
@@ -115,10 +115,10 @@ is not given."
;; set "negotiate domain supplied" bit
(aset request-flags 1 (logior (aref request-flags 1) ?\x10)))
;; set fields offsets within the request struct
- (setq lu (length user))
- (setq ld (length domain))
- (setq off-u 32) ;offset to the string 'user
- (setq off-d (+ 32 lu)) ;offset to the string 'domain
+ (let* ((lu (length user))
+ (ld (length domain))
+ (off-u 32) ;offset to the string 'user
+ (off-d (+ 32 lu))) ;offset to the string 'domain
;; pack the request struct in a string
(concat request-ident ;8 bytes
request-msgType ;4 bytes
@@ -131,39 +131,34 @@ is not given."
(md4-pack-int32 (cons 0 off-d)) ;domain field, offset field
user ;buffer field
domain ;buffer field
- )))
-
-(eval-when-compile
- (defmacro ntlm-string-as-unibyte (string)
- (if (fboundp 'string-as-unibyte)
- `(string-as-unibyte ,string)
- string)))
+ ))))
(defun ntlm-compute-timestamp ()
"Compute an NTLMv2 timestamp.
Return a unibyte string representing the number of tenths of a
microsecond since January 1, 1601 as a 64-bit little-endian
signed integer."
+ ;; FIXME: This can likely be significantly simplified using the new
+ ;; bignums support!
(let* ((s-to-tenths-of-us "mul(add(lsh($1,16),$2),10000000)")
(us-to-tenths-of-us "mul($3,10)")
(ps-to-tenths-of-us "idiv($4,100000)")
(tenths-of-us-since-jan-1-1601
- (apply 'calc-eval (concat "add(add(add("
+ (apply #'calc-eval (concat "add(add(add("
s-to-tenths-of-us ","
us-to-tenths-of-us "),"
ps-to-tenths-of-us "),"
;; tenths of microseconds between
;; 1601-01-01 and 1970-01-01
"116444736000000000)")
- ;; add trailing zeros to support old current-time formats
- 'rawnum (append (current-time) '(0 0))))
+ 'rawnum (encode-time nil 'list)))
result-bytes)
- (dotimes (byte 8)
+ (dotimes (_byte 8)
(push (calc-eval "and($1,16#FF)" 'rawnum tenths-of-us-since-jan-1-1601)
result-bytes)
(setq tenths-of-us-since-jan-1-1601
(calc-eval "rsh($1,8,64)" 'rawnum tenths-of-us-since-jan-1-1601)))
- (apply 'unibyte-string (nreverse result-bytes))))
+ (apply #'unibyte-string (nreverse result-bytes))))
(defun ntlm-generate-nonce ()
"Generate a random nonce, not to be used more than once.
@@ -178,7 +173,13 @@ the NTLM based server for the user USER and the password hash list
PASSWORD-HASHES. NTLM uses two hash values which are represented
by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of
(list (ntlm-smb-passwd-hash password) (ntlm-md4hash password))"
- (let* ((rchallenge (ntlm-string-as-unibyte challenge))
+ (let* ((rchallenge (if (multibyte-string-p challenge)
+ (progn
+ ;; FIXME: Maybe it would be better to
+ ;; signal an error.
+ (message "Incorrect challenge string type in ntlm-build-auth-response")
+ (encode-coding-string challenge 'binary))
+ challenge))
;; get fields within challenge struct
;;(ident (substring rchallenge 0 8)) ;ident, 8 bytes
;;(msgType (substring rchallenge 8 12)) ;msgType, 4 bytes
@@ -189,20 +190,16 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of
;0x07 0x82 0x08 0x00
(flags (substring rchallenge 20 24)) ;flags, 4 bytes
(challengeData (substring rchallenge 24 32)) ;challengeData, 8 bytes
- uDomain-len uDomain-offs
- ;; response struct and its fields
+ ;; Extract domain string from challenge string.
+ ;;(uDomain-len (md4-unpack-int16 (substring uDomain 0 2)))
+ (uDomain-offs (md4-unpack-int32 (substring uDomain 4 8)))
+ ;; Response struct and its fields.
lmRespData ;lmRespData, 24 bytes
ntRespData ;ntRespData, variable length
- domain ;ascii domain string
- workstation ;ascii workstation string
- ll ln lu ld lw off-lm off-nt off-u off-d off-w)
- ;; extract domain string from challenge string
- (setq uDomain-len (md4-unpack-int16 (substring uDomain 0 2)))
- (setq uDomain-offs (md4-unpack-int32 (substring uDomain 4 8)))
- ;; match Mozilla behavior, which is to send an empty domain string
- (setq domain "")
- ;; match Mozilla behavior, which is to send "WORKSTATION"
- (setq workstation "WORKSTATION")
+ ;; Match Mozilla behavior, which is to send an empty domain string
+ (domain "") ;ascii domain string
+ ;; Match Mozilla behavior, which is to send "WORKSTATION".
+ (workstation "WORKSTATION")) ;ascii workstation string
;; overwrite domain in case user is given in <user>@<domain> format
(when (string-match "@" user)
(setq domain (substring user (1+ (match-beginning 0))))
@@ -261,13 +258,11 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of
;; so just treat it the same as levels 0 and 1
;; check if "negotiate NTLM2 key" flag is set in type 2 message
(if (not (zerop (logand (aref flags 2) 8)))
- (let (randomString
- sessionHash)
- ;; generate NTLM2 session response data
- (setq randomString (ntlm-generate-nonce))
- (setq sessionHash (secure-hash 'md5
+ ;; generate NTLM2 session response data
+ (let* ((randomString (ntlm-generate-nonce))
+ (sessionHash (secure-hash 'md5
(concat challengeData randomString)
- nil nil t))
+ nil nil t)))
(setq sessionHash (substring sessionHash 0 8))
(setq lmRespData (concat randomString (make-string 16 0)))
(setq ntRespData (ntlm-smb-owf-encrypt
@@ -279,16 +274,16 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of
(ntlm-smb-owf-encrypt (cadr password-hashes) challengeData))))
;; get offsets to fields to pack the response struct in a string
- (setq ll (length lmRespData))
- (setq ln (length ntRespData))
- (setq lu (length user))
- (setq ld (length domain))
- (setq lw (length workstation))
- (setq off-u 64) ;offset to string 'uUser
- (setq off-d (+ off-u (* 2 lu))) ;offset to string 'uDomain
- (setq off-w (+ off-d (* 2 ld))) ;offset to string 'uWks
- (setq off-lm (+ off-w (* 2 lw))) ;offset to string 'lmResponse
- (setq off-nt (+ off-lm ll)) ;offset to string 'ntResponse
+ (let* ((ll (length lmRespData))
+ (ln (length ntRespData))
+ (lu (length user))
+ (ld (length domain))
+ (lw (length workstation))
+ (off-u 64) ;offset to string 'uUser
+ (off-d (+ off-u (* 2 lu))) ;offset to string 'uDomain
+ (off-w (+ off-d (* 2 ld))) ;offset to string 'uWks
+ (off-lm (+ off-w (* 2 lw))) ;offset to string 'lmResponse
+ (off-nt (+ off-lm ll))) ;offset to string 'ntResponse
;; pack the response struct in a string
(concat "NTLMSSP\0" ;response ident field, 8 bytes
(md4-pack-int32 '(0 . 3)) ;response msgType field, 4 bytes
@@ -342,7 +337,7 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of
(ntlm-ascii2unicode workstation lw) ;Unicode workstation, 2*lw bytes
lmRespData ;lmResponse, 24 bytes
ntRespData ;ntResponse, ln bytes
- )))
+ ))))
(defun ntlm-get-password-hashes (password)
"Return a pair of SMB hash and NT MD4 hash of the given password PASSWORD."
@@ -352,7 +347,10 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of
(defun ntlm-ascii2unicode (str len)
"Convert an ASCII string into a NT Unicode string, which is
little-endian utf16."
- (let ((utf (make-string (* 2 len) 0)) (i 0) val)
+ ;; FIXME: Can't we use encode-coding-string with a `utf-16le' coding system?
+ (let ((utf (make-string (* 2 len) 0))
+ (i 0)
+ val)
(while (and (< i len)
(not (zerop (setq val (aref str i)))))
(aset utf (* 2 i) val)
@@ -381,9 +379,9 @@ string PASSWD. PASSWD is truncated to 14 bytes if longer."
"Return the response string of 24 bytes long for the given password
string PASSWD based on the DES encryption. PASSWD is of at most 14
bytes long and the challenge string C8 of 8 bytes long."
- (let ((len (min (length passwd) 16)) p22)
- (setq p22 (concat (substring passwd 0 len) ;fill top 16 bytes with passwd
- (make-string (- 22 len) 0)))
+ (let* ((len (min (length passwd) 16))
+ (p22 (concat (substring passwd 0 len) ;Fill top 16 bytes with passwd.
+ (make-string (- 22 len) 0))))
(ntlm-smb-des-e-p24 p22 c8)))
(defun ntlm-smb-des-e-p24 (p22 c8)
@@ -405,53 +403,53 @@ string C8."
"Return the hash string of length 8 for a string IN of length 8 and
a string KEY of length 8. FORW is t or nil."
(let ((out (make-string 8 0))
- outb ;string of length 64
(inb (make-string 64 0))
(keyb (make-string 64 0))
(key2 (ntlm-smb-str-to-key key))
- (i 0) aa)
+ (i 0))
(while (< i 64)
- (unless (zerop (logand (aref in (/ i 8)) (lsh 1 (- 7 (% i 8)))))
+ (unless (zerop (logand (aref in (/ i 8)) (ash 1 (- 7 (% i 8)))))
(aset inb i 1))
- (unless (zerop (logand (aref key2 (/ i 8)) (lsh 1 (- 7 (% i 8)))))
+ (unless (zerop (logand (aref key2 (/ i 8)) (ash 1 (- 7 (% i 8)))))
(aset keyb i 1))
(setq i (1+ i)))
- (setq outb (ntlm-smb-dohash inb keyb forw))
- (setq i 0)
- (while (< i 64)
- (unless (zerop (aref outb i))
- (setq aa (aref out (/ i 8)))
- (aset out (/ i 8)
- (logior aa (lsh 1 (- 7 (% i 8))))))
- (setq i (1+ i)))
- out))
+ (let ((outb (ntlm-smb-dohash inb keyb forw))
+ aa)
+ (setq i 0)
+ (while (< i 64)
+ (unless (zerop (aref outb i))
+ (setq aa (aref out (/ i 8)))
+ (aset out (/ i 8)
+ (logior aa (ash 1 (- 7 (% i 8))))))
+ (setq i (1+ i)))
+ out)))
(defun ntlm-smb-str-to-key (str)
"Return a string of length 8 for the given string STR of length 7."
(let ((key (make-string 8 0))
(i 7))
- (aset key 0 (lsh (aref str 0) -1))
+ (aset key 0 (ash (aref str 0) -1))
(aset key 1 (logior
- (lsh (logand (aref str 0) 1) 6)
- (lsh (aref str 1) -2)))
+ (ash (logand (aref str 0) 1) 6)
+ (ash (aref str 1) -2)))
(aset key 2 (logior
- (lsh (logand (aref str 1) 3) 5)
- (lsh (aref str 2) -3)))
+ (ash (logand (aref str 1) 3) 5)
+ (ash (aref str 2) -3)))
(aset key 3 (logior
- (lsh (logand (aref str 2) 7) 4)
- (lsh (aref str 3) -4)))
+ (ash (logand (aref str 2) 7) 4)
+ (ash (aref str 3) -4)))
(aset key 4 (logior
- (lsh (logand (aref str 3) 15) 3)
- (lsh (aref str 4) -5)))
+ (ash (logand (aref str 3) 15) 3)
+ (ash (aref str 4) -5)))
(aset key 5 (logior
- (lsh (logand (aref str 4) 31) 2)
- (lsh (aref str 5) -6)))
+ (ash (logand (aref str 4) 31) 2)
+ (ash (aref str 5) -6)))
(aset key 6 (logior
- (lsh (logand (aref str 5) 63) 1)
- (lsh (aref str 6) -7)))
+ (ash (logand (aref str 5) 63) 1)
+ (ash (aref str 6) -7)))
(aset key 7 (logand (aref str 6) 127))
(while (>= i 0)
- (aset key i (lsh (aref key i) 1))
+ (aset key i (ash (aref key i) 1))
(setq i (1- i)))
key))
@@ -571,27 +569,22 @@ length of STR is LEN."
"Return the hash value for a string IN and a string KEY.
Length of IN and KEY are 64. FORW non-nil means forward, nil means
backward."
- (let (pk1 ;string of length 56
- c ;string of length 28
- d ;string of length 28
- cd ;string of length 56
- (ki (make-vector 16 0)) ;vector of string of length 48
- pd1 ;string of length 64
- l ;string of length 32
- r ;string of length 32
- rl ;string of length 64
- (i 0) (j 0) (k 0))
- (setq pk1 (ntlm-string-permute key ntlm-smb-perm1 56))
- (setq c (substring pk1 0 28))
- (setq d (substring pk1 28 56))
-
- (setq i 0)
- (while (< i 16)
+ (let* ((pk1 (ntlm-string-permute key ntlm-smb-perm1 56)) ;string of length 56
+ (c (substring pk1 0 28)) ;string of length 28
+ (d (substring pk1 28 56)) ;string of length 28
+ cd ;string of length 56
+ (ki (make-vector 16 0)) ;vector of string of length 48
+ pd1 ;string of length 64
+ l ;string of length 32
+ r ;string of length 32
+ rl ;string of length 64
+ (i 0) (j 0) (k 0))
+
+ (dotimes (i 16)
(setq c (ntlm-string-lshift c (aref ntlm-smb-sc i) 28))
(setq d (ntlm-string-lshift d (aref ntlm-smb-sc i) 28))
(setq cd (concat (substring c 0 28) (substring d 0 28)))
- (aset ki i (ntlm-string-permute cd ntlm-smb-perm2 48))
- (setq i (1+ i)))
+ (aset ki i (ntlm-string-permute cd ntlm-smb-perm2 48)))
(setq pd1 (ntlm-string-permute in ntlm-smb-perm3 64))
@@ -619,16 +612,16 @@ backward."
(setq j 0)
(while (< j 8)
(setq bj (aref b j))
- (setq m (logior (lsh (aref bj 0) 1) (aref bj 5)))
- (setq n (logior (lsh (aref bj 1) 3)
- (lsh (aref bj 2) 2)
- (lsh (aref bj 3) 1)
+ (setq m (logior (ash (aref bj 0) 1) (aref bj 5)))
+ (setq n (logior (ash (aref bj 1) 3)
+ (ash (aref bj 2) 2)
+ (ash (aref bj 3) 1)
(aref bj 4)))
(setq k 0)
(setq sbox-jmn (aref (aref (aref ntlm-smb-sbox j) m) n))
(while (< k 4)
(aset bj k
- (if (zerop (logand sbox-jmn (lsh 1 (- 3 k))))
+ (if (zerop (logand sbox-jmn (ash 1 (- 3 k))))
0 1))
(setq k (1+ k)))
(setq j (1+ j)))
@@ -650,16 +643,12 @@ backward."
(defun ntlm-md4hash (passwd)
"Return the 16 bytes MD4 hash of a string PASSWD after converting it
into a Unicode string. PASSWD is truncated to 128 bytes if longer."
- (let (len wpwd)
- ;; Password cannot be longer than 128 characters
- (setq len (length passwd))
- (if (> len 128)
- (setq len 128))
- ;; Password must be converted to NT Unicode
- (setq wpwd (ntlm-ascii2unicode passwd len))
- ;; Calculate length in bytes
- (setq len (* len 2))
- (md4 wpwd len)))
+ (let* ((len (min (length passwd) 128)) ;Pwd can't be > than 128 characters.
+ ;; Password must be converted to NT Unicode.
+ (wpwd (ntlm-ascii2unicode passwd len)))
+ (md4 wpwd
+ ;; Calculate length in bytes.
+ (* len 2))))
(provide 'ntlm)
diff --git a/lisp/net/pop3.el b/lisp/net/pop3.el
index f73607081c5..599e2305f77 100644
--- a/lisp/net/pop3.el
+++ b/lisp/net/pop3.el
@@ -1,4 +1,4 @@
-;;; pop3.el --- Post Office Protocol (RFC 1460) interface
+;;; pop3.el --- Post Office Protocol (RFC 1460) interface -*- lexical-binding:t -*-
;; Copyright (C) 1996-2019 Free Software Foundation, Inc.
@@ -32,7 +32,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'mail-utils)
(defvar parse-time-months)
@@ -165,12 +165,7 @@ Used for APOP authentication.")
"How long pop3 should wait between checking for the end of output.
Shorter values mean quicker response, but are more CPU intensive.")
(defun pop3-accept-process-output (process)
- (accept-process-output
- process
- (truncate pop3-read-timeout)
- (truncate (* (- pop3-read-timeout
- (truncate pop3-read-timeout))
- 1000))))))
+ (accept-process-output process pop3-read-timeout))))
(defvar pop3-uidl)
;; List of UIDLs of existing messages at present in the server:
@@ -185,8 +180,8 @@ Shorter values mean quicker response, but are more CPU intensive.")
;; ("SERVER_B" ("USER_B1" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...)
;; ("USER_B2" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...)
;; ...))
-;; Where TIMESTAMP is the most significant two digits of an Emacs time,
-;; i.e. the return value of `current-time'.
+;; Where TIMESTAMP is an Emacs time value (HI LO) representing the
+;; number of seconds (+ (ash HI 16) LO).
;;;###autoload
(defun pop3-movemail (file)
@@ -237,8 +232,8 @@ Use streaming commands."
(setq start-point
(pop3-wait-for-messages process pop3-stream-length
total-size start-point))
- (incf waited-for pop3-stream-length))
- (incf i))
+ (cl-incf waited-for pop3-stream-length))
+ (cl-incf i))
(pop3-wait-for-messages process (- count waited-for)
total-size start-point)))
@@ -249,7 +244,7 @@ Use streaming commands."
(or (not total-size)
(re-search-forward "^\\.\r?\n" nil t)))
(re-search-forward "^-ERR " nil t))
- (decf count)
+ (cl-decf count)
(setq start-point (point)))
(unless (memq (process-status process) '(open run))
(error "pop3 process died"))
@@ -269,7 +264,6 @@ Use streaming commands."
(defun pop3-write-to-file (file messages)
(let ((pop-buffer (current-buffer))
- (start (point-min))
beg end
temp-buffer)
(with-temp-buffer
@@ -280,7 +274,6 @@ Use streaming commands."
(forward-line 1)
(setq beg (point))
(when (re-search-forward "^\\.\r?\n" nil t)
- (setq start (point))
(forward-line -1)
(setq end (point)))
(with-current-buffer temp-buffer
@@ -369,7 +362,7 @@ Use streaming commands."
(while (> i 0)
(unless (member (nth (1- i) pop3-uidl) saved)
(push i messages))
- (decf i)))
+ (cl-decf i)))
(when messages
(setq list (pop3-list process)
size 0)
@@ -387,7 +380,9 @@ Use streaming commands."
(defun pop3-uidl-dele (process)
"Delete messages according to `pop3-leave-mail-on-server'.
Return non-nil if it is necessary to update the local UIDL file."
- (let* ((ctime (current-time))
+ (let* ((ctime (encode-time nil 'list))
+ (age-limit (and (numberp pop3-leave-mail-on-server)
+ (* 86400 pop3-leave-mail-on-server)))
(srvr (assoc pop3-mailhost pop3-uidl-saved))
(saved (assoc pop3-maildrop (cdr srvr)))
i uidl mod new tstamp dele)
@@ -399,22 +394,18 @@ Return non-nil if it is necessary to update the local UIDL file."
(unless (member (setq uidl (nth i pop3-uidl)) (cdr saved))
(push ctime new)
(push uidl new))
- (decf i)))
+ (cl-decf i)))
(pop3-uidl
(setq new (mapcan (lambda (elt) (list elt ctime)) pop3-uidl))))
(when new (setq mod t))
;; List expirable messages and delete them from the data to be saved.
- (setq ctime (when (numberp pop3-leave-mail-on-server)
- (/ (+ (* (car ctime) 65536.0) (cadr ctime)) 86400))
- i (1- (length saved)))
+ (setq i (1- (length saved)))
(while (> i 0)
(if (member (setq uidl (nth (1- i) saved)) pop3-uidl)
(progn
(setq tstamp (nth i saved))
- (if (and ctime
- (> (- ctime (/ (+ (* (car tstamp) 65536.0) (cadr tstamp))
- 86400))
- pop3-leave-mail-on-server))
+ (if (and age-limit
+ (time-less-p age-limit (time-subtract ctime tstamp)))
;; Mails to delete.
(progn
(setq mod t)
@@ -424,7 +415,7 @@ Return non-nil if it is necessary to update the local UIDL file."
(push uidl new)))
;; Mails having been deleted in the server.
(setq mod t))
- (decf i 2))
+ (cl-decf i 2))
(cond (saved
(setcdr saved new))
(srvr
@@ -440,7 +431,7 @@ Return non-nil if it is necessary to update the local UIDL file."
(while (> i 0)
(when (member (nth (1- i) pop3-uidl) dele)
(push i uidl))
- (decf i))
+ (cl-decf i))
(when uidl
(pop3-send-streaming-command process "DELE" uidl nil)))
mod))
@@ -594,7 +585,7 @@ Return the response string if optional second argument is non-nil."
(goto-char pop3-read-point)
(if (looking-at "-ERR")
(error "%s" (buffer-substring (point) (- match-end 2)))
- (if (not (looking-at "+OK"))
+ (if (not (looking-at "\\+OK"))
(progn (setq pop3-read-point match-end) nil)
(setq pop3-read-point match-end)
(if return
@@ -620,10 +611,8 @@ Return the response string if optional second argument is non-nil."
If NOW, use that time instead."
(require 'parse-time)
(let* ((now (or now (current-time)))
- (zone (nth 8 (decode-time now)))
- (sign "+"))
+ (zone (nth 8 (decode-time now))))
(when (< zone 0)
- (setq sign "-")
(setq zone (- zone)))
(concat
(format-time-string "%d" now)
@@ -695,14 +684,14 @@ If NOW, use that time instead."
"Send USER information to POP3 server."
(pop3-send-command process (format "USER %s" user))
(let ((response (pop3-read-response process t)))
- (if (not (and response (string-match "+OK" response)))
+ (if (not (and response (string-match "\\+OK" response)))
(error "USER %s not valid" user))))
(defun pop3-pass (process)
"Send authentication information to the server."
(pop3-send-command process (format "PASS %s" pop3-password))
(let ((response (pop3-read-response process t)))
- (if (not (and response (string-match "+OK" response)))
+ (if (not (and response (string-match "\\+OK" response)))
(pop3-quit process))))
(defun pop3-apop (process user)
@@ -715,7 +704,7 @@ If NOW, use that time instead."
(let ((hash (md5 (concat pop3-timestamp pass) nil nil 'binary)))
(pop3-send-command process (format "APOP %s %s" user hash))
(let ((response (pop3-read-response process t)))
- (if (not (and response (string-match "+OK" response)))
+ (if (not (and response (string-match "\\+OK" response)))
(pop3-quit process)))))
))
@@ -785,7 +774,7 @@ Otherwise, return the size of the message-id MSG"
(pop3-send-command process (format "DELE %s" msg))
(pop3-read-response process))
-(defun pop3-noop (process msg)
+(defun pop3-noop (process _msg)
"No-operation."
(pop3-send-command process "NOOP")
(pop3-read-response process))
diff --git a/lisp/net/puny.el b/lisp/net/puny.el
index bb1ef290f64..23c7af80619 100644
--- a/lisp/net/puny.el
+++ b/lisp/net/puny.el
@@ -27,6 +27,7 @@
;;; Code:
+(eval-when-compile (require 'cl-lib))
(require 'seq)
(defun puny-encode-domain (domain)
diff --git a/lisp/net/quickurl.el b/lisp/net/quickurl.el
index db1ff0d3ae9..3f7e9d192d6 100644
--- a/lisp/net/quickurl.el
+++ b/lisp/net/quickurl.el
@@ -155,7 +155,7 @@ could be used here."
(defconst quickurl-reread-hook-postfix
"
;; Local Variables:
-;; eval: (progn (require 'quickurl) (add-hook 'local-write-file-hooks (lambda () (quickurl-read) nil)))
+;; eval: (progn (require 'quickurl) (add-hook 'write-file-functions (lambda () (quickurl-read) nil) nil t))
;; End:
"
"Example `quickurl-postfix' text that adds a local variable to the
@@ -504,15 +504,15 @@ TYPE dictates what will be inserted, options are:
(with-current-buffer quickurl-list-last-buffer
(insert
(pcase type
- (`url (funcall quickurl-format-function url))
- (`naked-url (quickurl-url-url url))
- (`with-lookup (format "%s <URL:%s>"
+ ('url (funcall quickurl-format-function url))
+ ('naked-url (quickurl-url-url url))
+ ('with-lookup (format "%s <URL:%s>"
(quickurl-url-keyword url)
(quickurl-url-url url)))
- (`with-desc (format "%S <URL:%s>"
+ ('with-desc (format "%S <URL:%s>"
(quickurl-url-description url)
(quickurl-url-url url)))
- (`lookup (quickurl-url-keyword url)))))
+ ('lookup (quickurl-url-keyword url)))))
(error "No URL details on that line"))
url))
diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el
index de524d9ef10..b1a6c1ce8d2 100644
--- a/lisp/net/rcirc.el
+++ b/lisp/net/rcirc.el
@@ -168,6 +168,14 @@ underneath each nick."
(string :tag "Prefix text"))
:group 'rcirc)
+(defcustom rcirc-url-max-length nil
+ "Maximum number of characters in displayed URLs.
+If nil, no maximum is applied."
+ :version "27.1"
+ :type '(choice (const :tag "No maximum" nil)
+ (integer :tag "Number of characters"))
+ :group 'rcirc)
+
(defvar rcirc-ignore-buffer-activity-flag nil
"If non-nil, ignore activity in this buffer.")
(make-variable-buffer-local 'rcirc-ignore-buffer-activity-flag)
@@ -186,9 +194,6 @@ underneath each nick."
(define-minor-mode rcirc-omit-mode
"Toggle the hiding of \"uninteresting\" lines.
-With a prefix argument ARG, enable Rcirc-Omit mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Uninteresting lines are those whose responses are listed in
`rcirc-omit-responses'."
@@ -665,8 +670,9 @@ last ping."
(defun rcirc-handler-ctcp-KEEPALIVE (process _target _sender message)
(with-rcirc-process-buffer process
- (setq header-line-format (format "%f" (- (float-time)
- (string-to-number message))))))
+ (setq header-line-format
+ (format "%f" (float-time
+ (time-since (string-to-number message)))))))
(defvar rcirc-debug-buffer "*rcirc debug*")
(defvar rcirc-debug-flag nil
@@ -718,8 +724,8 @@ When 0, do not auto-reconnect."
(< 0 rcirc-reconnect-delay))
(let ((now (current-time)))
(when (or (null rcirc-last-connect-time)
- (< rcirc-reconnect-delay
- (float-time (time-subtract now rcirc-last-connect-time))))
+ (time-less-p rcirc-reconnect-delay
+ (time-subtract now rcirc-last-connect-time)))
(setq rcirc-last-connect-time now)
(rcirc-cmd-reconnect nil))))
(run-hook-with-args 'rcirc-sentinel-functions process sentinel))))
@@ -1353,10 +1359,7 @@ Create the buffer if it doesn't exist."
"Keymap for multiline mode in rcirc.")
(define-minor-mode rcirc-multiline-minor-mode
- "Minor mode for editing multiple lines in rcirc.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil."
+ "Minor mode for editing multiple lines in rcirc."
:init-value nil
:lighter " rcirc-mline"
:keymap rcirc-multiline-minor-mode-map
@@ -1867,10 +1870,7 @@ This function does not alter the INPUT string."
;;;###autoload
(define-minor-mode rcirc-track-minor-mode
- "Global minor mode for tracking activity in rcirc buffers.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil."
+ "Global minor mode for tracking activity in rcirc buffers."
:init-value nil
:lighter ""
:keymap rcirc-track-minor-mode-map
@@ -2065,9 +2065,7 @@ activity. Only run if the buffer is not visible and
(defvar rcirc-visible-buffers nil)
(defun rcirc-window-configuration-change ()
(unless (minibuffer-window-active-p (minibuffer-window))
- ;; delay this until command has finished to make sure window is
- ;; actually visible before clearing activity
- (add-hook 'post-command-hook 'rcirc-window-configuration-change-1)))
+ (rcirc-window-configuration-change-1)))
(defun rcirc-window-configuration-change-1 ()
;; clear activity and overlay arrows
@@ -2091,9 +2089,7 @@ activity. Only run if the buffer is not visible and
rcirc-activity)))
;; update the mode-line string
(unless (equal old-activity rcirc-activity)
- (rcirc-update-activity-string)))
-
- (remove-hook 'post-command-hook 'rcirc-window-configuration-change-1))
+ (rcirc-update-activity-string))))
;;; buffer name abbreviation
@@ -2494,24 +2490,26 @@ If ARG is given, opens the URL in a new browser window."
(rcirc-record-activity (current-buffer) 'nick)))))
(defun rcirc-markup-urls (_sender _response)
- (while (and rcirc-url-regexp ;; nil means disable URL catching
+ (while (and rcirc-url-regexp ; nil means disable URL catching.
(re-search-forward rcirc-url-regexp nil t))
(let* ((start (match-beginning 0))
- (end (match-end 0))
- (url (match-string-no-properties 0))
- (link-text (buffer-substring-no-properties start end)))
+ (url (buffer-substring-no-properties start (point))))
+ (when rcirc-url-max-length
+ ;; Replace match with truncated URL.
+ (delete-region start (point))
+ (insert (url-truncate-url-for-viewing url rcirc-url-max-length)))
;; Add a button for the URL. Note that we use `make-text-button',
;; rather than `make-button', as text-buttons are much faster in
;; large buffers.
- (make-text-button start end
+ (make-text-button start (point)
'face 'rcirc-url
'follow-link t
'rcirc-url url
'action (lambda (button)
(browse-url (button-get button 'rcirc-url))))
- ;; record the url if it is not already the latest stored url
- (when (not (string= link-text (caar rcirc-urls)))
- (push (cons link-text start) rcirc-urls)))))
+ ;; Record the URL if it is not already the latest stored URL.
+ (unless (string= url (caar rcirc-urls))
+ (push (cons url start) rcirc-urls)))))
(defun rcirc-markup-keywords (sender response)
(when (and (string= response "PRIVMSG")
@@ -2796,11 +2794,8 @@ the only argument."
"RPL_WHOISIDLE"
(let* ((nick (nth 1 args))
(idle-secs (string-to-number (nth 2 args)))
- (idle-string
- (if (< idle-secs most-positive-fixnum)
- (format-seconds "%yy %dd %hh %mm %z%ss" idle-secs)
- "a very long time"))
- (signon-time (seconds-to-time (string-to-number (nth 3 args))))
+ (idle-string (format-seconds "%yy %dd %hh %mm %z%ss" idle-secs))
+ (signon-time (string-to-number (nth 3 args)))
(signon-string (format-time-string "%c" signon-time))
(message (format "%s idle for %s, signed on %s"
nick idle-string signon-string)))
@@ -2821,8 +2816,7 @@ Not in rfc1459.txt"
(with-current-buffer buffer
(let ((setter (nth 2 args))
(time (current-time-string
- (seconds-to-time
- (string-to-number (cl-cadddr args))))))
+ (string-to-number (cl-cadddr args)))))
(rcirc-print process sender "TOPIC" (cadr args)
(format "%s (%s on %s)" rcirc-topic setter time))))))
diff --git a/lisp/net/rfc2104.el b/lisp/net/rfc2104.el
index 3b000399b99..68c35aa3130 100644
--- a/lisp/net/rfc2104.el
+++ b/lisp/net/rfc2104.el
@@ -1,4 +1,4 @@
-;;; rfc2104.el --- RFC2104 Hashed Message Authentication Codes
+;;; rfc2104.el --- RFC2104 Hashed Message Authentication Codes -*- lexical-binding:t -*-
;; Copyright (C) 1998-2019 Free Software Foundation, Inc.
@@ -55,7 +55,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
;; Magic character for inner HMAC round. 0x36 == 54 == '6'
(defconst rfc2104-ipad ?\x36)
@@ -101,7 +101,7 @@ In XEmacs return just STRING."
(opad (make-string (+ block-length hash-length) rfc2104-opad))
c partial)
;; Prefix *pad with key, appropriately XORed.
- (do ((i 0 (1+ i)))
+ (cl-do ((i 0 (1+ i)))
((= len i))
(setq c (aref key i))
(aset ipad i (logxor rfc2104-ipad c))
@@ -110,8 +110,8 @@ In XEmacs return just STRING."
(setq partial (rfc2104-string-make-unibyte
(funcall hash (concat ipad text))))
;; Pack latter part of opad.
- (do ((r 0 (+ 2 r))
- (w block-length (1+ w)))
+ (cl-do ((r 0 (+ 2 r))
+ (w block-length (1+ w)))
((= (* 2 hash-length) r))
(aset opad w
(+ (* 16 (aref rfc2104-nybbles (aref partial r)))
diff --git a/lisp/net/rlogin.el b/lisp/net/rlogin.el
index f73638699d4..bf6f5359aad 100644
--- a/lisp/net/rlogin.el
+++ b/lisp/net/rlogin.el
@@ -1,4 +1,4 @@
-;;; rlogin.el --- remote login interface
+;;; rlogin.el --- remote login interface -*- lexical-binding:t -*-
;; Copyright (C) 1992-1995, 1997-1998, 2001-2019 Free Software
;; Foundation, Inc.
@@ -30,9 +30,9 @@
;; tracking and the sending of some special characters.
;; If you wish for rlogin mode to prompt you in the minibuffer for
-;; passwords when a password prompt appears, just enter m-x send-invisible
-;; and type in your line, or add `comint-watch-for-password-prompt' to
-;; `comint-output-filter-functions'.
+;; passwords when a password prompt appears, just enter
+;; M-x comint-send-invisible and type in your line (or tweak
+;; `comint-password-prompt-regexp' to match your password prompt).
;;; Code:
diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el
index e67a5a915fa..492f6574e7f 100644
--- a/lisp/net/sasl.el
+++ b/lisp/net/sasl.el
@@ -183,7 +183,7 @@ It contain at least 64 bits of entropy."
;; Don't use microseconds from (current-time), they may be unsupported.
;; Instead we use this randomly inited counter.
(setq sasl-unique-id-char
- (% (1+ (or sasl-unique-id-char (logand (random) (1- (lsh 1 20)))))
+ (% (1+ (or sasl-unique-id-char (logand (random) (1- (ash 1 20)))))
;; (current-time) returns 16-bit ints,
;; and 2^16*25 just fits into 4 digits i base 36.
(* 25 25)))
@@ -191,10 +191,10 @@ It contain at least 64 bits of entropy."
(concat
(sasl-unique-id-number-base36
(+ (car tm)
- (lsh (% sasl-unique-id-char 25) 16)) 4)
+ (ash (% sasl-unique-id-char 25) 16)) 4)
(sasl-unique-id-number-base36
(+ (nth 1 tm)
- (lsh (/ sasl-unique-id-char 25) 16)) 4))))
+ (ash (/ sasl-unique-id-char 25) 16)) 4))))
(defun sasl-unique-id-number-base36 (num len)
(if (if (< len 0)
diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el
index e8d2091296a..5d294ce2c51 100644
--- a/lisp/net/secrets.el
+++ b/lisp/net/secrets.el
@@ -158,7 +158,7 @@
(defvar secrets-enabled nil
"Whether there is a daemon offering the Secret Service API.")
-(defvar secrets-debug t
+(defvar secrets-debug nil
"Write debug messages")
(defconst secrets-service "org.freedesktop.secrets"
@@ -331,9 +331,7 @@ It returns t if not."
;; Properties.
`(:array
(:dict-entry ,(concat secrets-interface-item ".Label")
- (:variant "dummy"))
- (:dict-entry ,(concat secrets-interface-item ".Type")
- (:variant ,secrets-interface-item-type-generic)))
+ (:variant " ")))
;; Secret.
`(:struct :object-path ,path
(:array :signature "y")
@@ -539,6 +537,18 @@ For the time being, only the alias \"default\" is supported."
secrets-interface-service "SetAlias"
alias :object-path secrets-empty-path))
+(defun secrets-lock-collection (collection)
+ "Lock collection labeled COLLECTION.
+If successful, return the object path of the collection."
+ (let ((collection-path (secrets-collection-path collection)))
+ (unless (secrets-empty-path collection-path)
+ (secrets-prompt
+ (cadr
+ (dbus-call-method
+ :session secrets-service secrets-path secrets-interface-service
+ "Lock" `(:array :object-path ,collection-path)))))
+ collection-path))
+
(defun secrets-unlock-collection (collection)
"Unlock collection labeled COLLECTION.
If successful, return the object path of the collection."
@@ -565,7 +575,6 @@ If successful, return the object path of the collection."
(defun secrets-get-items (collection-path)
"Return the object paths of all available items in COLLECTION-PATH."
(unless (secrets-empty-path collection-path)
- (secrets-open-session)
(dbus-get-property
:session secrets-service collection-path
secrets-interface-collection "Items")))
@@ -593,16 +602,16 @@ If successful, return the object path of the collection."
(secrets-get-item-property item-path "Label"))
(secrets-get-items collection-path)))))
-(defun secrets-search-items (collection &rest attributes)
+(defun secrets-search-item-paths (collection &rest attributes)
"Search items in COLLECTION with ATTRIBUTES.
ATTRIBUTES are key-value pairs. The keys are keyword symbols,
starting with a colon. Example:
- (secrets-search-items \"Tramp collection\" :user \"joe\")
+ (secrets-search-item-paths \"Tramp collection\" :user \"joe\")
-The object labels of the found items are returned as list."
+The object paths of the found items are returned as list."
(let ((collection-path (secrets-unlock-collection collection))
- result props)
+ props)
(unless (secrets-empty-path collection-path)
;; Create attributes list.
(while (consp (cdr attributes))
@@ -617,84 +626,109 @@ The object labels of the found items are returned as list."
,(cadr attributes))))
attributes (cddr attributes)))
;; Search. The result is a list of object paths.
- (setq result
- (dbus-call-method
- :session secrets-service collection-path
- secrets-interface-collection "SearchItems"
- (if props
- (cons :array props)
- '(:array :signature "{ss}"))))
- ;; Return the found items.
- (mapcar
- (lambda (item-path) (secrets-get-item-property item-path "Label"))
- result))))
+ (dbus-call-method
+ :session secrets-service collection-path
+ secrets-interface-collection "SearchItems"
+ (if props
+ (cons :array props)
+ '(:array :signature "{ss}"))))))
+
+(defun secrets-search-items (collection &rest attributes)
+ "Search items in COLLECTION with ATTRIBUTES.
+ATTRIBUTES are key-value pairs. The keys are keyword symbols,
+starting with a colon. Example:
+
+ (secrets-search-items \"Tramp collection\" :user \"joe\")
+
+The object labels of the found items are returned as list."
+ (mapcar
+ (lambda (item-path) (secrets-get-item-property item-path "Label"))
+ (apply 'secrets-search-item-paths collection attributes)))
(defun secrets-create-item (collection item password &rest attributes)
"Create a new item in COLLECTION with label ITEM and password PASSWORD.
+The label ITEM does not have to be unique in COLLECTION.
ATTRIBUTES are key-value pairs set for the created item. The
keys are keyword symbols, starting with a colon. Example:
(secrets-create-item \"Tramp collection\" \"item\" \"geheim\"
:method \"sudo\" :user \"joe\" :host \"remote-host\")
+The key `:xdg:schema' determines the scope of the item to be
+generated, i.e. for which applications the item is intended for.
+This is just a string like \"org.freedesktop.NetworkManager.Mobile\"
+or \"org.gnome.OnlineAccounts\", the other required keys are
+determined by this. If no `:xdg:schema' is given,
+\"org.freedesktop.Secret.Generic\" is used by default.
+
The object path of the created item is returned."
- (unless (member item (secrets-list-items collection))
- (let ((collection-path (secrets-unlock-collection collection))
- result props)
- (unless (secrets-empty-path collection-path)
- ;; Create attributes list.
- (while (consp (cdr attributes))
- (unless (keywordp (car attributes))
- (error 'wrong-type-argument (car attributes)))
- (unless (stringp (cadr attributes))
- (error 'wrong-type-argument (cadr attributes)))
- (setq props (append
- props
- `((:dict-entry
- ,(substring (symbol-name (car attributes)) 1)
- ,(cadr attributes))))
- attributes (cddr attributes)))
- ;; Create the item.
- (setq result
- (dbus-call-method
- :session secrets-service collection-path
- secrets-interface-collection "CreateItem"
- ;; Properties.
- (append
- `(:array
- (:dict-entry ,(concat secrets-interface-item ".Label")
- (:variant ,item))
- (:dict-entry ,(concat secrets-interface-item ".Type")
- (:variant ,secrets-interface-item-type-generic)))
- (when props
- `((:dict-entry ,(concat secrets-interface-item ".Attributes")
- (:variant ,(append '(:array) props))))))
- ;; Secret.
- (append
- `(:struct :object-path ,secrets-session-path
- (:array :signature "y") ;; No parameters.
- ,(dbus-string-to-byte-array password))
- ;; We add the content_type. In backward compatibility
- ;; mode, nil is appended, which means nothing.
- secrets-struct-secret-content-type)
- ;; Do not replace. Replace does not seem to work.
- nil))
- (secrets-prompt (cadr result))
- ;; Return the object path.
- (car result)))))
+ (let ((collection-path (secrets-unlock-collection collection))
+ result props)
+ (unless (secrets-empty-path collection-path)
+ ;; Set default type if needed.
+ (unless (member :xdg:schema attributes)
+ (setq attributes
+ (append
+ attributes `(:xdg:schema ,secrets-interface-item-type-generic))))
+ ;; Create attributes list.
+ (while (consp (cdr attributes))
+ (unless (keywordp (car attributes))
+ (error 'wrong-type-argument (car attributes)))
+ (unless (stringp (cadr attributes))
+ (error 'wrong-type-argument (cadr attributes)))
+ (setq props (append
+ props
+ `((:dict-entry
+ ,(substring (symbol-name (car attributes)) 1)
+ ,(cadr attributes))))
+ attributes (cddr attributes)))
+ ;; Create the item.
+ (setq result
+ (dbus-call-method
+ :session secrets-service collection-path
+ secrets-interface-collection "CreateItem"
+ ;; Properties.
+ (append
+ `(:array
+ (:dict-entry ,(concat secrets-interface-item ".Label")
+ (:variant ,item)))
+ (when props
+ `((:dict-entry ,(concat secrets-interface-item ".Attributes")
+ (:variant ,(append '(:array) props))))))
+ ;; Secret.
+ (append
+ `(:struct :object-path ,secrets-session-path
+ (:array :signature "y") ;; No parameters.
+ ,(dbus-string-to-byte-array password))
+ ;; We add the content_type. In backward compatibility
+ ;; mode, nil is appended, which means nothing.
+ secrets-struct-secret-content-type)
+ ;; Do not replace. Replace does not seem to work.
+ nil))
+ (secrets-prompt (cadr result))
+ ;; Return the object path.
+ (car result))))
(defun secrets-item-path (collection item)
"Return the object path of item labeled ITEM in COLLECTION.
-If there is no such item, return nil."
+If there are several items labeled ITEM, it is undefined which
+one is returned. If there is no such item, return nil.
+
+ITEM can also be an object path, which is returned if contained in COLLECTION."
(let ((collection-path (secrets-unlock-collection collection)))
- (catch 'item-found
- (dolist (item-path (secrets-get-items collection-path))
- (when (string-equal item (secrets-get-item-property item-path "Label"))
- (throw 'item-found item-path))))))
+ (or (and (member item (secrets-get-items collection-path)) item)
+ (catch 'item-found
+ (dolist (item-path (secrets-get-items collection-path))
+ (when (string-equal
+ item (secrets-get-item-property item-path "Label"))
+ (throw 'item-found item-path)))))))
(defun secrets-get-secret (collection item)
"Return the secret of item labeled ITEM in COLLECTION.
-If there is no such item, return nil."
+If there are several items labeled ITEM, it is undefined which
+one is returned. If there is no such item, return nil.
+
+ITEM can also be an object path, which is used if contained in COLLECTION."
(let ((item-path (secrets-item-path collection item)))
(unless (secrets-empty-path item-path)
(dbus-byte-array-to-string
@@ -705,8 +739,11 @@ If there is no such item, return nil."
(defun secrets-get-attributes (collection item)
"Return the lookup attributes of item labeled ITEM in COLLECTION.
-If there is no such item, or the item has no attributes, return nil."
- (unless (stringp collection) (setq collection "default"))
+If there are several items labeled ITEM, it is undefined which
+one is returned. If there is no such item, or the item has no
+attributes, return nil.
+
+ITEM can also be an object path, which is used if contained in COLLECTION."
(let ((item-path (secrets-item-path collection item)))
(unless (secrets-empty-path item-path)
(mapcar
@@ -718,11 +755,19 @@ If there is no such item, or the item has no attributes, return nil."
(defun secrets-get-attribute (collection item attribute)
"Return the value of ATTRIBUTE of item labeled ITEM in COLLECTION.
-If there is no such item, or the item doesn't own this attribute, return nil."
+If there are several items labeled ITEM, it is undefined which
+one is returned. If there is no such item, or the item doesn't
+own this attribute, return nil.
+
+ITEM can also be an object path, which is used if contained in COLLECTION."
(cdr (assoc attribute (secrets-get-attributes collection item))))
(defun secrets-delete-item (collection item)
- "Delete ITEM in COLLECTION."
+ "Delete item labeled ITEM in COLLECTION.
+If there are several items labeled ITEM, it is undefined which
+one is deleted.
+
+ITEM can also be an object path, which is used if contained in COLLECTION."
(let ((item-path (secrets-item-path collection item)))
(unless (secrets-empty-path item-path)
(secrets-prompt
@@ -872,6 +917,8 @@ to their attributes."
(when (dbus-ping :session secrets-service 100)
+ (secrets-open-session)
+
;; We must reset all variables, when there is a new instance of the
;; "org.freedesktop.secrets" service.
(dbus-register-signal
diff --git a/lisp/net/shr-color.el b/lisp/net/shr-color.el
index fcc307b929c..2d6cf68d8ff 100644
--- a/lisp/net/shr-color.el
+++ b/lisp/net/shr-color.el
@@ -1,4 +1,4 @@
-;;; shr-color.el --- Simple HTML Renderer color management
+;;; shr-color.el --- Simple HTML Renderer color management -*- lexical-binding:t -*-
;; Copyright (C) 2010-2019 Free Software Foundation, Inc.
@@ -27,7 +27,7 @@
;;; Code:
(require 'color)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defgroup shr-color nil
"Simple HTML Renderer colors"
@@ -210,8 +210,8 @@ This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\"."
(defun shr-color-hue-to-rgb (x y h)
"Convert X Y H to RGB value."
- (when (< h 0) (incf h))
- (when (> h 1) (decf h))
+ (when (< h 0) (cl-incf h))
+ (when (> h 1) (cl-decf h))
(cond ((< h (/ 6.0)) (+ x (* (- y x) h 6)))
((< h 0.5) y)
((< h (/ 2.0 3.0)) (+ x (* (- y x) (- (/ 2.0 3.0) h) 6)))
@@ -259,8 +259,7 @@ Like rgb() or hsl()."
(let ((h (/ (string-to-number (match-string-no-properties 1 color)) 360.0))
(s (/ (string-to-number (match-string-no-properties 2 color)) 100.0))
(l (/ (string-to-number (match-string-no-properties 3 color)) 100.0)))
- (destructuring-bind (r g b)
- (shr-color-hsl-to-rgb-fractions h s l)
+ (pcase-let ((`(,r ,g ,b) (shr-color-hsl-to-rgb-fractions h s l)))
(color-rgb-to-hex r g b 2))))
;; Color names
((cdr (assoc-string color shr-color-html-colors-alist t)))
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 4e584e131fa..2f628e1caa2 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -30,7 +30,7 @@
;;; Code:
-(eval-when-compile (require 'cl-lib))
+(require 'cl-lib)
(eval-when-compile (require 'url)) ;For url-filename's setf handler.
(require 'browse-url)
(eval-when-compile (require 'subr-x))
@@ -38,6 +38,8 @@
(require 'seq)
(require 'svg)
(require 'image)
+(require 'puny)
+(require 'text-property-search)
(defgroup shr nil
"Simple HTML Renderer"
@@ -66,6 +68,13 @@ fit these criteria."
:group 'shr
:type 'boolean)
+(defcustom shr-discard-aria-hidden nil
+ "If non-nil, don't render tags with `aria-hidden=\"true\"'.
+This attribute is meant to tell screen readers to ignore a tag."
+ :version "27.1"
+ :group 'shr
+ :type 'boolean)
+
(defcustom shr-use-colors t
"If non-nil, respect color specifications in the HTML."
:version "26.1"
@@ -133,13 +142,21 @@ cid: URL as the argument.")
(defvar shr-put-image-function 'shr-put-image
"Function called to put image and alt string.")
-(defface shr-strike-through '((t (:strike-through t)))
- "Font for <s> elements."
+(defface shr-strike-through '((t :strike-through t))
+ "Face for <s> elements."
+ :version "24.1"
:group 'shr)
(defface shr-link
- '((t (:inherit link)))
- "Font for link elements."
+ '((t :inherit link))
+ "Face for link elements."
+ :version "24.1"
+ :group 'shr)
+
+(defface shr-selected-link
+ '((t :inherit shr-link :background "red"))
+ "Face for link elements."
+ :version "27.1"
:group 'shr)
(defvar shr-inhibit-images nil
@@ -267,7 +284,9 @@ DOM should be a parse tree as generated by
(if (and (null shr-width)
(not (shr--have-one-fringe-p)))
(* (frame-char-width) 2)
- 0)))))
+ 0)
+ 1))))
+ (max-specpdl-size max-specpdl-size)
bidi-display-reordering)
;; If the window was hscrolled for some reason, shr-fill-lines
;; below will misbehave, because it silently assumes that it
@@ -344,52 +363,45 @@ If the URL is already at the front of the kill ring act like
(shr-probe-and-copy-url url)
(shr-copy-url url)))
+(defun shr--current-link-region ()
+ (let ((current (get-text-property (point) 'shr-url))
+ start)
+ (save-excursion
+ ;; Go to the beginning.
+ (while (and (not (bobp))
+ (equal (get-text-property (point) 'shr-url) current))
+ (forward-char -1))
+ (unless (equal (get-text-property (point) 'shr-url) current)
+ (forward-char 1))
+ (setq start (point))
+ ;; Go to the end.
+ (while (and (not (eobp))
+ (equal (get-text-property (point) 'shr-url) current))
+ (forward-char 1))
+ (list start (point)))))
+
+(defun shr--blink-link ()
+ (let* ((region (shr--current-link-region))
+ (overlay (make-overlay (car region) (cadr region))))
+ (overlay-put overlay 'face 'shr-selected-link)
+ (run-at-time 1 nil (lambda ()
+ (delete-overlay overlay)))))
+
(defun shr-next-link ()
"Skip to the next link."
(interactive)
- (let ((current (get-text-property (point) 'shr-url))
- (start (point))
- skip)
- (while (and (not (eobp))
- (equal (get-text-property (point) 'shr-url) current))
- (forward-char 1))
- (cond
- ((and (not (eobp))
- (get-text-property (point) 'shr-url))
- ;; The next link is adjacent.
- (message "%s" (get-text-property (point) 'help-echo)))
- ((or (eobp)
- (not (setq skip (text-property-not-all (point) (point-max)
- 'shr-url nil))))
- (goto-char start)
- (message "No next link"))
- (t
- (goto-char skip)
- (message "%s" (get-text-property (point) 'help-echo))))))
+ (let ((match (text-property-search-forward 'shr-url nil nil t)))
+ (if (not match)
+ (message "No next link")
+ (goto-char (prop-match-beginning match))
+ (message "%s" (get-text-property (point) 'help-echo)))))
(defun shr-previous-link ()
"Skip to the previous link."
(interactive)
- (let ((start (point))
- (found nil))
- ;; Skip past the current link.
- (while (and (not (bobp))
- (get-text-property (point) 'help-echo))
- (forward-char -1))
- ;; Find the previous link.
- (while (and (not (bobp))
- (not (setq found (get-text-property (point) 'help-echo))))
- (forward-char -1))
- (if (not found)
- (progn
- (message "No previous link")
- (goto-char start))
- ;; Put point at the start of the link.
- (while (and (not (bobp))
- (get-text-property (point) 'help-echo))
- (forward-char -1))
- (forward-char 1)
- (message "%s" (get-text-property (point) 'help-echo)))))
+ (if (not (text-property-search-backward 'shr-url nil nil t))
+ (message "No previous link")
+ (message "%s" (get-text-property (point) 'help-echo))))
(defun shr-show-alt-text ()
"Show the ALT text of the image under point."
@@ -493,15 +505,20 @@ size, and full-buffer size."
(shr-depth (1+ shr-depth))
(start (point)))
;; shr uses many frames per nested node.
- (if (> shr-depth (/ max-specpdl-size 15))
- (setq shr-warning "Too deeply nested to render properly; consider increasing `max-specpdl-size'")
+ (if (and (> shr-depth (/ max-specpdl-size 15))
+ (not (and (y-or-n-p "Too deeply nested to render properly; increase `max-specpdl-size'?")
+ (setq max-specpdl-size (* max-specpdl-size 2)))))
+ (setq shr-warning
+ "Not rendering the complete page because of too-deep nesting")
(when style
(if (string-match "color\\|display\\|border-collapse" style)
(setq shr-stylesheet (nconc (shr-parse-style style)
shr-stylesheet))
(setq style nil)))
;; If we have a display:none, then just ignore this part of the DOM.
- (unless (equal (cdr (assq 'display shr-stylesheet)) "none")
+ (unless (or (equal (cdr (assq 'display shr-stylesheet)) "none")
+ (and shr-discard-aria-hidden
+ (equal (dom-attr dom 'aria-hidden) "true")))
;; We don't use shr-indirect-call here, since shr-descend is
;; the central bit of shr.el, and should be as fast as
;; possible. Having one more level of indirection with its
@@ -689,37 +706,47 @@ size, and full-buffer size."
`,(shr-face-background face))))
(setq start (point))
(setq shr-indentation (or continuation shr-indentation))
- (shr-vertical-motion shr-internal-width)
- (when (looking-at " $")
- (delete-region (point) (line-end-position)))
- (while (not (eolp))
- ;; We have to do some folding. First find the first
- ;; previous point suitable for folding.
- (if (or (not (shr-find-fill-point (line-beginning-position)))
- (= (point) start))
- ;; We had unbreakable text (for this width), so just go to
- ;; the first space and carry on.
- (progn
- (beginning-of-line)
- (skip-chars-forward " ")
- (search-forward " " (line-end-position) 'move)))
- ;; Success; continue.
- (when (= (preceding-char) ?\s)
- (delete-char -1))
- (let ((props `(face ,(get-text-property (point) 'face)
- ;; Don't break the image-displayer property
- ;; as it will cause `gnus-article-show-images'
- ;; to show the two or more same images.
- image-displayer
- ,(get-text-property (point) 'image-displayer)))
- (gap-start (point)))
- (insert "\n")
- (shr-indent)
- (add-text-properties gap-start (point) props))
- (setq start (point))
+ ;; If we have an indentation that's wider than the width we're
+ ;; trying to fill to, then just give up and don't do any filling.
+ (when (< shr-indentation shr-internal-width)
(shr-vertical-motion shr-internal-width)
(when (looking-at " $")
- (delete-region (point) (line-end-position))))))
+ (delete-region (point) (line-end-position)))
+ (while (not (eolp))
+ ;; We have to do some folding. First find the first
+ ;; previous point suitable for folding.
+ (if (or (not (shr-find-fill-point (line-beginning-position)))
+ (= (point) start))
+ ;; We had unbreakable text (for this width), so just go to
+ ;; the first space and carry on.
+ (progn
+ (beginning-of-line)
+ (skip-chars-forward " ")
+ (search-forward " " (line-end-position) 'move)))
+ ;; Success; continue.
+ (when (= (preceding-char) ?\s)
+ (delete-char -1))
+ (let ((gap-start (point)))
+ (insert "\n")
+ (shr-indent)
+ (when (and (> (1- gap-start) (point-min))
+ ;; The link on both sides of the newline are the
+ ;; same...
+ (equal (get-text-property (point) 'shr-url)
+ (get-text-property (1- gap-start) 'shr-url)))
+ ;; ... so we join the two bits into one link logically, but
+ ;; not visually. This makes navigation between links work
+ ;; well, but avoids underscores before the link on the next
+ ;; line when indented.
+ (let ((props (copy-sequence (text-properties-at (point)))))
+ ;; We don't want to use the faces on the indentation, because
+ ;; that's ugly.
+ (setq props (plist-put props 'face nil))
+ (add-text-properties gap-start (point) props))))
+ (setq start (point))
+ (shr-vertical-motion shr-internal-width)
+ (when (looking-at " $")
+ (delete-region (point) (line-end-position)))))))
(defun shr-find-fill-point (start)
(let ((bp (point))
@@ -950,7 +977,9 @@ the mouse click event."
(browse-url-mail url))
(t
(if external
- (funcall shr-external-browser url)
+ (progn
+ (funcall shr-external-browser url)
+ (shr--blink-link))
(browse-url url))))))
(defun shr-save-contents (directory)
@@ -1178,12 +1207,24 @@ START, and END. Note that START and END should be markers."
(add-text-properties
start (point)
(list 'shr-url url
- 'help-echo (let ((iri (or (ignore-errors
- (decode-coding-string
- (url-unhex-string url)
- 'utf-8 t))
- url)))
- (if title (format "%s (%s)" iri title) iri))
+ 'help-echo (let ((parsed (url-generic-parse-url
+ (or (ignore-errors
+ (decode-coding-string
+ (url-unhex-string url)
+ 'utf-8 t))
+ url)))
+ iri)
+ ;; If we have an IDNA domain, then show the
+ ;; decoded version in the mouseover to let the
+ ;; user know that there's something possibly
+ ;; fishy.
+ (when (url-host parsed)
+ (setf (url-host parsed)
+ (puny-encode-domain (url-host parsed))))
+ (setq iri (url-recreate-url parsed))
+ (if title
+ (format "%s (%s)" iri title)
+ iri))
'follow-link t
'mouse-face 'highlight))
;; Don't overwrite any keymaps that are already in the buffer (i.e.,
@@ -1319,19 +1360,19 @@ ones, in case fg and bg are nil."
(shr-generic dom)
(put-text-property start (point) 'display '(raise -0.5))))
-(defun shr-tag-label (dom)
- (shr-generic dom)
- (shr-ensure-paragraph))
-
(defun shr-tag-p (dom)
(shr-ensure-paragraph)
(shr-generic dom)
(shr-ensure-paragraph))
(defun shr-tag-div (dom)
- (shr-ensure-newline)
- (shr-generic dom)
- (shr-ensure-newline))
+ (let ((display (cdr (assq 'display shr-stylesheet))))
+ (if (or (equal display "inline")
+ (equal display "inline-block"))
+ (shr-generic dom)
+ (shr-ensure-newline)
+ (shr-generic dom)
+ (shr-ensure-newline))))
(defun shr-tag-s (dom)
(shr-fontize-dom dom 'shr-strike-through))
@@ -1528,6 +1569,10 @@ The preference is a float determined from `shr-prefer-media-type'."
(when (zerop (length alt))
(setq alt "*"))
(cond
+ ((null url)
+ ;; After further expansion, there turned out to be no valid
+ ;; src in the img after all.
+ )
((or (member (dom-attr dom 'height) '("0" "1"))
(member (dom-attr dom 'width) '("0" "1")))
;; Ignore zero-sized or single-pixel images.
@@ -1710,7 +1755,14 @@ The preference is a float determined from `shr-prefer-media-type'."
(defun shr-tag-ol (dom)
(shr-ensure-paragraph)
- (let ((shr-list-mode 1))
+ (let* ((attrs (dom-attributes dom))
+ (start-attr (alist-get 'start attrs))
+ ;; Start at 1 if there is no start attribute
+ ;; or if start can't be parsed as an integer.
+ (start-index (condition-case _
+ (cl-parse-integer start-attr)
+ (t 1)))
+ (shr-list-mode start-index))
(shr-generic dom))
(shr-ensure-paragraph))
diff --git a/lisp/net/sieve-manage.el b/lisp/net/sieve-manage.el
index 18a3dcc4c09..72731b8fdae 100644
--- a/lisp/net/sieve-manage.el
+++ b/lisp/net/sieve-manage.el
@@ -1,4 +1,4 @@
-;;; sieve-manage.el --- Implementation of the managesieve protocol in elisp
+;;; sieve-manage.el --- Implementation of the managesieve protocol in elisp -*- lexical-binding:t -*-
;; Copyright (C) 2001-2019 Free Software Foundation, Inc.
@@ -75,9 +75,8 @@
(require 'password-cache)
(require 'password))
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'sasl)
-(require 'starttls)
(autoload 'sasl-find-mechanism "sasl")
(autoload 'auth-source-search "auth-source")
@@ -182,7 +181,7 @@ Valid states are `closed', `initial', `nonauth', and `auth'.")
(generate-new-buffer (format " *sieve %s:%s*"
sieve-manage-server
sieve-manage-port))
- (mapc 'make-local-variable sieve-manage-local-variables)
+ (mapc #'make-local-variable sieve-manage-local-variables)
(mm-enable-multibyte)
(buffer-disable-undo)
(current-buffer)))
@@ -206,19 +205,19 @@ Return the buffer associated with the connection."
(with-current-buffer buffer
(sieve-manage-erase)
(setq sieve-manage-state 'initial)
- (destructuring-bind (proc . props)
- (open-network-stream
- "SIEVE" buffer server port
- :type stream
- :capability-command "CAPABILITY\r\n"
- :end-of-command "^\\(OK\\|NO\\).*\n"
- :success "^OK.*\n"
- :return-list t
- :starttls-function
- (lambda (capabilities)
- (when (and (not sieve-manage-ignore-starttls)
- (string-match "\\bSTARTTLS\\b" capabilities))
- "STARTTLS\r\n")))
+ (pcase-let ((`(,proc . ,props)
+ (open-network-stream
+ "SIEVE" buffer server port
+ :type stream
+ :capability-command "CAPABILITY\r\n"
+ :end-of-command "^\\(OK\\|NO\\).*\n"
+ :success "^OK.*\n"
+ :return-list t
+ :starttls-function
+ (lambda (capabilities)
+ (when (and (not sieve-manage-ignore-starttls)
+ (string-match "\\bSTARTTLS\\b" capabilities))
+ "STARTTLS\r\n")))))
(setq sieve-manage-process proc)
(setq sieve-manage-capability
(sieve-manage-parse-capability (plist-get props :capabilities)))
@@ -250,7 +249,7 @@ Return the buffer associated with the connection."
;; somehow.
`(lambda (prompt) ,(copy-sequence user-password)))
(step (sasl-next-step client nil))
- (tag (sieve-manage-send
+ (_tag (sieve-manage-send
(concat
"AUTHENTICATE \""
mech
@@ -373,11 +372,11 @@ to work in."
;; Choose authenticator
(when (and (null sieve-manage-auth)
(not (eq sieve-manage-state 'auth)))
- (dolist (auth sieve-manage-authenticators)
+ (cl-dolist (auth sieve-manage-authenticators)
(when (funcall (nth 1 (assq auth sieve-manage-authenticator-alist))
buffer)
(setq sieve-manage-auth auth)
- (return)))
+ (cl-return)))
(unless sieve-manage-auth
(error "Couldn't figure out authenticator for server")))
(sieve-manage-erase)
diff --git a/lisp/net/sieve-mode.el b/lisp/net/sieve-mode.el
index 774047f3aa8..adab010257f 100644
--- a/lisp/net/sieve-mode.el
+++ b/lisp/net/sieve-mode.el
@@ -100,23 +100,20 @@
(defconst sieve-font-lock-keywords
(eval-when-compile
- (list
- ;; control commands
- (cons (regexp-opt '("require" "if" "else" "elsif" "stop")
- 'words)
- 'sieve-control-commands)
- ;; action commands
- (cons (regexp-opt '("fileinto" "redirect" "reject" "keep" "discard")
- 'words)
- 'sieve-action-commands)
- ;; test commands
- (cons (regexp-opt '("address" "allof" "anyof" "exists" "false"
- "true" "header" "not" "size" "envelope"
- "body")
- 'words)
- 'sieve-test-commands)
- (cons "\\Sw+:\\sw+"
- 'sieve-tagged-arguments))))
+ `(
+ ;; control commands
+ (,(regexp-opt '("require" "if" "else" "elsif" "stop") 'words)
+ . 'sieve-control-commands)
+ ;; action commands
+ (,(regexp-opt '("fileinto" "redirect" "reject" "keep" "discard") 'words)
+ . 'sieve-action-commands)
+ ;; test commands
+ (,(regexp-opt '("address" "allof" "anyof" "exists" "false"
+ "true" "header" "not" "size" "envelope"
+ "body")
+ 'words)
+ . 'sieve-test-commands)
+ ("\\Sw+:\\sw+" . 'sieve-tagged-arguments))))
;; Syntax table
diff --git a/lisp/net/sieve.el b/lisp/net/sieve.el
index 0e14af2cc84..d237c1e7c42 100644
--- a/lisp/net/sieve.el
+++ b/lisp/net/sieve.el
@@ -345,11 +345,14 @@ Used to bracket operations which move point in the sieve-buffer."
;;;###autoload
(defun sieve-upload (&optional name)
(interactive)
- (when (or (get-buffer sieve-buffer) (call-interactively 'sieve-manage))
- (let ((script (buffer-string)) err)
+ (when (or (get-buffer sieve-buffer)
+ (save-current-buffer (call-interactively 'sieve-manage)))
+ (let ((script (buffer-string))
+ (script-name (file-name-sans-extension (buffer-name)))
+ err)
(with-current-buffer (get-buffer sieve-buffer)
(setq err (sieve-manage-putscript
- (or name sieve-buffer-script-name (buffer-name))
+ (or name sieve-buffer-script-name script-name)
script sieve-manage-buffer))
(if (sieve-manage-ok-p err)
(message (substitute-command-keys
diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el
index 64c2b9a2367..1632ee13758 100644
--- a/lisp/net/soap-client.el
+++ b/lisp/net/soap-client.el
@@ -5,7 +5,7 @@
;; Author: Alexandru Harsanyi <AlexHarsanyi@gmail.com>
;; Author: Thomas Fitzsimmons <fitzsim@fitzsim.org>
;; Created: December, 2009
-;; Version: 3.1.4
+;; Version: 3.1.5
;; Keywords: soap, web-services, comm, hypermedia
;; Package: soap-client
;; Homepage: https://github.com/alex-hhh/emacs-soap-client
@@ -629,7 +629,7 @@ disallows them."
(<= time-zone-minute 59))
(error "Invalid or unsupported time: %s" date-time-string))
;; Return a value in a format similar to that returned by decode-time, and
- ;; suitable for (apply 'encode-time ...).
+ ;; suitable for (apply #'encode-time ...).
(list second minute hour day month year second-fraction datatype
(if has-time-zone
(* (rng-xsd-time-to-seconds
@@ -685,14 +685,17 @@ This is a specialization of `soap-decode-type' for
(anyType (soap-decode-any-type node))
(Array (soap-decode-array node))))))
-(defun soap-type-of (element)
- "Return the type of ELEMENT."
- ;; Support Emacs < 26 byte-code running in Emacs >= 26 sessions
- ;; (Bug#31742).
- (let ((type (type-of element)))
- (if (eq type 'vector)
- (aref element 0) ; For Emacs 25 and earlier.
- type)))
+(defalias 'soap-type-of
+ (if (eq 'soap-xs-basic-type (type-of (make-soap-xs-basic-type)))
+ ;; `type-of' in Emacs ≥ 26 already does what we need.
+ #'type-of
+ ;; For Emacs < 26, use our own function.
+ (lambda (element)
+ "Return the type of ELEMENT."
+ (if (vectorp element)
+ (aref element 0) ;Assume this vector is actually a struct!
+ ;; This should never happen.
+ (type-of element)))))
;; Register methods for `soap-xs-basic-type'
(let ((tag (soap-type-of (make-soap-xs-basic-type))))
@@ -2334,6 +2337,14 @@ traverse an element tree."
(defun soap-parse-server-response ()
"Error-check and parse the XML contents of the current buffer."
(let ((mime-part (mm-dissect-buffer t t)))
+ (when (and
+ (equal (mm-handle-media-type mime-part) "multipart/related")
+ (equal (get-text-property 0 'type (mm-handle-media-type mime-part))
+ "text/xml"))
+ (setq mime-part
+ (mm-make-handle
+ (get-text-property 0 'buffer (mm-handle-media-type mime-part))
+ `(,(get-text-property 0 'type (mm-handle-media-type mime-part))))))
(unless mime-part
(error "Failed to decode response from server"))
(unless (equal (car (mm-handle-type mime-part)) "text/xml")
@@ -2881,6 +2892,8 @@ reference multiRef parts which are external to RESPONSE-NODE."
;;;; SOAP type encoding
+;; FIXME: Use `cl-defmethod' (but this requires Emacs-25).
+
(defun soap-encode-attributes (value type)
"Encode XML attributes for VALUE according to TYPE.
This is a generic function which determines the attribute encoder
diff --git a/lisp/net/socks.el b/lisp/net/socks.el
index c2a8b699cd5..6356707a1db 100644
--- a/lisp/net/socks.el
+++ b/lisp/net/socks.el
@@ -1,4 +1,4 @@
-;;; socks.el --- A Socks v5 Client for Emacs
+;;; socks.el --- A Socks v5 Client for Emacs -*- lexical-binding:t -*-
;; Copyright (C) 1996-2000, 2002, 2007-2019 Free Software Foundation,
;; Inc.
@@ -32,71 +32,59 @@
;; - Implement composition of servers. Recursively evaluate the
;; redirection rules and do SOCKS-over-HTTP and SOCKS-in-SOCKS
-(eval-when-compile
- (require 'wid-edit))
-(require 'custom)
-
-(eval-and-compile
- (if (featurep 'emacs)
- (defalias 'socks-split-string 'split-string) ; since at least 21.1
- (if (fboundp 'split-string)
- (defalias 'socks-split-string 'split-string)
- (defun socks-split-string (string &optional pattern)
- "Return a list of substrings of STRING which are separated by PATTERN.
-If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
- (or pattern
- (setq pattern "[ \f\t\n\r\v]+"))
- (let (parts (start 0))
- (while (string-match pattern string start)
- (setq parts (cons (substring string start
- (match-beginning 0)) parts)
- start (match-end 0)))
- (nreverse (cons (substring string start) parts)))))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Custom widgets
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; (define-widget 'dynamic-choice 'menu-choice
-;;; "A pretty simple dynamic dropdown list"
-;;; :format "%[%t%]: %v"
-;;; :tag "Network"
-;;; :case-fold t
-;;; :void '(item :format "invalid (%t)\n")
-;;; :value-create 's5-widget-value-create
-;;; :value-delete 'widget-children-value-delete
-;;; :value-get 'widget-choice-value-get
-;;; :value-inline 'widget-choice-value-inline
-;;; :mouse-down-action 'widget-choice-mouse-down-action
-;;; :action 'widget-choice-action
-;;; :error "Make a choice"
-;;; :validate 'widget-choice-validate
-;;; :match 's5-dynamic-choice-match
-;;; :match-inline 's5-dynamic-choice-match-inline)
-;;;
-;;; (defun s5-dynamic-choice-match (widget value)
-;;; (let ((choices (funcall (widget-get widget :choice-function)))
-;;; current found)
-;;; (while (and choices (not found))
-;;; (setq current (car choices)
-;;; choices (cdr choices)
-;;; found (widget-apply current :match value)))
-;;; found))
-;;;
-;;; (defun s5-dynamic-choice-match-inline (widget value)
-;;; (let ((choices (funcall (widget-get widget :choice-function)))
-;;; current found)
-;;; (while (and choices (not found))
-;;; (setq current (car choices)
-;;; choices (cdr choices)
-;;; found (widget-match-inline current value)))
-;;; found))
-;;;
-;;; (defun s5-widget-value-create (widget)
-;;; (let ((choices (funcall (widget-get widget :choice-function)))
-;;; (value (widget-get widget :value)))
-;;; (if (not value)
-;;; (widget-put widget :value (widget-value (car choices))))
-;;; (widget-put widget :args choices)
-;;; (widget-choice-value-create widget)))
+;;; Code:
+
+(eval-when-compile (require 'cl-lib))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ;;; Custom widgets
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; (eval-when-compile
+;; (require 'wid-edit))
+
+;; (define-widget 'dynamic-choice 'menu-choice
+;; "A pretty simple dynamic dropdown list"
+;; :format "%[%t%]: %v"
+;; :tag "Network"
+;; :case-fold t
+;; :void '(item :format "invalid (%t)\n")
+;; :value-create 's5-widget-value-create
+;; :value-delete 'widget-children-value-delete
+;; :value-get 'widget-choice-value-get
+;; :value-inline 'widget-choice-value-inline
+;; :mouse-down-action 'widget-choice-mouse-down-action
+;; :action 'widget-choice-action
+;; :error "Make a choice"
+;; :validate 'widget-choice-validate
+;; :match 's5-dynamic-choice-match
+;; :match-inline 's5-dynamic-choice-match-inline)
+;;
+;; (defun s5-dynamic-choice-match (widget value)
+;; (let ((choices (funcall (widget-get widget :choice-function)))
+;; current found)
+;; (while (and choices (not found))
+;; (setq current (car choices)
+;; choices (cdr choices)
+;; found (widget-apply current :match value)))
+;; found))
+;;
+;; (defun s5-dynamic-choice-match-inline (widget value)
+;; (let ((choices (funcall (widget-get widget :choice-function)))
+;; current found)
+;; (while (and choices (not found))
+;; (setq current (car choices)
+;; choices (cdr choices)
+;; found (widget-match-inline current value)))
+;; found))
+;;
+;; (defun s5-widget-value-create (widget)
+;; (let ((choices (funcall (widget-get widget :choice-function)))
+;; (value (widget-get widget :value)))
+;; (if (not value)
+;; (widget-put widget :value (widget-value (car choices))))
+;; (widget-put widget :args choices)
+;; (widget-choice-value-create widget)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Customization support
@@ -107,70 +95,66 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
:prefix "socks-"
:group 'processes)
-;;; (defcustom socks-server-aliases nil
-;;; "A list of server aliases for use in access control and filtering rules."
-;;; :group 'socks
-;;; :type '(repeat (list :format "%v"
-;;; :value ("" "" 1080 5)
-;;; (string :tag "Alias")
-;;; (string :tag "Hostname/IP Address")
-;;; (integer :tag "Port #")
-;;; (choice :tag "SOCKS Version"
-;;; (integer :tag "SOCKS v4" :value 4)
-;;; (integer :tag "SOCKS v5" :value 5)))))
-;;;
-;;; (defcustom socks-network-aliases
-;;; '(("Anywhere" (netmask "0.0.0.0" "0.0.0.0")))
-;;; "A list of network aliases for use in subsequent rules."
-;;; :group 'socks
-;;; :type '(repeat (list :format "%v"
-;;; :value (netmask "" "255.255.255.0")
-;;; (string :tag "Alias")
-;;; (radio-button-choice
-;;; :format "%v"
-;;; (list :tag "IP address range"
-;;; (const :format "" :value range)
-;;; (string :tag "From")
-;;; (string :tag "To"))
-;;; (list :tag "IP address/netmask"
-;;; (const :format "" :value netmask)
-;;; (string :tag "IP Address")
-;;; (string :tag "Netmask"))
-;;; (list :tag "Domain Name"
-;;; (const :format "" :value domain)
-;;; (string :tag "Domain name"))
-;;; (list :tag "Unique hostname/IP address"
-;;; (const :format "" :value exact)
-;;; (string :tag "Hostname/IP Address"))))))
-;;;
-;;; (defun s5-servers-filter ()
-;;; (if socks-server-aliases
-;;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x))) s5-server-aliases)
-;;; '((const :tag "No aliases defined" :value nil))))
-;;;
-;;; (defun s5-network-aliases-filter ()
-;;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x)))
-;;; socks-network-aliases))
-;;;
-;;; (defcustom socks-redirection-rules
-;;; nil
-;;; "A list of redirection rules."
-;;; :group 'socks
-;;; :type '(repeat (list :format "%v"
-;;; :value ("Anywhere" nil)
-;;; (dynamic-choice :choice-function s5-network-aliases-filter
-;;; :tag "Destination network")
-;;; (radio-button-choice
-;;; :tag "Connection type"
-;;; (const :tag "Direct connection" :value nil)
-;;; (dynamic-choice :format "%t: %[%v%]"
-;;; :choice-function s5-servers-filter
-;;; :tag "Proxy chain via")))))
+;; (defcustom socks-server-aliases nil
+;; "A list of server aliases for use in access control and filtering rules."
+;; :type '(repeat (list :format "%v"
+;; :value ("" "" 1080 5)
+;; (string :tag "Alias")
+;; (string :tag "Hostname/IP Address")
+;; (integer :tag "Port #")
+;; (choice :tag "SOCKS Version"
+;; (integer :tag "SOCKS v4" :value 4)
+;; (integer :tag "SOCKS v5" :value 5)))))
+;;
+;; (defcustom socks-network-aliases
+;; '(("Anywhere" (netmask "0.0.0.0" "0.0.0.0")))
+;; "A list of network aliases for use in subsequent rules."
+;; :type '(repeat (list :format "%v"
+;; :value (netmask "" "255.255.255.0")
+;; (string :tag "Alias")
+;; (radio-button-choice
+;; :format "%v"
+;; (list :tag "IP address range"
+;; (const :format "" :value range)
+;; (string :tag "From")
+;; (string :tag "To"))
+;; (list :tag "IP address/netmask"
+;; (const :format "" :value netmask)
+;; (string :tag "IP Address")
+;; (string :tag "Netmask"))
+;; (list :tag "Domain Name"
+;; (const :format "" :value domain)
+;; (string :tag "Domain name"))
+;; (list :tag "Unique hostname/IP address"
+;; (const :format "" :value exact)
+;; (string :tag "Hostname/IP Address"))))))
+;;
+;; (defun s5-servers-filter ()
+;; (if socks-server-aliases
+;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x))) s5-server-aliases)
+;; '((const :tag "No aliases defined" :value nil))))
+;;
+;; (defun s5-network-aliases-filter ()
+;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x)))
+;; socks-network-aliases))
+;;
+;; (defcustom socks-redirection-rules
+;; nil
+;; "A list of redirection rules."
+;; :type '(repeat (list :format "%v"
+;; :value ("Anywhere" nil)
+;; (dynamic-choice :choice-function s5-network-aliases-filter
+;; :tag "Destination network")
+;; (radio-button-choice
+;; :tag "Connection type"
+;; (const :tag "Direct connection" :value nil)
+;; (dynamic-choice :format "%t: %[%v%]"
+;; :choice-function s5-servers-filter
+;; :tag "Proxy chain via")))))
(defcustom socks-server
(list "Default server" "socks" 1080 5)
""
- :group 'socks
:type '(list
(string :format "" :value "Default server")
(string :tag "Server")
@@ -225,7 +209,6 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
;; Base variables
(defvar socks-timeout 5)
-(defvar socks-connections (make-hash-table :size 13))
;; Miscellaneous stuff for authentication
(defvar socks-authentication-methods nil)
@@ -266,40 +249,40 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
(defconst socks-state-waiting 3)
(defconst socks-state-connected 4)
-(defmacro socks-wait-for-state-change (proc htable cur-state)
- `(while (and (= (gethash 'state ,htable) ,cur-state)
- (memq (process-status ,proc) '(run open)))
- (accept-process-output ,proc socks-timeout)))
+(defun socks-wait-for-state-change (proc cur-state)
+ (while (and (= (process-get proc 'socks-state) cur-state)
+ (memq (process-status proc) '(run open)))
+ (accept-process-output proc socks-timeout)))
(defun socks-filter (proc string)
- (let ((info (gethash proc socks-connections))
- state version desired-len)
- (or info (error "socks-filter called on non-SOCKS connection %S" proc))
- (setq state (gethash 'state info))
+ (let (state version desired-len)
+ (or (process-get proc 'socks)
+ (error "socks-filter called on non-SOCKS connection %S" proc))
+ (setq state (process-get proc 'socks-state))
(cond
((= state socks-state-waiting-for-auth)
- (puthash 'scratch (concat string (gethash 'scratch info)) info)
- (setq string (gethash 'scratch info))
+ (cl-callf (lambda (s) (setq string (concat string s)))
+ (process-get proc 'socks-scratch))
(if (< (length string) 2)
nil ; We need to spin some more
- (puthash 'authtype (aref string 1) info)
- (puthash 'scratch (substring string 2 nil) info)
- (puthash 'state socks-state-submethod-negotiation info)))
+ (process-put proc 'socks-authtype (aref string 1))
+ (process-put proc 'socks-scratch (substring string 2 nil))
+ (process-put proc 'socks-state socks-state-submethod-negotiation)))
((= state socks-state-submethod-negotiation)
)
((= state socks-state-authenticated)
)
((= state socks-state-waiting)
- (puthash 'scratch (concat string (gethash 'scratch info)) info)
- (setq string (gethash 'scratch info))
- (setq version (gethash 'server-protocol info))
+ (cl-callf (lambda (s) (setq string (concat string s)))
+ (process-get proc 'socks-scratch))
+ (setq version (process-get proc 'socks-server-protocol))
(cond
((equal version 'http)
(if (not (string-match "\r\n\r\n" string))
nil ; Need to spin some more
- (puthash 'state socks-state-connected info)
- (puthash 'reply 0 info)
- (puthash 'response string info)))
+ (process-put proc 'socks-state socks-state-connected)
+ (process-put proc 'socks-reply 0)
+ (process-put proc 'socks-response string)))
((equal version 4)
(if (< (length string) 2)
nil ; Can't know how much to read yet
@@ -313,71 +296,58 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
(let ((response (aref string 1)))
(if (= response 90)
(setq response 0))
- (puthash 'state socks-state-connected info)
- (puthash 'reply response info)
- (puthash 'response string info)))))
+ (process-put proc 'socks-state socks-state-connected)
+ (process-put proc 'socks-reply response)
+ (process-put proc 'socks-response string)))))
((equal version 5)
(if (< (length string) 4)
nil
(setq desired-len
(+ 6 ; Standard socks header
- (cond
- ((= (aref string 3) socks-address-type-v4) 4)
- ((= (aref string 3) socks-address-type-v6) 16)
- ((= (aref string 3) socks-address-type-name)
- (if (< (length string) 5)
- 255
- (+ 1 (aref string 4)))))))
+ (pcase (aref string 3)
+ ((pred (= socks-address-type-v4)) 4)
+ ((pred (= socks-address-type-v6)) 16)
+ ((pred (= socks-address-type-name))
+ (if (< (length string) 5)
+ 255
+ (+ 1 (aref string 4)))))))
(if (< (length string) desired-len)
nil ; Need to spin some more
- (puthash 'state socks-state-connected info)
- (puthash 'reply (aref string 1) info)
- (puthash 'response string info))))))
- ((= state socks-state-connected)
- )
- )
- )
- )
-
-(declare-function socks-original-open-network-stream "socks") ; fset
+ (process-put proc 'socks-state socks-state-connected)
+ (process-put proc 'socks-reply (aref string 1))
+ (process-put proc 'socks-response string))))))
+ ((= state socks-state-connected)))))
;; FIXME this is a terrible idea.
;; It is not even compatible with the argument spec of open-network-stream
-;; in 24.1. If this is really necessary, open-network-stream
-;; could get a wrapper hook, or defer to open-network-stream-function.
+;; in 24.1.
(defvar socks-override-functions nil
- "Whether to overwrite the `open-network-stream' function with the SOCKSified
-version.")
-
-(require 'network-stream)
+ "If non-nil, overwrite `open-network-stream' function with SOCKSified version.")
-(if (fboundp 'socks-original-open-network-stream)
- nil ; Do nothing, we've been here already
- (defalias 'socks-original-open-network-stream
- (symbol-function 'open-network-stream))
- (if socks-override-functions
- (defalias 'open-network-stream 'socks-open-network-stream)))
+(when socks-override-functions
+ (advice-add 'open-network-stream :around #'socks--open-network-stream))
(defun socks-open-connection (server-info)
(interactive)
(save-excursion
- (let ((proc (socks-original-open-network-stream "socks"
- nil
- (nth 1 server-info)
- (nth 2 server-info)))
- (info (make-hash-table :size 13))
+ (let ((proc
+ (let ((socks-override-functions nil))
+ (open-network-stream "socks"
+ nil
+ (nth 1 server-info)
+ (nth 2 server-info))))
(authtype nil)
version)
;; Initialize process and info about the process
- (set-process-filter proc 'socks-filter)
+ (set-process-filter proc #'socks-filter)
(set-process-query-on-exit-flag proc nil)
- (puthash proc info socks-connections)
- (puthash 'state socks-state-waiting-for-auth info)
- (puthash 'authtype socks-authentication-failure info)
- (puthash 'server-protocol (nth 3 server-info) info)
- (puthash 'server-name (nth 1 server-info) info)
+ (process-put proc 'socks t)
+ (process-put proc 'socks-state socks-state-waiting-for-auth)
+ (process-put proc 'socks-authtype socks-authentication-failure)
+ (process-put proc 'socks-server-protocol (nth 3 server-info))
+ (process-put proc 'socks-server-name (nth 1 server-info))
(setq version (nth 3 server-info))
(cond
((equal version 'http)
@@ -393,15 +363,15 @@ version.")
(socks-build-auth-list)))
;; Basically just do a select() until we change states.
- (socks-wait-for-state-change proc info socks-state-waiting-for-auth)
- (setq authtype (gethash 'authtype info))
+ (socks-wait-for-state-change proc socks-state-waiting-for-auth)
+ (setq authtype (process-get proc 'socks-authtype))
(cond
((= authtype socks-authentication-null)
(and socks-debug (message "No authentication necessary")))
((= authtype socks-authentication-failure)
(error "No acceptable authentication methods found"))
(t
- (let* ((auth-type (gethash 'authtype info))
+ (let* ((auth-type (process-get proc 'socks-authtype))
(auth-handler (assoc auth-type socks-authentication-methods))
(auth-func (and auth-handler (cdr (cdr auth-handler))))
(auth-desc (and auth-handler (car (cdr auth-handler)))))
@@ -415,8 +385,8 @@ version.")
)
)
)
- (puthash 'state socks-state-authenticated info)
- (set-process-filter proc 'socks-filter)))
+ (process-put proc 'socks-state socks-state-authenticated)
+ (set-process-filter proc #'socks-filter)))
proc)))
(defun socks-send-command (proc command atype address port)
@@ -428,12 +398,11 @@ version.")
(format "%c%s" (length address) address))
(t
(error "Unknown address type: %d" atype))))
- (info (gethash proc socks-connections))
request version)
- (or info (error "socks-send-command called on non-SOCKS connection %S"
- proc))
- (puthash 'state socks-state-waiting info)
- (setq version (gethash 'server-protocol info))
+ (or (process-get proc 'socks)
+ (error "socks-send-command called on non-SOCKS connection %S" proc))
+ (process-put proc 'socks-state socks-state-waiting)
+ (setq version (process-get proc 'socks-server-protocol))
(cond
((equal version 'http)
(setq request (format (eval-when-compile
@@ -447,38 +416,36 @@ version.")
(error "Unsupported address type for HTTP: %d" atype)))
port)))
((equal version 4)
- (setq request (string-make-unibyte
- (format
- "%c%c%c%c%s%s%c"
- version ; version
- command ; command
- (lsh port -8) ; port, high byte
- (- port (lsh (lsh port -8) 8)) ; port, low byte
- addr ; address
- (user-full-name) ; username
- 0 ; terminate username
- ))))
+ (setq request (concat
+ (unibyte-string
+ version ; version
+ command ; command
+ (ash port -8) ; port, high byte
+ (logand port #xff)) ; port, low byte
+ addr ; address
+ (user-full-name) ; username
+ "\0"))) ; terminate username
((equal version 5)
- (setq request (string-make-unibyte
- (format
- "%c%c%c%c%s%c%c"
+ (setq request (concat
+ (unibyte-string
version ; version
command ; command
0 ; reserved
- atype ; address type
- addr ; address
- (lsh port -8) ; port, high byte
- (- port (lsh (lsh port -8) 8)) ; port, low byte
- ))))
+ atype) ; address type
+ addr ; address
+ (unibyte-string
+ (ash port -8) ; port, high byte
+ (logand port #xff))))) ; port, low byte
(t
(error "Unknown protocol version: %d" version)))
(process-send-string proc request)
- (socks-wait-for-state-change proc info socks-state-waiting)
+ (socks-wait-for-state-change proc socks-state-waiting)
(process-status proc)
- (if (= (or (gethash 'reply info) 1) socks-response-success)
+ (if (= (or (process-get proc 'socks-reply) 1) socks-response-success)
nil ; Sweet sweet success!
(delete-process proc)
- (error "SOCKS: %s" (nth (or (gethash 'reply info) 1) socks-errors)))
+ (error "SOCKS: %s"
+ (nth (or (process-get proc 'socks-reply) 1) socks-errors)))
proc))
@@ -486,7 +453,7 @@ version.")
(defvar socks-noproxy nil
"List of regexps matching hosts that we should not socksify connections to")
-(defun socks-find-route (host service)
+(defun socks-find-route (host _service)
(let ((route socks-server)
(noproxy socks-noproxy))
(while noproxy
@@ -540,37 +507,46 @@ version.")
(if udp socks-udp-services socks-tcp-services)))
(defun socks-open-network-stream (name buffer host service)
- (let* ((route (socks-find-route host service))
- proc info version atype)
+ (let ((socks-override-functions t))
+ (socks--open-network-stream
+ (lambda (&rest args)
+ (let ((socks-override-functions nil))
+ (apply #'open-network-stream args)))
+ name buffer host service)))
+
+(defun socks--open-network-stream (orig-fun name buffer host service &rest params)
+ (let ((route (and socks-override-functions
+ (socks-find-route host service))))
(if (not route)
- (socks-original-open-network-stream name buffer host service)
- (setq proc (socks-open-connection route)
- info (gethash proc socks-connections)
- version (gethash 'server-protocol info))
- (cond
- ((equal version 4)
- (setq host (socks-nslookup-host host))
- (if (not (listp host))
- (error "Could not get IP address for: %s" host))
- (setq host (apply 'format "%c%c%c%c" host))
- (setq atype socks-address-type-v4))
- (t
- (setq atype socks-address-type-name)))
- (socks-send-command proc
- socks-connect-command
- atype
- host
- (if (stringp service)
- (or
- (socks-find-services-entry service)
- (error "Unknown service: %s" service))
- service))
- (puthash 'buffer buffer info)
- (puthash 'host host info)
- (puthash 'service host info)
- (set-process-filter proc nil)
- (set-process-buffer proc (if buffer (get-buffer-create buffer)))
- proc)))
+ (apply orig-fun name buffer host service params)
+ ;; FIXME: Obey `params'!
+ (let* ((proc (socks-open-connection route))
+ (version (process-get proc 'socks-server-protocol))
+ (atype
+ (cond
+ ((equal version 4)
+ (setq host (socks-nslookup-host host))
+ (if (not (listp host))
+ (error "Could not get IP address for: %s" host))
+ (setq host (apply #'format "%c%c%c%c" host))
+ socks-address-type-v4)
+ (t
+ socks-address-type-name))))
+ (socks-send-command proc
+ socks-connect-command
+ atype
+ host
+ (if (stringp service)
+ (or
+ (socks-find-services-entry service)
+ (error "Unknown service: %s" service))
+ service))
+ (process-put proc 'socks-buffer buffer)
+ (process-put proc 'socks-host host)
+ (process-put proc 'socks-service host)
+ (set-process-filter proc nil)
+ (set-process-buffer proc (if buffer (get-buffer-create buffer)))
+ proc))))
;; Authentication modules go here
@@ -581,24 +557,25 @@ version.")
(defconst socks-username/password-auth-version 1)
(defun socks-username/password-auth-filter (proc str)
- (let ((info (gethash proc socks-connections)))
- (or info (error "socks-filter called on non-SOCKS connection %S" proc))
- (puthash 'scratch (concat (gethash 'scratch info) str) info)
- (if (< (length (gethash 'scratch info)) 2)
- nil
- (puthash 'password-auth-status (aref (gethash 'scratch info) 1) info)
- (puthash 'state socks-state-authenticated info))))
+ (or (process-get proc 'socks)
+ (error "socks-filter called on non-SOCKS connection %S" proc))
+ (cl-callf (lambda (s) (concat s str))
+ (process-get proc 'socks-scratch))
+ (if (< (length (process-get proc 'socks-scratch)) 2)
+ nil
+ (process-put proc 'socks-password-auth-status
+ (aref (process-get proc 'socks-scratch) 1))
+ (process-put proc 'socks-state socks-state-authenticated)))
(defun socks-username/password-auth (proc)
- (let* ((info (gethash proc socks-connections))
- (state (gethash 'state info)))
+ (let ((state (process-get proc 'socks-state)))
(if (not socks-password)
(setq socks-password (read-passwd
(format "Password for %s@%s: "
socks-username
- (gethash 'server-name info)))))
- (puthash 'scratch "" info)
- (set-process-filter proc 'socks-username/password-auth-filter)
+ (process-get proc 'socks-server-name)))))
+ (process-put proc 'socks-scratch "")
+ (set-process-filter proc #'socks-username/password-auth-filter)
(process-send-string proc
(format "%c%c%s%c%s"
socks-username/password-auth-version
@@ -606,33 +583,32 @@ version.")
socks-username
(length socks-password)
socks-password))
- (socks-wait-for-state-change proc info state)
- (= (gethash 'password-auth-status info) 0)))
+ (socks-wait-for-state-change proc state)
+ (= (process-get proc 'socks-password-auth-status) 0)))
;; More advanced GSS/API stuff, not yet implemented - volunteers?
;; (socks-register-authentication-method 1 "GSS/API" 'socks-gssapi-auth)
-(defun socks-gssapi-auth (proc)
+(defun socks-gssapi-auth (_proc)
nil)
;; CHAP stuff
;; (socks-register-authentication-method 3 "CHAP" 'socks-chap-auth)
-(defun socks-chap-auth (proc)
+(defun socks-chap-auth (_proc)
nil)
;; CRAM stuff
;; (socks-register-authentication-method 5 "CRAM" 'socks-cram-auth)
-(defun socks-cram-auth (proc)
+(defun socks-cram-auth (_proc)
nil)
(defcustom socks-nslookup-program "nslookup"
- "If non-NIL then a string naming the nslookup program."
- :type '(choice (const :tag "None" :value nil) string)
- :group 'socks)
+ "If non-nil then a string naming the nslookup program."
+ :type '(choice (const :tag "None" :value nil) string))
(defun socks-nslookup-host (host)
"Attempt to resolve the given HOSTNAME using nslookup if possible."
@@ -651,8 +627,8 @@ version.")
(progn
(setq res (buffer-substring (match-beginning 2)
(match-end 2))
- res (mapcar 'string-to-number
- (socks-split-string res "\\.")))))
+ res (mapcar #'string-to-number
+ (split-string res "\\.")))))
(kill-buffer (current-buffer)))
res)
host))
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index b3aa7ca1bab..db9acbfc631 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -35,14 +35,12 @@
(require 'tramp)
-;;;###tramp-autoload
(defcustom tramp-adb-program "adb"
"Name of the Android Debug Bridge program."
:group 'tramp
:version "24.4"
:type 'string)
-;;;###tramp-autoload
(defcustom tramp-adb-connect-if-not-connected nil
"Try to run `adb connect' if provided device is not connected currently.
It is used for TCP/IP devices."
@@ -54,7 +52,6 @@ It is used for TCP/IP devices."
(defconst tramp-adb-method "adb"
"When this method name is used, forward all calls to Android Debug Bridge.")
-;;;###tramp-autoload
(defcustom tramp-adb-prompt
"^\\(?:[[:digit:]]*|?\\)?\\(?:[[:alnum:]\e;[]*@?[[:alnum:]]*[^#\\$]*\\)?[#\\$][[:space:]]"
"Regexp used as prompt in almquist shell."
@@ -68,7 +65,7 @@ It is used for TCP/IP devices."
(defconst tramp-adb-ls-toolbox-regexp
(concat
- "^[[:space:]]*\\([-[:alpha:]]+\\)" ; \1 permissions
+ "^[[:space:]]*\\([-.[:alpha:]]+\\)" ; \1 permissions
"\\(?:[[:space:]]+[[:digit:]]+\\)?" ; links (Android 7/toybox)
"[[:space:]]*\\([^[:space:]]+\\)" ; \2 username
"[[:space:]]+\\([^[:space:]]+\\)" ; \3 group
@@ -78,22 +75,20 @@ It is used for TCP/IP devices."
"Regexp for ls output.")
;;;###tramp-autoload
-(add-to-list 'tramp-methods
- `(,tramp-adb-method
- (tramp-tmpdir "/data/local/tmp")
- (tramp-default-port 5555)))
+(tramp--with-startup
+ (add-to-list 'tramp-methods
+ `(,tramp-adb-method
+ (tramp-tmpdir "/data/local/tmp")
+ (tramp-default-port 5555)))
-;;;###tramp-autoload
-(add-to-list 'tramp-default-host-alist `(,tramp-adb-method nil ""))
+ (add-to-list 'tramp-default-host-alist `(,tramp-adb-method nil ""))
-;;;###tramp-autoload
-(eval-after-load 'tramp
- '(tramp-set-completion-function
- tramp-adb-method '((tramp-adb-parse-device-names ""))))
+ (tramp-set-completion-function
+ tramp-adb-method '((tramp-adb-parse-device-names ""))))
;;;###tramp-autoload
(defconst tramp-adb-file-name-handler-alist
- '((access-file . ignore)
+ '((access-file . tramp-handle-access-file)
(add-name-to-file . tramp-handle-add-name-to-file)
;; `byte-compiler-base-file-name' performed by default handler.
;; `copy-directory' performed by default handler.
@@ -107,11 +102,12 @@ It is used for TCP/IP devices."
. tramp-adb-handle-directory-files-and-attributes)
(dired-compress-file . ignore)
(dired-uncache . tramp-handle-dired-uncache)
- (expand-file-name . tramp-adb-handle-expand-file-name)
+ (exec-path . tramp-adb-handle-exec-path)
+ (expand-file-name . tramp-handle-expand-file-name)
(file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
(file-acl . ignore)
(file-attributes . tramp-adb-handle-file-attributes)
- (file-directory-p . tramp-adb-handle-file-directory-p)
+ (file-directory-p . tramp-handle-file-directory-p)
(file-equal-p . tramp-handle-file-equal-p)
;; FIXME: This is too sloppy.
(file-executable-p . tramp-handle-file-exists-p)
@@ -140,7 +136,6 @@ It is used for TCP/IP devices."
(file-truename . tramp-adb-handle-file-truename)
(file-writable-p . tramp-adb-handle-file-writable-p)
(find-backup-file-name . tramp-handle-find-backup-file-name)
- ;; `find-file-noselect' performed by default handler.
;; `get-file-buffer' performed by default handler.
(insert-directory . tramp-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
@@ -149,6 +144,7 @@ It is used for TCP/IP devices."
(make-directory . tramp-adb-handle-make-directory)
(make-directory-internal . ignore)
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
+ (make-process . tramp-adb-handle-make-process)
(make-symbolic-link . tramp-handle-make-symbolic-link)
(process-file . tramp-adb-handle-process-file)
(rename-file . tramp-adb-handle-rename-file)
@@ -157,10 +153,11 @@ It is used for TCP/IP devices."
(set-file-selinux-context . ignore)
(set-file-times . tramp-adb-handle-set-file-times)
(set-visited-file-modtime . tramp-handle-set-visited-file-modtime)
- (shell-command . tramp-adb-handle-shell-command)
- (start-file-process . tramp-adb-handle-start-file-process)
+ (shell-command . tramp-handle-shell-command)
+ (start-file-process . tramp-handle-start-file-process)
(substitute-in-file-name . tramp-handle-substitute-in-file-name)
(temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-set-file-uid-gid . ignore)
(unhandled-file-name-directory . ignore)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
@@ -172,8 +169,9 @@ It is used for TCP/IP devices."
;;;###tramp-autoload
(defsubst tramp-adb-file-name-p (filename)
"Check if it's a filename for ADB."
- (let ((v (tramp-dissect-file-name filename)))
- (string= (tramp-file-name-method v) tramp-adb-method)))
+ (and (tramp-tramp-file-p filename)
+ (string= (tramp-file-name-method (tramp-dissect-file-name filename))
+ tramp-adb-method)))
;;;###tramp-autoload
(defun tramp-adb-file-name-handler (operation &rest args)
@@ -186,72 +184,21 @@ pass to the OPERATION."
(tramp-run-real-handler operation args))))
;;;###tramp-autoload
-(tramp-register-foreign-file-name-handler
- 'tramp-adb-file-name-p 'tramp-adb-file-name-handler)
+(tramp--with-startup
+ (tramp-register-foreign-file-name-handler
+ #'tramp-adb-file-name-p #'tramp-adb-file-name-handler))
;;;###tramp-autoload
(defun tramp-adb-parse-device-names (_ignore)
"Return a list of (nil host) tuples allowed to access."
- (with-timeout (10)
- (with-temp-buffer
- ;; `call-process' does not react on timer under MS Windows.
- ;; That's why we use `start-process'.
- (let ((p (start-process
- tramp-adb-program (current-buffer) tramp-adb-program "devices"))
- (v (make-tramp-file-name
- :method tramp-adb-method :user tramp-current-user
- :host tramp-current-host))
- result)
- (tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " "))
- (process-put p 'adjust-window-size-function 'ignore)
- (set-process-query-on-exit-flag p nil)
- (while (process-live-p p)
- (accept-process-output p 0.1))
- (accept-process-output p 0.1)
- (tramp-message v 6 "\n%s" (buffer-string))
- (goto-char (point-min))
- (while (search-forward-regexp "^\\(\\S-+\\)[[:space:]]+device$" nil t)
- (push (list nil (match-string 1)) result))
-
- ;; Replace ":" by "#".
- (mapc
- (lambda (elt)
- (setcar
- (cdr elt)
- (replace-regexp-in-string
- ":" tramp-prefix-port-format (car (cdr elt)))))
- result)
- result))))
-
-(defun tramp-adb-handle-expand-file-name (name &optional dir)
- "Like `expand-file-name' for Tramp files."
- ;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
- (setq dir (or dir default-directory "/"))
- ;; Unless NAME is absolute, concat DIR and NAME.
- (unless (file-name-absolute-p name)
- (setq name (concat (file-name-as-directory dir) name)))
- ;; If NAME is not a Tramp file, run the real handler.
- (if (not (tramp-tramp-file-p name))
- (tramp-run-real-handler 'expand-file-name (list name nil))
- ;; Dissect NAME.
- (with-parsed-tramp-file-name name nil
- (unless (tramp-run-real-handler 'file-name-absolute-p (list localname))
- (setq localname (concat "/" localname)))
- ;; Do normal `expand-file-name' (this does "/./" and "/../").
- ;; `default-directory' is bound, because on Windows there would
- ;; be problems with UNC shares or Cygwin mounts.
- (let ((default-directory (tramp-compat-temporary-file-directory)))
- (tramp-make-tramp-file-name
- method user domain host port
- (tramp-drop-volume-letter
- (tramp-run-real-handler
- 'expand-file-name (list localname))))))))
-
-(defun tramp-adb-handle-file-directory-p (filename)
- "Like `file-directory-p' for Tramp files."
- (eq (tramp-compat-file-attribute-type
- (file-attributes (file-truename filename)))
- t))
+ (delq nil
+ (mapcar
+ (lambda (line)
+ (when (string-match "^\\(\\S-+\\)[[:space:]]+device$" line)
+ ;; Replace ":" by "#".
+ `(nil ,(replace-regexp-in-string
+ ":" tramp-prefix-port-format (match-string 1 line)))))
+ (tramp-process-lines nil tramp-adb-program "devices"))))
(defun tramp-adb-handle-file-system-info (filename)
"Like `file-system-info' for Tramp files."
@@ -264,18 +211,19 @@ pass to the OPERATION."
(goto-char (point-min))
(forward-line)
(when (looking-at
- (concat "[[:space:]]*[^[:space:]]+"
- "[[:space:]]+\\([[:digit:]]+\\)"
- "[[:space:]]+\\([[:digit:]]+\\)"
- "[[:space:]]+\\([[:digit:]]+\\)"))
+ (eval-when-compile
+ (concat "[[:space:]]*[^[:space:]]+"
+ "[[:space:]]+\\([[:digit:]]+\\)"
+ "[[:space:]]+\\([[:digit:]]+\\)"
+ "[[:space:]]+\\([[:digit:]]+\\)")))
;; The values are given as 1k numbers, so we must change
;; them to number of bytes.
- (list (* 1024 (string-to-number (concat (match-string 1) "e0")))
+ (list (* 1024 (string-to-number (match-string 1)))
;; The second value is the used size. We need the
;; free size.
- (* 1024 (- (string-to-number (concat (match-string 1) "e0"))
- (string-to-number (concat (match-string 2) "e0"))))
- (* 1024 (string-to-number (concat (match-string 3) "e0")))))))))
+ (* 1024 (- (string-to-number (match-string 1))
+ (string-to-number (match-string 2))))
+ (* 1024 (string-to-number (match-string 3)))))))))
;; This is derived from `tramp-sh-handle-file-truename'. Maybe the
;; code could be shared?
@@ -284,10 +232,10 @@ pass to the OPERATION."
;; Preserve trailing "/".
(funcall
(if (string-equal (file-name-nondirectory filename) "")
- 'file-name-as-directory 'identity)
+ #'file-name-as-directory #'identity)
(with-parsed-tramp-file-name (expand-file-name filename) nil
(tramp-make-tramp-file-name
- method user domain host port
+ v
(with-tramp-file-property v localname "file-truename"
(let ((result nil) ; result steps in reverse order
(quoted (tramp-compat-file-name-quoted-p localname)))
@@ -309,19 +257,17 @@ pass to the OPERATION."
(setq thisstep (pop steps))
(tramp-message
v 5 "Check %s"
- (mapconcat 'identity
+ (mapconcat #'identity
(append '("") (reverse result) (list thisstep))
"/"))
(setq symlink-target
(tramp-compat-file-attribute-type
(file-attributes
(tramp-make-tramp-file-name
- method user domain host port
- (mapconcat 'identity
- (append '("")
- (reverse result)
- (list thisstep))
- "/")))))
+ v (mapconcat #'identity
+ (append
+ '("") (reverse result) (list thisstep))
+ "/")))))
(cond ((string= "." thisstep)
(tramp-message v 5 "Ignoring step `.'"))
((string= ".." thisstep)
@@ -356,7 +302,7 @@ pass to the OPERATION."
;; Combine list to form string.
(setq result
(if result
- (mapconcat 'identity (cons "" result) "/")
+ (mapconcat #'identity (cons "" result) "/")
"/"))
(when (and is-dir (or (string= "" result)
(not (string= (substring result -1) "/"))))
@@ -418,9 +364,9 @@ pass to the OPERATION."
;; no way to handle numeric ids in Androids ash
(if (eq id-format 'integer) 0 uid)
(if (eq id-format 'integer) 0 gid)
- '(0 0) ; atime
+ tramp-time-dont-know ; atime
(date-to-time date) ; mtime
- '(0 0) ; ctime
+ tramp-time-dont-know ; ctime
size
mod-string
;; fake
@@ -469,18 +415,24 @@ pass to the OPERATION."
(sort result (lambda (x y) (string< (car x) (car y))))))
(delq nil
(mapcar (lambda (x)
- (if (or (not match) (string-match match (car x)))
+ (if (or (not match) (string-match-p match (car x)))
x))
result)))))))))
(defun tramp-adb-get-ls-command (vec)
- "Determine `ls' command at its arguments."
+ "Determine `ls' command and its arguments."
(with-tramp-connection-property vec "ls"
(tramp-message vec 5 "Finding a suitable `ls' command")
(cond
+ ;; Support Android derived systems where "ls" command is provided
+ ;; by GNU Coreutils. Force "ls" to print one column and set
+ ;; time-style to imitate other "ls" flavors.
+ ((tramp-adb-send-command-and-check
+ vec "ls --time-style=long-iso /dev/null")
+ "ls -1 --time-style=long-iso")
;; Can't disable coloring explicitly for toybox ls command. We
- ;; must force "ls" to print just one column.
- ((tramp-adb-send-command-and-check vec "toybox") "env COLUMNS=1 ls")
+ ;; also must force "ls" to print just one column.
+ ((tramp-adb-send-command-and-check vec "toybox") "ls -1")
;; On CyanogenMod based system BusyBox is used and "ls" output
;; coloring is enabled by default. So we try to disable it when
;; possible.
@@ -492,15 +444,15 @@ pass to the OPERATION."
"Almquist shell can't handle multiple arguments.
Convert (\"-al\") to (\"-a\" \"-l\"). Remove arguments like \"--dired\"."
(split-string
- (apply 'concat
+ (apply #'concat
(mapcar (lambda (s)
(replace-regexp-in-string
- "\\(.\\)" " -\\1" (replace-regexp-in-string "^-" "" s)))
+ "\\(.\\)" " -\\1" (replace-regexp-in-string "^-" "" s)))
;; FIXME: Warning about removed switches (long and non-dash).
(delq nil
(mapcar
(lambda (s)
- (and (not (string-match "\\(^--\\|^[^-]\\)" s)) s))
+ (and (not (string-match-p "\\(^--\\|^[^-]\\)" s)) s))
switches))))))
(defun tramp-adb-sh-fix-ls-output (&optional sort-by-time)
@@ -515,7 +467,7 @@ Emacs dired can't find files."
"[[:space:]]\\([[:space:]][0-9]\\{4\\}-[0-9][0-9]-[0-9][0-9][[:space:]]\\)" nil t)
(replace-match "0\\1" "\\1" nil)
;; Insert missing "/".
- (when (looking-at "[0-9][0-9]:[0-9][0-9][[:space:]]+$")
+ (when (looking-at-p "[0-9][0-9]:[0-9][0-9][[:space:]]+$")
(end-of-line)
(insert "/")))
;; Sort entries.
@@ -524,10 +476,10 @@ Emacs dired can't find files."
(sort
lines
(if sort-by-time
- 'tramp-adb-ls-output-time-less-p
- 'tramp-adb-ls-output-name-less-p))))
+ #'tramp-adb-ls-output-time-less-p
+ #'tramp-adb-ls-output-name-less-p))))
(delete-region (point-min) (point-max))
- (insert " " (mapconcat 'identity sorted-lines "\n ")))
+ (insert " " (mapconcat #'identity sorted-lines "\n ")))
;; Add final newline.
(goto-char (point-max))
(unless (bolp) (insert "\n"))))
@@ -536,9 +488,9 @@ Emacs dired can't find files."
"Sort \"ls\" output by time, descending."
(let (time-a time-b)
(string-match tramp-adb-ls-date-regexp a)
- (setq time-a (apply 'encode-time (parse-time-string (match-string 0 a))))
+ (setq time-a (apply #'encode-time (parse-time-string (match-string 0 a))))
(string-match tramp-adb-ls-date-regexp b)
- (setq time-b (apply 'encode-time (parse-time-string (match-string 0 b))))
+ (setq time-b (apply #'encode-time (parse-time-string (match-string 0 b))))
(time-less-p time-b time-a)))
(defun tramp-adb-ls-output-name-less-p (a b)
@@ -557,8 +509,8 @@ Emacs dired can't find files."
(let ((par (expand-file-name ".." dir)))
(unless (file-directory-p par)
(make-directory par parents))))
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-directory-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-directory-properties v localname)
(unless (or (tramp-adb-send-command-and-check
v (format "mkdir %s" (tramp-shell-quote-argument localname)))
(and parents (file-directory-p dir)))
@@ -568,11 +520,11 @@ Emacs dired can't find files."
"Like `delete-directory' for Tramp files."
(setq directory (expand-file-name directory))
(with-parsed-tramp-file-name (file-truename directory) nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-directory-property v localname))
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-directory-properties v localname))
(with-parsed-tramp-file-name directory nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-directory-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-directory-properties v localname)
(tramp-adb-barf-unless-okay
v (format "%s %s"
(if recursive "rm -r" "rmdir")
@@ -583,8 +535,8 @@ Emacs dired can't find files."
"Like `delete-file' for Tramp files."
(setq filename (expand-file-name filename))
(with-parsed-tramp-file-name filename nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
(tramp-adb-barf-unless-okay
v (format "rm %s" (tramp-shell-quote-argument localname))
"Couldn't delete %s" filename)))
@@ -595,28 +547,27 @@ Emacs dired can't find files."
filename
(with-parsed-tramp-file-name (expand-file-name directory) nil
(with-tramp-file-property v localname "file-name-all-completions"
- (save-match-data
- (tramp-adb-send-command
- v (format "%s -a %s"
- (tramp-adb-get-ls-command v)
- (tramp-shell-quote-argument localname)))
- (mapcar
- (lambda (f)
- (if (file-directory-p (expand-file-name f directory))
- (file-name-as-directory f)
- f))
- (with-current-buffer (tramp-get-buffer v)
- (delete-dups
- (append
- ;; In older Android versions, "." and ".." are not
- ;; included. In newer versions (toybox, since Android
- ;; 6) they are. We fix this by `delete-dups'.
- '("." "..")
- (delq
- nil
- (mapcar
- (lambda (l) (and (not (string-match "^[[:space:]]*$" l)) l))
- (split-string (buffer-string) "\n"))))))))))))
+ (tramp-adb-send-command
+ v (format "%s -a %s"
+ (tramp-adb-get-ls-command v)
+ (tramp-shell-quote-argument localname)))
+ (mapcar
+ (lambda (f)
+ (if (file-directory-p (expand-file-name f directory))
+ (file-name-as-directory f)
+ f))
+ (with-current-buffer (tramp-get-buffer v)
+ (delete-dups
+ (append
+ ;; In older Android versions, "." and ".." are not
+ ;; included. In newer versions (toybox, since Android 6)
+ ;; they are. We fix this by `delete-dups'.
+ '("." "..")
+ (delq
+ nil
+ (mapcar
+ (lambda (l) (and (not (string-match-p "^[[:space:]]*$" l)) l))
+ (split-string (buffer-string) "\n")))))))))))
(defun tramp-adb-handle-file-local-copy (filename)
"Like `file-local-copy' for Tramp files."
@@ -635,13 +586,11 @@ Emacs dired can't find files."
(ignore-errors (delete-file tmpfile))
(tramp-error
v 'file-error "Cannot make local copy of file `%s'" filename))
- (set-file-modes
- tmpfile
- (logior (or (file-modes filename) 0) (string-to-number "0400" 8))))
+ (set-file-modes tmpfile (logior (or (file-modes filename) 0) #o0400)))
tmpfile)))
(defun tramp-adb-handle-file-writable-p (filename)
- "Like `tramp-sh-handle-file-writable-p'.
+ "Like `file-writable-p' for Tramp files.
But handle the case, if the \"test\" command is not available."
(with-parsed-tramp-file-name filename nil
(with-tramp-file-property v localname "file-writable-p"
@@ -677,17 +626,15 @@ But handle the case, if the \"test\" command is not available."
;; We must also flush the cache of the directory, because
;; `file-attributes' reads the values from there.
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
(let* ((curbuf (current-buffer))
(tmpfile (tramp-compat-make-temp-file filename)))
(when (and append (file-exists-p filename))
(copy-file filename tmpfile 'ok)
- (set-file-modes
- tmpfile
- (logior (or (file-modes tmpfile) 0) (string-to-number "0600" 8))))
+ (set-file-modes tmpfile (logior (or (file-modes tmpfile) 0) #o0600)))
(tramp-run-real-handler
- 'write-region (list start end tmpfile append 'no-message lockname))
+ #'write-region (list start end tmpfile append 'no-message lockname))
(with-tramp-progress-reporter
v 3 (format-message
"Moving tmp file `%s' to `%s'" tmpfile filename)
@@ -717,23 +664,35 @@ But handle the case, if the \"test\" command is not available."
(defun tramp-adb-handle-set-file-modes (filename mode)
"Like `set-file-modes' for Tramp files."
(with-parsed-tramp-file-name filename nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
(tramp-adb-send-command-and-check v (format "chmod %o %s" mode localname))))
(defun tramp-adb-handle-set-file-times (filename &optional time)
"Like `set-file-times' for Tramp files."
(with-parsed-tramp-file-name filename nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
- (let ((time (if (or (null time) (equal time '(0 0)))
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
+ (let ((time (if (or (null time)
+ (tramp-compat-time-equal-p time tramp-time-doesnt-exist)
+ (tramp-compat-time-equal-p time tramp-time-dont-know))
(current-time)
- time)))
+ time))
+ (quoted-name (tramp-shell-quote-argument localname)))
+ ;; Older versions of toybox 'touch' mishandle nanoseconds and/or
+ ;; trailing "Z", so fall back on plain seconds if nanoseconds+Z
+ ;; fails. Also, fall back on old POSIX 'touch -t' if 'touch -d'
+ ;; (introduced in POSIX.1-2008) fails.
(tramp-adb-send-command-and-check
- ;; Use shell arithmetic because of Emacs integer size limit.
- v (format "touch -t $(( %d * 65536 + %d )) %s"
- (car time) (cadr time)
- (tramp-shell-quote-argument localname))))))
+ v (format (concat "touch -d %s %s 2>/dev/null || "
+ "touch -d %s %s 2>/dev/null || "
+ "touch -t %s %s")
+ (format-time-string "%Y-%m-%dT%H:%M:%S.%NZ" time t)
+ quoted-name
+ (format-time-string "%Y-%m-%dT%H:%M:%S" time t)
+ quoted-name
+ (format-time-string "%Y%m%d%H%M.%S" time t)
+ quoted-name)))))
(defun tramp-adb-handle-copy-file
(filename newname &optional ok-if-already-exists keep-date
@@ -753,16 +712,16 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
v 0 (format "Copying %s to %s" filename newname)
(if (and t1 t2 (tramp-equal-remote filename newname))
- (let ((l1 (file-remote-p filename 'localname))
- (l2 (file-remote-p newname 'localname)))
+ (let ((l1 (tramp-compat-file-local-name filename))
+ (l2 (tramp-compat-file-local-name newname)))
(when (and (not ok-if-already-exists)
(file-exists-p newname))
(tramp-error v 'file-already-exists newname))
;; We must also flush the cache of the directory,
;; because `file-attributes' reads the values from
;; there.
- (tramp-flush-file-property v (file-name-directory l2))
- (tramp-flush-file-property v l2)
+ (tramp-flush-file-properties v (file-name-directory l2))
+ (tramp-flush-file-properties v l2)
;; Short track.
(tramp-adb-barf-unless-okay
v (format
@@ -796,8 +755,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
;; We must also flush the cache of the directory,
;; because `file-attributes' reads the values from
;; there.
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties
+ v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
(when (tramp-adb-execute-adb-command
v "push"
(tramp-compat-file-name-unquote filename)
@@ -833,17 +793,17 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(if (and t1 t2
(tramp-equal-remote filename newname)
(not (file-directory-p filename)))
- (let ((l1 (file-remote-p filename 'localname))
- (l2 (file-remote-p newname 'localname)))
+ (let ((l1 (tramp-compat-file-local-name filename))
+ (l2 (tramp-compat-file-local-name newname)))
(when (and (not ok-if-already-exists)
(file-exists-p newname))
(tramp-error v 'file-already-exists newname))
;; We must also flush the cache of the directory, because
;; `file-attributes' reads the values from there.
- (tramp-flush-file-property v (file-name-directory l1))
- (tramp-flush-file-property v l1)
- (tramp-flush-file-property v (file-name-directory l2))
- (tramp-flush-file-property v l2)
+ (tramp-flush-file-properties v (file-name-directory l1))
+ (tramp-flush-file-properties v l1)
+ (tramp-flush-file-properties v (file-name-directory l2))
+ (tramp-flush-file-properties v l2)
;; Short track.
(tramp-adb-barf-unless-okay
v (format
@@ -867,7 +827,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(with-parsed-tramp-file-name default-directory nil
(let (command input tmpinput stderr tmpstderr outbuf ret)
;; Compute command.
- (setq command (mapconcat 'tramp-shell-quote-argument
+ (setq command (mapconcat #'tramp-shell-quote-argument
(cons program args) " "))
;; Determine input.
(if (null infile)
@@ -878,8 +838,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(setq input (with-parsed-tramp-file-name infile nil localname))
;; INFILE must be copied to remote host.
(setq input (tramp-make-tramp-temp-file v)
- tmpinput (tramp-make-tramp-file-name
- method user domain host port input))
+ tmpinput (tramp-make-tramp-file-name v input))
(copy-file infile tmpinput t)))
(when input (setq command (format "%s <%s" command input)))
@@ -912,8 +871,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
;; stderr must be copied to remote host. The temporary
;; file must be deleted after execution.
(setq stderr (tramp-make-tramp-temp-file v)
- tmpstderr (tramp-make-tramp-file-name
- method user domain host port stderr))))
+ tmpstderr (tramp-make-tramp-file-name v stderr))))
;; stderr to be discarded.
((null (cadr destination))
(setq stderr "/dev/null"))))
@@ -957,167 +915,149 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(when tmpinput (delete-file tmpinput))
(unless process-file-side-effects
- (tramp-flush-directory-property v ""))
+ (tramp-flush-directory-properties v ""))
;; Return exit status.
(if (equal ret -1)
(keyboard-quit)
ret))))
-(defun tramp-adb-handle-shell-command
- (command &optional output-buffer error-buffer)
- "Like `shell-command' for Tramp files."
- (let* ((asynchronous (string-match "[ \t]*&[ \t]*\\'" command))
- ;; We cannot use `shell-file-name' and `shell-command-switch',
- ;; they are variables of the local host.
- (args (list "sh" "-c" (substring command 0 asynchronous)))
- current-buffer-p
- (output-buffer
- (cond
- ((bufferp output-buffer) output-buffer)
- ((stringp output-buffer) (get-buffer-create output-buffer))
- (output-buffer
- (setq current-buffer-p t)
- (current-buffer))
- (t (get-buffer-create
- (if asynchronous
- "*Async Shell Command*"
- "*Shell Command Output*")))))
- (error-buffer
- (cond
- ((bufferp error-buffer) error-buffer)
- ((stringp error-buffer) (get-buffer-create error-buffer))))
- (buffer
- (if (and (not asynchronous) error-buffer)
- (with-parsed-tramp-file-name default-directory nil
- (list output-buffer (tramp-make-tramp-temp-file v)))
- output-buffer))
- (p (get-buffer-process output-buffer)))
-
- ;; Check whether there is another process running. Tramp does not
- ;; support 2 (asynchronous) processes in parallel.
- (when p
- (if (yes-or-no-p "A command is running. Kill it? ")
- (ignore-errors (kill-process p))
- (tramp-compat-user-error p "Shell command in progress")))
-
- (if current-buffer-p
- (progn
- (barf-if-buffer-read-only)
- (push-mark nil t))
- (with-current-buffer output-buffer
- (setq buffer-read-only nil)
- (erase-buffer)))
-
- (if (and (not current-buffer-p) (integerp asynchronous))
- (prog1
- ;; Run the process.
- (apply 'start-file-process "*Async Shell*" buffer args)
- ;; Display output.
- (pop-to-buffer output-buffer)
- (setq mode-line-process '(":%s"))
- (shell-mode))
-
- (prog1
- ;; Run the process.
- (apply 'process-file (car args) nil buffer nil (cdr args))
- ;; Insert error messages if they were separated.
- (when (listp buffer)
- (with-current-buffer error-buffer
- (insert-file-contents (cadr buffer)))
- (delete-file (cadr buffer)))
- (if current-buffer-p
- ;; This is like exchange-point-and-mark, but doesn't
- ;; activate the mark. It is cleaner to avoid activation,
- ;; even though the command loop would deactivate the mark
- ;; because we inserted text.
- (goto-char (prog1 (mark t)
- (set-marker (mark-marker) (point)
- (current-buffer))))
- ;; There's some output, display it.
- (when (with-current-buffer output-buffer (> (point-max) (point-min)))
- (display-message-or-buffer output-buffer)))))))
-
;; We use BUFFER also as connection buffer during setup. Because of
;; this, its original contents must be saved, and restored once
;; connection has been setup.
-(defun tramp-adb-handle-start-file-process (name buffer program &rest args)
- "Like `start-file-process' for Tramp files."
- (with-parsed-tramp-file-name default-directory nil
- ;; When PROGRAM is nil, we should provide a tty. This is not
- ;; possible here.
- (unless (stringp program)
- (tramp-error v 'file-error "PROGRAM must be a string"))
-
- (let* ((buffer
- (if buffer
- (get-buffer-create buffer)
- ;; BUFFER can be nil. We use a temporary buffer.
- (generate-new-buffer tramp-temp-buffer-name)))
- (command
- (format "cd %s; %s"
- (tramp-shell-quote-argument localname)
- (mapconcat 'tramp-shell-quote-argument
- (cons program args) " ")))
- (tramp-process-connection-type
- (or (null program) tramp-process-connection-type))
- (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer)))
- (name1 name)
- (i 0)
- ;; We do not want to run timers.
- timer-list timer-idle-list)
-
- (while (get-process name1)
- ;; NAME must be unique as process name.
- (setq i (1+ i)
- name1 (format "%s<%d>" name i)))
- (setq name name1)
- ;; Set the new process properties.
- (tramp-set-connection-property v "process-name" name)
- (tramp-set-connection-property v "process-buffer" buffer)
-
- (with-current-buffer (tramp-get-connection-buffer v)
- (unwind-protect
- ;; We catch this event. Otherwise, `start-process' could
- ;; be called on the local host.
- (save-excursion
- (save-restriction
- ;; Activate narrowing in order to save BUFFER
- ;; contents. Clear also the modification time;
- ;; otherwise we might be interrupted by
- ;; `verify-visited-file-modtime'.
- (let ((buffer-undo-list t)
- (buffer-read-only nil)
- (mark (point)))
- (clear-visited-file-modtime)
- (narrow-to-region (point-max) (point-max))
- ;; We call `tramp-adb-maybe-open-connection', in
- ;; order to cleanup the prompt afterwards.
- (tramp-adb-maybe-open-connection v)
- (widen)
- (delete-region mark (point))
- (narrow-to-region (point-max) (point-max))
- ;; Send the command.
- (let ((tramp-adb-prompt (regexp-quote command)))
- (tramp-adb-send-command v command))
- (let ((p (tramp-get-connection-process v)))
- ;; Set query flag and process marker for this
- ;; process. We ignore errors, because the process
- ;; could have finished already.
- (ignore-errors
- (set-process-query-on-exit-flag p t)
- (set-marker (process-mark p) (point)))
- ;; Return process.
- p))))
-
- ;; Save exit.
- (if (string-match tramp-temp-buffer-name (buffer-name))
- (ignore-errors
- (set-process-buffer (tramp-get-connection-process v) nil)
- (kill-buffer (current-buffer)))
- (set-buffer-modified-p bmp))
- (tramp-set-connection-property v "process-name" nil)
- (tramp-set-connection-property v "process-buffer" nil))))))
+(defun tramp-adb-handle-make-process (&rest args)
+ "Like `make-process' for Tramp files."
+ (when args
+ (with-parsed-tramp-file-name (expand-file-name default-directory) nil
+ (let ((name (plist-get args :name))
+ (buffer (plist-get args :buffer))
+ (command (plist-get args :command))
+ (coding (plist-get args :coding))
+ (noquery (plist-get args :noquery))
+ (stop (plist-get args :stop))
+ (connection-type (plist-get args :connection-type))
+ (filter (plist-get args :filter))
+ (sentinel (plist-get args :sentinel))
+ (stderr (plist-get args :stderr)))
+ (unless (stringp name)
+ (signal 'wrong-type-argument (list #'stringp name)))
+ (unless (or (null buffer) (bufferp buffer) (stringp buffer))
+ (signal 'wrong-type-argument (list #'stringp buffer)))
+ (unless (consp command)
+ (signal 'wrong-type-argument (list #'consp command)))
+ (unless (or (null coding)
+ (and (symbolp coding) (memq coding coding-system-list))
+ (and (consp coding)
+ (memq (car coding) coding-system-list)
+ (memq (cdr coding) coding-system-list)))
+ (signal 'wrong-type-argument (list #'symbolp coding)))
+ (unless (or (null connection-type) (memq connection-type '(pipe pty)))
+ (signal 'wrong-type-argument (list #'symbolp connection-type)))
+ (unless (or (null filter) (functionp filter))
+ (signal 'wrong-type-argument (list #'functionp filter)))
+ (unless (or (null sentinel) (functionp sentinel))
+ (signal 'wrong-type-argument (list #'functionp sentinel)))
+ (unless (or (null stderr) (bufferp stderr) (stringp stderr))
+ (signal 'wrong-type-argument (list #'stringp stderr)))
+
+ (let* ((buffer
+ (if buffer
+ (get-buffer-create buffer)
+ ;; BUFFER can be nil. We use a temporary buffer.
+ (generate-new-buffer tramp-temp-buffer-name)))
+ (program (car command))
+ (args (cdr command))
+ (command
+ (format "cd %s && exec %s"
+ (tramp-shell-quote-argument localname)
+ (mapconcat #'tramp-shell-quote-argument
+ (cons program args) " ")))
+ (tramp-process-connection-type
+ (or (null program) tramp-process-connection-type))
+ (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer)))
+ (name1 name)
+ (i 0)
+ ;; We do not want to run timers.
+ timer-list timer-idle-list)
+
+ (while (get-process name1)
+ ;; NAME must be unique as process name.
+ (setq i (1+ i)
+ name1 (format "%s<%d>" name i)))
+ (setq name name1)
+ ;; Set the new process properties.
+ (tramp-set-connection-property v "process-name" name)
+ (tramp-set-connection-property v "process-buffer" buffer)
+
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (unwind-protect
+ ;; We catch this event. Otherwise, `make-process'
+ ;; could be called on the local host.
+ (save-excursion
+ (save-restriction
+ ;; Activate narrowing in order to save BUFFER
+ ;; contents. Clear also the modification time;
+ ;; otherwise we might be interrupted by
+ ;; `verify-visited-file-modtime'.
+ (let ((buffer-undo-list t)
+ (inhibit-read-only t))
+ (clear-visited-file-modtime)
+ (narrow-to-region (point-max) (point-max))
+ ;; We call `tramp-adb-maybe-open-connection', in
+ ;; order to cleanup the prompt afterwards.
+ (tramp-adb-maybe-open-connection v)
+ (delete-region (point-min) (point-max))
+ ;; Send the command.
+ (let* ((p (tramp-get-connection-process v)))
+ (tramp-adb-send-command v command nil t) ; nooutput
+ ;; Stop process if indicated.
+ (when stop
+ (stop-process p))
+ ;; Set sentinel and filter.
+ (when sentinel
+ (set-process-sentinel p sentinel))
+ (when filter
+ (set-process-filter p filter))
+ ;; Set query flag and process marker for this
+ ;; process. We ignore errors, because the
+ ;; process could have finished already.
+ (ignore-errors
+ (set-process-query-on-exit-flag p (null noquery))
+ (set-marker (process-mark p) (point)))
+ ;; Read initial output. Remove the first line,
+ ;; which is the command echo.
+ (while
+ (progn
+ (goto-char (point-min))
+ (not (re-search-forward "[\n]" nil t)))
+ (tramp-accept-process-output p 0))
+ (delete-region (point-min) (point))
+ ;; Return process.
+ p))))
+
+ ;; Save exit.
+ (if (string-match-p tramp-temp-buffer-name (buffer-name))
+ (ignore-errors
+ (set-process-buffer (tramp-get-connection-process v) nil)
+ (kill-buffer (current-buffer)))
+ (set-buffer-modified-p bmp))
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer"))))))))
+
+(defun tramp-adb-handle-exec-path ()
+ "Like `exec-path' for Tramp files."
+ (append
+ (with-parsed-tramp-file-name default-directory nil
+ (with-tramp-connection-property v "remote-path"
+ (tramp-adb-send-command v "echo \\\"$PATH\\\"")
+ (split-string
+ (with-current-buffer (tramp-get-connection-buffer v)
+ ;; Read the expression.
+ (goto-char (point-min))
+ (read (current-buffer)))
+ ":" 'omit)))
+ ;; The equivalent to `exec-directory'.
+ `(,(tramp-compat-file-local-name default-directory))))
(defun tramp-adb-get-device (vec)
"Return full host name from VEC to be used in shell execution.
@@ -1126,11 +1066,11 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\"
;; Sometimes this is called before there is a connection process
;; yet. In order to work with the connection cache, we flush all
;; unwanted entries first.
- (tramp-flush-connection-property nil)
+ (tramp-flush-connection-properties nil)
(with-tramp-connection-property (tramp-get-connection-process vec) "device"
(let* ((host (tramp-file-name-host vec))
(port (tramp-file-name-port-or-default vec))
- (devices (mapcar 'cadr (tramp-adb-parse-device-names nil))))
+ (devices (mapcar #'cadr (tramp-adb-parse-device-names nil))))
(replace-regexp-in-string
tramp-prefix-port-format ":"
(cond ((member host devices) host)
@@ -1167,7 +1107,7 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\"
(prog1
(unless
(zerop
- (apply 'tramp-call-process vec tramp-adb-program nil t nil args))
+ (apply #'tramp-call-process vec tramp-adb-program nil t nil args))
(buffer-string))
(tramp-message vec 6 "%s" (buffer-string)))))
@@ -1179,24 +1119,27 @@ This happens for Android >= 4.0."
;; Connection functions
-(defun tramp-adb-send-command (vec command)
+(defun tramp-adb-send-command (vec command &optional neveropen nooutput)
"Send the COMMAND to connection VEC."
- (tramp-adb-maybe-open-connection vec)
+ (unless neveropen (tramp-adb-maybe-open-connection vec))
(tramp-message vec 6 "%s" command)
(tramp-send-string vec command)
- ;; fixme: Race condition
- (tramp-adb-wait-for-output (tramp-get-connection-process vec))
- (with-current-buffer (tramp-get-connection-buffer vec)
- (save-excursion
- (goto-char (point-min))
- ;; We can't use stty to disable echo of command.
- (delete-matching-lines (regexp-quote command))
- ;; When the local machine is W32, there are still trailing ^M.
- ;; There must be a better solution by setting the correct coding
- ;; system, but this requires changes in core Tramp.
- (goto-char (point-min))
- (while (re-search-forward "\r+$" nil t)
- (replace-match "" nil nil)))))
+ (unless nooutput
+ ;; FIXME: Race condition.
+ (tramp-adb-wait-for-output (tramp-get-connection-process vec))
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ (save-excursion
+ (goto-char (point-min))
+ ;; We can't use stty to disable echo of command. stty is said
+ ;; to be added to toybox 0.7.6. busybox shall have it, but this
+ ;; isn't used any longer for Android.
+ (delete-matching-lines (regexp-quote command))
+ ;; When the local machine is W32, there are still trailing ^M.
+ ;; There must be a better solution by setting the correct coding
+ ;; system, but this requires changes in core Tramp.
+ (goto-char (point-min))
+ (while (re-search-forward "\r+$" nil t)
+ (replace-match "" nil nil))))))
(defun tramp-adb-send-command-and-check (vec command)
"Run COMMAND and check its exit status.
@@ -1215,51 +1158,43 @@ the exit status is not equal 0, and t otherwise."
(skip-chars-forward "^ ")
(prog1
(zerop (read (current-buffer)))
- (let (buffer-read-only)
+ (let ((inhibit-read-only t))
(delete-region (match-beginning 0) (point-max))))))
(defun tramp-adb-barf-unless-okay (vec command fmt &rest args)
"Run COMMAND, check exit status, throw error if exit status not okay.
FMT and ARGS are passed to `error'."
(unless (tramp-adb-send-command-and-check vec command)
- (apply 'tramp-error vec 'file-error fmt args)))
+ (apply #'tramp-error vec 'file-error fmt args)))
(defun tramp-adb-wait-for-output (proc &optional timeout)
"Wait for output from remote command."
(unless (buffer-live-p (process-buffer proc))
(delete-process proc)
(tramp-error proc 'file-error "Process `%s' not available, try again" proc))
- (with-current-buffer (process-buffer proc)
- (if (tramp-wait-for-regexp
- proc timeout
- (tramp-get-connection-property proc "prompt" tramp-adb-prompt))
- (let (buffer-read-only)
- (goto-char (point-min))
- ;; ADB terminal sends "^H" sequences.
- (when (re-search-forward "<\b+" (point-at-eol) t)
- (forward-line 1)
- (delete-region (point-min) (point)))
- ;; Delete the prompt.
- (goto-char (point-min))
- (when (re-search-forward
- (tramp-get-connection-property proc "prompt" tramp-adb-prompt)
- (point-at-eol) t)
- (forward-line 1)
- (delete-region (point-min) (point)))
- (goto-char (point-max))
- (re-search-backward
- (tramp-get-connection-property proc "prompt" tramp-adb-prompt) nil t)
- (delete-region (point) (point-max)))
- (if timeout
+ (let ((prompt (tramp-get-connection-property proc "prompt" tramp-adb-prompt)))
+ (with-current-buffer (process-buffer proc)
+ (if (tramp-wait-for-regexp proc timeout prompt)
+ (let ((inhibit-read-only t))
+ (goto-char (point-min))
+ ;; ADB terminal sends "^H" sequences.
+ (when (re-search-forward "<\b+" (point-at-eol) t)
+ (forward-line 1)
+ (delete-region (point-min) (point)))
+ ;; Delete the prompt.
+ (goto-char (point-min))
+ (when (re-search-forward prompt (point-at-eol) t)
+ (forward-line 1)
+ (delete-region (point-min) (point)))
+ (goto-char (point-max))
+ (re-search-backward prompt nil t)
+ (delete-region (point) (point-max)))
+ (if timeout
+ (tramp-error
+ proc 'file-error
+ "[[Remote prompt `%s' not found in %d secs]]" prompt timeout)
(tramp-error
- proc 'file-error
- "[[Remote adb prompt `%s' not found in %d secs]]"
- (tramp-get-connection-property proc "prompt" tramp-adb-prompt)
- timeout)
- (tramp-error
- proc 'file-error
- "[[Remote prompt `%s' not found]]"
- (tramp-get-connection-property proc "prompt" tramp-adb-prompt))))))
+ proc 'file-error "[[Remote prompt `%s' not found]]" prompt))))))
(defun tramp-adb-maybe-open-connection (vec)
"Maybe open a connection VEC.
@@ -1271,10 +1206,6 @@ connection if a previous connection has died for some reason."
(user (tramp-file-name-user vec))
(device (tramp-adb-get-device vec)))
- ;; Set variables for proper tracing in `tramp-adb-parse-device-names'.
- (setq tramp-current-user (tramp-file-name-user vec)
- tramp-current-host (tramp-file-name-host vec))
-
;; Maybe we know already that "su" is not supported. We cannot
;; use a connection property, because we have not checked yet
;; whether it is still the same device.
@@ -1282,6 +1213,14 @@ connection if a previous connection has died for some reason."
(tramp-error vec 'file-error "Cannot switch to user `%s'" user))
(unless (process-live-p p)
+ ;; During completion, don't reopen a new connection. We check
+ ;; this for the process related to `tramp-buffer-name';
+ ;; otherwise `start-file-process' wouldn't run ever when
+ ;; `non-essential' is non-nil.
+ (when (and (tramp-completion-mode-p)
+ (null (get-process (tramp-buffer-name vec))))
+ (throw 'non-essential 'non-essential))
+
(save-match-data
(when (and p (processp p)) (delete-process p))
(if (zerop (length device))
@@ -1294,18 +1233,24 @@ connection if a previous connection has died for some reason."
(list "shell")))
(p (let ((default-directory
(tramp-compat-temporary-file-directory)))
- (apply 'start-process (tramp-get-connection-name vec) buf
+ (apply #'start-process (tramp-get-connection-name vec) buf
tramp-adb-program args)))
(prompt (md5 (concat (prin1-to-string process-environment)
(current-time-string)))))
(tramp-message
- vec 6 "%s" (mapconcat 'identity (process-command p) " "))
- ;; Wait for initial prompt.
+ vec 6 "%s" (mapconcat #'identity (process-command p) " "))
+ ;; Wait for initial prompt. On some devices, it needs an
+ ;; initial RET, in order to get it.
+ (sleep-for 0.1)
+ (tramp-send-string vec tramp-rsh-end-of-line)
(tramp-adb-wait-for-output p 30)
(unless (process-live-p p)
- (tramp-error vec 'file-error "Terminated!"))
- (tramp-set-connection-property p "vector" vec)
- (process-put p 'adjust-window-size-function 'ignore)
+ (tramp-error vec 'file-error "Terminated!"))
+
+ ;; Set sentinel and query flag. Initialize variables.
+ (set-process-sentinel p #'tramp-process-sentinel)
+ (process-put p 'vector vec)
+ (process-put p 'adjust-window-size-function #'ignore)
(set-process-query-on-exit-flag p nil)
;; Change prompt.
@@ -1343,28 +1288,35 @@ connection if a previous connection has died for some reason."
(tramp-adb-send-command vec (format "su %s" user))
(unless (tramp-adb-send-command-and-check vec nil)
(delete-process p)
- (tramp-set-file-property vec "" "su-command-p" nil)
+ (tramp-flush-file-property vec "" "su-command-p")
(tramp-error
vec 'file-error "Cannot switch to user `%s'" user)))
- ;; Set "remote-path" connection property. This is needed
- ;; for eshell.
- (tramp-adb-send-command vec "echo \\\"$PATH\\\"")
- (tramp-set-connection-property
- vec "remote-path"
- (split-string
- (with-current-buffer (tramp-get-connection-buffer vec)
- ;; Read the expression.
- (goto-char (point-min))
- (read (current-buffer)))
- ":" 'omit))
-
;; Set connection-local variables.
(tramp-set-connection-local-variables vec)
;; Mark it as connected.
(tramp-set-connection-property p "connected" t)))))))
+;; Default settings for connection-local variables.
+(defconst tramp-adb-connection-local-default-profile
+ '((shell-file-name . "/system/bin/sh")
+ (shell-command-switch . "-c"))
+ "Default connection-local variables for remote adb connections.")
+
+;; `connection-local-set-profile-variables' and
+;; `connection-local-set-profiles' exists since Emacs 26.1.
+(eval-after-load "shell"
+ '(progn
+ (tramp-compat-funcall
+ 'connection-local-set-profile-variables
+ 'tramp-adb-connection-local-default-profile
+ tramp-adb-connection-local-default-profile)
+ (tramp-compat-funcall
+ 'connection-local-set-profiles
+ `(:application tramp :protocol ,tramp-adb-method)
+ 'tramp-adb-connection-local-default-profile)))
+
(add-hook 'tramp-unload-hook
(lambda ()
(unload-feature 'tramp-adb 'force)))
diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el
new file mode 100644
index 00000000000..ba4c26cdf2f
--- /dev/null
+++ b/lisp/net/tramp-archive.el
@@ -0,0 +1,661 @@
+;;; tramp-archive.el --- Tramp archive manager -*- lexical-binding:t -*-
+
+;; Copyright (C) 2017-2019 Free Software Foundation, Inc.
+
+;; Author: Michael Albinus <michael.albinus@gmx.de>
+;; Keywords: comm, processes
+;; Package: tramp
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Access functions for file archives. This is possible only on
+;; machines which have installed the virtual file system for the Gnome
+;; Desktop (GVFS). Internally, file archives are mounted via the GVFS
+;; "archive" method.
+
+;; A file archive is a regular file of kind "/path/to/dir/file.EXT".
+;; The extension ".EXT" identifies the type of the file archive. A
+;; file inside a file archive, called archive file name, has the name
+;; "/path/to/dir/file.EXT/dir/file".
+
+;; Most of the magic file name operations are implemented for archive
+;; file names, exceptions are all operations which write into a file
+;; archive, and process related operations. Therefore, functions like
+
+;; (copy-file "/path/to/dir/file.tar/dir/file" "/somewhere/else")
+
+;; work out of the box. This is also true for file name completion,
+;; and for libraries like `dired' or `ediff', which accept archive
+;; file names as well.
+
+;; File archives are identified by the file name extension ".EXT".
+;; Since GVFS uses internally the library libarchive(3), all suffixes,
+;; which are accepted by this library, work also for archive file
+;; names. Accepted suffixes are listed in the constant
+;; `tramp-archive-suffixes'. They are
+
+;; * ".7z" - 7-Zip archives
+;; * ".apk" - Android package kits
+;; * ".ar" - UNIX archiver formats
+;; * ".cab", ".CAB" - Microsoft Windows cabinets
+;; * ".cpio" - CPIO archives
+;; * ".deb" - Debian packages
+;; * ".depot" - HP-UX SD depots
+;; * ".exe" - Self extracting Microsoft Windows EXE files
+;; * ".iso" - ISO 9660 images
+;; * ".jar" - Java archives
+;; * ".lzh", ".LZH" - Microsoft Windows compressed LHA archives
+;; * ".msu", ".MSU" - Microsoft Windows Update packages
+;; * ".mtree" - BSD mtree format
+;; * ".odb" ".odf" ".odg" ".odp" ".ods" ".odt" - OpenDocument formats
+;; * ".pax" - Posix archives
+;; * ".rar" - RAR archives
+;; * ".rpm" - Red Hat packages
+;; * ".shar" - Shell archives
+;; * ".tar", ".tbz", ".tgz", ".tlz", ".txz" - (Compressed) tape archives
+;; * ".warc" - Web archives
+;; * ".xar" - macOS XAR archives
+;; * ".xpi" - XPInstall Mozilla addons
+;; * ".xps" - Open XML Paper Specification (OpenXPS) documents
+;; * ".zip", ".ZIP" - ZIP archives
+
+;; File archives could also be compressed, identified by an additional
+;; compression suffix. Valid compression suffixes are listed in the
+;; constant `tramp-archive-compression-suffixes'. They are ".bz2",
+;; ".gz", ".lrz", ".lz", ".lz4", ".lzma", ".lzo", ".uu", ".xz" and
+;; ".Z". A valid archive file name would be
+;; "/path/to/dir/file.tar.gz/dir/file". Even several suffixes in a
+;; row are possible, like "/path/to/dir/file.tar.gz.uu/dir/file".
+
+;; An archive file name could be a remote file name, as in
+;; "/ftp:anonymous@ftp.gnu.org:/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL".
+;; Since all file operations are mapped internally to GVFS operations,
+;; remote file names supported by tramp-gvfs.el perform better,
+;; because no local copy of the file archive must be downloaded first.
+;; For example, "/sftp:user@host:..." performs better than the similar
+;; "/scp:user@host:...". See the constant
+;; `tramp-archive-all-gvfs-methods' for a complete list of
+;; tramp-gvfs.el supported method names.
+
+;; If `url-handler-mode' is enabled, archives could be visited via
+;; URLs, like "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL".
+;; This allows complex file operations like
+
+;; (ediff-directories
+;; "https://ftp.gnu.org/gnu/tramp/tramp-2.3.1.tar.gz/tramp-2.3.1"
+;; "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/tramp-2.3.2" "")
+
+;; It is even possible to access file archives in file archives, as
+
+;; (find-file
+;; "http://ftp.debian.org/debian/pool/main/c/coreutils/coreutils_8.28-1_amd64.deb/control.tar.gz/control")
+
+;;; Code:
+
+(eval-when-compile (require 'cl-lib))
+;; Sometimes, compilation fails with "Variable binding depth exceeds
+;; max-specpdl-size".
+(eval-and-compile
+ (let ((max-specpdl-size (* 2 max-specpdl-size))) (require 'tramp-gvfs)))
+
+(autoload 'dired-uncache "dired")
+(autoload 'url-tramp-convert-url-to-tramp "url-tramp")
+(defvar url-handler-mode-hook)
+(defvar url-handler-regexp)
+(defvar url-tramp-protocols)
+
+;; We cannot check `tramp-gvfs-enabled' in loaddefs.el, because this
+;; would load Tramp. So we make a cheaper check.
+;;;###autoload
+(defvar tramp-archive-enabled (featurep 'dbusbind)
+ "Non-nil when file archive support is available.")
+
+;; After loading tramp-gvfs.el, we know it better.
+(setq tramp-archive-enabled tramp-gvfs-enabled)
+
+;; <https://github.com/libarchive/libarchive/wiki/LibarchiveFormats>
+;;;###autoload
+(defconst tramp-archive-suffixes
+ ;; "cab", "lzh", "msu" and "zip" are included with lower and upper
+ ;; letters, because Microsoft Windows provides them often with
+ ;; capital letters.
+ '("7z" ;; 7-Zip archives.
+ "apk" ;; Android package kits. Not in libarchive testsuite.
+ "ar" ;; UNIX archiver formats.
+ "cab" "CAB" ;; Microsoft Windows cabinets.
+ "cpio" ;; CPIO archives.
+ "deb" ;; Debian packages. Not in libarchive testsuite.
+ "depot" ;; HP-UX SD depot. Not in libarchive testsuite.
+ "exe" ;; Self extracting Microsoft Windows EXE files.
+ "iso" ;; ISO 9660 images.
+ "jar" ;; Java archives. Not in libarchive testsuite.
+ "lzh" "LZH" ;; Microsoft Windows compressed LHA archives.
+ "msu" "MSU" ;; Microsoft Windows Update packages. Not in testsuite.
+ "mtree" ;; BSD mtree format.
+ "odb" "odf" "odg" "odp" "ods" "odt" ;; OpenDocument formats. Not in testsuite.
+ "pax" ;; Posix archives.
+ "rar" ;; RAR archives.
+ "rpm" ;; Red Hat packages.
+ "shar" ;; Shell archives. Not in libarchive testsuite.
+ "tar" "tbz" "tgz" "tlz" "txz" ;; (Compressed) tape archives.
+ "warc" ;; Web archives.
+ "xar" ;; macOS XAR archives. Not in libarchive testsuite.
+ "xpi" ;; XPInstall Mozilla addons. Not in libarchive testsuite.
+ "xps" ;; Open XML Paper Specification (OpenXPS) documents.
+ "zip" "ZIP") ;; ZIP archives.
+ "List of suffixes which indicate a file archive.
+It must be supported by libarchive(3).")
+
+;; <http://unix-memo.readthedocs.io/en/latest/vfs.html>
+;; read and write: tar, cpio, pax , gzip , zip, bzip2, xz, lzip, lzma, ar, mtree, iso9660, compress.
+;; read only: 7-Zip, mtree, xar, lha/lzh, rar, microsoft cab.
+
+;;;###autoload
+(defconst tramp-archive-compression-suffixes
+ '("bz2" "gz" "lrz" "lz" "lz4" "lzma" "lzo" "uu" "xz" "Z")
+ "List of suffixes which indicate a compressed file.
+It must be supported by libarchive(3).")
+
+;; The definition of `tramp-archive-file-name-regexp' contains calls
+;; to `regexp-opt', which cannot be autoloaded while loading
+;; loaddefs.el. So we use a macro, which is evaluated only when needed.
+;;;###autoload
+(progn (defmacro tramp-archive-autoload-file-name-regexp ()
+ "Regular expression matching archive file names."
+ '(concat
+ "\\`" "\\(" ".+" "\\."
+ ;; Default suffixes ...
+ (regexp-opt tramp-archive-suffixes)
+ ;; ... with compression.
+ "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*"
+ "\\)" ;; \1
+ "\\(" "/" ".*" "\\)" "\\'"))) ;; \2
+
+;; In older Emacsen (prior 27.1), `tramp-archive-autoload-file-name-regexp'
+;; is not autoloaded. So we cannot expect it to be known in
+;; tramp-loaddefs.el. But it exists, when tramp-archive.el is loaded.
+;;;###tramp-autoload
+(defconst tramp-archive-file-name-regexp
+ (ignore-errors (tramp-archive-autoload-file-name-regexp))
+ "Regular expression matching archive file names.")
+
+;;;###tramp-autoload
+(defconst tramp-archive-method "archive"
+ "Method name for archives in GVFS.")
+
+(defconst tramp-archive-all-gvfs-methods
+ (cons tramp-archive-method
+ (let ((values (cdr (cadr (get 'tramp-gvfs-methods 'custom-type)))))
+ (setq values (mapcar #'last values)
+ values (mapcar #'car values))))
+ "List of all methods `tramp-gvfs-methods' offers.")
+
+
+;; New handlers should be added here.
+;;;###tramp-autoload
+(defconst tramp-archive-file-name-handler-alist
+ '((access-file . tramp-archive-handle-access-file)
+ (add-name-to-file . tramp-archive-handle-not-implemented)
+ ;; `byte-compiler-base-file-name' performed by default handler.
+ ;; `copy-directory' performed by default handler.
+ (copy-file . tramp-archive-handle-copy-file)
+ (delete-directory . tramp-archive-handle-not-implemented)
+ (delete-file . tramp-archive-handle-not-implemented)
+ ;; `diff-latest-backup-file' performed by default handler.
+ (directory-file-name . tramp-archive-handle-directory-file-name)
+ (directory-files . tramp-handle-directory-files)
+ (directory-files-and-attributes
+ . tramp-handle-directory-files-and-attributes)
+ (dired-compress-file . tramp-archive-handle-not-implemented)
+ (dired-uncache . tramp-archive-handle-dired-uncache)
+ (exec-path . ignore)
+ ;; `expand-file-name' performed by default handler.
+ (file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
+ (file-acl . ignore)
+ (file-attributes . tramp-archive-handle-file-attributes)
+ (file-directory-p . tramp-handle-file-directory-p)
+ (file-equal-p . tramp-handle-file-equal-p)
+ (file-executable-p . tramp-archive-handle-file-executable-p)
+ (file-exists-p . tramp-handle-file-exists-p)
+ (file-in-directory-p . tramp-handle-file-in-directory-p)
+ (file-local-copy . tramp-archive-handle-file-local-copy)
+ (file-modes . tramp-handle-file-modes)
+ (file-name-all-completions . tramp-archive-handle-file-name-all-completions)
+ ;; `file-name-as-directory' performed by default handler.
+ (file-name-case-insensitive-p . ignore)
+ (file-name-completion . tramp-handle-file-name-completion)
+ ;; `file-name-directory' performed by default handler.
+ ;; `file-name-nondirectory' performed by default handler.
+ ;; `file-name-sans-versions' performed by default handler.
+ (file-newer-than-file-p . tramp-handle-file-newer-than-file-p)
+ (file-notify-add-watch . ignore)
+ (file-notify-rm-watch . ignore)
+ (file-notify-valid-p . ignore)
+ (file-ownership-preserved-p . ignore)
+ (file-readable-p . tramp-archive-handle-file-readable-p)
+ (file-regular-p . tramp-handle-file-regular-p)
+ ;; `file-remote-p' performed by default handler.
+ (file-selinux-context . tramp-handle-file-selinux-context)
+ (file-symlink-p . tramp-handle-file-symlink-p)
+ (file-system-info . tramp-archive-handle-file-system-info)
+ (file-truename . tramp-archive-handle-file-truename)
+ (file-writable-p . ignore)
+ (find-backup-file-name . ignore)
+ ;; `get-file-buffer' performed by default handler.
+ (insert-directory . tramp-archive-handle-insert-directory)
+ (insert-file-contents . tramp-archive-handle-insert-file-contents)
+ (load . tramp-archive-handle-load)
+ (make-auto-save-file-name . ignore)
+ (make-directory . tramp-archive-handle-not-implemented)
+ (make-directory-internal . tramp-archive-handle-not-implemented)
+ (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
+ (make-process . ignore)
+ (make-symbolic-link . tramp-archive-handle-not-implemented)
+ (process-file . ignore)
+ (rename-file . tramp-archive-handle-not-implemented)
+ (set-file-acl . ignore)
+ (set-file-modes . tramp-archive-handle-not-implemented)
+ (set-file-selinux-context . ignore)
+ (set-file-times . tramp-archive-handle-not-implemented)
+ (set-visited-file-modtime . tramp-handle-set-visited-file-modtime)
+ (shell-command . tramp-archive-handle-not-implemented)
+ (start-file-process . tramp-archive-handle-not-implemented)
+ ;; `substitute-in-file-name' performed by default handler.
+ (temporary-file-directory . tramp-archive-handle-temporary-file-directory)
+ ;; `tramp-set-file-uid-gid' performed by default handler.
+ (unhandled-file-name-directory . ignore)
+ (vc-registered . ignore)
+ (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
+ (write-region . tramp-archive-handle-not-implemented))
+ "Alist of handler functions for file archive method.
+Operations not mentioned here will be handled by the default Emacs primitives.")
+
+(defsubst tramp-archive-file-name-for-operation (operation &rest args)
+ "Like `tramp-file-name-for-operation', but for archive file name syntax."
+ (cl-letf (((symbol-function #'tramp-tramp-file-p)
+ #'tramp-archive-file-name-p))
+ (apply #'tramp-file-name-for-operation operation args)))
+
+(defun tramp-archive-run-real-handler (operation args)
+ "Invoke normal file name handler for OPERATION.
+First arg specifies the OPERATION, second arg is a list of arguments to
+pass to the OPERATION."
+ (let* ((inhibit-file-name-handlers
+ `(tramp-archive-file-name-handler
+ .
+ ,(and (eq inhibit-file-name-operation operation)
+ inhibit-file-name-handlers)))
+ (inhibit-file-name-operation operation))
+ (apply operation args)))
+
+;;;###tramp-autoload
+(defun tramp-archive-file-name-handler (operation &rest args)
+ "Invoke the file archive related OPERATION.
+First arg specifies the OPERATION, second arg is a list of arguments to
+pass to the OPERATION."
+ (if (not tramp-archive-enabled)
+ ;; Unregister `tramp-archive-file-name-handler'.
+ (progn
+ (tramp-register-file-name-handlers)
+ (tramp-archive-run-real-handler operation args))
+
+ (let* ((filename (apply #'tramp-archive-file-name-for-operation
+ operation args))
+ (archive (tramp-archive-file-name-archive filename)))
+
+ ;; The file archive could be a directory, see Bug#30293.
+ (if (and archive
+ (tramp-archive-run-real-handler
+ #'file-directory-p (list archive)))
+ (tramp-archive-run-real-handler operation args)
+ ;; Now run the handler.
+ (let ((tramp-methods (cons `(,tramp-archive-method) tramp-methods))
+ (tramp-gvfs-methods tramp-archive-all-gvfs-methods)
+ ;; Set uid and gid. gvfsd-archive could do it, but it doesn't.
+ (tramp-unknown-id-integer (user-uid))
+ (tramp-unknown-id-string (user-login-name))
+ (fn (assoc operation tramp-archive-file-name-handler-alist)))
+ (when (eq (cdr fn) #'tramp-archive-handle-not-implemented)
+ (setq args (cons operation args)))
+ (if fn
+ (save-match-data (apply (cdr fn) args))
+ (tramp-archive-run-real-handler operation args)))))))
+
+;;;###autoload
+(defalias
+ 'tramp-archive-autoload-file-name-handler #'tramp-autoload-file-name-handler)
+
+;;;###autoload
+(progn (defun tramp-register-archive-file-name-handler ()
+ "Add archive file name handler to `file-name-handler-alist'."
+ (when tramp-archive-enabled
+ (add-to-list 'file-name-handler-alist
+ (cons (tramp-archive-autoload-file-name-regexp)
+ #'tramp-archive-autoload-file-name-handler))
+ (put 'tramp-archive-autoload-file-name-handler 'safe-magic t))))
+
+;;;###autoload
+(progn
+ (add-hook 'after-init-hook #'tramp-register-archive-file-name-handler)
+ (add-hook
+ 'tramp-archive-unload-hook
+ (lambda ()
+ (remove-hook
+ 'after-init-hook #'tramp-register-archive-file-name-handler))))
+
+;; In older Emacsen (prior 27.1), the autoload above does not exist.
+;; So we call it again; it doesn't hurt.
+(tramp-register-archive-file-name-handler)
+
+;; Mark `operations' the handler is responsible for.
+(put 'tramp-archive-file-name-handler 'operations
+ (mapcar #'car tramp-archive-file-name-handler-alist))
+
+;; `tramp-archive-file-name-handler' must be placed before `url-file-handler'.
+(when url-handler-mode (tramp-register-file-name-handlers))
+
+(eval-after-load 'url-handler
+ '(progn
+ (add-hook 'url-handler-mode-hook #'tramp-register-file-name-handlers)
+ (add-hook
+ 'tramp-archive-unload-hook
+ (lambda ()
+ (remove-hook
+ 'url-handler-mode-hook #'tramp-register-file-name-handlers)))))
+
+
+;; File name conversions.
+
+(defun tramp-archive-file-name-p (name)
+ "Return t if NAME is a string with archive file name syntax."
+ (and (stringp name)
+ ;; We cannot use `string-match-p', the matches are used.
+ (string-match tramp-archive-file-name-regexp name)
+ t))
+
+(defun tramp-archive-file-name-archive (name)
+ "Return archive part of NAME."
+ (and (tramp-archive-file-name-p name)
+ (match-string 1 name)))
+
+(defun tramp-archive-file-name-localname (name)
+ "Return localname part of NAME."
+ (and (tramp-archive-file-name-p name)
+ (match-string 2 name)))
+
+(defvar tramp-archive-hash (make-hash-table :test 'equal)
+ "Hash table for archive local copies.
+The hash key is the archive name. The value is a cons of the
+used `tramp-file-name' structure for tramp-gvfs, and the file
+name of a local copy, if any.")
+
+(defsubst tramp-archive-gvfs-host (archive)
+ "Return host name of ARCHIVE as used in GVFS for mounting"
+ (url-hexify-string (tramp-gvfs-url-file-name archive)))
+
+(defun tramp-archive-dissect-file-name (name)
+ "Return a `tramp-file-name' structure.
+The structure consists of the `tramp-archive-method' method, the
+hexified archive name as host, and the localname. The archive
+name is kept in slot `hop'"
+ (save-match-data
+ (unless (tramp-archive-file-name-p name)
+ (tramp-user-error nil "Not an archive file name: \"%s\"" name))
+ (let* ((localname (tramp-archive-file-name-localname name))
+ (archive (file-truename (tramp-archive-file-name-archive name)))
+ (vec (make-tramp-file-name
+ :method tramp-archive-method :hop archive)))
+
+ (cond
+ ;; The value is already in the hash table.
+ ((gethash archive tramp-archive-hash)
+ (setq vec (car (gethash archive tramp-archive-hash))))
+
+ ;; File archives inside file archives.
+ ((tramp-archive-file-name-p archive)
+ (let ((archive
+ (tramp-make-tramp-file-name
+ (tramp-archive-dissect-file-name archive) nil 'noarchive)))
+ (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive)))
+ (puthash archive (list vec) tramp-archive-hash))
+
+ ;; http://...
+ ((and url-handler-mode
+ tramp-compat-use-url-tramp-p
+ (string-match-p url-handler-regexp archive)
+ (string-match-p
+ "https?" (url-type (url-generic-parse-url archive))))
+ (let* ((url-tramp-protocols
+ (cons
+ (url-type (url-generic-parse-url archive))
+ url-tramp-protocols))
+ (archive (url-tramp-convert-url-to-tramp archive)))
+ (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive)))
+ (puthash archive (list vec) tramp-archive-hash))
+
+ ;; GVFS supported schemes.
+ ((or (tramp-gvfs-file-name-p archive)
+ (not (file-remote-p archive)))
+ (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive))
+ (puthash archive (list vec) tramp-archive-hash))
+
+ ;; Anything else. Here we call `file-local-copy', which we
+ ;; have avoided so far.
+ (t (let* ((inhibit-file-name-operation #'file-local-copy)
+ (inhibit-file-name-handlers
+ (cons #'jka-compr-handler inhibit-file-name-handlers))
+ (copy (file-local-copy archive)))
+ (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host copy))
+ (puthash archive (cons vec copy) tramp-archive-hash))))
+
+ ;; So far, `vec' handles just the mount point. Add `localname',
+ ;; which shouldn't be pushed to the hash.
+ (setf (tramp-file-name-localname vec) localname)
+ vec)))
+
+(defun tramp-archive-cleanup-hash ()
+ "Remove local copies of archives, used by GVFS."
+ (maphash
+ (lambda (key value)
+ ;; Unmount local copy.
+ (ignore-errors
+ (tramp-message (car value) 3 "Unmounting %s" (or (cdr value) key))
+ (tramp-gvfs-unmount (car value)))
+ ;; Delete local copy.
+ (ignore-errors (delete-file (cdr value)))
+ (remhash key tramp-archive-hash))
+ tramp-archive-hash)
+ (clrhash tramp-archive-hash))
+
+(add-hook 'tramp-cleanup-all-connections-hook #'tramp-archive-cleanup-hash)
+(add-hook 'kill-emacs-hook #'tramp-archive-cleanup-hash)
+(add-hook 'tramp-archive-unload-hook
+ (lambda ()
+ (remove-hook 'tramp-cleanup-all-connections-hook
+ #'tramp-archive-cleanup-hash)
+ (remove-hook 'kill-emacs-hook
+ #'tramp-archive-cleanup-hash)))
+
+(defsubst tramp-file-name-archive (vec)
+ "Extract the archive file name from VEC.
+VEC is expected to be a `tramp-file-name', with the method being
+`tramp-archive-method', and the host being a coded URL. The
+archive name is extracted from the hop part of the VEC structure."
+ (and (tramp-file-name-p vec)
+ (string-equal (tramp-file-name-method vec) tramp-archive-method)
+ (tramp-file-name-hop vec)))
+
+(defmacro with-parsed-tramp-archive-file-name (filename var &rest body)
+ "Parse an archive filename and make components available in the body.
+This works exactly as `with-parsed-tramp-file-name' for the Tramp
+file name structure returned by `tramp-archive-dissect-file-name'.
+A variable `foo-archive' (or `archive') will be bound to the
+archive name part of FILENAME, assuming `foo' (or nil) is the
+value of VAR. OTOH, the variable `foo-hop' (or `hop') won't be
+offered."
+ (declare (debug (form symbolp body))
+ (indent 2))
+ (let ((bindings
+ (mapcar (lambda (elem)
+ `(,(if var (intern (format "%s-%s" var elem)) elem)
+ (,(intern (format "tramp-file-name-%s" elem))
+ ,(or var 'v))))
+ `,(cons
+ 'archive
+ (delete 'hop (tramp-compat-tramp-file-name-slots))))))
+ `(let* ((,(or var 'v) (tramp-archive-dissect-file-name ,filename))
+ ,@bindings)
+ ;; We don't know which of those vars will be used, so we bind them all,
+ ;; and then add here a dummy use of all those variables, so we don't get
+ ;; flooded by warnings about those vars `body' didn't use.
+ (ignore ,@(mapcar #'car bindings))
+ ,@body)))
+
+(defun tramp-archive-gvfs-file-name (name)
+ "Return FILENAME in GVFS syntax."
+ (tramp-make-tramp-file-name
+ (tramp-archive-dissect-file-name name) nil 'nohop))
+
+
+;; File name primitives.
+
+(defun tramp-archive-handle-access-file (filename string)
+ "Like `access-file' for Tramp files."
+ (access-file (tramp-archive-gvfs-file-name filename) string))
+
+(defun tramp-archive-handle-copy-file
+ (filename newname &optional ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes)
+ "Like `copy-file' for file archives."
+ (when (tramp-archive-file-name-p newname)
+ (tramp-error
+ (tramp-archive-dissect-file-name newname) 'file-error
+ "Permission denied: %s" newname))
+ (copy-file
+ (tramp-archive-gvfs-file-name filename) newname ok-if-already-exists
+ keep-date preserve-uid-gid preserve-extended-attributes))
+
+(defun tramp-archive-handle-directory-file-name (directory)
+ "Like `directory-file-name' for file archives."
+ (with-parsed-tramp-archive-file-name directory nil
+ (if (and (not (zerop (length localname)))
+ (eq (aref localname (1- (length localname))) ?/)
+ (not (string= localname "/")))
+ (substring directory 0 -1)
+ ;; We do not want to leave the file archive. This would require
+ ;; unnecessary download of http-based file archives, for
+ ;; example. So we return `directory'.
+ directory)))
+
+(defun tramp-archive-handle-dired-uncache (dir)
+ "Like `dired-uncache' for file archives."
+ (dired-uncache (tramp-archive-gvfs-file-name dir)))
+
+(defun tramp-archive-handle-file-attributes (filename &optional id-format)
+ "Like `file-attributes' for file archives."
+ (file-attributes (tramp-archive-gvfs-file-name filename) id-format))
+
+(defun tramp-archive-handle-file-executable-p (filename)
+ "Like `file-executable-p' for file archives."
+ (file-executable-p (tramp-archive-gvfs-file-name filename)))
+
+(defun tramp-archive-handle-file-local-copy (filename)
+ "Like `file-local-copy' for file archives."
+ (file-local-copy (tramp-archive-gvfs-file-name filename)))
+
+(defun tramp-archive-handle-file-name-all-completions (filename directory)
+ "Like `file-name-all-completions' for file archives."
+ (file-name-all-completions filename (tramp-archive-gvfs-file-name directory)))
+
+(defun tramp-archive-handle-file-readable-p (filename)
+ "Like `file-readable-p' for file archives."
+ (file-readable-p (tramp-archive-gvfs-file-name filename)))
+
+(defun tramp-archive-handle-file-system-info (filename)
+ "Like `file-system-info' for file archives."
+ (with-parsed-tramp-archive-file-name filename nil
+ (list (tramp-compat-file-attribute-size (file-attributes archive)) 0 0)))
+
+(defun tramp-archive-handle-file-truename (filename)
+ "Like `file-truename' for file archives."
+ (with-parsed-tramp-archive-file-name filename nil
+ (let ((local (or (file-symlink-p filename) localname)))
+ (unless (file-name-absolute-p local)
+ (setq local (expand-file-name local (file-name-directory localname))))
+ (concat (file-truename archive) local))))
+
+(defun tramp-archive-handle-insert-directory
+ (filename switches &optional wildcard full-directory-p)
+ "Like `insert-directory' for file archives."
+ (insert-directory
+ (tramp-archive-gvfs-file-name filename) switches wildcard full-directory-p)
+ (goto-char (point-min))
+ (while (search-forward (tramp-archive-gvfs-file-name filename) nil 'noerror)
+ (replace-match filename)))
+
+(defun tramp-archive-handle-insert-file-contents
+ (filename &optional visit beg end replace)
+ "Like `insert-file-contents' for file archives."
+ (let ((result
+ (insert-file-contents
+ (tramp-archive-gvfs-file-name filename) visit beg end replace)))
+ (prog1
+ (list (expand-file-name filename)
+ (cadr result))
+ (when visit (setq buffer-file-name filename)))))
+
+(defun tramp-archive-handle-load
+ (file &optional noerror nomessage nosuffix must-suffix)
+ "Like `load' for file archives."
+ (load
+ (tramp-archive-gvfs-file-name file) noerror nomessage nosuffix must-suffix))
+
+(defun tramp-archive-handle-temporary-file-directory ()
+ "Like `temporary-file-directory' for file archives."
+ ;; If the default directory, the file archive, is located on a
+ ;; mounted directory, it is returned as it. Not what we want.
+ (with-parsed-tramp-archive-file-name default-directory nil
+ (let ((default-directory (file-name-directory archive)))
+ (tramp-compat-temporary-file-directory))))
+
+(defun tramp-archive-handle-not-implemented (operation &rest args)
+ "Generic handler for operations not implemented for file archives."
+ (let ((v (ignore-errors
+ (tramp-archive-dissect-file-name
+ (apply #'tramp-archive-file-name-for-operation operation args)))))
+ (tramp-message v 10 "%s" (cons operation args))
+ (tramp-error
+ v 'file-error
+ "Operation `%s' not implemented for file archives" operation)))
+
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-archive 'force)))
+
+(provide 'tramp-archive)
+
+;;; TODO:
+
+;; * Check, whether we could retrieve better file attributes like uid,
+;; gid, permissions. See gvfsbackendarchive.c
+;; (archive_file_set_info_from_entry), where it is commented out.
+;;
+;; * Implement write access, when possible.
+;; https://bugzilla.gnome.org/show_bug.cgi?id=589617
+
+;;; tramp-archive.el ends here
diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el
index 701d2c22102..3d3b14e7371 100644
--- a/lisp/net/tramp-cache.el
+++ b/lisp/net/tramp-cache.el
@@ -28,7 +28,7 @@
;; An implementation of information caching for remote files.
;; Each connection, identified by a `tramp-file-name' structure or by
-;; a process, has a unique cache. We distinguish 3 kind of caches,
+;; a process, has a unique cache. We distinguish 4 kind of caches,
;; depending on the key:
;;
;; - localname is NIL. This are reusable properties. Examples:
@@ -49,6 +49,17 @@
;; an open connection. Examples: "scripts" keeps shell script
;; definitions already sent to the remote shell, "last-cmd-time" is
;; the time stamp a command has been sent to the remote process.
+;;
+;; - The key is nil. This are temporary properties related to the
+;; local machine. Examples: "parse-passwd" and "parse-group" keep
+;; the results of parsing "/etc/passwd" and "/etc/group",
+;; "{uid,gid}-{integer,string}" are the local uid and gid, and
+;; "locale" is the used shell locale.
+
+;; Some properties are handled special:
+;;
+;; - "process-name", "process-buffer" and "first-password-request" are
+;; not saved in the file `tramp-persistency-file-name'.
;;; Code:
@@ -58,7 +69,7 @@
;;; -- Cache --
;;;###tramp-autoload
-(defvar tramp-cache-data (make-hash-table :test 'equal)
+(defvar tramp-cache-data (make-hash-table :test #'equal)
"Hash table for remote files properties.")
;;;###tramp-autoload
@@ -75,7 +86,6 @@ details see the info pages."
(choice :tag " Property" string)
(choice :tag " Value" sexp))))
-;;;###tramp-autoload
(defcustom tramp-persistency-file-name
(expand-file-name (locate-user-emacs-file "tramp"))
"File which keeps connection history for Tramp connections."
@@ -91,15 +101,12 @@ If it doesn't exist yet, it is created and initialized with
matching entries of `tramp-connection-properties'."
(or (gethash key tramp-cache-data)
(let ((hash
- (puthash key (make-hash-table :test 'equal) tramp-cache-data)))
+ (puthash key (make-hash-table :test #'equal) tramp-cache-data)))
(when (tramp-file-name-p key)
(dolist (elt tramp-connection-properties)
- (when (string-match
+ (when (string-match-p
(or (nth 0 elt) "")
- (tramp-make-tramp-file-name
- (tramp-file-name-method key) (tramp-file-name-user key)
- (tramp-file-name-domain key) (tramp-file-name-host key)
- (tramp-file-name-port key) nil))
+ (tramp-make-tramp-file-name key 'noloc 'nohop))
(tramp-set-connection-property key (nth 1 elt) (nth 2 elt)))))
hash)))
@@ -111,20 +118,24 @@ Returns DEFAULT if not set."
(setq file (tramp-compat-file-name-unquote file)
key (copy-tramp-file-name key))
(setf (tramp-file-name-localname key)
- (tramp-run-real-handler 'directory-file-name (list file))
+ (tramp-run-real-handler #'directory-file-name (list file))
(tramp-file-name-hop key) nil)
(let* ((hash (tramp-get-hash-table key))
(value (when (hash-table-p hash) (gethash property hash))))
- (if
- ;; We take the value only if there is any, and
+ (if ;; We take the value only if there is any, and
;; `remote-file-name-inhibit-cache' indicates that it is still
;; valid. Otherwise, DEFAULT is set.
(and (consp value)
(or (null remote-file-name-inhibit-cache)
(and (integerp remote-file-name-inhibit-cache)
- (<=
- (tramp-time-diff (current-time) (car value))
- remote-file-name-inhibit-cache))
+ (time-less-p
+ ;; `current-time' can be nil once we get rid of Emacs 24.
+ (current-time)
+ (time-add
+ (car value)
+ ;; `seconds-to-time' can be removed once we get
+ ;; rid of Emacs 24.
+ (seconds-to-time remote-file-name-inhibit-cache))))
(and (consp remote-file-name-inhibit-cache)
(time-less-p
remote-file-name-inhibit-cache (car value)))))
@@ -150,7 +161,7 @@ Returns VALUE."
(setq file (tramp-compat-file-name-unquote file)
key (copy-tramp-file-name key))
(setf (tramp-file-name-localname key)
- (tramp-run-real-handler 'directory-file-name (list file))
+ (tramp-run-real-handler #'directory-file-name (list file))
(tramp-file-name-hop key) nil)
(let ((hash (tramp-get-hash-table key)))
;; We put the timestamp there.
@@ -167,10 +178,25 @@ Returns VALUE."
value))
;;;###tramp-autoload
-(defun tramp-flush-file-property (key file)
+(defun tramp-flush-file-property (key file property)
+ "Remove PROPERTY of FILE in the cache context of KEY."
+ ;; Unify localname. Remove hop from `tramp-file-name' structure.
+ (setq file (tramp-compat-file-name-unquote file)
+ key (copy-tramp-file-name key))
+ (setf (tramp-file-name-localname key)
+ (tramp-run-real-handler #'directory-file-name (list file))
+ (tramp-file-name-hop key) nil)
+ (remhash property (tramp-get-hash-table key))
+ (tramp-message key 8 "%s %s" file property)
+ (when (>= tramp-verbose 10)
+ (let ((var (intern (concat "tramp-cache-set-count-" property))))
+ (makunbound var))))
+
+;;;###tramp-autoload
+(defun tramp-flush-file-properties (key file)
"Remove all properties of FILE in the cache context of KEY."
(let* ((file (tramp-run-real-handler
- 'directory-file-name (list file)))
+ #'directory-file-name (list file)))
(truename (tramp-get-file-property key file "file-truename" nil)))
;; Unify localname. Remove hop from `tramp-file-name' structure.
(setq file (tramp-compat-file-name-unquote file)
@@ -182,29 +208,29 @@ Returns VALUE."
;; Remove file properties of symlinks.
(when (and (stringp truename)
(not (string-equal file (directory-file-name truename))))
- (tramp-flush-file-property key truename))))
+ (tramp-flush-file-properties key truename))))
;;;###tramp-autoload
-(defun tramp-flush-directory-property (key directory)
+(defun tramp-flush-directory-properties (key directory)
"Remove all properties of DIRECTORY in the cache context of KEY.
Remove also properties of all files in subdirectories."
(setq directory (tramp-compat-file-name-unquote directory))
(let* ((directory (tramp-run-real-handler
- 'directory-file-name (list directory)))
+ #'directory-file-name (list directory)))
(truename (tramp-get-file-property key directory "file-truename" nil)))
(tramp-message key 8 "%s" directory)
(maphash
(lambda (key _value)
(when (and (tramp-file-name-p key)
(stringp (tramp-file-name-localname key))
- (string-match (regexp-quote directory)
- (tramp-file-name-localname key)))
+ (string-match-p (regexp-quote directory)
+ (tramp-file-name-localname key)))
(remhash key tramp-cache-data)))
tramp-cache-data)
;; Remove file properties of symlinks.
(when (and (stringp truename)
(not (string-equal directory (directory-file-name truename))))
- (tramp-flush-directory-property key truename))))
+ (tramp-flush-directory-properties key truename))))
;; Reverting or killing a buffer should also flush file properties.
;; They could have been changed outside Tramp. In eshell, "ls" would
@@ -216,26 +242,26 @@ Remove also properties of all files in subdirectories."
This is suppressed for temporary buffers."
(save-match-data
(unless (or (null (buffer-name))
- (string-match "^\\( \\|\\*\\)" (buffer-name)))
+ (string-match-p "^\\( \\|\\*\\)" (buffer-name)))
(let ((bfn (if (stringp (buffer-file-name))
(buffer-file-name)
default-directory))
(tramp-verbose 0))
(when (tramp-tramp-file-p bfn)
(with-parsed-tramp-file-name bfn nil
- (tramp-flush-file-property v localname)))))))
+ (tramp-flush-file-properties v localname)))))))
-(add-hook 'before-revert-hook 'tramp-flush-file-function)
-(add-hook 'eshell-pre-command-hook 'tramp-flush-file-function)
-(add-hook 'kill-buffer-hook 'tramp-flush-file-function)
+(add-hook 'before-revert-hook #'tramp-flush-file-function)
+(add-hook 'eshell-pre-command-hook #'tramp-flush-file-function)
+(add-hook 'kill-buffer-hook #'tramp-flush-file-function)
(add-hook 'tramp-cache-unload-hook
(lambda ()
(remove-hook 'before-revert-hook
- 'tramp-flush-file-function)
+ #'tramp-flush-file-function)
(remove-hook 'eshell-pre-command-hook
- 'tramp-flush-file-function)
+ #'tramp-flush-file-function)
(remove-hook 'kill-buffer-hook
- 'tramp-flush-file-function)))
+ #'tramp-flush-file-function)))
;;; -- Properties --
@@ -292,7 +318,24 @@ used to cache connection properties of the local machine."
(not (eq (tramp-get-connection-property key property 'undef) 'undef)))
;;;###tramp-autoload
-(defun tramp-flush-connection-property (key)
+(defun tramp-flush-connection-property (key property)
+ "Remove the named PROPERTY of a connection identified by KEY.
+KEY identifies the connection, it is either a process or a
+`tramp-file-name' structure. A special case is nil, which is
+used to cache connection properties of the local machine.
+PROPERTY is set persistent when KEY is a `tramp-file-name' structure."
+ ;; Unify key by removing localname and hop from `tramp-file-name'
+ ;; structure. Work with a copy in order to avoid side effects.
+ (when (tramp-file-name-p key)
+ (setq key (copy-tramp-file-name key))
+ (setf (tramp-file-name-localname key) nil
+ (tramp-file-name-hop key) nil))
+ (remhash property (tramp-get-hash-table key))
+ (setq tramp-cache-data-changed t)
+ (tramp-message key 7 "%s" property))
+
+;;;###tramp-autoload
+(defun tramp-flush-connection-properties (key)
"Remove all properties identified by KEY.
KEY identifies the connection, it is either a process or a
`tramp-file-name' structure. A special case is nil, which is
@@ -326,7 +369,7 @@ used to cache connection properties of the local machine."
(when (tramp-file-name-p key)
;; (dolist
;; (slot
- ;; (mapcar 'car (cdr (cl-struct-slot-info 'tramp-file-name))))
+ ;; (mapcar #'car (cdr (cl-struct-slot-info 'tramp-file-name))))
;; (when (stringp (cl-struct-slot-value 'tramp-file-name slot key))
;; (setf (cl-struct-slot-value 'tramp-file-name slot key)
;; (substring-no-properties
@@ -385,6 +428,8 @@ used to cache connection properties of the local machine."
(maphash
(lambda (key value)
(if (and (tramp-file-name-p key) value
+ (not (string-equal
+ (tramp-file-name-method key) tramp-archive-method))
(not (tramp-file-name-localname key))
(not (gethash "login-as" value))
(not (gethash "started" value)))
@@ -412,11 +457,11 @@ used to cache connection properties of the local machine."
(pp (read (format "(%s)" (tramp-cache-print cache)))))))))))
(unless noninteractive
- (add-hook 'kill-emacs-hook 'tramp-dump-connection-properties))
+ (add-hook 'kill-emacs-hook #'tramp-dump-connection-properties))
(add-hook 'tramp-cache-unload-hook
(lambda ()
(remove-hook 'kill-emacs-hook
- 'tramp-dump-connection-properties)))
+ #'tramp-dump-connection-properties)))
;;;###tramp-autoload
(defun tramp-parse-connection-properties (method)
diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el
index 1d35aa5a019..f1e1d8271ff 100644
--- a/lisp/net/tramp-cmds.el
+++ b/lisp/net/tramp-cmds.el
@@ -55,9 +55,9 @@ SYNTAX can be one of the symbols `default' (default),
"Return a list of all Tramp connection buffers."
(append
(all-completions
- "*tramp" (mapcar 'list (mapcar 'buffer-name (buffer-list))))
+ "*tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list))))
(all-completions
- "*debug tramp" (mapcar 'list (mapcar 'buffer-name (buffer-list))))))
+ "*debug tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list))))))
(defun tramp-list-remote-buffers ()
"Return a list of all buffers with remote default-directory."
@@ -69,6 +69,11 @@ SYNTAX can be one of the symbols `default' (default),
(buffer-list))))
;;;###tramp-autoload
+(defvar tramp-cleanup-connection-hook nil
+ "List of functions to be called after Tramp connection is cleaned up.
+Each function is called with the current vector as argument.")
+
+;;;###tramp-autoload
(defun tramp-cleanup-connection (vec &optional keep-debug keep-password)
"Flush all connection related objects.
This includes password cache, file cache, connection cache,
@@ -80,16 +85,7 @@ When called interactively, a Tramp connection has to be selected."
;; Return nil when there is no Tramp connection.
(list
(let ((connections
- (mapcar
- (lambda (x)
- (tramp-make-tramp-file-name
- (tramp-file-name-method x)
- (tramp-file-name-user x)
- (tramp-file-name-domain x)
- (tramp-file-name-host x)
- (tramp-file-name-port x)
- (tramp-file-name-localname x)))
- (tramp-list-connections)))
+ (mapcar #'tramp-make-tramp-file-name (tramp-list-connections)))
name)
(when connections
@@ -108,18 +104,17 @@ When called interactively, a Tramp connection has to be selected."
(unless keep-password (tramp-clear-passwd vec))
;; Cleanup `tramp-current-connection'. Otherwise, we would be
- ;; suppressed in the test suite. We use `keep-password' as
- ;; indicator; it is not worth to add a new argument.
- (when keep-password (setq tramp-current-connection nil))
+ ;; suppressed.
+ (setq tramp-current-connection nil)
;; Flush file cache.
- (tramp-flush-directory-property vec "")
+ (tramp-flush-directory-properties vec "")
;; Flush connection cache.
(when (processp (tramp-get-connection-process vec))
- (tramp-flush-connection-property (tramp-get-connection-process vec))
+ (tramp-flush-connection-properties (tramp-get-connection-process vec))
(delete-process (tramp-get-connection-process vec)))
- (tramp-flush-connection-property vec)
+ (tramp-flush-connection-properties vec)
;; Remove buffers.
(dolist
@@ -127,7 +122,10 @@ When called interactively, a Tramp connection has to be selected."
(unless keep-debug
(get-buffer (tramp-debug-buffer-name vec)))
(tramp-get-connection-property vec "process-buffer" nil)))
- (when (bufferp buf) (kill-buffer buf)))))
+ (when (bufferp buf) (kill-buffer buf)))
+
+ ;; The end.
+ (run-hook-with-args 'tramp-cleanup-connection-hook vec)))
;;;###tramp-autoload
(defun tramp-cleanup-this-connection ()
@@ -138,6 +136,10 @@ When called interactively, a Tramp connection has to be selected."
(tramp-dissect-file-name default-directory 'noexpand))))
;;;###tramp-autoload
+(defvar tramp-cleanup-all-connections-hook nil
+ "List of functions to be called after all Tramp connections are cleaned up.")
+
+;;;###tramp-autoload
(defun tramp-cleanup-all-connections ()
"Flush all Tramp internal objects.
This includes password cache, file cache, connection cache, buffers."
@@ -152,9 +154,25 @@ This includes password cache, file cache, connection cache, buffers."
;; Flush file and connection cache.
(clrhash tramp-cache-data)
+ ;; Remove ad-hoc proxies.
+ (let ((proxies tramp-default-proxies-alist))
+ (while proxies
+ (if (ignore-errors
+ (get-text-property 0 'tramp-ad-hoc (nth 2 (car proxies))))
+ (setq tramp-default-proxies-alist
+ (delete (car proxies) tramp-default-proxies-alist)
+ proxies tramp-default-proxies-alist)
+ (setq proxies (cdr proxies)))))
+ (when (and tramp-default-proxies-alist tramp-save-ad-hoc-proxies)
+ (customize-save-variable
+ 'tramp-default-proxies-alist tramp-default-proxies-alist))
+
;; Remove buffers.
(dolist (name (tramp-list-tramp-buffers))
- (when (bufferp (get-buffer name)) (kill-buffer name))))
+ (when (bufferp (get-buffer name)) (kill-buffer name)))
+
+ ;; The end.
+ (run-hooks 'tramp-cleanup-all-connections-hook))
;;;###tramp-autoload
(defun tramp-cleanup-all-buffers ()
@@ -186,16 +204,19 @@ This includes password cache, file cache, connection cache, buffers."
"Submit a bug report to the Tramp developers."
(interactive)
(catch 'dont-send
- (let ((reporter-prompt-for-summary-p t))
+ (let ((reporter-prompt-for-summary-p t)
+ ;; In rare cases, it could contain the password. So we make it nil.
+ tramp-password-save-function)
(reporter-submit-bug-report
- tramp-bug-report-address ; to-address
- (format "tramp (%s)" tramp-version) ; package name and version
+ tramp-bug-report-address ; to-address
+ (format "tramp (%s %s/%s)" ; package name and version
+ tramp-version tramp-repository-branch tramp-repository-version)
(sort
(delq nil (mapcar
(lambda (x)
(and x (boundp x) (cons x 'tramp-reporter-dump-variable)))
(append
- (mapcar 'intern (all-completions "tramp-" obarray 'boundp))
+ (mapcar #'intern (all-completions "tramp-" obarray #'boundp))
;; Non-tramp variables of interest.
'(shell-prompt-pattern
backup-by-copying
@@ -250,7 +271,7 @@ buffer in your bug report.
(set varsym (read (format "(%s)" (tramp-cache-print val))))
;; There are non-7bit characters to be masked.
(when (and (stringp val)
- (string-match
+ (string-match-p
(concat "[^" (bound-and-true-p mm-7bit-chars) "]") val))
(with-current-buffer reporter-eval-buffer
(set
@@ -266,10 +287,11 @@ buffer in your bug report.
;; Remove string quotation.
(forward-line -1)
(when (looking-at
- (concat "\\(^.*\\)" "\"" ;; \1 "
- "\\((base64-decode-string \\)" "\\\\" ;; \2 \
- "\\(\".*\\)" "\\\\" ;; \3 \
- "\\(\")\\)" "\"$")) ;; \4 "
+ (eval-when-compile
+ (concat "\\(^.*\\)" "\"" ;; \1 "
+ "\\((base64-decode-string \\)" "\\\\" ;; \2 \
+ "\\(\".*\\)" "\\\\" ;; \3 \
+ "\\(\")\\)" "\"$"))) ;; \4 "
(replace-match "\\1\\2\\3\\4")
(beginning-of-line)
(insert " ;; Variable encoded due to non-printable characters.\n"))
@@ -294,7 +316,7 @@ buffer in your bug report.
(delq nil
(mapcar
(lambda (b)
- (when (string-match "\\*tramp/" (buffer-name b)) b))
+ (when (string-match-p "\\*tramp/" (buffer-name b)) b))
(buffer-list))))
(let ((reporter-eval-buffer buffer)
(elbuf (get-buffer-create " *tmp-reporter-buffer*")))
@@ -308,11 +330,11 @@ buffer in your bug report.
(sort
(append
(mapcar
- 'intern
+ #'intern
(all-completions "tramp-" (buffer-local-variables buffer)))
;; Non-tramp variables of interest.
'(connection-local-variables-alist default-directory))
- 'string<))
+ #'string<))
(reporter-dump-variable varsym elbuf))
(lisp-indent-line)
(insert ")\n"))
@@ -322,7 +344,7 @@ buffer in your bug report.
(insert "\nload-path shadows:\n==================\n")
(ignore-errors
(mapc
- (lambda (x) (when (string-match "tramp" x) (insert x "\n")))
+ (lambda (x) (when (string-match-p "tramp" x) (insert x "\n")))
(split-string (list-load-path-shadows t) "\n")))
;; Append buffers only when we are in message mode.
@@ -390,7 +412,7 @@ please ensure that the buffers are attached to your email.\n\n"))
(kill-buffer nil)
(throw 'dont-send nil))))))
-(defalias 'tramp-submit-bug 'tramp-bug)
+(defalias 'tramp-submit-bug #'tramp-bug)
(add-hook 'tramp-unload-hook
(lambda () (unload-feature 'tramp-cmds 'force)))
diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el
index ccb1d1ce327..e3d03435691 100644
--- a/lisp/net/tramp-compat.el
+++ b/lisp/net/tramp-compat.el
@@ -29,6 +29,11 @@
;;; Code:
+;; In Emacs 24 and 25, `tramp-unload-file-name-handlers' is not
+;; autoloaded. So we declare it here in order to avoid recursive
+;; load. This will be overwritten in tramp.el.
+(defun tramp-unload-file-name-handlers ())
+
(require 'auth-source)
(require 'advice)
(require 'cl-lib)
@@ -40,9 +45,6 @@
(require 'timer)
(require 'ucs-normalize)
-(require 'trampver)
-(require 'tramp-loaddefs)
-
;; For not existing functions, obsolete functions, or functions with a
;; changed argument list, there are compiler warnings. We want to
;; avoid them in cases we know what we do.
@@ -71,7 +73,7 @@ Add the extension of F, if existing."
;; `temporary-file-directory' as function is introduced with Emacs 26.1.
(defalias 'tramp-compat-temporary-file-directory-function
(if (fboundp 'temporary-file-directory)
- 'temporary-file-directory
+ #'temporary-file-directory
'tramp-handle-temporary-file-directory))
(defun tramp-compat-process-running-p (process-name)
@@ -93,26 +95,19 @@ Add the extension of F, if existing."
;; The returned command name could be truncated
;; to 15 characters. Therefore, we cannot check
;; for `string-equal'.
- (and comm (string-match
+ (and comm (string-match-p
(concat "^" (regexp-quote comm))
process-name))))
(setq result t)))))))))
-;; `user-error' has appeared in Emacs 24.3.
-(defsubst tramp-compat-user-error (vec-or-proc format &rest args)
- "Signal a pilot error."
- (apply
- 'tramp-error vec-or-proc
- (if (fboundp 'user-error) 'user-error 'error) format args))
-
;; `default-toplevel-value' has been declared in Emacs 24.4.
(unless (fboundp 'default-toplevel-value)
- (defalias 'default-toplevel-value 'symbol-value))
+ (defalias 'default-toplevel-value #'symbol-value))
;; `file-attribute-*' are introduced in Emacs 25.1.
(if (fboundp 'file-attribute-type)
- (defalias 'tramp-compat-file-attribute-type 'file-attribute-type)
+ (defalias 'tramp-compat-file-attribute-type #'file-attribute-type)
(defsubst tramp-compat-file-attribute-type (attributes)
"The type field in ATTRIBUTES returned by `file-attributes'.
The value is either t for directory, string (name linked to) for
@@ -121,13 +116,13 @@ symbolic link, or nil."
(if (fboundp 'file-attribute-link-number)
(defalias 'tramp-compat-file-attribute-link-number
- 'file-attribute-link-number)
+ #'file-attribute-link-number)
(defsubst tramp-compat-file-attribute-link-number (attributes)
"Return the number of links in ATTRIBUTES returned by `file-attributes'."
(nth 1 attributes)))
(if (fboundp 'file-attribute-user-id)
- (defalias 'tramp-compat-file-attribute-user-id 'file-attribute-user-id)
+ (defalias 'tramp-compat-file-attribute-user-id #'file-attribute-user-id)
(defsubst tramp-compat-file-attribute-user-id (attributes)
"The UID field in ATTRIBUTES returned by `file-attributes'.
This is either a string or a number. If a string value cannot be
@@ -136,7 +131,7 @@ returned."
(nth 2 attributes)))
(if (fboundp 'file-attribute-group-id)
- (defalias 'tramp-compat-file-attribute-group-id 'file-attribute-group-id)
+ (defalias 'tramp-compat-file-attribute-group-id #'file-attribute-group-id)
(defsubst tramp-compat-file-attribute-group-id (attributes)
"The GID field in ATTRIBUTES returned by `file-attributes'.
This is either a string or a number. If a string value cannot be
@@ -146,23 +141,23 @@ returned."
(if (fboundp 'file-attribute-modification-time)
(defalias 'tramp-compat-file-attribute-modification-time
- 'file-attribute-modification-time)
+ #'file-attribute-modification-time)
(defsubst tramp-compat-file-attribute-modification-time (attributes)
"The modification time in ATTRIBUTES returned by `file-attributes'.
This is the time of the last change to the file's contents, and
-is a list of integers (HIGH LOW USEC PSEC) in the same style
-as (current-time)."
+is a Lisp timestamp in the style of `current-time'."
(nth 5 attributes)))
(if (fboundp 'file-attribute-size)
- (defalias 'tramp-compat-file-attribute-size 'file-attribute-size)
+ (defalias 'tramp-compat-file-attribute-size #'file-attribute-size)
(defsubst tramp-compat-file-attribute-size (attributes)
"The size (in bytes) in ATTRIBUTES returned by `file-attributes'.
-This is a floating point number if the size is too large for an integer."
+If the size is too large for a fixnum, this is a bignum in Emacs 27
+and later, and is a float in Emacs 26 and earlier."
(nth 7 attributes)))
(if (fboundp 'file-attribute-modes)
- (defalias 'tramp-compat-file-attribute-modes 'file-attribute-modes)
+ (defalias 'tramp-compat-file-attribute-modes #'file-attribute-modes)
(defsubst tramp-compat-file-attribute-modes (attributes)
"The file modes in ATTRIBUTES returned by `file-attributes'.
This is a string of ten letters or dashes as in ls -l."
@@ -170,11 +165,11 @@ This is a string of ten letters or dashes as in ls -l."
;; `format-message' is new in Emacs 25.1.
(unless (fboundp 'format-message)
- (defalias 'format-message 'format))
+ (defalias 'format-message #'format))
;; `directory-name-p' is new in Emacs 25.1.
(if (fboundp 'directory-name-p)
- (defalias 'tramp-compat-directory-name-p 'directory-name-p)
+ (defalias 'tramp-compat-directory-name-p #'directory-name-p)
(defsubst tramp-compat-directory-name-p (name)
"Return non-nil if NAME ends with a directory separator character."
(let ((len (length name))
@@ -190,49 +185,50 @@ This is a string of ten letters or dashes as in ls -l."
(if (get 'file-missing 'error-conditions) 'file-missing 'file-error)
"The error symbol for the `file-missing' error.")
-(add-hook 'tramp-unload-hook
- (lambda ()
- (unload-feature 'tramp-loaddefs 'force)
- (unload-feature 'tramp-compat 'force)))
-
-;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' are
-;; introduced in Emacs 26.
+;; `file-local-name', `file-name-quoted-p', `file-name-quote' and
+;; `file-name-unquote' are introduced in Emacs 26.
(eval-and-compile
+ (if (fboundp 'file-local-name)
+ (defalias 'tramp-compat-file-local-name #'file-local-name)
+ (defsubst tramp-compat-file-local-name (name)
+ "Return the local name component of NAME.
+It returns a file name which can be used directly as argument of
+`process-file', `start-file-process', or `shell-command'."
+ (or (file-remote-p name 'localname) name)))
+
(if (fboundp 'file-name-quoted-p)
- (defalias 'tramp-compat-file-name-quoted-p 'file-name-quoted-p)
+ (defalias 'tramp-compat-file-name-quoted-p #'file-name-quoted-p)
(defsubst tramp-compat-file-name-quoted-p (name)
"Whether NAME is quoted with prefix \"/:\".
If NAME is a remote file name, check the local part of NAME."
- (string-match "^/:" (or (file-remote-p name 'localname) name))))
+ (string-prefix-p "/:" (tramp-compat-file-local-name name))))
(if (fboundp 'file-name-quote)
- (defalias 'tramp-compat-file-name-quote 'file-name-quote)
+ (defalias 'tramp-compat-file-name-quote #'file-name-quote)
(defsubst tramp-compat-file-name-quote (name)
"Add the quotation prefix \"/:\" to file NAME.
If NAME is a remote file name, the local part of NAME is quoted."
(if (tramp-compat-file-name-quoted-p name)
name
(concat
- (file-remote-p name) "/:" (or (file-remote-p name 'localname) name)))))
+ (file-remote-p name) "/:" (tramp-compat-file-local-name name)))))
(if (fboundp 'file-name-unquote)
- (defalias 'tramp-compat-file-name-unquote 'file-name-unquote)
+ (defalias 'tramp-compat-file-name-unquote #'file-name-unquote)
(defsubst tramp-compat-file-name-unquote (name)
"Remove quotation prefix \"/:\" from file NAME.
If NAME is a remote file name, the local part of NAME is unquoted."
- (save-match-data
- (let ((localname (or (file-remote-p name 'localname) name)))
- (when (tramp-compat-file-name-quoted-p localname)
- (setq
- localname
- (replace-match
- (if (= (length localname) 2) "/" "") nil t localname)))
- (concat (file-remote-p name) localname))))))
+ (let ((localname (tramp-compat-file-local-name name)))
+ (when (tramp-compat-file-name-quoted-p localname)
+ (setq
+ localname (if (= (length localname) 2) "/" (substring localname 2))))
+ (concat (file-remote-p name) localname)))))
;; `tramp-syntax' has changed its meaning in Emacs 26. We still
;; support old settings.
(defsubst tramp-compat-tramp-syntax ()
"Return proper value of `tramp-syntax'."
+ (defvar tramp-syntax)
(cond ((eq tramp-syntax 'ftp) 'default)
((eq tramp-syntax 'sep) 'separate)
(t tramp-syntax)))
@@ -240,11 +236,59 @@ If NAME is a remote file name, the local part of NAME is unquoted."
;; `cl-struct-slot-info' has been introduced with Emacs 25.
(defmacro tramp-compat-tramp-file-name-slots ()
(if (fboundp 'cl-struct-slot-info)
- `(cdr (mapcar 'car (cl-struct-slot-info 'tramp-file-name)))
- `(cdr (mapcar 'car (get 'tramp-file-name 'cl-struct-slots)))))
+ '(cdr (mapcar #'car (cl-struct-slot-info 'tramp-file-name)))
+ '(cdr (mapcar #'car (get 'tramp-file-name 'cl-struct-slots)))))
+
+;; The signature of `tramp-make-tramp-file-name' has been changed.
+;; Therefore, we cannot us `url-tramp-convert-url-to-tramp' prior
+;; Emacs 26.1. We use `temporary-file-directory' as indicator.
+(defconst tramp-compat-use-url-tramp-p (fboundp 'temporary-file-directory)
+ "Whether to use url-tramp.el.")
+
+;; `exec-path' is new in Emacs 27.1.
+(eval-and-compile
+ (if (fboundp 'exec-path)
+ (defalias 'tramp-compat-exec-path #'exec-path)
+ (defun tramp-compat-exec-path ()
+ "List of directories to search programs to run in remote subprocesses."
+ (let ((handler (find-file-name-handler default-directory 'exec-path)))
+ (if handler
+ (funcall handler 'exec-path)
+ exec-path)))))
+
+;; `time-equal-p' has appeared in Emacs 27.1.
+(if (fboundp 'time-equal-p)
+ (defalias 'tramp-compat-time-equal-p #'time-equal-p)
+ (defsubst tramp-compat-time-equal-p (t1 t2)
+ "Return non-nil if time value T1 is equal to time value T2.
+A nil value for either argument stands for the current time."
+ (equal (or t1 (current-time)) (or t2 (current-time)))))
+
+;; `flatten-tree' has appeared in Emacs 27.1.
+(if (fboundp 'flatten-tree)
+ (defalias 'tramp-compat-flatten-tree #'flatten-tree)
+ (defun tramp-compat-flatten-tree (tree)
+ "Take TREE and \"flatten\" it."
+ (let (elems)
+ (setq tree (list tree))
+ (while (let ((elem (pop tree)))
+ (cond ((consp elem)
+ (setq tree (cons (car elem) (cons (cdr elem) tree))))
+ (elem
+ (push elem elems)))
+ tree))
+ (nreverse elems))))
+
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-loaddefs 'force)
+ (unload-feature 'tramp-compat 'force)))
(provide 'tramp-compat)
;;; TODO:
+;; * When we get rid of Emacs 24, replace "(mapconcat #'identity" by
+;; "(string-join".
+
;;; tramp-compat.el ends here
diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el
index de9bb4024da..d1aae22a484 100644
--- a/lisp/net/tramp-ftp.el
+++ b/lisp/net/tramp-ftp.el
@@ -54,10 +54,9 @@ present for backward compatibility."
(delete a1 (delete a2 file-name-handler-alist)))))
(eval-after-load "ange-ftp"
- '(when (functionp 'tramp-disable-ange-ftp)
- (tramp-disable-ange-ftp)))
+ '(tramp-disable-ange-ftp))
-;;;###autoload
+;;;###tramp-autoload
(defun tramp-ftp-enable-ange-ftp ()
"Reenable Ange-FTP, when Tramp is unloaded."
;; The following code is commented out in Ange-FTP.
@@ -86,7 +85,7 @@ present for backward compatibility."
ange-ftp-completion-hook-function)
file-name-handler-alist)))))
-(add-hook 'tramp-ftp-unload-hook 'tramp-ftp-enable-ange-ftp)
+(add-hook 'tramp-ftp-unload-hook #'tramp-ftp-enable-ange-ftp)
;; Define FTP method ...
;;;###tramp-autoload
@@ -95,22 +94,19 @@ present for backward compatibility."
;; ... and add it to the method list.
;;;###tramp-autoload
-(add-to-list 'tramp-methods (cons tramp-ftp-method nil))
+(tramp--with-startup
+ (add-to-list 'tramp-methods (cons tramp-ftp-method nil))
-;; Add some defaults for `tramp-default-method-alist'.
-;;;###tramp-autoload
-(add-to-list 'tramp-default-method-alist
- (list "\\`ftp\\." nil tramp-ftp-method))
-;;;###tramp-autoload
-(add-to-list 'tramp-default-method-alist
- (list nil "\\`\\(anonymous\\|ftp\\)\\'" tramp-ftp-method))
+ ;; Add some defaults for `tramp-default-method-alist'.
+ (add-to-list 'tramp-default-method-alist
+ (list "\\`ftp\\." nil tramp-ftp-method))
+ (add-to-list 'tramp-default-method-alist
+ (list nil "\\`\\(anonymous\\|ftp\\)\\'" tramp-ftp-method))
-;; Add completion function for FTP method.
-;;;###tramp-autoload
-(eval-after-load 'tramp
- '(tramp-set-completion-function
- tramp-ftp-method
- '((tramp-parse-netrc "~/.netrc"))))
+ ;; Add completion function for FTP method.
+ (tramp-set-completion-function
+ tramp-ftp-method
+ '((tramp-parse-netrc "~/.netrc"))))
;;;###tramp-autoload
(defun tramp-ftp-file-name-handler (operation &rest args)
@@ -142,7 +138,7 @@ pass to the OPERATION."
;; because this returns another user but the one declared in
;; "~/.netrc".
((memq operation '(file-directory-p file-exists-p))
- (if (apply 'ange-ftp-hook-function operation args)
+ (if (apply #'ange-ftp-hook-function operation args)
(let ((v (tramp-dissect-file-name (car args) t)))
(setf (tramp-file-name-method v) tramp-ftp-method)
(tramp-set-connection-property v "started" t))
@@ -176,19 +172,21 @@ pass to the OPERATION."
(and (eq inhibit-file-name-operation operation)
inhibit-file-name-handlers)))
(inhibit-file-name-operation operation))
- (apply 'ange-ftp-hook-function operation args)))))))
+ (apply #'ange-ftp-hook-function operation args)))))))
;; It must be a `defsubst' in order to push the whole code into
;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading.
;;;###tramp-autoload
(defsubst tramp-ftp-file-name-p (filename)
"Check if it's a filename that should be forwarded to Ange-FTP."
- (string= (tramp-file-name-method (tramp-dissect-file-name filename))
- tramp-ftp-method))
+ (and (tramp-tramp-file-p filename)
+ (string= (tramp-file-name-method (tramp-dissect-file-name filename))
+ tramp-ftp-method)))
;;;###tramp-autoload
-(add-to-list 'tramp-foreign-file-name-handler-alist
- (cons 'tramp-ftp-file-name-p 'tramp-ftp-file-name-handler))
+(tramp--with-startup
+ (add-to-list 'tramp-foreign-file-name-handler-alist
+ (cons #'tramp-ftp-file-name-p #'tramp-ftp-file-name-handler)))
(add-hook 'tramp-unload-hook
(lambda ()
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index 4a4be5c51f3..8fea82d97c4 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -47,17 +47,19 @@
;; discovered during development time, is given in respective
;; comments.
-;; The custom option `tramp-gvfs-methods' contains the list of
-;; supported connection methods. Per default, these are "afp", "dav",
-;; "davs", "gdrive", "obex", "sftp" and "synce". Note that with
-;; "obex" it might be necessary to pair with the other bluetooth
-;; device, if it hasn't been done already. There might be also some
-;; few seconds delay in discovering available bluetooth devices.
-
-;; Other possible connection methods are "ftp" and "smb". When one of
-;; these methods is added to the list, the remote access for that
-;; method is performed via GVFS instead of the native Tramp
-;; implementation.
+;; The user option `tramp-gvfs-methods' contains the list of supported
+;; connection methods. Per default, these are "afp", "dav", "davs",
+;; "gdrive", "nextcloud" and "sftp".
+
+;; "gdrive" and "nextcloud" connection methods require a respective
+;; account in GNOME Online Accounts, with enabled "Files" service.
+
+;; Other possible connection methods are "ftp", "http", "https" and
+;; "smb". When one of these methods is added to the list, the remote
+;; access for that method is performed via GVFS instead of the native
+;; Tramp implementation. However, this is not recommended. These
+;; methods are listed here for the benefit of file archives, see
+;; tramp-archive.el.
;; GVFS offers even more connection methods. The complete list of
;; connection methods of the actual GVFS implementation can be
@@ -66,28 +68,26 @@
;; (message
;; "%s"
;; (mapcar
-;; 'car
+;; #'car
;; (dbus-call-method
;; :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
;; tramp-gvfs-interface-mounttracker "ListMountableInfo")))
+;; See also /usr/share/gvfs/mounts
+
;; Note that all other connection methods are not tested, beside the
;; ones offered for customization in `tramp-gvfs-methods'. If you
;; request an additional connection method to be supported, please
;; drop me a note.
-;; For hostname completion, information is retrieved either from the
-;; bluez daemon (for the "obex" method), the hal daemon (for the
-;; "synce" method), or from the zeroconf daemon (for the "afp", "dav",
-;; "davs", and "sftp" methods). The zeroconf daemon is pre-configured
-;; to discover services in the "local" domain. If another domain
-;; shall be used for discovering services, the custom option
-;; `tramp-gvfs-zeroconf-domain' can be set accordingly.
+;; For hostname completion, information is retrieved from the zeroconf
+;; daemon (for the "afp", "dav", "davs", and "sftp" methods). The
+;; zeroconf daemon is pre-configured to discover services in the
+;; "local" domain. If another domain shall be used for discovering
+;; services, the user option `tramp-gvfs-zeroconf-domain' can be set
+;; accordingly.
;; Restrictions:
-
-;; * The current GVFS implementation does not allow writing on the
-;; remote bluetooth device via OBEX.
;;
;; * Two shares of the same SMB server cannot be mounted in parallel.
@@ -97,6 +97,7 @@
;; option "--without-dbus". Declare used subroutines and variables.
(declare-function dbus-get-unique-name "dbusbind.c")
+(eval-when-compile (require 'cl-lib))
(require 'tramp)
(require 'dbus)
@@ -108,34 +109,52 @@
(eval-when-compile
(require 'custom))
+;; We don't call `dbus-ping', because this would load dbus.el.
+(defconst tramp-gvfs-enabled
+ (ignore-errors
+ (and (featurep 'dbusbind)
+ (tramp-compat-funcall 'dbus-get-unique-name :system)
+ (tramp-compat-funcall 'dbus-get-unique-name :session)
+ (or (tramp-compat-process-running-p "gvfs-fuse-daemon")
+ (tramp-compat-process-running-p "gvfsd-fuse"))))
+ "Non-nil when GVFS is available.")
+
;;;###tramp-autoload
(defcustom tramp-gvfs-methods
- '("afp" "dav" "davs" "gdrive" "obex" "sftp" "synce")
+ '("afp" "dav" "davs" "gdrive" "nextcloud" "sftp")
"List of methods for remote files, accessed with GVFS."
:group 'tramp
- :version "26.1"
+ :version "27.1"
:type '(repeat (choice (const "afp")
(const "dav")
(const "davs")
(const "ftp")
(const "gdrive")
- (const "obex")
+ (const "http")
+ (const "https")
+ (const "nextcloud")
(const "sftp")
- (const "smb")
- (const "synce"))))
+ (const "smb"))))
+
+(defconst tramp-goa-methods '("gdrive" "nextcloud")
+ "List of methods which require registration at GNOME Online Accounts.")
+
+;; Remove GNOME Online Accounts methods if not supported.
+(unless (and tramp-gvfs-enabled
+ (member tramp-goa-service (dbus-list-known-names :session)))
+ (dolist (method tramp-goa-methods)
+ (setq tramp-gvfs-methods (delete method tramp-gvfs-methods))))
;; Add defaults for `tramp-default-user-alist' and `tramp-default-host-alist'.
;;;###tramp-autoload
-(when (string-match "\\(.+\\)@\\(\\(?:gmail\\|googlemail\\)\\.com\\)"
- user-mail-address)
- (add-to-list 'tramp-default-user-alist
- `("\\`gdrive\\'" nil ,(match-string 1 user-mail-address)))
- (add-to-list 'tramp-default-host-alist
- '("\\`gdrive\\'" nil ,(match-string 2 user-mail-address))))
-;;;###tramp-autoload
-(add-to-list 'tramp-default-user-alist '("\\`synce\\'" nil nil))
+(tramp--with-startup
+ (when (string-match "\\(.+\\)@\\(\\(?:gmail\\|googlemail\\)\\.com\\)"
+ user-mail-address)
+ (add-to-list 'tramp-default-user-alist
+ `("\\`gdrive\\'" nil ,(match-string 1 user-mail-address)))
+ (add-to-list 'tramp-default-host-alist
+ '("\\`gdrive\\'" nil ,(match-string 2 user-mail-address)))))
-;;;###tramp-autoload
(defcustom tramp-gvfs-zeroconf-domain "local"
"Zeroconf domain to be used for discovering services, like host names."
:group 'tramp
@@ -146,9 +165,10 @@
;; completion.
;;;###tramp-autoload
(when (featurep 'dbusbind)
- (dolist (elt tramp-gvfs-methods)
- (unless (assoc elt tramp-methods)
- (add-to-list 'tramp-methods (cons elt nil)))))
+ (tramp--with-startup
+ (dolist (elt tramp-gvfs-methods)
+ (unless (assoc elt tramp-methods)
+ (add-to-list 'tramp-methods (cons elt nil))))))
(defconst tramp-gvfs-path-tramp (concat dbus-path-emacs "/Tramp")
"The preceding object path for own objects.")
@@ -156,16 +176,6 @@
(defconst tramp-gvfs-service-daemon "org.gtk.vfs.Daemon"
"The well known name of the GVFS daemon.")
-;; We don't call `dbus-ping', because this would load dbus.el.
-(defconst tramp-gvfs-enabled
- (ignore-errors
- (and (featurep 'dbusbind)
- (tramp-compat-funcall 'dbus-get-unique-name :system)
- (tramp-compat-funcall 'dbus-get-unique-name :session)
- (or (tramp-compat-process-running-p "gvfs-fuse-daemon")
- (tramp-compat-process-running-p "gvfsd-fuse"))))
- "Non-nil when GVFS is available.")
-
(defconst tramp-gvfs-path-mounttracker "/org/gtk/vfs/mounttracker"
"The object path of the GVFS daemon.")
@@ -287,131 +297,161 @@ It has been changed in GVFS 1.14.")
(defconst tramp-gvfs-password-anonymous-supported 16
"Operation supports anonymous users.")
-(defconst tramp-bluez-service "org.bluez"
- "The well known name of the BLUEZ service.")
+;; For the time being, we just need org.goa.Account and org.goa.Files
+;; interfaces. We document the other ones, just in case.
-(defconst tramp-bluez-interface-manager "org.bluez.Manager"
- "The manager interface of the BLUEZ daemon.")
+;;;###tramp-autoload
+(defconst tramp-goa-service "org.gnome.OnlineAccounts"
+ "The well known name of the GNOME Online Accounts service.")
-;; <interface name='org.bluez.Manager'>
-;; <method name='DefaultAdapter'>
-;; <arg type='o' direction='out'/>
-;; </method>
-;; <method name='FindAdapter'>
-;; <arg type='s' direction='in'/>
-;; <arg type='o' direction='out'/>
-;; </method>
-;; <method name='ListAdapters'>
-;; <arg type='ao' direction='out'/>
-;; </method>
-;; <signal name='AdapterAdded'>
-;; <arg type='o'/>
-;; </signal>
-;; <signal name='AdapterRemoved'>
-;; <arg type='o'/>
-;; </signal>
-;; <signal name='DefaultAdapterChanged'>
-;; <arg type='o'/>
-;; </signal>
+(defconst tramp-goa-path "/org/gnome/OnlineAccounts"
+ "The object path of the GNOME Online Accounts.")
+
+(defconst tramp-goa-path-accounts (concat tramp-goa-path "/Accounts")
+ "The object path of the GNOME Online Accounts accounts.")
+
+(defconst tramp-goa-interface-documents "org.gnome.OnlineAccounts.Documents"
+ "The documents interface of the GNOME Online Accounts.")
+
+;; <interface name='org.gnome.OnlineAccounts.Documents'>
;; </interface>
-(defconst tramp-bluez-interface-adapter "org.bluez.Adapter"
- "The adapter interface of the BLUEZ daemon.")
+(defconst tramp-goa-interface-printers "org.gnome.OnlineAccounts.Printers"
+ "The printers interface of the GNOME Online Accounts.")
-;; <interface name='org.bluez.Adapter'>
-;; <method name='GetProperties'>
-;; <arg type='a{sv}' direction='out'/>
-;; </method>
-;; <method name='SetProperty'>
-;; <arg type='s' direction='in'/>
-;; <arg type='v' direction='in'/>
-;; </method>
-;; <method name='RequestMode'>
-;; <arg type='s' direction='in'/>
-;; </method>
-;; <method name='ReleaseMode'/>
-;; <method name='RequestSession'/>
-;; <method name='ReleaseSession'/>
-;; <method name='StartDiscovery'/>
-;; <method name='StopDiscovery'/>
-;; <method name='ListDevices'>
-;; <arg type='ao' direction='out'/>
-;; </method>
-;; <method name='CreateDevice'>
-;; <arg type='s' direction='in'/>
-;; <arg type='o' direction='out'/>
-;; </method>
-;; <method name='CreatePairedDevice'>
-;; <arg type='s' direction='in'/>
-;; <arg type='o' direction='in'/>
-;; <arg type='s' direction='in'/>
-;; <arg type='o' direction='out'/>
-;; </method>
-;; <method name='CancelDeviceCreation'>
-;; <arg type='s' direction='in'/>
-;; </method>
-;; <method name='RemoveDevice'>
-;; <arg type='o' direction='in'/>
-;; </method>
-;; <method name='FindDevice'>
-;; <arg type='s' direction='in'/>
-;; <arg type='o' direction='out'/>
-;; </method>
-;; <method name='RegisterAgent'>
-;; <arg type='o' direction='in'/>
-;; <arg type='s' direction='in'/>
+;; <interface name='org.gnome.OnlineAccounts.Printers'>
+;; </interface>
+
+(defconst tramp-goa-interface-files "org.gnome.OnlineAccounts.Files"
+ "The files interface of the GNOME Online Accounts.")
+
+;; <interface name='org.gnome.OnlineAccounts.Files'>
+;; <property type='b' name='AcceptSslErrors' access='read'/>
+;; <property type='s' name='Uri' access='read'/>
+;; </interface>
+
+(defconst tramp-goa-interface-contacts "org.gnome.OnlineAccounts.Contacts"
+ "The contacts interface of the GNOME Online Accounts.")
+
+;; <interface name='org.gnome.OnlineAccounts.Contacts'>
+;; <property type='b' name='AcceptSslErrors' access='read'/>
+;; <property type='s' name='Uri' access='read'/>
+;; </interface>
+
+(defconst tramp-goa-interface-calendar "org.gnome.OnlineAccounts.Calendar"
+ "The calendar interface of the GNOME Online Accounts.")
+
+;; <interface name='org.gnome.OnlineAccounts.Calendar'>
+;; <property type='b' name='AcceptSslErrors' access='read'/>
+;; <property type='s' name='Uri' access='read'/>
+;; </interface>
+
+(defconst tramp-goa-interface-oauth2based "org.gnome.OnlineAccounts.OAuth2Based"
+ "The oauth2based interface of the GNOME Online Accounts.")
+
+;; <interface name='org.gnome.OnlineAccounts.OAuth2Based'>
+;; <method name='GetAccessToken'>
+;; <arg type='s' name='access_token' direction='out'/>
+;; <arg type='i' name='expires_in' direction='out'/>
;; </method>
-;; <method name='UnregisterAgent'>
-;; <arg type='o' direction='in'/>
+;; <property type='s' name='ClientId' access='read'/>
+;; <property type='s' name='ClientSecret' access='read'/>
+;; </interface>
+
+(defconst tramp-goa-interface-account "org.gnome.OnlineAccounts.Account"
+ "The account interface of the GNOME Online Accounts.")
+
+;; <interface name='org.gnome.OnlineAccounts.Account'>
+;; <method name='Remove'/>
+;; <method name='EnsureCredentials'>
+;; <arg type='i' name='expires_in' direction='out'/>
;; </method>
-;; <signal name='DeviceCreated'>
-;; <arg type='o'/>
-;; </signal>
-;; <signal name='DeviceRemoved'>
-;; <arg type='o'/>
-;; </signal>
-;; <signal name='DeviceFound'>
-;; <arg type='s'/>
-;; <arg type='a{sv}'/>
-;; </signal>
-;; <signal name='PropertyChanged'>
-;; <arg type='s'/>
-;; <arg type='v'/>
-;; </signal>
-;; <signal name='DeviceDisappeared'>
-;; <arg type='s'/>
-;; </signal>
+;; <property type='s' name='ProviderType' access='read'/>
+;; <property type='s' name='ProviderName' access='read'/>
+;; <property type='s' name='ProviderIcon' access='read'/>
+;; <property type='s' name='Id' access='read'/>
+;; <property type='b' name='IsLocked' access='read'/>
+;; <property type='b' name='IsTemporary' access='readwrite'/>
+;; <property type='b' name='AttentionNeeded' access='read'/>
+;; <property type='s' name='Identity' access='read'/>
+;; <property type='s' name='PresentationIdentity' access='read'/>
+;; <property type='b' name='MailDisabled' access='readwrite'/>
+;; <property type='b' name='CalendarDisabled' access='readwrite'/>
+;; <property type='b' name='ContactsDisabled' access='readwrite'/>
+;; <property type='b' name='ChatDisabled' access='readwrite'/>
+;; <property type='b' name='DocumentsDisabled' access='readwrite'/>
+;; <property type='b' name='MapsDisabled' access='readwrite'/>
+;; <property type='b' name='MusicDisabled' access='readwrite'/>
+;; <property type='b' name='PrintersDisabled' access='readwrite'/>
+;; <property type='b' name='PhotosDisabled' access='readwrite'/>
+;; <property type='b' name='FilesDisabled' access='readwrite'/>
+;; <property type='b' name='TicketingDisabled' access='readwrite'/>
+;; <property type='b' name='TodoDisabled' access='readwrite'/>
+;; <property type='b' name='ReadLaterDisabled' access='readwrite'/>
;; </interface>
-;;;###tramp-autoload
-(defcustom tramp-bluez-discover-devices-timeout 60
- "Defines seconds since last bluetooth device discovery before rescanning.
-A value of 0 would require an immediate discovery during hostname
-completion, nil means to use always cached values for discovered
-devices."
- :group 'tramp
- :version "23.2"
- :type '(choice (const nil) integer))
+(defconst tramp-goa-identity-regexp
+ (concat "^" "\\(" tramp-user-regexp "\\)?"
+ "@" "\\(" tramp-host-regexp "\\)?"
+ "\\(?:" ":""\\(" tramp-port-regexp "\\)" "\\)?")
+ "Regexp matching GNOME Online Accounts \"PresentationIdentity\" property.")
+
+(defconst tramp-goa-interface-mail "org.gnome.OnlineAccounts.Mail"
+ "The mail interface of the GNOME Online Accounts.")
+
+;; <interface name='org.gnome.OnlineAccounts.Mail'>
+;; <property type='s' name='EmailAddress' access='read'/>
+;; <property type='s' name='Name' access='read'/>
+;; <property type='b' name='ImapSupported' access='read'/>
+;; <property type='b' name='ImapAcceptSslErrors' access='read'/>
+;; <property type='s' name='ImapHost' access='read'/>
+;; <property type='b' name='ImapUseSsl' access='read'/>
+;; <property type='b' name='ImapUseTls' access='read'/>
+;; <property type='s' name='ImapUserName' access='read'/>
+;; <property type='b' name='SmtpSupported' access='read'/>
+;; <property type='b' name='SmtpAcceptSslErrors' access='read'/>
+;; <property type='s' name='SmtpHost' access='read'/>
+;; <property type='b' name='SmtpUseAuth' access='read'/>
+;; <property type='b' name='SmtpAuthLogin' access='read'/>
+;; <property type='b' name='SmtpAuthPlain' access='read'/>
+;; <property type='b' name='SmtpAuthXoauth2' access='read'/>
+;; <property type='b' name='SmtpUseSsl' access='read'/>
+;; <property type='b' name='SmtpUseTls' access='read'/>
+;; <property type='s' name='SmtpUserName' access='read'/>
+;; </interface>
+
+(defconst tramp-goa-interface-chat "org.gnome.OnlineAccounts.Chat"
+ "The chat interface of the GNOME Online Accounts.")
+
+;; <interface name='org.gnome.OnlineAccounts.Chat'>
+;; </interface>
-(defvar tramp-bluez-discovery nil
- "Indicator for a running bluetooth device discovery.
-It keeps the timestamp of last discovery.")
+(defconst tramp-goa-interface-photos "org.gnome.OnlineAccounts.Photos"
+ "The photos interface of the GNOME Online Accounts.")
-(defvar tramp-bluez-devices nil
- "Alist of detected bluetooth devices.
-Every entry is a list (NAME ADDRESS).")
+;; <interface name='org.gnome.OnlineAccounts.Photos'>
+;; </interface>
-(defconst tramp-hal-service "org.freedesktop.Hal"
- "The well known name of the HAL service.")
+(defconst tramp-goa-path-manager (concat tramp-goa-path "/Manager")
+ "The object path of the GNOME Online Accounts manager.")
-(defconst tramp-hal-path-manager "/org/freedesktop/Hal/Manager"
- "The object path of the HAL daemon manager.")
+(defconst tramp-goa-interface-documents "org.gnome.OnlineAccounts.Manager"
+ "The manager interface of the GNOME Online Accounts.")
-(defconst tramp-hal-interface-manager "org.freedesktop.Hal.Manager"
- "The manager interface of the HAL daemon.")
+;; <interface name='org.gnome.OnlineAccounts.Manager'>
+;; <method name='AddAccount'>
+;; <arg type='s' name='provider' direction='in'/>
+;; <arg type='s' name='identity' direction='in'/>
+;; <arg type='s' name='presentation_identity' direction='in'/>
+;; <arg type='a{sv}' name='credentials' direction='in'/>
+;; <arg type='a{ss}' name='details' direction='in'/>
+;; <arg type='o' name='account_object_path' direction='out'/>
+;; </method>
+;; </interface>
-(defconst tramp-hal-interface-device "org.freedesktop.Hal.Device"
- "The device interface of the HAL daemon.")
+;; The basic structure for GNOME Online Accounts. We use a list :type,
+;; in order to be compatible with Emacs 24 and 25.
+(cl-defstruct (tramp-goa-name (:type list) :named) method user host port)
;; "gvfs-<command>" utilities have been deprecated in GVFS 1.31.1. We
;; must use "gio <command>" tool instead.
@@ -421,11 +461,13 @@ Every entry is a list (NAME ADDRESS).")
("gvfs-ls" . "list")
("gvfs-mkdir" . "mkdir")
("gvfs-monitor-file" . "monitor")
+ ("gvfs-mount" . "mount")
("gvfs-move" . "move")
("gvfs-rm" . "remove")
("gvfs-trash" . "trash"))
"List of cons cells, mapping \"gvfs-<command>\" to \"gio <command>\".")
+;; <http://www.pygtk.org/docs/pygobject/gio-constants.html>
(defconst tramp-gvfs-file-attributes
'("name"
"type"
@@ -470,11 +512,18 @@ Every entry is a list (NAME ADDRESS).")
":[[:blank:]]+\\(.*\\)$")
"Regexp to parse GVFS file system attributes with `gvfs-info'.")
+(defconst tramp-gvfs-nextcloud-default-prefix "/remote.php/webdav"
+ "Default prefix for owncloud / nextcloud methods.")
+
+(defconst tramp-gvfs-nextcloud-default-prefix-regexp
+ (concat (regexp-quote tramp-gvfs-nextcloud-default-prefix) "$")
+ "Regexp of default prefix for owncloud / nextcloud methods.")
+
;; New handlers should be added here.
;;;###tramp-autoload
(defconst tramp-gvfs-file-name-handler-alist
- '((access-file . ignore)
+ '((access-file . tramp-handle-access-file)
(add-name-to-file . tramp-handle-add-name-to-file)
;; `byte-compiler-base-file-name' performed by default handler.
;; `copy-directory' performed by default handler.
@@ -488,16 +537,17 @@ Every entry is a list (NAME ADDRESS).")
. tramp-handle-directory-files-and-attributes)
(dired-compress-file . ignore)
(dired-uncache . tramp-handle-dired-uncache)
+ (exec-path . ignore)
(expand-file-name . tramp-gvfs-handle-expand-file-name)
(file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
(file-acl . ignore)
(file-attributes . tramp-gvfs-handle-file-attributes)
- (file-directory-p . tramp-gvfs-handle-file-directory-p)
+ (file-directory-p . tramp-handle-file-directory-p)
(file-equal-p . tramp-handle-file-equal-p)
(file-executable-p . tramp-gvfs-handle-file-executable-p)
(file-exists-p . tramp-handle-file-exists-p)
(file-in-directory-p . tramp-handle-file-in-directory-p)
- (file-local-copy . tramp-gvfs-handle-file-local-copy)
+ (file-local-copy . tramp-handle-file-local-copy)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions . tramp-gvfs-handle-file-name-all-completions)
(file-name-as-directory . tramp-handle-file-name-as-directory)
@@ -518,9 +568,8 @@ Every entry is a list (NAME ADDRESS).")
(file-symlink-p . tramp-handle-file-symlink-p)
(file-system-info . tramp-gvfs-handle-file-system-info)
(file-truename . tramp-handle-file-truename)
- (file-writable-p . tramp-gvfs-handle-file-writable-p)
+ (file-writable-p . tramp-handle-file-writable-p)
(find-backup-file-name . tramp-handle-find-backup-file-name)
- ;; `find-file-noselect' performed by default handler.
;; `get-file-buffer' performed by default handler.
(insert-directory . tramp-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
@@ -529,6 +578,7 @@ Every entry is a list (NAME ADDRESS).")
(make-directory . tramp-gvfs-handle-make-directory)
(make-directory-internal . ignore)
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
+ (make-process . ignore)
(make-symbolic-link . tramp-handle-make-symbolic-link)
(process-file . ignore)
(rename-file . tramp-gvfs-handle-rename-file)
@@ -541,10 +591,11 @@ Every entry is a list (NAME ADDRESS).")
(start-file-process . ignore)
(substitute-in-file-name . tramp-handle-substitute-in-file-name)
(temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-set-file-uid-gid . ignore)
(unhandled-file-name-directory . ignore)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
- (write-region . tramp-gvfs-handle-write-region))
+ (write-region . tramp-handle-write-region))
"Alist of handler functions for Tramp GVFS method.
Operations not mentioned here will be handled by the default Emacs primitives.")
@@ -564,7 +615,7 @@ Operations not mentioned here will be handled by the default Emacs primitives.")
First arg specifies the OPERATION, second arg is a list of arguments to
pass to the OPERATION."
(unless tramp-gvfs-enabled
- (tramp-compat-user-error nil "Package `tramp-gvfs' not supported"))
+ (tramp-user-error nil "Package `tramp-gvfs' not supported"))
(let ((fn (assoc operation tramp-gvfs-file-name-handler-alist)))
(if fn
(save-match-data (apply (cdr fn) args))
@@ -572,8 +623,9 @@ pass to the OPERATION."
;;;###tramp-autoload
(when (featurep 'dbusbind)
- (tramp-register-foreign-file-name-handler
- 'tramp-gvfs-file-name-p 'tramp-gvfs-file-name-handler))
+ (tramp--with-startup
+ (tramp-register-foreign-file-name-handler
+ #'tramp-gvfs-file-name-p #'tramp-gvfs-file-name-handler)))
;; D-Bus helper function.
@@ -601,12 +653,24 @@ Return nil for null BYTE-ARRAY."
(cond
((and (consp message) (characterp (car message)))
(format "%S" (tramp-gvfs-dbus-byte-array-to-string message)))
+ ((and (consp message) (atom (cdr message)))
+ (cons (tramp-gvfs-stringify-dbus-message (car message))
+ (tramp-gvfs-stringify-dbus-message (cdr message))))
((consp message)
- (mapcar 'tramp-gvfs-stringify-dbus-message message))
+ (mapcar #'tramp-gvfs-stringify-dbus-message message))
((stringp message)
(format "%S" message))
(t message)))
+(defun tramp-dbus-function (vec func args)
+ "Apply a D-Bus function FUNC from dbus.el.
+The call will be traced by Tramp with trace level 6."
+ (let (result)
+ (tramp-message vec 6 "%s" (cons func args))
+ (setq result (apply func args))
+ (tramp-message vec 6 "%s" result(tramp-gvfs-stringify-dbus-message result))
+ result))
+
(defmacro with-tramp-dbus-call-method
(vec synchronous bus service path interface method &rest args)
"Apply a D-Bus call on bus BUS.
@@ -615,22 +679,34 @@ If SYNCHRONOUS is non-nil, the call is synchronously. Otherwise,
it is an asynchronous call, with `ignore' as callback function.
The other arguments have the same meaning as with `dbus-call-method'
-or `dbus-call-method-asynchronously'. Additionally, the call
-will be traced by Tramp with trace level 6."
+or `dbus-call-method-asynchronously'."
`(let ((func (if ,synchronous
- 'dbus-call-method 'dbus-call-method-asynchronously))
+ #'dbus-call-method #'dbus-call-method-asynchronously))
(args (append (list ,bus ,service ,path ,interface ,method)
- (if ,synchronous (list ,@args) (list 'ignore ,@args))))
- result)
- (tramp-message ,vec 6 "%s %s" func args)
- (setq result (apply func args))
- (tramp-message ,vec 6 "%s" (tramp-gvfs-stringify-dbus-message result))
- result))
+ (if ,synchronous (list ,@args) (list 'ignore ,@args)))))
+ (tramp-dbus-function ,vec func args)))
(put 'with-tramp-dbus-call-method 'lisp-indent-function 2)
(put 'with-tramp-dbus-call-method 'edebug-form-spec '(form symbolp body))
(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>"))
+(defmacro with-tramp-dbus-get-all-properties
+ (vec bus service path interface)
+ "Return all properties of INTERFACE.
+The call will be traced by Tramp with trace level 6."
+ ;; Check, that interface exists at object path. Retrieve properties.
+ `(when (member
+ ,interface
+ (tramp-dbus-function
+ ,vec #'dbus-introspect-get-interface-names
+ (list ,bus ,service ,path)))
+ (tramp-dbus-function
+ ,vec #'dbus-get-all-properties (list ,bus ,service ,path ,interface))))
+
+(put 'with-tramp-dbus-get-all-properties 'lisp-indent-function 1)
+(put 'with-tramp-dbus-get-all-properties 'edebug-form-spec '(form symbolp body))
+(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-get-all-properties\\>"))
+
(defvar tramp-gvfs-dbus-event-vector nil
"Current Tramp file name to be used, as vector.
It is needed when D-Bus signals or errors arrive, because there
@@ -639,7 +715,7 @@ is no information where to trace the message.")
(defun tramp-gvfs-dbus-event-error (event err)
"Called when a D-Bus error message arrives, see `dbus-event-error-functions'."
(when tramp-gvfs-dbus-event-vector
- (tramp-message tramp-gvfs-dbus-event-vector 10 "%S" event)
+ (tramp-message tramp-gvfs-dbus-event-vector 6 "%S" event)
(tramp-error tramp-gvfs-dbus-event-vector 'file-error "%s" (cadr err))))
;; `dbus-event-error-hooks' has been renamed to
@@ -647,7 +723,7 @@ is no information where to trace the message.")
(add-hook
(if (boundp 'dbus-event-error-functions)
'dbus-event-error-functions 'dbus-event-error-hooks)
- 'tramp-gvfs-dbus-event-error)
+ #'tramp-gvfs-dbus-event-error)
;; File name primitives.
@@ -672,6 +748,7 @@ file names."
(unless (memq op '(copy rename))
(error "Unknown operation `%s', must be `copy' or `rename'" op))
+ (setq filename (file-truename filename))
(if (file-directory-p filename)
(progn
(copy-directory filename newname keep-date t)
@@ -706,7 +783,7 @@ file names."
v 0 (format "%s %s to %s" msg-operation filename newname)
(unless
(apply
- 'tramp-gvfs-send-command v gvfs-operation
+ #'tramp-gvfs-send-command v gvfs-operation
(append
(and (eq op 'copy) (or keep-date preserve-uid-gid)
'("--preserve"))
@@ -735,13 +812,13 @@ file names."
(when (and t1 (eq op 'rename))
(with-parsed-tramp-file-name filename nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)))
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)))
(when t2
(with-parsed-tramp-file-name newname nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname))))))))
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname))))))))
(defun tramp-gvfs-handle-copy-file
(filename newname &optional ok-if-already-exists keep-date
@@ -775,8 +852,8 @@ file names."
(tramp-error
v 'file-error "Couldn't delete non-empty %s" directory)))
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-directory-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-directory-properties v localname)
(unless
(tramp-gvfs-send-command
v (if (and trash delete-by-moving-to-trash) "gvfs-trash" "gvfs-rm")
@@ -790,8 +867,8 @@ file names."
(defun tramp-gvfs-handle-delete-file (filename &optional trash)
"Like `delete-file' for Tramp files."
(with-parsed-tramp-file-name filename nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
(unless
(tramp-gvfs-send-command
v (if (and trash delete-by-moving-to-trash) "gvfs-trash" "gvfs-rm")
@@ -806,12 +883,14 @@ file names."
"Like `expand-file-name' for Tramp files."
;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
(setq dir (or dir default-directory "/"))
+ ;; Handle empty NAME.
+ (when (zerop (length name)) (setq name "."))
;; Unless NAME is absolute, concat DIR and NAME.
(unless (file-name-absolute-p name)
(setq name (concat (file-name-as-directory dir) name)))
;; If NAME is not a Tramp file, run the real handler.
(if (not (tramp-tramp-file-p name))
- (tramp-run-real-handler 'expand-file-name (list name nil))
+ (tramp-run-real-handler #'expand-file-name (list name nil))
;; Dissect NAME.
(with-parsed-tramp-file-name name nil
;; If there is a default location, expand tilde.
@@ -826,14 +905,14 @@ file names."
(tramp-get-connection-property v "default-location" "~")
nil t localname 1)))
;; Tilde expansion is not possible.
- (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)
+ (when (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)
(tramp-error
v 'file-error
"Cannot expand tilde in file `%s'" name))
- (unless (tramp-run-real-handler 'file-name-absolute-p (list localname))
+ (unless (tramp-run-real-handler #'file-name-absolute-p (list localname))
(setq localname (concat "/" localname)))
;; We do not pass "/..".
- (if (string-match "^\\(afp\\|davs?\\|smb\\)$" method)
+ (if (string-match-p "^\\(afp\\|davs?\\|smb\\)$" method)
(when (string-match "^/[^/]+\\(/\\.\\./?\\)" localname)
(setq localname (replace-match "/" t t localname 1)))
(when (string-match "^/\\.\\./?" localname)
@@ -844,8 +923,7 @@ file names."
;; No tilde characters in file name, do normal
;; `expand-file-name' (this does "/./" and "/../").
(tramp-make-tramp-file-name
- method user domain host port
- (tramp-run-real-handler 'expand-file-name (list localname))))))
+ v (tramp-run-real-handler #'expand-file-name (list localname))))))
(defun tramp-gvfs-get-directory-attributes (directory)
"Return GVFS attributes association list of all files in DIRECTORY."
@@ -859,7 +937,7 @@ file names."
;; Send command.
(tramp-gvfs-send-command
v "gvfs-ls" "-h" "-n" "-a"
- (mapconcat 'identity tramp-gvfs-file-attributes ",")
+ (mapconcat #'identity tramp-gvfs-file-attributes ",")
(tramp-gvfs-url-file-name directory))
;; Parse output.
(with-current-buffer (tramp-get-connection-buffer v)
@@ -925,8 +1003,8 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(setq filename (directory-file-name (expand-file-name filename)))
(with-parsed-tramp-file-name filename nil
(setq localname (tramp-compat-file-name-unquote localname))
- (if (or (and (string-match "^\\(afp\\|davs?\\|smb\\)$" method)
- (string-match "^/?\\([^/]+\\)$" localname))
+ (if (or (and (string-match-p "^\\(afp\\|davs?\\|smb\\)$" method)
+ (string-match-p "^/?\\([^/]+\\)$" localname))
(string-equal localname "/"))
(tramp-gvfs-get-root-attributes filename)
(assoc
@@ -945,6 +1023,18 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(setq dirp (if (equal "directory" (cdr (assoc "type" attributes))) t))
(setq res-symlink-target
(cdr (assoc "standard::symlink-target" attributes)))
+ (when (stringp res-symlink-target)
+ (setq res-symlink-target
+ ;; Parse unibyte codes "\xNN". We assume they are
+ ;; non-ASCII codepoints in the range #x80 through #xff.
+ ;; Convert them to multibyte.
+ (decode-coding-string
+ (replace-regexp-in-string
+ "\\\\x\\([[:xdigit:]]\\{2\\}\\)"
+ (lambda (x)
+ (unibyte-string (string-to-number (match-string 1 x) 16)))
+ res-symlink-target)
+ 'utf-8)))
;; ... number links
(setq res-numlinks
(string-to-number
@@ -954,7 +1044,8 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(if (eq id-format 'integer)
(string-to-number
(or (cdr (assoc "unix::uid" attributes))
- (format "%s" tramp-unknown-id-integer)))
+ (eval-when-compile
+ (format "%s" tramp-unknown-id-integer))))
(or (cdr (assoc "owner::user" attributes))
(cdr (assoc "unix::uid" attributes))
tramp-unknown-id-string)))
@@ -962,7 +1053,8 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(if (eq id-format 'integer)
(string-to-number
(or (cdr (assoc "unix::gid" attributes))
- (format "%s" tramp-unknown-id-integer)))
+ (eval-when-compile
+ (format "%s" tramp-unknown-id-integer))))
(or (cdr (assoc "owner::group" attributes))
(cdr (assoc "unix::gid" attributes))
tramp-unknown-id-string)))
@@ -1040,31 +1132,16 @@ If FILE-SYSTEM is non-nil, return file system attributes."
res-device
)))))
-(defun tramp-gvfs-handle-file-directory-p (filename)
- "Like `file-directory-p' for Tramp files."
- (eq t (tramp-compat-file-attribute-type
- (file-attributes (file-truename filename)))))
-
(defun tramp-gvfs-handle-file-executable-p (filename)
"Like `file-executable-p' for Tramp files."
(with-parsed-tramp-file-name filename nil
(with-tramp-file-property v localname "file-executable-p"
- (tramp-check-cached-permissions v ?x))))
-
-(defun tramp-gvfs-handle-file-local-copy (filename)
- "Like `file-local-copy' for Tramp files."
- (with-parsed-tramp-file-name filename nil
- (unless (file-exists-p filename)
- (tramp-error
- v tramp-file-missing
- "Cannot make local copy of non-existing file `%s'" filename))
- (let ((tmpfile (tramp-compat-make-temp-file filename)))
- (copy-file filename tmpfile 'ok-if-already-exists 'keep-time)
- tmpfile)))
+ (and (file-exists-p filename)
+ (tramp-check-cached-permissions v ?x)))))
(defun tramp-gvfs-handle-file-name-all-completions (filename directory)
"Like `file-name-all-completions' for Tramp files."
- (unless (save-match-data (string-match "/" filename))
+ (unless (string-match-p "/" filename)
(all-completions
filename
(with-parsed-tramp-file-name (expand-file-name directory) nil
@@ -1080,9 +1157,10 @@ If FILE-SYSTEM is non-nil, return file system attributes."
"Like `file-notify-add-watch' for Tramp files."
(setq file-name (expand-file-name file-name))
(with-parsed-tramp-file-name file-name nil
- ;; We cannot watch directories, because `gvfs-monitor-dir' is not
- ;; supported for gvfs-mounted directories.
- (when (file-directory-p file-name)
+ ;; TODO: We cannot watch directories, because `gio monitor' is not
+ ;; supported for gvfs-mounted directories. However,
+ ;; `file-notify-add-watch' uses directories.
+ (when (or (not (tramp-gvfs-gio-tool-p v)) (file-directory-p file-name))
(tramp-error
v 'file-notify-error "Monitoring not supported for `%s'" file-name))
(let* ((default-directory (file-name-directory file-name))
@@ -1095,69 +1173,82 @@ If FILE-SYSTEM is non-nil, return file system attributes."
'(created changed changes-done-hint moved deleted))
((memq 'attribute-change flags) '(attribute-changed))))
(p (apply
- 'start-process
+ #'start-process
"gvfs-monitor" (generate-new-buffer " *gvfs-monitor*")
- (if (tramp-gvfs-gio-tool-p v)
- `("gio" "monitor" ,(tramp-gvfs-url-file-name file-name)))
- `("gvfs-monitor-file" (tramp-gvfs-url-file-name file-name)))))
+ `("gio" "monitor" ,(tramp-gvfs-url-file-name file-name)))))
(if (not (processp p))
(tramp-error
v 'file-notify-error "Monitoring not supported for `%s'" file-name)
(tramp-message
- v 6 "Run `%s', %S" (mapconcat 'identity (process-command p) " ") p)
- (tramp-set-connection-property p "vector" v)
+ v 6 "Run `%s', %S" (mapconcat #'identity (process-command p) " ") p)
+ (process-put p 'vector v)
(process-put p 'events events)
(process-put p 'watch-name localname)
- (process-put p 'adjust-window-size-function 'ignore)
+ (process-put p 'adjust-window-size-function #'ignore)
(set-process-query-on-exit-flag p nil)
- (set-process-filter p 'tramp-gvfs-monitor-file-process-filter)
+ (set-process-filter p #'tramp-gvfs-monitor-process-filter)
;; There might be an error if the monitor is not supported.
;; Give the filter a chance to read the output.
- (tramp-accept-process-output p 1)
+ (while (tramp-accept-process-output p 0))
(unless (process-live-p p)
(tramp-error
- v 'file-notify-error "Monitoring not supported for `%s'" file-name))
+ p 'file-notify-error "Monitoring not supported for `%s'" file-name))
p))))
-(defun tramp-gvfs-monitor-file-process-filter (proc string)
+(defun tramp-gvfs-monitor-process-filter (proc string)
"Read output from \"gvfs-monitor-file\" and add corresponding \
file-notify events."
- (let* ((rest-string (process-get proc 'rest-string))
+ (let* ((events (process-get proc 'events))
+ (rest-string (process-get proc 'rest-string))
(dd (with-current-buffer (process-buffer proc) default-directory))
(ddu (regexp-quote (tramp-gvfs-url-file-name dd))))
(when rest-string
(tramp-message proc 10 "Previous string:\n%s" rest-string))
(tramp-message proc 6 "%S\n%s" proc string)
(setq string (concat rest-string string)
- ;; Attribute change is returned in unused wording.
- string (replace-regexp-in-string
- "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string))
- (when (string-match "Monitoring not supported" string)
+ ;; Fix action names.
+ string (replace-regexp-in-string
+ "attributes changed" "attribute-changed" string)
+ string (replace-regexp-in-string
+ "changes done" "changes-done-hint" string)
+ string (replace-regexp-in-string
+ "renamed to" "moved" string))
+ ;; https://bugs.launchpad.net/bugs/1742946
+ (when
+ (string-match-p "Monitoring not supported\\|No locations given" string)
(delete-process proc))
(while (string-match
- (concat "^[\n\r]*"
- "File Monitor Event:[\n\r]+"
- "File = \\([^\n\r]+\\)[\n\r]+"
- "Event = \\([^[:blank:]]+\\)[\n\r]+")
+ (eval-when-compile
+ (concat "^.+:"
+ "[[:space:]]\\(.+\\):"
+ "[[:space:]]" (regexp-opt tramp-gio-events t)
+ "\\([[:space:]]\\(.+\\)\\)?$"))
string)
+
(let ((file (match-string 1 string))
- (action (intern-soft
- (replace-regexp-in-string
- "_" "-" (downcase (match-string 2 string))))))
+ (file1 (match-string 4 string))
+ (action (intern-soft (match-string 2 string))))
(setq string (replace-match "" nil nil string))
;; File names are returned as URL paths. We must convert them.
(when (string-match ddu file)
(setq file (replace-match dd nil nil file)))
- (while (string-match "%\\([0-9A-F]\\{2\\}\\)" file)
- (setq file
- (replace-match
- (char-to-string (string-to-number (match-string 1 file) 16))
- nil nil file)))
+ (while (string-match-p "%\\([0-9A-F]\\{2\\}\\)" file)
+ (setq file (url-unhex-string file)))
+ (when (string-match ddu (or file1 ""))
+ (setq file1 (replace-match dd nil nil file1)))
+ (while (string-match-p "%\\([0-9A-F]\\{2\\}\\)" (or file1 ""))
+ (setq file1 (url-unhex-string file1)))
+ ;; Remove watch when file or directory to be watched is deleted.
+ (when (and (member action '(moved deleted))
+ (string-equal file (process-get proc 'watch-name)))
+ (delete-process proc))
;; Usually, we would add an Emacs event now. Unfortunately,
;; `unread-command-events' does not accept several events at
;; once. Therefore, we apply the callback directly.
- (tramp-compat-funcall 'file-notify-callback (list proc action file))))
+ (when (member action events)
+ (tramp-compat-funcall
+ 'file-notify-callback (list proc action file file1)))))
;; Save rest of the string.
(when (zerop (length string)) (setq string nil))
@@ -1168,40 +1259,42 @@ file-notify events."
"Like `file-readable-p' for Tramp files."
(with-parsed-tramp-file-name filename nil
(with-tramp-file-property v localname "file-readable-p"
- (tramp-check-cached-permissions v ?r))))
+ (and (file-exists-p filename)
+ (or (tramp-check-cached-permissions v ?r)
+ ;; If the user is different from what we guess to be
+ ;; the user, we don't know. Let's check, whether
+ ;; access is restricted explicitly.
+ (and (/= (tramp-gvfs-get-remote-uid v 'integer)
+ (tramp-compat-file-attribute-user-id
+ (file-attributes filename 'integer)))
+ (not
+ (string-equal
+ "FALSE"
+ (cdr (assoc
+ "access::can-read"
+ (tramp-gvfs-get-file-attributes filename)))))))))))
(defun tramp-gvfs-handle-file-system-info (filename)
"Like `file-system-info' for Tramp files."
(setq filename (directory-file-name (expand-file-name filename)))
(with-parsed-tramp-file-name filename nil
;; We don't use cached values.
- (tramp-set-file-property v localname "file-system-attributes" 'undef)
+ (tramp-flush-file-property v localname "file-system-attributes")
(let* ((attr (tramp-gvfs-get-root-attributes filename 'file-system))
(size (cdr (assoc "filesystem::size" attr)))
(used (cdr (assoc "filesystem::used" attr)))
(free (cdr (assoc "filesystem::free" attr))))
(when (and (stringp size) (stringp used) (stringp free))
- (list (string-to-number (concat size "e0"))
- (- (string-to-number (concat size "e0"))
- (string-to-number (concat used "e0")))
- (string-to-number (concat free "e0")))))))
-
-(defun tramp-gvfs-handle-file-writable-p (filename)
- "Like `file-writable-p' for Tramp files."
- (with-parsed-tramp-file-name filename nil
- (with-tramp-file-property v localname "file-writable-p"
- (if (file-exists-p filename)
- (tramp-check-cached-permissions v ?w)
- ;; If file doesn't exist, check if directory is writable.
- (and (file-directory-p (file-name-directory filename))
- (file-writable-p (file-name-directory filename)))))))
+ (list (string-to-number size)
+ (- (string-to-number size) (string-to-number used))
+ (string-to-number free))))))
(defun tramp-gvfs-handle-make-directory (dir &optional parents)
"Like `make-directory' for Tramp files."
(setq dir (directory-file-name (expand-file-name dir)))
(with-parsed-tramp-file-name dir nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-directory-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-directory-properties v localname)
(save-match-data
(let ((ldir (file-name-directory dir)))
;; Make missing directory parts. "gvfs-mkdir -p ..." does not
@@ -1228,56 +1321,14 @@ file-notify events."
'rename filename newname ok-if-already-exists
'keep-date 'preserve-uid-gid)
(tramp-run-real-handler
- 'rename-file (list filename newname ok-if-already-exists))))
-
-(defun tramp-gvfs-handle-write-region
- (start end filename &optional append visit lockname mustbenew)
- "Like `write-region' for Tramp files."
- (setq filename (expand-file-name filename))
- (with-parsed-tramp-file-name filename nil
- (when (and mustbenew (file-exists-p filename)
- (or (eq mustbenew 'excl)
- (not
- (y-or-n-p
- (format "File %s exists; overwrite anyway? " filename)))))
- (tramp-error v 'file-already-exists filename))
-
- (let ((tmpfile (tramp-compat-make-temp-file filename)))
- (when (and append (file-exists-p filename))
- (copy-file filename tmpfile 'ok))
- ;; We say `no-message' here because we don't want the visited file
- ;; modtime data to be clobbered from the temp file. We call
- ;; `set-visited-file-modtime' ourselves later on.
- (tramp-run-real-handler
- 'write-region (list start end tmpfile append 'no-message lockname))
- (condition-case nil
- (rename-file tmpfile filename 'ok-if-already-exists)
- (error
- (delete-file tmpfile)
- (tramp-error
- v 'file-error "Couldn't write region to `%s'" filename))))
-
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
-
- ;; Set file modification time.
- (when (or (eq visit t) (stringp visit))
- (set-visited-file-modtime
- (tramp-compat-file-attribute-modification-time
- (file-attributes filename))))
-
- ;; The end.
- (when (and (null noninteractive)
- (or (eq visit t) (null visit) (stringp visit)))
- (tramp-message v 0 "Wrote %s" filename))
- (run-hooks 'tramp-handle-write-region-hook)))
+ #'rename-file (list filename newname ok-if-already-exists))))
;; File name conversions.
(defun tramp-gvfs-url-file-name (filename)
"Return FILENAME in URL syntax."
- ;; "/" must NOT be hexlified.
+ ;; "/" must NOT be hexified.
(setq filename (tramp-compat-file-name-unquote filename))
(let ((url-unreserved-chars (cons ?/ url-unreserved-chars))
result)
@@ -1288,6 +1339,10 @@ file-notify events."
(with-parsed-tramp-file-name filename nil
(when (string-equal "gdrive" method)
(setq method "google-drive"))
+ (when (string-equal "nextcloud" method)
+ (setq method "davs"
+ localname
+ (concat (tramp-gvfs-get-remote-prefix v) localname)))
(when (and user domain)
(setq user (concat domain ";" user)))
(url-parse-make-urlobj
@@ -1312,24 +1367,6 @@ file-notify events."
(dbus-unescape-from-identifier
(replace-regexp-in-string "^.*/\\([^/]+\\)$" "\\1" object-path)))
-(defun tramp-bluez-address (device)
- "Return bluetooth device address from a given bluetooth DEVICE name."
- (when (stringp device)
- (if (string-match tramp-ipv6-regexp device)
- (match-string 0 device)
- (cadr (assoc device (tramp-bluez-list-devices))))))
-
-(defun tramp-bluez-device (address)
- "Return bluetooth device name from a given bluetooth device ADDRESS.
-ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
- (when (stringp address)
- (while (string-match "[][]" address)
- (setq address (replace-match "" t t address)))
- (let (result)
- (dolist (item (tramp-bluez-list-devices) result)
- (when (string-match address (cadr item))
- (setq result (car item)))))))
-
;; D-Bus GVFS functions.
@@ -1361,13 +1398,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
(unless (tramp-get-connection-property l "first-password-request" nil)
(tramp-clear-passwd l))
- ;; Set variables for computing the prompt for reading password.
- (setq tramp-current-method l-method
- tramp-current-user user
- tramp-current-domain l-domain
- tramp-current-host l-host
- tramp-current-port l-port
- password (tramp-read-passwd
+ (setq password (tramp-read-passwd
(tramp-get-connection-process l) pw-prompt))
;; Return result.
@@ -1406,7 +1437,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
(tramp-get-connection-process v) message
;; In theory, there can be several choices.
;; Until now, there is only the question whether
- ;; to accept an unknown host signature.
+ ;; to accept an unknown host signature or certificate.
(with-temp-buffer
;; Preserve message for `progress-reporter'.
(with-temp-message ""
@@ -1447,6 +1478,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
(while (stringp (car elt)) (setq elt (cdr elt)))
(let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string (cadr elt)))
(mount-spec (cl-caddr elt))
+ (prefix (tramp-gvfs-dbus-byte-array-to-string (car mount-spec)))
(default-location (tramp-gvfs-dbus-byte-array-to-string
(cl-cadddr elt)))
(method (tramp-gvfs-dbus-byte-array-to-string
@@ -1462,53 +1494,56 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
(cadr (assoc "port" (cadr mount-spec)))))
(ssl (tramp-gvfs-dbus-byte-array-to-string
(cadr (assoc "ssl" (cadr mount-spec)))))
- (prefix (concat
- (tramp-gvfs-dbus-byte-array-to-string
- (car mount-spec))
- (tramp-gvfs-dbus-byte-array-to-string
- (or (cadr (assoc "share" (cadr mount-spec)))
- (cadr (assoc "volume" (cadr mount-spec))))))))
+ (uri (tramp-gvfs-dbus-byte-array-to-string
+ (cadr (assoc "uri" (cadr mount-spec))))))
(when (string-match "^\\(afp\\|smb\\)" method)
(setq method (match-string 1 method)))
- (when (string-equal "obex" method)
- (setq host (tramp-bluez-device host)))
(when (and (string-equal "dav" method) (string-equal "true" ssl))
(setq method "davs"))
+ (when (and (string-equal "davs" method)
+ (string-match-p
+ tramp-gvfs-nextcloud-default-prefix-regexp prefix))
+ (setq method "nextcloud"))
(when (string-equal "google-drive" method)
(setq method "gdrive"))
- (with-parsed-tramp-file-name
- (tramp-make-tramp-file-name method user domain host port "") nil
- (tramp-message
- v 6 "%s %s"
- signal-name (tramp-gvfs-stringify-dbus-message mount-info))
- (tramp-set-file-property v "/" "list-mounts" 'undef)
- (if (string-equal (downcase signal-name) "unmounted")
- (tramp-flush-file-property v "/")
- ;; Set prefix, mountpoint and location.
- (unless (string-equal prefix "/")
- (tramp-set-file-property v "/" "prefix" prefix))
- (tramp-set-file-property v "/" "fuse-mountpoint" fuse-mountpoint)
- (tramp-set-connection-property
- v "default-location" default-location)))))))
+ (when (and (string-equal "http" method) (stringp uri))
+ (setq uri (url-generic-parse-url uri)
+ method (url-type uri)
+ user (url-user uri)
+ host (url-host uri)
+ port (url-portspec uri)))
+ (when (member method tramp-gvfs-methods)
+ (with-parsed-tramp-file-name
+ (tramp-make-tramp-file-name method user domain host port "") nil
+ (tramp-message
+ v 6 "%s %s"
+ signal-name (tramp-gvfs-stringify-dbus-message mount-info))
+ (tramp-flush-file-property v "/" "list-mounts")
+ (if (string-equal (downcase signal-name) "unmounted")
+ (tramp-flush-file-properties v "/")
+ ;; Set mountpoint and location.
+ (tramp-set-file-property v "/" "fuse-mountpoint" fuse-mountpoint)
+ (tramp-set-connection-property
+ v "default-location" default-location))))))))
(when tramp-gvfs-enabled
(dbus-register-signal
:session nil tramp-gvfs-path-mounttracker
tramp-gvfs-interface-mounttracker "mounted"
- 'tramp-gvfs-handler-mounted-unmounted)
+ #'tramp-gvfs-handler-mounted-unmounted)
(dbus-register-signal
:session nil tramp-gvfs-path-mounttracker
tramp-gvfs-interface-mounttracker "Mounted"
- 'tramp-gvfs-handler-mounted-unmounted)
+ #'tramp-gvfs-handler-mounted-unmounted)
(dbus-register-signal
:session nil tramp-gvfs-path-mounttracker
tramp-gvfs-interface-mounttracker "unmounted"
- 'tramp-gvfs-handler-mounted-unmounted)
+ #'tramp-gvfs-handler-mounted-unmounted)
(dbus-register-signal
:session nil tramp-gvfs-path-mounttracker
tramp-gvfs-interface-mounttracker "Unmounted"
- 'tramp-gvfs-handler-mounted-unmounted))
+ #'tramp-gvfs-handler-mounted-unmounted))
(defun tramp-gvfs-connection-mounted-p (vec)
"Check, whether the location is already mounted."
@@ -1529,6 +1564,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
(let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string
(cadr elt)))
(mount-spec (cl-caddr elt))
+ (prefix (tramp-gvfs-dbus-byte-array-to-string (car mount-spec)))
(default-location (tramp-gvfs-dbus-byte-array-to-string
(cl-cadddr elt)))
(method (tramp-gvfs-dbus-byte-array-to-string
@@ -1544,43 +1580,59 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
(cadr (assoc "port" (cadr mount-spec)))))
(ssl (tramp-gvfs-dbus-byte-array-to-string
(cadr (assoc "ssl" (cadr mount-spec)))))
- (prefix (concat
- (tramp-gvfs-dbus-byte-array-to-string
- (car mount-spec))
- (tramp-gvfs-dbus-byte-array-to-string
- (or
- (cadr (assoc "share" (cadr mount-spec)))
- (cadr (assoc "volume" (cadr mount-spec))))))))
+ (uri (tramp-gvfs-dbus-byte-array-to-string
+ (cadr (assoc "uri" (cadr mount-spec)))))
+ (share (tramp-gvfs-dbus-byte-array-to-string
+ (or
+ (cadr (assoc "share" (cadr mount-spec)))
+ (cadr (assoc "volume" (cadr mount-spec)))))))
(when (string-match "^\\(afp\\|smb\\)" method)
(setq method (match-string 1 method)))
- (when (string-equal "obex" method)
- (setq host (tramp-bluez-device host)))
(when (and (string-equal "dav" method) (string-equal "true" ssl))
(setq method "davs"))
+ (when (and (string-equal "davs" method)
+ (string-match-p
+ tramp-gvfs-nextcloud-default-prefix-regexp prefix))
+ (setq method "nextcloud"))
(when (string-equal "google-drive" method)
(setq method "gdrive"))
- (when (and (string-equal "synce" method) (zerop (length user)))
- (setq user (or (tramp-file-name-user vec) "")))
+ (when (and (string-equal "http" method) (stringp uri))
+ (setq uri (url-generic-parse-url uri)
+ method (url-type uri)
+ user (url-user uri)
+ host (url-host uri)
+ port (url-portspec uri)))
(when (and
(string-equal method (tramp-file-name-method vec))
(string-equal user (tramp-file-name-user vec))
(string-equal domain (tramp-file-name-domain vec))
(string-equal host (tramp-file-name-host vec))
(string-equal port (tramp-file-name-port vec))
- (string-match (concat "^" (regexp-quote prefix))
- (tramp-file-name-unquote-localname vec)))
- ;; Set prefix, mountpoint and location.
- (unless (string-equal prefix "/")
- (tramp-set-file-property vec "/" "prefix" prefix))
+ (string-match-p (concat "^/" (regexp-quote (or share "")))
+ (tramp-file-name-unquote-localname vec)))
+ ;; Set mountpoint and location.
(tramp-set-file-property vec "/" "fuse-mountpoint" fuse-mountpoint)
(tramp-set-connection-property
vec "default-location" default-location)
(throw 'mounted t)))))))
+(defun tramp-gvfs-unmount (vec)
+ "Unmount the object identified by VEC."
+ (setf (tramp-file-name-localname vec) "/"
+ (tramp-file-name-hop vec) nil)
+ (when (tramp-gvfs-connection-mounted-p vec)
+ (tramp-gvfs-send-command
+ vec "gvfs-mount" "-u"
+ (tramp-gvfs-url-file-name (tramp-make-tramp-file-name vec))))
+ (while (tramp-gvfs-connection-mounted-p vec)
+ (read-event nil nil 0.1))
+ (tramp-flush-connection-properties vec)
+ (tramp-flush-connection-properties (tramp-get-connection-process vec)))
+
(defun tramp-gvfs-mount-spec-entry (key value)
"Construct a mount-spec entry to be used in a mount_spec.
It was \"a(say)\", but has changed to \"a{sv})\"."
- (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature)
+ (if (string-match-p "^(aya{sv})" tramp-gvfs-mountlocation-signature)
(list :dict-entry key
(list :variant (tramp-gvfs-dbus-string-to-byte-array value)))
(list :struct key (tramp-gvfs-dbus-string-to-byte-array value))))
@@ -1595,7 +1647,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"."
(localname (tramp-file-name-unquote-localname vec))
(share (when (string-match "^/?\\([^/]+\\)" localname)
(match-string 1 localname)))
- (ssl (if (string-match "^davs" method) "true" "false"))
+ (ssl (if (string-match-p "^davs\\|^nextcloud" method) "true" "false"))
(mount-spec
`(:array
,@(cond
@@ -1603,11 +1655,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"."
(list (tramp-gvfs-mount-spec-entry "type" "smb-share")
(tramp-gvfs-mount-spec-entry "server" host)
(tramp-gvfs-mount-spec-entry "share" share)))
- ((string-equal "obex" method)
- (list (tramp-gvfs-mount-spec-entry "type" method)
- (tramp-gvfs-mount-spec-entry
- "host" (concat "[" (tramp-bluez-address host) "]"))))
- ((string-match "\\`dav" method)
+ ((string-match-p "^dav\\|^nextcloud" method)
(list (tramp-gvfs-mount-spec-entry "type" "dav")
(tramp-gvfs-mount-spec-entry "host" host)
(tramp-gvfs-mount-spec-entry "ssl" ssl)))
@@ -1618,7 +1666,17 @@ It was \"a(say)\", but has changed to \"a{sv})\"."
((string-equal "gdrive" method)
(list (tramp-gvfs-mount-spec-entry "type" "google-drive")
(tramp-gvfs-mount-spec-entry "host" host)))
- (t
+ ((string-equal "nextcloud" method)
+ (list (tramp-gvfs-mount-spec-entry "type" "owncloud")
+ (tramp-gvfs-mount-spec-entry "host" host)))
+ ((string-match-p "^http" method)
+ (list (tramp-gvfs-mount-spec-entry "type" "http")
+ (tramp-gvfs-mount-spec-entry
+ "uri"
+ (url-recreate-url
+ (url-parse-make-urlobj
+ method user nil host port "/" nil nil t)))))
+ (t
(list (tramp-gvfs-mount-spec-entry "type" method)
(tramp-gvfs-mount-spec-entry "host" host))))
,@(when user
@@ -1628,10 +1686,10 @@ It was \"a(say)\", but has changed to \"a{sv})\"."
,@(when port
(list (tramp-gvfs-mount-spec-entry "port" port)))))
(mount-pref
- (if (and (string-match "\\`dav" method)
+ (if (and (string-match-p "^dav" method)
(string-match "^/?[^/]+" localname))
(match-string 0 localname)
- "/")))
+ (tramp-gvfs-get-remote-prefix vec))))
;; Return.
`(:struct ,(tramp-gvfs-dbus-string-to-byte-array mount-pref) ,mount-spec)))
@@ -1643,20 +1701,15 @@ It was \"a(say)\", but has changed to \"a{sv})\"."
"The uid of the remote connection VEC, in ID-FORMAT.
ID-FORMAT valid values are `string' and `integer'."
(with-tramp-connection-property vec (format "uid-%s" id-format)
- (let ((method (tramp-file-name-method vec))
- (user (tramp-file-name-user vec))
- (domain (tramp-file-name-domain vec))
- (host (tramp-file-name-host vec))
- (port (tramp-file-name-port vec))
+ (let ((user (tramp-file-name-user vec))
(localname
(tramp-get-connection-property vec "default-location" nil)))
(cond
- ((and user (equal id-format 'string)) user)
+ ((and (equal id-format 'string) user))
(localname
(tramp-compat-file-attribute-user-id
(file-attributes
- (tramp-make-tramp-file-name method user domain host port localname)
- id-format)))
+ (tramp-make-tramp-file-name vec localname) id-format)))
((equal id-format 'integer) tramp-unknown-id-integer)
((equal id-format 'string) tramp-unknown-id-string)))))
@@ -1664,25 +1717,34 @@ ID-FORMAT valid values are `string' and `integer'."
"The gid of the remote connection VEC, in ID-FORMAT.
ID-FORMAT valid values are `string' and `integer'."
(with-tramp-connection-property vec (format "gid-%s" id-format)
- (let ((method (tramp-file-name-method vec))
- (user (tramp-file-name-user vec))
- (domain (tramp-file-name-domain vec))
- (host (tramp-file-name-host vec))
- (port (tramp-file-name-port vec))
- (localname
+ (let ((localname
(tramp-get-connection-property vec "default-location" nil)))
(cond
(localname
(tramp-compat-file-attribute-group-id
(file-attributes
- (tramp-make-tramp-file-name method user domain host port localname)
- id-format)))
+ (tramp-make-tramp-file-name vec localname) id-format)))
((equal id-format 'integer) tramp-unknown-id-integer)
((equal id-format 'string) tramp-unknown-id-string)))))
(defvar tramp-gvfs-get-remote-uid-gid-in-progress nil
"Indication, that remote uid and gid determination is in progress.")
+(defun tramp-gvfs-get-remote-prefix (vec)
+ "The prefix of the remote connection VEC.
+This is relevant for GNOME Online Accounts."
+ (with-tramp-connection-property vec "prefix"
+ ;; Ensure that GNOME Online Accounts are cached.
+ (when (member (tramp-file-name-method vec) tramp-goa-methods)
+ (tramp-get-goa-accounts vec))
+ (tramp-get-connection-property
+ (make-tramp-goa-name
+ :method (tramp-file-name-method vec)
+ :user (tramp-file-name-user vec)
+ :host (tramp-file-name-host vec)
+ :port (tramp-file-name-port vec))
+ "prefix" "/")))
+
(defun tramp-gvfs-maybe-open-connection (vec)
"Maybe open a connection VEC.
Does not do anything if a connection is already open, but re-opens the
@@ -1699,24 +1761,22 @@ connection if a previous connection has died for some reason."
:name (tramp-buffer-name vec)
:buffer (tramp-get-connection-buffer vec)
:server t :host 'local :service t :noquery t)))
+ (process-put p 'vector vec)
(set-process-query-on-exit-flag p nil)))
(unless (tramp-gvfs-connection-mounted-p vec)
- (let* ((method (tramp-file-name-method vec))
- (user (tramp-file-name-user vec))
- (domain (tramp-file-name-domain vec))
- (host (tramp-file-name-host vec))
- (port (tramp-file-name-port vec))
- (localname (tramp-file-name-unquote-localname vec))
- (object-path
- (tramp-gvfs-object-path
- (tramp-make-tramp-file-name method user domain host port ""))))
+ (let ((method (tramp-file-name-method vec))
+ (user (tramp-file-name-user vec))
+ (host (tramp-file-name-host vec))
+ (localname (tramp-file-name-unquote-localname vec))
+ (object-path
+ (tramp-gvfs-object-path (tramp-make-tramp-file-name vec 'noloc))))
(when (and (string-equal method "afp")
(string-equal localname "/"))
(tramp-error vec 'file-error "Filename must contain an AFP volume"))
- (when (and (string-match method "davs?")
+ (when (and (string-match-p "davs?" method)
(string-equal localname "/"))
(tramp-error vec 'file-error "Filename must contain a WebDAV share"))
@@ -1738,25 +1798,26 @@ connection if a previous connection has died for some reason."
(dbus-register-method
:session dbus-service-emacs object-path
tramp-gvfs-interface-mountoperation "askPassword"
- 'tramp-gvfs-handler-askpassword)
+ #'tramp-gvfs-handler-askpassword)
(dbus-register-method
:session dbus-service-emacs object-path
tramp-gvfs-interface-mountoperation "AskPassword"
- 'tramp-gvfs-handler-askpassword)
+ #'tramp-gvfs-handler-askpassword)
- ;; There could be a callback of "askQuestion" when adding fingerprint.
+ ;; There could be a callback of "askQuestion" when adding
+ ;; fingerprints or checking certificates.
(dbus-register-method
:session dbus-service-emacs object-path
tramp-gvfs-interface-mountoperation "askQuestion"
- 'tramp-gvfs-handler-askquestion)
+ #'tramp-gvfs-handler-askquestion)
(dbus-register-method
:session dbus-service-emacs object-path
tramp-gvfs-interface-mountoperation "AskQuestion"
- 'tramp-gvfs-handler-askquestion)
+ #'tramp-gvfs-handler-askquestion)
;; The call must be asynchronously, because of the "askPassword"
;; or "askQuestion" callbacks.
- (if (string-match "(so)$" tramp-gvfs-mountlocation-signature)
+ (if (string-match-p "(so)$" tramp-gvfs-mountlocation-signature)
(with-tramp-dbus-call-method vec nil
:session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
@@ -1791,6 +1852,9 @@ connection if a previous connection has died for some reason."
(tramp-get-file-property vec "/" "fuse-mountpoint" "") "/")
(tramp-error vec 'file-error "FUSE mount denied"))
+ ;; Save the password.
+ (ignore-errors (funcall tramp-password-save-function))
+
;; Set connection-local variables.
(tramp-set-connection-local-variables vec)
@@ -1799,7 +1863,7 @@ connection if a previous connection has died for some reason."
(tramp-get-connection-process vec) "connected" t))))
;; In `tramp-check-cached-permissions', the connection properties
- ;; {uig,gid}-{integer,string} are used. We set them to proper values.
+ ;; "{uid,gid}-{integer,string}" are used. We set them to proper values.
(unless tramp-gvfs-get-remote-uid-gid-in-progress
(let ((tramp-gvfs-get-remote-uid-gid-in-progress t))
(tramp-gvfs-get-remote-uid vec 'integer)
@@ -1832,88 +1896,66 @@ is applied, and it returns t if the return code is zero."
(with-current-buffer (tramp-get-connection-buffer vec)
(tramp-gvfs-maybe-open-connection vec)
(erase-buffer)
- (or (zerop (apply 'tramp-call-process vec command nil t nil args))
+ (or (zerop (apply #'tramp-call-process vec command nil t nil args))
;; Remove information about mounted connection.
- (and (tramp-flush-file-property vec "/") nil)))))
+ (and (tramp-flush-file-properties vec "/") nil)))))
-;; D-Bus BLUEZ functions.
-
-(defun tramp-bluez-list-devices ()
- "Return all discovered bluetooth devices as list.
-Every entry is a list (NAME ADDRESS).
-
-If `tramp-bluez-discover-devices-timeout' is an integer, and the last
-discovery happened more time before indicated there, a rescan will be
-started, which lasts some ten seconds. Otherwise, cached results will
-be used."
- ;; Reset the scanned devices list if time has passed.
- (and (integerp tramp-bluez-discover-devices-timeout)
- (integerp tramp-bluez-discovery)
- (> (tramp-time-diff (current-time) tramp-bluez-discovery)
- tramp-bluez-discover-devices-timeout)
- (setq tramp-bluez-devices nil))
-
- ;; Rescan if needed.
- (unless tramp-bluez-devices
- (let ((object-path
- (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
- :system tramp-bluez-service "/"
- tramp-bluez-interface-manager "DefaultAdapter")))
- (setq tramp-bluez-devices nil
- tramp-bluez-discovery t)
- (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector nil
- :system tramp-bluez-service object-path
- tramp-bluez-interface-adapter "StartDiscovery")
- (while tramp-bluez-discovery
- (read-event nil nil 0.1))))
- (setq tramp-bluez-discovery (current-time))
- (tramp-message tramp-gvfs-dbus-event-vector 10 "%s" tramp-bluez-devices)
- tramp-bluez-devices)
-
-(defun tramp-bluez-property-changed (property value)
- "Signal handler for the \"org.bluez.Adapter.PropertyChanged\" signal."
- (tramp-message tramp-gvfs-dbus-event-vector 6 "%s %s" property value)
- (cond
- ((string-equal property "Discovering")
- (unless (car value)
- ;; "Discovering" FALSE means discovery run has been completed.
- ;; We stop it, because we don't need another run.
- (setq tramp-bluez-discovery nil)
- (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
- :system tramp-bluez-service (dbus-event-path-name last-input-event)
- tramp-bluez-interface-adapter "StopDiscovery")))))
-
-(when tramp-gvfs-enabled
- (dbus-register-signal
- :system nil nil tramp-bluez-interface-adapter "PropertyChanged"
- 'tramp-bluez-property-changed))
-
-(defun tramp-bluez-device-found (device args)
- "Signal handler for the \"org.bluez.Adapter.DeviceFound\" signal."
- (tramp-message tramp-gvfs-dbus-event-vector 6 "%s %s" device args)
- (let ((alias (car (cadr (assoc "Alias" args))))
- (address (car (cadr (assoc "Address" args)))))
- ;; Maybe we shall check the device class for being a proper
- ;; device, and call also SDP in order to find the obex service.
- (add-to-list 'tramp-bluez-devices (list alias address))))
-
-(when tramp-gvfs-enabled
- (dbus-register-signal
- :system nil nil tramp-bluez-interface-adapter "DeviceFound"
- 'tramp-bluez-device-found))
-
-(defun tramp-bluez-parse-device-names (_ignore)
- "Return a list of (nil host) tuples allowed to access."
- (mapcar
- (lambda (x) (list nil (car x)))
- (tramp-bluez-list-devices)))
-
-;; Add completion function for OBEX method.
-(when (and tramp-gvfs-enabled
- (member tramp-bluez-service (dbus-list-known-names :system)))
- (tramp-set-completion-function
- "obex" '((tramp-bluez-parse-device-names ""))))
+;; D-Bus GNOME Online Accounts functions.
+
+(defun tramp-get-goa-accounts (vec)
+ "Retrieve GNOME Online Accounts, and cache them.
+The hash key is a `tramp-goa-name' structure. The value is an
+alist of the properties of `tramp-goa-interface-account' and
+`tramp-goa-interface-files' of the corresponding GNOME online
+account. Additionally, a property \"prefix\" is added.
+VEC is used only for traces."
+ (dolist
+ (object-path
+ (mapcar
+ #'car
+ (tramp-dbus-function
+ vec #'dbus-get-all-managed-objects
+ `(:session ,tramp-goa-service ,tramp-goa-path))))
+ (let* ((account-properties
+ (with-tramp-dbus-get-all-properties vec
+ :session tramp-goa-service object-path
+ tramp-goa-interface-account))
+ (files-properties
+ (with-tramp-dbus-get-all-properties vec
+ :session tramp-goa-service object-path
+ tramp-goa-interface-files))
+ (identity
+ (or (cdr (assoc "PresentationIdentity" account-properties)) ""))
+ key)
+ ;; Only accounts which matter.
+ (when (and
+ (not (cdr (assoc "FilesDisabled" account-properties)))
+ (member
+ (cdr (assoc "ProviderType" account-properties))
+ '("google" "owncloud"))
+ (string-match tramp-goa-identity-regexp identity))
+ (setq key (make-tramp-goa-name
+ :method (cdr (assoc "ProviderType" account-properties))
+ :user (match-string 1 identity)
+ :host (match-string 2 identity)
+ :port (match-string 3 identity)))
+ (when (string-equal (tramp-goa-name-method key) "google")
+ (setf (tramp-goa-name-method key) "gdrive"))
+ (when (string-equal (tramp-goa-name-method key) "owncloud")
+ (setf (tramp-goa-name-method key) "nextcloud"))
+ ;; Cache all properties.
+ (dolist (prop (nconc account-properties files-properties))
+ (tramp-set-connection-property key (car prop) (cdr prop)))
+ ;; Cache "prefix".
+ (tramp-message
+ vec 10 "%s prefix %s" key
+ (tramp-set-connection-property
+ key "prefix"
+ (directory-file-name
+ (url-filename
+ (url-generic-parse-url
+ (tramp-get-connection-property key "Uri" "file:///"))))))))))
;; D-Bus zeroconf functions.
@@ -1997,41 +2039,6 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi."
(tramp-set-completion-function
"smb" '((tramp-gvfs-parse-device-names "_smb._tcp"))))))))
-
-;; D-Bus SYNCE functions.
-
-(defun tramp-synce-list-devices ()
- "Return all discovered synce devices as list.
-They are retrieved from the hal daemon."
- (let (tramp-synce-devices)
- (dolist (device
- (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
- :system tramp-hal-service tramp-hal-path-manager
- tramp-hal-interface-manager "GetAllDevices"))
- (when (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t
- :system tramp-hal-service device tramp-hal-interface-device
- "PropertyExists" "sync.plugin")
- (let ((prop
- (with-tramp-dbus-call-method
- tramp-gvfs-dbus-event-vector t
- :system tramp-hal-service device tramp-hal-interface-device
- "GetPropertyString" "pda.pocketpc.name")))
- (unless (member prop tramp-synce-devices)
- (push prop tramp-synce-devices)))))
- (tramp-message tramp-gvfs-dbus-event-vector 10 "%s" tramp-synce-devices)
- tramp-synce-devices))
-
-(defun tramp-synce-parse-device-names (_ignore)
- "Return a list of (nil host) tuples allowed to access."
- (mapcar
- (lambda (x) (list nil x))
- (tramp-synce-list-devices)))
-
-;; Add completion function for SYNCE method.
-(when tramp-gvfs-enabled
- (tramp-set-completion-function
- "synce" '((tramp-synce-parse-device-names ""))))
-
(add-hook 'tramp-unload-hook
(lambda ()
(unload-feature 'tramp-gvfs 'force)))
@@ -2040,15 +2047,14 @@ They are retrieved from the hal daemon."
;;; TODO:
+;; * (Customizable) unmount when exiting Emacs. See tramp-archive.el.
+;;
;; * Host name completion for existing mount points (afp-server,
-;; smb-server) or via smb-network.
+;; smb-server, google-drive, nextcloud) or via smb-network or network.
;;
;; * Check, how two shares of the same SMB server can be mounted in
;; parallel.
;;
-;; * Apply SDP on bluetooth devices, in order to filter out obex
-;; capability.
-;;
-;; * Implement obex for other serial communication but bluetooth.
+;; * What's up with ftps dns-sd afc admin computer?
;;; tramp-gvfs.el ends here
diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el
new file mode 100644
index 00000000000..da168adce77
--- /dev/null
+++ b/lisp/net/tramp-integration.el
@@ -0,0 +1,199 @@
+;;; tramp-integration.el --- Tramp integration into other packages -*- lexical-binding:t -*-
+
+;; Copyright (C) 2019 Free Software Foundation, Inc.
+
+;; Author: Michael Albinus <michael.albinus@gmx.de>
+;; Keywords: comm, processes
+;; Package: tramp
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This assembles all integration of Tramp with other packages.
+
+;;; Code:
+
+(require 'tramp-compat)
+
+;; Pacify byte-compiler.
+(require 'cl-lib)
+(declare-function tramp-dissect-file-name "tramp")
+(declare-function tramp-file-name-equal-p "tramp")
+(declare-function tramp-tramp-file-p "tramp")
+(declare-function recentf-cleanup "recentf")
+(defvar eshell-path-env)
+(defvar recentf-exclude)
+(defvar tramp-current-connection)
+(defvar tramp-postfix-host-format)
+
+;;; Fontification of `read-file-name':
+
+(defvar tramp-rfn-eshadow-overlay)
+(make-variable-buffer-local 'tramp-rfn-eshadow-overlay)
+
+(defun tramp-rfn-eshadow-setup-minibuffer ()
+ "Set up a minibuffer for `file-name-shadow-mode'.
+Adds another overlay hiding filename parts according to Tramp's
+special handling of `substitute-in-file-name'."
+ (when minibuffer-completing-file-name
+ (setq tramp-rfn-eshadow-overlay
+ (make-overlay (minibuffer-prompt-end) (minibuffer-prompt-end)))
+ ;; Copy rfn-eshadow-overlay properties.
+ (let ((props (overlay-properties rfn-eshadow-overlay)))
+ (while props
+ ;; The `field' property prevents correct minibuffer
+ ;; completion; we exclude it.
+ (if (not (eq (car props) 'field))
+ (overlay-put tramp-rfn-eshadow-overlay (pop props) (pop props))
+ (pop props) (pop props))))))
+
+(add-hook 'rfn-eshadow-setup-minibuffer-hook
+ #'tramp-rfn-eshadow-setup-minibuffer)
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (remove-hook 'rfn-eshadow-setup-minibuffer-hook
+ #'tramp-rfn-eshadow-setup-minibuffer)))
+
+(defun tramp-rfn-eshadow-update-overlay-regexp ()
+ (format "[^%s/~]*\\(/\\|~\\)" tramp-postfix-host-format))
+
+;; Package rfn-eshadow is preloaded in Emacs, but for some reason,
+;; it only did (defvar rfn-eshadow-overlay) without giving it a global
+;; value, so it was only declared as dynamically-scoped within the
+;; rfn-eshadow.el file. This is now fixed in Emacs>26.1 but we still need
+;; this defvar here for older releases.
+(defvar rfn-eshadow-overlay)
+
+(defun tramp-rfn-eshadow-update-overlay ()
+ "Update `rfn-eshadow-overlay' to cover shadowed part of minibuffer input.
+This is intended to be used as a minibuffer `post-command-hook' for
+`file-name-shadow-mode'; the minibuffer should have already
+been set up by `rfn-eshadow-setup-minibuffer'."
+ ;; In remote files name, there is a shadowing just for the local part.
+ (ignore-errors
+ (let ((end (or (overlay-end rfn-eshadow-overlay)
+ (minibuffer-prompt-end)))
+ ;; We do not want to send any remote command.
+ (non-essential t))
+ (when (tramp-tramp-file-p (buffer-substring end (point-max)))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region
+ (1+ (or (string-match-p
+ (tramp-rfn-eshadow-update-overlay-regexp)
+ (buffer-string) end)
+ end))
+ (point-max))
+ (let ((rfn-eshadow-overlay tramp-rfn-eshadow-overlay)
+ (rfn-eshadow-update-overlay-hook nil)
+ file-name-handler-alist)
+ (move-overlay rfn-eshadow-overlay (point-max) (point-max))
+ (rfn-eshadow-update-overlay))))))))
+
+(add-hook 'rfn-eshadow-update-overlay-hook
+ #'tramp-rfn-eshadow-update-overlay)
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (remove-hook 'rfn-eshadow-update-overlay-hook
+ #'tramp-rfn-eshadow-update-overlay)))
+
+;;; Integration of eshell.el:
+
+;; eshell.el keeps the path in `eshell-path-env'. We must change it
+;; when `default-directory' points to another host.
+(defun tramp-eshell-directory-change ()
+ "Set `eshell-path-env' to $PATH of the host related to `default-directory'."
+ ;; Remove last element of `(exec-path)', which is `exec-directory'.
+ ;; Use `path-separator' as it does eshell.
+ (setq eshell-path-env
+ (mapconcat
+ #'identity (butlast (tramp-compat-exec-path)) path-separator)))
+
+(eval-after-load "esh-util"
+ '(progn
+ (add-hook 'eshell-mode-hook
+ #'tramp-eshell-directory-change)
+ (add-hook 'eshell-directory-change-hook
+ #'tramp-eshell-directory-change)
+ (add-hook 'tramp-integration-unload-hook
+ (lambda ()
+ (remove-hook 'eshell-mode-hook
+ #'tramp-eshell-directory-change)
+ (remove-hook 'eshell-directory-change-hook
+ #'tramp-eshell-directory-change)))))
+
+;;; Integration of recentf.el:
+
+(defun tramp-recentf-exclude-predicate (name)
+ "Predicate to exclude a remote file name from recentf.
+NAME must be equal to `tramp-current-connection'."
+ (when (file-remote-p name)
+ (tramp-file-name-equal-p
+ (tramp-dissect-file-name name) (car tramp-current-connection))))
+
+(defun tramp-recentf-cleanup (vec)
+ "Remove all file names related to VEC from recentf."
+ (when (bound-and-true-p recentf-list)
+ (let ((tramp-current-connection `(,vec))
+ (recentf-exclude '(tramp-recentf-exclude-predicate)))
+ (recentf-cleanup))))
+
+(defun tramp-recentf-cleanup-all ()
+ "Remove all remote file names from recentf."
+ (when (bound-and-true-p recentf-list)
+ (let ((recentf-exclude '(file-remote-p)))
+ (recentf-cleanup))))
+
+(eval-after-load "recentf"
+ '(progn
+ (add-hook 'tramp-cleanup-connection-hook
+ #'tramp-recentf-cleanup)
+ (add-hook 'tramp-cleanup-all-connections-hook
+ #'tramp-recentf-cleanup-all)
+ (add-hook 'tramp-integration-unload-hook
+ (lambda ()
+ (remove-hook 'tramp-cleanup-connection-hook
+ #'tramp-recentf-cleanup)
+ (remove-hook 'tramp-cleanup-all-connections-hook
+ #'tramp-recentf-cleanup-all)))))
+
+;;; Default connection-local variables for Tramp:
+
+(defconst tramp-connection-local-default-profile
+ '((shell-file-name . "/bin/sh")
+ (shell-command-switch . "-c"))
+ "Default connection-local variables for remote connections.")
+
+;; `connection-local-set-profile-variables' and
+;; `connection-local-set-profiles' exists since Emacs 26.1.
+(eval-after-load "shell"
+ '(progn
+ (tramp-compat-funcall
+ 'connection-local-set-profile-variables
+ 'tramp-connection-local-default-profile
+ tramp-connection-local-default-profile)
+ (tramp-compat-funcall
+ 'connection-local-set-profiles
+ `(:application tramp)
+ 'tramp-connection-local-default-profile)))
+
+(add-hook 'tramp-unload-hook
+ (lambda () (unload-feature 'tramp-integration 'force)))
+
+(provide 'tramp-integration)
+
+;;; tramp-integration.el ends here
diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el
new file mode 100644
index 00000000000..0148116d739
--- /dev/null
+++ b/lisp/net/tramp-rclone.el
@@ -0,0 +1,608 @@
+;;; tramp-rclone.el --- Tramp access functions to cloud storages -*- lexical-binding:t -*-
+
+;; Copyright (C) 2018-2019 Free Software Foundation, Inc.
+
+;; Author: Michael Albinus <michael.albinus@gmx.de>
+;; Keywords: comm, processes
+;; Package: tramp
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; rclone is a command line program to sync files and directories to
+;; and from cloud storages. Tramp uses its mount utility to access
+;; files and directories there. The configuration of rclone for
+;; different storage systems is performed outside Tramp, see rclone(1).
+
+;; A remote file under rclone control has the form
+;; "/rclone:<remote>:/path/to/file". <remote> is the name of a
+;; storage system in rclone's configuration. Therefore, such a remote
+;; file name does not know of any user or port specification.
+
+;;; Code:
+
+(eval-when-compile (require 'cl-lib))
+(require 'tramp)
+
+;;;###tramp-autoload
+(defconst tramp-rclone-method "rclone"
+ "When this method name is used, forward all calls to rclone mounts.")
+
+(defcustom tramp-rclone-program "rclone"
+ "Name of the rclone program."
+ :group 'tramp
+ :version "27.1"
+ :type 'string)
+
+;;;###tramp-autoload
+(tramp--with-startup
+ (add-to-list 'tramp-methods
+ `(,tramp-rclone-method
+ (tramp-mount-args nil)
+ (tramp-copyto-args nil)
+ (tramp-moveto-args nil)
+ (tramp-about-args ("--full"))))
+
+ (add-to-list 'tramp-default-host-alist `(,tramp-rclone-method nil ""))
+
+ (tramp-set-completion-function
+ tramp-rclone-method '((tramp-rclone-parse-device-names ""))))
+
+
+;; New handlers should be added here.
+;;;###tramp-autoload
+(defconst tramp-rclone-file-name-handler-alist
+ '((access-file . tramp-handle-access-file)
+ (add-name-to-file . tramp-handle-add-name-to-file)
+ ;; `byte-compiler-base-file-name' performed by default handler.
+ ;; `copy-directory' performed by default handler.
+ (copy-file . tramp-rclone-handle-copy-file)
+ (delete-directory . tramp-rclone-handle-delete-directory)
+ (delete-file . tramp-rclone-handle-delete-file)
+ ;; `diff-latest-backup-file' performed by default handler.
+ (directory-file-name . tramp-handle-directory-file-name)
+ (directory-files . tramp-rclone-handle-directory-files)
+ (directory-files-and-attributes
+ . tramp-handle-directory-files-and-attributes)
+ (dired-compress-file . ignore)
+ (dired-uncache . tramp-handle-dired-uncache)
+ (exec-path . ignore)
+ (expand-file-name . tramp-handle-expand-file-name)
+ (file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
+ (file-acl . ignore)
+ (file-attributes . tramp-rclone-handle-file-attributes)
+ (file-directory-p . tramp-handle-file-directory-p)
+ (file-equal-p . tramp-handle-file-equal-p)
+ (file-executable-p . tramp-rclone-handle-file-executable-p)
+ (file-exists-p . tramp-handle-file-exists-p)
+ (file-in-directory-p . tramp-handle-file-in-directory-p)
+ (file-local-copy . tramp-handle-file-local-copy)
+ (file-modes . tramp-handle-file-modes)
+ (file-name-all-completions . tramp-rclone-handle-file-name-all-completions)
+ (file-name-as-directory . tramp-handle-file-name-as-directory)
+ (file-name-case-insensitive-p . tramp-handle-file-name-case-insensitive-p)
+ (file-name-completion . tramp-handle-file-name-completion)
+ (file-name-directory . tramp-handle-file-name-directory)
+ (file-name-nondirectory . tramp-handle-file-name-nondirectory)
+ ;; `file-name-sans-versions' performed by default handler.
+ (file-newer-than-file-p . tramp-handle-file-newer-than-file-p)
+ (file-notify-add-watch . ignore)
+ (file-notify-rm-watch . ignore)
+ (file-notify-valid-p . ignore)
+ (file-ownership-preserved-p . ignore)
+ (file-readable-p . tramp-rclone-handle-file-readable-p)
+ (file-regular-p . tramp-handle-file-regular-p)
+ (file-remote-p . tramp-handle-file-remote-p)
+ (file-selinux-context . tramp-handle-file-selinux-context)
+ (file-symlink-p . tramp-handle-file-symlink-p)
+ (file-system-info . tramp-rclone-handle-file-system-info)
+ (file-truename . tramp-handle-file-truename)
+ (file-writable-p . tramp-handle-file-writable-p)
+ (find-backup-file-name . tramp-handle-find-backup-file-name)
+ ;; `get-file-buffer' performed by default handler.
+ (insert-directory . tramp-handle-insert-directory)
+ (insert-file-contents . tramp-handle-insert-file-contents)
+ (load . tramp-handle-load)
+ (make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
+ (make-directory . tramp-rclone-handle-make-directory)
+ (make-directory-internal . ignore)
+ (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
+ (make-process . ignore)
+ (make-symbolic-link . tramp-handle-make-symbolic-link)
+ (process-file . ignore)
+ (rename-file . tramp-rclone-handle-rename-file)
+ (set-file-acl . ignore)
+ (set-file-modes . ignore)
+ (set-file-selinux-context . ignore)
+ (set-file-times . ignore)
+ (set-visited-file-modtime . tramp-handle-set-visited-file-modtime)
+ (shell-command . ignore)
+ (start-file-process . ignore)
+ (substitute-in-file-name . tramp-handle-substitute-in-file-name)
+ (temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-set-file-uid-gid . ignore)
+ (unhandled-file-name-directory . ignore)
+ (vc-registered . ignore)
+ (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
+ (write-region . tramp-handle-write-region))
+ "Alist of handler functions for Tramp RCLONE method.
+Operations not mentioned here will be handled by the default Emacs primitives.")
+
+;; It must be a `defsubst' in order to push the whole code into
+;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading.
+;;;###tramp-autoload
+(defsubst tramp-rclone-file-name-p (filename)
+ "Check if it's a filename for rclone."
+ (and (tramp-tramp-file-p filename)
+ (string= (tramp-file-name-method (tramp-dissect-file-name filename))
+ tramp-rclone-method)))
+
+;;;###tramp-autoload
+(defun tramp-rclone-file-name-handler (operation &rest args)
+ "Invoke the rclone handler for OPERATION.
+First arg specifies the OPERATION, second arg is a list of arguments to
+pass to the OPERATION."
+ (let ((fn (assoc operation tramp-rclone-file-name-handler-alist)))
+ (if fn
+ (save-match-data (apply (cdr fn) args))
+ (tramp-run-real-handler operation args))))
+
+;;;###tramp-autoload
+(tramp--with-startup
+ (tramp-register-foreign-file-name-handler
+ #'tramp-rclone-file-name-p #'tramp-rclone-file-name-handler))
+
+;;;###tramp-autoload
+(defun tramp-rclone-parse-device-names (_ignore)
+ "Return a list of (nil host) tuples allowed to access."
+ (with-tramp-connection-property nil "rclone-device-names"
+ (delq nil
+ (mapcar
+ (lambda (line)
+ (when (string-match "^\\(\\S-+\\):$" line)
+ `(nil ,(match-string 1 line))))
+ (tramp-process-lines nil tramp-rclone-program "listremotes")))))
+
+
+;; File name primitives.
+
+(defun tramp-rclone-do-copy-or-rename-file
+ (op filename newname &optional ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes)
+ "Copy or rename a remote file.
+OP must be `copy' or `rename' and indicates the operation to perform.
+FILENAME specifies the file to copy or rename, NEWNAME is the name of
+the new file (for copy) or the new name of the file (for rename).
+OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already.
+KEEP-DATE means to make sure that NEWNAME has the same timestamp
+as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep
+the uid and gid if both files are on the same host.
+PRESERVE-EXTENDED-ATTRIBUTES is ignored.
+
+This function is invoked by `tramp-rclone-handle-copy-file' and
+`tramp-rclone-handle-rename-file'. It is an error if OP is neither
+of `copy' and `rename'. FILENAME and NEWNAME must be absolute
+file names."
+ (unless (memq op '(copy rename))
+ (error "Unknown operation `%s', must be `copy' or `rename'" op))
+
+ (setq filename (file-truename filename))
+ (if (file-directory-p filename)
+ (progn
+ (copy-directory filename newname keep-date t)
+ (when (eq op 'rename) (delete-directory filename 'recursive)))
+
+ (let ((t1 (tramp-tramp-file-p filename))
+ (t2 (tramp-tramp-file-p newname))
+ (rclone-operation (if (eq op 'copy) "copyto" "moveto"))
+ (msg-operation (if (eq op 'copy) "Copying" "Renaming")))
+
+ (with-parsed-tramp-file-name (if t1 filename newname) nil
+ (when (and (not ok-if-already-exists) (file-exists-p newname))
+ (tramp-error v 'file-already-exists newname))
+
+ (if (or (and t1 (not (tramp-rclone-file-name-p filename)))
+ (and t2 (not (tramp-rclone-file-name-p newname))))
+
+ ;; We cannot copy or rename directly.
+ (let ((tmpfile (tramp-compat-make-temp-file filename)))
+ (if (eq op 'copy)
+ (copy-file
+ filename tmpfile t keep-date preserve-uid-gid
+ preserve-extended-attributes)
+ (rename-file filename tmpfile t))
+ (rename-file tmpfile newname ok-if-already-exists))
+
+ ;; Direct action.
+ (with-tramp-progress-reporter
+ v 0 (format "%s %s to %s" msg-operation filename newname)
+ (unless (zerop
+ (tramp-rclone-send-command
+ v rclone-operation
+ (tramp-rclone-remote-file-name filename)
+ (tramp-rclone-remote-file-name newname)))
+ (tramp-error
+ v 'file-error
+ "Error %s `%s' `%s'" msg-operation filename newname)))
+
+ (when (and t1 (eq op 'rename))
+ (with-parsed-tramp-file-name filename v1
+ (tramp-flush-file-properties
+ v1 (file-name-directory v1-localname))
+ (tramp-flush-file-properties v1 v1-localname)
+ (when (tramp-rclone-file-name-p filename)
+ (tramp-rclone-flush-directory-cache v1)
+ ;; The mount point's directory cache might need time
+ ;; to flush.
+ (while (file-exists-p filename)
+ (tramp-flush-file-properties
+ v1 (file-name-directory v1-localname))
+ (tramp-flush-file-properties v1 v1-localname)))))
+
+ (when t2
+ (with-parsed-tramp-file-name newname v2
+ (tramp-flush-file-properties
+ v2 (file-name-directory v2-localname))
+ (tramp-flush-file-properties v2 v2-localname)
+ (when (tramp-rclone-file-name-p newname)
+ (tramp-rclone-flush-directory-cache v2)
+ ;; The mount point's directory cache might need time
+ ;; to flush.
+ (while (not (file-exists-p newname))
+ (tramp-flush-file-properties
+ v2 (file-name-directory v2-localname))
+ (tramp-flush-file-properties v2 v2-localname))))))))))
+
+(defun tramp-rclone-handle-copy-file
+ (filename newname &optional ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes)
+ "Like `copy-file' for Tramp files."
+ (setq filename (expand-file-name filename))
+ (setq newname (expand-file-name newname))
+ ;; At least one file a Tramp file?
+ (if (or (tramp-tramp-file-p filename)
+ (tramp-tramp-file-p newname))
+ (tramp-rclone-do-copy-or-rename-file
+ 'copy filename newname ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes)
+ (tramp-run-real-handler
+ #'copy-file
+ (list filename newname ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes))))
+
+(defun tramp-rclone-handle-delete-directory
+ (directory &optional recursive trash)
+ "Like `delete-directory' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name directory) nil
+ (delete-directory (tramp-rclone-local-file-name directory) recursive trash)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-directory-properties v localname)
+ (tramp-rclone-flush-directory-cache v)))
+
+(defun tramp-rclone-handle-delete-file (filename &optional trash)
+ "Like `delete-file' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (delete-file (tramp-rclone-local-file-name filename) trash)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
+ (tramp-rclone-flush-directory-cache v)))
+
+(defun tramp-rclone-handle-directory-files
+ (directory &optional full match nosort)
+ "Like `directory-files' for Tramp files."
+ (when (file-directory-p directory)
+ (setq directory (file-name-as-directory (expand-file-name directory)))
+ (with-parsed-tramp-file-name directory nil
+ (let ((result
+ (directory-files
+ (tramp-rclone-local-file-name directory) full match)))
+ ;; Massage the result.
+ (when full
+ (let ((local (concat "^" (regexp-quote (tramp-rclone-mount-point v))))
+ (remote (funcall (if (tramp-compat-file-name-quoted-p directory)
+ #'tramp-compat-file-name-quote #'identity)
+ (file-remote-p directory))))
+ (setq result
+ (mapcar
+ (lambda (x) (replace-regexp-in-string local remote x))
+ result))))
+ ;; Some storage systems do not return "." and "..".
+ (dolist (item '(".." "."))
+ (when (and (string-match-p (or match (regexp-quote item)) item)
+ (not
+ (member (if full (setq item (concat directory item)) item)
+ result)))
+ (setq result (cons item result))))
+ ;; Return result.
+ (if nosort result (sort result #'string<))))))
+
+(defun tramp-rclone-handle-file-attributes (filename &optional id-format)
+ "Like `file-attributes' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (with-tramp-file-property
+ v localname (format "file-attributes-%s" id-format)
+ (file-attributes (tramp-rclone-local-file-name filename) id-format))))
+
+(defun tramp-rclone-handle-file-executable-p (filename)
+ "Like `file-executable-p' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (with-tramp-file-property v localname "file-executable-p"
+ (file-executable-p (tramp-rclone-local-file-name filename)))))
+
+(defun tramp-rclone-handle-file-name-all-completions (filename directory)
+ "Like `file-name-all-completions' for Tramp files."
+ (all-completions
+ filename
+ (delete-dups
+ (append
+ (file-name-all-completions
+ filename (tramp-rclone-local-file-name directory))
+ ;; Some storage systems do not return "." and "..".
+ (let (result)
+ (dolist (item '(".." ".") result)
+ (when (string-prefix-p filename item)
+ (catch 'match
+ (dolist (elt completion-regexp-list)
+ (unless (string-match-p elt item) (throw 'match nil)))
+ (setq result (cons (concat item "/") result))))))))))
+
+(defun tramp-rclone-handle-file-readable-p (filename)
+ "Like `file-readable-p' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (with-tramp-file-property v localname "file-readable-p"
+ (file-readable-p (tramp-rclone-local-file-name filename)))))
+
+(defun tramp-rclone-handle-file-system-info (filename)
+ "Like `file-system-info' for Tramp files."
+ (ignore-errors
+ (unless (file-directory-p filename)
+ (setq filename (file-name-directory filename)))
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (tramp-message v 5 "file system info: %s" localname)
+ (tramp-rclone-send-command v "about" (concat host ":"))
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (let (total used free)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (when (looking-at "Total: [[:space:]]+\\([[:digit:]]+\\)")
+ (setq total (string-to-number (match-string 1))))
+ (when (looking-at "Used: [[:space:]]+\\([[:digit:]]+\\)")
+ (setq used (string-to-number (match-string 1))))
+ (when (looking-at "Free: [[:space:]]+\\([[:digit:]]+\\)")
+ (setq free (string-to-number (match-string 1))))
+ (forward-line))
+ (when used
+ ;; The used number of bytes is not part of the result. As
+ ;; side effect, we store it as file property.
+ (tramp-set-file-property v localname "used-bytes" used))
+ ;; Result.
+ (when (and total free)
+ (list total free (- total free))))))))
+
+(defun tramp-rclone-handle-insert-directory
+ (filename switches &optional wildcard full-directory-p)
+ "Like `insert-directory' for Tramp files."
+ (insert-directory
+ (tramp-rclone-local-file-name filename) switches wildcard full-directory-p)
+ (goto-char (point-min))
+ (while (search-forward (tramp-rclone-local-file-name filename) nil 'noerror)
+ (replace-match filename)))
+
+(defun tramp-rclone-handle-insert-file-contents
+ (filename &optional visit beg end replace)
+ "Like `insert-file-contents' for Tramp files."
+ (let ((result
+ (insert-file-contents
+ (tramp-rclone-local-file-name filename) visit beg end replace)))
+ (prog1
+ (list (expand-file-name filename) (cadr result))
+ (when visit (setq buffer-file-name filename)))))
+
+(defun tramp-rclone-handle-make-directory (dir &optional parents)
+ "Like `make-directory' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name dir) nil
+ (make-directory (tramp-rclone-local-file-name dir) parents)
+ ;; When PARENTS is non-nil, DIR could be a chain of non-existent
+ ;; directories a/b/c/... Instead of checking, we simply flush the
+ ;; whole file cache.
+ (tramp-flush-file-properties v localname)
+ (tramp-flush-directory-properties
+ v (if parents "/" (file-name-directory localname)))
+ (tramp-rclone-flush-directory-cache v)))
+
+(defun tramp-rclone-handle-rename-file
+ (filename newname &optional ok-if-already-exists)
+ "Like `rename-file' for Tramp files."
+ (setq filename (expand-file-name filename))
+ (setq newname (expand-file-name newname))
+ ;; At least one file a Tramp file?
+ (if (or (tramp-tramp-file-p filename)
+ (tramp-tramp-file-p newname))
+ (tramp-rclone-do-copy-or-rename-file
+ 'rename filename newname ok-if-already-exists
+ 'keep-date 'preserve-uid-gid)
+ (tramp-run-real-handler
+ #'rename-file (list filename newname ok-if-already-exists))))
+
+
+;; File name conversions.
+
+(defun tramp-rclone-mount-point (vec)
+ "Return local mount point of VEC."
+ (expand-file-name
+ (concat
+ tramp-temp-name-prefix (tramp-file-name-method vec)
+ "." (tramp-file-name-host vec))
+ (tramp-compat-temporary-file-directory)))
+
+(defun tramp-rclone-mounted-p (vec)
+ "Check, whether storage system determined by VEC is mounted."
+ (when (tramp-get-connection-process vec)
+ ;; We cannot use `with-connection-property', because we don't want
+ ;; to cache a nil result.
+ (or (tramp-get-connection-property
+ (tramp-get-connection-process vec) "mounted" nil)
+ (let* ((default-directory temporary-file-directory)
+ (mount (shell-command-to-string "mount -t fuse.rclone")))
+ (tramp-message vec 6 "%s" "mount -t fuse.rclone")
+ (tramp-message vec 6 "\n%s" mount)
+ (tramp-set-connection-property
+ (tramp-get-connection-process vec) "mounted"
+ (when (string-match
+ (format
+ "^\\(%s:\\S-*\\)" (regexp-quote (tramp-file-name-host vec)))
+ mount)
+ (match-string 1 mount)))))))
+
+(defun tramp-rclone-flush-directory-cache (vec)
+ "Flush directory cache of VEC mount."
+ (let ((rclone-pid
+ ;; Identify rclone process.
+ (when (tramp-get-connection-process vec)
+ (with-tramp-connection-property
+ (tramp-get-connection-process vec) "rclone-pid"
+ (catch 'pid
+ (dolist (pid (list-system-processes)) ;; "pidof rclone" ?
+ (and (string-match-p
+ (regexp-quote
+ (format "rclone mount %s:" (tramp-file-name-host vec)))
+ (or (cdr (assoc 'args (process-attributes pid))) ""))
+ (throw 'pid pid))))))))
+ ;; Send a SIGHUP in order to flush directory cache.
+ (when rclone-pid
+ (tramp-message
+ vec 6 "Send SIGHUP %d: %s"
+ rclone-pid (cdr (assoc 'args (process-attributes rclone-pid))))
+ (signal-process rclone-pid 'SIGHUP))))
+
+(defun tramp-rclone-local-file-name (filename)
+ "Return local mount name of FILENAME."
+ (setq filename (tramp-compat-file-name-unquote (expand-file-name filename)))
+ (with-parsed-tramp-file-name filename nil
+ ;; As long as we call `tramp-rclone-maybe-open-connection' here,
+ ;; we cache the result.
+ (with-tramp-file-property v localname "local-file-name"
+ (tramp-rclone-maybe-open-connection v)
+ (let ((quoted (tramp-compat-file-name-quoted-p localname))
+ (localname (tramp-compat-file-name-unquote localname)))
+ (funcall
+ (if quoted #'tramp-compat-file-name-quote #'identity)
+ (expand-file-name
+ (if (file-name-absolute-p localname)
+ (substring localname 1) localname)
+ (tramp-rclone-mount-point v)))))))
+
+(defun tramp-rclone-remote-file-name (filename)
+ "Return FILENAME as used in the `rclone' command."
+ (setq filename (tramp-compat-file-name-unquote (expand-file-name filename)))
+ (if (tramp-rclone-file-name-p filename)
+ (with-parsed-tramp-file-name filename nil
+ ;; As long as we call `tramp-rclone-maybe-open-connection' here,
+ ;; we cache the result.
+ (with-tramp-file-property v localname "remote-file-name"
+ (tramp-rclone-maybe-open-connection v)
+ ;; TODO: This shall be handled by `expand-file-name'.
+ (setq localname
+ (replace-regexp-in-string "^\\." "" (or localname "")))
+ (format "%s%s" (tramp-rclone-mounted-p v) localname)))
+ ;; It is a local file name.
+ filename))
+
+(defun tramp-rclone-maybe-open-connection (vec)
+ "Maybe open a connection VEC.
+Does not do anything if a connection is already open, but re-opens the
+connection if a previous connection has died for some reason."
+ (let ((host (tramp-file-name-host vec)))
+ (when (rassoc `(,host) (tramp-rclone-parse-device-names nil))
+ (if (zerop (length host))
+ (tramp-error vec 'file-error "Storage %s not connected" host))
+
+ ;; During completion, don't reopen a new connection. We check
+ ;; this for the process related to `tramp-buffer-name';
+ ;; otherwise `start-file-process' wouldn't run ever when
+ ;; `non-essential' is non-nil.
+ (when (and (tramp-completion-mode-p)
+ (null (get-process (tramp-buffer-name vec))))
+ (throw 'non-essential 'non-essential))
+
+ ;; We need a process bound to the connection buffer. Therefore,
+ ;; we create a dummy process. Maybe there is a better solution?
+ (unless (get-buffer-process (tramp-get-connection-buffer vec))
+ (let ((p (make-network-process
+ :name (tramp-buffer-name vec)
+ :buffer (tramp-get-connection-buffer vec)
+ :server t :host 'local :service t :noquery t)))
+ (process-put p 'vector vec)
+ (set-process-query-on-exit-flag p nil)
+
+ ;; Set connection-local variables.
+ (tramp-set-connection-local-variables vec)))
+
+ ;; Create directory.
+ (unless (file-directory-p (tramp-rclone-mount-point vec))
+ (make-directory (tramp-rclone-mount-point vec) 'parents))
+
+ ;; Mount. This command does not return, so we use 0 as
+ ;; DESTINATION of `tramp-call-process'.
+ (unless (tramp-rclone-mounted-p vec)
+ (apply
+ #'tramp-call-process
+ vec tramp-rclone-program nil 0 nil
+ (delq nil
+ `("mount" ,(concat host ":/")
+ ,(tramp-rclone-mount-point vec)
+ ;; This could be nil.
+ ,(tramp-get-method-parameter vec 'tramp-mount-args))))
+ (while (not (file-exists-p (tramp-make-tramp-file-name vec 'localname)))
+ (tramp-cleanup-connection vec 'keep-debug 'keep-password))
+
+ ;; Mark it as connected.
+ (tramp-set-connection-property
+ (tramp-get-connection-process vec) "connected" t))))
+
+ ;; In `tramp-check-cached-permissions', the connection properties
+ ;; "{uid,gid}-{integer,string}" are used. We set them to proper values.
+ (with-tramp-connection-property
+ vec "uid-integer" (tramp-get-local-uid 'integer))
+ (with-tramp-connection-property
+ vec "gid-integer" (tramp-get-local-gid 'integer))
+ (with-tramp-connection-property
+ vec "uid-string" (tramp-get-local-uid 'string))
+ (with-tramp-connection-property
+ vec "gid-string" (tramp-get-local-gid 'string)))
+
+(defun tramp-rclone-send-command (vec &rest args)
+ "Send the COMMAND to connection VEC."
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ (erase-buffer)
+ (let ((flags (tramp-get-method-parameter
+ vec (intern (format "tramp-%s-args" (car args))))))
+ (apply #'tramp-call-process
+ vec tramp-rclone-program nil t nil (append args flags)))))
+
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-rclone 'force)))
+
+(provide 'tramp-rclone)
+
+;;; TODO:
+
+;; * If possible, get rid of "rclone mount". Maybe it is more
+;; performant then.
+
+;;; tramp-rclone.el ends here
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index 6e868aa1fc6..7d903c5769c 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -27,6 +27,7 @@
;;; Code:
+(eval-when-compile (require 'cl-lib))
(require 'tramp)
;; Pacify byte-compiler.
@@ -40,7 +41,6 @@
(defvar vc-git-program)
(defvar vc-hg-program)
-;;;###tramp-autoload
(defcustom tramp-inline-compress-start-size 4096
"The minimum size of compressing where inline transfer.
When inline transfer, compress transferred data of file
@@ -49,7 +49,6 @@ If it is nil, no compression at all will be applied."
:group 'tramp
:type '(choice (const nil) integer))
-;;;###tramp-autoload
(defcustom tramp-copy-size-limit 10240
"The maximum file size where inline copying is preferred over an \
out-of-the-band copy.
@@ -66,7 +65,6 @@ files conditionalize this setup based on the TERM environment variable."
:group 'tramp
:type 'string)
-;;;###tramp-autoload
(defcustom tramp-histfile-override "~/.tramp_history"
"When invoking a shell, override the HISTFILE with this value.
When setting to a string, it redirects the shell history to that
@@ -87,7 +85,6 @@ the default storage location, e.g. \"$HOME/.sh_history\"."
(defconst tramp-display-escape-sequence-regexp "\e[[;0-9]+m"
"Terminal control escape sequences for display attributes.")
-;;;###tramp-autoload
(defconst tramp-device-escape-sequence-regexp "\e[[0-9]+n"
"Terminal control escape sequences for device status.")
@@ -110,7 +107,6 @@ detected as prompt when being sent on echoing hosts, therefore.")
(defconst tramp-end-of-heredoc (md5 tramp-end-of-output)
"String used to recognize end of heredoc strings.")
-;;;###tramp-autoload
(defcustom tramp-use-ssh-controlmaster-options t
"Whether to use `tramp-ssh-controlmaster-options'."
:group 'tramp
@@ -133,285 +129,262 @@ The string is used in `tramp-methods'.")
;; Initialize `tramp-methods' with the supported methods.
;;;###tramp-autoload
-(add-to-list 'tramp-methods
- '("rcp"
- (tramp-login-program "rsh")
- (tramp-login-args (("%h") ("-l" "%u")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))
- (tramp-copy-program "rcp")
- (tramp-copy-args (("-p" "%k") ("-r")))
- (tramp-copy-keep-date t)
- (tramp-copy-recursive t)))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- '("remcp"
- (tramp-login-program "remsh")
- (tramp-login-args (("%h") ("-l" "%u")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))
- (tramp-copy-program "rcp")
- (tramp-copy-args (("-p" "%k")))
- (tramp-copy-keep-date t)))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- '("scp"
- (tramp-login-program "ssh")
- (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
- ("-e" "none") ("%h")))
- (tramp-async-args (("-q")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))
- (tramp-copy-program "scp")
- (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q") ("-r") ("%c")))
- (tramp-copy-keep-date t)
- (tramp-copy-recursive t)))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- '("scpx"
- (tramp-login-program "ssh")
- (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
- ("-e" "none") ("-t" "-t") ("%h") ("/bin/sh")))
- (tramp-async-args (("-q")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))
- (tramp-copy-program "scp")
- (tramp-copy-args (("-P" "%p") ("-p" "%k")
- ("-q") ("-r") ("%c")))
- (tramp-copy-keep-date t)
- (tramp-copy-recursive t)))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- '("rsync"
- (tramp-login-program "ssh")
- (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
- ("-e" "none") ("%h")))
- (tramp-async-args (("-q")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))
- (tramp-copy-program "rsync")
- (tramp-copy-args (("-t" "%k") ("-p") ("-r") ("-s") ("-c")))
- (tramp-copy-env (("RSYNC_RSH") ("ssh" "%c")))
- (tramp-copy-keep-date t)
- (tramp-copy-keep-tmpfile t)
- (tramp-copy-recursive t)))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- '("rsh"
- (tramp-login-program "rsh")
- (tramp-login-args (("%h") ("-l" "%u")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- '("remsh"
- (tramp-login-program "remsh")
- (tramp-login-args (("%h") ("-l" "%u")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- '("ssh"
- (tramp-login-program "ssh")
- (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
- ("-e" "none") ("%h")))
- (tramp-async-args (("-q")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- '("sshx"
- (tramp-login-program "ssh")
- (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
- ("-e" "none") ("-t" "-t") ("%h") ("/bin/sh")))
- (tramp-async-args (("-q")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- '("telnet"
- (tramp-login-program "telnet")
- (tramp-login-args (("%h") ("%p") ("2>/dev/null")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- '("nc"
- (tramp-login-program "telnet")
- (tramp-login-args (("%h") ("%p") ("2>/dev/null")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))
- (tramp-copy-program "nc")
- ;; We use "-v" for better error tracking.
- (tramp-copy-args (("-w" "1") ("-v") ("%h") ("%r")))
- (tramp-remote-copy-program "nc")
- ;; We use "-p" as required for newer busyboxes. For older
- ;; busybox/nc versions, the value must be (("-l") ("%r")). This
- ;; can be achieved by tweaking `tramp-connection-properties'.
- (tramp-remote-copy-args (("-l") ("-p" "%r") ("2>/dev/null")))))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- '("su"
- (tramp-login-program "su")
- (tramp-login-args (("-") ("%u")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))
- (tramp-connection-timeout 10)))
-;;;###tramp-autoload
-(add-to-list
- 'tramp-methods
- '("sg"
- (tramp-login-program "sg")
- (tramp-login-args (("-") ("%u")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-args ("-c"))
- (tramp-connection-timeout 10)))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- '("sudo"
- (tramp-login-program "sudo")
- ;; The password template must be masked. Otherwise, it could be
- ;; interpreted as password prompt if the remote host echoes the command.
- (tramp-login-args (("-u" "%u") ("-s") ("-H")
- ("-p" "P\"\"a\"\"s\"\"s\"\"w\"\"o\"\"r\"\"d\"\":")))
- ;; Local $SHELL could be a nasty one, like zsh or fish. Let's override it.
- (tramp-login-env (("SHELL") ("/bin/sh")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))
- (tramp-connection-timeout 10)))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- '("doas"
- (tramp-login-program "doas")
- (tramp-login-args (("-u" "%u") ("-s")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-args ("-c"))
- (tramp-connection-timeout 10)))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- '("ksu"
- (tramp-login-program "ksu")
- (tramp-login-args (("%u") ("-q")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))
- (tramp-connection-timeout 10)))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- '("krlogin"
- (tramp-login-program "krlogin")
- (tramp-login-args (("%h") ("-l" "%u") ("-x")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- `("plink"
- (tramp-login-program "plink")
- ;; ("%h") must be a single element, see `tramp-compute-multi-hops'.
- (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t")
- ("%h") ("\"")
- (,(format
- "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'"
- tramp-terminal-type
- tramp-initial-end-of-output))
- ("/bin/sh") ("\"")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- `("plinkx"
- (tramp-login-program "plink")
- (tramp-login-args (("-load") ("%h") ("-t") ("\"")
- (,(format
- "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'"
- tramp-terminal-type
- tramp-initial-end-of-output))
- ("/bin/sh") ("\"")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- `("pscp"
- (tramp-login-program "plink")
- (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t")
- ("%h") ("\"")
- (,(format
- "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'"
- tramp-terminal-type
- tramp-initial-end-of-output))
- ("/bin/sh") ("\"")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))
- (tramp-copy-program "pscp")
- (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-scp") ("-p" "%k")
- ("-q") ("-r")))
- (tramp-copy-keep-date t)
- (tramp-copy-recursive t)))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- `("psftp"
- (tramp-login-program "plink")
- (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t")
- ("%h") ("\"")
- (,(format
- "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'"
- tramp-terminal-type
- tramp-initial-end-of-output))
- ("/bin/sh") ("\"")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))
- (tramp-copy-program "pscp")
- (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-sftp") ("-p" "%k")
- ("-q")))
- (tramp-copy-keep-date t)))
-;;;###tramp-autoload
-(add-to-list 'tramp-methods
- '("fcp"
- (tramp-login-program "fsh")
- (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i")))
- (tramp-remote-shell "/bin/sh")
- (tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-i") ("-c"))
- (tramp-copy-program "fcp")
- (tramp-copy-args (("-p" "%k")))
- (tramp-copy-keep-date t)))
-
-;;;###tramp-autoload
-(add-to-list 'tramp-default-method-alist
- `(,tramp-local-host-regexp "\\`root\\'" "su"))
-
-;;;###tramp-autoload
-(add-to-list 'tramp-default-user-alist
- `(,(concat "\\`" (regexp-opt '("su" "sudo" "doas" "ksu")) "\\'")
- nil "root"))
-;; Do not add "ssh" based methods, otherwise ~/.ssh/config would be ignored.
-;; Do not add "plink" based methods, they ask interactively for the user.
-;;;###tramp-autoload
-(add-to-list 'tramp-default-user-alist
- `(,(concat
- "\\`"
- (regexp-opt
- '("rcp" "remcp" "rsh" "telnet" "nc" "krlogin" "fcp"))
- "\\'")
- nil ,(user-login-name)))
+(tramp--with-startup
+ (add-to-list 'tramp-methods
+ '("rcp"
+ (tramp-login-program "rsh")
+ (tramp-login-args (("%h") ("-l" "%u")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))
+ (tramp-copy-program "rcp")
+ (tramp-copy-args (("-p" "%k") ("-r")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-recursive t)))
+ (add-to-list 'tramp-methods
+ '("remcp"
+ (tramp-login-program "remsh")
+ (tramp-login-args (("%h") ("-l" "%u")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))
+ (tramp-copy-program "rcp")
+ (tramp-copy-args (("-p" "%k")))
+ (tramp-copy-keep-date t)))
+ (add-to-list 'tramp-methods
+ '("scp"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
+ ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))
+ (tramp-copy-program "scp")
+ (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q") ("-r") ("%c")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-recursive t)))
+ (add-to-list 'tramp-methods
+ '("scpx"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
+ ("-e" "none") ("-t" "-t") ("%h") ("/bin/sh")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))
+ (tramp-copy-program "scp")
+ (tramp-copy-args (("-P" "%p") ("-p" "%k")
+ ("-q") ("-r") ("%c")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-recursive t)))
+ (add-to-list 'tramp-methods
+ '("rsync"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
+ ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))
+ (tramp-copy-program "rsync")
+ (tramp-copy-args (("-t" "%k") ("-p") ("-r") ("-s") ("-c")))
+ (tramp-copy-env (("RSYNC_RSH") ("ssh" "%c")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-keep-tmpfile t)
+ (tramp-copy-recursive t)))
+ (add-to-list 'tramp-methods
+ '("rsh"
+ (tramp-login-program "rsh")
+ (tramp-login-args (("%h") ("-l" "%u")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))))
+ (add-to-list 'tramp-methods
+ '("remsh"
+ (tramp-login-program "remsh")
+ (tramp-login-args (("%h") ("-l" "%u")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))))
+ (add-to-list 'tramp-methods
+ '("ssh"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
+ ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))))
+ (add-to-list 'tramp-methods
+ '("sshx"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
+ ("-e" "none") ("-t" "-t") ("%h") ("/bin/sh")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))))
+ (add-to-list 'tramp-methods
+ '("telnet"
+ (tramp-login-program "telnet")
+ (tramp-login-args (("%h") ("%p") ("2>/dev/null")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))))
+ (add-to-list 'tramp-methods
+ '("nc"
+ (tramp-login-program "telnet")
+ (tramp-login-args (("%h") ("%p") ("2>/dev/null")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))
+ (tramp-copy-program "nc")
+ ;; We use "-v" for better error tracking.
+ (tramp-copy-args (("-w" "1") ("-v") ("%h") ("%r")))
+ (tramp-remote-copy-program "nc")
+ ;; We use "-p" as required for newer busyboxes. For older
+ ;; busybox/nc versions, the value must be (("-l") ("%r")). This
+ ;; can be achieved by tweaking `tramp-connection-properties'.
+ (tramp-remote-copy-args (("-l") ("-p" "%r") ("2>/dev/null")))))
+ (add-to-list 'tramp-methods
+ '("su"
+ (tramp-login-program "su")
+ (tramp-login-args (("-") ("%u")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))
+ (tramp-connection-timeout 10)))
+ (add-to-list 'tramp-methods
+ '("sg"
+ (tramp-login-program "sg")
+ (tramp-login-args (("-") ("%u")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-args ("-c"))
+ (tramp-connection-timeout 10)))
+ (add-to-list 'tramp-methods
+ '("sudo"
+ (tramp-login-program "sudo")
+ ;; The password template must be masked. Otherwise, it could be
+ ;; interpreted as password prompt if the remote host echoes the command.
+ (tramp-login-args (("-u" "%u") ("-s") ("-H")
+ ("-p" "P\"\"a\"\"s\"\"s\"\"w\"\"o\"\"r\"\"d\"\":")))
+ ;; Local $SHELL could be a nasty one, like zsh or fish. Let's override it.
+ (tramp-login-env (("SHELL") ("/bin/sh")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))
+ (tramp-connection-timeout 10)
+ (tramp-session-timeout 300)))
+ (add-to-list 'tramp-methods
+ '("doas"
+ (tramp-login-program "doas")
+ (tramp-login-args (("-u" "%u") ("-s")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-args ("-c"))
+ (tramp-connection-timeout 10)
+ (tramp-session-timeout 300)))
+ (add-to-list 'tramp-methods
+ '("ksu"
+ (tramp-login-program "ksu")
+ (tramp-login-args (("%u") ("-q")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))
+ (tramp-connection-timeout 10)))
+ (add-to-list 'tramp-methods
+ '("krlogin"
+ (tramp-login-program "krlogin")
+ (tramp-login-args (("%h") ("-l" "%u") ("-x")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))))
+ (add-to-list 'tramp-methods
+ `("plink"
+ (tramp-login-program "plink")
+ (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t")
+ ("%h") ("\"")
+ (,(format
+ "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'"
+ tramp-terminal-type
+ tramp-initial-end-of-output))
+ ("/bin/sh") ("\"")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))))
+ (add-to-list 'tramp-methods
+ `("plinkx"
+ (tramp-login-program "plink")
+ (tramp-login-args (("-load") ("%h") ("-t") ("\"")
+ (,(format
+ "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'"
+ tramp-terminal-type
+ tramp-initial-end-of-output))
+ ("/bin/sh") ("\"")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))))
+ (add-to-list 'tramp-methods
+ `("pscp"
+ (tramp-login-program "plink")
+ (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t")
+ ("%h") ("\"")
+ (,(format
+ "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'"
+ tramp-terminal-type
+ tramp-initial-end-of-output))
+ ("/bin/sh") ("\"")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))
+ (tramp-copy-program "pscp")
+ (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-scp") ("-p" "%k")
+ ("-q") ("-r")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-recursive t)))
+ (add-to-list 'tramp-methods
+ `("psftp"
+ (tramp-login-program "plink")
+ (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t")
+ ("%h") ("\"")
+ (,(format
+ "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'"
+ tramp-terminal-type
+ tramp-initial-end-of-output))
+ ("/bin/sh") ("\"")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))
+ (tramp-copy-program "pscp")
+ (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-sftp") ("-p" "%k")
+ ("-q")))
+ (tramp-copy-keep-date t)))
+ (add-to-list 'tramp-methods
+ '("fcp"
+ (tramp-login-program "fsh")
+ (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i")))
+ (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-i") ("-c"))
+ (tramp-copy-program "fcp")
+ (tramp-copy-args (("-p" "%k")))
+ (tramp-copy-keep-date t)))
+
+ (add-to-list 'tramp-default-method-alist
+ `(,tramp-local-host-regexp "\\`root\\'" "su"))
+
+ (add-to-list 'tramp-default-user-alist
+ `(,(concat "\\`" (regexp-opt '("su" "sudo" "doas" "ksu")) "\\'")
+ nil "root"))
+ ;; Do not add "ssh" based methods, otherwise ~/.ssh/config would be ignored.
+ ;; Do not add "plink" based methods, they ask interactively for the user.
+ (add-to-list 'tramp-default-user-alist
+ `(,(concat
+ "\\`"
+ (regexp-opt
+ '("rcp" "remcp" "rsh" "telnet" "nc" "krlogin" "fcp"))
+ "\\'")
+ nil ,(user-login-name))))
;;;###tramp-autoload
(defconst tramp-completion-function-alist-rsh
@@ -459,33 +432,32 @@ The string is used in `tramp-methods'.")
"Default list of (FUNCTION REGISTRY) pairs to be examined for putty sessions.")
;;;###tramp-autoload
-(eval-after-load 'tramp
- '(progn
- (tramp-set-completion-function "rcp" tramp-completion-function-alist-rsh)
- (tramp-set-completion-function "remcp" tramp-completion-function-alist-rsh)
- (tramp-set-completion-function "scp" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function "scpx" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function "rsync" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function "rsh" tramp-completion-function-alist-rsh)
- (tramp-set-completion-function "remsh" tramp-completion-function-alist-rsh)
- (tramp-set-completion-function "ssh" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function "sshx" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function
- "telnet" tramp-completion-function-alist-telnet)
- (tramp-set-completion-function "nc" tramp-completion-function-alist-telnet)
- (tramp-set-completion-function "su" tramp-completion-function-alist-su)
- (tramp-set-completion-function "sudo" tramp-completion-function-alist-su)
- (tramp-set-completion-function "doas" tramp-completion-function-alist-su)
- (tramp-set-completion-function "ksu" tramp-completion-function-alist-su)
- (tramp-set-completion-function "sg" tramp-completion-function-alist-sg)
- (tramp-set-completion-function
- "krlogin" tramp-completion-function-alist-rsh)
- (tramp-set-completion-function "plink" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function
- "plinkx" tramp-completion-function-alist-putty)
- (tramp-set-completion-function "pscp" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function "psftp" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function "fcp" tramp-completion-function-alist-ssh)))
+(tramp--with-startup
+ (tramp-set-completion-function "rcp" tramp-completion-function-alist-rsh)
+ (tramp-set-completion-function "remcp" tramp-completion-function-alist-rsh)
+ (tramp-set-completion-function "scp" tramp-completion-function-alist-ssh)
+ (tramp-set-completion-function "scpx" tramp-completion-function-alist-ssh)
+ (tramp-set-completion-function "rsync" tramp-completion-function-alist-ssh)
+ (tramp-set-completion-function "rsh" tramp-completion-function-alist-rsh)
+ (tramp-set-completion-function "remsh" tramp-completion-function-alist-rsh)
+ (tramp-set-completion-function "ssh" tramp-completion-function-alist-ssh)
+ (tramp-set-completion-function "sshx" tramp-completion-function-alist-ssh)
+ (tramp-set-completion-function
+ "telnet" tramp-completion-function-alist-telnet)
+ (tramp-set-completion-function "nc" tramp-completion-function-alist-telnet)
+ (tramp-set-completion-function "su" tramp-completion-function-alist-su)
+ (tramp-set-completion-function "sudo" tramp-completion-function-alist-su)
+ (tramp-set-completion-function "doas" tramp-completion-function-alist-su)
+ (tramp-set-completion-function "ksu" tramp-completion-function-alist-su)
+ (tramp-set-completion-function "sg" tramp-completion-function-alist-sg)
+ (tramp-set-completion-function
+ "krlogin" tramp-completion-function-alist-rsh)
+ (tramp-set-completion-function "plink" tramp-completion-function-alist-ssh)
+ (tramp-set-completion-function
+ "plinkx" tramp-completion-function-alist-putty)
+ (tramp-set-completion-function "pscp" tramp-completion-function-alist-ssh)
+ (tramp-set-completion-function "psftp" tramp-completion-function-alist-ssh)
+ (tramp-set-completion-function "fcp" tramp-completion-function-alist-ssh))
;; "getconf PATH" yields:
;; HP-UX: /usr/bin:/usr/ccs/bin:/opt/ansic/bin:/opt/langtools/bin:/opt/fortran/bin
@@ -694,7 +666,7 @@ else
$uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\";
$gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\";
printf(
- \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) -1)\\n\",
+ \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u %%u t %%u -1)\\n\",
$type,
$stat[3],
$uid,
@@ -707,8 +679,7 @@ printf(
$stat[10] & 0xffff,
$stat[7],
$stat[2],
- $stat[1] >> 16 & 0xffff,
- $stat[1] & 0xffff
+ $stat[1]
);' \"$1\" \"$2\" 2>/dev/null"
"Perl script to produce output suitable for use with `file-attributes'
on the remote file system.
@@ -945,24 +916,19 @@ od -v -t x1 -A n </dev/null && \
busybox awk '{}' </dev/null"
"Test command for checking `tramp-awk-encode' and `tramp-awk-decode'.")
-(defconst tramp-stat-marker "/////"
- "Marker in stat commands for file attributes.")
-
-(defconst tramp-stat-quoted-marker "\\/\\/\\/\\/\\/"
- "Quoted marker in stat commands for file attributes.")
-
(defconst tramp-vc-registered-read-file-names
"echo \"(\"
while read file; do
+ quoted=`echo \"$file\" | sed -e \"s/\\\"/\\\\\\\\\\\\\\\\\\\"/\"`
if %s \"$file\"; then
- echo \"(\\\"$file\\\" \\\"file-exists-p\\\" t)\"
+ echo \"(\\\"$quoted\\\" \\\"file-exists-p\\\" t)\"
else
- echo \"(\\\"$file\\\" \\\"file-exists-p\\\" nil)\"
+ echo \"(\\\"$quoted\\\" \\\"file-exists-p\\\" nil)\"
fi
if %s \"$file\"; then
- echo \"(\\\"$file\\\" \\\"file-readable-p\\\" t)\"
+ echo \"(\\\"$quoted\\\" \\\"file-readable-p\\\" t)\"
else
- echo \"(\\\"$file\\\" \\\"file-readable-p\\\" nil)\"
+ echo \"(\\\"$quoted\\\" \\\"file-readable-p\\\" nil)\"
fi
done
echo \")\""
@@ -975,7 +941,7 @@ of command line.")
;; New handlers should be added here.
;;;###tramp-autoload
(defconst tramp-sh-file-name-handler-alist
- '(;; `access-file' performed by default handler.
+ '((access-file . tramp-handle-access-file)
(add-name-to-file . tramp-sh-handle-add-name-to-file)
;; `byte-compiler-base-file-name' performed by default handler.
(copy-directory . tramp-sh-handle-copy-directory)
@@ -989,6 +955,7 @@ of command line.")
. tramp-sh-handle-directory-files-and-attributes)
(dired-compress-file . tramp-sh-handle-dired-compress-file)
(dired-uncache . tramp-handle-dired-uncache)
+ (exec-path . tramp-sh-handle-exec-path)
(expand-file-name . tramp-sh-handle-expand-file-name)
(file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
(file-acl . tramp-sh-handle-file-acl)
@@ -1021,7 +988,6 @@ of command line.")
(file-truename . tramp-sh-handle-file-truename)
(file-writable-p . tramp-sh-handle-file-writable-p)
(find-backup-file-name . tramp-handle-find-backup-file-name)
- ;; `find-file-noselect' performed by default handler.
;; `get-file-buffer' performed by default handler.
(insert-directory . tramp-sh-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
@@ -1030,6 +996,7 @@ of command line.")
(make-directory . tramp-sh-handle-make-directory)
;; `make-directory-internal' performed by default handler.
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
+ (make-process . tramp-sh-handle-make-process)
(make-symbolic-link . tramp-sh-handle-make-symbolic-link)
(process-file . tramp-sh-handle-process-file)
(rename-file . tramp-sh-handle-rename-file)
@@ -1039,9 +1006,10 @@ of command line.")
(set-file-times . tramp-sh-handle-set-file-times)
(set-visited-file-modtime . tramp-sh-handle-set-visited-file-modtime)
(shell-command . tramp-handle-shell-command)
- (start-file-process . tramp-sh-handle-start-file-process)
+ (start-file-process . tramp-handle-start-file-process)
(substitute-in-file-name . tramp-handle-substitute-in-file-name)
(temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-set-file-uid-gid . tramp-sh-handle-set-file-uid-gid)
(unhandled-file-name-directory . ignore)
(vc-registered . tramp-sh-handle-vc-registered)
(verify-visited-file-modtime . tramp-sh-handle-verify-visited-file-modtime)
@@ -1059,7 +1027,7 @@ of the symlink. If TARGET is a Tramp file, only the localname
component is used as the target of the symlink."
(if (not (tramp-tramp-file-p (expand-file-name linkname)))
(tramp-run-real-handler
- 'make-symbolic-link (list target linkname ok-if-already-exists))
+ #'make-symbolic-link (list target linkname ok-if-already-exists))
(with-parsed-tramp-file-name linkname nil
;; If TARGET is a Tramp name, use just the localname component.
@@ -1077,7 +1045,7 @@ component is used as the target of the symlink."
(let ((ln (tramp-get-remote-ln v))
(cwd (tramp-run-real-handler
- 'file-name-directory (list localname))))
+ #'file-name-directory (list localname))))
(unless ln
(tramp-error
v 'file-error
@@ -1096,8 +1064,8 @@ component is used as the target of the symlink."
(tramp-error v 'file-already-exists localname)
(delete-file linkname)))
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
;; Right, they are on the same host, regardless of user,
;; method, etc. We now make the link on the remote
@@ -1121,10 +1089,10 @@ component is used as the target of the symlink."
;; Preserve trailing "/".
(funcall
(if (string-equal (file-name-nondirectory filename) "")
- 'file-name-as-directory 'identity)
+ #'file-name-as-directory #'identity)
(with-parsed-tramp-file-name (expand-file-name filename) nil
(tramp-make-tramp-file-name
- method user domain host port
+ v
(with-tramp-file-property v localname "file-truename"
(let ((result nil) ; result steps in reverse order
(quoted (tramp-compat-file-name-quoted-p localname))
@@ -1169,19 +1137,20 @@ component is used as the target of the symlink."
(setq thisstep (pop steps))
(tramp-message
v 5 "Check %s"
- (mapconcat 'identity
+ (mapconcat #'identity
(append '("") (reverse result) (list thisstep))
"/"))
(setq symlink-target
(tramp-compat-file-attribute-type
(file-attributes
(tramp-make-tramp-file-name
- method user domain host port
- (mapconcat 'identity
+ v
+ (mapconcat #'identity
(append '("")
(reverse result)
(list thisstep))
- "/")))))
+ "/")
+ 'nohop))))
(cond ((string= "." thisstep)
(tramp-message v 5 "Ignoring step `.'"))
((string= ".." thisstep)
@@ -1208,7 +1177,7 @@ component is used as the target of the symlink."
;; Combine list to form string.
(setq result
(if result
- (mapconcat 'identity (cons "" result) "/")
+ (mapconcat #'identity (cons "" result) "/")
"/"))
(when (string= "" result)
(setq result "/")))))
@@ -1225,7 +1194,8 @@ component is used as the target of the symlink."
(let (file-name-handler-alist)
(setq result (tramp-compat-file-name-quote result))))
(tramp-message v 4 "True name of `%s' is `%s'" localname result)
- result))))))
+ result))
+ 'nohop))))
;; Basic functions.
@@ -1253,18 +1223,24 @@ component is used as the target of the symlink."
(with-parsed-tramp-file-name (expand-file-name filename) nil
(with-tramp-file-property
v localname (format "file-attributes-%s" id-format)
- (save-excursion
- (tramp-convert-file-attributes
- v
- (or
- (cond
- ((tramp-get-remote-stat v)
- (tramp-do-file-attributes-with-stat v localname id-format))
- ((tramp-get-remote-perl v)
- (tramp-do-file-attributes-with-perl v localname id-format))
- (t nil))
- ;; The scripts could fail, for example with huge file size.
- (tramp-do-file-attributes-with-ls v localname id-format)))))))))
+ (tramp-convert-file-attributes
+ v
+ (or
+ (cond
+ ((tramp-get-remote-stat v)
+ (tramp-do-file-attributes-with-stat v localname id-format))
+ ((tramp-get-remote-perl v)
+ (tramp-do-file-attributes-with-perl v localname id-format))
+ (t nil))
+ ;; The scripts could fail, for example with huge file size.
+ (tramp-do-file-attributes-with-ls v localname id-format))))))))
+
+(defun tramp-sh--quoting-style-options (vec)
+ (or
+ (tramp-get-ls-command-with
+ vec "--quoting-style=literal --show-control-chars")
+ (tramp-get-ls-command-with vec "-w")
+ ""))
(defun tramp-do-file-attributes-with-ls (vec localname &optional id-format)
"Implement `file-attributes' for Tramp files using the ls(1) command."
@@ -1291,12 +1267,7 @@ component is used as the target of the symlink."
(if (eq id-format 'integer) "-ildn" "-ild")
;; On systems which have no quoting style, file names
;; with special characters could fail.
- (cond
- ((tramp-get-ls-command-with-quoting-style vec)
- "--quoting-style=c")
- ((tramp-get-ls-command-with-w-option vec)
- "-w")
- (t ""))
+ (tramp-sh--quoting-style-options vec)
(tramp-shell-quote-argument localname)))
;; Parse `ls -l' output ...
(with-current-buffer (tramp-get-buffer vec)
@@ -1329,7 +1300,7 @@ component is used as the target of the symlink."
(when symlinkp
(search-forward "-> ")
(setq res-symlink-target
- (if (tramp-get-ls-command-with-quoting-style vec)
+ (if (looking-at-p "\"")
(read (current-buffer))
(buffer-substring (point) (point-at-eol)))))
;; Return data gathered.
@@ -1343,13 +1314,10 @@ component is used as the target of the symlink."
res-uid
;; 3. File gid.
res-gid
- ;; 4. Last access time, as a list of integers. Normally
- ;; this would be in the same format as `current-time', but
- ;; the subseconds part is not currently implemented, and
- ;; (0 0) denotes an unknown time.
- ;; 5. Last modification time, likewise.
- ;; 6. Last status change time, likewise.
- '(0 0) '(0 0) '(0 0) ;CCC how to find out?
+ ;; 4. Last access time.
+ ;; 5. Last modification time.
+ ;; 6. Last status change time.
+ tramp-time-dont-know tramp-time-dont-know tramp-time-dont-know
;; 7. Size in bytes (-1, if number is out of range).
res-size
;; 8. File modes, as a string of ten letters or dashes as in ls -l.
@@ -1380,15 +1348,16 @@ component is used as the target of the symlink."
(tramp-send-command-and-read
vec
(format
- (concat
- ;; On Opsware, pdksh (which is the true name of ksh there)
- ;; doesn't parse correctly the sequence "((". Therefore, we add
- ;; a space. Apostrophes in the stat output are masked as
- ;; `tramp-stat-marker', in order to make a proper shell escape of
- ;; them in file names.
- "( (%s %s || %s -h %s) && (%s -c "
- "'((%s%%N%s) %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 %s%%A%s t %%ie0 -1)' "
- "%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g') || echo nil)")
+ (eval-when-compile
+ (concat
+ ;; On Opsware, pdksh (which is the true name of ksh there)
+ ;; doesn't parse correctly the sequence "((". Therefore, we
+ ;; add a space. Apostrophes in the stat output are masked as
+ ;; `tramp-stat-marker', in order to make a proper shell escape
+ ;; of them in file names.
+ "( (%s %s || %s -h %s) && (%s -c "
+ "'((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' "
+ "%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g') || echo nil)"))
(tramp-get-file-exists-command vec)
(tramp-shell-quote-argument localname)
(tramp-get-test-command vec)
@@ -1396,9 +1365,11 @@ component is used as the target of the symlink."
(tramp-get-remote-stat vec)
tramp-stat-marker tramp-stat-marker
(if (eq id-format 'integer)
- "%ue0" (concat tramp-stat-marker "%U" tramp-stat-marker))
+ "%u"
+ (eval-when-compile (concat tramp-stat-marker "%U" tramp-stat-marker)))
(if (eq id-format 'integer)
- "%ge0" (concat tramp-stat-marker "%G" tramp-stat-marker))
+ "%g"
+ (eval-when-compile (concat tramp-stat-marker "%G" tramp-stat-marker)))
tramp-stat-marker tramp-stat-marker
(tramp-shell-quote-argument localname)
tramp-stat-quoted-marker)))
@@ -1409,20 +1380,17 @@ component is used as the target of the symlink."
(error "Can't set-visited-file-modtime: buffer `%s' not visiting a file"
(buffer-name)))
(if time-list
- (tramp-run-real-handler 'set-visited-file-modtime (list time-list))
+ (tramp-run-real-handler #'set-visited-file-modtime (list time-list))
(let ((f (buffer-file-name))
coding-system-used)
(with-parsed-tramp-file-name f nil
(let* ((remote-file-name-inhibit-cache t)
(attr (file-attributes f))
- ;; '(-1 65535) means file doesn't exists yet.
(modtime (or (tramp-compat-file-attribute-modification-time attr)
- '(-1 65535))))
+ tramp-time-doesnt-exist)))
(setq coding-system-used last-coding-system-used)
- ;; We use '(0 0) as a don't-know value. See also
- ;; `tramp-do-file-attributes-with-ls'.
- (if (not (equal modtime '(0 0)))
- (tramp-run-real-handler 'set-visited-file-modtime (list modtime))
+ (if (not (tramp-compat-time-equal-p modtime tramp-time-dont-know))
+ (tramp-run-real-handler #'set-visited-file-modtime (list modtime))
(progn
(tramp-send-command
v
@@ -1450,7 +1418,7 @@ of."
;; recorded last modification time, or there is no established
;; connection.
(if (or (not f)
- (eq (visited-file-modtime) 0)
+ (zerop (float-time (visited-file-modtime)))
(not (file-remote-p f nil 'connected)))
t
(with-parsed-tramp-file-name f nil
@@ -1461,16 +1429,10 @@ of."
(cond
;; File exists, and has a known modtime.
- ((and attr (not (equal modtime '(0 0))))
- (< (abs (tramp-time-diff
- modtime
- ;; For compatibility, deal with both the old
- ;; (HIGH . LOW) and the new (HIGH LOW) return
- ;; values of `visited-file-modtime'.
- (if (atom (cdr mt))
- (list (car mt) (cdr mt))
- mt)))
- 2))
+ ((and attr
+ (not
+ (tramp-compat-time-equal-p modtime tramp-time-dont-know)))
+ (< (abs (tramp-time-diff modtime mt)) 2))
;; Modtime has the don't know value.
(attr
(tramp-send-command
@@ -1486,13 +1448,13 @@ of."
v localname "visited-file-modtime-ild" "")))
;; If file does not exist, say it is not modified if and
;; only if that agrees with the buffer's record.
- (t (equal mt '(-1 65535))))))))))
+ (t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist)))))))))
(defun tramp-sh-handle-set-file-modes (filename mode)
"Like `set-file-modes' for Tramp files."
(with-parsed-tramp-file-name filename nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
;; FIXME: extract the proper text from chmod's stderr.
(tramp-barf-unless-okay
v
@@ -1503,11 +1465,14 @@ of."
"Like `set-file-times' for Tramp files."
(with-parsed-tramp-file-name filename nil
(when (tramp-get-remote-touch v)
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
- (let ((time (if (or (null time) (equal time '(0 0)))
- (current-time)
- time)))
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
+ (let ((time
+ (if (or (null time)
+ (tramp-compat-time-equal-p time tramp-time-doesnt-exist)
+ (tramp-compat-time-equal-p time tramp-time-dont-know))
+ (current-time)
+ time)))
(tramp-send-command-and-check
v (format
"env TZ=UTC %s %s %s"
@@ -1517,39 +1482,26 @@ of."
"")
(tramp-shell-quote-argument localname)))))))
-(defun tramp-set-file-uid-gid (filename &optional uid gid)
- "Set the ownership for FILENAME.
-If UID and GID are provided, these values are used; otherwise uid
-and gid of the corresponding user is taken. Both parameters must
-be non-negative integers."
+(defun tramp-sh-handle-set-file-uid-gid (filename &optional uid gid)
+ "Like `tramp-set-file-uid-gid' for Tramp files."
;; Modern Unices allow chown only for root. So we might need
;; another implementation, see `dired-do-chown'. OTOH, it is mostly
;; working with su(do)? when it is needed, so it shall succeed in
;; the majority of cases.
;; Don't modify `last-coding-system-used' by accident.
(let ((last-coding-system-used last-coding-system-used))
- (if (tramp-tramp-file-p filename)
- (with-parsed-tramp-file-name filename nil
- (if (and (zerop (user-uid)) (tramp-local-host-p v))
- ;; If we are root on the local host, we can do it directly.
- (tramp-set-file-uid-gid localname uid gid)
- (let ((uid (or (and (natnump uid) uid)
- (tramp-get-remote-uid v 'integer)))
- (gid (or (and (natnump gid) gid)
- (tramp-get-remote-gid v 'integer))))
- (tramp-send-command
- v (format
- "chown %d:%d %s" uid gid
- (tramp-shell-quote-argument localname))))))
-
- ;; We handle also the local part, because there doesn't exist
- ;; `set-file-uid-gid'. On W32 "chown" does not work.
- (unless (memq system-type '(ms-dos windows-nt))
- (let ((uid (or (and (natnump uid) uid) (tramp-get-local-uid 'integer)))
- (gid (or (and (natnump gid) gid) (tramp-get-local-gid 'integer))))
- (tramp-call-process
- nil "chown" nil nil nil
- (format "%d:%d" uid gid) (shell-quote-argument filename)))))))
+ (with-parsed-tramp-file-name filename nil
+ (if (and (zerop (user-uid)) (tramp-local-host-p v))
+ ;; If we are root on the local host, we can do it directly.
+ (tramp-set-file-uid-gid localname uid gid)
+ (let ((uid (or (and (natnump uid) uid)
+ (tramp-get-remote-uid v 'integer)))
+ (gid (or (and (natnump gid) gid)
+ (tramp-get-remote-gid v 'integer))))
+ (tramp-send-command
+ v (format
+ "chown %d:%d %s" uid gid
+ (tramp-shell-quote-argument localname))))))))
(defun tramp-remote-selinux-p (vec)
"Check, whether SELINUX is enabled on the remote host."
@@ -1561,8 +1513,9 @@ be non-negative integers."
(with-parsed-tramp-file-name filename nil
(with-tramp-file-property v localname "file-selinux-context"
(let ((context '(nil nil nil nil))
- (regexp (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):"
- "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)")))
+ (regexp (eval-when-compile
+ (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):"
+ "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)"))))
(when (and (tramp-remote-selinux-p v)
(tramp-send-command-and-check
v (format
@@ -1596,8 +1549,7 @@ be non-negative integers."
(if (and user role type range)
(tramp-set-file-property
v localname "file-selinux-context" context)
- (tramp-set-file-property
- v localname "file-selinux-context" 'undef))
+ (tramp-flush-file-property v localname "file-selinux-context"))
t)))))
(defun tramp-remote-acl-p (vec)
@@ -1637,7 +1589,7 @@ be non-negative integers."
(tramp-set-file-property v localname "file-acl" acl-string)
t)
;; In case of errors, we return nil.
- (tramp-set-file-property v localname "file-acl-string" 'undef)
+ (tramp-flush-file-property v localname "file-acl-string")
nil)))
;; Simple functions using the `test' command.
@@ -1667,28 +1619,26 @@ be non-negative integers."
;; something smarter about it.
(defun tramp-sh-handle-file-newer-than-file-p (file1 file2)
"Like `file-newer-than-file-p' for Tramp files."
- (cond ((not (file-exists-p file1))
- nil)
- ((not (file-exists-p file2))
- t)
- ;; We are sure both files exist at this point.
- (t
- (save-excursion
- ;; We try to get the mtime of both files. If they are not
- ;; equal to the "dont-know" value, then we subtract the times
- ;; and obtain the result.
+ (cond ((not (file-exists-p file1)) nil)
+ ((not (file-exists-p file2)) t)
+ (t ;; We are sure both files exist at this point. We try to
+ ;; get the mtime of both files. If they are not equal to
+ ;; the "dont-know" value, then we subtract the times and
+ ;; obtain the result.
(let ((fa1 (file-attributes file1))
(fa2 (file-attributes file2)))
(if (and
(not
- (equal (tramp-compat-file-attribute-modification-time fa1)
- '(0 0)))
+ (tramp-compat-time-equal-p
+ (tramp-compat-file-attribute-modification-time fa1)
+ tramp-time-dont-know))
(not
- (equal (tramp-compat-file-attribute-modification-time fa2)
- '(0 0))))
- (> 0 (tramp-time-diff
- (tramp-compat-file-attribute-modification-time fa2)
- (tramp-compat-file-attribute-modification-time fa1)))
+ (tramp-compat-time-equal-p
+ (tramp-compat-file-attribute-modification-time fa2)
+ tramp-time-dont-know)))
+ (time-less-p
+ (tramp-compat-file-attribute-modification-time fa2)
+ (tramp-compat-file-attribute-modification-time fa1))
;; If one of them is the dont-know value, then we can
;; still try to run a shell command on the remote host.
;; However, this only works if both files are Tramp
@@ -1703,7 +1653,7 @@ be non-negative integers."
file1 file2)))
(with-parsed-tramp-file-name file1 nil
(tramp-run-test2
- (tramp-get-test-nt-command v) file1 file2))))))))
+ (tramp-get-test-nt-command v) file1 file2)))))))
;; Functions implemented using the basic functions above.
@@ -1760,25 +1710,22 @@ be non-negative integers."
(with-tramp-file-property
v localname
(format "directory-files-and-attributes-%s" id-format)
- (save-excursion
- (mapcar
- (lambda (x)
- (cons (car x)
- (tramp-convert-file-attributes v (cdr x))))
- (or
- (cond
- ((tramp-get-remote-stat v)
- (tramp-do-directory-files-and-attributes-with-stat
- v localname id-format))
- ((tramp-get-remote-perl v)
- (tramp-do-directory-files-and-attributes-with-perl
- v localname id-format))
- (t nil)))))))))
+ (mapcar
+ (lambda (x)
+ (cons (car x) (tramp-convert-file-attributes v (cdr x))))
+ (cond
+ ((tramp-get-remote-stat v)
+ (tramp-do-directory-files-and-attributes-with-stat
+ v localname id-format))
+ ((tramp-get-remote-perl v)
+ (tramp-do-directory-files-and-attributes-with-perl
+ v localname id-format))
+ (t nil)))))))
result item)
(while temp
(setq item (pop temp))
- (when (or (null match) (string-match match (car item)))
+ (when (or (null match) (string-match-p match (car item)))
(when full
(setcar item (expand-file-name (car item) directory)))
(push item result)))
@@ -1812,33 +1759,32 @@ be non-negative integers."
(tramp-send-command-and-read
vec
(format
- (concat
- ;; We must care about file names with spaces, or starting with
- ;; "-"; this would confuse xargs. "ls -aQ" might be a solution,
- ;; but it does not work on all remote systems. Apostrophes in
- ;; the stat output are masked as `tramp-stat-marker', in order to
- ;; make a proper shell escape of them in file names.
- "cd %s && echo \"(\"; (%s %s -a | "
- "xargs %s -c "
- "'(%s%%n%s (%s%%N%s) %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 %s%%A%s t %%ie0 -1)' "
- "-- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"")
+ (eval-when-compile
+ (concat
+ ;; We must care about file names with spaces, or starting with
+ ;; "-"; this would confuse xargs. "ls -aQ" might be a
+ ;; solution, but it does not work on all remote systems.
+ ;; Apostrophes in the stat output are masked as
+ ;; `tramp-stat-marker', in order to make a proper shell escape
+ ;; of them in file names.
+ "cd %s && echo \"(\"; (%s %s -a | "
+ "xargs %s -c "
+ "'(%s%%n%s (%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' "
+ "-- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\""))
(tramp-shell-quote-argument localname)
(tramp-get-ls-command vec)
;; On systems which have no quoting style, file names with special
;; characters could fail.
- (cond
- ((tramp-get-ls-command-with-quoting-style vec)
- "--quoting-style=shell")
- ((tramp-get-ls-command-with-w-option vec)
- "-w")
- (t ""))
+ (tramp-sh--quoting-style-options vec)
(tramp-get-remote-stat vec)
tramp-stat-marker tramp-stat-marker
tramp-stat-marker tramp-stat-marker
(if (eq id-format 'integer)
- "%ue0" (concat tramp-stat-marker "%U" tramp-stat-marker))
+ "%u"
+ (eval-when-compile (concat tramp-stat-marker "%U" tramp-stat-marker)))
(if (eq id-format 'integer)
- "%ge0" (concat tramp-stat-marker "%G" tramp-stat-marker))
+ "%g"
+ (eval-when-compile (concat tramp-stat-marker "%G" tramp-stat-marker)))
tramp-stat-marker tramp-stat-marker
tramp-stat-quoted-marker)))
@@ -1846,7 +1792,7 @@ be non-negative integers."
;; files.
(defun tramp-sh-handle-file-name-all-completions (filename directory)
"Like `file-name-all-completions' for Tramp files."
- (unless (save-match-data (string-match "/" filename))
+ (unless (string-match-p "/" filename)
(all-completions
filename
(with-parsed-tramp-file-name (expand-file-name directory) nil
@@ -1865,12 +1811,13 @@ be non-negative integers."
(format "tramp_perl_file_name_all_completions %s"
(tramp-shell-quote-argument localname)))
- (format (concat
- "(cd %s 2>&1 && %s -a 2>/dev/null"
- " | while IFS= read f; do"
- " if %s -d \"$f\" 2>/dev/null;"
- " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done"
- " && \\echo ok) || \\echo fail")
+ (format (eval-when-compile
+ (concat
+ "(cd %s 2>&1 && %s -a 2>/dev/null"
+ " | while IFS= read f; do"
+ " if %s -d \"$f\" 2>/dev/null;"
+ " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done"
+ " && \\echo ok) || \\echo fail"))
(tramp-shell-quote-argument localname)
(tramp-get-ls-command v)
(tramp-get-test-command v))))
@@ -1881,7 +1828,7 @@ be non-negative integers."
;; Check result code, found in last line of output.
(forward-line -1)
- (if (looking-at "^fail$")
+ (if (looking-at-p "^fail$")
(progn
;; Grab error message from line before last line
;; (it was put there by `cd 2>&1').
@@ -1894,7 +1841,7 @@ be non-negative integers."
;; then it should end in `ok'. If neither are in the
;; buffer something went seriously wrong on the remote
;; side.
- (unless (looking-at "^ok$")
+ (unless (looking-at-p "^ok$")
(tramp-error
v 'file-error "\
tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'"
@@ -1931,8 +1878,8 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'"
v2-localname)))))
(tramp-error v2 'file-already-exists newname)
(delete-file newname)))
- (tramp-flush-file-property v2 (file-name-directory v2-localname))
- (tramp-flush-file-property v2 v2-localname)
+ (tramp-flush-file-properties v2 (file-name-directory v2-localname))
+ (tramp-flush-file-properties v2 v2-localname)
(tramp-barf-unless-okay
v1
(format "%s %s %s" ln
@@ -1985,7 +1932,7 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'"
(setq newname
(expand-file-name
(file-name-nondirectory dirname) newname)))
- (when (not (file-directory-p (file-name-directory newname)))
+ (unless (file-directory-p (file-name-directory newname))
(make-directory (file-name-directory newname) parents))
(tramp-do-copy-or-rename-file-out-of-band
'copy dirname newname keep-date))
@@ -1998,8 +1945,8 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'"
;; When newname did exist, we have wrong cached values.
(when t2
(with-parsed-tramp-file-name newname nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname))))))
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname))))))
(defun tramp-sh-handle-rename-file
(filename newname &optional ok-if-already-exists)
@@ -2015,7 +1962,7 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'"
'rename filename newname ok-if-already-exists
'keep-time 'preserve-uid-gid)
(tramp-run-real-handler
- 'rename-file (list filename newname ok-if-already-exists))))
+ #'rename-file (list filename newname ok-if-already-exists))))
(defun tramp-do-copy-or-rename-file
(op filename newname &optional ok-if-already-exists keep-date
@@ -2048,8 +1995,9 @@ file names."
(t2 (tramp-tramp-file-p newname))
(length (tramp-compat-file-attribute-size
(file-attributes (file-truename filename))))
+ ;; `file-extended-attributes' exists since Emacs 24.4.
(attributes (and preserve-extended-attributes
- (apply 'file-extended-attributes (list filename)))))
+ (apply #'file-extended-attributes (list filename)))))
(with-parsed-tramp-file-name (if t1 filename newname) nil
(when (and (not ok-if-already-exists) (file-exists-p newname))
@@ -2119,21 +2067,24 @@ file names."
;; Handle `preserve-extended-attributes'. We ignore possible
;; errors, because ACL strings could be incompatible.
+ ;; `set-file-extended-attributes' exists since Emacs 24.4.
(when attributes
(ignore-errors
- (apply 'set-file-extended-attributes (list newname attributes))))
+ (apply #'set-file-extended-attributes (list newname attributes))))
;; In case of `rename', we must flush the cache of the source file.
(when (and t1 (eq op 'rename))
(with-parsed-tramp-file-name filename v1
- (tramp-flush-file-property v1 (file-name-directory v1-localname))
- (tramp-flush-file-property v1 v1-localname)))
+ (tramp-flush-file-properties
+ v1 (file-name-directory v1-localname))
+ (tramp-flush-file-properties v1 v1-localname)))
;; When newname did exist, we have wrong cached values.
(when t2
(with-parsed-tramp-file-name newname v2
- (tramp-flush-file-property v2 (file-name-directory v2-localname))
- (tramp-flush-file-property v2 v2-localname))))))))
+ (tramp-flush-file-properties
+ v2 (file-name-directory v2-localname))
+ (tramp-flush-file-properties v2 v2-localname))))))))
(defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date)
"Use an Emacs buffer to copy or rename a file.
@@ -2195,8 +2146,8 @@ the uid and gid from FILENAME."
v 'file-error
"Unknown operation `%s', must be `copy' or `rename'"
op))))
- (localname1 (if t1 (file-remote-p filename 'localname) filename))
- (localname2 (if t2 (file-remote-p newname 'localname) newname))
+ (localname1 (tramp-compat-file-local-name filename))
+ (localname2 (tramp-compat-file-local-name newname))
(prefix (file-remote-p (if t1 filename newname)))
cmd-result)
(when (and (eq op 'copy) (file-directory-p filename))
@@ -2234,8 +2185,7 @@ the uid and gid from FILENAME."
(or (eq op 'copy)
(zerop
(logand
- (file-modes (file-name-directory localname1))
- (string-to-number "1000" 8))))
+ (file-modes (file-name-directory localname1)) #o1000)))
(file-writable-p (file-name-directory localname2))
(or (file-directory-p localname2)
(file-writable-p localname2))))
@@ -2244,7 +2194,8 @@ the uid and gid from FILENAME."
localname1 localname2 ok-if-already-exists
keep-date preserve-uid-gid)
(tramp-run-real-handler
- 'rename-file (list localname1 localname2 ok-if-already-exists))))
+ #'rename-file
+ (list localname1 localname2 ok-if-already-exists))))
;; We can do it directly with `tramp-send-command'
((and (file-readable-p (concat prefix localname1))
@@ -2279,8 +2230,7 @@ the uid and gid from FILENAME."
;; We must change the ownership as remote user.
;; Since this does not work reliable, we also
;; give read permissions.
- (set-file-modes
- (concat prefix tmpfile) (string-to-number "0777" 8))
+ (set-file-modes (concat prefix tmpfile) #o0777)
(tramp-set-file-uid-gid
(concat prefix tmpfile)
(tramp-get-local-uid 'integer)
@@ -2290,11 +2240,11 @@ the uid and gid from FILENAME."
(copy-file
localname1 tmpfile t keep-date preserve-uid-gid)
(tramp-run-real-handler
- 'rename-file (list localname1 tmpfile t)))
+ #'rename-file (list localname1 tmpfile t)))
;; We must change the ownership as local user.
;; Since this does not work reliable, we also
;; give read permissions.
- (set-file-modes tmpfile (string-to-number "0777" 8))
+ (set-file-modes tmpfile #o0777)
(tramp-set-file-uid-gid
tmpfile
(tramp-get-remote-uid v 'integer)
@@ -2312,7 +2262,7 @@ the uid and gid from FILENAME."
(tramp-get-buffer v)))
(t1
(tramp-run-real-handler
- 'rename-file
+ #'rename-file
(list tmpfile localname2 ok-if-already-exists)))))
;; Save exit.
@@ -2357,21 +2307,12 @@ The method used must be an out-of-band method."
(expand-file-name ".." tmpfile) 'recursive)
(delete-file tmpfile)))))
- ;; Set variables for computing the prompt for reading password.
- (setq tramp-current-method (tramp-file-name-method v)
- tramp-current-user (or (tramp-file-name-user v)
- (tramp-get-connection-property
- v "login-as" nil))
- tramp-current-domain (tramp-file-name-domain v)
- tramp-current-host (tramp-file-name-host v)
- tramp-current-port (tramp-file-name-port v))
-
;; Check which ones of source and target are Tramp files.
(setq source (funcall
(if (and (file-directory-p filename)
(not (file-exists-p newname)))
- 'file-name-as-directory
- 'identity)
+ #'file-name-as-directory
+ #'identity)
(if t1
(tramp-make-copy-program-file-name v)
(tramp-unquote-shell-quote-argument filename)))
@@ -2425,7 +2366,7 @@ The method used must be an out-of-band method."
(mapcar
(lambda (x)
(setq x (mapcar (lambda (y) (format-spec y spec)) x))
- (unless (member "" x) (mapconcat 'identity x " ")))
+ (unless (member "" x) (mapconcat #'identity x " ")))
(tramp-get-method-parameter v 'tramp-copy-env)))
remote-copy-program
@@ -2455,7 +2396,7 @@ The method used must be an out-of-band method."
"Cannot find remote listener: %s" remote-copy-program))
(setq remote-copy-program
(mapconcat
- 'identity
+ #'identity
(append
(list remote-copy-program) remote-copy-args
(list (if t1 (concat "<" source) (concat ">" target)) "&"))
@@ -2501,7 +2442,7 @@ The method used must be an out-of-band method."
;; copying of large files can last longer than 60 secs.
(let* ((command
(mapconcat
- 'identity (append (list copy-program) copy-args)
+ #'identity (append (list copy-program) copy-args)
" "))
(p (let ((default-directory
(tramp-compat-temporary-file-directory)))
@@ -2510,8 +2451,8 @@ The method used must be an out-of-band method."
(tramp-get-connection-buffer v)
command))))
(tramp-message orig-vec 6 "%s" command)
- (tramp-set-connection-property p "vector" orig-vec)
- (process-put p 'adjust-window-size-function 'ignore)
+ (process-put p 'vector orig-vec)
+ (process-put p 'adjust-window-size-function #'ignore)
(set-process-query-on-exit-flag p nil)
;; We must adapt `tramp-local-end-of-line' for
@@ -2521,8 +2462,8 @@ The method used must be an out-of-band method."
p v nil tramp-actions-copy-out-of-band))))
;; Reset the transfer process properties.
- (tramp-set-connection-property v "process-name" nil)
- (tramp-set-connection-property v "process-buffer" nil)
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer")
;; Clear the remote prompt.
(when (and remote-copy-program
(not (tramp-send-command-and-check v nil)))
@@ -2553,20 +2494,23 @@ The method used must be an out-of-band method."
"Like `make-directory' for Tramp files."
(setq dir (expand-file-name dir))
(with-parsed-tramp-file-name dir nil
- (tramp-flush-directory-property v (file-name-directory localname))
- (save-excursion
- (tramp-barf-unless-okay
- v (format "%s %s"
- (if parents "mkdir -p" "mkdir")
- (tramp-shell-quote-argument localname))
- "Couldn't make directory %s" dir))))
+ ;; When PARENTS is non-nil, DIR could be a chain of non-existent
+ ;; directories a/b/c/... Instead of checking, we simply flush the
+ ;; whole cache.
+ (tramp-flush-directory-properties
+ v (if parents "/" (file-name-directory localname)))
+ (tramp-barf-unless-okay
+ v (format "%s %s"
+ (if parents "mkdir -p" "mkdir")
+ (tramp-shell-quote-argument localname))
+ "Couldn't make directory %s" dir)))
(defun tramp-sh-handle-delete-directory (directory &optional recursive trash)
"Like `delete-directory' for Tramp files."
(setq directory (expand-file-name directory))
(with-parsed-tramp-file-name directory nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-directory-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-directory-properties v localname)
(tramp-barf-unless-okay
v (format "cd / && %s %s"
(or (and trash (tramp-get-remote-trash v))
@@ -2578,8 +2522,8 @@ The method used must be an out-of-band method."
"Like `delete-file' for Tramp files."
(setq filename (expand-file-name filename))
(with-parsed-tramp-file-name filename nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
(tramp-barf-unless-okay
v (format "%s %s"
(or (and trash (tramp-get-remote-trash v)) "rm -f")
@@ -2592,48 +2536,49 @@ The method used must be an out-of-band method."
"Like `dired-compress-file' for Tramp files."
;; Code stolen mainly from dired-aux.el.
(with-parsed-tramp-file-name file nil
- (tramp-flush-file-property v localname)
- (save-excursion
- (let ((suffixes dired-compress-file-suffixes)
- suffix)
- ;; See if any suffix rule matches this file name.
- (while suffixes
- (let (case-fold-search)
- (if (string-match (car (car suffixes)) localname)
- (setq suffix (car suffixes) suffixes nil))
- (setq suffixes (cdr suffixes))))
-
- (cond ((file-symlink-p file)
- nil)
- ((and suffix (nth 2 suffix))
- ;; We found an uncompression rule.
- (with-tramp-progress-reporter
- v 0 (format "Uncompressing %s" file)
- (when (tramp-send-command-and-check
- v (concat (nth 2 suffix) " "
- (tramp-shell-quote-argument localname)))
- (dired-remove-file file)
- (string-match (car suffix) file)
- (concat (substring file 0 (match-beginning 0))))))
- (t
- ;; We don't recognize the file as compressed, so compress it.
- ;; Try gzip.
- (with-tramp-progress-reporter v 0 (format "Compressing %s" file)
- (when (tramp-send-command-and-check
- v (concat "gzip -f "
- (tramp-shell-quote-argument localname)))
- (dired-remove-file file)
- (cond ((file-exists-p (concat file ".gz"))
- (concat file ".gz"))
- ((file-exists-p (concat file ".z"))
- (concat file ".z"))
- (t nil))))))))))
+ (tramp-flush-file-properties v localname)
+ (let ((suffixes dired-compress-file-suffixes)
+ suffix)
+ ;; See if any suffix rule matches this file name.
+ (while suffixes
+ (let (case-fold-search)
+ (if (string-match-p (car (car suffixes)) localname)
+ (setq suffix (car suffixes) suffixes nil))
+ (setq suffixes (cdr suffixes))))
+
+ (cond ((file-symlink-p file) nil)
+ ((and suffix (nth 2 suffix))
+ ;; We found an uncompression rule.
+ (with-tramp-progress-reporter
+ v 0 (format "Uncompressing %s" file)
+ (when (tramp-send-command-and-check
+ v (concat (nth 2 suffix) " "
+ (tramp-shell-quote-argument localname)))
+ (dired-remove-file file)
+ (string-match (car suffix) file)
+ (concat (substring file 0 (match-beginning 0))))))
+ (t
+ ;; We don't recognize the file as compressed, so compress it.
+ ;; Try gzip.
+ (with-tramp-progress-reporter v 0 (format "Compressing %s" file)
+ (when (tramp-send-command-and-check
+ v (concat "gzip -f "
+ (tramp-shell-quote-argument localname)))
+ (dired-remove-file file)
+ (cond ((file-exists-p (concat file ".gz"))
+ (concat file ".gz"))
+ ((file-exists-p (concat file ".z"))
+ (concat file ".z"))
+ (t nil)))))))))
(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
(if (and (featurep 'ls-lisp)
(not (symbol-value 'ls-lisp-use-insert-directory-program)))
@@ -2641,19 +2586,21 @@ 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-quoting-style v)
- (setq switches (append switches '("--quoting-style=literal"))))
- (when (and (member "--dired" switches)
- (not (tramp-get-ls-command-with-dired v)))
+ (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"))))
+ (unless (tramp-get-ls-command-with v "--dired")
(setq switches (delete "--dired" switches)))
(when wildcard
(setq wildcard (tramp-run-real-handler
- 'file-name-nondirectory (list localname)))
+ #'file-name-nondirectory (list localname)))
(setq localname (tramp-run-real-handler
- 'file-name-directory (list localname))))
+ #'file-name-directory (list localname))))
(unless (or full-directory-p (member "-d" switches))
(setq switches (append switches '("-d"))))
- (setq switches (mapconcat 'tramp-shell-quote-argument switches " "))
+ (setq switches (mapconcat #'tramp-shell-quote-argument switches " "))
(when wildcard
(setq switches (concat switches " " wildcard)))
(tramp-message
@@ -2675,10 +2622,10 @@ The method used must be an out-of-band method."
v
(format "cd %s" (tramp-shell-quote-argument
(tramp-run-real-handler
- 'file-name-directory (list localname))))
+ #'file-name-directory (list localname))))
"Couldn't `cd %s'"
(tramp-shell-quote-argument
- (tramp-run-real-handler 'file-name-directory (list localname))))
+ (tramp-run-real-handler #'file-name-directory (list localname))))
(tramp-send-command
v
(format "%s %s %s 2>/dev/null"
@@ -2687,11 +2634,11 @@ The method used must be an out-of-band method."
(if (or wildcard
(zerop (length
(tramp-run-real-handler
- 'file-name-nondirectory (list localname)))))
+ #'file-name-nondirectory (list localname)))))
""
(tramp-shell-quote-argument
(tramp-run-real-handler
- 'file-name-nondirectory (list localname)))))))
+ #'file-name-nondirectory (list localname)))))))
(save-restriction
(let ((beg (point)))
@@ -2705,7 +2652,7 @@ The method used must be an out-of-band method."
;; Check for "--dired" output.
(forward-line -2)
- (when (looking-at "//SUBDIRED//")
+ (when (looking-at-p "//SUBDIRED//")
(forward-line -1))
(when (looking-at "//DIRED//\\s-+")
(let ((databeg (match-end 0))
@@ -2726,7 +2673,7 @@ The method used must be an out-of-band method."
;; Some busyboxes are reluctant to discard colors.
(unless
- (string-match "color" (tramp-get-connection-property v "ls" ""))
+ (string-match-p "color" (tramp-get-connection-property v "ls" ""))
(goto-char beg)
(while
(re-search-forward tramp-display-escape-sequence-regexp nil t)
@@ -2770,15 +2717,17 @@ If the localname part of the given file name starts with \"/../\" then
the result will be a local, non-Tramp, file name."
;; If DIR is not given, use `default-directory' or "/".
(setq dir (or dir default-directory "/"))
+ ;; Handle empty NAME.
+ (when (zerop (length name)) (setq name "."))
;; Unless NAME is absolute, concat DIR and NAME.
(unless (file-name-absolute-p name)
(setq name (concat (file-name-as-directory dir) name)))
;; If connection is not established yet, run the real handler.
(if (not (tramp-connectable-p name))
- (tramp-run-real-handler 'expand-file-name (list name nil))
+ (tramp-run-real-handler #'expand-file-name (list name nil))
;; Dissect NAME.
(with-parsed-tramp-file-name name nil
- (unless (tramp-run-real-handler 'file-name-absolute-p (list localname))
+ (unless (tramp-run-real-handler #'file-name-absolute-p (list localname))
(setq localname (concat "~/" localname)))
;; Tilde expansion if necessary. This needs a shell which
;; groks tilde expansion! The function `tramp-find-shell' is
@@ -2794,7 +2743,7 @@ the result will be a local, non-Tramp, file name."
;; appropriate either, because ssh and companions might
;; use a user name from the config file.
(when (and (string-equal uname "~")
- (string-match "\\`su\\(do\\)?\\'" method))
+ (string-match-p "\\`su\\(do\\)?\\'" method))
(setq uname (concat uname user)))
(setq uname
(with-tramp-connection-property v uname
@@ -2814,165 +2763,210 @@ the result will be a local, non-Tramp, file name."
;; be problems with UNC shares or Cygwin mounts.
(let ((default-directory (tramp-compat-temporary-file-directory)))
(tramp-make-tramp-file-name
- method user domain host port
- (tramp-drop-volume-letter
- (tramp-run-real-handler
- 'expand-file-name (list localname)))
- hop)))))
+ v (tramp-drop-volume-letter
+ (tramp-run-real-handler
+ #'expand-file-name (list localname))))))))
;;; Remote commands:
-(defun tramp-process-sentinel (proc event)
- "Flush file caches."
- (unless (process-live-p proc)
- (let ((vec (tramp-get-connection-property proc "vector" nil)))
- (when vec
- (tramp-message vec 5 "Sentinel called: `%S' `%s'" proc event)
- (tramp-flush-connection-property proc)
- (tramp-flush-directory-property vec "")))))
-
;; We use BUFFER also as connection buffer during setup. Because of
;; this, its original contents must be saved, and restored once
;; connection has been setup.
-(defun tramp-sh-handle-start-file-process (name buffer program &rest args)
- "Like `start-file-process' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name default-directory) nil
- (let* ((buffer
- (if buffer
- (get-buffer-create buffer)
- ;; BUFFER can be nil. We use a temporary buffer.
- (generate-new-buffer tramp-temp-buffer-name)))
- ;; When PROGRAM matches "*sh", and the first arg is "-c",
- ;; it might be that the arguments exceed the command line
- ;; length. Therefore, we modify the command.
- (heredoc (and (stringp program)
- (string-match "sh$" program)
- (string-equal "-c" (car args))
- (= (length args) 2)))
- ;; When PROGRAM is nil, we just provide a tty.
- (args (if (not heredoc) args
- (let ((i 250))
- (while (and (< i (length (cadr args)))
- (string-match " " (cadr args) i))
- (setcdr
- args
- (list (replace-match " \\\\\n" nil nil (cadr args))))
- (setq i (+ i 250))))
- (cdr args)))
- ;; Use a human-friendly prompt, for example for `shell'.
- ;; We discard hops, if existing, that's why we cannot use
- ;; `file-remote-p'.
- (prompt (format "PS1=%s %s"
- (tramp-make-tramp-file-name
- (tramp-file-name-method v)
- (tramp-file-name-user v)
- (tramp-file-name-domain v)
- (tramp-file-name-host v)
- (tramp-file-name-port v)
- (tramp-file-name-localname v))
- tramp-initial-end-of-output))
- ;; We use as environment the difference to toplevel
- ;; `process-environment'.
- env uenv
- (env (dolist (elt (cons prompt process-environment) env)
- (or (member elt (default-toplevel-value 'process-environment))
- (if (string-match "=" elt)
- (setq env (append env `(,elt)))
- (if (tramp-get-env-with-u-option v)
- (setq env (append `("-u" ,elt) env))
- (setq uenv (cons elt uenv)))))))
- (command
- (when (stringp program)
- (format "cd %s && %s exec %s env %s %s"
- (tramp-shell-quote-argument localname)
- (if uenv
- (format
- "unset %s &&"
- (mapconcat 'tramp-shell-quote-argument uenv " "))
- "")
- (if heredoc (format "<<'%s'" tramp-end-of-heredoc) "")
- (mapconcat 'tramp-shell-quote-argument env " ")
- (if heredoc
- (format "%s\n(\n%s\n) </dev/tty\n%s"
- program (car args) tramp-end-of-heredoc)
- (mapconcat 'tramp-shell-quote-argument
- (cons program args) " ")))))
- (tramp-process-connection-type
- (or (null program) tramp-process-connection-type))
- (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer)))
- (name1 name)
- (i 0)
- ;; We do not want to raise an error when
- ;; `start-file-process' has been started several times in
- ;; `eshell' and friends.
- tramp-current-connection
- ;; We do not want to run timers.
- timer-list timer-idle-list
- p)
-
- (while (get-process name1)
- ;; NAME must be unique as process name.
- (setq i (1+ i)
- name1 (format "%s<%d>" name i)))
- (setq name name1)
- ;; Set the new process properties.
- (tramp-set-connection-property v "process-name" name)
- (tramp-set-connection-property v "process-buffer" buffer)
-
- (with-current-buffer (tramp-get-connection-buffer v)
- (unwind-protect
- ;; We catch this event. Otherwise, `start-process' could
- ;; be called on the local host.
- (save-excursion
- (save-restriction
- ;; Activate narrowing in order to save BUFFER
- ;; contents. Clear also the modification time;
- ;; otherwise we might be interrupted by
- ;; `verify-visited-file-modtime'.
- (let ((buffer-undo-list t)
- (buffer-read-only nil)
- (mark (point-max)))
- (clear-visited-file-modtime)
- (narrow-to-region (point-max) (point-max))
- ;; We call `tramp-maybe-open-connection', in order
- ;; to cleanup the prompt afterwards.
- (catch 'suppress
- (tramp-maybe-open-connection v)
- (setq p (tramp-get-connection-process v))
- ;; Set the pid of the remote shell. This is
- ;; needed when sending signals remotely.
- (let ((pid (tramp-send-command-and-read v "echo $$")))
- (process-put p 'remote-pid pid)
- (tramp-set-connection-property p "remote-pid" pid))
- (widen)
- (delete-region mark (point-max))
- (narrow-to-region (point-max) (point-max))
- ;; Now do it.
- (if command
- ;; Send the command.
- (tramp-send-command v command nil t) ; nooutput
- ;; Check, whether a pty is associated.
- (unless (process-get p 'remote-tty)
- (tramp-error
- v 'file-error
- "pty association is not supported for `%s'" name))))
- ;; Set query flag and process marker for this
- ;; process. We ignore errors, because the process
- ;; could have finished already.
- (ignore-errors
- (set-process-query-on-exit-flag p t)
- (set-marker (process-mark p) (point)))
- ;; Return process.
- p)))
+(defun tramp-sh-handle-make-process (&rest args)
+ "Like `make-process' for Tramp files."
+ (when args
+ (with-parsed-tramp-file-name (expand-file-name default-directory) nil
+ (let ((name (plist-get args :name))
+ (buffer (plist-get args :buffer))
+ (command (plist-get args :command))
+ (coding (plist-get args :coding))
+ (noquery (plist-get args :noquery))
+ (stop (plist-get args :stop))
+ (connection-type (plist-get args :connection-type))
+ (filter (plist-get args :filter))
+ (sentinel (plist-get args :sentinel))
+ (stderr (plist-get args :stderr)))
+ (unless (stringp name)
+ (signal 'wrong-type-argument (list #'stringp name)))
+ (unless (or (null buffer) (bufferp buffer) (stringp buffer))
+ (signal 'wrong-type-argument (list #'stringp buffer)))
+ (unless (consp command)
+ (signal 'wrong-type-argument (list #'consp command)))
+ (unless (or (null coding)
+ (and (symbolp coding) (memq coding coding-system-list))
+ (and (consp coding)
+ (memq (car coding) coding-system-list)
+ (memq (cdr coding) coding-system-list)))
+ (signal 'wrong-type-argument (list #'symbolp coding)))
+ (unless (or (null connection-type) (memq connection-type '(pipe pty)))
+ (signal 'wrong-type-argument (list #'symbolp connection-type)))
+ (unless (or (null filter) (functionp filter))
+ (signal 'wrong-type-argument (list #'functionp filter)))
+ (unless (or (null sentinel) (functionp sentinel))
+ (signal 'wrong-type-argument (list #'functionp sentinel)))
+ (unless (or (null stderr) (bufferp stderr) (stringp stderr))
+ (signal 'wrong-type-argument (list #'stringp stderr)))
+
+ (let* ((buffer
+ (if buffer
+ (get-buffer-create buffer)
+ ;; BUFFER can be nil. We use a temporary buffer.
+ (generate-new-buffer tramp-temp-buffer-name)))
+ (stderr (and stderr (get-buffer-create stderr)))
+ (tmpstderr (and stderr (tramp-make-tramp-temp-file v)))
+ (program (car command))
+ (args (cdr command))
+ ;; When PROGRAM matches "*sh", and the first arg is
+ ;; "-c", it might be that the arguments exceed the
+ ;; command line length. Therefore, we modify the
+ ;; command.
+ (heredoc (and (stringp program)
+ (string-match-p "sh$" program)
+ (string-equal "-c" (car args))
+ (= (length args) 2)))
+ ;; When PROGRAM is nil, we just provide a tty.
+ (args (if (not heredoc) args
+ (let ((i 250))
+ (while (and (< i (length (cadr args)))
+ (string-match " " (cadr args) i))
+ (setcdr
+ args
+ (list
+ (replace-match " \\\\\n" nil nil (cadr args))))
+ (setq i (+ i 250))))
+ (cdr args)))
+ ;; Use a human-friendly prompt, for example for
+ ;; `shell'. We discard hops, if existing, that's why
+ ;; we cannot use `file-remote-p'.
+ (prompt (format "PS1=%s %s"
+ (tramp-make-tramp-file-name v nil 'nohop)
+ tramp-initial-end-of-output))
+ ;; We use as environment the difference to toplevel
+ ;; `process-environment'.
+ env uenv
+ (env (dolist (elt (cons prompt process-environment) env)
+ (or (member
+ elt (default-toplevel-value 'process-environment))
+ (if (string-match-p "=" elt)
+ (setq env (append env `(,elt)))
+ (if (tramp-get-env-with-u-option v)
+ (setq env (append `("-u" ,elt) env))
+ (setq uenv (cons elt uenv)))))))
+ (command
+ (when (stringp program)
+ (format "cd %s && %s exec %s %s env %s %s"
+ (tramp-shell-quote-argument localname)
+ (if uenv
+ (format
+ "unset %s &&"
+ (mapconcat
+ #'tramp-shell-quote-argument uenv " "))
+ "")
+ (if heredoc (format "<<'%s'" tramp-end-of-heredoc) "")
+ (if tmpstderr (format "2>'%s'" tmpstderr) "")
+ (mapconcat #'tramp-shell-quote-argument env " ")
+ (if heredoc
+ (format "%s\n(\n%s\n) </dev/tty\n%s"
+ program (car args) tramp-end-of-heredoc)
+ (mapconcat #'tramp-shell-quote-argument
+ (cons program args) " ")))))
+ (tramp-process-connection-type
+ (or (null program) tramp-process-connection-type))
+ (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer)))
+ (name1 name)
+ (i 0)
+ ;; We do not want to raise an error when `make-process'
+ ;; has been started several times in `eshell' and
+ ;; friends.
+ tramp-current-connection
+ ;; We do not want to run timers.
+ timer-list timer-idle-list
+ p)
+
+ (while (get-process name1)
+ ;; NAME must be unique as process name.
+ (setq i (1+ i)
+ name1 (format "%s<%d>" name i)))
+ (setq name name1)
+ ;; Set the new process properties.
+ (tramp-set-connection-property v "process-name" name)
+ (tramp-set-connection-property v "process-buffer" buffer)
- ;; Save exit.
- (if (string-match tramp-temp-buffer-name (buffer-name))
- (ignore-errors
- (set-process-buffer p nil)
- (kill-buffer (current-buffer)))
- (set-buffer-modified-p bmp))
- (tramp-set-connection-property v "process-name" nil)
- (tramp-set-connection-property v "process-buffer" nil))))))
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (unwind-protect
+ ;; We catch this event. Otherwise, `make-process' could
+ ;; be called on the local host.
+ (save-excursion
+ (save-restriction
+ ;; Activate narrowing in order to save BUFFER
+ ;; contents. Clear also the modification time;
+ ;; otherwise we might be interrupted by
+ ;; `verify-visited-file-modtime'.
+ (let ((buffer-undo-list t)
+ (inhibit-read-only t))
+ (clear-visited-file-modtime)
+ (narrow-to-region (point-max) (point-max))
+ ;; We call `tramp-maybe-open-connection', in
+ ;; order to cleanup the prompt afterwards.
+ (catch 'suppress
+ (tramp-maybe-open-connection v)
+ (setq p (tramp-get-connection-process v))
+ ;; Set the pid of the remote shell. This is
+ ;; needed when sending signals remotely.
+ (let ((pid (tramp-send-command-and-read v "echo $$")))
+ (process-put p 'remote-pid pid)
+ (tramp-set-connection-property p "remote-pid" pid))
+ (delete-region (point-min) (point-max))
+ ;; Now do it.
+ (if command
+ ;; Send the command.
+ (tramp-send-command v command nil t) ; nooutput
+ ;; Check, whether a pty is associated.
+ (unless (process-get p 'remote-tty)
+ (tramp-error
+ v 'file-error
+ "pty association is not supported for `%s'"
+ name))))
+ ;; Stop process if indicated.
+ (when stop
+ (stop-process p))
+ ;; Set sentinel and filter.
+ (when sentinel
+ (set-process-sentinel p sentinel))
+ (when filter
+ (set-process-filter p filter))
+ ;; Set query flag and process marker for this
+ ;; process. We ignore errors, because the
+ ;; process could have finished already.
+ (ignore-errors
+ (set-process-query-on-exit-flag p (null noquery))
+ (set-marker (process-mark p) (point)))
+ ;; Provide error buffer. This shows only
+ ;; initial error messages; messages arriving
+ ;; later on shall be inserted by `auto-revert'.
+ ;; The temporary file will still be existing.
+ ;; TODO: Write a sentinel, which deletes the
+ ;; temporary file.
+ (when tmpstderr
+ ;; We must flush them here already; otherwise
+ ;; `insert-file-contents' will fail.
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer")
+ (with-current-buffer stderr
+ (insert-file-contents
+ (tramp-make-tramp-file-name v tmpstderr) 'visit)
+ (auto-revert-mode)))
+ ;; Return process.
+ p)))
+
+ ;; Save exit.
+ (if (string-match-p tramp-temp-buffer-name (buffer-name))
+ (ignore-errors
+ (set-process-buffer p nil)
+ (kill-buffer (current-buffer)))
+ (set-buffer-modified-p bmp))
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer"))))))))
(defun tramp-sh-handle-process-file
(program &optional infile destination display &rest args)
@@ -2984,12 +2978,12 @@ the result will be a local, non-Tramp, file name."
(with-parsed-tramp-file-name default-directory nil
(let (command env uenv input tmpinput stderr tmpstderr outbuf ret)
;; Compute command.
- (setq command (mapconcat 'tramp-shell-quote-argument
+ (setq command (mapconcat #'tramp-shell-quote-argument
(cons program args) " "))
;; We use as environment the difference to toplevel `process-environment'.
(dolist (elt process-environment)
(or (member elt (default-toplevel-value 'process-environment))
- (if (string-match "=" elt)
+ (if (string-match-p "=" elt)
(setq env (append env `(,elt)))
(if (tramp-get-env-with-u-option v)
(setq env (append `("-u" ,elt) env))
@@ -2998,12 +2992,12 @@ the result will be a local, non-Tramp, file name."
(setq command
(format
"env %s %s"
- (mapconcat 'tramp-shell-quote-argument env " ") command)))
+ (mapconcat #'tramp-shell-quote-argument env " ") command)))
(when uenv
(setq command
(format
"unset %s && %s"
- (mapconcat 'tramp-shell-quote-argument uenv " ") command)))
+ (mapconcat #'tramp-shell-quote-argument uenv " ") command)))
;; Determine input.
(if (null infile)
(setq input "/dev/null")
@@ -3013,8 +3007,7 @@ the result will be a local, non-Tramp, file name."
(setq input (with-parsed-tramp-file-name infile nil localname))
;; INFILE must be copied to remote host.
(setq input (tramp-make-tramp-temp-file v)
- tmpinput
- (tramp-make-tramp-file-name method user domain host port input))
+ tmpinput (tramp-make-tramp-file-name v input 'nohop))
(copy-file infile tmpinput t)))
(when input (setq command (format "%s <%s" command input)))
@@ -3047,8 +3040,7 @@ the result will be a local, non-Tramp, file name."
;; stderr must be copied to remote host. The temporary
;; file must be deleted after execution.
(setq stderr (tramp-make-tramp-temp-file v)
- tmpstderr (tramp-make-tramp-file-name
- method user domain host port stderr))))
+ tmpstderr (tramp-make-tramp-file-name v stderr 'nohop))))
;; stderr to be discarded.
((null (cadr destination))
(setq stderr "/dev/null"))))
@@ -3094,13 +3086,20 @@ the result will be a local, non-Tramp, file name."
(when tmpinput (delete-file tmpinput))
(unless process-file-side-effects
- (tramp-flush-directory-property v ""))
+ (tramp-flush-directory-properties v ""))
;; Return exit status.
(if (equal ret -1)
(keyboard-quit)
ret))))
+(defun tramp-sh-handle-exec-path ()
+ "Like `exec-path' for Tramp files."
+ (append
+ (tramp-get-remote-path (tramp-dissect-file-name default-directory))
+ ;; The equivalent to `exec-directory'.
+ `(,(tramp-compat-file-local-name default-directory))))
+
(defun tramp-sh-handle-file-local-copy (filename)
"Like `file-local-copy' for Tramp files."
(with-parsed-tramp-file-name filename nil
@@ -3124,50 +3123,49 @@ the result will be a local, non-Tramp, file name."
;; Use inline encoding for file transfer.
(rem-enc
- (save-excursion
- (with-tramp-progress-reporter
- v 3
- (format-message "Encoding remote file `%s' with `%s'"
- filename rem-enc)
- (tramp-barf-unless-okay
- v (format rem-enc (tramp-shell-quote-argument localname))
- "Encoding remote file failed"))
-
- (with-tramp-progress-reporter
- v 3 (format-message "Decoding local file `%s' with `%s'"
- tmpfile loc-dec)
- (if (functionp loc-dec)
- ;; If local decoding is a function, we call it.
- ;; We must disable multibyte, because
- ;; `uudecode-decode-region' doesn't handle it
- ;; correctly. Unset `file-name-handler-alist'.
- ;; Otherwise, epa-file gets confused.
- (let (file-name-handler-alist
- (coding-system-for-write 'binary))
- (with-temp-file tmpfile
- (set-buffer-multibyte nil)
- (insert-buffer-substring (tramp-get-buffer v))
- (funcall loc-dec (point-min) (point-max))))
-
- ;; If tramp-decoding-function is not defined for this
- ;; method, we invoke tramp-decoding-command instead.
- (let ((tmpfile2 (tramp-compat-make-temp-file filename)))
- ;; Unset `file-name-handler-alist'. Otherwise,
- ;; epa-file gets confused.
- (let (file-name-handler-alist
- (coding-system-for-write 'binary))
- (with-current-buffer (tramp-get-buffer v)
- (write-region
- (point-min) (point-max) tmpfile2 nil 'no-message)))
- (unwind-protect
- (tramp-call-local-coding-command
- loc-dec tmpfile2 tmpfile)
- (delete-file tmpfile2)))))
-
- ;; Set proper permissions.
- (set-file-modes tmpfile (tramp-default-file-modes filename))
- ;; Set local user ownership.
- (tramp-set-file-uid-gid tmpfile)))
+ (with-tramp-progress-reporter
+ v 3
+ (format-message
+ "Encoding remote file `%s' with `%s'" filename rem-enc)
+ (tramp-barf-unless-okay
+ v (format rem-enc (tramp-shell-quote-argument localname))
+ "Encoding remote file failed"))
+
+ (with-tramp-progress-reporter
+ v 3 (format-message
+ "Decoding local file `%s' with `%s'" tmpfile loc-dec)
+ (if (functionp loc-dec)
+ ;; If local decoding is a function, we call it. We
+ ;; must disable multibyte, because
+ ;; `uudecode-decode-region' doesn't handle it
+ ;; correctly. Unset `file-name-handler-alist'.
+ ;; Otherwise, epa-file gets confused.
+ (let (file-name-handler-alist
+ (coding-system-for-write 'binary))
+ (with-temp-file tmpfile
+ (set-buffer-multibyte nil)
+ (insert-buffer-substring (tramp-get-buffer v))
+ (funcall loc-dec (point-min) (point-max))))
+
+ ;; If tramp-decoding-function is not defined for this
+ ;; method, we invoke tramp-decoding-command instead.
+ (let ((tmpfile2 (tramp-compat-make-temp-file filename)))
+ ;; Unset `file-name-handler-alist'. Otherwise,
+ ;; epa-file gets confused.
+ (let (file-name-handler-alist
+ (coding-system-for-write 'binary))
+ (with-current-buffer (tramp-get-buffer v)
+ (write-region
+ (point-min) (point-max) tmpfile2 nil 'no-message)))
+ (unwind-protect
+ (tramp-call-local-coding-command
+ loc-dec tmpfile2 tmpfile)
+ (delete-file tmpfile2)))))
+
+ ;; Set proper permissions.
+ (set-file-modes tmpfile (tramp-default-file-modes filename))
+ ;; Set local user ownership.
+ (tramp-set-file-uid-gid tmpfile))
;; Oops, I don't know what to do.
(t (tramp-error
@@ -3211,7 +3209,8 @@ the result will be a local, non-Tramp, file name."
(file-writable-p localname)))))
;; Short track: if we are on the local host, we can run directly.
(tramp-run-real-handler
- 'write-region (list start end localname append 'no-message lockname))
+ #'write-region
+ (list start end localname append 'no-message lockname))
(let* ((modes (save-excursion (tramp-default-file-modes filename)))
;; We use this to save the value of
@@ -3247,7 +3246,7 @@ the result will be a local, non-Tramp, file name."
(tramp-find-file-name-coding-system-alist filename tmpfile)))
(condition-case err
(tramp-run-real-handler
- 'write-region
+ #'write-region
(list start end tmpfile append 'no-message lockname))
((error quit)
(setq tramp-temp-buffer-file-name nil)
@@ -3263,9 +3262,7 @@ the result will be a local, non-Tramp, file name."
;; handles permissions.
;; Ensure that it is still readable.
(when modes
- (set-file-modes
- tmpfile
- (logior (or modes 0) (string-to-number "0400" 8))))
+ (set-file-modes tmpfile (logior (or modes 0) #o0400)))
;; This is a bit lengthy due to the different methods
;; possible for file transfer. First, we check whether the
@@ -3333,8 +3330,9 @@ the result will be a local, non-Tramp, file name."
loc-enc tmpfile t))
(tramp-error
v 'file-error
- (concat "Cannot write to `%s', "
- "local encoding command `%s' failed")
+ (eval-when-compile
+ (concat "Cannot write to `%s', "
+ "local encoding command `%s' failed"))
filename loc-enc))))
;; Send buffer into remote decoding command which
@@ -3379,8 +3377,9 @@ the result will be a local, non-Tramp, file name."
(buffer-string))))
(tramp-error
v 'file-error
- (concat "Couldn't write region to `%s',"
- " decode using `%s' failed")
+ (eval-when-compile
+ (concat "Couldn't write region to `%s',"
+ " decode using `%s' failed"))
filename rem-dec)))))
;; Save exit.
@@ -3390,16 +3389,17 @@ the result will be a local, non-Tramp, file name."
(t
(tramp-error
v 'file-error
- (concat "Method `%s' should specify both encoding and "
- "decoding command or an scp program")
+ (eval-when-compile
+ (concat "Method `%s' should specify both encoding and "
+ "decoding command or an scp program"))
method))))
;; Make `last-coding-system-used' have the right value.
(when coding-system-used
(set 'last-coding-system-used coding-system-used))))
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
;; We must protect `last-coding-system-used', now we have set it
;; to its correct value.
@@ -3460,7 +3460,7 @@ the result will be a local, non-Tramp, file name."
;; Here we collect only file names, which need an operation.
(tramp-with-demoted-errors
v "Error in 1st pass of `vc-registered': %s"
- (tramp-run-real-handler 'vc-registered (list file)))
+ (tramp-run-real-handler #'vc-registered (list file)))
(tramp-message v 10 "\n%s" tramp-vc-registered-file-names)
;; Send just one command, in order to fill the cache.
@@ -3483,7 +3483,7 @@ the result will be a local, non-Tramp, file name."
(format
"tramp_vc_registered_read_file_names <<'%s'\n%s\n%s\n"
tramp-end-of-heredoc
- (mapconcat 'tramp-shell-quote-argument
+ (mapconcat #'tramp-shell-quote-argument
tramp-vc-registered-file-names
"\n")
tramp-end-of-heredoc))
@@ -3523,7 +3523,7 @@ the result will be a local, non-Tramp, file name."
;; Run.
(tramp-with-demoted-errors
v "Error in 2nd pass of `vc-registered': %s"
- (tramp-run-real-handler 'vc-registered (list file))))))))
+ (tramp-run-real-handler #'vc-registered (list file))))))))
;;;###tramp-autoload
(defun tramp-sh-file-name-handler (operation &rest args)
@@ -3536,15 +3536,16 @@ Fall back to normal file name handler if no Tramp handler exists."
;; This must be the last entry, because `identity' always matches.
;;;###tramp-autoload
-(tramp-register-foreign-file-name-handler
- 'identity 'tramp-sh-file-name-handler 'append)
+(tramp--with-startup
+ (tramp-register-foreign-file-name-handler
+ #'identity #'tramp-sh-file-name-handler 'append))
(defun tramp-vc-file-name-handler (operation &rest args)
"Invoke special file name handler, which collects files to be handled."
(save-match-data
(let ((filename
(tramp-replace-environment-variables
- (apply 'tramp-file-name-for-operation operation args)))
+ (apply #'tramp-file-name-for-operation operation args)))
(fn (assoc operation tramp-sh-file-name-handler-alist)))
(with-parsed-tramp-file-name filename nil
(cond
@@ -3572,29 +3573,19 @@ Fall back to normal file name handler if no Tramp handler exists."
(let ((default-directory (file-name-directory file-name))
command events filter p sequence)
(cond
- ;; gvfs-monitor-dir.
- ((setq command (tramp-get-remote-gvfs-monitor-dir v))
- (setq filter 'tramp-sh-gvfs-monitor-dir-process-filter
- events
- (cond
- ((and (memq 'change flags) (memq 'attribute-change flags))
- '(created changed changes-done-hint moved deleted
- attribute-changed))
- ((memq 'change flags)
- '(created changed changes-done-hint moved deleted))
- ((memq 'attribute-change flags) '(attribute-changed)))
- sequence `(,command ,localname)))
- ;; inotifywait.
+ ;; "inotifywait".
((setq command (tramp-get-remote-inotifywait v))
- (setq filter 'tramp-sh-inotifywait-process-filter
+ (setq filter #'tramp-sh-inotifywait-process-filter
events
(cond
((and (memq 'change flags) (memq 'attribute-change flags))
- (concat "create,modify,move,moved_from,moved_to,move_self,"
- "delete,delete_self,attrib,ignored"))
+ (eval-when-compile
+ (concat "create,modify,move,moved_from,moved_to,move_self,"
+ "delete,delete_self,attrib,ignored")))
((memq 'change flags)
- (concat "create,modify,move,moved_from,moved_to,move_self,"
- "delete,delete_self,ignored"))
+ (eval-when-compile
+ (concat "create,modify,move,moved_from,moved_to,move_self,"
+ "delete,delete_self,ignored")))
((memq 'attribute-change flags) "attrib,ignored"))
sequence `(,command "-mq" "-e" ,events ,localname)
;; Make events a list of symbols.
@@ -3602,6 +3593,30 @@ Fall back to normal file name handler if no Tramp handler exists."
(mapcar
(lambda (x) (intern-soft (replace-regexp-in-string "_" "-" x)))
(split-string events "," 'omit))))
+ ;; "gio monitor".
+ ((setq command (tramp-get-remote-gio-monitor v))
+ (setq filter #'tramp-sh-gio-monitor-process-filter
+ events
+ (cond
+ ((and (memq 'change flags) (memq 'attribute-change flags))
+ '(created changed changes-done-hint moved deleted
+ attribute-changed))
+ ((memq 'change flags)
+ '(created changed changes-done-hint moved deleted))
+ ((memq 'attribute-change flags) '(attribute-changed)))
+ sequence `(,command "monitor" ,localname)))
+ ;; "gvfs-monitor-dir".
+ ((setq command (tramp-get-remote-gvfs-monitor-dir v))
+ (setq filter #'tramp-sh-gvfs-monitor-dir-process-filter
+ events
+ (cond
+ ((and (memq 'change flags) (memq 'attribute-change flags))
+ '(created changed changes-done-hint moved deleted
+ attribute-changed))
+ ((memq 'change flags)
+ '(created changed changes-done-hint moved deleted))
+ ((memq 'attribute-change flags) '(attribute-changed)))
+ sequence `(,command ,localname)))
;; None.
(t (tramp-error
v 'file-notify-error
@@ -3609,7 +3624,7 @@ Fall back to normal file name handler if no Tramp handler exists."
(file-remote-p file-name))))
;; Start process.
(setq p (apply
- 'start-file-process
+ #'start-file-process
(file-name-nondirectory command)
(generate-new-buffer
(format " *%s*" (file-name-nondirectory command)))
@@ -3619,9 +3634,9 @@ Fall back to normal file name handler if no Tramp handler exists."
(tramp-error
v 'file-notify-error
"`%s' failed to start on remote host"
- (mapconcat 'identity sequence " "))
- (tramp-message v 6 "Run `%s', %S" (mapconcat 'identity sequence " ") p)
- (tramp-set-connection-property p "vector" v)
+ (mapconcat #'identity sequence " "))
+ (tramp-message v 6 "Run `%s', %S" (mapconcat #'identity sequence " ") p)
+ (process-put p 'vector v)
;; Needed for process filter.
(process-put p 'events events)
(process-put p 'watch-name localname)
@@ -3629,12 +3644,75 @@ Fall back to normal file name handler if no Tramp handler exists."
(set-process-filter p filter)
;; There might be an error if the monitor is not supported.
;; Give the filter a chance to read the output.
- (tramp-accept-process-output p 1)
+ (while (tramp-accept-process-output p 0))
(unless (process-live-p p)
(tramp-error
- v 'file-notify-error "Monitoring not supported for `%s'" file-name))
+ p 'file-notify-error "Monitoring not supported for `%s'" file-name))
p))))
+(defun tramp-sh-gio-monitor-process-filter (proc string)
+ "Read output from \"gio monitor\" and add corresponding file-notify events."
+ (let ((events (process-get proc 'events))
+ (remote-prefix
+ (with-current-buffer (process-buffer proc)
+ (file-remote-p default-directory)))
+ (rest-string (process-get proc 'rest-string)))
+ (when rest-string
+ (tramp-message proc 10 "Previous string:\n%s" rest-string))
+ (tramp-message proc 6 "%S\n%s" proc string)
+ (setq string (concat rest-string string)
+ ;; Fix action names.
+ string (replace-regexp-in-string
+ "attributes changed" "attribute-changed" string)
+ string (replace-regexp-in-string
+ "changes done" "changes-done-hint" string)
+ string (replace-regexp-in-string
+ "renamed to" "moved" string))
+ ;; https://bugs.launchpad.net/bugs/1742946
+ (when
+ (string-match-p "Monitoring not supported\\|No locations given" string)
+ (delete-process proc))
+
+ ;; Delete empty lines.
+ (setq string (replace-regexp-in-string "\n\n" "\n" string))
+
+ (while (string-match
+ (eval-when-compile
+ (concat "^[^:]+:"
+ "[[:space:]]\\([^:]+\\):"
+ "[[:space:]]" (regexp-opt tramp-gio-events t)
+ "\\([[:space:]]\\([^:]+\\)\\)?$"))
+ string)
+
+ (let* ((file (match-string 1 string))
+ (file1 (match-string 4 string))
+ (object
+ (list
+ proc
+ (list
+ (intern-soft (match-string 2 string)))
+ ;; File names are returned as absolute paths. We must
+ ;; add the remote prefix.
+ (concat remote-prefix file)
+ (when file1 (concat remote-prefix file1)))))
+ (setq string (replace-match "" nil nil string))
+ ;; Remove watch when file or directory to be watched is deleted.
+ (when (and (member (cl-caadr object) '(moved deleted))
+ (string-equal file (process-get proc 'watch-name)))
+ (delete-process proc))
+ ;; Usually, we would add an Emacs event now. Unfortunately,
+ ;; `unread-command-events' does not accept several events at
+ ;; once. Therefore, we apply the handler directly.
+ (when (member (cl-caadr object) events)
+ (tramp-compat-funcall
+ 'file-notify-handle-event
+ `(file-notify ,object file-notify-callback)))))
+
+ ;; Save rest of the string.
+ (when (zerop (length string)) (setq string nil))
+ (when string (tramp-message proc 10 "Rest string:\n%s" string))
+ (process-put proc 'rest-string string)))
+
(defun tramp-sh-gvfs-monitor-dir-process-filter (proc string)
"Read output from \"gvfs-monitor-dir\" and add corresponding \
file-notify events."
@@ -3650,15 +3728,14 @@ file-notify events."
;; Attribute change is returned in unused wording.
string (replace-regexp-in-string
"ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string))
- (when (string-match "Monitoring not supported" string)
- (delete-process proc))
(while (string-match
- (concat "^[\n\r]*"
- "Directory Monitor Event:[\n\r]+"
- "Child = \\([^\n\r]+\\)[\n\r]+"
- "\\(Other = \\([^\n\r]+\\)[\n\r]+\\)?"
- "Event = \\([^[:blank:]]+\\)[\n\r]+")
+ (eval-when-compile
+ (concat "^[\n\r]*"
+ "Directory Monitor Event:[\n\r]+"
+ "Child = \\([^\n\r]+\\)[\n\r]+"
+ "\\(Other = \\([^\n\r]+\\)[\n\r]+\\)?"
+ "Event = \\([^[:blank:]]+\\)[\n\r]+"))
string)
(let* ((file (match-string 1 string))
(file1 (match-string 3 string))
@@ -3697,12 +3774,12 @@ file-notify events."
(tramp-message proc 6 "%S\n%s" proc string)
(dolist (line (split-string string "[\n\r]+" 'omit))
;; Check, whether there is a problem.
- (unless
- (string-match
- (concat "^[^[:blank:]]+"
- "[[:blank:]]+\\([^[:blank:]]+\\)+"
- "\\([[:blank:]]+\\([^\n\r]+\\)\\)?")
- line)
+ (unless (string-match
+ (eval-when-compile
+ (concat "^[^[:blank:]]+"
+ "[[:blank:]]+\\([^[:blank:]]+\\)+"
+ "\\([[:blank:]]+\\([^\n\r]+\\)\\)?"))
+ line)
(tramp-error proc 'file-notify-error "%s" line))
(let ((object
@@ -3733,21 +3810,26 @@ file-notify events."
(tramp-message v 5 "file system info: %s" localname)
(tramp-send-command
v (format
- "%s --block-size=1 --output=size,used,avail %s"
+ "%s %s"
(tramp-get-remote-df v) (tramp-shell-quote-argument localname)))
(with-current-buffer (tramp-get-connection-buffer v)
(goto-char (point-min))
(forward-line)
(when (looking-at
- (concat "[[:space:]]*\\([[:digit:]]+\\)"
- "[[:space:]]+\\([[:digit:]]+\\)"
- "[[:space:]]+\\([[:digit:]]+\\)"))
- (list (string-to-number (concat (match-string 1) "e0"))
- ;; The second value is the used size. We need the
- ;; free size.
- (- (string-to-number (concat (match-string 1) "e0"))
- (string-to-number (concat (match-string 2) "e0")))
- (string-to-number (concat (match-string 3) "e0")))))))))
+ (eval-when-compile
+ (concat "\\(?:^/[^[:space:]]*[[:space:]]\\)?"
+ "[[:space:]]*\\([[:digit:]]+\\)"
+ "[[:space:]]+\\([[:digit:]]+\\)"
+ "[[:space:]]+\\([[:digit:]]+\\)")))
+ (mapcar
+ (lambda (d)
+ (* d (tramp-get-connection-property v "df-blocksize" 0)))
+ (list (string-to-number (match-string 1))
+ ;; The second value is the used size. We need the
+ ;; free size.
+ (- (string-to-number (match-string 1))
+ (string-to-number (match-string 2)))
+ (string-to-number (match-string 3))))))))))
;;; Internal Functions:
@@ -3766,7 +3848,7 @@ Only send the definition if it has not already been done."
(setq script (replace-regexp-in-string
(make-string 1 ?\t) (make-string 8 ? ) script))
;; The script could contain a call of Perl. This is masked with `%s'.
- (when (and (string-match "%s" script)
+ (when (and (string-match-p "%s" script)
(not (tramp-get-remote-perl vec)))
(tramp-error vec 'file-error "No Perl available on remote host"))
(tramp-barf-unless-okay
@@ -3827,12 +3909,12 @@ This function expects to be in the right *tramp* buffer."
;; 5.11") have problems with this command, we disable the call
;; therefore.
(unless (or ignore-path
- (string-match
- (regexp-opt '("SunOS 5.10" "SunOS 5.11"))
+ (string-match-p
+ (eval-when-compile (regexp-opt '("SunOS 5.10" "SunOS 5.11")))
(tramp-get-connection-property vec "uname" "")))
(tramp-send-command vec (format "which \\%s | wc -w" progname))
(goto-char (point-min))
- (if (looking-at "^\\s-*1$")
+ (if (looking-at-p "^\\s-*1$")
(setq result (concat "\\" progname))))
(unless result
(when ignore-tilde
@@ -3846,14 +3928,15 @@ This function expects to be in the right *tramp* buffer."
(setq dirlist (nreverse newdl))))
(tramp-send-command
vec
- (format (concat "while read d; "
- "do if test -x $d/%s && test -f $d/%s; "
- "then echo tramp_executable $d/%s; "
- "break; fi; done <<'%s'\n"
- "%s\n%s")
+ (format (eval-when-compile
+ (concat "while read d; "
+ "do if test -x $d/%s && test -f $d/%s; "
+ "then echo tramp_executable $d/%s; "
+ "break; fi; done <<'%s'\n"
+ "%s\n%s"))
progname progname progname
tramp-end-of-heredoc
- (mapconcat 'identity dirlist "\n")
+ (mapconcat #'identity dirlist "\n")
tramp-end-of-heredoc))
(goto-char (point-max))
(when (search-backward "tramp_executable " nil t)
@@ -3862,15 +3945,33 @@ This function expects to be in the right *tramp* buffer."
(setq result (buffer-substring (point) (point-at-eol)))))
result)))
+;; On hydra.nixos.org, the $PATH environment variable is too long to
+;; send it. This is likely not due to PATH_MAX, but PIPE_BUF. We
+;; check it, and use a temporary file in case of. See Bug#33781.
(defun tramp-set-remote-path (vec)
"Sets the remote environment PATH to existing directories.
I.e., for each directory in `tramp-remote-path', it is tested
whether it exists and if so, it is added to the environment
variable PATH."
- (tramp-message vec 5 "Setting $PATH environment variable")
- (tramp-send-command
- vec (format "PATH=%s; export PATH"
- (mapconcat 'identity (tramp-get-remote-path vec) ":"))))
+ (let ((command
+ (format "PATH=%s; export PATH"
+ (mapconcat #'identity (tramp-get-remote-path vec) ":")))
+ (pipe-buf
+ (or (with-tramp-connection-property vec "pipe-buf"
+ (tramp-send-command-and-read
+ vec "getconf PIPE_BUF / 2>/dev/null || echo nil" 'noerror))
+ 4096))
+ tmpfile)
+ (tramp-message vec 5 "Setting $PATH environment variable")
+ (if (< (length command) pipe-buf)
+ (tramp-send-command vec command)
+ ;; Use a temporary file.
+ (setq tmpfile
+ (tramp-make-tramp-file-name vec (tramp-make-tramp-temp-file vec)))
+ (write-region command nil tmpfile)
+ (tramp-send-command
+ vec (format ". %s" (tramp-compat-file-local-name tmpfile)))
+ (delete-file tmpfile))))
;; ------------------------------------------------------------
;; -- Communication with external shell --
@@ -3939,7 +4040,7 @@ file exists and nonzero exit status otherwise."
item extra-args)
(while (and alist (null extra-args))
(setq item (pop alist))
- (when (string-match (car item) shell)
+ (when (string-match-p (car item) shell)
(setq extra-args (cdr item))))
;; It is useful to set the prompt in the following command
;; because some people have a setting for $PS1 which /bin/sh
@@ -3960,9 +4061,10 @@ file exists and nonzero exit status otherwise."
;; initial probes to ensure the remote shell is usable.)
(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")
+ (eval-when-compile
+ (concat
+ "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' "
+ "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s"))
tramp-terminal-type
emacs-version tramp-version ; INSIDE_EMACS
(or (getenv-internal "ENV" tramp-remote-process-environment) "")
@@ -4000,13 +4102,14 @@ file exists and nonzero exit status otherwise."
;; CCC: "root" does not exist always, see my QNAP TS-459.
;; Which check could we apply instead?
(tramp-send-command vec "echo ~root" t)
- (if (or (string-match "^~root$" (buffer-string))
+ (if (or (string-match-p "^~root$" (buffer-string))
;; The default shell (ksh93) of OpenSolaris and
;; Solaris is buggy. We've got reports for
;; "SunOS 5.10" and "SunOS 5.11" so far.
- (string-match (regexp-opt '("SunOS 5.10" "SunOS 5.11"))
- (tramp-get-connection-property
- vec "uname" "")))
+ (string-match-p
+ (eval-when-compile
+ (regexp-opt '("SunOS 5.10" "SunOS 5.11")))
+ (tramp-get-connection-property vec "uname" "")))
(or (tramp-find-executable
vec "bash" (tramp-get-remote-path vec) t t)
@@ -4017,9 +4120,10 @@ file exists and nonzero exit status otherwise."
default-shell
(tramp-message
vec 2
- (concat
- "Couldn't find a remote shell which groks tilde "
- "expansion, using `%s'")
+ (eval-when-compile
+ (concat
+ "Couldn't find a remote shell which groks tilde "
+ "expansion, using `%s'"))
default-shell)))
default-shell)))
@@ -4036,7 +4140,7 @@ file exists and nonzero exit status otherwise."
"Wait for shell prompt and barf if none appears.
Looks at process PROC to see if a shell prompt appears in TIMEOUT
seconds. If not, it produces an error message with the given ERROR-ARGS."
- (let ((vec (tramp-get-connection-property proc "vector" nil)))
+ (let ((vec (process-get proc 'vector)))
(condition-case nil
(tramp-wait-for-regexp
proc timeout
@@ -4044,7 +4148,7 @@ seconds. If not, it produces an error message with the given ERROR-ARGS."
"\\(%s\\|%s\\)\\'" shell-prompt-pattern tramp-shell-prompt-pattern))
(error
(delete-process proc)
- (apply 'tramp-error-with-buffer
+ (apply #'tramp-error-with-buffer
(tramp-get-connection-buffer vec) vec 'file-error error-args)))))
(defun tramp-open-connection-setup-interactive-shell (proc vec)
@@ -4065,7 +4169,7 @@ process to set up. VEC specifies the connection."
(tramp-send-command vec "echo foo" t)
(with-current-buffer (process-buffer proc)
(goto-char (point-min))
- (when (looking-at "echo foo")
+ (when (looking-at-p "echo foo")
(tramp-set-connection-property proc "remote-echo" t)
(tramp-message vec 5 "Remote echo still on. Ok.")
;; Make sure backspaces and their echo are enabled and no line
@@ -4104,10 +4208,10 @@ process to set up. VEC specifies the connection."
;; Use MULE to select the right EOL convention for communicating
;; with the process.
(let ((cs (or (and (memq 'utf-8-hfs (coding-system-list))
- (string-match "^Darwin" uname)
+ (string-match-p "^Darwin" uname)
(cons 'utf-8-hfs 'utf-8-hfs))
(and (memq 'utf-8 (coding-system-list))
- (string-match "utf-?8" (tramp-get-remote-locale vec))
+ (string-match-p "utf-?8" (tramp-get-remote-locale vec))
(cons 'utf-8 'utf-8))
(process-coding-system proc)
(cons 'undecided 'undecided)))
@@ -4117,7 +4221,7 @@ process to set up. VEC specifies the connection."
cs-encode (or (cdr cs) 'undecided)
cs-encode
(coding-system-change-eol-conversion
- cs-encode (if (string-match "^Darwin" uname) 'mac 'unix)))
+ cs-encode (if (string-match-p "^Darwin" uname) 'mac 'unix)))
(tramp-send-command vec "(echo foo ; echo bar)" t)
(goto-char (point-min))
(when (search-forward "\r" nil t)
@@ -4141,7 +4245,7 @@ process to set up. VEC specifies the connection."
(t
(tramp-message
vec 5 "Checking remote host type for `send-process-string' bug")
- (if (string-match "^FreeBSD" uname) 500 0))))
+ (if (string-match-p "^FreeBSD" uname) 500 0))))
;; Set remote PATH variable.
(tramp-set-remote-path vec)
@@ -4164,11 +4268,11 @@ process to set up. VEC specifies the connection."
;; IRIX64 bash expands "!" even when in single quotes. This
;; destroys our shell functions, we must disable it. See
;; <http://stackoverflow.com/questions/3291692/irix-bash-shell-expands-expression-in-single-quotes-yet-shouldnt>.
- (when (string-match "^IRIX64" uname)
+ (when (string-match-p "^IRIX64" uname)
(tramp-send-command vec "set +H" t))
;; Disable tab expansion.
- (if (string-match "BSD\\|Darwin" uname)
+ (if (string-match-p "BSD\\|Darwin" uname)
(tramp-send-command vec "stty tabs" t)
(tramp-send-command vec "stty tab0" t))
@@ -4194,7 +4298,7 @@ process to set up. VEC specifies the connection."
(append `(,(tramp-get-remote-locale vec))
(copy-sequence tramp-remote-process-environment))))
(setq item (split-string item "=" 'omit))
- (setcdr item (mapconcat 'identity (cdr item) "="))
+ (setcdr item (mapconcat #'identity (cdr item) "="))
(if (and (stringp (cdr item)) (not (string-equal (cdr item) "")))
(push (format "%s %s" (car item) (cdr item)) vars)
(push (car item) unset)))
@@ -4204,12 +4308,12 @@ process to set up. VEC specifies the connection."
(format
"while read var val; do export $var=\"$val\"; done <<'%s'\n%s\n%s"
tramp-end-of-heredoc
- (mapconcat 'identity vars "\n")
+ (mapconcat #'identity vars "\n")
tramp-end-of-heredoc)
t))
(when unset
(tramp-send-command
- vec (format "unset %s" (mapconcat 'identity unset " ")) t)))))
+ vec (format "unset %s" (mapconcat #'identity unset " ")) t)))))
;; Old text from documentation of tramp-methods:
;; Using a uuencode/uudecode inline method is discouraged, please use one
@@ -4235,7 +4339,7 @@ Each item is a list that looks like this:
\(FORMAT ENCODING DECODING)
-FORMAT is symbol describing the encoding/decoding format. It can be
+FORMAT is a symbol describing the encoding/decoding format. It can be
`b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing.
ENCODING and DECODING can be strings, giving commands, or symbols,
@@ -4315,16 +4419,14 @@ Goes through the list `tramp-local-coding-commands' and
vec 5 "Checking local encoding function `%s'" loc-enc)
(tramp-message
vec 5 "Checking local encoding command `%s' for sanity" loc-enc)
- (unless (zerop (tramp-call-local-coding-command
- loc-enc nil nil))
+ (unless (zerop (tramp-call-local-coding-command loc-enc nil nil))
(throw 'wont-work-local nil)))
(if (not (stringp loc-dec))
(tramp-message
vec 5 "Checking local decoding function `%s'" loc-dec)
(tramp-message
vec 5 "Checking local decoding command `%s' for sanity" loc-dec)
- (unless (zerop (tramp-call-local-coding-command
- loc-dec nil nil))
+ (unless (zerop (tramp-call-local-coding-command loc-dec nil nil))
(throw 'wont-work-local nil)))
;; Search for remote coding commands with the same format
(while (and remote-commands (not found))
@@ -4342,7 +4444,7 @@ Goes through the list `tramp-local-coding-commands' and
(throw 'wont-work-remote nil)))
;; Check if remote perl exists when necessary.
(when (and (symbolp rem-enc)
- (string-match "perl" (symbol-name rem-enc))
+ (string-match-p "perl" (symbol-name rem-enc))
(not (tramp-get-remote-perl vec)))
(throw 'wont-work-remote nil))
;; Check if remote encoding and decoding commands can be
@@ -4353,9 +4455,9 @@ Goes through the list `tramp-local-coding-commands' and
;; actually check the output it gives. And also, when
;; redirecting "mimencode" output to /dev/null, then as root
;; it might change the permissions of /dev/null!
- (when (not (stringp rem-enc))
+ (unless (stringp rem-enc)
(let ((name (symbol-name rem-enc)))
- (while (string-match (regexp-quote "-") name)
+ (while (string-match "-" name)
(setq name (replace-match "_" nil t name)))
(tramp-maybe-send-script vec (symbol-value rem-enc) name)
(setq rem-enc name)))
@@ -4366,13 +4468,13 @@ Goes through the list `tramp-local-coding-commands' and
vec (format "%s </dev/null" rem-enc) t)
(throw 'wont-work-remote nil))
- (when (not (stringp rem-dec))
+ (unless (stringp rem-dec)
(let ((name (symbol-name rem-dec))
(value (symbol-value rem-dec))
tmpfile)
- (while (string-match (regexp-quote "-") name)
+ (while (string-match "-" name)
(setq name (replace-match "_" nil t name)))
- (when (string-match "\\(^\\|[^%]\\)%t" value)
+ (when (string-match-p "\\(^\\|[^%]\\)%t" value)
(setq tmpfile
(make-temp-name
(expand-file-name
@@ -4382,8 +4484,7 @@ Goes through the list `tramp-local-coding-commands' and
(format-spec
value
(format-spec-make
- ?t
- (file-remote-p tmpfile 'localname)))))
+ ?t (tramp-compat-file-local-name tmpfile)))))
(tramp-maybe-send-script vec value name)
(setq rem-dec name)))
(tramp-message
@@ -4395,9 +4496,9 @@ Goes through the list `tramp-local-coding-commands' and
t)
(throw 'wont-work-remote nil))
- (with-current-buffer (tramp-get-buffer vec)
+ (with-current-buffer (tramp-get-connection-buffer vec)
(goto-char (point-min))
- (unless (looking-at (regexp-quote magic))
+ (unless (looking-at-p (regexp-quote magic))
(throw 'wont-work-remote nil)))
;; `rem-enc' and `rem-dec' could be a string meanwhile.
@@ -4427,12 +4528,12 @@ means standard output and thus the current buffer), or nil (which
means discard it)."
(tramp-call-process
nil tramp-encoding-shell
- (when (and input (not (string-match "%s" cmd))) input)
+ (when (and input (not (string-match-p "%s" cmd))) input)
(if (eq output t) t nil)
nil
tramp-encoding-command-switch
(concat
- (if (string-match "%s" cmd) (format cmd input) cmd)
+ (if (string-match-p "%s" cmd) (format cmd input) cmd)
(if (stringp output) (concat " >" output) ""))))
(defconst tramp-inline-compress-commands
@@ -4474,9 +4575,9 @@ Goes through the list `tramp-inline-compress-commands'."
;; the pipe symbol be quoted if they use forward
;; slashes as directory separators.
(mapconcat
- 'shell-quote-argument (split-string compress) " ")
+ #'shell-quote-argument (split-string compress) " ")
(mapconcat
- 'shell-quote-argument (split-string decompress) " "))
+ #'shell-quote-argument (split-string decompress) " "))
nil nil))
(throw 'next nil))
(tramp-message
@@ -4508,28 +4609,29 @@ Goes through the list `tramp-inline-compress-commands'."
(defun tramp-compute-multi-hops (vec)
"Expands VEC according to `tramp-default-proxies-alist'."
- (let ((target-alist `(,vec))
+ (let ((saved-tdpa tramp-default-proxies-alist)
+ (target-alist `(,vec))
(hops (or (tramp-file-name-hop vec) ""))
(item vec)
choices proxy)
;; Ad-hoc proxy definitions.
(dolist (proxy (reverse (split-string hops tramp-postfix-hop-regexp 'omit)))
- (let ((user (tramp-file-name-user item))
- (host (tramp-file-name-host item))
+ (let ((user-domain (tramp-file-name-user-domain item))
+ (host-port (tramp-file-name-host-port item))
(proxy (concat
tramp-prefix-format proxy tramp-postfix-host-format)))
(tramp-message
vec 5 "Add proxy (\"%s\" \"%s\" \"%s\")"
- (and (stringp host) (regexp-quote host))
- (and (stringp user) (regexp-quote user))
+ (and (stringp host-port) (regexp-quote host-port))
+ (and (stringp user-domain) (regexp-quote user-domain))
proxy)
;; Add the hop.
(add-to-list
'tramp-default-proxies-alist
- (list (and (stringp host) (regexp-quote host))
- (and (stringp user) (regexp-quote user))
- proxy))
+ (list (and (stringp host-port) (regexp-quote host-port))
+ (and (stringp user-domain) (regexp-quote user-domain))
+ (propertize proxy 'tramp-ad-hoc t)))
(setq item (tramp-dissect-file-name proxy))))
;; Save the new value.
(when (and hops tramp-save-ad-hoc-proxies)
@@ -4543,11 +4645,15 @@ Goes through the list `tramp-inline-compress-commands'."
proxy (eval (nth 2 item)))
(when (and
;; Host.
- (string-match (or (eval (nth 0 item)) "")
- (or (tramp-file-name-host (car target-alist)) ""))
+ (string-match-p
+ (or (eval (nth 0 item)) "")
+ (or (tramp-file-name-host-port (car target-alist))
+ ""))
;; User.
- (string-match (or (eval (nth 1 item)) "")
- (or (tramp-file-name-user (car target-alist)) "")))
+ (string-match-p
+ (or (eval (nth 1 item)) "")
+ (or (tramp-file-name-user-domain (car target-alist))
+ "")))
(if (null proxy)
;; No more hops needed.
(setq choices nil)
@@ -4570,30 +4676,30 @@ Goes through the list `tramp-inline-compress-commands'."
(while (setq item (pop choices))
(when (or (not (tramp-get-method-parameter item 'tramp-login-program))
(tramp-get-method-parameter item 'tramp-copy-program))
- (tramp-error
- vec 'file-error
- "Method `%s' is not supported for multi-hops."
+ (setq tramp-default-proxies-alist saved-tdpa)
+ (tramp-user-error
+ vec "Method `%s' is not supported for multi-hops."
(tramp-file-name-method item)))))
- ;; In case the host name is not used for the remote shell
- ;; command, the user could be misguided by applying a random
- ;; host name.
- (let* ((v (car target-alist))
- (method (tramp-file-name-method v))
- (host (tramp-file-name-host v)))
- (unless
- (or
- ;; There are multi-hops.
- (cdr target-alist)
- ;; The host name is used for the remote shell command.
- (member '("%h") (tramp-get-method-parameter v 'tramp-login-args))
- ;; The host is local. We cannot use `tramp-local-host-p'
- ;; here, because it opens a connection as well.
- (string-match tramp-local-host-regexp host))
- (tramp-error
- v 'file-error
- "Host `%s' looks like a remote host, `%s' can only use the local host"
- host method)))
+ ;; Some methods ("su", "sg", "sudo", "doas", "ksu") do not use the
+ ;; host name in their command template. In this case, the remote
+ ;; file name must use either a local host name (first hop), or a
+ ;; host name matching the previous hop.
+ (let ((previous-host (or tramp-local-host-regexp "")))
+ (setq choices target-alist)
+ (while (setq item (pop choices))
+ (let ((host (tramp-file-name-host item)))
+ (unless
+ (or
+ ;; The host name is used for the remote shell command.
+ (member
+ '("%h") (tramp-get-method-parameter item 'tramp-login-args))
+ ;; The host name must match previous hop.
+ (string-match-p previous-host host))
+ (setq tramp-default-proxies-alist saved-tdpa)
+ (tramp-user-error
+ vec "Host name `%s' does not match `%s'" host previous-host))
+ (setq previous-host (concat "^" (regexp-quote host) "$")))))
;; Result.
target-alist))
@@ -4615,7 +4721,7 @@ Goes through the list `tramp-inline-compress-commands'."
(ignore-errors
(when (executable-find "ssh")
(with-tramp-progress-reporter
- vec 4 "Computing ControlMaster options"
+ vec 4 "Computing ControlMaster options"
(with-temp-buffer
(tramp-call-process vec "ssh" nil t nil "-o" "ControlMaster")
(goto-char (point-min))
@@ -4645,6 +4751,19 @@ Goes through the list `tramp-inline-compress-commands'."
" -o ControlPersist=no")))))))))
tramp-ssh-controlmaster-options)))
+(defun tramp-timeout-session (vec)
+ "Close the connection VEC after a session timeout.
+If there is just some editing, retry it after 5 seconds."
+ (if (and tramp-locked tramp-locker
+ (tramp-file-name-equal-p vec (car tramp-current-connection)))
+ (progn
+ (tramp-message
+ vec 5 "Cannot timeout session, trying it again in %s seconds." 5)
+ (run-at-time 5 nil 'tramp-timeout-session vec))
+ (tramp-message
+ vec 3 "Timeout session %s" (tramp-make-tramp-file-name vec 'localname))
+ (tramp-cleanup-connection vec 'keep-debug)))
+
(defun tramp-maybe-open-connection (vec)
"Maybe open a connection VEC.
Does not do anything if a connection is already open, but re-opens the
@@ -4659,9 +4778,12 @@ connection if a previous connection has died for some reason."
(unless (or (process-live-p p)
(not (tramp-file-name-equal-p
vec (car tramp-current-connection)))
- (> (tramp-time-diff
- (current-time) (cdr tramp-current-connection))
- (or tramp-connection-min-time-diff 0)))
+ (time-less-p
+ ;; `current-time' can be removed once we get rid of Emacs 24.
+ (time-since (or (cdr tramp-current-connection) (current-time)))
+ ;; `seconds-to-time' can be removed once we get rid
+ ;; of Emacs 24.
+ (seconds-to-time (or tramp-connection-min-time-diff 0))))
(throw 'suppress 'suppress))
;; If too much time has passed since last command was sent, look
@@ -4672,11 +4794,11 @@ connection if a previous connection has died for some reason."
;; try to send a command from time to time, then look again
;; whether the process is really alive.
(condition-case nil
- (when (and (> (tramp-time-diff
- (current-time)
- (tramp-get-connection-property
- p "last-cmd-time" '(0 0 0)))
- 60)
+ ;; `seconds-to-time' can be removed once we get rid of Emacs 24.
+ (when (and (time-less-p (seconds-to-time 60)
+ (time-since
+ (tramp-get-connection-property
+ p "last-cmd-time" (seconds-to-time 0))))
(process-live-p p))
(tramp-send-command vec "echo are you awake" t t)
(unless (and (process-live-p p)
@@ -4727,7 +4849,8 @@ connection if a previous connection has died for some reason."
(setenv "PS1" tramp-initial-end-of-output)
(unless (stringp tramp-encoding-shell)
(tramp-error vec 'file-error "`tramp-encoding-shell' not set"))
- (let* ((target-alist (tramp-compute-multi-hops vec))
+ (let* ((current-host (system-name))
+ (target-alist (tramp-compute-multi-hops vec))
;; We will apply `tramp-ssh-controlmaster-options'
;; only for the first hop.
(options (tramp-ssh-controlmaster-options vec))
@@ -4742,7 +4865,7 @@ connection if a previous connection has died for some reason."
(p (let ((default-directory
(tramp-compat-temporary-file-directory)))
(apply
- 'start-process
+ #'start-process
(tramp-get-connection-name vec)
(tramp-get-connection-buffer vec)
(if tramp-encoding-command-interactive
@@ -4750,16 +4873,15 @@ connection if a previous connection has died for some reason."
tramp-encoding-command-interactive)
(list tramp-encoding-shell))))))
- ;; Set sentinel and query flag.
- (tramp-set-connection-property p "vector" vec)
- (set-process-sentinel p 'tramp-process-sentinel)
- (process-put p 'adjust-window-size-function 'ignore)
+ ;; Set sentinel and query flag. Initialize variables.
+ (set-process-sentinel p #'tramp-process-sentinel)
+ (process-put p 'vector vec)
+ (process-put p 'adjust-window-size-function #'ignore)
(set-process-query-on-exit-flag p nil)
- (setq tramp-current-connection (cons vec (current-time))
- tramp-current-host (system-name))
+ (setq tramp-current-connection (cons vec (current-time)))
(tramp-message
- vec 6 "%s" (mapconcat 'identity (process-command p) " "))
+ vec 6 "%s" (mapconcat #'identity (process-command p) " "))
;; Check whether process is alive.
(tramp-barf-if-no-shell-prompt
@@ -4810,16 +4932,24 @@ connection if a previous connection has died for some reason."
;; Check, whether there is a restricted shell.
(dolist (elt tramp-restricted-shell-hosts-alist)
- (when (string-match elt tramp-current-host)
+ (when (string-match-p elt current-host)
(setq r-shell t)))
-
- ;; Set variables for computing the prompt for
- ;; reading password.
- (setq tramp-current-method l-method
- tramp-current-user l-user
- tramp-current-domain l-domain
- tramp-current-host l-host
- tramp-current-port l-port)
+ (setq current-host l-host)
+
+ ;; Set password prompt vector.
+ (tramp-set-connection-property
+ p "password-vector"
+ (make-tramp-file-name
+ :method l-method :user l-user :domain l-domain
+ :host l-host :port l-port))
+
+ ;; Set session timeout.
+ (when (tramp-get-method-parameter
+ hop 'tramp-session-timeout)
+ (tramp-set-connection-property
+ p "session-timeout"
+ (tramp-get-method-parameter
+ hop 'tramp-session-timeout)))
;; Add login environment.
(when login-env
@@ -4828,7 +4958,7 @@ connection if a previous connection has died for some reason."
(mapcar
(lambda (x)
(setq x (mapcar (lambda (y) (format-spec y spec)) x))
- (unless (member "" x) (mapconcat 'identity x " ")))
+ (unless (member "" x) (mapconcat #'identity x " ")))
login-env))
(while login-env
(setq command
@@ -4857,7 +4987,7 @@ connection if a previous connection has died for some reason."
(mapconcat
(lambda (x)
(setq x (mapcar (lambda (y) (format-spec y spec)) x))
- (unless (member "" x) (mapconcat 'identity x " ")))
+ (unless (member "" x) (mapconcat #'identity x " ")))
login-args " ")
;; Local shell could be a Windows COMSPEC. It
;; doesn't know the ";" syntax, but we must exit
@@ -4884,6 +5014,12 @@ connection if a previous connection has died for some reason."
;; Set connection-local variables.
(tramp-set-connection-local-variables vec)
+ ;; Activate session timeout.
+ (when (tramp-get-connection-property p "session-timeout" nil)
+ (run-at-time
+ (tramp-get-connection-property p "session-timeout" nil) nil
+ 'tramp-timeout-session vec))
+
;; Make initial shell settings.
(tramp-open-connection-setup-interactive-shell p vec)
@@ -4943,7 +5079,7 @@ function waits for output unless NOOUTPUT is set."
(regexp1 (format "\\(^\\|\000\\)%s" regexp))
(found (tramp-wait-for-regexp proc timeout regexp1)))
(if found
- (let (buffer-read-only)
+ (let ((inhibit-read-only t))
;; A simple-minded busybox has sent " ^H" sequences.
;; Delete them.
(goto-char (point-min))
@@ -4990,7 +5126,7 @@ DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null."
(skip-chars-forward "^ ")
(prog1
(zerop (read (current-buffer)))
- (let (buffer-read-only)
+ (let ((inhibit-read-only t))
(delete-region (match-beginning 0) (point-max))))))
(defun tramp-barf-unless-okay (vec command fmt &rest args)
@@ -4998,7 +5134,7 @@ DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null."
Similar to `tramp-send-command-and-check' but accepts two more arguments
FMT and ARGS which are passed to `error'."
(or (tramp-send-command-and-check vec command)
- (apply 'tramp-error vec 'file-error fmt args)))
+ (apply #'tramp-error vec 'file-error fmt args)))
(defun tramp-send-command-and-read (vec command &optional noerror marker)
"Run COMMAND and return the output, which must be a Lisp expression.
@@ -5006,7 +5142,7 @@ If MARKER is a regexp, read the output after that string.
In case there is no valid Lisp expression and NOERROR is nil, it
raises an error."
(when (if noerror
- (tramp-send-command-and-check vec command)
+ (ignore-errors (tramp-send-command-and-check vec command))
(tramp-barf-unless-okay
vec command "`%s' returns with error" command))
(with-current-buffer (tramp-get-connection-buffer vec)
@@ -5032,92 +5168,92 @@ raises an error."
"`%s' does not return a valid Lisp expression: `%s'"
command (buffer-string))))))))
+;; FIXME: Move to tramp.el?
+;;;###tramp-autoload
(defun tramp-convert-file-attributes (vec attr)
"Convert `file-attributes' ATTR generated by perl script, stat or ls.
Convert file mode bits to string and set virtual device number.
Return ATTR."
(when attr
- ;; Remove color escape sequences from symlink.
- (when (stringp (car attr))
- (while (string-match tramp-display-escape-sequence-regexp (car attr))
- (setcar attr (replace-match "" nil nil (car attr)))))
- ;; Convert uid and gid. Use `tramp-unknown-id-integer' as
- ;; indication of unusable value.
- (when (and (numberp (nth 2 attr)) (< (nth 2 attr) 0))
- (setcar (nthcdr 2 attr) tramp-unknown-id-integer))
- (when (and (floatp (nth 2 attr))
- (<= (nth 2 attr) most-positive-fixnum))
- (setcar (nthcdr 2 attr) (round (nth 2 attr))))
- (when (and (numberp (nth 3 attr)) (< (nth 3 attr) 0))
- (setcar (nthcdr 3 attr) tramp-unknown-id-integer))
- (when (and (floatp (nth 3 attr))
- (<= (nth 3 attr) most-positive-fixnum))
- (setcar (nthcdr 3 attr) (round (nth 3 attr))))
- ;; Convert last access time.
- (unless (listp (nth 4 attr))
- (setcar (nthcdr 4 attr)
- (list (floor (nth 4 attr) 65536)
- (floor (mod (nth 4 attr) 65536)))))
- ;; Convert last modification time.
- (unless (listp (nth 5 attr))
- (setcar (nthcdr 5 attr)
- (list (floor (nth 5 attr) 65536)
- (floor (mod (nth 5 attr) 65536)))))
- ;; Convert last status change time.
- (unless (listp (nth 6 attr))
- (setcar (nthcdr 6 attr)
- (list (floor (nth 6 attr) 65536)
- (floor (mod (nth 6 attr) 65536)))))
- ;; Convert file size.
- (when (< (nth 7 attr) 0)
- (setcar (nthcdr 7 attr) -1))
- (when (and (floatp (nth 7 attr))
- (<= (nth 7 attr) most-positive-fixnum))
- (setcar (nthcdr 7 attr) (round (nth 7 attr))))
- ;; Convert file mode bits to string.
- (unless (stringp (nth 8 attr))
- (setcar (nthcdr 8 attr) (tramp-file-mode-from-int (nth 8 attr)))
+ (save-match-data
+ ;; Remove color escape sequences from symlink.
(when (stringp (car attr))
- (aset (nth 8 attr) 0 ?l)))
- ;; Convert directory indication bit.
- (when (string-match "^d" (nth 8 attr))
- (setcar attr t))
- ;; Convert symlink from `tramp-do-file-attributes-with-stat'.
- (when (consp (car attr))
- (if (and (stringp (caar attr))
- (string-match ".+ -> .\\(.+\\)." (caar attr)))
- (setcar attr (match-string 1 (caar attr)))
- (setcar attr nil)))
- ;; Set file's gid change bit.
- (setcar (nthcdr 9 attr)
- (if (numberp (nth 3 attr))
- (not (= (nth 3 attr)
- (tramp-get-remote-gid vec 'integer)))
- (not (string-equal
- (nth 3 attr)
- (tramp-get-remote-gid vec 'string)))))
- ;; Convert inode.
- (unless (listp (nth 10 attr))
- (setcar (nthcdr 10 attr)
- (condition-case nil
- (let ((high (nth 10 attr))
- middle low)
- (if (<= high most-positive-fixnum)
- (floor high)
- ;; The low 16 bits.
- (setq low (mod high #x10000)
- high (/ high #x10000))
+ (while (string-match tramp-display-escape-sequence-regexp (car attr))
+ (setcar attr (replace-match "" nil nil (car attr)))))
+ ;; Convert uid and gid. Use `tramp-unknown-id-integer' as
+ ;; indication of unusable value.
+ (when (and (numberp (nth 2 attr)) (< (nth 2 attr) 0))
+ (setcar (nthcdr 2 attr) tramp-unknown-id-integer))
+ (when (and (floatp (nth 2 attr))
+ (<= (nth 2 attr) most-positive-fixnum))
+ (setcar (nthcdr 2 attr) (round (nth 2 attr))))
+ (when (and (numberp (nth 3 attr)) (< (nth 3 attr) 0))
+ (setcar (nthcdr 3 attr) tramp-unknown-id-integer))
+ (when (and (floatp (nth 3 attr))
+ (<= (nth 3 attr) most-positive-fixnum))
+ (setcar (nthcdr 3 attr) (round (nth 3 attr))))
+ ;; Convert last access time.
+ (unless (listp (nth 4 attr))
+ (setcar (nthcdr 4 attr) (seconds-to-time (nth 4 attr))))
+ ;; Convert last modification time.
+ (unless (listp (nth 5 attr))
+ (setcar (nthcdr 5 attr) (seconds-to-time (nth 5 attr))))
+ ;; Convert last status change time.
+ (unless (listp (nth 6 attr))
+ (setcar (nthcdr 6 attr) (seconds-to-time (nth 6 attr))))
+ ;; Convert file size.
+ (when (< (nth 7 attr) 0)
+ (setcar (nthcdr 7 attr) -1))
+ (when (and (floatp (nth 7 attr))
+ (<= (nth 7 attr) most-positive-fixnum))
+ (setcar (nthcdr 7 attr) (round (nth 7 attr))))
+ ;; Convert file mode bits to string.
+ (unless (stringp (nth 8 attr))
+ (setcar (nthcdr 8 attr) (tramp-file-mode-from-int (nth 8 attr)))
+ (when (stringp (car attr))
+ (aset (nth 8 attr) 0 ?l)))
+ ;; Convert directory indication bit.
+ (when (string-match-p "^d" (nth 8 attr))
+ (setcar attr t))
+ ;; Convert symlink from `tramp-do-file-attributes-with-stat'.
+ ;; Decode also multibyte string.
+ (when (consp (car attr))
+ (setcar attr
+ (and (stringp (caar attr))
+ (string-match ".+ -> .\\(.+\\)." (caar attr))
+ (decode-coding-string
+ (match-string 1 (caar attr)) 'utf-8))))
+ ;; Set file's gid change bit.
+ (setcar (nthcdr 9 attr)
+ (if (numberp (nth 3 attr))
+ (not (= (nth 3 attr)
+ (tramp-get-remote-gid vec 'integer)))
+ (not (string-equal
+ (nth 3 attr)
+ (tramp-get-remote-gid vec 'string)))))
+ ;; Convert inode.
+ (when (floatp (nth 10 attr))
+ (setcar (nthcdr 10 attr)
+ (condition-case nil
+ (let ((high (nth 10 attr))
+ middle low)
(if (<= high most-positive-fixnum)
- (cons (floor high) (floor low))
- ;; The middle 24 bits.
- (setq middle (mod high #x1000000)
- high (/ high #x1000000))
- (cons (floor high) (cons (floor middle) (floor low))))))
- ;; Inodes can be incredible huge. We must hide this.
- (error (tramp-get-inode vec)))))
- ;; Set virtual device number.
- (setcar (nthcdr 11 attr)
- (tramp-get-device vec))
+ (floor high)
+ ;; The low 16 bits.
+ (setq low (mod high #x10000)
+ high (/ high #x10000))
+ (if (<= high most-positive-fixnum)
+ (cons (floor high) (floor low))
+ ;; The middle 24 bits.
+ (setq middle (mod high #x1000000)
+ high (/ high #x1000000))
+ (cons (floor high)
+ (cons (floor middle) (floor low))))))
+ ;; Inodes can be incredible huge. We must hide this.
+ (error (tramp-get-inode vec)))))
+ ;; Set virtual device number.
+ (setcar (nthcdr 11 attr)
+ (tramp-get-device vec)))
attr))
(defun tramp-shell-case-fold (string)
@@ -5137,9 +5273,9 @@ Return ATTR."
(host (tramp-file-name-host vec))
(localname
(directory-file-name (tramp-file-name-unquote-localname vec))))
- (when (string-match tramp-ipv6-regexp host)
+ (when (string-match-p tramp-ipv6-regexp host)
(setq host (format "[%s]" host)))
- (unless (string-match "ftp$" method)
+ (unless (string-match-p "ftp$" method)
(setq localname (tramp-shell-quote-argument localname)))
(cond
((tramp-get-method-parameter vec 'tramp-remote-copy-program)
@@ -5166,94 +5302,90 @@ Return ATTR."
(defun tramp-get-remote-path (vec)
"Compile list of remote directories for $PATH.
Nonexistent directories are removed from spec."
- (with-tramp-connection-property
- ;; When `tramp-own-remote-path' is in `tramp-remote-path', we
- ;; cache the result for the session only. Otherwise, the result
- ;; is cached persistently.
- (if (memq 'tramp-own-remote-path tramp-remote-path)
- (tramp-get-connection-process vec)
- vec)
- "remote-path"
- (let* ((remote-path (copy-tree tramp-remote-path))
- (elt1 (memq 'tramp-default-remote-path remote-path))
- (elt2 (memq 'tramp-own-remote-path remote-path))
- (default-remote-path
- (when elt1
- (or
- (tramp-send-command-and-read
- vec "echo \\\"`getconf PATH 2>/dev/null`\\\"" 'noerror)
- ;; Default if "getconf" is not available.
- (progn
- (tramp-message
- vec 3
- "`getconf PATH' not successful, using default value \"%s\"."
- "/bin:/usr/bin")
- "/bin:/usr/bin"))))
- (own-remote-path
- ;; The login shell could return more than just the $PATH
- ;; string. So we use `tramp-end-of-heredoc' as marker.
- (when elt2
- (or
- (tramp-send-command-and-read
- vec
- (format
- "%s %s %s 'echo %s \\\"$PATH\\\"'"
- (tramp-get-method-parameter vec 'tramp-remote-shell)
- (mapconcat
- 'identity
- (tramp-get-method-parameter vec 'tramp-remote-shell-login)
- " ")
- (mapconcat
- 'identity
- (tramp-get-method-parameter vec 'tramp-remote-shell-args)
- " ")
- (tramp-shell-quote-argument tramp-end-of-heredoc))
- 'noerror (regexp-quote tramp-end-of-heredoc))
- (progn
- (tramp-message
- vec 2 "Could not retrieve `tramp-own-remote-path'")
- nil)))))
-
- ;; Replace place holder `tramp-default-remote-path'.
- (when elt1
- (setcdr elt1
- (append
- (split-string (or default-remote-path "") ":" 'omit)
- (cdr elt1)))
- (setq remote-path (delq 'tramp-default-remote-path remote-path)))
-
- ;; Replace place holder `tramp-own-remote-path'.
- (when elt2
- (setcdr elt2
- (append
- (split-string (or own-remote-path "") ":" 'omit)
- (cdr elt2)))
- (setq remote-path (delq 'tramp-own-remote-path remote-path)))
-
- ;; Remove double entries.
- (setq elt1 remote-path)
- (while (consp elt1)
- (while (and (car elt1) (setq elt2 (member (car elt1) (cdr elt1))))
- (setcar elt2 nil))
- (setq elt1 (cdr elt1)))
-
- ;; Remove non-existing directories.
- (delq
- nil
- (mapcar
- (lambda (x)
- (and
- (stringp x)
- (file-directory-p
- (tramp-make-tramp-file-name
- (tramp-file-name-method vec)
- (tramp-file-name-user vec)
- (tramp-file-name-domain vec)
- (tramp-file-name-host vec)
- (tramp-file-name-port vec)
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ ;; Expand connection-local variables.
+ (tramp-set-connection-local-variables vec)
+ (with-tramp-connection-property
+ ;; When `tramp-own-remote-path' is in `tramp-remote-path', we
+ ;; cache the result for the session only. Otherwise, the
+ ;; result is cached persistently.
+ (if (memq 'tramp-own-remote-path tramp-remote-path)
+ (tramp-get-connection-process vec)
+ vec)
+ "remote-path"
+ (let* ((remote-path (copy-tree tramp-remote-path))
+ (elt1 (memq 'tramp-default-remote-path remote-path))
+ (elt2 (memq 'tramp-own-remote-path remote-path))
+ (default-remote-path
+ (when elt1
+ (or
+ (tramp-send-command-and-read
+ vec "echo \\\"`getconf PATH 2>/dev/null`\\\"" 'noerror)
+ ;; Default if "getconf" is not available.
+ (progn
+ (tramp-message
+ vec 3
+ "`getconf PATH' not successful, using default value \"%s\"."
+ "/bin:/usr/bin")
+ "/bin:/usr/bin"))))
+ (own-remote-path
+ ;; The login shell could return more than just the $PATH
+ ;; string. So we use `tramp-end-of-heredoc' as marker.
+ (when elt2
+ (or
+ (tramp-send-command-and-read
+ vec
+ (format
+ "%s %s %s 'echo %s \\\"$PATH\\\"'"
+ (tramp-get-method-parameter vec 'tramp-remote-shell)
+ (mapconcat
+ #'identity
+ (tramp-get-method-parameter vec 'tramp-remote-shell-login)
+ " ")
+ (mapconcat
+ #'identity
+ (tramp-get-method-parameter vec 'tramp-remote-shell-args)
+ " ")
+ (tramp-shell-quote-argument tramp-end-of-heredoc))
+ 'noerror (regexp-quote tramp-end-of-heredoc))
+ (progn
+ (tramp-message
+ vec 2 "Could not retrieve `tramp-own-remote-path'")
+ nil)))))
+
+ ;; Replace place holder `tramp-default-remote-path'.
+ (when elt1
+ (setcdr elt1
+ (append
+ (split-string (or default-remote-path "") ":" 'omit)
+ (cdr elt1)))
+ (setq remote-path (delq 'tramp-default-remote-path remote-path)))
+
+ ;; Replace place holder `tramp-own-remote-path'.
+ (when elt2
+ (setcdr elt2
+ (append
+ (split-string (or own-remote-path "") ":" 'omit)
+ (cdr elt2)))
+ (setq remote-path (delq 'tramp-own-remote-path remote-path)))
+
+ ;; Remove double entries.
+ (setq elt1 remote-path)
+ (while (consp elt1)
+ (while (and (car elt1) (setq elt2 (member (car elt1) (cdr elt1))))
+ (setcar elt2 nil))
+ (setq elt1 (cdr elt1)))
+
+ ;; Remove non-existing directories.
+ (delq
+ nil
+ (mapcar
+ (lambda (x)
+ (and
+ (stringp x)
+ (file-directory-p (tramp-make-tramp-file-name vec x 'nohop))
x))
- x))
- remote-path)))))
+ remote-path))))))
(defun tramp-get-remote-locale (vec)
"Determine remote locale, supporting UTF8 if possible."
@@ -5264,8 +5396,8 @@ Nonexistent directories are removed from spec."
(with-current-buffer (tramp-get-connection-buffer vec)
(while candidates
(goto-char (point-min))
- (if (string-match (format "^%s\r?$" (regexp-quote (car candidates)))
- (buffer-string))
+ (if (string-match-p (format "^%s\r?$" (regexp-quote (car candidates)))
+ (buffer-string))
(setq locale (car candidates)
candidates nil)
(setq candidates (cdr candidates)))))
@@ -5285,7 +5417,7 @@ Nonexistent directories are removed from spec."
;; Check parameters. On busybox, "ls" output coloring is
;; enabled by default sometimes. So we try to disable it
;; when possible. $LS_COLORING is not supported there.
- ;; Some "ls" versions are sensible wrt the order of
+ ;; Some "ls" versions are sensitive to the order of
;; arguments, they fail when "-al" is after the
;; "--color=never" argument (for example on FreeBSD).
(when (tramp-send-command-and-check
@@ -5298,36 +5430,23 @@ Nonexistent directories are removed from spec."
(setq dl (cdr dl))))))
(tramp-error vec 'file-error "Couldn't find a proper `ls' command"))))
-(defun tramp-get-ls-command-with-dired (vec)
- "Check, whether the remote `ls' command supports the --dired option."
- (save-match-data
- (with-tramp-connection-property vec "ls-dired"
- (tramp-message vec 5 "Checking, whether `ls --dired' works")
- ;; Some "ls" versions are sensible wrt the order of arguments,
- ;; they fail when "-al" is after the "--dired" argument (for
- ;; example on FreeBSD).
- (tramp-send-command-and-check
- vec (format "%s --dired -al /dev/null" (tramp-get-ls-command vec))))))
-
-(defun tramp-get-ls-command-with-quoting-style (vec)
- "Check, whether the remote `ls' command supports the --quoting-style option."
- (save-match-data
- (with-tramp-connection-property vec "ls-quoting-style"
- (tramp-message vec 5 "Checking, whether `ls --quoting-style=shell' works")
+(defun tramp-get-ls-command-with (vec option)
+ "Return OPTION, if the remote `ls' command supports the OPTION option."
+ (with-tramp-connection-property vec (concat "ls" option)
+ (tramp-message vec 5 "Checking, whether `ls %s' works" option)
+ ;; Some "ls" versions are sensitive to the order of arguments,
+ ;; they fail when "-al" is after the "--dired" argument (for
+ ;; example on FreeBSD). Busybox does not support this kind of
+ ;; options.
+ (and
+ (not
(tramp-send-command-and-check
- vec (format "%s --quoting-style=shell -al /dev/null"
- (tramp-get-ls-command vec))))))
-
-(defun tramp-get-ls-command-with-w-option (vec)
- "Check, whether the remote `ls' command supports the -w option."
- (save-match-data
- (with-tramp-connection-property vec "ls-w-option"
- (tramp-message vec 5 "Checking, whether `ls -w' works")
- ;; Option "-w" is available on BSD systems. No argument is
- ;; given, because this could return wrong results in case "ls"
- ;; supports the "-w NUM" argument, as for busyboxes.
- (tramp-send-command-and-check
- vec (format "%s -alw" (tramp-get-ls-command vec))))))
+ vec
+ (format
+ "%s --help 2>&1 | grep -iq busybox" (tramp-get-ls-command vec))))
+ (tramp-send-command-and-check
+ vec (format "%s %s -al /dev/null" (tramp-get-ls-command vec) option))
+ option)))
(defun tramp-get-test-command (vec)
"Determine remote `test' command."
@@ -5349,7 +5468,7 @@ Nonexistent directories are removed from spec."
vec (format "( %s / -nt / )" (tramp-get-test-command vec)))
(with-current-buffer (tramp-get-buffer vec)
(goto-char (point-min))
- (when (looking-at (regexp-quote tramp-end-of-output))
+ (when (looking-at-p (regexp-quote tramp-end-of-output))
(format "%s %%s -nt %%s" (tramp-get-test-command vec)))))
(progn
(tramp-send-command
@@ -5411,7 +5530,7 @@ Nonexistent directories are removed from spec."
tmp (tramp-send-command-and-read
vec (format "%s -c '(\"%%N\" %%s)' /" result) 'noerror))
(unless (and (listp tmp) (stringp (car tmp))
- (string-match "^\\(`/'\\|‘/’\\)$" (car tmp))
+ (string-match-p "^\\(`/'\\|‘/’\\)$" (car tmp))
(integerp (cadr tmp)))
(setq result nil)))
result)))
@@ -5456,7 +5575,7 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil."
"%s -t %s %s"
result
(format-time-string "%Y%m%d%H%M.%S")
- (file-remote-p tmpfile 'localname))))
+ (tramp-compat-file-local-name tmpfile))))
(delete-file tmpfile))
result)))
@@ -5464,12 +5583,30 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil."
"Determine remote `df' command."
(with-tramp-connection-property vec "df"
(tramp-message vec 5 "Finding a suitable `df' command")
- (let ((result (tramp-find-executable vec "df" (tramp-get-remote-path vec))))
- (and
- result
- (tramp-send-command-and-check
- vec (format "%s --block-size=1 --output=size,used,avail /" result))
- result))))
+ (let ((df (tramp-find-executable vec "df" (tramp-get-remote-path vec)))
+ result)
+ (when df
+ (cond
+ ;; coreutils.
+ ((tramp-send-command-and-check
+ vec
+ (format
+ "%s /"
+ (setq result
+ (format "%s --block-size=1 --output=size,used,avail" df))))
+ (tramp-set-connection-property vec "df-blocksize" 1)
+ result)
+ ;; POSIX.1
+ ((tramp-send-command-and-check
+ vec (format "%s /" (setq result (format "%s -k" df))))
+ (tramp-set-connection-property vec "df-blocksize" 1024)
+ result))))))
+
+(defun tramp-get-remote-gio-monitor (vec)
+ "Determine remote `gio-monitor' command."
+ (with-tramp-connection-property vec "gio-monitor"
+ (tramp-message vec 5 "Finding a suitable `gio-monitor' command")
+ (tramp-find-executable vec "gio" (tramp-get-remote-path vec) t t)))
(defun tramp-get-remote-gvfs-monitor-dir (vec)
"Determine remote `gvfs-monitor-dir' command."
@@ -5539,7 +5676,7 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil."
(tramp-get-remote-python vec)
(if (equal id-format 'integer)
"import os; print (os.getuid())"
- "import os, pwd; print ('\\\"' + pwd.getpwuid(os.getuid())[0] + '\\\"')"))))
+ "import os, pwd; print ('\\\"' + pwd.getpwuid(os.getuid())[0] + '\\\"')"))))
(defun tramp-get-remote-uid (vec id-format)
"The uid of the remote connection VEC, in ID-FORMAT.
@@ -5590,7 +5727,7 @@ ID-FORMAT valid values are `string' and `integer'."
(tramp-get-remote-python vec)
(if (equal id-format 'integer)
"import os; print (os.getgid())"
- "import os, grp; print ('\\\"' + grp.getgrgid(os.getgid())[0] + '\\\"')"))))
+ "import os, grp; print ('\\\"' + grp.getgrgid(os.getgid())[0] + '\\\"')"))))
(defun tramp-get-remote-gid (vec id-format)
"The gid of the remote connection VEC, in ID-FORMAT.
@@ -5656,14 +5793,14 @@ function cell is returned to be applied on a buffer."
(tramp-find-inline-encoding vec)
(tramp-get-connection-property
(tramp-get-connection-process vec) prop nil)))
- (prop1 (if (string-match "encoding" prop)
+ (prop1 (if (string-match-p "encoding" prop)
"inline-compress" "inline-decompress"))
compress)
;; The connection property might have been cached. So we must
;; send the script to the remote side - maybe.
- (when (and coding (symbolp coding) (string-match "remote" prop))
+ (when (and coding (symbolp coding) (string-match-p "remote" prop))
(let ((name (symbol-name coding)))
- (while (string-match (regexp-quote "-") name)
+ (while (string-match "-" name)
(setq name (replace-match "_" nil t name)))
(tramp-maybe-send-script vec (symbol-value coding) name)
(setq coding name)))
@@ -5673,35 +5810,35 @@ function cell is returned to be applied on a buffer."
;; Return the value.
(cond
((and compress (symbolp coding))
- (if (string-match "decompress" prop1)
+ (if (string-match-p "decompress" prop1)
`(lambda (beg end)
(,coding beg end)
(let ((coding-system-for-write 'binary)
(coding-system-for-read 'binary))
(apply
- 'tramp-call-process-region ',vec (point-min) (point-max)
+ #'tramp-call-process-region ',vec (point-min) (point-max)
(car (split-string ,compress)) t t nil
(cdr (split-string ,compress)))))
`(lambda (beg end)
(let ((coding-system-for-write 'binary)
(coding-system-for-read 'binary))
(apply
- 'tramp-call-process-region ',vec beg end
+ #'tramp-call-process-region ',vec beg end
(car (split-string ,compress)) t t nil
(cdr (split-string ,compress))))
(,coding (point-min) (point-max)))))
((symbolp coding)
coding)
- ((and compress (string-match "decoding" prop))
+ ((and compress (string-match-p "decoding" prop))
(format
;; Windows shells need the program file name after
;; the pipe symbol be quoted if they use forward
;; slashes as directory separators.
(cond
- ((and (string-match "local" prop)
+ ((and (string-match-p "local" prop)
(memq system-type '(windows-nt)))
"(%s | \"%s\")")
- ((string-match "local" prop) "(%s | %s)")
+ ((string-match-p "local" prop) "(%s | %s)")
(t "(%s | %s >%%s)"))
coding compress))
(compress
@@ -5709,14 +5846,14 @@ function cell is returned to be applied on a buffer."
;; Windows shells need the program file name after
;; the pipe symbol be quoted if they use forward
;; slashes as directory separators.
- (if (and (string-match "local" prop)
+ (if (and (string-match-p "local" prop)
(memq system-type '(windows-nt)))
"(%s <%%s | \"%s\")"
"(%s <%%s | %s)")
compress coding))
- ((string-match "decoding" prop)
+ ((string-match-p "decoding" prop)
(cond
- ((string-match "local" prop) (format "%s" coding))
+ ((string-match-p "local" prop) (format "%s" coding))
(t (format "%s >%%s" coding))))
(t
(format "%s <%%s" coding)))))))
@@ -5740,10 +5877,6 @@ function cell is returned to be applied on a buffer."
;; gets confused about the file locking status. Try to find out why
;; the workaround doesn't work.
;;
-;; * Allow out-of-band methods as _last_ multi-hop. Open a connection
-;; until the last but one hop via `start-file-process'. Apply it
-;; also for ftp and smb.
-;;
;; * WIBNI if we had a command "trampclient"? If I was editing in
;; some shell with root privileges, it would be nice if I could
;; just call
@@ -5817,5 +5950,9 @@ function cell is returned to be applied on a buffer."
;; which could immediately be passed on to the remote side, and
;; later on checks the return value of those calls as and when
;; needed. (Stefan Monnier)
+;;
+;; * Implement detaching/re-attaching remote sessions. By this, a
+;; session could be reused after a connection loss. Use dtach, or
+;; screen, or tmux, or mosh.
;;; tramp-sh.el ends here
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index 894c0de4aa7..66476305c2b 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -27,6 +27,7 @@
;;; Code:
+(eval-when-compile (require 'cl-lib))
(require 'tramp)
;; Define SMB method ...
@@ -37,45 +38,39 @@
;; ... and add it to the method list.
;;;###tramp-autoload
(unless (memq system-type '(cygwin windows-nt))
- (add-to-list 'tramp-methods
- `(,tramp-smb-method
- ;; We define an empty command, because `tramp-smb-call-winexe'
- ;; opens already the powershell. Used in `tramp-handle-shell-command'.
- (tramp-remote-shell "")
- ;; This is just a guess. We don't know whether the share "C$"
- ;; is available for public use, and whether the user has write
- ;; access.
- (tramp-tmpdir "/C$/Temp")
- ;; Another guess. We might implement a better check later on.
- (tramp-case-insensitive t))))
+ (tramp--with-startup
+ (add-to-list 'tramp-methods
+ `(,tramp-smb-method
+ ;; This is just a guess. We don't know whether the share "C$"
+ ;; is available for public use, and whether the user has write
+ ;; access.
+ (tramp-tmpdir "/C$/Temp")
+ ;; Another guess. We might implement a better check later on.
+ (tramp-case-insensitive t)))))
;; Add a default for `tramp-default-user-alist'. Rule: For the SMB method,
;; the anonymous user is chosen.
;;;###tramp-autoload
-(add-to-list 'tramp-default-user-alist
- `(,(concat "\\`" tramp-smb-method "\\'") nil nil))
+(tramp--with-startup
+ (add-to-list 'tramp-default-user-alist
+ `(,(concat "\\`" tramp-smb-method "\\'") nil nil))
-;; Add completion function for SMB method.
-;;;###tramp-autoload
-(eval-after-load 'tramp
- '(tramp-set-completion-function
- tramp-smb-method
- '((tramp-parse-netrc "~/.netrc"))))
+ ;; Add completion function for SMB method.
+ (tramp-set-completion-function
+ tramp-smb-method
+ '((tramp-parse-netrc "~/.netrc"))))
-;;;###tramp-autoload
(defcustom tramp-smb-program "smbclient"
"Name of SMB client to run."
:group 'tramp
:type 'string)
-;;;###tramp-autoload
(defcustom tramp-smb-acl-program "smbcacls"
"Name of SMB acls to run."
:group 'tramp
:type 'string
:version "24.4")
-;;;###tramp-autoload
(defcustom tramp-smb-conf "/dev/null"
"Path of the smb.conf file.
If it is nil, no smb.conf will be added to the `tramp-smb-program'
@@ -101,7 +96,7 @@ call, letting the SMB client use the default one."
(defconst tramp-smb-errors
(mapconcat
- 'identity
+ #'identity
`(;; Connection error / timeout / unknown command.
"Connection\\( to \\S-+\\)? failed"
"Read from server failed, maybe it closed the connection"
@@ -119,6 +114,7 @@ call, letting the SMB client use the default one."
"ERRnoaccess"
"ERRnomem"
"ERRnosuchshare"
+ ;; See /usr/include/samba-4.0/core/ntstatus.h.
;; Windows 4.0 (Windows NT), Windows 5.0 (Windows 2000),
;; Windows 5.1 (Windows XP), Windows 5.2 (Windows Server 2003),
;; Windows 6.0 (Windows Vista), Windows 6.1 (Windows 7),
@@ -129,6 +125,7 @@ call, letting the SMB client use the default one."
"NT_STATUS_CANNOT_DELETE"
"NT_STATUS_CONNECTION_DISCONNECTED"
"NT_STATUS_CONNECTION_REFUSED"
+ "NT_STATUS_CONNECTION_RESET"
"NT_STATUS_DIRECTORY_NOT_EMPTY"
"NT_STATUS_DUPLICATE_NAME"
"NT_STATUS_FILE_IS_A_DIRECTORY"
@@ -143,12 +140,14 @@ call, letting the SMB client use the default one."
"NT_STATUS_NO_LOGON_SERVERS"
"NT_STATUS_NO_SUCH_FILE"
"NT_STATUS_NO_SUCH_USER"
+ "NT_STATUS_NOT_A_DIRECTORY"
"NT_STATUS_OBJECT_NAME_COLLISION"
"NT_STATUS_OBJECT_NAME_INVALID"
"NT_STATUS_OBJECT_NAME_NOT_FOUND"
"NT_STATUS_OBJECT_PATH_SYNTAX_BAD"
"NT_STATUS_PASSWORD_MUST_CHANGE"
"NT_STATUS_RESOURCE_NAME_NOT_FOUND"
+ "NT_STATUS_REVISION_MISMATCH"
"NT_STATUS_SHARING_VIOLATION"
"NT_STATUS_TRUSTED_RELATIONSHIP_FAILURE"
"NT_STATUS_UNSUCCESSFUL"
@@ -211,7 +210,7 @@ See `tramp-actions-before-shell' for more info.")
;; New handlers should be added here.
;;;###tramp-autoload
(defconst tramp-smb-file-name-handler-alist
- '(;; `access-file' performed by default handler.
+ '((access-file . tramp-handle-access-file)
(add-name-to-file . tramp-smb-handle-add-name-to-file)
;; `byte-compiler-base-file-name' performed by default handler.
(copy-directory . tramp-smb-handle-copy-directory)
@@ -225,11 +224,12 @@ See `tramp-actions-before-shell' for more info.")
. tramp-handle-directory-files-and-attributes)
(dired-compress-file . ignore)
(dired-uncache . tramp-handle-dired-uncache)
+ (exec-path . ignore)
(expand-file-name . tramp-smb-handle-expand-file-name)
- (file-accessible-directory-p . tramp-smb-handle-file-directory-p)
+ (file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
(file-acl . tramp-smb-handle-file-acl)
(file-attributes . tramp-smb-handle-file-attributes)
- (file-directory-p . tramp-smb-handle-file-directory-p)
+ (file-directory-p . tramp-handle-file-directory-p)
(file-file-equal-p . tramp-handle-file-equal-p)
(file-executable-p . tramp-handle-file-exists-p)
(file-exists-p . tramp-handle-file-exists-p)
@@ -257,7 +257,6 @@ See `tramp-actions-before-shell' for more info.")
(file-truename . tramp-handle-file-truename)
(file-writable-p . tramp-smb-handle-file-writable-p)
(find-backup-file-name . tramp-handle-find-backup-file-name)
- ;; `find-file-noselect' performed by default handler.
;; `get-file-buffer' performed by default handler.
(insert-directory . tramp-smb-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
@@ -266,6 +265,7 @@ See `tramp-actions-before-shell' for more info.")
(make-directory . tramp-smb-handle-make-directory)
(make-directory-internal . tramp-smb-handle-make-directory-internal)
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
+ (make-process . ignore)
(make-symbolic-link . tramp-smb-handle-make-symbolic-link)
(process-file . tramp-smb-handle-process-file)
(rename-file . tramp-smb-handle-rename-file)
@@ -278,6 +278,7 @@ See `tramp-actions-before-shell' for more info.")
(start-file-process . tramp-smb-handle-start-file-process)
(substitute-in-file-name . tramp-smb-handle-substitute-in-file-name)
(temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-set-file-uid-gid . ignore)
(unhandled-file-name-directory . ignore)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
@@ -286,7 +287,6 @@ See `tramp-actions-before-shell' for more info.")
Operations not mentioned here will be handled by the default Emacs primitives.")
;; Options for remote processes via winexe.
-;;;###tramp-autoload
(defcustom tramp-smb-winexe-program "winexe"
"Name of winexe client to run.
If it isn't found in the local $PATH, the absolute path of winexe
@@ -295,7 +295,6 @@ shall be given. This is needed for remote processes."
:type 'string
:version "24.3")
-;;;###tramp-autoload
(defcustom tramp-smb-winexe-shell-command "powershell.exe"
"Shell to be used for processes on remote machines.
This must be Powershell V2 compatible."
@@ -303,7 +302,6 @@ This must be Powershell V2 compatible."
:type 'string
:version "24.3")
-;;;###tramp-autoload
(defcustom tramp-smb-winexe-shell-command-switch "-file -"
"Command switch used together with `tramp-smb-winexe-shell-command'.
This can be used to disable echo etc."
@@ -316,8 +314,9 @@ This can be used to disable echo etc."
;;;###tramp-autoload
(defsubst tramp-smb-file-name-p (filename)
"Check if it's a filename for SMB servers."
- (string= (tramp-file-name-method (tramp-dissect-file-name filename))
- tramp-smb-method))
+ (and (tramp-tramp-file-p filename)
+ (string= (tramp-file-name-method (tramp-dissect-file-name filename))
+ tramp-smb-method)))
;;;###tramp-autoload
(defun tramp-smb-file-name-handler (operation &rest args)
@@ -331,8 +330,9 @@ pass to the OPERATION."
;;;###tramp-autoload
(unless (memq system-type '(cygwin windows-nt))
- (tramp-register-foreign-file-name-handler
- 'tramp-smb-file-name-p 'tramp-smb-file-name-handler))
+ (tramp--with-startup
+ (tramp-register-foreign-file-name-handler
+ #'tramp-smb-file-name-p #'tramp-smb-file-name-handler)))
;; File name primitives.
@@ -365,8 +365,8 @@ pass to the OPERATION."
(delete-file newname)))
;; We must also flush the cache of the directory, because
;; `file-attributes' reads the values from there.
- (tramp-flush-file-property v2 (file-name-directory v2-localname))
- (tramp-flush-file-property v2 v2-localname)
+ (tramp-flush-file-properties v2 (file-name-directory v2-localname))
+ (tramp-flush-file-properties v2 v2-localname)
(unless
(tramp-smb-send-command
v1
@@ -401,7 +401,7 @@ pass to the OPERATION."
(if copy-contents
;; We must do it file-wise.
(tramp-run-real-handler
- 'copy-directory (list dirname newname keep-date parents copy-contents))
+ #'copy-directory (list dirname newname keep-date parents copy-contents))
(setq dirname (expand-file-name dirname)
newname (expand-file-name newname))
@@ -444,13 +444,6 @@ pass to the OPERATION."
(if (not (file-directory-p newname))
(make-directory newname parents))
- ;; Set variables for computing the prompt for reading password.
- (setq tramp-current-method method
- tramp-current-user user
- tramp-current-domain domain
- tramp-current-host host
- tramp-current-port port)
-
(let* ((share (tramp-smb-get-share v))
(localname (file-name-as-directory
(replace-regexp-in-string
@@ -514,15 +507,15 @@ pass to the OPERATION."
;; password can be handled.
(let* ((default-directory tmpdir)
(p (apply
- 'start-process
+ #'start-process
(tramp-get-connection-name v)
(tramp-get-connection-buffer v)
tramp-smb-program args)))
(tramp-message
- v 6 "%s" (mapconcat 'identity (process-command p) " "))
- (tramp-set-connection-property p "vector" v)
- (process-put p 'adjust-window-size-function 'ignore)
+ v 6 "%s" (mapconcat #'identity (process-command p) " "))
+ (process-put p 'vector v)
+ (process-put p 'adjust-window-size-function #'ignore)
(set-process-query-on-exit-flag p nil)
(tramp-process-actions p v nil tramp-smb-actions-with-tar)
@@ -531,8 +524,8 @@ pass to the OPERATION."
(tramp-message v 6 "\n%s" (buffer-string))))
;; Reset the transfer process properties.
- (tramp-set-connection-property v "process-name" nil)
- (tramp-set-connection-property v "process-buffer" nil)
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer")
(when t1 (delete-directory tmpdir 'recursive))))
;; Handle KEEP-DATE argument.
@@ -549,13 +542,13 @@ pass to the OPERATION."
;; When newname did exist, we have wrong cached values.
(when t2
(with-parsed-tramp-file-name newname nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname))))
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname))))
;; We must do it file-wise.
(t
(tramp-run-real-handler
- 'copy-directory (list dirname newname keep-date parents)))))))))
+ #'copy-directory (list dirname newname keep-date parents)))))))))
(defun tramp-smb-handle-copy-file
(filename newname &optional ok-if-already-exists keep-date
@@ -595,8 +588,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
;; We must also flush the cache of the directory, because
;; `file-attributes' reads the values from there.
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
(unless (tramp-smb-get-share v)
(tramp-error
v 'file-error "Target `%s' must contain a share name" newname))
@@ -630,8 +623,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(with-parsed-tramp-file-name directory nil
;; We must also flush the cache of the directory, because
;; `file-attributes' reads the values from there.
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-directory-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-directory-properties v localname)
(unless (tramp-smb-send-command
v (format
"%s \"%s\""
@@ -656,8 +649,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(with-parsed-tramp-file-name filename nil
;; We must also flush the cache of the directory, because
;; `file-attributes' reads the values from there.
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
(unless (tramp-smb-send-command
v (format
"%s \"%s\""
@@ -673,13 +666,13 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(defun tramp-smb-handle-directory-files
(directory &optional full match nosort)
"Like `directory-files' for Tramp files."
- (let ((result (mapcar 'directory-file-name
+ (let ((result (mapcar #'directory-file-name
(file-name-all-completions "" directory))))
;; Discriminate with regexp.
(when match
(setq result
(delete nil
- (mapcar (lambda (x) (when (string-match match x) x))
+ (mapcar (lambda (x) (when (string-match-p match x) x))
result))))
;; Append directory.
(when full
@@ -688,19 +681,21 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(lambda (x) (format "%s/%s" directory x))
result)))
;; Sort them if necessary.
- (unless nosort (setq result (sort result 'string-lessp)))
+ (unless nosort (setq result (sort result #'string-lessp)))
result))
(defun tramp-smb-handle-expand-file-name (name &optional dir)
"Like `expand-file-name' for Tramp files."
;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
(setq dir (or dir default-directory "/"))
+ ;; Handle empty NAME.
+ (when (zerop (length name)) (setq name "."))
;; Unless NAME is absolute, concat DIR and NAME.
(unless (file-name-absolute-p name)
(setq name (concat (file-name-as-directory dir) name)))
;; If NAME is not a Tramp file, run the real handler.
(if (not (tramp-tramp-file-p name))
- (tramp-run-real-handler 'expand-file-name (list name nil))
+ (tramp-run-real-handler #'expand-file-name (list name nil))
;; Dissect NAME.
(with-parsed-tramp-file-name name nil
;; Tilde expansion if necessary. We use the user name as share,
@@ -713,92 +708,85 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(match-string 1 localname))
nil nil localname)))
;; Make the file name absolute.
- (unless (tramp-run-real-handler 'file-name-absolute-p (list localname))
+ (unless (tramp-run-real-handler #'file-name-absolute-p (list localname))
(setq localname (concat "/" localname)))
;; No tilde characters in file name, do normal
;; `expand-file-name' (this does "/./" and "/../").
(tramp-make-tramp-file-name
- method user domain host port
- (tramp-run-real-handler 'expand-file-name (list localname))))))
+ v (tramp-run-real-handler #'expand-file-name (list localname))))))
(defun tramp-smb-action-get-acl (proc vec)
"Read ACL data from connection buffer."
(unless (process-live-p proc)
;; Accept pending output.
- (while (tramp-accept-process-output proc 0.1))
+ (while (tramp-accept-process-output proc))
(with-current-buffer (tramp-get-connection-buffer vec)
;; There might be a hidden password prompt.
(widen)
(tramp-message vec 10 "\n%s" (buffer-string))
(goto-char (point-min))
- (while (and (not (eobp)) (not (looking-at "^REVISION:")))
+ (while (and (not (eobp)) (not (looking-at-p "^REVISION:")))
(forward-line)
(delete-region (point-min) (point)))
- (while (and (not (eobp)) (looking-at "^.+:.+"))
+ (while (and (not (eobp)) (looking-at-p "^.+:.+"))
(forward-line))
(delete-region (point) (point-max))
(throw 'tramp-action 'ok))))
(defun tramp-smb-handle-file-acl (filename)
"Like `file-acl' for Tramp files."
- (with-parsed-tramp-file-name filename nil
- (with-tramp-file-property v localname "file-acl"
- (when (executable-find tramp-smb-acl-program)
- ;; Set variables for computing the prompt for reading password.
- (setq tramp-current-method method
- tramp-current-user user
- tramp-current-domain domain
- tramp-current-host host
- tramp-current-port port)
-
- (let* ((share (tramp-smb-get-share v))
- (localname (replace-regexp-in-string
- "\\\\" "/" (tramp-smb-get-localname v)))
+ (ignore-errors
+ (with-parsed-tramp-file-name filename nil
+ (with-tramp-file-property v localname "file-acl"
+ (when (executable-find tramp-smb-acl-program)
+ (let* ((share (tramp-smb-get-share v))
+ (localname (replace-regexp-in-string
+ "\\\\" "/" (tramp-smb-get-localname v)))
(args (list (concat "//" host "/" share) "-E"))
;; We do not want to run timers.
timer-list timer-idle-list)
- (if (not (zerop (length user)))
- (setq args (append args (list "-U" user)))
- (setq args (append args (list "-N"))))
+ (if (not (zerop (length user)))
+ (setq args (append args (list "-U" user)))
+ (setq args (append args (list "-N"))))
- (when domain (setq args (append args (list "-W" domain))))
- (when port (setq args (append args (list "-p" port))))
- (when tramp-smb-conf
- (setq args (append args (list "-s" tramp-smb-conf))))
- (setq
- args
- (append args (list (tramp-unquote-shell-quote-argument localname)
- "2>/dev/null")))
-
- (unwind-protect
- (with-temp-buffer
- ;; Set the transfer process properties.
- (tramp-set-connection-property
- v "process-name" (buffer-name (current-buffer)))
- (tramp-set-connection-property
- v "process-buffer" (current-buffer))
-
- ;; Use an asynchronous processes. By this, password
- ;; can be handled.
- (let ((p (apply
- 'start-process
- (tramp-get-connection-name v)
- (tramp-get-connection-buffer v)
- tramp-smb-acl-program args)))
-
- (tramp-message
- v 6 "%s" (mapconcat 'identity (process-command p) " "))
- (tramp-set-connection-property p "vector" v)
- (process-put p 'adjust-window-size-function 'ignore)
- (set-process-query-on-exit-flag p nil)
- (tramp-process-actions p v nil tramp-smb-actions-get-acl)
- (when (> (point-max) (point-min))
- (substring-no-properties (buffer-string)))))
-
- ;; Reset the transfer process properties.
- (tramp-set-connection-property v "process-name" nil)
- (tramp-set-connection-property v "process-buffer" nil)))))))
+ (when domain (setq args (append args (list "-W" domain))))
+ (when port (setq args (append args (list "-p" port))))
+ (when tramp-smb-conf
+ (setq args (append args (list "-s" tramp-smb-conf))))
+ (setq
+ args
+ (append args (list (tramp-unquote-shell-quote-argument localname)
+ "2>/dev/null")))
+
+ (unwind-protect
+ (with-temp-buffer
+ ;; Set the transfer process properties.
+ (tramp-set-connection-property
+ v "process-name" (buffer-name (current-buffer)))
+ (tramp-set-connection-property
+ v "process-buffer" (current-buffer))
+
+ ;; Use an asynchronous process. By this, password can
+ ;; be handled.
+ (let ((p (apply
+ #'start-process
+ (tramp-get-connection-name v)
+ (tramp-get-connection-buffer v)
+ tramp-smb-acl-program args)))
+
+ (tramp-message
+ v 6 "%s" (mapconcat #'identity (process-command p) " "))
+ (process-put p 'vector v)
+ (process-put p 'adjust-window-size-function #'ignore)
+ (set-process-query-on-exit-flag p nil)
+ (tramp-process-actions p v nil tramp-smb-actions-get-acl)
+ (when (> (point-max) (point-min))
+ (substring-no-properties (buffer-string)))))
+
+ ;; Reset the transfer process properties.
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer"))))))))
(defun tramp-smb-handle-file-attributes (filename &optional id-format)
"Like `file-attributes' for Tramp files."
@@ -825,19 +813,19 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
;; Check result.
(when entry
- (list (and (string-match "d" (nth 1 entry))
- t) ;0 file type
- -1 ;1 link count
- uid ;2 uid
- gid ;3 gid
- '(0 0) ;4 atime
- (nth 3 entry) ;5 mtime
- '(0 0) ;6 ctime
- (nth 2 entry) ;7 size
- (nth 1 entry) ;8 mode
- nil ;9 gid weird
- inode ;10 inode number
- device)))))))) ;11 file system number
+ (list (and (string-match-p "d" (nth 1 entry))
+ t) ;0 file type
+ -1 ;1 link count
+ uid ;2 uid
+ gid ;3 gid
+ tramp-time-dont-know ;4 atime
+ (nth 3 entry) ;5 mtime
+ tramp-time-dont-know ;6 ctime
+ (nth 2 entry) ;7 size
+ (nth 1 entry) ;8 mode
+ nil ;9 gid weird
+ inode ;10 inode number
+ device)))))))) ;11 file system number
(defun tramp-smb-do-file-attributes-with-stat (vec &optional id-format)
"Implement `file-attributes' for Tramp files using stat command."
@@ -915,13 +903,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(list id link uid gid atime mtime ctime size mode nil inode
(tramp-get-device vec))))))))
-(defun tramp-smb-handle-file-directory-p (filename)
- "Like `file-directory-p' for Tramp files."
- (and (file-exists-p filename)
- (eq ?d
- (aref (tramp-compat-file-attribute-modes (file-attributes filename))
- 0))))
-
(defun tramp-smb-handle-file-local-copy (filename)
"Like `file-local-copy' for Tramp files."
(with-parsed-tramp-file-name (file-truename filename) nil
@@ -949,15 +930,14 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
filename
(with-parsed-tramp-file-name (expand-file-name directory) nil
(with-tramp-file-property v localname "file-name-all-completions"
- (save-match-data
- (delete-dups
- (mapcar
- (lambda (x)
- (list
- (if (string-match "d" (nth 1 x))
- (file-name-as-directory (nth 0 x))
- (nth 0 x))))
- (tramp-smb-get-file-entries directory))))))))
+ (delete-dups
+ (mapcar
+ (lambda (x)
+ (list
+ (if (string-match-p "d" (nth 1 x))
+ (file-name-as-directory (nth 0 x))
+ (nth 0 x))))
+ (tramp-smb-get-file-entries directory)))))))
(defun tramp-smb-handle-file-system-info (filename)
"Like `file-system-info' for Tramp files."
@@ -972,21 +952,19 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(goto-char (point-min))
(forward-line)
(when (looking-at
- (concat "[[:space:]]*\\([[:digit:]]+\\)"
- " blocks of size \\([[:digit:]]+\\)"
- "\\. \\([[:digit:]]+\\) blocks available"))
- (setq blocksize (string-to-number (concat (match-string 2) "e0"))
- total (* blocksize
- (string-to-number (concat (match-string 1) "e0")))
- avail (* blocksize
- (string-to-number (concat (match-string 3) "e0")))))
+ (eval-when-compile
+ (concat "[[:space:]]*\\([[:digit:]]+\\)"
+ " blocks of size \\([[:digit:]]+\\)"
+ "\\. \\([[:digit:]]+\\) blocks available")))
+ (setq blocksize (string-to-number (match-string 2))
+ total (* blocksize (string-to-number (match-string 1)))
+ avail (* blocksize (string-to-number (match-string 3)))))
(forward-line)
(when (looking-at "Total number of bytes: \\([[:digit:]]+\\)")
;; The used number of bytes is not part of the result. As
;; side effect, we store it as file property.
(tramp-set-file-property
- v localname "used-bytes"
- (string-to-number (concat (match-string 1) "e0"))))
+ v localname "used-bytes" (string-to-number (match-string 1))))
;; Result.
(when (and total avail)
(list total (- total avail) avail)))))))
@@ -994,7 +972,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(defun tramp-smb-handle-file-writable-p (filename)
"Like `file-writable-p' for Tramp files."
(if (file-exists-p filename)
- (string-match
+ (string-match-p
"w"
(or (tramp-compat-file-attribute-modes (file-attributes filename)) ""))
(let ((dir (file-name-directory filename)))
@@ -1014,6 +992,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
;; Called from `dired-add-entry'.
(setq filename (file-name-as-directory filename))
(setq filename (directory-file-name filename)))
+ ;; Check, whether directory is accessible.
+ (unless wildcard
+ (access-file filename "Reading directory"))
(with-parsed-tramp-file-name filename nil
(with-tramp-progress-reporter v 0 (format "Opening directory %s" filename)
(save-match-data
@@ -1046,7 +1027,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
;; Check for matching entries.
(mapcar
(lambda (x)
- (when (string-match
+ (when (string-match-p
(format "^%s" base) (nth 0 x))
x))
entries)
@@ -1058,17 +1039,17 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(sort
entries
(lambda (x y)
- (if (string-match "t" switches)
+ (if (string-match-p "t" switches)
;; Sort by date.
(time-less-p (nth 3 y) (nth 3 x))
;; Sort by name.
(string-lessp (nth 0 x) (nth 0 y))))))
;; Handle "-F" switch.
- (when (string-match "F" switches)
+ (when (string-match-p "F" switches)
(mapc
(lambda (x)
- (when (not (zerop (length (car x))))
+ (unless (zerop (length (car x)))
(cond
((char-equal ?d (string-to-char (nth 1 x)))
(setcar x (concat (car x) "/")))
@@ -1086,7 +1067,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
;; Print entries.
(mapc
(lambda (x)
- (when (not (zerop (length (nth 0 x))))
+ (unless (zerop (length (nth 0 x)))
(let ((attr
(when (tramp-smb-get-stat-capability v)
(ignore-errors
@@ -1094,7 +1075,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(expand-file-name
(nth 0 x) (file-name-directory filename))
'string)))))
- (when (string-match "l" switches)
+ (when (string-match-p "l" switches)
(insert
(format
"%10s %3d %-8s %-8s %8s %s "
@@ -1104,10 +1085,11 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(or (tramp-compat-file-attribute-group-id attr) "nogroup")
(or (tramp-compat-file-attribute-size attr) (nth 2 x))
(format-time-string
- (if (time-less-p (time-subtract (current-time) (nth 3 x))
- tramp-half-a-year)
+ (if (time-less-p
+ ;; Half a year.
+ (time-since (nth 3 x)) (days-to-time 183))
"%b %e %R"
- "%b %e %Y")
+ "%b %e %Y")
(nth 3 x))))) ; date
;; We mark the file name. The inserted name could be
@@ -1124,7 +1106,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(put-text-property start (point) 'dired-filename t))
;; Insert symlink.
- (when (and (string-match "l" switches)
+ (when (and (string-match-p "l" switches)
(stringp (tramp-compat-file-attribute-type attr)))
(insert " -> " (tramp-compat-file-attribute-type attr))))
@@ -1139,18 +1121,17 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(unless (file-name-absolute-p dir)
(setq dir (expand-file-name dir default-directory)))
(with-parsed-tramp-file-name dir nil
- (save-match-data
- (let* ((ldir (file-name-directory dir)))
- ;; Make missing directory parts.
- (when (and parents
- (tramp-smb-get-share v)
- (not (file-directory-p ldir)))
- (make-directory ldir parents))
- ;; Just do it.
- (when (file-directory-p ldir)
- (make-directory-internal dir))
- (unless (file-directory-p dir)
- (tramp-error v 'file-error "Couldn't make directory %s" dir))))))
+ (let* ((ldir (file-name-directory dir)))
+ ;; Make missing directory parts.
+ (when (and parents
+ (tramp-smb-get-share v)
+ (not (file-directory-p ldir)))
+ (make-directory ldir parents))
+ ;; Just do it.
+ (when (file-directory-p ldir)
+ (make-directory-internal dir))
+ (unless (file-directory-p dir)
+ (tramp-error v 'file-error "Couldn't make directory %s" dir)))))
(defun tramp-smb-handle-make-directory-internal (directory)
"Like `make-directory-internal' for Tramp files."
@@ -1158,21 +1139,19 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(unless (file-name-absolute-p directory)
(setq directory (expand-file-name directory default-directory)))
(with-parsed-tramp-file-name directory nil
- (save-match-data
- (let* ((file (tramp-smb-get-localname v)))
- (when (file-directory-p (file-name-directory directory))
- (tramp-smb-send-command
- v
- (if (tramp-smb-get-cifs-capabilities v)
- (format "posix_mkdir \"%s\" %o" file (default-file-modes))
- (format "mkdir \"%s\"" file)))
- ;; We must also flush the cache of the directory, because
- ;; `file-attributes' reads the values from there.
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname))
- (unless (file-directory-p directory)
- (tramp-error
- v 'file-error "Couldn't make directory %s" directory))))))
+ (let* ((file (tramp-smb-get-localname v)))
+ (when (file-directory-p (file-name-directory directory))
+ (tramp-smb-send-command
+ v
+ (if (tramp-smb-get-cifs-capabilities v)
+ (format "posix_mkdir \"%s\" %o" file (default-file-modes))
+ (format "mkdir \"%s\"" file)))
+ ;; We must also flush the cache of the directory, because
+ ;; `file-attributes' reads the values from there.
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname))
+ (unless (file-directory-p directory)
+ (tramp-error v 'file-error "Couldn't make directory %s" directory)))))
(defun tramp-smb-handle-make-symbolic-link
(target linkname &optional ok-if-already-exists)
@@ -1182,7 +1161,7 @@ of the symlink. If TARGET is a Tramp file, only the localname
component is used as the target of the symlink."
(if (not (tramp-tramp-file-p (expand-file-name linkname)))
(tramp-run-real-handler
- 'make-symbolic-link (list target linkname ok-if-already-exists))
+ #'make-symbolic-link (list target linkname ok-if-already-exists))
(with-parsed-tramp-file-name linkname nil
;; If TARGET is a Tramp name, use just the localname component.
@@ -1215,8 +1194,8 @@ component is used as the target of the symlink."
;; We must also flush the cache of the directory, because
;; `file-attributes' reads the values from there.
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
(unless
(tramp-smb-send-command
@@ -1226,7 +1205,7 @@ component is used as the target of the symlink."
(tramp-error
v 'file-error
"error with make-symbolic-link, see buffer `%s' for details"
- (buffer-name)))))))
+ (tramp-get-connection-buffer v)))))))
(defun tramp-smb-handle-process-file
(program &optional infile destination display &rest args)
@@ -1251,8 +1230,7 @@ component is used as the target of the symlink."
(setq input (with-parsed-tramp-file-name infile nil localname))
;; INFILE must be copied to remote host.
(setq input (tramp-make-tramp-temp-file v)
- tmpinput
- (tramp-make-tramp-file-name method user domain host port input))
+ tmpinput (tramp-make-tramp-file-name v input))
(copy-file infile tmpinput t))
;; Transform input into a filename powershell does understand.
(setq input (format "//%s%s" host input)))
@@ -1282,7 +1260,7 @@ component is used as the target of the symlink."
(setq outbuf (current-buffer))))
;; Construct command.
- (setq command (mapconcat 'identity (cons program args) " ")
+ (setq command (mapconcat #'identity (cons program args) " ")
command (if input
(format
"get-content %s | & %s"
@@ -1333,14 +1311,14 @@ component is used as the target of the symlink."
;; Cleanup. We remove all file cache values for the connection,
;; because the remote process could have changed them.
- (tramp-set-connection-property v "process-name" nil)
- (tramp-set-connection-property v "process-buffer" nil)
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer")
(when tmpinput (delete-file tmpinput))
(unless outbuf
(kill-buffer (tramp-get-connection-property v "process-buffer" nil)))
(unless process-file-side-effects
- (tramp-flush-directory-property v ""))
+ (tramp-flush-directory-properties v ""))
;; Return exit status.
(if (equal ret -1)
@@ -1376,10 +1354,10 @@ component is used as the target of the symlink."
;; We must also flush the cache of the directory, because
;; `file-attributes' reads the values from there.
- (tramp-flush-file-property v1 (file-name-directory v1-localname))
- (tramp-flush-file-property v1 v1-localname)
- (tramp-flush-file-property v2 (file-name-directory v2-localname))
- (tramp-flush-file-property v2 v2-localname)
+ (tramp-flush-file-properties v1 (file-name-directory v1-localname))
+ (tramp-flush-file-properties v1 v1-localname)
+ (tramp-flush-file-properties v2 (file-name-directory v2-localname))
+ (tramp-flush-file-properties v2 v2-localname)
(unless (tramp-smb-get-share v2)
(tramp-error
v2 'file-error "Target `%s' must contain a share name" newname))
@@ -1397,10 +1375,10 @@ component is used as the target of the symlink."
(delete-file filename)))))
(defun tramp-smb-action-set-acl (proc vec)
- "Read ACL data from connection buffer."
+ "Set ACL data."
(unless (process-live-p proc)
;; Accept pending output.
- (while (tramp-accept-process-output proc 0.1))
+ (while (tramp-accept-process-output proc))
(with-current-buffer (tramp-get-connection-buffer vec)
(tramp-message vec 10 "\n%s" (buffer-string))
(throw 'tramp-action 'ok))))
@@ -1409,15 +1387,9 @@ component is used as the target of the symlink."
"Like `set-file-acl' for Tramp files."
(ignore-errors
(with-parsed-tramp-file-name filename nil
- (when (and (stringp acl-string) (executable-find tramp-smb-acl-program))
- ;; Set variables for computing the prompt for reading password.
- (setq tramp-current-method method
- tramp-current-user user
- tramp-current-domain domain
- tramp-current-host host
- tramp-current-port port)
- (tramp-set-file-property v localname "file-acl" 'undef)
+ (tramp-flush-file-property v localname "file-acl")
+ (when (and (stringp acl-string) (executable-find tramp-smb-acl-program))
(let* ((share (tramp-smb-get-share v))
(localname (replace-regexp-in-string
"\\\\" "/" (tramp-smb-get-localname v)))
@@ -1452,15 +1424,15 @@ component is used as the target of the symlink."
;; Use an asynchronous process. By this, password can
;; be handled.
(let ((p (apply
- 'start-process
+ #'start-process
(tramp-get-connection-name v)
(tramp-get-connection-buffer v)
tramp-smb-acl-program args)))
(tramp-message
- v 6 "%s" (mapconcat 'identity (process-command p) " "))
- (tramp-set-connection-property p "vector" v)
- (process-put p 'adjust-window-size-function 'ignore)
+ v 6 "%s" (mapconcat #'identity (process-command p) " "))
+ (process-put p 'vector v)
+ (process-put p 'adjust-window-size-function #'ignore)
(set-process-query-on-exit-flag p nil)
(tramp-process-actions p v nil tramp-smb-actions-set-acl)
(goto-char (point-max))
@@ -1478,14 +1450,14 @@ component is used as the target of the symlink."
t)))
;; Reset the transfer process properties.
- (tramp-set-connection-property v "process-name" nil)
- (tramp-set-connection-property v "process-buffer" nil)))))))
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer")))))))
(defun tramp-smb-handle-set-file-modes (filename mode)
"Like `set-file-modes' for Tramp files."
(with-parsed-tramp-file-name filename nil
(when (tramp-smb-get-cifs-capabilities v)
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v localname)
(unless (tramp-smb-send-command
v (format "chmod \"%s\" %o" (tramp-smb-get-localname v) mode))
(tramp-error
@@ -1502,7 +1474,7 @@ component is used as the target of the symlink."
(get-buffer-create buffer)
;; BUFFER can be nil. We use a temporary buffer.
(generate-new-buffer tramp-temp-buffer-name)))
- (command (mapconcat 'identity (cons program args) " "))
+ (command (mapconcat #'identity (cons program args) " "))
(bmp (and (buffer-live-p buffer) (buffer-modified-p buffer)))
(name1 name)
(i 0)
@@ -1535,13 +1507,13 @@ component is used as the target of the symlink."
;; Save exit.
(with-current-buffer (tramp-get-connection-buffer v)
- (if (string-match tramp-temp-buffer-name (buffer-name))
+ (if (string-match-p tramp-temp-buffer-name (buffer-name))
(progn
(set-process-buffer (tramp-get-connection-process v) nil)
(kill-buffer (current-buffer)))
(set-buffer-modified-p bmp)))
- (tramp-set-connection-property v "process-name" nil)
- (tramp-set-connection-property v "process-buffer" nil)))))
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer")))))
(defun tramp-smb-handle-substitute-in-file-name (filename)
"Like `handle-substitute-in-file-name' for Tramp files.
@@ -1557,7 +1529,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows."
(concat (file-remote-p filename)
(replace-match "\\1" nil nil localname)))))
(condition-case nil
- (tramp-run-real-handler 'substitute-in-file-name (list filename))
+ (tramp-run-real-handler #'substitute-in-file-name (list filename))
(error filename))))
(defun tramp-smb-handle-write-region
@@ -1574,8 +1546,8 @@ errors for shares like \"C$/\", which are common in Microsoft Windows."
;; We must also flush the cache of the directory, because
;; `file-attributes' reads the values from there.
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
(let ((curbuf (current-buffer))
(tmpfile (tramp-compat-make-temp-file filename)))
(when (and append (file-exists-p filename))
@@ -1584,7 +1556,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows."
;; modtime data to be clobbered from the temp file. We call
;; `set-visited-file-modtime' ourselves later on.
(tramp-run-real-handler
- 'write-region (list start end tmpfile append 'no-message lockname))
+ #'write-region (list start end tmpfile append 'no-message lockname))
(with-tramp-progress-reporter
v 3 (format "Moving tmp file %s to %s" tmpfile filename)
@@ -1644,6 +1616,13 @@ If VEC has no cifs capabilities, exchange \"/\" by \"\\\\\"."
(when (string-match "\\(\\$\\$\\)\\(/\\|$\\)" localname)
(setq localname (replace-match "$" nil nil localname 1)))
+ ;; A period followed by a space, or trailing periods and spaces,
+ ;; are not supported.
+ (when (string-match-p "\\. \\|\\.$\\| $" localname)
+ (tramp-error
+ vec 'file-error
+ "Invalid file name %s" (tramp-make-tramp-file-name vec localname)))
+
localname)))
;; Share names of a host are cached. It is very unlikely that the
@@ -1793,7 +1772,7 @@ Result is the list (LOCALNAME MODE SIZE MTIME)."
(cl-return))
;; weekday.
- (if (string-match "\\(\\w+\\)$" line)
+ (if (string-match-p "\\(\\w+\\)$" line)
(setq line (substring line 0 -5))
(cl-return))
@@ -1814,12 +1793,12 @@ Result is the list (LOCALNAME MODE SIZE MTIME)."
(if (string-match "\\([ACDEHNORrsSTV]+\\)?$" line)
(setq
mode (or (match-string 1 line) "")
- mode (save-match-data (format
+ mode (format
"%s%s"
- (if (string-match "D" mode) "d" "-")
+ (if (string-match-p "D" mode) "d" "-")
(mapconcat
(lambda (_x) "") " "
- (concat "r" (if (string-match "R" mode) "-" "w") "x"))))
+ (concat "r" (if (string-match-p "R" mode) "-" "w") "x")))
line (substring line 0 -6))
(cl-return))
@@ -1835,7 +1814,7 @@ Result is the list (LOCALNAME MODE SIZE MTIME)."
sec min hour day
(cdr (assoc (downcase month) parse-time-months))
year)
- '(0 0)))
+ tramp-time-dont-know))
(list localname mode size mtime))))
(defun tramp-smb-get-cifs-capabilities (vec)
@@ -1908,8 +1887,8 @@ If ARGUMENT is non-nil, use it as argument for
tramp-smb-version
(tramp-get-connection-property
vec "smbclient-version" tramp-smb-version))
- (tramp-flush-directory-property vec "")
- (tramp-flush-connection-property vec))
+ (tramp-flush-directory-properties vec "")
+ (tramp-flush-connection-properties vec))
(tramp-set-connection-property
vec "smbclient-version" tramp-smb-version)))
@@ -1919,11 +1898,11 @@ If ARGUMENT is non-nil, use it as argument for
;; connection timeout.
(with-current-buffer buf
(goto-char (point-min))
- (when (and (> (tramp-time-diff
- (current-time)
- (tramp-get-connection-property
- p "last-cmd-time" '(0 0 0)))
- 60)
+ ;; `seconds-to-time' can be removed once we get rid of Emacs 24.
+ (when (and (time-less-p (seconds-to-time 60)
+ (time-since
+ (tramp-get-connection-property
+ p "last-cmd-time" (seconds-to-time 0))))
(process-live-p p)
(re-search-forward tramp-smb-errors nil t))
(delete-process p)
@@ -1936,6 +1915,14 @@ If ARGUMENT is non-nil, use it as argument for
share
(tramp-get-connection-property p "smb-share" ""))))
+ ;; During completion, don't reopen a new connection. We
+ ;; check this for the process related to
+ ;; `tramp-buffer-name'; otherwise `start-file-process'
+ ;; wouldn't run ever when `non-essential' is non-nil.
+ (when (and (tramp-completion-mode-p)
+ (null (get-process (tramp-buffer-name vec))))
+ (throw 'non-essential 'non-essential))
+
(save-match-data
;; There might be unread output from checking for share names.
(when buf (with-current-buffer buf (erase-buffer)))
@@ -1985,18 +1972,11 @@ If ARGUMENT is non-nil, use it as argument for
args))))
(tramp-message
- vec 6 "%s" (mapconcat 'identity (process-command p) " "))
- (tramp-set-connection-property p "vector" vec)
- (process-put p 'adjust-window-size-function 'ignore)
+ vec 6 "%s" (mapconcat #'identity (process-command p) " "))
+ (process-put p 'vector vec)
+ (process-put p 'adjust-window-size-function #'ignore)
(set-process-query-on-exit-flag p nil)
- ;; Set variables for computing the prompt for reading password.
- (setq tramp-current-method tramp-smb-method
- tramp-current-user user
- tramp-current-domain domain
- tramp-current-host host
- tramp-current-port port)
-
(condition-case err
(let (tramp-message-show-message)
;; Play login scenario.
@@ -2007,20 +1987,22 @@ If ARGUMENT is non-nil, use it as argument for
tramp-smb-actions-without-share))
;; Check server version.
- (unless argument
- (with-current-buffer (tramp-get-connection-buffer vec)
- (goto-char (point-min))
- (search-forward-regexp tramp-smb-server-version nil t)
- (let ((smbserver-version (match-string 0)))
- (unless
- (string-equal
- smbserver-version
- (tramp-get-connection-property
- vec "smbserver-version" smbserver-version))
- (tramp-flush-directory-property vec "")
- (tramp-flush-connection-property vec))
- (tramp-set-connection-property
- vec "smbserver-version" smbserver-version))))
+ ;; FIXME: With recent smbclient versions, this
+ ;; information isn't printed anymore.
+ ;; (unless argument
+ ;; (with-current-buffer (tramp-get-connection-buffer vec)
+ ;; (goto-char (point-min))
+ ;; (search-forward-regexp tramp-smb-server-version nil t)
+ ;; (let ((smbserver-version (match-string 0)))
+ ;; (unless
+ ;; (string-equal
+ ;; smbserver-version
+ ;; (tramp-get-connection-property
+ ;; vec "smbserver-version" smbserver-version))
+ ;; (tramp-flush-directory-properties vec "")
+ ;; (tramp-flush-connection-properties vec))
+ ;; (tramp-set-connection-property
+ ;; vec "smbserver-version" smbserver-version))))
;; Set chunksize to 1. smbclient reads its input
;; character by character; if we send the string
@@ -2056,51 +2038,27 @@ If ARGUMENT is non-nil, use it as argument for
;; We don't use timeouts. If needed, the caller shall wrap around.
(defun tramp-smb-wait-for-output (vec)
"Wait for output from smbclient command.
-Returns nil if an error message has appeared."
+Removes smb prompt. Returns nil if an error message has appeared."
(with-current-buffer (tramp-get-connection-buffer vec)
(let ((p (get-buffer-process (current-buffer)))
- (found (progn (goto-char (point-min))
- (re-search-forward tramp-smb-prompt nil t)))
- (err (progn (goto-char (point-min))
- (re-search-forward tramp-smb-errors nil t)))
- buffer-read-only)
-
- ;; Algorithm: get waiting output. See if last line contains
- ;; `tramp-smb-prompt' sentinel or `tramp-smb-errors' strings.
- ;; If not, wait a bit and again get waiting output.
- (while (and (not found) (not err) (process-live-p p))
-
- ;; Accept pending output.
- (tramp-accept-process-output p 0.1)
-
- ;; Search for prompt.
- (goto-char (point-min))
- (setq found (re-search-forward tramp-smb-prompt nil t))
-
- ;; Search for errors.
- (goto-char (point-min))
- (setq err (re-search-forward tramp-smb-errors nil t)))
-
- ;; When the process is still alive, read pending output.
- (while (and (not found) (process-live-p p))
-
- ;; Accept pending output.
- (tramp-accept-process-output p 0.1)
-
- ;; Search for prompt.
- (goto-char (point-min))
- (setq found (re-search-forward tramp-smb-prompt nil t)))
+ (inhibit-read-only t))
+ ;; Read pending output.
+ (while (not (re-search-forward tramp-smb-prompt nil t))
+ (while (tramp-accept-process-output p 0)
+ (goto-char (point-min))))
(tramp-message vec 6 "\n%s" (buffer-string))
;; Remove prompt.
- (when found
+ (goto-char (point-min))
+ (when (re-search-forward tramp-smb-prompt nil t)
(goto-char (point-max))
(re-search-backward tramp-smb-prompt nil t)
(delete-region (point) (point-max)))
;; Return value is whether no error message has appeared.
- (not err))))
+ (goto-char (point-min))
+ (not (re-search-forward tramp-smb-errors nil t)))))
(defun tramp-smb-kill-winexe-function ()
"Send SIGKILL to the winexe process."
@@ -2111,7 +2069,6 @@ Returns nil if an error message has appeared."
(defun tramp-smb-call-winexe (vec)
"Apply a remote command, if possible, using `tramp-smb-winexe-program'."
-
;; Check for program.
(unless (executable-find tramp-smb-winexe-program)
(tramp-error
diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el
new file mode 100644
index 00000000000..0d9e04d0bd1
--- /dev/null
+++ b/lisp/net/tramp-sudoedit.el
@@ -0,0 +1,893 @@
+;;; tramp-sudoedit.el --- Functions for accessing under root permissions -*- lexical-binding:t -*-
+
+;; Copyright (C) 2018-2019 Free Software Foundation, Inc.
+
+;; Author: Michael Albinus <michael.albinus@gmx.de>
+;; Keywords: comm, processes
+;; Package: tramp
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; The "sudoedit" Tramp method allows to edit a file as a different
+;; user on the local host. Contrary to the "sudo" method, all magic
+;; file name functions are implemented by single "sudo ..." commands.
+;; The purpose is to make editing such a file as secure as possible;
+;; there must be no session running in the Emacs background which
+;; could be attacked from inside Emacs.
+
+;; Consequently, external processes are not implemented.
+
+;;; Code:
+
+(require 'tramp)
+
+;;;###tramp-autoload
+(defconst tramp-sudoedit-method "sudoedit"
+ "When this method name is used, call sudoedit for editing a file.")
+
+;;;###tramp-autoload
+(tramp--with-startup
+ (add-to-list 'tramp-methods
+ `(,tramp-sudoedit-method
+ (tramp-sudo-login (("sudo") ("-u" "%u") ("-S") ("-H")
+ ("-p" "Password:") ("--")))))
+
+ (add-to-list 'tramp-default-user-alist '("\\`sudoedit\\'" nil "root"))
+
+ (tramp-set-completion-function
+ tramp-sudoedit-method tramp-completion-function-alist-su))
+
+(defconst tramp-sudoedit-sudo-actions
+ '((tramp-password-prompt-regexp tramp-action-password)
+ (tramp-wrong-passwd-regexp tramp-action-permission-denied)
+ (tramp-process-alive-regexp tramp-sudoedit-action-sudo))
+ "List of pattern/action pairs.
+This list is used for sudo calls.
+
+See `tramp-actions-before-shell' for more info.")
+
+;;;###tramp-autoload
+(defconst tramp-sudoedit-file-name-handler-alist
+ '((access-file . tramp-handle-access-file)
+ (add-name-to-file . tramp-sudoedit-handle-add-name-to-file)
+ (byte-compiler-base-file-name . ignore)
+ ;; `copy-directory' performed by default handler.
+ (copy-file . tramp-sudoedit-handle-copy-file)
+ (delete-directory . tramp-sudoedit-handle-delete-directory)
+ (delete-file . tramp-sudoedit-handle-delete-file)
+ (diff-latest-backup-file . ignore)
+ ;; `directory-file-name' performed by default handler.
+ (directory-files . tramp-handle-directory-files)
+ (directory-files-and-attributes
+ . tramp-handle-directory-files-and-attributes)
+ (dired-compress-file . ignore)
+ (dired-uncache . tramp-handle-dired-uncache)
+ (exec-path . ignore)
+ (expand-file-name . tramp-sudoedit-handle-expand-file-name)
+ (file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
+ (file-acl . tramp-sudoedit-handle-file-acl)
+ (file-attributes . tramp-sudoedit-handle-file-attributes)
+ (file-directory-p . tramp-handle-file-directory-p)
+ (file-equal-p . tramp-handle-file-equal-p)
+ (file-executable-p . tramp-sudoedit-handle-file-executable-p)
+ (file-exists-p . tramp-sudoedit-handle-file-exists-p)
+ (file-in-directory-p . tramp-handle-file-in-directory-p)
+ (file-local-copy . tramp-handle-file-local-copy)
+ (file-modes . tramp-handle-file-modes)
+ (file-name-all-completions
+ . tramp-sudoedit-handle-file-name-all-completions)
+ (file-name-as-directory . tramp-handle-file-name-as-directory)
+ (file-name-case-insensitive-p . tramp-handle-file-name-case-insensitive-p)
+ (file-name-completion . tramp-handle-file-name-completion)
+ (file-name-directory . tramp-handle-file-name-directory)
+ (file-name-nondirectory . tramp-handle-file-name-nondirectory)
+ ;; `file-name-sans-versions' performed by default handler.
+ (file-newer-than-file-p . tramp-handle-file-newer-than-file-p)
+ (file-notify-add-watch . ignore)
+ (file-notify-rm-watch . ignore)
+ (file-notify-valid-p . ignore)
+ (file-ownership-preserved-p . ignore)
+ (file-readable-p . tramp-sudoedit-handle-file-readable-p)
+ (file-regular-p . tramp-handle-file-regular-p)
+ (file-remote-p . tramp-handle-file-remote-p)
+ (file-selinux-context . tramp-sudoedit-handle-file-selinux-context)
+ (file-symlink-p . tramp-handle-file-symlink-p)
+ (file-system-info . tramp-sudoedit-handle-file-system-info)
+ (file-truename . tramp-sudoedit-handle-file-truename)
+ (file-writable-p . tramp-sudoedit-handle-file-writable-p)
+ (find-backup-file-name . tramp-handle-find-backup-file-name)
+ ;; `get-file-buffer' performed by default handler.
+ (insert-directory . tramp-handle-insert-directory)
+ (insert-file-contents . tramp-handle-insert-file-contents)
+ (load . tramp-handle-load)
+ (make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
+ (make-directory . tramp-sudoedit-handle-make-directory)
+ (make-directory-internal . ignore)
+ (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
+ (make-process . ignore)
+ (make-symbolic-link . tramp-sudoedit-handle-make-symbolic-link)
+ (process-file . ignore)
+ (rename-file . tramp-sudoedit-handle-rename-file)
+ (set-file-acl . tramp-sudoedit-handle-set-file-acl)
+ (set-file-modes . tramp-sudoedit-handle-set-file-modes)
+ (set-file-selinux-context . tramp-sudoedit-handle-set-file-selinux-context)
+ (set-file-times . tramp-sudoedit-handle-set-file-times)
+ (set-visited-file-modtime . tramp-handle-set-visited-file-modtime)
+ (shell-command . ignore)
+ (start-file-process . ignore)
+ (substitute-in-file-name . tramp-handle-substitute-in-file-name)
+ (temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-set-file-uid-gid . tramp-sudoedit-handle-set-file-uid-gid)
+ (unhandled-file-name-directory . ignore)
+ (vc-registered . ignore)
+ (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
+ (write-region . tramp-sudoedit-handle-write-region))
+ "Alist of handler functions for Tramp SUDOEDIT method.")
+
+;; It must be a `defsubst' in order to push the whole code into
+;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading.
+;;;###tramp-autoload
+(defsubst tramp-sudoedit-file-name-p (filename)
+ "Check if it's a filename for SUDOEDIT."
+ (and (tramp-tramp-file-p filename)
+ (string= (tramp-file-name-method (tramp-dissect-file-name filename))
+ tramp-sudoedit-method)))
+
+;;;###tramp-autoload
+(defun tramp-sudoedit-file-name-handler (operation &rest args)
+ "Invoke the SUDOEDIT handler for OPERATION.
+First arg specifies the OPERATION, second arg is a list of arguments to
+pass to the OPERATION."
+ (let ((fn (assoc operation tramp-sudoedit-file-name-handler-alist)))
+ (if fn
+ (save-match-data (apply (cdr fn) args))
+ (tramp-run-real-handler operation args))))
+
+;;;###tramp-autoload
+(tramp--with-startup
+ (tramp-register-foreign-file-name-handler
+ #'tramp-sudoedit-file-name-p #'tramp-sudoedit-file-name-handler))
+
+
+;; File name primitives.
+
+(defun tramp-sudoedit-handle-add-name-to-file
+ (filename newname &optional ok-if-already-exists)
+ "Like `add-name-to-file' for Tramp files."
+ (unless (tramp-equal-remote filename newname)
+ (with-parsed-tramp-file-name
+ (if (tramp-tramp-file-p filename) filename newname) nil
+ (tramp-error
+ v 'file-error
+ "add-name-to-file: %s"
+ "only implemented for same method, same user, same host")))
+ (with-parsed-tramp-file-name filename v1
+ (with-parsed-tramp-file-name newname v2
+ ;; 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)))
+ (tramp-flush-file-properties v2 (file-name-directory v2-localname))
+ (tramp-flush-file-properties v2 v2-localname)
+ (unless
+ (tramp-sudoedit-send-command
+ v1 "ln"
+ (tramp-compat-file-name-unquote v1-localname)
+ (tramp-compat-file-name-unquote v2-localname))
+ (tramp-error
+ v1 'file-error
+ "error with add-name-to-file, see buffer `%s' for details"
+ (buffer-name))))))
+
+(defun tramp-sudoedit-do-copy-or-rename-file
+ (op filename newname &optional ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes)
+ "Copy or rename a remote file.
+OP must be `copy' or `rename' and indicates the operation to perform.
+FILENAME specifies the file to copy or rename, NEWNAME is the name of
+the new file (for copy) or the new name of the file (for rename).
+OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already.
+KEEP-DATE means to make sure that NEWNAME has the same timestamp
+as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep
+the uid and gid if both files are on the same host.
+PRESERVE-EXTENDED-ATTRIBUTES activates selinux and acl commands.
+
+This function is invoked by `tramp-sudoedit-handle-copy-file' and
+`tramp-sudoedit-handle-rename-file'. It is an error if OP is
+neither of `copy' and `rename'. FILENAME and NEWNAME must be
+absolute file names."
+ (unless (memq op '(copy rename))
+ (error "Unknown operation `%s', must be `copy' or `rename'" op))
+
+ (setq filename (file-truename filename))
+ (if (file-directory-p filename)
+ (progn
+ (copy-directory filename newname keep-date t)
+ (when (eq op 'rename) (delete-directory filename 'recursive)))
+
+ (let ((t1 (tramp-sudoedit-file-name-p filename))
+ (t2 (tramp-sudoedit-file-name-p newname))
+ (file-times (tramp-compat-file-attribute-modification-time
+ (file-attributes filename)))
+ (file-modes (tramp-default-file-modes filename))
+ ;; `file-extended-attributes' exists since Emacs 24.4.
+ (attributes (and preserve-extended-attributes
+ (apply #'file-extended-attributes (list filename))))
+ (sudoedit-operation
+ (cond
+ ((and (eq op 'copy) preserve-uid-gid) '("cp" "-f" "-p"))
+ ((eq op 'copy) '("cp" "-f"))
+ ((eq op 'rename) '("mv" "-f"))))
+ (msg-operation (if (eq op 'copy) "Copying" "Renaming")))
+
+ (with-parsed-tramp-file-name (if t1 filename newname) nil
+ (when (and (not ok-if-already-exists) (file-exists-p newname))
+ (tramp-error v 'file-already-exists newname))
+
+ (if (or (and (file-remote-p filename) (not t1))
+ (and (file-remote-p newname) (not t2)))
+ ;; We cannot copy or rename directly.
+ (let ((tmpfile (tramp-compat-make-temp-file filename)))
+ (if (eq op 'copy)
+ (copy-file filename tmpfile t)
+ (rename-file filename tmpfile t))
+ (rename-file tmpfile newname ok-if-already-exists))
+
+ ;; Direct action.
+ (with-tramp-progress-reporter
+ v 0 (format "%s %s to %s" msg-operation filename newname)
+ (unless (tramp-sudoedit-send-command
+ v sudoedit-operation
+ (tramp-compat-file-name-unquote
+ (tramp-compat-file-local-name filename))
+ (tramp-compat-file-name-unquote
+ (tramp-compat-file-local-name newname)))
+ (tramp-error
+ v 'file-error
+ "Error %s `%s' `%s'" msg-operation filename newname))))
+
+ ;; When `newname' is local, we must change the ownership to
+ ;; the local user.
+ (unless (file-remote-p newname)
+ (tramp-set-file-uid-gid
+ (concat (file-remote-p filename) newname)
+ (tramp-get-local-uid 'integer)
+ (tramp-get-local-gid 'integer)))
+
+ ;; Set the time and mode. Mask possible errors.
+ (when keep-date
+ (ignore-errors
+ (set-file-times newname file-times)
+ (set-file-modes newname file-modes)))
+
+ ;; Handle `preserve-extended-attributes'. We ignore possible
+ ;; errors, because ACL strings could be incompatible.
+ ;; `set-file-extended-attributes' exists since Emacs 24.4.
+ (when attributes
+ (ignore-errors
+ (apply #'set-file-extended-attributes (list newname attributes))))
+
+ (when (and t1 (eq op 'rename))
+ (with-parsed-tramp-file-name filename v1
+ (tramp-flush-file-properties
+ v1 (file-name-directory v1-localname))
+ (tramp-flush-file-properties v1 v1-localname)))
+
+ (when t2
+ (with-parsed-tramp-file-name newname v2
+ (tramp-flush-file-properties
+ v2 (file-name-directory v2-localname))
+ (tramp-flush-file-properties v2 v2-localname)))))))
+
+(defun tramp-sudoedit-handle-copy-file
+ (filename newname &optional ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes)
+ "Like `copy-file' for Tramp files."
+ (setq filename (expand-file-name filename))
+ (setq newname (expand-file-name newname))
+ ;; At least one file a Tramp file?
+ (if (or (tramp-tramp-file-p filename)
+ (tramp-tramp-file-p newname))
+ (tramp-sudoedit-do-copy-or-rename-file
+ 'copy filename newname ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes)
+ (tramp-run-real-handler
+ #'copy-file
+ (list filename newname ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes))))
+
+(defun tramp-sudoedit-handle-delete-directory
+ (directory &optional recursive trash)
+ "Like `delete-directory' for Tramp files."
+ (setq directory (expand-file-name directory))
+ (with-parsed-tramp-file-name directory nil
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-directory-properties v localname)
+ (unless
+ (tramp-sudoedit-send-command
+ v (or (and trash "trash")
+ (if recursive '("rm" "-rf") "rmdir"))
+ (tramp-compat-file-name-unquote localname))
+ (tramp-error v 'file-error "Couldn't delete %s" directory))))
+
+(defun tramp-sudoedit-handle-delete-file (filename &optional trash)
+ "Like `delete-file' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
+ (unless
+ (tramp-sudoedit-send-command
+ v (if (and trash delete-by-moving-to-trash) "trash" "rm")
+ (tramp-compat-file-name-unquote localname))
+ ;; Propagate the error.
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (goto-char (point-min))
+ (tramp-error-with-buffer
+ nil v 'file-error "Couldn't delete %s" filename)))))
+
+(defun tramp-sudoedit-handle-expand-file-name (name &optional dir)
+ "Like `expand-file-name' for Tramp files.
+If the localname part of the given file name starts with \"/../\" then
+the result will be a local, non-Tramp, file name."
+ ;; If DIR is not given, use `default-directory' or "/".
+ (setq dir (or dir default-directory "/"))
+ ;; Handle empty NAME.
+ (when (zerop (length name)) (setq name "."))
+ ;; Unless NAME is absolute, concat DIR and NAME.
+ (unless (file-name-absolute-p name)
+ (setq name (concat (file-name-as-directory dir) name)))
+ (with-parsed-tramp-file-name name nil
+ ;; Tilde expansion if necessary. We cannot accept "~/", because
+ ;; under sudo "~/" is expanded to the local user home directory
+ ;; but to the root home directory.
+ (when (zerop (length localname))
+ (setq localname "~"))
+ (unless (file-name-absolute-p localname)
+ (setq localname (format "~%s/%s" user localname)))
+ (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)
+ (let ((uname (match-string 1 localname))
+ (fname (match-string 2 localname)))
+ (when (string-equal uname "~")
+ (setq uname (concat uname user)))
+ (setq localname (concat uname fname))))
+ ;; Do normal `expand-file-name' (this does "~user/", "/./" and "/../").
+ (tramp-make-tramp-file-name v (expand-file-name localname))))
+
+(defun tramp-sudoedit-remote-acl-p (vec)
+ "Check, whether ACL is enabled on the remote host."
+ (with-tramp-connection-property (tramp-get-connection-process vec) "acl-p"
+ (zerop (tramp-call-process vec "getfacl" nil nil nil "/"))))
+
+(defun tramp-sudoedit-handle-file-acl (filename)
+ "Like `file-acl' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (with-tramp-file-property v localname "file-acl"
+ (let ((result (and (tramp-sudoedit-remote-acl-p v)
+ (tramp-sudoedit-send-command-string
+ v "getfacl" "-acp"
+ (tramp-compat-file-name-unquote localname)))))
+ ;; The acl string must have a trailing \n, which is not
+ ;; provided by `tramp-sudoedit-send-command-string'. Add it.
+ (and (stringp result) (concat result "\n"))))))
+
+(defun tramp-sudoedit-handle-file-attributes (filename &optional id-format)
+ "Like `file-attributes' for Tramp files."
+ (unless id-format (setq id-format 'integer))
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (with-tramp-file-property
+ v localname (format "file-attributes-%s" id-format)
+ (tramp-message v 5 "file attributes: %s" localname)
+ (ignore-errors
+ (tramp-convert-file-attributes
+ v
+ (tramp-sudoedit-send-command-and-read
+ v "env" "QUOTING_STYLE=locale" "stat" "-c"
+ (format
+ ;; Apostrophes in the stat output are masked as
+ ;; `tramp-stat-marker', in order to make a proper shell
+ ;; escape of them in file names.
+ "((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)"
+ tramp-stat-marker tramp-stat-marker
+ (if (eq id-format 'integer)
+ "%u"
+ (eval-when-compile
+ (concat tramp-stat-marker "%U" tramp-stat-marker)))
+ (if (eq id-format 'integer)
+ "%g"
+ (eval-when-compile
+ (concat tramp-stat-marker "%G" tramp-stat-marker)))
+ tramp-stat-marker tramp-stat-marker)
+ (tramp-compat-file-name-unquote localname)))))))
+
+(defun tramp-sudoedit-handle-file-executable-p (filename)
+ "Like `file-executable-p' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (with-tramp-file-property v localname "file-executable-p"
+ (tramp-sudoedit-send-command
+ v "test" "-x" (tramp-compat-file-name-unquote localname)))))
+
+(defun tramp-sudoedit-handle-file-exists-p (filename)
+ "Like `file-exists-p' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (with-tramp-file-property v localname "file-exists-p"
+ (tramp-sudoedit-send-command
+ v "test" "-e" (tramp-compat-file-name-unquote localname)))))
+
+(defun tramp-sudoedit-handle-file-name-all-completions (filename directory)
+ "Like `file-name-all-completions' for Tramp files."
+ (all-completions
+ filename
+ (with-parsed-tramp-file-name (expand-file-name directory) nil
+ (with-tramp-file-property v localname "file-name-all-completions"
+ (tramp-sudoedit-send-command
+ v "ls" "-a1" "--quoting-style=literal" "--show-control-chars"
+ (if (zerop (length localname))
+ "" (tramp-compat-file-name-unquote localname)))
+ (mapcar
+ (lambda (f)
+ (if (file-directory-p (expand-file-name f directory))
+ (file-name-as-directory f)
+ f))
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (delq
+ nil
+ (mapcar
+ (lambda (l) (and (not (string-match-p "^[[:space:]]*$" l)) l))
+ (split-string (buffer-string) "\n" 'omit)))))))))
+
+(defun tramp-sudoedit-handle-file-readable-p (filename)
+ "Like `file-readable-p' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (with-tramp-file-property v localname "file-readable-p"
+ (tramp-sudoedit-send-command
+ v "test" "-r" (tramp-compat-file-name-unquote localname)))))
+
+(defun tramp-sudoedit-handle-set-file-modes (filename mode)
+ "Like `set-file-modes' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
+ (unless (tramp-sudoedit-send-command
+ v "chmod" (format "%o" mode)
+ (tramp-compat-file-name-unquote localname))
+ (tramp-error
+ v 'file-error "Error while changing file's mode %s" filename))))
+
+(defun tramp-sudoedit-remote-selinux-p (vec)
+ "Check, whether SELINUX is enabled on the remote host."
+ (with-tramp-connection-property (tramp-get-connection-process vec) "selinux-p"
+ (zerop (tramp-call-process vec "selinuxenabled"))))
+
+(defun tramp-sudoedit-handle-file-selinux-context (filename)
+ "Like `file-selinux-context' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (with-tramp-file-property v localname "file-selinux-context"
+ (let ((context '(nil nil nil nil))
+ (regexp (eval-when-compile
+ (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):"
+ "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)"))))
+ (when (and (tramp-sudoedit-remote-selinux-p v)
+ (tramp-sudoedit-send-command
+ v "ls" "-d" "-Z"
+ (tramp-compat-file-name-unquote localname)))
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (goto-char (point-min))
+ (when (re-search-forward regexp (point-at-eol) t)
+ (setq context (list (match-string 1) (match-string 2)
+ (match-string 3) (match-string 4))))))
+ ;; Return the context.
+ context))))
+
+(defun tramp-sudoedit-handle-file-system-info (filename)
+ "Like `file-system-info' for Tramp files."
+ (ignore-errors
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (tramp-message v 5 "file system info: %s" localname)
+ (when (tramp-sudoedit-send-command
+ v "df" "--block-size=1" "--output=size,used,avail"
+ (tramp-compat-file-name-unquote localname)))
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (goto-char (point-min))
+ (forward-line)
+ (when (looking-at
+ (eval-when-compile
+ (concat "[[:space:]]*\\([[:digit:]]+\\)"
+ "[[:space:]]+\\([[:digit:]]+\\)"
+ "[[:space:]]+\\([[:digit:]]+\\)")))
+ (list (string-to-number (match-string 1))
+ ;; The second value is the used size. We need the
+ ;; free size.
+ (- (string-to-number (match-string 1))
+ (string-to-number (match-string 2)))
+ (string-to-number (match-string 3))))))))
+
+(defun tramp-sudoedit-handle-set-file-times (filename &optional time)
+ "Like `set-file-times' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
+ (let ((time
+ (if (or (null time)
+ (tramp-compat-time-equal-p time tramp-time-doesnt-exist)
+ (tramp-compat-time-equal-p time tramp-time-dont-know))
+ (current-time)
+ time)))
+ (tramp-sudoedit-send-command
+ v "env" "TZ=UTC" "touch" "-t"
+ (format-time-string "%Y%m%d%H%M.%S" time t)
+ (tramp-compat-file-name-unquote localname)))))
+
+(defun tramp-sudoedit-handle-file-truename (filename)
+ "Like `file-truename' for Tramp files."
+ ;; Preserve trailing "/".
+ (funcall
+ (if (string-equal (file-name-nondirectory filename) "")
+ #'file-name-as-directory #'identity)
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (tramp-make-tramp-file-name
+ v
+ (with-tramp-file-property v localname "file-truename"
+ (let ((quoted (tramp-compat-file-name-quoted-p localname))
+ (localname (tramp-compat-file-name-unquote localname))
+ result)
+ (tramp-message v 4 "Finding true name for `%s'" filename)
+ (setq result (tramp-sudoedit-send-command-string
+ v "readlink" "--canonicalize-missing" localname))
+ ;; Detect cycle.
+ (when (and (file-symlink-p filename)
+ (string-equal result localname))
+ (tramp-error
+ v 'file-error
+ "Apparent cycle of symbolic links for %s" filename))
+ ;; If the resulting localname looks remote, we must quote it
+ ;; for security reasons.
+ (when (or quoted (file-remote-p result))
+ (let (file-name-handler-alist)
+ (setq result (tramp-compat-file-name-quote result))))
+ (tramp-message v 4 "True name of `%s' is `%s'" localname result)
+ result))
+ 'nohop))))
+
+(defun tramp-sudoedit-handle-file-writable-p (filename)
+ "Like `file-writable-p' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (with-tramp-file-property v localname "file-writable-p"
+ (if (file-exists-p filename)
+ (tramp-sudoedit-send-command
+ v "test" "-w" (tramp-compat-file-name-unquote localname))
+ (let ((dir (file-name-directory filename)))
+ (and (file-exists-p dir)
+ (file-writable-p dir)))))))
+
+(defun tramp-sudoedit-handle-make-directory (dir &optional parents)
+ "Like `make-directory' for Tramp files."
+ (setq dir (expand-file-name dir))
+ (with-parsed-tramp-file-name dir nil
+ ;; When PARENTS is non-nil, DIR could be a chain of non-existent
+ ;; directories a/b/c/... Instead of checking, we simply flush the
+ ;; whole cache.
+ (tramp-flush-directory-properties
+ v (if parents "/" (file-name-directory localname)))
+ (unless (tramp-sudoedit-send-command
+ v (if parents '("mkdir" "-p") "mkdir")
+ (tramp-compat-file-name-unquote localname))
+ (tramp-error v 'file-error "Couldn't make directory %s" dir))))
+
+(defun tramp-sudoedit-handle-make-symbolic-link
+ (target linkname &optional ok-if-already-exists)
+ "Like `make-symbolic-link' for Tramp files.
+If TARGET is a non-Tramp file, it is used verbatim as the target
+of the symlink. If TARGET is a Tramp file, only the localname
+component is used as the target of the symlink."
+ (if (not (tramp-tramp-file-p (expand-file-name linkname)))
+ (tramp-run-real-handler
+ #'make-symbolic-link (list target linkname ok-if-already-exists))
+
+ (with-parsed-tramp-file-name linkname nil
+ ;; If TARGET is a Tramp name, use just the localname component.
+ (when (and (tramp-tramp-file-p target)
+ (tramp-file-name-equal-p v (tramp-dissect-file-name target)))
+ (setq target
+ (tramp-file-name-localname
+ (tramp-dissect-file-name (expand-file-name target)))))
+
+ ;; If TARGET is still remote, quote it.
+ (if (tramp-tramp-file-p target)
+ (make-symbolic-link
+ (let (file-name-handler-alist) (tramp-compat-file-name-quote target))
+ linkname ok-if-already-exists)
+
+ ;; Do the 'confirm if exists' thing.
+ (when (file-exists-p linkname)
+ ;; 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? "
+ localname)))))
+ (tramp-error v 'file-already-exists localname)
+ (delete-file linkname)))
+
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
+ (tramp-sudoedit-send-command
+ v "ln" "-sf"
+ (tramp-compat-file-name-unquote target)
+ (tramp-compat-file-name-unquote localname))))))
+
+(defun tramp-sudoedit-handle-rename-file
+ (filename newname &optional ok-if-already-exists)
+ "Like `rename-file' for Tramp files."
+ (setq filename (expand-file-name filename))
+ (setq newname (expand-file-name newname))
+ ;; At least one file a Tramp file?
+ (if (or (tramp-tramp-file-p filename)
+ (tramp-tramp-file-p newname))
+ (tramp-sudoedit-do-copy-or-rename-file
+ 'rename filename newname ok-if-already-exists
+ 'keep-date 'preserve-uid-gid)
+ (tramp-run-real-handler
+ 'rename-file (list filename newname ok-if-already-exists))))
+
+(defun tramp-sudoedit-handle-set-file-acl (filename acl-string)
+ "Like `set-file-acl' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (when (and (stringp acl-string) (tramp-sudoedit-remote-acl-p v))
+ ;; Massage `acl-string'.
+ (setq acl-string
+ (mapconcat #'identity (split-string acl-string "\n" 'omit) ","))
+ (prog1
+ (tramp-sudoedit-send-command
+ v "setfacl" "-m"
+ acl-string (tramp-compat-file-name-unquote localname))
+ (tramp-flush-file-property v localname "file-acl")))))
+
+(defun tramp-sudoedit-handle-set-file-selinux-context (filename context)
+ "Like `set-file-selinux-context' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (when (and (consp context)
+ (tramp-sudoedit-remote-selinux-p v))
+ (let ((user (and (stringp (nth 0 context)) (nth 0 context)))
+ (role (and (stringp (nth 1 context)) (nth 1 context)))
+ (type (and (stringp (nth 2 context)) (nth 2 context)))
+ (range (and (stringp (nth 3 context)) (nth 3 context))))
+ (when (tramp-sudoedit-send-command
+ v "chcon"
+ (when user (format "--user=%s" user))
+ (when role (format "--role=%s" role))
+ (when type (format "--type=%s" type))
+ (when range (format "--range=%s" range))
+ (tramp-compat-file-name-unquote localname))
+ (if (and user role type range)
+ (tramp-set-file-property
+ v localname "file-selinux-context" context)
+ (tramp-flush-file-property v localname "file-selinux-context"))
+ t)))))
+
+(defun tramp-sudoedit-get-remote-uid (vec id-format)
+ "The uid of the remote connection VEC, in ID-FORMAT.
+ID-FORMAT valid values are `string' and `integer'."
+ (with-tramp-connection-property vec (format "uid-%s" id-format)
+ (if (equal id-format 'integer)
+ (tramp-sudoedit-send-command-and-read vec "id" "-u")
+ (tramp-sudoedit-send-command-string vec "id" "-un"))))
+
+(defun tramp-sudoedit-get-remote-gid (vec id-format)
+ "The gid of the remote connection VEC, in ID-FORMAT.
+ID-FORMAT valid values are `string' and `integer'."
+ (with-tramp-connection-property vec (format "gid-%s" id-format)
+ (if (equal id-format 'integer)
+ (tramp-sudoedit-send-command-and-read vec "id" "-g")
+ (tramp-sudoedit-send-command-string vec "id" "-gn"))))
+
+(defun tramp-sudoedit-handle-set-file-uid-gid (filename &optional uid gid)
+ "Like `tramp-set-file-uid-gid' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (tramp-sudoedit-send-command
+ v "chown"
+ (format "%d:%d"
+ (or uid (tramp-sudoedit-get-remote-uid v 'integer))
+ (or gid (tramp-sudoedit-get-remote-gid v 'integer)))
+ (tramp-compat-file-name-unquote
+ (tramp-compat-file-local-name filename)))))
+
+(defun tramp-sudoedit-handle-write-region
+ (start end filename &optional append visit lockname mustbenew)
+ "Like `write-region' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (let ((uid (or (tramp-compat-file-attribute-user-id
+ (file-attributes filename 'integer))
+ (tramp-sudoedit-get-remote-uid v 'integer)))
+ (gid (or (tramp-compat-file-attribute-group-id
+ (file-attributes filename 'integer))
+ (tramp-sudoedit-get-remote-gid v 'integer)))
+ (modes (tramp-default-file-modes filename)))
+ (prog1
+ (tramp-handle-write-region
+ start end filename append visit lockname mustbenew)
+
+ ;; Set the ownership and modes. This is not performed in
+ ;; `tramp-handle-write-region'.
+ (unless (and (= (tramp-compat-file-attribute-user-id
+ (file-attributes filename 'integer))
+ uid)
+ (= (tramp-compat-file-attribute-group-id
+ (file-attributes filename 'integer))
+ gid))
+ (tramp-set-file-uid-gid filename uid gid))
+ (set-file-modes filename modes)))))
+
+
+;; Internal functions.
+
+;; Used in `tramp-sudoedit-sudo-actions'.
+(defun tramp-sudoedit-action-sudo (proc vec)
+ "Check, whether a sudo process has finished.
+Remove unneeded output."
+ ;; There might be pending output for the exit status.
+ (unless (process-live-p proc)
+ (while (tramp-accept-process-output proc 0))
+ ;; Delete narrowed region, it would be in the way reading a Lisp form.
+ (goto-char (point-min))
+ (widen)
+ (delete-region (point-min) (point))
+ ;; Delete empty lines.
+ (goto-char (point-min))
+ (while (and (not (eobp)) (= (point) (point-at-eol)))
+ (forward-line))
+ (delete-region (point-min) (point))
+ (tramp-message vec 3 "Process has finished.")
+ (throw 'tramp-action 'ok)))
+
+(defun tramp-sudoedit-maybe-open-connection (vec)
+ "Maybe open a connection VEC.
+Does not do anything if a connection is already open, but re-opens the
+connection if a previous connection has died for some reason."
+ ;; We need a process bound to the connection buffer. Therefore, we
+ ;; create a dummy process. Maybe there is a better solution?
+ (unless (tramp-get-connection-process vec)
+
+ ;; During completion, don't reopen a new connection. We check
+ ;; this for the process related to `tramp-buffer-name'; otherwise
+ ;; `start-file-process' wouldn't run ever when `non-essential' is
+ ;; non-nil.
+ (when (and (tramp-completion-mode-p)
+ (null (get-process (tramp-buffer-name vec))))
+ (throw 'non-essential 'non-essential))
+
+ (let ((p (make-network-process
+ :name (tramp-buffer-name vec)
+ :buffer (tramp-get-connection-buffer vec)
+ :server t :host 'local :service t :noquery t)))
+ (process-put p 'vector vec)
+ (set-process-query-on-exit-flag p nil)
+
+ ;; Set connection-local variables.
+ (tramp-set-connection-local-variables vec)
+
+ ;; Mark it as connected.
+ (tramp-set-connection-property p "connected" t))
+
+ ;; In `tramp-check-cached-permissions', the connection properties
+ ;; "{uid,gid}-{integer,string}" are used. We set them to proper values.
+ (tramp-sudoedit-get-remote-uid vec 'integer)
+ (tramp-sudoedit-get-remote-gid vec 'integer)
+ (tramp-sudoedit-get-remote-uid vec 'string)
+ (tramp-sudoedit-get-remote-gid vec 'string)))
+
+(defun tramp-sudoedit-send-command (vec &rest args)
+ "Send commands ARGS to connection VEC.
+If an element of ARGS is a list, it will be flattened. If an
+element of ARGS is nil, it will be deleted.
+Erases temporary buffer before sending the command. Returns nil
+in case of error, t otherwise."
+ (tramp-sudoedit-maybe-open-connection vec)
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ (erase-buffer)
+ (let* ((login (tramp-get-method-parameter vec 'tramp-sudo-login))
+ (host (or (tramp-file-name-host vec) ""))
+ (user (or (tramp-file-name-user vec) ""))
+ (spec (format-spec-make ?h host ?u user))
+ (args (append
+ (tramp-compat-flatten-tree
+ (mapcar
+ (lambda (x)
+ (setq x (mapcar (lambda (y) (format-spec y spec)) x))
+ (unless (member "" x) x))
+ login))
+ (tramp-compat-flatten-tree (delq nil args))))
+ (delete-exited-processes t)
+ (process-connection-type tramp-process-connection-type)
+ (p (apply #'start-process
+ (tramp-get-connection-name vec) (current-buffer) args))
+ ;; We suppress the messages `Waiting for prompts from remote shell'.
+ (tramp-verbose (if (= tramp-verbose 3) 2 tramp-verbose))
+ ;; We do not want to save the password.
+ auth-source-save-behavior)
+ (tramp-message vec 6 "%s" (mapconcat #'identity (process-command p) " "))
+ ;; Avoid process status message in output buffer.
+ (set-process-sentinel p #'ignore)
+ (process-put p 'vector vec)
+ (process-put p 'adjust-window-size-function #'ignore)
+ (set-process-query-on-exit-flag p nil)
+ (tramp-process-actions p vec nil tramp-sudoedit-sudo-actions)
+ (tramp-message vec 6 "%s\n%s" (process-exit-status p) (buffer-string))
+ (prog1
+ (zerop (process-exit-status p))
+ (delete-process p)))))
+
+(defun tramp-sudoedit-send-command-and-read (vec &rest args)
+ "Run command ARGS and return the output, which must be a Lisp expression.
+In case there is no valid Lisp expression, it raises an error."
+ (when (apply #'tramp-sudoedit-send-command vec args)
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ ;; Replace stat marker.
+ (goto-char (point-min))
+ (when (search-forward tramp-stat-marker nil t)
+ (goto-char (point-min))
+ (while (search-forward "\"" nil t)
+ (replace-match "\\\"" nil 'literal))
+ (goto-char (point-min))
+ (while (search-forward tramp-stat-marker nil t)
+ (replace-match "\"")))
+ ;; Read the expression.
+ (tramp-message vec 6 "\n%s" (buffer-string))
+ (goto-char (point-min))
+ (condition-case nil
+ (prog1 (read (current-buffer))
+ ;; Error handling.
+ (when (re-search-forward "\\S-" (point-at-eol) t)
+ (error nil)))
+ (error (tramp-error
+ vec 'file-error
+ "`%s' does not return a valid Lisp expression: `%s'"
+ (car args) (buffer-string)))))))
+
+(defun tramp-sudoedit-send-command-string (vec &rest args)
+ "Run command ARGS and return the output as astring."
+ (when (apply #'tramp-sudoedit-send-command vec args)
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ (tramp-message vec 6 "\n%s" (buffer-string))
+ (goto-char (point-max))
+ ;(delete-blank-lines)
+ (while (looking-back "[ \t\n]+" nil 'greedy)
+ (delete-region (match-beginning 0) (point)))
+ (when (> (point-max) (point-min))
+ (substring-no-properties (buffer-string))))))
+
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-sudoedit 'force)))
+
+(provide 'tramp-sudoedit)
+
+;;; TODO:
+
+;; * Fix *-selinux functions. Likely, this is due to wrong file
+;; ownership after `write-region' and/or `copy-file'.
+
+;;; tramp-sudoedit.el ends here
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 315e7099479..32963ac5432 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -7,6 +7,8 @@
;; Maintainer: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
;; Package: tramp
+;; Version: 2.4.2-pre
+;; Package-Requires: ((emacs "24.1"))
;; This file is part of GNU Emacs.
@@ -35,8 +37,6 @@
;; Notes:
;; -----
;;
-;; This package only works for Emacs 24.1 and higher.
-;;
;; Also see the todo list at the bottom of this file.
;;
;; The current version of Tramp can be retrieved from the following URL:
@@ -56,11 +56,13 @@
;;; Code:
(require 'tramp-compat)
+(require 'tramp-integration)
+(require 'trampver)
;; Pacify byte-compiler.
(require 'cl-lib)
+(declare-function netrc-parse "netrc")
(defvar auto-save-file-name-transforms)
-(defvar eshell-path-env)
(defvar ls-lisp-use-insert-directory-program)
(defvar outline-regexp)
@@ -73,6 +75,16 @@
:link '(custom-manual "(tramp)Top")
:version "22.1")
+(eval-and-compile ;; So it's also available in tramp-loaddefs.el!
+ (defvar tramp--startup-hook nil
+ "Forms to be executed at the end of tramp.el.")
+
+ (defmacro tramp--with-startup (&rest body)
+ "Schedule BODY to be executed at the end of tramp.el."
+ `(add-hook 'tramp--startup-hook (lambda () ,@body))))
+
+(require 'tramp-loaddefs)
+
;; Maybe we need once a real Tramp mode, with key bindings etc.
;;;###autoload
(defcustom tramp-mode t
@@ -161,12 +173,12 @@ See the variable `tramp-encoding-shell' for more information."
:group 'tramp
:type '(choice (const nil) string))
-;;;###tramp-autoload
(defvar tramp-methods nil
"Alist of methods for remote files.
This is a list of entries of the form (NAME PARAM1 PARAM2 ...).
Each NAME stands for a remote access method. Each PARAM is a
pair of the form (KEY VALUE). The following KEYs are defined:
+
* `tramp-remote-shell'
This specifies the shell to use on the remote host. This
MUST be a Bourne-like shell. It is normally not necessary to
@@ -175,19 +187,23 @@ pair of the form (KEY VALUE). The following KEYs are defined:
for it. Also note that \"/bin/sh\" exists on all Unixen,
this might not be true for the value that you decide to use.
You Have Been Warned.
+
* `tramp-remote-shell-login'
This specifies the arguments to let `tramp-remote-shell' run
as a login shell. It defaults to (\"-l\"), but some shells,
like ksh, require another argument. See
`tramp-connection-properties' for a way to overwrite the
default value.
+
* `tramp-remote-shell-args'
For implementation of `shell-command', this specifies the
arguments to let `tramp-remote-shell' run a single command.
+
* `tramp-login-program'
This specifies the name of the program to use for logging in to the
remote host. This may be the name of rsh or a workalike program,
or the name of telnet or a workalike, or the name of su or a workalike.
+
* `tramp-login-args'
This specifies the list of arguments to pass to the above
mentioned program. Please note that this is a list of list of arguments,
@@ -203,55 +219,88 @@ pair of the form (KEY VALUE). The following KEYs are defined:
`tramp-make-tramp-temp-file'. \"%k\" indicates the keep-date
parameter of a program, if exists. \"%c\" adds additional
`tramp-ssh-controlmaster-options' options for the first hop.
+ The existence of `tramp-login-args', combined with the absence of
+ `tramp-copy-args', is an indication that the method is capable of
+ multi-hops.
+
* `tramp-login-env'
A list of environment variables and their values, which will
be set when calling `tramp-login-program'.
+
* `tramp-async-args'
When an asynchronous process is started, we know already that
the connection works. Therefore, we can pass additional
parameters to suppress diagnostic messages, in order not to
tamper the process output.
+
* `tramp-copy-program'
This specifies the name of the program to use for remotely copying
the file; this might be the absolute filename of scp or the name of
a workalike program. It is always applied on the local host.
+
* `tramp-copy-args'
This specifies the list of parameters to pass to the above mentioned
program, the hints for `tramp-login-args' also apply here.
+
* `tramp-copy-env'
A list of environment variables and their values, which will
be set when calling `tramp-copy-program'.
+
* `tramp-remote-copy-program'
The listener program to be applied on remote side, if needed.
+
* `tramp-remote-copy-args'
The list of parameters to pass to the listener program, the hints
for `tramp-login-args' also apply here. Additionally, \"%r\" could
be used here and in `tramp-copy-args'. It denotes a randomly
chosen port for the remote listener.
+
* `tramp-copy-keep-date'
This specifies whether the copying program when the preserves the
timestamp of the original file.
+
* `tramp-copy-keep-tmpfile'
This specifies whether a temporary local file shall be kept
for optimization reasons (useful for \"rsync\" methods).
+
* `tramp-copy-recursive'
Whether the operation copies directories recursively.
+
* `tramp-default-port'
The default port of a method.
+
* `tramp-tmpdir'
A directory on the remote host for temporary files. If not
specified, \"/tmp\" is taken as default.
+
* `tramp-connection-timeout'
This is the maximum time to be spent for establishing a connection.
In general, the global default value shall be used, but for
some methods, like \"su\" or \"sudo\", a shorter timeout
might be desirable.
+
+ * `tramp-session-timeout'
+ How long a Tramp connection keeps open before being disconnected.
+ This is useful for methods like \"su\" or \"sudo\", which
+ shouldn't run an open connection in the background forever.
+
* `tramp-case-insensitive'
Whether the remote file system handles file names case insensitive.
Only a non-nil value counts, the default value nil means to
perform further checks on the remote host. See
`tramp-connection-properties' for a way to overwrite this.
+ * `tramp-mount-args'
+ * `tramp-copyto-args'
+ * `tramp-moveto-args'
+ * `tramp-about-args'
+ These parameters, a list of list like `tramp-login-args', are used
+ for the \"rclone\" method, and are appended to the respective
+ \"rclone\" commands. In general, they shouldn't be changed inside
+ `tramp-methods'; it is recommended to change their values via
+ `tramp-connection-properties'. Unlike `tramp-login-args' there is
+ no pattern replacement.
+
What does all this mean? Well, you should specify `tramp-login-program'
for all methods; this program is used to log in to the remote site. Then,
there are two ways to actually transfer the files between the local and the
@@ -304,7 +353,6 @@ Also see `tramp-default-method-alist'."
:group 'tramp
:type 'string)
-;;;###tramp-autoload
(defcustom tramp-default-method-alist nil
"Default method to use for specific host/user pairs.
This is an alist of items (HOST USER METHOD). The first matching item
@@ -334,7 +382,6 @@ This variable is regarded as obsolete, and will be removed soon."
:group 'tramp
:type '(choice (const nil) string))
-;;;###tramp-autoload
(defcustom tramp-default-user-alist nil
"Default user to use for specific method/host pairs.
This is an alist of items (METHOD HOST USER). The first matching item
@@ -356,7 +403,6 @@ Useful for su and sudo methods mostly."
:group 'tramp
:type 'string)
-;;;###tramp-autoload
(defcustom tramp-default-host-alist nil
"Default host to use for specific method/user pairs.
This is an alist of items (METHOD USER HOST). The first matching item
@@ -378,11 +424,17 @@ empty string for the method name."
This is an alist of items (HOST USER PROXY). The first matching
item specifies the proxy to be passed for a file name located on
a remote target matching USER@HOST. HOST and USER are regular
-expressions. PROXY must be a Tramp filename without a localname
-part. Method and user name on PROXY are optional, which is
-interpreted with the default values. PROXY can contain the
-patterns %h and %u, which are replaced by the strings matching
-HOST or USER, respectively.
+expressions, which could also cover a domain (USER%DOMAIN) or
+port (HOST#PORT). PROXY must be a Tramp filename without a
+localname part. Method and user name on PROXY are optional,
+which is interpreted with the default values.
+
+PROXY can contain the patterns %h and %u, which are replaced by
+the strings matching HOST or USER (without DOMAIN and PORT parts),
+respectively.
+
+If an entry is added while parsing ad-hoc hop definitions, PROXY
+carries the non-nil text property `tramp-ad-hoc'.
HOST, USER or PROXY could also be Lisp forms, which will be
evaluated. The result must be a string or nil, which is
@@ -410,14 +462,18 @@ host runs a registered shell, it shall be added to this list, too."
:group 'tramp
:type '(repeat (regexp :tag "Host regexp")))
-;;;###tramp-autoload
-(defconst tramp-local-host-regexp
+(defcustom tramp-local-host-regexp
(concat
"\\`"
(regexp-opt
(list "localhost" "localhost6" (system-name) "127.0.0.1" "::1") t)
"\\'")
- "Host names which are regarded as local host.")
+ "Host names which are regarded as local host.
+If the local host runs a chrooted environment, set this to nil."
+ :version "27.1"
+ :group 'tramp
+ :type '(choice (const :tag "Chrooted environment" nil)
+ (regexp :tag "Host regexp")))
(defvar tramp-completion-function-alist nil
"Alist of methods for remote files.
@@ -632,7 +688,6 @@ Useful for \"rsync\" like methods.")
(make-variable-buffer-local 'tramp-temp-buffer-file-name)
(put 'tramp-temp-buffer-file-name 'permanent-local t)
-;;;###tramp-autoload
(defcustom tramp-syntax 'default
"Tramp filename syntax to be used.
@@ -651,8 +706,8 @@ Customize. See also `tramp-change-syntax'."
(const :tag "Ange-FTP" simplified)
(const :tag "XEmacs" separate))
:require 'tramp
- :initialize 'custom-initialize-set
- :set 'tramp-set-syntax)
+ :initialize #'custom-initialize-default
+ :set #'tramp-set-syntax)
(defun tramp-set-syntax (symbol value)
"Set SYMBOL to value VALUE.
@@ -660,7 +715,7 @@ Used in user option `tramp-syntax'. There are further variables
to be set, depending on VALUE."
;; Check allowed values.
(unless (memq value (tramp-syntax-values))
- (tramp-compat-user-error "Wrong `tramp-syntax' %s" tramp-syntax))
+ (tramp-user-error "Wrong `tramp-syntax' %s" value))
;; Cleanup existing buffers.
(unless (eq (symbol-value symbol) value)
(tramp-cleanup-all-buffers))
@@ -692,14 +747,15 @@ to be set, depending on VALUE."
;; value of `tramp-file-name-regexp'. Other Tramp syntax variables
;; must be initialized as well to proper values. We do not call
;; `custom-set-variable', this would load Tramp via custom.el.
-(eval-after-load 'tramp
- '(tramp-set-syntax 'tramp-syntax (tramp-compat-tramp-syntax)))
+(tramp--with-startup
+ (tramp-set-syntax 'tramp-syntax (tramp-compat-tramp-syntax)))
(defun tramp-syntax-values ()
"Return possible values of `tramp-syntax', a list"
(let ((values (cdr (get 'tramp-syntax 'custom-type))))
- (setq values (mapcar 'last values)
- values (mapcar 'car values))))
+ (setq values (mapcar #'last values)
+ values (mapcar #'car values))
+ values))
(defun tramp-lookup-syntax (alist)
"Look up a syntax string in ALIST according to `tramp-compat-tramp-syntax.'
@@ -716,14 +772,14 @@ Raise an error if `tramp-syntax' is invalid."
(defun tramp-build-prefix-format ()
(tramp-lookup-syntax tramp-prefix-format-alist))
-(defvar tramp-prefix-format (tramp-build-prefix-format)
+(defvar tramp-prefix-format nil ;Initialized when defining `tramp-syntax'!
"String matching the very beginning of Tramp file names.
Used in `tramp-make-tramp-file-name'.")
(defun tramp-build-prefix-regexp ()
(concat "^" (regexp-quote tramp-prefix-format)))
-(defvar tramp-prefix-regexp (tramp-build-prefix-regexp)
+(defvar tramp-prefix-regexp nil ;Initialized when defining `tramp-syntax'!
"Regexp matching the very beginning of Tramp file names.
Should always start with \"^\". Derived from `tramp-prefix-format'.")
@@ -736,7 +792,7 @@ Should always start with \"^\". Derived from `tramp-prefix-format'.")
(defun tramp-build-method-regexp ()
(tramp-lookup-syntax tramp-method-regexp-alist))
-(defvar tramp-method-regexp (tramp-build-method-regexp)
+(defvar tramp-method-regexp nil ;Initialized when defining `tramp-syntax'!
"Regexp matching methods identifiers.
The `ftp' syntax does not support methods.")
@@ -749,7 +805,7 @@ The `ftp' syntax does not support methods.")
(defun tramp-build-postfix-method-format ()
(tramp-lookup-syntax tramp-postfix-method-format-alist))
-(defvar tramp-postfix-method-format (tramp-build-postfix-method-format)
+(defvar tramp-postfix-method-format nil ;Init'd when defining `tramp-syntax'!
"String matching delimiter between method and user or host names.
The `ftp' syntax does not support methods.
Used in `tramp-make-tramp-file-name'.")
@@ -757,18 +813,16 @@ Used in `tramp-make-tramp-file-name'.")
(defun tramp-build-postfix-method-regexp ()
(regexp-quote tramp-postfix-method-format))
-(defvar tramp-postfix-method-regexp (tramp-build-postfix-method-regexp)
+(defvar tramp-postfix-method-regexp nil ;Init'd when defining `tramp-syntax'!
"Regexp matching delimiter between method and user or host names.
Derived from `tramp-postfix-method-format'.")
(defconst tramp-user-regexp "[^/|: \t]+"
"Regexp matching user names.")
-;;;###tramp-autoload
(defconst tramp-prefix-domain-format "%"
"String matching delimiter between user and domain names.")
-;;;###tramp-autoload
(defconst tramp-prefix-domain-regexp (regexp-quote tramp-prefix-domain-format)
"Regexp matching delimiter between user and domain names.
Derived from `tramp-prefix-domain-format'.")
@@ -802,21 +856,21 @@ Derived from `tramp-postfix-user-format'.")
(defun tramp-build-prefix-ipv6-format ()
(tramp-lookup-syntax tramp-prefix-ipv6-format-alist))
-(defvar tramp-prefix-ipv6-format (tramp-build-prefix-ipv6-format)
+(defvar tramp-prefix-ipv6-format nil ;Initialized when defining `tramp-syntax'!
"String matching left hand side of IPv6 addresses.
Used in `tramp-make-tramp-file-name'.")
(defun tramp-build-prefix-ipv6-regexp ()
(regexp-quote tramp-prefix-ipv6-format))
-(defvar tramp-prefix-ipv6-regexp (tramp-build-prefix-ipv6-regexp)
+(defvar tramp-prefix-ipv6-regexp nil ;Initialized when defining `tramp-syntax'!
"Regexp matching left hand side of IPv6 addresses.
Derived from `tramp-prefix-ipv6-format'.")
;; The following regexp is a bit sloppy. But it shall serve our
;; purposes. It covers also IPv4 mapped IPv6 addresses, like in
;; "::ffff:192.168.0.1".
-(defconst tramp-ipv6-regexp "\\(?:\\(?:[a-zA-Z0-9]+\\)?:\\)+[a-zA-Z0-9.]+"
+(defconst tramp-ipv6-regexp "\\(?:[a-zA-Z0-9]*:\\)+[a-zA-Z0-9.]+"
"Regexp matching IPv6 addresses.")
(defconst tramp-postfix-ipv6-format-alist
@@ -828,14 +882,14 @@ Derived from `tramp-prefix-ipv6-format'.")
(defun tramp-build-postfix-ipv6-format ()
(tramp-lookup-syntax tramp-postfix-ipv6-format-alist))
-(defvar tramp-postfix-ipv6-format (tramp-build-postfix-ipv6-format)
+(defvar tramp-postfix-ipv6-format nil ;Initialized when defining `tramp-syntax'!
"String matching right hand side of IPv6 addresses.
Used in `tramp-make-tramp-file-name'.")
(defun tramp-build-postfix-ipv6-regexp ()
(regexp-quote tramp-postfix-ipv6-format))
-(defvar tramp-postfix-ipv6-regexp (tramp-build-postfix-ipv6-regexp)
+(defvar tramp-postfix-ipv6-regexp nil ;Initialized when defining `tramp-syntax'!
"Regexp matching right hand side of IPv6 addresses.
Derived from `tramp-postfix-ipv6-format'.")
@@ -871,18 +925,18 @@ Derived from `tramp-postfix-hop-format'.")
(defun tramp-build-postfix-host-format ()
(tramp-lookup-syntax tramp-postfix-host-format-alist))
-(defvar tramp-postfix-host-format (tramp-build-postfix-host-format)
+(defvar tramp-postfix-host-format nil ;Initialized when defining `tramp-syntax'!
"String matching delimiter between host names and localnames.
Used in `tramp-make-tramp-file-name'.")
(defun tramp-build-postfix-host-regexp ()
(regexp-quote tramp-postfix-host-format))
-(defvar tramp-postfix-host-regexp (tramp-build-postfix-host-regexp)
+(defvar tramp-postfix-host-regexp nil ;Initialized when defining `tramp-syntax'!
"Regexp matching delimiter between host names and localnames.
Derived from `tramp-postfix-host-format'.")
-(defconst tramp-localname-regexp ".*$"
+(defconst tramp-localname-regexp "[^\n\r]*\\'"
"Regexp matching localnames.")
(defconst tramp-unknown-id-string "UNKNOWN"
@@ -905,7 +959,7 @@ It is expected, that `tramp-syntax' has the proper value."
"\\(?:" tramp-prefix-port-regexp tramp-port-regexp "\\)?" "\\)?"))
(defvar tramp-remote-file-name-spec-regexp
- (tramp-build-remote-file-name-spec-regexp)
+ nil ;Initialized when defining `tramp-syntax'!
"Regular expression matching a Tramp file name between prefix and postfix.")
(defun tramp-build-file-name-structure ()
@@ -921,7 +975,7 @@ See `tramp-file-name-structure'."
"\\(" tramp-localname-regexp "\\)")
5 6 7 8 1))
-(defvar tramp-file-name-structure (tramp-build-file-name-structure)
+(defvar tramp-file-name-structure nil ;Initialized when defining `tramp-syntax'!
"List of six elements (REGEXP METHOD USER HOST FILE HOP), detailing \
the Tramp file name structure.
@@ -956,6 +1010,13 @@ This regexp should match Tramp file names but no other file
names. When calling `tramp-register-file-name-handlers', the
initial value is overwritten by the car of `tramp-file-name-structure'.")
+;;;###autoload
+(defcustom tramp-ignored-file-name-regexp nil
+ "Regular expression matching file names that are not under Tramp’s control."
+ :version "27.1"
+ :group 'tramp
+ :type '(choice (const nil) regexp))
+
(defconst tramp-completion-file-name-regexp-default
(concat
"\\`/\\("
@@ -1007,7 +1068,7 @@ See `tramp-file-name-structure' for more explanations.")
(tramp-lookup-syntax tramp-completion-file-name-regexp-alist))
(defvar tramp-completion-file-name-regexp
- (tramp-build-completion-file-name-regexp)
+ nil ;Initialized when defining `tramp-syntax'!
"Regular expression matching file names handled by Tramp completion.
This regexp should match partial Tramp file names only.
@@ -1149,24 +1210,14 @@ means to use always cached values for the directory contents."
;;; Internal Variables:
-(defvar tramp-current-method nil
- "Connection method for this *tramp* buffer.")
-
-(defvar tramp-current-user nil
- "Remote login name for this *tramp* buffer.")
-
-(defvar tramp-current-domain nil
- "Remote domain name for this *tramp* buffer.")
-
-(defvar tramp-current-host nil
- "Remote host for this *tramp* buffer.")
-
-(defvar tramp-current-port nil
- "Remote port for this *tramp* buffer.")
-
(defvar tramp-current-connection nil
"Last connection timestamp.")
+(defvar tramp-password-save-function nil
+ "Password save function.
+Will be called once the password has been verified by successful
+authentication.")
+
(defconst tramp-completion-file-name-handler-alist
'((file-name-all-completions
. tramp-completion-handle-file-name-all-completions)
@@ -1177,7 +1228,6 @@ Operations not mentioned here will be handled by Tramp's file
name handler functions, or the normal Emacs functions.")
;; Handlers for foreign methods, like FTP or SMB, shall be plugged here.
-;;;###tramp-autoload
(defvar tramp-foreign-file-name-handler-alist nil
"Alist of elements (FUNCTION . HANDLER) for foreign methods handled specially.
If (FUNCTION FILENAME) returns non-nil, then all I/O on that file is done by
@@ -1216,6 +1266,7 @@ If nil, return `tramp-default-port'."
(or (tramp-file-name-port vec)
(tramp-get-method-parameter vec 'tramp-default-port)))
+;; Comparision of file names is performed by `tramp-equal-remote'.
(defun tramp-file-name-equal-p (vec1 vec2)
"Check, whether VEC1 and VEC2 denote the same `tramp-file-name'."
(and (tramp-file-name-p vec1) (tramp-file-name-p vec2)
@@ -1246,22 +1297,24 @@ entry does not exist, return nil."
"Return unquoted localname component of VEC."
(tramp-compat-file-name-unquote (tramp-file-name-localname vec)))
-;;;###tramp-autoload
(defun tramp-tramp-file-p (name)
"Return t if NAME is a string with Tramp file name syntax."
- (and (stringp name)
+ (and tramp-mode (stringp name)
;; No "/:" and "/c:". This is not covered by `tramp-file-name-regexp'.
(not (string-match-p
(if (memq system-type '(cygwin windows-nt))
"^/[[:alpha:]]?:" "^/:")
name))
+ ;; Excluded file names.
+ (or (null tramp-ignored-file-name-regexp)
+ (not (string-match-p tramp-ignored-file-name-regexp name)))
(string-match-p tramp-file-name-regexp name)
t))
(defun tramp-find-method (method user host)
"Return the right method string to use.
This is METHOD, if non-nil. Otherwise, do a lookup in
-`tramp-default-method-alist'."
+`tramp-default-method-alist' and `tramp-default-method'."
(when (and method
(or (string-equal method "")
(string-equal method tramp-default-method-marker)))
@@ -1272,8 +1325,8 @@ This is METHOD, if non-nil. Otherwise, do a lookup in
lmethod item)
(while choices
(setq item (pop choices))
- (when (and (string-match (or (nth 0 item) "") (or host ""))
- (string-match (or (nth 1 item) "") (or user "")))
+ (when (and (string-match-p (or (nth 0 item) "") (or host ""))
+ (string-match-p (or (nth 1 item) "") (or user "")))
(setq lmethod (nth 2 item))
(setq choices nil)))
lmethod)
@@ -1286,15 +1339,15 @@ This is METHOD, if non-nil. Otherwise, do a lookup in
(defun tramp-find-user (method user host)
"Return the right user string to use.
This is USER, if non-nil. Otherwise, do a lookup in
-`tramp-default-user-alist'."
+`tramp-default-user-alist' and `tramp-default-user'."
(let ((result
(or user
(let ((choices tramp-default-user-alist)
luser item)
(while choices
(setq item (pop choices))
- (when (and (string-match (or (nth 0 item) "") (or method ""))
- (string-match (or (nth 1 item) "") (or host "")))
+ (when (and (string-match-p (or (nth 0 item) "") (or method ""))
+ (string-match-p (or (nth 1 item) "") (or host "")))
(setq luser (nth 2 item))
(setq choices nil)))
luser)
@@ -1306,18 +1359,24 @@ This is USER, if non-nil. Otherwise, do a lookup in
(defun tramp-find-host (method user host)
"Return the right host string to use.
-This is HOST, if non-nil. Otherwise, it is `tramp-default-host'."
- (or (and (> (length host) 0) host)
- (let ((choices tramp-default-host-alist)
- lhost item)
- (while choices
- (setq item (pop choices))
- (when (and (string-match (or (nth 0 item) "") (or method ""))
- (string-match (or (nth 1 item) "") (or user "")))
- (setq lhost (nth 2 item))
- (setq choices nil)))
- lhost)
- tramp-default-host))
+This is HOST, if non-nil. Otherwise, do a lookup in
+`tramp-default-host-alist' and `tramp-default-host'."
+ (let ((result
+ (or (and (> (length host) 0) host)
+ (let ((choices tramp-default-host-alist)
+ lhost item)
+ (while choices
+ (setq item (pop choices))
+ (when (and (string-match-p (or (nth 0 item) "") (or method ""))
+ (string-match-p (or (nth 1 item) "") (or user "")))
+ (setq lhost (nth 2 item))
+ (setq choices nil)))
+ lhost)
+ tramp-default-host)))
+ ;; We must mark, whether a default value has been used.
+ (if (or (> (length host) 0) (null result))
+ result
+ (propertize result 'tramp-default t))))
(defun tramp-dissect-file-name (name &optional nodefault)
"Return a `tramp-file-name' structure of NAME, a remote file name.
@@ -1329,7 +1388,7 @@ to their default values. For the other file name parts, no
default values are used."
(save-match-data
(unless (tramp-tramp-file-p name)
- (tramp-compat-user-error nil "Not a Tramp file name: \"%s\"" name))
+ (tramp-user-error nil "Not a Tramp file name: \"%s\"" name))
(if (not (string-match (nth 0 tramp-file-name-structure) name))
(error "`tramp-file-name-structure' didn't match!")
(let ((method (match-string (nth 1 tramp-file-name-structure) name))
@@ -1337,7 +1396,7 @@ default values are used."
(host (match-string (nth 3 tramp-file-name-structure) name))
(localname (match-string (nth 4 tramp-file-name-structure) name))
(hop (match-string (nth 5 tramp-file-name-structure) name))
- domain port)
+ domain port v)
(when user
(when (string-match tramp-user-with-domain-regexp user)
(setq domain (match-string 2 user)
@@ -1353,13 +1412,50 @@ default values are used."
(setq host (replace-match "" nil t host))))
(unless nodefault
- (setq method (tramp-find-method method user host)
- user (tramp-find-user method user host)
- host (tramp-find-host method user host)))
-
- (make-tramp-file-name
- :method method :user user :domain domain :host host :port port
- :localname (or localname "") :hop hop)))))
+ (when hop
+ (setq v (tramp-dissect-hop-name hop)
+ hop (and hop (tramp-make-tramp-hop-name v))))
+ (let ((tramp-default-host
+ (or (and v (not (string-match-p "%h" (tramp-file-name-host v)))
+ (tramp-file-name-host v))
+ tramp-default-host)))
+ (setq method (tramp-find-method method user host)
+ user (tramp-find-user method user host)
+ host (tramp-find-host method user host)
+ hop
+ (and hop
+ (format-spec hop (format-spec-make ?h host ?u user))))))
+
+ ;; Return result.
+ (prog1
+ (setq v (make-tramp-file-name
+ :method method :user user :domain domain :host host
+ :port port :localname localname :hop hop))
+ ;; Only some methods from tramp-sh.el do support multi-hops.
+ (when (and
+ hop
+ (or (not (tramp-get-method-parameter v 'tramp-login-program))
+ (tramp-get-method-parameter v 'tramp-copy-program)))
+ (tramp-user-error
+ v "Method `%s' is not supported for multi-hops." method)))))))
+
+(defun tramp-dissect-hop-name (name &optional nodefault)
+ "Return a `tramp-file-name' structure of `hop' part of NAME.
+See `tramp-dissect-file-name' for details."
+ (let ((v (tramp-dissect-file-name
+ (concat tramp-prefix-format
+ (replace-regexp-in-string
+ (concat tramp-postfix-hop-regexp "$")
+ tramp-postfix-host-format name))
+ nodefault)))
+ ;; Only some methods from tramp-sh.el do support multi-hops.
+ (when (or (not (tramp-get-method-parameter v 'tramp-login-program))
+ (tramp-get-method-parameter v 'tramp-copy-program))
+ (tramp-user-error
+ v "Method `%s' is not supported for multi-hops."
+ (tramp-file-name-method v)))
+ ;; Return result.
+ v))
(defun tramp-buffer-name (vec)
"A name for the connection buffer VEC."
@@ -1370,33 +1466,75 @@ default values are used."
(format "*tramp/%s %s@%s*" method user-domain host-port)
(format "*tramp/%s %s*" method host-port))))
-(defun tramp-make-tramp-file-name
- (method user domain host port localname &optional hop)
- "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME.
-When not nil, optional DOMAIN, PORT and HOP are used."
- ;; Unless `tramp-syntax' is `simplified', we need a method.
- (when (and (not (zerop (length tramp-postfix-method-format)))
- (zerop (length method)))
- (signal 'wrong-type-argument (list 'stringp method)))
- (concat tramp-prefix-format hop
- (unless (zerop (length tramp-postfix-method-format))
- (concat method tramp-postfix-method-format))
- user
- (unless (zerop (length domain))
- (concat tramp-prefix-domain-format domain))
- (unless (zerop (length user))
- tramp-postfix-user-format)
- (when host
- (if (string-match tramp-ipv6-regexp host)
- (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format)
- host))
- (unless (zerop (length port))
- (concat tramp-prefix-port-format port))
- tramp-postfix-host-format
- (when localname localname)))
+(defun tramp-make-tramp-file-name (&rest args)
+ "Construct a Tramp file name from ARGS.
+
+ARGS could have two different signatures. The first one is of
+type (VEC &optional LOCALNAME HOP).
+If LOCALNAME is nil, the value in VEC is used. If it is a
+symbol, a null localname will be used. Otherwise, LOCALNAME is
+expected to be a string, which will be used.
+If HOP is nil, the value in VEC is used. If it is a symbol, a
+null hop will be used. Otherwise, HOP is expected to be a
+string, which will be used.
+
+The other signature exists for backward compatibility. It has
+the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)."
+ (let (method user domain host port localname hop)
+ (cond
+ ((tramp-file-name-p (car args))
+ (setq method (tramp-file-name-method (car args))
+ user (tramp-file-name-user (car args))
+ domain (tramp-file-name-domain (car args))
+ host (tramp-file-name-host (car args))
+ port (tramp-file-name-port (car args))
+ localname (tramp-file-name-localname (car args))
+ hop (tramp-file-name-hop (car args)))
+ (when (cadr args)
+ (setq localname (and (stringp (cadr args)) (cadr args))))
+ (when (cl-caddr args)
+ (setq hop (and (stringp (cl-caddr args)) (cl-caddr args)))))
+
+ (t (setq method (nth 0 args)
+ user (nth 1 args)
+ domain (nth 2 args)
+ host (nth 3 args)
+ port (nth 4 args)
+ localname (nth 5 args)
+ hop (nth 6 args))))
+
+ ;; Unless `tramp-syntax' is `simplified', we need a method.
+ (when (and (not (zerop (length tramp-postfix-method-format)))
+ (zerop (length method)))
+ (signal 'wrong-type-argument (list #'stringp method)))
+ (concat tramp-prefix-format hop
+ (unless (zerop (length tramp-postfix-method-format))
+ (concat method tramp-postfix-method-format))
+ user
+ (unless (zerop (length domain))
+ (concat tramp-prefix-domain-format domain))
+ (unless (zerop (length user))
+ tramp-postfix-user-format)
+ (when host
+ (if (string-match-p tramp-ipv6-regexp host)
+ (concat
+ tramp-prefix-ipv6-format host tramp-postfix-ipv6-format)
+ host))
+ (unless (zerop (length port))
+ (concat tramp-prefix-port-format port))
+ tramp-postfix-host-format
+ localname)))
+
+(defun tramp-make-tramp-hop-name (vec)
+ "Construct a Tramp hop name from VEC."
+ (replace-regexp-in-string
+ tramp-prefix-regexp ""
+ (replace-regexp-in-string
+ (concat tramp-postfix-host-regexp "$") tramp-postfix-hop-format
+ (tramp-make-tramp-file-name vec 'noloc))))
(defun tramp-completion-make-tramp-file-name (method user host localname)
- "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME.
+ "Construct a Tramp file name from METHOD, USER, HOST and LOCALNAME.
It must not be a complete Tramp file name, but as long as there are
necessary only. This function will be used in file name completion."
(concat tramp-prefix-format
@@ -1407,7 +1545,7 @@ necessary only. This function will be used in file name completion."
(concat user tramp-postfix-user-format))
(unless (zerop (length host))
(concat
- (if (string-match tramp-ipv6-regexp host)
+ (if (string-match-p tramp-ipv6-regexp host)
(concat
tramp-prefix-ipv6-format host tramp-postfix-ipv6-format)
host)
@@ -1423,15 +1561,8 @@ necessary only. This function will be used in file name completion."
(tramp-set-connection-property
vec "process-buffer"
(tramp-get-connection-property vec "process-buffer" nil))
- (setq buffer-undo-list t)
- (setq default-directory
- (tramp-make-tramp-file-name
- (tramp-file-name-method vec)
- (tramp-file-name-user vec)
- (tramp-file-name-domain vec)
- (tramp-file-name-host vec)
- (tramp-file-name-port vec)
- "/"))
+ (setq buffer-undo-list t
+ default-directory (tramp-make-tramp-file-name vec 'noloc 'nohop))
(current-buffer))))
(defun tramp-get-connection-buffer (vec)
@@ -1517,7 +1648,9 @@ The outline level is equal to the verbosity of the Tramp message."
(outline-regexp tramp-debug-outline-regexp))
(outline-mode))
(set (make-local-variable 'outline-regexp) tramp-debug-outline-regexp)
- (set (make-local-variable 'outline-level) 'tramp-debug-outline-level))
+ (set (make-local-variable 'outline-level) 'tramp-debug-outline-level)
+ ;; Do not edit the debug buffer.
+ (use-local-map special-mode-map))
(current-buffer)))
(defsubst tramp-debug-message (vec fmt-string &rest arguments)
@@ -1533,10 +1666,13 @@ ARGUMENTS to actually emit the message (if applicable)."
";; Emacs: %s Tramp: %s -*- mode: outline; -*-"
emacs-version tramp-version))
(when (>= tramp-verbose 10)
- (insert
- (format
- "\n;; Location: %s Git: %s"
- (locate-library "tramp") (tramp-repository-get-version)))))
+ (let ((tramp-verbose 0))
+ (insert
+ (format
+ "\n;; Location: %s Git: %s/%s"
+ (locate-library "tramp")
+ (or tramp-repository-branch "")
+ (or tramp-repository-version ""))))))
(unless (bolp)
(insert "\n"))
;; Timestamp.
@@ -1554,22 +1690,23 @@ ARGUMENTS to actually emit the message (if applicable)."
(setq fn (symbol-name btf))
(unless
(and
- (string-match "^tramp" fn)
+ (string-match-p "^tramp" fn)
(not
- (string-match
- (concat
- "^"
- (regexp-opt
- '("tramp-backtrace"
- "tramp-compat-funcall"
- "tramp-compat-user-error"
- "tramp-condition-case-unless-debug"
- "tramp-debug-message"
- "tramp-error"
- "tramp-error-with-buffer"
- "tramp-message")
- t)
- "$")
+ (string-match-p
+ (eval-when-compile
+ (concat
+ "^"
+ (regexp-opt
+ '("tramp-backtrace"
+ "tramp-compat-funcall"
+ "tramp-condition-case-unless-debug"
+ "tramp-debug-message"
+ "tramp-error"
+ "tramp-error-with-buffer"
+ "tramp-message"
+ "tramp-user-error")
+ t)
+ "$"))
fn)))
(setq fn nil)))
(setq btn (1+ btn))))
@@ -1607,47 +1744,47 @@ control string and the remaining ARGUMENTS to actually emit the message (if
applicable)."
(ignore-errors
(when (<= level tramp-verbose)
- ;; Match data must be preserved!
- (save-match-data
- ;; Display only when there is a minimum level.
- (when (and tramp-message-show-message (<= level 3))
- (apply 'message
- (concat
- (cond
- ((= level 0) "")
- ((= level 1) "")
- ((= level 2) "Warning: ")
- (t "Tramp: "))
- fmt-string)
- arguments))
- ;; Log only when there is a minimum level.
- (when (>= tramp-verbose 4)
- ;; Translate proc to vec.
- (when (processp vec-or-proc)
- (let ((tramp-verbose 0))
- (setq vec-or-proc
- (tramp-get-connection-property vec-or-proc "vector" nil))))
+ ;; Display only when there is a minimum level.
+ (when (and tramp-message-show-message (<= level 3))
+ (apply #'message
+ (concat
+ (cond
+ ((= level 0) "")
+ ((= level 1) "")
+ ((= level 2) "Warning: ")
+ (t "Tramp: "))
+ fmt-string)
+ arguments))
+ ;; Log only when there is a minimum level.
+ (when (>= tramp-verbose 4)
+ (let ((tramp-verbose 0))
;; Append connection buffer for error messages.
(when (= level 1)
- (let ((tramp-verbose 0))
- (with-current-buffer (tramp-get-connection-buffer vec-or-proc)
- (setq fmt-string (concat fmt-string "\n%s")
- arguments (append arguments (list (buffer-string)))))))
- ;; Do it.
- (when (tramp-file-name-p vec-or-proc)
- (apply 'tramp-debug-message
- vec-or-proc
- (concat (format "(%d) # " level) fmt-string)
- arguments)))))))
+ (with-current-buffer
+ (if (processp vec-or-proc)
+ (process-buffer vec-or-proc)
+ (tramp-get-connection-buffer vec-or-proc))
+ (setq fmt-string (concat fmt-string "\n%s")
+ arguments (append arguments (list (buffer-string))))))
+ ;; Translate proc to vec.
+ (when (processp vec-or-proc)
+ (setq vec-or-proc (process-get vec-or-proc 'vector))))
+ ;; Do it.
+ (when (tramp-file-name-p vec-or-proc)
+ (apply #'tramp-debug-message
+ vec-or-proc
+ (concat (format "(%d) # " level) fmt-string)
+ arguments))))))
(defsubst tramp-backtrace (&optional vec-or-proc)
"Dump a backtrace into the debug buffer.
If VEC-OR-PROC is nil, the buffer *debug tramp* is used. This
function is meant for debugging purposes."
- (if vec-or-proc
- (tramp-message vec-or-proc 10 "\n%s" (with-output-to-string (backtrace)))
- (if (>= tramp-verbose 10)
- (with-output-to-temp-buffer "*debug tramp*" (backtrace)))))
+ (when (>= tramp-verbose 10)
+ (if vec-or-proc
+ (tramp-message
+ vec-or-proc 10 "\n%s" (with-output-to-string (backtrace)))
+ (with-output-to-temp-buffer "*debug tramp*" (backtrace)))))
(defsubst tramp-error (vec-or-proc signal fmt-string &rest arguments)
"Emit an error.
@@ -1685,7 +1822,7 @@ an input event arrives. The other arguments are passed to `tramp-error'."
(and buf (with-current-buffer buf
(tramp-dissect-file-name default-directory))))))
(unwind-protect
- (apply 'tramp-error vec-or-proc signal fmt-string arguments)
+ (apply #'tramp-error vec-or-proc signal fmt-string arguments)
;; Save exit.
(when (and buf
tramp-message-show-message
@@ -1697,7 +1834,7 @@ an input event arrives. The other arguments are passed to `tramp-error'."
(let ((enable-recursive-minibuffers t))
;; `tramp-error' does not show messages. So we must do it
;; ourselves.
- (apply 'message fmt-string arguments)
+ (apply #'message fmt-string arguments)
;; Show buffer.
(pop-to-buffer buf)
(discard-input)
@@ -1706,6 +1843,31 @@ an input event arrives. The other arguments are passed to `tramp-error'."
(when (tramp-file-name-equal-p vec (car tramp-current-connection))
(setcdr tramp-current-connection (current-time)))))))
+;; We must make it a defun, because it is used earlier already.
+(defun tramp-user-error (vec-or-proc fmt-string &rest arguments)
+ "Signal a pilot error."
+ (unwind-protect
+ (apply
+ #'tramp-error vec-or-proc
+ ;; `user-error' has appeared in Emacs 24.3.
+ (if (fboundp 'user-error) 'user-error 'error) fmt-string arguments)
+ ;; Save exit.
+ (when (and tramp-message-show-message
+ (not (zerop tramp-verbose))
+ ;; Do not show when flagged from outside.
+ (not (tramp-completion-mode-p))
+ ;; Show only when Emacs has started already.
+ (current-message))
+ (let ((enable-recursive-minibuffers t))
+ ;; `tramp-error' does not show messages. So we must do it ourselves.
+ (apply #'message fmt-string arguments)
+ (discard-input)
+ (sit-for 30)
+ ;; Reset timestamp. It would be wrong after waiting for a while.
+ (when
+ (tramp-file-name-equal-p vec-or-proc (car tramp-current-connection))
+ (setcdr tramp-current-connection (current-time)))))))
+
(defmacro tramp-with-demoted-errors (vec-or-proc format &rest body)
"Execute BODY while redirecting the error message to `tramp-message'.
BODY is executed like wrapped by `with-demoted-errors'. FORMAT
@@ -1756,7 +1918,7 @@ If VAR is nil, then we bind `v' to the structure and `method', `user',
"Report progress of an operation for Tramp."
(let* ((parameters (cdr reporter))
(message (aref parameters 3)))
- (when (string-match message (or (current-message) ""))
+ (when (string-match-p message (or (current-message) ""))
(progress-reporter-update reporter value))))
(defmacro with-tramp-progress-reporter (vec level message &rest body)
@@ -1829,7 +1991,7 @@ letter into the file name. This function removes it."
(save-match-data
(funcall
(if (tramp-compat-file-name-quoted-p name)
- 'tramp-compat-file-name-quote 'identity)
+ #'tramp-compat-file-name-quote #'identity)
(let ((name (tramp-compat-file-name-unquote name)))
(if (string-match "\\`[a-zA-Z]:/" name)
(replace-match "/" nil t name)
@@ -1837,7 +1999,6 @@ letter into the file name. This function removes it."
;;; Config Manipulation Functions:
-;;;###tramp-autoload
(defun tramp-set-completion-function (method function-list)
"Sets the list of completion functions for METHOD.
FUNCTION-LIST is a list of entries of the form (FUNCTION FILE).
@@ -1851,7 +2012,6 @@ Example:
\"ssh\"
\\='((tramp-parse-sconfig \"/etc/ssh_config\")
(tramp-parse-sconfig \"~/.ssh/config\")))"
-
(let ((r function-list)
(v function-list))
(setq tramp-completion-function-alist
@@ -1866,13 +2026,13 @@ Example:
(unless (and (functionp (nth 0 (car v)))
(cond
;; Windows registry.
- ((string-match "^HKEY_CURRENT_USER" (nth 1 (car v)))
+ ((string-match-p "^HKEY_CURRENT_USER" (nth 1 (car v)))
(and (memq system-type '(cygwin windows-nt))
(zerop
(tramp-call-process
v "reg" nil nil nil "query" (nth 1 (car v))))))
;; Zeroconf service type.
- ((string-match
+ ((string-match-p
"^_[[:alpha:]]+\\._[[:alpha:]]+$" (nth 1 (car v))))
;; Configuration file.
(t (file-exists-p (nth 1 (car v))))))
@@ -1889,82 +2049,13 @@ For definition of that list see `tramp-set-completion-function'."
(append
`(;; Default settings are taken into account.
(tramp-parse-default-user-host ,method)
+ ;; Hits from auth-sources.
+ (tramp-parse-auth-sources ,method)
;; Hosts visited once shall be remembered.
(tramp-parse-connection-properties ,method))
;; The method related defaults.
(cdr (assoc method tramp-completion-function-alist))))
-;;; Fontification of `read-file-name':
-
-(defvar tramp-rfn-eshadow-overlay)
-(make-variable-buffer-local 'tramp-rfn-eshadow-overlay)
-
-(defun tramp-rfn-eshadow-setup-minibuffer ()
- "Set up a minibuffer for `file-name-shadow-mode'.
-Adds another overlay hiding filename parts according to Tramp's
-special handling of `substitute-in-file-name'."
- (when minibuffer-completing-file-name
- (setq tramp-rfn-eshadow-overlay
- (make-overlay (minibuffer-prompt-end) (minibuffer-prompt-end)))
- ;; Copy rfn-eshadow-overlay properties.
- (let ((props (overlay-properties rfn-eshadow-overlay)))
- (while props
- ;; The `field' property prevents correct minibuffer
- ;; completion; we exclude it.
- (if (not (eq (car props) 'field))
- (overlay-put tramp-rfn-eshadow-overlay (pop props) (pop props))
- (pop props) (pop props))))))
-
-(add-hook 'rfn-eshadow-setup-minibuffer-hook
- 'tramp-rfn-eshadow-setup-minibuffer)
-(add-hook 'tramp-unload-hook
- (lambda ()
- (remove-hook 'rfn-eshadow-setup-minibuffer-hook
- 'tramp-rfn-eshadow-setup-minibuffer)))
-
-(defun tramp-rfn-eshadow-update-overlay-regexp ()
- (format "[^%s/~]*\\(/\\|~\\)" tramp-postfix-host-format))
-
-;; Package rfn-eshadow is preloaded in Emacs, but for some reason,
-;; it only did (defvar rfn-eshadow-overlay) without giving it a global
-;; value, so it was only declared as dynamically-scoped within the
-;; rfn-eshadow.el file. This is now fixed in Emacs>26.1 but we still need
-;; this defvar here for older releases.
-(defvar rfn-eshadow-overlay)
-
-(defun tramp-rfn-eshadow-update-overlay ()
- "Update `rfn-eshadow-overlay' to cover shadowed part of minibuffer input.
-This is intended to be used as a minibuffer `post-command-hook' for
-`file-name-shadow-mode'; the minibuffer should have already
-been set up by `rfn-eshadow-setup-minibuffer'."
- ;; In remote files name, there is a shadowing just for the local part.
- (ignore-errors
- (let ((end (or (overlay-end rfn-eshadow-overlay)
- (minibuffer-prompt-end)))
- ;; We do not want to send any remote command.
- (non-essential t))
- (when (tramp-tramp-file-p (buffer-substring end (point-max)))
- (save-excursion
- (save-restriction
- (narrow-to-region
- (1+ (or (string-match
- (tramp-rfn-eshadow-update-overlay-regexp)
- (buffer-string) end)
- end))
- (point-max))
- (let ((rfn-eshadow-overlay tramp-rfn-eshadow-overlay)
- (rfn-eshadow-update-overlay-hook nil)
- file-name-handler-alist)
- (move-overlay rfn-eshadow-overlay (point-max) (point-max))
- (rfn-eshadow-update-overlay))))))))
-
-(add-hook 'rfn-eshadow-update-overlay-hook
- 'tramp-rfn-eshadow-update-overlay)
-(add-hook 'tramp-unload-hook
- (lambda ()
- (remove-hook 'rfn-eshadow-update-overlay-hook
- 'tramp-rfn-eshadow-update-overlay)))
-
;; Inodes don't exist for some file systems. Therefore we must
;; generate virtual ones. Used in `find-buffer-visiting'. The method
;; applied might be not so efficient (Ange-FTP uses hashes). But
@@ -1986,7 +2077,7 @@ been set up by `rfn-eshadow-setup-minibuffer'."
If the file modes of FILENAME cannot be determined, return the
value of `default-file-modes', without execute permissions."
(or (file-modes filename)
- (logand (default-file-modes) (string-to-number "0666" 8))))
+ (logand (default-file-modes) #o0666)))
(defun tramp-replace-environment-variables (filename)
"Replace environment variables in FILENAME.
@@ -1996,7 +2087,7 @@ Return the string with the replaced variables."
(tramp-compat-funcall 'substitute-env-vars filename 'only-defined))
;; We need an own implementation.
(save-match-data
- (let ((idx (string-match "$\\(\\w+\\)" filename)))
+ (let ((idx (string-match "\\$\\(\\w+\\)" filename)))
;; `$' is coded as `$$'.
(when (and idx
(or (zerop idx) (not (eq ?$ (aref filename (1- idx)))))
@@ -2015,7 +2106,7 @@ expression, which matches more than the file name suffix, the
coding system might not be determined. This function repairs it."
(let (result)
(dolist (elt file-coding-system-alist (nreverse result))
- (when (and (consp elt) (string-match (car elt) filename))
+ (when (and (consp elt) (string-match-p (car elt) filename))
;; We found a matching entry in `file-coding-system-alist'.
;; So we add a similar entry, but with the temporary file name
;; as regexp.
@@ -2029,6 +2120,7 @@ pass to the OPERATION."
`(tramp-file-name-handler
tramp-vc-file-name-handler
tramp-completion-file-name-handler
+ tramp-archive-file-name-handler
cygwin-mount-name-hook-function
cygwin-mount-map-drive-hook-function
.
@@ -2062,7 +2154,7 @@ ARGS are the arguments OPERATION has been called with."
file-ownership-preserved-p file-readable-p
file-regular-p file-remote-p file-selinux-context
file-symlink-p file-truename file-writable-p
- find-backup-file-name find-file-noselect get-file-buffer
+ find-backup-file-name get-file-buffer
insert-directory insert-file-contents load
make-directory make-directory-internal set-file-acl
set-file-modes set-file-selinux-context set-file-times
@@ -2071,13 +2163,15 @@ ARGS are the arguments OPERATION has been called with."
;; Emacs 26+ only.
file-name-case-insensitive-p
;; Emacs 27+ only.
- file-system-info))
+ file-system-info
+ ;; Tramp internal magic file name function.
+ tramp-set-file-uid-gid))
(if (file-name-absolute-p (nth 0 args))
(nth 0 args)
default-directory))
;; FILE DIRECTORY resp FILE1 FILE2.
((member operation
- '(add-name-to-file copy-directory copy-file expand-file-name
+ '(add-name-to-file copy-directory copy-file
file-equal-p file-in-directory-p
file-name-all-completions file-name-completion
;; Starting with Emacs 26.1, just the 2nd argument of
@@ -2086,11 +2180,16 @@ ARGS are the arguments OPERATION has been called with."
;; file name to be checked. Handled properly in
;; `tramp-handle-*-make-symbolic-link'.
file-newer-than-file-p make-symbolic-link rename-file))
- (save-match-data
- (cond
- ((tramp-tramp-file-p (nth 0 args)) (nth 0 args))
- ((tramp-tramp-file-p (nth 1 args)) (nth 1 args))
- (t default-directory))))
+ (cond
+ ((tramp-tramp-file-p (nth 0 args)) (nth 0 args))
+ ((tramp-tramp-file-p (nth 1 args)) (nth 1 args))
+ (t default-directory)))
+ ;; FILE DIRECTORY resp FILE1 FILE2.
+ ((eq operation 'expand-file-name)
+ (cond
+ ((file-name-absolute-p (nth 0 args)) (nth 0 args))
+ ((tramp-tramp-file-p (nth 1 args)) (nth 1 args))
+ (t default-directory)))
;; START END FILE.
((eq operation 'write-region)
(if (file-name-absolute-p (nth 2 args))
@@ -2106,7 +2205,9 @@ ARGS are the arguments OPERATION has been called with."
((member operation
'(process-file shell-command start-file-process
;; Emacs 26+ only.
- make-nearby-temp-file temporary-file-directory))
+ make-nearby-temp-file temporary-file-directory
+ ;; Emacs 27+ only.
+ exec-path make-process))
default-directory)
;; PROC.
((member operation
@@ -2138,6 +2239,7 @@ ARGS are the arguments OPERATION has been called with."
(defmacro tramp-condition-case-unless-debug
(var bodyform &rest handlers)
"Like `condition-case-unless-debug' but `tramp-debug-on-error'."
+ (declare (debug condition-case) (indent 2))
`(let ((debug-on-error tramp-debug-on-error))
(condition-case-unless-debug ,var ,bodyform ,@handlers)))
@@ -2172,8 +2274,8 @@ preventing reentrant calls of Tramp.")
(defun tramp-file-name-handler (operation &rest args)
"Invoke Tramp file name handler.
Falls back to normal file name handler if no Tramp file name handler exists."
- (let ((filename (apply 'tramp-file-name-for-operation operation args)))
- (if (and tramp-mode (tramp-tramp-file-p filename))
+ (let ((filename (apply #'tramp-file-name-for-operation operation args)))
+ (if (tramp-tramp-file-p filename)
(save-match-data
(setq filename (tramp-replace-environment-variables filename))
(with-parsed-tramp-file-name filename nil
@@ -2192,8 +2294,11 @@ Falls back to normal file name handler if no Tramp file name handler exists."
;; Tramp packages locally.
(when (autoloadp sf)
(let ((default-directory
- (tramp-compat-temporary-file-directory)))
+ (tramp-compat-temporary-file-directory))
+ file-name-handler-alist)
(load (cadr sf) 'noerror 'nomessage)))
+;; (tramp-message
+;; v 4 "Running `%s'..." (cons operation args))
;; If `non-essential' is non-nil, Tramp shall
;; not open a new connection.
;; If Tramp detects that it shouldn't continue
@@ -2217,6 +2322,8 @@ Falls back to normal file name handler if no Tramp file name handler exists."
(let ((tramp-locker t))
(apply foreign operation args))
(setq tramp-locked tl))))))
+;; (tramp-message
+;; v 4 "Running `%s'...`%s'" (cons operation args) result)
(cond
((eq result 'non-essential)
(tramp-message
@@ -2238,7 +2345,7 @@ Falls back to normal file name handler if no Tramp file name handler exists."
(tramp-message
v 1 "Interrupt received in operation %s"
(cons operation args)))
- ;; Propagate the quit signal.
+ ;; Propagate the signal.
(signal (car err) (cdr err)))
;; When we are in completion mode, some failed
@@ -2282,10 +2389,10 @@ Falls back to normal file name handler if no Tramp file name handler exists."
;;;###autoload
(progn (defun tramp-autoload-file-name-handler (operation &rest args)
"Load Tramp file name handler, and perform OPERATION."
+ (tramp-unload-file-name-handlers)
(if tramp-mode
(let ((default-directory temporary-file-directory))
- (load "tramp" 'noerror 'nomessage))
- (tramp-unload-file-name-handlers))
+ (load "tramp" 'noerror 'nomessage)))
(apply operation args)))
;; `tramp-autoload-file-name-handler' must be registered before
@@ -2312,44 +2419,47 @@ remote file names."
"^%s$"
(regexp-opt
(mapcar
- 'file-name-sans-extension
+ #'file-name-sans-extension
(directory-files dir nil "^tramp.+\\.elc?$"))
'paren))))
(mapatoms
(lambda (atom)
(when (and (functionp atom)
(autoloadp (symbol-function atom))
- (string-match files-regexp (cadr (symbol-function atom))))
+ (string-match-p files-regexp (cadr (symbol-function atom))))
(ignore-errors
(setf (cadr (symbol-function atom))
(expand-file-name (cadr (symbol-function atom)) dir))))))))
-(eval-after-load 'tramp (tramp-use-absolute-autoload-file-names))
+(tramp--with-startup (tramp-use-absolute-autoload-file-names))
(defun tramp-register-file-name-handlers ()
"Add Tramp file name handlers to `file-name-handler-alist'."
;; Remove autoloaded handlers from file name handler alist. Useful,
;; if `tramp-syntax' has been changed.
- (dolist (fnh '(tramp-file-name-handler
- tramp-completion-file-name-handler
- tramp-autoload-file-name-handler))
- (let ((a1 (rassq fnh file-name-handler-alist)))
- (setq file-name-handler-alist (delq a1 file-name-handler-alist))))
+ (tramp-unload-file-name-handlers)
;; Add the handlers. We do not add anything to the `operations'
- ;; property of `tramp-file-name-handler', this shall be done by the
+ ;; property of `tramp-file-name-handler' and
+ ;; `tramp-archive-file-name-handler', this shall be done by the
;; respective foreign handlers.
(add-to-list 'file-name-handler-alist
- (cons tramp-file-name-regexp 'tramp-file-name-handler))
+ (cons tramp-file-name-regexp #'tramp-file-name-handler))
(put 'tramp-file-name-handler 'safe-magic t)
(add-to-list 'file-name-handler-alist
(cons tramp-completion-file-name-regexp
- 'tramp-completion-file-name-handler))
+ #'tramp-completion-file-name-handler))
(put 'tramp-completion-file-name-handler 'safe-magic t)
;; Mark `operations' the handler is responsible for.
(put 'tramp-completion-file-name-handler 'operations
- (mapcar 'car tramp-completion-file-name-handler-alist))
+ (mapcar #'car tramp-completion-file-name-handler-alist))
+
+ (when (bound-and-true-p tramp-archive-enabled)
+ (add-to-list 'file-name-handler-alist
+ (cons tramp-archive-file-name-regexp
+ #'tramp-archive-file-name-handler))
+ (put 'tramp-archive-file-name-handler 'safe-magic t))
;; If jka-compr or epa-file are already loaded, move them to the
;; front of `file-name-handler-alist'.
@@ -2359,10 +2469,9 @@ remote file names."
(setq file-name-handler-alist
(cons entry (delete entry file-name-handler-alist)))))))
-(eval-after-load 'tramp (tramp-register-file-name-handlers))
+(tramp--with-startup (tramp-register-file-name-handlers))
-;;;###tramp-autoload
-(progn (defun tramp-register-foreign-file-name-handler
+(defun tramp-register-foreign-file-name-handler
(func handler &optional append)
"Register (FUNC . HANDLER) in `tramp-foreign-file-name-handler-alist'.
FUNC is the function, which determines whether HANDLER is to be called.
@@ -2376,8 +2485,8 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'."
(append
(get 'tramp-file-name-handler 'operations)
(mapcar
- 'car
- (symbol-value (intern (concat (symbol-name handler) "-alist")))))))))
+ #'car
+ (symbol-value (intern (concat (symbol-name handler) "-alist"))))))))
(defun tramp-exists-file-name-handler (operation &rest args)
"Check, whether OPERATION runs a file name handler."
@@ -2402,13 +2511,12 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'."
;;;###autoload
(progn (defun tramp-unload-file-name-handlers ()
"Unload Tramp file name handlers from `file-name-handler-alist'."
- (dolist (fnh '(tramp-file-name-handler
- tramp-completion-file-name-handler
- tramp-autoload-file-name-handler))
- (let ((a1 (rassq fnh file-name-handler-alist)))
- (setq file-name-handler-alist (delq a1 file-name-handler-alist))))))
+ (dolist (fnh file-name-handler-alist)
+ (when (and (symbolp (cdr fnh))
+ (string-prefix-p "tramp-" (symbol-name (cdr fnh))))
+ (setq file-name-handler-alist (delq fnh file-name-handler-alist))))))
-(add-hook 'tramp-unload-hook 'tramp-unload-file-name-handlers)
+(add-hook 'tramp-unload-hook #'tramp-unload-file-name-handlers)
;;; File name handler functions for completion mode:
@@ -2442,7 +2550,6 @@ not in completion mode."
;; completions.
(defun tramp-completion-handle-file-name-all-completions (filename directory)
"Like `file-name-all-completions' for partial Tramp files."
-
(let ((fullname
(tramp-drop-volume-letter (expand-file-name filename directory)))
hop result result1)
@@ -2465,7 +2572,6 @@ not in completion mode."
(host (tramp-file-name-host elt))
(localname (tramp-file-name-localname elt))
(m (tramp-find-method method user host))
- (tramp-current-user user) ; see `tramp-parse-passwd'
all-user-hosts)
(unless localname ;; Nothing to complete.
@@ -2515,7 +2621,7 @@ not in completion mode."
"Like `file-name-completion' for Tramp files."
(try-completion
filename
- (mapcar 'list (file-name-all-completions filename directory))
+ (mapcar #'list (file-name-all-completions filename directory))
(when (and predicate
(tramp-connectable-p (expand-file-name filename directory)))
(lambda (x) (funcall predicate (expand-file-name (car x) directory))))))
@@ -2540,7 +2646,6 @@ not in completion mode."
(defun tramp-completion-dissect-file-name (name)
"Returns a list of `tramp-file-name' structures.
They are collected by `tramp-completion-dissect-file-name1'."
-
(let* ((x-nil "\\|\\(\\)")
(tramp-completion-ipv6-regexp
(format
@@ -2615,7 +2720,6 @@ They are collected by `tramp-completion-dissect-file-name1'."
"Returns a `tramp-file-name' structure matching STRUCTURE.
The structure consists of remote method, remote user,
remote host and localname (filename on remote host)."
-
(save-match-data
(when (string-match (nth 0 structure) name)
(make-tramp-file-name
@@ -2633,9 +2737,9 @@ remote host and localname (filename on remote host)."
(mapcar
(lambda (method)
(and method
- (string-match (concat "^" (regexp-quote partial-method)) method)
+ (string-match-p (concat "^" (regexp-quote partial-method)) method)
(tramp-completion-make-tramp-file-name method nil nil nil)))
- (mapcar 'car tramp-methods)))
+ (mapcar #'car tramp-methods)))
;; Compares partial user and host names with possible completions.
(defun tramp-get-completion-user-host
@@ -2646,7 +2750,7 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST."
((and partial-user partial-host)
(if (and host
- (string-match (concat "^" (regexp-quote partial-host)) host)
+ (string-match-p (concat "^" (regexp-quote partial-host)) host)
(string-equal partial-user (or user partial-user)))
(setq user partial-user)
(setq user nil
@@ -2655,13 +2759,15 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST."
(partial-user
(setq host nil)
(unless
- (and user (string-match (concat "^" (regexp-quote partial-user)) user))
+ (and user
+ (string-match-p (concat "^" (regexp-quote partial-user)) user))
(setq user nil)))
(partial-host
(setq user nil)
(unless
- (and host (string-match (concat "^" (regexp-quote partial-host)) host))
+ (and host
+ (string-match-p (concat "^" (regexp-quote partial-host)) host))
(setq host nil)))
(t (setq user nil
@@ -2676,15 +2782,33 @@ This function is added always in `tramp-get-completion-function'
for all methods. Resulting data are derived from default settings."
`((,(tramp-find-user method nil nil) ,(tramp-find-host method nil nil))))
+(defcustom tramp-completion-use-auth-sources auth-source-do-cache
+ "Whether to use `auth-source-search' for completion of user and host names.
+This could be disturbing, if it requires a password / passphrase,
+as for \"~/.authinfo.gpg\"."
+ :group 'tramp
+ :version "27.1"
+ :type 'boolean)
+
+(defun tramp-parse-auth-sources (method)
+ "Return a list of (user host) tuples allowed to access for METHOD.
+This function is added always in `tramp-get-completion-function'
+for all methods. Resulting data are derived from default settings."
+ (and tramp-completion-use-auth-sources
+ (mapcar
+ (lambda (x) `(,(plist-get x :user) ,(plist-get x :host)))
+ (auth-source-search
+ :port method :require '(:port) :max most-positive-fixnum))))
+
;; Generic function.
-(defun tramp-parse-group (regexp match-level skip-regexp)
+(defun tramp-parse-group (regexp match-level skip-chars)
"Return a (user host) tuple allowed to access.
User is always nil."
(let (result)
(when (re-search-forward regexp (point-at-eol) t)
(setq result (list nil (match-string match-level))))
(or
- (> (skip-chars-forward skip-regexp) 0)
+ (> (skip-chars-forward skip-chars) 0)
(forward-line 1))
result))
@@ -2701,11 +2825,10 @@ User is always nil."
(goto-char (point-min))
(cl-loop while (not (eobp)) collect (funcall function))))))
-;;;###tramp-autoload
(defun tramp-parse-rhosts (filename)
"Return a list of (user host) tuples allowed to access.
Either user or host may be nil."
- (tramp-parse-file filename 'tramp-parse-rhosts-group))
+ (tramp-parse-file filename #'tramp-parse-rhosts-group))
(defun tramp-parse-rhosts-group ()
"Return a (user host) tuple allowed to access.
@@ -2720,22 +2843,20 @@ Either user or host may be nil."
(forward-line 1)
result))
-;;;###tramp-autoload
(defun tramp-parse-shosts (filename)
"Return a list of (user host) tuples allowed to access.
User is always nil."
- (tramp-parse-file filename 'tramp-parse-shosts-group))
+ (tramp-parse-file filename #'tramp-parse-shosts-group))
(defun tramp-parse-shosts-group ()
"Return a (user host) tuple allowed to access.
User is always nil."
(tramp-parse-group (concat "^\\(" tramp-host-regexp "\\)") 1 ","))
-;;;###tramp-autoload
(defun tramp-parse-sconfig (filename)
"Return a list of (user host) tuples allowed to access.
User is always nil."
- (tramp-parse-file filename 'tramp-parse-sconfig-group))
+ (tramp-parse-file filename #'tramp-parse-sconfig-group))
(defun tramp-parse-sconfig-group ()
"Return a (user host) tuple allowed to access.
@@ -2743,7 +2864,7 @@ User is always nil."
(tramp-parse-group
(concat "\\(?:^[ \t]*Host\\)" "\\|" "\\(?:^.+\\)"
"\\|" "\\(" tramp-host-regexp "\\)")
- 1 "[ \t]+"))
+ 1 " \t"))
;; Generic function.
(defun tramp-parse-shostkeys-sknownhosts (dirname regexp)
@@ -2758,14 +2879,12 @@ User is always nil."
when (and (not (string-match "^\\.\\.?$" f)) (string-match regexp f))
collect (list nil (match-string 1 f)))))
-;;;###tramp-autoload
(defun tramp-parse-shostkeys (dirname)
"Return a list of (user host) tuples allowed to access.
User is always nil."
(tramp-parse-shostkeys-sknownhosts
dirname (concat "^key_[0-9]+_\\(" tramp-host-regexp "\\)\\.pub$")))
-;;;###tramp-autoload
(defun tramp-parse-sknownhosts (dirname)
"Return a list of (user host) tuples allowed to access.
User is always nil."
@@ -2773,11 +2892,10 @@ User is always nil."
dirname
(concat "^\\(" tramp-host-regexp "\\)\\.ssh-\\(dss\\|rsa\\)\\.pub$")))
-;;;###tramp-autoload
(defun tramp-parse-hosts (filename)
"Return a list of (user host) tuples allowed to access.
User is always nil."
- (tramp-parse-file filename 'tramp-parse-hosts-group))
+ (tramp-parse-file filename #'tramp-parse-hosts-group))
(defun tramp-parse-hosts-group ()
"Return a (user host) tuple allowed to access.
@@ -2785,7 +2903,6 @@ User is always nil."
(tramp-parse-group
(concat "^\\(" tramp-ipv6-regexp "\\|" tramp-host-regexp "\\)") 1 " \t"))
-;;;###tramp-autoload
(defun tramp-parse-passwd (filename)
"Return a list of (user host) tuples allowed to access.
Host is always \"localhost\"."
@@ -2796,7 +2913,7 @@ Host is always \"localhost\"."
(goto-char (point-min))
(cl-loop while (not (eobp)) collect
(tramp-parse-etc-group-group))))
- (tramp-parse-file filename 'tramp-parse-passwd-group))))
+ (tramp-parse-file filename #'tramp-parse-passwd-group))))
(defun tramp-parse-passwd-group ()
"Return a (user host) tuple allowed to access.
@@ -2808,7 +2925,6 @@ Host is always \"localhost\"."
(forward-line 1)
result))
-;;;###tramp-autoload
(defun tramp-parse-etc-group (filename)
"Return a list of (group host) tuples allowed to access.
Host is always \"localhost\"."
@@ -2819,7 +2935,7 @@ Host is always \"localhost\"."
(goto-char (point-min))
(cl-loop while (not (eobp)) collect
(tramp-parse-etc-group-group))))
- (tramp-parse-file filename 'tramp-parse-etc-group-group))))
+ (tramp-parse-file filename #'tramp-parse-etc-group-group))))
(defun tramp-parse-etc-group-group ()
"Return a (group host) tuple allowed to access.
@@ -2831,26 +2947,16 @@ Host is always \"localhost\"."
(forward-line 1)
result))
-;;;###tramp-autoload
(defun tramp-parse-netrc (filename)
"Return a list of (user host) tuples allowed to access.
User may be nil."
- (tramp-parse-file filename 'tramp-parse-netrc-group))
-
-(defun tramp-parse-netrc-group ()
- "Return a (user host) tuple allowed to access.
-User may be nil."
- (let ((result)
- (regexp
- (concat
- "^[ \t]*machine[ \t]+" "\\(" tramp-host-regexp "\\)"
- "\\([ \t]+login[ \t]+" "\\(" tramp-user-regexp "\\)" "\\)?")))
- (when (re-search-forward regexp (point-at-eol) t)
- (setq result (list (match-string 3) (match-string 1))))
- (forward-line 1)
- result))
+ (require 'netrc)
+ (mapcar
+ (lambda (item)
+ (and (assoc "machine" item)
+ `(,(cdr (assoc "login" item)) ,(cdr (assoc "machine" item)))))
+ (netrc-parse filename)))
-;;;###tramp-autoload
(defun tramp-parse-putty (registry-or-dirname)
"Return a list of (user host) tuples allowed to access.
User is always nil."
@@ -2884,6 +2990,13 @@ User is always nil."
(defvar tramp-handle-write-region-hook nil
"Normal hook to be run at the end of `tramp-*-handle-write-region'.")
+(defun tramp-handle-access-file (filename string)
+ "Like `access-file' for Tramp files."
+ (unless (file-readable-p filename)
+ (tramp-error
+ (tramp-dissect-file-name filename) tramp-file-missing
+ "%s: No such file or directory %s" string filename)))
+
(defun tramp-handle-add-name-to-file
(filename newname &optional ok-if-already-exists)
"Like `add-name-to-file' for Tramp files."
@@ -2905,8 +3018,8 @@ User is always nil."
localname)))))
(tramp-error v 'file-already-exists newname)
(delete-file newname)))
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
(copy-file
filename newname 'ok-if-already-exists 'keep-time
'preserve-uid-gid 'preserve-permissions)))
@@ -2932,10 +3045,10 @@ User is always nil."
(while temp
(setq item (directory-file-name (pop temp)))
- (when (or (null match) (string-match match item))
+ (when (or (null match) (string-match-p match item))
(push (if full (concat directory item) item)
result)))
- (if nosort result (sort result 'string<)))))
+ (if nosort result (sort result #'string<)))))
(defun tramp-handle-directory-files-and-attributes
(directory &optional full match nosort id-format)
@@ -2950,13 +3063,43 @@ User is always nil."
"Like `dired-uncache' for Tramp files."
(with-parsed-tramp-file-name
(if (file-directory-p dir) dir (file-name-directory dir)) nil
- (tramp-flush-directory-property v localname)))
+ (tramp-flush-directory-properties v localname)))
+
+(defun tramp-handle-expand-file-name (name &optional dir)
+ "Like `expand-file-name' for Tramp files."
+ ;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
+ (setq dir (or dir default-directory "/"))
+ ;; Handle empty NAME.
+ (when (zerop (length name)) (setq name "."))
+ ;; Unless NAME is absolute, concat DIR and NAME.
+ (unless (file-name-absolute-p name)
+ (setq name (concat (file-name-as-directory dir) name)))
+ ;; If NAME is not a Tramp file, run the real handler.
+ (if (not (tramp-tramp-file-p name))
+ (tramp-run-real-handler #'expand-file-name (list name nil))
+ ;; Dissect NAME.
+ (with-parsed-tramp-file-name name nil
+ (unless (tramp-run-real-handler #'file-name-absolute-p (list localname))
+ (setq localname (concat "/" localname)))
+ ;; Do normal `expand-file-name' (this does "/./" and "/../").
+ ;; `default-directory' is bound, because on Windows there would
+ ;; be problems with UNC shares or Cygwin mounts.
+ (let ((default-directory (tramp-compat-temporary-file-directory)))
+ (tramp-make-tramp-file-name
+ v (tramp-drop-volume-letter
+ (tramp-run-real-handler #'expand-file-name (list localname))))))))
(defun tramp-handle-file-accessible-directory-p (filename)
"Like `file-accessible-directory-p' for Tramp files."
(and (file-directory-p filename)
(file-readable-p filename)))
+(defun tramp-handle-file-directory-p (filename)
+ "Like `file-directory-p' for Tramp files."
+ (eq (tramp-compat-file-attribute-type
+ (file-attributes (file-truename filename)))
+ t))
+
(defun tramp-handle-file-equal-p (filename1 filename2)
"Like `file-equalp-p' for Tramp files."
;; Native `file-equalp-p' calls `file-truename', which requires a
@@ -2965,7 +3108,7 @@ User is always nil."
(when (string-equal
(file-remote-p (expand-file-name filename1))
(file-remote-p (expand-file-name filename2)))
- (tramp-run-real-handler 'file-equal-p (list filename1 filename2))))
+ (tramp-run-real-handler #'file-equal-p (list filename1 filename2))))
(defun tramp-handle-file-exists-p (filename)
"Like `file-exists-p' for Tramp files."
@@ -2979,7 +3122,18 @@ User is always nil."
(when (string-equal
(file-remote-p (expand-file-name filename))
(file-remote-p (expand-file-name directory)))
- (tramp-run-real-handler 'file-in-directory-p (list filename directory))))
+ (tramp-run-real-handler #'file-in-directory-p (list filename directory))))
+
+(defun tramp-handle-file-local-copy (filename)
+ "Like `file-local-copy' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (unless (file-exists-p filename)
+ (tramp-error
+ v tramp-file-missing
+ "Cannot make local copy of non-existing file `%s'" filename))
+ (let ((tmpfile (tramp-compat-make-temp-file filename)))
+ (copy-file filename tmpfile 'ok-if-already-exists 'keep-time)
+ tmpfile)))
(defun tramp-handle-file-modes (filename)
"Like `file-modes' for Tramp files."
@@ -2997,17 +3151,11 @@ User is always nil."
;; Run the command on the localname portion only unless we are in
;; completion mode.
(tramp-make-tramp-file-name
- (tramp-file-name-method v)
- (tramp-file-name-user v)
- (tramp-file-name-domain v)
- (tramp-file-name-host v)
- (tramp-file-name-port v)
- (if (and (zerop (length (tramp-file-name-localname v)))
- (not (tramp-connectable-p file)))
- ""
- (tramp-run-real-handler
- 'file-name-as-directory (list (or (tramp-file-name-localname v) ""))))
- (tramp-file-name-hop v))))
+ v (or (and (zerop (length (tramp-file-name-localname v)))
+ (not (tramp-connectable-p file)))
+ (tramp-run-real-handler
+ #'file-name-as-directory
+ (list (tramp-file-name-localname v)))))))
(defun tramp-handle-file-name-case-insensitive-p (filename)
"Like `file-name-case-insensitive-p' for Tramp files."
@@ -3034,8 +3182,8 @@ User is always nil."
;; Check, whether we find an existing file with
;; lower case letters. This avoids us to create a
;; temporary file.
- (while (and (string-match
- "[a-z]" (file-remote-p candidate 'localname))
+ (while (and (string-match-p
+ "[a-z]" (tramp-compat-file-local-name candidate))
(not (file-exists-p candidate)))
(setq candidate
(directory-file-name
@@ -3045,8 +3193,8 @@ User is always nil."
;; to Emacs 26+ like `file-name-case-insensitive-p',
;; so there is no compatibility problem calling it.
(unless
- (string-match
- "[a-z]" (file-remote-p candidate 'localname))
+ (string-match-p
+ "[a-z]" (tramp-compat-file-local-name candidate))
(setq tmpfile
(let ((default-directory
(file-name-directory filename)))
@@ -3059,27 +3207,23 @@ User is always nil."
(file-exists-p
(concat
(file-remote-p candidate)
- (upcase (file-remote-p candidate 'localname))))
+ (upcase (tramp-compat-file-local-name candidate))))
;; Cleanup.
(when tmpfile (delete-file tmpfile)))))))))))
(defun tramp-handle-file-name-completion
(filename directory &optional predicate)
"Like `file-name-completion' for Tramp files."
- (unless (tramp-tramp-file-p directory)
- (error
- "tramp-handle-file-name-completion invoked on non-tramp directory `%s'"
- directory))
(let (hits-ignored-extensions)
(or
(try-completion
filename (file-name-all-completions filename directory)
(lambda (x)
- (when (funcall (or predicate 'identity) (expand-file-name x directory))
+ (when (funcall (or predicate #'identity) (expand-file-name x directory))
(not
(and
completion-ignored-extensions
- (string-match
+ (string-match-p
(concat (regexp-opt completion-ignored-extensions 'paren) "$") x)
;; We remember the hit.
(push x hits-ignored-extensions))))))
@@ -3090,24 +3234,19 @@ User is always nil."
"Like `file-name-directory' but aware of Tramp files."
;; Everything except the last filename thing is the directory. We
;; cannot apply `with-parsed-tramp-file-name', because this expands
- ;; the remote file name parts. This is a problem when we are in
- ;; file name completion.
+ ;; the remote file name parts.
(let ((v (tramp-dissect-file-name file t)))
- ;; Run the command on the localname portion only.
+ ;; Run the command on the localname portion only. If this returns
+ ;; nil, mark also the localname part of `v' as nil.
(tramp-make-tramp-file-name
- (tramp-file-name-method v)
- (tramp-file-name-user v)
- (tramp-file-name-domain v)
- (tramp-file-name-host v)
- (tramp-file-name-port v)
- (tramp-run-real-handler
- 'file-name-directory (list (or (tramp-file-name-localname v) "")))
- (tramp-file-name-hop v))))
+ v (or (tramp-run-real-handler
+ #'file-name-directory (list (tramp-file-name-localname v)))
+ 'noloc))))
(defun tramp-handle-file-name-nondirectory (file)
"Like `file-name-nondirectory' but aware of Tramp files."
(with-parsed-tramp-file-name file nil
- (tramp-run-real-handler 'file-name-nondirectory (list localname))))
+ (tramp-run-real-handler #'file-name-nondirectory (list localname))))
(defun tramp-handle-file-newer-than-file-p (file1 file2)
"Like `file-newer-than-file-p' for Tramp files."
@@ -3141,13 +3280,13 @@ User is always nil."
(and (or (not connected) c)
(cond
((eq identification 'method) method)
- ;; Domain and port are appended.
+ ;; Domain and port are appended to user and host,
+ ;; respectively.
((eq identification 'user) (tramp-file-name-user-domain v))
((eq identification 'host) (tramp-file-name-host-port v))
((eq identification 'localname) localname)
((eq identification 'hop) hop)
- (t (tramp-make-tramp-file-name
- method user domain host port "" hop)))))))))
+ (t (tramp-make-tramp-file-name v 'noloc)))))))))
(defun tramp-handle-file-selinux-context (_filename)
"Like `file-selinux-context' for Tramp files."
@@ -3164,7 +3303,7 @@ User is always nil."
;; Preserve trailing "/".
(funcall
(if (string-equal (file-name-nondirectory filename) "")
- 'file-name-as-directory 'identity)
+ #'file-name-as-directory #'identity)
(let ((result (expand-file-name filename))
(numchase 0)
;; Don't make the following value larger than necessary.
@@ -3174,30 +3313,44 @@ User is always nil."
(numchase-limit 20)
symlink-target)
(with-parsed-tramp-file-name result v1
- (with-tramp-file-property v1 v1-localname "file-truename"
- (while (and (setq symlink-target (file-symlink-p result))
- (< numchase numchase-limit))
- (setq numchase (1+ numchase)
- result
- (with-parsed-tramp-file-name (expand-file-name result) v2
- (tramp-make-tramp-file-name
- v2-method v2-user v2-domain v2-host v2-port
- (funcall
- (if (tramp-compat-file-name-quoted-p v2-localname)
- 'tramp-compat-file-name-quote 'identity)
-
- (if (stringp symlink-target)
- (if (file-remote-p symlink-target)
- (let (file-name-handler-alist)
- (tramp-compat-file-name-quote symlink-target))
- (expand-file-name
- symlink-target (file-name-directory v2-localname)))
- v2-localname)))))
- (when (>= numchase numchase-limit)
- (tramp-error
- v1 'file-error
- "Maximum number (%d) of symlinks exceeded" numchase-limit)))
- (directory-file-name result))))))
+ ;; We cache only the localname.
+ (tramp-make-tramp-file-name
+ v1
+ (with-tramp-file-property v1 v1-localname "file-truename"
+ (while (and (setq symlink-target (file-symlink-p result))
+ (< numchase numchase-limit))
+ (setq numchase (1+ numchase)
+ result
+ (with-parsed-tramp-file-name (expand-file-name result) v2
+ (tramp-make-tramp-file-name
+ v2
+ (funcall
+ (if (tramp-compat-file-name-quoted-p v2-localname)
+ #'tramp-compat-file-name-quote #'identity)
+
+ (if (stringp symlink-target)
+ (if (file-remote-p symlink-target)
+ (let (file-name-handler-alist)
+ (tramp-compat-file-name-quote symlink-target))
+ (expand-file-name
+ symlink-target (file-name-directory v2-localname)))
+ v2-localname))
+ 'nohop)))
+ (when (>= numchase numchase-limit)
+ (tramp-error
+ v1 'file-error
+ "Maximum number (%d) of symlinks exceeded" numchase-limit)))
+ (tramp-compat-file-local-name (directory-file-name result))))))))
+
+(defun tramp-handle-file-writable-p (filename)
+ "Like `file-writable-p' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (with-tramp-file-property v localname "file-writable-p"
+ (if (file-exists-p filename)
+ (tramp-check-cached-permissions v ?w)
+ ;; If file doesn't exist, check if directory is writable.
+ (and (file-directory-p (file-name-directory filename))
+ (file-writable-p (file-name-directory filename)))))))
(defun tramp-handle-find-backup-file-name (filename)
"Like `find-backup-file-name' for Tramp files."
@@ -3211,12 +3364,11 @@ User is always nil."
(if (and (stringp (cdr x))
(file-name-absolute-p (cdr x))
(not (tramp-tramp-file-p (cdr x))))
- (tramp-make-tramp-file-name
- method user domain host port (cdr x) hop)
+ (tramp-make-tramp-file-name v (cdr x))
(cdr x))))
tramp-backup-directory-alist)
backup-directory-alist)))
- (tramp-run-real-handler 'find-backup-file-name (list filename)))))
+ (tramp-run-real-handler #'find-backup-file-name (list filename)))))
(defun tramp-handle-insert-directory
(filename switches &optional wildcard full-directory-p)
@@ -3226,16 +3378,19 @@ User is always nil."
(when (and (zerop (length (file-name-nondirectory filename)))
(not full-directory-p))
(setq switches (concat switches "F")))
+ ;; Check, whether directory is accessible.
+ (unless wildcard
+ (access-file filename "Reading directory"))
(with-parsed-tramp-file-name (expand-file-name filename) nil
(with-tramp-progress-reporter v 0 (format "Opening directory %s" filename)
(require 'ls-lisp)
(let (ls-lisp-use-insert-directory-program start)
(tramp-run-real-handler
- 'insert-directory
+ #'insert-directory
(list filename switches wildcard full-directory-p))
;; `ls-lisp' always returns full listings. We must remove
;; superfluous parts.
- (unless (string-match "l" switches)
+ (unless (string-match-p "l" switches)
(save-excursion
(goto-char (point-min))
(while (setq start
@@ -3245,7 +3400,7 @@ User is always nil."
start
(or (text-property-any start (point-at-eol) 'dired-filename t)
(point-at-eol)))
- (if (= (point-at-bol) (point-at-eol))
+ (if (= (point-at-bol) (point-at-eol))
;; Empty line.
(delete-region (point) (progn (forward-line) (point)))
(forward-line)))))))))
@@ -3273,7 +3428,7 @@ User is always nil."
;; run directly.
(setq result
(tramp-run-real-handler
- 'insert-file-contents
+ #'insert-file-contents
(list localname visit beg end replace)))
;; When we shall insert only a part of the file, we
@@ -3317,7 +3472,7 @@ User is always nil."
((stringp remote-copy)
(file-local-copy
(tramp-make-tramp-file-name
- method user domain host port remote-copy)))
+ v remote-copy 'nohop)))
((stringp tramp-temp-buffer-file-name)
(copy-file
filename tramp-temp-buffer-file-name 'ok)
@@ -3327,7 +3482,7 @@ User is always nil."
;; When the file is not readable for the owner, it
;; cannot be inserted, even if it is readable for the
;; group or for everybody.
- (set-file-modes local-copy (string-to-number "0600" 8))
+ (set-file-modes local-copy #o0600)
(when (and (null remote-copy)
(tramp-get-method-parameter
@@ -3361,9 +3516,7 @@ User is always nil."
(or remote-copy (null tramp-temp-buffer-file-name)))
(delete-file local-copy))
(when (stringp remote-copy)
- (delete-file
- (tramp-make-tramp-file-name
- method user domain host port remote-copy)))))
+ (delete-file (tramp-make-tramp-file-name v remote-copy 'nohop)))))
;; Result.
(list (expand-file-name filename)
@@ -3381,14 +3534,13 @@ User is always nil."
;; The first condition is always true for absolute file names.
;; Included for safety's sake.
(unless (or (file-name-directory file)
- (string-match "\\.elc?\\'" file))
+ (string-match-p "\\.elc?\\'" file))
(tramp-error
v 'file-error
"File `%s' does not include a `.el' or `.elc' suffix" file)))
- (unless noerror
- (when (not (file-exists-p file))
- (tramp-error
- v tramp-file-missing "Cannot load nonexistent file `%s'" file)))
+ (unless (or noerror (file-exists-p file))
+ (tramp-error
+ v tramp-file-missing "Cannot load nonexistent file `%s'" file))
(if (not (file-exists-p file))
nil
(let ((tramp-message-show-message (not nomessage)))
@@ -3411,23 +3563,13 @@ support symbolic links."
;; This is needed prior Emacs 26.1, where TARGET has also be
;; checked for a file name handler.
(tramp-run-real-handler
- 'make-symbolic-link (list target linkname ok-if-already-exists))))
+ #'make-symbolic-link (list target linkname ok-if-already-exists))))
(defun tramp-handle-shell-command
(command &optional output-buffer error-buffer)
"Like `shell-command' for Tramp files."
- (let* ((asynchronous (string-match "[ \t]*&[ \t]*\\'" command))
- ;; We cannot use `shell-file-name' and `shell-command-switch',
- ;; they are variables of the local host.
- (args (append
- (cons
- (tramp-get-method-parameter
- (tramp-dissect-file-name default-directory)
- 'tramp-remote-shell)
- (tramp-get-method-parameter
- (tramp-dissect-file-name default-directory)
- 'tramp-remote-shell-args))
- (list (substring command 0 asynchronous))))
+ (let* ((asynchronous (string-match-p "[ \t]*&[ \t]*\\'" command))
+ (command (substring command 0 asynchronous))
current-buffer-p
(output-buffer
(cond
@@ -3444,19 +3586,48 @@ support symbolic links."
(cond
((bufferp error-buffer) error-buffer)
((stringp error-buffer) (get-buffer-create error-buffer))))
- (buffer
- (if (and (not asynchronous) error-buffer)
- (with-parsed-tramp-file-name default-directory nil
- (list output-buffer (tramp-make-tramp-temp-file v)))
- output-buffer))
- (p (get-buffer-process output-buffer)))
-
- ;; Check whether there is another process running. Tramp does not
- ;; support 2 (asynchronous) processes in parallel.
+ (bname (buffer-name output-buffer))
+ (p (get-buffer-process output-buffer))
+ buffer)
+
+ ;; The following code is taken from `shell-command', slightly
+ ;; adapted. Shouldn't it be factored out?
(when p
- (if (yes-or-no-p "A command is running. Kill it? ")
- (ignore-errors (kill-process p))
- (tramp-compat-user-error p "Shell command in progress")))
+ (cond
+ ((eq async-shell-command-buffer 'confirm-kill-process)
+ ;; If will kill a process, query first.
+ (if (yes-or-no-p
+ "A command is running in the default buffer. Kill it? ")
+ (kill-process p)
+ (tramp-user-error p "Shell command in progress")))
+ ((eq async-shell-command-buffer 'confirm-new-buffer)
+ ;; If will create a new buffer, query first.
+ (if (yes-or-no-p
+ "A command is running in the default buffer. Use a new buffer? ")
+ (setq output-buffer (generate-new-buffer bname))
+ (tramp-user-error p "Shell command in progress")))
+ ((eq async-shell-command-buffer 'new-buffer)
+ ;; It will create a new buffer.
+ (setq output-buffer (generate-new-buffer bname)))
+ ((eq async-shell-command-buffer 'confirm-rename-buffer)
+ ;; If will rename the buffer, query first.
+ (if (yes-or-no-p
+ "A command is running in the default buffer. Rename it? ")
+ (progn
+ (with-current-buffer output-buffer
+ (rename-uniquely))
+ (setq output-buffer (get-buffer-create bname)))
+ (tramp-user-error p "Shell command in progress")))
+ ((eq async-shell-command-buffer 'rename-buffer)
+ ;; It will rename the buffer.
+ (with-current-buffer output-buffer
+ (rename-uniquely))
+ (setq output-buffer (get-buffer-create bname)))))
+
+ (setq buffer (if (and (not asynchronous) error-buffer)
+ (with-parsed-tramp-file-name default-directory nil
+ (list output-buffer (tramp-make-tramp-temp-file v)))
+ output-buffer))
(if current-buffer-p
(progn
@@ -3469,18 +3640,19 @@ support symbolic links."
(if (and (not current-buffer-p) (integerp asynchronous))
(prog1
;; Run the process.
- (setq p (apply 'start-file-process "*Async Shell*" buffer args))
+ (setq p (start-file-process-shell-command
+ (buffer-name output-buffer) buffer command))
;; Display output.
(with-current-buffer output-buffer
(display-buffer output-buffer '(nil (allow-no-window . t)))
(setq mode-line-process '(":%s"))
(shell-mode)
- (set-process-sentinel p 'shell-command-sentinel)
- (set-process-filter p 'comint-output-filter)))
+ (set-process-sentinel p #'shell-command-sentinel)
+ (set-process-filter p #'comint-output-filter)))
(prog1
;; Run the process.
- (apply 'process-file (car args) nil buffer nil (cdr args))
+ (process-file-shell-command command nil buffer nil)
;; Insert error messages if they were separated.
(when (listp buffer)
(with-current-buffer error-buffer
@@ -3498,6 +3670,17 @@ support symbolic links."
(when (with-current-buffer output-buffer (> (point-max) (point-min)))
(display-message-or-buffer output-buffer)))))))
+(defun tramp-handle-start-file-process (name buffer program &rest args)
+ "Like `start-file-process' for Tramp files."
+ ;; `make-process' knows the `:file-error' argument since Emacs 27.1.
+ (tramp-file-name-handler
+ 'make-process
+ :name name
+ :buffer buffer
+ :command (and program (cons program args))
+ :noquery nil
+ :file-handler t))
+
(defun tramp-handle-substitute-in-file-name (filename)
"Like `substitute-in-file-name' for Tramp files.
\"//\" and \"/~\" substitute only in the local filename part."
@@ -3507,17 +3690,34 @@ support symbolic links."
;; First, we must replace environment variables.
(setq filename (tramp-replace-environment-variables filename))
(with-parsed-tramp-file-name filename nil
- ;; Ignore in LOCALNAME everything before "//" or "/~".
- (when (and (stringp localname) (string-match ".+?/\\(/\\|~\\)" localname))
- (setq filename
- (concat (file-remote-p filename)
- (replace-match "\\1" nil nil localname)))
- ;; "/m:h:~" does not work for completion. We use "/m:h:~/".
- (when (string-match "~$" filename)
- (setq filename (concat filename "/"))))
- ;; We do not want to replace environment variables, again.
+ ;; We do not want to replace environment variables, again. "//"
+ ;; has a special meaning at the beginning of a file name on
+ ;; Cygwin and MS-Windows, we must remove it.
(let (process-environment)
- (tramp-run-real-handler 'substitute-in-file-name (list filename))))))
+ ;; Ignore in LOCALNAME everything before "//" or "/~".
+ (when (stringp localname)
+ (if (string-match "//\\(/\\|~\\)" localname)
+ (setq filename
+ (replace-regexp-in-string
+ "\\`/+" "/" (substitute-in-file-name localname)))
+ (setq filename
+ (concat (file-remote-p filename)
+ (replace-regexp-in-string
+ "\\`/+" "/"
+ ;; We must disable cygwin-mount file name
+ ;; handlers and alike.
+ (tramp-run-real-handler
+ #'substitute-in-file-name (list localname))))))))
+ ;; "/m:h:~" does not work for completion. We use "/m:h:~/".
+ (if (and (stringp localname) (string-equal "~" localname))
+ (concat filename "/")
+ filename))))
+
+(defconst tramp-time-dont-know '(0 0 0 1000)
+ "An invalid time value, used as \"Don’t know\" value.")
+
+(defconst tramp-time-doesnt-exist '(-1 65535)
+ "An invalid time value, used as \"Doesn’t exist\" value.")
(defun tramp-handle-set-visited-file-modtime (&optional time-list)
"Like `set-visited-file-modtime' for Tramp files."
@@ -3526,14 +3726,12 @@ support symbolic links."
(buffer-name)))
(unless time-list
(let ((remote-file-name-inhibit-cache t))
- ;; '(-1 65535) means file doesn't exists yet.
(setq time-list
(or (tramp-compat-file-attribute-modification-time
(file-attributes (buffer-file-name)))
- '(-1 65535)))))
- ;; We use '(0 0) as a don't-know value.
- (unless (equal time-list '(0 0))
- (tramp-run-real-handler 'set-visited-file-modtime (list time-list))))
+ tramp-time-doesnt-exist))))
+ (unless (tramp-compat-time-equal-p time-list tramp-time-dont-know)
+ (tramp-run-real-handler #'set-visited-file-modtime (list time-list))))
(defun tramp-handle-verify-visited-file-modtime (&optional buf)
"Like `verify-visited-file-modtime' for Tramp files.
@@ -3551,34 +3749,81 @@ of."
(eq (visited-file-modtime) 0)
(not (file-remote-p f nil 'connected)))
t
- (with-parsed-tramp-file-name f nil
- (let* ((remote-file-name-inhibit-cache t)
- (attr (file-attributes f))
- (modtime (tramp-compat-file-attribute-modification-time attr))
- (mt (visited-file-modtime)))
-
- (cond
- ;; File exists, and has a known modtime.
- ((and attr (not (equal modtime '(0 0))))
- (< (abs (tramp-time-diff
- modtime
- ;; For compatibility, deal with both the old
- ;; (HIGH . LOW) and the new (HIGH LOW) return
- ;; values of `visited-file-modtime'.
- (if (atom (cdr mt))
- (list (car mt) (cdr mt))
- mt)))
- 2))
- ;; Modtime has the don't know value.
- (attr t)
- ;; If file does not exist, say it is not modified if and
- ;; only if that agrees with the buffer's record.
- (t (equal mt '(-1 65535))))))))))
+ (let* ((remote-file-name-inhibit-cache t)
+ (attr (file-attributes f))
+ (modtime (tramp-compat-file-attribute-modification-time attr))
+ (mt (visited-file-modtime)))
+ (cond
+ ;; File exists, and has a known modtime.
+ ((and attr
+ (not (tramp-compat-time-equal-p modtime tramp-time-dont-know)))
+ (< (abs (tramp-time-diff modtime mt)) 2))
+ ;; Modtime has the don't know value.
+ (attr t)
+ ;; If file does not exist, say it is not modified if and
+ ;; only if that agrees with the buffer's record.
+ (t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist))))))))
+
+(defun tramp-handle-write-region
+ (start end filename &optional append visit lockname mustbenew)
+ "Like `write-region' for Tramp files."
+ (setq filename (expand-file-name filename))
+ (with-parsed-tramp-file-name filename nil
+ (when (and mustbenew (file-exists-p filename)
+ (or (eq mustbenew 'excl)
+ (not
+ (y-or-n-p
+ (format "File %s exists; overwrite anyway? " filename)))))
+ (tramp-error v 'file-already-exists filename))
+
+ (let ((tmpfile (tramp-compat-make-temp-file filename)))
+ (when (and append (file-exists-p filename))
+ (copy-file filename tmpfile 'ok))
+ ;; We say `no-message' here because we don't want the visited file
+ ;; modtime data to be clobbered from the temp file. We call
+ ;; `set-visited-file-modtime' ourselves later on.
+ (tramp-run-real-handler
+ #'write-region (list start end tmpfile append 'no-message lockname))
+ (condition-case nil
+ (rename-file tmpfile filename 'ok-if-already-exists)
+ (error
+ (delete-file tmpfile)
+ (tramp-error
+ v 'file-error "Couldn't write region to `%s'" filename))))
+
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
+
+ ;; Set file modification time.
+ (when (or (eq visit t) (stringp visit))
+ (set-visited-file-modtime
+ (tramp-compat-file-attribute-modification-time
+ (file-attributes filename))))
+
+ ;; The end.
+ (when (and (null noninteractive)
+ (or (eq visit t) (null visit) (stringp visit)))
+ (tramp-message v 0 "Wrote %s" filename))
+ (run-hooks 'tramp-handle-write-region-hook)))
+
+;; This is used in tramp-sh.el and tramp-sudoedit.el.
+(defconst tramp-stat-marker "/////"
+ "Marker in stat commands for file attributes.")
+
+(defconst tramp-stat-quoted-marker "\\/\\/\\/\\/\\/"
+ "Quoted marker in stat commands for file attributes.")
+
+;; This is used in tramp-gvfs.el and tramp-sh.el.
+(defconst tramp-gio-events
+ '("attribute-changed" "changed" "changes-done-hint"
+ "created" "deleted" "moved" "pre-unmount" "unmounted")
+ "List of events \"gio monitor\" could send.")
+
+;; This is the default handler. tramp-gvfs.el and tramp-sh.el have
+;; their own one.
(defun tramp-handle-file-notify-add-watch (filename _flags _callback)
"Like `file-notify-add-watch' for Tramp files."
- ;; This is the default handler. tramp-gvfs.el and tramp-sh.el have
- ;; their own one.
(setq filename (expand-file-name filename))
(with-parsed-tramp-file-name filename nil
(tramp-error
@@ -3610,17 +3855,17 @@ of."
(defun tramp-action-login (_proc vec)
"Send the login name."
- (when (not (stringp tramp-current-user))
- (setq tramp-current-user
- (with-tramp-connection-property vec "login-as"
- (save-window-excursion
- (let ((enable-recursive-minibuffers t))
- (pop-to-buffer (tramp-get-connection-buffer vec))
- (read-string (match-string 0)))))))
- (with-current-buffer (tramp-get-connection-buffer vec)
- (tramp-message vec 6 "\n%s" (buffer-string)))
- (tramp-message vec 3 "Sending login name `%s'" tramp-current-user)
- (tramp-send-string vec (concat tramp-current-user tramp-local-end-of-line)))
+ (let ((user (or (tramp-file-name-user vec)
+ (with-tramp-connection-property vec "login-as"
+ (save-window-excursion
+ (let ((enable-recursive-minibuffers t))
+ (pop-to-buffer (tramp-get-connection-buffer vec))
+ (read-string (match-string 0))))))))
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ (tramp-message vec 6 "\n%s" (buffer-string)))
+ (tramp-message vec 3 "Sending login name `%s'" user)
+ (tramp-send-string vec (concat user tramp-local-end-of-line)))
+ t)
(defun tramp-action-password (proc vec)
"Query the user for a password."
@@ -3636,11 +3881,12 @@ of."
(tramp-check-for-regexp proc tramp-password-prompt-regexp)
(tramp-message vec 3 "Sending %s" (match-string 1))
;; We don't call `tramp-send-string' in order to hide the
- ;; password from the debug buffer.
+ ;; password from the debug buffer and the traces.
(process-send-string
proc (concat (tramp-read-passwd proc) tramp-local-end-of-line))
;; Hide password prompt.
- (narrow-to-region (point-max) (point-max)))))
+ (narrow-to-region (point-max) (point-max))))
+ t)
(defun tramp-action-succeed (_proc _vec)
"Signal success in finding shell prompt."
@@ -3657,13 +3903,14 @@ Send \"yes\" to remote process on confirmation, abort otherwise.
See also `tramp-action-yn'."
(save-window-excursion
(let ((enable-recursive-minibuffers t))
- (save-match-data (pop-to-buffer (tramp-get-connection-buffer vec)))
+ (pop-to-buffer (tramp-get-connection-buffer vec))
(unless (yes-or-no-p (match-string 0))
(kill-process proc)
(throw 'tramp-action 'permission-denied))
(with-current-buffer (tramp-get-connection-buffer vec)
(tramp-message vec 6 "\n%s" (buffer-string)))
- (tramp-send-string vec (concat "yes" tramp-local-end-of-line)))))
+ (tramp-send-string vec (concat "yes" tramp-local-end-of-line))))
+ t)
(defun tramp-action-yn (proc vec)
"Ask the user for confirmation using `y-or-n-p'.
@@ -3671,13 +3918,14 @@ Send \"y\" to remote process on confirmation, abort otherwise.
See also `tramp-action-yesno'."
(save-window-excursion
(let ((enable-recursive-minibuffers t))
- (save-match-data (pop-to-buffer (tramp-get-connection-buffer vec)))
+ (pop-to-buffer (tramp-get-connection-buffer vec))
(unless (y-or-n-p (match-string 0))
(kill-process proc)
(throw 'tramp-action 'permission-denied))
(with-current-buffer (tramp-get-connection-buffer vec)
(tramp-message vec 6 "\n%s" (buffer-string)))
- (tramp-send-string vec (concat "y" tramp-local-end-of-line)))))
+ (tramp-send-string vec (concat "y" tramp-local-end-of-line))))
+ t)
(defun tramp-action-terminal (_proc vec)
"Tell the remote host which terminal type to use.
@@ -3685,7 +3933,8 @@ The terminal type can be configured with `tramp-terminal-type'."
(tramp-message vec 5 "Setting `%s' as terminal type." tramp-terminal-type)
(with-current-buffer (tramp-get-connection-buffer vec)
(tramp-message vec 6 "\n%s" (buffer-string)))
- (tramp-send-string vec (concat tramp-terminal-type tramp-local-end-of-line)))
+ (tramp-send-string vec (concat tramp-terminal-type tramp-local-end-of-line))
+ t)
(defun tramp-action-process-alive (proc _vec)
"Check, whether a process has finished."
@@ -3695,14 +3944,14 @@ The terminal type can be configured with `tramp-terminal-type'."
(defun tramp-action-out-of-band (proc vec)
"Check, whether an out-of-band copy has finished."
;; There might be pending output for the exit status.
- (tramp-accept-process-output proc 0.1)
+ (while (tramp-accept-process-output proc 0))
(cond ((and (not (process-live-p proc))
(zerop (process-exit-status proc)))
(tramp-message vec 3 "Process has finished.")
(throw 'tramp-action 'ok))
((or (and (memq (process-status proc) '(stop exit))
(not (zerop (process-exit-status proc))))
- (memq (process-status proc) '(signal)))
+ (eq (process-status proc) 'signal))
;; `scp' could have copied correctly, but set modes could have failed.
;; This can be ignored.
(with-current-buffer (process-buffer proc)
@@ -3719,13 +3968,14 @@ The terminal type can be configured with `tramp-terminal-type'."
;;; Functions for processing the actions:
(defun tramp-process-one-action (proc vec actions)
- "Wait for output from the shell and perform one action."
+ "Wait for output from the shell and perform one action.
+See `tramp-process-actions' for the format of ACTIONS."
(let ((case-fold-search t)
found todo item pattern action)
(while (not found)
;; Reread output once all actions have been performed.
;; Obviously, the output was not complete.
- (tramp-accept-process-output proc 1)
+ (while (tramp-accept-process-output proc 0))
(setq todo actions)
(while todo
(setq item (pop todo))
@@ -3742,14 +3992,32 @@ The terminal type can be configured with `tramp-terminal-type'."
"Perform ACTIONS until success or TIMEOUT.
PROC and VEC indicate the remote connection to be used. POS, if
set, is the starting point of the region to be deleted in the
-connection buffer."
+connection buffer.
+
+ACTIONS is a list of (PATTERN ACTION). The PATTERN should be a
+symbol, a variable. The value of this variable gives the regular
+expression to search for. Note that the regexp must match at the
+end of the buffer, \"\\'\" is implicitly appended to it.
+
+The ACTION should also be a symbol, but a function. When the
+corresponding PATTERN matches, the ACTION function is called.
+
+An ACTION function has two arguments (PROC VEC). If it returns
+nil, nothing has been done, and the next action shall be called.
+A non-nil return value indicates that the process output has been
+consumed, and new output shall be retrieved, before starting to
+process all ACTIONs, again. The same happens after calling the
+last ACTION.
+
+If an action determines, that all processing has been done (e.g.,
+because the shell prompt has been detected), it shall throw a
+result. The symbol `ok' means that all ACTIONs have been
+performed successfully. Any other value means an error."
;; Enable `auth-source', unless "emacs -Q" has been called. We must
- ;; use `tramp-current-*' variables in case we have several hops.
+ ;; use the "password-vector" property in case we have several hops.
(tramp-set-connection-property
- (make-tramp-file-name
- :method tramp-current-method :user tramp-current-user
- :domain tramp-current-domain :host tramp-current-host
- :port tramp-current-port)
+ (tramp-get-connection-property
+ proc "password-vector" (process-get proc 'vector))
"first-password-request" tramp-cache-read-persistent-data)
(save-restriction
(with-tramp-progress-reporter
@@ -3768,7 +4036,9 @@ connection buffer."
(with-current-buffer (tramp-get-connection-buffer vec)
(widen)
(tramp-message vec 6 "\n%s" (buffer-string)))
- (unless (eq exit 'ok)
+ (if (eq exit 'ok)
+ (ignore-errors (funcall tramp-password-save-function))
+ ;; Not successful.
(tramp-clear-passwd vec)
(delete-process proc)
(tramp-error-with-buffer
@@ -3781,9 +4051,10 @@ connection buffer."
(tramp-get-connection-buffer vec)))
((eq exit 'process-died)
(substitute-command-keys
- (concat
- "Tramp failed to connect. If this happens repeatedly, try\n"
- " `\\[tramp-cleanup-this-connection]'")))
+ (eval-when-compile
+ (concat
+ "Tramp failed to connect. If this happens repeatedly, try\n"
+ " `\\[tramp-cleanup-this-connection]'"))))
((eq exit 'timeout)
(format-message
"Timeout reached, see buffer `%s' for details"
@@ -3791,28 +4062,36 @@ connection buffer."
(t "Login failed")))))
(when (numberp pos)
(with-current-buffer (tramp-get-connection-buffer vec)
- (let (buffer-read-only) (delete-region pos (point))))))))
+ (let ((inhibit-read-only t)) (delete-region pos (point))))))))
;;; Utility functions:
-(defun tramp-accept-process-output (proc timeout)
+(defun tramp-accept-process-output (proc &optional timeout)
"Like `accept-process-output' for Tramp processes.
This is needed in order to hide `last-coding-system-used', which is set
for process communication also."
(with-current-buffer (process-buffer proc)
- (let (buffer-read-only last-coding-system-used
+ (let ((inhibit-read-only t)
+ last-coding-system-used
;; We do not want to run timers.
- timer-list timer-idle-list)
- ;; Under Windows XP, `accept-process-output' doesn't return
- ;; sometimes. So we add an additional timeout. JUST-THIS-ONE
- ;; is set due to Bug#12145. It is an integer, in order to avoid
- ;; running timers as well.
+ (tl timer-list)
+ (stimers (with-timeout-suspend))
+ timer-list timer-idle-list
+ result)
+ ;; Enable our progress reporter.
+ (dolist (timer tl)
+ (if (eq (timer--function timer) #'tramp-progress-reporter-update)
+ (push timer timer-list)))
+ ;; JUST-THIS-ONE is set due to Bug#12145.
(tramp-message
- proc 10 "%s %s %s\n%s"
- proc (process-status proc)
- (with-timeout (timeout)
- (accept-process-output proc timeout nil 0))
- (buffer-string)))))
+ proc 10 "%s %s %s %s\n%s"
+ proc timeout (process-status proc)
+ (with-local-quit
+ (setq result (accept-process-output proc timeout nil t)))
+ (buffer-string))
+ ;; Reenable the timers.
+ (with-timeout-unsuspend stimers)
+ result)))
(defun tramp-check-for-regexp (proc regexp)
"Check, whether REGEXP is contained in process buffer of PROC.
@@ -3860,20 +4139,20 @@ nil."
(cond (timeout
(with-timeout (timeout)
(while (not found)
- (tramp-accept-process-output proc 1)
+ (tramp-accept-process-output proc)
(unless (process-live-p proc)
(tramp-error-with-buffer
nil proc 'file-error "Process has died"))
(setq found (tramp-check-for-regexp proc regexp)))))
(t
(while (not found)
- (tramp-accept-process-output proc 1)
+ (tramp-accept-process-output proc)
(unless (process-live-p proc)
(tramp-error-with-buffer
nil proc 'file-error "Process has died"))
(setq found (tramp-check-for-regexp proc regexp)))))
(tramp-message proc 6 "\n%s" (buffer-string))
- (when (not found)
+ (unless found
(if timeout
(tramp-error
proc 'file-error "[[Regexp `%s' not found in %d secs]]"
@@ -3892,35 +4171,59 @@ The STRING is expected to use Unix line-endings, but the lines sent to
the remote host use line-endings as defined in the variable
`tramp-rsh-end-of-line'. The communication buffer is erased before sending."
(let* ((p (tramp-get-connection-process vec))
- (chunksize (tramp-get-connection-property p "chunksize" nil)))
+ (chunksize (tramp-get-connection-property p "chunksize" nil))
+ ;; We do not want to run timers.
+ (tl timer-list)
+ (stimers (with-timeout-suspend))
+ timer-list timer-idle-list)
(unless p
(tramp-error
vec 'file-error "Can't send string to remote host -- not logged in"))
(tramp-set-connection-property p "last-cmd-time" (current-time))
(tramp-message vec 10 "%s" string)
+ ;; Enable our progress reporter.
+ (dolist (timer tl)
+ (if (eq (timer--function timer) #'tramp-progress-reporter-update)
+ (push timer timer-list)))
(with-current-buffer (tramp-get-connection-buffer vec)
;; Clean up the buffer. We cannot call `erase-buffer' because
;; narrowing might be in effect.
- (let (buffer-read-only) (delete-region (point-min) (point-max)))
+ (let ((inhibit-read-only t)) (delete-region (point-min) (point-max)))
;; Replace "\n" by `tramp-rsh-end-of-line'.
(setq string
(mapconcat
- 'identity (split-string string "\n") tramp-rsh-end-of-line))
+ #'identity (split-string string "\n") tramp-rsh-end-of-line))
(unless (or (string= string "")
(string-equal (substring string -1) tramp-rsh-end-of-line))
(setq string (concat string tramp-rsh-end-of-line)))
;; Send the string.
- (if (and chunksize (not (zerop chunksize)))
- (let ((pos 0)
- (end (length string)))
- (while (< pos end)
- (tramp-message
- vec 10 "Sending chunk from %s to %s"
- pos (min (+ pos chunksize) end))
- (process-send-string
- p (substring string pos (min (+ pos chunksize) end)))
- (setq pos (+ pos chunksize))))
- (process-send-string p string)))))
+ (with-local-quit
+ (if (and chunksize (not (zerop chunksize)))
+ (let ((pos 0)
+ (end (length string)))
+ (while (< pos end)
+ (tramp-message
+ vec 10 "Sending chunk from %s to %s"
+ pos (min (+ pos chunksize) end))
+ (process-send-string
+ p (substring string pos (min (+ pos chunksize) end)))
+ (setq pos (+ pos chunksize))))
+ (process-send-string p string)))
+ ;; Reenable the timers.
+ (with-timeout-unsuspend stimers))))
+
+(defun tramp-process-sentinel (proc event)
+ "Flush file caches and remove shell prompt."
+ (unless (process-live-p proc)
+ (let ((vec (process-get proc 'vector))
+ (prompt (tramp-get-connection-property proc "prompt" nil)))
+ (when vec
+ (tramp-message vec 5 "Sentinel called: `%S' `%s'" proc event)
+ (tramp-flush-connection-properties proc)
+ (tramp-flush-directory-properties vec ""))
+ (goto-char (point-max))
+ (when (and prompt (re-search-backward (regexp-quote prompt) nil t))
+ (delete-region (point) (point-max))))))
(defun tramp-get-inode (vec)
"Returns the virtual inode number.
@@ -3934,6 +4237,7 @@ If it doesn't exist, generate a new one."
(with-tramp-connection-property (tramp-get-connection-process vec) "device"
(cons -1 (setq tramp-devices (1+ tramp-devices)))))
+;; Comparision of vectors is performed by `tramp-file-name-equal-p'.
(defun tramp-equal-remote (file1 file2)
"Check, whether the remote parts of FILE1 and FILE2 are identical.
The check depends on method, user and host name of the files. If
@@ -3943,7 +4247,7 @@ account.
Example:
- (tramp-equal-remote \"/ssh::/etc\" \"/<your host name>:/home\")
+ (tramp-equal-remote \"/ssh::/etc\" \"/-:<your host name>:/home\")
would yield t. On the other hand, the following check results in nil:
@@ -3952,7 +4256,6 @@ would yield t. On the other hand, the following check results in nil:
(tramp-tramp-file-p file2)
(string-equal (file-remote-p file1) (file-remote-p file2))))
-;;;###tramp-autoload
(defun tramp-mode-string-to-int (mode-string)
"Converts a ten-letter `drwxrwxrwx'-style mode string into mode bits."
(let* (case-fold-search
@@ -3966,53 +4269,52 @@ would yield t. On the other hand, the following check results in nil:
(other-read (aref mode-chars 7))
(other-write (aref mode-chars 8))
(other-execute-or-sticky (aref mode-chars 9)))
- (save-match-data
- (logior
- (cond
- ((char-equal owner-read ?r) (string-to-number "00400" 8))
- ((char-equal owner-read ?-) 0)
- (t (error "Second char `%c' must be one of `r-'" owner-read)))
- (cond
- ((char-equal owner-write ?w) (string-to-number "00200" 8))
- ((char-equal owner-write ?-) 0)
- (t (error "Third char `%c' must be one of `w-'" owner-write)))
- (cond
- ((char-equal owner-execute-or-setid ?x) (string-to-number "00100" 8))
- ((char-equal owner-execute-or-setid ?S) (string-to-number "04000" 8))
- ((char-equal owner-execute-or-setid ?s) (string-to-number "04100" 8))
- ((char-equal owner-execute-or-setid ?-) 0)
- (t (error "Fourth char `%c' must be one of `xsS-'"
- owner-execute-or-setid)))
- (cond
- ((char-equal group-read ?r) (string-to-number "00040" 8))
- ((char-equal group-read ?-) 0)
- (t (error "Fifth char `%c' must be one of `r-'" group-read)))
- (cond
- ((char-equal group-write ?w) (string-to-number "00020" 8))
- ((char-equal group-write ?-) 0)
- (t (error "Sixth char `%c' must be one of `w-'" group-write)))
- (cond
- ((char-equal group-execute-or-setid ?x) (string-to-number "00010" 8))
- ((char-equal group-execute-or-setid ?S) (string-to-number "02000" 8))
- ((char-equal group-execute-or-setid ?s) (string-to-number "02010" 8))
- ((char-equal group-execute-or-setid ?-) 0)
- (t (error "Seventh char `%c' must be one of `xsS-'"
- group-execute-or-setid)))
- (cond
- ((char-equal other-read ?r) (string-to-number "00004" 8))
- ((char-equal other-read ?-) 0)
- (t (error "Eighth char `%c' must be one of `r-'" other-read)))
- (cond
- ((char-equal other-write ?w) (string-to-number "00002" 8))
- ((char-equal other-write ?-) 0)
- (t (error "Ninth char `%c' must be one of `w-'" other-write)))
- (cond
- ((char-equal other-execute-or-sticky ?x) (string-to-number "00001" 8))
- ((char-equal other-execute-or-sticky ?T) (string-to-number "01000" 8))
- ((char-equal other-execute-or-sticky ?t) (string-to-number "01001" 8))
- ((char-equal other-execute-or-sticky ?-) 0)
- (t (error "Tenth char `%c' must be one of `xtT-'"
- other-execute-or-sticky)))))))
+ (logior
+ (cond
+ ((char-equal owner-read ?r) #o0400)
+ ((char-equal owner-read ?-) 0)
+ (t (error "Second char `%c' must be one of `r-'" owner-read)))
+ (cond
+ ((char-equal owner-write ?w) #o0200)
+ ((char-equal owner-write ?-) 0)
+ (t (error "Third char `%c' must be one of `w-'" owner-write)))
+ (cond
+ ((char-equal owner-execute-or-setid ?x) #o0100)
+ ((char-equal owner-execute-or-setid ?S) #o4000)
+ ((char-equal owner-execute-or-setid ?s) #o4100)
+ ((char-equal owner-execute-or-setid ?-) 0)
+ (t (error "Fourth char `%c' must be one of `xsS-'"
+ owner-execute-or-setid)))
+ (cond
+ ((char-equal group-read ?r) #o0040)
+ ((char-equal group-read ?-) 0)
+ (t (error "Fifth char `%c' must be one of `r-'" group-read)))
+ (cond
+ ((char-equal group-write ?w) #o0020)
+ ((char-equal group-write ?-) 0)
+ (t (error "Sixth char `%c' must be one of `w-'" group-write)))
+ (cond
+ ((char-equal group-execute-or-setid ?x) #o0010)
+ ((char-equal group-execute-or-setid ?S) #o2000)
+ ((char-equal group-execute-or-setid ?s) #o2010)
+ ((char-equal group-execute-or-setid ?-) 0)
+ (t (error "Seventh char `%c' must be one of `xsS-'"
+ group-execute-or-setid)))
+ (cond
+ ((char-equal other-read ?r) #o0004)
+ ((char-equal other-read ?-) 0)
+ (t (error "Eighth char `%c' must be one of `r-'" other-read)))
+ (cond
+ ((char-equal other-write ?w) #o0002)
+ ((char-equal other-write ?-) 0)
+ (t (error "Ninth char `%c' must be one of `w-'" other-write)))
+ (cond
+ ((char-equal other-execute-or-sticky ?x) #o0001)
+ ((char-equal other-execute-or-sticky ?T) #o1000)
+ ((char-equal other-execute-or-sticky ?t) #o1001)
+ ((char-equal other-execute-or-sticky ?-) 0)
+ (t (error "Tenth char `%c' must be one of `xtT-'"
+ other-execute-or-sticky))))))
(defconst tramp-file-mode-type-map
'((0 . "-") ; Normal file (SVID-v2 and XPG2)
@@ -4033,17 +4335,16 @@ would yield t. On the other hand, the following check results in nil:
"A list of file types returned from the `stat' system call.
This is used to map a mode number to a permission string.")
-;;;###tramp-autoload
(defun tramp-file-mode-from-int (mode)
"Turn an integer representing a file mode into an ls(1)-like string."
(let ((type (cdr
- (assoc (logand (lsh mode -12) 15) tramp-file-mode-type-map)))
- (user (logand (lsh mode -6) 7))
- (group (logand (lsh mode -3) 7))
- (other (logand (lsh mode -0) 7))
- (suid (> (logand (lsh mode -9) 4) 0))
- (sgid (> (logand (lsh mode -9) 2) 0))
- (sticky (> (logand (lsh mode -9) 1) 0)))
+ (assoc (logand (ash mode -12) 15) tramp-file-mode-type-map)))
+ (user (logand (ash mode -6) 7))
+ (group (logand (ash mode -3) 7))
+ (other (logand (ash mode -0) 7))
+ (suid (> (logand (ash mode -9) 4) 0))
+ (sgid (> (logand (ash mode -9) 2) 0))
+ (sticky (> (logand (ash mode -9) 1) 0)))
(setq user (tramp-file-mode-permissions user suid "s"))
(setq group (tramp-file-mode-permissions group sgid "s"))
(setq other (tramp-file-mode-permissions other sticky "t"))
@@ -4061,20 +4362,53 @@ This is used internally by `tramp-file-mode-from-int'."
(and suid (upcase suid-text)) ; suid, !execute
(and x "x") "-")))) ; !suid
-;;;###tramp-autoload
+;; This is a Tramp internal function. A general `set-file-uid-gid'
+;; outside Tramp is not needed, I believe.
+(defun tramp-set-file-uid-gid (filename &optional uid gid)
+ "Set the ownership for FILENAME.
+If UID and GID are provided, these values are used; otherwise uid
+and gid of the corresponding remote or local user is taken,
+depending whether FILENAME is remote or local. Both parameters
+must be non-negative integers.
+The setgid bit of the upper directory is respected.
+If FILENAME is remote, a file name handler is called."
+ (let* ((dir (file-name-directory filename))
+ (modes (file-modes dir)))
+ (when (and modes (not (zerop (logand modes #o2000))))
+ (setq gid (tramp-compat-file-attribute-group-id (file-attributes dir)))))
+
+ (let ((handler (find-file-name-handler filename 'tramp-set-file-uid-gid)))
+ (if handler
+ (funcall handler #'tramp-set-file-uid-gid filename uid gid)
+ ;; On W32 "chown" does not work.
+ (unless (memq system-type '(ms-dos windows-nt))
+ (let ((uid (or (and (natnump uid) uid) (tramp-get-local-uid 'integer)))
+ (gid (or (and (natnump gid) gid) (tramp-get-local-gid 'integer))))
+ (tramp-call-process
+ nil "chown" nil nil nil
+ (format "%d:%d" uid gid) (shell-quote-argument filename)))))))
+
(defun tramp-get-local-uid (id-format)
"The uid of the local user, in ID-FORMAT.
ID-FORMAT valid values are `string' and `integer'."
- (if (equal id-format 'integer) (user-uid) (user-login-name)))
+ ;; We use key nil for local connection properties.
+ (with-tramp-connection-property nil (format "uid-%s" id-format)
+ (if (equal id-format 'integer) (user-uid) (user-login-name))))
-;;;###tramp-autoload
(defun tramp-get-local-gid (id-format)
"The gid of the local user, in ID-FORMAT.
ID-FORMAT valid values are `string' and `integer'."
- ;; `group-gid' has been introduced with Emacs 24.4.
- (if (and (fboundp 'group-gid) (equal id-format 'integer))
- (tramp-compat-funcall 'group-gid)
- (tramp-compat-file-attribute-group-id (file-attributes "~/" id-format))))
+ ;; We use key nil for local connection properties.
+ (with-tramp-connection-property nil (format "gid-%s" id-format)
+ (cond
+ ;; `group-gid' has been introduced with Emacs 24.4.
+ ((and (fboundp 'group-gid) (equal id-format 'integer))
+ (tramp-compat-funcall 'group-gid))
+ ;; `group-name' has been introduced with Emacs 27.1.
+ ((and (fboundp 'group-name) (equal id-format 'string))
+ (tramp-compat-funcall 'group-name (tramp-compat-funcall 'group-gid)))
+ ((tramp-compat-file-attribute-group-id
+ (file-attributes "~/" id-format))))))
(defun tramp-get-local-locale (&optional vec)
"Determine locale, supporting UTF8 if possible.
@@ -4089,8 +4423,9 @@ VEC is used for tracing."
nil "locale" nil t nil "-a"))))
(while candidates
(goto-char (point-min))
- (if (string-match (format "^%s\r?$" (regexp-quote (car candidates)))
- (buffer-string))
+ (if (string-match-p
+ (format "^%s\r?$" (regexp-quote (car candidates)))
+ (buffer-string))
(setq locale (car candidates)
candidates nil)
(setq candidates (cdr candidates))))))
@@ -4098,7 +4433,6 @@ VEC is used for tracing."
(when vec (tramp-message vec 7 "locale %s" (or locale "C")))
(or locale "C"))))
-;;;###tramp-autoload
(defun tramp-check-cached-permissions (vec access)
"Check `file-attributes' caches for VEC.
Return t if according to the cache access type ACCESS is known to
@@ -4119,15 +4453,7 @@ be granted."
vec (tramp-file-name-localname vec)
(concat "file-attributes-" suffix) nil)
(file-attributes
- (tramp-make-tramp-file-name
- (tramp-file-name-method vec)
- (tramp-file-name-user vec)
- (tramp-file-name-domain vec)
- (tramp-file-name-host vec)
- (tramp-file-name-port vec)
- (tramp-file-name-localname vec)
- (tramp-file-name-hop vec))
- (intern suffix))))
+ (tramp-make-tramp-file-name vec) (intern suffix))))
(remote-uid
(tramp-get-connection-property
vec (concat "uid-" suffix) nil))
@@ -4167,14 +4493,14 @@ be granted."
(tramp-compat-file-attribute-group-id
file-attr))))))))))))
-;;;###tramp-autoload
(defun tramp-local-host-p (vec)
- "Return t if this points to the local host, nil otherwise."
+ "Return t if this points to the local host, nil otherwise.
+This handles also chrooted environments, which are not regarded as local."
(let ((host (tramp-file-name-host vec))
(port (tramp-file-name-port vec)))
(and
- (stringp host)
- (string-match tramp-local-host-regexp host)
+ (stringp tramp-local-host-regexp) (stringp host)
+ (string-match-p tramp-local-host-regexp host)
;; A port is an indication for an ssh tunnel or alike.
(null port)
;; The method shall be applied to one of the shell file name
@@ -4184,11 +4510,7 @@ be granted."
;; The local temp directory must be writable for the other user.
(file-writable-p
(tramp-make-tramp-file-name
- (tramp-file-name-method vec)
- (tramp-file-name-user vec)
- (tramp-file-name-domain vec)
- host port
- (tramp-compat-temporary-file-directory)))
+ vec (tramp-compat-temporary-file-directory) 'nohop))
;; On some systems, chown runs only for root.
(or (zerop (user-uid))
;; This is defined in tramp-sh.el. Let's assume this is
@@ -4198,20 +4520,14 @@ be granted."
(defun tramp-get-remote-tmpdir (vec)
"Return directory for temporary files on the remote host identified by VEC."
(with-tramp-connection-property vec "tmpdir"
- (let ((dir (tramp-make-tramp-file-name
- (tramp-file-name-method vec)
- (tramp-file-name-user vec)
- (tramp-file-name-domain vec)
- (tramp-file-name-host vec)
- (tramp-file-name-port vec)
- (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp")
- (tramp-file-name-hop vec))))
+ (let ((dir
+ (tramp-make-tramp-file-name
+ vec (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp"))))
(or (and (file-directory-p dir) (file-writable-p dir)
- (file-remote-p dir 'localname))
+ (tramp-compat-file-local-name dir))
(tramp-error vec 'file-error "Directory %s not accessible" dir))
dir)))
-;;;###tramp-autoload
(defun tramp-make-tramp-temp-file (vec)
"Create a temporary file on the remote host identified by VEC.
Return the local name of the temporary file."
@@ -4228,7 +4544,7 @@ Return the local name of the temporary file."
(setq result nil)
;; This creates the file by side effect.
(set-file-times result)
- (set-file-modes result (string-to-number "0700" 8))))
+ (set-file-modes result #o0700)))
;; Return the local part.
(with-parsed-tramp-file-name result nil localname)))
@@ -4238,11 +4554,11 @@ Return the local name of the temporary file."
(when (stringp tramp-temp-buffer-file-name)
(ignore-errors (delete-file tramp-temp-buffer-file-name))))
-(add-hook 'kill-buffer-hook 'tramp-delete-temp-file-function)
+(add-hook 'kill-buffer-hook #'tramp-delete-temp-file-function)
(add-hook 'tramp-unload-hook
(lambda ()
(remove-hook 'kill-buffer-hook
- 'tramp-delete-temp-file-function)))
+ #'tramp-delete-temp-file-function)))
(defun tramp-handle-make-auto-save-file-name ()
"Like `make-auto-save-file-name' for Tramp files.
@@ -4278,7 +4594,7 @@ this file, if that variable is non-nil."
(tramp-compat-file-name-unquote (buffer-file-name)))
tramp-auto-save-directory))))
;; Run plain `make-auto-save-file-name'.
- (tramp-run-real-handler 'make-auto-save-file-name nil)))
+ (tramp-run-real-handler #'make-auto-save-file-name nil)))
(defun tramp-subst-strs-in-string (alist string)
"Replace all occurrences of the string FROM with TO in STRING.
@@ -4317,22 +4633,18 @@ ALIST is of the form ((FROM . TO) ...)."
It always returns a return code. The Lisp error raised when
PROGRAM is nil is trapped also, returning 1. Furthermore, traces
are written with verbosity of 6."
- (let ((default-directory (tramp-compat-temporary-file-directory))
- (v (or vec
- (make-tramp-file-name
- :method tramp-current-method :user tramp-current-user
- :domain tramp-current-domain :host tramp-current-host
- :port tramp-current-port)))
+ (let ((default-directory (tramp-compat-temporary-file-directory))
(destination (if (eq destination t) (current-buffer) destination))
+ (vec (or vec (car tramp-current-connection)))
output error result)
(tramp-message
- v 6 "`%s %s' %s %s"
- program (mapconcat 'identity args " ") infile destination)
+ vec 6 "`%s %s' %s %s"
+ program (mapconcat #'identity args " ") infile destination)
(condition-case err
(with-temp-buffer
(setq result
(apply
- 'call-process program infile (or destination t) display args))
+ #'call-process program infile (or destination t) display args))
;; `result' could also be an error string.
(when (stringp result)
(setq error result
@@ -4344,8 +4656,8 @@ are written with verbosity of 6."
(setq error (error-message-string err)
result 1)))
(if (zerop (length error))
- (tramp-message v 6 "%d\n%s" result output)
- (tramp-message v 6 "%d\n%s\n%s" result output error))
+ (tramp-message vec 6 "%d\n%s" result output)
+ (tramp-message vec 6 "%d\n%s\n%s" result output error))
result))
(defun tramp-call-process-region
@@ -4354,55 +4666,75 @@ are written with verbosity of 6."
It always returns a return code. The Lisp error raised when
PROGRAM is nil is trapped also, returning 1. Furthermore, traces
are written with verbosity of 6."
- (let ((default-directory (tramp-compat-temporary-file-directory))
- (v (or vec
- (make-tramp-file-name
- :method tramp-current-method :user tramp-current-user
- :domain tramp-current-domain :host tramp-current-host
- :port tramp-current-port)))
+ (let ((default-directory (tramp-compat-temporary-file-directory))
(buffer (if (eq buffer t) (current-buffer) buffer))
result)
(tramp-message
- v 6 "`%s %s' %s %s %s %s"
- program (mapconcat 'identity args " ") start end delete buffer)
+ vec 6 "`%s %s' %s %s %s %s"
+ program (mapconcat #'identity args " ") start end delete buffer)
(condition-case err
(progn
(setq result
(apply
- 'call-process-region
+ #'call-process-region
start end program delete buffer display args))
;; `result' could also be an error string.
(when (stringp result)
(signal 'file-error (list result)))
(with-current-buffer (if (bufferp buffer) buffer (current-buffer))
(if (zerop result)
- (tramp-message v 6 "%d" result)
- (tramp-message v 6 "%d\n%s" result (buffer-string)))))
+ (tramp-message vec 6 "%d" result)
+ (tramp-message vec 6 "%d\n%s" result (buffer-string)))))
(error
(setq result 1)
- (tramp-message v 6 "%d\n%s" result (error-message-string err))))
+ (tramp-message vec 6 "%d\n%s" result (error-message-string err))))
+ result))
+
+(defun tramp-process-lines
+ (vec program &rest args)
+ "Calls `process-lines' on the local host.
+If an error occurs, it returns nil. Traces are written with
+verbosity of 6."
+ (let ((default-directory (tramp-compat-temporary-file-directory))
+ (vec (or vec (car tramp-current-connection)))
+ result)
+ (if args
+ (tramp-message vec 6 "%s %s" program (mapconcat #'identity args " "))
+ (tramp-message vec 6 "%s" program))
+ (setq result
+ (condition-case err
+ (apply #'process-lines program args)
+ (error
+ (tramp-error vec (car err) (cdr err)))))
+ (tramp-message vec 6 "%s" result)
result))
-;;;###tramp-autoload
(defun tramp-read-passwd (proc &optional prompt)
"Read a password from user (compat function).
Consults the auth-source package.
Invokes `password-read' if available, `read-passwd' else."
(let* ((case-fold-search t)
(key (tramp-make-tramp-file-name
- tramp-current-method tramp-current-user tramp-current-domain
- tramp-current-host tramp-current-port ""))
+ ;; In tramp-sh.el, we must use "password-vector" due to
+ ;; multi-hop.
+ (tramp-get-connection-property
+ proc "password-vector" (process-get proc 'vector))
+ 'noloc 'nohop))
(pw-prompt
(or prompt
(with-current-buffer (process-buffer proc)
(tramp-check-for-regexp proc tramp-password-prompt-regexp)
(format "%s for %s " (capitalize (match-string 1)) key))))
+ (auth-source-creation-prompts `((secret . ,pw-prompt)))
;; We suspend the timers while reading the password.
(stimers (with-timeout-suspend))
auth-info auth-passwd)
(unwind-protect
(with-parsed-tramp-file-name key nil
+ (setq tramp-password-save-function nil
+ user
+ (or user (tramp-get-connection-property key "login-as" nil)))
(prog1
(or
;; See if auth-sources contains something useful.
@@ -4411,78 +4743,62 @@ Invokes `password-read' if available, `read-passwd' else."
v "first-password-request" nil)
;; Try with Tramp's current method.
(setq auth-info
- (auth-source-search
- :max 1
- (and tramp-current-user :user)
- (if tramp-current-domain
- (format
- "%s%s%s"
- tramp-current-user tramp-prefix-domain-format
- tramp-current-domain)
- tramp-current-user)
- :host
- (if tramp-current-port
- (format
- "%s%s%s"
- tramp-current-host tramp-prefix-port-format
- tramp-current-port)
- tramp-current-host)
- :port tramp-current-method
- :require
- (cons
- :secret (and tramp-current-user '(:user))))
- auth-passwd (plist-get
- (nth 0 auth-info) :secret)
- auth-passwd (if (functionp auth-passwd)
- (funcall auth-passwd)
- auth-passwd))))
+ (car
+ (auth-source-search
+ :max 1
+ (and user :user)
+ (if domain
+ (concat
+ user tramp-prefix-domain-format domain)
+ user)
+ :host
+ (if port
+ (concat
+ host tramp-prefix-port-format port)
+ host)
+ :port method
+ :require (cons :secret (and user '(:user)))
+ :create t))
+ tramp-password-save-function
+ (plist-get auth-info :save-function)
+ auth-passwd (plist-get auth-info :secret)))
+ (while (functionp auth-passwd)
+ (setq auth-passwd (funcall auth-passwd)))
+ auth-passwd)
+
;; Try the password cache.
- (let ((password (password-read pw-prompt key)))
- (password-cache-add key password)
- password)
- ;; Else, get the password interactively.
+ (progn
+ (setq auth-passwd (password-read pw-prompt key)
+ tramp-password-save-function
+ (lambda () (password-cache-add key auth-passwd)))
+ auth-passwd)
+
+ ;; Else, get the password interactively w/o cache.
(read-passwd pw-prompt))
+
(tramp-set-connection-property v "first-password-request" nil)))
+
;; Reenable the timers.
(with-timeout-unsuspend stimers))))
-;;;###tramp-autoload
(defun tramp-clear-passwd (vec)
"Clear password cache for connection related to VEC."
(let ((method (tramp-file-name-method vec))
- (user (tramp-file-name-user vec))
- (domain (tramp-file-name-domain vec))
(user-domain (tramp-file-name-user-domain vec))
- (host (tramp-file-name-host vec))
- (port (tramp-file-name-port vec))
(host-port (tramp-file-name-host-port vec))
(hop (tramp-file-name-hop vec)))
(when hop
;; Clear also the passwords of the hops.
- (tramp-clear-passwd
- (tramp-dissect-file-name
- (concat
- tramp-prefix-format
- (replace-regexp-in-string
- (concat tramp-postfix-hop-regexp "$")
- tramp-postfix-host-format hop)))))
+ (tramp-clear-passwd (tramp-dissect-hop-name hop)))
(auth-source-forget
`(:max 1 ,(and user-domain :user) ,user-domain
:host ,host-port :port ,method))
- (password-cache-remove
- (tramp-make-tramp-file-name method user domain host port ""))))
-
-;; Snarfed code from time-date.el.
-
-(defconst tramp-half-a-year '(241 17024)
-"Evaluated by \"(days-to-time 183)\".")
+ (password-cache-remove (tramp-make-tramp-file-name vec 'noloc 'nohop))))
-;;;###tramp-autoload
(defun tramp-time-diff (t1 t2)
"Return the difference between the two times, in seconds.
T1 and T2 are time values (as returned by `current-time' for example)."
- ;; Starting with Emacs 25.1, we could change this to use `time-subtract'.
- (float-time (tramp-compat-funcall 'subtract-time t1 t2)))
+ (float-time (time-subtract t1 t2)))
(defun tramp-unquote-shell-quote-argument (s)
"Remove quotation prefix \"/:\" from string S, and quote it then for shell."
@@ -4509,7 +4825,6 @@ T1 and T2 are time values (as returned by `current-time' for example)."
;;
;; Thanks to Mario DeWeerd for the hint that it is sufficient for this
;; function to work with Bourne-like shells.
-;;;###tramp-autoload
(defun tramp-shell-quote-argument (s)
"Similar to `shell-quote-argument', but groks newlines.
Only works for Bourne-like shells."
@@ -4541,64 +4856,28 @@ Only works for Bourne-like shells."
pid)
;; If it's a Tramp process, send the INT signal remotely.
(when (and (processp proc) (setq pid (process-get proc 'remote-pid)))
- (if (not (process-live-p proc))
+ (if (not (process-live-p proc))
(tramp-error proc 'error "Process %s is not active" proc)
(tramp-message proc 5 "Interrupt process %s with pid %s" proc pid)
;; This is for tramp-sh.el. Other backends do not support this (yet).
(tramp-compat-funcall
'tramp-send-command
- (tramp-get-connection-property proc "vector" nil)
+ (process-get proc 'vector)
(format "kill -2 %d" pid))
;; Wait, until the process has disappeared. If it doesn't,
;; fall back to the default implementation.
(with-timeout (1 (ignore))
- (while (process-live-p proc)
- ;; We cannot run `tramp-accept-process-output', it blocks timers.
- (accept-process-output proc 0.1))
+ (while (tramp-accept-process-output proc))
;; Report success.
proc)))))
;; `interrupt-process-functions' exists since Emacs 26.1.
(when (boundp 'interrupt-process-functions)
- (add-hook 'interrupt-process-functions 'tramp-interrupt-process)
+ (add-hook 'interrupt-process-functions #'tramp-interrupt-process)
(add-hook
'tramp-unload-hook
(lambda ()
- (remove-hook 'interrupt-process-functions 'tramp-interrupt-process))))
-
-;;; Integration of eshell.el:
-
-;; eshell.el keeps the path in `eshell-path-env'. We must change it
-;; when `default-directory' points to another host.
-(defun tramp-eshell-directory-change ()
- "Set `eshell-path-env' to $PATH of the host related to `default-directory'."
- (setq eshell-path-env
- (if (tramp-tramp-file-p default-directory)
- (with-parsed-tramp-file-name default-directory nil
- (mapconcat
- 'identity
- (or
- ;; When `tramp-own-remote-path' is in `tramp-remote-path',
- ;; the remote path is only set in the session cache.
- ;; Use `path-separator' as it does eshell.
- (tramp-get-connection-property
- (tramp-get-connection-process v) "remote-path" nil)
- (tramp-get-connection-property v "remote-path" nil))
- path-separator))
- (getenv "PATH"))))
-
-(eval-after-load "esh-util"
- '(progn
- (add-hook 'eshell-mode-hook
- 'tramp-eshell-directory-change)
- (add-hook 'eshell-directory-change-hook
- 'tramp-eshell-directory-change)
- (add-hook 'tramp-unload-hook
- (lambda ()
- (remove-hook 'eshell-mode-hook
- 'tramp-eshell-directory-change)
- (remove-hook 'eshell-directory-change-hook
- 'tramp-eshell-directory-change)))))
+ (remove-hook 'interrupt-process-functions #'tramp-interrupt-process))))
;; Checklist for `tramp-unload-hook'
;; - Unload all `tramp-*' packages
@@ -4610,13 +4889,16 @@ Only works for Bourne-like shells."
(defun tramp-unload-tramp ()
"Discard Tramp from loading remote files."
(interactive)
- ;; ange-ftp settings must be enabled.
+ ;; ange-ftp settings must be re-enabled.
(tramp-compat-funcall 'tramp-ftp-enable-ange-ftp)
;; Maybe it's not loaded yet.
(ignore-errors (unload-feature 'tramp 'force)))
(provide 'tramp)
+(run-hooks 'tramp--startup-hook)
+(setq tramp--startup-hook nil)
+
;;; TODO:
;;
;; * Avoid screen blanking when hitting `g' in dired. (Eli Tziperman)
@@ -4639,6 +4921,12 @@ Only works for Bourne-like shells."
;; and friends, for most of the handlers this is the major
;; difference between the different backends. Other handlers but
;; *-process-file would profit from this as well.
+;;
+;; * Get rid of `shell-command'. In its primary implementation, it
+;; uses `process-file-shell-command' and
+;; `start-file-process-shell-command', which is sufficient due to
+;; connection-local `shell-file-name'.
+
;;; tramp.el ends here
diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el
index 5f10cd30ba6..83d34c02220 100644
--- a/lisp/net/trampver.el
+++ b/lisp/net/trampver.el
@@ -7,7 +7,6 @@
;; Maintainer: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
;; Package: tramp
-;; Version: 2.3.5.26.2
;; This file is part of GNU Emacs.
@@ -26,39 +25,49 @@
;;; Code:
-;; In the Tramp GIT repository, the version number and the bug report
-;; address are auto-frobbed from configure.ac, so you should edit that
-;; file and run "autoconf && ./configure" to change them. Emacs
-;; version check is defined in macro AC_EMACS_INFO of aclocal.m4;
-;; should be changed only there.
+;; In the Tramp GIT, the version number is auto-frobbed from tramp.el,
+;; and the bug report address is auto-frobbed from configure.ac.
+;; Emacs version check is defined in macro AC_EMACS_INFO of
+;; aclocal.m4; should be changed only there.
;;;###tramp-autoload
-(defconst tramp-version "2.3.5.26.2"
+(defconst tramp-version "2.4.2-pre"
"This version of Tramp.")
;;;###tramp-autoload
(defconst tramp-bug-report-address "tramp-devel@gnu.org"
"Email address to send bug reports to.")
-(defun tramp-repository-get-version ()
- "Try to return as a string the repository revision of the Tramp sources."
- (let ((dir (locate-dominating-file (locate-library "tramp") ".git")))
- (when dir
- (with-temp-buffer
- (let ((default-directory (file-name-as-directory dir)))
- (and (zerop
- (ignore-errors
- (call-process "git" nil '(t nil) nil "rev-parse" "HEAD")))
- (not (zerop (buffer-size)))
- (replace-regexp-in-string "\n" "" (buffer-string))))))))
+(defconst tramp-repository-branch
+ (ignore-errors
+ ;; Suppress message from `emacs-repository-get-branch'. We must
+ ;; also handle out-of-tree builds.
+ (let ((inhibit-message t)
+ (dir (or (locate-dominating-file (locate-library "tramp") ".git")
+ source-directory)))
+ ;; `emacs-repository-get-branch' has been introduced with Emacs 27.1.
+ (with-no-warnings
+ (and (stringp dir) (file-directory-p dir)
+ (emacs-repository-get-branch dir)))))
+ "The repository branch of the Tramp sources.")
+
+(defconst tramp-repository-version
+ (ignore-errors
+ ;; Suppress message from `emacs-repository-get-version'. We must
+ ;; also handle out-of-tree builds.
+ (let ((inhibit-message t)
+ (dir (or (locate-dominating-file (locate-library "tramp") ".git")
+ source-directory)))
+ (and (stringp dir) (file-directory-p dir)
+ (emacs-repository-get-version dir))))
+ "The repository revision of the Tramp sources.")
;; Check for Emacs version.
-(let ((x (if (>= emacs-major-version 24)
- "ok"
- (format "Tramp 2.3.5.26.2 is not fit for %s"
- (when (string-match "^.*$" (emacs-version))
- (match-string 0 (emacs-version)))))))
- (unless (string-match "\\`ok\\'" x) (error "%s" x)))
+(let ((x (if (not (string-lessp emacs-version "24.1"))
+ "ok"
+ (format "Tramp 2.4.2-pre is not fit for %s"
+ (replace-regexp-in-string "\n" "" (emacs-version))))))
+ (unless (string-equal "ok" x) (error "%s" x)))
;; Tramp versions integrated into Emacs. If a user option declares a
;; `:package-version' which doesn't belong to an integrated Tramp
diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el
index 40df23e174a..e297b9d6108 100644
--- a/lisp/net/webjump.el
+++ b/lisp/net/webjump.el
@@ -342,7 +342,7 @@ Please submit bug reports and other feedback to the author, Neil W. Van Dyke
(mapconcat (lambda (c)
(let ((s (char-to-string c)))
(cond ((string= s " ") "+")
- ((string-match "[a-zA-Z_.-/]" s) s)
+ ((string-match "[a-zA-Z_./~-]" s) s)
(t (upcase (format "%%%02x" c))))))
(encode-coding-string str 'utf-8)
""))
diff --git a/lisp/net/zeroconf.el b/lisp/net/zeroconf.el
index 8c58bcc41a9..36643a828eb 100644
--- a/lisp/net/zeroconf.el
+++ b/lisp/net/zeroconf.el
@@ -382,6 +382,8 @@ TYPE. The resulting list has the format
;; `zeroconf-services-hash'.
(gethash (concat name "/" type) zeroconf-services-hash nil))
+(defvar dbus-debug)
+
(defun zeroconf-resolve-service (service)
"Return all service attributes SERVICE as list.
NAME must be a string. The service must be of service type
@@ -526,22 +528,27 @@ DOMAIN is nil, the local domain is used."
zeroconf-avahi-current-domain
zeroconf-avahi-flags-unspec))))
+(defvar zeroconf-service-type-browser-handler-running nil
+ "Prevent infinite recursion in `zeroconf-service-type-browser-handler'.")
+
(defun zeroconf-service-type-browser-handler (&rest val)
"Registered service type browser handler at the Avahi daemon."
- (when zeroconf-debug
- (message "zeroconf-service-type-browser-handler: %s %S"
- (dbus-event-member-name last-input-event) val))
- (cond
- ((string-equal (dbus-event-member-name last-input-event) "ItemNew")
- ;; Parameters: (interface protocol type domain flags)
- ;; Register a service browser.
- (let ((object-path (zeroconf-register-service-browser (nth 2 val))))
- ;; Register the signals.
- (dolist (member '("ItemNew" "ItemRemove" "Failure"))
- (dbus-register-signal
- :system zeroconf-service-avahi object-path
- zeroconf-interface-avahi-service-browser member
- 'zeroconf-service-browser-handler))))))
+ (unless zeroconf-service-type-browser-handler-running
+ (let ((zeroconf-service-type-browser-handler-running t))
+ (when zeroconf-debug
+ (message "zeroconf-service-type-browser-handler: %s %S"
+ (dbus-event-member-name last-input-event) val))
+ (cond
+ ((string-equal (dbus-event-member-name last-input-event) "ItemNew")
+ ;; Parameters: (interface protocol type domain flags)
+ ;; Register a service browser.
+ (let ((object-path (zeroconf-register-service-browser (nth 2 val))))
+ ;; Register the signals.
+ (dolist (member '("ItemNew" "ItemRemove" "Failure"))
+ (dbus-register-signal
+ :system zeroconf-service-avahi object-path
+ zeroconf-interface-avahi-service-browser member
+ 'zeroconf-service-browser-handler))))))))
(defun zeroconf-register-service-browser (type)
"Register a service browser at the Avahi daemon."
diff --git a/lisp/newcomment.el b/lisp/newcomment.el
index 335cbdd3366..9d919ccbbea 100644
--- a/lisp/newcomment.el
+++ b/lisp/newcomment.el
@@ -159,6 +159,14 @@ The function has no args.
Applicable at least in modes for languages like fixed-format Fortran where
comments always start in column zero.")
+(defvar-local comment-combine-change-calls t
+ "If non-nil (the default), use `combine-change-calls' around
+ calls of `comment-region-function' and
+ `uncomment-region-function'. This Substitutes a single call to
+ each of the hooks `before-change-functions' and
+ `after-change-functions' in place of those hooks being called
+ for each individual buffer change.")
+
(defvar comment-region-function 'comment-region-default
"Function to comment a region.
Its args are the same as those of `comment-region', but BEG and END are
@@ -527,7 +535,7 @@ Ensure that `comment-normalize-vars' has been called before you use this."
;; comment-search-backward is only used to find the comment-column (in
;; comment-set-column) and to find the comment-start string (via
;; comment-beginning) in indent-new-comment-line, it should be harmless.
- (if (not (re-search-backward comment-start-skip limit t))
+ (if (not (re-search-backward comment-start-skip limit 'move))
(unless noerror (error "No comment"))
(beginning-of-line)
(let* ((end (match-end 0))
@@ -898,7 +906,7 @@ comment delimiters."
(save-excursion
(funcall uncomment-region-function beg end arg))))
-(defun uncomment-region-default (beg end &optional arg)
+(defun uncomment-region-default-1 (beg end &optional arg)
"Uncomment each line in the BEG .. END region.
The numeric prefix ARG can specify a number of chars to remove from the
comment delimiters.
@@ -996,6 +1004,15 @@ This function is the default value of `uncomment-region-function'."
(goto-char (point-max))))))
(set-marker end nil))
+(defun uncomment-region-default (beg end &optional arg)
+ "Uncomment each line in the BEG .. END region.
+The numeric prefix ARG can specify a number of chars to remove from the
+comment markers."
+ (if comment-combine-change-calls
+ (combine-change-calls beg end (uncomment-region-default-1 beg end arg))
+ (uncomment-region-default-1 beg end arg)))
+
+
(defun comment-make-bol-ws (len)
"Make a white-space string of width LEN for use at BOL.
When `indent-tabs-mode' is non-nil, tab characters will be used."
@@ -1192,7 +1209,7 @@ changed with `comment-style'."
;; FIXME: maybe we should call uncomment depending on ARG.
(funcall comment-region-function beg end arg)))
-(defun comment-region-default (beg end &optional arg)
+(defun comment-region-default-1 (beg end &optional arg)
(let* ((numarg (prefix-numeric-value arg))
(style (cdr (assoc comment-style comment-styles)))
(lines (nth 2 style))
@@ -1261,6 +1278,11 @@ changed with `comment-style'."
lines
indent))))))
+(defun comment-region-default (beg end &optional arg)
+ (if comment-combine-change-calls
+ (combine-change-calls beg end (comment-region-default-1 beg end arg))
+ (comment-region-default-1 beg end arg)))
+
;;;###autoload
(defun comment-box (beg end &optional arg)
"Comment out the BEG .. END region, putting it inside a box.
diff --git a/lisp/notifications.el b/lisp/notifications.el
index baab00a0e5a..1d250e2d920 100644
--- a/lisp/notifications.el
+++ b/lisp/notifications.el
@@ -232,8 +232,8 @@ of another `notifications-notify' call."
(add-to-list 'hints `(:dict-entry
"urgency"
(:variant :byte ,(pcase urgency
- (`low 0)
- (`critical 2)
+ ('low 0)
+ ('critical 2)
(_ 1)))) t))
(when category
(add-to-list 'hints `(:dict-entry
diff --git a/lisp/novice.el b/lisp/novice.el
index e4aa2eeef4c..3da4e25810a 100644
--- a/lisp/novice.el
+++ b/lisp/novice.el
@@ -35,9 +35,6 @@
;; and the keys are returned by (this-command-keys).
;;;###autoload
-(define-obsolete-variable-alias 'disabled-command-hook
- 'disabled-command-function "22.1")
-;;;###autoload
(defvar disabled-command-function 'disabled-command-function
"Function to call to handle disabled commands.
If nil, the feature is disabled, i.e., all commands work normally.")
diff --git a/lisp/nxml/nxml-maint.el b/lisp/nxml/nxml-maint.el
index 2570e51af51..2956efb736e 100644
--- a/lisp/nxml/nxml-maint.el
+++ b/lisp/nxml/nxml-maint.el
@@ -34,10 +34,10 @@
(let (lst head)
(with-current-buffer (find-file-noselect file)
(goto-char (point-min))
- (while (re-search-forward "^ *\\([a-FA-F0-9]\\{2\\}\\)[ \t]+" nil t)
+ (while (re-search-forward "^ *\\([a-fA-F0-9]\\{2\\}\\)[ \t]+" nil t)
(let ((row (match-string 1))
(eol (line-end-position)))
- (while (re-search-forward "\\([a-FA-F0-9]\\{2\\}\\)-\\([a-FA-F0-9]\\{2\\}\\)\\|\\([a-FA-F0-9]\\{2\\}\\)" eol t)
+ (while (re-search-forward "\\([a-fA-F0-9]\\{2\\}\\)-\\([a-fA-F0-9]\\{2\\}\\)\\|\\([a-fA-F0-9]\\{2\\}\\)" eol t)
(setq lst
(cons (if (match-beginning 3)
(concat "#x" row (match-string 3))
diff --git a/lisp/nxml/nxml-mode.el b/lisp/nxml/nxml-mode.el
index f17f5843b80..6f80912dd58 100644
--- a/lisp/nxml/nxml-mode.el
+++ b/lisp/nxml/nxml-mode.el
@@ -56,8 +56,9 @@ The glyph is displayed in face `nxml-glyph'."
:group 'nxml
:type 'boolean)
-(defcustom nxml-sexp-element-flag nil
+(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)
@@ -471,11 +472,10 @@ The Emacs commands that normally operate on balanced expressions will
operate on XML markup items. Thus \\[forward-sexp] will move forward
across one markup item; \\[backward-sexp] will move backward across
one markup item; \\[kill-sexp] will kill the following markup item;
-\\[mark-sexp] will mark the following markup item. By default, each
-tag each treated as a single markup item; to make the complete element
-be treated as a single markup item, set the variable
-`nxml-sexp-element-flag' to t. For more details, see the function
-`nxml-forward-balanced-item'.
+\\[mark-sexp] will mark the following markup item. By default, the
+complete element is treated as a single markup item; to make each tag be
+treated as a separate markup item, set the variable `nxml-sexp-element-flag'
+to nil. For more details, see the function `nxml-forward-balanced-item'.
\\[nxml-backward-up-element] and \\[nxml-down-element] move up and down the element structure.
@@ -493,7 +493,7 @@ Many aspects this mode can be customized using
;; FIXME: Use the fact that we're parsing the document already
;; rather than using regex-based filtering.
(setq-local tildify-foreach-region-function
- (apply-partially #'tildify-foreach-ignore-environments
+ (apply-partially 'tildify-foreach-ignore-environments
'(("<! *--" . "-- *>") ("<" . ">"))))
(setq-local mode-line-process '((nxml-degraded "/degraded")))
;; We'll determine the fill prefix ourselves
@@ -1510,17 +1510,18 @@ With ARG, do it that many times. Negative arg -N means
move backward across N balanced expressions.
This is the equivalent of `forward-sexp' for XML.
-An element contains as items strings with no markup, tags, processing
-instructions, comments, CDATA sections, entity references and
-characters references. However, if the variable
-`nxml-sexp-element-flag' is non-nil, then an element is treated as a
-single markup item. A start-tag contains an element name followed by
-one or more attributes. An end-tag contains just an element name.
-An attribute value literals contains strings with no markup, entity
-references and character references. A processing instruction
-consists of a target and a content string. A comment or a CDATA
-section contains a single string. An entity reference contains a
-single name. A character reference contains a character number."
+An element is by default treated as a single markup item.
+However, if the variable `nxml-sexp-element-flag' is nil, then an
+element contains as items strings with no markup, tags,
+processing instructions, comments, CDATA sections, entity
+references and character references. A start-tag contains an
+element name followed by one or more attributes. An end-tag
+contains just an element name. An attribute value literals
+contains strings with no markup, entity references and character
+references. A processing instruction consists of a target and a
+content string. A comment or a CDATA section contains a single
+string. An entity reference contains a single name. A character
+reference contains a character number."
(interactive "^p")
(or arg (setq arg 1))
(cond ((> arg 0)
diff --git a/lisp/nxml/rng-loc.el b/lisp/nxml/rng-loc.el
index 89b58e38b06..db4f6e48284 100644
--- a/lisp/nxml/rng-loc.el
+++ b/lisp/nxml/rng-loc.el
@@ -407,7 +407,7 @@ or nil."
"Return a list of rules for the schema locating file FILE."
(setq file (expand-file-name file))
(let ((cached (assoc file rng-schema-locating-file-alist))
- (mtime (nth 5 (file-attributes file)))
+ (mtime (file-attribute-modification-time (file-attributes file)))
parsed)
(cond ((not mtime)
(when cached
diff --git a/lisp/nxml/rng-maint.el b/lisp/nxml/rng-maint.el
index da4567daf6e..56fbf12eda9 100644
--- a/lisp/nxml/rng-maint.el
+++ b/lisp/nxml/rng-maint.el
@@ -226,11 +226,9 @@
(defun rng-time-function (function &rest args)
(let* ((start (current-time))
- (val (apply function args))
- (end (current-time)))
+ (val (apply function args)))
(message "%s ran in %g seconds"
- function
- (float-time (time-subtract end start)))
+ function (float-time (time-since start)))
val))
(defun rng-time-tokenize-buffer ()
diff --git a/lisp/nxml/rng-nxml.el b/lisp/nxml/rng-nxml.el
index c110937b34b..05b59316d13 100644
--- a/lisp/nxml/rng-nxml.el
+++ b/lisp/nxml/rng-nxml.el
@@ -160,7 +160,7 @@ Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil."
(and rng-collecting-text (rng-flush-text))
(let ((target-names (rng-match-possible-start-tag-names)))
`(,(1+ lt-pos)
- ,(save-excursion (skip-chars-forward "[[:alnum:]_.-:]") (point))
+ ,(save-excursion (skip-chars-forward "-[:alnum:]_.:") (point))
,(apply-partially #'rng-complete-qname-function
target-names nil extra-strings)
:exit-function
@@ -207,7 +207,7 @@ Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil."
(cdar rng-open-elements))
(cdar rng-open-elements))))
`(,(+ (match-beginning 0) 2)
- ,(save-excursion (skip-chars-forward "[[:alnum:]_.-:]") (point))
+ ,(save-excursion (skip-chars-forward "-[:alnum:]_.:") (point))
,(list start-tag-name) ;Sole completion candidate.
:exit-function
,(lambda (_completion status)
@@ -247,7 +247,7 @@ Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil."
"xmlns"))
rng-undeclared-prefixes)))
`(,attribute-start
- ,(save-excursion (skip-chars-forward "[[:alnum:]_.-:]") (point))
+ ,(save-excursion (skip-chars-forward "-[:alnum:]_.:") (point))
,(apply-partially #'rng-complete-qname-function
target-names t extra-strings)
:exit-function
diff --git a/lisp/nxml/rng-uri.el b/lisp/nxml/rng-uri.el
index 0e458cfd2f4..798475bbc3d 100644
--- a/lisp/nxml/rng-uri.el
+++ b/lisp/nxml/rng-uri.el
@@ -30,9 +30,10 @@ Multibyte characters are left as is. Use `rng-uri-escape-multibyte' to
escape them using %HH."
(setq f (expand-file-name f))
(let ((url
- (replace-regexp-in-string "[\000-\032\177<>#%\"{}|\\^[]`%?;]"
- 'rng-percent-encode
- f)))
+ ;; FIXME. Explain why the pattern doesn't also have "!$&'()*+,/:@=".
+ ;; See Internet RFC 3986 section 2.2.
+ (replace-regexp-in-string "[]\0-\s\"#%;<>?[\\^`{|}\177]"
+ 'rng-percent-encode f)))
(concat "file:"
(if (and (> (length url) 0)
(= (aref url 0) ?/))
@@ -42,7 +43,7 @@ escape them using %HH."
(defun rng-uri-escape-multibyte (uri)
"Escape multibyte characters in URI."
- (replace-regexp-in-string "[:nonascii:]"
+ (replace-regexp-in-string "[[:nonascii:]]"
'rng-percent-encode
(encode-coding-string uri 'utf-8)))
diff --git a/lisp/nxml/rng-xsd.el b/lisp/nxml/rng-xsd.el
index 6cd1688fe46..f308b049f3b 100644
--- a/lisp/nxml/rng-xsd.el
+++ b/lisp/nxml/rng-xsd.el
@@ -360,7 +360,7 @@ trailing digits. For example, -0021.0430 would be represented by [-1
n)))
(defun rng-xsd-convert-any-uri (string)
- (and (string-match "\\`\\(?:[^%]\\|%[0-9a-fA-F][0-9a-fA-F]\\)?*\\'" string)
+ (and (string-match "\\`\\(?:[^%]\\|%[0-9a-fA-F][0-9a-fA-F]\\)*\\'" string)
(string-match "\\`[^#]*\\(?:#[^#]*\\)?\\'" string)
(string-match "\\`\\(?:[a-zA-Z][-+.A-Za-z0-9]*:.+\\|[^:]*\\(?:[#/?].*\\)?\\)\\'" string)
string))
diff --git a/lisp/obsolete/assoc.el b/lisp/obsolete/assoc.el
index a601733799f..926e60516ed 100644
--- a/lisp/obsolete/assoc.el
+++ b/lisp/obsolete/assoc.el
@@ -27,7 +27,6 @@
;; fetching off key-value pairs in association lists.
;;; Code:
-(eval-when-compile (require 'cl))
(defun asort (alist-symbol key)
"Move a specified key-value pair to the head of an alist.
diff --git a/lisp/obsolete/complete.el b/lisp/obsolete/complete.el
index da73840c73a..8021b2227ea 100644
--- a/lisp/obsolete/complete.el
+++ b/lisp/obsolete/complete.el
@@ -191,7 +191,6 @@ If nil, means use the colon-separated path in the variable $INCPATH instead."
;;;###autoload
(define-minor-mode partial-completion-mode
"Toggle Partial Completion mode.
-With prefix ARG, turn Partial Completion mode on if ARG is positive.
When Partial Completion mode is enabled, TAB (or M-TAB if `PC-meta-flag' is
nil) is enhanced so that if some string is divided into words and each word is
diff --git a/lisp/obsolete/crisp.el b/lisp/obsolete/crisp.el
index 239c7e19960..832820b0a57 100644
--- a/lisp/obsolete/crisp.el
+++ b/lisp/obsolete/crisp.el
@@ -353,10 +353,7 @@ normal CRiSP binding) and when it is nil M-x will run
;;;###autoload
(define-minor-mode crisp-mode
- "Toggle CRiSP/Brief emulation (CRiSP mode).
-With a prefix argument ARG, enable CRiSP mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil."
+ "Toggle CRiSP/Brief emulation (CRiSP mode)."
:keymap crisp-mode-map
:lighter crisp-mode-mode-line-string
(when crisp-mode
@@ -379,10 +376,6 @@ if ARG is omitted or nil."
;;;###autoload
(defalias 'brief-mode 'crisp-mode)
-;; Interaction with other packages.
-(put 'crisp-home 'CUA 'move)
-(put 'crisp-end 'CUA 'move)
-
(run-hooks 'crisp-load-hook)
(provide 'crisp)
diff --git a/lisp/obsolete/fast-lock.el b/lisp/obsolete/fast-lock.el
index d660e5506c3..5180d4527be 100644
--- a/lisp/obsolete/fast-lock.el
+++ b/lisp/obsolete/fast-lock.el
@@ -190,10 +190,6 @@
(defvar font-lock-face-list)
(eval-when-compile
- ;;
- ;; We don't do this at the top-level as we only use non-autoloaded macros.
- (require 'cl)
- ;;
;; We use this to preserve or protect things when modifying text properties.
(defmacro save-buffer-state (varlist &rest body)
"Bind variables according to VARLIST and eval BODY restoring buffer state."
@@ -445,7 +441,8 @@ See `fast-lock-mode'."
;; Only save if user's restrictions are satisfied.
(and min-size (>= (buffer-size) min-size))
(or fast-lock-save-others
- (eq (user-uid) (nth 2 (file-attributes buffer-file-name))))
+ (eq (user-uid) (file-attribute-user-id
+ (file-attributes buffer-file-name))))
;;
;; Only save if there are `face' properties to save.
(text-property-not-all (point-min) (point-max) 'face nil))
diff --git a/lisp/obsolete/iswitchb.el b/lisp/obsolete/iswitchb.el
index 888c0af8f90..5b0df1e6950 100644
--- a/lisp/obsolete/iswitchb.el
+++ b/lisp/obsolete/iswitchb.el
@@ -353,8 +353,6 @@ See also `iswitchb-newbuffer'."
:type 'boolean
:group 'iswitchb)
-(define-obsolete-variable-alias 'iswitchb-use-fonts 'iswitchb-use-faces "22.1")
-
(defcustom iswitchb-use-faces t
"Non-nil means use font-lock faces for showing first match."
:type 'boolean
@@ -1247,7 +1245,7 @@ Modified from `icomplete-completions'."
(if (and iswitchb-use-faces comps)
(progn
- (setq first (car comps))
+ (setq first (copy-sequence (car comps)))
(setq first (format "%s" first))
(put-text-property 0 (length first) 'face
(if (= (length comps) 1)
@@ -1419,9 +1417,6 @@ See the variable `iswitchb-case' for details."
;;;###autoload
(define-minor-mode iswitchb-mode
"Toggle Iswitchb mode.
-With a prefix argument ARG, enable Iswitchb mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Iswitchb mode is a global minor mode that enables switching
between buffers using substrings. See `iswitchb' for details."
diff --git a/lisp/obsolete/lazy-lock.el b/lisp/obsolete/lazy-lock.el
index 364c2d3200d..44f8528b201 100644
--- a/lisp/obsolete/lazy-lock.el
+++ b/lisp/obsolete/lazy-lock.el
@@ -267,11 +267,9 @@
;;; Code:
(require 'font-lock)
+(eval-when-compile (require 'cl-lib))
(eval-when-compile
- ;; We don't do this at the top-level as we only use non-autoloaded macros.
- (require 'cl)
- ;;
;; We use this to preserve or protect things when modifying text properties.
(defmacro save-buffer-state (varlist &rest body)
"Bind variables according to VARLIST and eval BODY restoring buffer state."
@@ -977,7 +975,7 @@ verbosity is controlled via the variable `lazy-lock-stealth-verbose'."
(while (setq beg (text-property-any beg (point-max) 'lazy-lock t))
(setq next (or (text-property-any beg (point-max) 'lazy-lock nil)
(point-max)))
- (incf size (- next beg))
+ (cl-incf size (- next beg))
(setq beg next))
;; Float because using integer multiplication will frequently overflow.
(truncate (* (/ (float size) (point-max)) 100)))))
diff --git a/lisp/obsolete/levents.el b/lisp/obsolete/levents.el
index a2a50119c8a..714b3fbb761 100644
--- a/lisp/obsolete/levents.el
+++ b/lisp/obsolete/levents.el
@@ -145,7 +145,7 @@ It will be the next event read after all pending events."
The value is an ASCII printing character (not upper case) or a symbol."
(if (symbolp event)
(car (get event 'event-symbol-elements))
- (let ((base (logand event (1- (lsh 1 18)))))
+ (let ((base (logand event (1- (ash 1 18)))))
(downcase (if (< base 32) (logior base 64) base)))))
(defun event-object (event)
diff --git a/lisp/obsolete/longlines.el b/lisp/obsolete/longlines.el
index a35947bd613..2ef5324e51b 100644
--- a/lisp/obsolete/longlines.el
+++ b/lisp/obsolete/longlines.el
@@ -97,9 +97,6 @@ This is used when `longlines-show-hard-newlines' is on."
;;;###autoload
(define-minor-mode longlines-mode
"Toggle Long Lines mode in this buffer.
-With a prefix argument ARG, enable Long Lines mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
When Long Lines mode is enabled, long lines are wrapped if they
extend beyond `fill-column'. The soft newlines used for line
diff --git a/lisp/obsolete/mailpost.el b/lisp/obsolete/mailpost.el
index eebaa34de10..2f74faf1d6c 100644
--- a/lisp/obsolete/mailpost.el
+++ b/lisp/obsolete/mailpost.el
@@ -54,10 +54,10 @@ site-init."
(while (and (re-search-forward "\n\n\n*" delimline t)
(< (point) delimline))
(replace-match "\n"))
- ;; Find and handle any FCC fields.
+ ;; Find and handle any Fcc fields.
(let ((case-fold-search t))
(goto-char (point-min))
- (if (re-search-forward "^FCC:" delimline t)
+ (if (re-search-forward "^Fcc:" delimline t)
(mail-do-fcc delimline))
;; If there is a From and no Sender, put it a Sender.
(goto-char (point-min))
diff --git a/lisp/obsolete/mouse-sel.el b/lisp/obsolete/mouse-sel.el
index 0a19fc0a961..b8dd9e6fa73 100644
--- a/lisp/obsolete/mouse-sel.el
+++ b/lisp/obsolete/mouse-sel.el
@@ -135,9 +135,6 @@
(require 'mouse)
(require 'thingatpt)
-(eval-when-compile
- (require 'cl))
-
;;=== User Variables ======================================================
(defgroup mouse-sel nil
@@ -197,9 +194,6 @@ If nil, point will always be placed at the beginning of the region."
;;;###autoload
(define-minor-mode mouse-sel-mode
"Toggle Mouse Sel mode.
-With a prefix argument ARG, enable Mouse Sel mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Mouse Sel mode is a global minor mode. When enabled, mouse
selection is enhanced in various ways:
diff --git a/lisp/obsolete/old-whitespace.el b/lisp/obsolete/old-whitespace.el
index 591f018907a..c8daa572bf2 100644
--- a/lisp/obsolete/old-whitespace.el
+++ b/lisp/obsolete/old-whitespace.el
@@ -747,7 +747,6 @@ If timer is not set, then set it to scan the files in
;;;###autoload
(define-minor-mode whitespace-global-mode
"Toggle using Whitespace mode in new buffers.
-With ARG, turn the mode on if ARG is positive, otherwise turn it off.
When this mode is active, `whitespace-buffer' is added to
`find-file-hook' and `kill-buffer-hook'."
diff --git a/lisp/obsolete/options.el b/lisp/obsolete/options.el
deleted file mode 100644
index eb3fb2aa4f3..00000000000
--- a/lisp/obsolete/options.el
+++ /dev/null
@@ -1,140 +0,0 @@
-;;; options.el --- edit Options command for Emacs
-
-;; Copyright (C) 1985, 2001-2019 Free Software Foundation, Inc.
-
-;; Maintainer: emacs-devel@gnu.org
-;; Obsolete-since: 22.1
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This code provides functions to list and edit the values of all global
-;; option variables known to loaded Emacs Lisp code. There are two entry
-;; points, `list-options' and `edit' options'. The latter enters a major
-;; mode specifically for editing option values. Do `M-x describe-mode' in
-;; that context for more details.
-
-;; The customization buffer feature is intended to make this obsolete.
-
-;;; Code:
-
-;;;###autoload
-(defun list-options ()
- "Display a list of Emacs user options, with values and documentation.
-It is now better to use Customize instead."
- (interactive)
- (with-output-to-temp-buffer "*List Options*"
- (let (vars)
- (princ "This facility is obsolete; we recommend using M-x customize instead.")
-
- (mapatoms (function (lambda (sym)
- (if (custom-variable-p sym)
- (setq vars (cons sym vars))))))
- (setq vars (sort vars 'string-lessp))
- (while vars
- (let ((sym (car vars)))
- (when (boundp sym)
- (princ ";; ")
- (prin1 sym)
- (princ ":\n\t")
- (prin1 (symbol-value sym))
- (terpri)
- (princ (substitute-command-keys
- (documentation-property sym 'variable-documentation)))
- (princ "\n;;\n"))
- (setq vars (cdr vars))))
- (with-current-buffer "*List Options*"
- (Edit-options-mode)
- (setq buffer-read-only t)))))
-
-;;;###autoload
-(defun edit-options ()
- "Edit a list of Emacs user option values.
-Selects a buffer containing such a list,
-in which there are commands to set the option values.
-Type \\[describe-mode] in that buffer for a list of commands.
-
-The Custom feature is intended to make this obsolete."
- (interactive)
- (list-options)
- (pop-to-buffer "*List Options*"))
-
-(defvar Edit-options-mode-map
- (let ((map (make-keymap)))
- (define-key map "s" 'Edit-options-set)
- (define-key map "x" 'Edit-options-toggle)
- (define-key map "1" 'Edit-options-t)
- (define-key map "0" 'Edit-options-nil)
- (define-key map "p" 'backward-paragraph)
- (define-key map " " 'forward-paragraph)
- (define-key map "n" 'forward-paragraph)
- map)
- "")
-
-;; Edit Options mode is suitable only for specially formatted data.
-(put 'Edit-options-mode 'mode-class 'special)
-
-(define-derived-mode Edit-options-mode emacs-lisp-mode "Options"
- "\\<Edit-options-mode-map>\
-Major mode for editing Emacs user option settings.
-Special commands are:
-\\[Edit-options-set] -- set variable point points at. New value read using minibuffer.
-\\[Edit-options-toggle] -- toggle variable, t -> nil, nil -> t.
-\\[Edit-options-t] -- set variable to t.
-\\[Edit-options-nil] -- set variable to nil.
-Changed values made by these commands take effect immediately.
-
-Each variable description is a paragraph.
-For convenience, the characters \\[backward-paragraph] and \\[forward-paragraph] move back and forward by paragraphs."
- (setq-local paragraph-separate "[^\^@-\^?]")
- (setq-local paragraph-start "\t")
- (setq-local truncate-lines t))
-
-(defun Edit-options-set () (interactive)
- (Edit-options-modify
- (lambda (var) (eval-minibuffer (concat "New " (symbol-name var) ": ")))))
-
-(defun Edit-options-toggle () (interactive)
- (Edit-options-modify (lambda (var) (not (symbol-value var)))))
-
-(defun Edit-options-t () (interactive)
- (Edit-options-modify (lambda (var) t)))
-
-(defun Edit-options-nil () (interactive)
- (Edit-options-modify (lambda (var) nil)))
-
-(defun Edit-options-modify (modfun)
- (save-excursion
- (let ((buffer-read-only nil) var pos)
- (re-search-backward "^;; \\|\\`")
- (forward-char 3)
- (setq pos (point))
- (save-restriction
- (narrow-to-region pos (progn (end-of-line) (1- (point))))
- (goto-char pos)
- (setq var (read (current-buffer))))
- (goto-char pos)
- (forward-line 1)
- (forward-char 1)
- (save-excursion
- (set var (funcall modfun var)))
- (kill-sexp 1)
- (prin1 (symbol-value var) (current-buffer)))))
-
-(provide 'options)
-
-;;; options.el ends here
diff --git a/lisp/obsolete/pgg-gpg.el b/lisp/obsolete/pgg-gpg.el
index 1dfd3e672bc..6a901fbef3e 100644
--- a/lisp/obsolete/pgg-gpg.el
+++ b/lisp/obsolete/pgg-gpg.el
@@ -27,8 +27,7 @@
;;; Code:
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'pgg)
@@ -303,7 +302,7 @@ passphrase cache or user."
(defun pgg-gpg-select-matching-key (message-keys secret-keys)
"Choose a key from MESSAGE-KEYS that matches one of the keys in SECRET-KEYS."
- (loop for message-key in message-keys
+ (cl-loop for message-key in message-keys
for message-key-id = (and (equal (car message-key) 1)
(cdr (assq 'key-identifier
(cdr message-key))))
diff --git a/lisp/obsolete/pgg-parse.el b/lisp/obsolete/pgg-parse.el
index ba39cc2ad63..cdff9acba9c 100644
--- a/lisp/obsolete/pgg-parse.el
+++ b/lisp/obsolete/pgg-parse.el
@@ -35,10 +35,7 @@
;;; Code:
-(eval-when-compile
- ;; For Emacs <22.2 and XEmacs.
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defgroup pgg-parse ()
"OpenPGP packet parsing."
@@ -119,17 +116,17 @@
)
(defmacro pgg-parse-time-field (bytes)
- `(list (logior (lsh (car ,bytes) 8)
+ `(list (logior (ash (car ,bytes) 8)
(nth 1 ,bytes))
- (logior (lsh (nth 2 ,bytes) 8)
+ (logior (ash (nth 2 ,bytes) 8)
(nth 3 ,bytes))
0))
(defmacro pgg-byte-after (&optional pos)
- `(pgg-char-int (char-after ,(or pos `(point)))))
+ `(pgg-char-int (char-after ,(or pos '(point)))))
(defmacro pgg-read-byte ()
- `(pgg-char-int (char-after (prog1 (point) (forward-char)))))
+ '(pgg-char-int (char-after (prog1 (point) (forward-char)))))
(defmacro pgg-read-bytes-string (nbytes)
`(buffer-substring
@@ -187,21 +184,21 @@
(ccl-execute-on-string pgg-parse-crc24 h string)
(format "%c%c%c"
(logand (aref h 1) 255)
- (logand (lsh (aref h 2) -8) 255)
+ (logand (ash (aref h 2) -8) 255)
(logand (aref h 2) 255)))))
(defmacro pgg-parse-length-type (c)
`(cond
((< ,c 192) (cons ,c 1))
((< ,c 224)
- (cons (+ (lsh (- ,c 192) 8)
+ (cons (+ (ash (- ,c 192) 8)
(pgg-byte-after (+ 2 (point)))
192)
2))
((= ,c 255)
- (cons (cons (logior (lsh (pgg-byte-after (+ 2 (point))) 8)
+ (cons (cons (logior (ash (pgg-byte-after (+ 2 (point))) 8)
(pgg-byte-after (+ 3 (point))))
- (logior (lsh (pgg-byte-after (+ 4 (point))) 8)
+ (logior (ash (pgg-byte-after (+ 4 (point))) 8)
(pgg-byte-after (+ 5 (point)))))
5))
(t;partial body length
@@ -213,13 +210,13 @@
(if (zerop (logand 64 ptag));Old format
(progn
(setq length-type (logand ptag 3)
- length-type (if (= 3 length-type) 0 (lsh 1 length-type))
- content-tag (logand 15 (lsh ptag -2))
+ length-type (if (= 3 length-type) 0 (ash 1 length-type))
+ content-tag (logand 15 (ash ptag -2))
packet-bytes 0
header-bytes (1+ length-type))
(dotimes (i length-type)
(setq packet-bytes
- (logior (lsh packet-bytes 8)
+ (logior (ash packet-bytes 8)
(pgg-byte-after (+ 1 i (point)))))))
(setq content-tag (logand 63 ptag)
length-type (pgg-parse-length-type
@@ -229,7 +226,7 @@
(list content-tag packet-bytes header-bytes)))
(defun pgg-parse-packet (ptag)
- (case (car ptag)
+ (cl-case (car ptag)
(1 ;Public-Key Encrypted Session Key Packet
(pgg-parse-public-key-encrypted-session-key-packet ptag))
(2 ;Signature Packet
@@ -282,7 +279,7 @@
(1+ (cdr length-type)))))
(defun pgg-parse-signature-subpacket (ptag)
- (case (car ptag)
+ (cl-case (car ptag)
(2 ;signature creation time
(cons 'creation-time
(let ((bytes (pgg-read-bytes 4)))
@@ -320,10 +317,10 @@
(let ((name-bytes (pgg-read-bytes 2))
(value-bytes (pgg-read-bytes 2)))
(cons (pgg-read-bytes-string
- (logior (lsh (car name-bytes) 8)
+ (logior (ash (car name-bytes) 8)
(nth 1 name-bytes)))
(pgg-read-bytes-string
- (logior (lsh (car value-bytes) 8)
+ (logior (ash (car value-bytes) 8)
(nth 1 value-bytes)))))))
(21 ;preferred hash algorithms
(cons 'preferred-hash-algorithm
@@ -383,7 +380,7 @@
(pgg-set-alist result
'hash-algorithm (pgg-read-byte))
(when (>= 10000 (setq n (pgg-read-bytes 2)
- n (logior (lsh (car n) 8)
+ n (logior (ash (car n) 8)
(nth 1 n))))
(save-restriction
(narrow-to-region (point)(+ n (point)))
@@ -394,7 +391,7 @@
#'pgg-parse-signature-subpacket)))
(goto-char (point-max))))
(when (>= 10000 (setq n (pgg-read-bytes 2)
- n (logior (lsh (car n) 8)
+ n (logior (ash (car n) 8)
(nth 1 n))))
(save-restriction
(narrow-to-region (point)(+ n (point)))
diff --git a/lisp/obsolete/pgg-pgp.el b/lisp/obsolete/pgg-pgp.el
index 0627217f073..9e9a38d5447 100644
--- a/lisp/obsolete/pgg-pgp.el
+++ b/lisp/obsolete/pgg-pgp.el
@@ -25,8 +25,7 @@
;;; Code:
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'pgg)
diff --git a/lisp/obsolete/pgg-pgp5.el b/lisp/obsolete/pgg-pgp5.el
index eafa2742557..81199431458 100644
--- a/lisp/obsolete/pgg-pgp5.el
+++ b/lisp/obsolete/pgg-pgp5.el
@@ -25,8 +25,7 @@
;;; Code:
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'pgg)
diff --git a/lisp/obsolete/pgg.el b/lisp/obsolete/pgg.el
index 23bbedea28b..18b63fc3ee6 100644
--- a/lisp/obsolete/pgg.el
+++ b/lisp/obsolete/pgg.el
@@ -29,11 +29,7 @@
(require 'pgg-parse)
(autoload 'run-at-time "timer")
-;; Don't merge these two `eval-when-compile's.
-(eval-when-compile
- ;; For Emacs <22.2 and XEmacs.
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
;;; @ utility functions
;;;
@@ -258,7 +254,7 @@ regulate cache behavior."
(defmacro pgg-convert-lbt-region (start end lbt)
`(let ((pgg-conversion-end (set-marker (make-marker) ,end)))
(goto-char ,start)
- (case ,lbt
+ (cl-case ,lbt
(CRLF
(while (progn
(end-of-line)
@@ -576,7 +572,7 @@ within the region."
(with-current-buffer (get-buffer-create pgg-output-buffer)
(buffer-disable-undo)
(erase-buffer)
- (let ((proto (if (string-match "^[a-zA-Z\\+\\.\\\\-]+:" keyserver)
+ (let ((proto (if (string-match "^[a-zA-Z\\+.-]+:" keyserver)
(substring keyserver 0 (1- (match-end 0))))))
(save-excursion
(funcall pgg-insert-url-function
diff --git a/lisp/obsolete/sregex.el b/lisp/obsolete/sregex.el
index 32020d01c72..884cd3e4e45 100644
--- a/lisp/obsolete/sregex.el
+++ b/lisp/obsolete/sregex.el
@@ -240,7 +240,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
;; Compatibility code for when we didn't have shy-groups
(defvar sregex--current-sregex nil)
@@ -487,7 +487,7 @@ has one of the following forms:
(concat "\\(?:" (regexp-quote exp) "\\)")
(regexp-quote exp)))
((symbolp exp)
- (ecase exp
+ (cl-ecase exp
(any ".")
(bol "^")
(eol "$")
diff --git a/lisp/net/starttls.el b/lisp/obsolete/starttls.el
index 4087a562448..e0a09688f45 100644
--- a/lisp/net/starttls.el
+++ b/lisp/obsolete/starttls.el
@@ -6,6 +6,7 @@
;; Author: Simon Josefsson <simon@josefsson.org>
;; Created: 1999/11/20
;; Keywords: TLS, SSL, OpenSSL, GnuTLS, mail, news
+;; Obsolete-since: 27.1
;; This file is part of GNU Emacs.
@@ -216,7 +217,7 @@ handshake, or nil on failure."
starttls-success nil t))
(setq done-bad (re-search-forward
starttls-failure nil t))))))
- (accept-process-output process 1 100)
+ (accept-process-output process 1.1)
(sit-for 0.1))
(setq info (buffer-substring-no-properties old-max (point-max)))
(delete-region old-max (point-max))
@@ -250,7 +251,7 @@ handshake, or nil on failure."
(goto-char old-max)
(not (setq done (re-search-forward
starttls-connect nil t)))))
- (accept-process-output process 0 100)
+ (accept-process-output process 0.1)
(sit-for 0.1))
(if done
(with-current-buffer buffer
diff --git a/lisp/net/tls.el b/lisp/obsolete/tls.el
index 83f7d18984b..d17ddad7ee5 100644
--- a/lisp/net/tls.el
+++ b/lisp/obsolete/tls.el
@@ -4,6 +4,7 @@
;; Author: Simon Josefsson <simon@josefsson.org>
;; Keywords: comm, tls, gnutls, ssl
+;; Obsolete-since: 27.1
;; This file is part of GNU Emacs.
diff --git a/lisp/obsolete/tpu-edt.el b/lisp/obsolete/tpu-edt.el
index 6830f3ccf9b..8db1c4f5f11 100644
--- a/lisp/obsolete/tpu-edt.el
+++ b/lisp/obsolete/tpu-edt.el
@@ -980,10 +980,7 @@ and the total number of lines in the buffer."
;;;
;;;###autoload
(define-minor-mode tpu-edt-mode
- "Toggle TPU/edt emulation on or off.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil."
+ "Toggle TPU/edt emulation on or off."
:global t :group 'tpu
(if tpu-edt-mode (tpu-edt-on) (tpu-edt-off)))
diff --git a/lisp/obsolete/tpu-extras.el b/lisp/obsolete/tpu-extras.el
index cc048cd9240..f19a67dd48d 100644
--- a/lisp/obsolete/tpu-extras.el
+++ b/lisp/obsolete/tpu-extras.el
@@ -133,10 +133,7 @@ the previous line when starting from a line beginning."
;;;###autoload
(define-minor-mode tpu-cursor-free-mode
- "Minor mode to allow the cursor to move freely about the screen.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil."
+ "Minor mode to allow the cursor to move freely about the screen."
:init-value nil
(if (not tpu-cursor-free-mode)
(tpu-trim-line-ends))
diff --git a/lisp/obsolete/vc-arch.el b/lisp/obsolete/vc-arch.el
index 32e21613679..925289102c1 100644
--- a/lisp/obsolete/vc-arch.el
+++ b/lisp/obsolete/vc-arch.el
@@ -133,7 +133,8 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
(file-error (insert (format "%s <%s> %s"
(current-time-string)
user-mail-address
- (+ (nth 2 (current-time))
+ (+ (% (car (encode-time nil 1000000))
+ 1000000)
(buffer-size)))))))
(comment-region beg (point))))
@@ -304,8 +305,9 @@ Only the value `maybe' can be trusted :-(."
;; Buh? Unexpected format.
'edited
(let ((ats (file-attributes file)))
- (if (and (eq (nth 7 ats) (string-to-number (match-string 2)))
- (equal (format-time-string "%s" (nth 5 ats))
+ (if (and (eq (file-attribute-size ats) (string-to-number (match-string 2)))
+ (equal (format-time-string
+ "%s" (file-attribute-modification-time ats))
(match-string 1)))
'up-to-date
'edited)))))))))
@@ -395,14 +397,14 @@ CALLBACK expects (ENTRIES &optional MORE-TO-COME); see
(setq rev (replace-match (cdr rule) t nil rev))))
(format "Arch%c%s"
(pcase (vc-state file)
- ((or `up-to-date `needs-update) ?-)
- (`added ?@)
+ ((or 'up-to-date 'needs-update) ?-)
+ ('added ?@)
(_ ?:))
rev)))
(defun vc-arch-diff3-rej-p (rej)
(let ((attrs (file-attributes rej)))
- (and attrs (< (nth 7 attrs) 60)
+ (and attrs (< (file-attribute-size attrs) 60)
(with-temp-buffer
(insert-file-contents rej)
(goto-char (point-min))
diff --git a/lisp/obsolete/vi.el b/lisp/obsolete/vi.el
index a7a98d0ca55..df5ddfdbcf9 100644
--- a/lisp/obsolete/vi.el
+++ b/lisp/obsolete/vi.el
@@ -132,7 +132,7 @@ command extensions.")
(define-key vi-com-map "\C-e" 'vi-expose-line-below)
(define-key vi-com-map "\C-f" 'vi-forward-windowful)
(define-key vi-com-map "\C-g" 'keyboard-quit)
- (define-key vi-com-map "\C-i" 'indent-relative-maybe) ; TAB
+ (define-key vi-com-map "\C-i" 'indent-relative-first-indent-point) ; TAB
(define-key vi-com-map "\C-j" 'vi-next-line) ; LFD
(define-key vi-com-map "\C-k" 'vi-kill-line) ; extension
(define-key vi-com-map "\C-l" 'recenter)
@@ -1386,7 +1386,7 @@ l(ines)."
(interactive "p\nc")
(cond ((char-equal region ?d) (mark-defun))
((char-equal region ?s) (mark-sexp arg))
- ((char-equal region ?b) (mark-whole-buffer))
+ ((char-equal region ?b) (with-no-warnings (mark-whole-buffer)))
((char-equal region ?p) (mark-paragraph))
((char-equal region ?P) (mark-page arg))
((char-equal region ?f) (c-mark-function))
diff --git a/lisp/obsolete/vip.el b/lisp/obsolete/vip.el
index e0566cdb78c..bc4b90031ea 100644
--- a/lisp/obsolete/vip.el
+++ b/lisp/obsolete/vip.el
@@ -1858,7 +1858,7 @@ STRING. Search will be forward if FORWARD, otherwise backward."
(+ vip-use-register 32) (point) (+ (point) val))
(copy-to-register vip-use-register (point) (+ (point) val) nil))
(setq vip-use-register nil)))
- (delete-backward-char val t)))
+ (with-no-warnings (delete-backward-char val t))))
;; join lines.
@@ -2187,19 +2187,19 @@ a token has type \(command, address, end-mark\) and value."
((looking-at "%")
(forward-char 1)
(setq ex-token-type "whole"))
- ((looking-at "+")
- (cond ((or (looking-at "+[-+]") (looking-at "+[\n|]"))
+ ((looking-at "\\+")
+ (cond ((looking-at "\\+[-+\n|]")
(forward-char 1)
(insert "1")
(backward-char 1)
(setq ex-token-type "plus"))
- ((looking-at "+[0-9]")
+ ((looking-at "\\+[0-9]")
(forward-char 1)
(setq ex-token-type "plus"))
(t
(error "Badly formed address"))))
((looking-at "-")
- (cond ((or (looking-at "-[-+]") (looking-at "-[\n|]"))
+ (cond ((looking-at "-[-+\n|]")
(forward-char 1)
(insert "1")
(backward-char 1)
@@ -2216,7 +2216,7 @@ a token has type \(command, address, end-mark\) and value."
(while (and (not (eolp)) cont)
;;(re-search-forward "[^/]*/")
(re-search-forward "[^/]*\\(/\\|\n\\)")
- (if (not (vip-looking-back "[^\\\\]\\(\\\\\\\\\\)*\\\\/"))
+ (if (not (vip-looking-back "[^\\]\\(\\\\\\\\\\)*\\\\/"))
(setq cont nil))))
(backward-char 1)
(setq ex-token (buffer-substring (point) (mark)))
@@ -2229,7 +2229,7 @@ a token has type \(command, address, end-mark\) and value."
(while (and (not (eolp)) cont)
;;(re-search-forward "[^\\?]*\\?")
(re-search-forward "[^\\?]*\\(\\?\\|\n\\)")
- (if (not (vip-looking-back "[^\\\\]\\(\\\\\\\\\\)*\\\\\\?"))
+ (if (not (vip-looking-back "[^\\]\\(\\\\\\\\\\)*\\\\\\?"))
(setq cont nil))
(backward-char 1)
(if (not (looking-at "\n")) (forward-char 1))))
@@ -2325,7 +2325,7 @@ a token has type \(command, address, end-mark\) and value."
(while (and (not (eolp)) cont)
(re-search-forward "[^/]*\\(/\\|\n\\)")
;;(re-search-forward "[^/]*/")
- (if (not (vip-looking-back "[^\\\\]\\(\\\\\\\\\\)*\\\\/"))
+ (if (not (vip-looking-back "[^\\]\\(\\\\\\\\\\)*\\\\/"))
(setq cont nil))))
(setq ex-token
(if (= (mark) (point)) ""
@@ -2520,7 +2520,7 @@ a token has type \(command, address, end-mark\) and value."
ex-variant t)
(forward-char 2)
(skip-chars-forward " \t")))
- (if (looking-at "+")
+ (if (looking-at "\\+")
(progn
(forward-char 1)
(set-mark (point))
diff --git a/lisp/obsolete/xesam.el b/lisp/obsolete/xesam.el
index 78c4c948c6e..16da6d9cbba 100644
--- a/lisp/obsolete/xesam.el
+++ b/lisp/obsolete/xesam.el
@@ -410,18 +410,18 @@ If there is no registered search engine at all, the function returns nil."
;; Hopefully, this will change later.
(setq hit-fields
(pcase (intern vendor-id)
- (`Beagle
+ ('Beagle
'("xesam:mimeType" "xesam:url"))
- (`Strigi
+ ('Strigi
'("xesam:author" "xesam:cc" "xesam:charset"
"xesam:contentType" "xesam:fileExtension"
"xesam:id" "xesam:lineCount" "xesam:links"
"xesam:mimeType" "xesam:name" "xesam:size"
"xesam:sourceModified" "xesam:subject" "xesam:to"
"xesam:url"))
- (`TrackerXesamSession
+ ('TrackerXesamSession
'("xesam:relevancyRating" "xesam:url"))
- (`Debbugs
+ ('Debbugs
'("xesam:keyword" "xesam:owner" "xesam:title"
"xesam:url" "xesam:sourceModified" "xesam:mimeType"
"debbugs:key"))
@@ -512,9 +512,6 @@ engine specific, widget :notify function to visualize xesam:url."
(define-minor-mode xesam-minor-mode
"Toggle Xesam minor mode.
-With a prefix argument ARG, enable Xesam minor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
When Xesam minor mode is enabled, all text which matches a
previous Xesam query in this buffer is highlighted."
@@ -625,8 +622,7 @@ Return propertized STRING."
(or (widget-get widget :tag) "")
(format-time-string
"%d %B %Y, %T"
- (seconds-to-time
- (string-to-number (widget-get widget :xesam:sourceModified)))))))
+ (string-to-number (widget-get widget :xesam:sourceModified))))))
;; Second line: :value.
(widget-put widget :value (widget-get widget :xesam:url))
diff --git a/lisp/org/ob-abc.el b/lisp/org/ob-abc.el
index cefbe716e15..43ee1d9921b 100644
--- a/lisp/org/ob-abc.el
+++ b/lisp/org/ob-abc.el
@@ -47,7 +47,7 @@
(value (cdr pair)))
(setq body
(replace-regexp-in-string
- (concat "\$" (regexp-quote name))
+ (concat "\\$" (regexp-quote name))
(if (stringp value) value (format "%S" value))
body))))
vars)
@@ -59,7 +59,7 @@
(message "executing Abc source code block")
(let* ((cmdline (cdr (assq :cmdline params)))
(out-file (let ((file (cdr (assq :file params))))
- (if file (replace-regexp-in-string "\.pdf$" ".ps" file)
+ (if file (replace-regexp-in-string "\\.pdf$" ".ps" file)
(error "abc code block requires :file header argument"))))
(in-file (org-babel-temp-file "abc-"))
(render (concat "abcm2ps" " " cmdline
diff --git a/lisp/org/ob-core.el b/lisp/org/ob-core.el
index 3649d6666c8..b6c54a92ab6 100644
--- a/lisp/org/ob-core.el
+++ b/lisp/org/ob-core.el
@@ -2310,10 +2310,9 @@ INFO may provide the values of these header arguments (in the
(lambda (r)
;; Non-nil when result R can be turned into
;; a table.
- (and (listp r)
- (null (cdr (last r)))
+ (and (proper-list-p r)
(cl-every
- (lambda (e) (or (atom e) (null (cdr (last e)))))
+ (lambda (e) (or (atom e) (proper-list-p e)))
result)))))
;; insert results based on type
(cond
@@ -2956,7 +2955,7 @@ If the table is trivial, then return it as a scalar."
(defun org-babel-string-read (cell)
"Strip nested \"s from around strings."
(org-babel-read (or (and (stringp cell)
- (string-match "\\\"\\(.+\\)\\\"" cell)
+ (string-match "\"\\(.+\\)\"" cell)
(match-string 1 cell))
cell) t))
diff --git a/lisp/org/ob-eval.el b/lisp/org/ob-eval.el
index 0587851e8bd..8d5b7ed2674 100644
--- a/lisp/org/ob-eval.el
+++ b/lisp/org/ob-eval.el
@@ -120,7 +120,7 @@ function in various versions of Emacs.
(delete-file input-file))
(when (and error-file (file-exists-p error-file))
- (when (< 0 (nth 7 (file-attributes error-file)))
+ (when (< 0 (file-attribute-size (file-attributes error-file)))
(with-current-buffer (get-buffer-create error-buffer)
(let ((pos-from-end (- (point-max) (point))))
(or (bobp)
diff --git a/lisp/org/ob-forth.el b/lisp/org/ob-forth.el
index 8ca292656a2..88ed964fd77 100644
--- a/lisp/org/ob-forth.el
+++ b/lisp/org/ob-forth.el
@@ -53,7 +53,7 @@ This function is called by `org-babel-execute-src-block'"
(defun org-babel-forth-session-execute (body params)
(require 'forth-mode)
(let ((proc (forth-proc))
- (rx " \\(\n:\\|compiled\n\\\|ok\n\\)")
+ (rx " \\(\n:\\|compiled\n\\|ok\n\\)")
(result-start))
(with-current-buffer (process-buffer (forth-proc))
(mapcar (lambda (line)
diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el
index f1335a50668..23ee8d71e66 100644
--- a/lisp/org/org-agenda.el
+++ b/lisp/org/org-agenda.el
@@ -1401,6 +1401,9 @@ current display in the agenda."
:group 'org-agenda-daily/weekly
:type 'plist)
+(defvaralias 'org-agenda-search-view-search-words-only
+ 'org-agenda-search-view-always-boolean)
+
(defcustom org-agenda-search-view-always-boolean nil
"Non-nil means the search string is interpreted as individual parts.
@@ -1429,9 +1432,6 @@ boolean search."
:version "24.1"
:type 'boolean)
-(defvaralias 'org-agenda-search-view-search-words-only
- 'org-agenda-search-view-always-boolean)
-
(defcustom org-agenda-search-view-force-full-words nil
"Non-nil means, search words must be matches as complete words.
When nil, they may also match part of a word."
@@ -1873,6 +1873,9 @@ Nil means don't hide any tags."
(const :tag "Hide none" nil)
(string :tag "Regexp ")))
+(defvaralias 'org-agenda-remove-tags-when-in-prefix
+ 'org-agenda-remove-tags)
+
(defcustom org-agenda-remove-tags nil
"Non-nil means remove the tags from the headline copy in the agenda.
When this is the symbol `prefix', only remove tags when
@@ -1883,8 +1886,7 @@ When this is the symbol `prefix', only remove tags when
(const :tag "Never" nil)
(const :tag "When prefix format contains %T" prefix)))
-(defvaralias 'org-agenda-remove-tags-when-in-prefix
- 'org-agenda-remove-tags)
+(defvaralias 'org-agenda-align-tags-to-column 'org-agenda-tags-column)
(defcustom org-agenda-tags-column 'auto
"Shift tags in agenda items to this column.
@@ -1902,8 +1904,6 @@ character screen."
:package-version '(Org . "9.1")
:version "26.1")
-(defvaralias 'org-agenda-align-tags-to-column 'org-agenda-tags-column)
-
(defcustom org-agenda-fontify-priorities 'cookies
"Non-nil means highlight low and high priorities in agenda.
When t, the highest priority entries are bold, lowest priority italic.
@@ -2067,9 +2067,9 @@ works you probably want to add it to `org-agenda-custom-commands' for good."
;;; Define the org-agenda-mode
+(defvaralias 'org-agenda-keymap 'org-agenda-mode-map)
(defvar org-agenda-mode-map (make-sparse-keymap)
"Keymap for `org-agenda-mode'.")
-(defvaralias 'org-agenda-keymap 'org-agenda-mode-map)
(defvar org-agenda-menu) ; defined later in this file.
(defvar org-agenda-restrict nil) ; defined later in this file.
@@ -2205,10 +2205,14 @@ The following commands are available:
(add-hook 'post-command-hook 'org-agenda-update-agenda-type nil 'local)
(add-hook 'pre-command-hook 'org-unhighlight nil 'local)
;; Make sure properties are removed when copying text
- (add-hook 'filter-buffer-substring-functions
- (lambda (fun start end delete)
- (substring-no-properties (funcall fun start end delete)))
- nil t)
+ (if (boundp 'filter-buffer-substring-functions)
+ (add-hook 'filter-buffer-substring-functions
+ (lambda (fun start end delete)
+ (substring-no-properties (funcall fun start end delete)))
+ nil t)
+ ;; Emacs >= 24.4.
+ (add-function :filter-return (local 'filter-buffer-substring-function)
+ #'substring-no-properties))
(unless org-agenda-keep-modes
(setq org-agenda-follow-mode org-agenda-start-with-follow-mode
org-agenda-entry-text-mode org-agenda-start-with-entry-text-mode
@@ -2878,13 +2882,12 @@ Pressing `<' twice means to restrict to the current subtree or region
(let* ((m (org-agenda-get-any-marker))
(note (and m (org-entry-get m "THEFLAGGINGNOTE"))))
(when note
- (message (concat
- "FLAGGING-NOTE ([?] for more info): "
- (org-add-props
- (replace-regexp-in-string
- "\\\\n" "//"
- (copy-sequence note))
- nil 'face 'org-warning)))))))
+ (message "FLAGGING-NOTE ([?] for more info): %s"
+ (org-add-props
+ (replace-regexp-in-string
+ "\\\\n" "//"
+ (copy-sequence note))
+ nil 'face 'org-warning))))))
t t))
((equal org-keys "#") (call-interactively 'org-agenda-list-stuck-projects))
((equal org-keys "/") (call-interactively 'org-occur-in-agenda-files))
@@ -5487,8 +5490,8 @@ displayed in agenda view."
(substring
(format-time-string
(car org-time-stamp-formats)
- (apply #'encode-time ; DATE bound by calendar
- (list 0 0 0 (nth 1 date) (car date) (nth 2 date))))
+ (encode-time ; DATE bound by calendar
+ 0 0 0 (nth 1 date) (car date) (nth 2 date)))
1 11))
"\\|\\(<[0-9]+-[0-9]+-[0-9]+[^>\n]+?\\+[0-9]+[hdwmy]>\\)"
"\\|\\(<%%\\(([^>\n]+)\\)>\\)"))
@@ -5738,8 +5741,8 @@ then those holidays will be skipped."
(substring
(format-time-string
(car org-time-stamp-formats)
- (apply 'encode-time ; DATE bound by calendar
- (list 0 0 0 (nth 1 date) (car date) (nth 2 date))))
+ (encode-time ; DATE bound by calendar
+ 0 0 0 (nth 1 date) (car date) (nth 2 date)))
1 11))))
(org-agenda-search-headline-for-time nil)
marker hdmarker priority category level tags closedp
@@ -5856,21 +5859,19 @@ See also the user option `org-agenda-clock-consistency-checks'."
(throw 'next t))
(setq ts (match-string 1)
te (match-string 3)
- ts (float-time
- (apply #'encode-time (org-parse-time-string ts)))
- te (float-time
- (apply #'encode-time (org-parse-time-string te)))
+ ts (float-time (org-time-string-to-time ts))
+ te (float-time (org-time-string-to-time te))
dt (- te ts))))
(cond
((> dt (* 60 maxtime))
;; a very long clocking chunk
(setq issue (format "Clocking interval is very long: %s"
- (org-duration-from-minutes (floor (/ dt 60.))))
+ (org-duration-from-minutes (floor dt 60)))
face (or (plist-get pl :long-face) face)))
((< dt (* 60 mintime))
;; a very short clocking chunk
(setq issue (format "Clocking interval is very short: %s"
- (org-duration-from-minutes (floor (/ dt 60.))))
+ (org-duration-from-minutes (floor dt 60)))
face (or (plist-get pl :short-face) face)))
((and (> tlend 0) (< ts tlend))
;; Two clock entries are overlapping
@@ -5910,8 +5911,8 @@ See also the user option `org-agenda-clock-consistency-checks'."
(throw 'exit t))
;; We have a shorter gap.
;; Now we have to get the minute of the day when these times are
- (let* ((t1dec (decode-time (seconds-to-time t1)))
- (t2dec (decode-time (seconds-to-time t2)))
+ (let* ((t1dec (decode-time t1))
+ (t2dec (decode-time t2))
;; compute the minute on the day
(min1 (+ (nth 1 t1dec) (* 60 (nth 2 t1dec))))
(min2 (+ (nth 1 t2dec) (* 60 (nth 2 t2dec)))))
@@ -7005,15 +7006,15 @@ When TYPE is \"scheduled\", \"deadline\", \"timestamp\" or
\"timestamp_ia\", compare within each of these type. When TYPE
is the empty string, compare all timestamps without respect of
their type."
- (let* ((def (if org-sort-agenda-notime-is-late most-positive-fixnum -1))
+ (let* ((def (and (not org-sort-agenda-notime-is-late) -1))
(ta (or (and (string-match type (or (get-text-property 1 'type a) ""))
(get-text-property 1 'ts-date a))
def))
(tb (or (and (string-match type (or (get-text-property 1 'type b) ""))
(get-text-property 1 'ts-date b))
def)))
- (cond ((< ta tb) -1)
- ((< tb ta) +1))))
+ (cond ((if ta (and tb (< ta tb)) tb) -1)
+ ((if tb (and ta (< tb ta)) ta) +1))))
(defsubst org-cmp-habit-p (a b)
"Compare the todo states of strings A and B."
@@ -9444,7 +9445,7 @@ the resulting entry will not be shown. When TEXT is empty, switch to
(goto-char (point-min))
(cond
((eq type 'anniversary)
- (or (re-search-forward "^*[ \t]+Anniversaries" nil t)
+ (or (re-search-forward "^\\*[ \t]+Anniversaries" nil t)
(progn
(or (org-at-heading-p t)
(progn
@@ -10155,8 +10156,7 @@ to override `appt-message-warning-time'."
;; Do not use `org-today' here because appt only takes
;; time and without date as argument, so it may pass wrong
;; information otherwise
- (today (org-date-to-gregorian
- (time-to-days (current-time))))
+ (today (org-date-to-gregorian (time-to-days nil)))
(org-agenda-restrict nil)
(files (org-agenda-files 'unrestricted)) entries file
(org-agenda-buffer nil))
diff --git a/lisp/org/org-attach.el b/lisp/org/org-attach.el
index db8b61b3d51..f430cd5ed3e 100644
--- a/lisp/org/org-attach.el
+++ b/lisp/org/org-attach.el
@@ -352,7 +352,7 @@ This checks for the existence of a \".git\" directory in that directory."
(shell-command-to-string
"git ls-files -zmo --exclude-standard") "\0" t))
(if (and use-annex
- (>= (nth 7 (file-attributes new-or-modified))
+ (>= (file-attribute-size (file-attributes new-or-modified))
org-attach-git-annex-cutoff))
(call-process "git" nil nil nil "annex" "add" new-or-modified)
(call-process "git" nil nil nil "add" new-or-modified))
diff --git a/lisp/org/org-capture.el b/lisp/org/org-capture.el
index a699d2e28fc..dbba33b50d0 100644
--- a/lisp/org/org-capture.el
+++ b/lisp/org/org-capture.el
@@ -1000,8 +1000,7 @@ Store them in the capture property list."
(equal current-prefix-arg 1))
;; Prompt for date.
(let ((prompt-time (org-read-date
- nil t nil "Date for tree entry:"
- (current-time))))
+ nil t nil "Date for tree entry:" nil)))
(org-capture-put
:default-time
(cond ((and (or (not (boundp 'org-time-was-given))
@@ -1009,9 +1008,8 @@ Store them in the capture property list."
(not (= (time-to-days prompt-time) (org-today))))
;; Use 00:00 when no time is given for another
;; date than today?
- (apply #'encode-time
- (append '(0 0 0)
- (cl-cdddr (decode-time prompt-time)))))
+ (apply #'encode-time 0 0 0
+ (cl-cdddr (decode-time prompt-time))))
((string-match "\\([^ ]+\\)--?[^ ]+[ ]+\\(.*\\)"
org-read-date-final-answer)
;; Replace any time range by its start.
diff --git a/lisp/org/org-clock.el b/lisp/org/org-clock.el
index a9b933c8e37..62c7cd92d12 100644
--- a/lisp/org/org-clock.el
+++ b/lisp/org/org-clock.el
@@ -723,8 +723,8 @@ menu\nmouse-2 will jump to task"))
The time returned includes the time spent on this task in
previous clocking intervals."
(let ((currently-clocked-time
- (floor (- (float-time)
- (float-time org-clock-start-time)) 60)))
+ (floor (encode-time (time-since org-clock-start-time) 'integer)
+ 60)))
(+ currently-clocked-time (or org-clock-total-time 0))))
(defun org-clock-modify-effort-estimate (&optional value)
@@ -932,7 +932,7 @@ If necessary, clock-out of the currently active clock."
(unless (org-is-active-clock clock)
(org-clock-clock-in clock t))))
- ((not (time-less-p resolve-to (current-time)))
+ ((not (time-less-p resolve-to nil))
(error "RESOLVE-TO must refer to a time in the past"))
(t
@@ -1033,8 +1033,8 @@ to be CLOCKED OUT."))))
nil 45)))
(and (not (memq char-pressed '(?i ?q))) char-pressed)))))
(default
- (floor (/ (float-time
- (time-subtract (current-time) last-valid)) 60)))
+ (floor (encode-time (time-since last-valid) 'integer)
+ 60))
(keep
(and (memq ch '(?k ?K))
(read-number "Keep how many minutes? " default)))
@@ -1042,8 +1042,9 @@ to be CLOCKED OUT."))))
(and (memq ch '(?g ?G))
(read-number "Got back how many minutes ago? " default)))
(subtractp (memq ch '(?s ?S)))
- (barely-started-p (< (- (float-time last-valid)
- (float-time (cdr clock))) 45))
+ (barely-started-p (time-less-p
+ (time-subtract last-valid (cdr clock))
+ 45))
(start-over (and subtractp barely-started-p)))
(cond
((memq ch '(?j ?J))
@@ -1069,10 +1070,9 @@ to be CLOCKED OUT."))))
(and gotback (= gotback default)))
'now)
(keep
- (time-add last-valid (seconds-to-time (* 60 keep))))
+ (time-add last-valid (* 60 keep)))
(gotback
- (time-subtract (current-time)
- (seconds-to-time (* 60 gotback))))
+ (time-since (* 60 gotback)))
(t
(error "Unexpected, please report this as a bug")))
(and gotback last-valid)
@@ -1102,8 +1102,8 @@ If `only-dangling-p' is non-nil, only ask to resolve dangling
(lambda (clock)
(format
"Dangling clock started %d mins ago"
- (floor (- (float-time)
- (float-time (cdr clock)))
+ (floor (encode-time (time-since (cdr clock))
+ 'integer)
60)))))
(or last-valid
(cdr clock)))))))))))
@@ -1154,8 +1154,7 @@ so long."
org-clock-marker (marker-buffer org-clock-marker))
(let* ((org-clock-user-idle-seconds (org-user-idle-seconds))
(org-clock-user-idle-start
- (time-subtract (current-time)
- (seconds-to-time org-clock-user-idle-seconds)))
+ (time-since org-clock-user-idle-seconds))
(org-clock-resolving-clocks-due-to-idleness t))
(if (> org-clock-user-idle-seconds (* 60 org-clock-idle-time))
(org-clock-resolve
@@ -1164,9 +1163,8 @@ so long."
(lambda (_)
(format "Clocked in & idle for %.1f mins"
(/ (float-time
- (time-subtract (current-time)
- org-clock-user-idle-start))
- 60.0)))
+ (time-since org-clock-user-idle-start))
+ 60)))
org-clock-user-idle-start)))))
(defvar org-clock-current-task nil "Task currently clocked in.")
@@ -1293,8 +1291,7 @@ the default behavior."
(setq ts (concat "[" (match-string 1) "]"))
(goto-char (match-end 1))
(setq org-clock-start-time
- (apply 'encode-time
- (org-parse-time-string (match-string 1))))
+ (org-time-string-to-time (match-string 1)))
(setq org-clock-effort (org-entry-get (point) org-effort-property))
(setq org-clock-total-time (org-clock-sum-current-item
(org-clock-get-sum-start))))
@@ -1324,9 +1321,11 @@ the default behavior."
(y-or-n-p
(format
"You stopped another clock %d mins ago; start this one from then? "
- (/ (- (float-time
- (org-current-time org-clock-rounding-minutes t))
- (float-time leftover))
+ (/ (encode-time
+ (time-subtract
+ (org-current-time org-clock-rounding-minutes t)
+ leftover)
+ 'integer)
60)))
leftover)
start-time
@@ -1431,7 +1430,7 @@ The time is always returned as UTC."
(day (nth 3 dt)))
(if (< hour org-extend-today-until) (setf (nth 3 dt) (1- day)))
(setf (nth 2 dt) org-extend-today-until)
- (apply #'encode-time (append (list 0 0) (nthcdr 2 dt)))))
+ (apply #'encode-time 0 0 (nthcdr 2 dt))))
((or (equal cmt "all")
(and (or (not cmt) (equal cmt "auto"))
(not lr)))
@@ -1577,21 +1576,19 @@ to, overriding the existing value of `org-clock-out-switch-to-state'."
(delete-region (point) (point-at-eol))
(insert "--")
(setq te (org-insert-time-stamp (or at-time now) 'with-hm 'inactive))
- (setq s (- (float-time
- (apply #'encode-time (org-parse-time-string te)))
- (float-time
- (apply #'encode-time (org-parse-time-string ts))))
- h (floor (/ s 3600))
- s (- s (* 3600 h))
- m (floor (/ s 60))
- s (- s (* 60 s)))
+ (setq s (encode-time (time-subtract
+ (org-time-string-to-time te)
+ (org-time-string-to-time ts))
+ 'integer)
+ h (floor s 3600)
+ m (floor (mod s 3600) 60))
(insert " => " (format "%2d:%02d" h m))
(move-marker org-clock-marker nil)
(move-marker org-clock-hd-marker nil)
;; Possibly remove zero time clocks. However, do not add
;; a note associated to the CLOCK line in this case.
(cond ((and org-clock-out-remove-zero-time-clocks
- (= (+ h m) 0))
+ (= 0 h m))
(setq remove t)
(delete-region (line-beginning-position)
(line-beginning-position 2)))
@@ -1625,9 +1622,10 @@ to, overriding the existing value of `org-clock-out-switch-to-state'."
"\\>"))))
(org-todo org-clock-out-switch-to-state))))))
(force-mode-line-update)
- (message (concat "Clock stopped at %s after "
- (org-duration-from-minutes (+ (* 60 h) m)) "%s")
- te (if remove " => LINE REMOVED" ""))
+ (message (if remove
+ "Clock stopped at %s after %s => LINE REMOVED"
+ "Clock stopped at %s after %s")
+ te (org-duration-from-minutes (+ (* 60 h) m)))
(run-hooks 'org-clock-out-hook)
(unless (org-clocking-p)
(setq org-clock-current-task nil)))))))
@@ -1813,15 +1811,15 @@ PROPNAME lets you set a custom text property instead of :org-clock-minutes."
((match-end 2)
;; Two time stamps.
(let* ((ts (float-time
- (apply #'encode-time
- (save-match-data
- (org-parse-time-string (match-string 2))))))
+ (encode-time
+ (save-match-data
+ (org-parse-time-string (match-string 2))))))
(te (float-time
- (apply #'encode-time
- (org-parse-time-string (match-string 3)))))
+ (encode-time
+ (org-parse-time-string (match-string 3)))))
(dt (- (if tend (min te tend) te)
(if tstart (max ts tstart) ts))))
- (when (> dt 0) (cl-incf t1 (floor (/ dt 60))))))
+ (when (> dt 0) (cl-incf t1 (floor dt 60)))))
((match-end 4)
;; A naked time.
(setq t1 (+ t1 (string-to-number (match-string 5))
@@ -1835,8 +1833,9 @@ PROPNAME lets you set a custom text property instead of :org-clock-minutes."
tend
(>= (float-time org-clock-start-time) tstart)
(<= (float-time org-clock-start-time) tend))
- (let ((time (floor (- (float-time)
- (float-time org-clock-start-time))
+ (let ((time (floor (encode-time
+ (time-since org-clock-start-time)
+ 'integer)
60)))
(setq t1 (+ t1 time))))
(let* ((headline-forced
@@ -1927,13 +1926,14 @@ Use `\\[org-clock-remove-overlays]' to remove the subtree times."
nil 'local))))
(let* ((h (/ org-clock-file-total-minutes 60))
(m (- org-clock-file-total-minutes (* 60 h))))
- (message (concat (format "Total file time%s: "
- (cond (todayp " for today")
- (customp " (custom)")
- (t "")))
- (org-duration-from-minutes
- org-clock-file-total-minutes)
- " (%d hours and %d minutes)")
+ (message (cond
+ (todayp
+ "Total file time for today: %s (%d hours and %d minutes)")
+ (customp
+ "Total file time (custom): %s (%d hours and %d minutes)")
+ (t
+ "Total file time: %s (%d hours and %d minutes)"))
+ (org-duration-from-minutes org-clock-file-total-minutes)
h m))))
(defvar-local org-clock-overlays nil)
@@ -2239,8 +2239,18 @@ have priority."
(let* ((start (pcase key
(`interactive (org-read-date nil t nil "Range start? "))
;; In theory, all clocks started after the dawn of
- ;; humanity.
- (`untilnow (encode-time 0 0 0 0 0 -50000))
+ ;; humanity. However, the platform's clock
+ ;; support might not go back that far. Choose the
+ ;; POSIX timestamp -2**41 (approximately 68,000
+ ;; BCE) if that works, otherwise -2**31 (1901) if
+ ;; that works, otherwise 0 (1970). Going back
+ ;; billions of years would loop forever on Mac OS
+ ;; X 10.6 with Emacs 26 and earlier (Bug#27736).
+ (`untilnow
+ (let ((old 0))
+ (dolist (older '((-32768 0) (-33554432 0)) old)
+ (when (ignore-errors (decode-time older))
+ (setq old older)))))
(_ (encode-time 0 m h d month y))))
(end (pcase key
(`interactive (org-read-date nil t nil "Range end? "))
@@ -2694,24 +2704,24 @@ LEVEL is an integer. Indent by two spaces per level above 1."
(pcase-let ((`(,month ,day ,year) (calendar-gregorian-from-absolute ts)))
(setq ts (float-time (encode-time 0 0 0 day month year)))))
(ts
- (setq ts (float-time (apply #'encode-time (org-parse-time-string ts))))))
+ (setq ts (float-time (org-time-string-to-time ts)))))
(cond
((numberp te)
;; Likewise for te.
(pcase-let ((`(,month ,day ,year) (calendar-gregorian-from-absolute te)))
(setq te (float-time (encode-time 0 0 0 day month year)))))
(te
- (setq te (float-time (apply #'encode-time (org-parse-time-string te))))))
+ (setq te (float-time (org-time-string-to-time te)))))
(setq tsb
(if (eq step0 'week)
- (let ((dow (nth 6 (decode-time (seconds-to-time ts)))))
+ (let ((dow (nth 6 (decode-time ts))))
(if (<= dow ws) ts
(- ts (* 86400 (- dow ws)))))
ts))
(while (< tsb te)
(unless (bolp) (insert "\n"))
- (let ((start-time (seconds-to-time (max tsb ts))))
- (cl-incf tsb (let ((dow (nth 6 (decode-time (seconds-to-time tsb)))))
+ (let ((start-time (max tsb ts)))
+ (cl-incf tsb (let ((dow (nth 6 (decode-time tsb))))
(if (or (eq step0 'day)
(= dow ws))
step
@@ -2731,7 +2741,7 @@ LEVEL is an integer. Indent by two spaces per level above 1."
:tstart (format-time-string (org-time-stamp-format t t)
start-time)
:tend (format-time-string (org-time-stamp-format t t)
- (seconds-to-time (min te tsb))))))))
+ (min te tsb)))))))
(re-search-forward "^[ \t]*#\\+END:")
(when (and stepskip0 (equal step-time 0))
;; Remove the empty table
@@ -2872,18 +2882,16 @@ Otherwise, return nil."
(<= org-clock-marker (point-at-eol)))
;; The clock is running here
(setq org-clock-start-time
- (apply 'encode-time
- (org-parse-time-string (match-string 1))))
+ (org-time-string-to-time (match-string 1)))
(org-clock-update-mode-line)))
(t
(and (match-end 4) (delete-region (match-beginning 4) (match-end 4)))
(end-of-line 1)
(setq ts (match-string 1)
te (match-string 3))
- (setq s (- (float-time
- (apply #'encode-time (org-parse-time-string te)))
- (float-time
- (apply #'encode-time (org-parse-time-string ts))))
+ (setq s (float-time
+ (time-subtract (org-time-string-to-time te)
+ (org-time-string-to-time ts)))
neg (< s 0)
s (abs s)
h (floor (/ s 3600))
diff --git a/lisp/org/org-colview.el b/lisp/org/org-colview.el
index 2c34eddcf6b..799cc608bfa 100644
--- a/lisp/org/org-colview.el
+++ b/lisp/org/org-colview.el
@@ -540,7 +540,7 @@ Where possible, use the standard interface for changing this line."
(eol (line-end-position))
(pom (or (get-text-property bol 'org-hd-marker) (point)))
(key (or key (get-char-property (point) 'org-columns-key)))
- (org-columns--time (float-time (current-time)))
+ (org-columns--time (float-time))
(action
(pcase key
("CLOCKSUM"
@@ -719,7 +719,7 @@ around it."
(setq time-after (copy-sequence time))
(setf (nth 3 time-before) (1- (nth 3 time)))
(setf (nth 3 time-after) (1+ (nth 3 time)))
- (mapcar (lambda (x) (format-time-string fmt (apply 'encode-time x)))
+ (mapcar (lambda (x) (format-time-string fmt (encode-time x)))
(list time-before time time-after)))))
(defun org-columns-open-link (&optional arg)
@@ -790,7 +790,7 @@ When COLUMNS-FMT-STRING is non-nil, use it as the column format."
(org-columns-goto-top-level)
;; Initialize `org-columns-current-fmt' and
;; `org-columns-current-fmt-compiled'.
- (let ((org-columns--time (float-time (current-time))))
+ (let ((org-columns--time (float-time)))
(org-columns-get-format columns-fmt-string)
(unless org-columns-inhibit-recalculation (org-columns-compute-all))
(save-excursion
@@ -1070,7 +1070,7 @@ as a canonical duration, i.e., using units defined in
(cond
((string-match-p org-ts-regexp s)
(/ (- org-columns--time
- (float-time (apply #'encode-time (org-parse-time-string s))))
+ (float-time (org-time-string-to-time s)))
60))
((org-duration-p s) (org-duration-to-minutes s t)) ;skip user units
(t (user-error "Invalid age: %S" s))))
@@ -1494,7 +1494,7 @@ PARAMS is a property list of parameters:
(if (markerp org-columns-begin-marker)
(move-marker org-columns-begin-marker (point))
(setq org-columns-begin-marker (point-marker)))
- (let* ((org-columns--time (float-time (current-time)))
+ (let* ((org-columns--time (float-time))
(fmt
(cond
((bound-and-true-p org-agenda-overriding-columns-format))
diff --git a/lisp/org/org-ctags.el b/lisp/org/org-ctags.el
index 7dc8dd5b16a..111be379fd4 100644
--- a/lisp/org/org-ctags.el
+++ b/lisp/org/org-ctags.el
@@ -137,6 +137,7 @@
;;; Code:
+(eval-when-compile (require 'cl-lib))
(require 'org)
(defgroup org-ctags nil
@@ -235,7 +236,7 @@ buffer position where the tag is found."
(with-current-buffer (get-file-buffer tags-file-name)
(goto-char (point-min))
(cond
- ((re-search-forward (format "^.*%s\\([0-9]+\\),\\([0-9]+\\)$"
+ ((re-search-forward (format "^.*\^?%s\^A\\([0-9]+\\),\\([0-9]+\\)$"
(regexp-quote tag)) nil t)
(let ((line (string-to-number (match-string 1)))
(pos (string-to-number (match-string 2))))
@@ -260,7 +261,7 @@ Return the list."
(visit-tags-table-buffer 'same)
(with-current-buffer (get-file-buffer tags-file-name)
(goto-char (point-min))
- (while (re-search-forward "^.*\\(.*\\)\\([0-9]+\\),\\([0-9]+\\)$"
+ (while (re-search-forward "^.*\^?\\(.*\\)\^A\\([0-9]+\\),\\([0-9]+\\)$"
nil t)
(push (substring-no-properties (match-string 1)) taglist)))
taglist)))
diff --git a/lisp/org/org-datetree.el b/lisp/org/org-datetree.el
index aea2c8d3d61..b4797de1e58 100644
--- a/lisp/org/org-datetree.el
+++ b/lisp/org/org-datetree.el
@@ -138,15 +138,16 @@ will be built under the headline at point."
"^\\*+[ \t]+%d-%02d-\\([0123][0-9]\\) \\w+$"
year month day))))
-(defun org-datetree--find-create (regex year &optional month day insert)
- "Find the datetree matched by REGEX for YEAR, MONTH, or DAY.
-REGEX is passed to `format' with YEAR, MONTH, and DAY as
+(defun org-datetree--find-create
+ (regex-template year &optional month day insert)
+ "Find the datetree matched by REGEX-TEMPLATE for YEAR, MONTH, or DAY.
+REGEX-TEMPLATE is passed to `format' with YEAR, MONTH, and DAY as
arguments. Match group 1 is compared against the specified date
component. If INSERT is non-nil and there is no match then it is
inserted into the buffer."
(when (or month day)
(org-narrow-to-subtree))
- (let ((re (format regex year month day))
+ (let ((re (format regex-template year month day))
match)
(goto-char (point-min))
(while (and (setq match (re-search-forward re nil t))
diff --git a/lisp/org/org-duration.el b/lisp/org/org-duration.el
index f115082243b..770c72fd676 100644
--- a/lisp/org/org-duration.el
+++ b/lisp/org/org-duration.el
@@ -317,11 +317,10 @@ When optional argument CANONICAL is non-nil, ignore
Raise an error if expected format is unknown."
(pcase (or fmt org-duration-format)
(`h:mm
- (let ((minutes (floor minutes)))
- (format "%d:%02d" (/ minutes 60) (mod minutes 60))))
+ (format "%d:%02d" (/ minutes 60) (mod minutes 60)))
(`h:mm:ss
(let* ((whole-minutes (floor minutes))
- (seconds (floor (* 60 (- minutes whole-minutes)))))
+ (seconds (mod (* 60 minutes) 60)))
(format "%s:%02d"
(org-duration-from-minutes whole-minutes 'h:mm)
seconds)))
@@ -402,9 +401,7 @@ Raise an error if expected format is unknown."
(pcase-let* ((`(,unit . ,required?) units)
(modifier (org-duration--modifier unit canonical)))
(cond ((<= modifier minutes)
- (let ((value (if (integerp modifier)
- (/ (floor minutes) modifier)
- (floor (/ minutes modifier)))))
+ (let ((value (floor minutes modifier)))
(cl-decf minutes (* value modifier))
(format " %d%s" value unit)))
(required? (concat " 0" unit))
diff --git a/lisp/org/org-element.el b/lisp/org/org-element.el
index 6458335704e..04e2fda55e3 100644
--- a/lisp/org/org-element.el
+++ b/lisp/org/org-element.el
@@ -2119,7 +2119,7 @@ containing `:key', `:value', `:begin', `:end', `:post-blank' and
;; this corner case.
(let ((begin (or (car affiliated) (point)))
(post-affiliated (point))
- (key (progn (looking-at "[ \t]*#\\+\\(\\S-+*\\):")
+ (key (progn (looking-at "[ \t]*#\\+\\(\\S-*\\):")
(upcase (match-string-no-properties 1))))
(value (org-trim (buffer-substring-no-properties
(match-end 0) (point-at-eol))))
@@ -4765,13 +4765,13 @@ you want to help debugging the issue.")
(defvar org-element-cache-sync-idle-time 0.6
"Length, in seconds, of idle time before syncing cache.")
-(defvar org-element-cache-sync-duration (seconds-to-time 0.04)
+(defvar org-element-cache-sync-duration 0.04
"Maximum duration, as a time value, for a cache synchronization.
If the synchronization is not over after this delay, the process
pauses and resumes after `org-element-cache-sync-break'
seconds.")
-(defvar org-element-cache-sync-break (seconds-to-time 0.3)
+(defvar org-element-cache-sync-break 0.3
"Duration, as a time value, of the pause between synchronizations.
See `org-element-cache-sync-duration' for more information.")
@@ -4856,7 +4856,7 @@ table is cleared once the synchronization is complete."
(defun org-element--cache-generate-key (lower upper)
"Generate a key between LOWER and UPPER.
-LOWER and UPPER are integers or lists, possibly empty.
+LOWER and UPPER are fixnums or lists of same, possibly empty.
If LOWER and UPPER are equals, return LOWER. Otherwise, return
a unique key, as an integer or a list of integers, according to
@@ -4950,6 +4950,7 @@ A and B are either integers or lists of integers, as returned by
(defsubst org-element--cache-root ()
"Return root value in cache.
This function assumes `org-element--cache' is a valid AVL tree."
+ ;; FIXME: Why use internal functions of avl-tree?
(avl-tree--node-left (avl-tree--dummyroot org-element--cache)))
@@ -4978,6 +4979,7 @@ the cache."
(aref (car org-element--cache-sync-requests) 0)))
(node (org-element--cache-root))
lower upper)
+ ;; FIXME: Why use internal functions of avl-tree?
(while node
(let* ((element (avl-tree--node-data node))
(begin (org-element-property :begin element)))
@@ -5064,7 +5066,7 @@ Assume ELEMENT belongs to cache and that a cache is active."
TIME-LIMIT is a time value or nil."
(and time-limit
(or (input-pending-p)
- (time-less-p time-limit (current-time)))))
+ (time-less-p time-limit nil))))
(defsubst org-element--cache-shift-positions (element offset &optional props)
"Shift ELEMENT properties relative to buffer positions by OFFSET.
@@ -5118,8 +5120,7 @@ updated before current modification are actually submitted."
(and next (aref next 0))
threshold
(and (not threshold)
- (time-add (current-time)
- org-element-cache-sync-duration))
+ (time-add nil org-element-cache-sync-duration))
future-change)
;; Request processed. Merge current and next offsets and
;; transfer ending position.
diff --git a/lisp/org/org-eshell.el b/lisp/org/org-eshell.el
index bb27d92e12d..2251a1b892f 100644
--- a/lisp/org/org-eshell.el
+++ b/lisp/org/org-eshell.el
@@ -37,7 +37,7 @@
eshell buffer) or a command line prefixed by a buffer name
followed by a colon."
(let* ((buffer-and-command
- (if (string-match "\\([A-Za-z0-9-+*]+\\):\\(.*\\)" link)
+ (if (string-match "\\([A-Za-z0-9+*-]+\\):\\(.*\\)" link)
(list (match-string 1 link)
(match-string 2 link))
(list eshell-buffer-name link)))
diff --git a/lisp/org/org-footnote.el b/lisp/org/org-footnote.el
index dee127a78ab..f8963184654 100644
--- a/lisp/org/org-footnote.el
+++ b/lisp/org/org-footnote.el
@@ -636,7 +636,7 @@ or new, let the user edit the definition of the footnote."
(let* ((all (org-footnote-all-labels))
(label
(if (eq org-footnote-auto-label 'random)
- (format "%x" (random most-positive-fixnum))
+ (format "%x" (abs (random)))
(org-footnote-normalize-label
(let ((propose (org-footnote-unique-label all)))
(if (eq org-footnote-auto-label t) propose
diff --git a/lisp/org/org-habit.el b/lisp/org/org-habit.el
index 06429d7ff37..6234d0251e9 100644
--- a/lisp/org/org-habit.el
+++ b/lisp/org/org-habit.el
@@ -288,7 +288,7 @@ Habits are assigned colors on the following basis:
(deadline (if scheduled-days
(+ scheduled-days (- d-repeat s-repeat))
(org-habit-deadline habit)))
- (m-days (or now-days (time-to-days (current-time)))))
+ (m-days (or now-days (time-to-days nil))))
(cond
((< m-days scheduled)
'(org-habit-clear-face . org-habit-clear-future-face))
@@ -406,8 +406,7 @@ current time."
"Insert consistency graph for any habitual tasks."
(let ((inhibit-read-only t)
(buffer-invisibility-spec '(org-link))
- (moment (time-subtract (current-time)
- (list 0 (* 3600 org-extend-today-until) 0))))
+ (moment (time-since (* 3600 org-extend-today-until))))
(save-excursion
(goto-char (if line (point-at-bol) (point-min)))
(while (not (eobp))
diff --git a/lisp/org/org-id.el b/lisp/org/org-id.el
index 994aa7e3e83..6a9d729c0a4 100644
--- a/lisp/org/org-id.el
+++ b/lisp/org/org-id.el
@@ -357,7 +357,7 @@ So a typical ID could look like \"Org:4nd91V40HI\"."
"Return string with random (version 4) UUID."
(let ((rnd (md5 (format "%s%s%s%s%s%s%s"
(random)
- (current-time)
+ (encode-time nil 'list)
(user-uid)
(emacs-pid)
(user-full-name)
@@ -416,7 +416,7 @@ The input I may be a character, or a single-letter string."
"Encode TIME as a 10-digit string.
This string holds the time to micro-second accuracy, and can be decoded
using `org-id-decode'."
- (setq time (or time (current-time)))
+ (setq time (encode-time time 'list))
(concat (org-id-int-to-b36 (nth 0 time) 4)
(org-id-int-to-b36 (nth 1 time) 4)
(org-id-int-to-b36 (or (nth 2 time) 0) 4)))
diff --git a/lisp/org/org-indent.el b/lisp/org/org-indent.el
index 71d6658a56f..97cf8786566 100644
--- a/lisp/org/org-indent.el
+++ b/lisp/org/org-indent.el
@@ -183,11 +183,15 @@ during idle time."
org-hide-leading-stars)
(setq-local org-hide-leading-stars t))
(org-indent--compute-prefixes)
- (add-hook 'filter-buffer-substring-functions
- (lambda (fun start end delete)
- (org-indent-remove-properties-from-string
- (funcall fun start end delete)))
- nil t)
+ (if (boundp 'filter-buffer-substring-functions)
+ (add-hook 'filter-buffer-substring-functions
+ (lambda (fun start end delete)
+ (org-indent-remove-properties-from-string
+ (funcall fun start end delete)))
+ nil t)
+ ;; Emacs >= 24.4.
+ (add-function :filter-return (local 'filter-buffer-substring-function)
+ #'org-indent-remove-properties-from-string))
(add-hook 'after-change-functions 'org-indent-refresh-maybe nil 'local)
(add-hook 'before-change-functions
'org-indent-notify-modified-headline nil 'local)
@@ -211,10 +215,13 @@ during idle time."
(when (boundp 'org-hide-leading-stars-before-indent-mode)
(setq-local org-hide-leading-stars
org-hide-leading-stars-before-indent-mode))
- (remove-hook 'filter-buffer-substring-functions
- (lambda (fun start end delete)
- (org-indent-remove-properties-from-string
- (funcall fun start end delete))))
+ (if (boundp 'filter-buffer-substring-functions)
+ (remove-hook 'filter-buffer-substring-functions
+ (lambda (fun start end delete)
+ (org-indent-remove-properties-from-string
+ (funcall fun start end delete))))
+ (remove-function (local 'filter-buffer-substring-function)
+ #'org-indent-remove-properties-from-string))
(remove-hook 'after-change-functions 'org-indent-refresh-maybe 'local)
(remove-hook 'before-change-functions
'org-indent-notify-modified-headline 'local)
@@ -325,7 +332,7 @@ stopped."
(let* ((case-fold-search t)
(limited-re (org-get-limited-outline-regexp))
(level (or (org-current-level) 0))
- (time-limit (and delay (time-add (current-time) delay))))
+ (time-limit (and delay (time-add nil delay))))
;; For each line, set `line-prefix' and `wrap-prefix'
;; properties depending on the type of line (headline, inline
;; task, item or other).
@@ -338,7 +345,7 @@ stopped."
;; In asynchronous mode, take a break of
;; `org-indent-agent-resume-delay' every DELAY to avoid
;; blocking any other idle timer or process output.
- ((and delay (time-less-p time-limit (current-time)))
+ ((and delay (time-less-p time-limit nil))
(setq org-indent-agent-resume-timer
(run-with-idle-timer
(time-add (current-idle-time) org-indent-agent-resume-delay)
diff --git a/lisp/org/org-list.el b/lisp/org/org-list.el
index 96c8f55d3a5..22692d224a8 100644
--- a/lisp/org/org-list.el
+++ b/lisp/org/org-list.el
@@ -236,7 +236,7 @@ into
(defcustom org-plain-list-ordered-item-terminator t
"The character that makes a line with leading number an ordered list item.
-Valid values are ?. and ?\). To get both terminators, use t.
+Valid values are ?. and ?\\). To get both terminators, use t.
This variable needs to be set before org.el is loaded. If you
need to make a change while Emacs is running, use the customize
@@ -2678,7 +2678,7 @@ Return t if successful."
(error "Cannot outdent beyond margin")
;; Change bullet if necessary.
(when (and (= (+ top-ind offset) 0)
- (string-match "*"
+ (string-match "\\*"
(org-list-get-bullet beg struct)))
(org-list-set-bullet beg struct
(org-list-bullet-string "-")))
diff --git a/lisp/org/org-macro.el b/lisp/org/org-macro.el
index b2399966dc7..a151e1e8469 100644
--- a/lisp/org/org-macro.el
+++ b/lisp/org/org-macro.el
@@ -159,7 +159,8 @@ function installs the following ones: \"property\",
(format "(eval (format-time-string \"$1\" (or (and (org-string-nw-p \"$2\") (org-macro--vc-modified-time %s)) '%s)))"
(prin1-to-string visited-file)
(prin1-to-string
- (nth 5 (file-attributes visited-file)))))))))
+ (file-attribute-modification-time
+ (file-attributes visited-file)))))))))
;; Initialize and install "n" macro.
(org-macro--counter-initialize)
(funcall update-templates
@@ -312,7 +313,7 @@ Return a list of arguments, as strings. This is the opposite of
(buffer-substring
(point) (line-end-position)))))
(when (cl-some #'identity time)
- (setq date (apply #'encode-time time))))))))
+ (setq date (encode-time time))))))))
(let ((proc (get-buffer-process buf)))
(while (and proc (accept-process-output proc .5 nil t)))))
(kill-buffer buf))
diff --git a/lisp/org/org-macs.el b/lisp/org/org-macs.el
index 9851168e970..3c768244331 100644
--- a/lisp/org/org-macs.el
+++ b/lisp/org/org-macs.el
@@ -31,6 +31,8 @@
;;; Code:
+(require 'cl-lib)
+
(defmacro org-with-gensyms (symbols &rest body)
(declare (debug (sexp body)) (indent 1))
`(let ,(mapcar (lambda (s)
diff --git a/lisp/org/org-mhe.el b/lisp/org/org-mhe.el
index 969bff3cc64..a37c41ad06e 100644
--- a/lisp/org/org-mhe.el
+++ b/lisp/org/org-mhe.el
@@ -142,7 +142,7 @@ So if you use sequences, it will now work."
"Return the name of the message folder in an index folder buffer."
(save-excursion
(mh-index-previous-folder)
- (if (re-search-forward "^\\(+.*\\)$" nil t)
+ (if (re-search-forward "^\\(\\+.*\\)$" nil t)
(message "%s" (match-string 1)))))
(defun org-mhe-get-message-folder ()
diff --git a/lisp/org/org-mobile.el b/lisp/org/org-mobile.el
index 1ff6358403c..8b4e8953889 100644
--- a/lisp/org/org-mobile.el
+++ b/lisp/org/org-mobile.el
@@ -845,11 +845,11 @@ If BEG and END are given, only do this in that region."
(cl-incf cnt-error)
(throw 'next t))
(move-marker bos-marker (point))
- (if (re-search-forward "^** Old value[ \t]*$" eos t)
+ (if (re-search-forward "^\\** Old value[ \t]*$" eos t)
(setq old (buffer-substring
(1+ (match-end 0))
(progn (outline-next-heading) (point)))))
- (if (re-search-forward "^** New value[ \t]*$" eos t)
+ (if (re-search-forward "^\\** New value[ \t]*$" eos t)
(setq new (buffer-substring
(1+ (match-end 0))
(progn (outline-next-heading)
diff --git a/lisp/org/org-mouse.el b/lisp/org/org-mouse.el
index ac75decb925..a3dcb77554c 100644
--- a/lisp/org/org-mouse.el
+++ b/lisp/org/org-mouse.el
@@ -643,7 +643,7 @@ This means, between the beginning of line and the point."
,@(org-mouse-list-options-menu (mapcar 'car org-startup-options)
'org-mode-restart))))
((or (eolp)
- (and (looking-at "\\( \\|\t\\)\\(+:[0-9a-zA-Z_:]+\\)?\\( \\|\t\\)+$")
+ (and (looking-at "\\( \\|\t\\)\\(\\+:[0-9a-zA-Z_:]+\\)?\\( \\|\t\\)+$")
(looking-back " \\|\t" (- (point) 2)
(line-beginning-position))))
(org-mouse-popup-global-menu))
diff --git a/lisp/org/org-pcomplete.el b/lisp/org/org-pcomplete.el
index 7f944c5a765..cf272de90a8 100644
--- a/lisp/org/org-pcomplete.el
+++ b/lisp/org/org-pcomplete.el
@@ -49,10 +49,10 @@
"Examine the thing at point and let the caller know what it is.
The return value is a string naming the thing at point."
(let ((beg1 (save-excursion
- (skip-chars-backward "[:alnum:]-_@")
+ (skip-chars-backward "-[:alnum:]_@")
(point)))
(beg (save-excursion
- (skip-chars-backward "a-zA-Z0-9-_:$")
+ (skip-chars-backward "-a-zA-Z0-9_:$")
(point)))
(line-to-here (buffer-substring (point-at-bol) (point))))
(cond
@@ -82,7 +82,7 @@ The return value is a string naming the thing at point."
(not (equal (char-after (point-at-bol)) ?*))
(save-excursion
(move-beginning-of-line 1)
- (skip-chars-backward "[ \t\n]")
+ (skip-chars-backward " \t\n")
;; org-drawer-regexp matches a whole line but while
;; looking-back, we just ignore trailing whitespaces
(or (looking-back (substring org-drawer-regexp 0 -1)
@@ -194,7 +194,7 @@ When completing for #+STARTUP, for example, this function returns
"Complete arguments for the #+LANGUAGE file option."
(require 'ox)
(pcomplete-here
- (pcomplete-uniqify-list
+ (pcomplete-uniquify-list
(list org-export-default-language "en"))))
(defvar org-default-priority)
@@ -219,7 +219,7 @@ When completing for #+STARTUP, for example, this function returns
(defun pcomplete/org-mode/file-option/startup ()
"Complete arguments for the #+STARTUP file option."
(while (pcomplete-here
- (let ((opts (pcomplete-uniqify-list
+ (let ((opts (pcomplete-uniquify-list
(mapcar 'car org-startup-options))))
;; Some options are mutually exclusive, and shouldn't be completed
;; against if certain other options have already been seen.
@@ -248,7 +248,7 @@ When completing for #+STARTUP, for example, this function returns
(defun pcomplete/org-mode/file-option/options ()
"Complete arguments for the #+OPTIONS file option."
(while (pcomplete-here
- (pcomplete-uniqify-list
+ (pcomplete-uniquify-list
(append
;; Hard-coded OPTION items always available.
'("H:" "\\n:" "num:" "timestamp:" "arch:" "author:" "c:"
@@ -267,7 +267,7 @@ When completing for #+STARTUP, for example, this function returns
(defun pcomplete/org-mode/file-option/infojs_opt ()
"Complete arguments for the #+INFOJS_OPT file option."
(while (pcomplete-here
- (pcomplete-uniqify-list
+ (pcomplete-uniquify-list
(mapcar (lambda (item) (format "%s:" (car item)))
(bound-and-true-p org-html-infojs-opts-table))))))
@@ -283,7 +283,7 @@ When completing for #+STARTUP, for example, this function returns
(defun pcomplete/org-mode/link ()
"Complete against defined #+LINK patterns."
(pcomplete-here
- (pcomplete-uniqify-list
+ (pcomplete-uniquify-list
(copy-sequence
(append (mapcar 'car org-link-abbrev-alist-local)
(mapcar 'car org-link-abbrev-alist))))))
@@ -293,13 +293,13 @@ When completing for #+STARTUP, for example, this function returns
"Complete against TeX-style HTML entity names."
(require 'org-entities)
(while (pcomplete-here
- (pcomplete-uniqify-list (remove nil (mapcar 'car-safe org-entities)))
+ (pcomplete-uniquify-list (remove nil (mapcar 'car-safe org-entities)))
(substring pcomplete-stub 1))))
(defvar org-todo-keywords-1)
(defun pcomplete/org-mode/todo ()
"Complete against known TODO keywords."
- (pcomplete-here (pcomplete-uniqify-list (copy-sequence org-todo-keywords-1))))
+ (pcomplete-here (pcomplete-uniquify-list (copy-sequence org-todo-keywords-1))))
(defvar org-todo-line-regexp)
(defun pcomplete/org-mode/searchhead ()
@@ -315,14 +315,14 @@ This needs more work, to handle headings with lots of spaces in them."
(push (org-make-org-heading-search-string
(match-string-no-properties 3))
tbl)))
- (pcomplete-uniqify-list tbl)))
+ (pcomplete-uniquify-list tbl)))
(substring pcomplete-stub 1))))
(defun pcomplete/org-mode/tag ()
"Complete a tag name. Omit tags already set."
(while (pcomplete-here
(mapcar (lambda (x) (concat x ":"))
- (let ((lst (pcomplete-uniqify-list
+ (let ((lst (pcomplete-uniquify-list
(or (remq
nil
(mapcar (lambda (x) (org-string-nw-p (car x)))
@@ -339,7 +339,7 @@ This needs more work, to handle headings with lots of spaces in them."
(pcomplete-here
(mapcar (lambda (x)
(concat x ": "))
- (let ((lst (pcomplete-uniqify-list
+ (let ((lst (pcomplete-uniquify-list
(copy-sequence
(org-buffer-property-keys nil t t t)))))
(dolist (prop (org-entry-properties))
diff --git a/lisp/org/org-plot.el b/lisp/org/org-plot.el
index aa34e4011ae..a5635e326d4 100644
--- a/lisp/org/org-plot.el
+++ b/lisp/org/org-plot.el
@@ -336,7 +336,7 @@ line directly before or after the table."
(insert "\n")
(insert-file-contents (plist-get params :script))
(goto-char (point-min))
- (while (re-search-forward "$datafile" nil t)
+ (while (re-search-forward "\\$datafile" nil t)
(replace-match data-file nil nil)))
(insert (org-plot/gnuplot-script data-file num-cols params)))
;; Graph table.
diff --git a/lisp/org/org-protocol.el b/lisp/org/org-protocol.el
index 3959a17cf4a..016105ef53b 100644
--- a/lisp/org/org-protocol.el
+++ b/lisp/org/org-protocol.el
@@ -331,7 +331,7 @@ returned list."
(len 0)
dir
ret)
- (when (string-match "^\\(.*\\)\\(org-protocol:/+[a-zA-z0-9][-_a-zA-z0-9]*:/+\\)\\(.*\\)" trigger)
+ (when (string-match "^\\(.*\\)\\(org-protocol:/+[a-zA-Z0-9][-_a-zA-Z0-9]*:/+\\)\\(.*\\)" trigger)
(setq dir (match-string 1 trigger))
(setq len (length dir))
(setcar l (concat dir (match-string 3 trigger))))
@@ -349,17 +349,20 @@ returned list."
ret)
l)))
-(defun org-protocol-flatten (list)
- "Transform LIST into a flat list.
+(defalias 'org-protocol-flatten
+ (if (fboundp 'flatten-tree) 'flatten-tree
+ (lambda (list)
+ "Transform LIST into a flat list.
Greedy handlers might receive a list like this from emacsclient:
\((\"/dir/org-protocol:/greedy:/~/path1\" (23 . 12)) (\"/dir/param\"))
where \"/dir/\" is the absolute path to emacsclients working directory.
This function transforms it into a flat list."
- (if (null list) ()
- (if (listp list)
- (append (org-protocol-flatten (car list)) (org-protocol-flatten (cdr list)))
- (list list))))
+ (if list
+ (if (consp list)
+ (append (org-protocol-flatten (car list))
+ (org-protocol-flatten (cdr list)))
+ (list list))))))
(defun org-protocol-parse-parameters (info &optional new-style default-order)
"Return a property list of parameters from INFO.
diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el
index 0a8382c8b56..b6e864fc9c9 100644
--- a/lisp/org/org-table.el
+++ b/lisp/org/org-table.el
@@ -1182,7 +1182,7 @@ to a number. In the case of a timestamp, increment by days."
(- (org-time-string-to-absolute txt)
(org-time-string-to-absolute txt-up)))
((string-match org-ts-regexp3 txt) 1)
- ((string-match "\\([-+]\\)?\\(?:[0-9]+\\)?\\(?:\.[0-9]+\\)?" txt-up)
+ ((string-match "\\([-+]\\)?[0-9]*\\(?:\\.[0-9]+\\)?" txt-up)
(- (string-to-number txt)
(string-to-number (match-string 0 txt-up))))
(t 1)))
@@ -2175,8 +2175,8 @@ If NLAST is a number, only the NLAST fields will actually be summed."
(sres (if (= org-timecnt 0)
(number-to-string res)
(setq diff (* 3600 res)
- h (floor (/ diff 3600)) diff (mod diff 3600)
- m (floor (/ diff 60)) diff (mod diff 60)
+ h (floor diff 3600) diff (mod diff 3600)
+ m (floor diff 60) diff (mod diff 60)
s diff)
(format "%.0f:%02.0f:%02.0f" h m s))))
(kill-new sres)
@@ -2307,7 +2307,7 @@ LOCATION instead."
"\n"))))
(defsubst org-table-formula-make-cmp-string (a)
- (when (string-match "\\`$[<>]" a)
+ (when (string-match "\\`\\$[<>]" a)
(let ((arrow (string-to-char (substring a 1))))
;; Fake a high number to make sure this is sorted at the end.
(setq a (org-table-formula-handle-first/last-rc a))
@@ -2355,7 +2355,7 @@ LOCATION is a buffer position, consider the formulas there."
(cond
((not (match-end 2)) m)
;; Is it a column reference?
- ((string-match-p "\\`$\\([0-9]+\\|[<>]+\\)\\'" m) m)
+ ((string-match-p "\\`\\$\\([0-9]+\\|[<>]+\\)\\'" m) m)
;; Since named columns are not possible in
;; LHS, assume this is a named field.
(t (match-string 2 string)))))
@@ -2909,8 +2909,8 @@ location of point."
(format-time-string
(org-time-stamp-format
(string-match-p "[0-9]\\{1,2\\}:[0-9]\\{2\\}" ts))
- (apply #'encode-time
- (save-match-data (org-parse-time-string ts))))))
+ (encode-time
+ (save-match-data (org-parse-time-string ts))))))
form t t))
(setq ev (if (and duration (string-match "^[0-9]+:[0-9]+\\(?::[0-9]+\\)?$" form))
@@ -3216,7 +3216,7 @@ known that the table will be realigned a little later anyway."
(cond
((string-match "\\`@-?I+" old-lhs)
(user-error "Can't assign to hline relative reference"))
- ((string-match "\\`$[<>]" old-lhs)
+ ((string-match "\\`\\$[<>]" old-lhs)
(let ((new (org-table-formula-handle-first/last-rc
old-lhs)))
(when (assoc new eqlist)
@@ -3639,7 +3639,8 @@ Parameters get priority."
(setq startline (org-current-line))
(dolist (entry eql)
(let* ((type (cond
- ((string-match "\\`$\\([0-9]+\\|[<>]+\\)\\'" (car entry))
+ ((string-match "\\`\\$\\([0-9]+\\|[<>]+\\)\\'"
+ (car entry))
'column)
((equal (string-to-char (car entry)) ?@) 'field)
(t 'named)))
diff --git a/lisp/org/org-timer.el b/lisp/org/org-timer.el
index bf17de4b03e..6529a8b0ddf 100644
--- a/lisp/org/org-timer.el
+++ b/lisp/org/org-timer.el
@@ -139,12 +139,7 @@ the region 0:00:00."
(format "Restart timer with offset [%s]: " def)))
(unless (string-match "\\S-" s) (setq s def))
(setq delta (org-timer-hms-to-secs (org-timer-fix-incomplete s)))))
- (setq org-timer-start-time
- (seconds-to-time
- ;; Pass `current-time' result to `float-time' (instead
- ;; of calling without arguments) so that only
- ;; `current-time' has to be overridden in tests.
- (- (float-time (current-time)) delta))))
+ (setq org-timer-start-time (time-since delta)))
(setq org-timer-pause-time nil)
(org-timer-set-mode-line 'on)
(message "Timer start time set to %s, current value is %s"
@@ -167,14 +162,9 @@ With prefix arg STOP, stop it entirely."
(setq org-timer-countdown-timer
(org-timer--run-countdown-timer
new-secs org-timer-countdown-timer-title))
- (setq org-timer-start-time
- (time-add (current-time) (seconds-to-time new-secs))))
+ (setq org-timer-start-time (time-add nil new-secs)))
(setq org-timer-start-time
- ;; Pass `current-time' result to `float-time' (instead
- ;; of calling without arguments) so that only
- ;; `current-time' has to be overridden in tests.
- (seconds-to-time (- (float-time (current-time))
- (- pause-secs start-secs)))))
+ (time-since (- pause-secs start-secs))))
(setq org-timer-pause-time nil)
(org-timer-set-mode-line 'on)
(run-hooks 'org-timer-continue-hook)
@@ -233,14 +223,9 @@ it in the buffer."
(abs (floor (org-timer-seconds))))))
(defun org-timer-seconds ()
- ;; Pass `current-time' result to `float-time' (instead of calling
- ;; without arguments) so that only `current-time' has to be
- ;; overridden in tests.
- (if org-timer-countdown-timer
- (- (float-time org-timer-start-time)
- (float-time (or org-timer-pause-time (current-time))))
- (- (float-time (or org-timer-pause-time (current-time)))
- (float-time org-timer-start-time))))
+ (let ((s (float-time (time-subtract org-timer-pause-time
+ org-timer-start-time))))
+ (if org-timer-countdown-timer (- s) s)))
;;;###autoload
(defun org-timer-change-times-in-region (beg end delta)
@@ -400,7 +385,7 @@ VALUE can be `on', `off', or `paused'."
(message "No timer set")
(let* ((rtime (decode-time
(time-subtract (timer--time org-timer-countdown-timer)
- (current-time))))
+ nil)))
(rsecs (nth 0 rtime))
(rmins (nth 1 rtime)))
(message "%d minute(s) %d seconds left before next time out"
@@ -463,8 +448,7 @@ using three `C-u' prefix arguments."
(org-timer--run-countdown-timer
secs org-timer-countdown-timer-title))
(run-hooks 'org-timer-set-hook)
- (setq org-timer-start-time
- (time-add (current-time) (seconds-to-time secs)))
+ (setq org-timer-start-time (time-add nil secs))
(setq org-timer-pause-time nil)
(org-timer-set-mode-line 'on))))))
diff --git a/lisp/org/org.el b/lisp/org/org.el
index bce12956e23..ce6dd24a83b 100644
--- a/lisp/org/org.el
+++ b/lisp/org/org.el
@@ -229,9 +229,10 @@ file to byte-code before it is loaded."
(interactive "fFile to load: \nP")
(let* ((age (lambda (file)
(float-time
- (time-subtract (current-time)
- (nth 5 (or (file-attributes (file-truename file))
- (file-attributes file)))))))
+ (time-since
+ (file-attribute-modification-time
+ (or (file-attributes (file-truename file))
+ (file-attributes file)))))))
(base-name (file-name-sans-extension file))
(exported-file (concat base-name ".el")))
;; tangle if the Org file is newer than the elisp file
@@ -429,7 +430,7 @@ Matched keyword is in group 1.")
(defconst org-deadline-time-hour-regexp
(concat "\\<" org-deadline-string
- " *<\\([^>]+[0-9]\\{1,2\\}:[0-9]\\{2\\}[0-9-+:hdwmy \t.]*\\)>")
+ " *<\\([^>]+[0-9]\\{1,2\\}:[0-9]\\{2\\}[0-9+:hdwmy \t.-]*\\)>")
"Matches the DEADLINE keyword together with a time-and-hour stamp.")
(defconst org-deadline-line-regexp
@@ -445,7 +446,7 @@ Matched keyword is in group 1.")
(defconst org-scheduled-time-hour-regexp
(concat "\\<" org-scheduled-string
- " *<\\([^>]+[0-9]\\{1,2\\}:[0-9]\\{2\\}[0-9-+:hdwmy \t.]*\\)>")
+ " *<\\([^>]+[0-9]\\{1,2\\}:[0-9]\\{2\\}[0-9+:hdwmy \t.-]*\\)>")
"Matches the SCHEDULED keyword together with a time-and-hour stamp.")
(defconst org-closed-time-regexp
@@ -1071,6 +1072,8 @@ has been set."
:group 'org-startup
:type 'boolean)
+(defvaralias 'org-CUA-compatible 'org-replace-disputed-keys)
+
(defcustom org-replace-disputed-keys nil
"Non-nil means use alternative key bindings for some keys.
Org mode uses S-<cursor> keys for changing timestamps and priorities.
@@ -1095,8 +1098,6 @@ loading Org."
:group 'org-startup
:type 'boolean)
-(defvaralias 'org-CUA-compatible 'org-replace-disputed-keys)
-
(defcustom org-disputed-keys
'(([(shift up)] . [(meta p)])
([(shift down)] . [(meta n)])
@@ -1490,6 +1491,8 @@ time in Emacs."
:group 'org-edit-structure
:type 'boolean)
+(defvaralias 'org-special-ctrl-a 'org-special-ctrl-a/e)
+
(defcustom org-special-ctrl-a/e nil
"Non-nil means `C-a' and `C-e' behave specially in headlines and items.
@@ -1527,7 +1530,6 @@ This may also be a cons cell where the behavior for `C-a' and
(const :tag "off" nil)
(const :tag "on: before tags first" t)
(const :tag "reversed: after tags first" reversed)))))
-(defvaralias 'org-special-ctrl-a 'org-special-ctrl-a/e)
(defcustom org-special-ctrl-k nil
"Non-nil means `C-k' will behave specially in headlines.
@@ -3005,6 +3007,8 @@ because Agenda Log mode depends on the format of these entries."
(unless (assq 'note org-log-note-headings)
(push '(note . "%t") org-log-note-headings))
+(defvaralias 'org-log-state-notes-into-drawer 'org-log-into-drawer)
+
(defcustom org-log-into-drawer nil
"Non-nil means insert state change notes and time stamps into a drawer.
When nil, state changes notes will be inserted after the headline and
@@ -3036,8 +3040,6 @@ function `org-log-into-drawer' instead."
(const :tag "LOGBOOK" t)
(string :tag "Other")))
-(defvaralias 'org-log-state-notes-into-drawer 'org-log-into-drawer)
-
(defun org-log-into-drawer ()
"Name of the log drawer, as a string, or nil.
This is the value of `org-log-into-drawer'. However, if the
@@ -3342,6 +3344,9 @@ This display will be in an overlay, in the minibuffer."
:group 'org-time
:type 'boolean)
+(defvaralias 'org-popup-calendar-for-date-prompt
+ 'org-read-date-popup-calendar)
+
(defcustom org-read-date-popup-calendar t
"Non-nil means pop up a calendar when prompting for a date.
In the calendar, the date can be selected with mouse-1. However, the
@@ -3349,8 +3354,6 @@ minibuffer will also be active, and you can simply enter the date as well.
When nil, only the minibuffer will be available."
:group 'org-time
:type 'boolean)
-(defvaralias 'org-popup-calendar-for-date-prompt
- 'org-read-date-popup-calendar)
(defcustom org-extend-today-until 0
"The hour when your day really ends. Must be an integer.
@@ -3798,6 +3801,9 @@ regular expression will be included."
:group 'org-agenda
:type 'regexp)
+(defvaralias 'org-agenda-multi-occur-extra-files
+ 'org-agenda-text-search-extra-files)
+
(defcustom org-agenda-text-search-extra-files nil
"List of extra files to be searched by text search commands.
These files will be searched in addition to the agenda files by the
@@ -3815,9 +3821,6 @@ scope."
(const :tag "Agenda Archives" agenda-archives)
(repeat :inline t (file))))
-(defvaralias 'org-agenda-multi-occur-extra-files
- 'org-agenda-text-search-extra-files)
-
(defcustom org-agenda-skip-unavailable-files nil
"Non-nil means to just skip non-reachable files in `org-agenda-files'.
A nil value means to remove them, after a query, from the list."
@@ -5610,22 +5613,20 @@ When ROUNDING-MINUTES is not an integer, fall back on the car of
the rounding returns a past time."
(let ((r (or (and (integerp rounding-minutes) rounding-minutes)
(car org-time-stamp-rounding-minutes)))
- (time (decode-time)) res)
+ (now (current-time)))
(if (< r 1)
- (current-time)
- (setq res
- (apply 'encode-time
- (append (list 0 (* r (floor (+ .5 (/ (float (nth 1 time)) r)))))
- (nthcdr 2 time))))
- (if (and past (< (float-time (time-subtract (current-time) res)) 0))
- (seconds-to-time (- (float-time res) (* r 60)))
- res))))
+ now
+ (let* ((time (decode-time now))
+ (res (apply #'encode-time 0 (* r (round (nth 1 time) r))
+ (nthcdr 2 time))))
+ (if (or (not past) (time-less-p res now))
+ res
+ (time-subtract res (* r 60)))))))
(defun org-today ()
"Return today date, considering `org-extend-today-until'."
(time-to-days
- (time-subtract (current-time)
- (list 0 (* 3600 org-extend-today-until) 0))))
+ (time-since (* 3600 org-extend-today-until))))
;;;; Font-Lock stuff, including the activators
@@ -9740,9 +9741,7 @@ active region."
(setq link
(format-time-string
(car org-time-stamp-formats)
- (apply 'encode-time
- (list 0 0 0 (nth 1 cd) (nth 0 cd) (nth 2 cd)
- nil nil nil))))
+ (encode-time 0 0 0 (nth 1 cd) (nth 0 cd) (nth 2 cd))))
(org-store-link-props :type "calendar" :date cd)))
((eq major-mode 'help-mode)
@@ -10056,7 +10055,7 @@ Note: this function also decodes single byte encodings like
(cons 6 128))))
(when (>= val 192) (setq eat (car shift-xor)))
(setq val (logxor val (cdr shift-xor)))
- (setq sum (+ (lsh sum (car shift-xor)) val))
+ (setq sum (+ (ash sum (car shift-xor)) val))
(when (> eat 0) (setq eat (- eat 1)))
(cond
((= 0 eat) ;multi byte
@@ -10468,7 +10467,7 @@ This is still an experimental function, your mileage may vary."
((and (equal type "lisp") (string-match "^/" path))
;; Planner has a slash, we do not.
(setq type "elisp" path (substring path 1)))
- ((string-match "^//\\(.?*\\)/\\(<.*>\\)$" path)
+ ((string-match "^//\\(.*\\)/\\(<.*>\\)$" path)
;; A typical message link. Planner has the id after the final slash,
;; we separate it with a hash mark
(setq path (concat (match-string 1 path) "#"
@@ -11879,7 +11878,8 @@ prefix argument (`C-u C-u C-u C-c C-w')."
(when (featurep 'org-inlinetask)
(org-inlinetask-remove-END-maybe))
(setq org-markers-to-move nil)
- (message (concat actionmsg " to \"%s\" in file %s: done") (car it) file)))))))
+ (message "%s to \"%s\" in file %s: done" actionmsg
+ (car it) file)))))))
(defun org-refile-goto-last-stored ()
"Go to the location where the last refile was stored."
@@ -13110,8 +13110,7 @@ This function is run automatically after each state change to a DONE state."
(while (re-search-forward org-clock-line-re end t)
(when (org-at-clock-log-p) (throw :clock t))))))
(org-entry-put nil "LAST_REPEAT" (format-time-string
- (org-time-stamp-format t t)
- (current-time))))
+ (org-time-stamp-format t t))))
(when org-log-repeat
(if (or (memq 'org-add-log-note (default-value 'post-command-hook))
(memq 'org-add-log-note post-command-hook))
@@ -13170,7 +13169,7 @@ has been set"
(let ((nshiftmax 10)
(nshift 0))
(while (or (= nshift 0)
- (not (time-less-p (current-time) time)))
+ (not (time-less-p nil time)))
(when (= (cl-incf nshift) nshiftmax)
(or (y-or-n-p
(format "%d repeater intervals were not \
@@ -13341,7 +13340,7 @@ for calling org-schedule with, or if there is no scheduling,
returns nil."
(let ((time (org-entry-get pom "SCHEDULED" inherit)))
(when time
- (apply 'encode-time (org-parse-time-string time)))))
+ (org-time-string-to-time time))))
(defun org-get-deadline-time (pom &optional inherit)
"Get the deadline as a time tuple, of a format suitable for
@@ -13349,7 +13348,7 @@ calling org-deadline with, or if there is no scheduling, returns
nil."
(let ((time (org-entry-get pom "DEADLINE" inherit)))
(when time
- (apply 'encode-time (org-parse-time-string time)))))
+ (org-time-string-to-time time))))
(defun org-remove-timestamp-with-keyword (keyword)
"Remove all time stamps with KEYWORD in the current entry."
@@ -13408,7 +13407,7 @@ WHAT entry will also be removed."
org-deadline-time-regexp)
end t)
(setq ts (match-string 1)
- default-time (apply 'encode-time (org-parse-time-string ts))
+ default-time (org-time-string-to-time ts)
default-input (and ts (org-get-compact-tod ts)))))))
(when what
(setq time
@@ -14665,16 +14664,15 @@ it as a time string and apply `float-time' to it. If S is nil, just return 0."
((numberp s) s)
((stringp s)
(condition-case nil
- (float-time (apply #'encode-time (org-parse-time-string s)))
- (error 0.)))
- (t 0.)))
+ (float-time (org-time-string-to-time s))
+ (error 0)))
+ (t 0)))
(defun org-time-today ()
"Time in seconds today at 0:00.
Returns the float number of seconds since the beginning of the
epoch to the beginning of today (00:00)."
- (float-time (apply 'encode-time
- (append '(0 0 0) (nthcdr 3 (decode-time))))))
+ (float-time (apply #'encode-time 0 0 0 (nthcdr 3 (decode-time)))))
(defun org-matcher-time (s)
"Interpret a time comparison value."
@@ -14955,7 +14953,7 @@ When JUST-ALIGN is non-nil, only align tags."
(unless (equal tags "")
(let* ((level (save-excursion
(beginning-of-line)
- (skip-chars-forward "\\*")))
+ (skip-chars-forward "*")))
(offset (if (bound-and-true-p org-indent-mode)
(* (1- org-indent-indentation-per-level)
(1- level))
@@ -16569,22 +16567,20 @@ non-nil."
((org-at-timestamp-p 'lax) (match-string 0))))
;; Default time is either the timestamp at point or today.
;; When entering a range, only the range start is considered.
- (default-time (if (not ts) (current-time)
- (apply #'encode-time (org-parse-time-string ts))))
+ (default-time (and ts (org-time-string-to-time ts)))
(default-input (and ts (org-get-compact-tod ts)))
(repeater (and ts
(string-match "\\([.+-]+[0-9]+[hdwmy] ?\\)+" ts)
(match-string 0 ts)))
org-time-was-given
org-end-time-was-given
- (time
- (and (if (equal arg '(16)) (current-time)
+ (time (if (equal arg '(16)) (current-time)
;; Preserve `this-command' and `last-command'.
(let ((this-command this-command)
(last-command last-command))
(org-read-date
arg 'totime nil nil default-time default-input
- inactive))))))
+ inactive)))))
(cond
((and ts
(memq last-command '(org-time-stamp org-time-stamp-inactive))
@@ -16817,7 +16813,7 @@ user."
(when (< (nth 2 org-defdecode) org-extend-today-until)
(setf (nth 2 org-defdecode) -1)
(setf (nth 1 org-defdecode) 59)
- (setq org-def (apply #'encode-time org-defdecode))
+ (setq org-def (encode-time org-defdecode))
(setq org-defdecode (decode-time org-def)))
(let* ((timestr (format-time-string
(if org-with-time "%Y-%m-%d %H:%M" "%Y-%m-%d")
@@ -16890,13 +16886,14 @@ user."
"range representable on this machine"))
(ding))
- ;; One round trip to get rid of 34th of August and stuff like that....
- (setq final (decode-time (apply 'encode-time final)))
+ (setq final (apply #'encode-time final))
(setq org-read-date-final-answer ans)
(if to-time
- (apply 'encode-time final)
+ final
+ ;; This round-trip gets rid of 34th of August and stuff like that....
+ (setq final (decode-time final))
(if (and (boundp 'org-time-was-given) org-time-was-given)
(format "%04d-%02d-%02d %02d:%02d"
(nth 5 final) (nth 4 final) (nth 3 final)
@@ -16926,7 +16923,7 @@ user."
(and (boundp 'org-time-was-given) org-time-was-given))
(cdr fmts)
(car fmts)))
- (txt (format-time-string fmt (apply 'encode-time f)))
+ (txt (format-time-string fmt (apply #'encode-time f)))
(txt (if org-read-date-inactive (concat "[" (substring txt 1 -1) "]") txt))
(txt (concat "=> " txt)))
(when (and org-end-time-was-given
@@ -16957,7 +16954,7 @@ user."
(when (string-match "\\`[ \t]*\\.[ \t]*\\'" ans)
(setq ans "+0"))
- (when (setq delta (org-read-date-get-relative ans (current-time) org-def))
+ (when (setq delta (org-read-date-get-relative ans nil org-def))
(setq ans (replace-match "" t t ans)
deltan (car delta)
deltaw (nth 1 delta)
@@ -17114,7 +17111,7 @@ user."
; (when (and org-read-date-prefer-future
; (not iso-year)
; (< (calendar-absolute-from-gregorian iso-date)
- ; (time-to-days (current-time))))
+ ; (time-to-days nil)))
; (setq year (1+ year)
; iso-date (calendar-gregorian-from-absolute
; (calendar-iso-to-absolute
@@ -17293,7 +17290,7 @@ The command returns the inserted time stamp."
time (org-fix-decoded-time t1)
str (org-add-props
(format-time-string
- (substring tf 1 -1) (apply 'encode-time time))
+ (substring tf 1 -1) (encode-time time))
nil 'mouse-face 'highlight))
(put-text-property beg end 'display str)))
@@ -17308,7 +17305,7 @@ Don't touch the rest."
If SECONDS is non-nil, return the difference in seconds."
(let ((fdiff (if seconds #'float-time #'time-to-days)))
(- (funcall fdiff (org-time-string-to-time timestamp-string))
- (funcall fdiff (current-time)))))
+ (funcall fdiff nil))))
(defun org-deadline-close-p (timestamp-string &optional ndays)
"Is the time in TIMESTAMP-STRING close to the current date?"
@@ -17490,10 +17487,8 @@ days in order to avoid rounding problems."
(match-end (match-end 0))
(time1 (org-time-string-to-time ts1))
(time2 (org-time-string-to-time ts2))
- (t1 (float-time time1))
- (t2 (float-time time2))
- (diff (abs (- t2 t1)))
- (negative (< (- t2 t1) 0))
+ (diff (abs (float-time (time-subtract time2 time1))))
+ (negative (time-less-p time2 time1))
;; (ys (floor (* 365 24 60 60)))
(ds (* 24 60 60))
(hs (* 60 60))
@@ -17504,14 +17499,14 @@ days in order to avoid rounding problems."
(fh "%02d:%02d")
y d h m align)
(if havetime
- (setq ; y (floor (/ diff ys)) diff (mod diff ys)
+ (setq ; y (floor diff ys) diff (mod diff ys)
y 0
- d (floor (/ diff ds)) diff (mod diff ds)
- h (floor (/ diff hs)) diff (mod diff hs)
- m (floor (/ diff 60)))
- (setq ; y (floor (/ diff ys)) diff (mod diff ys)
+ d (floor diff ds) diff (mod diff ds)
+ h (floor diff hs) diff (mod diff hs)
+ m (floor diff 60))
+ (setq ; y (floor diff ys) diff (mod diff ys)
y 0
- d (floor (+ (/ diff ds) 0.5))
+ d (round diff ds)
h 0 m 0))
(if (not to-buffer)
(message "%s" (org-make-tdiff-string y d h m))
@@ -17550,7 +17545,7 @@ days in order to avoid rounding problems."
(defun org-time-string-to-time (s)
"Convert timestamp string S into internal time."
- (apply #'encode-time (org-parse-time-string s)))
+ (encode-time (org-parse-time-string s)))
(defun org-time-string-to-seconds (s)
"Convert a timestamp string S into a number of seconds."
@@ -17585,7 +17580,7 @@ signaled."
(daynr (org-closest-date s daynr prefer))
(t (time-to-days
(condition-case errdata
- (apply #'encode-time (org-parse-time-string s))
+ (org-time-string-to-time s)
(error (error "Bad timestamp `%s'%s\nError was: %s"
s
(if (not (and buffer pos)) ""
@@ -17602,7 +17597,7 @@ signaled."
YEAR is expanded into one of the 30 next years, if possible, or
into a past one. Any year larger than 99 is returned unchanged."
(if (>= year 100) year
- (let* ((current (string-to-number (format-time-string "%Y" (current-time))))
+ (let* ((current (string-to-number (format-time-string "%Y")))
(century (/ current 100))
(offset (- year (% current 100))))
(cond ((> offset 30) (+ (* (1- century) 100) year))
@@ -17683,12 +17678,12 @@ stamp stay unchanged. In any case, return value is an absolute
day number."
(if (not (string-match "\\+\\([0-9]+\\)\\([hdwmy]\\)" start))
;; No repeater. Do not shift time stamp.
- (time-to-days (apply #'encode-time (org-parse-time-string start)))
+ (time-to-days (org-time-string-to-time start))
(let ((value (string-to-number (match-string 1 start)))
(type (match-string 2 start)))
(if (= 0 value)
;; Repeater with a 0-value is considered as void.
- (time-to-days (apply #'encode-time (org-parse-time-string start)))
+ (time-to-days (org-time-string-to-time start))
(let* ((base (org-date-to-gregorian start))
(target (org-date-to-gregorian current))
(sday (calendar-absolute-from-gregorian base))
@@ -17793,7 +17788,7 @@ NODEFAULT, hour and minute fields will be nil if not given."
;; second argument. However, this requires at least Emacs
;; 25.1. We can do it when we switch to this version as our
;; minimal requirement.
- (decode-time (seconds-to-time (org-matcher-time s))))
+ (decode-time (encode-time (org-matcher-time s))))
(t (error "Not a standard Org time string: %s" s))))
(defun org-timestamp-up (&optional arg)
@@ -17997,7 +17992,7 @@ When SUPPRESS-TMP-DELAY is non-nil, suppress delays like \"--2d\"."
(setcar time0 (or (car time0) 0))
(setcar (nthcdr 1 time0) (or (nth 1 time0) 0))
(setcar (nthcdr 2 time0) (or (nth 2 time0) 0))
- (setq time (apply 'encode-time time0))))
+ (setq time (encode-time time0))))
;; Insert the new time-stamp, and ensure point stays in the same
;; category as before (i.e. not after the last position in that
;; category).
@@ -18122,7 +18117,7 @@ A prefix ARG can be used to force the current date."
diff)
(when (or (org-at-timestamp-p 'lax)
(org-match-line (concat ".*" org-ts-regexp)))
- (let ((d1 (time-to-days (current-time)))
+ (let ((d1 (time-to-days nil))
(d2 (time-to-days (org-time-string-to-time (match-string 1)))))
(setq diff (- d2 d1))))
(calendar)
@@ -19324,6 +19319,9 @@ INCLUDE-LINKED is passed to `org-display-inline-images'."
(org-toggle-inline-images)
(org-toggle-inline-images)))
+;; For without-x builds.
+(declare-function image-refresh "image" (spec &optional frame))
+
(defun org-display-inline-images (&optional include-linked refresh beg end)
"Display inline images.
@@ -20617,7 +20615,7 @@ this numeric value."
(unless inc (setq inc 1))
(let ((pos (point))
(beg (skip-chars-backward "-+^/*0-9eE."))
- (end (skip-chars-forward "-+^/*0-9eE^.")) nap)
+ (end (skip-chars-forward "-+^/*0-9eE.")) nap)
(setq nap (buffer-substring-no-properties
(+ pos beg) (+ pos beg end)))
(delete-region (+ pos beg) (+ pos beg end))
@@ -22376,7 +22374,9 @@ returned by, e.g., `current-time'."
;; (e.g. HFS+) do not retain any finer granularity. As
;; a consequence, make sure we return non-nil when the two
;; times are equal.
- (not (time-less-p (cl-subseq (nth 5 (file-attributes file)) 0 2)
+ (not (time-less-p (cl-subseq (file-attribute-modification-time
+ (file-attributes file))
+ 0 2)
(cl-subseq time 0 2)))))
(defun org-compile-file (source process ext &optional err-msg log-buf spec)
@@ -22837,9 +22837,9 @@ assumed to be significant there."
(defun org-fill-line-break-nobreak-p ()
"Non-nil when a new line at point would create an Org line break."
(save-excursion
- (skip-chars-backward "[ \t]")
+ (skip-chars-backward " \t")
(skip-chars-backward "\\\\")
- (looking-at "\\\\\\\\\\($\\|[^\\\\]\\)")))
+ (looking-at "\\\\\\\\\\($\\|[^\\]\\)")))
(defun org-fill-paragraph-with-timestamp-nobreak-p ()
"Non-nil when a new line at point would split a timestamp."
@@ -22922,7 +22922,7 @@ matches in paragraphs or comments, use it."
(match-string 0)
"")))))))))))
-(declare-function message-goto-body "message" ())
+(declare-function message-goto-body "message" (&optional interactive))
(defvar message-cite-prefix-regexp) ; From message.el
(defun org-fill-element (&optional justify)
@@ -23381,13 +23381,12 @@ strictly within a source block, use appropriate comment syntax."
(defun org-timestamp--to-internal-time (timestamp &optional end)
"Encode TIMESTAMP object into Emacs internal time.
Use end of date range or time range when END is non-nil."
- (apply #'encode-time
- (cons 0
- (mapcar
- (lambda (prop) (or (org-element-property prop timestamp) 0))
- (if end '(:minute-end :hour-end :day-end :month-end :year-end)
- '(:minute-start :hour-start :day-start :month-start
- :year-start))))))
+ (apply #'encode-time 0
+ (mapcar
+ (lambda (prop) (or (org-element-property prop timestamp) 0))
+ (if end '(:minute-end :hour-end :day-end :month-end :year-end)
+ '(:minute-start :hour-start :day-start :month-start
+ :year-start)))))
(defun org-timestamp-has-time-p (timestamp)
"Non-nil when TIMESTAMP has a time specified."
diff --git a/lisp/org/ox-ascii.el b/lisp/org/ox-ascii.el
index c20536184ea..7c9920f64c5 100644
--- a/lisp/org/ox-ascii.el
+++ b/lisp/org/ox-ascii.el
@@ -1474,8 +1474,8 @@ contextual information."
(replace-regexp-in-string
"-" "•"
(replace-regexp-in-string
- "+" "⁃"
- (replace-regexp-in-string "*" "‣" bul))))))))
+ "\\+" "⁃"
+ (replace-regexp-in-string "\\*" "‣" bul))))))))
(indentation (if (eq list-type 'descriptive) org-ascii-quote-margin
(string-width bullet))))
(concat
diff --git a/lisp/org/ox-html.el b/lisp/org/ox-html.el
index b547c2181a5..1f98fcdd5cf 100644
--- a/lisp/org/ox-html.el
+++ b/lisp/org/ox-html.el
@@ -1935,7 +1935,8 @@ INFO is a plist used as a communication channel."
(?c . ,(plist-get info :creator))
(?C . ,(let ((file (plist-get info :input-file)))
(format-time-string timestamp-format
- (and file (nth 5 (file-attributes file))))))
+ (and file (file-attribute-modification-time
+ (file-attributes file))))))
(?v . ,(or (plist-get info :html-validation-link) "")))))
(defun org-html--build-pre/postamble (type info)
diff --git a/lisp/org/ox-latex.el b/lisp/org/ox-latex.el
index d3e62861499..d711530bf71 100644
--- a/lisp/org/ox-latex.el
+++ b/lisp/org/ox-latex.el
@@ -1613,7 +1613,7 @@ INFO is a plist used as a communication channel."
(defun org-latex-clean-invalid-line-breaks (data _backend _info)
(replace-regexp-in-string
- "\\(\\end{[A-Za-z0-9*]+}\\|^\\)[ \t]*\\\\\\\\[ \t]*$" "\\1"
+ "\\(\\\\end{[A-Za-z0-9*]+}\\|^\\)[ \t]*\\\\\\\\[ \t]*$" "\\1"
data))
diff --git a/lisp/org/ox-odt.el b/lisp/org/ox-odt.el
index 71fd02541a7..8deb6bd51ab 100644
--- a/lisp/org/ox-odt.el
+++ b/lisp/org/ox-odt.el
@@ -2192,6 +2192,10 @@ SHORT-CAPTION are strings."
(org-odt-create-manifest-file-entry media-type target-file)
target-file))
+;; For --without-x builds.
+(declare-function clear-image-cache "image.c" (&optional filter))
+(declare-function image-size "image.c" (spec &optional pixels frame))
+
(defun org-odt--image-size
(file info &optional user-width user-height scale dpi embed-as)
(let* ((--pixels-to-cms
diff --git a/lisp/org/ox-publish.el b/lisp/org/ox-publish.el
index 9af50fdac44..74312bc20f8 100644
--- a/lisp/org/ox-publish.el
+++ b/lisp/org/ox-publish.el
@@ -793,13 +793,11 @@ Default for SITEMAP-FILENAME is `sitemap.org'."
(not (string-lessp B A))))))
((or `anti-chronologically `chronologically)
(let* ((adate (org-publish-find-date a project))
- (bdate (org-publish-find-date b project))
- (A (+ (lsh (car adate) 16) (cadr adate)))
- (B (+ (lsh (car bdate) 16) (cadr bdate))))
+ (bdate (org-publish-find-date b project)))
(setq retval
- (if (eq sort-files 'chronologically)
- (<= A B)
- (>= A B)))))
+ (not (if (eq sort-files 'chronologically)
+ (time-less-p bdate adate)
+ (time-less-p adate bdate))))))
(`nil nil)
(_ (user-error "Invalid sort value %s" sort-files)))
;; Directory-wise wins:
@@ -879,7 +877,8 @@ If FILE is an Org file and provides a DATE keyword use it. In
any other case use the file system's modification time. Return
time in `current-time' format."
(let ((file (org-publish--expand-file-name file project)))
- (if (file-directory-p file) (nth 5 (file-attributes file))
+ (if (file-directory-p file) (file-attribute-modification-time
+ (file-attributes file))
(let ((date (org-publish-find-property file :date project)))
;; DATE is a secondary string. If it contains a time-stamp,
;; convert it to internal format. Otherwise, use FILE
@@ -889,7 +888,8 @@ time in `current-time' format."
(let ((value (org-element-interpret-data ts)))
(and (org-string-nw-p value)
(org-time-string-to-time value))))))
- ((file-exists-p file) (nth 5 (file-attributes file)))
+ ((file-exists-p file) (file-attribute-modification-time
+ (file-attributes file)))
(t (error "No such file: \"%s\"" file)))))))
(defun org-publish-sitemap-default-entry (entry style project)
@@ -1348,8 +1348,7 @@ does not exist."
(expand-file-name (or (file-symlink-p file) file)
(file-name-directory file)))))
(if (not attr) (error "No such file: \"%s\"" file)
- (+ (lsh (car (nth 5 attr)) 16)
- (cadr (nth 5 attr))))))
+ (encode-time (file-attribute-modification-time attr) 'integer))))
(provide 'ox-publish)
diff --git a/lisp/org/ox.el b/lisp/org/ox.el
index 6c278a1b7cf..58bc9b0ffb0 100644
--- a/lisp/org/ox.el
+++ b/lisp/org/ox.el
@@ -3252,7 +3252,7 @@ locally for the subtree through node properties."
(let ((val (cond ((equal (car key) "DATE")
(or (cdr key)
(with-temp-buffer
- (org-insert-time-stamp (current-time)))))
+ (org-insert-time-stamp nil))))
((equal (car key) "TITLE")
(or (let ((visited-file
(buffer-file-name (buffer-base-buffer))))
@@ -3322,7 +3322,7 @@ storing and resolving footnotes. It is created automatically."
(setq value (replace-match "" nil nil value)))))
(lines
(and (string-match
- ":lines +\"\\(\\(?:[0-9]+\\)?-\\(?:[0-9]+\\)?\\)\""
+ ":lines +\"\\([0-9]*-[0-9]*\\)\""
value)
(prog1 (match-string 1 value)
(setq value (replace-match "" nil nil value)))))
diff --git a/lisp/outline.el b/lisp/outline.el
index 0174dcb8e36..74df77b8be7 100644
--- a/lisp/outline.el
+++ b/lisp/outline.el
@@ -299,9 +299,6 @@ After that, changing the prefix key requires manipulating keymaps."
;;;###autoload
(define-minor-mode outline-minor-mode
"Toggle Outline minor mode.
-With a prefix argument ARG, enable Outline minor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
See the command `outline-mode' for more information on this mode."
nil " Outl" (list (cons [menu-bar] outline-minor-mode-menu-bar-map)
@@ -1100,28 +1097,26 @@ convenient way to make a table of contents of the buffer."
(save-restriction
(narrow-to-region beg end)
(goto-char (point-min))
- (let ((buffer (current-buffer))
- start end)
- (with-temp-buffer
- (with-current-buffer buffer
- ;; Boundary condition: starting on heading:
- (when (outline-on-heading-p)
- (outline-back-to-heading)
- (setq start (point)
- end (progn (outline-end-of-heading)
- (point)))
- (insert-buffer-substring buffer start end)
- (insert "\n\n")))
- (let ((temp-buffer (current-buffer)))
- (with-current-buffer buffer
- (while (outline-next-heading)
- (unless (outline-invisible-p)
- (setq start (point)
- end (progn (outline-end-of-heading) (point)))
- (with-current-buffer temp-buffer
- (insert-buffer-substring buffer start end)
- (insert "\n\n"))))))
- (kill-new (buffer-string)))))))
+ (let ((buffer (current-buffer)) start end)
+ (with-temp-buffer
+ (let ((temp-buffer (current-buffer)))
+ (with-current-buffer buffer
+ ;; Boundary condition: starting on heading:
+ (when (outline-on-heading-p)
+ (outline-back-to-heading)
+ (setq start (point)
+ end (progn (outline-end-of-heading) (point)))
+ (with-current-buffer temp-buffer
+ (insert-buffer-substring buffer start end)
+ (insert "\n\n")))
+ (while (outline-next-heading)
+ (unless (outline-invisible-p)
+ (setq start (point)
+ end (progn (outline-end-of-heading) (point)))
+ (with-current-buffer temp-buffer
+ (insert-buffer-substring buffer start end)
+ (insert "\n\n"))))))
+ (kill-new (buffer-string)))))))
(provide 'outline)
(provide 'noutline)
diff --git a/lisp/paren.el b/lisp/paren.el
index b47bb033e20..13908d46eef 100644
--- a/lisp/paren.el
+++ b/lisp/paren.el
@@ -100,9 +100,6 @@ its position."
;;;###autoload
(define-minor-mode show-paren-mode
"Toggle visualization of matching parens (Show Paren mode).
-With a prefix argument ARG, enable Show Paren mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Show Paren mode is a global minor mode. When enabled, any
matching parenthesis is highlighted in `show-paren-style' after
diff --git a/lisp/pcmpl-cvs.el b/lisp/pcmpl-cvs.el
index 4424af5c3d6..c90e00f8909 100644
--- a/lisp/pcmpl-cvs.el
+++ b/lisp/pcmpl-cvs.el
@@ -122,7 +122,7 @@
(let (cmds)
(while (re-search-forward "^\\s-+\\([a-z]+\\)" nil t)
(setq cmds (cons (match-string 1) cmds)))
- (pcomplete-uniqify-list cmds))))
+ (pcomplete-uniquify-list cmds))))
(defun pcmpl-cvs-modules ()
"Return a list of available modules under CVS."
@@ -132,7 +132,7 @@
(let (entries)
(while (re-search-forward "\\(\\S-+\\)$" nil t)
(setq entries (cons (match-string 1) entries)))
- (pcomplete-uniqify-list entries))))
+ (pcomplete-uniquify-list entries))))
(defun pcmpl-cvs-tags (&optional opers)
"Return all the tags which could apply to the files related to OPERS."
@@ -149,7 +149,7 @@
(error "Error in output from `cvs status -v'"))
(setq tags (cons (match-string 1) tags))
(forward-line))))
- (pcomplete-uniqify-list tags)))
+ (pcomplete-uniquify-list tags)))
(defun pcmpl-cvs-entries (&optional opers)
"Return the Entries for the current directory.
@@ -187,6 +187,6 @@ operation character applies, as displayed by `cvs -n update'."
(setq entries (cons text entries))))
(forward-line)))))
(setq pcomplete-stub nondir)
- (pcomplete-uniqify-list entries)))
+ (pcomplete-uniquify-list entries)))
;;; pcmpl-cvs.el ends here
diff --git a/lisp/pcmpl-gnu.el b/lisp/pcmpl-gnu.el
index 4e921ceeb59..d9caf35577d 100644
--- a/lisp/pcmpl-gnu.el
+++ b/lisp/pcmpl-gnu.el
@@ -125,7 +125,7 @@
(while (re-search-forward
(concat "^\\s-*\\([^\n#%.$][^:=\n]*\\)\\s-*:[^=]") nil t)
(setq rules (append (split-string (match-string 1)) rules))))
- (pcomplete-uniqify-list rules))))
+ (pcomplete-uniquify-list rules))))
(defcustom pcmpl-gnu-tarfile-regexp
"\\.t\\(ar\\(\\.\\(gz\\|bz2\\|Z\\|xz\\)\\)?\\|gz\\|a[zZ]\\|z2\\)\\'"
@@ -316,7 +316,7 @@
(while (pcomplete-here
(if (and complete-within
(let* ((fa (file-attributes (pcomplete-arg 1)))
- (size (nth 7 fa)))
+ (size (file-attribute-size fa)))
(and (numberp size)
(or (null large-file-warning-threshold)
(< size large-file-warning-threshold)))))
diff --git a/lisp/pcmpl-linux.el b/lisp/pcmpl-linux.el
index f7d03d202d1..9121e78261e 100644
--- a/lisp/pcmpl-linux.el
+++ b/lisp/pcmpl-linux.el
@@ -43,7 +43,7 @@
"Completion for GNU/Linux `kill', using /proc filesystem."
(if (pcomplete-match "^-\\(.*\\)" 0)
(pcomplete-here
- (pcomplete-uniqify-list
+ (pcomplete-uniquify-list
(split-string
(pcomplete-process-result "kill" "-l")))
(pcomplete-match-string 1 0)))
@@ -82,7 +82,7 @@
(args (split-string line " ")))
(setq points (cons (nth 1 args) points)))
(forward-line)))
- (pcomplete-uniqify-list points))))
+ (pcomplete-uniquify-list points))))
(defun pcomplete-pare-list (l r)
"Destructively remove from list L all elements matching any in list R.
@@ -109,7 +109,7 @@ Test is done using `equal'."
(setq points (cons (nth 1 args) points)))
(forward-line)))
(pcomplete-pare-list
- (pcomplete-uniqify-list points)
+ (pcomplete-uniquify-list points)
(cons "swap" (pcmpl-linux-mounted-directories))))))
;;; pcmpl-linux.el ends here
diff --git a/lisp/pcmpl-rpm.el b/lisp/pcmpl-rpm.el
index 33525682405..213eac76e38 100644
--- a/lisp/pcmpl-rpm.el
+++ b/lisp/pcmpl-rpm.el
@@ -71,7 +71,8 @@
"Return a list of all installed rpm packages."
(if (and pcmpl-rpm-cache
pcmpl-rpm-cache-time
- (let ((mtime (nth 5 (file-attributes pcmpl-rpm-cache-stamp-file))))
+ (let ((mtime (file-attribute-modification-time
+ (file-attributes pcmpl-rpm-cache-stamp-file))))
(and mtime (not (time-less-p pcmpl-rpm-cache-time mtime)))))
pcmpl-rpm-packages
(message "Getting list of installed rpms...")
@@ -96,7 +97,7 @@
(pcomplete-process-result
"rpm" "-q" (car pkgs) flag)))
(setq pkgs (cdr pkgs)))
- (pcomplete-uniqify-list (cdr provs))))
+ (pcomplete-uniquify-list (cdr provs))))
(defsubst pcmpl-rpm-files ()
(pcomplete-dirs-or-entries "\\.rpm\\'"))
diff --git a/lisp/pcmpl-unix.el b/lisp/pcmpl-unix.el
index 68203d20bf5..fa42809c592 100644
--- a/lisp/pcmpl-unix.el
+++ b/lisp/pcmpl-unix.el
@@ -111,7 +111,7 @@ documentation), this function returns nil."
(point))) ":")))
(setq names (cons (nth 0 fields) names)))
(forward-line))))
- (pcomplete-uniqify-list names)))
+ (pcomplete-uniquify-list names)))
(defsubst pcmpl-unix-group-names ()
"Read the contents of /etc/group for group names."
diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el
index c5307de92e8..e0800749273 100644
--- a/lisp/pcomplete.el
+++ b/lisp/pcomplete.el
@@ -272,6 +272,39 @@ to all arguments, such as variable names after a $."
"Complete amongst a list of directories and executables."
(pcomplete-entries regexp 'file-executable-p))
+(defmacro pcomplete-here (&optional form stub paring form-only)
+ "Complete against the current argument, if at the end.
+If completion is to be done here, evaluate FORM to generate the completion
+table which will be used for completion purposes. If STUB is a
+string, use it as the completion stub instead of the default (which is
+the entire text of the current argument).
+
+For an example of when you might want to use STUB: if the current
+argument text is `long-path-name/', you don't want the completions
+list display to be cluttered by `long-path-name/' appearing at the
+beginning of every alternative. Not only does this make things less
+intelligible, but it is also inefficient. Yet, if the completion list
+does not begin with this string for every entry, the current argument
+won't complete correctly.
+
+The solution is to specify a relative stub. It allows you to
+substitute a different argument from the current argument, almost
+always for the sake of efficiency.
+
+If PARING is nil, this argument will be pared against previous
+arguments using the function `file-truename' to normalize them.
+PARING may be a function, in which case that function is used for
+normalization. If PARING is t, the argument dealt with by this
+call will not participate in argument paring. If it is the
+integer 0, all previous arguments that have been seen will be
+cleared.
+
+If FORM-ONLY is non-nil, only the result of FORM will be used to
+generate the completions list. This means that the hook
+`pcomplete-try-first-hook' will not be run."
+ (declare (debug t))
+ `(pcomplete--here (lambda () ,form) ,stub ,paring ,form-only))
+
(defcustom pcomplete-command-completion-function
(function
(lambda ()
@@ -411,10 +444,28 @@ Same as `pcomplete' but using the standard completion UI."
;; table which expects strings using a prefix from the
;; buffer's text but internally uses the corresponding
;; prefix from pcomplete-stub.
+ ;;
+ (argbeg (pcomplete-begin))
+ ;; When completing an envvar within an argument in Eshell
+ ;; (e.g. "cd /home/$US TAB"), `pcomplete-stub' will just be
+ ;; "US" whereas `argbeg' will point to the first "/".
+ ;; We could rely on c-t-subvert to handle the difference,
+ ;; but we try here to guess the "real" beginning so as to
+ ;; rely less on c-t-subvert.
(beg (max (- (point) (length pcomplete-stub))
- (pcomplete-begin)))
- (buftext (pcomplete-unquote-argument
- (buffer-substring beg (point)))))
+ argbeg))
+ buftext)
+ ;; Try and improve our guess of `beg' in case the difference
+ ;; between pcomplete-stub and the buffer's text is simply due to
+ ;; some chars removed by unquoting. Again, this is not
+ ;; indispensable but reduces the reliance on c-t-subvert and
+ ;; improves corner case behaviors.
+ (while (progn (setq buftext (pcomplete-unquote-argument
+ (buffer-substring beg (point))))
+ (and (> beg argbeg)
+ (> (length pcomplete-stub) (length buftext))))
+ (setq beg (max argbeg (- beg (- (length pcomplete-stub)
+ (length buftext))))))
(when completions
(let ((table
(completion-table-with-quoting
@@ -735,7 +786,7 @@ this is `comint-dynamic-complete-functions'."
(push (point) begins)
(while
(progn
- (skip-chars-forward "^ \t\n\\")
+ (skip-chars-forward "^ \t\n\\\\")
(when (eq (char-after) ?\\)
(forward-char 1)
(unless (eolp)
@@ -950,7 +1001,7 @@ Arguments NO-GANGING and ARGS-FOLLOW are currently ignored."
(function
(lambda (opt)
(concat "-" opt)))
- (pcomplete-uniqify-list choices))))
+ (pcomplete-uniquify-list choices))))
(let ((arg (pcomplete-arg)))
(when (and (> (length arg) 1)
(stringp arg)
@@ -1014,39 +1065,6 @@ See the documentation for `pcomplete-here'."
;; byte-compiled with the older code.
(eval form)))))
-(defmacro pcomplete-here (&optional form stub paring form-only)
- "Complete against the current argument, if at the end.
-If completion is to be done here, evaluate FORM to generate the completion
-table which will be used for completion purposes. If STUB is a
-string, use it as the completion stub instead of the default (which is
-the entire text of the current argument).
-
-For an example of when you might want to use STUB: if the current
-argument text is `long-path-name/', you don't want the completions
-list display to be cluttered by `long-path-name/' appearing at the
-beginning of every alternative. Not only does this make things less
-intelligible, but it is also inefficient. Yet, if the completion list
-does not begin with this string for every entry, the current argument
-won't complete correctly.
-
-The solution is to specify a relative stub. It allows you to
-substitute a different argument from the current argument, almost
-always for the sake of efficiency.
-
-If PARING is nil, this argument will be pared against previous
-arguments using the function `file-truename' to normalize them.
-PARING may be a function, in which case that function is used for
-normalization. If PARING is t, the argument dealt with by this
-call will not participate in argument paring. If it is the
-integer 0, all previous arguments that have been seen will be
-cleared.
-
-If FORM-ONLY is non-nil, only the result of FORM will be used to
-generate the completions list. This means that the hook
-`pcomplete-try-first-hook' will not be run."
- (declare (debug t))
- `(pcomplete--here (lambda () ,form) ,stub ,paring ,form-only))
-
(defmacro pcomplete-here* (&optional form stub form-only)
"An alternate form which does not participate in argument paring."
@@ -1269,7 +1287,7 @@ If specific documentation can't be given, be generic."
;; general utilities
-(defun pcomplete-uniqify-list (l)
+(defun pcomplete-uniquify-list (l)
"Sort and remove multiples in L."
(setq l (sort l 'string-lessp))
(let ((m l))
@@ -1280,6 +1298,9 @@ If specific documentation can't be given, be generic."
(setcdr m (cddr m)))
(setq m (cdr m))))
l)
+(define-obsolete-function-alias
+ 'pcomplete-uniqify-list
+ 'pcomplete-uniquify-list "27.1")
(defun pcomplete-process-result (cmd &rest args)
"Call CMD using `call-process' and return the simplest result."
diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el
index 54d45b39890..dfd9a5ad5b3 100644
--- a/lisp/pixel-scroll.el
+++ b/lisp/pixel-scroll.el
@@ -97,18 +97,16 @@ When scrolling request is delivered soon after the previous one,
user is in hurry. When the time since last scroll is larger than
`pixel-dead-time', we are ready for another smooth scroll, and this
function returns nil."
- (let* ((current-time (float-time))
- (scroll-in-rush-p (< (- current-time pixel-last-scroll-time)
- pixel-dead-time)))
- (setq pixel-last-scroll-time current-time)
+ (let* ((now (current-time))
+ (scroll-in-rush-p (time-less-p
+ (time-subtract now pixel-last-scroll-time)
+ pixel-dead-time)))
+ (setq pixel-last-scroll-time (float-time now))
scroll-in-rush-p))
;;;###autoload
(define-minor-mode pixel-scroll-mode
- "A minor mode to scroll text pixel-by-pixel.
-With a prefix argument ARG, enable Pixel Scroll mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable Pixel Scroll mode
-if ARG is omitted or nil."
+ "A minor mode to scroll text pixel-by-pixel."
:init-value nil
:group 'scrolling
:global t
diff --git a/lisp/play/bubbles.el b/lisp/play/bubbles.el
index 8d161775ffd..239fbe4e07c 100644
--- a/lisp/play/bubbles.el
+++ b/lisp/play/bubbles.el
@@ -1,4 +1,4 @@
-;;; bubbles.el --- Puzzle game for Emacs
+;;; bubbles.el --- Puzzle game for Emacs -*- lexical-binding:t -*-
;; Copyright (C) 2007-2019 Free Software Foundation, Inc.
@@ -144,8 +144,7 @@ images the `ascii' theme will be used."
(const :tag "Diamonds" diamonds)
(const :tag "Balls" balls)
(const :tag "Emacs" emacs)
- (const :tag "ASCII (no images)" ascii))
- :group 'bubbles)
+ (const :tag "ASCII (no images)" ascii)))
(defconst bubbles--grid-small '(10 . 10)
"Predefined small bubbles grid.")
@@ -168,8 +167,7 @@ images the `ascii' theme will be used."
(const :tag "Huge" ,bubbles--grid-huge)
(cons :tag "User defined"
(integer :tag "Width")
- (integer :tag "Height")))
- :group 'bubbles)
+ (integer :tag "Height"))))
(defconst bubbles--colors-2 '("orange" "violet")
"Predefined bubbles color list with two colors.")
@@ -194,16 +192,14 @@ types are present."
(const :tag "Red, darkgreen, blue, orange" ,bubbles--colors-4)
(const :tag "Red, darkgreen, blue, orange, violet"
,bubbles--colors-5)
- (repeat :tag "User defined" color))
- :group 'bubbles)
+ (repeat :tag "User defined" color)))
(defcustom bubbles-chars
'(?+ ?O ?# ?X ?. ?* ?& ?§)
"Characters used for bubbles.
Note that the actual number of different bubbles is determined by
the number of colors, see `bubbles-colors'."
- :type '(repeat character)
- :group 'bubbles)
+ :type '(repeat character))
(defcustom bubbles-shift-mode
'default
@@ -212,12 +208,10 @@ Available modes are `shift-default' and `shift-always'."
:type '(radio (const :tag "Default" default)
(const :tag "Shifter" always)
;;(const :tag "Mega Shifter" mega)
- )
- :group 'bubbles)
+ ))
(defcustom bubbles-mode-hook nil
"Hook run by Bubbles mode."
- :group 'bubbles
:type 'hook)
(defun bubbles-customize ()
@@ -718,57 +712,57 @@ static char * dot3d_xpm[] = {
(defsubst bubbles--grid-width ()
"Return the grid width for the current game theme."
(car (pcase bubbles-game-theme
- (`easy
+ ('easy
bubbles--grid-small)
- (`medium
+ ('medium
bubbles--grid-medium)
- (`difficult
+ ('difficult
bubbles--grid-large)
- (`hard
+ ('hard
bubbles--grid-huge)
- (`user-defined
+ ('user-defined
bubbles-grid-size))))
(defsubst bubbles--grid-height ()
"Return the grid height for the current game theme."
(cdr (pcase bubbles-game-theme
- (`easy
+ ('easy
bubbles--grid-small)
- (`medium
+ ('medium
bubbles--grid-medium)
- (`difficult
+ ('difficult
bubbles--grid-large)
- (`hard
+ ('hard
bubbles--grid-huge)
- (`user-defined
+ ('user-defined
bubbles-grid-size))))
(defsubst bubbles--colors ()
"Return the color list for the current game theme."
(pcase bubbles-game-theme
- (`easy
+ ('easy
bubbles--colors-2)
- (`medium
+ ('medium
bubbles--colors-3)
- (`difficult
+ ('difficult
bubbles--colors-4)
- (`hard
+ ('hard
bubbles--colors-5)
- (`user-defined
+ ('user-defined
bubbles-colors)))
(defsubst bubbles--shift-mode ()
"Return the shift mode for the current game theme."
(pcase bubbles-game-theme
- (`easy
+ ('easy
'default)
- (`medium
+ ('medium
'default)
- (`difficult
+ ('difficult
'always)
- (`hard
+ ('hard
'always)
- (`user-defined
+ ('user-defined
bubbles-shift-mode)))
(defun bubbles-save-settings ()
@@ -898,7 +892,7 @@ static char * dot3d_xpm[] = {
;; bubbles mode map
(defvar bubbles-mode-map
(let ((map (make-sparse-keymap 'bubbles-mode-map)))
-;; (suppress-keymap map t)
+ ;; (suppress-keymap map t)
(define-key map "q" 'bubbles-quit)
(define-key map "\n" 'bubbles-plop)
(define-key map " " 'bubbles-plop)
@@ -925,7 +919,7 @@ static char * dot3d_xpm[] = {
(buffer-disable-undo)
(force-mode-line-update)
(redisplay)
- (add-hook 'post-command-hook 'bubbles--mark-neighborhood t t))
+ (add-hook 'post-command-hook #'bubbles--mark-neighborhood t t))
;;;###autoload
(defun bubbles ()
@@ -1004,14 +998,14 @@ Set `bubbles--col-offset' and `bubbles--row-offset'."
(list bubbles--row-offset))))
(insert "\n")
(let ((max-char (length (bubbles--colors))))
- (dotimes (i (bubbles--grid-height))
+ (dotimes (_ (bubbles--grid-height))
(let ((p (point)))
(insert " ")
(put-text-property p (point)
'display
(cons 'space (list :width
(list bubbles--col-offset)))))
- (dotimes (j (bubbles--grid-width))
+ (dotimes (_ (bubbles--grid-width))
(let* ((index (random max-char))
(char (nth index bubbles-chars)))
(insert char)
@@ -1268,7 +1262,7 @@ Use optional parameter POS instead of point if given."
(while (get-text-property (point) 'removed)
(setq shifted-cols (1+ shifted-cols))
(bubbles--shift 'right (1- (bubbles--grid-height)) j))
- (dotimes (k shifted-cols)
+ (dotimes (_ shifted-cols)
(let ((i (- (bubbles--grid-height) 2)))
(while (>= i 0)
(setq shifted (or (bubbles--shift 'right i j)
@@ -1334,11 +1328,11 @@ Return t if new char is non-empty."
(when (and (display-images-p)
(not (eq bubbles-graphics-theme 'ascii)))
(let ((template (pcase bubbles-graphics-theme
- (`circles bubbles--image-template-circle)
- (`balls bubbles--image-template-ball)
- (`squares bubbles--image-template-square)
- (`diamonds bubbles--image-template-diamond)
- (`emacs bubbles--image-template-emacs))))
+ ('circles bubbles--image-template-circle)
+ ('balls bubbles--image-template-ball)
+ ('squares bubbles--image-template-square)
+ ('diamonds bubbles--image-template-diamond)
+ ('emacs bubbles--image-template-emacs))))
(setq bubbles--empty-image
(create-image (replace-regexp-in-string
"^\"\\(.*\\)\t.*c .*\",$"
@@ -1422,8 +1416,8 @@ Return t if new char is non-empty."
(goto-char (point-min))
(forward-line 1)
(let ((inhibit-read-only t))
- (dotimes (i (bubbles--grid-height))
- (dotimes (j (bubbles--grid-width))
+ (dotimes (_ (bubbles--grid-height))
+ (dotimes (_ (bubbles--grid-width))
(forward-char 1)
(let ((index (or (get-text-property (point) 'index) -1)))
(let ((img bubbles--empty-image))
diff --git a/lisp/play/cookie1.el b/lisp/play/cookie1.el
index 165b86d037c..e461b37e362 100644
--- a/lisp/play/cookie1.el
+++ b/lisp/play/cookie1.el
@@ -125,7 +125,8 @@ and subsequent calls on the same file won't go to disk."
(setq phrase-file (cookie-check-file phrase-file))
(let ((sym (intern-soft phrase-file cookie-cache)))
(and sym (not (equal (symbol-function sym)
- (nth 5 (file-attributes phrase-file))))
+ (file-attribute-modification-time
+ (file-attributes phrase-file))))
(yes-or-no-p (concat phrase-file
" has changed. Read new contents? "))
(setq sym nil))
@@ -133,7 +134,8 @@ and subsequent calls on the same file won't go to disk."
(symbol-value sym)
(setq sym (intern phrase-file cookie-cache))
(if startmsg (message "%s" startmsg))
- (fset sym (nth 5 (file-attributes phrase-file)))
+ (fset sym (file-attribute-modification-time
+ (file-attributes phrase-file)))
(let (result)
(with-temp-buffer
(insert-file-contents (expand-file-name phrase-file))
diff --git a/lisp/play/dunnet.el b/lisp/play/dunnet.el
index 49e2b877d4d..0a9ab37d198 100644
--- a/lisp/play/dunnet.el
+++ b/lisp/play/dunnet.el
@@ -2349,7 +2349,6 @@ for a moment, then straighten yourself up.\n")
;;;; This section sets up the keymaps for interactive and batch dunnet.
;;;;
-(define-obsolete-variable-alias 'dungeon-mode-map 'dun-mode-map "22.1")
(define-key dun-mode-map "\r" 'dun-parse)
(defvar dungeon-batch-map (make-keymap))
(if (string= (substring emacs-version 0 2) "18")
diff --git a/lisp/play/fortune.el b/lisp/play/fortune.el
index 4488bb9c6ec..3c057f41497 100644
--- a/lisp/play/fortune.el
+++ b/lisp/play/fortune.el
@@ -313,6 +313,8 @@ Optional FILE is a fortune file from which a cookie will be selected."
(with-temp-buffer
(let ((fortune-buffer-name (current-buffer)))
(fortune-in-buffer t file)
+ ;; Avoid trailing newline.
+ (if (bolp) (delete-char -1))
(message "%s" (buffer-string)))))
;;;###autoload
diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el
index 7999194207b..4a9dac7f748 100644
--- a/lisp/play/gamegrid.el
+++ b/lisp/play/gamegrid.el
@@ -1,4 +1,4 @@
-;;; gamegrid.el --- library for implementing grid-based games on Emacs
+;;; gamegrid.el --- library for implementing grid-based games on Emacs -*- lexical-binding:t -*-
;; Copyright (C) 1997-1998, 2001-2019 Free Software Foundation, Inc.
@@ -86,49 +86,157 @@ directory will be used.")
(defvar gamegrid-mono-x-face nil)
(defvar gamegrid-mono-tty-face nil)
-;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar gamegrid-glyph-height-mm 7.0
+ "Desired glyph height in mm.")
-(defconst gamegrid-glyph-height 16)
+;; ;;;;;;;;;;;;; glyph generation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defconst gamegrid-xpm "\
+(defun gamegrid-calculate-glyph-size ()
+ "Calculate appropriate glyph size in pixels based on display resolution.
+Return a multiple of 8 no less than 16."
+ (if (and (display-pixel-height) (display-mm-height))
+ (let* ((y-pitch (/ (display-pixel-height) (float (display-mm-height))))
+ (pixels (* y-pitch gamegrid-glyph-height-mm))
+ (rounded (* (floor (/ (+ pixels 4) 8)) 8)))
+ (max 16 rounded))
+ 16))
+
+;; Example of glyph in XPM format:
+;;
+;; /* XPM */
+;; static char *noname[] = {
+;; /* width height ncolors chars_per_pixel */
+;; \"16 16 3 1\",
+;; /* colors */
+;; \"+ s col1\",
+;; \". s col2\",
+;; \"- s col3\",
+;; /* pixels */
+;; \"---------------+\",
+;; \"--------------++\",
+;; \"--............++\",
+;; \"--............++\",
+;; \"--............++\",
+;; \"--............++\",
+;; \"--............++\",
+;; \"--............++\",
+;; \"--............++\",
+;; \"--............++\",
+;; \"--............++\",
+;; \"--............++\",
+;; \"--............++\",
+;; \"--............++\",
+;; \"-+++++++++++++++\",
+;; \"++++++++++++++++\"
+;; };
+
+(defun gamegrid-xpm ()
+ "Generate the XPM format image used for each square."
+ (let* ((glyph-pixel-count (gamegrid-calculate-glyph-size))
+ (border-pixel-count (/ glyph-pixel-count 8))
+ (center-pixel-count (- glyph-pixel-count (* border-pixel-count 2))))
+ (with-temp-buffer
+ (insert (format "\
/* XPM */
static char *noname[] = {
/* width height ncolors chars_per_pixel */
-\"16 16 3 1\",
+\"%s %s 3 1\",
/* colors */
\"+ s col1\",
\". s col2\",
\"- s col3\",
/* pixels */
-\"---------------+\",
-\"--------------++\",
-\"--............++\",
-\"--............++\",
-\"--............++\",
-\"--............++\",
-\"--............++\",
-\"--............++\",
-\"--............++\",
-\"--............++\",
-\"--............++\",
-\"--............++\",
-\"--............++\",
-\"--............++\",
-\"-+++++++++++++++\",
-\"++++++++++++++++\"
-};
-"
- "XPM format image used for each square")
-
-(defvar gamegrid-xbm "\
+" glyph-pixel-count glyph-pixel-count))
+
+ (dotimes (row border-pixel-count)
+ (let ((edge-pixel-count (+ row 1)))
+ (insert "\"")
+ (dotimes (_ (- glyph-pixel-count edge-pixel-count)) (insert "-"))
+ (dotimes (_ edge-pixel-count) (insert "+"))
+ (insert "\",\n")))
+
+ (let ((middle (format "\"%s%s%s\",\n"
+ (make-string border-pixel-count ?-)
+ (make-string center-pixel-count ?.)
+ (make-string border-pixel-count ?+))))
+ (dotimes (_ center-pixel-count) (insert middle)))
+
+ (dotimes (row border-pixel-count)
+ (let ((edge-pixel-count (- border-pixel-count row 1)))
+ (insert "\"")
+ (dotimes (_ edge-pixel-count) (insert "-"))
+ (dotimes (_ (- glyph-pixel-count edge-pixel-count)) (insert "+"))
+ (insert "\"")
+ (if (/= row (1- border-pixel-count))
+ (insert ",\n")
+ (insert "\n};\n"))))
+ (buffer-string))))
+
+;; Example of glyph in XBM format:
+;;
+;; /* gamegrid XBM */
+;; #define gamegrid_width 16
+;; #define gamegrid_height 16
+;; static unsigned char gamegrid_bits[] = {
+;; 0xff, 0xff, 0xff, 0x7f, 0xff, 0x3f, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a,
+;; 0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a,
+;; 0x57, 0x15, 0x07, 0x00, 0x03, 0x00, 0x01, 0x00 };
+
+(defun gamegrid-xbm ()
+ "Generate XBM format image used for each square."
+ (let* ((glyph-pixel-count (gamegrid-calculate-glyph-size))
+ (border-pixel-count (1- (/ glyph-pixel-count 4)))
+ (center-pixel-count (- glyph-pixel-count (* 2 border-pixel-count))))
+ (with-temp-buffer
+ (insert (format "\
/* gamegrid XBM */
-#define gamegrid_width 16
-#define gamegrid_height 16
+#define gamegrid_width %s
+#define gamegrid_height %s
static unsigned char gamegrid_bits[] = {
- 0xff, 0xff, 0xff, 0x7f, 0xff, 0x3f, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a,
- 0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a,
- 0x57, 0x15, 0x07, 0x00, 0x03, 0x00, 0x01, 0x00 };"
- "XBM format image used for each square.")
+" glyph-pixel-count glyph-pixel-count))
+ (dotimes (row border-pixel-count)
+ (gamegrid-insert-xbm-bits
+ (concat (make-string (- glyph-pixel-count row) ?1)
+ (make-string row ?0)))
+ (insert ", \n"))
+
+ (let* ((left-border (make-string border-pixel-count ?1))
+ (right-border (make-string border-pixel-count ?0))
+ (even-line (apply 'concat
+ (append (list left-border)
+ (make-list (/ center-pixel-count 2) "10")
+ (list right-border))))
+ (odd-line (apply 'concat
+ (append (list left-border)
+ (make-list (/ center-pixel-count 2) "01")
+ (list right-border)))))
+ (dotimes (row center-pixel-count)
+ (gamegrid-insert-xbm-bits (if (eq (logand row 1) 1) odd-line even-line))
+ (insert ", \n")))
+
+ (dotimes (row border-pixel-count)
+ (let ((edge-pixel-count (- border-pixel-count row)))
+ (gamegrid-insert-xbm-bits
+ (concat (make-string edge-pixel-count ?1)
+ (make-string (- glyph-pixel-count edge-pixel-count) ?0))))
+ (if (/= row (1- border-pixel-count))
+ (insert ", \n")
+ (insert " };\n")))
+ (buffer-string))))
+
+(defun gamegrid-insert-xbm-bits (str)
+ "Convert binary to hex and insert in current buffer.
+STR should be a string composed of 1s and 0s and be a multiple of
+8 in length. Divide it into 8 bit bytes, reverse the order of
+each, convert them to hex and insert them in comma separated C
+format."
+ (let ((byte-count (/ (length str) 8)))
+ (dotimes (i byte-count)
+ (let* ((byte (reverse (substring str (* i 8) (+ (* i 8) 8))))
+ (value (string-to-number byte 2)))
+ (insert (format "0x%02x" value))
+ (unless (= i (1- byte-count))
+ (insert ", "))))))
;; ;;;;;;;;;;;;;;;; miscellaneous functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -210,31 +318,31 @@ static unsigned char gamegrid_bits[] = {
(let ((data (gamegrid-match-spec-list data-spec-list))
(color (gamegrid-match-spec-list color-spec-list)))
(pcase data
- (`color-x
+ ('color-x
(gamegrid-make-color-x-face color))
- (`grid-x
+ ('grid-x
(unless gamegrid-grid-x-face
(setq gamegrid-grid-x-face (gamegrid-make-grid-x-face)))
gamegrid-grid-x-face)
- (`mono-x
+ ('mono-x
(unless gamegrid-mono-x-face
(setq gamegrid-mono-x-face (gamegrid-make-mono-x-face)))
gamegrid-mono-x-face)
- (`color-tty
+ ('color-tty
(gamegrid-make-color-tty-face color))
- (`mono-tty
+ ('mono-tty
(unless gamegrid-mono-tty-face
(setq gamegrid-mono-tty-face (gamegrid-make-mono-tty-face)))
gamegrid-mono-tty-face))))
(defun gamegrid-colorize-glyph (color)
- (find-image `((:type xpm :data ,gamegrid-xpm
+ (find-image `((:type xpm :data ,(gamegrid-xpm)
:ascent center
:color-symbols
(("col1" . ,(gamegrid-color color 0.6))
("col2" . ,(gamegrid-color color 0.8))
("col3" . ,(gamegrid-color color 1.0))))
- (:type xbm :data ,gamegrid-xbm
+ (:type xbm :data ,(gamegrid-xbm)
:ascent center
:foreground ,(gamegrid-color color 1.0)
:background ,(gamegrid-color color 0.5)))))
@@ -376,7 +484,7 @@ static unsigned char gamegrid_bits[] = {
(buffer-read-only nil))
(erase-buffer)
(setq gamegrid-buffer-start (point))
- (dotimes (i height)
+ (dotimes (_ height)
(insert line))
;; Adjust the height of the default face to the height of the
;; images. Unlike XEmacs, Emacs doesn't allow making the default
@@ -449,7 +557,7 @@ On non-POSIX systems Emacs searches for FILE in the directory
specified by the variable `temporary-file-directory'. If necessary,
FILE is created there."
(pcase system-type
- ((or `ms-dos `windows-nt)
+ ((or 'ms-dos 'windows-nt)
(gamegrid-add-score-insecure file score))
(_
(gamegrid-add-score-with-update-game-score file score))))
@@ -457,8 +565,8 @@ FILE is created there."
;; On POSIX systems there are four cases to distinguish:
-;; 1. FILE is an absolute filename. Then it should be a file in
-;; temporary file directory. This is the way,
+;; 1. FILE is an absolute filename or "update-game-score" does not exist.
+;; Then FILE should be a file in a temporary file directory. This is how
;; `gamegrid-add-score' was supposed to be used in the past and
;; is covered here for backward-compatibility.
;;
@@ -475,21 +583,18 @@ FILE is created there."
;; update FILE. This is for the case that a user has installed
;; a game on her own.
;;
-;; 4. "update-game-score" does not exist or is not setgid/setuid.
-;; Create/update FILE in the user's home directory, without
-;; using "update-game-score". There is presumably no shared
-;; game directory.
+;; 4. "update-game-score" is not setgid/setuid. Use it to
+;; create/update FILE in the user's home directory. There is
+;; presumably no shared game directory.
(defvar gamegrid-shared-game-dir)
(defun gamegrid-add-score-with-update-game-score (file score)
- (let ((gamegrid-shared-game-dir
- (not (zerop (logand (or (file-modes
- (expand-file-name "update-game-score"
- exec-directory))
- 0)
- #o6000)))))
- (cond ((file-name-absolute-p file)
+ (let* ((update-game-score-modes
+ (file-modes (expand-file-name "update-game-score" exec-directory)))
+ (gamegrid-shared-game-dir
+ (not (zerop (logand #o6000 (or update-game-score-modes 0))))))
+ (cond ((or (not update-game-score-modes) (file-name-absolute-p file))
(gamegrid-add-score-insecure file score))
((and gamegrid-shared-game-dir
(file-exists-p (expand-file-name file shared-game-score-directory)))
@@ -499,12 +604,23 @@ FILE is created there."
(expand-file-name file shared-game-score-directory) score))
;; Else: Add the score to a score file in the user's home
;; directory.
- (t
+ (gamegrid-shared-game-dir
+ ;; If gamegrid-shared-game-dir is non-nil the
+ ;; "update-gamescore" program is setuid, so don't use it.
(unless (file-exists-p
(directory-file-name gamegrid-user-score-file-directory))
(make-directory gamegrid-user-score-file-directory t))
(gamegrid-add-score-insecure file score
- gamegrid-user-score-file-directory)))))
+ gamegrid-user-score-file-directory))
+ (t
+ (unless (file-exists-p
+ (directory-file-name gamegrid-user-score-file-directory))
+ (make-directory gamegrid-user-score-file-directory t))
+ (let ((f (expand-file-name file
+ gamegrid-user-score-file-directory)))
+ (unless (file-exists-p f)
+ (write-region "" nil f nil 'silent nil 'excl))
+ (gamegrid-add-score-with-update-game-score-1 file f score))))))
(defun gamegrid-add-score-with-update-game-score-1 (file target score)
(let ((default-directory "/")
diff --git a/lisp/play/gametree.el b/lisp/play/gametree.el
index d92914d9118..c0226c85ce1 100644
--- a/lisp/play/gametree.el
+++ b/lisp/play/gametree.el
@@ -586,8 +586,7 @@ shogi, etc.) players, it is a slightly modified version of Outline mode.
\\{gametree-mode-map}"
(auto-fill-mode 0)
- (make-local-variable 'write-contents-hooks)
- (add-hook 'write-contents-hooks 'gametree-save-and-hack-layout))
+ (add-hook 'write-contents-functions 'gametree-save-and-hack-layout nil t))
;;;; Goodies for mousing users
(defun gametree-mouse-break-line-here (event)
diff --git a/lisp/play/gomoku.el b/lisp/play/gomoku.el
index b16938a56d0..6d5553b3202 100644
--- a/lisp/play/gomoku.el
+++ b/lisp/play/gomoku.el
@@ -656,48 +656,48 @@ that DVAL has been added on SQUARE."
((eq result 'emacs-won)
(setq gomoku-number-of-emacs-wins (1+ gomoku-number-of-emacs-wins))
(cond ((< gomoku-number-of-moves 20)
- "This was a REALLY QUICK win.")
+ "I won... I hope you like the game as you get better.")
(gomoku-human-refused-draw
"I won... Too bad you refused my offer of a draw!")
(gomoku-human-took-back
- "I won... Taking moves back will not help you!")
+ "I won... It's OK to take back more moves next time.")
((not gomoku-emacs-played-first)
- "I won... Playing first did not help you much!")
+ "I won... Use C-c C-b to take back a move on second thought.")
((and (zerop gomoku-number-of-human-wins)
(zerop gomoku-number-of-draws)
(> gomoku-number-of-emacs-wins 1))
- "I'm becoming tired of winning...")
+ "I won... It might be time take a break before trying again.")
("I won.")))
((eq result 'human-won)
(setq gomoku-number-of-human-wins (1+ gomoku-number-of-human-wins))
(concat "OK, you won this one."
(cond
(gomoku-human-took-back
- " I, for one, never take my moves back...")
+ " For a bigger challenge, play without taking moves back.")
(gomoku-emacs-played-first
- ".. so what?")
- (" Now, let me play first just once."))))
+ " Congratulations!")
+ (" For a bigger challenge, let me play first."))))
((eq result 'human-resigned)
(setq gomoku-number-of-emacs-wins (1+ gomoku-number-of-emacs-wins))
- "So you resign. That's just one more win for me.")
+ "I see that you resigned. Better luck next time.")
((eq result 'nobody-won)
(setq gomoku-number-of-draws (1+ gomoku-number-of-draws))
(concat "This is a draw. "
(cond
(gomoku-human-took-back
- "I, for one, never take my moves back...")
+ " For a bigger challenge, try without taking moves back.")
(gomoku-emacs-played-first
- "Just chance, I guess.")
- ("Now, let me play first just once."))))
+ "Wow, that was a long game. We both played well.")
+ (" For a bigger challenge, let me play first."))))
((eq result 'draw-agreed)
(setq gomoku-number-of-draws (1+ gomoku-number-of-draws))
(concat "Draw agreed. "
(cond
(gomoku-human-took-back
- "I, for one, never take my moves back...")
+ " For a bigger challenge, try without taking moves back.")
(gomoku-emacs-played-first
- "You were lucky.")
- ("Now, let me play first just once."))))
+ "Good game.")
+ (" For a bigger challenge, let me play first."))))
((eq result 'crash-game)
"Sorry, I have been interrupted and cannot resume that game...")))
(gomoku-display-statistics)
diff --git a/lisp/play/hanoi.el b/lisp/play/hanoi.el
index 635e4a95bc3..d762290f0da 100644
--- a/lisp/play/hanoi.el
+++ b/lisp/play/hanoi.el
@@ -381,7 +381,7 @@ BITS must be of length nrings. Start at START-TIME."
(cl-loop for elapsed = (- (float-time) start-time)
while (< elapsed hanoi-move-period)
with tick-period = (/ (float hanoi-move-period) total-ticks)
- for tick = (ceiling (/ elapsed tick-period)) do
+ for tick = (ceiling elapsed tick-period) do
(hanoi-ring-to-pos ring (funcall tick-to-pos tick))
(hanoi-sit-for (- (* tick tick-period) elapsed)))
(cl-loop for tick from 1 to total-ticks by 2 do
diff --git a/lisp/printing.el b/lisp/printing.el
index d3240fe532c..f2495ecda38 100644
--- a/lisp/printing.el
+++ b/lisp/printing.el
@@ -1,9 +1,9 @@
-;;; printing.el --- printing utilities
+;;; printing.el --- printing utilities -*- lexical-binding:t -*-
;; Copyright (C) 2000-2001, 2003-2019 Free Software Foundation, Inc.
-;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
-;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
+;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: wp, print, PostScript
;; Version: 6.9.3
;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
@@ -12,7 +12,7 @@
"printing.el, v 6.9.3 <2007/12/09 vinicius>
Please send all bug fixes and enhancements to
- bug-gnu-emacs@gnu.org and Vinicius Jose Latorre <viniciusjl@ig.com.br>
+ bug-gnu-emacs@gnu.org and Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
")
;; This file is part of GNU Emacs.
@@ -460,7 +460,7 @@ Please send all bug fixes and enhancements to
;; subjects shows up at the printer. With major mode printing you don't need
;; to switch from gnus *Summary* buffer first.
;;
-;; Current global keyboard mapping for GNU Emacs is:
+;; Current global keyboard mapping is:
;;
;; (global-set-key [print] 'pr-ps-fast-fire)
;; (global-set-key [M-print] 'pr-ps-mode-using-ghostscript)
@@ -468,14 +468,6 @@ Please send all bug fixes and enhancements to
;; (global-set-key [C-print] 'pr-txt-fast-fire)
;; (global-set-key [C-M-print] 'pr-txt-fast-fire)
;;
-;; And for XEmacs is:
-;;
-;; (global-set-key 'f22 'pr-ps-fast-fire)
-;; (global-set-key '(meta f22) 'pr-ps-mode-using-ghostscript)
-;; (global-set-key '(shift f22) 'pr-ps-mode-using-ghostscript)
-;; (global-set-key '(control f22) 'pr-txt-fast-fire)
-;; (global-set-key '(control meta f22) 'pr-txt-fast-fire)
-;;
;; As a suggestion of global keyboard mapping for some `printing' commands:
;;
;; (global-set-key "\C-ci" 'pr-interface)
@@ -493,7 +485,7 @@ Please send all bug fixes and enhancements to
;; Below it's shown a brief description of `printing' options, please, see the
;; options declaration in the code for a long documentation.
;;
-;; `pr-path-style' Specify which path style to use for external
+;; `pr-filename-style' Specify which filename style to use for external
;; commands.
;;
;; `pr-path-alist' Specify an alist for command paths.
@@ -999,7 +991,7 @@ Please send all bug fixes and enhancements to
;; - automagic region detection.
;; - menu entry hiding.
;; - fast fire PostScript printing command.
-;; - `pr-path-style' variable.
+;; - `pr-filename-style' variable.
;;
;; Thanks to Kim F. Storm <storm@filanet.dk> for beta-test and for suggestions:
;; - PostScript Print and PostScript Print Preview merge.
@@ -1023,7 +1015,7 @@ Please send all bug fixes and enhancements to
(require 'lpr)
(require 'ps-print)
-
+(require 'easymenu)
(and (string< ps-print-version "6.6.4")
(error "`printing' requires `ps-print' package version 6.6.4 or later"))
@@ -1038,93 +1030,16 @@ Please send all bug fixes and enhancements to
;; To avoid compilation gripes
-;; Emacs has this since at least 21.1.
-(when (featurep 'xemacs)
- (or (fboundp 'subst-char-in-string) ; hacked from subr.el
- (defun subst-char-in-string (fromchar tochar string &optional inplace)
- "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
-Unless optional argument INPLACE is non-nil, return a new string."
- (let ((i (length string))
- (newstr (if inplace string (copy-sequence string))))
- (while (> (setq i (1- i)) 0)
- (if (eq (aref newstr i) fromchar)
- (aset newstr i tochar)))
- newstr))))
-
-
-;; Emacs has this since at least 21.1, but the SUFFIX argument
-;; (which this file uses) only since 22.1. So the fboundp test
-;; wasn't even correct/adequate. Whatever, no-one is using
-;; this file on older Emacs version, so it's irrelevant.
-(when (featurep 'xemacs)
- (or (fboundp 'make-temp-file) ; hacked from subr.el
- (defun make-temp-file (prefix &optional dir-flag suffix)
- "Create a temporary file.
-The returned file name (created by appending some random characters at the end
-of PREFIX, and expanding against `temporary-file-directory' if necessary),
-is guaranteed to point to a newly created empty file.
-You can then use `write-region' to write new data into the file.
-
-If DIR-FLAG is non-nil, create a new empty directory instead of a file.
-
-If SUFFIX is non-nil, add that at the end of the file name."
- (let ((umask (default-file-modes))
- file)
- (unwind-protect
- (progn
- ;; Create temp files with strict access rights. It's easy to
- ;; loosen them later, whereas it's impossible to close the
- ;; time-window of loose permissions otherwise.
- (set-default-file-modes ?\700)
- (while (condition-case ()
- (progn
- (setq file
- (make-temp-name
- (expand-file-name prefix temporary-file-directory)))
- (if suffix
- (setq file (concat file suffix)))
- (if dir-flag
- (make-directory file)
- (write-region "" nil file nil 'silent nil 'excl))
- nil)
- (file-already-exists t))
- ;; the file was somehow created by someone else between
- ;; `make-temp-name' and `write-region', let's try again.
- nil)
- file)
- ;; Reset the umask.
- (set-default-file-modes umask))))))
-
-
-(eval-when-compile
- ;; User Interface --- declared here to avoid compiler warnings
- (defvar pr-path-style)
- (defvar pr-auto-region)
- (defvar pr-menu-char-height)
- (defvar pr-menu-char-width)
- (defvar pr-menu-lock)
- (defvar pr-ps-printer-alist)
- (defvar pr-txt-printer-alist)
- (defvar pr-ps-utility-alist)
-
-
- ;; Internal fun alias to avoid compilation gripes
- (defalias 'pr-menu-lookup 'ignore)
- (defalias 'pr-menu-lock 'ignore)
- (defalias 'pr-menu-alist 'ignore)
- (defalias 'pr-even-or-odd-pages 'ignore)
- (defalias 'pr-menu-get-item 'ignore)
- (defalias 'pr-menu-set-item-name 'ignore)
- (defalias 'pr-menu-set-utility-title 'ignore)
- (defalias 'pr-menu-set-ps-title 'ignore)
- (defalias 'pr-menu-set-txt-title 'ignore)
- (defalias 'pr-region-active-p 'ignore)
- (defalias 'pr-do-update-menus 'ignore)
- (defalias 'pr-update-mode-line 'ignore)
- (defalias 'pr-read-string 'ignore)
- (defalias 'pr-set-keymap-parents 'ignore)
- (defalias 'pr-keep-region-active 'ignore))
-
+;; User Interface --- declared here to avoid compiler warnings
+(define-obsolete-variable-alias 'pr-path-style 'pr-filename-style "27.1")
+(defvar pr-filename-style)
+(defvar pr-auto-region)
+(defvar pr-menu-char-height)
+(defvar pr-menu-char-width)
+(defvar pr-menu-lock)
+(defvar pr-ps-printer-alist)
+(defvar pr-txt-printer-alist)
+(defvar pr-ps-utility-alist)
;; Internal Vars --- defined here to avoid compiler warnings
(defvar pr-menu-print-item "print"
@@ -1151,480 +1066,206 @@ Used by `pr-menu-bind' and `pr-update-menus'.")
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; XEmacs Definitions
-
-
-(cond
- ((featurep 'xemacs) ; XEmacs
- ;; XEmacs
- (defalias 'pr-set-keymap-parents 'set-keymap-parents)
- (defalias 'pr-set-keymap-name 'set-keymap-name)
-
- ;; XEmacs
- (defun pr-read-string (prompt initial history default)
- (let ((str (read-string prompt initial)))
- (if (and str (not (string= str "")))
- str
- default)))
-
- ;; XEmacs
- (defvar zmacs-region-stays nil)
-
- ;; XEmacs
- (defun pr-keep-region-active ()
- (setq zmacs-region-stays t))
-
- ;; XEmacs
- (defun pr-region-active-p ()
- (and pr-auto-region (not zmacs-region-stays) (ps-mark-active-p)))
-
- ;; XEmacs
- (defun pr-menu-char-height ()
- (font-height (face-font 'default)))
-
- ;; XEmacs
- (defun pr-menu-char-width ()
- (font-width (face-font 'default)))
-
- ;; XEmacs
- (defmacro pr-xemacs-global-menubar (&rest body)
- `(save-excursion
- (let ((temp (get-buffer-create (make-temp-name " *Temp"))))
- ;; be sure to access global menubar
- (set-buffer temp)
- ,@body
- (kill-buffer temp))))
-
- ;; XEmacs
- (defun pr-global-menubar (pr-menu-spec)
- ;; Menu binding
- (pr-xemacs-global-menubar
- (add-submenu nil (cons "Printing" pr-menu-spec) "Apps"))
- (setq pr-menu-print-item nil))
-
- ;; XEmacs
- (defvar current-mouse-event nil)
- (defun pr-menu-position (entry index horizontal)
- (make-event
- 'button-release
- (list 'button 1
- 'x (- (event-x-pixel current-mouse-event) ; X
- (* horizontal pr-menu-char-width))
- 'y (- (event-y-pixel current-mouse-event) ; Y
- (* (pr-menu-index entry index) pr-menu-char-height)))))
-
- (defvar pr-menu-position nil)
- (defvar pr-menu-state nil)
-
- ;; XEmacs
- (defvar current-menubar nil) ; to avoid compilation gripes
- (defun pr-menu-lookup (path)
- (car (find-menu-item current-menubar (cons "Printing" path))))
-
- ;; XEmacs
- (defun pr-menu-lock (entry index horizontal state path)
- (when pr-menu-lock
- (or (and pr-menu-position (eq state pr-menu-state))
- (setq pr-menu-position (pr-menu-position entry index horizontal)
- pr-menu-state state))
- (let* ((menu (pr-menu-lookup path))
- (result (get-popup-menu-response menu pr-menu-position)))
- (and (misc-user-event-p result)
- (funcall (event-function result)
- (event-object result))))
- (setq pr-menu-position nil)))
-
- ;; XEmacs
- (defalias 'pr-update-mode-line 'set-menubar-dirty-flag)
-
- ;; XEmacs
- (defvar pr-ps-name-old "PostScript Printers")
- (defvar pr-txt-name-old "Text Printers")
- (defvar pr-ps-utility-old "PostScript Utility")
- (defvar pr-even-or-odd-old "Print All Pages")
-
- ;; XEmacs
- (defun pr-do-update-menus (&optional force)
- (pr-menu-alist pr-ps-printer-alist
- 'pr-ps-name
- 'pr-menu-set-ps-title
- '("Printing")
- 'pr-ps-printer-menu-modified
- force
- pr-ps-name-old
- 'postscript 2)
- (pr-menu-alist pr-txt-printer-alist
- 'pr-txt-name
- 'pr-menu-set-txt-title
- '("Printing")
- 'pr-txt-printer-menu-modified
- force
- pr-txt-name-old
- 'text 2)
- (let ((save-var pr-ps-utility-menu-modified))
- (pr-menu-alist pr-ps-utility-alist
- 'pr-ps-utility
- 'pr-menu-set-utility-title
- '("Printing" "PostScript Print" "File")
- 'save-var
- force
- pr-ps-utility-old
- nil 1))
- (pr-menu-alist pr-ps-utility-alist
- 'pr-ps-utility
- 'pr-menu-set-utility-title
- '("Printing" "PostScript Preview" "File")
- 'pr-ps-utility-menu-modified
- force
- pr-ps-utility-old
- nil 1)
- (pr-even-or-odd-pages ps-even-or-odd-pages force))
-
- ;; XEmacs
- (defun pr-menu-alist (alist var-sym fun menu-path modified-sym force name
- entry index)
- (when (and alist (or force (symbol-value modified-sym)))
- (pr-xemacs-global-menubar
- (add-submenu menu-path
- (pr-menu-create name alist var-sym
- fun entry index)))
- (funcall fun (symbol-value var-sym))
- (set modified-sym nil)))
-
- ;; XEmacs
- (defun pr-relabel-menu-item (newname var-sym)
- (pr-xemacs-global-menubar
- (relabel-menu-item
- (list "Printing" (symbol-value var-sym))
- newname)
- (set var-sym newname)))
-
- ;; XEmacs
- (defun pr-menu-set-ps-title (value &optional item entry index)
- (pr-relabel-menu-item (format "PostScript Printer: %s" value)
- 'pr-ps-name-old)
- (pr-ps-set-printer value)
- (and index
- (pr-menu-lock entry index 12 'toggle nil)))
-
- ;; XEmacs
- (defun pr-menu-set-txt-title (value &optional item entry index)
- (pr-relabel-menu-item (format "Text Printer: %s" value)
- 'pr-txt-name-old)
- (pr-txt-set-printer value)
- (and index
- (pr-menu-lock entry index 12 'toggle nil)))
-
- ;; XEmacs
- (defun pr-menu-set-utility-title (value &optional item entry index)
- (pr-xemacs-global-menubar
- (let ((newname (format "%s" value)))
- (relabel-menu-item
- (list "Printing" "PostScript Print" "File" pr-ps-utility-old)
- newname)
- (relabel-menu-item
- (list "Printing" "PostScript Preview" "File" pr-ps-utility-old)
- newname)
- (setq pr-ps-utility-old newname)))
- (pr-ps-set-utility value)
- (and index
- (pr-menu-lock entry index 5 nil '("PostScript Print" "File"))))
-
- ;; XEmacs
- (defun pr-even-or-odd-pages (value &optional no-lock)
- (pr-relabel-menu-item (cdr (assq value pr-even-or-odd-alist))
- 'pr-even-or-odd-old)
- (setq ps-even-or-odd-pages value)
- (or no-lock
- (pr-menu-lock 'postscript-options 8 12 'toggle nil)))
-
- )
- (t ; GNU Emacs
- ;; Do nothing
- )) ; end cond featurep
+;; GNU Emacs Definitions
+(defun pr-keep-region-active ()
+ (setq deactivate-mark nil))
-
-;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; GNU Emacs Definitions
+(defun pr-region-active-p ()
+ (and pr-auto-region (use-region-p)))
-(eval-and-compile
- (unless (featurep 'xemacs)
- (defvar pr-menu-bar nil
- "Specify Printing menu-bar entry.")))
-
-(cond
- ((featurep 'xemacs) ; XEmacs
- ;; Do nothing
- )
- (t ; GNU Emacs
- ;; GNU Emacs
- (defalias 'pr-set-keymap-parents 'set-keymap-parent)
- (defalias 'pr-set-keymap-name 'ignore)
- (defalias 'pr-read-string 'read-string)
-
- ;; GNU Emacs
- (defvar deactivate-mark)
-
- ;; GNU Emacs
- (defun pr-keep-region-active ()
- (setq deactivate-mark nil))
-
- ;; GNU Emacs
- (defun pr-region-active-p ()
- (and pr-auto-region transient-mark-mode mark-active))
-
- ;; GNU Emacs
- (defun pr-menu-char-height ()
- (frame-char-height))
-
- ;; GNU Emacs
- (defun pr-menu-char-width ()
- (frame-char-width))
-
- ;; GNU Emacs
- ;; Menu binding
- ;; Replace existing "print" item by "Printing" item.
- ;; If you're changing this file, you'll load it a second,
- ;; third... time, but "print" item exists only in the first load.
- (eval-when-compile
- (require 'easymenu)) ; to avoid compilation gripes
-
- (declare-function easy-menu-add-item "easymenu"
- (map path item &optional before))
- (declare-function easy-menu-remove-item "easymenu" (map path name))
-
- (eval-and-compile
- (defun pr-global-menubar (pr-menu-spec)
- (require 'easymenu)
- (let ((menu-file (if (= emacs-major-version 21)
- '("menu-bar" "files") ; GNU Emacs 21
- '("menu-bar" "file")))) ; GNU Emacs 22 or higher
- (cond
- (pr-menu-print-item
- (easy-menu-add-item global-map menu-file
- (easy-menu-create-menu "Print" pr-menu-spec)
- "print-buffer")
- (dolist (item '("print-buffer" "print-region"
- "ps-print-buffer-faces" "ps-print-region-faces"
- "ps-print-buffer" "ps-print-region"))
- (easy-menu-remove-item global-map menu-file item))
- (setq pr-menu-print-item nil
- pr-menu-bar (vector 'menu-bar
- (pr-get-symbol (nth 1 menu-file))
- (pr-get-symbol "Print"))))
- (t
- (easy-menu-add-item global-map menu-file
- (easy-menu-create-menu "Print" pr-menu-spec)))
- ))))
-
- (eval-and-compile
+;; Menu binding
+;; Replace existing "print" item by "Printing" item.
+;; If you're changing this file, you'll load it a second,
+;; third... time, but "print" item exists only in the first load.
+
+(defvar pr-menu-bar nil
+ "Specify Printing menu-bar entry.")
+
+(defun pr-global-menubar (menu-spec)
+ (let ((menu-file '("menu-bar" "file")))
(cond
- (lpr-windows-system
- ;; GNU Emacs for Windows 9x/NT
- (defun pr-menu-position (entry index horizontal)
- (let ((pos (cdr (mouse-pixel-position))))
- (list
- (list (or (car pos) 0) ; X
- (- (or (cdr pos) 0) ; Y
- (* (pr-menu-index entry index) pr-menu-char-height)))
- (selected-frame)))) ; frame
- )
+ (pr-menu-print-item
+ (easy-menu-add-item global-map menu-file
+ (easy-menu-create-menu "Print" menu-spec)
+ "print-buffer")
+ (dolist (item '("print-buffer" "print-region"
+ "ps-print-buffer-faces" "ps-print-region-faces"
+ "ps-print-buffer" "ps-print-region"))
+ (easy-menu-remove-item global-map menu-file item))
+ (setq pr-menu-print-item nil
+ pr-menu-bar (vector 'menu-bar
+ (easy-menu-intern (nth 1 menu-file))
+ (easy-menu-intern "Print"))))
(t
- ;; GNU Emacs
- (defun pr-menu-position (entry index horizontal)
- (let ((pos (cdr (mouse-pixel-position))))
- (list
- (list (- (or (car pos) 0) ; X
- (* horizontal pr-menu-char-width))
- (- (or (cdr pos) 0) ; Y
- (* (pr-menu-index entry index) pr-menu-char-height)))
- (selected-frame)))) ; frame
- )))
-
- (defvar pr-menu-position nil)
- (defvar pr-menu-state nil)
-
- ;; GNU Emacs
- (defun pr-menu-lookup (path)
- (lookup-key global-map
- (if path
- (vconcat pr-menu-bar
- (mapcar 'pr-get-symbol
- (if (listp path)
- path
- (list path))))
- pr-menu-bar)))
-
- ;; GNU Emacs
- (defun pr-menu-lock (entry index horizontal state path)
- (when pr-menu-lock
- (or (and pr-menu-position (eq state pr-menu-state))
- (setq pr-menu-position (pr-menu-position entry index horizontal)
- pr-menu-state state))
- (let* ((menu (pr-menu-lookup path))
- (result (x-popup-menu pr-menu-position menu)))
- (and result
- (let ((command (lookup-key menu (vconcat result))))
- (if (fboundp command)
- (funcall command)
- (eval command)))))
- (setq pr-menu-position nil)))
-
- ;; GNU Emacs
- (defalias 'pr-update-mode-line 'force-mode-line-update)
-
- ;; GNU Emacs
- (defun pr-do-update-menus (&optional force)
- (pr-menu-alist pr-ps-printer-alist
- 'pr-ps-name
- 'pr-menu-set-ps-title
- "PostScript Printers"
- 'pr-ps-printer-menu-modified
- force
- "PostScript Printers"
- 'postscript 2)
- (pr-menu-alist pr-txt-printer-alist
- 'pr-txt-name
- 'pr-menu-set-txt-title
- "Text Printers"
- 'pr-txt-printer-menu-modified
- force
- "Text Printers"
- 'text 2)
- (let ((save-var pr-ps-utility-menu-modified))
- (pr-menu-alist pr-ps-utility-alist
- 'pr-ps-utility
- 'pr-menu-set-utility-title
- '("PostScript Print" "File" "PostScript Utility")
- 'save-var
- force
- "PostScript Utility"
- nil 1))
+ (easy-menu-add-item global-map menu-file
+ (easy-menu-create-menu "Print" menu-spec)))
+ )))
+
+(defun pr-menu-position (entry index horizontal)
+ (let ((pos (cdr (mouse-pixel-position))))
+ (list
+ (list (- (or (car pos) 0) ; X
+ (if lpr-windows-system
+ 0 ;; GNU Emacs for Windows 9x/NT
+ (* horizontal pr-menu-char-width)))
+ (- (or (cdr pos) 0) ; Y
+ (* (pr-menu-index entry index) pr-menu-char-height)))
+ (selected-frame)))) ; frame
+
+(defvar pr-menu-position nil)
+(defvar pr-menu-state nil)
+
+(defun pr-menu-lookup (path)
+ (lookup-key global-map
+ (if path
+ (vconcat pr-menu-bar
+ (mapcar #'easy-menu-intern
+ (if (listp path)
+ path
+ (list path))))
+ pr-menu-bar)))
+
+(defun pr-menu-lock (entry index horizontal state path)
+ (when pr-menu-lock
+ (or (and pr-menu-position (eq state pr-menu-state))
+ (setq pr-menu-position (pr-menu-position entry index horizontal)
+ pr-menu-state state))
+ (let* ((menu (pr-menu-lookup path))
+ (result (x-popup-menu pr-menu-position menu)))
+ (and result
+ (let ((command (lookup-key menu (vconcat result))))
+ (if (fboundp command)
+ (funcall command)
+ (eval command)))))
+ (setq pr-menu-position nil)))
+
+(defun pr-do-update-menus (&optional force)
+ (pr-menu-alist pr-ps-printer-alist
+ 'pr-ps-name
+ #'pr-menu-set-ps-title
+ "PostScript Printers"
+ 'pr-ps-printer-menu-modified
+ force
+ "PostScript Printers"
+ 'postscript 2)
+ (pr-menu-alist pr-txt-printer-alist
+ 'pr-txt-name
+ #'pr-menu-set-txt-title
+ "Text Printers"
+ 'pr-txt-printer-menu-modified
+ force
+ "Text Printers"
+ 'text 2)
+ (defvar pr--save-var)
+ (let ((pr--save-var pr-ps-utility-menu-modified))
(pr-menu-alist pr-ps-utility-alist
'pr-ps-utility
- 'pr-menu-set-utility-title
- '("PostScript Preview" "File" "PostScript Utility")
- 'pr-ps-utility-menu-modified
+ #'pr-menu-set-utility-title
+ '("PostScript Print" "File" "PostScript Utility")
+ 'pr--save-var
force
"PostScript Utility"
- nil 1)
- (pr-even-or-odd-pages ps-even-or-odd-pages force))
-
- ;; GNU Emacs
- (defun pr-menu-get-item (name-list)
- ;; NAME-LIST is a string or a list of strings.
- (or (listp name-list)
- (setq name-list (list name-list)))
- (and name-list
- (let* ((reversed (reverse name-list))
- (name (pr-get-symbol (car reversed)))
- (path (nreverse (cdr reversed)))
- (menu (lookup-key
- global-map
- (vconcat pr-menu-bar
- (mapcar 'pr-get-symbol path)))))
- (assq name (nthcdr 2 menu)))))
-
- ;; GNU Emacs
- (defvar pr-temp-menu nil)
-
- ;; GNU Emacs
- (defun pr-menu-alist (alist var-sym fun menu-path modified-sym force name
- entry index)
- (when (and alist (or force (symbol-value modified-sym)))
- (easy-menu-define pr-temp-menu nil ""
- (pr-menu-create name alist var-sym fun entry index))
- (let ((item (pr-menu-get-item menu-path)))
- (and item
- (let* ((binding (nthcdr 3 item))
- (key-binding (cdr binding)))
- (setcar binding pr-temp-menu)
- (and key-binding (listp (car key-binding))
- (setcdr binding (cdr key-binding))) ; skip KEY-BINDING
- (funcall fun (symbol-value var-sym) item))))
- (set modified-sym nil)))
-
- ;; GNU Emacs
- (defun pr-menu-set-item-name (item name)
- (and item
- (setcar (nthcdr 2 item) name))) ; ITEM-NAME
-
- ;; GNU Emacs
- (defun pr-menu-set-ps-title (value &optional item entry index)
- (pr-menu-set-item-name (or item
- (pr-menu-get-item "PostScript Printers"))
- (format "PostScript Printer: %s" value))
- (pr-ps-set-printer value)
- (and index
- (pr-menu-lock entry index 12 'toggle nil)))
-
- ;; GNU Emacs
- (defun pr-menu-set-txt-title (value &optional item entry index)
- (pr-menu-set-item-name (or item
- (pr-menu-get-item "Text Printers"))
- (format "Text Printer: %s" value))
- (pr-txt-set-printer value)
- (and index
- (pr-menu-lock entry index 12 'toggle nil)))
-
- ;; GNU Emacs
- (defun pr-menu-set-utility-title (value &optional item entry index)
- (let ((name (symbol-name value)))
- (if item
- (pr-menu-set-item-name item name)
- (pr-menu-set-item-name
- (pr-menu-get-item
- '("PostScript Print" "File" "PostScript Utility"))
- name)
- (pr-menu-set-item-name
- (pr-menu-get-item
- '("PostScript Preview" "File" "PostScript Utility"))
- name)))
- (pr-ps-set-utility value)
- (and index
- (pr-menu-lock entry index 5 nil '("PostScript Print" "File"))))
-
- ;; GNU Emacs
- (defun pr-even-or-odd-pages (value &optional no-lock)
- (pr-menu-set-item-name (pr-menu-get-item "Print All Pages")
- (cdr (assq value pr-even-or-odd-alist)))
- (setq ps-even-or-odd-pages value)
- (or no-lock
- (pr-menu-lock 'postscript-options 8 12 'toggle nil)))
-
- )) ; end cond featurep
-
+ nil 1))
+ (pr-menu-alist pr-ps-utility-alist
+ 'pr-ps-utility
+ #'pr-menu-set-utility-title
+ '("PostScript Preview" "File" "PostScript Utility")
+ 'pr-ps-utility-menu-modified
+ force
+ "PostScript Utility"
+ nil 1)
+ (pr-even-or-odd-pages ps-even-or-odd-pages force))
+
+(defun pr-menu-get-item (name-list)
+ ;; NAME-LIST is a string or a list of strings.
+ (or (listp name-list)
+ (setq name-list (list name-list)))
+ (and name-list
+ (let* ((reversed (reverse name-list))
+ (name (easy-menu-intern (car reversed)))
+ (path (nreverse (cdr reversed)))
+ (menu (lookup-key
+ global-map
+ (vconcat pr-menu-bar
+ (mapcar #'easy-menu-intern path)))))
+ (assq name (nthcdr 2 menu)))))
+
+(defvar pr-temp-menu nil)
+
+(defun pr-menu-alist (alist var-sym fun menu-path modified-sym force name
+ entry index)
+ (when (and alist (or force (symbol-value modified-sym)))
+ (easy-menu-define pr-temp-menu nil ""
+ (pr-menu-create name alist var-sym fun entry index))
+ (let ((item (pr-menu-get-item menu-path)))
+ (and item
+ (progn
+ (setf (nth 3 item) pr-temp-menu)
+ (funcall fun (symbol-value var-sym) item))))
+ (set modified-sym nil)))
+
+(defun pr-menu-set-item-name (item name)
+ (and item
+ (setcar (nthcdr 2 item) name))) ; ITEM-NAME
+
+(defun pr-menu-set-ps-title (value &optional item entry index)
+ (pr-menu-set-item-name (or item
+ (pr-menu-get-item "PostScript Printers"))
+ (format "PostScript Printer: %s" value))
+ (pr-ps-set-printer value)
+ (and index
+ (pr-menu-lock entry index 12 'toggle nil)))
+
+(defun pr-menu-set-txt-title (value &optional item entry index)
+ (pr-menu-set-item-name (or item
+ (pr-menu-get-item "Text Printers"))
+ (format "Text Printer: %s" value))
+ (pr-txt-set-printer value)
+ (and index
+ (pr-menu-lock entry index 12 'toggle nil)))
+
+(defun pr-menu-set-utility-title (value &optional item entry index)
+ (let ((name (symbol-name value)))
+ (if item
+ (pr-menu-set-item-name item name)
+ (pr-menu-set-item-name
+ (pr-menu-get-item
+ '("PostScript Print" "File" "PostScript Utility"))
+ name)
+ (pr-menu-set-item-name
+ (pr-menu-get-item
+ '("PostScript Preview" "File" "PostScript Utility"))
+ name)))
+ (pr-ps-set-utility value)
+ (and index
+ (pr-menu-lock entry index 5 nil '("PostScript Print" "File"))))
+
+(defun pr-even-or-odd-pages (value &optional no-lock)
+ (pr-menu-set-item-name (pr-menu-get-item "Print All Pages")
+ (cdr (assq value pr-even-or-odd-alist)))
+ (setq ps-even-or-odd-pages value)
+ (or no-lock
+ (pr-menu-lock 'postscript-options 8 12 'toggle nil)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Internal Functions (I)
-(defun pr-dosify-file-name (path)
+(defun pr-dosify-file-name (filename)
"Replace unix-style directory separator character with dos/windows one."
- (interactive "sPath: ")
- (if (eq pr-path-style 'windows)
- (subst-char-in-string ?/ ?\\ path)
- path))
-
+ (if (eq pr-filename-style 'windows)
+ (subst-char-in-string ?/ ?\\ filename)
+ filename))
-(defun pr-unixify-file-name (path)
- "Replace dos/windows-style directory separator character with unix one."
- (interactive "sPath: ")
- (if (eq pr-path-style 'windows)
- (subst-char-in-string ?\\ ?/ path)
- path))
-
-
-(defun pr-standard-file-name (path)
+(defun pr-standard-file-name (filename)
"Ensure the proper directory separator depending on the OS.
That is, if Emacs is running on DOS/Windows, ensure dos/windows-style directory
separator; otherwise, ensure unix-style directory separator."
+ ;; FIXME: Why not use pr-dosify-file-name?
(if (or pr-cygwin-system lpr-windows-system)
- (subst-char-in-string ?/ ?\\ path)
- (subst-char-in-string ?\\ ?/ path)))
-
+ (subst-char-in-string ?/ ?\\ filename)
+ filename))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Customization Functions
@@ -1672,22 +1313,21 @@ separator; otherwise, ensure unix-style directory separator."
:group 'postscript)
-(defcustom pr-path-style
+(defcustom pr-filename-style
(if (and (not pr-cygwin-system)
lpr-windows-system)
'windows
'unix)
- "Specify which path style to use for external commands.
+ "Specify which filename style to use for external commands.
Valid values are:
windows Windows 9x/NT style (\\)
unix Unix style (/)"
- :type '(choice :tag "Path style"
+ :type '(choice :tag "Filename style"
(const :tag "Windows 9x/NT Style (\\)" :value windows)
- (const :tag "Unix Style (/)" :value unix))
- :group 'printing)
+ (const :tag "Unix Style (/)" :value unix)))
(defcustom pr-path-alist
@@ -1708,13 +1348,13 @@ Where:
ENTRY It's a symbol, used to identify this entry.
There must exist at least one of the following entries:
- unix this entry is used when Emacs is running on GNU or
+ `unix' this entry is used when Emacs is running on GNU or
Unix system.
- cygwin this entry is used when Emacs is running on Windows
+ `cygwin' this entry is used when Emacs is running on Windows
95/98/NT/2000 with Cygwin.
- windows this entry is used when Emacs is running on Windows
+ `windows' this entry is used when Emacs is running on Windows
95/98/NT/2000.
DIRECTORY It should be a string or a symbol. If it's a symbol, it should
@@ -1764,8 +1404,7 @@ Examples:
(choice :menu-tag "Directory"
:tag "Directory"
(string :value "")
- (symbol :value symbol)))))
- :group 'printing)
+ (symbol :value symbol))))))
(defcustom pr-txt-name 'default
@@ -1778,8 +1417,7 @@ This variable should be modified by customization engine. If this variable is
modified by other means (for example, a lisp function), use `pr-update-menus'
function (see it for documentation) to update text printer menu."
:type 'symbol
- :set 'pr-txt-name-custom-set
- :group 'printing)
+ :set 'pr-txt-name-custom-set)
(defcustom pr-txt-printer-alist
@@ -1910,8 +1548,7 @@ Useful links:
:tag "Printer Name"
(const :tag "None" nil)
string)))
- :set 'pr-alist-custom-set
- :group 'printing)
+ :set 'pr-alist-custom-set)
(defcustom pr-ps-name 'default
@@ -1924,8 +1561,7 @@ This variable should be modified by customization engine. If this variable is
modified by other means (for example, a lisp function), use `pr-update-menus'
function (see it for documentation) to update PostScript printer menu."
:type 'symbol
- :set 'pr-ps-name-custom-set
- :group 'printing)
+ :set 'pr-ps-name-custom-set)
(defcustom pr-ps-printer-alist
@@ -2196,33 +1832,21 @@ Useful links:
(variable :tag "Other"))
(sexp :tag "Value")))
))
- :set 'pr-alist-custom-set
- :group 'printing)
-
-
-(defcustom pr-temp-dir
- (pr-dosify-file-name
- (if (boundp 'temporary-file-directory)
- (symbol-value 'temporary-file-directory)
- ;; hacked from `temporary-file-directory' variable in files.el
- (file-name-as-directory
- (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP")
- (cond (lpr-windows-system "c:/temp")
- (t "/tmp")
- )))))
+ :set 'pr-alist-custom-set)
+
+
+(defcustom pr-temp-dir temporary-file-directory
"Specify a directory for temporary files during printing.
See also `pr-ps-temp-file' and `pr-file-modes'."
- :type '(directory :tag "Temporary Directory")
- :group 'printing)
+ :type '(directory :tag "Temporary Directory"))
(defcustom pr-ps-temp-file "prspool-"
"Specify PostScript temporary file name prefix.
See also `pr-temp-dir' and `pr-file-modes'."
- :type '(file :tag "PostScript Temporary File Name")
- :group 'printing)
+ :type '(file :tag "PostScript Temporary File Name"))
;; It uses 0600 as default instead of (default-file-modes).
@@ -2234,8 +1858,7 @@ See also `pr-temp-dir' and `pr-file-modes'."
It should be an integer; only the low 9 bits are used.
See also `pr-temp-dir' and `pr-ps-temp-file'."
- :type '(integer :tag "File Permission Bits")
- :group 'printing)
+ :type '(integer :tag "File Permission Bits"))
(defcustom pr-gv-command
@@ -2275,8 +1898,7 @@ Useful links:
* MacGSView (Mac OS)
`http://www.cs.wisc.edu/~ghost/macos/index.htm'
"
- :type '(string :tag "Ghostview Utility")
- :group 'printing)
+ :type '(string :tag "Ghostview Utility"))
(defcustom pr-gs-command
@@ -2301,8 +1923,7 @@ Useful links:
* Printer compatibility
`http://www.cs.wisc.edu/~ghost/doc/printer.htm'
"
- :type '(string :tag "Ghostscript Utility")
- :group 'printing)
+ :type '(string :tag "Ghostscript Utility"))
(defcustom pr-gs-switches
@@ -2343,8 +1964,7 @@ Useful links:
* Printer compatibility
`http://www.cs.wisc.edu/~ghost/doc/printer.htm'
"
- :type '(repeat (string :tag "Ghostscript Switch"))
- :group 'printing)
+ :type '(repeat (string :tag "Ghostscript Switch")))
(defcustom pr-gs-device
@@ -2359,8 +1979,7 @@ A note on the gs switches:
See `pr-gs-switches' for documentation.
See also `pr-ps-printer-alist'."
- :type '(string :tag "Ghostscript Device")
- :group 'printing)
+ :type '(string :tag "Ghostscript Device"))
(defcustom pr-gs-resolution 300
@@ -2372,8 +1991,7 @@ A note on the gs switches:
See `pr-gs-switches' for documentation.
See also `pr-ps-printer-alist'."
- :type '(integer :tag "Ghostscript Resolution")
- :group 'printing)
+ :type '(integer :tag "Ghostscript Resolution"))
(defcustom pr-print-using-ghostscript nil
@@ -2384,32 +2002,27 @@ ghostscript to print a PostScript file.
In GNU or Unix system, if ghostscript is set as a PostScript filter, this
variable should be nil."
- :type 'boolean
- :group 'printing)
+ :type 'boolean)
(defcustom pr-faces-p nil
"Non-nil means print with face attributes."
- :type 'boolean
- :group 'printing)
+ :type 'boolean)
(defcustom pr-spool-p nil
"Non-nil means spool printing in a buffer."
- :type 'boolean
- :group 'printing)
+ :type 'boolean)
(defcustom pr-file-landscape nil
"Non-nil means print PostScript file in landscape orientation."
- :type 'boolean
- :group 'printing)
+ :type 'boolean)
(defcustom pr-file-duplex nil
"Non-nil means print PostScript file in duplex mode."
- :type 'boolean
- :group 'printing)
+ :type 'boolean)
(defcustom pr-file-tumble nil
@@ -2419,8 +2032,7 @@ If tumble is off, produces a printing suitable for binding on the left or
right.
If tumble is on, produces a printing suitable for binding at the top or
bottom."
- :type 'boolean
- :group 'printing)
+ :type 'boolean)
(defcustom pr-auto-region t
@@ -2431,8 +2043,7 @@ Note that this will only work if you're using transient mark mode.
When this variable is non-nil, the `*-buffer*' commands will behave like
`*-region*' commands, that is, `*-buffer*' commands will print only the region
marked instead of all buffer."
- :type 'boolean
- :group 'printing)
+ :type 'boolean)
(defcustom pr-auto-mode t
@@ -2442,8 +2053,7 @@ That is, if current major-mode is declared in `pr-mode-alist', the `*-buffer*'
and `*-region*' commands will behave like `*-mode*' commands; otherwise,
`*-buffer*' commands will print the current buffer and `*-region*' commands
will print the current region."
- :type 'boolean
- :group 'printing)
+ :type 'boolean)
(defcustom pr-mode-alist
@@ -2642,8 +2252,7 @@ DEFAULT It's a way to set default values when this entry is selected.
(const :tag "inherits-from:" inherits-from:)
(variable :tag "Other"))
(sexp :tag "Value")))
- ))
- :group 'printing)
+ )))
(defcustom pr-ps-utility 'mpage
@@ -2659,8 +2268,7 @@ function (see it for documentation) to update PostScript utility menu.
NOTE: Don't forget to download and install the utilities declared on
`pr-ps-utility-alist'."
:type '(symbol :tag "PS File Utility")
- :set 'pr-ps-utility-custom-set
- :group 'printing)
+ :set 'pr-ps-utility-custom-set)
(defcustom pr-ps-utility-alist
@@ -2871,38 +2479,34 @@ Useful links:
(variable :tag "Other"))
(sexp :tag "Value")))
))
- :set 'pr-alist-custom-set
- :group 'printing)
+ :set 'pr-alist-custom-set)
(defcustom pr-menu-lock t
"Non-nil means menu is locked while selecting toggle options.
See also `pr-menu-char-height' and `pr-menu-char-width'."
- :type 'boolean
- :group 'printing)
+ :type 'boolean)
-(defcustom pr-menu-char-height (pr-menu-char-height)
+(defcustom pr-menu-char-height (frame-char-height)
"Specify menu char height in pixels.
This variable is used to guess which vertical position should be locked the
menu, so don't forget to adjust it if menu position is not ok.
See also `pr-menu-lock' and `pr-menu-char-width'."
- :type 'integer
- :group 'printing)
+ :type 'integer)
-(defcustom pr-menu-char-width (pr-menu-char-width)
+(defcustom pr-menu-char-width (frame-char-width)
"Specify menu char width in pixels.
This variable is used to guess which horizontal position should be locked the
menu, so don't forget to adjust it if menu position is not ok.
See also `pr-menu-lock' and `pr-menu-char-height'."
- :type 'integer
- :group 'printing)
+ :type 'integer)
(defcustom pr-setting-database
@@ -3017,8 +2621,7 @@ SETTING It's a cons like:
(const :tag "Ghostscript Resolution" pr-gs-resolution)
(variable :tag "Other"))
(sexp :tag "Value")))
- ))
- :group 'printing)
+ )))
(defcustom pr-visible-entry-list
@@ -3070,8 +2673,7 @@ Any other value is ignored."
(const postscript-options)
(const postscript-process)
(const printing)
- (const help)))
- :group 'printing)
+ (const help))))
(defcustom pr-delete-temp-file t
@@ -3081,8 +2683,7 @@ Set `pr-delete-temp-file' to nil, if the following message (or a similar)
happens when printing:
Error: could not open \"c:\\temp\\prspool.ps\" for reading."
- :type 'boolean
- :group 'printing)
+ :type 'boolean)
(defcustom pr-list-directory nil
@@ -3094,16 +2695,14 @@ argument of functions below) are also printed (as dired-mode listings).
It's used by `pr-ps-directory-preview', `pr-ps-directory-using-ghostscript',
`pr-ps-directory-print', `pr-ps-directory-ps-print', `pr-printify-directory'
and `pr-txt-directory'."
- :type 'boolean
- :group 'printing)
+ :type 'boolean)
(defcustom pr-buffer-name "*Printing Interface*"
"Specify the name of the buffer interface for printing package.
It's used by `pr-interface'."
- :type 'string
- :group 'printing)
+ :type 'string)
(defcustom pr-buffer-name-ignore
@@ -3115,16 +2714,14 @@ NOTE: Case is important for matching, that is, `case-fold-search' is always
nil.
It's used by `pr-interface'."
- :type '(repeat (regexp :tag "Buffer Name Regexp"))
- :group 'printing)
+ :type '(repeat (regexp :tag "Buffer Name Regexp")))
(defcustom pr-buffer-verbose t
"Non-nil means to be verbose when editing a field in interface buffer.
It's used by `pr-interface'."
- :type 'boolean
- :group 'printing)
+ :type 'boolean)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -3167,15 +2764,6 @@ See `pr-ps-printer-alist'.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Macros
-
-
-(defmacro pr-save-file-modes (&rest body)
- "Execute BODY with file permissions temporarily set to `pr-file-modes'."
- (declare (obsolete with-file-modes "25.1"))
- `(with-file-modes pr-file-modes ,@body))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Keys & Menus
@@ -3195,252 +2783,211 @@ See `pr-ps-printer-alist'.")
(and pr-print-using-ghostscript (not pr-spool-p)))
-(defalias 'pr-get-symbol
- (if (featurep 'emacs) 'easy-menu-intern ; since 22.1
- (if (fboundp 'easy-menu-intern) ; hacked from easymenu.el
- 'easy-menu-intern
- (lambda (s) (if (stringp s) (intern s) s)))))
-
-
(defconst pr-menu-spec
- ;; Menu mapping:
- ;; unfortunately XEmacs doesn't support :active for submenus,
- ;; only for items.
- ;; So, it uses :included instead of :active.
- ;; Also, XEmacs doesn't support :help tag.
- (let ((pr-:active (if (featurep 'xemacs)
- :included ; XEmacs
- :active)) ; GNU Emacs
- (pr-:help (if (featurep 'xemacs)
- 'ignore ; XEmacs
- #'(lambda (text) (list :help text))))) ; GNU Emacs
- `(
- ["Printing Interface" pr-interface
- ,@(funcall
- pr-:help "Use buffer interface instead of menu interface")]
+ '(
+ ["Printing Interface" pr-interface
+ :help "Use buffer interface instead of menu interface"]
+ "--"
+ ("PostScript Preview" :included (pr-visible-p 'postscript)
+ :help "Preview PostScript instead of sending to printer"
+ ("Directory" :active (not pr-spool-p)
+ ["1-up" (pr-ps-directory-preview 1 nil nil t) t]
+ ["2-up" (pr-ps-directory-preview 2 nil nil t) t]
+ ["4-up" (pr-ps-directory-preview 4 nil nil t) t]
+ ["Other..." (pr-ps-directory-preview nil nil nil t)
+ :keys "\\[pr-ps-buffer-preview]"])
+ ("Buffer" :active (not pr-spool-p)
+ ["1-up" (pr-ps-buffer-preview 1 t) t]
+ ["2-up" (pr-ps-buffer-preview 2 t) t]
+ ["4-up" (pr-ps-buffer-preview 4 t) t]
+ ["Other..." (pr-ps-buffer-preview nil t)
+ :keys "\\[pr-ps-buffer-preview]"])
+ ("Region" :active (and (not pr-spool-p) (ps-mark-active-p))
+ ["1-up" (pr-ps-region-preview 1 t) t]
+ ["2-up" (pr-ps-region-preview 2 t) t]
+ ["4-up" (pr-ps-region-preview 4 t) t]
+ ["Other..." (pr-ps-region-preview nil t)
+ :keys "\\[pr-ps-region-preview]"])
+ ("Mode" :active (and (not pr-spool-p) (pr-mode-alist-p))
+ ["1-up" (pr-ps-mode-preview 1 t) t]
+ ["2-up" (pr-ps-mode-preview 2 t) t]
+ ["4-up" (pr-ps-mode-preview 4 t) t]
+ ["Other..." (pr-ps-mode-preview nil t)
+ :keys "\\[pr-ps-mode-preview]"])
+ ("File"
+ ["No Preprocessing..." (call-interactively 'pr-ps-file-preview)
+ :keys "\\[pr-ps-file-preview]"
+ :help "Preview PostScript file"]
"--"
- ("PostScript Preview" :included (pr-visible-p 'postscript)
- ,@(funcall
- pr-:help "Preview PostScript instead of sending to printer")
- ("Directory" ,pr-:active (not pr-spool-p)
- ["1-up" (pr-ps-directory-preview 1 nil nil t) t]
- ["2-up" (pr-ps-directory-preview 2 nil nil t) t]
- ["4-up" (pr-ps-directory-preview 4 nil nil t) t]
- ["Other..." (pr-ps-directory-preview nil nil nil t)
- :keys "\\[pr-ps-buffer-preview]"])
- ("Buffer" ,pr-:active (not pr-spool-p)
- ["1-up" (pr-ps-buffer-preview 1 t) t]
- ["2-up" (pr-ps-buffer-preview 2 t) t]
- ["4-up" (pr-ps-buffer-preview 4 t) t]
- ["Other..." (pr-ps-buffer-preview nil t)
- :keys "\\[pr-ps-buffer-preview]"])
- ("Region" ,pr-:active (and (not pr-spool-p) (ps-mark-active-p))
- ["1-up" (pr-ps-region-preview 1 t) t]
- ["2-up" (pr-ps-region-preview 2 t) t]
- ["4-up" (pr-ps-region-preview 4 t) t]
- ["Other..." (pr-ps-region-preview nil t)
- :keys "\\[pr-ps-region-preview]"])
- ("Mode" ,pr-:active (and (not pr-spool-p) (pr-mode-alist-p))
- ["1-up" (pr-ps-mode-preview 1 t) t]
- ["2-up" (pr-ps-mode-preview 2 t) t]
- ["4-up" (pr-ps-mode-preview 4 t) t]
- ["Other..." (pr-ps-mode-preview nil t)
- :keys "\\[pr-ps-mode-preview]"])
- ("File"
- ["No Preprocessing..." (call-interactively 'pr-ps-file-preview)
- :keys "\\[pr-ps-file-preview]"
- ,@(funcall
- pr-:help "Preview PostScript file")]
- "--"
- ["PostScript Utility" pr-update-menus :active pr-ps-utility-alist
- ,@(funcall
- pr-:help "Select PostScript utility")]
- "--"
- ["1-up..." (pr-ps-file-up-preview 1 t t) pr-ps-utility-alist]
- ["2-up..." (pr-ps-file-up-preview 2 t t) pr-ps-utility-alist]
- ["4-up..." (pr-ps-file-up-preview 4 t t) pr-ps-utility-alist]
- ["Other..." (pr-ps-file-up-preview nil t t)
- :keys "\\[pr-ps-file-up-preview]" :active pr-ps-utility-alist]
- "--"
- ["Landscape" pr-toggle-file-landscape-menu
- :style toggle :selected pr-file-landscape
- ,@(funcall
- pr-:help "Toggle landscape for PostScript file")
- :active pr-ps-utility-alist]
- ["Duplex" pr-toggle-file-duplex-menu
- :style toggle :selected pr-file-duplex
- ,@(funcall
- pr-:help "Toggle duplex for PostScript file")
- :active pr-ps-utility-alist]
- ["Tumble" pr-toggle-file-tumble-menu
- :style toggle :selected pr-file-tumble
- ,@(funcall
- pr-:help "Toggle tumble for PostScript file")
- :active (and pr-file-duplex pr-ps-utility-alist)])
- ["Despool..." (call-interactively 'pr-despool-preview)
- :active pr-spool-p :keys "\\[pr-despool-preview]"
- ,@(funcall
- pr-:help "Despool PostScript buffer to printer or file (C-u)")])
- ("PostScript Print" :included (pr-visible-p 'postscript)
- ,@(funcall
- pr-:help "Send PostScript to printer or file (C-u)")
- ("Directory"
- ["1-up" (pr-ps-directory-ps-print 1 nil nil t) t]
- ["2-up" (pr-ps-directory-ps-print 2 nil nil t) t]
- ["4-up" (pr-ps-directory-ps-print 4 nil nil t) t]
- ["Other..." (pr-ps-directory-ps-print nil nil nil t)
- :keys "\\[pr-ps-buffer-ps-print]"])
- ("Buffer"
- ["1-up" (pr-ps-buffer-ps-print 1 t) t]
- ["2-up" (pr-ps-buffer-ps-print 2 t) t]
- ["4-up" (pr-ps-buffer-ps-print 4 t) t]
- ["Other..." (pr-ps-buffer-ps-print nil t)
- :keys "\\[pr-ps-buffer-ps-print]"])
- ("Region" ,pr-:active (ps-mark-active-p)
- ["1-up" (pr-ps-region-ps-print 1 t) t]
- ["2-up" (pr-ps-region-ps-print 2 t) t]
- ["4-up" (pr-ps-region-ps-print 4 t) t]
- ["Other..." (pr-ps-region-ps-print nil t)
- :keys "\\[pr-ps-region-ps-print]"])
- ("Mode" ,pr-:active (pr-mode-alist-p)
- ["1-up" (pr-ps-mode-ps-print 1 t) t]
- ["2-up" (pr-ps-mode-ps-print 2 t) t]
- ["4-up" (pr-ps-mode-ps-print 4 t) t]
- ["Other..." (pr-ps-mode-ps-print nil t)
- :keys "\\[pr-ps-mode-ps-print]"])
- ("File"
- ["No Preprocessing..." (call-interactively 'pr-ps-file-ps-print)
- :keys "\\[pr-ps-file-ps-print]"
- ,@(funcall
- pr-:help "Send PostScript file to printer")]
- "--"
- ["PostScript Utility" pr-update-menus :active pr-ps-utility-alist
- ,@(funcall
- pr-:help "Select PostScript utility")]
- "--"
- ["1-up..." (pr-ps-file-up-ps-print 1 t t) pr-ps-utility-alist]
- ["2-up..." (pr-ps-file-up-ps-print 2 t t) pr-ps-utility-alist]
- ["4-up..." (pr-ps-file-up-ps-print 4 t t) pr-ps-utility-alist]
- ["Other..." (pr-ps-file-up-ps-print nil t t)
- :keys "\\[pr-ps-file-up-ps-print]" :active pr-ps-utility-alist]
- "--"
- ["Landscape" pr-toggle-file-landscape-menu
- :style toggle :selected pr-file-landscape
- ,@(funcall
- pr-:help "Toggle landscape for PostScript file")
- :active pr-ps-utility-alist]
- ["Duplex" pr-toggle-file-duplex-menu
- :style toggle :selected pr-file-duplex
- ,@(funcall
- pr-:help "Toggle duplex for PostScript file")
- :active pr-ps-utility-alist]
- ["Tumble" pr-toggle-file-tumble-menu
- :style toggle :selected pr-file-tumble
- ,@(funcall
- pr-:help "Toggle tumble for PostScript file")
- :active (and pr-file-duplex pr-ps-utility-alist)])
- ["Despool..." (call-interactively 'pr-despool-ps-print)
- :active pr-spool-p :keys "\\[pr-despool-ps-print]"
- ,@(funcall
- pr-:help "Despool PostScript buffer to printer or file (C-u)")])
- ["PostScript Printers" pr-update-menus
- :active pr-ps-printer-alist :included (pr-visible-p 'postscript)
- ,@(funcall
- pr-:help "Select PostScript printer")]
+ ["PostScript Utility" pr-update-menus :active pr-ps-utility-alist
+ :help "Select PostScript utility"]
"--"
- ("Printify" :included (pr-visible-p 'text)
- ,@(funcall
- pr-:help
- "Replace non-printing chars with printable representations.")
- ["Directory" pr-printify-directory t]
- ["Buffer" pr-printify-buffer t]
- ["Region" pr-printify-region (ps-mark-active-p)])
- ("Print" :included (pr-visible-p 'text)
- ,@(funcall
- pr-:help "Send text to printer")
- ["Directory" pr-txt-directory t]
- ["Buffer" pr-txt-buffer t]
- ["Region" pr-txt-region (ps-mark-active-p)]
- ["Mode" pr-txt-mode (pr-mode-alist-p)])
- ["Text Printers" pr-update-menus
- :active pr-txt-printer-alist :included (pr-visible-p 'text)
- ,@(funcall
- pr-:help "Select text printer")]
+ ["1-up..." (pr-ps-file-up-preview 1 t t) pr-ps-utility-alist]
+ ["2-up..." (pr-ps-file-up-preview 2 t t) pr-ps-utility-alist]
+ ["4-up..." (pr-ps-file-up-preview 4 t t) pr-ps-utility-alist]
+ ["Other..." (pr-ps-file-up-preview nil t t)
+ :keys "\\[pr-ps-file-up-preview]" :active pr-ps-utility-alist]
"--"
- ["Landscape" pr-toggle-landscape-menu
- :style toggle :selected ps-landscape-mode
- :included (pr-visible-p 'postscript-options)]
- ["Print Header" pr-toggle-header-menu
- :style toggle :selected ps-print-header
- :included (pr-visible-p 'postscript-options)]
- ["Print Header Frame" pr-toggle-header-frame-menu
- :style toggle :selected ps-print-header-frame :active ps-print-header
- :included (pr-visible-p 'postscript-options)]
- ["Line Number" pr-toggle-line-menu
- :style toggle :selected ps-line-number
- :included (pr-visible-p 'postscript-options)]
- ["Zebra Stripes" pr-toggle-zebra-menu
- :style toggle :selected ps-zebra-stripes
- :included (pr-visible-p 'postscript-options)]
- ["Duplex" pr-toggle-duplex-menu
- :style toggle :selected ps-spool-duplex
- :included (pr-visible-p 'postscript-options)]
- ["Tumble" pr-toggle-tumble-menu
- :style toggle :selected ps-spool-tumble :active ps-spool-duplex
- :included (pr-visible-p 'postscript-options)]
- ["Upside-Down" pr-toggle-upside-down-menu
- :style toggle :selected ps-print-upside-down
- :included (pr-visible-p 'postscript-options)]
- ("Print All Pages" :included (pr-visible-p 'postscript-options)
- ,@(funcall
- pr-:help "Select odd/even pages/sheets to print")
- ["All Pages" (pr-even-or-odd-pages nil)
- :style radio :selected (eq ps-even-or-odd-pages nil)]
- ["Even Pages" (pr-even-or-odd-pages 'even-page)
- :style radio :selected (eq ps-even-or-odd-pages 'even-page)]
- ["Odd Pages" (pr-even-or-odd-pages 'odd-page)
- :style radio :selected (eq ps-even-or-odd-pages 'odd-page)]
- ["Even Sheets" (pr-even-or-odd-pages 'even-sheet)
- :style radio :selected (eq ps-even-or-odd-pages 'even-sheet)]
- ["Odd Sheets" (pr-even-or-odd-pages 'odd-sheet)
- :style radio :selected (eq ps-even-or-odd-pages 'odd-sheet)])
+ ["Landscape" pr-toggle-file-landscape-menu
+ :style toggle :selected pr-file-landscape
+ :help "Toggle landscape for PostScript file"
+ :active pr-ps-utility-alist]
+ ["Duplex" pr-toggle-file-duplex-menu
+ :style toggle :selected pr-file-duplex
+ :help "Toggle duplex for PostScript file"
+ :active pr-ps-utility-alist]
+ ["Tumble" pr-toggle-file-tumble-menu
+ :style toggle :selected pr-file-tumble
+ :help "Toggle tumble for PostScript file"
+ :active (and pr-file-duplex pr-ps-utility-alist)])
+ ["Despool..." (call-interactively 'pr-despool-preview)
+ :active pr-spool-p :keys "\\[pr-despool-preview]"
+ :help "Despool PostScript buffer to printer or file (C-u)"])
+ ("PostScript Print" :included (pr-visible-p 'postscript)
+ :help "Send PostScript to printer or file (C-u)"
+ ("Directory"
+ ["1-up" (pr-ps-directory-ps-print 1 nil nil t) t]
+ ["2-up" (pr-ps-directory-ps-print 2 nil nil t) t]
+ ["4-up" (pr-ps-directory-ps-print 4 nil nil t) t]
+ ["Other..." (pr-ps-directory-ps-print nil nil nil t)
+ :keys "\\[pr-ps-buffer-ps-print]"])
+ ("Buffer"
+ ["1-up" (pr-ps-buffer-ps-print 1 t) t]
+ ["2-up" (pr-ps-buffer-ps-print 2 t) t]
+ ["4-up" (pr-ps-buffer-ps-print 4 t) t]
+ ["Other..." (pr-ps-buffer-ps-print nil t)
+ :keys "\\[pr-ps-buffer-ps-print]"])
+ ("Region" :active (ps-mark-active-p)
+ ["1-up" (pr-ps-region-ps-print 1 t) t]
+ ["2-up" (pr-ps-region-ps-print 2 t) t]
+ ["4-up" (pr-ps-region-ps-print 4 t) t]
+ ["Other..." (pr-ps-region-ps-print nil t)
+ :keys "\\[pr-ps-region-ps-print]"])
+ ("Mode" :active (pr-mode-alist-p)
+ ["1-up" (pr-ps-mode-ps-print 1 t) t]
+ ["2-up" (pr-ps-mode-ps-print 2 t) t]
+ ["4-up" (pr-ps-mode-ps-print 4 t) t]
+ ["Other..." (pr-ps-mode-ps-print nil t)
+ :keys "\\[pr-ps-mode-ps-print]"])
+ ("File"
+ ["No Preprocessing..." (call-interactively 'pr-ps-file-ps-print)
+ :keys "\\[pr-ps-file-ps-print]"
+ :help "Send PostScript file to printer"]
"--"
- ["Spool Buffer" pr-toggle-spool-menu
- :style toggle :selected pr-spool-p
- :included (pr-visible-p 'postscript-process)
- ,@(funcall
- pr-:help "Toggle PostScript spooling")]
- ["Print with faces" pr-toggle-faces-menu
- :style toggle :selected pr-faces-p
- :included (pr-visible-p 'postscript-process)
- ,@(funcall
- pr-:help "Toggle PostScript printing with faces")]
- ["Print via Ghostscript" pr-toggle-ghostscript-menu
- :style toggle :selected pr-print-using-ghostscript
- :included (pr-visible-p 'postscript-process)
- ,@(funcall
- pr-:help "Toggle PostScript generation using ghostscript")]
+ ["PostScript Utility" pr-update-menus :active pr-ps-utility-alist
+ :help "Select PostScript utility"]
"--"
- ["Auto Region" pr-toggle-region-menu
- :style toggle :selected pr-auto-region
- :included (pr-visible-p 'printing)]
- ["Auto Mode" pr-toggle-mode-menu
- :style toggle :selected pr-auto-mode
- :included (pr-visible-p 'printing)]
- ["Menu Lock" pr-toggle-lock-menu
- :style toggle :selected pr-menu-lock
- :included (pr-visible-p 'printing)]
+ ["1-up..." (pr-ps-file-up-ps-print 1 t t) pr-ps-utility-alist]
+ ["2-up..." (pr-ps-file-up-ps-print 2 t t) pr-ps-utility-alist]
+ ["4-up..." (pr-ps-file-up-ps-print 4 t t) pr-ps-utility-alist]
+ ["Other..." (pr-ps-file-up-ps-print nil t t)
+ :keys "\\[pr-ps-file-up-ps-print]" :active pr-ps-utility-alist]
"--"
- ("Customize" :included (pr-visible-p 'help)
- ["printing" pr-customize t]
- ["ps-print" ps-print-customize t]
- ["lpr" lpr-customize t])
- ("Show Settings" :included (pr-visible-p 'help)
- ["printing" pr-show-pr-setup t]
- ["ps-print" pr-show-ps-setup t]
- ["lpr" pr-show-lpr-setup t])
- ["Help" pr-help :active t :included (pr-visible-p 'help)]
- )))
+ ["Landscape" pr-toggle-file-landscape-menu
+ :style toggle :selected pr-file-landscape
+ :help "Toggle landscape for PostScript file"
+ :active pr-ps-utility-alist]
+ ["Duplex" pr-toggle-file-duplex-menu
+ :style toggle :selected pr-file-duplex
+ :help "Toggle duplex for PostScript file"
+ :active pr-ps-utility-alist]
+ ["Tumble" pr-toggle-file-tumble-menu
+ :style toggle :selected pr-file-tumble
+ :help "Toggle tumble for PostScript file"
+ :active (and pr-file-duplex pr-ps-utility-alist)])
+ ["Despool..." (call-interactively 'pr-despool-ps-print)
+ :active pr-spool-p :keys "\\[pr-despool-ps-print]"
+ :help "Despool PostScript buffer to printer or file (C-u)"])
+ ["PostScript Printers" pr-update-menus
+ :active pr-ps-printer-alist :included (pr-visible-p 'postscript)
+ :help "Select PostScript printer"]
+ "--"
+ ("Printify" :included (pr-visible-p 'text)
+ :help
+ "Replace non-printing chars with printable representations."
+ ["Directory" pr-printify-directory t]
+ ["Buffer" pr-printify-buffer t]
+ ["Region" pr-printify-region (ps-mark-active-p)])
+ ("Print" :included (pr-visible-p 'text)
+ :help "Send text to printer"
+ ["Directory" pr-txt-directory t]
+ ["Buffer" pr-txt-buffer t]
+ ["Region" pr-txt-region (ps-mark-active-p)]
+ ["Mode" pr-txt-mode (pr-mode-alist-p)])
+ ["Text Printers" pr-update-menus
+ :active pr-txt-printer-alist :included (pr-visible-p 'text)
+ :help "Select text printer"]
+ "--"
+ ["Landscape" pr-toggle-landscape-menu
+ :style toggle :selected ps-landscape-mode
+ :included (pr-visible-p 'postscript-options)]
+ ["Print Header" pr-toggle-header-menu
+ :style toggle :selected ps-print-header
+ :included (pr-visible-p 'postscript-options)]
+ ["Print Header Frame" pr-toggle-header-frame-menu
+ :style toggle :selected ps-print-header-frame :active ps-print-header
+ :included (pr-visible-p 'postscript-options)]
+ ["Line Number" pr-toggle-line-menu
+ :style toggle :selected ps-line-number
+ :included (pr-visible-p 'postscript-options)]
+ ["Zebra Stripes" pr-toggle-zebra-menu
+ :style toggle :selected ps-zebra-stripes
+ :included (pr-visible-p 'postscript-options)]
+ ["Duplex" pr-toggle-duplex-menu
+ :style toggle :selected ps-spool-duplex
+ :included (pr-visible-p 'postscript-options)]
+ ["Tumble" pr-toggle-tumble-menu
+ :style toggle :selected ps-spool-tumble :active ps-spool-duplex
+ :included (pr-visible-p 'postscript-options)]
+ ["Upside-Down" pr-toggle-upside-down-menu
+ :style toggle :selected ps-print-upside-down
+ :included (pr-visible-p 'postscript-options)]
+ ("Print All Pages" :included (pr-visible-p 'postscript-options)
+ :help "Select odd/even pages/sheets to print"
+ ["All Pages" (pr-even-or-odd-pages nil)
+ :style radio :selected (eq ps-even-or-odd-pages nil)]
+ ["Even Pages" (pr-even-or-odd-pages 'even-page)
+ :style radio :selected (eq ps-even-or-odd-pages 'even-page)]
+ ["Odd Pages" (pr-even-or-odd-pages 'odd-page)
+ :style radio :selected (eq ps-even-or-odd-pages 'odd-page)]
+ ["Even Sheets" (pr-even-or-odd-pages 'even-sheet)
+ :style radio :selected (eq ps-even-or-odd-pages 'even-sheet)]
+ ["Odd Sheets" (pr-even-or-odd-pages 'odd-sheet)
+ :style radio :selected (eq ps-even-or-odd-pages 'odd-sheet)])
+ "--"
+ ["Spool Buffer" pr-toggle-spool-menu
+ :style toggle :selected pr-spool-p
+ :included (pr-visible-p 'postscript-process)
+ :help "Toggle PostScript spooling"]
+ ["Print with faces" pr-toggle-faces-menu
+ :style toggle :selected pr-faces-p
+ :included (pr-visible-p 'postscript-process)
+ :help "Toggle PostScript printing with faces"]
+ ["Print via Ghostscript" pr-toggle-ghostscript-menu
+ :style toggle :selected pr-print-using-ghostscript
+ :included (pr-visible-p 'postscript-process)
+ :help "Toggle PostScript generation using ghostscript"]
+ "--"
+ ["Auto Region" pr-toggle-region-menu
+ :style toggle :selected pr-auto-region
+ :included (pr-visible-p 'printing)]
+ ["Auto Mode" pr-toggle-mode-menu
+ :style toggle :selected pr-auto-mode
+ :included (pr-visible-p 'printing)]
+ ["Menu Lock" pr-toggle-lock-menu
+ :style toggle :selected pr-menu-lock
+ :included (pr-visible-p 'printing)]
+ "--"
+ ("Customize" :included (pr-visible-p 'help)
+ ["printing" pr-customize t]
+ ["ps-print" ps-print-customize t]
+ ["lpr" lpr-customize t])
+ ("Show Settings" :included (pr-visible-p 'help)
+ ["printing" pr-show-pr-setup t]
+ ["ps-print" pr-show-ps-setup t]
+ ["lpr" pr-show-lpr-setup t])
+ ["Help" pr-help :active t :included (pr-visible-p 'help)]
+ ))
(defun pr-menu-bind ()
@@ -3453,19 +3000,17 @@ Calls `pr-update-menus' to adjust menus."
;; Key binding
-(let ((pr-print-key (if (featurep 'xemacs)
- 'f22 ; XEmacs
- 'print))) ; GNU Emacs
- (global-set-key `[,pr-print-key] 'pr-ps-fast-fire)
- ;; Well, M-print and S-print are used because in my keyboard S-print works
- ;; and M-print doesn't. But M-print can work in other keyboard.
- (global-set-key `[(meta ,pr-print-key)] 'pr-ps-mode-using-ghostscript)
- (global-set-key `[(shift ,pr-print-key)] 'pr-ps-mode-using-ghostscript)
- ;; Well, C-print and C-M-print are used because in my keyboard C-M-print works
- ;; and C-print doesn't. But C-print can work in other keyboard.
- (global-set-key `[(control ,pr-print-key)] 'pr-txt-fast-fire)
- (global-set-key `[(control meta ,pr-print-key)] 'pr-txt-fast-fire))
-
+;; FIXME: These should be moved to a function so that just loading the file
+;; doesn't affect the global keymap!
+(global-set-key [print] 'pr-ps-fast-fire)
+;; Well, M-print and S-print are used because on my keyboard S-print works
+;; and M-print doesn't. But M-print can work on other keyboards.
+(global-set-key [(meta print)] 'pr-ps-mode-using-ghostscript)
+(global-set-key [(shift print)] 'pr-ps-mode-using-ghostscript)
+;; Well, C-print and C-M-print are used because in my keyboard C-M-print works
+;; and C-print doesn't. But C-print can work in other keyboard.
+(global-set-key [(control print)] 'pr-txt-fast-fire)
+(global-set-key [(control meta print)] 'pr-txt-fast-fire)
;;; You can also use something like:
;;;(global-set-key "\C-ci" 'pr-interface)
@@ -3962,13 +3507,16 @@ file name.
See also documentation for `pr-list-directory'."
(interactive (pr-interactive-ps-dir-args (pr-prompt "PS preview dir")))
- (pr-set-ps-dir-args 'n-up 'dir 'file-regexp 'filename
- (pr-prompt "PS preview dir"))
- (setq filename (pr-ps-file filename))
- (pr-ps-file-list n-up dir file-regexp filename)
- (or pr-spool-p
- (pr-ps-file-preview filename)))
-
+ (defvar pr--n-up) (defvar pr--dir) (defvar pr--file-regexp)
+ (defvar pr--filename)
+ (let ((pr--n-up n-up) (pr--dir dir) (pr--file-regexp file-regexp)
+ (pr--filename filename))
+ (pr-set-ps-dir-args 'pr--n-up 'pr--dir 'pr--file-regexp 'pr--filename
+ (pr-prompt "PS preview dir"))
+ (setq pr--filename (pr-ps-file pr--filename))
+ (pr-ps-file-list pr--n-up pr--dir pr--file-regexp pr--filename)
+ (or pr-spool-p
+ (pr-ps-file-preview pr--filename))))
;;;###autoload
(defun pr-ps-directory-using-ghostscript (n-up dir file-regexp &optional filename)
@@ -3988,12 +3536,16 @@ file name.
See also documentation for `pr-list-directory'."
(interactive (pr-interactive-ps-dir-args (pr-prompt "PS print dir GS")))
- (pr-set-ps-dir-args 'n-up 'dir 'file-regexp 'filename
- (pr-prompt "PS print dir GS"))
- (let ((file (pr-ps-file filename)))
- (pr-ps-file-list n-up dir file-regexp file)
- (pr-ps-file-using-ghostscript file)
- (or filename (pr-delete-file file))))
+ (defvar pr--n-up) (defvar pr--dir) (defvar pr--file-regexp)
+ (defvar pr--filename)
+ (let ((pr--n-up n-up) (pr--dir dir) (pr--file-regexp file-regexp)
+ (pr--filename filename))
+ (pr-set-ps-dir-args 'pr--n-up 'pr--dir 'pr--file-regexp 'pr--filename
+ (pr-prompt "PS print dir GS"))
+ (let ((file (pr-ps-file pr--filename)))
+ (pr-ps-file-list pr--n-up pr--dir pr--file-regexp file)
+ (pr-ps-file-using-ghostscript file)
+ (or pr--filename (pr-delete-file file)))))
;;;###autoload
@@ -4014,12 +3566,16 @@ file name.
See also documentation for `pr-list-directory'."
(interactive (pr-interactive-ps-dir-args (pr-prompt "PS print dir")))
- (pr-set-ps-dir-args 'n-up 'dir 'file-regexp 'filename
- (pr-prompt "PS print dir"))
- (let ((file (pr-ps-file filename)))
- (pr-ps-file-list n-up dir file-regexp file)
- (pr-ps-file-print file)
- (or filename (pr-delete-file file))))
+ (defvar pr--n-up) (defvar pr--dir) (defvar pr--file-regexp)
+ (defvar pr--filename)
+ (let ((pr--n-up n-up) (pr--dir dir) (pr--file-regexp file-regexp)
+ (pr--filename filename))
+ (pr-set-ps-dir-args 'pr--n-up 'pr--dir 'pr--file-regexp 'pr--filename
+ (pr-prompt "PS print dir"))
+ (let ((file (pr-ps-file pr--filename)))
+ (pr-ps-file-list pr--n-up pr--dir pr--file-regexp file)
+ (pr-ps-file-print file)
+ (or pr--filename (pr-delete-file file)))))
;;;###autoload
@@ -4043,11 +3599,16 @@ file name.
See also documentation for `pr-list-directory'."
(interactive (pr-interactive-ps-dir-args
(pr-prompt (pr-prompt-gs "PS print dir"))))
- (pr-set-ps-dir-args 'n-up 'dir 'file-regexp 'filename
- (pr-prompt (pr-prompt-gs "PS print dir")))
- (if (pr-using-ghostscript-p)
- (pr-ps-directory-using-ghostscript n-up dir file-regexp filename)
- (pr-ps-directory-print n-up dir file-regexp filename)))
+ (defvar pr--n-up) (defvar pr--dir) (defvar pr--file-regexp)
+ (defvar pr--filename)
+ (let ((pr--n-up n-up) (pr--dir dir) (pr--file-regexp file-regexp)
+ (pr--filename filename))
+ (pr-set-ps-dir-args 'pr--n-up 'pr--dir 'pr--file-regexp 'pr--filename
+ (pr-prompt (pr-prompt-gs "PS print dir")))
+ (funcall (if (pr-using-ghostscript-p)
+ #'pr-ps-directory-using-ghostscript
+ #'pr-ps-directory-print)
+ pr--n-up pr--dir pr--file-regexp pr--filename)))
;;;###autoload
@@ -4191,11 +3752,13 @@ See also `pr-ps-buffer-ps-print'."
See also `pr-ps-buffer-preview'."
(interactive (pr-interactive-n-up-file "PS preview mode"))
- (pr-set-n-up-and-filename 'n-up 'filename "PS preview mode")
- (let ((file (pr-ps-file filename)))
- (and (pr-ps-mode n-up file)
- (not pr-spool-p)
- (pr-ps-file-preview file))))
+ (defvar pr--n-up) (defvar pr--filename)
+ (let ((pr--n-up n-up) (pr--filename filename))
+ (pr-set-n-up-and-filename 'pr--n-up 'pr--filename "PS preview mode")
+ (let ((file (pr-ps-file pr--filename)))
+ (and (pr-ps-mode pr--n-up file)
+ (not pr-spool-p)
+ (pr-ps-file-preview file)))))
;;;###autoload
@@ -4204,12 +3767,14 @@ See also `pr-ps-buffer-preview'."
See also `pr-ps-buffer-using-ghostscript'."
(interactive (pr-interactive-n-up-file "PS print GS mode"))
- (pr-set-n-up-and-filename 'n-up 'filename "PS print GS mode")
- (let ((file (pr-ps-file filename)))
- (when (and (pr-ps-mode n-up file)
- (not pr-spool-p))
- (pr-ps-file-using-ghostscript file)
- (or filename (pr-delete-file file)))))
+ (defvar pr--n-up) (defvar pr--filename)
+ (let ((pr--n-up n-up) (pr--filename filename))
+ (pr-set-n-up-and-filename 'pr--n-up 'pr--filename "PS print GS mode")
+ (let ((file (pr-ps-file pr--filename)))
+ (when (and (pr-ps-mode pr--n-up file)
+ (not pr-spool-p))
+ (pr-ps-file-using-ghostscript file)
+ (or pr--filename (pr-delete-file file))))))
;;;###autoload
@@ -4218,8 +3783,10 @@ See also `pr-ps-buffer-using-ghostscript'."
See also `pr-ps-buffer-print'."
(interactive (pr-interactive-n-up-file "PS print mode"))
- (pr-set-n-up-and-filename 'n-up 'filename "PS print mode")
- (pr-ps-mode n-up filename))
+ (defvar pr--n-up) (defvar pr--filename)
+ (let ((pr--n-up n-up) (pr--filename filename))
+ (pr-set-n-up-and-filename 'pr--n-up 'pr--filename "PS print mode")
+ (pr-ps-mode pr--n-up pr--filename)))
;;;###autoload
@@ -4247,8 +3814,10 @@ prompts for FILE(name)-REGEXP.
See also documentation for `pr-list-directory'."
(interactive (pr-interactive-dir-args "Printify dir"))
- (pr-set-dir-args 'dir 'file-regexp "Printify dir")
- (pr-file-list dir file-regexp 'pr-printify-buffer))
+ (defvar pr--dir) (defvar pr--file-regexp)
+ (let ((pr--dir dir) (pr--file-regexp file-regexp))
+ (pr-set-dir-args 'pr--dir 'pr--file-regexp "Printify dir")
+ (pr-file-list pr--dir pr--file-regexp 'pr-printify-buffer)))
;;;###autoload
@@ -4283,8 +3852,10 @@ prompts for FILE(name)-REGEXP.
See also documentation for `pr-list-directory'."
(interactive (pr-interactive-dir-args "Print dir"))
- (pr-set-dir-args 'dir 'file-regexp "Print dir")
- (pr-file-list dir file-regexp 'pr-txt-buffer))
+ (defvar pr--dir) (defvar pr--file-regexp)
+ (let ((pr--dir dir) (pr--file-regexp file-regexp))
+ (pr-set-dir-args 'pr--dir 'pr--file-regexp "Print dir")
+ (pr-file-list pr--dir pr--file-regexp 'pr-txt-buffer)))
;;;###autoload
@@ -4406,10 +3977,12 @@ image in a file with that name."
(defun pr-ps-file-up-preview (n-up ifilename &optional ofilename)
"Preview PostScript file FILENAME."
(interactive (pr-interactive-n-up-inout "PS preview"))
- (let ((outfile (pr-ps-utility-args 'n-up 'ifilename 'ofilename
- "PS preview ")))
- (pr-ps-utility-process n-up ifilename outfile)
- (pr-ps-file-preview outfile)))
+ (defvar pr--n-up) (defvar pr--ifilename) (defvar pr--ofilename)
+ (let ((pr--n-up n-up) (pr--ifilename ifilename) (pr--ofilename ofilename))
+ (let ((outfile (pr-ps-utility-args 'pr--n-up 'pr--ifilename 'pr--ofilename
+ "PS preview ")))
+ (pr-ps-utility-process pr--n-up pr--ifilename outfile)
+ (pr-ps-file-preview outfile))))
;;;###autoload
@@ -4417,15 +3990,18 @@ image in a file with that name."
"Print PostScript file FILENAME using ghostscript."
(interactive (list (pr-ps-infile-preprint "Print preview ")))
(and (stringp filename) (file-exists-p filename)
- (let* ((file (pr-expand-file-name filename))
- (tempfile (pr-dosify-file-name (make-temp-file file))))
+ (let* ((file (expand-file-name filename))
+ (tempfile (make-temp-file file)))
;; gs use
(pr-call-process pr-gs-command
(format "-sDEVICE=%s" pr-gs-device)
(format "-r%d" pr-gs-resolution)
(pr-switches-string pr-gs-switches "pr-gs-switches")
- (format "-sOutputFile=\"%s\"" tempfile)
- file
+ (format "-sOutputFile=\"%s\""
+ ;; FIXME: Do we need to dosify here really?
+ (pr-dosify-file-name tempfile))
+ ;; FIXME: Do we need to dosify here really?
+ (pr-dosify-file-name file)
"-c quit")
;; printing
(pr-ps-file-print tempfile)
@@ -4439,7 +4015,7 @@ image in a file with that name."
(interactive (list (pr-ps-infile-preprint "Print ")))
(and (stringp filename) (file-exists-p filename)
;; printing
- (let ((file (pr-expand-file-name filename)))
+ (let ((file (expand-file-name filename)))
(if (string= pr-ps-command "")
;; default action
(let ((ps-spool-buffer (get-buffer-create ps-spool-buffer-name)))
@@ -4448,16 +4024,16 @@ image in a file with that name."
(insert-file-contents-literally file))
(pr-despool-print))
;; use `pr-ps-command' to print
- (apply 'pr-call-process
+ (apply #'pr-call-process
pr-ps-command
(pr-switches-string pr-ps-switches "pr-ps-switches")
(if (string-match "cp" pr-ps-command)
;; for "cp" (cmd in out)
- (list file
+ (list (pr-dosify-file-name file)
(concat pr-ps-printer-switch pr-ps-printer))
;; else, for others (cmd out in)
(list (concat pr-ps-printer-switch pr-ps-printer)
- file)))))))
+ (pr-dosify-file-name file))))))))
;;;###autoload
@@ -4492,14 +4068,16 @@ file name."
(if pr-print-using-ghostscript
"PS print GS"
"PS print")))
- (let ((outfile (pr-ps-utility-args 'n-up 'ifilename 'ofilename
- (if pr-print-using-ghostscript
- "PS print GS "
- "PS print "))))
- (pr-ps-utility-process n-up ifilename outfile)
- (unless ofilename
- (pr-ps-file-ps-print outfile)
- (pr-delete-file outfile))))
+ (defvar pr--n-up) (defvar pr--ifilename) (defvar pr--ofilename)
+ (let ((pr--n-up n-up) (pr--ifilename ifilename) (pr--ofilename ofilename))
+ (let ((outfile (pr-ps-utility-args 'pr--n-up 'pr--ifilename 'pr--ofilename
+ (if pr-print-using-ghostscript
+ "PS print GS "
+ "PS print "))))
+ (pr-ps-utility-process pr--n-up pr--ifilename outfile)
+ (unless pr--ofilename
+ (pr-ps-file-ps-print outfile)
+ (pr-delete-file outfile)))))
;;;###autoload
@@ -5210,9 +4788,9 @@ If menu binding was not done, calls `pr-menu-bind'."
(let ((sym (car elt)))
(vector
(symbol-name sym)
- (list fun (list 'quote sym) nil (list 'quote entry) index)
+ `(,fun ',sym nil ',entry ',index)
:style 'radio
- :selected (list 'eq var-sym (list 'quote sym)))))
+ :selected `(eq ,var-sym ',sym))))
alist)))
@@ -5224,7 +4802,7 @@ If menu binding was not done, calls `pr-menu-bind'."
value))
(setq pr-ps-utility value)
(pr-eval-alist (nthcdr 9 item)))
- (pr-update-mode-line))
+ (force-mode-line-update))
(defun pr-ps-set-printer (value)
@@ -5234,7 +4812,7 @@ If menu binding was not done, calls `pr-menu-bind'."
"Invalid PostScript printer name `%s' for variable `pr-ps-name'"
value))
(setq pr-ps-name value
- pr-ps-command (pr-dosify-file-name (nth 0 ps))
+ pr-ps-command (nth 0 ps)
pr-ps-switches (nth 1 ps)
pr-ps-printer-switch (nth 2 ps)
pr-ps-printer (nth 3 ps))
@@ -5251,7 +4829,7 @@ If menu binding was not done, calls `pr-menu-bind'."
(t "-P")
)))
(pr-eval-alist (nthcdr 4 ps)))
- (pr-update-mode-line))
+ (force-mode-line-update))
(defun pr-txt-set-printer (value)
@@ -5260,7 +4838,7 @@ If menu binding was not done, calls `pr-menu-bind'."
(error "Invalid text printer name `%s' for variable `pr-txt-name'"
value))
(setq pr-txt-name value
- pr-txt-command (pr-dosify-file-name (nth 0 txt))
+ pr-txt-command (nth 0 txt)
pr-txt-switches (nth 1 txt)
pr-txt-printer (nth 2 txt)))
(or (stringp pr-txt-command)
@@ -5269,30 +4847,28 @@ If menu binding was not done, calls `pr-menu-bind'."
(lpr-lp-system "lp")
(t "lpr")
)))
- (pr-update-mode-line))
+ (force-mode-line-update))
(defun pr-eval-alist (alist)
- (mapcar #'(lambda (option)
- (let ((var-sym (car option))
- (value (cdr option)))
- (if (eq var-sym 'inherits-from:)
- (pr-eval-setting-alist value 'global)
- (set var-sym (eval value)))))
- alist))
+ (dolist (option alist)
+ (let ((var-sym (car option))
+ (value (cdr option)))
+ (if (eq var-sym 'inherits-from:)
+ (pr-eval-setting-alist value 'global)
+ (set var-sym (eval value))))))
(defun pr-eval-local-alist (alist)
(let (local-list)
- (mapc #'(lambda (option)
- (let ((var-sym (car option))
- (value (cdr option)))
- (setq local-list
- (if (eq var-sym 'inherits-from:)
- (nconc (pr-eval-setting-alist value) local-list)
- (set (make-local-variable var-sym) (eval value))
- (cons var-sym local-list)))))
- alist)
+ (dolist (option alist)
+ (let ((var-sym (car option))
+ (value (cdr option)))
+ (setq local-list
+ (if (eq var-sym 'inherits-from:)
+ (nconc (pr-eval-setting-alist value) local-list)
+ (set (make-local-variable var-sym) (eval value))
+ (cons var-sym local-list)))))
local-list))
@@ -5338,7 +4914,7 @@ If menu binding was not done, calls `pr-menu-bind'."
(defun pr-kill-local-variable (local-var-list)
- (mapcar 'kill-local-variable local-var-list))
+ (mapcar #'kill-local-variable local-var-list))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -5526,10 +5102,6 @@ If menu binding was not done, calls `pr-menu-bind'."
(delete-file file)))
-(defun pr-expand-file-name (filename)
- (pr-dosify-file-name (expand-file-name filename)))
-
-
(defun pr-ps-outfile-preprint (&optional mess)
(let* ((prompt (format "%soutput PostScript file name: " (or mess "")))
(res (read-file-name prompt default-directory "" nil)))
@@ -5549,7 +5121,7 @@ If menu binding was not done, calls `pr-menu-bind'."
(format "File %s; PostScript file: " prompt)
(file-name-directory res) nil nil
(file-name-nondirectory res))))
- (pr-expand-file-name res)))
+ (expand-file-name res)))
(defun pr-ps-infile-preprint (&optional mess)
@@ -5569,7 +5141,7 @@ If menu binding was not done, calls `pr-menu-bind'."
(format "File %s; PostScript file: " prompt)
(file-name-directory res) nil nil
(file-name-nondirectory res))))
- (pr-expand-file-name res)))
+ (expand-file-name res)))
(defun pr-ps-utility-args (n-up-sym infile-sym outfile-sym prompt)
@@ -5582,13 +5154,10 @@ If menu binding was not done, calls `pr-menu-bind'."
(set infile-sym (pr-ps-infile-preprint prompt)))
(or (symbol-value infile-sym)
(error "%s: input PostScript file name is missing" prompt))
- (set infile-sym (pr-dosify-file-name (symbol-value infile-sym)))
;; output file
(and (eq (symbol-value outfile-sym) t)
(set outfile-sym (and current-prefix-arg
(pr-ps-outfile-preprint prompt))))
- (and (symbol-value outfile-sym)
- (set outfile-sym (pr-dosify-file-name (symbol-value outfile-sym))))
(pr-ps-file (symbol-value outfile-sym)))
@@ -5608,9 +5177,9 @@ If menu binding was not done, calls `pr-menu-bind'."
(and pr-file-landscape (nth 4 item))
(and pr-file-duplex (nth 5 item))
(and pr-file-tumble (nth 6 item))
- (pr-expand-file-name infile)
+ (pr-dosify-file-name (expand-file-name infile))
(nth 7 item)
- (pr-expand-file-name outfile)))))
+ (pr-dosify-file-name (expand-file-name outfile))))))
(defun pr-remove-nil-from-list (lst)
@@ -5640,7 +5209,7 @@ If menu binding was not done, calls `pr-menu-bind'."
(with-file-modes pr-file-modes
(setq status
(condition-case data
- (apply 'call-process cmd nil buffer nil args)
+ (apply #'call-process cmd nil buffer nil args)
((quit error)
(error-message-string data)))))
;; *Printing Command Output* == show exit status
@@ -5666,47 +5235,53 @@ If menu binding was not done, calls `pr-menu-bind'."
;; If SWITCHES is nil, return nil.
;; Otherwise, return the list of string in a string.
(and switches
- (mapconcat 'identity (pr-switches switches mess) " ")))
+ (mapconcat #'identity (pr-switches switches mess) " ")))
(defun pr-switches (switches mess)
(or (listp switches)
(error "%S should have a list of strings" mess))
- (lpr-flatten-list ; dynamic evaluation
+ (flatten-tree ; dynamic evaluation
(mapcar #'lpr-eval-switch switches)))
(defun pr-ps-preview (kind n-up filename mess)
- (pr-set-n-up-and-filename 'n-up 'filename mess)
- (let ((file (pr-ps-file filename)))
- (pr-text2ps kind n-up file)
- (or pr-spool-p (pr-ps-file-preview file))))
+ (defvar pr--n-up) (defvar pr--filename)
+ (let ((pr--n-up n-up) (pr--filename filename))
+ (pr-set-n-up-and-filename 'pr--n-up 'pr--filename mess)
+ (let ((file (pr-ps-file pr--filename)))
+ (pr-text2ps kind pr--n-up file)
+ (or pr-spool-p (pr-ps-file-preview file)))))
(defun pr-ps-using-ghostscript (kind n-up filename mess)
- (pr-set-n-up-and-filename 'n-up 'filename mess)
- (let ((file (pr-ps-file filename)))
- (pr-text2ps kind n-up file)
- (unless (or pr-spool-p filename)
- (pr-ps-file-using-ghostscript file)
- (pr-delete-file file))))
+ (defvar pr--n-up) (defvar pr--filename)
+ (let ((pr--n-up n-up) (pr--filename filename))
+ (pr-set-n-up-and-filename 'pr--n-up 'pr--filename mess)
+ (let ((file (pr-ps-file pr--filename)))
+ (pr-text2ps kind pr--n-up file)
+ (unless (or pr-spool-p pr--filename)
+ (pr-ps-file-using-ghostscript file)
+ (pr-delete-file file)))))
(defun pr-ps-print (kind n-up filename mess)
- (pr-set-n-up-and-filename 'n-up 'filename mess)
- (let ((file (pr-ps-file filename)))
- (pr-text2ps kind n-up file)
- (unless (or pr-spool-p filename)
- (pr-ps-file-print file)
- (pr-delete-file file))))
+ (defvar pr--n-up) (defvar pr--filename)
+ (let ((pr--n-up n-up) (pr--filename filename))
+ (pr-set-n-up-and-filename 'pr--n-up 'pr--filename mess)
+ (let ((file (pr-ps-file pr--filename)))
+ (pr-text2ps kind pr--n-up file)
+ (unless (or pr-spool-p pr--filename)
+ (pr-ps-file-print file)
+ (pr-delete-file file)))))
(defun pr-ps-file (&optional filename)
- (pr-dosify-file-name (or filename
- (make-temp-file
- (convert-standard-filename
- (expand-file-name pr-ps-temp-file pr-temp-dir))
- nil ".ps"))))
+ (or filename
+ (make-temp-file
+ (convert-standard-filename
+ (expand-file-name pr-ps-temp-file pr-temp-dir))
+ nil ".ps")))
(defun pr-interactive-n-up (mess)
@@ -5714,7 +5289,7 @@ If menu binding was not done, calls `pr-menu-bind'."
(save-match-data
(let* ((fmt-prompt "%s[%s] N-up printing (default 1): ")
(prompt "")
- (str (pr-read-string (format fmt-prompt prompt mess) "1" nil "1"))
+ (str (read-string (format fmt-prompt prompt mess) nil nil "1"))
int)
(while (if (string-match "^\\s *[0-9]+$" str)
(setq int (string-to-number str)
@@ -5724,7 +5299,7 @@ If menu binding was not done, calls `pr-menu-bind'."
(setq prompt "Invalid integer syntax; "))
(ding)
(setq str
- (pr-read-string (format fmt-prompt prompt mess) str nil "1")))
+ (read-string (format fmt-prompt prompt mess) str nil "1")))
int)))
@@ -5749,7 +5324,7 @@ If menu binding was not done, calls `pr-menu-bind'."
(defun pr-interactive-regexp (mess)
- (pr-read-string (format "[%s] File regexp to print: " mess) "" nil ""))
+ (read-string (format "[%s] File regexp to print: " mess) nil nil ""))
(defun pr-interactive-dir-args (mess)
@@ -5796,9 +5371,7 @@ If menu binding was not done, calls `pr-menu-bind'."
(and (not pr-spool-p)
(eq (symbol-value filename-sym) t)
(set filename-sym (and current-prefix-arg
- (ps-print-preprint current-prefix-arg))))
- (and (symbol-value filename-sym)
- (set filename-sym (pr-dosify-file-name (symbol-value filename-sym)))))
+ (ps-print-preprint current-prefix-arg)))))
(defun pr-set-n-up-and-filename (n-up-sym filename-sym mess)
@@ -5875,7 +5448,7 @@ If menu binding was not done, calls `pr-menu-bind'."
(defun pr-ps-file-list (n-up dir file-regexp filename)
- (pr-delete-file-if-exists (setq filename (pr-expand-file-name filename)))
+ (pr-delete-file-if-exists (setq filename (expand-file-name filename)))
(let ((pr-spool-p t))
(pr-file-list dir file-regexp
#'(lambda ()
@@ -5941,15 +5514,14 @@ If Emacs is running on Windows 95/98/NT/2000, tries to find COMMAND,
COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
(if (string= command "")
command
- (pr-dosify-file-name
- (or (pr-find-command command)
- (pr-path-command (cond (pr-cygwin-system 'cygwin)
- (lpr-windows-system 'windows)
- (t 'unix))
- (file-name-nondirectory command)
- nil)
- (error "Command not found: %s"
- (file-name-nondirectory command))))))
+ (or (pr-find-command command)
+ (pr-path-command (cond (pr-cygwin-system 'cygwin)
+ (lpr-windows-system 'windows)
+ (t 'unix))
+ (file-name-nondirectory command)
+ nil)
+ (error "Command not found: %s"
+ (file-name-nondirectory command)))))
(defun pr-path-command (symbol command sym-list)
@@ -6004,12 +5576,6 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
;; Printing Interface (inspired by ps-print-interface.el)
-(eval-when-compile
- (require 'cus-edit)
- (require 'wid-edit)
- (require 'widget))
-
-
(defvar pr-i-window-configuration nil)
(defvar pr-i-buffer nil)
@@ -6027,20 +5593,13 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
(defvar pr-i-ps-send 'printer)
-(defvar pr-interface-map nil
- "Keymap for pr-interface.")
-
-(unless pr-interface-map
+(defvar pr-interface-map
(let ((map (make-sparse-keymap)))
- (cond ((featurep 'xemacs) ; XEmacs
- (pr-set-keymap-parents map (list widget-keymap))
- (pr-set-keymap-name map 'pr-interface-map))
- (t ; GNU Emacs
- (pr-set-keymap-parents map widget-keymap)))
+ (set-keymap-parent map widget-keymap)
(define-key map "q" 'pr-interface-quit)
(define-key map "?" 'pr-interface-help)
- (setq pr-interface-map map)))
-
+ map)
+ "Keymap for pr-interface.")
(defmacro pr-interface-save (&rest body)
`(with-current-buffer pr-i-buffer
@@ -6111,15 +5670,13 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
(setq found (string-match (car ignore) name)
ignore (cdr ignore)))
(or found
- (setq choices
- (cons (list 'quote
- (list 'choice-item
- :format "%[%t%]"
- name))
- choices)))))
+ (push (list 'choice-item
+ :format "%[%t%]"
+ name)
+ choices))))
(nreverse choices))
" Buffer : " nil
- '(progn
+ (lambda ()
(pr-interface-save
(setq pr-i-region (ps-mark-active-p)
pr-i-mode (pr-mode-alist-p)))
@@ -6345,11 +5902,10 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
(pr-insert-italic "\n\nSelect Pages : " 2 14)
(pr-insert-menu "Page Parity" 'ps-even-or-odd-pages
(mapcar #'(lambda (alist)
- (list 'quote
- (list 'choice-item
- :format "%[%t%]"
- :tag (cdr alist)
- :value (car alist))))
+ (list 'choice-item
+ :format "%[%t%]"
+ :tag (cdr alist)
+ :value (car alist)))
pr-even-or-odd-alist)))
@@ -6605,8 +6161,8 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
(defun pr-insert-toggle (var-sym label)
(widget-create 'checkbox
- :notify `(lambda (&rest _ignore)
- (setq ,var-sym (not ,var-sym)))
+ :notify (lambda (&rest _ignore)
+ (set var-sym (not (symbol-value var-sym))))
(symbol-value var-sym))
(widget-insert label))
@@ -6619,32 +6175,32 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
(widget-insert separator)))
-(defun pr-insert-menu (tag var-sym choices &optional before after &rest body)
+(defun pr-insert-menu (tag var-sym choices &optional before after body)
(and before (widget-insert before))
- (eval `(widget-create 'menu-choice
- :tag ,tag
- :format "%v"
- :inline t
- :value ,var-sym
- :notify (lambda (widget &rest _ignore)
- (setq ,var-sym (widget-value widget))
- ,@body)
- :void '(choice-item :format "%[%t%]"
- :tag "Can not display value!")
- ,@choices))
- (and after (widget-insert after)))
+ (apply #'widget-create 'menu-choice
+ :tag tag
+ :format "%v"
+ :inline t
+ :value (symbol-value var-sym)
+ :notify (lambda (widget &rest _ignore)
+ (set var-sym (widget-value widget))
+ (when body (funcall body)))
+ :void '(choice-item :format "%[%t%]"
+ :tag "Can not display value!")
+ choices)
+ (and after (widget-insert after)))
(defun pr-insert-radio-button (var-sym sym)
(widget-insert "\n")
(let ((wid-list (get var-sym 'pr-widget-list))
- (wid (eval `(widget-create
- 'radio-button
- :format " %[%v%]"
- :value (eq ,var-sym (quote ,sym))
- :notify (lambda (&rest _ignore)
- (setq ,var-sym (quote ,sym))
- (pr-update-radio-button (quote ,var-sym)))))))
+ (wid (widget-create
+ 'radio-button
+ :format " %[%v%]"
+ :value (eq (symbol-value var-sym) sym)
+ :notify (lambda (&rest _ignore)
+ (set var-sym sym)
+ (pr-update-radio-button var-sym)))))
(put var-sym 'pr-widget-list (cons (cons wid sym) wid-list))))
@@ -6666,20 +6222,18 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
(defun pr-choice-alist (alist)
- (let ((max (apply 'max (mapcar #'(lambda (alist)
- (length (symbol-name (car alist))))
- alist))))
+ (let ((max (apply #'max (mapcar #'(lambda (alist)
+ (length (symbol-name (car alist))))
+ alist))))
(mapcar #'(lambda (alist)
(let* ((sym (car alist))
(name (symbol-name sym)))
- (list
- 'quote
- (list
- 'choice-item
- :format "%[%t%]"
- :tag (concat name
- (make-string (- max (length name)) ?_))
- :value sym))))
+ (list
+ 'choice-item
+ :format "%[%t%]"
+ :tag (concat name
+ (make-string (- max (length name)) ?_))
+ :value sym)))
alist)))
diff --git a/lisp/proced.el b/lisp/proced.el
index b3c8e2cb698..ce379a7c6aa 100644
--- a/lisp/proced.el
+++ b/lisp/proced.el
@@ -1348,7 +1348,7 @@ Prefix ARG controls sort order, see `proced-sort-interactive'."
(defun proced-format-time (time)
"Format time interval TIME."
- (let* ((ftime (float-time time))
+ (let* ((ftime (encode-time time 'integer))
(days (truncate ftime 86400))
(ftime (mod ftime 86400))
(hours (truncate ftime 3600))
diff --git a/lisp/profiler.el b/lisp/profiler.el
index 5e6f4be2c12..45dc1d1edc0 100644
--- a/lisp/profiler.el
+++ b/lisp/profiler.el
@@ -105,13 +105,13 @@
"Format ENTRY in human readable string. ENTRY would be a
function name of a function itself."
(cond ((memq (car-safe entry) '(closure lambda))
- (format "#<lambda 0x%x>" (sxhash entry)))
+ (format "#<lambda %#x>" (sxhash entry)))
((byte-code-function-p entry)
- (format "#<compiled 0x%x>" (sxhash entry)))
+ (format "#<compiled %#x>" (sxhash entry)))
((or (subrp entry) (symbolp entry) (stringp entry))
(format "%s" entry))
(t
- (format "#<unknown 0x%x>" (sxhash entry)))))
+ (format "#<unknown %#x>" (sxhash entry)))))
(defun profiler-fixup-entry (entry)
(if (symbolp entry)
diff --git a/lisp/progmodes/ada-mode.el b/lisp/progmodes/ada-mode.el
index eb7efc3cf04..e01f1e8ecbe 100644
--- a/lisp/progmodes/ada-mode.el
+++ b/lisp/progmodes/ada-mode.el
@@ -767,7 +767,7 @@ the 4 file locations can be clicked on and jumped to."
(interactive "d")
(goto-char pos)
- (skip-chars-backward "-a-zA-Z0-9_:./\\")
+ (skip-chars-backward "-a-zA-Z0-9_:./\\\\")
(cond
;; special case: looking at a filename:line not at the beginning of a line
;; or a simple line reference "at line ..."
@@ -4519,6 +4519,7 @@ Moves to `begin' if in a declarative part."
(define-key ada-mode-map "\C-c\C-n" 'ada-make-subprogram-body)
;; Use predefined function of Emacs19 for comments (RE)
+ ;; FIXME: Made redundant with Emacs-21's standard comment-dwim binding on M-;
(define-key ada-mode-map "\C-c;" 'comment-region)
(define-key ada-mode-map "\C-c:" 'ada-uncomment-region)
@@ -4756,16 +4757,17 @@ Moves to `begin' if in a declarative part."
;; function for justifying the comments.
;; -------------------------------------------------------
-(defadvice comment-region (before ada-uncomment-anywhere disable)
- (if (and (consp arg) ;; a prefix with \C-u is of the form '(4), whereas
- ;; \C-u 2 sets arg to '2' (fixed by S.Leake)
- (derived-mode-p 'ada-mode))
- (save-excursion
- (let ((cs (concat "^[ \t]*" (regexp-quote comment-start))))
- (goto-char beg)
- (while (re-search-forward cs end t)
- (replace-match comment-start))
- ))))
+(when (or (<= emacs-major-version 20) (featurep 'xemacs))
+ (defadvice comment-region (before ada-uncomment-anywhere disable)
+ (if (and (consp arg) ;; a prefix with \C-u is of the form '(4), whereas
+ ;; \C-u 2 sets arg to '2' (fixed by S.Leake)
+ (derived-mode-p 'ada-mode))
+ (save-excursion
+ (let ((cs (concat "^[ \t]*" (regexp-quote comment-start))))
+ (goto-char beg)
+ (while (re-search-forward cs end t)
+ (replace-match comment-start))
+ )))))
(defun ada-uncomment-region (beg end &optional arg)
"Uncomment region BEG .. END.
diff --git a/lisp/progmodes/ada-xref.el b/lisp/progmodes/ada-xref.el
index 7f0e1663284..c9c923e1d69 100644
--- a/lisp/progmodes/ada-xref.el
+++ b/lisp/progmodes/ada-xref.el
@@ -416,7 +416,7 @@ As a special case, ${current} is replaced with the name of the current
file, minus extension but with directory, and ${full_current} is
replaced by the name including the extension."
- (while (string-match "\\(-[^-$IO]*[IO]\\)?${\\([^}]+\\)}" cmd-string)
+ (while (string-match "\\(-[^-$IO]*[IO]\\)?\\${\\([^}]+\\)}" cmd-string)
(let (value
(name (match-string 2 cmd-string)))
(cond
@@ -1133,8 +1133,7 @@ If OTHER-FRAME is non-nil, display the cross-reference in another frame."
(ada-find-in-ali identlist other-frame)
;; File not found: print explicit error message
(ada-error-file-not-found
- (message (concat (error-message-string err)
- (nthcdr 1 err))))
+ (message "%s%s" (error-message-string err) (nthcdr 1 err)))
(error
(let ((ali-file (ada-get-ali-file-name (ada-file-of identlist))))
diff --git a/lisp/progmodes/antlr-mode.el b/lisp/progmodes/antlr-mode.el
index ef140f38962..40bef0b35b6 100644
--- a/lisp/progmodes/antlr-mode.el
+++ b/lisp/progmodes/antlr-mode.el
@@ -82,8 +82,7 @@
;;; Code:
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'easymenu)
(require 'cc-mode)
@@ -1066,7 +1065,7 @@ Used for `antlr-slow-syntactic-context'.")
(buffer-syntactic-context-depth)
nil)
:EMACS
-;;; (incf antlr-statistics-inval)
+;;; (cl-incf antlr-statistics-inval)
(setq antlr-slow-context-cache nil))
(defunx antlr-syntactic-context ()
@@ -1096,9 +1095,9 @@ WARNING: this may alter `match-data'."
(if (>= orig antlr-slow-cache-diff-threshold)
(beginning-of-defun)
(goto-char (point-min)))
-;;; (cond ((and diff (< diff 0)) (incf antlr-statistics-full-neg))
-;;; ((and diff (>= diff 3000)) (incf antlr-statistics-full-diff))
-;;; (t (incf antlr-statistics-full-other)))
+;;; (cond ((and diff (< diff 0)) (cl-incf antlr-statistics-full-neg))
+;;; ((and diff (>= diff 3000)) (cl-incf antlr-statistics-full-diff))
+;;; (t (cl-incf antlr-statistics-full-other)))
(setq state (parse-partial-sexp (point) orig)))
(goto-char orig)
(if antlr-slow-context-cache
@@ -1110,12 +1109,12 @@ WARNING: this may alter `match-data'."
((nth 4 state) 'comment) ; block-comment? -- we don't care
(t (car state)))))
-;;; (incf (aref antlr-statistics 2))
+;;; (cl-incf (aref antlr-statistics 2))
;;; (unless (and (eq (current-buffer)
;;; (caar antlr-slow-context-cache))
;;; (eq (buffer-modified-tick)
;;; (cdar antlr-slow-context-cache)))
-;;; (incf (aref antlr-statistics 1))
+;;; (cl-incf (aref antlr-statistics 1))
;;; (setq antlr-slow-context-cache nil))
;;; (let* ((orig (point))
;;; (base (cadr antlr-slow-context-cache))
@@ -1124,7 +1123,7 @@ WARNING: this may alter `match-data'."
;;; ((eq orig (car base)) (cdr base))))
;;; diff diff2)
;;; (unless state
-;;; (incf (aref antlr-statistics 3))
+;;; (cl-incf (aref antlr-statistics 3))
;;; (when curr
;;; (if (< (setq diff (abs (- orig (car curr))))
;;; (setq diff2 (abs (- orig (car base)))))
@@ -1137,7 +1136,7 @@ WARNING: this may alter `match-data'."
;;; (setq state
;;; (parse-partial-sexp (car state) orig nil nil (cdr state)))
;;; (if (>= orig 3000) (beginning-of-defun) (goto-char (point-min)))
-;;; (incf (aref antlr-statistics 4))
+;;; (cl-incf (aref antlr-statistics 4))
;;; (setq cw (list orig (point) base curr))
;;; (setq state (parse-partial-sexp (point) orig)))
;;; (goto-char orig)
@@ -1348,10 +1347,10 @@ is non-nil, move to beginning of the rule."
(antlr-skip-exception-part skip-comment))
(antlr-skip-file-prelude skip-comment))
(if (< arg 0)
- (unless (and (< (point) pos) (zerop (incf arg)))
+ (unless (and (< (point) pos) (zerop (cl-incf arg)))
;; if we have moved backward, we already moved one defun backward
(goto-char beg) ; rewind (to ";" / point)
- (while (and arg (<= (incf arg) 0))
+ (while (and arg (<= (cl-incf arg) 0))
(if (antlr-search-backward ";")
(setq beg (point))
(when (>= arg -1)
@@ -1368,9 +1367,9 @@ is non-nil, move to beginning of the rule."
(antlr-skip-exception-part skip-comment)))
(if (<= (point) pos) ; moved backward?
(goto-char pos) ; rewind
- (decf arg)) ; already moved one defun forward
+ (cl-decf arg)) ; already moved one defun forward
(unless (zerop arg)
- (while (>= (decf arg) 0)
+ (while (>= (cl-decf arg) 0)
(antlr-search-forward ";"))
(antlr-skip-exception-part skip-comment)))))
@@ -1465,7 +1464,7 @@ If non-nil, TRANSFORM is used on literals instead of `downcase-region'."
(antlr-invalidate-context-cache)
(while (antlr-re-search-forward "\"\\(\\sw\\(\\sw\\|-\\)*\\)\"" nil)
(funcall transform (match-beginning 0) (match-end 0))
- (incf literals))))
+ (cl-incf literals))))
(message "Transformed %d literals" literals)))
(defun antlr-upcase-literals ()
@@ -2131,7 +2130,7 @@ its export vocabulary is used as an import vocabulary."
(or (null ivocab)
(member ivocab import-vocabs) (push ivocab import-vocabs)))))
(if classes
- (list* (file-name-nondirectory buffer-file-name)
+ (cl-list* (file-name-nondirectory buffer-file-name)
(cons (nreverse classes) (nreverse superclasses))
(cons (nreverse export-vocabs) (nreverse import-vocabs))
antlr-language))))
@@ -2277,7 +2276,7 @@ command `antlr-show-makefile-rules' for detail."
(dolist (dep deps)
(let ((supers (cdadr dep))
(lang (cdr (assoc (cdddr dep) antlr-file-formats-alist))))
- (if n (incf n))
+ (if n (cl-incf n))
(antlr-makefile-insert-variable n "" " =")
(if supers
(insert " "
@@ -2313,7 +2312,7 @@ command `antlr-show-makefile-rules' for detail."
(if n
(let ((i 0))
(antlr-makefile-insert-variable nil "" " =")
- (while (<= (incf i) n)
+ (while (<= (cl-incf i) n)
(antlr-makefile-insert-variable i " $(" ")"))
(insert "\n" (car antlr-makefile-specification))))
(if (string-equal (car antlr-makefile-specification) "\n")
@@ -2442,8 +2441,8 @@ to a lesser extent, `antlr-tab-offset-alist'."
(goto-char boi)
(unless (symbolp syntax) ; direct indentation
;;(antlr-invalidate-context-cache)
- (incf indent (antlr-syntactic-context))
- (and (> indent 0) (looking-at antlr-indent-item-regexp) (decf indent))
+ (cl-incf indent (antlr-syntactic-context))
+ (and (> indent 0) (looking-at antlr-indent-item-regexp) (cl-decf indent))
(setq indent (* indent c-basic-offset)))
;; the usual major-mode indent stuff ---------------------------------
(setq orig (- (point-max) orig))
diff --git a/lisp/progmodes/autoconf.el b/lisp/progmodes/autoconf.el
index d236ef6e750..9d70aeb9d52 100644
--- a/lisp/progmodes/autoconf.el
+++ b/lisp/progmodes/autoconf.el
@@ -84,7 +84,7 @@ searching backwards at another AC_... command."
(setq-local syntax-propertize-function
(syntax-propertize-rules ("\\<dnl\\>" (0 "<"))))
(setq-local font-lock-defaults
- `(autoconf-font-lock-keywords nil nil))
+ '(autoconf-font-lock-keywords nil nil))
(setq-local imenu-generic-expression autoconf-imenu-generic-expression)
(setq-local indent-line-function #'indent-relative)
(setq-local add-log-current-defun-function
diff --git a/lisp/progmodes/bat-mode.el b/lisp/progmodes/bat-mode.el
index 5853d511c9a..a8b002be59b 100644
--- a/lisp/progmodes/bat-mode.el
+++ b/lisp/progmodes/bat-mode.el
@@ -78,12 +78,14 @@
"goto" "gtr" "if" "in" "leq" "lss" "neq" "not" "start"))
(UNIX
'("bash" "cat" "cp" "fgrep" "grep" "ls" "sed" "sh" "mv" "rm")))
- `(("\\_<\\(call\\|goto\\)\\_>[ \t]+%?\\([A-Za-z0-9-_\\:.]+\\)%?"
+ `(("\\_<\\(call\\|goto\\)\\_>[ \t]+%?\\([A-Za-z0-9_\\:.-]+\\)%?"
(2 font-lock-constant-face t))
("^:[^:].*"
. 'bat-label-face)
("\\_<\\(defined\\|set\\)\\_>[ \t]*\\(\\(\\sw\\|\\s_\\)+\\)"
(2 font-lock-variable-name-face))
+ ("%~\\([0-9]\\)"
+ (1 font-lock-variable-name-face))
("%\\([^%~ \n]+\\)%?"
(1 font-lock-variable-name-face))
("!\\([^!%~ \n]+\\)!?" ; delayed-expansion !variable!
diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el
index 861b0137cb0..813ecbe3847 100644
--- a/lisp/progmodes/bug-reference.el
+++ b/lisp/progmodes/bug-reference.el
@@ -1,4 +1,4 @@
-;; bug-reference.el --- buttonize bug references
+;; bug-reference.el --- buttonize bug references -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2019 Free Software Foundation, Inc.
@@ -69,7 +69,7 @@ so that it is considered safe, see `enable-local-variables'.")
(get s 'bug-reference-url-format)))))
(defcustom bug-reference-bug-regexp
- "\\([Bb]ug ?#?\\|[Pp]atch ?#\\|RFE ?#\\|PR [a-z-+]+/\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)"
+ "\\([Bb]ug ?#?\\|[Pp]atch ?#\\|RFE ?#\\|PR [a-z+-]+/\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)"
"Regular expression matching bug references.
The second subexpression should match the bug reference (usually a number)."
:type 'string
@@ -91,7 +91,7 @@ The second subexpression should match the bug reference (usually a number)."
(bug-reference-set-overlay-properties)
(defun bug-reference-unfontify (start end)
- "Remove bug reference overlays from region."
+ "Remove bug reference overlays from the region between START and END."
(dolist (o (overlays-in start end))
(when (eq (overlay-get o 'category) 'bug-reference)
(delete-overlay o))))
@@ -99,7 +99,7 @@ The second subexpression should match the bug reference (usually a number)."
(defvar bug-reference-prog-mode)
(defun bug-reference-fontify (start end)
- "Apply bug reference overlays to region."
+ "Apply bug reference overlays to the region between START and END."
(save-excursion
(let ((beg-line (progn (goto-char start) (line-beginning-position)))
(end-line (progn (goto-char end) (line-end-position))))
@@ -141,10 +141,7 @@ The second subexpression should match the bug reference (usually a number)."
;;;###autoload
(define-minor-mode bug-reference-mode
- "Toggle hyperlinking bug references in the buffer (Bug Reference mode).
-With a prefix argument ARG, enable Bug Reference mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil."
+ "Toggle hyperlinking bug references in the buffer (Bug Reference mode)."
nil
""
nil
diff --git a/lisp/progmodes/cc-align.el b/lisp/progmodes/cc-align.el
index d658e07774d..009f58ea586 100644
--- a/lisp/progmodes/cc-align.el
+++ b/lisp/progmodes/cc-align.el
@@ -868,12 +868,11 @@ returned if there's no template argument on the first line.
Works with: template-args-cont."
(save-excursion
- (c-with-syntax-table c++-template-syntax-table
- (beginning-of-line)
- (backward-up-list 1)
- (if (and (eq (char-after) ?<)
- (zerop (c-forward-token-2 1 nil (c-point 'eol))))
- (vector (current-column))))))
+ (beginning-of-line)
+ (backward-up-list 1)
+ (if (and (eq (char-after) ?<)
+ (zerop (c-forward-token-2 1 nil (c-point 'eol))))
+ (vector (current-column)))))
(defun c-lineup-ObjC-method-call (langelem)
"Line up selector args as Emacs Lisp mode does with function args:
@@ -1084,6 +1083,130 @@ arglist-cont."
(vector (+ (current-column) c-basic-offset))))
(vector 0)))))
+(defun c-lineup-2nd-brace-entry-in-arglist (langelem)
+ "Lineup the second entry of a brace block under the first, when the first
+line is also contained in an arglist or an enclosing brace ON THAT LINE.
+
+I.e. handle something like the following:
+
+ set_line (line_t {point_t{0.4, 0.2},
+ point_t{0.2, 0.5}, <---- brace-list-intro
+ .....});
+ ^ enclosing parenthesis.
+
+The middle line of that example will have a syntactic context
+with three syntactic symbols, arglist-cont-nonempty, brace-list-intro, and
+brace-list-entry.
+
+This function is intended for use in a list. If the construct
+being analyzed isn't like the preceding, the function returns nil.
+Otherwise it returns the function `c-lineup-arglist-intro-after-paren', which
+the caller then uses to perform indentation.
+
+Works with brace-list-intro."
+ ;; brace-list-intro and brace-list-entry are both present for the second
+ ;; entry of the list when the first entry is on the same line as the opening
+ ;; brace.
+ (and (assq 'brace-list-intro c-syntactic-context)
+ (assq 'brace-list-entry c-syntactic-context)
+ (or (assq 'arglist-cont-nonempty c-syntactic-context) ; "(" earlier on
+ ; the line.
+ (save-excursion ; "{" earlier on the line
+ (goto-char (c-langelem-pos
+ (assq 'brace-list-intro c-syntactic-context)))
+ (and
+ (eq (c-backward-token-2
+ 1 nil
+ (c-point 'bol (c-langelem-pos
+ (assq 'brace-list-entry
+ c-syntactic-context))))
+ 0)
+ (eq (char-after) ?{))))
+ 'c-lineup-arglist-intro-after-paren))
+
+(defun c-lineup-class-decl-init-+ (langelem)
+ "Line up the second entry of a class (etc.) initializer c-basic-offset
+characters in from the identifier when:
+\(i) The type is a class, struct, union, etc. (but not an enum);
+\(ii) There is a brace block in the type declaration, specifying it; and
+\(iii) The first element of the initializer is on the same line as its opening
+brace.
+
+I.e. we have a construct like this:
+
+ struct STR {
+ int i; float f;
+ } str_1 = {1, 1.7},
+ str_2 = {2,
+ 3.1 <---- brace-list-intro
+ };
+ <--> <---- c-basic-offset
+
+Note that the syntactic context of the brace-list-intro line also has a
+syntactic element with the symbol brace-list-entry.
+
+This function is intended for use in a list. If the above structure isn't
+present, this function returns nil, allowing a different offset specification
+to indent the line.
+
+Works with: brace-list-intro."
+ (and (assq 'brace-list-intro c-syntactic-context)
+ (assq 'brace-list-entry c-syntactic-context)
+ (let ((init-pos (c-point 'boi (c-langelem-pos
+ (assq 'brace-list-entry
+ c-syntactic-context))))
+ )
+ (save-excursion
+ (goto-char (c-langelem-pos (assq 'brace-list-intro
+ c-syntactic-context)))
+ (and
+ (c-forward-class-decl)
+ (not (c-do-declarators init-pos t nil nil nil))
+ (eq (point) init-pos)
+ (vector (+ (current-column) c-basic-offset)))))))
+
+(defun c-lineup-class-decl-init-after-brace (langelem)
+ "Line up the second entry of a class (etc.) initializer after its opening
+brace when:
+\(i) The type is a class, struct, union, etc. (but not an enum);
+\(ii) There is a brace block in the type declaration, specifying it; and
+\(iii) The first element of the initializer is on the same line as its opening
+brace.
+
+I.e. we have a construct like this:
+
+ struct STR {
+ int i; float f;
+ } str_1 = {1, 1.7},
+ str_2 = {2,
+ 3.1 <---- brace-list-intro
+ };
+
+Note that the syntactic context of the brace-list-intro line also has a
+syntactic element with the symbol brace-list-entry. Also note that this
+function works by returning the symbol `c-lineup-arglist-intro-after-paren',
+which the caller then uses to perform the indentation.
+
+This function is intended for use in a list. If the above structure isn't
+present, this function returns nil, allowing a different offset specification
+to indent the line.
+
+Works with: brace-list-intro."
+ (and (assq 'brace-list-intro c-syntactic-context)
+ (assq 'brace-list-entry c-syntactic-context)
+ (let ((init-pos (c-point 'boi (c-langelem-pos
+ (assq 'brace-list-entry
+ c-syntactic-context))))
+ )
+ (save-excursion
+ (goto-char (c-langelem-pos (assq 'brace-list-intro
+ c-syntactic-context)))
+ (and
+ (c-forward-class-decl)
+ (not (c-do-declarators init-pos t nil nil nil))
+ (eq (point) init-pos)
+ 'c-lineup-arglist-intro-after-paren)))))
+
(defun c-lineup-cpp-define (_langelem)
"Line up macro continuation lines according to the indentation of
the construct preceding the macro. E.g.:
diff --git a/lisp/progmodes/cc-awk.el b/lisp/progmodes/cc-awk.el
index bcb9d0430a3..70aa3c4b1f1 100644
--- a/lisp/progmodes/cc-awk.el
+++ b/lisp/progmodes/cc-awk.el
@@ -130,7 +130,7 @@
;; REGEXPS FOR "HARMLESS" STRINGS/LINES.
(defconst c-awk-harmless-_ "_\\([^\"]\\|\\'\\)")
;; Matches an underline NOT followed by ".
-(defconst c-awk-harmless-char-re "[^_#/\"{}();\\\\\n\r]")
+(defconst c-awk-harmless-char-re "[^_#/\"{}();\\\n\r]")
;; Matches any character not significant in the state machine applying
;; syntax-table properties to "s and /s.
(defconst c-awk-harmless-string*-re
@@ -141,7 +141,7 @@
(concat "\\=" c-awk-harmless-string*-re))
;; Matches the (possibly empty) sequence of "insignificant" chars at point.
-(defconst c-awk-harmless-line-char-re "[^_#/\"\\\\\n\r]")
+(defconst c-awk-harmless-line-char-re "[^_#/\"\\\n\r]")
;; Matches any character but a _, #, /, ", \, or newline. N.B. _" starts a
;; localization string in gawk 3.1
(defconst c-awk-harmless-line-string*-re
@@ -188,8 +188,8 @@
"\\[:[a-z]+:\\]")
;; Matches a character class spec (e.g. [:alpha:]).
(defconst c-awk-regexp-char-list-re
- (concat "\\[" c-awk-escaped-newlines*-re "^?" c-awk-escaped-newlines*-re "]?"
- "\\(" c-awk-esc-pair-re "\\|" c-awk-regexp-char-class-re
+ (concat "\\[\\(" c-awk-escaped-newlines*-re "\\^\\)?" c-awk-escaped-newlines*-re "]?"
+ "\\(" c-awk-esc-pair-re "\\|" c-awk-regexp-char-class-re
"\\|" "[^]\n\r]" "\\)*" "\\(]\\|$\\)"))
;; Matches a regexp char list, up to (but not including) EOL if the ] is
;; missing.
@@ -250,7 +250,7 @@
;; which can precede an expression.
;; REGEXPS USED FOR FINDING THE POSITION OF A "virtual semicolon"
-(defconst c-awk-_-harmless-nonws-char-re "[^#/\"\\\\\n\r \t]")
+(defconst c-awk-_-harmless-nonws-char-re "[^#/\"\\\n\r \t]")
(defconst c-awk-non-/-syn-ws*-re
(concat
"\\(" c-awk-escaped-nls*-with-space*
diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el
index 65b44339bc1..efc6747de48 100644
--- a/lisp/progmodes/cc-cmds.el
+++ b/lisp/progmodes/cc-cmds.el
@@ -47,6 +47,7 @@
;; Silence the compiler.
(cc-bytecomp-defvar filladapt-mode) ; c-fill-paragraph contains a kludge
; which looks at this.
+(cc-bytecomp-defun electric-pair-post-self-insert-function)
;; Indentation / Display syntax functions
(defvar c-fix-backslashes t)
@@ -503,7 +504,8 @@ inside a literal or a macro, nothing special happens."
(eq (char-before) ?\\))))
(c-in-literal)))
;; do nothing special
- (self-insert-command (prefix-numeric-value arg))
+ (let (post-self-insert-hook) ; Disable random functionality.
+ (self-insert-command (prefix-numeric-value arg)))
;; place the pound character at the left edge
(let ((pos (- (point-max) (point)))
(bolp (bolp)))
@@ -694,6 +696,134 @@ inside a literal or a macro, nothing special happens."
t))))
(goto-char (- (point-max) pos))))))
+(defun c-do-brace-electrics (before after)
+ ;; Point is just after a brace. Indent the various lines, add any required
+ ;; auto newlines, and apply pertinent clean ups. It is assumed that the
+ ;; caller has checked that point is at EOL if need be, and that the brace is
+ ;; not in a comment or string, and suchlike.
+ ;;
+ ;; BEFORE and AFTER qualify the newlines required before and after the
+ ;; brace as follows:
+ ;; If
+ ;; o - nil: insert a newline or not according to `c-hanging-braces-alist'.
+ ;; o - 'ignore: don't insert a newline.
+ ;; o - 'assume: insert a newline.
+ ;;
+ ;; The return value has no significance.
+ (let (;; shut this up too
+ (c-echo-syntactic-information-p nil)
+ newlines
+ ln-syntax br-syntax syntax) ; Syntactic context of the original line,
+ ; of the brace itself, of the line the
+ ; brace ends up on.
+ (c-save-buffer-state ((c-syntactic-indentation-in-macros t)
+ (c-auto-newline-analysis t))
+ (setq ln-syntax (c-guess-basic-syntax)))
+ (if c-syntactic-indentation
+ (c-indent-line ln-syntax))
+
+ (when c-auto-newline
+ (backward-char)
+ (setq br-syntax (c-point-syntax)
+ newlines (c-brace-newlines br-syntax))
+
+ ;; Insert the BEFORE newline, if wanted, and reindent the newline.
+ (if (or (and (null before) (memq 'before newlines)
+ (> (current-column) (current-indentation)))
+ (eq before 'assume))
+ (if c-syntactic-indentation
+ ;; Only a plain newline for now - it's indented
+ ;; after the cleanups when the line has its final
+ ;; appearance.
+ (newline)
+ (c-newline-and-indent)))
+ (forward-char)
+
+ ;; `syntax' is the syntactic context of the line which ends up
+ ;; with the brace on it.
+ (setq syntax (if (memq 'before newlines) br-syntax ln-syntax))
+
+ ;; Do all appropriate clean ups
+ (let ((here (point))
+ (pos (- (point-max) (point)))
+ mbeg mend
+ )
+
+ ;; `}': clean up empty defun braces
+ (when (c-save-buffer-state ()
+ (and (memq 'empty-defun-braces c-cleanup-list)
+ (eq (c-last-command-char) ?\})
+ (c-intersect-lists '(defun-close class-close inline-close)
+ syntax)
+ (progn
+ (forward-char -1)
+ (c-skip-ws-backward)
+ (eq (char-before) ?\{))
+ ;; make sure matching open brace isn't in a comment
+ (not (c-in-literal))))
+ (delete-region (point) (1- here))
+ (setq here (- (point-max) pos)))
+ (goto-char here)
+
+ ;; `}': compact to a one-liner defun?
+ (save-match-data
+ (when
+ (and (eq (c-last-command-char) ?\})
+ (memq 'one-liner-defun c-cleanup-list)
+ (c-intersect-lists '(defun-close) syntax)
+ (c-try-one-liner))
+ (setq here (- (point-max) pos))))
+
+ ;; `{': clean up brace-else-brace and brace-elseif-brace
+ (when (eq (c-last-command-char) ?\{)
+ (cond
+ ((and (memq 'brace-else-brace c-cleanup-list)
+ (re-search-backward
+ (concat "}"
+ "\\([ \t\n]\\|\\\\\n\\)*"
+ "else"
+ "\\([ \t\n]\\|\\\\\n\\)*"
+ "{"
+ "\\=")
+ nil t))
+ (delete-region (match-beginning 0) (match-end 0))
+ (insert-and-inherit "} else {"))
+ ((and (memq 'brace-elseif-brace c-cleanup-list)
+ (progn
+ (goto-char (1- here))
+ (setq mend (point))
+ (c-skip-ws-backward)
+ (setq mbeg (point))
+ (eq (char-before) ?\)))
+ (zerop (c-save-buffer-state nil (c-backward-token-2 1 t)))
+ (eq (char-after) ?\()
+ (re-search-backward
+ (concat "}"
+ "\\([ \t\n]\\|\\\\\n\\)*"
+ "else"
+ "\\([ \t\n]\\|\\\\\n\\)+"
+ "if"
+ "\\([ \t\n]\\|\\\\\n\\)*"
+ "\\=")
+ nil t))
+ (delete-region mbeg mend)
+ (goto-char mbeg)
+ (insert ?\ ))))
+
+ (goto-char (- (point-max) pos))
+
+ ;; Indent the line after the cleanups since it might
+ ;; very well indent differently due to them, e.g. if
+ ;; c-indent-one-line-block is used together with the
+ ;; one-liner-defun cleanup.
+ (when c-syntactic-indentation
+ (c-indent-line)))
+
+ ;; does a newline go after the brace?
+ (if (or (and (null after) (memq 'after newlines))
+ (eq after 'assume))
+ (c-newline-and-indent)))))
+
(defun c-electric-brace (arg)
"Insert a brace.
@@ -716,7 +846,10 @@ settings of `c-cleanup-list' are done."
;; We want to inhibit blinking the paren since this would be
;; most disruptive. We'll blink it ourselves later on.
(old-blink-paren blink-paren-function)
- blink-paren-function case-fold-search)
+ blink-paren-function case-fold-search
+ (at-eol (looking-at "[ \t]*\\\\?$"))
+ (active-region (and (fboundp 'use-region-p) (use-region-p)))
+ got-pair-} electric-pair-deletion)
(c-save-buffer-state ()
(setq safepos (c-safe-position (point) (c-parse-state))
@@ -724,128 +857,36 @@ settings of `c-cleanup-list' are done."
;; Insert the brace. Note that expand-abbrev might reindent
;; the line here if there's a preceding "else" or something.
- (self-insert-command (prefix-numeric-value arg))
-
- (when (and c-electric-flag (not literal) (not arg))
- (if (not (looking-at "[ \t]*\\\\?$"))
- (if c-syntactic-indentation
- (indent-according-to-mode))
-
- (let ( ;; shut this up too
- (c-echo-syntactic-information-p nil)
- newlines
- ln-syntax br-syntax syntax) ; Syntactic context of the original line,
- ; of the brace itself, of the line the brace ends up on.
- (c-save-buffer-state ((c-syntactic-indentation-in-macros t)
- (c-auto-newline-analysis t))
- (setq ln-syntax (c-guess-basic-syntax)))
- (if c-syntactic-indentation
- (c-indent-line ln-syntax))
-
- (when c-auto-newline
- (backward-char)
- (setq br-syntax (c-point-syntax)
- newlines (c-brace-newlines br-syntax))
-
- ;; Insert the BEFORE newline, if wanted, and reindent the newline.
- (if (and (memq 'before newlines)
- (> (current-column) (current-indentation)))
- (if c-syntactic-indentation
- ;; Only a plain newline for now - it's indented
- ;; after the cleanups when the line has its final
- ;; appearance.
- (newline)
- (c-newline-and-indent)))
+ (let (post-self-insert-hook) ; the only way to get defined functionality
+ ; from `self-insert-command'.
+ (self-insert-command (prefix-numeric-value arg)))
+
+ ;; Emulate `electric-pair-mode'.
+ (when (and (boundp 'electric-pair-mode)
+ electric-pair-mode)
+ (let ((size (buffer-size))
+ (c-in-electric-pair-functionality t)
+ post-self-insert-hook)
+ (electric-pair-post-self-insert-function)
+ (setq got-pair-} (and at-eol
+ (eq (c-last-command-char) ?{)
+ (eq (char-after) ?}))
+ electric-pair-deletion (< (buffer-size) size))))
+
+ ;; Perform any required CC Mode electric actions.
+ (cond
+ ((or literal arg (not c-electric-flag) active-region))
+ ((not at-eol)
+ (c-indent-line))
+ (electric-pair-deletion
+ (c-indent-line)
+ (c-do-brace-electrics 'ignore nil))
+ (t (c-do-brace-electrics nil nil)
+ (when got-pair-}
+ (save-excursion
(forward-char)
-
- ;; `syntax' is the syntactic context of the line which ends up
- ;; with the brace on it.
- (setq syntax (if (memq 'before newlines) br-syntax ln-syntax))
-
- ;; Do all appropriate clean ups
- (let ((here (point))
- (pos (- (point-max) (point)))
- mbeg mend
- )
-
- ;; `}': clean up empty defun braces
- (when (c-save-buffer-state ()
- (and (memq 'empty-defun-braces c-cleanup-list)
- (eq (c-last-command-char) ?\})
- (c-intersect-lists '(defun-close class-close inline-close)
- syntax)
- (progn
- (forward-char -1)
- (c-skip-ws-backward)
- (eq (char-before) ?\{))
- ;; make sure matching open brace isn't in a comment
- (not (c-in-literal))))
- (delete-region (point) (1- here))
- (setq here (- (point-max) pos)))
- (goto-char here)
-
- ;; `}': compact to a one-liner defun?
- (save-match-data
- (when
- (and (eq (c-last-command-char) ?\})
- (memq 'one-liner-defun c-cleanup-list)
- (c-intersect-lists '(defun-close) syntax)
- (c-try-one-liner))
- (setq here (- (point-max) pos))))
-
- ;; `{': clean up brace-else-brace and brace-elseif-brace
- (when (eq (c-last-command-char) ?\{)
- (cond
- ((and (memq 'brace-else-brace c-cleanup-list)
- (re-search-backward
- (concat "}"
- "\\([ \t\n]\\|\\\\\n\\)*"
- "else"
- "\\([ \t\n]\\|\\\\\n\\)*"
- "{"
- "\\=")
- nil t))
- (delete-region (match-beginning 0) (match-end 0))
- (insert-and-inherit "} else {"))
- ((and (memq 'brace-elseif-brace c-cleanup-list)
- (progn
- (goto-char (1- here))
- (setq mend (point))
- (c-skip-ws-backward)
- (setq mbeg (point))
- (eq (char-before) ?\)))
- (zerop (c-save-buffer-state nil (c-backward-token-2 1 t)))
- (eq (char-after) ?\()
- ; (progn
- ; (setq tmp (point))
- (re-search-backward
- (concat "}"
- "\\([ \t\n]\\|\\\\\n\\)*"
- "else"
- "\\([ \t\n]\\|\\\\\n\\)+"
- "if"
- "\\([ \t\n]\\|\\\\\n\\)*"
- "\\=")
- nil t);)
- ;(eq (match-end 0) tmp);
- )
- (delete-region mbeg mend)
- (goto-char mbeg)
- (insert ?\ ))))
-
- (goto-char (- (point-max) pos))
-
- ;; Indent the line after the cleanups since it might
- ;; very well indent differently due to them, e.g. if
- ;; c-indent-one-line-block is used together with the
- ;; one-liner-defun cleanup.
- (when c-syntactic-indentation
- (c-indent-line)))
-
- ;; does a newline go after the brace?
- (if (memq 'after newlines)
- (c-newline-and-indent))
- ))))
+ (c-do-brace-electrics 'assume 'ignore))
+ (c-indent-line))))
;; blink the paren
(and (eq (c-last-command-char) ?\})
@@ -903,7 +944,8 @@ is inhibited."
c-electric-flag
(eq (c-last-command-char) ?/)
(eq (char-before) (if literal ?* ?/))))
- (self-insert-command (prefix-numeric-value arg))
+ (let (post-self-insert-hook) ; Disable random functionality.
+ (self-insert-command (prefix-numeric-value arg)))
(if indentp
(indent-according-to-mode))))
@@ -916,7 +958,8 @@ supplied, point is inside a literal, or `c-syntactic-indentation' is nil,
this indentation is inhibited."
(interactive "*P")
- (self-insert-command (prefix-numeric-value arg))
+ (let (post-self-insert-hook) ; Disable random functionality.
+ (self-insert-command (prefix-numeric-value arg)))
;; if we are in a literal, or if arg is given do not reindent the
;; current line, unless this star introduces a comment-only line.
(if (c-save-buffer-state ()
@@ -963,7 +1006,8 @@ settings of `c-cleanup-list'."
(setq lim (c-most-enclosing-brace (c-parse-state))
literal (c-in-literal lim)))
- (self-insert-command (prefix-numeric-value arg))
+ (let (post-self-insert-hook) ; Disable random functionality.
+ (self-insert-command (prefix-numeric-value arg)))
(if (and c-electric-flag (not literal) (not arg))
;; do all cleanups and newline insertions if c-auto-newline is on.
@@ -1032,7 +1076,8 @@ reindented unless `c-syntactic-indentation' is nil.
newlines is-scope-op
;; shut this up
(c-echo-syntactic-information-p nil))
- (self-insert-command (prefix-numeric-value arg))
+ (let (post-self-insert-hook) ; Disable random functionality.
+ (self-insert-command (prefix-numeric-value arg)))
;; Any electric action?
(if (and c-electric-flag (not literal) (not arg))
;; Unless we're at EOL, only re-indentation happens.
@@ -1122,49 +1167,76 @@ finishes a C++ style stream operator in C++ mode. Exceptions are when a
numeric argument is supplied, or the point is inside a literal."
(interactive "*P")
- (let ((c-echo-syntactic-information-p nil)
+ (let ((literal (c-save-buffer-state () (c-in-literal)))
+ template-delim include-delim
+ (c-echo-syntactic-information-p nil)
final-pos found-delim case-fold-search)
- (self-insert-command (prefix-numeric-value arg))
+ (let (post-self-insert-hook) ; Disable random functionality.
+ (self-insert-command (prefix-numeric-value arg)))
(setq final-pos (point))
;;;; 2010-01-31: There used to be code here to put a syntax-table text
;;;; property on the new < or > and its mate (if any) when they are template
;;;; parens. This is now done in an after-change function.
- ;; Indent the line if appropriate.
- (when (and c-electric-flag c-syntactic-indentation c-recognize-<>-arglists)
- (setq found-delim
- (if (eq (c-last-command-char) ?<)
- ;; If a <, basically see if it's got "template" before it .....
- (or (and (progn
- (backward-char)
- (= (point)
- (progn (c-beginning-of-current-token) (point))))
- (progn
- (c-backward-token-2)
- (looking-at c-opt-<>-sexp-key)))
- ;; ..... or is a C++ << operator.
+ (when (and (not arg) (not literal))
+ ;; Have we got a delimiter on a #include directive?
+ (beginning-of-line)
+ (setq include-delim
+ (and
+ (looking-at c-cpp-include-key)
+ (if (eq (c-last-command-char) ?<)
+ (eq (match-end 0) (1- final-pos))
+ (goto-char (1- final-pos))
+ (skip-chars-backward "^<>" (c-point 'bol))
+ (eq (char-before) ?<))))
+ (goto-char final-pos)
+
+ ;; Indent the line if appropriate.
+ (when (and c-electric-flag c-syntactic-indentation c-recognize-<>-arglists)
+ (setq found-delim
+ (if (eq (c-last-command-char) ?<)
+ ;; If a <, basically see if it's got "template" before it .....
+ (or (and (progn
+ (backward-char)
+ (= (point)
+ (progn (c-beginning-of-current-token) (point))))
+ (progn
+ (c-backward-token-2)
+ (looking-at c-opt-<>-sexp-key))
+ (setq template-delim t))
+ ;; ..... or is a C++ << operator.
+ (and (c-major-mode-is 'c++-mode)
+ (progn
+ (goto-char (1- final-pos))
+ (c-beginning-of-current-token)
+ (looking-at "<<"))
+ (>= (match-end 0) final-pos)))
+
+ ;; It's a >. Either a template/generic terminator ...
+ (or (and (c-get-char-property (1- final-pos) 'syntax-table)
+ (setq template-delim t))
+ ;; or a C++ >> operator.
(and (c-major-mode-is 'c++-mode)
(progn
(goto-char (1- final-pos))
(c-beginning-of-current-token)
- (looking-at "<<"))
- (>= (match-end 0) final-pos)))
+ (looking-at ">>"))
+ (>= (match-end 0) final-pos)))))
+ (goto-char final-pos)
- ;; It's a >. Either a template/generic terminator ...
- (or (c-get-char-property (1- final-pos) 'syntax-table)
- ;; or a C++ >> operator.
- (and (c-major-mode-is 'c++-mode)
- (progn
- (goto-char (1- final-pos))
- (c-beginning-of-current-token)
- (looking-at ">>"))
- (>= (match-end 0) final-pos))))))
+ (when found-delim
+ (indent-according-to-mode)))
+
+ ;; On the off chance that < and > are configured as pairs in
+ ;; electric-pair-mode.
+ (when (and (boundp 'electric-pair-mode) electric-pair-mode
+ (or template-delim include-delim))
+ (let (post-self-insert-hook)
+ (electric-pair-post-self-insert-function))))
- (goto-char final-pos)
(when found-delim
- (indent-according-to-mode)
(when (and (eq (char-before) ?>)
(not executing-kbd-macro)
blink-paren-function)
@@ -1190,10 +1262,12 @@ newline cleanups are done if appropriate; see the variable `c-cleanup-list'."
;; shut this up
(c-echo-syntactic-information-p nil)
case-fold-search)
- (self-insert-command (prefix-numeric-value arg))
+ (let (post-self-insert-hook) ; The only way to get defined functionality
+ ; from `self-insert-command'.
+ (self-insert-command (prefix-numeric-value arg)))
(if (and (not arg) (not literal))
- (let* ( ;; We want to inhibit blinking the paren since this will
+ (let* (;; We want to inhibit blinking the paren since this will
;; be most disruptive. We'll blink it ourselves
;; afterwards.
(old-blink-paren blink-paren-function)
@@ -1239,6 +1313,12 @@ newline cleanups are done if appropriate; see the variable `c-cleanup-list'."
(delete-region (match-beginning 0) (match-end 0))
(insert-and-inherit "} catch (")))
+ ;; Apply `electric-pair-mode' stuff.
+ (when (and (boundp 'electric-pair-mode)
+ electric-pair-mode)
+ (let (post-self-insert-hook)
+ (electric-pair-post-self-insert-function)))
+
;; Check for clean-ups at function calls. These two DON'T need
;; `c-electric-flag' or `c-syntactic-indentation' set.
;; Point is currently just after the inserted paren.
@@ -1263,21 +1343,26 @@ newline cleanups are done if appropriate; see the variable `c-cleanup-list'."
(insert ?\ )))
;; compact-empty-funcall clean-up?
- ((c-save-buffer-state ()
- (and (memq 'compact-empty-funcall c-cleanup-list)
- (eq (c-last-command-char) ?\))
- (save-excursion
- (c-safe (backward-char 2))
- (when (looking-at "()")
- (setq end (point))
- (skip-chars-backward " \t")
- (setq beg (point))
- (c-on-identifier)))))
- (delete-region beg end))))
+ ((c-save-buffer-state ()
+ (and (memq 'compact-empty-funcall c-cleanup-list)
+ (eq (c-last-command-char) ?\))
+ (save-excursion
+ (c-safe (backward-char 2))
+ (when (looking-at "()")
+ (setq end (point))
+ (skip-chars-backward " \t")
+ (setq beg (point))
+ (c-on-identifier)))))
+ (delete-region beg end))))
(and (eq last-input-event ?\))
(not executing-kbd-macro)
old-blink-paren
- (funcall old-blink-paren))))))
+ (funcall old-blink-paren)))
+
+ ;; Apply `electric-pair-mode' stuff inside a string or comment.
+ (when (and (boundp 'electric-pair-mode) electric-pair-mode)
+ (let (post-self-insert-hook)
+ (electric-pair-post-self-insert-function))))))
(defun c-electric-continued-statement ()
"Reindent the current line if appropriate.
@@ -1383,7 +1468,7 @@ No indentation or other \"electric\" behavior is performed."
(let ((eo-block (point))
bod)
(and (eq (char-before) ?\})
- (eq (car (c-beginning-of-decl-1 lim)) 'previous)
+ (memq (car (c-beginning-of-decl-1 lim)) '(same previous))
(setq bod (point))
;; Look for struct or union or ... If we find one, it might
;; be the return type of a function, or the like. Exclude
@@ -1397,6 +1482,16 @@ No indentation or other \"electric\" behavior is performed."
(not (eq (char-before) ?_))
(c-syntactic-re-search-forward "[;=([{]" eo-block t t t)
(eq (char-before) ?\{)
+ ;; Exclude the entire "struct {...}" being the type of a
+ ;; function being declared.
+ (not
+ (and
+ (c-go-up-list-forward)
+ (eq (char-before) ?})
+ (progn (c-forward-syntactic-ws)
+ (c-syntactic-re-search-forward
+ "[;=([{]" nil t t t))
+ (eq (char-before) ?\()))
bod)))))
(defun c-where-wrt-brace-construct ()
@@ -1431,10 +1526,23 @@ No indentation or other \"electric\" behavior is performed."
'in-block)
((c-in-function-trailer-p)
'in-trailer)
- ((and (not least-enclosing)
- (consp paren-state)
- (consp (car paren-state))
- (eq start (cdar paren-state)))
+ ((or (and (eq (char-before) ?\;)
+ (save-excursion
+ (backward-char)
+ (c-in-function-trailer-p)))
+ (and (not least-enclosing)
+ (consp paren-state)
+ (consp (car paren-state))
+ (eq start (cdar paren-state))
+ (or
+ (save-excursion
+ (c-forward-syntactic-ws)
+ (or (not (looking-at c-symbol-start))
+ (looking-at c-keywords-regexp)))
+ (save-excursion
+ (goto-char (caar paren-state))
+ (c-beginning-of-decl-1)
+ (not (looking-at c-defun-type-name-decl-key))))))
'at-function-end)
(t
;; Find the start of the current declaration. NOTE: If we're in the
@@ -1450,6 +1558,18 @@ No indentation or other \"electric\" behavior is performed."
"\\([;#]\\|\\'\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s$\\|\\s<\\|\\s>\\|\\s!\\)")))
(forward-char))
(setq kluge-start (point))
+ ;; First approximation as to whether the current "header" we're in is
+ ;; one followed by braces.
+ (setq brace-decl-p
+ (save-excursion
+ (and (c-syntactic-re-search-forward "[;{]" nil t t)
+ (or (eq (char-before) ?\{)
+ (and c-recognize-knr-p
+ ;; Might have stopped on the
+ ;; ';' in a K&R argdecl. In
+ ;; that case the declaration
+ ;; should contain a block.
+ (c-in-knr-argdecl))))))
(setq decl-result
(car (c-beginning-of-decl-1
;; NOTE: If we're in a K&R region, this might be the start
@@ -1460,17 +1580,9 @@ No indentation or other \"electric\" behavior is performed."
(c-safe-position least-enclosing paren-state)))))
;; Has the declaration we've gone back to got braces?
- (or (eq decl-result 'label)
- (setq brace-decl-p
- (save-excursion
- (and (c-syntactic-re-search-forward "[;{]" nil t t)
- (or (eq (char-before) ?\{)
- (and c-recognize-knr-p
- ;; Might have stopped on the
- ;; ';' in a K&R argdecl. In
- ;; that case the declaration
- ;; should contain a block.
- (c-in-knr-argdecl)))))))
+ (if (or (eq decl-result 'label)
+ (looking-at c-protection-key))
+ (setq brace-decl-p nil))
(cond
((or (eq decl-result 'label) ; e.g. "private:" or invalid syntax.
@@ -1613,6 +1725,8 @@ No indentation or other \"electric\" behavior is performed."
paren-state orig-point-min orig-point-max))
(setq where 'in-block))))
+(def-edebug-spec c-while-widening-to-decl-block t)
+
(defun c-beginning-of-defun (&optional arg)
"Move backward to the beginning of a defun.
Every top level declaration that contains a brace paren block is
@@ -1817,251 +1931,268 @@ the open-parenthesis that starts a defun; see `beginning-of-defun'."
(c-keep-region-active)
(= arg 0))))
-(defun c-defun-name ()
- "Return the name of the current defun, or NIL if there isn't one.
-\"Defun\" here means a function, or other top level construct
-with a brace block."
+(defun c-defun-name-1 ()
+ "Return the name of the current defun, at the current narrowing,
+or NIL if there isn't one. \"Defun\" here means a function, or
+other top level construct with a brace block."
(c-save-buffer-state
(beginning-of-defun-function end-of-defun-function
- where pos name-end case-fold-search)
+ where pos decl0 decl type-pos tag-pos case-fold-search)
- (save-restriction
- (widen)
- (save-excursion
- ;; Move back out of any macro/comment/string we happen to be in.
- (c-beginning-of-macro)
- (setq pos (c-literal-start))
- (if pos (goto-char pos))
-
- (setq where (c-where-wrt-brace-construct))
-
- ;; Move to the beginning of the current defun, if any, if we're not
- ;; already there.
- (if (eq where 'outwith-function)
- nil
- (unless (eq where 'at-header)
- (c-backward-to-nth-BOF-{ 1 where)
- (c-beginning-of-decl-1))
- (when (looking-at c-typedef-key)
- (goto-char (match-end 0))
- (c-forward-syntactic-ws))
+ (save-excursion
+ ;; Move back out of any macro/comment/string we happen to be in.
+ (c-beginning-of-macro)
+ (setq pos (c-literal-start))
+ (if pos (goto-char pos))
- ;; Pick out the defun name, according to the type of defun.
- (cond
- ;; struct, union, enum, or similar:
- ((save-excursion
- (and
- (looking-at c-type-prefix-key)
- (consp (c-forward-decl-or-cast-1 (c-point 'bosws) 'top nil))
- (or (not (or (eq (char-after) ?{)
- (and c-recognize-knr-p
- (c-in-knr-argdecl))))
- (progn (c-backward-syntactic-ws)
- (not (eq (char-before) ?\)))))))
- (let ((key-pos (point)))
- (c-forward-over-token-and-ws) ; over "struct ".
- (cond
- ((looking-at c-symbol-key) ; "struct foo { ..."
- (buffer-substring-no-properties key-pos (match-end 0)))
- ((eq (char-after) ?{) ; "struct { ... } foo"
- (when (c-go-list-forward)
- (c-forward-syntactic-ws)
- (when (looking-at c-symbol-key) ; a bit bogus - there might
- ; be several identifiers.
- (match-string-no-properties 0)))))))
-
- ((looking-at "DEFUN\\s-*(") ;"DEFUN\\_>") think of XEmacs!
- ;; DEFUN ("file-name-directory", Ffile_name_directory, Sfile_name_directory, ...) ==> Ffile_name_directory
- ;; DEFUN(POSIX::STREAM-LOCK, stream lockp &key BLOCK SHARED START LENGTH) ==> POSIX::STREAM-LOCK
- (down-list 1)
+ (setq where (c-where-wrt-brace-construct))
+
+ ;; Move to the beginning of the current defun, if any, if we're not
+ ;; already there.
+ (if (memq where '(outwith-function at-function-end))
+ nil
+ (unless (eq where 'at-header)
+ (c-backward-to-nth-BOF-{ 1 where)
+ (c-beginning-of-decl-1))
+ (when (looking-at c-typedef-key)
+ (goto-char (match-end 0))
+ (c-forward-syntactic-ws))
+ (setq type-pos (point))
+
+ ;; Pick out the defun name, according to the type of defun.
+ (cond
+ ((looking-at "DEFUN\\s-*(") ;"DEFUN\\_>") think of XEmacs!
+ ;; DEFUN ("file-name-directory", Ffile_name_directory, Sfile_name_directory, ...) ==> Ffile_name_directory
+ ;; DEFUN(POSIX::STREAM-LOCK, stream lockp &key BLOCK SHARED START LENGTH) ==> POSIX::STREAM-LOCK
+ (down-list 1)
+ (c-forward-syntactic-ws)
+ (when (eq (char-after) ?\")
+ (forward-sexp 1)
+ (c-forward-token-2)) ; over the comma and following WS.
+ (buffer-substring-no-properties
+ (point)
+ (progn
+ (c-forward-token-2)
+ (c-backward-syntactic-ws)
+ (point))))
+
+ (t ; Normal function or initializer.
+ (when (looking-at c-defun-type-name-decl-key) ; struct, etc.
+ (goto-char (match-end 0))
(c-forward-syntactic-ws)
- (when (eq (char-after) ?\")
- (forward-sexp 1)
- (c-forward-token-2)) ; over the comma and following WS.
- (buffer-substring-no-properties
- (point)
- (progn
- (c-forward-token-2)
- (when (looking-at ":") ; CLISP: DEFUN(PACKAGE:LISP-SYMBOL,...)
- (skip-chars-forward "^,"))
- (c-backward-syntactic-ws)
- (point))))
-
- ((looking-at "DEF[a-zA-Z0-9_]* *( *\\([^, ]*\\) *,")
- ;; DEFCHECKER(sysconf_arg,prefix=_SC,default=, ...) ==> sysconf_arg
- ;; DEFFLAGSET(syslog_opt_flags,LOG_PID ...) ==> syslog_opt_flags
- (match-string-no-properties 1))
-
- ;; Objc selectors.
- ((assq 'objc-method-intro (c-guess-basic-syntax))
- (let ((bound (save-excursion (c-end-of-statement) (point)))
- (kw-re (concat "\\(?:" c-symbol-key "\\)?:"))
- (stretches))
- (when (c-syntactic-re-search-forward c-symbol-key bound t t t)
- (push (match-string-no-properties 0) stretches)
- (while (c-syntactic-re-search-forward kw-re bound t t t)
- (push (match-string-no-properties 0) stretches)))
- (apply 'concat (nreverse stretches))))
-
- (t
- ;; Normal function or initializer.
- (when
- (and
- (consp (c-forward-decl-or-cast-1 (c-point 'bosws) 'top nil))
- (or (eq (char-after) ?{)
- (and c-recognize-knr-p
- (c-in-knr-argdecl)))
- (progn
- (c-backward-syntactic-ws)
- (eq (char-before) ?\)))
- (c-go-list-backward))
- (c-backward-syntactic-ws)
- (when (eq (char-before) ?\=) ; struct foo bar = {0, 0} ;
- (c-backward-token-2)
- (c-backward-syntactic-ws))
- (setq name-end (point))
- (c-back-over-compound-identifier)
- (and (looking-at c-symbol-start)
- (buffer-substring-no-properties (point) name-end))))))))))
+ (setq tag-pos (point))
+ (goto-char type-pos))
+ (setq decl0 (c-forward-decl-or-cast-1 (c-point 'bosws) 'top nil))
+ (when (consp decl0)
+ (goto-char (car decl0))
+ (setq decl (c-forward-declarator)))
+ (and decl
+ (car decl) (cadr decl)
+ (buffer-substring-no-properties
+ (if (eq (car decl) tag-pos)
+ type-pos
+ (car decl))
+ (cadr decl)))))))))
-(defun c-declaration-limits (near)
- ;; Return a cons of the beginning and end positions of the current
- ;; top level declaration or macro. If point is not inside any then
- ;; nil is returned, unless NEAR is non-nil in which case the closest
- ;; following one is chosen instead (if there is any). The end
+(defun c-defun-name ()
+ "Return the name of the current defun, or NIL if there isn't one.
+\"Defun\" here means a function, or other top level construct
+with a brace block, at the outermost level of nesting."
+ (c-save-buffer-state ()
+ (save-restriction
+ (widen)
+ (c-defun-name-1))))
+
+(defun c-declaration-limits-1 (near)
+ ;; Return a cons of the beginning and end position of the current
+ ;; declaration or macro in the current narrowing. If there is no current
+ ;; declaration or macro, return nil, unless NEAR is non-nil, in which case
+ ;; the closest following one is chosen instead (if there is any). The end
;; position is at the next line, providing there is one before the
;; declaration.
;;
;; This function might do hidden buffer changes.
(save-excursion
- (save-restriction
- (let ((start (point))
- (paren-state (c-parse-state))
- lim pos end-pos where)
- ;; Narrow enclosing brace blocks out, as required by the values of
- ;; `c-defun-tactic', `near', and the position of point.
- (when (eq c-defun-tactic 'go-outward)
- (let ((bounds
- (save-restriction
- (if (and (not (save-excursion (c-beginning-of-macro)))
- (save-restriction
- (c-narrow-to-most-enclosing-decl-block)
- (memq (c-where-wrt-brace-construct)
- '(at-function-end outwith-function)))
- (not near))
- (c-narrow-to-most-enclosing-decl-block nil 2)
- (c-narrow-to-most-enclosing-decl-block))
- (cons (point-min) (point-max)))))
- (narrow-to-region (car bounds) (cdr bounds))))
- (setq paren-state (c-parse-state))
-
- (or
- ;; Note: Some code duplication in `c-beginning-of-defun' and
- ;; `c-end-of-defun'.
- (catch 'exit
- (unless (c-safe
- (goto-char (c-least-enclosing-brace paren-state))
- ;; If we moved to the outermost enclosing paren
- ;; then we can use c-safe-position to set the
- ;; limit. Can't do that otherwise since the
- ;; earlier paren pair on paren-state might very
- ;; well be part of the declaration we should go
- ;; to.
- (setq lim (c-safe-position (point) paren-state))
- t)
- ;; At top level. Make sure we aren't inside a literal.
- (setq pos (c-literal-start
- (c-safe-position (point) paren-state)))
- (if pos (goto-char pos)))
-
- (when (c-beginning-of-macro)
+ (let ((start (point))
+ (paren-state (c-parse-state))
+ lim pos end-pos where)
+ (or
+ ;; Note: Some code duplication in `c-beginning-of-defun' and
+ ;; `c-end-of-defun'.
+ (catch 'exit
+ (unless (c-safe
+ (goto-char (c-least-enclosing-brace paren-state))
+ ;; If we moved to the outermost enclosing paren
+ ;; then we can use c-safe-position to set the
+ ;; limit. Can't do that otherwise since the
+ ;; earlier paren pair on paren-state might very
+ ;; well be part of the declaration we should go
+ ;; to.
+ (setq lim (c-safe-position (point) paren-state))
+ ;; We might have a struct foo {...} as the type of the
+ ;; function, so set LIM back one further block.
+ (if (eq (char-before lim) ?})
+ (setq lim
+ (or
+ (save-excursion
+ (and
+ (c-go-list-backward lim)
+ (let ((paren-state-1 (c-parse-state)))
+ (c-safe-position
+ (point) paren-state-1))))
+ (point-min))))
+ t)
+ ;; At top level. Make sure we aren't inside a literal.
+ (setq pos (c-literal-start
+ (c-safe-position (point) paren-state)))
+ (if pos (goto-char pos)))
+
+ (when (c-beginning-of-macro)
+ (throw 'exit
+ (cons (point)
+ (save-excursion
+ (c-end-of-macro)
+ (forward-line 1)
+ (point)))))
+
+ (setq pos (point))
+ (setq where (and (not (save-excursion (c-beginning-of-macro)))
+ (c-where-wrt-brace-construct)))
+ (when (and (not (eq where 'at-header))
+ (or (and near
+ (memq where
+ '(at-function-end outwith-function))
+ ;; Check we're not inside a declaration without
+ ;; braces.
+ (save-excursion
+ (memq (car (c-beginning-of-decl-1 lim))
+ '(previous label))))
+ (eq (car (c-beginning-of-decl-1 lim)) 'previous)
+ (= pos (point))))
+ ;; We moved back over the previous defun. Skip to the next
+ ;; one. Not using c-forward-syntactic-ws here since we
+ ;; should not skip a macro. We can also be directly after
+ ;; the block in a `c-opt-block-decls-with-vars-key'
+ ;; declaration, but then we won't move significantly far
+ ;; here.
+ (goto-char pos)
+ (c-forward-comments)
+
+ (when (and near (c-beginning-of-macro))
(throw 'exit
(cons (point)
(save-excursion
(c-end-of-macro)
(forward-line 1)
- (point)))))
+ (point))))))
- (setq pos (point))
- (setq where (and (not (save-excursion (c-beginning-of-macro)))
- (c-where-wrt-brace-construct)))
- (when (and (not (eq where 'at-header))
- (or (and near
- (memq where
- '(at-function-end outwith-function)))
- (eq (car (c-beginning-of-decl-1 lim)) 'previous)
- (= pos (point))))
- ;; We moved back over the previous defun. Skip to the next
- ;; one. Not using c-forward-syntactic-ws here since we
- ;; should not skip a macro. We can also be directly after
- ;; the block in a `c-opt-block-decls-with-vars-key'
- ;; declaration, but then we won't move significantly far
- ;; here.
- (goto-char pos)
- (c-forward-comments)
-
- (when (and near (c-beginning-of-macro))
- (throw 'exit
- (cons (point)
- (save-excursion
- (c-end-of-macro)
- (forward-line 1)
- (point))))))
+ (if (eobp) (throw 'exit nil))
- (if (eobp) (throw 'exit nil))
+ ;; Check if `c-beginning-of-decl-1' put us after the block in a
+ ;; declaration that doesn't end there. We're searching back and
+ ;; forth over the block here, which can be expensive.
+ (setq pos (point))
+ (if (and c-opt-block-decls-with-vars-key
+ (progn
+ (c-backward-syntactic-ws)
+ (eq (char-before) ?}))
+ (eq (car (c-beginning-of-decl-1))
+ 'previous)
+ (save-excursion
+ (c-end-of-decl-1)
+ (and (> (point) pos)
+ (setq end-pos (point)))))
+ nil
+ (goto-char pos))
+
+ (if (or (and (not near) (> (point) start))
+ (not (eq (c-where-wrt-brace-construct) 'at-header)))
+ nil
+
+ ;; Try to be line oriented; position the limits at the
+ ;; closest preceding boi, and after the next newline, that
+ ;; isn't inside a comment, but if we hit a neighboring
+ ;; declaration then we instead use the exact declaration
+ ;; limit in that direction.
+ (cons (progn
+ (setq pos (point))
+ (while (and (/= (point) (c-point 'boi))
+ (c-backward-single-comment)))
+ (if (/= (point) (c-point 'boi))
+ pos
+ (point)))
+ (progn
+ (if end-pos
+ (goto-char end-pos)
+ (c-end-of-decl-1))
+ (setq pos (point))
+ (while (and (not (bolp))
+ (not (looking-at "\\s *$"))
+ (c-forward-single-comment)))
+ (cond ((bolp)
+ (point))
+ ((looking-at "\\s *$")
+ (forward-line 1)
+ (point))
+ (t
+ pos))))))
+ (and (not near)
+ (goto-char (point-min))
+ (c-forward-decl-or-cast-1 -1 nil nil)
+ (eq (char-after) ?\{)
+ (cons (point-min) (point-max)))))))
- ;; Check if `c-beginning-of-decl-1' put us after the block in a
- ;; declaration that doesn't end there. We're searching back and
- ;; forth over the block here, which can be expensive.
- (setq pos (point))
- (if (and c-opt-block-decls-with-vars-key
- (progn
- (c-backward-syntactic-ws)
- (eq (char-before) ?}))
- (eq (car (c-beginning-of-decl-1))
- 'previous)
- (save-excursion
- (c-end-of-decl-1)
- (and (> (point) pos)
- (setq end-pos (point)))))
- nil
- (goto-char pos))
-
- (if (and (not near) (> (point) start))
- nil
-
- ;; Try to be line oriented; position the limits at the
- ;; closest preceding boi, and after the next newline, that
- ;; isn't inside a comment, but if we hit a neighboring
- ;; declaration then we instead use the exact declaration
- ;; limit in that direction.
- (cons (progn
- (setq pos (point))
- (while (and (/= (point) (c-point 'boi))
- (c-backward-single-comment)))
- (if (/= (point) (c-point 'boi))
- pos
- (point)))
- (progn
- (if end-pos
- (goto-char end-pos)
- (c-end-of-decl-1))
- (setq pos (point))
- (while (and (not (bolp))
- (not (looking-at "\\s *$"))
- (c-forward-single-comment)))
- (cond ((bolp)
- (point))
- ((looking-at "\\s *$")
- (forward-line 1)
- (point))
- (t
- pos))))))
- (and (not near)
- (goto-char (point-min))
- (c-forward-decl-or-cast-1 -1 nil nil)
- (eq (char-after) ?\{)
- (cons (point-min) (point-max))))))))
+(defun c-declaration-limits (near)
+ ;; Return a cons of the beginning and end positions of the current
+ ;; top level declaration or macro. If point is not inside any then
+ ;; nil is returned, unless NEAR is non-nil in which case the closest
+ ;; following one is chosen instead (if there is any). The end
+ ;; position is at the next line, providing there is one before the
+ ;; declaration.
+ ;;
+ ;; This function might do hidden buffer changes.
+ (save-restriction
+ ;; Narrow enclosing brace blocks out, as required by the values of
+ ;; `c-defun-tactic', `near', and the position of point.
+ (when (eq c-defun-tactic 'go-outward)
+ (let ((bounds
+ (save-restriction
+ (if (and (not (save-excursion (c-beginning-of-macro)))
+ (save-restriction
+ (c-narrow-to-most-enclosing-decl-block)
+ (memq (c-where-wrt-brace-construct)
+ '(at-function-end outwith-function)))
+ (not near))
+ (c-narrow-to-most-enclosing-decl-block nil 2)
+ (c-narrow-to-most-enclosing-decl-block))
+ (cons (point-min) (point-max)))))
+ (narrow-to-region (car bounds) (cdr bounds))))
+ (c-declaration-limits-1 near)))
+
+(defun c-defun-name-and-limits (near)
+ ;; Return a cons of the name and limits (itself a cons) of the current
+ ;; top-level declaration or macro, or nil of there is none.
+ ;;
+ ;; If `c-defun-tactic' is 'go-outward, we return the name and limits of the
+ ;; most tightly enclosing declaration or macro. Otherwise, we return that
+ ;; at the file level.
+ (save-restriction
+ (widen)
+ (if (eq c-defun-tactic 'go-outward)
+ (c-save-buffer-state ((paren-state (c-parse-state))
+ (orig-point-min (point-min))
+ (orig-point-max (point-max))
+ lim name where limits fdoc)
+ (setq lim (c-widen-to-enclosing-decl-scope
+ paren-state orig-point-min orig-point-max))
+ (and lim (setq lim (1- lim)))
+ (c-while-widening-to-decl-block (not (setq name (c-defun-name-1))))
+ (when name
+ (setq limits (c-declaration-limits-1 near))
+ (cons name limits)))
+ (c-save-buffer-state ((name (c-defun-name))
+ (limits (c-declaration-limits near)))
+ (and name limits (cons name limits))))))
(defun c-display-defun-name (&optional arg)
"Display the name of the current CC mode defun and the position in it.
@@ -2069,12 +2200,13 @@ With a prefix arg, push the name onto the kill ring too."
(interactive "P")
(save-restriction
(widen)
- (c-save-buffer-state ((name (c-defun-name))
- (limits (c-declaration-limits t))
+ (c-save-buffer-state ((name-and-limits (c-defun-name-and-limits nil))
+ (name (car name-and-limits))
+ (limits (cdr name-and-limits))
(point-bol (c-point 'bol)))
(when name
(message "%s. Line %s/%s." name
- (1+ (count-lines (car limits) point-bol))
+ (1+ (count-lines (car limits) (max point-bol (car limits))))
(count-lines (car limits) (cdr limits)))
(if arg (kill-new name))
(sit-for 3 t)))))
@@ -3477,7 +3609,7 @@ Otherwise reindent just the current line."
(save-excursion
(goto-char end)
(point-marker))
- (nth 1 (current-time))
+ (encode-time nil 'integer)
context))
(message "Indenting region..."))
))
@@ -3485,7 +3617,7 @@ Otherwise reindent just the current line."
(defun c-progress-update ()
(if (not (and c-progress-info c-progress-interval))
nil
- (let ((now (nth 1 (current-time)))
+ (let ((now (encode-time nil 'integer))
(start (aref c-progress-info 0))
(end (aref c-progress-info 1))
(lastsecs (aref c-progress-info 2)))
@@ -4737,7 +4869,7 @@ If a fill prefix is specified, it overrides all the above."
(defalias 'c-comment-line-break-function 'c-indent-new-comment-line)
(make-obsolete 'c-comment-line-break-function 'c-indent-new-comment-line "21.1")
-;; advice for indent-new-comment-line for older Emacsen
+;; Advice for Emacsen older than 21.1 (!), released 2001/10
(unless (boundp 'comment-line-break-function)
(defvar c-inside-line-break-advice nil)
(defadvice indent-new-comment-line (around c-line-break-advice
diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el
index 40318b149d8..87ddf3ac1e2 100644
--- a/lisp/progmodes/cc-defs.el
+++ b/lisp/progmodes/cc-defs.el
@@ -81,7 +81,7 @@
(progn
(require 'font-lock)
(let (font-lock-keywords)
- (font-lock-compile-keywords '("\\<\\>"))
+ (font-lock-compile-keywords '("a\\`")) ; doesn't match anything.
font-lock-keywords))))
@@ -212,6 +212,13 @@ This variant works around bugs in `eval-when-compile' in various
`(cl-delete-duplicates ,cl-seq ,@cl-keys)
`(delete-duplicates ,cl-seq ,@cl-keys))))
+(defmacro c-font-lock-flush (beg end)
+ "Declare the region BEG...END's fontification as out-of-date.
+On XEmacs and older Emacsen, this refontifies that region immediately."
+ (if (fboundp 'font-lock-flush)
+ `(font-lock-flush ,beg ,end)
+ `(font-lock-fontify-region ,beg ,end)))
+
(defmacro c-point (position &optional point)
"Return the value of certain commonly referenced POSITIONs relative to POINT.
The current point is used if POINT isn't specified. POSITION can be
@@ -219,6 +226,7 @@ one of the following symbols:
`bol' -- beginning of line
`eol' -- end of line
+`eoll' -- end of logical line (i.e. without escaped NL)
`bod' -- beginning of defun
`eod' -- end of defun
`boi' -- beginning of indentation
@@ -240,7 +248,7 @@ to it is returned. This function does not modify the point or the mark."
((eq position 'bol)
(if (and (cc-bytecomp-fboundp 'line-beginning-position) (not point))
- `(line-beginning-position)
+ '(line-beginning-position)
`(save-excursion
,@(if point `((goto-char ,point)))
(beginning-of-line)
@@ -248,12 +256,24 @@ to it is returned. This function does not modify the point or the mark."
((eq position 'eol)
(if (and (cc-bytecomp-fboundp 'line-end-position) (not point))
- `(line-end-position)
+ '(line-end-position)
`(save-excursion
,@(if point `((goto-char ,point)))
(end-of-line)
(point))))
+ ((eq position 'eoll)
+ `(save-excursion
+ ,@(if point `((goto-char ,point)))
+ (while (and
+ (not (eobp))
+ (progn
+ (end-of-line)
+ (prog1 (eq (logand 1 (skip-chars-backward "\\\\")) 1))))
+ (forward-line))
+ (end-of-line)
+ (point)))
+
((eq position 'boi)
`(save-excursion
,@(if point `((goto-char ,point)))
@@ -274,7 +294,7 @@ to it is returned. This function does not modify the point or the mark."
((eq position 'bopl)
(if (and (cc-bytecomp-fboundp 'line-beginning-position) (not point))
- `(line-beginning-position 0)
+ '(line-beginning-position 0)
`(save-excursion
,@(if point `((goto-char ,point)))
(forward-line -1)
@@ -282,7 +302,7 @@ to it is returned. This function does not modify the point or the mark."
((eq position 'bonl)
(if (and (cc-bytecomp-fboundp 'line-beginning-position) (not point))
- `(line-beginning-position 2)
+ '(line-beginning-position 2)
`(save-excursion
,@(if point `((goto-char ,point)))
(forward-line 1)
@@ -290,7 +310,7 @@ to it is returned. This function does not modify the point or the mark."
((eq position 'eopl)
(if (and (cc-bytecomp-fboundp 'line-end-position) (not point))
- `(line-end-position 0)
+ '(line-end-position 0)
`(save-excursion
,@(if point `((goto-char ,point)))
(beginning-of-line)
@@ -299,7 +319,7 @@ to it is returned. This function does not modify the point or the mark."
((eq position 'eonl)
(if (and (cc-bytecomp-fboundp 'line-end-position) (not point))
- `(line-end-position 2)
+ '(line-end-position 2)
`(save-excursion
,@(if point `((goto-char ,point)))
(forward-line 1)
@@ -453,6 +473,13 @@ to it is returned. This function does not modify the point or the mark."
`(int-to-char ,integer)
integer))
+(defmacro c-characterp (arg)
+ ;; Return t when ARG is a character (XEmacs) or integer (Emacs), otherwise
+ ;; return nil.
+ (if (integerp ?c)
+ `(integerp ,arg)
+ `(characterp ,arg)))
+
(defmacro c-last-command-char ()
;; The last character just typed. Note that `last-command-event' exists in
;; both Emacs and XEmacs, but with confusingly different meanings.
@@ -464,17 +491,17 @@ to it is returned. This function does not modify the point or the mark."
;; Get the regular expression `sentence-end'.
(if (cc-bytecomp-fboundp 'sentence-end)
;; Emacs 22:
- `(sentence-end)
+ '(sentence-end)
;; Emacs <22 + XEmacs
- `sentence-end))
+ 'sentence-end))
(defmacro c-default-value-sentence-end ()
;; Get the default value of the variable sentence end.
(if (cc-bytecomp-fboundp 'sentence-end)
;; Emacs 22:
- `(let (sentence-end) (sentence-end))
+ '(let (sentence-end) (sentence-end))
;; Emacs <22 + XEmacs
- `(default-value 'sentence-end)))
+ '(default-value 'sentence-end)))
;; The following is essentially `save-buffer-state' from lazy-lock.el.
;; It ought to be a standard macro.
@@ -673,7 +700,7 @@ leave point unmoved.
A LIMIT for the search may be given. The start position is assumed to be
before it."
- `(let ((dest (c-safe-scan-lists ,(or pos `(point)) 1 0 ,limit)))
+ `(let ((dest (c-safe-scan-lists ,(or pos '(point)) 1 0 ,limit)))
(when dest (goto-char dest) dest)))
(defmacro c-go-list-backward (&optional pos limit)
@@ -683,7 +710,7 @@ leave point unmoved.
A LIMIT for the search may be given. The start position is assumed to be
after it."
- `(let ((dest (c-safe-scan-lists ,(or pos `(point)) -1 0 ,limit)))
+ `(let ((dest (c-safe-scan-lists ,(or pos '(point)) -1 0 ,limit)))
(when dest (goto-char dest) dest)))
(defmacro c-up-list-forward (&optional pos limit)
@@ -692,7 +719,7 @@ or nil if no such position exists. The point is used if POS is left out.
A limit for the search may be given. The start position is assumed to
be before it."
- `(c-safe-scan-lists ,(or pos `(point)) 1 1 ,limit))
+ `(c-safe-scan-lists ,(or pos '(point)) 1 1 ,limit))
(defmacro c-up-list-backward (&optional pos limit)
"Return the position of the start of the list sexp containing POS,
@@ -700,7 +727,7 @@ or nil if no such position exists. The point is used if POS is left out.
A limit for the search may be given. The start position is assumed to
be after it."
- `(c-safe-scan-lists ,(or pos `(point)) -1 1 ,limit))
+ `(c-safe-scan-lists ,(or pos '(point)) -1 1 ,limit))
(defmacro c-down-list-forward (&optional pos limit)
"Return the first position inside the first list sexp after POS,
@@ -708,7 +735,7 @@ or nil if no such position exists. The point is used if POS is left out.
A limit for the search may be given. The start position is assumed to
be before it."
- `(c-safe-scan-lists ,(or pos `(point)) 1 -1 ,limit))
+ `(c-safe-scan-lists ,(or pos '(point)) 1 -1 ,limit))
(defmacro c-down-list-backward (&optional pos limit)
"Return the last position inside the last list sexp before POS,
@@ -716,7 +743,7 @@ or nil if no such position exists. The point is used if POS is left out.
A limit for the search may be given. The start position is assumed to
be after it."
- `(c-safe-scan-lists ,(or pos `(point)) -1 -1 ,limit))
+ `(c-safe-scan-lists ,(or pos '(point)) -1 -1 ,limit))
(defmacro c-go-up-list-forward (&optional pos limit)
"Move the point to the first position after the list sexp containing POS,
@@ -877,7 +904,7 @@ be after it."
;; c-beginning-of-statement-1.
;; Languages which don't have EOL terminated statements always return NIL
;; (they _know_ there's no vsemi ;-).
- `(if c-vsemi-status-unknown-p-fn (funcall c-vsemi-status-unknown-p-fn)))
+ '(if c-vsemi-status-unknown-p-fn (funcall c-vsemi-status-unknown-p-fn)))
(defmacro c-benign-error (format &rest args)
@@ -1196,7 +1223,7 @@ Leave point just after the character, and set the match data on
this character, and return point. If the search fails, return
nil; point is then left undefined."
`(let ((char-skip (concat "^" (char-to-string ,char)))
- (-limit- ,limit)
+ (-limit- (or ,limit (point-max)))
(-value- ,value))
(while
(and
@@ -1208,15 +1235,39 @@ nil; point is then left undefined."
(search-forward-regexp ".") ; to set the match-data.
(point))))
+(defmacro c-search-forward-char-property-without-value-on-char
+ (property value char &optional limit)
+ "Search forward for a character CHAR without text property PROPERTY having
+a value CHAR.
+LIMIT bounds the search. The value comparison is done with `equal'.
+PROPERTY must be a constant.
+
+Leave point just after the character, and set the match data on
+this character, and return point. If the search fails, return
+nil; point is then left undefined."
+ `(let ((char-skip (concat "^" (char-to-string ,char)))
+ (-limit- (or ,limit (point-max)))
+ (-value- ,value))
+ (while
+ (and
+ (progn (skip-chars-forward char-skip -limit-)
+ (< (point) -limit-))
+ (equal (c-get-char-property (point) ,property) -value-))
+ (forward-char))
+ (when (< (point) -limit-)
+ (search-forward-regexp ".") ; to set the match-data.
+ (point))))
+
(defun c-clear-char-property-with-value-on-char-function (from to property
value char)
"Remove all text-properties PROPERTY with value VALUE on
characters with value CHAR from the region [FROM, TO), as tested
by `equal'. These properties are assumed to be over individual
characters, having been put there by c-put-char-property. POINT
-remains unchanged."
+remains unchanged. Return the position of the first removed
+property, or nil."
(let ((place from)
- )
+ first)
(while ; loop round occurrences of (PROPERTY VALUE)
(progn
(while ; loop round changes in PROPERTY till we find VALUE
@@ -1225,28 +1276,34 @@ remains unchanged."
(not (equal (get-text-property place property) value)))
(setq place (c-next-single-property-change place property nil to)))
(< place to))
- (if (eq (char-after place) char)
- (remove-text-properties place (1+ place) (cons property nil)))
+ (when (eq (char-after place) char)
+ (remove-text-properties place (1+ place) (cons property nil))
+ (or first (setq first place)))
;; Do we have to do anything with stickiness here?
- (setq place (1+ place)))))
+ (setq place (1+ place)))
+ first))
(defmacro c-clear-char-property-with-value-on-char (from to property value char)
"Remove all text-properties PROPERTY with value VALUE on
characters with value CHAR from the region [FROM, TO), as tested
by `equal'. These properties are assumed to be over individual
characters, having been put there by c-put-char-property. POINT
-remains unchanged."
+remains unchanged. Return the position of the first removed
+property, or nil."
(if c-use-extents
;; XEmacs
`(let ((-property- ,property)
- (-char- ,char))
+ (-char- ,char)
+ (first (1+ (point-max))))
(map-extents (lambda (ext val)
- (if (and (equal (extent-property ext -property-) val)
- (eq (char-after
- (extent-start-position ext))
- -char-))
- (delete-extent ext)))
- nil ,from ,to ,value nil -property-))
+ (when (and (equal (extent-property ext -property-) val)
+ (eq (char-after
+ (extent-start-position ext))
+ -char-))
+ (setq first (min first (extent-start-position ext)))
+ (delete-extent ext)))
+ nil ,from ,to ,value nil -property-)
+ (and (<= first (point-max)) first))
;; GNU Emacs
`(c-clear-char-property-with-value-on-char-function ,from ,to ,property
,value ,char)))
@@ -1298,20 +1355,37 @@ with value CHAR in the region [FROM to)."
;(eval-after-load "edebug" ; 2006-07-09: def-edebug-spec is now in subr.el.
; '(progn
(def-edebug-spec cc-eval-when-compile (&rest def-form))
+(def-edebug-spec c-font-lock-flush t)
+(def-edebug-spec c--mapcan t)
+(def-edebug-spec c--set-difference (form form &rest [symbolp form]))
+(def-edebug-spec c--intersection (form form &rest [symbolp form]))
+(def-edebug-spec c--delete-duplicates (form &rest [symbolp form]))
(def-edebug-spec c-point t)
+(def-edebug-spec c-next-single-property-change t)
+(def-edebug-spec c-delete-and-extract-region t)
(def-edebug-spec c-set-region-active t)
(def-edebug-spec c-set-keymap-parent t)
(def-edebug-spec c-safe t)
+(def-edebug-spec c-int-to-char t)
+(def-edebug-spec c-characterp t)
(def-edebug-spec c-save-buffer-state let*)
(def-edebug-spec c-tentative-buffer-changes t)
(def-edebug-spec c-forward-syntactic-ws t)
(def-edebug-spec c-backward-syntactic-ws t)
(def-edebug-spec c-forward-sexp t)
(def-edebug-spec c-backward-sexp t)
+(def-edebug-spec c-safe-scan-lists t)
+(def-edebug-spec c-go-list-forward t)
+(def-edebug-spec c-go-list-backward t)
(def-edebug-spec c-up-list-forward t)
(def-edebug-spec c-up-list-backward t)
(def-edebug-spec c-down-list-forward t)
(def-edebug-spec c-down-list-backward t)
+(def-edebug-spec c-go-up-list-forward t)
+(def-edebug-spec c-go-up-list-backward t)
+(def-edebug-spec c-go-down-list-forward t)
+(def-edebug-spec c-go-down-list-backward t)
+(def-edebug-spec c-at-vsemi-p t)
(def-edebug-spec c-add-syntax t)
(def-edebug-spec c-add-class-syntax t)
(def-edebug-spec c-benign-error t)
@@ -1319,15 +1393,28 @@ with value CHAR in the region [FROM to)."
(def-edebug-spec c-skip-ws-forward t)
(def-edebug-spec c-skip-ws-backward t)
(def-edebug-spec c-major-mode-is t)
+(def-edebug-spec c-search-forward-char-property t)
+(def-edebug-spec c-search-backward-char-property t)
(def-edebug-spec c-put-char-property t)
(def-edebug-spec c-get-char-property t)
(def-edebug-spec c-clear-char-property t)
+(def-edebug-spec c-clear-char-property-with-value t)
(def-edebug-spec c-clear-char-property-with-value-on-char t)
(def-edebug-spec c-put-char-properties-on-char t)
(def-edebug-spec c-clear-char-properties t)
(def-edebug-spec c-put-overlay t)
(def-edebug-spec c-delete-overlay t)
-(def-edebug-spec c-self-bind-state-cache t);))
+(def-edebug-spec c-mark-<-as-paren t)
+(def-edebug-spec c-mark->-as-paren t)
+(def-edebug-spec c-unmark-<->-as-paren t)
+(def-edebug-spec c-with-<->-as-parens-suppressed (body))
+(def-edebug-spec c-self-bind-state-cache (body))
+(def-edebug-spec c-sc-scan-lists-no-category+1+1 t)
+(def-edebug-spec c-sc-scan-lists-no-category+1-1 t)
+(def-edebug-spec c-sc-scan-lists-no-category-1+1 t)
+(def-edebug-spec c-sc-scan-lists-no-category-1-1 t)
+(def-edebug-spec c-sc-scan-lists t)
+(def-edebug-spec c-sc-parse-partial-sexp t);))
;;; Functions.
@@ -1560,12 +1647,12 @@ with value CHAR in the region [FROM to)."
(defmacro c-looking-at-non-alphnumspace ()
"Are we looking at a character which isn't alphanumeric or space?"
(if (memq 'gen-comment-delim c-emacs-features)
- `(looking-at
-"\\([;#]\\|\\'\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s$\\|\\s<\\|\\s>\\|\\s!\\)")
- `(or (looking-at
-"\\([;#]\\|\\'\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s$\\|\\s<\\|\\s>\\)"
- (let ((prop (c-get-char-property (point) 'syntax-table)))
- (eq prop '(14))))))) ; '(14) is generic comment delimiter.
+ '(looking-at
+ "\\([;#]\\|\\'\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s$\\|\\s<\\|\\s>\\|\\s!\\)")
+ '(or (looking-at
+ "\\([;#]\\|\\'\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s$\\|\\s<\\|\\s>\\)"
+ (let ((prop (c-get-char-property (point) 'syntax-table)))
+ (eq prop '(14))))))) ; '(14) is generic comment delimiter.
(defsubst c-intersect-lists (list alist)
@@ -1722,7 +1809,8 @@ when it's needed. The default is the current language taken from
t))
(setq pos (cdr pos)))
found))
- (setq pos list)
+ (setq pos (copy-tree list)
+ )
(while pos
(if (string-match "\\w\\'" (car pos))
(setcar pos (concat (car pos) unique)))
@@ -1775,10 +1863,10 @@ when it's needed. The default is the current language taken from
(t
re)))
- ;; Produce a regexp that matches nothing.
+ ;; Produce a regexp that doesn't match anything.
(if adorn
- "\\(\\<\\>\\)"
- "\\<\\>")))
+ "\\(a\\`\\)"
+ "a\\`")))
(put 'c-make-keywords-re 'lisp-indent-function 1)
@@ -1789,7 +1877,7 @@ The returned string is of the type that can be used with
non-nil, a caret is prepended to invert the set."
;; This function ought to be in the elisp core somewhere.
(let ((str (if inverted "^" "")) char char2)
- (setq chars (sort (append chars nil) `<))
+ (setq chars (sort (append chars nil) #'<))
(while chars
(setq char (pop chars))
(if (memq char '(?\\ ?^ ?-))
@@ -1840,7 +1928,7 @@ non-nil, a caret is prepended to invert the set."
(setq entry (get-char-table ?a table)))
;; incompatible
(t (error "CC Mode is incompatible with this version of Emacs")))
- (setq list (cons (if (= (logand (lsh entry -16) 255) 255)
+ (setq list (cons (if (= (logand (ash entry -16) 255) 255)
'8-bit
'1-bit)
list)))
diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el
index 965886727d9..1a8c5164906 100644
--- a/lisp/progmodes/cc-engine.el
+++ b/lisp/progmodes/cc-engine.el
@@ -152,8 +152,6 @@
(cc-require-when-compile 'cc-langs)
(cc-require 'cc-vars)
-(eval-when-compile (require 'cl))
-
;; Make declarations for all the `c-lang-defvar' variables in cc-langs.
@@ -665,10 +663,12 @@ comment at the start of cc-engine.el for more info."
stack (cdr stack))
t
,do-if-done
+ (setq pre-stmt-found t)
(throw 'loop nil)))
(defmacro c-bos-pop-state-and-retry ()
'(throw 'loop (setq state (car (car stack))
saved-pos (cdr (car stack))
+ pre-stmt-found (not (cdr stack))
;; Throw nil if stack is empty, else throw non-nil.
stack (cdr stack))))
(defmacro c-bos-save-pos ()
@@ -694,7 +694,7 @@ comment at the start of cc-engine.el for more info."
(c-point 'bol (elt saved-pos 0))))))))
(defun c-beginning-of-statement-1 (&optional lim ignore-labels
- noerror comma-delim)
+ noerror comma-delim hit-lim)
"Move to the start of the current statement or declaration, or to
the previous one if already at the beginning of one. Only
statements/declarations on the same level are considered, i.e. don't
@@ -729,14 +729,16 @@ Return:
`up' if stepped to a containing statement;
`previous' if stepped to a preceding statement;
`beginning' if stepped from a statement continuation clause to
- its start clause; or
-`macro' if stepped to a macro start.
+ its start clause;
+`macro' if stepped to a macro start; or
+nil if HIT-LIM is non-nil, and we hit the limit.
Note that `same' and not `label' is returned if stopped at the same
label without crossing the colon character.
LIM may be given to limit the search. If the search hits the limit,
point will be left at the closest following token, or at the start
-position if that is less (`same' is returned in this case).
+position if that is less. If HIT-LIM is non-nil, nil is returned in
+this case, otherwise `same'.
NOERROR turns off error logging to `c-parsing-error'.
@@ -840,6 +842,10 @@ comment at the start of cc-engine.el for more info."
pos
;; Position of last stmt boundary character (e.g. ;).
boundary-pos
+ ;; Non-nil when a construct has been found which delimits the search
+ ;; for a statement start, e.g. an opening brace or a macro start, or a
+ ;; keyword like `if' when the PDA stack is empty.
+ pre-stmt-found
;; The position of the last sexp or bound that follows the
;; first found colon, i.e. the start of the nonlabel part of
;; the statement. It's `start' if a colon is found just after
@@ -870,14 +876,17 @@ comment at the start of cc-engine.el for more info."
stack
;; Regexp which matches "for", "if", etc.
(cond-key (or c-opt-block-stmt-key
- "\\<\\>")) ; Matches nothing.
+ "a\\`")) ; Doesn't match anything.
;; Return value.
(ret 'same)
;; Positions of the last three sexps or bounds we've stopped at.
tok ptok pptok)
(save-restriction
- (if lim (narrow-to-region lim (point-max)))
+ (setq lim (if lim
+ (max lim (point-min))
+ (point-min)))
+ (widen)
(if (save-excursion
(and (c-beginning-of-macro)
@@ -923,9 +932,10 @@ comment at the start of cc-engine.el for more info."
;; The loop is exited only by throwing nil to the (catch 'loop ...):
;; 1. On reaching the start of a macro;
;; 2. On having passed a stmt boundary with the PDA stack empty;
- ;; 3. On reaching the start of an Objective C method def;
- ;; 4. From macro `c-bos-pop-state'; when the stack is empty;
- ;; 5. From macro `c-bos-pop-state-and-retry' when the stack is empty.
+ ;; 3. Going backwards past the search limit.
+ ;; 4. On reaching the start of an Objective C method def;
+ ;; 5. From macro `c-bos-pop-state'; when the stack is empty;
+ ;; 6. From macro `c-bos-pop-state-and-retry' when the stack is empty.
(while
(catch 'loop ;; Throw nil to break, non-nil to continue.
(cond
@@ -950,6 +960,7 @@ comment at the start of cc-engine.el for more info."
(setq pos saved
ret 'macro
ignore-labels t))
+ (setq pre-stmt-found t)
(throw 'loop nil)) ; 1. Start of macro.
;; Do a round through the automaton if we've just passed a
@@ -959,6 +970,7 @@ comment at the start of cc-engine.el for more info."
(setq sym (intern (match-string 1)))))
(when (and (< pos start) (null stack))
+ (setq pre-stmt-found t)
(throw 'loop nil)) ; 2. Statement boundary.
;; The PDA state handling.
@@ -1071,7 +1083,8 @@ comment at the start of cc-engine.el for more info."
;; Step to the previous sexp, but not if we crossed a
;; boundary, since that doesn't consume an sexp.
(if (eq sym 'boundary)
- (setq ret 'previous)
+ (when (>= (point) lim)
+ (setq ret 'previous))
;; HERE IS THE SINGLE PLACE INSIDE THE PDA LOOP WHERE WE MOVE
;; BACKWARDS THROUGH THE SOURCE.
@@ -1080,16 +1093,20 @@ comment at the start of cc-engine.el for more info."
(let ((before-sws-pos (point))
;; The end position of the area to search for statement
;; barriers in this round.
- (maybe-after-boundary-pos pos))
+ (maybe-after-boundary-pos pos)
+ comma-delimited)
;; Go back over exactly one logical sexp, taking proper
;; account of macros and escaped EOLs.
(while
(progn
+ (setq comma-delimited (and (not comma-delim)
+ (eq (char-before) ?\,)))
(unless (c-safe (c-backward-sexp) t)
;; Give up if we hit an unbalanced block. Since the
;; stack won't be empty the code below will report a
;; suitable error.
+ (setq pre-stmt-found t)
(throw 'loop nil))
(cond
;; Have we moved into a macro?
@@ -1121,10 +1138,23 @@ comment at the start of cc-engine.el for more info."
;; Just gone back over a brace block?
((and
(eq (char-after) ?{)
+ (not comma-delimited)
(not (c-looking-at-inexpr-block lim nil t))
(save-excursion
(c-backward-token-2 1 t nil)
- (not (looking-at "=\\([^=]\\|$\\)"))))
+ (not (looking-at "=\\([^=]\\|$\\)")))
+ (or
+ (not c-opt-block-decls-with-vars-key)
+ (save-excursion
+ (c-backward-token-2 1 t nil)
+ (if (and (looking-at c-symbol-start)
+ (not (looking-at c-keywords-regexp)))
+ (c-backward-token-2 1 t nil))
+ (and
+ (not (looking-at
+ c-opt-block-decls-with-vars-key))
+ (or comma-delim
+ (not (eq (char-after) ?\,)))))))
(save-excursion
(c-forward-sexp) (point)))
;; Just gone back over some paren block?
@@ -1146,12 +1176,17 @@ comment at the start of cc-engine.el for more info."
;; Like a C "continue". Analyze the next sexp.
(throw 'loop t))))
+ ;; Have we gone past the limit?
+ (when (< (point) lim)
+ (throw 'loop nil)) ; 3. Gone back over the limit.
+
;; ObjC method def?
(when (and c-opt-method-key
(setq saved (c-in-method-def-p)))
(setq pos saved
+ pre-stmt-found t
ignore-labels t) ; Avoid the label check on exit.
- (throw 'loop nil)) ; 3. ObjC method def.
+ (throw 'loop nil)) ; 4. ObjC method def.
;; Might we have a bitfield declaration, "<type> <id> : <size>"?
(if c-has-bitfields
@@ -1212,9 +1247,15 @@ comment at the start of cc-engine.el for more info."
ptok tok
tok (point)
pos tok) ; always non-nil
- ) ; end of (catch loop ....)
+ ) ; end of (catch 'loop ....)
) ; end of sexp-at-a-time (while ....)
+ (when (and hit-lim
+ (or (not pre-stmt-found)
+ (< pos lim)
+ (>= pos start)))
+ (setq ret nil))
+
;; If the stack isn't empty there might be errors to report.
(while stack
(if (and (vectorp saved-pos) (eq (length saved-pos) 3))
@@ -1273,7 +1314,7 @@ comment at the start of cc-engine.el for more info."
(c-backward-syntactic-ws)
;; protect AWK post-inc/decrement operators, etc.
(and (not (c-at-vsemi-p (point)))
- (/= (skip-chars-backward "-+!*&~@`#") 0)))
+ (/= (skip-chars-backward "-.+!*&~@`#") 0)))
(setq pos (point)))
(goto-char pos)
ret)))
@@ -1690,36 +1731,41 @@ comment at the start of cc-engine.el for more info."
`(let ((beg ,beg) (end ,end))
(put-text-property beg end 'c-is-sws t)
,@(when (facep 'c-debug-is-sws-face)
- `((c-debug-add-face beg end 'c-debug-is-sws-face)))))
+ '((c-debug-add-face beg end 'c-debug-is-sws-face)))))
+(def-edebug-spec c-put-is-sws t)
(defmacro c-put-in-sws (beg end)
;; This macro does a hidden buffer change.
`(let ((beg ,beg) (end ,end))
(put-text-property beg end 'c-in-sws t)
,@(when (facep 'c-debug-is-sws-face)
- `((c-debug-add-face beg end 'c-debug-in-sws-face)))))
+ '((c-debug-add-face beg end 'c-debug-in-sws-face)))))
+(def-edebug-spec c-put-in-sws t)
(defmacro c-remove-is-sws (beg end)
;; This macro does a hidden buffer change.
`(let ((beg ,beg) (end ,end))
(remove-text-properties beg end '(c-is-sws nil))
,@(when (facep 'c-debug-is-sws-face)
- `((c-debug-remove-face beg end 'c-debug-is-sws-face)))))
+ '((c-debug-remove-face beg end 'c-debug-is-sws-face)))))
+(def-edebug-spec c-remove-is-sws t)
(defmacro c-remove-in-sws (beg end)
;; This macro does a hidden buffer change.
`(let ((beg ,beg) (end ,end))
(remove-text-properties beg end '(c-in-sws nil))
,@(when (facep 'c-debug-is-sws-face)
- `((c-debug-remove-face beg end 'c-debug-in-sws-face)))))
+ '((c-debug-remove-face beg end 'c-debug-in-sws-face)))))
+(def-edebug-spec c-remove-in-sws t)
(defmacro c-remove-is-and-in-sws (beg end)
;; This macro does a hidden buffer change.
`(let ((beg ,beg) (end ,end))
(remove-text-properties beg end '(c-is-sws nil c-in-sws nil))
,@(when (facep 'c-debug-is-sws-face)
- `((c-debug-remove-face beg end 'c-debug-is-sws-face)
+ '((c-debug-remove-face beg end 'c-debug-is-sws-face)
(c-debug-remove-face beg end 'c-debug-in-sws-face)))))
+(def-edebug-spec c-remove-is-and-in-sws t)
;; The type of literal position `end' is in a `before-change-functions'
;; function - one of `c', `c++', `pound', or nil (but NOT `string').
@@ -1728,12 +1774,14 @@ comment at the start of cc-engine.el for more info."
;; enclosing END, if any, else nil.
(defvar c-sws-lit-limits nil)
-(defun c-invalidate-sws-region-before (end)
- ;; Called from c-before-change. END is the end of the change region, the
- ;; standard parameter given to all before-change-functions.
+(defun c-invalidate-sws-region-before (beg end)
+ ;; Called from c-before-change. BEG and END are the bounds of the change
+ ;; region, the standard parameters given to all before-change-functions.
;;
- ;; Note whether END is inside a comment or CPP construct, and if so note its
- ;; bounds in `c-sws-lit-limits' and type in `c-sws-lit-type'.
+ ;; Note whether END is inside a comment, CPP construct, or noise macro, and
+ ;; if so note its bounds in `c-sws-lit-limits' and type in `c-sws-lit-type'.
+ (setq c-sws-lit-type nil
+ c-sws-lit-limits nil)
(save-excursion
(goto-char end)
(let* ((limits (c-literal-limits))
@@ -1746,8 +1794,19 @@ comment at the start of cc-engine.el for more info."
(setq c-sws-lit-type 'pound
c-sws-lit-limits (cons (point)
(progn (c-end-of-macro) (point)))))
- (t (setq c-sws-lit-type nil
- c-sws-lit-limits nil))))))
+ ((progn (skip-syntax-backward "w_")
+ (looking-at c-noise-macro-name-re))
+ (setq c-sws-lit-type 'noise
+ c-sws-lit-limits (cons (match-beginning 1) (match-end 1))))
+ (t))))
+ (save-excursion
+ (goto-char beg)
+ (skip-syntax-backward "w_")
+ (when (looking-at c-noise-macro-name-re)
+ (setq c-sws-lit-type 'noise)
+ (if (consp c-sws-lit-limits)
+ (setcar c-sws-lit-limits (match-beginning 1))
+ (setq c-sws-lit-limits (cons (match-beginning 1) (match-end 1)))))))
(defun c-invalidate-sws-region-after-del (beg end old-len)
;; Text has been deleted, OLD-LEN characters of it starting from position
@@ -1756,7 +1815,6 @@ comment at the start of cc-engine.el for more info."
;; deletion deleted or "damaged" its opening delimiter. If so, return the
;; current position of where the construct ended, otherwise return nil.
(when c-sws-lit-limits
- (setcdr c-sws-lit-limits (- (cdr c-sws-lit-limits) old-len))
(if (and (< beg (+ (car c-sws-lit-limits) 2)) ; A lazy assumption that
; comment delimiters are 2
; chars long.
@@ -1774,9 +1832,9 @@ comment at the start of cc-engine.el for more info."
;; or `c-is-sws' text properties inside this literal. If there are, return
;; the buffer position of the end of the literal, else return nil.
(save-excursion
+ (goto-char end)
(let* ((limits (c-literal-limits))
(lit-type (c-literal-type limits)))
- (goto-char end)
(when (and (not (memq lit-type '(c c++)))
(c-beginning-of-macro))
(setq lit-type 'pound
@@ -1800,6 +1858,10 @@ comment at the start of cc-engine.el for more info."
;; properties right after they're added.
;;
;; This function does hidden buffer changes.
+ (when c-sws-lit-limits
+ (setcar c-sws-lit-limits (min beg (car c-sws-lit-limits)))
+ (setcdr c-sws-lit-limits
+ (max end (- (+ (cdr c-sws-lit-limits) (- end beg)) old-len))))
(let ((del-end
(and (> old-len 0)
(c-invalidate-sws-region-after-del beg end old-len)))
@@ -1819,6 +1881,10 @@ comment at the start of cc-engine.el for more info."
(when (and (eolp) (not (eobp)))
(setq end (1+ (point)))))
+ (when (eq c-sws-lit-type 'noise)
+ (setq beg (car c-sws-lit-limits)
+ end (cdr c-sws-lit-limits))) ; This last setting may be redundant.
+
(when (and (= beg end)
(get-text-property beg 'c-in-sws)
(> beg (point-min))
@@ -1838,6 +1904,7 @@ comment at the start of cc-engine.el for more info."
(setq end (max (or del-end end)
(or ins-end end)
+ (or (cdr c-sws-lit-limits) end)
end))
(c-debug-sws-msg "c-invalidate-sws-region-after [%s..%s]" beg end)
@@ -2106,7 +2173,8 @@ comment at the start of cc-engine.el for more info."
;; Try to find a rung position in the simple ws preceding point, so that
;; we can get a cache hit even if the last bit of the simple ws has
;; changed recently.
- (setq simple-ws-beg (point))
+ (setq simple-ws-beg (or (match-end 1) ; Noise macro
+ (match-end 0))) ; c-syntactic-ws-end
(skip-chars-backward " \t\n\r\f\v")
(if (setq rung-is-marked (text-property-any
(point) (min (1+ rung-pos) (point-max))
@@ -3870,9 +3938,10 @@ comment at the start of cc-engine.el for more info."
(defmacro c-state-maybe-marker (place marker)
;; If PLACE is non-nil, return a marker marking it, otherwise nil.
;; We (re)use MARKER.
- `(and ,place
- (or ,marker (setq ,marker (make-marker)))
- (set-marker ,marker ,place)))
+ `(let ((-place- ,place))
+ (and -place-
+ (or ,marker (setq ,marker (make-marker)))
+ (set-marker ,marker -place-))))
(defun c-parse-state ()
;; This is a wrapper over `c-parse-state-1'. See that function for a
@@ -4286,6 +4355,41 @@ comment at the start of cc-engine.el for more info."
"\\w\\|\\s_\\|\\s\"\\|\\s|"
"\\w\\|\\s_\\|\\s\""))
+(defun c-forward-over-token (&optional balanced)
+ "Move forward over a token.
+Return t if we moved, nil otherwise (i.e. we were at EOB, or a
+non-token or BALANCED is non-nil and we can't move). If we
+are at syntactic whitespace, move over this in place of a token.
+
+If BALANCED is non-nil move over any balanced parens we are at, and never move
+out of an enclosing paren."
+ (let ((jump-syntax (if balanced
+ c-jump-syntax-balanced
+ c-jump-syntax-unbalanced))
+ (here (point)))
+ (condition-case nil
+ (cond
+ ((/= (point)
+ (progn (c-forward-syntactic-ws) (point)))
+ ;; If we're at whitespace, count this as the token.
+ t)
+ ((eobp) nil)
+ ((looking-at jump-syntax)
+ (goto-char (scan-sexps (point) 1))
+ t)
+ ((looking-at c-nonsymbol-token-regexp)
+ (goto-char (match-end 0))
+ t)
+ ((save-restriction
+ (widen)
+ (looking-at c-nonsymbol-token-regexp))
+ nil)
+ (t
+ (forward-char)
+ t))
+ (error (goto-char here)
+ nil))))
+
(defun c-forward-over-token-and-ws (&optional balanced)
"Move forward over a token and any following whitespace
Return t if we moved, nil otherwise (i.e. we were at EOB, or a
@@ -4297,35 +4401,8 @@ out of an enclosing paren.
This function differs from `c-forward-token-2' in that it will move forward
over the final token in a buffer, up to EOB."
- (let ((jump-syntax (if balanced
- c-jump-syntax-balanced
- c-jump-syntax-unbalanced))
- (here (point)))
- (when
- (condition-case nil
- (cond
- ((/= (point)
- (progn (c-forward-syntactic-ws) (point)))
- ;; If we're at whitespace, count this as the token.
- t)
- ((eobp) nil)
- ((looking-at jump-syntax)
- (goto-char (scan-sexps (point) 1))
- t)
- ((looking-at c-nonsymbol-token-regexp)
- (goto-char (match-end 0))
- t)
- ((save-restriction
- (widen)
- (looking-at c-nonsymbol-token-regexp))
- nil)
- (t
- (forward-char)
- t))
- (error (goto-char here)
- nil))
- (c-forward-syntactic-ws)
- t)))
+ (prog1 (c-forward-over-token balanced)
+ (c-forward-syntactic-ws)))
(defun c-forward-token-2 (&optional count balanced limit)
"Move forward by tokens.
@@ -4727,56 +4804,6 @@ comment at the start of cc-engine.el for more info."
(defvar safe-pos-list) ; bound in c-syntactic-skip-backward
-(defsubst c-ssb-lit-begin ()
- ;; Return the start of the literal point is in, or nil.
- ;; We read and write the variables `safe-pos', `safe-pos-list', `state'
- ;; bound in the caller.
-
- ;; Use `parse-partial-sexp' from a safe position down to the point to check
- ;; if it's outside comments and strings.
- (save-excursion
- (let ((pos (point)) safe-pos state)
- ;; Pick a safe position as close to the point as possible.
- ;;
- ;; FIXME: Consult `syntax-ppss' here if our cache doesn't give a good
- ;; position.
-
- (while (and safe-pos-list
- (> (car safe-pos-list) (point)))
- (setq safe-pos-list (cdr safe-pos-list)))
- (unless (setq safe-pos (car-safe safe-pos-list))
- (setq safe-pos (max (or (c-safe-position
- (point) (c-parse-state))
- 0)
- (point-min))
- safe-pos-list (list safe-pos)))
-
- ;; Cache positions along the way to use if we have to back up more. We
- ;; cache every closing paren on the same level. If the paren cache is
- ;; relevant in this region then we're typically already on the same
- ;; level as the target position. Note that we might cache positions
- ;; after opening parens in case safe-pos is in a nested list. That's
- ;; both uncommon and harmless.
- (while (progn
- (setq state (parse-partial-sexp
- safe-pos pos 0))
- (< (point) pos))
- (setq safe-pos (point)
- safe-pos-list (cons safe-pos safe-pos-list)))
-
- ;; If the state contains the start of the containing sexp we cache that
- ;; position too, so that parse-partial-sexp in the next run has a bigger
- ;; chance of starting at the same level as the target position and thus
- ;; will get more good safe positions into the list.
- (if (elt state 1)
- (setq safe-pos (1+ (elt state 1))
- safe-pos-list (cons safe-pos safe-pos-list)))
-
- (if (or (elt state 3) (elt state 4))
- ;; Inside string or comment. Continue search at the
- ;; beginning of it.
- (elt state 8)))))
-
(defun c-syntactic-skip-backward (skip-chars &optional limit paren-level)
"Like `skip-chars-backward' but only look at syntactically relevant chars,
i.e. don't stop at positions inside syntactic whitespace or string
@@ -4793,108 +4820,110 @@ Non-nil is returned if the point moved, nil otherwise.
Note that this function might do hidden buffer changes. See the
comment at the start of cc-engine.el for more info."
-
- (c-self-bind-state-cache
- (let ((start (point))
- ;; A list of syntactically relevant positions in descending
- ;; order. It's used to avoid scanning repeatedly over
- ;; potentially large regions with `parse-partial-sexp' to verify
- ;; each position. Used in `c-ssb-lit-begin'
- safe-pos-list
+ (let* ((start (point))
;; The result from `c-beginning-of-macro' at the start position or the
- ;; start position itself if it isn't within a macro. Evaluated on
- ;; demand.
- start-macro-beg
+ ;; start position itself if it isn't within a macro.
+ (start-macro-beg
+ (save-excursion
+ (goto-char start)
+ (c-beginning-of-macro limit)
+ (point)))
+ lit-beg
;; The earliest position after the current one with the same paren
;; level. Used only when `paren-level' is set.
- lit-beg
- (paren-level-pos (point)))
+ (paren-level-pos (point))
+ ;; Whether we can optimize with an early `c-backward-syntactic-ws'.
+ (opt-ws (string-match "^\\^[^ \t\n\r]+$" skip-chars)))
- (while
- (progn
- ;; The next loop "tries" to find the end point each time round,
- ;; loops when it hasn't succeeded.
- (while
- (and
- (let ((pos (point)))
- (while (and
- (< (skip-chars-backward skip-chars limit) 0)
- ;; Don't stop inside a literal.
- (when (setq lit-beg (c-ssb-lit-begin))
+ ;; In the next while form, we only loop when `skip-chars' is something
+ ;; like "^/" and we've stopped at the end of a block comment.
+ (while
+ (progn
+ ;; The next loop "tries" to find the end point each time round,
+ ;; loops when it's ended up at the wrong level of nesting.
+ (while
+ (and
+ ;; Optimize for, in particular, large blocks of comments from
+ ;; `comment-region'.
+ (progn (when opt-ws
+ (c-backward-syntactic-ws)
+ (setq paren-level-pos (point)))
+ t)
+ ;; Move back to a candidate end point which isn't in a literal
+ ;; or in a macro we didn't start in.
+ (let ((pos (point))
+ macro-start)
+ (while (and
+ (< (skip-chars-backward skip-chars limit) 0)
+ (or
+ (when (setq lit-beg (c-literal-start))
(goto-char lit-beg)
- t)))
- (< (point) pos))
-
- (let ((pos (point)) state-2 pps-end-pos)
-
- (cond
- ((and paren-level
- (save-excursion
- (setq state-2 (parse-partial-sexp
- pos paren-level-pos -1)
- pps-end-pos (point))
- (/= (car state-2) 0)))
- ;; Not at the right level.
-
- (if (and (< (car state-2) 0)
- ;; We stop above if we go out of a paren.
- ;; Now check whether it precedes or is
- ;; nested in the starting sexp.
- (save-excursion
- (setq state-2
- (parse-partial-sexp
- pps-end-pos paren-level-pos
- nil nil state-2))
- (< (car state-2) 0)))
-
- ;; We've stopped short of the starting position
- ;; so the hit was inside a nested list. Go up
- ;; until we are at the right level.
- (condition-case nil
- (progn
- (goto-char (scan-lists pos -1
- (- (car state-2))))
- (setq paren-level-pos (point))
- (if (and limit (>= limit paren-level-pos))
- (progn
- (goto-char limit)
- nil)
- t))
- (error
- (goto-char (or limit (point-min)))
- nil))
-
- ;; The hit was outside the list at the start
- ;; position. Go to the start of the list and exit.
- (goto-char (1+ (elt state-2 1)))
- nil))
-
- ((c-beginning-of-macro limit)
- ;; Inside a macro.
- (if (< (point)
- (or start-macro-beg
- (setq start-macro-beg
- (save-excursion
- (goto-char start)
- (c-beginning-of-macro limit)
- (point)))))
- t
-
- ;; It's inside the same macro we started in so it's
- ;; a relevant match.
- (goto-char pos)
- nil))))))
-
- (> (point)
- (progn
- ;; Skip syntactic ws afterwards so that we don't stop at the
- ;; end of a comment if `skip-chars' is something like "^/".
- (c-backward-syntactic-ws)
- (point)))))
+ t)
+ ;; Don't stop inside a macro we didn't start in.
+ (when
+ (save-excursion
+ (and (c-beginning-of-macro limit)
+ (< (point) start-macro-beg)
+ (setq macro-start (point))))
+ (goto-char macro-start))))
+ (when opt-ws
+ (c-backward-syntactic-ws)))
+ (< (point) pos))
+
+ ;; Check whether we're at the wrong level of nesting (when
+ ;; `paren-level' is non-nil).
+ (let ((pos (point)) state-2 pps-end-pos)
+ (when
+ (and paren-level
+ (save-excursion
+ (setq state-2 (parse-partial-sexp
+ pos paren-level-pos -1)
+ pps-end-pos (point))
+ (/= (car state-2) 0)))
+ ;; Not at the right level.
+ (if (and (< (car state-2) 0)
+ ;; We stop above if we go out of a paren.
+ ;; Now check whether it precedes or is
+ ;; nested in the starting sexp.
+ (save-excursion
+ (setq state-2
+ (parse-partial-sexp
+ pps-end-pos paren-level-pos
+ nil nil state-2))
+ (< (car state-2) 0)))
+
+ ;; We've stopped short of the starting position
+ ;; so the hit was inside a nested list. Go up
+ ;; until we are at the right level.
+ (condition-case nil
+ (progn
+ (goto-char (scan-lists pos -1
+ (- (car state-2))))
+ (setq paren-level-pos (point))
+ (if (and limit (>= limit paren-level-pos))
+ (progn
+ (goto-char limit)
+ nil)
+ t))
+ (error
+ (goto-char (or limit (point-min)))
+ nil))
+
+ ;; The hit was outside the list at the start
+ ;; position. Go to the start of the list and exit.
+ (goto-char (1+ (elt state-2 1)))
+ nil)))))
+
+ (> (point)
+ (progn
+ ;; Skip syntactic ws afterwards so that we don't stop at the
+ ;; end of a comment if `skip-chars' is something like "^/".
+ (c-backward-syntactic-ws)
+ (point)))))
- ;; We might want to extend this with more useful return values in
- ;; the future.
- (/= (point) start))))
+ ;; We might want to extend this with more useful return values in
+ ;; the future.
+ (/= (point) start)))
;; The following is an alternative implementation of
;; `c-syntactic-skip-backward' that uses backward movement to keep
@@ -5089,7 +5118,7 @@ comment at the start of cc-engine.el for more info."
(setq beg (c-safe (c-backward-sexp 1) (point))))
((and (c-safe (forward-char -2) t)
- (looking-at "*/"))
+ (looking-at "\\*/"))
;; Block comment. Due to the nature of line
;; comments, they will always be covered by the
;; normal case above.
@@ -5177,6 +5206,9 @@ comment at the start of cc-engine.el for more info."
(defsubst c-determine-limit-get-base (start try-size)
;; Get a "safe place" approximately TRY-SIZE characters before START.
;; This defsubst doesn't preserve point.
+ (goto-char start)
+ (c-backward-syntactic-ws)
+ (setq start (point))
(let* ((pos (max (- start try-size) (point-min)))
(s (c-state-semi-pp-to-literal pos))
(cand (or (car (cddr s)) pos)))
@@ -5186,9 +5218,9 @@ comment at the start of cc-engine.el for more info."
(point))))
(defun c-determine-limit (how-far-back &optional start try-size)
- ;; Return a buffer position HOW-FAR-BACK non-literal characters from
- ;; START (default point). The starting position, either point or
- ;; START may not be in a comment or string.
+ ;; Return a buffer position approximately HOW-FAR-BACK non-literal
+ ;; characters from START (default point). The starting position, either
+ ;; point or START may not be in a comment or string.
;;
;; The position found will not be before POINT-MIN and won't be in a
;; literal.
@@ -5206,6 +5238,12 @@ comment at the start of cc-engine.el for more info."
(s (parse-partial-sexp pos pos)) ; null state.
stack elt size
(count 0))
+ ;; Optimization for large blocks of comments, particularly those being
+ ;; created by `comment-region'.
+ (goto-char pos)
+ (forward-comment try-size)
+ (setq pos (point))
+
(while (< pos start)
;; Move forward one literal each time round this loop.
;; Move forward to the start of a comment or string.
@@ -5248,6 +5286,10 @@ comment at the start of cc-engine.el for more info."
;; Have we found enough yet?
(cond
+ ((null elt) ; No non-literal characters found.
+ (if (> base (point-min))
+ (c-determine-limit how-far-back base (* 2 try-size))
+ (point-min)))
((>= count how-far-back)
(+ (car elt) (- count how-far-back)))
((eq base (point-min))
@@ -5255,7 +5297,7 @@ comment at the start of cc-engine.el for more info."
((> base (- start try-size)) ; Can only happen if we hit point-min.
(car elt))
(t
- (c-determine-limit (- how-far-back count) base try-size))))))
+ (c-determine-limit (- how-far-back count) base (* 2 try-size)))))))
(defun c-determine-+ve-limit (how-far &optional start-pos)
;; Return a buffer position about HOW-FAR non-literal characters forward
@@ -5604,8 +5646,12 @@ comment at the start of cc-engine.el for more info."
;; Pseudo match inside a comment or string literal. Skip out
;; of comments and string literals.
(while (progn
- (goto-char (c-next-single-property-change
- (point) 'face nil cfd-limit))
+ (unless
+ (and (match-end 1)
+ (c-got-face-at (1- (point)) c-literal-faces)
+ (not (c-got-face-at (point) c-literal-faces)))
+ (goto-char (c-next-single-property-change
+ (point) 'face nil cfd-limit)))
(and (< (point) cfd-limit)
(c-got-face-at (point) c-literal-faces))))
t) ; Continue the loop over pseudo matches.
@@ -6308,9 +6354,8 @@ comment at the start of cc-engine.el for more info."
;; Set by c-common-init in cc-mode.el.
(defvar c-new-BEG)
(defvar c-new-END)
-;; Set by c-after-change in cc-mode.el.
-(defvar c-old-BEG)
-(defvar c-old-END)
+;; Set by c-before-change-check-raw-strings.
+(defvar c-old-END-literality)
(defun c-before-change-check-<>-operators (beg end)
;; Unmark certain pairs of "< .... >" which are currently marked as
@@ -6442,9 +6487,9 @@ comment at the start of cc-engine.el for more info."
;; A valid C++ raw string looks like
;; R"<id>(<contents>)<id>"
;; , where <id> is an identifier from 0 to 16 characters long, not containing
-;; spaces, control characters, double quote or left/right paren. <contents>
-;; can include anything which isn't the terminating )<id>", including new
-;; lines, "s, parentheses, etc.
+;; spaces, control characters, or left/right paren. <contents> can include
+;; anything which isn't the terminating )<id>", including new lines, "s,
+;; parentheses, etc.
;;
;; CC Mode handles C++ raw strings by the use of `syntax-table' text
;; properties as follows:
@@ -6454,16 +6499,18 @@ comment at the start of cc-engine.el for more info."
;; contents is given the property value "punctuation" (`(1)') to prevent it
;; interacting with the "s in the delimiters.
;;
-;; The font locking routine `c-font-lock-c++-raw-strings' (in cc-fonts.el)
+;; The font locking routine `c-font-lock-raw-strings' (in cc-fonts.el)
;; recognizes valid raw strings, and fontifies the delimiters (apart from
;; the parentheses) with the default face and the parentheses and the
;; <contents> with font-lock-string-face.
;;
;; (ii) A valid, but unterminated, raw string opening delimiter gets the
;; "punctuation" value (`(1)') of the `syntax-table' text property, and the
-;; open parenthesis gets the "string fence" value (`(15)').
+;; open parenthesis gets the "string fence" value (`(15)'). When such a
+;; delimiter is found, no attempt is made in any way to "correct" any text
+;; properties after the delimiter.
;;
-;; `c-font-lock-c++-raw-strings' puts c-font-lock-warning-face on the entire
+;; `c-font-lock-raw-strings' puts c-font-lock-warning-face on the entire
;; unmatched opening delimiter (from the R up to the open paren), and allows
;; the rest of the buffer to get font-lock-string-face, caused by the
;; unmatched "string fence" `syntax-table' text property value.
@@ -6480,10 +6527,14 @@ comment at the start of cc-engine.el for more info."
;; already at the end of the macro, it gets the "punctuation" value, and no
;; "string fence"s are used.
;;
-;; The effect on the fontification of either of these tactics is that rest of
-;; the macro (if any) after the "(" gets font-lock-string-face, but the rest
-;; of the file is fontified normally.
+;; The effect on the fontification of either of these tactics is that the
+;; rest of the macro (if any) after the "(" gets font-lock-string-face, but
+;; the rest of the file is fontified normally.
+;; The values of the function `c-raw-string-pos' at before-change-functions'
+;; BEG and END.
+(defvar c-old-beg-rs nil)
+(defvar c-old-end-rs nil)
(defun c-raw-string-pos ()
;; Get POINT's relationship to any containing raw string.
@@ -6500,7 +6551,7 @@ comment at the start of cc-engine.el for more info."
;; characters.) If the raw string is not terminated, E\) and E\" are set to
;; nil.
;;
- ;; Note: this routine is dependant upon the correct syntax-table text
+ ;; Note: this function is dependant upon the correct syntax-table text
;; properties being set.
(let ((state (c-state-semi-pp-to-literal (point)))
open-quote-pos open-paren-pos close-paren-pos close-quote-pos id)
@@ -6513,8 +6564,20 @@ comment at the start of cc-engine.el for more info."
(search-backward "\"" (max (- (point) 17) (point-min)) t)))
((and (eq (cadr state) 'string)
(goto-char (nth 2 state))
- (or (eq (char-after) ?\")
- (search-backward "\"" (max (- (point) 17) (point-min)) t))
+ (cond
+ ((eq (char-after) ?\"))
+ ((eq (char-after) ?\()
+ (let ((here (point)))
+ (goto-char (max (- (point) 18) (point-min)))
+ (while
+ (and
+ (search-forward-regexp
+ "R\"\\([^ ()\\\n\r\t]\\{0,16\\}\\)("
+ (1+ here) 'limit)
+ (< (point) here)))
+ (and (eq (point) (1+ here))
+ (match-beginning 1)
+ (goto-char (1- (match-beginning 1)))))))
(not (bobp)))))
(eq (char-before) ?R)
(looking-at "\"\\([^ ()\\\n\r\t]\\{0,16\\}\\)("))
@@ -6537,6 +6600,21 @@ comment at the start of cc-engine.el for more info."
(t nil))
open-quote-pos open-paren-pos close-paren-pos close-quote-pos))))
+(defun c-raw-string-in-end-delim (beg end)
+ ;; If the region (BEG END) intersects a possible raw string terminator,
+ ;; return a cons of the position of the ) and the position of the " in the
+ ;; first one found.
+ (save-excursion
+ (goto-char (max (- beg 17) (point-min)))
+ (while
+ (and
+ (search-forward-regexp ")\\([^ ()\\\n\r\t]\\{0,16\\}\\)\""
+ (min (+ end 17) (point-max)) t)
+ (<= (point) beg)))
+ (unless (or (<= (point) beg)
+ (>= (match-beginning 0) end))
+ (cons (match-beginning 0) (match-end 1)))))
+
(defun c-depropertize-raw-string (id open-quote open-paren bound)
;; Point is immediately after a raw string opening delimiter. Remove any
;; `syntax-table' text properties associated with the delimiter (if it's
@@ -6545,29 +6623,55 @@ comment at the start of cc-engine.el for more info."
;; ID, a string, is the delimiter's identifier. OPEN-QUOTE and OPEN-PAREN
;; are the buffer positions of the delimiter's components. BOUND is the
;; bound for searching for a matching closing delimiter; it is usually nil,
- ;; but if we're inside a macro, it's the end of the macro.
+ ;; but if we're inside a macro, it's the end of the macro (i.e. just before
+ ;; the terminating \n).
;;
;; Point is moved to after the (terminated) raw string, or left after the
;; unmatched opening delimiter, as the case may be. The return value is of
;; no significance.
- (let ((open-paren-prop (c-get-char-property open-paren 'syntax-table)))
+ (let ((open-paren-prop (c-get-char-property open-paren 'syntax-table))
+ first)
+ ;; If the delimiter is "unclosed", or sombody's used " in their id, clear
+ ;; the 'syntax-table property from all of them.
+ (setq first (c-clear-char-property-with-value-on-char
+ open-quote open-paren 'syntax-table '(1) ?\"))
+ (if first (c-truncate-semi-nonlit-pos-cache first))
(cond
((null open-paren-prop)
- ;; A terminated raw string
+ ;; Should be a terminated raw string...
(when (search-forward (concat ")" id "\"") nil t)
+ ;; Yes, it is. :-)
+ ;; Clear any '(1)s from "s in the identifier.
+ (setq first (c-clear-char-property-with-value-on-char
+ (1+ (match-beginning 0)) (1- (match-end 0))
+ 'syntax-table '(1) ?\"))
+ (if first (c-truncate-semi-nonlit-pos-cache first))
+ ;; Clear any random `syntax-table' text properties from the contents.
(let* ((closing-paren (match-beginning 0))
- (first-punctuation
- (save-match-data
- (goto-char (1+ open-paren))
- (and (c-search-forward-char-property 'syntax-table '(1)
- closing-paren)
- (1- (point)))))
- )
- (when first-punctuation
- (c-clear-char-property-with-value
- first-punctuation (match-beginning 0) 'syntax-table '(1))
- (c-truncate-semi-nonlit-pos-cache first-punctuation)
- ))))
+ (first-st
+ (and
+ (< (1+ open-paren) closing-paren)
+ (or
+ (and (c-get-char-property (1+ open-paren) 'syntax-table)
+ (1+ open-paren))
+ (and
+ (setq first
+ (c-next-single-property-change
+ (1+ open-paren) 'syntax-table nil closing-paren))
+ (< first closing-paren)
+ first)))))
+ (when first-st
+ (c-clear-char-properties first-st (match-beginning 0)
+ 'syntax-table)
+ (c-truncate-semi-nonlit-pos-cache first-st))
+ (when (c-get-char-property (1- (match-end 0)) 'syntax-table)
+ ;; Was previously an unterminated (ordinary) string
+ (save-excursion
+ (goto-char (1- (match-end 0)))
+ (when (c-safe (c-forward-sexp)) ; to '(1) at EOL.
+ (c-clear-char-property (1- (point)) 'syntax-table))
+ (c-clear-char-property (1- (match-end 0)) 'syntax-table)
+ (c-truncate-semi-nonlit-pos-cache (1- (match-end 0))))))))
((or (and (equal open-paren-prop '(15)) (null bound))
(equal open-paren-prop '(1)))
;; An unterminated raw string either not in a macro, or in a macro with
@@ -6581,13 +6685,8 @@ comment at the start of cc-engine.el for more info."
(c-clear-char-property open-quote 'syntax-table)
(c-truncate-semi-nonlit-pos-cache open-quote)
(c-clear-char-property open-paren 'syntax-table)
- (let ((after-string-fence-pos
- (save-excursion
- (goto-char (1+ open-paren))
- (c-search-forward-char-property 'syntax-table '(15) bound))))
- (when after-string-fence-pos
- (c-clear-char-property (1- after-string-fence-pos) 'syntax-table)))
- ))))
+ (c-clear-char-property-with-value (1+ open-paren) bound 'syntax-table
+ '(15))))))
(defun c-depropertize-raw-strings-in-region (start finish)
;; Remove any `syntax-table' text properties associated with C++ raw strings
@@ -6627,37 +6726,89 @@ comment at the start of cc-engine.el for more info."
(defun c-before-change-check-raw-strings (beg end)
;; This function clears `syntax-table' text properties from C++ raw strings
- ;; in the region (c-new-BEG c-new-END). BEG and END are the standard
- ;; arguments supplied to any before-change function.
+ ;; whose delimiters are about to change in the region (c-new-BEG c-new-END).
+ ;; BEG and END are the standard arguments supplied to any before-change
+ ;; function.
;;
;; Point is undefined on both entry and exit, and the return value has no
;; significance.
;;
;; This function is called as a before-change function solely due to its
;; membership of the C++ value of `c-get-state-before-change-functions'.
+ (goto-char end)
+ ;; We use the following to detect a R"<id>( being swallowed into a string by
+ ;; the pending change.
+ (setq c-old-END-literality (c-in-literal))
(c-save-buffer-state
- ((beg-rs (progn (goto-char beg) (c-raw-string-pos)))
- (beg-plus (if (null beg-rs)
- beg
- (max beg
- (1+ (or (nth 4 beg-rs) (nth 2 beg-rs))))))
- (end-rs (progn (goto-char end) (c-raw-string-pos))) ; FIXME!!!
+ (;; (beg-rs (progn (goto-char beg) (c-raw-string-pos)))
+ ;; (end-rs (progn (goto-char end) (c-raw-string-pos)))
+ ; FIXME!!!
; Optimize this so that we don't call
; `c-raw-string-pos' twice when once
; will do. (2016-06-02).
- (end-minus (if (null end-rs)
- end
- (min end (cadr end-rs))))
- )
- (when beg-rs
- (setq c-new-BEG (min c-new-BEG (1- (cadr beg-rs)))))
- (c-depropertize-raw-strings-in-region c-new-BEG beg-plus)
-
- (when end-rs
- (setq c-new-END (max c-new-END
- (1+ (or (nth 4 end-rs)
- (nth 2 end-rs))))))
- (c-depropertize-raw-strings-in-region end-minus c-new-END)))
+ (term-del (c-raw-string-in-end-delim beg end))
+ Rquote close-quote)
+ (setq c-old-beg-rs (progn (goto-char beg) (c-raw-string-pos))
+ c-old-end-rs (progn (goto-char end) (c-raw-string-pos)))
+ (cond
+ ;; We're not changing, or we're obliterating raw strings.
+ ((and (null c-old-beg-rs) (null c-old-end-rs)))
+ ;; We're changing the putative terminating delimiter of a raw string
+ ;; containing BEG.
+ ((and c-old-beg-rs term-del
+ (or (null (nth 3 c-old-beg-rs))
+ (<= (car term-del) (nth 3 c-old-beg-rs))))
+ (setq Rquote (1- (cadr c-old-beg-rs))
+ close-quote (1+ (cdr term-del)))
+ (c-depropertize-raw-strings-in-region Rquote close-quote)
+ (setq c-new-BEG (min c-new-BEG Rquote)
+ c-new-END (max c-new-END close-quote)))
+ ;; We're breaking an escaped NL in a raw string in a macro.
+ ((and c-old-end-rs
+ (< beg end)
+ (goto-char end) (eq (char-before) ?\\)
+ (c-beginning-of-macro))
+ (let ((bom (point))
+ (eom (progn (c-end-of-macro) (point))))
+ (c-depropertize-raw-strings-in-region bom eom)
+ (setq c-new-BEG (min c-new-BEG bom)
+ c-new-END (max c-new-END eom))))
+ ;; We're changing only the contents of a raw string.
+ ((and (equal (cdr c-old-beg-rs) (cdr c-old-end-rs))
+ (null (car c-old-beg-rs)) (null (car c-old-end-rs))))
+ ((or
+ ;; We're removing (at least part of) the R" of the starting delim of a
+ ;; raw string:
+ (null c-old-beg-rs)
+ (and (eq beg (cadr c-old-beg-rs))
+ (< beg end))
+ ;; Or we're removing the ( of the starting delim of a raw string.
+ (and (eq (car c-old-beg-rs) 'open-delim)
+ (or (null c-old-end-rs)
+ (not (eq (car c-old-end-rs) 'open-delim))
+ (not (equal (cdr c-old-beg-rs) (cdr c-old-end-rs))))))
+ (let ((close (nth 4 (or c-old-end-rs c-old-beg-rs))))
+ (setq Rquote (1- (cadr (or c-old-end-rs c-old-beg-rs)))
+ close-quote (if close (1+ close) (point-max))))
+ (c-depropertize-raw-strings-in-region Rquote close-quote)
+ (setq c-new-BEG (min c-new-BEG Rquote)
+ c-new-END (max c-new-END close-quote)))
+ ;; We're changing only the text of the identifier of the opening
+ ;; delimiter of a raw string.
+ ((and (eq (car c-old-beg-rs) 'open-delim)
+ (equal c-old-beg-rs c-old-end-rs))))))
+
+(defun c-propertize-raw-string-id (start end)
+ ;; If the raw string identifier between buffer positions START and END
+ ;; contains any double quote characters, put a punctuation syntax-table text
+ ;; property on them. The return value is of no significance.
+ (save-excursion
+ (goto-char start)
+ (while (and (skip-chars-forward "^\"" end)
+ (< (point) end))
+ (c-put-char-property (point) 'syntax-table '(1))
+ (c-truncate-semi-nonlit-pos-cache (point))
+ (forward-char))))
(defun c-propertize-raw-string-opener (id open-quote open-paren bound)
;; Point is immediately after a raw string opening delimiter. Apply any
@@ -6667,117 +6818,264 @@ comment at the start of cc-engine.el for more info."
;; ID, a string, is the delimiter's identifier. OPEN-QUOTE and OPEN-PAREN
;; are the buffer positions of the delimiter's components. BOUND is the
;; bound for searching for a matching closing delimiter; it is usually nil,
- ;; but if we're inside a macro, it's the end of the macro.
- ;;
- ;; Point is moved to after the (terminated) raw string, or left after the
- ;; unmatched opening delimiter, as the case may be. The return value is of
- ;; no significance.
- (if (search-forward (concat ")" id "\"") bound t)
- (let ((end-string (match-beginning 0))
- (after-quote (match-end 0)))
- (goto-char open-paren)
- (while (progn (skip-syntax-forward "^\"" end-string)
- (< (point) end-string))
- (c-put-char-property (point) 'syntax-table '(1)) ; punctuation
- (c-truncate-semi-nonlit-pos-cache (point))
- (forward-char))
- (goto-char after-quote))
- (c-put-char-property open-quote 'syntax-table '(1)) ; punctuation
- (c-truncate-semi-nonlit-pos-cache open-quote)
- (c-put-char-property open-paren 'syntax-table '(15)) ; generic string
- (when bound
- ;; In a CPP construct, we try to apply a generic-string `syntax-table'
- ;; text property to the last possible character in the string, so that
- ;; only characters within the macro get "stringed out".
- (goto-char bound)
- (if (save-restriction
- (narrow-to-region (1+ open-paren) (point-max))
- (re-search-backward
- (eval-when-compile
- ;; This regular expression matches either an escape pair (which
- ;; isn't an escaped NL) (submatch 5) or a non-escaped character
- ;; (which isn't itself a backslash) (submatch 10). The long
- ;; preambles to these (respectively submatches 2-4 and 6-9)
- ;; ensure that we have the correct parity for sequences of
- ;; backslashes, etc..
- (concat "\\(" ; 1
- "\\(\\`[^\\]?\\|[^\\][^\\]\\)\\(\\\\\\(.\\|\n\\)\\)*" ; 2-4
- "\\(\\\\.\\)" ; 5
- "\\|"
- "\\(\\`\\|[^\\]\\|\\(\\`[^\\]?\\|[^\\][^\\]\\)\\(\\\\\\(.\\|\n\\)\\)+\\)" ; 6-9
- "\\([^\\]\\)" ; 10
- "\\)"
- "\\(\\\\\n\\)*\\=")) ; 11
- (1+ open-paren) t))
- (if (match-beginning 10)
- (progn
- (c-put-char-property (match-beginning 10) 'syntax-table '(15))
- (c-truncate-semi-nonlit-pos-cache (match-beginning 10)))
- (c-put-char-property (match-beginning 5) 'syntax-table '(1))
- (c-put-char-property (1+ (match-beginning 5)) 'syntax-table '(15))
- (c-truncate-semi-nonlit-pos-cache (1+ (match-beginning 5))))
- (c-put-char-property open-paren 'syntax-table '(1)))
- (goto-char bound))))
-
-(defun c-after-change-re-mark-raw-strings (_beg _end _old-len)
- ;; This function applies `syntax-table' text properties to C++ raw strings
- ;; beginning in the region (c-new-BEG c-new-END). BEG, END, and OLD-LEN are
- ;; the standard arguments supplied to any after-change function.
+ ;; but if we're inside a macro, it's the end of the macro (i.e. the position
+ ;; of the closing newline).
+ ;;
+ ;; Point is moved to after the (terminated) raw string and t is returned, or
+ ;; it is left after the unmatched opening delimiter and nil is returned.
+ (c-propertize-raw-string-id (1+ open-quote) open-paren)
+ (prog1
+ (if (search-forward (concat ")" id "\"") bound t)
+ (let ((end-string (match-beginning 0))
+ (after-quote (match-end 0)))
+ (c-propertize-raw-string-id
+ (1+ (match-beginning 0)) (1- (match-end 0)))
+ (goto-char open-paren)
+ (while (progn (skip-syntax-forward "^\"" end-string)
+ (< (point) end-string))
+ (c-put-char-property (point) 'syntax-table '(1)) ; punctuation
+ (c-truncate-semi-nonlit-pos-cache (point))
+ (forward-char))
+ (goto-char after-quote)
+ t)
+ (c-put-char-property open-quote 'syntax-table '(1)) ; punctuation
+ (c-truncate-semi-nonlit-pos-cache open-quote)
+ (c-put-char-property open-paren 'syntax-table '(15)) ; generic string
+ (when bound
+ ;; In a CPP construct, we try to apply a generic-string
+ ;; `syntax-table' text property to the last possible character in
+ ;; the string, so that only characters within the macro get
+ ;; "stringed out".
+ (goto-char bound)
+ (if (save-restriction
+ (narrow-to-region (1+ open-paren) (point-max))
+ (re-search-backward
+ (eval-when-compile
+ ;; This regular expression matches either an escape pair
+ ;; (which isn't an escaped NL) (submatch 5) or a
+ ;; non-escaped character (which isn't itself a backslash)
+ ;; (submatch 10). The long preambles to these
+ ;; (respectively submatches 2-4 and 6-9) ensure that we
+ ;; have the correct parity for sequences of backslashes,
+ ;; etc..
+ (concat "\\(" ; 1
+ "\\(\\`[^\\]?\\|[^\\][^\\]\\)\\(\\\\\\(.\\|\n\\)\\)*" ; 2-4
+ "\\(\\\\.\\)" ; 5
+ "\\|"
+ "\\(\\`\\|[^\\]\\|\\(\\`[^\\]?\\|[^\\][^\\]\\)\\(\\\\\\(.\\|\n\\)\\)+\\)" ; 6-9
+ "\\([^\\]\\)" ; 10
+ "\\)"
+ "\\(\\\\\n\\)*\\=")) ; 11
+ (1+ open-paren) t))
+ (if (match-beginning 10)
+ (progn
+ (c-put-char-property (match-beginning 10) 'syntax-table '(15))
+ (c-truncate-semi-nonlit-pos-cache (match-beginning 10)))
+ (c-put-char-property (match-beginning 5) 'syntax-table '(1))
+ (c-put-char-property (1+ (match-beginning 5)) 'syntax-table '(15))
+ (c-truncate-semi-nonlit-pos-cache (1+ (match-beginning 5))))
+ ;; (c-put-char-property open-paren 'syntax-table '(1))
+ )
+ (goto-char bound))
+ nil)
+ ;; Ensure the opening delimiter will get refontified.
+ (c-font-lock-flush (1- open-quote) (1+ open-paren))))
+
+(defun c-after-change-unmark-raw-strings (beg end _old-len)
+ ;; This function removes `syntax-table' text properties from any raw strings
+ ;; which have been affected by the current change. These are those which
+ ;; have been "stringed out" and from newly formed raw strings, or any
+ ;; existing raw string which the new text terminates. BEG, END, and
+ ;; _OLD-LEN are the standard arguments supplied to any
+ ;; after-change-function.
;;
;; Point is undefined on both entry and exit, and the return value has no
;; significance.
;;
- ;; This function is called as an after-change function solely due to its
+ ;; This functions is called as an after-change function by virtue of its
;; membership of the C++ value of `c-before-font-lock-functions'.
- (c-save-buffer-state ()
- ;; If the region (c-new-BEG c-new-END) has expanded, remove
- ;; `syntax-table' text-properties from the new piece(s).
- (when (< c-new-BEG c-old-BEG)
- (let ((beg-rs (progn (goto-char c-old-BEG) (c-raw-string-pos))))
- (c-depropertize-raw-strings-in-region
- c-new-BEG
- (if beg-rs
- (1+ (or (nth 4 beg-rs) (nth 2 beg-rs)))
- c-old-BEG))))
- (when (> c-new-END c-old-END)
- (let ((end-rs (progn (goto-char c-old-END) (c-raw-string-pos))))
- (c-depropertize-raw-strings-in-region
- (if end-rs
- (cadr end-rs)
- c-old-END)
- c-new-END)))
+ ;; (when (< beg end)
+ (c-save-buffer-state (found eoll state id found-beg found-end)
+ ;; Has an inserted " swallowed up a R"(, turning it into "...R"(?
+ (goto-char end)
+ (setq eoll (c-point 'eoll))
+ (when (and (null c-old-END-literality)
+ (search-forward-regexp "R\"\\([^ ()\\\n\r\t]\\{0,16\\}\\)("
+ eoll t))
+ (setq state (c-state-semi-pp-to-literal end))
+ (when (eq (cadr state) 'string)
+ (unwind-protect
+ ;; Temporarily insert a closing string delimiter....
+ (progn
+ (goto-char end)
+ (cond
+ ((c-characterp (nth 3 (car state)))
+ (insert (nth 3 (car state))))
+ ((eq (nth 3 (car state)) t)
+ (insert ?\")
+ (c-put-char-property end 'syntax-table '(15))))
+ (c-truncate-semi-nonlit-pos-cache end)
+ ;; ....ensure c-new-END extends right to the end of the about
+ ;; to be un-stringed raw string....
+ (save-excursion
+ (goto-char (match-beginning 1))
+ (let ((end-bs (c-raw-string-pos)))
+ (setq c-new-END
+ (max c-new-END
+ (if (nth 4 end-bs)
+ (1+ (nth 4 end-bs))
+ eoll)))))
+
+ ;; ...and clear `syntax-table' text propertes from the
+ ;; following raw strings.
+ (c-depropertize-raw-strings-in-region (point) (1+ eoll)))
+ ;; Remove the temporary string delimiter.
+ (goto-char end)
+ (delete-char 1))))
+
+ ;; Have we just created a new starting id?
+ (goto-char (max (- beg 18) (point-min)))
+ (while
+ (and
+ (setq found
+ (search-forward-regexp "R\"\\([^ ()\\\n\r\t]\\{0,16\\}\\)("
+ c-new-END 'bound))
+ (<= (match-end 0) beg)))
+ (when (and found (<= (match-beginning 0) end))
+ (setq c-new-BEG (min c-new-BEG (match-beginning 0)))
+ (c-depropertize-raw-strings-in-region c-new-BEG c-new-END))
+
+ ;; Have we invalidated an opening delimiter by typing into it?
+ (when (and c-old-beg-rs
+ (eq (car c-old-beg-rs) 'open-delim)
+ (equal (c-get-char-property (cadr c-old-beg-rs)
+ 'syntax-table)
+ '(1)))
+ (goto-char (1- (cadr c-old-beg-rs)))
+ (unless (looking-at "R\"[^ ()\\\n\r\t]\\{0,16\\}(")
+ (c-clear-char-property (1+ (point)) 'syntax-table)
+ (c-truncate-semi-nonlit-pos-cache (1+ (point)))
+ (if (c-search-forward-char-property 'syntax-table '(15)
+ (c-point 'eol))
+ (c-clear-char-property (1- (point)) 'syntax-table))))
+
+ ;; Have we terminated an existing raw string by inserting or removing
+ ;; text?
+ (when (eq c-old-END-literality 'string)
+ (setq state (c-state-semi-pp-to-literal beg))
+ (cond
+ ;; Possibly terminating a(n un)terminated raw string.
+ ((eq (nth 3 (car state)) t)
+ (goto-char (nth 8 (car state)))
+ (when
+ (and (eq (char-after) ?\()
+ (search-backward-regexp
+ "R\"\\([^ ()\\\n\r\t]\\{0,16\\}\\)\\=" (- (point) 18) t))
+ (setq id (match-string-no-properties 1)
+ found-beg (match-beginning 0)
+ found-end (1+ (match-end 0)))))
+ ;; Possibly terminating an already terminated raw string.
+ ((eq (nth 3 (car state)) ?\")
+ (goto-char (nth 8 (car state)))
+ (when
+ (and (eq (char-before) ?R)
+ (looking-at "\"\\([^ ()\\\n\r\t]\\{0,16\\}\\)("))
+ (setq id (match-string-no-properties 1)
+ found-beg (1- (point))
+ found-end (match-end 0)))))
+ (when id
+ (goto-char (max (- beg 18) (point-min)))
+ (when (search-forward (concat ")" id "\"") (+ end 1 (length id)) t)
+ ;; Has an earlier close delimiter just been inserted into an
+ ;; already terminated raw string?
+ (if (and (eq (nth 3 (car state)) ?\")
+ (search-forward (concat ")" id "\"") nil t))
+ (setq found-end (point)))
+ (setq c-new-BEG (min c-new-BEG found-beg)
+ c-new-END (max c-new-END found-end))
+ (c-clear-char-properties found-beg found-end 'syntax-table)
+ (c-truncate-semi-nonlit-pos-cache found-beg))))
+
+ ;; Are there any raw strings in a newly created macro?
+ (when (< beg end)
+ (goto-char beg)
+ (setq found-beg (point))
+ (when (search-forward-regexp c-anchored-cpp-prefix end t)
+ (c-end-of-macro)
+ (c-depropertize-raw-strings-in-region found-beg (point))))))
- (goto-char c-new-BEG)
- (while (and (< (point) c-new-END)
- (re-search-forward
- (concat "\\(" ; 1
- c-anchored-cpp-prefix ; 2
- "\\)\\|\\(" ; 3
- "R\"\\([^ ()\\\n\r\t]\\{0,16\\}\\)(" ; 4
- "\\)")
- c-new-END t))
- (when (save-excursion
- (goto-char (match-beginning 0)) (not (c-in-literal)))
- (if (match-beginning 4) ; the id
- ;; We've found a raw string.
+(defun c-maybe-re-mark-raw-string ()
+ ;; When this function is called, point is immediately after a ". If this "
+ ;; is the characteristic " of of a raw string delimiter, apply the pertinent
+ ;; `syntax-table' text properties to the entire raw string (when properly
+ ;; terminated) or just the delimiter (otherwise).
+ ;;
+ ;; If the " is in any way part of a raw string, return non-nil. Otherwise
+ ;; return nil.
+ (let ((here (point))
+ in-macro macro-end id Rquote found)
+ (cond
+ ((and
+ (eq (char-before (1- (point))) ?R)
+ (looking-at "\\([^ ()\\\n\r\t]\\{0,16\\}\\)("))
+ (save-excursion
+ (setq in-macro (c-beginning-of-macro))
+ (setq macro-end (when in-macro
+ (c-end-of-macro)
+ (point) ;; (min (1+ (point)) (point-max))
+ )))
+ (if (not
+ (c-propertize-raw-string-opener
+ (match-string-no-properties 1) ; id
+ (1- (point)) ; open quote
+ (match-end 1) ; open paren
+ macro-end)) ; bound (end of macro) or nil.
+ (goto-char (or macro-end (point-max))))
+ t)
+ ((save-excursion
+ (and
+ (search-backward-regexp ")\\([^ ()\\\n\r\t]\\{0,16\\}\\)\"\\=" nil t)
+ (setq id (match-string-no-properties 1))
+ (let* ((quoted-id (regexp-quote id))
+ (quoted-id-depth (regexp-opt-depth quoted-id)))
+ (while
+ (and
+ ;; Search back for an opening delimiter with identifier `id'.
+ ;; A closing delimiter with `id' "blocks" our search.
+ (search-backward-regexp ; This could be slow.
+ (concat "\\(R\"" quoted-id "(\\)"
+ "\\|"
+ "\\()" quoted-id "\"\\)")
+ nil t)
+ (setq found t)
+ (if (eq (c-in-literal) 'string)
+ (match-beginning 1)
+ (match-beginning (+ 2 quoted-id-depth)))))
+ (and found
+ (null (c-in-literal))
+ (match-beginning 1)))
+ (setq Rquote (point))))
+ (save-excursion
+ (goto-char Rquote)
+ (setq in-macro (c-beginning-of-macro))
+ (setq macro-end (when in-macro
+ (c-end-of-macro)
+ (point))))
+ (if (or (not in-macro)
+ (<= here macro-end))
+ (progn
(c-propertize-raw-string-opener
- (match-string-no-properties 4) ; id
- (1+ (match-beginning 3)) ; open quote
- (match-end 4) ; open paren
- nil) ; bound
- ;; We've found a CPP construct. Search for raw strings within it.
- (goto-char (match-beginning 2)) ; the "#"
- (c-end-of-macro)
- (let ((eom (point)))
- (goto-char (match-end 2)) ; after the "#".
- (while (and (< (point) eom)
- (c-syntactic-re-search-forward
- "R\"\\([^ ()\\\n\r\t]\\{0,16\\}\\)(" eom t))
- (c-propertize-raw-string-opener
- (match-string-no-properties 1) ; id
- (1+ (match-beginning 0)) ; open quote
- (match-end 1) ; open paren
- eom)))))))) ; bound
+ id (1+ (point)) (match-end 1) macro-end)
+ (goto-char here)
+ t)
+ (goto-char here)
+ nil))
+
+ (t
+ ;; If the " is in another part of a raw string (whether as part of the
+ ;; identifier, or in the string itself) the `syntax-table' text
+ ;; properties on the raw string will be current. So, we can use...
+ (c-raw-string-pos)))))
;; Handling of small scale constructs like types and names.
@@ -6890,8 +7188,8 @@ comment at the start of cc-engine.el for more info."
`(let (res)
(setq c-last-identifier-range nil)
(while (if (setq res ,(if (eq type 'type)
- `(c-forward-type)
- `(c-forward-name)))
+ '(c-forward-type)
+ '(c-forward-name)))
nil
(cond ((looking-at c-keywords-regexp)
(c-forward-keyword-clause 1))
@@ -6901,8 +7199,8 @@ comment at the start of cc-engine.el for more info."
(when (memq res '(t known found prefix maybe))
(when c-record-type-identifiers
,(if (eq type 'type)
- `(c-record-type-id c-last-identifier-range)
- `(c-record-ref-id c-last-identifier-range)))
+ '(c-record-type-id c-last-identifier-range)
+ '(c-record-ref-id c-last-identifier-range)))
t)))
(defmacro c-forward-id-comma-list (type update-safe-pos)
@@ -6913,7 +7211,7 @@ comment at the start of cc-engine.el for more info."
;; This macro might do hidden buffer changes.
`(while (and (progn
,(when update-safe-pos
- `(setq safe-pos (point)))
+ '(setq safe-pos (point)))
(eq (char-after) ?,))
(progn
(forward-char)
@@ -7138,7 +7436,7 @@ comment at the start of cc-engine.el for more info."
(progn
(c-forward-syntactic-ws)
(when (or (and c-record-type-identifiers all-types)
- (not (equal c-inside-<>-type-key "\\(\\<\\>\\)")))
+ (not (equal c-inside-<>-type-key "\\(a\\`\\)")))
(c-forward-syntactic-ws)
(cond
((eq (char-after) ??)
@@ -7688,7 +7986,7 @@ comment at the start of cc-engine.el for more info."
(c-record-type-id id-range))
(unless res
(setq res 'found)))
- (setq res (if (c-check-type id-start id-end)
+ (setq res (if (c-check-qualified-type id-start)
;; It's an identifier that has been used as
;; a type somewhere else.
'found
@@ -7700,7 +7998,7 @@ comment at the start of cc-engine.el for more info."
(c-forward-syntactic-ws)
(setq res
(if (eq (char-after) ?\()
- (if (c-check-type id-start id-end)
+ (if (c-check-qualified-type id-start)
;; It's an identifier that has been used as
;; a type somewhere else.
'found
@@ -7825,6 +8123,37 @@ comment at the start of cc-engine.el for more info."
(prog1 (car ,ps)
(setq ,ps (cdr ,ps)))))
+(defun c-forward-over-compound-identifier ()
+ ;; Go over a possibly compound identifier, such as C++'s Foo::Bar::Baz,
+ ;; returning that identifier (with any syntactic WS removed). Return nil if
+ ;; we're not at an identifier.
+ (when (c-on-identifier)
+ (let ((consolidated "") (consolidated-:: "")
+ start end)
+ (while
+ (progn
+ (setq start (point))
+ (c-forward-over-token)
+ (setq consolidated
+ (concat consolidated-::
+ (buffer-substring-no-properties start (point))))
+ (c-forward-syntactic-ws)
+ (and c-opt-identifier-concat-key
+ (looking-at c-opt-identifier-concat-key)
+ (progn
+ (setq start (point))
+ (c-forward-over-token)
+ (setq end (point))
+ (c-forward-syntactic-ws)
+ (and
+ (c-on-identifier)
+ (setq consolidated-::
+ (concat consolidated
+ (buffer-substring-no-properties start end))))))))
+ (if (equal consolidated "")
+ nil
+ consolidated))))
+
(defun c-back-over-compound-identifier ()
;; Point is putatively just after a "compound identifier", i.e. something
;; looking (in C++) like this "FQN::of::base::Class". Move to the start of
@@ -7849,6 +8178,21 @@ comment at the start of cc-engine.el for more info."
(goto-char end)
t)))
+(defun c-check-qualified-type (from)
+ ;; Look up successive tails of a (possibly) qualified type in
+ ;; `c-found-types'. If one of them matches, return it, else return nil.
+ (save-excursion
+ (goto-char from)
+ (let ((compound (c-forward-over-compound-identifier)))
+ (when compound
+ (while (and c-opt-identifier-concat-key
+ (> (length compound) 0)
+ (not (gethash compound c-found-types))
+ (string-match c-opt-identifier-concat-key compound))
+ (setq compound (substring compound (match-end 0))))
+ (and (gethash compound c-found-types)
+ compound)))))
+
(defun c-back-over-member-initializer-braces ()
;; Point is just after a closing brace/parenthesis. Try to parse this as a
;; C++ member initializer list, going back to just after the introducing ":"
@@ -7888,7 +8232,7 @@ comment at the start of cc-engine.el for more info."
;; a comma. If either of <symbol> or bracketed <expression> is missing,
;; throw nil to 'level. If the terminating } or ) is unmatched, throw nil
;; to 'done. This is not a general purpose macro!
- `(while (eq (char-before) ?,)
+ '(while (eq (char-before) ?,)
(backward-char)
(c-backward-syntactic-ws)
(when (not (memq (char-before) '(?\) ?})))
@@ -7952,49 +8296,28 @@ comment at the start of cc-engine.el for more info."
(or res (goto-char here))
res))
+(defun c-forward-class-decl ()
+ "From the beginning of a struct/union, etc. move forward to
+after the brace block which defines it, leaving point at the
+start of the next token and returning point. On failure leave
+point unchanged and return nil."
+ (let ((here (point)))
+ (if
+ (and
+ (looking-at c-class-key)
+ (eq (c-forward-token-2) 0)
+ (c-on-identifier)
+ (eq (c-forward-token-2) 0)
+ (eq (char-after) ?{)
+ (c-go-list-forward))
+ (progn
+ (c-forward-syntactic-ws)
+ (point))
+ (goto-char here)
+ nil)))
;; Handling of large scale constructs like statements and declarations.
-;; Macro used inside `c-forward-decl-or-cast-1'. It ought to be a
-;; defsubst or perhaps even a defun, but it contains lots of free
-;; variables that refer to things inside `c-forward-decl-or-cast-1'.
-(defmacro c-fdoc-shift-type-backward (&optional short)
- ;; `c-forward-decl-or-cast-1' can consume an arbitrary length list
- ;; of types when parsing a declaration, which means that it
- ;; sometimes consumes the identifier in the declaration as a type.
- ;; This is used to "backtrack" and make the last type be treated as
- ;; an identifier instead.
- `(progn
- ,(unless short
- ;; These identifiers are bound only in the inner let.
- '(setq identifier-type at-type
- identifier-start type-start
- got-parens nil
- got-identifier t
- got-suffix t
- got-suffix-after-parens id-start
- paren-depth 0))
-
- (if (setq at-type (if (eq backup-at-type 'prefix)
- t
- backup-at-type))
- (setq type-start backup-type-start
- id-start backup-id-start)
- (setq type-start start-pos
- id-start start-pos))
-
- ;; When these flags already are set we've found specifiers that
- ;; unconditionally signal these attributes - backtracking doesn't
- ;; change that. So keep them set in that case.
- (or at-type-decl
- (setq at-type-decl backup-at-type-decl))
- (or maybe-typeless
- (setq maybe-typeless backup-maybe-typeless))
-
- ,(unless short
- ;; This identifier is bound only in the inner let.
- '(setq start id-start))))
-
(defun c-forward-declarator (&optional limit accept-anon)
;; Assuming point is at the start of a declarator, move forward over it,
;; leaving point at the next token after it (e.g. a ) or a ; or a ,).
@@ -8147,6 +8470,176 @@ comment at the start of cc-engine.el for more info."
(goto-char here)
nil)))
+(defun c-do-declarators
+ (cdd-limit cdd-list cdd-not-top cdd-comma-prop cdd-function)
+ "Assuming point is at the start of a comma separated list of declarators,
+apply CDD-FUNCTION to each declarator (when CDD-LIST is non-nil) or just the
+first declarator (when CDD-LIST is nil). When CDD-FUNCTION is nil, no
+function is applied.
+
+CDD-FUNCTION is supplied with 6 arguments:
+0. The start position of the declarator's identifier;
+1. The end position of this identifier;
+\[Note: if there is no identifier, as in int (*);, both of these are nil.]
+2. The position of the next token after the declarator (CLARIFY!!!).
+3. CDD-NOT-TOP;
+4. Non-nil if the identifier is of a function.
+5. When there is an initialization following the declarator (such as \"=
+....\" or \"( ....\".), the character which introduces this initialization,
+otherwise nil.
+
+Additionally, if CDD-COMMA-PROP is non-nil, mark the separating commas with
+this value of the c-type property, when CDD-LIST is non-nil.
+
+Stop at or before CDD-LIMIT (which may NOT be nil).
+
+If CDD-NOT-TOP is non-nil, we are not at the top-level (\"top-level\" includes
+being directly inside a class or namespace, etc.).
+
+Return non-nil if we've reached the token after the last declarator (often a
+semicolon, or a comma when CDD-LIST is nil); otherwise (when we hit CDD-LIMIT,
+or fail otherwise) return nil, leaving point at the beginning of the putative
+declarator that could not be processed.
+
+This function might do hidden buffer changes."
+ ;; N.B.: We use the "cdd-" prefix in this routine to try to prevent
+ ;; confusion with possible reference to common variable names from within
+ ;; CDD-FUNCTION.
+ (let
+ ((cdd-pos (point)) cdd-next-pos cdd-id-start cdd-id-end
+ cdd-decl-res cdd-got-func cdd-got-type cdd-got-init
+ c-last-identifier-range cdd-exhausted)
+
+ ;; The following `while' applies `cdd-function' to a single declarator id
+ ;; each time round. It loops only when CDD-LIST is non-nil.
+ (while
+ (and (not cdd-exhausted)
+ (setq cdd-decl-res (c-forward-declarator cdd-limit)))
+ (setq cdd-next-pos (point)
+ cdd-id-start (car cdd-decl-res)
+ cdd-id-end (cadr cdd-decl-res)
+ cdd-got-func (and (eq (char-after) ?\()
+ (or (not (c-major-mode-is 'c++-mode))
+ (not cdd-not-top)
+ (car (cddr (cddr cdd-decl-res))) ; Id is in
+ ; parens, etc.
+ (save-excursion
+ (forward-char)
+ (c-forward-syntactic-ws)
+ (looking-at "[*&]")))
+ (not (car (cddr cdd-decl-res)))
+ (or (not (c-major-mode-is 'c++-mode))
+ (save-excursion
+ (let (c-last-identifier-range)
+ (forward-char)
+ (c-forward-syntactic-ws)
+ (catch 'is-function
+ (while
+ (progn
+ (if (eq (char-after) ?\))
+ (throw 'is-function t))
+ (setq cdd-got-type (c-forward-type))
+ (cond
+ ((null cdd-got-type)
+ (throw 'is-function nil))
+ ((not (eq cdd-got-type 'maybe))
+ (throw 'is-function t)))
+ (c-forward-declarator nil t)
+ (eq (char-after) ?,))
+ (forward-char)
+ (c-forward-syntactic-ws))
+ t)))))
+ cdd-got-init (and (cadr (cddr cdd-decl-res))
+ (char-after)))
+
+ ;; Jump past any initializer or function prototype to see if
+ ;; there's a ',' to continue at.
+ (cond (cdd-got-func
+ ;; Skip a parenthesized initializer (C++) or a function
+ ;; prototype.
+ (if (c-go-list-forward (point) cdd-limit) ; over the parameter list.
+ (c-forward-syntactic-ws cdd-limit)
+ (setq cdd-exhausted t))) ; unbalanced parens
+
+ (cdd-got-init ; "=" sign OR opening "(", "[", or "{"
+ ;; Skip an initializer expression. If we're at a '='
+ ;; then accept a brace list directly after it to cope
+ ;; with array initializers. Otherwise stop at braces
+ ;; to avoid going past full function and class blocks.
+ (if (and (if (and (eq cdd-got-init ?=)
+ (= (c-forward-token-2 1 nil cdd-limit) 0)
+ (looking-at "{"))
+ (c-go-list-forward (point) cdd-limit)
+ t)
+ ;; FIXME: Should look for c-decl-end markers here;
+ ;; we might go far into the following declarations
+ ;; in e.g. ObjC mode (see e.g. methods-4.m).
+ (c-syntactic-re-search-forward "[;,{]" cdd-limit 'move t))
+ (backward-char)
+ (setq cdd-exhausted t)
+ ))
+
+ (t (c-forward-syntactic-ws cdd-limit)))
+
+ (if cdd-function
+ (funcall cdd-function cdd-id-start cdd-id-end cdd-next-pos
+ cdd-not-top cdd-got-func cdd-got-init))
+
+ ;; If a ',' is found we set cdd-pos to the next declarator and iterate.
+ (if (and cdd-list (< (point) cdd-limit) (looking-at ","))
+ (progn
+ (when cdd-comma-prop
+ (c-put-char-property (point) 'c-type cdd-comma-prop))
+ (forward-char)
+ (c-forward-syntactic-ws cdd-limit)
+ (setq cdd-pos (point)))
+ (setq cdd-exhausted t)))
+
+ (if (> (point) cdd-pos)
+ t
+ (goto-char cdd-pos)
+ nil)))
+
+;; Macro used inside `c-forward-decl-or-cast-1'. It ought to be a
+;; defsubst or perhaps even a defun, but it contains lots of free
+;; variables that refer to things inside `c-forward-decl-or-cast-1'.
+(defmacro c-fdoc-shift-type-backward (&optional short)
+ ;; `c-forward-decl-or-cast-1' can consume an arbitrary length list
+ ;; of types when parsing a declaration, which means that it
+ ;; sometimes consumes the identifier in the declaration as a type.
+ ;; This is used to "backtrack" and make the last type be treated as
+ ;; an identifier instead.
+ `(progn
+ ,(unless short
+ ;; These identifiers are bound only in the inner let.
+ '(setq identifier-type at-type
+ identifier-start type-start
+ got-parens nil
+ got-identifier t
+ got-suffix t
+ got-suffix-after-parens id-start
+ paren-depth 0))
+
+ (if (setq at-type (if (eq backup-at-type 'prefix)
+ t
+ backup-at-type))
+ (setq type-start backup-type-start
+ id-start backup-id-start)
+ (setq type-start start-pos
+ id-start start-pos))
+
+ ;; When these flags already are set we've found specifiers that
+ ;; unconditionally signal these attributes - backtracking doesn't
+ ;; change that. So keep them set in that case.
+ (or at-type-decl
+ (setq at-type-decl backup-at-type-decl))
+ (or maybe-typeless
+ (setq maybe-typeless backup-maybe-typeless))
+
+ ,(unless short
+ ;; This identifier is bound only in the inner let.
+ '(setq start id-start))))
+
(defun c-forward-decl-or-cast-1 (preceding-token-end context last-cast-end)
;; Move forward over a declaration or a cast if at the start of one.
;; The point is assumed to be at the start of some token. Nil is
@@ -8550,7 +9043,7 @@ comment at the start of cc-engine.el for more info."
;; Skip over type decl prefix operators. (Note similar code in
;; `c-forward-declarator'.)
(if (and c-recognize-typeless-decls
- (equal c-type-decl-prefix-key "\\<\\>"))
+ (equal c-type-decl-prefix-key "a\\`")) ; Regexp which doesn't match
(when (eq (char-after) ?\()
(progn
(setq paren-depth (1+ paren-depth))
@@ -8609,8 +9102,18 @@ comment at the start of cc-engine.el for more info."
;; construct here in C, since we want to recognize this as a
;; typeless function declaration.
(not (and (c-major-mode-is 'c-mode)
+ (not got-prefix)
(or (eq context 'top) make-top)
- (eq (char-after) ?\)))))
+ (eq (char-after) ?\))
+ (or (memq at-type '(nil maybe))
+ (not got-identifier)
+ (save-excursion
+ (goto-char after-paren-pos)
+ (c-forward-syntactic-ws)
+ ;; Prevent the symbol being recorded as a type.
+ (let (c-record-type-identifiers)
+ (not (memq (c-forward-type)
+ '(nil maybe)))))))))
(if (eq (char-after) ?\))
(when (> paren-depth 0)
(setq paren-depth (1- paren-depth))
@@ -8638,31 +9141,39 @@ comment at the start of cc-engine.el for more info."
;; (con|de)structors in C++ and `c-typeless-decl-kwds'
;; style declarations. That isn't applicable in an
;; arglist context, though.
- (when (and (= paren-depth 1)
- (not got-prefix-before-parens)
- (not (eq at-type t))
- (or backup-at-type
- maybe-typeless
- backup-maybe-typeless
- (when c-recognize-typeless-decls
- (and (memq context '(nil top))
- ;; Deal with C++11's "copy-initialization"
- ;; where we have <type>(<constant>), by
- ;; contrasting with a typeless
- ;; <name>(<type><parameter>, ...).
- (save-excursion
- (goto-char after-paren-pos)
- (c-forward-syntactic-ws)
- (or (c-forward-type)
- ;; Recognize a top-level typeless
- ;; function declaration in C.
- (and (c-major-mode-is 'c-mode)
- (or (eq context 'top) make-top)
- (eq (char-after) ?\))))))))
- (setq pos (c-up-list-forward (point)))
- (eq (char-before pos) ?\)))
+ (when (and (> paren-depth 0)
+ (not got-prefix-before-parens)
+ (not (eq at-type t))
+ (or backup-at-type
+ maybe-typeless
+ backup-maybe-typeless
+ (when c-recognize-typeless-decls
+ (and (memq context '(nil top))
+ ;; Deal with C++11's "copy-initialization"
+ ;; where we have <type>(<constant>), by
+ ;; contrasting with a typeless
+ ;; <name>(<type><parameter>, ...).
+ (save-excursion
+ (goto-char after-paren-pos)
+ (c-forward-syntactic-ws)
+ (or (c-forward-type)
+ ;; Recognize a top-level typeless
+ ;; function declaration in C.
+ (and (c-major-mode-is 'c-mode)
+ (or (eq context 'top) make-top)
+ (eq (char-after) ?\))))))))
+ (let ((pd paren-depth))
+ (setq pos (point))
+ (catch 'pd
+ (while (> pd 0)
+ (setq pos (c-up-list-forward pos))
+ (when (or (null pos)
+ (not (eq (char-before pos) ?\))))
+ (throw 'pd nil))
+ (goto-char pos)
+ (setq pd (1- pd)))
+ t)))
(c-fdoc-shift-type-backward)
- (goto-char pos)
t)))
(c-forward-syntactic-ws))
@@ -8713,7 +9224,7 @@ comment at the start of cc-engine.el for more info."
(setq at-decl-end
(looking-at (cond ((eq context '<>) "[,>]")
- ((not (memq context '(nil top))) "[,\)]")
+ ((not (memq context '(nil top))) "[,)]")
(t "[,;]"))))
;; Now we've collected info about various characteristics of
@@ -9531,11 +10042,10 @@ comment at the start of cc-engine.el for more info."
;; back we should search.
;;
;; This function might do hidden buffer changes.
- (c-with-syntax-table c++-template-syntax-table
- (c-backward-token-2 0 t lim)
- (while (and (or (looking-at c-symbol-start)
- (looking-at "[<,]\\|::"))
- (zerop (c-backward-token-2 1 t lim))))))
+ (c-backward-token-2 0 t lim)
+ (while (and (or (looking-at c-symbol-start)
+ (looking-at "[<,]\\|::"))
+ (zerop (c-backward-token-2 1 t lim)))))
(defun c-in-method-def-p ()
;; Return nil if we aren't in a method definition, otherwise the
@@ -9615,7 +10125,7 @@ comment at the start of cc-engine.el for more info."
(let ((beg (point)) id-start)
(and
- (eq (c-beginning-of-statement-1 lim) 'same)
+ (eq (c-beginning-of-statement-1 lim nil nil nil t) 'same)
(not (and (c-major-mode-is 'objc-mode)
(c-forward-objc-directive)))
@@ -9833,9 +10343,15 @@ comment at the start of cc-engine.el for more info."
;; This function might do hidden buffer changes.
(save-excursion
(and (zerop (c-backward-token-2 1 t lim))
+ (if (looking-at c-block-stmt-hangon-key)
+ (zerop (c-backward-token-2 1 t lim))
+ t)
(or (looking-at c-block-stmt-1-key)
(and (eq (char-after) ?\()
(zerop (c-backward-token-2 1 t lim))
+ (if (looking-at c-block-stmt-hangon-key)
+ (zerop (c-backward-token-2 1 t lim))
+ t)
(or (looking-at c-block-stmt-2-key)
(looking-at c-block-stmt-1-2-key))))
(point))))
@@ -9905,11 +10421,10 @@ comment at the start of cc-engine.el for more info."
(and (c-safe (c-backward-sexp) t)
(looking-at c-opt-op-identifier-prefix)))
(and (eq (char-before) ?<)
- (c-with-syntax-table c++-template-syntax-table
- (if (c-safe (goto-char (c-up-list-forward (point))))
- t
- (goto-char (point-max))
- nil)))))
+ (if (c-safe (goto-char (c-up-list-forward (point))))
+ t
+ (goto-char (point-max))
+ nil))))
(setq base (point)))
(while (and
@@ -10002,28 +10517,25 @@ comment at the start of cc-engine.el for more info."
;; potentially can search over a large amount of text.). Take special
;; pains not to get mislead by C++'s "operator=", and the like.
(if (and (eq move 'previous)
- (c-with-syntax-table (if (c-major-mode-is 'c++-mode)
- c++-template-syntax-table
- (syntax-table))
- (save-excursion
- (and
- (progn
- (while ; keep going back to "[;={"s until we either find
- ; no more, or get to one which isn't an "operator ="
- (and (c-syntactic-re-search-forward "[;={]" start t t t)
- (eq (char-before) ?=)
- c-overloadable-operators-regexp
- c-opt-op-identifier-prefix
- (save-excursion
- (eq (c-backward-token-2) 0)
- (looking-at c-overloadable-operators-regexp)
- (eq (c-backward-token-2) 0)
- (looking-at c-opt-op-identifier-prefix))))
- (eq (char-before) ?=))
- (c-syntactic-re-search-forward "[;{]" start t t)
- (eq (char-before) ?{)
- (c-safe (goto-char (c-up-list-forward (point))) t)
- (not (c-syntactic-re-search-forward ";" start t t))))))
+ (save-excursion
+ (and
+ (progn
+ (while ; keep going back to "[;={"s until we either find
+ ; no more, or get to one which isn't an "operator ="
+ (and (c-syntactic-re-search-forward "[;={]" start t t t)
+ (eq (char-before) ?=)
+ c-overloadable-operators-regexp
+ c-opt-op-identifier-prefix
+ (save-excursion
+ (eq (c-backward-token-2) 0)
+ (looking-at c-overloadable-operators-regexp)
+ (eq (c-backward-token-2) 0)
+ (looking-at c-opt-op-identifier-prefix))))
+ (eq (char-before) ?=))
+ (c-syntactic-re-search-forward "[;{]" start t t)
+ (eq (char-before) ?{)
+ (c-safe (goto-char (c-up-list-forward (point))) t)
+ (not (c-syntactic-re-search-forward ";" start t t)))))
(cons 'same nil)
(cons move nil)))))
@@ -10038,10 +10550,7 @@ comment at the start of cc-engine.el for more info."
;; `c-end-of-macro' instead in those cases.
;;
;; This function might do hidden buffer changes.
- (let ((start (point))
- (decl-syntax-table (if (c-major-mode-is 'c++-mode)
- c++-template-syntax-table
- (syntax-table))))
+ (let ((start (point)))
(catch 'return
(c-search-decl-header-end)
@@ -10062,34 +10571,32 @@ comment at the start of cc-engine.el for more info."
(throw 'return nil)))
(if (or (not c-opt-block-decls-with-vars-key)
(save-excursion
- (c-with-syntax-table decl-syntax-table
- (let ((lim (point)))
- (goto-char start)
- (not (and
- ;; Check for `c-opt-block-decls-with-vars-key'
- ;; before the first paren.
- (c-syntactic-re-search-forward
- (concat "[;=([{]\\|\\("
- c-opt-block-decls-with-vars-key
- "\\)")
- lim t t t)
- (match-beginning 1)
- (not (eq (char-before) ?_))
- ;; Check that the first following paren is
- ;; the block.
- (c-syntactic-re-search-forward "[;=([{]"
- lim t t t)
- (eq (char-before) ?{)))))))
+ (let ((lim (point)))
+ (goto-char start)
+ (not (and
+ ;; Check for `c-opt-block-decls-with-vars-key'
+ ;; before the first paren.
+ (c-syntactic-re-search-forward
+ (concat "[;=([{]\\|\\("
+ c-opt-block-decls-with-vars-key
+ "\\)")
+ lim t t t)
+ (match-beginning 1)
+ (not (eq (char-before) ?_))
+ ;; Check that the first following paren is
+ ;; the block.
+ (c-syntactic-re-search-forward "[;=([{]"
+ lim t t t)
+ (eq (char-before) ?{))))))
;; The declaration doesn't have any of the
;; `c-opt-block-decls-with-vars' keywords in the
;; beginning, so it ends here at the end of the block.
(throw 'return t)))
- (c-with-syntax-table decl-syntax-table
- (while (progn
- (if (eq (char-before) ?\;)
- (throw 'return t))
- (c-syntactic-re-search-forward ";" nil 'move t))))
+ (while (progn
+ (if (eq (char-before) ?\;)
+ (throw 'return t))
+ (c-syntactic-re-search-forward ";" nil 'move t)))
nil)))
(defun c-looking-at-decl-block (_containing-sexp goto-start &optional limit)
@@ -10169,7 +10676,7 @@ comment at the start of cc-engine.el for more info."
;; legal because it's part of a "compound keyword" like
;; "enum class". Of course, if c-after-brace-list-key
;; is nil, we can skip the test.
- (or (equal c-after-brace-list-key "\\<\\>")
+ (or (equal c-after-brace-list-key "a\\`") ; Regexp which doesn't match
(save-match-data
(save-excursion
(not
@@ -10520,6 +11027,10 @@ comment at the start of cc-engine.el for more info."
((and class-key
(looking-at class-key))
(setq braceassignp nil))
+ ((and c-has-compound-literals
+ (looking-at c-return-key))
+ (setq braceassignp t)
+ nil)
((eq (char-after) ?=)
;; We've seen a =, but must check earlier tokens so
;; that it isn't something that should be ignored.
@@ -10558,9 +11069,14 @@ comment at the start of cc-engine.el for more info."
))))
nil)
(t t))))))
- (if (and (eq braceassignp 'dontknow)
- (/= (c-backward-token-2 1 t lim) 0))
- (setq braceassignp nil)))
+ (when (and (eq braceassignp 'dontknow)
+ (/= (c-backward-token-2 1 t lim) 0))
+ (if (save-excursion
+ (and c-has-compound-literals
+ (eq (c-backward-token-2 1 nil lim) 0)
+ (eq (char-after) ?\()))
+ (setq braceassignp t)
+ (setq braceassignp nil))))
(cond
(braceassignp
@@ -10616,12 +11132,17 @@ comment at the start of cc-engine.el for more info."
)))
(defun c-inside-bracelist-p (containing-sexp paren-state accept-in-paren)
- ;; return the buffer position of the beginning of the brace list
- ;; statement if we're inside a brace list, otherwise return nil.
- ;; CONTAINING-SEXP is the buffer pos of the innermost containing
- ;; paren. PAREN-STATE is the remainder of the state of enclosing
- ;; braces. ACCEPT-IN-PAREN is non-nil iff we will accept as a brace
- ;; list a brace directly enclosed in a parenthesis.
+ ;; return the buffer position of the beginning of the brace list statement
+ ;; if CONTAINING-SEXP is inside a brace list, otherwise return nil.
+ ;;
+ ;; CONTAINING-SEXP is the buffer pos of the innermost containing paren. NO
+ ;; IT ISN'T!!! [This function is badly designed, and probably needs
+ ;; reformulating without its first argument, and the critical position being
+ ;; at point.]
+ ;;
+ ;; PAREN-STATE is the remainder of the state of enclosing braces.
+ ;; ACCEPT-IN-PAREN is non-nil iff we will accept as a brace list a brace
+ ;; directly enclosed in a parenthesis.
;;
;; The "brace list" here is recognized solely by its context, not by
;; its contents.
@@ -10635,7 +11156,8 @@ comment at the start of cc-engine.el for more info."
;; This will pick up brace list declarations.
(save-excursion
(goto-char containing-sexp)
- (c-backward-over-enum-header))
+ (and (c-backward-over-enum-header)
+ (point)))
;; this will pick up array/aggregate init lists, even if they are nested.
(save-excursion
(let ((bufpos t)
@@ -10740,7 +11262,8 @@ comment at the start of cc-engine.el for more info."
(defun c-looking-at-statement-block ()
;; Point is at an opening brace. If this is a statement block (i.e. the
;; elements in the block are terminated by semicolons, or the block is
- ;; empty, or the block contains a keyword) return t. Otherwise, return nil.
+ ;; empty, or the block contains a keyword) return non-nil. Otherwise,
+ ;; return nil.
(let ((here (point)))
(prog1
(if (c-go-list-forward)
@@ -10925,7 +11448,7 @@ comment at the start of cc-engine.el for more info."
(c-on-identifier)))
(and c-special-brace-lists
(c-looking-at-special-brace-list))
- (and (c-major-mode-is 'c++-mode)
+ (and c-has-compound-literals
(save-excursion
(goto-char block-follows)
(not (c-looking-at-statement-block)))))
@@ -11244,7 +11767,7 @@ comment at the start of cc-engine.el for more info."
(if (and (eq step-type 'same)
(/= paren-pos (point)))
- (let (inexpr)
+ (let (inexpr bspec)
(cond
((save-excursion
(goto-char paren-pos)
@@ -11260,14 +11783,19 @@ comment at the start of cc-engine.el for more info."
(cdr (assoc (match-string 1)
c-other-decl-block-key-in-symbols-alist))
(max (c-point 'boi paren-pos) (point))))
- ((save-excursion
- (goto-char paren-pos)
- (c-looking-at-or-maybe-in-bracelist containing-sexp))
+ ((c-inside-bracelist-p paren-pos paren-state nil)
(if (save-excursion
(goto-char paren-pos)
(c-looking-at-statement-block))
(c-add-syntax 'defun-block-intro nil)
(c-add-syntax 'brace-list-intro nil)))
+ ((save-excursion
+ (goto-char paren-pos)
+ (setq bspec (c-looking-at-or-maybe-in-bracelist
+ containing-sexp containing-sexp))
+ (and (consp bspec)
+ (eq (cdr bspec) 'in-paren)))
+ (c-add-syntax 'brace-list-intro (car bspec)))
(t (c-add-syntax 'defun-block-intro nil))))
(c-add-syntax 'statement-block-intro nil)))
@@ -11354,10 +11882,9 @@ comment at the start of cc-engine.el for more info."
;; CASE B.2: brace-list-open
((or (consp special-brace-list)
- (consp
- (c-looking-at-or-maybe-in-bracelist
- containing-sexp beg-of-same-or-containing-stmt))
- )
+ (c-inside-bracelist-p (point)
+ (cons containing-sexp paren-state)
+ nil))
;; The most semantically accurate symbol here is
;; brace-list-open, but we normally report it simply as a
;; statement-cont. The reason is that one normally adjusts
@@ -11468,17 +11995,15 @@ comment at the start of cc-engine.el for more info."
((and (c-major-mode-is 'c++-mode)
(save-excursion
(goto-char indent-point)
- (c-with-syntax-table c++-template-syntax-table
- (setq placeholder (c-up-list-backward)))
+ (setq placeholder (c-up-list-backward))
(and placeholder
(eq (char-after placeholder) ?<)
(/= (char-before placeholder) ?<)
(progn
(goto-char (1+ placeholder))
(not (looking-at c-<-op-cont-regexp))))))
- (c-with-syntax-table c++-template-syntax-table
- (goto-char placeholder)
- (c-beginning-of-statement-1 containing-sexp t))
+ (goto-char placeholder)
+ (c-beginning-of-statement-1 containing-sexp t)
(if (save-excursion
(c-backward-syntactic-ws containing-sexp)
(eq (char-before) ?<))
@@ -12138,21 +12663,38 @@ comment at the start of cc-engine.el for more info."
;; NB: No c-after-special-operator-id stuff in this
;; clause - we assume only C++ needs it.
(c-syntactic-skip-backward "^;,=" lim t))
+ (setq placeholder (point))
(memq (char-before) '(?, ?= ?<)))
(cond
+ ;; CASE 5D.6: Something like C++11's "using foo = <type-exp>"
+ ((save-excursion
+ (and (eq (char-before placeholder) ?=)
+ (goto-char placeholder)
+ (eq (c-backward-token-2 1 nil lim) 0)
+ (eq (point) (1- placeholder))
+ (eq (c-beginning-of-statement-1 lim) 'same)
+ (looking-at c-equals-type-clause-key)
+ (let ((preserve-point (point)))
+ (when
+ (and
+ (eq (c-forward-token-2 1 nil nil) 0)
+ (c-on-identifier))
+ (setq placeholder preserve-point)))))
+ (c-add-syntax
+ 'statement-cont placeholder)
+ )
+
;; CASE 5D.3: perhaps a template list continuation?
((and (c-major-mode-is 'c++-mode)
(save-excursion
(save-restriction
- (c-with-syntax-table c++-template-syntax-table
- (goto-char indent-point)
- (setq placeholder (c-up-list-backward))
- (and placeholder
- (eq (char-after placeholder) ?<))))))
- (c-with-syntax-table c++-template-syntax-table
- (goto-char placeholder)
- (c-beginning-of-statement-1 lim t))
+ (goto-char indent-point)
+ (setq placeholder (c-up-list-backward))
+ (and placeholder
+ (eq (char-after placeholder) ?<)))))
+ (goto-char placeholder)
+ (c-beginning-of-statement-1 lim t)
(if (save-excursion
(c-backward-syntactic-ws lim)
(eq (char-before) ?<))
@@ -12176,8 +12718,7 @@ comment at the start of cc-engine.el for more info."
(and (looking-at c-class-key)
(zerop (c-forward-token-2 2 nil indent-point))
(if (eq (char-after) ?<)
- (c-with-syntax-table c++-template-syntax-table
- (zerop (c-forward-token-2 1 t indent-point)))
+ (zerop (c-forward-token-2 1 t indent-point))
t)
(eq (char-after) ?:))))
(goto-char placeholder)
@@ -12284,7 +12825,18 @@ comment at the start of cc-engine.el for more info."
;; The '}' is unbalanced.
nil
(c-end-of-decl-1)
- (>= (point) indent-point))))))
+ (>= (point) indent-point))))
+ ;; Check that we only have one brace block here, i.e. that we
+ ;; don't have something like a function with a struct
+ ;; declaration as its type.
+ (save-excursion
+ (or (not (and state-cache (consp (car state-cache))))
+ ;; The above probably can't happen.
+ (progn
+ (goto-char placeholder)
+ (and (c-syntactic-re-search-forward
+ "{" indent-point t)
+ (eq (1- (point)) (caar state-cache))))))))
(goto-char placeholder)
(c-add-stmt-syntax 'topmost-intro-cont nil nil
containing-sexp paren-state))
@@ -12432,6 +12984,11 @@ comment at the start of cc-engine.el for more info."
;; in-expression block or brace list. C.f. cases 4, 16A
;; and 17E.
((and (eq char-after-ip ?{)
+ (or (not (eq (char-after containing-sexp) ?\())
+ (save-excursion
+ (and c-opt-inexpr-brace-list-key
+ (eq (c-beginning-of-statement-1 lim t nil t) 'same)
+ (looking-at c-opt-inexpr-brace-list-key))))
(progn
(setq placeholder (c-inside-bracelist-p (point)
paren-state
@@ -12606,23 +13163,30 @@ comment at the start of cc-engine.el for more info."
(= (point) containing-sexp)))
(if (eq (point) (c-point 'boi))
(c-add-syntax 'brace-list-close (point))
- (setq lim (c-most-enclosing-brace state-cache (point)))
+ (setq lim (or (save-excursion
+ (and
+ (c-back-over-member-initializers)
+ (point)))
+ (c-most-enclosing-brace state-cache (point))))
(c-beginning-of-statement-1 lim nil nil t)
(c-add-stmt-syntax 'brace-list-close nil t lim paren-state)))
(t
- ;; Prepare for the rest of the cases below by going to the
- ;; token following the opening brace
- (if (consp special-brace-list)
- (progn
- (goto-char (car (car special-brace-list)))
- (c-forward-token-2 1 nil indent-point))
- (goto-char containing-sexp))
- (forward-char)
- (let ((start (point)))
- (c-forward-syntactic-ws indent-point)
- (goto-char (max start (c-point 'bol))))
- (c-skip-ws-forward indent-point)
+ ;; Prepare for the rest of the cases below by going back to the
+ ;; previous entry, or BOI before that, providing that this is
+ ;; inside the enclosing brace.
+ (goto-char indent-point)
+ (c-beginning-of-statement-1 containing-sexp nil nil t)
+ (when (/= (point) indent-point)
+ (if (> (c-point 'boi) containing-sexp)
+ (goto-char (c-point 'boi))
+ (if (consp special-brace-list)
+ (progn
+ (goto-char (caar special-brace-list))
+ (c-forward-token-2 1 nil indent-point))
+ (goto-char containing-sexp))
+ (forward-char)
+ (c-skip-ws-forward indent-point)))
(cond
;; CASE 9C: we're looking at the first line in a brace-list
@@ -12632,8 +13196,12 @@ comment at the start of cc-engine.el for more info."
(goto-char containing-sexp))
(if (eq (point) (c-point 'boi))
(c-add-syntax 'brace-list-intro (point))
- (setq lim (c-most-enclosing-brace state-cache (point)))
- (c-beginning-of-statement-1 lim)
+ (setq lim (or (save-excursion
+ (and
+ (c-back-over-member-initializers)
+ (point)))
+ (c-most-enclosing-brace state-cache (point))))
+ (c-beginning-of-statement-1 lim nil nil t)
(c-add-stmt-syntax 'brace-list-intro nil t lim paren-state)))
;; CASE 9D: this is just a later brace-list-entry or
@@ -13092,7 +13660,7 @@ Cannot combine absolute offsets %S and %S in `add' method"
nil))))
(if (or (null res) (integerp res)
- (and (vectorp res) (= (length res) 1) (integerp (aref res 0))))
+ (and (vectorp res) (>= (length res) 1) (integerp (aref res 0))))
res
(c-benign-error "Error evaluating offset %S for %s: Got invalid value %S"
offset symbol res)
@@ -13115,12 +13683,11 @@ Cannot combine absolute offsets %S and %S in `add' method"
(if c-strict-syntax-p
(c-benign-error "No offset found for syntactic symbol %s" symbol))
(setq offset 0))
- (if (vectorp offset)
- offset
- (or (and (numberp offset) offset)
- (and (symbolp offset) (symbol-value offset))
- 0))
- ))
+ (cond
+ ((or (vectorp offset) (numberp offset))
+ offset)
+ ((and (symbolp offset) (symbol-value offset)))
+ (t 0))))
(defun c-get-offset (langelem)
;; This is a compatibility wrapper for `c-calc-offset' in case
@@ -13177,6 +13744,18 @@ Cannot combine absolute offsets %S and %S in `add' method"
indent)))
+(def-edebug-spec c-bos-pop-state t)
+(def-edebug-spec c-bos-save-error-info t)
+(def-edebug-spec c-state-cache-top-lparen t)
+(def-edebug-spec c-state-cache-top-paren t)
+(def-edebug-spec c-state-cache-after-top-paren t)
+(def-edebug-spec c-state-maybe-marker (form symbolp))
+(def-edebug-spec c-record-type-id t)
+(def-edebug-spec c-record-ref-id t)
+(def-edebug-spec c-forward-keyword-prefixed-id t)
+(def-edebug-spec c-forward-id-comma-list t)
+(def-edebug-spec c-pull-open-brace (symbolp))
+
(cc-provide 'cc-engine)
;; Local Variables:
diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el
index b4ebecf56e4..e7a3748af43 100644
--- a/lisp/progmodes/cc-fonts.el
+++ b/lisp/progmodes/cc-fonts.el
@@ -488,6 +488,9 @@
; (eval-after-load "edebug" ; 2006-07-09: def-edebug-spec is now in subr.el.
; '(progn
+(def-edebug-spec c-put-font-lock-face t)
+(def-edebug-spec c-remove-font-lock-face t)
+(def-edebug-spec c-put-font-lock-string-face t)
(def-edebug-spec c-fontify-types-and-refs let*)
(def-edebug-spec c-make-syntactic-matcher t)
;; If there are literal quoted or backquoted highlight specs in
@@ -669,7 +672,7 @@ stuff. Used on level 1 and higher."
,@(when (c-major-mode-is 'pike-mode)
;; Recognize hashbangs in Pike.
- `((eval . (list "\\`#![^\n\r]*"
+ '((eval . (list "\\`#![^\n\r]*"
0 c-preprocessor-face-name))))
;; Make hard spaces visible through an inverted `font-lock-warning-face'.
@@ -682,33 +685,6 @@ stuff. Used on level 1 and higher."
''c-nonbreakable-space-face)))
))
-(defun c-font-lock-invalid-string ()
- ;; Assuming the point is after the opening character of a string,
- ;; fontify that char with `font-lock-warning-face' if the string
- ;; decidedly isn't terminated properly.
- ;;
- ;; This function does hidden buffer changes.
- (let ((start (1- (point))))
- (save-excursion
- (and (eq (elt (parse-partial-sexp start (c-point 'eol)) 8) start)
- (if (if (eval-when-compile (integerp ?c))
- ;; Emacs
- (integerp c-multiline-string-start-char)
- ;; XEmacs
- (characterp c-multiline-string-start-char))
- ;; There's no multiline string start char before the
- ;; string, so newlines aren't allowed.
- (not (eq (char-before start) c-multiline-string-start-char))
- ;; Multiline strings are allowed anywhere if
- ;; c-multiline-string-start-char is t.
- (not c-multiline-string-start-char))
- (if c-string-escaped-newlines
- ;; There's no \ before the newline.
- (not (eq (char-before (point)) ?\\))
- ;; Escaped newlines aren't supported.
- t)
- (c-put-font-lock-face start (1+ start) 'font-lock-warning-face)))))
-
(defun c-font-lock-invalid-single-quotes (limit)
;; This function will be called from font-lock for a region bounded by POINT
;; and LIMIT, as though it were to identify a keyword for
@@ -749,16 +725,12 @@ casts and declarations are fontified. Used on level 2 and higher."
;; `c-recognize-<>-arglists' is set.
t `(;; Put a warning face on the opener of unclosed strings that
- ;; can't span lines. Later font
+ ;; can't span lines and on the "terminating" newlines. Later font
;; lock packages have a `font-lock-syntactic-face-function' for
;; this, but it doesn't give the control we want since any
;; fontification done inside the function will be
;; unconditionally overridden.
- ,(c-make-font-lock-search-function
- ;; Match a char before the string starter to make
- ;; `c-skip-comments-and-strings' work correctly.
- (concat ".\\(" c-string-limit-regexp "\\)")
- '((c-font-lock-invalid-string)))
+ ("\\s|" 0 font-lock-warning-face t nil)
;; Invalid single quotes.
c-font-lock-invalid-single-quotes
@@ -1060,114 +1032,41 @@ casts and declarations are fontified. Used on level 2 and higher."
;;(message "c-font-lock-declarators from %s to %s" (point) limit)
(c-fontify-types-and-refs
- ((pos (point)) next-pos id-start
- decl-res
- id-face got-type got-init
- c-last-identifier-range
- (separator-prop (if types 'c-decl-type-start 'c-decl-id-start)))
-
- ;; The following `while' fontifies a single declarator id each time round.
- ;; It loops only when LIST is non-nil.
- (while
- (and pos (setq decl-res (c-forward-declarator)))
- (setq next-pos (point)
- id-start (car decl-res)
- id-face (if (and (eq (char-after) ?\()
- (or (not (c-major-mode-is 'c++-mode))
- (not not-top)
- (car (cddr (cddr decl-res))) ; Id is in
- ; parens, etc.
- (save-excursion
- (forward-char)
- (c-forward-syntactic-ws)
- (looking-at "[*&]")))
- (not (car (cddr decl-res)))
- (or (not (c-major-mode-is 'c++-mode))
- (save-excursion
- (let (c-last-identifier-range)
- (forward-char)
- (c-forward-syntactic-ws)
- (catch 'is-function
- (while
- (progn
- (if (eq (char-after) ?\))
- (throw 'is-function t))
- (setq got-type (c-forward-type))
- (cond
- ((null got-type)
- (throw 'is-function nil))
- ((not (eq got-type 'maybe))
- (throw 'is-function t)))
- (c-forward-declarator nil t)
- (eq (char-after) ?,))
- (forward-char)
- (c-forward-syntactic-ws))
- t)))))
- 'font-lock-function-name-face
- 'font-lock-variable-name-face)
- got-init (and (cadr (cddr decl-res)) ; got-init
- (char-after)))
-
- (if types
- ;; Register and fontify the identifier as a type.
- (let ((c-promote-possible-types t))
- (goto-char id-start)
- (c-forward-type))
- ;; Fontify the last symbol in the identifier if it isn't fontified
- ;; already. The check is necessary only in certain cases where this
- ;; function is used "sloppily", e.g. in `c-simple-decl-matchers'.
- (when (and c-last-identifier-range
- (not (get-text-property (car c-last-identifier-range)
- 'face)))
- (c-put-font-lock-face (car c-last-identifier-range)
- (cdr c-last-identifier-range)
- id-face)))
-
- (goto-char next-pos)
- (setq pos nil) ; So as to terminate the enclosing `while' form.
- (if (and template-class
- (eq got-init ?=) ; C++ "<class X = Y>"?
- (c-forward-token-2 1 nil limit) ; Over "="
- (let ((c-promote-possible-types t))
- (c-forward-type t))) ; Over "Y"
- (setq list nil)) ; Shouldn't be needed. We can't have a list, here.
-
- (when list
- ;; Jump past any initializer or function prototype to see if
- ;; there's a ',' to continue at.
- (cond ((eq id-face 'font-lock-function-name-face)
- ;; Skip a parenthesized initializer (C++) or a function
- ;; prototype.
- (if (c-safe (c-forward-sexp 1) t) ; over the parameter list.
- (c-forward-syntactic-ws limit)
- (goto-char limit))) ; unbalanced parens
-
- (got-init ; "=" sign OR opening "(", "[", or "{"
- ;; Skip an initializer expression. If we're at a '='
- ;; then accept a brace list directly after it to cope
- ;; with array initializers. Otherwise stop at braces
- ;; to avoid going past full function and class blocks.
- (and (if (and (eq got-init ?=)
- (= (c-forward-token-2 1 nil limit) 0)
- (looking-at "{"))
- (c-safe (c-forward-sexp) t) ; over { .... }
- t)
- (< (point) limit)
- ;; FIXME: Should look for c-decl-end markers here;
- ;; we might go far into the following declarations
- ;; in e.g. ObjC mode (see e.g. methods-4.m).
- (c-syntactic-re-search-forward "[;,{]" limit 'move t)
- (backward-char)))
-
- (t (c-forward-syntactic-ws limit)))
-
- ;; If a ',' is found we set pos to the next declarator and iterate.
- (when (and (< (point) limit) (looking-at ","))
- (c-put-char-property (point) 'c-type separator-prop)
- (forward-char)
- (c-forward-syntactic-ws limit)
- (setq pos (point)))))) ; acts to make the `while' form continue.
- nil)
+ ()
+ (c-do-declarators
+ limit list not-top
+ (if types 'c-decl-type-start 'c-decl-id-start)
+ (lambda (id-start id-end end-pos not-top is-function init-char)
+ (if types
+ ;; Register and fontify the identifier as a type.
+ (let ((c-promote-possible-types t))
+ (goto-char id-start)
+ (c-forward-type))
+ ;; The following doesn't work properly (yet, 2018-09-22).
+ ;; (c-put-font-lock-face id-start id-end
+ ;; (if is-function
+ ;; 'font-lock-function-name-face
+ ;; 'font-lock-variable-name-face))
+ (when (and c-last-identifier-range
+ (not (get-text-property (car c-last-identifier-range)
+ 'face)))
+ ;; We use `c-last-identifier-range' rather than `id-start' and
+ ;; `id-end', since the latter two can be erroneous. E.g. in
+ ;; "~Foo", `id-start' is at the tilde. This is a bug in
+ ;; `c-forward-declarator'.
+ (c-put-font-lock-face (car c-last-identifier-range)
+ (cdr c-last-identifier-range)
+ (if is-function
+ 'font-lock-function-name-face
+ 'font-lock-variable-name-face))))
+ (and template-class
+ (eq init-char ?=) ; C++ "<class X = Y>"?
+ (progn
+ (goto-char end-pos)
+ (c-forward-token-2 1 nil limit) ; Over "="
+ (let ((c-promote-possible-types t))
+ (c-forward-type t))))))
+ nil))
(defun c-get-fontification-context (match-pos not-front-decl &optional toplev)
;; Return a cons (CONTEXT . RESTRICTED-<>-ARGLISTS) for MATCH-POS.
@@ -1234,10 +1133,9 @@ casts and declarations are fontified. Used on level 2 and higher."
(cons 'decl nil))
;; We're inside a brace list.
((and (eq (char-before match-pos) ?{)
- (save-excursion
- (goto-char (1- match-pos))
- (consp
- (c-looking-at-or-maybe-in-bracelist))))
+ (c-inside-bracelist-p (1- match-pos)
+ (cdr (c-parse-state))
+ nil))
(c-put-char-property (1- match-pos) 'c-type
'c-not-decl)
(cons 'not-decl nil))
@@ -1776,25 +1674,36 @@ casts and declarations are fontified. Used on level 2 and higher."
(goto-char string-start)
(and (eq (char-before) ?R)
(looking-at "\"\\([^ ()\\\n\r\t]\\{0,16\\}\\)(")
- (match-string-no-properties 1))))))
+ (match-string-no-properties 1)))))
+ (content-start (and raw-id (point))))
+ ;; We go round the next loop twice per raw string, once for each "end".
(while (< (point) limit)
(if raw-id
+ ;; Search for the raw string end delimiter
(progn
- (if (search-forward-regexp (concat ")\\(" (regexp-quote raw-id) "\\)\"")
- limit 'limit)
- (c-put-font-lock-face (match-beginning 1) (point) 'default))
+ (when (search-forward-regexp (concat ")\\(" (regexp-quote raw-id) "\\)\"")
+ limit 'limit)
+ (c-put-font-lock-face content-start (match-beginning 1)
+ 'font-lock-string-face)
+ (c-remove-font-lock-face (match-beginning 1) (point)))
(setq raw-id nil))
-
+ ;; Search for the start of a raw string.
(when (search-forward-regexp
"R\\(\"\\)\\([^ ()\\\n\r\t]\\{0,16\\}\\)(" limit 'limit)
(when
- (or (and (eobp)
- (eq (c-get-char-property (1- (point)) 'face)
- 'font-lock-warning-face))
- (eq (c-get-char-property (point) 'face) 'font-lock-string-face)
- (and (equal (c-get-char-property (match-end 2) 'syntax-table) '(1))
- (equal (c-get-char-property (match-beginning 1) 'syntax-table)
- '(1))))
+ ;; Make sure we're not in a comment or string.
+ (and
+ (not (memq (c-get-char-property (match-beginning 0) 'face)
+ '(font-lock-comment-face font-lock-comment-delimiter-face
+ font-lock-string-face)))
+ (or (and (eobp)
+ (eq (c-get-char-property (1- (point)) 'face)
+ 'font-lock-warning-face))
+ (not (eq (c-get-char-property (point) 'face) 'font-lock-comment-face))
+ ;; (eq (c-get-char-property (point) 'face) 'font-lock-string-face)
+ (and (equal (c-get-char-property (match-end 2) 'syntax-table) '(1))
+ (equal (c-get-char-property (match-beginning 1) 'syntax-table)
+ '(1)))))
(let ((paren-prop (c-get-char-property (1- (point)) 'syntax-table)))
(if paren-prop
(progn
@@ -1805,8 +1714,9 @@ casts and declarations are fontified. Used on level 2 and higher."
(equal paren-prop '(15))
(not (c-search-forward-char-property 'syntax-table '(15) limit)))
(goto-char limit)))
- (c-put-font-lock-face (match-beginning 1) (match-end 2) 'default)
- (setq raw-id (match-string-no-properties 2)))))))))
+ (c-remove-font-lock-face (match-beginning 0) (match-end 2))
+ (setq raw-id (match-string-no-properties 2))
+ (setq content-start (match-end 0)))))))))
nil)
(defun c-font-lock-c++-lambda-captures (limit)
@@ -1968,7 +1878,7 @@ on level 2 only and so aren't combined with `c-complex-decl-matchers'."
;; Fontify generic colon labels in languages that support them.
,@(when (c-lang-const c-recognize-colon-labels)
- `(c-font-lock-labels))))
+ '(c-font-lock-labels))))
(c-lang-defconst c-complex-decl-matchers
"Complex font lock matchers for types and declarations. Used on level
@@ -2014,10 +1924,10 @@ on level 2 only and so aren't combined with `c-complex-decl-matchers'."
;; Fontify angle bracket arglists like templates in C++.
,@(when (c-lang-const c-recognize-<>-arglists)
- `(c-font-lock-<>-arglists))
+ '(c-font-lock-<>-arglists))
,@(when (c-major-mode-is 'c++-mode)
- `(c-font-lock-c++-lambda-captures))
+ '(c-font-lock-c++-lambda-captures))
;; The first two rules here mostly find occurrences that
;; `c-font-lock-declarations' has found already, but not
@@ -2039,7 +1949,7 @@ on level 2 only and so aren't combined with `c-complex-decl-matchers'."
,@(when (c-major-mode-is 'c++-mode)
;; This pattern is a probably a "(MATCHER . ANCHORED-HIGHLIGHTER)"
;; (see Elisp page "Search-based Fontification").
- `(("\\<new\\>"
+ '(("\\<new\\>"
(c-font-lock-c++-new))))
))
@@ -2107,10 +2017,10 @@ higher."
t `(,@(when (c-lang-const c-brace-list-decl-kwds)
;; Fontify the remaining identifiers inside an enum list when we start
;; inside it.
- `(c-font-lock-enum-tail
- ;; Fontify the identifiers inside enum lists. (The enum type
- ;; name is handled by `c-simple-decl-matchers' or
- ;; `c-complex-decl-matchers' below.
+ '(c-font-lock-enum-tail
+ ;; Fontify the identifiers inside enum lists. (The enum type
+ ;; name is handled by `c-simple-decl-matchers' or
+ ;; `c-complex-decl-matchers' below.
c-font-lock-enum-body))
;; Fontify labels after goto etc.
@@ -2161,7 +2071,7 @@ higher."
(if (> (point) limit) (goto-char limit))))))))
,@(when (c-major-mode-is 'java-mode)
- `((eval . (list "\\<\\(@[a-zA-Z0-9]+\\)\\>" 1 c-annotation-face))))
+ '((eval . (list "\\<\\(@[a-zA-Z0-9]+\\)\\>" 1 c-annotation-face))))
))
(c-lang-defconst c-matchers-1
diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el
index e45440b5bfd..2dff5cf83c8 100644
--- a/lisp/progmodes/cc-langs.el
+++ b/lisp/progmodes/cc-langs.el
@@ -205,12 +205,13 @@ the evaluated constant value at compile time."
; '
(def-edebug-spec c-lang-defvar
(&define name def-form &optional &or ("quote" symbolp) stringp))
+(def-edebug-spec c-lang-setvar (&define name def-form))
;; Suppress "might not be defined at runtime" warning.
;; This file is only used when compiling other cc files.
-;; These are defined in cl as aliases to the cl- versions.
-;(declare-function delete-duplicates "cl-seq" (cl-seq &rest cl-keys) t)
-;(declare-function mapcan "cl-extra" (cl-func cl-seq &rest cl-rest) t)
+(declare-function cl-delete-duplicates "cl-seq" (cl-seq &rest cl-keys))
+(declare-function cl-intersection "cl-seq" (cl-list1 cl-list2 &rest cl-keys))
+(declare-function cl-set-difference "cl-seq" (cl-list1 cl-list2 &rest cl-keys))
(eval-and-compile
;; Some helper functions used when building the language constants.
@@ -292,7 +293,7 @@ the evaluated constant value at compile time."
["Forward Statement" c-end-of-statement t]
,@(when (c-lang-const c-opt-cpp-prefix)
;; Only applicable if there's a cpp preprocessor.
- `(["Up Conditional" c-up-conditional t]
+ '(["Up Conditional" c-up-conditional t]
["Backward Conditional" c-backward-conditional t]
["Forward Conditional" c-forward-conditional t]
"----"
@@ -382,9 +383,9 @@ The syntax tables aren't stored directly since they're quite large."
;; its compiler directives as single keyword tokens.
;; This is then necessary since it's assumed that
;; every keyword is a single symbol.
- `(modify-syntax-entry ?@ "_" table))
+ '(modify-syntax-entry ?@ "_" table))
((c-major-mode-is 'pike-mode)
- `(modify-syntax-entry ?@ "." table)))
+ '(modify-syntax-entry ?@ "." table)))
table)))
(c-lang-defconst c-mode-syntax-table
@@ -392,27 +393,6 @@ The syntax tables aren't stored directly since they're quite large."
;; the constants in this file are evaluated.
t (funcall (c-lang-const c-make-mode-syntax-table)))
-(c-lang-defconst c++-make-template-syntax-table
- ;; A variant of `c++-mode-syntax-table' that defines `<' and `>' as
- ;; parenthesis characters. Used temporarily when template argument
- ;; lists are parsed. Note that this encourages incorrect parsing of
- ;; templates since they might contain normal operators that uses the
- ;; '<' and '>' characters. Therefore this syntax table might go
- ;; away when CC Mode handles templates correctly everywhere. WHILE
- ;; THIS SYNTAX TABLE IS CURRENT, `c-parse-state' MUST _NOT_ BE
- ;; CALLED!!!
- t nil
- (java c++) `(lambda ()
- (let ((table (funcall ,(c-lang-const c-make-mode-syntax-table))))
- (modify-syntax-entry ?< "(>" table)
- (modify-syntax-entry ?> ")<" table)
- table)))
-(c-lang-defvar c++-template-syntax-table
- (and (c-lang-const c++-make-template-syntax-table)
- ;; The next eval remove a superfluous ' from '(lambda. This
- ;; gets rid of compilation warnings.
- (funcall (eval (c-lang-const c++-make-template-syntax-table)))))
-
(c-lang-defconst c-make-no-parens-syntax-table
;; A variant of the standard syntax table which is used to find matching
;; "<"s and ">"s which have been marked as parens using syntax table
@@ -472,21 +452,24 @@ so that all identifiers are recognized as words.")
(c-lang-defconst c-get-state-before-change-functions
;; For documentation see the following c-lang-defvar of the same name.
;; The value here may be a list of functions or a single function.
- t nil
+ t 'c-before-change-check-unbalanced-strings
c++ '(c-extend-region-for-CPP
c-before-change-check-raw-strings
c-before-change-check-<>-operators
c-depropertize-CPP
c-invalidate-macro-cache
c-truncate-bs-cache
+ c-before-change-check-unbalanced-strings
c-parse-quotes-before-change)
(c objc) '(c-extend-region-for-CPP
c-depropertize-CPP
c-invalidate-macro-cache
c-truncate-bs-cache
+ c-before-change-check-unbalanced-strings
c-parse-quotes-before-change)
- java 'c-parse-quotes-before-change
- ;; 'c-before-change-check-<>-operators
+ java '(c-parse-quotes-before-change
+ c-before-change-check-unbalanced-strings
+ c-before-change-check-<>-operators)
awk 'c-awk-record-region-clear-NL)
(c-lang-defvar c-get-state-before-change-functions
(let ((fs (c-lang-const c-get-state-before-change-functions)))
@@ -514,21 +497,25 @@ parameters \(point-min) and \(point-max).")
;; For documentation see the following c-lang-defvar of the same name.
;; The value here may be a list of functions or a single function.
t '(c-depropertize-new-text
+ c-after-change-mark-abnormal-strings
c-change-expand-fl-region)
(c objc) '(c-depropertize-new-text
c-parse-quotes-after-change
+ c-after-change-mark-abnormal-strings
c-extend-font-lock-region-for-macros
c-neutralize-syntax-in-CPP
c-change-expand-fl-region)
c++ '(c-depropertize-new-text
+ c-after-change-unmark-raw-strings
c-parse-quotes-after-change
+ c-after-change-mark-abnormal-strings
c-extend-font-lock-region-for-macros
- c-after-change-re-mark-raw-strings
c-neutralize-syntax-in-CPP
c-restore-<>-properties
c-change-expand-fl-region)
java '(c-depropertize-new-text
c-parse-quotes-after-change
+ c-after-change-mark-abnormal-strings
c-restore-<>-properties
c-change-expand-fl-region)
awk '(c-depropertize-new-text
@@ -611,12 +598,39 @@ EOL terminated statements."
(c c++ objc) t)
(c-lang-defvar c-has-bitfields (c-lang-const c-has-bitfields))
+(c-lang-defconst c-single-quotes-quote-strings
+ "Whether the language uses single quotes for multi-char strings.
+
+Note that to set up a language to use this, additionally:
+\(i) the syntax of \"'\" must be \"string quote\" (7);
+\(ii) the language's value of `c-has-quoted-numbers' must be nil;
+\(iii) the language's value of `c-get-state-before-change-functions' may not
+ contain `c-parse-quotes-before-change';
+\(iv) the language's value of `c-before-font-lock-functions' may not contain
+ `c-parse-quotes-after-change'."
+ t nil)
+(c-lang-defvar c-single-quotes-quote-strings
+ (c-lang-const c-single-quotes-quote-strings))
+
+(c-lang-defconst c-string-delims
+;; A list of characters which can delimit arbitrary length strings.
+ t (if (c-lang-const c-single-quotes-quote-strings)
+ '(?\" ?\')
+ '(?\")))
+(c-lang-defvar c-string-delims (c-lang-const c-string-delims))
+
(c-lang-defconst c-has-quoted-numbers
"Whether the language has numbers quoted like 4'294'967'295."
t nil
c++ t)
(c-lang-defvar c-has-quoted-numbers (c-lang-const c-has-quoted-numbers))
+(c-lang-defconst c-has-compound-literals
+ "Whether literal initializers {...} are used other than in initializations."
+ t nil
+ (c c++) t)
+(c-lang-defvar c-has-compound-literals (c-lang-const c-has-compound-literals))
+
(c-lang-defconst c-modified-constant
"Regexp that matches a “modified” constant literal such as \"L\\='a\\='\",
a “long character”. In particular, this recognizes forms of constant
@@ -850,6 +864,28 @@ literal are multiline."
(c-lang-defvar c-multiline-string-start-char
(c-lang-const c-multiline-string-start-char))
+(c-lang-defconst c-string-innards-re-alist
+ ;; An alist of regexps matching the innards of a string, the key being the
+ ;; string's delimiter.
+ ;;
+ ;; The regexps' matches extend up to, but not including, the closing string
+ ;; delimiter or an unescaped NL. An EOL is part of the string only if it is
+ ;; escaped.
+ t (mapcar (lambda (delim)
+ (cons
+ delim
+ (concat "\\(\\\\\\(.\\|\n\\|\r\\)\\|[^\\\n\r"
+ (string delim)
+ "]\\)*")))
+ (and
+ (or (null (c-lang-const c-multiline-string-start-char))
+ (c-characterp (c-lang-const c-multiline-string-start-char)))
+ (if (c-lang-const c-single-quotes-quote-strings)
+ '(?\" ?\')
+ '(?\")))))
+(c-lang-defvar c-string-innards-re-alist
+ (c-lang-const c-string-innards-re-alist))
+
(c-lang-defconst c-opt-cpp-symbol
"The symbol which starts preprocessor constructs when in the margin."
t "#"
@@ -899,6 +935,19 @@ file name in angle brackets or quotes."
'("include"))
objc '("include" "import"))
+(c-lang-defconst c-cpp-include-key
+ ;; Matches an include directive anchored at BOL including any trailing
+ ;; whitespace, e.g. " # include "
+ t (if (and (c-lang-const c-anchored-cpp-prefix)
+ (c-lang-const c-cpp-include-directives))
+ (concat
+ (c-lang-const c-anchored-cpp-prefix)
+ (c-make-keywords-re 'appendable
+ (c-lang-const c-cpp-include-directives))
+ "[ \t]*")
+ "a\\`")) ; Doesn't match anything
+(c-lang-defvar c-cpp-include-key (c-lang-const c-cpp-include-key))
+
(c-lang-defconst c-opt-cpp-macro-define
"Cpp directive (without the prefix) that is followed by a macro
definition, or nil if the language doesn't have any."
@@ -1018,16 +1067,16 @@ since CC Mode treats every identifier as an expression."
;; Primary.
,@(c-lang-const c-identifier-ops)
,@(cond ((or (c-major-mode-is 'c++-mode) (c-major-mode-is 'java-mode))
- `((postfix-if-paren "<" ">"))) ; Templates.
+ '((postfix-if-paren "<" ">"))) ; Templates.
((c-major-mode-is 'pike-mode)
- `((prefix "global" "predef")))
+ '((prefix "global" "predef")))
((c-major-mode-is 'java-mode)
- `((prefix "super"))))
+ '((prefix "super"))))
;; Postfix.
,@(when (c-major-mode-is 'c++-mode)
;; The following need special treatment.
- `((prefix "dynamic_cast" "static_cast"
+ '((prefix "dynamic_cast" "static_cast"
"reinterpret_cast" "const_cast" "typeid"
"alignof")))
(left-assoc "."
@@ -1057,7 +1106,7 @@ since CC Mode treats every identifier as an expression."
;; Member selection.
,@(when (c-major-mode-is 'c++-mode)
- `((left-assoc ".*" "->*")))
+ '((left-assoc ".*" "->*")))
;; Multiplicative.
(left-assoc "*" "/" "%")
@@ -1274,7 +1323,7 @@ operators."
(c--set-difference (c-lang-const c-assignment-operators)
'("=")
:test 'string-equal)))
- "\\<\\>"))
+ "a\\`")) ; Doesn't match anything.
(c-lang-defvar c-assignment-op-regexp
(c-lang-const c-assignment-op-regexp))
@@ -1497,10 +1546,21 @@ properly."
;; language)
t (if (c-lang-const c-block-comment-ender)
(regexp-quote (c-lang-const c-block-comment-ender))
- "\\<\\>"))
+ "a\\`")) ; Doesn't match anything.
(c-lang-defvar c-block-comment-ender-regexp
(c-lang-const c-block-comment-ender-regexp))
+(c-lang-defconst c-font-lock-comment-end-skip
+ ;; Regexp which matches whitespace followed by the end of a block comment
+ ;; (if such exists in the language). This is used by font lock to determine
+ ;; the portion of the end of a comment to fontify with
+ ;; `font-lock-comment-delimiter-face'.
+ t (if (c-lang-const c-block-comment-ender)
+ (concat "[ \t]*" (c-lang-const c-block-comment-ender-regexp))
+ "a\\`")) ; Doesn't match anything.
+(c-lang-setvar font-lock-comment-end-skip
+ (c-lang-const c-font-lock-comment-end-skip))
+
(c-lang-defconst c-comment-start-regexp
;; Regexp to match the start of any type of comment.
t (let ((re (c-make-keywords-re nil
@@ -1516,7 +1576,7 @@ properly."
;; language)
t (if (c-lang-const c-block-comment-starter)
(regexp-quote (c-lang-const c-block-comment-starter))
- "\\<\\>"))
+ "a\\`")) ; Doesn't match anything.
(c-lang-defvar c-block-comment-start-regexp
(c-lang-const c-block-comment-start-regexp))
@@ -1525,7 +1585,7 @@ properly."
;; language; it does in all 7 CC Mode languages).
t (if (c-lang-const c-line-comment-starter)
(regexp-quote (c-lang-const c-line-comment-starter))
- "\\<\\>"))
+ "a\\`")) ; Doesn't match anything.
(c-lang-defvar c-line-comment-start-regexp
(c-lang-const c-line-comment-start-regexp))
@@ -1540,7 +1600,7 @@ properly."
(c-lang-defconst c-doc-comment-start-regexp
"Regexp to match the start of documentation comments."
- t "\\<\\>"
+ t "a\\`" ; Doesn't match anything.
;; From font-lock.el: `doxygen' uses /*! while others use /**.
(c c++ objc) "/\\*[*!]"
java "/\\*\\*"
@@ -2101,6 +2161,18 @@ will be handled."
"Alist associating keywords in c-other-decl-block-decl-kwds with
their matching \"in\" syntactic symbols.")
+(c-lang-defconst c-defun-type-name-decl-kwds
+ "Keywords introducing a named block, where the name is a \"defun\"
+ name."
+ t (append (c-lang-const c-class-decl-kwds)
+ (c-lang-const c-brace-list-decl-kwds)))
+
+(c-lang-defconst c-defun-type-name-decl-key
+ ;; Regexp matching a keyword in `c-defun-name-decl-kwds'.
+ t (c-make-keywords-re t (c-lang-const c-defun-type-name-decl-kwds)))
+(c-lang-defvar c-defun-type-name-decl-key
+ (c-lang-const c-defun-type-name-decl-key))
+
(c-lang-defconst c-typedef-decl-kwds
"Keywords introducing declarations where the identifier(s) being
declared are types.
@@ -2150,6 +2222,18 @@ will be handled."
pike (append (c-lang-const c-class-decl-kwds)
'("constant")))
+(c-lang-defconst c-equals-type-clause-kwds
+ "Keywords which are followed by an identifier then an \"=\"
+ sign, which declares the identifier to be a type."
+ t nil
+ c++ '("using"))
+
+(c-lang-defconst c-equals-type-clause-key
+ ;; A regular expression which matches any member of
+ ;; `c-equals-type-clause-kwds'.
+ t (c-make-keywords-re t (c-lang-const c-equals-type-clause-kwds)))
+(c-lang-defvar c-equals-type-clause-key (c-lang-const c-equals-type-clause-key))
+
(c-lang-defconst c-modifier-kwds
"Keywords that can prefix normal declarations of identifiers
\(and typically act as flags). Things like argument declarations
@@ -2443,7 +2527,11 @@ regexp if `c-colon-type-list-kwds' isn't nil."
;; before the ":" that starts the inherit list after "class"
;; or "struct" in C++. (Also used as default for other
;; languages.)
- "[^][{}();,/#=:]*:"))
+ (if (c-lang-const c-opt-identifier-concat-key)
+ (concat "\\([^][{}();,/#=:]\\|"
+ (c-lang-const c-opt-identifier-concat-key)
+ "\\)*:")
+ "[^][{}();,/#=:]*:")))
(c-lang-defvar c-colon-type-list-re (c-lang-const c-colon-type-list-re))
(c-lang-defconst c-paren-nontype-kwds
@@ -2569,6 +2657,17 @@ Keywords here should also be in `c-block-stmt-1-kwds'."
(c-lang-const c-block-stmt-2-kwds))
:test 'string-equal))
+(c-lang-defconst c-block-stmt-hangon-kwds
+ "Keywords which may directly follow a member of `c-block-stmt-1/2-kwds'."
+ t nil
+ c++ '("constexpr"))
+
+(c-lang-defconst c-block-stmt-hangon-key
+ ;; Regexp matching a "hangon" keyword in a `c-block-stmt-1/2-kwds'
+ ;; construct.
+ t (c-make-keywords-re t (c-lang-const c-block-stmt-hangon-kwds)))
+(c-lang-defvar c-block-stmt-hangon-key (c-lang-const c-block-stmt-hangon-key))
+
(c-lang-defconst c-opt-block-stmt-key
;; Regexp matching the start of any statement that has a
;; substatement (except a bare block). Nil in languages that
@@ -2972,7 +3071,7 @@ Note that Java specific rules are currently applied to tell this from
"Regexp matching a keyword that is followed by a colon, where
the whole construct can precede a declaration.
E.g. \"public:\" in C++."
- t "\\<\\>"
+ t "a\\`" ; Doesn't match anything.
c++ (c-make-keywords-re t (c-lang-const c-protection-kwds)))
(c-lang-defvar c-decl-start-colon-kwd-re
(c-lang-const c-decl-start-colon-kwd-re))
@@ -3153,7 +3252,7 @@ Identifier syntax is in effect when this is matched \(see
t (if (c-lang-const c-type-modifier-kwds)
(concat (regexp-opt (c-lang-const c-type-modifier-kwds) t) "\\>")
;; Default to a regexp that never matches.
- "\\<\\>")
+ "a\\`")
;; Check that there's no "=" afterwards to avoid matching tokens
;; like "*=".
(c objc) (concat "\\("
@@ -3167,7 +3266,7 @@ Identifier syntax is in effect when this is matched \(see
"\\|"
"\\.\\.\\."
"\\|"
- "[*(&]"
+ "[*(&~]"
"\\|"
(c-lang-const c-type-decl-prefix-key)
"\\|"
@@ -3191,7 +3290,7 @@ that might precede the identifier in a declaration, e.g. the
as the end of the operator. Identifier syntax is in effect when
this is matched \(see `c-identifier-syntax-table')."
t ;; Default to a regexp that never matches.
- "\\<\\>"
+ "a\\`"
;; Check that there's no "=" afterwards to avoid matching tokens
;; like "*=".
(c objc) (concat "\\(\\*\\)"
@@ -3350,7 +3449,7 @@ list."
(c-lang-defconst c-pre-id-bracelist-key
"A regexp matching tokens which, preceding an identifier, signify a bracelist.
"
- t "\\<\\>"
+ t "a\\`" ; Doesn't match anything.
c++ "new\\([^[:alnum:]_$]\\|$\\)\\|&&?\\(\\S.\\|$\\)")
(c-lang-defvar c-pre-id-bracelist-key (c-lang-const c-pre-id-bracelist-key))
@@ -3406,7 +3505,7 @@ the invalidity of the putative template construct."
;; before the '{' of the enum list, to avoid searching too far.
"[^][{};/#=]*"
"{")
- "\\<\\>"))
+ "a\\`")) ; Doesn't match anything.
(c-lang-defvar c-enum-clause-introduction-re
(c-lang-const c-enum-clause-introduction-re))
@@ -3522,7 +3621,7 @@ i.e. before \":\". Only used if `c-recognize-colon-labels' is set."
"Regexp matching things that can't occur two symbols before a colon in
a label construct. This catches C++'s inheritance construct \"class foo
: bar\". Only used if `c-recognize-colon-labels' is set."
- t "\\<\\>" ; matches nothing
+ t "a\\`" ; Doesn't match anything.
c++ (c-make-keywords-re t '("class")))
(c-lang-defvar c-nonlabel-token-2-key (c-lang-const c-nonlabel-token-2-key))
diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el
index 5283cfea6eb..49268c4482e 100644
--- a/lisp/progmodes/cc-mode.el
+++ b/lisp/progmodes/cc-mode.el
@@ -11,6 +11,8 @@
;; Maintainer: bug-cc-mode@gnu.org
;; Created: a long, long, time ago. adapted from the original c-mode.el
;; Keywords: c languages
+;; The version header below is used for ELPA packaging.
+;; Version: 5.33.1
;; This file is part of GNU Emacs.
@@ -499,9 +501,10 @@ preferably use the `c-mode-menu' language constant directly."
;; `basic-save-buffer' does (insert ?\n) when `require-final-newline' is
;; non-nil; (ii) to detect when Emacs fails to invoke
;; `before-change-functions'. This can happen when reverting a buffer - see
-;; bug #24094. It seems these failures happen only in GNU Emacs; XEmacs
-;; seems to maintain the strict alternation of calls to
-;; `before-change-functions' and `after-change-functions'.
+;; bug #24094. It seems these failures happen only in GNU Emacs; XEmacs seems
+;; to maintain the strict alternation of calls to `before-change-functions'
+;; and `after-change-functions'. Note that this variable is not set when
+;; `c-before-change' is invoked by a change to text properties.
(defun c-basic-common-init (mode default-style)
"Do the necessary initialization for the syntax handling routines
@@ -563,7 +566,7 @@ that requires a literal mode spec at compile time."
(when (or c-recognize-<>-arglists
(c-major-mode-is 'awk-mode)
- (c-major-mode-is '(java-mode c-mode c++-mode objc-mode)))
+ (c-major-mode-is '(java-mode c-mode c++-mode objc-mode pike-mode)))
;; We'll use the syntax-table text property to change the syntax
;; of some chars for this language, so do the necessary setup for
;; that.
@@ -675,14 +678,12 @@ that requires a literal mode spec at compile time."
(make-variable-buffer-local 'c-new-BEG)
(defvar c-new-END 0)
(make-variable-buffer-local 'c-new-END)
-;; The following two variables record the values of `c-new-BEG' and
-;; `c-new-END' just after `c-new-END' has been adjusted for the length of text
-;; inserted or removed. They may be read by any after-change function (but
-;; should not be altered by one).
-(defvar c-old-BEG 0)
-(make-variable-buffer-local 'c-old-BEG)
-(defvar c-old-END 0)
-(make-variable-buffer-local 'c-old-END)
+
+;; Buffer local variable which notes the value of calling `c-in-literal' just
+;; before a change. It is one of 'string, 'c, 'c++ (for the two sorts of
+;; comments), or nil.
+(defvar c-old-END-literality nil)
+(make-variable-buffer-local 'c-old-END-literality)
(defun c-common-init (&optional mode)
"Common initialization for all CC Mode modes.
@@ -897,7 +898,8 @@ Note that the style variables are always made local to the buffer."
(defun c-depropertize-CPP (beg end)
;; Remove the punctuation syntax-table text property from the CPP parts of
- ;; (c-new-BEG c-new-END).
+ ;; (c-new-BEG c-new-END), and remove all syntax-table properties from any
+ ;; raw strings within these CPP parts.
;;
;; This function is in the C/C++/ObjC values of
;; `c-get-state-before-change-functions' and is called exclusively as a
@@ -909,6 +911,7 @@ Note that the style variables are always made local to the buffer."
(goto-char (match-beginning 1))
(setq m-beg (point))
(c-end-of-macro)
+ (save-excursion (c-depropertize-raw-strings-in-region m-beg (point)))
(c-clear-char-property-with-value m-beg (point) 'syntax-table '(1)))
(while (and (< (point) end)
@@ -917,14 +920,16 @@ Note that the style variables are always made local to the buffer."
(goto-char (match-beginning 1))
(setq m-beg (point))
(c-end-of-macro))
- (if (and ss-found (> (point) end))
- (c-clear-char-property-with-value m-beg (point) 'syntax-table '(1)))
+ (when (and ss-found (> (point) end))
+ (save-excursion (c-depropertize-raw-strings-in-region m-beg (point)))
+ (c-clear-char-property-with-value m-beg (point) 'syntax-table '(1)))
(while (and (< (point) c-new-END)
(search-forward-regexp c-anchored-cpp-prefix c-new-END 'bound))
(goto-char (match-beginning 1))
(setq m-beg (point))
(c-end-of-macro)
+ (save-excursion (c-depropertize-raw-strings-in-region m-beg (point)))
(c-clear-char-property-with-value
m-beg (point) 'syntax-table '(1)))))
@@ -996,9 +1001,9 @@ Note that the style variables are always made local to the buffer."
;; characters, ones which would interact syntactically with stuff outside
;; this region.
;;
- ;; These are unmatched string delimiters, or unmatched
- ;; parens/brackets/braces. An unclosed comment is regarded as valid, NOT
- ;; obtrusive.
+ ;; These are unmatched parens/brackets/braces. An unclosed comment is
+ ;; regarded as valid, NOT obtrusive. Unbalanced strings are handled
+ ;; elsewhere.
(save-excursion
(let (s)
(while
@@ -1008,9 +1013,11 @@ Note that the style variables are always made local to the buffer."
((< (nth 0 s) 0) ; found an unmated ),},]
(c-put-char-property (1- (point)) 'syntax-table '(1))
t)
- ((nth 3 s) ; In a string
- (c-put-char-property (nth 8 s) 'syntax-table '(1))
- t)
+ ;; Unbalanced strings are now handled by
+ ;; `c-before-change-check-unbalanced-strings', etc.
+ ;; ((nth 3 s) ; In a string
+ ;; (c-put-char-property (nth 8 s) 'syntax-table '(1))
+ ;; t)
((> (nth 0 s) 0) ; In a (,{,[
(c-put-char-property (nth 1 s) 'syntax-table '(1))
t)
@@ -1070,6 +1077,312 @@ Note that the style variables are always made local to the buffer."
(forward-line)) ; no infinite loop with, e.g., "#//"
)))))
+(defun c-unescaped-nls-in-string-p (&optional quote-pos)
+ ;; Return whether unescaped newlines can be inside strings.
+ ;;
+ ;; QUOTE-POS, if present, is the position of the opening quote of a string.
+ ;; Depending on the language, there might be a special character before it
+ ;; signifying the validity of such NLs.
+ (cond
+ ((null c-multiline-string-start-char) nil)
+ ((c-characterp c-multiline-string-start-char)
+ (and quote-pos
+ (eq (char-before quote-pos) c-multiline-string-start-char)))
+ (t t)))
+
+(defun c-multiline-string-start-is-being-detached (end)
+ ;; If (e.g.), the # character in Pike is being detached from the string
+ ;; opener it applies to, return t. Else return nil. END is the argument
+ ;; supplied to every before-change function.
+ (and (memq (char-after end) c-string-delims)
+ (c-characterp c-multiline-string-start-char)
+ (eq (char-before end) c-multiline-string-start-char)))
+
+(defun c-pps-to-string-delim (end)
+ ;; parse-partial-sexp forward to the next string quote, which is deemed to
+ ;; be a closing quote. Return nil.
+ ;;
+ ;; We remove string-fence syntax-table text properties from characters we
+ ;; pass over.
+ (let* ((start (point))
+ (no-st-s `(0 nil nil ?\" nil nil 0 nil ,start nil nil))
+ (st-s `(0 nil nil t nil nil 0 nil ,start nil nil))
+ no-st-pos st-pos
+ )
+ (parse-partial-sexp start end nil nil no-st-s 'syntax-table)
+ (setq no-st-pos (point))
+ (goto-char start)
+ (while (progn
+ (parse-partial-sexp (point) end nil nil st-s 'syntax-table)
+ (unless (bobp)
+ (c-clear-char-property (1- (point)) 'syntax-table))
+ (setq st-pos (point))
+ (and (< (point) end)
+ (not (eq (char-before) ?\")))))
+ (goto-char (min no-st-pos st-pos))
+ nil))
+
+(defun c-multiline-string-check-final-quote ()
+ ;; Check that the final quote in the buffer is correctly marked or not with
+ ;; a string-fence syntax-table text propery. The return value has no
+ ;; significance.
+ (let (pos-ll pos-lt)
+ (save-excursion
+ (goto-char (point-max))
+ (skip-chars-backward "^\"")
+ (while
+ (and
+ (not (bobp))
+ (cond
+ ((progn
+ (setq pos-ll (c-literal-limits)
+ pos-lt (c-literal-type pos-ll))
+ (memq pos-lt '(c c++)))
+ ;; In a comment.
+ (goto-char (car pos-ll)))
+ ((save-excursion
+ (backward-char) ; over "
+ (eq (logand (skip-chars-backward "\\\\") 1) 1))
+ ;; At an escaped string.
+ (backward-char)
+ t)
+ (t
+ ;; At a significant "
+ (c-clear-char-property (1- (point)) 'syntax-table)
+ (setq pos-ll (c-literal-limits)
+ pos-lt (c-literal-type pos-ll))
+ nil)))
+ (skip-chars-backward "^\""))
+ (cond
+ ((bobp))
+ ((eq pos-lt 'string)
+ (c-put-char-property (1- (point)) 'syntax-table '(15)))
+ (t nil)))))
+
+(defvar c-bc-changed-stringiness nil)
+;; Non-nil when, in a before-change function, the deletion of a range of text
+;; will change the "stringiness" of the subsequent text. Only used when
+;; `c-multiline-sting-start-char' is a non-nil value which isn't a character.
+
+(defun c-before-change-check-unbalanced-strings (beg end)
+ ;; If BEG or END is inside an unbalanced string, remove the syntax-table
+ ;; text property from respectively the start or end of the string. Also
+ ;; extend the region (c-new-BEG c-new-END) as necessary to cope with the
+ ;; coming change involving the insertion or deletion of an odd number of
+ ;; quotes.
+ ;;
+ ;; POINT is undefined both at entry to and exit from this function, the
+ ;; buffer will have been widened, and match data will have been saved.
+ ;;
+ ;; This function is called exclusively as a before-change function via
+ ;; `c-get-state-before-change-functions'.
+ (c-save-buffer-state
+ ((end-limits
+ (progn
+ (goto-char (if (c-multiline-string-start-is-being-detached end)
+ (1+ end)
+ end))
+ (c-literal-limits)))
+ (end-literal-type (and end-limits
+ (c-literal-type end-limits)))
+ (beg-limits
+ (progn
+ (goto-char beg)
+ (c-literal-limits)))
+ (beg-literal-type (and beg-limits
+ (c-literal-type beg-limits))))
+
+ (when (eq end-literal-type 'string)
+ (setq c-new-END (max c-new-END (cdr end-limits))))
+ ;; It is possible the buffer change will include inserting a string quote.
+ ;; This could have the effect of flipping the meaning of any following
+ ;; quotes up until the next unescaped EOL. Also guard against the change
+ ;; being the insertion of \ before an EOL, escaping it.
+ (cond
+ ((c-characterp c-multiline-string-start-char)
+ ;; The text about to be inserted might contain a multiline string
+ ;; opener. Set c-new-END after anything which might be affected.
+ ;; Go to the end of the putative multiline string.
+ (goto-char end)
+ (c-pps-to-string-delim (point-max))
+ (when (< (point) (point-max))
+ (while
+ (and
+ (progn
+ (while
+ (and
+ (c-syntactic-re-search-forward
+ (if c-single-quotes-quote-strings
+ "[\"']\\|\\s|"
+ "\"\\|\\s|")
+ (point-max) t t)
+ (progn
+ (c-clear-char-property (1- (point)) 'syntax-table)
+ (c-truncate-semi-nonlit-pos-cache (1- (point)))
+ (not (memq (char-before) c-string-delims)))))
+ (memq (char-before) c-string-delims))
+ (progn
+ (c-pps-to-string-delim (point-max))
+ (< (point) (point-max))))))
+ (setq c-new-END (max (point) c-new-END)))
+
+ (c-multiline-string-start-char
+ (setq c-bc-changed-stringiness
+ (not (eq (eq end-literal-type 'string)
+ (eq beg-literal-type 'string))))
+ ;; Deal with deletion of backslashes before "s.
+ (goto-char end)
+ (if (and (looking-at (if c-single-quotes-quote-strings
+ "\\\\*[\"']"
+ "\\\\*\""))
+ (eq (logand (skip-chars-backward "\\\\" beg) 1) 1))
+ (setq c-bc-changed-stringiness (not c-bc-changed-stringiness)))
+ (if (eq beg-literal-type 'string)
+ (setq c-new-BEG (min (car beg-limits) c-new-BEG))))
+
+ ((< end (point-max))
+ (goto-char (1+ end)) ; might be a newline.
+ ;; In the following regexp, the initial \n caters for a newline getting
+ ;; joined to a preceding \ by the removal of what comes between.
+ (re-search-forward "[\n\r]?\\(\\\\\\(.\\|\n\\|\r\\)\\|[^\\\n\r]\\)*"
+ nil t)
+ ;; We're at an EOLL or point-max.
+ (setq c-new-END (max c-new-END (min (1+ (point)) (point-max))))
+ (if (equal (c-get-char-property (point) 'syntax-table) '(15))
+ (if (memq (char-after) '(?\n ?\r))
+ ;; Normally terminated invalid string.
+ (let ((eoll-1 (point)))
+ (forward-char)
+ (backward-sexp)
+ (c-clear-char-property eoll-1 'syntax-table)
+ (c-clear-char-property (point) 'syntax-table)
+ (c-truncate-semi-nonlit-pos-cache (point)))
+ ;; Opening " at EOB.
+ (c-clear-char-property (1- (point)) 'syntax-table))
+ (when (and (c-search-backward-char-property 'syntax-table '(15) c-new-BEG)
+ (memq (char-after) c-string-delims)) ; Ignore an unterminated raw string's (.
+ ;; Opening " on last line of text (without EOL).
+ (c-clear-char-property (point) 'syntax-table)
+ (c-truncate-semi-nonlit-pos-cache (point)))))
+
+ (t (goto-char end) ; point-max
+ (when
+ (and
+ (c-search-backward-char-property 'syntax-table '(15) c-new-BEG)
+ (memq (char-after) c-string-delims))
+ (c-clear-char-property (point) 'syntax-table)
+ (c-truncate-semi-nonlit-pos-cache (point)))))
+
+ (unless (and c-multiline-string-start-char
+ (not (c-characterp c-multiline-string-start-char)))
+ (when (and (eq end-literal-type 'string)
+ (not (eq (char-before (cdr end-limits)) ?\()))
+ (c-clear-char-property (1- (cdr end-limits)) 'syntax-table)
+ (c-truncate-semi-nonlit-pos-cache (1- (cdr end-limits))))
+
+ (when (and (eq beg-literal-type 'string)
+ (memq (char-after (car beg-limits)) c-string-delims))
+ (setq c-new-BEG (min c-new-BEG (car beg-limits)))
+ (c-clear-char-property (car beg-limits) 'syntax-table)
+ (c-truncate-semi-nonlit-pos-cache (car beg-limits))))))
+
+(defun c-after-change-mark-abnormal-strings (beg end _old-len)
+ ;; Mark any unbalanced strings in the region (c-new-BEG c-new-END) with
+ ;; string fence syntax-table text properties.
+ ;;
+ ;; POINT is undefined both at entry to and exit from this function, the
+ ;; buffer will have been widened, and match data will have been saved.
+ ;;
+ ;; This function is called exclusively as an after-change function via
+ ;; `c-before-font-lock-functions'.
+ (if (and c-multiline-string-start-char
+ (not (c-characterp c-multiline-string-start-char)))
+ ;; Only the last " might need to be marked.
+ (c-save-buffer-state
+ ((beg-literal-limits
+ (progn (goto-char beg) (c-literal-limits)))
+ (beg-literal-type (c-literal-type beg-literal-limits))
+ end-literal-limits end-literal-type)
+ (when (and (eq beg-literal-type 'string)
+ (c-get-char-property (car beg-literal-limits) 'syntax-table))
+ (c-clear-char-property (car beg-literal-limits) 'syntax-table)
+ (setq c-bc-changed-stringiness (not c-bc-changed-stringiness)))
+ (setq end-literal-limits (progn (goto-char end) (c-literal-limits))
+ end-literal-type (c-literal-type end-literal-limits))
+ ;; Deal with the insertion of backslashes before a ".
+ (goto-char end)
+ (if (and (looking-at "\\\\*\"")
+ (eq (logand (skip-chars-backward "\\\\" beg) 1) 1))
+ (setq c-bc-changed-stringiness (not c-bc-changed-stringiness)))
+ (when (eq (eq (eq beg-literal-type 'string)
+ (eq end-literal-type 'string))
+ c-bc-changed-stringiness)
+ (c-multiline-string-check-final-quote)))
+ ;; There could be several "s needing marking.
+ (c-save-buffer-state
+ ((cll (progn (goto-char c-new-BEG)
+ (c-literal-limits)))
+ (beg-literal-type (and cll (c-literal-type cll)))
+ (beg-limits
+ (cond
+ ((and (eq beg-literal-type 'string)
+ (c-unescaped-nls-in-string-p (car cll)))
+ (cons
+ (car cll)
+ (progn
+ (goto-char (1+ (car cll)))
+ (search-forward-regexp
+ (cdr (assq (char-after (car cll)) c-string-innards-re-alist))
+ nil t)
+ (min (1+ (point)) (point-max)))))
+ ((and (null beg-literal-type)
+ (goto-char beg)
+ (and (not (bobp))
+ (eq (char-before) c-multiline-string-start-char))
+ (memq (char-after) c-string-delims))
+ (cons (point)
+ (progn
+ (forward-char)
+ (search-forward-regexp
+ (cdr (assq (char-before) c-string-innards-re-alist)) nil t)
+ (1+ (point)))))
+ (cll)))
+ s)
+ (goto-char
+ (cond ((null beg-literal-type)
+ c-new-BEG)
+ ((eq beg-literal-type 'string)
+ (car beg-limits))
+ (t ; comment
+ (cdr beg-limits))))
+ (while
+ (and
+ (< (point) c-new-END)
+ (progn
+ ;; Skip over any comments before the next string.
+ (while (progn
+ (setq s (parse-partial-sexp (point) c-new-END nil
+ nil s 'syntax-table))
+ (and (< (point) c-new-END)
+ (or (not (nth 3 s))
+ (not (memq (char-before) c-string-delims))))))
+ ;; We're at the start of a string.
+ (memq (char-before) c-string-delims)))
+ (unless (and (c-major-mode-is 'c++-mode)
+ (c-maybe-re-mark-raw-string))
+ (if (c-unescaped-nls-in-string-p (1- (point)))
+ (looking-at "\\(\\\\\\(.\\|\n\\|\r\\)\\|[^\"]\\)*")
+ (looking-at (cdr (assq (char-before) c-string-innards-re-alist))))
+ (cond
+ ((memq (char-after (match-end 0)) '(?\n ?\r))
+ (c-put-char-property (1- (point)) 'syntax-table '(15))
+ (c-put-char-property (match-end 0) 'syntax-table '(15)))
+ ((or (eq (match-end 0) (point-max))
+ (eq (char-after (match-end 0)) ?\\)) ; \ at EOB
+ (c-put-char-property (1- (point)) 'syntax-table '(15))))
+ (goto-char (min (1+ (match-end 0)) (point-max))))
+ (setq s nil)))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Parsing of quotes.
;;
@@ -1172,7 +1485,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
(goto-char (match-beginning 0))
(save-excursion (search-forward "'" (match-end 0) t)))))))))
-(defun c-parse-quotes-before-change (beg end)
+(defun c-parse-quotes-before-change (_beg _end)
;; This function analyzes 's near the region (c-new-BEG c-new-END), amending
;; those two variables as needed to include 's into that region when they
;; might be syntactically relevant to the change in progress.
@@ -1184,7 +1497,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
;;
;; This function is called exclusively as a before-change function via the
;; variable `c-get-state-before-change-functions'.
- (c-save-buffer-state ()
+ (c-save-buffer-state (case-fold-search)
(goto-char c-new-BEG)
;; We need to scan for 's from the BO (logical) line.
(beginning-of-line)
@@ -1200,13 +1513,13 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
((c-quoted-number-head-before-point)
(if (>= (point) c-new-BEG)
(setq c-new-BEG (match-beginning 0))))
- ((looking-at "\\([^'\\]\\|\\\\.\\)'")
+ ((looking-at
+ "\\([^'\\]\\|\\\\\\([0-7]\\{1,3\\}\\|[xuU][0-9a-fA-F]+\\|.\\)\\)'")
(goto-char (match-end 0))
(if (> (match-end 0) c-new-BEG)
(setq c-new-BEG (1- (match-beginning 0)))))
- ((or (>= (point) (1- c-new-BEG))
- (and (eq (point) (- c-new-BEG 2))
- (eq (char-after) ?\\)))
+ ((save-excursion
+ (not (search-forward "'" c-new-BEG t)))
(setq c-new-BEG (1- (point))))
(t nil)))
@@ -1226,19 +1539,26 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
(goto-char (match-end 0))
(if (> (match-end 0) c-new-END)
(setq c-new-END (match-end 0))))
- ((looking-at "\\([^'\\]\\|\\\\.\\)'")
+ ((looking-at
+ "\\([^'\\]\\|\\\\\\([0-7]\\{1,3\\}\\|[xuU][0-9a-fA-F]+\\|.\\)\\)'")
(goto-char (match-end 0))
(if (> (match-end 0) c-new-END)
(setq c-new-END (match-end 0))))
+ ((equal (c-get-char-property (1- (point)) 'syntax-table) '(1))
+ (when (c-search-forward-char-property-with-value-on-char
+ 'syntax-table '(1) ?\' (c-point 'eoll))
+ (setq c-new-END (max (point) c-new-END))))
(t nil)))
;; Having reached c-new-END, handle any 's after it whose context may be
- ;; changed by the current buffer change.
+ ;; changed by the current buffer change. The idea is to catch
+ ;; monstrosities like ',',',',',' changing "polarity".
(goto-char c-new-END)
(cond
((c-quoted-number-tail-after-point)
(setq c-new-END (match-end 0)))
((looking-at
- "\\(\\\\.\\|.\\)?\\('\\([^'\\]\\|\\\\.\\)\\)*'")
+ "\\(\\\\\\([0-7]\\{1,3\\}\\|[xuU][0-9a-fA-F]+\\|.\\)\\|.\\)?\
+\\('\\([^'\\]\\|\\\\\\([0-7]\\{1,3\\}\\|[xuU][0-9a-fA-F]+\\|.\\)\\)\\)*'")
(setq c-new-END (match-end 0))))
;; Remove the '(1) syntax-table property from any "'"s within (c-new-BEG
@@ -1259,7 +1579,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
'c-digit-separator t
?')))))
-(defun c-parse-quotes-after-change (beg end old-len)
+(defun c-parse-quotes-after-change (_beg _end _old-len)
;; This function applies syntax-table properties (value '(1)) and
;; c-digit-separator properties as needed to 's within the range (c-new-BEG
;; c-new-END). This operation is performed even within strings and
@@ -1267,7 +1587,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
;;
;; This function is called exclusively as an after-change function via the
;; variable `c-before-font-lock-functions'.
- (c-save-buffer-state (num-beg num-end)
+ (c-save-buffer-state (num-beg num-end case-fold-search)
;; Apply the needed syntax-table and c-digit-separator text properties to
;; quotes.
(save-restriction
@@ -1289,7 +1609,9 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
(c-put-char-properties-on-char num-beg num-end
'c-digit-separator t ?')
(goto-char num-end))
- ((looking-at "\\([^\\']\\|\\\\.\\)'") ; balanced quoted expression.
+ ((looking-at
+ "\\([^\\']\\|\\\\\\([0-7]\\{1,3\\}\\|[xuU][0-9a-fA-F]+\\|.\\)\
+\\)'") ; balanced quoted expression.
(goto-char (match-end 0)))
(t
(c-invalidate-state-cache (1- (point)))
@@ -1332,7 +1654,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
;; Are we coalescing two tokens together, e.g. "fo o" -> "foo"?
(when (< beg end)
(c-unfind-coalesced-tokens beg end))
- (c-invalidate-sws-region-before end)
+ (c-invalidate-sws-region-before beg end)
;; Are we (potentially) disrupting the syntactic context which
;; makes a type a type? E.g. by inserting stuff after "foo" in
;; "foo bar;", or before "foo" in "typedef foo *bar;"?
@@ -1418,7 +1740,8 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
;; without an intervening call to `before-change-functions' when reverting
;; the buffer (see bug #24094). Whatever the cause, assume that the entire
;; buffer has changed.
- (when (not c-just-done-before-change)
+ (when (and (not c-just-done-before-change)
+ (not (c-called-from-text-property-change-p)))
(save-restriction
(widen)
(c-before-change (point-min) (point-max))
@@ -1429,7 +1752,6 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
;; (c-new-BEG c-new-END) will be the region to fontify. It may become
;; larger than (beg end).
(setq c-new-END (- (+ c-new-END (- end beg)) old-len))
- (setq c-old-BEG c-new-BEG c-old-END c-new-END)
(unless (c-called-from-text-property-change-p)
(setq c-just-done-before-change nil)
@@ -1511,7 +1833,16 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
;; Go to a less nested declaration each time round this loop.
(and
(setq old-pos (point))
- (c-syntactic-skip-backward "^;{}" bod-lim t)
+ (let (pseudo)
+ (while
+ (progn
+ (c-syntactic-skip-backward "^;{}" bod-lim t)
+ (and (eq (char-before) ?})
+ (save-excursion
+ (backward-char)
+ (setq pseudo (c-cheap-inside-bracelist-p (c-parse-state))))))
+ (goto-char pseudo))
+ t)
(> (point) bod-lim)
(progn (c-forward-syntactic-ws)
;; Have we got stuck in a comment at EOB?
@@ -1835,6 +2166,7 @@ Key bindings:
(c-common-init 'c-mode)
(easy-menu-add c-c-menu)
(cc-imenu-init cc-imenu-c-generic-expression)
+ (add-hook 'flymake-diagnostic-functions 'flymake-cc nil t)
(c-run-mode-hooks 'c-mode-common-hook))
(defconst c-or-c++-mode--regexp
@@ -1922,6 +2254,7 @@ Key bindings:
(c-common-init 'c++-mode)
(easy-menu-add c-c++-menu)
(cc-imenu-init cc-imenu-c++-generic-expression)
+ (add-hook 'flymake-diagnostic-functions 'flymake-cc nil t)
(c-run-mode-hooks 'c-mode-common-hook))
@@ -2000,7 +2333,7 @@ Key bindings:
;; since it's practically impossible to write a regexp that reliably
;; matches such a construct. Other tools are necessary.
(defconst c-Java-defun-prompt-regexp
- "^[ \t]*\\(\\(\\(public\\|protected\\|private\\|const\\|abstract\\|synchronized\\|final\\|static\\|threadsafe\\|transient\\|native\\|volatile\\)\\s-+\\)*\\(\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*[][_$.a-zA-Z0-9]+\\|[[a-zA-Z]\\)\\s-*\\)\\s-+\\)\\)?\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*\\s-+\\)\\s-*\\)?\\([_a-zA-Z][^][ \t:;.,{}()=]*\\|\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)\\)\\s-*\\(([^);{}]*)\\)?\\([] \t]*\\)\\(\\s-*\\<throws\\>\\s-*\\(\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)[, \t\n\r\f\v]*\\)+\\)?\\s-*")
+ "^[ \t]*\\(\\(\\(public\\|protected\\|private\\|const\\|abstract\\|synchronized\\|final\\|static\\|threadsafe\\|transient\\|native\\|volatile\\)\\s-+\\)*\\(\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*[][_$.a-zA-Z0-9]+\\|[[a-zA-Z]\\)\\s-*\\)\\s-+\\)\\)?\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*\\s-+\\)\\s-*\\)?\\([_a-zA-Z][^][ \t:;.,{}()\^?=]*\\|\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)\\)\\s-*\\(([^);{}]*)\\)?\\([] \t]*\\)\\(\\s-*\\<throws\\>\\s-*\\(\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)[, \t\n\r\f\v]*\\)+\\)?\\s-*")
(easy-menu-define c-java-menu java-mode-map "Java Mode Commands"
(cons "Java" (c-lang-const c-mode-menu java)))
diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el
index d2c41008711..92ea67128f4 100644
--- a/lisp/progmodes/cc-styles.el
+++ b/lisp/progmodes/cc-styles.el
@@ -68,7 +68,9 @@
(arglist-close . c-lineup-arglist)
(inline-open . 0)
(brace-list-open . +)
- (brace-list-intro . c-lineup-arglist-intro-after-paren)
+ (brace-list-intro . (first
+ c-lineup-2nd-brace-entry-in-arglist
+ c-lineup-class-decl-init-+ +))
(topmost-intro-cont
. (first c-lineup-topmost-intro-cont
c-lineup-gnu-DEFUN-intro-cont))))
@@ -95,6 +97,9 @@
(label . 0)
(statement-cont . +)
(inline-open . 0)
+ (brace-list-intro . (first
+ c-lineup-2nd-brace-entry-in-arglist
+ c-lineup-class-decl-init-+ +))
(inexpr-class . 0))))
("stroustrup"
@@ -104,6 +109,9 @@
(substatement-open . 0)
(substatement-label . 0)
(label . 0)
+ (brace-list-intro . (first
+ c-lineup-2nd-brace-entry-in-arglist
+ c-lineup-class-decl-init-+ +))
(statement-cont . +))))
("whitesmith"
@@ -194,6 +202,9 @@
(c-offsets-alist . ((substatement-open . 0)
(inextern-lang . 0)
(arglist-intro . +)
+ (brace-list-intro . (first
+ c-lineup-2nd-brace-entry-in-arglist
+ c-lineup-class-decl-init-+ +))
(knr-argdecl-intro . +)))
(c-hanging-braces-alist . ((brace-list-open)
(brace-list-intro)
@@ -219,6 +230,9 @@
(statement-cont . +)
(arglist-intro . c-lineup-arglist-intro-after-paren)
(arglist-close . c-lineup-arglist)
+ (brace-list-intro . (first
+ c-lineup-2nd-brace-entry-in-arglist
+ c-lineup-class-decl-init-+ +))
(access-label . 0)
(inher-cont . c-lineup-java-inher)
(func-decl-cont . c-lineup-java-throws))))
diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el
index 30475d0ba60..6e8acd4c0dd 100644
--- a/lisp/progmodes/cc-vars.el
+++ b/lisp/progmodes/cc-vars.el
@@ -1115,7 +1115,7 @@ can always override the use of `c-default-style' by making calls to
;; Anchor pos: At the brace list decl start(*).
(brace-list-intro . +)
;; Anchor pos: At the brace list decl start(*).
- (brace-list-entry . c-lineup-under-anchor)
+ (brace-list-entry . 0)
;; Anchor pos: At the first non-ws char after the open paren if
;; the first token is on the same line, otherwise boi at that
;; token.
@@ -1647,8 +1647,11 @@ white space either before or after the operator, but not both."
:type 'boolean
:group 'c)
-(defvar c-noise-macro-with-parens-name-re "\\<\\>")
-(defvar c-noise-macro-name-re "\\<\\>")
+;; Initialize the next two to a regexp which never matches.
+(defvar c-noise-macro-with-parens-name-re "a\\`")
+(make-variable-buffer-local 'c-noise-macro-with-parens-name-re)
+(defvar c-noise-macro-name-re "a\\`")
+(make-variable-buffer-local 'c-noise-macro-name-re)
(defcustom c-noise-macro-names nil
"A list of names of macros which expand to nothing, or compiler extensions
@@ -1663,6 +1666,7 @@ this implicitly by reinitializing C/C++/Objc Mode on any buffer)."
:type '(repeat :tag "List of names" string)
:group 'c)
(put 'c-noise-macro-names 'safe-local-variable #'c-string-list-p)
+(make-variable-buffer-local 'c-noise-macro-names)
(defcustom c-noise-macro-with-parens-names nil
"A list of names of macros \(or compiler extensions like \"__attribute__\")
@@ -1672,12 +1676,13 @@ These are recognized by CC Mode only in declarations."
:type '(repeat :tag "List of names (possibly empty)" string)
:group 'c)
(put 'c-noise-macro-with-parens-names 'safe-local-variable #'c-string-list-p)
+(make-variable-buffer-local 'c-noise-macro-with-parens-names)
(defun c-make-noise-macro-regexps ()
;; Convert `c-noise-macro-names' and `c-noise-macro-with-parens-names' into
;; `c-noise-macro-name-re' and `c-noise-macro-with-parens-name-re'.
(setq c-noise-macro-with-parens-name-re
- (cond ((null c-noise-macro-with-parens-names) "\\<\\>")
+ (cond ((null c-noise-macro-with-parens-names) "a\\`") ; Never matches.
((consp c-noise-macro-with-parens-names)
(concat (regexp-opt c-noise-macro-with-parens-names t)
"\\([^[:alnum:]_$]\\|$\\)"))
@@ -1686,7 +1691,7 @@ These are recognized by CC Mode only in declarations."
(t (error "c-make-noise-macro-regexps: \
c-noise-macro-with-parens-names is invalid: %s" c-noise-macro-with-parens-names))))
(setq c-noise-macro-name-re
- (cond ((null c-noise-macro-names) "\\<\\>")
+ (cond ((null c-noise-macro-names) "a\\`") ; Never matches anything.
((consp c-noise-macro-names)
(concat (regexp-opt c-noise-macro-names t)
"\\([^[:alnum:]_$]\\|$\\)"))
diff --git a/lisp/progmodes/cfengine.el b/lisp/progmodes/cfengine.el
index a86cb53ceb9..efe648bc034 100644
--- a/lisp/progmodes/cfengine.el
+++ b/lisp/progmodes/cfengine.el
@@ -852,8 +852,8 @@ This includes those for cfservd as well as cfagent.")
;; Classes.
("^[ \t]*\\([[:alnum:]_().|!]+\\)::" 1 font-lock-function-name-face)
;; Variables.
- ("$(\\([[:alnum:]_]+\\))" 1 font-lock-variable-name-face)
- ("${\\([[:alnum:]_]+\\)}" 1 font-lock-variable-name-face)
+ ("\\$(\\([[:alnum:]_]+\\))" 1 font-lock-variable-name-face)
+ ("\\${\\([[:alnum:]_]+\\)}" 1 font-lock-variable-name-face)
;; Variable definitions.
("\\_<\\([[:alnum:]_]+\\)[ \t]*=[ \t]*(" 1 font-lock-variable-name-face)
;; File, acl &c in group: { token ... }
diff --git a/lisp/progmodes/cmacexp.el b/lisp/progmodes/cmacexp.el
index 787d8d47a6f..a081c023079 100644
--- a/lisp/progmodes/cmacexp.el
+++ b/lisp/progmodes/cmacexp.el
@@ -383,7 +383,8 @@ Optional arg DISPLAY non-nil means show messages in the echo area."
(not (member (file-name-nondirectory shell-file-name)
msdos-shells)))
(eq exit-status 0))
- (zerop (nth 7 (file-attributes (expand-file-name tempname))))
+ (zerop (file-attribute-size
+ (file-attributes (expand-file-name tempname))))
(progn
(goto-char (point-min))
;; Put the messages inside a comment, so they won't get in
diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el
index 49b79de5851..1a0d9bdbb70 100644
--- a/lisp/progmodes/compile.el
+++ b/lisp/progmodes/compile.el
@@ -43,23 +43,20 @@
;;;###autoload
(defcustom compilation-mode-hook nil
"List of hook functions run by `compilation-mode'."
- :type 'hook
- :group 'compilation)
+ :type 'hook)
;;;###autoload
(defcustom compilation-start-hook nil
"Hook run after starting a new compilation process.
The hook is run with one argument, the new process."
- :type 'hook
- :group 'compilation)
+ :type 'hook)
;;;###autoload
(defcustom compilation-window-height nil
"Number of lines in a compilation window.
If nil, use Emacs default."
:type '(choice (const :tag "Default" nil)
- integer)
- :group 'compilation)
+ integer))
(defvar compilation-filter-hook nil
"Hook run after `compilation-filter' has inserted a string into the buffer.
@@ -80,34 +77,27 @@ If this is buffer-local in the destination buffer, Emacs obeys
that value, otherwise it uses the value in the *compilation*
buffer. This enables a major-mode to specify its own value.")
-(defvar compilation-parse-errors-filename-function nil
+(defvar compilation-parse-errors-filename-function #'identity
"Function to call to post-process filenames while parsing error messages.
It takes one arg FILENAME which is the name of a file as found
-in the compilation output, and should return a transformed file name.")
+in the compilation output, and should return a transformed file name
+or a buffer, the one which was compiled.")
+;; Note: the compilation-parse-errors-filename-function need not save the
+;; match data.
;;;###autoload
-(defvar compilation-process-setup-function nil
+(defvar compilation-process-setup-function #'ignore
"Function to call to customize the compilation process.
This function is called immediately before the compilation process is
started. It can be used to set any variables or functions that are used
while processing the output of the compilation process.")
;;;###autoload
-(defvar compilation-buffer-name-function nil
+(defvar compilation-buffer-name-function #'compilation--default-buffer-name
"Function to compute the name of a compilation buffer.
The function receives one argument, the name of the major mode of the
compilation buffer. It should return a string.
-If nil, compute the name with `(concat \"*\" (downcase major-mode) \"*\")'.")
-
-;;;###autoload
-(defvar compilation-finish-function nil
- "Function to call when a compilation process finishes.
-It is called with two arguments: the compilation buffer, and a string
-describing how the process finished.")
-
-(make-obsolete-variable 'compilation-finish-function
- "use `compilation-finish-functions', but it works a little differently."
- "22.1")
+By default, it returns `(concat \"*\" (downcase name-of-mode) \"*\")'.")
;;;###autoload
(defvar compilation-finish-functions nil
@@ -533,7 +523,7 @@ File = \\(.+\\), Line = \\([0-9]+\\)\\(?:, Column = \\([0-9]+\\)\\)?"
"Alist of values for `compilation-error-regexp-alist'.")
(defcustom compilation-error-regexp-alist
- (mapcar 'car compilation-error-regexp-alist-alist)
+ (mapcar #'car compilation-error-regexp-alist-alist)
"Alist that specifies how to match errors in compiler output.
On GNU and Unix, any string is a valid filename, so these
matchers must make some common sense assumptions, which catch
@@ -560,13 +550,18 @@ FILE can also have the form (FILE FORMAT...), where the FORMATs
\(e.g. \"%s.c\") will be applied in turn to the recognized file
name, until a file of that name is found. Or FILE can also be a
function that returns (FILENAME) or (RELATIVE-FILENAME . DIRNAME).
-In the former case, FILENAME may be relative or absolute.
+In the former case, FILENAME may be relative or absolute, or it may
+be a buffer.
LINE can also be of the form (LINE . END-LINE) meaning a range
of lines. COLUMN can also be of the form (COLUMN . END-COLUMN)
meaning a range of columns starting on LINE and ending on
END-LINE, if that matched.
+LINE, END-LINE, COL, and END-COL can also be functions of no argument
+that return the corresponding line or column number. They can assume REGEXP
+has just been matched, and should correspondingly preserve this match data.
+
TYPE is 2 or nil for a real error or 1 for warning or 0 for info.
TYPE can also be of the form (WARNING . INFO). In that case this
will be equivalent to 1 if the WARNING'th subexpression matched
@@ -587,8 +582,7 @@ listed text properties PROP# are given values VAL# as well."
:type '(repeat (choice (symbol :tag "Predefined symbol")
(sexp :tag "Error specification")))
:link `(file-link :tag "example file"
- ,(expand-file-name "compilation.txt" data-directory))
- :group 'compilation)
+ ,(expand-file-name "compilation.txt" data-directory)))
;;;###autoload(put 'compilation-directory 'safe-local-variable 'stringp)
(defvar compilation-directory nil
@@ -648,7 +642,6 @@ If this is buffer-local in the destination buffer, Emacs obeys
that value, otherwise it uses the value in the *compilation*
buffer. This enables a major-mode to specify its own value."
:type 'boolean
- :group 'compilation
:version "20.4")
(defcustom compilation-read-command t
@@ -659,15 +652,13 @@ Note that changing this to nil may be a security risk, because a
file might define a malicious `compile-command' as a file local
variable, and you might not notice. Therefore, `compile-command'
is considered unsafe if this variable is nil."
- :type 'boolean
- :group 'compilation)
+ :type 'boolean)
;;;###autoload
(defcustom compilation-ask-about-save t
"Non-nil means \\[compile] asks which buffers to save before compiling.
Otherwise, it saves all modified buffers without asking."
- :type 'boolean
- :group 'compilation)
+ :type 'boolean)
(defcustom compilation-save-buffers-predicate nil
"The second argument (PRED) passed to `save-some-buffers' before compiling.
@@ -681,7 +672,6 @@ of `my-compilation-root' here."
(const :tag "Default (save all file-visiting buffers)" nil)
(const :tag "Save all buffers" t)
function)
- :group 'compilation
:version "24.1")
;;;###autoload
@@ -690,8 +680,7 @@ of `my-compilation-root' here."
Elements should be directory names, not file names of directories.
The value nil as an element means to try the default directory."
:type '(repeat (choice (const :tag "Default" nil)
- (string :tag "Directory")))
- :group 'compilation)
+ (string :tag "Directory"))))
;;;###autoload
(defcustom compile-command (purecopy "make -k ")
@@ -711,8 +700,7 @@ You might also use mode hooks to specify it in certain modes, like this:
(file-name-sans-extension buffer-file-name))))))))
It's often useful to leave a space at the end of the value."
- :type 'string
- :group 'compilation)
+ :type 'string)
;;;###autoload(put 'compile-command 'safe-local-variable (lambda (a) (and (stringp a) (or (not (boundp 'compilation-read-command)) compilation-read-command))))
;;;###autoload
@@ -721,7 +709,6 @@ It's often useful to leave a space at the end of the value."
This only affects platforms that support asynchronous processes (see
`start-process'); synchronous compilation processes never accept input."
:type 'boolean
- :group 'compilation
:version "22.1")
;; A weak per-compilation-buffer hash indexed by (FILENAME . DIRECTORY). Each
@@ -734,8 +721,9 @@ This only affects platforms that support asynchronous processes (see
Then every error line will have a debug text property with the matcher that
fit this line and the match data. Use `describe-text-properties'.")
-(defvar compilation-exit-message-function nil "\
-If non-nil, called when a compilation process dies to return a status message.
+(defvar compilation-exit-message-function
+ (lambda (_process-status exit-status msg) (cons msg exit-status))
+ "If non-nil, called when a compilation process dies to return a status message.
This should be a function of three arguments: process status, exit status,
and exit message; it returns a cons (MESSAGE . MODELINE) of the strings to
write into the compilation buffer, and to put in its mode line.")
@@ -747,7 +735,6 @@ This list is temporarily prepended to `process-environment' prior to
starting the compilation process."
:type '(repeat (string :tag "ENVVARNAME=VALUE"))
:options '(("LANG=C"))
- :group 'compilation
:version "24.1")
;; History of compile commands.
@@ -756,19 +743,16 @@ starting the compilation process."
(defface compilation-error
'((t :inherit error))
"Face used to highlight compiler errors."
- :group 'compilation
:version "22.1")
(defface compilation-warning
'((t :inherit warning))
"Face used to highlight compiler warnings."
- :group 'compilation
:version "22.1")
(defface compilation-info
'((t :inherit success))
"Face used to highlight compiler information."
- :group 'compilation
:version "22.1")
;; The next three faces must be able to stand out against the
@@ -780,13 +764,11 @@ starting the compilation process."
(((class color) (min-colors 8)) (:foreground "red"))
(t (:inverse-video t :weight bold)))
"Face for Compilation mode's \"error\" mode line indicator."
- :group 'compilation
:version "24.3")
(defface compilation-mode-line-run
'((t :inherit compilation-warning))
"Face for Compilation mode's \"running\" mode line indicator."
- :group 'compilation
:version "24.3")
(defface compilation-mode-line-exit
@@ -796,19 +778,16 @@ starting the compilation process."
(((class color)) (:foreground "green" :weight bold))
(t (:weight bold)))
"Face for Compilation mode's \"exit\" mode line indicator."
- :group 'compilation
:version "24.3")
(defface compilation-line-number
'((t :inherit font-lock-keyword-face))
"Face for displaying line numbers in compiler messages."
- :group 'compilation
:version "22.1")
(defface compilation-column-number
'((t :inherit font-lock-doc-face))
"Face for displaying column numbers in compiler messages."
- :group 'compilation
:version "22.1")
(defcustom compilation-message-face 'underline
@@ -817,7 +796,6 @@ Faces `compilation-error-face', `compilation-warning-face',
`compilation-info-face', `compilation-line-face' and
`compilation-column-face' get prepended to this, when applicable."
:type 'face
- :group 'compilation
:version "22.1")
(defvar compilation-error-face 'compilation-error
@@ -850,7 +828,6 @@ Faces `compilation-error-face', `compilation-warning-face',
(defcustom compilation-auto-jump-to-first-error nil
"If non-nil, automatically jump to the first error during compilation."
:type 'boolean
- :group 'compilation
:version "23.1")
(defvar compilation-auto-jump-to-next nil
@@ -873,7 +850,6 @@ info, are considered errors."
:type '(choice (const :tag "Skip warnings and info" 2)
(const :tag "Skip info" 1)
(const :tag "No skip" 0))
- :group 'compilation
:version "22.1")
(defun compilation-set-skip-threshold (level)
@@ -897,7 +873,6 @@ Visited messages are ones for which the file, line and column have been jumped
to from the current content in the current compilation buffer, even if it was
from a different message."
:type 'boolean
- :group 'compilation
:version "22.1")
(defun compilation-type (type)
@@ -954,10 +929,11 @@ from a different message."
;; FILE-STRUCTURE is a list of
;; ((FILENAME DIRECTORY) FORMATS (LINE LOC ...) ...)
-;; FILENAME is a string parsed from an error message. DIRECTORY is a string
-;; obtained by following directory change messages. DIRECTORY will be nil for
-;; an absolute filename. FORMATS is a list of formats to apply to FILENAME if
-;; a file of that name can't be found.
+;; FILENAME is a string parsed from an error message, or the buffer which was
+;; compiled. DIRECTORY is a string obtained by following directory change
+;; messages. DIRECTORY will be nil for an absolute filename or a buffer.
+;; FORMATS is a list of formats to apply to FILENAME if a file of that name
+;; can't be found.
;; The rest of the list is an alist of elements with LINE as key. The keys
;; are either nil or line numbers. If present, nil comes first, followed by
;; the numbers in decreasing order. The LOCs for each line are again an alist
@@ -1134,23 +1110,27 @@ POS and RES.")
(setq file '("*unknown*")))))
;; All of these fields are optional, get them only if we have an index, and
;; it matched some part of the message.
- (and line
- (setq line (match-string-no-properties line))
- (setq line (string-to-number line)))
- (and end-line
- (setq end-line (match-string-no-properties end-line))
- (setq end-line (string-to-number end-line)))
- (if col
- (if (functionp col)
- (setq col (funcall col))
- (and
- (setq col (match-string-no-properties col))
- (setq col (string-to-number col)))))
- (if (and end-col (functionp end-col))
- (setq end-col (funcall end-col))
- (if (and end-col (setq end-col (match-string-no-properties end-col)))
- (setq end-col (- (string-to-number end-col) -1))
- (if end-line (setq end-col -1))))
+ (setq line
+ (if (functionp line) (funcall line)
+ (and line
+ (setq line (match-string-no-properties line))
+ (string-to-number line))))
+ (setq end-line
+ (if (functionp end-line) (funcall end-line)
+ (and end-line
+ (setq end-line (match-string-no-properties end-line))
+ (string-to-number end-line))))
+ (setq col
+ (if (functionp col) (funcall col)
+ (and col
+ (setq col (match-string-no-properties col))
+ (string-to-number col))))
+ (setq end-col
+ (or (if (functionp end-col) (funcall end-col)
+ (and end-col
+ (setq end-col (match-string-no-properties end-col))
+ (- (string-to-number end-col) -1)))
+ (and end-line -1)))
(if (consp type) ; not a static type, check what it is.
(setq type (or (and (car type) (match-end (car type)) 1)
(and (cdr type) (match-end (cdr type)) 0)
@@ -1190,7 +1170,8 @@ just char-counts."
"Get the meta-info that will be added as text-properties.
LINE, END-LINE, COL, END-COL are integers or nil.
TYPE can be 0, 1, or 2, meaning error, warning, or just info.
-FILE should be (FILENAME) or (RELATIVE-FILENAME . DIRNAME) or nil.
+FILE should be (FILENAME) or (RELATIVE-FILENAME . DIRNAME) or (BUFFER) or
+nil.
FMTS is a list of format specs for transforming the file name.
(See `compilation-error-regexp-alist'.)"
(unless file (setq file '("*unknown*")))
@@ -1250,12 +1231,12 @@ FMTS is a list of format specs for transforming the file name.
(setq loc (compilation-assq line (compilation--file-struct->loc-tree
file-struct)))
(setq end-loc
- (if end-line
+ (if end-line
(compilation-assq
end-col (compilation-assq
end-line (compilation--file-struct->loc-tree
file-struct)))
- (if end-col ; use same line element
+ (if end-col ; use same line element
(compilation-assq end-col loc))))
(setq loc (compilation-assq col loc))
;; If they are new, make the loc(s) reference the file they point to.
@@ -1398,92 +1379,70 @@ to `compilation-error-regexp-alist' if RULES is nil."
(if (consp line) (setq end-line (cdr line) line (car line)))
(if (consp col) (setq end-col (cdr col) col (car col)))
- (if (functionp line)
- ;; The old compile.el had here an undocumented hook that
- ;; allowed `line' to be a function that computed the actual
- ;; error location. Let's do our best.
- (progn
- (goto-char start)
- (while (re-search-forward pat end t)
- (save-match-data
- (when compilation-debug
- (font-lock-append-text-property
- (match-beginning 0) (match-end 0)
- 'compilation-debug (vector 'functionp item)))
- (add-text-properties
- (match-beginning 0) (match-end 0)
- (compilation--compat-error-properties
- (funcall line (cons (match-string file)
- (cons default-directory
- (nthcdr 4 item)))
- (if col (match-string col))))))
- (compilation--put-prop
- file 'font-lock-face compilation-error-face)))
+ (unless (or (null (nth 5 item)) (integerp (nth 5 item)))
+ (error "HYPERLINK should be an integer: %s" (nth 5 item)))
- (unless (or (null (nth 5 item)) (integerp (nth 5 item)))
- (error "HYPERLINK should be an integer: %s" (nth 5 item)))
+ (goto-char start)
+ (while (re-search-forward pat end t)
+ (when (setq props (compilation-error-properties
+ file line end-line col end-col (or type 2) fmt))
- (goto-char start)
- (while (re-search-forward pat end t)
- (when (setq props (compilation-error-properties
- file line end-line col end-col (or type 2) fmt))
-
- (when (integerp file)
- (let ((this-type (if (consp type)
- (compilation-type type)
- (or type 2))))
- (compilation--note-type this-type)
-
- (compilation--put-prop
- file 'font-lock-face
- (symbol-value (aref [compilation-info-face
- compilation-warning-face
- compilation-error-face]
- this-type)))))
-
- (compilation--put-prop
- line 'font-lock-face compilation-line-face)
- (compilation--put-prop
- end-line 'font-lock-face compilation-line-face)
-
- (compilation--put-prop
- col 'font-lock-face compilation-column-face)
- (compilation--put-prop
- end-col 'font-lock-face compilation-column-face)
-
- ;; Obey HIGHLIGHT.
- (dolist (extra-item (nthcdr 6 item))
- (let ((mn (pop extra-item)))
- (when (match-beginning mn)
- (let ((face (eval (car extra-item))))
- (cond
- ((null face))
- ((or (symbolp face) (stringp face))
- (put-text-property
- (match-beginning mn) (match-end mn)
- 'font-lock-face face))
- ((and (listp face)
- (eq (car face) 'face)
- (or (symbolp (cadr face))
- (stringp (cadr face))))
- (compilation--put-prop mn 'font-lock-face (cadr face))
- (add-text-properties
- (match-beginning mn) (match-end mn)
- (nthcdr 2 face)))
- (t
- (error "Don't know how to handle face %S"
- face)))))))
- (let ((mn (or (nth 5 item) 0)))
- (when compilation-debug
- (font-lock-append-text-property
- (match-beginning 0) (match-end 0)
- 'compilation-debug (vector 'std item props)))
- (add-text-properties
- (match-beginning mn) (match-end mn)
- (cddr props))
+ (when (integerp file)
+ (let ((this-type (if (consp type)
+ (compilation-type type)
+ (or type 2))))
+ (compilation--note-type this-type)
+
+ (compilation--put-prop
+ file 'font-lock-face
+ (symbol-value (aref [compilation-info-face
+ compilation-warning-face
+ compilation-error-face]
+ this-type)))))
+
+ (compilation--put-prop
+ line 'font-lock-face compilation-line-face)
+ (compilation--put-prop
+ end-line 'font-lock-face compilation-line-face)
+
+ (compilation--put-prop
+ col 'font-lock-face compilation-column-face)
+ (compilation--put-prop
+ end-col 'font-lock-face compilation-column-face)
+
+ ;; Obey HIGHLIGHT.
+ (dolist (extra-item (nthcdr 6 item))
+ (let ((mn (pop extra-item)))
+ (when (match-beginning mn)
+ (let ((face (eval (car extra-item))))
+ (cond
+ ((null face))
+ ((or (symbolp face) (stringp face))
+ (put-text-property
+ (match-beginning mn) (match-end mn)
+ 'font-lock-face face))
+ ((and (listp face)
+ (eq (car face) 'face)
+ (or (symbolp (cadr face))
+ (stringp (cadr face))))
+ (compilation--put-prop mn 'font-lock-face (cadr face))
+ (add-text-properties
+ (match-beginning mn) (match-end mn)
+ (nthcdr 2 face)))
+ (t
+ (error "Don't know how to handle face %S"
+ face)))))))
+ (let ((mn (or (nth 5 item) 0)))
+ (when compilation-debug
(font-lock-append-text-property
- (match-beginning mn) (match-end mn)
- 'font-lock-face (cadr props)))))))))
+ (match-beginning 0) (match-end 0)
+ 'compilation-debug (vector 'std item props)))
+ (add-text-properties
+ (match-beginning mn) (match-end mn)
+ (cddr props))
+ (font-lock-append-text-property
+ (match-beginning mn) (match-end mn)
+ 'font-lock-face (cadr props))))))))
(defvar compilation--parsed -1)
(make-variable-buffer-local 'compilation--parsed)
@@ -1587,7 +1546,7 @@ If the optional argument `edit-command' is non-nil, the command can be edited."
(setq command (compilation-read-command (or (car compilation-arguments)
command)))
(if compilation-arguments (setcar compilation-arguments command)))
- (apply 'compilation-start (or compilation-arguments (list command)))))
+ (apply #'compilation-start (or compilation-arguments (list command)))))
(defcustom compilation-scroll-output nil
"Non-nil to scroll the *compilation* buffer window as output appears.
@@ -1601,23 +1560,25 @@ point on its location in the *compilation* buffer."
:type '(choice (const :tag "No scrolling" nil)
(const :tag "Scroll compilation output" t)
(const :tag "Stop scrolling at the first error" first-error))
- :version "20.3"
- :group 'compilation)
+ :version "20.3")
-(defun compilation-buffer-name (name-of-mode mode-command name-function)
+(defun compilation-buffer-name (name-of-mode _mode-command name-function)
"Return the name of a compilation buffer to use.
If NAME-FUNCTION is non-nil, call it with one argument NAME-OF-MODE
to determine the buffer name.
Likewise if `compilation-buffer-name-function' is non-nil.
-If current buffer has the major mode MODE-COMMAND,
+If current buffer has the NAME-OF-MODE major mode,
return the name of the current buffer, so that it gets reused.
Otherwise, construct a buffer name from NAME-OF-MODE."
- (cond (name-function
- (funcall name-function name-of-mode))
- (compilation-buffer-name-function
- (funcall compilation-buffer-name-function name-of-mode))
- ((eq mode-command major-mode)
+ (funcall (or name-function
+ compilation-buffer-name-function
+ #'compilation--default-buffer-name)
+ name-of-mode))
+
+(defun compilation--default-buffer-name (name-of-mode)
+ (cond ((or (eq major-mode (intern-soft name-of-mode))
+ (eq major-mode (intern-soft (concat name-of-mode "-mode"))))
(buffer-name))
(t
(concat "*" (downcase name-of-mode) "*"))))
@@ -1626,8 +1587,7 @@ Otherwise, construct a buffer name from NAME-OF-MODE."
"If t, always kill a running compilation process before starting a new one.
If nil, ask to kill it."
:type 'boolean
- :version "24.3"
- :group 'compilation)
+ :version "24.3")
;;;###autoload
(defun compilation-start (command &optional mode name-function highlight-regexp)
@@ -1784,15 +1744,16 @@ Returns the compilation buffer created."
(if (fboundp 'make-process)
(let ((proc
(if (eq mode t)
- ;; comint uses `start-file-process'.
- (get-buffer-process
- (with-no-warnings
- (comint-exec
- outbuf (downcase mode-name)
- (if (file-remote-p default-directory)
- "/bin/sh"
- shell-file-name)
- nil `("-c" ,command))))
+ ;; On remote hosts, the local `shell-file-name'
+ ;; might be useless.
+ (with-connection-local-variables
+ ;; comint uses `start-file-process'.
+ (get-buffer-process
+ (with-no-warnings
+ (comint-exec
+ outbuf (downcase mode-name)
+ shell-file-name
+ nil `(,shell-command-switch ,command)))))
(start-file-process-shell-command (downcase mode-name)
outbuf command))))
;; Make the buffer's mode line show process state.
@@ -1806,11 +1767,11 @@ Returns the compilation buffer created."
(when compilation-always-kill
(set-process-query-on-exit-flag proc nil))
- (set-process-sentinel proc 'compilation-sentinel)
+ (set-process-sentinel proc #'compilation-sentinel)
(unless (eq mode t)
;; Keep the comint filter, since it's needed for proper
;; handling of the prompts.
- (set-process-filter proc 'compilation-filter))
+ (set-process-filter proc #'compilation-filter))
;; Use (point-max) here so that output comes in
;; after the initial text,
;; regardless of where the user sees point.
@@ -2095,13 +2056,11 @@ by replacing the first word, e.g., `compilation-scroll-output' from
(if (boundp 'byte-compile-bound-variables)
(memq (cdr v) byte-compile-bound-variables)))
`(set (make-local-variable ',(car v)) ,(cdr v))))
- '(compilation-buffer-name-function
- compilation-directory-matcher
+ '(compilation-directory-matcher
compilation-error
compilation-error-regexp-alist
compilation-error-regexp-alist-alist
compilation-error-screen-columns
- compilation-finish-function
compilation-finish-functions
compilation-first-column
compilation-mode-font-lock-keywords
@@ -2119,7 +2078,7 @@ by replacing the first word, e.g., `compilation-scroll-output' from
(let (revert-buffer-function)
(revert-buffer ignore-auto noconfirm))
(if (or noconfirm (yes-or-no-p (format "Restart compilation? ")))
- (apply 'compilation-start compilation-arguments))))
+ (apply #'compilation-start compilation-arguments))))
(defvar compilation-current-error nil
"Marker to the location from where the next error will be found.
@@ -2155,7 +2114,7 @@ Optional argument MINOR indicates this is called from
;; It's generally preferable to use after-change-functions since they
;; can be subject to combine-after-change-calls, but if we do that, we risk
;; running our hook after font-lock, resulting in incorrect refontification.
- (add-hook 'before-change-functions 'compilation--flush-parse nil t)
+ (add-hook 'before-change-functions #'compilation--flush-parse nil t)
;; Also for minor mode, since it's not permanent-local.
(add-hook 'change-major-mode-hook #'compilation--remove-properties nil t)
(if minor
@@ -2167,7 +2126,7 @@ Optional argument MINOR indicates this is called from
(defun compilation--unsetup ()
;; Only for minor mode.
(font-lock-remove-keywords nil (compilation-mode-font-lock-keywords))
- (remove-hook 'before-change-functions 'compilation--flush-parse t)
+ (remove-hook 'before-change-functions #'compilation--flush-parse t)
(kill-local-variable 'compilation--parsed)
(compilation--remove-properties)
(font-lock-flush))
@@ -2175,16 +2134,12 @@ Optional argument MINOR indicates this is called from
;;;###autoload
(define-minor-mode compilation-shell-minor-mode
"Toggle Compilation Shell minor mode.
-With a prefix argument ARG, enable Compilation Shell minor mode
-if ARG is positive, and disable it otherwise. If called from
-Lisp, enable the mode if ARG is omitted or nil.
When Compilation Shell minor mode is enabled, all the
error-parsing commands of the Compilation major mode are
available but bound to keys that don't collide with Shell mode.
See `compilation-mode'."
- nil " Shell-Compile"
- :group 'compilation
+ :lighter " Shell-Compile"
(if compilation-shell-minor-mode
(compilation-setup t)
(compilation--unsetup)))
@@ -2192,15 +2147,11 @@ See `compilation-mode'."
;;;###autoload
(define-minor-mode compilation-minor-mode
"Toggle Compilation minor mode.
-With a prefix argument ARG, enable Compilation minor mode if ARG
-is positive, and disable it otherwise. If called from Lisp,
-enable the mode if ARG is omitted or nil.
When Compilation minor mode is enabled, all the error-parsing
commands of Compilation major mode are available. See
`compilation-mode'."
- nil " Compilation"
- :group 'compilation
+ :lighter " Compilation"
(if compilation-minor-mode
(compilation-setup t)
(compilation--unsetup)))
@@ -2245,9 +2196,6 @@ commands of Compilation major mode are available. See
(force-mode-line-update)
(if (and opoint (< opoint omax))
(goto-char opoint))
- (with-no-warnings
- (if compilation-finish-function
- (funcall compilation-finish-function cur-buffer msg)))
(run-hook-with-args 'compilation-finish-functions cur-buffer msg)))
;; Called when compilation process changes state.
@@ -2393,7 +2341,7 @@ looking for the next message."
'compilation-message))
(setq pt (compilation-next-single-property-change
pt 'compilation-message nil
- (line-end-position)))
+ (line-end-position)))
(or (setq msg (get-text-property pt 'compilation-message))
(setq pt (point)))))
(setq last (compilation--loc->file-struct loc))
@@ -2411,7 +2359,7 @@ looking for the next message."
"Moved back before first %s" (point-min))))
(goto-char pt)
(or msg
- (error "No %s here" compilation-error))))
+ (user-error "No %s here" compilation-error))))
(defun compilation-previous-error (n)
"Move point to the previous error in the compilation buffer.
@@ -2513,12 +2461,14 @@ This is the value of `next-error-function' in Compilation buffers."
;; (setq timestamp compilation-buffer-modtime)))
)
(with-current-buffer
- (apply #'compilation-find-file
- marker
- (caar (compilation--loc->file-struct loc))
- (cadr (car (compilation--loc->file-struct loc)))
- (compilation--file-struct->formats
- (compilation--loc->file-struct loc)))
+ (if (bufferp (caar (compilation--loc->file-struct loc)))
+ (caar (compilation--loc->file-struct loc))
+ (apply #'compilation-find-file
+ marker
+ (caar (compilation--loc->file-struct loc))
+ (cadr (car (compilation--loc->file-struct loc)))
+ (compilation--file-struct->formats
+ (compilation--loc->file-struct loc))))
(let ((screen-columns
;; Obey the compilation-error-screen-columns of the target
;; buffer if its major mode set it buffer-locally.
@@ -2597,7 +2547,6 @@ compilation output window; an arrow in the left fringe points to
the current message. If nil and there is no left fringe, the message
displays at the top of the window; there is no arrow."
:type '(choice integer (const :tag "No window scrolling" nil))
- :group 'compilation
:version "22.1")
(defsubst compilation-set-window (w mk)
@@ -2691,7 +2640,7 @@ and overlay is highlighted between MK and END-MK."
(numberp next-error-highlight))
;; We want highlighting: delete overlay on next input.
(add-hook 'pre-command-hook
- 'compilation-goto-locus-delete-o)
+ #'compilation-goto-locus-delete-o)
;; We don't want highlighting: delete overlay now.
(delete-overlay compilation-highlight-overlay))
;; We want highlighting for a limited time:
@@ -2711,7 +2660,7 @@ and overlay is highlighted between MK and END-MK."
(if (timerp next-error-highlight-timer)
(cancel-timer next-error-highlight-timer))
(remove-hook 'pre-command-hook
- 'compilation-goto-locus-delete-o))
+ #'compilation-goto-locus-delete-o))
(defun compilation-find-file (marker filename directory &rest formats)
"Find a buffer for file FILENAME.
@@ -2830,18 +2779,22 @@ TRUE-DIRNAME is the `file-truename' of DIRNAME, if given."
(concat comint-file-name-prefix spec-directory))))))
;; If compilation-parse-errors-filename-function is
- ;; defined, use it to process the filename.
- (when compilation-parse-errors-filename-function
- (setq filename
- (funcall compilation-parse-errors-filename-function
- filename)))
+ ;; defined, use it to process the filename. The result might be a
+ ;; buffer.
+ (unless (memq compilation-parse-errors-filename-function
+ '(nil identity))
+ (save-match-data
+ (setq filename
+ (funcall compilation-parse-errors-filename-function
+ filename))))
;; Some compilers (e.g. Sun's java compiler, reportedly) produce bogus
;; file names like "./bar//foo.c" for file "bar/foo.c";
;; expand-file-name will collapse these into "/foo.c" and fail to find
;; the appropriate file. So we look for doubled slashes in the file
;; name and fix them.
- (setq filename (command-line-normalize-file-name filename))
+ (if (stringp filename)
+ (setq filename (command-line-normalize-file-name filename)))
;; Store it for the possibly unnormalized name
(puthash file
@@ -2874,29 +2827,6 @@ TRUE-DIRNAME is the `file-truename' of DIRNAME, if given."
(defvar compilation-error-list nil)
(defvar compilation-old-error-list nil)
-(defun compilation--compat-error-properties (err)
- "Map old-style error ERR to new-style message."
- ;; Old-style structure is (MARKER (FILE DIR) LINE COL) or
- ;; (MARKER . MARKER).
- (let ((dst (cdr err)))
- (if (markerp dst)
- `(compilation-message ,(compilation--make-message
- (cons nil (compilation--make-cdrloc
- nil nil dst))
- 2 nil)
- help-echo "mouse-2: visit the source location"
- keymap compilation-button-map
- mouse-face highlight)
- ;; Too difficult to do it by hand: dispatch to the normal code.
- (let* ((file (pop dst))
- (line (pop dst))
- (col (pop dst))
- (filename (pop file))
- (dirname (pop file))
- (fmt (pop file)))
- (compilation-internal-error-properties
- (cons filename dirname) line nil col nil 2 fmt)))))
-
(defun compilation--compat-parse-errors (limit)
(when compilation-parse-errors-function
;; FIXME: We should remove the rest of the compilation keywords
diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index f25e24ba717..73b55e29a5a 100644
--- a/lisp/progmodes/cperl-mode.el
+++ b/lisp/progmodes/cperl-mode.el
@@ -1,9 +1,10 @@
-;;; cperl-mode.el --- Perl code editing commands for Emacs
+;;; cperl-mode.el --- Perl code editing commands for Emacs -*- lexical-binding:t -*-
;; Copyright (C) 1985-1987, 1991-2019 Free Software Foundation, Inc.
;; Author: Ilya Zakharevich
;; Bob Olson
+;; Jonathan Rockway <jon@jrock.us>
;; Maintainer: emacs-devel@gnu.org
;; Keywords: languages, Perl
@@ -22,10 +23,19 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-;;; Corrections made by Ilya Zakharevich ilyaz@cpan.org
+;; Corrections made by Ilya Zakharevich ilyaz@cpan.org
;;; Commentary:
+;; This version of the file contains support for the syntax added by
+;; the MooseX::Declare CPAN module, as well as Perl 5.10 keyword
+;; support.
+
+;; The latest version is available from
+;; http://github.com/jrockway/cperl-mode
+;;
+;; (perhaps in the moosex-declare branch)
+
;; You can either fine-tune the bells and whistles of this mode or
;; bulk enable them by putting
@@ -56,7 +66,7 @@
;; (define-key global-map [M-S-down-mouse-3] 'imenu)
-;;; Font lock bugs as of v4.32:
+;;;; Font lock bugs as of v4.32:
;; The following kinds of Perl code erroneously start strings:
;; \$` \$' \$"
@@ -65,6 +75,8 @@
;;; Code:
+(eval-when-compile (require 'cl-lib))
+
(defvar vc-rcs-header)
(defvar vc-sccs-header)
@@ -75,37 +87,11 @@
(condition-case nil
(require 'man)
(error nil))
- (defvar cperl-can-font-lock
- (or (featurep 'xemacs)
- (and (boundp 'emacs-major-version)
- (or window-system
- (> emacs-major-version 20)))))
- (if cperl-can-font-lock
- (require 'font-lock))
(defvar msb-menu-cond)
(defvar gud-perldb-history)
(defvar font-lock-background-mode) ; not in Emacs
(defvar font-lock-display-type) ; ditto
(defvar paren-backwards-message) ; Not in newer XEmacs?
- (or (fboundp 'defgroup)
- (defmacro defgroup (name val doc &rest arr)
- nil))
- (or (fboundp 'custom-declare-variable)
- (defmacro defcustom (name val doc &rest arr)
- `(defvar ,name ,val ,doc)))
- (or (and (fboundp 'custom-declare-variable)
- (string< "19.31" emacs-version)) ; Checked with 19.30: defface does not work
- (defmacro defface (&rest arr)
- nil))
- ;; Avoid warning (tmp definitions)
- (or (fboundp 'x-color-defined-p)
- (defmacro x-color-defined-p (col)
- (cond ((fboundp 'color-defined-p) `(color-defined-p ,col))
- ;; XEmacs >= 19.12
- ((fboundp 'valid-color-name-p) `(valid-color-name-p ,col))
- ;; XEmacs 19.11
- ((fboundp 'x-valid-color-name-p) `(x-valid-color-name-p ,col))
- (t '(error "Cannot implement color-defined-p")))))
(defmacro cperl-is-face (arg) ; Takes quoted arg
(cond ((fboundp 'find-face)
`(find-face ,arg))
@@ -132,8 +118,8 @@
`(progn
(beginning-of-line 2)
(list ,file ,line)))
- (defmacro cperl-etags-snarf-tag (file line)
- `(etags-snarf-tag)))
+ (defmacro cperl-etags-snarf-tag (_file _line)
+ '(etags-snarf-tag)))
(if (featurep 'xemacs)
(defmacro cperl-etags-goto-tag-location (elt)
;;(progn
@@ -147,12 +133,6 @@
(defmacro cperl-etags-goto-tag-location (elt)
`(etags-goto-tag-location ,elt))))
-(defvar cperl-can-font-lock
- (or (featurep 'xemacs)
- (and (boundp 'emacs-major-version)
- (or window-system
- (> emacs-major-version 20)))))
-
(defun cperl-choose-color (&rest list)
(let (answer)
(while list
@@ -228,10 +208,10 @@ for constructs with multiline if/unless/while/until/for/foreach condition."
:type 'integer
:group 'cperl-indentation-details)
-;; Is is not unusual to put both things like perl-indent-level and
-;; cperl-indent-level in the local variable section of a file. If only
+;; It is not unusual to put both things like perl-indent-level and
+;; cperl-indent-level in the local variable section of a file. If only
;; one of perl-mode and cperl-mode is in use, a warning will be issued
-;; about the variable. Autoload these here, so that no warning is
+;; about the variable. Autoload these here, so that no warning is
;; issued when using either perl-mode or cperl-mode.
;;;###autoload(put 'cperl-indent-level 'safe-local-variable 'integerp)
;;;###autoload(put 'cperl-brace-offset 'safe-local-variable 'integerp)
@@ -286,6 +266,11 @@ Versions 5.2 ... 5.20 behaved as if this were nil."
:type 'boolean
:group 'cperl-indentation-details)
+(defcustom cperl-indent-subs-specially t
+ "Non-nil means indent subs that are inside other blocks (hash values, for example) relative to the beginning of the \"sub\" keyword, rather than relative to the statement that contains the declaration."
+ :type 'boolean
+ :group 'cperl-indentation-details)
+
(defcustom cperl-auto-newline nil
"Non-nil means automatically newline before and after braces,
and after colons and semicolons, inserted in CPerl code. The following
@@ -405,13 +390,6 @@ Affects: `cperl-font-lock', `cperl-electric-lbrace-space',
:type '(repeat string)
:group 'cperl)
-;; This became obsolete...
-(defvar cperl-vc-header-alist nil)
-(make-obsolete-variable
- 'cperl-vc-header-alist
- "use cperl-vc-rcs-header or cperl-vc-sccs-header instead."
- "22.1")
-
;; (defcustom cperl-clobber-mode-lists
;; (not
;; (and
@@ -458,7 +436,7 @@ Font for POD headers."
:type 'face
:group 'cperl-faces)
-;;; Some double-evaluation happened with font-locks... Needed with 21.2...
+;; Some double-evaluation happened with font-locks... Needed with 21.2...
(defvar cperl-singly-quote-face (featurep 'xemacs))
(defcustom cperl-invalid-face 'underline
@@ -612,8 +590,7 @@ One should tune up `cperl-close-paren-offset' as well."
:group 'cperl-indentation-details)
(defcustom cperl-syntaxify-by-font-lock
- (and cperl-can-font-lock
- (boundp 'parse-sexp-lookup-properties))
+ (boundp 'parse-sexp-lookup-properties)
"Non-nil means that CPerl uses the `font-lock' routines for syntaxification."
:type '(choice (const message) boolean)
:group 'cperl-speed)
@@ -1010,33 +987,15 @@ In regular expressions (including character classes):
(and (vectorp cperl-del-back-ch) (= (length cperl-del-back-ch) 1)
(setq cperl-del-back-ch (aref cperl-del-back-ch 0)))
-(defun cperl-mark-active () (mark)) ; Avoid undefined warning
-(if (featurep 'xemacs)
- (progn
- ;; "Active regions" are on: use region only if active
- ;; "Active regions" are off: use region unconditionally
- (defun cperl-use-region-p ()
- (if zmacs-regions (mark) t)))
- (defun cperl-use-region-p ()
- (if transient-mark-mode mark-active t))
- (defun cperl-mark-active () mark-active))
-
-(defsubst cperl-enable-font-lock ()
- cperl-can-font-lock)
-
(defun cperl-putback-char (c) ; Emacs 19
(push c unread-command-events)) ; Avoid undefined warning
(if (featurep 'xemacs)
(defun cperl-putback-char (c) ; XEmacs >= 19.12
- (push (eval '(character-to-event c)) unread-command-events)))
-
-(or (fboundp 'uncomment-region)
- (defun uncomment-region (beg end)
- (interactive "r")
- (comment-region beg end -1)))
+ (push (character-to-event c) unread-command-events)))
(defvar cperl-do-not-fontify
+ ;; FIXME: This is not doing what it claims!
(if (string< emacs-version "19.30")
'fontified
'lazy-lock)
@@ -1056,8 +1015,6 @@ In regular expressions (including character classes):
(defvar cperl-syntax-state nil)
(defvar cperl-syntax-done-to nil)
-(defvar cperl-emacs-can-parse (> (length (save-excursion
- (parse-partial-sexp (point) (point)))) 9))
;; Make customization possible "in reverse"
(defsubst cperl-val (symbol &optional default hairy)
@@ -1085,141 +1042,126 @@ versions of Emacs."
(put-text-property (point) (match-end 0)
'syntax-type prop)))))))
-;;; Probably it is too late to set these guys already, but it can help later:
+;; Probably it is too late to set these guys already, but it can help later:
-;;;(and cperl-clobber-mode-lists
-;;;(setq auto-mode-alist
-;;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist ))
-;;;(and (boundp 'interpreter-mode-alist)
-;;; (setq interpreter-mode-alist (append interpreter-mode-alist
-;;; '(("miniperl" . perl-mode))))))
+;;(and cperl-clobber-mode-lists
+;;(setq auto-mode-alist
+;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist ))
+;;(and (boundp 'interpreter-mode-alist)
+;; (setq interpreter-mode-alist (append interpreter-mode-alist
+;; '(("miniperl" . perl-mode))))))
(eval-when-compile
- (mapc (lambda (p)
- (condition-case nil
- (require p)
- (error nil)))
- '(imenu easymenu etags timer man info))
- (if (fboundp 'ps-extend-face-list)
- (defmacro cperl-ps-extend-face-list (arg)
- `(ps-extend-face-list ,arg))
- (defmacro cperl-ps-extend-face-list (arg)
- `(error "This version of Emacs has no `ps-extend-face-list'")))
- ;; Calling `cperl-enable-font-lock' below doesn't compile on XEmacs,
- ;; macros instead of defsubsts don't work on Emacs, so we do the
- ;; expansion manually. Any other suggestions?
- (require 'cl))
-
-(define-abbrev-table 'cperl-mode-abbrev-table
- '(
- ("if" "if" cperl-electric-keyword :system t)
- ("elsif" "elsif" cperl-electric-keyword :system t)
- ("while" "while" cperl-electric-keyword :system t)
- ("until" "until" cperl-electric-keyword :system t)
- ("unless" "unless" cperl-electric-keyword :system t)
- ("else" "else" cperl-electric-else :system t)
- ("continue" "continue" cperl-electric-else :system t)
- ("for" "for" cperl-electric-keyword :system t)
- ("foreach" "foreach" cperl-electric-keyword :system t)
- ("formy" "formy" cperl-electric-keyword :system t)
- ("foreachmy" "foreachmy" cperl-electric-keyword :system t)
- ("do" "do" cperl-electric-keyword :system t)
- ("=pod" "=pod" cperl-electric-pod :system t)
- ("=over" "=over" cperl-electric-pod :system t)
- ("=head1" "=head1" cperl-electric-pod :system t)
- ("=head2" "=head2" cperl-electric-pod :system t)
- ("pod" "pod" cperl-electric-pod :system t)
- ("over" "over" cperl-electric-pod :system t)
- ("head1" "head1" cperl-electric-pod :system t)
- ("head2" "head2" cperl-electric-pod :system t))
- "Abbrev table in use in CPerl mode buffers.")
-
-(add-hook 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-")))
-
-(defvar cperl-mode-map () "Keymap used in CPerl mode.")
-
-(if cperl-mode-map nil
- (setq cperl-mode-map (make-sparse-keymap))
- (cperl-define-key "{" 'cperl-electric-lbrace)
- (cperl-define-key "[" 'cperl-electric-paren)
- (cperl-define-key "(" 'cperl-electric-paren)
- (cperl-define-key "<" 'cperl-electric-paren)
- (cperl-define-key "}" 'cperl-electric-brace)
- (cperl-define-key "]" 'cperl-electric-rparen)
- (cperl-define-key ")" 'cperl-electric-rparen)
- (cperl-define-key ";" 'cperl-electric-semi)
- (cperl-define-key ":" 'cperl-electric-terminator)
- (cperl-define-key "\C-j" 'newline-and-indent)
- (cperl-define-key "\C-c\C-j" 'cperl-linefeed)
- (cperl-define-key "\C-c\C-t" 'cperl-invert-if-unless)
- (cperl-define-key "\C-c\C-a" 'cperl-toggle-auto-newline)
- (cperl-define-key "\C-c\C-k" 'cperl-toggle-abbrev)
- (cperl-define-key "\C-c\C-w" 'cperl-toggle-construct-fix)
- (cperl-define-key "\C-c\C-f" 'auto-fill-mode)
- (cperl-define-key "\C-c\C-e" 'cperl-toggle-electric)
- (cperl-define-key "\C-c\C-b" 'cperl-find-bad-style)
- (cperl-define-key "\C-c\C-p" 'cperl-pod-spell)
- (cperl-define-key "\C-c\C-d" 'cperl-here-doc-spell)
- (cperl-define-key "\C-c\C-n" 'cperl-narrow-to-here-doc)
- (cperl-define-key "\C-c\C-v" 'cperl-next-interpolated-REx)
- (cperl-define-key "\C-c\C-x" 'cperl-next-interpolated-REx-0)
- (cperl-define-key "\C-c\C-y" 'cperl-next-interpolated-REx-1)
- (cperl-define-key "\C-c\C-ha" 'cperl-toggle-autohelp)
- (cperl-define-key "\C-c\C-hp" 'cperl-perldoc)
- (cperl-define-key "\C-c\C-hP" 'cperl-perldoc-at-point)
- (cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound
- (cperl-define-key [?\C-\M-\|] 'cperl-lineup
- [(control meta |)])
- ;;(cperl-define-key "\M-q" 'cperl-fill-paragraph)
- ;;(cperl-define-key "\e;" 'cperl-indent-for-comment)
- (cperl-define-key "\177" 'cperl-electric-backspace)
- (cperl-define-key "\t" 'cperl-indent-command)
- ;; don't clobber the backspace binding:
- (cperl-define-key "\C-c\C-hF" 'cperl-info-on-command
- [(control c) (control h) F])
- (if (cperl-val 'cperl-clobber-lisp-bindings)
- (progn
- (cperl-define-key "\C-hf"
- ;;(concat (char-to-string help-char) "f") ; does not work
- 'cperl-info-on-command
- [(control h) f])
- (cperl-define-key "\C-hv"
- ;;(concat (char-to-string help-char) "v") ; does not work
- 'cperl-get-help
- [(control h) v])
- (cperl-define-key "\C-c\C-hf"
- ;;(concat (char-to-string help-char) "f") ; does not work
- (key-binding "\C-hf")
- [(control c) (control h) f])
- (cperl-define-key "\C-c\C-hv"
- ;;(concat (char-to-string help-char) "v") ; does not work
- (key-binding "\C-hv")
- [(control c) (control h) v]))
- (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command
- [(control c) (control h) f])
- (cperl-define-key "\C-c\C-hv"
- ;;(concat (char-to-string help-char) "v") ; does not work
- 'cperl-get-help
- [(control c) (control h) v]))
- (if (and (featurep 'xemacs)
- (<= emacs-minor-version 11) (<= emacs-major-version 19))
- (progn
- ;; substitute-key-definition is usefulness-deenhanced...
- ;;;;;(cperl-define-key "\M-q" 'cperl-fill-paragraph)
- (cperl-define-key "\e;" 'cperl-indent-for-comment)
- (cperl-define-key "\e\C-\\" 'cperl-indent-region))
+ (mapc #'require '(imenu easymenu etags timer man info)))
+
+(define-abbrev-table 'cperl-mode-electric-keywords-abbrev-table
+ (mapcar (lambda (x)
+ (let ((name (car x))
+ (fun (cadr x)))
+ (list name name fun :system t)))
+ '(("if" cperl-electric-keyword)
+ ("elsif" cperl-electric-keyword)
+ ("while" cperl-electric-keyword)
+ ("until" cperl-electric-keyword)
+ ("unless" cperl-electric-keyword)
+ ("else" cperl-electric-else)
+ ("continue" cperl-electric-else)
+ ("for" cperl-electric-keyword)
+ ("foreach" cperl-electric-keyword)
+ ("formy" cperl-electric-keyword)
+ ("foreachmy" cperl-electric-keyword)
+ ("do" cperl-electric-keyword)
+ ("=pod" cperl-electric-pod)
+ ("=begin" cperl-electric-pod t)
+ ("=over" cperl-electric-pod)
+ ("=head1" cperl-electric-pod)
+ ("=head2" cperl-electric-pod)
+ ("pod" cperl-electric-pod)
+ ("over" cperl-electric-pod)
+ ("head1" cperl-electric-pod)
+ ("head2" cperl-electric-pod)))
+ "Abbrev table for electric keywords. Controlled by `cperl-electric-keywords'."
+ :case-fixed t
+ :enable-function (lambda () (cperl-val 'cperl-electric-keywords)))
+
+(define-abbrev-table 'cperl-mode-abbrev-table ()
+ "Abbrev table in use in CPerl mode buffers."
+ :parents (list cperl-mode-electric-keywords-abbrev-table))
+
+(when (boundp 'edit-var-mode-alist)
+ ;; FIXME: What package uses this?
+ (add-to-list 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-"))))
+
+(defvar cperl-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "{" 'cperl-electric-lbrace)
+ (define-key map "[" 'cperl-electric-paren)
+ (define-key map "(" 'cperl-electric-paren)
+ (define-key map "<" 'cperl-electric-paren)
+ (define-key map "}" 'cperl-electric-brace)
+ (define-key map "]" 'cperl-electric-rparen)
+ (define-key map ")" 'cperl-electric-rparen)
+ (define-key map ";" 'cperl-electric-semi)
+ (define-key map ":" 'cperl-electric-terminator)
+ (define-key map "\C-j" 'newline-and-indent)
+ (define-key map "\C-c\C-j" 'cperl-linefeed)
+ (define-key map "\C-c\C-t" 'cperl-invert-if-unless)
+ (define-key map "\C-c\C-a" 'cperl-toggle-auto-newline)
+ (define-key map "\C-c\C-k" 'cperl-toggle-abbrev)
+ (define-key map "\C-c\C-w" 'cperl-toggle-construct-fix)
+ (define-key map "\C-c\C-f" 'auto-fill-mode)
+ (define-key map "\C-c\C-e" 'cperl-toggle-electric)
+ (define-key map "\C-c\C-b" 'cperl-find-bad-style)
+ (define-key map "\C-c\C-p" 'cperl-pod-spell)
+ (define-key map "\C-c\C-d" 'cperl-here-doc-spell)
+ (define-key map "\C-c\C-n" 'cperl-narrow-to-here-doc)
+ (define-key map "\C-c\C-v" 'cperl-next-interpolated-REx)
+ (define-key map "\C-c\C-x" 'cperl-next-interpolated-REx-0)
+ (define-key map "\C-c\C-y" 'cperl-next-interpolated-REx-1)
+ (define-key map "\C-c\C-ha" 'cperl-toggle-autohelp)
+ (define-key map "\C-c\C-hp" 'cperl-perldoc)
+ (define-key map "\C-c\C-hP" 'cperl-perldoc-at-point)
+ (define-key map "\e\C-q" 'cperl-indent-exp) ; Usually not bound
+ (define-key map [(control meta ?|)] 'cperl-lineup)
+ ;;(define-key map "\M-q" 'cperl-fill-paragraph)
+ ;;(define-key map "\e;" 'cperl-indent-for-comment)
+ (define-key map "\177" 'cperl-electric-backspace)
+ (define-key map "\t" 'cperl-indent-command)
+ ;; don't clobber the backspace binding:
+ (define-key map [(control ?c) (control ?h) ?F] 'cperl-info-on-command)
+ (if (cperl-val 'cperl-clobber-lisp-bindings)
+ (progn
+ (define-key map [(control ?h) ?f]
+ ;;(concat (char-to-string help-char) "f") ; does not work
+ 'cperl-info-on-command)
+ (define-key map [(control ?h) ?v]
+ ;;(concat (char-to-string help-char) "v") ; does not work
+ 'cperl-get-help)
+ (define-key map [(control ?c) (control ?h) ?f]
+ ;;(concat (char-to-string help-char) "f") ; does not work
+ (key-binding "\C-hf"))
+ (define-key map [(control ?c) (control ?h) ?v]
+ ;;(concat (char-to-string help-char) "v") ; does not work
+ (key-binding "\C-hv")))
+ (define-key map [(control ?c) (control ?h) ?f]
+ 'cperl-info-on-current-command)
+ (define-key map [(control ?c) (control ?h) ?v]
+ ;;(concat (char-to-string help-char) "v") ; does not work
+ 'cperl-get-help))
(or (boundp 'fill-paragraph-function)
- (substitute-key-definition
- 'fill-paragraph 'cperl-fill-paragraph
- cperl-mode-map global-map))
+ (substitute-key-definition
+ 'fill-paragraph 'cperl-fill-paragraph
+ map global-map))
(substitute-key-definition
'indent-sexp 'cperl-indent-exp
- cperl-mode-map global-map)
+ map global-map)
(substitute-key-definition
'indent-region 'cperl-indent-region
- cperl-mode-map global-map)
+ map global-map)
(substitute-key-definition
'indent-for-comment 'cperl-indent-for-comment
- cperl-mode-map global-map)))
+ map global-map)
+ map)
+ "Keymap used in CPerl mode.")
(defvar cperl-menu)
(defvar cperl-lazy-installed)
@@ -1236,7 +1178,7 @@ versions of Emacs."
["Indent expression" cperl-indent-exp t]
["Fill paragraph/comment" fill-paragraph t]
"----"
- ["Line up a construction" cperl-lineup (cperl-use-region-p)]
+ ["Line up a construction" cperl-lineup (use-region-p)]
["Invert if/unless/while etc" cperl-invert-if-unless t]
("Regexp"
["Beautify" cperl-beautify-regexp
@@ -1264,9 +1206,9 @@ versions of Emacs."
["Insert spaces if needed to fix style" cperl-find-bad-style t]
["Refresh \"hard\" constructions" cperl-find-pods-heres t]
"----"
- ["Indent region" cperl-indent-region (cperl-use-region-p)]
- ["Comment region" cperl-comment-region (cperl-use-region-p)]
- ["Uncomment region" cperl-uncomment-region (cperl-use-region-p)]
+ ["Indent region" cperl-indent-region (use-region-p)]
+ ["Comment region" cperl-comment-region (use-region-p)]
+ ["Uncomment region" cperl-uncomment-region (use-region-p)]
"----"
["Run" mode-compile (fboundp 'mode-compile)]
["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill)
@@ -1313,7 +1255,7 @@ versions of Emacs."
(fboundp 'ps-extend-face-list)]
"----"
["Syntaxify region" cperl-find-pods-heres-region
- (cperl-use-region-p)]
+ (use-region-p)]
["Profile syntaxification" cperl-time-fontification t]
["Debug errors in delayed fontification" cperl-emulate-lazy-lock t]
["Debug unwind for syntactic scan" cperl-toggle-set-debug-unwind t]
@@ -1323,15 +1265,15 @@ versions of Emacs."
["Class Hierarchy from TAGS" cperl-tags-hier-init t]
;;["Update classes" (cperl-tags-hier-init t) tags-table-list]
("Tags"
-;;; ["Create tags for current file" cperl-etags t]
-;;; ["Add tags for current file" (cperl-etags t) t]
-;;; ["Create tags for Perl files in directory" (cperl-etags nil t) t]
-;;; ["Add tags for Perl files in directory" (cperl-etags t t) t]
-;;; ["Create tags for Perl files in (sub)directories"
-;;; (cperl-etags nil 'recursive) t]
-;;; ["Add tags for Perl files in (sub)directories"
-;;; (cperl-etags t 'recursive) t])
-;;;; cperl-write-tags (&optional file erase recurse dir inbuffer)
+ ;; ["Create tags for current file" cperl-etags t]
+ ;; ["Add tags for current file" (cperl-etags t) t]
+ ;; ["Create tags for Perl files in directory" (cperl-etags nil t) t]
+ ;; ["Add tags for Perl files in directory" (cperl-etags t t) t]
+ ;; ["Create tags for Perl files in (sub)directories"
+ ;; (cperl-etags nil 'recursive) t]
+ ;; ["Add tags for Perl files in (sub)directories"
+ ;; (cperl-etags t 'recursive) t])
+ ;; ;;? cperl-write-tags (&optional file erase recurse dir inbuffer)
["Create tags for current file" (cperl-write-tags nil t) t]
["Add tags for current file" (cperl-write-tags) t]
["Create tags for Perl files in directory"
@@ -1352,11 +1294,9 @@ versions of Emacs."
["Perldoc on word at point" cperl-perldoc-at-point t]
["View manpage of POD in this file" cperl-build-manpage t]
["Auto-help on" cperl-lazy-install
- (and (fboundp 'run-with-idle-timer)
- (not cperl-lazy-installed))]
+ (not cperl-lazy-installed)]
["Auto-help off" cperl-lazy-unstall
- (and (fboundp 'run-with-idle-timer)
- cperl-lazy-installed)])
+ cperl-lazy-installed])
("Toggle..."
["Auto newline" cperl-toggle-auto-newline t]
["Electric parens" cperl-toggle-electric t]
@@ -1383,7 +1323,8 @@ versions of Emacs."
["CPerl mode" (describe-function 'cperl-mode) t]
["CPerl version"
(message "The version of master-file for this CPerl is %s-Emacs"
- cperl-version) t]))))
+ cperl-version)
+ t]))))
(error nil))
(autoload 'c-macro-expand "cmacexp"
@@ -1391,22 +1332,22 @@ versions of Emacs."
The expansion is entirely correct because it uses the C preprocessor."
t)
-;;; These two must be unwound, otherwise take exponential time
+;; These two must be unwound, otherwise take exponential time
(defconst cperl-maybe-white-and-comment-rex "[ \t\n]*\\(#[^\n]*\n[ \t\n]*\\)*"
"Regular expression to match optional whitespace with interspersed comments.
Should contain exactly one group.")
-;;; This one is tricky to unwind; still very inefficient...
+;; This one is tricky to unwind; still very inefficient...
(defconst cperl-white-and-comment-rex "\\([ \t\n]\\|#[^\n]*\n\\)+"
"Regular expression to match whitespace with interspersed comments.
Should contain exactly one group.")
-;;; Is incorporated in `cperl-imenu--function-name-regexp-perl'
-;;; `cperl-outline-regexp', `defun-prompt-regexp'.
-;;; Details of groups in this may be used in several functions; see comments
-;;; near mentioned above variable(s)...
-;;; sub($$):lvalue{} sub:lvalue{} Both allowed...
+;; Is incorporated in `cperl-imenu--function-name-regexp-perl'
+;; `cperl-outline-regexp', `defun-prompt-regexp'.
+;; Details of groups in this may be used in several functions; see comments
+;; near mentioned above variable(s)...
+;; sub($$):lvalue{} sub:lvalue{} Both allowed...
(defsubst cperl-after-sub-regexp (named attr) ; 9 groups without attr...
"Match the text after `sub' in a subroutine declaration.
If NAMED is nil, allows anonymous subroutines. Matches up to the first \":\"
@@ -1441,9 +1382,22 @@ the last)."
"\\)?" ; END n+6=proto-group
))
-;;; Details of groups in this are used in `cperl-imenu--create-perl-index'
-;;; and `cperl-outline-level'.
-;;;; Was: 2=sub|package; now 2=package-group, 5=package-name 8=sub-name (+3)
+;; Tired of editing this in 8 places every time I remember that there
+;; is another method-defining keyword
+(defvar cperl-sub-keywords
+ '("sub"))
+
+(defvar cperl-sub-regexp (regexp-opt cperl-sub-keywords))
+
+(defun cperl-char-ends-sub-keyword-p (char)
+ "Return T if CHAR is the last character of a perl sub keyword."
+ (cl-loop for keyword in cperl-sub-keywords
+ when (eq char (aref keyword (1- (length keyword))))
+ return t))
+
+;; Details of groups in this are used in `cperl-imenu--create-perl-index'
+;; and `cperl-outline-level'.
+;; Was: 2=sub|package; now 2=package-group, 5=package-name 8=sub-name (+3)
(defvar cperl-imenu--function-name-regexp-perl
(concat
"^\\(" ; 1 = all
@@ -1452,7 +1406,8 @@ the last)."
cperl-white-and-comment-rex ; 4 = pre-package-name
"\\([a-zA-Z_0-9:']+\\)\\)?\\)" ; 5 = package-name
"\\|"
- "[ \t]*sub"
+ "[ \t]*"
+ cperl-sub-regexp
(cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start
cperl-maybe-white-and-comment-rex ; 15=pre-block
"\\|"
@@ -1624,7 +1579,7 @@ It is possible to show this help automatically after some idle time.
This is regulated by variable `cperl-lazy-help-time'. Default with
`cperl-hairy' (if the value of `cperl-lazy-help-time' is nil) is 5
secs idle time . It is also possible to switch this on/off from the
-menu, or via \\[cperl-toggle-autohelp]. Requires `run-with-idle-timer'.
+menu, or via \\[cperl-toggle-autohelp].
Use \\[cperl-lineup] to vertically lineup some construction - put the
beginning of the region at the start of construction, and make region
@@ -1719,107 +1674,73 @@ or as help on variables `cperl-tips', `cperl-problems',
;; Until Emacs is multi-threaded, we do not actually need it local:
(make-local-variable 'cperl-font-lock-multiline-start)
(make-local-variable 'cperl-font-locking)
- (make-local-variable 'outline-regexp)
- ;; (setq outline-regexp imenu-example--function-name-regexp-perl)
- (setq outline-regexp cperl-outline-regexp)
- (make-local-variable 'outline-level)
- (setq outline-level 'cperl-outline-level)
- (make-local-variable 'add-log-current-defun-function)
- (setq add-log-current-defun-function
+ (set (make-local-variable 'outline-regexp) cperl-outline-regexp)
+ (set (make-local-variable 'outline-level) 'cperl-outline-level)
+ (set (make-local-variable 'add-log-current-defun-function)
(lambda ()
(save-excursion
(if (re-search-backward "^sub[ \t]+\\([^({ \t\n]+\\)" nil t)
(match-string-no-properties 1)))))
- (make-local-variable 'paragraph-start)
- (setq paragraph-start (concat "^$\\|" page-delimiter))
- (make-local-variable 'paragraph-separate)
- (setq paragraph-separate paragraph-start)
- (make-local-variable 'paragraph-ignore-fill-prefix)
- (setq paragraph-ignore-fill-prefix t)
+ (set (make-local-variable 'paragraph-start) (concat "^$\\|" page-delimiter))
+ (set (make-local-variable 'paragraph-separate) paragraph-start)
+ (set (make-local-variable 'paragraph-ignore-fill-prefix) t)
(if (featurep 'xemacs)
- (progn
- (make-local-variable 'paren-backwards-message)
- (set 'paren-backwards-message t)))
- (make-local-variable 'indent-line-function)
- (setq indent-line-function 'cperl-indent-line)
- (make-local-variable 'require-final-newline)
- (setq require-final-newline mode-require-final-newline)
- (make-local-variable 'comment-start)
- (setq comment-start "# ")
- (make-local-variable 'comment-end)
- (setq comment-end "")
- (make-local-variable 'comment-column)
- (setq comment-column cperl-comment-column)
- (make-local-variable 'comment-start-skip)
- (setq comment-start-skip "#+ *")
- (make-local-variable 'defun-prompt-regexp)
-;;; "[ \t]*sub"
-;;; (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start
-;;; cperl-maybe-white-and-comment-rex ; 15=pre-block
- (setq defun-prompt-regexp
- (concat "^[ \t]*\\(sub"
- (cperl-after-sub-regexp 'named 'attr-groups)
- "\\|" ; per toke.c
- "\\(BEGIN\\|CHECK\\|INIT\\|END\\|AUTOLOAD\\|DESTROY\\)"
- "\\)"
- cperl-maybe-white-and-comment-rex))
- (make-local-variable 'comment-indent-function)
- (setq comment-indent-function 'cperl-comment-indent)
+ (set (make-local-variable 'paren-backwards-message) t))
+ (set (make-local-variable 'indent-line-function) #'cperl-indent-line)
+ (set (make-local-variable 'require-final-newline) mode-require-final-newline)
+ (set (make-local-variable 'comment-start) "# ")
+ (set (make-local-variable 'comment-end) "")
+ (set (make-local-variable 'comment-column) cperl-comment-column)
+ (set (make-local-variable 'comment-start-skip) "#+ *")
+
+;; "[ \t]*sub"
+;; (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start
+;; cperl-maybe-white-and-comment-rex ; 15=pre-block
+ (set (make-local-variable 'defun-prompt-regexp)
+ (concat "^[ \t]*\\("
+ cperl-sub-regexp
+ (cperl-after-sub-regexp 'named 'attr-groups)
+ "\\|" ; per toke.c
+ "\\(BEGIN\\|UNITCHECK\\|CHECK\\|INIT\\|END\\|AUTOLOAD\\|DESTROY\\)"
+ "\\)"
+ cperl-maybe-white-and-comment-rex))
+ (set (make-local-variable 'comment-indent-function) #'cperl-comment-indent)
(and (boundp 'fill-paragraph-function)
- (progn
- (make-local-variable 'fill-paragraph-function)
- (set 'fill-paragraph-function 'cperl-fill-paragraph)))
- (make-local-variable 'parse-sexp-ignore-comments)
- (setq parse-sexp-ignore-comments t)
- (make-local-variable 'indent-region-function)
- (setq indent-region-function 'cperl-indent-region)
- ;;(setq auto-fill-function 'cperl-do-auto-fill) ; Need to switch on and off!
- (make-local-variable 'imenu-create-index-function)
- (setq imenu-create-index-function
- (function cperl-imenu--create-perl-index))
- (make-local-variable 'imenu-sort-function)
- (setq imenu-sort-function nil)
- (make-local-variable 'vc-rcs-header)
- (set 'vc-rcs-header cperl-vc-rcs-header)
- (make-local-variable 'vc-sccs-header)
- (set 'vc-sccs-header cperl-vc-sccs-header)
+ (set (make-local-variable 'fill-paragraph-function)
+ #'cperl-fill-paragraph))
+ (set (make-local-variable 'parse-sexp-ignore-comments) t)
+ (set (make-local-variable 'indent-region-function) #'cperl-indent-region)
+ ;;(setq auto-fill-function #'cperl-do-auto-fill) ; Need to switch on and off!
+ (set (make-local-variable 'imenu-create-index-function)
+ #'cperl-imenu--create-perl-index)
+ (set (make-local-variable 'imenu-sort-function) nil)
+ (set (make-local-variable 'vc-rcs-header) cperl-vc-rcs-header)
+ (set (make-local-variable 'vc-sccs-header) cperl-vc-sccs-header)
(when (featurep 'xemacs)
;; This one is obsolete...
- (make-local-variable 'vc-header-alist)
- (set 'vc-header-alist (or cperl-vc-header-alist ; Avoid warning
- `((SCCS ,(car cperl-vc-sccs-header))
- (RCS ,(car cperl-vc-rcs-header))))))
+ (set (make-local-variable 'vc-header-alist)
+ `((SCCS ,(car cperl-vc-sccs-header))
+ (RCS ,(car cperl-vc-rcs-header)))))
(cond ((boundp 'compilation-error-regexp-alist-alist);; xemacs 20.x
- (make-local-variable 'compilation-error-regexp-alist-alist)
- (set 'compilation-error-regexp-alist-alist
+ (set (make-local-variable 'compilation-error-regexp-alist-alist)
(cons (cons 'cperl (car cperl-compilation-error-regexp-alist))
- (symbol-value 'compilation-error-regexp-alist-alist)))
+ compilation-error-regexp-alist-alist))
(if (fboundp 'compilation-build-compilation-error-regexp-alist)
(let ((f 'compilation-build-compilation-error-regexp-alist))
(funcall f))
(make-local-variable 'compilation-error-regexp-alist)
(push 'cperl compilation-error-regexp-alist)))
((boundp 'compilation-error-regexp-alist);; xemacs 19.x
- (make-local-variable 'compilation-error-regexp-alist)
- (set 'compilation-error-regexp-alist
+ (set (make-local-variable 'compilation-error-regexp-alist)
(append cperl-compilation-error-regexp-alist
- (symbol-value 'compilation-error-regexp-alist)))))
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults
- (cond
- ((string< emacs-version "19.30")
- '(cperl-font-lock-keywords-2 nil nil ((?_ . "w"))))
- ((string< emacs-version "19.33") ; Which one to use?
- '((cperl-font-lock-keywords
- cperl-font-lock-keywords-1
- cperl-font-lock-keywords-2) nil nil ((?_ . "w"))))
- (t
- '((cperl-load-font-lock-keywords
- cperl-load-font-lock-keywords-1
- cperl-load-font-lock-keywords-2) nil nil ((?_ . "w"))))))
- (make-local-variable 'cperl-syntax-state)
- (setq cperl-syntax-state nil) ; reset syntaxification cache
+ compilation-error-regexp-alist))))
+ (set (make-local-variable 'font-lock-defaults)
+ '((cperl-load-font-lock-keywords
+ cperl-load-font-lock-keywords-1
+ cperl-load-font-lock-keywords-2) nil nil ((?_ . "w"))))
+ ;; Reset syntaxification cache.
+ (set (make-local-variable 'cperl-syntax-state) nil)
(if cperl-use-syntax-table-text-property
(if (eval-when-compile (fboundp 'syntax-propertize-rules))
(progn
@@ -1834,21 +1755,19 @@ or as help on variables `cperl-tips', `cperl-problems',
;; to re-apply them.
(setq cperl-syntax-done-to start)
(cperl-fontify-syntaxically end))))
- (make-local-variable 'parse-sexp-lookup-properties)
;; Do not introduce variable if not needed, we check it!
- (set 'parse-sexp-lookup-properties t)
+ (set (make-local-variable 'parse-sexp-lookup-properties) t)
;; Fix broken font-lock:
(or (boundp 'font-lock-unfontify-region-function)
- (set 'font-lock-unfontify-region-function
- 'font-lock-default-unfontify-region))
+ (setq font-lock-unfontify-region-function
+ #'font-lock-default-unfontify-region))
(unless (featurep 'xemacs) ; Our: just a plug for wrong font-lock
- (make-local-variable 'font-lock-unfontify-region-function)
- (set 'font-lock-unfontify-region-function ; not present with old Emacs
- 'cperl-font-lock-unfontify-region-function))
- (make-local-variable 'cperl-syntax-done-to)
- (setq cperl-syntax-done-to nil) ; reset syntaxification cache
- (make-local-variable 'font-lock-syntactic-keywords)
- (setq font-lock-syntactic-keywords
+ (set (make-local-variable 'font-lock-unfontify-region-function)
+ ;; not present with old Emacs
+ #'cperl-font-lock-unfontify-region-function))
+ ;; Reset syntaxification cache.
+ (set (make-local-variable 'cperl-syntax-done-to) nil)
+ (set (make-local-variable 'font-lock-syntactic-keywords)
(if cperl-syntaxify-by-font-lock
'((cperl-fontify-syntaxically))
;; unless font-lock-syntactic-keywords, font-lock (pre-22.1)
@@ -1860,54 +1779,43 @@ or as help on variables `cperl-tips', `cperl-problems',
(progn
(setq cperl-font-lock-multiline t) ; Not localized...
(set (make-local-variable 'font-lock-multiline) t))
- (make-local-variable 'font-lock-fontify-region-function)
- (set 'font-lock-fontify-region-function ; not present with old Emacs
- 'cperl-font-lock-fontify-region-function))
- (make-local-variable 'font-lock-fontify-region-function)
- (set 'font-lock-fontify-region-function ; not present with old Emacs
- 'cperl-font-lock-fontify-region-function)
+ (set (make-local-variable 'font-lock-fontify-region-function)
+ ;; not present with old Emacs
+ #'cperl-font-lock-fontify-region-function))
+ (set (make-local-variable 'font-lock-fontify-region-function)
+ #'cperl-font-lock-fontify-region-function)
(make-local-variable 'cperl-old-style)
- (if (boundp 'normal-auto-fill-function) ; 19.33 and later
- (set (make-local-variable 'normal-auto-fill-function)
- 'cperl-do-auto-fill)
- (or (fboundp 'cperl-old-auto-fill-mode)
- (progn
- (fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode))
- (defun auto-fill-mode (&optional arg)
- (interactive "P")
- (eval '(cperl-old-auto-fill-mode arg)) ; Avoid a warning
- (and auto-fill-function (memq major-mode '(perl-mode cperl-mode))
- (setq auto-fill-function 'cperl-do-auto-fill))))))
- (if (cperl-enable-font-lock)
- (if (cperl-val 'cperl-font-lock)
- (progn (or cperl-faces-init (cperl-init-faces))
- (font-lock-mode 1))))
+ (set (make-local-variable 'normal-auto-fill-function)
+ #'cperl-do-auto-fill)
+ (if (cperl-val 'cperl-font-lock)
+ (progn (or cperl-faces-init (cperl-init-faces))
+ (font-lock-mode 1)))
(set (make-local-variable 'facemenu-add-face-function)
- 'cperl-facemenu-add-face-function) ; XXXX What this guy is for???
+ #'cperl-facemenu-add-face-function) ; XXXX What this guy is for???
(and (boundp 'msb-menu-cond)
(not cperl-msb-fixed)
(cperl-msb-fix))
(if (fboundp 'easy-menu-add)
(easy-menu-add cperl-menu)) ; A NOP in Emacs.
- (run-mode-hooks 'cperl-mode-hook)
(if cperl-hook-after-change
- (add-hook 'after-change-functions 'cperl-after-change-function nil t))
+ (add-hook 'after-change-functions #'cperl-after-change-function nil t))
;; After hooks since fontification will break this
(if cperl-pod-here-scan
(or cperl-syntaxify-by-font-lock
(progn (or cperl-faces-init (cperl-init-faces-weak))
(cperl-find-pods-heres))))
;; Setup Flymake
- (add-hook 'flymake-diagnostic-functions 'perl-flymake nil t))
+ (add-hook 'flymake-diagnostic-functions #'perl-flymake nil t))
;; Fix for perldb - make default reasonable
(defun cperl-db ()
(interactive)
(require 'gud)
+ ;; FIXME: Use `read-string' or `read-shell-command'?
(perldb (read-from-minibuffer "Run perldb (like this): "
(if (consp gud-perldb-history)
(car gud-perldb-history)
- (concat "perl "
+ (concat "perl -d "
(buffer-file-name)))
nil nil
'(gud-perldb-history . 1))))
@@ -1971,24 +1879,24 @@ or as help on variables `cperl-tips', `cperl-problems',
(cperl-make-indent comment-column 1) ; Indent min 1
c)))))
-;;;(defun cperl-comment-indent-fallback ()
-;;; "Is called if the standard comment-search procedure fails.
-;;;Point is at start of real comment."
-;;; (let ((c (current-column)) target cnt prevc)
-;;; (if (= c comment-column) nil
-;;; (setq cnt (skip-chars-backward "[ \t]"))
-;;; (setq target (max (1+ (setq prevc
-;;; (current-column))) ; Else indent at comment column
-;;; comment-column))
-;;; (if (= c comment-column) nil
-;;; (delete-backward-char cnt)
-;;; (while (< prevc target)
-;;; (insert "\t")
-;;; (setq prevc (current-column)))
-;;; (if (> prevc target) (progn (delete-char -1) (setq prevc (current-column))))
-;;; (while (< prevc target)
-;;; (insert " ")
-;;; (setq prevc (current-column)))))))
+;;(defun cperl-comment-indent-fallback ()
+;; "Is called if the standard comment-search procedure fails.
+;;Point is at start of real comment."
+;; (let ((c (current-column)) target cnt prevc)
+;; (if (= c comment-column) nil
+;; (setq cnt (skip-chars-backward " \t"))
+;; (setq target (max (1+ (setq prevc
+;; (current-column))) ; Else indent at comment column
+;; comment-column))
+;; (if (= c comment-column) nil
+;; (delete-backward-char cnt)
+;; (while (< prevc target)
+;; (insert "\t")
+;; (setq prevc (current-column)))
+;; (if (> prevc target) (progn (delete-char -1) (setq prevc (current-column))))
+;; (while (< prevc target)
+;; (insert " ")
+;; (setq prevc (current-column)))))))
(defun cperl-indent-for-comment ()
"Substitute for `indent-for-comment' in CPerl."
@@ -2024,7 +1932,7 @@ char is \"{\", insert extra newline before only if
(interactive "P")
(let (insertpos
(other-end (if (and cperl-electric-parens-mark
- (cperl-mark-active)
+ (region-active-p)
(< (mark) (point)))
(mark)
nil)))
@@ -2096,13 +2004,13 @@ char is \"{\", insert extra newline before only if
(cperl-auto-newline cperl-auto-newline)
(other-end (or end
(if (and cperl-electric-parens-mark
- (cperl-mark-active)
+ (region-active-p)
(> (mark) (point)))
(save-excursion
(goto-char (mark))
(point-marker))
nil)))
- pos after)
+ pos)
(and (cperl-val 'cperl-electric-lbrace-space)
(eq (preceding-char) ?$)
(save-excursion
@@ -2132,9 +2040,8 @@ char is \"{\", insert extra newline before only if
"Insert an opening parenthesis or a matching pair of parentheses.
See `cperl-electric-parens'."
(interactive "P")
- (let ((beg (point-at-bol))
- (other-end (if (and cperl-electric-parens-mark
- (cperl-mark-active)
+ (let ((other-end (if (and cperl-electric-parens-mark
+ (region-active-p)
(> (mark) (point)))
(save-excursion
(goto-char (mark))
@@ -2144,7 +2051,6 @@ See `cperl-electric-parens'."
(memq last-command-event
(append cperl-electric-parens-string nil))
(>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))
- ;;(not (save-excursion (search-backward "#" beg t)))
(if (eq last-command-event ?<)
(progn
;; This code is too electric, see Bug#3943.
@@ -2169,12 +2075,11 @@ See `cperl-electric-parens'."
If not, or if we are not at the end of marking range, would self-insert.
Affected by `cperl-electric-parens'."
(interactive "P")
- (let ((beg (point-at-bol))
- (other-end (if (and cperl-electric-parens-mark
+ (let ((other-end (if (and cperl-electric-parens-mark
(cperl-val 'cperl-electric-parens)
(memq last-command-event
(append cperl-electric-parens-string nil))
- (cperl-mark-active)
+ (region-active-p)
(< (mark) (point)))
(mark)
nil))
@@ -2183,7 +2088,6 @@ Affected by `cperl-electric-parens'."
(cperl-val 'cperl-electric-parens)
(memq last-command-event '( ?\) ?\] ?\} ?\> ))
(>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))
- ;;(not (save-excursion (search-backward "#" beg t)))
)
(progn
(self-insert-command (prefix-numeric-value arg))
@@ -2223,6 +2127,7 @@ to nil."
(save-excursion (or (not (re-search-backward "^=" nil t))
(or
(looking-at "=cut")
+ (looking-at "=end")
(and cperl-use-syntax-table-text-property
(not (eq (get-text-property (point)
'syntax-type)
@@ -2297,7 +2202,7 @@ to nil."
(get-text-property (point) 'in-pod)
(cperl-after-expr-p nil "{;:")
(and (re-search-backward "\\(\\`\n?\\|^\n\\)=\\sw+" (point-min) t)
- (not (looking-at "\n*=cut"))
+ (not (or (looking-at "\n*=cut") (looking-at "\n*=end")))
(or (not cperl-use-syntax-table-text-property)
(eq (get-text-property (point) 'syntax-type) 'pod))))))
(progn
@@ -2316,7 +2221,7 @@ to nil."
nil t)))) ; Only one
(progn
(forward-word-strictly 1)
- (setq name (file-name-base)
+ (setq name (file-name-base (buffer-file-name))
p (point))
(insert " NAME\n\n" name
" - \n\n=head1 SYNOPSIS\n\n\n\n"
@@ -2355,6 +2260,7 @@ to nil."
beg t)))
(save-excursion (or (not (re-search-backward "^=" nil t))
(looking-at "=cut")
+ (looking-at "=end")
(and cperl-use-syntax-table-text-property
(not (eq (get-text-property (point)
'syntax-type)
@@ -2454,7 +2360,7 @@ If in POD, insert appropriate lines."
;; We are after \n now, so look for the rest
(if (looking-at "\\(\\`\n?\\|\n\\)=\\sw+")
(progn
- (setq cut (looking-at "\\(\\`\n?\\|\n\\)=cut\\>"))
+ (setq cut (looking-at "\\(\\`\n?\\|\n\\)=\\(cut\\|end\\)\\>"))
(setq over (looking-at "\\(\\`\n?\\|\n\\)=over\\>"))
t)))
(if (and over
@@ -2622,11 +2528,10 @@ The relative indentation among the lines of the expression are preserved."
Return the amount the indentation changed by."
(let ((case-fold-search nil)
(pos (- (point-max) (point)))
- indent i beg shift-amt)
+ indent i shift-amt)
(setq indent (cperl-calculate-indent parse-data)
i indent)
(beginning-of-line)
- (setq beg (point))
(cond ((or (eq indent nil) (eq indent t))
(setq indent (current-indentation) i nil))
;;((eq indent t) ; Never?
@@ -2653,8 +2558,8 @@ Return the amount the indentation changed by."
(zerop shift-amt))
(if (> (- (point-max) pos) (point))
(goto-char (- (point-max) pos)))
- ;;;(delete-region beg (point))
- ;;;(indent-to indent)
+ ;;(delete-region beg (point))
+ ;;(indent-to indent)
(cperl-make-indent indent)
;; If initial point was within line's indentation,
;; position after the indentation. Else stay at same point in text.
@@ -2672,13 +2577,13 @@ Return the amount the indentation changed by."
(looking-at "[a-zA-Z_][a-zA-Z0-9_]*:[^:]"))))
(defun cperl-get-state (&optional parse-start start-state)
- ;; returns list (START STATE DEPTH PRESTART),
- ;; START is a good place to start parsing, or equal to
- ;; PARSE-START if preset,
- ;; STATE is what is returned by `parse-partial-sexp'.
- ;; DEPTH is true is we are immediately after end of block
- ;; which contains START.
- ;; PRESTART is the position basing on which START was found.
+ "Return list (START STATE DEPTH PRESTART),
+START is a good place to start parsing, or equal to
+PARSE-START if preset,
+STATE is what is returned by `parse-partial-sexp'.
+DEPTH is true is we are immediately after end of block
+which contains START.
+PRESTART is the position basing on which START was found."
(save-excursion
(let ((start-point (point)) depth state start prestart)
(if (and parse-start
@@ -2707,17 +2612,17 @@ Return the amount the indentation changed by."
(defun cperl-beginning-of-property (p prop &optional lim)
"Given that P has a property PROP, find where the property starts.
Will not look before LIM."
- ;;; XXXX What to do at point-max???
+;;; XXXX What to do at point-max???
(or (previous-single-property-change (cperl-1+ p) prop lim)
(point-min))
-;;; (cond ((eq p (point-min))
-;;; p)
-;;; ((and lim (<= p lim))
-;;; p)
-;;; ((not (get-text-property (1- p) prop))
-;;; p)
-;;; (t (or (previous-single-property-change p look-prop lim)
-;;; (point-min))))
+ ;; (cond ((eq p (point-min))
+ ;; p)
+ ;; ((and lim (<= p lim))
+ ;; p)
+ ;; ((not (get-text-property (1- p) prop))
+ ;; p)
+ ;; (t (or (previous-single-property-change p look-prop lim)
+ ;; (point-min))))
)
(defun cperl-sniff-for-indent (&optional parse-data) ; was parse-start
@@ -2887,6 +2792,8 @@ Will not look before LIM."
(cperl-backward-to-noncomment containing-sexp))
;; Now we get non-label preceding the indent point
(if (not (or (eq (1- (point)) containing-sexp)
+ (and cperl-indent-parens-as-block
+ (not is-block))
(memq (preceding-char)
(append (if is-block " ;{" " ,;{") '(nil)))
(and (eq (preceding-char) ?\})
@@ -2962,12 +2869,13 @@ Will not look before LIM."
;; first thing on the line, say in the case of
;; anonymous sub in a hash.
(if (and;; Is it a sub in group starting on this line?
+ cperl-indent-subs-specially
(cond ((get-text-property (point) 'attrib-group)
(goto-char (cperl-beginning-of-property
(point) 'attrib-group)))
((eq (preceding-char) ?b)
(forward-sexp -1)
- (looking-at "sub\\>")))
+ (looking-at (concat cperl-sub-regexp "\\>"))))
(setq p (nth 1 ; start of innermost containing list
(parse-partial-sexp
(point-at-bol)
@@ -3001,7 +2909,10 @@ Will not look before LIM."
"Alist of indentation rules for CPerl mode.
The values mean:
nil: do not indent;
- number: add this amount of indentation.")
+ FUNCTION: a function to compute the indentation to use.
+ Takes a single argument which provides the currently computed indentation
+ context, and should return the column to which to indent.
+ NUMBER: add this amount of indentation.")
(defun cperl-calculate-indent (&optional parse-data) ; was parse-start
"Return appropriate indentation for current line as Perl code.
@@ -3020,7 +2931,11 @@ and closing parentheses and brackets."
((vectorp i)
(setq what (assoc (elt i 0) cperl-indent-rules-alist))
(cond
- (what (cadr what)) ; Load from table
+ (what
+ (let ((action (cadr what)))
+ (cond ((functionp action) (apply action (list i parse-data)))
+ ((numberp action) (+ action (current-indentation)))
+ (t action))))
;;
;; Indenters for regular expressions with //x and qw()
;;
@@ -3184,7 +3099,7 @@ and closing parentheses and brackets."
(defun cperl-calculate-indent-within-comment ()
"Return the indentation amount for line, assuming that
the current line is to be regarded as part of a block comment."
- (let (end star-start)
+ (let (end)
(save-excursion
(beginning-of-line)
(skip-chars-forward " \t")
@@ -3230,12 +3145,12 @@ Returns true if comment is found. In POD will not move the point."
(cond
((looking-at "\\(s\\|tr\\)\\>")
(or (re-search-forward
- "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*"
+ "\\=\\w+[ \t]*#\\([^\n\\#]\\|\\\\[\\#]\\)*#\\([^\n\\#]\\|\\\\[\\#]\\)*"
lim 'move)
(setq stop-in t)))
((looking-at "\\(m\\|q\\([qxwr]\\)?\\)\\>")
(or (re-search-forward
- "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#"
+ "\\=\\w+[ \t]*#\\([^\n\\#]\\|\\\\[\\#]\\)*#"
lim 'move)
(setq stop-in t)))
(t ; It was fair comment
@@ -3442,8 +3357,8 @@ Works before syntax recognition is done."
(or now (put-text-property b e 'cperl-postpone (cons type val)))
(put-text-property b e type val)))
-;;; Here is how the global structures (those which cannot be
-;;; recognized locally) are marked:
+;; Here is how the global structures (those which cannot be
+;; recognized locally) are marked:
;; a) PODs:
;; Start-to-end is marked `in-pod' ==> t
;; Each non-literal part is marked `syntax-type' ==> `pod'
@@ -3463,17 +3378,16 @@ Works before syntax recognition is done."
;; (or 0 if declaration); up to `{' or ';': `syntax-type' => `sub-decl'.
;; f) Multiline my/our declaration lists etc: `syntax-type' => `multiline'
-;;; In addition, some parts of RExes may be marked as `REx-interpolated'
-;;; (value: 0 in //o, 1 if "interpolated variable" is whole-REx, t otherwise).
+;; In addition, some parts of RExes may be marked as `REx-interpolated'
+;; (value: 0 in //o, 1 if "interpolated variable" is whole-REx, t otherwise).
(defun cperl-unwind-to-safe (before &optional end)
;; if BEFORE, go to the previous start-of-line on each step of unwinding
- (let ((pos (point)) opos)
+ (let ((pos (point)))
(while (and pos (progn
(beginning-of-line)
(get-text-property (setq pos (point)) 'syntax-type)))
- (setq opos pos
- pos (cperl-beginning-of-property pos 'syntax-type))
+ (setq pos (cperl-beginning-of-property pos 'syntax-type))
(if (eq pos (point-min))
(setq pos nil))
(if pos
@@ -3502,7 +3416,7 @@ Works before syntax recognition is done."
(setq end (point)))))
(or end pos)))))
-;;; These are needed for byte-compile (at least with v19)
+;; These are needed for byte-compile (at least with v19)
(defvar cperl-nonoverridable-face)
(defvar font-lock-variable-name-face)
(defvar font-lock-function-name-face)
@@ -3517,7 +3431,7 @@ Works before syntax recognition is done."
Should be called with the point before leading colon of an attribute."
;; Works *before* syntax recognition is done
(or st-l (setq st-l (list nil))) ; Avoid overwriting '()
- (let (st b p reset-st after-first (start (point)) start1 end1)
+ (let (st p reset-st after-first (start (point)) start1 end1)
(condition-case b
(while (looking-at
(concat
@@ -3593,18 +3507,18 @@ Should be called with the point before leading colon of an attribute."
(defsubst cperl-highlight-charclass (endbracket dashface bsface onec-space)
(let ((l '(1 5 7)) ll lle lll
;; 2 groups, the first takes the whole match (include \[trnfabe])
- (singleChar (concat "\\(" "[^\\\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)")))
+ (singleChar (concat "\\(" "[^\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)")))
(while ; look for unescaped - between non-classes
(re-search-forward
;; On 19.33, certain simplifications lead
;; to bugs (as in [^a-z] \\| [trnfabe] )
(concat ; 1: SingleChar (include \[trnfabe])
singleChar
- ;;"\\(" "[^\\\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)"
+ ;;"\\(" "[^\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)"
"\\(" ; 3: DASH SingleChar (match optionally)
"\\(-\\)" ; 4: DASH
singleChar ; 5: SingleChar
- ;;"\\(" "[^\\\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)"
+ ;;"\\(" "[^\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)"
"\\)?"
"\\|"
"\\(" ; 7: other escapes
@@ -3618,7 +3532,8 @@ Should be called with the point before leading colon of an attribute."
'face dashface))
;; save match data (for looking-at)
(setq lll (mapcar (function (lambda (elt) (cons (match-beginning elt)
- (match-end elt)))) l))
+ (match-end elt))))
+ l))
(while lll
(setq ll (car lll))
(setq lle (cdr ll)
@@ -3636,7 +3551,7 @@ Should be called with the point before leading colon of an attribute."
(goto-char endbracket) ; just in case something misbehaves???
t))
-;;; Debugging this may require (setq max-specpdl-size 2000)...
+;; Debugging this may require (setq max-specpdl-size 2000)...
(defun cperl-find-pods-heres (&optional min max non-inter end ignore-max end-of-here-doc)
"Scans the buffer for hard-to-parse Perl constructions.
If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify
@@ -3746,7 +3661,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
"\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob>
"\\|"
;; 1+6+2+1+1=11 extra () before this
- "\\<sub\\>" ; sub with proto/attr
+ "\\<" cperl-sub-regexp "\\>" ; sub with proto/attr
"\\("
cperl-white-and-comment-rex
"\\(::[a-zA-Z_:'0-9]*\\|[a-zA-Z_'][a-zA-Z_:'0-9]*\\)\\)?" ; name
@@ -3759,7 +3674,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
"\\|"
;; 1+6+2+1+1+6+1=18 extra () before this (old pack'var syntax;
;; we do not support intervening comments...):
- "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'"
+ "\\(\\<" cperl-sub-regexp "[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'"
;; 1+6+2+1+1+6+1+1=19 extra () before this:
"\\|"
"__\\(END\\|DATA\\)__" ; __END__ or __DATA__
@@ -3834,7 +3749,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
state-point b nil nil state)
state-point b)
(if (or (nth 3 state) (nth 4 state)
- (looking-at "cut\\>"))
+ (looking-at "\\(cut\\|end\\)\\>"))
(if (or (nth 3 state) (nth 4 state) ignore-max)
nil ; Doing a chunk only
(message "=cut is not preceded by a POD section")
@@ -3847,10 +3762,10 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
b1 nil) ; error condition
;; We do not search to max, since we may be called from
;; some hook of fontification, and max is random
- (or (re-search-forward "^\n=cut\\>" stop-point 'toend)
+ (or (re-search-forward "^\n=\\(cut\\|end\\)\\>" stop-point 'toend)
(progn
(goto-char b)
- (if (re-search-forward "\n=cut\\>" stop-point 'toend)
+ (if (re-search-forward "\n=\\(cut\\|end\\)\\>" stop-point 'toend)
(progn
(message "=cut is not preceded by an empty line")
(setq b1 t)
@@ -3957,7 +3872,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
(progn
(forward-sexp -2)
(not
- (looking-at "\\(printf?\\|system\\|exec\\|sort\\)\\>")))
+ (looking-at "\\(printf?\\|say\\|system\\|exec\\|sort\\)\\>")))
(error t)))))))
(error nil))) ; func(<<EOF)
(and (not (match-beginning 6)) ; Empty
@@ -4141,7 +4056,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
(not (memq (preceding-char)
'(?$ ?@ ?& ?%)))
(looking-at
- "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>")))))
+ "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\|say\\)\\>")))))
(and (eq (preceding-char) ?.)
(eq (char-after (- (point) 2)) ?.))
(bobp))
@@ -4539,14 +4454,14 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
(setq REx-subgr-end qtag) ;End smart-highlighted
;; Apparently, I can't put \] into a charclass
;; in m]]: m][\\\]\]] produces [\\]]
-;;; POSIX? [:word:] [:^word:] only inside []
-;;; "\\=\\(\\\\.\\|[^][\\\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]")
+;;; POSIX? [:word:] [:^word:] only inside []
+;;; "\\=\\(\\\\.\\|[^][\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]")
(while ; look for unescaped ]
(and argument
(re-search-forward
(if (eq (char-after b) ?\] )
- "\\=\\(\\\\[^]]\\|[^]\\\\]\\)*\\\\]"
- "\\=\\(\\\\.\\|[^]\\\\]\\)*]")
+ "\\=\\(\\\\[^]]\\|[^]\\]\\)*\\\\]"
+ "\\=\\(\\\\.\\|[^]\\]\\)*]")
(1- e) 'toend))
;; Is this ] an end of POSIX class?
(if (save-excursion
@@ -4665,7 +4580,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
;; Works also if the outside delimiters are ().
(or;;(if (eq (char-after b) ?\) )
;;(re-search-forward
- ;; "[^\\\\]\\(\\\\\\\\\\)*\\\\)"
+ ;; "[^\\]\\(\\\\\\\\\\)*\\\\)"
;; (1- e) 'toend)
(search-forward ")" (1- e) 'toend)
;;)
@@ -4797,8 +4712,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
(setq stop t))))))
;; Used only in `cperl-calculate-indent'...
-(defun cperl-block-p () ; Do not C-M-q ! One string contains ";" !
- ;; Positions is before ?\{. Checks whether it starts a block.
+(defun cperl-block-p ()
+ "Point is before ?\\{. Checks whether it starts a block."
;; No save-excursion! This is more a distinguisher of a block/hash ref...
(cperl-backward-to-noncomment (point-min))
(or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at bobp
@@ -4817,14 +4732,14 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
(and (eq (preceding-char) ?b)
(progn
(forward-sexp -1)
- (looking-at "sub[ \t\n\f#]")))))))))
-
-;;; What is the difference of (cperl-after-block-p lim t) and (cperl-block-p)?
-;;; No save-excursion; condition-case ... In (cperl-block-p) the block
-;;; may be a part of an in-statement construct, such as
-;;; ${something()}, print {FH} $data.
-;;; Moreover, one takes positive approach (looks for else,grep etc)
-;;; another negative (looks for bless,tr etc)
+ (looking-at (concat cperl-sub-regexp "[ \t\n\f#]"))))))))))
+
+;; What is the difference of (cperl-after-block-p lim t) and (cperl-block-p)?
+;; No save-excursion; condition-case ... In (cperl-block-p) the block
+;; may be a part of an in-statement construct, such as
+;; ${something()}, print {FH} $data.
+;; Moreover, one takes positive approach (looks for else,grep etc)
+;; another negative (looks for bless,tr etc)
(defun cperl-after-block-p (lim &optional pre-block)
"Return true if the preceding } (if PRE-BLOCK, following {) delimits a block.
Would not look before LIM. Assumes that LIM is a good place to begin a
@@ -4846,15 +4761,16 @@ statement would start; thus the block in ${func()} does not count."
(save-excursion
(forward-sexp -1)
;; else {} but not else::func {}
- (or (and (looking-at "\\(else\\|continue\\|grep\\|map\\|BEGIN\\|END\\|CHECK\\|INIT\\)\\>")
+ (or (and (looking-at "\\(else\\|catch\\|try\\|continue\\|grep\\|map\\|BEGIN\\|END\\|UNITCHECK\\|CHECK\\|INIT\\)\\>")
(not (looking-at "\\(\\sw\\|_\\)+::")))
;; sub f {}
(progn
(cperl-backward-to-noncomment lim)
- (and (eq (preceding-char) ?b)
+ (and (cperl-char-ends-sub-keyword-p (preceding-char))
(progn
(forward-sexp -1)
- (looking-at "sub[ \t\n\f#]"))))))
+ (looking-at
+ (concat cperl-sub-regexp "[ \t\n\f#]")))))))
;; What precedes is not word... XXXX Last statement in sub???
(cperl-after-expr-p lim))))
(error nil))))
@@ -4865,7 +4781,7 @@ TEST is the expression to evaluate at the found position. If absent,
CHARS is a string that contains good characters to have before us (however,
`}' is treated \"smartly\" if it is not in the list)."
(let ((lim (or lim (point-min)))
- stop p pr)
+ stop p)
(cperl-update-syntaxification (point) (point))
(save-excursion
(while (and (not stop) (> (point) lim))
@@ -4940,7 +4856,6 @@ CHARS is a string that contains good characters to have before us (however,
(error t))))
(defun cperl-forward-to-end-of-expr (&optional lim)
- (let ((p (point))))
(condition-case nil
(progn
(while (and (< (point) (or lim (point-max)))
@@ -4970,7 +4885,7 @@ CHARS is a string that contains good characters to have before us (however,
(forward-sexp -1)
(not
(looking-at
- "\\(map\\|grep\\|printf?\\|system\\|exec\\|tr\\|s\\)\\>")))))))
+ "\\(map\\|grep\\|say\\|printf?\\|system\\|exec\\|tr\\|s\\)\\>")))))))
(defun cperl-indent-exp ()
@@ -5006,13 +4921,13 @@ conditional/loop constructs."
(if (eq (following-char) ?$ ) ; for my $var (list)
(progn
(forward-sexp -1)
- (if (looking-at "\\(my\\|local\\|our\\)\\>")
+ (if (looking-at "\\(state\\|my\\|local\\|our\\)\\>")
(forward-sexp -1))))
(if (looking-at
- (concat "\\(\\elsif\\|if\\|unless\\|while\\|until"
+ (concat "\\(elsif\\|if\\|unless\\|while\\|until"
"\\|for\\(each\\)?\\>\\(\\("
cperl-maybe-white-and-comment-rex
- "\\(my\\|local\\|our\\)\\)?"
+ "\\(state\\|my\\|local\\|our\\)\\)?"
cperl-maybe-white-and-comment-rex
"\\$[_a-zA-Z0-9]+\\)?\\)\\>"))
(progn
@@ -5088,7 +5003,7 @@ Returns some position at the last line."
;; Looking at:
;; else {
(if (looking-at
- "[ \t]*}?[ \t]*\\<\\(\\els\\(e\\|if\\)\\|continue\\|unless\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]")
+ "[ \t]*}?[ \t]*\\<\\(els\\(e\\|if\\)\\|continue\\|unless\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]")
(progn
(forward-word-strictly 1)
(delete-horizontal-space)
@@ -5097,7 +5012,7 @@ Returns some position at the last line."
;; Looking at:
;; foreach my $var
(if (looking-at
- "[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)\\(\t*\\|[ \t][ \t]+\\)[^ \t\n]")
+ "[ \t]*\\<for\\(each\\)?[ \t]+\\(state\\|my\\|local\\|our\\)\\(\t*\\|[ \t][ \t]+\\)[^ \t\n]")
(progn
(forward-word-strictly 2)
(delete-horizontal-space)
@@ -5106,7 +5021,7 @@ Returns some position at the last line."
;; Looking at:
;; foreach my $var (
(if (looking-at
- "[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)[ \t]*\\$[_a-zA-Z0-9]+\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]")
+ "[ \t]*\\<for\\(each\\)?[ \t]+\\(state\\|my\\|local\\|our\\)[ \t]*\\$[_a-zA-Z0-9]+\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]")
(progn
(forward-sexp 3)
(delete-horizontal-space)
@@ -5116,7 +5031,7 @@ Returns some position at the last line."
;; Looking at (with or without "}" at start, ending after "({"):
;; } foreach my $var () OR {
(if (looking-at
- "[ \t]*\\(}[ \t]*\\)?\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|unless\\|while\\|for\\(each\\)?\\(\\([ \t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{")
+ "[ \t]*\\(}[ \t]*\\)?\\<\\(els\\(e\\|if\\)\\|continue\\|if\\|unless\\|while\\|for\\(each\\)?\\(\\([ \t]+\\(state\\|my\\|local\\|our\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{")
(progn
(setq ml (match-beginning 8)) ; "(" or "{" after control word
(re-search-forward "[({]")
@@ -5237,7 +5152,7 @@ Returns some position at the last line."
(defvar cperl-update-start) ; Do not need to make them local
(defvar cperl-update-end)
-(defun cperl-delay-update-hook (beg end old-len)
+(defun cperl-delay-update-hook (beg end _old-len)
(setq cperl-update-start (min beg (or cperl-update-start (point-max))))
(setq cperl-update-end (max end (or cperl-update-end (point-min)))))
@@ -5254,13 +5169,11 @@ conditional/loop constructs."
(cperl-update-syntaxification end end)
(save-excursion
(let (cperl-update-start cperl-update-end (h-a-c after-change-functions))
- (let ((indent-info (if cperl-emacs-can-parse
- (list nil nil nil) ; Cannot use '(), since will modify
- nil))
- (pm 0)
+ (let ((indent-info (list nil nil nil) ; Cannot use '(), since will modify
+ )
after-change-functions ; Speed it up!
- st comm old-comm-indent new-comm-indent p pp i empty)
- (if h-a-c (add-hook 'after-change-functions 'cperl-delay-update-hook))
+ comm old-comm-indent new-comm-indent i empty)
+ (if h-a-c (add-hook 'after-change-functions #'cperl-delay-update-hook))
(goto-char start)
(setq old-comm-indent (and (cperl-to-comment-or-eol)
(current-column))
@@ -5269,7 +5182,6 @@ conditional/loop constructs."
(setq end (set-marker (make-marker) end)) ; indentation changes pos
(or (bolp) (beginning-of-line 2))
(while (and (<= (point) end) (not (eobp))) ; bol to check start
- (setq st (point))
(if (or
(setq empty (looking-at "[ \t]*\n"))
(and (setq comm (looking-at "[ \t]*#"))
@@ -5455,10 +5367,10 @@ indentation and initial hashes. Behaves usually outside of comment."
(defun cperl-imenu--create-perl-index (&optional regexp)
(require 'imenu) ; May be called from TAGS creator
(let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '())
- (index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function))
+ (index-unsorted-alist '())
(index-meth-alist '()) meth
packages ends-ranges p marker is-proto
- (prev-pos 0) is-pack index index1 name (end-range 0) package)
+ is-pack index index1 name (end-range 0) package)
(goto-char (point-min))
(cperl-update-syntaxification (point-max) (point-max))
;; Search for the function
@@ -5604,7 +5516,7 @@ indentation and initial hashes. Behaves usually outside of comment."
(defun cperl-outline-level ()
(looking-at outline-regexp)
(cond ((not (match-beginning 1)) 0) ; beginning-of-file
-;;;; 2=package-group, 5=package-name 8=sub-name 16=head-level
+ ;; 2=package-group, 5=package-name 8=sub-name 16=head-level
((match-beginning 2) 0) ; package
((match-beginning 8) 1) ; sub
((match-beginning 16)
@@ -5627,10 +5539,9 @@ indentation and initial hashes. Behaves usually outside of comment."
(if (memq major-mode '(perl-mode cperl-mode))
(progn
(or cperl-faces-init (cperl-init-faces)))))))
- (if (fboundp 'eval-after-load)
- (eval-after-load
- "ps-print"
- '(or cperl-faces-init (cperl-init-faces)))))))
+ (eval-after-load
+ "ps-print"
+ '(or cperl-faces-init (cperl-init-faces))))))
(defvar cperl-font-lock-keywords-1 nil
"Additional expressions to highlight in Perl mode. Minimal set.")
@@ -5679,12 +5590,21 @@ indentation and initial hashes. Behaves usually outside of comment."
(cons
(concat
"\\(^\\|[^$@%&\\]\\)\\<\\("
+ ;; FIXME: Use regexp-opt.
(mapconcat
- 'identity
- '("if" "until" "while" "elsif" "else" "unless" "for"
+ #'identity
+ (append
+ cperl-sub-keywords
+ '("if" "until" "while" "elsif" "else"
+ "given" "when" "default" "break"
+ "unless" "for"
+ "try" "catch" "finally"
"foreach" "continue" "exit" "die" "last" "goto" "next"
- "redo" "return" "local" "exec" "sub" "do" "dump" "use" "our"
- "require" "package" "eval" "my" "BEGIN" "END" "CHECK" "INIT")
+ "redo" "return" "local" "exec"
+ "do" "dump"
+ "use" "our"
+ "require" "package" "eval" "evalbytes" "my" "state"
+ "BEGIN" "END" "CHECK" "INIT" "UNITCHECK"))
"\\|") ; Flow control
"\\)\\>") 2) ; was "\\)[ \n\t;():,|&]"
; In what follows we use `type' style
@@ -5692,13 +5612,14 @@ indentation and initial hashes. Behaves usually outside of comment."
(list
(concat
"\\(^\\|[^$@%&\\]\\)\\<\\("
- ;; "CORE" "__FILE__" "__LINE__" "abs" "accept" "alarm"
+ ;; FIXME: Use regexp-opt.
+ ;; "CORE" "__FILE__" "__LINE__" "__SUB__" "abs" "accept" "alarm"
;; "and" "atan2" "bind" "binmode" "bless" "caller"
;; "chdir" "chmod" "chown" "chr" "chroot" "close"
;; "closedir" "cmp" "connect" "continue" "cos" "crypt"
;; "dbmclose" "dbmopen" "die" "dump" "endgrent"
;; "endhostent" "endnetent" "endprotoent" "endpwent"
- ;; "endservent" "eof" "eq" "exec" "exit" "exp" "fcntl"
+ ;; "endservent" "eof" "eq" "exec" "exit" "exp" "fc" "fcntl"
;; "fileno" "flock" "fork" "formline" "ge" "getc"
;; "getgrent" "getgrgid" "getgrnam" "gethostbyaddr"
;; "gethostbyname" "gethostent" "getlogin"
@@ -5721,7 +5642,7 @@ indentation and initial hashes. Behaves usually outside of comment."
;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite"
;; "shutdown" "sin" "sleep" "socket" "socketpair"
;; "sprintf" "sqrt" "srand" "stat" "substr" "symlink"
- ;; "syscall" "sysopen" "sysread" "system" "syswrite" "tell"
+ ;; "syscall" "sysopen" "sysread" "sysseek" "system" "syswrite" "tell"
;; "telldir" "time" "times" "truncate" "uc" "ucfirst"
;; "umask" "unlink" "unpack" "utime" "values" "vec"
;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor"
@@ -5732,7 +5653,7 @@ indentation and initial hashes. Behaves usually outside of comment."
"CORE\\|d\\(ie\\|bm\\(close\\|open\\)\\|ump\\)\\|"
"e\\(x\\(p\\|it\\|ec\\)\\|q\\|nd\\(p\\(rotoent\\|went\\)\\|"
"hostent\\|servent\\|netent\\|grent\\)\\|of\\)\\|"
- "f\\(ileno\\|cntl\\|lock\\|or\\(k\\|mline\\)\\)\\|"
+ "f\\(ileno\\|c\\(ntl\\)?\\|lock\\|or\\(k\\|mline\\)\\)\\|"
"g\\(t\\|lob\\|mtime\\|e\\(\\|t\\(p\\(pid\\|r\\(iority\\|"
"oto\\(byn\\(ame\\|umber\\)\\|ent\\)\\)\\|eername\\|w"
"\\(uid\\|ent\\|nam\\)\\|grp\\)\\|host\\(by\\(addr\\|name\\)\\|"
@@ -5750,12 +5671,12 @@ indentation and initial hashes. Behaves usually outside of comment."
"\\(iority\\|otoent\\)\\|went\\|grp\\)\\|hostent\\|s\\(ervent\\|"
"ockopt\\)\\|netent\\|grent\\)\\|ek\\(\\|dir\\)\\|lect\\|"
"m\\(ctl\\|op\\|get\\)\\|nd\\)\\|h\\(utdown\\|m\\(read\\|ctl\\|"
- "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|open\\|tem\\|write\\)\\|"
+ "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|open\\|tem\\|write\\|seek\\)\\|"
"mlink\\)\\|in\\|leep\\|ocket\\(pair\\|\\)\\)\\|t\\(runcate\\|"
"ell\\(\\|dir\\)\\|ime\\(\\|s\\)\\)\\|u\\(c\\(\\|first\\)\\|"
"time\\|mask\\|n\\(pack\\|link\\)\\)\\|v\\(alues\\|ec\\)\\|"
"w\\(a\\(rn\\|it\\(pid\\|\\)\\|ntarray\\)\\|rite\\)\\|"
- "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\|PACKAGE__\\)"
+ "x\\(\\|or\\)\\|__\\(FILE\\|LINE\\|PACKAGE\\|SUB\\)__"
"\\)\\>") 2 'font-lock-type-face)
;; In what follows we use `other' style
;; for nonoverwritable builtins
@@ -5763,27 +5684,28 @@ indentation and initial hashes. Behaves usually outside of comment."
(list
(concat
"\\(^\\|[^$@%&\\]\\)\\<\\("
- ;; "AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "INIT" "__END__" "chomp"
- ;; "chop" "defined" "delete" "do" "each" "else" "elsif"
- ;; "eval" "exists" "for" "foreach" "format" "goto"
+ ;; "AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "INIT" "UNITCHECK" "__END__" "chomp"
+ ;; "break" "chop" "default" "defined" "delete" "do" "each" "else" "elsif"
+ ;; "eval" "evalbytes" "exists" "for" "foreach" "format" "given" "goto"
;; "grep" "if" "keys" "last" "local" "map" "my" "next"
- ;; "no" "our" "package" "pop" "pos" "print" "printf" "push"
- ;; "q" "qq" "qw" "qx" "redo" "return" "scalar" "shift"
- ;; "sort" "splice" "split" "study" "sub" "tie" "tr"
+ ;; "no" "our" "package" "pop" "pos" "print" "printf" "prototype" "push"
+ ;; "q" "qq" "qw" "qx" "redo" "return" "say" "scalar" "shift"
+ ;; "sort" "splice" "split" "state" "study" "sub" "tie" "tr"
;; "undef" "unless" "unshift" "untie" "until" "use"
- ;; "while" "y"
- "AUTOLOAD\\|BEGIN\\|CHECK\\|cho\\(p\\|mp\\)\\|d\\(e\\(fined\\|lete\\)\\|"
- "o\\)\\|DESTROY\\|e\\(ach\\|val\\|xists\\|ls\\(e\\|if\\)\\)\\|"
- "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|INIT\\|if\\|keys\\|"
+ ;; "when" "while" "y"
+ "AUTOLOAD\\|BEGIN\\|\\(UNIT\\)?CHECK\\|break\\|c\\(atch\\|ho\\(p\\|mp\\)\\)\\|d\\(e\\(f\\(inally\\|ault\\|ined\\)\\|lete\\)\\|"
+ "o\\)\\|DESTROY\\|e\\(ach\\|val\\(bytes\\)?\\|xists\\|ls\\(e\\|if\\)\\)\\|"
+ "END\\|for\\(\\|each\\|mat\\)\\|g\\(iven\\|rep\\|oto\\)\\|INIT\\|if\\|keys\\|"
"l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|our\\|"
- "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|"
- "q\\(\\|q\\|w\\|x\\|r\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|"
- "calar\\|tudy\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|"
+ "p\\(ackage\\|rototype\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|"
+ "q\\(\\|q\\|w\\|x\\|r\\)\\|re\\(turn\\|do\\)\\|s\\(ay\\|pli\\(ce\\|t\\)\\|"
+ "calar\\|t\\(ate\\|udy\\)\\|ub\\|hift\\|ort\\)\\|t\\(ry?\\|ied?\\)\\|"
"u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|"
- "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually
+ "wh\\(en\\|ile\\)\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually
"\\|[sm]" ; Added manually
- "\\)\\>") 2 'cperl-nonoverridable-face)
- ;; (mapconcat 'identity
+ "\\)\\>")
+ 2 'cperl-nonoverridable-face)
+ ;; (mapconcat #'identity
;; '("#endif" "#else" "#ifdef" "#ifndef" "#if"
;; "#include" "#define" "#undef")
;; "\\|")
@@ -5792,7 +5714,7 @@ indentation and initial hashes. Behaves usually outside of comment."
;; This highlights declarations and definitions differently.
;; We do not try to highlight in the case of attributes:
;; it is already done by `cperl-find-pods-heres'
- (list (concat "\\<sub"
+ (list (concat "\\<" cperl-sub-regexp
cperl-white-and-comment-rex ; whitespace/comments
"\\([^ \n\t{;()]+\\)" ; 2=name (assume non-anonymous)
"\\("
@@ -5814,9 +5736,9 @@ indentation and initial hashes. Behaves usually outside of comment."
(if (eq (char-after (cperl-1- (match-end 0))) ?\{ )
'font-lock-function-name-face
'font-lock-variable-name-face))))
- '("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B;
+ '("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-Z_][a-zA-Z_0-9:]*\\)[ \t;]" ; require A if B;
2 font-lock-function-name-face)
- '("^[ \t]*format[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t]*=[ \t]*$"
+ '("^[ \t]*format[ \t]+\\([a-zA-Z_][a-zA-Z_0-9:]*\\)[ \t]*=[ \t]*$"
1 font-lock-function-name-face)
(cond ((featurep 'font-lock-extra)
'("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
@@ -5834,14 +5756,14 @@ indentation and initial hashes. Behaves usually outside of comment."
font-lock-string-face t)
'("^[ \t]*\\([a-zA-Z0-9_]+[ \t]*:\\)[ \t]*\\($\\|{\\|\\<\\(until\\|while\\|for\\(each\\)?\\|do\\)\\>\\)" 1
font-lock-constant-face) ; labels
- '("\\<\\(continue\\|next\\|last\\|redo\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets
+ '("\\<\\(continue\\|next\\|last\\|redo\\|break\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets
2 font-lock-constant-face)
;; Uncomment to get perl-mode-like vars
;;; '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face)
;;; '("\\([@%]\\|\\$#\\)\\(\\sw+\\)"
;;; (2 (cons font-lock-variable-name-face '(underline))))
(cond ((featurep 'font-lock-extra)
- '("^[ \t]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?"
+ '("^[ \t]*\\(state\\|my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?"
(3 font-lock-variable-name-face)
(4 '(another 4 nil
("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?"
@@ -5850,7 +5772,7 @@ indentation and initial hashes. Behaves usually outside of comment."
nil t))) ; local variables, multiple
(font-lock-anchored
;; 1=my_etc, 2=white? 3=(+white? 4=white? 5=var
- `(,(concat "\\<\\(my\\|local\\|our\\)"
+ `(,(concat "\\<\\(state\\|my\\|local\\|our\\)"
cperl-maybe-white-and-comment-rex
"\\(("
cperl-maybe-white-and-comment-rex
@@ -5898,54 +5820,47 @@ indentation and initial hashes. Behaves usually outside of comment."
'syntax-type 'multiline))
(setq cperl-font-lock-multiline-start nil)))
(3 font-lock-variable-name-face))))
- (t '("^[ \t{}]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)"
+ (t '("^[ \t{}]*\\(state\\|my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)"
3 font-lock-variable-name-face)))
- '("\\<for\\(each\\)?\\([ \t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*("
+ '("\\<for\\(each\\)?\\([ \t]+\\(state\\|my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*("
4 font-lock-variable-name-face)
;; Avoid $!, and s!!, qq!! etc. when not fontifying syntactically
'("\\(?:^\\|[^smywqrx$]\\)\\(!\\)" 1 font-lock-negation-char-face)
'("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend)))
(setq
t-font-lock-keywords-1
- (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock
- ;; not yet as of XEmacs 19.12, works with 21.1.11
- (or
- (not (featurep 'xemacs))
- (string< "21.1.9" emacs-version)
- (and (string< "21.1.10" emacs-version)
- (string< emacs-version "21.1.2")))
- '(
- ("\\(\\([@%]\\|\\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1
- (if (eq (char-after (match-beginning 2)) ?%)
- 'cperl-hash-face
- 'cperl-array-face)
- t) ; arrays and hashes
- ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)"
- 1
- (if (= (- (match-end 2) (match-beginning 2)) 1)
- (if (eq (char-after (match-beginning 3)) ?{)
- 'cperl-hash-face
- 'cperl-array-face) ; arrays and hashes
- font-lock-variable-name-face) ; Just to put something
- t)
- ("\\(@\\|\\$#\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)"
- (1 cperl-array-face)
- (2 font-lock-variable-name-face))
- ("\\(%\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)"
- (1 cperl-hash-face)
- (2 font-lock-variable-name-face))
- ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2")
- ;;; Too much noise from \s* @s[ and friends
- ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)"
- ;;(3 font-lock-function-name-face t t)
- ;;(4
- ;; (if (cperl-slash-is-regexp)
- ;; font-lock-function-name-face 'default) nil t))
- )))
+ '(
+ ("\\(\\([@%]\\|\\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1
+ (if (eq (char-after (match-beginning 2)) ?%)
+ 'cperl-hash-face
+ 'cperl-array-face)
+ t) ; arrays and hashes
+ ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)"
+ 1
+ (if (= (- (match-end 2) (match-beginning 2)) 1)
+ (if (eq (char-after (match-beginning 3)) ?{)
+ 'cperl-hash-face
+ 'cperl-array-face) ; arrays and hashes
+ font-lock-variable-name-face) ; Just to put something
+ t)
+ ("\\(@\\|\\$#\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)"
+ (1 cperl-array-face)
+ (2 font-lock-variable-name-face))
+ ("\\(%\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)"
+ (1 cperl-hash-face)
+ (2 font-lock-variable-name-face))
+;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2")
+;;; Too much noise from \s* @s[ and friends
+ ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)"
+ ;;(3 font-lock-function-name-face t t)
+ ;;(4
+ ;; (if (cperl-slash-is-regexp)
+ ;; font-lock-function-name-face 'default) nil t))
+ ))
(if cperl-highlight-variables-indiscriminately
(setq t-font-lock-keywords-1
(append t-font-lock-keywords-1
- (list '("\\([$*]{?\\sw+\\)" 1
+ (list '("\\([$*]{?\\(?:\\sw+\\|::\\)+\\)" 1
font-lock-variable-name-face)))))
(setq cperl-font-lock-keywords-1
(if cperl-syntaxify-by-font-lock
@@ -6036,13 +5951,6 @@ indentation and initial hashes. Behaves usually outside of comment."
;; Do it the dull way, without choose-color
(defvar cperl-guessed-background nil
"Display characteristics as guessed by cperl.")
- ;; (or (fboundp 'x-color-defined-p)
- ;; (defalias 'x-color-defined-p
- ;; (cond ((fboundp 'color-defined-p) 'color-defined-p)
- ;; ;; XEmacs >= 19.12
- ;; ((fboundp 'valid-color-name-p) 'valid-color-name-p)
- ;; ;; XEmacs 19.11
- ;; (t 'x-valid-color-name-p))))
(cperl-force-face font-lock-constant-face
"Face for constant and label names")
(cperl-force-face font-lock-variable-name-face
@@ -6108,15 +6016,7 @@ indentation and initial hashes. Behaves usually outside of comment."
(let ((background
(if (boundp 'font-lock-background-mode)
font-lock-background-mode
- 'light))
- (face-list (and (fboundp 'face-list) (face-list))))
-;;;; (fset 'cperl-is-face
-;;;; (cond ((fboundp 'find-face)
-;;;; (symbol-function 'find-face))
-;;;; (face-list
-;;;; (function (lambda (face) (member face face-list))))
-;;;; (t
-;;;; (function (lambda (face) (boundp face))))))
+ 'light)))
(defvar cperl-guessed-background
(if (and (boundp 'font-lock-display-type)
(eq font-lock-display-type 'grayscale))
@@ -6155,40 +6055,40 @@ indentation and initial hashes. Behaves usually outside of comment."
(if (x-color-defined-p "orchid1")
"orchid1"
"orange")))))
-;;; (if (cperl-is-face 'font-lock-other-emphasized-face) nil
-;;; (copy-face 'bold-italic 'font-lock-other-emphasized-face)
-;;; (cond
-;;; ((eq background 'light)
-;;; (set-face-background 'font-lock-other-emphasized-face
-;;; (if (x-color-defined-p "lightyellow2")
-;;; "lightyellow2"
-;;; (if (x-color-defined-p "lightyellow")
-;;; "lightyellow"
-;;; "light yellow"))))
-;;; ((eq background 'dark)
-;;; (set-face-background 'font-lock-other-emphasized-face
-;;; (if (x-color-defined-p "navy")
-;;; "navy"
-;;; (if (x-color-defined-p "darkgreen")
-;;; "darkgreen"
-;;; "dark green"))))
-;;; (t (set-face-background 'font-lock-other-emphasized-face "gray90"))))
-;;; (if (cperl-is-face 'font-lock-emphasized-face) nil
-;;; (copy-face 'bold 'font-lock-emphasized-face)
-;;; (cond
-;;; ((eq background 'light)
-;;; (set-face-background 'font-lock-emphasized-face
-;;; (if (x-color-defined-p "lightyellow2")
-;;; "lightyellow2"
-;;; "lightyellow")))
-;;; ((eq background 'dark)
-;;; (set-face-background 'font-lock-emphasized-face
-;;; (if (x-color-defined-p "navy")
-;;; "navy"
-;;; (if (x-color-defined-p "darkgreen")
-;;; "darkgreen"
-;;; "dark green"))))
-;;; (t (set-face-background 'font-lock-emphasized-face "gray90"))))
+ ;; (if (cperl-is-face 'font-lock-other-emphasized-face) nil
+ ;; (copy-face 'bold-italic 'font-lock-other-emphasized-face)
+ ;; (cond
+ ;; ((eq background 'light)
+ ;; (set-face-background 'font-lock-other-emphasized-face
+ ;; (if (x-color-defined-p "lightyellow2")
+ ;; "lightyellow2"
+ ;; (if (x-color-defined-p "lightyellow")
+ ;; "lightyellow"
+ ;; "light yellow"))))
+ ;; ((eq background 'dark)
+ ;; (set-face-background 'font-lock-other-emphasized-face
+ ;; (if (x-color-defined-p "navy")
+ ;; "navy"
+ ;; (if (x-color-defined-p "darkgreen")
+ ;; "darkgreen"
+ ;; "dark green"))))
+ ;; (t (set-face-background 'font-lock-other-emphasized-face "gray90"))))
+ ;; (if (cperl-is-face 'font-lock-emphasized-face) nil
+ ;; (copy-face 'bold 'font-lock-emphasized-face)
+ ;; (cond
+ ;; ((eq background 'light)
+ ;; (set-face-background 'font-lock-emphasized-face
+ ;; (if (x-color-defined-p "lightyellow2")
+ ;; "lightyellow2"
+ ;; "lightyellow")))
+ ;; ((eq background 'dark)
+ ;; (set-face-background 'font-lock-emphasized-face
+ ;; (if (x-color-defined-p "navy")
+ ;; "navy"
+ ;; (if (x-color-defined-p "darkgreen")
+ ;; "darkgreen"
+ ;; "dark green"))))
+ ;; (t (set-face-background 'font-lock-emphasized-face "gray90"))))
(if (cperl-is-face 'font-lock-variable-name-face) nil
(copy-face 'italic 'font-lock-variable-name-face))
(if (cperl-is-face 'font-lock-constant-face) nil
@@ -6237,43 +6137,43 @@ Style of printout regulated by the variable `cperl-ps-print-face-properties'."
(require 'ps-print) ; To get ps-print-face-extension-alist
(let ((ps-print-color-p t)
(ps-print-face-extension-alist ps-print-face-extension-alist))
- (cperl-ps-extend-face-list cperl-ps-print-face-properties)
+ (ps-extend-face-list cperl-ps-print-face-properties)
(ps-print-buffer-with-faces file)))
-;;; (defun cperl-ps-print-init ()
-;;; "Initialization of `ps-print' components for faces used in CPerl."
-;;; ;; Guard against old versions
-;;; (defvar ps-underlined-faces nil)
-;;; (defvar ps-bold-faces nil)
-;;; (defvar ps-italic-faces nil)
-;;; (setq ps-bold-faces
-;;; (append '(font-lock-emphasized-face
-;;; cperl-array-face
-;;; font-lock-keyword-face
-;;; font-lock-variable-name-face
-;;; font-lock-constant-face
-;;; font-lock-reference-face
-;;; font-lock-other-emphasized-face
-;;; cperl-hash-face)
-;;; ps-bold-faces))
-;;; (setq ps-italic-faces
-;;; (append '(cperl-nonoverridable-face
-;;; font-lock-constant-face
-;;; font-lock-reference-face
-;;; font-lock-other-emphasized-face
-;;; cperl-hash-face)
-;;; ps-italic-faces))
-;;; (setq ps-underlined-faces
-;;; (append '(font-lock-emphasized-face
-;;; cperl-array-face
-;;; font-lock-other-emphasized-face
-;;; cperl-hash-face
-;;; cperl-nonoverridable-face font-lock-type-face)
-;;; ps-underlined-faces))
-;;; (cons 'font-lock-type-face ps-underlined-faces))
-
-
-(if (cperl-enable-font-lock) (cperl-windowed-init))
+;; (defun cperl-ps-print-init ()
+;; "Initialization of `ps-print' components for faces used in CPerl."
+;; ;; Guard against old versions
+;; (defvar ps-underlined-faces nil)
+;; (defvar ps-bold-faces nil)
+;; (defvar ps-italic-faces nil)
+;; (setq ps-bold-faces
+;; (append '(font-lock-emphasized-face
+;; cperl-array-face
+;; font-lock-keyword-face
+;; font-lock-variable-name-face
+;; font-lock-constant-face
+;; font-lock-reference-face
+;; font-lock-other-emphasized-face
+;; cperl-hash-face)
+;; ps-bold-faces))
+;; (setq ps-italic-faces
+;; (append '(cperl-nonoverridable-face
+;; font-lock-constant-face
+;; font-lock-reference-face
+;; font-lock-other-emphasized-face
+;; cperl-hash-face)
+;; ps-italic-faces))
+;; (setq ps-underlined-faces
+;; (append '(font-lock-emphasized-face
+;; cperl-array-face
+;; font-lock-other-emphasized-face
+;; cperl-hash-face
+;; cperl-nonoverridable-face font-lock-type-face)
+;; ps-underlined-faces))
+;; (cons 'font-lock-type-face ps-underlined-faces))
+
+
+(cperl-windowed-init)
(defconst cperl-styles-entries
'(cperl-indent-level cperl-brace-offset cperl-continued-brace-offset
@@ -6484,16 +6384,14 @@ data already), may be restored by `cperl-set-style-back'.
Choosing \"Current\" style will not change style, so this may be used for
side-effect of memorizing only. Examples in `cperl-style-examples'."
(interactive
- (let ((list (mapcar (function (lambda (elt) (list (car elt))))
- cperl-style-alist)))
- (list (completing-read "Enter style: " list nil 'insist))))
+ (list (completing-read "Enter style: " cperl-style-alist nil 'insist)))
(or cperl-old-style
(setq cperl-old-style
(mapcar (function
(lambda (name)
(cons name (eval name))))
cperl-styles-entries)))
- (let ((style (cdr (assoc style cperl-style-alist))) setting str sym)
+ (let ((style (cdr (assoc style cperl-style-alist))) setting)
(while style
(setq setting (car style) style (cdr style))
(set (car setting) (cdr setting)))))
@@ -6508,6 +6406,7 @@ side-effect of memorizing only. Examples in `cperl-style-examples'."
cperl-old-style (cdr cperl-old-style))
(set (car setting) (cdr setting)))))
+(defvar perl-dbg-flags)
(defun cperl-check-syntax ()
(interactive)
(require 'mode-compile)
@@ -6540,8 +6439,7 @@ side-effect of memorizing only. Examples in `cperl-style-examples'."
(set-buffer "*info-perl-tmp*")
(rename-buffer "*info*")
(set-buffer bname)))
- (make-local-variable 'window-min-height)
- (setq window-min-height 2)
+ (set (make-local-variable 'window-min-height) 2)
(current-buffer)))))
(defun cperl-word-at-point (&optional p)
@@ -6572,8 +6470,7 @@ Customized by setting variables `cperl-shrink-wrap-info-frame',
default
read))))
- (let ((buffer (current-buffer))
- (cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///"
+ (let ((cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///"
pos isvar height iniheight frheight buf win fr1 fr2 iniwin not-loner
max-height char-height buf-list)
(if (string-match "^-[a-zA-Z]$" command)
@@ -6671,9 +6568,9 @@ Opens Perl Info buffer if needed."
(setq imenu-create-index-function
'imenu-default-create-index-function
imenu-prev-index-position-function
- 'cperl-imenu-info-imenu-search
+ #'cperl-imenu-info-imenu-search
imenu-extract-index-name-function
- 'cperl-imenu-info-imenu-name)
+ #'cperl-imenu-info-imenu-name)
(imenu-choose-buffer-index)))))
(and index-item
(progn
@@ -6699,7 +6596,7 @@ If STEP is nil, `cperl-lineup-step' will be used
\(or `cperl-indent-level', if `cperl-lineup-step' is nil).
Will not move the position at the start to the left."
(interactive "r")
- (let (search col tcol seen b)
+ (let (search col tcol seen)
(save-excursion
(goto-char end)
(end-of-line)
@@ -6750,8 +6647,8 @@ in subdirectories too."
(interactive)
(let ((cmd "etags")
(args '("-l" "none" "-r"
- ;; 1=fullname 2=package? 3=name 4=proto? 5=attrs? (VERY APPROX!)
- "/\\<sub[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([ \t]*:[^#{;]*\\)?\\([{#]\\|$\\)/\\3/"
+ ;; 1=fullname 2=package? 3=name 4=proto? 5=attrs? (VERY APPROX!)
+ "/\\<" cperl-sub-regexp "[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([ \t]*:[^#{;]*\\)?\\([{#]\\|$\\)/\\3/"
"-r"
"/\\<package[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\([#;]\\|$\\)/\\1/"
"-r"
@@ -6805,17 +6702,16 @@ in subdirectories too."
(if (cperl-val 'cperl-electric-parens) "" "not ")))
(defun cperl-toggle-autohelp ()
+ ;; FIXME: Turn me into a minor mode. Fix menu entries for "Auto-help on" as
+ ;; well.
"Toggle the state of Auto-Help on Perl constructs (put in the message area).
Delay of auto-help controlled by `cperl-lazy-help-time'."
(interactive)
- (if (fboundp 'run-with-idle-timer)
- (progn
- (if cperl-lazy-installed
- (cperl-lazy-unstall)
- (cperl-lazy-install))
- (message "Perl help messages will %sbe automatically shown now."
- (if cperl-lazy-installed "" "not ")))
- (message "Cannot automatically show Perl help messages - run-with-idle-timer missing.")))
+ (if cperl-lazy-installed
+ (cperl-lazy-unstall)
+ (cperl-lazy-install))
+ (message "Perl help messages will %sbe automatically shown now."
+ (if cperl-lazy-installed "" "not ")))
(defun cperl-toggle-construct-fix ()
"Toggle whether `indent-region'/`indent-sexp' fix whitespace too."
@@ -6844,7 +6740,8 @@ by CPerl."
(interactive "P")
(or arg
(setq arg (if (eq cperl-syntaxify-by-font-lock
- (if backtrace 'backtrace 'message)) 0 1)))
+ (if backtrace 'backtrace 'message))
+ 0 1)))
(setq arg (if (> arg 0) (if backtrace 'backtrace 'message) t))
(setq cperl-syntaxify-by-font-lock arg)
(message "Debugging messages of syntax unwind %sabled."
@@ -6861,9 +6758,8 @@ by CPerl."
(auto-fill-mode 0)
(if cperl-use-syntax-table-text-property-for-tags
(progn
- (make-local-variable 'parse-sexp-lookup-properties)
;; Do not introduce variable if not needed, we check it!
- (set 'parse-sexp-lookup-properties t))))
+ (set (make-local-variable 'parse-sexp-lookup-properties) t))))
;; Copied from imenu-example--name-and-position.
(defvar imenu-use-markers)
@@ -6881,7 +6777,7 @@ Does not move point."
(defun cperl-xsub-scan ()
(require 'imenu)
(let ((index-alist '())
- (prev-pos 0) index index1 name package prefix)
+ index index1 name package prefix)
(goto-char (point-min))
;; Search for the function
(progn ;;save-match-data
@@ -6921,12 +6817,12 @@ Does not move point."
(defun cperl-find-tags (ifile xs topdir)
(let ((b (get-buffer cperl-tmp-buffer)) ind lst elt pos ret rel
- (cperl-pod-here-fontify nil) f file)
+ (cperl-pod-here-fontify nil) file)
(save-excursion
(if b (set-buffer b)
(cperl-setup-tmp-buf))
(erase-buffer)
- (condition-case err
+ (condition-case nil
(setq file (car (insert-file-contents ifile)))
(error (if cperl-unreadable-ok nil
(if (y-or-n-p
@@ -6940,7 +6836,7 @@ Does not move point."
(not xs))
(condition-case err ; after __END__ may have garbage
(cperl-find-pods-heres nil nil noninteractive)
- (error (message "While scanning for syntax: %s" err))))
+ (error (message "While scanning for syntax: %S" err))))
(if xs
(setq lst (cperl-xsub-scan))
(setq ind (cperl-imenu--create-perl-index))
@@ -6980,7 +6876,7 @@ Does not move point."
(number-to-string (1- (elt elt 1))) ; Char pos 0-based
"\n")
(if (and (string-match "^[_a-zA-Z]+::" (car elt))
- (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]"
+ (string-match (concat "^" cperl-sub-regexp "[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]")
(elt elt 3)))
;; Need to insert the name without package as well
(setq lst (cons (cons (substring (elt elt 3)
@@ -7038,7 +6934,7 @@ Use as
(setq topdir default-directory))
(let ((tags-file-name "TAGS")
(case-fold-search (and (featurep 'xemacs) (eq system-type 'emx)))
- xs rel tm)
+ xs rel)
(save-excursion
(cond (inbuffer nil) ; Already there
((file-exists-p tags-file-name)
@@ -7053,7 +6949,7 @@ Use as
(erase-buffer)
(setq erase 'ignore)))
(let ((files
- (condition-case err
+ (condition-case nil
(directory-files file t
(if recurse nil cperl-scan-files-regexp)
t)
@@ -7061,8 +6957,9 @@ Use as
(if cperl-unreadable-ok nil
(if (y-or-n-p
(format "Directory %s unreadable. Continue? " file))
- (setq cperl-unreadable-ok t
- tm nil) ; Return empty list
+ (progn
+ (setq cperl-unreadable-ok t)
+ nil) ; Return empty list
(error "Aborting: unreadable directory %s" file)))))))
(mapc (function
(lambda (file)
@@ -7110,7 +7007,7 @@ Use as
"^\\("
"\\(package\\)\\>"
"\\|"
- "sub\\>[^\n]+::"
+ cperl-sub-regexp "\\>[^\n]+::"
"\\|"
"[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::" ; XSUB?
"\\|"
@@ -7127,10 +7024,9 @@ Use as
(defun cperl-tags-hier-fill ()
;; Suppose we are in a tag table cooked by cperl.
(goto-char 1)
- (let (type pack name pos line chunk ord cons1 file str info fileind)
+ (let (pack name line ord cons1 file info fileind)
(while (re-search-forward cperl-tags-hier-regexp-list nil t)
- (setq pos (match-beginning 0)
- pack (match-beginning 2))
+ (setq pack (match-beginning 2))
(beginning-of-line)
(if (looking-at (concat
"\\([^\n]+\\)"
@@ -7182,7 +7078,7 @@ One may build such TAGS files from CPerl mode menu."
(or (nthcdr 2 elt)
;; Only in one file
(setcdr elt (cdr (nth 1 elt)))))))
- pack name cons1 to l1 l2 l3 l4 b)
+ to l1 l2 l3)
;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later!
(setq cperl-hierarchy (list l1 l2 l3))
(if (featurep 'xemacs) ; Not checked
@@ -7216,10 +7112,9 @@ One may build such TAGS files from CPerl mode menu."
(or (nth 2 cperl-hierarchy)
(error "No items found"))
(setq update
-;;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy))
+ ;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy))
(if (if (fboundp 'display-popup-menus-p)
- (let ((f 'display-popup-menus-p))
- (funcall f))
+ (display-popup-menus-p)
window-system)
(x-popup-menu t (nth 2 cperl-hierarchy))
(require 'tmm)
@@ -7236,22 +7131,20 @@ One may build such TAGS files from CPerl mode menu."
(defun cperl-tags-treeify (to level)
;; cadr of `to' is read-write. On start it is a cons
(let* ((regexp (concat "^\\(" (mapconcat
- 'identity
+ #'identity
(make-list level "[_a-zA-Z0-9]+")
"::")
"\\)\\(::\\)?"))
(packages (cdr (nth 1 to)))
(methods (cdr (nth 2 to)))
- l1 head tail cons1 cons2 ord writeto packs recurse
- root-packages root-functions ms many_ms same_name ps
+ l1 head cons1 cons2 ord writeto recurse
+ root-packages root-functions
(move-deeper
(function
(lambda (elt)
(cond ((and (string-match regexp (car elt))
(or (eq ord 1) (match-end 2)))
(setq head (substring (car elt) 0 (match-end 1))
- tail (if (match-end 2) (substring (car elt)
- (match-end 2)))
recurse t)
(if (setq cons1 (assoc head writeto)) nil
;; Need to init new head
@@ -7278,7 +7171,8 @@ One may build such TAGS files from CPerl mode menu."
;;Now clean up leaders with one child only
(mapc (function (lambda (elt)
(if (not (and (listp (cdr elt))
- (eq (length elt) 2))) nil
+ (eq (length elt) 2)))
+ nil
(setcar elt (car (nth 1 elt)))
(setcdr elt (cdr (nth 1 elt))))))
(cdr to))
@@ -7303,12 +7197,12 @@ One may build such TAGS files from CPerl mode menu."
(sort root-packages (default-value 'imenu-sort-function)))
root-packages))))
-;;;(x-popup-menu t
-;;; '(keymap "Name1"
-;;; ("Ret1" "aa")
-;;; ("Head1" "ab"
-;;; keymap "Name2"
-;;; ("Tail1" "x") ("Tail2" "y"))))
+;;(x-popup-menu t
+;; '(keymap "Name1"
+;; ("Ret1" "aa")
+;; ("Head1" "ab"
+;; keymap "Name2"
+;; ("Tail1" "x") ("Tail2" "y"))))
(defun cperl-list-fold (list name limit)
(let (list1 list2 elt1 (num 0))
@@ -7329,7 +7223,7 @@ One may build such TAGS files from CPerl mode menu."
(nreverse list2))
list1)))))
-(defun cperl-menu-to-keymap (menu &optional name)
+(defun cperl-menu-to-keymap (menu)
(let (list)
(cons 'keymap
(mapcar
@@ -7347,7 +7241,7 @@ One may build such TAGS files from CPerl mode menu."
(defvar cperl-bad-style-regexp
- (mapconcat 'identity
+ (mapconcat #'identity
'("[^-\n\t <>=+!.&|(*/'`\"#^][-=+<>!|&^]" ; char sign
"[-<>=+^&|]+[^- \t\n=+<>~]") ; sign+ char
"\\|")
@@ -7355,7 +7249,7 @@ One may build such TAGS files from CPerl mode menu."
(defvar cperl-not-bad-style-regexp
(mapconcat
- 'identity
+ #'identity
'("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++
"[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used.
"&[(a-zA-Z0-9_$]" ; &subroutine &(var->field)
@@ -7367,11 +7261,12 @@ One may build such TAGS files from CPerl mode menu."
".->" ; a->b
"->" ; a SPACE ->b
"\\[-" ; a[-1]
- "\\\\[&$@*\\\\]" ; \&func
+ "\\\\[&$@*\\]" ; \&func
"^=" ; =head
"\\$." ; $|
"<<[a-zA-Z_'\"`]" ; <<FOO, <<'FOO'
"||"
+ "//"
"&&"
"[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text>
"-[a-zA-Z_0-9]+[ \t]*=>" ; -option => value
@@ -7393,22 +7288,22 @@ Currently it is tuned to C and Perl syntax."
(setq last-nonmenu-event 13) ; To disable popup
(goto-char (point-min))
(map-y-or-n-p "Insert space here? "
- (lambda (arg) (insert " "))
+ (lambda (_) (insert " "))
'cperl-next-bad-style
'("location" "locations" "insert a space into")
- '((?\C-r (lambda (arg)
- (let ((buffer-quit-function
- 'exit-recursive-edit))
- (message "Exit with Esc Esc")
- (recursive-edit)
- t)) ; Consider acted upon
+ `((?\C-r ,(lambda (_)
+ (let ((buffer-quit-function
+ #'exit-recursive-edit))
+ (message "Exit with Esc Esc")
+ (recursive-edit)
+ t)) ; Consider acted upon
"edit, exit with Esc Esc")
- (?e (lambda (arg)
- (let ((buffer-quit-function
- 'exit-recursive-edit))
- (message "Exit with Esc Esc")
- (recursive-edit)
- t)) ; Consider acted upon
+ (?e ,(lambda (_)
+ (let ((buffer-quit-function
+ #'exit-recursive-edit))
+ (message "Exit with Esc Esc")
+ (recursive-edit)
+ t)) ; Consider acted upon
"edit, exit with Esc Esc"))
t)
(if found-bad (goto-char found-bad)
@@ -7416,7 +7311,7 @@ Currently it is tuned to C and Perl syntax."
(message "No appropriate place found"))))
(defun cperl-next-bad-style ()
- (let (p (not-found t) (point (point)) found)
+ (let (p (not-found t) found)
(while (and not-found
(re-search-forward cperl-bad-style-regexp nil 'to-end))
(setq p (point))
@@ -7445,14 +7340,14 @@ Currently it is tuned to C and Perl syntax."
(defvar cperl-have-help-regexp
;;(concat "\\("
(mapconcat
- 'identity
+ #'identity
'("[$@%*&][0-9a-zA-Z_:]+\\([ \t]*[[{]\\)?" ; Usual variable
"[$@]\\^[a-zA-Z]" ; Special variable
"[$@][^ \n\t]" ; Special variable
"-[a-zA-Z]" ; File test
"\\\\[a-zA-Z0]" ; Special chars
"^=[a-z][a-zA-Z0-9_]*" ; POD sections
- "[-!&*+,-./<=>?\\\\^|~]+" ; Operator
+ "[-!&*+,./<=>?\\^|~]+" ; Operator
"[a-zA-Z_0-9:]+" ; symbol or number
"x="
"#!")
@@ -7469,7 +7364,7 @@ Currently it is tuned to C and Perl syntax."
;; Does not save-excursion
;; Get to the something meaningful
(or (eobp) (eolp) (forward-char 1))
- (re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]"
+ (re-search-backward "[-a-zA-Z0-9_:!&*+,./<=>?\\^|~$%@]"
(point-at-bol)
'to-beg)
;; (cond
@@ -7496,8 +7391,8 @@ Currently it is tuned to C and Perl syntax."
(forward-char -1))
((and (looking-at "\\^") (eq (preceding-char) ?\$)) ; $^I
(forward-char -1))
- ((looking-at "[-!&*+,-./<=>?\\\\^|~]")
- (skip-chars-backward "-!&*+,-./<=>?\\\\^|~")
+ ((looking-at "[-!&*+,./<=>?\\^|~]")
+ (skip-chars-backward "-!&*+,./<=>?\\^|~")
(cond
((and (eq (preceding-char) ?\$)
(not (eq (char-after (- (point) 2)) ?\$))) ; $-
@@ -7545,7 +7440,7 @@ than a line. Your contribution to update/shorten it is appreciated."
(defun cperl-describe-perl-symbol (val)
"Display the documentation of symbol at point, a Perl operator."
(let ((enable-recursive-minibuffers t)
- args-file regexp)
+ regexp)
(cond
((string-match "^[&*][a-zA-Z_]" val)
(setq val (concat (substring val 0 1) "NAME")))
@@ -7712,6 +7607,7 @@ $~ The name of the current report format.
... = ... Assignment.
... == ... Numeric equality.
... =~ ... Search pattern, substitution, or translation
+... ~~ .. Smart match
... > ... Numeric greater than.
... >= ... Numeric greater than or equal to.
... >> ... Bitwise shift right.
@@ -7749,6 +7645,7 @@ ARGVOUT Output filehandle with -i flag.
BEGIN { ... } Immediately executed (during compilation) piece of code.
END { ... } Pseudo-subroutine executed after the script finishes.
CHECK { ... } Pseudo-subroutine executed after the script is compiled.
+UNITCHECK { ... }
INIT { ... } Pseudo-subroutine executed before the script starts running.
DATA Input filehandle for what follows after __END__ or __DATA__.
accept(NEWSOCKET,GENERICSOCKET)
@@ -7756,6 +7653,7 @@ alarm(SECONDS)
atan2(X,Y)
bind(SOCKET,NAME)
binmode(FILEHANDLE)
+break Break out of a given/when statement
caller[(LEVEL)]
chdir(EXPR)
chmod(LIST)
@@ -7771,6 +7669,7 @@ cos(EXPR)
crypt(PLAINTEXT,SALT)
dbmclose(%HASH)
dbmopen(%HASH,DBNAME,MODE)
+default { ... } default case for given/when block
defined(EXPR)
delete($HASH{KEY})
die(LIST)
@@ -7787,6 +7686,7 @@ endservent
eof[([FILEHANDLE])]
... eq ... String equality.
eval(EXPR) or eval { BLOCK }
+evalbytes See eval.
exec([TRUENAME] ARGV0, ARGVs) or exec(SHELL_COMMAND_LINE)
exit(EXPR)
exp(EXPR)
@@ -7823,6 +7723,7 @@ getservbyport(PORT,PROTO)
getservent
getsockname(SOCKET)
getsockopt(SOCKET,LEVEL,OPTNAME)
+given (EXPR) { [ when (EXPR) { ... } ]+ [ default { ... } ]? }
gmtime(EXPR)
goto LABEL
... gt ... String greater than.
@@ -7883,6 +7784,7 @@ rewinddir(DIRHANDLE)
rindex(STR,SUBSTR[,OFFSET])
rmdir(FILENAME)
s/PATTERN/REPLACEMENT/gieoxsm
+say [FILEHANDLE] [(LIST)]
scalar(EXPR)
seek(FILEHANDLE,POSITION,WHENCE)
seekdir(DIRHANDLE,POS)
@@ -7917,6 +7819,7 @@ sprintf(FORMAT,LIST)
sqrt(EXPR)
srand(EXPR)
stat(EXPR|FILEHANDLE|VAR)
+state VAR or state (VAR1,...) Introduces a static lexical variable
study[(SCALAR)]
sub [NAME [(format)]] { BODY } sub NAME [(format)]; sub [(format)] {...}
substr(EXPR,OFFSET[,LEN])
@@ -7952,6 +7855,7 @@ x= ... Repetition assignment.
y/SEARCHLIST/REPLACEMENTLIST/
... | ... Bitwise or.
... || ... Logical or.
+... // ... Defined-or.
~ ... Unary bitwise complement.
#! OS interpreter indicator. If contains `perl', used for options, and -x.
AUTOLOAD {...} Shorthand for `sub AUTOLOAD {...}'.
@@ -7972,6 +7876,7 @@ chr Converts a number to char with the same ordinal.
else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}.
elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}.
exists $HASH{KEY} True if the key exists.
+fc EXPR Returns the casefolded version of EXPR.
format [NAME] = Start of output format. Ended by a single dot (.) on a line.
formline PICTURE, LIST Backdoor into \"format\" processing.
glob EXPR Synonym of <EXPR>.
@@ -7983,6 +7888,7 @@ no PACKAGE [SYMBOL1, ...] Partial reverse for `use'. Runs `unimport' method.
not ... Low-precedence synonym for ! - negation.
... or ... Low-precedence synonym for ||.
pos STRING Set/Get end-position of the last match over this string, see \\G.
+prototype FUNC Returns the prototype of a function as a string, or undef.
quotemeta [ EXPR ] Quote regexp metacharacters.
qw/WORD1 .../ Synonym of split(\\='\\=', \\='WORD1 ...\\=')
readline FH Synonym of <FH>.
@@ -8005,6 +7911,8 @@ prototype \\&SUB Returns prototype of the function given a reference.
=back End list.
=cut Switch from POD to Perl.
=pod Switch from Perl to POD.
+=begin Switch from Perl6 to POD.
+=end Switch from POD to Perl6.
")
(defun cperl-switch-to-doc-buffer (&optional interactive)
@@ -8027,7 +7935,7 @@ prototype \\&SUB Returns prototype of the function given a reference.
;; The REx is guaranteed to have //x
;; LEVEL shows how many levels deep to go
;; position at enter and at leave is not defined
- (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code pos)
+ (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline pos)
(if embed
(progn
(goto-char b)
@@ -8223,8 +8131,8 @@ prototype \\&SUB Returns prototype of the function given a reference.
(goto-char (match-end 1))
(re-search-backward "\\s|"))) ; Assume it is scanned already.
;;(forward-char 1)
- (let ((b (point)) (e (make-marker)) have-x delim (c (current-column))
- (sub-p (eq (preceding-char) ?s)) s)
+ (let ((b (point)) (e (make-marker)) have-x delim
+ (sub-p (eq (preceding-char) ?s)))
(forward-sexp 1)
(set-marker e (1- (point)))
(setq delim (preceding-char))
@@ -8237,7 +8145,7 @@ prototype \\&SUB Returns prototype of the function given a reference.
;; Protect fragile " ", "#"
(if have-x nil
(goto-char (1+ b))
- (while (re-search-forward "\\(\\=\\|[^\\\\]\\)\\(\\\\\\\\\\)*[ \t\n#]" e t) ; Need to include (?#) too?
+ (while (re-search-forward "\\(\\=\\|[^\\]\\)\\(\\\\\\\\\\)*[ \t\n#]" e t) ; Need to include (?#) too?
(forward-char -1)
(insert "\\")
(forward-char 1)))
@@ -8266,7 +8174,7 @@ We suppose that the regexp is scanned already."
(error "Cannot find `(' which starts a group"))
(setq done
(save-excursion
- (skip-chars-backward "\\")
+ (skip-chars-backward "\\\\")
(looking-at "\\(\\\\\\\\\\)*(")))
(or done (forward-char -1)))))
@@ -8301,7 +8209,7 @@ We suppose that the regexp is scanned already."
(cperl-regext-to-level-start)
(error ; We are outside outermost group
(goto-char (cperl-make-regexp-x))))
- (let ((b (point)) (e (make-marker)) s c)
+ (let ((b (point)) (e (make-marker)))
(forward-sexp 1)
(set-marker e (1- (point)))
(goto-char (1+ b))
@@ -8513,10 +8421,10 @@ the appropriate statement modifier."
(declare-function Man-getpage-in-background "man" (topic))
-;;; By Anthony Foiani <afoiani@uswest.com>
-;;; Getting help on modules in C-h f ?
-;;; This is a modified version of `man'.
-;;; Need to teach it how to lookup functions
+;; By Anthony Foiani <afoiani@uswest.com>
+;; Getting help on modules in C-h f ?
+;; This is a modified version of `man'.
+;; Need to teach it how to lookup functions
;;;###autoload
(defun cperl-perldoc (word)
"Run `perldoc' on WORD."
@@ -8544,6 +8452,8 @@ the appropriate statement modifier."
(manual-program (if is-func "perldoc -f" "perldoc")))
(cond
((featurep 'xemacs)
+ (defvar Manual-program)
+ (defvar Manual-switches)
(let ((Manual-program "perldoc")
(Manual-switches (if is-func (list "-f"))))
(manual-entry word)))
@@ -8561,7 +8471,7 @@ the appropriate statement modifier."
:type 'file
:group 'cperl)
-;;; By Nick Roberts <Nick.Roberts@src.bae.co.uk> (with changes)
+;; By Nick Roberts <Nick.Roberts@src.bae.co.uk> (with changes)
(defun cperl-pod-to-manpage ()
"Create a virtual manpage in Emacs from the Perl Online Documentation."
(interactive)
@@ -8578,13 +8488,14 @@ the appropriate statement modifier."
(format (cperl-pod2man-build-command) pod2man-args))
'Man-bgproc-sentinel)))))
-;;; Updated version by him too
+;; Updated version by him too
(defun cperl-build-manpage ()
"Create a virtual manpage in Emacs from the POD in the file."
(interactive)
(require 'man)
(cond
((featurep 'xemacs)
+ (defvar Manual-program)
(let ((Manual-program "perldoc"))
(manual-entry buffer-file-name)))
(t
@@ -8641,7 +8552,7 @@ a result of qr//, this is not a performance hit), t for the rest."
(and (eq (get-text-property beg 'syntax-type) 'string)
(setq beg (next-single-property-change beg 'syntax-type nil limit)))
(cperl-map-pods-heres
- (function (lambda (s e p)
+ (function (lambda (s _e _p)
(if (memq (get-text-property s 'REx-interpolated) skip)
t
(setq pp s)
@@ -8650,27 +8561,27 @@ a result of qr//, this is not a performance hit), t for the rest."
(if pp (goto-char pp)
(message "No more interpolated REx"))))
-;;; Initial version contributed by Trey Belew
-(defun cperl-here-doc-spell (&optional beg end)
+;; Initial version contributed by Trey Belew
+(defun cperl-here-doc-spell ()
"Spell-check HERE-documents in the Perl buffer.
If a region is highlighted, restricts to the region."
- (interactive "")
- (cperl-pod-spell t beg end))
+ (interactive)
+ (cperl-pod-spell t))
-(defun cperl-pod-spell (&optional do-heres beg end)
+(defun cperl-pod-spell (&optional do-heres)
"Spell-check POD documentation.
If invoked with prefix argument, will do HERE-DOCs instead.
If a region is highlighted, restricts to the region."
(interactive "P")
(save-excursion
(let (beg end)
- (if (cperl-mark-active)
+ (if (region-active-p)
(setq beg (min (mark) (point))
end (max (mark) (point)))
(setq beg (point-min)
end (point-max)))
(cperl-map-pods-heres (function
- (lambda (s e p)
+ (lambda (s e _p)
(if do-heres
(setq e (save-excursion
(goto-char e)
@@ -8699,7 +8610,7 @@ function returns nil."
(setq cont (funcall func pos posend prop)))
(setq pos posend)))))
-;;; Based on code by Masatake YAMATO:
+;; Based on code by Masatake YAMATO:
(defun cperl-get-here-doc-region (&optional pos pod)
"Return HERE document region around the point.
Return nil if the point is not in a HERE document region. If POD is non-nil,
@@ -8735,7 +8646,7 @@ POS defaults to the point."
(push-mark (cdr p) nil t)) ; Message, activate in transient-mode
(message "I do not think POS is in POD or a HERE-doc..."))))
-(defun cperl-facemenu-add-face-function (face end)
+(defun cperl-facemenu-add-face-function (face _end)
"A callback to process user-initiated font-change requests.
Translates `bold', `italic', and `bold-italic' requests to insertion of
corresponding POD directives, and `underline' to C<> POD directive.
@@ -8748,7 +8659,7 @@ Such requests are usually bound to M-o LETTER."
(italic . "I<")
(bold-italic . "B<I<")
(underline . "C<")))
- (error "Face %s not configured for cperl-mode"
+ (error "Face %S not configured for cperl-mode"
face))))
(defun cperl-time-fontification (&optional l step lim)
@@ -8764,9 +8675,7 @@ start with default arguments, then refine the slowdown regions."
(or l (setq l 1))
(or step (setq step 500))
(or lim (setq lim 40))
- (let* ((timems (function (lambda ()
- (let ((tt (current-time)))
- (+ (* 1000 (nth 1 tt)) (/ (nth 2 tt) 1000))))))
+ (let* ((timems (function (lambda () (car (encode-time nil 1000)))))
(tt (funcall timems)) (c 0) delta tot)
(goto-char (point-min))
(forward-line (1- l))
@@ -8811,61 +8720,52 @@ may be used to debug problems with delayed incremental fontification."
(setq pos p))))
-(defun cperl-lazy-install ()) ; Avoid a warning
-(defun cperl-lazy-unstall ()) ; Avoid a warning
-
-(if (fboundp 'run-with-idle-timer)
- (progn
- (defvar cperl-help-shown nil
- "Non-nil means that the help was already shown now.")
+(defvar cperl-help-shown nil
+ "Non-nil means that the help was already shown now.")
- (defvar cperl-lazy-installed nil
- "Non-nil means that the lazy-help handlers are installed now.")
+(defvar cperl-lazy-installed nil
+ "Non-nil means that the lazy-help handlers are installed now.")
- (defun cperl-lazy-install ()
- "Switches on Auto-Help on Perl constructs (put in the message area).
+;; FIXME: Use eldoc?
+(defun cperl-lazy-install ()
+ "Switch on Auto-Help on Perl constructs (put in the message area).
Delay of auto-help controlled by `cperl-lazy-help-time'."
- (interactive)
- (make-local-variable 'cperl-help-shown)
- (if (and (cperl-val 'cperl-lazy-help-time)
- (not cperl-lazy-installed))
- (progn
- (add-hook 'post-command-hook 'cperl-lazy-hook)
- (run-with-idle-timer
- (cperl-val 'cperl-lazy-help-time 1000000 5)
- t
- 'cperl-get-help-defer)
- (setq cperl-lazy-installed t))))
-
- (defun cperl-lazy-unstall ()
- "Switches off Auto-Help on Perl constructs (put in the message area).
+ (interactive)
+ (make-local-variable 'cperl-help-shown)
+ (if (and (cperl-val 'cperl-lazy-help-time)
+ (not cperl-lazy-installed))
+ (progn
+ (add-hook 'post-command-hook #'cperl-lazy-hook)
+ (run-with-idle-timer
+ (cperl-val 'cperl-lazy-help-time 1000000 5)
+ t
+ #'cperl-get-help-defer)
+ (setq cperl-lazy-installed t))))
+
+(defun cperl-lazy-unstall ()
+ "Switch off Auto-Help on Perl constructs (put in the message area).
Delay of auto-help controlled by `cperl-lazy-help-time'."
- (interactive)
- (remove-hook 'post-command-hook 'cperl-lazy-hook)
- (cancel-function-timers 'cperl-get-help-defer)
- (setq cperl-lazy-installed nil))
+ (interactive)
+ (remove-hook 'post-command-hook #'cperl-lazy-hook)
+ (cancel-function-timers #'cperl-get-help-defer)
+ (setq cperl-lazy-installed nil))
- (defun cperl-lazy-hook ()
- (setq cperl-help-shown nil))
+(defun cperl-lazy-hook ()
+ (setq cperl-help-shown nil))
- (defun cperl-get-help-defer ()
- (if (not (memq major-mode '(perl-mode cperl-mode))) nil
- (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t))
- (cperl-get-help)
- (setq cperl-help-shown t))))
- (cperl-lazy-install)))
+(defun cperl-get-help-defer ()
+ (if (not (memq major-mode '(perl-mode cperl-mode))) nil
+ (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t))
+ (cperl-get-help)
+ (setq cperl-help-shown t))))
+(cperl-lazy-install)
;;; Plug for wrong font-lock:
(defun cperl-font-lock-unfontify-region-function (beg end)
- (let* ((modified (buffer-modified-p)) (buffer-undo-list t)
- (inhibit-read-only t) (inhibit-point-motion-hooks t)
- (inhibit-modification-hooks t)
- deactivate-mark buffer-file-name buffer-file-truename)
- (remove-text-properties beg end '(face nil))
- (if (and (not modified) (buffer-modified-p))
- (set-buffer-modified-p nil))))
+ (with-silent-modifications
+ (remove-text-properties beg end '(face nil))))
(defun cperl-font-lock-fontify-region-function (beg end loudly)
"Extends the region to safe positions, then calls the default function.
@@ -8897,6 +8797,7 @@ do extra unwind via `cperl-unwind-to-safe'."
(font-lock-default-fontify-region beg end loudly))
(defvar cperl-d-l nil)
+(defvar edebug-backtrace-buffer) ;FIXME: Why?
(defun cperl-fontify-syntaxically (end)
;; Some vars for debugging only
;; (message "Syntaxifying...")
@@ -8957,7 +8858,7 @@ do extra unwind via `cperl-unwind-to-safe'."
nil) ; Do not iterate
;; Called when any modification is made to buffer text.
-(defun cperl-after-change-function (beg end old-len)
+(defun cperl-after-change-function (beg _end _old-len)
;; We should have been informed about changes by `font-lock'. Since it
;; does not inform as which calls are deferred, do it ourselves
(if cperl-syntax-done-to
diff --git a/lisp/progmodes/cpp.el b/lisp/progmodes/cpp.el
index d5a8629da02..29988eb14f3 100644
--- a/lisp/progmodes/cpp.el
+++ b/lisp/progmodes/cpp.el
@@ -568,6 +568,14 @@ You can also use the keyboard accelerators indicated like this: [K]ey."
(set-window-start nil start)
(goto-char pos)))
+(defun cpp-locate-user-emacs-file (file)
+ (locate-user-emacs-file
+ ;; Remove initial '.' from file.
+ (if (eq (aref file 0) ?.)
+ (substring file 1)
+ file)
+ file))
+
(defun cpp-edit-load ()
"Load cpp configuration."
(interactive)
@@ -576,8 +584,8 @@ You can also use the keyboard accelerators indicated like this: [K]ey."
nil)
((file-readable-p cpp-config-file)
(load-file cpp-config-file))
- ((file-readable-p (concat "~/" cpp-config-file))
- (load-file cpp-config-file)))
+ ((file-readable-p (cpp-locate-user-emacs-file cpp-config-file))
+ (load-file (cpp-locate-user-emacs-file cpp-config-file))))
(if (derived-mode-p 'cpp-edit-mode)
(cpp-edit-reset)))
@@ -586,7 +594,10 @@ You can also use the keyboard accelerators indicated like this: [K]ey."
(interactive)
(require 'pp)
(with-current-buffer cpp-edit-buffer
- (let ((buffer (find-file-noselect cpp-config-file)))
+ (let* ((config-file (if (file-writable-p cpp-config-file)
+ cpp-config-file
+ (cpp-locate-user-emacs-file cpp-config-file)))
+ (buffer (find-file-noselect config-file)))
(set-buffer buffer)
(erase-buffer)
(pp (list 'setq 'cpp-known-face
@@ -601,7 +612,7 @@ You can also use the keyboard accelerators indicated like this: [K]ey."
(list 'quote cpp-unknown-writable)) buffer)
(pp (list 'setq 'cpp-edit-list
(list 'quote cpp-edit-list)) buffer)
- (write-file cpp-config-file))))
+ (write-file config-file))))
(defun cpp-edit-home ()
"Switch back to original buffer."
@@ -838,8 +849,8 @@ If that option is nil, don't prints messages.
ARGS are the same as for `message'."
(when cpp-message-min-time-interval
(let ((time (current-time)))
- (when (>= (float-time (time-subtract time cpp-progress-time))
- cpp-message-min-time-interval)
+ (unless (time-less-p cpp-message-min-time-interval
+ (time-subtract time cpp-progress-time))
(setq cpp-progress-time time)
(apply 'message args)))))
diff --git a/lisp/progmodes/cwarn.el b/lisp/progmodes/cwarn.el
index a95dffd0e9d..9ed9fb3b396 100644
--- a/lisp/progmodes/cwarn.el
+++ b/lisp/progmodes/cwarn.el
@@ -180,11 +180,7 @@ Suspicious constructs are highlighted using `font-lock-warning-face'.
Note, in addition to enabling this minor mode, the major mode must
be included in the variable `cwarn-configuration'. By default C and
-C++ modes are included.
-
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil."
+C++ modes are included."
:group 'cwarn :lighter cwarn-mode-text
(cwarn-font-lock-keywords cwarn-mode)
(font-lock-flush))
diff --git a/lisp/progmodes/dcl-mode.el b/lisp/progmodes/dcl-mode.el
index 17137cf3036..d5803c77bb4 100644
--- a/lisp/progmodes/dcl-mode.el
+++ b/lisp/progmodes/dcl-mode.el
@@ -1580,7 +1580,7 @@ Find the column of the first non-blank character on the line.
Returns the column offset."
(save-excursion
(beginning-of-line)
- (re-search-forward "^$[ \t]*" nil t)
+ (re-search-forward "^\\$[ \t]*" nil t)
(current-column)))
diff --git a/lisp/progmodes/ebnf-abn.el b/lisp/progmodes/ebnf-abn.el
index ff18c968bfa..b8441a79d98 100644
--- a/lisp/progmodes/ebnf-abn.el
+++ b/lisp/progmodes/ebnf-abn.el
@@ -2,8 +2,8 @@
;; Copyright (C) 2001-2019 Free Software Foundation, Inc.
-;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
-;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
+;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: wp, ebnf, PostScript
;; Old-Version: 1.2
;; Package: ebnf2ps
diff --git a/lisp/progmodes/ebnf-bnf.el b/lisp/progmodes/ebnf-bnf.el
index ed8419214cc..f28f49090d0 100644
--- a/lisp/progmodes/ebnf-bnf.el
+++ b/lisp/progmodes/ebnf-bnf.el
@@ -2,8 +2,8 @@
;; Copyright (C) 1999-2019 Free Software Foundation, Inc.
-;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
-;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
+;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: wp, ebnf, PostScript
;; Old-Version: 1.10
;; Package: ebnf2ps
diff --git a/lisp/progmodes/ebnf-dtd.el b/lisp/progmodes/ebnf-dtd.el
index 735ccbf593d..98284faf297 100644
--- a/lisp/progmodes/ebnf-dtd.el
+++ b/lisp/progmodes/ebnf-dtd.el
@@ -2,8 +2,8 @@
;; Copyright (C) 2001-2019 Free Software Foundation, Inc.
-;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
-;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
+;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: wp, ebnf, PostScript
;; Old-Version: 1.1
;; Package: ebnf2ps
diff --git a/lisp/progmodes/ebnf-ebx.el b/lisp/progmodes/ebnf-ebx.el
index 9261280be16..5f9f9b2c197 100644
--- a/lisp/progmodes/ebnf-ebx.el
+++ b/lisp/progmodes/ebnf-ebx.el
@@ -2,8 +2,8 @@
;; Copyright (C) 2001-2019 Free Software Foundation, Inc.
-;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
-;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
+;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: wp, ebnf, PostScript
;; Old-Version: 1.2
;; Package: ebnf2ps
diff --git a/lisp/progmodes/ebnf-iso.el b/lisp/progmodes/ebnf-iso.el
index 27457682e8b..88644bbe897 100644
--- a/lisp/progmodes/ebnf-iso.el
+++ b/lisp/progmodes/ebnf-iso.el
@@ -2,8 +2,8 @@
;; Copyright (C) 1999-2019 Free Software Foundation, Inc.
-;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
-;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
+;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: wp, ebnf, PostScript
;; Old-Version: 1.9
;; Package: ebnf2ps
diff --git a/lisp/progmodes/ebnf-otz.el b/lisp/progmodes/ebnf-otz.el
index 7b9bd33e4e1..cbc058e4767 100644
--- a/lisp/progmodes/ebnf-otz.el
+++ b/lisp/progmodes/ebnf-otz.el
@@ -2,8 +2,8 @@
;; Copyright (C) 1999-2019 Free Software Foundation, Inc.
-;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
-;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
+;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: wp, ebnf, PostScript
;; Old-Version: 1.0
;; Package: ebnf2ps
diff --git a/lisp/progmodes/ebnf-yac.el b/lisp/progmodes/ebnf-yac.el
index c667ed54d8e..9e712353e99 100644
--- a/lisp/progmodes/ebnf-yac.el
+++ b/lisp/progmodes/ebnf-yac.el
@@ -2,8 +2,8 @@
;; Copyright (C) 1999-2019 Free Software Foundation, Inc.
-;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
-;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
+;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: wp, ebnf, PostScript
;; Old-Version: 1.4
;; Package: ebnf2ps
@@ -392,7 +392,7 @@ See documentation for variable `ebnf-yac-lex'."
(defun ebnf-yac-skip-spaces ()
(skip-chars-forward
(if ebnf-yac-skip-char
- "\n\r\t !#$&()*+-.0123456789=?@[\\\\]^_`~"
+ "-\n\r\t !#$&()*+,.0123456789=?@[\\\\]^_`~"
"\n\r\t ")
ebnf-limit)
(< (point) ebnf-limit))
diff --git a/lisp/progmodes/ebnf2ps.el b/lisp/progmodes/ebnf2ps.el
index 770acc987f6..7e7efacf1e7 100644
--- a/lisp/progmodes/ebnf2ps.el
+++ b/lisp/progmodes/ebnf2ps.el
@@ -1,9 +1,9 @@
-;;; ebnf2ps.el --- translate an EBNF to a syntactic chart on PostScript
+;;; ebnf2ps.el --- translate an EBNF to a syntactic chart on PostScript -*- lexical-binding:t -*-
;; Copyright (C) 1999-2019 Free Software Foundation, Inc.
-;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
-;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
+;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: wp, ebnf, PostScript
;; Version: 4.4
;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
@@ -30,8 +30,7 @@ Vinicius's last change version. When reporting bugs, please also
report the version of Emacs, if any, that ebnf2ps was running with.
Please send all bug fixes and enhancements to
- Vinicius Jose Latorre <viniciusjl@ig.com.br>.
-")
+ Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>.")
;;; Commentary:
@@ -1154,6 +1153,7 @@ Please send all bug fixes and enhancements to
(require 'ps-print)
+(eval-when-compile (require 'cl-lib))
(and (string< ps-print-version "5.2.3")
(error "`ebnf2ps' requires `ps-print' package version 5.2.3 or later"))
@@ -2047,8 +2047,7 @@ It must be a float between 0.0 (top) and 1.0 (bottom)."
(defcustom ebnf-default-width 0.6
- "Specify additional border width over default terminal, non-terminal or
-special."
+ "Additional border width over default terminal, non-terminal or special."
:type 'number
:version "20"
:group 'ebnf2ps)
@@ -2252,7 +2251,7 @@ See also `ebnf-print-buffer'."
(defun ebnf-print-buffer (&optional filename)
"Generate and print a PostScript syntactic chart image of the buffer.
-When called with a numeric prefix argument (C-u), prompts the user for
+When called with a numeric prefix argument (\\[universal-argument]), prompts the user for
the name of a file to save the PostScript image in, instead of sending
it to the printer.
@@ -2383,6 +2382,7 @@ WARNING: This function does *NOT* ask any confirmation to override existing
(ebnf-log-header "(ebnf-eps-buffer)")
(ebnf-eps-region (point-min) (point-max)))
+(defvar ebnf-eps-executing)
;;;###autoload
(defun ebnf-eps-region (from to)
@@ -2411,7 +2411,7 @@ WARNING: This function does *NOT* ask any confirmation to override existing
;;;###autoload
-(defalias 'ebnf-despool 'ps-despool)
+(defalias 'ebnf-despool #'ps-despool)
;;;###autoload
@@ -2611,7 +2611,8 @@ See also `ebnf-syntax-buffer'."
(defvar ebnf-stack-style nil
- "Used in functions `ebnf-reset-style', `ebnf-push-style' and
+ "Stack of styles.
+Used in functions `ebnf-reset-style', `ebnf-push-style' and
`ebnf-pop-style'.")
@@ -3999,7 +4000,7 @@ See documentation for `ebnf-terminal-shape', `ebnf-non-terminal-shape' and
% === end EBNF engine
"
- "EBNF PostScript prologue")
+ "EBNF PostScript prologue.")
(defconst ebnf-eps-prologue
@@ -4276,7 +4277,7 @@ See documentation for `ebnf-terminal-shape', `ebnf-non-terminal-shape' and
}bind def
"
- "EBNF EPS prologue")
+ "EBNF EPS prologue.")
(defconst ebnf-eps-begin
@@ -4292,14 +4293,14 @@ end
%%EndProlog
"
- "EBNF EPS begin")
+ "EBNF EPS begin.")
(defconst ebnf-eps-end
"#ebnf2ps#end
%%EOF
"
- "EBNF EPS end")
+ "EBNF EPS end.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -4329,14 +4330,16 @@ end
;; hacked fom `ps-output-string-prim' (ps-print.el)
(defun ebnf-eps-string (string)
- (let* ((str (string-as-unibyte string))
+ (let* ((str string)
(len (length str))
(index 0)
(new "(") ; insert start-string delimiter
start special)
;; Find and quote special characters as necessary for PS
- ;; This skips everything except control chars, non-ASCII chars, (, ) and \.
- (while (setq start (string-match "[^]-~ -'*-[]" str index))
+ ;; This skips everything except control chars, non-ASCII chars,
+ ;; (, ), \, and DEL.
+ (while (setq start (string-match "[[:cntrl:][:nonascii:]\177()\\]"
+ str index))
(setq special (aref str start)
new (concat new
(substring str index start)
@@ -4536,26 +4539,25 @@ end
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PostScript generation
+(defvar ebnf-tree)
-(defun ebnf-generate-eps (ebnf-tree)
- (let* ((ps-color-p (and ebnf-color-p (ps-color-device)))
+(defun ebnf-generate-eps (tree)
+ (let* ((ebnf-tree tree)
+ (ps-color-p (and ebnf-color-p (ps-color-device)))
(ps-print-color-scale (if ps-color-p
(float (car (ps-color-values "white")))
1.0))
(ebnf-total (length ebnf-tree))
(ebnf-nprod 0)
- (old-ps-output (symbol-function 'ps-output))
- (old-ps-output-string (symbol-function 'ps-output-string))
(eps-buffer (get-buffer-create ebnf-eps-buffer-name))
- ebnf-debug-ps error-msg horizontal
+ ebnf-debug-ps horizontal
prod prod-name prod-width prod-height prod-list file-list)
- ;; redefines `ps-output' and `ps-output-string'
- (defalias 'ps-output 'ebnf-eps-output)
- (defalias 'ps-output-string 'ps-output-string-prim)
;; generate EPS file
- (save-excursion
- (condition-case data
- (progn
+ (unwind-protect
+ ;; redefines `ps-output' and `ps-output-string'
+ (cl-letf (((symbol-function 'ps-output) #'ebnf-eps-output)
+ ((symbol-function 'ps-output-string) #'ps-output-string-prim))
+ (save-excursion
(while ebnf-tree
(setq prod (car ebnf-tree)
prod-name (ebnf-node-name prod)
@@ -4573,8 +4575,9 @@ end
(if (setq prod-list (cdr (assoc prod-name
ebnf-eps-production-list)))
;; insert EPS buffer in all buffer associated with production
- (ebnf-eps-production-list prod-list 'file-list horizontal
- prod-width prod-height eps-buffer)
+ (ebnf-eps-production-list
+ prod-list (gv-ref file-list) horizontal
+ prod-width prod-height eps-buffer)
;; write EPS file for production
(ebnf-eps-finish-and-write eps-buffer
(ebnf-eps-filename prod-name)))
@@ -4584,17 +4587,10 @@ end
(setq ebnf-tree (cdr ebnf-tree)))
;; write and kill temporary buffers
(ebnf-eps-write-kill-temp file-list t)
- (setq file-list nil))
- ;; handler
- ((quit error)
- (setq error-msg (error-message-string data)))))
- ;; restore `ps-output' and `ps-output-string'
- (defalias 'ps-output old-ps-output)
- (defalias 'ps-output-string old-ps-output-string)
- ;; kill temporary buffers
- (kill-buffer eps-buffer)
- (ebnf-eps-write-kill-temp file-list nil)
- (and error-msg (error error-msg))
+ (setq file-list nil)))
+ ;; kill temporary buffers
+ (kill-buffer eps-buffer)
+ (ebnf-eps-write-kill-temp file-list nil))
(message " ")))
@@ -4610,10 +4606,10 @@ end
;; insert EPS buffer in all buffer associated with production
-(defun ebnf-eps-production-list (prod-list file-list-sym horizontal
+(defun ebnf-eps-production-list (prod-list file-list-ref horizontal
prod-width prod-height eps-buffer)
(while prod-list
- (add-to-list file-list-sym (car prod-list))
+ (cl-pushnew (car prod-list) (gv-deref file-list-ref) :test #'equal)
(with-current-buffer (get-buffer-create (concat " *" (car prod-list) "*"))
(goto-char (point-max))
(cond
@@ -4647,8 +4643,9 @@ end
(setq prod-list (cdr prod-list))))
-(defun ebnf-generate (ebnf-tree)
- (let* ((ps-color-p (and ebnf-color-p (ps-color-device)))
+(defun ebnf-generate (tree)
+ (let* ((ebnf-tree tree)
+ (ps-color-p (and ebnf-color-p (ps-color-device)))
(ps-print-color-scale (if ps-color-p
(float (car (ps-color-values "white")))
1.0))
@@ -4658,14 +4655,13 @@ end
ps-print-begin-page-hook
ps-print-begin-column-hook)
(ps-generate (current-buffer) (point-min) (point-max)
- 'ebnf-generate-postscript)))
+ #'ebnf-generate-postscript)))
-(defvar ebnf-tree nil)
(defvar ebnf-direction "R")
-(defun ebnf-generate-postscript (from to)
+(defun ebnf-generate-postscript (_from _to)
(ebnf-begin-file)
(if ebnf-horizontal-max-height
(ebnf-generate-with-max-height)
@@ -5134,7 +5130,7 @@ killed after process termination."
(defsubst ebnf-font-background (font) (nth 3 font))
(defsubst ebnf-font-list (font) (nthcdr 4 font))
(defsubst ebnf-font-attributes (font)
- (lsh (ps-extension-bit (cdr font)) -2))
+ (ash (ps-extension-bit (cdr font)) -2))
(defconst ebnf-font-name-select
@@ -5314,9 +5310,9 @@ killed after process termination."
"\n%%DocumentNeededResources: font "
(or ebnf-fonts-required
(setq ebnf-fonts-required
- (mapconcat 'identity
+ (mapconcat #'identity
(ps-remove-duplicates
- (mapcar 'ebnf-font-name-select
+ (mapcar #'ebnf-font-name-select
(list ebnf-production-font
ebnf-terminal-font
ebnf-non-terminal-font
@@ -5545,7 +5541,7 @@ killed after process termination."
(ebnf-log "(ebnf-dimensions tree)")
(let ((ebnf-total (length tree))
(ebnf-nprod 0))
- (mapc 'ebnf-production-dimension tree))
+ (mapc #'ebnf-production-dimension tree))
tree)
@@ -5925,7 +5921,7 @@ killed after process termination."
))))
-(defun ebnf-justify (node seq seq-width width last-p)
+(defun ebnf-justify (_node seq seq-width width last-p)
(let ((term (car (if last-p (last seq) seq))))
(cond
;; adjust empty term
diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el
index e12434a6689..3faec4959bc 100644
--- a/lisp/progmodes/ebrowse.el
+++ b/lisp/progmodes/ebrowse.el
@@ -1,4 +1,4 @@
-;;; ebrowse.el --- Emacs C++ class browser & tags facility
+;;; ebrowse.el --- Emacs C++ class browser & tags facility -*- lexical-binding:t -*-
;; Copyright (C) 1992-2019 Free Software Foundation, Inc.
@@ -233,30 +233,12 @@ Compare items with `eq' or TEST if specified."
found))
-(defmacro ebrowse-output (&rest body)
- "Eval BODY with a writable current buffer.
-Preserve buffer's modified state."
- (declare (indent 0) (debug t))
- (let ((modified (make-symbol "--ebrowse-output--")))
- `(let (buffer-read-only (,modified (buffer-modified-p)))
- (unwind-protect
- (progn ,@body)
- (set-buffer-modified-p ,modified)))))
-
-
(defmacro ebrowse-ignoring-completion-case (&rest body)
"Eval BODY with `completion-ignore-case' bound to t."
(declare (indent 0) (debug t))
`(let ((completion-ignore-case t))
,@body))
-(defmacro ebrowse-save-selective (&rest body)
- "Eval BODY with `selective-display' restored at the end."
- (declare (indent 0) (debug t))
- ;; FIXME: Don't use selective-display.
- `(let ((selective-display selective-display))
- ,@body))
-
(defmacro ebrowse-for-all-trees (spec &rest body)
"For all trees in SPEC, eval BODY."
(declare (indent 1) (debug ((sexp form) body)))
@@ -303,7 +285,7 @@ If a buffer with name NEW-NAME already exists, delete it first."
(defun ebrowse-trim-string (string)
"Return a copy of STRING with leading white space removed.
Replace sequences of newlines with a single space."
- (when (string-match "^[ \t\n\r]+" string)
+ (when (string-match "^[ \t\n]+" string)
(setq string (substring string (match-end 0))))
(cl-loop while (string-match "[\n]+" string)
finally return string do
@@ -688,7 +670,7 @@ MARKED-ONLY non-nil means include marked classes only."
"Return a list containing all files mentioned in a tree.
MARKED-ONLY non-nil means include marked classes only."
(let (list)
- (maphash (lambda (file _dummy) (setq list (cons file list)))
+ (maphash (lambda (file _dummy) (push file list))
(ebrowse-files-table marked-only))
list))
@@ -865,7 +847,7 @@ and TREE is a list of `ebrowse-ts' structures forming the class tree."
;; Read Lisp objects. Temporarily increase `gc-cons-threshold' to
;; prevent a GC that would not free any memory.
(let ((gc-cons-threshold 2000000))
- (while (not (progn (skip-chars-forward " \t\n\r") (eobp)))
+ (while (not (progn (skip-chars-forward " \t\n") (eobp)))
(let* ((root (read (current-buffer)))
(old-root-ptr (ebrowse-class-in-tree root tree)))
(ebrowse-show-progress "Reading data" (null tree))
@@ -907,8 +889,8 @@ Return the buffer created."
(ebrowse-redraw-tree)
(set-buffer-modified-p nil)
(pcase pop
- (`switch (switch-to-buffer name))
- (`pop (pop-to-buffer name)))
+ ('switch (switch-to-buffer name))
+ ('pop (pop-to-buffer name)))
(current-buffer)))
@@ -996,7 +978,6 @@ if for some reason a circle is in the inheritance graph."
(ebrowse-qualified-class-name
(ebrowse-ts-class (car subclass)))
classes)
- as next = nil
do
;; Replace the subclass tree with the one found in
;; CLASSES if there is already an entry for that class
@@ -1096,8 +1077,7 @@ Tree mode key bindings:
(set (make-local-variable 'ebrowse--frozen-flag) nil)
(setq mode-line-buffer-identification ident)
(setq buffer-read-only t)
- (setq selective-display t)
- (setq selective-display-ellipses t)
+ (add-to-invisibility-spec '(ebrowse . t))
(set (make-local-variable 'revert-buffer-function)
#'ebrowse-revert-tree-buffer-from-file)
(set (make-local-variable 'ebrowse--header) header)
@@ -1107,7 +1087,7 @@ Tree mode key bindings:
(and tree (ebrowse-build-tree-obarray tree)))
(set (make-local-variable 'ebrowse--frozen-flag) nil)
- (add-hook 'local-write-file-hooks 'ebrowse-write-file-hook-fn nil t)
+ (add-hook 'write-file-functions #'ebrowse-write-file-hook-fn nil t)
(modify-syntax-entry ?_ (char-to-string (char-syntax ?a)))
(when tree
(ebrowse-redraw-tree)
@@ -1184,7 +1164,7 @@ If given a numeric N-TIMES argument, mark that many classes."
;; by a regexp replace over the whole buffer. The reason for this
;; is that classes might have multiple base classes. If this is
;; the case, they are displayed more than once in the tree.
- (ebrowse-output
+ (with-silent-modifications
(cl-loop
for tree in to-change
as regexp = (concat "^.*\\b"
@@ -1213,7 +1193,7 @@ If given a numeric N-TIMES argument, mark that many classes."
"Display class marker signs in the tree between START and END."
(interactive)
(save-excursion
- (ebrowse-output
+ (with-silent-modifications
(catch 'end
(goto-char (point-min))
(dolist (root ebrowse--tree)
@@ -1242,8 +1222,8 @@ If given a numeric N-TIMES argument, mark that many classes."
With PREFIX, insert that many filenames."
(interactive "p")
(unless ebrowse--show-file-names-flag
- (ebrowse-output
- (dotimes (i prefix)
+ (with-silent-modifications
+ (dotimes (_ prefix)
(let ((tree (ebrowse-tree-at-point))
start
file-name-existing)
@@ -1393,6 +1373,18 @@ Pop to member buffer if no prefix ARG, to tree buffer otherwise."
+;;; Functions to hide/unhide text
+
+(defun ebrowse--hidden-p (&optional pos)
+ (eq (get-char-property (or pos (point)) 'invisible) 'ebrowse))
+
+(defun ebrowse--hide (start end)
+ (put-text-property start end 'invisible 'ebrowse))
+
+(defun ebrowse--unhide (start end)
+ ;; FIXME: This also removes other invisible properties!
+ (remove-text-properties start end '(invisible)))
+
;;; Misc tree buffer commands
(defun ebrowse-set-tree-indentation ()
@@ -1418,16 +1410,14 @@ Read a class name from the minibuffer if CLASS is nil."
(setf class
(completing-read "Goto class: "
(ebrowse-tree-obarray-as-alist) nil t)))
- (ebrowse-save-selective
- (goto-char (point-min))
- (widen)
- (setf selective-display nil)
- (setq ebrowse--last-regexp (concat "\\b" class "\\b"))
- (if (re-search-forward ebrowse--last-regexp nil t)
- (progn
- (goto-char (match-beginning 0))
- (ebrowse-unhide-base-classes))
- (error "Not found")))))
+ (goto-char (point-min))
+ (widen)
+ (setq ebrowse--last-regexp (concat "\\b" class "\\b"))
+ (if (re-search-forward ebrowse--last-regexp nil t)
+ (progn
+ (goto-char (match-beginning 0))
+ (ebrowse-unhide-base-classes))
+ (error "Not found"))))
@@ -1556,7 +1546,7 @@ and possibly kill the viewed buffer."
(setq original-frame-configuration ebrowse--frame-configuration
exit-action ebrowse--view-exit-action))
;; Delete the frame in which we viewed.
- (mapc 'delete-frame
+ (mapc #'delete-frame
(cl-loop for frame in (frame-list)
when (not (assq frame original-frame-configuration))
collect frame))
@@ -1610,17 +1600,15 @@ specifies where to find/view the result."
(cond (view
(setf ebrowse-temp-position-to-view struc
ebrowse-temp-info-to-view info)
- (unless (boundp 'view-mode-hook)
- (setq view-mode-hook nil))
- (push 'ebrowse-find-pattern view-mode-hook)
+ (add-hook 'view-mode-hook #'ebrowse-find-pattern)
(pcase where
- (`other-window (view-file-other-window file))
- (`other-frame (ebrowse-view-file-other-frame file))
+ ('other-window (view-file-other-window file))
+ ('other-frame (ebrowse-view-file-other-frame file))
(_ (view-file file))))
(t
(pcase where
- (`other-window (find-file-other-window file))
- (`other-frame (find-file-other-frame file))
+ ('other-window (find-file-other-window file))
+ ('other-frame (find-file-other-frame file))
(_ (find-file file)))
(ebrowse-find-pattern struc info))))
@@ -1676,7 +1664,7 @@ a pattern. To be able to do a search in a viewed buffer,
INFO is a list (TREE-HEADER TREE-OR-MEMBER MEMBER-LIST)."
(unless position
- (pop view-mode-hook)
+ (remove-hook 'view-mode-hook #'ebrowse-find-pattern)
(setf viewing t
position ebrowse-temp-position-to-view
info ebrowse-temp-info-to-view))
@@ -1685,7 +1673,7 @@ INFO is a list (TREE-HEADER TREE-OR-MEMBER MEMBER-LIST)."
(start (ebrowse-bs-point position))
(offset 100)
found)
- (pcase-let ((`(,header ,class-or-member ,member-list) info))
+ (pcase-let ((`(,_header ,class-or-member ,member-list) info))
;; If no pattern is specified, construct one from the member name.
(when (stringp pattern)
(setq pattern (concat "^.*" (regexp-quote pattern))))
@@ -1695,9 +1683,9 @@ INFO is a list (TREE-HEADER TREE-OR-MEMBER MEMBER-LIST)."
(ebrowse-ms
(setf pattern
(pcase member-list
- ((or `ebrowse-ts-member-variables
- `ebrowse-ts-static-variables
- `ebrowse-ts-types)
+ ((or 'ebrowse-ts-member-variables
+ 'ebrowse-ts-static-variables
+ 'ebrowse-ts-types)
(ebrowse-variable-declaration-regexp
(ebrowse-bs-name position)))
(_
@@ -1749,7 +1737,7 @@ QUIETLY non-nil means don't display progress messages."
(interactive)
(or quietly (message "Displaying..."))
(save-excursion
- (ebrowse-output
+ (with-silent-modifications
(erase-buffer)
(ebrowse-draw-tree-fn)))
(ebrowse-update-tree-buffer-mode-line)
@@ -1816,7 +1804,8 @@ This function may look weird, but this is faster than recursion."
(nconc (copy-sequence (ebrowse-ts-subclasses tree)) stack2)
stack1
(nconc (make-list (length (ebrowse-ts-subclasses tree))
- (1+ level)) stack1)))))
+ (1+ level))
+ stack1)))))
@@ -1844,69 +1833,60 @@ With prefix ARG, expand all sub-trees."
"Expand or fold all trees in the buffer.
COLLAPSE non-nil means fold them."
(interactive "P")
- (let ((line-end (if collapse "^\n" "^\r"))
- (insertion (if collapse "\r" "\n")))
- (ebrowse-output
+ (with-silent-modifications
+ (if (not collapse)
+ (ebrowse--unhide (point-min) (point-max))
(save-excursion
(goto-char (point-min))
- (while (not (progn (skip-chars-forward line-end) (eobp)))
- (when (or (not collapse)
- (looking-at "\n "))
- (delete-char 1)
- (insert insertion))
- (when collapse
- (skip-chars-forward "\n ")))))))
+ (while (progn (end-of-line) (not (eobp)))
+ (when (looking-at "\n ")
+ (ebrowse--hide (point) (line-end-position 2)))
+ (skip-chars-forward "\n "))))))
(defun ebrowse-unhide-base-classes ()
"Unhide the line the cursor is on and all base classes."
- (ebrowse-output
+ (with-silent-modifications
(save-excursion
(let (indent last-indent)
- (skip-chars-backward "^\r\n")
- (when (not (looking-at "[\r\n][^ \t]"))
- (skip-chars-forward "\r\n \t")
+ (forward-line 0)
+ (when (not (looking-at "\n[^ \t]"))
+ (skip-chars-forward "\n \t")
(while (and (or (null last-indent) ;first time
(> indent 1)) ;not root class
- (re-search-backward "[\r\n][ \t]*" nil t))
+ (re-search-backward "\n[ \t]*" nil t))
(setf indent (- (match-end 0)
(match-beginning 0)))
(when (or (null last-indent)
(< indent last-indent))
(setf last-indent indent)
- (when (looking-at "\r")
- (delete-char 1)
- (insert 10)))
- (backward-char 1)))))))
+ (when (ebrowse--hidden-p)
+ (ebrowse--unhide (point) (line-end-position 2))))))))))
(defun ebrowse-hide-line (collapse)
"Hide/show a single line in the tree.
COLLAPSE non-nil means hide."
- (save-excursion
- (ebrowse-output
- (skip-chars-forward "^\r\n")
- (delete-char 1)
- (insert (if collapse 13 10)))))
+ (with-silent-modifications
+ (funcall (if collapse #'ebrowse--hide #'ebrowse--unhide)
+ (line-end-position) (line-end-position 2))))
(defun ebrowse-collapse-fn (collapse)
"Collapse or expand a branch of the tree.
COLLAPSE non-nil means collapse the branch."
- (ebrowse-output
+ (with-silent-modifications
(save-excursion
(beginning-of-line)
(skip-chars-forward "> \t")
(let ((indentation (current-column)))
(while (and (not (eobp))
(save-excursion
- (skip-chars-forward "^\r\n")
- (goto-char (1+ (point)))
+ (forward-line 1)
(skip-chars-forward "> \t")
(> (current-column) indentation)))
(ebrowse-hide-line collapse)
- (skip-chars-forward "^\r\n")
- (goto-char (1+ (point))))))))
+ (forward-line 1))))))
;;; Electric tree selection
@@ -2164,7 +2144,7 @@ See `Electric-command-loop' for a description of STATE and CONDITION."
;;;###autoload
(define-derived-mode ebrowse-member-mode special-mode "Ebrowse-Members"
"Major mode for Ebrowse member buffers."
- (mapc 'make-local-variable
+ (mapc #'make-local-variable
'(ebrowse--decl-column ;display column
ebrowse--n-columns ;number of short columns
ebrowse--column-width ;width of columns above
@@ -2587,7 +2567,7 @@ TAGS-FILE is the file name of the BROWSE file."
(let ((display-fn (if ebrowse--long-display-flag
'ebrowse-draw-member-long-fn
'ebrowse-draw-member-short-fn)))
- (ebrowse-output
+ (with-silent-modifications
(erase-buffer)
;; Show this class
(ebrowse-draw-member-buffer-class-line)
@@ -2708,7 +2688,7 @@ means the member buffer is standalone. CLASS is its class."
(defun ebrowse-draw-member-long-fn (member-list tree)
"Display member buffer for MEMBER-LIST in long form.
TREE is the class tree of MEMBER-LIST."
- (dolist (member-struc (mapcar 'ebrowse-member-display-p member-list))
+ (dolist (member-struc (mapcar #'ebrowse-member-display-p member-list))
(when member-struc
(let ((name (ebrowse-ms-name member-struc))
(start (point)))
@@ -3172,9 +3152,9 @@ EVENT is the mouse event."
(2 (ebrowse-find-member-definition))
(1 (pcase (get-text-property (posn-point (event-start event))
'ebrowse-what)
- (`member-name
+ ('member-name
(ebrowse-popup-menu ebrowse-member-name-object-menu event))
- (`class-name
+ ('class-name
(ebrowse-popup-menu ebrowse-member-class-name-object-menu event))
(_
(ebrowse-popup-menu ebrowse-member-buffer-object-menu event))))))
@@ -3189,7 +3169,7 @@ EVENT is the mouse event."
(2 (ebrowse-find-member-definition))
(1 (pcase (get-text-property (posn-point (event-start event))
'ebrowse-what)
- (`member-name
+ ('member-name
(ebrowse-view-member-definition 0))))))
@@ -3243,7 +3223,8 @@ from point as default. Value is a list (CLASS-NAME MEMBER-NAME)."
(if members
(let* ((name (ebrowse-ignoring-completion-case
(completing-read prompt members nil nil member-name)))
- (completion-result (try-completion name members)))
+ ;; (completion-result (try-completion name members))
+ )
;; Cannot rely on `try-completion' returning t for exact
;; matches! It returns the name as a string.
(unless (gethash name members)
@@ -3522,12 +3503,12 @@ KIND is an additional string printed in the buffer."
(insert kind)
(indent-to 50)
(insert (pcase (cl-second info)
- (`ebrowse-ts-member-functions "member function")
- (`ebrowse-ts-member-variables "member variable")
- (`ebrowse-ts-static-functions "static function")
- (`ebrowse-ts-static-variables "static variable")
- (`ebrowse-ts-friends (if globals-p "define" "friend"))
- (`ebrowse-ts-types "type")
+ ('ebrowse-ts-member-functions "member function")
+ ('ebrowse-ts-member-variables "member variable")
+ ('ebrowse-ts-static-functions "static function")
+ ('ebrowse-ts-static-variables "static variable")
+ ('ebrowse-ts-friends (if globals-p "define" "friend"))
+ ('ebrowse-ts-types "type")
(_ "unknown"))
"\n")))
@@ -3750,6 +3731,7 @@ looks like a function call to the member."
;; Get the member name NAME (class-name is ignored).
(let ((name fix-name) class-name regexp)
(unless name
+ (ignore class-name) ;Can't use an underscore to silence the warning :-(!
(cl-multiple-value-setq (class-name name)
(cl-values-list (ebrowse-tags-read-name header "Find calls of: "))))
;; Set tags loop form to search for member and begin loop.
@@ -3794,14 +3776,13 @@ If VIEW is non-nil, view the position, otherwise find it."
(find-file (ebrowse-position-file-name position))
(goto-char (ebrowse-position-point position)))
(t
- (unwind-protect
- (progn
- (push (function
- (lambda ()
- (goto-char (ebrowse-position-point position))))
- view-mode-hook)
- (view-file (ebrowse-position-file-name position)))
- (pop view-mode-hook)))))
+ (let ((fn (lambda ()
+ (goto-char (ebrowse-position-point position)))))
+ (unwind-protect
+ (progn
+ (add-hook 'view-mode-hook fn)
+ (view-file (ebrowse-position-file-name position)))
+ (remove-hook 'view-mode-hook fn))))))
(defun ebrowse-push-position (marker info &optional target)
@@ -3904,6 +3885,7 @@ Runs the hook `ebrowse-electric-position-mode-hook'."
(setq mode-line-buffer-identification "Electric Position Menu")
(when (memq 'mode-name mode-line-format)
(setq mode-line-format (copy-sequence mode-line-format))
+ ;; FIXME: Why not set `mode-name' to "Positions"?
(setcar (memq 'mode-name mode-line-format) "Positions"))
(set (make-local-variable 'Helper-return-blurb) "return to buffer editing")
(setq truncate-lines t
@@ -4023,7 +4005,7 @@ If VIEW is non-nil, view else find source files."
(defun ebrowse-write-file-hook-fn ()
"Write current buffer as a class tree.
-Installed on `local-write-file-hooks'."
+Added to `write-file-functions'."
(ebrowse-save-tree)
t)
@@ -4050,7 +4032,7 @@ Otherwise, FILE-NAME specifies the file to save the tree in."
(erase-buffer)
(setf (ebrowse-hs-member-table header) nil)
(insert (prin1-to-string header) " ")
- (mapc 'ebrowse-save-class tree)
+ (mapc #'ebrowse-save-class tree)
(write-file file-name)
(message "Tree written to file `%s'" file-name))
(kill-buffer temp-buffer)
@@ -4065,7 +4047,7 @@ Otherwise, FILE-NAME specifies the file to save the tree in."
(insert "[ebrowse-ts ")
(prin1 (ebrowse-ts-class class)) ;class name
(insert "(") ;list of subclasses
- (mapc 'ebrowse-save-class (ebrowse-ts-subclasses class))
+ (mapc #'ebrowse-save-class (ebrowse-ts-subclasses class))
(insert ")")
(dolist (func ebrowse-member-list-accessors)
(prin1 (funcall func class))
@@ -4252,12 +4234,12 @@ NUMBER-OF-STATIC-VARIABLES:"
(unwind-protect
(progn
(add-hook 'electric-buffer-menu-mode-hook
- 'ebrowse-hack-electric-buffer-menu)
+ #'ebrowse-hack-electric-buffer-menu)
(add-hook 'electric-buffer-menu-mode-hook
- 'ebrowse-install-1-to-9-keys)
+ #'ebrowse-install-1-to-9-keys)
(call-interactively 'electric-buffer-list))
(remove-hook 'electric-buffer-menu-mode-hook
- 'ebrowse-hack-electric-buffer-menu)))
+ #'ebrowse-hack-electric-buffer-menu)))
;;; Mouse support
@@ -4371,7 +4353,7 @@ EVENT is the mouse event."
(pcase (event-click-count event)
(1
(pcase property
- (`class-name
+ ('class-name
(ebrowse-popup-menu ebrowse-tree-buffer-class-object-menu event))
(_
(ebrowse-popup-menu ebrowse-tree-buffer-object-menu event)))))))
@@ -4386,7 +4368,7 @@ EVENT is the mouse event."
(property (get-text-property where 'ebrowse-what)))
(pcase (event-click-count event)
(1 (pcase property
- (`class-name
+ ('class-name
(ebrowse-tree-command:show-member-functions)))))))
@@ -4399,11 +4381,10 @@ EVENT is the mouse event."
(property (get-text-property where 'ebrowse-what)))
(pcase (event-click-count event)
(2 (pcase property
- (`class-name
- (let ((collapsed (save-excursion (skip-chars-forward "^\r\n")
- (looking-at "\r"))))
+ ('class-name
+ (let ((collapsed (ebrowse--hidden-p (line-end-position))))
(ebrowse-collapse-fn (not collapsed))))
- (`mark
+ ('mark
(ebrowse-toggle-mark-at-point 1)))))))
@@ -4411,9 +4392,7 @@ EVENT is the mouse event."
(provide 'ebrowse)
;; Local variables:
-;; eval:(put 'ebrowse-output 'lisp-indent-hook 0)
;; eval:(put 'ebrowse-ignoring-completion-case 'lisp-indent-hook 0)
-;; eval:(put 'ebrowse-save-selective 'lisp-indent-hook 0)
;; eval:(put 'ebrowse-for-all-trees 'lisp-indent-hook 1)
;; End:
diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el
index df6d929ab58..cb1b17b4474 100644
--- a/lisp/progmodes/elisp-mode.el
+++ b/lisp/progmodes/elisp-mode.el
@@ -45,7 +45,7 @@ It has `lisp-mode-abbrev-table' as its parent."
"Syntax table used in `emacs-lisp-mode'.")
(defvar emacs-lisp-mode-map
- (let ((map (make-sparse-keymap "Emacs-Lisp"))
+ (let ((map (make-sparse-keymap))
(menu-map (make-sparse-keymap "Emacs-Lisp"))
(lint-map (make-sparse-keymap))
(prof-map (make-sparse-keymap))
@@ -271,14 +271,14 @@ Blank lines separate paragraphs. Semicolons start comments.
(unless
(setq res
(pcase sexp
- (`(,(or `let `let*) ,bindings)
+ (`(,(or 'let 'let*) ,bindings)
(let ((vars vars))
(when (eq 'let* (car sexp))
(dolist (binding (cdr (reverse bindings)))
(push (or (car-safe binding) binding) vars)))
(elisp--local-variables-1
vars (car (cdr-safe (car (last bindings)))))))
- (`(,(or `let `let*) ,bindings . ,body)
+ (`(,(or 'let 'let*) ,bindings . ,body)
(let ((vars vars))
(dolist (binding bindings)
(push (or (car-safe binding) binding) vars))
@@ -300,7 +300,7 @@ Blank lines separate paragraphs. Semicolons start comments.
;; FIXME: Handle `cond'.
(`(,_ . ,_)
(elisp--local-variables-1 vars (car (last sexp))))
- (`elisp--witness--lisp (or vars '(nil)))
+ ('elisp--witness--lisp (or vars '(nil)))
(_ nil)))
;; We didn't find the witness in the last element so we try to
;; backtrack to the last-but-one.
@@ -541,7 +541,7 @@ functions are annotated with \"<f>\" via the
(pcase parent
;; FIXME: Rather than hardcode special cases here,
;; we should use something like a symbol-property.
- (`declare
+ ('declare
(list t (mapcar (lambda (x) (symbol-name (car x)))
(delete-dups
;; FIXME: We should include some
@@ -549,14 +549,14 @@ functions are annotated with \"<f>\" via the
(append macro-declarations-alist
defun-declarations-alist
nil))))) ; Copy both alists.
- ((and (or `condition-case `condition-case-unless-debug)
+ ((and (or 'condition-case 'condition-case-unless-debug)
(guard (save-excursion
(ignore-errors
(forward-sexp 2)
(< (point) beg)))))
(list t obarray
:predicate (lambda (sym) (get sym 'error-conditions))))
- ((and (or ?\( `let `let*)
+ ((and (or ?\( 'let 'let*)
(guard (save-excursion
(goto-char (1- beg))
(when (eq parent ?\()
@@ -901,10 +901,11 @@ Semicolons start comments.
;;; Emacs Lisp Byte-Code mode
(eval-and-compile
- (defconst emacs-list-byte-code-comment-re
+ (defconst emacs-lisp-byte-code-comment-re
(concat "\\(#\\)@\\([0-9]+\\) "
;; Make sure it's a docstring and not a lazy-loaded byte-code.
- "\\(?:[^(]\\|([^\"]\\)")))
+ "\\(?:[^(]\\|([^\"]\\)")
+ "Regular expression matching a dynamic doc string comment."))
(defun elisp--byte-code-comment (end &optional _point)
"Try to syntactically mark the #@NNN ....^_ docstrings in byte-code files."
@@ -913,7 +914,7 @@ Semicolons start comments.
(eq (char-after (nth 8 ppss)) ?#))
(let* ((n (save-excursion
(goto-char (nth 8 ppss))
- (when (looking-at emacs-list-byte-code-comment-re)
+ (when (looking-at emacs-lisp-byte-code-comment-re)
(string-to-number (match-string 2)))))
;; `maxdiff' tries to make sure the loop below terminates.
(maxdiff n))
@@ -939,7 +940,7 @@ Semicolons start comments.
(elisp--byte-code-comment end (point))
(funcall
(syntax-propertize-rules
- (emacs-list-byte-code-comment-re
+ (emacs-lisp-byte-code-comment-re
(1 (prog1 "< b" (elisp--byte-code-comment end (point))))))
start end))
@@ -1131,7 +1132,9 @@ character)."
(eval-expression-get-print-arguments eval-last-sexp-arg-internal)))
;; Setup the lexical environment if lexical-binding is enabled.
(elisp--eval-last-sexp-print-value
- (eval (eval-sexp-add-defvars (elisp--preceding-sexp)) lexical-binding)
+ (eval (macroexpand-all
+ (eval-sexp-add-defvars (elisp--preceding-sexp)))
+ lexical-binding)
(if insert-value (current-buffer) t) no-truncate char-print-limit)))
(defun elisp--eval-last-sexp-print-value
@@ -1164,7 +1167,6 @@ character)."
(defun eval-sexp-add-defvars (exp &optional pos)
"Prepend EXP with all the `defvar's that precede it in the buffer.
POS specifies the starting position where EXP was found and defaults to point."
- (setq exp (macroexpand-all exp)) ;Eager macro-expansion.
(if (not lexical-binding)
exp
(save-excursion
@@ -1667,6 +1669,16 @@ Calls REPORT-FN directly."
(defvar-local elisp-flymake--byte-compile-process nil
"Buffer-local process started for byte-compiling the buffer.")
+(defvar elisp-flymake-byte-compile-load-path (list "./")
+ "Like `load-path' but used by `elisp-flymake-byte-compile'.
+The default value contains just \"./\" which includes the default
+directory of the buffer being compiled, and nothing else.")
+
+(put 'elisp-flymake-byte-compile-load-path 'safe-local-variable
+ (lambda (x) (and (listp x) (catch 'tag
+ (dolist (path x t) (unless (stringp path)
+ (throw 'tag nil)))))))
+
;;;###autoload
(defun elisp-flymake-byte-compile (report-fn &rest _args)
"A Flymake backend for elisp byte compilation.
@@ -1686,13 +1698,14 @@ current buffer state and calls REPORT-FN when done."
(make-process
:name "elisp-flymake-byte-compile"
:buffer output-buffer
- :command (list (expand-file-name invocation-name invocation-directory)
- "-Q"
- "--batch"
- ;; "--eval" "(setq load-prefer-newer t)" ; for testing
- "-L" default-directory
- "-f" "elisp-flymake--batch-compile-for-flymake"
- temp-file)
+ :command `(,(expand-file-name invocation-name invocation-directory)
+ "-Q"
+ "--batch"
+ ;; "--eval" "(setq load-prefer-newer t)" ; for testing
+ ,@(mapcan (lambda (path) (list "-L" path))
+ elisp-flymake-byte-compile-load-path)
+ "-f" "elisp-flymake--batch-compile-for-flymake"
+ ,temp-file)
:connection-type 'pipe
:sentinel
(lambda (proc _event)
@@ -1714,9 +1727,9 @@ current buffer state and calls REPORT-FN when done."
:explanation
(format "byte-compile process %s died" proc))))
(ignore-errors (delete-file temp-file))
- (kill-buffer output-buffer))))))
- :stderr null-device
- :noquery t)))
+ (kill-buffer output-buffer))))
+ :stderr " *stderr of elisp-flymake-byte-compile*"
+ :noquery t)))))
(defun elisp-flymake--batch-compile-for-flymake (&optional file)
"Helper for `elisp-flymake-byte-compile'.
diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el
index 7d8cf3f8236..910c320ab8f 100644
--- a/lisp/progmodes/etags.el
+++ b/lisp/progmodes/etags.el
@@ -26,9 +26,17 @@
;;; Code:
+;; The namespacing of this package is a mess:
+;; - The file name is "etags", but the "exported" functionality doesn't use
+;; this name
+;; - Uses "etags-", "tags-", and "tag-" prefixes.
+;; - Many functions use "-tag-" or "-tags-", or even "-etags-" not as
+;; prefixes but somewhere within the name.
+
(require 'ring)
(require 'button)
(require 'xref)
+(require 'fileloop)
;;;###autoload
(defvar tags-file-name nil
@@ -49,7 +57,6 @@ Use the `etags' program to make a tags table file.")
"Whether tags operations should be case-sensitive.
A value of t means case-insensitive, a value of nil means case-sensitive.
Any other value means use the setting of `case-fold-search'."
- :group 'etags
:type '(choice (const :tag "Case-sensitive" nil)
(const :tag "Case-insensitive" t)
(other :tag "Use default" default))
@@ -63,7 +70,6 @@ An element that is a directory means the file \"TAGS\" in that directory.
To switch to a new list of tags tables, setting this variable is sufficient.
If you set this variable, do not also set `tags-file-name'.
Use the `etags' program to make a tags table file."
- :group 'etags
:type '(repeat file))
;;;###autoload
@@ -72,8 +78,7 @@ Use the `etags' program to make a tags table file."
"List of extensions tried by etags when `auto-compression-mode' is on.
An empty string means search the non-compressed file."
:version "24.1" ; added xz
- :type '(repeat string)
- :group 'etags)
+ :type '(repeat string))
;; !!! tags-compression-info-list should probably be replaced by access
;; to directory list and matching jka-compr-compression-info-list. Currently,
@@ -91,14 +96,12 @@ An empty string means search the non-compressed file."
t means do; nil means don't (always start a new list).
Any other value means ask the user whether to add a new tags table
to the current list (as opposed to starting a new list)."
- :group 'etags
:type '(choice (const :tag "Do" t)
(const :tag "Don't" nil)
(other :tag "Ask" ask-user)))
(defcustom tags-revert-without-query nil
"Non-nil means reread a TAGS table without querying, if it has changed."
- :group 'etags
:type 'boolean)
(defvar tags-table-computed-list nil
@@ -131,7 +134,6 @@ Each element is a list of strings which are file names.")
"Hook to be run by \\[find-tag] after finding a tag. See `run-hooks'.
The value in the buffer in which \\[find-tag] is done is used,
not the value in the buffer \\[find-tag] goes to."
- :group 'etags
:type 'hook)
;;;###autoload
@@ -140,7 +142,6 @@ not the value in the buffer \\[find-tag] goes to."
If nil, and the symbol that is the value of `major-mode'
has a `find-tag-default-function' property (see `put'), that is used.
Otherwise, `find-tag-default' is used."
- :group 'etags
:type '(choice (const nil) function))
(define-obsolete-variable-alias 'find-tag-marker-ring-length
@@ -148,13 +149,11 @@ Otherwise, `find-tag-default' is used."
(defcustom tags-tag-face 'default
"Face for tags in the output of `tags-apropos'."
- :group 'etags
:type 'face
:version "21.1")
(defcustom tags-apropos-verbose nil
"If non-nil, print the name of the tags file in the *Tags List* buffer."
- :group 'etags
:type 'boolean
:version "21.1")
@@ -175,7 +174,6 @@ Example value:
((\"Emacs Lisp\" Info-goto-emacs-command-node obarray)
(\"Common Lisp\" common-lisp-hyperspec common-lisp-hyperspec-obarray)
(\"SCWM\" scwm-documentation scwm-obarray))"
- :group 'etags
:type '(repeat (list (string :tag "Title")
function
(sexp :tag "Tags to search")))
@@ -209,9 +207,6 @@ use function `tags-table-files' to do so.")
(defvar tags-included-tables nil
"List of tags tables included by the current tags table.")
-
-(defvar next-file-list nil
- "List of files for \\[next-file] to process.")
;; Hooks for file formats.
@@ -274,12 +269,9 @@ buffer-local and set them to nil."
(run-hook-with-args-until-success 'tags-table-format-functions))
;;;###autoload
-(defun tags-table-mode ()
+(define-derived-mode tags-table-mode special-mode "Tags Table"
"Major mode for tags table file buffers."
- (interactive)
- (setq major-mode 'tags-table-mode ;FIXME: Use define-derived-mode.
- mode-name "Tags Table"
- buffer-undo-list t)
+ (setq buffer-undo-list t)
(initialize-new-tags-table))
;;;###autoload
@@ -331,10 +323,10 @@ file the tag was in."
(defun tags-table-check-computed-list ()
"Compute `tags-table-computed-list' from `tags-table-list' if necessary."
- (let ((expanded-list (mapcar 'tags-expand-table-name tags-table-list)))
+ (let ((expanded-list (mapcar #'tags-expand-table-name tags-table-list)))
(or (equal tags-table-computed-list-for expanded-list)
;; The list (or default-directory) has changed since last computed.
- (let* ((compute-for (mapcar 'copy-sequence expanded-list))
+ (let* ((compute-for (mapcar #'copy-sequence expanded-list))
(tables (copy-sequence compute-for)) ;Mutated in the loop.
(computed nil)
table-buffer)
@@ -354,7 +346,7 @@ file the tag was in."
(if (tags-included-tables)
;; Insert the included tables into the list we
;; are processing.
- (setcdr tables (nconc (mapcar 'tags-expand-table-name
+ (setcdr tables (nconc (mapcar #'tags-expand-table-name
(tags-included-tables))
(cdr tables))))))
;; This table is not in core yet. Insert a placeholder
@@ -439,25 +431,25 @@ Returns non-nil if it is a valid table."
(progn
(set-buffer (get-file-buffer file))
(or verify-tags-table-function (tags-table-mode))
- (if (or (verify-visited-file-modtime (current-buffer))
- ;; Decide whether to revert the file.
- ;; revert-without-query can say to revert
- ;; or the user can say to revert.
- (not (or (let ((tail revert-without-query)
- (found nil))
- (while tail
- (if (string-match (car tail) buffer-file-name)
- (setq found t))
- (setq tail (cdr tail)))
- found)
- tags-revert-without-query
- (yes-or-no-p
- (format "Tags file %s has changed, read new contents? "
- file)))))
- (and verify-tags-table-function
- (funcall verify-tags-table-function))
+ (unless (or (verify-visited-file-modtime (current-buffer))
+ ;; Decide whether to revert the file.
+ ;; revert-without-query can say to revert
+ ;; or the user can say to revert.
+ (not (or (let ((tail revert-without-query)
+ (found nil))
+ (while tail
+ (if (string-match (car tail) buffer-file-name)
+ (setq found t))
+ (setq tail (cdr tail)))
+ found)
+ tags-revert-without-query
+ (yes-or-no-p
+ (format "Tags file %s has changed, read new contents? "
+ file)))))
(revert-buffer t t)
- (tags-table-mode)))
+ (tags-table-mode))
+ (and verify-tags-table-function
+ (funcall verify-tags-table-function)))
(when (file-exists-p file)
(let* ((buf (find-file-noselect file))
(newfile (buffer-file-name buf)))
@@ -470,7 +462,9 @@ Returns non-nil if it is a valid table."
;; Only change buffer now that we're done using potentially
;; buffer-local variables.
(set-buffer buf)
- (tags-table-mode)))))
+ (tags-table-mode)
+ (and verify-tags-table-function
+ (funcall verify-tags-table-function))))))
;; Subroutine of visit-tags-table-buffer. Search the current tags tables
;; for one that has tags for THIS-FILE (or that includes a table that
@@ -503,7 +497,7 @@ buffers. If CORE-ONLY is nil, it is ignored."
;; Select the tags table buffer and get the file list up to date.
(let ((tags-file-name (car tables)))
(visit-tags-table-buffer 'same)
- (if (member this-file (mapcar 'expand-file-name
+ (if (member this-file (mapcar #'expand-file-name
(tags-table-files)))
;; Found it.
(setq found tables))))
@@ -854,7 +848,7 @@ If no tags table is loaded, do nothing and return nil."
(defun find-tag--default ()
(funcall (or find-tag-default-function
(get major-mode 'find-tag-default-function)
- 'find-tag-default)))
+ #'find-tag-default)))
(defvar last-tag nil
"Last tag found by \\[find-tag].")
@@ -1287,7 +1281,7 @@ buffer-local values of tags table format variables."
;; This regexp matches an explicit tag name or the place where
;; it would start.
(while (re-search-forward
- "[\f\t\n\r()=,; ]?\177\\\(?:\\([^\n\001]+\\)\001\\)?"
+ "[\f\t\n\r()=,; ]?\177\\(?:\\([^\n\001]+\\)\001\\)?"
nil t)
(push (prog1 (if (match-beginning 1)
;; There is an explicit tag name.
@@ -1651,7 +1645,7 @@ Point should be just after a string that matches TAG."
;; a textual description of the four rules.
(and (string-match "^[^ \t()=,;]+$" tag) ;rule #1
;; Rules #2 and #4, and a check that there's no explicit name.
- (looking-at "[ \t()=,;]?\177\\(?:[0-9]+\\)?,\\(?:[0-9]+\\)?$")
+ (looking-at "[ \t()=,;]?\177[0-9]*,[0-9]*$")
(save-excursion
(backward-char (1+ (length tag)))
(looking-at "[\n \t()=,;]")))) ;rule #3
@@ -1699,18 +1693,14 @@ Point should be just after a string that matches TAG."
(let ((bol (point)))
(and (search-forward "\177" (line-end-position) t)
(re-search-backward re bol t)))))
-
-(defcustom tags-loop-revert-buffers nil
- "Non-nil means tags-scanning loops should offer to reread changed files.
-These loops normally read each file into Emacs, but when a file
-is already visited, they use the existing buffer.
-When this flag is non-nil, they offer to revert the existing buffer
-in the case where the file has changed since you visited it."
- :type 'boolean
- :group 'etags)
+(define-obsolete-variable-alias 'tags-loop-revert-buffers 'fileloop-revert-buffers "27.1")
;;;###autoload
-(defun next-file (&optional initialize novisit)
+(defalias 'next-file 'tags-next-file)
+(make-obsolete 'next-file
+ "use tags-next-file or fileloop-initialize and fileloop-next-file instead" "27.1")
+;;;###autoload
+(defun tags-next-file (&optional initialize novisit)
"Select next file among files in current tags table.
A first argument of t (prefix arg, if interactive) initializes to the
@@ -1724,71 +1714,39 @@ Value is nil if the file was already visited;
if the file was newly read in, the value is the filename."
;; Make the interactive arg t if there was any prefix arg.
(interactive (list (if current-prefix-arg t)))
- (cond ((not initialize)
- ;; Not the first run.
- )
- ((eq initialize t)
- ;; Initialize the list from the tags table.
- (save-excursion
- (let ((cbuf (current-buffer)))
- ;; Visit the tags table buffer to get its list of files.
- (visit-tags-table-buffer)
- ;; Copy the list so we can setcdr below, and expand the file
- ;; names while we are at it, in this buffer's default directory.
- (setq next-file-list (mapcar 'expand-file-name (tags-table-files)))
- ;; Iterate over all the tags table files, collecting
- ;; a complete list of referenced file names.
- (while (visit-tags-table-buffer t cbuf)
- ;; Find the tail of the working list and chain on the new
- ;; sublist for this tags table.
- (let ((tail next-file-list))
- (while (cdr tail)
- (setq tail (cdr tail)))
- ;; Use a copy so the next loop iteration will not modify the
- ;; list later returned by (tags-table-files).
- (if tail
- (setcdr tail (mapcar 'expand-file-name (tags-table-files)))
- (setq next-file-list (mapcar 'expand-file-name
- (tags-table-files)))))))))
- (t
- ;; Initialize the list by evalling the argument.
- (setq next-file-list (eval initialize))))
- (unless next-file-list
- (and novisit
- (get-buffer " *next-file*")
- (kill-buffer " *next-file*"))
- (user-error "All files processed"))
- (let* ((next (car next-file-list))
- (buffer (get-file-buffer next))
- (new (not buffer)))
- ;; Advance the list before trying to find the file.
- ;; If we get an error finding the file, don't get stuck on it.
- (setq next-file-list (cdr next-file-list))
- ;; Optionally offer to revert buffers
- ;; if the files have changed on disk.
- (and buffer tags-loop-revert-buffers
- (not (verify-visited-file-modtime buffer))
- (y-or-n-p
- (format
- (if (buffer-modified-p buffer)
- "File %s changed on disk. Discard your edits? "
- "File %s changed on disk. Reread from disk? ")
- next))
- (with-current-buffer buffer
- (revert-buffer t t)))
- (if (not (and new novisit))
- (find-file next)
- ;; Like find-file, but avoids random warning messages.
- (switch-to-buffer (get-buffer-create " *next-file*"))
- (kill-all-local-variables)
- (erase-buffer)
- (setq new next)
- (insert-file-contents new nil))
- new))
+ (when initialize ;; Not the first run.
+ (tags--compat-initialize initialize))
+ (fileloop-next-file novisit)
+ (switch-to-buffer (current-buffer)))
+(defun tags--all-files ()
+ (save-excursion
+ (let ((cbuf (current-buffer))
+ (files nil))
+ ;; Visit the tags table buffer to get its list of files.
+ (visit-tags-table-buffer)
+ ;; Copy the list so we can setcdr below, and expand the file
+ ;; names while we are at it, in this buffer's default directory.
+ (setq files (mapcar #'expand-file-name (tags-table-files)))
+ ;; Iterate over all the tags table files, collecting
+ ;; a complete list of referenced file names.
+ (while (visit-tags-table-buffer t cbuf)
+ ;; Find the tail of the working list and chain on the new
+ ;; sublist for this tags table.
+ (let ((tail files))
+ (while (cdr tail)
+ (setq tail (cdr tail)))
+ ;; Use a copy so the next loop iteration will not modify the
+ ;; list later returned by (tags-table-files).
+ (setf (if tail (cdr tail) files)
+ (mapcar #'expand-file-name (tags-table-files)))))
+ files)))
+
+(make-obsolete-variable 'tags-loop-operate 'fileloop-initialize "27.1")
(defvar tags-loop-operate nil
"Form for `tags-loop-continue' to eval to change one file.")
+(make-obsolete-variable 'tags-loop-scan 'fileloop-initialize "27.1")
(defvar tags-loop-scan
'(user-error "%s"
(substitute-command-keys
@@ -1806,121 +1764,84 @@ Bind `case-fold-search' during the evaluation, depending on the value of
case-fold-search)))
(eval form)))
+(defun tags--compat-files (files)
+ (cond
+ ((eq files t) (tags--all-files)) ;; Initialize the list from the tags table.
+ ((functionp files) files)
+ ((stringp (car-safe files)) files)
+ (t
+ ;; Backward compatibility <27.1
+ ;; Initialize the list by evalling the argument.
+ (eval files))))
+
+(defun tags--compat-initialize (initialize)
+ (fileloop-initialize
+ (tags--compat-files initialize)
+ (if tags-loop-operate
+ (lambda () (tags-loop-eval tags-loop-operate))
+ (lambda () (message "Scanning file %s...found" buffer-file-name) nil))
+ (lambda () (tags-loop-eval tags-loop-scan))))
;;;###autoload
(defun tags-loop-continue (&optional first-time)
"Continue last \\[tags-search] or \\[tags-query-replace] command.
Used noninteractively with non-nil argument to begin such a command (the
-argument is passed to `next-file', which see).
-
-Two variables control the processing we do on each file: the value of
-`tags-loop-scan' is a form to be executed on each file to see if it is
-interesting (it returns non-nil if so) and `tags-loop-operate' is a form to
-evaluate to operate on an interesting file. If the latter evaluates to
-nil, we exit; otherwise we scan the next file."
+argument is passed to `next-file', which see)."
+ ;; Two variables control the processing we do on each file: the value of
+ ;; `tags-loop-scan' is a form to be executed on each file to see if it is
+ ;; interesting (it returns non-nil if so) and `tags-loop-operate' is a form to
+ ;; evaluate to operate on an interesting file. If the latter evaluates to
+ ;; nil, we exit; otherwise we scan the next file.
+ (declare (obsolete fileloop-continue "27.1"))
(interactive)
- (let (new
- ;; Non-nil means we have finished one file
- ;; and should not scan it again.
- file-finished
- original-point
- (messaged nil))
- (while
- (progn
- ;; Scan files quickly for the first or next interesting one.
- ;; This starts at point in the current buffer.
- (while (or first-time file-finished
- (save-restriction
- (widen)
- (not (tags-loop-eval tags-loop-scan))))
- ;; If nothing was found in the previous file, and
- ;; that file isn't in a temp buffer, restore point to
- ;; where it was.
- (when original-point
- (goto-char original-point))
-
- (setq file-finished nil)
- (setq new (next-file first-time t))
-
- ;; If NEW is non-nil, we got a temp buffer,
- ;; and NEW is the file name.
- (when (or messaged
- (and (not first-time)
- (> baud-rate search-slow-speed)
- (setq messaged t)))
- (message "Scanning file %s..." (or new buffer-file-name)))
-
- (setq first-time nil)
- (setq original-point (if new nil (point)))
- (goto-char (point-min)))
+ (when first-time ;; Backward compatibility.
+ (tags--compat-initialize first-time))
+ (fileloop-continue))
- ;; If we visited it in a temp buffer, visit it now for real.
- (if new
- (let ((pos (point)))
- (erase-buffer)
- (set-buffer (find-file-noselect new))
- (setq new nil) ;No longer in a temp buffer.
- (widen)
- (goto-char pos))
- (push-mark original-point t))
-
- (switch-to-buffer (current-buffer))
-
- ;; Now operate on the file.
- ;; If value is non-nil, continue to scan the next file.
- (save-restriction
- (widen)
- (tags-loop-eval tags-loop-operate)))
- (setq file-finished t))
- (and messaged
- (null tags-loop-operate)
- (message "Scanning file %s...found" buffer-file-name))))
+;; We use it to detect when the last loop was a tags-search.
+(defvar tags--last-search-operate-function nil)
;;;###autoload
-(defun tags-search (regexp &optional file-list-form)
+(defun tags-search (regexp &optional files)
"Search through all files listed in tags table for match for REGEXP.
Stops when a match is found.
To continue searching for next match, use command \\[tags-loop-continue].
-If FILE-LIST-FORM is non-nil, it should be a form that, when
-evaluated, will return a list of file names. The search will be
-restricted to these files.
+If FILES if non-nil should be a list or an iterator returning the files to search.
+The search will be restricted to these files.
Also see the documentation of the `tags-file-name' variable."
(interactive "sTags search (regexp): ")
- (if (and (equal regexp "")
- (eq (car tags-loop-scan) 're-search-forward)
- (null tags-loop-operate))
- ;; Continue last tags-search as if by M-,.
- (tags-loop-continue nil)
- (setq tags-loop-scan `(re-search-forward ',regexp nil t)
- tags-loop-operate nil)
- (tags-loop-continue (or file-list-form t))))
+ (unless (and (equal regexp "")
+ ;; FIXME: If some other fileloop operation took place,
+ ;; rather than search for "", we should repeat the last search!
+ (eq fileloop--operate-function
+ tags--last-search-operate-function))
+ (fileloop-initialize-search
+ regexp
+ (tags--compat-files (or files t))
+ tags-case-fold-search)
+ ;; Store it, so we can detect if some other fileloop operation took
+ ;; place since the last search!
+ (setq tags--last-search-operate-function fileloop--operate-function))
+ (fileloop-continue))
;;;###autoload
-(defun tags-query-replace (from to &optional delimited file-list-form)
+(defun tags-query-replace (from to &optional delimited files)
"Do `query-replace-regexp' of FROM with TO on all files listed in tags table.
Third arg DELIMITED (prefix arg) means replace only word-delimited matches.
If you exit (\\[keyboard-quit], RET or q), you can resume the query replace
with the command \\[tags-loop-continue].
-Fourth arg FILE-LIST-FORM non-nil means initialize the replacement loop.
-
-If FILE-LIST-FORM is non-nil, it is a form to evaluate to
-produce the list of files to search.
-
-See also the documentation of the variable `tags-file-name'."
+For non-interactive use, superceded by `fileloop-initialize-replace'."
+ (declare (advertised-calling-convention (from to &optional delimited) "27.1"))
(interactive (query-replace-read-args "Tags query replace (regexp)" t t))
- (setq tags-loop-scan `(let ,(unless (equal from (downcase from))
- '((case-fold-search nil)))
- (if (re-search-forward ',from nil t)
- ;; When we find a match, move back
- ;; to the beginning of it so perform-replace
- ;; will see it.
- (goto-char (match-beginning 0))))
- tags-loop-operate `(perform-replace ',from ',to t t ',delimited
- nil multi-query-replace-map))
- (tags-loop-continue (or file-list-form t)))
-
+ (fileloop-initialize-replace
+ from to
+ (tags--compat-files (or files t))
+ (if (equal from (downcase from)) nil 'default)
+ delimited)
+ (fileloop-continue))
+
(defun tags-complete-tags-table-file (string predicate what) ; Doc string?
(save-excursion
;; If we need to ask for the tag table, allow that.
@@ -1977,7 +1898,8 @@ directory specification."
(funcall tags-apropos-function regexp))))
(etags-tags-apropos-additional regexp))
(with-current-buffer "*Tags List*"
- (eval-and-compile (require 'apropos))
+ (require 'apropos)
+ (declare-function apropos-mode "apropos")
(apropos-mode)
;; apropos-mode is derived from fundamental-mode and it kills
;; all local variables.
@@ -2007,14 +1929,14 @@ see the doc of that variable if you want to add names to the list."
(when tags-table-list
(setq desired-point (point-marker))
(setq b (point))
- (princ (mapcar 'abbreviate-file-name tags-table-list) (current-buffer))
+ (princ (mapcar #'abbreviate-file-name tags-table-list) (current-buffer))
(make-text-button b (point) 'type 'tags-select-tags-table
'etags-table (car tags-table-list))
(insert "\n"))
(while set-list
(unless (eq (car set-list) tags-table-list)
(setq b (point))
- (princ (mapcar 'abbreviate-file-name (car set-list)) (current-buffer))
+ (princ (mapcar #'abbreviate-file-name (car set-list)) (current-buffer))
(make-text-button b (point) 'type 'tags-select-tags-table
'etags-table (car (car set-list)))
(insert "\n"))
@@ -2028,9 +1950,9 @@ see the doc of that variable if you want to add names to the list."
'etags-table tags-file-name)
(insert "\n"))
(setq set-list (delete tags-file-name
- (apply 'nconc (cons (copy-sequence tags-table-list)
- (mapcar 'copy-sequence
- tags-table-set-list)))))
+ (apply #'nconc (cons (copy-sequence tags-table-list)
+ (mapcar #'copy-sequence
+ tags-table-set-list)))))
(while set-list
(setq b (point))
(insert (abbreviate-file-name (car set-list)))
@@ -2060,7 +1982,7 @@ see the doc of that variable if you want to add names to the list."
(define-derived-mode select-tags-table-mode special-mode "Select Tags Table"
"Major mode for choosing a current tags table among those already loaded."
- (setq buffer-read-only t))
+ )
(defun select-tags-table-select (button)
"Select the tags table named on this line."
diff --git a/lisp/progmodes/f90.el b/lisp/progmodes/f90.el
index 94317b3e17b..9de80635e9f 100644
--- a/lisp/progmodes/f90.el
+++ b/lisp/progmodes/f90.el
@@ -123,7 +123,6 @@
;; mechanism for treating multi-line directives (continued by \ ).
;; 7) f77 do-loops do 10 i=.. ; ; 10 continue are not correctly indented.
;; You are urged to use f90-do loops (with labels if you wish).
-;; 8) The highlighting mode under XEmacs is not as complete as under Emacs.
;; List of user commands
;; f90-previous-statement f90-next-statement
@@ -649,7 +648,7 @@ forall\\|block\\|critical\\)\\)\\_>"
\\|enumerator\\|procedure\\|\
logical\\|double[ \t]*precision\\|type[ \t]*(\\(?:\\sw\\|\\s_\\)+)\\|none\\)[ \t]*"
(1 font-lock-keyword-face) (2 font-lock-type-face))
- '("\\_<\\(namelist\\|common\\)[ \t]*/\\(\\(?:\\sw\\|\\s_\\)+\\)?\/"
+ '("\\_<\\(namelist\\|common\\)[ \t]*/\\(\\(?:\\sw\\|\\s_\\)+\\)?/"
(1 font-lock-keyword-face) (2 font-lock-constant-face nil t))
"\\_<else\\([ \t]*if\\|where\\)?\\_>"
'("\\(&\\)[ \t]*\\(!\\|$\\)" (1 font-lock-keyword-face))
@@ -1847,10 +1846,8 @@ A block is a subroutine, if-endif, etc."
(push-mark)
(goto-char pos)
(setq program (f90-beginning-of-subprogram))
- (if (featurep 'xemacs)
- (zmacs-activate-region)
- (setq mark-active t
- deactivate-mark nil))
+ (setq mark-active t
+ deactivate-mark nil)
program))
(defun f90-comment-region (beg-region end-region)
@@ -2042,9 +2039,7 @@ If run in the middle of a line, the line is not broken."
(goto-char save-point)
(set-marker end-region-mark nil)
(set-marker save-point nil)
- (if (featurep 'xemacs)
- (zmacs-deactivate-region)
- (deactivate-mark))))
+ (deactivate-mark)))
(defun f90-indent-subprogram ()
"Properly indent the subprogram containing point."
@@ -2157,9 +2152,7 @@ Like `join-line', but handles F90 syntax."
f90-cache-position (point)))
(setq f90-cache-position nil)
(set-marker end-region-mark nil)
- (if (featurep 'xemacs)
- (zmacs-deactivate-region)
- (deactivate-mark))))
+ (deactivate-mark)))
(defun f90-fill-paragraph (&optional justify)
"In a comment, fill it as a paragraph, else fill the current statement.
diff --git a/lisp/progmodes/flymake-cc.el b/lisp/progmodes/flymake-cc.el
new file mode 100644
index 00000000000..248c95a256f
--- /dev/null
+++ b/lisp/progmodes/flymake-cc.el
@@ -0,0 +1,146 @@
+;;; flymake-cc.el --- Flymake support for GNU tools for C/C++ -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018-2019 Free Software Foundation, Inc.
+
+;; Author: João Távora <joaotavora@gmail.com>
+;; Keywords: languages, c
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Flymake support for C/C++.
+
+;;; Code:
+
+(require 'cl-lib)
+
+(defcustom flymake-cc-command 'flymake-cc-use-special-make-target
+ "Command used by the `flymake-cc' backend.
+A list of strings, or a symbol naming a function that produces one
+such list when called with no arguments in the buffer where the
+variable `flymake-mode' is active.
+
+The command should invoke a GNU-style compiler that checks the
+syntax of a (Obj)C(++) program passed to it via its standard
+input and prints the result on its standard output."
+ :type '(choice
+ (symbol :tag "Function")
+ ((repeat :) string))
+ :group 'flymake-cc)
+
+(defun flymake-cc--make-diagnostics (source)
+ "Parse GNU-compatible compilation messages in current buffer.
+Return a list of Flymake diagnostic objects for the source buffer
+SOURCE."
+ ;; TODO: if you can understand it, use `compilation-mode's regexps
+ ;; or even some of its machinery here.
+ ;;
+ ;; (set (make-local-variable 'compilation-locs)
+ ;; (make-hash-table :test 'equal :weakness 'value))
+ ;; (compilation-parse-errors (point-min) (point-max)
+ ;; 'gnu 'gcc-include)
+ ;; (while (next-single-property-change 'compilation-message)
+ ;; ...)
+ ;;
+ ;; For now, this works minimally well.
+ (cl-loop
+ while
+ (search-forward-regexp
+ (concat
+ "^\\(In file included from \\)?<stdin>:\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)"
+ "?:[\n ]?\\(error\\|warning\\|note\\): \\(.*\\)$")
+ nil t)
+ for msg = (match-string 5)
+ for (beg . end) = (flymake-diag-region
+ source
+ (string-to-number (match-string 2))
+ (and (match-string 3) (string-to-number (match-string 3))))
+ for type = (if (match-string 1)
+ :error
+ (assoc-default
+ (match-string 4)
+ '(("error" . :error)
+ ("note" . :note)
+ ("warning" . :warning))
+ #'string-match))
+ collect (flymake-make-diagnostic source beg end type msg)))
+
+(defun flymake-cc-use-special-make-target ()
+ "Command for checking a file via a CHK_SOURCES Make target."
+ (unless (executable-find "make") (error "Make not found"))
+ `("make"
+ "check-syntax"
+ ,(format "CHK_SOURCES=-x %s -c -"
+ (cond ((derived-mode-p 'c++-mode) "c++")
+ (t "c")))))
+
+(defvar-local flymake-cc--proc nil "Internal variable for `flymake-gcc'")
+
+;; forward declare this to shoosh compiler (instead of requiring
+;; flymake-proc)
+;;
+(defvar flymake-proc-allowed-file-name-masks)
+
+;;;###autoload
+(defun flymake-cc (report-fn &rest _args)
+ "Flymake backend for GNU-style C compilers.
+This backend uses `flymake-cc-command' (which see) to launch a
+process that is passed the current buffer's contents via stdin.
+REPORT-FN is Flymake's callback."
+ ;; HACK: XXX: Assuming this backend function is run before it in
+ ;; `flymake-diagnostic-functions', very hackingly convince the other
+ ;; backend `flymake-proc-legacy-backend', which is on by default, to
+ ;; disable itself.
+ ;;
+ (setq-local flymake-proc-allowed-file-name-masks nil)
+ (when (process-live-p flymake-cc--proc)
+ (kill-process flymake-cc--proc))
+ (let ((source (current-buffer)))
+ (save-restriction
+ (widen)
+ (setq
+ flymake-cc--proc
+ (make-process
+ :name "gcc-flymake"
+ :buffer (generate-new-buffer "*gcc-flymake*")
+ :command (if (symbolp flymake-cc-command)
+ (funcall flymake-cc-command)
+ flymake-cc-command)
+ :noquery t :connection-type 'pipe
+ :sentinel
+ (lambda (p _ev)
+ (when (eq 'exit (process-status p))
+ (unwind-protect
+ (when (with-current-buffer source (eq p flymake-cc--proc))
+ (with-current-buffer (process-buffer p)
+ (goto-char (point-min))
+ (let ((diags
+ (flymake-cc--make-diagnostics source)))
+ (if (or diags (zerop (process-exit-status p)))
+ (funcall report-fn diags)
+ ;; non-zero exit with no diags is cause
+ ;; for alarm
+ (funcall report-fn
+ :panic :explanation
+ (buffer-substring
+ (point-min) (progn (goto-char (point-min))
+ (line-end-position))))))))
+ ;; (display-buffer (process-buffer p)) ; uncomment to debug
+ (kill-buffer (process-buffer p)))))))
+ (process-send-region flymake-cc--proc (point-min) (point-max))
+ (process-send-eof flymake-cc--proc))))
+
+(provide 'flymake-cc)
+;;; flymake-cc.el ends here
diff --git a/lisp/progmodes/flymake-proc.el b/lisp/progmodes/flymake-proc.el
index 673f83e3396..dbf7561944e 100644
--- a/lisp/progmodes/flymake-proc.el
+++ b/lisp/progmodes/flymake-proc.el
@@ -3,8 +3,8 @@
;; Copyright (C) 2003-2019 Free Software Foundation, Inc.
;; Author: Pavel Kobyakov <pk_at_work@yahoo.com>
-;; Maintainer: Leo Liu <sdl.web@gmail.com>
-;; Version: 0.3
+;; Maintainer: João Távora <joaotavora@gmail.com>
+;; Version: 1.0
;; Keywords: c languages tools
;; This file is part of GNU Emacs.
@@ -41,6 +41,8 @@
;;; Code:
+(require 'cl-lib)
+
(require 'flymake)
(define-obsolete-variable-alias 'flymake-compilation-prevents-syntax-check
@@ -77,6 +79,13 @@
:group 'flymake
:type 'integer)
+(defcustom flymake-proc-ignored-file-name-regexps '()
+ "Files syntax checking is forbidden for.
+Overrides `flymake-proc-allowed-file-name-masks'."
+ :group 'flymake
+ :type '(repeat (regexp))
+ :version "27.1")
+
(define-obsolete-variable-alias 'flymake-allowed-file-name-masks
'flymake-proc-allowed-file-name-masks "26.1")
@@ -106,6 +115,7 @@
;; ("\\.tex\\'" 1)
)
"Files syntax checking is allowed for.
+Variable `flymake-proc-ignored-file-name-regexps' overrides this variable.
This is an alist with elements of the form:
REGEXP INIT [CLEANUP [NAME]]
REGEXP is a regular expression that matches a file name.
@@ -148,6 +158,9 @@ Convert it to Flymake internal format."
(setq converted-list (cons (list regexp file line col) converted-list)))))
converted-list))
+(define-obsolete-variable-alias 'flymake-err-line-patterns
+ 'flymake-proc-err-line-patterns "26.1")
+
(defvar flymake-proc-err-line-patterns ; regexp file-idx line-idx col-idx (optional) text-idx(optional), match-end to end of string is error text
(append
'(
@@ -183,11 +196,10 @@ from compile.el")
'flymake-proc-default-guess
"Predicate matching against diagnostic text to detect its type.
Takes a single argument, the diagnostic's text and should return
-a value suitable for indexing
-`flymake-diagnostic-types-alist' (which see). If the returned
-value is nil, a type of `:error' is assumed. For some backward
-compatibility, if a non-nil value is returned that doesn't
-index that alist, a type of `:warning' is assumed.
+a diagnostic symbol naming a type. If the returned value is nil,
+a type of `:error' is assumed. For some backward compatibility,
+if a non-nil value is returned that doesn't name a type,
+`:warning' is assumed.
Instead of a function, it can also be a string, a regular
expression. A match indicates `:warning' type, otherwise
@@ -203,17 +215,22 @@ expression. A match indicates `:warning' type, otherwise
:error)))
(defun flymake-proc--get-file-name-mode-and-masks (file-name)
- "Return the corresponding entry from `flymake-proc-allowed-file-name-masks'."
+ "Return the corresponding entry from `flymake-proc-allowed-file-name-masks'.
+If the FILE-NAME matches a regexp from `flymake-proc-ignored-file-name-regexps',
+`flymake-proc-allowed-file-name-masks' is not searched."
(unless (stringp file-name)
(error "Invalid file-name"))
- (let ((fnm flymake-proc-allowed-file-name-masks)
- (mode-and-masks nil))
- (while (and (not mode-and-masks) fnm)
- (if (string-match (car (car fnm)) file-name)
- (setq mode-and-masks (cdr (car fnm))))
- (setq fnm (cdr fnm)))
- (flymake-log 3 "file %s, init=%s" file-name (car mode-and-masks))
- mode-and-masks))
+ (if (cl-find file-name flymake-proc-ignored-file-name-regexps
+ :test (lambda (fn rex) (string-match rex fn)))
+ (flymake-log 3 "file %s ignored")
+ (let ((fnm flymake-proc-allowed-file-name-masks)
+ (mode-and-masks nil))
+ (while (and (not mode-and-masks) fnm)
+ (if (string-match (car (car fnm)) file-name)
+ (setq mode-and-masks (cdr (car fnm))))
+ (setq fnm (cdr fnm)))
+ (flymake-log 3 "file %s, init=%s" file-name (car mode-and-masks))
+ mode-and-masks)))
(defun flymake-proc--get-init-function (file-name)
"Return init function to be used for the file."
@@ -320,6 +337,9 @@ to the beginning of the list (File.h -> File.cpp moved to top)."
(file-name-base file-one))
(not (equal file-one file-two))))
+(define-obsolete-variable-alias 'flymake-check-file-limit
+ 'flymake-proc-check-file-limit "26.1")
+
(defvar flymake-proc-check-file-limit 8192
"Maximum number of chars to look at when checking possible master file.
Nil means search the entire file.")
@@ -495,8 +515,8 @@ Create parent directories as needed."
:error))
((functionp pred)
(let ((probe (funcall pred message)))
- (cond ((assoc-default probe
- flymake-diagnostic-types-alist)
+ (cond ((and (symbolp probe)
+ (get probe 'flymake-category))
probe)
(probe
:warning)
@@ -867,7 +887,7 @@ can also be executed interactively independently of
(defun flymake-proc--delete-temp-directory (dir-name)
"Attempt to delete temp dir created by `flymake-proc-create-temp-with-folder-structure', do not fail on error."
(let* ((temp-dir temporary-file-directory)
- (suffix (substring dir-name (1+ (length temp-dir)))))
+ (suffix (substring dir-name (1+ (length (directory-file-name temp-dir))))))
(while (> (length suffix) 0)
(setq suffix (directory-file-name suffix))
@@ -1113,7 +1133,7 @@ Use CREATE-TEMP-F for creating temp copy."
(let* ((temp-master-file-name (flymake-proc--init-create-temp-source-and-master-buffer-copy
'flymake-proc-get-include-dirs-dot 'flymake-proc-create-temp-inplace
'("\\.tex\\'")
- "[ \t]*\\in\\(?:put\\|clude\\)[ \t]*{\\(.*%s\\)}")))
+ "[ \t]*in\\(?:put\\|clude\\)[ \t]*{\\(.*%s\\)}")))
(when temp-master-file-name
(flymake-proc--get-tex-args temp-master-file-name))))
@@ -1133,12 +1153,8 @@ Use CREATE-TEMP-F for creating temp copy."
;;;;
-(define-obsolete-variable-alias 'flymake-check-file-limit
- 'flymake-proc-check-file-limit "26.1")
(define-obsolete-function-alias 'flymake-reformat-err-line-patterns-from-compile-el
'flymake-proc-reformat-err-line-patterns-from-compile-el "26.1")
-(define-obsolete-variable-alias 'flymake-err-line-patterns
- 'flymake-proc-err-line-patterns "26.1")
(define-obsolete-function-alias 'flymake-parse-line
'flymake-proc-parse-line "26.1")
(define-obsolete-function-alias 'flymake-get-include-dirs
diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el
index 16d97b6ccaf..d6cd370dac4 100644
--- a/lisp/progmodes/flymake.el
+++ b/lisp/progmodes/flymake.el
@@ -3,8 +3,9 @@
;; Copyright (C) 2003-2019 Free Software Foundation, Inc.
;; Author: Pavel Kobyakov <pk_at_work@yahoo.com>
-;; Maintainer: Leo Liu <sdl.web@gmail.com>
-;; Version: 0.3
+;; Maintainer: João Távora <joaotavora@gmail.com>
+;; Version: 1.0.5
+;; Package-Requires: ((emacs "26.1"))
;; Keywords: c languages tools
;; This file is part of GNU Emacs.
@@ -14,10 +15,10 @@
;; 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.
+;; 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 <https://www.gnu.org/licenses/>.
@@ -34,13 +35,77 @@
;; results produced by these backends, as well as entry points for
;; backends to hook on to.
;;
-;; The main entry points are `flymake-mode' and `flymake-start'
+;; The main interactive entry point is the `flymake-mode' minor mode,
+;; which periodically and automatically initiates checks as the user
+;; is editing the buffer. The variables `flymake-no-changes-timeout',
+;; `flymake-start-syntax-check-on-newline' and
+;; `flymake-start-on-flymake-mode' give finer control over the events
+;; triggering a check, as does the interactive command
+;; `flymake-start', which immediately starts a check.
;;
-;; The docstrings of these variables are relevant to understanding how
-;; Flymake works for both the user and the backend programmer:
+;; Shortly after each check, a summary of collected diagnostics should
+;; appear in the mode-line. If it doesn't, there might not be a
+;; suitable Flymake backend for the current buffer's major mode, in
+;; which case Flymake will indicate this in the mode-line. The
+;; indicator will be `!' (exclamation mark), if all the configured
+;; backends errored (or decided to disable themselves) and `?'
+;; (question mark) if no backends were even configured.
;;
-;; * `flymake-diagnostic-functions'
-;; * `flymake-diagnostic-types-alist'
+;; For programmers interested in writing a new Flymake backend, the
+;; docstring of `flymake-diagnostic-functions', the Flymake manual,
+;; and the code of existing backends are probably a good starting
+;; point.
+;;
+;; The user wishing to customize the appearance of error types should
+;; set properties on the symbols associated with each diagnostic type.
+;; The standard diagnostic symbols are `:error', `:warning' and
+;; `:note' (though a specific backend may define and use more). The
+;; following properties can be set:
+;;
+;; * `flymake-bitmap', an image displayed in the fringe according to
+;; `flymake-fringe-indicator-position'. The value actually follows
+;; the syntax of `flymake-error-bitmap' (which see). It is overridden
+;; by any `before-string' overlay property.
+;;
+;; * `flymake-severity', a non-negative integer specifying the
+;; diagnostic's severity. The higher, the more serious. If the
+;; overlay property `priority' is not specified, `severity' is used to
+;; set it and help sort overlapping overlays.
+;;
+;; * `flymake-overlay-control', an alist ((OVPROP . VALUE) ...) of
+;; further properties used to affect the appearance of Flymake
+;; annotations. With the exception of `category' and `evaporate',
+;; these properties are applied directly to the created overlay. See
+;; Info Node `(elisp)Overlay Properties'.
+;;
+;; * `flymake-category', a symbol whose property list is considered a
+;; default for missing values of any other properties. This is useful
+;; to backend authors when creating new diagnostic types that differ
+;; from an existing type by only a few properties. The category
+;; symbols `flymake-error', `flymake-warning' and `flymake-note' make
+;; good candidates for values of this property.
+;;
+;; For instance, to omit the fringe bitmap displayed for the standard
+;; `:note' type, set its `flymake-bitmap' property to nil:
+;;
+;; (put :note 'flymake-bitmap nil)
+;;
+;; To change the face for `:note' type, add a `face' entry to its
+;; `flymake-overlay-control' property.
+;;
+;; (push '(face . highlight) (get :note 'flymake-overlay-control))
+;;
+;; If you push another alist entry in front, it overrides the previous
+;; one. So this effectively removes the face from `:note'
+;; diagnostics.
+;;
+;; (push '(face . nil) (get :note 'flymake-overlay-control))
+;;
+;; To erase customizations and go back to the original look for
+;; `:note' types:
+;;
+;; (cl-remf (symbol-plist :note) 'flymake-overlay-control)
+;; (cl-remf (symbol-plist :note) 'flymake-bitmap)
;;
;;; Code:
@@ -132,11 +197,17 @@ If nil, never start checking buffer automatically like this."
'flymake-start-on-flymake-mode "26.1")
(defcustom flymake-start-on-flymake-mode t
- "Start syntax check when `flymake-mode' is enabled.
+ "If non-nil, start syntax check when `flymake-mode' is enabled.
Specifically, start it when the buffer is actually displayed."
:version "26.1"
:type 'boolean)
+(defcustom flymake-start-on-save-buffer t
+ "If non-nil start syntax check when a buffer is saved.
+Specifically, start it when the saved buffer is actually displayed."
+ :version "27.1"
+ :type 'boolean)
+
(defcustom flymake-log-level -1
"Obsolete and ignored variable."
:type 'integer)
@@ -149,6 +220,15 @@ Specifically, start it when the buffer is actually displayed."
:version "26.1"
:type 'boolean)
+(defcustom flymake-suppress-zero-counters :warning
+ "Control appearance of zero-valued diagnostic counters in mode line.
+
+If set to t, supress all zero counters. If set to a severity
+symbol like `:warning' (the default) suppress zero counters less
+severe than that severity, according to `warning-numeric-level'.
+If set to nil, don't supress any zero counters."
+ :type 'symbol)
+
(when (fboundp 'define-fringe-bitmap)
(define-fringe-bitmap 'flymake-double-exclamation-mark
(vector #b00000000
@@ -222,18 +302,28 @@ generated it."
(cl-defstruct (flymake--diag
(:constructor flymake--diag-make))
- buffer beg end type text backend)
+ buffer beg end type text backend data overlay-properties overlay)
;;;###autoload
(defun flymake-make-diagnostic (buffer
beg
end
type
- text)
+ text
+ &optional data
+ overlay-properties)
"Make a Flymake diagnostic for BUFFER's region from BEG to END.
-TYPE is a key to `flymake-diagnostic-types-alist' and TEXT is a
-description of the problem detected in this region."
- (flymake--diag-make :buffer buffer :beg beg :end end :type type :text text))
+TYPE is a key to symbol and TEXT is a description of the problem
+detected in this region. DATA is any object that the caller
+wishes to attach to the created diagnostic for later retrieval.
+
+OVERLAY-PROPERTIES is an an alist of properties attached to the
+created diagnostic, overriding the default properties and any
+properties of `flymake-overlay-control' of the diagnostic's
+type."
+ (flymake--diag-make :buffer buffer :beg beg :end end
+ :type type :text text :data data
+ :overlay-properties overlay-properties))
;;;###autoload
(defun flymake-diagnostics (&optional beg end)
@@ -257,6 +347,7 @@ diagnostics at BEG."
(flymake--diag-accessor flymake-diagnostic-beg flymake--diag-beg beg)
(flymake--diag-accessor flymake-diagnostic-end flymake--diag-end end)
(flymake--diag-accessor flymake-diagnostic-backend flymake--diag-backend backend)
+(flymake--diag-accessor flymake-diagnostic-data flymake--diag-data backend)
(cl-defun flymake--overlays (&key beg end filter compare key)
"Get flymake-related overlays.
@@ -280,10 +371,6 @@ verify FILTER, a function, and sort them by COMPARE (using KEY)."
#'identity))
ovs))))
-(defun flymake-delete-own-overlays (&optional filter)
- "Delete all Flymake overlays in BUFFER."
- (mapc #'delete-overlay (flymake--overlays :filter filter)))
-
(defface flymake-error
'((((supports :underline (:style wave)))
:underline (:style wave :color "Red1"))
@@ -333,7 +420,7 @@ region is invalid."
(beg)
(progn
(end-of-line)
- (skip-chars-backward " \t\f\t\n" beg)
+ (skip-chars-backward " \t\f\n" beg)
(if (eq (point) beg)
(line-beginning-position 2)
(point)))))
@@ -370,9 +457,25 @@ number of arguments:
detailed below;
* the remaining arguments are keyword-value pairs in the
- form (:KEY VALUE :KEY2 VALUE2...). Currently, Flymake provides
- no such arguments, but backend functions must be prepared to
- accept and possibly ignore any number of them.
+ form (:KEY VALUE :KEY2 VALUE2...).
+
+Currently, Flymake may provide these keyword-value pairs:
+
+* `:recent-changes', a list of recent changes since the last time
+ the backend function was called for the buffer. An empty list
+ indicates that no changes have been reocrded. If it is the
+ first time that this backend function is called for this
+ activation of `flymake-mode', then this argument isn't provided
+ at all (i.e. it's not merely nil).
+
+ Each element is in the form (BEG END TEXT) where BEG and END
+ are buffer positions, and TEXT is a string containing the text
+ contained between those positions (if any) after the change was
+ performed.
+
+* `:changes-start' and `:changes-end', the minimum and maximum
+ buffer positions touched by the recent changes. These are only
+ provided if `:recent-changes' is also provided.
Whenever Flymake or the user decides to re-check the buffer,
backend functions are called as detailed above and are expected
@@ -384,8 +487,9 @@ asynchronous processes or other asynchronous mechanisms.
In any case, backend functions are expected to return quickly or
signal an error, in which case the backend is disabled. Flymake
will not try disabled backends again for any future checks of
-this buffer. Certain commands, like turning `flymake-mode' off
-and on again, reset the list of disabled backends.
+this buffer. To reset the list of disabled backends, turn
+`flymake-mode' off and on again, or interactively call
+`flymake-start' with a prefix argument.
If the function returns, Flymake considers the backend to be
\"running\". If it has not done so already, the backend is
@@ -396,8 +500,9 @@ pairs in the form (:REPORT-KEY VALUE :REPORT-KEY2 VALUE2...).
Currently accepted values for REPORT-ACTION are:
* A (possibly empty) list of diagnostic objects created with
- `flymake-make-diagnostic', causing Flymake to annotate the
- buffer with this information.
+ `flymake-make-diagnostic', causing Flymake to delete all
+ previous diagnostic annotations in the buffer and create new
+ ones from this list.
A backend may call REPORT-FN repeatedly in this manner, but
only until Flymake considers that the most recently requested
@@ -417,76 +522,71 @@ Currently accepted REPORT-KEY arguments are:
the situation encountered, if any.
* `:force': value should be a boolean suggesting that Flymake
- consider the report even if it was somehow unexpected.")
-
-(defvar flymake-diagnostic-types-alist
- `((:error
- . ((flymake-category . flymake-error)))
- (:warning
- . ((flymake-category . flymake-warning)))
- (:note
- . ((flymake-category . flymake-note))))
- "Alist ((KEY . PROPS)*) of properties of Flymake diagnostic types.
-KEY designates a kind of diagnostic can be anything passed as
-`:type' to `flymake-make-diagnostic'.
-
-PROPS is an alist of properties that are applied, in order, to
-the diagnostics of the type designated by KEY. The recognized
-properties are:
-
-* Every property pertaining to overlays, except `category' and
- `evaporate' (see Info Node `(elisp)Overlay Properties'), used
- to affect the appearance of Flymake annotations.
-
-* `bitmap', an image displayed in the fringe according to
- `flymake-fringe-indicator-position'. The value actually
- follows the syntax of `flymake-error-bitmap' (which see). It
- is overridden by any `before-string' overlay property.
-
-* `severity', a non-negative integer specifying the diagnostic's
- severity. The higher, the more serious. If the overlay
- property `priority' is not specified, `severity' is used to set
- it and help sort overlapping overlays.
-
-* `flymake-category', a symbol whose property list is considered
- a default for missing values of any other properties. This is
- useful to backend authors when creating new diagnostic types
- that differ from an existing type by only a few properties.")
+ consider the report even if it was somehow unexpected.
+
+* `:region': a cons (BEG . END) of buffer positions indicating
+ that the report applies to that region only. Specifically,
+ this means that Flymake will only delete diagnostic annotations
+ of past reports if they intersect the region by at least one
+ character.")
+
+(put 'flymake-diagnostic-functions 'safe-local-variable #'null)
+
+(put :error 'flymake-category 'flymake-error)
+(put :warning 'flymake-category 'flymake-warning)
+(put :note 'flymake-category 'flymake-note)
+
+(defvar flymake-diagnostic-types-alist '() "")
+(make-obsolete-variable
+ 'flymake-diagnostic-types-alist
+ "Set properties on the diagnostic symbols instead. See Info
+Node `(Flymake)Flymake error types'"
+ "27.1")
(put 'flymake-error 'face 'flymake-error)
-(put 'flymake-error 'bitmap 'flymake-error-bitmap)
+(put 'flymake-error 'flymake-bitmap 'flymake-error-bitmap)
(put 'flymake-error 'severity (warning-numeric-level :error))
(put 'flymake-error 'mode-line-face 'compilation-error)
(put 'flymake-warning 'face 'flymake-warning)
-(put 'flymake-warning 'bitmap 'flymake-warning-bitmap)
+(put 'flymake-warning 'flymake-bitmap 'flymake-warning-bitmap)
(put 'flymake-warning 'severity (warning-numeric-level :warning))
(put 'flymake-warning 'mode-line-face 'compilation-warning)
(put 'flymake-note 'face 'flymake-note)
-(put 'flymake-note 'bitmap 'flymake-note-bitmap)
+(put 'flymake-note 'flymake-bitmap 'flymake-note-bitmap)
(put 'flymake-note 'severity (warning-numeric-level :debug))
(put 'flymake-note 'mode-line-face 'compilation-info)
(defun flymake--lookup-type-property (type prop &optional default)
- "Look up PROP for TYPE in `flymake-diagnostic-types-alist'.
-If TYPE doesn't declare PROP in either
-`flymake-diagnostic-types-alist' or in the symbol of its
+ "Look up PROP for diagnostic TYPE.
+If TYPE doesn't declare PROP in its plist or in the symbol of its
associated `flymake-category' return DEFAULT."
- (let ((alist-probe (assoc type flymake-diagnostic-types-alist)))
- (cond (alist-probe
- (let* ((alist (cdr alist-probe))
- (prop-probe (assoc prop alist)))
- (if prop-probe
- (cdr prop-probe)
- (if-let* ((cat (assoc-default 'flymake-category alist))
- (plist (and (symbolp cat)
- (symbol-plist cat)))
- (cat-probe (plist-member plist prop)))
- (cadr cat-probe)
- default))))
- (t
- default))))
+ ;; This function also consults `flymake-diagnostic-types-alist' for
+ ;; backward compatibility.
+ ;;
+ (if (plist-member (symbol-plist type) prop)
+ ;; allow nil values to survive
+ (get type prop)
+ (let (alist)
+ (or
+ (alist-get
+ prop (setq
+ alist
+ (alist-get type flymake-diagnostic-types-alist)))
+ (when-let* ((cat (or
+ (get type 'flymake-category)
+ (alist-get 'flymake-category alist)))
+ (plist (and (symbolp cat)
+ (symbol-plist cat)))
+ (cat-probe (plist-member plist prop)))
+ (cadr cat-probe))
+ default))))
+
+(defun flymake--severity (type)
+ "Get the severity for diagnostic TYPE."
+ (flymake--lookup-type-property type 'severity
+ (warning-numeric-level :error)))
(defun flymake--fringe-overlay-spec (bitmap &optional recursed)
(if (and (symbolp bitmap)
@@ -503,34 +603,40 @@ associated `flymake-category' return DEFAULT."
(list bitmap)))))))
(defun flymake--highlight-line (diagnostic)
- "Highlight buffer with info in DIAGNOSTIC."
- (when-let* ((ov (make-overlay
+ "Highlight buffer with info in DIGNOSTIC."
+ (when-let* ((type (flymake--diag-type diagnostic))
+ (ov (make-overlay
(flymake--diag-beg diagnostic)
(flymake--diag-end diagnostic))))
- ;; First set `category' in the overlay, then copy over every other
- ;; property.
+ ;; First set `category' in the overlay
;;
- (let ((alist (assoc-default (flymake--diag-type diagnostic)
- flymake-diagnostic-types-alist)))
- (overlay-put ov 'category (assoc-default 'flymake-category alist))
- (cl-loop for (k . v) in alist
- unless (eq k 'category)
- do (overlay-put ov k v)))
+ (overlay-put ov 'category
+ (flymake--lookup-type-property type 'flymake-category))
+ ;; Now "paint" the overlay with all the other non-category
+ ;; properties.
+ (cl-loop
+ for (ov-prop . value) in
+ (append (reverse
+ (flymake--diag-overlay-properties diagnostic))
+ (reverse ; ensure ealier props override later ones
+ (flymake--lookup-type-property type 'flymake-overlay-control))
+ (alist-get type flymake-diagnostic-types-alist))
+ do (overlay-put ov ov-prop value))
;; Now ensure some essential defaults are set
;;
(cl-flet ((default-maybe
(prop value)
- (unless (or (plist-member (overlay-properties ov) prop)
- (let ((cat (overlay-get ov
- 'flymake-category)))
- (and cat
- (plist-member (symbol-plist cat) prop))))
- (overlay-put ov prop value))))
- (default-maybe 'bitmap 'flymake-error-bitmap)
+ (unless (plist-member (overlay-properties ov) prop)
+ (overlay-put ov prop (flymake--lookup-type-property
+ type prop value)))))
(default-maybe 'face 'flymake-error)
(default-maybe 'before-string
(flymake--fringe-overlay-spec
- (overlay-get ov 'bitmap)))
+ (flymake--lookup-type-property
+ type
+ 'flymake-bitmap
+ (alist-get 'bitmap (alist-get type ; backward compat
+ flymake-diagnostic-types-alist)))))
(default-maybe 'help-echo
(lambda (window _ov pos)
(with-selected-window window
@@ -543,7 +649,8 @@ associated `flymake-category' return DEFAULT."
;; Some properties can't be overridden.
;;
(overlay-put ov 'evaporate t)
- (overlay-put ov 'flymake-diagnostic diagnostic)))
+ (overlay-put ov 'flymake-diagnostic diagnostic)
+ ov))
;; Nothing in Flymake uses this at all any more, so this is just for
;; third-party compatibility.
@@ -590,13 +697,15 @@ backend is operating normally.")
(flymake-running-backends))
(cl-defun flymake--handle-report (backend token report-action
- &key explanation force
+ &key explanation force region
&allow-other-keys)
"Handle reports from BACKEND identified by TOKEN.
-BACKEND, REPORT-ACTION and EXPLANATION, and FORCE conform to the calling
-convention described in `flymake-diagnostic-functions' (which
-see). Optional FORCE says to handle a report even if TOKEN was
-not expected."
+BACKEND, REPORT-ACTION and EXPLANATION, and FORCE conform to the
+calling convention described in
+`flymake-diagnostic-functions' (which see). Optional FORCE says
+to handle a report even if TOKEN was not expected. REGION is
+a (BEG . END) pair of buffer positions indicating that this
+report applies to that region."
(let* ((state (gethash backend flymake--backend-state))
(first-report (not (flymake--backend-state-reported-p state))))
(setf (flymake--backend-state-reported-p state) t)
@@ -628,16 +737,27 @@ not expected."
(setq new-diags report-action)
(save-restriction
(widen)
- ;; only delete overlays if this is the first report
- (when first-report
- (flymake-delete-own-overlays
- (lambda (ov)
- (eq backend
- (flymake--diag-backend
- (overlay-get ov 'flymake-diagnostic))))))
+ ;; Before adding to backend's diagnostic list, decide if
+ ;; some or all must be deleted. When deleting, also delete
+ ;; the associated overlay.
+ (cond
+ (region
+ (cl-loop for diag in (flymake--backend-state-diags state)
+ if (or (> (flymake--diag-end diag) (car region))
+ (< (flymake--diag-beg diag) (cdr region)))
+ do (delete-overlay (flymake--diag-overlay diag))
+ else collect diag into surviving
+ finally (setf (flymake--backend-state-diags state)
+ surviving)))
+ (first-report
+ (dolist (diag (flymake--backend-state-diags state))
+ (delete-overlay (flymake--diag-overlay diag)))
+ (setf (flymake--backend-state-diags state) nil)))
+ ;; Now make new ones
(mapc (lambda (diag)
- (flymake--highlight-line diag)
- (setf (flymake--diag-backend diag) backend))
+ (let ((overlay (flymake--highlight-line diag)))
+ (setf (flymake--diag-backend diag) backend
+ (flymake--diag-overlay diag) overlay)))
new-diags)
(setf (flymake--backend-state-diags state)
(append new-diags (flymake--backend-state-diags state)))
@@ -645,7 +765,8 @@ not expected."
(flymake-log :debug "backend %s reported %d diagnostics in %.2f second(s)"
backend
(length new-diags)
- (- (float-time) flymake-check-start-time)))
+ (float-time
+ (time-since flymake-check-start-time))))
(when (and (get-buffer (flymake--diagnostics-buffer-name))
(get-buffer-window (flymake--diagnostics-buffer-name))
(null (cl-set-difference (flymake-running-backends)
@@ -709,14 +830,15 @@ If it is running also stop it."
(flymake--backend-state-disabled state) explanation
(flymake--backend-state-reported-p state) t)))
-(defun flymake--run-backend (backend)
- "Run the backend BACKEND, reenabling if necessary."
+(defun flymake--run-backend (backend &optional args)
+ "Run the backend BACKEND, re-enabling if necessary.
+ARGS is a keyword-value plist passed to the backend along
+with a report function."
(flymake-log :debug "Running backend %s" backend)
(let ((run-token (cl-gensym "backend-token")))
(flymake--with-backend-state backend state
(setf (flymake--backend-state-running state) run-token
(flymake--backend-state-disabled state) nil
- (flymake--backend-state-diags state) nil
(flymake--backend-state-reported-p state) nil))
;; FIXME: Should use `condition-case-unless-debug' here, but don't
;; for two reasons: (1) that won't let me catch errors from inside
@@ -727,11 +849,14 @@ If it is running also stop it."
;; backend) will trigger an annoying backtrace.
;;
(condition-case err
- (funcall backend
- (flymake-make-report-fn backend run-token))
+ (apply backend (flymake-make-report-fn backend run-token)
+ args)
(error
(flymake--disable-backend backend err)))))
+(defvar-local flymake--recent-changes nil
+ "Recent changes collected by `flymake-after-change-function'.")
+
(defun flymake-start (&optional deferred force)
"Start a syntax check for the current buffer.
DEFERRED is a list of symbols designating conditions to wait for
@@ -777,18 +902,30 @@ Interactively, with a prefix arg, FORCE is t."
'append 'local))
(t
(setq flymake-check-start-time (float-time))
- (run-hook-wrapped
- 'flymake-diagnostic-functions
- (lambda (backend)
- (cond
- ((and (not force)
- (flymake--with-backend-state backend state
- (flymake--backend-state-disabled state)))
- (flymake-log :debug "Backend %s is disabled, not starting"
- backend))
- (t
- (flymake--run-backend backend)))
- nil)))))))
+ (let ((backend-args
+ (and
+ flymake--recent-changes
+ (list :recent-changes
+ flymake--recent-changes
+ :changes-start
+ (cl-reduce
+ #'min (mapcar #'car flymake--recent-changes))
+ :changes-end
+ (cl-reduce
+ #'max (mapcar #'cadr flymake--recent-changes))))))
+ (setq flymake--recent-changes nil)
+ (run-hook-wrapped
+ 'flymake-diagnostic-functions
+ (lambda (backend)
+ (cond
+ ((and (not force)
+ (flymake--with-backend-state backend state
+ (flymake--backend-state-disabled state)))
+ (flymake-log :debug "Backend %s is disabled, not starting"
+ backend))
+ (t
+ (flymake--run-backend backend backend-args)))
+ nil))))))))
(defvar flymake-mode-map
(let ((map (make-sparse-keymap))) map)
@@ -797,9 +934,6 @@ Interactively, with a prefix arg, FORCE is t."
;;;###autoload
(define-minor-mode flymake-mode
"Toggle Flymake mode on or off.
-With a prefix argument ARG, enable Flymake mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'.
Flymake is an Emacs minor mode for on-the-fly syntax checking.
Flymake collects diagnostic information from multiple sources,
@@ -818,7 +952,9 @@ The commands `flymake-goto-next-error' and
diagnostics annotated in the buffer.
The visual appearance of each type of diagnostic can be changed
-in the variable `flymake-diagnostic-types-alist'.
+by setting properties `flymake-overlay-control', `flymake-bitmap'
+and `flymake-severity' on the symbols of diagnostic types (like
+`:error', `:warning' and `:note').
Activation or deactivation of backends used by Flymake in each
buffer happens via the special hook
@@ -838,7 +974,13 @@ special *Flymake log* buffer." :group 'flymake :lighter
(add-hook 'after-save-hook 'flymake-after-save-hook nil t)
(add-hook 'kill-buffer-hook 'flymake-kill-buffer-hook nil t)
+ ;; If Flymake happened to be alrady already ON, we must cleanup
+ ;; existing diagnostic overlays, lest we forget them by blindly
+ ;; reinitializing `flymake--backend-state' in the next line.
+ ;; See https://github.com/joaotavora/eglot/issues/223.
+ (mapc #'delete-overlay (flymake--overlays))
(setq flymake--backend-state (make-hash-table))
+ (setq flymake--recent-changes nil)
(when flymake-start-on-flymake-mode (flymake-start t)))
@@ -849,7 +991,7 @@ special *Flymake log* buffer." :group 'flymake :lighter
(remove-hook 'kill-buffer-hook 'flymake-kill-buffer-hook t)
;;+(remove-hook 'find-file-hook (function flymake-find-file-hook) t)
- (flymake-delete-own-overlays)
+ (mapc #'delete-overlay (flymake--overlays))
(when flymake-timer
(cancel-timer flymake-timer)
@@ -863,6 +1005,8 @@ Do it only if `flymake-no-changes-timeout' is non-nil."
(setq
flymake-timer
(run-with-idle-timer
+ ;; This can use encode-time instead of seconds-to-time,
+ ;; once we can assume Emacs 27 or later.
(seconds-to-time flymake-no-changes-timeout)
nil
(lambda (buffer)
@@ -891,15 +1035,17 @@ Do it only if `flymake-no-changes-timeout' is non-nil."
(make-obsolete 'flymake-mode-off 'flymake-mode "26.1")
(defun flymake-after-change-function (start stop _len)
- "Start syntax check for current buffer if it isn't already running."
+ "Start syntax check for current buffer if it isn't already running.
+START and STOP and LEN are as in `after-change-functions'."
(let((new-text (buffer-substring start stop)))
+ (push (list start stop new-text) flymake--recent-changes)
(when (and flymake-start-syntax-check-on-newline (equal new-text "\n"))
(flymake-log :debug "starting syntax check as new-line has been seen")
(flymake-start t))
(flymake--schedule-timer-maybe)))
(defun flymake-after-save-hook ()
- (when flymake-mode
+ (when flymake-start-on-save-buffer
(flymake-log :debug "starting syntax check as buffer was saved")
(flymake-start t)))
@@ -922,9 +1068,9 @@ arg, skip any diagnostics with a severity less than `:warning'.
If `flymake-wrap-around' is non-nil and no more next diagnostics,
resumes search from top.
-FILTER is a list of diagnostic types found in
-`flymake-diagnostic-types-alist', or nil, if no filter is to be
-applied."
+FILTER is a list of diagnostic types. Only diagnostics with
+matching severities matching are considered. If nil (the
+default) no filter is applied."
;; TODO: let filter be a number, a severity below which diags are
;; skipped.
(interactive (list 1
@@ -938,9 +1084,12 @@ applied."
ov
'flymake-diagnostic)))
(and diag
- (or (not filter)
- (memq (flymake--diag-type diag)
- filter)))))
+ (or
+ (not filter)
+ (cl-find
+ (flymake--severity
+ (flymake--diag-type diag))
+ filter :key #'flymake--severity)))))
:compare (if (cl-plusp n) #'< #'>)
:key #'overlay-start))
(tail (cl-member-if (lambda (ov)
@@ -964,10 +1113,10 @@ applied."
(funcall (overlay-get target 'help-echo)
(selected-window) target (point)))))
(interactive
- (user-error "No more Flymake errors%s"
+ (user-error "No more Flymake diagnostics%s"
(if filter
- (format " of types %s" filter)
- ""))))))
+ (format " of %s severity"
+ (mapconcat #'symbol-name filter ", ")) ""))))))
(defun flymake-goto-prev-error (&optional n filter interactive)
"Go to Nth previous Flymake diagnostic that matches FILTER.
@@ -978,9 +1127,9 @@ prefix arg, skip any diagnostics with a severity less than
If `flymake-wrap-around' is non-nil and no more previous
diagnostics, resumes search from bottom.
-FILTER is a list of diagnostic types found in
-`flymake-diagnostic-types-alist', or nil, if no filter is to be
-applied."
+FILTER is a list of diagnostic types. Only diagnostics with
+matching severities matching are considered. If nil (the
+default) no filter is applied."
(interactive (list 1 (if current-prefix-arg
'(:error :warning))
t))
@@ -990,7 +1139,7 @@ applied."
;;; Mode-line and menu
;;;
(easy-menu-define flymake-menu flymake-mode-map "Flymake"
- `("Flymake"
+ '("Flymake"
[ "Go to next problem" flymake-goto-next-error t ]
[ "Go to previous problem" flymake-goto-prev-error t ]
[ "Check now" flymake-start t ]
@@ -999,10 +1148,11 @@ applied."
[ "Go to log buffer" flymake-switch-to-log-buffer t ]
[ "Turn off Flymake" flymake-mode t ]))
-(defvar flymake--mode-line-format `(:eval (flymake--mode-line-format)))
+(defvar flymake--mode-line-format '(:eval (flymake--mode-line-format)))
(put 'flymake--mode-line-format 'risky-local-variable t)
+
(defun flymake--mode-line-format ()
"Produce a pretty minor mode indicator."
(let* ((known (hash-table-keys flymake--backend-state))
@@ -1038,16 +1188,16 @@ applied."
map))
,@(pcase-let ((`(,ind ,face ,explain)
(cond ((null known)
- `("?" mode-line "No known backends"))
+ '("?" mode-line "No known backends"))
(some-waiting
`("Wait" compilation-mode-line-run
,(format "Waiting for %s running backend(s)"
(length some-waiting))))
(all-disabled
- `("!" compilation-mode-line-run
+ '("!" compilation-mode-line-run
"All backends disabled"))
(t
- `(nil nil nil)))))
+ '(nil nil nil)))))
(when ind
`((":"
(:propertize ,ind
@@ -1061,22 +1211,23 @@ applied."
,@(unless (or all-disabled
(null known))
(cl-loop
- for (type . severity)
- in (cl-sort (mapcar (lambda (type)
- (cons type (flymake--lookup-type-property
- type
- 'severity
- (warning-numeric-level :error))))
- (cl-union (hash-table-keys diags-by-type)
- '(:error :warning)))
- #'>
- :key #'cdr)
+ with types = (hash-table-keys diags-by-type)
+ with _augmented = (cl-loop for extra in '(:error :warning)
+ do (cl-pushnew extra types
+ :key #'flymake--severity))
+ for type in (cl-sort types #'> :key #'flymake--severity)
for diags = (gethash type diags-by-type)
for face = (flymake--lookup-type-property type
'mode-line-face
'compilation-error)
when (or diags
- (>= severity (warning-numeric-level :warning)))
+ (cond ((eq flymake-suppress-zero-counters t)
+ nil)
+ (flymake-suppress-zero-counters
+ (>= (flymake--severity type)
+ (warning-numeric-level
+ flymake-suppress-zero-counters)))
+ (t t)))
collect `(:propertize
,(format "%d" (length diags))
face ,face
@@ -1180,14 +1331,14 @@ POS can be a buffer position or a button"
"Flymake diagnostics"
"A mode for listing Flymake diagnostics."
(setq tabulated-list-format
- `[("Line" 5 (lambda (l1 l2)
- (< (plist-get (car l1) :line)
- (plist-get (car l2) :line)))
+ `[("Line" 5 ,(lambda (l1 l2)
+ (< (plist-get (car l1) :line)
+ (plist-get (car l2) :line)))
:right-align t)
("Col" 3 nil :right-align t)
- ("Type" 8 (lambda (l1 l2)
- (< (plist-get (car l1) :severity)
- (plist-get (car l2) :severity))))
+ ("Type" 8 ,(lambda (l1 l2)
+ (< (plist-get (car l1) :severity)
+ (plist-get (car l2) :severity))))
("Message" 0 t)])
(setq tabulated-list-entries
'flymake--diagnostics-buffer-entries)
@@ -1204,9 +1355,9 @@ POS can be a buffer position or a button"
(target (or (get-buffer name)
(with-current-buffer (get-buffer-create name)
(flymake-diagnostics-buffer-mode)
- (setq flymake--diagnostics-buffer-source source)
(current-buffer)))))
(with-current-buffer target
+ (setq flymake--diagnostics-buffer-source source)
(revert-buffer)
(display-buffer (current-buffer)))))
diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el
index d04b00878e1..152667040fa 100644
--- a/lisp/progmodes/fortran.el
+++ b/lisp/progmodes/fortran.el
@@ -495,7 +495,7 @@ This is used to fontify fixed-format Fortran comments."
;; `byte-compile', but simple benchmarks indicate that it's probably not
;; worth the trouble (about 0.5% of slow down).
(eval ;I hate `eval', but it's hard to avoid it here.
- `(syntax-propertize-rules
+ '(syntax-propertize-rules
("^[CcDd\\*]" (0 "<"))
;; We mark all chars after line-length as "comment-start", rather than
;; just the first one. This is so that a closing ' that's past the
@@ -1040,13 +1040,9 @@ With non-nil ARG, uncomments the region."
Any other key combination is executed normally."
(interactive "*")
(insert last-command-event)
- (let* ((event (if (fboundp 'next-command-event) ; XEmacs
- (next-command-event)
- (read-event)))
- (char (if (fboundp 'event-to-character)
- (event-to-character event) event)))
+ (let ((event (read-event)))
;; Insert char if not equal to `?', or if abbrev-mode is off.
- (if (and abbrev-mode (or (eq char ??) (eq char help-char)
+ (if (and abbrev-mode (or (eq event ??) (eq event help-char)
(memq event help-event-list)))
(fortran-abbrev-help)
(push event unread-command-events))))
@@ -1799,7 +1795,7 @@ non-indentation text within the comment."
(goto-char (match-end 0)))
(t
;; Move past line number.
- (skip-chars-forward "[ \t0-9]")))
+ (skip-chars-forward " \t0-9")))
;; Move past whitespace.
(skip-chars-forward " \t")
(current-column)))
@@ -2056,7 +2052,7 @@ If ALL is nil, only match comments that start in column > 0."
(when (<= (point) bos)
(move-to-column (1+ fill-column))
;; What is this doing???
- (or (re-search-forward "[\t\n,'+-/*)=]" eol t)
+ (or (re-search-forward "[-\t\n,'+/*)=]" eol t)
(goto-char bol)))
(if (bolp)
(re-search-forward "[ \t]" opoint t))
diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el
index 69eb29c5eb1..716f40c1f3a 100644
--- a/lisp/progmodes/gdb-mi.el
+++ b/lisp/progmodes/gdb-mi.el
@@ -792,7 +792,7 @@ detailed description of this mode.
(gud-def gud-tbreak "tbreak %f:%l" "\C-t"
"Set temporary breakpoint at current line.")
(gud-def gud-jump
- (progn (gud-call "tbreak %f:%l") (gud-call "jump %f:%l"))
+ (progn (gud-call "tbreak %f:%l" arg) (gud-call "jump %f:%l"))
"\C-j" "Set execution address to current line.")
(gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).")
@@ -1140,9 +1140,7 @@ Used by Speedbar."
:version "22.2")
(define-minor-mode gdb-speedbar-auto-raise
- "Minor mode to automatically raise the speedbar for watch expressions.
-With prefix argument ARG, automatically raise speedbar if ARG is
-positive, otherwise don't automatically raise it."
+ "Minor mode to automatically raise the speedbar for watch expressions."
:global t
:group 'gdb
:version "22.1")
@@ -1375,7 +1373,7 @@ With arg, enter name of variable to be watched in the minibuffer."
TEXT is the text of the button we clicked on, a + or - item.
TOKEN is data related to this node.
INDENT is the current indentation depth."
- (cond ((string-match "+" text) ;expand this node
+ (cond ((string-match "\\+" text) ;expand this node
(let* ((var (assoc token gdb-var-list))
(expr (nth 1 var)) (children (nth 2 var)))
(if (or (<= (string-to-number children) gdb-max-children)
@@ -1745,16 +1743,12 @@ static char *magick[] = {
(defvar breakpoint-disabled-icon nil
"Icon for disabled breakpoint in display margin.")
-(declare-function define-fringe-bitmap "fringe.c"
- (bitmap bits &optional height width align))
-
-(and (display-images-p)
- ;; Bitmap for breakpoint in fringe
- (define-fringe-bitmap 'breakpoint
- "\x3c\x7e\xff\xff\xff\xff\x7e\x3c")
- ;; Bitmap for gud-overlay-arrow in fringe
- (define-fringe-bitmap 'hollow-right-triangle
- "\xe0\x90\x88\x84\x84\x88\x90\xe0"))
+;; Bitmap for breakpoint in fringe
+(define-fringe-bitmap 'breakpoint
+ "\x3c\x7e\xff\xff\xff\xff\x7e\x3c")
+;; Bitmap for gud-overlay-arrow in fringe
+(define-fringe-bitmap 'hollow-right-triangle
+ "\xe0\x90\x88\x84\x84\x88\x90\xe0")
(defface breakpoint-enabled
'((t
@@ -2720,10 +2714,10 @@ If `default-directory' is remote, full file names are adapted accordingly."
(insert "]"))))))
(goto-char (point-min))
(insert "{")
- (let ((re (concat "\\([[:alnum:]-_]+\\)=\\({\\|\\[\\|\"\"\\|"
- gdb--string-regexp "\\)")))
+ (let ((re (concat "\\([[:alnum:]-_]+\\)=")))
(while (re-search-forward re nil t)
- (replace-match "\"\\1\":\\2" nil nil)))
+ (replace-match "\"\\1\":" nil nil)
+ (if (eq (char-after) ?\") (forward-sexp) (forward-char))))
(goto-char (point-max))
(insert "}")))
@@ -4159,7 +4153,7 @@ member."
(when (not value)
(setq value "<complex data type>"))
(if (or (not value)
- (string-match "\\0x" value))
+ (string-match "0x" value))
(add-text-properties 0 (length name)
`(mouse-face highlight
help-echo "mouse-2: create watch expression"
diff --git a/lisp/progmodes/glasses.el b/lisp/progmodes/glasses.el
index 9c95951458a..2bfc256e18e 100644
--- a/lisp/progmodes/glasses.el
+++ b/lisp/progmodes/glasses.el
@@ -312,10 +312,9 @@ recognized according to the current value of the variable `glasses-separator'."
;;;###autoload
(define-minor-mode glasses-mode
"Minor mode for making identifiers likeThis readable.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil. When this mode is active, it tries to
-add virtual separators (like underscores) at places they belong to."
+
+When this mode is active, it tries to add virtual
+separators (like underscores) at places they belong to."
:group 'glasses :lighter " o^o"
(save-excursion
(save-restriction
@@ -326,10 +325,10 @@ add virtual separators (like underscores) at places they belong to."
(if glasses-mode
(progn
(jit-lock-register 'glasses-change)
- (add-hook 'local-write-file-hooks
+ (add-hook 'write-file-functions
'glasses-convert-to-unreadable nil t))
(jit-lock-unregister 'glasses-change)
- (remove-hook 'local-write-file-hooks
+ (remove-hook 'write-file-functions
'glasses-convert-to-unreadable t)))))
diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el
index 8b9a2d86c75..8c7a58fd8bd 100644
--- a/lisp/progmodes/grep.el
+++ b/lisp/progmodes/grep.el
@@ -29,6 +29,7 @@
;;; Code:
+(eval-when-compile (require 'cl-lib))
(require 'compile)
(defgroup grep nil
@@ -286,6 +287,11 @@ See `compilation-error-screen-columns'"
(define-key map [menu-bar grep]
(cons "Grep" (make-sparse-keymap "Grep")))
+ (define-key map [menu-bar grep grep-find-toggle-abbreviation]
+ '(menu-item "Toggle command abbreviation"
+ grep-find-toggle-abbreviation
+ :help "Toggle showing verbose command options"))
+ (define-key map [menu-bar grep compilation-separator3] '("----"))
(define-key map [menu-bar grep compilation-kill-compilation]
'(menu-item "Kill Grep" kill-compilation
:help "Kill the currently running grep process"))
@@ -308,7 +314,7 @@ See `compilation-error-screen-columns'"
(define-key map [menu-bar grep compilation-recompile]
'(menu-item "Repeat grep" recompile
:help "Run grep again"))
- (define-key map [menu-bar grep compilation-separator2] '("----"))
+ (define-key map [menu-bar grep compilation-separator1] '("----"))
(define-key map [menu-bar grep compilation-first-error]
'(menu-item "First Match" first-error
:help "Restart at the first match, visit corresponding location"))
@@ -348,17 +354,6 @@ See `compilation-error-screen-columns'"
(defalias 'kill-grep 'kill-compilation)
-;;;; TODO --- refine this!!
-
-;; (defcustom grep-use-compilation-buffer t
-;; "When non-nil, grep specific commands update `compilation-last-buffer'.
-;; This means that standard compile commands like \\[next-error] and \\[compile-goto-error]
-;; can be used to navigate between grep matches (the default).
-;; Otherwise, the grep specific commands like \\[grep-next-match] must
-;; be used to navigate between grep matches."
-;; :type 'boolean
-;; :group 'grep)
-
;; override compilation-last-buffer
(defvar grep-last-buffer nil
"The most recent grep buffer.
@@ -435,26 +430,57 @@ See `compilation-error-regexp-alist' for format details.")
help-echo "Number of matches so far")
"]"))
+(defcustom grep-find-abbreviate t
+ "If non-nil, hide part of rgrep/lgrep/zrgrep command line.
+The hidden part contains a list of ignored directories and files.
+Clicking on the button-like ellipsis unhides the abbreviated part
+and reveals the entire command line. The visibility of the
+abbreviated part can also be toggled with
+`grep-find-toggle-abbreviation'."
+ :type 'boolean
+ :version "27.1"
+ :group 'grep)
+
+(defvar grep-find-abbreviate-properties
+ (let ((ellipsis (if (char-displayable-p ?…) "[…]" "[...]"))
+ (map (make-sparse-keymap)))
+ (define-key map [down-mouse-2] 'mouse-set-point)
+ (define-key map [mouse-2] 'grep-find-toggle-abbreviation)
+ (define-key map "\C-m" 'grep-find-toggle-abbreviation)
+ `(face nil display ,ellipsis mouse-face highlight
+ help-echo "RET, mouse-2: show unabbreviated command"
+ keymap ,map abbreviated-command t))
+ "Properties of button-like ellipsis on part of rgrep command line.")
+
(defvar grep-mode-font-lock-keywords
'(;; Command output lines.
(": \\(.+\\): \\(?:Permission denied\\|No such \\(?:file or directory\\|device or address\\)\\)$"
1 grep-error-face)
;; remove match from grep-regexp-alist before fontifying
- ("^Grep[/a-zA-z]* started.*"
+ ("^Grep[/a-zA-Z]* started.*"
(0 '(face nil compilation-message nil help-echo nil mouse-face nil) t))
- ("^Grep[/a-zA-z]* finished with \\(?:\\(\\(?:[0-9]+ \\)?matches found\\)\\|\\(no matches found\\)\\).*"
+ ("^Grep[/a-zA-Z]* finished with \\(?:\\(\\(?:[0-9]+ \\)?match\\(?:es\\)? found\\)\\|\\(no matches found\\)\\).*"
(0 '(face nil compilation-message nil help-echo nil mouse-face nil) t)
(1 compilation-info-face nil t)
(2 compilation-warning-face nil t))
- ("^Grep[/a-zA-z]* \\(exited abnormally\\|interrupt\\|killed\\|terminated\\)\\(?:.*with code \\([0-9]+\\)\\)?.*"
+ ("^Grep[/a-zA-Z]* \\(exited abnormally\\|interrupt\\|killed\\|terminated\\)\\(?:.*with code \\([0-9]+\\)\\)?.*"
(0 '(face nil compilation-message nil help-echo nil mouse-face nil) t)
(1 grep-error-face)
(2 grep-error-face nil t))
;; "filename-linenumber-" format is used for context lines in GNU grep,
;; "filename=linenumber=" for lines with function names in "git grep -p".
- ("^.+?\\([-=\0]\\)[0-9]+\\([-=]\\).*\n" (0 grep-context-face)
+ ("^.+?\\([-=\0]\\)[0-9]+\\([-=]\\).*\n"
+ (0 grep-context-face)
(1 (if (eq (char-after (match-beginning 1)) ?\0)
- `(face nil display ,(match-string 2))))))
+ `(face nil display ,(match-string 2)))))
+ ;; Hide excessive part of rgrep command
+ ("^find \\(\\. -type d .*\\\\)\\)"
+ (1 (if grep-find-abbreviate grep-find-abbreviate-properties
+ '(face nil abbreviated-command t))))
+ ;; Hide excessive part of lgrep command
+ ("^grep \\( *--exclude.*--exclude[^ ]+\\)"
+ (1 (if grep-find-abbreviate grep-find-abbreviate-properties
+ '(face nil abbreviated-command t)))))
"Additional things to highlight in grep output.
This gets tacked on the end of the generated expressions.")
@@ -526,7 +552,10 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'."
;; so the buffer is still unmodified if there is no output.
(cond ((and (zerop code) (buffer-modified-p))
(if (> grep-num-matches-found 0)
- (cons (format "finished with %d matches found\n" grep-num-matches-found)
+ (cons (format (ngettext "finished with %d match found\n"
+ "finished with %d matches found\n"
+ grep-num-matches-found)
+ grep-num-matches-found)
"matched")
'("finished with matches found\n" . "matched")))
((not (buffer-modified-p))
@@ -608,22 +637,22 @@ This function is called from `compilation-filter-hook'."
;; `grep-command' is already set, so
;; use that for testing.
(grep-probe grep-command
- `(nil t nil "^English" ,hello-file)
+ `(nil t nil "^Copyright" ,hello-file)
#'call-process-shell-command)
;; otherwise use `grep-program'
(grep-probe grep-program
- `(nil t nil "-nH" "^English" ,hello-file)))
+ `(nil t nil "-nH" "^Copyright" ,hello-file)))
(progn
(goto-char (point-min))
(looking-at
(concat (regexp-quote hello-file)
- ":[0-9]+:English")))))))))
+ ":[0-9]+:Copyright")))))))))
(when (eq grep-use-null-filename-separator 'auto-detect)
(setq grep-use-null-filename-separator
(with-temp-buffer
(let* ((hello-file (expand-file-name "HELLO" data-directory))
- (args `("--null" "-ne" "^English" ,hello-file)))
+ (args `("--null" "-ne" "^Copyright" ,hello-file)))
(if grep-use-null-device
(setq args (append args (list null-device)))
(push "-H" args))
@@ -632,7 +661,7 @@ This function is called from `compilation-filter-hook'."
(goto-char (point-min))
(looking-at
(concat (regexp-quote hello-file)
- "\0[0-9]+:English"))))))))
+ "\0[0-9]+:Copyright"))))))))
(when (eq grep-highlight-matches 'auto-detect)
(setq grep-highlight-matches
@@ -678,7 +707,7 @@ This function is called from `compilation-filter-hook'."
'exec-plus)
((and
(grep-probe find-program `(nil nil nil ,null-device "-print0"))
- (grep-probe xargs-program `(nil nil nil "-0" "echo")))
+ (grep-probe xargs-program '(nil nil nil "-0" "echo")))
'gnu)
(t
'exec))))
@@ -930,8 +959,16 @@ substitution string. Note dynamic scoping of variables.")
The pattern can include shell wildcards. As whitespace triggers
completion when entering a pattern, including it requires
quoting, e.g. `\\[quoted-insert]<space>'."
- (let* ((bn (or (buffer-file-name)
- (replace-regexp-in-string "<[0-9]+>\\'" "" (buffer-name))))
+ (let* ((grep-read-files-function (get major-mode 'grep-read-files))
+ (file-name-at-point
+ (run-hook-with-args-until-success 'file-name-at-point-functions))
+ (bn (if grep-read-files-function
+ (funcall grep-read-files-function)
+ (or (if (and (stringp file-name-at-point)
+ (not (file-directory-p file-name-at-point)))
+ file-name-at-point)
+ (buffer-file-name)
+ (replace-regexp-in-string "<[0-9]+>\\'" "" (buffer-name)))))
(fn (and bn
(stringp bn)
(file-name-nondirectory bn)))
@@ -1048,6 +1085,7 @@ This command shares argument histories with \\[rgrep] and \\[grep]."
(concat command " " null-device)
command)
'grep-mode))
+ ;; Set default-directory if we started lgrep in the *grep* buffer.
(if (eq next-error-last-buffer (current-buffer))
(setq default-directory dir))))))
@@ -1170,6 +1208,20 @@ to specify a command to run."
(shell-quote-argument ")")
" -prune -o ")))))
+(defun grep-find-toggle-abbreviation ()
+ "Toggle showing the hidden part of rgrep/lgrep/zrgrep command line."
+ (interactive)
+ (with-silent-modifications
+ (let* ((beg (next-single-property-change (point-min) 'abbreviated-command))
+ (end (when beg
+ (next-single-property-change beg 'abbreviated-command))))
+ (if end
+ (if (get-text-property beg 'display)
+ (remove-list-of-text-properties
+ beg end '(display help-echo mouse-face help-echo keymap))
+ (add-text-properties beg end grep-find-abbreviate-properties))
+ (user-error "No abbreviated part to hide/show")))))
+
;;;###autoload
(defun zrgrep (regexp &optional files dir confirm template)
"Recursively grep for REGEXP in gzipped FILES in tree rooted at DIR.
diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el
index d918dbd5ef9..4306f5daa02 100644
--- a/lisp/progmodes/gud.el
+++ b/lisp/progmodes/gud.el
@@ -378,6 +378,7 @@ we're in the GUD buffer)."
(if (not gud-running)
,(if (stringp cmd)
`(gud-call ,cmd arg)
+ ;; Unused lexical warning if cmd does not use "arg".
cmd))))
,(if key `(local-set-key ,(concat "\C-c" key) ',func))
,(if key `(global-set-key (vconcat gud-key-prefix ,key) ',func))))
@@ -544,8 +545,8 @@ required by the caller."
nil
(if gdb-show-changed-values
(or parent (pcase status
- (`changed 'font-lock-warning-face)
- (`out-of-scope 'shadow)
+ ('changed 'font-lock-warning-face)
+ ('out-of-scope 'shadow)
(_ t)))
t)
depth)
@@ -565,8 +566,8 @@ required by the caller."
nil
(if gdb-show-changed-values
(or parent (pcase status
- (`changed 'font-lock-warning-face)
- (`out-of-scope 'shadow)
+ ('changed 'font-lock-warning-face)
+ ('out-of-scope 'shadow)
(_ t)))
t)
depth)
@@ -677,7 +678,7 @@ The option \"--fullname\" must be included in this value."
;; gud-marker-acc until we receive the rest of it. Since we
;; know the full marker regexp above failed, it's pretty simple to
;; test for marker starts.
- (if (string-match "\n\\(\032.*\\)?\\'" gud-marker-acc)
+ (if (string-match "\\(\n\\)?\\(\032.*\\)?\\'" gud-marker-acc)
(progn
;; Everything before the potential marker start can be output.
(setq output (concat output (substring gud-marker-acc
@@ -771,7 +772,7 @@ the buffer in which this command was invoked."
(gud-def gud-cont "cont" "\C-r" "Continue with display.")
(gud-def gud-finish "finish" "\C-f" "Finish executing current function.")
(gud-def gud-jump
- (progn (gud-call "tbreak %f:%l") (gud-call "jump %f:%l"))
+ (progn (gud-call "tbreak %f:%l" arg) (gud-call "jump %f:%l"))
"\C-j" "Set execution address to current line.")
(gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).")
@@ -1605,7 +1606,7 @@ and source-file directory for your debugger."
;; Last group is for return value, e.g. "> test.py(2)foo()->None"
;; Either file or function name may be omitted: "> <string>(0)?()"
(defvar gud-pdb-marker-regexp
- "^> \\([-a-zA-Z0-9_/.:\\]*\\|<string>\\)(\\([0-9]+\\))\\([a-zA-Z0-9_]*\\|\\?\\|<module>\\)()\\(->[^\n\r]*\\)?[\n\r]")
+ "^> \\([-a-zA-Z0-9_/.:@ \\]*\\|<string>\\)(\\([0-9]+\\))\\([a-zA-Z0-9_]*\\|\\?\\|<module>\\)()\\(->[^\n\r]*\\)?[\n\r]")
(defvar gud-pdb-marker-regexp-file-group 1)
(defvar gud-pdb-marker-regexp-line-group 2)
@@ -2236,7 +2237,7 @@ relative to a classpath directory."
(split-string
;; Eliminate any subclass references in the class
;; name string. These start with a "$"
- (if (string-match "$.*" p)
+ (if (string-match "\\$.*" p)
(replace-match "" t t p) p)
"\\.") "/")
".java"))
@@ -2604,7 +2605,12 @@ comint mode, which see."
file-subst)))
(filepart (and file-word (concat "-" (file-name-nondirectory file))))
(existing-buffer (get-buffer (concat "*gud" filepart "*"))))
- (switch-to-buffer (concat "*gud" filepart "*"))
+ (select-window
+ (display-buffer
+ (get-buffer-create (concat "*gud" filepart "*"))
+ '(display-buffer-reuse-window
+ display-buffer-in-previous-window
+ display-buffer-same-window display-buffer-pop-up-window)))
(when (and existing-buffer (get-buffer-process existing-buffer))
(error "This program is already being debugged"))
;; Set the dir, in case the buffer already existed with a different dir.
@@ -3357,10 +3363,7 @@ Treats actions as defuns."
;;;###autoload
(define-minor-mode gud-tooltip-mode
- "Toggle the display of GUD tooltips.
-With a prefix argument ARG, enable the feature if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-it if ARG is omitted or nil."
+ "Toggle the display of GUD tooltips."
:global t
:group 'gud
:group 'tooltip
@@ -3395,9 +3398,6 @@ it if ARG is omitted or nil."
(kill-local-variable 'gdb-define-alist)
(remove-hook 'after-save-hook 'gdb-create-define-alist t))))
-(define-obsolete-variable-alias 'tooltip-gud-modes
- 'gud-tooltip-modes "22.1")
-
(defcustom gud-tooltip-modes '(gud-mode c-mode c++-mode fortran-mode
python-mode)
"List of modes for which to enable GUD tooltips."
@@ -3405,9 +3405,6 @@ it if ARG is omitted or nil."
:group 'gud
:group 'tooltip)
-(define-obsolete-variable-alias 'tooltip-gud-display
- 'gud-tooltip-display "22.1")
-
(defcustom gud-tooltip-display
'((eq (tooltip-event-buffer gud-tooltip-event)
(marker-buffer gud-overlay-arrow-position)))
@@ -3499,8 +3496,6 @@ With arg, dereference expr if ARG is positive, otherwise do not dereference."
(message "Dereferencing is now %s."
(if gud-tooltip-dereference "on" "off")))
-(define-obsolete-function-alias 'tooltip-gud-toggle-dereference
- 'gud-tooltip-dereference "22.1")
(defvar tooltip-use-echo-area)
(declare-function tooltip-show "tooltip" (text &optional use-echo-area))
(declare-function tooltip-strip-prompt "tooltip" (process output))
@@ -3521,11 +3516,11 @@ With arg, dereference expr if ARG is positive, otherwise do not dereference."
(defun gud-tooltip-print-command (expr)
"Return a suitable command to print the expression EXPR."
(pcase gud-minor-mode
- (`gdbmi (concat "-data-evaluate-expression \"" expr "\""))
- (`guiler expr)
- (`dbx (concat "print " expr))
- ((or `xdb `pdb) (concat "p " expr))
- (`sdb (concat expr "/"))))
+ ('gdbmi (concat "-data-evaluate-expression \"" expr "\""))
+ ('guiler expr)
+ ('dbx (concat "print " expr))
+ ((or 'xdb 'pdb) (concat "p " expr))
+ ('sdb (concat expr "/"))))
(declare-function gdb-input "gdb-mi" (command handler &optional trigger))
(declare-function tooltip-expr-to-print "tooltip" (event))
diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el
index 442fdedf372..32b0b7551f9 100644
--- a/lisp/progmodes/hideif.el
+++ b/lisp/progmodes/hideif.el
@@ -263,9 +263,6 @@ This backup prevents any accidental clearance of `hide-fidef-env' by
;;;###autoload
(define-minor-mode hide-ifdef-mode
"Toggle features to hide/show #ifdef blocks (Hide-Ifdef mode).
-With a prefix argument ARG, enable Hide-Ifdef mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Hide-Ifdef mode is a buffer-local minor mode for use with C and
C-like major modes. When enabled, code within #ifdef constructs
@@ -675,12 +672,7 @@ that form should be displayed.")
result))
(nreverse result)))
-(defun hif-flatten (l)
- "Flatten a tree."
- (apply #'nconc
- (mapcar (lambda (x) (if (listp x)
- (hif-flatten x)
- (list x))) l)))
+(define-obsolete-function-alias 'hif-flatten #'flatten-tree "27.1")
(defun hif-expand-token-list (tokens &optional macroname expand_list)
"Perform expansion on TOKENS till everything expanded.
@@ -751,7 +743,7 @@ detecting self-reference."
expanded))
- (hif-flatten (nreverse expanded)))))
+ (flatten-tree (nreverse expanded)))))
(defun hif-parse-exp (token-list &optional macroname)
"Parse the TOKEN-LIST.
@@ -1042,16 +1034,12 @@ preprocessing token"
(defun hif-shiftleft (a b)
(setq a (hif-mathify a))
(setq b (hif-mathify b))
- (if (< a 0)
- (ash a b)
- (lsh a b)))
+ (ash a b))
(defun hif-shiftright (a b)
(setq a (hif-mathify a))
(setq b (hif-mathify b))
- (if (< a 0)
- (ash a (- b))
- (lsh a (- b))))
+ (ash a (- b)))
(defalias 'hif-multiply (hif-mathify-binop *))
@@ -1173,7 +1161,7 @@ preprocessing token"
(setq actual-parms (cdr actual-parms)))
;; Replacement completed, flatten the whole token list
- (setq macro-body (hif-flatten macro-body))
+ (setq macro-body (flatten-tree macro-body))
;; Stringification and token concatenation happens here
(hif-token-concatenation (hif-token-stringification macro-body)))))
@@ -1628,7 +1616,7 @@ not be expanded."
((integerp result)
(if (or (= 0 result) (= 1 result))
(message "%S <= `%s'" result exprstring)
- (message "%S (0x%x) <= `%s'" result result exprstring)))
+ (message "%S (%#x) <= `%s'" result result exprstring)))
((null result) (message "%S <= `%s'" 'false exprstring))
((eq t result) (message "%S <= `%s'" 'true exprstring))
(t (message "%S <= `%s'" result exprstring)))
diff --git a/lisp/progmodes/hideshow.el b/lisp/progmodes/hideshow.el
index 88f055e3ada..dcce2a6e2a9 100644
--- a/lisp/progmodes/hideshow.el
+++ b/lisp/progmodes/hideshow.el
@@ -932,9 +932,6 @@ This can be useful if you have huge RCS logs in those comments."
;;;###autoload
(define-minor-mode hs-minor-mode
"Minor mode to selectively hide/show code and comment blocks.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
When hideshow minor mode is on, the menu bar is augmented with hideshow
commands and the hideshow commands are enabled.
diff --git a/lisp/progmodes/idlw-complete-structtag.el b/lisp/progmodes/idlw-complete-structtag.el
index 8a50b9b5375..51c9117cd41 100644
--- a/lisp/progmodes/idlw-complete-structtag.el
+++ b/lisp/progmodes/idlw-complete-structtag.el
@@ -128,7 +128,7 @@ an up-to-date completion list."
;; x[i+4].name.g*. But it is complicated because we would have
;; to really parse this expression. For now, we allow only
;; substructures, like "aaa.bbb.ccc.ddd"
- (skip-chars-backward "[a-zA-Z0-9._$]")
+ (skip-chars-backward "a-zA-Z0-9._$")
(setq start (point)) ;; remember the start of the completion pos.
(and (< (point) pos)
(not (equal (char-before) ?!)) ; no sysvars
diff --git a/lisp/progmodes/idlw-help.el b/lisp/progmodes/idlw-help.el
index ec037596e04..4588e93dcf4 100644
--- a/lisp/progmodes/idlw-help.el
+++ b/lisp/progmodes/idlw-help.el
@@ -1181,9 +1181,10 @@ Useful when source code is displayed as help. See the option
(with-syntax-table idlwave-mode-syntax-table
(set (make-local-variable 'font-lock-defaults)
idlwave-font-lock-defaults)
- (if (fboundp 'font-lock-ensure)
+ (if (fboundp 'font-lock-ensure) ; Emacs >= 25.1
(font-lock-ensure)
- (font-lock-fontify-buffer))))))
+ ;; Silence "interactive use only" warning on Emacs >= 25.1.
+ (with-no-warnings (font-lock-fontify-buffer)))))))
(defun idlwave-help-error (name type class keyword)
diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el
index 883616cd285..a3b079830b2 100644
--- a/lisp/progmodes/idlw-shell.el
+++ b/lisp/progmodes/idlw-shell.el
@@ -1,4 +1,4 @@
-;; idlw-shell.el --- run IDL as an inferior process of Emacs.
+;; idlw-shell.el --- run IDL as an inferior process of Emacs. -*- lexical-binding:t -*-
;; Copyright (C) 1999-2019 Free Software Foundation, Inc.
@@ -92,7 +92,7 @@
(require 'comint)
(require 'idlwave)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defvar idlwave-shell-have-new-custom nil)
@@ -1115,8 +1115,7 @@ IDL has currently stepped.")
(setq idlwave-shell-display-wframe
(if (eq (selected-frame) idlwave-shell-idl-wframe)
(or
- (let ((flist (visible-frame-list))
- (frame (selected-frame)))
+ (let ((flist (visible-frame-list)))
(catch 'exit
(while flist
(if (not (eq (car flist)
@@ -1142,7 +1141,7 @@ IDL has currently stepped.")
(make-frame idlwave-shell-frame-parameters)))))
;;;###autoload
-(defun idlwave-shell (&optional arg quick)
+(defun idlwave-shell (&optional arg)
"Run an inferior IDL, with I/O through buffer `(idlwave-shell-buffer)'.
If buffer exists but shell process is not running, start new IDL.
If buffer exists and shell process is running, just switch to the buffer.
@@ -1881,10 +1880,10 @@ directory."
'idlwave-shell-filter-directory
'hide 'wait))
-(defun idlwave-shell-retall (&optional arg)
+(defun idlwave-shell-retall ()
"Return from the entire calling stack.
Also get rid of widget events in the queue."
- (interactive "P")
+ (interactive)
(save-selected-window
;;if (widget_info(/MANAGED))[0] gt 0 then for i=0,n_elements(widget_info(/MANAGED))-1 do widget_control,(widget_info(/MANAGED))[i],/clear_events &
(idlwave-shell-send-command "retall" nil
@@ -1892,9 +1891,9 @@ Also get rid of widget events in the queue."
nil t)
(idlwave-shell-display-line nil)))
-(defun idlwave-shell-closeall (&optional arg)
+(defun idlwave-shell-closeall ()
"Close all open files."
- (interactive "P")
+ (interactive)
(idlwave-shell-send-command "close,/all" nil
(idlwave-shell-hide-p 'misc) nil t))
@@ -2157,7 +2156,7 @@ keywords."
(if entry (setq idlw-help-link (cdr entry)))) ; setting dynamic variable!
(t (error "This should not happen")))))
-(defun idlwave-shell-complete-filename (&optional arg)
+(defun idlwave-shell-complete-filename ()
"Complete a file name at point if after a file name.
We assume that we are after a file name when completing one of the
args of an executive .run, .rnew or .compile."
@@ -2261,12 +2260,12 @@ overlays."
(defun idlwave-shell-stack-up ()
"Display the source code one step up the calling stack."
(interactive)
- (incf idlwave-shell-calling-stack-index)
+ (cl-incf idlwave-shell-calling-stack-index)
(idlwave-shell-display-level-in-calling-stack 'hide))
(defun idlwave-shell-stack-down ()
"Display the source code one step down the calling stack."
(interactive)
- (decf idlwave-shell-calling-stack-index)
+ (cl-decf idlwave-shell-calling-stack-index)
(idlwave-shell-display-level-in-calling-stack 'hide))
(defun idlwave-shell-goto-frame (&optional frame)
@@ -2739,10 +2738,9 @@ Runs to the last statement and then steps 1 statement. Use the .out command."
(bp-alist idlwave-shell-bp-alist)
(orig-func (if (> dir 0) '> '<))
(closer-func (if (> dir 0) '< '>))
- bp got-bp bp-line cur-line)
+ bp bp-line cur-line)
(while (setq bp (pop bp-alist))
(when (string= file (car (car bp)))
- (setq got-bp 1)
(setq cur-line (nth 1 (car bp)))
(if (and
(funcall orig-func cur-line orig-bp-line)
@@ -2759,6 +2757,8 @@ Runs to the last statement and then steps 1 statement. Use the .out command."
(interactive "P")
(idlwave-shell-print arg 'help))
+(defvar zmacs-regions)
+
(defmacro idlwave-shell-mouse-examine (help &optional ev)
"Create a function for generic examination of expressions."
`(lambda (event)
@@ -2782,7 +2782,7 @@ Runs to the last statement and then steps 1 statement. Use the .out command."
;; Begin terrible hack section -- XEmacs tests for button2 explicitly
;; on drag events, calling drag-n-drop code if detected. Ughhh...
-(defun idlwave-default-mouse-track-event-is-with-button (event n)
+(defun idlwave-default-mouse-track-event-is-with-button (_event _n)
t)
(defun idlwave-xemacs-hack-mouse-track (event)
@@ -3193,22 +3193,20 @@ size(___,/DIMENSIONS)"
output-begin output-end buffer))))
(defun idlwave-shell-delete-output-overlay ()
- (unless (or (eq this-command 'idlwave-shell-mouse-nop)
- (eq this-command 'handle-switch-frame))
+ (unless (memql this-command '(ignore handle-switch-frame))
(condition-case nil
(if idlwave-shell-output-overlay
(delete-overlay idlwave-shell-output-overlay))
(error nil))
- (remove-hook 'pre-command-hook 'idlwave-shell-delete-output-overlay)))
+ (remove-hook 'pre-command-hook #'idlwave-shell-delete-output-overlay)))
(defun idlwave-shell-delete-expression-overlay ()
- (unless (or (eq this-command 'idlwave-shell-mouse-nop)
- (eq this-command 'handle-switch-frame))
+ (unless (memql this-command '(ignore handle-switch-frame))
(condition-case nil
(if idlwave-shell-expression-overlay
(delete-overlay idlwave-shell-expression-overlay))
(error nil))
- (remove-hook 'pre-command-hook 'idlwave-shell-delete-expression-overlay)))
+ (remove-hook 'pre-command-hook #'idlwave-shell-delete-expression-overlay)))
(defvar idlwave-shell-bp-alist nil
"Alist of breakpoints.
@@ -3591,13 +3589,13 @@ Existing overlays are recycled, in order to minimize consumption."
(bp-list idlwave-shell-bp-alist)
(use-glyph (and (memq idlwave-shell-mark-breakpoints '(t glyph))
idlwave-shell-bp-glyph))
- ov ov-list bp buf old-buffers win)
+ ov ov-list bp buf old-buffers)
;; Delete the old overlays from their buffers
(if ov-alist
(while (setq ov-list (pop ov-alist))
(while (setq ov (pop (cdr ov-list)))
- (pushnew (overlay-buffer ov) old-buffers)
+ (cl-pushnew (overlay-buffer ov) old-buffers)
(delete-overlay ov))))
(setq ov-alist idlwave-shell-bp-overlays
@@ -3798,9 +3796,9 @@ only for glyphs)."
(t
(message "Unimplemented: %s" select))))))
-(defun idlwave-shell-edit-default-command-line (arg)
+(defun idlwave-shell-edit-default-command-line ()
"Edit the current execute command."
- (interactive "P")
+ (interactive)
(setq idlwave-shell-command-line-to-execute
(read-string "IDL> " idlwave-shell-command-line-to-execute)))
@@ -4057,9 +4055,56 @@ Otherwise, just expand the file name."
;; Keybindings ------------------------------------------------------------
-(defvar idlwave-shell-mode-map (copy-keymap comint-mode-map)
+(defvar idlwave-shell-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map comint-mode-map)
+
+ ;;(define-key map "\M-?" 'comint-dynamic-list-completions)
+ ;;(define-key map "\t" 'comint-dynamic-complete)
+
+ (define-key map "\C-w" 'comint-kill-region)
+ (define-key map "\t" 'idlwave-shell-complete)
+ (define-key map "\M-\t" 'idlwave-shell-complete)
+ (define-key map "\C-c\C-s" 'idlwave-shell)
+ (define-key map "\C-c?" 'idlwave-routine-info)
+ (define-key map "\C-g" 'idlwave-keyboard-quit)
+ (define-key map "\M-?" 'idlwave-context-help)
+ (define-key map [(control meta ?\?)]
+ 'idlwave-help-assistant-help-with-topic)
+ (define-key map "\C-c\C-i" 'idlwave-update-routine-info)
+ (define-key map "\C-c\C-y" 'idlwave-shell-char-mode-loop)
+ (define-key map "\C-c\C-x" 'idlwave-shell-send-char)
+ (define-key map "\C-c=" 'idlwave-resolve)
+ (define-key map "\C-c\C-v" 'idlwave-find-module)
+ (define-key map "\C-c\C-k" 'idlwave-kill-autoloaded-buffers)
+ (define-key map idlwave-shell-prefix-key
+ 'idlwave-shell-debug-map)
+ (define-key map [(up)] 'idlwave-shell-up-or-history)
+ (define-key map [(down)] 'idlwave-shell-down-or-history)
+ (define-key idlwave-shell-mode-map
+ (if (featurep 'xemacs) [(shift button3)] [(shift mouse-3)])
+ 'idlwave-mouse-context-help)
+ map)
"Keymap for `idlwave-mode'.")
-(defvar idlwave-shell-electric-debug-mode-map (make-sparse-keymap))
+
+(defvar idlwave-shell-electric-debug-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; A few extras in the electric debug map
+ (define-key map " " 'idlwave-shell-step)
+ (define-key map "+" 'idlwave-shell-stack-up)
+ (define-key map "=" 'idlwave-shell-stack-up)
+ (define-key map "-" 'idlwave-shell-stack-down)
+ (define-key map "_" 'idlwave-shell-stack-down)
+ (define-key map "e" (lambda () (interactive) (idlwave-shell-print '(16))))
+ (define-key map "q" 'idlwave-shell-retall)
+ (define-key map "t"
+ (lambda () (interactive) (idlwave-shell-send-command "help,/TRACE")))
+ (define-key map [(control ??)] 'idlwave-shell-electric-debug-help)
+ (define-key map "x"
+ (lambda (arg) (interactive "P")
+ (idlwave-shell-print arg nil nil t)))
+ map))
+
(defvar idlwave-shell-mode-prefix-map (make-sparse-keymap))
(fset 'idlwave-shell-mode-prefix-map idlwave-shell-mode-prefix-map)
(defvar idlwave-mode-prefix-map (make-sparse-keymap))
@@ -4069,29 +4114,6 @@ Otherwise, just expand the file name."
"Define a key in both the shell and buffer mode maps."
(define-key idlwave-mode-map key hook)
(define-key idlwave-shell-mode-map key hook))
-
-;(define-key idlwave-shell-mode-map "\M-?" 'comint-dynamic-list-completions)
-;(define-key idlwave-shell-mode-map "\t" 'comint-dynamic-complete)
-
-(define-key idlwave-shell-mode-map "\C-w" 'comint-kill-region)
-(define-key idlwave-shell-mode-map "\t" 'idlwave-shell-complete)
-(define-key idlwave-shell-mode-map "\M-\t" 'idlwave-shell-complete)
-(define-key idlwave-shell-mode-map "\C-c\C-s" 'idlwave-shell)
-(define-key idlwave-shell-mode-map "\C-c?" 'idlwave-routine-info)
-(define-key idlwave-shell-mode-map "\C-g" 'idlwave-keyboard-quit)
-(define-key idlwave-shell-mode-map "\M-?" 'idlwave-context-help)
-(define-key idlwave-shell-mode-map [(control meta ?\?)]
- 'idlwave-help-assistant-help-with-topic)
-(define-key idlwave-shell-mode-map "\C-c\C-i" 'idlwave-update-routine-info)
-(define-key idlwave-shell-mode-map "\C-c\C-y" 'idlwave-shell-char-mode-loop)
-(define-key idlwave-shell-mode-map "\C-c\C-x" 'idlwave-shell-send-char)
-(define-key idlwave-shell-mode-map "\C-c=" 'idlwave-resolve)
-(define-key idlwave-shell-mode-map "\C-c\C-v" 'idlwave-find-module)
-(define-key idlwave-shell-mode-map "\C-c\C-k" 'idlwave-kill-autoloaded-buffers)
-(define-key idlwave-shell-mode-map idlwave-shell-prefix-key
- 'idlwave-shell-debug-map)
-(define-key idlwave-shell-mode-map [(up)] 'idlwave-shell-up-or-history)
-(define-key idlwave-shell-mode-map [(down)] 'idlwave-shell-down-or-history)
(define-key idlwave-mode-map "\C-c\C-y" 'idlwave-shell-char-mode-loop)
(define-key idlwave-mode-map "\C-c\C-x" 'idlwave-shell-send-char)
@@ -4112,22 +4134,12 @@ Otherwise, just expand the file name."
[(control shift down-mouse-2)])
'idlwave-shell-examine-select)
;; Add this one from the idlwave-mode-map
-(define-key idlwave-shell-mode-map
- (if (featurep 'xemacs)
- [(shift button3)]
- [(shift mouse-3)])
- 'idlwave-mouse-context-help)
-
;; For Emacs, we need to turn off the button release events.
-(defun idlwave-shell-mouse-nop (event)
- (interactive "e"))
+
(unless (featurep 'xemacs)
- (idlwave-shell-define-key-both
- [(shift mouse-2)] 'idlwave-shell-mouse-nop)
- (idlwave-shell-define-key-both
- [(shift control mouse-2)] 'idlwave-shell-mouse-nop)
- (idlwave-shell-define-key-both
- [(control meta mouse-2)] 'idlwave-shell-mouse-nop))
+ (idlwave-shell-define-key-both [(shift mouse-2)] 'ignore)
+ (idlwave-shell-define-key-both [(shift control mouse-2)] 'ignore)
+ (idlwave-shell-define-key-both [(control meta mouse-2)] 'ignore))
;; The following set of bindings is used to bind the debugging keys.
@@ -4207,26 +4219,6 @@ Otherwise, just expand the file name."
(define-key idlwave-shell-electric-debug-mode-map (char-to-string c2)
cmd))))
-;; A few extras in the electric debug map
-(define-key idlwave-shell-electric-debug-mode-map " " 'idlwave-shell-step)
-(define-key idlwave-shell-electric-debug-mode-map "+" 'idlwave-shell-stack-up)
-(define-key idlwave-shell-electric-debug-mode-map "=" 'idlwave-shell-stack-up)
-(define-key idlwave-shell-electric-debug-mode-map "-"
- 'idlwave-shell-stack-down)
-(define-key idlwave-shell-electric-debug-mode-map "_"
- 'idlwave-shell-stack-down)
-(define-key idlwave-shell-electric-debug-mode-map "e"
- (lambda () (interactive) (idlwave-shell-print '(16))))
-(define-key idlwave-shell-electric-debug-mode-map "q" 'idlwave-shell-retall)
-(define-key idlwave-shell-electric-debug-mode-map "t"
- (lambda () (interactive) (idlwave-shell-send-command "help,/TRACE")))
-(define-key idlwave-shell-electric-debug-mode-map [(control ??)]
- 'idlwave-shell-electric-debug-help)
-(define-key idlwave-shell-electric-debug-mode-map "x"
- (lambda (arg) (interactive "P")
- (idlwave-shell-print arg nil nil t)))
-
-
; Enter the prefix map in two places.
(fset 'idlwave-debug-map idlwave-mode-prefix-map)
(fset 'idlwave-shell-debug-map idlwave-shell-mode-prefix-map)
@@ -4251,49 +4243,35 @@ Otherwise, just expand the file name."
(define-minor-mode idlwave-shell-electric-debug-mode
"Toggle Idlwave Shell Electric Debug mode.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
When Idlwave Shell Electric Debug mode is enabled, the Idlwave
Shell debugging commands are available as single key sequences."
- nil " *Debugging*" idlwave-shell-electric-debug-mode-map)
-
-(add-hook
- 'idlwave-shell-electric-debug-mode-on-hook
- (lambda ()
- (set (make-local-variable 'idlwave-shell-electric-debug-read-only)
- buffer-read-only)
- (setq buffer-read-only t)
- (add-to-list 'idlwave-shell-electric-debug-buffers (current-buffer))
- (if idlwave-shell-stop-line-overlay
- (overlay-put idlwave-shell-stop-line-overlay 'face
- idlwave-shell-electric-stop-line-face))
- (if (facep 'fringe)
- (set-face-foreground 'fringe idlwave-shell-electric-stop-color
- (selected-frame)))))
-
-(add-hook
- 'idlwave-shell-electric-debug-mode-off-hook
- (lambda ()
- ;; Return to previous read-only state
- (setq buffer-read-only (if (boundp 'idlwave-shell-electric-debug-read-only)
- idlwave-shell-electric-debug-read-only))
- (setq idlwave-shell-electric-debug-buffers
- (delq (current-buffer) idlwave-shell-electric-debug-buffers))
- (if idlwave-shell-stop-line-overlay
- (overlay-put idlwave-shell-stop-line-overlay 'face
- idlwave-shell-stop-line-face)
- (if (facep 'fringe)
- (set-face-foreground 'fringe (face-foreground 'default))))))
-
-;; easy-mmode defines electric-debug-mode for us, so we need to advise it.
-(defadvice idlwave-shell-electric-debug-mode (after print-enter activate)
- "Print out an entrance message."
- (when idlwave-shell-electric-debug-mode
+ :lighter " *Debugging*"
+ (cond
+ (idlwave-shell-electric-debug-mode
+ (set (make-local-variable 'idlwave-shell-electric-debug-read-only)
+ buffer-read-only)
+ (setq buffer-read-only t)
+ (add-to-list 'idlwave-shell-electric-debug-buffers (current-buffer))
+ (if idlwave-shell-stop-line-overlay
+ (overlay-put idlwave-shell-stop-line-overlay 'face
+ idlwave-shell-electric-stop-line-face))
+ (if (facep 'fringe)
+ (set-face-foreground 'fringe idlwave-shell-electric-stop-color
+ (selected-frame)))
(message
"Electric Debugging mode entered. Press [C-?] for help, [q] to quit"))
- (force-mode-line-update))
+ (t
+ ;; Return to previous read-only state
+ (setq buffer-read-only (if (boundp 'idlwave-shell-electric-debug-read-only)
+ idlwave-shell-electric-debug-read-only))
+ (setq idlwave-shell-electric-debug-buffers
+ (delq (current-buffer) idlwave-shell-electric-debug-buffers))
+ (if idlwave-shell-stop-line-overlay
+ (overlay-put idlwave-shell-stop-line-overlay 'face
+ idlwave-shell-stop-line-face)
+ (if (facep 'fringe)
+ (set-face-foreground 'fringe (face-foreground 'default)))))))
;; Turn it off in all relevant buffers
(defvar idlwave-shell-electric-debug-buffers nil)
diff --git a/lisp/progmodes/idlw-toolbar.el b/lisp/progmodes/idlw-toolbar.el
index b398ffc210a..d3b442c0567 100644
--- a/lisp/progmodes/idlw-toolbar.el
+++ b/lisp/progmodes/idlw-toolbar.el
@@ -34,8 +34,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
-
(defun idlwave-toolbar-make-button (image)
(if (featurep 'xemacs)
(toolbar-make-button-list image)
diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el
index 6dbc667c674..bded09d5038 100644
--- a/lisp/progmodes/idlwave.el
+++ b/lisp/progmodes/idlwave.el
@@ -151,7 +151,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'idlw-help)
;; For XEmacs
@@ -3690,7 +3690,7 @@ constants - a double quote followed by an octal digit."
(save-excursion
(forward-char)
(re-search-backward (concat "\\(" idlwave-idl-keywords
- "\\|[[(*+-/=,^><]\\)\\s-*\\*") limit t))))
+ "\\|[-[(*+/=,^><]\\)\\s-*\\*") limit t))))
;; Statement templates
@@ -3898,7 +3898,7 @@ Buffers containing unsaved changes require confirmation before they are killed."
(and (or (memq t reasons)
(memq (cdr entry) reasons))
(kill-buffer (car entry))
- (incf cnt)
+ (cl-incf cnt)
(setq idlwave-outlawed-buffers
(delq entry idlwave-outlawed-buffers)))
(setq idlwave-outlawed-buffers
@@ -4104,14 +4104,14 @@ blank lines."
(idlwave-sint-classes 10 10))))
;; Make sure these are lists
- (loop for entry in entries
+ (cl-loop for entry in entries
for var = (car entry)
do (if (not (consp (symbol-value var))) (set var (list nil))))
;; Reset the system & library hash
(when (or (eq what t) (eq what 'syslib)
(null (cdr idlwave-sint-routines)))
- (loop for entry in entries
+ (cl-loop for entry in entries
for var = (car entry) for size = (nth 1 entry)
do (setcdr (symbol-value var)
(make-hash-table ':size size ':test 'equal)))
@@ -4121,7 +4121,7 @@ blank lines."
;; Reset the buffer & shell hash
(when (or (eq what t) (eq what 'bufsh)
(null (car idlwave-sint-routines)))
- (loop for entry in entries
+ (cl-loop for entry in entries
for var = (car entry) for size = (nth 1 entry)
do (setcar (symbol-value var)
(make-hash-table ':size size ':test 'equal))))))
@@ -4680,7 +4680,7 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
(setq pref-list
(if (match-string 1 kwd) '("X" "Y" "Z") '("X" "Y"))
kwd (substring kwd (match-end 0)))
- (loop for x in pref-list do
+ (cl-loop for x in pref-list do
(push (list (concat x kwd) klink) kwds)))
(push (list kwd klink) kwds)))
@@ -4701,7 +4701,7 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
(cons (substring name 1) link)
(if extra-kws (setq kwds (nconc kwds extra-kws)))
(setq kwds (idlwave-rinfo-group-keywords kwds link))
- (loop for idx from 0 to 1 do
+ (cl-loop for idx from 0 to 1 do
(if (aref syntax-vec idx)
(push (append (list name (if (eq idx 0) 'pro 'fun)
class '(system)
@@ -4736,7 +4736,7 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
;; Clean up the syntax of routines which are actually aliases by
;; removing the "OR" from the statements
(let (syntax entry)
- (loop for x in aliases do
+ (cl-loop for x in aliases do
(setq entry (assoc x idlwave-system-routines))
(when entry
(while (string-match " +or +" (setq syntax (nth 4 entry)))
@@ -4746,7 +4746,7 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
;; Duplicate and trim original routine aliases from rinfo list
;; This if for, e.g. OPENR/OPENW/OPENU
(let (alias remove-list new parts all-parts)
- (loop for x in aliases do
+ (cl-loop for x in aliases do
(when (setq parts (split-string (cdr x) "/"))
(setq new (assoc (cdr x) all-parts))
(unless new
@@ -4755,30 +4755,30 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
(setcdr new (delete (car x) (cdr new)))))
;; Add any missing aliases (separate by slashes)
- (loop for x in all-parts do
+ (cl-loop for x in all-parts do
(if (cdr x)
(push (cons (nth 1 x) (car x)) aliases)))
- (loop for x in aliases do
+ (cl-loop for x in aliases do
(when (setq alias (assoc (cdr x) idlwave-system-routines))
(unless (memq alias remove-list) (push alias remove-list))
(setq alias (copy-sequence alias))
(setcar alias (car x))
(push alias idlwave-system-routines)))
- (loop for x in remove-list do
+ (cl-loop for x in remove-list do
(delq x idlwave-system-routines))))
(defun idlwave-convert-xml-clean-sysvar-aliases (aliases)
;; Duplicate and trim original routine aliases from rinfo list
;; This if for, e.g. !X, !Y, !Z.
(let (alias remove-list)
- (loop for x in aliases do
+ (cl-loop for x in aliases do
(when (setq alias (assoc (cdr x) idlwave-system-variables-alist))
(unless (memq alias remove-list) (push alias remove-list))
(setq alias (copy-sequence alias))
(setcar alias (car x))
(push alias idlwave-system-variables-alist)))
- (loop for x in remove-list do
+ (cl-loop for x in remove-list do
(delq x idlwave-system-variables-alist))))
@@ -4875,7 +4875,7 @@ Cache to disk for quick recovery."
(while rinfo
(setq elem (car rinfo)
rinfo (cdr rinfo))
- (incf elem-cnt)
+ (cl-incf elem-cnt)
(when (listp elem)
(setq type (car elem)
props (car (cdr elem)))
@@ -5106,7 +5106,7 @@ Cache to disk for quick recovery."
"Return the class alist - make it if necessary."
(or idlwave-class-alist
(let (class)
- (loop for x in idlwave-routines do
+ (cl-loop for x in idlwave-routines do
(when (and (setq class (nth 2 x))
(not (assq class idlwave-class-alist)))
(push (list class) idlwave-class-alist)))
@@ -5240,7 +5240,7 @@ Can run from `after-save-hook'."
class
(cond ((not (boundp 'idlwave-scanning-lib))
(list 'buffer (buffer-file-name)))
-; ((string= (downcase (file-name-base))
+; ((string= (downcase (file-name-base (buffer-file-name))
; (downcase name))
; (list 'lib))
; (t (cons 'lib (file-name-nondirectory (buffer-file-name))))
@@ -5588,7 +5588,7 @@ be set to nil to disable library catalog scanning."
(mapcar 'car idlwave-path-alist)))
(old-libname "")
dir-entry dir catalog all-routines)
- (if message-base (message message-base))
+ (if message-base (message "%s" message-base))
(while (setq dir (pop dirs))
(catch 'continue
(when (file-readable-p
@@ -5603,8 +5603,7 @@ be set to nil to disable library catalog scanning."
message-base
(not (string= idlwave-library-catalog-libname
old-libname)))
- (message "%s" (concat message-base
- idlwave-library-catalog-libname))
+ (message "%s%s" message-base idlwave-library-catalog-libname)
(setq old-libname idlwave-library-catalog-libname))
(when idlwave-library-catalog-routines
(setq all-routines
@@ -5618,7 +5617,7 @@ be set to nil to disable library catalog scanning."
(setq dir-entry (assoc dir idlwave-path-alist)))
(idlwave-path-alist-add-flag dir-entry 'lib)))))
(unless no-load (setq idlwave-library-catalog-routines all-routines))
- (if message-base (message (concat message-base "done"))))))
+ (if message-base (message "%sdone" message-base)))))
;;----- Communicating with the Shell -------------------
@@ -6223,7 +6222,7 @@ If yes, return the index (>=1)."
(let (file (cnt 0))
(catch 'exit
(while entries
- (incf cnt)
+ (cl-incf cnt)
(setq file (idlwave-routine-source-file (nth 3 (car entries))))
(if (and file (idlwave-syslib-p file))
(throw 'exit cnt)
@@ -6520,7 +6519,7 @@ ARROW: Location of the arrow"
(progn (up-list -1) t)
(error nil))
(setq pos (point))
- (incf cnt)
+ (cl-incf cnt)
(when (and (= (following-char) ?\()
(re-search-backward
"\\(::\\|\\<\\)\\([a-zA-Z][a-zA-Z0-9$_]*\\)[ \t]*\\="
@@ -7591,7 +7590,7 @@ property indicating the link is added."
(case-fold-search t))
(cond ((save-excursion
;; Check if the context is right for system variable
- (skip-chars-backward "[a-zA-Z0-9_$]")
+ (skip-chars-backward "a-zA-Z0-9_$")
(equal (char-before) ?!))
(setq idlwave-completion-help-info '(idlwave-complete-sysvar-help))
(idlwave-complete-in-buffer 'sysvar 'sysvar
@@ -8190,7 +8189,7 @@ demand _EXTRA in the keyword list."
(while (setq re (pop regexps))
(if (string-match re name) (throw 'exit t))))))
- (loop for entry in (idlwave-routines) do
+ (cl-loop for entry in (idlwave-routines) do
(and (nth 2 entry) ; non-nil class
(memq (nth 2 entry) super-classes) ; an inherited class
(eq (nth 1 entry) type) ; correct type
@@ -8399,7 +8398,7 @@ If we do not know about MODULE, just return KEYWORD literally."
"")
(if (> total 1) "- " ""))
entry props)
- (incf cnt)
+ (cl-incf cnt)
(when (and all (> cnt idlwave-rinfo-max-source-lines))
;; No more source lines, please
(insert (format
@@ -8707,7 +8706,7 @@ can be used to detect possible name clashes during this process."
(> (idlwave-count-memq 'lib (nth 2 (car dtwins))) 1)
(> (idlwave-count-memq 'user (nth 2 (car dtwins))) 1)
(> (idlwave-count-memq 'buffer (nth 2 (car dtwins))) 1))
- (incf cnt)
+ (cl-incf cnt)
(insert (format "\n%s%s"
(idlwave-make-full-name (nth 2 routine)
(car routine))
@@ -8776,7 +8775,7 @@ routines, and may have been scanned."
(cnt 0)
source type type-cons file alist syslibp key)
(while (setq entry (pop entries))
- (incf cnt)
+ (cl-incf cnt)
(setq source (nth 3 entry)
type (car source)
type-cons (cons type (nth 3 source))
@@ -9074,7 +9073,7 @@ Assumes that point is at the beginning of the unit as found by
;; Menus - using easymenu.el
(defvar idlwave-mode-menu-def
- `("IDLWAVE"
+ '("IDLWAVE"
["PRO/FUNC menu" idlwave-function-menu t]
("Motion"
["Subprogram Start" idlwave-beginning-of-subprogram t]
@@ -9151,7 +9150,7 @@ Assumes that point is at the beginning of the unit as found by
["Kill auto-created buffers" idlwave-kill-autoloaded-buffers t]
"--"
["Insert TAB character" idlwave-hard-tab t])
- "--"
+ "--"
("External"
["Start IDL shell" idlwave-shell t]
["Edit file in IDLDE" idlwave-edit-in-idlde t]
diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el
index 9c3f3b3e4f4..a0adaa84eeb 100644
--- a/lisp/progmodes/js.el
+++ b/lisp/progmodes/js.el
@@ -45,14 +45,11 @@
;;; Code:
-
(require 'cc-mode)
(require 'newcomment)
-(require 'thingatpt) ; forward-symbol etc
(require 'imenu)
(require 'moz nil t)
-(require 'json nil t)
-(require 'sgml-mode)
+(require 'json)
(require 'prog-mode)
(eval-when-compile
@@ -68,7 +65,7 @@
;;; Constants
-(defconst js--name-start-re "[a-zA-Z_$]"
+(defconst js--name-start-re (concat "[[:alpha:]_$]")
"Regexp matching the start of a JavaScript identifier, without grouping.")
(defconst js--stmt-delim-chars "^;{}?:")
@@ -574,6 +571,119 @@ then the \".\"s will be lined up:
:safe 'booleanp
:group 'js)
+(defcustom js-jsx-detect-syntax t
+ "When non-nil, automatically detect whether JavaScript uses JSX.
+`js-jsx-syntax' (which see) may be made buffer-local and set to
+t. The detection strategy can be customized by adding elements
+to `js-jsx-regexps', which see."
+ :version "27.1"
+ :type 'boolean
+ :safe 'booleanp
+ :group 'js)
+
+(defcustom js-jsx-syntax nil
+ "When non-nil, parse JavaScript with consideration for JSX syntax.
+
+This enables proper font-locking and indentation of code using
+Facebook’s “JSX” syntax extension for JavaScript, for use with
+Facebook’s “React” library. Font-locking is like sgml-mode.
+Indentation is also like sgml-mode, although some indentation
+behavior may differ slightly to align more closely with the
+conventions of the React developer community.
+
+When `js-mode' is already enabled, you should call
+`js-jsx-enable' to set this variable.
+
+It is set to be buffer-local (and t) when in `js-jsx-mode'."
+ :version "27.1"
+ :type 'boolean
+ :safe 'booleanp
+ :group 'js)
+
+(defcustom js-jsx-align->-with-< t
+ "When non-nil, “>” will be indented to the opening “<” in JSX.
+
+When this is enabled, JSX indentation looks like this:
+
+ <element
+ attr=\"\"
+ >
+ </element>
+ <input
+ />
+
+When this is disabled, JSX indentation looks like this:
+
+ <element
+ attr=\"\"
+ >
+ </element>
+ <input
+ />"
+ :version "27.1"
+ :type 'boolean
+ :safe 'booleanp
+ :group 'js)
+
+(defcustom js-jsx-indent-level nil
+ "When non-nil, indent JSX by this value, instead of like JS.
+
+Let `js-indent-level' be 4. When this variable is also set to
+nil, JSX indentation looks like this (consistent):
+
+ return (
+ <element>
+ <element>
+ Hello World!
+ </element>
+ </element>
+ )
+
+Alternatively, when this variable is also set to 2, JSX
+indentation looks like this (different):
+
+ return (
+ <element>
+ <element>
+ Hello World!
+ </element>
+ </element>
+ )"
+ :version "27.1"
+ :type 'integer
+ :safe (lambda (x) (or (null x) (integerp x)))
+ :group 'js)
+;; This is how indentation behaved out-of-the-box until Emacs 27. JSX
+;; indentation was controlled with `sgml-basic-offset', which defaults
+;; to 2, whereas `js-indent-level' defaults to 4. Users who had the
+;; same values configured for both their HTML and JS indentation would
+;; luckily get consistent JSX indentation; most others were probably
+;; unhappy. I’d be surprised if anyone actually wants different
+;; indentation levels, but just in case, here’s a way back to that.
+
+(defcustom js-jsx-attribute-offset 0
+ "Specifies a delta for JSXAttribute indentation.
+
+Let `js-indent-level' be 2. When this variable is also set to 0,
+JSXAttribute indentation looks like this:
+
+ <element
+ attribute=\"value\">
+ </element>
+
+Alternatively, when this variable is also set to 2, JSXAttribute
+indentation looks like this:
+
+ <element
+ attribute=\"value\">
+ </element>
+
+This variable is like `sgml-attribute-offset'."
+ :version "27.1"
+ :type 'integer
+ :safe 'integerp
+ :group 'js)
+
;;; KeyMap
(defvar js-mode-map
@@ -624,12 +734,6 @@ then the \".\"s will be lined up:
"Parse state at `js--last-parse-pos'.")
(make-variable-buffer-local 'js--state-at-last-parse-pos)
-(defun js--flatten-list (list)
- (cl-loop for item in list
- nconc (cond ((consp item)
- (js--flatten-list item))
- (item (list item)))))
-
(defun js--maybe-join (prefix separator suffix &rest list)
"Helper function for `js--update-quick-match-re'.
If LIST contains any element that is not nil, return its non-nil
@@ -637,7 +741,7 @@ elements, separated by SEPARATOR, prefixed by PREFIX, and ended
with SUFFIX as with `concat'. Otherwise, if LIST is empty, return
nil. If any element in LIST is itself a list, flatten that
element."
- (setq list (js--flatten-list list))
+ (setq list (flatten-tree list))
(when list
(concat prefix (mapconcat #'identity list separator) suffix)))
@@ -1007,7 +1111,7 @@ BEG defaults to `point-min', meaning to flush the entire cache."
Update parsing information up to point, referring to parse,
prev-parse-point, goal-point, and open-items bound lexically in
the body of `js--ensure-cache'."
- `(progn
+ '(progn
(setq goal-point (point))
(goto-char prev-parse-point)
(while (progn
@@ -1017,7 +1121,7 @@ the body of `js--ensure-cache'."
;; the given depth -- i.e., make sure we're deeper than the target
;; depth.
(cl-assert (> (nth 0 parse)
- (js--pitem-paren-depth (car open-items))))
+ (js--pitem-paren-depth (car open-items))))
(setq parse (parse-partial-sexp
prev-parse-point goal-point
(js--pitem-paren-depth (car open-items))
@@ -1493,6 +1597,102 @@ point of view of font-lock. It applies highlighting directly with
;; Matcher always "fails"
nil)
+;; It wouldn’t be sufficient to font-lock JSX with mere regexps, since
+;; a JSXElement may be nested inside a JS expression within the
+;; boundaries of a parent JSXOpeningElement, and such a hierarchy
+;; ought to be fontified like JSX, JS, and JSX respectively:
+;;
+;; <div attr={void(<div></div>) && void(0)}></div>
+;;
+;; <div attr={ ← JSX
+;; void( ← JS
+;; <div></div> ← JSX
+;; ) && void(0) ← JS
+;; }></div> ← JSX
+;;
+;; `js-syntax-propertize' unambiguously identifies JSX syntax,
+;; including when it’s nested.
+;;
+;; Using a matcher function for each relevant part, retrieve match
+;; data recorded as syntax properties for fontification.
+
+(defconst js-jsx--font-lock-keywords
+ `((js-jsx--match-tag-name 0 font-lock-function-name-face t)
+ (js-jsx--match-attribute-name 0 font-lock-variable-name-face t)
+ (js-jsx--match-text 0 'default t) ; “Undo” keyword fontification.
+ (js-jsx--match-tag-beg)
+ (js-jsx--match-tag-end)
+ (js-jsx--match-expr))
+ "JSX font lock faces and multiline text properties.")
+
+(defun js-jsx--match-tag-name (limit)
+ "Match JSXBoundaryElement names, until LIMIT."
+ (when js-jsx-syntax
+ (let ((pos (next-single-char-property-change (point) 'js-jsx-tag-name nil limit))
+ value)
+ (when (and pos (> pos (point)))
+ (goto-char pos)
+ (or (and (setq value (get-text-property pos 'js-jsx-tag-name))
+ (progn (set-match-data value) t))
+ (js-jsx--match-tag-name limit))))))
+
+(defun js-jsx--match-attribute-name (limit)
+ "Match JSXAttribute names, until LIMIT."
+ (when js-jsx-syntax
+ (let ((pos (next-single-char-property-change (point) 'js-jsx-attribute-name nil limit))
+ value)
+ (when (and pos (> pos (point)))
+ (goto-char pos)
+ (or (and (setq value (get-text-property pos 'js-jsx-attribute-name))
+ (progn (set-match-data value) t))
+ (js-jsx--match-attribute-name limit))))))
+
+(defun js-jsx--match-text (limit)
+ "Match JSXText, until LIMIT."
+ (when js-jsx-syntax
+ (let ((pos (next-single-char-property-change (point) 'js-jsx-text nil limit))
+ value)
+ (when (and pos (> pos (point)))
+ (goto-char pos)
+ (or (and (setq value (get-text-property pos 'js-jsx-text))
+ (progn (set-match-data value)
+ (put-text-property (car value) (cadr value) 'font-lock-multiline t)
+ t))
+ (js-jsx--match-text limit))))))
+
+(defun js-jsx--match-tag-beg (limit)
+ "Match JSXBoundaryElements from start, until LIMIT."
+ (when js-jsx-syntax
+ (let ((pos (next-single-char-property-change (point) 'js-jsx-tag-beg nil limit))
+ value)
+ (when (and pos (> pos (point)))
+ (goto-char pos)
+ (or (and (setq value (get-text-property pos 'js-jsx-tag-beg))
+ (progn (put-text-property pos (cdr value) 'font-lock-multiline t) t))
+ (js-jsx--match-tag-beg limit))))))
+
+(defun js-jsx--match-tag-end (limit)
+ "Match JSXBoundaryElements from end, until LIMIT."
+ (when js-jsx-syntax
+ (let ((pos (next-single-char-property-change (point) 'js-jsx-tag-end nil limit))
+ value)
+ (when (and pos (> pos (point)))
+ (goto-char pos)
+ (or (and (setq value (get-text-property pos 'js-jsx-tag-end))
+ (progn (put-text-property value pos 'font-lock-multiline t) t))
+ (js-jsx--match-tag-end limit))))))
+
+(defun js-jsx--match-expr (limit)
+ "Match JSXExpressionContainers, until LIMIT."
+ (when js-jsx-syntax
+ (let ((pos (next-single-char-property-change (point) 'js-jsx-expr nil limit))
+ value)
+ (when (and pos (> pos (point)))
+ (goto-char pos)
+ (or (and (setq value (get-text-property pos 'js-jsx-expr))
+ (progn (put-text-property pos value 'font-lock-multiline t) t))
+ (js-jsx--match-expr limit))))))
+
(defconst js--font-lock-keywords-3
`(
;; This goes before keywords-2 so it gets used preferentially
@@ -1604,7 +1804,10 @@ point of view of font-lock. It applies highlighting directly with
(forward-symbol -1)
(end-of-line))
'(end-of-line)
- '(0 font-lock-variable-name-face))))
+ '(0 font-lock-variable-name-face)))
+
+ ;; jsx (when enabled)
+ ,@js-jsx--font-lock-keywords)
"Level three font lock for `js-mode'.")
(defun js--inside-pitem-p (pitem)
@@ -1730,9 +1933,414 @@ This performs fontification according to `js--class-styles'."
'syntax-table (string-to-syntax "\"/"))
(goto-char end)))))
+(defconst js--unary-keyword-re
+ (js--regexp-opt-symbol '("await" "delete" "typeof" "void" "yield"))
+ "Regexp matching unary operator keywords.")
+
+(defun js--unary-keyword-p (string)
+ "Check if STRING is a unary operator keyword in JavaScript."
+ (string-match-p js--unary-keyword-re string))
+
+;; Adding `syntax-multiline' text properties to JSX isn’t sufficient
+;; to identify multiline JSX when first typing it. For instance, if
+;; the user is typing a JSXOpeningElement for the first time…
+;;
+;; <div
+;; ^ (point)
+;;
+;; …and the user inserts a line break after the tag name (before the
+;; JSXOpeningElement starting on that line has been unambiguously
+;; identified as such), then the `syntax-propertize' region won’t be
+;; extended backwards to the start of the JSXOpeningElement:
+;;
+;; <div ← This line wasn’t JSX when last edited.
+;; attr=""> ← Despite completing the JSX, the next
+;; ^ `syntax-propertize' region wouldn’t magically
+;; extend back a few lines.
+;;
+;; Therefore, to try and recover from this scenario, parse backward
+;; from “>” to try and find the start of JSXBoundaryElements, and
+;; extend the `syntax-propertize' region there.
+
+(defun js--syntax-propertize-extend-region (start end)
+ "Extend the START-END region for propertization, if necessary.
+For use by `syntax-propertize-extend-region-functions'."
+ (if js-jsx-syntax (js-jsx--syntax-propertize-extend-region start end)))
+
+(defun js-jsx--syntax-propertize-extend-region (start end)
+ "Extend the START-END region for propertization, if necessary.
+If any “>” in the region appears to be the end of a tag starting
+before the start of the region, extend region backwards to the
+start of that tag so parsing may proceed from that point.
+For use by `syntax-propertize-extend-region-functions'."
+ (let (new-start
+ forward-sexp-function ; Use the Lisp version.
+ parse-sexp-lookup-properties) ; Fix backward-sexp error here.
+ (catch 'stop
+ (goto-char start)
+ (while (re-search-forward ">" end t)
+ (catch 'continue
+ ;; Check if this is really a right shift bitwise operator
+ ;; (“>>” or “>>>”).
+ (unless (or (eq (char-before (1- (point))) ?>)
+ (eq (char-after) ?>))
+ (save-excursion
+ (backward-char)
+ (while (progn (if (= (point) (point-min)) (throw 'continue nil))
+ (/= (char-before) ?<))
+ (skip-chars-backward " \t\n")
+ (if (= (point) (point-min)) (throw 'continue nil))
+ (cond
+ ((memq (char-before) '(?\" ?\' ?\` ?\}))
+ (condition-case nil
+ (backward-sexp)
+ (scan-error (throw 'continue nil))))
+ ((memq (char-before) '(?\/ ?\=)) (backward-char))
+ ((looking-back js--dotted-name-re (line-beginning-position) t)
+ (goto-char (match-beginning 0)))
+ (t (throw 'continue nil))))
+ (when (< (point) start)
+ (setq new-start (1- (point)))
+ (throw 'stop nil)))))))
+ (if new-start (cons new-start end))))
+
+;; When applying syntax properties, since `js-syntax-propertize' uses
+;; `syntax-propertize-rules' to parse JSXBoundaryElements iteratively
+;; and statelessly, whenever we exit such an element, we need to
+;; determine the JSX depth. If >0, then we know we to apply syntax
+;; properties to JSXText up until the next JSXBoundaryElement occurs.
+;; But if the JSX depth is 0, then—importantly—we know to NOT parse
+;; the following code as JSXText, rather propertize it as regular JS
+;; as long as warranted.
+;;
+;; Also, when indenting code, we need to know if the code we’re trying
+;; to indent is on the 2nd or later line of multiline JSX, in which
+;; case the code is indented according to XML-like JSX conventions.
+;;
+;; For the aforementioned reasons, we find ourselves needing to
+;; determine whether point is enclosed in JSX or not; and, if so,
+;; where the JSX is. The following functions provide that knowledge.
+
+(defconst js-jsx--tag-start-re
+ (concat "\\(" js--dotted-name-re "\\)\\(?:"
+ ;; Whitespace is only necessary if an attribute implies JSX.
+ "\\(?:\\s-\\|\n\\)*[{/>]"
+ "\\|"
+ "\\(?:\\s-\\|\n\\)+" js--name-start-re
+ "\\)")
+ "Regexp unambiguously matching a JSXOpeningElement.")
+
+(defun js-jsx--matched-tag-type ()
+ "Determine if the last “<” was a JSXBoundaryElement and its type.
+Return `close' for a JSXClosingElement/JSXClosingFragment match,
+return `self-closing' for some self-closing JSXOpeningElements,
+else return `other'."
+ (cond
+ ((= (char-after) ?/) (forward-char) 'close) ; JSXClosingElement/JSXClosingFragment
+ ((= (char-after) ?>) (forward-char) 'other) ; JSXOpeningFragment
+ ((and (looking-at js-jsx--tag-start-re) ; JSXOpeningElement
+ (not (js--unary-keyword-p (match-string 1))))
+ (goto-char (match-end 0))
+ (if (= (char-before) ?/) 'self-closing 'other))))
+
+(defconst js-jsx--self-closing-re "/\\s-*>"
+ "Regexp matching the end of a self-closing JSXOpeningElement.")
+
+(defun js-jsx--matching-close-tag-pos ()
+ "Return position of the closer of the opener before point.
+Assuming a JSXOpeningElement or a JSXOpeningFragment is
+immediately before point, find a matching JSXClosingElement or
+JSXClosingFragment, skipping over any nested JSXElements to find
+the match. Return nil if a match can’t be found."
+ (let ((tag-stack 1) tag-pos type last-pos pos)
+ (catch 'stop
+ (while (and (re-search-forward "<\\s-*" nil t) (not (eobp)))
+ (when (setq tag-pos (match-beginning 0)
+ type (js-jsx--matched-tag-type))
+ (when last-pos
+ (setq pos (point))
+ (goto-char last-pos)
+ (while (re-search-forward js-jsx--self-closing-re pos 'move)
+ (setq tag-stack (1- tag-stack))))
+ (if (eq type 'close)
+ (progn
+ (setq tag-stack (1- tag-stack))
+ (when (= tag-stack 0)
+ (throw 'stop tag-pos)))
+ ;; JSXOpeningElements that we know are self-closing aren’t
+ ;; added to the stack at all (because point is already
+ ;; past that syntax).
+ (unless (eq type 'self-closing)
+ (setq tag-stack (1+ tag-stack))))
+ (setq last-pos (point)))))))
+
+(defun js-jsx--enclosing-tag-pos ()
+ "Return beginning and end of a JSXElement about point.
+Look backward for a JSXElement that both starts before point and
+also ends at/after point. That may be either a self-closing
+JSXElement or a JSXOpeningElement/JSXClosingElement pair."
+ (let ((start (point)) tag-beg tag-beg-pos tag-end-pos close-tag-pos)
+ (while
+ (and
+ (setq tag-beg (js--backward-text-property 'js-jsx-tag-beg))
+ (progn
+ (setq tag-beg-pos (point)
+ tag-end-pos (cdr tag-beg))
+ (not
+ (or
+ (and (eq (car tag-beg) 'self-closing)
+ (< start tag-end-pos))
+ (and (eq (car tag-beg) 'open)
+ (or (< start tag-end-pos)
+ (progn
+ (unless
+ ;; Try to read a cached close position,
+ ;; but it might not be available yet.
+ (setq close-tag-pos
+ (get-text-property (point) 'js-jsx-close-tag-pos))
+ (save-excursion
+ (goto-char tag-end-pos)
+ (setq close-tag-pos (js-jsx--matching-close-tag-pos)))
+ (when close-tag-pos
+ ;; Cache the close position to make future
+ ;; searches faster.
+ (put-text-property
+ (point) (1+ (point))
+ 'js-jsx-close-tag-pos close-tag-pos)))
+ ;; The JSXOpeningElement may be unclosed, else
+ ;; the closure must occur at/after the start
+ ;; point (otherwise, a miscellaneous previous
+ ;; JSXOpeningElement has been found, so keep
+ ;; looking backwards for an enclosing one).
+ (or (not close-tag-pos) (<= start close-tag-pos)))))))))
+ ;; Don’t return the last tag pos, as it wasn’t enclosing.
+ (setq tag-beg nil close-tag-pos nil))
+ (and tag-beg (list tag-beg-pos tag-end-pos close-tag-pos))))
+
+(defun js-jsx--at-enclosing-tag-child-p ()
+ "Return t if point is at an enclosing tag’s child."
+ (let ((pos (save-excursion (js-jsx--enclosing-tag-pos))))
+ (and pos (>= (point) (nth 1 pos)))))
+
+;; We implement `syntax-propertize-function' logic fully parsing JSX
+;; in order to provide very accurate JSX indentation, even in the most
+;; complex cases (e.g. to indent JSX within a JS expression within a
+;; JSXAttribute…), as over the years users have requested this. Since
+;; we find so much information during this parse, we later use some of
+;; the useful bits for font-locking, too.
+;;
+;; Some extra effort is devoted to ensuring that no code which could
+;; possibly be valid JS is ever misinterpreted as partial JSX, since
+;; that would be regressive.
+;;
+;; We first parse trying to find the minimum number of components
+;; necessary to unambiguously identify a JSXBoundaryElement, even if
+;; it is a partial one. If a complete one is parsed, we move on to
+;; parse any JSXText. When that’s terminated, we unwind back to the
+;; `syntax-propertize-rules' loop so the next JSXBoundaryElement can
+;; be parsed, if any, be it an opening or closing one.
+
+(defun js-jsx--put-syntax-table (start end value)
+ "Set syntax-table text property from START to END as VALUE.
+Redundantly set the value to two properties, syntax-table and
+js-jsx-syntax-table. Derivative modes that remove syntax-table
+text properties may recover the value from the second property." ; i.e. js2-mode
+ (add-text-properties start end (list 'syntax-table value
+ 'js-jsx-syntax-table value)))
+
+(defun js-jsx--text-range (beg end)
+ "Identify JSXText within a “>/{/}/<” pair."
+ (when (> (- end beg) 0)
+ (save-excursion
+ (goto-char beg)
+ (while (and (skip-chars-forward " \t\n" end) (< (point) end))
+ ;; Comments and string quotes don’t serve their usual
+ ;; syntactic roles in JSXText; make them plain punctuation to
+ ;; negate those roles.
+ (when (or (= (char-after) ?/) ; comment
+ (= (syntax-class (syntax-after (point))) 7)) ; string quote
+ (js-jsx--put-syntax-table (point) (1+ (point)) '(1)))
+ (forward-char)))
+ ;; Mark JSXText so it can be font-locked as non-keywords.
+ (put-text-property beg (1+ beg) 'js-jsx-text (list beg end (current-buffer)))
+ ;; Ensure future propertization beginning from within the
+ ;; JSXText determines JSXText context from earlier lines.
+ (put-text-property beg end 'syntax-multiline t)))
+
+;; In order to respect the end boundary `syntax-propertize-function'
+;; sets, care is taken in the following functions to abort parsing
+;; whenever that boundary is reached.
+
+(defun js-jsx--syntax-propertize-tag-text (end)
+ "Determine if JSXText is before END and propertize it.
+Text within an open/close tag pair may be JSXText. Temporarily
+interrupt JSXText by JSXExpressionContainers, and terminate
+JSXText when another JSXBoundaryElement is encountered. Despite
+terminations, all JSXText will be identified once all the
+JSXBoundaryElements within an outermost JSXElement’s tree have
+been propertized."
+ (let ((text-beg (point))
+ forward-sexp-function) ; Use Lisp version.
+ (catch 'stop
+ (while (re-search-forward "[{<]" end t)
+ (js-jsx--text-range text-beg (1- (point)))
+ (cond
+ ((= (char-before) ?{)
+ (let (expr-beg expr-end)
+ (condition-case nil
+ (save-excursion
+ (backward-char)
+ (setq expr-beg (point))
+ (forward-sexp)
+ (setq expr-end (point)))
+ (scan-error nil))
+ ;; Recursively propertize the JSXExpressionContainer’s
+ ;; (possibly-incomplete) expression.
+ (js-syntax-propertize (1+ expr-beg) (if expr-end (min (1- expr-end) end) end))
+ ;; Ensure future propertization beginning from within the
+ ;; (possibly-incomplete) expression can determine JSXText
+ ;; context from earlier lines.
+ (put-text-property expr-beg (1+ expr-beg) 'js-jsx-expr (or expr-end end)) ; font-lock
+ (put-text-property expr-beg (if expr-end (min expr-end end) end) 'syntax-multiline t) ; syntax-propertize
+ ;; Exit the JSXExpressionContainer if that’s possible,
+ ;; else move to the end of the propertized area.
+ (goto-char (if expr-end (min expr-end end) end))))
+ ((= (char-before) ?<)
+ (backward-char) ; Ensure the next tag can be propertized.
+ (throw 'stop nil)))
+ (setq text-beg (point))))))
+
+(defconst js-jsx--attribute-name-re (concat js--name-start-re
+ "\\(?:\\s_\\|\\sw\\|-\\)*")
+ "Like `js--name-re', but matches “-” as well.")
+
+(defun js-jsx--syntax-propertize-tag (end)
+ "Determine if a JSXBoundaryElement is before END and propertize it.
+Disambiguate JSX from inequality operators and arrow functions by
+testing for syntax only valid as JSX."
+ (let ((tag-beg (1- (point))) tag-end (type 'open)
+ name-beg name-match-data expr-attribute-beg unambiguous
+ forward-sexp-function) ; Use Lisp version.
+ (catch 'stop
+ (while (and (< (point) end)
+ (progn (skip-chars-forward " \t\n" end)
+ (< (point) end)))
+ (cond
+ ((= (char-after) ?>)
+ ;; Make the closing “>” a close parenthesis.
+ (js-jsx--put-syntax-table (point) (1+ (point)) '(5))
+ (forward-char)
+ (setq unambiguous t)
+ (throw 'stop nil))
+ ;; Handle a JSXSpreadChild (“<Foo {...bar}”) or a
+ ;; JSXExpressionContainer as a JSXAttribute value
+ ;; (“<Foo bar={…}”). Check this early in case continuing a
+ ;; JSXAttribute parse.
+ ((or (and name-beg (= (char-after) ?{))
+ (setq expr-attribute-beg nil))
+ (setq unambiguous t) ; JSXExpressionContainer post tag name ⇒ JSX
+ (when expr-attribute-beg
+ ;; Remember that this JSXExpressionContainer is part of a
+ ;; JSXAttribute, as that can affect its expression’s
+ ;; indentation.
+ (put-text-property
+ (point) (1+ (point)) 'js-jsx-expr-attribute expr-attribute-beg)
+ (setq expr-attribute-beg nil))
+ (let (expr-end)
+ (condition-case nil
+ (save-excursion
+ (forward-sexp)
+ (setq expr-end (point)))
+ (scan-error nil))
+ (forward-char)
+ (if (>= (point) end) (throw 'stop nil))
+ (skip-chars-forward " \t\n" end)
+ (if (>= (point) end) (throw 'stop nil))
+ (if (= (char-after) ?}) (forward-char) ; Shortcut to bail.
+ ;; Recursively propertize the JSXExpressionContainer’s
+ ;; expression.
+ (js-syntax-propertize (point) (if expr-end (min (1- expr-end) end) end))
+ ;; Exit the JSXExpressionContainer if that’s possible,
+ ;; else move to the end of the propertized area.
+ (goto-char (if expr-end (min expr-end end) end)))))
+ ((= (char-after) ?/)
+ ;; Assume a tag is an open tag until a slash is found, then
+ ;; figure out what type it actually is.
+ (if (eq type 'open) (setq type (if name-beg 'self-closing 'close)))
+ (forward-char))
+ ((and (not name-beg) (looking-at js--dotted-name-re))
+ ;; Don’t match code like “if (i < await foo)”
+ (if (js--unary-keyword-p (match-string 0)) (throw 'stop nil))
+ ;; Save boundaries for later fontification after
+ ;; unambiguously determining the code is JSX.
+ (setq name-beg (match-beginning 0)
+ name-match-data (match-data))
+ (goto-char (match-end 0)))
+ ((and name-beg (looking-at js-jsx--attribute-name-re))
+ (setq unambiguous t) ; Non-unary name followed by 2nd name ⇒ JSX
+ ;; Save JSXAttribute’s name’s match data for font-locking later.
+ (put-text-property (match-beginning 0) (1+ (match-beginning 0))
+ 'js-jsx-attribute-name (match-data))
+ (goto-char (match-end 0))
+ (if (>= (point) end) (throw 'stop nil))
+ (skip-chars-forward " \t\n" end)
+ (if (>= (point) end) (throw 'stop nil))
+ ;; “=” is optional for null-valued JSXAttributes.
+ (when (= (char-after) ?=)
+ (forward-char)
+ (if (>= (point) end) (throw 'stop nil))
+ (skip-chars-forward " \t\n" end)
+ (if (>= (point) end) (throw 'stop nil))
+ ;; Skip over strings (if possible). Any
+ ;; JSXExpressionContainer here will be parsed in the
+ ;; next iteration of the loop.
+ (if (memq (char-after) '(?\" ?\' ?\`))
+ (progn
+ ;; Record the string’s position so derived modes
+ ;; applying syntactic fontification atypically
+ ;; (e.g. js2-mode) can recognize it as part of JSX.
+ (put-text-property (point) (1+ (point)) 'js-jsx-string t)
+ (condition-case nil
+ (forward-sexp)
+ (scan-error (throw 'stop nil))))
+ ;; Save JSXAttribute’s beginning in case we find a
+ ;; JSXExpressionContainer as the JSXAttribute’s value which
+ ;; we should associate with the JSXAttribute.
+ (setq expr-attribute-beg (match-beginning 0)))))
+ ;; There is nothing more to check; this either isn’t JSX, or
+ ;; the tag is incomplete.
+ (t (throw 'stop nil)))))
+ (when unambiguous
+ ;; Save JSXBoundaryElement’s name’s match data for font-locking.
+ (if name-beg (put-text-property name-beg (1+ name-beg) 'js-jsx-tag-name name-match-data))
+ ;; Make the opening “<” an open parenthesis.
+ (js-jsx--put-syntax-table tag-beg (1+ tag-beg) '(4))
+ ;; Prevent “out of range” errors when typing at the end of a buffer.
+ (setq tag-end (if (eobp) (1- (point)) (point)))
+ ;; Mark beginning and end of tag for font-locking.
+ (put-text-property tag-beg (1+ tag-beg) 'js-jsx-tag-beg (cons type tag-end))
+ (put-text-property tag-end (1+ tag-end) 'js-jsx-tag-end tag-beg)
+ ;; Use text properties to extend the syntax-propertize region
+ ;; backward to the beginning of the JSXBoundaryElement in the
+ ;; future. Typically the closing angle bracket could suggest
+ ;; extending backward, but that would also involve more rigorous
+ ;; parsing, and the closing angle bracket may not even exist yet
+ ;; if the JSXBoundaryElement is still being typed.
+ (put-text-property tag-beg (1+ tag-end) 'syntax-multiline t))
+ (if (js-jsx--at-enclosing-tag-child-p) (js-jsx--syntax-propertize-tag-text end))))
+
+(defconst js-jsx--text-properties
+ (list
+ 'js-jsx-tag-beg nil 'js-jsx-tag-end nil 'js-jsx-close-tag-pos nil
+ 'js-jsx-tag-name nil 'js-jsx-attribute-name nil 'js-jsx-string nil
+ 'js-jsx-text nil 'js-jsx-expr nil 'js-jsx-expr-attribute nil
+ 'js-jsx-syntax-table nil)
+ "Plist of text properties added by `js-syntax-propertize'.")
+
(defun js-syntax-propertize (start end)
;; JavaScript allows immediate regular expression objects, written /.../.
(goto-char start)
+ (if js-jsx-syntax (remove-text-properties start end js-jsx--text-properties))
(js-syntax-propertize-regexp end)
(funcall
(syntax-propertize-rules
@@ -1756,7 +2364,8 @@ This performs fontification according to `js--class-styles'."
(put-text-property (match-beginning 1) (match-end 1)
'syntax-table (string-to-syntax "\"/"))
(js-syntax-propertize-regexp end)))))
- ("\\`\\(#\\)!" (1 "< b")))
+ ("\\`\\(#\\)!" (1 "< b"))
+ ("<" (0 (ignore (if js-jsx-syntax (js-jsx--syntax-propertize-tag end))))))
(point) end))
(defconst js--prettify-symbols-alist
@@ -1782,6 +2391,11 @@ This performs fontification according to `js--class-styles'."
(js--regexp-opt-symbol '("in" "instanceof")))
"Regexp matching operators that affect indentation of continued expressions.")
+(defun js-jsx--looking-at-start-tag-p ()
+ "Non-nil if a JSXOpeningElement immediately follows point."
+ (let ((tag-beg (get-text-property (point) 'js-jsx-tag-beg)))
+ (and tag-beg (memq (car tag-beg) '(open self-closing)))))
+
(defun js--looking-at-operator-p ()
"Return non-nil if point is on a JavaScript operator, other than a comma."
(save-match-data
@@ -1804,7 +2418,9 @@ This performs fontification according to `js--class-styles'."
(js--backward-syntactic-ws)
;; We might misindent some expressions that would
;; return NaN anyway. Shouldn't be a problem.
- (memq (char-before) '(?, ?} ?{))))))))
+ (memq (char-before) '(?, ?} ?{)))))
+ ;; “<” isn’t necessarily an operator in JSX.
+ (not (and js-jsx-syntax (js-jsx--looking-at-start-tag-p))))))
(defun js--find-newline-backward ()
"Move backward to the nearest newline that is not in a block comment."
@@ -1824,6 +2440,10 @@ This performs fontification according to `js--class-styles'."
(setq result nil)))
result))
+(defun js-jsx--looking-back-at-end-tag-p ()
+ "Non-nil if a JSXClosingElement immediately precedes point."
+ (get-text-property (point) 'js-jsx-tag-end))
+
(defun js--continued-expression-p ()
"Return non-nil if the current line continues an expression."
(save-excursion
@@ -1841,12 +2461,19 @@ This performs fontification according to `js--class-styles'."
(and (js--find-newline-backward)
(progn
(skip-chars-backward " \t")
- (or (bobp) (backward-char))
- (and (> (point) (point-min))
- (save-excursion (backward-char) (not (looking-at "[/*]/")))
- (js--looking-at-operator-p)
- (and (progn (backward-char)
- (not (looking-at "+\\+\\|--\\|/[/*]"))))))))))
+ (and
+ ;; The “>” at the end of any JSXBoundaryElement isn’t
+ ;; part of a continued expression.
+ (not (and js-jsx-syntax (js-jsx--looking-back-at-end-tag-p)))
+ (progn
+ (or (bobp) (backward-char))
+ (and (> (point) (point-min))
+ (save-excursion
+ (backward-char)
+ (not (looking-at "[/*]/\\|=>")))
+ (js--looking-at-operator-p)
+ (and (progn (backward-char)
+ (not (looking-at "\\+\\+\\|--\\|/[/*]"))))))))))))
(defun js--skip-term-backward ()
"Skip a term before point; return t if a term was skipped."
@@ -1916,7 +2543,7 @@ the same column as the current line."
(save-match-data
(when (looking-at "\\s-*\\_<while\\_>")
(if (save-excursion
- (skip-chars-backward "[ \t\n]*}")
+ (skip-chars-backward " \t\n}")
(looking-at "[ \t\n]*}"))
(save-excursion
(backward-list) (forward-symbol -1) (looking-at "\\_<do\\_>"))
@@ -2072,6 +2699,183 @@ indentation is aligned to that column."
(when comma-p
(goto-char (1+ declaration-keyword-end))))))))
+(defconst js--line-terminating-arrow-re "=>\\s-*\\(/[/*]\\|$\\)"
+ "Regexp matching the last \"=>\" (arrow) token on a line.
+Whitespace and comments around the arrow are ignored.")
+
+(defun js--broken-arrow-terminates-line-p ()
+ "Helper function for `js--proper-indentation'.
+Return t if the last non-comment, non-whitespace token of the
+current line is the \"=>\" token (of an arrow function)."
+ (let ((from (point)))
+ (end-of-line)
+ (re-search-backward js--line-terminating-arrow-re from t)))
+
+;; When indenting, we want to know if the line is…
+;;
+;; - within a multiline JSXElement, or
+;; - within a string in a JSXBoundaryElement, or
+;; - within JSXText, or
+;; - within a JSXAttribute’s multiline JSXExpressionContainer.
+;;
+;; In these cases, special XML-like indentation rules for JSX apply.
+;; If JS is nested within JSX, then indentation calculations may be
+;; combined, such that JS indentation is “relative” to the JSX’s.
+;;
+;; Therefore, functions below provide such contextual information, and
+;; `js--proper-indentation' may call itself once recursively in order
+;; to finish calculating that “relative” JS+JSX indentation.
+
+(defun js-jsx--context ()
+ "Determine JSX context and move to enclosing JSX."
+ (let ((pos (point))
+ (parse-status (syntax-ppss))
+ (enclosing-tag-pos (js-jsx--enclosing-tag-pos)))
+ (when enclosing-tag-pos
+ (if (< pos (nth 1 enclosing-tag-pos))
+ (if (nth 3 parse-status)
+ (list 'string (nth 8 parse-status))
+ (list 'tag (nth 0 enclosing-tag-pos) (nth 1 enclosing-tag-pos)))
+ (list 'text (nth 0 enclosing-tag-pos) (nth 2 enclosing-tag-pos))))))
+
+(defun js-jsx--contextual-indentation (line context)
+ "Calculate indentation column for LINE from CONTEXT.
+The column calculation is based off of `sgml-calculate-indent'."
+ (pcase (nth 0 context)
+
+ ('string
+ ;; Go back to previous non-empty line.
+ (while (and (> (point) (nth 1 context))
+ (zerop (forward-line -1))
+ (looking-at "[ \t]*$")))
+ (if (> (point) (nth 1 context))
+ ;; Previous line is inside the string.
+ (current-indentation)
+ (goto-char (nth 1 context))
+ (1+ (current-column))))
+
+ ('tag
+ ;; Special JSX indentation rule: a “dangling” closing angle
+ ;; bracket on its own line is indented at the same level as the
+ ;; opening angle bracket of the JSXElement. Otherwise, indent
+ ;; JSXAttribute space like SGML.
+ (if (and
+ js-jsx-align->-with-<
+ (progn
+ (goto-char (nth 2 context))
+ (and (= line (line-number-at-pos))
+ (looking-back "^\\s-*/?>" (line-beginning-position)))))
+ (progn
+ (goto-char (nth 1 context))
+ (current-column))
+ ;; Indent JSXAttribute space like SGML.
+ (goto-char (nth 1 context))
+ ;; Skip tag name:
+ (skip-chars-forward " \t")
+ (skip-chars-forward "^ \t\n")
+ (skip-chars-forward " \t")
+ (if (not (eolp))
+ (current-column)
+ ;; This is the first attribute: indent.
+ (goto-char (+ (nth 1 context) js-jsx-attribute-offset))
+ (+ (current-column) (or js-jsx-indent-level js-indent-level)))))
+
+ ('text
+ ;; Indent to reflect nesting.
+ (goto-char (nth 1 context))
+ (+ (current-column)
+ ;; The last line isn’t nested, but the rest are.
+ (if (or (not (nth 2 context)) ; Unclosed.
+ (< line (line-number-at-pos (nth 2 context))))
+ (or js-jsx-indent-level js-indent-level)
+ 0)))
+
+ ))
+
+(defun js-jsx--enclosing-curly-pos ()
+ "Return position of enclosing “{” in a “{/}” pair about point."
+ (let ((parens (reverse (nth 9 (syntax-ppss)))) paren-pos curly-pos)
+ (while
+ (and
+ (setq paren-pos (car parens))
+ (not (when (= (char-after paren-pos) ?{)
+ (setq curly-pos paren-pos)))
+ (setq parens (cdr parens))))
+ curly-pos))
+
+(defun js-jsx--goto-outermost-enclosing-curly (limit)
+ "Set point to enclosing “{” at or closest after LIMIT."
+ (let (pos)
+ (while
+ (and
+ (setq pos (js-jsx--enclosing-curly-pos))
+ (if (>= pos limit) (goto-char pos))
+ (> pos limit)))))
+
+(defun js-jsx--expr-attribute-pos (start limit)
+ "Look back from START to LIMIT for a JSXAttribute."
+ (save-excursion
+ (goto-char start) ; Skip the first curly.
+ ;; Skip any remaining enclosing curlies until the JSXElement’s
+ ;; beginning position; the last curly ought to be one of a
+ ;; JSXExpressionContainer, which may refer to its JSXAttribute’s
+ ;; beginning position (if it has one).
+ (js-jsx--goto-outermost-enclosing-curly limit)
+ (get-text-property (point) 'js-jsx-expr-attribute)))
+
+(defvar js-jsx--indent-col nil
+ "Baseline column for JS indentation within JSX.")
+
+(defvar js-jsx--indent-attribute-line nil
+ "Line relative to which indentation uses JSX as a baseline.")
+
+(defun js-jsx--expr-indentation (parse-status pos col)
+ "Indent using PARSE-STATUS; relative to POS, use base COL.
+To indent a JSXExpressionContainer’s expression, calculate the JS
+indentation, using JSX indentation as the base column when
+indenting relative to the beginning line of the
+JSXExpressionContainer’s JSXAttribute (if any)."
+ (let* ((js-jsx--indent-col col)
+ (js-jsx--indent-attribute-line
+ (if pos (line-number-at-pos pos))))
+ (js--proper-indentation parse-status)))
+
+(defun js-jsx--indentation (parse-status)
+ "Helper function for `js--proper-indentation'.
+Return the proper indentation of the current line if it is part
+of a JSXElement expression spanning multiple lines; otherwise,
+return nil."
+ (let ((current-line (line-number-at-pos))
+ (curly-pos (js-jsx--enclosing-curly-pos))
+ nth-context context expr-p beg-line col
+ forward-sexp-function) ; Use the Lisp version.
+ ;; Find the immediate context for indentation information, but
+ ;; keep going to determine that point is at the N+1th line of
+ ;; multiline JSX.
+ (save-excursion
+ (while
+ (and
+ (setq nth-context (js-jsx--context))
+ (progn
+ (unless context
+ (setq context nth-context)
+ (setq expr-p (and curly-pos (< (point) curly-pos))))
+ (setq beg-line (line-number-at-pos))
+ (and
+ (= beg-line current-line)
+ (or (not curly-pos) (> (point) curly-pos)))))))
+ ;; When on the second or later line of JSX, indent as JSX,
+ ;; possibly switching back to JS indentation within
+ ;; JSXExpressionContainers, possibly using the JSX as a base
+ ;; column while switching back to JS indentation.
+ (when (and context (> current-line beg-line))
+ (save-excursion
+ (setq col (js-jsx--contextual-indentation current-line context)))
+ (if expr-p
+ (js-jsx--expr-indentation
+ parse-status (js-jsx--expr-attribute-pos curly-pos (nth 1 context)) col)
+ col))))
+
(defun js--proper-indentation (parse-status)
"Return the proper indentation for the current line."
(save-excursion
@@ -2079,6 +2883,8 @@ indentation is aligned to that column."
(cond ((nth 4 parse-status) ; inside comment
(js--get-c-offset 'c (nth 8 parse-status)))
((nth 3 parse-status) 0) ; inside string
+ ((when (and js-jsx-syntax (not js-jsx--indent-col))
+ (save-excursion (js-jsx--indentation parse-status))))
((eq (char-after) ?#) 0)
((save-excursion (js--beginning-of-macro)) 4)
;; Indent array comprehension continuation lines specially.
@@ -2102,7 +2908,8 @@ indentation is aligned to that column."
(continued-expr-p (js--continued-expression-p)))
(goto-char (nth 1 parse-status)) ; go to the opening char
(if (or (not js-indent-align-list-continuation)
- (looking-at "[({[]\\s-*\\(/[/*]\\|$\\)"))
+ (looking-at "[({[]\\s-*\\(/[/*]\\|$\\)")
+ (save-excursion (forward-char) (js--broken-arrow-terminates-line-p)))
(progn ; nothing following the opening paren/bracket
(skip-syntax-backward " ")
(when (eq (char-before) ?\)) (backward-list))
@@ -2114,17 +2921,24 @@ indentation is aligned to that column."
(and switch-keyword-p
in-switch-p)))
(indent
- (cond (same-indent-p
- (current-column))
- (continued-expr-p
- (+ (current-column) (* 2 js-indent-level)
- js-expr-indent-offset))
- (t
- (+ (current-column) js-indent-level
- (pcase (char-after (nth 1 parse-status))
- (?\( js-paren-indent-offset)
- (?\[ js-square-indent-offset)
- (?\{ js-curly-indent-offset)))))))
+ (+
+ (cond
+ ((and js-jsx--indent-attribute-line
+ (eq js-jsx--indent-attribute-line
+ (line-number-at-pos)))
+ js-jsx--indent-col)
+ (t
+ (current-column)))
+ (cond (same-indent-p 0)
+ (continued-expr-p
+ (+ (* 2 js-indent-level)
+ js-expr-indent-offset))
+ (t
+ (+ js-indent-level
+ (pcase (char-after (nth 1 parse-status))
+ (?\( js-paren-indent-offset)
+ (?\[ js-square-indent-offset)
+ (?\{ js-curly-indent-offset))))))))
(if in-switch-p
(+ indent js-switch-indent-offset)
indent)))
@@ -2140,193 +2954,6 @@ indentation is aligned to that column."
(+ js-indent-level js-expr-indent-offset))
(t (prog-first-column)))))
-;;; JSX Indentation
-
-(defsubst js--jsx-find-before-tag ()
- "Find where JSX starts.
-
-Assume JSX appears in the following instances:
-- Inside parentheses, when returned or as the first argument
- to a function, and after a newline
-- When assigned to variables or object properties, but only
- on a single line
-- As the N+1th argument to a function
-
-This is an optimized version of (re-search-backward \"[(,]\n\"
-nil t), except set point to the end of the match. This logic
-executes up to the number of lines in the file, so it should be
-really fast to reduce that impact."
- (let (pos)
- (while (and (> (point) (point-min))
- (not (progn
- (end-of-line 0)
- (when (or (eq (char-before) 40) ; (
- (eq (char-before) 44)) ; ,
- (setq pos (1- (point))))))))
- pos))
-
-(defconst js--jsx-end-tag-re
- (concat "</" sgml-name-re ">\\|/>")
- "Find the end of a JSX element.")
-
-(defconst js--jsx-after-tag-re "[),]"
- "Find where JSX ends.
-This complements the assumption of where JSX appears from
-`js--jsx-before-tag-re', which see.")
-
-(defun js--jsx-indented-element-p ()
- "Determine if/how the current line should be indented as JSX.
-
-Return `first' for the first JSXElement on its own line.
-Return `nth' for subsequent lines of the first JSXElement.
-Return `expression' for an embedded JS expression.
-Return `after' for anything after the last JSXElement.
-Return nil for non-JSX lines.
-
-Currently, JSX indentation supports the following styles:
-
-- Single-line elements (indented like normal JS):
-
- var element = <div></div>;
-
-- Multi-line elements (enclosed in parentheses):
-
- function () {
- return (
- <div>
- <div></div>
- </div>
- );
- }
-
-- Function arguments:
-
- React.render(
- <div></div>,
- document.querySelector('.root')
- );"
- (let ((current-pos (point))
- (current-line (line-number-at-pos))
- last-pos
- before-tag-pos before-tag-line
- tag-start-pos tag-start-line
- tag-end-pos tag-end-line
- after-tag-line
- parens paren type)
- (save-excursion
- (and
- ;; Determine if we're inside a jsx element
- (progn
- (end-of-line)
- (while (and (not tag-start-pos)
- (setq last-pos (js--jsx-find-before-tag)))
- (while (forward-comment 1))
- (when (= (char-after) 60) ; <
- (setq before-tag-pos last-pos
- tag-start-pos (point)))
- (goto-char last-pos))
- tag-start-pos)
- (progn
- (setq before-tag-line (line-number-at-pos before-tag-pos)
- tag-start-line (line-number-at-pos tag-start-pos))
- (and
- ;; A "before" line which also starts an element begins with js, so
- ;; indent it like js
- (> current-line before-tag-line)
- ;; Only indent the jsx lines like jsx
- (>= current-line tag-start-line)))
- (cond
- ;; Analyze bounds if there are any
- ((progn
- (while (and (not tag-end-pos)
- (setq last-pos (re-search-forward js--jsx-end-tag-re nil t)))
- (while (forward-comment 1))
- (when (looking-at js--jsx-after-tag-re)
- (setq tag-end-pos last-pos)))
- tag-end-pos)
- (setq tag-end-line (line-number-at-pos tag-end-pos)
- after-tag-line (line-number-at-pos after-tag-line))
- (or (and
- ;; Ensure we're actually within the bounds of the jsx
- (<= current-line tag-end-line)
- ;; An "after" line which does not end an element begins with
- ;; js, so indent it like js
- (<= current-line after-tag-line))
- (and
- ;; Handle another case where there could be e.g. comments after
- ;; the element
- (> current-line tag-end-line)
- (< current-line after-tag-line)
- (setq type 'after))))
- ;; They may not be any bounds (yet)
- (t))
- ;; Check if we're inside an embedded multi-line js expression
- (cond
- ((not type)
- (goto-char current-pos)
- (end-of-line)
- (setq parens (nth 9 (syntax-ppss)))
- (while (and parens (not type))
- (setq paren (car parens))
- (cond
- ((and (>= paren tag-start-pos)
- ;; Curly bracket indicates the start of an embedded expression
- (= (char-after paren) 123) ; {
- ;; The first line of the expression is indented like sgml
- (> current-line (line-number-at-pos paren))
- ;; Check if within a closing curly bracket (if any)
- ;; (exclusive, as the closing bracket is indented like sgml)
- (cond
- ((progn
- (goto-char paren)
- (ignore-errors (let (forward-sexp-function)
- (forward-sexp))))
- (< current-line (line-number-at-pos)))
- (t)))
- ;; Indicate this guy will be indented specially
- (setq type 'expression))
- (t (setq parens (cdr parens)))))
- t)
- (t))
- (cond
- (type)
- ;; Indent the first jsx thing like js so we can indent future jsx things
- ;; like sgml relative to the first thing
- ((= current-line tag-start-line) 'first)
- ('nth))))))
-
-(defmacro js--as-sgml (&rest body)
- "Execute BODY as if in sgml-mode."
- `(with-syntax-table sgml-mode-syntax-table
- (let (forward-sexp-function
- parse-sexp-lookup-properties)
- ,@body)))
-
-(defun js--expression-in-sgml-indent-line ()
- "Indent the current line as JavaScript or SGML (whichever is farther)."
- (let* (indent-col
- (savep (point))
- ;; Don't whine about errors/warnings when we're indenting.
- ;; This has to be set before calling parse-partial-sexp below.
- (inhibit-point-motion-hooks t)
- (parse-status (save-excursion
- (syntax-ppss (point-at-bol)))))
- ;; Don't touch multiline strings.
- (unless (nth 3 parse-status)
- (setq indent-col (save-excursion
- (back-to-indentation)
- (if (>= (point) savep) (setq savep nil))
- (js--as-sgml (sgml-calculate-indent))))
- (if (null indent-col)
- 'noindent
- ;; Use whichever indentation column is greater, such that the sgml
- ;; column is effectively a minimum
- (setq indent-col (max (js--proper-indentation parse-status)
- (+ indent-col js-indent-level)))
- (if savep
- (save-excursion (indent-line-to indent-col))
- (indent-line-to indent-col))))))
-
(defun js-indent-line ()
"Indent the current line as JavaScript."
(interactive)
@@ -2338,23 +2965,9 @@ Currently, JSX indentation supports the following styles:
(when (> offset 0) (forward-char offset)))))
(defun js-jsx-indent-line ()
- "Indent the current line as JSX (with SGML offsets).
-i.e., customize JSX element indentation with `sgml-basic-offset',
-`sgml-attribute-offset' et al."
+ "Indent the current line as JavaScript+JSX."
(interactive)
- (let ((indentation-type (js--jsx-indented-element-p)))
- (cond
- ((eq indentation-type 'expression)
- (js--expression-in-sgml-indent-line))
- ((or (eq indentation-type 'first)
- (eq indentation-type 'after))
- ;; Don't treat this first thing as a continued expression (often a "<" or
- ;; ">" causes this misinterpretation)
- (cl-letf (((symbol-function #'js--continued-expression-p) 'ignore))
- (js-indent-line)))
- ((eq indentation-type 'nth)
- (js--as-sgml (sgml-indent-line)))
- (t (js-indent-line)))))
+ (let ((js-jsx-syntax t)) (js-indent-line)))
;;; Filling
@@ -2362,23 +2975,22 @@ i.e., customize JSX element indentation with `sgml-basic-offset',
;; FIXME: Such redefinitions are bad style. We should try and use some other
;; way to get the same result.
-(defadvice c-forward-sws (around js-fill-paragraph activate)
- (if js--filling-paragraph
- (setq ad-return-value (js--forward-syntactic-ws (ad-get-arg 0)))
- ad-do-it))
-
-(defadvice c-backward-sws (around js-fill-paragraph activate)
- (if js--filling-paragraph
- (setq ad-return-value (js--backward-syntactic-ws (ad-get-arg 0)))
- ad-do-it))
-
-(defadvice c-beginning-of-macro (around js-fill-paragraph activate)
- (if js--filling-paragraph
- (setq ad-return-value (js--beginning-of-macro (ad-get-arg 0)))
- ad-do-it))
-
-(defun js-c-fill-paragraph (&optional justify)
- "Fill the paragraph with `c-fill-paragraph'."
+(defun js--fill-c-advice (js-fun)
+ (lambda (orig-fun &rest args)
+ (if js--filling-paragraph
+ (funcall js-fun (car args))
+ (apply orig-fun args))))
+
+(advice-add 'c-forward-sws
+ :around (js--fill-c-advice #'js--forward-syntactic-ws))
+(advice-add 'c-backward-sws
+ :around (js--fill-c-advice #'js--backward-syntactic-ws))
+(advice-add 'c-beginning-of-macro
+ :around (js--fill-c-advice #'js--beginning-of-macro))
+
+(define-obsolete-function-alias 'js-c-fill-paragraph #'js-fill-paragraph "27.1")
+(defun js-fill-paragraph (&optional justify)
+ "Fill the paragraph for Javascript code."
(interactive "*P")
(let ((js--filling-paragraph t)
(fill-paragraph-function #'c-fill-paragraph))
@@ -2761,8 +3373,8 @@ Otherwise, use the current value of `process-mark'."
(with-current-buffer (process-buffer process)
(cl-loop with start-pos = (or start
(marker-position (process-mark process)))
- with end-time = (+ (float-time) timeout)
- for time-left = (- end-time (float-time))
+ with end-time = (time-add nil timeout)
+ for time-left = (float-time (time-subtract end-time nil))
do (goto-char (point-max))
if (looking-back regexp start-pos) return t
while (> time-left 0)
@@ -3317,11 +3929,11 @@ If nil, the whole Array is treated as a JS symbol.")
(defun js--js-decode-retval (result)
(pcase (intern (cl-first result))
- (`atom (cl-second result))
- (`special (intern (cl-second result)))
- (`array
+ ('atom (cl-second result))
+ ('special (intern (cl-second result)))
+ ('array
(mapcar #'js--js-decode-retval (cl-second result)))
- (`objid
+ ('objid
(or (gethash (cl-second result)
js--js-references)
(puthash (cl-second result)
@@ -3330,7 +3942,7 @@ If nil, the whole Array is treated as a JS symbol.")
:process (inferior-moz-process))
js--js-references)))
- (`error (signal 'js-js-error (list (cl-second result))))
+ ('error (signal 'js-js-error (list (cl-second result))))
(x (error "Unmatched case in js--js-decode-retval: %S" x))))
(defvar comint-last-input-end)
@@ -3715,8 +4327,8 @@ If one hasn't been set, or if it's stale, prompt for a new one."
(when (or (null js--js-context)
(js--js-handle-expired-p (cdr js--js-context))
(pcase (car js--js-context)
- (`window (js? (js< (cdr js--js-context) "closed")))
- (`browser (not (js? (js< (cdr js--js-context)
+ ('window (js? (js< (cdr js--js-context) "closed")))
+ ('browser (not (js? (js< (cdr js--js-context)
"contentDocument"))))
(x (error "Unmatched case in js--get-js-context: %S" x))))
(setq js--js-context (js--read-tab "JavaScript Context: ")))
@@ -3725,8 +4337,8 @@ If one hasn't been set, or if it's stale, prompt for a new one."
(defun js--js-content-window (context)
(with-js
(pcase (car context)
- (`window (cdr context))
- (`browser (js< (cdr context)
+ ('window (cdr context))
+ ('browser (js< (cdr context)
"contentWindow" "wrappedJSObject"))
(x (error "Unmatched case in js--js-content-window: %S" x)))))
@@ -3846,6 +4458,77 @@ If one hasn't been set, or if it's stale, prompt for a new one."
(when temp-name
(delete-file temp-name))))))
+;;; Syntax extensions
+
+(defvar js-syntactic-mode-name t
+ "If non-nil, print enabled syntaxes in the mode name.")
+
+(defun js--syntactic-mode-name-part ()
+ "Return a string like “[JSX]” when `js-jsx-syntax' is enabled."
+ (if js-syntactic-mode-name
+ (let (syntaxes)
+ (if js-jsx-syntax (push "JSX" syntaxes))
+ (if syntaxes
+ (concat "[" (mapconcat #'identity syntaxes ",") "]")
+ ""))
+ ""))
+
+(defun js-use-syntactic-mode-name ()
+ "Print enabled syntaxes if `js-syntactic-mode-name' is t.
+Modes deriving from `js-mode' should call this to ensure that
+their `mode-name' updates to show enabled syntax extensions."
+ (when (stringp mode-name)
+ (setq mode-name `(,mode-name (:eval (js--syntactic-mode-name-part))))))
+
+(defun js-jsx-enable ()
+ "Enable JSX in the current buffer."
+ (interactive)
+ (setq-local js-jsx-syntax t))
+
+;; To make discovering and using syntax extensions features easier for
+;; users (who might not read the docs), try to safely and
+;; automatically enable syntax extensions based on heuristics.
+
+(defvar js-jsx-regexps
+ (list "\\_<\\(?:var\\|let\\|const\\|import\\)\\_>.*?React")
+ "Regexps for detecting JSX in JavaScript buffers.
+When `js-jsx-detect-syntax' is non-nil and any of these regexps
+match text near the beginning of a JavaScript buffer,
+`js-jsx-syntax' (which see) will be made buffer-local and set to
+t.")
+
+(defun js-jsx--detect-and-enable (&optional arbitrarily)
+ "Detect if JSX is likely to be used, and enable it if so.
+Might make `js-jsx-syntax' buffer-local and set it to t. Matches
+from the beginning of the buffer, unless optional arg ARBITRARILY
+is non-nil. Return t after enabling, nil otherwise."
+ (when (or (and (buffer-file-name)
+ (string-match-p "\\.jsx\\'" (buffer-file-name)))
+ (and js-jsx-detect-syntax
+ (save-excursion
+ (unless arbitrarily
+ (goto-char (point-min)))
+ (catch 'match
+ (mapc
+ (lambda (regexp)
+ (if (re-search-forward regexp 4000 t) (throw 'match t)))
+ js-jsx-regexps)
+ nil))))
+ (js-jsx-enable)
+ t))
+
+(defun js-jsx--detect-after-change (beg end _len)
+ "Detect if JSX is likely to be used after a change.
+This function is intended for use in `after-change-functions'."
+ (when (<= end 4000)
+ (save-excursion
+ (goto-char beg)
+ (beginning-of-line)
+ (save-restriction
+ (narrow-to-region (point) end)
+ (when (js-jsx--detect-and-enable 'arbitrarily)
+ (remove-hook 'after-change-functions #'js-jsx--detect-after-change t))))))
+
;;; Main Function
;;;###autoload
@@ -3861,16 +4544,20 @@ If one hasn't been set, or if it's stale, prompt for a new one."
'(font-lock-syntactic-face-function
. js-font-lock-syntactic-face-function)))
(setq-local syntax-propertize-function #'js-syntax-propertize)
+ (add-hook 'syntax-propertize-extend-region-functions
+ #'syntax-propertize-multiline 'append 'local)
+ (add-hook 'syntax-propertize-extend-region-functions
+ #'js--syntax-propertize-extend-region 'append 'local)
(setq-local prettify-symbols-alist js--prettify-symbols-alist)
(setq-local parse-sexp-ignore-comments t)
- (setq-local parse-sexp-lookup-properties t)
(setq-local which-func-imenu-joiner-function #'js--which-func-joiner)
;; Comments
(setq-local comment-start "// ")
+ (setq-local comment-start-skip "\\(//+\\|/\\*+\\)\\s *")
(setq-local comment-end "")
- (setq-local fill-paragraph-function #'js-c-fill-paragraph)
+ (setq-local fill-paragraph-function #'js-fill-paragraph)
(setq-local normal-auto-fill-function #'js-do-auto-fill)
;; Parse cache
@@ -3879,6 +4566,11 @@ If one hasn't been set, or if it's stale, prompt for a new one."
;; Frameworks
(js--update-quick-match-re)
+ ;; Syntax extensions
+ (unless (js-jsx--detect-and-enable)
+ (add-hook 'after-change-functions #'js-jsx--detect-after-change nil t))
+ (js-use-syntactic-mode-name)
+
;; Imenu
(setq imenu-case-fold-search nil)
(setq imenu-create-index-function #'js--imenu-create-index)
@@ -3889,8 +4581,7 @@ If one hasn't been set, or if it's stale, prompt for a new one."
c-paragraph-separate "$"
c-block-comment-prefix "* "
c-line-comment-starter "//"
- c-comment-start-regexp "/[*/]\\|\\s!"
- comment-start-skip "\\(//+\\|/\\*+\\)\\s *")
+ c-comment-start-regexp "/[*/]\\|\\s!")
(setq-local comment-line-break-function #'c-indent-new-comment-line)
(setq-local c-block-comment-start-regexp "/\\*")
(setq-local comment-multi-line t)
@@ -3923,19 +4614,33 @@ If one hasn't been set, or if it's stale, prompt for a new one."
;;(syntax-propertize (point-max))
)
-;;;###autoload
-(define-derived-mode js-jsx-mode js-mode "JSX"
- "Major mode for editing JSX.
-
-To customize the indentation for this mode, set the SGML offset
-variables (`sgml-basic-offset', `sgml-attribute-offset' et al.)
-locally, like so:
+;; Since we made JSX support available and automatically-enabled in
+;; the base `js-mode' (for ease of use), now `js-jsx-mode' simply
+;; serves as one other interface to unconditionally enable JSX in
+;; buffers, mostly for backwards-compatibility.
+;;
+;; Since it is probably more common for packages to integrate with
+;; `js-mode' than with `js-jsx-mode', it is therefore probably
+;; slightly better for users to use one of the many other methods for
+;; enabling JSX syntax. But using `js-jsx-mode' can’t be that bad
+;; either, so we won’t bother users with an obsoletion warning.
- (defun set-jsx-indentation ()
- (setq-local sgml-basic-offset js-indent-level))
- (add-hook \\='js-jsx-mode-hook #\\='set-jsx-indentation)"
+;;;###autoload
+(define-derived-mode js-jsx-mode js-mode "JavaScript"
+ "Major mode for editing JavaScript+JSX.
+
+Simply makes `js-jsx-syntax' buffer-local and sets it to t.
+
+`js-mode' may detect and enable support for JSX automatically if
+it appears to be used in a JavaScript file. You could also
+customize `js-jsx-regexps' to improve that detection; or, you
+could set `js-jsx-syntax' to t in your init file, or in a
+.dir-locals.el file, or using file variables; or, you could call
+`js-jsx-enable' in `js-mode-hook'. You may be better served by
+one of the aforementioned options instead of using this mode."
:group 'js
- (setq-local indent-line-function #'js-jsx-indent-line))
+ (js-jsx-enable)
+ (js-use-syntactic-mode-name))
;;;###autoload (defalias 'javascript-mode 'js-mode)
diff --git a/lisp/progmodes/m4-mode.el b/lisp/progmodes/m4-mode.el
index 7a1f0a86466..98b812f52f6 100644
--- a/lisp/progmodes/m4-mode.el
+++ b/lisp/progmodes/m4-mode.el
@@ -63,10 +63,9 @@ If m4 is not in your PATH, set this to an absolute file name."
;;(defconst m4-program-options '("--prefix-builtins"))
(defvar m4-font-lock-keywords
- `(
- ("\\(\\_<\\(m4_\\)?dnl\\_>\\).*$" . font-lock-comment-face)
+ '(("\\(\\_<\\(m4_\\)?dnl\\_>\\).*$" . font-lock-comment-face)
("\\$[*#@0-9]" . font-lock-variable-name-face)
- ("\\$\\@" . font-lock-variable-name-face)
+ ("\\$@" . font-lock-variable-name-face)
("\\$\\*" . font-lock-variable-name-face)
("\\_<\\(m4_\\)?\\(builtin\\|change\\(com\\|quote\\|word\\)\\|d\\(e\\(bug\\(file\\|mode\\)\\|cr\\|f\\(ine\\|n\\)\\)\\|iv\\(ert\\|num\\)\\|nl\\|umpdef\\)\\|e\\(rrprint\\|syscmd\\|val\\)\\|f\\(ile\\|ormat\\)\\|gnu\\|i\\(f\\(def\\|else\\)\\|n\\(c\\(lude\\|r\\)\\|d\\(ex\\|ir\\)\\)\\)\\|l\\(en\\|ine\\)\\|m\\(4\\(exit\\|wrap\\)\\|aketemp\\)\\|p\\(atsubst\\|opdef\\|ushdef\\)\\|regexp\\|s\\(hift\\|include\\|ubstr\\|ys\\(cmd\\|val\\)\\)\\|tra\\(ceo\\(ff\\|n\\)\\|nslit\\)\\|un\\(d\\(efine\\|ivert\\)\\|ix\\)\\)\\_>" . font-lock-keyword-face))
"Default `font-lock-keywords' for M4 mode.")
diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el
index 7b00857ea95..cffb749c3e8 100644
--- a/lisp/progmodes/make-mode.el
+++ b/lisp/progmodes/make-mode.el
@@ -343,7 +343,7 @@ not be enclosed in { } or ( )."
"List of keywords understood by gmake.")
(defconst makefile-bsdmake-statements
- `(".elif" ".elifdef" ".elifmake" ".elifndef" ".elifnmake" ".else" ".endfor"
+ '(".elif" ".elifdef" ".elifmake" ".elifndef" ".elifnmake" ".else" ".endfor"
".endif" ".for" ".if" ".ifdef" ".ifmake" ".ifndef" ".ifnmake" ".undef")
"List of keywords understood by BSD make.")
@@ -557,6 +557,9 @@ This should identify a `make' command that can handle the `-q' option."
:type 'string
:group 'makefile)
+(defvaralias 'makefile-query-one-target-method
+ 'makefile-query-one-target-method-function)
+
(defcustom makefile-query-one-target-method-function
'makefile-query-by-make-minus-q
"Function to call to determine whether a make target is up to date.
@@ -574,8 +577,6 @@ The function must satisfy this calling convention:
makefile, any nonzero integer value otherwise."
:type 'function
:group 'makefile)
-(defvaralias 'makefile-query-one-target-method
- 'makefile-query-one-target-method-function)
(defcustom makefile-up-to-date-buffer-name "*Makefile Up-to-date overview*"
"Name of the Up-to-date overview buffer."
@@ -712,6 +713,7 @@ The function must satisfy this calling convention:
(modify-syntax-entry ?# "< " st)
(modify-syntax-entry ?\n "> " st)
(modify-syntax-entry ?= "." st)
+ (modify-syntax-entry ?$ "." st)
st)
"Syntax table used in `makefile-mode'.")
diff --git a/lisp/progmodes/mantemp.el b/lisp/progmodes/mantemp.el
index 9beeb4aae62..4190a847274 100644
--- a/lisp/progmodes/mantemp.el
+++ b/lisp/progmodes/mantemp.el
@@ -89,7 +89,7 @@
(save-excursion
(goto-char (point-min))
(message "Removing comments")
- (while (re-search-forward "^[A-z.()+0-9: ]*`\\|'.*$" nil t)
+ (while (re-search-forward "^[a-zA-Z.()+0-9: ]*`\\|'.*$" nil t)
(replace-match ""))))
(defun mantemp-remove-memfuncs ()
@@ -99,14 +99,14 @@
(goto-char (point-min))
(message "Removing member function extensions")
(while (re-search-forward
- "^[A-z :&*<>~=,0-9+]*>::operator " nil t nil)
+ "^[a-zA-Z :&*<>~=,0-9+]*>::operator " nil t nil)
(progn
(backward-char 11)
(delete-region (point) (line-end-position))))
;; Remove other member function extensions.
(goto-char (point-min))
(message "Removing member function extensions")
- (while (re-search-forward "^[A-z :&*<>~=,0-9+]*>::" nil t nil)
+ (while (re-search-forward "^[a-zA-Z :&*<>~=,0-9+]*>::" nil t nil)
(progn
(backward-char 2)
(delete-region (point) (line-end-position))))))
@@ -154,7 +154,7 @@ the lines."
(goto-char (point-min))
(message "Inserting 'template' for functions")
(while (re-search-forward
- "^template class [A-z :&*<>~=,0-9+!]*(" nil t nil)
+ "^template class [a-zA-Z :&*<>~=,0-9+!]*(" nil t nil)
(progn
(beginning-of-line)
(forward-word-strictly 1)
diff --git a/lisp/progmodes/meta-mode.el b/lisp/progmodes/meta-mode.el
index 34b8bbbd399..8d3745be7c9 100644
--- a/lisp/progmodes/meta-mode.el
+++ b/lisp/progmodes/meta-mode.el
@@ -666,7 +666,7 @@ If the list was changed, sort the list and remove duplicates first."
(let ((count 0))
(narrow-to-region
(point) (save-excursion
- (re-search-forward "[^\\\\\"]%\\|\n\\|\\'" nil t)
+ (re-search-forward "[^\\\"]%\\|\n\\|\\'" nil t)
(backward-char) (point)))
(while (re-search-forward "\\<\\sw+\\>\\|(\\|)" nil t)
(save-excursion
diff --git a/lisp/progmodes/mixal-mode.el b/lisp/progmodes/mixal-mode.el
index 2bf758bdaff..a759709b5c8 100644
--- a/lisp/progmodes/mixal-mode.el
+++ b/lisp/progmodes/mixal-mode.el
@@ -1044,7 +1044,7 @@ EXECUTION-TIME holds info about the time it takes, number or string.")
. mixal-font-lock-operation-code-face)
(,(regexp-opt mixal-assembly-pseudoinstructions 'words)
. mixal-font-lock-assembly-pseudoinstruction-face)
- ("^[A-Z0-9a-z]*[ \t]+[A-ZO-9a-z]+[ \t]+\\(=.*=\\)"
+ ("^[A-Z0-9a-z]*[ \t]+[A-Z0-9a-z]+[ \t]+\\(=.*=\\)"
(1 font-lock-constant-face)))
"Keyword highlighting specification for `mixal-mode'.")
;; (makunbound 'mixal-font-lock-keywords)
@@ -1108,7 +1108,7 @@ Assumes that file has been compiled with debugging support."
(set (make-local-variable 'comment-start) "*")
(set (make-local-variable 'comment-start-skip) "^\\*[ \t]*")
(set (make-local-variable 'font-lock-defaults)
- `(mixal-font-lock-keywords))
+ '(mixal-font-lock-keywords))
(set (make-local-variable 'syntax-propertize-function)
mixal-syntax-propertize-function)
;; might add an indent function in the future
diff --git a/lisp/progmodes/modula2.el b/lisp/progmodes/modula2.el
index 582e495a2bf..aa412304c59 100644
--- a/lisp/progmodes/modula2.el
+++ b/lisp/progmodes/modula2.el
@@ -232,11 +232,11 @@
;; FIXME: "^." are two tokens, not one.
(defun m2-smie-forward-token ()
(pcase (smie-default-forward-token)
- (`"VAR" (if (zerop (car (syntax-ppss))) "VAR" "VAR-arg"))
- (`"CONST" (if (zerop (car (syntax-ppss))) "CONST" "CONST-arg"))
- (`";" (save-excursion (m2-smie-refine-semi)))
- (`"OF" (save-excursion (forward-char -2) (m2-smie-refine-of)))
- (`":" (save-excursion (forward-char -1) (m2-smie-refine-colon)))
+ ("VAR" (if (zerop (car (syntax-ppss))) "VAR" "VAR-arg"))
+ ("CONST" (if (zerop (car (syntax-ppss))) "CONST" "CONST-arg"))
+ (";" (save-excursion (m2-smie-refine-semi)))
+ ("OF" (save-excursion (forward-char -2) (m2-smie-refine-of)))
+ (":" (save-excursion (forward-char -1) (m2-smie-refine-colon)))
;; (`"END" (if (and (looking-at "[ \t\n]*\\(\\(?:\\sw\\|\\s_\\)+\\)")
;; (not (assoc (match-string 1) m2-smie-grammar)))
;; "END-proc" "END"))
@@ -244,11 +244,11 @@
(defun m2-smie-backward-token ()
(pcase (smie-default-backward-token)
- (`"VAR" (if (zerop (car (syntax-ppss))) "VAR" "VAR-arg"))
- (`"CONST" (if (zerop (car (syntax-ppss))) "CONST" "CONST-arg"))
- (`";" (save-excursion (forward-char 1) (m2-smie-refine-semi)))
- (`"OF" (save-excursion (m2-smie-refine-of)))
- (`":" (save-excursion (m2-smie-refine-colon)))
+ ("VAR" (if (zerop (car (syntax-ppss))) "VAR" "VAR-arg"))
+ ("CONST" (if (zerop (car (syntax-ppss))) "CONST" "CONST-arg"))
+ (";" (save-excursion (forward-char 1) (m2-smie-refine-semi)))
+ ("OF" (save-excursion (m2-smie-refine-of)))
+ (":" (save-excursion (m2-smie-refine-colon)))
;; (`"END" (if (and (looking-at "\\sw+[ \t\n]+\\(\\(?:\\sw\\|\\s_\\)+\\)")
;; (not (assoc (match-string 1) m2-smie-grammar)))
;; "END-proc" "END"))
@@ -270,16 +270,16 @@
;; - The inner VAR/TYPE are indented just like the outer VAR/TYPE.
;; - The inner PROCEDURE is not aligned with its VAR/TYPE siblings.
(pcase (cons kind token)
- (`(:elem . basic) m2-indent)
- (`(:after . ":=") (or m2-indent smie-indent-basic))
- (`(:after . ,(or `"CONST" `"VAR" `"TYPE"))
+ ('(:elem . basic) m2-indent)
+ ('(:after . ":=") (or m2-indent smie-indent-basic))
+ (`(:after . ,(or "CONST" "VAR" "TYPE"))
(or m2-indent smie-indent-basic))
;; (`(:before . ,(or `"VAR" `"TYPE" `"CONST"))
;; (if (smie-rule-parent-p "PROCEDURE") 0))
- (`(:after . ";-block")
+ ('(:after . ";-block")
(if (smie-rule-parent-p "PROCEDURE")
(smie-rule-parent (or m2-indent smie-indent-basic))))
- (`(:before . "|") (smie-rule-separator kind))
+ ('(:before . "|") (smie-rule-separator kind))
))
;;;###autoload
diff --git a/lisp/progmodes/octave.el b/lisp/progmodes/octave.el
index 6caf8d93d3f..52e5fd477f4 100644
--- a/lisp/progmodes/octave.el
+++ b/lisp/progmodes/octave.el
@@ -170,8 +170,8 @@ parenthetical grouping.")
(modify-syntax-entry ?. "." table)
(modify-syntax-entry ?\" "\"" table)
(modify-syntax-entry ?_ "_" table)
- ;; The "b" flag only applies to the second letter of the comstart
- ;; and the first letter of the comend, i.e. the "4b" below is ineffective.
+ ;; The "b" flag only applies to the second letter of the comstart and
+ ;; the first letter of the comend, i.e. a "4b" below would be ineffective.
;; If we try to put `b' on the single-line comments, we get a similar
;; problem where the % and # chars appear as first chars of the 2-char
;; comend, so the multi-line ender is also turned into style-b.
@@ -442,12 +442,12 @@ Non-nil means always go to the next Octave code line after sending."
;; disadvantages:
;; - changes to octave-block-offset wouldn't take effect immediately.
;; - edebug wouldn't show the use of this variable.
- (`(:elem . basic) octave-block-offset)
+ ('(:elem . basic) octave-block-offset)
(`(:list-intro . ,(or "global" "persistent")) t)
;; Since "case" is in the same BNF rules as switch..end, SMIE by default
;; aligns it with "switch".
- (`(:before . "case") (if (not (smie-rule-sibling-p)) octave-block-offset))
- (`(:after . ";")
+ ('(:before . "case") (if (not (smie-rule-sibling-p)) octave-block-offset))
+ ('(:after . ";")
(if (apply #'smie-rule-parent-p octave--block-offset-keywords)
(smie-rule-parent octave-block-offset)
;; For (invalid) code between switch and case.
@@ -533,6 +533,27 @@ Non-nil means always go to the next Octave code line after sending."
(defvar electric-layout-rules)
+;; FIXME: cc-mode.el also adds an entry for .m files, mapping them to
+;; objc-mode. We here rely on the fact that loaddefs.el is filled in
+;; alphabetical order, so cc-mode.el comes before octave-mode.el, which lets
+;; our entry come first!
+;;;###autoload (add-to-list 'auto-mode-alist '("\\.m\\'" . octave-maybe-mode))
+
+;;;###autoload
+(defun octave-maybe-mode ()
+ "Select `octave-mode' if the current buffer seems to hold Octave code."
+ (if (save-excursion
+ (with-syntax-table octave-mode-syntax-table
+ (goto-char (point-min))
+ (forward-comment (point-max))
+ ;; FIXME: What about Octave files which don't start with "function"?
+ (looking-at "function")))
+ (octave-mode)
+ (let ((x (rassq 'octave-maybe-mode auto-mode-alist)))
+ (when x
+ (let ((auto-mode-alist (remove x auto-mode-alist)))
+ (set-auto-mode))))))
+
;;;###autoload
(define-derived-mode octave-mode prog-mode "Octave"
"Major mode for editing Octave code.
@@ -639,6 +660,9 @@ mode, include \"-q\" and \"--traditional\"."
:type '(repeat string)
:version "24.4")
+(define-obsolete-variable-alias 'inferior-octave-startup-hook
+ 'inferior-octave-mode-hook "24.4")
+
(defcustom inferior-octave-mode-hook nil
"Hook to be run when Inferior Octave mode is started."
:type 'hook)
@@ -693,9 +717,6 @@ mode, include \"-q\" and \"--traditional\"."
(defvar inferior-octave-output-string nil)
(defvar inferior-octave-receive-in-progress nil)
-(define-obsolete-variable-alias 'inferior-octave-startup-hook
- 'inferior-octave-mode-hook "24.4")
-
(defvar inferior-octave-dynamic-complete-functions
'(inferior-octave-completion-at-point comint-filename-completion)
"List of functions called to perform completion for inferior Octave.
@@ -1044,8 +1065,8 @@ directory and makes this the current buffer's default directory."
(unless found (goto-char orig))
found))))
(pcase (and buffer-file-name (file-name-extension buffer-file-name))
- (`"cc" (funcall search
- "\\_<DEFUN\\(?:_DLD\\)?\\s-*(\\s-*\\(\\(?:\\sw\\|\\s_\\)+\\)" 1))
+ ("cc" (funcall search
+ "\\_<DEFUN\\(?:_DLD\\)?\\s-*(\\s-*\\(\\(?:\\sw\\|\\s_\\)+\\)" 1))
(_ (funcall search octave-function-header-regexp 3)))))
(defun octave-function-file-p ()
@@ -1114,19 +1135,19 @@ q: Don't fix\n" func file))
(read-char-choice
"Which name to use? (a/b/q) " '(?a ?b ?q))))))
(pcase c
- (`?a (let ((newname (expand-file-name
- (concat func (file-name-extension
- buffer-file-name t)))))
- (when (or (not (file-exists-p newname))
- (yes-or-no-p
- (format "Target file %s exists; proceed? " newname)))
- (when (file-exists-p buffer-file-name)
- (rename-file buffer-file-name newname t))
- (set-visited-file-name newname))))
- (`?b (save-excursion
- (goto-char name-start)
- (delete-region name-start name-end)
- (insert file)))))))))
+ (?a (let ((newname (expand-file-name
+ (concat func (file-name-extension
+ buffer-file-name t)))))
+ (when (or (not (file-exists-p newname))
+ (yes-or-no-p
+ (format "Target file %s exists; proceed? " newname)))
+ (when (file-exists-p buffer-file-name)
+ (rename-file buffer-file-name newname t))
+ (set-visited-file-name newname))))
+ (?b (save-excursion
+ (goto-char name-start)
+ (delete-region name-start name-end)
+ (insert file)))))))))
(defun octave-update-function-file-comment (beg end)
"Query replace function names in function file comment."
@@ -1165,6 +1186,8 @@ q: Don't fix\n" func file))
"Face used to highlight function comment block.")
(eval-when-compile (require 'texinfo))
+;; Undo the effects of texinfo loading tex-mode loading compile.
+(declare-function compilation-forget-errors "compile" ())
(defun octave-font-lock-texinfo-comment ()
(let ((kws
@@ -1629,11 +1652,11 @@ code line."
;;
;; Return the value according to style.
(pcase octave-eldoc-message-style
- (`auto (if (< (length oneline) (window-width (minibuffer-window)))
+ ('auto (if (< (length oneline) (window-width (minibuffer-window)))
oneline
multiline))
- (`oneline oneline)
- (`multiline multiline)))))
+ ('oneline oneline)
+ ('multiline multiline)))))
(defcustom octave-help-buffer "*Octave Help*"
"Buffer name for `octave-help'."
@@ -1778,19 +1801,19 @@ If the environment variable OCTAVE_SRCDIR is set, it is searched first."
(defun octave-find-definition-default-filename (name)
"Default value for `octave-find-definition-filename-function'."
(pcase (file-name-extension name)
- (`"oct"
+ ("oct"
(octave-find-definition-default-filename
(concat "libinterp/dldfcn/"
(file-name-sans-extension (file-name-nondirectory name))
".cc")))
- (`"cc"
+ ("cc"
(let ((file (or (locate-file name (octave-source-directories))
(locate-file (file-name-nondirectory name)
(octave-source-directories)))))
(or (and file (file-exists-p file))
(error "File `%s' not found" name))
file))
- (`"mex"
+ ("mex"
(if (yes-or-no-p (format-message "File `%s' may be binary; open? "
(file-name-nondirectory name)))
name
diff --git a/lisp/progmodes/opascal.el b/lisp/progmodes/opascal.el
index cfacbe01e10..7d51816bf40 100644
--- a/lisp/progmodes/opascal.el
+++ b/lisp/progmodes/opascal.el
@@ -140,7 +140,7 @@ That is, regardless of where in the line point is at the time."
opascal-directives)
"OPascal4 keywords.")
-(defconst opascal-previous-terminators `(semicolon comma)
+(defconst opascal-previous-terminators '(semicolon comma)
"Expression/statement terminators that denote a previous expression.")
(defconst opascal-comments
@@ -186,7 +186,7 @@ are followed by an expression.")
`(except finally ,@opascal-visibilities)
"Statements that mark mid sections of the enclosing block.")
-(defconst opascal-end-block-statements `(end until)
+(defconst opascal-end-block-statements '(end until)
"Statements that end block sections.")
(defconst opascal-match-block-statements
@@ -210,7 +210,7 @@ are followed by an expression.")
'(interface implementation program library package)
"Unit sections within which the indent is 0.")
-(defconst opascal-use-clauses `(uses requires exports contains)
+(defconst opascal-use-clauses '(uses requires exports contains)
"Statements that refer to foreign symbols.")
(defconst opascal-unit-statements
@@ -393,17 +393,17 @@ routine.")
(if (null (nth 8 ppss))
(when (looking-at opascal--literal-start-re)
(pcase (char-after)
- (`?/ 'comment-single-line)
- (`?\{ 'comment-multi-line-1)
- (`?\( 'comment-multi-line-2)
- (`?\' 'string)
- (`?\" 'double-quoted-string)))
+ (?/ 'comment-single-line)
+ (?\{ 'comment-multi-line-1)
+ (?\( 'comment-multi-line-2)
+ (?\' 'string)
+ (?\" 'double-quoted-string)))
(if (nth 3 ppss) ;String.
(if (eq (nth 3 ppss) ?\")
'double-quoted-string 'string)
(pcase (nth 7 ppss)
- (`2 'comment-single-line)
- (`1 'comment-multi-line-2)
+ (2 'comment-single-line)
+ (1 'comment-multi-line-2)
(_ 'comment-multi-line-1))))))))
(defun opascal-literal-start-pattern (literal-kind)
@@ -1519,7 +1519,7 @@ value of `opascal-tab-always-indents' and the current line position."
(setq dir-name (match-string 1 dir-name)
recurse t))
;; Ensure the trailing slash is removed.
- (if (string-match "^\\(.+\\)[\\\\/]$" dir-name)
+ (if (string-match "^\\(.+\\)[\\/]$" dir-name)
(setq dir-name (match-string 1 dir-name)))
(opascal-search-directory unit dir-name recurse)))
diff --git a/lisp/progmodes/pascal.el b/lisp/progmodes/pascal.el
index 01ac96f09ae..cae514aa75b 100644
--- a/lisp/progmodes/pascal.el
+++ b/lisp/progmodes/pascal.el
@@ -117,7 +117,7 @@
(defconst pascal-beg-block-re "\\<\\(begin\\|case\\|record\\|repeat\\)\\>")
(defconst pascal-end-block-re "\\<\\(end\\|until\\)\\>")
(defconst pascal-declaration-re "\\<\\(const\\|label\\|type\\|var\\)\\>")
-(defconst pascal-progbeg-re "\\<\\program\\>")
+(defconst pascal-progbeg-re "\\<program\\>")
(defconst pascal-defun-re "\\<\\(function\\|procedure\\|program\\)\\>")
(defconst pascal-sub-block-re "\\<\\(if\\|else\\|for\\|while\\|with\\)\\>")
(defconst pascal-noindent-re "\\<\\(begin\\|end\\|until\\|else\\)\\>")
@@ -1403,12 +1403,8 @@ The default is a name found in the buffer around point."
map)
"Keymap used in Pascal Outline mode.")
-(define-obsolete-function-alias 'pascal-outline 'pascal-outline-mode "22.1")
(define-minor-mode pascal-outline-mode
"Outline-line minor mode for Pascal mode.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
When enabled, portions of the text being edited may be made
invisible.\\<pascal-outline-map>
diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el
index 6cc2ee95d04..7cbd30a0d1d 100644
--- a/lisp/progmodes/perl-mode.el
+++ b/lisp/progmodes/perl-mode.el
@@ -87,6 +87,8 @@
;;; Code:
+(eval-when-compile (require 'cl-lib))
+
(defgroup perl nil
"Major mode for editing Perl code."
:link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)
@@ -135,7 +137,7 @@
'(;; Functions
(nil "^[ \t]*sub\\s-+\\([-[:alnum:]+_:]+\\)" 1)
;;Variables
- ("Variables" "^\\(?:my\\|our\\)\\s-+\\([$@%][-[:alnum:]+_:]+\\)\\s-*=" 1)
+ ("Variables" "^[ \t]*\\(?:anon\\|argument\\|has\\|local\\|my\\|our\\|state\\|supersede\\)\\s-+\\([$@%][-[:alnum:]+_:]+\\)\\s-*=" 1)
("Packages" "^[ \t]*package\\s-+\\([-[:alnum:]+_:]+\\);" 1)
("Doc sections" "^=head[0-9][ \t]+\\(.*\\)" 1))
"Imenu generic expression for Perl mode. See `imenu-generic-expression'.")
@@ -165,7 +167,7 @@
;; Fontify function and package names in declarations.
("\\<\\(package\\|sub\\)\\>[ \t]*\\(\\sw+\\)?"
(1 font-lock-keyword-face) (2 font-lock-function-name-face nil t))
- ("\\<\\(import\\|no\\|require\\|use\\)\\>[ \t]*\\(\\sw+\\)?"
+ ("\\(^\\|[^$@%&\\]\\)\\<\\(import\\|no\\|require\\|use\\)\\>[ \t]*\\(\\sw+\\)?"
(1 font-lock-keyword-face) (2 font-lock-constant-face nil t)))
"Subdued level highlighting for Perl mode.")
@@ -179,8 +181,9 @@
"BEGIN" "END" "return" "exec" "eval") t)
"\\>")
;;
- ;; Fontify local and my keywords as types.
- ("\\<\\(local\\|my\\)\\>" . font-lock-type-face)
+ ;; Fontify declarators and prefixes as types.
+ ("\\<\\(anon\\|argument\\|has\\|local\\|my\\|our\\|state\\|supersede\\)\\>" . font-lock-type-face) ; declarators
+ ("\\<\\(let\\|temp\\)\\>" . font-lock-type-face) ; prefixes
;;
;; Fontify function, variable and file name references.
("&\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-function-name-face)
@@ -320,8 +323,8 @@
(cons (car (string-to-syntax "< c"))
;; Remember the names of heredocs found on this line.
(cons (cons (pcase (aref name 0)
- (`?\\ (substring name 1))
- ((or `?\" `?\' `?\`) (substring name 1 -1))
+ (?\\ (substring name 1))
+ ((or ?\" ?\' ?\`) (substring name 1 -1))
(_ name))
indented)
(cdr st)))))))
@@ -744,8 +747,6 @@ Turning on Perl mode runs the normal hook `perl-mode-hook'."
0 ;Existing comment at bol stays there.
comment-column))
-(define-obsolete-function-alias 'electric-perl-terminator
- 'perl-electric-terminator "22.1")
(defun perl-electric-noindent-p (_char)
;; To reproduce the old behavior, ;, {, }, and : are made electric, but
;; we only want them to be electric at EOL.
diff --git a/lisp/progmodes/prog-mode.el b/lisp/progmodes/prog-mode.el
index edb32a2d5a4..2b057356b10 100644
--- a/lisp/progmodes/prog-mode.el
+++ b/lisp/progmodes/prog-mode.el
@@ -196,9 +196,6 @@ on the symbol."
;;;###autoload
(define-minor-mode prettify-symbols-mode
"Toggle Prettify Symbols mode.
-With a prefix argument ARG, enable Prettify Symbols mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
When Prettify Symbols mode and font-locking are enabled, symbols are
prettified (displayed as composed characters) according to the rules
diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index d4c13e879bd..dabc4ab6b45 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -35,7 +35,7 @@
;; Infrastructure:
;;
;; Function `project-current', to determine the current project
-;; instance, and 3 (at the moment) generic functions that act on it.
+;; instance, and 5 (at the moment) generic functions that act on it.
;; This list is to be extended in future versions.
;;
;; Utils:
@@ -45,8 +45,9 @@
;;
;; Commands:
;;
-;; `project-find-regexp' and `project-or-external-find-regexp' use the
-;; current API, and thus will work in any project that has an adapter.
+;; `project-find-file', `project-find-regexp' and
+;; `project-or-external-find-regexp' use the current API, and thus
+;; will work in any project that has an adapter.
;;; TODO:
@@ -54,9 +55,6 @@
;; filenotify.el (if supported) to invalidate. And avoiding caching
;; if it's not available (manual cache invalidation is not nice).
;;
-;; * Allow the backend to override the file-listing logic? Maybe also
-;; to delegate file name completion to an external tool.
-;;
;; * Build tool related functionality. Start with a `project-build'
;; command, which should provide completions on tasks to run, and
;; maybe allow entering some additional arguments. This might
@@ -148,6 +146,8 @@ Patterns can match both regular files and directories.
To root an entry, start it with `./'. To match directories only,
end it with `/'. DIR must be one of `project-roots' or
`project-external-roots'."
+ ;; TODO: Document and support regexp ignores as used by Hg.
+ ;; TODO: Support whitelist entries.
(require 'grep)
(defvar grep-find-ignored-files)
(nconc
@@ -162,33 +162,64 @@ end it with `/'. DIR must be one of `project-roots' or
DIRS is a list of absolute directories; it should be some
subset of the project roots and external roots.
-The default implementation uses `find-program'. PROJECT is used
-to find the list of ignores for each directory."
- ;; FIXME: Uniquely abbreviate the roots?
- (require 'xref)
- (let ((all-files
- (cl-mapcan
- (lambda (dir)
- (let ((command
- (format "%s %s %s -type f -print0"
- find-program
- (shell-quote-argument
- (expand-file-name dir))
- (xref--find-ignores-arguments
- (project-ignores project dir)
- (expand-file-name dir)))))
- (split-string (shell-command-to-string command) "\0" t)))
- dirs)))
+The default implementation delegates to `project-files'."
+ (let ((all-files (project-files project dirs)))
(lambda (string pred action)
(cond
((eq action 'metadata)
- '(metadata . ((category . project-file))))
+ '(metadata . ((category . project-file))))
(t
- (complete-with-action action all-files string pred))))))
+ (complete-with-action action all-files string pred))))))
(cl-defmethod project-roots ((project (head transient)))
(list (cdr project)))
+(cl-defgeneric project-files (project &optional dirs)
+ "Return a list of files in directories DIRS in PROJECT.
+DIRS is a list of absolute directories; it should be some
+subset of the project roots and external roots.
+
+The default implementation uses `find-program'. PROJECT is used
+to find the list of ignores for each directory."
+ (require 'xref)
+ (cl-mapcan
+ (lambda (dir)
+ (project--files-in-directory dir
+ (project--dir-ignores project dir)))
+ (or dirs (project-roots project))))
+
+(defun project--files-in-directory (dir ignores &optional files)
+ (require 'find-dired)
+ (defvar find-name-arg)
+ (let ((default-directory dir)
+ (command (format "%s %s %s -type f %s -print0"
+ find-program
+ (file-local-name dir)
+ (xref--find-ignores-arguments
+ ignores
+ (expand-file-name dir))
+ (if files
+ (concat (shell-quote-argument "(")
+ " " find-name-arg " "
+ (mapconcat
+ #'shell-quote-argument
+ (split-string files)
+ (concat " -o " find-name-arg " "))
+ " "
+ (shell-quote-argument ")"))"")
+ )))
+ (project--remote-file-names
+ (split-string (shell-command-to-string command) "\0" t))))
+
+(defun project--remote-file-names (local-files)
+ "Return LOCAL-FILES as if they were on the system of `default-directory'."
+ (let ((remote-id (file-remote-p default-directory)))
+ (if (not remote-id)
+ local-files
+ (mapcar (lambda (file)
+ (concat remote-id file))
+ local-files))))
+
(defgroup project-vc nil
"Project implementation using the VC package."
:version "25.1"
@@ -264,7 +295,10 @@ backend implementation of `project-external-roots'.")
entry))
(vc-call-backend backend 'ignore-completion-table root)))
(project--value-in-dir 'project-vc-ignores root)
- (cl-call-next-method))))
+ (mapcar
+ (lambda (dir)
+ (concat dir "/"))
+ vc-directory-exclusion-list))))
(defun project-combine-directories (&rest lists-of-dirs)
"Return a sorted and culled list of directory names.
@@ -314,11 +348,27 @@ triggers completion when entering a pattern, including it
requires quoting, e.g. `\\[quoted-insert]<space>'."
(interactive (list (project--read-regexp)))
(let* ((pr (project-current t))
- (dirs (if current-prefix-arg
- (list (read-directory-name "Base directory: "
- nil default-directory t))
- (project-roots pr))))
- (project--find-regexp-in dirs regexp pr)))
+ (files
+ (if (not current-prefix-arg)
+ (project-files pr (project-roots pr))
+ (let ((dir (read-directory-name "Base directory: "
+ nil default-directory t)))
+ (project--files-in-directory dir
+ (project--dir-ignores pr dir)
+ (grep-read-files regexp))))))
+ (project--find-regexp-in-files regexp files)))
+
+(defun project--dir-ignores (project dir)
+ (let* ((roots (project-roots project))
+ (root (cl-find dir roots :test #'file-in-directory-p)))
+ (if (not root)
+ (project-ignores nil nil) ;The defaults.
+ (let ((ignores (project-ignores project root)))
+ (if (file-equal-p root dir)
+ ignores
+ ;; FIXME: Update the "rooted" ignores to relate to DIR instead.
+ (cl-delete-if (lambda (str) (string-prefix-p "./" str))
+ ignores))))))
;;;###autoload
(defun project-or-external-find-regexp (regexp)
@@ -327,29 +377,76 @@ With \\[universal-argument] prefix, you can specify the file name
pattern to search for."
(interactive (list (project--read-regexp)))
(let* ((pr (project-current t))
- (dirs (append
- (project-roots pr)
- (project-external-roots pr))))
- (project--find-regexp-in dirs regexp pr)))
+ (files
+ (project-files pr (append
+ (project-roots pr)
+ (project-external-roots pr)))))
+ (project--find-regexp-in-files regexp files)))
+
+(defun project--find-regexp-in-files (regexp files)
+ (pcase-let*
+ ((output (get-buffer-create " *project grep output*"))
+ (`(,grep-re ,file-group ,line-group . ,_) (car grep-regexp-alist))
+ (status nil)
+ (hits nil)
+ (xrefs nil)
+ (command (format "xargs -0 grep %s -nHE %s"
+ (if (and case-fold-search
+ (isearch-no-upper-case-p regexp t))
+ "-i"
+ "")
+ (shell-quote-argument (xref--regexp-to-extended regexp)))))
+ (with-current-buffer output
+ (erase-buffer)
+ (with-temp-buffer
+ (insert (mapconcat #'identity files "\0"))
+ (setq status
+ (project--process-file-region (point-min)
+ (point-max)
+ shell-file-name
+ output
+ nil
+ shell-command-switch
+ command)))
+ (goto-char (point-min))
+ (when (and (/= (point-min) (point-max))
+ (not (looking-at grep-re))
+ ;; TODO: Show these matches as well somehow?
+ (not (looking-at "Binary file .* matches")))
+ (user-error "Search failed with status %d: %s" status
+ (buffer-substring (point-min) (line-end-position))))
+ (while (re-search-forward grep-re nil t)
+ (push (list (string-to-number (match-string line-group))
+ (match-string file-group)
+ (buffer-substring-no-properties (point) (line-end-position)))
+ hits)))
+ (setq xrefs (xref--convert-hits (nreverse hits) regexp))
+ (unless xrefs
+ (user-error "No matches for: %s" regexp))
+ (xref--show-xrefs xrefs nil)))
+
+(defun project--process-file-region (start end program
+ &optional buffer display
+ &rest args)
+ ;; FIXME: This branching shouldn't be necessary, but
+ ;; call-process-region *is* measurably faster, even for a program
+ ;; doing some actual work (for a period of time). Even though
+ ;; call-process-region also creates a temp file internally
+ ;; (http://lists.gnu.org/archive/html/emacs-devel/2019-01/msg00211.html).
+ (if (not (file-remote-p default-directory))
+ (apply #'call-process-region
+ start end program nil buffer display args)
+ (let ((infile (make-temp-file "ppfr")))
+ (unwind-protect
+ (progn
+ (write-region start end infile nil 'silent)
+ (apply #'process-file program infile buffer display args))
+ (delete-file infile)))))
(defun project--read-regexp ()
(let ((id (xref-backend-identifier-at-point (xref-find-backend))))
(read-regexp "Find regexp" (and id (regexp-quote id)))))
-(defun project--find-regexp-in (dirs regexp project)
- (require 'grep)
- (let* ((files (if current-prefix-arg
- (grep-read-files regexp)
- "*"))
- (xrefs (cl-mapcan
- (lambda (dir)
- (xref-collect-matches regexp files dir
- (project-ignores project dir)))
- dirs)))
- (unless xrefs
- (user-error "No matches for: %s" regexp))
- (xref--show-xrefs xrefs nil)))
-
;;;###autoload
(defun project-find-file ()
"Visit a file (with completion) in the current project's roots.
@@ -389,18 +486,63 @@ recognized."
;; removing it when it has no matches. Neither seems natural
;; enough. Removal is confusing; early expansion makes the prompt
;; too long.
- (let* ((new-prompt (if default
+ (let* ((common-parent-directory
+ (let ((common-prefix (try-completion "" collection)))
+ (if (> (length common-prefix) 0)
+ (file-name-directory common-prefix))))
+ (cpd-length (length common-parent-directory))
+ (prompt (if (zerop cpd-length)
+ prompt
+ (concat prompt (format " in %s" common-parent-directory))))
+ ;; XXX: This requires collection to be "flat" as well.
+ (substrings (mapcar (lambda (s) (substring s cpd-length))
+ (all-completions "" collection)))
+ (new-collection
+ (lambda (string pred action)
+ (cond
+ ((eq action 'metadata)
+ (if (functionp collection) (funcall collection nil nil 'metadata)))
+ (t
+ (complete-with-action action substrings string pred)))))
+ (new-prompt (if default
(format "%s (default %s): " prompt default)
(format "%s: " prompt)))
(res (completing-read new-prompt
- collection predicate t
- nil hist default inherit-input-method)))
- (if (and (equal res default)
- (not (test-completion res collection predicate)))
- (completing-read (format "%s: " prompt)
- collection predicate t res hist nil
- inherit-input-method)
- res)))
+ new-collection predicate t
+ nil ;; initial-input
+ hist default inherit-input-method)))
+ (when (and (equal res default)
+ (not (test-completion res collection predicate)))
+ (setq res
+ (completing-read (format "%s: " prompt)
+ new-collection predicate t res hist nil
+ inherit-input-method)))
+ (concat common-parent-directory res)))
+
+(declare-function fileloop-continue "fileloop" ())
+
+;;;###autoload
+(defun project-search (regexp)
+ "Search for REGEXP in all the files of the project.
+Stops when a match is found.
+To continue searching for next match, use command \\[fileloop-continue]."
+ (interactive "sSearch (regexp): ")
+ (fileloop-initialize-search
+ regexp (project-files (project-current t)) 'default)
+ (fileloop-continue))
+
+;;;###autoload
+(defun project-query-replace-regexp (from to)
+ "Search for REGEXP in all the files of the project.
+Stops when a match is found.
+To continue searching for next match, use command \\[fileloop-continue]."
+ (interactive
+ (pcase-let ((`(,from ,to)
+ (query-replace-read-args "Query replace (regexp)" t t)))
+ (list from to)))
+ (fileloop-initialize-replace
+ from to (project-files (project-current t)) 'default)
+ (fileloop-continue))
(provide 'project)
;;; project.el ends here
diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el
index 8f75344912c..296a7ac3c95 100644
--- a/lisp/progmodes/prolog.el
+++ b/lisp/progmodes/prolog.el
@@ -942,21 +942,21 @@ This is really kludgy, and unneeded (i.e. obsolete) in Emacs>=24."
(defun prolog-smie-rules (kind token)
(pcase (cons kind token)
- (`(:elem . basic) prolog-indent-width)
+ ('(:elem . basic) prolog-indent-width)
;; The list of arguments can never be on a separate line!
(`(:list-intro . ,_) t)
;; When we don't know how to indent an empty line, assume the most
;; likely token will be ";".
- (`(:elem . empty-line-token) ";")
- (`(:after . ".") '(column . 0)) ;; To work around smie-closer-alist.
+ ('(:elem . empty-line-token) ";")
+ ('(:after . ".") '(column . 0)) ;; To work around smie-closer-alist.
;; Allow indentation of if-then-else as:
;; ( test
;; -> thenrule
;; ; elserule
;; )
- (`(:before . ,(or `"->" `";"))
+ (`(:before . ,(or "->" ";"))
(and (smie-rule-bolp) (smie-rule-parent-p "(") (smie-rule-parent 0)))
- (`(:after . ,(or `"->" `"*->"))
+ (`(:after . ,(or "->" "*->"))
;; We distinguish
;;
;; (a ->
@@ -977,7 +977,7 @@ This is really kludgy, and unneeded (i.e. obsolete) in Emacs>=24."
(smie-indent-backward-token)
(smie-rule-bolp))))
prolog-indent-width))
- (`(:after . ";")
+ ('(:after . ";")
;; Align with same-line comment as in:
;; ; %% Toto
;; foo
@@ -989,7 +989,7 @@ This is really kludgy, and unneeded (i.e. obsolete) in Emacs>=24."
;; Only do it for small offsets, since the comment may actually be
;; an "end-of-line" comment at comment-column!
(if (<= offset prolog-indent-width) offset))))
- (`(:after . ",")
+ ('(:after . ",")
;; Special indent for:
;; foopredicate(x) :- !,
;; toto.
@@ -998,7 +998,7 @@ This is really kludgy, and unneeded (i.e. obsolete) in Emacs>=24."
(smie-indent-backward-token) ;Skip !
(equal ":-" (car (smie-indent-backward-token))))
(smie-rule-parent prolog-indent-width)))
- (`(:after . ":-")
+ ('(:after . ":-")
(if (bolp)
(save-excursion
(smie-indent-forward-token)
@@ -1007,7 +1007,7 @@ This is really kludgy, and unneeded (i.e. obsolete) in Emacs>=24."
prolog-indent-width
(min prolog-indent-width (current-column))))
prolog-indent-width))
- (`(:after . "-->") prolog-indent-width)))
+ ('(:after . "-->") prolog-indent-width)))
;;-------------------------------------------------------------------
@@ -2826,7 +2826,7 @@ STRING should be given if the last search was by `string-match' on STRING."
(progn
(if (and (eq prolog-system 'mercury)
(looking-at
- (format ":-[ \t]*\\(pred\\|mode\\)[ \t]+\\(%s+\\)"
+ (format ":-[ \t]*\\(pred\\|mode\\)[ \t]+\\(\\(?:%s\\)+\\)"
prolog-atom-regexp)))
;; Skip predicate declarations
(progn
@@ -2950,7 +2950,7 @@ objects (relevant only if `prolog-system' is set to `sicstus')."
(predname
(if (looking-at prolog-atom-char-regexp)
(progn
- (skip-chars-forward "^ (\\.")
+ (skip-chars-forward "^ (.")
(buffer-substring op (point)))
""))
(arity 0))
@@ -3247,11 +3247,11 @@ the following comma and whitespace, if any."
(defun prolog-post-self-insert ()
(pcase last-command-event
- (`?_ (prolog-electric--underscore))
- (`?- (prolog-electric--dash))
- (`?: (prolog-electric--colon))
- ((or `?\( `?\; `?>) (prolog-electric--if-then-else))
- (`?. (prolog-electric--dot))))
+ (?_ (prolog-electric--underscore))
+ (?- (prolog-electric--dash))
+ (?: (prolog-electric--colon))
+ ((or ?\( ?\; ?>) (prolog-electric--if-then-else))
+ (?. (prolog-electric--dot))))
(defun prolog-find-term (functor arity &optional prefix)
"Go to the position at the start of the next occurrence of a term.
diff --git a/lisp/progmodes/ps-mode.el b/lisp/progmodes/ps-mode.el
index 381286ccb40..d9406278e97 100644
--- a/lisp/progmodes/ps-mode.el
+++ b/lisp/progmodes/ps-mode.el
@@ -458,9 +458,9 @@ If nil, use `temporary-file-directory'."
(defun ps-mode-smie-rules (kind token)
(pcase (cons kind token)
- (`(:after . "<") (when (smie-rule-next-p "<") 0))
- (`(:elem . basic) ps-mode-tab)
- (`(:close-all . ">") t)
+ ('(:after . "<") (when (smie-rule-next-p "<") 0))
+ ('(:elem . basic) ps-mode-tab)
+ ('(:close-all . ">") t)
(`(:list-intro . ,_) t)))
;;;###autoload
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index 27d31abaf5b..b05f9a33e90 100644
--- a/lisp/progmodes/python.el
+++ b/lisp/progmodes/python.el
@@ -4,7 +4,7 @@
;; Author: Fabián E. Gallina <fgallina@gnu.org>
;; URL: https://github.com/fgallina/python.el
-;; Version: 0.25.2
+;; Version: 0.26.1
;; Package-Requires: ((emacs "24.1") (cl-lib "1.0"))
;; Maintainer: emacs-devel@gnu.org
;; Created: Jul 2010
@@ -287,9 +287,20 @@
;;; 24.x Compat
-(unless (fboundp 'prog-first-column)
- (defun prog-first-column ()
- 0))
+(eval-and-compile
+ (unless (fboundp 'prog-first-column)
+ (defun prog-first-column ()
+ 0))
+ (unless (fboundp 'file-local-name)
+ (defun file-local-name (file)
+ "Return the local name component of FILE.
+It returns a file name which can be used directly as argument of
+`process-file', `start-file-process', or `shell-command'."
+ (or (file-remote-p file 'localname) file))))
+
+;; In Emacs 24.3 and earlier, `define-derived-mode' does not define
+;; the hook variable, it only puts documentation on the symbol.
+(defvar inferior-python-mode-hook)
;;; Bindings
@@ -331,7 +342,7 @@
(substitute-key-definition 'complete-symbol 'completion-at-point
map global-map)
(easy-menu-define python-menu map "Python Mode menu"
- `("Python"
+ '("Python"
:help "Python-specific Features"
["Shift region left" python-indent-shift-left :active mark-active
:help "Shift region left by a single indentation step"]
@@ -427,7 +438,7 @@
(* ?\\ ?\\) (any ?\' ?\")))
(* ?\\ ?\\)
;; Match single or triple quotes of any kind.
- (group (or "\"" "\"\"\"" "'" "'''")))))
+ (group (or "\"\"\"" "\"" "'''" "'")))))
(coding-cookie . ,(rx line-start ?# (* space)
(or
;; # coding=<encoding name>
@@ -458,13 +469,13 @@ This variant of `rx' supports common Python named REGEXPS."
(eval-and-compile
(defun python-syntax--context-compiler-macro (form type &optional syntax-ppss)
(pcase type
- (`'comment
+ (''comment
`(let ((ppss (or ,syntax-ppss (syntax-ppss))))
(and (nth 4 ppss) (nth 8 ppss))))
- (`'string
+ (''string
`(let ((ppss (or ,syntax-ppss (syntax-ppss))))
(and (nth 3 ppss) (nth 8 ppss))))
- (`'paren
+ (''paren
`(nth 1 (or ,syntax-ppss (syntax-ppss))))
(_ form))))
@@ -475,9 +486,9 @@ character address of the specified TYPE."
(declare (compiler-macro python-syntax--context-compiler-macro))
(let ((ppss (or syntax-ppss (syntax-ppss))))
(pcase type
- (`comment (and (nth 4 ppss) (nth 8 ppss)))
- (`string (and (nth 3 ppss) (nth 8 ppss)))
- (`paren (nth 1 ppss))
+ ('comment (and (nth 4 ppss) (nth 8 ppss)))
+ ('string (and (nth 3 ppss) (nth 8 ppss)))
+ ('paren (nth 1 ppss))
(_ nil))))
(defun python-syntax-context-type (&optional syntax-ppss)
@@ -515,9 +526,19 @@ The type returned can be `comment', `string' or `paren'."
font-lock-string-face)
font-lock-comment-face))
-(defvar python-font-lock-keywords
- ;; Keywords
- `(,(rx symbol-start
+(defvar python-font-lock-keywords-level-1
+ `((,(rx symbol-start "def" (1+ space) (group (1+ (or word ?_))))
+ (1 font-lock-function-name-face))
+ (,(rx symbol-start "class" (1+ space) (group (1+ (or word ?_))))
+ (1 font-lock-type-face)))
+ "Font lock keywords to use in python-mode for level 1 decoration.
+
+This is the minimum decoration level, including function and
+class declarations.")
+
+(defvar python-font-lock-keywords-level-2
+ `(,@python-font-lock-keywords-level-1
+ ,(rx symbol-start
(or
"and" "del" "from" "not" "while" "as" "elif" "global" "or" "with"
"assert" "else" "if" "pass" "yield" "break" "except" "import" "class"
@@ -537,12 +558,35 @@ The type returned can be `comment', `string' or `paren'."
;; Extra:
"self")
symbol-end)
- ;; functions
- (,(rx symbol-start "def" (1+ space) (group (1+ (or word ?_))))
- (1 font-lock-function-name-face))
- ;; classes
- (,(rx symbol-start "class" (1+ space) (group (1+ (or word ?_))))
- (1 font-lock-type-face))
+ ;; Builtins
+ (,(rx symbol-start
+ (or
+ "abs" "all" "any" "bin" "bool" "callable" "chr" "classmethod"
+ "compile" "complex" "delattr" "dict" "dir" "divmod" "enumerate"
+ "eval" "filter" "float" "format" "frozenset" "getattr" "globals"
+ "hasattr" "hash" "help" "hex" "id" "input" "int" "isinstance"
+ "issubclass" "iter" "len" "list" "locals" "map" "max" "memoryview"
+ "min" "next" "object" "oct" "open" "ord" "pow" "print" "property"
+ "range" "repr" "reversed" "round" "set" "setattr" "slice" "sorted"
+ "staticmethod" "str" "sum" "super" "tuple" "type" "vars" "zip"
+ "__import__"
+ ;; Python 2:
+ "basestring" "cmp" "execfile" "file" "long" "raw_input" "reduce"
+ "reload" "unichr" "unicode" "xrange" "apply" "buffer" "coerce"
+ "intern"
+ ;; Python 3:
+ "ascii" "breakpoint" "bytearray" "bytes" "exec"
+ ;; Extra:
+ "__all__" "__doc__" "__name__" "__package__")
+ symbol-end) . font-lock-builtin-face))
+ "Font lock keywords to use in python-mode for level 2 decoration.
+
+This is the medium decoration level, including everything in
+`python-font-lock-keywords-level-1', as well as keywords and
+builtins.")
+
+(defvar python-font-lock-keywords-maximum-decoration
+ `(,@python-font-lock-keywords-level-2
;; Constants
(,(rx symbol-start
(or
@@ -585,27 +629,6 @@ The type returned can be `comment', `string' or `paren'."
"VMSError" "WindowsError"
)
symbol-end) . font-lock-type-face)
- ;; Builtins
- (,(rx symbol-start
- (or
- "abs" "all" "any" "bin" "bool" "callable" "chr" "classmethod"
- "compile" "complex" "delattr" "dict" "dir" "divmod" "enumerate"
- "eval" "filter" "float" "format" "frozenset" "getattr" "globals"
- "hasattr" "hash" "help" "hex" "id" "input" "int" "isinstance"
- "issubclass" "iter" "len" "list" "locals" "map" "max" "memoryview"
- "min" "next" "object" "oct" "open" "ord" "pow" "print" "property"
- "range" "repr" "reversed" "round" "set" "setattr" "slice" "sorted"
- "staticmethod" "str" "sum" "super" "tuple" "type" "vars" "zip"
- "__import__"
- ;; Python 2:
- "basestring" "cmp" "execfile" "file" "long" "raw_input" "reduce"
- "reload" "unichr" "unicode" "xrange" "apply" "buffer" "coerce"
- "intern"
- ;; Python 3:
- "ascii" "bytearray" "bytes" "exec"
- ;; Extra:
- "__all__" "__doc__" "__name__" "__package__")
- symbol-end) . font-lock-builtin-face)
;; assignments
;; support for a = b = c = 5
(,(lambda (limit)
@@ -629,22 +652,41 @@ The type returned can be `comment', `string' or `paren'."
(goto-char (match-end 1))
(python-syntax-context 'paren)))
res))
- (1 font-lock-variable-name-face nil nil))))
+ (1 font-lock-variable-name-face nil nil)))
+ "Font lock keywords to use in python-mode for maximum decoration.
+
+This decoration level includes everything in
+`python-font-lock-keywords-level-2', as well as constants,
+decorators, exceptions, and assignments.")
+
+(defvar python-font-lock-keywords
+ '(python-font-lock-keywords-level-1 ; When `font-lock-maximum-decoration' is nil.
+ python-font-lock-keywords-level-1 ; When `font-lock-maximum-decoration' is 1.
+ python-font-lock-keywords-level-2 ; When `font-lock-maximum-decoration' is 2.
+ python-font-lock-keywords-maximum-decoration ; When `font-lock-maximum-decoration'
+ ; is more than 1, or t (which it is,
+ ; by default).
+ )
+ "List of font lock keyword specifications to use in python-mode.
+
+Which one will be chosen depends on the value of
+`font-lock-maximum-decoration'.")
+
(defconst python-syntax-propertize-function
(syntax-propertize-rules
- ((python-rx string-delimiter)
+ ((rx (or "\"\"\"" "'''"))
(0 (ignore (python-syntax-stringify))))))
+(define-obsolete-variable-alias 'python--prettify-symbols-alist
+ 'python-prettify-symbols-alist "26.1")
+
(defvar python-prettify-symbols-alist
'(("lambda" . ?λ)
("and" . ?∧)
("or" . ?∨))
"Value for `prettify-symbols-alist' in `python-mode'.")
-(define-obsolete-variable-alias 'python--prettify-symbols-alist
- 'python-prettify-symbols-alist "26.1")
-
(defsubst python-syntax-count-quotes (quote-char &optional point limit)
"Count number of quotes around point (max is 3).
QUOTE-CHAR is the quote char to count. Optional argument POINT is
@@ -659,35 +701,27 @@ is used to limit the scan."
(defun python-syntax-stringify ()
"Put `syntax-table' property correctly on single/triple quotes."
- (let* ((num-quotes (length (match-string-no-properties 1)))
- (ppss (prog2
- (backward-char num-quotes)
- (syntax-ppss)
- (forward-char num-quotes)))
- (string-start (and (not (nth 4 ppss)) (nth 8 ppss)))
- (quote-starting-pos (- (point) num-quotes))
- (quote-ending-pos (point))
- (num-closing-quotes
- (and string-start
- (python-syntax-count-quotes
- (char-before) string-start quote-starting-pos))))
- (cond ((and string-start (= num-closing-quotes 0))
- ;; This set of quotes doesn't match the string starting
- ;; kind. Do nothing.
+ (let* ((ppss (save-excursion (backward-char 3) (syntax-ppss)))
+ (string-start (and (eq t (nth 3 ppss)) (nth 8 ppss)))
+ (quote-starting-pos (- (point) 3))
+ (quote-ending-pos (point)))
+ (cond ((or (nth 4 ppss) ;Inside a comment
+ (and string-start
+ ;; Inside of a string quoted with different triple quotes.
+ (not (eql (char-after string-start)
+ (char-after quote-starting-pos)))))
+ ;; Do nothing.
nil)
- ((not string-start)
+ ((nth 5 ppss)
+ ;; The first quote is escaped, so it's not part of a triple quote!
+ (goto-char (1+ quote-starting-pos)))
+ ((null string-start)
;; This set of quotes delimit the start of a string.
(put-text-property quote-starting-pos (1+ quote-starting-pos)
'syntax-table (string-to-syntax "|")))
- ((= num-quotes num-closing-quotes)
+ (t
;; This set of quotes delimit the end of a string.
(put-text-property (1- quote-ending-pos) quote-ending-pos
- 'syntax-table (string-to-syntax "|")))
- ((> num-quotes num-closing-quotes)
- ;; This may only happen whenever a triple quote is closing
- ;; a single quoted string. Add string delimiter syntax to
- ;; all three quotes.
- (put-text-property quote-starting-pos quote-ending-pos
'syntax-table (string-to-syntax "|"))))))
(defvar python-mode-syntax-table
@@ -1292,16 +1326,17 @@ the line will be re-indented automatically if needed."
(not (equal ?: (char-before (1- (point)))))
(not (python-syntax-comment-or-string-p)))
;; Just re-indent dedenters
- (let ((dedenter-pos (python-info-dedenter-statement-p))
- (current-pos (point)))
+ (let ((dedenter-pos (python-info-dedenter-statement-p)))
(when dedenter-pos
- (save-excursion
- (goto-char dedenter-pos)
- (python-indent-line)
- (unless (= (line-number-at-pos dedenter-pos)
- (line-number-at-pos current-pos))
- ;; Reindent region if this is a multiline statement
- (python-indent-region dedenter-pos current-pos)))))))))
+ (let ((start (copy-marker dedenter-pos))
+ (end (point-marker)))
+ (save-excursion
+ (goto-char start)
+ (python-indent-line)
+ (unless (= (line-number-at-pos start)
+ (line-number-at-pos end))
+ ;; Reindent region if this is a multiline statement
+ (python-indent-region start end))))))))))
;;; Mark
@@ -1474,7 +1509,7 @@ nested definitions."
(defun python-nav-beginning-of-statement ()
"Move to start of current statement."
(interactive "^")
- (back-to-indentation)
+ (forward-line 0)
(let* ((ppss (syntax-ppss))
(context-point
(or
@@ -1489,6 +1524,7 @@ nested definitions."
(python-info-line-ends-backslash-p))
(forward-line -1)
(python-nav-beginning-of-statement))))
+ (back-to-indentation)
(point-marker))
(defun python-nav-end-of-statement (&optional noend)
@@ -1506,9 +1542,10 @@ of the statement."
;; are somehow out of whack. This has been
;; observed when using `syntax-ppss' during
;; narrowing.
- (cl-assert (> string-start last-string-end)
+ (cl-assert (>= string-start last-string-end)
:show-args
- "Overlapping strings detected")
+ "\
+Overlapping strings detected (start=%d, last-end=%d)")
(goto-char string-start)
(if (python-syntax-context 'paren)
;; Ended up inside a paren, roll again.
@@ -2147,7 +2184,7 @@ of `exec-path'."
(defun python-shell-tramp-refresh-process-environment (vec env)
"Update VEC's process environment with ENV."
;; Stolen from `tramp-open-connection-setup-interactive-shell'.
- (let ((env (append (when (fboundp #'tramp-get-remote-locale)
+ (let ((env (append (when (fboundp 'tramp-get-remote-locale)
;; Emacs<24.4 compat.
(list (tramp-get-remote-locale vec)))
(copy-sequence env)))
@@ -2829,10 +2866,12 @@ process buffer for a list of commands.)"
(y-or-n-p "Make dedicated process? ")
(= (prefix-numeric-value current-prefix-arg) 4))
(list (python-shell-calculate-command) nil t)))
- (get-buffer-process
- (python-shell-make-comint
- (or cmd (python-shell-calculate-command))
- (python-shell-get-process-name dedicated) show)))
+ (let ((buffer
+ (python-shell-make-comint
+ (or cmd (python-shell-calculate-command))
+ (python-shell-get-process-name dedicated) show)))
+ (pop-to-buffer buffer)
+ (get-buffer-process buffer)))
(defun run-python-internal ()
"Run an inferior Internal Python process.
@@ -2910,11 +2949,17 @@ be asked for their values."
"Instead call `python-shell-get-process' and create one if returns nil."
"25.1")
+(define-obsolete-variable-alias
+ 'python-buffer 'python-shell-internal-buffer "24.3")
+
(defvar python-shell-internal-buffer nil
"Current internal shell buffer for the current buffer.
This is really not necessary at all for the code to work but it's
there for compatibility with CEDET.")
+(define-obsolete-variable-alias
+ 'python-preoutput-result 'python-shell-internal-last-output "24.3")
+
(defvar python-shell-internal-last-output nil
"Last output captured by the internal shell.
This is really not necessary at all for the code to work but it's
@@ -2930,12 +2975,6 @@ there for compatibility with CEDET.")
(define-obsolete-function-alias
'python-proc 'python-shell-internal-get-or-create-process "24.3")
-(define-obsolete-variable-alias
- 'python-buffer 'python-shell-internal-buffer "24.3")
-
-(define-obsolete-variable-alias
- 'python-preoutput-result 'python-shell-internal-last-output "24.3")
-
(defun python-shell--save-temp-file (string)
(let* ((temporary-file-directory
(if (file-remote-p default-directory)
@@ -3150,9 +3189,12 @@ t when called interactively."
(beginning-of-line 1))
(> (current-indentation) 0)))
(when (not arg)
- (while (and (forward-line -1)
- (looking-at (python-rx decorator))))
- (forward-line 1))
+ (while (and
+ (eq (forward-line -1) 0)
+ (if (looking-at (python-rx decorator))
+ t
+ (forward-line 1)
+ nil))))
(point-marker))
(progn
(or (python-nav-end-of-defun)
@@ -3183,10 +3225,10 @@ t when called interactively."
(insert-file-contents
(or temp-file-name file-name))
(python-info-encoding)))
- (file-name (expand-file-name (file-local-name file-name)))
+ (file-name (file-local-name (expand-file-name file-name)))
(temp-file-name (when temp-file-name
- (expand-file-name
- (file-local-name temp-file-name)))))
+ (file-local-name (expand-file-name
+ temp-file-name)))))
(python-shell-send-string
(format
(concat
@@ -3966,11 +4008,11 @@ JUSTIFY should be used (if applicable) as in `fill-paragraph'."
;; is NIL means to not add any newlines for start or end
;; of docstring. See `python-fill-docstring-style' for a
;; graphic idea of each style.
- (`django (cons 1 1))
- (`onetwo (and multi-line-p (cons 1 2)))
- (`pep-257 (and multi-line-p (cons nil 2)))
- (`pep-257-nn (and multi-line-p (cons nil 1)))
- (`symmetric (and multi-line-p (cons 1 1)))))
+ ('django (cons 1 1))
+ ('onetwo (and multi-line-p (cons 1 2)))
+ ('pep-257 (and multi-line-p (cons nil 2)))
+ ('pep-257-nn (and multi-line-p (cons nil 1)))
+ ('symmetric (and multi-line-p (cons 1 1)))))
(fill-paragraph-function))
(save-restriction
(narrow-to-region str-start-pos str-end-pos)
@@ -5191,9 +5233,10 @@ be used."
(defcustom python-flymake-msg-alist
'(("\\(^redefinition\\|.*unused.*\\|used$\\)" . :warning))
"Alist used to associate messages to their types.
-Each element should be a cons-cell (REGEXP . TYPE), where TYPE must be
-one defined in the variable `flymake-diagnostic-types-alist'.
-For example, when using `flake8' a possible configuration could be:
+Each element should be a cons-cell (REGEXP . TYPE), where TYPE
+should be a diagnostic type symbol like `:error', `:warning' or
+`:note'. For example, when using `flake8' a possible
+configuration could be:
((\"\\(^redefinition\\|.*unused.*\\|used$\\)\" . :warning)
(\"^E999\" . :error)
@@ -5202,7 +5245,7 @@ For example, when using `flake8' a possible configuration could be:
By default messages are considered errors."
:version "26.1"
:group 'python-flymake
- :type `(alist :key-type (regexp)
+ :type '(alist :key-type (regexp)
:value-type (symbol)))
(defvar-local python--flymake-proc nil)
@@ -5286,6 +5329,7 @@ REPORT-FN is Flymake's callback function."
(save-excursion (insert (make-string 2 last-command-event)))))
(defvar electric-indent-inhibit)
+(defvar prettify-symbols-alist)
;;;###autoload
(define-derived-mode python-mode prog-mode "Python"
@@ -5305,7 +5349,7 @@ REPORT-FN is Flymake's callback function."
'python-nav-forward-sexp)
(set (make-local-variable 'font-lock-defaults)
- '(python-font-lock-keywords
+ `(,python-font-lock-keywords
nil nil nil nil
(font-lock-syntactic-face-function
. python-font-lock-syntactic-face-function)))
@@ -5363,7 +5407,7 @@ REPORT-FN is Flymake's callback function."
(add-to-list
'hs-special-modes-alist
- `(python-mode
+ '(python-mode
"\\s-*\\_<\\(?:def\\|class\\)\\_>"
;; Use the empty string as end regexp so it doesn't default to
;; "\\s)". This way parens at end of defun are properly hidden.
@@ -5381,7 +5425,7 @@ REPORT-FN is Flymake's callback function."
(1+ (/ (current-indentation) python-indent-offset))))
(set (make-local-variable 'prettify-symbols-alist)
- python--prettify-symbols-alist)
+ python-prettify-symbols-alist)
(python-skeleton-add-menu-items)
diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el
index bc9979ae997..4fceda89373 100644
--- a/lisp/progmodes/ruby-mode.el
+++ b/lisp/progmodes/ruby-mode.el
@@ -39,6 +39,8 @@
;;; Code:
+(eval-when-compile (require 'cl-lib))
+
(defgroup ruby nil
"Major mode for editing Ruby code."
:prefix "ruby-"
@@ -106,7 +108,7 @@
"Regexp to match the beginning of a heredoc.")
(defconst ruby-expression-expansion-re
- "\\(?:[^\\]\\|\\=\\)\\(\\\\\\\\\\)*\\(#\\({[^}\n\\\\]*\\(\\\\.[^}\n\\\\]*\\)*}\\|\\(\\$\\|@\\|@@\\)\\(\\w\\|_\\)+\\|\\$[^a-zA-Z \n]\\)\\)"))
+ "\\(?:[^\\]\\|\\=\\)\\(\\\\\\\\\\)*\\(#\\({[^}\n\\]*\\(\\\\.[^}\n\\]*\\)*}\\|\\(\\$\\|@\\|@@\\)\\(\\w\\|_\\)+\\|\\$[^a-zA-Z \n]\\)\\)"))
(defun ruby-here-doc-end-match ()
"Return a regexp to find the end of a heredoc.
@@ -215,19 +217,16 @@ This should only be called after matching against `ruby-here-doc-beg-re'."
(defcustom ruby-indent-tabs-mode nil
"Indentation can insert tabs in Ruby mode if this is non-nil."
:type 'boolean
- :group 'ruby
:safe 'booleanp)
(defcustom ruby-indent-level 2
"Indentation of Ruby statements."
:type 'integer
- :group 'ruby
:safe 'integerp)
(defcustom ruby-comment-column (default-value 'comment-column)
"Indentation column of comments."
:type 'integer
- :group 'ruby
:safe 'integerp)
(defconst ruby-alignable-keywords '(if while unless until begin case for def)
@@ -255,8 +254,7 @@ the statement:
qux
end
-Only has effect when `ruby-use-smie' is t.
-"
+Only has effect when `ruby-use-smie' is t."
:type `(choice
(const :tag "None" nil)
(const :tag "All" t)
@@ -264,7 +262,6 @@ Only has effect when `ruby-use-smie' is t.
(choice ,@(mapcar
(lambda (kw) (list 'const kw))
ruby-alignable-keywords))))
- :group 'ruby
:safe 'listp
:version "24.4")
@@ -276,7 +273,6 @@ of its parent.
Only has effect when `ruby-use-smie' is t."
:type 'boolean
- :group 'ruby
:safe 'booleanp
:version "24.4")
@@ -285,7 +281,6 @@ Only has effect when `ruby-use-smie' is t."
Also ignores spaces after parenthesis when `space'.
Only has effect when `ruby-use-smie' is nil."
:type 'boolean
- :group 'ruby
:safe 'booleanp)
;; FIXME Woefully under documented. What is the point of the last t?.
@@ -300,14 +295,12 @@ Only has effect when `ruby-use-smie' is nil."
(cons character (choice (const nil)
(const t)))
(const t) ; why?
- )))
- :group 'ruby)
+ ))))
(defcustom ruby-deep-indent-paren-style 'space
"Default deep indent style.
Only has effect when `ruby-use-smie' is nil."
- :type '(choice (const t) (const nil) (const space))
- :group 'ruby)
+ :type '(choice (const t) (const nil) (const space)))
(defcustom ruby-encoding-map
'((us-ascii . nil) ;; Do not put coding: us-ascii
@@ -317,8 +310,7 @@ Only has effect when `ruby-use-smie' is nil."
"Alist to map encoding name from Emacs to Ruby.
Associating an encoding name with nil means it needs not be
explicitly declared in magic comment."
- :type '(repeat (cons (symbol :tag "From") (symbol :tag "To")))
- :group 'ruby)
+ :type '(repeat (cons (symbol :tag "From") (symbol :tag "To"))))
(defcustom ruby-insert-encoding-magic-comment t
"Insert a magic Ruby encoding comment upon save if this is non-nil.
@@ -335,14 +327,12 @@ even if it's not required."
(const :tag "Emacs Style" emacs)
(const :tag "Ruby Style" ruby)
(const :tag "Custom Style" custom))
- :group 'ruby
:version "24.4")
(defcustom ruby-custom-encoding-magic-comment-template "# encoding: %s"
"A custom encoding comment template.
It is used when `ruby-encoding-magic-comment-style' is set to `custom'."
:type 'string
- :group 'ruby
:version "24.4")
(defcustom ruby-use-encoding-map t
@@ -527,6 +517,9 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'."
((ruby-smie--opening-pipe-p) "opening-|")
((ruby-smie--closing-pipe-p) "closing-|")
(t tok)))
+ ((string-match "\\`[^|]+|\\'" tok)
+ (forward-char -1)
+ (substring tok 0 -1))
((and (equal tok "") (looking-at "\\\\\n"))
(goto-char (match-end 0)) (ruby-smie--forward-token))
((equal tok "do")
@@ -569,6 +562,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'."
((ruby-smie--opening-pipe-p) "opening-|")
((ruby-smie--closing-pipe-p) "closing-|")
(t tok)))
+ ((string-match-p "\\`[^|]+|\\'" tok) "closing-|")
((string-match-p "\\`|[*&]\\'" tok)
(forward-char 1)
(substring tok 1))
@@ -596,12 +590,12 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'."
(defun ruby-smie-rules (kind token)
(pcase (cons kind token)
- (`(:elem . basic) ruby-indent-level)
+ ('(:elem . basic) ruby-indent-level)
;; "foo" "bar" is the concatenation of the two strings, so the second
;; should be aligned with the first.
- (`(:elem . args) (if (looking-at "\\s\"") 0))
+ ('(:elem . args) (if (looking-at "\\s\"") 0))
;; (`(:after . ",") (smie-rule-separator kind))
- (`(:before . ";")
+ ('(:before . ";")
(cond
((smie-rule-parent-p "def" "begin" "do" "class" "module" "for"
"while" "until" "unless"
@@ -611,7 +605,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'."
;; For (invalid) code between switch and case.
;; (if (smie-parent-p "switch") 4)
))
- (`(:before . ,(or `"(" `"[" `"{"))
+ (`(:before . ,(or "(" "[" "{"))
(cond
((and (equal token "{")
(not (smie-rule-prev-p "(" "{" "[" "," "=>" "=" "return" ";"))
@@ -638,7 +632,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'."
(forward-char -1))
(smie-indent-virtual))
(t (smie-rule-parent))))))
- (`(:after . ,(or `"(" "[" "{"))
+ (`(:after . ,(or "(" "[" "{"))
;; FIXME: Shouldn't this be the default behavior of
;; `smie-indent-after-keyword'?
(save-excursion
@@ -648,20 +642,20 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'."
;; because we want to reject hanging tokens at bol, too.
(unless (or (eolp) (forward-comment 1))
(cons 'column (current-column)))))
- (`(:before . " @ ")
+ ('(:before . " @ ")
(save-excursion
(skip-chars-forward " \t")
(cons 'column (current-column))))
- (`(:before . "do") (ruby-smie--indent-to-stmt))
- (`(:before . ".")
+ ('(:before . "do") (ruby-smie--indent-to-stmt))
+ ('(:before . ".")
(if (smie-rule-sibling-p)
(and ruby-align-chained-calls 0)
(smie-backward-sexp ".")
(cons 'column (+ (current-column)
ruby-indent-level))))
- (`(:before . ,(or `"else" `"then" `"elsif" `"rescue" `"ensure"))
+ (`(:before . ,(or "else" "then" "elsif" "rescue" "ensure"))
(smie-rule-parent))
- (`(:before . "when")
+ ('(:before . "when")
;; Align to the previous `when', but look up the virtual
;; indentation of `case'.
(if (smie-rule-sibling-p) 0 (smie-rule-parent)))
@@ -678,7 +672,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'."
(if (ruby-smie--indent-to-stmt-p token)
(ruby-smie--indent-to-stmt)
(cons 'column (current-column)))))
- (`(:before . "iuwu-mod")
+ ('(:before . "iuwu-mod")
(smie-rule-parent ruby-indent-level))
))
@@ -740,7 +734,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'."
(back-to-indentation)
(narrow-to-region (point) end)
(smie-forward-sexp))
- (while (and (setq state (apply 'ruby-parse-partial end state))
+ (while (and (setq state (apply #'ruby-parse-partial end state))
(>= (nth 2 state) 0) (< (point) end))))))
(defun ruby-mode-variables ()
@@ -750,7 +744,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'."
(smie-setup ruby-smie-grammar #'ruby-smie-rules
:forward-token #'ruby-smie--forward-token
:backward-token #'ruby-smie--backward-token)
- (setq-local indent-line-function 'ruby-indent-line))
+ (setq-local indent-line-function #'ruby-indent-line))
(setq-local comment-start "# ")
(setq-local comment-end "")
(setq-local comment-column ruby-comment-column)
@@ -766,9 +760,9 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'."
The style of the comment is controlled by `ruby-encoding-magic-comment-style'."
(let ((encoding-magic-comment-template
(pcase ruby-encoding-magic-comment-style
- (`ruby "# coding: %s")
- (`emacs "# -*- coding: %s -*-")
- (`custom
+ ('ruby "# coding: %s")
+ ('emacs "# -*- coding: %s -*-")
+ ('custom
ruby-custom-encoding-magic-comment-template))))
(insert
(format encoding-magic-comment-template encoding)
@@ -935,9 +929,9 @@ Can be one of `heredoc', `modifier', `expr-qstr', `expr-re'."
(goto-char (match-end 0))
(not (looking-at "\\s_")))
((eq option 'expr-qstr)
- (looking-at "[a-zA-Z][a-zA-z0-9_]* +%[^ \t]"))
+ (looking-at "[a-zA-Z][a-zA-Z0-9_]* +%[^ \t]"))
((eq option 'expr-re)
- (looking-at "[a-zA-Z][a-zA-z0-9_]* +/[^ \t]"))
+ (looking-at "[a-zA-Z][a-zA-Z0-9_]* +/[^ \t]"))
(t nil)))))))))
(defun ruby-forward-string (term &optional end no-error expand)
@@ -985,6 +979,7 @@ delimiter."
((eq c ?\( ) ruby-deep-arglist)))
(defun ruby-parse-partial (&optional end in-string nest depth pcol indent)
+ ;; FIXME: Document why we can't just use parse-partial-sexp.
"TODO: document throughout function body."
(or depth (setq depth 0))
(or indent (setq indent 0))
@@ -1052,7 +1047,7 @@ delimiter."
((looking-at "\\?") ;skip ?char
(cond
((and (ruby-expr-beg)
- (looking-at "?\\(\\\\C-\\|\\\\M-\\)*\\\\?."))
+ (looking-at "\\?\\(\\\\C-\\|\\\\M-\\)*\\\\?."))
(goto-char (match-end 0)))
(t
(goto-char pnt))))
@@ -1159,7 +1154,7 @@ delimiter."
(state (list in-string nest depth pcol indent)))
;; parse the rest of the line
(while (and (> line-end-position (point))
- (setq state (apply 'ruby-parse-partial
+ (setq state (apply #'ruby-parse-partial
line-end-position state))))
(setq in-string (car state)
nest (nth 1 state)
@@ -1196,7 +1191,7 @@ delimiter."
(save-restriction
(narrow-to-region (point) end)
(while (and (> end (point))
- (setq state (apply 'ruby-parse-partial end state))))))
+ (setq state (apply #'ruby-parse-partial end state))))))
(list (nth 0 state) ; in-string
(car (nth 1 state)) ; nest
(nth 2 state) ; depth
@@ -1495,7 +1490,7 @@ With ARG, do it many times. Negative ARG means move backward."
(cond ((looking-at "\\?\\(\\\\[CM]-\\)*\\\\?\\S ")
(goto-char (match-end 0)))
((progn
- (skip-chars-forward ",.:;|&^~=!?\\+\\-\\*")
+ (skip-chars-forward "-,.:;|&^~=!?+*")
(looking-at "\\s("))
(goto-char (scan-sexps (point) 1)))
((and (looking-at (concat "\\<\\(" ruby-block-beg-re
@@ -1538,20 +1533,20 @@ With ARG, do it many times. Negative ARG means move forward."
(let ((i (or arg 1)))
(condition-case nil
(while (> i 0)
- (skip-chars-backward " \t\n,.:;|&^~=!?\\+\\-\\*")
+ (skip-chars-backward "- \t\n,.:;|&^~=!?+*")
(forward-char -1)
(cond ((looking-at "\\s)")
(goto-char (scan-sexps (1+ (point)) -1))
(pcase (char-before)
- (`?% (forward-char -1))
- ((or `?q `?Q `?w `?W `?r `?x)
+ (?% (forward-char -1))
+ ((or ?q ?Q ?w ?W ?r ?x)
(if (eq (char-before (1- (point))) ?%)
(forward-char -2))))
nil)
((looking-at "\\s\"\\|\\\\\\S_")
(let ((c (char-to-string (char-before (match-end 0)))))
(while (and (search-backward c)
- (eq (logand (skip-chars-backward "\\") 1)
+ (eq (logand (skip-chars-backward "\\\\") 1)
1))))
nil)
((looking-at "\\s.\\|\\s\\")
@@ -1561,13 +1556,13 @@ With ARG, do it many times. Negative ARG means move forward."
(forward-char 1)
(while (progn (forward-word-strictly -1)
(pcase (char-before)
- (`?_ t)
- (`?. (forward-char -1) t)
- ((or `?$ `?@)
+ (?_ t)
+ (?. (forward-char -1) t)
+ ((or ?$ ?@)
(forward-char -1)
(and (eq (char-before) (char-after))
(forward-char -1)))
- (`?:
+ (?:
(forward-char -1)
(eq (char-before) :)))))
(if (looking-at ruby-block-end-re)
@@ -1619,7 +1614,7 @@ See `add-log-current-defun-function'."
(concat "^[ \t]*" re "[ \t]+"
"\\("
;; \\. and :: for class methods
- "\\([A-Za-z_]" ruby-symbol-re "*\\|\\.\\|::" "\\)"
+ "\\([A-Za-z_]" ruby-symbol-re "*[?!]?\\|\\.\\|::" "\\)"
"+\\)")))
(definition-re (funcall make-definition-re ruby-defun-beg-re))
(module-re (funcall make-definition-re "\\(class\\|module\\)")))
@@ -1799,8 +1794,8 @@ If the result is do-end block, it will always be multiline."
(buffer-substring-no-properties (1+ min) (1- max))))
(setq content
(if (equal string-quote "'")
- (replace-regexp-in-string "\\\\\"" "\"" (replace-regexp-in-string "\\(\\`\\|[^\\\\]\\)'" "\\1\\\\'" content))
- (replace-regexp-in-string "\\\\'" "'" (replace-regexp-in-string "\\(\\`\\|[^\\\\]\\)\"" "\\1\\\\\"" content))))
+ (replace-regexp-in-string "\\\\\"" "\"" (replace-regexp-in-string "\\(\\`\\|[^\\]\\)'" "\\1\\\\'" content))
+ (replace-regexp-in-string "\\\\'" "'" (replace-regexp-in-string "\\(\\`\\|[^\\]\\)\"" "\\1\\\\\"" content))))
(let ((orig-point (point)))
(delete-region min max)
(insert
@@ -1872,7 +1867,7 @@ It will be properly highlighted even when the call omits parens.")
("^[ \t]*def +\\(`\\)" (1 "_"))
;; Ternary operator colon followed by opening paren or bracket
;; (semi-important for indentation).
- ("\\(:\\)\\(?:[\({]\\|\\[[^]]\\)"
+ ("\\(:\\)\\(?:[({]\\|\\[[^]]\\)"
(1 (string-to-syntax ".")))
;; Regular expressions. Start with matching unescaped slash.
("\\(?:\\=\\|[^\\]\\)\\(?:\\\\\\\\\\)*\\(/\\)"
@@ -2033,13 +2028,6 @@ It will be properly highlighted even when the call omits parens.")
context)))
t)))
-(defvar ruby-font-lock-syntax-table
- (let ((tbl (make-syntax-table ruby-mode-syntax-table)))
- (modify-syntax-entry ?_ "w" tbl)
- tbl)
- "The syntax table to use for fontifying Ruby mode buffers.
-See `font-lock-syntax-table'.")
-
(defconst ruby-font-lock-keyword-beg-re "\\(?:^\\|[^.@$:]\\|\\.\\.\\)")
(defconst ruby-font-lock-keywords
@@ -2190,7 +2178,7 @@ See `font-lock-syntax-table'.")
font-lock-constant-face)
nil t))
;; Special globals.
- (,(concat "\\$\\(?:[:\"!@;,/\\._><\\$?~=*&`'+0-9]\\|-[0adFiIlpvw]\\|"
+ (,(concat "\\$\\(?:[:\"!@;,/._><\\$?~=*&`'+0-9]\\|-[0adFiIlpvw]\\|"
(regexp-opt '("LOAD_PATH" "LOADED_FEATURES" "PROGRAM_NAME"
"ERROR_INFO" "ERROR_POSITION"
"FS" "FIELD_SEPARATOR"
@@ -2218,7 +2206,8 @@ See `font-lock-syntax-table'.")
;; Conversion methods on Kernel.
(,(concat ruby-font-lock-keyword-beg-re
(regexp-opt '("Array" "Complex" "Float" "Hash"
- "Integer" "Rational" "String") 'symbols))
+ "Integer" "Rational" "String")
+ 'symbols))
(1 font-lock-builtin-face))
;; Expression expansion.
(ruby-match-expression-expansion
@@ -2299,7 +2288,7 @@ See `font-lock-syntax-table'.")
:command command
:sentinel
(lambda (proc _event)
- (when (eq 'exit (process-status proc))
+ (when (and (eq 'exit (process-status proc)) (buffer-live-p source))
(unwind-protect
(if (with-current-buffer source (eq proc ruby--flymake-proc))
(with-current-buffer (process-buffer proc)
@@ -2311,36 +2300,44 @@ See `font-lock-syntax-table'.")
(process-send-eof ruby--flymake-proc))))
(defcustom ruby-flymake-use-rubocop-if-available t
- "Non-nil to use the Rubocop Flymake backend.
-Only takes effect if Rubocop is installed."
+ "Non-nil to use the RuboCop Flymake backend.
+Only takes effect if RuboCop is installed.
+
+If there is no Rubocop config file, Rubocop will be passed a flag
+'--lint' to only show syntax errors and important problems."
:version "26.1"
:type 'boolean
- :group 'ruby
:safe 'booleanp)
(defcustom ruby-rubocop-config ".rubocop.yml"
"Configuration file for `ruby-flymake-rubocop'."
:version "26.1"
:type 'string
- :group 'ruby
:safe 'stringp)
(defun ruby-flymake-rubocop (report-fn &rest _args)
- "Rubocop backend for Flymake."
+ "RuboCop backend for Flymake."
(unless (executable-find "rubocop")
(error "Cannot find the rubocop executable"))
(let ((command (list "rubocop" "--stdin" buffer-file-name "--format" "emacs"
"--cache" "false" ; Work around a bug in old version.
"--display-cop-names"))
+ (default-directory default-directory)
config-dir)
(when buffer-file-name
(setq config-dir (locate-dominating-file buffer-file-name
ruby-rubocop-config))
- (when config-dir
+ (if (not config-dir)
+ (setq command (append command '("--lint")))
(setq command (append command (list "--config"
(expand-file-name ruby-rubocop-config
- config-dir)))))
+ config-dir))))
+ (when (ruby-flymake-rubocop--use-bundler-p config-dir)
+ (setq command (append '("bundle" "exec") command))
+ ;; In case of a project with multiple nested subprojects,
+ ;; each one with a Gemfile.
+ (setq default-directory config-dir)))
(ruby-flymake--helper
"rubocop-flymake"
@@ -2352,7 +2349,7 @@ Only takes effect if Rubocop is installed."
(when (eq (process-exit-status proc) 127)
;; Not sure what to do in this case. Maybe ideally we'd
;; switch back to ruby-flymake-simple.
- (flymake-log :warning "Rubocop returned status 127: %s"
+ (flymake-log :warning "RuboCop returned status 127: %s"
(buffer-string)))
(goto-char (point-min))
(cl-loop
@@ -2378,6 +2375,13 @@ Only takes effect if Rubocop is installed."
into diags
finally (funcall report-fn diags)))))))
+(defun ruby-flymake-rubocop--use-bundler-p (dir)
+ (let ((file (expand-file-name "Gemfile" dir)))
+ (and (file-exists-p file)
+ (with-temp-buffer
+ (insert-file-contents file)
+ (re-search-forward "^ *gem ['\"]rubocop['\"]" nil t)))))
+
(defun ruby-flymake-auto (report-fn &rest args)
(apply
(if (and ruby-flymake-use-rubocop-if-available
@@ -2392,18 +2396,17 @@ Only takes effect if Rubocop is installed."
"Major mode for editing Ruby code."
(ruby-mode-variables)
- (setq-local imenu-create-index-function 'ruby-imenu-create-index)
- (setq-local add-log-current-defun-function 'ruby-add-log-current-method)
- (setq-local beginning-of-defun-function 'ruby-beginning-of-defun)
- (setq-local end-of-defun-function 'ruby-end-of-defun)
+ (setq-local imenu-create-index-function #'ruby-imenu-create-index)
+ (setq-local add-log-current-defun-function #'ruby-add-log-current-method)
+ (setq-local beginning-of-defun-function #'ruby-beginning-of-defun)
+ (setq-local end-of-defun-function #'ruby-end-of-defun)
- (add-hook 'after-save-hook 'ruby-mode-set-encoding nil 'local)
- (add-hook 'electric-indent-functions 'ruby--electric-indent-p nil 'local)
- (add-hook 'flymake-diagnostic-functions 'ruby-flymake-auto nil 'local)
+ (add-hook 'after-save-hook #'ruby-mode-set-encoding nil 'local)
+ (add-hook 'electric-indent-functions #'ruby--electric-indent-p nil 'local)
+ (add-hook 'flymake-diagnostic-functions #'ruby-flymake-auto nil 'local)
- (setq-local font-lock-defaults '((ruby-font-lock-keywords) nil nil))
- (setq-local font-lock-keywords ruby-font-lock-keywords)
- (setq-local font-lock-syntax-table ruby-font-lock-syntax-table)
+ (setq-local font-lock-defaults '((ruby-font-lock-keywords) nil nil
+ ((?_ . "w"))))
(setq-local syntax-propertize-function #'ruby-syntax-propertize))
diff --git a/lisp/progmodes/scheme.el b/lisp/progmodes/scheme.el
index 62f521ee94a..507a4c7085d 100644
--- a/lisp/progmodes/scheme.el
+++ b/lisp/progmodes/scheme.el
@@ -433,7 +433,7 @@ that variable's value is a string."
;; (make-regexp '("case" "cond" "else" "if" "lambda"
;; "let" "let*" "letrec" "and" "or" "map" "with-mode"))
"and\\|c\\(ase\\|ond\\)\\|else\\|if\\|"
- "l\\(ambda\\|et\\(\\|*\\|rec\\)\\)\\|map\\|or\\|with-mode"
+ "l\\(ambda\\|et\\(\\|\\*\\|rec\\)\\)\\|map\\|or\\|with-mode"
"\\)\\>")
1)
;; DSSSL syntax
diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el
index 035dd50771e..853a3500ee1 100644
--- a/lisp/progmodes/sh-script.el
+++ b/lisp/progmodes/sh-script.el
@@ -345,7 +345,7 @@ naming the shell."
:group 'sh-script)
(defcustom sh-imenu-generic-expression
- `((sh
+ '((sh
. ((nil
;; function FOO
;; function FOO()
@@ -959,8 +959,8 @@ See `sh-feature'.")
;; ((...)) or $((...)) or $[...] or ${...}. Nested
;; parenthesis can occur inside the first of these forms, so
;; parse backward recursively.
- (`?\( (eq ?\( (char-before)))
- ((or `?\{ `?\[) (eq ?\$ (char-before))))
+ (?\( (eq ?\( (char-before)))
+ ((or ?\{ ?\[) (eq ?\$ (char-before))))
(sh--inside-noncommand-expression (1- (point))))))))
(defun sh-font-lock-open-heredoc (start string eol)
@@ -1022,7 +1022,7 @@ subshells can nest."
;; unescape " inside a $( ... ) construct.
(pcase (char-after)
(?\' (pcase state
- (`double-quote nil)
+ ('double-quote nil)
(_ (forward-char 1)
;; FIXME: mark skipped double quotes as punctuation syntax.
(let ((spos (point)))
@@ -1035,12 +1035,12 @@ subshells can nest."
'syntax-table '(1)))))))))
(?\\ (forward-char 1))
(?\" (pcase state
- (`double-quote (setq state (pop states)))
+ ('double-quote (setq state (pop states)))
(_ (push state states) (setq state 'double-quote)))
(if state (put-text-property (point) (1+ (point))
'syntax-table '(1))))
(?\` (pcase state
- (`backquote (setq state (pop states)))
+ ('backquote (setq state (pop states)))
(_ (push state states) (setq state 'backquote))))
(?\$ (if (not (eq (char-after (1+ (point))) ?\())
nil
@@ -1048,10 +1048,10 @@ subshells can nest."
(pcase state
(_ (push state states) (setq state 'code)))))
(?\( (pcase state
- (`double-quote nil)
+ ('double-quote nil)
(_ (push state states) (setq state 'code))))
(?\) (pcase state
- (`double-quote nil)
+ ('double-quote nil)
(_ (setq state (pop states)))))
(_ (error "Internal error in sh-font-lock-quoted-subshell")))
(forward-char 1))
@@ -1601,7 +1601,7 @@ with your script for an edit-interpret-debug cycle."
(setq-local comint-prompt-regexp "^[ \t]*")
(setq-local imenu-case-fold-search nil)
(setq font-lock-defaults
- `((sh-font-lock-keywords
+ '((sh-font-lock-keywords
sh-font-lock-keywords-1 sh-font-lock-keywords-2)
nil nil
((?/ . "w") (?~ . "w") (?. . "w") (?- . "w") (?_ . "w")) nil
@@ -2035,10 +2035,10 @@ May return nil if the line should not be treated as continued."
(defun sh-smie-sh-rules (kind token)
(pcase (cons kind token)
- (`(:elem . basic) sh-basic-offset)
- (`(:after . "case-)") (- (sh-var-value 'sh-indent-for-case-alt)
+ ('(:elem . basic) sh-basic-offset)
+ ('(:after . "case-)") (- (sh-var-value 'sh-indent-for-case-alt)
(sh-var-value 'sh-indent-for-case-label)))
- (`(:before . ,(or `"(" `"{" `"[" "while" "if" "for" "case"))
+ (`(:before . ,(or "(" "{" "[" "while" "if" "for" "case"))
(if (not (smie-rule-prev-p "&&" "||" "|"))
(when (smie-rule-hanging-p)
(smie-rule-parent))
@@ -2047,11 +2047,11 @@ May return nil if the line should not be treated as continued."
`(column . ,(smie-indent-virtual)))))
;; FIXME: Maybe this handling of ;; should be made into
;; a smie-rule-terminator function that takes the substitute ";" as arg.
- (`(:before . ,(or `";;" `";&" `";;&"))
+ (`(:before . ,(or ";;" ";&" ";;&"))
(if (and (smie-rule-bolp) (looking-at ";;?&?[ \t]*\\(#\\|$\\)"))
(cons 'column (smie-indent-keyword ";"))
(smie-rule-separator kind)))
- (`(:after . ,(or `";;" `";&" `";;&"))
+ (`(:after . ,(or ";;" ";&" ";;&"))
(with-demoted-errors
(smie-backward-sexp token)
(cons 'column
@@ -2062,26 +2062,26 @@ May return nil if the line should not be treated as continued."
(smie-rule-bolp))))
(current-column)
(smie-indent-calculate)))))
- (`(:before . ,(or `"|" `"&&" `"||"))
+ (`(:before . ,(or "|" "&&" "||"))
(unless (smie-rule-parent-p token)
(smie-backward-sexp token)
`(column . ,(+ (funcall smie-rules-function :elem 'basic)
(smie-indent-virtual)))))
;; Attempt at backward compatibility with the old config variables.
- (`(:before . "fi") (sh-var-value 'sh-indent-for-fi))
- (`(:before . "done") (sh-var-value 'sh-indent-for-done))
- (`(:after . "else") (sh-var-value 'sh-indent-after-else))
- (`(:after . "if") (sh-var-value 'sh-indent-after-if))
- (`(:before . "then") (sh-var-value 'sh-indent-for-then))
- (`(:before . "do") (sh-var-value 'sh-indent-for-do))
- (`(:after . "do")
+ ('(:before . "fi") (sh-var-value 'sh-indent-for-fi))
+ ('(:before . "done") (sh-var-value 'sh-indent-for-done))
+ ('(:after . "else") (sh-var-value 'sh-indent-after-else))
+ ('(:after . "if") (sh-var-value 'sh-indent-after-if))
+ ('(:before . "then") (sh-var-value 'sh-indent-for-then))
+ ('(:before . "do") (sh-var-value 'sh-indent-for-do))
+ ('(:after . "do")
(sh-var-value (if (smie-rule-hanging-p)
'sh-indent-after-loop-construct 'sh-indent-after-do)))
;; sh-indent-after-done: aligned completely differently.
- (`(:after . "in") (sh-var-value 'sh-indent-for-case-label))
+ ('(:after . "in") (sh-var-value 'sh-indent-for-case-label))
;; sh-indent-for-continuation: Line continuations are handled differently.
- (`(:after . ,(or `"(" `"{" `"["))
+ (`(:after . ,(or "(" "{" "["))
(if (not (looking-at ".[ \t]*[^\n \t#]"))
(sh-var-value 'sh-indent-after-open)
(goto-char (1- (match-end 0)))
@@ -2244,16 +2244,16 @@ Point should be before the newline."
(defun sh-smie-rc-rules (kind token)
(pcase (cons kind token)
- (`(:elem . basic) sh-basic-offset)
+ ('(:elem . basic) sh-basic-offset)
;; (`(:after . "case") (or sh-basic-offset smie-indent-basic))
- (`(:after . ";")
+ ('(:after . ";")
(if (smie-rule-parent-p "case")
(smie-rule-parent (sh-var-value 'sh-indent-after-case))))
- (`(:before . "{")
+ ('(:before . "{")
(save-excursion
(when (sh-smie--rc-after-special-arg-p)
`(column . ,(current-column)))))
- (`(:before . ,(or `"(" `"{" `"["))
+ (`(:before . ,(or "(" "{" "["))
(if (smie-rule-hanging-p) (smie-rule-parent)))
;; FIXME: SMIE parses "if (exp) cmd" as "(if ((exp) cmd))" so "cmd" is
;; treated as an arg to (exp) by default, which indents it all wrong.
@@ -2262,7 +2262,7 @@ Point should be before the newline."
;; rule we have is the :list-intro hack, which we use here to align "cmd"
;; with "(exp)", which is rarely the right thing to do, but is better
;; than nothing.
- (`(:list-intro . ,(or `"for" `"if" `"while")) t)
+ (`(:list-intro . ,(or "for" "if" "while")) t)
;; sh-indent-after-switch: handled implicitly by the default { rule.
))
@@ -2392,7 +2392,6 @@ whose value is the shell name (don't quote it)."
(funcall mksym "rules")
:forward-token (funcall mksym "forward-token")
:backward-token (funcall mksym "backward-token")))
- (setq-local parse-sexp-lookup-properties t)
(unless sh-use-smie
(setq-local sh-kw-alist (sh-feature sh-kw))
(let ((regexp (sh-feature sh-kws-for-done)))
@@ -2906,8 +2905,7 @@ STRING This is ignored for the purposes of calculating
(setq align-point (point))))
(or (bobp)
(forward-char -1))
- ;; FIXME: This charset looks too much like a regexp. --Stef
- (skip-chars-forward "[a-z0-9]*?")
+ (skip-chars-forward "*0-9?[]a-z")
)
((string-match "[])}]" x)
(setq x (sh-safe-forward-sexp -1))
diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el
index 36382640de5..4ab174d92b9 100644
--- a/lisp/progmodes/sql.el
+++ b/lisp/progmodes/sql.el
@@ -213,7 +213,7 @@
;; Drew Adams <drew.adams@oracle.com> -- Emacs 20 support
;; Harald Maier <maierh@myself.com> -- sql-send-string
;; Stefan Monnier <monnier@iro.umontreal.ca> -- font-lock corrections;
-;; code polish
+;; code polish; on-going guidance and mentorship
;; Paul Sleigh <bat@flurf.net> -- MySQL keyword enhancement
;; Andrew Schein <andrew@andrewschein.com> -- sql-port bug
;; Ian Bjorhovde <idbjorh@dataproxy.com> -- db2 escape newlines
@@ -221,6 +221,8 @@
;; Roman Scherer <roman.scherer@nugg.ad> -- Connection documentation
;; Mark Wilkinson <wilkinsonmr@gmail.com> -- file-local variables ignored
;; Simen Heggestøyl <simenheg@gmail.com> -- Postgres database completion
+;; Robert Cochran <robert-emacs@cochranmail.com> -- MariaDB support
+;; Alex Harsanyi <alexharsanyi@gmail.com> -- sql-indent package and support
;;
@@ -235,6 +237,7 @@
(require 'custom)
(require 'thingatpt)
(require 'view)
+(eval-when-compile (require 'subr-x)) ; string-empty-p
(defvar font-lock-keyword-face)
(defvar font-lock-set-defaults)
@@ -344,7 +347,8 @@ file. Since that is a plaintext file, this could be dangerous."
(const :format "" :completion)
(sexp :tag ":completion")
(const :format "" :must-match)
- (symbol :tag ":must-match")))
+ (restricted-sexp
+ :match-alternatives (listp stringp))))
(const port)))
;; SQL Product support
@@ -415,6 +419,21 @@ file. Since that is a plaintext file, this could be dangerous."
:prompt-regexp "^SQL>"
:prompt-length 4)
+ (mariadb
+ :name "MariaDB"
+ :free-software t
+ :font-lock sql-mode-mariadb-font-lock-keywords
+ :sqli-program sql-mariadb-program
+ :sqli-options sql-mariadb-options
+ :sqli-login sql-mariadb-login-params
+ :sqli-comint-func sql-comint-mariadb
+ :list-all "SHOW TABLES;"
+ :list-table "DESCRIBE %s;"
+ :prompt-regexp "^MariaDB \\[.*]> "
+ :prompt-cont-regexp "^ [\"'`-]> "
+ :syntax-alist ((?# . "< b"))
+ :input-filter sql-remove-tabs-filter)
+
(ms
:name "Microsoft"
:font-lock sql-mode-ms-font-lock-keywords
@@ -691,6 +710,8 @@ making new SQLi sessions."
:version "24.1"
:group 'SQL)
+(defvaralias 'sql-dialect 'sql-product)
+
(defcustom sql-product 'ansi
"Select the SQL database product used.
This allows highlighting buffers properly when you open them."
@@ -703,7 +724,145 @@ This allows highlighting buffers properly when you open them."
sql-product-alist))
:group 'SQL
:safe 'symbolp)
-(defvaralias 'sql-dialect 'sql-product)
+
+;; SQL indent support
+
+(defcustom sql-use-indent-support t
+ "If non-nil then use the SQL indent support features of sql-indent.
+The `sql-indent' package in ELPA provides indentation support for
+SQL statements with easy customizations to support varied layout
+requirements.
+
+The package must be available to be loaded and activated."
+ :group 'SQL
+ :link '(url-link "https://elpa.gnu.org/packages/sql-indent.html")
+ :type 'booleanp
+ :version "27.1")
+
+(defun sql-indent-enable ()
+ "Enable `sqlind-minor-mode' if available and requested."
+ (when (fboundp 'sqlind-minor-mode)
+ (sqlind-minor-mode (if sql-use-indent-support +1 -1))))
+
+;; Secure Password wallet
+
+(require 'auth-source)
+
+(defun sql-auth-source-search-wallet (wallet product user server database port)
+ "Read auth source WALLET to locate the USER secret.
+Sets `auth-sources' to WALLET and uses `auth-source-search' to locate the entry.
+The DATABASE and SERVER are concatenated with a slash between them as the
+host key."
+ (let* ((auth-sources wallet)
+ host
+ secret h-secret sd-secret)
+
+ ;; product
+ (setq product (symbol-name product))
+
+ ;; user
+ (setq user (unless (string-empty-p user) user))
+
+ ;; port
+ (setq port
+ (when (and port (numberp port) (not (zerop port)))
+ (number-to-string port)))
+
+ ;; server
+ (setq server (unless (string-empty-p server) server))
+
+ ;; database
+ (setq database (unless (string-empty-p database) database))
+
+ ;; host
+ (setq host (if server
+ (if database
+ (concat server "/" database)
+ server)
+ database))
+
+ ;; Perform search
+ (dolist (s (auth-source-search :max 1000))
+ (when (and
+ ;; Is PRODUCT specified, in the enty, and they are equal
+ (if product
+ (if (plist-member s :product)
+ (equal (plist-get s :product) product)
+ t)
+ t)
+ ;; Is USER specified, in the entry, and they are equal
+ (if user
+ (if (plist-member s :user)
+ (equal (plist-get s :user) user)
+ t)
+ t)
+ ;; Is PORT specified, in the entry, and they are equal
+ (if port
+ (if (plist-member s :port)
+ (equal (plist-get s :port) port)
+ t)
+ t))
+ ;; Is HOST specified, in the entry, and they are equal
+ ;; then the H-SECRET list
+ (if (and host
+ (plist-member s :host)
+ (equal (plist-get s :host) host))
+ (push s h-secret)
+ ;; Are SERVER and DATABASE specified, present, and equal
+ ;; then the SD-SECRET list
+ (if (and server
+ (plist-member s :server)
+ database
+ (plist-member s :database)
+ (equal (plist-get s :server) server)
+ (equal (plist-get s :database) database))
+ (push s sd-secret)
+ ;; Is SERVER specified, in the entry, and they are equal
+ ;; then the base SECRET list
+ (if (and server
+ (plist-member s :server)
+ (equal (plist-get s :server) server))
+ (push s secret)
+ ;; Is DATABASE specified, in the entry, and they are equal
+ ;; then the base SECRET list
+ (if (and database
+ (plist-member s :database)
+ (equal (plist-get s :database) database))
+ (push s secret)))))))
+ (setq secret (or h-secret sd-secret secret))
+
+ ;; If we found a single secret, return the password
+ (when (= 1 (length secret))
+ (setq secret (car secret))
+ (if (plist-member secret :secret)
+ (plist-get secret :secret)
+ nil))))
+
+(defcustom sql-password-wallet
+ (let (wallet w)
+ (dolist (ext '(".json.gpg" ".gpg" ".json" "") wallet)
+ (unless wallet
+ (setq w (locate-user-emacs-file (concat "sql-wallet" ext)
+ (concat ".sql-wallet" ext)))
+ (when (file-exists-p w)
+ (setq wallet w)))))
+ "Identification of the password wallet.
+See `sql-password-search-wallet-function' to understand how this value
+is used to locate the password wallet."
+ :type `(plist-get (symbol-plist 'auth-sources) 'custom-type)
+ :group 'SQL
+ :version "27.1")
+
+(defvar sql-password-search-wallet-function #'sql-auth-source-search-wallet
+ "Function to handle the lookup of the database password.
+The specified function will be called as:
+ (wallet-func WALLET PRODUCT USER SERVER DATABASE PORT)
+
+It is expected to return either a string containing the password,
+a function returning the password, or nil, If you want to support
+another format of password file, then implement a different
+search wallet function and identify the location of the password
+store with `sql-password-wallet'.")
;; misc customization of sql.el behavior
@@ -759,16 +918,20 @@ Globally should be set to nil; it will be non-nil in `sql-mode',
(defvar sql-login-delay 7.5 ;; Secs
"Maximum number of seconds you are willing to wait for a login connection.")
-(defcustom sql-pop-to-buffer-after-send-region nil
- "When non-nil, pop to the buffer SQL statements are sent to.
+(defvaralias 'sql-pop-to-buffer-after-send-region 'sql-display-sqli-buffer-function)
-After a call to `sql-sent-string', `sql-send-region',
-`sql-send-paragraph' or `sql-send-buffer', the window is split
-and the SQLi buffer is shown. If this variable is not nil, that
-buffer's window will be selected by calling `pop-to-buffer'. If
-this variable is nil, that buffer is shown using
-`display-buffer'."
- :type 'boolean
+(defcustom sql-display-sqli-buffer-function #'display-buffer
+ "Function to be called to display a SQLi buffer after `sql-send-*'.
+
+When set to a function, it will be called to display the buffer.
+When set to t, the default function `pop-to-buffer' will be
+called. If not set, no attempt will be made to display the
+buffer."
+
+ :type '(choice (const :tag "Default" t)
+ (const :tag "No display" nil)
+ (function :tag "Display Buffer function"))
+ :version "27.1"
:group 'SQL)
;; imenu support for sql-mode.
@@ -788,7 +951,7 @@ this variable is nil, that buffer is shown using
This is used to set `imenu-generic-expression' when SQL mode is
entered. Subsequent changes to `sql-imenu-generic-expression' will
-not affect existing SQL buffers because imenu-generic-expression is
+not affect existing SQL buffers because `imenu-generic-expression' is
a local variable.")
;; history file
@@ -828,15 +991,17 @@ commands when the input history is read, as if you had set
;; The usual hooks
-(defcustom sql-interactive-mode-hook '()
+(defcustom sql-interactive-mode-hook '(sql-indent-enable)
"Hook for customizing `sql-interactive-mode'."
:type 'hook
- :group 'SQL)
+ :group 'SQL
+ :version "27.1")
-(defcustom sql-mode-hook '()
+(defcustom sql-mode-hook '(sql-indent-enable)
"Hook for customizing `sql-mode'."
:type 'hook
- :group 'SQL)
+ :group 'SQL
+ :version "27.1")
(defcustom sql-set-sqli-hook '()
"Hook for reacting to changes of `sql-buffer'.
@@ -953,10 +1118,19 @@ Starts `sql-interactive-mode' after doing some setup."
:version "26.1"
:group 'SQL)
+;; Customization for MariaDB
+
+;; MariaDB is a drop-in replacement for MySQL, so just make the
+;; MariaDB variables aliases of the MySQL ones.
+
+(defvaralias 'sql-mariadb-program 'sql-mysql-program)
+(defvaralias 'sql-mariadb-options 'sql-mysql-options)
+(defvaralias 'sql-mariadb-login-params 'sql-mysql-login-params)
+
;; Customization for MySQL
(defcustom sql-mysql-program "mysql"
- "Command to start mysql by TcX.
+ "Command to start mysql by Oracle.
Starts `sql-interactive-mode' after doing some setup."
:type 'file
@@ -1103,8 +1277,11 @@ add your name with a \"-U\" prefix (such as \"-Umark\") to the list."
(when (executable-find sql-postgres-program)
(let ((res '()))
(ignore-errors
- (dolist (row (process-lines sql-postgres-program "-ltX"))
- (when (string-match "^ \\([[:alnum:]-_]+\\) +|.*" row)
+ (dolist (row (process-lines sql-postgres-program
+ "--list"
+ "--no-psqlrc"
+ "--tuples-only"))
+ (when (string-match "^ \\([^ |]+\\) +|.*" row)
(push (match-string 1 row) res))))
(nreverse res))))
@@ -1237,7 +1414,8 @@ specified, it's `sql-product' or `sql-connection' must match."
(or (not product)
(eq product sql-product))
(or (not connection)
- (eq connection sql-connection)))))))
+ (and (stringp connection)
+ (string= connection sql-connection))))))))
;; Keymap for sql-interactive-mode.
@@ -2312,75 +2490,148 @@ regular expressions are created during compilation by calling the
function `regexp-opt'. Therefore, take a look at the source before
you define your own `sql-mode-solid-font-lock-keywords'.")
+(defvaralias 'sql-mode-mariadb-font-lock-keywords 'sql-mode-mysql-font-lock-keywords
+ "MariaDB is SQL compatible with MySQL.")
+
(defvar sql-mode-mysql-font-lock-keywords
(eval-when-compile
(list
;; MySQL Functions
(sql-font-lock-keywords-builder 'font-lock-builtin-face nil
-"ascii" "avg" "bdmpolyfromtext" "bdmpolyfromwkb" "bdpolyfromtext"
-"bdpolyfromwkb" "benchmark" "bin" "bit_and" "bit_length" "bit_or"
-"bit_xor" "both" "cast" "char_length" "character_length" "coalesce"
-"concat" "concat_ws" "connection_id" "conv" "convert" "count"
-"curdate" "current_date" "current_time" "current_timestamp" "curtime"
-"elt" "encrypt" "export_set" "field" "find_in_set" "found_rows" "from"
+"acos" "adddate" "addtime" "aes_decrypt" "aes_encrypt" "area"
+"asbinary" "ascii" "asin" "astext" "aswkb" "aswkt" "atan" "atan2"
+"avg" "bdmpolyfromtext" "bdmpolyfromwkb" "bdpolyfromtext"
+"bdpolyfromwkb" "benchmark" "bin" "binlog_gtid_pos" "bit_and"
+"bit_count" "bit_length" "bit_or" "bit_xor" "both" "boundary" "buffer"
+"cast" "ceil" "ceiling" "centroid" "character_length" "char_length"
+"charset" "coalesce" "coercibility" "column_add" "column_check"
+"column_create" "column_delete" "column_exists" "column_get"
+"column_json" "column_list" "compress" "concat" "concat_ws"
+"connection_id" "conv" "convert" "convert_tz" "convexhull" "cos" "cot"
+"count" "crc32" "crosses" "cume_dist" "cume_dist" "curdate"
+"current_date" "current_time" "current_timestamp" "curtime" "date_add"
+"datediff" "date_format" "date_sub" "dayname" "dayofmonth" "dayofweek"
+"dayofyear" "decode" "decode_histogram" "degrees" "dense_rank"
+"dense_rank" "des_decrypt" "des_encrypt" "dimension" "disjoint" "div"
+"elt" "encode" "encrypt" "endpoint" "envelope" "exp" "export_set"
+"exteriorring" "extractvalue" "field" "find_in_set" "floor" "format"
+"found_rows" "from" "from_base64" "from_days" "from_unixtime"
"geomcollfromtext" "geomcollfromwkb" "geometrycollectionfromtext"
"geometrycollectionfromwkb" "geometryfromtext" "geometryfromwkb"
-"geomfromtext" "geomfromwkb" "get_lock" "group_concat" "hex" "ifnull"
-"instr" "interval" "isnull" "last_insert_id" "lcase" "leading"
-"length" "linefromtext" "linefromwkb" "linestringfromtext"
-"linestringfromwkb" "load_file" "locate" "lower" "lpad" "ltrim"
-"make_set" "master_pos_wait" "max" "mid" "min" "mlinefromtext"
-"mlinefromwkb" "mpointfromtext" "mpointfromwkb" "mpolyfromtext"
-"mpolyfromwkb" "multilinestringfromtext" "multilinestringfromwkb"
+"geometryn" "geometrytype" "geomfromtext" "geomfromwkb" "get_format"
+"get_lock" "glength" "greatest" "group_concat" "hex" "ifnull"
+"inet6_aton" "inet6_ntoa" "inet_aton" "inet_ntoa" "instr"
+"interiorringn" "intersects" "interval" "isclosed" "isempty"
+"is_free_lock" "is_ipv4" "is_ipv4_compat" "is_ipv4_mapped" "is_ipv6"
+"isnull" "isring" "issimple" "is_used_lock" "json_array"
+"json_array_append" "json_array_insert" "json_compact" "json_contains"
+"json_contains_path" "json_depth" "json_detailed" "json_exists"
+"json_extract" "json_insert" "json_keys" "json_length" "json_loose"
+"json_merge" "json_object" "json_query" "json_quote" "json_remove"
+"json_replace" "json_search" "json_set" "json_type" "json_unquote"
+"json_valid" "json_value" "lag" "last_day" "last_insert_id" "lastval"
+"last_value" "last_value" "lcase" "lead" "leading" "least" "length"
+"linefromtext" "linefromwkb" "linestringfromtext" "linestringfromwkb"
+"ln" "load_file" "locate" "log" "log10" "log2" "lower" "lpad" "ltrim"
+"makedate" "make_set" "maketime" "master_gtid_wait" "master_pos_wait"
+"max" "mbrcontains" "mbrdisjoint" "mbrequal" "mbrintersects"
+"mbroverlaps" "mbrtouches" "mbrwithin" "md5" "median"
+"mid" "min" "mlinefromtext" "mlinefromwkb" "monthname"
+"mpointfromtext" "mpointfromwkb" "mpolyfromtext" "mpolyfromwkb"
+"multilinestringfromtext" "multilinestringfromwkb"
"multipointfromtext" "multipointfromwkb" "multipolygonfromtext"
-"multipolygonfromwkb" "now" "nullif" "oct" "octet_length" "ord"
-"pointfromtext" "pointfromwkb" "polyfromtext" "polyfromwkb"
-"polygonfromtext" "polygonfromwkb" "position" "quote" "rand"
-"release_lock" "repeat" "replace" "reverse" "rpad" "rtrim" "soundex"
-"space" "std" "stddev" "substring" "substring_index" "sum" "sysdate"
-"trailing" "trim" "ucase" "unix_timestamp" "upper" "user" "variance"
+"multipolygonfromwkb" "name_const" "nextval" "now" "nth_value" "ntile"
+"ntile" "nullif" "numgeometries" "numinteriorrings" "numpoints" "oct"
+"octet_length" "old_password" "ord" "percentile_cont"
+"percentile_disc" "percent_rank" "percent_rank" "period_add"
+"period_diff" "pi" "pointfromtext" "pointfromwkb" "pointn"
+"pointonsurface" "polyfromtext" "polyfromwkb" "polygonfromtext"
+"polygonfromwkb" "position" "pow" "power" "quote" "radians"
+"rand" "rank" "rank" "regexp" "regexp_instr" "regexp_replace"
+"regexp_substr" "release_lock" "repeat" "replace" "reverse" "rlike"
+"row_number" "row_number" "rpad" "rtrim" "sec_to_time" "setval" "sha"
+"sha1" "sha2" "sign" "sin" "sleep" "soundex" "space"
+"spider_bg_direct_sql" "spider_copy_tables" "spider_direct_sql"
+"spider_flush_table_mon_cache" "sqrt" "srid" "st_area" "startpoint"
+"st_asbinary" "st_astext" "st_aswkb" "st_aswkt" "st_boundary"
+"st_buffer" "st_centroid" "st_contains" "st_convexhull" "st_crosses"
+"std" "stddev" "stddev_pop" "stddev_samp" "st_difference"
+"st_dimension" "st_disjoint" "st_distance" "st_endpoint" "st_envelope"
+"st_equals" "st_exteriorring" "st_geomcollfromtext"
+"st_geomcollfromwkb" "st_geometrycollectionfromtext"
+"st_geometrycollectionfromwkb" "st_geometryfromtext"
+"st_geometryfromwkb" "st_geometryn" "st_geometrytype"
+"st_geomfromtext" "st_geomfromwkb" "st_interiorringn"
+"st_intersection" "st_intersects" "st_isclosed" "st_isempty"
+"st_isring" "st_issimple" "st_length" "st_linefromtext"
+"st_linefromwkb" "st_linestringfromtext" "st_linestringfromwkb"
+"st_numgeometries" "st_numinteriorrings" "st_numpoints" "st_overlaps"
+"st_pointfromtext" "st_pointfromwkb" "st_pointn" "st_pointonsurface"
+"st_polyfromtext" "st_polyfromwkb" "st_polygonfromtext"
+"st_polygonfromwkb" "strcmp" "st_relate" "str_to_date" "st_srid"
+"st_startpoint" "st_symdifference" "st_touches" "st_union" "st_within"
+"st_x" "st_y" "subdate" "substr" "substring" "substring_index"
+"subtime" "sum" "sysdate" "tan" "timediff" "time_format"
+"timestampadd" "timestampdiff" "time_to_sec" "to_base64" "to_days"
+"to_seconds" "touches" "trailing" "trim" "ucase" "uncompress"
+"uncompressed_length" "unhex" "unix_timestamp" "updatexml" "upper"
+"user" "utc_date" "utc_time" "utc_timestamp" "uuid" "uuid_short"
+"variance" "var_pop" "var_samp" "version" "weekday"
+"weekofyear" "weight_string" "within"
)
;; MySQL Keywords
(sql-font-lock-keywords-builder 'font-lock-keyword-face nil
-"action" "add" "after" "against" "all" "alter" "and" "as" "asc"
-"auto_increment" "avg_row_length" "bdb" "between" "by" "cascade"
-"case" "change" "character" "check" "checksum" "close" "collate"
-"collation" "column" "columns" "comment" "committed" "concurrent"
-"constraint" "create" "cross" "data" "database" "default"
-"delay_key_write" "delayed" "delete" "desc" "directory" "disable"
-"distinct" "distinctrow" "do" "drop" "dumpfile" "duplicate" "else" "elseif"
-"enable" "enclosed" "end" "escaped" "exists" "fields" "first" "for"
-"force" "foreign" "from" "full" "fulltext" "global" "group" "handler"
-"having" "heap" "high_priority" "if" "ignore" "in" "index" "infile"
-"inner" "insert" "insert_method" "into" "is" "isam" "isolation" "join"
-"key" "keys" "last" "left" "level" "like" "limit" "lines" "load"
-"local" "lock" "low_priority" "match" "max_rows" "merge" "min_rows"
-"mode" "modify" "mrg_myisam" "myisam" "natural" "next" "no" "not"
-"null" "offset" "oj" "on" "open" "optionally" "or" "order" "outer"
-"outfile" "pack_keys" "partial" "password" "prev" "primary"
-"procedure" "quick" "raid0" "raid_type" "read" "references" "rename"
-"repeatable" "restrict" "right" "rollback" "rollup" "row_format"
-"savepoint" "select" "separator" "serializable" "session" "set"
-"share" "show" "sql_big_result" "sql_buffer_result" "sql_cache"
-"sql_calc_found_rows" "sql_no_cache" "sql_small_result" "starting"
-"straight_join" "striped" "table" "tables" "temporary" "terminated"
-"then" "to" "transaction" "truncate" "type" "uncommitted" "union"
-"unique" "unlock" "update" "use" "using" "values" "when" "where"
-"with" "write" "xor"
+"accessible" "action" "add" "after" "against" "all" "alter" "analyze"
+"and" "as" "asc" "auto_increment" "avg_row_length" "bdb" "between"
+"body" "by" "cascade" "case" "change" "character" "check" "checksum"
+"close" "collate" "collation" "column" "columns" "comment" "committed"
+"concurrent" "condition" "constraint" "create" "cross" "data"
+"database" "databases" "default" "delayed" "delay_key_write" "delete"
+"desc" "directory" "disable" "distinct" "distinctrow" "do" "drop"
+"dual" "dumpfile" "duplicate" "else" "elseif" "elsif" "enable"
+"enclosed" "end" "escaped" "exists" "exit" "explain" "fields" "first"
+"for" "force" "foreign" "from" "full" "fulltext" "global" "group"
+"handler" "having" "heap" "high_priority" "history" "if" "ignore"
+"ignore_server_ids" "in" "index" "infile" "inner" "insert"
+"insert_method" "into" "is" "isam" "isolation" "join" "key" "keys"
+"kill" "last" "leave" "left" "level" "like" "limit" "linear" "lines"
+"load" "local" "lock" "long" "loop" "low_priority"
+"master_heartbeat_period" "master_ssl_verify_server_cert" "match"
+"max_rows" "maxvalue" "merge" "min_rows" "mode" "modify" "mrg_myisam"
+"myisam" "natural" "next" "no" "not" "no_write_to_binlog" "null"
+"offset" "oj" "on" "open" "optimize" "optionally" "or" "order" "outer"
+"outfile" "over" "package" "pack_keys" "partial" "partition"
+"password" "period" "prev" "primary" "procedure" "purge" "quick"
+"raid0" "raid_type" "raise" "range" "read" "read_write" "references"
+"release" "rename" "repeatable" "require" "resignal" "restrict"
+"returning" "right" "rollback" "rollup" "row_format" "rowtype"
+"savepoint" "schemas" "select" "separator" "serializable" "session"
+"set" "share" "show" "signal" "slow" "spatial" "sql_big_result"
+"sql_buffer_result" "sql_cache" "sql_calc_found_rows" "sql_no_cache"
+"sql_small_result" "ssl" "starting" "straight_join" "striped"
+"system_time" "table" "tables" "temporary" "terminated" "then" "to"
+"transaction" "truncate" "type" "uncommitted" "undo" "union" "unique"
+"unlock" "update" "use" "using" "values" "versioning" "when" "where"
+"while" "window" "with" "write" "xor"
)
;; MySQL Data Types
(sql-font-lock-keywords-builder 'font-lock-type-face nil
-"bigint" "binary" "bit" "blob" "bool" "boolean" "char" "curve" "date"
-"datetime" "dec" "decimal" "double" "enum" "fixed" "float" "geometry"
-"geometrycollection" "int" "integer" "line" "linearring" "linestring"
-"longblob" "longtext" "mediumblob" "mediumint" "mediumtext"
+"bigint" "binary" "bit" "blob" "bool" "boolean" "byte" "char" "curve"
+"date" "datetime" "day" "day_hour" "day_microsecond" "day_minute"
+"day_second" "dec" "decimal" "double" "enum" "fixed" "float" "float4"
+"float8" "geometry" "geometrycollection" "hour" "hour_microsecond"
+"hour_minute" "hour_second" "int" "int1" "int2" "int3" "int4" "int8"
+"integer" "json" "line" "linearring" "linestring" "longblob"
+"longtext" "mediumblob" "mediumint" "mediumtext" "microsecond"
+"middleint" "minute" "minute_microsecond" "minute_second" "month"
"multicurve" "multilinestring" "multipoint" "multipolygon"
"multisurface" "national" "numeric" "point" "polygon" "precision"
-"real" "smallint" "surface" "text" "time" "timestamp" "tinyblob"
-"tinyint" "tinytext" "unsigned" "varchar" "year" "year2" "year4"
-"zerofill"
+"quarter" "real" "second" "second_microsecond" "signed" "smallint"
+"surface" "text" "time" "timestamp" "tinyblob" "tinyint" "tinytext"
+"unsigned" "varbinary" "varchar" "varcharacter" "week" "year" "year2"
+"year4" "year_month" "zerofill"
)))
"MySQL SQL keywords used by font-lock.
@@ -2474,7 +2725,7 @@ highlighting rules in SQL mode.")
nil 'require-match
init 'sql-product-history init))))
-(defun sql-add-product (product display &rest plist)
+(defun sql-add-product (product display &optional plist)
"Add support for a database product in `sql-mode'.
Add PRODUCT to `sql-product-alist' which enables `sql-mode' to
@@ -2531,15 +2782,38 @@ list. See `sql-add-product' to add new products. The FEATURE
argument must be a plist keyword accepted by
`sql-product-alist'."
- (let* ((p (assoc product sql-product-alist))
- (v (plist-get (cdr p) feature)))
+ (let* ((p (assoc product sql-product-alist)) ;; (PRODUCT :f v ...)
+ (v (plist-member (cdr p) feature))) ;; (:FEATURE value ...) or null
+
(if p
- (if (and
- (member feature sql-indirect-features)
- (symbolp v))
- (set v newvalue)
- (setcdr p (plist-put (cdr p) feature newvalue)))
- (error "`%s' is not a known product; use `sql-add-product' to add it first." product))))
+ (if (member feature sql-indirect-features) ; is indirect
+ (if v
+ (if (car (cdr v))
+ (if (symbolp (car (cdr v)))
+ ;; Indirect reference
+ (set (car (cdr v)) newvalue)
+ ;; indirect is not a symbol
+ (error "The value of `%s' for `%s' is not a symbol" feature product))
+ ;; keyword present, set the indirect variable name
+ (if (symbolp newvalue)
+ (if (cdr v)
+ (setf (car (cdr v)) newvalue)
+ (setf (cdr v) (list newvalue)))
+ (error "The indirect variable of `%s' for `%s' must be a symbol" feature product)))
+ ;; not present; insert list
+ (setq v (list feature newvalue))
+ (setf (cdr (cdr v)) (cdr p))
+ (setf (cdr p) v))
+ ;; Not an indirect feature
+ (if v
+ (if (cdr v)
+ (setf (car (cdr v)) newvalue)
+ (setf (cdr v) (list newvalue)))
+ ;; no value; insert into the list
+ (setq v (list feature newvalue))
+ (setf (cdr (cdr v)) (cdr p))
+ (setf (cdr p) v)))
+ (error "`%s' is not a known product; use `sql-add-product' to add it first" product))))
(defun sql-get-product-feature (product feature &optional fallback not-indirect)
"Lookup FEATURE associated with a SQL PRODUCT.
@@ -2567,7 +2841,7 @@ See `sql-product-alist' for a list of products and supported features."
(member feature sql-indirect-features)
(not not-indirect)
(symbolp v))
- (symbol-value v)
+ (eval v)
v))
(error "`%s' is not a known product; use `sql-add-product' to add it first." product)
nil)))
@@ -2712,18 +2986,52 @@ adds a fontification pattern to fontify identifiers ending in
;; Save product setting and fontify.
(setq sql-product product)
(sql-highlight-product))
+(defalias 'sql-set-dialect 'sql-set-product)
-
-;;; Compatibility functions
-
-(if (not (fboundp 'comint-line-beginning-position))
- ;; comint-line-beginning-position is defined in Emacs 21
- (defun comint-line-beginning-position ()
- "Return the buffer position of the beginning of the line, after any prompt.
-The prompt is assumed to be any text at the beginning of the line
-matching the regular expression `comint-prompt-regexp', a buffer
-local variable."
- (save-excursion (comint-bol nil) (point))))
+(defun sql-buffer-hidden-p (buf)
+ "Is the buffer hidden?"
+ (string-prefix-p " "
+ (cond
+ ((stringp buf)
+ (when (get-buffer buf)
+ buf))
+ ((bufferp buf)
+ (buffer-name buf))
+ (t nil))))
+
+(defun sql-display-buffer (buf)
+ "Display a SQLi buffer based on `sql-display-sqli-buffer-function'.
+
+If BUF is hidden or `sql-display-sqli-buffer-function' is nil,
+then the buffer will not be displayed. Otherwise the BUF is
+displayed."
+ (unless (sql-buffer-hidden-p buf)
+ (cond
+ ((eq sql-display-sqli-buffer-function t)
+ (pop-to-buffer buf))
+ ((not sql-display-sqli-buffer-function)
+ nil)
+ ((functionp sql-display-sqli-buffer-function)
+ (funcall sql-display-sqli-buffer-function buf))
+ (t
+ (message "Invalid setting of `sql-display-sqli-buffer-function'")
+ (pop-to-buffer buf)))))
+
+(defun sql-make-progress-reporter (buf message &optional min-value max-value current-value min-change min-time)
+ "Make a progress reporter if BUF is not hidden."
+ (unless (or (sql-buffer-hidden-p buf)
+ (not sql-display-sqli-buffer-function))
+ (make-progress-reporter message min-value max-value current-value min-change min-time)))
+
+(defun sql-progress-reporter-update (reporter &optional value)
+ "Report progress of an operation in the echo area."
+ (when reporter
+ (progress-reporter-update reporter value)))
+
+(defun sql-progress-reporter-done (reporter)
+ "Print reporter’s message followed by word \"done\" in echo area."
+ (when reporter
+ (progress-reporter-done reporter)))
;;; SMIE support
@@ -2756,12 +3064,12 @@ local variable."
;;; Motion Functions
(defun sql-statement-regexp (prod)
- (let* ((ansi-stmt (sql-get-product-feature 'ansi :statement))
+ (let* ((ansi-stmt (or (sql-get-product-feature 'ansi :statement) "select"))
(prod-stmt (sql-get-product-feature prod :statement)))
(concat "^\\<"
(if prod-stmt
- ansi-stmt
- (concat "\\(" ansi-stmt "\\|" prod-stmt "\\)"))
+ (concat "\\(" ansi-stmt "\\|" prod-stmt "\\)")
+ ansi-stmt)
"\\>")))
(defun sql-beginning-of-statement (arg)
@@ -2797,7 +3105,7 @@ local variable."
(defun sql-end-of-statement (arg)
"Move to the end of the current SQL statement."
(interactive "p")
- (let ((term (sql-get-product-feature sql-product :terminator))
+ (let ((term (or (sql-get-product-feature sql-product :terminator) ";"))
(re-search (if (> 0 arg) 're-search-backward 're-search-forward))
(here (point))
(n 0))
@@ -2917,11 +3225,11 @@ appended to the SQLi buffer without disturbing your SQL buffer.")
"Return a docstring for `sql-help' listing loaded SQL products."
(let ((doc sql--help-docstring))
;; Insert FREE software list
- (when (string-match "^\\(\\s-*\\)[\\\\][\\\\]FREE\\s-*$" doc 0)
+ (when (string-match "^\\(\\s-*\\)[\\][\\]FREE\\s-*$" doc 0)
(setq doc (replace-match (sql-help-list-products (match-string 1 doc) t)
t t doc 0)))
;; Insert non-FREE software list
- (when (string-match "^\\(\\s-*\\)[\\\\][\\\\]NONFREE\\s-*$" doc 0)
+ (when (string-match "^\\(\\s-*\\)[\\][\\]NONFREE\\s-*$" doc 0)
(setq doc (replace-match (sql-help-list-products (match-string 1 doc) nil)
t t doc 0)))
doc))
@@ -2952,7 +3260,12 @@ regexp pattern specified in its value.
The `:completion' property prompts for a string specified by its
value. (The property value is used as the PREDICATE argument to
-`completing-read'.)"
+`completing-read'.)
+
+For both `:file' and `:completion', there can also be a
+`:must-match' property that controls REQUIRE-MATCH parameter to
+`completing-read'."
+
(set-default
symbol
(let* ((default (plist-get plist :default))
@@ -2972,7 +3285,9 @@ value. (The property value is used as the PREDICATE argument to
(read-file-name prompt
(file-name-directory last-value)
default
- (plist-get plist :must-match)
+ (if (plist-member plist :must-match)
+ (plist-get plist :must-match)
+ t)
(file-name-nondirectory last-value)
(when (plist-get plist :file)
`(lambda (f)
@@ -2989,7 +3304,9 @@ value. (The property value is used as the PREDICATE argument to
(completing-read prompt-def
(plist-get plist :completion)
nil
- (plist-get plist :must-match)
+ (if (plist-member plist :must-match)
+ (plist-get plist :must-match)
+ t)
last-value
history-var
default))
@@ -3017,6 +3334,10 @@ symbol `password', for the server if it contains the symbol
`database'. The members of WHAT are processed in the order in
which they are provided.
+If the `sql-password-wallet' is non-nil and WHAT contains the
+`password' token, then the `password' token will be pushed to the
+end to be sure that all of the values can be fed to the wallet.
+
Each token may also be a list with the token in the car and a
plist of options as the cdr. The following properties are
supported:
@@ -3028,24 +3349,45 @@ supported:
In order to ask the user for username, password and database, call the
function like this: (sql-get-login \\='user \\='password \\='database)."
+
+ ;; Push the password to the end if we have a wallet
+ (when (and sql-password-wallet
+ (fboundp sql-password-search-wallet-function)
+ (member 'password what))
+ (setq what (append (cl-delete 'password what)
+ '(password))))
+
+ ;; Prompt for each parameter
(dolist (w what)
(let ((plist (cdr-safe w)))
(pcase (or (car-safe w) w)
- (`user
+ ('user
(sql-get-login-ext 'sql-user "User: " 'sql-user-history plist))
- (`password
+ ('password
(setq-default sql-password
- (read-passwd "Password: " nil (sql-default-value 'sql-password))))
-
- (`server
+ (if (and sql-password-wallet
+ (fboundp sql-password-search-wallet-function))
+ (let ((password (funcall sql-password-search-wallet-function
+ sql-password-wallet
+ sql-product
+ sql-user
+ sql-server
+ sql-database
+ sql-port)))
+ (if password
+ password
+ (read-passwd "Password: " nil (sql-default-value 'sql-password))))
+ (read-passwd "Password: " nil (sql-default-value 'sql-password)))))
+
+ ('server
(sql-get-login-ext 'sql-server "Server: " 'sql-server-history plist))
- (`database
+ ('database
(sql-get-login-ext 'sql-database "Database: "
'sql-database-history plist))
- (`port
+ ('port
(sql-get-login-ext 'sql-port "Port: "
nil (append '(:number t) plist)))))))
@@ -3129,7 +3471,7 @@ See also `sql-help' on how to create such a buffer."
(sql-set-sqli-buffer))
(display-buffer sql-buffer))
-(defun sql-make-alternate-buffer-name ()
+(defun sql-make-alternate-buffer-name (&optional product)
"Return a string that can be used to rename a SQLi buffer.
This is used to set `sql-alternate-buffer-name' within
`sql-interactive-mode'.
@@ -3151,23 +3493,23 @@ server/database name."
(cdr
(apply #'append nil
(sql-for-each-login
- (sql-get-product-feature sql-product :sqli-login)
+ (sql-get-product-feature (or product sql-product) :sqli-login)
(lambda (token plist)
(pcase token
- (`user
+ ('user
(unless (string= "" sql-user)
(list "/" sql-user)))
- (`port
+ ('port
(unless (or (not (numberp sql-port))
(= 0 sql-port))
(list ":" (number-to-string sql-port))))
- (`server
+ ('server
(unless (string= "" sql-server)
(list "."
(if (plist-member plist :file)
(file-name-nondirectory sql-server)
sql-server))))
- (`database
+ ('database
(unless (string= "" sql-database)
(list "@"
(if (plist-member plist :file)
@@ -3198,6 +3540,34 @@ server/database name."
;; Use the name we've got
name))))
+(defun sql-generate-unique-sqli-buffer-name (product base)
+ "Generate a new, unique buffer name for a SQLi buffer.
+
+Append a sequence number until a unique name is found."
+ (let ((base-name (when (stringp base)
+ (substring-no-properties
+ (or base
+ (sql-get-product-feature product :name)
+ (symbol-name product)))))
+ buf-fmt-1st buf-fmt-rest)
+
+ ;; Calculate buffer format
+ (if base-name
+ (setq buf-fmt-1st (format "*SQL: %s*" base-name)
+ buf-fmt-rest (format "*SQL: %s-%%d*" base-name))
+ (setq buf-fmt-1st "*SQL*"
+ buf-fmt-rest "*SQL-%d*"))
+
+ ;; See if we can find an unused buffer
+ (let ((buf-name buf-fmt-1st)
+ (i 1))
+ (while (sql-buffer-live-p buf-name)
+ ;; Check a sequence number on the BASE
+ (setq buf-name (format buf-fmt-rest i)
+ i (1+ i)))
+
+ buf-name)))
+
(defun sql-rename-buffer (&optional new-name)
"Rename a SQL interactive buffer.
@@ -3213,18 +3583,20 @@ NEW-NAME is empty, then the buffer name will be \"*SQL*\"."
(user-error "Current buffer is not a SQL interactive buffer")
(setq sql-alternate-buffer-name
- (cond
- ((stringp new-name) new-name)
- ((consp new-name)
- (read-string "Buffer name (\"*SQL: XXX*\"; enter `XXX'): "
- sql-alternate-buffer-name))
- (t sql-alternate-buffer-name)))
-
- (setq sql-alternate-buffer-name (substring-no-properties sql-alternate-buffer-name))
- (rename-buffer (if (string= "" sql-alternate-buffer-name)
- "*SQL*"
- (format "*SQL: %s*" sql-alternate-buffer-name))
- t)))
+ (substring-no-properties
+ (cond
+ ((stringp new-name)
+ new-name)
+ ((consp new-name)
+ (read-string "Buffer name (\"*SQL: XXX*\"; enter `XXX'): "
+ sql-alternate-buffer-name))
+ (t
+ sql-alternate-buffer-name))))
+
+ (rename-buffer
+ (sql-generate-unique-sqli-buffer-name sql-product
+ sql-alternate-buffer-name)
+ t)))
(defun sql-copy-column ()
"Copy current column to the end of buffer.
@@ -3323,8 +3695,8 @@ Allows the suppression of continuation prompts.")
;; Count how many newlines in the string
(setq sql-output-newline-count
- (apply #'+ (mapcar (lambda (ch)
- (if (eq ch ?\n) 1 0)) string)))
+ (apply #'+ (mapcar (lambda (ch) (if (eq ch ?\n) 1 0))
+ string)))
;; Send the string
(comint-simple-send proc string)))
@@ -3439,15 +3811,14 @@ to avoid deleting non-prompt output."
(sql-input-sender (get-buffer-process sql-buffer) s)
;; Send a command terminator if we must
- (if sql-send-terminator
- (sql-send-magic-terminator sql-buffer s sql-send-terminator))
+ (when sql-send-terminator
+ (sql-send-magic-terminator sql-buffer s sql-send-terminator))
- (message "Sent string to buffer %s" sql-buffer)))
+ (when sql-pop-to-buffer-after-send-region
+ (message "Sent string to buffer %s" sql-buffer))))
;; Display the sql buffer
- (if sql-pop-to-buffer-after-send-region
- (pop-to-buffer sql-buffer)
- (display-buffer sql-buffer)))
+ (sql-display-buffer sql-buffer))
;; We don't have no stinkin' sql
(user-error "No SQL process started"))))
@@ -3546,15 +3917,22 @@ of commands accepted by the SQLi program. COMMAND may also be a
list of SQLi command strings."
(let* ((visible (and outbuf
- (not (string= " " (substring outbuf 0 1))))))
+ (not (sql-buffer-hidden-p outbuf))))
+ (this-save save-prior)
+ (next-save t))
+
(when visible
(message "Executing SQL command..."))
+
(if (consp command)
- (mapc (lambda (c) (sql-redirect-one sqlbuf c outbuf save-prior))
- command)
+ (dolist (onecmd command)
+ (sql-redirect-one sqlbuf onecmd outbuf this-save)
+ (setq this-save next-save))
(sql-redirect-one sqlbuf command outbuf save-prior))
+
(when visible
- (message "Executing SQL command...done"))))
+ (message "Executing SQL command...done"))
+ nil))
(defun sql-redirect-one (sqlbuf command outbuf save-prior)
(when command
@@ -3603,7 +3981,7 @@ list of SQLi command strings."
(replace-match "" t t))
(goto-char start))))))))
-(defun sql-redirect-value (sqlbuf command regexp &optional regexp-groups)
+(defun sql-redirect-value (sqlbuf command &optional regexp regexp-groups)
"Execute the SQL command and return part of result.
SQLBUF must be an active SQL interactive buffer. COMMAND should
@@ -3618,7 +3996,7 @@ for each match."
(results nil))
(sql-redirect sqlbuf command outbuf nil)
(with-current-buffer outbuf
- (while (re-search-forward regexp nil t)
+ (while (re-search-forward (or regexp "^.+$") nil t)
(push
(cond
;; no groups-return all of them
@@ -3868,7 +4246,7 @@ must tell Emacs. Here's how to do that in your init file:
;; Set syntax and font-face highlighting
;; Catch changes to sql-product and highlight accordingly
(sql-set-product (or sql-product 'ansi)) ; Fixes bug#13591
- (add-hook 'hack-local-variables-hook 'sql-highlight-product t t))
+ (add-hook 'hack-local-variables-hook #'sql-highlight-product t t))
@@ -3876,7 +4254,7 @@ must tell Emacs. Here's how to do that in your init file:
(put 'sql-interactive-mode 'mode-class 'special)
(put 'sql-interactive-mode 'custom-mode-group 'SQL)
-
+;; FIXME: Why not use `define-derived-mode'?
(defun sql-interactive-mode ()
"Major mode to use a SQL interpreter interactively.
@@ -3938,13 +4316,15 @@ certain length.
\(add-hook \\='sql-interactive-mode-hook
(function (lambda ()
- (setq comint-output-filter-functions \\='comint-truncate-buffer))))
+ (setq comint-output-filter-functions #\\='comint-truncate-buffer))))
Here is another example. It will always put point back to the statement
you entered, right above the output it created.
\(setq comint-output-filter-functions
(function (lambda (STR) (comint-show-output))))"
+ ;; FIXME: The doc above uses `setq' on `comint-output-filter-functions',
+ ;; whereas hooks should be manipulated with things like `add/remove-hook'.
(delay-mode-hooks (comint-mode))
;; Get the `sql-product' for this interactive session.
@@ -3975,7 +4355,8 @@ you entered, right above the output it created.
(setq local-abbrev-table sql-mode-abbrev-table)
(setq abbrev-all-caps 1)
;; Exiting the process will call sql-stop.
- (set-process-sentinel (get-buffer-process (current-buffer)) 'sql-stop)
+ (let ((proc (get-buffer-process (current-buffer))))
+ (when proc (set-process-sentinel proc #'sql-stop)))
;; Save the connection and login params
(set (make-local-variable 'sql-user) sql-user)
(set (make-local-variable 'sql-database) sql-database)
@@ -3993,7 +4374,7 @@ you entered, right above the output it created.
(sql-make-alternate-buffer-name))
;; User stuff. Initialize before the hook.
(set (make-local-variable 'sql-prompt-regexp)
- (sql-get-product-feature sql-product :prompt-regexp))
+ (or (sql-get-product-feature sql-product :prompt-regexp) "^"))
(set (make-local-variable 'sql-prompt-length)
(sql-get-product-feature sql-product :prompt-length))
(set (make-local-variable 'sql-prompt-cont-regexp)
@@ -4001,7 +4382,7 @@ you entered, right above the output it created.
(make-local-variable 'sql-output-newline-count)
(make-local-variable 'sql-preoutput-hold)
(add-hook 'comint-preoutput-filter-functions
- 'sql-interactive-remove-continuation-prompt nil t)
+ #'sql-interactive-remove-continuation-prompt nil t)
(make-local-variable 'sql-input-ring-separator)
(make-local-variable 'sql-input-ring-file-name)
;; Run the mode hook (along with comint's hooks).
@@ -4012,7 +4393,7 @@ you entered, right above the output it created.
(concat "\\(" sql-prompt-regexp
"\\|" sql-prompt-cont-regexp "\\)")
sql-prompt-regexp))
- (setq left-margin sql-prompt-length)
+ (setq left-margin (or sql-prompt-length 0))
;; Install input sender
(set (make-local-variable 'comint-input-sender) 'sql-input-sender)
;; People wanting a different history file for each
@@ -4031,15 +4412,16 @@ Writes the input history to a history file using
This function is a sentinel watching the SQL interpreter process.
Sentinels will always get the two parameters PROCESS and EVENT."
- (with-current-buffer (process-buffer process)
- (let
- ((comint-input-ring-separator sql-input-ring-separator)
- (comint-input-ring-file-name sql-input-ring-file-name))
- (comint-write-input-ring))
+ (when (buffer-live-p (process-buffer process))
+ (with-current-buffer (process-buffer process)
+ (let
+ ((comint-input-ring-separator sql-input-ring-separator)
+ (comint-input-ring-file-name sql-input-ring-file-name))
+ (comint-write-input-ring))
- (if (not buffer-read-only)
- (insert (format "\nProcess %s %s\n" process event))
- (message "Process %s %s" process event))))
+ (if (not buffer-read-only)
+ (insert (format "\nProcess %s %s\n" process event))
+ (message "Process %s %s" process event)))))
@@ -4049,8 +4431,7 @@ Sentinels will always get the two parameters PROCESS and EVENT."
"Read a connection name."
(let ((completion-ignore-case t))
(completing-read prompt
- (mapcar (lambda (c) (car c))
- sql-connection-alist)
+ (mapcar #'car sql-connection-alist)
nil t initial 'sql-connection-history default)))
;;;###autoload
@@ -4099,11 +4480,11 @@ is specified in the connection settings."
(mapcar
(lambda (v)
(pcase (car v)
- (`sql-user 'user)
- (`sql-password 'password)
- (`sql-server 'server)
- (`sql-database 'database)
- (`sql-port 'port)
+ ('sql-user 'user)
+ ('sql-password 'password)
+ ('sql-server 'server)
+ ('sql-database 'database)
+ ('sql-port 'port)
(s s)))
connect-set))
@@ -4167,11 +4548,11 @@ optionally is saved to the user's init file."
`(product ,@login)
(lambda (token _plist)
(pcase token
- (`product `(sql-product ',product))
- (`user `(sql-user ,user))
- (`database `(sql-database ,database))
- (`server `(sql-server ,server))
- (`port `(sql-port ,port)))))))
+ ('product `(sql-product ',product))
+ ('user `(sql-user ,user))
+ ('database `(sql-database ,database))
+ ('server `(sql-server ,server))
+ ('port `(sql-port ,port)))))))
(setq alist (append alist (list connect)))
@@ -4215,31 +4596,30 @@ the call to \\[sql-product-interactive] with
;; Handle universal arguments if specified
(when (not (or executing-kbd-macro noninteractive))
- (when (and (consp product)
- (not (cdr product))
- (numberp (car product)))
- (when (>= (prefix-numeric-value product) 16)
- (when (not new-name)
- (setq new-name '(4)))
- (setq product '(4)))))
+ (when (>= (prefix-numeric-value product) 16)
+ (when (not new-name)
+ (setq new-name '(4)))
+ (setq product '(4))))
;; Get the value of product that we need
(setq product
(cond
((= (prefix-numeric-value product) 4) ; C-u, prompt for product
(sql-read-product "SQL product: " sql-product))
- ((and product ; Product specified
- (symbolp product)) product)
+ ((assoc product sql-product-alist) ; Product specified
+ product)
(t sql-product))) ; Default to sql-product
;; If we have a product and it has an interactive mode
(if product
(when (sql-get-product-feature product :sqli-comint-func)
- ;; If no new name specified, try to pop to an active SQL
- ;; interactive for the same product
+ ;; If no new name specified or new name in buffer name,
+ ;; try to pop to an active SQL interactive for the same product
(let ((buf (sql-find-sqli-buffer product sql-connection)))
- (if (and (not new-name) buf)
- (pop-to-buffer buf)
+ (if (and buf (or (not new-name)
+ (and (stringp new-name)
+ (string-match-p (regexp-quote new-name) buf))))
+ (sql-display-buffer buf)
;; We have a new name or sql-buffer doesn't exist or match
;; Start by remembering where we start
@@ -4251,34 +4631,41 @@ the call to \\[sql-product-interactive] with
(sql-get-product-feature product :sqli-login))
;; Connect to database.
- (setq rpt (make-progress-reporter "Login"))
+ (setq rpt (sql-make-progress-reporter nil "Login"))
(let ((sql-user (default-value 'sql-user))
(sql-password (default-value 'sql-password))
(sql-server (default-value 'sql-server))
(sql-database (default-value 'sql-database))
(sql-port (default-value 'sql-port))
- (default-directory (or sql-default-directory
- default-directory)))
+ (default-directory
+ (or sql-default-directory
+ default-directory)))
+
+ ;; The password wallet returns a function which supplies the password.
+ (when (functionp sql-password)
+ (setq sql-password (funcall sql-password)))
+
+ ;; Call the COMINT service
(funcall (sql-get-product-feature product :sqli-comint-func)
product
(sql-get-product-feature product :sqli-options)
+ ;; generate a buffer name
(cond
- ((null new-name)
- "*SQL*")
- ((stringp new-name)
- (if (string-prefix-p "*SQL: " new-name t)
- new-name
- (concat "*SQL: " new-name "*")))
- ((equal new-name '(4))
- (concat
- "*SQL: "
+ ((not new-name)
+ (sql-generate-unique-sqli-buffer-name product nil))
+ ((consp new-name)
+ (sql-generate-unique-sqli-buffer-name product
(read-string
"Buffer name (\"*SQL: XXX*\"; enter `XXX'): "
- sql-alternate-buffer-name)
- "*"))
+ (sql-make-alternate-buffer-name product))))
+ ((or (string-prefix-p " " new-name)
+ (string-match-p "\\`[*].*[*]\\'" new-name))
+ new-name)
+ ((stringp new-name)
+ (sql-generate-unique-sqli-buffer-name product new-name))
(t
- (format "*SQL: %s*" new-name)))))
+ (sql-generate-unique-sqli-buffer-name product nil)))))
;; Set SQLi mode.
(let ((sql-interactive-product product))
@@ -4301,30 +4688,32 @@ the call to \\[sql-product-interactive] with
(let ((proc (get-buffer-process new-sqli-buffer))
(secs sql-login-delay)
(step 0.3))
- (while (and (memq (process-status proc) '(open run))
+ (while (and proc
+ (memq (process-status proc) '(open run))
(or (accept-process-output proc step)
(<= 0.0 (setq secs (- secs step))))
(progn (goto-char (point-max))
(not (re-search-backward sql-prompt-regexp 0 t))))
- (progress-reporter-update rpt)))
+ (sql-progress-reporter-update rpt)))
(goto-char (point-max))
(when (re-search-backward sql-prompt-regexp nil t)
(run-hooks 'sql-login-hook))
;; All done.
- (progress-reporter-done rpt)
- (pop-to-buffer new-sqli-buffer)
+ (sql-progress-reporter-done rpt)
(goto-char (point-max))
- (current-buffer)))))
- (user-error "No default SQL product defined. Set `sql-product'.")))
+ (let ((sql-display-sqli-buffer-function t))
+ (sql-display-buffer new-sqli-buffer))
+ (get-buffer new-sqli-buffer)))))
+ (user-error "No default SQL product defined: set `sql-product'")))
(defun sql-comint (product params &optional buf-name)
"Set up a comint buffer to run the SQL processor.
PRODUCT is the SQL product. PARAMS is a list of strings which are
passed as command line arguments. BUF-NAME is the name of the new
-buffer. If nil, a name is chosen for it."
+buffer. If nil, a name is chosen for it."
(let ((program (sql-get-product-feature product :sqli-program)))
;; Make sure we can find the program. `executable-find' does not
@@ -4337,15 +4726,10 @@ buffer. If nil, a name is chosen for it."
;; if not specified, try *SQL* then *SQL-product*, then *SQL-product1*, ...
;; otherwise, use *buf-name*
(if buf-name
- (unless (string-match-p "\\`[*].*[*]\\'" buf-name)
+ (unless (or (string-prefix-p " " buf-name)
+ (string-match-p "\\`[*].*[*]\\'" buf-name))
(setq buf-name (concat "*" buf-name "*")))
- (setq buf-name "*SQL*")
- (when (sql-buffer-live-p buf-name)
- (setq buf-name (format "*SQL-%s*" product)))
- (let ((i 1))
- (while (sql-buffer-live-p buf-name)
- (setq buf-name (format "*SQL-%s%d*" product i)
- i (1+ i)))))
+ (setq buf-name (sql-generate-unique-sqli-buffer-name product nil)))
(set-text-properties 0 (length buf-name) nil buf-name)
;; Start the command interpreter in the buffer
@@ -4426,7 +4810,8 @@ The default comes from `process-coding-system-alist' and
(or coding 'utf-8))
(when (string-match (format "\\.%s\\'" (car cs)) nlslang)
(setq coding (cdr cs)))))
- (set-buffer-process-coding-system coding coding)))
+ (set-process-coding-system (get-buffer-process (current-buffer))
+ coding coding)))
(defun sql-oracle-save-settings (sqlbuf)
"Save most SQL*Plus settings so they may be reset by \\[sql-redirect]."
@@ -4787,6 +5172,46 @@ The default comes from `process-coding-system-alist' and
(list sql-database)))))
(sql-comint product params buf-name)))
+;;;###autoload
+(defun sql-mariadb (&optional buffer)
+ "Run mysql by MariaDB as an inferior process.
+
+MariaDB is free software.
+
+If buffer `*SQL*' exists but no process is running, make a new process.
+If buffer exists and a process is running, just switch to buffer
+`*SQL*'.
+
+Interpreter used comes from variable `sql-mariadb-program'. Login uses
+the variables `sql-user', `sql-password', `sql-database', and
+`sql-server' as defaults, if set. Additional command line parameters
+can be stored in the list `sql-mariadb-options'.
+
+The buffer is put in SQL interactive mode, giving commands for sending
+input. See `sql-interactive-mode'.
+
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-mariadb]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
+To specify a coding system for converting non-ASCII characters
+in the input and output to the process, use \\[universal-coding-system-argument]
+before \\[sql-mariadb]. You can also specify this with \\[set-buffer-process-coding-system]
+in the SQL buffer, after you start the process.
+The default comes from `process-coding-system-alist' and
+`default-process-coding-system'.
+
+\(Type \\[describe-mode] in the SQL buffer for a list of commands.)"
+ (interactive "P")
+ (sql-product-interactive 'mariadb buffer))
+
+(defun sql-comint-mariadb (product options &optional buf-name)
+ "Create comint buffer and connect to MariaDB.
+
+Use the MySQL comint driver since the two are compatible."
+ (sql-comint-mysql product options buf-name))
+
;;;###autoload
@@ -4968,8 +5393,7 @@ The default comes from `process-coding-system-alist' and
your might try undecided-dos as a coding system. If this doesn't help,
Try to set `comint-output-filter-functions' like this:
-\(setq comint-output-filter-functions (append comint-output-filter-functions
- \\='(comint-strip-ctrl-m)))
+\(add-hook 'comint-output-filter-functions #\\='comint-strip-ctrl-m 'append)
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)"
(interactive "P")
diff --git a/lisp/progmodes/subword.el b/lisp/progmodes/subword.el
index a188168c04f..58a266c117e 100644
--- a/lisp/progmodes/subword.el
+++ b/lisp/progmodes/subword.el
@@ -93,9 +93,6 @@
;;;###autoload
(define-minor-mode subword-mode
"Toggle subword movement and editing (Subword mode).
-With a prefix argument ARG, enable Subword mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Subword mode is a buffer-local minor mode. Enabling it changes
the definition of a word so that word-based commands stop inside
@@ -148,8 +145,6 @@ Optional argument ARG is the same as for `forward-word'."
(t
(point))))
-(put 'subword-forward 'CUA 'move)
-
(defun subword-backward (&optional arg)
"Do the same as `backward-word' but on subwords.
See the command `subword-mode' for a description of subwords.
@@ -190,8 +185,6 @@ Optional argument ARG is the same as for `mark-word'."
(point))
nil t))))
-(put 'subword-backward 'CUA 'move)
-
(defun subword-kill (arg)
"Do the same as `kill-word' but on subwords.
See the command `subword-mode' for a description of subwords.
@@ -267,9 +260,6 @@ Optional argument ARG is the same as for `capitalize-word'."
;;;###autoload
(define-minor-mode superword-mode
"Toggle superword movement and editing (Superword mode).
-With a prefix argument ARG, enable Superword mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Superword mode is a buffer-local minor mode. Enabling it changes
the definition of words such that symbols characters are treated
diff --git a/lisp/progmodes/tcl.el b/lisp/progmodes/tcl.el
index 3ebb311212e..ffb3d41ab62 100644
--- a/lisp/progmodes/tcl.el
+++ b/lisp/progmodes/tcl.el
@@ -360,7 +360,7 @@ Add functions to the hook with `add-hook':
(defvar tcl-proc-list
- '("proc" "method" "itcl_class" "body" "configbody" "class")
+ '("proc" "method" "itcl_class" "body" "configbody" "class" "namespace")
"List of commands whose first argument defines something.
This exists because some people (eg, me) use `defvar' et al.
Call `tcl-set-proc-regexp' and `tcl-set-font-lock-keywords'
@@ -611,6 +611,9 @@ already exist."
(set (make-local-variable 'add-log-current-defun-function)
'tcl-add-log-defun)
+ (setq-local beginning-of-defun-function #'tcl-beginning-of-defun-function)
+ (setq-local end-of-defun-function #'tcl-end-of-defun-function)
+
(easy-menu-add tcl-mode-menu)
;; Append Tcl menu to popup menu for XEmacs.
(if (boundp 'mode-popup-menu)
@@ -993,15 +996,49 @@ Returns nil if line starts inside a string, t if in a comment."
;; Interfaces to other packages.
;;
-;; FIXME Definition of function is very ad-hoc. Should use
-;; beginning-of-defun. Also has incestuous knowledge about the
-;; format of tcl-proc-regexp.
+(defun tcl-beginning-of-defun-function (&optional arg)
+ "`beginning-of-defun-function' for Tcl mode."
+ (when (or (not arg) (= arg 0))
+ (setq arg 1))
+ (let* ((search-fn (if (> arg 0)
+ ;; Positive arg means to search backward.
+ #'re-search-backward
+ #'re-search-forward))
+ (arg (abs arg))
+ (result t))
+ (while (and (> arg 0) result)
+ (unless (funcall search-fn tcl-proc-regexp nil t)
+ (setq result nil))
+ (setq arg (1- arg)))
+ result))
+
+(defun tcl-end-of-defun-function ()
+ "`end-of-defun-function' for Tcl mode."
+ ;; Because we let users redefine tcl-proc-list, we don't really know
+ ;; too much about the exact arguments passed to the "proc"-defining
+ ;; command. Instead we just skip words and lists until we see
+ ;; either a ";" or a newline, either of which terminates a command.
+ (skip-syntax-forward "-")
+ (while (and (not (eobp))
+ (not (looking-at-p "[\n;]")))
+ (condition-case nil
+ (forward-sexp)
+ (scan-error
+ (goto-char (point-max))))
+ ;; Note that here we do not want to skip \n.
+ (skip-chars-forward " \t")))
+
(defun tcl-add-log-defun ()
"Return name of Tcl function point is in, or nil."
(save-excursion
- (end-of-line)
- (if (re-search-backward (concat tcl-proc-regexp "\\([^ \t\n{]+\\)") nil t)
- (match-string 2))))
+ (let ((orig-point (point)))
+ (when (beginning-of-defun)
+ ;; Only return the name when in the body of the function.
+ (when (save-excursion
+ (end-of-defun)
+ (>= (point) orig-point))
+ (when (looking-at (concat tcl-proc-regexp "\\([^ \t\n{]+\\)"))
+ (match-string 2)))))))
(defun tcl-outline-level ()
(save-excursion
diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el
index e92647dbbac..9226291ffbb 100644
--- a/lisp/progmodes/verilog-mode.el
+++ b/lisp/progmodes/verilog-mode.el
@@ -108,7 +108,6 @@
;; verilog-minimum-comment-distance 40
;; verilog-indent-begin-after-if t
;; verilog-auto-lineup 'declarations
-;; verilog-highlight-p1800-keywords nil
;; verilog-linter "my_lint_shell_command"
;; )
@@ -122,7 +121,7 @@
;;
;; This variable will always hold the version number of the mode
-(defconst verilog-mode-version "2017-08-07-c085e50-vpo-GNU"
+(defconst verilog-mode-version "2019-04-02-5d62d3f-vpo-GNU"
"Version of this Verilog mode.")
(defconst verilog-mode-release-emacs t
"If non-nil, this version of Verilog mode was released with Emacs itself.")
@@ -238,7 +237,7 @@ STRING should be given if the last search was by `string-match' on STRING."
(unless (featurep 'xemacs)
(unless (fboundp 'region-active-p)
(defmacro region-active-p ()
- `(and transient-mark-mode mark-active))))
+ '(and transient-mark-mode mark-active))))
)
;; Provide a regular expression optimization routine, using regexp-opt
@@ -250,7 +249,7 @@ STRING should be given if the last search was by `string-match' on STRING."
(if (fboundp 'regexp-opt)
;; regexp-opt is defined, does it take 3 or 2 arguments?
(if (fboundp 'function-max-args)
- (let ((args (function-max-args `regexp-opt)))
+ (let ((args (function-max-args 'regexp-opt)))
(cond
((eq args 3) ; It takes 3
(condition-case nil ; Hide this defun from emacses
@@ -382,7 +381,7 @@ wherever possible, since it is slow."
((vectorp menu)
(let ((i 0) (out []))
(while (< i (length menu))
- (if (equal `:help (aref menu i))
+ (if (equal :help (aref menu i))
(setq i (+ 2 i))
(setq out (vconcat out (vector (aref menu i)))
i (1+ i))))
@@ -719,15 +718,13 @@ default avoids too many redundant comments in tight quarters."
(put 'verilog-minimum-comment-distance 'safe-local-variable 'integerp)
(defcustom verilog-highlight-p1800-keywords nil
- "Non-nil means highlight words newly reserved by IEEE-1800.
-These will appear in `verilog-font-lock-p1800-face' in order to gently
-suggest changing where these words are used as variables to something else.
-A nil value means highlight these words as appropriate for the SystemVerilog
-IEEE-1800 standard. Note that changing this will require restarting Emacs
-to see the effect as font color choices are cached by Emacs."
+ "Obsolete.
+Was non-nil means highlight SystemVerilog IEEE-1800 differently.
+All code is now highlighted as if SystemVerilog IEEE-1800."
:group 'verilog-mode-indent
:type 'boolean)
(put 'verilog-highlight-p1800-keywords 'safe-local-variable 'verilog-booleanp)
+(make-obsolete-variable 'verilog-highlight-p1800-keywords nil "27.1")
(defcustom verilog-highlight-grouping-keywords nil
"Non-nil means highlight grouping keywords more dramatically.
@@ -1070,6 +1067,18 @@ of each Verilog file that requires it, rather than being set globally."
:type 'boolean)
(put 'verilog-auto-sense-defines-constant 'safe-local-variable 'verilog-booleanp)
+(defcustom verilog-auto-simplify-expressions t
+ "Non-nil means AUTOs will simplify expressions when calculating bit ranges.
+When nil, do not simply ranges, which may simplify the output,
+but may cause problems when there are multiple instantiations
+outputting to the same wire. To maintain compatibility with
+other sites, this should be set at the bottom of each Verilog
+file that requires it, rather than being set globally."
+ :version "27.1"
+ :group 'verilog-mode-auto
+ :type 'boolean)
+(put 'verilog-auto-simplify-expressions 'safe-local-variable 'verilog-booleanp)
+
(defcustom verilog-auto-reset-blocking-in-non t
"Non-nil means AUTORESET will reset blocking statements.
When true, AUTORESET will reset in blocking statements those
@@ -1276,6 +1285,13 @@ See the \\[verilog-faq] for examples on using this."
:type '(choice (const nil) regexp))
(put 'verilog-auto-input-ignore-regexp 'safe-local-variable 'stringp)
+(defcustom verilog-auto-reg-input-assigned-ignore-regexp nil
+ "If non-nil, when creating AUTOINPUTREG, ignore signals matching this regexp."
+ :version "27.1"
+ :group 'verilog-mode-auto
+ :type '(choice (const nil) regexp))
+(put 'verilog-auto-reg-input-assigned-ignore-regexp 'safe-local-variable 'stringp)
+
(defcustom verilog-auto-inout-ignore-regexp nil
"If non-nil, when creating AUTOINOUT, ignore signals matching this regexp.
See the \\[verilog-faq] for examples on using this."
@@ -1389,7 +1405,7 @@ See also `verilog-case-fold'."
("*Variables*" "^\\s-*\\(reg\\|wire\\|logic\\)\\s-+\\(\\|\\[[^]]+\\]\\s-+\\)\\([A-Za-z0-9_]+\\)" 3)
("*Classes*" "^\\s-*\\(?:\\(?:virtual\\|interface\\)\\s-+\\)?class\\s-+\\([A-Za-z_][A-Za-z0-9_]+\\)" 1)
("*Tasks*" "^\\s-*\\(?:\\(?:static\\|pure\\|virtual\\|local\\|protected\\)\\s-+\\)*task\\s-+\\(?:\\(?:static\\|automatic\\)\\s-+\\)?\\([A-Za-z_][A-Za-z0-9_:]+\\)" 1)
- ("*Functions*" "^\\s-*\\(?:\\(?:static\\|pure\\|virtual\\|local\\|protected\\)\\s-+\\)*function\\s-+\\(?:\\(?:static\\|automatic\\)\\s-+\\)?\\(?:\\w+\\s-+\\)?\\([A-Za-z_][A-Za-z0-9_:]+\\)" 1)
+ ("*Functions*" "^\\s-*\\(?:\\(?:static\\|pure\\|virtual\\|local\\|protected\\)\\s-+\\)*function\\s-+\\(?:\\(?:static\\|automatic\\)\\s-+\\)?\\(?:\\w+\\s-+\\)?\\(?:\\(?:un\\)signed\\s-+\\)?\\([A-Za-z_][A-Za-z0-9_:]+\\)" 1)
("*Interfaces*" "^\\s-*interface\\s-+\\([a-zA-Z_0-9]+\\)" 1)
("*Types*" "^\\s-*typedef\\s-+.*\\s-+\\([a-zA-Z_0-9]+\\)\\s-*;" 1))
"Imenu expression for Verilog mode. See `imenu-generic-expression'.")
@@ -1432,7 +1448,7 @@ If set will become buffer local.")
(define-key map [(meta delete)] 'kill-word))
(define-key map "\M-\C-b" 'electric-verilog-backward-sexp)
(define-key map "\M-\C-f" 'electric-verilog-forward-sexp)
- (define-key map "\M-\r" `electric-verilog-terminate-and-indent)
+ (define-key map "\M-\r" 'electric-verilog-terminate-and-indent)
(define-key map "\M-\t" (if (fboundp 'completion-at-point)
'completion-at-point 'verilog-complete-word))
(define-key map "\M-?" (if (fboundp 'completion-help-at-point)
@@ -1481,35 +1497,35 @@ If set will become buffer local.")
(setq verilog-tool 'verilog-linter)
(verilog-set-compile-command))
:style radio
- :selected (equal verilog-tool `verilog-linter)
+ :selected (equal verilog-tool 'verilog-linter)
:help "When invoking compilation, use lint checker"]
["Coverage"
(progn
(setq verilog-tool 'verilog-coverage)
(verilog-set-compile-command))
:style radio
- :selected (equal verilog-tool `verilog-coverage)
+ :selected (equal verilog-tool 'verilog-coverage)
:help "When invoking compilation, annotate for coverage"]
["Simulator"
(progn
(setq verilog-tool 'verilog-simulator)
(verilog-set-compile-command))
:style radio
- :selected (equal verilog-tool `verilog-simulator)
+ :selected (equal verilog-tool 'verilog-simulator)
:help "When invoking compilation, interpret Verilog source"]
["Compiler"
(progn
(setq verilog-tool 'verilog-compiler)
(verilog-set-compile-command))
:style radio
- :selected (equal verilog-tool `verilog-compiler)
+ :selected (equal verilog-tool 'verilog-compiler)
:help "When invoking compilation, compile Verilog source"]
["Preprocessor"
(progn
(setq verilog-tool 'verilog-preprocessor)
(verilog-set-compile-command))
:style radio
- :selected (equal verilog-tool `verilog-preprocessor)
+ :selected (equal verilog-tool 'verilog-preprocessor)
:help "When invoking compilation, preprocess Verilog source, see also `verilog-preprocess'"]
)
("Move"
@@ -1728,29 +1744,29 @@ If set will become buffer local.")
:enable-function (lambda () (not (verilog-in-comment-or-string-p))))
(verilog-define-abbrev verilog-mode-abbrev-table "class" "" 'verilog-sk-ovm-class)
(verilog-define-abbrev verilog-mode-abbrev-table "always" "" 'verilog-sk-always)
-(verilog-define-abbrev verilog-mode-abbrev-table "begin" nil `verilog-sk-begin)
-(verilog-define-abbrev verilog-mode-abbrev-table "case" "" `verilog-sk-case)
-(verilog-define-abbrev verilog-mode-abbrev-table "for" "" `verilog-sk-for)
-(verilog-define-abbrev verilog-mode-abbrev-table "generate" "" `verilog-sk-generate)
-(verilog-define-abbrev verilog-mode-abbrev-table "initial" "" `verilog-sk-initial)
-(verilog-define-abbrev verilog-mode-abbrev-table "fork" "" `verilog-sk-fork)
-(verilog-define-abbrev verilog-mode-abbrev-table "module" "" `verilog-sk-module)
-(verilog-define-abbrev verilog-mode-abbrev-table "primitive" "" `verilog-sk-primitive)
-(verilog-define-abbrev verilog-mode-abbrev-table "repeat" "" `verilog-sk-repeat)
-(verilog-define-abbrev verilog-mode-abbrev-table "specify" "" `verilog-sk-specify)
-(verilog-define-abbrev verilog-mode-abbrev-table "task" "" `verilog-sk-task)
-(verilog-define-abbrev verilog-mode-abbrev-table "while" "" `verilog-sk-while)
-(verilog-define-abbrev verilog-mode-abbrev-table "casex" "" `verilog-sk-casex)
-(verilog-define-abbrev verilog-mode-abbrev-table "casez" "" `verilog-sk-casez)
-(verilog-define-abbrev verilog-mode-abbrev-table "if" "" `verilog-sk-if)
-(verilog-define-abbrev verilog-mode-abbrev-table "else if" "" `verilog-sk-else-if)
-(verilog-define-abbrev verilog-mode-abbrev-table "assign" "" `verilog-sk-assign)
-(verilog-define-abbrev verilog-mode-abbrev-table "function" "" `verilog-sk-function)
-(verilog-define-abbrev verilog-mode-abbrev-table "input" "" `verilog-sk-input)
-(verilog-define-abbrev verilog-mode-abbrev-table "output" "" `verilog-sk-output)
-(verilog-define-abbrev verilog-mode-abbrev-table "inout" "" `verilog-sk-inout)
-(verilog-define-abbrev verilog-mode-abbrev-table "wire" "" `verilog-sk-wire)
-(verilog-define-abbrev verilog-mode-abbrev-table "reg" "" `verilog-sk-reg)
+(verilog-define-abbrev verilog-mode-abbrev-table "begin" nil 'verilog-sk-begin)
+(verilog-define-abbrev verilog-mode-abbrev-table "case" "" 'verilog-sk-case)
+(verilog-define-abbrev verilog-mode-abbrev-table "for" "" 'verilog-sk-for)
+(verilog-define-abbrev verilog-mode-abbrev-table "generate" "" 'verilog-sk-generate)
+(verilog-define-abbrev verilog-mode-abbrev-table "initial" "" 'verilog-sk-initial)
+(verilog-define-abbrev verilog-mode-abbrev-table "fork" "" 'verilog-sk-fork)
+(verilog-define-abbrev verilog-mode-abbrev-table "module" "" 'verilog-sk-module)
+(verilog-define-abbrev verilog-mode-abbrev-table "primitive" "" 'verilog-sk-primitive)
+(verilog-define-abbrev verilog-mode-abbrev-table "repeat" "" 'verilog-sk-repeat)
+(verilog-define-abbrev verilog-mode-abbrev-table "specify" "" 'verilog-sk-specify)
+(verilog-define-abbrev verilog-mode-abbrev-table "task" "" 'verilog-sk-task)
+(verilog-define-abbrev verilog-mode-abbrev-table "while" "" 'verilog-sk-while)
+(verilog-define-abbrev verilog-mode-abbrev-table "casex" "" 'verilog-sk-casex)
+(verilog-define-abbrev verilog-mode-abbrev-table "casez" "" 'verilog-sk-casez)
+(verilog-define-abbrev verilog-mode-abbrev-table "if" "" 'verilog-sk-if)
+(verilog-define-abbrev verilog-mode-abbrev-table "else if" "" 'verilog-sk-else-if)
+(verilog-define-abbrev verilog-mode-abbrev-table "assign" "" 'verilog-sk-assign)
+(verilog-define-abbrev verilog-mode-abbrev-table "function" "" 'verilog-sk-function)
+(verilog-define-abbrev verilog-mode-abbrev-table "input" "" 'verilog-sk-input)
+(verilog-define-abbrev verilog-mode-abbrev-table "output" "" 'verilog-sk-output)
+(verilog-define-abbrev verilog-mode-abbrev-table "inout" "" 'verilog-sk-inout)
+(verilog-define-abbrev verilog-mode-abbrev-table "wire" "" 'verilog-sk-wire)
+(verilog-define-abbrev verilog-mode-abbrev-table "reg" "" 'verilog-sk-reg)
;;
;; Macros
@@ -2044,7 +2060,7 @@ find the errors."
"`resetall" "`timescale" "`unconnected_drive" "`undef" "`undefineall"
;; compiler directives not covered by IEEE 1800
"`case" "`default" "`endfor" "`endprotect" "`endswitch" "`endwhile" "`for"
- "`format" "`if" "`let" "`protect" "`switch" "`timescale" "`time_scale"
+ "`format" "`if" "`let" "`protect" "`switch" "`time_scale"
"`while"
))
"List of Verilog compiler directives.")
@@ -2135,14 +2151,7 @@ find the errors."
) nil ) ) )
(defconst verilog-vmm-statement-re
- (eval-when-compile
- (verilog-regexp-opt
- '(
- "`vmm_\\(data\\|env\\|scenario\\|subenv\\|xactor\\)_member_\\(scalar\\|string\\|enum\\|vmm_data\\|channel\\|xactor\\|subenv\\|user_defined\\)\\(_array\\)?"
- ;; "`vmm_xactor_member_enum_array"
- ;; "`vmm_xactor_member_scalar_array"
- ;; "`vmm_xactor_member_scalar"
- ) nil )))
+ "`vmm_\\(data\\|env\\|scenario\\|subenv\\|xactor\\)_member_\\(scalar\\|string\\|enum\\|vmm_data\\|channel\\|xactor\\|subenv\\|user_defined\\)\\(_array\\)?")
(defconst verilog-ovm-statement-re
(eval-when-compile
@@ -2402,12 +2411,10 @@ find the errors."
(defconst verilog-assignment-operator-re
(eval-when-compile
(verilog-regexp-opt
- `(
+ '(
;; blocking assignment_operator
"=" "+=" "-=" "*=" "/=" "%=" "&=" "|=" "^=" "<<=" ">>=" "<<<=" ">>>="
- ;; non blocking assignment operator
- "<="
- ;; comparison
+ ;; comparison (also nonblocking assignment "<=")
"==" "!=" "===" "!==" "<=" ">=" "==?" "!=?" "<->"
;; event_trigger
"->" "->>"
@@ -2478,7 +2485,7 @@ find the errors."
verilog-directive-re "\\)\\|\\("
(eval-when-compile
(verilog-regexp-words
- `( "begin"
+ '( "begin"
"else"
"end"
"endcase"
@@ -2531,7 +2538,7 @@ find the errors."
(eval-when-compile
(verilog-regexp-words
- `("end" ; closes begin
+ '("end" ; closes begin
"endcase" ; closes any of case, casex casez or randcase
"join" "join_any" "join_none" ; closes fork
"endclass"
@@ -2601,7 +2608,7 @@ find the errors."
(defconst verilog-beg-block-re
(eval-when-compile
(verilog-regexp-words
- `("begin"
+ '("begin"
"case" "casex" "casez" "randcase"
"clocking"
"generate"
@@ -2677,7 +2684,7 @@ find the errors."
(defconst verilog-nameable-item-re
(eval-when-compile
(verilog-regexp-words
- `("begin"
+ '("begin"
"fork"
"join" "join_any" "join_none"
"end"
@@ -2704,12 +2711,12 @@ find the errors."
(defconst verilog-declaration-opener
(eval-when-compile
(verilog-regexp-words
- `("module" "begin" "task" "function"))))
+ '("module" "begin" "task" "function"))))
(defconst verilog-declaration-prefix-re
(eval-when-compile
(verilog-regexp-words
- `(
+ '(
;; port direction
"inout" "input" "output" "ref"
;; changeableness
@@ -2718,11 +2725,13 @@ find the errors."
"localparam" "parameter" "var"
;; type creation
"typedef"
+ ;; randomness
+ "rand"
))))
(defconst verilog-declaration-core-re
(eval-when-compile
(verilog-regexp-words
- `(
+ '(
;; port direction (by themselves)
"inout" "input" "output"
;; integer_atom_type
@@ -2764,25 +2773,25 @@ find the errors."
(defconst verilog-declaration-re-1-no-macro (concat "^" verilog-declaration-re-2-no-macro))
(defconst verilog-defun-re
- (eval-when-compile (verilog-regexp-words `("macromodule" "module" "class" "program" "interface" "package" "primitive" "config"))))
+ (eval-when-compile (verilog-regexp-words '("macromodule" "module" "class" "program" "interface" "package" "primitive" "config"))))
(defconst verilog-end-defun-re
- (eval-when-compile (verilog-regexp-words `("endmodule" "endclass" "endprogram" "endinterface" "endpackage" "endprimitive" "endconfig"))))
+ (eval-when-compile (verilog-regexp-words '("endmodule" "endclass" "endprogram" "endinterface" "endpackage" "endprimitive" "endconfig"))))
(defconst verilog-zero-indent-re
(concat verilog-defun-re "\\|" verilog-end-defun-re))
(defconst verilog-inst-comment-re
- (eval-when-compile (verilog-regexp-words `("Outputs" "Inouts" "Inputs" "Interfaces" "Interfaced"))))
+ (eval-when-compile (verilog-regexp-words '("Outputs" "Inouts" "Inputs" "Interfaces" "Interfaced"))))
(defconst verilog-behavioral-block-beg-re
- (eval-when-compile (verilog-regexp-words `("initial" "final" "always" "always_comb" "always_latch" "always_ff"
- "function" "task"))))
-(defconst verilog-coverpoint-re "\\w+\\s*:\\s*\\(coverpoint\\|cross\\constraint\\)" )
+ (eval-when-compile (verilog-regexp-words '("initial" "final" "always" "always_comb" "always_latch" "always_ff"
+ "function" "task"))))
+(defconst verilog-coverpoint-re "\\w+\\s-*:\\s-*\\(coverpoint\\|cross\\|constraint\\)")
(defconst verilog-in-constraint-re ; keywords legal in constraint blocks starting a statement/block
- (eval-when-compile (verilog-regexp-words `("if" "else" "solve" "foreach"))))
+ (eval-when-compile (verilog-regexp-words '("if" "else" "solve" "foreach"))))
(defconst verilog-indent-re
(eval-when-compile
(verilog-regexp-words
- `(
+ '(
"{"
"always" "always_latch" "always_ff" "always_comb"
"begin" "end"
@@ -2866,28 +2875,28 @@ find the errors."
(defconst verilog-defun-level-not-generate-re
(eval-when-compile
(verilog-regexp-words
- `( "module" "macromodule" "primitive" "class" "program"
- "interface" "package" "config"))))
+ '( "module" "macromodule" "primitive" "class" "program"
+ "interface" "package" "config"))))
(defconst verilog-defun-level-re
(eval-when-compile
(verilog-regexp-words
(append
- `( "module" "macromodule" "primitive" "class" "program"
- "interface" "package" "config")
- `( "initial" "final" "always" "always_comb" "always_ff"
- "always_latch" "endtask" "endfunction" )))))
+ '( "module" "macromodule" "primitive" "class" "program"
+ "interface" "package" "config")
+ '( "initial" "final" "always" "always_comb" "always_ff"
+ "always_latch" "endtask" "endfunction" )))))
(defconst verilog-defun-level-generate-only-re
(eval-when-compile
(verilog-regexp-words
- `( "initial" "final" "always" "always_comb" "always_ff"
- "always_latch" "endtask" "endfunction" ))))
+ '( "initial" "final" "always" "always_comb" "always_ff"
+ "always_latch" "endtask" "endfunction" ))))
(defconst verilog-cpp-level-re
(eval-when-compile
(verilog-regexp-words
- `(
+ '(
"endmodule" "endprimitive" "endinterface" "endpackage" "endprogram" "endclass"
))))
@@ -2908,7 +2917,7 @@ find the errors."
(defconst verilog-basic-complete-re
(eval-when-compile
(verilog-regexp-words
- `(
+ '(
"always" "assign" "always_latch" "always_ff" "always_comb" "constraint"
"import" "initial" "final" "module" "macromodule" "repeat" "randcase" "while"
"if" "for" "forever" "foreach" "else" "parameter" "do" "localparam" "assert"
@@ -2937,7 +2946,7 @@ find the errors."
;; single words
"\\(?:"
(verilog-regexp-words
- `("`__FILE__"
+ '("`__FILE__"
"`__LINE__"
"`celldefine"
"`else"
@@ -2962,9 +2971,10 @@ find the errors."
"\\<\\(`pragma\\)\\>\\s-+.+$"
"\\)\\|\\(?:"
;; `timescale time_unit / time_precision
- "\\<\\(`timescale\\)\\>\\s-+10\\{0,2\\}\\s-*[munpf]?s\\s-*\\/\\s-*10\\{0,2\\}\\s-*[munpf]?s"
+ "\\<\\(`timescale\\)\\>\\s-+10\\{0,2\\}\\s-*[munpf]?s\\s-*/\\s-*10\\{0,2\\}\\s-*[munpf]?s"
"\\)\\|\\(?:"
- ;; `define and `if can span multiple lines if line ends in '\'. NOTE: `if is not IEEE 1800-2012
+ ;; `define and `if can span multiple lines if line ends in '\'.
+ ;; NOTE: `if is not IEEE 1800-2012.
;; from http://www.emacswiki.org/emacs/MultilineRegexp
(concat "\\<\\(`define\\|`if\\)\\>" ; directive
"\\s-+" ; separator
@@ -3096,7 +3106,7 @@ See also `verilog-font-lock-extra-types'.")
(defvar verilog-font-lock-p1800-face
'verilog-font-lock-p1800-face
- "Font to use for p1800 keywords.")
+ "Obsolete font to use for p1800 keywords.")
(defface verilog-font-lock-p1800-face
'((((class color)
(background light))
@@ -3107,6 +3117,7 @@ See also `verilog-font-lock-extra-types'.")
(t (:italic t)))
"Font lock mode face used to highlight P1800 keywords."
:group 'font-lock-highlighting-faces)
+(make-obsolete-variable 'verilog-font-lock-p1800-face nil "27.1")
(defvar verilog-font-lock-ams-face
'verilog-font-lock-ams-face
@@ -3137,133 +3148,110 @@ See also `verilog-font-lock-extra-types'.")
:group 'font-lock-highlighting-faces)
(let* ((verilog-type-font-keywords
- (eval-when-compile
- (verilog-regexp-opt
- '(
- "and" "bit" "buf" "bufif0" "bufif1" "cmos" "defparam"
- "event" "genvar" "inout" "input" "integer" "localparam"
- "logic" "mailbox" "nand" "nmos" "nor" "not" "notif0" "notif1" "or"
- "output" "parameter" "pmos" "pull0" "pull1" "pulldown" "pullup"
- "rcmos" "real" "realtime" "reg" "rnmos" "rpmos" "rtran"
- "rtranif0" "rtranif1" "semaphore" "signed" "struct" "supply"
- "supply0" "supply1" "time" "tran" "tranif0" "tranif1"
- "tri" "tri0" "tri1" "triand" "trior" "trireg" "typedef"
- "uwire" "vectored" "wand" "wire" "wor" "xnor" "xor"
- ) nil )))
+ (eval-when-compile
+ (verilog-regexp-opt
+ '("and" "buf" "bufif0" "bufif1" "cmos" "defparam" "event"
+ "genvar" "highz0" "highz1" "inout" "input" "integer"
+ "localparam" "mailbox" "nand" "nmos" "nor" "not" "notif0"
+ "notif1" "or" "output" "parameter" "pmos" "pull0" "pull1"
+ "pulldown" "pullup" "rcmos" "real" "realtime" "reg" "rnmos"
+ "rpmos" "rtran" "rtranif0" "rtranif1" "semaphore" "signed"
+ "specparam" "strong0" "strong1" "supply" "supply0" "supply1"
+ "time" "tran" "tranif0" "tranif1" "tri" "tri0" "tri1" "triand"
+ "trior" "trireg" "unsigned" "uwire" "vectored" "wand" "weak0"
+ "weak1" "wire" "wor" "xnor" "xor"
+ ;; 1800-2005
+ "bit" "byte" "chandle" "const" "enum" "int" "logic" "longint"
+ "packed" "ref" "shortint" "shortreal" "static" "string"
+ "struct" "type" "typedef" "union" "var"
+ ;; 1800-2009
+ ;; 1800-2012
+ "interconnect" "nettype" ) nil)))
(verilog-pragma-keywords
- (eval-when-compile
- (verilog-regexp-opt
- '("surefire" "auto" "synopsys" "rtl_synthesis" "verilint" "leda" "0in"
- ) nil )))
-
- (verilog-1800-2005-keywords
- (eval-when-compile
- (verilog-regexp-opt
- '("alias" "assert" "assume" "automatic" "before" "bind"
- "bins" "binsof" "break" "byte" "cell" "chandle" "class"
- "clocking" "config" "const" "constraint" "context" "continue"
- "cover" "covergroup" "coverpoint" "cross" "deassign" "design"
- "dist" "do" "edge" "endclass" "endclocking" "endconfig"
- "endgroup" "endprogram" "endproperty" "endsequence" "enum"
- "expect" "export" "extends" "extern" "first_match" "foreach"
- "forkjoin" "genvar" "highz0" "highz1" "ifnone" "ignore_bins"
- "illegal_bins" "import" "incdir" "include" "inside" "instance"
- "int" "intersect" "large" "liblist" "library" "local" "longint"
- "matches" "medium" "modport" "new" "noshowcancelled" "null"
- "packed" "program" "property" "protected" "pull0" "pull1"
- "pulsestyle_onevent" "pulsestyle_ondetect" "pure" "rand" "randc"
- "randcase" "randsequence" "ref" "release" "return" "scalared"
- "sequence" "shortint" "shortreal" "showcancelled" "small" "solve"
- "specparam" "static" "string" "strong0" "strong1" "struct"
- "super" "tagged" "this" "throughout" "timeprecision" "timeunit"
- "type" "union" "unsigned" "use" "var" "virtual" "void"
- "wait_order" "weak0" "weak1" "wildcard" "with" "within"
- ) nil )))
-
- (verilog-1800-2009-keywords
- (eval-when-compile
- (verilog-regexp-opt
- '("accept_on" "checker" "endchecker" "eventually" "global"
- "implies" "let" "nexttime" "reject_on" "restrict" "s_always"
- "s_eventually" "s_nexttime" "s_until" "s_until_with" "strong"
- "sync_accept_on" "sync_reject_on" "unique0" "until"
- "until_with" "untyped" "weak" ) nil )))
-
- (verilog-1800-2012-keywords
- (eval-when-compile
- (verilog-regexp-opt
- '("implements" "interconnect" "nettype" "soft" ) nil )))
+ (eval-when-compile
+ (verilog-regexp-opt
+ '("surefire" "0in" "auto" "leda" "rtl_synthesis" "synopsys"
+ "verilint" ) nil)))
(verilog-ams-keywords
- (eval-when-compile
- (verilog-regexp-opt
- '("above" "abs" "absdelay" "acos" "acosh" "ac_stim"
- "aliasparam" "analog" "analysis" "asin" "asinh" "atan" "atan2" "atanh"
- "branch" "ceil" "connectmodule" "connectrules" "cos" "cosh" "ddt"
- "ddx" "discipline" "driver_update" "enddiscipline" "endconnectrules"
- "endnature" "endparamset" "exclude" "exp" "final_step" "flicker_noise"
- "floor" "flow" "from" "ground" "hypot" "idt" "idtmod" "inf"
- "initial_step" "laplace_nd" "laplace_np" "laplace_zd" "laplace_zp"
- "last_crossing" "limexp" "ln" "log" "max" "min" "nature"
- "net_resolution" "noise_table" "paramset" "potential" "pow" "sin"
- "sinh" "slew" "sqrt" "tan" "tanh" "timer" "transition" "white_noise"
- "wreal" "zi_nd" "zi_np" "zi_zd" ) nil )))
-
- (verilog-font-keywords
- (eval-when-compile
- (verilog-regexp-opt
- '(
- "assign" "case" "casex" "casez" "randcase" "deassign"
- "default" "disable" "else" "endcase" "endfunction"
- "endgenerate" "endinterface" "endmodule" "endprimitive"
- "endspecify" "endtable" "endtask" "final" "for" "force" "return" "break"
- "continue" "forever" "fork" "function" "generate" "if" "iff" "initial"
- "interface" "join" "join_any" "join_none" "macromodule" "module" "negedge"
- "package" "endpackage" "always" "always_comb" "always_ff"
- "always_latch" "posedge" "primitive" "priority" "release"
- "repeat" "specify" "table" "task" "unique" "wait" "while"
- "class" "program" "endclass" "endprogram"
- ) nil )))
+ (eval-when-compile
+ (verilog-regexp-opt
+ '("above" "abs" "absdelay" "abstol" "ac_stim" "access" "acos"
+ "acosh" "aliasparam" "analog" "analysis" "asin" "asinh" "atan"
+ "atan2" "atanh" "branch" "ceil" "connect" "connectmodule"
+ "connectrules" "continuous" "cos" "cosh" "ddt" "ddt_nature"
+ "ddx" "discipline" "discrete" "domain" "driver_update"
+ "endconnectrules" "enddiscipline" "endnature" "endparamset"
+ "exclude" "exp" "final_step" "flicker_noise" "floor" "flow"
+ "from" "ground" "hypot" "idt" "idt_nature" "idtmod" "inf"
+ "initial_step" "laplace_nd" "laplace_np" "laplace_zd"
+ "laplace_zp" "last_crossing" "limexp" "ln" "log" "max"
+ "merged" "min" "nature" "net_resolution" "noise_table"
+ "paramset" "potential" "pow" "resolveto" "sin" "sinh" "slew"
+ "split" "sqrt" "tan" "tanh" "timer" "transition" "units"
+ "white_noise" "wreal" "zi_nd" "zi_np" "zi_zd" "zi_zp"
+ ;; Excluded AMS keywords: "assert" "cross" "string"
+ ) nil)))
+
+ (verilog-font-general-keywords
+ (eval-when-compile
+ (verilog-regexp-opt
+ '("always" "assign" "automatic" "case" "casex" "casez" "cell"
+ "config" "deassign" "default" "design" "disable" "edge" "else"
+ "endcase" "endconfig" "endfunction" "endgenerate" "endmodule"
+ "endprimitive" "endspecify" "endtable" "endtask" "for" "force"
+ "forever" "fork" "function" "generate" "if" "ifnone" "incdir"
+ "include" "initial" "instance" "join" "large" "liblist"
+ "library" "macromodule" "medium" "module" "negedge"
+ "noshowcancelled" "posedge" "primitive" "pulsestyle_ondetect"
+ "pulsestyle_onevent" "release" "repeat" "scalared"
+ "showcancelled" "small" "specify" "strength" "table" "task"
+ "use" "wait" "while"
+ ;; 1800-2005
+ "alias" "always_comb" "always_ff" "always_latch" "assert"
+ "assume" "before" "bind" "bins" "binsof" "break" "class"
+ "clocking" "constraint" "context" "continue" "cover"
+ "covergroup" "coverpoint" "cross" "dist" "do" "endclass"
+ "endclocking" "endgroup" "endinterface" "endpackage"
+ "endprogram" "endproperty" "endsequence" "expect" "export"
+ "extends" "extern" "final" "first_match" "foreach" "forkjoin"
+ "iff" "ignore_bins" "illegal_bins" "import" "inside"
+ "interface" "intersect" "join_any" "join_none" "local"
+ "matches" "modport" "new" "null" "package" "priority"
+ "program" "property" "protected" "pure" "rand" "randc"
+ "randcase" "randsequence" "return" "sequence" "solve" "super"
+ "tagged" "this" "throughout" "timeprecision" "timeunit"
+ "unique" "virtual" "void" "wait_order" "wildcard" "with"
+ "within"
+ ;; 1800-2009
+ "accept_on" "checker" "endchecker" "eventually" "global"
+ "implies" "let" "nexttime" "reject_on" "restrict" "s_always"
+ "s_eventually" "s_nexttime" "s_until" "s_until_with" "strong"
+ "sync_accept_on" "sync_reject_on" "unique0" "until"
+ "until_with" "untyped" "weak"
+ ;; 1800-2012
+ "implements" "soft" ) nil)))
(verilog-font-grouping-keywords
- (eval-when-compile
- (verilog-regexp-opt
- '( "begin" "end" ) nil ))))
+ (eval-when-compile
+ (verilog-regexp-opt
+ '( "begin" "end" ) nil))))
(setq verilog-font-lock-keywords
(list
;; Fontify all builtin keywords
- (concat "\\<\\(" verilog-font-keywords "\\|"
+ (concat "\\<\\(" verilog-font-general-keywords "\\|"
;; And user/system tasks and functions
"\\$[a-zA-Z][a-zA-Z0-9_\\$]*"
"\\)\\>")
;; Fontify all types
- (if verilog-highlight-grouping-keywords
- (cons (concat "\\<\\(" verilog-font-grouping-keywords "\\)\\>")
- 'verilog-font-lock-grouping-keywords-face)
- (cons (concat "\\<\\(" verilog-font-grouping-keywords "\\)\\>")
+ (cons (concat "\\<\\(" verilog-font-grouping-keywords "\\)\\>")
+ (if verilog-highlight-grouping-keywords
+ 'verilog-font-lock-grouping-keywords-face
'font-lock-type-face))
(cons (concat "\\<\\(" verilog-type-font-keywords "\\)\\>")
'font-lock-type-face)
- ;; Fontify IEEE-1800-2005 keywords appropriately
- (if verilog-highlight-p1800-keywords
- (cons (concat "\\<\\(" verilog-1800-2005-keywords "\\)\\>")
- 'verilog-font-lock-p1800-face)
- (cons (concat "\\<\\(" verilog-1800-2005-keywords "\\)\\>")
- 'font-lock-type-face))
- ;; Fontify IEEE-1800-2009 keywords appropriately
- (if verilog-highlight-p1800-keywords
- (cons (concat "\\<\\(" verilog-1800-2009-keywords "\\)\\>")
- 'verilog-font-lock-p1800-face)
- (cons (concat "\\<\\(" verilog-1800-2009-keywords "\\)\\>")
- 'font-lock-type-face))
- ;; Fontify IEEE-1800-2012 keywords appropriately
- (if verilog-highlight-p1800-keywords
- (cons (concat "\\<\\(" verilog-1800-2012-keywords "\\)\\>")
- 'verilog-font-lock-p1800-face)
- (cons (concat "\\<\\(" verilog-1800-2012-keywords "\\)\\>")
- 'font-lock-type-face))
;; Fontify Verilog-AMS keywords
(cons (concat "\\<\\(" verilog-ams-keywords "\\)\\>")
'verilog-font-lock-ams-face)))
@@ -3492,7 +3480,7 @@ either is ok to parse as a non-comment, or `verilog-insert' was used."
(remove-text-properties (point-min) (point-max) '(face nil))
(while (not (eobp))
(cond ((get-text-property (point) 'v-cmts)
- (put-text-property (point) (1+ (point)) `face 'underline)
+ (put-text-property (point) (1+ (point)) 'face 'underline)
;;(if dbg (setq dbg (concat dbg (format " v-cmts at %S\n" (point)))))
(forward-char 1))
(t
@@ -3960,13 +3948,15 @@ Key bindings specific to `verilog-mode-map' are:
(setq hs-special-modes-alist
(cons '(verilog-mode "\\<begin\\>" "\\<end\\>" nil
verilog-forward-sexp-function)
- hs-special-modes-alist))))
+ hs-special-modes-alist))))
(add-hook 'completion-at-point-functions
#'verilog-completion-at-point nil 'local)
;; Stuff for autos
- (add-hook 'write-contents-hooks 'verilog-auto-save-check nil 'local)
+ (add-hook (if (boundp 'write-contents-hooks) 'write-contents-hooks
+ 'write-contents-functions) ; Emacs >= 22.1
+ 'verilog-auto-save-check nil 'local)
;; verilog-mode-hook call added by define-derived-mode
)
@@ -4162,6 +4152,7 @@ With optional ARG, remove existing end of line comments."
To call this from the command line, see \\[verilog-batch-indent]."
(interactive)
(verilog-mode)
+ (verilog-auto-reeval-locals)
(indent-region (point-min) (point-max) nil))
(defun verilog-insert-block ()
@@ -4983,21 +4974,21 @@ primitive or interface named NAME."
(match-end 11) ; of verilog-end-block-ordered-re
;;(goto-char there)
(let ((nest 0)
- (reg "\\<\\(class\\)\\|\\(endclass\\)\\|\\(package\\|primitive\\|\\(macro\\)?module\\)\\>")
+ (reg "\\<\\(\\(class\\)\\|\\(endclass\\)\\|\\(package\\|primitive\\|\\(macro\\)?module\\)\\)\\>")
string)
(save-excursion
(catch 'skip
(while (verilog-re-search-backward reg nil 'move)
(cond
- ((match-end 3) ; endclass
+ ((match-end 4) ; endclass
(ding 't)
(setq string "unmatched endclass")
(throw 'skip 1))
- ((match-end 2) ; endclass
+ ((match-end 3) ; endclass
(setq nest (1+ nest)))
- ((match-end 1) ; class
+ ((match-end 2) ; class
(setq nest (1- nest))
(if (< nest 0)
(progn
@@ -5235,11 +5226,11 @@ Useful for creating tri's and other expanded fields."
compile-command))
(lint-word1 (verilog-string-replace-matches "\\s .*$" "" nil nil
verilog-linter)))
- (cond ((equal compile-word1 "surelint") `surelint)
- ((equal compile-word1 "verilint") `verilint)
- ((equal lint-word1 "surelint") `surelint)
- ((equal lint-word1 "verilint") `verilint)
- (t `surelint)))) ; back compatibility
+ (cond ((equal compile-word1 "surelint") 'surelint)
+ ((equal compile-word1 "verilint") 'verilint)
+ ((equal lint-word1 "surelint") 'surelint)
+ ((equal lint-word1 "verilint") 'verilint)
+ (t 'surelint)))) ; back compatibility
(defun verilog-lint-off ()
"Convert a Verilog linter warning line into a disable statement.
@@ -5253,9 +5244,9 @@ variables is used to determine which product is being used.
See \\[verilog-surelint-off] and \\[verilog-verilint-off]."
(interactive)
(let ((linter (verilog-linter-name)))
- (cond ((equal linter `surelint)
+ (cond ((equal linter 'surelint)
(verilog-surelint-off))
- ((equal linter `verilint)
+ ((equal linter 'verilint)
(verilog-verilint-off))
(t (error "Linter name not set")))))
@@ -5359,7 +5350,7 @@ FILENAME to find directory to run in, or defaults to `buffer-file-name'."
(interactive
(list
(let ((default (verilog-expand-command verilog-preprocessor)))
- (set (make-local-variable `verilog-preprocessor)
+ (set (make-local-variable 'verilog-preprocessor)
(read-from-minibuffer "Run Preprocessor (like this): "
default nil nil
'verilog-preprocess-history default)))))
@@ -5405,6 +5396,9 @@ This lets programs calling batch mode to easily extract error messages."
(error "%%Error: %s%s" (error-message-string err)
(if (featurep 'xemacs) "\n" "")))))) ; XEmacs forgets to add a newline
+;; Eliminate compile warning
+(defvar verilog-batch-orig-buffer-string)
+
(defun verilog-batch-execute-func (funref &optional no-save)
"Internal processing of a batch command.
Runs FUNREF on all command arguments.
@@ -5426,26 +5420,31 @@ Save the result unless optional NO-SAVE is t."
;; Remember buffer list, so don't later pickup any verilog-getopt files
(let ((orig-buffer-list (buffer-list)))
(mapc (lambda (buf)
- (when (buffer-file-name buf)
- (with-current-buffer buf
- (verilog-mode)
- (verilog-auto-reeval-locals)
- (verilog-getopt-flags))))
- orig-buffer-list)
+ (when (buffer-file-name buf)
+ (with-current-buffer buf
+ (set (make-local-variable 'verilog-batch-orig-buffer-string)
+ (buffer-string))
+ (put 'verilog-batch-orig-buffer-string 'permanent-local t)
+ (verilog-mode)
+ (verilog-auto-reeval-locals)
+ (verilog-getopt-flags))))
+ orig-buffer-list)
;; Process the files
- (mapcar (lambda (buf)
- (when (buffer-file-name buf)
- (save-excursion
- (if (not (file-exists-p (buffer-file-name buf)))
- (error
- "File not found: %s" (buffer-file-name buf)))
- (message "Processing %s" (buffer-file-name buf))
- (set-buffer buf)
- (funcall funref)
- (when (and (not no-save)
- (buffer-modified-p)) ; Avoid "no changes to be saved"
- (save-buffer)))))
- orig-buffer-list))))
+ (mapc (lambda (buf)
+ (when (buffer-file-name buf)
+ (save-excursion
+ (if (not (file-exists-p (buffer-file-name buf)))
+ (error
+ "File not found: %s" (buffer-file-name buf)))
+ (message "Processing %s" (buffer-file-name buf))
+ (set-buffer buf)
+ (funcall funref)
+ (verilog-star-cleanup)
+ (when (and (not no-save)
+ (buffer-modified-p)
+ (not (equal verilog-batch-orig-buffer-string (buffer-string))))
+ (save-buffer)))))
+ orig-buffer-list))))
(defun verilog-batch-auto ()
"For use with --batch, perform automatic expansions as a stand-alone tool.
@@ -5455,7 +5454,7 @@ For proper results, multiple filenames need to be passed on the command
line in bottom-up order."
(unless noninteractive
(error "Use verilog-batch-auto only with --batch")) ; Otherwise we'd mess up buffer modes
- (verilog-batch-execute-func `verilog-auto))
+ (verilog-batch-execute-func 'verilog-auto))
(defun verilog-batch-delete-auto ()
"For use with --batch, perform automatic deletion as a stand-alone tool.
@@ -5463,7 +5462,7 @@ This sets up the appropriate Verilog mode environment, deletes automatics
with \\[verilog-delete-auto] on all command-line files, and saves the buffers."
(unless noninteractive
(error "Use verilog-batch-delete-auto only with --batch")) ; Otherwise we'd mess up buffer modes
- (verilog-batch-execute-func `verilog-delete-auto))
+ (verilog-batch-execute-func 'verilog-delete-auto))
(defun verilog-batch-delete-trailing-whitespace ()
"For use with --batch, perform whitespace deletion as a stand-alone tool.
@@ -5472,7 +5471,7 @@ whitespace with \\[verilog-delete-trailing-whitespace] on all
command-line files, and saves the buffers."
(unless noninteractive
(error "Use verilog-batch-delete-trailing-whitespace only with --batch")) ; Otherwise we'd mess up buffer modes
- (verilog-batch-execute-func `verilog-delete-trailing-whitespace))
+ (verilog-batch-execute-func 'verilog-delete-trailing-whitespace))
(defun verilog-batch-diff-auto ()
"For use with --batch, perform automatic differences as a stand-alone tool.
@@ -5482,7 +5481,7 @@ if any differences are observed. This is appropriate for adding to regressions
to insure automatics are always properly maintained."
(unless noninteractive
(error "Use verilog-batch-diff-auto only with --batch")) ; Otherwise we'd mess up buffer modes
- (verilog-batch-execute-func `verilog-diff-auto t))
+ (verilog-batch-execute-func 'verilog-diff-auto t))
(defun verilog-batch-inject-auto ()
"For use with --batch, perform automatic injection as a stand-alone tool.
@@ -5492,7 +5491,7 @@ For proper results, multiple filenames need to be passed on the command
line in bottom-up order."
(unless noninteractive
(error "Use verilog-batch-inject-auto only with --batch")) ; Otherwise we'd mess up buffer modes
- (verilog-batch-execute-func `verilog-inject-auto))
+ (verilog-batch-execute-func 'verilog-inject-auto))
(defun verilog-batch-indent ()
"For use with --batch, reindent an entire file as a stand-alone tool.
@@ -5500,7 +5499,7 @@ This sets up the appropriate Verilog mode environment, calls
\\[verilog-indent-buffer] on all command-line files, and saves the buffers."
(unless noninteractive
(error "Use verilog-batch-indent only with --batch")) ; Otherwise we'd mess up buffer modes
- (verilog-batch-execute-func `verilog-indent-buffer))
+ (verilog-batch-execute-func 'verilog-indent-buffer))
;;; Indentation:
;;
@@ -6406,7 +6405,7 @@ Return >0 for nested struct."
(equal (char-before) ?\;)
(equal (char-before) ?\}))
;; skip what looks like bus repetition operator {#{
- (not (string-match "^{\\s-*[0-9]+\\s-*{" (buffer-substring p (point)))))))))
+ (not (string-match "^{\\s-*[0-9a-zA-Z_]+\\s-*{" (buffer-substring p (point)))))))))
(progn
(let ( (pt (point)) (pass 0))
(verilog-backward-ws&directives)
@@ -6424,9 +6423,11 @@ Return >0 for nested struct."
;; check next word token
(if (looking-at "\\<\\w+\\>\\|\\s-*(\\s-*\\S-+")
(progn (verilog-beg-of-statement)
- (if (looking-at (concat "\\<\\(constraint\\|"
+ (if (and
+ (not (string-match verilog-named-block-re (buffer-substring pt (point)))) ;; Abort if 'begin' keyword is found
+ (looking-at (concat "\\<\\(constraint\\|"
"\\(?:\\w+\\s-*:\\s-*\\)?\\(coverpoint\\|cross\\)"
- "\\|with\\)\\>\\|" verilog-in-constraint-re))
+ "\\|with\\)\\>\\|" verilog-in-constraint-re)))
(setq pass 1)))))
(if (eq pass 0)
(progn (goto-char pt) nil) 1)))
@@ -6556,9 +6557,9 @@ Return >0 for nested struct."
(t nil))))
(skip-chars-forward " \t\n\f")
(while
- (cond
- ((looking-at "\\/\\*")
- (progn
+ (cond
+ ((looking-at "/\\*")
+ (progn
(setq h (point))
(goto-char (match-end 0))
(if (search-forward "*/" nil t)
@@ -7337,7 +7338,7 @@ will be completed at runtime and should not be added to this list.")
("xor" "output"))
"Map of direction for each positional argument to each gate primitive.")
-(defvar verilog-gate-keywords (mapcar `car verilog-gate-ios)
+(defvar verilog-gate-keywords (mapcar #'car verilog-gate-ios)
"Keywords for gate primitives.")
(defun verilog-string-diff (str1 str2)
@@ -8170,7 +8171,7 @@ Duplicate signals are also removed. For example A[2] and A[1] become A[2:1]."
sv-modport
bus)
;; Shove signals so duplicated signals will be adjacent
- (setq in-list (sort in-list `verilog-signals-sort-compare))
+ (setq in-list (sort in-list #'verilog-signals-sort-compare))
(while in-list
(setq sig (car in-list))
;; No current signal; form from existing details
@@ -8191,11 +8192,11 @@ Duplicate signals are also removed. For example A[2] and A[1] become A[2:1]."
(setq bus (verilog-sig-bits sig))
(setq bus (and bus (verilog-simplify-range-expression bus)))
(cond ((and bus
- (or (and (string-match "\\[\\([0-9]+\\):\\([0-9]+\\)\\]" bus)
+ (or (and (string-match "^\\[\\([0-9]+\\):\\([0-9]+\\)\\]$" bus)
(setq highbit (string-to-number (match-string 1 bus))
lowbit (string-to-number
(match-string 2 bus))))
- (and (string-match "\\[\\([0-9]+\\)\\]" bus)
+ (and (string-match "^\\[\\([0-9]+\\)\\]$" bus)
(setq highbit (string-to-number (match-string 1 bus))
lowbit highbit))))
;; Combine bits in bus
@@ -8429,7 +8430,7 @@ Optional NUM-PARAM and MAX-PARAM check for a specific number of parameters."
;; /*AUTOPUNT("parameter", "parameter")*/
(backward-sexp 1)
(while (looking-at "(?\\s *\"\\([^\"]*\\)\"\\s *,?")
- (setq olist (cons (match-string 1) olist))
+ (setq olist (cons (match-string-no-properties 1) olist))
(goto-char (match-end 0))))
(or (eq nil num-param)
(<= num-param (length olist))
@@ -8461,12 +8462,12 @@ Return an array of [outputs inouts inputs wire reg assign const]."
(cond
((looking-at "//")
(when (looking-at "[^\n]*\\(auto\\|synopsys\\)\\s +enum\\s +\\([a-zA-Z0-9_]+\\)")
- (setq enum (match-string 2)))
+ (setq enum (match-string-no-properties 2)))
(search-forward "\n"))
((looking-at "/\\*")
(forward-char 2)
(when (looking-at "[^\n]*\\(auto\\|synopsys\\)\\s +enum\\s +\\([a-zA-Z0-9_]+\\)")
- (setq enum (match-string 2)))
+ (setq enum (match-string-no-properties 2)))
(or (search-forward "*/")
(error "%s: Unmatched /* */, at char %d" (verilog-point-text) (point))))
((looking-at "(\\*")
@@ -8513,33 +8514,36 @@ Return an array of [outputs inouts inputs wire reg assign const]."
(forward-char 1)
(when (< paren sig-paren)
(setq expect-signal nil rvalue nil))) ; ) that ends variables inside v2k arg list
- ((looking-at "\\s-*\\(\\[[^]]+\\]\\)")
- (goto-char (match-end 0))
+ ((looking-at "\\[")
+ (setq keywd (buffer-substring-no-properties
+ (point)
+ (progn (forward-sexp 1) (point))))
(cond (newsig ; Memory, not just width. Patch last signal added's memory (nth 3)
(setcar (cdr (cdr (cdr newsig)))
(if (verilog-sig-memory newsig)
- (concat (verilog-sig-memory newsig) (match-string 1))
- (match-string-no-properties 1))))
+ (concat (verilog-sig-memory newsig)
+ keywd)
+ keywd)))
(vec ; Multidimensional
(setq multidim (cons vec multidim))
(setq vec (verilog-string-replace-matches
- "\\s-+" "" nil nil (match-string-no-properties 1))))
+ "\\s-+" "" nil nil keywd)))
(t ; Bit width
(setq vec (verilog-string-replace-matches
- "\\s-+" "" nil nil (match-string-no-properties 1))))))
+ "\\s-+" "" nil nil keywd)))))
;; Normal or escaped identifier -- note we remember the \ if escaped
((looking-at "\\s-*\\([a-zA-Z0-9`_$]+\\|\\\\[^ \t\n\f]+\\)")
(goto-char (match-end 0))
(setq last-keywd keywd
keywd (match-string-no-properties 1))
- (when (string-match "^\\\\" (match-string 1))
+ (when (string-match "^\\\\" (match-string-no-properties 1))
(setq keywd (concat keywd " "))) ; Escaped ID needs space at end
;; Add any :: package names to same identifier
;; '*' here is for "import x::*"
(while (looking-at "\\s-*::\\s-*\\(\\*\\|[a-zA-Z0-9`_$]+\\|\\\\[^ \t\n\f]+\\)")
(goto-char (match-end 0))
- (setq keywd (concat keywd "::" (match-string 1)))
- (when (string-match "^\\\\" (match-string 1))
+ (setq keywd (concat keywd "::" (match-string-no-properties 1)))
+ (when (string-match "^\\\\" (match-string-no-properties 1))
(setq keywd (concat keywd " ")))) ; Escaped ID needs space at end
(cond ((equal keywd "input")
(setq vec nil enum nil rvalue nil newsig nil signed nil
@@ -8624,10 +8628,12 @@ Return an array of [outputs inouts inputs wire reg assign const]."
((and v2kargs-ok
(eq paren 1)
(not rvalue)
- (looking-at "\\s-*\\(\\.\\(\\s-*[a-zA-Z`_$][a-zA-Z0-9`_$]*\\)\\|\\)\\s-*[a-zA-Z`_$][a-zA-Z0-9`_$]*"))
+ (or (looking-at "\\s-*#")
+ (looking-at "\\s-*\\(\\.\\(\\s-*[a-zA-Z`_$][a-zA-Z0-9`_$]*\\)\\|\\)\\s-*[a-zA-Z`_$][a-zA-Z0-9`_$]*")))
(when (match-end 2) (goto-char (match-end 2)))
(setq vec nil enum nil rvalue nil signed nil
- typedefed keywd multidim nil ptype nil modport (match-string 2)
+ typedefed keywd multidim nil ptype nil
+ modport (match-string-no-properties 2)
newsig nil sig-paren paren
expect-signal 'sigs-intf io t ))
;; Ignore dotted LHS assignments: "assign foo.bar = z;"
@@ -8676,7 +8682,8 @@ Return an array of [outputs inouts inputs wire reg assign const]."
((and expect-signal
(not rvalue)
(eq functask 0)
- (not (member keywd verilog-keywords)))
+ (not (member keywd verilog-keywords))
+ (or (not io) (eq paren sig-paren)))
;; Add new signal to expect-signal's variable
;;(if dbg (setq dbg (concat dbg (format "Pt %s New sig %s'\n" (point) keywd))))
(setq newsig (verilog-sig-new keywd vec nil nil enum signed typedefed multidim modport))
@@ -8741,7 +8748,7 @@ Return an array of [outputs inouts inputs wire reg assign const]."
(setq port (verilog-symbol-detick-denumber port))
(setq sig (if dotname port (verilog-symbol-detick-denumber sig)))
(if vec (setq vec (verilog-symbol-detick-denumber vec)))
- (if multidim (setq multidim (mapcar `verilog-symbol-detick-denumber multidim)))
+ (if multidim (setq multidim (mapcar #'verilog-symbol-detick-denumber multidim)))
(if mem (setq mem (verilog-symbol-detick-denumber mem)))
(unless (or (not sig)
(equal sig "")) ; Ignore .foo(1'b1) assignments
@@ -8849,8 +8856,9 @@ Return an array of [outputs inouts inputs wire reg assign const]."
;;(message "vrsde-s: `%s'" (match-string 1 expr))
(setq sig (verilog-string-remove-spaces (match-string 1 expr))
expr (substring expr (match-end 0)))))
- ;; Find [vector] or [multi][multi][multi][vector]
- (while (string-match "^\\s-*\\(\\[[^]]+\\]\\)" expr)
+ ;; Find [vector] or [multi][multi][multi][vector] or [vector[VEC2]]
+ ;; Unfortunately Emacs regexps don't allow matching bracket searches, so just 2 deep.
+ (while (string-match "^\\s-*\\(\\[\\([^][]+\\|\\[[^][]+\\]\\)*\\]\\)" expr)
;;(message "vrsde-v: `%s'" (match-string 1 expr))
(when vec (setq multidim (cons vec multidim)))
(setq vec (match-string 1 expr)
@@ -8908,7 +8916,7 @@ Inserts the list of signals found, using submodi to look up each port."
(verilog-string-remove-spaces (match-string-no-properties 1)) ; sig
nil nil nil)) ; vec multidim mem
;;
- ((looking-at "\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\s-*\\(\\[[^]]+\\]\\)\\s-*)")
+ ((looking-at "\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\s-*\\(\\[[^][]+\\]\\)\\s-*)")
(verilog-read-sub-decls-sig
submoddecls par-values comment port
(verilog-string-remove-spaces (match-string-no-properties 1)) ; sig
@@ -8924,7 +8932,7 @@ Inserts the list of signals found, using submodi to look up each port."
(point)))))))) ; expr
;;
(forward-line 1)))))
-;;(verilog-read-sub-decls-line (verilog-subdecls-new nil nil nil nil nil) nil "Cmt")
+;;(verilog-read-sub-decls-line (verilog-decls-new nil nil nil nil nil nil nil nil nil) nil "Cmt")
(defun verilog-read-sub-decls-gate (submoddecls par-values comment submod end-inst-point)
"For `verilog-read-sub-decls', read lines of UDP gate decl until none match.
@@ -8943,15 +8951,15 @@ Inserts the list of signals found."
(forward-char 1)
(or (search-forward "*)")
(error "%s: Unmatched (* *), at char %d" (verilog-point-text) (point))))
- ;; On pins, parse and advance to next pin
- ;; Looking at pin, but *not* an // Output comment, or ) to end the inst
- ((looking-at "\\s-*[a-zA-Z0-9`_$({}\\\\][^,]*")
- (goto-char (match-end 0))
+ ;; On pins, parse and advance to next pin
+ ;; Looking at pin, but *not* an // Output comment, or ) to end the inst
+ ((looking-at "\\s-*[a-zA-Z0-9`_$({}\\][^,]*")
+ (goto-char (match-end 0))
(setq verilog-read-sub-decls-gate-ios (or (car iolist) "input")
iolist (cdr iolist))
(verilog-read-sub-decls-expr
submoddecls par-values comment "primitive_port"
- (match-string 0)))
+ (match-string-no-properties 0)))
(t
(forward-char 1)
(skip-syntax-forward " ")))))))
@@ -8995,7 +9003,7 @@ Outputs comments above subcell signals, for example:
submodi submoddecls)
(cond
(subprim
- (setq submodi `primitive
+ (setq submodi 'primitive
submoddecls (verilog-decls-new nil nil nil nil nil nil nil nil nil)
comment (concat inst " of " submod))
(verilog-backward-open-paren)
@@ -9048,7 +9056,7 @@ For example if declare A A (.B(SIG)) then B will be included in the list."
pins pin)
(verilog-backward-open-paren)
(while (re-search-forward "\\.\\([^(,) \t\n\f]*\\)\\s-*" end-mod-point t)
- (setq pin (match-string 1))
+ (setq pin (match-string-no-properties 1))
(unless (verilog-inside-comment-or-string-p)
(setq pins (cons (list pin) pins))
(when (looking-at "(")
@@ -9062,7 +9070,7 @@ For example if declare A A (.B(SIG)) then B will be included in the list."
pins pin)
(verilog-backward-open-paren)
(while (re-search-forward "\\([a-zA-Z0-9$_.%`]+\\)" end-mod-point t)
- (setq pin (match-string 1))
+ (setq pin (match-string-no-properties 1))
(unless (verilog-inside-comment-or-string-p)
(setq pins (cons (list pin) pins))))
(vector pins))))
@@ -9083,7 +9091,7 @@ For example if declare A A (.B(SIG)) then B will be included in the list."
(backward-char 1)
(point)))
(while (re-search-forward "\\s-*\\([\"a-zA-Z0-9$_.%`]+\\)\\s-*,*" tpl-end-pt t)
- (setq sig-list (cons (list (match-string 1) nil nil) sig-list))))
+ (setq sig-list (cons (list (match-string-no-properties 1) nil nil) sig-list))))
sig-list)))
(defvar verilog-cache-has-lisp nil "True if any AUTO_LISP in buffer.")
@@ -9115,7 +9123,7 @@ Must call `verilog-read-auto-lisp-present' before this function."
"Recursive routine for parentheses/bracket matching.
EXIT-KEYWD is expression to stop at, nil if top level.
RVALUE is true if at right hand side of equal.
-IGNORE-NEXT is true to ignore next token, fake from inside case statement."
+TEMP-NEXT is true to ignore next token, fake from inside case statement."
(let* ((semi-rvalue (equal "endcase" exit-keywd)) ; true if after a ; we are looking for rvalue
keywd last-keywd sig-tolk sig-last-tolk gotend got-sig got-list end-else-check
ignore-next)
@@ -9154,7 +9162,9 @@ IGNORE-NEXT is true to ignore next token, fake from inside case statement."
;;(if dbg (setq dbg (concat dbg (format "\tif-check-else-other %s\n" keywd))))
(setq gotend t))
;; Final statement?
- ((and exit-keywd (and (equal keywd exit-keywd)
+ ((and exit-keywd (and (or (equal keywd exit-keywd)
+ (and (equal exit-keywd "'}")
+ (equal keywd "}")))
(not (looking-at "::"))))
(setq gotend t)
(forward-char (length keywd)))
@@ -9167,9 +9177,13 @@ IGNORE-NEXT is true to ignore next token, fake from inside case statement."
(setq end-else-check t))
(forward-char 1))
((equal keywd "'")
- (if (looking-at "'[sS]?[hdxboHDXBO]?[ \t]*[0-9a-fA-F_xzXZ?]+")
- (goto-char (match-end 0))
- (forward-char 1)))
+ (cond ((looking-at "'[sS]?[hdxboHDXBO]?[ \t]*[0-9a-fA-F_xzXZ?]+")
+ (goto-char (match-end 0)))
+ ((looking-at "'{")
+ (forward-char 2)
+ (verilog-read-always-signals-recurse "'}" t nil))
+ (t
+ (forward-char 1))))
((equal keywd ":") ; Case statement, begin/end label, x?y:z
(cond ((looking-at "::")
(forward-char 1)) ; Another forward-char below
@@ -9179,6 +9193,8 @@ IGNORE-NEXT is true to ignore next token, fake from inside case statement."
) ; NOP
((equal "]" exit-keywd) ; [x:y] rvalue
) ; NOP
+ ((equal "'}" exit-keywd) ; Pattern assignment
+ ) ; NOP
(got-sig ; label: statement
(setq ignore-next nil rvalue semi-rvalue got-sig nil))
((not rvalue) ; begin label
@@ -9289,9 +9305,8 @@ IGNORE-NEXT is true to ignore next token, fake from inside case statement."
(forward-line 1))
(beginning-of-line)
(if (looking-at "^\\s-*\\([a-zA-Z0-9`_$]+\\)\\s-+\\([a-zA-Z0-9`_$]+\\)\\s-*(")
- ;;(if (looking-at "^\\(.+\\)$")
- (let ((module (match-string 1))
- (instant (match-string 2)))
+ (let ((module (match-string-no-properties 1))
+ (instant (match-string-no-properties 2)))
(if (not (member module verilog-keywords))
(setq instants-list (cons (list module instant) instants-list)))))
(forward-line 1)))
@@ -9311,7 +9326,7 @@ Returns REGEXP and list of ( (signal_name connection_name)... )."
;; We reserve @"..." for future lisp expressions that evaluate
;; once-per-AUTOINST
(when (looking-at "\\s-*\"\\([^\"]*\\)\"")
- (setq tpl-regexp (match-string 1))
+ (setq tpl-regexp (match-string-no-properties 1))
(goto-char (match-end 0)))
(search-forward "(")
;; Parse lines in the template
@@ -9340,10 +9355,10 @@ Returns REGEXP and list of ( (signal_name connection_name)... )."
templateno lineno)
tpl-sig-list))
(goto-char (match-end 0)))
- ;; Regexp form??
- ((looking-at
- ;; Regexp bug in XEmacs disallows ][ inside [], and wants + last
- "\\s-*\\.\\(\\([a-zA-Z0-9`_$+@^.*?|---]\\|[][]\\|\\\\[()|]\\)+\\)\\s-*(\\(.*\\))\\s-*\\(,\\|)\\s-*;\\)")
+ ;; Regexp form??
+ ((looking-at
+ ;; Regexp bug in XEmacs disallows ][ inside [], and wants + last
+ "\\s-*\\.\\(\\([-a-zA-Z0-9`_$+@^.*?|]\\|[][]\\|\\\\[()|0-9]\\)+\\)\\s-*(\\(.*\\))\\s-*\\(,\\|)\\s-*;\\)")
(setq rep (match-string-no-properties 3))
(goto-char (match-end 0))
(setq tpl-wild-list
@@ -9508,8 +9523,8 @@ warning message, you need to add to your init file:
(when recurse
(goto-char (point-min))
(while (re-search-forward "^\\s-*`include\\s-+\\([^ \t\n\f]+\\)" nil t)
- (let ((inc (verilog-string-replace-matches
- "\"" "" nil nil (match-string-no-properties 1))))
+ (let ((inc (verilog-substitute-include-name
+ (match-string-no-properties 1))))
(unless (verilog-inside-comment-or-string-p)
(verilog-read-defines inc recurse t)))))
;; Read `defines
@@ -9581,7 +9596,8 @@ foo.v (an include file):
(verilog-getopt-flags)
(goto-char (point-min))
(while (re-search-forward "^\\s-*`include\\s-+\\([^ \t\n\f]+\\)" nil t)
- (let ((inc (verilog-string-replace-matches "\"" "" nil nil (match-string 1))))
+ (let ((inc (verilog-substitute-include-name
+ (match-string-no-properties 1))))
(verilog-read-defines inc nil t)))))
(defun verilog-read-signals (&optional start end)
@@ -9650,7 +9666,7 @@ Use DEFAULT-DIR to anchor paths if non-nil."
((string-match "^\\+libext\\+\\(.*\\)" arg)
(setq arg (match-string 1 arg))
(while (string-match "\\([^+]+\\)\\+?\\(.*\\)" arg)
- (verilog-add-list-unique `verilog-library-extensions
+ (verilog-add-list-unique 'verilog-library-extensions
(match-string 1 arg))
(setq arg (match-string 2 arg))))
;;
@@ -9662,7 +9678,7 @@ Use DEFAULT-DIR to anchor paths if non-nil."
;;
((or (string-match "^\\+incdir\\+\\(.*\\)" arg) ; +incdir+dir
(string-match "^-I\\(.*\\)" arg)) ; -Idir
- (verilog-add-list-unique `verilog-library-directories
+ (verilog-add-list-unique 'verilog-library-directories
(substitute-in-file-name (match-string 1 arg))))
;; Ignore
((equal "+librescan" arg))
@@ -9677,15 +9693,15 @@ Use DEFAULT-DIR to anchor paths if non-nil."
(verilog-getopt-file (verilog-substitute-file-name-path arg default-dir) nil))
((equal next-param "-v")
(setq next-param nil)
- (verilog-add-list-unique `verilog-library-files
+ (verilog-add-list-unique 'verilog-library-files
(verilog-substitute-file-name-path arg default-dir)))
((equal next-param "-y")
(setq next-param nil)
- (verilog-add-list-unique `verilog-library-directories
+ (verilog-add-list-unique 'verilog-library-directories
(verilog-substitute-file-name-path arg default-dir)))
;; Filename
((string-match "^[^-+]" arg)
- (verilog-add-list-unique `verilog-library-files
+ (verilog-add-list-unique 'verilog-library-files
(verilog-substitute-file-name-path arg default-dir)))
;; Default - ignore; no warning
))))
@@ -9714,7 +9730,7 @@ Use DEFAULT-DIR to anchor paths if non-nil."
(defun verilog-getopt-flags ()
"Convert `verilog-library-flags' into standard library variables."
;; If the flags are local, then all the outputs should be local also
- (when (local-variable-p `verilog-library-flags (current-buffer))
+ (when (local-variable-p 'verilog-library-flags (current-buffer))
(mapc 'make-local-variable '(verilog-library-extensions
verilog-library-directories
verilog-library-files
@@ -9733,6 +9749,12 @@ Use DEFAULT-DIR to anchor paths if non-nil."
(expand-file-name (substitute-in-file-name filename) default-dir)
(substitute-in-file-name filename)))
+(defun verilog-substitute-include-name (filename)
+ "Return FILENAME for include with define substituted."
+ (setq filename (verilog-string-replace-matches "\"" "" nil nil filename))
+ (verilog-string-replace-matches "\"" "" nil nil
+ (verilog-symbol-detick filename t)))
+
(defun verilog-add-list-unique (varref object)
"Append to VARREF list the given OBJECT,
unless it is already a member of the variable's list."
@@ -9744,10 +9766,10 @@ unless it is already a member of the variable's list."
(defun verilog-current-flags ()
"Convert `verilog-library-flags' and similar variables to command line.
Used for __FLAGS__ in `verilog-expand-command'."
- (let ((cmd (mapconcat `concat verilog-library-flags " ")))
+ (let ((cmd (mapconcat #'concat verilog-library-flags " ")))
(when (equal cmd "")
(setq cmd (concat
- "+libext+" (mapconcat `concat verilog-library-extensions "+")
+ "+libext+" (mapconcat #'concat verilog-library-extensions "+")
(mapconcat (lambda (i) (concat " -y " i " +incdir+" i))
verilog-library-directories "")
(mapconcat (lambda (i) (concat " -v " i))
@@ -9886,7 +9908,8 @@ If undefined, and WING-IT, return just SYMBOL without the tick, else nil."
(defun verilog-symbol-detick-text (text)
"Return TEXT without any known defines.
-If the variable vh-{symbol} is defined, substitute that value."
+If the variable vh-{symbol} is defined, substitute that value.
+This function is intended for use in AUTO_TEMPLATE Lisp expressions."
(let ((ok t) symbol val)
(while (and ok (string-match "`\\([a-zA-Z0-9_]+\\)" text))
(setq symbol (match-string 1 text))
@@ -9972,7 +9995,7 @@ variables to build the path. With optional CHECK-EXT also check
(while chkdirs
(setq chkdir (expand-file-name (car chkdirs)
(file-name-directory current))
- chkexts (if check-ext verilog-library-extensions `("")))
+ chkexts (if check-ext verilog-library-extensions '("")))
(while chkexts
(setq fn (expand-file-name (concat filename (car chkexts))
chkdir))
@@ -10131,7 +10154,7 @@ Return modi if successful, else print message unless IGNORE-ERROR is true."
(set-buffer (if (bufferp (verilog-modi-file-or-buffer modi))
(verilog-modi-file-or-buffer modi)
(find-file-noselect (verilog-modi-file-or-buffer modi))))
- (or (equal major-mode `verilog-mode) ; Put into Verilog mode to get syntax
+ (or (equal major-mode 'verilog-mode) ; Put into Verilog mode to get syntax
(verilog-mode))
(goto-char (verilog-modi-get-point modi)))
@@ -10402,7 +10425,7 @@ When MODI is non-null, also add to modi-cache, for tracking."
(t
(error "Unsupported verilog-insert-definition direction: `%s'" direction))))
(or dont-sort
- (setq sigs (sort (copy-alist sigs) `verilog-signals-sort-compare)))
+ (setq sigs (sort (copy-alist sigs) #'verilog-signals-sort-compare)))
(while sigs
(let ((sig (car sigs)))
(verilog-insert-one-definition
@@ -10470,7 +10493,7 @@ Presumes that any newlines end a list element."
(looking-at "[(,]")))
(not (save-excursion ; Not `endif, or user define
(backward-char 1)
- (skip-chars-backward "[a-zA-Z0-9_`]")
+ (skip-chars-backward "a-zA-Z0-9_`")
(looking-at "`"))))
(insert ","))))
@@ -10518,67 +10541,96 @@ This repairs those mis-inserted by an AUTOARG."
(defun verilog-simplify-range-expression (expr)
"Return a simplified range expression with constants eliminated from EXPR."
;; Note this is always called with brackets; ie [z] or [z:z]
- (if (not (string-match "[---+*()]" expr))
- expr ; short-circuit
+ (if (or (not verilog-auto-simplify-expressions)
+ (not (string-match "[---+*/<>()]" expr)))
+ expr ; disabled or short-circuited
(let ((out expr)
(last-pass ""))
(while (not (equal last-pass out))
- (setq last-pass out)
- ;; Prefix regexp needs beginning of match, or some symbol of
- ;; lesser or equal precedence. We assume the [:]'s exist in expr.
- ;; Ditto the end.
- (while (string-match
- (concat "\\([[({:*+-]\\)" ; - must be last
- "(\\<\\([0-9A-Za-z_]+\\))"
- "\\([])}:*+-]\\)")
- out)
- (setq out (replace-match "\\1\\2\\3" nil nil out)))
- (while (string-match
- (concat "\\([[({:*+-]\\)" ; - must be last
- "\\$clog2\\s *(\\<\\([0-9]+\\))"
- "\\([])}:*+-]\\)")
- out)
- (setq out (replace-match
- (concat
- (match-string 1 out)
- (int-to-string (verilog-clog2 (string-to-number (match-string 2 out))))
- (match-string 3 out))
- nil nil out)))
- ;; For precedence do * before +/-
- (while (string-match
- (concat "\\([[({:*+-]\\)"
- "\\([0-9]+\\)\\s *\\([*]\\)\\s *\\([0-9]+\\)"
- "\\([])}:*+-]\\)")
- out)
- (setq out (replace-match
- (concat (match-string 1 out)
- (int-to-string (* (string-to-number (match-string 2 out))
- (string-to-number (match-string 4 out))))
- (match-string 5 out))
- nil nil out)))
- (while (string-match
- (concat "\\([[({:+-]\\)" ; No * here as higher prec
- "\\([0-9]+\\)\\s *\\([---+]\\)\\s *\\([0-9]+\\)"
- "\\([])}:+-]\\)")
- out)
- (let ((pre (match-string 1 out))
- (lhs (string-to-number (match-string 2 out)))
- (rhs (string-to-number (match-string 4 out)))
- (post (match-string 5 out))
- val)
- (when (equal pre "-")
- (setq lhs (- lhs)))
- (setq val (if (equal (match-string 3 out) "-")
- (- lhs rhs)
- (+ lhs rhs))
- out (replace-match
- (concat (if (and (equal pre "-")
- (< val 0))
- "" ; Not "--20" but just "-20"
- pre)
- (int-to-string val)
- post)
- nil nil out)) )))
+ (while (not (equal last-pass out))
+ (setq last-pass out)
+ ;; Prefix regexp needs beginning of match, or some symbol of
+ ;; lesser or equal precedence. We assume the [:]'s exist in expr.
+ ;; Ditto the end.
+ (while (string-match
+ (concat "\\([[({:*/<>+-]\\)" ; - must be last
+ "(\\<\\([0-9A-Za-z_]+\\))"
+ "\\([])}:*/<>+-]\\)")
+ out)
+ (setq out (replace-match "\\1\\2\\3" nil nil out)))
+ (while (string-match
+ (concat "\\([[({:*/<>+-]\\)" ; - must be last
+ "\\$clog2\\s *(\\<\\([0-9]+\\))"
+ "\\([])}:*/<>+-]\\)")
+ out)
+ (setq out (replace-match
+ (concat
+ (match-string 1 out)
+ (int-to-string (verilog-clog2 (string-to-number (match-string 2 out))))
+ (match-string 3 out))
+ nil nil out)))
+ ;; For precedence do *,/ before +,-,>>,<<
+ (while (string-match
+ (concat "\\([[({:*/<>+-]\\)"
+ "\\([0-9]+\\)\\s *\\([*/]\\)\\s *\\([0-9]+\\)"
+ "\\([])}:*/<>+-]\\)")
+ out)
+ (setq out (replace-match
+ (concat (match-string 1 out)
+ (if (equal (match-string 3 out) "/")
+ (int-to-string (/ (string-to-number (match-string 2 out))
+ (string-to-number (match-string 4 out)))))
+ (if (equal (match-string 3 out) "*")
+ (int-to-string (* (string-to-number (match-string 2 out))
+ (string-to-number (match-string 4 out)))))
+ (match-string 5 out))
+ nil nil out)))
+ ;; Next precedence is +,-
+ (while (string-match
+ (concat "\\([[({:<>+-]\\)" ; No *,/ here as higher prec
+ "\\([0-9]+\\)\\s *\\([---+]\\)\\s *\\([0-9]+\\)"
+ "\\([])}:<>+-]\\)")
+ out)
+ (let ((pre (match-string 1 out))
+ (lhs (string-to-number (match-string 2 out)))
+ (rhs (string-to-number (match-string 4 out)))
+ (post (match-string 5 out))
+ val)
+ (when (equal pre "-")
+ (setq lhs (- lhs)))
+ (setq val (if (equal (match-string 3 out) "-")
+ (- lhs rhs)
+ (+ lhs rhs))
+ out (replace-match
+ (concat (if (and (equal pre "-")
+ (< val 0))
+ "" ; Not "--20" but just "-20"
+ pre)
+ (int-to-string val)
+ post)
+ nil nil out)) ))
+ ;; Next precedence is >>,<<
+ (while (string-match
+ (concat "\\([[({:]\\)" ;; No << as not transitive
+ "\\([0-9]+\\)\\s *\\([<]\\{2,3\\}\\|[>]\\{2,3\\}\\)\\s *\\([0-9]+\\)"
+ "\\([])}:<>]\\)")
+ out)
+ (setq out (replace-match
+ (concat (match-string 1 out)
+ (if (equal (match-string 3 out) ">>")
+ (int-to-string (lsh (string-to-number (match-string 2 out))
+ (* -1 (string-to-number (match-string 4 out))))))
+ (if (equal (match-string 3 out) "<<")
+ (int-to-string (lsh (string-to-number (match-string 2 out))
+ (string-to-number (match-string 4 out)))))
+ (if (equal (match-string 3 out) ">>>")
+ (int-to-string (ash (string-to-number (match-string 2 out))
+ (* -1 (string-to-number (match-string 4 out))))))
+ (if (equal (match-string 3 out) "<<<")
+ (int-to-string (ash (string-to-number (match-string 2 out))
+ (string-to-number (match-string 4 out)))))
+ (match-string 5 out))
+ nil nil out)))))
out)))
;;(verilog-simplify-range-expression "[1:3]") ; 1
@@ -10591,6 +10643,9 @@ This repairs those mis-inserted by an AUTOARG."
;;(verilog-simplify-range-expression "[FOO-1+1-1+1]") ; FOO-0
;;(verilog-simplify-range-expression "[$clog2(2)]") ; 1
;;(verilog-simplify-range-expression "[$clog2(7)]") ; 3
+;;(verilog-simplify-range-expression "[(TEST[1])-1:0]")
+;;(verilog-simplify-range-expression "[1<<2:8>>2]") ; [4:2]
+;;(verilog-simplify-range-expression "[2*4/(4-2) +2+4 <<4 >>2]")
(defun verilog-clog2 (value)
"Compute $clog2 - ceiling log2 of VALUE."
@@ -10746,7 +10801,7 @@ Intended for internal use inside a `verilog-save-font-no-change-functions' block
(concat "/\\*"
(eval-when-compile
(verilog-regexp-words
- `("AS" "AUTOARG" "AUTOCONCATWIDTH" "AUTOINST" "AUTOINSTPARAM"
+ '("AS" "AUTOARG" "AUTOCONCATWIDTH" "AUTOINST" "AUTOINSTPARAM"
"AUTOSENSE")))
"\\*/")
'verilog-delete-to-paren)
@@ -11018,8 +11073,7 @@ or `diff' in batch mode."
(progn
(with-current-buffer b1 (setq buffer-file-name nil))
(verilog-auto)
- (when (not verilog-auto-star-save)
- (verilog-delete-auto-star-implicit)))
+ (verilog-star-cleanup))
;; Restore name if unwind
(with-current-buffer b1 (setq buffer-file-name name1)))))
;;
@@ -11036,6 +11090,11 @@ or `diff' in batch mode."
;; Auto save
;;
+(defun verilog-star-cleanup ()
+ "On saving or diff, cleanup .* expansions."
+ (when (not verilog-auto-star-save)
+ (verilog-delete-auto-star-implicit)))
+
(defun verilog-auto-save-check ()
"On saving see if we need auto update."
(cond ((not verilog-auto-save-policy)) ; disabled
@@ -11055,8 +11114,7 @@ or `diff' in batch mode."
(verilog-auto))
;; Don't ask again if didn't update
(set (make-local-variable 'verilog-auto-update-tick) (buffer-chars-modified-tick))))
- (when (not verilog-auto-star-save)
- (verilog-delete-auto-star-implicit))
+ (verilog-star-cleanup)
nil) ; Always return nil -- we don't write the file ourselves
(defun verilog-auto-read-locals ()
@@ -11087,7 +11145,7 @@ If FORCE, always reread it."
Takes SIGS list, adds MESSAGE to front and inserts each at INDENT-PT."
(when sigs
(when verilog-auto-arg-sort
- (setq sigs (sort (copy-alist sigs) `verilog-signals-sort-compare)))
+ (setq sigs (sort (copy-alist sigs) #'verilog-signals-sort-compare)))
(insert "\n")
(indent-to indent-pt)
(insert message)
@@ -11241,8 +11299,8 @@ See the example in `verilog-auto-inout-modport'."
(verilog-signals-matching-dir-re
(verilog-signals-matching-regexp sig-list-o regexp)
"output" direction-re)))
- (setq sig-list-i (sort (copy-alist sig-list-i) `verilog-signals-sort-compare))
- (setq sig-list-o (sort (copy-alist sig-list-o) `verilog-signals-sort-compare))
+ (setq sig-list-i (sort (copy-alist sig-list-i) #'verilog-signals-sort-compare))
+ (setq sig-list-o (sort (copy-alist sig-list-o) #'verilog-signals-sort-compare))
(when (or sig-list-i sig-list-o)
(verilog-insert-indent "// Beginning of automatic assignments from modport\n")
;; Don't sort them so an upper AUTOINST will match the main module
@@ -11386,7 +11444,7 @@ If PAR-VALUES replace final strings with these parameter values."
(indent-to (+ (if (< verilog-auto-inst-column 48) 24 16)
verilog-auto-inst-column))
;; verilog-insert requires the complete comment in one call - including the newline
- (cond ((equal verilog-auto-inst-template-numbers `lhs)
+ (cond ((equal verilog-auto-inst-template-numbers 'lhs)
(verilog-insert " // Templated"
" LHS: " (nth 0 tpl-ass)
"\n"))
@@ -11410,7 +11468,7 @@ If PAR-VALUES replace final strings with these parameter values."
(defun verilog-auto-inst-port-list (sig-list indent-pt moddecls tpl-list tpl-num for-star par-values)
"For `verilog-auto-inst' print a list of ports using `verilog-auto-inst-port'."
(when verilog-auto-inst-sort
- (setq sig-list (sort (copy-alist sig-list) `verilog-signals-sort-compare)))
+ (setq sig-list (sort (copy-alist sig-list) #'verilog-signals-sort-compare)))
(mapc (lambda (port)
(verilog-auto-inst-port port indent-pt moddecls
tpl-list tpl-num for-star par-values))
@@ -12021,15 +12079,18 @@ Typing \\[verilog-auto] will make this into:
(defun verilog-auto-reg-input ()
"Expand AUTOREGINPUT statements, as part of \\[verilog-auto].
-Make reg statements instantiation inputs that aren't already declared.
-This is useful for making a top level shell for testing the module that is
-to be instantiated.
+Make reg statements instantiation inputs that aren't already
+declared or assigned to. This is useful for making a top level
+shell for testing the module that is to be instantiated.
Limitations:
This ONLY detects inputs of AUTOINSTants (see `verilog-read-sub-decls').
This does NOT work on memories, declare those yourself.
+ Assignments cause the assigned-to variable not to be declared unless
+ the name matches `verilog-auto-reg-input-assigned-ignore-regexp'.
+
An example (see `verilog-auto-inst' for what else is going on here):
module ExampRegInput (o,i);
@@ -12067,7 +12128,9 @@ Typing \\[verilog-auto] will make this into:
(append (verilog-subdecls-get-inputs modsubdecls)
(verilog-subdecls-get-inouts modsubdecls))
(append (verilog-decls-get-signals moddecls)
- (verilog-decls-get-assigns moddecls))))))
+ (verilog-signals-not-matching-regexp
+ (verilog-decls-get-assigns moddecls)
+ verilog-auto-reg-input-assigned-ignore-regexp))))))
(when sig-list
(verilog-forward-or-insert-line)
(verilog-insert-indent "// Beginning of automatic reg inputs (for undeclared instantiated-module inputs)\n")
@@ -12252,7 +12315,7 @@ same expansion will result from only extracting outputs starting with ov:
"Expand AUTOOUTPUTEVERY statements, as part of \\[verilog-auto].
Make output statements for any signals that aren't primary inputs or
outputs already. This makes every signal in the design an output. This is
-useful to get Synopsys to preserve every signal in the design, since it
+useful to get synthesis to preserve every signal in the design, since it
won't optimize away the outputs.
An example:
@@ -13108,7 +13171,7 @@ operator. (This was added to the language in part due to AUTOSENSE!)
(verilog-re-search-backward-quick "\\s-" start-pt t))
(not (looking-at "\\s-or\\b"))))
(setq not-first t))
- (setq sig-list (sort sig-list `verilog-signals-sort-compare))
+ (setq sig-list (sort sig-list #'verilog-signals-sort-compare))
(while sig-list
(cond ((> (+ 4 (current-column) (length (verilog-sig-name (car sig-list)))) fill-column) ;+4 for width of or
(insert "\n")
@@ -13217,7 +13280,7 @@ Typing \\[verilog-auto] will make this into:
(append
(verilog-alw-get-temps sigss)
prereset-sigs)))
- (setq sig-list (sort sig-list `verilog-signals-sort-compare))
+ (setq sig-list (sort sig-list #'verilog-signals-sort-compare))
(when sig-list
(insert "\n");
(verilog-insert-indent "// Beginning of autoreset for uninitialized flops\n");
@@ -13308,7 +13371,7 @@ Typing \\[verilog-auto] will make this into:
(when sig-list
(verilog-forward-or-insert-line)
(verilog-insert-indent "// Beginning of automatic tieoffs (for this module's unterminated outputs)\n")
- (setq sig-list (sort (copy-alist sig-list) `verilog-signals-sort-compare))
+ (setq sig-list (sort (copy-alist sig-list) #'verilog-signals-sort-compare))
(verilog-modi-cache-add-vars modi sig-list) ; Before we trash list
(while sig-list
(let ((sig (car sig-list)))
@@ -13461,7 +13524,7 @@ Typing \\[verilog-auto] will make this into:
(when sig-list
(verilog-forward-or-insert-line)
(verilog-insert-indent "// Beginning of automatic unused inputs\n")
- (setq sig-list (sort (copy-alist sig-list) `verilog-signals-sort-compare))
+ (setq sig-list (sort (copy-alist sig-list) #'verilog-signals-sort-compare))
(while sig-list
(let ((sig (car sig-list)))
(indent-to indent-pt)
@@ -13510,19 +13573,19 @@ Finally, an AUTOASCIIENUM command is used.
`verilog-auto-wire-type' may be used to change the datatype of
the declarations.
- \"auto enum\" may be used in place of \"synopsys enum\".
+ \"synopsys enum\" may be used in place of \"auto enum\".
An example:
//== State enumeration
- parameter [2:0] // synopsys enum state_info
+ parameter [2:0] // auto enum state_info
SM_IDLE = 3\\='b000,
SM_SEND = 3\\='b001,
SM_WAIT1 = 3\\='b010;
//== State variables
- reg [2:0] /* synopsys enum state_info */
- state_r; /* synopsys state_vector state_r */
- reg [2:0] /* synopsys enum state_info */
+ reg [2:0] /* auto enum state_info */
+ state_r; /* auto state_vector state_r */
+ reg [2:0] /* auto enum state_info */
state_e1;
/*AUTOASCIIENUM(\"state_r\", \"state_ascii_r\", \"SM_\")*/
@@ -13654,9 +13717,11 @@ being different from the final output's line numbering."
(while (re-search-forward " Templated T\\([0-9]+\\) L\\([0-9]+\\)" nil t)
(replace-match
(concat " Templated "
- (int-to-string (+ (nth (string-to-number (match-string 1))
+ (int-to-string (+ (nth (string-to-number
+ (match-string-no-properties 1))
template-line)
- (string-to-number (match-string 2)))))
+ (string-to-number
+ (match-string-no-properties 2)))))
t t))))
(defun verilog-auto-template-lint ()
@@ -13787,7 +13852,7 @@ Wilson Snyder (wsnyder@wsnyder.org)."
;; Local state
(verilog-read-auto-template-init)
;; If we're not in verilog-mode, change syntax table so parsing works right
- (unless (eq major-mode `verilog-mode) (verilog-mode))
+ (unless (eq major-mode 'verilog-mode) (verilog-mode))
;; Allow user to customize
(verilog-run-hooks 'verilog-before-auto-hook)
;; Try to save the user from needing to revert-file to reread file local-variables
@@ -14198,13 +14263,13 @@ and the case items."
(defun verilog-sk-define-signal ()
"Insert a definition of signal under point at top of module."
(interactive "*")
- (let* ((sig-re "[a-zA-Z0-9_]*")
+ (let* ((sig-chars "a-zA-Z0-9_")
(v1 (buffer-substring
(save-excursion
- (skip-chars-backward sig-re)
+ (skip-chars-backward sig-chars)
(point))
(save-excursion
- (skip-chars-forward sig-re)
+ (skip-chars-forward sig-chars)
(point)))))
(if (not (member v1 verilog-keywords))
(save-excursion
@@ -14418,11 +14483,14 @@ Files are checked based on `verilog-library-flags'."
(when (and (not hit)
(looking-at verilog-include-file-regexp))
(if (and (car (verilog-library-filenames
- (match-string 1) (buffer-file-name)))
+ (match-string-no-properties 1)
+ (buffer-file-name)))
(file-readable-p (car (verilog-library-filenames
- (match-string 1) (buffer-file-name)))))
+ (match-string-no-properties 1)
+ (buffer-file-name)))))
(find-file (car (verilog-library-filenames
- (match-string 1) (buffer-file-name))))
+ (match-string-no-properties 1)
+ (buffer-file-name))))
(when warn
(message
"File `%s' isn't readable, use shift-mouse2 to paste in this field"
@@ -14507,7 +14575,6 @@ Files are checked based on `verilog-library-flags'."
verilog-highlight-grouping-keywords
verilog-highlight-includes
verilog-highlight-modules
- verilog-highlight-p1800-keywords
verilog-highlight-translate-off
verilog-indent-begin-after-if
verilog-indent-declaration-macros
diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el
index 506e9a6b2c7..1dc0c61d063 100644
--- a/lisp/progmodes/vhdl-mode.el
+++ b/lisp/progmodes/vhdl-mode.el
@@ -2474,7 +2474,7 @@ specified."
(defun vhdl-resolve-env-variable (string)
"Resolve environment variables in STRING."
- (while (string-match "\\(.*\\)${?\\(\\(\\w\\|_\\)+\\)}?\\(.*\\)" string)
+ (while (string-match "\\(.*\\)\\${?\\(\\(\\w\\|_\\)+\\)}?\\(.*\\)" string)
(setq string (concat (match-string 1 string)
(getenv (match-string 2 string))
(match-string 4 string))))
@@ -4953,8 +4953,8 @@ Key bindings:
(defun vhdl-write-file-hooks-init ()
"Add/remove hooks when buffer is saved."
(if vhdl-modify-date-on-saving
- (add-hook 'local-write-file-hooks 'vhdl-template-modify-noerror nil t)
- (remove-hook 'local-write-file-hooks 'vhdl-template-modify-noerror t))
+ (add-hook 'write-file-functions 'vhdl-template-modify-noerror nil t)
+ (remove-hook 'write-file-functions 'vhdl-template-modify-noerror t))
(if (featurep 'xemacs) (make-local-hook 'after-save-hook))
(add-hook 'after-save-hook 'vhdl-add-modified-file nil t))
@@ -7392,8 +7392,8 @@ only-lines."
(defun vhdl-update-progress-info (string pos)
"Update progress information."
(when (and vhdl-progress-info (not noninteractive)
- (< vhdl-progress-interval
- (- (nth 1 (current-time)) (aref vhdl-progress-info 2))))
+ (time-less-p vhdl-progress-interval
+ (time-since (aref vhdl-progress-info 2))))
(let ((delta (- (aref vhdl-progress-info 1)
(aref vhdl-progress-info 0))))
(message "%s... (%2d%%)" string
@@ -7401,7 +7401,7 @@ only-lines."
100
(floor (* 100.0 (- pos (aref vhdl-progress-info 0)))
delta))))
- (aset vhdl-progress-info 2 (nth 1 (current-time)))))
+ (aset vhdl-progress-info 2 (encode-time nil 'integer))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Indentation commands
@@ -8142,12 +8142,12 @@ depending on parameter UPPER-CASE."
(upcase-word -1)
(downcase-word -1)))
(when (and count vhdl-progress-interval (not noninteractive)
- (< vhdl-progress-interval
- (- (nth 1 (current-time)) last-update)))
+ (time-less-p vhdl-progress-interval
+ (time-since last-update)))
(message "Fixing case... (%2d%s)"
(+ (* count 20) (/ (* 20 (- (point) beg)) (- end beg)))
"%")
- (setq last-update (nth 1 (current-time)))))
+ (setq last-update (encode-time nil 'integer))))
(goto-char end)))))
(defun vhdl-fix-case-region (beg end &optional arg)
@@ -8707,17 +8707,11 @@ project is defined."
;; Enabling/disabling
(define-minor-mode vhdl-electric-mode
- "Toggle VHDL electric mode.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable it if ARG
-is omitted or nil."
+ "Toggle VHDL electric mode."
:global t :group 'vhdl-mode)
(define-minor-mode vhdl-stutter-mode
- "Toggle VHDL stuttering mode.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable it if ARG
-is omitted or nil."
+ "Toggle VHDL stuttering mode."
:global t :group 'vhdl-mode)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -15121,7 +15115,7 @@ otherwise use cached data."
(defun vhdl-speedbar-expand-project (text token indent)
"Expand/contract the project under the cursor."
(cond
- ((string-match "+" text) ; expand project
+ ((string-match "\\+" text) ; expand project
(speedbar-change-expand-button-char ?-)
(unless (member token vhdl-speedbar-shown-project-list)
(setq vhdl-speedbar-shown-project-list
@@ -15143,7 +15137,7 @@ otherwise use cached data."
(defun vhdl-speedbar-expand-entity (text token indent)
"Expand/contract the entity under the cursor."
(cond
- ((string-match "+" text) ; expand entity
+ ((string-match "\\+" text) ; expand entity
(let* ((key (vhdl-speedbar-line-key indent))
(ent-alist (vhdl-aget vhdl-entity-alist key))
(ent-entry (vhdl-aget ent-alist token))
@@ -15212,7 +15206,7 @@ otherwise use cached data."
(defun vhdl-speedbar-expand-architecture (text token indent)
"Expand/contract the architecture under the cursor."
(cond
- ((string-match "+" text) ; expand architecture
+ ((string-match "\\+" text) ; expand architecture
(let* ((key (vhdl-speedbar-line-key (1- indent)))
(ent-alist (vhdl-aget vhdl-entity-alist key))
(conf-alist (vhdl-aget vhdl-config-alist key))
@@ -15272,7 +15266,7 @@ otherwise use cached data."
(defun vhdl-speedbar-expand-config (text token indent)
"Expand/contract the configuration under the cursor."
(cond
- ((string-match "+" text) ; expand configuration
+ ((string-match "\\+" text) ; expand configuration
(let* ((key (vhdl-speedbar-line-key indent))
(conf-alist (vhdl-aget vhdl-config-alist key))
(conf-entry (vhdl-aget conf-alist token))
@@ -15330,7 +15324,7 @@ otherwise use cached data."
(defun vhdl-speedbar-expand-package (text token indent)
"Expand/contract the package under the cursor."
(cond
- ((string-match "+" text) ; expand package
+ ((string-match "\\+" text) ; expand package
(let* ((key (vhdl-speedbar-line-key indent))
(pack-alist (vhdl-aget vhdl-package-alist key))
(pack-entry (vhdl-aget pack-alist token))
@@ -15735,7 +15729,7 @@ NO-POSITION non-nil means do not re-position cursor."
(defun vhdl-speedbar-dired (text token indent)
"Speedbar click handler for directory expand button in hierarchy mode."
- (cond ((string-match "+" text) ; we have to expand this dir
+ (cond ((string-match "\\+" text) ; we have to expand this dir
(setq speedbar-shown-directories
(cons (expand-file-name
(concat (speedbar-line-directory indent) token "/"))
diff --git a/lisp/progmodes/which-func.el b/lisp/progmodes/which-func.el
index 28303022d96..564e0ff62c4 100644
--- a/lisp/progmodes/which-func.el
+++ b/lisp/progmodes/which-func.el
@@ -247,9 +247,6 @@ It creates the Imenu index for the buffer, if necessary."
;;;###autoload
(define-minor-mode which-function-mode
"Toggle mode line display of current function (Which Function mode).
-With a prefix argument ARG, enable Which Function mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Which Function mode is a global minor mode. When enabled, the
current function name is continuously displayed in the mode line,
@@ -275,16 +272,21 @@ It calls them sequentially, and if any returns non-nil,
(defun which-function ()
"Return current function name based on point.
-Uses `which-func-functions', `imenu--index-alist'
-or `add-log-current-defun'.
+Uses `which-func-functions', `add-log-current-defun'.
+or `imenu--index-alist'
If no function name is found, return nil."
(let ((name
;; Try the `which-func-functions' functions first.
(run-hook-with-args-until-success 'which-func-functions)))
-
+ ;; Try using add-log support.
+ (when (null name)
+ (setq name (add-log-current-defun)))
;; If Imenu is loaded, try to make an index alist with it.
(when (and (null name)
- (boundp 'imenu--index-alist) (null imenu--index-alist)
+ (boundp 'imenu--index-alist)
+ (or (null imenu--index-alist)
+ ;; Update if outdated
+ (/= (buffer-chars-modified-tick) imenu-menubar-modified-tick))
(null which-function-imenu-failed))
(ignore-errors (imenu--make-index-alist t))
(unless imenu--index-alist
@@ -326,10 +328,6 @@ If no function name is found, return nil."
(funcall
which-func-imenu-joiner-function
(reverse (cons (car pair) namestack))))))))))))
-
- ;; Try using add-log support.
- (when (null name)
- (setq name (add-log-current-defun)))
;; Filter the name if requested.
(when name
(if which-func-cleanup-function
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index e59bfdd36d2..aed92f8db62 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -71,9 +71,6 @@
(require 'ring)
(require 'project)
-(eval-when-compile
- (require 'semantic/symref)) ;; for hit-lines slot
-
(defgroup xref nil "Cross-referencing commands"
:version "25.1"
:group 'tools)
@@ -317,8 +314,12 @@ backward."
;;; Marker stack (M-. pushes, M-, pops)
(defcustom xref-marker-ring-length 16
- "Length of the xref marker ring."
- :type 'integer)
+ "Length of the xref marker ring.
+If this variable is not set through Customize, you must call
+`xref-set-marker-ring-length' for changes to take effect."
+ :type 'integer
+ :initialize #'custom-initialize-default
+ :set #'xref-set-marker-ring-length)
(defcustom xref-prompt-for-identifier '(not xref-find-definitions
xref-find-definitions-other-window
@@ -354,6 +355,14 @@ elements is negated: these commands will NOT prompt."
(defvar xref--marker-ring (make-ring xref-marker-ring-length)
"Ring of markers to implement the marker stack.")
+(defun xref-set-marker-ring-length (var val)
+ "Set `xref-marker-ring-length'.
+VAR is the symbol `xref-marker-ring-length' and VAL is the new
+value."
+ (set-default var val)
+ (if (ring-p xref--marker-ring)
+ (ring-resize xref--marker-ring val)))
+
(defun xref-push-marker-stack (&optional m)
"Add point M (defaults to `point-marker') to the marker stack."
(ring-insert xref--marker-ring (or m (point-marker))))
@@ -465,27 +474,17 @@ and finally return the window."
(or (eq xref--original-window-intent 'frame)
pop-up-frames))
(action
- (cond ((memq
- xref--original-window-intent
- '(window frame))
+ (cond ((eq xref--original-window-intent 'frame)
t)
+ ((eq xref--original-window-intent 'window)
+ '(display-buffer-same-window))
((and
(window-live-p xref--original-window)
(or (not (window-dedicated-p xref--original-window))
(eq (window-buffer xref--original-window) buf)))
- `(,(lambda (buf _alist)
- (set-window-buffer xref--original-window buf)
- xref--original-window))))))
- (with-selected-window
- (with-selected-window
- ;; Just before `display-buffer', place ourselves in the
- ;; original window to suggest preserving it. Of course, if
- ;; user has deleted the original window, all bets are off,
- ;; just use the selected one.
- (or (and (window-live-p xref--original-window)
- xref--original-window)
- (selected-window))
- (display-buffer buf action))
+ `((display-buffer-in-previous-window)
+ (previous-window . ,xref--original-window))))))
+ (with-selected-window (display-buffer buf action)
(xref--goto-char pos)
(run-hooks 'xref-after-jump-hook)
(let ((buf (current-buffer)))
@@ -503,8 +502,9 @@ SELECT is `quit', also quit the *xref* window."
(xref-buffer (current-buffer)))
(cond (select
(if (eq select 'quit) (quit-window nil nil))
- (with-current-buffer xref-buffer
- (select-window (xref--show-pos-in-buf marker buf))))
+ (select-window
+ (with-current-buffer xref-buffer
+ (xref--show-pos-in-buf marker buf))))
(t
(save-selected-window
(xref--with-dedicated-window
@@ -541,9 +541,12 @@ SELECT is `quit', also quit the *xref* window."
Non-interactively, non-nil QUIT means to first quit the *xref*
buffer."
(interactive)
- (let ((xref (or (xref--item-at-point)
- (user-error "No reference at point"))))
- (xref--show-location (xref-item-location xref) (if quit 'quit t))))
+ (let* ((buffer (current-buffer))
+ (xref (or (xref--item-at-point)
+ (user-error "No reference at point")))
+ (xref--current-item xref))
+ (xref--show-location (xref-item-location xref) (if quit 'quit t))
+ (next-error-found buffer (current-buffer))))
(defun xref-quit-and-goto-xref ()
"Quit *xref* buffer, then jump to xref on current line."
@@ -691,8 +694,10 @@ references displayed in the current *xref* buffer."
(let ((backward (< n 0))
(n (abs n))
(xref nil))
- (dotimes (_ n)
- (setq xref (xref--search-property 'xref-item backward)))
+ (if (= n 0)
+ (setq xref (get-text-property (point) 'xref-item))
+ (dotimes (_ n)
+ (setq xref (xref--search-property 'xref-item backward))))
(cond (xref
;; Save the current position (when the buffer is visible,
;; it gets reset to that window's point from time to time).
@@ -792,6 +797,7 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)."
(defvar xref--read-pattern-history nil)
(defun xref--show-xrefs (xrefs display-action &optional always-show-list)
+ (unless (region-active-p) (push-mark nil t))
(cond
((and (not (cdr xrefs)) (not always-show-list))
(xref-push-marker-stack)
@@ -876,6 +882,19 @@ is nil, prompt only if there's no usable symbol at point."
(interactive (list (xref--read-identifier "Find references of: ")))
(xref--find-xrefs identifier 'references identifier nil))
+;;;###autoload
+(defun xref-find-definitions-at-mouse (event)
+ "Find the definition of identifier at or around mouse click.
+This command is intended to be bound to a mouse event."
+ (interactive "e")
+ (let ((identifier
+ (save-excursion
+ (mouse-set-point event)
+ (xref-backend-identifier-at-point (xref-find-backend)))))
+ (if identifier
+ (xref-find-definitions identifier)
+ (user-error "No identifier here"))))
+
(declare-function apropos-parse-pattern "apropos" (pattern))
;;;###autoload
@@ -976,7 +995,7 @@ IGNORES is a list of glob patterns."
;; do that reliably enough, without creating false negatives?
(command (xref--rgrep-command (xref--regexp-to-extended regexp)
files
- (expand-file-name dir)
+ (file-local-name (expand-file-name dir))
ignores))
(def default-directory)
(buf (get-buffer-create " *xref-grep*"))
@@ -987,7 +1006,7 @@ IGNORES is a list of glob patterns."
(erase-buffer)
(setq default-directory def)
(setq status
- (call-process-shell-command command nil t))
+ (process-file-shell-command command nil t))
(goto-char (point-min))
;; Can't use the exit status: Grep exits with 1 to mean "no
;; matches found". Find exits with 1 if any of the invocations
@@ -1089,6 +1108,7 @@ Such as the current syntax table and the applied syntax properties."
(defun xref--collect-matches (hit regexp tmp-buffer)
(pcase-let* ((`(,line ,file ,text) hit)
+ (file (and file (concat (file-remote-p default-directory) file)))
(buf (xref--find-buffer-visiting file))
(syntax-needed (xref--regexp-syntax-dependent-p regexp)))
(if buf
diff --git a/lisp/ps-bdf.el b/lisp/ps-bdf.el
index 1c818fd7ab4..be80b4a15b6 100644
--- a/lisp/ps-bdf.el
+++ b/lisp/ps-bdf.el
@@ -70,13 +70,12 @@ for BDFNAME."
(defsubst bdf-file-mod-time (filename)
"Return modification time of FILENAME.
-The value is a list of integers in the same format as `current-time'."
- (nth 5 (file-attributes filename)))
+The value is a timestamp in the same format as `current-time'."
+ (file-attribute-modification-time (file-attributes filename)))
(defun bdf-file-newer-than-time (filename mod-time)
"Return non-nil if and only if FILENAME is newer than MOD-TIME.
-MOD-TIME is a modification time as a list of integers in the same
-format as `current-time'."
+MOD-TIME is a modification time in the same format as `current-time'."
(let ((new-mod-time (bdf-file-mod-time filename)))
(time-less-p mod-time new-mod-time)))
@@ -145,7 +144,7 @@ See the documentation of the function `bdf-read-font-info' for more detail."
(if (or (< code (aref code-range 4))
(> code (aref code-range 5)))
(setq code (aref code-range 6)))
- (+ (* (- (lsh code -8) (aref code-range 0))
+ (+ (* (- (ash code -8) (aref code-range 0))
(1+ (- (aref code-range 3) (aref code-range 2))))
(- (logand code 255) (aref code-range 2))))
@@ -168,8 +167,7 @@ FONT-INFO is a list of the following format:
(BDFFILE MOD-TIME FONT-BOUNDING-BOX
RELATIVE-COMPOSE BASELINE-OFFSET CODE-RANGE MAXLEN OFFSET-VECTOR)
-MOD-TIME is last modification time as a list of integers in the
-same format as `current-time'.
+MOD-TIME is last modification time in the same format as `current-time'.
SIZE is a size of the font on 72 dpi device. This value is got
from SIZE record of the font.
@@ -262,7 +260,7 @@ CODE, where N and CODE are in the following relation:
(setq code (read (current-buffer)))
(if (< code 0)
(search-forward "ENDCHAR")
- (setq code0 (lsh code -8)
+ (setq code0 (ash code -8)
code1 (logand code 255)
min-code (min min-code code)
max-code (max max-code code)
diff --git a/lisp/ps-def.el b/lisp/ps-def.el
index e3c9504a01f..20631338902 100644
--- a/lisp/ps-def.el
+++ b/lisp/ps-def.el
@@ -2,10 +2,10 @@
;; Copyright (C) 2007-2019 Free Software Foundation, Inc.
-;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Kenichi Handa <handa@m17n.org> (multi-byte characters)
;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters)
-;; Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: wp, print, PostScript
;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
;; Package: ps-print
@@ -31,9 +31,6 @@
;;; Code:
-(eval-and-compile
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest _r))))
-
(declare-function ps-plot-with-face "ps-print" (from to face))
(declare-function ps-plot-string "ps-print" (string))
diff --git a/lisp/ps-mule.el b/lisp/ps-mule.el
index 9a32b05526e..c88d6d26797 100644
--- a/lisp/ps-mule.el
+++ b/lisp/ps-mule.el
@@ -2,10 +2,10 @@
;; Copyright (C) 1998-2019 Free Software Foundation, Inc.
-;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Kenichi Handa <handa@m17n.org> (multi-byte characters)
;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters)
-;; Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: wp, print, PostScript, multibyte, mule
;; Package: ps-print
@@ -1031,7 +1031,7 @@ the sequence."
(setq ps-mule-prologue-generated nil
ps-mule-composition-prologue-generated nil
ps-mule-bitmap-prologue-generated nil)
- (mapcar `(lambda (x) (setcar (nthcdr 2 x) nil))
+ (mapcar (lambda (x) (setcar (nthcdr 2 x) nil))
ps-mule-external-libraries))
(defun ps-mule-encode-header-string (string fonttag)
diff --git a/lisp/ps-print.el b/lisp/ps-print.el
index 000aa850834..647597cefae 100644
--- a/lisp/ps-print.el
+++ b/lisp/ps-print.el
@@ -4,10 +4,10 @@
;; Author: Jim Thompson (was <thompson@wg2.waii.com>)
;; Jacques Duthen (was <duthen@cegelec-red.fr>)
-;; Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Kenichi Handa <handa@m17n.org> (multi-byte characters)
;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters)
-;; Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: wp, print, PostScript
;; Version: 7.3.5
;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
@@ -20,7 +20,7 @@ Emacs without changes to the version number. When reporting bugs, please also
report the version of Emacs, if any, that ps-print was distributed with.
Please send all bug fixes and enhancements to
- bug-gnu-emacs@gnu.org and Vinicius Jose Latorre <viniciusjl@ig.com.br>.")
+ bug-gnu-emacs@gnu.org and Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>.")
;; This file is part of GNU Emacs.
@@ -1216,7 +1216,7 @@ Please send all bug fixes and enhancements to
;; New since version 2.8
;; ---------------------
;;
-;; [vinicius] Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; [vinicius] Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;;
;; 2007-10-27
;; `ps-fg-validate-p', `ps-fg-list'
@@ -1274,7 +1274,7 @@ Please send all bug fixes and enhancements to
;;
;; `ps-print-region-function'
;;
-;; [vinicius] Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; [vinicius] Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;;
;; 1999-03-01
;; PostScript tumble and setpagedevice.
@@ -1287,7 +1287,7 @@ Please send all bug fixes and enhancements to
;;
;; Multi-byte buffer handling.
;;
-;; [vinicius] Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; [vinicius] Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;;
;; 1998-03-06
;; Skip invisible text.
@@ -1773,7 +1773,7 @@ See `ps-lpr-command'."
(defcustom ps-print-region-function
(if (memq system-type '(ms-dos windows-nt))
- #'w32-direct-ps-print-region-function
+ 'w32-direct-ps-print-region-function
#'call-process-region)
"Specify a function to print the region on a PostScript printer.
See definition of `call-process-region' for calling conventions. The fourth
@@ -4140,48 +4140,6 @@ If EXTENSION is any other symbol, it is ignored."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Adapted from font-lock: (obsolete stuff)
-;; Originally face attributes were specified via `font-lock-face-attributes'.
-;; Users then changed the default face attributes by setting that variable.
-;; However, we try and be back-compatible and respect its value if set except
-;; for faces where M-x customize has been used to save changes for the face.
-
-
-(defun ps-font-lock-face-attributes ()
- (and (boundp 'font-lock-mode) (symbol-value 'font-lock-mode)
- (boundp 'font-lock-face-attributes)
- (let ((face-attributes (symbol-value 'font-lock-face-attributes)))
- (while face-attributes
- (let* ((face-attribute
- (car (prog1 face-attributes
- (setq face-attributes (cdr face-attributes)))))
- (face (car face-attribute)))
- ;; Rustle up a `defface' SPEC from a
- ;; `font-lock-face-attributes' entry.
- (unless (get face 'saved-face)
- (let ((foreground (nth 1 face-attribute))
- (background (nth 2 face-attribute))
- (bold-p (nth 3 face-attribute))
- (italic-p (nth 4 face-attribute))
- (underline-p (nth 5 face-attribute))
- face-spec)
- (when foreground
- (setq face-spec (cons ':foreground
- (cons foreground face-spec))))
- (when background
- (setq face-spec (cons ':background
- (cons background face-spec))))
- (when bold-p
- (setq face-spec (append '(:weight bold) face-spec)))
- (when italic-p
- (setq face-spec (append '(:slant italic) face-spec)))
- (when underline-p
- (setq face-spec (append '(:underline t) face-spec)))
- (custom-declare-face face (list (list t face-spec)) nil)
- )))))))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Internal functions and variables
@@ -6341,7 +6299,7 @@ If FACE is not a valid face name, use default face."
(ps-font-number 'ps-font-for-text
(or (aref ps-font-type (logand effect 3))
face))
- fg-color bg-color (lsh effect -2)))))
+ fg-color bg-color (ash effect -2)))))
(goto-char to))
@@ -6350,10 +6308,6 @@ If FACE is not a valid face name, use default face."
(defun ps-build-reference-face-lists ()
- ;; Ensure that face database is updated with faces on
- ;; `font-lock-face-attributes' (obsolete stuff)
- (ps-font-lock-face-attributes)
- ;; Now, rebuild reference face lists
(setq ps-print-face-alist nil)
(if ps-auto-font-detect
(mapc 'ps-map-face (face-list))
diff --git a/lisp/ps-samp.el b/lisp/ps-samp.el
index cccf035834f..784b4356b47 100644
--- a/lisp/ps-samp.el
+++ b/lisp/ps-samp.el
@@ -4,10 +4,10 @@
;; Author: Jim Thompson (was <thompson@wg2.waii.com>)
;; Jacques Duthen (was <duthen@cegelec-red.fr>)
-;; Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Kenichi Handa <handa@m17n.org> (multi-byte characters)
;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters)
-;; Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: wp, print, PostScript
;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
;; Package: ps-print
diff --git a/lisp/recentf.el b/lisp/recentf.el
index 93f9a57094c..9b70017a385 100644
--- a/lisp/recentf.el
+++ b/lisp/recentf.el
@@ -228,10 +228,6 @@ This item will replace the \"More...\" item."
:group 'recentf
:type 'boolean)
-(define-obsolete-variable-alias 'recentf-menu-append-commands-p
- 'recentf-menu-append-commands-flag
- "22.1")
-
(defcustom recentf-menu-append-commands-flag t
"Non-nil means to append command items to the menu."
:group 'recentf
@@ -1346,9 +1342,6 @@ That is, remove duplicates, non-kept, and excluded files."
;;;###autoload
(define-minor-mode recentf-mode
"Toggle \"Open Recent\" menu (Recentf mode).
-With a prefix argument ARG, enable Recentf mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-Recentf mode if ARG is omitted or nil.
When Recentf mode is enabled, a \"Open Recent\" submenu is
displayed in the \"File\" menu, containing a list of files that
diff --git a/lisp/rect.el b/lisp/rect.el
index f180431a588..17907534ace 100644
--- a/lisp/rect.el
+++ b/lisp/rect.el
@@ -167,6 +167,45 @@ The final point after the last operation will be returned."
(<= (point) endpt))))
final-point)))
+(defun rectangle-position-as-coordinates (position)
+ "Return cons of the column and line values of POSITION.
+POSITION specifies a position of the current buffer. The value
+returned has the form (COLUMN . LINE)."
+ (save-excursion
+ (goto-char position)
+ (let ((col (current-column))
+ (line (line-number-at-pos)))
+ (cons col line))))
+
+(defun rectangle-intersect-p (pos1 size1 pos2 size2)
+ "Return non-nil if two rectangles intersect.
+POS1 and POS2 specify the positions of the upper-left corners of
+the first and second rectangles as conses of the form (COLUMN . LINE).
+SIZE1 and SIZE2 specify the dimensions of the first and second
+rectangles, as conses of the form (WIDTH . HEIGHT)."
+ (let ((x1 (car pos1))
+ (y1 (cdr pos1))
+ (x2 (car pos2))
+ (y2 (cdr pos2))
+ (w1 (car size1))
+ (h1 (cdr size1))
+ (w2 (car size2))
+ (h2 (cdr size2)))
+ (not (or (<= (+ x1 w1) x2)
+ (<= (+ x2 w2) x1)
+ (<= (+ y1 h1) y2)
+ (<= (+ y2 h2) y1)))))
+
+(defun rectangle-dimensions (start end)
+ "Return the dimensions of the rectangle with corners at START
+and END. The returned value has the form of (WIDTH . HEIGHT)."
+ (save-excursion
+ (let* ((height (1+ (abs (- (line-number-at-pos end)
+ (line-number-at-pos start)))))
+ (cols (rectangle--pos-cols start end))
+ (width (abs (- (cdr cols) (car cols)))))
+ (cons width height))))
+
(defun delete-rectangle-line (startcol endcol fill)
(when (= (move-to-column startcol (if fill t 'coerce)) startcol)
(delete-region (point)
@@ -604,6 +643,7 @@ with a prefix argument, prompt for START-AT and FORMAT."
;;;###autoload
(define-minor-mode rectangle-mark-mode
"Toggle the region as rectangular.
+
Activates the region if needed. Only lasts until the region is deactivated."
nil nil nil
(rectangle--reset-crutches)
diff --git a/lisp/register.el b/lisp/register.el
index 008c1611dfe..775e1a2cc92 100644
--- a/lisp/register.el
+++ b/lisp/register.el
@@ -39,9 +39,7 @@
(registerv (:constructor nil)
(:constructor registerv--make (&optional data print-func
jump-func insert-func))
- (:copier nil)
- (:type vector)
- :named)
+ (:copier nil))
(data nil :read-only t)
(print-func nil :read-only t)
(jump-func nil :read-only t)
@@ -59,6 +57,7 @@ this sentence:
JUMP-FUNC if provided, controls how `jump-to-register' jumps to the register.
INSERT-FUNC if provided, controls how `insert-register' insert the register.
They both receive DATA as argument."
+ (declare (obsolete "Use your own type with methods on register-val-(insert|describe|jump-to)" "27.1"))
(registerv--make data print-func jump-func insert-func))
(defvar register-alist nil
@@ -182,8 +181,11 @@ Use \\[jump-to-register] to go to that location or restore that configuration.
Argument is a character, naming the register.
Interactively, reads the register using `register-read-with-preview'."
- (interactive (list (register-read-with-preview "Point to register: ")
- current-prefix-arg))
+ (interactive (list (register-read-with-preview
+ (if current-prefix-arg
+ "Frame configuration to register: "
+ "Point to register: "))
+ current-prefix-arg))
;; Turn the marker into a file-ref if the buffer is killed.
(add-hook 'kill-buffer-hook 'register-swap-out nil t)
(set-register register
@@ -229,6 +231,7 @@ Interactively, reads the register using `register-read-with-preview'."
(defalias 'register-to-point 'jump-to-register)
(defun jump-to-register (register &optional delete)
"Move point to location stored in a register.
+Push the mark if jumping moves point, unless called in succession.
If the register contains a file name, find that file.
\(To put a file name in a register, you must use `set-register'.)
If the register contains a window configuration (one frame) or a frameset
@@ -242,36 +245,44 @@ Interactively, reads the register using `register-read-with-preview'."
(interactive (list (register-read-with-preview "Jump to register: ")
current-prefix-arg))
(let ((val (get-register register)))
- (cond
- ((registerv-p val)
- (cl-assert (registerv-jump-func val) nil
- "Don't know how to jump to register %s"
- (single-key-description register))
- (funcall (registerv-jump-func val) (registerv-data val)))
- ((and (consp val) (frame-configuration-p (car val)))
- (set-frame-configuration (car val) (not delete))
- (goto-char (cadr val)))
- ((and (consp val) (window-configuration-p (car val)))
- (set-window-configuration (car val))
- (goto-char (cadr val)))
- ((markerp val)
- (or (marker-buffer val)
- (user-error "That register's buffer no longer exists"))
- (switch-to-buffer (marker-buffer val))
- (unless (or (= (point) (marker-position val))
- (eq last-command 'jump-to-register))
- (push-mark))
- (goto-char val))
- ((and (consp val) (eq (car val) 'file))
- (find-file (cdr val)))
- ((and (consp val) (eq (car val) 'file-query))
- (or (find-buffer-visiting (nth 1 val))
- (y-or-n-p (format "Visit file %s again? " (nth 1 val)))
- (user-error "Register access aborted"))
- (find-file (nth 1 val))
- (goto-char (nth 2 val)))
- (t
- (user-error "Register doesn't contain a buffer position or configuration")))))
+ (register-val-jump-to val delete)))
+
+(cl-defgeneric register-val-jump-to (_val _arg)
+ "Execute the \"jump\" operation of VAL.
+ARG is the value of the prefix argument or nil."
+ (user-error "Register doesn't contain a buffer position or configuration"))
+
+(cl-defmethod register-val-jump-to ((val registerv) _arg)
+ (cl-assert (registerv-jump-func val) nil
+ "Don't know how to jump to register value %S" val)
+ (funcall (registerv-jump-func val) (registerv-data val)))
+
+(cl-defmethod register-val-jump-to ((val marker) _arg)
+ (or (marker-buffer val)
+ (user-error "That register's buffer no longer exists"))
+ (switch-to-buffer (marker-buffer val))
+ (unless (or (= (point) (marker-position val))
+ (eq last-command 'jump-to-register))
+ (push-mark))
+ (goto-char val))
+
+(cl-defmethod register-val-jump-to ((val cons) delete)
+ (cond
+ ((frame-configuration-p (car val))
+ (set-frame-configuration (car val) (not delete))
+ (goto-char (cadr val)))
+ ((window-configuration-p (car val))
+ (set-window-configuration (car val))
+ (goto-char (cadr val)))
+ ((eq (car val) 'file)
+ (find-file (cdr val)))
+ ((eq (car val) 'file-query)
+ (or (find-buffer-visiting (nth 1 val))
+ (y-or-n-p (format "Visit file %s again? " (nth 1 val)))
+ (user-error "Register access aborted"))
+ (find-file (nth 1 val))
+ (goto-char (nth 2 val)))
+ (t (cl-call-next-method val delete))))
(defun register-swap-out ()
"Turn markers into file-query references when a buffer is killed."
@@ -353,79 +364,97 @@ Interactively, reads the register using `register-read-with-preview'."
(princ (single-key-description register))
(princ " contains ")
(let ((val (get-register register)))
+ (register-val-describe val verbose)))
+
+(cl-defgeneric register-val-describe (val verbose)
+ "Print description of register value VAL to `standard-output'."
+ (princ "Garbage:\n")
+ (if verbose (prin1 val)))
+
+(cl-defmethod register-val-describe ((val registerv) _verbose)
+ (if (registerv-print-func val)
+ (funcall (registerv-print-func val) (registerv-data val))
+ (princ "[UNPRINTABLE CONTENTS].")))
+
+(cl-defmethod register-val-describe ((val number) _verbose)
+ (princ val))
+
+(cl-defmethod register-val-describe ((val marker) _verbose)
+ (let ((buf (marker-buffer val)))
+ (if (null buf)
+ (princ "a marker in no buffer")
+ (princ "a buffer position:\n buffer ")
+ (princ (buffer-name buf))
+ (princ ", position ")
+ (princ (marker-position val)))))
+
+(cl-defmethod register-val-describe ((val cons) verbose)
+ (cond
+ ((window-configuration-p (car val))
+ (let* ((stored-window-config (car val))
+ (window-config-frame (window-configuration-frame stored-window-config))
+ (current-frame (selected-frame)))
+ (princ (format "a window configuration: %s."
+ (if (frame-live-p window-config-frame)
+ (with-selected-frame window-config-frame
+ (save-window-excursion
+ (set-window-configuration stored-window-config)
+ (concat
+ (mapconcat (lambda (w) (buffer-name (window-buffer w)))
+ (window-list (selected-frame)) ", ")
+ (unless (eq current-frame window-config-frame)
+ " in another frame"))))
+ "dead frame")))))
+
+ ((frame-configuration-p (car val))
+ (princ "a frame configuration."))
+
+ ((eq (car val) 'file)
+ (princ "the file ")
+ (prin1 (cdr val))
+ (princ "."))
+
+ ((eq (car val) 'file-query)
+ (princ "a file-query reference:\n file ")
+ (prin1 (car (cdr val)))
+ (princ ",\n position ")
+ (princ (car (cdr (cdr val))))
+ (princ "."))
+
+ (t
+ (if verbose
+ (progn
+ (princ "the rectangle:\n")
+ (while val
+ (princ " ")
+ (princ (car val))
+ (terpri)
+ (setq val (cdr val))))
+ (princ "a rectangle starting with ")
+ (princ (car val))))))
+
+(cl-defmethod register-val-describe ((val string) verbose)
+ (setq val (copy-sequence val))
+ (if (eq yank-excluded-properties t)
+ (set-text-properties 0 (length val) nil val)
+ (remove-list-of-text-properties 0 (length val)
+ yank-excluded-properties val))
+ (if verbose
+ (progn
+ (princ "the text:\n")
+ (princ val))
(cond
- ((registerv-p val)
- (if (registerv-print-func val)
- (funcall (registerv-print-func val) (registerv-data val))
- (princ "[UNPRINTABLE CONTENTS].")))
-
- ((numberp val)
- (princ val))
-
- ((markerp val)
- (let ((buf (marker-buffer val)))
- (if (null buf)
- (princ "a marker in no buffer")
- (princ "a buffer position:\n buffer ")
- (princ (buffer-name buf))
- (princ ", position ")
- (princ (marker-position val)))))
-
- ((and (consp val) (window-configuration-p (car val)))
- (princ "a window configuration."))
-
- ((and (consp val) (frame-configuration-p (car val)))
- (princ "a frame configuration."))
-
- ((and (consp val) (eq (car val) 'file))
- (princ "the file ")
- (prin1 (cdr val))
- (princ "."))
-
- ((and (consp val) (eq (car val) 'file-query))
- (princ "a file-query reference:\n file ")
- (prin1 (car (cdr val)))
- (princ ",\n position ")
- (princ (car (cdr (cdr val))))
- (princ "."))
-
- ((consp val)
- (if verbose
- (progn
- (princ "the rectangle:\n")
- (while val
- (princ " ")
- (princ (car val))
- (terpri)
- (setq val (cdr val))))
- (princ "a rectangle starting with ")
- (princ (car val))))
-
- ((stringp val)
- (setq val (copy-sequence val))
- (if (eq yank-excluded-properties t)
- (set-text-properties 0 (length val) nil val)
- (remove-list-of-text-properties 0 (length val)
- yank-excluded-properties val))
- (if verbose
- (progn
- (princ "the text:\n")
- (princ val))
- (cond
- ;; Extract first N characters starting with first non-whitespace.
- ((string-match (format "[^ \t\n].\\{,%d\\}"
- ;; Deduct 6 for the spaces inserted below.
- (min 20 (max 0 (- (window-width) 6))))
- val)
- (princ "text starting with\n ")
- (princ (match-string 0 val)))
- ((string-match "^[ \t\n]+$" val)
- (princ "whitespace"))
- (t
- (princ "the empty string")))))
+ ;; Extract first N characters starting with first non-whitespace.
+ ((string-match (format "[^ \t\n].\\{,%d\\}"
+ ;; Deduct 6 for the spaces inserted below.
+ (min 20 (max 0 (- (window-width) 6))))
+ val)
+ (princ "text starting with\n ")
+ (princ (match-string 0 val)))
+ ((string-match "^[ \t\n]+$" val)
+ (princ "whitespace"))
(t
- (princ "Garbage:\n")
- (if verbose (prin1 val))))))
+ (princ "the empty string")))))
(defun insert-register (register &optional arg)
"Insert contents of register REGISTER. (REGISTER is a character.)
@@ -441,24 +470,32 @@ Interactively, reads the register using `register-read-with-preview'."
(not current-prefix-arg))))
(push-mark)
(let ((val (get-register register)))
- (cond
- ((registerv-p val)
- (cl-assert (registerv-insert-func val) nil
- "Don't know how to insert register %s"
- (single-key-description register))
- (funcall (registerv-insert-func val) (registerv-data val)))
- ((consp val)
- (insert-rectangle val))
- ((stringp val)
- (insert-for-yank val))
- ((numberp val)
- (princ val (current-buffer)))
- ((and (markerp val) (marker-position val))
- (princ (marker-position val) (current-buffer)))
- (t
- (user-error "Register does not contain text"))))
+ (register-val-insert val))
(if (not arg) (exchange-point-and-mark)))
+(cl-defgeneric register-val-insert (_val)
+ "Insert register value VAL."
+ (user-error "Register does not contain text"))
+
+(cl-defmethod register-val-insert ((val registerv))
+ (cl-assert (registerv-insert-func val) nil
+ "Don't know how to insert register value %S" val)
+ (funcall (registerv-insert-func val) (registerv-data val)))
+
+(cl-defmethod register-val-insert ((val cons))
+ (insert-rectangle val))
+
+(cl-defmethod register-val-insert ((val string))
+ (insert-for-yank val))
+
+(cl-defmethod register-val-insert ((val number))
+ (princ val (current-buffer)))
+
+(cl-defmethod register-val-insert ((val marker))
+ (if (marker-position val)
+ (princ (marker-position val) (current-buffer))
+ (cl-call-next-method val)))
+
(defun copy-to-register (register start end &optional delete-flag region)
"Copy region into register REGISTER.
With prefix arg, delete as well.
diff --git a/lisp/registry.el b/lisp/registry.el
index 52ff12360f2..8e2005b0a5a 100644
--- a/lisp/registry.el
+++ b/lisp/registry.el
@@ -358,11 +358,12 @@ return LIMIT such candidates. If SORTFUNC is provided, sort
entries first and return candidates from beginning of list."
(let* ((precious (oref db precious))
(precious-p (lambda (entry-key)
- (memq (car entry-key) precious)))
+ (memq (car-safe entry-key) precious)))
(data (oref db data))
(candidates (cl-loop for k being the hash-keys of data
using (hash-values v)
- when (cl-notany precious-p v)
+ when (and (listp v)
+ (cl-notany precious-p v))
collect (cons k v))))
;; We want the full entries for sorting, but should only return a
;; list of entry keys.
diff --git a/lisp/replace.el b/lisp/replace.el
index 08feb8eae7e..9d1b7bf747d 100644
--- a/lisp/replace.el
+++ b/lisp/replace.el
@@ -39,7 +39,7 @@
(defcustom replace-char-fold nil
"Non-nil means replacement commands should do character folding in matches.
This means, for instance, that \\=' will match a large variety of
-unicode quotes.
+Unicode quotes.
This variable affects `query-replace' and `replace-string', but not
`replace-regexp'."
:type 'boolean
@@ -147,15 +147,27 @@ is highlighted lazily using isearch lazy highlighting (see
See `replace-regexp' and `query-replace-regexp-eval'.")
(defun query-replace-descr (string)
- (mapconcat 'isearch-text-char-description string ""))
+ (setq string (copy-sequence string))
+ (dotimes (i (length string))
+ (let ((c (aref string i)))
+ (cond
+ ((< c ?\s) (add-text-properties
+ i (1+ i)
+ `(display ,(propertize (format "^%c" (+ c 64)) 'face 'escape-glyph))
+ string))
+ ((= c ?\^?) (add-text-properties
+ i (1+ i)
+ `(display ,(propertize "^?" 'face 'escape-glyph))
+ string)))))
+ string)
(defun query-replace--split-string (string)
"Split string STRING at a substring with property `separator'."
(let* ((length (length string))
(split-pos (text-property-any 0 length 'separator t string)))
(if (not split-pos)
- (substring-no-properties string)
- (cons (substring-no-properties string 0 split-pos)
+ string
+ (cons (substring string 0 split-pos)
(substring-no-properties
string (or (text-property-not-all
(1+ split-pos) length 'separator t string)
@@ -301,7 +313,9 @@ the original string if not."
(to (if (consp from) (prog1 (cdr from) (setq from (car from)))
(query-replace-read-to from prompt regexp-flag))))
(list from to
- (and current-prefix-arg (not (eq current-prefix-arg '-)))
+ (or (and current-prefix-arg (not (eq current-prefix-arg '-)))
+ (and (plist-member (text-properties-at 0 from) 'isearch-regexp-function)
+ (get-text-property 0 'isearch-regexp-function from)))
(and current-prefix-arg (eq current-prefix-arg '-)))))
(defun query-replace (from-string to-string &optional delimited start end backward region-noncontiguous-p)
@@ -345,6 +359,9 @@ character strings.
Fourth and fifth arg START and END specify the region to operate on.
+Arguments FROM-STRING, TO-STRING, DELIMITED, START, END, BACKWARD, and
+REGION-NONCONTIGUOUS-P are passed to `perform-replace' (which see).
+
To customize possible responses, change the bindings in `query-replace-map'."
(interactive
(let ((common
@@ -427,7 +444,10 @@ to terminate it. One space there, if any, will be discarded.
When using those Lisp features interactively in the replacement
text, TO-STRING is actually made a list instead of a string.
-Use \\[repeat-complex-command] after this command for details."
+Use \\[repeat-complex-command] after this command for details.
+
+Arguments REGEXP, TO-STRING, DELIMITED, START, END, BACKWARD, and
+REGION-NONCONTIGUOUS-P are passed to `perform-replace' (which see)."
(interactive
(let ((common
(query-replace-read-args
@@ -450,7 +470,7 @@ Use \\[repeat-complex-command] after this command for details."
(define-key esc-map [?\C-%] 'query-replace-regexp)
-(defun query-replace-regexp-eval (regexp to-expr &optional delimited start end)
+(defun query-replace-regexp-eval (regexp to-expr &optional delimited start end region-noncontiguous-p)
"Replace some things after point matching REGEXP with the result of TO-EXPR.
Interactive use of this function is deprecated in favor of the
@@ -496,7 +516,10 @@ This function is not affected by `replace-char-fold'.
Third arg DELIMITED (prefix arg if interactive), if non-nil, means replace
only matches that are surrounded by word boundaries.
-Fourth and fifth arg START and END specify the region to operate on."
+Fourth and fifth arg START and END specify the region to operate on.
+
+Arguments REGEXP, DELIMITED, START, END, and REGION-NONCONTIGUOUS-P
+are passed to `perform-replace' (which see)."
(declare (obsolete "use the `\\,' feature of `query-replace-regexp'
for interactive calls, and `search-forward-regexp'/`replace-match'
for Lisp calls." "22.1"))
@@ -518,11 +541,12 @@ for Lisp calls." "22.1"))
(replace-match-string-symbols to)
(list from (car to) current-prefix-arg
(if (use-region-p) (region-beginning))
- (if (use-region-p) (region-end))))))
+ (if (use-region-p) (region-end))
+ (if (use-region-p) (region-noncontiguous-p))))))
(perform-replace regexp (cons 'replace-eval-replacement to-expr)
- t 'literal delimited nil nil start end))
+ t 'literal delimited nil nil start end nil region-noncontiguous-p))
-(defun map-query-replace-regexp (regexp to-strings &optional n start end)
+(defun map-query-replace-regexp (regexp to-strings &optional n start end region-noncontiguous-p)
"Replace some matches for REGEXP with various strings, in rotation.
The second argument TO-STRINGS contains the replacement strings, separated
by spaces. This command works like `query-replace-regexp' except that
@@ -542,7 +566,10 @@ that reads REGEXP.
A prefix argument N says to use each replacement string N times
before rotating to the next.
-Fourth and fifth arg START and END specify the region to operate on."
+Fourth and fifth arg START and END specify the region to operate on.
+
+Arguments REGEXP, START, END, and REGION-NONCONTIGUOUS-P are passed to
+`perform-replace' (which see)."
(interactive
(let* ((from (read-regexp "Map query replace (regexp): " nil
query-replace-from-history-variable))
@@ -555,7 +582,8 @@ Fourth and fifth arg START and END specify the region to operate on."
(and current-prefix-arg
(prefix-numeric-value current-prefix-arg))
(if (use-region-p) (region-beginning))
- (if (use-region-p) (region-end)))))
+ (if (use-region-p) (region-end))
+ (if (use-region-p) (region-noncontiguous-p)))))
(let (replacements)
(if (listp to-strings)
(setq replacements to-strings)
@@ -569,9 +597,9 @@ Fourth and fifth arg START and END specify the region to operate on."
(1+ (string-match " " to-strings))))
(setq replacements (append replacements (list to-strings))
to-strings ""))))
- (perform-replace regexp replacements t t nil n nil start end)))
+ (perform-replace regexp replacements t t nil n nil start end nil region-noncontiguous-p)))
-(defun replace-string (from-string to-string &optional delimited start end backward)
+(defun replace-string (from-string to-string &optional delimited start end backward region-noncontiguous-p)
"Replace occurrences of FROM-STRING with TO-STRING.
Preserve case in each match if `case-replace' and `case-fold-search'
are non-nil and FROM-STRING has no uppercase letters.
@@ -625,10 +653,11 @@ and TO-STRING is also null.)"
(list (nth 0 common) (nth 1 common) (nth 2 common)
(if (use-region-p) (region-beginning))
(if (use-region-p) (region-end))
- (nth 3 common))))
- (perform-replace from-string to-string nil nil delimited nil nil start end backward))
+ (nth 3 common)
+ (if (use-region-p) (region-noncontiguous-p)))))
+ (perform-replace from-string to-string nil nil delimited nil nil start end backward region-noncontiguous-p))
-(defun replace-regexp (regexp to-string &optional delimited start end backward)
+(defun replace-regexp (regexp to-string &optional delimited start end backward region-noncontiguous-p)
"Replace things after point matching REGEXP with TO-STRING.
Preserve case in each match if `case-replace' and `case-fold-search'
are non-nil and REGEXP has no uppercase letters.
@@ -701,8 +730,9 @@ which will run faster and will not set the mark or print anything."
(list (nth 0 common) (nth 1 common) (nth 2 common)
(if (use-region-p) (region-beginning))
(if (use-region-p) (region-end))
- (nth 3 common))))
- (perform-replace regexp to-string nil t delimited nil nil start end backward))
+ (nth 3 common)
+ (if (use-region-p) (region-noncontiguous-p)))))
+ (perform-replace regexp to-string nil t delimited nil nil start end backward region-noncontiguous-p))
(defvar regexp-history nil
@@ -820,7 +850,6 @@ If nil, uses `regexp-history'."
(defalias 'delete-matching-lines 'flush-lines)
(defalias 'count-matches 'how-many)
-
(defun keep-lines-read-args (prompt)
"Read arguments for `keep-lines' and friends.
Prompt for a regexp with PROMPT.
@@ -900,9 +929,8 @@ a previously found match."
(set-marker rend nil)
nil)
-
(defun flush-lines (regexp &optional rstart rend interactive)
- "Delete lines containing matches for REGEXP.
+ "Delete lines containing matches for REGEXP.
When called from Lisp (and usually when called interactively as
well, see below), applies to the part of the buffer after point.
The line point is in is deleted if and only if it contains a
@@ -923,7 +951,10 @@ a non-nil INTERACTIVE argument.
If a match is split across lines, all the lines it lies in are deleted.
They are deleted _before_ looking for the next match. Hence, a match
-starting on the same line at which another match ended is ignored."
+starting on the same line at which another match ended is ignored.
+
+Return the number of deleted matching lines. When called interactively,
+also print the number."
(interactive
(progn
(barf-if-buffer-read-only)
@@ -938,7 +969,8 @@ starting on the same line at which another match ended is ignored."
(setq rstart (point)
rend (point-max-marker)))
(goto-char rstart))
- (let ((case-fold-search
+ (let ((count 0)
+ (case-fold-search
(if (and case-fold-search search-upper-case)
(isearch-no-upper-case-p regexp t)
case-fold-search)))
@@ -948,10 +980,14 @@ starting on the same line at which another match ended is ignored."
(delete-region (save-excursion (goto-char (match-beginning 0))
(forward-line 0)
(point))
- (progn (forward-line 1) (point))))))
- (set-marker rend nil)
- nil)
-
+ (progn (forward-line 1) (point)))
+ (setq count (1+ count))))
+ (set-marker rend nil)
+ (when interactive (message (ngettext "Deleted %d matching line"
+ "Deleted %d matching lines"
+ count)
+ count))
+ count))
(defun how-many (regexp &optional rstart rend interactive)
"Print and return number of matches for REGEXP following point.
@@ -999,9 +1035,10 @@ a previously found match."
(if (= opoint (point))
(forward-char 1)
(setq count (1+ count))))
- (when interactive (message "%d occurrence%s"
- count
- (if (= count 1) "" "s")))
+ (when interactive (message (ngettext "%d occurrence"
+ "%d occurrences"
+ count)
+ count))
count)))
@@ -1069,10 +1106,9 @@ a previously found match."
map)
"Keymap for `occur-mode'.")
-(defvar occur-revert-arguments nil
+(defvar-local occur-revert-arguments nil
"Arguments to pass to `occur-1' to revert an Occur mode buffer.
See `occur-revert-function'.")
-(make-variable-buffer-local 'occur-revert-arguments)
(put 'occur-revert-arguments 'permanent-local t)
(defcustom occur-mode-hook '(turn-on-font-lock)
@@ -1092,6 +1128,11 @@ for this is to reveal context in an outline-mode when the occurrence is hidden."
:type 'hook
:group 'matching)
+(defun occur--garbage-collect-revert-args ()
+ (dolist (boo (nth 2 occur-revert-arguments))
+ (when (overlayp boo) (delete-overlay boo)))
+ (kill-local-variable 'occur-revert-arguments))
+
(put 'occur-mode 'mode-class 'special)
(define-derived-mode occur-mode special-mode "Occur"
"Major mode for output from \\[occur].
@@ -1100,8 +1141,9 @@ for this is to reveal context in an outline-mode when the occurrence is hidden."
Alternatively, click \\[occur-mode-mouse-goto] on an item to go to it.
\\{occur-mode-map}"
- (set (make-local-variable 'revert-buffer-function) 'occur-revert-function)
- (setq next-error-function 'occur-next-error))
+ (setq-local revert-buffer-function #'occur-revert-function)
+ (add-hook 'kill-buffer-hook #'occur--garbage-collect-revert-args nil t)
+ (setq next-error-function #'occur-next-error))
;;; Occur Edit mode
@@ -1124,7 +1166,7 @@ the originating buffer.
To return to ordinary Occur mode, use \\[occur-cease-edit]."
(setq buffer-read-only nil)
- (add-hook 'after-change-functions 'occur-after-change-function nil t)
+ (add-hook 'after-change-functions #'occur-after-change-function nil t)
(message (substitute-command-keys
"Editing: Type \\[occur-cease-edit] to return to Occur mode.")))
@@ -1178,7 +1220,7 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]."
(defun occur-revert-function (_ignore1 _ignore2)
"Handle `revert-buffer' for Occur mode buffers."
- (apply 'occur-1 (append occur-revert-arguments (list (buffer-name)))))
+ (apply #'occur-1 (append occur-revert-arguments (list (buffer-name)))))
(defun occur-mode-find-occurrence ()
(let ((pos (get-text-property (point) 'occur-target)))
@@ -1192,7 +1234,8 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]."
(defun occur-mode-goto-occurrence (&optional event)
"Go to the occurrence on the current line."
(interactive (list last-nonmenu-event))
- (let ((pos
+ (let ((buffer (when event (current-buffer)))
+ (pos
(if (null event)
;; Actually `event-end' works correctly with a nil argument as
;; well, so we could dispense with this test, but let's not
@@ -1204,26 +1247,31 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]."
(occur-mode-find-occurrence))))))
(pop-to-buffer (marker-buffer pos))
(goto-char pos)
+ (when buffer (next-error-found buffer (current-buffer)))
(run-hooks 'occur-mode-find-occurrence-hook)))
(defun occur-mode-goto-occurrence-other-window ()
"Go to the occurrence the current line describes, in another window."
(interactive)
- (let ((pos (occur-mode-find-occurrence)))
+ (let ((buffer (current-buffer))
+ (pos (occur-mode-find-occurrence)))
(switch-to-buffer-other-window (marker-buffer pos))
(goto-char pos)
+ (next-error-found buffer (current-buffer))
(run-hooks 'occur-mode-find-occurrence-hook)))
(defun occur-mode-display-occurrence ()
"Display in another window the occurrence the current line describes."
(interactive)
- (let ((pos (occur-mode-find-occurrence))
+ (let ((buffer (current-buffer))
+ (pos (occur-mode-find-occurrence))
window)
(setq window (display-buffer (marker-buffer pos) t))
;; This is the way to set point in the proper window.
(save-selected-window
(select-window window)
(goto-char pos)
+ (next-error-found buffer (current-buffer))
(run-hooks 'occur-mode-find-occurrence-hook))))
(defun occur-find-match (n search message)
@@ -1236,7 +1284,7 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]."
(setq r (funcall search r 'occur-match)))
(if r
(goto-char r)
- (error message))
+ (user-error message))
(setq n (1- n)))))
(defun occur-next (&optional n)
@@ -1253,29 +1301,20 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]."
"Move to the Nth (default 1) next match in an Occur mode buffer.
Compatibility function for \\[next-error] invocations."
(interactive "p")
- ;; we need to run occur-find-match from within the Occur buffer
- (with-current-buffer
- ;; Choose the buffer and make it current.
- (if (next-error-buffer-p (current-buffer))
- (current-buffer)
- (next-error-find-buffer nil nil
- (lambda ()
- (eq major-mode 'occur-mode))))
-
- (goto-char (cond (reset (point-min))
- ((< argp 0) (line-beginning-position))
- ((> argp 0) (line-end-position))
- ((point))))
- (occur-find-match
- (abs argp)
- (if (> 0 argp)
- #'previous-single-property-change
- #'next-single-property-change)
- "No more matches")
- ;; In case the *Occur* buffer is visible in a nonselected window.
- (let ((win (get-buffer-window (current-buffer) t)))
- (if win (set-window-point win (point))))
- (occur-mode-goto-occurrence)))
+ (goto-char (cond (reset (point-min))
+ ((< argp 0) (line-beginning-position))
+ ((> argp 0) (line-end-position))
+ ((point))))
+ (occur-find-match
+ (abs argp)
+ (if (> 0 argp)
+ #'previous-single-property-change
+ #'next-single-property-change)
+ "No more matches")
+ ;; In case the *Occur* buffer is visible in a nonselected window.
+ (let ((win (get-buffer-window (current-buffer) t)))
+ (if win (set-window-point win (point))))
+ (occur-mode-goto-occurrence))
(defface match
'((((class color) (min-colors 88) (background light))
@@ -1385,11 +1424,6 @@ invoke `occur'."
(or unique-p (not interactive-p)))))
;; Region limits when `occur' applies on a region.
-(defvar occur--region-start nil)
-(defvar occur--region-end nil)
-(defvar occur--matches-threshold nil)
-(defvar occur--orig-line nil)
-(defvar occur--orig-line-str nil)
(defvar occur--final-pos nil)
(defun occur (regexp &optional nlines region)
@@ -1436,25 +1470,14 @@ is not modified."
(and (use-region-p) (list (region-bounds)))))
(let* ((start (and (caar region) (max (caar region) (point-min))))
(end (and (cdar region) (min (cdar region) (point-max))))
- (in-region-p (or start end)))
- (when in-region-p
- (or start (setq start (point-min)))
- (or end (setq end (point-max))))
- (let ((occur--region-start start)
- (occur--region-end end)
- (occur--matches-threshold
- (and in-region-p
- (line-number-at-pos (min start end))))
- (occur--orig-line
- (line-number-at-pos (point)))
- (occur--orig-line-str
- (buffer-substring-no-properties
- (line-beginning-position)
- (line-end-position))))
- (save-excursion ; If no matches `occur-1' doesn't restore the point.
- (and in-region-p (narrow-to-region start end))
- (occur-1 regexp nlines (list (current-buffer)))
- (and in-region-p (widen))))))
+ (in-region (or start end))
+ (bufs (if (not in-region) (list (current-buffer))
+ (let ((ol (make-overlay
+ (or start (point-min))
+ (or end (point-max)))))
+ (overlay-put ol 'occur--orig-point (point))
+ (list ol)))))
+ (occur-1 regexp nlines bufs)))
(defvar ido-ignore-item-temp-list)
@@ -1525,17 +1548,27 @@ See also `multi-occur'."
(query-replace-descr regexp))))
(defun occur-1 (regexp nlines bufs &optional buf-name)
+ ;; BUFS is a list of buffer-or-overlay!
(unless (and regexp (not (equal regexp "")))
(error "Occur doesn't work with the empty regexp"))
(unless buf-name
(setq buf-name "*Occur*"))
(let (occur-buf
- (active-bufs (delq nil (mapcar #'(lambda (buf)
- (when (buffer-live-p buf) buf))
- bufs))))
+ (active-bufs
+ (delq nil (mapcar (lambda (boo)
+ (when (or (buffer-live-p boo)
+ (and (overlayp boo)
+ (overlay-buffer boo)))
+ boo))
+ bufs))))
;; Handle the case where one of the buffers we're searching is the
;; output buffer. Just rename it.
- (when (member buf-name (mapcar 'buffer-name active-bufs))
+ (when (member buf-name
+ ;; FIXME: Use cl-exists.
+ (mapcar
+ (lambda (boo)
+ (buffer-name (if (overlayp boo) (overlay-buffer boo) boo)))
+ active-bufs))
(with-current-buffer (get-buffer buf-name)
(rename-uniquely)))
@@ -1550,27 +1583,29 @@ See also `multi-occur'."
(let ((inhibit-read-only t)
;; Don't generate undo entries for creation of the initial contents.
(buffer-undo-list t)
- (occur--final-pos nil))
+ (occur--final-pos nil))
(erase-buffer)
(let ((count
(if (stringp nlines)
;; Treat nlines as a regexp to collect.
- (let ((bufs active-bufs)
- (count 0))
- (while bufs
- (with-current-buffer (car bufs)
+ (let ((count 0))
+ (dolist (boo active-bufs)
+ (with-current-buffer
+ (if (overlayp boo) (overlay-buffer boo) boo)
(save-excursion
- (goto-char (point-min))
- (while (re-search-forward regexp nil t)
- ;; Insert the replacement regexp.
- (let ((str (match-substitute-replacement nlines)))
- (if str
- (with-current-buffer occur-buf
- (insert str)
- (setq count (1+ count))
- (or (zerop (current-column))
- (insert "\n"))))))))
- (setq bufs (cdr bufs)))
+ (goto-char
+ (if (overlayp boo) (overlay-start boo) (point-min)))
+ (let ((end (if (overlayp boo) (overlay-end boo))))
+ (while (re-search-forward regexp end t)
+ ;; Insert the replacement regexp.
+ (let ((str (match-substitute-replacement
+ nlines)))
+ (if str
+ (with-current-buffer occur-buf
+ (insert str)
+ (setq count (1+ count))
+ (or (zerop (current-column))
+ (insert "\n"))))))))))
count)
;; Perform normal occur.
(occur-engine
@@ -1586,11 +1621,12 @@ See also `multi-occur'."
(not (eq occur-excluded-properties t))))))
(let* ((bufcount (length active-bufs))
(diff (- (length bufs) bufcount)))
- (message "Searched %d buffer%s%s; %s match%s%s"
- bufcount (if (= bufcount 1) "" "s")
+ (message "Searched %d %s%s; %s %s%s"
+ bufcount
+ (ngettext "buffer" "buffers" bufcount)
(if (zerop diff) "" (format " (%d killed)" diff))
(if (zerop count) "no" (format "%d" count))
- (if (= count 1) "" "es")
+ (ngettext "match" "matches" count)
;; Don't display regexp if with remaining text
;; it is longer than window-width.
(if (> (+ (length (or (get-text-property 0 'isearch-string regexp)
@@ -1598,6 +1634,7 @@ See also `multi-occur'."
42)
(window-width))
"" (occur-regexp-descr regexp))))
+ (occur--garbage-collect-revert-args)
(setq occur-revert-arguments (list regexp nlines bufs))
(if (= count 0)
(kill-buffer occur-buf)
@@ -1613,51 +1650,55 @@ See also `multi-occur'."
(defun occur-engine (regexp buffers out-buf nlines case-fold
title-face prefix-face match-face keep-props)
+ ;; BUFFERS is a list of buffer-or-overlay!
(with-current-buffer out-buf
(let ((global-lines 0) ;; total count of matching lines
(global-matches 0) ;; total count of matches
(coding nil)
(case-fold-search case-fold)
- (in-region-p (and occur--region-start occur--region-end))
- (multi-occur-p (cdr buffers)))
+ (multi-occur-p (cdr buffers)))
;; Map over all the buffers
- (dolist (buf buffers)
- (when (buffer-live-p buf)
- (let ((lines 0) ;; count of matching lines
- (matches 0) ;; count of matches
- (curr-line ;; line count
- (or occur--matches-threshold 1))
- (orig-line occur--orig-line)
- (orig-line-str occur--orig-line-str)
- (orig-line-shown-p)
- (prev-line nil) ;; line number of prev match endpt
- (prev-after-lines nil) ;; context lines of prev match
- (matchbeg 0)
- (origpt nil)
- (begpt nil)
- (endpt nil)
- (finalpt nil)
- (marker nil)
- (curstring "")
- (ret nil)
- (inhibit-field-text-motion t)
- (headerpt (with-current-buffer out-buf (point))))
- (with-current-buffer buf
- ;; The following binding is for when case-fold-search
- ;; has a local binding in the original buffer, in which
- ;; case we cannot bind it globally and let that have
- ;; effect in every buffer we search.
- (let ((case-fold-search case-fold))
- (or coding
- ;; Set CODING only if the current buffer locally
- ;; binds buffer-file-coding-system.
- (not (local-variable-p 'buffer-file-coding-system))
- (setq coding buffer-file-coding-system))
- (save-excursion
- (goto-char (point-min)) ;; begin searching in the buffer
- (while (not (eobp))
+ (dolist (boo buffers)
+ (when (if (overlayp boo) (overlay-buffer boo) (buffer-live-p boo))
+ (with-current-buffer (if (overlayp boo) (overlay-buffer boo) boo)
+ (let ((inhibit-field-text-motion t)
+ (lines 0) ; count of matching lines
+ (matches 0) ; count of matches
+ (headerpt (with-current-buffer out-buf (point)))
+ (orig-line (if (not (overlayp boo))
+ (line-number-at-pos)
+ (line-number-at-pos
+ (overlay-get boo 'occur--orig-point)))))
+ (save-excursion
+ ;; begin searching in the buffer
+ (goto-char (if (overlayp boo) (overlay-start boo) (point-min)))
+ (forward-line 0)
+ (let* ((limit (if (overlayp boo) (overlay-end boo) (point-max)))
+ (start-line (line-number-at-pos))
+ (curr-line start-line) ; line count
+ (orig-line-shown-p)
+ (prev-line nil) ; line number of prev match endpt
+ (prev-after-lines nil) ; context lines of prev match
+ (matchbeg 0)
+ (origpt nil)
+ (begpt nil)
+ (endpt nil)
+ (marker nil)
+ (curstring "")
+ (ret nil)
+ ;; The following binding is for when case-fold-search
+ ;; has a local binding in the original buffer, in which
+ ;; case we cannot bind it globally and let that have
+ ;; effect in every buffer we search.
+ (case-fold-search case-fold))
+ (or coding
+ ;; Set CODING only if the current buffer locally
+ ;; binds buffer-file-coding-system.
+ (not (local-variable-p 'buffer-file-coding-system))
+ (setq coding buffer-file-coding-system))
+ (while (< (point) limit)
(setq origpt (point))
- (when (setq endpt (re-search-forward regexp nil t))
+ (when (setq endpt (re-search-forward regexp limit t))
(setq lines (1+ lines)) ;; increment matching lines count
(setq matchbeg (match-beginning 0))
;; Get beginning of first match line and end of the last.
@@ -1677,6 +1718,18 @@ See also `multi-occur'."
;; Count empty lines that don't use next loop (Bug#22062).
(when (zerop len)
(setq matches (1+ matches)))
+ (when (and list-matching-lines-jump-to-current-line
+ (not multi-occur-p))
+ (or orig-line (setq orig-line 1))
+ (or nlines (setq nlines (line-number-at-pos (point-max))))
+ (when (= curr-line orig-line)
+ (add-face-text-property
+ 0 len list-matching-lines-current-line-face nil curstring)
+ (add-text-properties 0 len '(current-line t) curstring))
+ (when (and (>= orig-line (- curr-line nlines))
+ (<= orig-line (+ curr-line nlines)))
+ ;; Shown either here or will be shown by occur-context-lines
+ (setq orig-line-shown-p t)))
(while (and (< start len)
(string-match regexp curstring start))
(setq matches (1+ matches))
@@ -1703,9 +1756,9 @@ See also `multi-occur'."
;; at the end of the prefix
;; (for Occur Edit mode).
front-sticky t
- rear-nonsticky t
- occur-target ,marker
- follow-link t
+ rear-nonsticky t
+ occur-target ,marker
+ follow-link t
help-echo "mouse-2: go to this occurrence"))))
(match-str
;; We don't put `mouse-face' on the newline,
@@ -1725,7 +1778,7 @@ See also `multi-occur'."
"\n"
(if prefix-face
(propertize
- "\n :" 'font-lock-face prefix-face)
+ "\n :" 'font-lock-face prefix-face)
"\n :")
match-str)
;; Add marker at eol, but no mouse props.
@@ -1737,27 +1790,33 @@ See also `multi-occur'."
;; The complex multi-line display style.
(setq ret (occur-context-lines
out-line nlines keep-props begpt
- endpt curr-line prev-line
- prev-after-lines prefix-face))
+ endpt curr-line prev-line
+ prev-after-lines prefix-face
+ orig-line multi-occur-p))
;; Set first elem of the returned list to `data',
;; and the second elem to `prev-after-lines'.
(setq prev-after-lines (nth 1 ret))
- (nth 0 ret))))
+ (nth 0 ret)))
+ (orig-line-str
+ (when (and list-matching-lines-jump-to-current-line
+ (null orig-line-shown-p)
+ (> curr-line orig-line))
+ (setq orig-line-shown-p t)
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line (1- orig-line))
+ (occur-engine-line (line-beginning-position)
+ (line-end-position) keep-props)))))
;; Actually insert the match display data
(with-current-buffer out-buf
- (when (and list-matching-lines-jump-to-current-line
- (not multi-occur-p)
- (not orig-line-shown-p)
- orig-line
- (>= curr-line orig-line))
- (insert
- (concat
- (propertize
- (format "%7d:%s" orig-line orig-line-str)
- 'face list-matching-lines-current-line-face
- 'mouse-face 'mode-line-highlight
- 'help-echo "Current line") "\n"))
- (setq orig-line-shown-p t finalpt (point)))
+ (when orig-line-str
+ (add-face-text-property
+ 0 (length orig-line-str)
+ list-matching-lines-current-line-face nil orig-line-str)
+ (add-text-properties 0 (length orig-line-str)
+ '(current-line t) orig-line-str)
+ (insert (car (occur-engine-add-prefix
+ (list orig-line-str) prefix-face))))
(insert data)))
(goto-char endpt))
(if endpt
@@ -1766,30 +1825,34 @@ See also `multi-occur'."
(setq curr-line (+ curr-line (count-lines begpt endpt)
;; Add 1 for empty last match line
;; since count-lines returns one
- ;; line less.
+ ;; line less.
(if (and (bolp) (eolp)) 1 0)))
;; On to the next match...
(forward-line 1))
(goto-char (point-max)))
(setq prev-line (1- curr-line)))
- ;; Insert original line if haven't done yet.
- (when (and list-matching-lines-jump-to-current-line
- (not multi-occur-p)
- (not orig-line-shown-p)
- orig-line)
- (with-current-buffer out-buf
- (insert
- (concat
- (propertize
- (format "%7d:%s" orig-line orig-line-str)
- 'face list-matching-lines-current-line-face
- 'mouse-face 'mode-line-highlight
- 'help-echo "Current line") "\n"))))
;; Flush remaining context after-lines.
(when prev-after-lines
(with-current-buffer out-buf
(insert (apply #'concat (occur-engine-add-prefix
- prev-after-lines prefix-face)))))))
+ prev-after-lines prefix-face)))))
+ (when (and list-matching-lines-jump-to-current-line
+ (null orig-line-shown-p))
+ (setq orig-line-shown-p t)
+ (let ((orig-line-str
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line (1- orig-line))
+ (occur-engine-line (line-beginning-position)
+ (line-end-position) keep-props))))
+ (add-face-text-property
+ 0 (length orig-line-str)
+ list-matching-lines-current-line-face nil orig-line-str)
+ (add-text-properties 0 (length orig-line-str)
+ '(current-line t) orig-line-str)
+ (with-current-buffer out-buf
+ (insert (car (occur-engine-add-prefix
+ (list orig-line-str) prefix-face))))))))
(when (not (zerop lines)) ;; is the count zero?
(setq global-lines (+ global-lines lines)
global-matches (+ global-matches matches))
@@ -1798,44 +1861,49 @@ See also `multi-occur'."
(let ((beg (point))
end)
(insert (propertize
- (format "%d match%s%s%s in buffer: %s%s\n"
- matches (if (= matches 1) "" "es")
+ (format "%d %s%s%s in buffer: %s%s\n"
+ matches
+ (ngettext "match" "matches" matches)
;; Don't display the same number of lines
;; and matches in case of 1 match per line.
(if (= lines matches)
- "" (format " in %d line%s"
+ "" (format " in %d %s"
lines
- (if (= lines 1) "" "s")))
+ (ngettext "line" "lines" lines)))
;; Don't display regexp for multi-buffer.
(if (> (length buffers) 1)
"" (occur-regexp-descr regexp))
- (buffer-name buf)
- (if in-region-p
- (format " within region: %d-%d"
- occur--region-start
- occur--region-end)
- ""))
+ (buffer-name (if (overlayp boo) (overlay-buffer boo) boo))
+ (if (overlayp boo)
+ (format " within region: %d-%d"
+ (overlay-start boo)
+ (overlay-end boo))
+ ""))
'read-only t))
(setq end (point))
- (add-text-properties beg end `(occur-title ,buf))
(when title-face
(add-face-text-property beg end title-face))
- (goto-char (if finalpt
- (setq occur--final-pos
- (cl-incf finalpt (- end beg)))
- (point-min))))))))))
+ (goto-char (if (and list-matching-lines-jump-to-current-line
+ (not multi-occur-p))
+ (setq occur--final-pos
+ (and (goto-char (point-max))
+ (or (previous-single-property-change (point) 'current-line)
+ (point-max))))
+ (point-min))))))))))
;; Display total match count and regexp for multi-buffer.
(when (and (not (zerop global-lines)) (> (length buffers) 1))
(goto-char (point-min))
(let ((beg (point))
end)
- (insert (format "%d match%s%s total%s:\n"
- global-matches (if (= global-matches 1) "" "es")
+ (insert (format "%d %s%s total%s:\n"
+ global-matches
+ (ngettext "match" "matches" global-matches)
;; Don't display the same number of lines
;; and matches in case of 1 match per line.
(if (= global-lines global-matches)
- "" (format " in %d line%s"
- global-lines (if (= global-lines 1) "" "s")))
+ "" (format " in %d %s"
+ global-lines
+ (ngettext "line" "lines" global-lines)))
(occur-regexp-descr regexp)))
(setq end (point))
(when title-face
@@ -1850,10 +1918,8 @@ See also `multi-occur'."
global-matches)))
(defun occur-engine-line (beg end &optional keep-props)
- (if (and keep-props (if (boundp 'jit-lock-mode) jit-lock-mode)
- (text-property-not-all beg end 'fontified t))
- (if (fboundp 'jit-lock-fontify-now)
- (jit-lock-fontify-now beg end)))
+ (if (and keep-props font-lock-mode)
+ (font-lock-ensure beg end))
(if (and keep-props (not (eq occur-excluded-properties t)))
(let ((str (buffer-substring beg end)))
(remove-list-of-text-properties
@@ -1897,7 +1963,8 @@ See also `multi-occur'."
;; then concatenate them all together.
(defun occur-context-lines (out-line nlines keep-props begpt endpt
curr-line prev-line prev-after-lines
- &optional prefix-face)
+ &optional prefix-face
+ orig-line multi-occur-p)
;; Find after- and before-context lines of the current match.
(let ((before-lines
(nreverse (cdr (occur-accumulate-lines
@@ -1907,13 +1974,32 @@ See also `multi-occur'."
(1+ nlines) keep-props endpt)))
separator)
+ (when (and list-matching-lines-jump-to-current-line
+ (not multi-occur-p))
+ (when (and (>= orig-line (- curr-line nlines))
+ (< orig-line curr-line))
+ (let ((curstring (nth (- (length before-lines) (- curr-line orig-line)) before-lines)))
+ (add-face-text-property
+ 0 (length curstring)
+ list-matching-lines-current-line-face nil curstring)
+ (add-text-properties 0 (length curstring)
+ '(current-line t) curstring)))
+ (when (and (<= orig-line (+ curr-line nlines))
+ (> orig-line curr-line))
+ (let ((curstring (nth (- orig-line curr-line 1) after-lines)))
+ (add-face-text-property
+ 0 (length curstring)
+ list-matching-lines-current-line-face nil curstring)
+ (add-text-properties 0 (length curstring)
+ '(current-line t) curstring))))
+
;; Combine after-lines of the previous match
;; with before-lines of the current match.
(when prev-after-lines
;; Don't overlap prev after-lines with current before-lines.
(if (>= (+ prev-line (length prev-after-lines))
- (- curr-line (length before-lines)))
+ (- curr-line (length before-lines)))
(setq prev-after-lines
(butlast prev-after-lines
(- (length prev-after-lines)
@@ -2186,9 +2272,9 @@ It is called with three arguments, as if it were
;; used after `recursive-edit' might override them.
(let* ((isearch-regexp regexp-flag)
(isearch-regexp-function (or delimited-flag
- (and replace-char-fold
- (not regexp-flag)
- #'char-fold-to-regexp)))
+ (and replace-char-fold
+ (not regexp-flag)
+ #'char-fold-to-regexp)))
(isearch-lax-whitespace
replace-lax-whitespace)
(isearch-regexp-lax-whitespace
@@ -2218,7 +2304,10 @@ It is called with three arguments, as if it were
(if query-replace-lazy-highlight
(let ((isearch-string search-string)
(isearch-regexp regexp-flag)
- (isearch-regexp-function delimited-flag)
+ (isearch-regexp-function (or delimited-flag
+ (and replace-char-fold
+ (not regexp-flag)
+ #'char-fold-to-regexp)))
(isearch-lax-whitespace
replace-lax-whitespace)
(isearch-regexp-lax-whitespace
@@ -2279,7 +2368,12 @@ REPLACEMENTS is either a string, a list of strings, or a cons cell
containing a function and its first argument. The function is
called to generate each replacement like this:
(funcall (car replacements) (cdr replacements) replace-count)
-It must return a string."
+It must return a string.
+
+Non-nil REGION-NONCONTIGUOUS-P means that the region is composed of
+noncontiguous pieces. The most common example of this is a
+rectangular region, where the pieces are separated by newline
+characters."
(or map (setq map query-replace-map))
(and query-flag minibuffer-auto-raise
(raise-frame (window-frame (minibuffer-window))))
@@ -2323,9 +2417,18 @@ It must return a string."
(message
(if query-flag
- (apply 'propertize
- (substitute-command-keys
- "Query replacing %s with %s: (\\<query-replace-map>\\[help] for help) ")
+ (apply #'propertize
+ (concat "Query replacing "
+ (if backward "backward " "")
+ (if delimited-flag
+ (or (and (symbolp delimited-flag)
+ (get delimited-flag
+ 'isearch-message-prefix))
+ "word ") "")
+ (if regexp-flag "regexp " "")
+ "%s with %s: "
+ (substitute-command-keys
+ "(\\<query-replace-map>\\[help] for help) "))
minibuffer-prompt-properties))))
;; Unless a single contiguous chunk is selected, operate on multiple chunks.
@@ -2540,22 +2643,24 @@ It must return a string."
(setq def (lookup-key map key))
;; Restore the match data while we process the command.
(cond ((eq def 'help)
- (with-output-to-temp-buffer "*Help*"
- (princ
- (concat "Query replacing "
- (if delimited-flag
- (or (and (symbolp delimited-flag)
- (get delimited-flag
- 'isearch-message-prefix))
- "word ") "")
- (if regexp-flag "regexp " "")
- (if backward "backward " "")
- from-string " with "
- next-replacement ".\n\n"
- (substitute-command-keys
- query-replace-help)))
- (with-current-buffer standard-output
- (help-mode))))
+ (let ((display-buffer-overriding-action
+ '(nil (inhibit-same-window . t))))
+ (with-output-to-temp-buffer "*Help*"
+ (princ
+ (concat "Query replacing "
+ (if backward "backward " "")
+ (if delimited-flag
+ (or (and (symbolp delimited-flag)
+ (get delimited-flag
+ 'isearch-message-prefix))
+ "word ") "")
+ (if regexp-flag "regexp " "")
+ from-string " with "
+ next-replacement ".\n\n"
+ (substitute-command-keys
+ query-replace-help)))
+ (with-current-buffer standard-output
+ (help-mode)))))
((eq def 'exit)
(setq keep-going nil)
(setq done t))
@@ -2635,10 +2740,10 @@ It must return a string."
(1+ num-replacements))))))
(when (and (eq def 'undo-all)
(null (zerop num-replacements)))
- (message "Undid %d %s" num-replacements
- (if (= num-replacements 1)
- "replacement"
- "replacements"))
+ (message (ngettext "Undid %d replacement"
+ "Undid %d replacements"
+ num-replacements)
+ num-replacements)
(ding 'no-terminate)
(sit-for 1)))
(setq replaced nil last-was-undo t last-was-act-and-show nil)))
@@ -2764,15 +2869,17 @@ It must return a string."
last-was-act-and-show nil))))))
(replace-dehighlight))
(or unread-command-events
- (message "Replaced %d occurrence%s%s"
+ (message (ngettext "Replaced %d occurrence%s"
+ "Replaced %d occurrences%s"
+ replace-count)
replace-count
- (if (= replace-count 1) "" "s")
(if (> (+ skip-read-only-count
skip-filtered-count
- skip-invisible-count) 0)
+ skip-invisible-count)
+ 0)
(format " (skipped %s)"
(mapconcat
- 'identity
+ #'identity
(delq nil (list
(if (> skip-read-only-count 0)
(format "%s read-only"
diff --git a/lisp/reveal.el b/lisp/reveal.el
index d5dc3acf79a..67740c8149b 100644
--- a/lisp/reveal.el
+++ b/lisp/reveal.el
@@ -191,9 +191,6 @@ Each element has the form (WINDOW . OVERLAY).")
;;;###autoload
(define-minor-mode reveal-mode
"Toggle uncloaking of invisible text near point (Reveal mode).
-With a prefix argument ARG, enable Reveal mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-Reveal mode if ARG is omitted or nil.
Reveal mode is a buffer-local minor mode. When enabled, it
reveals invisible text around point."
@@ -210,11 +207,7 @@ reveals invisible text around point."
;;;###autoload
(define-minor-mode global-reveal-mode
"Toggle Reveal mode in all buffers (Global Reveal mode).
-Reveal mode renders invisible text around point visible again.
-
-With a prefix argument ARG, enable Global Reveal mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil."
+Reveal mode renders invisible text around point visible again."
:global t :group 'reveal
(setq-default reveal-mode global-reveal-mode)
(if global-reveal-mode
diff --git a/lisp/rfn-eshadow.el b/lisp/rfn-eshadow.el
index 0a65e9a7384..d0a022aa92e 100644
--- a/lisp/rfn-eshadow.el
+++ b/lisp/rfn-eshadow.el
@@ -207,9 +207,6 @@ been set up by `rfn-eshadow-setup-minibuffer'."
(define-minor-mode file-name-shadow-mode
"Toggle file-name shadowing in minibuffers (File-Name Shadow mode).
-With a prefix argument ARG, enable File-Name Shadow mode if ARG
-is positive, and disable it otherwise. If called from Lisp,
-enable the mode if ARG is omitted or nil.
File-Name Shadow mode is a global minor mode. When enabled, any
part of a filename being read in the minibuffer that would be
diff --git a/lisp/rtree.el b/lisp/rtree.el
index ff160f207b2..9a0a649abf1 100644
--- a/lisp/rtree.el
+++ b/lisp/rtree.el
@@ -1,4 +1,4 @@
-;;; rtree.el --- functions for manipulating range trees
+;;; rtree.el --- functions for manipulating range trees -*- lexical-binding:t -*-
;; Copyright (C) 2010-2019 Free Software Foundation, Inc.
@@ -43,11 +43,8 @@
;;; Code:
-(eval-when-compile
- (require 'cl))
-
(defmacro rtree-make-node ()
- `(list (list nil) nil))
+ '(list (list nil) nil))
(defmacro rtree-set-left (node left)
`(setcar (cdr ,node) ,left))
@@ -85,7 +82,7 @@
range)
(define-obsolete-function-alias 'rtree-normalise-range
- 'rtree-normalize-range "25.1")
+ #'rtree-normalize-range "25.1")
(defun rtree-make (range)
"Make an rtree from RANGE."
diff --git a/lisp/ruler-mode.el b/lisp/ruler-mode.el
index ddf62d913d4..c5c88d03e08 100644
--- a/lisp/ruler-mode.el
+++ b/lisp/ruler-mode.el
@@ -591,10 +591,7 @@ format first."
;;;###autoload
(define-minor-mode ruler-mode
- "Toggle display of ruler in header line (Ruler mode).
-With a prefix argument ARG, enable Ruler mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil."
+ "Toggle display of ruler in header line (Ruler mode)."
nil nil
ruler-mode-map
:group 'ruler-mode
@@ -616,7 +613,7 @@ if ARG is omitted or nil."
;; Add ruler-mode to the minor mode menu in the mode line
(define-key mode-line-mode-menu [ruler-mode]
- `(menu-item "Ruler" ruler-mode
+ '(menu-item "Ruler" ruler-mode
:button (:toggle . ruler-mode)))
(defconst ruler-mode-ruler-help-echo
@@ -709,20 +706,18 @@ Optional argument PROPS specifies other text properties to apply."
;; Create an "clean" ruler.
(ruler
(propertize
- ;; FIXME: `make-string' returns a unibyte string if it's ASCII-only,
- ;; which prevents further `aset' from inserting non-ASCII chars,
- ;; hence the need for `string-to-multibyte'.
- ;; https://lists.gnu.org/r/emacs-devel/2017-05/msg00841.html
- (string-to-multibyte
- ;; Make the part of header-line corresponding to the
- ;; line-number display be blank, not filled with
- ;; ruler-mode-basic-graduation-char.
- (if display-line-numbers
- (let* ((lndw (round (line-number-display-width 'columns)))
- (s (make-string lndw ?\s)))
- (concat s (make-string (- w lndw)
- ruler-mode-basic-graduation-char)))
- (make-string w ruler-mode-basic-graduation-char)))
+ ;; Make the part of header-line corresponding to the
+ ;; line-number display be blank, not filled with
+ ;; ruler-mode-basic-graduation-char.
+ (if display-line-numbers
+ (let* ((lndw (round (line-number-display-width 'columns)))
+ ;; We need a multibyte string here so we could
+ ;; later use aset to insert multibyte characters
+ ;; into that string.
+ (s (make-string lndw ?\s t)))
+ (concat s (make-string (- w lndw)
+ ruler-mode-basic-graduation-char t)))
+ (make-string w ruler-mode-basic-graduation-char t))
'face 'ruler-mode-default
'local-map ruler-mode-map
'help-echo (cond
diff --git a/lisp/savehist.el b/lisp/savehist.el
index 795a3cab744..1eab18ef763 100644
--- a/lisp/savehist.el
+++ b/lisp/savehist.el
@@ -171,9 +171,6 @@ minibuffer history.")
;;;###autoload
(define-minor-mode savehist-mode
"Toggle saving of minibuffer history (Savehist mode).
-With a prefix argument ARG, enable Savehist mode if ARG is
-positive, and disable it otherwise. If called from Lisp,
-also enable the mode if ARG is omitted or nil.
When Savehist mode is enabled, minibuffer history is saved
to `savehist-file' periodically and when exiting Emacs. When
@@ -221,29 +218,6 @@ histories, which is probably undesirable."
(signal (car errvar) (cdr errvar)))))
(savehist-install)))
-(defun savehist-load ()
- "Load the variables stored in `savehist-file' and turn on Savehist mode.
-If `savehist-file' is in the old format that doesn't record
-the value of `savehist-minibuffer-history-variables', that
-value is deducted from the contents of the file."
- (declare (obsolete savehist-mode "22.1"))
- (savehist-mode 1)
- ;; Old versions of savehist distributed with XEmacs didn't save
- ;; savehist-minibuffer-history-variables. If that variable is nil
- ;; after loading the file, try to intuit the intended value.
- (when (null savehist-minibuffer-history-variables)
- (setq savehist-minibuffer-history-variables
- (with-temp-buffer
- (ignore-errors
- (insert-file-contents savehist-file))
- (let ((vars ()) form)
- (while (setq form (condition-case nil
- (read (current-buffer)) (error nil)))
- ;; Each form read is of the form (setq VAR VALUE).
- ;; Collect VAR, i.e. (nth form 1).
- (push (nth 1 form) vars))
- vars)))))
-
(defun savehist-install ()
"Hook Savehist into Emacs.
Normally invoked by calling `savehist-mode' to set the minor mode.
diff --git a/lisp/saveplace.el b/lisp/saveplace.el
index 56cfce39c8e..730d31ead25 100644
--- a/lisp/saveplace.el
+++ b/lisp/saveplace.el
@@ -160,9 +160,6 @@ If this mode is enabled, point is recorded when you kill the buffer
or exit Emacs. Visiting this file again will go to that position,
even in a later Emacs session.
-If called with a prefix arg, the mode is enabled if and only if
-the argument is positive.
-
To save places automatically in all files, put this in your init
file:
diff --git a/lisp/scroll-all.el b/lisp/scroll-all.el
index 08e8bc699b8..78a05b5d31d 100644
--- a/lisp/scroll-all.el
+++ b/lisp/scroll-all.el
@@ -102,9 +102,6 @@
;;;###autoload
(define-minor-mode scroll-all-mode
"Toggle shared scrolling in same-frame windows (Scroll-All mode).
-With a prefix argument ARG, enable Scroll-All mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
When Scroll-All mode is enabled, scrolling commands invoked in
one window apply to all visible windows in the same frame."
diff --git a/lisp/scroll-bar.el b/lisp/scroll-bar.el
index e864b41c7d2..dc0df7ab3fe 100644
--- a/lisp/scroll-bar.el
+++ b/lisp/scroll-bar.el
@@ -133,9 +133,6 @@ Setting the variable with a customization buffer also takes effect."
(define-minor-mode scroll-bar-mode
"Toggle vertical scroll bars on all frames (Scroll Bar mode).
-With a prefix argument ARG, enable Scroll Bar mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
This command applies to all frames that exist and frames to be
created in the future."
@@ -152,9 +149,6 @@ created in the future."
(define-minor-mode horizontal-scroll-bar-mode
"Toggle horizontal scroll bars on all frames (Horizontal Scroll Bar mode).
-With a prefix argument ARG, enable Horizontal Scroll Bar mode if
-ARG is positive, and disable it otherwise. If called from Lisp,
-enable the mode if ARG is omitted or nil.
This command applies to all frames that exist and frames to be
created in the future."
@@ -260,14 +254,22 @@ EVENT should be a scroll bar click or drag event."
(let* ((start-position (event-start event))
(window (nth 0 start-position))
(portion-whole (nth 2 start-position)))
- (save-excursion
- (with-current-buffer (window-buffer window)
- ;; Calculate position relative to the accessible part of the buffer.
- (goto-char (+ (point-min)
- (scroll-bar-scale portion-whole
- (- (point-max) (point-min)))))
- (vertical-motion 0 window)
- (set-window-start window (point))))))
+ ;; With 'scroll-bar-adjust-thumb-portion' nil and 'portion-whole'
+ ;; indicating that the buffer is fully visible, do not scroll the
+ ;; window since that might make it impossible to scroll it back
+ ;; with GTK's thumb (Bug#32002).
+ (when (or scroll-bar-adjust-thumb-portion
+ (not (numberp (car portion-whole)))
+ (not (numberp (cdr portion-whole)))
+ (/= (car portion-whole) (cdr portion-whole)))
+ (save-excursion
+ (with-current-buffer (window-buffer window)
+ ;; Calculate position relative to the accessible part of the buffer.
+ (goto-char (+ (point-min)
+ (scroll-bar-scale portion-whole
+ (- (point-max) (point-min)))))
+ (vertical-motion 0 window)
+ (set-window-start window (point)))))))
(defun scroll-bar-drag (event)
"Scroll the window by dragging the scroll bar slider.
diff --git a/lisp/scroll-lock.el b/lisp/scroll-lock.el
index f3ab069b3ec..8281edb1720 100644
--- a/lisp/scroll-lock.el
+++ b/lisp/scroll-lock.el
@@ -49,12 +49,11 @@
;;;###autoload
(define-minor-mode scroll-lock-mode
"Buffer-local minor mode for pager-like scrolling.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil. When enabled, keys that normally move
-point by line or paragraph will scroll the buffer by the
-respective amount of lines instead and point will be kept
-vertically fixed relative to window boundaries during scrolling."
+
+When enabled, keys that normally move point by line or paragraph
+will scroll the buffer by the respective amount of lines instead
+and point will be kept vertically fixed relative to window
+boundaries during scrolling."
:lighter " ScrLck"
:keymap scroll-lock-mode-map
(if scroll-lock-mode
diff --git a/lisp/select.el b/lisp/select.el
index f590025d8b9..c79e923b743 100644
--- a/lisp/select.el
+++ b/lisp/select.el
@@ -86,6 +86,8 @@ After the communication, this variable is set to nil.")
;; Only declared obsolete in 23.3.
(define-obsolete-function-alias 'x-selection 'x-get-selection "at least 19.34")
+(define-obsolete-variable-alias 'x-select-enable-clipboard
+ 'select-enable-clipboard "25.1")
(defcustom select-enable-clipboard t
"Non-nil means cutting and pasting uses the clipboard.
This can be in addition to, but in preference to, the primary selection,
@@ -94,9 +96,9 @@ if applicable (i.e. under X11)."
:group 'killing
;; The GNU/Linux version changed in 24.1, the MS-Windows version did not.
:version "24.1")
-(define-obsolete-variable-alias 'x-select-enable-clipboard
- 'select-enable-clipboard "25.1")
+(define-obsolete-variable-alias 'x-select-enable-primary
+ 'select-enable-primary "25.1")
(defcustom select-enable-primary nil
"Non-nil means cutting and pasting uses the primary selection.
The existence of a primary selection depends on the underlying GUI you use.
@@ -104,8 +106,6 @@ E.g. it doesn't exist under MS-Windows."
:type 'boolean
:group 'killing
:version "25.1")
-(define-obsolete-variable-alias 'x-select-enable-primary
- 'select-enable-primary "25.1")
;; We keep track of the last text selected here, so we can check the
;; current selection against it, and avoid passing back our own text
diff --git a/lisp/server.el b/lisp/server.el
index a39b1cb46d4..c38fdf84835 100644
--- a/lisp/server.el
+++ b/lisp/server.el
@@ -188,6 +188,13 @@ space (this means characters from ! to ~; or from code 33 to
:group 'server
:type 'hook)
+(defcustom server-after-make-frame-hook nil
+ "Hook run when the Emacs server creates a client frame.
+The created frame is selected when the hook is called."
+ :group 'server
+ :type 'hook
+ :version "27.1")
+
(defcustom server-done-hook nil
"Hook run when done editing a buffer for the Emacs server."
:group 'server
@@ -251,8 +258,16 @@ This means that the server should not kill the buffer when you say you
are done with it in the server.")
(make-variable-buffer-local 'server-existing-buffer)
-;;;###autoload
-(defcustom server-name "server"
+(defvar server--external-socket-initialized nil
+ "When an external socket is passed into Emacs, we need to call
+`server-start' in order to initialize the connection. This flag
+prevents multiple initializations when an external socket has
+been consumed.")
+
+(defcustom server-name
+ (if internal--daemon-sockname
+ (file-name-nondirectory internal--daemon-sockname)
+ "server")
"The name of the Emacs server, if this Emacs process creates one.
The command `server-start' makes use of this. It should not be
changed while a server is running.
@@ -270,8 +285,13 @@ the \"-f\" switch otherwise."
;; We do not use `temporary-file-directory' here, because emacsclient
;; does not read the init file.
(defvar server-socket-dir
- (and (featurep 'make-network-process '(:family local))
- (format "%s/emacs%d" (or (getenv "TMPDIR") "/tmp") (user-uid)))
+ (if internal--daemon-sockname
+ (file-name-directory internal--daemon-sockname)
+ (and (featurep 'make-network-process '(:family local))
+ (let ((xdg_runtime_dir (getenv "XDG_RUNTIME_DIR")))
+ (if xdg_runtime_dir
+ (format "%s/emacs" xdg_runtime_dir)
+ (format "%s/emacs%d" (or (getenv "TMPDIR") "/tmp") (user-uid))))))
"The directory in which to place the server socket.
If local sockets are not supported, this is nil.")
@@ -530,13 +550,13 @@ Creates the directory if necessary and makes sure:
(setq attrs (file-attributes dir 'integer)))
;; Check that it's safe for use.
- (let* ((uid (nth 2 attrs))
+ (let* ((uid (file-attribute-user-id attrs))
(w32 (eq system-type 'windows-nt))
(unsafe (cond
- ((not (eq t (car attrs)))
+ ((not (eq t (file-attribute-type attrs)))
(if (null attrs) "its attributes can't be checked"
(format "it is a %s"
- (if (stringp (car attrs))
+ (if (stringp (file-attribute-type attrs))
"symlink" "file"))))
((and w32 (zerop uid)) ; on FAT32?
(display-warning
@@ -628,23 +648,29 @@ the `server-process' variable."
(when server-process
;; kill it dead!
(ignore-errors (delete-process server-process)))
- ;; Delete the socket files made by previous server invocations.
- (if (not (eq t (server-running-p server-name)))
- ;; Remove any leftover socket or authentication file
- (ignore-errors
- (let (delete-by-moving-to-trash)
- (delete-file server-file)))
- (setq server-mode nil) ;; already set by the minor mode code
- (display-warning
- 'server
- (concat "Unable to start the Emacs server.\n"
- (format "There is an existing Emacs server, named %S.\n"
- server-name)
- (substitute-command-keys
- "To start the server in this Emacs process, stop the existing
+ ;; Check to see if an uninitialized external socket has been
+ ;; passed in, if that is the case, skip checking
+ ;; `server-running-p' as this will return the wrong result.
+ (if (and internal--daemon-sockname
+ (not server--external-socket-initialized))
+ (setq server--external-socket-initialized t)
+ ;; Delete the socket files made by previous server invocations.
+ (if (not (eq t (server-running-p server-name)))
+ ;; Remove any leftover socket or authentication file.
+ (ignore-errors
+ (let (delete-by-moving-to-trash)
+ (delete-file server-file)))
+ (setq server-mode nil) ;; already set by the minor mode code
+ (display-warning
+ 'server
+ (concat "Unable to start the Emacs server.\n"
+ (format "There is an existing Emacs server, named %S.\n"
+ server-name)
+ (substitute-command-keys
+ "To start the server in this Emacs process, stop the existing
server or call `\\[server-force-delete]' to forcibly disconnect it."))
- :warning)
- (setq leave-dead t))
+ :warning)
+ (setq leave-dead t)))
;; If this Emacs already had a server, clear out associated status.
(while server-clients
(server-delete-client (car server-clients)))
@@ -761,9 +787,6 @@ by the current Emacs process, use the `server-process' variable."
;;;###autoload
(define-minor-mode server-mode
"Toggle Server mode.
-With a prefix argument ARG, enable Server mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-Server mode if ARG is omitted or nil.
Server mode runs a process that accepts commands from the
`emacsclient' program. See Info node `Emacs server' and
@@ -1075,9 +1098,8 @@ The following commands are accepted by the client:
;; supported any more.
(cl-assert (eq (match-end 0) (length string)))
(let ((request (substring string 0 (match-beginning 0)))
- (coding-system (and (default-value 'enable-multibyte-characters)
- (or file-name-coding-system
- default-file-name-coding-system)))
+ (coding-system (or file-name-coding-system
+ default-file-name-coding-system))
nowait ; t if emacsclient does not want to wait for us.
frame ; Frame opened for the client (if any).
display ; Open frame on this display.
@@ -1091,7 +1113,8 @@ The following commands are accepted by the client:
tty-type ; string.
files
filepos
- args-left)
+ args-left
+ create-frame-func)
;; Remove this line from STRING.
(setq string (substring string (match-end 0)))
(setq args-left
@@ -1099,16 +1122,16 @@ The following commands are accepted by the client:
(while args-left
(pcase (pop args-left)
;; -version CLIENT-VERSION: obsolete at birth.
- (`"-version" (pop args-left))
+ ("-version" (pop args-left))
;; -nowait: Emacsclient won't wait for a result.
- (`"-nowait" (setq nowait t))
+ ("-nowait" (setq nowait t))
;; -current-frame: Don't create frames.
- (`"-current-frame" (setq use-current-frame t))
+ ("-current-frame" (setq use-current-frame t))
;; -frame-parameters: Set frame parameters
- (`"-frame-parameters"
+ ("-frame-parameters"
(let ((alist (pop args-left)))
(if coding-system
(setq alist (decode-coding-string alist coding-system)))
@@ -1116,24 +1139,24 @@ The following commands are accepted by the client:
;; -display DISPLAY:
;; Open X frames on the given display instead of the default.
- (`"-display"
+ ("-display"
(setq display (pop args-left))
(if (zerop (length display)) (setq display nil)))
;; -parent-id ID:
;; Open X frame within window ID, via XEmbed.
- (`"-parent-id"
+ ("-parent-id"
(setq parent-id (pop args-left))
(if (zerop (length parent-id)) (setq parent-id nil)))
;; -window-system: Open a new X frame.
- (`"-window-system"
+ ("-window-system"
(if (fboundp 'x-create-frame)
(setq dontkill t
tty-name 'window-system)))
;; -resume: Resume a suspended tty frame.
- (`"-resume"
+ ("-resume"
(let ((terminal (process-get proc 'terminal)))
(setq dontkill t)
(push (lambda ()
@@ -1144,7 +1167,7 @@ The following commands are accepted by the client:
;; -suspend: Suspend the client's frame. (In case we
;; get out of sync, and a C-z sends a SIGTSTP to
;; emacsclient.)
- (`"-suspend"
+ ("-suspend"
(let ((terminal (process-get proc 'terminal)))
(setq dontkill t)
(push (lambda ()
@@ -1154,13 +1177,13 @@ The following commands are accepted by the client:
;; -ignore COMMENT: Noop; useful for debugging emacsclient.
;; (The given comment appears in the server log.)
- (`"-ignore"
+ ("-ignore"
(setq dontkill t)
(pop args-left))
;; -tty DEVICE-NAME TYPE: Open a new tty frame.
;; (But if we see -window-system later, use that.)
- (`"-tty"
+ ("-tty"
(setq tty-name (pop args-left)
tty-type (pop args-left)
dontkill (or dontkill
@@ -1179,7 +1202,7 @@ The following commands are accepted by the client:
;; -position LINE[:COLUMN]: Set point to the given
;; position in the next file.
- (`"-position"
+ ("-position"
(if (not (string-match "\\+\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?"
(car args-left)))
(error "Invalid -position command in client args"))
@@ -1190,7 +1213,7 @@ The following commands are accepted by the client:
""))))))
;; -file FILENAME: Load the given file.
- (`"-file"
+ ("-file"
(let ((file (pop args-left)))
(if coding-system
(setq file (decode-coding-string file coding-system)))
@@ -1208,7 +1231,7 @@ The following commands are accepted by the client:
(setq filepos nil))
;; -eval EXPR: Evaluate a Lisp expression.
- (`"-eval"
+ ("-eval"
(if use-current-frame
(setq use-current-frame 'always))
(let ((expr (pop args-left)))
@@ -1219,14 +1242,14 @@ The following commands are accepted by the client:
(setq filepos nil)))
;; -env NAME=VALUE: An environment variable.
- (`"-env"
+ ("-env"
(let ((var (pop args-left)))
;; XXX Variables should be encoded as in getenv/setenv.
(process-put proc 'env
(cons var (process-get proc 'env)))))
;; -dir DIRNAME: The cwd of the emacsclient process.
- (`"-dir"
+ ("-dir"
(setq dir (pop args-left))
(if coding-system
(setq dir (decode-coding-string dir coding-system)))
@@ -1243,28 +1266,29 @@ The following commands are accepted by the client:
(or files commands)
(setq use-current-frame t))
- (setq frame
- (cond
- ((and use-current-frame
- (or (eq use-current-frame 'always)
- ;; We can't use the Emacs daemon's
- ;; terminal frame.
- (not (and (daemonp)
- (null (cdr (frame-list)))
- (eq (selected-frame)
- terminal-frame)))))
- (setq tty-name nil tty-type nil)
- (if display (server-select-display display)))
- ((or (and (eq system-type 'windows-nt)
- (daemonp)
- (setq display "w32"))
- (eq tty-name 'window-system))
- (server-create-window-system-frame display nowait proc
- parent-id
- frame-parameters))
- ;; When resuming on a tty, tty-name is nil.
- (tty-name
- (server-create-tty-frame tty-name tty-type proc))))
+ (setq create-frame-func
+ (lambda ()
+ (cond
+ ((and use-current-frame
+ (or (eq use-current-frame 'always)
+ ;; We can't use the Emacs daemon's
+ ;; terminal frame.
+ (not (and (daemonp)
+ (null (cdr (frame-list)))
+ (eq (selected-frame)
+ terminal-frame)))))
+ (setq tty-name nil tty-type nil)
+ (if display (server-select-display display)))
+ ((or (and (eq system-type 'windows-nt)
+ (daemonp)
+ (setq display "w32"))
+ (eq tty-name 'window-system))
+ (server-create-window-system-frame display nowait proc
+ parent-id
+ frame-parameters))
+ ;; When resuming on a tty, tty-name is nil.
+ (tty-name
+ (server-create-tty-frame tty-name tty-type proc)))))
(process-put
proc 'continuation
@@ -1276,16 +1300,16 @@ The following commands are accepted by the client:
(if (and dir (file-directory-p dir))
dir default-directory)))
(server-execute proc files nowait commands
- dontkill frame tty-name)))))
+ dontkill create-frame-func tty-name)))))
(when (or frame files)
(server-goto-toplevel proc))
(server-execute-continuation proc))))
;; condition-case
- (error (server-return-error proc err))))
+ (t (server-return-error proc err))))
-(defun server-execute (proc files nowait commands dontkill frame tty-name)
+(defun server-execute (proc files nowait commands dontkill create-frame-func tty-name)
;; This is run from timers and process-filters, i.e. "asynchronously".
;; But w.r.t the user, this is not really asynchronous since the timer
;; is run after 0s and the process-filter is run in response to the
@@ -1295,21 +1319,29 @@ The following commands are accepted by the client:
;; including code that needs to wait.
(with-local-quit
(condition-case err
- (let ((buffers (server-visit-files files proc nowait)))
- (mapc 'funcall (nreverse commands))
+ (let* ((buffers (server-visit-files files proc nowait))
+ ;; If we were told only to open a new client, obey
+ ;; `initial-buffer-choice' if it specifies a file
+ ;; or a function.
+ (initial-buffer (unless (or files commands)
+ (let ((buf
+ (cond ((stringp initial-buffer-choice)
+ (find-file-noselect initial-buffer-choice))
+ ((functionp initial-buffer-choice)
+ (funcall initial-buffer-choice)))))
+ (if (buffer-live-p buf) buf (get-buffer-create "*scratch*")))))
+ ;; Set current buffer so that newly created tty frames
+ ;; show the correct buffer initially.
+ (frame (with-current-buffer (or (car buffers)
+ initial-buffer
+ (current-buffer))
+ (prog1
+ (funcall create-frame-func)
+ ;; Switch to initial buffer in case the frame was reused.
+ (when initial-buffer
+ (switch-to-buffer initial-buffer 'norecord))))))
- ;; If we were told only to open a new client, obey
- ;; `initial-buffer-choice' if it specifies a file
- ;; or a function.
- (unless (or files commands)
- (let ((buf
- (cond ((stringp initial-buffer-choice)
- (find-file-noselect initial-buffer-choice))
- ((functionp initial-buffer-choice)
- (funcall initial-buffer-choice)))))
- (switch-to-buffer
- (if (buffer-live-p buf) buf (get-buffer-create "*scratch*"))
- 'norecord)))
+ (mapc 'funcall (nreverse commands))
;; Delete the client if necessary.
(cond
@@ -1325,9 +1357,11 @@ The following commands are accepted by the client:
((or isearch-mode (minibufferp))
nil)
((and frame (null buffers))
+ (run-hooks 'server-after-make-frame-hook)
(message "%s" (substitute-command-keys
"When done with this frame, type \\[delete-frame]")))
((not (null buffers))
+ (run-hooks 'server-after-make-frame-hook)
(server-switch-buffer (car buffers) nil (cdr (car files)))
(run-hooks 'server-switch-hook)
(unless nowait
@@ -1646,13 +1680,15 @@ only these files will be asked to be saved."
(save-buffers-kill-emacs arg)))
((processp proc)
(let ((buffers (process-get proc 'buffers)))
- ;; If client is bufferless, emulate a normal Emacs exit
- ;; and offer to save all buffers. Otherwise, offer to
- ;; save only the buffers belonging to the client.
(save-some-buffers
arg (if buffers
+ ;; Only files from emacsclient file list.
(lambda () (memq (current-buffer) buffers))
- t))
+ ;; No emacsclient file list: don't override
+ ;; `save-some-buffers-default-predicate' (unless
+ ;; ARG is non-nil), since we're not killing
+ ;; Emacs (unlike `save-buffers-kill-emacs').
+ (and arg t)))
(server-delete-client proc)))
(t (error "Invalid client frame")))))
@@ -1708,7 +1744,7 @@ returns the process ID of the Emacs instance running \"server\"."
(server-quote-arg (format "%S" form))
"\n"))
(while (memq (process-status process) '(open run))
- (accept-process-output process 0 10))
+ (accept-process-output process 0.01))
(goto-char (point-min))
;; If the result is nil, there's nothing in the buffer. If the
;; result is non-nil, it's after "-print ".
diff --git a/lisp/ses.el b/lisp/ses.el
index f3de00427b3..73157d6f5f0 100644
--- a/lisp/ses.el
+++ b/lisp/ses.el
@@ -837,7 +837,7 @@ updated again."
(defmacro ses--time-check (format &rest args)
"If `ses-start-time' is more than a second ago, call `message' with FORMAT
and ARGS and reset `ses-start-time' to the current time."
- `(when (> (- (float-time) ses-start-time) 1.0)
+ `(when (time-less-p 1 (time-since ses-start-time))
(message ,format ,@args)
(setq ses-start-time (float-time))))
@@ -858,7 +858,7 @@ cell (ROW,COL). This is undoable. The cell's data will be updated through
,(let ((field (progn (cl-assert (eq (car field) 'quote))
(cadr field))))
(if (eq field 'value)
- `(ses-set-with-undo (ses-cell-symbol cell) val)
+ '(ses-set-with-undo (ses-cell-symbol cell) val)
;; (let* ((slots (get 'ses-cell 'cl-struct-slots))
;; (slot (or (assq field slots)
;; (error "Unknown field %S" field)))
@@ -2495,7 +2495,7 @@ to are recalculated first."
prefix-length)
(when (and prefix (null (string= prefix "")))
(setq prefix-length (length prefix))
- (maphash (lambda (key val)
+ (maphash (lambda (key _val)
(let ((key-name (symbol-name key)))
(when (and (>= (length key-name) prefix-length)
(string= prefix (substring key-name 0 prefix-length)))
@@ -2648,7 +2648,7 @@ cells."
prefix-length)
(when prefix
(setq prefix-length (length prefix))
- (maphash (lambda (key val)
+ (maphash (lambda (key _val)
(let ((key-name (symbol-name key)))
(when (and (>= (length key-name) prefix-length)
(string= prefix (substring key-name 0 prefix-length)))
@@ -3956,17 +3956,17 @@ Use `math-format-value' as a printer for Calc objects."
(while rest
(let ((x (pop rest)))
(pcase x
- (`>v (setq transpose nil reorient-x nil reorient-y nil))
- (`>^ (setq transpose nil reorient-x nil reorient-y t))
- (`<^ (setq transpose nil reorient-x t reorient-y t))
- (`<v (setq transpose nil reorient-x t reorient-y nil))
- (`v> (setq transpose t reorient-x nil reorient-y t))
- (`^> (setq transpose t reorient-x nil reorient-y nil))
- (`^< (setq transpose t reorient-x t reorient-y nil))
- (`v< (setq transpose t reorient-x t reorient-y t))
- ((or `* `*2 `*1) (setq vectorize x))
- (`! (setq clean 'ses--clean-!))
- (`_ (setq clean `(lambda (&rest x)
+ ('>v (setq transpose nil reorient-x nil reorient-y nil))
+ ('>^ (setq transpose nil reorient-x nil reorient-y t))
+ ('<^ (setq transpose nil reorient-x t reorient-y t))
+ ('<v (setq transpose nil reorient-x t reorient-y nil))
+ ('v> (setq transpose t reorient-x nil reorient-y t))
+ ('^> (setq transpose t reorient-x nil reorient-y nil))
+ ('^< (setq transpose t reorient-x t reorient-y nil))
+ ('v< (setq transpose t reorient-x t reorient-y t))
+ ((or '* '*2 '*1) (setq vectorize x))
+ ('! (setq clean 'ses--clean-!))
+ ('_ (setq clean `(lambda (&rest x)
(ses--clean-_ x ,(if rest (pop rest) 0)))))
(_
(cond
@@ -4001,10 +4001,10 @@ Use `math-format-value' as a printer for Calc objects."
(cons clean (cons (quote 'vec) x)))
result)))))
(pcase vectorize
- (`nil (cons clean (apply #'append result)))
- (`*1 (vectorize-*1 clean result))
- (`*2 (vectorize-*2 clean result))
- (`* (funcall (if (cdr result)
+ ('nil (cons clean (apply #'append result)))
+ ('*1 (vectorize-*1 clean result))
+ ('*2 (vectorize-*2 clean result))
+ ('* (funcall (if (cdr result)
#'vectorize-*2
#'vectorize-*1)
clean result))))))
diff --git a/lisp/shadowfile.el b/lisp/shadowfile.el
index 729bcbb4f37..07e78506654 100644
--- a/lisp/shadowfile.el
+++ b/lisp/shadowfile.el
@@ -307,14 +307,7 @@ Replace HOST, and NAME when non-nil."
(if (null (tramp-file-name-method hup))
(format
"/%s:%s" (tramp-file-name-host hup) (tramp-file-name-localname hup))
- (tramp-make-tramp-file-name
- (tramp-file-name-method hup)
- (tramp-file-name-user hup)
- (tramp-file-name-domain hup)
- (tramp-file-name-host hup)
- (tramp-file-name-port hup)
- (tramp-file-name-localname hup)
- (tramp-file-name-hop hup)))))
+ (tramp-make-tramp-file-name hup))))
(defun shadow-replace-name-component (fullname newname)
"Return FULLNAME with the name component changed to NEWNAME."
diff --git a/lisp/shell.el b/lisp/shell.el
index 78227ca7351..53570272111 100644
--- a/lisp/shell.el
+++ b/lisp/shell.el
@@ -73,7 +73,7 @@
;; c-c c-o comint-delete-output Delete last batch of process output
;; c-c c-r comint-show-output Show last batch of process output
;; c-c c-l comint-dynamic-list-input-ring List input history
-;; send-invisible Read line w/o echo & send to proc
+;; comint-send-invisible Read line w/o echo & send to proc
;; comint-continue-subjob Useful if you accidentally suspend
;; top-level job
;; comint-mode-hook is the comint mode hook.
@@ -99,6 +99,7 @@
(require 'comint)
(require 'pcomplete)
+(eval-when-compile (require 'files-x)) ;with-connection-local-variables
;;; Customization and Buffer Variables
@@ -315,6 +316,8 @@ for Shell mode only."
"List of directories saved by pushd in this buffer's shell.
Thus, this does not include the shell's current directory.")
+(defvaralias 'shell-dirtrack-mode 'shell-dirtrackp)
+
(defvar shell-dirtrackp t
"Non-nil in a shell buffer means directory tracking is enabled.")
@@ -424,7 +427,7 @@ Thus, this does not include the shell's current directory.")
(while (looking-at
(eval-when-compile
(concat
- "\\(?:[^\s\t\n\\\"']+"
+ "\\(?:[^\s\t\n\\\"';]+"
"\\|'\\([^']*\\)'?"
"\\|\"\\(\\(?:[^\"\\]\\|\\\\.\\)*\\)\"?"
"\\|\\\\\\(\\(?:.\\|\n\\)?\\)\\)")))
@@ -466,6 +469,8 @@ Shell buffers. It implements `shell-completion-execonly' for
(set (make-local-variable 'comint-file-name-chars) shell-file-name-chars)
(set (make-local-variable 'comint-file-name-quote-list)
shell-file-name-quote-list)
+ (set (make-local-variable 'comint-file-name-prefix)
+ (or (file-remote-p default-directory) ""))
(set (make-local-variable 'comint-dynamic-complete-functions)
shell-dynamic-complete-functions)
(setq-local comint-unquote-function #'shell--unquote-argument)
@@ -486,7 +491,7 @@ Shell buffers. It implements `shell-completion-execonly' for
(setq-local comint-input-autoexpand shell-input-autoexpand)
;; Not needed in shell-mode because it's inherited from comint-mode, but
;; placed here for read-shell-command.
- (add-hook 'completion-at-point-functions 'comint-completion-at-point nil t))
+ (add-hook 'completion-at-point-functions #'comint-completion-at-point nil t))
(put 'shell-mode 'mode-class 'special)
@@ -496,7 +501,7 @@ Shell buffers. It implements `shell-completion-execonly' for
the end of process to the end of the current line.
\\[comint-send-input] before end of process output copies the current line minus the prompt to
the end of the buffer and sends it (\\[comint-copy-old-input] just copies the current line).
-\\[send-invisible] reads a line of text without echoing it, and sends it to
+\\[comint-send-invisible] reads a line of text without echoing it, and sends it to
the shell. This is useful for entering passwords. Or, add the function
`comint-watch-for-password-prompt' to `comint-output-filter-functions'.
@@ -568,8 +573,10 @@ buffer."
(setq list-buffers-directory (expand-file-name default-directory))
;; shell-dependent assignments.
(when (ring-empty-p comint-input-ring)
- (let ((shell (file-name-nondirectory (car
- (process-command (get-buffer-process (current-buffer))))))
+ (let ((shell (if (get-buffer-process (current-buffer))
+ (file-name-nondirectory
+ (car (process-command (get-buffer-process (current-buffer)))))
+ ""))
(hsize (getenv "HISTSIZE")))
(and (stringp hsize)
(integerp (setq hsize (string-to-number hsize)))
@@ -600,7 +607,7 @@ buffer."
;; Bypass a bug in certain versions of bash.
(when (string-equal shell "bash")
(add-hook 'comint-preoutput-filter-functions
- 'shell-filter-ctrl-a-ctrl-b nil t)))
+ #'shell-filter-ctrl-a-ctrl-b nil t)))
(comint-read-input-ring t)))
(defun shell-apply-ansi-color (beg end face)
@@ -714,43 +721,37 @@ Otherwise, one argument `-i' is passed to the shell.
(current-buffer)))
(with-current-buffer buffer
- (when (file-remote-p default-directory)
- ;; Apply connection-local variables.
- (hack-connection-local-variables-apply
- `(:application tramp
- :protocol ,(file-remote-p default-directory 'method)
- :user ,(file-remote-p default-directory 'user)
- :machine ,(file-remote-p default-directory 'host)))
-
- ;; On remote hosts, the local `shell-file-name' might be useless.
- (if (and (called-interactively-p 'any)
- (null explicit-shell-file-name)
- (null (getenv "ESHELL")))
- (set (make-local-variable 'explicit-shell-file-name)
- (file-local-name
- (expand-file-name
- (read-file-name
- "Remote shell path: " default-directory shell-file-name
- t shell-file-name)))))))
-
- ;; The buffer's window must be correctly set when we call comint
- ;; (so that comint sets the COLUMNS env var properly).
- (pop-to-buffer buffer)
- ;; Rain or shine, BUFFER must be current by now.
- (unless (comint-check-proc buffer)
- (let* ((prog (or explicit-shell-file-name
- (getenv "ESHELL") shell-file-name))
- (name (file-name-nondirectory prog))
- (startfile (concat "~/.emacs_" name))
- (xargs-name (intern-soft (concat "explicit-" name "-args"))))
- (unless (file-exists-p startfile)
- (setq startfile (concat user-emacs-directory "init_" name ".sh")))
- (apply 'make-comint-in-buffer "shell" buffer prog
- (if (file-exists-p startfile) startfile)
- (if (and xargs-name (boundp xargs-name))
- (symbol-value xargs-name)
- '("-i")))
- (shell-mode)))
+ (with-connection-local-variables
+ ;; On remote hosts, the local `shell-file-name' might be useless.
+ (when (file-remote-p default-directory)
+ (if (and (called-interactively-p 'any)
+ (null explicit-shell-file-name)
+ (null (getenv "ESHELL")))
+ (set (make-local-variable 'explicit-shell-file-name)
+ (file-local-name
+ (expand-file-name
+ (read-file-name
+ "Remote shell path: " default-directory shell-file-name
+ t shell-file-name))))))
+
+ ;; The buffer's window must be correctly set when we call comint
+ ;; (so that comint sets the COLUMNS env var properly).
+ (pop-to-buffer buffer)
+ ;; Rain or shine, BUFFER must be current by now.
+ (unless (comint-check-proc buffer)
+ (let* ((prog (or explicit-shell-file-name
+ (getenv "ESHELL") shell-file-name))
+ (name (file-name-nondirectory prog))
+ (startfile (concat "~/.emacs_" name))
+ (xargs-name (intern-soft (concat "explicit-" name "-args"))))
+ (unless (file-exists-p startfile)
+ (setq startfile (concat user-emacs-directory "init_" name ".sh")))
+ (apply #'make-comint-in-buffer "shell" buffer prog
+ (if (file-exists-p startfile) startfile)
+ (if (and xargs-name (boundp xargs-name))
+ (symbol-value xargs-name)
+ '("-i")))
+ (shell-mode)))))
buffer)
;;; Directory tracking
@@ -959,22 +960,18 @@ Environment variables are expanded, see function `substitute-in-file-name'."
(and (string-match "^\\+[1-9][0-9]*$" str)
(string-to-number str)))
-(defvaralias 'shell-dirtrack-mode 'shell-dirtrackp)
(define-minor-mode shell-dirtrack-mode
"Toggle directory tracking in this shell buffer (Shell Dirtrack mode).
-With a prefix argument ARG, enable Shell Dirtrack mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
The `dirtrack' package provides an alternative implementation of
this feature; see the function `dirtrack-mode'."
nil nil nil
(setq list-buffers-directory (if shell-dirtrack-mode default-directory))
(if shell-dirtrack-mode
- (add-hook 'comint-input-filter-functions 'shell-directory-tracker nil t)
- (remove-hook 'comint-input-filter-functions 'shell-directory-tracker t)))
+ (add-hook 'comint-input-filter-functions #'shell-directory-tracker nil t)
+ (remove-hook 'comint-input-filter-functions #'shell-directory-tracker t)))
-(define-obsolete-function-alias 'shell-dirtrack-toggle 'shell-dirtrack-mode
+(define-obsolete-function-alias 'shell-dirtrack-toggle #'shell-dirtrack-mode
"23.1")
(defun shell-cd (dir)
@@ -1167,9 +1164,12 @@ Returns t if successful."
(start (if (zerop (length filename)) (point) (match-beginning 0)))
(end (if (zerop (length filename)) (point) (match-end 0)))
(filenondir (file-name-nondirectory filename))
- ; why cdr? see `shell-dynamic-complete-command'
- (path-dirs (append (cdr (reverse exec-path))
- (if (memq system-type '(windows-nt ms-dos)) '("."))))
+ (path-dirs
+ ;; Ignore `exec-directory', the last entry in `exec-path'.
+ (append (cdr (reverse (exec-path)))
+ (if (and (memq system-type '(windows-nt ms-dos))
+ (not (file-remote-p default-directory)))
+ '("."))))
(cwd (file-name-as-directory (expand-file-name default-directory)))
(ignored-extensions
(and comint-completion-fignore
diff --git a/lisp/simple.el b/lisp/simple.el
index a0f2da7152c..37f92540dde 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -37,28 +37,6 @@
(defvar compilation-current-error)
(defvar compilation-context-lines)
-(defcustom shell-command-dont-erase-buffer nil
- "If non-nil, output buffer is not erased between shell commands.
-Also, a non-nil value sets the point in the output buffer
-once the command completes.
-The value `beg-last-out' sets point at the beginning of the output,
-`end-last-out' sets point at the end of the buffer, `save-point'
-restores the buffer position before the command."
- :type '(choice
- (const :tag "Erase buffer" nil)
- (const :tag "Set point to beginning of last output" beg-last-out)
- (const :tag "Set point to end of last output" end-last-out)
- (const :tag "Save point" save-point))
- :group 'shell
- :version "26.1")
-
-(defvar shell-command-saved-pos nil
- "Record of point positions in output buffers after command completion.
-The value is an alist whose elements are of the form (BUFFER . POS),
-where BUFFER is the output buffer, and POS is the point position
-in BUFFER once the command finishes.
-This variable is used when `shell-command-dont-erase-buffer' is non-nil.")
-
(defcustom idle-update-delay 0.5
"Idle time delay before updating various things on the screen.
Various Emacs features that update auxiliary information when point moves
@@ -132,6 +110,15 @@ If non-nil, the value is passed directly to `recenter'."
:type 'hook
:group 'next-error)
+(defcustom next-error-verbosity nil
+ "If nil, `next-error' always outputs the current error buffer.
+If non-nil, the message is output only when the error buffer
+changes."
+ :group 'next-error
+ :type 'boolean
+ :safe #'booleanp
+ :version "27.1")
+
(defvar next-error-highlight-timer nil)
(defvar next-error-overlay-arrow-position nil)
@@ -144,6 +131,14 @@ A buffer becomes most recent when its compilation, grep, or
similar mode is started, or when it is used with \\[next-error]
or \\[compile-goto-error].")
+(defvar next-error-buffer nil
+ "The buffer-local value of the most recent `next-error' buffer.")
+;; next-error-buffer is made buffer-local to keep the reference
+;; to the parent buffer used to navigate to the current buffer, so the
+;; next call of next-buffer will use the same parent buffer to
+;; continue navigation from it.
+(make-variable-buffer-local 'next-error-buffer)
+
(defvar next-error-function nil
"Function to use to find the next error in the current buffer.
The function is called with 2 parameters:
@@ -191,6 +186,47 @@ rejected, and the function returns nil."
(and extra-test-inclusive
(funcall extra-test-inclusive))))))
+(defcustom next-error-find-buffer-function #'ignore
+ "Function called to find a `next-error' capable buffer.
+This functions takes the same three arguments as the function
+`next-error-find-buffer', and should return the buffer to be
+used by the subsequent invocation of the command `next-error'
+and `previous-error'.
+If the function returns nil, `next-error-find-buffer' will
+try to use the buffer it used previously, and failing that
+all other buffers."
+ :type '(choice (const :tag "No default" ignore)
+ (const :tag "Single next-error capable buffer on selected frame"
+ next-error-buffer-on-selected-frame)
+ (function :tag "Other function"))
+ :group 'next-error
+ :version "27.1")
+
+(defcustom next-error-found-function #'ignore
+ "Function called when a next locus is found and displayed.
+Function is called with two arguments: a FROM-BUFFER buffer
+from which next-error navigated, and a target buffer TO-BUFFER."
+ :type '(choice (const :tag "No default" ignore)
+ (function :tag "Other function"))
+ :group 'next-error
+ :version "27.1")
+
+(defun next-error-buffer-on-selected-frame (&optional _avoid-current
+ extra-test-inclusive
+ extra-test-exclusive)
+ "Return a single visible next-error buffer on the selected frame."
+ (let ((window-buffers
+ (delete-dups
+ (delq nil (mapcar (lambda (w)
+ (if (next-error-buffer-p
+ (window-buffer w)
+ t
+ extra-test-inclusive extra-test-exclusive)
+ (window-buffer w)))
+ (window-list))))))
+ (if (eq (length window-buffers) 1)
+ (car window-buffers))))
+
(defun next-error-find-buffer (&optional avoid-current
extra-test-inclusive
extra-test-exclusive)
@@ -207,28 +243,28 @@ The function EXTRA-TEST-EXCLUSIVE, if non-nil, is called in each buffer
that would normally be considered usable. If it returns nil,
that buffer is rejected."
(or
- ;; 1. If one window on the selected frame displays such buffer, return it.
- (let ((window-buffers
- (delete-dups
- (delq nil (mapcar (lambda (w)
- (if (next-error-buffer-p
- (window-buffer w)
- avoid-current
- extra-test-inclusive extra-test-exclusive)
- (window-buffer w)))
- (window-list))))))
- (if (eq (length window-buffers) 1)
- (car window-buffers)))
- ;; 2. If next-error-last-buffer is an acceptable buffer, use that.
+ ;; 1. If a customizable function returns a buffer, use it.
+ (funcall next-error-find-buffer-function avoid-current
+ extra-test-inclusive
+ extra-test-exclusive)
+ ;; 2. If next-error-buffer has no buffer-local value
+ ;; (i.e. never navigated to the current buffer from another),
+ ;; and the current buffer is a `next-error' capable buffer,
+ ;; use it unconditionally, so next-error will always use it.
+ (if (and (not (local-variable-p 'next-error-buffer))
+ (next-error-buffer-p (current-buffer) avoid-current
+ extra-test-inclusive extra-test-exclusive))
+ (current-buffer))
+ ;; 3. If next-error-last-buffer is an acceptable buffer, use that.
(if (and next-error-last-buffer
(next-error-buffer-p next-error-last-buffer avoid-current
extra-test-inclusive extra-test-exclusive))
next-error-last-buffer)
- ;; 3. If the current buffer is acceptable, choose it.
+ ;; 4. If the current buffer is acceptable, choose it.
(if (next-error-buffer-p (current-buffer) avoid-current
extra-test-inclusive extra-test-exclusive)
(current-buffer))
- ;; 4. Look for any acceptable buffer.
+ ;; 5. Look for any acceptable buffer.
(let ((buffers (buffer-list)))
(while (and buffers
(not (next-error-buffer-p
@@ -236,7 +272,7 @@ that buffer is rejected."
extra-test-inclusive extra-test-exclusive)))
(setq buffers (cdr buffers)))
(car buffers))
- ;; 5. Use the current buffer as a last resort if it qualifies,
+ ;; 6. Use the current buffer as a last resort if it qualifies,
;; even despite AVOID-CURRENT.
(and avoid-current
(next-error-buffer-p (current-buffer) nil
@@ -244,7 +280,7 @@ that buffer is rejected."
(progn
(message "This is the only buffer with error message locations")
(current-buffer)))
- ;; 6. Give up.
+ ;; 7. Give up.
(error "No buffers contain error message locations")))
(defun next-error (&optional arg reset)
@@ -267,8 +303,9 @@ more generally, on any buffer in Compilation mode or with
Compilation Minor mode enabled, or any buffer in which
`next-error-function' is bound to an appropriate function.
To specify use of a particular buffer for error messages, type
-\\[next-error] in that buffer when it is the only one displayed
-in the current frame.
+\\[next-error] in that buffer. You can also use the command
+`next-error-select-buffer' to select the buffer to use for the subsequent
+invocation of `next-error'.
Once \\[next-error] has chosen the buffer for error messages, it
runs `next-error-hook' with `run-hooks', and stays with that buffer
@@ -279,23 +316,57 @@ To control which errors are matched, customize the variable
`compilation-error-regexp-alist'."
(interactive "P")
(if (consp arg) (setq reset t arg nil))
- (when (setq next-error-last-buffer (next-error-find-buffer))
- ;; we know here that next-error-function is a valid symbol we can funcall
- (with-current-buffer next-error-last-buffer
- (funcall next-error-function (prefix-numeric-value arg) reset)
- (when next-error-recenter
- (recenter next-error-recenter))
- (run-hooks 'next-error-hook))))
+ (let ((buffer (next-error-find-buffer)))
+ (when buffer
+ ;; We know here that next-error-function is a valid symbol we can funcall
+ (with-current-buffer buffer
+ (funcall next-error-function (prefix-numeric-value arg) reset)
+ (let ((prev next-error-last-buffer))
+ (next-error-found buffer (current-buffer))
+ (when (or (not next-error-verbosity)
+ (not (eq prev next-error-last-buffer)))
+ (message "%s locus from %s"
+ (cond (reset "First")
+ ((eq (prefix-numeric-value arg) 0) "Current")
+ ((< (prefix-numeric-value arg) 0) "Previous")
+ (t "Next"))
+ next-error-last-buffer)))))))
(defun next-error-internal ()
"Visit the source code corresponding to the `next-error' message at point."
- (setq next-error-last-buffer (current-buffer))
- ;; we know here that next-error-function is a valid symbol we can funcall
- (with-current-buffer next-error-last-buffer
+ (let ((buffer (current-buffer)))
+ ;; We know here that next-error-function is a valid symbol we can funcall
(funcall next-error-function 0 nil)
- (when next-error-recenter
- (recenter next-error-recenter))
- (run-hooks 'next-error-hook)))
+ (let ((prev next-error-last-buffer))
+ (next-error-found buffer (current-buffer))
+ (when (or (not next-error-verbosity)
+ (not (eq prev next-error-last-buffer)))
+ (message "Current locus from %s" next-error-last-buffer)))))
+
+(defun next-error-found (&optional from-buffer to-buffer)
+ "Function to call when the next locus is found and displayed.
+FROM-BUFFER is a buffer from which next-error navigated,
+and TO-BUFFER is a target buffer."
+ (setq next-error-last-buffer (or from-buffer (current-buffer)))
+ (when to-buffer
+ (with-current-buffer to-buffer
+ (setq next-error-buffer from-buffer)))
+ (when next-error-recenter
+ (recenter next-error-recenter))
+ (funcall next-error-found-function from-buffer to-buffer)
+ (run-hooks 'next-error-hook))
+
+(defun next-error-select-buffer (buffer)
+ "Select a `next-error' capable BUFFER and set it as the last used.
+This means that the selected buffer becomes the source of locations
+for the subsequent invocation of `next-error' or `previous-error'.
+Interactively, this command allows selection only among buffers
+where `next-error-function' is bound to an appropriate function."
+ (interactive
+ (list (get-buffer
+ (read-buffer "Select next-error buffer: " nil nil
+ (lambda (b) (next-error-buffer-p (cdr b)))))))
+ (setq next-error-last-buffer buffer))
(defalias 'goto-next-locus 'next-error)
(defalias 'next-match 'next-error)
@@ -306,7 +377,9 @@ To control which errors are matched, customize the variable
Prefix arg N says how many error messages to move backwards (or
forwards, if negative).
-This operates on the output from the \\[compile] and \\[grep] commands."
+This operates on the output from the \\[compile] and \\[grep] commands.
+
+See `next-error' for the details."
(interactive "p")
(next-error (- (or n 1))))
@@ -325,9 +398,11 @@ backwards, if negative).
Finds and highlights the source line like \\[next-error], but does not
select the source buffer."
(interactive "p")
- (let ((next-error-highlight next-error-highlight-no-select))
- (next-error n))
- (pop-to-buffer next-error-last-buffer))
+ (save-selected-window
+ (let ((next-error-highlight next-error-highlight-no-select)
+ (display-buffer-overriding-action
+ '(nil (inhibit-same-window . t))))
+ (next-error n))))
(defun previous-error-no-select (&optional n)
"Move point to the previous error in the `next-error' buffer and highlight match.
@@ -343,9 +418,7 @@ select the source buffer."
(define-minor-mode next-error-follow-minor-mode
"Minor mode for compilation, occur and diff modes.
-With a prefix argument ARG, enable mode if ARG is positive, and
-disable it otherwise. If called from Lisp, enable mode if ARG is
-omitted or nil.
+
When turned on, cursor motion in the compilation, grep, occur or diff
buffer causes automatic display of the corresponding source code location."
:group 'next-error :init-value nil :lighter " Fol"
@@ -535,25 +608,43 @@ When called from Lisp code, ARG may be a prefix string to copy."
(indent-to col 0)
(goto-char pos)))
-(defun delete-indentation (&optional arg)
+(defun delete-indentation (&optional arg beg end)
"Join this line to previous and fix up whitespace at join.
-If there is a fill prefix, delete it from the beginning of this line.
-With argument, join this line to following line."
- (interactive "*P")
- (beginning-of-line)
- (if arg (forward-line 1))
- (if (eq (preceding-char) ?\n)
- (progn
- (delete-region (point) (1- (point)))
- ;; If the second line started with the fill prefix,
- ;; delete the prefix.
- (if (and fill-prefix
- (<= (+ (point) (length fill-prefix)) (point-max))
- (string= fill-prefix
- (buffer-substring (point)
- (+ (point) (length fill-prefix)))))
- (delete-region (point) (+ (point) (length fill-prefix))))
- (fixup-whitespace))))
+If there is a fill prefix, delete it from the beginning of this
+line.
+With prefix ARG, join the current line to the following line.
+When BEG and END are non-nil, join all lines in the region they
+define. Interactively, BEG and END are, respectively, the start
+and end of the region if it is active, else nil. (The region is
+ignored if prefix ARG is given.)"
+ (interactive
+ (progn (barf-if-buffer-read-only)
+ (cons current-prefix-arg
+ (and (use-region-p)
+ (list (region-beginning) (region-end))))))
+ ;; Consistently deactivate mark even when no text is changed.
+ (setq deactivate-mark t)
+ (if (and beg (not arg))
+ ;; Region is active. Go to END, but only if region spans
+ ;; multiple lines.
+ (and (goto-char beg)
+ (> end (line-end-position))
+ (goto-char end))
+ ;; Region is inactive. Set a loop sentinel
+ ;; (subtracting 1 in order to compare less than BOB).
+ (setq beg (1- (line-beginning-position (and arg 2))))
+ (when arg (forward-line)))
+ (let ((prefix (and (> (length fill-prefix) 0)
+ (regexp-quote fill-prefix))))
+ (while (and (> (line-beginning-position) beg)
+ (forward-line 0)
+ (= (preceding-char) ?\n))
+ (delete-char -1)
+ ;; If the appended line started with the fill prefix,
+ ;; delete the prefix.
+ (if (and prefix (looking-at prefix))
+ (replace-match "" t t))
+ (fixup-whitespace))))
(defalias 'join-line #'delete-indentation) ; easier to find
@@ -1106,6 +1197,7 @@ the actual saved text might be different from what was killed."
(defun mark-whole-buffer ()
"Put point at beginning and mark at end of buffer.
+Also push mark at point before pushing mark at end of buffer.
If narrowing is in effect, only uses the accessible part of the buffer.
You probably should not use this function in Lisp programs;
it is usually a mistake for a Lisp function to use any subroutine
@@ -1356,7 +1448,7 @@ in *Help* buffer. See also the command `describe-char'."
(if (or (not coding)
(eq (coding-system-type coding) t))
(setq coding (default-value 'buffer-file-coding-system)))
- (if (and (>= char #x3fff80) (<= char #x3fffff))
+ (if (eq (char-charset char) 'eight-bit)
(setq encoding-msg
(format "(%d, #o%o, #x%x, raw-byte)" char char char))
;; Check if the character is displayed with some `display'
@@ -1554,7 +1646,7 @@ this command arranges for all errors to enter the debugger."
(eval-expression-get-print-arguments current-prefix-arg)))
(if (null eval-expression-debug-on-error)
- (push (eval exp lexical-binding) values)
+ (push (eval (macroexpand-all exp) lexical-binding) values)
(let ((old-value (make-symbol "t")) new-value)
;; Bind debug-on-error to something unique so that we can
;; detect when evalled code changes it.
@@ -1591,13 +1683,10 @@ the minibuffer, then read and evaluate the result."
'command-history)
;; If command was added to command-history as a string,
;; get rid of that. We want only evaluable expressions there.
- (if (stringp (car command-history))
- (setq command-history (cdr command-history)))))))
+ (when (stringp (car command-history))
+ (pop command-history))))))
- ;; If command to be redone does not match front of history,
- ;; add it to the history.
- (or (equal command (car command-history))
- (setq command-history (cons command command-history)))
+ (add-to-history 'command-history command)
(eval command)))
(defun repeat-complex-command (arg)
@@ -1627,13 +1716,10 @@ to get different commands to edit and resubmit."
;; If command was added to command-history as a
;; string, get rid of that. We want only
;; evaluable expressions there.
- (if (stringp (car command-history))
- (setq command-history (cdr command-history))))))
+ (when (stringp (car command-history))
+ (pop command-history)))))
- ;; If command to be redone does not match front of history,
- ;; add it to the history.
- (or (equal newcmd (car command-history))
- (setq command-history (cons newcmd command-history)))
+ (add-to-history 'command-history newcmd)
(apply #'funcall-interactively
(car newcmd)
(mapcar (lambda (e) (eval e t)) (cdr newcmd))))
@@ -1786,9 +1872,11 @@ invoking, give a prefix argument to `execute-extended-command'."
;; If this command displayed something in the echo area;
;; wait a few seconds, then display our suggestion message.
;; FIXME: Wait *after* running post-command-hook!
- ;; FIXME: Don't wait if execute-extended-command--shorter won't
- ;; find a better answer anyway!
- (when suggest-key-bindings
+ ;; FIXME: If execute-extended-command--shorter were
+ ;; faster, we could compute the result here first too.
+ (when (and suggest-key-bindings
+ (or binding
+ (and extended-command-suggest-shorter typed)))
(sit-for (cond
((zerop (length (current-message))) 0)
((numberp suggest-key-bindings) suggest-key-bindings)
@@ -1850,11 +1938,8 @@ a special event, so ignore the prefix argument and don't clear it."
;; If requested, place the macro in the command history. For
;; other sorts of commands, call-interactively takes care of this.
(when record-flag
- (push `(execute-kbd-macro ,final ,prefixarg) command-history)
- ;; Don't keep command history around forever.
- (when (and (numberp history-length) (> history-length 0))
- (let ((cell (nthcdr history-length command-history)))
- (if (consp cell) (setcdr cell nil)))))
+ (add-to-history
+ 'command-history `(execute-kbd-macro ,final ,prefixarg) nil t))
(execute-kbd-macro final prefixarg))
(t
;; Pass `cmd' rather than `final', for the backtrace's sake.
@@ -2958,7 +3043,7 @@ that calls `undo-auto-amalgamate'."
(defun undo-auto--ensure-boundary (cause)
"Add an `undo-boundary' to the current buffer if needed.
REASON describes the reason that the boundary is being added; see
-`undo-auto--last-boundary' for more information."
+`undo-auto--last-boundary-cause' for more information."
(when (and
(undo-auto--needs-boundary-p))
(let ((last-amalgamating
@@ -3007,10 +3092,10 @@ default values.")
"Add an `undo-boundary' in appropriate buffers."
(undo-auto--boundaries
(let ((amal undo-auto--this-command-amalgamating))
- (setq undo-auto--this-command-amalgamating nil)
- (if amal
- 'amalgamate
- 'command))))
+ (setq undo-auto--this-command-amalgamating nil)
+ (if amal
+ 'amalgamate
+ 'command))))
(defun undo-auto-amalgamate ()
"Amalgamate undo if necessary.
@@ -3023,30 +3108,38 @@ behavior."
(let ((last-amalgamating-count
(undo-auto--last-boundary-amalgamating-number)))
(setq undo-auto--this-command-amalgamating t)
- (when
- last-amalgamating-count
- (if
- (and
- (< last-amalgamating-count 20)
- (eq this-command last-command))
+ (when last-amalgamating-count
+ (if (and (< last-amalgamating-count 20)
+ (eq this-command last-command))
;; Amalgamate all buffers that have changed.
+ ;; This may be needed for example if some *-change-functions
+ ;; reflected these changes in some other buffer.
(dolist (b (cdr undo-auto--last-boundary-cause))
(when (buffer-live-p b)
(with-current-buffer
b
- (when
- ;; The head of `buffer-undo-list' is nil.
- ;; `car-safe' doesn't work because
- ;; `buffer-undo-list' need not be a list!
- (and (listp buffer-undo-list)
- (not (car buffer-undo-list)))
+ (when (and (consp buffer-undo-list)
+ ;; `car-safe' doesn't work because
+ ;; `buffer-undo-list' need not be a list!
+ (null (car buffer-undo-list)))
+ ;; The head of `buffer-undo-list' is nil.
(setq buffer-undo-list
(cdr buffer-undo-list))))))
(setq undo-auto--last-boundary-cause 0)))))
(defun undo-auto--undoable-change ()
"Called after every undoable buffer change."
- (add-to-list 'undo-auto--undoably-changed-buffers (current-buffer))
+ (unless (memq (current-buffer) undo-auto--undoably-changed-buffers)
+ (let ((bufs undo-auto--undoably-changed-buffers))
+ ;; Drop dead buffers from the list, to avoid memory leak in
+ ;; (while t (with-temp-buffer (setq buffer-undo-list nil) (insert "a")))
+ (while bufs
+ (let ((next (cdr bufs)))
+ (if (or (buffer-live-p (car bufs)) (null next))
+ (setq bufs next)
+ (setcar bufs (car next))
+ (setcdr bufs (cdr next))))))
+ (push (current-buffer) undo-auto--undoably-changed-buffers))
(undo-auto--boundary-ensure-timer))
;; End auto-boundary section
@@ -3159,61 +3252,6 @@ which is defined in the `warnings' library.\n")
(setq buffer-undo-list nil)
t))
-(defcustom password-word-equivalents
- '("password" "passcode" "passphrase" "pass phrase"
- ; These are sorted according to the GNU en_US locale.
- "암호" ; ko
- "パスワード" ; ja
- "ପ୍ରବେଶ ସଙ୍କେତ" ; or
- "ពាក្យសម្ងាត់" ; km
- "adgangskode" ; da
- "contraseña" ; es
- "contrasenya" ; ca
- "geslo" ; sl
- "hasło" ; pl
- "heslo" ; cs, sk
- "iphasiwedi" ; zu
- "jelszó" ; hu
- "lösenord" ; sv
- "lozinka" ; hr, sr
- "mật khẩu" ; vi
- "mot de passe" ; fr
- "parola" ; tr
- "pasahitza" ; eu
- "passord" ; nb
- "passwort" ; de
- "pasvorto" ; eo
- "salasana" ; fi
- "senha" ; pt
- "slaptažodis" ; lt
- "wachtwoord" ; nl
- "كلمة السر" ; ar
- "ססמה" ; he
- "лозинка" ; sr
- "пароль" ; kk, ru, uk
- "गुप्तशब्द" ; mr
- "शब्दकूट" ; hi
- "પાસવર્ડ" ; gu
- "సంకేతపదము" ; te
- "ਪਾਸਵਰਡ" ; pa
- "ಗುಪ್ತಪದ" ; kn
- "கடவுச்சொல்" ; ta
- "അടയാളവാക്ക്" ; ml
- "গুপ্তশব্দ" ; as
- "পাসওয়ার্ড" ; bn_IN
- "රහස්පදය" ; si
- "密码" ; zh_CN
- "密碼" ; zh_TW
- )
- "List of words equivalent to \"password\".
-This is used by Shell mode and other parts of Emacs to recognize
-password prompts, including prompts in languages other than
-English. Different case choices should not be assumed to be
-included; callers should bind `case-fold-search' to t."
- :type '(repeat string)
- :version "24.4"
- :group 'processes)
-
(defvar shell-command-history nil
"History list for some commands that read shell commands.
@@ -3313,6 +3351,28 @@ is output."
:group 'shell
:version "26.1")
+(defcustom shell-command-dont-erase-buffer nil
+ "If non-nil, output buffer is not erased between shell commands.
+Also, a non-nil value sets the point in the output buffer
+once the command completes.
+The value `beg-last-out' sets point at the beginning of the output,
+`end-last-out' sets point at the end of the buffer, `save-point'
+restores the buffer position before the command."
+ :type '(choice
+ (const :tag "Erase buffer" nil)
+ (const :tag "Set point to beginning of last output" beg-last-out)
+ (const :tag "Set point to end of last output" end-last-out)
+ (const :tag "Save point" save-point))
+ :group 'shell
+ :version "26.1")
+
+(defvar shell-command-saved-pos nil
+ "Record of point positions in output buffers after command completion.
+The value is an alist whose elements are of the form (BUFFER . POS),
+where BUFFER is the output buffer, and POS is the point position
+in BUFFER once the command finishes.
+This variable is used when `shell-command-dont-erase-buffer' is non-nil.")
+
(defun shell-command--save-pos-or-erase ()
"Store a buffer position or erase the buffer.
See `shell-command-dont-erase-buffer'."
@@ -3393,6 +3453,8 @@ a shell (with its need to quote arguments)."
(setq command (concat command " &")))
(shell-command command output-buffer error-buffer))
+(declare-function comint-output-filter "comint" (process string))
+
(defun shell-command (command &optional output-buffer error-buffer)
"Execute string COMMAND in inferior shell; display output, if any.
With prefix argument, insert the COMMAND's output at point.
@@ -3470,12 +3532,11 @@ impose the use of a shell (with its need to quote arguments)."
(not (or (bufferp output-buffer) (stringp output-buffer))))
;; Output goes in current buffer.
(let ((error-file
- (if error-buffer
- (make-temp-file
- (expand-file-name "scor"
- (or small-temporary-file-directory
- temporary-file-directory)))
- nil)))
+ (and error-buffer
+ (make-temp-file
+ (expand-file-name "scor"
+ (or small-temporary-file-directory
+ temporary-file-directory))))))
(barf-if-buffer-read-only)
(push-mark nil t)
;; We do not use -f for csh; we will not support broken use of
@@ -3483,24 +3544,22 @@ impose the use of a shell (with its need to quote arguments)."
;; "if ($?prompt) exit" before things which are not useful
;; non-interactively. Besides, if someone wants their other
;; aliases for shell commands then they can still have them.
- (call-process shell-file-name nil
- (if error-file
- (list t error-file)
- t)
- nil shell-command-switch command)
+ (call-process-shell-command command nil (if error-file
+ (list t error-file)
+ t))
(when (and error-file (file-exists-p error-file))
- (if (< 0 (nth 7 (file-attributes error-file)))
- (with-current-buffer (get-buffer-create error-buffer)
- (let ((pos-from-end (- (point-max) (point))))
- (or (bobp)
- (insert "\f\n"))
- ;; Do no formatting while reading error file,
- ;; because that can run a shell command, and we
- ;; don't want that to cause an infinite recursion.
- (format-insert-file error-file nil)
- ;; Put point after the inserted errors.
- (goto-char (- (point-max) pos-from-end)))
- (display-buffer (current-buffer))))
+ (when (< 0 (file-attribute-size (file-attributes error-file)))
+ (with-current-buffer (get-buffer-create error-buffer)
+ (let ((pos-from-end (- (point-max) (point))))
+ (or (bobp)
+ (insert "\f\n"))
+ ;; Do no formatting while reading error file,
+ ;; because that can run a shell command, and we
+ ;; don't want that to cause an infinite recursion.
+ (format-insert-file error-file nil)
+ ;; Put point after the inserted errors.
+ (goto-char (- (point-max) pos-from-end)))
+ (display-buffer (current-buffer))))
(delete-file error-file))
;; This is like exchange-point-and-mark, but doesn't
;; activate the mark. It is cleaner to avoid activation,
@@ -3519,12 +3578,11 @@ impose the use of a shell (with its need to quote arguments)."
(let* ((buffer (get-buffer-create
(or output-buffer "*Async Shell Command*")))
(bname (buffer-name buffer))
- (directory default-directory)
- proc)
+ (proc (get-buffer-process buffer))
+ (directory default-directory))
;; Remove the ampersand.
(setq command (substring command 0 (match-beginning 0)))
;; Ask the user what to do with already running process.
- (setq proc (get-buffer-process buffer))
(when proc
(cond
((eq async-shell-command-buffer 'confirm-kill-process)
@@ -3556,14 +3614,14 @@ impose the use of a shell (with its need to quote arguments)."
(with-current-buffer buffer
(shell-command--save-pos-or-erase)
(setq default-directory directory)
- (setq proc (start-process "Shell" buffer shell-file-name
- shell-command-switch command))
+ (setq proc
+ (start-process-shell-command "Shell" buffer command))
(setq mode-line-process '(":%s"))
(require 'shell) (shell-mode)
- (set-process-sentinel proc 'shell-command-sentinel)
+ (set-process-sentinel proc #'shell-command-sentinel)
;; Use the comint filter for proper handling of
;; carriage motion (see comint-inhibit-carriage-motion).
- (set-process-filter proc 'comint-output-filter)
+ (set-process-filter proc #'comint-output-filter)
(if async-shell-command-display-buffer
;; Display buffer immediately.
(display-buffer buffer '(nil (allow-no-window . t)))
@@ -3819,7 +3877,8 @@ interactively, this is t."
;; No output; error?
(let ((output
(if (and error-file
- (< 0 (nth 7 (file-attributes error-file))))
+ (< 0 (file-attribute-size
+ (file-attributes error-file))))
(format "some error output%s"
(if shell-command-default-error-buffer
(format " to the \"%s\" buffer"
@@ -3842,7 +3901,7 @@ interactively, this is t."
)))))
(when (and error-file (file-exists-p error-file))
- (if (< 0 (nth 7 (file-attributes error-file)))
+ (if (< 0 (file-attribute-size (file-attributes error-file)))
(with-current-buffer (get-buffer-create error-buffer)
(let ((pos-from-end (- (point-max) (point))))
(or (bobp)
@@ -3863,11 +3922,11 @@ interactively, this is t."
(with-output-to-string
(with-current-buffer
standard-output
- (process-file shell-file-name nil t nil shell-command-switch command))))
+ (shell-command command t))))
(defun process-file (program &optional infile buffer display &rest args)
"Process files synchronously in a separate process that runs PROGRAM.
-Similar to `call-process', but may invoke a file handler based on
+Similar to `call-process', but may invoke a file name handler based on
`default-directory'. The current working directory of the
subprocess is `default-directory'.
@@ -3877,10 +3936,10 @@ by `file-local-name' before passing it to this function.
File names in INFILE and BUFFER are handled normally, but file
names in ARGS should be relative to `default-directory', as they
are passed to the process verbatim. (This is a difference to
-`call-process' which does not support file handlers for INFILE
+`call-process' which does not support file name handlers for INFILE
and BUFFER.)
-Some file handlers might not support all variants, for example
+Some file name handlers might not support all variants, for example
they might behave as if DISPLAY was nil, regardless of the actual
value passed."
(let ((fh (find-file-name-handler default-directory 'process-file))
@@ -3904,7 +3963,7 @@ value passed."
By default, this variable is always set to t, meaning that a
call of `process-file' could potentially change any file on a
-remote host. When set to nil, a file handler could optimize
+remote host. When set to nil, a file name handler could optimize
its behavior with respect to remote file attribute caching.
You should only ever change this variable with a let-binding;
@@ -3913,7 +3972,7 @@ never with `setq'.")
(defun start-file-process (name buffer program &rest program-args)
"Start a program in a subprocess. Return the process object for it.
-Similar to `start-process', but may invoke a file handler based on
+Similar to `start-process', but may invoke a file name handler based on
`default-directory'. See Info node `(elisp)Magic File Names'.
This handler ought to run PROGRAM, perhaps on the local host,
@@ -3923,10 +3982,10 @@ produced from it by `file-local-name', becomes the working directory
of the process on the remote host.
PROGRAM and PROGRAM-ARGS might be file names. They are not
-objects of file handler invocation, so they need to be obtained
+objects of file name handler invocation, so they need to be obtained
by calling `file-local-name', in case they are remote file names.
-File handlers might not support pty association, if PROGRAM is nil."
+File name handlers might not support pty association, if PROGRAM is nil."
(let ((fh (find-file-name-handler default-directory 'start-file-process)))
(if fh (apply fh 'start-file-process name buffer program program-args)
(apply 'start-process name buffer program program-args))))
@@ -3952,8 +4011,11 @@ File handlers might not support pty association, if PROGRAM is nil."
(setq tabulated-list-format [("Process" 15 t)
("PID" 7 t)
("Status" 7 t)
- ("Buffer" 15 t)
+ ;; 25 is the length of the long standard buffer
+ ;; name "*Async Shell Command*<10>" (bug#30016)
+ ("Buffer" 25 t)
("TTY" 12 t)
+ ("Thread" 12 t)
("Command" 0 t)])
(make-local-variable 'process-menu-query-only)
(setq tabulated-list-sort-key (cons "Process" nil))
@@ -3995,6 +4057,13 @@ Also, delete any process that is exited or signaled."
action process-menu-visit-buffer)
"--"))
(tty (or (process-tty-name p) "--"))
+ (thread
+ (cond
+ ((or
+ (null (process-thread p))
+ (not (fboundp 'thread-name))) "--")
+ ((eq (process-thread p) main-thread) "Main")
+ ((thread-name (process-thread p)))))
(cmd
(if (memq type '(network serial))
(let ((contact (process-contact p t)))
@@ -4017,7 +4086,7 @@ Also, delete any process that is exited or signaled."
(format " at %s b/s" speed)
"")))))
(mapconcat 'identity (process-command p) " "))))
- (push (list p (vector name pid status buf-label tty cmd))
+ (push (list p (vector name pid status buf-label tty thread cmd))
tabulated-list-entries)))))
(tabulated-list-init-header))
@@ -4104,7 +4173,7 @@ Runs `prefix-command-preserve-state-hook'."
(when prefix-arg
(concat "C-u"
(pcase prefix-arg
- (`(-) " -")
+ ('(-) " -")
(`(,(and (pred integerp) n))
(let ((str ""))
(while (and (> n 4) (= (mod n 4) 0))
@@ -4386,7 +4455,8 @@ argument should still be a \"useful\" string for such uses."
(funcall interprogram-paste-function))))
(when interprogram-paste
(dolist (s (if (listp interprogram-paste)
- (nreverse interprogram-paste)
+ ;; Use `reverse' to avoid modifying external data.
+ (reverse interprogram-paste)
(list interprogram-paste)))
(unless (and kill-do-not-save-duplicates
(equal-including-properties s (car kill-ring)))
@@ -4395,9 +4465,8 @@ argument should still be a \"useful\" string for such uses."
(equal-including-properties string (car kill-ring)))
(if (and replace kill-ring)
(setcar kill-ring string)
- (push string kill-ring)
- (if (> (length kill-ring) kill-ring-max)
- (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil))))
+ (let ((history-delete-duplicates nil))
+ (add-to-history 'kill-ring string kill-ring-max t))))
(setq kill-ring-yank-pointer kill-ring)
(if interprogram-cut-function
(funcall interprogram-cut-function string)))
@@ -4420,20 +4489,20 @@ If `interprogram-cut-function' is non-nil, call it with the
resulting kill.
If `kill-append-merge-undo' is non-nil, remove the last undo
boundary in the current buffer."
- (let* ((cur (car kill-ring)))
+ (let ((cur (car kill-ring)))
(kill-new (if before-p (concat string cur) (concat cur string))
- (or (= (length cur) 0)
- (equal nil (get-text-property 0 'yank-handler cur))))
- (when (and kill-append-merge-undo (not buffer-read-only))
- (let ((prev buffer-undo-list)
- (next (cdr buffer-undo-list)))
- ;; find the next undo boundary
- (while (car next)
- (pop next)
- (pop prev))
- ;; remove this undo boundary
- (when prev
- (setcdr prev (cdr next)))))))
+ (or (string= cur "")
+ (null (get-text-property 0 'yank-handler cur)))))
+ (when (and kill-append-merge-undo (not buffer-read-only))
+ (let ((prev buffer-undo-list)
+ (next (cdr buffer-undo-list)))
+ ;; Find the next undo boundary.
+ (while (car next)
+ (pop next)
+ (pop prev))
+ ;; Remove this undo boundary.
+ (when prev
+ (setcdr prev (cdr next))))))
(defcustom yank-pop-change-selection nil
"Whether rotating the kill ring changes the window system selection.
@@ -4467,9 +4536,13 @@ move the yanking point; just return the Nth kill forward."
;; Disable the interprogram cut function when we add the new
;; text to the kill ring, so Emacs doesn't try to own the
;; selection, with identical text.
- (let ((interprogram-cut-function nil))
+ ;; Also disable the interprogram paste function, so that
+ ;; `kill-new' doesn't call it repeatedly.
+ (let ((interprogram-cut-function nil)
+ (interprogram-paste-function nil))
(if (listp interprogram-paste)
- (mapc 'kill-new (nreverse interprogram-paste))
+ ;; Use `reverse' to avoid modifying external data.
+ (mapc #'kill-new (reverse interprogram-paste))
(kill-new interprogram-paste)))
(car kill-ring))
(or kill-ring (error "Kill ring is empty"))
@@ -5708,22 +5781,23 @@ Novice Emacs Lisp programmers often try to use the mark for the wrong
purposes. See the documentation of `set-mark' for more information.
In Transient Mark mode, activate mark if optional third arg ACTIVATE non-nil."
- (unless (null (mark t))
- (setq mark-ring (cons (copy-marker (mark-marker)) mark-ring))
- (when (> (length mark-ring) mark-ring-max)
- (move-marker (car (nthcdr mark-ring-max mark-ring)) nil)
- (setcdr (nthcdr (1- mark-ring-max) mark-ring) nil)))
+ (when (mark t)
+ (let ((old (nth mark-ring-max mark-ring))
+ (history-delete-duplicates nil))
+ (add-to-history 'mark-ring (copy-marker (mark-marker)) mark-ring-max t)
+ (when old
+ (set-marker old nil))))
(set-marker (mark-marker) (or location (point)) (current-buffer))
- ;; Now push the mark on the global mark ring.
- (if (and global-mark-ring
- (eq (marker-buffer (car global-mark-ring)) (current-buffer)))
- ;; The last global mark pushed was in this same buffer.
- ;; Don't push another one.
- nil
- (setq global-mark-ring (cons (copy-marker (mark-marker)) global-mark-ring))
- (when (> (length global-mark-ring) global-mark-ring-max)
- (move-marker (car (nthcdr global-mark-ring-max global-mark-ring)) nil)
- (setcdr (nthcdr (1- global-mark-ring-max) global-mark-ring) nil)))
+ ;; Don't push the mark on the global mark ring if the last global
+ ;; mark pushed was in this same buffer.
+ (unless (and global-mark-ring
+ (eq (marker-buffer (car global-mark-ring)) (current-buffer)))
+ (let ((old (nth global-mark-ring-max global-mark-ring))
+ (history-delete-duplicates nil))
+ (add-to-history
+ 'global-mark-ring (copy-marker (mark-marker)) global-mark-ring-max t)
+ (when old
+ (set-marker old nil))))
(or nomsg executing-kbd-macro (> (minibuffer-depth) 0)
(message "Mark set"))
(if (or activate (not transient-mark-mode))
@@ -5735,10 +5809,10 @@ In Transient Mark mode, activate mark if optional third arg ACTIVATE non-nil."
Does not set point. Does nothing if mark ring is empty."
(when mark-ring
(setq mark-ring (nconc mark-ring (list (copy-marker (mark-marker)))))
- (set-marker (mark-marker) (+ 0 (car mark-ring)) (current-buffer))
- (move-marker (car mark-ring) nil)
- (if (null (mark t)) (ding))
- (setq mark-ring (cdr mark-ring)))
+ (set-marker (mark-marker) (car mark-ring))
+ (set-marker (car mark-ring) nil)
+ (unless (mark t) (ding))
+ (pop mark-ring))
(deactivate-mark))
(define-obsolete-function-alias
@@ -5812,9 +5886,6 @@ its earlier value."
(define-minor-mode transient-mark-mode
"Toggle Transient Mark mode.
-With a prefix argument ARG, enable Transient Mark mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-Transient Mark mode if ARG is omitted or nil.
Transient Mark mode is a global minor mode. When enabled, the
region is highlighted with the `region' face whenever the mark
@@ -6849,12 +6920,6 @@ other purposes."
(define-minor-mode visual-line-mode
"Toggle visual line based editing (Visual Line mode) in the current buffer.
-Interactively, with a prefix argument, enable
-Visual Line mode if the prefix argument is positive,
-and disable it otherwise. If called from Lisp, toggle
-the mode if ARG is `toggle', disable the mode if ARG is
-a non-positive integer, and enable the mode otherwise
-\(including if ARG is omitted or nil or a positive integer).
When Visual Line mode is enabled, `word-wrap' is turned on in
this buffer, and simple editing commands are redefined to act on
@@ -7285,12 +7350,6 @@ Some major modes set this.")
(define-minor-mode auto-fill-mode
"Toggle automatic line breaking (Auto Fill mode).
-Interactively, with a prefix argument, enable
-Auto Fill mode if the prefix argument is positive,
-and disable it otherwise. If called from Lisp, toggle
-the mode if ARG is `toggle', disable the mode if ARG is
-a non-positive integer, and enable the mode otherwise
-\(including if ARG is omitted or nil or a positive integer).
When Auto Fill mode is enabled, inserting a space at a column
beyond `current-fill-column' automatically breaks the line at a
@@ -7405,9 +7464,6 @@ if long lines are truncated."
(define-minor-mode overwrite-mode
"Toggle Overwrite mode.
-With a prefix argument ARG, enable Overwrite mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
When Overwrite mode is enabled, printing characters typed in
replace existing text on a one-for-one basis, rather than pushing
@@ -7421,9 +7477,6 @@ characters when necessary."
(define-minor-mode binary-overwrite-mode
"Toggle Binary Overwrite mode.
-With a prefix argument ARG, enable Binary Overwrite mode if ARG
-is positive, and disable it otherwise. If called from Lisp,
-enable the mode if ARG is omitted or nil.
When Binary Overwrite mode is enabled, printing characters typed
in replace existing text. Newlines are not treated specially, so
@@ -7441,9 +7494,6 @@ a specialization of overwrite mode, entered by setting the
(define-minor-mode line-number-mode
"Toggle line number display in the mode line (Line Number mode).
-With a prefix argument ARG, enable Line Number mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Line numbers do not appear for very large buffers and buffers
with very long lines; see variables `line-number-display-limit'
@@ -7451,27 +7501,15 @@ and `line-number-display-limit-width'."
:init-value t :global t :group 'mode-line)
(define-minor-mode column-number-mode
- "Toggle column number display in the mode line (Column Number mode).
-With a prefix argument ARG, enable Column Number mode if ARG is
-positive, and disable it otherwise.
-
-If called from Lisp, enable the mode if ARG is omitted or nil."
+ "Toggle column number display in the mode line (Column Number mode)."
:global t :group 'mode-line)
(define-minor-mode size-indication-mode
- "Toggle buffer size display in the mode line (Size Indication mode).
-With a prefix argument ARG, enable Size Indication mode if ARG is
-positive, and disable it otherwise.
-
-If called from Lisp, enable the mode if ARG is omitted or nil."
+ "Toggle buffer size display in the mode line (Size Indication mode)."
:global t :group 'mode-line)
(define-minor-mode auto-save-mode
- "Toggle auto-saving in the current buffer (Auto Save mode).
-With a prefix argument ARG, enable Auto Save mode if ARG is
-positive, and disable it otherwise.
-
-If called from Lisp, enable the mode if ARG is omitted or nil."
+ "Toggle auto-saving in the current buffer (Auto Save mode)."
:variable ((and buffer-auto-save-file-name
;; If auto-save is off because buffer has shrunk,
;; then toggling should turn it on.
@@ -7884,7 +7922,7 @@ buffer buried."
(eq mail-user-agent 'message-user-agent)
(let (warn-vars)
(dolist (var '(mail-mode-hook mail-send-hook mail-setup-hook
- mail-yank-hooks mail-archive-file-name
+ mail-citation-hook mail-archive-file-name
mail-default-reply-to mail-mailing-lists
mail-self-blind))
(and (boundp var)
@@ -7902,6 +7940,8 @@ To disable this warning, set `compose-mail-user-agent-warnings' to nil."
warn-vars " "))))))
(let ((function (get mail-user-agent 'composefunc)))
+ (unless function
+ (error "Invalid value for `mail-user-agent'"))
(funcall function to subject other-headers continue switch-function
yank-action send-actions return-action)))
@@ -8380,20 +8420,18 @@ LSHIFTBY is the numeric value of this modifier, in keyboard events.
PREFIX is the string that represents this modifier in an event type symbol."
(if (numberp event)
(cond ((eq symbol 'control)
- (if (and (<= (downcase event) ?z)
- (>= (downcase event) ?a))
- (- (downcase event) ?a -1)
- (if (and (<= (downcase event) ?Z)
- (>= (downcase event) ?A))
- (- (downcase event) ?A -1)
- (logior (lsh 1 lshiftby) event))))
+ (if (<= 64 (upcase event) 95)
+ (- (upcase event) 64)
+ (logior (ash 1 lshiftby) event)))
((eq symbol 'shift)
+ ;; FIXME: Should we also apply this "upcase" behavior of shift
+ ;; to non-ascii letters?
(if (and (<= (downcase event) ?z)
(>= (downcase event) ?a))
(upcase event)
- (logior (lsh 1 lshiftby) event)))
+ (logior (ash 1 lshiftby) event)))
(t
- (logior (lsh 1 lshiftby) event)))
+ (logior (ash 1 lshiftby) event)))
(if (memq symbol (event-modifiers event))
event
(let ((event-type (if (symbolp event) event (car event))))
@@ -8548,13 +8586,16 @@ after it has been set up properly in other respects."
;; Set up other local variables.
(mapc (lambda (v)
- (condition-case () ;in case var is read-only
+ (condition-case ()
(if (symbolp v)
(makunbound v)
(set (make-local-variable (car v)) (cdr v)))
- (error nil)))
+ (setting-constant nil))) ;E.g. for enable-multibyte-characters.
lvars)
+ (setq mark-ring (mapcar (lambda (mk) (copy-marker (marker-position mk)))
+ mark-ring))
+
;; Run any hooks (typically set up by the major mode
;; for cloning to work properly).
(run-hooks 'clone-buffer-hook))
@@ -8667,7 +8708,7 @@ call `normal-erase-is-backspace-mode' (which see) instead."
(and (not noninteractive)
(or (memq system-type '(ms-dos windows-nt))
(memq window-system '(w32 ns))
- (and (memq window-system '(x))
+ (and (eq window-system 'x)
(fboundp 'x-backspace-delete-keys-p)
(x-backspace-delete-keys-p))
;; If the terminal Emacs is running on has erase char
@@ -8678,11 +8719,10 @@ call `normal-erase-is-backspace-mode' (which see) instead."
normal-erase-is-backspace)
1 0)))))
+(declare-function display-symbol-keys-p "frame" (&optional display))
+
(define-minor-mode normal-erase-is-backspace-mode
"Toggle the Erase and Delete mode of the Backspace and Delete keys.
-With a prefix argument ARG, enable this feature if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
On window systems, when this mode is on, Delete is mapped to C-d
and Backspace is mapped to DEL; when this mode is off, both
@@ -8716,10 +8756,9 @@ See also `normal-erase-is-backspace'."
(let ((enabled (eq 1 (terminal-parameter
nil 'normal-erase-is-backspace))))
- (cond ((or (memq window-system '(x w32 ns pc))
- (memq system-type '(ms-dos windows-nt)))
+ (cond ((display-symbol-keys-p)
(let ((bindings
- `(([M-delete] [M-backspace])
+ '(([M-delete] [M-backspace])
([C-M-delete] [C-M-backspace])
([?\e C-delete] [?\e C-backspace]))))
@@ -8759,9 +8798,9 @@ See also `normal-erase-is-backspace'."
(define-minor-mode read-only-mode
"Change whether the current buffer is read-only.
-With prefix argument ARG, make the buffer read-only if ARG is
-positive, otherwise make it writable. If buffer is read-only
-and `view-read-only' is non-nil, enter view mode.
+
+If buffer is read-only and `view-read-only' is non-nil, enter
+view mode.
Do not call this from a Lisp program unless you really intend to
do the same thing as the \\[read-only-mode] command, including
@@ -8785,9 +8824,6 @@ to a non-nil value."
(define-minor-mode visible-mode
"Toggle making all invisible text temporarily visible (Visible mode).
-With a prefix argument ARG, enable Visible mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
This mode works by saving the value of `buffer-invisibility-spec'
and setting it to nil."
@@ -8979,7 +9015,7 @@ Otherwise, it calls `upcase-word', with prefix argument passed to it
to upcase ARG words."
(interactive "*p")
(if (use-region-p)
- (upcase-region (region-beginning) (region-end))
+ (upcase-region (region-beginning) (region-end) (region-noncontiguous-p))
(upcase-word arg)))
(defun downcase-dwim (arg)
@@ -8989,7 +9025,7 @@ Otherwise, it calls `downcase-word', with prefix argument passed to it
to downcase ARG words."
(interactive "*p")
(if (use-region-p)
- (downcase-region (region-beginning) (region-end))
+ (downcase-region (region-beginning) (region-end) (region-noncontiguous-p))
(downcase-word arg)))
(defun capitalize-dwim (arg)
diff --git a/lisp/skeleton.el b/lisp/skeleton.el
index 77a3a6ae601..bce73d6bfef 100644
--- a/lisp/skeleton.el
+++ b/lisp/skeleton.el
@@ -37,13 +37,13 @@
;; page 2: paired insertion
;; page 3: mirror-mode, an example for setting up paired insertion
+(defvaralias 'skeleton-transformation 'skeleton-transformation-function)
(defvar skeleton-transformation-function 'identity
"If non-nil, function applied to literal strings before they are inserted.
It should take strings and characters and return them transformed, or nil
which means no transformation.
Typical examples might be `upcase' or `capitalize'.")
-(defvaralias 'skeleton-transformation 'skeleton-transformation-function)
; this should be a fourth argument to defvar
(put 'skeleton-transformation-function 'variable-interactive
@@ -65,11 +65,11 @@ region.")
"Hook called at end of skeleton but before going to point of interest.
The variables `v1' and `v2' are still set when calling this.")
+(defvaralias 'skeleton-filter 'skeleton-filter-function)
;;;###autoload
(defvar skeleton-filter-function 'identity
"Function for transforming a skeleton proxy's aliases' variable value.")
-(defvaralias 'skeleton-filter 'skeleton-filter-function)
(defvar skeleton-untabify nil ; bug#12223
"When non-nil untabifies when deleting backwards with element -ARG.")
diff --git a/lisp/speedbar.el b/lisp/speedbar.el
index c43db0f678f..4823e4ba565 100644
--- a/lisp/speedbar.el
+++ b/lisp/speedbar.el
@@ -637,9 +637,6 @@ Created from `speedbar-ignored-directory-expressions' with the function
Use the function `speedbar-add-ignored-directory-regexp', or customize the
variable `speedbar-ignored-directory-expressions' to modify this variable.")
-(define-obsolete-variable-alias 'speedbar-ignored-path-expressions
- 'speedbar-ignored-directory-expressions "22.1")
-
(defcustom speedbar-ignored-directory-expressions
'("[/\\]logs?[/\\]\\'")
"List of regular expressions matching directories speedbar will ignore.
@@ -650,9 +647,9 @@ speedbar is loaded. You may place anything you like in this list
before speedbar has been loaded."
:group 'speedbar
:type '(repeat (regexp :tag "Directory Regexp"))
- :set (lambda (_sym val)
- (setq speedbar-ignored-directory-expressions val
- speedbar-ignored-directory-regexp
+ :set (lambda (sym val)
+ (set sym val)
+ (setq speedbar-ignored-directory-regexp
(speedbar-extension-list-to-regex val))))
(defcustom speedbar-directory-unshown-regexp "^\\(\\..*\\)\\'"
@@ -704,9 +701,9 @@ need to also modify `completion-ignored-extension' which will also help
file completion."
:group 'speedbar
:type '(repeat (regexp :tag "Extension Regexp"))
- :set (lambda (_sym val)
- (set 'speedbar-supported-extension-expressions val)
- (set 'speedbar-file-regexp (speedbar-extension-list-to-regex val))))
+ :set (lambda (sym val)
+ (set sym val)
+ (setq speedbar-file-regexp (speedbar-extension-list-to-regex val))))
(setq speedbar-file-regexp
(speedbar-extension-list-to-regex speedbar-supported-extension-expressions))
@@ -744,13 +741,6 @@ DIRECTORY-EXPRESSION to `speedbar-ignored-directory-expressions'."
(setq speedbar-ignored-directory-regexp (speedbar-extension-list-to-regex
speedbar-ignored-directory-expressions)))
-;; If we don't have custom, then we set it here by hand.
-(if (not (fboundp 'custom-declare-variable))
- (setq speedbar-file-regexp (speedbar-extension-list-to-regex
- speedbar-supported-extension-expressions)
- speedbar-ignored-directory-regexp (speedbar-extension-list-to-regex
- speedbar-ignored-directory-expressions)))
-
(defcustom speedbar-update-flag dframe-have-timer-flag
"Non-nil means to automatically update the display.
When this is nil then speedbar will not follow the attached frame's directory.
@@ -982,9 +972,8 @@ supported at a time.
(interactive "P")
;; Get the buffer to play with
(if (not (buffer-live-p speedbar-buffer))
- (save-excursion
- (setq speedbar-buffer (get-buffer-create " SPEEDBAR"))
- (set-buffer speedbar-buffer)
+ (with-current-buffer
+ (setq speedbar-buffer (get-buffer-create " SPEEDBAR"))
(speedbar-mode)))
;; Do the frame thing
(dframe-frame-mode arg
@@ -1476,66 +1465,69 @@ Return nil if not applicable. If FILENAME, then use that
instead of reading it from the speedbar buffer."
(let* ((item (or filename (speedbar-line-file)))
(attr (if item (file-attributes item) nil)))
- (if (and item attr) (dframe-message "%s %-6d %s" (nth 8 attr)
- (nth 7 attr) item)
- nil)))
+ (if (and item attr)
+ (dframe-message "%s %-6d %s"
+ (file-attribute-modes attr)
+ (file-attribute-size attr) item))))
(defun speedbar-item-info-tag-helper ()
"Display info about a tag that is on the current line.
Return nil if not applicable."
(save-excursion
(beginning-of-line)
- (if (re-search-forward " [-+=]?> \\([^\n]+\\)" (line-end-position) t)
- (let* ((tag (match-string 1))
- (attr (speedbar-line-token))
- (item nil)
- (semantic-tagged (if (fboundp 'semantic-tag-p)
- (semantic-tag-p attr))))
- (if semantic-tagged
- (with-no-warnings
- (save-excursion
- (when (and (semantic-tag-overlay attr)
- (semantic-tag-buffer attr))
- (set-buffer (semantic-tag-buffer attr)))
- (dframe-message
- (funcall semantic-sb-info-format-tag-function attr)
- )))
- (looking-at "\\([0-9]+\\):")
- (setq item (file-name-nondirectory (speedbar-line-directory)))
- (dframe-message "Tag: %s in %s" tag item)))
- (if (re-search-forward "{[+-]} \\([^\n]+\\)$" (line-end-position) t)
- (dframe-message "Group of tags \"%s\"" (match-string 1))
- (if (re-search-forward " [+-]?[()|@] \\([^\n]+\\)$" nil t)
- (let* ((detailtext (match-string 1))
- (detail (or (speedbar-line-token) detailtext))
- (parent (save-excursion
- (beginning-of-line)
- (let ((dep (if (looking-at "[0-9]+:")
- (1- (string-to-number (match-string 0)))
- 0)))
- (re-search-backward (concat "^"
- (int-to-string dep)
- ":")
- nil t))
- (if (looking-at "[0-9]+: +[-+=>]> \\([^\n]+\\)$")
- (speedbar-line-token)
- nil))))
- (if (featurep 'semantic)
- (with-no-warnings
- (if (semantic-tag-p detail)
- (dframe-message
- (funcall semantic-sb-info-format-tag-function detail parent))
- (if parent
- (dframe-message "Detail: %s of tag %s" detail
- (if (semantic-tag-p parent)
- (semantic-format-tag-name parent nil t)
- parent))
- (dframe-message "Detail: %s" detail))))
- ;; Not using `semantic':
- (if parent
- (dframe-message "Detail: %s of tag %s" detail parent)
- (dframe-message "Detail: %s" detail))))
- nil)))))
+ (cond
+ ((re-search-forward " [-+=]?> \\([^\n]+\\)" (line-end-position) t)
+ (let* ((tag (match-string 1))
+ (attr (speedbar-line-token))
+ (item nil)
+ (semantic-tagged (if (fboundp 'semantic-tag-p)
+ (semantic-tag-p attr))))
+ (if semantic-tagged
+ (with-no-warnings
+ (save-excursion
+ (when (and (semantic-tag-overlay attr)
+ (semantic-tag-buffer attr))
+ (set-buffer (semantic-tag-buffer attr)))
+ (dframe-message
+ (funcall semantic-sb-info-format-tag-function attr)
+ )))
+ (looking-at "\\([0-9]+\\):")
+ (setq item (file-name-nondirectory (speedbar-line-directory)))
+ (dframe-message "Tag: %s in %s" tag item))))
+ ((re-search-forward "{[+-]} \\([^\n]+\\)$" (line-end-position) t)
+ (dframe-message "Group of tags \"%s\"" (match-string 1)))
+ ((re-search-forward " [+-]?[()|@] \\([^\n]+\\)$" nil t)
+ (let* ((detailtext (match-string 1))
+ (detail (or (speedbar-line-token) detailtext))
+ (parent (save-excursion
+ (beginning-of-line)
+ (let ((dep (if (looking-at "[0-9]+:")
+ (1- (string-to-number (match-string 0)))
+ 0)))
+ (re-search-backward (concat "^"
+ (int-to-string dep)
+ ":")
+ nil t))
+ (if (looking-at "[0-9]+: +[-+=>]> \\([^\n]+\\)$")
+ (speedbar-line-token)
+ nil))))
+ (cond
+ ((featurep 'semantic)
+ (with-no-warnings
+ (if (semantic-tag-p detail)
+ (dframe-message
+ (funcall semantic-sb-info-format-tag-function detail parent))
+ (if parent
+ (dframe-message "Detail: %s of tag %s" detail
+ (if (semantic-tag-p parent)
+ (semantic-format-tag-name parent nil t)
+ parent))
+ (dframe-message "Detail: %s" detail)))))
+ ;; Not using `semantic':
+ (parent
+ (dframe-message "Detail: %s of tag %s" detail parent))
+ (t
+ (dframe-message "Detail: %s" detail))))))))
(defun speedbar-files-item-info ()
"Display info in the minibuffer about the button the mouse is over."
@@ -2857,7 +2849,7 @@ indicator, then do not add a space."
(progn
(goto-char speedbar-ro-to-do-point)
(while (and (not (input-pending-p))
- (re-search-forward "^\\([0-9]+\\):\\s-*[[<][+-?][]>] "
+ (re-search-forward "^\\([0-9]+\\):\\s-*[[<][+?-][]>] "
nil t))
(setq speedbar-ro-to-do-point (point))
(let ((f (speedbar-line-file)))
@@ -2908,7 +2900,7 @@ to add more types of version control systems."
(progn
(goto-char speedbar-vc-to-do-point)
(while (and (not (input-pending-p))
- (re-search-forward "^\\([0-9]+\\):\\s-*\\[[+-?]\\] "
+ (re-search-forward "^\\([0-9]+\\):\\s-*\\[[+?-]\\] "
nil t))
(setq speedbar-vc-to-do-point (point))
(if (speedbar-check-vc-this-line (match-string 1))
@@ -3018,13 +3010,13 @@ the file being checked."
(cdr (car oa))))))
nil
;; Find out if the object is out of date or not.
- (let ((date1 (nth 5 (file-attributes fulln)))
- (date2 (nth 5 (file-attributes (concat
- (file-name-sans-extension fulln)
- (cdr (car oa)))))))
- (if (or (< (car date1) (car date2))
- (and (= (car date1) (car date2))
- (< (nth 1 date1) (nth 1 date2))))
+ (let ((date1 (file-attribute-modification-time
+ (file-attributes fulln)))
+ (date2 (file-attribute-modification-time
+ (file-attributes (concat
+ (file-name-sans-extension fulln)
+ (cdr (car oa)))))))
+ (if (time-less-p date1 date2)
(car speedbar-obj-indicator)
(cdr speedbar-obj-indicator)))))))
@@ -3362,7 +3354,7 @@ Handles end-of-sublist smartly."
Clicking this button expands or contracts a directory. TEXT is the
button clicked which has either a + or -. TOKEN is the directory to be
expanded. INDENT is the current indentation level."
- (cond ((string-match "+" text) ;we have to expand this dir
+ (cond ((string-match "\\+" text) ;we have to expand this dir
(setq speedbar-shown-directories
(cons (expand-file-name
(concat (speedbar-line-directory indent) token "/"))
@@ -3397,9 +3389,7 @@ expanded. INDENT is the current indentation level."
"Speedbar click handler for default directory buttons.
TEXT is the button clicked on. TOKEN is the directory to follow.
INDENT is the current indentation level and is unused."
- (if (string-match "^[A-z]:$" token)
- (setq default-directory (concat token "/"))
- (setq default-directory token))
+ (setq default-directory (file-name-as-directory token))
;; Because we leave speedbar as the current buffer,
;; update contents will change directory without
;; having to touch the attached frame.
@@ -3411,7 +3401,7 @@ INDENT is the current indentation level and is unused."
The parameter TEXT and TOKEN are required, where TEXT is the button
clicked, and TOKEN is the file to expand. INDENT is the current
indentation level."
- (cond ((string-match "+" text) ;we have to expand this file
+ (cond ((string-match "\\+" text) ;we have to expand this file
(let* ((fn (expand-file-name (concat (speedbar-line-directory indent)
token)))
(lst (speedbar-fetch-dynamic-tags fn)))
@@ -3452,7 +3442,7 @@ INDENT is the current indentation level."
"Expand a tag sublist. Imenu will return sub-lists of specialized tag types.
Etags does not support this feature. TEXT will be the button string.
TOKEN will be the list, and INDENT is the current indentation level."
- (cond ((string-match "+" text) ;we have to expand this file
+ (cond ((string-match "\\+" text) ;we have to expand this file
(speedbar-change-expand-button-char ?-)
(speedbar-with-writable
(save-excursion
@@ -3973,7 +3963,7 @@ TEXT is the buffer's name, TOKEN and INDENT are unused."
(speedbar-unhighlight-one-tag-line)
(setq speedbar-highlight-one-tag-line
(speedbar-make-overlay (line-beginning-position)
- (1+ (line-end-position))))
+ (line-beginning-position 2)))
(speedbar-overlay-put speedbar-highlight-one-tag-line 'face
'speedbar-highlight-face)
(add-hook 'pre-command-hook 'speedbar-unhighlight-one-tag-line))
@@ -4077,26 +4067,6 @@ TEXT is the buffer's name, TOKEN and INDENT are unused."
(setq font-lock-global-modes (delq 'speedbar-mode
font-lock-global-modes)))))
-;;; Obsolete variables and functions
-
-(define-obsolete-variable-alias
- 'speedbar-ignored-path-regexp 'speedbar-ignored-directory-regexp "22.1")
-
-(define-obsolete-function-alias 'speedbar-add-ignored-path-regexp
- 'speedbar-add-ignored-directory-regexp "22.1")
-
-(define-obsolete-function-alias 'speedbar-line-path
- 'speedbar-line-directory "22.1")
-
-(define-obsolete-function-alias 'speedbar-buffers-line-path
- 'speedbar-buffers-line-directory "22.1")
-
-(define-obsolete-function-alias 'speedbar-path-line
- 'speedbar-directory-line "22.1")
-
-(define-obsolete-function-alias 'speedbar-buffers-line-path
- 'speedbar-buffers-line-directory "22.1")
-
(provide 'speedbar)
;; run load-time hooks
diff --git a/lisp/startup.el b/lisp/startup.el
index 32051c232ca..a9b58c5e013 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -60,19 +60,17 @@ string or function value that this variable has."
(const :tag "Remember Mode notes buffer" remember-notes)
(function :tag "Function")
(const :tag "Lisp scratch buffer" t))
- :version "23.1"
- :group 'initialization)
+ :version "23.1")
+
+(defvaralias 'inhibit-splash-screen 'inhibit-startup-screen)
+(defvaralias 'inhibit-startup-message 'inhibit-startup-screen)
(defcustom inhibit-startup-screen nil
"Non-nil inhibits the startup screen.
This is for use in your personal init file (but NOT site-start.el),
once you are familiar with the contents of the startup screen."
- :type 'boolean
- :group 'initialization)
-
-(defvaralias 'inhibit-splash-screen 'inhibit-startup-screen)
-(defvaralias 'inhibit-startup-message 'inhibit-startup-screen)
+ :type 'boolean)
(defvar startup-screen-inhibit-startup-screen nil)
@@ -101,18 +99,15 @@ instead:
Thus, someone else using a copy of your init file will see the
startup message unless he personally acts to inhibit it."
:type '(choice (const :tag "Don't inhibit")
- (string :tag "Enter your user name, to inhibit"))
- :group 'initialization)
+ (string :tag "Enter your user name, to inhibit")))
(defcustom inhibit-default-init nil
"Non-nil inhibits loading the `default' library."
- :type 'boolean
- :group 'initialization)
+ :type 'boolean)
(defcustom inhibit-startup-buffer-menu nil
"Non-nil inhibits display of buffer list when more than 2 files are loaded."
- :type 'boolean
- :group 'initialization)
+ :type 'boolean)
(defvar command-switch-alist nil
"Alist of command-line switches.
@@ -120,18 +115,20 @@ Elements look like (SWITCH-STRING . HANDLER-FUNCTION).
HANDLER-FUNCTION receives the switch string as its sole argument;
the remaining command-line args are in the variable `command-line-args-left'.")
-(defvar command-line-args-left nil
- "List of command-line args not yet processed.")
-
-(defvaralias 'argv 'command-line-args-left
- "List of command-line args not yet processed.
-This is a convenience alias, so that one can write \(pop argv)
+(with-no-warnings
+ (defvaralias 'argv 'command-line-args-left
+ "List of command-line args not yet processed.
+This is a convenience alias, so that one can write (pop argv)
inside of --eval command line arguments in order to access
-following arguments.")
+following arguments."))
(internal-make-var-non-special 'argv)
-(defvar argi nil
- "Current command-line argument.")
+(defvar command-line-args-left nil
+ "List of command-line args not yet processed.")
+
+(with-no-warnings
+ (defvar argi nil
+ "Current command-line argument."))
(internal-make-var-non-special 'argi)
(defvar command-line-functions nil ;; lrs 7/31/89
@@ -312,6 +309,12 @@ see `tty-setup-hook'.")
Currently this applies to: `emacs-startup-hook', `term-setup-hook',
and `window-setup-hook'.")
+(defvar early-init-file nil
+ "File name, including directory, of user's early init file.
+See `user-init-file'. The only difference is that
+`early-init-file' is not set during the course of evaluating the
+early init file.")
+
(defvar keyboard-type nil
"The brand of keyboard you are using.
This variable is used to define the proper function and keypad
@@ -328,8 +331,7 @@ is due to historical reasons, and does not reflect its purpose very well.)")
(defcustom initial-major-mode 'lisp-interaction-mode
"Major mode command symbol to use for the initial `*scratch*' buffer."
- :type 'function
- :group 'initialization)
+ :type 'function)
(defvar init-file-user nil
"Identity of user whose init file is or was read.
@@ -368,7 +370,6 @@ it visible in the relevant context. However, actually customizing it
is not allowed, since it would not work anyway. The only way to set
this variable usefully is to set it while building and dumping Emacs."
:type '(choice (const :tag "none" nil) string)
- :group 'initialization
:initialize #'custom-initialize-default
:set (lambda (_variable _value)
(error "Customizing `site-run-file' does not work")))
@@ -789,7 +790,7 @@ to prepare for opening the first frame (e.g. open a connection to an X server)."
argval
(let ((case-fold-search t)
i)
- (setq argval (invocation-name))
+ (setq argval (copy-sequence invocation-name))
;; Change any . or * characters in name to
;; hyphens, so as to emulate behavior on X.
@@ -878,6 +879,98 @@ If STYLE is nil, display appropriately for the terminal."
(when standard-display-table
(aset standard-display-table char nil)))))))
+(defun startup--load-user-init-file
+ (filename-function &optional alternate-filename-function load-defaults)
+ "Load a user init-file.
+FILENAME-FUNCTION is called with no arguments and should return
+the name of the init-file to load. If this file cannot be
+loaded, and ALTERNATE-FILENAME-FUNCTION is non-nil, then it is
+called with no arguments and should return the name of an
+alternate init-file to load. If LOAD-DEFAULTS is non-nil, then
+load default.el after the init-file.
+
+This function sets `user-init-file' to the name of the loaded
+init-file, or to a default value if loading is not possible."
+ (let ((debug-on-error-from-init-file nil)
+ (debug-on-error-should-be-set nil)
+ (debug-on-error-initial
+ (if (eq init-file-debug t)
+ 'startup
+ init-file-debug)))
+ (let ((debug-on-error debug-on-error-initial))
+ (condition-case-unless-debug error
+ (when init-file-user
+ (let ((init-file-name (funcall filename-function)))
+
+ ;; If `user-init-file' is t, then `load' will store
+ ;; the name of the file that it loads into
+ ;; `user-init-file'.
+ (setq user-init-file t)
+ (load (if (equal (file-name-extension init-file-name)
+ "el")
+ (file-name-sans-extension init-file-name)
+ init-file-name)
+ 'noerror 'nomessage)
+
+ (when (and (eq user-init-file t) alternate-filename-function)
+ (let ((alt-file (funcall alternate-filename-function)))
+ (and (equal (file-name-extension alt-file) "el")
+ (setq alt-file (file-name-sans-extension alt-file)))
+ (load alt-file 'noerror 'nomessage)))
+
+ ;; If we did not find the user's init file, set
+ ;; user-init-file conclusively. Don't let it be
+ ;; set from default.el.
+ (when (eq user-init-file t)
+ (setq user-init-file init-file-name)))
+
+ ;; If we loaded a compiled file, set `user-init-file' to
+ ;; the source version if that exists.
+ (when (equal (file-name-extension user-init-file)
+ "elc")
+ (let* ((source (file-name-sans-extension user-init-file))
+ (alt (concat source ".el")))
+ (setq source (cond ((file-exists-p alt) alt)
+ ((file-exists-p source) source)
+ (t nil)))
+ (when source
+ (when (file-newer-than-file-p source user-init-file)
+ (message "Warning: %s is newer than %s"
+ source user-init-file)
+ (sit-for 1))
+ (setq user-init-file source))))
+
+ (when load-defaults
+
+ ;; Prevent default.el from changing the value of
+ ;; `inhibit-startup-screen'.
+ (let ((inhibit-startup-screen nil))
+ (load "default" 'noerror 'nomessage))))
+ (error
+ (display-warning
+ 'initialization
+ (format-message "\
+An error occurred while loading `%s':\n\n%s%s%s\n\n\
+To ensure normal operation, you should investigate and remove the
+cause of the error in your initialization file. Start Emacs with
+the `--debug-init' option to view a complete error backtrace."
+ user-init-file
+ (get (car error) 'error-message)
+ (if (cdr error) ": " "")
+ (mapconcat (lambda (s) (prin1-to-string s t))
+ (cdr error) ", "))
+ :warning)
+ (setq init-file-had-error t)))
+
+ ;; If we can tell that the init file altered debug-on-error,
+ ;; arrange to preserve the value that it set up.
+ (or (eq debug-on-error debug-on-error-initial)
+ (setq debug-on-error-should-be-set t
+ debug-on-error-from-init-file debug-on-error)))
+
+ (when debug-on-error-should-be-set
+ (setq debug-on-error debug-on-error-from-init-file))))
+
(defun command-line ()
"A subroutine of `normal-top-level'.
Amongst another things, it parses the command-line arguments."
@@ -962,7 +1055,8 @@ please check its value")
(let* ((longopts '(("--no-init-file") ("--no-site-file")
("--no-x-resources") ("--debug-init")
("--user") ("--iconic") ("--icon-type") ("--quick")
- ("--no-blinking-cursor") ("--basic-display")))
+ ("--no-blinking-cursor") ("--basic-display")
+ ("--dump-file") ("--temacs")))
(argi (pop args))
(orig-argi argi)
argval)
@@ -1014,6 +1108,9 @@ please check its value")
(push '(visibility . icon) initial-frame-alist))
((member argi '("-nbc" "-no-blinking-cursor"))
(setq no-blinking-cursor t))
+ ((member argi '("-dump-file" "-temacs")) ; Handled in C
+ (or argval (pop args))
+ (setq argval nil))
;; Push the popped arg back on the list of arguments.
(t
(push argi args)
@@ -1029,6 +1126,82 @@ please check its value")
(and command-line-args
(setcdr command-line-args args)))
+ ;; Re-evaluate predefined variables whose initial value depends on
+ ;; the runtime context.
+ (let (current-load-list) ; c-r-s may call defvar, and hence LOADHIST_ATTACH
+ (setq custom-delayed-init-variables
+ ;; Initialize them in the same order they were loaded, in case there
+ ;; are dependencies between them.
+ (nreverse custom-delayed-init-variables))
+ (mapc 'custom-reevaluate-setting custom-delayed-init-variables))
+
+ ;; Warn for invalid user name.
+ (when init-file-user
+ (if (string-match "[~/:\n]" init-file-user)
+ (display-warning 'initialization
+ (format "Invalid user name %s"
+ init-file-user)
+ :error)
+ (if (file-directory-p (expand-file-name
+ ;; We don't support ~USER on MS-Windows
+ ;; and MS-DOS except for the current
+ ;; user, and always load .emacs from
+ ;; the current user's home directory
+ ;; (see below). So always check "~",
+ ;; even if invoked with "-u USER", or
+ ;; if $USER or $LOGNAME are set to
+ ;; something different.
+ (if (memq system-type '(windows-nt ms-dos))
+ "~"
+ (concat "~" init-file-user))))
+ nil
+ (display-warning 'initialization
+ (format "User %s has no home directory"
+ (if (equal init-file-user "")
+ (user-real-login-name)
+ init-file-user))
+ :error))))
+
+ ;; Load the early init file, if found.
+ (startup--load-user-init-file
+ (lambda ()
+ (expand-file-name
+ ;; We use an explicit .el extension here to force
+ ;; startup--load-user-init-file to set user-init-file to "early-init.el",
+ ;; with the .el extension, if the file doesn't exist, not just
+ ;; "early-init" without an extension, as it does for ".emacs".
+ "early-init.el"
+ (file-name-as-directory
+ (concat "~" init-file-user "/.emacs.d")))))
+ (setq early-init-file user-init-file)
+
+ ;; If any package directory exists, initialize the package system.
+ (and user-init-file
+ package-enable-at-startup
+ (catch 'package-dir-found
+ (let (dirs)
+ (if (boundp 'package-directory-list)
+ (setq dirs package-directory-list)
+ (dolist (f load-path)
+ (and (stringp f)
+ (equal (file-name-nondirectory f) "site-lisp")
+ (push (expand-file-name "elpa" f) dirs))))
+ (push (if (boundp 'package-user-dir)
+ package-user-dir
+ (locate-user-emacs-file "elpa"))
+ dirs)
+ (dolist (dir dirs)
+ (when (file-directory-p dir)
+ (dolist (subdir (directory-files dir))
+ (when (let ((subdir (expand-file-name subdir dir)))
+ (and (file-directory-p subdir)
+ (file-exists-p
+ (expand-file-name
+ (package--description-file subdir)
+ subdir))))
+ (throw 'package-dir-found t)))))))
+ (package-activate-all))
+
;; Make sure window system's init file was loaded in loadup.el if
;; using a window system.
;; Initialize the window-system only after processing the command-line
@@ -1096,14 +1269,12 @@ please check its value")
(startup--setup-quote-display)
(setq internal--text-quoting-flag t))
- ;; Re-evaluate predefined variables whose initial value depends on
- ;; the runtime context.
+ ;; 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.
(let (current-load-list) ; c-r-s may call defvar, and hence LOADHIST_ATTACH
- (mapc 'custom-reevaluate-setting
- ;; Initialize them in the same order they were loaded, in case there
- ;; are dependencies between them.
- (prog1 (nreverse custom-delayed-init-variables)
- (setq custom-delayed-init-variables nil))))
+ (mapc 'custom-reevaluate-setting custom-delayed-init-variables)
+ (setq custom-delayed-init-variables nil))
(normal-erase-is-backspace-setup-frame)
@@ -1130,176 +1301,52 @@ please check its value")
;; should check init-file-user instead, since that is already set.
;; See cus-edit.el for an example.
(if site-run-file
- (load site-run-file t t))
-
- ;; Sites should not disable this. Only individuals should disable
- ;; the startup screen.
- (setq inhibit-startup-screen nil)
-
- ;; Warn for invalid user name.
- (when init-file-user
- (if (string-match "[~/:\n]" init-file-user)
- (display-warning 'initialization
- (format "Invalid user name %s"
- init-file-user)
- :error)
- (if (file-directory-p (expand-file-name
- ;; We don't support ~USER on MS-Windows
- ;; and MS-DOS except for the current
- ;; user, and always load .emacs from
- ;; the current user's home directory
- ;; (see below). So always check "~",
- ;; even if invoked with "-u USER", or
- ;; if $USER or $LOGNAME are set to
- ;; something different.
- (if (memq system-type '(windows-nt ms-dos))
- "~"
- (concat "~" init-file-user))))
- nil
- (display-warning 'initialization
- (format "User %s has no home directory"
- (if (equal init-file-user "")
- (user-real-login-name)
- init-file-user))
- :error))))
+ ;; Sites should not disable the startup screen.
+ ;; Only individuals should disable the startup screen.
+ (let ((inhibit-startup-screen inhibit-startup-screen))
+ (load site-run-file t t)))
;; Load that user's init file, or the default one, or none.
- (let (debug-on-error-from-init-file
- debug-on-error-should-be-set
- (debug-on-error-initial
- (if (eq init-file-debug t) 'startup init-file-debug))
- (orig-enable-multibyte (default-value 'enable-multibyte-characters)))
- (let ((debug-on-error debug-on-error-initial)
- ;; This function actually reads the init files.
- (inner
- (function
- (lambda ()
- (if init-file-user
- (let ((user-init-file-1
- (cond
- ((eq system-type 'ms-dos)
- (concat "~" init-file-user "/_emacs"))
- ((not (eq system-type 'windows-nt))
- (concat "~" init-file-user "/.emacs"))
- ;; Else deal with the Windows situation
- ((directory-files "~" nil "^\\.emacs\\(\\.elc?\\)?$")
- ;; Prefer .emacs on Windows.
- "~/.emacs")
- ((directory-files "~" nil "^_emacs\\(\\.elc?\\)?$")
- ;; Also support _emacs for compatibility, but warn about it.
- (push `(initialization
- ,(format-message
- "`_emacs' init file is deprecated, please use `.emacs'"))
- delayed-warnings-list)
- "~/_emacs")
- (t ;; But default to .emacs if _emacs does not exist.
- "~/.emacs"))))
- ;; This tells `load' to store the file name found
- ;; into user-init-file.
- (setq user-init-file t)
- (load user-init-file-1 t t)
-
- (when (eq user-init-file t)
- ;; If we did not find ~/.emacs, try
- ;; ~/.emacs.d/init.el.
- (let ((otherfile
- (expand-file-name
- "init"
- (file-name-as-directory
- (concat "~" init-file-user "/.emacs.d")))))
- (load otherfile t t)
-
- ;; If we did not find the user's init file,
- ;; set user-init-file conclusively.
- ;; Don't let it be set from default.el.
- (when (eq user-init-file t)
- (setq user-init-file user-init-file-1))))
-
- ;; If we loaded a compiled file, set
- ;; `user-init-file' to the source version if that
- ;; exists.
- (when (and user-init-file
- (equal (file-name-extension user-init-file)
- "elc"))
- (let* ((source (file-name-sans-extension user-init-file))
- (alt (concat source ".el")))
- (setq source (cond ((file-exists-p alt) alt)
- ((file-exists-p source) source)
- (t nil)))
- (when source
- (when (file-newer-than-file-p source user-init-file)
- (message "Warning: %s is newer than %s"
- source user-init-file)
- (sit-for 1))
- (setq user-init-file source))))
-
- (unless inhibit-default-init
- (let ((inhibit-startup-screen nil))
- ;; Users are supposed to be told their rights.
- ;; (Plus how to get help and how to undo.)
- ;; Don't you dare turn this off for anyone
- ;; except yourself.
- (load "default" t t)))))))))
- (if init-file-debug
- ;; Do this without a condition-case if the user wants to debug.
- (funcall inner)
- (condition-case error
- (progn
- (funcall inner)
- (setq init-file-had-error nil))
- (error
- (display-warning
- 'initialization
- (format-message "\
-An error occurred while loading `%s':\n\n%s%s%s\n\n\
-To ensure normal operation, you should investigate and remove the
-cause of the error in your initialization file. Start Emacs with
-the `--debug-init' option to view a complete error backtrace."
- user-init-file
- (get (car error) 'error-message)
- (if (cdr error) ": " "")
- (mapconcat (lambda (s) (prin1-to-string s t))
- (cdr error) ", "))
- :warning)
- (setq init-file-had-error t))))
-
- (if (and deactivate-mark transient-mark-mode)
- (with-current-buffer (window-buffer)
- (deactivate-mark)))
-
- ;; If the user has a file of abbrevs, read it (unless -batch).
- (when (and (not noninteractive)
- (file-exists-p abbrev-file-name)
- (file-readable-p abbrev-file-name))
- (quietly-read-abbrev-file abbrev-file-name))
-
- ;; If the abbrevs came entirely from the init file or the
- ;; abbrevs file, they do not need saving.
- (setq abbrevs-changed nil)
-
- ;; If we can tell that the init file altered debug-on-error,
- ;; arrange to preserve the value that it set up.
- (or (eq debug-on-error debug-on-error-initial)
- (setq debug-on-error-should-be-set t
- debug-on-error-from-init-file debug-on-error)))
- (if debug-on-error-should-be-set
- (setq debug-on-error debug-on-error-from-init-file))
- (unless (or (default-value 'enable-multibyte-characters)
- (eq orig-enable-multibyte (default-value
- 'enable-multibyte-characters)))
- ;; Init file changed to unibyte. Reset existing multibyte
- ;; buffers (probably *scratch*, *Messages*, *Minibuf-0*).
- ;; Arguably this should only be done if they're free of
- ;; multibyte characters.
- (mapc (lambda (buffer)
- (with-current-buffer buffer
- (if enable-multibyte-characters
- (set-buffer-multibyte nil))))
- (buffer-list))
- ;; Also re-set the language environment in case it was
- ;; originally done before unibyte was set and is sensitive to
- ;; unibyte (display table, terminal coding system &c).
- (set-language-environment current-language-environment)))
+ (startup--load-user-init-file
+ (lambda ()
+ (cond
+ ((eq system-type 'ms-dos)
+ (concat "~" init-file-user "/_emacs"))
+ ((not (eq system-type 'windows-nt))
+ (concat "~" init-file-user "/.emacs"))
+ ;; Else deal with the Windows situation.
+ ((directory-files "~" nil "^\\.emacs\\(\\.elc?\\)?$")
+ ;; Prefer .emacs on Windows.
+ "~/.emacs")
+ ((directory-files "~" nil "^_emacs\\(\\.elc?\\)?$")
+ ;; Also support _emacs for compatibility, but warn about it.
+ (push `(initialization
+ ,(format-message
+ "`_emacs' init file is deprecated, please use `.emacs'"))
+ delayed-warnings-list)
+ "~/_emacs")
+ (t ;; But default to .emacs if _emacs does not exist.
+ "~/.emacs")))
+ (lambda ()
+ (expand-file-name
+ "init"
+ (file-name-as-directory
+ (concat "~" init-file-user "/.emacs.d"))))
+ (not inhibit-default-init))
+
+ (when (and deactivate-mark transient-mark-mode)
+ (with-current-buffer (window-buffer)
+ (deactivate-mark)))
+
+ ;; If the user has a file of abbrevs, read it (unless -batch).
+ (when (and (not noninteractive)
+ (file-exists-p abbrev-file-name)
+ (file-readable-p abbrev-file-name))
+ (quietly-read-abbrev-file abbrev-file-name))
+
+ ;; If the abbrevs came entirely from the init file or the
+ ;; abbrevs file, they do not need saving.
+ (setq abbrevs-changed nil)
;; Do this here in case the init file sets mail-host-address.
(and mail-host-address
@@ -1321,33 +1368,6 @@ the `--debug-init' option to view a complete error backtrace."
(eq face-ignored-fonts old-face-ignored-fonts))
(clear-face-cache)))
- ;; If any package directory exists, initialize the package system.
- (and user-init-file
- package-enable-at-startup
- (catch 'package-dir-found
- (let (dirs)
- (if (boundp 'package-directory-list)
- (setq dirs package-directory-list)
- (dolist (f load-path)
- (and (stringp f)
- (equal (file-name-nondirectory f) "site-lisp")
- (push (expand-file-name "elpa" f) dirs))))
- (push (if (boundp 'package-user-dir)
- package-user-dir
- (locate-user-emacs-file "elpa"))
- dirs)
- (dolist (dir dirs)
- (when (file-directory-p dir)
- (dolist (subdir (directory-files dir))
- (when (let ((subdir (expand-file-name subdir dir)))
- (and (file-directory-p subdir)
- (file-exists-p
- (expand-file-name
- (package--description-file subdir)
- subdir))))
- (throw 'package-dir-found t)))))))
- (package-initialize))
-
(setq after-init-time (current-time))
;; Display any accumulated warnings after all functions in
;; `after-init-hook' like `desktop-read' have finalized possible
@@ -1460,8 +1480,7 @@ settings will be marked as \"CHANGED outside of Customize\"."
"Initial documentation displayed in *scratch* buffer at startup.
If this is nil, no message will be displayed."
:type '(choice (text :tag "Message")
- (const :tag "none" nil))
- :group 'initialization)
+ (const :tag "none" nil)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1615,13 +1634,13 @@ Each element in the list should be a list of strings or pairs
(defgroup fancy-splash-screen ()
+ ;; FIXME: Do we really need this group with a single custom var?
"Fancy splash screen when Emacs starts."
:version "21.1"
:group 'initialization)
(defcustom fancy-splash-image nil
"The image to show in the splash screens, or nil for defaults."
- :group 'fancy-splash-screen
:type '(choice (const :tag "Default" nil)
(file :tag "File")))
@@ -1742,7 +1761,7 @@ a face or button specification."
:face 'variable-pitch "To quit a partially entered command, type "
:face 'default "Control-g"
:face 'variable-pitch ".\n")
- (fancy-splash-insert :face `(variable-pitch font-lock-builtin-face)
+ (fancy-splash-insert :face '(variable-pitch font-lock-builtin-face)
"\nThis is "
(emacs-version)
"\n"
@@ -1890,7 +1909,8 @@ we put it on this frame."
(if (and (frame-visible-p frame)
(not (window-minibuffer-p (frame-selected-window frame))))
(setq chosen-frame frame)))
- chosen-frame))
+ ;; If there are no visible frames yet, try the selected one.
+ (or chosen-frame (selected-frame))))
(defun use-fancy-splash-screens-p ()
"Return t if fancy splash screens should be used."
@@ -2505,7 +2525,12 @@ nil default-directory" name)
(insert (substitute-command-keys initial-scratch-message))
(set-buffer-modified-p nil))))
- ;; Prepend `initial-buffer-choice' to `displayable-buffers'.
+ ;; Prepend `initial-buffer-choice' to `displayable-buffers'. If
+ ;; the buffer is already a member of that list then shift the
+ ;; buffer to the head of the list. The shift behavior is intended
+ ;; to prevent the same buffer being displayed in two windows when
+ ;; an `initial-buffer-choice' function happens to return the head
+ ;; of `displayable-buffers'.
(when initial-buffer-choice
(let ((buf
(cond ((stringp initial-buffer-choice)
@@ -2518,7 +2543,7 @@ nil default-directory" name)
(error "`initial-buffer-choice' must be a string, a function, or t")))))
(unless (buffer-live-p buf)
(error "Value returned by `initial-buffer-choice' is not a live buffer: %S" buf))
- (setq displayable-buffers (cons buf displayable-buffers))))
+ (setq displayable-buffers (cons buf (delq buf displayable-buffers)))))
;; Display the first two buffers in `displayable-buffers'. If
;; `initial-buffer-choice' is non-nil, its buffer will be the
diff --git a/lisp/strokes.el b/lisp/strokes.el
index c480efdfbfe..9265b8a52ea 100644
--- a/lisp/strokes.el
+++ b/lisp/strokes.el
@@ -1388,9 +1388,6 @@ If STROKES-MAP is not given, `strokes-global-map' will be used instead."
;;;###autoload
(define-minor-mode strokes-mode
"Toggle Strokes mode, a global minor mode.
-With a prefix argument ARG, enable Strokes mode if ARG is
-positive, and disable it otherwise. If called from Lisp,
-enable the mode if ARG is omitted or nil.
\\<strokes-mode-map>
Strokes are pictographic mouse gestures which invoke commands.
diff --git a/lisp/subr.el b/lisp/subr.el
index 54bee8a809f..bf3716bbd37 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -78,8 +78,8 @@ If FORM does return, signal an error."
(defmacro 1value (form)
"Evaluate FORM, expecting a constant return value.
-This is the global do-nothing version. There is also `testcover-1value'
-that complains if FORM ever does return differing values."
+If FORM returns differing values when running under Testcover,
+Testcover will raise an error."
(declare (debug t))
form)
@@ -118,6 +118,33 @@ BODY should be a list of Lisp expressions.
;; depend on backquote.el.
(list 'function (cons 'lambda cdr)))
+(defmacro prog2 (form1 form2 &rest body)
+ "Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
+The value of FORM2 is saved during the evaluation of the
+remaining args, whose values are discarded."
+ (declare (indent 2) (debug t))
+ `(progn ,form1 (prog1 ,form2 ,@body)))
+
+(defmacro setq-default (&rest args)
+ "Set the default value of variable VAR to VALUE.
+VAR, the variable name, is literal (not evaluated);
+VALUE is an expression: it is evaluated and its value returned.
+The default value of a variable is seen in buffers
+that do not have their own values for the variable.
+
+More generally, you can use multiple variables and values, as in
+ (setq-default VAR VALUE VAR VALUE...)
+This sets each VAR's default value to the corresponding VALUE.
+The VALUE for the Nth VAR can refer to the new default values
+of previous VARs.
+
+\(fn [VAR VALUE]...)"
+ (declare (debug setq))
+ (let ((exps nil))
+ (while args
+ (push `(set-default ',(pop args) ,(pop args)) exps))
+ `(progn . ,(nreverse exps))))
+
(defmacro setq-local (var val)
"Set variable VAR to value VAL in current buffer."
;; Can't use backquote here, it's too early in the bootstrap.
@@ -224,7 +251,7 @@ Then evaluate RESULT to get return value, default nil.
"Loop a certain number of times.
Evaluate BODY with VAR bound to successive integers running from 0,
inclusive, to COUNT, exclusive. Then evaluate RESULT to get
-the return value (nil if RESULT is omitted).
+the return value (nil if RESULT is omitted). Its use is deprecated.
\(fn (VAR COUNT [RESULT]) BODY...)"
(declare (indent 1) (debug dolist))
@@ -360,6 +387,34 @@ was called."
(lambda (&rest args2)
(apply fun (append args args2))))
+(defun zerop (number)
+ "Return t if NUMBER is zero."
+ ;; Used to be in C, but it's pointless since (= 0 n) is faster anyway because
+ ;; = has a byte-code.
+ (declare (compiler-macro (lambda (_) `(= 0 ,number))))
+ (= 0 number))
+
+(defun fixnump (object)
+ "Return t if OBJECT is a fixnum."
+ (and (integerp object)
+ (<= most-negative-fixnum object most-positive-fixnum)))
+
+(defun bignump (object)
+ "Return t if OBJECT is a bignum."
+ (and (integerp object) (not (fixnump object))))
+
+(defun lsh (value count)
+ "Return VALUE with its bits shifted left by COUNT.
+If COUNT is negative, shifting is actually to the right.
+In this case, if VALUE is a negative fixnum treat it as unsigned,
+i.e., subtract 2 * most-negative-fixnum from VALUE before shifting it."
+ (when (and (< value 0) (< count 0))
+ (when (< value most-negative-fixnum)
+ (signal 'args-out-of-range (list value count)))
+ (setq value (logand (ash value -1) most-positive-fixnum))
+ (setq count (1+ count)))
+ (ash value count))
+
;;;; List functions.
@@ -549,12 +604,10 @@ If N is omitted or nil, remove the last element."
(if (> n 0) (setcdr (nthcdr (- (1- m) n) list) nil))
list))))
-(defun zerop (number)
- "Return t if NUMBER is zero."
- ;; Used to be in C, but it's pointless since (= 0 n) is faster anyway because
- ;; = has a byte-code.
- (declare (compiler-macro (lambda (_) `(= 0 ,number))))
- (= 0 number))
+;; The function's definition was moved to fns.c,
+;; but it's easier to set properties here.
+(put 'proper-list-p 'pure t)
+(put 'proper-list-p 'side-effect-free 'error-free)
(defun delete-dups (list)
"Destructively remove `equal' duplicates from LIST.
@@ -681,20 +734,6 @@ If TEST is omitted or nil, `equal' is used."
(setq tail (cdr tail)))
value))
-(defun assoc-ignore-case (key alist)
- "Like `assoc', but ignores differences in case and text representation.
-KEY must be a string. Upper-case and lower-case letters are treated as equal.
-Unibyte strings are converted to multibyte for comparison."
- (declare (obsolete assoc-string "22.1"))
- (assoc-string key alist t))
-
-(defun assoc-ignore-representation (key alist)
- "Like `assoc', but ignores differences in text representation.
-KEY must be a string.
-Unibyte strings are converted to multibyte for comparison."
- (declare (obsolete assoc-string "22.1"))
- (assoc-string key alist nil))
-
(defun member-ignore-case (elt list)
"Like `member', but ignore differences in case and text representation.
ELT must be a string. Upper-case and lower-case letters are treated as equal.
@@ -706,17 +745,19 @@ Non-strings in LIST are ignored."
(setq list (cdr list)))
list)
-(defun assoc-delete-all (key alist)
- "Delete from ALIST all elements whose car is `equal' to KEY.
+(defun assoc-delete-all (key alist &optional test)
+ "Delete from ALIST all elements whose car is KEY.
+Compare keys with TEST. Defaults to `equal'.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
+ (unless test (setq test #'equal))
(while (and (consp (car alist))
- (equal (car (car alist)) key))
+ (funcall test (caar alist) key))
(setq alist (cdr alist)))
(let ((tail alist) tail-cdr)
(while (setq tail-cdr (cdr tail))
(if (and (consp (car tail-cdr))
- (equal (car (car tail-cdr)) key))
+ (funcall test (caar tail-cdr) key))
(setcdr tail (cdr tail-cdr))
(setq tail tail-cdr))))
alist)
@@ -725,16 +766,7 @@ Elements of ALIST that are not conses are ignored."
"Delete from ALIST all elements whose car is `eq' to KEY.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
- (while (and (consp (car alist))
- (eq (car (car alist)) key))
- (setq alist (cdr alist)))
- (let ((tail alist) tail-cdr)
- (while (setq tail-cdr (cdr tail))
- (if (and (consp (car tail-cdr))
- (eq (car (car tail-cdr)) key))
- (setcdr tail (cdr tail-cdr))
- (setq tail tail-cdr))))
- alist)
+ (assoc-delete-all key alist #'eq))
(defun rassq-delete-all (value alist)
"Delete from ALIST all elements whose cdr is `eq' to VALUE.
@@ -756,9 +788,31 @@ Elements of ALIST that are not conses are ignored."
If KEY is not found in ALIST, return DEFAULT.
Equality with KEY is tested by TESTFN, defaulting to `eq'.
-This is a generalized variable suitable for use with `setf'.
+You can use `alist-get' in PLACE expressions. This will modify
+an existing association (more precisely, the first one if
+multiple exist), or add a new element to the beginning of ALIST,
+destructively modifying the list stored in ALIST.
+
+Example:
+
+ (setq foo '((a . 0)))
+ (setf (alist-get 'a foo) 1
+ (alist-get 'b foo) 2)
+
+ foo => ((b . 2) (a . 1))
+
+
When using it to set a value, optional argument REMOVE non-nil
-means to remove KEY from ALIST if the new value is `eql' to DEFAULT."
+means to remove KEY from ALIST if the new value is `eql' to
+DEFAULT (more precisely the first found association will be
+deleted from the alist).
+
+Example:
+
+ (setq foo '((a . 1) (b . 2)))
+ (setf (alist-get 'b foo nil 'remove) nil)
+
+ foo => ((a . 1))"
(ignore remove) ;;Silence byte-compiler.
(let ((x (if (not testfn)
(assq key alist)
@@ -1456,8 +1510,17 @@ be a list of the form returned by `event-start' and `event-end'."
(make-obsolete 'forward-point "use (+ (point) N) instead." "23.1")
(make-obsolete 'buffer-has-markers-at nil "24.3")
+(make-obsolete 'invocation-directory "use the variable of the same name."
+ "27.1")
+(make-obsolete 'invocation-name "use the variable of the same name." "27.1")
+
+;; We used to declare string-to-unibyte obsolete, but it is a valid
+;; way of getting a unibyte string that can be indexed by bytes, when
+;; the original string has raw bytes in their internal multibyte
+;; representation. This can be useful when one needs to examine
+;; individual bytes at known offsets from the string beginning.
+;; (make-obsolete 'string-to-unibyte "use `encode-coding-string'." "26.1")
;; bug#23850
-(make-obsolete 'string-to-unibyte "use `encode-coding-string'." "26.1")
(make-obsolete 'string-as-unibyte "use `encode-coding-string'." "26.1")
(make-obsolete 'string-make-unibyte "use `encode-coding-string'." "26.1")
(make-obsolete 'string-to-multibyte "use `decode-coding-string'." "26.1")
@@ -1469,17 +1532,13 @@ be a list of the form returned by `event-start' and `event-end'."
(declare (obsolete log "24.4"))
(log x 10))
-;; These are used by VM and some old programs
-(defalias 'focus-frame 'ignore "")
-(make-obsolete 'focus-frame "it does nothing." "22.1")
-(defalias 'unfocus-frame 'ignore "")
-(make-obsolete 'unfocus-frame "it does nothing." "22.1")
-
(set-advertised-calling-convention
'all-completions '(string collection &optional predicate) "23.1")
(set-advertised-calling-convention 'unintern '(name obarray) "23.3")
(set-advertised-calling-convention 'indirect-function '(object) "25.1")
(set-advertised-calling-convention 'redirect-frame-focus '(frame focus-frame) "24.3")
+(set-advertised-calling-convention 'libxml-parse-xml-region '(start end &optional base-url) "27.1")
+(set-advertised-calling-convention 'libxml-parse-html-region '(start end &optional base-url) "27.1")
;;;; Obsolescence declarations for variables, and aliases.
@@ -1497,15 +1556,6 @@ be a list of the form returned by `event-start' and `event-end'."
(make-obsolete-variable 'command-debug-status
"expect it to be removed in a future version." "25.2")
-;; Lisp manual only updated in 22.1.
-(define-obsolete-variable-alias 'executing-macro 'executing-kbd-macro
- "before 19.34")
-
-(define-obsolete-variable-alias 'x-lost-selection-hooks
- 'x-lost-selection-functions "22.1")
-(define-obsolete-variable-alias 'x-sent-selection-hooks
- 'x-sent-selection-functions "22.1")
-
;; This was introduced in 21.4 for pre-unicode unification. That
;; usage was rendered obsolete in 23.1 which uses Unicode internally.
;; Other uses are possible, so this variable is not _really_ obsolete,
@@ -1515,6 +1565,8 @@ be a list of the form returned by `event-start' and `event-end'."
(make-obsolete-variable 'x-gtk-use-window-move nil "26.1")
(defvaralias 'messages-buffer-max-lines 'message-log-max)
+(define-obsolete-variable-alias 'inhibit-null-byte-detection
+ 'inhibit-nul-byte-detection "27.1")
;;;; Alternate names for functions - these are not being phased out.
@@ -1829,7 +1881,7 @@ variable. The possible values of maximum length have the same meaning as
the values of `history-length'.
Remove duplicates of NEWELT if `history-delete-duplicates' is non-nil.
If optional fourth arg KEEP-ALL is non-nil, add NEWELT to history even
-if it is empty or a duplicate."
+if it is empty or duplicates the most recent entry in the history."
(unless maxelt
(setq maxelt (or (get history-var 'history-length)
history-length)))
@@ -1845,27 +1897,25 @@ if it is empty or a duplicate."
(setq history (delete newelt history)))
(setq history (cons newelt history))
(when (integerp maxelt)
- (if (= 0 maxelt)
+ (if (>= 0 maxelt)
(setq history nil)
(setq tail (nthcdr (1- maxelt) history))
(when (consp tail)
- (setcdr tail nil)))))
- (set history-var history)))
+ (setcdr tail nil))))
+ (set history-var history))))
;;;; Mode hooks.
(defvar delay-mode-hooks nil
"If non-nil, `run-mode-hooks' should delay running the hooks.")
-(defvar delayed-mode-hooks nil
+(defvar-local delayed-mode-hooks nil
"List of delayed mode hooks waiting to be run.")
-(make-variable-buffer-local 'delayed-mode-hooks)
(put 'delay-mode-hooks 'permanent-local t)
-(defvar delayed-after-hook-functions nil
+(defvar-local delayed-after-hook-functions nil
"List of delayed :after-hook forms waiting to be run.
These forms come from `define-derived-mode'.")
-(make-variable-buffer-local 'delayed-after-hook-functions)
(defvar change-major-mode-after-body-hook nil
"Normal hook run in major mode functions, before the mode hooks.")
@@ -1894,15 +1944,22 @@ running their FOO-mode-hook."
(push hook delayed-mode-hooks))
;; Normal case, just run the hook as before plus any delayed hooks.
(setq hooks (nconc (nreverse delayed-mode-hooks) hooks))
+ (and (bound-and-true-p syntax-propertize-function)
+ (not (local-variable-p 'parse-sexp-lookup-properties))
+ ;; `syntax-propertize' sets `parse-sexp-lookup-properties' for us, but
+ ;; in order for the sexp primitives to automatically call
+ ;; `syntax-propertize' we need `parse-sexp-lookup-properties' to be
+ ;; set first.
+ (setq-local parse-sexp-lookup-properties t))
(setq delayed-mode-hooks nil)
- (apply 'run-hooks (cons 'change-major-mode-after-body-hook hooks))
+ (apply #'run-hooks (cons 'change-major-mode-after-body-hook hooks))
(if (buffer-file-name)
(with-demoted-errors "File local-variables error: %s"
(hack-local-variables 'no-mode)))
(run-hooks 'after-change-major-mode-hook)
- (dolist (fun (nreverse delayed-after-hook-functions))
- (funcall fun))
- (setq delayed-after-hook-functions nil)))
+ (dolist (fun (prog1 (nreverse delayed-after-hook-functions)
+ (setq delayed-after-hook-functions nil)))
+ (funcall fun))))
(defmacro delay-mode-hooks (&rest body)
"Execute BODY, but delay any `run-mode-hooks'.
@@ -1918,17 +1975,51 @@ Only affects hooks run in the current buffer."
;; PUBLIC: find if the current mode derives from another.
(defun provided-mode-derived-p (mode &rest modes)
- "Non-nil if MODE is derived from one of MODES.
+ "Non-nil if MODE is derived from one of MODES or their aliases.
Uses the `derived-mode-parent' property of the symbol to trace backwards.
If you just want to check `major-mode', use `derived-mode-p'."
- (while (and (not (memq mode modes))
- (setq mode (get mode 'derived-mode-parent))))
+ (while
+ (and
+ (not (memq mode modes))
+ (let* ((parent (get mode 'derived-mode-parent))
+ (parentfn (symbol-function parent)))
+ (setq mode (if (and parentfn (symbolp parentfn)) parentfn parent)))))
mode)
(defun derived-mode-p (&rest modes)
"Non-nil if the current major mode is derived from one of MODES.
Uses the `derived-mode-parent' property of the symbol to trace backwards."
(apply #'provided-mode-derived-p major-mode modes))
+
+(defvar-local major-mode--suspended nil)
+(put 'major-mode--suspended 'permanent-local t)
+
+(defun major-mode-suspend ()
+ "Exit current major, remembering it."
+ (let* ((prev-major-mode (or major-mode--suspended
+ (unless (eq major-mode 'fundamental-mode)
+ major-mode))))
+ (kill-all-local-variables)
+ (setq-local major-mode--suspended prev-major-mode)))
+
+(defun major-mode-restore (&optional avoided-modes)
+ "Restore major mode earlier suspended with `major-mode-suspend'.
+If there was no earlier suspended major mode, then fallback to `normal-mode',
+tho trying to avoid AVOIDED-MODES."
+ (if major-mode--suspended
+ (funcall (prog1 major-mode--suspended
+ (kill-local-variable 'major-mode--suspended)))
+ (let ((auto-mode-alist
+ (let ((alist (copy-sequence auto-mode-alist)))
+ (dolist (mode avoided-modes)
+ (setq alist (rassq-delete-all mode alist)))
+ alist))
+ (magic-fallback-mode-alist
+ (let ((alist (copy-sequence magic-fallback-mode-alist)))
+ (dolist (mode avoided-modes)
+ (setq alist (rassq-delete-all mode alist)))
+ alist)))
+ (normal-mode))))
;;;; Minor modes.
@@ -2178,19 +2269,6 @@ process."
(memq (process-status process)
'(run open listen connect stop))))
-;; compatibility
-
-(defun process-kill-without-query (process &optional _flag)
- "Say no query needed if PROCESS is running when Emacs is exited.
-Optional second argument if non-nil says to require a query.
-Value is t if a query was formerly required."
- (declare (obsolete
- "use `process-query-on-exit-flag' or `set-process-query-on-exit-flag'."
- "22.1"))
- (let ((old (process-query-on-exit-flag process)))
- (set-process-query-on-exit-flag process nil)
- old))
-
(defun process-kill-buffer-query-function ()
"Ask before killing a buffer that has a running process."
(let ((process (get-buffer-process (current-buffer))))
@@ -2216,6 +2294,10 @@ It can be retrieved with `(process-get PROCESS PROPNAME)'."
(set-process-plist process
(plist-put (process-plist process) propname value)))
+(defun memory-limit ()
+ "Return an estimate of Emacs virtual memory usage, divided by 1024."
+ (or (cdr (assq 'vsize (process-attributes (emacs-pid)))) 0))
+
;;;; Input and display facilities.
@@ -2299,7 +2381,7 @@ some sort of escape sequence, the ambiguity is resolved via `read-key-delay'."
If optional CONFIRM is non-nil, read the password twice to make sure.
Optional DEFAULT is a default password to use instead of empty input.
-This function echoes `.' for each character that the user types.
+This function echoes `*' for each character that the user types.
You could let-bind `read-hide-char' to another hiding character, though.
Once the caller uses the password, it can erase the password
@@ -2325,7 +2407,7 @@ by doing (clear-string STRING)."
beg)))
(dotimes (i (- end beg))
(put-text-property (+ i beg) (+ 1 i beg)
- 'display (string (or read-hide-char ?.))))))
+ 'display (string (or read-hide-char ?*))))))
minibuf)
(minibuffer-with-setup-hook
(lambda ()
@@ -2340,7 +2422,7 @@ by doing (clear-string STRING)."
(add-hook 'after-change-functions hide-chars-fun nil 'local))
(unwind-protect
(let ((enable-recursive-minibuffers t)
- (read-hide-char (or read-hide-char ?.)))
+ (read-hide-char (or read-hide-char ?*)))
(read-string prompt nil t default)) ; t = "no history"
(when (buffer-live-p minibuf)
(with-current-buffer minibuf
@@ -2591,7 +2673,7 @@ is nil and `use-dialog-box' is non-nil."
;;; Atomic change groups.
(defmacro atomic-change-group (&rest body)
- "Perform BODY as an atomic change group.
+ "Like `progn' but perform BODY as an atomic change group.
This means that if BODY exits abnormally,
all of its changes to the current buffer are undone.
This works regardless of whether undo is enabled in the buffer.
@@ -2614,8 +2696,8 @@ user can undo the change normally."
;; it enables undo if that was disabled; we need
;; to make sure that it gets disabled again.
(activate-change-group ,handle)
- ,@body
- (setq ,success t))
+ (prog1 ,(macroexp-progn body)
+ (setq ,success t)))
;; Either of these functions will disable undo
;; if it was disabled before.
(if ,success
@@ -3064,6 +3146,8 @@ This function is like `insert', except it honors the variables
(inhibit-read-only inhibit-read-only)
end)
+ ;; FIXME: This throws away any yank-undo-function set by previous calls
+ ;; to insert-for-yank-1 within the loop of insert-for-yank!
(setq yank-undo-function t)
(if (nth 0 handler) ; FUNCTION
(funcall (car handler) param)
@@ -3157,11 +3241,12 @@ discouraged."
"Start a program in a subprocess. Return the process object for it.
Similar to `start-process-shell-command', but calls `start-file-process'."
(declare (advertised-calling-convention (name buffer command) "23.1"))
- (start-file-process
- name buffer
- (if (file-remote-p default-directory) "/bin/sh" shell-file-name)
- (if (file-remote-p default-directory) "-c" shell-command-switch)
- (mapconcat 'identity args " ")))
+ ;; On remote hosts, the local `shell-file-name' might be useless.
+ (with-connection-local-variables
+ (start-file-process
+ name buffer
+ shell-file-name shell-command-switch
+ (mapconcat 'identity args " "))))
(defun call-process-shell-command (command &optional infile buffer display
&rest args)
@@ -3202,11 +3287,11 @@ discouraged."
Similar to `call-process-shell-command', but calls `process-file'."
(declare (advertised-calling-convention
(command &optional infile buffer display) "24.5"))
- (process-file
- (if (file-remote-p default-directory) "/bin/sh" shell-file-name)
- infile buffer display
- (if (file-remote-p default-directory) "-c" shell-command-switch)
- (mapconcat 'identity (cons command args) " ")))
+ ;; On remote hosts, the local `shell-file-name' might be useless.
+ (with-connection-local-variables
+ (process-file
+ shell-file-name infile buffer display shell-command-switch
+ (mapconcat 'identity (cons command args) " "))))
(defun call-shell-region (start end command &optional delete buffer)
"Send text from START to END as input to an inferior shell running COMMAND.
@@ -3554,9 +3639,31 @@ If BODY finishes, `while-no-input' returns whatever value BODY produced."
(let ((catch-sym (make-symbol "input")))
`(with-local-quit
(catch ',catch-sym
- (let ((throw-on-input ',catch-sym))
- (or (input-pending-p)
- (progn ,@body)))))))
+ (let ((throw-on-input ',catch-sym)
+ val)
+ (setq val (or (input-pending-p)
+ (progn ,@body)))
+ (cond
+ ;; When input arrives while throw-on-input is non-nil,
+ ;; kbd_buffer_store_buffered_event sets quit-flag to the
+ ;; value of throw-on-input. If, when BODY finishes,
+ ;; quit-flag still has the same value as throw-on-input, it
+ ;; means BODY never tested quit-flag, and therefore ran to
+ ;; completion even though input did arrive before it
+ ;; finished. In that case, we must manually simulate what
+ ;; 'throw' in process_quit_flag would do, and we must
+ ;; reset quit-flag, because leaving it set will cause us
+ ;; quit to top-level, which has undesirable consequences,
+ ;; such as discarding input etc. We return t in that case
+ ;; because input did arrive during execution of BODY.
+ ((eq quit-flag throw-on-input)
+ (setq quit-flag nil)
+ t)
+ ;; This is for when the user actually QUITs during
+ ;; execution of BODY.
+ (quit-flag
+ nil)
+ (t val)))))))
(defmacro condition-case-unless-debug (var bodyform &rest handlers)
"Like `condition-case' except that it does not prevent debugging.
@@ -3613,6 +3720,126 @@ in BODY."
. ,body)
(combine-after-change-execute)))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar undo--combining-change-calls nil
+ "Non-nil when `combine-change-calls-1' is running.")
+
+(defun combine-change-calls-1 (beg end body)
+ "Evaluate BODY, running the change hooks just once, for region \(BEG END).
+
+Firstly, `before-change-functions' is invoked for the region
+\(BEG END), then BODY (a function) is evaluated with
+`before-change-functions' and `after-change-functions' bound to
+nil, then finally `after-change-functions' is invoked on the
+updated region (BEG NEW-END) with a calculated OLD-LEN argument.
+If `inhibit-modification-hooks' is initially non-nil, the change
+hooks are not run.
+
+The result of `combine-change-calls-1' is the value returned by
+BODY. BODY must not make a different buffer current, except
+temporarily. It must not make any changes to the buffer outside
+the specified region. It must not change
+`before-change-functions' or `after-change-functions'.
+
+Additionally, the buffer modifications of BODY are recorded on
+the buffer's undo list as a single (apply ...) entry containing
+the function `undo--wrap-and-run-primitive-undo'."
+ (let ((old-bul buffer-undo-list)
+ (end-marker (copy-marker end t))
+ result)
+ (if undo--combining-change-calls
+ (setq result (funcall body))
+ (let ((undo--combining-change-calls t))
+ (if (not inhibit-modification-hooks)
+ (run-hook-with-args 'before-change-functions beg end))
+ (if (eq buffer-undo-list t)
+ (setq result (funcall body))
+ (let (;; (inhibit-modification-hooks t)
+ (before-change-functions
+ ;; Ugly Hack: if the body uses syntax-ppss/syntax-propertize
+ ;; (e.g. via a regexp-search or sexp-movement trigerring
+ ;; on-the-fly syntax-propertize), make sure that this gets
+ ;; properly refreshed after subsequent changes.
+ (if (memq #'syntax-ppss-flush-cache before-change-functions)
+ '(syntax-ppss-flush-cache)))
+ after-change-functions)
+ (setq result (funcall body)))
+ (let ((ap-elt
+ (list 'apply
+ (- end end-marker)
+ beg
+ (marker-position end-marker)
+ #'undo--wrap-and-run-primitive-undo
+ beg (marker-position end-marker) buffer-undo-list))
+ (ptr buffer-undo-list))
+ (if (not (eq buffer-undo-list old-bul))
+ (progn
+ (while (and (not (eq (cdr ptr) old-bul))
+ ;; In case garbage collection has removed OLD-BUL.
+ (cdr ptr)
+ ;; Don't include a timestamp entry.
+ (not (and (consp (cdr ptr))
+ (consp (cadr ptr))
+ (eq (caadr ptr) t)
+ (setq old-bul (cdr ptr)))))
+ (setq ptr (cdr ptr)))
+ (unless (cdr ptr)
+ (message "combine-change-calls: buffer-undo-list broken"))
+ (setcdr ptr nil)
+ (push ap-elt buffer-undo-list)
+ (setcdr buffer-undo-list old-bul)))))
+ (if (not inhibit-modification-hooks)
+ (run-hook-with-args 'after-change-functions
+ beg (marker-position end-marker)
+ (- end beg)))))
+ (set-marker end-marker nil)
+ result))
+
+(defmacro combine-change-calls (beg end &rest body)
+ "Evaluate BODY, running the change hooks just once.
+
+BODY is a sequence of lisp forms to evaluate. BEG and END bound
+the region the change hooks will be run for.
+
+Firstly, `before-change-functions' is invoked for the region
+\(BEG END), then the BODY forms are evaluated with
+`before-change-functions' and `after-change-functions' bound to
+nil, and finally `after-change-functions' is invoked on the
+updated region. The change hooks are not run if
+`inhibit-modification-hooks' is initially non-nil.
+
+The result of `combine-change-calls' is the value returned by the
+last of the BODY forms to be evaluated. BODY may not make a
+different buffer current, except temporarily. BODY may not
+change the buffer outside the specified region. It must not
+change `before-change-functions' or `after-change-functions'.
+
+Additionally, the buffer modifications of BODY are recorded on
+the buffer's undo list as a single \(apply ...) entry containing
+the function `undo--wrap-and-run-primitive-undo'. "
+ `(combine-change-calls-1 ,beg ,end (lambda () ,@body)))
+
+(defun undo--wrap-and-run-primitive-undo (beg end list)
+ "Call `primitive-undo' on the undo elements in LIST.
+
+This function is intended to be called purely by `undo' as the
+function in an \(apply DELTA BEG END FUNNAME . ARGS) undo
+element. It invokes `before-change-functions' and
+`after-change-functions' once each for the entire region \(BEG
+END) rather than once for each individual change.
+
+Additionally the fresh \"redo\" elements which are generated on
+`buffer-undo-list' will themselves be \"enclosed\" in
+`undo--wrap-and-run-primitive-undo'.
+
+Undo elements of this form are generated by the macro
+`combine-change-calls'."
+ (combine-change-calls beg end
+ (while list
+ (setq list (primitive-undo 1 list)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
(defmacro with-case-table (table &rest body)
"Execute the forms in BODY with TABLE as the current case table.
The value returned is the value of the last form in BODY."
@@ -4254,14 +4481,24 @@ to `display-warning'."
(defun add-to-invisibility-spec (element)
"Add ELEMENT to `buffer-invisibility-spec'.
See documentation for `buffer-invisibility-spec' for the kind of elements
-that can be added."
+that can be added.
+
+If `buffer-invisibility-spec' isn't a list before calling this
+function, `buffer-invisibility-spec' will afterwards be a list
+with the value `(t ELEMENT)'. This means that if text exists
+that invisibility values that aren't either `t' or ELEMENT, that
+text will become visible."
(if (eq buffer-invisibility-spec t)
(setq buffer-invisibility-spec (list t)))
(setq buffer-invisibility-spec
(cons element buffer-invisibility-spec)))
(defun remove-from-invisibility-spec (element)
- "Remove ELEMENT from `buffer-invisibility-spec'."
+ "Remove ELEMENT from `buffer-invisibility-spec'.
+If `buffer-invisibility-spec' isn't a list before calling this
+function, it will be made into a list containing just `t' as the
+only list member. This means that if text exists with non-`t'
+invisibility values, that text will become visible."
(setq buffer-invisibility-spec
(if (consp buffer-invisibility-spec)
(delete element buffer-invisibility-spec)
@@ -4540,25 +4777,6 @@ The properties used on SYMBOL are `composefunc', `sendfunc',
(put symbol 'hookvar (or hookvar 'mail-send-hook)))
-(defun backtrace--print-frame (evald func args flags)
- "Print a trace of a single stack frame to `standard-output'.
-EVALD, FUNC, ARGS, FLAGS are as in `mapbacktrace'."
- (princ (if (plist-get flags :debug-on-exit) "* " " "))
- (cond
- ((and evald (not debugger-stack-frame-as-list))
- (prin1 func)
- (if args (prin1 args) (princ "()")))
- (t
- (prin1 (cons func args))))
- (princ "\n"))
-
-(defun backtrace ()
- "Print a trace of Lisp function calls currently active.
-Output stream used is value of `standard-output'."
- (let ((print-level (or print-level 8))
- (print-escape-control-characters t))
- (mapbacktrace #'backtrace--print-frame 'backtrace)))
-
(defun backtrace-frames (&optional base)
"Collect all frames of current backtrace into a list.
If non-nil, BASE should be a function, and frames before its
@@ -4661,8 +4879,8 @@ command is called from a keyboard macro?"
'called-interactively-p-functions
i frame nextframe)))
(pcase skip
- (`nil nil)
- (`0 t)
+ ('nil nil)
+ (0 t)
(_ (setq i (+ i skip -1)) (funcall get-next-frame)))))))
;; Now `frame' should be "the function from which we were called".
(pcase (cons frame nextframe)
@@ -4881,7 +5099,7 @@ NEW-MESSAGE, if non-nil, sets a new message for the reporter."
(enough-time-passed
;; See if enough time has passed since the last update.
(or (not update-time)
- (when (>= (float-time) update-time)
+ (when (time-less-p update-time nil)
;; Calculate time for the next update
(aset parameters 0 (+ update-time (aref parameters 5)))))))
(cond ((and min-value max-value)
@@ -4924,32 +5142,62 @@ NEW-MESSAGE, if non-nil, sets a new message for the reporter."
"Print reporter's message followed by word \"done\" in echo area."
(message "%sdone" (aref (cdr reporter) 3)))
-(defmacro dotimes-with-progress-reporter (spec message &rest body)
+(defmacro dotimes-with-progress-reporter (spec reporter-or-message &rest body)
"Loop a certain number of times and report progress in the echo area.
Evaluate BODY with VAR bound to successive integers running from
0, inclusive, to COUNT, exclusive. Then evaluate RESULT to get
the return value (nil if RESULT is omitted).
-At each iteration MESSAGE followed by progress percentage is
-printed in the echo area. After the loop is finished, MESSAGE
-followed by word \"done\" is printed. This macro is a
-convenience wrapper around `make-progress-reporter' and friends.
+REPORTER-OR-MESSAGE is a progress reporter object or a string. In the latter
+case, use this string to create a progress reporter.
-\(fn (VAR COUNT [RESULT]) MESSAGE BODY...)"
+At each iteration, print the reporter message followed by progress
+percentage in the echo area. After the loop is finished,
+print the reporter message followed by the word \"done\".
+
+This macro is a convenience wrapper around `make-progress-reporter' and friends.
+
+\(fn (VAR COUNT [RESULT]) REPORTER-OR-MESSAGE BODY...)"
(declare (indent 2) (debug ((symbolp form &optional form) form body)))
- (let ((temp (make-symbol "--dotimes-temp--"))
- (temp2 (make-symbol "--dotimes-temp2--"))
- (start 0)
- (end (nth 1 spec)))
- `(let ((,temp ,end)
- (,(car spec) ,start)
- (,temp2 (make-progress-reporter ,message ,start ,end)))
- (while (< ,(car spec) ,temp)
- ,@body
- (progress-reporter-update ,temp2
- (setq ,(car spec) (1+ ,(car spec)))))
- (progress-reporter-done ,temp2)
- nil ,@(cdr (cdr spec)))))
+ (let ((prep (make-symbol "--dotimes-prep--"))
+ (end (make-symbol "--dotimes-end--")))
+ `(let ((,prep ,reporter-or-message)
+ (,end ,(cadr spec)))
+ (when (stringp ,prep)
+ (setq ,prep (make-progress-reporter ,prep 0 ,end)))
+ (dotimes (,(car spec) ,end)
+ ,@body
+ (progress-reporter-update ,prep (1+ ,(car spec))))
+ (progress-reporter-done ,prep)
+ (or ,@(cdr (cdr spec)) nil))))
+
+(defmacro dolist-with-progress-reporter (spec reporter-or-message &rest body)
+ "Loop over a list and report progress in the echo area.
+Evaluate BODY with VAR bound to each car from LIST, in turn.
+Then evaluate RESULT to get return value, default nil.
+
+REPORTER-OR-MESSAGE is a progress reporter object or a string. In the latter
+case, use this string to create a progress reporter.
+
+At each iteration, print the reporter message followed by progress
+percentage in the echo area. After the loop is finished,
+print the reporter message followed by the word \"done\".
+
+\(fn (VAR LIST [RESULT]) REPORTER-OR-MESSAGE BODY...)"
+ (declare (indent 2) (debug ((symbolp form &optional form) form body)))
+ (let ((prep (make-symbol "--dolist-progress-reporter--"))
+ (count (make-symbol "--dolist-count--"))
+ (list (make-symbol "--dolist-list--")))
+ `(let ((,prep ,reporter-or-message)
+ (,count 0)
+ (,list ,(cadr spec)))
+ (when (stringp ,prep)
+ (setq ,prep (make-progress-reporter ,prep 0 (1- (length ,list)))))
+ (dolist (,(car spec) ,list)
+ ,@body
+ (progress-reporter-update ,prep (setq ,count (1+ ,count))))
+ (progress-reporter-done ,prep)
+ (or ,@(cdr (cdr spec)) nil))))
;;;; Comparing version strings.
@@ -5264,5 +5512,26 @@ This function is called from lisp/Makefile and leim/Makefile."
(setq file (concat (substring file 1 2) ":" (substring file 2))))
file)
+(defun flatten-tree (tree)
+ "Return a \"flattened\" copy of TREE.
+In other words, return a list of the non-nil terminal nodes, or
+leaves, of the tree of cons cells rooted at TREE. Leaves in the
+returned list are in the same order as in TREE.
+
+\(flatten-tree \\='(1 (2 . 3) nil (4 5 (6)) 7))
+=> (1 2 3 4 5 6 7)"
+ (let (elems)
+ (while (consp tree)
+ (let ((elem (pop tree)))
+ (while (consp elem)
+ (push (cdr elem) tree)
+ (setq elem (car elem)))
+ (if elem (push elem elems))))
+ (if tree (push tree elems))
+ (nreverse elems)))
+
+;; Technically, `flatten-list' is a misnomer, but we provide it here
+;; for discoverability:
+(defalias 'flatten-list 'flatten-tree)
;;; subr.el ends here
diff --git a/lisp/svg.el b/lisp/svg.el
index 3384f1dbc02..291b9a11d99 100644
--- a/lisp/svg.el
+++ b/lisp/svg.el
@@ -157,7 +157,27 @@ otherwise. IMAGE-TYPE should be a MIME image type, like
(dom-node
'text
`(,@(svg--arguments svg args))
- text)))
+ (svg--encode-text text))))
+
+(defun svg--encode-text (text)
+ ;; Apparently the SVG renderer needs to have all non-ASCII
+ ;; characters encoded, and only certain special characters.
+ (with-temp-buffer
+ (insert text)
+ (dolist (substitution '(("&" . "&amp;")
+ ("<" . "&lt;")
+ (">" . "&gt;")))
+ (goto-char (point-min))
+ (while (search-forward (car substitution) nil t)
+ (replace-match (cdr substitution) t t nil)))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (let ((char (following-char)))
+ (if (< char 128)
+ (forward-char 1)
+ (delete-char 1)
+ (insert "&#" (format "%d" char) ";"))))
+ (buffer-string)))
(defun svg--append (svg node)
(let ((old (and (dom-attr node 'id)
diff --git a/lisp/t-mouse.el b/lisp/t-mouse.el
index bf668c385ad..14b292d4414 100644
--- a/lisp/t-mouse.el
+++ b/lisp/t-mouse.el
@@ -67,9 +67,6 @@
;;;###autoload
(define-minor-mode gpm-mouse-mode
"Toggle mouse support in GNU/Linux consoles (GPM Mouse mode).
-With a prefix argument ARG, enable GPM Mouse mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
This allows the use of the mouse when operating on a GNU/Linux console,
in the same way as you can use the mouse under X11.
diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el
index a73fa917e4b..599da9ac807 100644
--- a/lisp/tar-mode.el
+++ b/lisp/tar-mode.el
@@ -95,6 +95,7 @@
;;; Code:
(eval-when-compile (require 'cl-lib))
+(require 'arc-mode)
(defgroup tar nil
"Simple editing of tar files."
@@ -265,11 +266,10 @@ write-date, checksum, link-type, and link-name."
(setq name (concat (substring string tar-prefix-offset
(1- (match-end 0)))
"/" name)))
- (if (default-value 'enable-multibyte-characters)
- (setq name
- (decode-coding-string name coding)
- linkname
- (decode-coding-string linkname coding)))
+ (setq name
+ (decode-coding-string name coding)
+ linkname
+ (decode-coding-string linkname coding))
(if (and (null link-p) (string-match "/\\'" name))
(setq link-p 5)) ; directory
@@ -305,7 +305,7 @@ write-date, checksum, link-type, and link-name."
(tar-parse-octal-integer string tar-uid-offset tar-gid-offset)
(tar-parse-octal-integer string tar-gid-offset tar-size-offset)
(tar-parse-octal-integer string tar-size-offset tar-time-offset)
- (tar-parse-octal-long-integer string tar-time-offset tar-chk-offset)
+ (tar-parse-octal-integer string tar-time-offset tar-chk-offset)
(tar-parse-octal-integer string tar-chk-offset tar-linkp-offset)
link-p
linkname
@@ -343,20 +343,8 @@ write-date, checksum, link-type, and link-name."
start (1+ start)))
n)))
-(defun tar-parse-octal-long-integer (string &optional start end)
- (if (null start) (setq start 0))
- (if (null end) (setq end (length string)))
- (if (= (aref string start) 0)
- (list 0 0)
- (let ((lo 0)
- (hi 0))
- (while (< start end)
- (if (>= (aref string start) ?0)
- (setq lo (+ (* lo 8) (- (aref string start) ?0))
- hi (+ (* hi 8) (ash lo -16))
- lo (logand lo 65535)))
- (setq start (1+ start)))
- (list hi lo))))
+(define-obsolete-function-alias 'tar-parse-octal-long-integer
+ 'tar-parse-octal-integer "27.1")
(defun tar-parse-octal-integer-safe (string)
(if (zerop (length string)) (error "empty string"))
@@ -596,7 +584,7 @@ MODE should be an integer which is a file mode value."
(progress-reporter-done progress-reporter)
(message "Warning: premature EOF parsing tar file"))
(goto-char (point-min))
- (let ((buffer-file-truename nil) ; avoid changing dir mtime by lock_file
+ (let ((create-lockfiles nil) ; avoid changing dir mtime by lock_file
(inhibit-read-only t)
(total-summaries
(mapconcat 'tar-header-block-summarize tar-parse-info "\n")))
@@ -763,12 +751,10 @@ See also: variables `tar-update-datestamp' and `tar-anal-blocksize'.
(define-minor-mode tar-subfile-mode
"Minor mode for editing an element of a tar-file.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil. This mode arranges for \"saving\" this
-buffer to write the data into the tar-file buffer that it came
-from. The changes will actually appear on disk when you save the
-tar-file's buffer."
+
+This mode arranges for \"saving\" this buffer to write the data
+into the tar-file buffer that it came from. The changes will
+actually appear on disk when you save the tar-file's buffer."
;; Don't do this, because it is redundant and wastes mode line space.
;; :lighter " TarFile"
nil nil nil
@@ -907,8 +893,7 @@ tar-file's buffer."
(if (or (not coding)
(eq (coding-system-type coding) 'undecided))
(setq coding (detect-coding-region start end t)))
- (if (and (default-value 'enable-multibyte-characters)
- (coding-system-get coding :for-unibyte))
+ (if (coding-system-get coding :for-unibyte)
(with-current-buffer buffer
(set-buffer-multibyte nil)))
(widen)
@@ -947,6 +932,7 @@ tar-file's buffer."
(setq buffer-file-name new-buffer-file-name)
(setq buffer-file-truename
(abbreviate-file-name buffer-file-name))
+ (archive-try-jka-compr) ;Pretty ugly hack :-(
;; Force buffer-file-coding-system to what
;; decode-coding-region actually used.
(set-buffer-file-coding-system last-coding-system-used t)
@@ -1280,14 +1266,8 @@ for this to be permanent."
(defun tar-octal-time (timeval)
- ;; Format a timestamp as 11 octal digits. Ghod, I hope this works...
- (let ((hibits (car timeval)) (lobits (car (cdr timeval))))
- (format "%05o%01o%05o"
- (lsh hibits -2)
- (logior (lsh (logand 3 hibits) 1)
- (if (> (logand lobits 32768) 0) 1 0))
- (logand 32767 lobits)
- )))
+ ;; Format a timestamp as 11 octal digits.
+ (format "%011o" (encode-time timeval 'integer)))
(defun tar-subfile-save-buffer ()
"In tar subfile mode, save this buffer into its parent tar-file buffer.
diff --git a/lisp/term.el b/lisp/term.el
index cbef68dc0ac..586a887a29f 100644
--- a/lisp/term.el
+++ b/lisp/term.el
@@ -1,4 +1,4 @@
-;;; term.el --- general command interpreter in a window stuff
+;;; term.el --- general command interpreter in a window stuff -*- lexical-binding: t -*-
;; Copyright (C) 1988, 1990, 1992, 1994-1995, 2001-2019 Free Software
;; Foundation, Inc.
@@ -101,12 +101,8 @@
;; ----------------------------------------
;;
;;
-;; ANSI colorization should work well, I've decided to limit the interpreter
-;; to five outstanding commands (like ESC [ 01;04;32;41;07m.
-;; You shouldn't need more, if you do, tell me and I'll increase it. It's
-;; so easy you could do it yourself...
-;;
-;; Blink, is not supported. Currently it's mapped as bold.
+;; ANSI colorization should work well. Blink, is not supported.
+;; Currently it's mapped as bold.
;;
;; ----------------------------------------
;;
@@ -288,17 +284,6 @@
;; merge them into the master source.
;; - Per Bothner (bothner@cygnus.com)
-;; This file defines a general command-interpreter-in-a-buffer package
-;; (term mode). The idea is that you can build specific process-in-a-buffer
-;; modes on top of term mode -- e.g., lisp, shell, scheme, T, soar, ....
-;; This way, all these specific packages share a common base functionality,
-;; and a common set of bindings, which makes them easier to use (and
-;; saves code, implementation time, etc., etc.).
-
-;; For hints on converting existing process modes (e.g., tex-mode,
-;; background, dbx, gdb, kermit, prolog, telnet) to use term-mode
-;; instead of shell-mode, see the notes at the end of this file.
-
;; Brief Command Documentation:
;;============================================================================
@@ -396,28 +381,23 @@ contains saved term-home-marker from original sub-buffer.")
"Current vertical row (relative to home-marker) or nil if unknown.")
(defvar term-insert-mode nil)
(defvar term-vertical-motion)
-(defvar term-terminal-state 0
- "State of the terminal emulator:
-state 0: Normal state
-state 1: Last character was a graphic in the last column.
+(defvar term-do-line-wrapping nil
+ "Last character was a graphic in the last column.
If next char is graphic, first move one column right
\(and line warp) before displaying it.
-This emulates (more or less) the behavior of xterm.
-state 2: seen ESC
-state 3: seen ESC [ (or ESC [ ?)
-state 4: term-terminal-parameter contains pending output.")
+This emulates (more or less) the behavior of xterm.")
(defvar term-kill-echo-list nil
"A queue of strings whose echo we want suppressed.")
-(defvar term-terminal-parameter)
(defvar term-terminal-undecoded-bytes nil)
-(defvar term-terminal-previous-parameter)
(defvar term-current-face 'term)
(defvar term-scroll-start 0 "Top-most line (inclusive) of scrolling region.")
(defvar term-scroll-end) ; Number of line (zero-based) after scrolling region.
(defvar term-pager-count nil
"Number of lines before we need to page; if nil, paging is disabled.")
(defvar term-saved-cursor nil)
-(defvar term-command-hook)
+(define-obsolete-variable-alias 'term-command-hook
+ 'term-command-function "27.1")
+(defvar term-command-function #'term-command-hook)
(defvar term-log-buffer nil)
(defvar term-scroll-with-delete nil
"If t, forward scrolling should be implemented by delete to
@@ -556,6 +536,8 @@ This means text can automatically reflow if the window is resized."
:version "24.4"
:type 'boolean
:group 'term)
+(make-obsolete-variable 'term-suppress-hard-newline nil
+ "27.1")
;; Where gud-display-frame should put the debugging arrow. This is
;; set by the marker-filter, which scans the debugger's output for
@@ -590,16 +572,13 @@ These functions get one argument, a string containing the text to send.
This variable is buffer-local.")
-(defvar term-input-sender (function term-simple-send)
+(defvar term-input-sender #'term-simple-send
"Function to actually send to PROCESS the STRING submitted by user.
Usually this is just `term-simple-send', but if your mode needs to
massage the input string, this is your hook. This is called from
the user command `term-send-input'. `term-simple-send' just sends
the string plus a newline.")
-(defvar term-partial-ansi-terminal-message nil
- "Keep partial ansi terminal messages for future processing.")
-
(defcustom term-eol-on-send t
"Non-nil means go to the end of the line before sending input.
See `term-send-input'."
@@ -757,12 +736,6 @@ Buffer local variable.")
(defvar term-ansi-current-reverse nil)
(defvar term-ansi-current-invisible nil)
-;; Four should be enough, if you want more, just add. -mm
-(defvar term-terminal-more-parameters 0)
-(defvar term-terminal-previous-parameter-2 -1)
-(defvar term-terminal-previous-parameter-3 -1)
-(defvar term-terminal-previous-parameter-4 -1)
-
;;; Faces
(defvar ansi-term-color-vector
[term
@@ -1056,8 +1029,6 @@ Entry to this mode runs the hooks on `term-mode-hook'."
(set (make-local-variable 'term-last-input-start) (make-marker))
(set (make-local-variable 'term-last-input-end) (make-marker))
(set (make-local-variable 'term-last-input-match) "")
- (set (make-local-variable 'term-command-hook)
- (symbol-function 'term-command-hook))
;; These local variables are set to their local values:
(make-local-variable 'term-saved-home-marker)
@@ -1084,8 +1055,6 @@ Entry to this mode runs the hooks on `term-mode-hook'."
(make-local-variable 'ange-ftp-default-password)
(make-local-variable 'ange-ftp-generate-anonymous-password)
- (make-local-variable 'term-partial-ansi-terminal-message)
-
;; You may want to have different scroll-back sizes -mm
(make-local-variable 'term-buffer-maximum-size)
@@ -1098,15 +1067,9 @@ Entry to this mode runs the hooks on `term-mode-hook'."
(make-local-variable 'term-ansi-current-reverse)
(make-local-variable 'term-ansi-current-invisible)
- (make-local-variable 'term-terminal-parameter)
(make-local-variable 'term-terminal-undecoded-bytes)
- (make-local-variable 'term-terminal-previous-parameter)
- (make-local-variable 'term-terminal-previous-parameter-2)
- (make-local-variable 'term-terminal-previous-parameter-3)
- (make-local-variable 'term-terminal-previous-parameter-4)
- (make-local-variable 'term-terminal-more-parameters)
- (make-local-variable 'term-terminal-state)
+ (make-local-variable 'term-do-line-wrapping)
(make-local-variable 'term-kill-echo-list)
(make-local-variable 'term-start-line-column)
(make-local-variable 'term-current-column)
@@ -1119,21 +1082,18 @@ Entry to this mode runs the hooks on `term-mode-hook'."
(make-local-variable 'term-pager-old-local-map)
(make-local-variable 'term-old-mode-map)
(make-local-variable 'term-insert-mode)
- (make-local-variable 'term-dynamic-complete-functions)
(make-local-variable 'term-completion-fignore)
(make-local-variable 'term-get-old-input)
(make-local-variable 'term-matching-input-from-input-string)
(make-local-variable 'term-input-autoexpand)
(make-local-variable 'term-input-ignoredups)
(make-local-variable 'term-delimiter-argument-list)
- (make-local-variable 'term-input-filter-functions)
(make-local-variable 'term-input-filter)
(make-local-variable 'term-input-sender)
(make-local-variable 'term-eol-on-send)
(make-local-variable 'term-scroll-to-bottom-on-output)
(make-local-variable 'term-scroll-show-maximum-output)
(make-local-variable 'term-ptyp)
- (make-local-variable 'term-exec-hook)
(set (make-local-variable 'term-vertical-motion) 'vertical-motion)
(set (make-local-variable 'term-pending-delete-marker) (make-marker))
(make-local-variable 'term-current-face)
@@ -1145,6 +1105,9 @@ Entry to this mode runs the hooks on `term-mode-hook'."
(set (make-local-variable 'font-lock-defaults) '(nil t))
(add-function :filter-return
+ (local 'filter-buffer-substring-function)
+ #'term--filter-buffer-substring)
+ (add-function :filter-return
(local 'window-adjust-process-window-size-function)
(lambda (size)
(when size
@@ -1160,9 +1123,51 @@ Entry to this mode runs the hooks on `term-mode-hook'."
(setq term-input-ring (make-ring term-input-ring-size)))
(term-update-mode-line))
+(defun term--remove-fake-newlines ()
+ (goto-char (point-min))
+ (let (fake-newline)
+ (while (setq fake-newline (next-single-property-change (point)
+ 'term-line-wrap))
+ (goto-char fake-newline)
+ (cl-assert (eq ?\n (char-after)))
+ (let ((inhibit-read-only t))
+ (delete-char 1)))))
+
+(defun term--filter-buffer-substring (content)
+ (with-temp-buffer
+ (insert content)
+ (term--remove-fake-newlines)
+ (buffer-string)))
+
+(defun term--unwrap-visible-long-lines (width)
+ ;; Unwrap lines longer than width using fake newlines. Only do it
+ ;; for lines that are currently visible (i.e. following the home
+ ;; marker). Invisible lines don't have to be unwrapped since they
+ ;; are unreachable using the cursor movement anyway. Not having to
+ ;; unwrap the entire buffer means the runtime of this function is
+ ;; bounded by the size of the screen instead of the buffer size.
+
+ (save-excursion
+ ;; We will just assume that our accounting for the home marker is
+ ;; correct, i.e. programs will not try to reach any position
+ ;; earlier than this marker.
+ (goto-char term-home-marker)
+
+ (move-to-column width)
+ (while (not (eobp))
+ (if (eolp)
+ (forward-char)
+ (let ((inhibit-read-only t))
+ (term-unwrap-line)))
+ (move-to-column width))))
+
(defun term-reset-size (height width)
(when (or (/= height term-height)
(/= width term-width))
+ ;; Delete all newlines used for wrapping
+ (when (/= width term-width)
+ (save-excursion
+ (term--remove-fake-newlines)))
(let ((point (point)))
(setq term-height height)
(setq term-width width)
@@ -1175,7 +1180,8 @@ Entry to this mode runs the hooks on `term-mode-hook'."
(setq term-start-line-column nil)
(setq term-current-row nil)
(setq term-current-column nil)
- (goto-char point))))
+ (goto-char point))
+ (term--unwrap-visible-long-lines width)))
;; Recursive routine used to check if any string in term-kill-echo-list
;; matches part of the buffer before point.
@@ -1308,16 +1314,14 @@ intervention from Emacs, except for the escape character (usually C-c)."
(add-hook 'post-command-hook #'term-goto-process-mark-maybe nil t)
;; Send existing partial line to inferior (without newline).
- (let ((pmark (process-mark (get-buffer-process (current-buffer))))
- (save-input-sender term-input-sender))
+ (let ((pmark (process-mark (get-buffer-process (current-buffer)))))
(when (> (point) pmark)
(unwind-protect
(progn
- (setq term-input-sender
- (symbol-function 'term-send-string))
+ (add-function :override term-input-sender #'term-send-string)
(end-of-line)
(term-send-input))
- (setq term-input-sender save-input-sender))))
+ (remove-function term-input-sender #'term-send-string))))
(term-update-mode-line)))
(defun term-line-mode ()
@@ -1447,8 +1451,8 @@ buffer. The hook `term-exec-hook' is run after each exec."
;; Jump to the end, and set the process mark.
(goto-char (point-max))
(set-marker (process-mark proc) (point))
- (set-process-filter proc 'term-emulate-terminal)
- (set-process-sentinel proc 'term-sentinel)
+ (set-process-filter proc #'term-emulate-terminal)
+ (set-process-sentinel proc #'term-sentinel)
;; Feed it the startfile.
(when startfile
;;This is guaranteed to wait long enough
@@ -1577,7 +1581,7 @@ Nil if unknown.")
(when (term--bash-needs-EMACSp)
(push (format "EMACS=%s (term:%s)" emacs-version term-protocol-version)
process-environment))
- (apply 'start-process name buffer
+ (apply #'start-process name buffer
"/bin/sh" "-c"
(format "stty -nl echo rows %d columns %d sane 2>/dev/null;\
if [ $1 = .. ]; then shift; fi; exec \"$@\""
@@ -1980,8 +1984,8 @@ A useful command to bind to SPC. See `term-replace-by-expanded-history'."
(defun term-within-quotes (beg end)
"Return t if the number of quotes between BEG and END is odd.
Quotes are single and double."
- (let ((countsq (term-how-many-region "\\(^\\|[^\\\\]\\)'" beg end))
- (countdq (term-how-many-region "\\(^\\|[^\\\\]\\)\"" beg end)))
+ (let ((countsq (term-how-many-region "\\(^\\|[^\\]\\)'" beg end))
+ (countdq (term-how-many-region "\\(^\\|[^\\]\\)\"" beg end)))
(or (= (mod countsq 2) 1) (= (mod countdq 2) 1))))
(defun term-how-many-region (regexp beg end)
@@ -2071,7 +2075,7 @@ Argument 0 is the command name."
(let ((n (or nth (1- count)))
(m (if mth (1- (- count mth)) 0)))
(mapconcat
- (function (lambda (a) a)) (nthcdr n (nreverse (nthcdr m args))) " "))))
+ #'identity (nthcdr n (nreverse (nthcdr m args))) " "))))
;;;
;;; Input processing stuff [line mode]
@@ -2151,10 +2155,7 @@ Similarly for Soar, Scheme, etc."
(not (string-equal (ring-ref term-input-ring 0)
history))))
(ring-insert term-input-ring history))
- (let ((functions term-input-filter-functions))
- (while functions
- (funcall (car functions) (concat input "\n"))
- (setq functions (cdr functions))))
+ (run-hook-with-args 'term-input-filter-functions (concat input "\n"))
(setq term-input-ring-index nil)
;; Update the markers before we send the input
@@ -2244,6 +2245,7 @@ filter and C-g is pressed, this function returns nil rather than a string).
Note that the keystrokes comprising the text can still be recovered
\(temporarily) with \\[view-lossage]. This may be a security bug for some
applications."
+ (declare (obsolete read-passwd "27.1"))
(let ((ans "")
(c 0)
(echo-keystrokes 0)
@@ -2703,10 +2705,8 @@ See `term-prompt-regexp'."
(cond (term-current-column)
((setq term-current-column (current-column)))))
-;; Move DELTA column right (or left if delta < 0 limiting at column 0).
-
-(defun term-move-columns (delta)
- (setq term-current-column (max 0 (+ (term-current-column) delta)))
+(defun term-move-to-column (column)
+ (setq term-current-column column)
(let ((point-at-eol (line-end-position)))
(move-to-column term-current-column t)
;; If move-to-column extends the current line it will use the face
@@ -2715,6 +2715,11 @@ See `term-prompt-regexp'."
(when (> (point) point-at-eol)
(put-text-property point-at-eol (point) 'font-lock-face 'default))))
+;; Move DELTA column right (or left if delta < 0 limiting at column 0).
+(defun term-move-columns (delta)
+ (term-move-to-column
+ (max 0 (+ (term-current-column) delta))))
+
;; Insert COUNT copies of CHAR in the default face.
(defun term-insert-char (char count)
(let ((old-point (point)))
@@ -2747,11 +2752,6 @@ See `term-prompt-regexp'."
;;difference ;-) -mm
(defun term-handle-ansi-terminal-messages (message)
- ;; Handle stored partial message
- (when term-partial-ansi-terminal-message
- (setq message (concat term-partial-ansi-terminal-message message))
- (setq term-partial-ansi-terminal-message nil))
-
;; Is there a command here?
(while (string-match "\eAnSiT.+\n" message)
;; Extract the command code and the argument.
@@ -2802,11 +2802,6 @@ See `term-prompt-regexp'."
(setq ange-ftp-default-user nil)
(setq ange-ftp-default-password nil)
(setq ange-ftp-generate-anonymous-password nil)))))
- ;; If there is a partial message at the end of the string, store it
- ;; for future use.
- (when (string-match "\eAnSiT.+$" message)
- (setq term-partial-ansi-terminal-message (match-string 0 message))
- (setq message (replace-match "" t t message)))
message)
@@ -2814,27 +2809,42 @@ See `term-prompt-regexp'."
;; This is the standard process filter for term buffers.
;; It emulates (most of the features of) a VT100/ANSI-style terminal.
+;; References:
+;; [ctlseqs]: http://invisible-island.net/xterm/ctlseqs/ctlseqs.html
+;; [ECMA-48]: http://www.ecma-international.org/publications/standards/Ecma-048.htm
+;; [vt100]: https://vt100.net/docs/vt100-ug/chapter3.html
+
+(defconst term-control-seq-regexp
+ (concat
+ ;; A control character,
+ "\\(?:[\r\n\000\007\t\b\016\017]\\|"
+ ;; some Emacs specific control sequences, implemented by
+ ;; `term-command-hook',
+ "\032[^\n]+\r?\n\\|"
+ ;; a C1 escape coded character (see [ECMA-48] section 5.3 "Elements
+ ;; of the C1 set"),
+ "\e\\(?:[DM78c]\\|"
+ ;; another Emacs specific control sequence,
+ "AnSiT[^\n]+\r?\n\\|"
+ ;; or an escape sequence (section 5.4 "Control Sequences"),
+ "\\[\\([\x30-\x3F]*\\)[\x20-\x2F]*[\x40-\x7E]\\)\\)")
+ "Regexp matching control sequences handled by term.el.")
+
+(defconst term-control-seq-prefix-regexp
+ "[\032\e]")
+
(defun term-emulate-terminal (proc str)
(with-current-buffer (process-buffer proc)
- (let* ((i 0) char funny
- count ; number of decoded chars in substring
- count-bytes ; number of bytes
+ (let* ((i 0) funny
decoded-substring
- save-point save-marker old-point temp win
+ save-point save-marker win
(inhibit-read-only t)
(buffer-undo-list t)
(selected (selected-window))
last-win
- handled-ansi-message
(str-length (length str)))
(save-selected-window
- (let ((newstr (term-handle-ansi-terminal-messages str)))
- (unless (eq str newstr)
- (setq handled-ansi-message t
- str newstr)))
- (setq str-length (length str))
-
(when (marker-buffer term-pending-delete-marker)
;; Delete text following term-pending-delete-marker.
(delete-region term-pending-delete-marker (process-mark proc))
@@ -2864,298 +2874,223 @@ See `term-prompt-regexp'."
(setq str (concat term-terminal-undecoded-bytes str))
(setq str-length (length str))
(setq term-terminal-undecoded-bytes nil))
- (cond ((eq term-terminal-state 4) ;; Have saved pending output.
- (setq str (concat term-terminal-parameter str))
- (setq term-terminal-parameter nil)
- (setq str-length (length str))
- (setq term-terminal-state 0)))
-
- (while (< i str-length)
- (setq char (aref str i))
- (cond ((< term-terminal-state 2)
- ;; Look for prefix of regular chars
- (setq funny
- (string-match "[\r\n\000\007\033\t\b\032\016\017]"
- str i))
- (when (not funny) (setq funny str-length))
- (cond ((> funny i)
- (cond ((eq term-terminal-state 1)
- ;; We are in state 1, we need to wrap
- ;; around. Go to the beginning of
- ;; the next line and switch to state
- ;; 0.
- (term-down 1 t)
- (term-move-columns (- (term-current-column)))
- (setq term-terminal-state 0)))
- ;; Decode the string before counting
- ;; characters, to avoid garbling of certain
- ;; multibyte characters (bug#1006).
- (setq decoded-substring
- (decode-coding-string
- (substring str i funny)
- locale-coding-system))
- (setq count (length decoded-substring))
- ;; Check for multibyte characters that ends
- ;; before end of string, and save it for
- ;; next time.
- (when (= funny str-length)
- (let ((partial 0))
- (while (eq (char-charset (aref decoded-substring
- (- count 1 partial)))
- 'eight-bit)
- (cl-incf partial))
- (when (> partial 0)
- (setq term-terminal-undecoded-bytes
- (substring decoded-substring (- partial)))
- (setq decoded-substring
- (substring decoded-substring 0 (- partial)))
- (cl-decf str-length partial)
- (cl-decf count partial)
- (cl-decf funny partial))))
- (setq temp (- (+ (term-horizontal-column) count)
- term-width))
- (cond ((or term-suppress-hard-newline (<= temp 0)))
- ;; All count chars fit in line.
- ((> count temp) ;; Some chars fit.
- ;; This iteration, handle only what fits.
- (setq count (- count temp))
- (setq count-bytes
- (length
- (encode-coding-string
- (substring decoded-substring 0 count)
- 'binary)))
- (setq temp 0)
- (setq funny (+ count-bytes i)))
- ((or (not (or term-pager-count
- term-scroll-with-delete))
- (> (term-handle-scroll 1) 0))
- (term-adjust-current-row-cache 1)
- (setq count (min count term-width))
- (setq count-bytes
- (length
- (encode-coding-string
- (substring decoded-substring 0 count)
- 'binary)))
- (setq funny (+ count-bytes i))
- (setq term-start-line-column
- term-current-column))
- (t ;; Doing PAGER processing.
- (setq count 0 funny i)
- (setq term-current-column nil)
- (setq term-start-line-column nil)))
- (setq old-point (point))
-
- ;; Insert a string, check how many columns
- ;; we moved, then delete that many columns
- ;; following point if not eob nor insert-mode.
- (let ((old-column (current-column))
- columns pos)
- (insert (decode-coding-string (substring str i funny) locale-coding-system))
- (setq term-current-column (current-column)
- columns (- term-current-column old-column))
- (when (not (or (eobp) term-insert-mode))
- (setq pos (point))
- (term-move-columns columns)
- (delete-region pos (point)))
- ;; In insert mode if the current line
- ;; has become too long it needs to be
- ;; chopped off.
- (when term-insert-mode
- (setq pos (point))
- (end-of-line)
- (when (> (current-column) term-width)
- (delete-region (- (point) (- (current-column) term-width))
- (point)))
- (goto-char pos)))
- (setq term-current-column nil)
-
- (put-text-property old-point (point)
- 'font-lock-face term-current-face)
- ;; If the last char was written in last column,
- ;; back up one column, but remember we did so.
- ;; Thus we emulate xterm/vt100-style line-wrapping.
- (cond ((eq temp 0)
- (term-move-columns -1)
- (setq term-terminal-state 1)))
- (setq i (1- funny)))
- ((and (setq term-terminal-state 0)
- (eq char ?\^I)) ; TAB (terminfo: ht)
- (setq count (term-current-column))
- ;; The line cannot exceed term-width. TAB at
- ;; the end of a line should not cause wrapping.
- (setq count (min term-width
- (+ count 8 (- (mod count 8)))))
- (if (> term-width count)
- (progn
- (term-move-columns
- (- count (term-current-column)))
- (setq term-current-column count))
- (when (> term-width (term-current-column))
- (term-move-columns
- (1- (- term-width (term-current-column)))))
- (when (= term-width (term-current-column))
- (term-move-columns -1))))
- ((eq char ?\r) ;; (terminfo: cr)
- (term-vertical-motion 0)
- (setq term-current-column term-start-line-column))
- ((eq char ?\n) ;; (terminfo: cud1, ind)
- (unless (and term-kill-echo-list
- (term-check-kill-echo-list))
- (term-down 1 t)))
- ((eq char ?\b) ;; (terminfo: cub1)
- (term-move-columns -1))
- ((eq char ?\033) ; Escape
- (setq term-terminal-state 2))
- ((eq char 0)) ; NUL: Do nothing
- ((eq char ?\016)) ; Shift Out - ignored
- ((eq char ?\017)) ; Shift In - ignored
- ((eq char ?\^G) ;; (terminfo: bel)
- (beep t))
- ((eq char ?\032)
- (let ((end (string-match "\r?\n" str i)))
- (if end
- (progn
- (unless handled-ansi-message
- (funcall term-command-hook
- (decode-coding-string
- (substring str (1+ i) end)
- locale-coding-system)))
- (setq i (1- (match-end 0))))
- (setq term-terminal-parameter (substring str i))
- (setq term-terminal-state 4)
- (setq i str-length))))
- (t ; insert char FIXME: Should never happen
- (term-move-columns 1)
- (backward-delete-char 1)
- (insert char))))
- ((eq term-terminal-state 2) ; Seen Esc
- (cond ((eq char ?\133) ;; ?\133 = ?[
-
- ;; Some modifications to cope with multiple
- ;; settings like ^[[01;32;43m -mm
- ;; Note that now the init value of
- ;; term-terminal-previous-parameter has been
- ;; changed to -1
-
- (setq term-terminal-parameter 0)
- (setq term-terminal-previous-parameter -1)
- (setq term-terminal-previous-parameter-2 -1)
- (setq term-terminal-previous-parameter-3 -1)
- (setq term-terminal-previous-parameter-4 -1)
- (setq term-terminal-more-parameters 0)
- (setq term-terminal-state 3))
- ((eq char ?D) ;; scroll forward
- (term-handle-deferred-scroll)
- (term-down 1 t)
- (setq term-terminal-state 0))
- ;; ((eq char ?E) ;; (terminfo: nw), not used for
- ;; ;; now, but this is a working
- ;; ;; implementation
- ;; (term-down 1)
- ;; (term-goto term-current-row 0)
- ;; (setq term-terminal-state 0))
- ((eq char ?M) ;; scroll reversed (terminfo: ri)
- (if (or (< (term-current-row) term-scroll-start)
- (>= (1- (term-current-row))
- term-scroll-start))
- ;; Scrolling up will not move outside
- ;; the scroll region.
- (term-down -1)
- ;; Scrolling the scroll region is needed.
- (term-down -1 t))
- (setq term-terminal-state 0))
- ((eq char ?7) ;; Save cursor (terminfo: sc)
- (term-handle-deferred-scroll)
- (setq term-saved-cursor
- (list (term-current-row)
- (term-horizontal-column)
- term-ansi-current-bg-color
- term-ansi-current-bold
- term-ansi-current-color
- term-ansi-current-invisible
- term-ansi-current-reverse
- term-ansi-current-underline
- term-current-face)
- )
- (setq term-terminal-state 0))
- ((eq char ?8) ;; Restore cursor (terminfo: rc)
- (when term-saved-cursor
- (term-goto (nth 0 term-saved-cursor)
- (nth 1 term-saved-cursor))
- (setq term-ansi-current-bg-color
- (nth 2 term-saved-cursor)
- term-ansi-current-bold
- (nth 3 term-saved-cursor)
- term-ansi-current-color
- (nth 4 term-saved-cursor)
- term-ansi-current-invisible
- (nth 5 term-saved-cursor)
- term-ansi-current-reverse
- (nth 6 term-saved-cursor)
- term-ansi-current-underline
- (nth 7 term-saved-cursor)
- term-current-face
- (nth 8 term-saved-cursor)))
- (setq term-terminal-state 0))
- ((eq char ?c) ;; \Ec - Reset (terminfo: rs1)
- ;; This is used by the "clear" program.
- (setq term-terminal-state 0)
- (term-reset-terminal))
- ;; The \E#8 reset sequence for xterm. We
- ;; probably don't need to handle it, but this
- ;; is the code to parse it.
- ;; ((eq char ?#)
- ;; (when (eq (aref str (1+ i)) ?8)
- ;; (setq i (1+ i))
- ;; (setq term-scroll-start 0)
- ;; (setq term-scroll-end term-height)
- ;; (setq term-terminal-state 0)))
- ((setq term-terminal-state 0))))
- ((eq term-terminal-state 3) ; Seen Esc [
- (cond ((and (>= char ?0) (<= char ?9))
- (setq term-terminal-parameter
- (+ (* 10 term-terminal-parameter) (- char ?0))))
- ((eq char ?\;)
- ;; Some modifications to cope with multiple
- ;; settings like ^[[01;32;43m -mm
- (setq term-terminal-more-parameters 1)
- (setq term-terminal-previous-parameter-4
- term-terminal-previous-parameter-3)
- (setq term-terminal-previous-parameter-3
- term-terminal-previous-parameter-2)
- (setq term-terminal-previous-parameter-2
- term-terminal-previous-parameter)
- (setq term-terminal-previous-parameter
- term-terminal-parameter)
- (setq term-terminal-parameter 0))
- ((eq char ??)) ; Ignore ?
- (t
- (term-handle-ansi-escape proc char)
- (setq term-terminal-more-parameters 0)
- (setq term-terminal-previous-parameter-4 -1)
- (setq term-terminal-previous-parameter-3 -1)
- (setq term-terminal-previous-parameter-2 -1)
- (setq term-terminal-previous-parameter -1)
- (setq term-terminal-state 0)))))
- (when (term-handling-pager)
- ;; Finish stuff to get ready to handle PAGER.
- (if (> (% (current-column) term-width) 0)
- (setq term-terminal-parameter
- (substring str i))
- ;; We're at column 0. Goto end of buffer; to compensate,
- ;; prepend a ?\r for later. This looks more consistent.
- (if (zerop i)
- (setq term-terminal-parameter
- (concat "\r" (substring str i)))
- (setq term-terminal-parameter (substring str (1- i)))
- (aset term-terminal-parameter 0 ?\r))
- (goto-char (point-max)))
- (setq term-terminal-state 4)
- (make-local-variable 'term-pager-old-filter)
- (setq term-pager-old-filter (process-filter proc))
- (set-process-filter proc term-pager-filter)
- (setq i str-length))
- (setq i (1+ i))))
+
+ (while (< i str-length)
+ (setq funny (string-match term-control-seq-regexp str i))
+ (let ((ctl-params (and funny (match-string 1 str)))
+ (ctl-params-end (and funny (match-end 1)))
+ (ctl-end (if funny (match-end 0)
+ (setq funny (string-match term-control-seq-prefix-regexp str i))
+ (if funny
+ (setq term-terminal-undecoded-bytes
+ (substring str funny))
+ (setq funny str-length))
+ ;; The control sequence ends somewhere
+ ;; past the end of this string.
+ (1+ str-length))))
+ (when (> funny i)
+ (when term-do-line-wrapping
+ (term-down 1 t)
+ (term-move-to-column 0)
+ (setq term-do-line-wrapping nil))
+ ;; Handle non-control data. Decode the string before
+ ;; counting characters, to avoid garbling of certain
+ ;; multibyte characters (bug#1006).
+ (setq decoded-substring
+ (decode-coding-string
+ (substring str i funny)
+ locale-coding-system t))
+ ;; Check for multibyte characters that ends
+ ;; before end of string, and save it for
+ ;; next time.
+ (when (= funny str-length)
+ (let ((partial 0)
+ (count (length decoded-substring)))
+ (while (eq (char-charset (aref decoded-substring
+ (- count 1 partial)))
+ 'eight-bit)
+ (cl-incf partial))
+ (when (> partial 0)
+ (setq term-terminal-undecoded-bytes
+ (substring decoded-substring (- partial)))
+ (setq decoded-substring
+ (substring decoded-substring 0 (- partial)))
+ (cl-decf str-length partial)
+ (cl-decf funny partial))))
+
+ ;; Insert a string, check how many columns
+ ;; we moved, then delete that many columns
+ ;; following point if not eob nor insert-mode.
+ (let ((old-column (term-horizontal-column))
+ (old-point (point))
+ columns)
+ (unless term-suppress-hard-newline
+ (while (> (+ (length decoded-substring) old-column)
+ term-width)
+ (insert (substring decoded-substring 0
+ (- term-width old-column)))
+ ;; Since we've enough text to fill the whole line,
+ ;; delete previous text regardless of
+ ;; `term-insert-mode's value.
+ (delete-region (point) (line-end-position))
+ (term-down 1 t)
+ (term-move-columns (- (term-current-column)))
+ (put-text-property (1- (point)) (point) 'term-line-wrap t)
+ (setq decoded-substring
+ (substring decoded-substring (- term-width old-column)))
+ (setq old-column 0)))
+ (insert decoded-substring)
+ (setq term-current-column (current-column)
+ columns (- term-current-column old-column))
+ (when (not (or (eobp) term-insert-mode))
+ (let ((pos (point)))
+ (term-move-columns columns)
+ (delete-region pos (point))
+ (setq term-current-column nil)))
+ ;; In insert mode if the current line
+ ;; has become too long it needs to be
+ ;; chopped off.
+ (when term-insert-mode
+ (let ((pos (point)))
+ (end-of-line)
+ (when (> (current-column) term-width)
+ (delete-region (- (point) (- (current-column) term-width))
+ (point)))
+ (goto-char pos)))
+
+ (put-text-property old-point (point)
+ 'font-lock-face term-current-face))
+ ;; If the last char was written in last column,
+ ;; back up one column, but remember we did so.
+ ;; Thus we emulate xterm/vt100-style line-wrapping.
+ (when (eq (term-current-column) term-width)
+ (term-move-columns -1)
+ ;; We check after ctrl sequence handling if point
+ ;; was moved (and leave line-wrapping state if so).
+ (setq term-do-line-wrapping (point)))
+ (setq term-current-column nil)
+ (setq i funny))
+ (pcase-exhaustive (and (<= ctl-end str-length) (aref str i))
+ (?\t ;; TAB (terminfo: ht)
+ ;; The line cannot exceed term-width. TAB at
+ ;; the end of a line should not cause wrapping.
+ (let ((col (term-current-column)))
+ (term-move-to-column
+ (min (1- term-width)
+ (+ col 8 (- (mod col 8)))))))
+ (?\r ;; (terminfo: cr)
+ (term-vertical-motion 0)
+ (setq term-current-column term-start-line-column))
+ (?\n ;; (terminfo: cud1, ind)
+ (unless (and term-kill-echo-list
+ (term-check-kill-echo-list))
+ (term-down 1 t)))
+ (?\b ;; (terminfo: cub1)
+ (term-move-columns -1))
+ (?\C-g ;; (terminfo: bel)
+ (beep t))
+ (?\032 ; Emacs specific control sequence.
+ (funcall term-command-function
+ (decode-coding-string
+ (substring str (1+ i)
+ (- ctl-end
+ (if (eq (aref str (- ctl-end 2)) ?\r)
+ 2 1)))
+ locale-coding-system t)))
+ (?\e
+ (pcase (aref str (1+ i))
+ (?\[
+ ;; We only handle control sequences with a single
+ ;; "Final" byte (see [ECMA-48] section 5.4).
+ (when (eq ctl-params-end (1- ctl-end))
+ (term-handle-ansi-escape
+ proc
+ (mapcar ;; We don't distinguish empty params
+ ;; from 0 (according to [ECMA-48] we
+ ;; should, but all commands we support
+ ;; default to 0 values anyway).
+ #'string-to-number
+ (split-string ctl-params ";"))
+ (aref str (1- ctl-end)))))
+ (?D ;; Scroll forward (apparently not documented in
+ ;; [ECMA-48], [ctlseqs] mentions it as C1
+ ;; character "Index" though).
+ (term-handle-deferred-scroll)
+ (term-down 1 t))
+ (?M ;; Scroll reversed (terminfo: ri, ECMA-48
+ ;; "Reverse Linefeed").
+ (if (or (< (term-current-row) term-scroll-start)
+ (>= (1- (term-current-row))
+ term-scroll-start))
+ ;; Scrolling up will not move outside
+ ;; the scroll region.
+ (term-down -1)
+ ;; Scrolling the scroll region is needed.
+ (term-down -1 t)))
+ (?7 ;; Save cursor (terminfo: sc, not in [ECMA-48],
+ ;; [ctlseqs] has it as "DECSC").
+ (term-handle-deferred-scroll)
+ (setq term-saved-cursor
+ (list (term-current-row)
+ (term-horizontal-column)
+ term-ansi-current-bg-color
+ term-ansi-current-bold
+ term-ansi-current-color
+ term-ansi-current-invisible
+ term-ansi-current-reverse
+ term-ansi-current-underline
+ term-current-face)))
+ (?8 ;; Restore cursor (terminfo: rc, [ctlseqs]
+ ;; "DECRC").
+ (when term-saved-cursor
+ (term-goto (nth 0 term-saved-cursor)
+ (nth 1 term-saved-cursor))
+ (setq term-ansi-current-bg-color
+ (nth 2 term-saved-cursor)
+ term-ansi-current-bold
+ (nth 3 term-saved-cursor)
+ term-ansi-current-color
+ (nth 4 term-saved-cursor)
+ term-ansi-current-invisible
+ (nth 5 term-saved-cursor)
+ term-ansi-current-reverse
+ (nth 6 term-saved-cursor)
+ term-ansi-current-underline
+ (nth 7 term-saved-cursor)
+ term-current-face
+ (nth 8 term-saved-cursor))))
+ (?c ;; \Ec - Reset (terminfo: rs1, [ctlseqs] "RIS").
+ ;; This is used by the "clear" program.
+ (term-reset-terminal))
+ (?A ;; An \eAnSiT sequence (Emacs specific).
+ (term-handle-ansi-terminal-messages
+ (substring str i ctl-end)))))
+ ;; Ignore NUL, Shift Out, Shift In.
+ ((or ?\0 #xE #xF 'nil) nil))
+ ;; Leave line-wrapping state if point was moved.
+ (unless (eq term-do-line-wrapping (point))
+ (setq term-do-line-wrapping nil))
+ (if (term-handling-pager)
+ (progn
+ ;; Finish stuff to get ready to handle PAGER.
+ (if (> (% (current-column) term-width) 0)
+ (setq term-terminal-undecoded-bytes
+ (substring str i))
+ ;; We're at column 0. Goto end of buffer; to compensate,
+ ;; prepend a ?\r for later. This looks more consistent.
+ (if (zerop i)
+ (setq term-terminal-undecoded-bytes
+ (concat "\r" (substring str i)))
+ (setq term-terminal-undecoded-bytes (substring str (1- i)))
+ (aset term-terminal-undecoded-bytes 0 ?\r))
+ (goto-char (point-max)))
+ ;; FIXME: Use (add-function :override (process-filter proc)
+ (make-local-variable 'term-pager-old-filter)
+ (setq term-pager-old-filter (process-filter proc))
+ ;; FIXME: Where is `term-pager-filter' set to a function?!
+ (set-process-filter proc term-pager-filter)
+ (setq i str-length))
+ (setq i ctl-end)))))
(when (>= (term-current-row) term-height)
(term-handle-deferred-scroll))
@@ -3388,86 +3323,81 @@ option is enabled. See `term-set-goto-process-mark'."
;; Handle a character assuming (eq terminal-state 2) -
;; i.e. we have previously seen Escape followed by ?[.
-(defun term-handle-ansi-escape (proc char)
+(defun term-handle-ansi-escape (proc params char)
(cond
((or (eq char ?H) ;; cursor motion (terminfo: cup,home)
;; (eq char ?f) ;; xterm seems to handle this sequence too, not
;; needed for now
)
- (when (<= term-terminal-parameter 0)
- (setq term-terminal-parameter 1))
- (when (<= term-terminal-previous-parameter 0)
- (setq term-terminal-previous-parameter 1))
- (when (> term-terminal-previous-parameter term-height)
- (setq term-terminal-previous-parameter term-height))
- (when (> term-terminal-parameter term-width)
- (setq term-terminal-parameter term-width))
(term-goto
- (1- term-terminal-previous-parameter)
- (1- term-terminal-parameter)))
+ (1- (max 1 (min (or (nth 0 params) 0) term-height)))
+ (1- (max 1 (min (or (nth 1 params) 0) term-width)))))
;; \E[A - cursor up (terminfo: cuu, cuu1)
((eq char ?A)
(term-handle-deferred-scroll)
- (let ((tcr (term-current-row)))
+ (let ((tcr (term-current-row))
+ (scroll-amount (car params)))
(term-down
- (if (< (- tcr term-terminal-parameter) term-scroll-start)
+ (if (< (- tcr scroll-amount) term-scroll-start)
;; If the amount to move is before scroll start, move
;; to scroll start.
(- term-scroll-start tcr)
- (if (>= term-terminal-parameter tcr)
+ (if (>= scroll-amount tcr)
(- tcr)
- (- (max 1 term-terminal-parameter)))) t)))
+ (- (max 1 scroll-amount))))
+ t)))
;; \E[B - cursor down (terminfo: cud)
((eq char ?B)
- (let ((tcr (term-current-row)))
+ (let ((tcr (term-current-row))
+ (scroll-amount (car params)))
(unless (>= tcr term-scroll-end)
(term-down
- (min (- term-scroll-end tcr) (max 1 term-terminal-parameter))
+ (min (- term-scroll-end tcr) (max 1 scroll-amount))
t))))
;; \E[C - cursor right (terminfo: cuf, cuf1)
((eq char ?C)
(term-move-columns
(max 1
- (if (>= (+ term-terminal-parameter (term-current-column)) term-width)
+ (if (>= (+ (car params) (term-current-column)) term-width)
(- term-width (term-current-column) 1)
- term-terminal-parameter))))
+ (car params)))))
;; \E[D - cursor left (terminfo: cub)
((eq char ?D)
- (term-move-columns (- (max 1 term-terminal-parameter))))
+ (term-move-columns (- (max 1 (car params)))))
;; \E[G - cursor motion to absolute column (terminfo: hpa)
((eq char ?G)
- (term-move-columns (- (max 0 (min term-width term-terminal-parameter))
+ (term-move-columns (- (max 0 (min term-width (car params)))
(term-current-column))))
;; \E[J - clear to end of screen (terminfo: ed, clear)
((eq char ?J)
- (term-erase-in-display term-terminal-parameter))
+ (term-erase-in-display (car params)))
;; \E[K - clear to end of line (terminfo: el, el1)
((eq char ?K)
- (term-erase-in-line term-terminal-parameter))
+ (term-erase-in-line (car params)))
;; \E[L - insert lines (terminfo: il, il1)
((eq char ?L)
- (term-insert-lines (max 1 term-terminal-parameter)))
+ (term-insert-lines (max 1 (car params))))
;; \E[M - delete lines (terminfo: dl, dl1)
((eq char ?M)
- (term-delete-lines (max 1 term-terminal-parameter)))
+ (term-delete-lines (max 1 (car params))))
;; \E[P - delete chars (terminfo: dch, dch1)
((eq char ?P)
- (term-delete-chars (max 1 term-terminal-parameter)))
+ (term-delete-chars (max 1 (car params))))
;; \E[@ - insert spaces (terminfo: ich)
((eq char ?@)
- (term-insert-spaces (max 1 term-terminal-parameter)))
+ (term-insert-spaces (max 1 (car params))))
;; \E[?h - DEC Private Mode Set
((eq char ?h)
- (cond ((eq term-terminal-parameter 4) ;; (terminfo: smir)
+ (cond ((eq (car params) 4) ;; (terminfo: smir)
(setq term-insert-mode t))
- ;; ((eq term-terminal-parameter 47) ;; (terminfo: smcup)
+ ;; ((eq (car params) 47) ;; (terminfo: smcup)
;; (term-switch-to-alternate-sub-buffer t))
))
;; \E[?l - DEC Private Mode Reset
((eq char ?l)
- (cond ((eq term-terminal-parameter 4) ;; (terminfo: rmir)
+ (cond ((eq (car params) 4) ;; (terminfo: rmir)
(setq term-insert-mode nil))
- ;; ((eq term-terminal-parameter 47) ;; (terminfo: rmcup)
+ ;; ((eq (car params) 47) ;; (terminfo: rmcup)
;; (term-switch-to-alternate-sub-buffer nil))
))
@@ -3475,15 +3405,7 @@ option is enabled. See `term-set-goto-process-mark'."
;; \E[m - Set/reset modes, set bg/fg
;;(terminfo: smso,rmso,smul,rmul,rev,bold,sgr0,invis,op,setab,setaf)
((eq char ?m)
- (when (= term-terminal-more-parameters 1)
- (when (>= term-terminal-previous-parameter-4 0)
- (term-handle-colors-array term-terminal-previous-parameter-4))
- (when (>= term-terminal-previous-parameter-3 0)
- (term-handle-colors-array term-terminal-previous-parameter-3))
- (when (>= term-terminal-previous-parameter-2 0)
- (term-handle-colors-array term-terminal-previous-parameter-2))
- (term-handle-colors-array term-terminal-previous-parameter))
- (term-handle-colors-array term-terminal-parameter))
+ (mapc #'term-handle-colors-array params))
;; \E[6n - Report cursor position (terminfo: u7)
((eq char ?n)
@@ -3496,8 +3418,8 @@ option is enabled. See `term-set-goto-process-mark'."
;; \E[r - Set scrolling region (terminfo: csr)
((eq char ?r)
(term-set-scroll-region
- (1- term-terminal-previous-parameter)
- (1- term-terminal-parameter)))
+ (1- (or (nth 0 params) 0))
+ (1- (or (nth 1 params) 0))))
(t)))
(defun term-set-scroll-region (top bottom)
@@ -3547,7 +3469,7 @@ The top-most line is line 0."
;; (setq term-current-row 0)
;; (term-goto row col))))
-;; Default value for the symbol term-command-hook.
+;; Default value for the symbol term-command-function.
(defun term-command-hook (string)
(cond ((equal string "")
@@ -3685,7 +3607,7 @@ The top-most line is line 0."
(defun term-pager-discard ()
(interactive)
- (setq term-terminal-parameter "")
+ (setq term-terminal-undecoded-bytes "")
(interrupt-process nil t)
(term-pager-continue term-height))
@@ -3829,7 +3751,10 @@ all pending output has been dealt with."))
;; if the line above point wraps around, add a ?\n to undo the wrapping.
;; FIXME: Probably should be called more than it is.
(defun term-unwrap-line ()
- (when (not (bolp)) (insert-before-markers ?\n)))
+ (when (not (bolp))
+ (let ((old-point (point)))
+ (insert-before-markers ?\n)
+ (put-text-property old-point (point) 'term-line-wrap t))))
(defun term-erase-in-line (kind)
(when (= kind 1) ;; erase left of point
@@ -3863,7 +3788,7 @@ all pending output has been dealt with."))
If KIND is 0, erase from (point) to (point-max);
if KIND is 1, erase from home to point; else erase from home to point-max."
(term-handle-deferred-scroll)
- (cond ((eq term-terminal-parameter 0)
+ (cond ((eq kind 0)
(let ((need-unwrap (bolp)))
(delete-region (point) (point-max))
(when need-unwrap (term-unwrap-line))))
@@ -4098,9 +4023,7 @@ Calls the functions in `term-dynamic-complete-functions' to perform
completion until a function returns non-nil, at which point completion is
assumed to have occurred."
(interactive)
- (let ((functions term-dynamic-complete-functions))
- (while (and functions (null (funcall (car functions))))
- (setq functions (cdr functions)))))
+ (run-hook-with-args-until-success 'term-dynamic-complete-functions))
(defun term-dynamic-complete-filename ()
@@ -4200,7 +4123,6 @@ Returns `listed' if a completion listing was shown.
See also `term-dynamic-complete-filename'."
(declare (obsolete completion-in-region "23.2"))
(let* ((completion-ignore-case nil)
- (candidates (mapcar (function (lambda (x) (list x))) candidates))
(completions (all-completions stub candidates)))
(cond ((null completions)
(message "No completions of %s" stub)
@@ -4425,9 +4347,9 @@ well as the newer ports COM10 and higher."
(setq serial-name-history file-name-history))
(when (or (null x) (and (stringp x) (zerop (length x))))
(error "No serial port selected"))
- (when (and (not (serial-port-is-file-p))
- (not (string-match "\\\\" x)))
- (set 'x (concat "\\\\.\\" x)))
+ (when (not (or (serial-port-is-file-p)
+ (string-match "\\\\" x)))
+ (setq x (concat "\\\\.\\" x)))
x))
(defun serial-read-speed ()
@@ -4481,8 +4403,8 @@ use in that buffer.
(term-char-mode)
(goto-char (point-max))
(set-marker (process-mark process) (point))
- (set-process-filter process 'term-emulate-terminal)
- (set-process-sentinel process 'term-sentinel))
+ (set-process-filter process #'term-emulate-terminal)
+ (set-process-sentinel process #'term-sentinel))
(switch-to-buffer buffer)
buffer))
@@ -4619,27 +4541,19 @@ The return value may be nil for a special serial port."
;; term-mode will take care of it. The following example, from shell.el,
;; is typical:
;;
-;; (defvar shell-mode-map '())
-;; (cond ((not shell-mode-map)
-;; (setq shell-mode-map (copy-keymap term-mode-map))
-;; (define-key shell-mode-map "\C-c\C-f" 'shell-forward-command)
-;; (define-key shell-mode-map "\C-c\C-b" 'shell-backward-command)
-;; (define-key shell-mode-map "\t" 'term-dynamic-complete)
-;; (define-key shell-mode-map "\M-?"
-;; 'term-dynamic-list-filename-completions)))
-;;
-;; (defun shell-mode ()
-;; (interactive)
-;; (term-mode)
-;; (setq term-prompt-regexp shell-prompt-pattern)
-;; (setq major-mode 'shell-mode)
-;; (setq mode-name "Shell")
-;; (use-local-map shell-mode-map)
-;; (make-local-variable 'shell-directory-stack)
-;; (setq shell-directory-stack nil)
-;; (add-hook 'term-input-filter-functions 'shell-directory-tracker)
-;; (run-mode-hooks 'shell-mode-hook))
+;; (defvar shell-mode-map
+;; (let ((map (make-sparse-keymap)))
+;; (define-key map "\C-c\C-f" 'shell-forward-command)
+;; (define-key map "\C-c\C-b" 'shell-backward-command)
+;; (define-key map "\t" 'term-dynamic-complete)
+;; (define-key map "\M-?"
+;; 'term-dynamic-list-filename-completions)))
;;
+;; (define-derived-mode shell-mode term-mode "Shell"
+;; "A shell mode."
+;; (setq-local term-prompt-regexp shell-prompt-pattern)
+;; (setq-local shell-directory-stack nil)
+;; (add-hook 'term-input-filter-functions #'shell-directory-tracker nil t))
;;
;; Completion for term-mode users
;;
diff --git a/lisp/term/common-win.el b/lisp/term/common-win.el
index 4399eaed186..b7a778fc004 100644
--- a/lisp/term/common-win.el
+++ b/lisp/term/common-win.el
@@ -59,20 +59,20 @@
(setq system-key-alist
(list
;; These are special "keys" used to pass events from C to lisp.
- (cons (logior (lsh 0 16) 1) 'ns-power-off)
- (cons (logior (lsh 0 16) 2) 'ns-open-file)
- (cons (logior (lsh 0 16) 3) 'ns-open-temp-file)
- (cons (logior (lsh 0 16) 4) 'ns-drag-file)
- (cons (logior (lsh 0 16) 5) 'ns-drag-color)
- (cons (logior (lsh 0 16) 6) 'ns-drag-text)
- (cons (logior (lsh 0 16) 7) 'ns-change-font)
- (cons (logior (lsh 0 16) 8) 'ns-open-file-line)
-;;; (cons (logior (lsh 0 16) 9) 'ns-insert-working-text)
-;;; (cons (logior (lsh 0 16) 10) 'ns-delete-working-text)
- (cons (logior (lsh 0 16) 11) 'ns-spi-service-call)
- (cons (logior (lsh 0 16) 12) 'ns-new-frame)
- (cons (logior (lsh 0 16) 13) 'ns-toggle-toolbar)
- (cons (logior (lsh 0 16) 14) 'ns-show-prefs)
+ (cons 1 'ns-power-off)
+ (cons 2 'ns-open-file)
+ (cons 3 'ns-open-temp-file)
+ (cons 4 'ns-drag-file)
+ (cons 5 'ns-drag-color)
+ (cons 6 'ns-drag-text)
+ (cons 7 'ns-change-font)
+ (cons 8 'ns-open-file-line)
+;;; (cons 9 'ns-insert-working-text)
+;;; (cons 10 'ns-delete-working-text)
+ (cons 11 'ns-spi-service-call)
+ (cons 12 'ns-new-frame)
+ (cons 13 'ns-toggle-toolbar)
+ (cons 14 'ns-show-prefs)
))))
(set-terminal-parameter frame 'x-setup-function-keys t)))
@@ -112,7 +112,7 @@
;; Handle the -xrm option.
(defun x-handle-xrm-switch (switch)
(unless (consp x-invocation-args)
- (error "%s: missing argument to `%s' option" (invocation-name) switch))
+ (error "%s: missing argument to `%s' option" invocation-name switch))
(setq x-command-line-resources
(if (null x-command-line-resources)
(pop x-invocation-args)
@@ -152,7 +152,7 @@
;; the initial frame, too.
(defun x-handle-name-switch (switch)
(or (consp x-invocation-args)
- (error "%s: missing argument to `%s' option" (invocation-name) switch))
+ (error "%s: missing argument to `%s' option" invocation-name switch))
(setq x-resource-name (pop x-invocation-args)
initial-frame-alist (cons (cons 'name x-resource-name)
initial-frame-alist)))
diff --git a/lisp/term/internal.el b/lisp/term/internal.el
index 1e9cbf477df..396521d676d 100644
--- a/lisp/term/internal.el
+++ b/lisp/term/internal.el
@@ -595,8 +595,7 @@ list. You can (and should) also run it if and when the value of
(set-selection-coding-system coding-dos)
(IT-setup-unicode-display coding-unix)
(prefer-coding-system coding-dos)
- (and (default-value 'enable-multibyte-characters)
- (setq unibyte-display-via-language-environment t))
+ (setq unibyte-display-via-language-environment t)
;; Some codepages have sporadic support for Latin-1, Greek, and
;; symbol glyphs, which don't belong to their native character
;; set. It's a nuisance to have all those glyphs here, for all
diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el
index 40397fcfedd..6a668b213dd 100644
--- a/lisp/term/ns-win.el
+++ b/lisp/term/ns-win.el
@@ -42,7 +42,7 @@
(eval-when-compile (require 'cl-lib))
(or (featurep 'ns)
(error "%s: Loading ns-win.el but not compiled for GNUstep/macOS"
- (invocation-name)))
+ invocation-name))
;; Documentation-purposes only: actually loaded in loadup.el.
(require 'frame)
@@ -125,7 +125,6 @@ The properties returned may include `top', `left', `height', and `width'."
(define-key global-map [?\s-h] 'ns-do-hide-emacs)
(define-key global-map [?\s-H] 'ns-do-hide-others)
(define-key global-map [?\M-\s-h] 'ns-do-hide-others)
-(define-key key-translation-map [?\M-\s-\u02D9] [?\M-\s-h])
(define-key global-map [?\s-j] 'exchange-point-and-mark)
(define-key global-map [?\s-k] 'kill-current-buffer)
(define-key global-map [?\s-l] 'goto-line)
@@ -142,8 +141,13 @@ The properties returned may include `top', `left', `height', and `width'."
(define-key global-map [?\s-x] 'kill-region)
(define-key global-map [?\s-y] 'ns-paste-secondary)
(define-key global-map [?\s-z] 'undo)
+(define-key global-map [?\s-+] 'text-scale-adjust)
+(define-key global-map [?\s-=] 'text-scale-adjust)
+(define-key global-map [?\s--] 'text-scale-adjust)
+(define-key global-map [?\s-0] 'text-scale-adjust)
(define-key global-map [?\s-|] 'shell-command-on-region)
(define-key global-map [s-kp-bar] 'shell-command-on-region)
+(define-key global-map [?\C-\s- ] 'ns-do-show-character-palette)
;; (as in Terminal.app)
(define-key global-map [s-right] 'ns-next-frame)
(define-key global-map [s-left] 'ns-prev-frame)
@@ -307,8 +311,8 @@ is currently being used."
"Insert contents of `ns-working-text' as UTF-8 string and mark with
`ns-working-overlay'. Any previously existing working text is cleared first.
The overlay is assigned the face `ns-working-text-face'."
- ;; FIXME: if buffer is read-only, don't try to insert anything
- ;; and if text is bound to a command, execute that instead (Bug#1453)
+ ;; FIXME: if buffer is read-only, don't try to insert anything, and
+ ;; if text is bound to a command, execute that instead (Bug#1453).
(interactive)
(ns-delete-working-text)
(let ((start (point)))
@@ -354,7 +358,7 @@ See `ns-insert-working-text'."
;; Used prior to Emacs 25.
(define-coding-system-alias 'utf-8-nfd 'utf-8-hfs)
- (set-file-name-coding-system 'utf-8-hfs))
+ (set-file-name-coding-system 'utf-8-hfs-unix))
;;;; Inter-app communications support.
@@ -437,14 +441,7 @@ Lines are highlighted according to `ns-input-line'."
;;;; File handling.
(defun x-file-dialog (prompt dir default_filename mustmatch only_dir_p)
-"Read file name, prompting with PROMPT in directory DIR.
-Use a file selection dialog. Select DEFAULT-FILENAME in the dialog's file
-selection box, if specified. If MUSTMATCH is non-nil, the returned file
-or directory must exist.
-
-This function is only defined on NS, MS Windows, and X Windows with the
-Motif or Gtk toolkits. With the Motif toolkit, ONLY-DIR-P is ignored.
-Otherwise, if ONLY-DIR-P is non-nil, the user can only select directories."
+ "SKIP: real doc in xfns.c."
(ns-read-file-name prompt dir mustmatch default_filename only_dir_p))
(defun ns-open-file-using-panel ()
@@ -504,48 +501,38 @@ unless the current buffer is a scratch buffer."
(find-file f)))))
-(defun ns-drag-n-drop (event &optional new-frame force-text)
+(defun ns-drag-n-drop (event)
"Edit the files listed in the drag-n-drop EVENT.
-Switch to a buffer editing the last file dropped."
+Switch to a buffer editing the last file dropped, or insert the
+string dropped into the current buffer."
(interactive "e")
(let* ((window (posn-window (event-start event)))
(arg (car (cdr (cdr event))))
(type (car arg))
- (data (car (cdr arg)))
- (url-or-string (cond ((eq type 'file)
- (concat "file:" data))
- (t data))))
+ (operations (car (cdr arg)))
+ (objects (cdr (cdr arg)))
+ (string (mapconcat 'identity objects "\n")))
(set-frame-selected-window nil window)
- (when new-frame
- (select-frame (make-frame)))
(raise-frame)
(setq window (selected-window))
- (if force-text
- (dnd-insert-text window 'private data)
- (dnd-handle-one-url window 'private url-or-string))))
-
-
-(defun ns-drag-n-drop-other-frame (event)
- "Edit the files listed in the drag-n-drop EVENT, in other frames.
-May create new frames, or reuse existing ones. The frame editing
-the last file dropped is selected."
- (interactive "e")
- (ns-drag-n-drop event t))
-
-(defun ns-drag-n-drop-as-text (event)
- "Drop the data in EVENT as text."
- (interactive "e")
- (ns-drag-n-drop event nil t))
-
-(defun ns-drag-n-drop-as-text-other-frame (event)
- "Drop the data in EVENT as text in a new frame."
- (interactive "e")
- (ns-drag-n-drop event t t))
+ (cond ((memq 'ns-drag-operation-generic operations)
+ ;; Perform the default action for the type.
+ (if (eq type 'file)
+ (dolist (data objects)
+ (dnd-handle-one-url window 'private (concat "file:" data)))
+ (dnd-insert-text window 'private string)))
+ ((memq 'ns-drag-operation-copy operations)
+ ;; Try to open the file/URL. If type is nil, try to open
+ ;; it as a URL anyway.
+ (dolist (data objects)
+ (dnd-handle-one-url window 'private (if (eq type 'file)
+ (concat "file:" data)
+ data))))
+ (t
+ ;; Insert the text as is.
+ (dnd-insert-text window 'private string)))))
(global-set-key [drag-n-drop] 'ns-drag-n-drop)
-(global-set-key [C-drag-n-drop] 'ns-drag-n-drop-other-frame)
-(global-set-key [M-drag-n-drop] 'ns-drag-n-drop-as-text)
-(global-set-key [C-M-drag-n-drop] 'ns-drag-n-drop-as-text-other-frame)
;;;; Frame-related functions.
@@ -556,8 +543,9 @@ the last file dropped is selected."
(defvar ns-right-control-modifier)
;; You say tomAYto, I say tomAHto..
-(defvaralias 'ns-option-modifier 'ns-alternate-modifier)
-(defvaralias 'ns-right-option-modifier 'ns-right-alternate-modifier)
+(with-no-warnings
+ (defvaralias 'ns-option-modifier 'ns-alternate-modifier)
+ (defvaralias 'ns-right-option-modifier 'ns-right-alternate-modifier))
(defun ns-do-hide-emacs ()
(interactive)
@@ -575,6 +563,12 @@ the last file dropped is selected."
(interactive)
(ns-emacs-info-panel))
+(declare-function ns-show-character-palette "nsfns.m" ())
+
+(defun ns-do-show-character-palette ()
+ (interactive)
+ (ns-show-character-palette))
+
(defun ns-next-frame ()
"Switch to next visible frame."
(interactive)
@@ -619,7 +613,7 @@ the last file dropped is selected."
(let ((last-nonmenu-event (if (listp last-nonmenu-event)
last-nonmenu-event
;; Fake it:
- `(mouse-1 POSITION 1))))
+ '(mouse-1 POSITION 1))))
(if (y-or-n-p (format "Print buffer %s? " (buffer-name)))
(print-buffer)
(error "Canceled")))
@@ -739,6 +733,10 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
;;;; macOS-like defaults for trackpad and mouse wheel scrolling on
;;;; macOS 10.7+.
+(defvar ns-version-string)
+(defvar mouse-wheel-scroll-amount)
+(defvar mouse-wheel-progressive-speed)
+
;; FIXME: This doesn't look right. Is there a better way to do this
;; that keeps customize happy?
(when (featurep 'cocoa)
@@ -801,8 +799,8 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
;; Set some options to be as Nextstep-like as possible.
-(setq frame-title-format t
- icon-title-format t)
+(setq frame-title-format "%b"
+ icon-title-format "%b")
(defvar ns-initialized nil
diff --git a/lisp/term/pc-win.el b/lisp/term/pc-win.el
index 214c5a37f55..09275991cf5 100644
--- a/lisp/term/pc-win.el
+++ b/lisp/term/pc-win.el
@@ -38,7 +38,7 @@
(if (not (fboundp 'msdos-remember-default-colors))
(error "%s: Loading pc-win.el but not compiled for MS-DOS"
- (invocation-name)))
+ invocation-name))
(declare-function msdos-remember-default-colors "msdos.c")
(declare-function w16-set-clipboard-data "w16select.c")
@@ -158,159 +158,59 @@ created."
;; a useful function for returning 'nil regardless of argument.
;; Note: Any re-definition in this file of a function that is defined
-;; in C on other platforms, should either have no doc-string, or one
-;; that is identical to the C version, but with the arglist signature
-;; at the end. Otherwise help-split-fundoc gets confused on other
-;; platforms. (Bug#10783)
+;; in C on other platforms, should either have a doc-string that
+;; starts with "SKIP", or one that is identical to the C version,
+;; but with the arglist signature at the end. Otherwise
+;; help-split-fundoc gets confused on other platforms. (Bug#10783)
-;; From src/xfns.c
(defun x-list-fonts (_pattern &optional _face _frame _maximum width)
- "Return a list of the names of available fonts matching PATTERN.
-If optional arguments FACE and FRAME are specified, return only fonts
-the same size as FACE on FRAME.
-
-PATTERN should be a string containing a font name in the XLFD,
-Fontconfig, or GTK format. A font name given in the XLFD format may
-contain wildcard characters:
- the * character matches any substring, and
- the ? character matches any single character.
- PATTERN is case-insensitive.
-
-The return value is a list of strings, suitable as arguments to
-`set-face-font'.
-
-Fonts Emacs can't use may or may not be excluded
-even if they match PATTERN and FACE.
-The optional fourth argument MAXIMUM sets a limit on how many
-fonts to match. The first MAXIMUM fonts are reported.
-The optional fifth argument WIDTH, if specified, is a number of columns
-occupied by a character of a font. In that case, return only fonts
-the WIDTH times as wide as FACE on FRAME."
+ "SKIP: real doc in xfaces.c."
(if (or (null width) (and (numberp width) (= width 1)))
(list "ms-dos")
(list "no-such-font")))
(defun x-display-pixel-width (&optional frame)
- "Return the width in pixels of DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display.
-
-On \"multi-monitor\" setups this refers to the pixel width for all
-physical monitors associated with DISPLAY. To get information for
-each physical monitor, use `display-monitor-attributes-list'."
+ "SKIP: real doc in xfns.c."
(frame-width frame))
(defun x-display-pixel-height (&optional frame)
- "Return the height in pixels of DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display.
-
-On \"multi-monitor\" setups this refers to the pixel height for all
-physical monitors associated with DISPLAY. To get information for
-each physical monitor, use `display-monitor-attributes-list'."
+ "SKIP: real doc in xfns.c."
(frame-height frame))
(defun x-display-planes (&optional _frame)
- "Return the number of bitplanes of DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display."
+ "SKIP: real doc in xfns.c."
4) ;bg switched to 16 colors as well
(defun x-display-color-cells (&optional _frame)
- "Return the number of color cells of DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display."
+ "SKIP: real doc in xfns.c."
16)
(defun x-server-max-request-size (&optional _frame)
- "Return the maximum request size of the server of DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display."
+ "SKIP: real doc in xfns.c."
1000000) ; ???
(defun x-server-vendor (&optional _frame)
- "Return the \"vendor ID\" string of the GUI software on TERMINAL.
-
-\(Labeling every distributor as a \"vendor\" embodies the false assumption
-that operating systems cannot be developed and distributed noncommercially.)
-
-For GNU and Unix systems, this queries the X server software; for
-MS-Windows, this queries the OS.
-
-The optional argument TERMINAL specifies which display to ask about.
-TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display."
+ "SKIP: real doc in xfns.c."
"GNU")
(defun x-server-version (&optional _frame)
- "Return the version numbers of the GUI software on TERMINAL.
-The value is a list of three integers specifying the version of the GUI
-software in use.
-
-For GNU and Unix system, the first 2 numbers are the version of the X
-Protocol used on TERMINAL and the 3rd number is the distributor-specific
-release number. For MS-Windows, the 3 numbers report the version and
-the build number of the OS.
-
-See also the function `x-server-vendor'.
-
-The optional argument TERMINAL specifies which display to ask about.
-TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display."
+ "SKIP: real doc in xfns.c."
'(1 0 0))
(defun x-display-screens (&optional _frame)
- "Return the number of screens on the server of DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display."
+ "SKIP: real doc in xfns.c."
1)
(defun x-display-mm-height (&optional _frame)
- "Return the height in millimeters of DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display.
-
-On \"multi-monitor\" setups this refers to the height in millimeters for
-all physical monitors associated with DISPLAY. To get information
-for each physical monitor, use `display-monitor-attributes-list'."
+ "SKIP: real doc in xfns.c."
245) ; Guess the size of my...
(defun x-display-mm-width (&optional _frame)
- "Return the width in millimeters of DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display.
-
-On \"multi-monitor\" setups this refers to the width in millimeters for
-all physical monitors associated with TERMINAL. To get information
-for each physical monitor, use `display-monitor-attributes-list'."
+ "SKIP: real doc in xfns.c."
322) ; ...monitor, EZ...
(defun x-display-backing-store (&optional _frame)
- "Return an indication of whether DISPLAY does backing store.
-The value may be `always', `when-mapped', or `not-useful'.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display."
+ "SKIP: real doc in xfns.c."
'not-useful)
(defun x-display-visual-class (&optional _frame)
- "Return the visual class of DISPLAY.
-The value is one of the symbols `static-gray', `gray-scale',
-`static-color', `pseudo-color', `true-color', or `direct-color'.
-
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display."
+ "SKIP: real doc in xfns.c."
'static-color)
(fset 'x-display-save-under 'ignore)
(fset 'x-get-resource 'ignore)
-;; From lisp/term/x-win.el
(defvar x-display-name "pc"
- "The name of the window display on which Emacs was started.
-On X, the display name of individual X frames is recorded in the
-`display' frame parameter.")
+ "SKIP: real doc in common-win.el.")
(defvar x-colors (mapcar 'car msdos-color-values)
- "List of basic colors available on color displays.
-For X, the list comes from the `rgb.txt' file,v 10.41 94/02/20.
-For Nextstep, this is a list of non-PANTONE colors returned by
-the operating system.")
+ "SKIP: real doc in common-win.el.")
;; From lisp/term/w32-win.el
;
diff --git a/lisp/term/sun.el b/lisp/term/sun.el
index a1c018483d5..c9f531e3520 100644
--- a/lisp/term/sun.el
+++ b/lisp/term/sun.el
@@ -118,14 +118,6 @@
(define-key map "D" [left]) ; R10
map))
-;; Since .emacs gets loaded before this file, a hook is supplied
-;; for you to put your own bindings in.
-
-(defvar sun-raw-prefix-hooks nil
- "List of forms to evaluate after setting `sun-raw-prefix'.")
-;; Obsolete since 21.1, but tty-setup-hook only exists since 24.4.
-(make-obsolete-variable 'sun-raw-prefix-hooks 'tty-setup-hook "21.1")
-
(defun terminal-init-sun ()
@@ -147,16 +139,7 @@
(global-set-key [f3] 'scroll-down-in-place)
(global-set-key [f4] 'scroll-up-in-place)
(global-set-key [f6] 'shrink-window)
- (global-set-key [f7] 'enlarge-window)
-
- (when sun-raw-prefix-hooks
- (message "sun-raw-prefix-hooks is obsolete! Use %s instead!"
- (or (car-safe (get 'sun-raw-prefix-hooks 'byte-obsolete-variable))
- "emacs-startup-hook"))
- (let ((hooks sun-raw-prefix-hooks))
- (while hooks
- (eval (car hooks))
- (setq hooks (cdr hooks))))))
+ (global-set-key [f7] 'enlarge-window))
(provide 'term/sun)
diff --git a/lisp/term/tty-colors.el b/lisp/term/tty-colors.el
index 04b433e178c..307586f2213 100644
--- a/lisp/term/tty-colors.el
+++ b/lisp/term/tty-colors.el
@@ -830,10 +830,10 @@ DISPLAY can be a display name or a frame, and defaults to the
selected frame's display.
If DISPLAY is not on a 24-but TTY terminal, return nil."
(when (and rgb (= (display-color-cells display) 16777216))
- (let ((r (lsh (car rgb) -8))
- (g (lsh (cadr rgb) -8))
- (b (lsh (nth 2 rgb) -8)))
- (logior (lsh r 16) (lsh g 8) b))))
+ (let ((r (ash (car rgb) -8))
+ (g (ash (cadr rgb) -8))
+ (b (ash (nth 2 rgb) -8)))
+ (logior (ash r 16) (ash g 8) b))))
(defun tty-color-define (name index &optional rgb frame)
"Specify a tty color by its NAME, terminal INDEX and RGB values.
@@ -895,9 +895,9 @@ FRAME defaults to the selected frame."
;; never consider it for approximating another color.
(if try-rgb
(progn
- (setq try-r (lsh (car try-rgb) -8)
- try-g (lsh (cadr try-rgb) -8)
- try-b (lsh (nth 2 try-rgb) -8))
+ (setq try-r (ash (car try-rgb) -8)
+ try-g (ash (cadr try-rgb) -8)
+ try-b (ash (nth 2 try-rgb) -8))
(setq dif-r (- r try-r)
dif-g (- g try-g)
dif-b (- b try-b))
@@ -938,13 +938,13 @@ should be the same regardless of what display is being used."
(i2 (+ i1 ndig))
(i3 (+ i2 ndig)))
(list
- (lsh
+ (ash
(string-to-number (substring color i1 i2) 16)
(* 4 (- 4 ndig)))
- (lsh
+ (ash
(string-to-number (substring color i2 i3) 16)
(* 4 (- 4 ndig)))
- (lsh
+ (ash
(string-to-number (substring color i3) 16)
(* 4 (- 4 ndig))))))
((and (>= len 9) ;; X-style RGB:xx/yy/zz color spec
diff --git a/lisp/term/tvi970.el b/lisp/term/tvi970.el
index 20c5a53fc2d..3b748483eef 100644
--- a/lisp/term/tvi970.el
+++ b/lisp/term/tvi970.el
@@ -101,9 +101,6 @@
;; Should keypad numbers send ordinary digits or distinct escape sequences?
(define-minor-mode tvi970-set-keypad-mode
"Toggle alternate keypad mode on TVI 970 keypad.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
In alternate keypad mode, the keys send distinct escape
sequences, meaning that they can have their own bindings,
diff --git a/lisp/term/vt100.el b/lisp/term/vt100.el
index a296f7e5293..81843ceb975 100644
--- a/lisp/term/vt100.el
+++ b/lisp/term/vt100.el
@@ -39,10 +39,7 @@
;;; Controlling the screen width.
(define-minor-mode vt100-wide-mode
- "Toggle 132/80 column mode for vt100s.
-With a prefix argument ARG, switch to 132-column mode if ARG is
-positive, and 80-column mode otherwise. If called from Lisp,
-switch to 132-column mode if ARG is omitted or nil."
+ "Toggle 132/80 column mode for vt100s."
:global t :init-value (= (frame-width) 132)
:group 'terminals
(send-string-to-terminal (if vt100-wide-mode "\e[?3h" "\e[?3l"))
diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el
index 39f393fcf98..beb7425ce55 100644
--- a/lisp/term/w32-win.el
+++ b/lisp/term/w32-win.el
@@ -66,7 +66,7 @@
;; ../startup.el.
;; (if (not (eq window-system 'w32))
-;; (error "%s: Loading w32-win.el but not compiled for w32" (invocation-name)))
+;; (error "%s: Loading w32-win.el but not compiled for w32" invocation-name))
(eval-when-compile (require 'cl-lib))
(require 'frame)
@@ -276,7 +276,8 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
'(gnutls "libgnutls-28.dll" "libgnutls-26.dll"))
'(libxml2 "libxml2-2.dll" "libxml2.dll")
'(zlib "zlib1.dll" "libz-1.dll")
- '(lcms2 "liblcms2-2.dll")))
+ '(lcms2 "liblcms2-2.dll")
+ '(json "libjansson-4.dll")))
;;; multi-tty support
(defvar w32-initialized nil
@@ -309,7 +310,7 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
(setq x-resource-name
;; Change any . or * characters in x-resource-name to hyphens,
;; so as not to choke when we use it in X resource queries.
- (replace-regexp-in-string "[.*]" "-" (invocation-name))))
+ (replace-regexp-in-string "[.*]" "-" invocation-name)))
(x-open-connection "w32" x-command-line-resources
;; Exit with a fatal error if this fails and we
@@ -391,8 +392,12 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
(declare-function w32-set-clipboard-data "w32select.c"
(string &optional ignored))
-(declare-function w32-get-clipboard-data "w32select.c")
-(declare-function w32-selection-exists-p "w32select.c")
+(declare-function w32-get-clipboard-data "w32select.c"
+ (&optional ignored))
+(declare-function w32-selection-exists-p "w32select.c"
+ (&optional selection terminal))
+(declare-function w32-selection-targets "w32select.c"
+ (&optional selection terminal))
;;; Fix interface to (X-specific) mouse.el
(defun w32--set-selection (type value)
diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el
index f159a71d988..56061371fe1 100644
--- a/lisp/term/x-win.el
+++ b/lisp/term/x-win.el
@@ -69,7 +69,7 @@
(eval-when-compile (require 'cl-lib))
(if (not (fboundp 'x-create-frame))
- (error "%s: Loading x-win.el but not compiled for X" (invocation-name)))
+ (error "%s: Loading x-win.el but not compiled for X" invocation-name))
(require 'term/common-win)
(require 'frame)
@@ -93,7 +93,7 @@
;; Handle the --parent-id option.
(defun x-handle-parent-id (switch)
(or (consp x-invocation-args)
- (error "%s: missing argument to `%s' option" (invocation-name) switch))
+ (error "%s: missing argument to `%s' option" invocation-name switch))
(setq initial-frame-alist (cons
(cons 'parent-id
(string-to-number (car x-invocation-args)))
@@ -104,7 +104,7 @@
;; to give us back our session id we had on the previous run.
(defun x-handle-smid (switch)
(or (consp x-invocation-args)
- (error "%s: missing argument to `%s' option" (invocation-name) switch))
+ (error "%s: missing argument to `%s' option" invocation-name switch))
(setq x-session-previous-id (car x-invocation-args)
x-invocation-args (cdr x-invocation-args)))
@@ -1205,7 +1205,7 @@ This returns an error if any Emacs frames are X frames."
;; Make sure we have a valid resource name.
(or (stringp x-resource-name)
(let (i)
- (setq x-resource-name (invocation-name))
+ (setq x-resource-name (copy-sequence invocation-name))
;; Change any . or * characters in x-resource-name to hyphens,
;; so as not to choke when we use it in X resource queries.
diff --git a/lisp/term/xterm.el b/lisp/term/xterm.el
index 8cbf5dace0f..c4b0a8fb6e6 100644
--- a/lisp/term/xterm.el
+++ b/lisp/term/xterm.el
@@ -68,8 +68,13 @@ string bytes that can be copied is 3/4 of this value."
:version "25.1"
:type 'integer)
+(defcustom xterm-set-window-title nil
+ "Whether Emacs should set window titles to an Emacs frame in an XTerm."
+ :version "27.1"
+ :type 'boolean)
+
(defconst xterm-paste-ending-sequence "\e[201~"
- "Characters send by the terminal to end a bracketed paste.")
+ "Characters sent by the terminal to end a bracketed paste.")
(defun xterm--pasted-text ()
"Handle the rest of a terminal paste operation.
@@ -90,15 +95,49 @@ Return the pasted text as a string."
(decode-coding-region (point-min) (point) (keyboard-coding-system)
t)))))
-(defun xterm-paste ()
+(defun xterm-paste (event)
"Handle the start of a terminal paste operation."
- (interactive)
- (let* ((pasted-text (xterm--pasted-text))
+ (interactive "e")
+ (unless (eq (car-safe event) 'xterm-paste)
+ (error "xterm-paste must be found to xterm-paste event"))
+ (let* ((pasted-text (nth 1 event))
(interprogram-paste-function (lambda () pasted-text)))
(yank)))
+;; Put xterm-paste itself in global-map because, after translation,
+;; it's just a normal input event.
(define-key global-map [xterm-paste] #'xterm-paste)
+;; By returning an empty key sequence, these two functions perform the
+;; moral equivalent of the kind of transparent event processing done
+;; by read-event's handling of special-event-map, but inside
+;; read-key-sequence (which can recognize multi-character terminal
+;; notifications) instead of read-event (which can't).
+
+(defun xterm-translate-focus-in (_prompt)
+ (setf (terminal-parameter nil 'tty-focus-state) 'focused)
+ (funcall after-focus-change-function)
+ [])
+
+(defun xterm-translate-focus-out (_prompt)
+ (setf (terminal-parameter nil 'tty-focus-state) 'defocused)
+ (funcall after-focus-change-function)
+ [])
+
+(defun xterm--suspend-tty-function (_tty)
+ ;; We can't know what happens to the tty after we're suspended
+ (setf (terminal-parameter nil 'tty-focus-state) nil)
+ (funcall after-focus-change-function))
+
+;; Similarly, we want to transparently slurp the entirety of a
+;; bracketed paste and encapsulate it into a single event. We used to
+;; just slurp up the bracketed paste content in the event handler, but
+;; this strategy can produce unexpected results in a caller manually
+;; looping on read-key and buffering input for later processing.
+
+(defun xterm-translate-bracketed-paste (_prompt)
+ (vector (list 'xterm-paste (xterm--pasted-text))))
+
(defvar xterm-rxvt-function-map
(let ((map (make-sparse-keymap)))
(define-key map "\e[2~" [insert])
@@ -127,9 +166,15 @@ Return the pasted text as a string."
(define-key map "\e[13~" [f3])
(define-key map "\e[14~" [f4])
- ;; Recognize the start of a bracketed paste sequence. The handler
- ;; internally recognizes the end.
- (define-key map "\e[200~" [xterm-paste])
+ ;; Recognize the start of a bracketed paste sequence.
+ ;; The translation function internally recognizes the end.
+ (define-key map "\e[200~" #'xterm-translate-bracketed-paste)
+
+ ;; These translation functions actually call the focus handlers
+ ;; internally and return an empty sequence, causing us to go on to
+ ;; read the next event.
+ (define-key map "\e[I" #'xterm-translate-focus-in)
+ (define-key map "\e[O" #'xterm-translate-focus-out)
map)
"Keymap of escape sequences, shared between xterm and rxvt support.")
@@ -634,7 +679,7 @@ Return the pasted text as a string."
(let ((str "")
chr)
;; The reply should be: \e ] 11 ; rgb: NUMBER1 / NUMBER2 / NUMBER3 \e \\
- (while (and (setq chr (read-event nil nil 2)) (not (equal chr ?\\)))
+ (while (and (setq chr (xterm--read-event-for-query)) (not (equal chr ?\\)))
(setq str (concat str (string chr))))
(when (string-match
"rgb:\\([a-f0-9]+\\)/\\([a-f0-9]+\\)/\\([a-f0-9]+\\)" str)
@@ -662,7 +707,7 @@ Return the pasted text as a string."
;; respond to this escape sequence. RMS' opinion was to remove
;; it completely. That might be right, but let's first try to
;; see if by using a longer timeout we get rid of most issues.
- (while (and (setq chr (read-event nil nil 2)) (not (equal chr ?c)))
+ (while (and (setq chr (xterm--read-event-for-query)) (not (equal chr ?c)))
(setq str (concat str (string chr))))
;; Since xterm-280, the terminal type (NUMBER1) is now 41 instead of 0.
(when (string-match "\\([0-9]+\\);\\([0-9]+\\);0" str)
@@ -712,6 +757,26 @@ Return the pasted text as a string."
"Seconds to wait for an answer from the terminal.
Can be nil to mean \"no timeout\".")
+(defvar xterm-query-redisplay-timeout 0.2
+ "Seconds to wait before allowing redisplay during terminal
+ query." )
+
+(defun xterm--read-event-for-query ()
+ "Like read-event, but inhibit redisplay.
+
+By not redisplaying right away for xterm queries, we can avoid
+unsightly flashing during initialization. Give up and redisplay
+anyway if we've been waiting a little while."
+ (let ((start-time (current-time)))
+ (or (let ((inhibit-redisplay t))
+ (read-event nil nil xterm-query-redisplay-timeout))
+ (read-event nil nil
+ (and xterm-query-timeout
+ (max 0 (float-time
+ (time-subtract
+ xterm-query-timeout
+ (time-since start-time)))))))))
+
(defun xterm--query (query handlers &optional no-async)
"Send QUERY string to the terminal and watch for a response.
HANDLERS is an alist with elements of the form (STRING . FUNCTION).
@@ -744,7 +809,7 @@ We run the first FUNCTION whose STRING matches the input events."
(let ((handler (pop handlers))
(i 0))
(while (and (< i (length (car handler)))
- (let ((evt (read-event nil nil xterm-query-timeout)))
+ (let ((evt (xterm--read-event-for-query)))
(if (and (null evt) (= i 0) (not no-async))
;; Timeout on the first event: fallback on async.
(progn
@@ -807,9 +872,13 @@ We run the first FUNCTION whose STRING matches the input events."
(when (memq 'setSelection xterm-extra-capabilities)
(xterm--init-activate-set-selection)))
+ (when xterm-set-window-title
+ (xterm--init-frame-title))
;; Unconditionally enable bracketed paste mode: terminals that don't
;; support it just ignore the sequence.
(xterm--init-bracketed-paste-mode)
+ ;; We likewise unconditionally enable support for focus tracking.
+ (xterm--init-focus-tracking)
(run-hooks 'terminal-init-xterm-hook))
@@ -825,6 +894,12 @@ We run the first FUNCTION whose STRING matches the input events."
(push "\e[?2004l" (terminal-parameter nil 'tty-mode-reset-strings))
(push "\e[?2004h" (terminal-parameter nil 'tty-mode-set-strings)))
+(defun xterm--init-focus-tracking ()
+ "Terminal initialization for focus tracking mode."
+ (send-string-to-terminal "\e[?1004h")
+ (push "\e[?1004l" (terminal-parameter nil 'tty-mode-reset-strings))
+ (push "\e[?1004h" (terminal-parameter nil 'tty-mode-set-strings)))
+
(defun xterm--init-activate-get-selection ()
"Terminal initialization for `gui-get-selection'."
(set-terminal-parameter nil 'xterm--get-selection t))
@@ -833,6 +908,34 @@ We run the first FUNCTION whose STRING matches the input events."
"Terminal initialization for `gui-set-selection'."
(set-terminal-parameter nil 'xterm--set-selection t))
+(defun xterm--init-frame-title ()
+ "Terminal initialization for XTerm frame titles."
+ (xterm-set-window-title)
+ (add-hook 'after-make-frame-functions 'xterm-set-window-title-flag)
+ (add-hook 'window-configuration-change-hook 'xterm-unset-window-title-flag)
+ (add-hook 'post-command-hook 'xterm-set-window-title)
+ (add-hook 'minibuffer-exit-hook 'xterm-set-window-title))
+
+(defvar xterm-window-title-flag nil
+ "Whether a new frame has been created, calling for a title update.")
+
+(defun xterm-set-window-title-flag (_frame)
+ "Set `xterm-window-title-flag'.
+See `xterm--init-frame-title'"
+ (setq xterm-window-title-flag t))
+
+(defun xterm-unset-window-title-flag ()
+ (when xterm-window-title-flag
+ (setq xterm-window-title-flag nil)
+ (xterm-set-window-title)))
+
+(defun xterm-set-window-title (&optional terminal)
+ "Set the window title of the Xterm TERMINAL.
+The title is constructed from `frame-title-format'."
+ (send-string-to-terminal
+ (format "\e]2;%s\a" (format-mode-line frame-title-format))
+ terminal))
+
(defun xterm--selection-char (type)
(pcase type
('PRIMARY "p")
@@ -908,7 +1011,7 @@ hitting screen's max DCS length."
(defun xterm-rgb-convert-to-16bit (prim)
"Convert an 8-bit primary color value PRIM to a corresponding 16-bit value."
- (logior prim (lsh prim 8)))
+ (logior prim (ash prim 8)))
(defun xterm-register-default-colors (colors)
"Register the default set of colors for xterm or compatible emulator.
diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el
index 885a4ee67ec..e9b17795a92 100644
--- a/lisp/textmodes/artist.el
+++ b/lisp/textmodes/artist.el
@@ -351,13 +351,12 @@ Example:
(defvar artist-pointer-shape (if (eq window-system 'x) x-pointer-crosshair nil)
"If in X Windows, use this pointer shape while drawing with the mouse.")
+(defvaralias 'artist-text-renderer 'artist-text-renderer-function)
(defcustom artist-text-renderer-function 'artist-figlet
"Function for doing text rendering."
:group 'artist-text
:type 'symbol)
-(defvaralias 'artist-text-renderer 'artist-text-renderer-function)
-
(defcustom artist-figlet-program "figlet"
"Program to run for `figlet'."
@@ -1199,7 +1198,7 @@ PREV-OP-ARG are used when invoked recursively during the build-up."
;;;###autoload
(define-minor-mode artist-mode
"Toggle Artist mode.
-With argument ARG, turn Artist mode on if ARG is positive.
+
Artist lets you draw lines, squares, rectangles and poly-lines,
ellipses and circles with your mouse and/or keyboard.
@@ -1401,7 +1400,10 @@ Keymap summary
(artist-mode-exit))
(t
;; Turn mode on
- (artist-mode-init))))
+ (artist-mode-init)
+ (let ((font (face-attribute 'default :font)))
+ (when (and (fontp font) (not (font-get font :spacing)))
+ (message "The default font isn't monospaced, so the drawings in this buffer may look odd"))))))
;; Init and exit
(defun artist-mode-init ()
@@ -2893,7 +2895,7 @@ Returns a list of strings."
dir-list)
(mapcar
(lambda (file)
- (replace-regexp-in-string "\.flf\\'" "" file))
+ (replace-regexp-in-string "\\.flf\\'" "" file))
result))))
(defun artist-figlet-choose-font ()
diff --git a/lisp/textmodes/bib-mode.el b/lisp/textmodes/bib-mode.el
index 81dfb6c99c0..7a5d3ef7758 100644
--- a/lisp/textmodes/bib-mode.el
+++ b/lisp/textmodes/bib-mode.el
@@ -198,7 +198,7 @@ named by variable `unread-bib-file'."
(defvar bib-capitalize-title-stop-words
(concat
- "the\\|and\\|of\\|is\\|a\\|an\\|of\\|for\\|in\\|to\\|in\\|on\\|at\\|"
+ "the\\|and\\|of\\|is\\|a\\|an\\|for\\|in\\|to\\|on\\|at\\|"
"by\\|with\\|that\\|its")
"Words not to be capitalized in a title (unless the first word).")
diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el
index b9ff7a57988..a560c2b097f 100644
--- a/lisp/textmodes/bibtex.el
+++ b/lisp/textmodes/bibtex.el
@@ -1038,6 +1038,9 @@ See `bibtex-generate-autokey' for details."
:type '(repeat (cons (regexp :tag "Old")
(string :tag "New"))))
+(defvaralias 'bibtex-autokey-name-case-convert
+ 'bibtex-autokey-name-case-convert-function)
+
(defcustom bibtex-autokey-name-case-convert-function 'downcase
"Function called for each name to perform case conversion.
See `bibtex-generate-autokey' for details."
@@ -1049,8 +1052,6 @@ See `bibtex-generate-autokey' for details."
(function :tag "Conversion function")))
(put 'bibtex-autokey-name-case-convert-function 'safe-local-variable
(lambda (x) (memq x '(upcase downcase capitalize identity))))
-(defvaralias 'bibtex-autokey-name-case-convert
- 'bibtex-autokey-name-case-convert-function)
(defcustom bibtex-autokey-name-length 'infty
"Number of characters from name to incorporate into key.
@@ -1113,6 +1114,9 @@ Case is significant. See `bibtex-generate-autokey' for details."
:group 'bibtex-autokey
:type '(repeat regexp))
+(defvaralias 'bibtex-autokey-titleword-case-convert
+ 'bibtex-autokey-titleword-case-convert-function)
+
(defcustom bibtex-autokey-titleword-case-convert-function 'downcase
"Function called for each titleword to perform case conversion.
See `bibtex-generate-autokey' for details."
@@ -1122,8 +1126,6 @@ See `bibtex-generate-autokey' for details."
(const :tag "Capitalize" capitalize)
(const :tag "Upcase" upcase)
(function :tag "Conversion function")))
-(defvaralias 'bibtex-autokey-titleword-case-convert
- 'bibtex-autokey-titleword-case-convert-function)
(defcustom bibtex-autokey-titleword-abbrevs nil
"Determines exceptions to the usual abbreviation mechanism.
@@ -1354,6 +1356,8 @@ Set this variable before loading BibTeX mode."
;; The Key `C-c&' is reserved for reftex.el
(define-key km "\t" 'bibtex-find-text)
(define-key km "\n" 'bibtex-next-field)
+ (define-key km [remap forward-paragraph] 'bibtex-next-entry)
+ (define-key km [remap backward-paragraph] 'bibtex-previous-entry)
(define-key km "\M-\t" 'completion-at-point)
(define-key km "\C-c\"" 'bibtex-remove-delimiters)
(define-key km "\C-c{" 'bibtex-remove-delimiters)
@@ -1413,6 +1417,8 @@ Set this variable before loading BibTeX mode."
("Moving inside an Entry"
["End of Field" bibtex-find-text t]
["Next Field" bibtex-next-field t]
+ ["Next entry" bibtex-next-entry t]
+ ["Previous entry" bibtex-previous-entry t]
["Beginning of Entry" bibtex-beginning-of-entry t]
["End of Entry" bibtex-end-of-entry t]
"--"
@@ -2343,7 +2349,8 @@ Formats current entry according to variable `bibtex-entry-format'."
(when (memq 'sort-fields format)
(goto-char (point-min))
(let ((beg-fields (save-excursion (bibtex-beginning-first-field)))
- (fields-alist (bibtex-parse-entry))
+ (fields-alist (bibtex-parse-entry
+ nil (not (memq 'opts-or-alts format))))
bibtex-help-message elt)
(delete-region beg-fields (point))
(dolist (field default-field-list)
@@ -2365,7 +2372,8 @@ Formats current entry according to variable `bibtex-entry-format'."
(end-text (copy-marker (bibtex-end-of-text-in-field bounds) t))
(empty-field (equal "" (bibtex-text-in-field-bounds bounds t)))
(field-name (buffer-substring-no-properties beg-name end-name))
- (opt-alt (and (string-match "\\`\\(OPT\\|ALT\\)" field-name)
+ (opt-alt (and (memq 'opts-or-alts format)
+ (string-match "\\`\\(OPT\\|ALT\\)" field-name)
(not (and bibtex-no-opt-remove-re
(string-match bibtex-no-opt-remove-re
field-name)))))
@@ -2932,7 +2940,7 @@ for parsing BibTeX keys. If parsing fails, try to set this variable to nil."
(if verbose
(bibtex-progress-message 'done))
;; successful operation --> return `bibtex-reference-keys'
- (setq bibtex-reference-keys ref-keys)))))))
+ (setq bibtex-reference-keys (nreverse ref-keys))))))))
(defun bibtex-parse-strings (&optional add abortable)
"Set `bibtex-strings' to the string definitions in the whole buffer.
@@ -3639,20 +3647,20 @@ When called interactively with a prefix arg, query for a value of ENTRY-TYPE."
(mapc 'bibtex-make-field required)
(mapc 'bibtex-make-optional-field optional)))))
-(defun bibtex-parse-entry (&optional content)
+(defun bibtex-parse-entry (&optional content keep-opt-alt)
"Parse entry at point, return an alist.
The alist elements have the form (FIELD . TEXT), where FIELD can also be
the special strings \"=type=\" and \"=key=\". For the FIELD \"=key=\"
-TEXT may be nil. Remove \"OPT\" and \"ALT\" from FIELD.
-Move point to the end of the last field.
-If optional arg CONTENT is non-nil extract content of text fields."
+TEXT may be nil. Move point to the end of the last field.
+If optional arg CONTENT is non-nil extract content of text fields.
+Remove \"OPT\" and \"ALT\" from FIELD unless KEEP-OPT-ALT is non-nil."
(let (alist bounds)
(when (looking-at bibtex-entry-maybe-empty-head)
(push (cons "=type=" (bibtex-type-in-head)) alist)
(push (cons "=key=" (bibtex-key-in-head)) alist)
(goto-char (match-end 0))
(while (setq bounds (bibtex-parse-field))
- (push (cons (bibtex-name-in-field bounds t)
+ (push (cons (bibtex-name-in-field bounds (not keep-opt-alt))
(bibtex-text-in-field-bounds bounds content))
alist)
(goto-char (bibtex-end-of-field bounds))))
@@ -3846,11 +3854,13 @@ Return the new location of point."
(re-search-forward "[\n\C-m]" nil 'end (1- arg))
(forward-line (1- arg))))
-(defun bibtex-reposition-window ()
+(defun bibtex-reposition-window (&optional pos)
"Make the current BibTeX entry visible.
If entry is smaller than `window-body-height', entry is centered in window.
-Otherwise display the beginning of entry."
+Otherwise display the beginning of entry.
+Optional arg POS is the position of the BibTeX entry to use."
(interactive)
+ (if pos (goto-char pos))
(let ((pnt (point))
(beg (line-number-at-pos (bibtex-beginning-of-entry)))
(end (line-number-at-pos (bibtex-end-of-entry))))
@@ -3869,9 +3879,10 @@ Otherwise display the beginning of entry."
(goto-char pnt)))))
(defun bibtex-mark-entry ()
- "Put mark at beginning, point at end of current BibTeX entry."
+ "Put mark at beginning, point at end of current BibTeX entry.
+Activate mark in Transient Mark mode."
(interactive)
- (push-mark (bibtex-beginning-of-entry) :activate t)
+ (push-mark (bibtex-beginning-of-entry) t t)
(bibtex-end-of-entry))
(defun bibtex-count-entries (&optional count-string-entries)
@@ -4058,8 +4069,7 @@ for a crossref key, t otherwise."
(message "Key `%s' is current entry" crossref-key)
(if eqb (select-window (split-window))
(pop-to-buffer buffer))
- (goto-char pos)
- (bibtex-reposition-window)
+ (bibtex-reposition-window pos)
(beginning-of-line)
(if (and eqb (> pnt pos) (not noerror))
(error "The referencing entry must precede the crossrefed entry!"))))
@@ -4107,9 +4117,14 @@ A prefix arg negates the value of `bibtex-search-entry-globally'."
(if (cdr (assoc-string key bibtex-reference-keys))
(setq found (bibtex-search-entry key)))))
(cond ((and found display)
- (switch-to-buffer buffer)
- (goto-char found)
- (bibtex-reposition-window))
+ ;; If possible, reuse the window displaying BUFFER.
+ (let ((window (get-buffer-window buffer t)))
+ (if window
+ (progn
+ (select-frame-set-input-focus (window-frame window))
+ (select-window window))
+ (switch-to-buffer buffer)))
+ (bibtex-reposition-window found))
(found (set-buffer buffer))
(display (message "Key `%s' not found" key)))
found)
@@ -4441,6 +4456,24 @@ is as in `bibtex-enclosing-field'. It is t for interactive calls."
(goto-char (match-beginning 0)))
(bibtex-find-text begin nil bibtex-help-message)))
+(defun bibtex-next-entry (&optional arg)
+ "Move point ARG entries forward.
+ARG defaults to one. Called interactively, ARG is the prefix
+argument."
+ (interactive "p")
+ (bibtex-end-of-entry)
+ (when (re-search-forward bibtex-entry-maybe-empty-head nil t (or arg 1))
+ (goto-char (match-beginning 0))))
+
+(defun bibtex-previous-entry (&optional arg)
+ "Move point ARG entries backward.
+ARG defaults to one. Called interactively, ARG is the prefix
+argument."
+ (interactive "p")
+ (bibtex-beginning-of-entry)
+ (when (re-search-backward bibtex-entry-maybe-empty-head nil t (or arg 1))
+ (goto-char (match-beginning 0))))
+
(defun bibtex-find-text (&optional begin noerror help comma)
"Move point to end of text of current BibTeX field or entry head.
With optional prefix BEGIN non-nil, move point to its beginning.
@@ -4925,23 +4958,26 @@ If mark is active reformat entries in region, if not in whole buffer."
(cond (read-options
(if use-previous-options
bibtex-reformat-previous-options
- (setq bibtex-reformat-previous-options
- (delq nil
- (mapcar (lambda (option)
- (if (y-or-n-p (car option)) (cdr option)))
- `(("Realign entries (recommended)? " . realign)
- ("Remove empty optional and alternative fields? " . opts-or-alts)
- ("Remove delimiters around pure numerical fields? " . numerical-fields)
- (,(concat (if bibtex-comma-after-last-field "Insert" "Remove")
- " comma at end of entry? ") . last-comma)
- ("Replace double page dashes by single ones? " . page-dashes)
- ("Delete whitespace at the beginning and end of fields? " . whitespace)
- ("Inherit booktitle? " . inherit-booktitle)
- ("Force delimiters? " . delimiters)
- ("Unify case of entry types and field names? " . unify-case)
- ("Enclose parts of field entries by braces? " . braces)
- ("Replace parts of field entries by string constants? " . strings)
- ("Sort fields? " . sort-fields)))))))
+ (let (answers)
+ (map-y-or-n-p
+ #'car
+ (lambda (option)
+ (push (cdr option) answers))
+ `(("Realign entries (recommended)? " . realign)
+ ("Remove empty optional and alternative fields? " . opts-or-alts)
+ ("Remove delimiters around pure numerical fields? " . numerical-fields)
+ (,(concat (if bibtex-comma-after-last-field "Insert" "Remove")
+ " comma at end of entry? ") . last-comma)
+ ("Replace double page dashes by single ones? " . page-dashes)
+ ("Delete whitespace at the beginning and end of fields? " . whitespace)
+ ("Inherit booktitle? " . inherit-booktitle)
+ ("Force delimiters? " . delimiters)
+ ("Unify case of entry types and field names? " . unify-case)
+ ("Enclose parts of field entries by braces? " . braces)
+ ("Replace parts of field entries by string constants? " . strings)
+ ("Sort fields? " . sort-fields))
+ '("formatting action" "formatting actions" "perform"))
+ (setq bibtex-reformat-previous-options (nreverse answers)))))
;; Do not include required-fields because `bibtex-reformat'
;; cannot handle the error messages of `bibtex-format-entry'.
;; Use `bibtex-validate' to check for required fields.
@@ -5059,7 +5095,7 @@ entries from minibuffer."
(list beg end
(lambda (s p a)
(cond
- ((eq a 'metadata) `(metadata (category . bibtex-key)))
+ ((eq a 'metadata) '(metadata (category . bibtex-key)))
(t (let ((completion-ignore-case nil))
(complete-with-action
a (bibtex-global-key-alist) s p)))))
@@ -5077,7 +5113,7 @@ entries from minibuffer."
(list beg end
(lambda (s p a)
(cond
- ((eq a 'metadata) `(metadata (category . bibtex-string)))
+ ((eq a 'metadata) '(metadata (category . bibtex-string)))
(t (let ((completion-ignore-case t))
(complete-with-action a compl s p)))))
:exit-function (bibtex-complete-string-cleanup compl))))))
diff --git a/lisp/textmodes/conf-mode.el b/lisp/textmodes/conf-mode.el
index ff0f56ebbb8..ad9f60fabca 100644
--- a/lisp/textmodes/conf-mode.el
+++ b/lisp/textmodes/conf-mode.el
@@ -1,4 +1,4 @@
-;;; conf-mode.el --- Simple major mode for editing conf/ini/properties files
+;;; conf-mode.el --- Simple major mode for editing conf/ini/properties files -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2019 Free Software Foundation, Inc.
@@ -230,7 +230,7 @@ This variable is best set in the file local variables, or through
(put 'conf-space-keywords 'safe-local-variable 'stringp)
(defvar conf-space-font-lock-keywords
- `(;; [section] (do this first because it may look like a parameter)
+ '(;; [section] (do this first because it may look like a parameter)
("^[ \t]*\\[\\(.+\\)\\]" 1 'font-lock-type-face)
;; section { ... } (do this first because it looks like a parameter)
("^[ \t]*\\(.+?\\)[ \t\n]*{[^{}]*?$" 1 'font-lock-type-face)
@@ -243,7 +243,7 @@ This variable is best set in the file local variables, or through
"Keywords to highlight in Conf Space mode.")
(defvar conf-colon-font-lock-keywords
- `(;; [section] (do this first because it may look like a parameter)
+ '(;; [section] (do this first because it may look like a parameter)
("^[ \t]*\\[\\(.+\\)\\]" 1 'font-lock-type-face)
;; var: val
("^[ \t]*\\(.+?\\)[ \t]*:"
@@ -281,10 +281,10 @@ whitespace.")
;; If anybody can figure out how to get the same effect by configuring
;; `align', I'd be glad to hear.
(defun conf-align-assignments (&optional arg)
- (interactive "P")
"Align the assignments in the buffer or active region.
In Transient Mark mode, if the mark is active, operate on the
contents of the region. Otherwise, operate on the whole buffer."
+ (interactive "P")
(setq arg (if arg
(prefix-numeric-value arg)
conf-assignment-column))
@@ -323,7 +323,7 @@ contents of the region. Otherwise, operate on the whole buffer."
(defun conf-quote-normal (arg)
"Set the syntax of \\=' and \" to punctuation.
-With prefix arg, only do it for \\=' if 1, or only for \" if 2.
+With prefix ARG, only do it for \\=' if 1, or only for \" if 2.
This only affects the current buffer. Some conf files use quotes
to delimit strings, while others allow quotes as simple parts of
the assigned value. In those files font locking will be wrong,
@@ -442,7 +442,7 @@ See also `conf-space-mode', `conf-colon-mode', `conf-javaprop-mode',
(run-mode-hooks 'conf-mode-hook)))
(defun conf-mode-initialize (comment &optional font-lock)
- "Initializations for sub-modes of conf-mode.
+ "Initializations for sub-modes of `conf-mode'.
COMMENT initializes `comment-start' and `comment-start-skip'.
The optional arg FONT-LOCK is the value for FONT-LOCK-KEYWORDS."
(set (make-local-variable 'comment-start) comment)
diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el
index 67a0c9f7a57..11a77b5bb78 100644
--- a/lisp/textmodes/css-mode.el
+++ b/lisp/textmodes/css-mode.el
@@ -34,9 +34,12 @@
(require 'cl-lib)
(require 'color)
+(require 'eww)
+(require 'imenu)
(require 'seq)
(require 'sgml-mode)
(require 'smie)
+(require 'thingatpt)
(eval-when-compile (require 'subr-x))
(defgroup css nil
@@ -109,7 +112,6 @@
("bottom" length percentage "auto")
("caption-side" "top" "bottom")
("clear" "none" "left" "right" "both")
- ("clip" shape "auto")
("content" "normal" "none" string uri counter "attr()"
"open-quote" "close-quote" "no-open-quote" "no-close-quote")
("counter-increment" identifier integer "none")
@@ -372,6 +374,31 @@
("orphans" integer)
("widows" integer)
+ ;; CSS Masking Module Level 1
+ ;; (https://www.w3.org/TR/css-masking-1/#property-index)
+ ("clip-path" clip-source basic-shape geometry-box "none")
+ ("clip-rule" "nonzero" "evenodd")
+ ("mask-image" mask-reference)
+ ("mask-mode" masking-mode)
+ ("mask-repeat" repeat-style)
+ ("mask-position" position)
+ ("mask-clip" geometry-box "no-clip")
+ ("mask-origin" geometry-box)
+ ("mask-size" bg-size)
+ ("mask-composite" compositing-operator)
+ ("mask" mask-layer)
+ ("mask-border-source" "none" image)
+ ("mask-border-mode" "luminance" "alpha")
+ ("mask-border-slice" number percentage "fill")
+ ("mask-border-width" length percentage number "auto")
+ ("mask-border-outset" length number)
+ ("mask-border-repeat" "stretch" "repeat" "round" "space")
+ ("mask-border" mask-border-source mask-border-slice
+ mask-border-width mask-border-outset mask-border-repeat
+ mask-border-mode)
+ ("mask-type" "luminance" "alpha")
+ ("clip" "rect()" "auto")
+
;; CSS Multi-column Layout Module
;; (https://www.w3.org/TR/css3-multicol/#property-index)
;; "break-after", "break-before", and "break-inside" are left out
@@ -649,14 +676,17 @@ further value candidates, since that list would be infinite.")
(attachment "scroll" "fixed" "local")
(auto-repeat "repeat()")
(auto-track-list line-names fixed-size fixed-repeat auto-repeat)
+ (basic-shape "inset()" "circle()" "ellipse()" "polygon()")
(bg-image image "none")
(bg-layer bg-image position repeat-style attachment box)
(bg-size length percentage "auto" "cover" "contain")
(box "border-box" "padding-box" "content-box")
+ (clip-source uri)
(color
"rgb()" "rgba()" "hsl()" "hsla()" named-color "transparent"
"currentColor")
(common-lig-values "common-ligatures" "no-common-ligatures")
+ (compositing-operator "add" "subtract" "intersect" "exclude")
(contextual-alt-values "contextual" "no-contextual")
(counter "counter()" "counters()")
(discretionary-lig-values
@@ -682,6 +712,7 @@ further value candidates, since that list would be infinite.")
(generic-family
"serif" "sans-serif" "cursive" "fantasy" "monospace")
(generic-voice "male" "female" "child")
+ (geometry-box shape-box "fill-box" "stroke-box" "view-box")
(gradient
linear-gradient radial-gradient repeating-linear-gradient
repeating-radial-gradient)
@@ -702,6 +733,12 @@ further value candidates, since that list would be infinite.")
(line-width length "thin" "medium" "thick")
(linear-gradient "linear-gradient()")
(margin-width "auto" length percentage)
+ (mask-layer
+ mask-reference masking-mode position bg-size repeat-style
+ geometry-box "no-clip" compositing-operator)
+ (mask-reference "none" image mask-source)
+ (mask-source uri)
+ (masking-mode "alpha" "luminance" "auto")
(named-color . ,(mapcar #'car css--color-map))
(number "calc()")
(numeric-figure-values "lining-nums" "oldstyle-nums")
@@ -717,7 +754,7 @@ further value candidates, since that list would be infinite.")
(repeating-linear-gradient "repeating-linear-gradient()")
(repeating-radial-gradient "repeating-radial-gradient()")
(shadow "inset" length color)
- (shape "rect()")
+ (shape-box box "margin-box")
(single-animation-direction
"normal" "reverse" "alternate" "alternate-reverse")
(single-animation-fill-mode "none" "forwards" "backwards" "both")
@@ -807,6 +844,7 @@ cannot be completed sensibly: `custom-ident',
(defvar css-mode-map
(let ((map (make-sparse-keymap)))
(define-key map [remap info-lookup-symbol] 'css-lookup-symbol)
+ (define-key map "\C-c\C-f" 'css-cycle-color-format)
map)
"Keymap used in `css-mode'.")
@@ -854,7 +892,7 @@ cannot be completed sensibly: `custom-ident',
(,(concat "@" css-ident-re) (0 font-lock-builtin-face))
;; Selectors.
;; Allow plain ":root" as a selector.
- ("^[ \t]*\\(:root\\)\\(?:[\n \t]*\\)*{" (1 'css-selector keep))
+ ("^[ \t]*\\(:root\\)[\n \t]*{" (1 'css-selector keep))
;; FIXME: attribute selectors don't work well because they may contain
;; strings which have already been highlighted as f-l-string-face and
;; thus prevent this highlighting from being applied (actually now that
@@ -877,7 +915,7 @@ cannot be completed sensibly: `custom-ident',
"\\(?:\\(:" (regexp-opt (append css-pseudo-class-ids
css-pseudo-element-ids)
t)
- "\\|\\::" (regexp-opt css-pseudo-element-ids t) "\\)"
+ "\\|::" (regexp-opt css-pseudo-element-ids t) "\\)"
"\\(?:([^)]+)\\)?"
(if (not sassy)
"[^:{}()\n]*"
@@ -897,7 +935,7 @@ cannot be completed sensibly: `custom-ident',
;; No face.
nil)))
;; Variables.
- (,(concat "--" css-ident-re) (0 font-lock-variable-name-face))
+ (,(concat (rx symbol-start) "--" css-ident-re) (0 font-lock-variable-name-face))
;; Properties. Again, we don't limit ourselves to css-property-ids.
(,(concat "\\(?:[{;]\\|^\\)[ \t]*\\("
"\\(?:\\(" css-proprietary-nmstart-re "\\)\\|"
@@ -937,11 +975,13 @@ cannot be completed sensibly: `custom-ident',
"Skip blanks and comments."
(while (forward-comment 1)))
-(cl-defun css--rgb-color ()
+(cl-defun css--rgb-color (&optional include-alpha)
"Parse a CSS rgb() or rgba() color.
Point should be just after the open paren.
Returns a hex RGB color, or nil if the color could not be recognized.
-This recognizes CSS-color-4 extensions."
+This recognizes CSS-color-4 extensions.
+When INCLUDE-ALPHA is non-nil, the alpha component is included in
+the returned hex string."
(let ((result '())
(iter 0))
(while (< iter 4)
@@ -951,11 +991,11 @@ This recognizes CSS-color-4 extensions."
(let* ((is-percent (match-beginning 1))
(str (match-string (if is-percent 1 2)))
(number (string-to-number str)))
- (when is-percent
- (setq number (* 255 (/ number 100.0))))
- ;; Don't push the alpha.
- (when (< iter 3)
- (push (min (max 0 (truncate number)) 255) result))
+ (if is-percent
+ (setq number (* 255 (/ number 100.0)))
+ (when (and include-alpha (= iter 3))
+ (setq number (* number 255))))
+ (push (min (max 0 (round number)) 255) result)
(goto-char (match-end 0))
(css--color-skip-blanks)
(cl-incf iter)
@@ -967,7 +1007,11 @@ This recognizes CSS-color-4 extensions."
(css--color-skip-blanks)))
(when (looking-at ")")
(forward-char)
- (apply #'format "#%02x%02x%02x" (nreverse result)))))
+ (apply #'format
+ (if (and include-alpha (= (length result) 4))
+ "#%02x%02x%02x%02x"
+ "#%02x%02x%02x")
+ (nreverse result)))))
(cl-defun css--hsl-color ()
"Parse a CSS hsl() or hsla() color.
@@ -1038,9 +1082,15 @@ This recognizes CSS-color-4 extensions."
STR is the incoming CSS hex color.
This function simply drops any transparency."
;; Either #RGB or #RRGGBB, drop the "A" or "AA".
- (if (> (length str) 5)
- (substring str 0 7)
- (substring str 0 4)))
+ (substring str 0 (if (> (length str) 5) 7 4)))
+
+(defun css--hex-alpha (hex)
+ "Return the alpha component of CSS color HEX.
+HEX can either be in the #RGBA or #RRGGBBAA format. Return nil
+if the color doesn't have an alpha component."
+ (cl-case (length hex)
+ (5 (string (elt hex 4)))
+ (9 (substring hex 7 9))))
(defun css--named-color (start-point str)
"Check whether STR, seen at point, is CSS named color.
@@ -1200,19 +1250,20 @@ for determining whether point is within a selector."
(defun css-smie-rules (kind token)
(pcase (cons kind token)
- (`(:elem . basic) css-indent-offset)
- (`(:elem . arg) 0)
- (`(:list-intro . ,(or `";" `"")) t) ;"" stands for BOB (bug#15467).
- (`(:before . "{")
+ ('(:elem . basic) css-indent-offset)
+ ('(:elem . arg) 0)
+ ;; "" stands for BOB (bug#15467).
+ (`(:list-intro . ,(or ";" "" ":-property")) t)
+ ('(:before . "{")
(when (or (smie-rule-hanging-p) (smie-rule-bolp))
(smie-backward-sexp ";")
(unless (eq (char-after) ?\{)
(smie-indent-virtual))))
- (`(:before . "(")
+ ('(:before . "(")
(cond
((smie-rule-hanging-p) (smie-rule-parent 0))
((not (smie-rule-bolp)) 0)))
- (`(:after . ":-property")
+ ('(:after . ":-property")
(when (smie-rule-hanging-p)
css-indent-offset))))
@@ -1384,6 +1435,171 @@ tags, classes and IDs."
(progn (insert ": ;")
(forward-char -1))))))))))
+(defun css--color-to-4-dpc (hex)
+ "Convert the CSS color HEX to four digits per component.
+CSS colors use one or two digits per component for RGB hex
+values. Convert the given color to four digits per component.
+
+Note that this function handles CSS colors specifically, and
+should not be mixed with those in color.el."
+ (let ((six-digits (= (length hex) 7)))
+ (apply
+ #'concat
+ `("#"
+ ,@(seq-mapcat
+ (apply-partially #'make-list (if six-digits 2 4))
+ (seq-partition (seq-drop hex 1) (if six-digits 2 1)))))))
+
+(defun css--format-hex (hex)
+ "Format a CSS hex color by shortening it if possible."
+ (let ((parts (seq-partition (seq-drop hex 1) 2)))
+ (if (and (>= (length hex) 6)
+ (seq-every-p (lambda (p) (eq (elt p 0) (elt p 1))) parts))
+ (apply #'string
+ (cons ?# (mapcar (lambda (p) (elt p 0)) parts)))
+ hex)))
+
+(defun css--named-color-to-hex ()
+ "Convert named CSS color at point to hex format.
+Return non-nil if a conversion was made.
+
+Note that this function handles CSS colors specifically, and
+should not be mixed with those in color.el."
+ (save-excursion
+ (unless (or (looking-at css--colors-regexp)
+ (eq (char-before) ?#))
+ (backward-word))
+ (when (member (word-at-point) (mapcar #'car css--color-map))
+ (looking-at css--colors-regexp)
+ (let ((color (css--compute-color (point) (match-string 0))))
+ (replace-match (css--format-hex color)))
+ t)))
+
+(defun css--format-rgba-alpha (alpha)
+ "Return ALPHA component formatted for use in rgba()."
+ (let ((a (string-to-number (format "%.2f" alpha))))
+ (if (or (= a 0)
+ (= a 1))
+ (format "%d" a)
+ (string-remove-suffix "0" (number-to-string a)))))
+
+(defun css--hex-to-rgb ()
+ "Convert CSS hex color at point to RGB format.
+Return non-nil if a conversion was made.
+
+Note that this function handles CSS colors specifically, and
+should not be mixed with those in color.el."
+ (save-excursion
+ (unless (or (eq (char-after) ?#)
+ (eq (char-before) ?\())
+ (backward-sexp))
+ (when-let* ((hex (when (looking-at css--colors-regexp)
+ (and (eq (elt (match-string 0) 0) ?#)
+ (match-string 0))))
+ (rgb (css--hex-color hex)))
+ (seq-let (r g b)
+ (mapcar (lambda (x) (round (* x 255)))
+ (color-name-to-rgb (css--color-to-4-dpc rgb)))
+ (replace-match
+ (if-let* ((alpha (css--hex-alpha hex))
+ (a (css--format-rgba-alpha
+ (/ (string-to-number alpha 16)
+ (float (- (expt 16 (length alpha)) 1))))))
+ (format "rgba(%d, %d, %d, %s)" r g b a)
+ (format "rgb(%d, %d, %d)" r g b))
+ t))
+ t)))
+
+(defun css--rgb-to-named-color-or-hex ()
+ "Convert CSS RGB color at point to a named color or hex format.
+Convert to a named color if the color at point has a name, else
+convert to hex format. Return non-nil if a conversion was made.
+
+Note that this function handles CSS colors specifically, and
+should not be mixed with those in color.el."
+ (save-excursion
+ (when-let* ((open-paren-pos (nth 1 (syntax-ppss))))
+ (when (save-excursion
+ (goto-char open-paren-pos)
+ (looking-back "rgba?" (- (point) 4)))
+ (goto-char (nth 1 (syntax-ppss)))))
+ (when (eq (char-before) ?\))
+ (backward-sexp))
+ (skip-chars-backward "rgba")
+ (when (looking-at css--colors-regexp)
+ (let* ((start (match-end 0))
+ (color (save-excursion
+ (goto-char start)
+ (css--rgb-color t))))
+ (when color
+ (kill-sexp)
+ (kill-sexp)
+ (let ((named-color (seq-find (lambda (x) (equal (cdr x) color))
+ css--color-map)))
+ (insert (if named-color
+ (car named-color)
+ (css--format-hex color))))
+ t)))))
+
+(defun css-cycle-color-format ()
+ "Cycle the color at point between different CSS color formats.
+Supported formats are by name (if possible), hexadecimal, and
+rgb()/rgba()."
+ (interactive)
+ (or (css--named-color-to-hex)
+ (css--hex-to-rgb)
+ (css--rgb-to-named-color-or-hex)
+ (message "It doesn't look like a color at point")))
+
+(defun css--join-nested-selectors (selectors)
+ "Join a list of nested CSS selectors."
+ (let ((processed '())
+ (prev nil))
+ (dolist (sel selectors)
+ (cond
+ ((seq-contains-p sel ?&)
+ (setq sel (replace-regexp-in-string "&" prev sel))
+ (pop processed))
+ ;; Unless this is the first selector, separate this one and the
+ ;; previous one by a space.
+ (processed
+ (push " " processed)))
+ (push sel processed)
+ (setq prev sel))
+ (apply #'concat (nreverse processed))))
+
+(defun css--prev-index-position ()
+ (when (nth 7 (syntax-ppss))
+ (goto-char (comment-beginning)))
+ (forward-comment (- (point)))
+ (when (search-backward "{" (point-min) t)
+ (if (re-search-backward "}\\|;\\|{" (point-min) t)
+ (forward-char)
+ (goto-char (point-min)))
+ (forward-comment (point-max))
+ (save-excursion (re-search-forward "[^{;]*"))))
+
+(defun css--extract-index-name ()
+ (save-excursion
+ (let ((res (list (match-string-no-properties 0))))
+ (condition-case nil
+ (while t
+ (goto-char (nth 1 (syntax-ppss)))
+ (if (re-search-backward "}\\|;\\|{" (point-min) t)
+ (forward-char)
+ (goto-char (point-min)))
+ (forward-comment (point-max))
+ (when (save-excursion
+ (re-search-forward "[^{;]*"))
+ (push (match-string-no-properties 0) res)))
+ (error
+ (css--join-nested-selectors
+ (mapcar
+ (lambda (s)
+ (string-trim
+ (replace-regexp-in-string "[\n ]+" " " s)))
+ res)))))))
+
;;;###autoload
(define-derived-mode css-mode prog-mode "CSS"
"Major mode to edit Cascading Style Sheets (CSS).
@@ -1422,7 +1638,13 @@ be used to fill comments.
(append css-electric-keys electric-indent-chars))
(setq-local font-lock-fontify-region-function #'css--fontify-region)
(add-hook 'completion-at-point-functions
- #'css-completion-at-point nil 'local))
+ #'css-completion-at-point nil 'local)
+ ;; The default "." creates ambiguity with class selectors.
+ (setq-local imenu-space-replacement " ")
+ (setq-local imenu-prev-index-position-function
+ #'css--prev-index-position)
+ (setq-local imenu-extract-index-name-function
+ #'css--extract-index-name))
(defvar comment-continue)
@@ -1519,12 +1741,8 @@ be used to fill comments.
(defun css-current-defun-name ()
"Return the name of the CSS section at point, or nil."
(save-excursion
- (let ((max (max (point-min) (- (point) 1600)))) ; approx 20 lines back
- (when (search-backward "{" max t)
- (skip-chars-backward " \t\r\n")
- (beginning-of-line)
- (if (looking-at "^[ \t]*\\([^{\r\n]*[^ {\t\r\n]\\)")
- (match-string-no-properties 1))))))
+ (when (css--prev-index-position)
+ (css--extract-index-name))))
;;; SCSS mode
diff --git a/lisp/textmodes/dns-mode.el b/lisp/textmodes/dns-mode.el
index 5344d6127fe..1dbc7bd7351 100644
--- a/lisp/textmodes/dns-mode.el
+++ b/lisp/textmodes/dns-mode.el
@@ -45,6 +45,8 @@
;;; Code:
+(eval-when-compile (require 'cl-lib))
+
(defgroup dns-mode nil
"DNS master file mode configuration."
:group 'data)
@@ -112,9 +114,9 @@
"26.1" 'set)
(defcustom dns-mode-font-lock-keywords
- `((,(concat "^$" (regexp-opt dns-mode-control-entities))
+ `((,(concat "^\\$" (regexp-opt dns-mode-control-entities))
0 ,dns-mode-control-entity-face)
- ("^$[a-z0-9A-Z]+" 0 ,dns-mode-bad-control-entity-face)
+ ("^\\$[a-z0-9A-Z]+" 0 ,dns-mode-bad-control-entity-face)
(,(regexp-opt dns-mode-classes) 0 ,dns-mode-class-face)
(,(regexp-opt dns-mode-types) 0 ,dns-mode-type-face))
"Font lock keywords used to highlight text in DNS master file mode."
@@ -290,9 +292,9 @@ Examples:
(skip-syntax-backward " ")
(skip-syntax-backward "w_.")
(re-search-forward "\\([[:xdigit:]:]+\\)\\(/-?[0-9]\\{2,3\\}\\)?")
- (kill-new (match-string 0))
(let ((address (match-string 1))
(prefix-length (match-string 2)))
+ (kill-new (match-string 0))
(when prefix-length
(setq prefix-length (string-to-number (substring prefix-length 1)))
(if negate-prefix
diff --git a/lisp/textmodes/enriched.el b/lisp/textmodes/enriched.el
index d4e2f788ee3..e89ffead9e8 100644
--- a/lisp/textmodes/enriched.el
+++ b/lisp/textmodes/enriched.el
@@ -120,9 +120,11 @@ expression, which is evaluated to get the string to insert.")
;; The following are not part of the standard:
(FUNCTION (enriched-decode-foreground "x-color")
(enriched-decode-background "x-bg-color")
- (enriched-decode-display-prop "x-display"))
+ (enriched-decode-display-prop "x-display")
+ (enriched-decode-charset "x-charset"))
(read-only (t "x-read-only"))
(display (nil enriched-handle-display-prop))
+ (charset (nil enriched-handle-charset-prop))
(unknown (nil format-annotate-value))
; (font-size (2 "bigger") ; unimplemented
; (-2 "smaller"))
@@ -208,10 +210,6 @@ The value is a list of \(VAR VALUE VAR VALUE...).")
These are files with embedded formatting information in the MIME standard
text/enriched format.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
-
Turning the mode on or off runs `enriched-mode-hook'.
More information about Enriched mode is available in the file
@@ -492,6 +490,21 @@ Return value is \(begin end name positive-p), or nil if none was found."
(list from to 'face (list ':background color))
(message "Warning: no color specified for <x-bg-color>")
nil))
+
+(defun enriched-decode-charset (from to &optional cset)
+ (let ((cs (when (stringp cset)
+ (condition-case ()
+ (car (read-from-string cset))
+ (error nil)))))
+ (unless cs
+ (message "Warning: invalid <x-charset> parameter %s" cset))
+ (list from to 'charset cs)))
+
+(defun enriched-handle-charset-prop (old new)
+ "Return a list of annotations for a change in the `charset' property."
+ (cons (and old (list (list "x-charset" (symbol-name old))))
+ (and new (list (list "x-charset" (symbol-name new))))))
+
;;; Handling the `display' property.
diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el
index c5975bb721b..c285491a305 100644
--- a/lisp/textmodes/fill.el
+++ b/lisp/textmodes/fill.el
@@ -129,10 +129,11 @@ if it would act as a paragraph-starter on the second line."
:type 'regexp
:group 'fill)
-(defcustom adaptive-fill-function nil
- "Function to call to choose a fill prefix for a paragraph, or nil.
-A nil value means the function has not determined the fill prefix."
- :type '(choice (const nil) function)
+(defcustom adaptive-fill-function #'ignore
+ "Function to call to choose a fill prefix for a paragraph.
+A nil return value means the function has not determined the fill prefix."
+ :version "27.1"
+ :type 'function
:group 'fill)
(defvar fill-indent-according-to-mode nil ;Screws up CC-mode's filling tricks.
@@ -339,6 +340,18 @@ places."
(and (memq (preceding-char) '(?\t ?\s))
(eq (char-syntax (following-char)) ?w)))))))
+(defun fill-polish-nobreak-p ()
+ "Return nil if Polish style allows breaking the line at point.
+This function may be used in the `fill-nobreak-predicate' hook.
+It is almost the same as `fill-single-char-nobreak-p', with the
+exception that it does not require the one-letter word to be
+preceded by a space. This blocks line-breaking in cases like
+\"(a jednak)\"."
+ (save-excursion
+ (skip-chars-backward " \t")
+ (backward-char 2)
+ (looking-at "[^[:alpha:]]\\cl")))
+
(defun fill-single-char-nobreak-p ()
"Return non-nil if a one-letter word is before point.
This function is suitable for adding to the hook `fill-nobreak-predicate',
diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el
index 042f432d635..d18916dfd01 100644
--- a/lisp/textmodes/flyspell.el
+++ b/lisp/textmodes/flyspell.el
@@ -68,6 +68,12 @@ Detection of repeated words is not implemented in
:group 'flyspell
:type 'boolean)
+(defcustom flyspell-case-fold-duplications t
+ "Non-nil means Flyspell matches duplicate words case-insensitively."
+ :group 'flyspell
+ :type 'boolean
+ :version "27.1")
+
(defcustom flyspell-mark-duplications-exceptions
'((nil . ("that" "had")) ; Common defaults for English.
("\\`francais" . ("nous" "vous")))
@@ -324,14 +330,16 @@ If this variable is nil, all regions are treated as small."
;;* (lambda () (setq flyspell-generic-check-word-predicate */
;;* 'mail-mode-flyspell-verify))) */
;;*---------------------------------------------------------------------*/
+
+(define-obsolete-variable-alias 'flyspell-generic-check-word-p
+ 'flyspell-generic-check-word-predicate "25.1")
+
(defvar flyspell-generic-check-word-predicate nil
"Function providing per-mode customization over which words are flyspelled.
Returns t to continue checking, nil otherwise.
Flyspell mode sets this variable to whatever is the `flyspell-mode-predicate'
property of the major mode name.")
(make-variable-buffer-local 'flyspell-generic-check-word-predicate)
-(define-obsolete-variable-alias 'flyspell-generic-check-word-p
- 'flyspell-generic-check-word-predicate "25.1")
;;*--- mail mode -------------------------------------------------------*/
(put 'mail-mode 'flyspell-mode-predicate 'mail-mode-flyspell-verify)
@@ -506,9 +514,6 @@ See also `flyspell-duplicate-distance'."
;;;###autoload
(define-minor-mode flyspell-mode
"Toggle on-the-fly spell checking (Flyspell mode).
-With a prefix argument ARG, enable Flyspell mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Flyspell mode is a buffer-local minor mode. When enabled, it
spawns a single Ispell process and checks each word. The default
@@ -924,7 +929,7 @@ Mostly we check word delimiters."
(or (string= "" ispell-otherchars)
(not (looking-at ispell-otherchars)))
(or flyspell-consider-dash-as-word-delimiter-flag
- (not (looking-at "\\-")))
+ (not (looking-at "-")))
2)))))
(format " because : %S\n"
(cond
@@ -942,7 +947,7 @@ Mostly we check word delimiters."
(or (string= "" ispell-otherchars)
(not (looking-at ispell-otherchars)))
(or flyspell-consider-dash-as-word-delimiter-flag
- (not (looking-at "\\-")))))))
+ (not (looking-at "-")))))))
;; Yes because we have reached or typed a word delimiter.
'separator)
((not (integerp flyspell-delay))
@@ -985,6 +990,11 @@ Mostly we check word delimiters."
(let ((command this-command)
;; Prevent anything we do from affecting the mark.
deactivate-mark)
+ (if (and (eq command 'transpose-chars)
+ flyspell-pre-point)
+ (save-excursion
+ (goto-char (- flyspell-pre-point 1))
+ (flyspell-word)))
(if (flyspell-check-pre-word-p)
(save-excursion
'(flyspell-debug-signal-pre-word-checked)
@@ -1150,7 +1160,8 @@ spell-check."
(- (save-excursion
(skip-chars-backward " \t\n\f")))))
(p (when (>= bound (point-min))
- (flyspell-word-search-backward word bound t))))
+ (flyspell-word-search-backward
+ word bound flyspell-case-fold-duplications))))
(and p (/= p start)))))
;; yes, this is a doublon
(flyspell-highlight-incorrect-region start end 'doublon)
diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el
index 237997d41d7..6553a2799bb 100644
--- a/lisp/textmodes/ispell.el
+++ b/lisp/textmodes/ispell.el
@@ -320,18 +320,21 @@ The following values are supported:
:type 'boolean
:group 'ispell)
+(defvaralias 'ispell-format-word 'ispell-format-word-function)
+
(defcustom ispell-format-word-function (function upcase)
"Formatting function for displaying word being spell checked.
The function must take one string argument and return a string."
:type 'function
:group 'ispell)
-(defvaralias 'ispell-format-word 'ispell-format-word-function)
+;; FIXME framepop.el last updated c 2003 (?),
+;; probably something else replaces it these days.
(defcustom ispell-use-framepop-p nil
"When non-nil ispell uses framepop to display choices in a dedicated frame.
You can set this variable to dynamically use framepop if you are in a
window system by evaluating the following on startup to set this variable:
- (and window-system (condition-case () (require \\='framepop) (error nil)))"
+ (and (display-graphic-p) (require \\='framepop nil t))"
:type 'boolean
:group 'ispell)
@@ -815,16 +818,6 @@ See `ispell-buffer-with-debug' for an example of use."
;; because otherwise this file gets autoloaded every time Emacs starts
;; so that it can set up the menus and determine keyboard equivalents.
-;;;###autoload
-(defvar ispell-menu-map nil "Key map for ispell menu.")
-;; Redo menu when loading ispell to get dictionary modifications
-(setq ispell-menu-map nil)
-
-;;; Set up dictionary
-;;;###autoload
-(defvar ispell-menu-map-needed
- (unless ispell-menu-map 'reload))
-
(defvar ispell-library-directory (condition-case ()
(ispell-check-version)
(error nil))
@@ -1193,6 +1186,12 @@ dictionary from that list was found."
;; Parse and set values for default dictionary.
(setq hunspell-default-dict (or hunspell-multi-dict
(car hunspell-default-dict)))
+ ;; If hunspell-default-dict is nil, ispell-parse-hunspell-affix-file
+ ;; will barf with an error message that doesn't help users figure
+ ;; out what is wrong. Produce an error message that points to the
+ ;; root cause of the problem.
+ (or hunspell-default-dict
+ (error "Can't find Hunspell dictionary with a .aff affix file"))
(setq hunspell-default-dict-entry
(ispell-parse-hunspell-affix-file hunspell-default-dict))
;; Create an alist of found dicts with only names, except for default dict.
@@ -1215,9 +1214,11 @@ Internal use.")
(with-output-to-string
(with-current-buffer
standard-output
- (apply 'ispell-call-process
- (replace-regexp-in-string "enchant\\(-[0-9]\\)?$" "enchant-lsmod\\1"
- ispell-program-name) nil t nil args))))
+ (apply #'ispell-call-process
+ (replace-regexp-in-string "enchant\\(-[0-9]\\)?\\'"
+ "enchant-lsmod\\1"
+ ispell-program-name)
+ nil t nil args))))
(defun ispell--get-extra-word-characters (&optional lang)
"Get the extra word characters for LANG as a character class.
@@ -1272,7 +1273,6 @@ aspell is used along with Emacs).")
(defun ispell-set-spellchecker-params ()
"Initialize some spellchecker parameters when changed or first used."
(unless (eq ispell-last-program-name ispell-program-name)
- (setq ispell-last-program-name ispell-program-name)
(ispell-kill-ispell t)
(if (and (condition-case ()
(progn
@@ -1387,7 +1387,8 @@ aspell is used along with Emacs).")
(nth 7 adict)))
adict)
tmp-dicts-alist :test #'equal))
- (setq ispell-dictionary-alist tmp-dicts-alist))))
+ (setq ispell-dictionary-alist tmp-dicts-alist)))
+ (setq ispell-last-program-name ispell-program-name))
(defun ispell-valid-dictionary-list ()
"Return a list of valid dictionaries.
@@ -1425,80 +1426,78 @@ The variable `ispell-library-directory' defines their location."
(push name dict-list)))
dict-list))
-;; Define commands in menu in opposite order you want them to appear.
;;;###autoload
-(if ispell-menu-map-needed
- (progn
- (setq ispell-menu-map (make-sparse-keymap "Spell"))
- (define-key ispell-menu-map [ispell-change-dictionary]
- `(menu-item ,(purecopy "Change Dictionary...") ispell-change-dictionary
- :help ,(purecopy "Supply explicit dictionary file name")))
- (define-key ispell-menu-map [ispell-kill-ispell]
- `(menu-item ,(purecopy "Kill Process")
- (lambda () (interactive) (ispell-kill-ispell nil 'clear))
- :enable (and (boundp 'ispell-process) ispell-process
- (eq (ispell-process-status) 'run))
- :help ,(purecopy "Terminate Ispell subprocess")))
- (define-key ispell-menu-map [ispell-pdict-save]
- `(menu-item ,(purecopy "Save Dictionary")
- (lambda () (interactive) (ispell-pdict-save t t))
- :help ,(purecopy "Save personal dictionary")))
- (define-key ispell-menu-map [ispell-customize]
- `(menu-item ,(purecopy "Customize...")
- (lambda () (interactive) (customize-group 'ispell))
- :help ,(purecopy "Customize spell checking options")))
- (define-key ispell-menu-map [ispell-help]
- ;; use (x-popup-menu last-nonmenu-event(list "" ispell-help-list)) ?
- `(menu-item ,(purecopy "Help")
- (lambda () (interactive) (describe-function 'ispell-help))
- :help ,(purecopy "Show standard Ispell keybindings and commands")))
- (define-key ispell-menu-map [flyspell-mode]
- `(menu-item ,(purecopy "Automatic spell checking (Flyspell)")
- flyspell-mode
- :help ,(purecopy "Check spelling while you edit the text")
- :button (:toggle . (bound-and-true-p flyspell-mode))))
- (define-key ispell-menu-map [ispell-complete-word]
- `(menu-item ,(purecopy "Complete Word") ispell-complete-word
- :help ,(purecopy "Complete word at cursor using dictionary")))
- (define-key ispell-menu-map [ispell-complete-word-interior-frag]
- `(menu-item ,(purecopy "Complete Word Fragment")
- ispell-complete-word-interior-frag
- :help ,(purecopy "Complete word fragment at cursor")))))
-
-;;;###autoload
-(if ispell-menu-map-needed
- (progn
- (define-key ispell-menu-map [ispell-continue]
- `(menu-item ,(purecopy "Continue Spell-Checking") ispell-continue
- :enable (and (boundp 'ispell-region-end)
- (marker-position ispell-region-end)
- (equal (marker-buffer ispell-region-end)
- (current-buffer)))
- :help ,(purecopy "Continue spell checking last region")))
- (define-key ispell-menu-map [ispell-word]
- `(menu-item ,(purecopy "Spell-Check Word") ispell-word
- :help ,(purecopy "Spell-check word at cursor")))
- (define-key ispell-menu-map [ispell-comments-and-strings]
- `(menu-item ,(purecopy "Spell-Check Comments")
- ispell-comments-and-strings
- :help ,(purecopy "Spell-check only comments and strings")))))
-
+(defconst ispell-menu-map
+ ;; Use `defconst' so as to redo the menu when loading ispell, like the
+ ;; previous code did.
+
+ ;; Define commands in menu in opposite order you want them to appear.
+ (let ((map (make-sparse-keymap "Spell")))
+ (define-key map [ispell-change-dictionary]
+ `(menu-item ,(purecopy "Change Dictionary...") ispell-change-dictionary
+ :help ,(purecopy "Supply explicit dictionary file name")))
+ (define-key map [ispell-kill-ispell]
+ `(menu-item ,(purecopy "Kill Process")
+ (lambda () (interactive) (ispell-kill-ispell nil 'clear))
+ :enable (and (boundp 'ispell-process) ispell-process
+ (eq (ispell-process-status) 'run))
+ :help ,(purecopy "Terminate Ispell subprocess")))
+ (define-key map [ispell-pdict-save]
+ `(menu-item ,(purecopy "Save Dictionary")
+ (lambda () (interactive) (ispell-pdict-save t t))
+ :help ,(purecopy "Save personal dictionary")))
+ (define-key map [ispell-customize]
+ `(menu-item ,(purecopy "Customize...")
+ (lambda () (interactive) (customize-group 'ispell))
+ :help ,(purecopy "Customize spell checking options")))
+ (define-key map [ispell-help]
+ ;; use (x-popup-menu last-nonmenu-event(list "" ispell-help-list)) ?
+ `(menu-item ,(purecopy "Help")
+ (lambda () (interactive) (describe-function 'ispell-help))
+ :help ,(purecopy "Show standard Ispell keybindings and commands")))
+ (define-key map [flyspell-mode]
+ `(menu-item ,(purecopy "Automatic spell checking (Flyspell)")
+ flyspell-mode
+ :help ,(purecopy "Check spelling while you edit the text")
+ :button (:toggle . (bound-and-true-p flyspell-mode))))
+ (define-key map [ispell-complete-word]
+ `(menu-item ,(purecopy "Complete Word") ispell-complete-word
+ :help ,(purecopy "Complete word at cursor using dictionary")))
+ (define-key map [ispell-complete-word-interior-frag]
+ `(menu-item ,(purecopy "Complete Word Fragment")
+ ispell-complete-word-interior-frag
+ :help ,(purecopy "Complete word fragment at cursor")))
+
+ (define-key map [ispell-continue]
+ `(menu-item ,(purecopy "Continue Spell-Checking") ispell-continue
+ :enable (and (boundp 'ispell-region-end)
+ (marker-position ispell-region-end)
+ (equal (marker-buffer ispell-region-end)
+ (current-buffer)))
+ :help ,(purecopy "Continue spell checking last region")))
+ (define-key map [ispell-word]
+ `(menu-item ,(purecopy "Spell-Check Word") ispell-word
+ :help ,(purecopy "Spell-check word at cursor")))
+ (define-key map [ispell-comments-and-strings]
+ `(menu-item ,(purecopy "Spell-Check Comments")
+ ispell-comments-and-strings
+ :help ,(purecopy "Spell-check only comments and strings")))
+
+ (define-key map [ispell-region]
+ `(menu-item ,(purecopy "Spell-Check Region") ispell-region
+ :enable mark-active
+ :help ,(purecopy "Spell-check text in marked region")))
+ (define-key map [ispell-message]
+ `(menu-item ,(purecopy "Spell-Check Message") ispell-message
+ :visible (eq major-mode 'mail-mode)
+ :help ,(purecopy "Skip headers and included message text")))
+ (define-key map [ispell-buffer]
+ `(menu-item ,(purecopy "Spell-Check Buffer") ispell-buffer
+ :help ,(purecopy "Check spelling of selected buffer")))
+ map)
+ "Key map for ispell menu.")
;;;###autoload
-(if ispell-menu-map-needed
- (progn
- (define-key ispell-menu-map [ispell-region]
- `(menu-item ,(purecopy "Spell-Check Region") ispell-region
- :enable mark-active
- :help ,(purecopy "Spell-check text in marked region")))
- (define-key ispell-menu-map [ispell-message]
- `(menu-item ,(purecopy "Spell-Check Message") ispell-message
- :visible (eq major-mode 'mail-mode)
- :help ,(purecopy "Skip headers and included message text")))
- (define-key ispell-menu-map [ispell-buffer]
- `(menu-item ,(purecopy "Spell-Check Buffer") ispell-buffer
- :help ,(purecopy "Check spelling of selected buffer")))
- (fset 'ispell-menu-map (symbol-value 'ispell-menu-map))))
-
+(fset 'ispell-menu-map (symbol-value 'ispell-menu-map))
;;; **********************************************************************
@@ -1791,11 +1790,15 @@ You can set this variable in hooks in your init file -- eg:
(defun ispell-accept-output (&optional timeout-secs timeout-msecs)
- "Wait for output from Ispell process, or TIMEOUT-SECS and TIMEOUT-MSECS.
+ "Wait for output from Ispell process, or for TIMEOUT-SECS + TIMEOUT-MSECS.
+\(The TIMEOUT-MSECS argument is obsolete and should be avoided.)
If asynchronous subprocesses are not supported, call function `ispell-filter'
and pass it the output of the last Ispell invocation."
(if ispell-async-processp
- (accept-process-output ispell-process timeout-secs timeout-msecs)
+ (let ((timeout (if timeout-msecs
+ (+ (or timeout-secs 0) (/ timeout-msecs 1000.0))
+ timeout-secs)))
+ (accept-process-output ispell-process timeout))
(if (null ispell-process)
(error "No Ispell process to read output from!")
(let ((buf ispell-output-buffer)
@@ -1840,11 +1843,9 @@ Only works for Aspell and Enchant."
(setq default-directory defdir)
(insert string)
(if (not (memq cmd cmds-to-defer))
- (let (coding-system-for-read coding-system-for-write status)
- (if (and (boundp 'enable-multibyte-characters)
- enable-multibyte-characters)
- (setq coding-system-for-read (ispell-get-coding-system)
- coding-system-for-write (ispell-get-coding-system)))
+ (let* ((coding-system-for-read (ispell-get-coding-system))
+ (coding-system-for-write coding-system-for-read)
+ status)
(set-buffer output-buf)
(erase-buffer)
(set-buffer session-buf)
@@ -3474,7 +3475,7 @@ Returns the sum SHIFT due to changes in word replacements."
;; Error in tex mode when a potential math mode change exists.
(if (and replace (listp replace) (= 2 (length replace)))
(if (and (eq ispell-parser 'tex)
- (string-match "[\\\\][]()[]\\|\\\\begin\\|\\$"
+ (string-match "[\\][]()[]\\|\\\\begin\\|\\$"
(regexp-quote string)))
(error
"Don't start query replace on a line with math characters"
@@ -3718,9 +3719,6 @@ available on the net."
;;;###autoload
(define-minor-mode ispell-minor-mode
"Toggle last-word spell checking (Ispell minor mode).
-With a prefix argument ARG, enable Ispell minor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Ispell minor mode is a buffer-local minor mode. When enabled,
typing SPC or RET warns you if the previous word is incorrectly
diff --git a/lisp/textmodes/less-css-mode.el b/lisp/textmodes/less-css-mode.el
index b4c7f28985d..4077789eb12 100644
--- a/lisp/textmodes/less-css-mode.el
+++ b/lisp/textmodes/less-css-mode.el
@@ -194,10 +194,10 @@ directory by default."
;; - custom faces.
(defconst less-css-font-lock-keywords
'(;; Variables
- ("@[a-z_-][a-z-_0-9]*" . font-lock-variable-name-face)
+ ("@[a-z_-][a-z_0-9-]*" . font-lock-variable-name-face)
("&" . font-lock-preprocessor-face)
;; Mixins
- ("\\(?:[ \t{;]\\|^\\)\\(\\.[a-z_-][a-z-_0-9]*\\)[ \t]*;" .
+ ("\\(?:[ \t{;]\\|^\\)\\(\\.[a-z_-][a-z_0-9-]*\\)[ \t]*;" .
(1 font-lock-keyword-face))))
(defvar less-css-mode-syntax-table
diff --git a/lisp/textmodes/mhtml-mode.el b/lisp/textmodes/mhtml-mode.el
index 17298ccf5f7..7de24c783f0 100644
--- a/lisp/textmodes/mhtml-mode.el
+++ b/lisp/textmodes/mhtml-mode.el
@@ -21,7 +21,9 @@
;;; Code:
-(eval-and-compile (require 'sgml-mode))
+(eval-and-compile
+ (require 'cl-lib)
+ (require 'sgml-mode))
(require 'js)
(require 'css-mode)
(require 'prog-mode)
@@ -363,7 +365,6 @@ Code inside a <script> element is indented using the rules from
`js-mode'; and code inside a <style> element is indented using
the rules from `css-mode'."
(setq-local indent-line-function #'mhtml-indent-line)
- (setq-local parse-sexp-lookup-properties t)
(setq-local syntax-propertize-function #'mhtml-syntax-propertize)
(setq-local font-lock-fontify-region-function
#'mhtml--submode-fontify-region)
diff --git a/lisp/textmodes/nroff-mode.el b/lisp/textmodes/nroff-mode.el
index e5cc39d54f6..f33d4df4d19 100644
--- a/lisp/textmodes/nroff-mode.el
+++ b/lisp/textmodes/nroff-mode.el
@@ -298,9 +298,6 @@ automatically inserts the matching closing request after point."
(define-minor-mode nroff-electric-mode
"Toggle automatic nroff request pairing (Nroff Electric mode).
-With a prefix argument ARG, enable Nroff Electric mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Nroff Electric mode is a buffer-local minor mode, for use with
`nroff-mode'. When enabled, Emacs checks for an nroff request at
@@ -328,13 +325,6 @@ otherwise off."
(kill-buffer viewbuf))
(Man-getpage-in-background file)))
-;; Old names that were not namespace clean.
-(define-obsolete-function-alias 'count-text-lines 'nroff-count-text-lines "22.1")
-(define-obsolete-function-alias 'forward-text-line 'nroff-forward-text-line "22.1")
-(define-obsolete-function-alias 'backward-text-line 'nroff-backward-text-line "22.1")
-(define-obsolete-function-alias 'electric-nroff-newline 'nroff-electric-newline "22.1")
-(define-obsolete-function-alias 'electric-nroff-mode 'nroff-electric-mode "22.1")
-
(provide 'nroff-mode)
;;; nroff-mode.el ends here
diff --git a/lisp/textmodes/page-ext.el b/lisp/textmodes/page-ext.el
index a9199fffe0d..23e2d28f77e 100644
--- a/lisp/textmodes/page-ext.el
+++ b/lisp/textmodes/page-ext.el
@@ -1,4 +1,4 @@
-;;; page-ext.el --- extended page handling commands
+;;; page-ext.el --- extended page handling commands -*- lexical-binding:t -*-
;; Copyright (C) 1990-1991, 1993-1994, 2001-2019 Free Software
;; Foundation, Inc.
@@ -243,18 +243,15 @@
(defcustom pages-directory-buffer-narrowing-p t
"If non-nil, `pages-directory-goto' narrows pages buffer to entry."
- :type 'boolean
- :group 'pages)
+ :type 'boolean)
(defcustom pages-directory-for-adding-page-narrowing-p t
"If non-nil, `add-new-page' narrows page buffer to new entry."
- :type 'boolean
- :group 'pages)
+ :type 'boolean)
(defcustom pages-directory-for-adding-new-page-before-current-page-p t
"If non-nil, `add-new-page' inserts new page before current page."
- :type 'boolean
- :group 'pages)
+ :type 'boolean)
;;; Addresses related variables
@@ -262,23 +259,19 @@
(defcustom pages-addresses-file-name "~/addresses"
"Standard name for file of addresses. Entries separated by page-delimiter.
Used by `pages-directory-for-addresses' function."
- :type 'file
- :group 'pages)
+ :type 'file)
(defcustom pages-directory-for-addresses-goto-narrowing-p t
"If non-nil, `pages-directory-goto' narrows addresses buffer to entry."
- :type 'boolean
- :group 'pages)
+ :type 'boolean)
(defcustom pages-directory-for-addresses-buffer-keep-windows-p t
"If nil, `pages-directory-for-addresses' deletes other windows."
- :type 'boolean
- :group 'pages)
+ :type 'boolean)
(defcustom pages-directory-for-adding-addresses-narrowing-p t
"If non-nil, `add-new-page' narrows addresses buffer to new entry."
- :type 'boolean
- :group 'pages)
+ :type 'boolean)
;;; Key bindings for page handling functions
@@ -311,19 +304,21 @@ With arg (prefix if interactive), move that many pages."
(or count (setq count 1))
(widen)
;; Cannot use forward-page because of problems at page boundaries.
- (while (and (> count 0) (not (eobp)))
- (if (re-search-forward page-delimiter nil t)
- nil
- (goto-char (point-max)))
- (setq count (1- count)))
- ;; If COUNT is negative, we want to go back -COUNT + 1 page boundaries.
- ;; The first page boundary we reach is the top of the current page,
- ;; which doesn't count.
- (while (and (< count 1) (not (bobp)))
- (if (re-search-backward page-delimiter nil t)
- (goto-char (match-beginning 0))
- (goto-char (point-min)))
- (setq count (1+ count)))
+ (if (>= count 0)
+ (while (and (> count 0) (not (eobp)))
+ (if (re-search-forward page-delimiter nil t)
+ nil
+ (goto-char (point-max)))
+ (setq count (1- count)))
+ ;; If COUNT is negative, we want to go back -COUNT + 1 page boundaries.
+ ;; The first page boundary we reach is the top of the current page,
+ ;; which doesn't count.
+ (while (and (< count 1) (not (bobp)))
+ (if (re-search-backward page-delimiter nil t)
+ (when (= count 0)
+ (goto-char (match-end 0)))
+ (goto-char (point-min)))
+ (setq count (1+ count))))
(narrow-to-page)
(goto-char (point-min))
(recenter 0))
@@ -415,9 +410,9 @@ Point is left in the body of page."
Called from a program, there are three arguments:
REVERSE (non-nil means reverse order), BEG and END (region to sort)."
-;;; This sort function handles ends of pages differently than
-;;; `sort-pages' and works better with lists of addresses and similar
-;;; files.
+ ;; This sort function handles ends of pages differently than
+ ;; `sort-pages' and works better with lists of addresses and similar
+ ;; files.
(interactive "P\nr")
(save-restriction
@@ -463,25 +458,27 @@ REVERSE (non-nil means reverse order), BEG and END (region to sort)."
\(This regular expression may be used to select only those pages that
contain matches to the regexp.)")
-(defvar pages-buffer nil
+(defvar-local pages-buffer nil
"The buffer for which the pages-directory function creates the directory.")
(defvar pages-directory-prefix "*Directory for:"
"Prefix of name of temporary buffer for pages-directory.")
-(defvar pages-pos-list nil
+(defvar-local pages-pos-list nil
"List containing the positions of the pages in the pages-buffer.")
(defvar pages-target-buffer)
+(define-obsolete-variable-alias 'pages-directory-map
+ 'pages-directory-mode-map "26.1")
(defvar pages-directory-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "\C-c\C-c" 'pages-directory-goto)
+ (define-key map "\C-m" 'pages-directory-goto)
(define-key map "\C-c\C-p\C-a" 'add-new-page)
- (define-key map [mouse-2] 'pages-directory-goto-with-mouse)
+ (define-key map [mouse-2] 'pages-directory-goto)
map)
"Keymap for the pages-directory-buffer.")
-(defvaralias 'pages-directory-map 'pages-directory-mode-map)
(defvar original-page-delimiter "^\f"
"Default page delimiter.")
@@ -512,6 +509,9 @@ resets the page-delimiter to the original value."
;;; Pages directory main definitions
+(defvar pages-buffer-original-position)
+(defvar pages-buffer-original-page)
+
(defun pages-directory
(pages-list-all-headers-p count-lines-p &optional regexp)
"Display a directory of the page headers in a temporary buffer.
@@ -573,7 +573,6 @@ directory for only the accessible portion of the buffer."
(let ((pages-target-buffer (current-buffer))
(pages-directory-buffer
(concat pages-directory-prefix " " (buffer-name)))
- (linenum 1)
(pages-buffer-original-position (point))
(pages-buffer-original-page 0))
@@ -644,10 +643,6 @@ directory for only the accessible portion of the buffer."
1
pages-buffer-original-page))))
-(defvar pages-buffer-original-position)
-(defvar pages-buffer-original-page)
-(defvar pages-buffer-original-page)
-
(defun pages-copy-header-and-position (count-lines-p)
"Copy page header and its position to the Pages Directory.
Only arg non-nil, count lines in page and insert before header.
@@ -701,16 +696,13 @@ Used by `pages-directory' function."
Move point to one of the lines in this buffer, then use \\[pages-directory-goto] to go
to the same line in the pages buffer."
- (make-local-variable 'pages-buffer)
- (make-local-variable 'pages-pos-list)
(make-local-variable 'pages-directory-buffer-narrowing-p))
-(defun pages-directory-goto ()
+(defun pages-directory-goto (&optional event)
"Go to the corresponding line in the pages buffer."
-
-;;; This function is mostly a copy of `occur-mode-goto-occurrence'
-
- (interactive)
+ ;; This function is mostly a copy of `occur-mode-goto-occurrence'
+ (interactive (list last-nonmenu-event))
+ (if event (mouse-set-point event))
(if (or (not pages-buffer)
(not (buffer-name pages-buffer)))
(progn
@@ -724,18 +716,13 @@ to the same line in the pages buffer."
(narrowing-p pages-directory-buffer-narrowing-p))
(pop-to-buffer pages-buffer)
(widen)
- (if end-of-directory-p
- (goto-char (point-max))
- (goto-char (marker-position pos)))
+ (goto-char (if end-of-directory-p
+ (point-max)
+ (marker-position pos)))
(if narrowing-p (narrow-to-page))))
-(defun pages-directory-goto-with-mouse (event)
- "Go to the corresponding line under the mouse pointer in the pages buffer."
- (interactive "e")
- (with-current-buffer (window-buffer (posn-window (event-end event)))
- (save-excursion
- (goto-char (posn-point (event-end event)))
- (pages-directory-goto))))
+(define-obsolete-function-alias 'pages-directory-goto-with-mouse
+ #'pages-directory-goto "26.1")
;;; The `pages-directory-for-addresses' function and ancillary code
diff --git a/lisp/textmodes/paragraphs.el b/lisp/textmodes/paragraphs.el
index 40ad64b846e..92a6b907859 100644
--- a/lisp/textmodes/paragraphs.el
+++ b/lisp/textmodes/paragraphs.el
@@ -36,9 +36,6 @@
(put 'use-hard-newlines 'permanent-local t)
(define-minor-mode use-hard-newlines
"Toggle distinguishing between hard and soft newlines.
-With a prefix argument ARG, enable the feature if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-it if ARG is omitted or nil.
When enabled, the functions `newline' and `open-line' add the
text-property `hard' to newlines that they insert, and a line is
diff --git a/lisp/textmodes/picture.el b/lisp/textmodes/picture.el
index f0e30135f16..b5208494674 100644
--- a/lisp/textmodes/picture.el
+++ b/lisp/textmodes/picture.el
@@ -387,7 +387,8 @@ Interactively, ARG is the numeric argument, and defaults to 1."
\\[picture-set-tab-stops] and \\[picture-tab-search].
The syntax for this variable is like the syntax used inside of `[...]'
in a regular expression--but without the `[' and the `]'.
-It is NOT a regular expression, any regexp special characters will be quoted.
+It is NOT a regular expression, and should follow the usual
+rules for the contents of a character alternative.
It defines a set of \"interesting characters\" to look for when setting
\(or searching for) tab stops, initially \"!-~\" (all printing characters).
For example, suppose that you are editing a table which is formatted thus:
@@ -425,7 +426,7 @@ stops computed are displayed in the minibuffer with `:' at each stop."
(if arg
(setq tabs (or (default-value 'tab-stop-list)
(indent-accumulate-tab-stops (window-width))))
- (let ((regexp (concat "[ \t]+[" (regexp-quote picture-tab-chars) "]")))
+ (let ((regexp (concat "[ \t]+[" picture-tab-chars "]")))
(beginning-of-line)
(let ((bol (point)))
(end-of-line)
@@ -433,8 +434,8 @@ stops computed are displayed in the minibuffer with `:' at each stop."
(skip-chars-forward " \t")
(setq tabs (cons (current-column) tabs)))
(if (null tabs)
- (error "No characters in set %s on this line"
- (regexp-quote picture-tab-chars))))))
+ (error "No characters in set [%s] on this line"
+ picture-tab-chars)))))
(setq tab-stop-list tabs)
(let ((blurb (make-string (1+ (nth (1- (length tabs)) tabs)) ?\ )))
(while tabs
@@ -455,12 +456,13 @@ If no such character is found, move to beginning of line."
(progn
(beginning-of-line)
(skip-chars-backward
- (concat "^" (regexp-quote picture-tab-chars))
+ (concat "^" (replace-regexp-in-string
+ "\\\\" "\\\\" picture-tab-chars nil t))
(point-min))
(not (bobp))))
(move-to-column target))
(if (re-search-forward
- (concat "[ \t]+[" (regexp-quote picture-tab-chars) "]")
+ (concat "[ \t]+[" picture-tab-chars "]")
(line-end-position)
'move)
(setq target (1- (current-column)))
diff --git a/lisp/textmodes/refbib.el b/lisp/textmodes/refbib.el
index f8013c73bb2..3ba52e61ea6 100644
--- a/lisp/textmodes/refbib.el
+++ b/lisp/textmodes/refbib.el
@@ -137,7 +137,7 @@ This is in addition to the `r2b-capitalize-title-stop-words'.")
(defvar r2b-capitalize-title-stop-words
(concat
- "the\\|and\\|of\\|is\\|a\\|an\\|of\\|for\\|in\\|to\\|in\\|on\\|at\\|"
+ "the\\|and\\|of\\|is\\|a\\|an\\|for\\|in\\|to\\|on\\|at\\|"
"by\\|with\\|that\\|its")
"Words not to be capitalized in a title (unless the first word).")
diff --git a/lisp/textmodes/refill.el b/lisp/textmodes/refill.el
index 5e577e4b279..5c69fdc1b07 100644
--- a/lisp/textmodes/refill.el
+++ b/lisp/textmodes/refill.el
@@ -169,7 +169,7 @@ complex processing.")
(when refill-doit ; there was a change
;; There's probably scope for more special cases here...
(pcase this-command
- (`self-insert-command
+ ('self-insert-command
;; Treat self-insertion commands specially, since they don't
;; always reset `refill-doit' -- for self-insertion commands that
;; *don't* cause a refill, we want to leave it turned on so that
@@ -179,9 +179,9 @@ complex processing.")
;; newline, covered below).
(refill-fill-paragraph-at refill-doit)
(setq refill-doit nil)))
- ((or `quoted-insert `fill-paragraph `fill-region) nil)
- ((or `newline `newline-and-indent `open-line `indent-new-comment-line
- `reindent-then-newline-and-indent)
+ ((or 'quoted-insert 'fill-paragraph 'fill-region) nil)
+ ((or 'newline 'newline-and-indent 'open-line 'indent-new-comment-line
+ 'reindent-then-newline-and-indent)
;; Don't zap what was just inserted.
(save-excursion
(beginning-of-line) ; for newline-and-indent
@@ -213,9 +213,6 @@ complex processing.")
;;;###autoload
(define-minor-mode refill-mode
"Toggle automatic refilling (Refill mode).
-With a prefix argument ARG, enable Refill mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Refill mode is a buffer-local minor mode. When enabled, the
current paragraph is refilled as you edit. Self-inserting
diff --git a/lisp/textmodes/reftex-cite.el b/lisp/textmodes/reftex-cite.el
index 851e46ca2d5..5b42b25f772 100644
--- a/lisp/textmodes/reftex-cite.el
+++ b/lisp/textmodes/reftex-cite.el
@@ -172,7 +172,7 @@ If RETURN is non-nil, just return the entry and restore point."
(if item
(progn (end-of-line)
(re-search-forward
- "\\\\bibitem\\|\\end{thebibliography}")
+ "\\\\bibitem\\|\\\\end{thebibliography}")
(1- (match-beginning 0)))
(progn (forward-list 1) (point)))
(error (min (point-max) (+ 300 (point)))))))
@@ -447,7 +447,7 @@ If FIELD is empty try \"editor\" field."
(setq names (reftex-get-bib-field "editor" entry)))
(while (string-match "\\band\\b[ \t]*" names)
(setq names (replace-match "\n" nil t names)))
- (while (string-match "[\\.a-zA-Z\\-]+\\.[ \t]*\\|,.*\\|[{}]+" names)
+ (while (string-match "[-.a-zA-Z]+\\.[ \t]*\\|,.*\\|[{}]+" names)
(setq names (replace-match "" nil t names)))
(while (string-match "^[ \t]+\\|[ \t]+$" names)
(setq names (replace-match "" nil t names)))
diff --git a/lisp/textmodes/reftex-parse.el b/lisp/textmodes/reftex-parse.el
index 2f9b7268fc8..005816e9659 100644
--- a/lisp/textmodes/reftex-parse.el
+++ b/lisp/textmodes/reftex-parse.el
@@ -1000,7 +1000,7 @@ OPT-ARGS is a list of argument numbers which are optional."
(eq (following-char) ?\{))
(cl-incf cnt)))
(if (and (= n cnt)
- (> (skip-chars-forward "{\\[") 0))
+ (> (skip-chars-forward "{[") 0))
(reftex-context-substring)
nil))))
diff --git a/lisp/textmodes/reftex-ref.el b/lisp/textmodes/reftex-ref.el
index ca1d2b2df8d..3ec96aa67db 100644
--- a/lisp/textmodes/reftex-ref.el
+++ b/lisp/textmodes/reftex-ref.el
@@ -308,13 +308,13 @@ also applies `reftex-translate-to-ascii-function' to the string."
;; Replace %escapes in a label prefix
(save-match-data
(let (letter (num 0) replace)
- (while (string-match "\\%\\([a-zA-Z]\\)" prefix num)
+ (while (string-match "%\\([a-zA-Z]\\)" prefix num)
(setq letter (match-string 1 prefix))
(setq replace
(save-match-data
(cond
((equal letter "f")
- (file-name-base))
+ (file-name-base (buffer-file-name)))
((equal letter "F")
(let ((masterdir (file-name-directory (reftex-TeX-master-file)))
(file (file-name-sans-extension (buffer-file-name))))
diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el
index 017f5a32126..88ad4478b06 100644
--- a/lisp/textmodes/reftex-vars.el
+++ b/lisp/textmodes/reftex-vars.el
@@ -891,21 +891,58 @@ DOWNCASE t: Downcase words before using them."
;; so this list mustn't get any more items.
(defconst reftex-label-regexps '("\\\\label{\\([^}]*\\)}"))
(defcustom reftex-label-regexps
- '(;; Normal \\label{foo} labels
+ `(;; Normal \\label{foo} labels
"\\\\label{\\(?1:[^}]*\\)}"
;; keyvals [..., label = {foo}, ...] forms used by ctable,
- ;; listings, minted, ...
- "\\[[^][]\\{0,2000\\}\\<label[[:space:]]*=[[:space:]]*{?\\(?1:[^],}]+\\)}?")
+ ;; listings, breqn, ...
+ ,(concat
+ ;; Make sure we search only for optional arguments of
+ ;; environments/macros and don't match any other [. ctable
+ ;; provides a macro called \ctable, listings/breqn have
+ ;; environments. Start with a backslash and a group for names
+ "\\\\\\(?:"
+ ;; begin, optional spaces and opening brace
+ "begin[[:space:]]*{"
+ ;; Build a regexp for env names
+ (regexp-opt '("lstlisting" "dmath" "dseries" "dgroup" "darray"))
+ ;; closing brace, optional spaces
+ "}[[:space:]]*"
+ ;; Now for macros
+ "\\|"
+ ;; Build a regexp for macro names; currently only \ctable
+ (regexp-opt '("ctable"))
+ ;; Close the group for names
+ "\\)"
+ ;; Match the opening [ and the following chars
+ "\\[[^][]*"
+ ;; Allow nested levels of chars enclosed in braces
+ "\\(?:{[^}{]*"
+ "\\(?:{[^}{]*"
+ "\\(?:{[^}{]*}[^}{]*\\)*"
+ "}[^}{]*\\)*"
+ "}[^][]*\\)*"
+ ;; Match the label key
+ "\\<label[[:space:]]*=[[:space:]]*"
+ ;; Match the label value; braces around the value are
+ ;; optional.
+ "{?\\(?1:[^] ,}\r\n\t%]+\\)}?"
+ ;; We are done. Just search until the next closing bracket
+ "[^]]*\\]"))
"List of regexps matching \\label definitions.
The default value matches usual \\label{...} definitions and
-keyval style [..., label = {...}, ...] label definitions. It is
-assumed that the regexp group 1 matches the label text, so you
-have to define it using \\(?1:...\\) when adding new regexps.
+keyval style [..., label = {...}, ...] label definitions. The
+regexp for keyval style explicitly looks for environments
+provided by the packages \"listings\" (\"lstlisting\"),
+\"breqn\" (\"dmath\", \"dseries\", \"dgroup\", \"darray\") and
+the macro \"\\ctable\" provided by the package of the same name.
+
+It is assumed that the regexp group 1 matches the label text, so
+you have to define it using \\(?1:...\\) when adding new regexps.
When changed from Lisp, make sure to call
`reftex-compile-variables' afterwards to make the change
effective."
- :version "25.1"
+ :version "27.1"
:set (lambda (symbol value)
(set symbol value)
(when (fboundp 'reftex-compile-variables)
@@ -1030,7 +1067,9 @@ This is used to string together whole reference sets, like
("Hyperref" "hyperref"
(("\\autoref" ?a) ("\\autopageref" ?u)))
("Cleveref" "cleveref"
- (("\\cref" ?c) ("\\Cref" ?C) ("\\cpageref" ?d) ("\\Cpageref" ?D))))
+ (("\\cref" ?c) ("\\Cref" ?C) ("\\cpageref" ?d) ("\\Cpageref" ?D)))
+ ("AMSmath" "amsmath"
+ (("\\eqref" ?e))))
"Alist of reference styles.
Each element is a list of the style name, the name of the LaTeX
package associated with the style or t for any package, and an
@@ -1040,7 +1079,7 @@ the macro type is being prompted for. (See also
`reftex-ref-macro-prompt'.) The keys, represented as characters,
have to be unique."
:group 'reftex-referencing-labels
- :version "24.3"
+ :version "27.1"
:type '(alist :key-type (string :tag "Style name")
:value-type (group (choice :tag "Package"
(const :tag "Any package" t)
diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el
index b9c08b8797e..67ecd3ced81 100644
--- a/lisp/textmodes/remember.el
+++ b/lisp/textmodes/remember.el
@@ -402,11 +402,19 @@ exists) might be changed."
:type 'string
:group 'remember)
+(defcustom remember-time-format "%a %b %d %H:%M:%S %Y"
+ "The format for time stamp, passed to `format-time-string'.
+The default emulates `current-time-string' for backward compatibility."
+ :type 'string
+ :group 'remember
+ :version "27.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 (current-time-string)
+ (remember-text (concat "\n" remember-leader-text
+ (format-time-string remember-time-format)
" (" desc ")\n\n" text
(save-excursion (goto-char (point-max))
(if (bolp) nil "\n"))))
diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el
index 7b9b618e4a4..ba5d7e4f46f 100644
--- a/lisp/textmodes/rst.el
+++ b/lisp/textmodes/rst.el
@@ -112,27 +112,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Support for `testcover'
-(when (and (boundp 'testcover-1value-functions)
- (boundp 'testcover-compose-functions))
- ;; Below `lambda' is used in a loop with varying parameters and is thus not
- ;; 1valued.
- (setq testcover-1value-functions
- (delq 'lambda testcover-1value-functions))
- (add-to-list 'testcover-compose-functions 'lambda))
-
-(defun rst-testcover-defcustom ()
- "Remove all customized variables from `testcover-module-constants'.
-This seems to be a bug in `testcover': `defcustom' variables are
-considered constants. Revert it with this function after each `defcustom'."
- (when (boundp 'testcover-module-constants)
- (setq testcover-module-constants
- (delq nil
- (mapcar
- #'(lambda (sym)
- (if (not (plist-member (symbol-plist sym) 'standard-value))
- sym))
- testcover-module-constants)))))
-
(defun rst-testcover-add-compose (fun)
"Add FUN to `testcover-compose-functions'."
(when (boundp 'testcover-compose-functions)
@@ -246,7 +225,7 @@ and before TAIL-RE and DELIM-RE in VAR or DEFAULT for no match."
"The SVN revision of this file.
SVN revision is the upstream (docutils) revision.")
(defconst rst-svn-timestamp
- (rst-extract-version "\\$" "LastChangedDate: " ".+?+" " "
+ (rst-extract-version "\\$" "LastChangedDate: " ".+" " "
"$LastChangedDate: 2017-01-08 10:54:35 +0100 (Sun, 08 Jan 2017) $")
"The SVN time stamp of this file.")
@@ -817,6 +796,9 @@ Return ADO if so or signal an error otherwise."
;; Public class methods
+(define-obsolete-variable-alias
+ 'rst-preferred-decorations 'rst-preferred-adornments "rst 1.0.0")
+
(defvar rst-preferred-adornments) ; Forward declaration.
(defun rst-Hdr-preferred-adornments ()
@@ -1344,7 +1326,6 @@ This inherits from Text mode.")
The hook for `text-mode' is run before this one."
:group 'rst
:type '(hook))
-(rst-testcover-defcustom)
;; Pull in variable definitions silencing byte-compiler.
(require 'newcomment)
@@ -1430,9 +1411,6 @@ highlighting.
;;;###autoload
(define-minor-mode rst-minor-mode
"Toggle ReST minor mode.
-With a prefix argument ARG, enable ReST minor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
When ReST minor mode is enabled, the ReST mode keybindings
are installed on top of the major mode bindings. Use this
@@ -1503,8 +1481,6 @@ for modes derived from Text mode, like Mail mode."
:group 'rst
:version "21.1")
-(define-obsolete-variable-alias
- 'rst-preferred-decorations 'rst-preferred-adornments "rst 1.0.0")
;; FIXME: Default must match suggestion in
;; http://sphinx-doc.org/rest.html#sections for Python documentation.
(defcustom rst-preferred-adornments '((?= over-and-under 1)
@@ -1541,7 +1517,6 @@ file."
(const :tag "Underline only" simple))
(integer :tag "Indentation for overline and underline type"
:value 0))))
-(rst-testcover-defcustom)
;; FIXME: Rename this to `rst-over-and-under-default-indent' and set default to
;; 0 because the effect of 1 is probably surprising in the few cases
@@ -1558,7 +1533,6 @@ found in the buffer are to be used but the indentation for
over-and-under adornments is inconsistent across the buffer."
:group 'rst-adjust
:type '(integer))
-(rst-testcover-defcustom)
(defun rst-new-preferred-hdr (seen prev)
;; testcover: ok.
@@ -1997,7 +1971,6 @@ b. a negative numerical argument, which generally inverts the
:group 'rst-adjust
:type '(hook)
:package-version '(rst . "1.1.0"))
-(rst-testcover-defcustom)
(defcustom rst-new-adornment-down nil
"Controls level of new adornment for section headers."
@@ -2006,7 +1979,6 @@ b. a negative numerical argument, which generally inverts the
(const :tag "Same level as previous one" nil)
(const :tag "One level down relative to the previous one" t))
:package-version '(rst . "1.1.0"))
-(rst-testcover-defcustom)
(defun rst-adjust-adornment (pfxarg)
"Call `rst-adjust-section' interactively.
@@ -2429,7 +2401,6 @@ also arranged by `rst-insert-list-new-tag'."
:tag (char-to-string char) char))
rst-bullets)))
:package-version '(rst . "1.1.0"))
-(rst-testcover-defcustom)
(defun rst-insert-list-continue (ind tag tab prefer-roman)
;; testcover: ok.
@@ -2666,7 +2637,6 @@ section headers at all."
Also used for formatting insertion, when numbering is disabled."
:type 'integer
:group 'rst-toc)
-(rst-testcover-defcustom)
(defcustom rst-toc-insert-style 'fixed
"Insertion style for table-of-contents.
@@ -2681,19 +2651,16 @@ indentation style:
(const aligned)
(const listed))
:group 'rst-toc)
-(rst-testcover-defcustom)
(defcustom rst-toc-insert-number-separator " "
"Separator that goes between the TOC number and the title."
:type 'string
:group 'rst-toc)
-(rst-testcover-defcustom)
(defcustom rst-toc-insert-max-level nil
"If non-nil, maximum depth of the inserted TOC."
:type '(choice (const nil) integer)
:group 'rst-toc)
-(rst-testcover-defcustom)
(defconst rst-toc-link-keymap
(let ((map (make-sparse-keymap)))
@@ -3158,35 +3125,30 @@ These indentation widths can be customized here."
"Indentation when there is no more indentation point given."
:group 'rst-indent
:type '(integer))
-(rst-testcover-defcustom)
(defcustom rst-indent-field 3
"Indentation for first line after a field or 0 to always indent for content."
:group 'rst-indent
:package-version '(rst . "1.1.0")
:type '(integer))
-(rst-testcover-defcustom)
(defcustom rst-indent-literal-normal 3
"Default indentation for literal block after a markup on an own line."
:group 'rst-indent
:package-version '(rst . "1.1.0")
:type '(integer))
-(rst-testcover-defcustom)
(defcustom rst-indent-literal-minimized 2
"Default indentation for literal block after a minimized markup."
:group 'rst-indent
:package-version '(rst . "1.1.0")
:type '(integer))
-(rst-testcover-defcustom)
(defcustom rst-indent-comment 3
"Default indentation for first line of a comment."
:group 'rst-indent
:package-version '(rst . "1.1.0")
:type '(integer))
-(rst-testcover-defcustom)
;; FIXME: Must consider other tabs:
;; * Line blocks
@@ -3636,7 +3598,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too."
:version "24.1"
:group 'rst-faces
:type '(face))
-(rst-testcover-defcustom)
(make-obsolete-variable 'rst-block-face
"customize the face `rst-block' instead."
"24.1")
@@ -3651,7 +3612,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too."
:version "24.1"
:group 'rst-faces
:type '(face))
-(rst-testcover-defcustom)
(make-obsolete-variable 'rst-external-face
"customize the face `rst-external' instead."
"24.1")
@@ -3666,7 +3626,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too."
:version "24.1"
:group 'rst-faces
:type '(face))
-(rst-testcover-defcustom)
(make-obsolete-variable 'rst-definition-face
"customize the face `rst-definition' instead."
"24.1")
@@ -3683,7 +3642,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too."
"Directives and roles."
:group 'rst-faces
:type '(face))
-(rst-testcover-defcustom)
(make-obsolete-variable 'rst-directive-face
"customize the face `rst-directive' instead."
"24.1")
@@ -3698,7 +3656,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too."
:version "24.1"
:group 'rst-faces
:type '(face))
-(rst-testcover-defcustom)
(make-obsolete-variable 'rst-comment-face
"customize the face `rst-comment' instead."
"24.1")
@@ -3713,7 +3670,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too."
:version "24.1"
:group 'rst-faces
:type '(face))
-(rst-testcover-defcustom)
(make-obsolete-variable 'rst-emphasis1-face
"customize the face `rst-emphasis1' instead."
"24.1")
@@ -3727,7 +3683,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too."
"Double emphasis."
:group 'rst-faces
:type '(face))
-(rst-testcover-defcustom)
(make-obsolete-variable 'rst-emphasis2-face
"customize the face `rst-emphasis2' instead."
"24.1")
@@ -3742,7 +3697,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too."
:version "24.1"
:group 'rst-faces
:type '(face))
-(rst-testcover-defcustom)
(make-obsolete-variable 'rst-literal-face
"customize the face `rst-literal' instead."
"24.1")
@@ -3757,7 +3711,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too."
:version "24.1"
:group 'rst-faces
:type '(face))
-(rst-testcover-defcustom)
(make-obsolete-variable 'rst-reference-face
"customize the face `rst-reference' instead."
"24.1")
@@ -3840,7 +3793,6 @@ of your own."
(const :tag "transitions" t)
(const :tag "section title adornment" nil))
:value-type (face)))
-(rst-testcover-defcustom)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -4337,7 +4289,6 @@ string)) to be used for converting the document."
(string :tag "Options"))))
:group 'rst-compile
:package-version "1.2.0")
-(rst-testcover-defcustom)
;; FIXME: Must be defcustom.
(defvar rst-compile-primary-toolset 'html
diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el
index 50b2077ef4f..9e3be99af14 100644
--- a/lisp/textmodes/sgml-mode.el
+++ b/lisp/textmodes/sgml-mode.el
@@ -46,8 +46,7 @@
(defcustom sgml-basic-offset 2
"Specifies the basic indentation level for `sgml-indent-line'."
- :type 'integer
- :group 'sgml)
+ :type 'integer)
(defcustom sgml-attribute-offset 0
"Specifies a delta for attribute indentation in `sgml-indent-line'.
@@ -65,16 +64,16 @@ When 2, attribute indentation looks like this:
</element>"
:version "25.1"
:type 'integer
- :safe 'integerp
- :group 'sgml)
+ :safe 'integerp)
(defcustom sgml-xml-mode nil
"When non-nil, tag insertion functions will be XML-compliant.
It is set to be buffer-local when the file has
a DOCTYPE or an XML declaration."
:type 'boolean
- :version "22.1"
- :group 'sgml)
+ :version "22.1")
+
+(defvaralias 'sgml-transformation 'sgml-transformation-function)
(defcustom sgml-transformation-function 'identity
"Default value for `skeleton-transformation-function' in SGML mode."
@@ -87,17 +86,14 @@ a DOCTYPE or an XML declaration."
(and (derived-mode-p 'sgml-mode)
(not sgml-xml-mode)
(setq skeleton-transformation-function val))))
- (buffer-list)))
- :group 'sgml)
+ (buffer-list))))
(put 'sgml-transformation-function 'variable-interactive
"aTransformation function: ")
-(defvaralias 'sgml-transformation 'sgml-transformation-function)
(defcustom sgml-mode-hook nil
"Hook run by command `sgml-mode'.
`text-mode-hook' is run first."
- :group 'sgml
:type 'hook)
;; As long as Emacs's syntax can't be complemented with predicates to context
@@ -210,8 +206,7 @@ This takes effect when first loading the `sgml-mode' library.")
(defcustom sgml-name-8bit-mode nil
"When non-nil, insert non-ASCII characters as named entities."
- :type 'boolean
- :group 'sgml)
+ :type 'boolean)
(defvar sgml-char-names
[nil nil nil nil nil nil nil nil
@@ -281,8 +276,7 @@ Currently, only Latin-1 characters are supported.")
The file name of current buffer file name will be appended to this,
separated by a space."
:type 'string
- :version "21.1"
- :group 'sgml)
+ :version "21.1")
(defvar sgml-saved-validate-command nil
"The command last used to validate in this buffer.")
@@ -291,8 +285,7 @@ separated by a space."
;; so use a small distance here.
(defcustom sgml-slash-distance 1000
"If non-nil, is the maximum distance to search for matching `/'."
- :type '(choice (const nil) integer)
- :group 'sgml)
+ :type '(choice (const nil) integer))
(defconst sgml-namespace-re "[_[:alpha:]][-_.[:alnum:]]*")
(defconst sgml-name-re "[_:[:alpha:]][-_.:[:alnum:]]*")
@@ -304,8 +297,7 @@ Any terminating `>' or `/' is not matched.")
(defface sgml-namespace
'((t (:inherit font-lock-builtin-face)))
- "`sgml-mode' face used to highlight the namespace part of identifiers."
- :group 'sgml)
+ "`sgml-mode' face used to highlight the namespace part of identifiers.")
(defvar sgml-namespace-face 'sgml-namespace)
;; internal
@@ -351,12 +343,21 @@ Any terminating `>' or `/' is not matched.")
("--[ \t\n]*\\(>\\)" (1 "> b"))
("\\(<\\)[?!]" (1 (prog1 "|>"
(sgml-syntax-propertize-inside end))))
- ;; Double quotes outside of tags should not introduce strings.
- ;; Be careful to call `syntax-ppss' on a position before the one we're
- ;; going to change, so as not to need to flush the data we just computed.
- ("\"" (0 (if (prog1 (zerop (car (syntax-ppss (match-beginning 0))))
- (goto-char (match-end 0)))
- (string-to-syntax ".")))))))
+ ;; Double quotes outside of tags should not introduce strings which end up
+ ;; hiding tags. We used to test every double quote and mark it as "."
+ ;; if it's outside of tags, but there are too many double quotes and
+ ;; the resulting number of calls to syntax-ppss made it too slow
+ ;; (bug#33887), so we're now careful to leave alone any pair
+ ;; of quotes that doesn't hold a < or > char, which is the vast majority.
+ ("\\(\"\\)[^\"<>]*[<>\"]"
+ (1 (unless (eq ?\" (char-before))
+ ;; Be careful to call `syntax-ppss' on a position before the one
+ ;; we're going to change, so as not to need to flush the data we
+ ;; just computed.
+ (if (prog1 (zerop (car (syntax-ppss (match-beginning 0))))
+ (goto-char (1- (match-end 0))))
+ (string-to-syntax ".")))))
+ )))
(defun sgml-syntax-propertize (start end)
"Syntactic keywords for `sgml-mode'."
@@ -420,8 +421,7 @@ The attribute alist is made up as
ATTRIBUTERULE is a list of optionally t (no value when no input) followed by
an optional alist of possible values."
:type '(repeat (cons (string :tag "Tag Name")
- (repeat :tag "Tag Rule" sexp)))
- :group 'sgml)
+ (repeat :tag "Tag Rule" sexp))))
(put 'sgml-tag-alist 'risky-local-variable t)
(defcustom sgml-tag-help
@@ -433,8 +433,7 @@ an optional alist of possible values."
("!entity" . "Entity (macro) declaration"))
"Alist of tag name and short description."
:type '(repeat (cons (string :tag "Tag Name")
- (string :tag "Description")))
- :group 'sgml)
+ (string :tag "Description"))))
(defvar sgml-empty-tags nil
"List of tags whose !ELEMENT definition says EMPTY.")
@@ -460,7 +459,7 @@ an optional alist of possible values."
nil t)
(string-match "X\\(HT\\)?ML" (match-string 3))))))
-(defvar v2) ; free for skeleton
+(with-no-warnings (defvar v2)) ; free for skeleton
(defun sgml-comment-indent-new-line (&optional soft)
(let ((comment-start "-- ")
@@ -618,7 +617,7 @@ Behaves electrically if `sgml-quick-keys' is non-nil."
(delete-char -1)
(sgml-close-tag))
(t
- (sgml-slash-matching arg))))
+ (insert-char ?/ arg))))
(defun sgml-slash-matching (arg)
"Insert `/' and display any previous matching `/'.
@@ -895,7 +894,7 @@ Return non-nil if we skipped over matched tags."
(condition-case err
(save-excursion
(goto-char end)
- (skip-chars-backward "[:alnum:]-_.:")
+ (skip-chars-backward "-[:alnum:]_.:")
(if (and ;; (<= (point) beg) ; This poses problems for downcase-word.
(or (eq (char-before) ?<)
(and (eq (char-before) ?/)
@@ -903,7 +902,7 @@ Return non-nil if we skipped over matched tags."
(null (get-char-property (point) 'text-clones)))
(let* ((endp (eq (char-before) ?/))
(cl-start (point))
- (cl-end (progn (skip-chars-forward "[:alnum:]-_.:") (point)))
+ (cl-end (progn (skip-chars-forward "-[:alnum:]_.:") (point)))
(match
(if endp
(when (sgml-skip-tag-backward 1) (forward-char 1) t)
@@ -920,7 +919,8 @@ Return non-nil if we skipped over matched tags."
(equal (buffer-substring cl-start cl-end)
(buffer-substring (point)
(save-excursion
- (skip-chars-forward "[:alnum:]-_.:")
+ (skip-chars-forward
+ "-[:alnum:]_.:")
(point))))
(or (not endp) (eq (char-after cl-end) ?>)))
(when clones
@@ -940,9 +940,6 @@ Return non-nil if we skipped over matched tags."
(define-minor-mode sgml-electric-tag-pair-mode
"Toggle SGML Electric Tag Pair mode.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
SGML Electric Tag Pair mode is a buffer-local minor mode for use
with `sgml-mode' and related major modes. When enabled, editing
@@ -1241,8 +1238,11 @@ See `sgml-tag-alist' for info about attribute rules."
(defun sgml-quote (start end &optional unquotep)
"Quote SGML text in region START ... END.
-Only &, < and > are quoted, the rest is left untouched.
-With prefix argument UNQUOTEP, unquote the region."
+Only &, <, >, ' and \" characters are quoted, the rest is left
+untouched. This is sufficient to use quoted text as SGML argument.
+
+With prefix argument UNQUOTEP, unquote the region. All numeric entities,
+\"amp\", \"lt\", \"gt\" and \"quot\" named entities are unquoted."
(interactive "r\nP")
(save-restriction
(narrow-to-region start end)
@@ -1250,14 +1250,23 @@ With prefix argument UNQUOTEP, unquote the region."
(if unquotep
;; FIXME: We should unquote other named character references as well.
(while (re-search-forward
- "\\(&\\(amp\\|\\(l\\|\\(g\\)\\)t\\)\\)[][<>&;\n\t \"%!'(),/=?]"
+ "\\(&\\(amp\\|quot\\|lt\\|gt\\|#\\([0-9]+\\|[xX][0-9a-fA-F]+\\)\\)\\)\\([][<>&;\n\t \"%!'(),/=?]\\|$\\)"
nil t)
- (replace-match (if (match-end 4) ">" (if (match-end 3) "<" "&")) t t
- nil (if (eq (char-before (match-end 0)) ?\;) 0 1)))
- (while (re-search-forward "[&<>]" nil t)
+ (replace-match
+ (string
+ (or (cdr (assq (char-after (match-beginning 2))
+ '((?a . ?&) (?q . ?\") (?l . ?<) (?g . ?>))))
+ (let ((num (match-string 3)))
+ (if (or (eq ?x (aref num 0)) (eq ?X (aref num 0)))
+ (string-to-number (substring num 1) 16)
+ (string-to-number num 10)))))
+ t t nil (if (eq (char-before (match-end 0)) ?\;) 0 1)))
+ (while (re-search-forward "[&<>\"']" nil t)
(replace-match (cdr (assq (char-before) '((?& . "&amp;")
(?< . "&lt;")
- (?> . "&gt;"))))
+ (?> . "&gt;")
+ (?\" . "&#34;")
+ (?' . "&#39;"))))
t t)))))
(defun sgml-pretty-print (beg end)
@@ -1514,12 +1523,12 @@ Depending on context, inserts a matching close-tag, or closes
the current start-tag or the current comment or the current cdata, ..."
(interactive)
(pcase (car (sgml-lexical-context))
- (`comment (insert " -->"))
- (`cdata (insert "]]>"))
- (`pi (insert " ?>"))
- (`jsp (insert " %>"))
- (`tag (insert " />"))
- (`text
+ ('comment (insert " -->"))
+ ('cdata (insert "]]>"))
+ ('pi (insert " ?>"))
+ ('jsp (insert " %>"))
+ ('tag (insert " />"))
+ ('text
(let ((context (save-excursion (sgml-get-context))))
(if context
(progn
@@ -1552,7 +1561,7 @@ LCON is the lexical context, if any."
(pcase (car lcon)
- (`string
+ ('string
;; Go back to previous non-empty line.
(while (and (> (point) (cdr lcon))
(zerop (forward-line -1))
@@ -1563,7 +1572,7 @@ LCON is the lexical context, if any."
(goto-char (cdr lcon))
(1+ (current-column))))
- (`comment
+ ('comment
(let ((mark (looking-at "--")))
;; Go back to previous non-empty line.
(while (and (> (point) (cdr lcon))
@@ -1582,11 +1591,11 @@ LCON is the lexical context, if any."
(current-column)))
;; We don't know how to indent it. Let's be honest about it.
- (`cdata nil)
+ ('cdata nil)
;; We don't know how to indent it. Let's be honest about it.
- (`pi nil)
+ ('pi nil)
- (`tag
+ ('tag
(goto-char (+ (cdr lcon) sgml-attribute-offset))
(skip-chars-forward "^ \t\n") ;Skip tag name.
(skip-chars-forward " \t")
@@ -1596,7 +1605,7 @@ LCON is the lexical context, if any."
(goto-char (+ (cdr lcon) sgml-attribute-offset))
(+ (current-column) sgml-basic-offset)))
- (`text
+ ('text
(while (looking-at "</")
(sgml-forward-sexp 1)
(skip-chars-forward " \t"))
@@ -1712,7 +1721,6 @@ Currently just returns (EMPTY-TAGS UNCLOSED-TAGS)."
(defcustom html-mode-hook nil
"Hook run by command `html-mode'.
`text-mode-hook' and `sgml-mode-hook' are run first."
- :group 'sgml
:type 'hook
:options '(html-autoview-mode))
@@ -2232,6 +2240,9 @@ buffer's tick counter (as produced by `buffer-modified-tick'),
and the CDR is the list of class names found in the buffer.")
(make-variable-buffer-local 'html--buffer-ids-cache)
+(declare-function libxml-parse-html-region "xml.c"
+ (start end &optional base-url discard-comments))
+
(defun html-current-buffer-classes ()
"Return a list of class names used in the current buffer.
The result is cached in `html--buffer-classes-cache'."
@@ -2363,18 +2374,14 @@ The third `match-string' will be the used in the menu.")
(define-minor-mode html-autoview-mode
"Toggle viewing of HTML files on save (HTML Autoview mode).
-With a prefix argument ARG, enable HTML Autoview mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
HTML Autoview mode is a buffer-local minor mode for use with
`html-mode'. If enabled, saving the file automatically runs
`browse-url-of-buffer' to view it."
nil nil nil
- :group 'sgml
(if html-autoview-mode
- (add-hook 'after-save-hook 'browse-url-of-buffer nil t)
- (remove-hook 'after-save-hook 'browse-url-of-buffer t)))
+ (add-hook 'after-save-hook #'browse-url-of-buffer nil t)
+ (remove-hook 'after-save-hook #'browse-url-of-buffer t)))
(define-skeleton html-href-anchor
diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el
index 479bcbe975a..9c91d27b944 100644
--- a/lisp/textmodes/tex-mode.el
+++ b/lisp/textmodes/tex-mode.el
@@ -601,9 +601,9 @@ An alternative value is \" . \", if you use a font with a narrow period."
(list (concat slash citations opt arg) 3 'font-lock-constant-face)
;;
;; Text between `` quotes ''.
- (cons (concat (regexp-opt `("``" "\"<" "\"`" "<<" "«") t)
+ (cons (concat (regexp-opt '("``" "\"<" "\"`" "<<" "«") t)
"[^'\">{]+" ;a bit pessimistic
- (regexp-opt `("''" "\">" "\"'" ">>" "»") t))
+ (regexp-opt '("''" "\">" "\"'" ">>" "»") t))
'font-lock-string-face)
;;
;; Command names, special and general.
@@ -713,9 +713,6 @@ An alternative value is \" . \", if you use a font with a narrow period."
(define-minor-mode latex-electric-env-pair-mode
"Toggle Latex Electric Env Pair mode.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable it if ARG
-is omitted or nil.
Latex Electric Env Pair mode is a buffer-local minor mode for use
with `latex-mode'. When enabled, typing a \\begin or \\end tag
@@ -1173,7 +1170,7 @@ subshell is initiated, `tex-shell-hook' is run."
(setq-local fill-indent-according-to-mode t)
(add-hook 'completion-at-point-functions
#'latex-complete-data nil 'local)
- (add-hook 'flymake-diagnostic-functions 'tex-chktex nil t)
+ (add-hook 'flymake-diagnostic-functions #'tex-chktex nil t)
(setq-local outline-regexp latex-outline-regexp)
(setq-local outline-level #'latex-outline-level)
(setq-local forward-sexp-function #'latex-forward-sexp)
@@ -1264,8 +1261,8 @@ Entering SliTeX mode runs the hook `text-mode-hook', then the hook
(setq-local comment-start-skip
"\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\)\\(%+ *\\)")
(setq-local parse-sexp-ignore-comments t)
- (setq-local compare-windows-whitespace 'tex-categorize-whitespace)
- (setq-local facemenu-add-face-function 'tex-facemenu-add-face-function)
+ (setq-local compare-windows-whitespace #'tex-categorize-whitespace)
+ (setq-local facemenu-add-face-function #'tex-facemenu-add-face-function)
(setq-local facemenu-end-add-face "}")
(setq-local facemenu-remove-face-function t)
(setq-local font-lock-defaults
@@ -1594,7 +1591,7 @@ Puts point on a blank line between them."
(defvar latex-complete-bibtex-cache nil)
(define-obsolete-function-alias 'latex-string-prefix-p
- 'string-prefix-p "24.3")
+ #'string-prefix-p "24.3")
(defvar bibtex-reference-key)
(declare-function reftex-get-bibfile-list "reftex-cite.el" ())
@@ -1659,7 +1656,7 @@ Puts point on a blank line between them."
(let ((pt (point)))
(skip-chars-backward "^ {}\n\t\\\\")
(pcase (char-before)
- ((or `nil ?\s ?\n ?\t ?\}) nil)
+ ((or 'nil ?\s ?\n ?\t ?\}) nil)
(?\\
;; TODO: Complete commands.
nil)
@@ -2112,7 +2109,7 @@ If NOT-ALL is non-nil, save the `.dvi' file."
(delete-file (concat dir (car list))))
(setq list (cdr list))))))
-(add-hook 'kill-emacs-hook 'tex-delete-last-temp-files)
+(add-hook 'kill-emacs-hook #'tex-delete-last-temp-files)
;;
;; Machinery to guess the command that the user wants to execute.
@@ -2171,7 +2168,7 @@ IN can be either a string (with the same % escapes in it) indicating
OUT describes the output file and is either a %-escaped string
or nil to indicate that there is no output file.")
-(define-obsolete-function-alias 'tex-string-prefix-p 'string-prefix-p "24.3")
+(define-obsolete-function-alias 'tex-string-prefix-p #'string-prefix-p "24.3")
(defun tex-guess-main-file (&optional all)
"Find a likely `tex-main-file'.
@@ -2266,9 +2263,11 @@ FILE is typically the output DVI or PDF file."
(> (save-excursion
;; Usually page numbers are output as [N], but
;; I've already seen things like
- ;; [1{/var/lib/texmf/fonts/map/pdftex/updmap/pdftex.map}]
- (or (re-search-backward "\\[[0-9]+\\({[^}]*}\\)?\\]"
- nil t)
+ ;; [N{/var/lib/texmf/fonts/map/pdftex/updmap/pdftex.map}]
+ ;; as well as [N.N] (e.g. with 'acmart' style).
+ (or (re-search-backward
+ "\\[[0-9]+\\({[^}]*}\\|\\.[0-9]+\\)?\\]"
+ nil t)
(point-min)))
(save-excursion
(or (re-search-backward "Rerun" nil t)
@@ -2995,8 +2994,8 @@ There might be text before point."
(mapcar
(lambda (x)
(pcase (car-safe x)
- (`font-lock-syntactic-face-function
- (cons (car x) 'doctex-font-lock-syntactic-face-function))
+ ('font-lock-syntactic-face-function
+ (cons (car x) #'doctex-font-lock-syntactic-face-function))
(_ x)))
(cdr font-lock-defaults))))
(setq-local syntax-propertize-function
diff --git a/lisp/textmodes/texinfmt.el b/lisp/textmodes/texinfmt.el
index 0e65b1c4e20..4bfecb48b65 100644
--- a/lisp/textmodes/texinfmt.el
+++ b/lisp/textmodes/texinfmt.el
@@ -552,13 +552,7 @@ if large. You can use `Info-split' to do this manually."
(defvar texinfo-accent-commands
(concat
- "@^\\|"
- "@`\\|"
- "@'\\|"
- "@\"\\|"
- "@,\\|"
- "@=\\|"
- "@~\\|"
+ "@[\"',=^`~]\\|"
"@OE{\\|"
"@oe{\\|"
"@AA{\\|"
@@ -2447,7 +2441,7 @@ Use only the FILENAME arg; for Info, ignore the other arguments to @image."
(defun texinfo-format-option ()
"Insert \\=` ... \\=' around arg unless inside a table; in that case, no quotes."
;; `looking-at-backward' not available in v. 18.57, 20.2
- (if (not (search-backward "" ; searched-for character is a control-H
+ (if (not (search-backward "\^H"
(line-beginning-position)
t))
(insert "`" (texinfo-parse-arg-discard) "'")
diff --git a/lisp/textmodes/texinfo.el b/lisp/textmodes/texinfo.el
index f6aa8727410..71cdcab57ef 100644
--- a/lisp/textmodes/texinfo.el
+++ b/lisp/textmodes/texinfo.el
@@ -470,6 +470,7 @@ Subexpression 1 is what goes into the corresponding `@end' statement.")
(define-key map "\C-c\C-cu" 'texinfo-insert-@uref)
(define-key map "\C-c\C-ct" 'texinfo-insert-@table)
(define-key map "\C-c\C-cs" 'texinfo-insert-@samp)
+ (define-key map "\C-c\C-cr" 'texinfo-insert-dwim-@ref)
(define-key map "\C-c\C-cq" 'texinfo-insert-@quotation)
(define-key map "\C-c\C-co" 'texinfo-insert-@noindent)
(define-key map "\C-c\C-cn" 'texinfo-insert-@node)
@@ -596,9 +597,9 @@ value of `texinfo-mode-hook'."
(setq-local require-final-newline mode-require-final-newline)
(setq-local indent-tabs-mode nil)
(setq-local paragraph-separate
- (concat "\b\\|@[a-zA-Z]*[ \n]\\|"
+ (concat "@[a-zA-Z]*[ \n]\\|"
paragraph-separate))
- (setq-local paragraph-start (concat "\b\\|@[a-zA-Z]*[ \n]\\|"
+ (setq-local paragraph-start (concat "@[a-zA-Z]*[ \n]\\|"
paragraph-start))
(setq-local sentence-end-base "\\(@\\(end\\)?dots{}\\|[.?!]\\)[]\"'”)}]*")
(setq-local fill-column 70)
@@ -610,7 +611,6 @@ value of `texinfo-mode-hook'."
(setq font-lock-defaults
'(texinfo-font-lock-keywords nil nil nil backward-paragraph))
(setq-local syntax-propertize-function texinfo-syntax-propertize-function)
- (setq-local parse-sexp-lookup-properties t)
(setq-local add-log-current-defun-function #'texinfo-current-defun-name)
;; Outline settings.
@@ -826,6 +826,38 @@ Leave point after `@node'."
"Insert the string `@quotation' in a Texinfo buffer."
\n "@quotation" \n _ \n)
+(define-skeleton texinfo-insert-dwim-@ref
+ "Insert appropriate `@pxref{...}', `@xref{}', or `@ref{}' command.
+
+Looks at text around point to decide what to insert; an unclosed
+preceding open parenthesis results in '@pxref{}', point at the
+beginning of a sentence or at (point-min) yields '@xref{}', any
+other location (including inside a word), will result in '@ref{}'
+at the nearest previous whitespace or beginning-of-line. A
+numeric argument says how many words the braces should surround.
+The default is not to surround any existing words with the
+braces."
+ nil
+ (cond
+ ;; parenthesis
+ ((looking-back "([^)]*" (point-at-bol 0))
+ "@pxref{")
+ ;; beginning of sentence or buffer
+ ((or (looking-back (sentence-end) (point-at-bol 0))
+ (= (point) (point-min)))
+ "@xref{")
+ ;; bol or eol
+ ((looking-at "^\\|$")
+ "@ref{")
+ ;; inside word
+ ((not (eq (char-syntax (char-after)) ? ))
+ (skip-syntax-backward "^ " (point-at-bol))
+ "@ref{")
+ ;; everything else
+ (t
+ "@ref{"))
+ _ "}")
+
(define-skeleton texinfo-insert-@samp
"Insert a `@samp{...}' command in a Texinfo buffer.
A numeric argument says how many words the braces should surround.
diff --git a/lisp/textmodes/texnfo-upd.el b/lisp/textmodes/texnfo-upd.el
index 8c6e23eae4a..e960e992a89 100644
--- a/lisp/textmodes/texnfo-upd.el
+++ b/lisp/textmodes/texnfo-upd.el
@@ -642,7 +642,7 @@ appears in the texinfo file."
"Return description field of old menu line as string.
Point must be located just after the node name. Point left before description.
Single argument, END-OF-MENU, is position limiting search."
- (skip-chars-forward "[:.,\t\n ]+")
+ (skip-chars-forward ":.,\t\n ")
;; don't copy a carriage return at line beginning with asterisk!
;; don't copy @detailmenu or @end menu or @ignore as descriptions!
;; do copy a description that begins with an `@'!
diff --git a/lisp/textmodes/text-mode.el b/lisp/textmodes/text-mode.el
index 931faadb5bb..e676a5dae20 100644
--- a/lisp/textmodes/text-mode.el
+++ b/lisp/textmodes/text-mode.el
@@ -1,4 +1,4 @@
-;;; text-mode.el --- text mode, and its idiosyncratic commands
+;;; text-mode.el --- text mode, and its idiosyncratic commands -*- lexical-binding: t -*-
;; Copyright (C) 1985, 1992, 1994, 2001-2019 Free Software Foundation,
;; Inc.
@@ -38,8 +38,8 @@
:group 'text)
(defvar text-mode-variant nil
- "Non-nil if this buffer's major mode is a variant of Text mode.
-Use (derived-mode-p \\='text-mode) instead.")
+ "Non-nil if this buffer's major mode is a variant of Text mode.")
+(make-obsolete-variable 'text-mode-variant 'derived-mode-p "27.1")
(defvar text-mode-syntax-table
(let ((st (make-syntax-table)))
@@ -104,10 +104,8 @@ You can thus get the full benefit of adaptive filling
(see the variable `adaptive-fill-mode').
\\{text-mode-map}
Turning on Text mode runs the normal hook `text-mode-hook'."
- (set (make-local-variable 'text-mode-variant) t)
- (set (make-local-variable 'require-final-newline)
- mode-require-final-newline)
- (set (make-local-variable 'indent-line-function) 'indent-relative))
+ (setq-local text-mode-variant t)
+ (setq-local require-final-newline mode-require-final-newline))
(define-derived-mode paragraph-indent-text-mode text-mode "Parindent"
"Major mode for editing text, with leading spaces starting a paragraph.
@@ -131,14 +129,12 @@ Turning on Paragraph-Indent minor mode runs the normal hook
:initial-value nil
;; Change the definition of a paragraph start.
(let ((ps-re "[ \t\n\f]\\|"))
- (if (eq t (compare-strings ps-re nil nil
- paragraph-start nil (length ps-re)))
+ (if (string-prefix-p ps-re paragraph-start)
(if (not paragraph-indent-minor-mode)
- (set (make-local-variable 'paragraph-start)
- (substring paragraph-start (length ps-re))))
+ (setq-local paragraph-start
+ (substring paragraph-start (length ps-re))))
(if paragraph-indent-minor-mode
- (set (make-local-variable 'paragraph-start)
- (concat ps-re paragraph-start)))))
+ (setq-local paragraph-start (concat ps-re paragraph-start)))))
;; Change the indentation function.
(if paragraph-indent-minor-mode
(add-function :override (local 'indent-line-function)
@@ -154,7 +150,7 @@ Turning on Paragraph-Indent minor mode runs the normal hook
(defun text-mode-hook-identify ()
"Mark that this mode has run `text-mode-hook'.
This is how `toggle-text-mode-auto-fill' knows which buffers to operate on."
- (set (make-local-variable 'text-mode-variant) t))
+ (setq-local text-mode-variant t))
(defun toggle-text-mode-auto-fill ()
"Toggle whether to use Auto Fill in Text mode and related modes.
@@ -163,8 +159,8 @@ both existing buffers and buffers that you subsequently create."
(interactive)
(let ((enable-mode (not (memq 'turn-on-auto-fill text-mode-hook))))
(if enable-mode
- (add-hook 'text-mode-hook 'turn-on-auto-fill)
- (remove-hook 'text-mode-hook 'turn-on-auto-fill))
+ (add-hook 'text-mode-hook #'turn-on-auto-fill)
+ (remove-hook 'text-mode-hook #'turn-on-auto-fill))
(dolist (buffer (buffer-list))
(with-current-buffer buffer
(if (or (derived-mode-p 'text-mode) text-mode-variant)
@@ -214,15 +210,14 @@ The argument NLINES says how many lines to center."
(while (not (eq nlines 0))
(save-excursion
(let ((lm (current-left-margin))
- line-length)
+ space)
(beginning-of-line)
(delete-horizontal-space)
(end-of-line)
(delete-horizontal-space)
- (setq line-length (current-column))
- (if (> (- fill-column lm line-length) 0)
- (indent-line-to
- (+ lm (/ (- fill-column lm line-length) 2))))))
+ (setq space (- fill-column lm (current-column)))
+ (if (> space 0)
+ (indent-line-to (+ lm (/ space 2))))))
(cond ((null nlines)
(setq nlines 0))
((> nlines 0)
diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el
index d75898fcc4f..26e084320bd 100644
--- a/lisp/thingatpt.el
+++ b/lisp/thingatpt.el
@@ -42,6 +42,9 @@
;; beginning-op Function to call to skip to the beginning of a "thing".
;; end-op Function to call to skip to the end of a "thing".
;;
+;; For simple things, defined as sequences of specific kinds of characters,
+;; use macro define-thing-chars.
+;;
;; Reliance on existing operators means that many `things' can be accessed
;; without further code: eg.
;; (thing-at-point 'line)
@@ -58,7 +61,7 @@
"Move forward to the end of the Nth next THING.
THING should be a symbol specifying a type of syntactic entity.
Possibilities include `symbol', `list', `sexp', `defun',
-`filename', `url', `email', `word', `sentence', `whitespace',
+`filename', `url', `email', `uuid', `word', `sentence', `whitespace',
`line', and `page'."
(let ((forward-op (or (get thing 'forward-op)
(intern-soft (format "forward-%s" thing)))))
@@ -73,7 +76,7 @@ Possibilities include `symbol', `list', `sexp', `defun',
"Determine the start and end buffer locations for the THING at point.
THING should be a symbol specifying a type of syntactic entity.
Possibilities include `symbol', `list', `sexp', `defun',
-`filename', `url', `email', `word', `sentence', `whitespace',
+`filename', `url', `email', `uuid', `word', `sentence', `whitespace',
`line', and `page'.
See the file `thingatpt.el' for documentation on how to define a
@@ -131,7 +134,7 @@ positions of the thing found."
"Return the THING at point.
THING should be a symbol specifying a type of syntactic entity.
Possibilities include `symbol', `list', `sexp', `defun',
-`filename', `url', `email', `word', `sentence', `whitespace',
+`filename', `url', `email', `uuid', `word', `sentence', `whitespace',
`line', `number', and `page'.
When the optional argument NO-PROPERTIES is non-nil,
@@ -235,21 +238,28 @@ Prefer the enclosing list with fallback on sexp at point.
(put 'defun 'end-op 'end-of-defun)
(put 'defun 'forward-op 'end-of-defun)
+;; Things defined by sets of characters
+
+(defmacro define-thing-chars (thing chars)
+ "Define THING as a sequence of CHARS.
+E.g.:
+\(define-thing-chars twitter-screen-name \"[:alnum:]_\")"
+ `(progn
+ (put ',thing 'end-op
+ (lambda ()
+ (re-search-forward (concat "\\=[" ,chars "]*") nil t)))
+ (put ',thing 'beginning-op
+ (lambda ()
+ (if (re-search-backward (concat "[^" ,chars "]") nil t)
+ (forward-char)
+ (goto-char (point-min)))))))
+
;; Filenames
(defvar thing-at-point-file-name-chars "-~/[:alnum:]_.${}#%,:"
"Characters allowable in filenames.")
-(put 'filename 'end-op
- (lambda ()
- (re-search-forward (concat "\\=[" thing-at-point-file-name-chars "]*")
- nil t)))
-(put 'filename 'beginning-op
- (lambda ()
- (if (re-search-backward (concat "[^" thing-at-point-file-name-chars "]")
- nil t)
- (forward-char)
- (goto-char (point-min)))))
+(define-thing-chars filename thing-at-point-file-name-chars)
;; URIs
@@ -456,11 +466,14 @@ looks like an email address, \"ftp://\" if it starts with
(while htbs
(setq htb (car htbs) htbs (cdr htbs))
(ignore-errors
- ;; errs: htb symbol may be unbound, or not a hash-table.
- ;; gnus-gethash is just a macro for intern-soft.
- (and (symbol-value htb)
- (intern-soft string (symbol-value htb))
- (setq ret string htbs nil))
+ (setq htb (symbol-value htb))
+ (when (cond ((obarrayp htb)
+ (intern-soft string htb))
+ ((listp htb)
+ (member string htb))
+ ((hash-table-p htb)
+ (gethash string htb)))
+ (setq ret string htbs nil))
;; If we made it this far, gnus is running, so ignore "heads":
(setq heads nil)))
(or ret (not heads)
@@ -552,6 +565,24 @@ with angle brackets.")
(put 'buffer 'end-op (lambda () (goto-char (point-max))))
(put 'buffer 'beginning-op (lambda () (goto-char (point-min))))
+;; UUID
+
+(defconst thing-at-point-uuid-regexp
+ (rx bow
+ (repeat 8 hex-digit) "-"
+ (repeat 4 hex-digit) "-"
+ (repeat 4 hex-digit) "-"
+ (repeat 4 hex-digit) "-"
+ (repeat 12 hex-digit)
+ eow)
+ "A regular expression matching a UUID.
+See RFC 4122 for the description of the format.")
+
+(put 'uuid 'bounds-of-thing-at-point
+ (lambda ()
+ (when (thing-at-point-looking-at thing-at-point-uuid-regexp 36)
+ (cons (match-beginning 0) (match-end 0)))))
+
;; Aliases
(defun word-at-point ()
diff --git a/lisp/thread.el b/lisp/thread.el
new file mode 100644
index 00000000000..e8f3cc7da6a
--- /dev/null
+++ b/lisp/thread.el
@@ -0,0 +1,200 @@
+;;; thread.el --- Thread support in Emacs Lisp -*- lexical-binding: t -*-
+
+;; Copyright (C) 2018-2019 Free Software Foundation, Inc.
+
+;; Author: Gemini Lasswell <gazally@runbox.com>
+;; Maintainer: emacs-devel@gnu.org
+;; Keywords: thread, tools
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-when-compile (require 'cl-lib))
+(require 'backtrace)
+(eval-when-compile (require 'pcase))
+(eval-when-compile (require 'subr-x))
+
+;;;###autoload
+(defun thread-handle-event (event)
+ "Handle thread events, propagated by `thread-signal'.
+An EVENT has the format
+ (thread-event THREAD ERROR-SYMBOL DATA)"
+ (interactive "e")
+ (if (and (consp event)
+ (eq (car event) 'thread-event)
+ (= (length event) 4))
+ (let ((thread (cadr event))
+ (err (cddr event)))
+ (message "Error %s: %S" thread err))))
+
+(make-obsolete 'thread-alive-p 'thread-live-p "27.1")
+
+;;; The thread list buffer and list-threads command
+
+(defcustom thread-list-refresh-seconds 0.5
+ "Seconds between automatic refreshes of the *Threads* buffer."
+ :group 'thread-list
+ :type 'number
+ :version "27.1")
+
+(defvar thread-list-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map tabulated-list-mode-map)
+ (define-key map "b" #'thread-list-pop-to-backtrace)
+ (define-key map "s" nil)
+ (define-key map "sq" #'thread-list-send-quit-signal)
+ (define-key map "se" #'thread-list-send-error-signal)
+ (easy-menu-define nil map ""
+ '("Threads"
+ ["Show backtrace" thread-list-pop-to-backtrace t]
+ ["Send Quit Signal" thread-list-send-quit-signal t]
+ ["Send Error Signal" thread-list-send-error-signal t]))
+ map)
+ "Local keymap for `thread-list-mode' buffers.")
+
+(define-derived-mode thread-list-mode tabulated-list-mode "Thread-List"
+ "Major mode for monitoring Lisp threads."
+ (setq tabulated-list-format
+ [("Thread Name" 20 t)
+ ("Status" 10 t)
+ ("Blocked On" 30 t)])
+ (setq tabulated-list-sort-key (cons (car (aref tabulated-list-format 0)) nil))
+ (setq tabulated-list-entries #'thread-list--get-entries)
+ (tabulated-list-init-header))
+
+;;;###autoload
+(defun list-threads ()
+ "Display a list of threads."
+ (interactive)
+ ;; Threads may not exist, if Emacs was configured --without-threads.
+ (unless (bound-and-true-p main-thread)
+ (error "Threads are not supported in this configuration"))
+ ;; Generate the Threads list buffer, and switch to it.
+ (let ((buf (get-buffer-create "*Threads*")))
+ (with-current-buffer buf
+ (unless (derived-mode-p 'thread-list-mode)
+ (thread-list-mode)
+ (run-at-time thread-list-refresh-seconds nil
+ #'thread-list--timer-func buf))
+ (revert-buffer))
+ (switch-to-buffer buf)))
+;; This command can be destructive if they don't know what they are
+;; doing. Kids, don't try this at home!
+;;;###autoload (put 'list-threads 'disabled "Beware: manually canceling threads can ruin your Emacs session.")
+
+(defun thread-list--timer-func (buffer)
+ "Revert BUFFER and set a timer to do it again."
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (revert-buffer))
+ (run-at-time thread-list-refresh-seconds nil
+ #'thread-list--timer-func buffer)))
+
+(defun thread-list--get-entries ()
+ "Return tabulated list entries for the currently live threads."
+ (let (entries)
+ (dolist (thread (all-threads))
+ (pcase-let ((`(,status ,blocker) (thread-list--get-status thread)))
+ (push `(,thread [,(thread-list--name thread)
+ ,status ,blocker])
+ entries)))
+ entries))
+
+(defun thread-list--get-status (thread)
+ "Describe the status of THREAD.
+Return a list of two strings, one describing THREAD's status, the
+other describing THREAD's blocker, if any."
+ (cond
+ ((not (thread-live-p thread)) '("Finished" ""))
+ ((eq thread (current-thread)) '("Running" ""))
+ (t (if-let ((blocker (thread--blocker thread)))
+ `("Blocked" ,(prin1-to-string blocker))
+ '("Yielded" "")))))
+
+(defun thread-list-send-quit-signal ()
+ "Send a quit signal to the thread at point."
+ (interactive)
+ (thread-list--send-signal 'quit))
+
+(defun thread-list-send-error-signal ()
+ "Send an error signal to the thread at point."
+ (interactive)
+ (thread-list--send-signal 'error))
+
+(defun thread-list--send-signal (signal)
+ "Send the specified SIGNAL to the thread at point.
+Ask for user confirmation before signaling the thread."
+ (let ((thread (tabulated-list-get-id)))
+ (if (thread-live-p thread)
+ (when (y-or-n-p (format "Send %s signal to %s? " signal thread))
+ (if (thread-live-p thread)
+ (thread-signal thread signal nil)
+ (message "This thread is no longer alive")))
+ (message "This thread is no longer alive"))))
+
+(defvar-local thread-list-backtrace--thread nil
+ "Thread whose backtrace is displayed in the current buffer.")
+
+(defun thread-list-pop-to-backtrace ()
+ "Display the backtrace for the thread at point."
+ (interactive)
+ (let ((thread (tabulated-list-get-id)))
+ (if (thread-live-p thread)
+ (let ((buffer (get-buffer-create "*Thread Backtrace*")))
+ (pop-to-buffer buffer)
+ (unless (derived-mode-p 'backtrace-mode)
+ (backtrace-mode)
+ (add-hook 'backtrace-revert-hook
+ #'thread-list-backtrace--revert-hook-function)
+ (setq backtrace-insert-header-function
+ #'thread-list-backtrace--insert-header))
+ (setq thread-list-backtrace--thread thread)
+ (thread-list-backtrace--revert-hook-function)
+ (backtrace-print)
+ (goto-char (point-min)))
+ (message "This thread is no longer alive"))))
+
+(defun thread-list-backtrace--revert-hook-function ()
+ (setq backtrace-frames
+ (when (thread-live-p thread-list-backtrace--thread)
+ (mapcar #'thread-list--make-backtrace-frame
+ (backtrace--frames-from-thread
+ thread-list-backtrace--thread)))))
+
+(cl-defun thread-list--make-backtrace-frame ((evald fun &rest args))
+ (backtrace-make-frame :evald evald :fun fun :args args))
+
+(defun thread-list-backtrace--insert-header ()
+ (let ((name (thread-list--name thread-list-backtrace--thread)))
+ (if (thread-live-p thread-list-backtrace--thread)
+ (progn
+ (insert (substitute-command-keys "Backtrace for thread `"))
+ (insert name)
+ (insert (substitute-command-keys "':\n")))
+ (insert (substitute-command-keys "Thread `"))
+ (insert name)
+ (insert (substitute-command-keys "' is no longer running\n")))))
+
+(defun thread-list--name (thread)
+ (or (thread-name thread)
+ (and (eq thread main-thread) "Main")
+ (prin1-to-string thread)))
+
+(provide 'thread)
+;;; thread.el ends here
diff --git a/lisp/thumbs.el b/lisp/thumbs.el
index 3309ed23317..6a17a756548 100644
--- a/lisp/thumbs.el
+++ b/lisp/thumbs.el
@@ -210,7 +210,9 @@ reached."
(mapcar
(lambda (f)
(let ((fattribs-list (file-attributes f)))
- `(,(nth 4 fattribs-list) ,(nth 7 fattribs-list) ,f)))
+ `(,(file-attribute-access-time fattribs-list)
+ ,(file-attribute-size fattribs-list)
+ ,f)))
(directory-files (thumbs-thumbsdir) t (image-file-name-regexp)))
(lambda (l1 l2) (time-less-p (car l1) (car l2)))))
(dirsize (apply '+ (mapcar (lambda (x) (cadr x)) files-list))))
diff --git a/lisp/time.el b/lisp/time.el
index 953e6084e29..35157c5e807 100644
--- a/lisp/time.el
+++ b/lisp/time.el
@@ -336,15 +336,10 @@ would give mode line times like `94/12/30 21:07:48 (UTC)'."
(next-time (timer-relative-time
(list (aref timer 1) (aref timer 2) (aref timer 3))
(* 5 (aref timer 4)) 0)))
- ;; If the activation time is far in the past,
+ ;; If the activation time is not in the future,
;; skip executions until we reach a time in the future.
;; This avoids a long pause if Emacs has been suspended for hours.
- (or (> (nth 0 next-time) (nth 0 current))
- (and (= (nth 0 next-time) (nth 0 current))
- (> (nth 1 next-time) (nth 1 current)))
- (and (= (nth 0 next-time) (nth 0 current))
- (= (nth 1 next-time) (nth 1 current))
- (> (nth 2 next-time) (nth 2 current)))
+ (or (time-less-p current next-time)
(progn
(timer-set-time timer (timer-next-integral-multiple-of-time
current display-time-interval)
@@ -365,7 +360,8 @@ Switches from the 1 to 5 to 15 minute load average, and then back to 1."
(while (and mail-files (= size 0))
;; Count size of regular files only.
(setq size (+ size (or (and (file-regular-p (car mail-files))
- (nth 7 (file-attributes (car mail-files))))
+ (file-attribute-size
+ (file-attributes (car mail-files))))
0)))
(setq mail-files (cdr mail-files)))
(if (> size 0)
@@ -438,23 +434,17 @@ update which can wait for the next redisplay."
((and (stringp mail-spool-file)
(or (null display-time-server-down-time)
;; If have been down for 20 min, try again.
- (> (- (nth 1 now) display-time-server-down-time)
- 1200)
- (and (< (nth 1 now) display-time-server-down-time)
- (> (- (nth 1 now)
- display-time-server-down-time)
- -64336))))
+ (time-less-p 1200 (time-since
+ display-time-server-down-time))))
(let ((start-time (current-time)))
(prog1
(display-time-file-nonempty-p mail-spool-file)
- (if (> (- (nth 1 (current-time))
- (nth 1 start-time))
- 20)
- ;; Record that mail file is not accessible.
- (setq display-time-server-down-time
- (nth 1 (current-time)))
- ;; Record that mail file is accessible.
- (setq display-time-server-down-time nil)))))))
+ ;; Record whether mail file is accessible.
+ (setq display-time-server-down-time
+ (let ((end-time (current-time)))
+ (and (time-less-p 20 (time-subtract
+ end-time start-time))
+ (float-time end-time)))))))))
(24-hours (substring time 11 13))
(hour (string-to-number 24-hours))
(12-hours (int-to-string (1+ (% (+ hour 11) 12))))
@@ -483,14 +473,12 @@ update which can wait for the next redisplay."
(defun display-time-file-nonempty-p (file)
(let ((remote-file-name-inhibit-cache (- display-time-interval 5)))
(and (file-exists-p file)
- (< 0 (nth 7 (file-attributes (file-chase-links file)))))))
+ (< 0 (file-attribute-size
+ (file-attributes (file-chase-links file)))))))
;;;###autoload
(define-minor-mode display-time-mode
"Toggle display of time, load level, and mail flag in mode lines.
-With a prefix argument ARG, enable Display Time mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-it if ARG is omitted or nil.
When Display Time mode is enabled, it updates every minute (you
can control the number of seconds between updates by customizing
@@ -584,8 +572,9 @@ For example, the Unix uptime command format is \"%D, %z%2h:%.2m\"."
(interactive)
(let ((str
(format-seconds (or format "%Y, %D, %H, %M, %z%S")
- (float-time
- (time-subtract (current-time) before-init-time)))))
+ (encode-time
+ (time-since before-init-time)
+ 'integer))))
(if (called-interactively-p 'interactive)
(message "%s" str)
str)))
@@ -595,7 +584,7 @@ For example, the Unix uptime command format is \"%D, %z%2h:%.2m\"."
"Return a string giving the duration of the Emacs initialization."
(interactive)
(let ((str
- (format "%.1f seconds"
+ (format "%s seconds"
(float-time
(time-subtract after-init-time before-init-time)))))
(if (called-interactively-p 'interactive)
diff --git a/lisp/tmm.el b/lisp/tmm.el
index e8122339c8e..44f04eab87b 100644
--- a/lisp/tmm.el
+++ b/lisp/tmm.el
@@ -42,6 +42,23 @@
(defvar tmm-next-shortcut-digit)
(defvar tmm-table-undef)
+(defun tmm-menubar-keymap ()
+ "Return the current menu-bar keymap.
+
+The ordering of the return value respects `menu-bar-final-items'."
+ (let ((menu-bar '())
+ (menu-end '()))
+ (map-keymap
+ (lambda (key binding)
+ (push (cons key binding)
+ ;; If KEY is the name of an item that we want to put last,
+ ;; move it to the end.
+ (if (memq key menu-bar-final-items)
+ menu-end
+ menu-bar)))
+ (tmm-get-keybind [menu-bar]))
+ `(keymap ,@(nreverse menu-bar) ,@(nreverse menu-end))))
+
;;;###autoload (define-key global-map "\M-`" 'tmm-menubar)
;;;###autoload (define-key global-map [menu-bar mouse-1] 'tmm-menubar-mouse)
@@ -58,19 +75,8 @@ to invoke `tmm-menubar' instead, customize the variable
(interactive)
(run-hooks 'menu-bar-update-hook)
;; Obey menu-bar-final-items; put those items last.
- (let ((menu-bar '())
- (menu-end '())
+ (let ((menu-bar (tmm-menubar-keymap))
menu-bar-item)
- (map-keymap
- (lambda (key binding)
- (push (cons key binding)
- ;; If KEY is the name of an item that we want to put last,
- ;; move it to the end.
- (if (memq key menu-bar-final-items)
- menu-end
- menu-bar)))
- (tmm-get-keybind [menu-bar]))
- (setq menu-bar `(keymap ,@(nreverse menu-bar) ,@(nreverse menu-end)))
(if x-position
(let ((column 0)
prev-key)
@@ -154,7 +160,7 @@ specify nil for this variable."
(defvar tmm--history nil)
;;;###autoload
-(defun tmm-prompt (menu &optional in-popup default-item)
+(defun tmm-prompt (menu &optional in-popup default-item no-execute)
"Text-mode emulation of calling the bindings in keymap.
Creates a text-mode menu of possible choices. You can access the elements
in the menu in two ways:
@@ -165,7 +171,9 @@ The last alternative is currently a hack, you cannot use mouse reliably.
MENU is like the MENU argument to `x-popup-menu': either a
keymap or an alist of alists.
DEFAULT-ITEM, if non-nil, specifies an initial default choice.
-Its value should be an event that has a binding in MENU."
+Its value should be an event that has a binding in MENU.
+NO-EXECUTE, if non-nil, means to return the command the user selects
+instead of executing it."
;; If the optional argument IN-POPUP is t,
;; then MENU is an alist of elements of the form (STRING . VALUE).
;; That is used for recursive calls only.
@@ -268,7 +276,7 @@ Its value should be an event that has a binding in MENU."
;; We just did the inner level of a -popup menu.
choice)
;; We just did the outer level. Do the inner level now.
- (not-menu (tmm-prompt choice t))
+ (not-menu (tmm-prompt choice t nil no-execute))
;; We just handled a menu keymap and found another keymap.
((keymapp choice)
(if (symbolp choice)
@@ -276,11 +284,11 @@ Its value should be an event that has a binding in MENU."
(condition-case nil
(require 'mouse)
(error nil))
- (tmm-prompt choice))
+ (tmm-prompt choice nil nil no-execute))
;; We just handled a menu keymap and found a command.
(choice
(if chosen-string
- (progn
+ (if no-execute choice
(setq last-command-event chosen-string)
(call-interactively choice))
choice)))))
diff --git a/lisp/tool-bar.el b/lisp/tool-bar.el
index 06f5bff6c9a..4be16b21fb8 100644
--- a/lisp/tool-bar.el
+++ b/lisp/tool-bar.el
@@ -44,9 +44,6 @@
;; when you are on a tty. I hope that won't cause too much trouble -- rms.
(define-minor-mode tool-bar-mode
"Toggle the tool bar in all graphical frames (Tool Bar mode).
-With a prefix argument ARG, enable Tool Bar mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-Tool Bar mode if ARG is omitted or nil.
See `tool-bar-add-item' and `tool-bar-add-item-from-menu' for
conveniently adding tool bar items."
diff --git a/lisp/tooltip.el b/lisp/tooltip.el
index 8b029b5f07a..b1c69ae7368 100644
--- a/lisp/tooltip.el
+++ b/lisp/tooltip.el
@@ -42,9 +42,6 @@
(define-minor-mode tooltip-mode
"Toggle Tooltip mode.
-With a prefix argument ARG, enable Tooltip mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
When this global minor mode is enabled, Emacs displays help
text (e.g. for buttons and menu items that you put the mouse on)
@@ -155,6 +152,18 @@ This variable is obsolete; instead of setting it to t, disable
(make-obsolete-variable 'tooltip-use-echo-area
"disable Tooltip mode instead" "24.1" 'set)
+(defcustom tooltip-resize-echo-area nil
+ "If non-nil, using the echo area for tooltips will resize the echo area.
+By default, when the echo area is used for displaying tooltips,
+the tooltip text is truncated if it exceeds a single screen line.
+When this variable is non-nil, the text is not truncated; instead,
+the echo area is resized as needed to accommodate the full text
+of the tooltip.
+This variable has effect only on GUI frames."
+ :type 'boolean
+ :group 'tooltip
+ :version "27.1")
+
;;; Variables that are not customizable.
@@ -192,7 +201,8 @@ This might return nil if the event did not occur over a buffer."
(defun tooltip-delay ()
"Return the delay in seconds for the next tooltip."
(if (and tooltip-hide-time
- (< (- (float-time) tooltip-hide-time) tooltip-recent-seconds))
+ (time-less-p (time-since tooltip-hide-time)
+ tooltip-recent-seconds))
tooltip-short-delay
tooltip-delay))
@@ -347,7 +357,8 @@ It is also called if Tooltip mode is on, for text-only displays."
(current-message))))
(setq tooltip-previous-message (current-message)))
(setq tooltip-help-message help)
- (let ((message-truncate-lines t)
+ (let ((message-truncate-lines
+ (or (not (display-graphic-p)) (not tooltip-resize-echo-area)))
(message-log-max nil))
(message "%s" help)))
((stringp tooltip-previous-message)
diff --git a/lisp/tutorial.el b/lisp/tutorial.el
index 3a64e290cd4..37ebb5cbe7c 100644
--- a/lisp/tutorial.el
+++ b/lisp/tutorial.el
@@ -476,8 +476,8 @@ where
((and cua-mode
(or (and (eq def-fun 'ESC-prefix)
(equal key-fun
- `(keymap
- (118 . cua-repeat-replace-region)))
+ '(keymap
+ (118 . cua-repeat-replace-region)))
(setq def-fun-txt "\"ESC prefix\""))
(and (eq def-fun 'mode-specific-command-prefix)
(equal key-fun
diff --git a/lisp/type-break.el b/lisp/type-break.el
index 60aec3cf1fa..0ad79dd1130 100644
--- a/lisp/type-break.el
+++ b/lisp/type-break.el
@@ -287,9 +287,6 @@ again in a short period of time. The idea is to give the user enough time
to find a good breaking point in his or her work, but be sufficiently
annoying to discourage putting typing breaks off indefinitely.
-A negative prefix argument disables this mode.
-No argument or any non-negative argument enables it.
-
The user may enable or disable this mode by setting the variable of the
same name, though setting it in that way doesn't reschedule a break or
reset the keystroke counter.
@@ -376,7 +373,7 @@ problems."
(if (and type-break-time-last-break
(< (setq diff (type-break-time-difference
type-break-time-last-break
- (current-time)))
+ nil))
type-break-interval))
;; Use the file's value.
(progn
@@ -406,9 +403,6 @@ problems."
(define-minor-mode type-break-mode-line-message-mode
"Toggle warnings about typing breaks in the mode line.
-With a prefix argument ARG, enable these warnings if ARG is
-positive, and disable them otherwise. If called from Lisp,
-enable them if ARG is omitted or nil.
The user may also enable or disable this mode simply by setting
the variable of the same name.
@@ -423,9 +417,6 @@ Variables controlling the display of messages in the mode line include:
(define-minor-mode type-break-query-mode
"Toggle typing break queries.
-With a prefix argument ARG, enable these queries if ARG is
-positive, and disable them otherwise. If called from Lisp,
-enable them if ARG is omitted or nil.
The user may also enable or disable this mode simply by setting
the variable of the same name."
@@ -469,8 +460,7 @@ the variable of the same name."
))))))
(defun timep (time)
- "If TIME is in the format returned by `current-time' then
-return TIME, else return nil."
+ "If TIME is a Lisp time value then return TIME, else return nil."
(condition-case nil
(and (float-time time) time)
(error nil)))
@@ -490,8 +480,7 @@ return TIME, else return nil."
(defun type-break-get-previous-time ()
"Get previous break time from `type-break-file-name'.
-Returns nil if the file is missing or if the time breaks with the
-`current-time' format."
+Return nil if the file is missing or if the time is not a Lisp time value."
(let ((file (type-break-choose-file)))
(if file
(timep ;; returns expected format, else nil
@@ -563,7 +552,7 @@ as per the function `type-break-schedule'."
(cond
(good-interval
(let ((break-secs (type-break-time-difference
- start-time (current-time))))
+ start-time nil)))
(cond
((>= break-secs good-interval)
(setq continue nil))
@@ -624,7 +613,7 @@ INTERVAL is the full length of an interval (defaults to TIME)."
type-break-time-warning-intervals))
(or time
- (setq time (type-break-time-difference (current-time)
+ (setq time (type-break-time-difference nil
type-break-time-next-break)))
(while (and type-break-current-time-warning-interval
@@ -685,7 +674,7 @@ keystroke threshold has been exceeded."
(and type-break-good-rest-interval
(progn
(and (> (type-break-time-difference
- type-break-time-last-command (current-time))
+ type-break-time-last-command nil)
type-break-good-rest-interval)
(progn
(type-break-keystroke-reset)
@@ -817,7 +806,7 @@ this or ask the user to start one right now."
((and (car type-break-keystroke-threshold)
(< type-break-keystroke-count (car type-break-keystroke-threshold))))
((> type-break-time-warning-count 0)
- (let ((timeleft (type-break-time-difference (current-time)
+ (let ((timeleft (type-break-time-difference nil
type-break-time-next-break)))
(setq type-break-warning-countdown-string (number-to-string timeleft))
(cond
@@ -914,8 +903,8 @@ Current keystroke count : %s"
(current-time-string type-break-time-next-break)
(type-break-format-time
(type-break-time-difference
- (current-time)
- type-break-time-next-break)))
+ nil
+ type-break-time-next-break)))
"none scheduled")
(or (car type-break-keystroke-threshold) "none")
(or (cdr type-break-keystroke-threshold) "none")
@@ -1099,7 +1088,7 @@ With optional non-nil ALL, force redisplay of all mode-lines."
(erase-buffer)
(setq elapsed (type-break-time-difference
type-break-time-last-break
- (current-time)))
+ nil))
(let ((good-interval (or type-break-good-rest-interval
type-break-good-break-interval)))
(cond
diff --git a/lisp/url/url-auth.el b/lisp/url/url-auth.el
index c3714f26562..0746cfd96cb 100644
--- a/lisp/url/url-auth.el
+++ b/lisp/url/url-auth.el
@@ -192,9 +192,10 @@ key cache `url-digest-auth-storage'."
(defun url-digest-auth-make-cnonce ()
"Compute a new unique client nonce value."
(base64-encode-string
- (apply 'format "%016x%04x%04x%05x%05x" (random) (current-time)) t))
+ (format "%016x%016x" (random) (car (encode-time nil t)))
+ t))
-(defun url-digest-auth-nonce-count (nonce)
+(defun url-digest-auth-nonce-count (_nonce)
"The number requests sent to server with the given NONCE.
This count includes the request we're preparing here.
diff --git a/lisp/url/url-cache.el b/lisp/url/url-cache.el
index 01e57799cc6..b306082c3ba 100644
--- a/lisp/url/url-cache.el
+++ b/lisp/url/url-cache.el
@@ -86,10 +86,10 @@ FILE can be created or overwritten."
The actual return value is the last modification time of the cache file."
(let* ((fname (url-cache-create-filename url))
(attribs (file-attributes fname)))
- (and fname ; got a filename
- (file-exists-p fname) ; file exists
- (not (eq (nth 0 attribs) t)) ; Its not a directory
- (nth 5 attribs)))) ; Can get last mod-time
+ (and fname
+ (file-exists-p fname)
+ (not (eq (file-attribute-type attribs) t))
+ (file-attribute-modification-time attribs))))
(defun url-cache-create-filename-human-readable (url)
"Return a filename in the local cache for URL."
@@ -205,8 +205,8 @@ If `url-standalone-mode' is non-nil, cached items never expire."
(time-less-p
(time-add
cache-time
- (seconds-to-time (or expire-time url-cache-expire-time)))
- (current-time))))))
+ (or expire-time url-cache-expire-time))
+ nil)))))
(defun url-cache-prune-cache (&optional directory)
"Remove all expired files from the cache.
@@ -226,8 +226,8 @@ considered \"expired\"."
(setq deleted-files (1+ deleted-files))))
((time-less-p
(time-add
- (nth 5 (file-attributes file))
- (seconds-to-time url-cache-expire-time))
+ (file-attribute-modification-time (file-attributes file))
+ url-cache-expire-time)
now)
(delete-file file)
(setq deleted-files (1+ deleted-files))))))
diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el
index 61fd85bbf1e..31fc3e72664 100644
--- a/lisp/url/url-cookie.el
+++ b/lisp/url/url-cookie.el
@@ -74,6 +74,54 @@ telling Microsoft that."
;; It's completely normal for the cookies file not to exist yet.
(load (or fname url-cookie-file) t t))
+(defun url-cookie-parse-file-netscape (filename &optional long-session)
+ "Load cookies from FILENAME in Netscape/Mozilla format.
+When LONG-SESSION is non-nil, session cookies (expiring at t=0
+i.e. 1970-1-1) are loaded as expiring one year from now instead."
+ (interactive "fLoad Netscape/Mozilla cookie file: ")
+ (let ((n 0))
+ (with-temp-buffer
+ (insert-file-contents-literally filename)
+ (goto-char (point-min))
+ (when (not (looking-at-p "# Netscape HTTP Cookie File\n"))
+ (error (format "File %s doesn't look like a netscape cookie file" filename)))
+ (while (not (eobp))
+ (when (not (looking-at-p (rx bol (* space) "#")))
+ (let* ((line (buffer-substring (point) (save-excursion (end-of-line) (point))))
+ (fields (split-string line "\t")))
+ (cond
+ ;;((>= 1 (length line) 0)
+ ;; (message "skipping empty line"))
+ ((= (length fields) 7)
+ (let ((dom (nth 0 fields))
+ ;; (match (nth 1 fields))
+ (path (nth 2 fields))
+ (secure (string= (nth 3 fields) "TRUE"))
+ ;; session cookies (expire time = 0) are supposed
+ ;; to be removed when the browser is closed, but
+ ;; the main point of loading external cookie is to
+ ;; reuse a browser session, so to prevent the
+ ;; cookie from being detected as expired straight
+ ;; away, make it expire a year from now
+ (expires (format-time-string
+ "%d %b %Y %T [GMT]"
+ (let ((s (string-to-number (nth 4 fields))))
+ (if (and (zerop s) long-session)
+ (time-add nil (* 365 24 60 60))
+ s))))
+ (key (nth 5 fields))
+ (val (nth 6 fields)))
+ (cl-incf n)
+ ;;(message "adding <%s>=<%s> exp=<%s> dom=<%s> path=<%s> sec=%S" key val expires dom path secure)
+ (url-cookie-store key val expires dom path secure)
+ ))
+ (t
+ (message "ignoring malformed cookie line <%s>" line)))))
+ (forward-line))
+ (when (< 0 n)
+ (setq url-cookies-changed-since-last-save t))
+ (message "added %d cookies from file %s" n filename))))
+
(defun url-cookie-clean-up (&optional secure)
(let ((var (if secure 'url-cookie-secure-storage 'url-cookie-storage))
new new-cookies)
@@ -90,7 +138,8 @@ telling Microsoft that."
(set var new)))
(defun url-cookie-write-file (&optional fname)
- (when url-cookies-changed-since-last-save
+ (when (and url-cookies-changed-since-last-save
+ url-cookie-file)
(or fname (setq fname (expand-file-name url-cookie-file)))
(if (condition-case nil
(progn
@@ -345,6 +394,8 @@ instead delete all cookies that do not match REGEXP."
;;; Mode for listing and editing cookies.
+(defvar url-cookie--deleted-cookies nil)
+
(defun url-cookie-list ()
"Display a buffer listing the current URL cookies, if there are any.
Use \\<url-cookie-mode-map>\\[url-cookie-delete] to remove cookies."
@@ -354,6 +405,11 @@ Use \\<url-cookie-mode-map>\\[url-cookie-delete] to remove cookies."
(error "No cookies are defined"))
(pop-to-buffer "*url cookies*")
+ (url-cookie-mode)
+ (url-cookie--generate-buffer)
+ (goto-char (point-min)))
+
+(defun url-cookie--generate-buffer ()
(let ((inhibit-read-only t)
(domains (sort
(copy-sequence
@@ -364,7 +420,6 @@ Use \\<url-cookie-mode-map>\\[url-cookie-delete] to remove cookies."
(domain-length 0)
start name format domain)
(erase-buffer)
- (url-cookie-mode)
(dolist (elem domains)
(setq domain-length (max domain-length (length (car elem)))))
(setq format (format "%%-%ds %%-20s %%s" domain-length)
@@ -376,16 +431,15 @@ Use \\<url-cookie-mode-map>\\[url-cookie-delete] to remove cookies."
(lambda (c1 c2)
(string< (url-cookie-name c1)
(url-cookie-name c2)))))
- (setq start (point)
+ (setq start (point)
name (url-cookie-name cookie))
- (when (> (length name) 20)
+ (when (> (length name) 20)
(setq name (substring name 0 20)))
- (insert (format format domain name
- (url-cookie-value cookie))
- "\n")
- (setq domain "")
- (put-text-property start (1+ start) 'url-cookie cookie)))
- (goto-char (point-min))))
+ (insert (format format domain name
+ (url-cookie-value cookie))
+ "\n")
+ (setq domain "")
+ (put-text-property start (1+ start) 'url-cookie cookie)))))
(defun url-cookie-delete ()
"Delete the cookie on the current line."
@@ -409,12 +463,41 @@ Use \\<url-cookie-mode-map>\\[url-cookie-delete] to remove cookies."
(delete-region (line-beginning-position)
(progn
(forward-line 1)
- (point)))))
+ (point)))
+ (let ((point (point)))
+ (erase-buffer)
+ (url-cookie--generate-buffer)
+ (goto-char point))
+ (push cookie url-cookie--deleted-cookies)))
+
+(defun url-cookie-undo ()
+ "Undo deletion of a cookie."
+ (interactive)
+ (unless url-cookie--deleted-cookies
+ (error "No cookie deletions to undo"))
+ (let* ((cookie (pop url-cookie--deleted-cookies))
+ (variable (if (url-cookie-secure cookie)
+ 'url-cookie-secure-storage
+ 'url-cookie-storage))
+ (list (symbol-value variable))
+ (elem (assoc (url-cookie-domain cookie) list)))
+ (if elem
+ (nconc elem (list cookie))
+ (setq elem (list (url-cookie-domain cookie) cookie))
+ (set variable (cons elem list)))
+ (setq url-cookies-changed-since-last-save t)
+ (url-cookie-write-file)
+ (let ((point (point))
+ (inhibit-read-only t))
+ (erase-buffer)
+ (url-cookie--generate-buffer)
+ (goto-char point))))
(defvar url-cookie-mode-map
(let ((map (make-sparse-keymap)))
(define-key map [delete] 'url-cookie-delete)
(define-key map [(control k)] 'url-cookie-delete)
+ (define-key map [(control _)] 'url-cookie-undo)
map))
(define-derived-mode url-cookie-mode special-mode "URL Cookie"
diff --git a/lisp/url/url-dav.el b/lisp/url/url-dav.el
index f2182e39e65..a4cf0f0ec01 100644
--- a/lisp/url/url-dav.el
+++ b/lisp/url/url-dav.el
@@ -146,7 +146,7 @@ Returns nil if WebDAV is not supported."
(setq time (parse-time-string date-string)))
(if time
- (setq time (apply 'encode-time time))
+ (setq time (encode-time time))
(url-debug 'dav "Unable to decode date (%S) (%s)"
(xml-node-name node) date-string))
time))
@@ -204,22 +204,22 @@ Returns nil if WebDAV is not supported."
value nil)
(pcase node-type
- ((or `dateTime.iso8601tz
- `dateTime.iso8601
- `dateTime.tz
- `dateTime.rfc1123
- `dateTime
- `date) ; date is our 'special' one...
+ ((or 'dateTime.iso8601tz
+ 'dateTime.iso8601
+ 'dateTime.tz
+ 'dateTime.rfc1123
+ 'dateTime
+ 'date) ; date is our 'special' one...
;; Some type of date/time string.
(setq value (url-dav-process-date-property node)))
- (`int
+ ('int
;; Integer type...
(setq value (url-dav-process-integer-property node)))
- ((or `number `float)
+ ((or 'number 'float)
(setq value (url-dav-process-number-property node)))
- (`boolean
+ ('boolean
(setq value (url-dav-process-boolean-property node)))
- (`uri
+ ('uri
(setq value (url-dav-process-uri-property node)))
(_
(if (not (eq node-type 'unknown))
@@ -611,11 +611,11 @@ Returns t if the lock was successfully released."
(setq lock (car supported-locks)
supported-locks (cdr supported-locks))
(pcase (car lock)
- (`DAV:write
+ ('DAV:write
(pcase (cdr lock)
- (`DAV:shared ; group permissions (possibly world)
+ ('DAV:shared ; group permissions (possibly world)
(aset modes 5 ?w))
- (`DAV:exclusive
+ ('DAV:exclusive
(aset modes 2 ?w)) ; owner permissions?
(_
(url-debug 'dav "Unrecognized DAV:lockscope (%S)" (cdr lock)))))
diff --git a/lisp/url/url-dired.el b/lisp/url/url-dired.el
index 0d7f22b61c5..a665db86fef 100644
--- a/lisp/url/url-dired.el
+++ b/lisp/url/url-dired.el
@@ -43,10 +43,7 @@
(url-dired-find-file))
(define-minor-mode url-dired-minor-mode
- "Minor mode for directory browsing.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil."
+ "Minor mode for directory browsing."
:lighter " URL" :keymap url-dired-minor-mode-map)
(defun url-find-file-dired (dir)
diff --git a/lisp/url/url-file.el b/lisp/url/url-file.el
index 23fc97828ff..b953ce76940 100644
--- a/lisp/url/url-file.el
+++ b/lisp/url/url-file.el
@@ -1,4 +1,4 @@
-;;; url-file.el --- File retrieval code
+;;; url-file.el --- File retrieval code -*- lexical-binding:t -*-
;; Copyright (C) 1996-1999, 2004-2019 Free Software Foundation, Inc.
@@ -33,7 +33,7 @@
(defconst url-file-asynchronous-p t "FTP transfers are asynchronous.")
(defalias 'url-file-expand-file-name 'url-default-expander)
-(defun url-file-find-possibly-compressed-file (fname &rest args)
+(defun url-file-find-possibly-compressed-file (fname &rest _)
"Find the exact file referenced by `fname'.
This tries the common compression extensions, because things like
ange-ftp and efs are not quite smart enough to realize when a server
@@ -63,14 +63,14 @@ to them."
(match-beginning 0))
(system-name)))))))
-(defun url-file-asynch-callback (x y name buff func args &optional efs)
+(defun url-file-asynch-callback (_x _y name buff func args &optional efs)
(if (not (featurep 'ange-ftp))
;; EFS passes us an extra argument
(setq name buff
buff func
func args
args efs))
- (let ((size (nth 7 (file-attributes name))))
+ (let ((size (file-attribute-size (file-attributes name))))
(with-current-buffer buff
(goto-char (point-max))
(if (/= -1 size)
@@ -114,8 +114,7 @@ to them."
((string-match "\\`/[^/]+:/" file)
(concat "/:" file))
(t
- file)))
- pos-index)
+ file))))
(and user pass
(cond
@@ -142,17 +141,6 @@ to them."
(not (string-match "/\\'" filename)))
(setf (url-filename url) (format "%s/" filename)))
-
- ;; If it is a directory, look for an index file first.
- (if (and (file-directory-p filename)
- url-directory-index-file
- (setq pos-index (expand-file-name url-directory-index-file filename))
- (file-exists-p pos-index)
- (file-readable-p pos-index))
- (setq filename pos-index))
-
- ;; Find the (possibly compressed) file
- (setq filename (url-file-find-possibly-compressed-file filename))
filename))
;;;###autoload
@@ -211,7 +199,7 @@ to them."
(if (featurep 'ange-ftp)
(ange-ftp-copy-file-internal filename (expand-file-name new) t
nil t
- (list 'url-file-asynch-callback
+ (list #'url-file-asynch-callback
new (current-buffer)
callback cbargs)
t)
@@ -220,7 +208,7 @@ to them."
(efs-copy-file-internal filename (efs-ftp-path filename)
new (efs-ftp-path new)
t nil 0
- (list 'url-file-asynch-callback
+ (list #'url-file-asynch-callback
new (current-buffer)
callback cbargs)
0 nil)))))))
diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el
index c62e813b663..54360840784 100644
--- a/lisp/url/url-gw.el
+++ b/lisp/url/url-gw.el
@@ -239,7 +239,7 @@ overriding the value of `url-gateway-method'."
(let ((coding-system-for-read 'binary)
(coding-system-for-write 'binary))
(setq conn (pcase gw-method
- ((or `tls `ssl `native)
+ ((or 'tls 'ssl 'native)
(if (eq gw-method 'native)
(setq gw-method 'plain))
(open-network-stream
@@ -249,11 +249,11 @@ overriding the value of `url-gateway-method'."
:nowait (and (featurep 'make-network-process)
(url-asynchronous url-current-object)
'(:nowait t))))
- (`socks
+ ('socks
(socks-open-network-stream name buffer host service))
- (`telnet
+ ('telnet
(url-open-telnet name buffer host service))
- (`rlogin
+ ('rlogin
(url-open-rlogin name buffer host service))
(_
(error "Bad setting of url-gateway-method: %s"
diff --git a/lisp/url/url-handlers.el b/lisp/url/url-handlers.el
index 91f9b7f5208..e35d999e0fe 100644
--- a/lisp/url/url-handlers.el
+++ b/lisp/url/url-handlers.el
@@ -28,6 +28,7 @@
;; (require 'url-util)
(eval-when-compile (require 'mm-decode))
;; (require 'mailcap)
+(eval-when-compile (require 'subr-x))
;; The following are autoloaded instead of `require'd to avoid eagerly
;; loading all of URL when turning on url-handler-mode in the .emacs.
(autoload 'url-expand-file-name "url-expand" "Convert url to a fully specified url, and canonicalize it.")
@@ -41,7 +42,7 @@
(declare-function mm-decode-string "mm-bodies" (string charset))
;; mm-decode loads mail-parse.
(declare-function mail-content-type-get "mail-parse" (ct attribute))
-;; mm-bodies loads mm-util.
+;; mm-decode loads mm-bodies, which loads mm-util.
(declare-function mm-charset-to-coding-system "mm-util"
(charset &optional lbt allow-override silent))
@@ -101,10 +102,7 @@
;;;###autoload
(define-minor-mode url-handler-mode
- "Toggle using `url' library for URL filenames (URL Handler mode).
-With a prefix argument ARG, enable URL Handler mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil."
+ "Toggle using `url' library for URL filenames (URL Handler mode)."
:global t :group 'url
;; Remove old entry, if any.
(setq file-name-handler-alist
@@ -186,6 +184,7 @@ the arguments that would have been passed to OPERATION."
(put 'file-name-absolute-p 'url-file-handlers (lambda (&rest ignored) t))
(put 'expand-file-name 'url-file-handlers 'url-handler-expand-file-name)
(put 'directory-file-name 'url-file-handlers 'url-handler-directory-file-name)
+(put 'file-name-directory 'url-file-handlers 'url-handler-file-name-directory)
(put 'unhandled-file-name-directory 'url-file-handlers 'url-handler-unhandled-file-name-directory)
(put 'file-remote-p 'url-file-handlers 'url-handler-file-remote-p)
;; (put 'file-name-as-directory 'url-file-handlers 'url-handler-file-name-as-directory)
@@ -231,6 +230,14 @@ the arguments that would have been passed to OPERATION."
;; a local process.
nil)))
+(defun url-handler-file-name-directory (dir)
+ (let ((url (url-generic-parse-url dir)))
+ ;; Do not attempt to handle `file' URLs which are local.
+ (if (and (not (equal (url-type url) "file"))
+ (string-empty-p (url-filename url)))
+ (url-handler-file-name-directory (concat dir "/"))
+ (url-run-real-handler 'file-name-directory (list dir)))))
+
(defun url-handler-file-remote-p (filename &optional identification _connected)
(let ((url (url-generic-parse-url filename)))
(if (and (url-type url) (not (equal (url-type url) "file")))
diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el
index 1bcfc10645d..cf1952066a5 100644
--- a/lisp/url/url-http.el
+++ b/lisp/url/url-http.el
@@ -54,6 +54,7 @@
(defvar url-http-target-url)
(defvar url-http-transfer-encoding)
(defvar url-show-status)
+(defvar url-http-referer)
(require 'url-gw)
(require 'url-parse)
@@ -149,7 +150,7 @@ request.")
;; These routines will allow us to implement persistent HTTP
;; connections.
(defsubst url-http-debug (&rest args)
- (if quit-flag
+ (if (eq quit-flag t)
(let ((proc (get-buffer-process (current-buffer))))
;; The user hit C-g, honor it! Some things can get in an
;; incredibly tight loop (chunked encoding)
@@ -238,6 +239,35 @@ request.")
emacs-info os-info))
" ")))
+(defun url-http--get-referer (url)
+ (url-http-debug "getting referer from buffer: buffer:%S target-url:%S lastloc:%S" (current-buffer) url url-current-lastloc)
+ (when url-current-lastloc
+ (if (not (url-p url-current-lastloc))
+ (setq url-current-lastloc (url-generic-parse-url url-current-lastloc)))
+ (let ((referer (copy-sequence url-current-lastloc)))
+ (setf (url-host referer) (puny-encode-domain (url-host referer)))
+ (let ((referer-string (url-recreate-url referer)))
+ (when (and (not (memq url-privacy-level '(low high paranoid)))
+ (not (and (listp url-privacy-level)
+ (memq 'lastloc url-privacy-level))))
+ ;; url-privacy-level allows referer. But url-lastloc-privacy-level
+ ;; may restrict who we send it to.
+ (cl-case url-lastloc-privacy-level
+ (host-match
+ (let ((referer-host (url-host referer))
+ (url-host (url-host url)))
+ (when (string= referer-host url-host)
+ referer-string)))
+ (domain-match
+ (let ((referer-domain (url-domain referer))
+ (url-domain (url-domain url)))
+ (when (and referer-domain
+ url-domain
+ (string= referer-domain url-domain))
+ referer-string)))
+ (otherwise
+ referer-string)))))))
+
;; Building an HTTP request
(defun url-http-user-agent-string ()
"Compute a User-Agent string.
@@ -254,8 +284,9 @@ The string is based on `url-privacy-level' and `url-user-agent'."
((eq url-user-agent 'default) (url-http--user-agent-default-string))))))
(if ua-string (format "User-Agent: %s\r\n" (string-trim ua-string)) "")))
-(defun url-http-create-request (&optional ref-url)
- "Create an HTTP request for `url-http-target-url', referred to by REF-URL."
+(defun url-http-create-request ()
+ "Create an HTTP request for `url-http-target-url'.
+Use `url-http-referer' as the Referer-header (subject to `url-privacy-level')."
(let* ((extra-headers)
(request nil)
(no-cache (cdr-safe (assoc "Pragma" url-http-extra-headers)))
@@ -268,13 +299,14 @@ The string is based on `url-privacy-level' and `url-user-agent'."
'url-http-proxy-basic-auth-storage))
(url-get-authentication url-http-proxy nil 'any nil))))
(real-fname (url-filename url-http-target-url))
- (host (url-http--encode-string (url-host url-http-target-url)))
+ (host (url-host url-http-target-url))
(auth (if (cdr-safe (assoc "Authorization" url-http-extra-headers))
nil
(url-get-authentication (or
(and (boundp 'proxy-info)
proxy-info)
- url-http-target-url) nil 'any nil))))
+ url-http-target-url) nil 'any nil)))
+ (ref-url (url-http--encode-string url-http-referer)))
(if (equal "" real-fname)
(setq real-fname "/"))
(setq no-cache (and no-cache (string-match "no-cache" no-cache)))
@@ -288,12 +320,6 @@ The string is based on `url-privacy-level' and `url-user-agent'."
(string= ref-url "")))
(setq ref-url nil))
- ;; We do not want to expose the referrer if the user is paranoid.
- (if (or (memq url-privacy-level '(low high paranoid))
- (and (listp url-privacy-level)
- (memq 'lastloc url-privacy-level)))
- (setq ref-url nil))
-
;; url-http-extra-headers contains an assoc-list of
;; header/value pairs that we need to put into the request.
(setq extra-headers (mapconcat
@@ -329,9 +355,11 @@ The string is based on `url-privacy-level' and `url-user-agent'."
(url-scheme-get-property
(url-type url-http-target-url) 'default-port))
(format
- "Host: %s:%d\r\n" (puny-encode-domain host)
+ "Host: %s:%d\r\n" (url-http--encode-string
+ (puny-encode-domain host))
(url-port url-http-target-url))
- (format "Host: %s\r\n" (puny-encode-domain host)))
+ (format "Host: %s\r\n"
+ (url-http--encode-string (puny-encode-domain host))))
;; Who its from
(if url-personal-mail-address
(concat
@@ -485,11 +513,11 @@ Return the number of characters removed."
(url-http-debug "url-http-parse-response called in (%s)" (buffer-name))
(goto-char (point-min))
(skip-chars-forward " \t\n") ; Skip any blank crap
- (skip-chars-forward "HTTP/") ; Skip HTTP Version
+ (skip-chars-forward "/HPT") ; Skip HTTP Version "HTTP/".
(setq url-http-response-version
(buffer-substring (point)
(progn
- (skip-chars-forward "[0-9].")
+ (skip-chars-forward "0-9.")
(point))))
(setq url-http-response-status (read (current-buffer))))
@@ -585,7 +613,7 @@ should be shown to the user."
;; 206 Partial content
;; 207 Multi-status (Added by DAV)
(pcase status-symbol
- ((or `no-content `reset-content)
+ ((or 'no-content 'reset-content)
;; No new data, just stay at the same document
(url-mark-buffer-as-dead buffer))
(_
@@ -606,7 +634,7 @@ should be shown to the user."
(let ((redirect-uri (or (mail-fetch-field "Location")
(mail-fetch-field "URI"))))
(pcase status-symbol
- (`multiple-choices ; 300
+ ('multiple-choices ; 300
;; Quoth the spec (section 10.3.1)
;; -------------------------------
;; The requested resource corresponds to any one of a set of
@@ -623,20 +651,26 @@ should be shown to the user."
;; We do not support agent-driven negotiation, so we just
;; redirect to the preferred URI if one is provided.
nil)
- (`see-other ; 303
+ ('found ; 302
+ ;; 302 Found was ambiguously defined in the standards, but
+ ;; it's now recommended that it's treated like 303 instead
+ ;; of 307, since that's what most servers expect.
+ (setq url-http-method "GET"
+ url-http-data nil))
+ ('see-other ; 303
;; The response to the request can be found under a different
;; URI and SHOULD be retrieved using a GET method on that
;; resource.
(setq url-http-method "GET"
url-http-data nil))
- (`not-modified ; 304
+ ('not-modified ; 304
;; The 304 response MUST NOT contain a message-body.
(url-http-debug "Extracting document from cache... (%s)"
(url-cache-create-filename (url-view-url t)))
(url-cache-extract (url-cache-create-filename (url-view-url t)))
(setq redirect-uri nil
success t))
- (`use-proxy ; 305
+ ('use-proxy ; 305
;; The requested resource MUST be accessed through the
;; proxy given by the Location field. The Location field
;; gives the URI of the proxy. The recipient is expected
@@ -734,50 +768,50 @@ should be shown to the user."
;; 424 Failed Dependency
(setq success
(pcase status-symbol
- (`unauthorized ; 401
+ ('unauthorized ; 401
;; The request requires user authentication. The response
;; MUST include a WWW-Authenticate header field containing a
;; challenge applicable to the requested resource. The
;; client MAY repeat the request with a suitable
;; Authorization header field.
(url-http-handle-authentication nil))
- (`payment-required ; 402
+ ('payment-required ; 402
;; This code is reserved for future use
(url-mark-buffer-as-dead buffer)
(error "Somebody wants you to give them money"))
- (`forbidden ; 403
+ ('forbidden ; 403
;; The server understood the request, but is refusing to
;; fulfill it. Authorization will not help and the request
;; SHOULD NOT be repeated.
t)
- (`not-found ; 404
+ ('not-found ; 404
;; Not found
t)
- (`method-not-allowed ; 405
+ ('method-not-allowed ; 405
;; The method specified in the Request-Line is not allowed
;; for the resource identified by the Request-URI. The
;; response MUST include an Allow header containing a list of
;; valid methods for the requested resource.
t)
- (`not-acceptable ; 406
+ ('not-acceptable ; 406
;; The resource identified by the request is only capable of
;; generating response entities which have content
;; characteristics not acceptable according to the accept
;; headers sent in the request.
t)
- (`proxy-authentication-required ; 407
+ ('proxy-authentication-required ; 407
;; This code is similar to 401 (Unauthorized), but indicates
;; that the client must first authenticate itself with the
;; proxy. The proxy MUST return a Proxy-Authenticate header
;; field containing a challenge applicable to the proxy for
;; the requested resource.
(url-http-handle-authentication t))
- (`request-timeout ; 408
+ ('request-timeout ; 408
;; The client did not produce a request within the time that
;; the server was prepared to wait. The client MAY repeat
;; the request without modifications at any later time.
t)
- (`conflict ; 409
+ ('conflict ; 409
;; The request could not be completed due to a conflict with
;; the current state of the resource. This code is only
;; allowed in situations where it is expected that the user
@@ -786,11 +820,11 @@ should be shown to the user."
;; information for the user to recognize the source of the
;; conflict.
t)
- (`gone ; 410
+ ('gone ; 410
;; The requested resource is no longer available at the
;; server and no forwarding address is known.
t)
- (`length-required ; 411
+ ('length-required ; 411
;; The server refuses to accept the request without a defined
;; Content-Length. The client MAY repeat the request if it
;; adds a valid Content-Length header field containing the
@@ -800,29 +834,29 @@ should be shown to the user."
;; `url-http-create-request' automatically calculates the
;; content-length.
t)
- (`precondition-failed ; 412
+ ('precondition-failed ; 412
;; The precondition given in one or more of the
;; request-header fields evaluated to false when it was
;; tested on the server.
t)
- ((or `request-entity-too-large `request-uri-too-large) ; 413 414
+ ((or 'request-entity-too-large 'request-uri-too-large) ; 413 414
;; The server is refusing to process a request because the
;; request entity|URI is larger than the server is willing or
;; able to process.
t)
- (`unsupported-media-type ; 415
+ ('unsupported-media-type ; 415
;; The server is refusing to service the request because the
;; entity of the request is in a format not supported by the
;; requested resource for the requested method.
t)
- (`requested-range-not-satisfiable ; 416
+ ('requested-range-not-satisfiable ; 416
;; A server SHOULD return a response with this status code if
;; a request included a Range request-header field, and none
;; of the range-specifier values in this field overlap the
;; current extent of the selected resource, and the request
;; did not include an If-Range request-header field.
t)
- (`expectation-failed ; 417
+ ('expectation-failed ; 417
;; The expectation given in an Expect request-header field
;; could not be met by this server, or, if the server is a
;; proxy, the server has unambiguous evidence that the
@@ -849,16 +883,16 @@ should be shown to the user."
;; 507 Insufficient storage
(setq success t)
(pcase url-http-response-status
- (`not-implemented ; 501
+ ('not-implemented ; 501
;; The server does not support the functionality required to
;; fulfill the request.
nil)
- (`bad-gateway ; 502
+ ('bad-gateway ; 502
;; The server, while acting as a gateway or proxy, received
;; an invalid response from the upstream server it accessed
;; in attempting to fulfill the request.
nil)
- (`service-unavailable ; 503
+ ('service-unavailable ; 503
;; The server is currently unable to handle the request due
;; to a temporary overloading or maintenance of the server.
;; The implication is that this is a temporary condition
@@ -867,19 +901,19 @@ should be shown to the user."
;; header. If no Retry-After is given, the client SHOULD
;; handle the response as it would for a 500 response.
nil)
- (`gateway-timeout ; 504
+ ('gateway-timeout ; 504
;; The server, while acting as a gateway or proxy, did not
;; receive a timely response from the upstream server
;; specified by the URI (e.g. HTTP, FTP, LDAP) or some other
;; auxiliary server (e.g. DNS) it needed to access in
;; attempting to complete the request.
nil)
- (`http-version-not-supported ; 505
+ ('http-version-not-supported ; 505
;; The server does not support, or refuses to support, the
;; HTTP protocol version that was used in the request
;; message.
nil)
- (`insufficient-storage ; 507 (DAV)
+ ('insufficient-storage ; 507 (DAV)
;; The method could not be performed on the resource
;; because the server is unable to store the representation
;; needed to successfully complete the request. This
@@ -905,7 +939,8 @@ should be shown to the user."
(goto-char (point-min))
success))
-(declare-function zlib-decompress-region "decompress.c" (start end))
+(declare-function zlib-decompress-region "decompress.c"
+ (start end &optional allow-partial))
(defun url-handle-content-transfer-encoding ()
(let ((encoding (mail-fetch-field "content-encoding")))
@@ -917,7 +952,7 @@ should be shown to the user."
(widen)
(goto-char (point-min))
(when (search-forward "\n\n")
- (zlib-decompress-region (point) (point-max)))))))
+ (zlib-decompress-region (point) (point-max) t))))))
;; Miscellaneous
(defun url-http-activate-callback ()
@@ -1258,7 +1293,8 @@ The return value of this function is the retrieval buffer."
(mime-accept-string url-mime-accept-string)
(buffer (or retry-buffer
(generate-new-buffer
- (format " *http %s:%d*" (url-host url) (url-port url))))))
+ (format " *http %s:%d*" (url-host url) (url-port url)))))
+ (referer (url-http--encode-string (url-http--get-referer url))))
(if (not connection)
;; Failed to open the connection for some reason
(progn
@@ -1293,7 +1329,8 @@ The return value of this function is the retrieval buffer."
url-http-no-retry
url-http-connection-opened
url-mime-accept-string
- url-http-proxy))
+ url-http-proxy
+ url-http-referer))
(set (make-local-variable var) nil))
(setq url-http-method (or url-request-method "GET")
@@ -1311,15 +1348,16 @@ The return value of this function is the retrieval buffer."
url-http-no-retry retry-buffer
url-http-connection-opened nil
url-mime-accept-string mime-accept-string
- url-http-proxy url-using-proxy)
+ url-http-proxy url-using-proxy
+ url-http-referer referer)
(set-process-buffer connection buffer)
(set-process-filter connection 'url-http-generic-filter)
(pcase (process-status connection)
- (`connect
+ ('connect
;; Asynchronous connection
(set-process-sentinel connection 'url-http-async-sentinel))
- (`failed
+ ('failed
;; Asynchronous connection failed
(error "Could not create connection to %s:%d" (url-host url)
(url-port url)))
@@ -1375,7 +1413,9 @@ The return value of this function is the retrieval buffer."
'url-http-wait-for-headers-change-function)
(set-process-filter tls-connection 'url-http-generic-filter)
(process-send-string tls-connection
- (url-http-create-request)))
+ ;; Use the non-proxy form of the request
+ (let (url-http-proxy)
+ (url-http-create-request))))
(gnutls-error
(url-http-activate-callback)
(error "gnutls-error: %s" e))
@@ -1563,7 +1603,6 @@ p3p
;; HTTPS. This used to be in url-https.el, but that file collides
;; with url-http.el on systems with 8-character file names.
-(require 'tls)
(defconst url-https-asynchronous-p t "HTTPS retrievals are asynchronous.")
diff --git a/lisp/url/url-methods.el b/lisp/url/url-methods.el
index 456be7ed4f7..1c0c5af86ac 100644
--- a/lisp/url/url-methods.el
+++ b/lisp/url/url-methods.el
@@ -134,11 +134,11 @@ it has not already been loaded."
(type (cdr cell)))
(if symbol
(pcase type
- (`function
+ ('function
;; Store the symbol name of a function
(if (fboundp symbol)
(setq desc (plist-put desc (car cell) symbol))))
- (`variable
+ ('variable
;; Store the VALUE of a variable
(if (boundp symbol)
(setq desc (plist-put desc (car cell)
diff --git a/lisp/url/url-parse.el b/lisp/url/url-parse.el
index a15ec953f62..1f72f51d769 100644
--- a/lisp/url/url-parse.el
+++ b/lisp/url/url-parse.el
@@ -209,7 +209,7 @@ parses to
;; 3.3. Path
(skip-chars-forward "^?#")
;; 3.4. Query
- (when (looking-at "?")
+ (when (looking-at "\\?")
(skip-chars-forward "^#"))
(setq file (buffer-substring save-pos (point)))
;; 3.5 Fragment
diff --git a/lisp/url/url-privacy.el b/lisp/url/url-privacy.el
index 994ae6ac5da..ef9ff84d56e 100644
--- a/lisp/url/url-privacy.el
+++ b/lisp/url/url-privacy.el
@@ -45,9 +45,9 @@
((memq (url-device-type) '(win32 w32)) "Windows; 32bit")
(t
(pcase (url-device-type)
- (`x "X11")
- (`ns "OpenStep")
- (`tty "TTY")
+ ('x "X11")
+ ('ns "OpenStep")
+ ('tty "TTY")
(_ nil)))))
(setq url-personal-mail-address (or url-personal-mail-address
diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el
index 38137b85e40..9bf1bca238d 100644
--- a/lisp/url/url-queue.el
+++ b/lisp/url/url-queue.el
@@ -52,7 +52,7 @@
(cl-defstruct url-queue
url callback cbargs silentp
buffer start-time pre-triggered
- inhibit-cookiesp)
+ inhibit-cookiesp context-buffer)
;;;###autoload
(defun url-queue-retrieve (url callback &optional cbargs silent inhibit-cookies)
@@ -67,7 +67,8 @@ The variable `url-queue-timeout' sets a timeout."
:callback callback
:cbargs cbargs
:silentp silent
- :inhibit-cookiesp inhibit-cookies))))
+ :inhibit-cookiesp inhibit-cookies
+ :context-buffer (current-buffer)))))
(url-queue-setup-runners))
;; To ensure asynch behavior, we start the required number of queue
@@ -147,19 +148,22 @@ The variable `url-queue-timeout' sets a timeout."
(defun url-queue-start-retrieve (job)
(setf (url-queue-buffer job)
(ignore-errors
- (let ((url-request-noninteractive t))
- (url-retrieve (url-queue-url job)
- #'url-queue-callback-function (list job)
- (url-queue-silentp job)
- (url-queue-inhibit-cookiesp job))))))
+ (with-current-buffer (if (buffer-live-p (url-queue-context-buffer job))
+ (url-queue-context-buffer job)
+ (current-buffer))
+ (let ((url-request-noninteractive t))
+ (url-retrieve (url-queue-url job)
+ #'url-queue-callback-function (list job)
+ (url-queue-silentp job)
+ (url-queue-inhibit-cookiesp job)))))))
(defun url-queue-prune-old-entries ()
(let (dead-jobs)
(dolist (job url-queue)
;; Kill jobs that have lasted longer than the timeout.
(when (and (url-queue-start-time job)
- (> (- (float-time) (url-queue-start-time job))
- url-queue-timeout))
+ (time-less-p url-queue-timeout
+ (time-since (url-queue-start-time job))))
(push job dead-jobs)))
(dolist (job dead-jobs)
(url-queue-kill-job job)
diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el
index 95e808f764d..72ff4f171cd 100644
--- a/lisp/url/url-util.el
+++ b/lisp/url/url-util.el
@@ -61,7 +61,7 @@ If a list, it is a list of the types of messages to be logged."
;;;###autoload
(defun url-debug (tag &rest args)
- (if quit-flag
+ (if (eq quit-flag t)
(error "Interrupted!"))
(if (or (eq url-debug t)
(numberp url-debug)
@@ -183,7 +183,7 @@ Will not do anything if `url-show-status' is nil."
(null url-show-status)
(active-minibuffer-window)
(= url-lazy-message-time
- (setq url-lazy-message-time (nth 1 (current-time)))))
+ (setq url-lazy-message-time (encode-time nil 'integer))))
nil
(apply 'message args)))
@@ -503,7 +503,7 @@ WIDTH defaults to the current frame width."
(urlobj nil))
;; The first thing that can go are the search strings
(if (and (>= str-width fr-width)
- (string-match "?" url))
+ (string-match "\\?" url))
(setq url (concat (substring url 0 (match-beginning 0)) "?...")
str-width (length url)))
(if (< str-width fr-width)
@@ -628,6 +628,34 @@ Creates FILE and its parent directories if they do not exist."
(error "Danger: `%s' is a symbolic link" file))
(set-file-modes file #o0600))))
+(autoload 'puny-encode-domain "puny")
+(autoload 'url-domsuf-cookie-allowed-p "url-domsuf")
+
+;;;###autoload
+(defun url-domain (url)
+ "Return the domain of the host of the URL.
+Return nil if this can't be determined.
+
+For instance, this function will return \"fsf.co.uk\" if the host in URL
+is \"www.fsf.co.uk\"."
+ (let* ((host (puny-encode-domain (url-host url)))
+ (parts (nreverse (split-string host "\\.")))
+ (candidate (pop parts))
+ found)
+ ;; IP addresses aren't domains.
+ (when (string-match "\\`[0-9.]+\\'" host)
+ (setq parts nil))
+ ;; We assume that the top-level domain is never an appropriate
+ ;; thing as "the domain", so we start at the next one (eg.
+ ;; "fsf.org").
+ (while (and parts
+ (not (setq found
+ (url-domsuf-cookie-allowed-p
+ (setq candidate (concat (pop parts) "."
+ candidate))))))
+ )
+ (and found candidate)))
+
(provide 'url-util)
;;; url-util.el ends here
diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el
index a5d80ff1518..ae1d6e54391 100644
--- a/lisp/url/url-vars.el
+++ b/lisp/url/url-vars.el
@@ -60,10 +60,18 @@
(defvar url-current-mime-headers nil
"A parsed representation of the MIME headers for the current URL.")
+(defvar url-current-lastloc nil
+ "A parsed representation of the URL to be considered as the last location.
+Use of this value on outbound connections is subject to
+`url-privacy-level' and `url-lastloc-privacy-level'. This is never set
+by the url library, applications are expected to set this
+variable in buffers representing a displayed location.")
+
(mapc 'make-variable-buffer-local
'(
url-current-object
url-current-mime-headers
+ url-current-lastloc
))
(defcustom url-honor-refresh-requests t
@@ -117,7 +125,7 @@ Valid symbols are:
email -- the email address
os -- the operating system info
emacs -- the version of Emacs
-lastloc -- the last location
+lastloc -- the last location (see also `url-lastloc-privacy-level')
agent -- do not send the User-Agent string
cookies -- never accept HTTP cookies
@@ -150,6 +158,24 @@ variable."
(const :tag "No cookies" :value cookie)))
:group 'url)
+(defcustom url-lastloc-privacy-level 'domain-match
+ "Further restrictions on sending the last location.
+This value is only consulted if `url-privacy-level' permits
+sending last location in the first place.
+
+Valid values are:
+none -- Always send last location.
+domain-match -- Send last location if the new location is within the
+ same domain
+host-match -- Send last location if the new location is on the
+ same host
+"
+ :version "27.1"
+ :type '(radio (const :tag "Always send" none)
+ (const :tag "Domains match" domain-match)
+ (const :tag "Hosts match" host-match))
+ :group 'url)
+
(defvar url-inhibit-uncompression nil "Do not do decompression if non-nil.")
(defcustom url-uncompressor-alist '((".z" . "x-gzip")
diff --git a/lisp/url/url.el b/lisp/url/url.el
index fbf31d420cb..ed0947795b0 100644
--- a/lisp/url/url.el
+++ b/lisp/url/url.el
@@ -259,9 +259,7 @@ how long to wait for a response before giving up."
;; process output.
(while (and (not retrieval-done)
(or (not timeout)
- (< (float-time (time-subtract
- (current-time) start-time))
- timeout)))
+ (time-less-p (time-since start-time) timeout)))
(url-debug 'retrieval
"Spinning in url-retrieve-synchronously: %S (%S)"
retrieval-done asynch-buffer)
diff --git a/lisp/userlock.el b/lisp/userlock.el
index ec5215badb5..f077bc9ad62 100644
--- a/lisp/userlock.el
+++ b/lisp/userlock.el
@@ -32,6 +32,8 @@
;;; Code:
+(eval-when-compile (require 'cl-lib))
+
(define-error 'file-locked "File is locked" 'file-error)
;;;###autoload
@@ -172,7 +174,9 @@ really edit the buffer? (y, n, r or C-h) "
(defun ask-user-about-supersession-help ()
(with-output-to-temp-buffer "*Help*"
- (princ "You want to modify a buffer whose disk file has changed
+ (princ
+ (substitute-command-keys
+ "You want to modify a buffer whose disk file has changed
since you last read it in or saved it with this buffer.
If you say `y' to go ahead and modify this buffer,
@@ -182,7 +186,7 @@ from the file on disk.
If you say `n', the change you started to make will be aborted.
Usually, you should type `n' and then `\\[revert-buffer]',
-to get the latest version of the file, then make the change again.")
+to get the latest version of the file, then make the change again."))
(with-current-buffer standard-output
(help-mode))))
diff --git a/lisp/vc/add-log.el b/lisp/vc/add-log.el
index 5350176e00e..f9efd44c5c7 100644
--- a/lisp/vc/add-log.el
+++ b/lisp/vc/add-log.el
@@ -239,7 +239,7 @@ a case simply use the directory containing the changed file."
;; wrongly with a non-date line existing as a random note. In
;; addition, using any kind of fixed setting like this doesn't
;; work if a user customizes add-log-time-format.
- ("^[0-9-]+ +\\|^ \\{11,\\}\\|^\t \\{3,\\}\\|^\\(Sun\\|Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\) [A-z][a-z][a-z] [0-9:+ ]+"
+ ("^[0-9-]+ +\\|^ \\{11,\\}\\|^\t \\{3,\\}\\|^\\(Sun\\|Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\) [A-Z][a-z][a-z] [0-9:+ ]+"
(0 'change-log-date)
;; Name and e-mail; some people put e-mail in parens, not angles.
("\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]" nil nil
@@ -471,6 +471,11 @@ A change log tag is a symbol within a parenthesized,
comma-separated list. If no suitable tag can be found nearby,
try to visit the file for the change under `point' instead."
(interactive)
+ (let ((buffer (current-buffer)))
+ (change-log-goto-source-internal)
+ (next-error-found buffer (current-buffer))))
+
+(defun change-log-goto-source-internal ()
(if (and (eq last-command 'change-log-goto-source)
change-log-find-tail)
(setq change-log-find-tail
@@ -539,7 +544,7 @@ Compatibility function for \\[next-error] invocations."
;; if we found a place to visit...
(when (looking-at change-log-file-names-re)
(let (change-log-find-window)
- (change-log-goto-source)
+ (change-log-goto-source-internal)
(when change-log-find-window
;; Select window displaying source file.
(select-window change-log-find-window)))))
@@ -739,6 +744,7 @@ Optional arg BUFFER-FILE overrides `buffer-file-name'."
file-name)
(defun add-log-file-name (buffer-file log-file)
+ "Compute file-name of BUFFER-FILE to be used in entries in LOG-FILE."
;; Never want to add a change log entry for the ChangeLog file itself.
(unless (or (null buffer-file) (string= buffer-file log-file))
(if add-log-file-name-function
@@ -762,15 +768,57 @@ Optional arg BUFFER-FILE overrides `buffer-file-name'."
(file-name-sans-versions buffer-file)
buffer-file))))
+(defcustom add-log-dont-create-changelog-file t
+ "If non-nil, don't create ChangeLog files for log entries.
+If a ChangeLog file does not already exist, a non-nil value
+means to put log entries in a suitably named buffer."
+ :type :boolean
+ :version "27.1")
+
+(put 'add-log-dont-create-changelog-file 'safe-local-variable 'booleanp)
+
+(defun add-log--pseudo-changelog-buffer-name (changelog-file-name)
+ "Compute a suitable name for a non-file visiting ChangeLog buffer.
+CHANGELOG-FILE-NAME is the file name of the actual ChangeLog file
+if it were to exist."
+ (format "*changes to %s*"
+ (abbreviate-file-name
+ (file-name-directory changelog-file-name))))
+
+(defun add-log--changelog-buffer-p (changelog-file-name buffer)
+ "Return non-nil if BUFFER holds a change log for CHANGELOG-FILE-NAME."
+ (with-current-buffer buffer
+ (if buffer-file-name
+ (equal buffer-file-name changelog-file-name)
+ (equal (add-log--pseudo-changelog-buffer-name changelog-file-name)
+ (buffer-name)))))
+
+(defun add-log-find-changelog-buffer (changelog-file-name)
+ "Find a ChangeLog buffer for CHANGELOG-FILE-NAME.
+Respect `add-log-use-pseudo-changelog', which see."
+ (if (or (file-exists-p changelog-file-name)
+ (not add-log-dont-create-changelog-file))
+ (find-file-noselect changelog-file-name)
+ (get-buffer-create
+ (add-log--pseudo-changelog-buffer-name changelog-file-name))))
+
;;;###autoload
-(defun add-change-log-entry (&optional whoami file-name other-window new-entry
+(defun add-change-log-entry (&optional whoami
+ changelog-file-name
+ other-window new-entry
put-new-entry-on-new-line)
- "Find change log file, and add an entry for today and an item for this file.
-Optional arg WHOAMI (interactive prefix) non-nil means prompt for user
-name and email (stored in `add-log-full-name' and `add-log-mailing-address').
-
-Second arg FILE-NAME is file name of the change log.
-If nil, use the value of `change-log-default-name'.
+ "Find ChangeLog buffer, add an entry for today and an item for this file.
+Optional arg WHOAMI (interactive prefix) non-nil means prompt for
+user name and email (stored in `add-log-full-name'
+and `add-log-mailing-address').
+
+Second arg CHANGELOG-FILE-NAME is the file name of the change log.
+If nil, use the value of `change-log-default-name'. If the file
+thus named exists, it is used for the new entry. If it doesn't
+exist, it is created, unless `add-log-dont-create-changelog-file' is t,
+in which case a suitably named buffer that doesn't visit any file
+is used for keeping entries pertaining to CHANGELOG-FILE-NAME's
+directory.
Third arg OTHER-WINDOW non-nil means visit in other window.
@@ -799,20 +847,28 @@ non-nil, otherwise in local time."
(change-log-version-number-search)))
(buf-file-name (funcall add-log-buffer-file-name-function))
(buffer-file (if buf-file-name (expand-file-name buf-file-name)))
- (file-name (expand-file-name (find-change-log file-name buffer-file)))
+ (changelog-file-name (expand-file-name (find-change-log
+ changelog-file-name
+ buffer-file)))
;; Set ITEM to the file name to use in the new item.
- (item (add-log-file-name buffer-file file-name)))
+ (item (add-log-file-name buffer-file changelog-file-name)))
- (unless (equal file-name buffer-file-name)
+ ;; don't add entries from the ChangeLog file/buffer to itself.
+ (unless (equal changelog-file-name buffer-file-name)
(cond
- ((equal file-name (buffer-file-name (window-buffer)))
+ ((add-log--changelog-buffer-p
+ changelog-file-name
+ (window-buffer))
;; If the selected window already shows the desired buffer don't show
;; it again (particularly important if other-window is true).
;; This is important for diff-add-change-log-entries-other-window.
(set-buffer (window-buffer)))
((or other-window (window-dedicated-p))
- (find-file-other-window file-name))
- (t (find-file file-name))))
+ (switch-to-buffer-other-window
+ (add-log-find-changelog-buffer changelog-file-name)))
+ (t
+ (switch-to-buffer
+ (add-log-find-changelog-buffer changelog-file-name)))))
(or (derived-mode-p 'change-log-mode)
(change-log-mode))
(undo-boundary)
@@ -1019,6 +1075,13 @@ the change log file in another window."
(defvar smerge-resolve-function)
(defvar copyright-at-end-flag)
+(defvar change-log-mode-syntax-table
+ (let ((table (make-syntax-table)))
+ (modify-syntax-entry ?` "' " table)
+ (modify-syntax-entry ?' "' " table)
+ table)
+ "Syntax table used while in `change-log-mode'.")
+
;;;###autoload
(define-derived-mode change-log-mode text-mode "Change Log"
"Major mode for editing change logs; like Indented Text mode.
@@ -1067,8 +1130,7 @@ Runs `change-log-mode-hook'.
(set (make-local-variable 'end-of-defun-function)
'change-log-end-of-defun)
;; next-error function glue
- (setq next-error-function 'change-log-next-error)
- (setq next-error-last-buffer (current-buffer)))
+ (setq next-error-function 'change-log-next-error))
(defun change-log-next-buffer (&optional buffer wrap)
"Return the next buffer in the series of ChangeLog file buffers.
@@ -1095,9 +1157,17 @@ file were isearch was started."
;; If there are no files that match the default pattern ChangeLog.[0-9],
;; return the current buffer to force isearch wrapping to its beginning.
;; If file is nil, multi-isearch-search-fun will signal "end of multi".
- (if (file-exists-p file)
- (find-file-noselect file)
- (current-buffer))))
+ (cond
+ ;; Wrapping doesn't catch errors from the nil arg of file-exists-p,
+ ;; so handle it explicitly.
+ ((and wrap (null file))
+ (current-buffer))
+ ;; When there is no next file, file-exists-p raises the error to be
+ ;; catched by the search function that displays the error message.
+ ((file-exists-p file)
+ (find-file-noselect file))
+ (t
+ (current-buffer)))))
(defun change-log-fill-forward-paragraph (n)
"Cut paragraphs so filling preserves open parentheses at beginning of lines."
diff --git a/lisp/vc/cvs-status.el b/lisp/vc/cvs-status.el
index 7fdff51607e..ccc8e5f4720 100644
--- a/lisp/vc/cvs-status.el
+++ b/lisp/vc/cvs-status.el
@@ -269,9 +269,9 @@ BEWARE: because of stability issues, this is not a symmetric operation."
(cond
((= l1 l2)
(pcase (cvs-tag-compare tag1 tag2)
- (`more1 (cons rev2 (cvs-tree-merge tree1 (cdr tree2))))
- (`more2 (cons rev1 (cvs-tree-merge (cdr tree1) tree2)))
- (`equal
+ ('more1 (cons rev2 (cvs-tree-merge tree1 (cdr tree2))))
+ ('more2 (cons rev1 (cvs-tree-merge (cdr tree1) tree2)))
+ ('equal
(cons (cons (cvs-tag-merge tag1 tag2)
(cvs-tree-merge (cvs-cdr rev1) (cvs-cdr rev2)))
(cvs-tree-merge (cdr tree1) (cdr tree2))))))
@@ -395,33 +395,33 @@ Otherwise, default to ASCII chars like +, - and |.")
(defconst cvs-tree-char-space
(pcase cvs-tree-use-charset
- (`jisx0208 (make-char 'japanese-jisx0208 33 33))
- (`unicode " ")
+ ('jisx0208 (make-char 'japanese-jisx0208 33 33))
+ ('unicode " ")
(_ " ")))
(defconst cvs-tree-char-hbar
(pcase cvs-tree-use-charset
- (`jisx0208 (make-char 'japanese-jisx0208 40 44))
- (`unicode "━")
+ ('jisx0208 (make-char 'japanese-jisx0208 40 44))
+ ('unicode "━")
(_ "--")))
(defconst cvs-tree-char-vbar
(pcase cvs-tree-use-charset
- (`jisx0208 (make-char 'japanese-jisx0208 40 45))
- (`unicode "┃")
+ ('jisx0208 (make-char 'japanese-jisx0208 40 45))
+ ('unicode "┃")
(_ "| ")))
(defconst cvs-tree-char-branch
(pcase cvs-tree-use-charset
- (`jisx0208 (make-char 'japanese-jisx0208 40 50))
- (`unicode "┣")
+ ('jisx0208 (make-char 'japanese-jisx0208 40 50))
+ ('unicode "┣")
(_ "+-")))
(defconst cvs-tree-char-eob ;end of branch
(pcase cvs-tree-use-charset
- (`jisx0208 (make-char 'japanese-jisx0208 40 49))
- (`unicode "┗")
+ ('jisx0208 (make-char 'japanese-jisx0208 40 49))
+ ('unicode "┗")
(_ "`-")))
(defconst cvs-tree-char-bob ;beginning of branch
(pcase cvs-tree-use-charset
- (`jisx0208 (make-char 'japanese-jisx0208 40 51))
- (`unicode "┳")
+ ('jisx0208 (make-char 'japanese-jisx0208 40 51))
+ ('unicode "┳")
(_ "+-")))
(defun cvs-tag-lessp (tag1 tag2)
diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el
index d8d35d6682e..1d5a2cf69ab 100644
--- a/lisp/vc/diff-mode.el
+++ b/lisp/vc/diff-mode.el
@@ -55,6 +55,9 @@
;;; Code:
(eval-when-compile (require 'cl-lib))
+(autoload 'vc-find-revision "vc")
+(autoload 'vc-find-revision-no-save "vc")
+(defvar vc-find-revision-no-save)
(defvar add-log-buffer-file-name-function)
@@ -66,14 +69,12 @@
(defcustom diff-default-read-only nil
"If non-nil, `diff-mode' buffers default to being read-only."
- :type 'boolean
- :group 'diff-mode)
+ :type 'boolean)
(defcustom diff-jump-to-old-file nil
"Non-nil means `diff-goto-source' jumps to the old file.
Else, it jumps to the new file."
- :type 'boolean
- :group 'diff-mode)
+ :type 'boolean)
(defcustom diff-update-on-the-fly t
"Non-nil means hunk headers are kept up-to-date on-the-fly.
@@ -82,23 +83,70 @@ need to be kept consistent with the actual diff. This can
either be done on the fly (but this sometimes interacts poorly with the
undo mechanism) or whenever the file is written (can be slow
when editing big diffs)."
- :type 'boolean
- :group 'diff-mode)
+ :type 'boolean)
(defcustom diff-advance-after-apply-hunk t
"Non-nil means `diff-apply-hunk' will move to the next hunk after applying."
- :type 'boolean
- :group 'diff-mode)
+ :type 'boolean)
(defcustom diff-mode-hook nil
"Run after setting up the `diff-mode' major mode."
:type 'hook
- :options '(diff-delete-empty-files diff-make-unified)
- :group 'diff-mode)
+ :options '(diff-delete-empty-files diff-make-unified))
+
+(defcustom diff-refine 'font-lock
+ "If non-nil, enable hunk refinement.
+
+The value `font-lock' means to refine during font-lock.
+The value `navigation' means to refine each hunk as you visit it
+with `diff-hunk-next' or `diff-hunk-prev'.
+
+You can always manually refine a hunk with `diff-refine-hunk'."
+ :version "27.1"
+ :type '(choice (const :tag "Don't refine hunks" nil)
+ (const :tag "Refine hunks during font-lock" font-lock)
+ (const :tag "Refine hunks during navigation" navigation)))
+
+(defcustom diff-font-lock-prettify nil
+ "If non-nil, font-lock will try and make the format prettier."
+ :version "27.1"
+ :type 'boolean)
+
+(defcustom diff-font-lock-syntax t
+ "If non-nil, diff hunk font-lock includes source language syntax highlighting.
+This highlighting is the same as added by `font-lock-mode'
+when corresponding source files are visited normally.
+Syntax highlighting is added over diff-mode's own highlighted changes.
+
+If t, the default, highlight syntax only in Diff buffers created by Diff
+commands that compare files or by VC commands that compare revisions.
+These provide all necessary context for reliable highlighting. This value
+requires support from a VC backend to find the files being compared.
+For diffs against the working-tree version of a file, the highlighting is
+based on the current file contents. File-based fontification tries to
+infer fontification from the compared files.
+
+If `hunk-only' fontification is based on hunk alone, without full source.
+It tries to highlight hunks without enough context that sometimes might result
+in wrong fontification. This is the fastest option, but less reliable.
+
+If `hunk-also', use reliable file-based syntax highlighting when available
+and hunk-based syntax highlighting otherwise as a fallback."
+ :version "27.1"
+ :type '(choice (const :tag "Don't highlight syntax" nil)
+ (const :tag "Hunk-based only" hunk-only)
+ (const :tag "Highlight syntax" t)
+ (const :tag "Allow hunk-based fallback" hunk-also)))
(defvar diff-vc-backend nil
"The VC backend that created the current Diff buffer, if any.")
+(defvar diff-vc-revisions nil
+ "The VC revisions compared in the current Diff buffer, if any.")
+
+(defvar-local diff-default-directory nil
+ "The default directory where the current Diff buffer was created.")
+
(defvar diff-outline-regexp
"\\([*+][*+][*+] [^0-9]\\|@@ ...\\|\\*\\*\\* [0-9].\\|--- [0-9]..\\)")
@@ -207,27 +255,29 @@ when editing big diffs)."
(defcustom diff-minor-mode-prefix "\C-c="
"Prefix key for `diff-minor-mode' commands."
- :type '(choice (string "\e") (string "C-c=") string)
- :group 'diff-mode)
+ :type '(choice (string "\e") (string "C-c=") string))
(easy-mmode-defmap diff-minor-mode-map
`((,diff-minor-mode-prefix . ,diff-mode-shared-map))
"Keymap for `diff-minor-mode'. See also `diff-mode-shared-map'.")
(define-minor-mode diff-auto-refine-mode
- "Toggle automatic diff hunk highlighting (Diff Auto Refine mode).
-With a prefix argument ARG, enable Diff Auto Refine mode if ARG
-is positive, and disable it otherwise. If called from Lisp,
-enable the mode if ARG is omitted or nil.
+ "Toggle automatic diff hunk finer highlighting (Diff Auto Refine mode).
Diff Auto Refine mode is a buffer-local minor mode used with
`diff-mode'. When enabled, Emacs automatically highlights
changes in detail as the user visits hunks. When transitioning
from disabled to enabled, it tries to refine the current hunk, as
well."
- :group 'diff-mode :init-value t :lighter nil ;; " Auto-Refine"
- (when diff-auto-refine-mode
- (condition-case-unless-debug nil (diff-refine-hunk) (error nil))))
+ :group 'diff-mode :init-value nil :lighter nil ;; " Auto-Refine"
+ (if diff-auto-refine-mode
+ (progn
+ (customize-set-variable 'diff-refine 'navigation)
+ (condition-case-unless-debug nil (diff-refine-hunk) (error nil)))
+ (customize-set-variable 'diff-refine nil)))
+(make-obsolete 'diff-auto-refine-mode "set `diff-refine' instead." "27.1")
+(make-obsolete-variable 'diff-auto-refine-mode
+ "set `diff-refine' instead." "27.1")
;;;;
;;;; font-lock support
@@ -235,105 +285,95 @@ well."
(defface diff-header
'((((class color) (min-colors 88) (background light))
- :background "grey80")
+ :background "grey85")
(((class color) (min-colors 88) (background dark))
:background "grey45")
(((class color))
:foreground "blue1" :weight bold)
(t :weight bold))
- "`diff-mode' face inherited by hunk and index header faces."
- :group 'diff-mode)
+ "`diff-mode' face inherited by hunk and index header faces.")
(defface diff-file-header
'((((class color) (min-colors 88) (background light))
- :background "grey70" :weight bold)
+ :background "grey75" :weight bold)
(((class color) (min-colors 88) (background dark))
:background "grey60" :weight bold)
(((class color))
:foreground "cyan" :weight bold)
(t :weight bold)) ; :height 1.3
- "`diff-mode' face used to highlight file header lines."
- :group 'diff-mode)
+ "`diff-mode' face used to highlight file header lines.")
(defface diff-index
'((t :inherit diff-file-header))
- "`diff-mode' face used to highlight index header lines."
- :group 'diff-mode)
+ "`diff-mode' face used to highlight index header lines.")
(defface diff-hunk-header
'((t :inherit diff-header))
- "`diff-mode' face used to highlight hunk header lines."
- :group 'diff-mode)
+ "`diff-mode' face used to highlight hunk header lines.")
(defface diff-removed
'((default
:inherit diff-changed)
(((class color) (min-colors 88) (background light))
- :background "#ffdddd")
+ :background "#ffeeee")
(((class color) (min-colors 88) (background dark))
:background "#553333")
(((class color))
:foreground "red"))
- "`diff-mode' face used to highlight removed lines."
- :group 'diff-mode)
+ "`diff-mode' face used to highlight removed lines.")
(defface diff-added
'((default
:inherit diff-changed)
(((class color) (min-colors 88) (background light))
- :background "#ddffdd")
+ :background "#eeffee")
(((class color) (min-colors 88) (background dark))
:background "#335533")
(((class color))
:foreground "green"))
- "`diff-mode' face used to highlight added lines."
- :group 'diff-mode)
+ "`diff-mode' face used to highlight added lines.")
(defface diff-changed
'((t nil))
"`diff-mode' face used to highlight changed lines."
- :version "25.1"
- :group 'diff-mode)
+ :version "25.1")
(defface diff-indicator-removed
- '((t :inherit diff-removed))
+ '((default :inherit diff-removed)
+ (((class color) (min-colors 88))
+ :foreground "#aa2222"))
"`diff-mode' face used to highlight indicator of removed lines (-, <)."
- :group 'diff-mode
:version "22.1")
(defvar diff-indicator-removed-face 'diff-indicator-removed)
(defface diff-indicator-added
- '((t :inherit diff-added))
+ '((default :inherit diff-added)
+ (((class color) (min-colors 88))
+ :foreground "#22aa22"))
"`diff-mode' face used to highlight indicator of added lines (+, >)."
- :group 'diff-mode
:version "22.1")
(defvar diff-indicator-added-face 'diff-indicator-added)
(defface diff-indicator-changed
- '((t :inherit diff-changed))
+ '((default :inherit diff-changed)
+ (((class color) (min-colors 88))
+ :foreground "#aaaa22"))
"`diff-mode' face used to highlight indicator of changed lines."
- :group 'diff-mode
:version "22.1")
(defvar diff-indicator-changed-face 'diff-indicator-changed)
(defface diff-function
'((t :inherit diff-header))
- "`diff-mode' face used to highlight function names produced by \"diff -p\"."
- :group 'diff-mode)
+ "`diff-mode' face used to highlight function names produced by \"diff -p\".")
(defface diff-context
- '((((class color grayscale) (min-colors 88) (background light))
- :foreground "#333333")
- (((class color grayscale) (min-colors 88) (background dark))
- :foreground "#dddddd"))
+ '((t nil))
"`diff-mode' face used to highlight context and other side-information."
- :version "25.1"
- :group 'diff-mode)
+ :version "25.1")
(defface diff-nonexistent
'((t :inherit diff-file-header))
- "`diff-mode' face used to highlight nonexistent files in recursive diffs."
- :group 'diff-mode)
+ "`diff-mode' face used to highlight nonexistent files in recursive diffs.")
(defconst diff-yank-handler '(diff-yank-function))
(defun diff-yank-function (text)
@@ -408,11 +448,17 @@ and the face `diff-added' for added lines.")
'diff-removed))))))
("^\\(?:Index\\|revno\\): \\(.+\\).*\n"
(0 'diff-header) (1 'diff-index prepend))
+ ("^\\(?:index .*\\.\\.\\|diff \\).*\n" . 'diff-header)
+ ("^\\(?:new\\|deleted\\) file mode .*\n" . 'diff-header)
("^Only in .*\n" . 'diff-nonexistent)
+ ("^Binary files .* differ\n" . 'diff-file-header)
("^\\(#\\)\\(.*\\)"
(1 font-lock-comment-delimiter-face)
(2 font-lock-comment-face))
- ("^[^-=+*!<>#].*\n" (0 'diff-context))))
+ ("^[^-=+*!<>#].*\n" (0 'diff-context))
+ (,#'diff--font-lock-syntax)
+ (,#'diff--font-lock-prettify)
+ (,#'diff--font-lock-refined)))
(defconst diff-font-lock-defaults
'(diff-font-lock-keywords t nil nil nil (font-lock-multiline . nil)))
@@ -481,13 +527,14 @@ See https://lists.gnu.org/r/emacs-devel/2007-11/msg01990.html")
(unless end
(setq end (and (re-search-forward
(pcase style
- (`unified
+ ('unified
(concat (if diff-valid-unified-empty-line
"^[^-+# \\\n]\\|" "^[^-+# \\]\\|")
;; A `unified' header is ambiguous.
diff-file-header-re))
- (`context "^[^-+#! \\]")
- (`normal "^[^<>#\\]")
+ ('context (if diff-valid-unified-empty-line
+ "^[^-+#! \n\\]" "^[^-+#! \\]"))
+ ('normal "^[^<>#\\]")
(_ "^[^-+#!<> \\]"))
nil t)
(match-beginning 0)))
@@ -590,7 +637,7 @@ next hunk if TRY-HARDER is non-nil; otherwise signal an error."
;; Define diff-{hunk,file}-{prev,next}
(easy-mmode-define-navigation
diff-hunk diff-hunk-header-re "hunk" diff-end-of-hunk diff-restrict-view
- (when diff-auto-refine-mode
+ (when (and (eq diff-refine 'navigation) (called-interactively-p 'interactive))
(unless (prog1 diff--auto-refine-data
(setq diff--auto-refine-data
(cons (current-buffer) (point-marker))))
@@ -891,7 +938,7 @@ PREFIX is only used internally: don't use it."
(if (and newfile (file-exists-p newfile)) (cl-return newfile))))
;; look for each file in turn. If none found, try again but
;; ignoring the first level of directory, ...
- (cl-do* ((files fs (delq nil (mapcar 'diff-filename-drop-dir files)))
+ (cl-do* ((files fs (delq nil (mapcar #'diff-filename-drop-dir files)))
(file nil nil))
((or (null files)
(setq file (cl-do* ((files files (cdr files))
@@ -1018,7 +1065,7 @@ else cover the whole buffer."
" ----\n" hunk))
;;(goto-char (point-min))
(forward-line 1)
- (if (not (save-excursion (re-search-forward "^+" nil t)))
+ (if (not (save-excursion (re-search-forward "^\\+" nil t)))
(delete-region (point) (point-max))
(let ((modif nil) (delete nil))
(if (save-excursion (re-search-forward "^\\+.*\n-"
@@ -1351,6 +1398,14 @@ See `after-change-functions' for the meaning of BEG, END and LEN."
(diff-hunk-next arg)
(diff-goto-source))
+(defun diff--font-lock-cleanup ()
+ (remove-overlays nil nil 'diff-mode 'fine)
+ (remove-overlays nil nil 'diff-mode 'syntax)
+ (when font-lock-mode
+ (make-local-variable 'font-lock-extra-managed-props)
+ ;; Added when diff--font-lock-prettify is non-nil!
+ (cl-pushnew 'display font-lock-extra-managed-props)))
+
(defvar whitespace-style)
(defvar whitespace-trailing-regexp)
@@ -1368,12 +1423,10 @@ You can also switch between context diff and unified diff with \\[diff-context->
or vice versa with \\[diff-unified->context] and you can also reverse the direction of
a diff with \\[diff-reverse-direction].
- \\{diff-mode-map}"
+\\{diff-mode-map}"
(set (make-local-variable 'font-lock-defaults) diff-font-lock-defaults)
- (add-hook 'font-lock-mode-hook
- (lambda () (remove-overlays nil nil 'diff-mode 'fine))
- nil 'local)
+ (add-hook 'font-lock-mode-hook #'diff--font-lock-cleanup nil 'local)
(set (make-local-variable 'outline-regexp) diff-outline-regexp)
(set (make-local-variable 'imenu-generic-expression)
diff-imenu-generic-expression)
@@ -1387,12 +1440,12 @@ a diff with \\[diff-reverse-direction].
;; (set (make-local-variable 'paragraph-separate) paragraph-start)
;; (set (make-local-variable 'page-delimiter) "--- [^\t]+\t")
;; compile support
- (set (make-local-variable 'next-error-function) 'diff-next-error)
+ (set (make-local-variable 'next-error-function) #'diff-next-error)
(set (make-local-variable 'beginning-of-defun-function)
- 'diff-beginning-of-file-and-junk)
+ #'diff-beginning-of-file-and-junk)
(set (make-local-variable 'end-of-defun-function)
- 'diff-end-of-file)
+ #'diff-end-of-file)
(diff-setup-whitespace)
@@ -1400,10 +1453,10 @@ a diff with \\[diff-reverse-direction].
(setq buffer-read-only t))
;; setup change hooks
(if (not diff-update-on-the-fly)
- (add-hook 'write-contents-functions 'diff-write-contents-hooks nil t)
+ (add-hook 'write-contents-functions #'diff-write-contents-hooks nil t)
(make-local-variable 'diff-unhandled-changes)
- (add-hook 'after-change-functions 'diff-after-change-function nil t)
- (add-hook 'post-command-hook 'diff-post-command-hook nil t))
+ (add-hook 'after-change-functions #'diff-after-change-function nil t)
+ (add-hook 'post-command-hook #'diff-post-command-hook nil t))
;; Neat trick from Dave Love to add more bindings in read-only mode:
(let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map)))
(add-to-list 'minor-mode-overriding-map-alist ro-bind)
@@ -1415,28 +1468,27 @@ a diff with \\[diff-reverse-direction].
nil t))
;; add-log support
(set (make-local-variable 'add-log-current-defun-function)
- 'diff-current-defun)
+ #'diff-current-defun)
(set (make-local-variable 'add-log-buffer-file-name-function)
(lambda () (diff-find-file-name nil 'noprompt)))
- (unless (buffer-file-name)
+ (add-function :filter-return (local 'filter-buffer-substring-function)
+ #'diff--filter-substring)
+ (unless buffer-file-name
(hack-dir-local-variables-non-file-buffer)))
;;;###autoload
(define-minor-mode diff-minor-mode
"Toggle Diff minor mode.
-With a prefix argument ARG, enable Diff minor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
\\{diff-minor-mode-map}"
:group 'diff-mode :lighter " Diff"
;; FIXME: setup font-lock
;; setup change hooks
(if (not diff-update-on-the-fly)
- (add-hook 'write-contents-functions 'diff-write-contents-hooks nil t)
+ (add-hook 'write-contents-functions #'diff-write-contents-hooks nil t)
(make-local-variable 'diff-unhandled-changes)
- (add-hook 'after-change-functions 'diff-after-change-function nil t)
- (add-hook 'post-command-hook 'diff-post-command-hook nil t)))
+ (add-hook 'after-change-functions #'diff-after-change-function nil t)
+ (add-hook 'post-command-hook #'diff-post-command-hook nil t)))
;;; Handy hook functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1463,12 +1515,12 @@ modified lines of the diff."
;; can just remove the file altogether. Very handy for .rej files if we
;; remove hunks as we apply them.
(when (and buffer-file-name
- (eq 0 (nth 7 (file-attributes buffer-file-name))))
+ (eq 0 (file-attribute-size (file-attributes buffer-file-name))))
(delete-file buffer-file-name)))
(defun diff-delete-empty-files ()
"Arrange for empty diff files to be removed."
- (add-hook 'after-save-hook 'diff-delete-if-empty nil t))
+ (add-hook 'after-save-hook #'diff-delete-if-empty nil t))
(defun diff-make-unified ()
"Turn context diffs into unified diffs if applicable."
@@ -1662,10 +1714,11 @@ char-offset in TEXT."
(delete-region divider-pos (point-max)))
(delete-region (point-min) keep))
;; Remove line-prefix characters, and unneeded lines (unified diffs).
- (let ((kill-char (if destp ?- ?+)))
+ ;; Also skip lines like "\ No newline at end of file"
+ (let ((kill-chars (list (if destp ?- ?+) ?\\)))
(goto-char (point-min))
(while (not (eobp))
- (if (eq (char-after) kill-char)
+ (if (memq (char-after) kill-chars)
(delete-region (point) (progn (forward-line 1) (point)))
(delete-char num-pfx-chars)
(forward-line 1)))))
@@ -1693,7 +1746,7 @@ If TEXT isn't found, nil is returned."
Whitespace differences are ignored."
(let* ((orig (point))
(re (concat "^[ \t\n ]*"
- (mapconcat 'regexp-quote (split-string text) "[ \t\n ]+")
+ (mapconcat #'regexp-quote (split-string text) "[ \t\n ]+")
"[ \t\n ]*\n"))
(forw (and (re-search-forward re nil t)
(cons (match-beginning 0) (match-end 0))))
@@ -1742,7 +1795,15 @@ NOPROMPT, if non-nil, means not to prompt the user."
(match-string 1)))))
(file (or (diff-find-file-name other noprompt)
(error "Can't find the file")))
- (buf (find-file-noselect file)))
+ (revision (and other diff-vc-backend
+ (if reverse (nth 1 diff-vc-revisions)
+ (or (nth 0 diff-vc-revisions)
+ ;; When diff shows changes in working revision
+ (vc-working-revision file)))))
+ (buf (if revision
+ (let ((vc-find-revision-no-save t))
+ (vc-find-revision (expand-file-name file) revision diff-vc-backend))
+ (find-file-noselect file))))
;; Update the user preference if he so wished.
(when (> (prefix-numeric-value other-file) 8)
(setq diff-jump-to-old-file other))
@@ -1868,18 +1929,24 @@ With a prefix argument, try to REVERSE the hunk."
`diff-jump-to-old-file' (or its opposite if the OTHER-FILE prefix arg
is given) determines whether to jump to the old or the new file.
If the prefix arg is bigger than 8 (for example with \\[universal-argument] \\[universal-argument])
-then `diff-jump-to-old-file' is also set, for the next invocations."
+then `diff-jump-to-old-file' is also set, for the next invocations.
+
+Under version control, the OTHER-FILE prefix arg means jump to the old
+revision of the file if point is on an old changed line, or to the new
+revision of the file otherwise."
(interactive (list current-prefix-arg last-input-event))
;; When pointing at a removal line, we probably want to jump to
;; the old location, and else to the new (i.e. as if reverting).
;; This is a convenient detail when using smerge-diff.
(if event (posn-set-point (event-end event)))
- (let ((rev (not (save-excursion (beginning-of-line) (looking-at "[-<]")))))
+ (let ((buffer (when event (current-buffer)))
+ (reverse (not (save-excursion (beginning-of-line) (looking-at "[-<]")))))
(pcase-let ((`(,buf ,line-offset ,pos ,src ,_dst ,switched)
- (diff-find-source-location other-file rev)))
+ (diff-find-source-location other-file reverse)))
(pop-to-buffer buf)
(goto-char (+ (car pos) (cdr src)))
- (diff-hunk-status-msg line-offset (diff-xor rev switched) t))))
+ (when buffer (next-error-found buffer (current-buffer)))
+ (diff-hunk-status-msg line-offset (diff-xor reverse switched) t))))
(defun diff-current-defun ()
@@ -1968,29 +2035,26 @@ For use in `add-log-current-defun-function'."
(((class color) (min-colors 88) (background dark))
:background "#aaaa22")
(t :inverse-video t))
- "Face used for char-based changes shown by `diff-refine-hunk'."
- :group 'diff-mode)
+ "Face used for char-based changes shown by `diff-refine-hunk'.")
(defface diff-refine-removed
'((default
:inherit diff-refine-changed)
(((class color) (min-colors 88) (background light))
- :background "#ffbbbb")
+ :background "#ffcccc")
(((class color) (min-colors 88) (background dark))
:background "#aa2222"))
"Face used for removed characters shown by `diff-refine-hunk'."
- :group 'diff-mode
:version "24.3")
(defface diff-refine-added
'((default
:inherit diff-refine-changed)
(((class color) (min-colors 88) (background light))
- :background "#aaffaa")
+ :background "#bbffbb")
(((class color) (min-colors 88) (background dark))
:background "#22aa22"))
"Face used for added characters shown by `diff-refine-hunk'."
- :group 'diff-mode
:version "24.3")
(defun diff-refine-preproc ()
@@ -2017,59 +2081,112 @@ Return new point, if it was moved."
(defun diff-refine-hunk ()
"Highlight changes of hunk at point at a finer granularity."
(interactive)
- (require 'smerge-mode)
(when (diff--some-hunks-p)
(save-excursion
- (diff-beginning-of-hunk t)
- (let* ((start (point))
- (style (diff-hunk-style)) ;Skips the hunk header as well.
- (beg (point))
- (props-c '((diff-mode . fine) (face diff-refine-changed)))
- (props-r '((diff-mode . fine) (face diff-refine-removed)))
- (props-a '((diff-mode . fine) (face diff-refine-added)))
- ;; Be careful to go back to `start' so diff-end-of-hunk gets
- ;; to read the hunk header's line info.
- (end (progn (goto-char start) (diff-end-of-hunk) (point))))
-
- (remove-overlays beg end 'diff-mode 'fine)
+ (let ((beg (diff-beginning-of-hunk t))
+ ;; Be careful to start from the hunk header so diff-end-of-hunk
+ ;; gets to read the hunk header's line info.
+ (end (progn (diff-end-of-hunk) (point))))
+ (diff--refine-hunk beg end)))))
+(defun diff--refine-hunk (start end)
+ (require 'smerge-mode)
+ (goto-char start)
+ (let* ((style (diff-hunk-style)) ;Skips the hunk header as well.
+ (beg (point))
+ (props-c '((diff-mode . fine) (face . diff-refine-changed)))
+ (props-r '((diff-mode . fine) (face . diff-refine-removed)))
+ (props-a '((diff-mode . fine) (face . diff-refine-added))))
+
+ (remove-overlays beg end 'diff-mode 'fine)
+
+ (goto-char beg)
+ (pcase style
+ ('unified
+ (while (re-search-forward "^-" end t)
+ (let ((beg-del (progn (beginning-of-line) (point)))
+ beg-add end-add)
+ (when (and (diff--forward-while-leading-char ?- end)
+ ;; Allow for "\ No newline at end of file".
+ (progn (diff--forward-while-leading-char ?\\ end)
+ (setq beg-add (point)))
+ (diff--forward-while-leading-char ?+ end)
+ (progn (diff--forward-while-leading-char ?\\ end)
+ (setq end-add (point))))
+ (smerge-refine-regions beg-del beg-add beg-add end-add
+ nil #'diff-refine-preproc props-r props-a)))))
+ ('context
+ (let* ((middle (save-excursion (re-search-forward "^---" end)))
+ (other middle))
+ (while (re-search-forward "^\\(?:!.*\n\\)+" middle t)
+ (smerge-refine-regions (match-beginning 0) (match-end 0)
+ (save-excursion
+ (goto-char other)
+ (re-search-forward "^\\(?:!.*\n\\)+" end)
+ (setq other (match-end 0))
+ (match-beginning 0))
+ other
+ (if diff-use-changed-face props-c)
+ #'diff-refine-preproc
+ (unless diff-use-changed-face props-r)
+ (unless diff-use-changed-face props-a)))))
+ (_ ;; Normal diffs.
+ (let ((beg1 (1+ (point))))
+ (when (re-search-forward "^---.*\n" end t)
+ ;; It's a combined add&remove, so there's something to do.
+ (smerge-refine-regions beg1 (match-beginning 0)
+ (match-end 0) end
+ nil #'diff-refine-preproc props-r props-a)))))))
+
+(defun diff--iterate-hunks (max fun)
+ "Iterate over all hunks between point and MAX.
+Call FUN with two args (BEG and END) for each hunk."
+ (save-excursion
+ (let* ((beg (or (ignore-errors (diff-beginning-of-hunk))
+ (ignore-errors (diff-hunk-next) (point))
+ max)))
+ (while (< beg max)
(goto-char beg)
- (pcase style
- (`unified
- (while (re-search-forward "^-" end t)
- (let ((beg-del (progn (beginning-of-line) (point)))
- beg-add end-add)
- (when (and (diff--forward-while-leading-char ?- end)
- ;; Allow for "\ No newline at end of file".
- (progn (diff--forward-while-leading-char ?\\ end)
- (setq beg-add (point)))
- (diff--forward-while-leading-char ?+ end)
- (progn (diff--forward-while-leading-char ?\\ end)
- (setq end-add (point))))
- (smerge-refine-regions beg-del beg-add beg-add end-add
- nil 'diff-refine-preproc props-r props-a)))))
- (`context
- (let* ((middle (save-excursion (re-search-forward "^---")))
- (other middle))
- (while (re-search-forward "^\\(?:!.*\n\\)+" middle t)
- (smerge-refine-regions (match-beginning 0) (match-end 0)
- (save-excursion
- (goto-char other)
- (re-search-forward "^\\(?:!.*\n\\)+" end)
- (setq other (match-end 0))
- (match-beginning 0))
- other
- (if diff-use-changed-face props-c)
- 'diff-refine-preproc
- (unless diff-use-changed-face props-r)
- (unless diff-use-changed-face props-a)))))
- (_ ;; Normal diffs.
- (let ((beg1 (1+ (point))))
- (when (re-search-forward "^---.*\n" end t)
- ;; It's a combined add&remove, so there's something to do.
- (smerge-refine-regions beg1 (match-beginning 0)
- (match-end 0) end
- nil 'diff-refine-preproc props-r props-a)))))))))
+ (cl-assert (looking-at diff-hunk-header-re))
+ (let ((end
+ (save-excursion (diff-end-of-hunk) (point))))
+ (cl-assert (< beg end))
+ (funcall fun beg end)
+ (goto-char end)
+ (setq beg (if (looking-at diff-hunk-header-re)
+ end
+ (or (ignore-errors (diff-hunk-next) (point))
+ max))))))))
+
+(defun diff--font-lock-refined (max)
+ "Apply hunk refinement from font-lock."
+ (when (eq diff-refine 'font-lock)
+ (when (get-char-property (point) 'diff--font-lock-refined)
+ ;; Refinement works over a complete hunk, whereas font-lock limits itself
+ ;; to highlighting smallish chunks between point..max, so we may be
+ ;; called N times for a large hunk in which case we don't want to
+ ;; rehighlight that hunk N times (especially since each highlighting
+ ;; of a large hunk can itself take a long time, adding insult to injury).
+ ;; So, after refining a hunk (including a failed attempt), we place an
+ ;; overlay over the whole hunk to mark it as refined, to avoid redoing
+ ;; the job redundantly when asked to highlight subsequent parts of the
+ ;; same hunk.
+ (goto-char (next-single-char-property-change
+ (point) 'diff--font-lock-refined nil max)))
+ (diff--iterate-hunks
+ max
+ (lambda (beg end)
+ (unless (get-char-property beg 'diff--font-lock-refined)
+ (diff--refine-hunk beg end)
+ (let ((ol (make-overlay beg end)))
+ (overlay-put ol 'diff--font-lock-refined t)
+ (overlay-put ol 'diff-mode 'fine)
+ (overlay-put ol 'evaporate t)
+ (overlay-put ol 'modification-hooks
+ '(diff--overlay-auto-delete))))))))
+
+(defun diff--overlay-auto-delete (ol _after _beg _end &optional _len)
+ (delete-overlay ol))
(defun diff-undo (&optional arg)
"Perform `undo', ignoring the buffer's read-only status."
@@ -2095,7 +2212,7 @@ I.e. like `add-change-log-entry-other-window' but applied to all hunks."
;; `add-change-log-entry-other-window' works better in
;; that case.
(re-search-forward
- (concat "\n[!+-<>]"
+ (concat "\n[!+<>-]"
;; If the hunk is a context hunk with an empty first
;; half, recognize the "--- NNN,MMM ----" line
"\\(-- [0-9]+\\(,[0-9]+\\)? ----\n"
@@ -2175,6 +2292,384 @@ fixed, visit it in a buffer."
modified-buffers ", "))
(message "No trailing whitespace to delete.")))))
+
+;;; Prettifying from font-lock
+
+(define-fringe-bitmap 'diff-fringe-add
+ [#b00000000
+ #b00000000
+ #b00010000
+ #b00010000
+ #b01111100
+ #b00010000
+ #b00010000
+ #b00000000
+ #b00000000]
+ nil nil 'center)
+
+(define-fringe-bitmap 'diff-fringe-del
+ [#b00000000
+ #b00000000
+ #b00000000
+ #b00000000
+ #b01111100
+ #b00000000
+ #b00000000
+ #b00000000
+ #b00000000]
+ nil nil 'center)
+
+(define-fringe-bitmap 'diff-fringe-rep
+ [#b00000000
+ #b00010000
+ #b00010000
+ #b00010000
+ #b00010000
+ #b00010000
+ #b00000000
+ #b00010000
+ #b00000000]
+ nil nil 'center)
+
+(define-fringe-bitmap 'diff-fringe-nul
+ ;; Maybe there should be such an "empty" bitmap defined by default?
+ [#b00000000
+ #b00000000
+ #b00000000
+ #b00000000
+ #b00000000
+ #b00000000
+ #b00000000
+ #b00000000
+ #b00000000]
+ nil nil 'center)
+
+(defun diff--font-lock-prettify (limit)
+ (when diff-font-lock-prettify
+ (save-excursion
+ ;; FIXME: Include the first space for context-style hunks!
+ (while (re-search-forward "^[-+! ]" limit t)
+ (let ((spec (alist-get (char-before)
+ '((?+ . (left-fringe diff-fringe-add diff-indicator-added))
+ (?- . (left-fringe diff-fringe-del diff-indicator-removed))
+ (?! . (left-fringe diff-fringe-rep diff-indicator-changed))
+ (?\s . (left-fringe diff-fringe-nul))))))
+ (put-text-property (match-beginning 0) (match-end 0) 'display spec))))
+ ;; Mimicks the output of Magit's diff.
+ ;; FIXME: This has only been tested with Git's diff output.
+ (while (re-search-forward "^diff " limit t)
+ ;; FIXME: Switching between context<->unified leads to messed up
+ ;; file headers by cutting the `display' property in chunks!
+ (when (save-excursion
+ (forward-line 0)
+ (looking-at
+ (eval-when-compile
+ (concat "diff.*\n"
+ "\\(?:\\(?:new file\\|deleted\\).*\n\\)?"
+ "\\(?:index.*\n\\)?"
+ "--- \\(?:/dev/null\\|a/\\(.*\\)\\)\n"
+ "\\+\\+\\+ \\(?:/dev/null\\|b/\\(.*\\)\\)\n"))))
+ (put-text-property (match-beginning 0)
+ (or (match-beginning 2) (match-beginning 1))
+ 'display (propertize
+ (cond
+ ((null (match-beginning 1)) "new file ")
+ ((null (match-beginning 2)) "deleted ")
+ (t "modified "))
+ 'face '(diff-file-header diff-header)))
+ (unless (match-beginning 2)
+ (put-text-property (match-end 1) (1- (match-end 0))
+ 'display "")))))
+ nil)
+
+;;; Syntax highlighting from font-lock
+
+(defun diff--font-lock-syntax (max)
+ "Apply source language syntax highlighting from font-lock.
+Calls `diff-syntax-fontify' on every hunk found between point
+and the position in MAX."
+ (when diff-font-lock-syntax
+ (when (get-char-property (point) 'diff--font-lock-syntax)
+ (goto-char (next-single-char-property-change
+ (point) 'diff--font-lock-syntax nil max)))
+ (diff--iterate-hunks
+ max
+ (lambda (beg end)
+ (unless (get-char-property beg 'diff--font-lock-syntax)
+ (diff-syntax-fontify beg end)
+ (let ((ol (make-overlay beg end)))
+ (overlay-put ol 'diff--font-lock-syntax t)
+ (overlay-put ol 'diff-mode 'syntax)
+ (overlay-put ol 'evaporate t)
+ (overlay-put ol 'modification-hooks
+ '(diff--overlay-auto-delete))))))))
+
+(defun diff-syntax-fontify (beg end)
+ "Highlight source language syntax in diff hunk between BEG and END."
+ (remove-overlays beg end 'diff-mode 'syntax)
+ (save-excursion
+ (diff-syntax-fontify-hunk beg end t)
+ (diff-syntax-fontify-hunk beg end nil)))
+
+(eval-when-compile (require 'subr-x)) ; for string-trim-right
+
+(defvar-local diff--syntax-file-attributes nil)
+(put 'diff--syntax-file-attributes 'permanent-local t)
+
+(defun diff-syntax-fontify-hunk (beg end old)
+ "Highlight source language syntax in diff hunk between BEG and END.
+When OLD is non-nil, highlight the hunk from the old source."
+ (goto-char beg)
+ (let* ((hunk (buffer-substring-no-properties beg end))
+ ;; Trim a trailing newline to find hunk in diff-syntax-fontify-props
+ ;; in diffs that have no newline at end of diff file.
+ (text (string-trim-right
+ (or (with-demoted-errors (diff-hunk-text hunk (not old) nil))
+ "")))
+ (line (if (looking-at "\\(?:\\*\\{15\\}.*\n\\)?[-@* ]*\\([0-9,]+\\)\\([ acd+]+\\([0-9,]+\\)\\)?")
+ (if old (match-string 1)
+ (if (match-end 3) (match-string 3) (match-string 1)))))
+ (line-nb (when line
+ (if (string-match "\\([0-9]+\\),\\([0-9]+\\)" line)
+ (list (string-to-number (match-string 1 line))
+ (string-to-number (match-string 2 line)))
+ (list (string-to-number line) 1)))) ; One-line diffs
+ (props
+ (or
+ (when (and diff-vc-backend
+ (not (eq diff-font-lock-syntax 'hunk-only)))
+ (let* ((file (diff-find-file-name old t))
+ (revision (and file (if (not old) (nth 1 diff-vc-revisions)
+ (or (nth 0 diff-vc-revisions)
+ (vc-working-revision file))))))
+ (when file
+ (if (not revision)
+ ;; Get properties from the current working revision
+ (when (and (not old) (file-readable-p file)
+ (file-regular-p file))
+ (let ((buf (get-file-buffer (expand-file-name file))))
+ ;; Try to reuse an existing buffer
+ (if buf
+ (with-current-buffer buf
+ (diff-syntax-fontify-props nil text line-nb))
+ ;; Get properties from the file.
+ (with-current-buffer (get-buffer-create
+ " *diff-syntax-file*")
+ (let ((attrs (file-attributes file)))
+ (if (equal diff--syntax-file-attributes attrs)
+ ;; Same file as last-time, unmodified.
+ ;; Reuse buffer as-is.
+ (setq file nil)
+ (insert-file-contents file)
+ (setq diff--syntax-file-attributes attrs)))
+ (diff-syntax-fontify-props file text line-nb)))))
+ ;; Get properties from a cached revision
+ (let* ((buffer-name (format " *diff-syntax:%s.~%s~*"
+ (expand-file-name file)
+ revision))
+ (buffer (get-buffer buffer-name)))
+ (if buffer
+ ;; Don't re-initialize the buffer (which would throw
+ ;; away the previous fontification work).
+ (setq file nil)
+ (setq buffer (ignore-errors
+ (vc-find-revision-no-save
+ (expand-file-name file) revision
+ diff-vc-backend
+ (get-buffer-create buffer-name)))))
+ (when buffer
+ (with-current-buffer buffer
+ (diff-syntax-fontify-props file text line-nb))))))))
+ (let ((file (car (diff-hunk-file-names old))))
+ (cond
+ ((and file diff-default-directory
+ (not (eq diff-font-lock-syntax 'hunk-only))
+ (not diff-vc-backend)
+ (file-readable-p file) (file-regular-p file))
+ ;; Try to get full text from the file.
+ (with-temp-buffer
+ (insert-file-contents file)
+ (diff-syntax-fontify-props file text line-nb)))
+ ;; Otherwise, get properties from the hunk alone
+ ((memq diff-font-lock-syntax '(hunk-also hunk-only))
+ (with-temp-buffer
+ (insert text)
+ (diff-syntax-fontify-props file text line-nb t))))))))
+
+ ;; Put properties over the hunk text
+ (goto-char beg)
+ (when (and props (eq (diff-hunk-style) 'unified))
+ (while (< (progn (forward-line 1) (point)) end)
+ ;; Skip the "\ No newline at end of file" lines as well as the lines
+ ;; corresponding to the "other" version.
+ (unless (looking-at-p (if old "[+>\\]" "[-<\\]"))
+ (if (and old (not (looking-at-p "[-<]")))
+ ;; Fontify context lines only from new source,
+ ;; don't refontify context lines from old source.
+ (pop props)
+ (let ((line-props (pop props))
+ (bol (1+ (point))))
+ (dolist (prop line-props)
+ ;; Ideally, we'd want to use text-properties as in:
+ ;;
+ ;; (add-face-text-property
+ ;; (+ bol (nth 0 prop)) (+ bol (nth 1 prop))
+ ;; (nth 2 prop) 'append)
+ ;;
+ ;; rather than overlays here, but they'd get removed by later
+ ;; font-locking.
+ ;; This is because we also apply faces outside of the
+ ;; beg...end chunk currently font-locked and when font-lock
+ ;; later comes to handle the rest of the hunk that we already
+ ;; handled we don't (want to) redo it (we work at
+ ;; hunk-granularity rather than font-lock's own chunk
+ ;; granularity).
+ ;; I see two ways to fix this:
+ ;; - don't immediately apply the props that fall outside of
+ ;; font-lock's chunk but stash them somewhere (e.g. in another
+ ;; text property) and only later when font-lock comes back
+ ;; move them to `face'.
+ ;; - change the code so work at font-lock's chunk granularity
+ ;; (this seems doable without too much extra overhead,
+ ;; contrary to the refine highlighting, which inherently
+ ;; works at a different granularity).
+ (let ((ol (make-overlay (+ bol (nth 0 prop))
+ (+ bol (nth 1 prop))
+ nil 'front-advance nil)))
+ (overlay-put ol 'diff-mode 'syntax)
+ (overlay-put ol 'evaporate t)
+ (overlay-put ol 'face (nth 2 prop)))))))))))
+
+(defun diff-syntax-fontify-props (file text line-nb &optional hunk-only)
+ "Get font-lock properties from the source code.
+FILE is the name of the source file. If non-nil, it requests initialization
+of the mode according to FILE.
+TEXT is the literal source text from hunk.
+LINE-NB is a pair of numbers: start line number and the number of
+lines in the hunk.
+When HUNK-ONLY is non-nil, then don't verify the existence of the
+hunk text in the source file. Otherwise, don't highlight the hunk if the
+hunk text is not found in the source file."
+ (when file
+ ;; When initialization is requested, we should be in a brand new
+ ;; temp buffer.
+ (cl-assert (null buffer-file-name))
+ (let ((enable-local-variables :safe) ;; to find `mode:'
+ (buffer-file-name file))
+ (set-auto-mode)
+ ;; FIXME: Is this really worth the trouble?
+ (when (and (fboundp 'generic-mode-find-file-hook)
+ (memq #'generic-mode-find-file-hook
+ ;; There's no point checking the buffer-local value,
+ ;; we're in a fresh new buffer.
+ (default-value 'find-file-hook)))
+ (generic-mode-find-file-hook))))
+
+ (let ((font-lock-defaults (or font-lock-defaults '(nil t)))
+ props beg end)
+ (goto-char (point-min))
+ (if hunk-only
+ (setq beg (point-min) end (point-max))
+ (forward-line (1- (nth 0 line-nb)))
+ ;; non-regexp looking-at to compare hunk text for verification
+ (if (search-forward text (+ (point) (length text)) t)
+ (setq beg (- (point) (length text)) end (point))
+ (goto-char (point-min))
+ (if (search-forward text nil t)
+ (setq beg (- (point) (length text)) end (point)))))
+
+ (when (and beg end)
+ (goto-char beg)
+ (font-lock-ensure beg end)
+
+ (while (< (point) end)
+ (let* ((bol (point))
+ (eol (line-end-position))
+ line-props
+ (searching t)
+ (from (point)) to
+ (val (get-text-property from 'face)))
+ (while searching
+ (setq to (next-single-property-change from 'face nil eol))
+ (when val (push (list (- from bol) (- to bol) val) line-props))
+ (setq val (get-text-property to 'face) from to)
+ (unless (< to eol) (setq searching nil)))
+ (when val (push (list from eol val) line-props))
+ (push (nreverse line-props) props))
+ (forward-line 1)))
+ (nreverse props)))
+
+
+(defun diff--filter-substring (str)
+ (when diff-font-lock-prettify
+ ;; Strip the `display' properties added by diff-font-lock-prettify,
+ ;; since they look weird when you kill&yank!
+ (remove-text-properties 0 (length str) '(display nil) str)
+ ;; We could also try to only remove those `display' properties actually
+ ;; added by diff-font-lock-prettify rather than removing them all blindly.
+ ;; E.g.:
+ ;;(let ((len (length str))
+ ;; (i 0))
+ ;; (while (and (< i len)
+ ;; (setq i (text-property-not-all i len 'display nil str)))
+ ;; (let* ((val (get-text-property i 'display str))
+ ;; (end (or (text-property-not-all i len 'display val str) len)))
+ ;; ;; FIXME: Check for display props that prettify the file header!
+ ;; (when (eq 'left-fringe (car-safe val))
+ ;; ;; FIXME: Should we check that it's a diff-fringe-* bitmap?
+ ;; (remove-text-properties i end '(display nil) str))
+ ;; (setq i end))))
+ )
+ str)
+
+;;; Support for converting a diff to diff3 markers via `wiggle'.
+
+;; Wiggle can be found at http://neil.brown.name/wiggle/ or in your nearest
+;; Debian repository.
+
+(defun diff-wiggle ()
+ "Use `wiggle' to apply the whole current file diff by hook or by crook.
+When a hunk can't cleanly be applied, it gets turned into a diff3-style
+conflict."
+ (interactive)
+ (let* ((bounds (diff-bounds-of-file))
+ (file (diff-find-file-name))
+ (tmpbuf (current-buffer))
+ (filebuf (find-buffer-visiting file))
+ (patchfile (make-temp-file
+ (expand-file-name "wiggle" (file-name-directory file))
+ nil ".diff"))
+ (errfile (make-temp-file
+ (expand-file-name "wiggle" (file-name-directory file))
+ nil ".error")))
+ (unwind-protect
+ (with-temp-buffer
+ (set-buffer (prog1 tmpbuf (setq tmpbuf (current-buffer))))
+ (when (buffer-modified-p filebuf)
+ (save-some-buffers nil (lambda () (eq (current-buffer) filebuf)))
+ (if (buffer-modified-p filebuf) (user-error "Abort!")))
+ (write-region (car bounds) (cadr bounds) patchfile nil 'silent)
+ (let ((exitcode
+ (call-process "wiggle" nil (list tmpbuf errfile) nil
+ file patchfile)))
+ (if (not (memq exitcode '(0 1)))
+ (message "diff-wiggle error: %s"
+ (with-current-buffer tmpbuf
+ (goto-char (point-min))
+ (insert-file-contents errfile)
+ (buffer-string)))
+ (with-current-buffer tmpbuf
+ (write-region nil nil file nil 'silent)
+ (with-current-buffer filebuf
+ (revert-buffer t t t)
+ (save-excursion
+ (goto-char (point-min))
+ (if (re-search-forward "^<<<<<<<" nil t)
+ (smerge-mode 1)))
+ (pop-to-buffer filebuf))))))
+ (delete-file patchfile)
+ (delete-file errfile))))
+
;; provide the package
(provide 'diff-mode)
diff --git a/lisp/vc/diff.el b/lisp/vc/diff.el
index c04ff17ade7..523be87bc49 100644
--- a/lisp/vc/diff.el
+++ b/lisp/vc/diff.el
@@ -121,6 +121,8 @@ Possible values are:
nil -- no, it does not
check -- try to probe whether it does")
+(defvar diff-default-directory)
+
(defun diff-no-select (old new &optional switches no-async buf)
;; Noninteractive helper for creating and reverting diff buffers
(unless (bufferp new) (setq new (expand-file-name new)))
@@ -165,6 +167,7 @@ Possible values are:
(lambda (_ignore-auto _noconfirm)
(diff-no-select old new switches no-async (current-buffer))))
(setq default-directory thisdir)
+ (setq diff-default-directory default-directory)
(let ((inhibit-read-only t))
(insert command "\n"))
(if (and (not no-async) (fboundp 'make-process))
@@ -226,8 +229,9 @@ With prefix arg, prompt for diff switches."
"View the differences between BUFFER and its associated file.
This requires the external program `diff' to be in your `exec-path'."
(interactive "bBuffer: ")
- (with-current-buffer (get-buffer (or buffer (current-buffer)))
- (diff buffer-file-name (current-buffer) nil 'noasync)))
+ (let ((buf (get-buffer (or buffer (current-buffer)))))
+ (with-current-buffer (or (buffer-base-buffer buf) buf)
+ (diff buffer-file-name (current-buffer) nil 'noasync))))
(provide 'diff)
diff --git a/lisp/vc/ediff-init.el b/lisp/vc/ediff-init.el
index c1526235dea..a74d6a8b4d1 100644
--- a/lisp/vc/ediff-init.el
+++ b/lisp/vc/ediff-init.el
@@ -267,17 +267,17 @@ It needs to be killed when we quit the session.")
(and (ediff-window-display-p) ediff-multiframe))
(defmacro ediff-narrow-control-frame-p ()
- `(and (ediff-multiframe-setup-p)
- (equal ediff-help-message ediff-brief-message-string)))
+ '(and (ediff-multiframe-setup-p)
+ (equal ediff-help-message ediff-brief-message-string)))
(defmacro ediff-3way-comparison-job ()
- `(memq
+ '(memq
ediff-job-name
'(ediff-files3 ediff-buffers3)))
(ediff-defvar-local ediff-3way-comparison-job nil "")
(defmacro ediff-merge-job ()
- `(memq
+ '(memq
ediff-job-name
'(ediff-merge-files
ediff-merge-buffers
@@ -288,10 +288,10 @@ It needs to be killed when we quit the session.")
(ediff-defvar-local ediff-merge-job nil "")
(defmacro ediff-patch-job ()
- `(eq ediff-job-name 'epatch))
+ '(eq ediff-job-name 'epatch))
(defmacro ediff-merge-with-ancestor-job ()
- `(memq
+ '(memq
ediff-job-name
'(ediff-merge-files-with-ancestor
ediff-merge-buffers-with-ancestor
@@ -299,26 +299,26 @@ It needs to be killed when we quit the session.")
(ediff-defvar-local ediff-merge-with-ancestor-job nil "")
(defmacro ediff-3way-job ()
- `(or ediff-3way-comparison-job ediff-merge-job))
+ '(or ediff-3way-comparison-job ediff-merge-job))
(ediff-defvar-local ediff-3way-job nil "")
;; A diff3 job is like a 3way job, but ediff-merge doesn't require the use
;; of diff3.
(defmacro ediff-diff3-job ()
- `(or ediff-3way-comparison-job
+ '(or ediff-3way-comparison-job
ediff-merge-with-ancestor-job))
(ediff-defvar-local ediff-diff3-job nil "")
(defmacro ediff-windows-job ()
- `(memq ediff-job-name '(ediff-windows-wordwise ediff-windows-linewise)))
+ '(memq ediff-job-name '(ediff-windows-wordwise ediff-windows-linewise)))
(ediff-defvar-local ediff-windows-job nil "")
(defmacro ediff-word-mode-job ()
- `(memq ediff-job-name '(ediff-windows-wordwise ediff-regions-wordwise)))
+ '(memq ediff-job-name '(ediff-windows-wordwise ediff-regions-wordwise)))
(ediff-defvar-local ediff-word-mode-job nil "")
(defmacro ediff-narrow-job ()
- `(memq ediff-job-name '(ediff-windows-wordwise
+ '(memq ediff-job-name '(ediff-windows-wordwise
ediff-regions-wordwise
ediff-windows-linewise
ediff-regions-linewise)))
diff --git a/lisp/vc/ediff-merg.el b/lisp/vc/ediff-merg.el
index 27835f7bdc1..a511f4488f1 100644
--- a/lisp/vc/ediff-merg.el
+++ b/lisp/vc/ediff-merg.el
@@ -194,7 +194,7 @@ Buffer B."
(defun ediff-set-merge-mode ()
(normal-mode t)
- (remove-hook 'local-write-file-hooks 'ediff-set-merge-mode))
+ (remove-hook 'write-file-functions 'ediff-set-merge-mode t))
;; Go over all diffs starting with DIFF-NUM and copy regions into buffer C
diff --git a/lisp/vc/ediff-ptch.el b/lisp/vc/ediff-ptch.el
index 35d7e28f294..4178b5a8c05 100644
--- a/lisp/vc/ediff-ptch.el
+++ b/lisp/vc/ediff-ptch.el
@@ -681,7 +681,7 @@ optional argument, then use it."
(error
"Ediff doesn't take the -V option in `ediff-patch-options'--sorry"))
- ;; Make a temp file, if source-filename has a magic file handler (or if
+ ;; Make a temp file, if source-filename has a magic file name handler (or if
;; it is handled via auto-mode-alist and similar magic).
;; Check if there is a buffer visiting source-filename and if they are in
;; sync; arrange for the deletion of temp file.
@@ -691,7 +691,7 @@ optional argument, then use it."
;; Check if source file name has triggered black magic, such as file name
;; handlers or auto mode alist, and make a note of it.
;; true-source-filename should be either the original name or a
- ;; temporary file where we put the after-product of the file handler.
+ ;; temporary file where we put the after-product of the file name handler.
(setq file-name-magic-p (not (equal (file-truename true-source-filename)
(file-truename source-filename))))
@@ -823,11 +823,11 @@ you can still examine the changes via M-x ediff-files"
(setq startup-hooks
;; this sets various vars in the meta buffer inside
;; ediff-prepare-meta-buffer
- (cons `(lambda ()
- ;; tell what to do if the user clicks on a session record
- (setq ediff-session-action-function
- 'ediff-patch-file-form-meta
- ediff-meta-patchbufer patch-buf) )
+ (cons (lambda ()
+ ;; tell what to do if the user clicks on a session record
+ (setq ediff-session-action-function
+ 'ediff-patch-file-form-meta
+ ediff-meta-patchbufer patch-buf) )
startup-hooks))
(setq meta-buf (ediff-prepare-meta-buffer
'ediff-filegroup-action
diff --git a/lisp/vc/ediff-util.el b/lisp/vc/ediff-util.el
index 2e9863048f9..6e282a4fd80 100644
--- a/lisp/vc/ediff-util.el
+++ b/lisp/vc/ediff-util.el
@@ -39,9 +39,6 @@
(defvar ediff-after-quit-hook-internal nil)
-(eval-and-compile
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest _r))))
-
;; end pacifier
@@ -347,7 +344,7 @@ to invocation.")
(goto-char (point-min))
(funcall (ediff-with-current-buffer buf major-mode))
(widen) ; merge buffer is always widened
- (add-hook 'local-write-file-hooks 'ediff-set-merge-mode nil t)
+ (add-hook 'write-file-functions 'ediff-set-merge-mode nil t)
)))
(setq buffer-read-only nil
ediff-buffer-A buffer-A
@@ -778,8 +775,8 @@ Reestablish the default window display."
(select-frame-set-input-focus ediff-control-frame)
(raise-frame ediff-control-frame)
(select-frame ediff-control-frame)
- (if (fboundp 'focus-frame)
- (focus-frame ediff-control-frame))))
+ (and (featurep 'xemacs) (fboundp 'focus-frame)
+ (focus-frame ediff-control-frame))))
;; Redisplay whatever buffers are showing, if there is a selected difference
(let ((control-frame ediff-control-frame)
@@ -3224,9 +3221,9 @@ Hit \\[ediff-recenter] to reset the windows afterward."
short-f (concat ediff-temp-file-prefix short-p)
f (cond (given-file)
((find-file-name-handler f 'insert-file-contents)
- ;; to thwart file handlers in write-region, e.g., if file
- ;; name ends with .Z or .gz
- ;; This is needed so that patches produced by ediff will
+ ;; to thwart file name handlers in write-region,
+ ;; e.g., if file name ends with .Z or .gz
+ ;; This is needed so that patches produced by ediff will
;; have more meaningful names
(ediff-make-empty-tmp-file short-f))
(prefix
@@ -3549,25 +3546,19 @@ Ediff Control Panel to restore highlighting."
(ediff-paint-background-regions 'unhighlight)
(cond ((ediff-merge-job)
- (setq bufB ediff-buffer-C)
;; ask which buffer to compare to the merge buffer
- (while (cond ((eq answer ?A)
- (setq bufA ediff-buffer-A
- possibilities '(?B))
- nil)
- ((eq answer ?B)
- (setq bufA ediff-buffer-B
- possibilities '(?A))
- nil)
- ((equal answer ""))
- (t (beep 1)
- (message "Valid values are A or B")
- (sit-for 2)
- t))
- (let ((cursor-in-echo-area t))
- (message
- "Which buffer to compare to the merge buffer (A or B)? ")
- (setq answer (capitalize (read-char-exclusive))))))
+ (setq answer (read-multiple-choice
+ "Which buffer to compare?"
+ '((?a "A")
+ (?b "B"))))
+ (if (eq (car answer) ?a)
+ (setq bufA ediff-buffer-A)
+ (setq bufA ediff-buffer-B))
+ (setq bufB (if (and ediff-ancestor-buffer
+ (y-or-n-p (format "Compare %s against ancestor buffer?"
+ (cadr answer))))
+ ediff-ancestor-buffer
+ ediff-buffer-C)))
((ediff-3way-comparison-job)
;; ask which two buffers to compare
diff --git a/lisp/vc/ediff-wind.el b/lisp/vc/ediff-wind.el
index bc41e3d9e5c..492ddd3417a 100644
--- a/lisp/vc/ediff-wind.el
+++ b/lisp/vc/ediff-wind.el
@@ -38,10 +38,6 @@
(defvar frame-icon-title-format)
(defvar ediff-diff-status)
-;; declare-function does not exist in XEmacs
-(eval-and-compile
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest _r))))
-
(require 'ediff-init)
(require 'ediff-help)
;; end pacifier
@@ -64,10 +60,10 @@
(defun ediff-choose-window-setup-function-automatically ()
(declare (obsolete ediff-setup-windows-default "24.3"))
(if (ediff-window-display-p)
- 'ediff-setup-windows-multiframe
- 'ediff-setup-windows-plain))
+ #'ediff-setup-windows-multiframe
+ #'ediff-setup-windows-plain))
-(defcustom ediff-window-setup-function 'ediff-setup-windows-default
+(defcustom ediff-window-setup-function #'ediff-setup-windows-default
"Function called to set up windows.
Ediff provides a choice of three functions:
(1) `ediff-setup-windows-multiframe', which sets the control panel
@@ -132,7 +128,7 @@ provided functions are written."
(Ancestor . ediff-window-Ancestor)))
-(defcustom ediff-split-window-function 'split-window-vertically
+(defcustom ediff-split-window-function #'split-window-vertically
"The function used to split the main window between buffer-A and buffer-B.
You can set it to a horizontal split instead of the default vertical split
by setting this variable to `split-window-horizontally'.
@@ -145,7 +141,7 @@ In this case, Ediff will use those frames to display these buffers."
function)
:group 'ediff-window)
-(defcustom ediff-merge-split-window-function 'split-window-horizontally
+(defcustom ediff-merge-split-window-function #'split-window-horizontally
"The function used to split the main window between buffer-A and buffer-B.
You can set it to a vertical split instead of the default horizontal split
by setting this variable to `split-window-vertically'.
@@ -212,7 +208,7 @@ responsibility."
:type 'boolean
:group 'ediff-window)
-(defcustom ediff-control-frame-position-function 'ediff-make-frame-position
+(defcustom ediff-control-frame-position-function #'ediff-make-frame-position
"Function to call to determine the desired location for the control panel.
Expects three parameters: the control buffer, the desired width and height
of the control frame. It returns an association list
@@ -260,7 +256,7 @@ customization of the default."
display off.")
(ediff-defvar-local ediff-wide-display-frame nil
"Frame to be used for wide display.")
-(ediff-defvar-local ediff-make-wide-display-function 'ediff-make-wide-display
+(ediff-defvar-local ediff-make-wide-display-function #'ediff-make-wide-display
"The value is a function that is called to create a wide display.
The function is called without arguments. It should resize the frame in
which buffers A, B, and C are to be displayed, and it should save the old
@@ -336,11 +332,11 @@ into icons, regardless of the window manager."
;; in case user did a no-no on a tty
(or (ediff-window-display-p)
- (setq ediff-window-setup-function 'ediff-setup-windows-plain))
+ (setq ediff-window-setup-function #'ediff-setup-windows-plain))
(or (ediff-keep-window-config control-buffer)
(funcall
- (ediff-with-current-buffer control-buffer ediff-window-setup-function)
+ (with-current-buffer control-buffer ediff-window-setup-function)
buffer-A buffer-B buffer-C control-buffer))
(run-hooks 'ediff-after-setup-windows-hook))
@@ -354,7 +350,7 @@ into icons, regardless of the window manager."
;; Usually used without windowing systems
;; With windowing, we want to use dedicated frames.
(defun ediff-setup-windows-plain (buffer-A buffer-B buffer-C control-buffer)
- (ediff-with-current-buffer control-buffer
+ (with-current-buffer control-buffer
(setq ediff-multiframe nil))
(if ediff-merge-job
(ediff-setup-windows-plain-merge
@@ -368,14 +364,14 @@ into icons, regardless of the window manager."
;; skip dedicated and unsplittable frames
(ediff-destroy-control-frame control-buffer)
(let ((window-min-height 1)
- (with-Ancestor-p (ediff-with-current-buffer control-buffer
+ (with-Ancestor-p (with-current-buffer control-buffer
ediff-merge-with-ancestor-job))
split-window-function
merge-window-share merge-window-lines
- (buf-Ancestor (ediff-with-current-buffer control-buffer
+ (buf-Ancestor (with-current-buffer control-buffer
ediff-ancestor-buffer))
wind-A wind-B wind-C wind-Ancestor)
- (ediff-with-current-buffer control-buffer
+ (with-current-buffer control-buffer
(setq merge-window-share ediff-merge-window-share
;; this lets us have local versions of ediff-split-window-function
split-window-function ediff-split-window-function))
@@ -419,7 +415,7 @@ into icons, regardless of the window manager."
(switch-to-buffer buf-B)
(setq wind-B (selected-window))
- (ediff-with-current-buffer control-buffer
+ (with-current-buffer control-buffer
(setq ediff-window-A wind-A
ediff-window-B wind-B
ediff-window-C wind-C
@@ -438,7 +434,7 @@ into icons, regardless of the window manager."
split-window-function wind-width-or-height
three-way-comparison
wind-A-start wind-B-start wind-A wind-B wind-C)
- (ediff-with-current-buffer control-buffer
+ (with-current-buffer control-buffer
(setq wind-A-start (ediff-overlay-start
(ediff-get-value-according-to-buffer-type
'A ediff-narrow-bounds))
@@ -464,7 +460,7 @@ into icons, regardless of the window manager."
(setq wind-A (selected-window))
(if three-way-comparison
(setq wind-width-or-height
- (/ (if (eq split-window-function 'split-window-vertically)
+ (/ (if (eq split-window-function #'split-window-vertically)
(window-height wind-A)
(window-width wind-A))
3)))
@@ -489,7 +485,7 @@ into icons, regardless of the window manager."
(switch-to-buffer buf-C)
(setq wind-C (selected-window))))
- (ediff-with-current-buffer control-buffer
+ (with-current-buffer control-buffer
(setq ediff-window-A wind-A
ediff-window-B wind-B
ediff-window-C wind-C))
@@ -508,23 +504,23 @@ into icons, regardless of the window manager."
;; dispatch an appropriate window setup function
(defun ediff-setup-windows-multiframe (buf-A buf-B buf-C control-buf)
- (ediff-with-current-buffer control-buf
+ (with-current-buffer control-buf
(setq ediff-multiframe t))
(if ediff-merge-job
(ediff-setup-windows-multiframe-merge buf-A buf-B buf-C control-buf)
(ediff-setup-windows-multiframe-compare buf-A buf-B buf-C control-buf)))
(defun ediff-setup-windows-multiframe-merge (buf-A buf-B buf-C control-buf)
-;;; Algorithm:
-;;; 1. Never use frames that have dedicated windows in them---it is bad to
-;;; destroy dedicated windows.
-;;; 2. If A and B are in the same frame but C's frame is different---use one
-;;; frame for A and B, and use a separate frame for C.
-;;; 3. If C's frame is non-existent, then: if the first suitable
-;;; non-dedicated frame is different from A&B's, then use it for C.
-;;; Otherwise, put A, B, and C in one frame.
-;;; 4. If buffers A, B, C are in separate frames, use them to display these
-;;; buffers.
+ ;; Algorithm:
+ ;; 1. Never use frames that have dedicated windows in them---it is bad to
+ ;; destroy dedicated windows.
+ ;; 2. If A and B are in the same frame but C's frame is different--- use one
+ ;; frame for A and B and use a separate frame for C.
+ ;; 3. If C's frame is non-existent, then: if the first suitable
+ ;; non-dedicated frame is different from A&B's, then use it for C.
+ ;; Otherwise, put A,B, and C in one frame.
+ ;; 4. If buffers A, B, C are is separate frames, use them to display these
+ ;; buffers.
;; Skip dedicated or iconified frames.
;; Unsplittable frames are taken care of later.
@@ -534,7 +530,7 @@ into icons, regardless of the window manager."
(wind-A (ediff-get-visible-buffer-window buf-A))
(wind-B (ediff-get-visible-buffer-window buf-B))
(wind-C (ediff-get-visible-buffer-window buf-C))
- (buf-Ancestor (ediff-with-current-buffer control-buf
+ (buf-Ancestor (with-current-buffer control-buf
ediff-ancestor-buffer))
(wind-Ancestor (ediff-get-visible-buffer-window buf-Ancestor))
(frame-A (if wind-A (window-frame wind-A)))
@@ -543,10 +539,10 @@ into icons, regardless of the window manager."
(frame-Ancestor (if wind-Ancestor (window-frame wind-Ancestor)))
;; on wide display, do things in one frame
(force-one-frame
- (ediff-with-current-buffer control-buf ediff-wide-display-p))
+ (with-current-buffer control-buf ediff-wide-display-p))
;; this lets us have local versions of ediff-split-window-function
(split-window-function
- (ediff-with-current-buffer control-buf ediff-split-window-function))
+ (with-current-buffer control-buf ediff-split-window-function))
(orig-wind (selected-window))
(orig-frame (selected-frame))
(use-same-frame (or force-one-frame
@@ -568,11 +564,11 @@ into icons, regardless of the window manager."
;; use-same-frame-for-AB implies wind A and B are ok for display
(use-same-frame-for-AB (and (not use-same-frame)
(eq frame-A frame-B)))
- (merge-window-share (ediff-with-current-buffer control-buf
+ (merge-window-share (with-current-buffer control-buf
ediff-merge-window-share))
merge-window-lines
designated-minibuffer-frame ; ediff-merge-with-ancestor-job
- (with-Ancestor-p (ediff-with-current-buffer control-buf
+ (with-Ancestor-p (with-current-buffer control-buf
ediff-merge-with-ancestor-job))
(done-Ancestor (not with-Ancestor-p))
done-A done-B done-C)
@@ -726,7 +722,7 @@ into icons, regardless of the window manager."
(switch-to-buffer buf-Ancestor)
(setq wind-Ancestor (selected-window))))
- (ediff-with-current-buffer control-buf
+ (with-current-buffer control-buf
(setq ediff-window-A wind-A
ediff-window-B wind-B
ediff-window-C wind-C
@@ -740,21 +736,17 @@ into icons, regardless of the window manager."
;; Window setup for all comparison jobs, including 3way comparisons
(defun ediff-setup-windows-multiframe-compare (buf-A buf-B buf-C control-buf)
-;;; Algorithm:
-;;; If a buffer is seen in a frame, use that frame for that buffer.
-;;; If it is not seen, use the current frame.
-;;; If both buffers are not seen, they share the current frame. If one
-;;; of the buffers is not seen, it is placed in the current frame (where
-;;; ediff started). If that frame is displaying the other buffer, it is
-;;; shared between the two buffers.
-;;; However, if we decide to put both buffers in one frame
-;;; and the selected frame isn't splittable, we create a new frame and
-;;; put both buffers there, event if one of this buffers is visible in
-;;; another frame.
-
- ;; Skip dedicated or iconified frames.
- ;; Unsplittable frames are taken care of later.
- (ediff-skip-unsuitable-frames 'ok-unsplittable)
+ ;; Algorithm:
+ ;; If a buffer is seen in a frame, use that frame for that buffer.
+ ;; If it is not seen, use the current frame.
+ ;; If both buffers are not seen, they share the current frame. If one
+ ;; of the buffers is not seen, it is placed in the current frame (where
+ ;; ediff started). If that frame is displaying the other buffer, it is
+ ;; shared between the two buffers.
+ ;; However, if we decide to put both buffers in one frame
+ ;; and the selected frame isn't splittable, we create a new frame and
+ ;; put both buffers there, event if one of this buffers is visible in
+ ;; another frame.
(let* ((window-min-height 1)
(wind-A (ediff-get-visible-buffer-window buf-A))
@@ -763,17 +755,16 @@ into icons, regardless of the window manager."
(frame-A (if wind-A (window-frame wind-A)))
(frame-B (if wind-B (window-frame wind-B)))
(frame-C (if wind-C (window-frame wind-C)))
- (ctl-frame-exists-p (ediff-with-current-buffer control-buf
+ (ctl-frame-exists-p (with-current-buffer control-buf
(frame-live-p ediff-control-frame)))
;; on wide display, do things in one frame
(force-one-frame
- (ediff-with-current-buffer control-buf ediff-wide-display-p))
+ (with-current-buffer control-buf ediff-wide-display-p))
;; this lets us have local versions of ediff-split-window-function
(split-window-function
- (ediff-with-current-buffer control-buf ediff-split-window-function))
+ (with-current-buffer control-buf ediff-split-window-function))
(three-way-comparison
- (ediff-with-current-buffer control-buf ediff-3way-comparison-job))
- (orig-wind (selected-window))
+ (with-current-buffer control-buf ediff-3way-comparison-job))
(use-same-frame (or force-one-frame
(eq frame-A frame-B)
(not (ediff-window-ok-for-display wind-A))
@@ -792,10 +783,9 @@ into icons, regardless of the window manager."
(or ctl-frame-exists-p
(eq frame-B (selected-frame))))))
wind-A-start wind-B-start
- designated-minibuffer-frame
- done-A done-B done-C)
+ designated-minibuffer-frame)
- (ediff-with-current-buffer control-buf
+ (with-current-buffer control-buf
(setq wind-A-start (ediff-overlay-start
(ediff-get-value-according-to-buffer-type
'A ediff-narrow-bounds))
@@ -803,30 +793,6 @@ into icons, regardless of the window manager."
(ediff-get-value-according-to-buffer-type
'B ediff-narrow-bounds))))
- (if (and (window-live-p wind-A) (null use-same-frame)) ; buf-A on its own
- (progn
- ;; buffer buf-A is seen in live wind-A
- (select-window wind-A) ; must be displaying buf-A
- (delete-other-windows)
- (setq wind-A (selected-window))
- (setq done-A t)))
-
- (if (and (window-live-p wind-B) (null use-same-frame)) ; buf B on its own
- (progn
- ;; buffer buf-B is seen in live wind-B
- (select-window wind-B) ; must be displaying buf-B
- (delete-other-windows)
- (setq wind-B (selected-window))
- (setq done-B t)))
-
- (if (and (window-live-p wind-C) (null use-same-frame)) ; buf C on its own
- (progn
- ;; buffer buf-C is seen in live wind-C
- (select-window wind-C) ; must be displaying buf-C
- (delete-other-windows)
- (setq wind-C (selected-window))
- (setq done-C t)))
-
(if use-same-frame
(let (wind-width-or-height) ; this affects 3way setups only
(if (and (eq frame-A frame-B) (frame-live-p frame-A))
@@ -840,7 +806,7 @@ into icons, regardless of the window manager."
(if three-way-comparison
(setq wind-width-or-height
(/
- (if (eq split-window-function 'split-window-vertically)
+ (if (eq split-window-function #'split-window-vertically)
(window-height wind-A)
(window-width wind-A))
3)))
@@ -857,46 +823,57 @@ into icons, regardless of the window manager."
(if (memq (selected-window) (list wind-A wind-B))
(other-window 1))
(switch-to-buffer buf-C)
- (setq wind-C (selected-window))))
- (setq done-A t
- done-B t
- done-C t)
- ))
-
- (or done-A ; Buf A to be set in its own frame
- ;;; or it was set before because use-same-frame = 1
- (progn
- ;; Buf-A was not set up yet as it wasn't visible,
- ;; and use-same-frame = nil
- (select-window orig-wind)
- (delete-other-windows)
- (switch-to-buffer buf-A)
- (setq wind-A (selected-window))
- ))
- (or done-B ; Buf B to be set in its own frame
- ;;; or it was set before because use-same-frame = 1
- (progn
- ;; Buf-B was not set up yet as it wasn't visible,
- ;; and use-same-frame = nil
- (select-window orig-wind)
- (delete-other-windows)
- (switch-to-buffer buf-B)
- (setq wind-B (selected-window))
- ))
-
- (if three-way-comparison
- (or done-C ; Buf C to be set in its own frame
- ;;; or it was set before because use-same-frame = 1
+ (setq wind-C (selected-window)))))
+
+ (if (window-live-p wind-A) ; buf-A on its own
+ (progn
+ ;; buffer buf-A is seen in live wind-A
+ (select-window wind-A) ; must be displaying buf-A
+ (delete-other-windows)
+ (setq wind-A (selected-window))) ;FIXME: Why?
+ ;; Buf-A was not set up yet as it wasn't visible,
+ ;; and use-same-frame = nil
+ ;; Skip dedicated or iconified frames.
+ ;; Unsplittable frames are taken care of later.
+ (ediff-skip-unsuitable-frames 'ok-unsplittable)
+ (delete-other-windows)
+ (switch-to-buffer buf-A)
+ (setq wind-A (selected-window)))
+
+ (if (window-live-p wind-B) ; buf B on its own
+ (progn
+ ;; buffer buf-B is seen in live wind-B
+ (select-window wind-B) ; must be displaying buf-B
+ (delete-other-windows)
+ (setq wind-B (selected-window))) ;FIXME: Why?
+ ;; Buf-B was not set up yet as it wasn't visible,
+ ;; and use-same-frame = nil
+ ;; Skip dedicated or iconified frames.
+ ;; Unsplittable frames are taken care of later.
+ (ediff-skip-unsuitable-frames 'ok-unsplittable)
+ (delete-other-windows)
+ (switch-to-buffer buf-B)
+ (setq wind-B (selected-window)))
+
+ (if (window-live-p wind-C) ; buf C on its own
+ (progn
+ ;; buffer buf-C is seen in live wind-C
+ (select-window wind-C) ; must be displaying buf-C
+ (delete-other-windows)
+ (setq wind-C (selected-window))) ;FIXME: Why?
+ (if three-way-comparison
(progn
;; Buf-C was not set up yet as it wasn't visible,
;; and use-same-frame = nil
- (select-window orig-wind)
+ ;; Skip dedicated or iconified frames.
+ ;; Unsplittable frames are taken care of later.
+ (ediff-skip-unsuitable-frames 'ok-unsplittable)
(delete-other-windows)
(switch-to-buffer buf-C)
(setq wind-C (selected-window))
- )))
+ ))))
- (ediff-with-current-buffer control-buf
+ (with-current-buffer control-buf
(setq ediff-window-A wind-A
ediff-window-B wind-B
ediff-window-C wind-C)
@@ -915,9 +892,9 @@ into icons, regardless of the window manager."
(ediff-setup-control-frame control-buf designated-minibuffer-frame)
))
-;; skip unsplittable frames and frames that have dedicated windows.
-;; create a new splittable frame if none is found
(defun ediff-skip-unsuitable-frames (&optional ok-unsplittable)
+ "Skip unsplittable frames and frames that have dedicated windows.
+create a new splittable frame if none is found."
(if (ediff-window-display-p)
(let ((wind-frame (window-frame))
seen-windows)
@@ -977,14 +954,14 @@ into icons, regardless of the window manager."
;; user-grabbed-mouse
fheight fwidth adjusted-parameters)
- (ediff-with-current-buffer ctl-buffer
+ (with-current-buffer ctl-buffer
(if (and (featurep 'xemacs) (featurep 'menubar))
(set-buffer-menubar nil))
;;(setq user-grabbed-mouse (ediff-user-grabbed-mouse))
(run-hooks 'ediff-before-setup-control-frame-hook))
- (setq old-ctl-frame (ediff-with-current-buffer ctl-buffer ediff-control-frame))
- (ediff-with-current-buffer ctl-buffer
+ (setq old-ctl-frame (with-current-buffer ctl-buffer ediff-control-frame))
+ (with-current-buffer ctl-buffer
(setq ctl-frame (if (frame-live-p old-ctl-frame)
old-ctl-frame
(make-frame ediff-control-frame-parameters))
@@ -1004,7 +981,7 @@ into icons, regardless of the window manager."
;; must be before ediff-setup-control-buffer
;; just a precaution--we should be in ctl-buffer already
- (ediff-with-current-buffer ctl-buffer
+ (with-current-buffer ctl-buffer
(make-local-variable 'frame-title-format)
(make-local-variable 'frame-icon-title-format) ; XEmacs
(make-local-variable 'icon-title-format)) ; Emacs
@@ -1103,12 +1080,12 @@ into icons, regardless of the window manager."
(not (eq ediff-grab-mouse t)))))
(when (featurep 'xemacs)
- (ediff-with-current-buffer ctl-buffer
+ (with-current-buffer ctl-buffer
(make-local-hook 'select-frame-hook)
(add-hook 'select-frame-hook
- 'ediff-xemacs-select-frame-hook nil 'local)))
+ #'ediff-xemacs-select-frame-hook nil 'local)))
- (ediff-with-current-buffer ctl-buffer
+ (with-current-buffer ctl-buffer
(run-hooks 'ediff-after-setup-control-frame-hook))))
@@ -1128,7 +1105,7 @@ into icons, regardless of the window manager."
;; finds a good place to clip control frame
(defun ediff-make-frame-position (ctl-buffer ctl-frame-width ctl-frame-height)
- (ediff-with-current-buffer ctl-buffer
+ (with-current-buffer ctl-buffer
(let* ((frame-A (window-frame ediff-window-A))
(frame-A-parameters (frame-parameters frame-A))
(frame-A-top (eval (cdr (assoc 'top frame-A-parameters))))
@@ -1382,12 +1359,4 @@ It assumes that it is called from within the control buffer."
(provide 'ediff-wind)
-
-
-;; Local Variables:
-;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
-;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
-;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
-;; End:
-
;;; ediff-wind.el ends here
diff --git a/lisp/vc/ediff.el b/lisp/vc/ediff.el
index 68c4fa2722a..0dfbe2ea66f 100644
--- a/lisp/vc/ediff.el
+++ b/lisp/vc/ediff.el
@@ -112,10 +112,6 @@
(provide 'ediff)
-;; Compiler pacifier
-(eval-and-compile
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest _r))))
-
(require 'ediff-util)
;; end pacifier
@@ -153,7 +149,7 @@
(declare-function dired-get-filename "dired"
(&optional localp no-error-if-not-filep))
(declare-function dired-get-marked-files "dired"
- (&optional localp arg filter distinguish-one-marked))
+ (&optional localp arg filter distinguish-one-marked error))
;; Return a plausible default for ediff's first file:
;; In dired, return the file number FILENO (or 0) in the list
diff --git a/lisp/vc/emerge.el b/lisp/vc/emerge.el
index 0da14d07fd3..fc8c318e3af 100644
--- a/lisp/vc/emerge.el
+++ b/lisp/vc/emerge.el
@@ -1,6 +1,6 @@
-;;; emerge.el --- merge diffs under Emacs control
+;;; emerge.el --- merge diffs under Emacs control -*- lexical-binding:t -*-
-;;; The author has placed this file in the public domain.
+;; The author has placed this file in the public domain.
;; This file is part of GNU Emacs.
@@ -24,42 +24,20 @@
;;; Code:
-;; There aren't really global variables, just dynamic bindings
-(defvar A-begin)
-(defvar A-end)
-(defvar B-begin)
-(defvar B-end)
-(defvar diff-vector)
-(defvar merge-begin)
-(defvar merge-end)
-(defvar valid-diff)
-
;;; Macros
(defmacro emerge-defvar-local (var value doc)
- "Defines SYMBOL as an advertised variable.
+ "Define SYMBOL as an advertised buffer-local variable.
Performs a defvar, then executes `make-variable-buffer-local' on
the variable. Also sets the `permanent-local' property, so that
`kill-all-local-variables' (called by major-mode setting commands)
won't destroy Emerge control variables."
`(progn
- (defvar ,var ,value ,doc)
- (make-variable-buffer-local ',var)
- (put ',var 'permanent-local t)))
-
-;; Add entries to minor-mode-alist so that emerge modes show correctly
-(defvar emerge-minor-modes-list
- '((emerge-mode " Emerge")
- (emerge-fast-mode " F")
- (emerge-edit-mode " E")
- (emerge-auto-advance " A")
- (emerge-skip-prefers " S")))
-(if (not (assq 'emerge-mode minor-mode-alist))
- (setq minor-mode-alist (append emerge-minor-modes-list
- minor-mode-alist)))
+ (defvar-local ,var ,value ,doc)
+ (put ',var 'permanent-local t)))
;; We need to define this function so describe-mode can describe Emerge mode.
-(defun emerge-mode ()
+(define-minor-mode emerge-mode
"Emerge mode is used by the Emerge file-merging package.
It is entered only through one of the functions:
`emerge-files'
@@ -74,7 +52,13 @@ It is entered only through one of the functions:
Commands:
\\{emerge-basic-keymap}
Commands must be prefixed by \\<emerge-fast-keymap>\\[emerge-basic-keymap] in `edit' mode,
-but can be invoked directly in `fast' mode.")
+but can be invoked directly in `fast' mode."
+ :lighter (" Emerge"
+ (emerge-fast-mode " F")
+ (emerge-edit-mode " E")
+ (emerge-auto-advance " A")
+ (emerge-skip-prefers " S")))
+(put 'emerge-mode 'permanent-local t)
;;; Emerge configuration variables
@@ -453,8 +437,6 @@ Must be set before Emerge is loaded."
;; Variables which control each merge. They are local to the merge buffer.
;; Mode variables
-(emerge-defvar-local emerge-mode nil
- "Indicator for emerge-mode.")
(emerge-defvar-local emerge-fast-mode nil
"Indicator for emerge-mode fast submode.")
(emerge-defvar-local emerge-edit-mode nil
@@ -556,7 +538,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(if temp
(setq file-A temp
startup-hooks
- (cons `(lambda () (delete-file ,file-A))
+ (cons (lambda () (delete-file file-A))
startup-hooks))
;; Verify that the file matches the buffer
(emerge-verify-file-buffer))))
@@ -567,7 +549,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(if temp
(setq file-B temp
startup-hooks
- (cons `(lambda () (delete-file ,file-B))
+ (cons (lambda () (delete-file file-B))
startup-hooks))
;; Verify that the file matches the buffer
(emerge-verify-file-buffer))))
@@ -584,48 +566,49 @@ This is *not* a user option, since Emerge uses it for its own processing.")
;; create the merge buffer from buffer A, so it inherits buffer A's
;; default directory, etc.
(merge-buffer (with-current-buffer
- buffer-A
- (get-buffer-create merge-buffer-name))))
+ buffer-A
+ (get-buffer-create merge-buffer-name))))
(with-current-buffer
- merge-buffer
- (emerge-copy-modes buffer-A)
- (setq buffer-read-only nil)
- (auto-save-mode 1)
- (setq emerge-mode t)
- (setq emerge-A-buffer buffer-A)
- (setq emerge-B-buffer buffer-B)
- (setq emerge-ancestor-buffer nil)
- (setq emerge-merge-buffer merge-buffer)
- (setq emerge-output-description
- (if output-file
- (concat "Output to file: " output-file)
- (concat "Output to buffer: " (buffer-name merge-buffer))))
- (save-excursion (insert-buffer-substring emerge-A-buffer))
- (emerge-set-keys)
- (setq emerge-difference-list (emerge-make-diff-list file-A file-B))
- (setq emerge-number-of-differences (length emerge-difference-list))
- (setq emerge-current-difference -1)
- (setq emerge-quit-hook quit-hooks)
- (emerge-remember-buffer-characteristics)
- (emerge-handle-local-variables))
+ merge-buffer
+ (emerge-copy-modes buffer-A)
+ (setq buffer-read-only nil)
+ (auto-save-mode 1)
+ (setq emerge-mode t)
+ (setq emerge-A-buffer buffer-A)
+ (setq emerge-B-buffer buffer-B)
+ (setq emerge-ancestor-buffer nil)
+ (setq emerge-merge-buffer merge-buffer)
+ (setq emerge-output-description
+ (if output-file
+ (concat "Output to file: " output-file)
+ (concat "Output to buffer: " (buffer-name merge-buffer))))
+ (save-excursion (insert-buffer-substring emerge-A-buffer))
+ (emerge-set-keys)
+ (setq emerge-difference-list (emerge-make-diff-list file-A file-B))
+ (setq emerge-number-of-differences (length emerge-difference-list))
+ (setq emerge-current-difference -1)
+ (setq emerge-quit-hook quit-hooks)
+ (emerge-remember-buffer-characteristics)
+ (emerge-handle-local-variables))
(emerge-setup-windows buffer-A buffer-B merge-buffer t)
(with-current-buffer merge-buffer
- (run-hooks 'startup-hooks 'emerge-startup-hook)
- (setq buffer-read-only t))))
+ (mapc #'funcall startup-hooks)
+ (run-hooks 'emerge-startup-hook)
+ (setq buffer-read-only t))))
;; Generate the Emerge difference list between two files
(defun emerge-make-diff-list (file-A file-B)
(setq emerge-diff-buffer (get-buffer-create "*emerge-diff*"))
(with-current-buffer
- emerge-diff-buffer
- (erase-buffer)
- (shell-command
- (format "%s %s %s %s"
- (shell-quote-argument emerge-diff-program)
- emerge-diff-options
- (shell-quote-argument file-A)
- (shell-quote-argument file-B))
- t))
+ emerge-diff-buffer
+ (erase-buffer)
+ (shell-command
+ (format "%s %s %s %s"
+ (shell-quote-argument emerge-diff-program)
+ emerge-diff-options
+ (shell-quote-argument file-A)
+ (shell-quote-argument file-B))
+ t))
(emerge-prepare-error-list emerge-diff-ok-lines-regexp)
(emerge-convert-diffs-to-markers
emerge-A-buffer emerge-B-buffer emerge-merge-buffer
@@ -711,7 +694,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(if temp
(setq file-A temp
startup-hooks
- (cons `(lambda () (delete-file ,file-A))
+ (cons (lambda () (delete-file file-A))
startup-hooks))
;; Verify that the file matches the buffer
(emerge-verify-file-buffer))))
@@ -722,7 +705,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(if temp
(setq file-B temp
startup-hooks
- (cons `(lambda () (delete-file ,file-B))
+ (cons (lambda () (delete-file file-B))
startup-hooks))
;; Verify that the file matches the buffer
(emerge-verify-file-buffer))))
@@ -733,7 +716,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(if temp
(setq file-ancestor temp
startup-hooks
- (cons `(lambda () (delete-file ,file-ancestor))
+ (cons (lambda () (delete-file file-ancestor))
startup-hooks))
;; Verify that the file matches the buffer
(emerge-verify-file-buffer))))
@@ -746,6 +729,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
buffer-ancestor file-ancestor
&optional startup-hooks quit-hooks
output-file)
+ ;; FIXME: Duplicated code!
(setq file-A (expand-file-name file-A))
(setq file-B (expand-file-name file-B))
(setq file-ancestor (expand-file-name file-ancestor))
@@ -754,36 +738,37 @@ This is *not* a user option, since Emerge uses it for its own processing.")
;; create the merge buffer from buffer A, so it inherits buffer A's
;; default directory, etc.
(merge-buffer (with-current-buffer
- buffer-A
- (get-buffer-create merge-buffer-name))))
+ buffer-A
+ (get-buffer-create merge-buffer-name))))
(with-current-buffer
- merge-buffer
- (emerge-copy-modes buffer-A)
- (setq buffer-read-only nil)
- (auto-save-mode 1)
- (setq emerge-mode t)
- (setq emerge-A-buffer buffer-A)
- (setq emerge-B-buffer buffer-B)
- (setq emerge-ancestor-buffer buffer-ancestor)
- (setq emerge-merge-buffer merge-buffer)
- (setq emerge-output-description
- (if output-file
- (concat "Output to file: " output-file)
- (concat "Output to buffer: " (buffer-name merge-buffer))))
- (save-excursion (insert-buffer-substring emerge-A-buffer))
- (emerge-set-keys)
- (setq emerge-difference-list
- (emerge-make-diff3-list file-A file-B file-ancestor))
- (setq emerge-number-of-differences (length emerge-difference-list))
- (setq emerge-current-difference -1)
- (setq emerge-quit-hook quit-hooks)
- (emerge-remember-buffer-characteristics)
- (emerge-select-prefer-Bs)
- (emerge-handle-local-variables))
+ merge-buffer
+ (emerge-copy-modes buffer-A)
+ (setq buffer-read-only nil)
+ (auto-save-mode 1)
+ (setq emerge-mode t)
+ (setq emerge-A-buffer buffer-A)
+ (setq emerge-B-buffer buffer-B)
+ (setq emerge-ancestor-buffer buffer-ancestor)
+ (setq emerge-merge-buffer merge-buffer)
+ (setq emerge-output-description
+ (if output-file
+ (concat "Output to file: " output-file)
+ (concat "Output to buffer: " (buffer-name merge-buffer))))
+ (save-excursion (insert-buffer-substring emerge-A-buffer))
+ (emerge-set-keys)
+ (setq emerge-difference-list
+ (emerge-make-diff3-list file-A file-B file-ancestor))
+ (setq emerge-number-of-differences (length emerge-difference-list))
+ (setq emerge-current-difference -1)
+ (setq emerge-quit-hook quit-hooks)
+ (emerge-remember-buffer-characteristics)
+ (emerge-select-prefer-Bs)
+ (emerge-handle-local-variables))
(emerge-setup-windows buffer-A buffer-B merge-buffer t)
(with-current-buffer merge-buffer
- (run-hooks 'startup-hooks 'emerge-startup-hook)
- (setq buffer-read-only t))))
+ (mapc #'funcall startup-hooks)
+ (run-hooks 'emerge-startup-hook)
+ (setq buffer-read-only t))))
;; Generate the Emerge difference list between two files with an ancestor
(defun emerge-make-diff3-list (file-A file-B file-ancestor)
@@ -872,7 +857,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(emerge-read-file-name "Output file" emerge-last-dir-output
f f nil)))))
(if file-out
- (add-hook 'quit-hooks `(lambda () (emerge-files-exit ,file-out))))
+ (push (lambda () (emerge-files-exit file-out)) quit-hooks))
(emerge-files-internal
file-A file-B startup-hooks
quit-hooks
@@ -894,7 +879,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(emerge-read-file-name "Output file" emerge-last-dir-output
f f nil)))))
(if file-out
- (add-hook 'quit-hooks `(lambda () (emerge-files-exit ,file-out))))
+ (push (lambda () (emerge-files-exit file-out)) quit-hooks))
(emerge-files-with-ancestor-internal
file-A file-B file-ancestor startup-hooks
quit-hooks
@@ -922,9 +907,9 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(write-region (point-min) (point-max) emerge-file-B nil 'no-message))
(emerge-setup (get-buffer buffer-A) emerge-file-A
(get-buffer buffer-B) emerge-file-B
- (cons `(lambda ()
- (delete-file ,emerge-file-A)
- (delete-file ,emerge-file-B))
+ (cons (lambda ()
+ (delete-file emerge-file-A)
+ (delete-file emerge-file-B))
startup-hooks)
quit-hooks
nil)))
@@ -953,11 +938,10 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(get-buffer buffer-B) emerge-file-B
(get-buffer buffer-ancestor)
emerge-file-ancestor
- (cons `(lambda ()
- (delete-file ,emerge-file-A)
- (delete-file ,emerge-file-B)
- (delete-file
- ,emerge-file-ancestor))
+ (cons (lambda ()
+ (delete-file emerge-file-A)
+ (delete-file emerge-file-B)
+ (delete-file emerge-file-ancestor))
startup-hooks)
quit-hooks
nil)))
@@ -972,7 +956,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(setq command-line-args-left (nthcdr 3 command-line-args-left))
(emerge-files-internal
file-a file-b nil
- (list `(lambda () (emerge-command-exit ,file-out))))))
+ (list (lambda () (emerge-command-exit file-out))))))
;;;###autoload
(defun emerge-files-with-ancestor-command ()
@@ -994,7 +978,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(setq command-line-args-left (nthcdr 4 command-line-args-left)))
(emerge-files-with-ancestor-internal
file-a file-b file-anc nil
- (list `(lambda () (emerge-command-exit ,file-out))))))
+ (list (lambda () (emerge-command-exit file-out))))))
(defun emerge-command-exit (file-out)
(emerge-write-and-delete file-out)
@@ -1007,7 +991,8 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(setq emerge-file-out file-out)
(emerge-files-internal
file-a file-b nil
- (list `(lambda () (emerge-remote-exit ,file-out ',emerge-exit-func)))
+ (let ((f emerge-exit-func))
+ (list (lambda () (emerge-remote-exit file-out f))))
file-out)
(throw 'client-wait nil))
@@ -1016,14 +1001,15 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(setq emerge-file-out file-out)
(emerge-files-with-ancestor-internal
file-a file-b file-anc nil
- (list `(lambda () (emerge-remote-exit ,file-out ',emerge-exit-func)))
+ (let ((f emerge-exit-func))
+ (list (lambda () (emerge-remote-exit file-out f))))
file-out)
(throw 'client-wait nil))
-(defun emerge-remote-exit (file-out emerge-exit-func)
+(defun emerge-remote-exit (file-out exit-func)
(emerge-write-and-delete file-out)
(kill-buffer emerge-merge-buffer)
- (funcall emerge-exit-func (if emerge-prefix-argument 1 0)))
+ (funcall exit-func (if emerge-prefix-argument 1 0)))
;;; Functions to start Emerge on RCS versions
@@ -1041,10 +1027,9 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(emerge-revisions-internal
file revision-A revision-B startup-hooks
(if arg
- (cons `(lambda ()
- (shell-command
- ,(format "%s %s" emerge-rcs-ci-program file)))
- quit-hooks)
+ (let ((cmd (format "%s %s" emerge-rcs-ci-program file)))
+ (cons (lambda () (shell-command cmd))
+ quit-hooks))
quit-hooks)))
;;;###autoload
@@ -1065,12 +1050,10 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(emerge-revision-with-ancestor-internal
file revision-A revision-B ancestor startup-hooks
(if arg
- (let ((cmd ))
- (cons `(lambda ()
- (shell-command
- ,(format "%s %s" emerge-rcs-ci-program file)))
+ (let ((cmd (format "%s %s" emerge-rcs-ci-program file)))
+ (cons (lambda () (shell-command cmd))
quit-hooks))
- quit-hooks)))
+ quit-hooks)))
(defun emerge-revisions-internal (file revision-A revision-B &optional
startup-hooks quit-hooks _output-file)
@@ -1098,11 +1081,11 @@ This is *not* a user option, since Emerge uses it for its own processing.")
;; Do the merge
(emerge-setup buffer-A emerge-file-A
buffer-B emerge-file-B
- (cons `(lambda ()
- (delete-file ,emerge-file-A)
- (delete-file ,emerge-file-B))
+ (cons (lambda ()
+ (delete-file emerge-file-A)
+ (delete-file emerge-file-B))
startup-hooks)
- (cons `(lambda () (emerge-files-exit ,file))
+ (cons (lambda () (emerge-files-exit file))
quit-hooks)
nil)))
@@ -1146,12 +1129,12 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(emerge-setup-with-ancestor
buffer-A emerge-file-A buffer-B emerge-file-B
buffer-ancestor emerge-ancestor
- (cons `(lambda ()
- (delete-file ,emerge-file-A)
- (delete-file ,emerge-file-B)
- (delete-file ,emerge-ancestor))
+ (cons (lambda ()
+ (delete-file emerge-file-A)
+ (delete-file emerge-file-B)
+ (delete-file emerge-ancestor))
startup-hooks)
- (cons `(lambda () (emerge-files-exit ,file))
+ (cons (lambda () (emerge-files-exit file))
quit-hooks)
output-file)))
@@ -1233,20 +1216,20 @@ Otherwise, the A or B file present is copied to the output file."
file-ancestor file-out
nil
;; When done, return to this buffer.
- (list
- `(lambda ()
- (switch-to-buffer ,(current-buffer))
- (message "Merge done.")))))
+ (let ((buf (current-buffer)))
+ (list (lambda ()
+ (switch-to-buffer buf)
+ (message "Merge done"))))))
;; Merge of two files without ancestor
((and file-A file-B)
(message "Merging %s and %s..." file-A file-B)
(emerge-files (not (not file-out)) file-A file-B file-out
nil
;; When done, return to this buffer.
- (list
- `(lambda ()
- (switch-to-buffer ,(current-buffer))
- (message "Merge done.")))))
+ (let ((buf (current-buffer)))
+ (list (lambda ()
+ (switch-to-buffer buf)
+ (message "Merge done"))))))
;; There is an output file (or there would have been an error above),
;; but only one input file.
;; The file appears to have been deleted in one version; do nothing.
@@ -1456,9 +1439,8 @@ These characteristics are restored by `emerge-restore-buffer-characteristics'."
merge-buffer
lineno-list)
(let* (marker-list
- (A-point-min (with-current-buffer A-buffer (point-min)))
- (offset (1- A-point-min))
- (B-point-min (with-current-buffer B-buffer (point-min)))
+ (offset (with-current-buffer A-buffer
+ (- (point-min) (save-restriction (widen) (point-min)))))
;; Record current line number in each buffer
;; so we don't have to count from the beginning.
(a-line 1)
@@ -1480,17 +1462,17 @@ These characteristics are restored by `emerge-restore-buffer-characteristics'."
(state (aref list-element 4)))
;; place markers at the appropriate places in the buffers
(with-current-buffer
- A-buffer
- (setq a-line (emerge-goto-line a-begin a-line))
- (setq a-begin-marker (point-marker))
- (setq a-line (emerge-goto-line a-end a-line))
- (setq a-end-marker (point-marker)))
+ A-buffer
+ (setq a-line (emerge-goto-line a-begin a-line))
+ (setq a-begin-marker (point-marker))
+ (setq a-line (emerge-goto-line a-end a-line))
+ (setq a-end-marker (point-marker)))
(with-current-buffer
- B-buffer
- (setq b-line (emerge-goto-line b-begin b-line))
- (setq b-begin-marker (point-marker))
- (setq b-line (emerge-goto-line b-end b-line))
- (setq b-end-marker (point-marker)))
+ B-buffer
+ (setq b-line (emerge-goto-line b-begin b-line))
+ (setq b-begin-marker (point-marker))
+ (setq b-line (emerge-goto-line b-end b-line))
+ (setq b-end-marker (point-marker)))
(setq merge-begin-marker (set-marker
(make-marker)
(- (marker-position a-begin-marker)
@@ -1502,15 +1484,15 @@ These characteristics are restored by `emerge-restore-buffer-characteristics'."
offset)
merge-buffer))
;; record all the markers for this difference
- (setq marker-list (cons (vector a-begin-marker a-end-marker
- b-begin-marker b-end-marker
- merge-begin-marker merge-end-marker
- state)
- marker-list)))
+ (push (vector a-begin-marker a-end-marker
+ b-begin-marker b-end-marker
+ merge-begin-marker merge-end-marker
+ state)
+ marker-list))
(setq lineno-list (cdr lineno-list)))
;; convert the list of difference information into a vector for
;; fast access
- (setq emerge-difference-list (apply 'vector (nreverse marker-list)))))
+ (setq emerge-difference-list (apply #'vector (nreverse marker-list)))))
;; If we have an ancestor, select all B variants that we prefer
(defun emerge-select-prefer-Bs ()
@@ -1636,7 +1618,7 @@ the height of the merge window.
`C-u -' alone as argument scrolls half the height of the merge window."
(interactive "P")
(emerge-operate-on-windows
- 'scroll-up
+ #'scroll-up
;; calculate argument to scroll-up
;; if there is an explicit argument
(if (and arg (not (equal arg '-)))
@@ -1663,7 +1645,7 @@ the height of the merge window.
`C-u -' alone as argument scrolls half the height of the merge window."
(interactive "P")
(emerge-operate-on-windows
- 'scroll-down
+ #'scroll-down
;; calculate argument to scroll-down
;; if there is an explicit argument
(if (and arg (not (equal arg '-)))
@@ -1690,7 +1672,7 @@ the width of the A and B windows. `C-u -' alone as argument scrolls half the
width of the A and B windows."
(interactive "P")
(emerge-operate-on-windows
- 'scroll-left
+ #'scroll-left
;; calculate argument to scroll-left
;; if there is an explicit argument
(if (and arg (not (equal arg '-)))
@@ -1718,7 +1700,7 @@ the width of the A and B windows. `C-u -' alone as argument scrolls half the
width of the A and B windows."
(interactive "P")
(emerge-operate-on-windows
- 'scroll-right
+ #'scroll-right
;; calculate argument to scroll-right
;; if there is an explicit argument
(if (and arg (not (equal arg '-)))
@@ -1745,18 +1727,18 @@ This resets the horizontal scrolling of all three merge buffers
to the left margin, if they are in windows."
(interactive)
(emerge-operate-on-windows
- (lambda (x) (set-window-hscroll (selected-window) 0))
+ (lambda (_) (set-window-hscroll (selected-window) 0))
nil))
-;; Attempt to show the region nicely.
-;; If there are min-lines lines above and below the region, then don't do
-;; anything.
-;; If not, recenter the region to make it so.
-;; If that isn't possible, remove context lines evenly from top and bottom
-;; so the entire region shows.
-;; If that isn't possible, show the top of the region.
-;; BEG must be at the beginning of a line.
(defun emerge-position-region (beg end pos)
+ "Attempt to show the region nicely.
+If there are min-lines lines above and below the region, then don't do
+anything.
+If not, recenter the region to make it so.
+If that isn't possible, remove context lines evenly from top and bottom
+so the entire region shows.
+If that isn't possible, show the top of the region.
+BEG must be at the beginning of a line."
;; First test whether the entire region is visible with
;; emerge-min-visible-lines above and below it
(if (not (and (<= (progn
@@ -1795,7 +1777,7 @@ to the left margin, if they are in windows."
(memq (aref (aref emerge-difference-list n) 6)
'(prefer-A prefer-B)))
(setq n (1+ n)))
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(emerge-unselect-and-select-difference n)))
(error "At end")))
@@ -1809,14 +1791,14 @@ to the left margin, if they are in windows."
(memq (aref (aref emerge-difference-list n) 6)
'(prefer-A prefer-B)))
(setq n (1- n)))
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(emerge-unselect-and-select-difference n)))
(error "At beginning")))
(defun emerge-jump-to-difference (difference-number)
"Go to the N-th difference."
(interactive "p")
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(setq difference-number (1- difference-number))
(if (and (>= difference-number -1)
(< difference-number (1+ emerge-number-of-differences)))
@@ -1878,6 +1860,13 @@ buffer after this will cause serious problems."
(let ((emerge-prefix-argument arg))
(run-hooks 'emerge-quit-hook)))
+(defmacro emerge--current-beg (diff-vector side)
+ ;; +1 because emerge-place-flags-in-buffer1 moved the marker by 1.
+ `(1+ (aref ,diff-vector ,(pcase-exhaustive side ('A 0) ('B 2) ('merge 4)))))
+(defmacro emerge--current-end (diff-vector side)
+ ;; -1 because emerge-place-flags-in-buffer1 moved the marker by 1.
+ `(1- (aref ,diff-vector ,(pcase-exhaustive side ('A 1) ('B 3) ('merge 5)))))
+
(defun emerge-select-A (&optional force)
"Select the A variant of this difference.
Refuses to function if this difference has been edited, i.e., if it
@@ -1885,26 +1874,25 @@ is neither the A nor the B variant.
A prefix argument forces the variant to be selected
even if the difference has been edited."
(interactive "P")
- (let ((operate
- (lambda ()
- (emerge-select-A-edit merge-begin merge-end A-begin A-end)
- (if emerge-auto-advance
- (emerge-next-difference))))
+ (let ((operate #'emerge-select-A-edit)
(operate-no-change
- (lambda () (if emerge-auto-advance
- (emerge-next-difference)))))
+ (lambda (_diff-vector)
+ (if emerge-auto-advance (emerge-next-difference)))))
(emerge-select-version force operate-no-change operate operate)))
;; Actually select the A variant
-(defun emerge-select-A-edit (merge-begin merge-end A-begin A-end)
+(defun emerge-select-A-edit (diff-vector)
(with-current-buffer
- emerge-merge-buffer
- (delete-region merge-begin merge-end)
- (goto-char merge-begin)
- (insert-buffer-substring emerge-A-buffer A-begin A-end)
- (goto-char merge-begin)
- (aset diff-vector 6 'A)
- (emerge-refresh-mode-line)))
+ emerge-merge-buffer
+ (goto-char (emerge--current-beg diff-vector merge))
+ (delete-region (point) (emerge--current-end diff-vector merge))
+ (save-excursion
+ (insert-buffer-substring emerge-A-buffer
+ (emerge--current-beg diff-vector A)
+ (emerge--current-end diff-vector A)))
+ (aset diff-vector 6 'A)
+ (emerge-refresh-mode-line)
+ (if emerge-auto-advance (emerge-next-difference))))
(defun emerge-select-B (&optional force)
"Select the B variant of this difference.
@@ -1913,26 +1901,25 @@ is neither the A nor the B variant.
A prefix argument forces the variant to be selected
even if the difference has been edited."
(interactive "P")
- (let ((operate
- (lambda ()
- (emerge-select-B-edit merge-begin merge-end B-begin B-end)
- (if emerge-auto-advance
- (emerge-next-difference))))
+ (let ((operate #'emerge-select-B-edit)
(operate-no-change
- (lambda () (if emerge-auto-advance
- (emerge-next-difference)))))
+ (lambda (_diff-vector)
+ (if emerge-auto-advance (emerge-next-difference)))))
(emerge-select-version force operate operate-no-change operate)))
;; Actually select the B variant
-(defun emerge-select-B-edit (merge-begin merge-end B-begin B-end)
+(defun emerge-select-B-edit (diff-vector)
(with-current-buffer
- emerge-merge-buffer
- (delete-region merge-begin merge-end)
- (goto-char merge-begin)
- (insert-buffer-substring emerge-B-buffer B-begin B-end)
- (goto-char merge-begin)
- (aset diff-vector 6 'B)
- (emerge-refresh-mode-line)))
+ emerge-merge-buffer
+ (goto-char (emerge--current-beg diff-vector merge))
+ (delete-region (point) (emerge--current-end diff-vector merge))
+ (save-excursion
+ (insert-buffer-substring emerge-B-buffer
+ (emerge--current-beg diff-vector B)
+ (emerge--current-end diff-vector B)))
+ (aset diff-vector 6 'B)
+ (emerge-refresh-mode-line)
+ (if emerge-auto-advance (emerge-next-difference))))
(defun emerge-default-A ()
"Make the A variant the default from here down.
@@ -1940,7 +1927,7 @@ This selects the A variant for all differences from here down in the buffer
which are still defaulted, i.e., which the user has not selected and for
which there is no preference."
(interactive)
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(let ((selected-difference emerge-current-difference)
(n (max emerge-current-difference 0)))
(while (< n emerge-number-of-differences)
@@ -1962,7 +1949,7 @@ This selects the B variant for all differences from here down in the buffer
which are still defaulted, i.e., which the user has not selected and for
which there is no preference."
(interactive)
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(let ((selected-difference emerge-current-difference)
(n (max emerge-current-difference 0)))
(while (< n emerge-number-of-differences)
@@ -2071,7 +2058,7 @@ With prefix argument, puts point before, mark after."
(A-begin (1+ (aref diff-vector 0)))
(A-end (1- (aref diff-vector 1)))
(opoint (point))
- (buffer-read-only nil))
+ (inhibit-read-only t))
(insert-buffer-substring emerge-A-buffer A-begin A-end)
(if (not arg)
(set-mark opoint)
@@ -2089,7 +2076,7 @@ With prefix argument, puts point before, mark after."
(B-begin (1+ (aref diff-vector 2)))
(B-end (1- (aref diff-vector 3)))
(opoint (point))
- (buffer-read-only nil))
+ (inhibit-read-only t))
(insert-buffer-substring emerge-B-buffer B-begin B-end)
(if (not arg)
(set-mark opoint)
@@ -2450,28 +2437,28 @@ the nearest previous difference."
(1- index)
(error "No difference contains or precedes point")))))))
+(defvar emerge-line-diff)
+
(defun emerge-line-numbers ()
"Display the current line numbers.
This function displays the line numbers of the points in the A, B, and
merge buffers."
(interactive)
(let* ((valid-diff
- (and (>= emerge-current-difference 0)
- (< emerge-current-difference emerge-number-of-differences)))
+ (and (>= emerge-current-difference 0)
+ (< emerge-current-difference emerge-number-of-differences)))
(emerge-line-diff (and valid-diff
(aref emerge-difference-list
emerge-current-difference)))
- (merge-line (emerge-line-number-in-buf 4 5))
+ (merge-line (emerge-line-number-in-buf valid-diff 4 5))
(A-line (with-current-buffer emerge-A-buffer
- (emerge-line-number-in-buf 0 1)))
+ (emerge-line-number-in-buf valid-diff 0 1)))
(B-line (with-current-buffer emerge-B-buffer
- (emerge-line-number-in-buf 2 3))))
+ (emerge-line-number-in-buf valid-diff 2 3))))
(message "At lines: merge = %d, A = %d, B = %d"
merge-line A-line B-line)))
-(defvar emerge-line-diff)
-
-(defun emerge-line-number-in-buf (begin-marker end-marker)
+(defun emerge-line-number-in-buf (valid-diff begin-marker end-marker)
;; FIXME point-min rather than 1? widen?
(let ((temp (1+ (count-lines 1 (line-beginning-position)))))
(if valid-diff
@@ -2537,46 +2524,41 @@ Interactively, reads the register using `register-read-with-preview'."
(error "Register does not contain text"))
(emerge-combine-versions-internal template force)))
-(defun emerge-combine-versions-internal (emerge-combine-template force)
- (let ((operate
- (lambda ()
- (emerge-combine-versions-edit merge-begin merge-end
- A-begin A-end B-begin B-end)
- (if emerge-auto-advance
- (emerge-next-difference)))))
+(defun emerge-combine-versions-internal (combine-template force)
+ (let ((operate (lambda (diff-vector)
+ (emerge-combine-versions-edit diff-vector
+ combine-template))))
(emerge-select-version force operate operate operate)))
-(defvar emerge-combine-template)
-
-(defun emerge-combine-versions-edit (merge-begin merge-end
- A-begin A-end B-begin B-end)
+(defun emerge-combine-versions-edit (diff-vector combine-template)
(with-current-buffer
- emerge-merge-buffer
- (delete-region merge-begin merge-end)
- (goto-char merge-begin)
- (let ((i 0))
- (while (< i (length emerge-combine-template))
- (let ((c (aref emerge-combine-template i)))
- (if (= c ?%)
- (progn
- (setq i (1+ i))
- (setq c
- (condition-case nil
- (aref emerge-combine-template i)
- (error ?%)))
- (cond ((= c ?a)
- (insert-buffer-substring emerge-A-buffer A-begin A-end))
- ((= c ?b)
- (insert-buffer-substring emerge-B-buffer B-begin B-end))
- ((= c ?%)
- (insert ?%))
- (t
- (insert c))))
- (insert c)))
- (setq i (1+ i))))
- (goto-char merge-begin)
- (aset diff-vector 6 'combined)
- (emerge-refresh-mode-line)))
+ emerge-merge-buffer
+ (goto-char (emerge--current-beg diff-vector merge))
+ (delete-region (point) (emerge--current-end diff-vector merge))
+ (save-excursion
+ (let ((i 0))
+ (while (< i (length combine-template))
+ (let ((c (aref combine-template i)))
+ (if (not (= c ?%))
+ (insert c)
+ (setq i (1+ i))
+ (pcase (condition-case nil
+ (aref combine-template i)
+ (error ?%))
+ (?a
+ (insert-buffer-substring emerge-A-buffer
+ (emerge--current-beg diff-vector A)
+ (emerge--current-end diff-vector A)))
+ (?b
+ (insert-buffer-substring emerge-B-buffer
+ (emerge--current-beg diff-vector B)
+ (emerge--current-end diff-vector B)))
+ (?% (insert ?%))
+ (c (insert c)))))
+ (setq i (1+ i)))))
+ (aset diff-vector 6 'combined)
+ (emerge-refresh-mode-line)
+ (if emerge-auto-advance (emerge-next-difference))))
(defun emerge-set-merge-mode (mode)
"Set the major mode in a merge buffer.
@@ -2617,7 +2599,7 @@ keymap. Leaves merge in fast mode."
(emerge-place-flags-in-buffer1 difference before-index after-index)))
(defun emerge-place-flags-in-buffer1 (difference before-index after-index)
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
;; insert the flag before the difference
(let ((before (aref (aref emerge-globalized-difference-list difference)
before-index))
@@ -2682,7 +2664,7 @@ keymap. Leaves merge in fast mode."
(defun emerge-remove-flags-in-buffer (buffer before after)
(with-current-buffer
buffer
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
;; remove the flags, if they're there
(goto-char (- before (1- emerge-before-flag-length)))
(if (looking-at emerge-before-flag-match)
@@ -2717,18 +2699,18 @@ keymap. Leaves merge in fast mode."
(emerge-recenter)
(emerge-refresh-mode-line))))
-;; Perform tests to see whether user should be allowed to select a version
-;; of this difference:
-;; a valid difference has been selected; and
-;; the difference text in the merge buffer is:
-;; the A version (execute a-version), or
-;; the B version (execute b-version), or
-;; empty (execute neither-version), or
-;; argument FORCE is true (execute neither-version)
-;; Otherwise, signal an error.
(defun emerge-select-version (force a-version b-version neither-version)
+ "Perform tests to see whether user should be allowed to select a version
+of this difference:
+ a valid difference has been selected; and
+ the difference text in the merge buffer is:
+ the A version (execute a-version), or
+ the B version (execute b-version), or
+ empty (execute neither-version), or
+ argument FORCE is true (execute neither-version)
+Otherwise, signal an error."
(emerge-validate-difference)
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(let* ((diff-vector
(aref emerge-difference-list emerge-current-difference))
(A-begin (1+ (aref diff-vector 0)))
@@ -2740,13 +2722,13 @@ keymap. Leaves merge in fast mode."
(if (emerge-compare-buffers emerge-A-buffer A-begin A-end
emerge-merge-buffer merge-begin
merge-end)
- (funcall a-version)
+ (funcall a-version diff-vector)
(if (emerge-compare-buffers emerge-B-buffer B-begin B-end
emerge-merge-buffer merge-begin
merge-end)
- (funcall b-version)
+ (funcall b-version diff-vector)
(if (or force (= merge-begin merge-end))
- (funcall neither-version)
+ (funcall neither-version diff-vector)
(error "This difference region has been edited")))))))
;; Read a file name, handling all of the various defaulting rules.
@@ -2972,78 +2954,6 @@ If some prefix of KEY has a non-prefix definition, it is redefined."
;; Now define the key
(define-key keymap key definition))
-;;;;; Improvements to describe-mode, so that it describes minor modes as well
-;;;;; as the major mode
-;;(defun describe-mode (&optional minor)
-;; "Display documentation of current major mode.
-;;If optional arg MINOR is non-nil (or prefix argument is given if interactive),
-;;display documentation of active minor modes as well.
-;;For this to work correctly for a minor mode, the mode's indicator variable
-;;\(listed in `minor-mode-alist') must also be a function whose documentation
-;;describes the minor mode."
-;; (interactive)
-;; (with-output-to-temp-buffer "*Help*"
-;; (princ mode-name)
-;; (princ " Mode:\n")
-;; (princ (documentation major-mode))
-;; (let ((minor-modes minor-mode-alist)
-;; (locals (buffer-local-variables)))
-;; (while minor-modes
-;; (let* ((minor-mode (car (car minor-modes)))
-;; (indicator (car (cdr (car minor-modes))))
-;; (local-binding (assq minor-mode locals)))
-;; ;; Document a minor mode if it is listed in minor-mode-alist,
-;; ;; bound locally in this buffer, non-nil, and has a function
-;; ;; definition.
-;; (if (and local-binding
-;; (cdr local-binding)
-;; (fboundp minor-mode))
-;; (progn
-;; (princ (format "\n\n\n%s minor mode (indicator%s):\n"
-;; minor-mode indicator))
-;; (princ (documentation minor-mode)))))
-;; (setq minor-modes (cdr minor-modes))))
-;; (with-current-buffer standard-output
-;; (help-mode))
-;; (help-print-return-message)))
-
-;; This goes with the redefinition of describe-mode.
-;;;; Adjust things so that keyboard macro definitions are documented correctly.
-;;(fset 'defining-kbd-macro (symbol-function 'start-kbd-macro))
-
-;; substitute-key-definition should work now.
-;;;; Function to shadow a definition in a keymap with definitions in another.
-;;(defun emerge-shadow-key-definition (olddef newdef keymap shadowmap)
-;; "Shadow OLDDEF with NEWDEF for any keys in KEYMAP with entries in SHADOWMAP.
-;;In other words, SHADOWMAP will now shadow all definitions of OLDDEF in KEYMAP
-;;with NEWDEF. Does not affect keys that are already defined in SHADOWMAP,
-;;including those whose definition is OLDDEF."
-;; ;; loop through all keymaps accessible from keymap
-;; (let ((maps (accessible-keymaps keymap)))
-;; (while maps
-;; (let ((prefix (car (car maps)))
-;; (map (cdr (car maps))))
-;; ;; examine a keymap
-;; (if (arrayp map)
-;; ;; array keymap
-;; (let ((len (length map))
-;; (i 0))
-;; (while (< i len)
-;; (if (eq (aref map i) olddef)
-;; ;; set the shadowing definition
-;; (let ((key (concat prefix (char-to-string i))))
-;; (emerge-define-key-if-possible shadowmap key newdef)))
-;; (setq i (1+ i))))
-;; ;; sparse keymap
-;; (while map
-;; (if (eq (cdr-safe (car-safe map)) olddef)
-;; ;; set the shadowing definition
-;; (let ((key
-;; (concat prefix (char-to-string (car (car map))))))
-;; (emerge-define-key-if-possible shadowmap key newdef)))
-;; (setq map (cdr map)))))
-;; (setq maps (cdr maps)))))
-
;; Define a key if it (or a prefix) is not already defined in the map.
(defun emerge-define-key-if-possible (keymap key definition)
;; look up the present definition of the key
@@ -3057,18 +2967,6 @@ If some prefix of KEY has a non-prefix definition, it is redefined."
(if (not present)
(define-key keymap key definition)))))
-;; Ordinary substitute-key-definition should do this now.
-;;(defun emerge-recursively-substitute-key-definition (olddef newdef keymap)
-;; "Like `substitute-key-definition', but act recursively on subkeymaps.
-;;Make sure that subordinate keymaps aren't shared with other keymaps!
-;;\(`copy-keymap' will suffice.)"
-;; ;; Loop through all keymaps accessible from keymap
-;; (let ((maps (accessible-keymaps keymap)))
-;; (while maps
-;; ;; Substitute in this keymap
-;; (substitute-key-definition olddef newdef (cdr (car maps)))
-;; (setq maps (cdr maps)))))
-
;; Show the name of the file in the buffer.
(defun emerge-show-file-name ()
"Displays the name of the file loaded into the current buffer.
diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el
index 963edb49dd3..42710dd8dc9 100644
--- a/lisp/vc/log-edit.el
+++ b/lisp/vc/log-edit.el
@@ -52,7 +52,7 @@
;; The main keymap
(easy-mmode-defmap log-edit-mode-map
- `(("\C-c\C-c" . log-edit-done)
+ '(("\C-c\C-c" . log-edit-done)
("\C-c\C-a" . log-edit-insert-changelog)
("\C-c\C-d" . log-edit-show-diff)
("\C-c\C-f" . log-edit-show-files)
@@ -203,10 +203,7 @@ when this variable is set to nil.")
(defconst log-edit-maximum-comment-ring-size 32
"Maximum number of saved comments in the comment ring.")
-(define-obsolete-variable-alias 'vc-comment-ring 'log-edit-comment-ring "22.1")
(defvar log-edit-comment-ring (make-ring log-edit-maximum-comment-ring-size))
-(define-obsolete-variable-alias 'vc-comment-ring-index
- 'log-edit-comment-ring-index "22.1")
(defvar log-edit-comment-ring-index nil)
(defvar log-edit-last-comment-match "")
@@ -311,13 +308,6 @@ automatically."
(or (eobp) (looking-at "\n\n")
(insert "\n"))))
-;; Compatibility with old names.
-(define-obsolete-function-alias 'vc-previous-comment 'log-edit-previous-comment "22.1")
-(define-obsolete-function-alias 'vc-next-comment 'log-edit-next-comment "22.1")
-(define-obsolete-function-alias 'vc-comment-search-reverse 'log-edit-comment-search-backward "22.1")
-(define-obsolete-function-alias 'vc-comment-search-forward 'log-edit-comment-search-forward "22.1")
-(define-obsolete-function-alias 'vc-comment-to-change-log 'log-edit-comment-to-change-log "22.1")
-
;;;
;;; Actual code
;;;
@@ -360,7 +350,7 @@ The first subexpression is the actual text of the field.")
(defun log-edit-goto-eoh () ;FIXME: Almost rfc822-goto-eoh!
(goto-char (point-min))
(when (re-search-forward
- "^\\([^[:alpha:]]\\|[[:alnum:]-]+[^[:alnum:]-:]\\)" nil 'move)
+ "^\\([^[:alpha:]]\\|[[:alnum:]-]+[^[:alnum:]-]\\)" nil 'move)
(goto-char (match-beginning 0))))
(defun log-edit--match-first-line (limit)
@@ -623,7 +613,7 @@ Also saves its contents in the comment history and hides
(setq buffer-read-only nil)
(erase-buffer)
(cvs-insert-strings files)
- (setq buffer-read-only t)
+ (special-mode)
(goto-char (point-min))
(save-selected-window
(cvs-pop-to-buffer-same-frame buf)
@@ -923,8 +913,10 @@ where LOGBUFFER is the name of the ChangeLog buffer, and each
(setq change-log-default-name nil)
(find-change-log)))))
(when (or (find-buffer-visiting changelog-file-name)
- (file-exists-p changelog-file-name))
- (with-current-buffer (find-file-noselect changelog-file-name)
+ (file-exists-p changelog-file-name)
+ add-log-dont-create-changelog-file)
+ (with-current-buffer
+ (add-log-find-changelog-buffer changelog-file-name)
(unless (eq major-mode 'change-log-mode) (change-log-mode))
(goto-char (point-min))
(if (looking-at "\\s-*\n") (goto-char (match-end 0)))
diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el
index b9f386d5158..e47fad89083 100644
--- a/lisp/vc/log-view.el
+++ b/lisp/vc/log-view.el
@@ -157,7 +157,7 @@
(easy-menu-define log-view-mode-menu log-view-mode-map
"Log-View Display Menu"
- `("Log-View"
+ '("Log-View"
;; XXX Do we need menu entries for these?
;; ["Quit" quit-window]
;; ["Kill This Buffer" kill-this-buffer]
@@ -217,7 +217,7 @@ If it is nil, `log-view-toggle-entry-display' does nothing.")
The match group number 1 should match the file name itself.")
(defvar log-view-per-file-logs t
- "Set if to t if the logs are shown one file at a time.")
+ "Set to t if the logs are shown one file at a time.")
(defvar log-view-message-re
(concat "^\\(?:revision \\(?1:[.0-9]+\\)\\(?:\t.*\\)?" ; RCS and CVS.
@@ -517,8 +517,10 @@ Works like `end-of-defun'."
If called interactively, visit the version at point."
(interactive "d")
(unless log-view-per-file-logs
- (when (> (length log-view-vc-fileset) 1)
- (error "Multiple files shown in this buffer, cannot use this command here")))
+ (when (or (> (length log-view-vc-fileset) 1)
+ (null (car log-view-vc-fileset))
+ (file-directory-p (car log-view-vc-fileset)))
+ (user-error "Multiple files shown in this buffer, cannot use this command here")))
(save-excursion
(goto-char pos)
(switch-to-buffer (vc-find-revision (if log-view-per-file-logs
@@ -561,8 +563,10 @@ If called interactively, visit the version at point."
If called interactively, annotate the version at point."
(interactive "d")
(unless log-view-per-file-logs
- (when (> (length log-view-vc-fileset) 1)
- (error "Multiple files shown in this buffer, cannot use this command here")))
+ (when (or (> (length log-view-vc-fileset) 1)
+ (null (car log-view-vc-fileset))
+ (file-directory-p (car log-view-vc-fileset)))
+ (user-error "Multiple files shown in this buffer, cannot use this command here")))
(save-excursion
(goto-char pos)
(vc-annotate (if log-view-per-file-logs
diff --git a/lisp/vc/pcvs-info.el b/lisp/vc/pcvs-info.el
index 28cfccbf293..224bab314d7 100644
--- a/lisp/vc/pcvs-info.el
+++ b/lisp/vc/pcvs-info.el
@@ -39,9 +39,6 @@
;;;; config variables
;;;;
-(define-obsolete-variable-alias 'cvs-display-full-path
- 'cvs-display-full-name "22.1")
-
(defcustom cvs-display-full-name t
"Specifies how the filenames should be displayed in the listing.
If non-nil, their full filename name will be displayed, else only the
@@ -211,8 +208,6 @@ to confuse some users sometimes."
;; Here, I use `concat' rather than `expand-file-name' because I want
;; the resulting path to stay relative if `dir' is relative.
(concat dir (cvs-fileinfo->file fileinfo)))))
-(define-obsolete-function-alias 'cvs-fileinfo->full-path
- 'cvs-fileinfo->full-name "22.1")
(defun cvs-fileinfo->pp-name (fi)
"Return the filename of FI as it should be displayed."
@@ -268,9 +263,9 @@ to confuse some users sometimes."
(setq check 'type) (symbolp type)
(setq check 'consistency)
(pcase type
- (`DIRCHANGE (and (null subtype) (string= "." file)))
- ((or `NEED-UPDATE `ADDED `MISSING `DEAD `MODIFIED `MESSAGE
- `UP-TO-DATE `REMOVED `NEED-MERGE `CONFLICT `UNKNOWN)
+ ('DIRCHANGE (and (null subtype) (string= "." file)))
+ ((or 'NEED-UPDATE 'ADDED 'MISSING 'DEAD 'MODIFIED 'MESSAGE
+ 'UP-TO-DATE 'REMOVED 'NEED-MERGE 'CONFLICT 'UNKNOWN)
t)))
fi
(error "Invalid :%s in cvs-fileinfo %s" check fi))))
@@ -331,11 +326,11 @@ For use by the ewoc package."
(subtype (cvs-fileinfo->subtype fileinfo)))
(insert
(pcase type
- (`DIRCHANGE (concat "In directory "
+ ('DIRCHANGE (concat "In directory "
(cvs-add-face (cvs-fileinfo->full-name fileinfo)
'cvs-header t 'cvs-goal-column t)
":"))
- (`MESSAGE
+ ('MESSAGE
(cvs-add-face (format "Message: %s" (cvs-fileinfo->full-log fileinfo))
'cvs-msg))
(_
@@ -349,7 +344,7 @@ For use by the ewoc package."
(type
(let ((str (pcase type
;;(MOD-CONFLICT "Not Removed")
- (`DEAD "")
+ ('DEAD "")
(_ (capitalize (symbol-name type)))))
(face (let ((sym (intern-soft
(concat "cvs-fi-"
@@ -456,7 +451,8 @@ DIR can also be a file."
((not (file-exists-p (concat dir f))) (setq type 'MISSING))
((equal rev "0") (setq type 'ADDED rev nil))
((equal date "Result of merge") (setq subtype 'MERGED))
- ((let ((mtime (nth 5 (file-attributes (concat dir f))))
+ ((let ((mtime (file-attribute-modification-time
+ (file-attributes (concat dir f))))
(system-time-locale "C"))
(setq timestamp (format-time-string "%c" mtime t))
;; Solaris sometimes uses "Wed Sep 05", not "Wed Sep 5".
diff --git a/lisp/vc/pcvs-parse.el b/lisp/vc/pcvs-parse.el
index 9525ff93be5..0596ccb9129 100644
--- a/lisp/vc/pcvs-parse.el
+++ b/lisp/vc/pcvs-parse.el
@@ -32,6 +32,7 @@
;;; Code:
+(eval-when-compile (require 'cl-lib))
(require 'pcvs-util)
(require 'pcvs-info)
diff --git a/lisp/vc/pcvs.el b/lisp/vc/pcvs.el
index fafeaaedae6..4679996b35b 100644
--- a/lisp/vc/pcvs.el
+++ b/lisp/vc/pcvs.el
@@ -430,11 +430,11 @@ If non-nil, NEW means to create a new buffer no matter what."
(set-buffer buffer)
(and (cvs-buffer-p)
(pcase cvs-reuse-cvs-buffer
- (`always t)
- (`subdir
+ ('always t)
+ ('subdir
(or (string-prefix-p default-directory dir)
(string-prefix-p dir default-directory)))
- (`samedir (string= default-directory dir)))
+ ('samedir (string= default-directory dir)))
(cl-return buffer)))))
;; we really have to create a new buffer:
;; we temporarily bind cwd to "" to prevent
@@ -700,7 +700,7 @@ OLD-FIS is the list of fileinfos on which the cvs command was applied and
;; because of the call to `process-send-eof'.
(save-excursion
(goto-char (point-min))
- (while (re-search-forward "^\\^D+" nil t)
+ (while (re-search-forward "^\\^D\^H+" nil t)
(let ((inhibit-read-only t))
(delete-region (match-beginning 0) (match-end 0))))))
(let* ((fileinfos (cvs-parse-buffer 'cvs-parse-table dcd subdir))
@@ -876,11 +876,11 @@ RM-MSGS if non-nil means remove messages."
(keep
(pcase type
;; Remove temp messages and keep the others.
- (`MESSAGE (not (or rm-msgs (eq subtype 'TEMP))))
+ ('MESSAGE (not (or rm-msgs (eq subtype 'TEMP))))
;; Remove dead entries.
- (`DEAD nil)
+ ('DEAD nil)
;; Handled also?
- (`UP-TO-DATE
+ ('UP-TO-DATE
(not
(if (find-buffer-visiting (cvs-fileinfo->full-name fi))
(eq rm-handled 'all)
diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el
index cb0083a9851..6b1df6603df 100644
--- a/lisp/vc/smerge-mode.el
+++ b/lisp/vc/smerge-mode.el
@@ -44,7 +44,7 @@
;;; Code:
(eval-when-compile (require 'cl-lib))
-(require 'diff-mode) ;For diff-auto-refine-mode.
+(require 'diff-mode) ;For diff-refine.
(require 'newcomment)
;;; The real definition comes later.
@@ -104,7 +104,6 @@ Used in `smerge-diff-base-upper' and related functions."
(((class color))
:foreground "yellow"))
"Face for the base code.")
-(define-obsolete-face-alias 'smerge-base-face 'smerge-base "22.1")
(defvar smerge-base-face 'smerge-base)
(defface smerge-markers
@@ -113,7 +112,6 @@ Used in `smerge-diff-base-upper' and related functions."
(((background dark))
(:background "grey30")))
"Face for the conflict markers.")
-(define-obsolete-face-alias 'smerge-markers-face 'smerge-markers "22.1")
(defvar smerge-markers-face 'smerge-markers)
(defface smerge-refined-changed
@@ -266,7 +264,7 @@ Can be nil if the style is undecided, or else:
;; Define smerge-next and smerge-prev
(easy-mmode-define-navigation smerge smerge-begin-re "conflict" nil nil
- (if diff-auto-refine-mode
+ (if diff-refine
(condition-case nil (smerge-refine) (error nil))))
(defconst smerge-match-names ["conflict" "upper" "base" "lower"])
@@ -365,9 +363,9 @@ function should only apply safe heuristics) and with the match data set
according to `smerge-match-conflict'.")
(defvar smerge-text-properties
- `(help-echo "merge conflict: mouse-3 shows a menu"
- ;; mouse-face highlight
- keymap (keymap (down-mouse-3 . smerge-popup-context-menu))))
+ '(help-echo "merge conflict: mouse-3 shows a menu"
+ ;; mouse-face highlight
+ keymap (keymap (down-mouse-3 . smerge-popup-context-menu))))
(defun smerge-remove-props (beg end)
(remove-overlays beg end 'smerge 'refine)
@@ -1077,9 +1075,10 @@ used to replace chars to try and eliminate some spurious differences."
(if smerge-refine-weight-hack (make-hash-table :test #'equal))))
(unless (markerp beg1) (setq beg1 (copy-marker beg1)))
(unless (markerp beg2) (setq beg2 (copy-marker beg2)))
- ;; Chop up regions into smaller elements and save into files.
- (smerge--refine-chopup-region beg1 end1 file1 preproc)
- (smerge--refine-chopup-region beg2 end2 file2 preproc)
+ (let ((write-region-inhibit-fsync t)) ; Don't fsync temp files (Bug#12747).
+ ;; Chop up regions into smaller elements and save into files.
+ (smerge--refine-chopup-region beg1 end1 file1 preproc)
+ (smerge--refine-chopup-region beg2 end2 file2 preproc))
;; Call diff on those files.
(unwind-protect
@@ -1400,9 +1399,7 @@ with a \\[universal-argument] prefix, makes up a 3-way conflict."
;;;###autoload
(define-minor-mode smerge-mode
"Minor mode to simplify editing output from the diff3 program.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
+
\\{smerge-mode-map}"
:group 'smerge :lighter " SMerge"
(when (and (boundp 'font-lock-mode) font-lock-mode)
@@ -1435,6 +1432,40 @@ If no conflict maker is found, turn off `smerge-mode'."
(smerge-next))
(error (smerge-auto-leave))))
+(defcustom smerge-change-buffer-confirm t
+ "If non-nil, request confirmation before moving to another buffer."
+ :type 'boolean)
+
+(defun smerge-vc-next-conflict ()
+ "Go to next conflict, possibly in another file.
+First tries to go to the next conflict in the current buffer, and if not
+found, uses VC to try and find the next file with conflict."
+ (interactive)
+ (let ((buffer (current-buffer)))
+ (condition-case nil
+ ;; FIXME: Try again from BOB before moving to the next file.
+ (smerge-next)
+ (error
+ (if (and (or smerge-change-buffer-confirm
+ (and (buffer-modified-p) buffer-file-name))
+ (not (or (eq last-command this-command)
+ (eq ?\r last-command-event)))) ;Called via M-x!?
+ ;; FIXME: Don't emit this message if `vc-find-conflicted-file' won't
+ ;; go to another file anyway (because there are no more conflicted
+ ;; files).
+ (message (if (buffer-modified-p)
+ "No more conflicts here. Repeat to save and go to next buffer"
+ "No more conflicts here. Repeat to go to next buffer"))
+ (if (and (buffer-modified-p) buffer-file-name)
+ (save-buffer))
+ (vc-find-conflicted-file)
+ (if (eq buffer (current-buffer))
+ ;; Do nothing: presumably `vc-find-conflicted-file' already
+ ;; emitted a message explaining there aren't any more conflicts.
+ nil
+ (goto-char (point-min))
+ (smerge-next)))))))
+
(provide 'smerge-mode)
;;; smerge-mode.el ends here
diff --git a/lisp/vc/vc-annotate.el b/lisp/vc/vc-annotate.el
index 86fc8686c39..84838135fcc 100644
--- a/lisp/vc/vc-annotate.el
+++ b/lisp/vc/vc-annotate.el
@@ -541,7 +541,9 @@ Return a cons (REV . FILENAME)."
(setq prev-rev
(vc-call-backend vc-annotate-backend 'previous-revision
fname rev))
- (vc-annotate-warp-revision prev-rev fname)))))
+ (if (not prev-rev)
+ (message "No previous revisions")
+ (vc-annotate-warp-revision prev-rev fname))))))
(defvar log-view-vc-backend)
(defvar log-view-vc-fileset)
diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el
index a33560aa47a..ab5a449cd3d 100644
--- a/lisp/vc/vc-bzr.el
+++ b/lisp/vc/vc-bzr.el
@@ -268,8 +268,8 @@ in the repository root directory of FILE."
;; If file is in dirstate, can only be added (b#8025).
((or (not (match-beginning 4))
(eq (char-after (match-beginning 4)) ?a)) 'added)
- ((or (and (eq (string-to-number (match-string 3))
- (nth 7 (file-attributes file)))
+ ((or (and (eql (string-to-number (match-string 3))
+ (file-attribute-size (file-attributes file)))
(equal (match-string 5)
(save-match-data (vc-bzr-sha1 file)))
;; For a file, does the executable state match?
@@ -281,7 +281,8 @@ in the repository root directory of FILE."
?x
(mapcar
'identity
- (nth 8 (file-attributes file))))))
+ (file-attribute-modes
+ (file-attributes file))))))
(if (eq (char-after (match-beginning 7))
?y)
exe
@@ -291,8 +292,8 @@ in the repository root directory of FILE."
;; checkouts \2 is empty and we need to
;; look for size in \6.
(eq (match-beginning 2) (match-end 2))
- (eq (string-to-number (match-string 6))
- (nth 7 (file-attributes file)))
+ (eql (string-to-number (match-string 6))
+ (file-attribute-size (file-attributes file)))
(equal (match-string 5)
(vc-bzr-sha1 file))))
'up-to-date)
@@ -331,7 +332,7 @@ in the repository root directory of FILE."
(file-relative-name filename* rootdir))))
(defvar vc-bzr-error-regexp-alist
- '(("^\\( M[* ]\\|+N \\|-D \\|\\| \\*\\|R[M ] \\) \\(.+\\)" 2 nil nil 1)
+ '(("^\\( M[* ]\\|\\+N \\|-D \\|\\| \\*\\|R[M ] \\) \\(.+\\)" 2 nil nil 1)
("^C \\(.+\\)" 2)
("^Text conflict in \\(.+\\)" 1 nil nil 2)
("^Using saved parent location: \\(.+\\)" 1 nil nil 0))
@@ -694,7 +695,6 @@ or a superior directory.")
(defvar log-view-message-re)
(defvar log-view-file-re)
(defvar log-view-font-lock-keywords)
-(defvar log-view-current-tag-function)
(defvar log-view-per-file-logs)
(defvar log-view-expanded-log-entry-function)
@@ -782,7 +782,11 @@ If LIMIT is non-nil, show no more than this many entries."
(defun vc-bzr-expanded-log-entry (revision)
(with-temp-buffer
(apply 'vc-bzr-command "log" t nil nil
- (list "--long" (format "-r%s" revision)))
+ (append
+ (list "--long" (format "-r%s" revision))
+ (if (stringp vc-bzr-log-switches)
+ (list vc-bzr-log-switches)
+ vc-bzr-log-switches)))
(goto-char (point-min))
(when (looking-at "^-+\n")
;; Indent the expanded log entry.
@@ -1243,7 +1247,11 @@ stream. Standard error output is discarded."
(let ((vc-bzr-revisions '())
(default-directory (file-name-directory (car files))))
(with-temp-buffer
- (vc-bzr-command "log" t 0 files "--line")
+ (apply 'vc-bzr-command "log" t 0 files
+ (append '("--line")
+ (if (stringp vc-bzr-log-switches)
+ (list vc-bzr-log-switches)
+ vc-bzr-log-switches)))
(let ((start (point-min))
(loglines (buffer-substring-no-properties (point-min) (point-max))))
(while (string-match "^\\([0-9]+\\):" loglines)
diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el
index b4419a4db30..626e190c1e8 100644
--- a/lisp/vc/vc-cvs.el
+++ b/lisp/vc/vc-cvs.el
@@ -57,7 +57,7 @@
;; (We actually shouldn't trust this, but there is
;; no other way to learn this from CVS at the
;; moment (version 1.9).)
- (string-match "r-..-..-." (nth 8 attrib)))
+ (string-match "r-..-..-." (file-attribute-modes attrib)))
'announce
'implicit))))))
@@ -257,7 +257,7 @@ See also variable `vc-cvs-sticky-date-format-string'."
;; If the file has not changed since checkout, consider it `up-to-date'.
;; Otherwise consider it `edited'.
(let ((checkout-time (vc-file-getprop file 'vc-checkout-time))
- (lastmod (nth 5 (file-attributes file))))
+ (lastmod (file-attribute-modification-time (file-attributes file))))
(cond
((equal checkout-time lastmod) 'up-to-date)
((string= (vc-working-revision file) "0") 'added)
@@ -524,7 +524,8 @@ The changes are between FIRST-REVISION and SECOND-REVISION."
(string= (match-string 1) "P "))
(vc-file-setprop file 'vc-state 'up-to-date)
(vc-file-setprop file 'vc-checkout-time
- (nth 5 (file-attributes file)))
+ (file-attribute-modification-time
+ (file-attributes file)))
0);; indicate success to the caller
;; Merge successful, but our own changes are still in the file
((string= (match-string 1) "M ")
@@ -649,7 +650,7 @@ Optional arg REVISION is a revision to annotate from."
"Return the current time, based at midnight of the current day, and
encoded as fractional days."
(vc-annotate-convert-time
- (apply 'encode-time 0 0 0 (nthcdr 3 (decode-time)))))
+ (apply #'encode-time 0 0 0 (nthcdr 3 (decode-time)))))
(defun vc-cvs-annotate-time ()
"Return the time of the next annotation (as fraction of days)
@@ -748,7 +749,8 @@ If UPDATE is non-nil, then update (resynch) any affected buffers."
(vc-file-setprop file 'vc-state 'up-to-date)
(vc-file-setprop file 'vc-working-revision nil)
(vc-file-setprop file 'vc-checkout-time
- (nth 5 (file-attributes file))))
+ (file-attribute-modification-time
+ (file-attributes file))))
((or (string= state "M")
(string= state "C"))
(vc-file-setprop file 'vc-state 'edited)
@@ -908,7 +910,7 @@ essential information. Note that this can never set the `ignored'
state."
(let (file status missing)
(goto-char (point-min))
- (while (looking-at "? \\(.*\\)")
+ (while (looking-at "\\? \\(.*\\)")
(setq file (expand-file-name (match-string 1)))
(vc-file-setprop file 'vc-state 'unregistered)
(forward-line 1))
@@ -931,7 +933,8 @@ state."
(cond
((string-match "Up-to-date" status)
(vc-file-setprop file 'vc-checkout-time
- (nth 5 (file-attributes file)))
+ (file-attribute-modification-time
+ (file-attributes file)))
'up-to-date)
((string-match "Locally Modified" status) 'edited)
((string-match "Needs Merge" status) 'needs-merge)
@@ -1084,7 +1087,7 @@ CVS/Entries should only be accessed through this function."
;; an uppercase or lowercase letter and can contain uppercase and
;; lowercase letters, digits, `-', and `_'.
(and (string-match "^[a-zA-Z]" tag)
- (not (string-match "[^a-z0-9A-Z-_]" tag))))
+ (not (string-match "[^a-z0-9A-Z_-]" tag))))
(defun vc-cvs-valid-revision-number-p (tag)
"Return non-nil if TAG is a valid revision number."
@@ -1174,16 +1177,15 @@ is non-nil."
;; (which is based on textual comparison), because there can be problems
;; generating a time string that looks exactly like the one from CVS.
(let* ((time (match-string 2))
- (mtime (nth 5 (file-attributes file)))
+ (mtime (file-attribute-modification-time (file-attributes file)))
(parsed-time (progn (require 'parse-time)
(parse-time-string (concat time " +0000")))))
(cond ((and (not (string-match "\\+" time))
(car parsed-time)
;; Compare just the seconds part of the file time,
;; since CVS file time stamp resolution is just 1 second.
- (let ((ptime (apply 'encode-time parsed-time)))
- (and (eq (car mtime) (car ptime))
- (eq (cadr mtime) (cadr ptime)))))
+ (= (encode-time mtime 'integer)
+ (encode-time parsed-time 'integer)))
(vc-file-setprop file 'vc-checkout-time mtime)
(if set-state (vc-file-setprop file 'vc-state 'up-to-date)))
(t
diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el
index 39894952e05..75697e389ad 100644
--- a/lisp/vc/vc-dir.el
+++ b/lisp/vc/vc-dir.el
@@ -554,11 +554,15 @@ If a prefix argument is given, move by that many lines."
(defun vc-dir-mark-unmark (mark-unmark-function)
(if (use-region-p)
- (let (;; (firstl (line-number-at-pos (region-beginning)))
+ (let ((processed-line nil)
(lastl (line-number-at-pos (region-end))))
(save-excursion
(goto-char (region-beginning))
- (while (<= (line-number-at-pos) lastl)
+ (while (and (<= (line-number-at-pos) lastl)
+ ;; We make sure to not get stuck processing the
+ ;; same line in an infinite loop.
+ (not (eq processed-line (line-number-at-pos))))
+ (setq processed-line (line-number-at-pos))
(condition-case nil
(funcall mark-unmark-function)
;; `vc-dir-mark-file' signals an error if we try marking
diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el
index 54c0880d444..edbb83f3df7 100644
--- a/lisp/vc/vc-dispatcher.el
+++ b/lisp/vc/vc-dispatcher.el
@@ -290,16 +290,16 @@ case, and the process object in the asynchronous case."
(let* ((files
(mapcar (lambda (f) (file-relative-name (expand-file-name f)))
(if (listp file-or-list) file-or-list (list file-or-list))))
+ ;; Keep entire commands in *Messages* but avoid resizing the
+ ;; echo area. Messages in this function are formatted in
+ ;; a such way that the important parts are at the beginning,
+ ;; due to potential truncation of long messages.
+ (message-truncate-lines t)
(full-command
- ;; What we're doing here is preparing a version of the command
- ;; for display in a debug-progress message. If it's fewer than
- ;; 20 characters display the entire command (without trailing
- ;; newline). Otherwise display the first 20 followed by an ellipsis.
(concat (if (string= (substring command -1) "\n")
(substring command 0 -1)
command)
- " "
- (vc-delistify (mapcar (lambda (s) (if (> (length s) 20) (concat (substring s 0 2) "...") s)) flags))
+ " " (vc-delistify flags)
" " (vc-delistify files))))
(save-current-buffer
(unless (or (eq buffer t)
@@ -324,7 +324,7 @@ case, and the process object in the asynchronous case."
(apply 'start-file-process command (current-buffer)
command squeezed))))
(when vc-command-messages
- (message "Running %s in background..." full-command))
+ (message "Running in background: %s" full-command))
;; Get rid of the default message insertion, in case we don't
;; set a sentinel explicitly.
(set-process-sentinel proc #'ignore)
@@ -332,10 +332,11 @@ case, and the process object in the asynchronous case."
(setq status proc)
(when vc-command-messages
(vc-run-delayed
- (message "Running %s in background... done" full-command))))
+ (let ((message-truncate-lines t))
+ (message "Done in background: %s" full-command)))))
;; Run synchronously
(when vc-command-messages
- (message "Running %s in foreground..." full-command))
+ (message "Running in foreground: %s" full-command))
(let ((buffer-undo-list t))
(setq status (apply 'process-file command nil t nil squeezed)))
(when (and (not (eq t okstatus))
@@ -345,13 +346,14 @@ case, and the process object in the asynchronous case."
(pop-to-buffer (current-buffer))
(goto-char (point-min))
(shrink-window-if-larger-than-buffer))
- (error "Running %s...FAILED (%s)" full-command
- (if (integerp status) (format "status %d" status) status)))
+ (error "Failed (%s): %s"
+ (if (integerp status) (format "status %d" status) status)
+ full-command))
(when vc-command-messages
- (message "Running %s...OK = %d" full-command status))))
+ (message "Done (status=%d): %s" status full-command))))
(vc-run-delayed
- (run-hook-with-args 'vc-post-command-functions
- command file-or-list flags))
+ (run-hook-with-args 'vc-post-command-functions
+ command file-or-list flags))
status))))
(defun vc-do-async-command (buffer root command &rest args)
diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index 610cbde7a49..a921ff1bb88 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -101,9 +101,9 @@
(eval-when-compile
(require 'cl-lib)
+ (require 'subr-x) ; for string-trim-right
(require 'vc)
- (require 'vc-dir)
- (require 'grep))
+ (require 'vc-dir))
(defgroup vc-git nil
"VC Git backend."
@@ -180,9 +180,21 @@ Should be consistent with the Git config value i18n.logOutputEncoding."
:type '(coding-system :tag "Coding system to decode Git log output")
:version "25.1")
+(defcustom vc-git-grep-template "git --no-pager grep -n -e <R> -- <F>"
+ "The default command to run for \\[vc-git-grep].
+The following place holders should be present in the string:
+ <F> - file names and wildcards to search.
+ <R> - the regular expression searched for."
+ :type 'string
+ :version "27.1")
+
;; History of Git commands.
(defvar vc-git-history nil)
+;; Clear up the cache to force vc-call to check again and discover
+;; new functions when we reload this file.
+(put 'Git 'vc-functions nil)
+
;;; BACKEND PROPERTIES
(defun vc-git-revision-granularity () 'repository)
@@ -242,7 +254,7 @@ Should be consistent with the Git config value i18n.logOutputEncoding."
;; Git for Windows appends ".windows.N" to the
;; numerical version reported by Git.
(string-match
- "git version \\([0-9.]+\\)\\(\.windows.[0-9]+\\)?$"
+ "git version \\([0-9.]+\\)\\(\\.windows\\.[0-9]+\\)?$"
version-string))
(match-string 1 version-string)
"0")))))
@@ -278,7 +290,7 @@ in the order given by 'git status'."
;; 2. When a file A is renamed to B in the index and then back to A
;; in the working tree.
;; In both of these instances, `unregistered' is a reasonable response.
- (`("D " "??") 'unregistered)
+ ('("D " "??") 'unregistered)
;; In other cases, let us return `edited'.
(_ 'edited)))
@@ -364,8 +376,8 @@ in the order given by 'git status'."
(defun vc-git-file-type-as-string (old-perm new-perm)
"Return a string describing the file type based on its permissions."
- (let* ((old-type (lsh (or old-perm 0) -9))
- (new-type (lsh (or new-perm 0) -9))
+ (let* ((old-type (ash (or old-perm 0) -9))
+ (new-type (ash (or new-perm 0) -9))
(str (pcase new-type
(?\100 ;; File.
(pcase old-type
@@ -475,9 +487,9 @@ or an empty string if none."
(files (vc-git-dir-status-state->files git-state)))
(goto-char (point-min))
(pcase (vc-git-dir-status-state->stage git-state)
- (`update-index
+ ('update-index
(setq next-stage (if (vc-git--empty-db-p) 'ls-files-added 'diff-index)))
- (`ls-files-added
+ ('ls-files-added
(setq next-stage 'ls-files-unknown)
(while (re-search-forward "\\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} 0\t\\([^\0]+\\)\0" nil t)
(let ((new-perm (string-to-number (match-string 1) 8))
@@ -485,7 +497,7 @@ or an empty string if none."
(vc-git-dir-status-update-file
git-state name 'added
(vc-git-create-extra-fileinfo 0 new-perm)))))
- (`ls-files-up-to-date
+ ('ls-files-up-to-date
(setq next-stage 'ls-files-unknown)
(while (re-search-forward "\\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} \\([0-3]\\)\t\\([^\0]+\\)\0" nil t)
(let ((perm (string-to-number (match-string 1) 8))
@@ -496,7 +508,7 @@ or an empty string if none."
'up-to-date
'conflict)
(vc-git-create-extra-fileinfo perm perm)))))
- (`ls-files-conflict
+ ('ls-files-conflict
(setq next-stage 'ls-files-unknown)
;; It's enough to look for "3" to notice a conflict.
(while (re-search-forward "\\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} 3\t\\([^\0]+\\)\0" nil t)
@@ -505,16 +517,16 @@ or an empty string if none."
(vc-git-dir-status-update-file
git-state name 'conflict
(vc-git-create-extra-fileinfo perm perm)))))
- (`ls-files-unknown
+ ('ls-files-unknown
(when files (setq next-stage 'ls-files-ignored))
(while (re-search-forward "\\([^\0]*?\\)\0" nil t 1)
(vc-git-dir-status-update-file git-state (match-string 1) 'unregistered
(vc-git-create-extra-fileinfo 0 0))))
- (`ls-files-ignored
+ ('ls-files-ignored
(while (re-search-forward "\\([^\0]*?\\)\0" nil t 1)
(vc-git-dir-status-update-file git-state (match-string 1) 'ignored
(vc-git-create-extra-fileinfo 0 0))))
- (`diff-index
+ ('diff-index
(setq next-stage (if files 'ls-files-up-to-date 'ls-files-conflict))
(while (re-search-forward
":\\([0-7]\\{6\\}\\) \\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} [0-9a-f]\\{40\\} \\(\\([ADMUT]\\)\0\\([^\0]+\\)\\|\\([CR]\\)[0-9]*\0\\([^\0]+\\)\0\\([^\0]+\\)\\)\0"
@@ -566,30 +578,30 @@ or an empty string if none."
(let ((files (vc-git-dir-status-state->files git-state)))
(erase-buffer)
(pcase (vc-git-dir-status-state->stage git-state)
- (`update-index
+ ('update-index
(if files
(vc-git-command (current-buffer) 'async files "add" "--refresh" "--")
(vc-git-command (current-buffer) 'async nil
"update-index" "--refresh")))
- (`ls-files-added
+ ('ls-files-added
(vc-git-command (current-buffer) 'async files
"ls-files" "-z" "-c" "-s" "--"))
- (`ls-files-up-to-date
+ ('ls-files-up-to-date
(vc-git-command (current-buffer) 'async files
"ls-files" "-z" "-c" "-s" "--"))
- (`ls-files-conflict
+ ('ls-files-conflict
(vc-git-command (current-buffer) 'async files
"ls-files" "-z" "-u" "--"))
- (`ls-files-unknown
+ ('ls-files-unknown
(vc-git-command (current-buffer) 'async files
"ls-files" "-z" "-o" "--directory"
"--no-empty-directory" "--exclude-standard" "--"))
- (`ls-files-ignored
+ ('ls-files-ignored
(vc-git-command (current-buffer) 'async files
"ls-files" "-z" "-o" "-i" "--directory"
"--no-empty-directory" "--exclude-standard" "--"))
;; --relative added in Git 1.5.5.
- (`diff-index
+ ('diff-index
(vc-git-command (current-buffer) 'async files
"diff-index" "--relative" "-z" "-M" "HEAD" "--")))
(vc-run-delayed
@@ -746,6 +758,11 @@ the commit message."
(interactive)
(log-edit-toggle-header "Sign-Off" "yes"))
+(defun vc-git-log-edit-toggle-no-verify ()
+ "Toggle whether to bypass the pre-commit and commit-msg hooks."
+ (interactive)
+ (log-edit-toggle-header "No-Verify" "yes"))
+
(defun vc-git-log-edit-toggle-amend ()
"Toggle whether this will amend the previous commit.
If toggling on, also insert its message into the buffer."
@@ -771,6 +788,7 @@ If toggling on, also insert its message into the buffer."
(defvar vc-git-log-edit-mode-map
(let ((map (make-sparse-keymap "Git-Log-Edit")))
(define-key map "\C-c\C-s" 'vc-git-log-edit-toggle-signoff)
+ (define-key map "\C-c\C-n" 'vc-git-log-edit-toggle-no-verify)
(define-key map "\C-c\C-e" 'vc-git-log-edit-toggle-amend)
map))
@@ -814,6 +832,7 @@ It is based on `log-edit-mode', and has Git-specific extensions.")
`(("Author" . "--author")
("Date" . "--date")
("Amend" . ,(boolean-arg-fn "--amend"))
+ ("No-Verify" . ,(boolean-arg-fn "--no-verify"))
("Sign-Off" . ,(boolean-arg-fn "--signoff")))
comment)))
(when msg-file
@@ -863,6 +882,8 @@ It is based on `log-edit-mode', and has Git-specific extensions.")
;; To be called via vc-pull from vc.el, which requires vc-dispatcher.
(declare-function vc-compilation-mode "vc-dispatcher" (backend))
+(defvar compilation-directory)
+(defvar compilation-arguments)
(defun vc-git--pushpull (command prompt extra-args)
"Run COMMAND (a string; either push or pull) on the current Git branch.
@@ -997,7 +1018,8 @@ This prompts for a branch to merge from."
If SHORTLOG is non-nil, use a short format based on `vc-git-root-log-format'.
\(This requires at least Git version 1.5.6, for the --graph option.)
If START-REVISION is non-nil, it is the newest revision to show.
-If LIMIT is non-nil, show no more than this many entries."
+If LIMIT is a number, show no more than this many entries.
+If LIMIT is a revision string, use it as an end-revision."
(let ((coding-system-for-read
(or coding-system-for-read vc-git-log-output-coding-system)))
;; `vc-do-command' creates the buffer, but we need it before running
@@ -1025,8 +1047,14 @@ If LIMIT is non-nil, show no more than this many entries."
,(format "--pretty=tformat:%s"
(car vc-git-root-log-format))
"--abbrev-commit"))
- (when limit (list "-n" (format "%s" limit)))
- (when start-revision (list start-revision))
+ (when (numberp limit)
+ (list "-n" (format "%s" limit)))
+ (when start-revision
+ (if (and limit (not (numberp limit)))
+ (list (concat start-revision ".." (if (equal limit "")
+ "HEAD"
+ limit)))
+ (list start-revision)))
'("--")))))))
(defun vc-git-log-outgoing (buffer remote-location)
@@ -1057,6 +1085,10 @@ If LIMIT is non-nil, show no more than this many entries."
"@{upstream}"
remote-location))))
+(defun vc-git-mergebase (rev1 &optional rev2)
+ (unless rev2 (setq rev2 "HEAD"))
+ (string-trim-right (vc-git--run-command-string nil "merge-base" rev1 rev2)))
+
(defvar log-view-message-re)
(defvar log-view-file-re)
(defvar log-view-font-lock-keywords)
@@ -1073,7 +1105,7 @@ If LIMIT is non-nil, show no more than this many entries."
(cadr vc-git-root-log-format)
"^commit *\\([0-9a-z]+\\)"))
;; Allow expanding short log entries.
- (when (memq vc-log-view-type '(short log-outgoing log-incoming))
+ (when (memq vc-log-view-type '(short log-outgoing log-incoming mergebase))
(setq truncate-lines t)
(set (make-local-variable 'log-view-expanded-log-entry-function)
'vc-git-expanded-log-entry))
@@ -1176,7 +1208,7 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"."
(defvar vc-git--log-view-long-font-lock-keywords nil)
(defvar font-lock-keywords)
(defvar vc-git-region-history-font-lock-keywords
- `((vc-git-region-history-font-lock)))
+ '((vc-git-region-history-font-lock)))
(defun vc-git-region-history-font-lock (limit)
(let ((in-diff (save-excursion
@@ -1373,6 +1405,9 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"."
(define-key map [git-grep]
'(menu-item "Git grep..." vc-git-grep
:help "Run the `git grep' command"))
+ (define-key map [git-ds]
+ '(menu-item "Delete Stash..." vc-git-stash-delete
+ :help "Delete a stash"))
(define-key map [git-sn]
'(menu-item "Stash a Snapshot" vc-git-stash-snapshot
:help "Stash the current state of the tree and keep the current state"))
@@ -1397,6 +1432,7 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"."
(declare-function grep-read-files "grep" (regexp))
(declare-function grep-expand-template "grep"
(template &optional regexp files dir excl))
+(defvar compilation-environment)
;; Derived from `lgrep'.
(defun vc-git-grep (regexp &optional files dir)
@@ -1423,8 +1459,7 @@ This command shares argument histories with \\[rgrep] and \\[grep]."
(cond
((equal current-prefix-arg '(16))
(list (read-from-minibuffer "Run: " "git grep"
- nil nil 'grep-history)
- nil))
+ nil nil 'grep-history)))
(t (let* ((regexp (grep-read-regexp))
(files
(mapconcat #'shell-quote-argument
@@ -1434,13 +1469,15 @@ This command shares argument histories with \\[rgrep] and \\[grep]."
(list regexp files dir))))))
(require 'grep)
(when (and (stringp regexp) (> (length regexp) 0))
+ (unless (and dir (file-accessible-directory-p dir))
+ (setq dir default-directory))
(let ((command regexp))
(if (null files)
(if (string= command "git grep")
(setq command nil))
(setq dir (file-name-as-directory (expand-file-name dir)))
(setq command
- (grep-expand-template "git --no-pager grep -n -e <R> -- <F>"
+ (grep-expand-template vc-git-grep-template
regexp files))
(when command
(if (equal current-prefix-arg '(4))
@@ -1457,17 +1494,36 @@ This command shares argument histories with \\[rgrep] and \\[grep]."
(if (eq next-error-last-buffer (current-buffer))
(setq default-directory dir))))))
+(autoload 'vc-dir-marked-files "vc-dir")
+
(defun vc-git-stash (name)
"Create a stash."
(interactive "sStash name: ")
(let ((root (vc-git-root default-directory)))
(when root
- (vc-git--call nil "stash" "save" name)
+ (apply #'vc-git--call nil "stash" "push" "-m" name
+ (when (derived-mode-p 'vc-dir-mode)
+ (vc-dir-marked-files)))
(vc-resynch-buffer root t t))))
+(defvar vc-git-stash-read-history nil
+ "History for `vc-git-stash-read'.")
+
+(defun vc-git-stash-read (prompt)
+ "Read a Git stash. PROMPT is a string to prompt with."
+ (let ((stash (completing-read
+ prompt
+ (split-string
+ (or (vc-git--run-command-string nil "stash" "list") "") "\n")
+ nil :require-match nil 'vc-git-stash-read-history)))
+ (if (string-equal stash "")
+ (user-error "Not a stash")
+ (string-match "^stash@{[[:digit:]]+}" stash)
+ (match-string 0 stash))))
+
(defun vc-git-stash-show (name)
"Show the contents of stash NAME."
- (interactive "sStash name: ")
+ (interactive (list (vc-git-stash-read "Show stash: ")))
(vc-setup-buffer "*vc-git-stash*")
(vc-git-command "*vc-git-stash*" 'async nil "stash" "show" "-p" name)
(set-buffer "*vc-git-stash*")
@@ -1477,24 +1533,27 @@ This command shares argument histories with \\[rgrep] and \\[grep]."
(defun vc-git-stash-apply (name)
"Apply stash NAME."
- (interactive "sApply stash: ")
+ (interactive (list (vc-git-stash-read "Apply stash: ")))
(vc-git-command "*vc-git-stash*" 0 nil "stash" "apply" "-q" name)
(vc-resynch-buffer (vc-git-root default-directory) t t))
(defun vc-git-stash-pop (name)
"Pop stash NAME."
- (interactive "sPop stash: ")
+ (interactive (list (vc-git-stash-read "Pop stash: ")))
(vc-git-command "*vc-git-stash*" 0 nil "stash" "pop" "-q" name)
(vc-resynch-buffer (vc-git-root default-directory) t t))
+(defun vc-git-stash-delete (name)
+ "Delete stash NAME."
+ (interactive (list (vc-git-stash-read "Delete stash: ")))
+ (vc-git-command "*vc-git-stash*" 0 nil "stash" "drop" "-q" name)
+ (vc-resynch-buffer (vc-git-root default-directory) t t))
+
(defun vc-git-stash-snapshot ()
"Create a stash with the current tree state."
(interactive)
(vc-git--call nil "stash" "save"
- (let ((ct (current-time)))
- (concat
- (format-time-string "Snapshot on %Y-%m-%d" ct)
- (format-time-string " at %H:%M" ct))))
+ (format-time-string "Snapshot on %Y-%m-%d at %H:%M"))
(vc-git-command "*vc-git-stash*" 0 nil "stash" "apply" "-q" "stash@{0}")
(vc-resynch-buffer (vc-git-root default-directory) t t))
@@ -1555,7 +1614,14 @@ The difference to vc-do-command is that this function always invokes
(or coding-system-for-read vc-git-log-output-coding-system))
(coding-system-for-write
(or coding-system-for-write vc-git-commits-coding-system))
- (process-environment (cons "GIT_DIR" process-environment)))
+ (process-environment
+ (append
+ `("GIT_DIR"
+ ;; Avoid repository locking during background operations
+ ;; (bug#21559).
+ ,@(when revert-buffer-in-progress-p
+ '("GIT_OPTIONAL_LOCKS=0")))
+ process-environment)))
(apply 'vc-do-command (or buffer "*vc*") okstatus vc-git-program
;; https://debbugs.gnu.org/16897
(unless (and (not (cdr-safe file-or-list))
@@ -1575,15 +1641,22 @@ The difference to vc-do-command is that this function always invokes
(defun vc-git--call (buffer command &rest args)
;; We don't need to care the arguments. If there is a file name, it
;; is always a relative one. This works also for remote
- ;; directories. We enable `inhibit-null-byte-detection', otherwise
+ ;; directories. We enable `inhibit-nul-byte-detection', otherwise
;; Tramp's eol conversion might be confused.
- (let ((inhibit-null-byte-detection t)
+ (let ((inhibit-nul-byte-detection t)
(coding-system-for-read
(or coding-system-for-read vc-git-log-output-coding-system))
(coding-system-for-write
(or coding-system-for-write vc-git-commits-coding-system))
- (process-environment (cons "PAGER=" process-environment)))
- (push "GIT_DIR" process-environment)
+ (process-environment
+ (append
+ `("GIT_DIR"
+ "PAGER="
+ ;; Avoid repository locking during background operations
+ ;; (bug#21559).
+ ,@(when revert-buffer-in-progress-p
+ '("GIT_OPTIONAL_LOCKS=0")))
+ process-environment)))
(apply 'process-file vc-git-program nil buffer nil command args)))
(defun vc-git--out-ok (command &rest args)
diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el
index eab7e566b27..6b17e861dda 100644
--- a/lisp/vc/vc-hg.el
+++ b/lisp/vc/vc-hg.el
@@ -101,12 +101,12 @@
;;; Code:
+(require 'cl-lib)
+
(eval-when-compile
(require 'vc)
(require 'vc-dir))
-(require 'cl-lib)
-
(declare-function vc-compilation-mode "vc-dispatcher" (backend))
;;; Customization options
@@ -145,6 +145,15 @@ switches."
:version "25.1"
:group 'vc-hg)
+(defcustom vc-hg-revert-switches nil
+ "String or list of strings specifying switches for hg revert
+under VC."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "27.1"
+ :group 'vc-hg)
+
(defcustom vc-hg-program "hg"
"Name of the Mercurial executable (excluding any arguments)."
:type 'string
@@ -175,6 +184,10 @@ highlighting the Log View buffer."
:version "24.5")
+;; Clear up the cache to force vc-call to check again and discover
+;; new functions when we reload this file.
+(put 'Hg 'vc-functions nil)
+
;;; Properties of the backend
(defvar vc-hg-history nil)
@@ -579,15 +592,14 @@ back to running Mercurial directly."
(defsubst vc-hg--read-u8 ()
"Read and advance over an unsigned byte.
-Return a fixnum."
+Return the byte's value as an integer."
(prog1 (char-after)
(forward-char)))
(defsubst vc-hg--read-u32-be ()
- "Read and advance over a big-endian unsigned 32-bit integer.
-Return a fixnum; on overflow, result is undefined."
+ "Read and advance over a big-endian unsigned 32-bit integer."
;; Because elisp bytecode has an instruction for multiply and
- ;; doesn't have one for lsh, it's somewhat counter-intuitively
+ ;; doesn't have one for shift, it's somewhat counter-intuitively
;; faster to multiply than to shift.
(+ (* (vc-hg--read-u8) (* 256 256 256))
(* (vc-hg--read-u8) (* 256 256))
@@ -623,9 +635,7 @@ Return a fixnum; on overflow, result is undefined."
;; hundreds of thousands of times, so performance is important
;; here
(while (< (point) search-limit)
- ;; 1+4*4 is the length of the dirstate item header, which we
- ;; spell as a literal for performance, since the elisp
- ;; compiler lacks constant propagation
+ ;; 1+4*4 is the length of the dirstate item header.
(forward-char (1+ (* 3 4)))
(let ((this-flen (vc-hg--read-u32-be)))
(if (and (or (eq this-flen flen)
@@ -832,7 +842,7 @@ if we don't understand a construct, we signal
(with-temp-buffer
(let ((attr (file-attributes hgignore)))
(when attr (insert-file-contents hgignore))
- (push (list hgignore (nth 5 attr) (nth 7 attr))
+ (push (list hgignore (file-attribute-modification-time attr) (file-attribute-size attr))
vc-hg--hgignore-filenames))
(while (not (eobp))
;; This list of pattern-file commands isn't complete, but it
@@ -896,8 +906,8 @@ REPO must be the directory name of an hg repository."
(saved-mtime (nth 1 fs))
(saved-size (nth 2 fs))
(attr (file-attributes (nth 0 fs)))
- (current-mtime (nth 5 attr))
- (current-size (nth 7 attr)))
+ (current-mtime (file-attribute-modification-time attr))
+ (current-size (file-attribute-size attr)))
(unless (and (equal saved-mtime current-mtime)
(equal saved-size current-size))
(setf valid nil))))
@@ -913,9 +923,6 @@ FILENAME must be the file's true absolute name."
(setf ignored (string-match (pop patterns) filename)))
ignored))
-(defun vc-hg--time-to-fixnum (ts)
- (+ (* 65536 (car ts)) (cadr ts)))
-
(defvar vc-hg--cached-ignore-patterns nil
"Cached pre-parsed hg ignore patterns.")
@@ -967,8 +974,8 @@ Avoids the need to repeatedly scan dirstate on repeated calls to
`vc-hg-state', as we see during registration queries.")
(defun vc-hg--cached-dirstate-search (dirstate dirstate-attr ascii-fname)
- (let* ((mtime (nth 5 dirstate-attr))
- (size (nth 7 dirstate-attr))
+ (let* ((mtime (file-attribute-modification-time dirstate-attr))
+ (size (file-attribute-size dirstate-attr))
(cache vc-hg--dirstate-scan-cache)
)
(if (and cache
@@ -1011,9 +1018,7 @@ hg binary."
;; Repository must be in an understood format
(not (vc-hg--requirements-understood-p repo))
;; Dirstate too small to be valid
- (< (nth 7 dirstate-attr) 40)
- ;; We want to store 32-bit unsigned values in fixnums
- (< most-positive-fixnum 4294967295)
+ (< (file-attribute-size dirstate-attr) 40)
(progn
(setf repo-relative-filename
(file-relative-name truename repo))
@@ -1037,8 +1042,10 @@ hg binary."
((eq state ?n)
(let ((vc-hg-size (nth 2 dirstate-entry))
(vc-hg-mtime (nth 3 dirstate-entry))
- (fs-size (nth 7 stat))
- (fs-mtime (vc-hg--time-to-fixnum (nth 5 stat))))
+ (fs-size (file-attribute-size stat))
+ (fs-mtime (encode-time
+ (file-attribute-modification-time stat)
+ 'integer)))
(if (and (eql vc-hg-size fs-size) (eql vc-hg-mtime fs-mtime))
'up-to-date
'edited)))
@@ -1142,11 +1149,9 @@ REV is the revision to check out into WORKFILE."
(defun vc-hg-find-file-hook ()
(when (and buffer-file-name
- (file-exists-p (concat buffer-file-name ".orig"))
;; Hg does not seem to have a "conflict" status, eg
;; hg http://bz.selenic.com/show_bug.cgi?id=2724
- (memq (vc-file-getprop buffer-file-name 'vc-state)
- '(edited conflict))
+ (memq (vc-state buffer-file-name) '(edited conflict))
;; Maybe go on to check that "hg resolve -l" says "U"?
;; If "hg resolve -l" says there's a conflict but there are no
;; conflict markers, it's not clear what we should do.
@@ -1163,7 +1168,11 @@ REV is the revision to check out into WORKFILE."
;; Modeled after the similar function in vc-bzr.el
(defun vc-hg-revert (file &optional contents-done)
(unless contents-done
- (with-temp-buffer (vc-hg-command t 0 file "revert"))))
+ (with-temp-buffer
+ (apply #'vc-hg-command
+ t 0 file
+ "revert"
+ (append (vc-switches 'hg 'revert))))))
;;; Hg specific functionality.
@@ -1194,9 +1203,9 @@ REV is the revision to check out into WORKFILE."
(insert (propertize
(format " (%s %s)"
(pcase (vc-hg-extra-fileinfo->rename-state extra)
- (`copied "copied from")
- (`renamed-from "renamed from")
- (`renamed-to "renamed to"))
+ ('copied "copied from")
+ ('renamed-from "renamed from")
+ ('renamed-to "renamed to"))
(vc-hg-extra-fileinfo->extra-name extra))
'face 'font-lock-comment-face)))))
diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el
index c3ff41088ca..07b3d86b518 100644
--- a/lisp/vc/vc-hooks.el
+++ b/lisp/vc/vc-hooks.el
@@ -1,4 +1,4 @@
-;;; vc-hooks.el --- resident support for version-control
+;;; vc-hooks.el --- resident support for version-control -*- lexical-binding:t -*-
;; Copyright (C) 1992-1996, 1998-2019 Free Software Foundation, Inc.
@@ -173,9 +173,9 @@ Otherwise, not displayed."
(make-variable-buffer-local 'vc-mode)
(put 'vc-mode 'permanent-local t)
-;;; We signal this error when we try to do something a VC backend
-;;; doesn't support. Two arguments: the method that's not supported
-;;; and the backend
+;; We signal this error when we try to do something a VC backend
+;; doesn't support. Two arguments: the method that's not supported
+;; and the backend
(define-error 'vc-not-supported "VC method not implemented for backend")
(defun vc-mode (&optional _arg)
@@ -243,12 +243,12 @@ if that doesn't exist either, return nil."
"Call for BACKEND the implementation of FUNCTION-NAME with the given ARGS.
Calls
- (apply \\='vc-BACKEND-FUN ARGS)
+ (apply #\\='vc-BACKEND-FUN ARGS)
if vc-BACKEND-FUN exists (after trying to find it in vc-BACKEND.el)
and else calls
- (apply \\='vc-default-FUN BACKEND ARGS)
+ (apply #\\='vc-default-FUN BACKEND ARGS)
It is usually called via the `vc-call' macro."
(let ((f (assoc function-name (get backend 'vc-functions))))
@@ -603,7 +603,7 @@ a regexp for matching all such backup files, regardless of the version."
"Delete all existing automatic version backups for FILE."
(condition-case nil
(mapc
- 'delete-file
+ #'delete-file
(directory-files (or (file-name-directory file) default-directory) t
(vc-version-backup-file-name file nil nil t)))
;; Don't fail when the directory doesn't exist.
@@ -658,7 +658,7 @@ Before doing that, check if there are any old backups and get rid of them."
;; If the file was saved in the same second in which it was
;; checked out, clear the checkout-time to avoid confusion.
(if (equal (vc-file-getprop file 'vc-checkout-time)
- (nth 5 (file-attributes file)))
+ (file-attribute-modification-time (file-attributes file)))
(vc-file-setprop file 'vc-checkout-time nil))
(if (vc-state-refresh file backend)
(vc-mode-line file backend)))
@@ -692,24 +692,26 @@ visiting FILE.
If BACKEND is passed use it as the VC backend when computing the result."
(interactive (list buffer-file-name))
(setq backend (or backend (vc-backend file)))
- (if (not backend)
- (setq vc-mode nil)
+ (cond
+ ((not backend)
+ (setq vc-mode nil))
+ ((null vc-display-status)
+ (setq vc-mode (concat " " (symbol-name backend))))
+ (t
(let* ((ml-string (vc-call-backend backend 'mode-line-string file))
(ml-echo (get-text-property 0 'help-echo ml-string)))
(setq vc-mode
(concat
" "
- (if (null vc-display-status)
- (symbol-name backend)
- (propertize
- ml-string
- 'mouse-face 'mode-line-highlight
- 'help-echo
- (concat (or ml-echo
- (format "File under the %s version control system"
- backend))
- "\nmouse-1: Version Control menu")
- 'local-map vc-mode-line-map)))))
+ (propertize
+ ml-string
+ 'mouse-face 'mode-line-highlight
+ 'help-echo
+ (concat (or ml-echo
+ (format "File under the %s version control system"
+ backend))
+ "\nmouse-1: Version Control menu")
+ 'local-map vc-mode-line-map))))
;; If the user is root, and the file is not owner-writable,
;; then pretend that we can't write it
;; even though we can (because root can write anything).
@@ -718,7 +720,7 @@ If BACKEND is passed use it as the VC backend when computing the result."
(not buffer-read-only)
(zerop (user-real-uid))
(zerop (logand (file-modes buffer-file-name) 128))
- (setq buffer-read-only t)))
+ (setq buffer-read-only t))))
(force-mode-line-update)
backend)
@@ -809,7 +811,7 @@ In the latter case, VC mode is deactivated for this buffer."
(when buffer-file-name
(vc-file-clearprops buffer-file-name)
;; FIXME: Why use a hook? Why pass it buffer-file-name?
- (add-hook 'vc-mode-line-hook 'vc-mode-line nil t)
+ (add-hook 'vc-mode-line-hook #'vc-mode-line nil t)
(let (backend)
(cond
((setq backend (with-demoted-errors (vc-backend buffer-file-name)))
@@ -860,13 +862,13 @@ In the latter case, VC mode is deactivated for this buffer."
)))))))))
(add-hook 'find-file-hook #'vc-refresh-state)
-(define-obsolete-function-alias 'vc-find-file-hook 'vc-refresh-state "25.1")
+(define-obsolete-function-alias 'vc-find-file-hook #'vc-refresh-state "25.1")
(defun vc-kill-buffer-hook ()
"Discard VC info about a file when we kill its buffer."
(when buffer-file-name (vc-file-clearprops buffer-file-name)))
-(add-hook 'kill-buffer-hook 'vc-kill-buffer-hook)
+(add-hook 'kill-buffer-hook #'vc-kill-buffer-hook)
;; Now arrange for (autoloaded) bindings of the main package.
;; Bindings for this have to go in the global map, as we'll often
@@ -888,6 +890,8 @@ In the latter case, VC mode is deactivated for this buffer."
(define-key map "L" 'vc-print-root-log)
(define-key map "I" 'vc-log-incoming)
(define-key map "O" 'vc-log-outgoing)
+ (define-key map "ML" 'vc-log-mergebase)
+ (define-key map "MD" 'vc-diff-mergebase)
(define-key map "m" 'vc-merge)
(define-key map "r" 'vc-retrieve-tag)
(define-key map "s" 'vc-create-tag)
@@ -948,8 +952,7 @@ In the latter case, VC mode is deactivated for this buffer."
(bindings--define-key map [separator2] menu-bar-separator)
(bindings--define-key map [vc-insert-header]
'(menu-item "Insert Header" vc-insert-headers
- :help "Insert headers into a file for use with a version control system.
-"))
+ :help "Insert headers into a file for use with a version control system."))
(bindings--define-key map [vc-revert]
'(menu-item "Revert to Base Version" vc-revert
:help "Revert working copies of the selected file set to their repository contents"))
diff --git a/lisp/vc/vc-mtn.el b/lisp/vc/vc-mtn.el
index 748c2ae23ff..f0b12489c1b 100644
--- a/lisp/vc/vc-mtn.el
+++ b/lisp/vc/vc-mtn.el
@@ -190,8 +190,8 @@ switches."
(setq branch (replace-match (cdr rule) t nil branch))))
(format "Mtn%c%s"
(pcase (vc-state file)
- ((or `up-to-date `needs-update) ?-)
- (`added ?@)
+ ((or 'up-to-date 'needs-update) ?-)
+ ('added ?@)
(_ ?:))
branch))
"")))
diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el
index 11a8d396953..598e98250ac 100644
--- a/lisp/vc/vc-rcs.el
+++ b/lisp/vc/vc-rcs.el
@@ -684,13 +684,13 @@ Optional arg REVISION is a revision to annotate from."
(forward-line (1- (pop insn)))
(setq p (point))
(pcase (pop insn)
- (`k (setq s (buffer-substring-no-properties
+ ('k (setq s (buffer-substring-no-properties
p (progn (forward-line (car insn))
(point))))
(when prda
(push `(,p . ,(propertize s :vc-rcs-r/d/a prda)) path))
(delete-region p (point)))
- (`i (setq s (car insn))
+ ('i (setq s (car insn))
(when prda
(push `(,p . ,(length s)) path))
(insert s)))))
@@ -716,10 +716,10 @@ Optional arg REVISION is a revision to annotate from."
(goto-char (point-min))
(forward-line (1- (pop insn)))
(pcase (pop insn)
- (`k (delete-region
+ ('k (delete-region
(point) (progn (forward-line (car insn))
(point))))
- (`i (insert (propertize
+ ('i (insert (propertize
(car insn)
:vc-rcs-r/d/a
(or prda (setq prda (r/d/a))))))))
@@ -955,11 +955,10 @@ Uses `rcs2log' which only works for RCS and CVS."
"Return non-nil if FILE is newer than its RCS master.
This likely means that FILE has been changed with respect
to its master version."
- (let ((file-time (nth 5 (file-attributes file)))
- (master-time (nth 5 (file-attributes (vc-master-name file)))))
- (or (> (nth 0 file-time) (nth 0 master-time))
- (and (= (nth 0 file-time) (nth 0 master-time))
- (> (nth 1 file-time) (nth 1 master-time))))))
+ (let ((file-time (file-attribute-modification-time (file-attributes file)))
+ (master-time (file-attribute-modification-time
+ (file-attributes (vc-master-name file)))))
+ (time-less-p master-time file-time)))
(defun vc-rcs-find-most-recent-rev (branch)
"Find most recent revision on BRANCH."
diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el
index e10cdd21698..3c50c8fff64 100644
--- a/lisp/vc/vc-svn.el
+++ b/lisp/vc/vc-svn.el
@@ -479,7 +479,8 @@ The changes are between FIRST-VERSION and SECOND-VERSION."
((string= (match-string 2) "U")
(vc-file-setprop file 'vc-state 'up-to-date)
(vc-file-setprop file 'vc-checkout-time
- (nth 5 (file-attributes file)))
+ (file-attribute-modification-time
+ (file-attributes file)))
0);; indicate success to the caller
;; Merge successful, but our own changes are still in the file
((string= (match-string 2) "G")
@@ -729,7 +730,8 @@ Set file properties accordingly. If FILENAME is non-nil, return its status."
(if (eq (char-after (match-beginning 1)) ?*)
'needs-update
(vc-file-setprop file 'vc-checkout-time
- (nth 5 (file-attributes file)))
+ (file-attribute-modification-time
+ (file-attributes file)))
'up-to-date))
((eq status ?A)
;; If the file was actually copied, (match-string 2) is "-".
@@ -757,7 +759,7 @@ Set file properties accordingly. If FILENAME is non-nil, return its status."
;; an uppercase or lowercase letter and can contain uppercase and
;; lowercase letters, digits, `-', and `_'.
(and (string-match "^[a-zA-Z]" tag)
- (not (string-match "[^a-z0-9A-Z-_]" tag))))
+ (not (string-match "[^a-z0-9A-Z_-]" tag))))
(defun vc-svn-valid-revision-number-p (tag)
"Return non-nil if TAG is a valid revision number."
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index 353299cbed9..b992a8ebe09 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -429,6 +429,10 @@
;; - region-history-mode ()
;;
;; Major mode to use for the output of `region-history'.
+;;
+;; - mergebase (rev1 &optional rev2)
+;;
+;; Return the common ancestor between REV1 and REV2 revisions.
;; TAG SYSTEM
;;
@@ -729,13 +733,6 @@
"Emacs interface to version control systems."
:group 'tools)
-(defcustom vc-initial-comment nil
- "If non-nil, prompt for initial comment when a file is registered."
- :type 'boolean
- :group 'vc)
-
-(make-obsolete-variable 'vc-initial-comment "it has no effect." "23.2")
-
(defcustom vc-checkin-switches nil
"A string or list of strings specifying extra switches for checkin.
These are passed to the checkin program by \\[vc-checkin]."
@@ -743,8 +740,7 @@ These are passed to the checkin program by \\[vc-checkin]."
(string :tag "Argument String")
(repeat :tag "Argument List"
:value ("")
- string))
- :group 'vc)
+ string)))
(defcustom vc-checkout-switches nil
"A string or list of strings specifying extra switches for checkout.
@@ -753,8 +749,7 @@ These are passed to the checkout program by \\[vc-checkout]."
(string :tag "Argument String")
(repeat :tag "Argument List"
:value ("")
- string))
- :group 'vc)
+ string)))
(defcustom vc-register-switches nil
"A string or list of strings; extra switches for registering a file.
@@ -763,8 +758,7 @@ These are passed to the checkin program by \\[vc-register]."
(string :tag "Argument String")
(repeat :tag "Argument List"
:value ("")
- string))
- :group 'vc)
+ string)))
(defcustom vc-diff-switches nil
"A string or list of strings specifying switches for diff under VC.
@@ -779,7 +773,6 @@ not specific to any particular backend."
(const :tag "None" t)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :group 'vc
:version "21.1")
(defcustom vc-annotate-switches nil
@@ -799,15 +792,13 @@ for the backend you use."
(const :tag "None" t)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :group 'vc
:version "25.1")
(defcustom vc-log-show-limit 2000
"Limit the number of items shown by the VC log commands.
Zero means unlimited.
Not all VC backends are able to support this feature."
- :type 'integer
- :group 'vc)
+ :type 'integer)
(defcustom vc-allow-async-revert nil
"Specifies whether the diff during \\[vc-revert] may be asynchronous.
@@ -815,7 +806,6 @@ Enabling this option means that you can confirm a revert operation even
if the local changes in the file have not been found and displayed yet."
:type '(choice (const :tag "No" nil)
(const :tag "Yes" t))
- :group 'vc
:version "22.1")
;;;###autoload
@@ -823,7 +813,6 @@ if the local changes in the file have not been found and displayed yet."
"Normal hook (list of functions) run after checking out a file.
See `run-hooks'."
:type 'hook
- :group 'vc
:version "21.1")
;;;###autoload
@@ -831,20 +820,22 @@ See `run-hooks'."
"Normal hook (list of functions) run after commit or file checkin.
See also `log-edit-done-hook'."
:type 'hook
- :options '(log-edit-comment-to-change-log)
- :group 'vc)
+ :options '(log-edit-comment-to-change-log))
;;;###autoload
(defcustom vc-before-checkin-hook nil
"Normal hook (list of functions) run before a commit or a file checkin.
See `run-hooks'."
+ :type 'hook)
+
+(defcustom vc-retrieve-tag-hook nil
+ "Normal hook (list of functions) run after retrieving a tag."
:type 'hook
- :group 'vc)
+ :version "27.1")
(defcustom vc-revert-show-diff t
"If non-nil, `vc-revert' shows a `vc-diff' buffer before querying."
:type 'boolean
- :group 'vc
:version "24.1")
;; Header-insertion hair
@@ -857,8 +848,7 @@ A %s in the template is replaced with the first string associated with
the file's version control type in `vc-BACKEND-header'."
:type '(repeat (cons :format "%v"
(regexp :tag "File Type")
- (string :tag "Header String")))
- :group 'vc)
+ (string :tag "Header String"))))
(defcustom vc-comment-alist
'((nroff-mode ".\\\"" ""))
@@ -869,8 +859,12 @@ is sensitive to blank lines."
:type '(repeat (list :format "%v"
(symbol :tag "Mode")
(string :tag "Comment Start")
- (string :tag "Comment End")))
- :group 'vc)
+ (string :tag "Comment End"))))
+
+(defcustom vc-find-revision-no-save nil
+ "If non-nil, `vc-find-revision' doesn't write the created buffer to file."
+ :type 'boolean
+ :version "27.1")
;; File property caching
@@ -935,7 +929,7 @@ use."
;; 'create-repo method.
(completing-read
(format "%s is not in a version controlled directory.\nUse VC backend: " file)
- (mapcar 'symbol-name possible-backends) nil t)))
+ (mapcar #'symbol-name possible-backends) nil t)))
(repo-dir
(let ((def-dir (file-name-directory file)))
;; read the directory where to create the
@@ -988,6 +982,7 @@ Within directories, only files already under version control are noticed."
(defvar log-view-vc-backend)
(defvar log-edit-vc-backend)
(defvar diff-vc-backend)
+(defvar diff-vc-revisions)
(defun vc-deduce-backend ()
(cond ((derived-mode-p 'vc-dir-mode) vc-dir-backend)
@@ -1062,27 +1057,27 @@ BEWARE: this function may change the current buffer."
(t (error "File is not under version control")))))
(defun vc-dired-deduce-fileset ()
- (let ((backend (vc-responsible-backend default-directory)))
- (unless backend (error "Directory not under VC"))
- (list backend
- (dired-map-over-marks (dired-get-filename nil t) nil))))
+ (list (vc-responsible-backend default-directory)
+ (dired-map-over-marks (dired-get-filename nil t) nil)))
(defun vc-ensure-vc-buffer ()
"Make sure that the current buffer visits a version-controlled file."
(cond
((derived-mode-p 'vc-dir-mode)
(set-buffer (find-file-noselect (vc-dir-current-file))))
+ ((derived-mode-p 'dired-mode)
+ (set-buffer (find-file-noselect (dired-get-filename))))
(t
(while (and vc-parent-buffer
(buffer-live-p vc-parent-buffer)
;; Avoid infinite looping when vc-parent-buffer and
;; current buffer are the same buffer.
(not (eq vc-parent-buffer (current-buffer))))
- (set-buffer vc-parent-buffer))
- (if (not buffer-file-name)
- (error "Buffer %s is not associated with a file" (buffer-name))
- (unless (vc-backend buffer-file-name)
- (error "File %s is not under version control" buffer-file-name))))))
+ (set-buffer vc-parent-buffer))))
+ (if (not buffer-file-name)
+ (error "Buffer %s is not associated with a file" (buffer-name))
+ (unless (vc-backend buffer-file-name)
+ (error "File %s is not under version control" buffer-file-name))))
;;; Support for the C-x v v command.
;; This is where all the single-file-oriented code from before the fileset
@@ -1103,7 +1098,7 @@ BEWARE: this function may change the current buffer."
(defun vc-read-backend (prompt)
(intern
- (completing-read prompt (mapcar 'symbol-name vc-handled-backends)
+ (completing-read prompt (mapcar #'symbol-name vc-handled-backends)
nil 'require-match)))
;; Here's the major entry point.
@@ -1361,7 +1356,7 @@ first backend that could register the file is used."
(set-buffer-modified-p t))
(vc-buffer-sync)))))
(message "Registering %s... " files)
- (mapc 'vc-file-clearprops files)
+ (mapc #'vc-file-clearprops files)
(vc-call-backend backend 'register files comment)
(mapc
(lambda (file)
@@ -1488,7 +1483,8 @@ After check-out, runs the normal hook `vc-checkout-hook'."
nil)
'up-to-date
'edited))
- (vc-checkout-time . ,(nth 5 (file-attributes file))))))
+ (vc-checkout-time . ,(file-attribute-modification-time
+ (file-attributes file))))))
(vc-resynch-buffer file t t)
(run-hooks 'vc-checkout-hook))
@@ -1542,8 +1538,7 @@ The optional argument REV may be a string specifying the new revision
level (only supported for some older VCSes, like RCS and CVS).
Runs the normal hooks `vc-before-checkin-hook' and `vc-checkin-hook'."
- (when vc-before-checkin-hook
- (run-hooks 'vc-before-checkin-hook))
+ (run-hooks 'vc-before-checkin-hook)
(vc-start-logentry
files comment initial-contents
"Enter a change comment."
@@ -1563,9 +1558,10 @@ Runs the normal hooks `vc-before-checkin-hook' and `vc-checkin-hook'."
;; not a well-defined concept for filesets.
(progn
(vc-call-backend backend 'checkin files comment rev)
- (mapc 'vc-delete-automatic-version-backups files))
+ (mapc #'vc-delete-automatic-version-backups files))
`((vc-state . up-to-date)
- (vc-checkout-time . ,(nth 5 (file-attributes file)))
+ (vc-checkout-time . ,(file-attribute-modification-time
+ (file-attributes file)))
(vc-working-revision . nil)))
(message "Checking in %s...done" (vc-delistify files)))
'vc-checkin-hook
@@ -1649,11 +1645,6 @@ to override the value of `vc-diff-switches' and `diff-switches'."
;; any switches in diff-switches.
(when (listp switches) switches))))
-;; Old def for compatibility with Emacs-21.[123].
-(defmacro vc-diff-switches-list (backend)
- (declare (obsolete vc-switches "22.1"))
- `(vc-switches ',backend 'diff))
-
(defun vc-diff-finish (buffer messages)
;; The empty sync output case has already been handled, so the only
;; possibility of an empty output is for an async process.
@@ -1725,7 +1716,7 @@ Return t if the buffer had changes, nil otherwise."
(error "No revisions of %s exist" file)
;; We regard this as "changed".
;; Diff it against /dev/null.
- (apply 'vc-do-command buffer
+ (apply #'vc-do-command buffer
(if async 'async 1) "diff" file
(append (vc-switches nil 'diff) '("/dev/null"))))))
(setq files (nreverse filtered))))
@@ -1733,6 +1724,7 @@ Return t if the buffer had changes, nil otherwise."
(set-buffer buffer)
(diff-mode)
(set (make-local-variable 'diff-vc-backend) (car vc-fileset))
+ (set (make-local-variable 'diff-vc-revisions) (list rev1 rev2))
(set (make-local-variable 'revert-buffer-function)
(lambda (_ignore-auto _noconfirm)
(vc-diff-internal async vc-fileset rev1 rev2 verbose)))
@@ -1774,9 +1766,9 @@ Return t if the buffer had changes, nil otherwise."
nil nil initial-input 'vc-revision-history default)
(read-string prompt initial-input nil default))))
-(defun vc-diff-build-argument-list-internal ()
+(defun vc-diff-build-argument-list-internal (&optional fileset)
"Build argument list for calling internal diff functions."
- (let* ((vc-fileset (vc-deduce-fileset t)) ;FIXME: why t? --Stef
+ (let* ((vc-fileset (or fileset (vc-deduce-fileset t))) ;FIXME: why t? --Stef
(files (cadr vc-fileset))
(backend (car vc-fileset))
(first (car files))
@@ -1830,6 +1822,32 @@ state of each file in the fileset."
(called-interactively-p 'interactive)))
;;;###autoload
+(defun vc-root-version-diff (_files rev1 rev2)
+ "Report diffs between REV1 and REV2 revisions of the whole tree."
+ (interactive
+ (vc-diff-build-argument-list-internal
+ (or (ignore-errors (vc-deduce-fileset t))
+ (let ((backend (or (vc-deduce-backend) (vc-responsible-backend default-directory))))
+ (list backend (list (vc-call-backend backend 'root default-directory)))))))
+ ;; This is a mix of `vc-root-diff' and `vc-version-diff'
+ (when (and (not rev1) rev2)
+ (error "Not a valid revision range"))
+ (let ((backend (vc-deduce-backend))
+ (default-directory default-directory)
+ rootdir)
+ (if backend
+ (setq rootdir (vc-call-backend backend 'root default-directory))
+ (setq rootdir (read-directory-name "Directory for VC root-diff: "))
+ (setq backend (vc-responsible-backend rootdir))
+ (if backend
+ (setq default-directory rootdir)
+ (error "Directory is not version controlled")))
+ (let ((default-directory rootdir))
+ (vc-diff-internal
+ t (list backend (list rootdir)) rev1 rev2
+ (called-interactively-p 'interactive)))))
+
+;;;###autoload
(defun vc-diff (&optional historic not-urgent)
"Display diffs between file revisions.
Normally this compares the currently selected fileset with their
@@ -1845,6 +1863,33 @@ saving the buffer."
(vc-diff-internal t (vc-deduce-fileset t) nil nil
(called-interactively-p 'interactive))))
+;;;###autoload
+(defun vc-diff-mergebase (_files rev1 rev2)
+ "Report diffs between the merge base of REV1 and REV2 revisions.
+The merge base is a common ancestor between REV1 and REV2 revisions."
+ (interactive
+ (vc-diff-build-argument-list-internal
+ (or (ignore-errors (vc-deduce-fileset t))
+ (let ((backend (or (vc-deduce-backend) (vc-responsible-backend default-directory))))
+ (list backend (list (vc-call-backend backend 'root default-directory)))))))
+ (when (and (not rev1) rev2)
+ (error "Not a valid revision range"))
+ (let ((backend (vc-deduce-backend))
+ (default-directory default-directory)
+ rootdir)
+ (if backend
+ (setq rootdir (vc-call-backend backend 'root default-directory))
+ (setq rootdir (read-directory-name "Directory for VC root-diff: "))
+ (setq backend (vc-responsible-backend rootdir))
+ (if backend
+ (setq default-directory rootdir)
+ (error "Directory is not version controlled")))
+ (let ((default-directory rootdir)
+ (rev1 (vc-call-backend backend 'mergebase rev1 rev2)))
+ (vc-diff-internal
+ t (list backend (list rootdir)) rev1 rev2
+ (called-interactively-p 'interactive)))))
+
(declare-function ediff-load-version-control "ediff" (&optional silent))
(declare-function ediff-vc-internal "ediff-vers"
(rev1 rev2 &optional startup-hooks))
@@ -1908,10 +1953,8 @@ The optional argument NOT-URGENT non-nil means it is ok to say no to
saving the buffer."
(interactive (list current-prefix-arg t))
(if historic
- ;; FIXME: this does not work right, `vc-version-diff' ends up
- ;; calling `vc-deduce-fileset' to find the files to diff, and
- ;; that's not what we want here, we want the diff for the VC root dir.
- (call-interactively 'vc-version-diff)
+ ;; We want the diff for the VC root dir.
+ (call-interactively 'vc-root-version-diff)
(when buffer-file-name (vc-buffer-sync not-urgent))
(let ((backend (vc-deduce-backend))
(default-directory default-directory)
@@ -1967,6 +2010,13 @@ If `F.~REV~' already exists, use it instead of checking it out again."
(defun vc-find-revision (file revision &optional backend)
"Read REVISION of FILE into a buffer and return the buffer.
Use BACKEND as the VC backend if specified."
+ (if vc-find-revision-no-save
+ (vc-find-revision-no-save file revision backend)
+ (vc-find-revision-save file revision backend)))
+
+(defun vc-find-revision-save (file revision &optional backend)
+ "Read REVISION of FILE into a buffer and return the buffer.
+Saves the buffer to the file."
(let ((automatic-backup (vc-version-backup-file-name file revision))
(filebuf (or (get-file-buffer file) (current-buffer)))
(filename (vc-version-backup-file-name file revision 'manual)))
@@ -2002,6 +2052,51 @@ Use BACKEND as the VC backend if specified."
(set (make-local-variable 'vc-parent-buffer) filebuf))
result-buf)))
+(defun vc-find-revision-no-save (file revision &optional backend buffer)
+ "Read REVISION of FILE into BUFFER and return the buffer.
+If BUFFER omitted or nil, this function creates a new buffer and sets
+`buffer-file-name' to the name constructed from the file name and the
+revision number.
+Unlike `vc-find-revision-save', doesn't save the buffer to the file."
+ (let* ((buffer (when (buffer-live-p buffer) buffer))
+ (filebuf (or buffer (get-file-buffer file) (current-buffer)))
+ (filename (unless buffer (vc-version-backup-file-name file revision 'manual))))
+ (unless (and (not buffer)
+ (or (get-file-buffer filename)
+ (file-exists-p filename)))
+ (with-current-buffer filebuf
+ (let ((failed t))
+ (unwind-protect
+ (with-current-buffer (or buffer (create-file-buffer filename))
+ (unless buffer (setq buffer-file-name filename))
+ (let ((outbuf (current-buffer)))
+ (with-current-buffer filebuf
+ (if backend
+ (vc-call-backend backend 'find-revision file revision outbuf)
+ (vc-call find-revision file revision outbuf))))
+ (decode-coding-inserted-region (point-min) (point-max) file)
+ (after-insert-file-set-coding (- (point-max) (point-min)))
+ (goto-char (point-min))
+ (if buffer
+ ;; For non-interactive, skip any questions
+ (let ((enable-local-variables :safe) ;; to find `mode:'
+ (buffer-file-name file))
+ (ignore-errors (set-auto-mode)))
+ (normal-mode))
+ (set-buffer-modified-p nil)
+ (setq buffer-read-only t))
+ (setq failed nil)
+ (when (and failed (unless buffer (get-file-buffer filename)))
+ (with-current-buffer (get-file-buffer filename)
+ (set-buffer-modified-p nil))
+ (kill-buffer (get-file-buffer filename)))))))
+ (let ((result-buf (or buffer
+ (get-file-buffer filename)
+ (find-file-noselect filename))))
+ (with-current-buffer result-buf
+ (set (make-local-variable 'vc-parent-buffer) filebuf))
+ result-buf)))
+
;; Header-insertion code
;;;###autoload
@@ -2108,6 +2203,7 @@ changes from the current branch."
;; `default-next-file' variable for its default file (M-n), and
;; we could then set it upon mark-resolve, so C-x C-s C-x C-f M-n would
;; automatically offer the next conflicted file.
+;;;###autoload
(defun vc-find-conflicted-file ()
"Visit the next conflicted file in the current project."
(interactive)
@@ -2178,7 +2274,8 @@ otherwise use the repository root of the current buffer.
If NAME is empty, it refers to the latest revisions of the current branch.
If locking is used for the files in DIR, then there must not be any
locked files at or below DIR (but if NAME is empty, locked files are
-allowed and simply skipped)."
+allowed and simply skipped).
+This function runs the hook `vc-retrieve-tag-hook' when finished."
(interactive
(let* ((granularity
(vc-call-backend (vc-responsible-backend default-directory)
@@ -2205,6 +2302,7 @@ allowed and simply skipped)."
(vc-call-backend (vc-responsible-backend dir)
'retrieve-tag dir name update)
(vc-resynch-buffer dir t t t)
+ (run-hooks 'vc-retrieve-tag-hook)
(message "%s" (concat msg "done"))))
@@ -2294,11 +2392,11 @@ earlier revisions. Show up to LIMIT entries (non-nil means unlimited)."
setup-buttons-func
goto-location-func
rev-buff-func)
- (let (retval)
- (with-current-buffer (get-buffer-create buffer-name)
+ (let (retval (buffer (get-buffer-create buffer-name)))
+ (with-current-buffer buffer
(set (make-local-variable 'vc-log-view-type) type))
(setq retval (funcall backend-func backend buffer-name type files))
- (with-current-buffer (get-buffer buffer-name)
+ (with-current-buffer buffer
(let ((inhibit-read-only t))
;; log-view-mode used to be called with inhibit-read-only bound
;; to t, so let's keep doing it, just in case.
@@ -2309,7 +2407,7 @@ earlier revisions. Show up to LIMIT entries (non-nil means unlimited)."
rev-buff-func)))
;; Display after setting up major-mode, so display-buffer-alist can know
;; the major-mode.
- (pop-to-buffer buffer-name)
+ (pop-to-buffer buffer)
(vc-run-delayed
(let ((inhibit-read-only t))
(funcall setup-buttons-func backend files retval)
@@ -2429,17 +2527,41 @@ When called interactively with a prefix argument, prompt for REMOTE-LOCATION."
"*vc-outgoing*" 'log-outgoing)))
;;;###autoload
+(defun vc-log-mergebase (_files rev1 rev2)
+ "Show a log of changes between the merge base of REV1 and REV2 revisions.
+The merge base is a common ancestor between REV1 and REV2 revisions."
+ (interactive
+ (vc-diff-build-argument-list-internal
+ (or (ignore-errors (vc-deduce-fileset t))
+ (let ((backend (or (vc-deduce-backend) (vc-responsible-backend default-directory))))
+ (list backend (list (vc-call-backend backend 'root default-directory)))))))
+ (let ((backend (vc-deduce-backend))
+ (default-directory default-directory)
+ rootdir)
+ (if backend
+ (setq rootdir (vc-call-backend backend 'root default-directory))
+ (setq rootdir (read-directory-name "Directory for VC root-log: "))
+ (setq backend (vc-responsible-backend rootdir))
+ (unless backend
+ (error "Directory is not version controlled")))
+ (setq default-directory rootdir)
+ (setq rev1 (vc-call-backend backend 'mergebase rev1 rev2))
+ (vc-print-log-internal backend (list rootdir) rev1 t (or rev2 ""))))
+
+;;;###autoload
(defun vc-region-history (from to)
"Show the history of the region between FROM and TO.
If called interactively, show the history between point and
mark."
(interactive "r")
- (let* ((lfrom (line-number-at-pos from))
- (lto (line-number-at-pos (1- to)))
+ (let* ((lfrom (line-number-at-pos from t))
+ (lto (line-number-at-pos (1- to) t))
(file buffer-file-name)
(backend (vc-backend file))
(buf (get-buffer-create "*VC-history*")))
+ (unless backend
+ (error "Buffer is not version controlled"))
(with-current-buffer buf
(setq-local vc-log-view-type 'long))
(vc-call region-history file buf lfrom lto)
@@ -2592,7 +2714,8 @@ its name; otherwise return nil."
(vc-delete-automatic-version-backups file))
(vc-call revert file backup-file))
`((vc-state . up-to-date)
- (vc-checkout-time . ,(nth 5 (file-attributes file)))))
+ (vc-checkout-time . ,(file-attribute-modification-time
+ (file-attributes file)))))
(vc-resynch-buffer file t t))
;;;###autoload
@@ -2703,7 +2826,8 @@ If called interactively, read FILE, defaulting to the current
buffer's file name if it's under version control."
(interactive (list (read-file-name "VC delete file: " nil
(when (vc-backend buffer-file-name)
- buffer-file-name) t)))
+ buffer-file-name)
+ t)))
(setq file (expand-file-name file))
(let ((buf (get-file-buffer file))
(backend (vc-backend file)))
diff --git a/lisp/vcursor.el b/lisp/vcursor.el
index 84482ef6b85..3e8b6ee838e 100644
--- a/lisp/vcursor.el
+++ b/lisp/vcursor.el
@@ -815,8 +815,7 @@ out how much to copy."
(define-minor-mode vcursor-use-vcursor-map
"Toggle the state of the vcursor key map.
-With a prefix argument ARG, enable it if ARG is positive, and disable
-it otherwise. If called from Lisp, enable it if ARG is omitted or nil.
+
When on, the keys defined in it are mapped directly on top of the main
keymap, allowing you to move the vcursor with ordinary motion keys.
An indication \"!VC\" appears in the mode list. The effect is
diff --git a/lisp/version.el b/lisp/version.el
index cb9d0442ccf..d13d8c31e80 100644
--- a/lisp/version.el
+++ b/lisp/version.el
@@ -99,15 +99,15 @@ to the system configuration; look at `system-configuration' instead."
;; We hope that this alias is easier for people to find.
(defalias 'version 'emacs-version)
+(define-obsolete-variable-alias 'emacs-bzr-version
+ 'emacs-repository-version "24.4")
+
;; Set during dumping, this is a defvar so that it can be setq'd.
(defvar emacs-repository-version nil
"String giving the repository revision from which this Emacs was built.
Value is nil if Emacs was not built from a repository checkout,
or if we could not determine the revision.")
-(define-obsolete-variable-alias 'emacs-bzr-version
- 'emacs-repository-version "24.4")
-
(define-obsolete-function-alias 'emacs-bzr-get-version
'emacs-repository-get-version "24.4")
@@ -135,6 +135,34 @@ Optional argument DIR is a directory to use instead of `source-directory'.
Optional argument EXTERNAL is ignored."
(emacs-repository-version-git (or dir source-directory)))
+(defvar emacs-repository-branch nil
+ "String giving the repository branch from which this Emacs was built.
+Value is nil if Emacs was not built from a repository checkout,
+or if we could not determine the branch.")
+
+(defun emacs-repository-branch-git (dir)
+ "Ask git itself for the branch information for directory DIR."
+ (message "Waiting for git...")
+ (with-temp-buffer
+ (let ((default-directory (file-name-as-directory dir)))
+ (and (zerop
+ (with-demoted-errors "Error running git rev-parse --abbrev-ref: %S"
+ (call-process "git" nil '(t nil) nil
+ "rev-parse" "--abbrev-ref" "HEAD")))
+ (goto-char (point-min))
+ (buffer-substring (point) (line-end-position))))))
+
+(defun emacs-repository-get-branch (&optional dir)
+ "Try to return as a string the repository branch of the Emacs sources.
+The format of the returned string is dependent on the VCS in use.
+Value is nil if the sources do not seem to be under version
+control, or if we could not determine the branch. Note that
+this reports on the current state of the sources, which may not
+correspond to the running Emacs.
+
+Optional argument DIR is a directory to use instead of `source-directory'."
+ (emacs-repository-branch-git (or dir source-directory)))
+
;; We put version info into the executable in the form that `ident' uses.
(purecopy (concat "\n$Id: " (subst-char-in-string ?\n ?\s (emacs-version))
" $\n"))
diff --git a/lisp/view.el b/lisp/view.el
index 3d423f17480..e74ce1e8888 100644
--- a/lisp/view.el
+++ b/lisp/view.el
@@ -381,9 +381,6 @@ own View-like bindings."
;; bindings instead of using the \\[] construction. The reason for this
;; is that most commands have more than one key binding.
"Toggle View mode, a minor mode for viewing text but not editing it.
-With a prefix argument ARG, enable View mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable View mode
-if ARG is omitted or nil.
When View mode is enabled, commands that do not change the buffer
contents are available as usual. Kill commands insert text in
diff --git a/lisp/w32-fns.el b/lisp/w32-fns.el
index 938331d5372..8762fe772b8 100644
--- a/lisp/w32-fns.el
+++ b/lisp/w32-fns.el
@@ -31,13 +31,15 @@
;;;; Function keys
-(declare-function set-message-beep "w32fns.c" (sound))
(declare-function w32-get-locale-info "w32proc.c" (lcid &optional longform))
(declare-function w32-get-valid-locale-ids "w32proc.c" ())
-;; Map all versions of a filename (8.3, longname, mixed case) to the
-;; same buffer.
-(setq find-file-visit-truename t)
+(if (eq system-type 'windows-nt)
+ ;; Map all versions of a filename (8.3, longname, mixed case) to the
+ ;; same buffer.
+ (setq find-file-visit-truename t))
+
+;;;; Shells
(defun w32-shell-name ()
"Return the name of the shell being used."
@@ -120,28 +122,24 @@ You should set this to t when using a non-system shell.\n\n"))))
(add-hook 'after-init-hook 'w32-check-shell-configuration)
+;;;; Coding-systems, locales, etc.
+
;; Override setting chosen at startup.
(defun w32-set-default-process-coding-system ()
;; Most programs on Windows will accept Unix line endings on input
;; (and some programs ported from Unix require it) but most will
;; produce DOS line endings on output.
(setq default-process-coding-system
- (if (default-value 'enable-multibyte-characters)
- '(undecided-dos . undecided-unix)
- '(raw-text-dos . raw-text-unix)))
+ '(undecided-dos . undecided-unix))
;; Make cmdproxy default to using DOS line endings for input,
;; because some Windows programs (including command.com) require it.
(add-to-list 'process-coding-system-alist
- `("[cC][mM][dD][pP][rR][oO][xX][yY]"
- . ,(if (default-value 'enable-multibyte-characters)
- '(undecided-dos . undecided-dos)
- '(raw-text-dos . raw-text-dos))))
+ '("[cC][mM][dD][pP][rR][oO][xX][yY]"
+ . (undecided-dos . undecided-dos)))
;; plink needs DOS input when entering the password.
(add-to-list 'process-coding-system-alist
- `("[pP][lL][iI][nN][kK]"
- . ,(if (default-value 'enable-multibyte-characters)
- '(undecided-dos . undecided-dos)
- '(raw-text-dos . raw-text-dos)))))
+ '("[pP][lL][iI][nN][kK]"
+ . (undecided-dos . undecided-dos))))
(define-obsolete-function-alias 'set-default-process-coding-system
#'w32-set-default-process-coding-system "26.1")
(add-hook 'before-init-hook #'w32-set-default-process-coding-system)
@@ -193,31 +191,6 @@ You should set this to t when using a non-system shell.\n\n"))))
;; (setq source-directory (file-name-as-directory
;; (expand-file-name ".." exec-directory)))))
-(defun w32-convert-standard-filename (filename)
- "Convert a standard file's name to something suitable for MS-Windows.
-This means to guarantee valid names and perhaps to canonicalize
-certain patterns.
-
-This function is called by `convert-standard-filename'.
-
-Replace invalid characters and turn Cygwin names into native
-names."
- (save-match-data
- (let ((name
- (if (string-match "\\`/cygdrive/\\([a-zA-Z]\\)/" filename)
- (replace-match "\\1:/" t nil filename)
- (copy-sequence filename)))
- (start 0))
- ;; leave ':' if part of drive specifier
- (if (and (> (length name) 1)
- (eq (aref name 1) ?:))
- (setq start 2))
- ;; destructively replace invalid filename characters with !
- (while (string-match "[?*:<>|\"\000-\037]" name start)
- (aset name (match-beginning 0) ?!)
- (setq start (match-end 0)))
- name)))
-
(defun w32-set-system-coding-system (coding-system)
"Set the coding system used by the Windows system to CODING-SYSTEM.
This is used for things like passing font names with non-ASCII
@@ -242,7 +215,8 @@ This function is provided for backward compatibility, since
(defvaralias 'w32-system-coding-system 'locale-coding-system)
;; Set to a system sound if you want a fancy bell.
-(set-message-beep nil)
+(if (fboundp 'set-message-beep) ; w32fns.c
+ (set-message-beep nil))
(defvar w32-charset-info-alist) ; w32font.c
@@ -259,47 +233,118 @@ bit output with no translation."
(add-to-list 'w32-charset-info-alist
(cons xlfd-charset (cons windows-charset codepage))))
-;; The last charset we add becomes the "preferred" charset for the return
-;; value from x-select-font etc, so list the most important charsets last.
-(w32-add-charset-info "iso8859-14" 'w32-charset-ansi 28604)
-(w32-add-charset-info "iso8859-15" 'w32-charset-ansi 28605)
-;; The following two are included for pattern matching.
-(w32-add-charset-info "jisx0201" 'w32-charset-shiftjis 932)
-(w32-add-charset-info "jisx0208" 'w32-charset-shiftjis 932)
-(w32-add-charset-info "jisx0201-latin" 'w32-charset-shiftjis 932)
-(w32-add-charset-info "jisx0201-katakana" 'w32-charset-shiftjis 932)
-(w32-add-charset-info "ksc5601.1989" 'w32-charset-hangeul 949)
-(w32-add-charset-info "big5" 'w32-charset-chinesebig5 950)
-(w32-add-charset-info "gb2312.1980" 'w32-charset-gb2312 936)
-(w32-add-charset-info "ms-symbol" 'w32-charset-symbol nil)
-(w32-add-charset-info "ms-oem" 'w32-charset-oem 437)
-(w32-add-charset-info "ms-oemlatin" 'w32-charset-oem 850)
-(w32-add-charset-info "iso8859-2" 'w32-charset-easteurope 28592)
-(w32-add-charset-info "iso8859-3" 'w32-charset-turkish 28593)
-(w32-add-charset-info "iso8859-4" 'w32-charset-baltic 28594)
-(w32-add-charset-info "iso8859-6" 'w32-charset-arabic 28596)
-(w32-add-charset-info "iso8859-7" 'w32-charset-greek 28597)
-(w32-add-charset-info "iso8859-8" 'w32-charset-hebrew 1255)
-(w32-add-charset-info "iso8859-9" 'w32-charset-turkish 1254)
-(w32-add-charset-info "iso8859-13" 'w32-charset-baltic 1257)
-(w32-add-charset-info "koi8-r" 'w32-charset-russian 20866)
-(w32-add-charset-info "iso8859-5" 'w32-charset-russian 28595)
-(w32-add-charset-info "tis620-2533" 'w32-charset-thai 874)
-(w32-add-charset-info "windows-1258" 'w32-charset-vietnamese 1258)
-(w32-add-charset-info "ksc5601.1992" 'w32-charset-johab 1361)
-(w32-add-charset-info "mac-roman" 'w32-charset-mac 10000)
-(w32-add-charset-info "iso10646-1" 'w32-charset-default t)
-
-;; ;; If Unicode Windows charset is not defined, use ansi fonts.
-;; (w32-add-charset-info "iso10646-1" 'w32-charset-ansi t))
-
-;; Preferred names
-(w32-add-charset-info "big5-0" 'w32-charset-chinesebig5 950)
-(w32-add-charset-info "gb2312.1980-0" 'w32-charset-gb2312 936)
-(w32-add-charset-info "jisx0208-sjis" 'w32-charset-shiftjis 932)
-(w32-add-charset-info "ksc5601.1987-0" 'w32-charset-hangeul 949)
-(w32-add-charset-info "tis620-0" 'w32-charset-thai 874)
-(w32-add-charset-info "iso8859-1" 'w32-charset-ansi 1252)
+(when (boundp 'w32-charset-info-alist)
+ ;; The last charset we add becomes the "preferred" charset for the return
+ ;; value from x-select-font etc, so list the most important charsets last.
+ (w32-add-charset-info "iso8859-14" 'w32-charset-ansi 28604)
+ (w32-add-charset-info "iso8859-15" 'w32-charset-ansi 28605)
+ ;; The following two are included for pattern matching.
+ (w32-add-charset-info "jisx0201" 'w32-charset-shiftjis 932)
+ (w32-add-charset-info "jisx0208" 'w32-charset-shiftjis 932)
+ (w32-add-charset-info "jisx0201-latin" 'w32-charset-shiftjis 932)
+ (w32-add-charset-info "jisx0201-katakana" 'w32-charset-shiftjis 932)
+ (w32-add-charset-info "ksc5601.1989" 'w32-charset-hangeul 949)
+ (w32-add-charset-info "big5" 'w32-charset-chinesebig5 950)
+ (w32-add-charset-info "gb2312.1980" 'w32-charset-gb2312 936)
+ (w32-add-charset-info "ms-symbol" 'w32-charset-symbol nil)
+ (w32-add-charset-info "ms-oem" 'w32-charset-oem 437)
+ (w32-add-charset-info "ms-oemlatin" 'w32-charset-oem 850)
+ (w32-add-charset-info "iso8859-2" 'w32-charset-easteurope 28592)
+ (w32-add-charset-info "iso8859-3" 'w32-charset-turkish 28593)
+ (w32-add-charset-info "iso8859-4" 'w32-charset-baltic 28594)
+ (w32-add-charset-info "iso8859-6" 'w32-charset-arabic 28596)
+ (w32-add-charset-info "iso8859-7" 'w32-charset-greek 28597)
+ (w32-add-charset-info "iso8859-8" 'w32-charset-hebrew 1255)
+ (w32-add-charset-info "iso8859-9" 'w32-charset-turkish 1254)
+ (w32-add-charset-info "iso8859-13" 'w32-charset-baltic 1257)
+ (w32-add-charset-info "koi8-r" 'w32-charset-russian 20866)
+ (w32-add-charset-info "tis620-2533" 'w32-charset-russian 28595)
+ (w32-add-charset-info "iso8859-11" 'w32-charset-thai 874)
+ (w32-add-charset-info "windows-1258" 'w32-charset-vietnamese 1258)
+ (w32-add-charset-info "ksc5601.1992" 'w32-charset-johab 1361)
+ (w32-add-charset-info "mac-roman" 'w32-charset-mac 10000)
+ (w32-add-charset-info "iso10646-1" 'w32-charset-default t)
+
+ ;; ;; If Unicode Windows charset is not defined, use ansi fonts.
+ ;; (w32-add-charset-info "iso10646-1" 'w32-charset-ansi t))
+
+ ;; Preferred names
+ (w32-add-charset-info "big5-0" 'w32-charset-chinesebig5 950)
+ (w32-add-charset-info "gb2312.1980-0" 'w32-charset-gb2312 936)
+ (w32-add-charset-info "jisx0208-sjis" 'w32-charset-shiftjis 932)
+ (w32-add-charset-info "ksc5601.1987-0" 'w32-charset-hangeul 949)
+ (w32-add-charset-info "tis620-0" 'w32-charset-thai 874)
+ (w32-add-charset-info "iso8859-1" 'w32-charset-ansi 1252))
+
+;;;; Standard filenames
+
+(defun w32-convert-standard-filename (filename)
+ "Convert a standard file's name to something suitable for MS-Windows.
+This means to guarantee valid names and perhaps to canonicalize
+certain patterns.
+
+This function is called by `convert-standard-filename'.
+
+Replace invalid characters and turn Cygwin names into native
+names."
+ (save-match-data
+ (let ((name
+ (if (string-match "\\`/cygdrive/\\([a-zA-Z]\\)/" filename)
+ (replace-match "\\1:/" t nil filename)
+ (copy-sequence filename)))
+ (start 0))
+ ;; leave ':' if part of drive specifier
+ (if (and (> (length name) 1)
+ (eq (aref name 1) ?:))
+ (setq start 2))
+ ;; destructively replace invalid filename characters with !
+ (while (string-match "[?*:<>|\"\000-\037]" name start)
+ (aset name (match-beginning 0) ?!)
+ (setq start (match-end 0)))
+ name)))
+
+;;;; System name and version for emacsbug.el
+
+(defun w32--os-description ()
+ "Return a string describing the underlying OS and its version."
+ (let* ((w32ver (car (w32-version)))
+ (w9x-p (< w32ver 5))
+ (key (if w9x-p
+ "SOFTWARE/Microsoft/Windows/CurrentVersion"
+ "SOFTWARE/Microsoft/Windows NT/CurrentVersion"))
+ (os-name (w32-read-registry 'HKLM key "ProductName"))
+ (os-version (if w9x-p
+ (w32-read-registry 'HKLM key "VersionNumber")
+ (let ((vmajor
+ (w32-read-registry 'HKLM key
+ "CurrentMajorVersionNumber"))
+ (vminor
+ (w32-read-registry 'HKLM key
+ "CurrentMinorVersionNumber")))
+ (if (and vmajor vmajor)
+ (format "%d.%d" vmajor vminor)
+ (w32-read-registry 'HKLM key "CurrentVersion")))))
+ (os-csd (w32-read-registry 'HKLM key "CSDVersion"))
+ (os-rel (or (w32-read-registry 'HKLM key "ReleaseID")
+ (w32-read-registry 'HKLM key "CSDBuildNumber")
+ "0")) ; No Release ID before Windows Vista
+ (os-build (w32-read-registry 'HKLM key "CurrentBuildNumber"))
+ (os-rev (w32-read-registry 'HKLM key "UBR"))
+ (os-rev (if os-rev (format "%d" os-rev))))
+ (if w9x-p
+ (concat
+ (if (not (string-match "\\`Microsoft " os-name)) "Microsoft ")
+ os-name
+ " (v" os-version ")")
+ (concat
+ (if (not (string-match "\\`Microsoft " os-name)) "Microsoft ")
+ os-name ; Windows 7 Enterprise
+ " "
+ os-csd ; Service Pack 1
+ (if (and os-csd (> (length os-csd) 0)) " " "")
+ "(v"
+ os-version "." os-rel "." os-build (if os-rev (concat "." os-rev))
+ ")"))))
;;;; Support for build process
diff --git a/lisp/w32-vars.el b/lisp/w32-vars.el
index 72acf205ff7..2861a3572da 100644
--- a/lisp/w32-vars.el
+++ b/lisp/w32-vars.el
@@ -47,10 +47,6 @@ after changing the value of this variable."
(setq mouse-appearance-menu-map nil))
:group 'w32)
-(defvar w32-list-proportional-fonts nil
- "Include proportional fonts in the default font dialog.")
-(make-obsolete-variable 'w32-list-proportional-fonts "no longer used." "23.1")
-
(unless (eq system-type 'cygwin)
(defcustom w32-allow-system-shell nil
"Disable startup warning when using \"system\" shells."
diff --git a/lisp/wdired.el b/lisp/wdired.el
index cf73b7bf249..acc62e4e391 100644
--- a/lisp/wdired.el
+++ b/lisp/wdired.el
@@ -255,6 +255,7 @@ See `wdired-mode'."
(setq buffer-read-only nil)
(dired-unadvertise default-directory)
(add-hook 'kill-buffer-hook 'wdired-check-kill-buffer nil t)
+ (add-hook 'after-change-functions 'wdired--restore-dired-filename-prop nil t)
(setq major-mode 'wdired-mode)
(setq mode-name "Editable Dired")
(setq revert-buffer-function 'wdired-revert)
@@ -363,6 +364,7 @@ non-nil means return old filename."
(setq mode-name "Dired")
(dired-advertise)
(remove-hook 'kill-buffer-hook 'wdired-check-kill-buffer t)
+ (remove-hook 'after-change-functions 'wdired--restore-dired-filename-prop t)
(set (make-local-variable 'revert-buffer-function) 'dired-revert))
@@ -381,7 +383,6 @@ non-nil means return old filename."
(defun wdired-finish-edit ()
"Actually rename files based on your editing in the Dired buffer."
(interactive)
- (wdired-change-to-dired-mode)
(let ((changes nil)
(errors 0)
files-deleted
@@ -423,6 +424,11 @@ non-nil means return old filename."
(forward-line -1)))
(when files-renamed
(setq errors (+ errors (wdired-do-renames files-renamed))))
+ ;; We have to be in wdired-mode when wdired-do-renames is executed
+ ;; so that wdired--restore-dired-filename-prop runs, but we have
+ ;; to change back to dired-mode before reverting the buffer to
+ ;; avoid using wdired-revert, which changes back to wdired-mode.
+ (wdired-change-to-dired-mode)
(if changes
(progn
;; If we are displaying a single file (rather than the
@@ -543,39 +549,25 @@ and proceed depending on the answer."
(goto-char (point-max))
(forward-line -1)
(let ((done nil)
- (failed t)
+ (failed t)
curr-filename)
(while (and (not done) (not (bobp)))
(setq curr-filename (wdired-get-filename nil t))
(if (equal curr-filename filename-ori)
- (unwind-protect
- (progn
- (setq done t)
- (let ((inhibit-read-only t))
- ;; Remove dired-filename text property in order to
- ;; find filename-new when it only partially
- ;; replaces filename-ori (bug#32173); the text
- ;; property is added again when renaming succeeds.
- (remove-text-properties
- (line-beginning-position) (line-end-position)
- '(dired-filename nil))
- (dired-move-to-filename)
- (search-forward (wdired-get-filename t) nil t)
- (replace-match (file-name-nondirectory filename-ori) t t))
- (dired-do-create-files-regexp
- (function dired-rename-file)
- "Move" 1 ".*" filename-new nil t)
- (setq failed nil))
- ;; If user quits before renaming succeeds, restore the
- ;; dired-filename text property.
- (when failed
- (beginning-of-line)
- (let ((beg (re-search-forward
- directory-listing-before-filename-regexp
- (line-end-position) t))
- (end (dired-move-to-end-of-filename))
- (inhibit-read-only t))
- (add-text-properties beg end '(dired-filename t)))))
+ (unwind-protect
+ (progn
+ (setq done t)
+ (let ((inhibit-read-only t))
+ (dired-move-to-filename)
+ (search-forward (wdired-get-filename t) nil t)
+ (replace-match (file-name-nondirectory filename-ori) t t))
+ (dired-do-create-files-regexp
+ (function dired-rename-file)
+ "Move" 1 ".*" filename-new nil t)
+ (setq failed nil))
+ ;; If user types C-g when prompted to change the file
+ ;; name, make sure we return to dired-mode.
+ (when failed (wdired-change-to-dired-mode)))
(forward-line -1))))))
;; marks a list of files for deletion
@@ -606,6 +598,32 @@ Optional arguments are ignored."
(not (y-or-n-p "Buffer changed. Discard changes and kill buffer? ")))
(error "Error")))
+;; Added to after-change-functions in wdired-change-to-wdired-mode to
+;; ensure that, on editing a file name, new characters get the
+;; dired-filename text property, which allows functions that look for
+;; this property (e.g. dired-isearch-filenames) to work in wdired-mode
+;; and also avoids an error with non-nil wdired-use-interactive-rename
+;; (bug#32173).
+(defun wdired--restore-dired-filename-prop (beg end _len)
+ (save-match-data
+ (save-excursion
+ (let ((lep (line-end-position)))
+ (beginning-of-line)
+ (when (re-search-forward
+ directory-listing-before-filename-regexp lep t)
+ (setq beg (point)
+ ;; If the file is a symlink, put the dired-filename
+ ;; property only on the link name. (Using
+ ;; (file-symlink-p (dired-get-filename)) fails in
+ ;; wdired-mode, bug#32673.)
+ end (if (and (re-search-backward
+ dired-permission-flags-regexp nil t)
+ (looking-at "l")
+ (search-forward " -> " lep t))
+ (goto-char (match-beginning 0))
+ lep))
+ (put-text-property beg end 'dired-filename t))))))
+
(defun wdired-next-line (arg)
"Move down lines then position at filename or the current column.
See `wdired-use-dired-vertical-movement'. Optional prefix ARG
diff --git a/lisp/whitespace.el b/lisp/whitespace.el
index 79bc5c88348..2463e655b19 100644
--- a/lisp/whitespace.el
+++ b/lisp/whitespace.el
@@ -2,8 +2,8 @@
;; Copyright (C) 2000-2019 Free Software Foundation, Inc.
-;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
-;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
+;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: data, wp
;; Version: 13.2.2
;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
@@ -924,11 +924,6 @@ Any other value is treated as nil."
;;;###autoload
(define-minor-mode whitespace-mode
"Toggle whitespace visualization (Whitespace mode).
-With a prefix argument ARG, enable Whitespace mode if ARG is
-positive, and disable it otherwise.
-
-If called from Lisp, also enables the mode if ARG is omitted or nil,
-and toggles it if ARG is `toggle'.
See also `whitespace-style', `whitespace-newline' and
`whitespace-display-mappings'."
@@ -949,11 +944,6 @@ See also `whitespace-style', `whitespace-newline' and
;;;###autoload
(define-minor-mode whitespace-newline-mode
"Toggle newline visualization (Whitespace Newline mode).
-With a prefix argument ARG, enable Whitespace Newline mode if ARG
-is positive, and disable it otherwise.
-
-If called from Lisp, also enables the mode if ARG is omitted or nil,
-and toggles it if ARG is `toggle'.
Use `whitespace-newline-mode' only for NEWLINE visualization
exclusively. For other visualizations, including NEWLINE
@@ -979,11 +969,6 @@ See also `whitespace-newline' and `whitespace-display-mappings'."
;;;###autoload
(define-minor-mode global-whitespace-mode
"Toggle whitespace visualization globally (Global Whitespace mode).
-With a prefix argument ARG, enable Global Whitespace mode if ARG
-is positive, and disable it otherwise.
-
-If called from Lisp, also enables the mode if ARG is omitted or nil,
-and toggles it if ARG is `toggle'.
See also `whitespace-style', `whitespace-newline' and
`whitespace-display-mappings'."
@@ -1040,11 +1025,6 @@ This variable is normally modified via `add-function'.")
;;;###autoload
(define-minor-mode global-whitespace-newline-mode
"Toggle global newline visualization (Global Whitespace Newline mode).
-With a prefix argument ARG, enable Global Whitespace Newline mode
-if ARG is positive, and disable it otherwise.
-
-If called from Lisp, also enables the mode if ARG is omitted or nil,
-and toggles it if ARG is `toggle'.
Use `global-whitespace-newline-mode' only for NEWLINE
visualization exclusively. For other visualizations, including
@@ -1728,7 +1708,7 @@ cleaning up these problems."
(setq has-bogus (memq (car option) style)))
t)))
whitespace-report-list)))
- (when (pcase report-if-bogus (`nil t) (`never nil) (_ has-bogus))
+ (when (pcase report-if-bogus ('nil t) ('never nil) (_ has-bogus))
(whitespace-kill-buffer whitespace-report-buffer-name)
;; `indent-tabs-mode' may be local to current buffer
;; `tab-width' may be local to current buffer
diff --git a/lisp/wid-browse.el b/lisp/wid-browse.el
index 0094152ddfe..dbc41009c77 100644
--- a/lisp/wid-browse.el
+++ b/lisp/wid-browse.el
@@ -269,10 +269,7 @@ VALUE is assumed to be a list of widgets."
;;;###autoload
(define-minor-mode widget-minor-mode
- "Minor mode for traversing widgets.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil."
+ "Minor mode for traversing widgets."
:lighter " Widget")
;;; The End:
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index 52c0b5b74d2..b9f98cdc4c7 100644
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -1163,8 +1163,9 @@ When not inside a field, signal an error."
(defun widget-at (&optional pos)
"The button or field at POS (default, point)."
- (or (get-char-property (or pos (point)) 'button)
- (widget-field-at pos)))
+ (let ((widget (or (get-char-property (or pos (point)) 'button)
+ (widget-field-at pos))))
+ (and (widgetp widget) widget)))
;;;###autoload
(defun widget-setup ()
diff --git a/lisp/windmove.el b/lisp/windmove.el
index cf7b65a6ed7..0853f7ec7f9 100644
--- a/lisp/windmove.el
+++ b/lisp/windmove.el
@@ -1,4 +1,4 @@
-;;; windmove.el --- directional window-selection routines
+;;; windmove.el --- directional window-selection routines -*- lexical-binding:t -*-
;;
;; Copyright (C) 1998-2019 Free Software Foundation, Inc.
;;
@@ -149,6 +149,15 @@ is inactive."
:type 'boolean
:group 'windmove)
+(defcustom windmove-create-window nil
+ "Whether movement off the edge of the frame creates a new window.
+If this variable is set to t, moving left from the leftmost window in
+a frame will create a new window on the left, and similarly for the other
+directions."
+ :type 'boolean
+ :group 'windmove
+ :version "27.1")
+
;; If your Emacs sometimes places an empty column between two adjacent
;; windows, you may wish to set this delta to 2.
(defcustom windmove-window-distance-delta 1
@@ -159,8 +168,7 @@ placement bugs in old versions of Emacs."
:type 'number
:group 'windmove)
-
-
+
;; Implementation overview:
;;
;; The conceptual framework behind this code is all fairly simple. We
@@ -459,25 +467,28 @@ movement is relative to."
windmove-window-distance-delta))) ; (x, y1+d-1)
(t (error "Invalid direction of movement: %s" dir)))))
+
;; Rewritten on 2013-12-13 using `window-in-direction'. After the
;; pixelwise change the old approach didn't work any more. martin
(defun windmove-find-other-window (dir &optional arg window)
"Return the window object in direction DIR.
DIR, ARG, and WINDOW are handled as by `windmove-other-window-loc'."
- (window-in-direction
- (cond
- ((eq dir 'up) 'above)
- ((eq dir 'down) 'below)
- (t dir))
- window nil arg windmove-wrap-around t))
+ (window-in-direction dir window nil arg windmove-wrap-around t))
;; Selects the window that's hopefully at the location returned by
;; `windmove-other-window-loc', or screams if there's no window there.
(defun windmove-do-window-select (dir &optional arg window)
"Move to the window at direction DIR.
DIR, ARG, and WINDOW are handled as by `windmove-other-window-loc'.
-If no window is at direction DIR, an error is signaled."
+If no window is at direction DIR, an error is signaled.
+If `windmove-create-window' is non-nil, try to create a new window
+in direction DIR instead."
(let ((other-window (windmove-find-other-window dir arg window)))
+ (when (and windmove-create-window
+ (or (null other-window)
+ (and (window-minibuffer-p other-window)
+ (not (minibuffer-window-active-p other-window)))))
+ (setq other-window (split-window window nil dir)))
(cond ((null other-window)
(user-error "No window %s from selected window" dir))
((and (window-minibuffer-p other-window)
@@ -486,9 +497,9 @@ If no window is at direction DIR, an error is signaled."
(t
(select-window other-window)))))
-
-;;; end-user functions
-;; these are all simple interactive wrappers to
+
+;;; End-user functions
+;; These are all simple interactive wrappers to
;; `windmove-do-window-select', meant to be bound to keys.
;;;###autoload
@@ -498,9 +509,10 @@ With no prefix argument, or with prefix argument equal to zero,
\"left\" is relative to the position of point in the window; otherwise
it is relative to the top edge (for positive ARG) or the bottom edge
\(for negative ARG) of the current window.
-If no window is at the desired location, an error is signaled."
+If no window is at the desired location, an error is signaled
+unless `windmove-create-window' is non-nil and a new window is created."
(interactive "P")
- (windmove-do-window-select 'left arg))
+ (windmove-do-window-select 'left (and arg (prefix-numeric-value arg))))
;;;###autoload
(defun windmove-up (&optional arg)
@@ -509,9 +521,10 @@ With no prefix argument, or with prefix argument equal to zero, \"up\"
is relative to the position of point in the window; otherwise it is
relative to the left edge (for positive ARG) or the right edge (for
negative ARG) of the current window.
-If no window is at the desired location, an error is signaled."
+If no window is at the desired location, an error is signaled
+unless `windmove-create-window' is non-nil and a new window is created."
(interactive "P")
- (windmove-do-window-select 'up arg))
+ (windmove-do-window-select 'up (and arg (prefix-numeric-value arg))))
;;;###autoload
(defun windmove-right (&optional arg)
@@ -520,9 +533,10 @@ With no prefix argument, or with prefix argument equal to zero,
\"right\" is relative to the position of point in the window;
otherwise it is relative to the top edge (for positive ARG) or the
bottom edge (for negative ARG) of the current window.
-If no window is at the desired location, an error is signaled."
+If no window is at the desired location, an error is signaled
+unless `windmove-create-window' is non-nil and a new window is created."
(interactive "P")
- (windmove-do-window-select 'right arg))
+ (windmove-do-window-select 'right (and arg (prefix-numeric-value arg))))
;;;###autoload
(defun windmove-down (&optional arg)
@@ -531,9 +545,10 @@ With no prefix argument, or with prefix argument equal to zero,
\"down\" is relative to the position of point in the window; otherwise
it is relative to the left edge (for positive ARG) or the right edge
\(for negative ARG) of the current window.
-If no window is at the desired location, an error is signaled."
+If no window is at the desired location, an error is signaled
+unless `windmove-create-window' is non-nil and a new window is created."
(interactive "P")
- (windmove-do-window-select 'down arg))
+ (windmove-do-window-select 'down (and arg (prefix-numeric-value arg))))
;;; set up keybindings
@@ -543,18 +558,254 @@ If no window is at the desired location, an error is signaled."
;; probably want to use different bindings in that case.
;;;###autoload
-(defun windmove-default-keybindings (&optional modifier)
+(defun windmove-default-keybindings (&optional modifiers)
"Set up keybindings for `windmove'.
-Keybindings are of the form MODIFIER-{left,right,up,down}.
-Default MODIFIER is `shift'."
+Keybindings are of the form MODIFIERS-{left,right,up,down},
+where MODIFIERS is either a list of modifiers or a single modifier.
+Default value of MODIFIERS is `shift'."
+ (interactive)
+ (unless modifiers (setq modifiers 'shift))
+ (unless (listp modifiers) (setq modifiers (list modifiers)))
+ (global-set-key (vector (append modifiers '(left))) 'windmove-left)
+ (global-set-key (vector (append modifiers '(right))) 'windmove-right)
+ (global-set-key (vector (append modifiers '(up))) 'windmove-up)
+ (global-set-key (vector (append modifiers '(down))) 'windmove-down))
+
+
+;;; Directional window display and selection
+
+(defcustom windmove-display-no-select nil
+ "Whether the window should be selected after displaying the buffer in it."
+ :type 'boolean
+ :group 'windmove
+ :version "27.1")
+
+(defun windmove-display-in-direction (dir &optional arg)
+ "Display the next buffer in the window at direction DIR.
+The next buffer is the buffer displayed by the next command invoked
+immediately after this command (ignoring reading from the minibuffer).
+Create a new window if there is no window in that direction.
+By default, select the window with a displayed buffer.
+If prefix ARG is `C-u', reselect a previously selected window.
+If `windmove-display-no-select' is non-nil, this command doesn't
+select the window with a displayed buffer, and the meaning of
+the prefix argument is reversed.
+When `switch-to-buffer-obey-display-actions' is non-nil,
+`switch-to-buffer' commands are also supported."
+ (let* ((no-select (not (eq (consp arg) windmove-display-no-select))) ; xor
+ (old-window (or (minibuffer-selected-window) (selected-window)))
+ (new-window)
+ (minibuffer-depth (minibuffer-depth))
+ (action display-buffer-overriding-action)
+ (command this-command)
+ (clearfun (make-symbol "clear-display-buffer-overriding-action"))
+ (exitfun
+ (lambda ()
+ (setq display-buffer-overriding-action action)
+ (when (window-live-p (if no-select old-window new-window))
+ (select-window (if no-select old-window new-window)))
+ (remove-hook 'post-command-hook clearfun))))
+ (fset clearfun
+ (lambda ()
+ (unless (or
+ ;; Remove the hook immediately
+ ;; after exiting the minibuffer.
+ (> (minibuffer-depth) minibuffer-depth)
+ ;; But don't remove immediately after
+ ;; adding the hook by the same command below.
+ (eq this-command command))
+ (funcall exitfun))))
+ (add-hook 'post-command-hook clearfun)
+ (push (lambda (buffer alist)
+ (unless (> (minibuffer-depth) minibuffer-depth)
+ (let ((window (if (eq dir 'same-window)
+ (selected-window)
+ (window-in-direction
+ dir nil nil
+ (and arg (prefix-numeric-value arg))
+ windmove-wrap-around)))
+ (type 'reuse))
+ (unless window
+ (setq window (split-window nil nil dir) type 'window))
+ (setq new-window (window--display-buffer buffer window type alist)))))
+ display-buffer-overriding-action)
+ (message "[display-%s]" dir)))
+
+;;;###autoload
+(defun windmove-display-left (&optional arg)
+ "Display the next buffer in window to the left of the current one.
+See the logic of the prefix ARG in `windmove-display-in-direction'."
+ (interactive "P")
+ (windmove-display-in-direction 'left arg))
+
+;;;###autoload
+(defun windmove-display-up (&optional arg)
+ "Display the next buffer in window above the current one.
+See the logic of the prefix ARG in `windmove-display-in-direction'."
+ (interactive "P")
+ (windmove-display-in-direction 'up arg))
+
+;;;###autoload
+(defun windmove-display-right (&optional arg)
+ "Display the next buffer in window to the right of the current one.
+See the logic of the prefix ARG in `windmove-display-in-direction'."
+ (interactive "P")
+ (windmove-display-in-direction 'right arg))
+
+;;;###autoload
+(defun windmove-display-down (&optional arg)
+ "Display the next buffer in window below the current one.
+See the logic of the prefix ARG in `windmove-display-in-direction'."
+ (interactive "P")
+ (windmove-display-in-direction 'down arg))
+
+;;;###autoload
+(defun windmove-display-same-window (&optional arg)
+ "Display the next buffer in the same window."
+ (interactive "P")
+ (windmove-display-in-direction 'same-window arg))
+
+;;;###autoload
+(defun windmove-display-default-keybindings (&optional modifiers)
+ "Set up keybindings for directional buffer display.
+Keys are bound to commands that display the next buffer in the specified
+direction. Keybindings are of the form MODIFIERS-{left,right,up,down},
+where MODIFIERS is either a list of modifiers or a single modifier.
+Default value of MODIFIERS is `shift-meta'."
+ (interactive)
+ (unless modifiers (setq modifiers '(shift meta)))
+ (unless (listp modifiers) (setq modifiers (list modifiers)))
+ (global-set-key (vector (append modifiers '(left))) 'windmove-display-left)
+ (global-set-key (vector (append modifiers '(right))) 'windmove-display-right)
+ (global-set-key (vector (append modifiers '(up))) 'windmove-display-up)
+ (global-set-key (vector (append modifiers '(down))) 'windmove-display-down)
+ (global-set-key (vector (append modifiers '(?0))) 'windmove-display-same-window))
+
+
+;;; Directional window deletion
+
+(defun windmove-delete-in-direction (dir &optional arg)
+ "Delete the window at direction DIR.
+If prefix ARG is `\\[universal-argument]', also kill the buffer in that window.
+With `M-0' prefix, delete the selected window and
+select the window at direction DIR.
+When `windmove-wrap-around' is non-nil, takes the window
+from the opposite side of the frame."
+ (let ((other-window (window-in-direction dir nil nil arg
+ windmove-wrap-around t)))
+ (cond ((null other-window)
+ (user-error "No window %s from selected window" dir))
+ (t
+ (when (equal arg '(4))
+ (kill-buffer (window-buffer other-window)))
+ (if (not (equal arg 0))
+ (delete-window other-window)
+ (delete-window (selected-window))
+ (select-window other-window))))))
+
+;;;###autoload
+(defun windmove-delete-left (&optional arg)
+ "Delete the window to the left of the current one.
+If prefix ARG is `C-u', delete the selected window and
+select the window that was to the left of the current one."
+ (interactive "P")
+ (windmove-delete-in-direction 'left arg))
+
+;;;###autoload
+(defun windmove-delete-up (&optional arg)
+ "Delete the window above the current one.
+If prefix ARG is `C-u', delete the selected window and
+select the window that was above the current one."
+ (interactive "P")
+ (windmove-delete-in-direction 'up arg))
+
+;;;###autoload
+(defun windmove-delete-right (&optional arg)
+ "Delete the window to the right of the current one.
+If prefix ARG is `C-u', delete the selected window and
+select the window that was to the right of the current one."
+ (interactive "P")
+ (windmove-delete-in-direction 'right arg))
+
+;;;###autoload
+(defun windmove-delete-down (&optional arg)
+ "Delete the window below the current one.
+If prefix ARG is `C-u', delete the selected window and
+select the window that was below the current one."
+ (interactive "P")
+ (windmove-delete-in-direction 'down arg))
+
+;;;###autoload
+(defun windmove-delete-default-keybindings (&optional prefix modifiers)
+ "Set up keybindings for directional window deletion.
+Keys are bound to commands that delete windows in the specified
+direction. Keybindings are of the form PREFIX MODIFIERS-{left,right,up,down},
+where PREFIX is a prefix key and MODIFIERS is either a list of modifiers or
+a single modifier. Default value of PREFIX is `C-x' and MODIFIERS is `shift'."
(interactive)
- (unless modifier (setq modifier 'shift))
- (global-set-key (vector (list modifier 'left)) 'windmove-left)
- (global-set-key (vector (list modifier 'right)) 'windmove-right)
- (global-set-key (vector (list modifier 'up)) 'windmove-up)
- (global-set-key (vector (list modifier 'down)) 'windmove-down))
+ (unless prefix (setq prefix '(?\C-x)))
+ (unless (listp prefix) (setq prefix (list prefix)))
+ (unless modifiers (setq modifiers '(shift)))
+ (unless (listp modifiers) (setq modifiers (list modifiers)))
+ (global-set-key (vector prefix (append modifiers '(left))) 'windmove-delete-left)
+ (global-set-key (vector prefix (append modifiers '(right))) 'windmove-delete-right)
+ (global-set-key (vector prefix (append modifiers '(up))) 'windmove-delete-up)
+ (global-set-key (vector prefix (append modifiers '(down))) 'windmove-delete-down))
+
+
+;;; Directional window swap states
+
+(defun windmove-swap-states-in-direction (dir)
+ "Swap the states of the selected window and the window at direction DIR.
+When `windmove-wrap-around' is non-nil, takes the window
+from the opposite side of the frame."
+ (let ((other-window (window-in-direction dir nil nil nil
+ windmove-wrap-around t)))
+ (cond ((or (null other-window) (window-minibuffer-p other-window))
+ (user-error "No window %s from selected window" dir))
+ (t
+ (window-swap-states nil other-window)))))
+
+;;;###autoload
+(defun windmove-swap-states-left ()
+ "Swap the states with the window on the left from the current one."
+ (interactive)
+ (windmove-swap-states-in-direction 'left))
+
+;;;###autoload
+(defun windmove-swap-states-up ()
+ "Swap the states with the window above from the current one."
+ (interactive)
+ (windmove-swap-states-in-direction 'up))
+;;;###autoload
+(defun windmove-swap-states-down ()
+ "Swap the states with the window below from the current one."
+ (interactive)
+ (windmove-swap-states-in-direction 'down))
+;;;###autoload
+(defun windmove-swap-states-right ()
+ "Swap the states with the window on the right from the current one."
+ (interactive)
+ (windmove-swap-states-in-direction 'right))
+
+;;;###autoload
+(defun windmove-swap-states-default-keybindings (&optional modifiers)
+ "Set up keybindings for directional window swap states.
+Keys are bound to commands that swap the states of the selected window
+with the window in the specified direction. Keybindings are of the form
+MODIFIERS-{left,right,up,down}, where MODIFIERS is either a list of modifiers
+or a single modifier. Default value of MODIFIERS is `shift-super'."
+ (interactive)
+ (unless modifiers (setq modifiers '(shift super)))
+ (unless (listp modifiers) (setq modifiers (list modifiers)))
+ (global-set-key (vector (append modifiers '(left))) 'windmove-swap-states-left)
+ (global-set-key (vector (append modifiers '(right))) 'windmove-swap-states-right)
+ (global-set-key (vector (append modifiers '(up))) 'windmove-swap-states-up)
+ (global-set-key (vector (append modifiers '(down))) 'windmove-swap-states-down))
+
+
(provide 'windmove)
;;; windmove.el ends here
diff --git a/lisp/window.el b/lisp/window.el
index 58e22a2306a..b4f5ac5cc44 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -509,11 +509,14 @@ child if WINDOW is a horizontal combination."
(window-left-child window)
(window-top-child window)))
-(defun window-combinations (window &optional horizontal)
+(defun window-combinations (window &optional horizontal ignore-fixed)
"Return largest number of windows vertically arranged within WINDOW.
WINDOW must be a valid window and defaults to the selected one.
If HORIZONTAL is non-nil, return the largest number of
-windows horizontally arranged within WINDOW."
+windows horizontally arranged within WINDOW.
+
+Optional argument IGNORE-FIXED, if non-nil, means to ignore
+fixed-size windows in the calculation."
(setq window (window-normalize-window window))
(cond
((window-live-p window)
@@ -527,9 +530,10 @@ windows horizontally arranged within WINDOW."
(let ((child (window-child window))
(count 0))
(while child
- (setq count
- (+ (window-combinations child horizontal)
- count))
+ (unless (and ignore-fixed (window-size-fixed-p child horizontal))
+ (setq count
+ (+ (window-combinations child horizontal ignore-fixed)
+ count)))
(setq child (window-right child)))
count))
(t
@@ -538,9 +542,10 @@ windows horizontally arranged within WINDOW."
(let ((child (window-child window))
(count 1))
(while child
- (setq count
- (max (window-combinations child horizontal)
- count))
+ (unless (and ignore-fixed (window-size-fixed-p child horizontal))
+ (setq count
+ (max (window-combinations child horizontal ignore-fixed)
+ count)))
(setq child (window-right child)))
count))))
@@ -571,23 +576,25 @@ FRAME.
Optional argument MINIBUF t means run FUN on FRAME's minibuffer
window even if it isn't active. MINIBUF nil or omitted means run
-FUN on FRAME's minibuffer window only if it's active. In both
-cases the minibuffer window must be part of FRAME. MINIBUF
+FUN on FRAME's minibuffer window only if it's active. In either
+case the minibuffer window must be part of FRAME. MINIBUF
neither nil nor t means never run FUN on the minibuffer window.
This function performs a pre-order, depth-first traversal of the
window tree. If FUN changes the window tree, the result is
unpredictable."
- (setq frame (window-normalize-frame frame))
- (walk-window-tree-1 fun (frame-root-window frame) any)
- (when (memq minibuf '(nil t))
+ (let ((root (frame-root-window frame))
+ (mini (minibuffer-window frame)))
+ (setq frame (window-normalize-frame frame))
+ (unless (eq root mini)
+ (walk-window-tree-1 fun root any))
;; Run FUN on FRAME's minibuffer window if requested.
- (let ((minibuffer-window (minibuffer-window frame)))
- (when (and (window-live-p minibuffer-window)
- (eq (window-frame minibuffer-window) frame)
- (or (eq minibuf t)
- (minibuffer-window-active-p minibuffer-window)))
- (funcall fun minibuffer-window)))))
+ (when (and (window-live-p mini)
+ (eq (window-frame mini) frame)
+ (or (eq minibuf t)
+ (and (not minibuf)
+ (minibuffer-window-active-p mini))))
+ (funcall fun mini))))
(defun walk-window-subtree (fun &optional window any)
"Run function FUN on the subtree of windows rooted at WINDOW.
@@ -700,8 +707,7 @@ failed."
(set-window-parameter window 'window-atom 'main))
(set-window-parameter new 'window-atom side)
;; Display BUFFER in NEW and return NEW.
- (window--display-buffer
- buffer new 'window alist display-buffer-mark-dedicated))))
+ (window--display-buffer buffer new 'window alist))))
(defun window--atom-check-1 (window)
"Subroutine of `window--atom-check'."
@@ -958,7 +964,11 @@ and may be called only if no window on SIDE exists yet."
;; window and not make a new parent window unless needed.
(window-combination-resize 'side)
(window-combination-limit nil)
- (window (split-window-no-error next-to nil on-side)))
+ (window (split-window-no-error next-to nil on-side))
+ (alist (if (assq 'dedicated alist)
+ alist
+ (cons `(dedicated . ,(or display-buffer-mark-dedicated 'side))
+ alist))))
(when window
;; Initialize `window-side' parameter of new window to SIDE and
;; make that parameter persistent.
@@ -985,7 +995,7 @@ and may be called only if no window on SIDE exists yet."
(with-current-buffer buffer
(setq window--sides-shown t))
;; Install BUFFER in new window and return WINDOW.
- (window--display-buffer buffer window 'window alist 'side))))
+ (window--display-buffer buffer window 'window alist))))
(defun display-buffer-in-side-window (buffer alist)
"Display BUFFER in a side window of the selected frame.
@@ -1019,10 +1029,7 @@ nor installs any other window parameters unless they have been
explicitly provided via a `window-parameters' entry in ALIST."
(let* ((side (or (cdr (assq 'side alist)) 'bottom))
(slot (or (cdr (assq 'slot alist)) 0))
- (left-or-right (memq side '(left right)))
- ;; Softly dedicate window to BUFFER unless
- ;; `display-buffer-mark-dedicated' already asks for it.
- (dedicated (or display-buffer-mark-dedicated 'side)))
+ (left-or-right (memq side '(left right))))
(cond
((not (memq side '(top bottom left right)))
(error "Invalid side %s specified" side))
@@ -1055,7 +1062,11 @@ explicitly provided via a `window-parameters' entry in ALIST."
((eq side 'bottom) 3))
window-sides-slots))
(window--sides-inhibit-check t)
- window this-window this-slot prev-window next-window
+ (alist (if (assq 'dedicated alist)
+ alist
+ (cons `(dedicated . ,(or display-buffer-mark-dedicated 'side))
+ alist)))
+ window this-window this-slot prev-window next-window
best-window best-slot abs-slot)
(cond
@@ -1113,8 +1124,7 @@ explicitly provided via a `window-parameters' entry in ALIST."
;; Reuse `this-window'.
(with-current-buffer buffer
(setq window--sides-shown t))
- (window--display-buffer
- buffer this-window 'reuse alist dedicated))
+ (window--display-buffer buffer this-window 'reuse alist))
(and (or (not max-slots) (< slots max-slots))
(or (and next-window
;; Make new window before `next-window'.
@@ -1131,8 +1141,7 @@ explicitly provided via a `window-parameters' entry in ALIST."
(set-window-parameter window 'window-slot slot)
(with-current-buffer buffer
(setq window--sides-shown t))
- (window--display-buffer
- buffer window 'window alist dedicated))
+ (window--display-buffer buffer window 'window alist))
(and best-window
;; Reuse `best-window'.
(progn
@@ -1141,7 +1150,7 @@ explicitly provided via a `window-parameters' entry in ALIST."
(with-current-buffer buffer
(setq window--sides-shown t))
(window--display-buffer
- buffer best-window 'reuse alist dedicated)))))))))
+ buffer best-window 'reuse alist)))))))))
(defun window-toggle-side-windows (&optional frame)
"Toggle display of side windows on specified FRAME.
@@ -2041,6 +2050,8 @@ doc-string of `window-resizable'."
;; Aliases of functions defined in window.c.
(defalias 'window-height 'window-total-height)
(defalias 'window-width 'window-body-width)
+(defalias 'window-pixel-width-before-size-change 'window-old-pixel-width)
+(defalias 'window-pixel-height-before-size-change 'window-old-pixel-height)
(defun window-full-height-p (&optional window)
"Return t if WINDOW is as high as its containing frame.
@@ -2262,14 +2273,14 @@ SIDE can be any of the symbols `left', `top', `right' or
"Return window in DIRECTION as seen from WINDOW.
More precisely, return the nearest window in direction DIRECTION
as seen from the position of `window-point' in window WINDOW.
-DIRECTION must be one of `above', `below', `left' or `right'.
+DIRECTION should be one of 'above', 'below', 'left' or 'right'.
WINDOW must be a live window and defaults to the selected one.
-Do not return a window whose `no-other-window' parameter is
-non-nil. If the nearest window's `no-other-window' parameter is
+Do not return a window whose 'no-other-window' parameter is
+non-nil. If the nearest window's 'no-other-window' parameter is
non-nil, try to find another window in the indicated direction.
If, however, the optional argument IGNORE is non-nil, return that
-window even if its `no-other-window' parameter is non-nil.
+window even if its 'no-other-window' parameter is non-nil.
Optional argument SIGN a negative number means to use the right
or bottom edge of WINDOW as reference position instead of
@@ -2278,7 +2289,7 @@ top edge of WINDOW as reference position.
Optional argument WRAP non-nil means to wrap DIRECTION around
frame borders. This means to return for WINDOW at the top of the
-frame and DIRECTION `above' the minibuffer window if the frame
+frame and DIRECTION 'above' the minibuffer window if the frame
has one, and a window at the bottom of the frame otherwise.
Optional argument MINI nil means to return the minibuffer window
@@ -2288,8 +2299,13 @@ if WRAP is non-nil, always act as if MINI were nil.
Return nil if no suitable window can be found."
(setq window (window-normalize-window window t))
- (unless (memq direction '(above below left right))
- (error "Wrong direction %s" direction))
+ (cond
+ ((eq direction 'up)
+ (setq direction 'above))
+ ((eq direction 'down)
+ (setq direction 'below))
+ ((not (memq direction '(above below left right)))
+ (error "Wrong direction %s" direction)))
(let* ((frame (window-frame window))
(hor (memq direction '(left right)))
(first (if hor
@@ -2737,7 +2753,7 @@ as small) as possible, but don't signal an error."
;; Sanitize DELTA.
(cond
((<= (+ height delta) 0)
- (setq delta (- (frame-char-height (window-frame window)) height)))
+ (setq delta (- (frame-char-height frame) height)))
((> delta min-delta)
(setq delta min-delta)))
@@ -2752,20 +2768,19 @@ as small) as possible, but don't signal an error."
;; The following routine catches the case where we want to resize
;; a minibuffer-only frame.
(when (resize-mini-window-internal window)
- (window--pixel-to-total frame)
- (run-window-configuration-change-hook frame))))))
+ (window--pixel-to-total frame))))))
(defun window--resize-apply-p (frame &optional horizontal)
"Return t when a window on FRAME shall be resized vertically.
Optional argument HORIZONTAL non-nil means return t when a window
shall be resized horizontally."
-(catch 'apply
+ (catch 'apply
(walk-window-tree
(lambda (window)
(unless (= (window-new-pixel window)
(window-size window horizontal t))
(throw 'apply t)))
- frame t)
+ frame t t)
nil))
(defun window-resize (window delta &optional horizontal ignore pixelwise)
@@ -2851,9 +2866,7 @@ instead."
(window--resize-siblings window delta horizontal ignore))
(when (window--resize-apply-p frame horizontal)
(if (window-resize-apply frame horizontal)
- (progn
- (window--pixel-to-total frame horizontal)
- (run-window-configuration-change-hook frame))
+ (window--pixel-to-total frame horizontal)
(error "Failed to apply resizing %s" window))))
(t
(error "Cannot resize window %s" window)))))
@@ -3084,11 +3097,12 @@ already set by this routine."
(while (and best-window (not (zerop delta)))
(setq sub last)
(setq best-window nil)
- (setq best-value most-negative-fixnum)
+ (setq best-value nil)
(while sub
(when (and (consp (window-new-normal sub))
(not (<= (car (window-new-normal sub)) 0))
- (> (cdr (window-new-normal sub)) best-value))
+ (or (not best-value)
+ (> (cdr (window-new-normal sub)) best-value)))
(setq best-window sub)
(setq best-value (cdr (window-new-normal sub))))
@@ -3113,10 +3127,11 @@ already set by this routine."
(while (and best-window (not (zerop delta)))
(setq sub last)
(setq best-window nil)
- (setq best-value most-positive-fixnum)
+ (setq best-value nil)
(while sub
(when (and (numberp (window-new-normal sub))
- (< (window-new-normal sub) best-value))
+ (or (not best-value)
+ (< (window-new-normal sub) best-value)))
(setq best-window sub)
(setq best-value (window-new-normal sub)))
@@ -3366,6 +3381,12 @@ routines."
pixel-delta
(/ pixel-delta (frame-char-height frame)))))
+(defun window--resize-mini-frame (frame)
+ "Resize minibuffer-only frame FRAME."
+ (if (functionp resize-mini-frames)
+ (funcall resize-mini-frames frame)
+ (fit-frame-to-buffer frame)))
+
(defun window--sanitize-window-sizes (horizontal)
"Assert that all windows on selected frame are large enough.
If necessary and possible, make sure that every window on frame
@@ -3385,7 +3406,8 @@ may happen when the FRAME is not large enough to accommodate it."
(when (> delta 0)
(if (window-resizable-p window delta horizontal nil t)
(window-resize window delta horizontal nil t)
- (setq value nil))))))
+ (setq value nil)))))
+ nil nil 'nomini)
value))
(defun adjust-window-trailing-edge (window delta &optional horizontal pixelwise)
@@ -3570,9 +3592,7 @@ move it as far as possible in the desired direction."
;; Don't report an error in the standard case.
(when (window--resize-apply-p frame horizontal)
(if (window-resize-apply frame horizontal)
- (progn
- (window--pixel-to-total frame horizontal)
- (run-window-configuration-change-hook frame))
+ (window--pixel-to-total frame horizontal)
;; But do report an error if applying the changes fails.
(error "Failed adjusting window %s" window))))))))
@@ -4103,7 +4123,6 @@ that is its frame's root window."
;; `delete-window-internal' has selected a window that should
;; not be selected, fix this here.
(other-window -1 frame))
- (run-window-configuration-change-hook frame)
(window--check frame)
;; Always return nil.
nil))))
@@ -4166,7 +4185,8 @@ any window whose `no-delete-other-windows' parameter is non-nil."
(and (not (window-parameter other 'window-side))
(window-parameter
other 'no-delete-other-windows)))
- (throw 'tag nil))))
+ (throw 'tag nil)))
+ nil nil 'nomini)
t)
(setq main (window-main-window frame)))
(t
@@ -4189,7 +4209,6 @@ any window whose `no-delete-other-windows' parameter is non-nil."
;; If WINDOW is the main window of its frame do nothing.
(unless (eq window main)
(delete-other-windows-internal window main)
- (run-window-configuration-change-hook frame)
(window--check frame))
;; Always return nil.
nil)))
@@ -4271,7 +4290,7 @@ WINDOW must be a live window and defaults to the selected one."
(list (copy-marker start)
(copy-marker
;; Preserve window-point-insertion-type
- ;; (Bug#12588).
+ ;; (Bug#12855).
point window-point-insertion-type)))))
(set-window-prev-buffers
window (cons entry (window-prev-buffers window)))))
@@ -4721,7 +4740,7 @@ If the buffer specified by BUFFER-OR-NAME is shown in a
minibuffer window, do nothing for that window. For any window
that does not show that buffer, remove the buffer from that
window's lists of previous and next buffers."
- (interactive "BDelete windows on (buffer):\nP")
+ (interactive "bDelete windows on (buffer):\nP")
(let ((buffer (window-normalize-buffer buffer-or-name))
;; Handle the "inverted" meaning of the FRAME argument wrt other
;; `window-list-1' based function.
@@ -4904,7 +4923,7 @@ BUFFER-OR-NAME. Optional argument FRAME is handled as by
This function calls `quit-window' on all candidate windows
showing BUFFER-OR-NAME."
- (interactive "BQuit windows on (buffer):\nP")
+ (interactive "bQuit windows on (buffer):\nP")
(let ((buffer (window-normalize-buffer buffer-or-name))
;; Handle the "inverted" meaning of the FRAME argument wrt other
;; `window-list-1' based function.
@@ -4915,6 +4934,24 @@ showing BUFFER-OR-NAME."
;; If a window doesn't show BUFFER, unrecord BUFFER in it.
(unrecord-window-buffer window buffer)))))
+(defun window--combination-resizable (parent &optional horizontal)
+ "Return number of pixels recoverable from height of window PARENT.
+PARENT must be a vertical (horizontal if HORIZONTAL is non-nil)
+window combination. The return value is the sum of the pixel
+heights of all non-fixed height child windows of PARENT divided
+by their number plus 1. If HORIZONTAL is non-nil, return the sum
+of the pixel widths of all non-fixed width child windows of
+PARENT divided by their number plus 1."
+ (let ((sibling (window-child parent))
+ (number 0)
+ (size 0))
+ (while sibling
+ (unless (window-size-fixed-p sibling horizontal)
+ (setq number (1+ number))
+ (setq size (+ (window-size sibling horizontal t) size)))
+ (setq sibling (window-next-sibling sibling)))
+ (/ size (1+ number))))
+
(defun split-window (&optional window size side pixelwise)
"Make a new window adjacent to WINDOW.
WINDOW must be a valid window and defaults to the selected one.
@@ -4928,26 +4965,29 @@ absolute value can be less than `window-min-height' or
small as one line or two columns. SIZE defaults to half of
WINDOW's size.
-Optional third argument SIDE nil (or `below') specifies that the
-new window shall be located below WINDOW. SIDE `above' means the
+Optional third argument SIDE nil (or 'below') specifies that the
+new window shall be located below WINDOW. SIDE 'above' means the
new window shall be located above WINDOW. In both cases SIZE
specifies the new number of lines for WINDOW (or the new window
if SIZE is negative) including space reserved for the mode and/or
header line.
-SIDE t (or `right') specifies that the new window shall be
-located on the right side of WINDOW. SIDE `left' means the new
+SIDE t (or 'right') specifies that the new window shall be
+located on the right side of WINDOW. SIDE 'left' means the new
window shall be located on the left of WINDOW. In both cases
SIZE specifies the new number of columns for WINDOW (or the new
window provided SIZE is negative) including space reserved for
-fringes and the scrollbar or a divider column. Any other non-nil
-value for SIDE is currently handled like t (or `right').
+fringes and the scrollbar or a divider column.
+
+For compatibility reasons, SIDE 'up' and 'down' are interpreted
+as 'above' and 'below'. Any other non-nil value for SIDE is
+currently handled like t (or 'right').
PIXELWISE, if non-nil, means to interpret SIZE pixelwise.
If the variable `ignore-window-parameters' is non-nil or the
-`split-window' parameter of WINDOW equals t, do not process any
-parameters of WINDOW. Otherwise, if the `split-window' parameter
+'split-window' parameter of WINDOW equals t, do not process any
+parameters of WINDOW. Otherwise, if the 'split-window' parameter
of WINDOW specifies a function, call that function with all three
arguments and return the value returned by that function.
@@ -4963,6 +5003,8 @@ frame. The selected window is not changed by this function."
(setq window (window-normalize-window window))
(let* ((side (cond
((not side) 'below)
+ ((eq side 'up) 'above)
+ ((eq side 'down) 'below)
((memq side '(below above right left)) side)
(t 'right)))
(horizontal (not (memq side '(below above))))
@@ -4986,10 +5028,10 @@ frame. The selected window is not changed by this function."
(catch 'done
(cond
;; Ignore window parameters if either `ignore-window-parameters'
- ;; is t or the `split-window' parameter equals t.
+ ;; is t or the 'split-window' parameter equals t.
((or ignore-window-parameters (eq function t)))
((functionp function)
- ;; The `split-window' parameter specifies the function to call.
+ ;; The 'split-window' parameter specifies the function to call.
;; If that function is `ignore', do nothing.
(throw 'done (funcall function window size side)))
;; If WINDOW is part of an atomic window, split the root window
@@ -5022,10 +5064,10 @@ frame. The selected window is not changed by this function."
(setq window-combination-limit t))
(let* ((parent-pixel-size
- ;; `parent-pixel-size' is the pixel size of WINDOW's
+ ;; 'parent-pixel-size' is the pixel size of WINDOW's
;; parent, provided it has one.
(when parent (window-size parent horizontal t)))
- ;; `resize' non-nil means we are supposed to resize other
+ ;; 'resize' non-nil means we are supposed to resize other
;; windows in WINDOW's combination.
(resize
(and window-combination-resize
@@ -5034,9 +5076,9 @@ frame. The selected window is not changed by this function."
(not (eq window-combination-limit t))
;; Resize makes sense in iso-combinations only.
(window-combined-p window horizontal)))
- ;; `old-pixel-size' is the current pixel size of WINDOW.
+ ;; 'old-pixel-size' is the current pixel size of WINDOW.
(old-pixel-size (window-size window horizontal t))
- ;; `new-size' is the specified or calculated size of the
+ ;; 'new-size' is the specified or calculated size of the
;; new window.
new-pixel-size new-parent new-normal)
(cond
@@ -5047,8 +5089,7 @@ frame. The selected window is not changed by this function."
;; average size of a window in its combination.
(max (min (- parent-pixel-size
(window-min-size parent horizontal nil t))
- (/ parent-pixel-size
- (1+ (window-combinations parent horizontal))))
+ (window--combination-resizable parent horizontal))
(window-min-pixel-size))
;; Else try to give the new window half the size
;; of WINDOW (plus an eventual odd pixel).
@@ -5133,7 +5174,7 @@ frame. The selected window is not changed by this function."
(pixel-size (/ (float new-pixel-size)
(if new-parent old-pixel-size parent-pixel-size)))
(new-parent 0.5)
- (resize (/ 1.0 (1+ (window-combinations parent horizontal))))
+ (resize (/ 1.0 (1+ (window-combinations parent horizontal t))))
(t (/ (window-normal-size window horizontal) 2.0))))
(if resize
@@ -5190,7 +5231,6 @@ frame. The selected window is not changed by this function."
(unless size
(window--sanitize-window-sizes horizontal))
- (run-window-configuration-change-hook frame)
(run-window-scroll-functions new)
(window--check frame)
;; Always return the new window.
@@ -5323,11 +5363,12 @@ is non-nil)."
(total-sum parent-size)
failed size sub-total sub-delta sub-amount rest)
(while sub
- (setq number-of-children (1+ number-of-children))
- (when (window-size-fixed-p sub horizontal)
- (setq total-sum
- (- total-sum (window-size sub horizontal t)))
- (set-window-new-normal sub 'ignore))
+ (if (window-size-fixed-p sub horizontal)
+ (progn
+ (setq total-sum
+ (- total-sum (window-size sub horizontal t)))
+ (set-window-new-normal sub 'ignore))
+ (setq number-of-children (1+ number-of-children)))
(setq sub (window-right sub)))
(setq failed t)
@@ -5352,16 +5393,16 @@ is non-nil)."
(set-window-new-normal sub 'skip)))
(setq sub (window-right sub))))
- ;; How can we be sure that `number-of-children' is NOT zero here ?
- (setq rest (% total-sum number-of-children))
- ;; Fix rounding by trying to enlarge non-stuck windows by one line
- ;; (column) until `rest' is zero.
- (setq sub first)
- (while (and sub (> rest 0))
- (unless (window--resize-child-windows-skip-p window)
- (set-window-new-pixel sub (min rest char-size) t)
- (setq rest (- rest char-size)))
- (setq sub (window-right sub)))
+ (when (> number-of-children 0)
+ (setq rest (% total-sum number-of-children))
+ ;; Fix rounding by trying to enlarge non-stuck windows by one line
+ ;; (column) until `rest' is zero.
+ (setq sub first)
+ (while (and sub (> rest 0))
+ (unless (window--resize-child-windows-skip-p window)
+ (set-window-new-pixel sub (min rest char-size) t)
+ (setq rest (- rest char-size)))
+ (setq sub (window-right sub))))
;; Fix rounding by trying to enlarge stuck windows by one line
;; (column) until `rest' equals zero.
@@ -5420,15 +5461,13 @@ window."
(balance-windows-1 window)
(when (window--resize-apply-p frame)
(window-resize-apply frame)
- (window--pixel-to-total frame)
- (run-window-configuration-change-hook frame))
+ (window--pixel-to-total frame))
;; Balance horizontally.
(window--resize-reset (window-frame window) t)
(balance-windows-1 window t)
(when (window--resize-apply-p frame t)
(window-resize-apply frame t)
- (window--pixel-to-total frame t)
- (run-window-configuration-change-hook frame))))
+ (window--pixel-to-total frame t))))
(defun window-fixed-size-p (&optional window direction)
"Return t if WINDOW cannot be resized in DIRECTION.
@@ -5557,9 +5596,18 @@ specific buffers."
(t 'leaf)))
(buffer (window-buffer window))
(selected (eq window (selected-window)))
+ (next-buffers (when (window-live-p window)
+ (delq nil (mapcar (lambda (buffer)
+ (and (buffer-live-p buffer) buffer))
+ (window-next-buffers window)))))
+ (prev-buffers (when (window-live-p window)
+ (delq nil (mapcar (lambda (entry)
+ (and (buffer-live-p (nth 0 entry))
+ entry))
+ (window-prev-buffers window)))))
(head
`(,type
- ,@(unless (window-next-sibling window) `((last . t)))
+ ,@(unless (window-next-sibling window) '((last . t)))
(pixel-width . ,(window-pixel-width window))
(pixel-height . ,(window-pixel-height window))
(total-width . ,(window-total-width window))
@@ -5591,7 +5639,7 @@ specific buffers."
(let ((point (window-point window))
(start (window-start window)))
`((buffer
- ,(buffer-name buffer)
+ ,(if writable (buffer-name buffer) buffer)
(selected . ,selected)
(hscroll . ,(window-hscroll window))
(fringes . ,(window-fringes window))
@@ -5609,7 +5657,22 @@ specific buffers."
(start . ,(if writable
start
(with-current-buffer buffer
- (copy-marker start))))))))))
+ (copy-marker start))))))))
+ ,@(when next-buffers
+ `((next-buffers
+ . ,(if writable
+ (mapcar (lambda (buffer) (buffer-name buffer))
+ next-buffers)
+ next-buffers))))
+ ,@(when prev-buffers
+ `((prev-buffers
+ . ,(if writable
+ (mapcar (lambda (entry)
+ (list (buffer-name (nth 0 entry))
+ (marker-position (nth 1 entry))
+ (marker-position (nth 2 entry))))
+ prev-buffers)
+ prev-buffers))))))
(tail
(when (memq type '(vc hc))
(let (list)
@@ -5752,7 +5815,9 @@ value can be also stored on disk and read back in a new session."
(let ((window (car item))
(combination-limit (cdr (assq 'combination-limit item)))
(parameters (cdr (assq 'parameters item)))
- (state (cdr (assq 'buffer item))))
+ (state (cdr (assq 'buffer item)))
+ (next-buffers (cdr (assq 'next-buffers item)))
+ (prev-buffers (cdr (assq 'prev-buffers item))))
(when combination-limit
(set-window-combination-limit window combination-limit))
;; Reset window's parameters and assign saved ones (we might want
@@ -5764,7 +5829,8 @@ value can be also stored on disk and read back in a new session."
(set-window-parameter window (car parameter) (cdr parameter))))
;; Process buffer related state.
(when state
- (let ((buffer (get-buffer (car state))))
+ (let ((buffer (get-buffer (car state)))
+ (state (cdr state)))
(if buffer
(with-current-buffer buffer
(set-window-buffer window buffer)
@@ -5833,7 +5899,30 @@ value can be also stored on disk and read back in a new session."
(set-window-point window (cdr (assq 'point state))))
;; Select window if it's the selected one.
(when (cdr (assq 'selected state))
- (select-window window)))
+ (select-window window))
+ (when next-buffers
+ (set-window-next-buffers
+ window
+ (delq nil (mapcar (lambda (buffer)
+ (setq buffer (get-buffer buffer))
+ (when (buffer-live-p buffer) buffer))
+ next-buffers))))
+ (when prev-buffers
+ (set-window-prev-buffers
+ window
+ (delq nil (mapcar (lambda (entry)
+ (let ((buffer (get-buffer (nth 0 entry)))
+ (m1 (nth 1 entry))
+ (m2 (nth 2 entry)))
+ (when (buffer-live-p buffer)
+ (list buffer
+ (if (markerp m1) m1
+ (set-marker (make-marker) m1
+ buffer))
+ (if (markerp m2) m2
+ (set-marker (make-marker) m2
+ buffer))))))
+ prev-buffers)))))
;; We don't want to raise an error in case the buffer does
;; not exist anymore, so we switch to a previous one and
;; save the window with the intention of deleting it later
@@ -5845,29 +5934,34 @@ value can be also stored on disk and read back in a new session."
"Put window state STATE into WINDOW.
STATE should be the state of a window returned by an earlier
invocation of `window-state-get'. Optional argument WINDOW must
-specify a valid window and defaults to the selected one. If
-WINDOW is not live, replace WINDOW by a live one before putting
-STATE into it.
+specify a valid window. If WINDOW is not a live window,
+replace WINDOW by a new live window created on the same frame.
+If WINDOW is nil, create a new window before putting STATE into it.
Optional argument IGNORE non-nil means ignore minimum window
sizes and fixed size restrictions. IGNORE equal `safe' means
windows can get as small as `window-safe-min-height' and
`window-safe-min-width'."
(setq window-state-put-stale-windows nil)
- (setq window (window-normalize-window window))
- ;; When WINDOW is internal, reduce it to a live one to put STATE into,
- ;; see Bug#16793.
+ ;; When WINDOW is internal or nil, reduce it to a live one,
+ ;; then create a new window on the same frame to put STATE into.
(unless (window-live-p window)
(let ((root window))
- (setq window (catch 'live
- (walk-window-subtree
- (lambda (window)
- (when (and (window-live-p window)
- (not (window-parameter window 'window-side)))
- (throw 'live window)))
- root)))
- (delete-other-windows-internal window root)))
+ (setq window (if root
+ (catch 'live
+ (walk-window-subtree
+ (lambda (window)
+ (when (and (window-live-p window)
+ (not (window-parameter
+ window 'window-side)))
+ (throw 'live window)))
+ root))
+ (selected-window)))
+ (delete-other-windows-internal window root)
+ ;; Create a new window to replace the existing one.
+ (setq window (prog1 (split-window window)
+ (delete-window window)))))
(set-window-dedicated-p window nil)
@@ -6023,23 +6117,26 @@ not resized by this function."
(defun display-buffer-record-window (type window buffer)
"Record information for window used by `display-buffer'.
+WINDOW is the window used for or created by a buffer display
+action function. BUFFER is the buffer to display. Note that
+this function must be called before BUFFER is explicitly made
+WINDOW's buffer (although WINDOW may show BUFFER already).
+
TYPE specifies the type of the calling operation and must be one
-of the symbols `reuse' (when WINDOW existed already and was
-reused for displaying BUFFER), `window' (when WINDOW was created
-on an already existing frame), or `frame' (when WINDOW was
-created on a new frame). WINDOW is the window used for or created
-by the `display-buffer' routines. BUFFER is the buffer that
-shall be displayed.
-
-This function installs or updates the quit-restore parameter of
-WINDOW. The quit-restore parameter is a list of four elements:
-The first element is one of the symbols `window', `frame', `same' or
-`other'. The second element is either one of the symbols `window'
-or `frame' or a list whose elements are the buffer previously
-shown in the window, that buffer's window start and window point,
-and the window's height. The third element is the window
-selected at the time the parameter was created. The fourth
-element is BUFFER."
+of the symbols 'reuse' (meaning that WINDOW exists already and
+will be used for displaying BUFFER), 'window' (WINDOW was created
+on an already existing frame) or 'frame' (WINDOW was created on a
+new frame).
+
+This function installs or updates the 'quit-restore' parameter of
+WINDOW. The 'quit-restore' parameter is a list of four elements:
+The first element is one of the symbols 'window', 'frame', 'same'
+or 'other'. The second element is either one of the symbols
+'window' or 'frame' or a list whose elements are the buffer
+previously shown in the window, that buffer's window start and
+window point, and the window's height. The third element is the
+window selected at the time the parameter was created. The
+fourth element is BUFFER."
(cond
((eq type 'reuse)
(if (eq (window-buffer window) buffer)
@@ -6060,7 +6157,7 @@ element is BUFFER."
(list 'other
;; A quadruple of WINDOW's buffer, start, point and height.
(list (current-buffer) (window-start window)
- ;; Preserve window-point-insertion-type (Bug#12588).
+ ;; Preserve window-point-insertion-type (Bug#12855).
(copy-marker
(window-point window) window-point-insertion-type)
(if (window-combined-p window)
@@ -6608,7 +6705,7 @@ split."
(unless (or (eq w window)
(window-dedicated-p w))
(throw 'done nil)))
- frame)
+ frame nil 'nomini)
t)))
(not (window-minibuffer-p window))
(let ((split-height-threshold 0))
@@ -6660,6 +6757,7 @@ represents a live window, nil otherwise."
))
frame))))
+(defvaralias 'even-window-heights 'even-window-sizes)
(defcustom even-window-sizes t
"If non-nil `display-buffer' will try to even window sizes.
Otherwise `display-buffer' will leave the window configuration
@@ -6673,7 +6771,6 @@ any of them."
(const :tag "Always" t))
:version "25.1"
:group 'windows)
-(defvaralias 'even-window-heights 'even-window-sizes)
(defun window--even-window-sizes (window)
"Even sizes of WINDOW and selected window.
@@ -6698,20 +6795,51 @@ window is larger than WINDOW."
(/ (- (window-total-height window) (window-total-height)) 2))
(error nil))))))
-(defun window--display-buffer (buffer window type &optional alist dedicated)
+(defun window--display-buffer (buffer window type &optional alist)
"Display BUFFER in WINDOW.
-TYPE must be one of the symbols `reuse', `window' or `frame' and
-is passed unaltered to `display-buffer-record-window'. ALIST is
-the alist argument of `display-buffer'. Set `window-dedicated-p'
-to DEDICATED if non-nil. Return WINDOW if BUFFER and WINDOW are
-live."
+WINDOW must be a live window chosen by a buffer display action
+function for showing BUFFER. TYPE tells whether WINDOW existed
+already before that action function was called or is a new window
+created by that function. ALIST is a buffer display action alist
+as compiled by `display-buffer'.
+
+TYPE must be one of the following symbols: 'reuse' (which means
+WINDOW existed before the call of `display-buffer' and may
+already show BUFFER or not), 'window' (WINDOW was created on an
+existing frame) or 'frame' (WINDOW was created on a new frame).
+TYPE is passed unaltered to `display-buffer-record-window'.
+
+Handle WINDOW's dedicated flag as follows: If WINDOW already
+shows BUFFER, leave it alone. Otherwise, if ALIST contains a
+'dedicated' entry and WINDOW is either new or that entry's value
+equals 'side', set WINDOW's dedicated flag to the value of that
+entry. Otherwise, if WINDOW is new and the value of
+'display-buffer-mark-dedicated' is non-nil, set WINDOW's
+dedicated flag to that value. In any other case, reset WINDOW's
+dedicated flag to nil.
+
+Return WINDOW if BUFFER and WINDOW are live."
(when (and (buffer-live-p buffer) (window-live-p window))
(display-buffer-record-window type window buffer)
(unless (eq buffer (window-buffer window))
+ ;; Unless WINDOW already shows BUFFER reset its dedicated flag.
(set-window-dedicated-p window nil)
(set-window-buffer window buffer))
- (when dedicated
- (set-window-dedicated-p window dedicated))
+ (let ((alist-dedicated (assq 'dedicated alist)))
+ ;; Maybe dedicate WINDOW to BUFFER if asked for.
+ (cond
+ ;; Don't dedicate WINDOW if it is dedicated because it shows
+ ;; BUFFER already or it is reused and is not a side window.
+ ((or (window-dedicated-p window)
+ (and (eq type 'reuse) (not (eq (cdr alist-dedicated) 'side)))))
+ ;; Otherwise, if ALIST contains a 'dedicated' entry, use that
+ ;; entry's value (which may be nil).
+ (alist-dedicated
+ (set-window-dedicated-p window (cdr alist-dedicated)))
+ ;; Otherwise, if 'display-buffer-mark-dedicated' is non-nil,
+ ;; use that.
+ (display-buffer-mark-dedicated
+ (set-window-dedicated-p window display-buffer-mark-dedicated))))
(when (memq type '(window frame))
(set-window-prev-buffers window nil))
(let ((quit-restore (window-parameter window 'quit-restore))
@@ -7106,7 +7234,7 @@ on all the frames on the current terminal, skipping the selected
window; if that fails, it pops up a new frame.
This uses the function `display-buffer' as a subroutine; see
its documentation for additional customization information."
- (interactive "BDisplay buffer in other frame: ")
+ (interactive "bDisplay buffer in other frame: ")
(display-buffer buffer display-buffer--other-frame-action t))
;;; `display-buffer' action functions:
@@ -7140,8 +7268,7 @@ that allows the selected frame)."
frame nil (cdr (assq 'inhibit-same-window alist))))))
(when window
(prog1
- (window--display-buffer
- buffer window 'reuse alist display-buffer-mark-dedicated)
+ (window--display-buffer buffer window 'reuse alist)
(unless (cdr (assq 'inhibit-switch-frame alist))
(window--maybe-raise-frame frame))))))
@@ -7306,8 +7433,7 @@ new frame."
(with-current-buffer buffer
(setq frame (funcall fun)))
(setq window (frame-selected-window frame)))
- (prog1 (window--display-buffer
- buffer window 'frame alist display-buffer-mark-dedicated)
+ (prog1 (window--display-buffer buffer window 'frame alist)
(unless (cdr (assq 'inhibit-switch-frame alist))
(window--maybe-raise-frame frame))))))
@@ -7336,8 +7462,7 @@ raising the frame."
(window--try-to-split-window
(get-lru-window frame t) alist))))
- (prog1 (window--display-buffer
- buffer window 'window alist display-buffer-mark-dedicated)
+ (prog1 (window--display-buffer buffer window 'window alist)
(unless (cdr (assq 'inhibit-switch-frame alist))
(window--maybe-raise-frame (window-frame window)))))))
@@ -7348,12 +7473,23 @@ text-only terminal), try with `display-buffer-pop-up-frame'.
If that cannot be done, and `pop-up-windows' is non-nil, try
again with `display-buffer-pop-up-window'."
- (or (and (if (eq pop-up-frames 'graphic-only)
- (display-graphic-p)
- pop-up-frames)
- (display-buffer-pop-up-frame buffer alist))
- (and pop-up-windows
- (display-buffer-pop-up-window buffer alist))))
+ (or (display-buffer--maybe-pop-up-frame buffer alist)
+ (display-buffer--maybe-pop-up-window buffer alist)))
+
+(defun display-buffer--maybe-pop-up-frame (buffer alist)
+ "Try displaying BUFFER based on `pop-up-frames'.
+If `pop-up-frames' is non-nil (and not `graphic-only' on a
+text-only terminal), try with `display-buffer-pop-up-frame'."
+ (and (if (eq pop-up-frames 'graphic-only)
+ (display-graphic-p)
+ pop-up-frames)
+ (display-buffer-pop-up-frame buffer alist)))
+
+(defun display-buffer--maybe-pop-up-window (buffer alist)
+ "Try displaying BUFFER based on `pop-up-windows'.
+If `pop-up-windows' is non-nil, try with `display-buffer-pop-up-window'."
+ (and pop-up-windows
+ (display-buffer-pop-up-window buffer alist)))
(defun display-buffer-in-child-frame (buffer alist)
"Display BUFFER in a child frame.
@@ -7374,7 +7510,7 @@ be added to ALIST."
(parent (or (assq 'parent-frame parameters)
(selected-frame)))
(share (assq 'share-child-frame parameters))
- share1 frame window)
+ share1 frame window type)
(with-current-buffer buffer
(when (frame-live-p parent)
(catch 'frame
@@ -7387,12 +7523,14 @@ be added to ALIST."
(throw 'frame t))))))
(if frame
- (setq window (frame-selected-window frame))
+ (progn
+ (setq window (frame-selected-window frame))
+ (setq type 'reuse))
(setq frame (make-frame parameters))
- (setq window (frame-selected-window frame))))
+ (setq window (frame-selected-window frame))
+ (setq type 'frame)))
- (prog1 (window--display-buffer
- buffer window 'frame alist display-buffer-mark-dedicated)
+ (prog1 (window--display-buffer buffer window type alist)
(unless (cdr (assq 'inhibit-switch-frame alist))
(window--maybe-raise-frame frame)))))
@@ -7402,22 +7540,54 @@ If there is a window below the selected one and that window
already displays BUFFER, use that window. Otherwise, try to
create a new window below the selected one and show BUFFER there.
If that attempt fails as well and there is a non-dedicated window
-below the selected one, use that window."
- (let (window)
+below the selected one, use that window.
+
+If ALIST contains a 'window-min-height' entry, this function
+ensures that the window used is or can become at least as high as
+specified by that entry's value. Note that such an entry alone
+will not resize the window per se. In order to do that, ALIST
+must also contain a 'window-height' entry with the same value."
+ (let ((min-height (cdr (assq 'window-min-height alist)))
+ window)
(or (and (setq window (window-in-direction 'below))
- (eq buffer (window-buffer window))
+ (eq buffer (window-buffer window))
+ (or (not (numberp min-height))
+ (>= (window-height window) min-height)
+ ;; 'window--display-buffer' can resize this window if
+ ;; and only if it has a 'quit-restore' parameter
+ ;; certifying that it always showed BUFFER before.
+ (let ((height (window-height window))
+ (quit-restore (window-parameter window 'quit-restore)))
+ (and quit-restore
+ (eq (nth 1 quit-restore) 'window)
+ (window-resizable-p window (- min-height height)))))
(window--display-buffer buffer window 'reuse alist))
(and (not (frame-parameter nil 'unsplittable))
- (let ((split-height-threshold 0)
+ (or (not (numberp min-height))
+ (window-sizable-p nil (- min-height)))
+ (let ((split-height-threshold 0)
split-width-threshold)
- (setq window (window--try-to-split-window
+ (setq window (window--try-to-split-window
(selected-window) alist)))
- (window--display-buffer
- buffer window 'window alist display-buffer-mark-dedicated))
+ (window--display-buffer buffer window 'window alist))
(and (setq window (window-in-direction 'below))
- (not (window-dedicated-p window))
- (window--display-buffer
- buffer window 'reuse alist display-buffer-mark-dedicated)))))
+ (not (window-dedicated-p window))
+ (or (not (numberp min-height))
+ ;; A window that showed another buffer before cannot
+ ;; be resized.
+ (>= (window-height window) min-height))
+ (window--display-buffer buffer window 'reuse alist)))))
+
+(defun display-buffer--maybe-at-bottom (buffer alist)
+ (let ((alist (append alist `(,(if temp-buffer-resize-mode
+ '(window-height . resize-temp-buffer-window)
+ '(window-height . fit-window-to-buffer))
+ ,(when temp-buffer-resize-mode
+ '(preserve-size . (nil . t)))))))
+ (or (display-buffer--maybe-same-window buffer alist)
+ (display-buffer-reuse-window buffer alist)
+ (display-buffer--maybe-pop-up-frame buffer alist)
+ (display-buffer-at-bottom buffer alist))))
(defun display-buffer-at-bottom (buffer alist)
"Try displaying BUFFER in a window at the bottom of the selected frame.
@@ -7435,24 +7605,16 @@ selected frame."
(setq bottom-window-shows-buffer t)
(setq bottom-window window))
((not bottom-window)
- (setq bottom-window window)))
- nil nil 'nomini))
+ (setq bottom-window window))))
+ nil nil 'nomini)
(or (and bottom-window-shows-buffer
- (window--display-buffer
- buffer bottom-window 'reuse alist display-buffer-mark-dedicated))
- (and (not (frame-parameter nil 'unsplittable))
- (let (split-width-threshold)
- (setq window (window--try-to-split-window bottom-window alist)))
- (window--display-buffer
- buffer window 'window alist display-buffer-mark-dedicated))
+ (window--display-buffer buffer bottom-window 'reuse alist))
(and (not (frame-parameter nil 'unsplittable))
(setq window (split-window-no-error (window-main-window)))
- (window--display-buffer
- buffer window 'window alist display-buffer-mark-dedicated))
+ (window--display-buffer buffer window 'window alist))
(and (setq window bottom-window)
(not (window-dedicated-p window))
- (window--display-buffer
- buffer window 'reuse alist display-buffer-mark-dedicated)))))
+ (window--display-buffer buffer window 'reuse alist)))))
(defun display-buffer-in-previous-window (buffer alist)
"Display BUFFER in a window previously showing it.
@@ -7501,7 +7663,8 @@ above, even if that window never showed BUFFER before."
;; anything we found so far.
(when (and (setq window (cdr (assq 'previous-window alist)))
(window-live-p window)
- (not (window-dedicated-p window)))
+ (or (eq buffer (window-buffer window))
+ (not (window-dedicated-p window))))
(if (eq window (selected-window))
(unless inhibit-same-window
(setq second-best-window window))
@@ -7671,7 +7834,9 @@ position in the selected window.
This variable is ignored if the buffer is already displayed in
the selected window or never appeared in it before, or if
-`switch-to-buffer' calls `pop-to-buffer' to display the buffer."
+`switch-to-buffer' calls `pop-to-buffer' to display the buffer,
+or non-nil `switch-to-buffer-obey-display-actions' displays it
+in another window."
:type '(choice
(const :tag "Never" nil)
(const :tag "If already displayed elsewhere" already-displayed)
@@ -7706,6 +7871,16 @@ FORCE-SAME-WINDOW is non-nil."
:group 'windows
:version "25.1")
+(defcustom switch-to-buffer-obey-display-actions nil
+ "If non-nil, `switch-to-buffer' runs `pop-to-buffer-same-window' instead.
+This means that when switching the buffer it respects display actions
+specified by `display-buffer-overriding-action', `display-buffer-alist'
+and other display related variables. So `switch-to-buffer' will display
+the buffer in the window specified by the rules from these variables."
+ :type 'boolean
+ :group 'windows
+ :version "27.1")
+
(defun switch-to-buffer (buffer-or-name &optional norecord force-same-window)
"Display buffer BUFFER-OR-NAME in the selected window.
@@ -7738,59 +7913,83 @@ displaying it the most recently selected one.
If optional argument FORCE-SAME-WINDOW is non-nil, the buffer
must be displayed in the selected window when called
non-interactively; if that is impossible, signal an error rather
-than calling `pop-to-buffer'.
+than calling `pop-to-buffer'. It has no effect when the option
+`switch-to-buffer-obey-display-actions' is non-nil.
The option `switch-to-buffer-preserve-window-point' can be used
to make the buffer appear at its last position in the selected
window.
+If the option `switch-to-buffer-obey-display-actions' is non-nil,
+run the function `pop-to-buffer-same-window' instead.
+This may display the buffer in another window as specified by
+`display-buffer-overriding-action', `display-buffer-alist' and
+other display related variables. If this results in displaying
+the buffer in the selected window, window start and point are adjusted
+as prescribed by the option `switch-to-buffer-preserve-window-point'.
+Otherwise, these are left alone.
+
Return the buffer switched to."
(interactive
(let ((force-same-window
- (cond
- ((window-minibuffer-p) nil)
- ((not (eq (window-dedicated-p) t)) 'force-same-window)
- ((pcase switch-to-buffer-in-dedicated-window
- (`nil (user-error
- "Cannot switch buffers in a dedicated window"))
- (`prompt
- (if (y-or-n-p
- (format "Window is dedicated to %s; undedicate it"
- (window-buffer)))
- (progn
- (set-window-dedicated-p nil nil)
- 'force-same-window)
- (user-error
- "Cannot switch buffers in a dedicated window")))
- (`pop nil)
- (_ (set-window-dedicated-p nil nil) 'force-same-window))))))
+ (unless switch-to-buffer-obey-display-actions
+ (cond
+ ((window-minibuffer-p) nil)
+ ((not (eq (window-dedicated-p) t)) 'force-same-window)
+ ((pcase switch-to-buffer-in-dedicated-window
+ ('nil (user-error
+ "Cannot switch buffers in a dedicated window"))
+ ('prompt
+ (if (y-or-n-p
+ (format "Window is dedicated to %s; undedicate it"
+ (window-buffer)))
+ (progn
+ (set-window-dedicated-p nil nil)
+ 'force-same-window)
+ (user-error
+ "Cannot switch buffers in a dedicated window")))
+ ('pop nil)
+ (_ (set-window-dedicated-p nil nil) 'force-same-window)))))))
(list (read-buffer-to-switch "Switch to buffer: ") nil force-same-window)))
- (let ((buffer (window-normalize-buffer-to-switch-to buffer-or-name)))
+ (let ((buffer (window-normalize-buffer-to-switch-to buffer-or-name))
+ (set-window-start-and-point (not switch-to-buffer-obey-display-actions)))
(cond
;; Don't call set-window-buffer if it's not needed since it
;; might signal an error (e.g. if the window is dedicated).
- ((eq buffer (window-buffer)))
- ((window-minibuffer-p)
+ ((and (eq buffer (window-buffer))
+ ;; pop-to-buffer-same-window might decide to display
+ ;; the same buffer in another window
+ (not switch-to-buffer-obey-display-actions)))
+ ((and (window-minibuffer-p)
+ (not switch-to-buffer-obey-display-actions))
(if force-same-window
(user-error "Cannot switch buffers in minibuffer window")
(pop-to-buffer buffer norecord)))
- ((eq (window-dedicated-p) t)
+ ((and (eq (window-dedicated-p) t)
+ (not switch-to-buffer-obey-display-actions))
(if force-same-window
(user-error "Cannot switch buffers in a dedicated window")
(pop-to-buffer buffer norecord)))
(t
- (let* ((entry (assq buffer (window-prev-buffers)))
- (displayed (and (eq switch-to-buffer-preserve-window-point
- 'already-displayed)
- (get-buffer-window buffer 0))))
- (set-window-buffer nil buffer)
- (when (and entry
- (or (eq switch-to-buffer-preserve-window-point t)
- displayed))
- ;; Try to restore start and point of buffer in the selected
- ;; window (Bug#4041).
- (set-window-start (selected-window) (nth 1 entry) t)
- (set-window-point nil (nth 2 entry))))))
+ (when switch-to-buffer-obey-display-actions
+ (let ((selected-window (selected-window)))
+ (pop-to-buffer-same-window buffer norecord)
+ (when (eq (selected-window) selected-window)
+ (setq set-window-start-and-point t))))
+
+ (when set-window-start-and-point
+ (let* ((entry (assq buffer (window-prev-buffers)))
+ (displayed (and (eq switch-to-buffer-preserve-window-point
+ 'already-displayed)
+ (get-buffer-window buffer 0))))
+ (set-window-buffer nil buffer)
+ (when (and entry
+ (or (eq switch-to-buffer-preserve-window-point t)
+ displayed))
+ ;; Try to restore start and point of buffer in the selected
+ ;; window (Bug#4041).
+ (set-window-start (selected-window) (nth 1 entry) t)
+ (set-window-point nil (nth 2 entry)))))))
(unless norecord
(select-window (selected-window)))
@@ -8811,7 +9010,7 @@ A prefix argument is handled like `recenter':
With plain `C-u', move current line to window center."
(interactive "P")
(cond
- (arg (recenter arg)) ; Always respect ARG.
+ (arg (recenter arg t)) ; Always respect ARG.
(t
(setq recenter-last-op
(if (eq this-command last-command)
@@ -8822,15 +9021,15 @@ A prefix argument is handled like `recenter':
(min (max 0 scroll-margin)
(truncate (/ (window-body-height) 4.0)))))
(cond ((eq recenter-last-op 'middle)
- (recenter))
+ (recenter nil t))
((eq recenter-last-op 'top)
- (recenter this-scroll-margin))
+ (recenter this-scroll-margin t))
((eq recenter-last-op 'bottom)
- (recenter (- -1 this-scroll-margin)))
+ (recenter (- -1 this-scroll-margin) t))
((integerp recenter-last-op)
- (recenter recenter-last-op))
+ (recenter recenter-last-op t))
((floatp recenter-last-op)
- (recenter (round (* recenter-last-op (window-height))))))))))
+ (recenter (round (* recenter-last-op (window-height))) t)))))))
(define-key global-map [?\C-l] 'recenter-top-bottom)
@@ -8968,35 +9167,17 @@ This is different from `scroll-down-command' that scrolls a full screen."
(put 'scroll-down-line 'scroll-command t)
-(defun scroll-other-window-down (&optional lines)
- "Scroll the \"other window\" down.
-For more details, see the documentation for `scroll-other-window'."
- (interactive "P")
- (scroll-other-window
- ;; Just invert the argument's meaning.
- ;; We can do that without knowing which window it will be.
- (if (eq lines '-) nil
- (if (null lines) '-
- (- (prefix-numeric-value lines))))))
-
(defun beginning-of-buffer-other-window (arg)
"Move point to the beginning of the buffer in the other window.
Leave mark at previous position.
With arg N, put point N/10 of the way from the true beginning."
(interactive "P")
- (let ((orig-window (selected-window))
- (window (other-window-for-scrolling)))
- ;; We use unwind-protect rather than save-window-excursion
- ;; because the latter would preserve the things we want to change.
- (unwind-protect
- (progn
- (select-window window)
- ;; Set point and mark in that window's buffer.
- (with-no-warnings
- (beginning-of-buffer arg))
- ;; Set point accordingly.
- (recenter '(t)))
- (select-window orig-window))))
+ (with-selected-window (other-window-for-scrolling)
+ ;; Set point and mark in that window's buffer.
+ (with-no-warnings
+ (beginning-of-buffer arg))
+ ;; Set point accordingly.
+ (recenter '(t))))
(defun end-of-buffer-other-window (arg)
"Move point to the end of the buffer in the other window.
@@ -9004,15 +9185,10 @@ Leave mark at previous position.
With arg N, put point N/10 of the way from the true end."
(interactive "P")
;; See beginning-of-buffer-other-window for comments.
- (let ((orig-window (selected-window))
- (window (other-window-for-scrolling)))
- (unwind-protect
- (progn
- (select-window window)
- (with-no-warnings
- (end-of-buffer arg))
- (recenter '(t)))
- (select-window orig-window))))
+ (with-selected-window (other-window-for-scrolling)
+ (with-no-warnings
+ (end-of-buffer arg))
+ (recenter '(t))))
(defvar mouse-autoselect-window-timer nil
"Timer used by delayed window autoselection.")
@@ -9138,6 +9314,8 @@ is active. This function is run by `mouse-autoselect-window-timer'."
;; autoselection.
(mouse-autoselect-window-start mouse-position window)))))
+(declare-function display-multi-frame-p "frame" (&optional display))
+
(defun handle-select-window (event)
"Handle select-window events."
(interactive "^e")
@@ -9175,7 +9353,7 @@ is active. This function is run by `mouse-autoselect-window-timer'."
;; we might get two windows with an active cursor.
(select-window window)
(cond
- ((or (not (memq (window-system frame) '(x w32 ns)))
+ ((or (not (display-multi-frame-p))
(not focus-follows-mouse)
;; Focus FRAME if it's either a child frame or an ancestor
;; of the frame switched from.
@@ -9306,15 +9484,7 @@ displaying that processes's buffer."
(when size
(set-process-window-size process (cdr size) (car size))))))))))
-;; Remove the following call in Emacs 27, running
-;; 'window-size-change-functions' should suffice.
(add-hook 'window-configuration-change-hook 'window--adjust-process-windows)
-
-;; Catch any size changes not handled by
-;; 'window-configuration-change-hook' (Bug#32720, "another issue" in
-;; Bug#33230).
-(add-hook 'window-size-change-functions (lambda (_frame)
- (window--adjust-process-windows)))
;; Some of these are in tutorial--default-keys, so update that if you
;; change these.
diff --git a/lisp/winner.el b/lisp/winner.el
index bdec60cb301..7a5f0df0b70 100644
--- a/lisp/winner.el
+++ b/lisp/winner.el
@@ -351,9 +351,6 @@ You may want to include buffer names such as *Help*, *Apropos*,
;;;###autoload
(define-minor-mode winner-mode
"Toggle Winner mode on or off.
-With a prefix argument ARG, enable Winner mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'.
Winner mode is a global minor mode that records the changes in
the window configuration (i.e. how the frames are partitioned
diff --git a/lisp/woman.el b/lisp/woman.el
index 8a206338f7f..39d9b806d27 100644
--- a/lisp/woman.el
+++ b/lisp/woman.el
@@ -1619,7 +1619,7 @@ decompress the file if appropriate. See the documentation for the
(setq woman-buffer-alist
(cons (cons file-name bufname) woman-buffer-alist)
woman-buffer-number 0)))))
- (Man-build-section-alist)
+ (Man-build-section-list)
(Man-build-references-alist)
(goto-char (point-min)))
@@ -1714,14 +1714,14 @@ Do not call directly!"
;; Interpret overprinting to indicate bold face:
(goto-char (point-min))
- (while (re-search-forward "\\(.\\)\\(\\(+\\1\\)+\\)" nil t)
+ (while (re-search-forward "\\(.\\)\\(\\(\^H+\\1\\)+\\)" nil t)
(woman-delete-match 2)
(woman-set-face (1- (point)) (point) 'woman-bold))
;; Interpret underlining to indicate italic face:
;; (Must be AFTER emboldening to interpret bold _ correctly!)
(goto-char (point-min))
- (while (search-forward "_" nil t)
+ (while (search-forward "_\^H" nil t)
(delete-char -2)
(woman-set-face (point) (1+ (point)) 'woman-italic))
@@ -2010,10 +2010,8 @@ Optional argument REDRAW, if non-nil, forces mode line to be updated."
;; (after Man-bgproc-sentinel-advice activate)
;; ;; Terminates man processing
;; "Report formatting time."
-;; (let* ((time (current-time))
-;; (time (+ (* (- (car time) (car WoMan-Man-start-time)) 65536)
-;; (- (cadr time) (cadr WoMan-Man-start-time)))))
-;; (message "Man formatting done in %d seconds" time)))
+;; (message "Man formatting done in %s seconds"
+;; (float-time (time-since WoMan-Man-start-time))))
;;; Buffer handling:
@@ -2071,14 +2069,14 @@ alist in `woman-buffer-alist' and return nil."
;;; Syntax and display tables:
-(defconst woman-escaped-escape-char ?
+(defconst woman-escaped-escape-char ?\^\\
;; An arbitrary unused control character
"Internal character representation of escaped escape characters.")
(defconst woman-escaped-escape-string
(char-to-string woman-escaped-escape-char)
"Internal string representation of escaped escape characters.")
-(defconst woman-unpadded-space-char ?
+(defconst woman-unpadded-space-char ?\^\]
;; An arbitrary unused control character
"Internal character representation of unpadded space characters.")
(defconst woman-unpadded-space-string
@@ -2626,7 +2624,7 @@ If DELETE is non-nil then delete from point."
(t ; Ignore -- leave in buffer
;; This does not work too well, but it's only for debugging!
(skip-chars-forward "^ \t")
- (if (looking-at "[ \t]*\\{") (search-forward "\\}"))
+ (if (looking-at "[ \t]*{") (search-forward "}"))
(forward-line 1))))
;; request is not used dynamically by any callees.
@@ -2638,7 +2636,7 @@ If DELETE is non-nil then delete from point."
;; Ignore -- leave in buffer
;; This does not work too well, but it's only for debugging!
(skip-chars-forward "^ \t")
- (if (looking-at "[ \t]*\\{") (search-forward "\\}"))
+ (if (looking-at "[ \t]*{") (search-forward "}"))
(forward-line 1)))
(defun woman0-so ()
@@ -3270,7 +3268,7 @@ If optional arg CONCAT is non-nil then join arguments."
(while
;; Find font requests, paragraph macros and font escapes:
(re-search-forward
- "^[.'][ \t]*\\(\\(\\ft\\)\\|\\(.P\\)\\)\\|\\(\\\\f\\)" nil 1)
+ "^[.'][ \t]*\\(\\(ft\\)\\|\\(.P\\)\\)\\|\\(\\\\f\\)" nil 1)
(let (font beg notfont fescape)
;; Match font indicator and leave point at end of sequence:
(cond ((match-beginning 2)
@@ -3513,7 +3511,7 @@ The expression may be an argument in quotes."
(let ((value (if (looking-at "[+-]") 0 (woman-parse-numeric-value)))
op)
(while (cond
- ((looking-at "[+-/*%]") ; arithmetic operators
+ ((looking-at "[+/*%-]") ; arithmetic operators
(forward-char)
(setq op (intern-soft (match-string 0)))
(setq value (funcall op value (woman-parse-numeric-value))))
@@ -3663,46 +3661,46 @@ expression in parentheses. Leaves point after the value."
(fset 'insert-and-inherit (symbol-function 'insert))
(fset 'set-text-properties 'ignore)
(unwind-protect
- (while
- ;; Find next control line:
- (re-search-forward woman-request-regexp nil t)
- (cond
- ;; Construct woman function to call:
- ((setq fn (intern-soft
- (concat "woman2-"
- (setq woman-request (match-string 1)))))
- ;; Delete request or macro name:
- (woman-delete-match 0))
- ;; Unrecognized request:
- ((prog1 nil
- ;; (WoMan-warn ".%s request ignored!" woman-request)
- (WoMan-warn-ignored woman-request "ignored!")
- ;; (setq fn 'woman2-LP)
+ (progn
+ (while
+ ;; Find next control line:
+ (re-search-forward woman-request-regexp nil t)
+ (cond
+ ;; Construct woman function to call:
+ ((setq fn (intern-soft
+ (concat "woman2-"
+ (setq woman-request (match-string 1)))))
+ ;; Delete request or macro name:
+ (woman-delete-match 0))
+ ;; Unrecognized request:
+ ((prog1 nil
+ ;; (WoMan-warn ".%s request ignored!" woman-request)
+ (WoMan-warn-ignored woman-request "ignored!")
+ ;; (setq fn 'woman2-LP)
+ ;; AVOID LEAVING A BLANK LINE!
+ ;; (setq fn 'woman2-format-paragraphs)
+ ))
+ ;; .LP assumes it is at eol and leaves a (blank) line,
+ ;; so leave point at end of line before paragraph:
+ ((or (looking-at "[ \t]*$") ; no argument
+ woman-ignore) ; ignore all
+ ;; (beginning-of-line) (kill-line)
;; AVOID LEAVING A BLANK LINE!
- ;; (setq fn 'woman2-format-paragraphs)
- ))
- ;; .LP assumes it is at eol and leaves a (blank) line,
- ;; so leave point at end of line before paragraph:
- ((or (looking-at "[ \t]*$") ; no argument
- woman-ignore) ; ignore all
- ;; (beginning-of-line) (kill-line)
- ;; AVOID LEAVING A BLANK LINE!
- (beginning-of-line) (woman-delete-line 1))
- (t (end-of-line) (insert ?\n))
- )
- (if (not (or fn
- (and (not (memq (following-char) '(?. ?')))
- (setq fn 'woman2-format-paragraphs))))
- ()
- ;; Find next control line:
- (if (equal woman-request "TS")
- (set-marker to (woman-find-next-control-line "TE"))
- (set-marker to (woman-find-next-control-line)))
- ;; Call the appropriate function:
- (funcall fn to)))
- (if (not (eobp)) ; This should not happen, but ...
- (woman2-format-paragraphs (copy-marker (point-max) t)
- woman-left-margin))
+ (beginning-of-line) (woman-delete-line 1))
+ (t (end-of-line) (insert ?\n)))
+ (if (not (or fn
+ (and (not (memq (following-char) '(?. ?')))
+ (setq fn 'woman2-format-paragraphs))))
+ ()
+ ;; Find next control line:
+ (if (equal woman-request "TS")
+ (set-marker to (woman-find-next-control-line "TE"))
+ (set-marker to (woman-find-next-control-line)))
+ ;; Call the appropriate function:
+ (funcall fn to)))
+ (if (not (eobp)) ; This should not happen, but ...
+ (woman2-format-paragraphs (copy-marker (point-max) t)
+ woman-left-margin)))
(fset 'canonically-space-region canonically-space-region)
(fset 'set-text-properties set-text-properties)
(fset 'insert-and-inherit insert-and-inherit)
diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el
index 8f12b0be25b..e4e2dec3b82 100644
--- a/lisp/x-dnd.el
+++ b/lisp/x-dnd.el
@@ -264,9 +264,8 @@ STRING is the uri-list as a string. The URIs are separated by \\r\\n."
WINDOW is the window where the drop happened.
STRING is the file names as a string, separated by nulls."
(let ((uri-list (split-string string "[\0\r\n]" t))
- (coding (and (default-value 'enable-multibyte-characters)
- (or file-name-coding-system
- default-file-name-coding-system)))
+ (coding (or file-name-coding-system
+ default-file-name-coding-system))
retval)
(dolist (bf uri-list)
;; If one URL is handled, treat as if the whole drop succeeded.
@@ -557,18 +556,18 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent."
(defun x-dnd-motif-value-to-list (value size byteorder)
(let ((bytes (cond ((eq size 2)
- (list (logand (lsh value -8) ?\xff)
+ (list (logand (ash value -8) ?\xff)
(logand value ?\xff)))
((eq size 4)
(if (consp value)
- (list (logand (lsh (car value) -8) ?\xff)
+ (list (logand (ash (car value) -8) ?\xff)
(logand (car value) ?\xff)
- (logand (lsh (cdr value) -8) ?\xff)
+ (logand (ash (cdr value) -8) ?\xff)
(logand (cdr value) ?\xff))
- (list (logand (lsh value -24) ?\xff)
- (logand (lsh value -16) ?\xff)
- (logand (lsh value -8) ?\xff)
+ (list (logand (ash value -24) ?\xff)
+ (logand (ash value -16) ?\xff)
+ (logand (ash value -8) ?\xff)
(logand value ?\xff)))))))
(if (eq byteorder ?l)
(reverse bytes)
diff --git a/lisp/xdg.el b/lisp/xdg.el
index 3a7420d6a41..e5a3de48289 100644
--- a/lisp/xdg.el
+++ b/lisp/xdg.el
@@ -34,6 +34,7 @@
;;; Code:
(eval-when-compile
+ (require 'cl-lib)
(require 'subr-x))
@@ -116,7 +117,7 @@ file:///foo/bar.jpg"
(defun xdg--substitute-home-env (str)
(if (file-name-absolute-p str) str
(save-match-data
- (and (string-match "^$HOME/" str)
+ (and (string-match "^\\$HOME/" str)
(replace-match "~/" t nil str 0)))))
(defun xdg--user-dirs-parse-line ()
@@ -212,6 +213,110 @@ Optional argument GROUP defaults to the string \"Desktop Entry\"."
(when (null (string-match-p "[^[:blank:]]" (car res))) (pop res))
(nreverse res)))
+
+;; MIME apps specification
+;; https://standards.freedesktop.org/mime-apps-spec/mime-apps-spec-1.0.1.html
+
+(defvar xdg-mime-table nil
+ "Table of MIME type to desktop file associations.
+The table is an alist with keys being MIME major types (\"application\",
+\"audio\", etc.), and values being hash tables. Each hash table has
+MIME subtypes as keys and lists of desktop file absolute filenames.")
+
+(defun xdg-mime-apps-files ()
+ "Return a list of files containing MIME/Desktop associations.
+The list is in order of descending priority: user config, then
+admin config, and finally system cached associations."
+ (let ((xdg-data-dirs (xdg-data-dirs))
+ (desktop (getenv "XDG_CURRENT_DESKTOP"))
+ res)
+ (when desktop
+ (setq desktop (format "%s-mimeapps.list" desktop)))
+ (dolist (name (cons "mimeapps.list" desktop))
+ (push (expand-file-name name (xdg-config-home)) res)
+ (push (expand-file-name (format "applications/%s" name) (xdg-data-home))
+ res)
+ (dolist (dir (xdg-config-dirs))
+ (push (expand-file-name name dir) res))
+ (dolist (dir xdg-data-dirs)
+ (push (expand-file-name (format "applications/%s" name) dir) res)))
+ (dolist (dir xdg-data-dirs)
+ (push (expand-file-name "applications/mimeinfo.cache" dir) res))
+ (nreverse res)))
+
+(defun xdg-mime-collect-associations (mime files)
+ "Return a list of desktop file names associated with MIME.
+The associations are searched in the list of file names FILES,
+which is expected to be ordered by priority as in
+`xdg-mime-apps-files'."
+ (let ((regexp (concat (regexp-quote mime) "=\\([^[:cntrl:]]*\\)$"))
+ res sec defaults added removed cached)
+ (with-temp-buffer
+ (dolist (f (reverse files))
+ (when (file-readable-p f)
+ (insert-file-contents-literally f nil nil nil t)
+ (goto-char (point-min))
+ (let (end)
+ (while (not (or (eobp) end))
+ (if (= (following-char) ?\[)
+ (progn (setq sec (char-after (1+ (point))))
+ (forward-line))
+ (if (not (looking-at regexp))
+ (forward-line)
+ (dolist (str (xdg-desktop-strings (match-string 1)))
+ (cl-pushnew str
+ (cond ((eq sec ?D) defaults)
+ ((eq sec ?A) added)
+ ((eq sec ?R) removed)
+ ((eq sec ?M) cached))
+ :test #'equal))
+ (while (and (zerop (forward-line))
+ (/= (following-char) ?\[)))))))
+ ;; Accumulate results into res
+ (dolist (f cached)
+ (when (not (member f removed)) (cl-pushnew f res :test #'equal)))
+ (dolist (f added)
+ (when (not (member f removed)) (push f res)))
+ (dolist (f removed)
+ (setq res (delete f res)))
+ (dolist (f defaults)
+ (push f res))
+ (setq defaults nil added nil removed nil cached nil))))
+ (delete-dups res)))
+
+(defun xdg-mime-apps (mime)
+ "Return list of desktop files associated with MIME, otherwise nil.
+The list is in order of descending priority, and each element is
+an absolute file name of a readable file.
+Results are cached in `xdg-mime-table'."
+ (pcase-let ((`(,type ,subtype) (split-string mime "/"))
+ (xdg-data-dirs (xdg-data-dirs))
+ (caches (xdg-mime-apps-files))
+ (files ()))
+ (let ((mtim1 (get 'xdg-mime-table 'mtime))
+ (mtim2 (cl-loop for f in caches when (file-readable-p f)
+ maximize (float-time
+ (file-attribute-modification-time
+ (file-attributes f))))))
+ ;; If one of the MIME/Desktop cache files has been modified:
+ (when (or (null mtim1) (time-less-p mtim1 mtim2))
+ (setq xdg-mime-table nil)))
+ (when (null (assoc type xdg-mime-table))
+ (push (cons type (make-hash-table :test #'equal)) xdg-mime-table))
+ (if (let ((def (make-symbol "def"))
+ (table (cdr (assoc type xdg-mime-table))))
+ (not (eq (setq files (gethash subtype table def)) def)))
+ files
+ (and files (setq files nil))
+ (let ((dirs (mapcar (lambda (dir) (expand-file-name "applications" dir))
+ (cons (xdg-data-home) xdg-data-dirs))))
+ ;; Not being particular about desktop IDs
+ (dolist (f (nreverse (xdg-mime-collect-associations mime caches)))
+ (push (locate-file f dirs) files))
+ (when files
+ (put 'xdg-mime-table 'mtime (current-time)))
+ (puthash subtype (delq nil files) (cdr (assoc type xdg-mime-table)))))))
+
(provide 'xdg)
;;; xdg.el ends here
diff --git a/lisp/xml.el b/lisp/xml.el
index cec1f8a4e16..b5b923f863e 100644
--- a/lisp/xml.el
+++ b/lisp/xml.el
@@ -176,11 +176,11 @@ See also `xml-get-attribute-or-nil'."
;; [4] NameStartChar
;; See the definition of word syntax in `xml-syntax-table'.
-(defconst xml-name-start-char-re (concat "[[:word:]:_]"))
+(defconst xml-name-start-char-re "[[:word:]:_]")
;; [4a] NameChar ::= NameStartChar | "-" | "." | [0-9] | #xB7
;; | [#x0300-#x036F] | [#x203F-#x2040]
-(defconst xml-name-char-re (concat "[-0-9.[:word:]:_·̀-ͯ‿-⁀]"))
+(defconst xml-name-char-re "[[:word:]:_.0-9\u00B7\u0300-\u036F\u203F\u2040-]")
;; [5] Name ::= NameStartChar (NameChar)*
(defconst xml-name-re (concat xml-name-start-char-re xml-name-char-re "*"))
@@ -718,10 +718,10 @@ This follows the rule [28] in the XML specifications."
(cond ((looking-at "PUBLIC\\s-+")
(goto-char (match-end 0))
(unless (or (re-search-forward
- "\\=\"\\([[:space:][:alnum:]-'()+,./:=?;!*#@$_%]*\\)\""
+ "\\=\"\\([[:space:][:alnum:]'()+,./:=?;!*#@$_%-]*\\)\""
nil t)
(re-search-forward
- "\\='\\([[:space:][:alnum:]-()+,./:=?;!*#@$_%]*\\)'"
+ "\\='\\([[:space:][:alnum:]()+,./:=?;!*#@$_%-]*\\)'"
nil t))
(error "XML: Missing Public ID"))
(let ((pubid (match-string-no-properties 1)))
@@ -1073,6 +1073,19 @@ The first line is indented with INDENT-STRING."
(insert ?\n indent-string))
(insert ?< ?/ (symbol-name (xml-node-name xml)) ?>))))
+;;;###autoload
+(defun xml-remove-comments (beg end)
+ "Remove XML/HTML comments in the region between BEG and END.
+All text between the <!-- ... --> markers will be removed."
+ (save-excursion
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char beg)
+ (while (search-forward "<!--" nil t)
+ (let ((start (match-beginning 0)))
+ (when (search-forward "-->" nil t)
+ (delete-region start (point))))))))
+
(provide 'xml)
;;; xml.el ends here
diff --git a/lisp/xt-mouse.el b/lisp/xt-mouse.el
index cfa9c36ea0e..5ff718292d3 100644
--- a/lisp/xt-mouse.el
+++ b/lisp/xt-mouse.el
@@ -123,20 +123,7 @@ http://invisible-island.net/xterm/ctlseqs/ctlseqs.html)."
(terminal-parameter nil 'xterm-mouse-y))))
pos)
-(defun xterm-mouse-truncate-wrap (f)
- "Truncate with wrap-around."
- (condition-case nil
- ;; First try the built-in truncate, in case there's no overflow.
- (truncate f)
- ;; In case of overflow, do wraparound by hand.
- (range-error
- ;; In our case, we wrap around every 3 days or so, so if we assume
- ;; a maximum of 65536 wraparounds, we're safe for a couple years.
- ;; Using a power of 2 makes rounding errors less likely.
- (let* ((maxwrap (* 65536 2048))
- (dbig (truncate (/ f maxwrap)))
- (fdiff (- f (* 1.0 maxwrap dbig))))
- (+ (truncate fdiff) (* maxwrap dbig))))))
+(define-obsolete-function-alias 'xterm-mouse-truncate-wrap 'truncate "27.1")
(defcustom xterm-mouse-utf-8 nil
"Non-nil if UTF-8 coordinates should be used to read mouse coordinates.
@@ -256,18 +243,17 @@ which is the \"1006\" extension implemented in Xterm >= 277."
(y (nth 2 click))
;; Emulate timestamp information. This is accurate enough
;; for default value of mouse-1-click-follows-link (450msec).
- (timestamp (xterm-mouse-truncate-wrap
- (* 1000
- (- (float-time)
- (or xt-mouse-epoch
- (setq xt-mouse-epoch (float-time)))))))
+ (timestamp (if (not xt-mouse-epoch)
+ (progn (setq xt-mouse-epoch (float-time)) 0)
+ (car (encode-time (time-since xt-mouse-epoch)
+ 1000))))
(w (window-at x y))
(ltrb (window-edges w))
(left (nth 0 ltrb))
(top (nth 1 ltrb))
(posn (if w
- (posn-at-x-y (- x left) (- y top) w t)
- (append (list nil 'menu-bar)
+ (posn-at-x-y (- x left) (- y top) w t)
+ (append (list nil 'menu-bar)
(nthcdr 2 (posn-at-x-y x y)))))
(event (list type posn)))
(setcar (nthcdr 3 posn) timestamp)
@@ -312,9 +298,6 @@ which is the \"1006\" extension implemented in Xterm >= 277."
;;;###autoload
(define-minor-mode xterm-mouse-mode
"Toggle XTerm mouse mode.
-With a prefix argument ARG, enable XTerm mouse mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
Turn it on to use Emacs mouse commands, and off to use xterm mouse commands.
This works in terminal emulators compatible with xterm. It only
diff --git a/lwlib/Makefile.in b/lwlib/Makefile.in
index a9ff973ad56..e1d92872732 100644
--- a/lwlib/Makefile.in
+++ b/lwlib/Makefile.in
@@ -111,7 +111,7 @@ $(globals_h):
.PHONY: mostlyclean clean distclean bootstrap-clean maintainer-clean
clean mostlyclean:
- rm -f *.o liblw.a \#* $(DEPDIR)/*
+ rm -f ./*.o liblw.a \#* $(DEPDIR)/*
distclean: clean
rm -f Makefile
diff --git a/m4/__inline.m4 b/m4/__inline.m4
new file mode 100644
index 00000000000..e1aa310c957
--- /dev/null
+++ b/m4/__inline.m4
@@ -0,0 +1,22 @@
+# Test for __inline keyword
+dnl Copyright 2017-2019 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.
+
+AC_DEFUN([gl___INLINE],
+[
+ AC_CACHE_CHECK([whether the compiler supports the __inline keyword],
+ [gl_cv_c___inline],
+ [AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[typedef int foo_t;
+ static __inline foo_t foo (void) { return 0; }]],
+ [[return foo ();]])],
+ [gl_cv_c___inline=yes],
+ [gl_cv_c___inline=no])])
+ if test $gl_cv_c___inline = yes; then
+ AC_DEFINE([HAVE___INLINE], [1],
+ [Define to 1 if the compiler supports the keyword '__inline'.])
+ fi
+])
diff --git a/m4/acl.m4 b/m4/acl.m4
index 9ee7bbbde47..5234a80f93f 100644
--- a/m4/acl.m4
+++ b/m4/acl.m4
@@ -1,5 +1,5 @@
# acl.m4 - check for access control list (ACL) primitives
-# serial 22
+# serial 23
# Copyright (C) 2002, 2004-2019 Free Software Foundation, Inc.
# This file is free software; the Free Software Foundation
@@ -30,7 +30,8 @@ AC_DEFUN([gl_FUNC_ACL],
ac_save_LIBS=$LIBS
dnl Test for POSIX-draft-like API (GNU/Linux, FreeBSD, Mac OS X,
- dnl IRIX, Tru64). -lacl is needed on GNU/Linux, -lpacl on OSF/1.
+ dnl IRIX, Tru64, Cygwin >= 2.5).
+ dnl -lacl is needed on GNU/Linux, -lpacl on OSF/1.
if test $use_acl = 0; then
AC_SEARCH_LIBS([acl_get_file], [acl pacl],
[if test "$ac_cv_search_acl_get_file" != "none required"; then
diff --git a/m4/alloca.m4 b/m4/alloca.m4
index c379eea1da4..29bd289b02a 100644
--- a/m4/alloca.m4
+++ b/m4/alloca.m4
@@ -1,6 +1,6 @@
-# alloca.m4 serial 14
-dnl Copyright (C) 2002-2004, 2006-2007, 2009-2019 Free Software
-dnl Foundation, Inc.
+# alloca.m4 serial 15
+dnl Copyright (C) 2002-2004, 2006-2007, 2009-2019 Free Software Foundation,
+dnl 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.
@@ -37,6 +37,13 @@ AC_DEFUN([gl_FUNC_ALLOCA],
fi
AC_SUBST([ALLOCA_H])
AM_CONDITIONAL([GL_GENERATE_ALLOCA_H], [test -n "$ALLOCA_H"])
+
+ if test $ac_cv_working_alloca_h = yes; then
+ HAVE_ALLOCA_H=1
+ else
+ HAVE_ALLOCA_H=0
+ fi
+ AC_SUBST([HAVE_ALLOCA_H])
])
# Prerequisites of lib/alloca.c.
diff --git a/m4/builtin-expect.m4 b/m4/builtin-expect.m4
new file mode 100644
index 00000000000..b65fbf87a62
--- /dev/null
+++ b/m4/builtin-expect.m4
@@ -0,0 +1,49 @@
+dnl Check for __builtin_expect.
+
+dnl Copyright 2016-2019 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 Written by Paul Eggert.
+
+AC_DEFUN([gl___BUILTIN_EXPECT],
+[
+ AC_CACHE_CHECK([for __builtin_expect],
+ [gl_cv___builtin_expect],
+ [AC_LINK_IFELSE(
+ [AC_LANG_SOURCE([[
+ int
+ main (int argc, char **argv)
+ {
+ argc = __builtin_expect (argc, 100);
+ return argv[argc != 100][0];
+ }]])],
+ [gl_cv___builtin_expect=yes],
+ [AC_LINK_IFELSE(
+ [AC_LANG_SOURCE([[
+ #include <builtins.h>
+ int
+ main (int argc, char **argv)
+ {
+ argc = __builtin_expect (argc, 100);
+ return argv[argc != 100][0];
+ }]])],
+ [gl_cv___builtin_expect="in <builtins.h>"],
+ [gl_cv___builtin_expect=no])])])
+ if test "$gl_cv___builtin_expect" = yes; then
+ AC_DEFINE([HAVE___BUILTIN_EXPECT], [1])
+ elif test "$gl_cv___builtin_expect" = "in <builtins.h>"; then
+ AC_DEFINE([HAVE___BUILTIN_EXPECT], [2])
+ fi
+ AH_VERBATIM([HAVE___BUILTIN_EXPECT],
+ [/* Define to 1 if the compiler supports __builtin_expect,
+ and to 2 if <builtins.h> does. */
+#undef HAVE___BUILTIN_EXPECT
+#ifndef HAVE___BUILTIN_EXPECT
+# define __builtin_expect(e, c) (e)
+#elif HAVE___BUILTIN_EXPECT == 2
+# include <builtins.h>
+#endif
+ ])
+])
diff --git a/m4/c-strtod.m4 b/m4/c-strtod.m4
deleted file mode 100644
index 5b6e8297310..00000000000
--- a/m4/c-strtod.m4
+++ /dev/null
@@ -1,49 +0,0 @@
-# c-strtod.m4 serial 15
-
-# Copyright (C) 2004-2006, 2009-2019 Free Software Foundation, Inc.
-# This file is free software; the Free Software Foundation
-# gives unlimited permission to copy and/or distribute it,
-# with or without modifications, as long as this notice is preserved.
-
-# Written by Paul Eggert.
-
-AC_DEFUN([gl_C99_STRTOLD],
-[
- AC_CACHE_CHECK([whether strtold conforms to C99],
- [gl_cv_func_c99_strtold],
- [AC_LINK_IFELSE(
- [AC_LANG_PROGRAM(
- [[/* On HP-UX before 11.23, strtold returns a struct instead of
- long double. Reject implementations like that, by requiring
- compatibility with the C99 prototype. */
- #include <stdlib.h>
- static long double (*p) (char const *, char **) = strtold;
- static long double
- test (char const *nptr, char **endptr)
- {
- long double r;
- r = strtold (nptr, endptr);
- return r;
- }]],
- [[return test ("1.0", NULL) != 1 || p ("1.0", NULL) != 1;]])],
- [gl_cv_func_c99_strtold=yes],
- [gl_cv_func_c99_strtold=no])])
- if test $gl_cv_func_c99_strtold = yes; then
- AC_DEFINE([HAVE_C99_STRTOLD], [1], [Define to 1 if strtold conforms to C99.])
- fi
-])
-
-dnl Prerequisites of lib/c-strtod.c.
-AC_DEFUN([gl_C_STRTOD],
-[
- AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
- AC_CHECK_FUNCS([strtod_l])
-])
-
-dnl Prerequisites of lib/c-strtold.c.
-AC_DEFUN([gl_C_STRTOLD],
-[
- AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
- AC_REQUIRE([gl_C99_STRTOLD])
- AC_CHECK_FUNCS([strtold_l])
-])
diff --git a/m4/d-type.m4 b/m4/d-type.m4
index d5c5f1e02b4..4ca56d61910 100644
--- a/m4/d-type.m4
+++ b/m4/d-type.m4
@@ -5,8 +5,7 @@ dnl
dnl Check whether struct dirent has a member named d_type.
dnl
-# Copyright (C) 1997, 1999-2004, 2006, 2009-2019 Free Software
-# Foundation, Inc.
+# Copyright (C) 1997, 1999-2004, 2006, 2009-2019 Free Software Foundation, Inc.
#
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
diff --git a/m4/dup2.m4 b/m4/dup2.m4
index 28db4d64851..b314247d3bc 100644
--- a/m4/dup2.m4
+++ b/m4/dup2.m4
@@ -1,6 +1,5 @@
#serial 25
-dnl Copyright (C) 2002, 2005, 2007, 2009-2019 Free Software Foundation,
-dnl Inc.
+dnl Copyright (C) 2002, 2005, 2007, 2009-2019 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.
diff --git a/m4/eealloc.m4 b/m4/eealloc.m4
new file mode 100644
index 00000000000..2a4b120a172
--- /dev/null
+++ b/m4/eealloc.m4
@@ -0,0 +1,31 @@
+# eealloc.m4 serial 3
+dnl Copyright (C) 2003, 2009-2019 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.
+
+AC_DEFUN([gl_EEALLOC],
+[
+ AC_REQUIRE([gl_EEMALLOC])
+ AC_REQUIRE([gl_EEREALLOC])
+])
+
+AC_DEFUN([gl_EEMALLOC],
+[
+ _AC_FUNC_MALLOC_IF(
+ [gl_cv_func_malloc_0_nonnull=1],
+ [gl_cv_func_malloc_0_nonnull=0])
+ AC_DEFINE_UNQUOTED([MALLOC_0_IS_NONNULL], [$gl_cv_func_malloc_0_nonnull],
+ [If malloc(0) is != NULL, define this to 1. Otherwise define this
+ to 0.])
+])
+
+AC_DEFUN([gl_EEREALLOC],
+[
+ _AC_FUNC_REALLOC_IF(
+ [gl_cv_func_realloc_0_nonnull=1],
+ [gl_cv_func_realloc_0_nonnull=0])
+ AC_DEFINE_UNQUOTED([REALLOC_0_IS_NONNULL], [$gl_cv_func_realloc_0_nonnull],
+ [If realloc(NULL,0) is != NULL, define this to 1. Otherwise define this
+ to 0.])
+])
diff --git a/m4/environ.m4 b/m4/environ.m4
index 974bd56adb3..c1a6fa37468 100644
--- a/m4/environ.m4
+++ b/m4/environ.m4
@@ -1,4 +1,4 @@
-# environ.m4 serial 6
+# environ.m4 serial 7
dnl Copyright (C) 2001-2004, 2006-2019 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -29,16 +29,14 @@ AC_DEFUN_ONCE([gl_ENVIRON],
AC_DEFUN([gt_CHECK_VAR_DECL],
[
define([gt_cv_var], [gt_cv_var_]$2[_declaration])
- AC_MSG_CHECKING([if $2 is properly declared])
- AC_CACHE_VAL([gt_cv_var], [
- AC_COMPILE_IFELSE(
- [AC_LANG_PROGRAM(
- [[$1
- extern struct { int foo; } $2;]],
- [[$2.foo = 1;]])],
- [gt_cv_var=no],
- [gt_cv_var=yes])])
- AC_MSG_RESULT([$gt_cv_var])
+ AC_CACHE_CHECK([if $2 is properly declared], [gt_cv_var],
+ [AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[$1
+ extern struct { int foo; } $2;]],
+ [[$2.foo = 1;]])],
+ [gt_cv_var=no],
+ [gt_cv_var=yes])])
if test $gt_cv_var = yes; then
AC_DEFINE([HAVE_]m4_translit($2, [a-z], [A-Z])[_DECL], 1,
[Define if you have the declaration of $2.])
diff --git a/m4/errno_h.m4 b/m4/errno_h.m4
index 0dd8f44ff71..2388854e057 100644
--- a/m4/errno_h.m4
+++ b/m4/errno_h.m4
@@ -1,9 +1,11 @@
-# errno_h.m4 serial 12
+# errno_h.m4 serial 13
dnl Copyright (C) 2004, 2006, 2008-2019 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.
+AC_PREREQ([2.61])
+
AC_DEFUN_ONCE([gl_HEADER_ERRNO_H],
[
AC_REQUIRE([AC_PROG_CC])
@@ -129,9 +131,3 @@ yes
AC_SUBST($1[_VALUE])
fi
])
-
-dnl Autoconf >= 2.61 has AC_COMPUTE_INT built-in.
-dnl Remove this when we can assume autoconf >= 2.61.
-m4_ifdef([AC_COMPUTE_INT], [], [
- AC_DEFUN([AC_COMPUTE_INT], [_AC_COMPUTE_INT([$2],[$1],[$3],[$4])])
-])
diff --git a/m4/extensions.m4 b/m4/extensions.m4
index 1a8e899d369..fd1ce817f06 100644
--- a/m4/extensions.m4
+++ b/m4/extensions.m4
@@ -1,4 +1,4 @@
-# serial 17 -*- Autoconf -*-
+# serial 18 -*- Autoconf -*-
# Enable extensions on systems that normally disable them.
# Copyright (C) 2003, 2006-2019 Free Software Foundation, Inc.
@@ -118,6 +118,11 @@ dnl configure.ac when using autoheader 2.62.
#ifndef _XOPEN_SOURCE
# undef _XOPEN_SOURCE
#endif
+/* Enable X/Open compliant socket functions that do not require linking
+ with -lxnet on HP-UX 11.11. */
+#ifndef _HPUX_ALT_XOPEN_SOCKET_API
+# undef _HPUX_ALT_XOPEN_SOCKET_API
+#endif
/* Enable general extensions on Solaris. */
#ifndef __EXTENSIONS__
# undef __EXTENSIONS__
@@ -163,6 +168,7 @@ dnl configure.ac when using autoheader 2.62.
[ac_cv_should_define__xopen_source=yes])])])
test $ac_cv_should_define__xopen_source = yes &&
AC_DEFINE([_XOPEN_SOURCE], [500])
+ AC_DEFINE([_HPUX_ALT_XOPEN_SOCKET_API])
])# AC_USE_SYSTEM_EXTENSIONS
# gl_USE_SYSTEM_EXTENSIONS
diff --git a/m4/extern-inline.m4 b/m4/extern-inline.m4
index a33d2a9e71d..ec9f2218bf3 100644
--- a/m4/extern-inline.m4
+++ b/m4/extern-inline.m4
@@ -25,7 +25,8 @@ AC_DEFUN([gl_EXTERN_INLINE],
if isdigit is mistakenly implemented via a static inline function,
a program containing an extern inline function that calls isdigit
may not work since the C standard prohibits extern inline functions
- from calling static functions. This bug is known to occur on:
+ from calling static functions (ISO C 99 section 6.7.4.(3).
+ This bug is known to occur on:
OS X 10.8 and earlier; see:
https://lists.gnu.org/r/bug-gnulib/2012-12/msg00023.html
@@ -38,7 +39,18 @@ AC_DEFUN([gl_EXTERN_INLINE],
OS X 10.9 has a macro __header_inline indicating the bug is fixed for C and
for clang but remains for g++; see <https://trac.macports.org/ticket/41033>.
- Assume DragonFly and FreeBSD will be similar. */
+ Assume DragonFly and FreeBSD will be similar.
+
+ GCC 4.3 and above with -std=c99 or -std=gnu99 implements ISO C99
+ inline semantics, unless -fgnu89-inline is used. It defines a macro
+ __GNUC_STDC_INLINE__ to indicate this situation or a macro
+ __GNUC_GNU_INLINE__ to indicate the opposite situation.
+ GCC 4.2 with -std=c99 or -std=gnu99 implements the GNU C inline
+ semantics but warns, unless -fgnu89-inline is used:
+ warning: C99 inline functions are not supported; using GNU89
+ warning: to disable this warning use -fgnu89-inline or the gnu_inline function attribute
+ It defines a macro __GNUC_GNU_INLINE__ to indicate this situation.
+ */
#if (((defined __APPLE__ && defined __MACH__) \
|| defined __DragonFly__ || defined __FreeBSD__) \
&& (defined __header_inline \
diff --git a/m4/fdatasync.m4 b/m4/fdatasync.m4
deleted file mode 100644
index c2ea85e4dfd..00000000000
--- a/m4/fdatasync.m4
+++ /dev/null
@@ -1,32 +0,0 @@
-# fdatasync.m4 serial 4
-dnl Copyright (C) 2008-2019 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.
-
-AC_DEFUN([gl_FUNC_FDATASYNC],
-[
- AC_REQUIRE([gl_UNISTD_H_DEFAULTS])
-
- dnl Using AC_CHECK_FUNCS_ONCE would break our subsequent AC_SEARCH_LIBS
- AC_CHECK_DECLS_ONCE([fdatasync])
- LIB_FDATASYNC=
- AC_SUBST([LIB_FDATASYNC])
-
- if test $ac_cv_have_decl_fdatasync = no; then
- HAVE_DECL_FDATASYNC=0
- dnl Mac OS X 10.7 has fdatasync but does not declare it.
- AC_CHECK_FUNCS([fdatasync])
- if test $ac_cv_func_fdatasync = no; then
- HAVE_FDATASYNC=0
- fi
- else
- dnl Solaris <= 2.6 has fdatasync() in libposix4.
- dnl Solaris 7..10 has it in librt.
- gl_saved_libs=$LIBS
- AC_SEARCH_LIBS([fdatasync], [rt posix4],
- [test "$ac_cv_search_fdatasync" = "none required" ||
- LIB_FDATASYNC=$ac_cv_search_fdatasync])
- LIBS=$gl_saved_libs
- fi
-])
diff --git a/m4/fdopendir.m4 b/m4/fdopendir.m4
index 04905519d0b..b2b3b037316 100644
--- a/m4/fdopendir.m4
+++ b/m4/fdopendir.m4
@@ -1,4 +1,4 @@
-# serial 10
+# serial 11
# See if we need to provide fdopendir.
dnl Copyright (C) 2009-2019 Free Software Foundation, Inc.
@@ -45,10 +45,12 @@ DIR *fdopendir (int);
[gl_cv_func_fdopendir_works=yes],
[gl_cv_func_fdopendir_works=no],
[case "$host_os" in
- # Guess yes on glibc systems.
- *-gnu*) gl_cv_func_fdopendir_works="guessing yes" ;;
- # If we don't know, assume the worst.
- *) gl_cv_func_fdopendir_works="guessing no" ;;
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_fdopendir_works="guessing yes" ;;
+ # Guess yes on musl systems.
+ *-musl*) gl_cv_func_fdopendir_works="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_fdopendir_works="guessing no" ;;
esac
])])
case "$gl_cv_func_fdopendir_works" in
diff --git a/m4/filemode.m4 b/m4/filemode.m4
index 82ca2a626f5..c086c680d3c 100644
--- a/m4/filemode.m4
+++ b/m4/filemode.m4
@@ -1,6 +1,5 @@
# filemode.m4 serial 8
-dnl Copyright (C) 2002, 2005-2006, 2009-2019 Free Software Foundation,
-dnl Inc.
+dnl Copyright (C) 2002, 2005-2006, 2009-2019 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.
diff --git a/m4/fsusage.m4 b/m4/fsusage.m4
new file mode 100644
index 00000000000..a283f645dda
--- /dev/null
+++ b/m4/fsusage.m4
@@ -0,0 +1,307 @@
+# serial 34
+# Obtaining file system usage information.
+
+# Copyright (C) 1997-1998, 2000-2001, 2003-2019 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# Written by Jim Meyering.
+
+AC_DEFUN([gl_FSUSAGE],
+[
+ AC_CHECK_HEADERS_ONCE([sys/param.h])
+ AC_CHECK_HEADERS_ONCE([sys/vfs.h sys/fs_types.h])
+ AC_CHECK_HEADERS([sys/mount.h], [], [],
+ [AC_INCLUDES_DEFAULT
+ [#if HAVE_SYS_PARAM_H
+ #include <sys/param.h>
+ #endif]])
+ gl_FILE_SYSTEM_USAGE([gl_cv_fs_space=yes], [gl_cv_fs_space=no])
+])
+
+# Try to determine how a program can obtain file system usage information.
+# If successful, define the appropriate symbol (see fsusage.c) and
+# execute ACTION-IF-FOUND. Otherwise, execute ACTION-IF-NOT-FOUND.
+#
+# gl_FILE_SYSTEM_USAGE([ACTION-IF-FOUND[, ACTION-IF-NOT-FOUND]])
+
+AC_DEFUN([gl_FILE_SYSTEM_USAGE],
+[
+ dnl Enable large-file support. This has the effect of changing the size
+ dnl of field f_blocks in 'struct statvfs' from 32 bit to 64 bit on
+ dnl glibc/Hurd, HP-UX 11, Solaris (32-bit mode). It also changes the size
+ dnl of field f_blocks in 'struct statfs' from 32 bit to 64 bit on
+ dnl Mac OS X >= 10.5 (32-bit mode).
+ AC_REQUIRE([AC_SYS_LARGEFILE])
+
+ AC_MSG_CHECKING([how to get file system space usage])
+ ac_fsusage_space=no
+
+ # Perform only the link test since it seems there are no variants of the
+ # statvfs function. This check is more than just AC_CHECK_FUNCS([statvfs])
+ # because that got a false positive on SCO OSR5. Adding the declaration
+ # of a 'struct statvfs' causes this test to fail (as it should) on such
+ # systems. That system is reported to work fine with STAT_STATFS4 which
+ # is what it gets when this test fails.
+ if test $ac_fsusage_space = no; then
+ # glibc/{Hurd,kFreeBSD}, FreeBSD >= 5.0, NetBSD >= 3.0,
+ # OpenBSD >= 4.4, AIX, HP-UX, IRIX, Solaris, Cygwin, Interix, BeOS.
+ AC_CACHE_CHECK([for statvfs function (SVR4)],
+ [fu_cv_sys_stat_statvfs],
+ [AC_LINK_IFELSE(
+ [AC_LANG_PROGRAM([[
+#include <sys/types.h>
+#ifdef __osf__
+"Do not use Tru64's statvfs implementation"
+#endif
+
+#include <sys/statvfs.h>
+
+struct statvfs fsd;
+
+#if defined __APPLE__ && defined __MACH__
+#include <limits.h>
+/* On Mac OS X >= 10.5, f_blocks in 'struct statvfs' is a 32-bit quantity;
+ that commonly limits file systems to 4 TiB. Whereas f_blocks in
+ 'struct statfs' is a 64-bit type, thanks to the large-file support
+ that was enabled above. In this case, don't use statvfs(); use statfs()
+ instead. */
+int check_f_blocks_size[sizeof fsd.f_blocks * CHAR_BIT <= 32 ? -1 : 1];
+#endif
+]],
+ [[statvfs (0, &fsd);]])],
+ [fu_cv_sys_stat_statvfs=yes],
+ [fu_cv_sys_stat_statvfs=no])
+ ])
+ if test $fu_cv_sys_stat_statvfs = yes; then
+ ac_fsusage_space=yes
+ # AIX >= 5.2 has statvfs64 that has a wider f_blocks field than statvfs.
+ # glibc, HP-UX, IRIX, Solaris have statvfs64 as well, but on these systems
+ # statvfs with large-file support is already equivalent to statvfs64.
+ AC_CACHE_CHECK([whether to use statvfs64],
+ [fu_cv_sys_stat_statvfs64],
+ [AC_LINK_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#include <sys/types.h>
+ #include <sys/statvfs.h>
+ struct statvfs64 fsd;
+ int check_f_blocks_larger_in_statvfs64
+ [sizeof (((struct statvfs64 *) 0)->f_blocks)
+ > sizeof (((struct statvfs *) 0)->f_blocks)
+ ? 1 : -1];
+ ]],
+ [[statvfs64 (0, &fsd);]])],
+ [fu_cv_sys_stat_statvfs64=yes],
+ [fu_cv_sys_stat_statvfs64=no])
+ ])
+ if test $fu_cv_sys_stat_statvfs64 = yes; then
+ AC_DEFINE([STAT_STATVFS64], [1],
+ [Define if statvfs64 should be preferred over statvfs.])
+ else
+ AC_DEFINE([STAT_STATVFS], [1],
+ [Define if there is a function named statvfs. (SVR4)])
+ fi
+ fi
+ fi
+
+ # Check for this unconditionally so we have a
+ # good fallback on glibc/Linux > 2.6 < 2.6.36
+ AC_CACHE_CHECK([for two-argument statfs with statfs.f_frsize member],
+ [fu_cv_sys_stat_statfs2_frsize],
+ [AC_RUN_IFELSE(
+ [AC_LANG_SOURCE([[
+#ifdef HAVE_SYS_PARAM_H
+#include <sys/param.h>
+#endif
+#ifdef HAVE_SYS_MOUNT_H
+#include <sys/mount.h>
+#endif
+#ifdef HAVE_SYS_VFS_H
+#include <sys/vfs.h>
+#endif
+ int
+ main ()
+ {
+ struct statfs fsd;
+ fsd.f_frsize = 0;
+ return statfs (".", &fsd) != 0;
+ }]])],
+ [fu_cv_sys_stat_statfs2_frsize=yes],
+ [fu_cv_sys_stat_statfs2_frsize=no],
+ [fu_cv_sys_stat_statfs2_frsize=no])
+ ])
+ if test $fu_cv_sys_stat_statfs2_frsize = yes; then
+ ac_fsusage_space=yes
+ AC_DEFINE([STAT_STATFS2_FRSIZE], [1],
+ [Define if statfs takes 2 args and struct statfs has a field named f_frsize.
+ (glibc/Linux > 2.6)])
+ fi
+
+ if test $ac_fsusage_space = no; then
+ # DEC Alpha running OSF/1
+ AC_CACHE_CHECK([for 3-argument statfs function (DEC OSF/1)],
+ [fu_cv_sys_stat_statfs3_osf1],
+ [AC_RUN_IFELSE([AC_LANG_SOURCE([[
+#include <sys/param.h>
+#include <sys/types.h>
+#include <sys/mount.h>
+ int
+ main ()
+ {
+ struct statfs fsd;
+ fsd.f_fsize = 0;
+ return statfs (".", &fsd, sizeof (struct statfs)) != 0;
+ }]])],
+ [fu_cv_sys_stat_statfs3_osf1=yes],
+ [fu_cv_sys_stat_statfs3_osf1=no],
+ [fu_cv_sys_stat_statfs3_osf1=no])
+ ])
+ if test $fu_cv_sys_stat_statfs3_osf1 = yes; then
+ ac_fsusage_space=yes
+ AC_DEFINE([STAT_STATFS3_OSF1], [1],
+ [Define if statfs takes 3 args. (DEC Alpha running OSF/1)])
+ fi
+ fi
+
+ if test $ac_fsusage_space = no; then
+ # glibc/Linux, Mac OS X, FreeBSD < 5.0, NetBSD < 3.0, OpenBSD < 4.4.
+ # (glibc/{Hurd,kFreeBSD}, FreeBSD >= 5.0, NetBSD >= 3.0,
+ # OpenBSD >= 4.4, AIX, HP-UX, OSF/1, Cygwin already handled above.)
+ # (On IRIX you need to include <sys/statfs.h>, not only <sys/mount.h> and
+ # <sys/vfs.h>.)
+ # (On Solaris, statfs has 4 arguments.)
+ AC_CACHE_CHECK([for two-argument statfs with statfs.f_bsize member (AIX, 4.3BSD)],
+ [fu_cv_sys_stat_statfs2_bsize],
+ [AC_RUN_IFELSE([AC_LANG_SOURCE([[
+#ifdef HAVE_SYS_PARAM_H
+#include <sys/param.h>
+#endif
+#ifdef HAVE_SYS_MOUNT_H
+#include <sys/mount.h>
+#endif
+#ifdef HAVE_SYS_VFS_H
+#include <sys/vfs.h>
+#endif
+ int
+ main ()
+ {
+ struct statfs fsd;
+ fsd.f_bsize = 0;
+ return statfs (".", &fsd) != 0;
+ }]])],
+ [fu_cv_sys_stat_statfs2_bsize=yes],
+ [fu_cv_sys_stat_statfs2_bsize=no],
+ [fu_cv_sys_stat_statfs2_bsize=no])
+ ])
+ if test $fu_cv_sys_stat_statfs2_bsize = yes; then
+ ac_fsusage_space=yes
+ AC_DEFINE([STAT_STATFS2_BSIZE], [1],
+ [Define if statfs takes 2 args and struct statfs has a field named f_bsize.
+ (4.3BSD, SunOS 4, HP-UX)])
+ fi
+ fi
+
+ if test $ac_fsusage_space = no; then
+ # SVR3
+ # (Solaris already handled above.)
+ AC_CACHE_CHECK([for four-argument statfs (SVR3)],
+ [fu_cv_sys_stat_statfs4],
+ [AC_RUN_IFELSE([AC_LANG_SOURCE([[
+#include <sys/types.h>
+#include <sys/statfs.h>
+ int
+ main ()
+ {
+ struct statfs fsd;
+ return statfs (".", &fsd, sizeof fsd, 0) != 0;
+ }]])],
+ [fu_cv_sys_stat_statfs4=yes],
+ [fu_cv_sys_stat_statfs4=no],
+ [fu_cv_sys_stat_statfs4=no])
+ ])
+ if test $fu_cv_sys_stat_statfs4 = yes; then
+ ac_fsusage_space=yes
+ AC_DEFINE([STAT_STATFS4], [1],
+ [Define if statfs takes 4 args. (SVR3, old Irix)])
+ fi
+ fi
+
+ if test $ac_fsusage_space = no; then
+ # 4.4BSD and older NetBSD
+ # (OSF/1 already handled above.)
+ # (On AIX, you need to include <sys/statfs.h>, not only <sys/mount.h>.)
+ # (On Solaris, statfs has 4 arguments and 'struct statfs' is not declared in
+ # <sys/mount.h>.)
+ AC_CACHE_CHECK([for two-argument statfs with statfs.f_fsize member (4.4BSD and NetBSD)],
+ [fu_cv_sys_stat_statfs2_fsize],
+ [AC_RUN_IFELSE([AC_LANG_SOURCE([[
+#include <sys/types.h>
+#ifdef HAVE_SYS_PARAM_H
+#include <sys/param.h>
+#endif
+#ifdef HAVE_SYS_MOUNT_H
+#include <sys/mount.h>
+#endif
+ int
+ main ()
+ {
+ struct statfs fsd;
+ fsd.f_fsize = 0;
+ return statfs (".", &fsd) != 0;
+ }]])],
+ [fu_cv_sys_stat_statfs2_fsize=yes],
+ [fu_cv_sys_stat_statfs2_fsize=no],
+ [fu_cv_sys_stat_statfs2_fsize=no])
+ ])
+ if test $fu_cv_sys_stat_statfs2_fsize = yes; then
+ ac_fsusage_space=yes
+ AC_DEFINE([STAT_STATFS2_FSIZE], [1],
+ [Define if statfs takes 2 args and struct statfs has a field named f_fsize.
+ (4.4BSD, NetBSD)])
+ fi
+ fi
+
+ AS_IF([test $ac_fsusage_space = yes], [$1], [$2])
+
+])
+
+
+# Check for SunOS statfs brokenness wrt partitions 2GB and larger.
+# If <sys/vfs.h> exists and struct statfs has a member named f_spare,
+# enable the work-around code in fsusage.c.
+AC_DEFUN([gl_STATFS_TRUNCATES],
+[
+ AC_CACHE_CHECK([for statfs that truncates block counts],
+ [fu_cv_sys_truncating_statfs],
+ [AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM([[
+#if !defined(sun) && !defined(__sun)
+choke -- this is a workaround for a Sun-specific problem
+#endif
+#include <sys/types.h>
+#include <sys/vfs.h>
+ ]],
+ [[struct statfs t; long c = *(t.f_spare);
+ if (c) return 0;
+ ]])],
+ [fu_cv_sys_truncating_statfs=yes],
+ [fu_cv_sys_truncating_statfs=no])
+ ])
+ if test $fu_cv_sys_truncating_statfs = yes; then
+ AC_DEFINE([STATFS_TRUNCATES_BLOCK_COUNTS], [1],
+ [Define if the block counts reported by statfs may be truncated to 2GB
+ and the correct values may be stored in the f_spare array.
+ (SunOS 4.1.2, 4.1.3, and 4.1.3_U1 are reported to have this problem.
+ SunOS 4.1.1 seems not to be affected.)])
+ fi
+])
+
+
+# Prerequisites of lib/fsusage.c not done by gl_FILE_SYSTEM_USAGE.
+AC_DEFUN([gl_PREREQ_FSUSAGE_EXTRA],
+[
+ AC_CHECK_HEADERS([sys/fs/s5param.h sys/statfs.h])
+ gl_STATFS_TRUNCATES
+])
diff --git a/m4/getgroups.m4 b/m4/getgroups.m4
index 33c32a70f80..c93447bb11c 100644
--- a/m4/getgroups.m4
+++ b/m4/getgroups.m4
@@ -1,10 +1,9 @@
-# serial 20
+# serial 22
dnl From Jim Meyering.
dnl A wrapper around AC_FUNC_GETGROUPS.
-# Copyright (C) 1996-1997, 1999-2004, 2008-2019 Free Software
-# Foundation, Inc.
+# Copyright (C) 1996-1997, 1999-2004, 2008-2019 Free Software Foundation, Inc.
#
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
@@ -35,7 +34,7 @@ AC_DEFUN([AC_FUNC_GETGROUPS],
[AC_RUN_IFELSE(
[AC_LANG_PROGRAM(
[AC_INCLUDES_DEFAULT],
- [[/* On Ultrix 4.3, getgroups (0, 0) always fails. */
+ [[/* On NeXTstep 3.2, getgroups (0, 0) always fails. */
return getgroups (0, 0) == -1;]])
],
[ac_cv_func_getgroups_works=yes],
@@ -43,6 +42,8 @@ AC_DEFUN([AC_FUNC_GETGROUPS],
[case "$host_os" in # ((
# Guess yes on glibc systems.
*-gnu* | gnu*) ac_cv_func_getgroups_works="guessing yes" ;;
+ # Guess yes on musl systems.
+ *-musl*) ac_cv_func_getgroups_works="guessing yes" ;;
# If we don't know, assume the worst.
*) ac_cv_func_getgroups_works="guessing no" ;;
esac
@@ -96,6 +97,8 @@ AC_DEFUN([gl_FUNC_GETGROUPS],
[case "$host_os" in
# Guess yes on glibc systems.
*-gnu* | gnu*) gl_cv_func_getgroups_works="guessing yes" ;;
+ # Guess yes on musl systems.
+ *-musl*) gl_cv_func_getgroups_works="guessing yes" ;;
# If we don't know, assume the worst.
*) gl_cv_func_getgroups_works="guessing no" ;;
esac
diff --git a/m4/getloadavg.m4 b/m4/getloadavg.m4
index 58015fe4722..333ced781bb 100644
--- a/m4/getloadavg.m4
+++ b/m4/getloadavg.m4
@@ -1,13 +1,13 @@
# Check for getloadavg.
-# Copyright (C) 1992-1996, 1999-2000, 2002-2003, 2006, 2008-2019 Free
-# Software Foundation, Inc.
+# Copyright (C) 1992-1996, 1999-2000, 2002-2003, 2006, 2008-2019 Free Software
+# Foundation, Inc.
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
# with or without modifications, as long as this notice is preserved.
-#serial 6
+#serial 8
# Autoconf defines AC_FUNC_GETLOADAVG, but that is obsolescent.
# New applications should use gl_GETLOADAVG instead.
@@ -22,7 +22,7 @@ AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])
gl_save_LIBS=$LIBS
-# getloadvg is present in libc on glibc >= 2.2, Mac OS X, FreeBSD >= 2.0,
+# getloadavg is present in libc on glibc >= 2.2, Mac OS X, FreeBSD >= 2.0,
# NetBSD >= 0.9, OpenBSD >= 2.0, Solaris >= 7.
HAVE_GETLOADAVG=1
AC_CHECK_FUNC([getloadavg], [],
@@ -92,6 +92,9 @@ else
fi
AC_CHECK_DECL([getloadavg], [], [HAVE_DECL_GETLOADAVG=0],
[[#if HAVE_SYS_LOADAVG_H
+ /* OpenIndiana has a bug: <sys/time.h> must be included before
+ <sys/loadavg.h>. */
+ # include <sys/time.h>
# include <sys/loadavg.h>
#endif
#include <stdlib.h>]])
@@ -105,7 +108,7 @@ AC_DEFUN([gl_PREREQ_GETLOADAVG],
[
# Figure out what our getloadavg.c needs.
-AC_CHECK_HEADERS_ONCE([sys/param.h])
+AC_CHECK_HEADERS_ONCE([sys/param.h unistd.h])
# On HPUX9, an unprivileged user can get load averages this way.
if test $gl_func_getloadavg_done = no; then
diff --git a/m4/gettime.m4 b/m4/gettime.m4
index d52d66b8932..60d8ea183bc 100644
--- a/m4/gettime.m4
+++ b/m4/gettime.m4
@@ -1,6 +1,5 @@
-# gettime.m4 serial 8
-dnl Copyright (C) 2002, 2004-2006, 2009-2019 Free Software Foundation,
-dnl Inc.
+# gettime.m4 serial 9
+dnl Copyright (C) 2002, 2004-2006, 2009-2019 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.
@@ -10,5 +9,5 @@ AC_DEFUN([gl_GETTIME],
dnl Prerequisites of lib/gettime.c.
AC_REQUIRE([gl_CLOCK_TIME])
AC_REQUIRE([gl_TIMESPEC])
- AC_CHECK_FUNCS_ONCE([gettimeofday nanotime])
+ AC_CHECK_FUNCS_ONCE([gettimeofday])
])
diff --git a/m4/gettimeofday.m4 b/m4/gettimeofday.m4
index 58a7ab78c1b..5e2ef6f47e2 100644
--- a/m4/gettimeofday.m4
+++ b/m4/gettimeofday.m4
@@ -1,7 +1,6 @@
-# serial 25
+# serial 26
-# Copyright (C) 2001-2003, 2005, 2007, 2009-2019 Free Software
-# Foundation, Inc.
+# Copyright (C) 2001-2003, 2005, 2007, 2009-2019 Free Software Foundation, Inc.
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
# with or without modifications, as long as this notice is preserved.
@@ -106,6 +105,8 @@ AC_DEFUN([gl_FUNC_GETTIMEOFDAY_CLOBBER],
case "$host_os" in
# Guess all is fine on glibc systems.
*-gnu* | gnu*) gl_cv_func_gettimeofday_clobber="guessing no" ;;
+ # Guess all is fine on musl systems.
+ *-musl*) gl_cv_func_gettimeofday_clobber="guessing no" ;;
# Guess no on native Windows.
mingw*) gl_cv_func_gettimeofday_clobber="guessing no" ;;
# If we don't know, assume the worst.
diff --git a/m4/glibc21.m4 b/m4/glibc21.m4
new file mode 100644
index 00000000000..0ab0f235a66
--- /dev/null
+++ b/m4/glibc21.m4
@@ -0,0 +1,34 @@
+# glibc21.m4 serial 5
+dnl Copyright (C) 2000-2002, 2004, 2008, 2010-2019 Free Software Foundation,
+dnl 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.
+
+# Test for the GNU C Library, version 2.1 or newer, or uClibc.
+# From Bruno Haible.
+
+AC_DEFUN([gl_GLIBC21],
+ [
+ AC_CACHE_CHECK([whether we are using the GNU C Library >= 2.1 or uClibc],
+ [ac_cv_gnu_library_2_1],
+ [AC_EGREP_CPP([Lucky],
+ [
+#include <features.h>
+#ifdef __GNU_LIBRARY__
+ #if (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 1) || (__GLIBC__ > 2)
+ Lucky GNU user
+ #endif
+#endif
+#ifdef __UCLIBC__
+ Lucky user
+#endif
+ ],
+ [ac_cv_gnu_library_2_1=yes],
+ [ac_cv_gnu_library_2_1=no])
+ ]
+ )
+ AC_SUBST([GLIBC21])
+ GLIBC21="$ac_cv_gnu_library_2_1"
+ ]
+)
diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4
index 3f74cb4d038..57b94ed5325 100644
--- a/m4/gnulib-common.m4
+++ b/m4/gnulib-common.m4
@@ -1,9 +1,11 @@
-# gnulib-common.m4 serial 38
+# gnulib-common.m4 serial 44
dnl Copyright (C) 2007-2019 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.
+AC_PREREQ([2.62])
+
# gl_COMMON
# is expanded unconditionally through gnulib-tool magic.
AC_DEFUN([gl_COMMON], [
@@ -14,12 +16,18 @@ AC_DEFUN([gl_COMMON], [
AC_DEFUN([gl_COMMON_BODY], [
AH_VERBATIM([_Noreturn],
[/* The _Noreturn keyword of C11. */
-#if ! (defined _Noreturn \
- || (defined __STDC_VERSION__ && 201112 <= __STDC_VERSION__))
-# if (3 <= __GNUC__ || (__GNUC__ == 2 && 8 <= __GNUC_MINOR__) \
- || 0x5110 <= __SUNPRO_C)
+#ifndef _Noreturn
+# if (defined __cplusplus \
+ && ((201103 <= __cplusplus && !(__GNUC__ == 4 && __GNUC_MINOR__ == 7)) \
+ || (defined _MSC_VER && 1900 <= _MSC_VER)))
+# define _Noreturn [[noreturn]]
+# elif ((!defined __cplusplus || defined __clang__) \
+ && (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \
+ || 4 < __GNUC__ + (7 <= __GNUC_MINOR__)))
+ /* _Noreturn works as-is. */
+# elif 2 < __GNUC__ + (8 <= __GNUC_MINOR__) || 0x5110 <= __SUNPRO_C
# define _Noreturn __attribute__ ((__noreturn__))
-# elif defined _MSC_VER && 1200 <= _MSC_VER
+# elif 1200 <= (defined _MSC_VER ? _MSC_VER : 0)
# define _Noreturn __declspec (noreturn)
# else
# define _Noreturn
@@ -72,6 +80,40 @@ AC_DEFUN([gl_COMMON_BODY], [
#else
# define _GL_ATTRIBUTE_CONST /* empty */
#endif
+
+/* The __malloc__ attribute was added in gcc 3. */
+#if 3 <= __GNUC__
+# define _GL_ATTRIBUTE_MALLOC __attribute__ ((__malloc__))
+#else
+# define _GL_ATTRIBUTE_MALLOC /* empty */
+#endif
+])
+ AH_VERBATIM([async_safe],
+[/* The _GL_ASYNC_SAFE marker should be attached to functions that are
+ signal handlers (for signals other than SIGABRT, SIGPIPE) or can be
+ invoked from such signal handlers. Such functions have some restrictions:
+ * All functions that it calls should be marked _GL_ASYNC_SAFE as well,
+ or should be listed as async-signal-safe in POSIX
+ <http://pubs.opengroup.org/onlinepubs/9699919799/functions/V2_chap02.html#tag_15_04>
+ section 2.4.3. Note that malloc(), sprintf(), and fwrite(), in
+ particular, are NOT async-signal-safe.
+ * All memory locations (variables and struct fields) that these functions
+ access must be marked 'volatile'. This holds for both read and write
+ accesses. Otherwise the compiler might optimize away stores to and
+ reads from such locations that occur in the program, depending on its
+ data flow analysis. For example, when the program contains a loop
+ that is intended to inspect a variable set from within a signal handler
+ while (!signal_occurred)
+ ;
+ the compiler is allowed to transform this into an endless loop if the
+ variable 'signal_occurred' is not declared 'volatile'.
+ Additionally, recall that:
+ * A signal handler should not modify errno (except if it is a handler
+ for a fatal signal and ends by raising the same signal again, thus
+ provoking the termination of the process). If it invokes a function
+ that may clobber errno, it needs to save and restore the value of
+ errno. */
+#define _GL_ASYNC_SAFE
])
dnl Preparation for running test programs:
dnl Tell glibc to write diagnostics from -D_FORTIFY_SOURCE=2 to stderr, not
@@ -207,13 +249,6 @@ AC_DEFUN([gl_FEATURES_H],
AC_SUBST([HAVE_FEATURES_H])
])
-# m4_foreach_w
-# is a backport of autoconf-2.59c's m4_foreach_w.
-# Remove this macro when we can assume autoconf >= 2.60.
-m4_ifndef([m4_foreach_w],
- [m4_define([m4_foreach_w],
- [m4_foreach([$1], m4_split(m4_normalize([$2]), [ ]), [$3])])])
-
# AS_VAR_IF(VAR, VALUE, [IF-MATCH], [IF-NOT-MATCH])
# ----------------------------------------------------
# Backport of autoconf-2.63b's macro.
@@ -226,7 +261,6 @@ m4_ifndef([AS_VAR_IF],
# Modifies the value of the shell variable CC in an attempt to make $CC
# understand ISO C99 source code.
# This is like AC_PROG_CC_C99, except that
-# - AC_PROG_CC_C99 did not exist in Autoconf versions < 2.60,
# - AC_PROG_CC_C99 does not mix well with AC_PROG_CC_STDC
# <https://lists.gnu.org/r/bug-gnulib/2011-09/msg00367.html>,
# but many more packages use AC_PROG_CC_STDC than AC_PROG_CC_C99
@@ -315,25 +349,6 @@ Amsterdam
AC_SUBST([RANLIB])
])
-# AC_PROG_MKDIR_P
-# is a backport of autoconf-2.60's AC_PROG_MKDIR_P, with a fix
-# for interoperability with automake-1.9.6 from autoconf-2.62.
-# Remove this macro when we can assume autoconf >= 2.62 or
-# autoconf >= 2.60 && automake >= 1.10.
-# AC_AUTOCONF_VERSION was introduced in 2.62, so use that as the witness.
-m4_ifndef([AC_AUTOCONF_VERSION],[
-m4_ifdef([AC_PROG_MKDIR_P], [
- dnl For automake-1.9.6 && autoconf < 2.62: Ensure MKDIR_P is AC_SUBSTed.
- m4_define([AC_PROG_MKDIR_P],
- m4_defn([AC_PROG_MKDIR_P])[
- AC_SUBST([MKDIR_P])])], [
- dnl For autoconf < 2.60: Backport of AC_PROG_MKDIR_P.
- AC_DEFUN_ONCE([AC_PROG_MKDIR_P],
- [AC_REQUIRE([AM_PROG_MKDIR_P])dnl defined by automake
- MKDIR_P='$(mkdir_p)'
- AC_SUBST([MKDIR_P])])])
-])
-
# AC_C_RESTRICT
# This definition is copied from post-2.69 Autoconf and overrides the
# AC_C_RESTRICT macro from autoconf 2.60..2.69. It can be removed
@@ -347,16 +362,16 @@ AC_DEFUN([AC_C_RESTRICT],
for ac_kw in __restrict __restrict__ _Restrict restrict; do
AC_COMPILE_IFELSE(
[AC_LANG_PROGRAM(
- [[typedef int *int_ptr;
- int foo (int_ptr $ac_kw ip) { return ip[0]; }
- int bar (int [$ac_kw]); /* Catch GCC bug 14050. */
- int bar (int ip[$ac_kw]) { return ip[0]; }
- ]],
- [[int s[1];
- int *$ac_kw t = s;
- t[0] = 0;
- return foo (t) + bar (t);
- ]])],
+ [[typedef int *int_ptr;
+ int foo (int_ptr $ac_kw ip) { return ip[0]; }
+ int bar (int [$ac_kw]); /* Catch GCC bug 14050. */
+ int bar (int ip[$ac_kw]) { return ip[0]; }
+ ]],
+ [[int s[1];
+ int *$ac_kw t = s;
+ t[0] = 0;
+ return foo (t) + bar (t);
+ ]])],
[ac_cv_c_restrict=$ac_kw])
test "$ac_cv_c_restrict" != no && break
done
@@ -407,61 +422,3 @@ AC_DEFUN([gl_CACHE_VAL_SILENT],
# AS_VAR_COPY was added in autoconf 2.63b
m4_define_default([AS_VAR_COPY],
[AS_LITERAL_IF([$1[]$2], [$1=$$2], [eval $1=\$$2])])
-
-# AC_PROG_SED was added in autoconf 2.59b
-m4_ifndef([AC_PROG_SED],
-[AC_DEFUN([AC_PROG_SED],
-[AC_CACHE_CHECK([for a sed that does not truncate output], ac_cv_path_SED,
- [dnl ac_script should not contain more than 99 commands (for HP-UX sed),
- dnl but more than about 7000 bytes, to catch a limit in Solaris 8 /usr/ucb/sed.
- ac_script=s/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb/
- for ac_i in 1 2 3 4 5 6 7; do
- ac_script="$ac_script$as_nl$ac_script"
- done
- echo "$ac_script" 2>/dev/null | sed 99q >conftest.sed
- AS_UNSET([ac_script])
- if test -z "$SED"; then
- ac_path_SED_found=false
- _AS_PATH_WALK([], [
- for ac_prog in sed gsed; do
- for ac_exec_ext in '' $ac_executable_extensions; do
- ac_path_SED="$as_dir/$ac_prog$ac_exec_ext"
- AS_EXECUTABLE_P(["$ac_path_SED"]) || continue
- case `"$ac_path_SED" --version 2>&1` in
- *GNU*) ac_cv_path_SED=$ac_path_SED ac_path_SED_found=:;;
- *)
- ac_count=0
- _AS_ECHO_N([0123456789]) >conftest.in
- while :
- do
- cat conftest.in conftest.in >conftest.tmp
- mv conftest.tmp conftest.in
- cp conftest.in conftest.nl
- echo >> conftest.nl
- "$ac_path_SED" -f conftest.sed <conftest.nl >conftest.out 2>/dev/null || break
- diff conftest.out conftest.nl >/dev/null 2>&1 || break
- ac_count=`expr $ac_count + 1`
- if test $ac_count -gt ${ac_path_SED_max-0}; then
- # Best so far, but keep looking for better
- ac_cv_path_SED=$ac_path_SED
- ac_path_SED_max=$ac_count
- fi
- test $ac_count -gt 10 && break
- done
- rm -f conftest.in conftest.tmp conftest.nl conftest.out;;
- esac
- $ac_path_SED_found && break 3
- done
- done])
- if test -z "$ac_cv_path_SED"; then
- AC_ERROR([no acceptable sed could be found in \$PATH])
- fi
- else
- ac_cv_path_SED=$SED
- fi
- ])
- SED="$ac_cv_path_SED"
- AC_SUBST([SED])dnl
- rm -f conftest.sed
-])
-])
diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4
index a555e2561b9..f25a0e40816 100644
--- a/m4/gnulib-comp.m4
+++ b/m4/gnulib-comp.m4
@@ -48,6 +48,7 @@ AC_DEFUN([gl_EARLY],
# Code from module allocator:
# Code from module at-internal:
# Code from module binary-io:
+ # Code from module builtin-expect:
# Code from module byteswap:
# Code from module c-ctype:
# Code from module c-strcase:
@@ -58,10 +59,10 @@ AC_DEFUN([gl_EARLY],
# Code from module count-leading-zeros:
# Code from module count-one-bits:
# Code from module count-trailing-zeros:
- # Code from module crypto/md5:
- # Code from module crypto/sha1:
- # Code from module crypto/sha256:
- # Code from module crypto/sha512:
+ # Code from module crypto/md5-buffer:
+ # Code from module crypto/sha1-buffer:
+ # Code from module crypto/sha256-buffer:
+ # Code from module crypto/sha512-buffer:
# Code from module d-type:
# Code from module diffseq:
# Code from module dirent:
@@ -80,7 +81,6 @@ AC_DEFUN([gl_EARLY],
# Code from module faccessat:
# Code from module fcntl:
# Code from module fcntl-h:
- # Code from module fdatasync:
# Code from module fdopendir:
# Code from module filemode:
# Code from module filevercmp:
@@ -89,6 +89,7 @@ AC_DEFUN([gl_EARLY],
# Code from module fpieee:
AC_REQUIRE([gl_FP_IEEE])
# Code from module fstatat:
+ # Code from module fsusage:
# Code from module fsync:
# Code from module getdtablesize:
# Code from module getgroups:
@@ -100,12 +101,14 @@ AC_DEFUN([gl_EARLY],
# Code from module gettimeofday:
# Code from module gitlog-to-changelog:
# Code from module group-member:
+ # Code from module ieee754-h:
# Code from module ignore-value:
# Code from module include_next:
# Code from module intprops:
# Code from module inttypes-incomplete:
# Code from module largefile:
AC_REQUIRE([AC_SYS_LARGEFILE])
+ # Code from module libc-config:
# Code from module limits-h:
# Code from module localtime-buffer:
# Code from module lstat:
@@ -127,6 +130,7 @@ AC_DEFUN([gl_EARLY],
# Code from module qcopy-acl:
# Code from module readlink:
# Code from module readlinkat:
+ # Code from module regex:
# Code from module root-uid:
# Code from module sig2str:
# Code from module signal-h:
@@ -205,7 +209,6 @@ AC_DEFUN([gl_INIT],
gl_SHA512
gl_CHECK_TYPE_STRUCT_DIRENT_D_TYPE
gl_DIRENT_H
- AC_REQUIRE([gl_C99_STRTOLD])
gl_FUNC_DUP2
if test $HAVE_DUP2 = 0 || test $REPLACE_DUP2 = 1; then
AC_LIBOBJ([dup2])
@@ -236,11 +239,6 @@ AC_DEFUN([gl_INIT],
fi
gl_FCNTL_MODULE_INDICATOR([fcntl])
gl_FCNTL_H
- gl_FUNC_FDATASYNC
- if test $HAVE_FDATASYNC = 0; then
- AC_LIBOBJ([fdatasync])
- fi
- gl_UNISTD_MODULE_INDICATOR([fdatasync])
gl_FUNC_FDOPENDIR
if test $HAVE_FDOPENDIR = 0 || test $REPLACE_FDOPENDIR = 1; then
AC_LIBOBJ([fdopendir])
@@ -258,6 +256,11 @@ AC_DEFUN([gl_INIT],
AC_LIBOBJ([fstatat])
fi
gl_SYS_STAT_MODULE_INDICATOR([fstatat])
+ gl_FSUSAGE
+ if test $gl_cv_fs_space = yes; then
+ AC_LIBOBJ([fsusage])
+ gl_PREREQ_FSUSAGE_EXTRA
+ fi
gl_FUNC_FSYNC
if test $HAVE_FSYNC = 0; then
AC_LIBOBJ([fsync])
@@ -289,6 +292,7 @@ AC_DEFUN([gl_INIT],
gl_PREREQ_GETTIMEOFDAY
fi
gl_SYS_TIME_MODULE_INDICATOR([gettimeofday])
+ gl_IEEE754_H
gl_INTTYPES_INCOMPLETE
AC_REQUIRE([gl_LARGEFILE])
gl_LIMITS_H
@@ -350,6 +354,11 @@ AC_DEFUN([gl_INIT],
AC_LIBOBJ([readlinkat])
fi
gl_UNISTD_MODULE_INDICATOR([readlinkat])
+ gl_REGEX
+ if test $ac_use_included_regex = yes; then
+ AC_LIBOBJ([regex])
+ gl_PREREQ_REGEX
+ fi
gl_FUNC_SIG2STR
if test $ac_cv_func_sig2str = no; then
AC_LIBOBJ([sig2str])
@@ -417,14 +426,15 @@ AC_DEFUN([gl_INIT],
gl_UTIMENS
AC_C_VARARRAYS
gl_gnulib_enabled_260941c0e5dc67ec9e87d1fb321c300b=false
+ gl_gnulib_enabled_37f71b604aa9c54446783d80f42fe547=false
gl_gnulib_enabled_cloexec=false
gl_gnulib_enabled_dirfd=false
- gl_gnulib_enabled_dosname=false
gl_gnulib_enabled_euidaccess=false
gl_gnulib_enabled_getdtablesize=false
gl_gnulib_enabled_getgroups=false
gl_gnulib_enabled_be453cec5eecf5731a274f2de7f2db36=false
gl_gnulib_enabled_a9786850e999ae65a836a6041e8e5ed1=false
+ gl_gnulib_enabled_21ee726a3540c09237a8e70c0baf7467=false
gl_gnulib_enabled_2049e887c7e5308faad27b3f894bb8c9=false
gl_gnulib_enabled_5264294aa0a5557541b53c8c741f7f31=false
gl_gnulib_enabled_open=false
@@ -440,6 +450,13 @@ AC_DEFUN([gl_INIT],
func_gl_gnulib_m4code_open
fi
}
+ func_gl_gnulib_m4code_37f71b604aa9c54446783d80f42fe547 ()
+ {
+ if ! $gl_gnulib_enabled_37f71b604aa9c54446783d80f42fe547; then
+ gl___BUILTIN_EXPECT
+ gl_gnulib_enabled_37f71b604aa9c54446783d80f42fe547=true
+ fi
+ }
func_gl_gnulib_m4code_cloexec ()
{
if ! $gl_gnulib_enabled_cloexec; then
@@ -460,12 +477,6 @@ AC_DEFUN([gl_INIT],
gl_gnulib_enabled_dirfd=true
fi
}
- func_gl_gnulib_m4code_dosname ()
- {
- if ! $gl_gnulib_enabled_dosname; then
- gl_gnulib_enabled_dosname=true
- fi
- }
func_gl_gnulib_m4code_euidaccess ()
{
if ! $gl_gnulib_enabled_euidaccess; then
@@ -531,6 +542,13 @@ AC_DEFUN([gl_INIT],
fi
fi
}
+ func_gl_gnulib_m4code_21ee726a3540c09237a8e70c0baf7467 ()
+ {
+ if ! $gl_gnulib_enabled_21ee726a3540c09237a8e70c0baf7467; then
+ gl___INLINE
+ gl_gnulib_enabled_21ee726a3540c09237a8e70c0baf7467=true
+ fi
+ }
func_gl_gnulib_m4code_2049e887c7e5308faad27b3f894bb8c9 ()
{
if ! $gl_gnulib_enabled_2049e887c7e5308faad27b3f894bb8c9; then
@@ -599,9 +617,6 @@ AC_DEFUN([gl_INIT],
func_gl_gnulib_m4code_260941c0e5dc67ec9e87d1fb321c300b
fi
if test $HAVE_FACCESSAT = 0 || test $REPLACE_FACCESSAT = 1; then
- func_gl_gnulib_m4code_dosname
- fi
- if test $HAVE_FACCESSAT = 0 || test $REPLACE_FACCESSAT = 1; then
func_gl_gnulib_m4code_euidaccess
fi
if test $HAVE_FACCESSAT = 0 || test $REPLACE_FACCESSAT = 1; then
@@ -620,9 +635,6 @@ AC_DEFUN([gl_INIT],
func_gl_gnulib_m4code_260941c0e5dc67ec9e87d1fb321c300b
fi
if test $HAVE_FSTATAT = 0 || test $REPLACE_FSTATAT = 1; then
- func_gl_gnulib_m4code_dosname
- fi
- if test $HAVE_FSTATAT = 0 || test $REPLACE_FSTATAT = 1; then
func_gl_gnulib_m4code_03e0aaad4cb89ca757653bd367a6ccb7
fi
if test $REPLACE_GETOPT = 1; then
@@ -631,18 +643,21 @@ AC_DEFUN([gl_INIT],
if test $NEED_LOCALTIME_BUFFER = 1; then
func_gl_gnulib_m4code_2049e887c7e5308faad27b3f894bb8c9
fi
- if test $REPLACE_LSTAT = 1; then
- func_gl_gnulib_m4code_dosname
+ if test $REPLACE_MKTIME = 1; then
+ func_gl_gnulib_m4code_21ee726a3540c09237a8e70c0baf7467
fi
if test $HAVE_READLINKAT = 0; then
func_gl_gnulib_m4code_260941c0e5dc67ec9e87d1fb321c300b
fi
if test $HAVE_READLINKAT = 0; then
- func_gl_gnulib_m4code_dosname
- fi
- if test $HAVE_READLINKAT = 0; then
func_gl_gnulib_m4code_03e0aaad4cb89ca757653bd367a6ccb7
fi
+ if test $ac_use_included_regex = yes; then
+ func_gl_gnulib_m4code_37f71b604aa9c54446783d80f42fe547
+ fi
+ if test $ac_use_included_regex = yes; then
+ func_gl_gnulib_m4code_21ee726a3540c09237a8e70c0baf7467
+ 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
@@ -651,14 +666,15 @@ AC_DEFUN([gl_INIT],
fi
m4_pattern_allow([^gl_GNULIB_ENABLED_])
AM_CONDITIONAL([gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b], [$gl_gnulib_enabled_260941c0e5dc67ec9e87d1fb321c300b])
+ AM_CONDITIONAL([gl_GNULIB_ENABLED_37f71b604aa9c54446783d80f42fe547], [$gl_gnulib_enabled_37f71b604aa9c54446783d80f42fe547])
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_dosname], [$gl_gnulib_enabled_dosname])
AM_CONDITIONAL([gl_GNULIB_ENABLED_euidaccess], [$gl_gnulib_enabled_euidaccess])
AM_CONDITIONAL([gl_GNULIB_ENABLED_getdtablesize], [$gl_gnulib_enabled_getdtablesize])
AM_CONDITIONAL([gl_GNULIB_ENABLED_getgroups], [$gl_gnulib_enabled_getgroups])
AM_CONDITIONAL([gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36], [$gl_gnulib_enabled_be453cec5eecf5731a274f2de7f2db36])
AM_CONDITIONAL([gl_GNULIB_ENABLED_a9786850e999ae65a836a6041e8e5ed1], [$gl_gnulib_enabled_a9786850e999ae65a836a6041e8e5ed1])
+ AM_CONDITIONAL([gl_GNULIB_ENABLED_21ee726a3540c09237a8e70c0baf7467], [$gl_gnulib_enabled_21ee726a3540c09237a8e70c0baf7467])
AM_CONDITIONAL([gl_GNULIB_ENABLED_2049e887c7e5308faad27b3f894bb8c9], [$gl_gnulib_enabled_2049e887c7e5308faad27b3f894bb8c9])
AM_CONDITIONAL([gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31], [$gl_gnulib_enabled_5264294aa0a5557541b53c8c741f7f31])
AM_CONDITIONAL([gl_GNULIB_ENABLED_open], [$gl_gnulib_enabled_open])
@@ -831,6 +847,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/c-strncasecmp.c
lib/careadlinkat.c
lib/careadlinkat.h
+ lib/cdefs.h
lib/cloexec.c
lib/cloexec.h
lib/close-stream.c
@@ -856,7 +873,6 @@ AC_DEFUN([gl_FILE_LIST], [
lib/faccessat.c
lib/fcntl.c
lib/fcntl.in.h
- lib/fdatasync.c
lib/fdopendir.c
lib/filemode.c
lib/filemode.h
@@ -866,6 +882,8 @@ AC_DEFUN([gl_FILE_LIST], [
lib/fpending.c
lib/fpending.h
lib/fstatat.c
+ lib/fsusage.c
+ lib/fsusage.h
lib/fsync.c
lib/ftoastr.c
lib/ftoastr.h
@@ -887,9 +905,11 @@ AC_DEFUN([gl_FILE_LIST], [
lib/gettimeofday.c
lib/gl_openssl.h
lib/group-member.c
+ lib/ieee754.in.h
lib/ignore-value.h
lib/intprops.h
lib/inttypes.in.h
+ lib/libc-config.h
lib/limits.in.h
lib/localtime-buffer.c
lib/localtime-buffer.h
@@ -913,6 +933,12 @@ AC_DEFUN([gl_FILE_LIST], [
lib/qcopy-acl.c
lib/readlink.c
lib/readlinkat.c
+ lib/regcomp.c
+ lib/regex.c
+ lib/regex.h
+ lib/regex_internal.c
+ lib/regex_internal.h
+ lib/regexec.c
lib/root-uid.h
lib/set-permissions.c
lib/sha1.c
@@ -966,11 +992,12 @@ AC_DEFUN([gl_FILE_LIST], [
lib/warn-on-use.h
lib/xalloc-oversized.h
m4/00gnulib.m4
+ m4/__inline.m4
m4/absolute-header.m4
m4/acl.m4
m4/alloca.m4
+ m4/builtin-expect.m4
m4/byteswap.m4
- m4/c-strtod.m4
m4/clock_time.m4
m4/close-stream.m4
m4/count-leading-zeros.m4
@@ -980,6 +1007,7 @@ AC_DEFUN([gl_FILE_LIST], [
m4/dirent_h.m4
m4/dirfd.m4
m4/dup2.m4
+ m4/eealloc.m4
m4/environ.m4
m4/errno_h.m4
m4/euidaccess.m4
@@ -991,13 +1019,13 @@ AC_DEFUN([gl_FILE_LIST], [
m4/fcntl-o.m4
m4/fcntl.m4
m4/fcntl_h.m4
- m4/fdatasync.m4
m4/fdopendir.m4
m4/filemode.m4
m4/flexmember.m4
m4/fpending.m4
m4/fpieee.m4
m4/fstatat.m4
+ m4/fsusage.m4
m4/fsync.m4
m4/getdtablesize.m4
m4/getgroups.m4
@@ -1006,8 +1034,10 @@ AC_DEFUN([gl_FILE_LIST], [
m4/gettime.m4
m4/gettimeofday.m4
m4/gl-openssl.m4
+ m4/glibc21.m4
m4/gnulib-common.m4
m4/group-member.m4
+ m4/ieee754-h.m4
m4/include_next.m4
m4/inttypes.m4
m4/largefile.m4
@@ -1017,6 +1047,7 @@ AC_DEFUN([gl_FILE_LIST], [
m4/lstat.m4
m4/manywarnings-c++.m4
m4/manywarnings.m4
+ m4/mbstate_t.m4
m4/md5.m4
m4/memrchr.m4
m4/minmax.m4
@@ -1035,6 +1066,7 @@ AC_DEFUN([gl_FILE_LIST], [
m4/putenv.m4
m4/readlink.m4
m4/readlinkat.m4
+ m4/regex.m4
m4/sha1.m4
m4/sha256.m4
m4/sha512.m4
diff --git a/m4/group-member.m4 b/m4/group-member.m4
index dc87cd9601b..77d389de693 100644
--- a/m4/group-member.m4
+++ b/m4/group-member.m4
@@ -1,7 +1,6 @@
# serial 14
-# Copyright (C) 1999-2001, 2003-2007, 2009-2019 Free Software
-# Foundation, Inc.
+# Copyright (C) 1999-2001, 2003-2007, 2009-2019 Free Software Foundation, Inc.
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
diff --git a/m4/ieee754-h.m4 b/m4/ieee754-h.m4
new file mode 100644
index 00000000000..b8b9d5dca19
--- /dev/null
+++ b/m4/ieee754-h.m4
@@ -0,0 +1,21 @@
+# Configure ieee754-h module
+
+dnl Copyright 2018-2019 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.
+
+AC_DEFUN([gl_IEEE754_H],
+[
+ AC_REQUIRE([AC_C_BIGENDIAN])
+ AC_CHECK_HEADERS_ONCE([ieee754.h])
+ if test $ac_cv_header_ieee754_h = yes; then
+ IEEE754_H=
+ else
+ IEEE754_H=ieee754.h
+ AC_DEFINE([_GL_REPLACE_IEEE754_H], 1,
+ [Define to 1 if <ieee754.h> is missing.])
+ fi
+ AC_SUBST([IEEE754_H])
+ AM_CONDITIONAL([GL_GENERATE_IEEE754_H], [test -n "$IEEE754_H"])
+])
diff --git a/m4/inttypes.m4 b/m4/inttypes.m4
index f57350a5276..c58a1bec474 100644
--- a/m4/inttypes.m4
+++ b/m4/inttypes.m4
@@ -1,4 +1,4 @@
-# inttypes.m4 serial 26
+# inttypes.m4 serial 27
dnl Copyright (C) 2006-2019 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -147,6 +147,7 @@ AC_DEFUN([gl_INTTYPES_H_DEFAULTS],
HAVE_DECL_IMAXDIV=1; AC_SUBST([HAVE_DECL_IMAXDIV])
HAVE_DECL_STRTOIMAX=1; AC_SUBST([HAVE_DECL_STRTOIMAX])
HAVE_DECL_STRTOUMAX=1; AC_SUBST([HAVE_DECL_STRTOUMAX])
+ HAVE_IMAXDIV_T=1; AC_SUBST([HAVE_IMAXDIV_T])
REPLACE_STRTOIMAX=0; AC_SUBST([REPLACE_STRTOIMAX])
REPLACE_STRTOUMAX=0; AC_SUBST([REPLACE_STRTOUMAX])
INT32_MAX_LT_INTMAX_MAX=1; AC_SUBST([INT32_MAX_LT_INTMAX_MAX])
diff --git a/m4/limits-h.m4 b/m4/limits-h.m4
index 73e27c6558e..68f724c777e 100644
--- a/m4/limits-h.m4
+++ b/m4/limits-h.m4
@@ -11,14 +11,18 @@ AC_DEFUN_ONCE([gl_LIMITS_H],
[
gl_CHECK_NEXT_HEADERS([limits.h])
- AC_CACHE_CHECK([whether limits.h has ULLONG_WIDTH etc.],
+ AC_CACHE_CHECK([whether limits.h has LLONG_MAX, WORD_BIT, ULLONG_WIDTH etc.],
[gl_cv_header_limits_width],
[AC_COMPILE_IFELSE(
- [AC_LANG_PROGRAM([[#ifndef __STDC_WANT_IEC_60559_BFP_EXT__
- #define __STDC_WANT_IEC_60559_BFP_EXT__ 1
- #endif
- #include <limits.h>
- int ullw = ULLONG_WIDTH;]])],
+ [AC_LANG_PROGRAM(
+ [[#ifndef __STDC_WANT_IEC_60559_BFP_EXT__
+ #define __STDC_WANT_IEC_60559_BFP_EXT__ 1
+ #endif
+ #include <limits.h>
+ long long llm = LLONG_MAX;
+ int wb = WORD_BIT;
+ int ullw = ULLONG_WIDTH;
+ ]])],
[gl_cv_header_limits_width=yes],
[gl_cv_header_limits_width=no])])
if test "$gl_cv_header_limits_width" = yes; then
@@ -29,3 +33,11 @@ AC_DEFUN_ONCE([gl_LIMITS_H],
AC_SUBST([LIMITS_H])
AM_CONDITIONAL([GL_GENERATE_LIMITS_H], [test -n "$LIMITS_H"])
])
+
+dnl Unconditionally enables the replacement of <limits.h>.
+AC_DEFUN([gl_REPLACE_LIMITS_H],
+[
+ AC_REQUIRE([gl_LIMITS_H])
+ LIMITS_H='limits.h'
+ AM_CONDITIONAL([GL_GENERATE_LIMITS_H], [test -n "$LIMITS_H"])
+])
diff --git a/m4/longlong.m4 b/m4/longlong.m4
index 7d45d5e52e0..08d0e36300d 100644
--- a/m4/longlong.m4
+++ b/m4/longlong.m4
@@ -1,4 +1,4 @@
-# longlong.m4 serial 17
+# longlong.m4 serial 18
dnl Copyright (C) 1999-2007, 2009-2019 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -6,9 +6,10 @@ dnl with or without modifications, as long as this notice is preserved.
dnl From Paul Eggert.
+AC_PREREQ([2.62])
+
# Define HAVE_LONG_LONG_INT if 'long long int' works.
-# This fixes a bug in Autoconf 2.61, and can be faster
-# than what's in Autoconf 2.62 through 2.68.
+# This can be faster than what's in Autoconf 2.62 through 2.68.
# Note: If the type 'long long int' exists but is only 32 bits large
# (as on some very old compilers), HAVE_LONG_LONG_INT will not be
@@ -56,8 +57,7 @@ AC_DEFUN([AC_TYPE_LONG_LONG_INT],
])
# Define HAVE_UNSIGNED_LONG_LONG_INT if 'unsigned long long int' works.
-# This fixes a bug in Autoconf 2.61, and can be faster
-# than what's in Autoconf 2.62 through 2.68.
+# This can be faster than what's in Autoconf 2.62 through 2.68.
# Note: If the type 'unsigned long long int' exists but is only 32 bits
# large (as on some very old compilers), AC_TYPE_UNSIGNED_LONG_LONG_INT
diff --git a/m4/lstat.m4 b/m4/lstat.m4
index ef6b457a94d..ace163867e2 100644
--- a/m4/lstat.m4
+++ b/m4/lstat.m4
@@ -1,4 +1,4 @@
-# serial 31
+# serial 32
# Copyright (C) 1997-2001, 2003-2019 Free Software Foundation, Inc.
#
@@ -53,6 +53,9 @@ AC_DEFUN([gl_FUNC_LSTAT_FOLLOWS_SLASHED_SYMLINK],
[gl_cv_func_lstat_dereferences_slashed_symlink=yes],
[gl_cv_func_lstat_dereferences_slashed_symlink=no],
[case "$host_os" in
+ linux-* | linux)
+ # Guess yes on Linux systems.
+ gl_cv_func_lstat_dereferences_slashed_symlink="guessing yes" ;;
*-gnu* | gnu*)
# Guess yes on glibc systems.
gl_cv_func_lstat_dereferences_slashed_symlink="guessing yes" ;;
diff --git a/m4/manywarnings.m4 b/m4/manywarnings.m4
index 72fdd418607..e0488a5cb38 100644
--- a/m4/manywarnings.m4
+++ b/m4/manywarnings.m4
@@ -1,4 +1,4 @@
-# manywarnings.m4 serial 13
+# manywarnings.m4 serial 17
dnl Copyright (C) 2008-2019 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -51,54 +51,53 @@ m4_defun([gl_MANYWARN_ALL_GCC(C)],
dnl Check if -W -Werror -Wno-missing-field-initializers is supported
dnl with the current $CC $CFLAGS $CPPFLAGS.
- AC_MSG_CHECKING([whether -Wno-missing-field-initializers is supported])
- AC_CACHE_VAL([gl_cv_cc_nomfi_supported], [
- gl_save_CFLAGS="$CFLAGS"
- CFLAGS="$CFLAGS -W -Werror -Wno-missing-field-initializers"
- AC_COMPILE_IFELSE(
- [AC_LANG_PROGRAM([[]], [[]])],
- [gl_cv_cc_nomfi_supported=yes],
- [gl_cv_cc_nomfi_supported=no])
- CFLAGS="$gl_save_CFLAGS"])
- AC_MSG_RESULT([$gl_cv_cc_nomfi_supported])
+ AC_CACHE_CHECK([whether -Wno-missing-field-initializers is supported],
+ [gl_cv_cc_nomfi_supported],
+ [gl_save_CFLAGS="$CFLAGS"
+ CFLAGS="$CFLAGS -W -Werror -Wno-missing-field-initializers"
+ AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM([[]], [[]])],
+ [gl_cv_cc_nomfi_supported=yes],
+ [gl_cv_cc_nomfi_supported=no])
+ CFLAGS="$gl_save_CFLAGS"
+ ])
if test "$gl_cv_cc_nomfi_supported" = yes; then
dnl Now check whether -Wno-missing-field-initializers is needed
dnl for the { 0, } construct.
- AC_MSG_CHECKING([whether -Wno-missing-field-initializers is needed])
- AC_CACHE_VAL([gl_cv_cc_nomfi_needed], [
- gl_save_CFLAGS="$CFLAGS"
- CFLAGS="$CFLAGS -W -Werror"
- AC_COMPILE_IFELSE(
- [AC_LANG_PROGRAM(
- [[int f (void)
- {
- typedef struct { int a; int b; } s_t;
- s_t s1 = { 0, };
- return s1.b;
- }
- ]],
- [[]])],
- [gl_cv_cc_nomfi_needed=no],
- [gl_cv_cc_nomfi_needed=yes])
- CFLAGS="$gl_save_CFLAGS"
- ])
- AC_MSG_RESULT([$gl_cv_cc_nomfi_needed])
+ AC_CACHE_CHECK([whether -Wno-missing-field-initializers is needed],
+ [gl_cv_cc_nomfi_needed],
+ [gl_save_CFLAGS="$CFLAGS"
+ CFLAGS="$CFLAGS -W -Werror"
+ AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[int f (void)
+ {
+ typedef struct { int a; int b; } s_t;
+ s_t s1 = { 0, };
+ return s1.b;
+ }
+ ]],
+ [[]])],
+ [gl_cv_cc_nomfi_needed=no],
+ [gl_cv_cc_nomfi_needed=yes])
+ CFLAGS="$gl_save_CFLAGS"
+ ])
fi
dnl Next, check if -Werror -Wuninitialized is useful with the
dnl user's choice of $CFLAGS; some versions of gcc warn that it
dnl has no effect if -O is not also used
- AC_MSG_CHECKING([whether -Wuninitialized is supported])
- AC_CACHE_VAL([gl_cv_cc_uninitialized_supported], [
- gl_save_CFLAGS="$CFLAGS"
- CFLAGS="$CFLAGS -Werror -Wuninitialized"
- AC_COMPILE_IFELSE(
- [AC_LANG_PROGRAM([[]], [[]])],
- [gl_cv_cc_uninitialized_supported=yes],
- [gl_cv_cc_uninitialized_supported=no])
- CFLAGS="$gl_save_CFLAGS"])
- AC_MSG_RESULT([$gl_cv_cc_uninitialized_supported])
+ AC_CACHE_CHECK([whether -Wuninitialized is supported],
+ [gl_cv_cc_uninitialized_supported],
+ [gl_save_CFLAGS="$CFLAGS"
+ CFLAGS="$CFLAGS -Werror -Wuninitialized"
+ AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM([[]], [[]])],
+ [gl_cv_cc_uninitialized_supported=yes],
+ [gl_cv_cc_uninitialized_supported=no])
+ CFLAGS="$gl_save_CFLAGS"
+ ])
fi
@@ -106,18 +105,17 @@ m4_defun([gl_MANYWARN_ALL_GCC(C)],
# To compare this list to your installed GCC's, run this Bash command:
#
# comm -3 \
- # <(sed -n 's/^ *\(-[^ ]*\) .*/\1/p' manywarnings.m4 | sort) \
- # <(gcc --help=warnings | sed -n 's/^ \(-[^ ]*\) .*/\1/p' | sort |
- # grep -v -x -F -f <(
- # awk '/^[^#]/ {print $1}' ../build-aux/gcc-warning.spec))
+ # <((sed -n 's/^ *\(-[^ 0-9][^ ]*\) .*/\1/p' manywarnings.m4; \
+ # awk '/^[^#]/ {print $1}' ../build-aux/gcc-warning.spec) | sort) \
+ # <(LC_ALL=C gcc --help=warnings | sed -n 's/^ \(-[^ ]*\) .*/\1/p' | sort)
gl_manywarn_set=
for gl_manywarn_item in -fno-common \
-W \
- -Wabi \
-Waddress \
-Waggressive-loop-optimizations \
-Wall \
+ -Wattribute-alias \
-Wattributes \
-Wbad-function-cast \
-Wbool-compare \
@@ -125,8 +123,9 @@ m4_defun([gl_MANYWARN_ALL_GCC(C)],
-Wbuiltin-declaration-mismatch \
-Wbuiltin-macro-redefined \
-Wcast-align \
+ -Wcast-align=strict \
+ -Wcast-function-type \
-Wchar-subscripts \
- -Wchkp \
-Wclobbered \
-Wcomment \
-Wcomments \
@@ -160,6 +159,7 @@ m4_defun([gl_MANYWARN_ALL_GCC(C)],
-Wframe-address \
-Wfree-nonheap-object \
-Whsa \
+ -Wif-not-aligned \
-Wignored-attributes \
-Wignored-qualifiers \
-Wimplicit \
@@ -173,7 +173,6 @@ m4_defun([gl_MANYWARN_ALL_GCC(C)],
-Wint-to-pointer-cast \
-Winvalid-memory-model \
-Winvalid-pch \
- -Wjump-misses-init \
-Wlogical-not-parentheses \
-Wlogical-op \
-Wmain \
@@ -181,6 +180,7 @@ m4_defun([gl_MANYWARN_ALL_GCC(C)],
-Wmemset-elt-size \
-Wmemset-transposed-args \
-Wmisleading-indentation \
+ -Wmissing-attributes \
-Wmissing-braces \
-Wmissing-declarations \
-Wmissing-field-initializers \
@@ -188,6 +188,7 @@ m4_defun([gl_MANYWARN_ALL_GCC(C)],
-Wmissing-parameter-type \
-Wmissing-prototypes \
-Wmultichar \
+ -Wmultistatement-macros \
-Wnarrowing \
-Wnested-externs \
-Wnonnull \
@@ -202,6 +203,7 @@ m4_defun([gl_MANYWARN_ALL_GCC(C)],
-Woverride-init \
-Wpacked \
-Wpacked-bitfield-compat \
+ -Wpacked-not-aligned \
-Wparentheses \
-Wpointer-arith \
-Wpointer-compare \
@@ -219,20 +221,23 @@ m4_defun([gl_MANYWARN_ALL_GCC(C)],
-Wshift-count-overflow \
-Wshift-negative-value \
-Wsizeof-array-argument \
+ -Wsizeof-pointer-div \
-Wsizeof-pointer-memaccess \
-Wstack-protector \
-Wstrict-aliasing \
-Wstrict-overflow \
-Wstrict-prototypes \
+ -Wstringop-truncation \
+ -Wsuggest-attribute=cold \
-Wsuggest-attribute=const \
-Wsuggest-attribute=format \
+ -Wsuggest-attribute=malloc \
-Wsuggest-attribute=noreturn \
-Wsuggest-attribute=pure \
-Wsuggest-final-methods \
-Wsuggest-final-types \
-Wswitch \
-Wswitch-bool \
- -Wswitch-default \
-Wswitch-unreachable \
-Wsync-nand \
-Wsystem-headers \
diff --git a/m4/mbstate_t.m4 b/m4/mbstate_t.m4
new file mode 100644
index 00000000000..f669753c07e
--- /dev/null
+++ b/m4/mbstate_t.m4
@@ -0,0 +1,41 @@
+# mbstate_t.m4 serial 13
+dnl Copyright (C) 2000-2002, 2008-2019 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.
+
+# From Paul Eggert.
+
+# BeOS 5 has <wchar.h> but does not define mbstate_t,
+# so you can't declare an object of that type.
+# Check for this incompatibility with Standard C.
+
+# AC_TYPE_MBSTATE_T
+# -----------------
+AC_DEFUN([AC_TYPE_MBSTATE_T],
+[
+ AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS]) dnl for HP-UX 11.11
+
+ AC_CACHE_CHECK([for mbstate_t], [ac_cv_type_mbstate_t],
+ [AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM(
+ [AC_INCLUDES_DEFAULT[
+/* Tru64 with Desktop Toolkit C has a bug: <stdio.h> must be included before
+ <wchar.h>.
+ BSD/OS 4.0.1 has a bug: <stddef.h>, <stdio.h> and <time.h> must be
+ included before <wchar.h>. */
+#include <stddef.h>
+#include <stdio.h>
+#include <time.h>
+#include <wchar.h>]],
+ [[mbstate_t x; return sizeof x;]])],
+ [ac_cv_type_mbstate_t=yes],
+ [ac_cv_type_mbstate_t=no])])
+ if test $ac_cv_type_mbstate_t = yes; then
+ AC_DEFINE([HAVE_MBSTATE_T], [1],
+ [Define to 1 if <wchar.h> declares mbstate_t.])
+ else
+ AC_DEFINE([mbstate_t], [int],
+ [Define to a type if <wchar.h> does not define.])
+ fi
+])
diff --git a/m4/memrchr.m4 b/m4/memrchr.m4
index c4ac8c180c5..e907590e38a 100644
--- a/m4/memrchr.m4
+++ b/m4/memrchr.m4
@@ -1,6 +1,6 @@
# memrchr.m4 serial 10
-dnl Copyright (C) 2002-2003, 2005-2007, 2009-2019 Free Software
-dnl Foundation, Inc.
+dnl Copyright (C) 2002-2003, 2005-2007, 2009-2019 Free Software Foundation,
+dnl 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.
diff --git a/m4/mktime.m4 b/m4/mktime.m4
index 47cbefba1a5..a86e1eebc68 100644
--- a/m4/mktime.m4
+++ b/m4/mktime.m4
@@ -1,6 +1,6 @@
# serial 30
-dnl Copyright (C) 2002-2003, 2005-2007, 2009-2019 Free Software
-dnl Foundation, Inc.
+dnl Copyright (C) 2002-2003, 2005-2007, 2009-2019 Free Software Foundation,
+dnl 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.
diff --git a/m4/nocrash.m4 b/m4/nocrash.m4
index 4735f04b402..4d9f0226906 100644
--- a/m4/nocrash.m4
+++ b/m4/nocrash.m4
@@ -1,4 +1,4 @@
-# nocrash.m4 serial 4
+# nocrash.m4 serial 5
dnl Copyright (C) 2005, 2009-2019 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -79,7 +79,7 @@ nocrash_init (void)
}
}
}
-#elif (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+#elif defined _WIN32 && ! defined __CYGWIN__
/* Avoid a crash on native Windows. */
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
diff --git a/m4/nstrftime.m4 b/m4/nstrftime.m4
index 67fcd140589..546c2408277 100644
--- a/m4/nstrftime.m4
+++ b/m4/nstrftime.m4
@@ -1,7 +1,6 @@
# serial 34
-# Copyright (C) 1996-1997, 1999-2007, 2009-2019 Free Software
-# Foundation, Inc.
+# Copyright (C) 1996-1997, 1999-2007, 2009-2019 Free Software Foundation, Inc.
#
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
diff --git a/m4/pkg.m4 b/m4/pkg.m4
index 82bea96ee70..13a88901786 100644
--- a/m4/pkg.m4
+++ b/m4/pkg.m4
@@ -1,6 +1,6 @@
-dnl pkg.m4 - Macros to locate and utilise pkg-config. -*- Autoconf -*-
-dnl serial 11 (pkg-config-0.29.1)
-dnl
+# pkg.m4 - Macros to locate and utilise pkg-config. -*- Autoconf -*-
+# serial 12 (pkg-config-0.29.2)
+
dnl Copyright © 2004 Scott James Remnant <scott@netsplit.com>.
dnl Copyright © 2012-2015 Dan Nicholson <dbn.lists@gmail.com>
dnl
@@ -41,7 +41,7 @@ dnl
dnl See the "Since" comment for each macro you use to see what version
dnl of the macros you require.
m4_defun([PKG_PREREQ],
-[m4_define([PKG_MACROS_VERSION], [0.29.1])
+[m4_define([PKG_MACROS_VERSION], [0.29.2])
m4_if(m4_version_compare(PKG_MACROS_VERSION, [$1]), -1,
[m4_fatal([pkg.m4 version $1 or higher is required but ]PKG_MACROS_VERSION[ found])])
])dnl PKG_PREREQ
@@ -142,7 +142,7 @@ AC_ARG_VAR([$1][_CFLAGS], [C compiler flags for $1, overriding pkg-config])dnl
AC_ARG_VAR([$1][_LIBS], [linker flags for $1, overriding pkg-config])dnl
pkg_failed=no
-AC_MSG_CHECKING([for $1])
+AC_MSG_CHECKING([for $2])
_PKG_CONFIG([$1][_CFLAGS], [cflags], [$2])
_PKG_CONFIG([$1][_LIBS], [libs], [$2])
@@ -152,11 +152,11 @@ and $1[]_LIBS to avoid the need to call pkg-config.
See the pkg-config man page for more details.])
if test $pkg_failed = yes; then
- AC_MSG_RESULT([no])
+ AC_MSG_RESULT([no])
_PKG_SHORT_ERRORS_SUPPORTED
if test $_pkg_short_errors_supported = yes; then
$1[]_PKG_ERRORS=`$PKG_CONFIG --short-errors --print-errors --cflags --libs "$2" 2>&1`
- else
+ else
$1[]_PKG_ERRORS=`$PKG_CONFIG --print-errors --cflags --libs "$2" 2>&1`
fi
# Put the nasty error message in config.log where it belongs
@@ -173,7 +173,7 @@ installed software in a non-standard prefix.
_PKG_TEXT])[]dnl
])
elif test $pkg_failed = untried; then
- AC_MSG_RESULT([no])
+ AC_MSG_RESULT([no])
m4_default([$4], [AC_MSG_FAILURE(
[The pkg-config script could not be found or is too old. Make sure it
is in your PATH or set the PKG_CONFIG environment variable to the full
diff --git a/m4/pselect.m4 b/m4/pselect.m4
index d85aa6a6fad..5c72b69587a 100644
--- a/m4/pselect.m4
+++ b/m4/pselect.m4
@@ -1,4 +1,4 @@
-# pselect.m4 serial 6
+# pselect.m4 serial 7
dnl Copyright (C) 2011-2019 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -51,10 +51,12 @@ AC_DEFUN([gl_FUNC_PSELECT],
[gl_cv_func_pselect_detects_ebadf=no],
[
case "$host_os" in
- # Guess yes on glibc systems.
- *-gnu* | gnu*) gl_cv_func_pselect_detects_ebadf="guessing yes" ;;
- # If we don't know, assume the worst.
- *) gl_cv_func_pselect_detects_ebadf="guessing no" ;;
+ # Guess yes on Linux systems.
+ linux-* | linux) gl_cv_func_pselect_detects_ebadf="guessing yes" ;;
+ # Guess yes on glibc systems.
+ *-gnu* | gnu*) gl_cv_func_pselect_detects_ebadf="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_pselect_detects_ebadf="guessing no" ;;
esac
])
])
diff --git a/m4/pthread_sigmask.m4 b/m4/pthread_sigmask.m4
index ca614294228..cadc239a3c6 100644
--- a/m4/pthread_sigmask.m4
+++ b/m4/pthread_sigmask.m4
@@ -124,41 +124,41 @@ AC_DEFUN([gl_FUNC_PTHREAD_SIGMASK],
case " $LIBS " in
*' -pthread '*) ;;
*' -lpthread '*) ;;
- *)
- AC_CACHE_CHECK([whether pthread_sigmask works without -lpthread],
- [gl_cv_func_pthread_sigmask_in_libc_works],
- [
- AC_RUN_IFELSE(
- [AC_LANG_SOURCE([[
- #include <pthread.h>
- #include <signal.h>
- #include <stddef.h>
- int main ()
- {
- sigset_t set;
- sigemptyset (&set);
- return pthread_sigmask (1729, &set, NULL) != 0;
- }]])],
- [gl_cv_func_pthread_sigmask_in_libc_works=no],
- [gl_cv_func_pthread_sigmask_in_libc_works=yes],
- [
- changequote(,)dnl
- case "$host_os" in
- freebsd* | hpux* | solaris | solaris2.[2-9]*)
- gl_cv_func_pthread_sigmask_in_libc_works="guessing no";;
- *)
- gl_cv_func_pthread_sigmask_in_libc_works="guessing yes";;
- esac
- changequote([,])dnl
- ])
- ])
- case "$gl_cv_func_pthread_sigmask_in_libc_works" in
- *no)
- REPLACE_PTHREAD_SIGMASK=1
- AC_DEFINE([PTHREAD_SIGMASK_INEFFECTIVE], [1],
- [Define to 1 if pthread_sigmask may return 0 and have no effect.])
- ;;
- esac;;
+ *)
+ AC_CACHE_CHECK([whether pthread_sigmask works without -lpthread],
+ [gl_cv_func_pthread_sigmask_in_libc_works],
+ [
+ AC_RUN_IFELSE(
+ [AC_LANG_SOURCE([[
+ #include <pthread.h>
+ #include <signal.h>
+ #include <stddef.h>
+ int main ()
+ {
+ sigset_t set;
+ sigemptyset (&set);
+ return pthread_sigmask (1729, &set, NULL) != 0;
+ }]])],
+ [gl_cv_func_pthread_sigmask_in_libc_works=no],
+ [gl_cv_func_pthread_sigmask_in_libc_works=yes],
+ [
+ changequote(,)dnl
+ case "$host_os" in
+ freebsd* | hpux* | solaris | solaris2.[2-9]*)
+ gl_cv_func_pthread_sigmask_in_libc_works="guessing no";;
+ *)
+ gl_cv_func_pthread_sigmask_in_libc_works="guessing yes";;
+ esac
+ changequote([,])dnl
+ ])
+ ])
+ case "$gl_cv_func_pthread_sigmask_in_libc_works" in
+ *no)
+ REPLACE_PTHREAD_SIGMASK=1
+ AC_DEFINE([PTHREAD_SIGMASK_INEFFECTIVE], [1],
+ [Define to 1 if pthread_sigmask may return 0 and have no effect.])
+ ;;
+ esac;;
esac
fi
diff --git a/m4/putenv.m4 b/m4/putenv.m4
index f8960f66be5..342ba2636ab 100644
--- a/m4/putenv.m4
+++ b/m4/putenv.m4
@@ -1,4 +1,4 @@
-# putenv.m4 serial 22
+# putenv.m4 serial 23
dnl Copyright (C) 2002-2019 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -36,6 +36,8 @@ AC_DEFUN([gl_FUNC_PUTENV],
[case "$host_os" in
# Guess yes on glibc systems.
*-gnu* | gnu*) gl_cv_func_svid_putenv="guessing yes" ;;
+ # Guess yes on musl systems.
+ *-musl*) gl_cv_func_svid_putenv="guessing yes" ;;
# Guess no on native Windows.
mingw*) gl_cv_func_svid_putenv="guessing no" ;;
# If we don't know, assume the worst.
diff --git a/m4/readlink.m4 b/m4/readlink.m4
index f76bcf9c9ab..2d7681576cc 100644
--- a/m4/readlink.m4
+++ b/m4/readlink.m4
@@ -1,4 +1,4 @@
-# readlink.m4 serial 13
+# readlink.m4 serial 14
dnl Copyright (C) 2003, 2007, 2009-2019 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -34,10 +34,12 @@ AC_DEFUN([gl_FUNC_READLINK],
return readlink ("conftest.lnk2/", buf, sizeof buf) != -1;]])],
[gl_cv_func_readlink_works=yes], [gl_cv_func_readlink_works=no],
[case "$host_os" in
- # Guess yes on glibc systems.
- *-gnu* | gnu*) gl_cv_func_readlink_works="guessing yes" ;;
- # If we don't know, assume the worst.
- *) gl_cv_func_readlink_works="guessing no" ;;
+ # Guess yes on Linux systems.
+ linux-* | linux) gl_cv_func_readlink_works="guessing yes" ;;
+ # Guess yes on glibc systems.
+ *-gnu* | gnu*) gl_cv_func_readlink_works="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_readlink_works="guessing no" ;;
esac
])
rm -f conftest.link conftest.lnk2])
diff --git a/m4/regex.m4 b/m4/regex.m4
new file mode 100644
index 00000000000..35119c5c85f
--- /dev/null
+++ b/m4/regex.m4
@@ -0,0 +1,311 @@
+# serial 68
+
+# Copyright (C) 1996-2001, 2003-2019 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+dnl Initially derived from code in GNU grep.
+dnl Mostly written by Jim Meyering.
+
+AC_PREREQ([2.50])
+
+AC_DEFUN([gl_REGEX],
+[
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
+ AC_ARG_WITH([included-regex],
+ [AS_HELP_STRING([--without-included-regex],
+ [don't compile regex; this is the default on systems
+ with recent-enough versions of the GNU C Library
+ (use with caution on other systems).])])
+
+ case $with_included_regex in #(
+ yes|no) ac_use_included_regex=$with_included_regex
+ ;;
+ '')
+ # If the system regex support is good enough that it passes the
+ # following run test, then default to *not* using the included regex.c.
+ # If cross compiling, assume the test would fail and use the included
+ # regex.c.
+ AC_CHECK_DECLS_ONCE([alarm])
+ AC_CHECK_HEADERS_ONCE([malloc.h])
+ AC_CACHE_CHECK([for working re_compile_pattern],
+ [gl_cv_func_re_compile_pattern_working],
+ [AC_RUN_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#include <regex.h>
+
+ #include <locale.h>
+ #include <limits.h>
+ #include <string.h>
+
+ #if defined M_CHECK_ACTION || HAVE_DECL_ALARM
+ # include <signal.h>
+ # include <unistd.h>
+ #endif
+
+ #if HAVE_MALLOC_H
+ # include <malloc.h>
+ #endif
+
+ #ifdef M_CHECK_ACTION
+ /* Exit with distinguishable exit code. */
+ static void sigabrt_no_core (int sig) { raise (SIGTERM); }
+ #endif
+ ]],
+ [[int result = 0;
+ static struct re_pattern_buffer regex;
+ unsigned char folded_chars[UCHAR_MAX + 1];
+ int i;
+ const char *s;
+ struct re_registers regs;
+
+ /* Some builds of glibc go into an infinite loop on this
+ test. Use alarm to force death, and mallopt to avoid
+ malloc recursion in diagnosing the corrupted heap. */
+#if HAVE_DECL_ALARM
+ signal (SIGALRM, SIG_DFL);
+ alarm (2);
+#endif
+#ifdef M_CHECK_ACTION
+ signal (SIGABRT, sigabrt_no_core);
+ mallopt (M_CHECK_ACTION, 2);
+#endif
+
+ if (setlocale (LC_ALL, "en_US.UTF-8"))
+ {
+ {
+ /* https://sourceware.org/ml/libc-hacker/2006-09/msg00008.html
+ This test needs valgrind to catch the bug on Debian
+ GNU/Linux 3.1 x86, but it might catch the bug better
+ on other platforms and it shouldn't hurt to try the
+ test here. */
+ static char const pat[] = "insert into";
+ static char const data[] =
+ "\xFF\0\x12\xA2\xAA\xC4\xB1,K\x12\xC4\xB1*\xACK";
+ re_set_syntax (RE_SYNTAX_GREP | RE_HAT_LISTS_NOT_NEWLINE
+ | RE_ICASE);
+ memset (&regex, 0, sizeof regex);
+ s = re_compile_pattern (pat, sizeof pat - 1, &regex);
+ if (s)
+ result |= 1;
+ else if (re_search (&regex, data, sizeof data - 1,
+ 0, sizeof data - 1, &regs)
+ != -1)
+ result |= 1;
+ regfree (&regex);
+ }
+
+ {
+ /* This test is from glibc bug 15078.
+ The test case is from Andreas Schwab in
+ <https://sourceware.org/ml/libc-alpha/2013-01/msg00967.html>.
+ */
+ static char const pat[] = "[^x]x";
+ static char const data[] =
+ /* <U1000><U103B><U103D><U1014><U103A><U102F><U1015><U103A> */
+ "\xe1\x80\x80"
+ "\xe1\x80\xbb"
+ "\xe1\x80\xbd"
+ "\xe1\x80\x94"
+ "\xe1\x80\xba"
+ "\xe1\x80\xaf"
+ "\xe1\x80\x95"
+ "\xe1\x80\xba"
+ "x";
+ re_set_syntax (0);
+ memset (&regex, 0, sizeof regex);
+ s = re_compile_pattern (pat, sizeof pat - 1, &regex);
+ if (s)
+ result |= 1;
+ else
+ {
+ i = re_search (&regex, data, sizeof data - 1,
+ 0, sizeof data - 1, 0);
+ if (i != 0 && i != 21)
+ result |= 1;
+ }
+ regfree (&regex);
+ }
+
+ if (! setlocale (LC_ALL, "C"))
+ return 1;
+ }
+
+ /* This test is from glibc bug 3957, reported by Andrew Mackey. */
+ re_set_syntax (RE_SYNTAX_EGREP | RE_HAT_LISTS_NOT_NEWLINE);
+ memset (&regex, 0, sizeof regex);
+ s = re_compile_pattern ("a[^x]b", 6, &regex);
+ if (s)
+ result |= 2;
+ /* This should fail, but succeeds for glibc-2.5. */
+ else if (re_search (&regex, "a\nb", 3, 0, 3, &regs) != -1)
+ result |= 2;
+
+ /* This regular expression is from Spencer ere test number 75
+ in grep-2.3. */
+ re_set_syntax (RE_SYNTAX_POSIX_EGREP);
+ memset (&regex, 0, sizeof regex);
+ for (i = 0; i <= UCHAR_MAX; i++)
+ folded_chars[i] = i;
+ regex.translate = folded_chars;
+ s = re_compile_pattern ("a[[:@:>@:]]b\n", 11, &regex);
+ /* This should fail with _Invalid character class name_ error. */
+ if (!s)
+ result |= 4;
+
+ /* Ensure that [b-a] is diagnosed as invalid, when
+ using RE_NO_EMPTY_RANGES. */
+ re_set_syntax (RE_SYNTAX_POSIX_EGREP | RE_NO_EMPTY_RANGES);
+ memset (&regex, 0, sizeof regex);
+ s = re_compile_pattern ("a[b-a]", 6, &regex);
+ if (s == 0)
+ result |= 8;
+
+ /* This should succeed, but does not for glibc-2.1.3. */
+ memset (&regex, 0, sizeof regex);
+ s = re_compile_pattern ("{1", 2, &regex);
+ if (s)
+ result |= 8;
+
+ /* The following example is derived from a problem report
+ against gawk from Jorge Stolfi <stolfi@ic.unicamp.br>. */
+ memset (&regex, 0, sizeof regex);
+ s = re_compile_pattern ("[an\371]*n", 7, &regex);
+ if (s)
+ result |= 8;
+ /* This should match, but does not for glibc-2.2.1. */
+ else if (re_match (&regex, "an", 2, 0, &regs) != 2)
+ result |= 8;
+
+ memset (&regex, 0, sizeof regex);
+ s = re_compile_pattern ("x", 1, &regex);
+ if (s)
+ result |= 8;
+ /* glibc-2.2.93 does not work with a negative RANGE argument. */
+ else if (re_search (&regex, "wxy", 3, 2, -2, &regs) != 1)
+ result |= 8;
+
+ /* The version of regex.c in older versions of gnulib
+ ignored RE_ICASE. Detect that problem too. */
+ re_set_syntax (RE_SYNTAX_EMACS | RE_ICASE);
+ memset (&regex, 0, sizeof regex);
+ s = re_compile_pattern ("x", 1, &regex);
+ if (s)
+ result |= 16;
+ else if (re_search (&regex, "WXY", 3, 0, 3, &regs) < 0)
+ result |= 16;
+
+ /* Catch a bug reported by Vin Shelton in
+ https://lists.gnu.org/r/bug-coreutils/2007-06/msg00089.html
+ */
+ re_set_syntax (RE_SYNTAX_POSIX_BASIC
+ & ~RE_CONTEXT_INVALID_DUP
+ & ~RE_NO_EMPTY_RANGES);
+ memset (&regex, 0, sizeof regex);
+ s = re_compile_pattern ("[[:alnum:]_-]\\\\+$", 16, &regex);
+ if (s)
+ result |= 32;
+
+ /* REG_STARTEND was added to glibc on 2004-01-15.
+ Reject older versions. */
+ if (! REG_STARTEND)
+ result |= 64;
+
+ /* Matching with the compiled form of this regexp would provoke
+ an assertion failure prior to glibc-2.28:
+ regexec.c:1375: pop_fail_stack: Assertion 'num >= 0' failed
+ With glibc-2.28, compilation fails and reports the invalid
+ back reference. */
+ re_set_syntax (RE_SYNTAX_POSIX_EGREP);
+ memset (&regex, 0, sizeof regex);
+ s = re_compile_pattern ("0|()0|\\1|0", 10, &regex);
+ if (!s || strcmp (s, "Invalid back reference"))
+ result |= 64;
+
+#if 0
+ /* It would be nice to reject hosts whose regoff_t values are too
+ narrow (including glibc on hosts with 64-bit ptrdiff_t and
+ 32-bit int), but we should wait until glibc implements this
+ feature. Otherwise, support for equivalence classes and
+ multibyte collation symbols would always be broken except
+ when compiling --without-included-regex. */
+ if (sizeof (regoff_t) < sizeof (ptrdiff_t)
+ || sizeof (regoff_t) < sizeof (ssize_t))
+ result |= 64;
+#endif
+
+ return result;
+ ]])],
+ [gl_cv_func_re_compile_pattern_working=yes],
+ [gl_cv_func_re_compile_pattern_working=no],
+ [case "$host_os" in
+ # Guess no on native Windows.
+ mingw*) gl_cv_func_re_compile_pattern_working="guessing no" ;;
+ # Otherwise, assume it is not working.
+ *) gl_cv_func_re_compile_pattern_working="guessing no" ;;
+ esac
+ ])
+ ])
+ case "$gl_cv_func_re_compile_pattern_working" in #(
+ *yes) ac_use_included_regex=no;; #(
+ *no) ac_use_included_regex=yes;;
+ esac
+ ;;
+ *) AC_MSG_ERROR([Invalid value for --with-included-regex: $with_included_regex])
+ ;;
+ esac
+
+ if test $ac_use_included_regex = yes; then
+ AC_DEFINE([_REGEX_INCLUDE_LIMITS_H], [1],
+ [Define if you want <regex.h> to include <limits.h>, so that it
+ consistently overrides <limits.h>'s RE_DUP_MAX.])
+ AC_DEFINE([_REGEX_LARGE_OFFSETS], [1],
+ [Define if you want regoff_t to be at least as wide POSIX requires.])
+ AC_DEFINE([re_syntax_options], [rpl_re_syntax_options],
+ [Define to rpl_re_syntax_options if the replacement should be used.])
+ AC_DEFINE([re_set_syntax], [rpl_re_set_syntax],
+ [Define to rpl_re_set_syntax if the replacement should be used.])
+ AC_DEFINE([re_compile_pattern], [rpl_re_compile_pattern],
+ [Define to rpl_re_compile_pattern if the replacement should be used.])
+ AC_DEFINE([re_compile_fastmap], [rpl_re_compile_fastmap],
+ [Define to rpl_re_compile_fastmap if the replacement should be used.])
+ AC_DEFINE([re_search], [rpl_re_search],
+ [Define to rpl_re_search if the replacement should be used.])
+ AC_DEFINE([re_search_2], [rpl_re_search_2],
+ [Define to rpl_re_search_2 if the replacement should be used.])
+ AC_DEFINE([re_match], [rpl_re_match],
+ [Define to rpl_re_match if the replacement should be used.])
+ AC_DEFINE([re_match_2], [rpl_re_match_2],
+ [Define to rpl_re_match_2 if the replacement should be used.])
+ AC_DEFINE([re_set_registers], [rpl_re_set_registers],
+ [Define to rpl_re_set_registers if the replacement should be used.])
+ AC_DEFINE([re_comp], [rpl_re_comp],
+ [Define to rpl_re_comp if the replacement should be used.])
+ AC_DEFINE([re_exec], [rpl_re_exec],
+ [Define to rpl_re_exec if the replacement should be used.])
+ AC_DEFINE([regcomp], [rpl_regcomp],
+ [Define to rpl_regcomp if the replacement should be used.])
+ AC_DEFINE([regexec], [rpl_regexec],
+ [Define to rpl_regexec if the replacement should be used.])
+ AC_DEFINE([regerror], [rpl_regerror],
+ [Define to rpl_regerror if the replacement should be used.])
+ AC_DEFINE([regfree], [rpl_regfree],
+ [Define to rpl_regfree if the replacement should be used.])
+ fi
+])
+
+# Prerequisites of lib/regex.c and lib/regex_internal.c.
+AC_DEFUN([gl_PREREQ_REGEX],
+[
+ AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])
+ AC_REQUIRE([AC_C_INLINE])
+ AC_REQUIRE([AC_C_RESTRICT])
+ AC_REQUIRE([AC_TYPE_MBSTATE_T])
+ AC_REQUIRE([gl_EEMALLOC])
+ AC_REQUIRE([gl_GLIBC21])
+ AC_CHECK_HEADERS([libintl.h])
+ AC_CHECK_FUNCS_ONCE([isblank iswctype])
+ AC_CHECK_DECLS([isblank], [], [], [[#include <ctype.h>]])
+])
diff --git a/m4/sig2str.m4 b/m4/sig2str.m4
index 8c90e10477e..0474d51d39e 100644
--- a/m4/sig2str.m4
+++ b/m4/sig2str.m4
@@ -1,6 +1,5 @@
# serial 7
-dnl Copyright (C) 2002, 2005-2006, 2009-2019 Free Software Foundation,
-dnl Inc.
+dnl Copyright (C) 2002, 2005-2006, 2009-2019 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.
diff --git a/m4/socklen.m4 b/m4/socklen.m4
index 3cb6625ca9a..deb5135fef4 100644
--- a/m4/socklen.m4
+++ b/m4/socklen.m4
@@ -1,4 +1,4 @@
-# socklen.m4 serial 10
+# socklen.m4 serial 11
dnl Copyright (C) 2005-2007, 2009-2019 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -15,8 +15,8 @@ dnl So we have to test to find something that will work.
AC_DEFUN([gl_TYPE_SOCKLEN_T],
[AC_REQUIRE([gl_CHECK_SOCKET_HEADERS])dnl
AC_CHECK_TYPE([socklen_t], ,
- [AC_MSG_CHECKING([for socklen_t equivalent])
- AC_CACHE_VAL([gl_cv_socklen_t_equiv],
+ [AC_CACHE_CHECK([for socklen_t equivalent],
+ [gl_cv_socklen_t_equiv],
[# Systems have either "struct sockaddr *" or
# "void *" as the second argument to getpeername
gl_cv_socklen_t_equiv=
@@ -34,11 +34,10 @@ AC_DEFUN([gl_TYPE_SOCKLEN_T],
done
test "$gl_cv_socklen_t_equiv" != "" && break
done
- ])
- if test "$gl_cv_socklen_t_equiv" = ""; then
- AC_MSG_ERROR([Cannot find a type to use in place of socklen_t])
- fi
- AC_MSG_RESULT([$gl_cv_socklen_t_equiv])
+ if test "$gl_cv_socklen_t_equiv" = ""; then
+ AC_MSG_ERROR([Cannot find a type to use in place of socklen_t])
+ fi
+ ])
AC_DEFINE_UNQUOTED([socklen_t], [$gl_cv_socklen_t_equiv],
[type to use in place of socklen_t if not defined])],
[gl_SOCKET_HEADERS])])
diff --git a/m4/ssize_t.m4 b/m4/ssize_t.m4
index 117b0ca9b07..38bcee1c7d9 100644
--- a/m4/ssize_t.m4
+++ b/m4/ssize_t.m4
@@ -1,6 +1,5 @@
# ssize_t.m4 serial 5 (gettext-0.18.2)
-dnl Copyright (C) 2001-2003, 2006, 2010-2019 Free Software Foundation,
-dnl Inc.
+dnl Copyright (C) 2001-2003, 2006, 2010-2019 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.
diff --git a/m4/st_dm_mode.m4 b/m4/st_dm_mode.m4
index cad31460521..283981f9ddf 100644
--- a/m4/st_dm_mode.m4
+++ b/m4/st_dm_mode.m4
@@ -1,7 +1,6 @@
# serial 6
-# Copyright (C) 1998-1999, 2001, 2009-2019 Free Software Foundation,
-# Inc.
+# Copyright (C) 1998-1999, 2001, 2009-2019 Free Software Foundation, Inc.
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
# with or without modifications, as long as this notice is preserved.
diff --git a/m4/stat-time.m4 b/m4/stat-time.m4
index 8fe9efbd9c4..1685788e05f 100644
--- a/m4/stat-time.m4
+++ b/m4/stat-time.m4
@@ -1,7 +1,7 @@
# Checks for stat-related time functions.
-# Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2019 Free
-# Software Foundation, Inc.
+# Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2019 Free Software
+# Foundation, Inc.
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
diff --git a/m4/std-gnu11.m4 b/m4/std-gnu11.m4
index 207fcec6c23..23e7f75f1f4 100644
--- a/m4/std-gnu11.m4
+++ b/m4/std-gnu11.m4
@@ -70,7 +70,7 @@ _AS_ECHO_LOG([checking for _AC_LANG compiler version])
set X $ac_compile
ac_compiler=$[2]
for ac_option in --version -v -V -qversion -version; do
- _AC_DO_LIMIT([$ac_compiler $ac_option >&AS_MESSAGE_LOG_FD])
+ m4_ifdef([_AC_DO_LIMIT],[_AC_DO_LIMIT],[_AC_DO])([$ac_compiler $ac_option >&AS_MESSAGE_LOG_FD])
done
m4_expand_once([_AC_COMPILER_EXEEXT])[]dnl
@@ -135,7 +135,7 @@ _AS_ECHO_LOG([checking for _AC_LANG compiler version])
set X $ac_compile
ac_compiler=$[2]
for ac_option in --version -v -V -qversion; do
- _AC_DO_LIMIT([$ac_compiler $ac_option >&AS_MESSAGE_LOG_FD])
+ m4_ifdef([_AC_DO_LIMIT],[_AC_DO_LIMIT],[_AC_DO])([$ac_compiler $ac_option >&AS_MESSAGE_LOG_FD])
done
m4_expand_once([_AC_COMPILER_EXEEXT])[]dnl
diff --git a/m4/stddef_h.m4 b/m4/stddef_h.m4
index 7f6be5b2937..979e3cf7e79 100644
--- a/m4/stddef_h.m4
+++ b/m4/stddef_h.m4
@@ -1,5 +1,5 @@
dnl A placeholder for <stddef.h>, for platforms that have issues.
-# stddef_h.m4 serial 5
+# stddef_h.m4 serial 6
dnl Copyright (C) 2009-2019 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -10,13 +10,33 @@ AC_DEFUN([gl_STDDEF_H],
AC_REQUIRE([gl_STDDEF_H_DEFAULTS])
AC_REQUIRE([gt_TYPE_WCHAR_T])
STDDEF_H=
- AC_CHECK_TYPE([max_align_t], [], [HAVE_MAX_ALIGN_T=0; STDDEF_H=stddef.h],
- [[#include <stddef.h>
- ]])
+
+ dnl Test whether the type max_align_t exists and whether its alignment
+ dnl "is as great as is supported by the implementation in all contexts".
+ AC_CACHE_CHECK([for good max_align_t],
+ [gl_cv_type_max_align_t],
+ [AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#include <stddef.h>
+ unsigned int s = sizeof (max_align_t);
+ #if defined __GNUC__ || defined __IBM__ALIGNOF__
+ int check1[2 * (__alignof__ (double) <= __alignof__ (max_align_t)) - 1];
+ int check2[2 * (__alignof__ (long double) <= __alignof__ (max_align_t)) - 1];
+ #endif
+ ]])],
+ [gl_cv_type_max_align_t=yes],
+ [gl_cv_type_max_align_t=no])
+ ])
+ if test $gl_cv_type_max_align_t = no; then
+ HAVE_MAX_ALIGN_T=0
+ STDDEF_H=stddef.h
+ fi
+
if test $gt_cv_c_wchar_t = no; then
HAVE_WCHAR_T=0
STDDEF_H=stddef.h
fi
+
AC_CACHE_CHECK([whether NULL can be used in arbitrary expressions],
[gl_cv_decl_null_works],
[AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <stddef.h>
@@ -28,6 +48,7 @@ AC_DEFUN([gl_STDDEF_H],
REPLACE_NULL=1
STDDEF_H=stddef.h
fi
+
AC_SUBST([STDDEF_H])
AM_CONDITIONAL([GL_GENERATE_STDDEF_H], [test -n "$STDDEF_H"])
if test -n "$STDDEF_H"; then
diff --git a/m4/stdint.m4 b/m4/stdint.m4
index 0f58055b770..11d8e8e52d4 100644
--- a/m4/stdint.m4
+++ b/m4/stdint.m4
@@ -1,4 +1,4 @@
-# stdint.m4 serial 51
+# stdint.m4 serial 53
dnl Copyright (C) 2001-2019 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -7,6 +7,8 @@ dnl with or without modifications, as long as this notice is preserved.
dnl From Paul Eggert and Bruno Haible.
dnl Test whether <stdint.h> is supported or must be substituted.
+AC_PREREQ([2.61])
+
AC_DEFUN_ONCE([gl_STDINT_H],
[
AC_PREREQ([2.59])dnl
@@ -364,8 +366,7 @@ int32_t i32 = INT32_C (0x7fffffff);
esac
dnl The substitute stdint.h needs the substitute limit.h's _GL_INTEGER_WIDTH.
- LIMITS_H=limits.h
- AM_CONDITIONAL([GL_GENERATE_LIMITS_H], [test -n "$LIMITS_H"])
+ gl_REPLACE_LIMITS_H
AC_SUBST([HAVE_C99_STDINT_H])
AC_SUBST([HAVE_SYS_BITYPES_H])
@@ -541,9 +542,3 @@ AC_DEFUN([gl_STDINT_TYPE_PROPERTIES],
BITSIZEOF_WINT_T=32
fi
])
-
-dnl Autoconf >= 2.61 has AC_COMPUTE_INT built-in.
-dnl Remove this when we can assume autoconf >= 2.61.
-m4_ifdef([AC_COMPUTE_INT], [], [
- AC_DEFUN([AC_COMPUTE_INT], [_AC_COMPUTE_INT([$2],[$1],[$3],[$4])])
-])
diff --git a/m4/stdio_h.m4 b/m4/stdio_h.m4
index d507372d090..6c9c104044a 100644
--- a/m4/stdio_h.m4
+++ b/m4/stdio_h.m4
@@ -1,4 +1,4 @@
-# stdio_h.m4 serial 48
+# stdio_h.m4 serial 49
dnl Copyright (C) 2007-2019 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -28,7 +28,7 @@ AC_DEFUN([gl_STDIO_H],
/* For non-mingw systems, compilation will trivially succeed.
For mingw, compilation will succeed for older mingw (system
printf, "I64d") and fail for newer mingw (gnu printf, "lld"). */
- #if ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__) && \
+ #if (defined _WIN32 && ! defined __CYGWIN__) && \
(__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4))
extern char PRIdMAX_probe[sizeof PRIdMAX == sizeof "I64d" ? 1 : -1];
#endif
diff --git a/m4/stdlib_h.m4 b/m4/stdlib_h.m4
index 881704f6f3c..6121602aea3 100644
--- a/m4/stdlib_h.m4
+++ b/m4/stdlib_h.m4
@@ -1,4 +1,4 @@
-# stdlib_h.m4 serial 44
+# stdlib_h.m4 serial 48
dnl Copyright (C) 2007-2019 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -14,16 +14,19 @@ AC_DEFUN([gl_STDLIB_H],
dnl guaranteed by C89.
gl_WARN_ON_USE_PREPARE([[#include <stdlib.h>
#if HAVE_SYS_LOADAVG_H
+/* OpenIndiana has a bug: <sys/time.h> must be included before
+ <sys/loadavg.h>. */
+# include <sys/time.h>
# include <sys/loadavg.h>
#endif
#if HAVE_RANDOM_H
# include <random.h>
#endif
]], [_Exit atoll canonicalize_file_name getloadavg getsubopt grantpt
- initstate initstate_r mkdtemp mkostemp mkostemps mkstemp mkstemps
+ initstate initstate_r mbtowc mkdtemp mkostemp mkostemps mkstemp mkstemps
posix_openpt ptsname ptsname_r qsort_r random random_r reallocarray
realpath rpmatch secure_getenv setenv setstate setstate_r srandom
- srandom_r strtod strtoll strtoull unlockpt unsetenv])
+ srandom_r strtod strtold strtoll strtoull unlockpt unsetenv])
])
AC_DEFUN([gl_STDLIB_MODULE_INDICATOR],
@@ -65,6 +68,7 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS],
GNULIB_SECURE_GETENV=0; AC_SUBST([GNULIB_SECURE_GETENV])
GNULIB_SETENV=0; AC_SUBST([GNULIB_SETENV])
GNULIB_STRTOD=0; AC_SUBST([GNULIB_STRTOD])
+ GNULIB_STRTOLD=0; AC_SUBST([GNULIB_STRTOLD])
GNULIB_STRTOLL=0; AC_SUBST([GNULIB_STRTOLL])
GNULIB_STRTOULL=0; AC_SUBST([GNULIB_STRTOULL])
GNULIB_SYSTEM_POSIX=0; AC_SUBST([GNULIB_SYSTEM_POSIX])
@@ -78,7 +82,9 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS],
HAVE_DECL_GETLOADAVG=1; AC_SUBST([HAVE_DECL_GETLOADAVG])
HAVE_GETSUBOPT=1; AC_SUBST([HAVE_GETSUBOPT])
HAVE_GRANTPT=1; AC_SUBST([HAVE_GRANTPT])
+ HAVE_INITSTATE=1; AC_SUBST([HAVE_INITSTATE])
HAVE_DECL_INITSTATE=1; AC_SUBST([HAVE_DECL_INITSTATE])
+ HAVE_MBTOWC=1; AC_SUBST([HAVE_MBTOWC])
HAVE_MKDTEMP=1; AC_SUBST([HAVE_MKDTEMP])
HAVE_MKOSTEMP=1; AC_SUBST([HAVE_MKOSTEMP])
HAVE_MKOSTEMPS=1; AC_SUBST([HAVE_MKOSTEMPS])
@@ -97,8 +103,10 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS],
HAVE_SECURE_GETENV=1; AC_SUBST([HAVE_SECURE_GETENV])
HAVE_SETENV=1; AC_SUBST([HAVE_SETENV])
HAVE_DECL_SETENV=1; AC_SUBST([HAVE_DECL_SETENV])
+ HAVE_SETSTATE=1; AC_SUBST([HAVE_SETSTATE])
HAVE_DECL_SETSTATE=1; AC_SUBST([HAVE_DECL_SETSTATE])
HAVE_STRTOD=1; AC_SUBST([HAVE_STRTOD])
+ HAVE_STRTOLD=1; AC_SUBST([HAVE_STRTOLD])
HAVE_STRTOLL=1; AC_SUBST([HAVE_STRTOLL])
HAVE_STRTOULL=1; AC_SUBST([HAVE_STRTOULL])
HAVE_STRUCT_RANDOM_DATA=1; AC_SUBST([HAVE_STRUCT_RANDOM_DATA])
@@ -107,6 +115,7 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS],
HAVE_DECL_UNSETENV=1; AC_SUBST([HAVE_DECL_UNSETENV])
REPLACE_CALLOC=0; AC_SUBST([REPLACE_CALLOC])
REPLACE_CANONICALIZE_FILE_NAME=0; AC_SUBST([REPLACE_CANONICALIZE_FILE_NAME])
+ REPLACE_INITSTATE=0; AC_SUBST([REPLACE_INITSTATE])
REPLACE_MALLOC=0; AC_SUBST([REPLACE_MALLOC])
REPLACE_MBTOWC=0; AC_SUBST([REPLACE_MBTOWC])
REPLACE_MKSTEMP=0; AC_SUBST([REPLACE_MKSTEMP])
@@ -114,11 +123,14 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS],
REPLACE_PTSNAME_R=0; AC_SUBST([REPLACE_PTSNAME_R])
REPLACE_PUTENV=0; AC_SUBST([REPLACE_PUTENV])
REPLACE_QSORT_R=0; AC_SUBST([REPLACE_QSORT_R])
+ REPLACE_RANDOM=0; AC_SUBST([REPLACE_RANDOM])
REPLACE_RANDOM_R=0; AC_SUBST([REPLACE_RANDOM_R])
REPLACE_REALLOC=0; AC_SUBST([REPLACE_REALLOC])
REPLACE_REALPATH=0; AC_SUBST([REPLACE_REALPATH])
REPLACE_SETENV=0; AC_SUBST([REPLACE_SETENV])
+ REPLACE_SETSTATE=0; AC_SUBST([REPLACE_SETSTATE])
REPLACE_STRTOD=0; AC_SUBST([REPLACE_STRTOD])
+ REPLACE_STRTOLD=0; AC_SUBST([REPLACE_STRTOLD])
REPLACE_UNSETENV=0; AC_SUBST([REPLACE_UNSETENV])
REPLACE_WCTOMB=0; AC_SUBST([REPLACE_WCTOMB])
])
diff --git a/m4/strtoimax.m4 b/m4/strtoimax.m4
index b236e1b219e..9632279a183 100644
--- a/m4/strtoimax.m4
+++ b/m4/strtoimax.m4
@@ -1,6 +1,5 @@
# strtoimax.m4 serial 15
-dnl Copyright (C) 2002-2004, 2006, 2009-2019 Free Software Foundation,
-dnl Inc.
+dnl Copyright (C) 2002-2004, 2006, 2009-2019 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.
diff --git a/m4/strtoll.m4 b/m4/strtoll.m4
index add5156c468..3ba7e223b58 100644
--- a/m4/strtoll.m4
+++ b/m4/strtoll.m4
@@ -1,6 +1,5 @@
# strtoll.m4 serial 7
-dnl Copyright (C) 2002, 2004, 2006, 2008-2019 Free Software Foundation,
-dnl Inc.
+dnl Copyright (C) 2002, 2004, 2006, 2008-2019 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.
diff --git a/m4/symlink.m4 b/m4/symlink.m4
index 277614e0443..508e94dd410 100644
--- a/m4/symlink.m4
+++ b/m4/symlink.m4
@@ -1,4 +1,4 @@
-# serial 7
+# serial 8
# See if we need to provide symlink replacement.
dnl Copyright (C) 2009-2019 Free Software Foundation, Inc.
@@ -36,10 +36,12 @@ AC_DEFUN([gl_FUNC_SYMLINK],
]])],
[gl_cv_func_symlink_works=yes], [gl_cv_func_symlink_works=no],
[case "$host_os" in
- # Guess yes on glibc systems.
- *-gnu* | gnu*) gl_cv_func_symlink_works="guessing yes" ;;
- # If we don't know, assume the worst.
- *) gl_cv_func_symlink_works="guessing no" ;;
+ # Guess yes on Linux systems.
+ linux-* | linux) gl_cv_func_symlink_works="guessing yes" ;;
+ # Guess yes on glibc systems.
+ *-gnu* | gnu*) gl_cv_func_symlink_works="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_symlink_works="guessing no" ;;
esac
])
rm -f conftest.f conftest.link conftest.lnk2])
diff --git a/m4/time_h.m4 b/m4/time_h.m4
index 1e2990fc187..f08f29b35ea 100644
--- a/m4/time_h.m4
+++ b/m4/time_h.m4
@@ -1,7 +1,6 @@
# Configure a more-standard replacement for <time.h>.
-# Copyright (C) 2000-2001, 2003-2007, 2009-2019 Free Software
-# Foundation, Inc.
+# Copyright (C) 2000-2001, 2003-2007, 2009-2019 Free Software Foundation, Inc.
# serial 11
diff --git a/m4/time_rz.m4 b/m4/time_rz.m4
index 1f4bb4f4f0a..5564559c867 100644
--- a/m4/time_rz.m4
+++ b/m4/time_rz.m4
@@ -13,6 +13,39 @@ AC_DEFUN([gl_TIME_RZ],
AC_REQUIRE([gl_HEADER_TIME_H_DEFAULTS])
AC_REQUIRE([AC_STRUCT_TIMEZONE])
+ # Mac OS X 10.6 loops forever with some time_t values.
+ # See Bug#27706, Bug#27736, and
+ # https://lists.gnu.org/r/bug-gnulib/2017-07/msg00142.html
+ AC_CACHE_CHECK([whether localtime loops forever near extrema],
+ [gl_cv_func_localtime_infloop_bug],
+ [gl_cv_func_localtime_infloop_bug=no
+ AC_RUN_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#include <stdlib.h>
+ #include <string.h>
+ #include <unistd.h>
+ #include <time.h>
+ ]], [[
+ time_t t = -67768038400666600;
+ struct tm *tm;
+ char *tz = getenv ("TZ");
+ if (! (tz && strcmp (tz, "QQQ0") == 0))
+ return 0;
+ alarm (2);
+ tm = localtime (&t);
+ /* Use TM and *TM to suppress over-optimization. */
+ return tm && tm->tm_isdst;
+ ]])],
+ [(TZ=QQQ0 ./conftest$EXEEXT) >/dev/null 2>&1 ||
+ gl_cv_func_localtime_infloop_bug=yes],
+ [],
+ [gl_cv_func_localtime_infloop_bug="guessing no"])])
+ if test "$gl_cv_func_localtime_infloop_bug" = yes; then
+ AC_DEFINE([HAVE_LOCALTIME_INFLOOP_BUG], 1,
+ [Define if localtime-like functions can loop forever on
+ extreme arguments.])
+ fi
+
AC_CHECK_TYPES([timezone_t], [], [], [[#include <time.h>]])
if test "$ac_cv_type_timezone_t" = yes; then
HAVE_TIMEZONE_T=1
diff --git a/m4/timespec.m4 b/m4/timespec.m4
index cea97cde1ca..3db9943a74a 100644
--- a/m4/timespec.m4
+++ b/m4/timespec.m4
@@ -1,7 +1,6 @@
#serial 15
-# Copyright (C) 2000-2001, 2003-2007, 2009-2019 Free Software
-# Foundation, Inc.
+# Copyright (C) 2000-2001, 2003-2007, 2009-2019 Free Software Foundation, Inc.
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
diff --git a/m4/unistd_h.m4 b/m4/unistd_h.m4
index a7445a48393..a04055d2aa8 100644
--- a/m4/unistd_h.m4
+++ b/m4/unistd_h.m4
@@ -1,4 +1,4 @@
-# unistd_h.m4 serial 71
+# unistd_h.m4 serial 74
dnl Copyright (C) 2006-2019 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -37,13 +37,13 @@ AC_DEFUN([gl_UNISTD_H],
# include <fcntl.h>
# include <stdio.h>
# include <stdlib.h>
-# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+# if defined _WIN32 && ! defined __CYGWIN__
# include <io.h>
# endif
#endif
]], [chdir chown dup dup2 dup3 environ euidaccess faccessat fchdir fchownat
fdatasync fsync ftruncate getcwd getdomainname getdtablesize getgroups
- gethostname getlogin getlogin_r getpagesize
+ gethostname getlogin getlogin_r getpagesize getpass
getusershell setusershell endusershell
group_member isatty lchown link linkat lseek pipe pipe2 pread pwrite
readlink readlinkat rmdir sethostname sleep symlink symlinkat
@@ -83,6 +83,7 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS],
GNULIB_GETLOGIN=0; AC_SUBST([GNULIB_GETLOGIN])
GNULIB_GETLOGIN_R=0; AC_SUBST([GNULIB_GETLOGIN_R])
GNULIB_GETPAGESIZE=0; AC_SUBST([GNULIB_GETPAGESIZE])
+ GNULIB_GETPASS=0; AC_SUBST([GNULIB_GETPASS])
GNULIB_GETUSERSHELL=0; AC_SUBST([GNULIB_GETUSERSHELL])
GNULIB_GROUP_MEMBER=0; AC_SUBST([GNULIB_GROUP_MEMBER])
GNULIB_ISATTY=0; AC_SUBST([GNULIB_ISATTY])
@@ -126,6 +127,7 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS],
HAVE_GETHOSTNAME=1; AC_SUBST([HAVE_GETHOSTNAME])
HAVE_GETLOGIN=1; AC_SUBST([HAVE_GETLOGIN])
HAVE_GETPAGESIZE=1; AC_SUBST([HAVE_GETPAGESIZE])
+ HAVE_GETPASS=1; AC_SUBST([HAVE_GETPASS])
HAVE_GROUP_MEMBER=1; AC_SUBST([HAVE_GROUP_MEMBER])
HAVE_LCHOWN=1; AC_SUBST([HAVE_LCHOWN])
HAVE_LINK=1; AC_SUBST([HAVE_LINK])
@@ -140,7 +142,6 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS],
HAVE_SLEEP=1; AC_SUBST([HAVE_SLEEP])
HAVE_SYMLINK=1; AC_SUBST([HAVE_SYMLINK])
HAVE_SYMLINKAT=1; AC_SUBST([HAVE_SYMLINKAT])
- HAVE_TRUNCATE=1; AC_SUBST([HAVE_TRUNCATE])
HAVE_UNLINKAT=1; AC_SUBST([HAVE_UNLINKAT])
HAVE_USLEEP=1; AC_SUBST([HAVE_USLEEP])
HAVE_DECL_ENVIRON=1; AC_SUBST([HAVE_DECL_ENVIRON])
@@ -152,6 +153,7 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS],
HAVE_DECL_GETPAGESIZE=1; AC_SUBST([HAVE_DECL_GETPAGESIZE])
HAVE_DECL_GETUSERSHELL=1; AC_SUBST([HAVE_DECL_GETUSERSHELL])
HAVE_DECL_SETHOSTNAME=1; AC_SUBST([HAVE_DECL_SETHOSTNAME])
+ HAVE_DECL_TRUNCATE=1; AC_SUBST([HAVE_DECL_TRUNCATE])
HAVE_DECL_TTYNAME_R=1; AC_SUBST([HAVE_DECL_TTYNAME_R])
HAVE_OS_H=0; AC_SUBST([HAVE_OS_H])
HAVE_SYS_PARAM_H=0; AC_SUBST([HAVE_SYS_PARAM_H])
@@ -168,6 +170,7 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS],
REPLACE_GETLOGIN_R=0; AC_SUBST([REPLACE_GETLOGIN_R])
REPLACE_GETGROUPS=0; AC_SUBST([REPLACE_GETGROUPS])
REPLACE_GETPAGESIZE=0; AC_SUBST([REPLACE_GETPAGESIZE])
+ REPLACE_GETPASS=0; AC_SUBST([REPLACE_GETPASS])
REPLACE_ISATTY=0; AC_SUBST([REPLACE_ISATTY])
REPLACE_LCHOWN=0; AC_SUBST([REPLACE_LCHOWN])
REPLACE_LINK=0; AC_SUBST([REPLACE_LINK])
diff --git a/m4/utimens.m4 b/m4/utimens.m4
index 479fecc0b87..dda86b09d77 100644
--- a/m4/utimens.m4
+++ b/m4/utimens.m4
@@ -3,7 +3,7 @@ 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 serial 8
+dnl serial 9
AC_DEFUN([gl_UTIMENS],
[
@@ -31,10 +31,12 @@ AC_DEFUN([gl_UTIMENS],
[gl_cv_func_futimesat_works=yes],
[gl_cv_func_futimesat_works=no],
[case "$host_os" in
- # Guess yes on glibc systems.
- *-gnu*) gl_cv_func_futimesat_works="guessing yes" ;;
- # If we don't know, assume the worst.
- *) gl_cv_func_futimesat_works="guessing no" ;;
+ # Guess yes on Linux systems.
+ linux-* | linux) gl_cv_func_futimesat_works="guessing yes" ;;
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_futimesat_works="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_futimesat_works="guessing no" ;;
esac
])
rm -f conftest.file])
diff --git a/m4/utimes.m4 b/m4/utimes.m4
index 7209b6dd599..5806d8fbbb6 100644
--- a/m4/utimes.m4
+++ b/m4/utimes.m4
@@ -1,5 +1,5 @@
# Detect some bugs in glibc's implementation of utimes.
-# serial 5
+# serial 6
dnl Copyright (C) 2003-2005, 2009-2019 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
@@ -143,9 +143,11 @@ main ()
[gl_cv_func_working_utimes=yes],
[gl_cv_func_working_utimes=no],
[case "$host_os" in
- # Guess no on native Windows.
- mingw*) gl_cv_func_working_utimes="guessing no" ;;
- *) gl_cv_func_working_utimes="guessing no" ;;
+ # Guess yes on musl systems.
+ *-musl*) gl_cv_func_working_utimes="guessing yes" ;;
+ # Guess no on native Windows.
+ mingw*) gl_cv_func_working_utimes="guessing no" ;;
+ *) gl_cv_func_working_utimes="guessing no" ;;
esac
])
])
diff --git a/m4/vararrays.m4 b/m4/vararrays.m4
index 09a815036a2..98a4ef0be8f 100644
--- a/m4/vararrays.m4
+++ b/m4/vararrays.m4
@@ -18,44 +18,44 @@ AC_DEFUN([AC_C_VARARRAYS],
ac_cv_c_vararrays,
[AC_EGREP_CPP([defined],
[#ifdef __STDC_NO_VLA__
- defined
- #endif
+ defined
+ #endif
],
[ac_cv_c_vararrays='no: __STDC_NO_VLA__ is defined'],
[AC_COMPILE_IFELSE(
- [AC_LANG_PROGRAM(
- [[/* Test for VLA support. This test is partly inspired
- from examples in the C standard. Use at least two VLA
- functions to detect the GCC 3.4.3 bug described in:
- https://lists.gnu.org/r/bug-gnulib/2014-08/msg00014.html
- */
- #ifdef __STDC_NO_VLA__
- syntax error;
- #else
- extern int n;
- int B[100];
- int fvla (int m, int C[m][m]);
+ [AC_LANG_PROGRAM(
+ [[/* Test for VLA support. This test is partly inspired
+ from examples in the C standard. Use at least two VLA
+ functions to detect the GCC 3.4.3 bug described in:
+ https://lists.gnu.org/r/bug-gnulib/2014-08/msg00014.html
+ */
+ #ifdef __STDC_NO_VLA__
+ syntax error;
+ #else
+ extern int n;
+ int B[100];
+ int fvla (int m, int C[m][m]);
- int
- simple (int count, int all[static count])
- {
- return all[count - 1];
- }
+ int
+ simple (int count, int all[static count])
+ {
+ return all[count - 1];
+ }
- int
- fvla (int m, int C[m][m])
- {
- typedef int VLA[m][m];
- VLA x;
- int D[m];
- static int (*q)[m] = &B;
- int (*s)[n] = q;
- return C && &x[0][0] == &D[0] && &D[0] == s[0];
- }
- #endif
- ]])],
- [ac_cv_c_vararrays=yes],
- [ac_cv_c_vararrays=no])])])
+ int
+ fvla (int m, int C[m][m])
+ {
+ typedef int VLA[m][m];
+ VLA x;
+ int D[m];
+ static int (*q)[m] = &B;
+ int (*s)[n] = q;
+ return C && &x[0][0] == &D[0] && &D[0] == s[0];
+ }
+ #endif
+ ]])],
+ [ac_cv_c_vararrays=yes],
+ [ac_cv_c_vararrays=no])])])
if test "$ac_cv_c_vararrays" = yes; then
dnl This is for compatibility with Autoconf 2.61-2.69.
AC_DEFINE([HAVE_C_VARARRAYS], 1,
diff --git a/m4/warnings.m4 b/m4/warnings.m4
index dadcea29c16..235cac6171c 100644
--- a/m4/warnings.m4
+++ b/m4/warnings.m4
@@ -1,4 +1,4 @@
-# warnings.m4 serial 13
+# warnings.m4 serial 14
dnl Copyright (C) 2008-2019 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -76,6 +76,15 @@ m4_defun([gl_UNKNOWN_WARNINGS_ARE_ERRORS(C++)],
AC_LANG_POP([C++])
])
+# Specialization for _AC_LANG = Objective C. This macro can be AC_REQUIREd.
+# Use of m4_defun rather than AC_DEFUN works around a bug in autoconf < 2.63b.
+m4_defun([gl_UNKNOWN_WARNINGS_ARE_ERRORS(Objective C)],
+[
+ AC_LANG_PUSH([Objective C])
+ gl_UNKNOWN_WARNINGS_ARE_ERRORS_IMPL
+ AC_LANG_POP([Objective C])
+])
+
AC_DEFUN([gl_UNKNOWN_WARNINGS_ARE_ERRORS_IMPL],
[gl_COMPILER_OPTION_IF([-Werror -Wunknown-warning-option],
[gl_unknown_warnings_are_errors='-Wunknown-warning-option -Werror'],
diff --git a/make-dist b/make-dist
index e8aca553343..821895a0053 100755
--- a/make-dist
+++ b/make-dist
@@ -51,6 +51,7 @@ clean_up=no
make_tar=no
default_gzip=gzip
newer=""
+with_info=yes
with_tests=no
changelog=yes
verbose=no
@@ -77,6 +78,11 @@ while [ $# -gt 0 ]; do
"--no-changelog" )
changelog=no
;;
+ ## This options tells make-dist to skip the info files. This can
+ ## be useful for creating a tarball purely for test purposes.
+ "--no-info" )
+ with_info=no
+ ;;
## This option tells make-dist to make the distribution normally, then
## remove all files older than the given timestamp file. This is useful
## for creating incremental or patch distributions.
@@ -124,6 +130,7 @@ while [ $# -gt 0 ]; do
echo " --no-check don't check for bad file names etc."
echo " --no-update don't recompile or do analogous things"
echo " --no-changelog don't generate the top-level ChangeLog"
+ echo " --no-info don't include info files"
echo " --snapshot same as --clean-up --no-update --tar --no-check"
echo " --tar make a tar file"
echo " --tests include the test/ directory"
@@ -215,18 +222,23 @@ if [ $check = yes ]; then
error=no
+ temp_el=/tmp/make-dist.tmp.$$
+ temp_elc=$temp_el.1
+ temp_elelc=$temp_el.2
+ temp_elcel=$temp_el.3
+
ls -1 lisp/[a-zA-Z]*.el lisp/[a-z]*/[a-zA-Z0-9]*.el \
lisp/[a-z]*/[a-z]*/[a-zA-Z0-9]*.el \
- lisp/[a-z]*/[a-z]*/[a-z]*/[a-zA-Z0-9]*.el > /tmp/el
+ lisp/[a-z]*/[a-z]*/[a-z]*/[a-zA-Z0-9]*.el > $temp_el
ls -1 lisp/[a-zA-Z]*.elc lisp/[a-z]*/[a-zA-Z0-9]*.elc \
lisp/[a-z]*/[a-z]*/[a-zA-Z0-9]*.elc \
- lisp/[a-z]*/[a-z]*/[a-z]*/[a-zA-Z0-9]*.elc > /tmp/elc
+ lisp/[a-z]*/[a-z]*/[a-z]*/[a-zA-Z0-9]*.elc > $temp_elc
## Check for .elc files with no corresponding .el file.
- sed 's/\.el$/.elc/' /tmp/el > /tmp/elelc
+ sed 's/\.el$/.elc/' $temp_el > $temp_elelc
- bogosities=`comm -13 /tmp/elelc /tmp/elc`
+ bogosities=`comm -13 $temp_elelc $temp_elc`
if [ x"${bogosities}" != x"" ]; then
error=yes
echo "The following .elc files have no corresponding .el files:"
@@ -234,15 +246,15 @@ if [ $check = yes ]; then
fi
### Check for .el files with no corresponding .elc file.
- sed 's/\.elc$/.el/' /tmp/elc > /tmp/elcel
- losers=`comm -23 /tmp/el /tmp/elcel`
+ sed 's/\.elc$/.el/' $temp_elc > $temp_elcel
+ losers=`comm -23 $temp_el $temp_elcel`
bogosities=
while read elc; do
el=`echo $elc | sed 's/c$//'`
[ -r $el ] || continue
[ $elc -nt $el ] || bogosities="$bogosities $elc"
- done < /tmp/elc
+ done < $temp_elc
if [ x"${bogosities}" != x"" ]; then
error=yes
@@ -250,11 +262,11 @@ if [ $check = yes ]; then
echo "${bogosities}"
fi
- rm -f /tmp/el /tmp/elc /tmp/elcel /tmp/elelc
+ rm -f $temp_el*
bogosities=
for file in $losers; do
- grep -q "no-byte-compile: t" $file && continue
+ grep -q "^;.*no-byte-compile: t" $file && continue
case $file in
site-init.el | site-load.el | site-start.el | default.el) continue ;;
esac
@@ -271,7 +283,7 @@ if [ $check = yes ]; then
## This is only a crude check, eg it does not handle .info
## files with multiple .texi source files.
- find doc -name '*.texi' > /tmp/el
+ find doc -name '*.texi' > $temp_el
bogosities=
while read texi; do
@@ -280,9 +292,9 @@ if [ $check = yes ]; then
info=info/$info
[ -r $info ] || continue
[ $info -nt $texi ] || bogosities="$bogosities $info"
- done < /tmp/el
+ done < $temp_el
- rm -f /tmp/el
+ rm -f $temp_el
if [ x"${bogosities}" != x"" ]; then
error=yes
@@ -292,7 +304,7 @@ if [ $check = yes ]; then
## This exits with non-zero status if any .info files need
## rebuilding.
- if [ -r Makefile ]; then
+ if [ -r Makefile ] && [ "$with_info" = "yes" ]; then
echo "Checking to see if info files are up-to-date..."
make --question info || error=yes
fi
@@ -327,8 +339,10 @@ if [ $update = yes ]; then
echo "Running autoreconf"
autoreconf -i -I m4 || { x=$?; echo Autoreconf FAILED! >&2; exit $x; }
- echo "Updating Info files"
- make info
+ if [ "$make_info" = yes ] ; then
+ echo "Updating Info files"
+ make info
+ fi
echo "Updating finder, custom and autoload data"
(cd lisp && make updates EMACS="$EMACS")
@@ -340,11 +354,61 @@ if [ $update = yes ]; then
$EMACS -batch -f batch-byte-recompile-directory lisp
fi # $update = yes
+if [ "$changelog" = yes ] && [ -r .git ]; then
+ top_level_ChangeLog=ChangeLog
+else
+ top_level_ChangeLog=
+fi
+
+# Files to distribute that might not be under version control.
+# Don't distribute site-init.el, site-load.el, or default.el.
+possibly_non_vc_files="
+ $top_level_ChangeLog
+ MANIFEST aclocal.m4 configure
+ admin/charsets/jisx2131-filter
+ src/config.in src/emacs-module.h
+ src/fingerprint.c
+"$(
+ find admin doc etc lisp \
+ \( -name '*.el' -o -name '*.elc' -o -name '*.map' -o -name '*.stamp' \
+ -o -name '*.texi' -o -name '*.tex' -o -name '*.txt' \) \
+ ! -name 'site-init*' ! -name 'site-load*' ! -name 'default*'
+) || exit
+
+if [ $with_info = yes ]; then
+ info_files="info/dir $(echo info/*.info)" || exit
+else
+ info_files=
+fi
+
echo "Creating staging directory: '${tempparent}'"
-mkdir ${tempparent}
+mkdir ${tempparent} || exit
tempdir="${tempparent}/${emacsname}"
+manifest=MANIFEST
+
+[ -f $manifest ] || manifest=${tempparent}/MANIFEST
+
+# If Git is in use update the file MANIFEST, which can substitute for
+# 'git ls-files' later (e.g., after extraction from a tarball).
+# Otherwise, rely on the existing MANIFEST, which should be maintained some
+# other way when adding or deleting a distributed file while not using Git.
+# TODO: maybe this should ignore $update, and always update MANIFEST
+# if .git is present.
+if ( [ $update = yes ] || [ ! -f $manifest ] ) && [ -r .git ]; then
+ echo "Updating $manifest"
+ if [ $with_tests = yes ]; then
+ git ls-files > $manifest
+ else
+ git ls-files | grep -v '^test' >$manifest
+ fi || exit
+ printf '%s\n' $possibly_non_vc_files $info_files >>$manifest || exit
+ sort -u -o $manifest $manifest || exit
+fi
+
+<$manifest || exit
+
### This trap ensures that the staging directory will be cleaned up even
### when the script is interrupted in mid-career.
if [ "${clean_up}" = yes ]; then
@@ -352,272 +416,66 @@ if [ "${clean_up}" = yes ]; then
fi
echo "Creating top directory: '${tempdir}'"
-mkdir ${tempdir}
+if [ $verbose = yes ] && (mkdir --verbose ${tempdir}) >/dev/null 2>&1; then
+ mkdir_verbose='mkdir --verbose'
+else
+ mkdir $tempdir || exit
+ mkdir_verbose=mkdir
+fi
+
+# file_to_skip is normally empty to link every file,
+# but it can be 'ChangeLog' if we do not want to link the
+# top-level ChangeLog.
+file_to_skip=
if [ "$changelog" = yes ]; then
if test -r .git; then
## When making a release or pretest the ChangeLog should already
## have been created and edited as needed. Don't ignore it.
- if test -r ChangeLog; then
+ if [ -r ChangeLog ] && [ ! -L ChangeLog ]; then
echo "Using existing top-level ChangeLog"
else
echo "Making top-level ChangeLog"
make ChangeLog CHANGELOG=${tempdir}/ChangeLog || \
{ x=$?; echo "make ChangeLog FAILED (try --no-changelog?)" >&2; exit $x; }
+ file_to_skip=ChangeLog
fi
else
echo "No repository, so omitting top-level ChangeLog"
fi
fi
-### We copy in the top-level files before creating the subdirectories in
-### hopes that this will make the top-level files appear first in the
-### tar file; this means that people can start reading the INSTALL and
-### README while the rest of the tar file is still unpacking. Whoopee.
-echo "Making links to top-level files"
-ln INSTALL README BUGS ${tempdir}
-ln ChangeLog.*[0-9] Makefile.in autogen.sh configure configure.ac ${tempdir}
-ln config.bat make-dist .dir-locals.el ${tempdir}
-ln aclocal.m4 CONTRIBUTE ChangeLog ${tempdir}
-
echo "Creating subdirectories"
-for subdir in site-lisp \
- leim leim/CXTERM-DIC leim/MISC-DIC leim/SKK-DIC \
- build-aux \
- src src/bitmaps lib lib-src oldXMenu lwlib \
- nt nt/inc nt/inc/sys nt/inc/arpa nt/inc/netinet nt/icons \
- `find etc lisp admin test -type d` \
- doc doc/emacs doc/misc doc/man doc/lispref doc/lispintro \
- info m4 modules msdos \
- nextstep nextstep/templates \
- nextstep/Cocoa nextstep/Cocoa/Emacs.base \
- nextstep/Cocoa/Emacs.base/Contents \
- nextstep/Cocoa/Emacs.base/Contents/Resources \
- nextstep/GNUstep \
- nextstep/GNUstep/Emacs.base \
- nextstep/GNUstep/Emacs.base/Resources
-do
-
- if [ "$with_tests" != "yes" ]; then
- case $subdir in
- test*) continue ;;
- esac
- fi
-
- ## site-lisp for in-place installs (?).
- [ "$subdir" = "site-lisp" ] || [ -d "$subdir" ] || \
- echo "WARNING: $subdir not found, making anyway"
- [ "$verbose" = "yes" ] && echo " ${tempdir}/${subdir}"
- mkdir ${tempdir}/${subdir}
-done
-
-echo "Making links to 'lisp' and its subdirectories"
-files=`find lisp \( -name '*.el' -o -name '*.elc' -o -name 'ChangeLog*' \
- -o -name 'README' \)`
-
-### Don't distribute site-init.el, site-load.el, or default.el.
-for file in lisp/Makefile.in $files; do
+MANIFEST_subdir_sed='
+ $a\
+'$tempdir'/info\
+'$tempdir'/site-lisp
+ s,[^/]*$,,
+ s,/$,,
+ /^$/d
+ s,^,'$tempdir'/,
+'
+tempsubdirs=$(sed "$MANIFEST_subdir_sed" $manifest | sort -u)
+$mkdir_verbose -p $tempsubdirs || exit
+
+echo "Making links to files"
+while read file; do
case $file in
- */site-init*|*/site-load*|*/default*) continue ;;
- esac
- ln $file $tempdir/$file
-done
-
-echo "Making links to 'leim' and its subdirectories"
-(cd leim
- ln ChangeLog.*[0-9] README ../${tempdir}/leim
- ln CXTERM-DIC/README CXTERM-DIC/*.tit ../${tempdir}/leim/CXTERM-DIC
- ln SKK-DIC/README SKK-DIC/SKK-JISYO.L ../${tempdir}/leim/SKK-DIC
- ln MISC-DIC/README MISC-DIC/*.* ../${tempdir}/leim/MISC-DIC
- ln Makefile.in ../${tempdir}/leim/Makefile.in
- ln leim-ext.el ../${tempdir}/leim/leim-ext.el)
-
-## FIXME Can we not just use the "find -type f" method for this one?
-echo "Making links to 'build-aux'"
-(cd build-aux
- ln config.guess config.sub msys-to-w32 ../${tempdir}/build-aux
- ln gitlog-to-changelog gitlog-to-emacslog ../${tempdir}/build-aux
- ln install-sh move-if-change ../${tempdir}/build-aux
- ln update-copyright update-subdirs ../${tempdir}/build-aux
- ln dir_top make-info-dir ../${tempdir}/build-aux)
-
-echo "Making links to 'src'"
-### Don't distribute the configured versions of
-### config.in, paths.in, buildobj.h, or Makefile.in.
-(cd src
- echo " (It is ok if ln fails in some cases.)"
- ln [a-zA-Z]*.[chm] ../${tempdir}/src
- ln [a-zA-Z]*.in ../${tempdir}/src
- ln deps.mk ../${tempdir}/src
- ln README ChangeLog.*[0-9] ../${tempdir}/src
- ln .gdbinit .dbxinit ../${tempdir}/src
- cd ../${tempdir}/src
- rm -f globals.h config.h epaths.h Makefile buildobj.h)
-
-echo "Making links to 'src/bitmaps'"
-(cd src/bitmaps
- ln README *.xbm ../../${tempdir}/src/bitmaps)
-
-echo "Making links to 'lib'"
-(cd lib
- ln [a-zA-Z_]*.[ch] ../${tempdir}/lib
- ln gnulib.mk.in Makefile.in ../${tempdir}/lib
- cd ../${tempdir}/lib
- script='/[*]/d; s/\.in\.h$/.h/'
- rm -f `ls *.in.h | sed "$script"`)
-
-echo "Making links to 'lib-src'"
-(cd lib-src
- ln [a-zA-Z]*.[ch] ../${tempdir}/lib-src
- ln ChangeLog.*[0-9] Makefile.in README ../${tempdir}/lib-src
- ln rcs2log ../${tempdir}/lib-src)
-
-echo "Making links to 'm4'"
-(cd m4
- ln *.m4 ../${tempdir}/m4)
-
-echo "Making links to 'modules'"
-(cd modules
- ln *.py ../${tempdir}/modules
-)
-
-echo "Making links to 'nt'"
-(cd nt
- ln emacs-x86.manifest emacs-x64.manifest ../${tempdir}/nt
- ln [a-z]*.bat [a-z]*.[ch] ../${tempdir}/nt
- ln *.in gnulib-cfg.mk ../${tempdir}/nt
- ln mingw-cfg.site epaths.nt INSTALL.W64 ../${tempdir}/nt
- ln ChangeLog.*[0-9] INSTALL README README.W32 ../${tempdir}/nt)
-
-echo "Making links to 'nt/inc' and its subdirectories"
-for f in `find nt/inc -type f -name '[a-z]*.h'`; do
- ln $f $tempdir/$f
-done
-
-echo "Making links to 'nt/icons'"
-(cd nt/icons
- ln README [a-z]*.ico ../../${tempdir}/nt/icons
- ln [a-z]*.cur ../../${tempdir}/nt/icons)
-
-echo "Making links to 'msdos'"
-(cd msdos
- ln ChangeLog.*[0-9] INSTALL README emacs.ico emacs.pif ../${tempdir}/msdos
- ln depfiles.bat inttypes.h ../${tempdir}/msdos
- ln mainmake.v2 sed*.inp ../${tempdir}/msdos)
-
-echo "Making links to 'nextstep'"
-(cd nextstep
- ln ChangeLog.*[0-9] README INSTALL Makefile.in ../${tempdir}/nextstep)
-
-echo "Making links to 'nextstep/templates'"
-(cd nextstep/templates
- ln Emacs.desktop.in Info-gnustep.plist.in Info.plist.in InfoPlist.strings.in ../../${tempdir}/nextstep/templates)
-
-echo "Making links to 'nextstep/Cocoa/Emacs.base/Contents'"
-(cd nextstep/Cocoa/Emacs.base/Contents
- ln PkgInfo ../../../../${tempdir}/nextstep/Cocoa/Emacs.base/Contents)
-
-echo "Making links to 'nextstep/Cocoa/Emacs.base/Contents/Resources'"
-(cd nextstep/Cocoa/Emacs.base/Contents/Resources
- ln Credits.html *.icns ../../../../../${tempdir}/nextstep/Cocoa/Emacs.base/Contents/Resources)
-
-echo "Making links to 'nextstep/GNUstep/Emacs.base/Resources'"
-(cd nextstep/GNUstep/Emacs.base/Resources
- ln README emacs.tiff ../../../../${tempdir}/nextstep/GNUstep/Emacs.base/Resources )
-
-echo "Making links to 'oldXMenu'"
-(cd oldXMenu
- ln *.[ch] *.in *.mk ../${tempdir}/oldXMenu
- ln README ChangeLog.*[0-9] ../${tempdir}/oldXMenu)
-
-echo "Making links to 'lwlib'"
-(cd lwlib
- ln *.[ch] *.in *.mk ../${tempdir}/lwlib
- ln README ChangeLog.*[0-9] ../${tempdir}/lwlib)
-
-## It is important to distribute admin/ because it contains sources
-## for generated lisp/international/uni-*.el files.
-echo "Making links to 'admin' and its subdirectories"
-for f in `find admin -type f`; do
- case $f in
- */Makefile) [ -f $f.in ] && continue ;;
+ MANIFEST) ln $manifest $tempdir/MANIFEST || exit ;;
+ $file_to_skip) continue ;;
+ *) ln $file $tempdir/$file || exit ;;
esac
- ln $f $tempdir/$f
-done
-
-if [ "$with_tests" = "yes" ]; then
- echo "Making links to 'test' and its subdirectories"
- for f in `find test -type f ! -name '*.log' ! -name a.out \
- ! -name '*.so' ! -name '*.dll' ! -name '*.o'
- `; do
- case $f in
- */Makefile) [ -f $f.in ] && continue ;;
- esac
- ln $f $tempdir/$f
- done
-fi
-
-echo "Making links to 'etc' and its subdirectories"
-for f in `find etc -type f`; do
- case $f in
- etc/DOC*|etc/*.pyc) continue ;;
- ## Arguably we should not exclude *.ps.
- etc/refcards/*.aux|etc/refcards/*.dvi|etc/refcards/*.log|etc/refcards/*.ps)
- continue ;;
- esac
- ln $f $tempdir/$f
-done
-
-echo "Making links to 'info'"
-ln `find info -type f -print` ${tempdir}/info
-
-echo "Making links to 'doc/emacs'"
-(cd doc/emacs
- ln *.texi *.in ChangeLog.*[0-9] ../../${tempdir}/doc/emacs)
-
-echo "Making links to 'doc/misc'"
-(cd doc/misc
- ln *.texi *.tex *.in gnus-news.el ChangeLog.*[0-9] \
- ../../${tempdir}/doc/misc)
-
-echo "Making links to 'doc/lispref'"
-(cd doc/lispref
- ln *.texi *.in README ChangeLog.*[0-9] ../../${tempdir}/doc/lispref
- ln spellfile ../../${tempdir}/doc/lispref
- ln two-volume.make two-volume-cross-refs.txt ../../${tempdir}/doc/lispref)
-
-echo "Making links to 'doc/lispintro'"
-(cd doc/lispintro
- ln *.texi *.in *.eps *.pdf ../../${tempdir}/doc/lispintro
- ln README ChangeLog.*[0-9] ../../${tempdir}/doc/lispintro
- cd ../../${tempdir}/doc/lispintro)
-
-echo "Making links to 'doc/man'"
-(cd doc/man
- ln *.*[0-9] *.in ../../${tempdir}/doc/man
- cd ../../${tempdir}/doc/man
- rm -f emacs.1)
-
-### It would be nice if they could all be symlinks to top-level copy, but
-### you're not supposed to have any symlinks in distribution tar files.
-echo "Making sure copying notices are all copies of 'COPYING'"
-for subdir in . etc leim lib lib-src lisp lwlib msdos nt src; do
- rm -f ${tempdir}/${subdir}/COPYING
- cp COPYING ${tempdir}/${subdir}
-done
+done <$manifest
if [ "${newer}" ]; then
printf '%s\n' "Removing files older than $newer"
## We remove .elc files unconditionally, on the theory that anyone picking
## up an incremental distribution already has a running Emacs to byte-compile
## them with.
- find ${tempparent} \( -name '*.elc' -o ! -newer ${newer} \) -exec rm -f {} \;
+ find ${tempdir} \( -name '*.elc' -o ! -newer ${newer} \) \
+ -exec rm -f {} \; || exit
fi
-## Don't distribute backups, autosaves, etc.
-echo "Removing unwanted files"
-find ${tempparent} \( -name '*~' -o -name '#*#' -o -name '.*ignore' -o -name '=*' -o -name 'TAGS' \) -exec rm -f {} \;
-
if [ "${make_tar}" = yes ]; then
echo "Looking for $default_gzip"
found=0
@@ -635,21 +493,36 @@ if [ "${make_tar}" = yes ]; then
case "${default_gzip}" in
bzip2) gzip_extension=.bz2 ;;
xz) gzip_extension=.xz ;;
- gzip) gzip_extension=.gz ; default_gzip="gzip --best";;
+ gzip) gzip_extension=.gz ; default_gzip="gzip --best --no-name";;
*) gzip_extension= ;;
esac
echo "Creating tar file"
- taropt=
- [ "$verbose" = "yes" ] && taropt=v
-
- (cd ${tempparent} ; tar c${taropt}f - ${emacsname} ) \
- | ${default_gzip} \
- > ${emacsname}.tar${gzip_extension}
+ taropt='--numeric-owner --owner=0 --group=0 --mode=go+u,go-w'
+ tar --sort=name -cf /dev/null $tempdir/src/lisp.h 2>/dev/null &&
+ taropt="$taropt --sort=name"
+ [ "$verbose" = "yes" ] && taropt="$taropt --verbose"
+
+ (cd $tempparent &&
+ case $default_gzip in
+ cat) tar $taropt -cf - $emacsname;;
+ *) if tar $taropt -cf /dev/null --use-compress-program="$default_gzip" \
+ $emacsname/src/lisp.h > /dev/null 2>&1
+ then
+ tar $taropt -cf - --use-compress-program="$default_gzip" $emacsname
+ else
+ tar $taropt -cf $emacsname.tar $emacsname &&
+ $default_gzip <$emacsname.tar
+ fi;;
+ esac
+ ) >$emacsname.tar$gzip_extension || exit
fi
+## Why are we deleting the staging directory if clean_up is no?
if [ "${clean_up}" != yes ]; then
- (cd ${tempparent}; mv ${emacsname} ..)
+ (cd ${tempparent} && mv ${emacsname} ..) &&
rm -rf ${tempparent}
fi
-### make-dist ends here
+# Local Variables:
+# sh-basic-offset: 2
+# End:
diff --git a/msdos/sed2v2.inp b/msdos/sed2v2.inp
index fdfec3059ec..39cffdb6f3b 100644
--- a/msdos/sed2v2.inp
+++ b/msdos/sed2v2.inp
@@ -66,7 +66,7 @@
/^#undef PACKAGE_NAME/s/^.*$/#define PACKAGE_NAME ""/
/^#undef PACKAGE_STRING/s/^.*$/#define PACKAGE_STRING ""/
/^#undef PACKAGE_TARNAME/s/^.*$/#define PACKAGE_TARNAME ""/
-/^#undef PACKAGE_VERSION/s/^.*$/#define PACKAGE_VERSION "26.1.92"/
+/^#undef PACKAGE_VERSION/s/^.*$/#define PACKAGE_VERSION "27.0.50"/
/^#undef SYSTEM_TYPE/s/^.*$/#define SYSTEM_TYPE "ms-dos"/
/^#undef HAVE_DECL_GETENV/s/^.*$/#define HAVE_DECL_GETENV 1/
/^#undef SYS_SIGLIST_DECLARED/s/^.*$/#define SYS_SIGLIST_DECLARED 1/
diff --git a/nextstep/Makefile.in b/nextstep/Makefile.in
index e19845cc96b..08e2e510d30 100644
--- a/nextstep/Makefile.in
+++ b/nextstep/Makefile.in
@@ -44,7 +44,7 @@ ns_check_file = @ns_appdir@/@ns_check_file@
.PHONY: all
-all: ${ns_appdir} ${ns_appbindir}/Emacs
+all: ${ns_appdir} ${ns_appbindir}/Emacs ${ns_appbindir}/Emacs.pdmp
${ns_check_file} ${ns_appdir}: ${srcdir}/${ns_appsrc} ${ns_appsrc}
rm -rf ${ns_appdir}
@@ -63,6 +63,10 @@ ${ns_appbindir}/Emacs: ${ns_appdir} ${ns_check_file} ../src/emacs${EXEEXT}
${MKDIR_P} ${ns_appbindir}
cp -f ../src/emacs${EXEEXT} $@
+${ns_appbindir}/Emacs.pdmp: ${ns_appdir} ${ns_check_file} ../src/emacs${EXEEXT}.pdmp
+ ${MKDIR_P} ${ns_appbindir}
+ cp -f ../src/emacs${EXEEXT}.pdmp $@
+
.PHONY: FORCE
../src/emacs${EXEEXT}: FORCE
@@ -76,11 +80,12 @@ links: ../src/emacs${EXEEXT}
for d in $(shell cd ${srcdir}/${ns_appsrc}; find . -type d); do ${MKDIR_P} ${ns_appdir}/$$d; done
for f in $(shell cd ${srcdir}/${ns_appsrc}; find . -type f); do ln -s $(shell cd ${srcdir}; pwd -P)/${ns_appsrc}/$$f ${ns_appdir}/$$f; done
for d in $(shell cd ${ns_appsrc}; find . -type d); do ${MKDIR_P} ${ns_appdir}/$$d; done
- for f in $(shell cd ${ns_appsrc}; find . -type f); do ln -s $(shell cd ${ns_appsrc}; pwd -P)/$$f ${ns_appdir}/$$f; done
+ for f in $(shell cd ${ns_appsrc}; find . -type f); do rm -f ${ns_appdir}/$$f; ln -s $(shell cd ${ns_appsrc}; pwd -P)/$$f ${ns_appdir}/$$f; done
ln -s $(top_srcdir_abs)/lisp ${ns_appdir}/Contents/Resources
ln -s $(top_srcdir_abs)/info ${ns_appdir}/Contents/Resources
${MKDIR_P} ${ns_appbindir}
ln -s $(abs_top_builddir)/src/emacs${EXEEXT} ${ns_appbindir}/Emacs
+ ln -s $(abs_top_builddir)/src/emacs${EXEEXT}.pdmp ${ns_appbindir}/Emacs.pdmp
ln -s $(abs_top_builddir)/lib-src ${ns_appbindir}/bin
ln -s $(abs_top_builddir)/lib-src ${ns_appbindir}/libexec
${MKDIR_P} ${ns_appdir}/Contents/Resources/etc
diff --git a/nt/INSTALL b/nt/INSTALL
index d82df6c970e..3e617f27057 100644
--- a/nt/INSTALL
+++ b/nt/INSTALL
@@ -808,6 +808,13 @@ build will run on Windows 9X and newer systems).
Prebuilt binaries of lcms2 DLL (for 32-bit builds of Emacs) are
available from the ezwinports site and from the MSYS2 project.
+* Optional support for JSON
+
+ Emacs can provide built-in support for JSON parsing and
+ serialization using the libjansson library. Prebuilt binaries of
+ the libjansson DLL (for 32-bit builds of Emacs) are available from
+ the ezwinports site and from the MSYS2 project.
+
This file is part of GNU Emacs.
diff --git a/nt/INSTALL.W64 b/nt/INSTALL.W64
index b63f15079b7..994c567c34b 100644
--- a/nt/INSTALL.W64
+++ b/nt/INSTALL.W64
@@ -52,6 +52,7 @@ packages (you can copy and paste it into the shell with Shift + Insert):
mingw-w64-x86_64-libjpeg-turbo \
mingw-w64-x86_64-librsvg \
mingw-w64-x86_64-lcms2 \
+ mingw-w64-x86_64-jansson \
mingw-w64-x86_64-libxml2 \
mingw-w64-x86_64-gnutls \
mingw-w64-x86_64-zlib
diff --git a/nt/README.W32 b/nt/README.W32
index e22b5820d32..0fac1c32988 100644
--- a/nt/README.W32
+++ b/nt/README.W32
@@ -1,7 +1,7 @@
Copyright (C) 2001-2019 Free Software Foundation, Inc.
See the end of the file for license conditions.
- Emacs version 26.1.92 for MS-Windows
+ Emacs version 27.0.50 for MS-Windows
This README file describes how to set up and run a precompiled
distribution of the latest version of GNU Emacs for MS-Windows. You
diff --git a/nt/gnulib-cfg.mk b/nt/gnulib-cfg.mk
index 2e5923a0120..09cd5822578 100644
--- a/nt/gnulib-cfg.mk
+++ b/nt/gnulib-cfg.mk
@@ -49,6 +49,7 @@ OMIT_GNULIB_MODULE_dirent = true
OMIT_GNULIB_MODULE_dirfd = true
OMIT_GNULIB_MODULE_fcntl = true
OMIT_GNULIB_MODULE_fcntl-h = true
+OMIT_GNULIB_MODULE_fsusage = true
OMIT_GNULIB_MODULE_inttypes-incomplete = true
OMIT_GNULIB_MODULE_open = true
OMIT_GNULIB_MODULE_pipe2 = true
diff --git a/nt/inc/langinfo.h b/nt/inc/langinfo.h
index fc69068969e..6c4959ecb54 100644
--- a/nt/inc/langinfo.h
+++ b/nt/inc/langinfo.h
@@ -27,6 +27,7 @@ enum {
DAY_1, DAY_2, DAY_3, DAY_4, DAY_5, DAY_6, DAY_7,
MON_1, MON_2, MON_3, MON_4, MON_5, MON_6, MON_7, MON_8, MON_9, MON_10,
MON_11, MON_12,
+ _NL_PAPER_WIDTH, _NL_PAPER_HEIGHT,
/* Number of enumerated values. */
_NL_NUM
@@ -55,6 +56,9 @@ enum {
#define MON_11 MON_11
#define MON_12 MON_12
+#define _NL_PAPER_WIDTH _NL_PAPER_WIDTH
+#define _NL_PAPER_HEIGHT _NL_PAPER_HEIGHT
+
extern char *nl_langinfo (nl_item);
#endif /* _LANGINFO_H */
diff --git a/nt/inc/ms-w32.h b/nt/inc/ms-w32.h
index d169b40bee1..7de94ca0153 100644
--- a/nt/inc/ms-w32.h
+++ b/nt/inc/ms-w32.h
@@ -34,6 +34,11 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
# ifdef __MINGW64_VERSION_MAJOR
# define MINGW_W64
# endif
+# if defined __MINGW32_VERSION && __MINGW32_VERSION >= 5001000L
+/* Avoid warnings about gettimeofday being deprecated. */
+# undef __POSIX_2008_DEPRECATED
+# define __POSIX_2008_DEPRECATED
+# endif
#endif
/* #undef const */
@@ -306,7 +311,7 @@ extern int execve (const char *, char * const *, char * const *);
#else
extern intptr_t execve (const char *, char * const *, char * const *);
#endif
-#define fdatasync _commit
+#define tcdrain _commit
#define fdopen _fdopen
#define fsync _commit
#define ftruncate _chsize
diff --git a/nt/mingw-cfg.site b/nt/mingw-cfg.site
index d9a824008cb..4df20494921 100644
--- a/nt/mingw-cfg.site
+++ b/nt/mingw-cfg.site
@@ -109,6 +109,7 @@ gl_cv_func_pthread_sigmask_return_works=yes
gl_cv_func_pthread_sigmask_unblock_works="not relevant"
# Implemented in w32proc.c
emacs_cv_langinfo_codeset=yes
+emacs_cv_langinfo__nl_paper_width=yes
# Declared in ms-w32.h
ac_cv_have_decl_alarm=yes
# Avoid including the gnulib dup2 module
diff --git a/oldXMenu/Makefile.in b/oldXMenu/Makefile.in
index b9055c4537a..db76e7420dd 100644
--- a/oldXMenu/Makefile.in
+++ b/oldXMenu/Makefile.in
@@ -138,7 +138,7 @@ libXMenu11.a: $(OBJS) $(EXTRA)
.PHONY: mostlyclean clean distclean bootstrap-clean maintainer-clean
clean mostlyclean:
- rm -f libXMenu11.a *.o $(DEPDIR)/*
+ rm -f libXMenu11.a ./*.o $(DEPDIR)/*
bootstrap-clean maintainer-clean distclean: clean
rm -f Makefile
diff --git a/src/.gdbinit b/src/.gdbinit
index 59534417905..b8b303104f5 100644
--- a/src/.gdbinit
+++ b/src/.gdbinit
@@ -49,7 +49,7 @@ define xgetptr
else
set $bugfix = $arg0
end
- set $ptr = $bugfix & VALMASK
+ set $ptr = (EMACS_INT) $bugfix & VALMASK
end
define xgetint
@@ -58,7 +58,7 @@ define xgetint
else
set $bugfix = $arg0
end
- set $int = $bugfix << (USE_LSB_TAG ? 0 : INTTYPEBITS) >> INTTYPEBITS
+ set $int = (EMACS_INT) $bugfix << (USE_LSB_TAG ? 0 : INTTYPEBITS) >> INTTYPEBITS
end
define xgettype
@@ -67,7 +67,7 @@ define xgettype
else
set $bugfix = $arg0
end
- set $type = (enum Lisp_Type) (USE_LSB_TAG ? $bugfix & (1 << GCTYPEBITS) - 1 : (EMACS_UINT) $bugfix >> VALBITS)
+ set $type = (enum Lisp_Type) (USE_LSB_TAG ? (EMACS_INT) $bugfix & (1 << GCTYPEBITS) - 1 : (EMACS_UINT) $bugfix >> VALBITS)
end
define xgetsym
@@ -119,6 +119,12 @@ Print the value of the lisp variable given as argument.
Works only when an inferior emacs is executing.
end
+# Format the value and print it as a string. Works in
+# an rr session and during live debugging. Calls into lisp.
+define xfmt
+ printf "%s\n", debug_format("%S", $arg0)
+end
+
# Print out current buffer point and boundaries
define ppt
set $b = current_buffer
@@ -643,17 +649,13 @@ define xtype
xgettype $
output $type
echo \n
- if $type == Lisp_Misc
- xmisctype
- else
- if $type == Lisp_Vectorlike
- xvectype
- end
+ if $type == Lisp_Vectorlike
+ xvectype
end
end
document xtype
Print the type of $, assuming it is an Emacs Lisp value.
-If the first type printed is Lisp_Vector or Lisp_Misc,
+If the first type printed is Lisp_Vectorlike,
a second line gives the more precise type.
end
@@ -705,15 +707,6 @@ Print the size of $
This command assumes that $ is a Lisp_Object.
end
-define xmisctype
- xgetptr $
- output (enum Lisp_Misc_Type) (((struct Lisp_Free *) $ptr)->type)
- echo \n
-end
-document xmisctype
-Assume that $ is some misc type and print its specific type.
-end
-
define xint
xgetint $
print $int
@@ -748,15 +741,6 @@ Print $ as a overlay pointer.
This command assumes that $ is an Emacs Lisp overlay value.
end
-define xmiscfree
- xgetptr $
- print (struct Lisp_Free *) $ptr
-end
-document xmiscfree
-Print $ as a misc free-cell pointer.
-This command assumes that $ is an Emacs Lisp Misc value.
-end
-
define xsymbol
set $sym = $
xgetsym $sym
@@ -819,6 +803,7 @@ define xcompiled
xgetptr $
print (struct Lisp_Vector *) $ptr
output ($->contents[0])@($->header.size & 0xff)
+ echo \n
end
document xcompiled
Print $ as a compiled function pointer.
@@ -1008,21 +993,6 @@ define xpr
if $type == Lisp_Float
xfloat
end
- if $type == Lisp_Misc
- set $misc = (enum Lisp_Misc_Type) (((struct Lisp_Free *) $ptr)->type)
- if $misc == Lisp_Misc_Free
- xmiscfree
- end
- if $misc == Lisp_Misc_Marker
- xmarker
- end
- if $misc == Lisp_Misc_Overlay
- xoverlay
- end
-# if $misc == Lisp_Misc_Save_Value
-# xsavevalue
-# end
- end
if $type == Lisp_Vectorlike
set $size = ((struct Lisp_Vector *) $ptr)->header.size
if ($size & PSEUDOVECTOR_FLAG)
@@ -1030,6 +1000,12 @@ define xpr
if $vec == PVEC_NORMAL_VECTOR
xvector
end
+ if $vec == PVEC_MARKER
+ xmarker
+ end
+ if $vec == PVEC_OVERLAY
+ xoverlay
+ end
if $vec == PVEC_PROCESS
xprocess
end
@@ -1243,24 +1219,12 @@ show environment TERM
# terminate_due_to_signal when an assertion failure is non-fatal.
break terminate_due_to_signal
-# x_error_quitter is defined only on X. But window-system is set up
-# only at run time, during Emacs startup, so we need to defer setting
-# the breakpoint. init_sys_modes is the first function called on
-# every platform after init_display, where window-system is set.
-tbreak init_sys_modes
-commands
- silent
- xsymname globals.f_Vinitial_window_system
- xgetptr $symname
- set $tem = (struct Lisp_String *) $ptr
- set $tem = (char *) $tem->u.s.data
- # If we are running in synchronous mode, we want a chance to look
- # around before Emacs exits. Perhaps we should put the break
- # somewhere else instead...
- if $tem[0] == 'x' && $tem[1] == '\0'
- break x_error_quitter
- end
- continue
+# x_error_quitter is defined only if defined_HAVE_X_WINDOWS.
+# If we are running in synchronous mode, we want a chance to look
+# around before Emacs exits. Perhaps we should put the break
+# somewhere else instead...
+if defined_HAVE_X_WINDOWS
+ break x_error_quitter
end
@@ -1270,6 +1234,12 @@ end
python
+# Python 3 compatibility.
+try:
+ long
+except:
+ long = int
+
# Omit pretty-printing in older (pre-7.3) GDBs that lack it.
if hasattr(gdb, 'printing'):
@@ -1306,13 +1276,13 @@ if hasattr(gdb, 'printing'):
# symbol table, guess reasonable defaults.
sym = gdb.lookup_symbol ("EMACS_INT_WIDTH")[0]
if sym:
- EMACS_INT_WIDTH = int (sym.value ())
+ EMACS_INT_WIDTH = long (sym.value ())
else:
sym = gdb.lookup_symbol ("EMACS_INT")[0]
EMACS_INT_WIDTH = 8 * sym.type.sizeof
sym = gdb.lookup_symbol ("USE_LSB_TAG")[0]
if sym:
- USE_LSB_TAG = int (sym.value ())
+ USE_LSB_TAG = long (sym.value ())
else:
USE_LSB_TAG = 1
@@ -1321,19 +1291,26 @@ if hasattr(gdb, 'printing'):
Lisp_Int0 = 2
Lisp_Int1 = 6 if USE_LSB_TAG else 3
- # Unpack the Lisp value from its containing structure, if necessary.
val = self.val
basic_type = gdb.types.get_basic_type (val.type)
+
+ # Unpack VAL from its containing structure, if necessary.
if (basic_type.code == gdb.TYPE_CODE_STRUCT
and gdb.types.has_field (basic_type, "i")):
val = val["i"]
+ # Convert VAL to a Python integer. Convert by hand, as this is
+ # simpler and works regardless of whether VAL is a pointer or
+ # integer. Also, val.cast (gdb.lookup.type ("EMACS_UINT"))
+ # would have problems with GDB 7.12.1; see
+ # <http://patchwork.sourceware.org/patch/11557/>.
+ ival = long (val)
+
# For nil, yield "XIL(0)", which is easier to read than "XIL(0x0)".
- if not val:
+ if not ival:
return "XIL(0)"
# Extract the integer representation of the value and its Lisp type.
- ival = int(val)
itype = ival >> (0 if USE_LSB_TAG else VALBITS)
itype = itype & ((1 << GCTYPEBITS) - 1)
@@ -1341,7 +1318,7 @@ if hasattr(gdb, 'printing'):
if itype == Lisp_Int0 or itype == Lisp_Int1:
if USE_LSB_TAG:
ival = ival >> (GCTYPEBITS - 1)
- elif (ival >> VALBITS) & 1:
+ if (ival >> VALBITS) & 1:
ival = ival | (-1 << VALBITS)
else:
ival = ival & ((1 << VALBITS) - 1)
@@ -1352,8 +1329,7 @@ if hasattr(gdb, 'printing'):
# integers even when Lisp_Object is an integer.
# Perhaps some day the pretty-printing could be fancier.
# Prefer the unsigned representation to negative values, converting
- # by hand as val.cast(gdb.lookup_type("EMACS_UINT") does not work in
- # GDB 7.12.1; see <http://patchwork.sourceware.org/patch/11557/>.
+ # by hand as val.cast does not work in GDB 7.12.1 as noted above.
if ival < 0:
ival = ival + (1 << EMACS_INT_WIDTH)
return "XIL(0x%x)" % ival
diff --git a/src/Makefile.in b/src/Makefile.in
index 5989ab4ceff..2348c8dae4c 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -54,8 +54,6 @@ lwlibdir = ../lwlib
# Configuration files for .o files to depend on.
config_h = config.h $(srcdir)/conf_post.h
-bootstrap_exe = ../src/bootstrap-emacs$(EXEEXT)
-
## ns-app if HAVE_NS, else empty.
OTHER_FILES = @OTHER_FILES@
@@ -104,7 +102,7 @@ LD_SWITCH_SYSTEM_TEMACS=@LD_SWITCH_SYSTEM_TEMACS@
## Flags to pass to ld only for temacs.
TEMACS_LDFLAGS = $(LD_SWITCH_SYSTEM) $(LD_SWITCH_SYSTEM_TEMACS)
-## If available, the names of the paxctl and setfattr programs.
+## If needed, the names of the paxctl and setfattr programs.
## On grsecurity/PaX systems, unexec will fail due to a gap between
## the bss section and the heap. Older versions need paxctl to work
## around this, newer ones setfattr. See Bug#11398 and Bug#16343.
@@ -127,7 +125,8 @@ LIBIMAGE=@LIBTIFF@ @LIBJPEG@ @LIBPNG@ @LIBGIF@ @LIBXPM@
XCB_LIBS=@XCB_LIBS@
XFT_LIBS=@XFT_LIBS@
-LIBX_EXTRA=-lX11 $(XCB_LIBS) $(XFT_LIBS)
+XRENDER_LIBS=@XRENDER_LIBS@
+LIBX_EXTRA=-lX11 $(XCB_LIBS) $(XFT_LIBS) $(XRENDER_LIBS)
FONTCONFIG_CFLAGS = @FONTCONFIG_CFLAGS@
FONTCONFIG_LIBS = @FONTCONFIG_LIBS@
@@ -141,7 +140,6 @@ M17N_FLT_LIBS = @M17N_FLT_LIBS@
LIB_ACL=@LIB_ACL@
LIB_CLOCK_GETTIME=@LIB_CLOCK_GETTIME@
LIB_EACCESS=@LIB_EACCESS@
-LIB_FDATASYNC=@LIB_FDATASYNC@
LIB_TIMER_TIME=@LIB_TIMER_TIME@
DBUS_CFLAGS = @DBUS_CFLAGS@
@@ -234,7 +232,8 @@ LIBXML2_CFLAGS = @LIBXML2_CFLAGS@
GETADDRINFO_A_LIBS = @GETADDRINFO_A_LIBS@
-LIBLCMS2 = @LIBLCMS2@
+LCMS2_LIBS = @LCMS2_LIBS@
+LCMS2_CFLAGS = @LCMS2_CFLAGS@
LIBZ = @LIBZ@
@@ -277,11 +276,12 @@ NS_OBJC_OBJ=@NS_OBJC_OBJ@
## Used only for GNUstep.
GNU_OBJC_CFLAGS=$(patsubst -specs=%-hardened-cc1,,@GNU_OBJC_CFLAGS@)
## w32fns.o w32menu.c w32reg.o fringe.o fontset.o w32font.o w32term.o
-## w32xfns.o w32select.o image.o w32uniscribe.o if HAVE_W32, else
-## empty.
+## w32xfns.o w32select.o image.o w32uniscribe.o w32cygwinx.o if HAVE_W32,
+## w32cygwinx.o if CYGWIN but not HAVE_W32, else empty.
W32_OBJ=@W32_OBJ@
## -lkernel32 -luser32 -lusp10 -lgdi32 -lole32 -lcomdlg32 -lcomctl32
-## --lwinspool if HAVE_W32, else empty.
+## -lwinspool if HAVE_W32,
+## -lkernel32 if CYGWIN but not HAVE_W32, else empty.
W32_LIBS=@W32_LIBS@
## emacs.res if HAVE_W32
@@ -312,10 +312,17 @@ LIBGNUTLS_CFLAGS = @LIBGNUTLS_CFLAGS@
LIBSYSTEMD_LIBS = @LIBSYSTEMD_LIBS@
LIBSYSTEMD_CFLAGS = @LIBSYSTEMD_CFLAGS@
+JSON_LIBS = @JSON_LIBS@
+JSON_CFLAGS = @JSON_CFLAGS@
+JSON_OBJ = @JSON_OBJ@
+
INTERVALS_H = dispextern.h intervals.h composite.h
GETLOADAVG_LIBS = @GETLOADAVG_LIBS@
+GMP_LIB = @GMP_LIB@
+GMP_OBJ = @GMP_OBJ@
+
RUN_TEMACS = ./temacs
# Whether builds should contain details. '--no-build-details' or empty.
@@ -323,7 +330,8 @@ BUILD_DETAILS = @BUILD_DETAILS@
UNEXEC_OBJ = @UNEXEC_OBJ@
-CANNOT_DUMP=@CANNOT_DUMP@
+DUMPING=@DUMPING@
+CHECK_STRUCTS = @CHECK_STRUCTS@
# 'make' verbosity.
AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@
@@ -348,6 +356,15 @@ am__v_at_ = $(am__v_at_@AM_DEFAULT_V@)
am__v_at_0 = @
am__v_at_1 =
+bootstrap_exe = ../src/bootstrap-emacs$(EXEEXT)
+ifeq ($(DUMPING),pdumper)
+bootstrap_pdmp := bootstrap-emacs.pdmp # Keep in sync with loadup.el
+pdmp := emacs.pdmp
+else
+bootstrap_pdmp :=
+pdmp :=
+endif
+
# Flags that might be in WARN_CFLAGS but are not valid for Objective C.
NON_OBJC_CFLAGS = -Wignored-attributes -Wignored-qualifiers -Wopenmp-simd
@@ -360,10 +377,10 @@ EMACS_CFLAGS=-Demacs $(MYCPPFLAGS) -I. -I$(srcdir) \
$(GNUSTEP_CFLAGS) $(CFLAGS_SOUND) $(RSVG_CFLAGS) $(IMAGEMAGICK_CFLAGS) \
$(PNG_CFLAGS) $(LIBXML2_CFLAGS) $(DBUS_CFLAGS) \
$(XRANDR_CFLAGS) $(XINERAMA_CFLAGS) $(XFIXES_CFLAGS) $(XDBE_CFLAGS) \
- $(WEBKIT_CFLAGS) \
+ $(WEBKIT_CFLAGS) $(LCMS2_CFLAGS) \
$(SETTINGS_CFLAGS) $(FREETYPE_CFLAGS) $(FONTCONFIG_CFLAGS) \
$(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \
- $(LIBSYSTEMD_CFLAGS) \
+ $(LIBSYSTEMD_CFLAGS) $(JSON_CFLAGS) \
$(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \
$(WERROR_CFLAGS)
ALL_CFLAGS = $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS)
@@ -383,21 +400,21 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \
charset.o coding.o category.o ccl.o character.o chartab.o bidi.o \
$(CM_OBJ) term.o terminal.o xfaces.o $(XOBJ) $(GTK_OBJ) $(DBUS_OBJ) \
emacs.o keyboard.o macros.o keymap.o sysdep.o \
- buffer.o filelock.o insdel.o marker.o \
+ bignum.o buffer.o filelock.o insdel.o marker.o \
minibuf.o fileio.o dired.o \
- cmds.o casetab.o casefiddle.o indent.o search.o regex.o undo.o \
- alloc.o data.o doc.o editfns.o callint.o \
+ cmds.o casetab.o casefiddle.o indent.o search.o regex-emacs.o undo.o \
+ alloc.o pdumper.o data.o doc.o editfns.o callint.o \
eval.o floatfns.o fns.o font.o print.o lread.o $(MODULES_OBJ) \
syntax.o $(UNEXEC_OBJ) bytecode.o \
process.o gnutls.o callproc.o \
- region-cache.o sound.o atimer.o \
+ region-cache.o sound.o timefns.o atimer.o \
doprnt.o intervals.o textprop.o composite.o xml.o lcms.o $(NOTIFY_OBJ) \
$(XWIDGETS_OBJ) \
profiler.o decompress.o \
thread.o systhread.o \
$(if $(HYBRID_MALLOC),sheap.o) \
$(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \
- $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ)
+ $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) $(JSON_OBJ) $(GMP_OBJ)
obj = $(base_obj) $(NS_OBJC_OBJ)
## Object files used on some machine or other.
@@ -408,7 +425,7 @@ SOME_MACHINE_OBJECTS = dosfns.o msdos.o \
xterm.o xfns.o xmenu.o xselect.o xrdb.o xsmfns.o fringe.o image.o \
fontset.o dbusbind.o cygw32.o \
nsterm.o nsfns.o nsmenu.o nsselect.o nsimage.o nsfont.o macfont.o \
- w32.o w32console.o w32fns.o w32heap.o w32inevt.o w32notify.o \
+ w32.o w32console.o w32cygwinx.o w32fns.o w32heap.o w32inevt.o w32notify.o \
w32menu.o w32proc.o w32reg.o w32select.o w32term.o w32xfns.o \
w16select.o widget.o xfont.o ftfont.o xftfont.o ftxfont.o gtkutil.o \
xsettings.o xgselect.o termcap.o
@@ -436,6 +453,20 @@ otherobj= $(TERMCAP_OBJ) $(PRE_ALLOC_OBJ) $(GMALLOC_OBJ) $(RALLOC_OBJ) \
FIRSTFILE_OBJ=@FIRSTFILE_OBJ@
ALLOBJS = $(FIRSTFILE_OBJ) $(VMLIMIT_OBJ) $(obj) $(otherobj)
+# Must be first, before dep inclusion!
+all: emacs$(EXEEXT) $(pdmp) $(OTHER_FILES)
+.PHONY: all
+
+dmpstruct_headers=$(srcdir)/lisp.h $(srcdir)/buffer.h \
+ $(srcdir)/intervals.h $(srcdir)/charset.h $(srcdir)/bignum.h
+ifeq ($(CHECK_STRUCTS),true)
+pdumper.o: dmpstruct.h
+endif
+dmpstruct.h: $(srcdir)/dmpstruct.awk
+dmpstruct.h: $(libsrc)/make-fingerprint$(EXEEXT) $(dmpstruct_headers)
+ $(AM_V_GEN)POSIXLY_CORRECT=1 awk -f $(srcdir)/dmpstruct.awk \
+ $(dmpstruct_headers) > $@
+
AUTO_DEPEND = @AUTO_DEPEND@
DEPDIR = deps
ifeq ($(AUTO_DEPEND),yes)
@@ -446,9 +477,6 @@ else
include $(srcdir)/deps.mk
endif
-all: emacs$(EXEEXT) $(OTHER_FILES)
-.PHONY: all
-
## This is the list of all Lisp files that might be loaded into the
## dumped Emacs. Some of them are not loaded on all platforms, but
## the DOC file on every platform uses them (because the DOC file is
@@ -486,21 +514,22 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \
$(LIBX_OTHER) $(LIBSOUND) \
$(RSVG_LIBS) $(IMAGEMAGICK_LIBS) $(LIB_ACL) $(LIB_CLOCK_GETTIME) \
$(WEBKIT_LIBS) \
- $(LIB_EACCESS) $(LIB_FDATASYNC) $(LIB_TIMER_TIME) $(DBUS_LIBS) \
+ $(LIB_EACCESS) $(LIB_TIMER_TIME) $(DBUS_LIBS) \
$(LIB_EXECINFO) $(XRANDR_LIBS) $(XINERAMA_LIBS) $(XFIXES_LIBS) \
$(XDBE_LIBS) \
$(LIBXML2_LIBS) $(LIBGPM) $(LIBS_SYSTEM) $(CAIRO_LIBS) \
$(LIBS_TERMCAP) $(GETLOADAVG_LIBS) $(SETTINGS_LIBS) $(LIBSELINUX_LIBS) \
$(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \
- $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LIBLCMS2) \
- $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS)
-
-## FORCE it so that admin/unidata can decide whether these files
-## are up-to-date. Although since charprop depends on bootstrap-emacs,
-## and emacs (which recreates bootstrap-emacs) depends on charprop,
-## in practice this rule was always run anyway.
-$(srcdir)/macuvs.h $(lispsource)/international/charprop.el: \
- bootstrap-emacs$(EXEEXT) FORCE
+ $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LCMS2_LIBS) \
+ $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \
+ $(JSON_LIBS) $(GMP_LIB)
+
+## FORCE it so that admin/unidata can decide whether this file is
+## up-to-date. Although since charprop depends on bootstrap-emacs,
+## and emacs depends on charprop, in practice this rule was always run
+## anyway.
+$(lispsource)/international/charprop.el: \
+ FORCE | bootstrap-emacs$(EXEEXT) $(bootstrap_pdmp)
$(MAKE) -C ../admin/unidata all EMACS="../$(bootstrap_exe)"
## We require charprop.el to exist before ucs-normalize.el is
@@ -515,7 +544,7 @@ ${lispintdir}/cp51932.el ${lispintdir}/eucjp-ms.el: FORCE
charsets = ${top_srcdir}/admin/charsets/charsets.stamp
${charsets}: FORCE
- ${MAKE} -C ../admin/charsets all
+ $(MAKE) -C ../admin/charsets all
charscript = ${lispintdir}/charscript.el
${charscript}: FORCE
@@ -531,15 +560,20 @@ ${lispintdir}/characters.elc: ${charscript:.el=.elc}
emacs$(EXEEXT): temacs$(EXEEXT) \
lisp.mk $(etc)/DOC $(lisp) \
$(lispsource)/international/charprop.el ${charsets}
-ifeq ($(CANNOT_DUMP),yes)
- ln -f temacs$(EXEEXT) $@
-else
- unset EMACS_HEAP_EXEC; \
- LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup dump
+ifeq ($(DUMPING),unexec)
+ LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=dump
ifneq ($(PAXCTL_dumped),)
- $(PAXCTL_dumped) $@
+ $(PAXCTL_dumped) emacs$(EXEEXT)
endif
- ln -f $@ bootstrap-emacs$(EXEEXT)
+ cp -f $@ bootstrap-emacs$(EXEEXT)
+else
+ rm -f $@ && cp -f temacs$(EXEEXT) $@
+endif
+
+ifeq ($(DUMPING),pdumper)
+$(pdmp): emacs$(EXEEXT)
+ LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=pdump
+ cp -f $@ $(bootstrap_pdmp)
endif
## We run make-docfile twice because the command line may get too long
@@ -561,8 +595,9 @@ $(etc)/DOC: lisp.mk $(libsrc)/make-docfile$(EXEEXT) $(obj) $(lisp)
$(AM_V_at)$(libsrc)/make-docfile -a $(etc)/DOC -d $(lispsource) \
$(shortlisp)
-$(libsrc)/make-docfile$(EXEEXT): $(lib)/libgnu.a
- $(MAKE) -C $(libsrc) make-docfile$(EXEEXT)
+$(libsrc)/make-docfile$(EXEEXT) $(libsrc)/make-fingerprint$(EXEEXT): \
+ $(lib)/libgnu.a
+ $(MAKE) -C $(dir $@) $(notdir $@)
buildobj.h: Makefile
$(AM_V_GEN)for i in $(ALLOBJS); do \
@@ -590,18 +625,23 @@ $(ALLOBJS): globals.h
LIBEGNU_ARCHIVE = $(lib)/lib$(if $(HYBRID_MALLOC),e)gnu.a
$(LIBEGNU_ARCHIVE): $(config_h)
- $(MAKE) -C $(lib) all
+ $(MAKE) -C $(dir $@) all
+
+FINGERPRINTED = $(LIBXMENU) $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(EMACSRES)
+fingerprint.c: $(FINGERPRINTED) $(libsrc)/make-fingerprint$(EXEEXT)
+ $(AM_V_GEN)$(libsrc)/make-fingerprint$(EXEEXT) $(FINGERPRINTED) >$@.tmp
+ $(AM_V_at)mv $@.tmp $@
## We have to create $(etc) here because init_cmdargs tests its
## existence when setting Vinstallation_directory (FIXME?).
## This goes on to affect various things, and the emacs binary fails
## to start if Vinstallation_directory has the wrong value.
-temacs$(EXEEXT): $(LIBXMENU) $(ALLOBJS) \
- $(LIBEGNU_ARCHIVE) $(EMACSRES) ${charsets} ${charscript}
- $(AM_V_CCLD)$(CC) $(ALL_CFLAGS) $(TEMACS_LDFLAGS) $(LDFLAGS) \
- -o temacs $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES)
+temacs$(EXEEXT): fingerprint.o $(charsets) $(charscript)
+ $(AM_V_CCLD)$(CC) -o $@ $(ALL_CFLAGS) $(TEMACS_LDFLAGS) $(LDFLAGS) \
+ $(ALLOBJS) fingerprint.o \
+ $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES)
$(MKDIR_P) $(etc)
-ifneq ($(CANNOT_DUMP),yes)
+ifeq ($(DUMPING),unexec)
ifneq ($(PAXCTL_notdumped),)
$(PAXCTL_notdumped) $@
endif
@@ -610,15 +650,15 @@ endif
## The following oldxmenu-related rules are only (possibly) used if
## HAVE_X11 && !USE_GTK, but there is no harm in always defining them.
$(lwlibdir)/liblw.a: $(config_h) globals.h lisp.h FORCE
- $(MAKE) -C $(lwlibdir) liblw.a
+ $(MAKE) -C $(dir $@) $(notdir $@)
$(oldXMenudir)/libXMenu11.a: FORCE
- $(MAKE) -C $(oldXMenudir) libXMenu11.a
+ $(MAKE) -C $(dir $@) $(notdir $@)
FORCE:
.PHONY: FORCE
.PRECIOUS: ../config.status Makefile
../config.status: $(top_srcdir)/configure.ac $(top_srcdir)/m4/*.m4
- $(MAKE) -C .. $(notdir $@)
+ $(MAKE) -C $(dir $@) $(notdir $@)
Makefile: ../config.status $(srcdir)/Makefile.in
$(MAKE) -C .. src/$@
@@ -628,21 +668,25 @@ emacs.res: FORCE
$(MAKE) -C ../nt ../src/emacs.res
.PHONY: ns-app
-ns-app: emacs$(EXEEXT)
+ns-app: emacs$(EXEEXT) $(pdmp)
$(MAKE) -C ../nextstep all
.PHONY: mostlyclean clean bootstrap-clean distclean maintainer-clean
.PHONY: versionclean extraclean
mostlyclean:
- rm -f temacs$(EXEEXT) core *.core \#* *.o
+ rm -f temacs$(EXEEXT) core ./*.core \#* ./*.o
+ rm -f dmpstruct.h fingerprint.c
+ rm -f emacs.pdmp
rm -f ../etc/DOC
- rm -f bootstrap-emacs$(EXEEXT) emacs-$(version)$(EXEEXT)
+ rm -f bootstrap-emacs$(EXEEXT) $(bootstrap_pdmp)
+ rm -f emacs-$(version)$(EXEEXT)
rm -f buildobj.h
rm -f globals.h gl-stamp
- rm -f *.res *.tmp
+ rm -f ./*.res ./*.tmp
clean: mostlyclean
- rm -f emacs-*.*.*[0-9]$(EXEEXT) emacs$(EXEEXT) $(DEPDIR)/*
+ rm -f emacs-*.*.*[0-9]$(EXEEXT) emacs-*.*.*[0-9].pdmp
+ rm -f emacs$(EXEEXT) $(DEPDIR)/*
## bootstrap-clean is used to clean up just before a bootstrap.
## It should remove all files generated during a compilation/bootstrap,
@@ -664,15 +708,18 @@ maintainer-clean: distclean
versionclean:
-rm -f emacs$(EXEEXT) emacs-*.*.*[0-9]$(EXEEXT) ../etc/DOC*
extraclean: distclean
- -rm -f *~ \#*
+ -rm -f ./*~ \#*
ETAGS = ../lib-src/etags${EXEEXT}
${ETAGS}: FORCE
- ${MAKE} -C ../lib-src $(notdir $@)
+ $(MAKE) -C $(dir $@) $(notdir $@)
-ctagsfiles1 = $(wildcard ${srcdir}/*.[hc])
+# Remove macuvs.h and fingerprint.c since they'd cause `src/emacs`
+# to be built before we can get TAGS.
+ctagsfiles1 = $(filter-out ${srcdir}/macuvs.h ${srcdir}/fingerprint.c, \
+ $(wildcard ${srcdir}/*.[hc]))
ctagsfiles2 = $(wildcard ${srcdir}/*.m)
## In out-of-tree builds, TAGS are generated in the build dir, like
@@ -692,11 +739,8 @@ TAGS: ${ETAGS} $(ctagsfiles1) $(ctagsfiles2)
## Arrange to make tags tables for ../lisp and ../lwlib,
## which the above TAGS file for the C files includes by reference.
-../lisp/TAGS: FORCE
- $(MAKE) -C ../lisp TAGS ETAGS="$(ETAGS)"
-
-$(lwlibdir)/TAGS: FORCE
- $(MAKE) -C $(lwlibdir) TAGS ETAGS="$(ETAGS)"
+../lisp/TAGS $(lwlibdir)/TAGS: FORCE
+ $(MAKE) -C $(dir $@) $(notdir $@) ETAGS="$(ETAGS)"
tags: TAGS ../lisp/TAGS $(lwlibdir)/TAGS
.PHONY: tags
@@ -722,7 +766,7 @@ tags: TAGS ../lisp/TAGS $(lwlibdir)/TAGS
## but now that we require GNU make, we can simply specify
## bootstrap-emacs$(EXEEXT) as an order-only prerequisite.
-%.elc: %.el | bootstrap-emacs$(EXEEXT)
+%.elc: %.el | bootstrap-emacs$(EXEEXT) $(bootstrap_pdmp)
@$(MAKE) -C ../lisp EMACS="$(bootstrap_exe)" THEFILE=$< $<c
## VCSWITNESS points to the file that holds info about the current checkout.
@@ -730,22 +774,37 @@ tags: TAGS ../lisp/TAGS $(lwlibdir)/TAGS
## If empty it is ignored; the parent makefile can set it to some other value.
VCSWITNESS =
-$(lispsource)/loaddefs.el: $(VCSWITNESS) | bootstrap-emacs$(EXEEXT)
+$(lispsource)/loaddefs.el: $(VCSWITNESS) | \
+ bootstrap-emacs$(EXEEXT) $(bootstrap_pdmp)
$(MAKE) -C ../lisp autoloads EMACS="$(bootstrap_exe)"
## Dump an Emacs executable named bootstrap-emacs containing the
## files from loadup.el in source form.
+
bootstrap-emacs$(EXEEXT): temacs$(EXEEXT)
$(MAKE) -C ../lisp update-subdirs
-ifeq ($(CANNOT_DUMP),yes)
- ln -f temacs$(EXEEXT) $@
-else
- unset EMACS_HEAP_EXEC; \
- $(RUN_TEMACS) --batch $(BUILD_DETAILS) --load loadup bootstrap
+ifeq ($(DUMPING),unexec)
+ $(RUN_TEMACS) --batch $(BUILD_DETAILS) -l loadup --temacs=bootstrap
ifneq ($(PAXCTL_dumped),)
$(PAXCTL_dumped) emacs$(EXEEXT)
endif
- mv -f emacs$(EXEEXT) $@
+ mv -f emacs$(EXEEXT) bootstrap-emacs$(EXEEXT)
+ @: Compile some files earlier to speed up further compilation.
+ $(MAKE) -C ../lisp compile-first EMACS="$(bootstrap_exe)"
+else
+ @: In the pdumper case, make compile-first after the dump
+ cp -f temacs$(EXEEXT) bootstrap-emacs$(EXEEXT)
endif
+
+ifeq ($(DUMPING),pdumper)
+$(bootstrap_pdmp): bootstrap-emacs$(EXEEXT)
+ rm -f $@
+ $(RUN_TEMACS) --batch $(BUILD_DETAILS) -l loadup --temacs=pbootstrap
@: Compile some files earlier to speed up further compilation.
$(MAKE) -C ../lisp compile-first EMACS="$(bootstrap_exe)"
+endif
+
+### Flymake support (for C only)
+check-syntax:
+ $(AM_V_CC)$(CC) -c $(CPPFLAGS) $(ALL_CFLAGS) ${CHK_SOURCES} || true
+.PHONY: check-syntax
diff --git a/src/alloc.c b/src/alloc.c
index 6fd78188a0c..dd783863be8 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -31,8 +31,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#endif
#include "lisp.h"
+#include "bignum.h"
#include "dispextern.h"
#include "intervals.h"
+#include "ptr-bounds.h"
#include "puresize.h"
#include "sheap.h"
#include "systime.h"
@@ -42,6 +44,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "keyboard.h"
#include "frame.h"
#include "blockinput.h"
+#include "pdumper.h"
#include "termhooks.h" /* For struct terminal. */
#ifdef HAVE_WINDOW_SYSTEM
#include TERM_HEADER
@@ -63,16 +66,13 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
# include <malloc.h>
#endif
-#if (defined ENABLE_CHECKING \
- && defined HAVE_VALGRIND_VALGRIND_H \
- && !defined USE_VALGRIND)
+#if defined HAVE_VALGRIND_VALGRIND_H && !defined USE_VALGRIND
# define USE_VALGRIND 1
#endif
#if USE_VALGRIND
#include <valgrind/valgrind.h>
#include <valgrind/memcheck.h>
-static bool valgrind_p;
#endif
/* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
@@ -103,24 +103,12 @@ static bool valgrind_p;
#include "w32heap.h" /* for sbrk */
#endif
-#ifdef GNU_LINUX
-/* The address where the heap starts. */
-void *
-my_heap_start (void)
-{
- static void *start;
- if (! start)
- start = sbrk (0);
- return start;
-}
-#endif
-
#ifdef DOUG_LEA_MALLOC
/* Specify maximum number of areas to mmap. It would be nice to use a
value that explicitly means "no limit". */
-#define MMAP_MAX_AREAS 100000000
+# define MMAP_MAX_AREAS 100000000
/* A pointer to the memory allocated that copies that static data
inside glibc's malloc. */
@@ -136,9 +124,9 @@ malloc_initialize_hook (void)
if (! initialized)
{
-#ifdef GNU_LINUX
+# ifdef GNU_LINUX
my_heap_start ();
-#endif
+# endif
malloc_using_checking = getenv ("MALLOC_CHECK_") != NULL;
}
else
@@ -171,6 +159,7 @@ malloc_initialize_hook (void)
/* Declare the malloc initialization hook, which runs before 'main' starts.
EXTERNALLY_VISIBLE works around Bug#22522. */
+typedef void (*voidfuncptr) (void);
# ifndef __MALLOC_HOOK_VOLATILE
# define __MALLOC_HOOK_VOLATILE
# endif
@@ -179,7 +168,7 @@ voidfuncptr __MALLOC_HOOK_VOLATILE __malloc_initialize_hook EXTERNALLY_VISIBLE
#endif
-#if defined DOUG_LEA_MALLOC || !defined CANNOT_DUMP
+#if defined DOUG_LEA_MALLOC || defined HAVE_UNEXEC
/* Allocator-related actions to do just before and after unexec. */
@@ -191,9 +180,6 @@ alloc_unexec_pre (void)
if (!malloc_state_ptr)
fatal ("malloc_get_state: %s", strerror (errno));
# endif
-# ifdef HYBRID_MALLOC
- bss_sbrk_did_unexec = true;
-# endif
}
void
@@ -202,22 +188,33 @@ alloc_unexec_post (void)
# ifdef DOUG_LEA_MALLOC
free (malloc_state_ptr);
# endif
-# ifdef HYBRID_MALLOC
- bss_sbrk_did_unexec = false;
-# endif
}
+
+# ifdef GNU_LINUX
+
+/* The address where the heap starts. */
+void *
+my_heap_start (void)
+{
+ static void *start;
+ if (! start)
+ start = sbrk (0);
+ return start;
+}
+# endif
+
#endif
/* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
to a struct Lisp_String. */
-#define MARK_STRING(S) ((S)->u.s.size |= ARRAY_MARK_FLAG)
-#define UNMARK_STRING(S) ((S)->u.s.size &= ~ARRAY_MARK_FLAG)
-#define STRING_MARKED_P(S) (((S)->u.s.size & ARRAY_MARK_FLAG) != 0)
+#define XMARK_STRING(S) ((S)->u.s.size |= ARRAY_MARK_FLAG)
+#define XUNMARK_STRING(S) ((S)->u.s.size &= ~ARRAY_MARK_FLAG)
+#define XSTRING_MARKED_P(S) (((S)->u.s.size & ARRAY_MARK_FLAG) != 0)
-#define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
-#define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
-#define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
+#define XMARK_VECTOR(V) ((V)->header.size |= ARRAY_MARK_FLAG)
+#define XUNMARK_VECTOR(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
+#define XVECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
/* Default value of gc_cons_threshold (see below). */
@@ -228,26 +225,40 @@ struct emacs_globals globals;
/* Number of bytes of consing done since the last gc. */
-EMACS_INT consing_since_gc;
+byte_ct consing_since_gc;
/* Similar minimum, computed from Vgc_cons_percentage. */
-EMACS_INT gc_relative_threshold;
+byte_ct gc_relative_threshold;
-/* Minimum number of bytes of consing since GC before next GC,
- when memory is full. */
-
-EMACS_INT memory_full_cons_threshold;
+#ifdef HAVE_PDUMPER
+/* Number of finalizers run: used to loop over GC until we stop
+ generating garbage. */
+int number_finalizers_run;
+#endif
/* True during GC. */
bool gc_in_progress;
+/* Type of object counts reported by GC. Unlike byte_ct, this can be
+ signed, e.g., it is less than 2**31 on a typical 32-bit machine. */
+
+typedef intptr_t object_ct;
+
/* Number of live and free conses etc. */
-static EMACS_INT total_conses, total_markers, total_symbols, total_buffers;
-static EMACS_INT total_free_conses, total_free_markers, total_free_symbols;
-static EMACS_INT total_free_floats, total_floats;
+static struct gcstat
+{
+ object_ct total_conses, total_free_conses;
+ object_ct total_symbols, total_free_symbols;
+ object_ct total_strings, total_free_strings;
+ byte_ct total_string_bytes;
+ object_ct total_vectors, total_vector_slots, total_free_vector_slots;
+ object_ct total_floats, total_free_floats;
+ object_ct total_intervals, total_free_intervals;
+ object_ct total_buffers;
+} gcstat;
/* Points to memory space allocated as "spare", to be freed if we run
out of memory. We keep one large block, four cons-blocks, and
@@ -354,6 +365,7 @@ no_sanitize_memcpy (void *dest, void const *src, size_t size)
#endif /* MAX_SAVE_STACK > 0 */
+static void unchain_finalizer (struct Lisp_Finalizer *);
static void mark_terminals (void);
static void gc_sweep (void);
static Lisp_Object make_pure_vector (ptrdiff_t);
@@ -366,6 +378,27 @@ static void compact_small_strings (void);
static void free_large_strings (void);
extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
+/* Forward declare mark accessor functions: they're used all over the
+ place. */
+
+inline static bool vector_marked_p (const struct Lisp_Vector *v);
+inline static void set_vector_marked (struct Lisp_Vector *v);
+
+inline static bool vectorlike_marked_p (const union vectorlike_header *v);
+inline static void set_vectorlike_marked (union vectorlike_header *v);
+
+inline static bool cons_marked_p (const struct Lisp_Cons *c);
+inline static void set_cons_marked (struct Lisp_Cons *c);
+
+inline static bool string_marked_p (const struct Lisp_String *s);
+inline static void set_string_marked (struct Lisp_String *s);
+
+inline static bool symbol_marked_p (const struct Lisp_Symbol *s);
+inline static void set_symbol_marked (struct Lisp_Symbol *s);
+
+inline static bool interval_marked_p (INTERVAL i);
+inline static void set_interval_marked (INTERVAL i);
+
/* When scanning the C stack for live Lisp objects, Emacs keeps track of
what memory allocated via lisp_malloc and lisp_align_malloc is intended
for what purpose. This enumeration specifies the type of memory. */
@@ -376,7 +409,6 @@ enum mem_type
MEM_TYPE_BUFFER,
MEM_TYPE_CONS,
MEM_TYPE_STRING,
- MEM_TYPE_MISC,
MEM_TYPE_SYMBOL,
MEM_TYPE_FLOAT,
/* Since all non-bool pseudovectors are small enough to be
@@ -392,7 +424,10 @@ enum mem_type
/* A unique object in pure space used to make some Lisp objects
on free lists recognizable in O(1). */
-static Lisp_Object Vdead;
+#ifndef ENABLE_CHECKING
+static
+#endif
+Lisp_Object Vdead;
#define DEADP(x) EQ (x, Vdead)
#ifdef GC_MALLOC_CHECK
@@ -470,30 +505,21 @@ static struct mem_node *mem_find (void *);
#endif
/* Addresses of staticpro'd variables. Initialize it to a nonzero
- value; otherwise some compilers put it into BSS. */
+ value if we might unexec; otherwise some compilers put it into
+ BSS. */
-enum { NSTATICS = 2048 };
-static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
+Lisp_Object const *staticvec[NSTATICS]
+#ifdef HAVE_UNEXEC
+= {&Vpurify_flag}
+#endif
+ ;
/* Index of next unused slot in staticvec. */
-static int staticidx;
+int staticidx;
static void *pure_alloc (size_t, int);
-/* True if N is a power of 2. N should be positive. */
-
-#define POWER_OF_2(n) (((n) & ((n) - 1)) == 0)
-
-/* Return X rounded to the next multiple of Y. Y should be positive,
- and Y - 1 + X should not overflow. Arguments should not have side
- effects, as they are evaluated more than once. Tune for Y being a
- power of 2. */
-
-#define ROUNDUP(x, y) (POWER_OF_2 (y) \
- ? ((y) - 1 + (x)) & ~ ((y) - 1) \
- : ((y) - 1 + (x)) - ((y) - 1 + (x)) % (y))
-
/* Return PTR rounded up to the next multiple of ALIGNMENT. */
static void *
@@ -502,30 +528,36 @@ pointer_align (void *ptr, int alignment)
return (void *) ROUNDUP ((uintptr_t) ptr, alignment);
}
-/* Extract the pointer hidden within A, if A is not a symbol.
- If A is a symbol, extract the hidden pointer's offset from lispsym,
- converted to void *. */
-
-#define macro_XPNTR_OR_SYMBOL_OFFSET(a) \
- ((void *) (intptr_t) (USE_LSB_TAG ? XLI (a) - XTYPE (a) : XLI (a) & VALMASK))
+/* Define PNTR_ADD and XPNTR as functions, which are cleaner and can
+ be used in debuggers. Also, define them as macros if
+ DEFINE_KEY_OPS_AS_MACROS, for performance in that case.
+ The macro_* macros are private to this section of code. */
-/* Extract the pointer hidden within A. */
+/* Add a pointer P to an integer I without gcc -fsanitize complaining
+ about the result being out of range of the underlying array. */
-#define macro_XPNTR(a) \
- ((void *) ((intptr_t) XPNTR_OR_SYMBOL_OFFSET (a) \
- + (SYMBOLP (a) ? (char *) lispsym : NULL)))
+#define macro_PNTR_ADD(p, i) ((p) + (i))
-/* For pointer access, define XPNTR and XPNTR_OR_SYMBOL_OFFSET as
- functions, as functions are cleaner and can be used in debuggers.
- Also, define them as macros if being compiled with GCC without
- optimization, for performance in that case. The macro_* names are
- private to this section of code. */
-
-static ATTRIBUTE_UNUSED void *
-XPNTR_OR_SYMBOL_OFFSET (Lisp_Object a)
+static ATTRIBUTE_NO_SANITIZE_UNDEFINED ATTRIBUTE_UNUSED char *
+PNTR_ADD (char *p, EMACS_UINT i)
{
- return macro_XPNTR_OR_SYMBOL_OFFSET (a);
+ return macro_PNTR_ADD (p, i);
}
+
+#if DEFINE_KEY_OPS_AS_MACROS
+# define PNTR_ADD(p, i) macro_PNTR_ADD (p, i)
+#endif
+
+/* Extract the pointer hidden within O. */
+
+#define macro_XPNTR(o) \
+ ((void *) \
+ (SYMBOLP (o) \
+ ? PNTR_ADD ((char *) lispsym, \
+ (XLI (o) \
+ - ((EMACS_UINT) Lisp_Symbol << (USE_LSB_TAG ? 0 : VALBITS)))) \
+ : (char *) XLP (o) - (XLI (o) & ~VALMASK)))
+
static ATTRIBUTE_UNUSED void *
XPNTR (Lisp_Object a)
{
@@ -533,7 +565,6 @@ XPNTR (Lisp_Object a)
}
#if DEFINE_KEY_OPS_AS_MACROS
-# define XPNTR_OR_SYMBOL_OFFSET(a) macro_XPNTR_OR_SYMBOL_OFFSET (a)
# define XPNTR(a) macro_XPNTR (a)
#endif
@@ -558,18 +589,18 @@ mmap_lisp_allowed_p (void)
over our address space. We also can't use mmap for lisp objects
if we might dump: unexec doesn't preserve the contents of mmapped
regions. */
- return pointers_fit_in_lispobj_p () && !might_dump;
+ return pointers_fit_in_lispobj_p () && !will_dump_with_unexec_p ();
}
#endif
/* Head of a circularly-linked list of extant finalizers. */
-static struct Lisp_Finalizer finalizers;
+struct Lisp_Finalizer finalizers;
/* Head of a circularly-linked list of finalizers that must be invoked
because we deemed them unreachable. This list must be global, and
not a local inside garbage_collect_1, in case we GC again while
running finalizers. */
-static struct Lisp_Finalizer doomed_finalizers;
+struct Lisp_Finalizer doomed_finalizers;
/************************************************************************
@@ -627,6 +658,29 @@ buffer_memory_full (ptrdiff_t nbytes)
#define COMMON_MULTIPLE(a, b) \
((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
+/* LISP_ALIGNMENT is the alignment of Lisp objects. It must be at
+ least GCALIGNMENT so that pointers can be tagged. It also must be
+ at least as strict as the alignment of all the C types used to
+ implement Lisp objects; since pseudovectors can contain any C type,
+ this is max_align_t. On recent GNU/Linux x86 and x86-64 this can
+ often waste up to 8 bytes, since alignof (max_align_t) is 16 but
+ typical vectors need only an alignment of 8. Although shrinking
+ the alignment to 8 would save memory, it cost a 20% hit to Emacs
+ CPU performance on Fedora 28 x86-64 when compiled with gcc -m32. */
+enum { LISP_ALIGNMENT = alignof (union { max_align_t x;
+ GCALIGNED_UNION_MEMBER }) };
+verify (LISP_ALIGNMENT % GCALIGNMENT == 0);
+
+/* True if malloc (N) is known to return storage suitably aligned for
+ Lisp objects whenever N is a multiple of LISP_ALIGNMENT. In
+ practice this is true whenever alignof (max_align_t) is also a
+ multiple of LISP_ALIGNMENT. This works even for x86, where some
+ platform combinations (e.g., GCC 7 and later, glibc 2.25 and
+ earlier) have bugs where alignof (max_align_t) is 16 even though
+ the malloc alignment is only 8, and where Emacs still works because
+ it never does anything that requires an alignment of 16. */
+enum { MALLOC_IS_LISP_ALIGNED = alignof (max_align_t) % LISP_ALIGNMENT == 0 };
+
#ifndef XMALLOC_OVERRUN_CHECK
#define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
#else
@@ -647,18 +701,13 @@ buffer_memory_full (ptrdiff_t nbytes)
#define XMALLOC_OVERRUN_CHECK_OVERHEAD \
(2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
-#define XMALLOC_BASE_ALIGNMENT alignof (max_align_t)
-
-#define XMALLOC_HEADER_ALIGNMENT \
- COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
-
/* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
hold a size_t value and (2) the header size is a multiple of the
alignment that Emacs needs for C types and for USE_LSB_TAG. */
#define XMALLOC_OVERRUN_SIZE_SIZE \
(((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
- + XMALLOC_HEADER_ALIGNMENT - 1) \
- / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
+ + LISP_ALIGNMENT - 1) \
+ / LISP_ALIGNMENT * LISP_ALIGNMENT) \
- XMALLOC_OVERRUN_CHECK_SIZE)
static char const xmalloc_overrun_check_header[XMALLOC_OVERRUN_CHECK_SIZE] =
@@ -900,6 +949,8 @@ xfree (void *block)
{
if (!block)
return;
+ if (pdumper_object_p (block))
+ return;
MALLOC_BLOCK_INPUT;
free (block);
MALLOC_UNBLOCK_INPUT;
@@ -1122,6 +1173,9 @@ lisp_malloc (size_t nbytes, enum mem_type type)
static void
lisp_free (void *block)
{
+ if (pdumper_object_p (block))
+ return;
+
MALLOC_BLOCK_INPUT;
free (block);
#ifndef GC_MALLOC_CHECK
@@ -1140,11 +1194,10 @@ lisp_free (void *block)
verify (POWER_OF_2 (BLOCK_ALIGN));
/* Use aligned_alloc if it or a simple substitute is available.
- Address sanitization breaks aligned allocation, as of gcc 4.8.2 and
- clang 3.3 anyway. Aligned allocation is incompatible with
- unexmacosx.c, so don't use it on Darwin. */
+ Aligned allocation is incompatible with unexmacosx.c, so don't use
+ it on Darwin if HAVE_UNEXEC. */
-#if ! ADDRESS_SANITIZER && !defined DARWIN_OS
+#if ! (defined DARWIN_OS && defined HAVE_UNEXEC)
# if (defined HAVE_ALIGNED_ALLOC \
|| (defined HYBRID_MALLOC \
? defined HAVE_POSIX_MEMALIGN \
@@ -1160,9 +1213,11 @@ aligned_alloc (size_t alignment, size_t size)
Verify this for all arguments this function is given. */
verify (BLOCK_ALIGN % sizeof (void *) == 0
&& POWER_OF_2 (BLOCK_ALIGN / sizeof (void *)));
- verify (GCALIGNMENT % sizeof (void *) == 0
- && POWER_OF_2 (GCALIGNMENT / sizeof (void *)));
- eassert (alignment == BLOCK_ALIGN || alignment == GCALIGNMENT);
+ verify (MALLOC_IS_LISP_ALIGNED
+ || (LISP_ALIGNMENT % sizeof (void *) == 0
+ && POWER_OF_2 (LISP_ALIGNMENT / sizeof (void *))));
+ eassert (alignment == BLOCK_ALIGN
+ || (!MALLOC_IS_LISP_ALIGNED && alignment == LISP_ALIGNMENT));
void *p;
return posix_memalign (&p, alignment, size) == 0 ? p : 0;
@@ -1394,31 +1449,15 @@ lisp_align_free (void *block)
MALLOC_UNBLOCK_INPUT;
}
-#if !defined __GNUC__ && !defined __alignof__
-# define __alignof__(type) alignof (type)
-#endif
-
-/* True if malloc (N) is known to return a multiple of GCALIGNMENT
- whenever N is also a multiple. In practice this is true if
- __alignof__ (max_align_t) is a multiple as well, assuming
- GCALIGNMENT is 8; other values of GCALIGNMENT have not been looked
- into. Use __alignof__ if available, as otherwise
- MALLOC_IS_GC_ALIGNED would be false on GCC x86 even though the
- alignment is OK there.
-
- This is a macro, not an enum constant, for portability to HP-UX
- 10.20 cc and AIX 3.2.5 xlc. */
-#define MALLOC_IS_GC_ALIGNED \
- (GCALIGNMENT == 8 && __alignof__ (max_align_t) % GCALIGNMENT == 0)
-
/* True if a malloc-returned pointer P is suitably aligned for SIZE,
- where Lisp alignment may be needed if SIZE is Lisp-aligned. */
+ where Lisp object alignment may be needed if SIZE is a multiple of
+ LISP_ALIGNMENT. */
static bool
laligned (void *p, size_t size)
{
- return (MALLOC_IS_GC_ALIGNED || (intptr_t) p % GCALIGNMENT == 0
- || size % GCALIGNMENT != 0);
+ return (MALLOC_IS_LISP_ALIGNED || (intptr_t) p % LISP_ALIGNMENT == 0
+ || size % LISP_ALIGNMENT != 0);
}
/* Like malloc and realloc except that if SIZE is Lisp-aligned, make
@@ -1440,9 +1479,9 @@ laligned (void *p, size_t size)
static void *
lmalloc (size_t size)
{
-#if USE_ALIGNED_ALLOC
- if (! MALLOC_IS_GC_ALIGNED && size % GCALIGNMENT == 0)
- return aligned_alloc (GCALIGNMENT, size);
+#ifdef USE_ALIGNED_ALLOC
+ if (! MALLOC_IS_LISP_ALIGNED && size % LISP_ALIGNMENT == 0)
+ return aligned_alloc (LISP_ALIGNMENT, size);
#endif
while (true)
@@ -1451,7 +1490,7 @@ lmalloc (size_t size)
if (laligned (p, size))
return p;
free (p);
- size_t bigger = size + GCALIGNMENT;
+ size_t bigger = size + LISP_ALIGNMENT;
if (size < bigger)
size = bigger;
}
@@ -1465,7 +1504,7 @@ lrealloc (void *p, size_t size)
p = realloc (p, size);
if (laligned (p, size))
return p;
- size_t bigger = size + GCALIGNMENT;
+ size_t bigger = size + LISP_ALIGNMENT;
if (size < bigger)
size = bigger;
}
@@ -1502,10 +1541,6 @@ static struct interval_block *interval_block;
static int interval_block_index = INTERVAL_BLOCK_SIZE;
-/* Number of free and live intervals. */
-
-static EMACS_INT total_free_intervals, total_intervals;
-
/* List of free intervals. */
static INTERVAL interval_free_list;
@@ -1534,7 +1569,7 @@ make_interval (void)
newi->next = interval_block;
interval_block = newi;
interval_block_index = 0;
- total_free_intervals += INTERVAL_BLOCK_SIZE;
+ gcstat.total_free_intervals += INTERVAL_BLOCK_SIZE;
}
val = &interval_block->intervals[interval_block_index++];
}
@@ -1543,7 +1578,7 @@ make_interval (void)
consing_since_gc += sizeof (struct interval);
intervals_consed++;
- total_free_intervals--;
+ gcstat.total_free_intervals--;
RESET_INTERVAL (val);
val->gcmarkbit = 0;
return val;
@@ -1553,22 +1588,23 @@ make_interval (void)
/* Mark Lisp objects in interval I. */
static void
-mark_interval (INTERVAL i, void *dummy)
+mark_interval_tree_1 (INTERVAL i, void *dummy)
{
/* Intervals should never be shared. So, if extra internal checking is
enabled, GC aborts if it seems to have visited an interval twice. */
- eassert (!i->gcmarkbit);
- i->gcmarkbit = 1;
+ eassert (!interval_marked_p (i));
+ set_interval_marked (i);
mark_object (i->plist);
}
/* Mark the interval tree rooted in I. */
-#define MARK_INTERVAL_TREE(i) \
- do { \
- if (i && !i->gcmarkbit) \
- traverse_intervals_noorder (i, mark_interval, NULL); \
- } while (0)
+static void
+mark_interval_tree (INTERVAL i)
+{
+ if (i && !interval_marked_p (i))
+ traverse_intervals_noorder (i, mark_interval_tree_1, NULL);
+}
/***********************************************************************
String Allocation
@@ -1718,14 +1754,6 @@ static struct string_block *string_blocks;
static struct Lisp_String *string_free_list;
-/* Number of live and free Lisp_Strings. */
-
-static EMACS_INT total_strings, total_free_strings;
-
-/* Number of bytes used by live strings. */
-
-static EMACS_INT total_string_bytes;
-
/* Given a pointer to a Lisp_String S which is on the free-list
string_free_list, return a pointer to its successor in the
free-list. */
@@ -1737,7 +1765,8 @@ static EMACS_INT total_string_bytes;
a pointer to the `u.data' member of its sdata structure; the
structure starts at a constant offset in front of that. */
-#define SDATA_OF_STRING(S) ((sdata *) ((S)->u.s.data - SDATA_DATA_OFFSET))
+#define SDATA_OF_STRING(S) ((sdata *) ptr_bounds_init ((S)->u.s.data \
+ - SDATA_DATA_OFFSET))
#ifdef GC_CHECK_STRING_OVERRUN
@@ -1785,7 +1814,7 @@ static char const string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
#define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
/* Exact bound on the number of bytes in a string, not counting the
- terminating null. A string cannot contain more bytes than
+ terminating NUL. A string cannot contain more bytes than
STRING_BYTES_BOUND, nor can it be so long that the size_t
arithmetic in allocate_string_data would overflow while it is
calculating a value to be passed to malloc. */
@@ -1803,7 +1832,9 @@ static void
init_strings (void)
{
empty_unibyte_string = make_pure_string ("", 0, 0, 0);
+ staticpro (&empty_unibyte_string);
empty_multibyte_string = make_pure_string ("", 0, 0, 1);
+ staticpro (&empty_multibyte_string);
}
@@ -1929,10 +1960,10 @@ allocate_string (void)
/* Every string on a free list should have NULL data pointer. */
s->u.s.data = NULL;
NEXT_FREE_LISP_STRING (s) = string_free_list;
- string_free_list = s;
+ string_free_list = ptr_bounds_clip (s, sizeof *s);
}
- total_free_strings += STRING_BLOCK_SIZE;
+ gcstat.total_free_strings += STRING_BLOCK_SIZE;
}
check_string_free_list ();
@@ -1943,8 +1974,8 @@ allocate_string (void)
MALLOC_UNBLOCK_INPUT;
- --total_free_strings;
- ++total_strings;
+ gcstat.total_free_strings--;
+ gcstat.total_strings++;
++strings_consed;
consing_since_gc += sizeof *s;
@@ -2044,7 +2075,7 @@ allocate_string_data (struct Lisp_String *s,
MALLOC_UNBLOCK_INPUT;
- s->u.s.data = SDATA_DATA (data);
+ s->u.s.data = ptr_bounds_clip (SDATA_DATA (data), nbytes + 1);
#ifdef GC_CHECK_STRING_BYTES
SDATA_NBYTES (data) = nbytes;
#endif
@@ -2079,8 +2110,8 @@ sweep_strings (void)
struct string_block *live_blocks = NULL;
string_free_list = NULL;
- total_strings = total_free_strings = 0;
- total_string_bytes = 0;
+ gcstat.total_strings = gcstat.total_free_strings = 0;
+ gcstat.total_string_bytes = 0;
/* Scan strings_blocks, free Lisp_Strings that aren't marked. */
for (b = string_blocks; b; b = next)
@@ -2097,16 +2128,16 @@ sweep_strings (void)
if (s->u.s.data)
{
/* String was not on free-list before. */
- if (STRING_MARKED_P (s))
+ if (XSTRING_MARKED_P (s))
{
/* String is live; unmark it and its intervals. */
- UNMARK_STRING (s);
+ XUNMARK_STRING (s);
/* Do not use string_(set|get)_intervals here. */
s->u.s.intervals = balance_intervals (s->u.s.intervals);
- ++total_strings;
- total_string_bytes += STRING_BYTES (s);
+ gcstat.total_strings++;
+ gcstat.total_string_bytes += STRING_BYTES (s);
}
else
{
@@ -2130,7 +2161,7 @@ sweep_strings (void)
/* Put the string on the free-list. */
NEXT_FREE_LISP_STRING (s) = string_free_list;
- string_free_list = s;
+ string_free_list = ptr_bounds_clip (s, sizeof *s);
++nfree;
}
}
@@ -2138,7 +2169,7 @@ sweep_strings (void)
{
/* S was on the free-list before. Put it there again. */
NEXT_FREE_LISP_STRING (s) = string_free_list;
- string_free_list = s;
+ string_free_list = ptr_bounds_clip (s, sizeof *s);
++nfree;
}
}
@@ -2146,14 +2177,14 @@ sweep_strings (void)
/* Free blocks that contain free Lisp_Strings only, except
the first two of them. */
if (nfree == STRING_BLOCK_SIZE
- && total_free_strings > STRING_BLOCK_SIZE)
+ && gcstat.total_free_strings > STRING_BLOCK_SIZE)
{
lisp_free (b);
string_free_list = free_list_before;
}
else
{
- total_free_strings += nfree;
+ gcstat.total_free_strings += nfree;
b->next = live_blocks;
live_blocks = b;
}
@@ -2234,9 +2265,9 @@ compact_small_strings (void)
nbytes = s ? STRING_BYTES (s) : SDATA_NBYTES (from);
eassert (nbytes <= LARGE_STRING_BYTES);
- nbytes = SDATA_SIZE (nbytes);
+ ptrdiff_t size = SDATA_SIZE (nbytes);
sdata *from_end = (sdata *) ((char *) from
- + nbytes + GC_STRING_EXTRA);
+ + size + GC_STRING_EXTRA);
#ifdef GC_CHECK_STRING_OVERRUN
if (memcmp (string_overrun_cookie,
@@ -2250,22 +2281,23 @@ compact_small_strings (void)
{
/* If TB is full, proceed with the next sblock. */
sdata *to_end = (sdata *) ((char *) to
- + nbytes + GC_STRING_EXTRA);
+ + size + GC_STRING_EXTRA);
if (to_end > tb_end)
{
tb->next_free = to;
tb = tb->next;
tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE);
to = tb->data;
- to_end = (sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
+ to_end = (sdata *) ((char *) to + size + GC_STRING_EXTRA);
}
/* Copy, and update the string's `data' pointer. */
if (from != to)
{
eassert (tb != b || to < from);
- memmove (to, from, nbytes + GC_STRING_EXTRA);
- to->string->u.s.data = SDATA_DATA (to);
+ memmove (to, from, size + GC_STRING_EXTRA);
+ to->string->u.s.data
+ = ptr_bounds_clip (SDATA_DATA (to), nbytes + 1);
}
/* Advance past the sdata we copied to. */
@@ -2299,23 +2331,25 @@ string_overflow (void)
error ("Maximum string size exceeded");
}
-DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0,
+DEFUN ("make-string", Fmake_string, Smake_string, 2, 3, 0,
doc: /* Return a newly created string of length LENGTH, with INIT in each element.
LENGTH must be an integer.
-INIT must be an integer that represents a character. */)
- (Lisp_Object length, Lisp_Object init)
+INIT must be an integer that represents a character.
+If optional argument MULTIBYTE is non-nil, the result will be
+a multibyte string even if INIT is an ASCII character. */)
+ (Lisp_Object length, Lisp_Object init, Lisp_Object multibyte)
{
register Lisp_Object val;
int c;
EMACS_INT nbytes;
- CHECK_NATNUM (length);
+ CHECK_FIXNAT (length);
CHECK_CHARACTER (init);
- c = XFASTINT (init);
- if (ASCII_CHAR_P (c))
+ c = XFIXNAT (init);
+ if (ASCII_CHAR_P (c) && NILP (multibyte))
{
- nbytes = XINT (length);
+ nbytes = XFIXNUM (length);
val = make_uninit_string (nbytes);
if (nbytes)
{
@@ -2327,7 +2361,7 @@ INIT must be an integer that represents a character. */)
{
unsigned char str[MAX_MULTIBYTE_LENGTH];
ptrdiff_t len = CHAR_STRING (c, str);
- EMACS_INT string_len = XINT (length);
+ EMACS_INT string_len = XFIXNUM (length);
unsigned char *p, *beg, *end;
if (INT_MULTIPLY_WRAPV (len, string_len, &nbytes))
@@ -2383,6 +2417,8 @@ make_uninit_bool_vector (EMACS_INT nbits)
EMACS_INT needed_elements = ((bool_header_size - header_size + word_bytes
+ word_size - 1)
/ word_size);
+ if (PTRDIFF_MAX < needed_elements)
+ memory_full (SIZE_MAX);
struct Lisp_Bool_Vector *p
= (struct Lisp_Bool_Vector *) allocate_vector (needed_elements);
XSETVECTOR (val, p);
@@ -2403,8 +2439,8 @@ LENGTH must be a number. INIT matters only in whether it is t or nil. */)
{
Lisp_Object val;
- CHECK_NATNUM (length);
- val = make_uninit_bool_vector (XFASTINT (length));
+ CHECK_FIXNAT (length);
+ val = make_uninit_bool_vector (XFIXNAT (length));
return bool_vector_fill (val, init);
}
@@ -2597,7 +2633,8 @@ make_formatted_string (char *buf, const char *format, ...)
&= ~((bits_word) 1 << ((n) % BITS_PER_BITS_WORD)))
#define FLOAT_BLOCK(fptr) \
- ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
+ (eassert (!pdumper_object_p (fptr)), \
+ ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1))))
#define FLOAT_INDEX(fptr) \
((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
@@ -2610,13 +2647,13 @@ struct float_block
struct float_block *next;
};
-#define FLOAT_MARKED_P(fptr) \
+#define XFLOAT_MARKED_P(fptr) \
GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
-#define FLOAT_MARK(fptr) \
+#define XFLOAT_MARK(fptr) \
SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
-#define FLOAT_UNMARK(fptr) \
+#define XFLOAT_UNMARK(fptr) \
UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
/* Current float_block. */
@@ -2655,7 +2692,7 @@ make_float (double float_value)
memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
float_block = new;
float_block_index = 0;
- total_free_floats += FLOAT_BLOCK_SIZE;
+ gcstat.total_free_floats += FLOAT_BLOCK_SIZE;
}
XSETFLOAT (val, &float_block->floats[float_block_index]);
float_block_index++;
@@ -2664,10 +2701,10 @@ make_float (double float_value)
MALLOC_UNBLOCK_INPUT;
XFLOAT_INIT (val, float_value);
- eassert (!FLOAT_MARKED_P (XFLOAT (val)));
+ eassert (!XFLOAT_MARKED_P (XFLOAT (val)));
consing_since_gc += sizeof (struct Lisp_Float);
floats_consed++;
- total_free_floats--;
+ gcstat.total_free_floats--;
return val;
}
@@ -2689,7 +2726,8 @@ make_float (double float_value)
/ (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
#define CONS_BLOCK(fptr) \
- ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
+ (eassert (!pdumper_object_p (fptr)), \
+ ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1))))
#define CONS_INDEX(fptr) \
(((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
@@ -2702,15 +2740,20 @@ struct cons_block
struct cons_block *next;
};
-#define CONS_MARKED_P(fptr) \
+#define XCONS_MARKED_P(fptr) \
GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
-#define CONS_MARK(fptr) \
+#define XMARK_CONS(fptr) \
SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
-#define CONS_UNMARK(fptr) \
+#define XUNMARK_CONS(fptr) \
UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
+/* Minimum number of bytes of consing since GC before next GC,
+ when memory is full. */
+
+byte_ct const memory_full_cons_threshold = sizeof (struct cons_block);
+
/* Current cons_block. */
static struct cons_block *cons_block;
@@ -2732,7 +2775,7 @@ free_cons (struct Lisp_Cons *ptr)
ptr->u.s.car = Vdead;
cons_free_list = ptr;
consing_since_gc -= sizeof *ptr;
- total_free_conses++;
+ gcstat.total_free_conses++;
}
DEFUN ("cons", Fcons, Scons, 2, 2, 0,
@@ -2752,13 +2795,26 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0,
{
if (cons_block_index == CONS_BLOCK_SIZE)
{
+ /* Maximum number of conses that should be active at any
+ given time, so that list lengths fit into a ptrdiff_t and
+ into a fixnum. */
+ ptrdiff_t max_conses = min (PTRDIFF_MAX, MOST_POSITIVE_FIXNUM);
+
+ /* This check is typically optimized away, as a runtime
+ check is needed only on weird platforms where a count of
+ distinct conses might not fit. */
+ if (max_conses < INTPTR_MAX / sizeof (struct Lisp_Cons)
+ && (max_conses - CONS_BLOCK_SIZE
+ < gcstat.total_free_conses + gcstat.total_conses))
+ memory_full (sizeof (struct cons_block));
+
struct cons_block *new
= lisp_align_malloc (sizeof *new, MEM_TYPE_CONS);
memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
new->next = cons_block;
cons_block = new;
cons_block_index = 0;
- total_free_conses += CONS_BLOCK_SIZE;
+ gcstat.total_free_conses += CONS_BLOCK_SIZE;
}
XSETCONS (val, &cons_block->conses[cons_block_index]);
cons_block_index++;
@@ -2768,9 +2824,9 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0,
XSETCAR (val, car);
XSETCDR (val, cdr);
- eassert (!CONS_MARKED_P (XCONS (val)));
+ eassert (!XCONS_MARKED_P (XCONS (val)));
consing_since_gc += sizeof (struct Lisp_Cons);
- total_free_conses--;
+ gcstat.total_free_conses--;
cons_cells_consed++;
return val;
}
@@ -2808,50 +2864,57 @@ list3 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil)));
}
-
Lisp_Object
list4 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4)
{
return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil))));
}
-
Lisp_Object
-list5 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5)
+list5 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4,
+ Lisp_Object arg5)
{
return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4,
Fcons (arg5, Qnil)))));
}
-/* Make a list of COUNT Lisp_Objects, where ARG is the
- first one. Allocate conses from pure space if TYPE
- is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
-
-Lisp_Object
-listn (enum constype type, ptrdiff_t count, Lisp_Object arg, ...)
+/* Make a list of COUNT Lisp_Objects, where ARG is the first one.
+ Use CONS to construct the pairs. AP has any remaining args. */
+static Lisp_Object
+cons_listn (ptrdiff_t count, Lisp_Object arg,
+ Lisp_Object (*cons) (Lisp_Object, Lisp_Object), va_list ap)
{
- Lisp_Object (*cons) (Lisp_Object, Lisp_Object);
- switch (type)
- {
- case CONSTYPE_PURE: cons = pure_cons; break;
- case CONSTYPE_HEAP: cons = Fcons; break;
- default: emacs_abort ();
- }
-
eassume (0 < count);
Lisp_Object val = cons (arg, Qnil);
Lisp_Object tail = val;
-
- va_list ap;
- va_start (ap, arg);
for (ptrdiff_t i = 1; i < count; i++)
{
Lisp_Object elem = cons (va_arg (ap, Lisp_Object), Qnil);
XSETCDR (tail, elem);
tail = elem;
}
+ return val;
+}
+
+/* Make a list of COUNT Lisp_Objects, where ARG1 is the first one. */
+Lisp_Object
+listn (ptrdiff_t count, Lisp_Object arg1, ...)
+{
+ va_list ap;
+ va_start (ap, arg1);
+ Lisp_Object val = cons_listn (count, arg1, Fcons, ap);
va_end (ap);
+ return val;
+}
+/* Make a pure list of COUNT Lisp_Objects, where ARG1 is the first one. */
+Lisp_Object
+pure_listn (ptrdiff_t count, Lisp_Object arg1, ...)
+{
+ va_list ap;
+ va_start (ap, arg1);
+ Lisp_Object val = cons_listn (count, arg1, pure_cons, ap);
+ va_end (ap);
return val;
}
@@ -2878,9 +2941,9 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
(Lisp_Object length, Lisp_Object init)
{
Lisp_Object val = Qnil;
- CHECK_NATNUM (length);
+ CHECK_FIXNAT (length);
- for (EMACS_INT size = XFASTINT (length); 0 < size; size--)
+ for (EMACS_INT size = XFIXNAT (length); 0 < size; size--)
{
val = Fcons (init, val);
rarely_quit (size);
@@ -2903,7 +2966,7 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
static struct Lisp_Vector *
next_vector (struct Lisp_Vector *v)
{
- return XUNTAG (v->contents[0], Lisp_Int0);
+ return XUNTAG (v->contents[0], Lisp_Int0, struct Lisp_Vector);
}
static void
@@ -2916,18 +2979,10 @@ set_next_vector (struct Lisp_Vector *v, struct Lisp_Vector *p)
for the most common cases; it's not required to be a power of two, but
it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
-#define VECTOR_BLOCK_SIZE 4096
-
-/* Alignment of struct Lisp_Vector objects. Because pseudovectors
- can contain any C type, align at least as strictly as
- max_align_t. On x86 and x86-64 this can waste up to 8 bytes
- for typical vectors, since alignof (max_align_t) is 16 but
- typical vectors need only an alignment of 8. However, it is
- not worth the hassle to avoid wasting those bytes. */
-enum {vector_alignment = COMMON_MULTIPLE (alignof (max_align_t), GCALIGNMENT)};
+enum { VECTOR_BLOCK_SIZE = 4096 };
/* Vector size requests are a multiple of this. */
-enum { roundup_size = COMMON_MULTIPLE (vector_alignment, word_size) };
+enum { roundup_size = COMMON_MULTIPLE (LISP_ALIGNMENT, word_size) };
/* Verify assumptions described above. */
verify (VECTOR_BLOCK_SIZE % roundup_size == 0);
@@ -2940,22 +2995,21 @@ verify (VECTOR_BLOCK_SIZE <= (1 << PSEUDOVECTOR_SIZE_BITS));
/* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
-#define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *)))
+enum {VECTOR_BLOCK_BYTES = VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *))};
/* Size of the minimal vector allocated from block. */
-#define VBLOCK_BYTES_MIN vroundup_ct (header_size + sizeof (Lisp_Object))
+enum { VBLOCK_BYTES_MIN = vroundup_ct (header_size + sizeof (Lisp_Object)) };
/* Size of the largest vector allocated from block. */
-#define VBLOCK_BYTES_MAX \
- vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
+enum { VBLOCK_BYTES_MAX = vroundup_ct ((VECTOR_BLOCK_BYTES / 2) - word_size) };
/* We maintain one free list for each possible block-allocated
vector size, and this is the number of free lists we have. */
-#define VECTOR_MAX_FREE_LIST_INDEX \
- ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
+enum { VECTOR_MAX_FREE_LIST_INDEX =
+ (VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1 };
/* Common shortcut to advance vector pointer over a block data. */
@@ -2994,7 +3048,7 @@ struct large_vector
enum
{
- large_vector_offset = ROUNDUP (sizeof (struct large_vector), vector_alignment)
+ large_vector_offset = ROUNDUP (sizeof (struct large_vector), LISP_ALIGNMENT)
};
static struct Lisp_Vector *
@@ -3029,19 +3083,12 @@ static struct large_vector *large_vectors;
Lisp_Object zero_vector;
-/* Number of live vectors. */
-
-static EMACS_INT total_vectors;
-
-/* Total size of live and free vectors, in Lisp_Object units. */
-
-static EMACS_INT total_vector_slots, total_free_vector_slots;
-
/* Common shortcut to setup vector on a free list. */
static void
setup_on_free_list (struct Lisp_Vector *v, ptrdiff_t nbytes)
{
+ v = ptr_bounds_clip (v, nbytes);
eassume (header_size <= nbytes);
ptrdiff_t nwords = (nbytes - header_size) / word_size;
XSETPVECTYPESIZE (v, PVEC_FREE, 0, nwords);
@@ -3050,7 +3097,7 @@ setup_on_free_list (struct Lisp_Vector *v, ptrdiff_t nbytes)
eassert (vindex < VECTOR_MAX_FREE_LIST_INDEX);
set_next_vector (v, vector_free_lists[vindex]);
vector_free_lists[vindex] = v;
- total_free_vector_slots += nbytes / word_size;
+ gcstat.total_free_vector_slots += nbytes / word_size;
}
/* Get a new vector block. */
@@ -3076,19 +3123,20 @@ static void
init_vectors (void)
{
zero_vector = make_pure_vector (0);
+ staticpro (&zero_vector);
}
/* Allocate vector from a vector block. */
static struct Lisp_Vector *
-allocate_vector_from_block (size_t nbytes)
+allocate_vector_from_block (ptrdiff_t nbytes)
{
struct Lisp_Vector *vector;
struct vector_block *block;
size_t index, restbytes;
- eassert (VBLOCK_BYTES_MIN <= nbytes && nbytes <= VBLOCK_BYTES_MAX);
- eassert (nbytes % roundup_size == 0);
+ eassume (VBLOCK_BYTES_MIN <= nbytes && nbytes <= VBLOCK_BYTES_MAX);
+ eassume (nbytes % roundup_size == 0);
/* First, try to allocate from a free list
containing vectors of the requested size. */
@@ -3097,7 +3145,7 @@ allocate_vector_from_block (size_t nbytes)
{
vector = vector_free_lists[index];
vector_free_lists[index] = next_vector (vector);
- total_free_vector_slots -= nbytes / word_size;
+ gcstat.total_free_vector_slots -= nbytes / word_size;
return vector;
}
@@ -3111,7 +3159,7 @@ allocate_vector_from_block (size_t nbytes)
/* This vector is larger than requested. */
vector = vector_free_lists[index];
vector_free_lists[index] = next_vector (vector);
- total_free_vector_slots -= nbytes / word_size;
+ gcstat.total_free_vector_slots -= nbytes / word_size;
/* Excess bytes are used for the smaller vector,
which should be set on an appropriate free list. */
@@ -3146,17 +3194,17 @@ allocate_vector_from_block (size_t nbytes)
/* Return the memory footprint of V in bytes. */
-static ptrdiff_t
-vector_nbytes (struct Lisp_Vector *v)
+ptrdiff_t
+vectorlike_nbytes (const union vectorlike_header *hdr)
{
- ptrdiff_t size = v->header.size & ~ARRAY_MARK_FLAG;
+ ptrdiff_t size = hdr->size & ~ARRAY_MARK_FLAG;
ptrdiff_t nwords;
if (size & PSEUDOVECTOR_FLAG)
{
- if (PSEUDOVECTOR_TYPEP (&v->header, PVEC_BOOL_VECTOR))
+ if (PSEUDOVECTOR_TYPEP (hdr, PVEC_BOOL_VECTOR))
{
- struct Lisp_Bool_Vector *bv = (struct Lisp_Bool_Vector *) v;
+ struct Lisp_Bool_Vector *bv = (struct Lisp_Bool_Vector *) hdr;
ptrdiff_t word_bytes = (bool_vector_words (bv->size)
* sizeof (bits_word));
ptrdiff_t boolvec_bytes = bool_header_size + word_bytes;
@@ -3173,35 +3221,63 @@ vector_nbytes (struct Lisp_Vector *v)
return vroundup (header_size + word_size * nwords);
}
+/* Convert a pseudovector pointer P to its underlying struct T pointer.
+ Verify that the struct is small, since cleanup_vector is called
+ only on small vector-like objects. */
+
+#define PSEUDOVEC_STRUCT(p, t) \
+ verify_expr ((header_size + VECSIZE (struct t) * word_size \
+ <= VBLOCK_BYTES_MAX), \
+ (struct t *) (p))
+
/* Release extra resources still in use by VECTOR, which may be any
- vector-like object. */
+ small vector-like object. */
static void
cleanup_vector (struct Lisp_Vector *vector)
{
detect_suspicious_free (vector);
- if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FONT)
- && ((vector->header.size & PSEUDOVECTOR_SIZE_MASK)
- == FONT_OBJECT_MAX))
- {
- struct font_driver const *drv = ((struct font *) vector)->driver;
- /* The font driver might sometimes be NULL, e.g. if Emacs was
- interrupted before it had time to set it up. */
- if (drv)
+ if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_BIGNUM))
+ mpz_clear (PSEUDOVEC_STRUCT (vector, Lisp_Bignum)->value);
+ else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FINALIZER))
+ unchain_finalizer (PSEUDOVEC_STRUCT (vector, Lisp_Finalizer));
+ else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FONT))
+ {
+ if ((vector->header.size & PSEUDOVECTOR_SIZE_MASK) == FONT_OBJECT_MAX)
{
- /* Attempt to catch subtle bugs like Bug#16140. */
- eassert (valid_font_driver (drv));
- drv->close ((struct font *) vector);
+ struct font *font = PSEUDOVEC_STRUCT (vector, font);
+ struct font_driver const *drv = font->driver;
+
+ /* The font driver might sometimes be NULL, e.g. if Emacs was
+ interrupted before it had time to set it up. */
+ if (drv)
+ {
+ /* Attempt to catch subtle bugs like Bug#16140. */
+ eassert (valid_font_driver (drv));
+ drv->close (font);
+ }
}
}
-
- if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD))
- finalize_one_thread ((struct thread_state *) vector);
+ else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD))
+ finalize_one_thread (PSEUDOVEC_STRUCT (vector, thread_state));
else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX))
- finalize_one_mutex ((struct Lisp_Mutex *) vector);
+ finalize_one_mutex (PSEUDOVEC_STRUCT (vector, Lisp_Mutex));
else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR))
- finalize_one_condvar ((struct Lisp_CondVar *) vector);
+ finalize_one_condvar (PSEUDOVEC_STRUCT (vector, Lisp_CondVar));
+ else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MARKER))
+ {
+ /* sweep_buffer should already have unchained this from its buffer. */
+ eassert (! PSEUDOVEC_STRUCT (vector, Lisp_Marker)->buffer);
+ }
+#ifdef HAVE_MODULES
+ else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_USER_PTR))
+ {
+ struct Lisp_User_Ptr *uptr = PSEUDOVEC_STRUCT (vector, Lisp_User_Ptr);
+ if (uptr->finalizer)
+ uptr->finalizer (uptr->p);
+ }
+#endif
}
/* Reclaim space used by unmarked vectors. */
@@ -3214,48 +3290,43 @@ sweep_vectors (void)
struct large_vector *lv, **lvprev = &large_vectors;
struct Lisp_Vector *vector, *next;
- total_vectors = total_vector_slots = total_free_vector_slots = 0;
+ gcstat.total_vectors = 0;
+ gcstat.total_vector_slots = gcstat.total_free_vector_slots = 0;
memset (vector_free_lists, 0, sizeof (vector_free_lists));
/* Looking through vector blocks. */
for (block = vector_blocks; block; block = *bprev)
{
- bool free_this_block = 0;
- ptrdiff_t nbytes;
+ bool free_this_block = false;
for (vector = (struct Lisp_Vector *) block->data;
VECTOR_IN_BLOCK (vector, block); vector = next)
{
- if (VECTOR_MARKED_P (vector))
+ if (XVECTOR_MARKED_P (vector))
{
- VECTOR_UNMARK (vector);
- total_vectors++;
- nbytes = vector_nbytes (vector);
- total_vector_slots += nbytes / word_size;
+ XUNMARK_VECTOR (vector);
+ gcstat.total_vectors++;
+ ptrdiff_t nbytes = vector_nbytes (vector);
+ gcstat.total_vector_slots += nbytes / word_size;
next = ADVANCE (vector, nbytes);
}
else
{
- ptrdiff_t total_bytes;
-
- cleanup_vector (vector);
- nbytes = vector_nbytes (vector);
- total_bytes = nbytes;
- next = ADVANCE (vector, nbytes);
+ ptrdiff_t total_bytes = 0;
/* While NEXT is not marked, try to coalesce with VECTOR,
thus making VECTOR of the largest possible size. */
- while (VECTOR_IN_BLOCK (next, block))
+ next = vector;
+ do
{
- if (VECTOR_MARKED_P (next))
- break;
cleanup_vector (next);
- nbytes = vector_nbytes (next);
+ ptrdiff_t nbytes = vector_nbytes (next);
total_bytes += nbytes;
next = ADVANCE (next, nbytes);
}
+ while (VECTOR_IN_BLOCK (next, block) && !vector_marked_p (next));
eassert (total_bytes % roundup_size == 0);
@@ -3263,7 +3334,7 @@ sweep_vectors (void)
&& !VECTOR_IN_BLOCK (next, block))
/* This block should be freed because all of its
space was coalesced into the only free vector. */
- free_this_block = 1;
+ free_this_block = true;
else
setup_on_free_list (vector, total_bytes);
}
@@ -3286,15 +3357,14 @@ sweep_vectors (void)
for (lv = large_vectors; lv; lv = *lvprev)
{
vector = large_vector_vec (lv);
- if (VECTOR_MARKED_P (vector))
+ if (XVECTOR_MARKED_P (vector))
{
- VECTOR_UNMARK (vector);
- total_vectors++;
- if (vector->header.size & PSEUDOVECTOR_FLAG)
- total_vector_slots += vector_nbytes (vector) / word_size;
- else
- total_vector_slots
- += header_size / word_size + vector->header.size;
+ XUNMARK_VECTOR (vector);
+ gcstat.total_vectors++;
+ gcstat.total_vector_slots
+ += (vector->header.size & PSEUDOVECTOR_FLAG
+ ? vector_nbytes (vector) / word_size
+ : header_size / word_size + vector->header.size);
lvprev = &lv->next;
}
else
@@ -3305,71 +3375,72 @@ sweep_vectors (void)
}
}
+/* Maximum number of elements in a vector. This is a macro so that it
+ can be used in an integer constant expression. */
+
+#define VECTOR_ELTS_MAX \
+ ((ptrdiff_t) \
+ min (((min (PTRDIFF_MAX, SIZE_MAX) - header_size - large_vector_offset) \
+ / word_size), \
+ MOST_POSITIVE_FIXNUM))
+
/* Value is a pointer to a newly allocated Lisp_Vector structure
- with room for LEN Lisp_Objects. */
+ with room for LEN Lisp_Objects. LEN must be positive and
+ at most VECTOR_ELTS_MAX. */
static struct Lisp_Vector *
allocate_vectorlike (ptrdiff_t len)
{
+ eassert (0 < len && len <= VECTOR_ELTS_MAX);
+ ptrdiff_t nbytes = header_size + len * word_size;
struct Lisp_Vector *p;
MALLOC_BLOCK_INPUT;
- if (len == 0)
- p = XVECTOR (zero_vector);
- else
- {
- size_t nbytes = header_size + len * word_size;
-
#ifdef DOUG_LEA_MALLOC
- if (!mmap_lisp_allowed_p ())
- mallopt (M_MMAP_MAX, 0);
+ if (!mmap_lisp_allowed_p ())
+ mallopt (M_MMAP_MAX, 0);
#endif
- if (nbytes <= VBLOCK_BYTES_MAX)
- p = allocate_vector_from_block (vroundup (nbytes));
- else
- {
- struct large_vector *lv
- = lisp_malloc ((large_vector_offset + header_size
- + len * word_size),
- MEM_TYPE_VECTORLIKE);
- lv->next = large_vectors;
- large_vectors = lv;
- p = large_vector_vec (lv);
- }
+ if (nbytes <= VBLOCK_BYTES_MAX)
+ p = allocate_vector_from_block (vroundup (nbytes));
+ else
+ {
+ struct large_vector *lv = lisp_malloc (large_vector_offset + nbytes,
+ MEM_TYPE_VECTORLIKE);
+ lv->next = large_vectors;
+ large_vectors = lv;
+ p = large_vector_vec (lv);
+ }
#ifdef DOUG_LEA_MALLOC
- if (!mmap_lisp_allowed_p ())
- mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
+ if (!mmap_lisp_allowed_p ())
+ mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
- if (find_suspicious_object_in_range (p, (char *) p + nbytes))
- emacs_abort ();
+ if (find_suspicious_object_in_range (p, (char *) p + nbytes))
+ emacs_abort ();
- consing_since_gc += nbytes;
- vector_cells_consed += len;
- }
+ consing_since_gc += nbytes;
+ vector_cells_consed += len;
MALLOC_UNBLOCK_INPUT;
- return p;
+ return ptr_bounds_clip (p, nbytes);
}
/* Allocate a vector with LEN slots. */
struct Lisp_Vector *
-allocate_vector (EMACS_INT len)
+allocate_vector (ptrdiff_t len)
{
- struct Lisp_Vector *v;
- ptrdiff_t nbytes_max = min (PTRDIFF_MAX, SIZE_MAX);
-
- if (min ((nbytes_max - header_size) / word_size, MOST_POSITIVE_FIXNUM) < len)
+ if (len == 0)
+ return XVECTOR (zero_vector);
+ if (VECTOR_ELTS_MAX < len)
memory_full (SIZE_MAX);
- v = allocate_vectorlike (len);
- if (len)
- v->header.size = len;
+ struct Lisp_Vector *v = allocate_vectorlike (len);
+ v->header.size = len;
return v;
}
@@ -3380,14 +3451,16 @@ struct Lisp_Vector *
allocate_pseudovector (int memlen, int lisplen,
int zerolen, enum pvec_type tag)
{
- struct Lisp_Vector *v = allocate_vectorlike (memlen);
-
/* Catch bogus values. */
+ enum { size_max = (1 << PSEUDOVECTOR_SIZE_BITS) - 1 };
+ enum { rest_max = (1 << PSEUDOVECTOR_REST_BITS) - 1 };
+ verify (size_max + rest_max <= VECTOR_ELTS_MAX);
eassert (0 <= tag && tag <= PVEC_FONT);
eassert (0 <= lisplen && lisplen <= zerolen && zerolen <= memlen);
- eassert (memlen - lisplen <= (1 << PSEUDOVECTOR_REST_BITS) - 1);
- eassert (lisplen <= PSEUDOVECTOR_SIZE_MASK);
+ eassert (lisplen <= size_max);
+ eassert (memlen <= size_max + rest_max);
+ struct Lisp_Vector *v = allocate_vectorlike (memlen);
/* Only the first LISPLEN slots will be traced normally by the GC. */
memclear (v->contents, zerolen * word_size);
XSETPVECTYPESIZE (v, tag, lisplen, memlen - lisplen);
@@ -3431,8 +3504,8 @@ symbol or a type descriptor. SLOTS is the number of non-type slots,
each initialized to INIT. */)
(Lisp_Object type, Lisp_Object slots, Lisp_Object init)
{
- CHECK_NATNUM (slots);
- EMACS_INT size = XFASTINT (slots) + 1;
+ CHECK_FIXNAT (slots);
+ EMACS_INT size = XFIXNAT (slots) + 1;
struct Lisp_Vector *p = allocate_record (size);
p->contents[0] = type;
for (ptrdiff_t i = 1; i < size; i++)
@@ -3460,9 +3533,18 @@ DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
See also the function `vector'. */)
(Lisp_Object length, Lisp_Object init)
{
- CHECK_NATNUM (length);
- struct Lisp_Vector *p = allocate_vector (XFASTINT (length));
- for (ptrdiff_t i = 0; i < XFASTINT (length); i++)
+ CHECK_TYPE (FIXNATP (length) && XFIXNAT (length) <= PTRDIFF_MAX,
+ Qwholenump, length);
+ return make_vector (XFIXNAT (length), init);
+}
+
+/* Return a new vector of length LENGTH with each element being INIT. */
+
+Lisp_Object
+make_vector (ptrdiff_t length, Lisp_Object init)
+{
+ struct Lisp_Vector *p = allocate_vector (length);
+ for (ptrdiff_t i = 0; i < length; i++)
p->contents[i] = init;
return make_lisp_ptr (p, Lisp_Vectorlike);
}
@@ -3616,7 +3698,7 @@ Its value is void, and its function definition and property list are nil. */)
new->next = symbol_block;
symbol_block = new;
symbol_block_index = 0;
- total_free_symbols += SYMBOL_BLOCK_SIZE;
+ gcstat.total_free_symbols += SYMBOL_BLOCK_SIZE;
}
XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]);
symbol_block_index++;
@@ -3627,211 +3709,33 @@ Its value is void, and its function definition and property list are nil. */)
init_symbol (val, name);
consing_since_gc += sizeof (struct Lisp_Symbol);
symbols_consed++;
- total_free_symbols--;
+ gcstat.total_free_symbols--;
return val;
}
-/***********************************************************************
- Marker (Misc) Allocation
- ***********************************************************************/
-
-/* Like union Lisp_Misc, but padded so that its size is a multiple of
- the required alignment. */
-
-union aligned_Lisp_Misc
-{
- union Lisp_Misc m;
- unsigned char c[(sizeof (union Lisp_Misc) + GCALIGNMENT - 1)
- & -GCALIGNMENT];
-};
-
-/* Allocation of markers and other objects that share that structure.
- Works like allocation of conses. */
-
-#define MARKER_BLOCK_SIZE \
- ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
-
-struct marker_block
-{
- /* Place `markers' first, to preserve alignment. */
- union aligned_Lisp_Misc markers[MARKER_BLOCK_SIZE];
- struct marker_block *next;
-};
-
-static struct marker_block *marker_block;
-static int marker_block_index = MARKER_BLOCK_SIZE;
-
-static union Lisp_Misc *marker_free_list;
-
-/* Return a newly allocated Lisp_Misc object of specified TYPE. */
-
-static Lisp_Object
-allocate_misc (enum Lisp_Misc_Type type)
-{
- Lisp_Object val;
-
- MALLOC_BLOCK_INPUT;
-
- if (marker_free_list)
- {
- XSETMISC (val, marker_free_list);
- marker_free_list = marker_free_list->u_free.chain;
- }
- else
- {
- if (marker_block_index == MARKER_BLOCK_SIZE)
- {
- struct marker_block *new = lisp_malloc (sizeof *new, MEM_TYPE_MISC);
- new->next = marker_block;
- marker_block = new;
- marker_block_index = 0;
- total_free_markers += MARKER_BLOCK_SIZE;
- }
- XSETMISC (val, &marker_block->markers[marker_block_index].m);
- marker_block_index++;
- }
-
- MALLOC_UNBLOCK_INPUT;
-
- --total_free_markers;
- consing_since_gc += sizeof (union Lisp_Misc);
- misc_objects_consed++;
- XMISCANY (val)->type = type;
- XMISCANY (val)->gcmarkbit = 0;
- return val;
-}
-
-/* Free a Lisp_Misc object. */
-
-void
-free_misc (Lisp_Object misc)
-{
- XMISCANY (misc)->type = Lisp_Misc_Free;
- XMISC (misc)->u_free.chain = marker_free_list;
- marker_free_list = XMISC (misc);
- consing_since_gc -= sizeof (union Lisp_Misc);
- total_free_markers++;
-}
-
-/* Verify properties of Lisp_Save_Value's representation
- that are assumed here and elsewhere. */
-
-verify (SAVE_UNUSED == 0);
-verify (((SAVE_INTEGER | SAVE_POINTER | SAVE_FUNCPOINTER | SAVE_OBJECT)
- >> SAVE_SLOT_BITS)
- == 0);
-
-/* Return Lisp_Save_Value objects for the various combinations
- that callers need. */
-
-Lisp_Object
-make_save_int_int_int (ptrdiff_t a, ptrdiff_t b, ptrdiff_t c)
-{
- Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
- struct Lisp_Save_Value *p = XSAVE_VALUE (val);
- p->save_type = SAVE_TYPE_INT_INT_INT;
- p->data[0].integer = a;
- p->data[1].integer = b;
- p->data[2].integer = c;
- return val;
-}
-
-Lisp_Object
-make_save_obj_obj_obj_obj (Lisp_Object a, Lisp_Object b, Lisp_Object c,
- Lisp_Object d)
-{
- Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
- struct Lisp_Save_Value *p = XSAVE_VALUE (val);
- p->save_type = SAVE_TYPE_OBJ_OBJ_OBJ_OBJ;
- p->data[0].object = a;
- p->data[1].object = b;
- p->data[2].object = c;
- p->data[3].object = d;
- return val;
-}
-
-Lisp_Object
-make_save_ptr (void *a)
-{
- Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
- struct Lisp_Save_Value *p = XSAVE_VALUE (val);
- p->save_type = SAVE_POINTER;
- p->data[0].pointer = a;
- return val;
-}
-
-Lisp_Object
-make_save_ptr_int (void *a, ptrdiff_t b)
-{
- Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
- struct Lisp_Save_Value *p = XSAVE_VALUE (val);
- p->save_type = SAVE_TYPE_PTR_INT;
- p->data[0].pointer = a;
- p->data[1].integer = b;
- return val;
-}
-
-Lisp_Object
-make_save_ptr_ptr (void *a, void *b)
-{
- Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
- struct Lisp_Save_Value *p = XSAVE_VALUE (val);
- p->save_type = SAVE_TYPE_PTR_PTR;
- p->data[0].pointer = a;
- p->data[1].pointer = b;
- return val;
-}
-
-Lisp_Object
-make_save_funcptr_ptr_obj (void (*a) (void), void *b, Lisp_Object c)
-{
- Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
- struct Lisp_Save_Value *p = XSAVE_VALUE (val);
- p->save_type = SAVE_TYPE_FUNCPTR_PTR_OBJ;
- p->data[0].funcpointer = a;
- p->data[1].pointer = b;
- p->data[2].object = c;
- return val;
-}
-
-/* Return a Lisp_Save_Value object that represents an array A
- of N Lisp objects. */
-
Lisp_Object
-make_save_memory (Lisp_Object *a, ptrdiff_t n)
-{
- Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
- struct Lisp_Save_Value *p = XSAVE_VALUE (val);
- p->save_type = SAVE_TYPE_MEMORY;
- p->data[0].pointer = a;
- p->data[1].integer = n;
- return val;
-}
-
-/* Free a Lisp_Save_Value object. Do not use this function
- if SAVE contains pointer other than returned by xmalloc. */
-
-void
-free_save_value (Lisp_Object save)
+make_misc_ptr (void *a)
{
- xfree (XSAVE_POINTER (save, 0));
- free_misc (save);
+ struct Lisp_Misc_Ptr *p = ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Misc_Ptr,
+ PVEC_MISC_PTR);
+ p->pointer = a;
+ return make_lisp_ptr (p, Lisp_Vectorlike);
}
-/* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
+/* Return a new overlay with specified START, END and PLIST. */
Lisp_Object
build_overlay (Lisp_Object start, Lisp_Object end, Lisp_Object plist)
{
- register Lisp_Object overlay;
-
- overlay = allocate_misc (Lisp_Misc_Overlay);
+ struct Lisp_Overlay *p = ALLOCATE_PSEUDOVECTOR (struct Lisp_Overlay, plist,
+ PVEC_OVERLAY);
+ Lisp_Object overlay = make_lisp_ptr (p, Lisp_Vectorlike);
OVERLAY_START (overlay) = start;
OVERLAY_END (overlay) = end;
set_overlay_plist (overlay, plist);
- XOVERLAY (overlay)->next = NULL;
+ p->next = NULL;
return overlay;
}
@@ -3839,18 +3743,15 @@ DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
doc: /* Return a newly allocated marker which does not point at any place. */)
(void)
{
- register Lisp_Object val;
- register struct Lisp_Marker *p;
-
- val = allocate_misc (Lisp_Misc_Marker);
- p = XMARKER (val);
+ struct Lisp_Marker *p = ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Marker,
+ PVEC_MARKER);
p->buffer = 0;
p->bytepos = 0;
p->charpos = 0;
p->next = NULL;
p->insertion_type = 0;
p->need_adjustment = 0;
- return val;
+ return make_lisp_ptr (p, Lisp_Vectorlike);
}
/* Return a newly allocated marker which points into BUF
@@ -3859,17 +3760,14 @@ DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
Lisp_Object
build_marker (struct buffer *buf, ptrdiff_t charpos, ptrdiff_t bytepos)
{
- Lisp_Object obj;
- struct Lisp_Marker *m;
-
/* No dead buffers here. */
eassert (BUFFER_LIVE_P (buf));
/* Every character is at least one byte. */
eassert (charpos <= bytepos);
- obj = allocate_misc (Lisp_Misc_Marker);
- m = XMARKER (obj);
+ struct Lisp_Marker *m = ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Marker,
+ PVEC_MARKER);
m->buffer = buf;
m->charpos = charpos;
m->bytepos = bytepos;
@@ -3877,7 +3775,7 @@ build_marker (struct buffer *buf, ptrdiff_t charpos, ptrdiff_t bytepos)
m->need_adjustment = 0;
m->next = BUF_MARKERS (buf);
BUF_MARKERS (buf) = m;
- return obj;
+ return make_lisp_ptr (m, Lisp_Vectorlike);
}
@@ -3896,8 +3794,8 @@ make_event_array (ptrdiff_t nargs, Lisp_Object *args)
/* The things that fit in a string
are characters that are in 0...127,
after discarding the meta bit and all the bits above it. */
- if (!INTEGERP (args[i])
- || (XINT (args[i]) & ~(-CHAR_META)) >= 0200)
+ if (!FIXNUMP (args[i])
+ || (XFIXNUM (args[i]) & ~(-CHAR_META)) >= 0200)
return Fvector (nargs, args);
/* Since the loop exited, we know that all the things in it are
@@ -3905,12 +3803,12 @@ make_event_array (ptrdiff_t nargs, Lisp_Object *args)
{
Lisp_Object result;
- result = Fmake_string (make_number (nargs), make_number (0));
+ result = Fmake_string (make_fixnum (nargs), make_fixnum (0), Qnil);
for (i = 0; i < nargs; i++)
{
- SSET (result, i, XINT (args[i]));
+ SSET (result, i, XFIXNUM (args[i]));
/* Move the meta bit to the right place for a string char. */
- if (XINT (args[i]) & CHAR_META)
+ if (XFIXNUM (args[i]) & CHAR_META)
SSET (result, i, SREF (result, i) | 0x80);
}
@@ -3923,14 +3821,11 @@ make_event_array (ptrdiff_t nargs, Lisp_Object *args)
Lisp_Object
make_user_ptr (void (*finalizer) (void *), void *p)
{
- Lisp_Object obj;
- struct Lisp_User_Ptr *uptr;
-
- obj = allocate_misc (Lisp_Misc_User_Ptr);
- uptr = XUSER_PTR (obj);
+ struct Lisp_User_Ptr *uptr
+ = ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_User_Ptr, PVEC_USER_PTR);
uptr->finalizer = finalizer;
uptr->p = p;
- return obj;
+ return make_lisp_ptr (uptr, Lisp_Vectorlike);
}
#endif
@@ -3973,7 +3868,7 @@ mark_finalizer_list (struct Lisp_Finalizer *head)
finalizer != head;
finalizer = finalizer->next)
{
- finalizer->base.gcmarkbit = true;
+ set_vectorlike_marked (&finalizer->header);
mark_object (finalizer->function);
}
}
@@ -3990,7 +3885,8 @@ queue_doomed_finalizers (struct Lisp_Finalizer *dest,
while (finalizer != src)
{
struct Lisp_Finalizer *next = finalizer->next;
- if (!finalizer->base.gcmarkbit && !NILP (finalizer->function))
+ if (!vectorlike_marked_p (&finalizer->header)
+ && !NILP (finalizer->function))
{
unchain_finalizer (finalizer);
finalizer_insert (dest, finalizer);
@@ -4011,6 +3907,9 @@ static void
run_finalizer_function (Lisp_Object function)
{
ptrdiff_t count = SPECPDL_INDEX ();
+#ifdef HAVE_PDUMPER
+ ++number_finalizers_run;
+#endif
specbind (Qinhibit_quit, Qt);
internal_condition_case_1 (call0, function, Qt, run_finalizer_handler);
@@ -4026,7 +3925,6 @@ run_finalizers (struct Lisp_Finalizer *finalizers)
while (finalizers->next != finalizers)
{
finalizer = finalizers->next;
- eassert (finalizer->base.type == Lisp_Misc_Finalizer);
unchain_finalizer (finalizer);
function = finalizer->function;
if (!NILP (function))
@@ -4046,12 +3944,132 @@ count as reachable for the purpose of deciding whether to run
FUNCTION. FUNCTION will be run once per finalizer object. */)
(Lisp_Object function)
{
- Lisp_Object val = allocate_misc (Lisp_Misc_Finalizer);
- struct Lisp_Finalizer *finalizer = XFINALIZER (val);
+ struct Lisp_Finalizer *finalizer
+ = ALLOCATE_PSEUDOVECTOR (struct Lisp_Finalizer, function, PVEC_FINALIZER);
finalizer->function = function;
finalizer->prev = finalizer->next = NULL;
finalizer_insert (&finalizers, finalizer);
- return val;
+ return make_lisp_ptr (finalizer, Lisp_Vectorlike);
+}
+
+
+/************************************************************************
+ Mark bit access functions
+ ************************************************************************/
+
+/* With the rare exception of functions implementing block-based
+ allocation of various types, you should not directly test or set GC
+ mark bits on objects. Some objects might live in special memory
+ regions (e.g., a dump image) and might store their mark bits
+ elsewhere. */
+
+static bool
+vector_marked_p (const struct Lisp_Vector *v)
+{
+ if (pdumper_object_p (v))
+ {
+ /* Look at cold_start first so that we don't have to fault in
+ the vector header just to tell that it's a bool vector. */
+ if (pdumper_cold_object_p (v))
+ {
+ eassert (PSEUDOVECTOR_TYPE (v) == PVEC_BOOL_VECTOR);
+ return true;
+ }
+ return pdumper_marked_p (v);
+ }
+ return XVECTOR_MARKED_P (v);
+}
+
+static void
+set_vector_marked (struct Lisp_Vector *v)
+{
+ if (pdumper_object_p (v))
+ {
+ eassert (PSEUDOVECTOR_TYPE (v) != PVEC_BOOL_VECTOR);
+ pdumper_set_marked (v);
+ }
+ else
+ XMARK_VECTOR (v);
+}
+
+static bool
+vectorlike_marked_p (const union vectorlike_header *header)
+{
+ return vector_marked_p ((const struct Lisp_Vector *) header);
+}
+
+static void
+set_vectorlike_marked (union vectorlike_header *header)
+{
+ set_vector_marked ((struct Lisp_Vector *) header);
+}
+
+static bool
+cons_marked_p (const struct Lisp_Cons *c)
+{
+ return pdumper_object_p (c)
+ ? pdumper_marked_p (c)
+ : XCONS_MARKED_P (c);
+}
+
+static void
+set_cons_marked (struct Lisp_Cons *c)
+{
+ if (pdumper_object_p (c))
+ pdumper_set_marked (c);
+ else
+ XMARK_CONS (c);
+}
+
+static bool
+string_marked_p (const struct Lisp_String *s)
+{
+ return pdumper_object_p (s)
+ ? pdumper_marked_p (s)
+ : XSTRING_MARKED_P (s);
+}
+
+static void
+set_string_marked (struct Lisp_String *s)
+{
+ if (pdumper_object_p (s))
+ pdumper_set_marked (s);
+ else
+ XMARK_STRING (s);
+}
+
+static bool
+symbol_marked_p (const struct Lisp_Symbol *s)
+{
+ return pdumper_object_p (s)
+ ? pdumper_marked_p (s)
+ : s->u.s.gcmarkbit;
+}
+
+static void
+set_symbol_marked (struct Lisp_Symbol *s)
+{
+ if (pdumper_object_p (s))
+ pdumper_set_marked (s);
+ else
+ s->u.s.gcmarkbit = true;
+}
+
+static bool
+interval_marked_p (INTERVAL i)
+{
+ return pdumper_object_p (i)
+ ? pdumper_marked_p (i)
+ : i->gcmarkbit;
+}
+
+static void
+set_interval_marked (INTERVAL i)
+{
+ if (pdumper_object_p (i))
+ pdumper_set_marked (i);
+ else
+ i->gcmarkbit = true;
}
@@ -4071,7 +4089,7 @@ void
memory_full (size_t nbytes)
{
/* Do not go into hysterics merely because a large request failed. */
- bool enough_free_memory = 0;
+ bool enough_free_memory = false;
if (SPARE_MEMORY < nbytes)
{
void *p;
@@ -4081,21 +4099,17 @@ memory_full (size_t nbytes)
if (p)
{
free (p);
- enough_free_memory = 1;
+ enough_free_memory = true;
}
MALLOC_UNBLOCK_INPUT;
}
if (! enough_free_memory)
{
- int i;
-
Vmemory_full = Qt;
- memory_full_cons_threshold = sizeof (struct cons_block);
-
/* The first time we get here, free the spare memory. */
- for (i = 0; i < ARRAYELTS (spare_memory); i++)
+ for (int i = 0; i < ARRAYELTS (spare_memory); i++)
if (spare_memory[i])
{
if (i == 0)
@@ -4561,6 +4575,7 @@ live_string_holding (struct mem_node *m, void *p)
must not be on the free-list. */
if (0 <= offset && offset < STRING_BLOCK_SIZE * sizeof b->strings[0])
{
+ cp = ptr_bounds_copy (cp, b);
struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0];
if (s->u.s.data)
return make_lisp_ptr (s, Lisp_String);
@@ -4595,6 +4610,7 @@ live_cons_holding (struct mem_node *m, void *p)
&& (b != cons_block
|| offset / sizeof b->conses[0] < cons_block_index))
{
+ cp = ptr_bounds_copy (cp, b);
struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0];
if (!EQ (s->u.s.car, Vdead))
return make_lisp_ptr (s, Lisp_Cons);
@@ -4630,6 +4646,7 @@ live_symbol_holding (struct mem_node *m, void *p)
&& (b != symbol_block
|| offset / sizeof b->symbols[0] < symbol_block_index))
{
+ cp = ptr_bounds_copy (cp, b);
struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0];
if (!EQ (s->u.s.function, Vdead))
return make_lisp_symbol (s);
@@ -4669,40 +4686,6 @@ live_float_p (struct mem_node *m, void *p)
return 0;
}
-
-/* If P is a pointer to a live Lisp Misc on the heap, return the object.
- Otherwise, return nil. M is a pointer to the mem_block for P. */
-
-static Lisp_Object
-live_misc_holding (struct mem_node *m, void *p)
-{
- if (m->type == MEM_TYPE_MISC)
- {
- struct marker_block *b = m->start;
- char *cp = p;
- ptrdiff_t offset = cp - (char *) &b->markers[0];
-
- /* P must point into a Lisp_Misc, not be
- one of the unused cells in the current misc block,
- and not be on the free-list. */
- if (0 <= offset && offset < MARKER_BLOCK_SIZE * sizeof b->markers[0]
- && (b != marker_block
- || offset / sizeof b->markers[0] < marker_block_index))
- {
- union Lisp_Misc *s = p = cp -= offset % sizeof b->markers[0];
- if (s->u_any.type != Lisp_Misc_Free)
- return make_lisp_ptr (s, Lisp_Misc);
- }
- }
- return Qnil;
-}
-
-static bool
-live_misc_p (struct mem_node *m, void *p)
-{
- return !NILP (live_misc_holding (m, p));
-}
-
/* If P is a pointer to a live vector-like object, return the object.
Otherwise, return nil.
M is a pointer to the mem_block for P. */
@@ -4784,14 +4767,29 @@ static void
mark_maybe_object (Lisp_Object obj)
{
#if USE_VALGRIND
- if (valgrind_p)
- VALGRIND_MAKE_MEM_DEFINED (&obj, sizeof (obj));
+ VALGRIND_MAKE_MEM_DEFINED (&obj, sizeof (obj));
#endif
- if (INTEGERP (obj))
+ if (FIXNUMP (obj))
return;
void *po = XPNTR (obj);
+
+ /* If the pointer is in the dumped image and the dump has a record
+ of the object starting at the place where the pointer points, we
+ definitely have an object. If the pointer is in the dumped image
+ and the dump has no idea what the pointer is pointing at, we
+ definitely _don't_ have an object. */
+ if (pdumper_object_p (po))
+ {
+ /* Don't use pdumper_object_p_precise here! It doesn't check the
+ tag bits. OBJ here might be complete garbage, so we need to
+ verify both the pointer and the tag. */
+ if (XTYPE (obj) == pdumper_find_object_type (po))
+ mark_object (obj);
+ return;
+ }
+
struct mem_node *m = mem_find (po);
if (m != MEM_NIL)
@@ -4821,10 +4819,6 @@ mark_maybe_object (Lisp_Object obj)
|| EQ (obj, live_buffer_holding (m, po)));
break;
- case Lisp_Misc:
- mark_p = EQ (obj, live_misc_holding (m, po));
- break;
-
default:
break;
}
@@ -4834,14 +4828,23 @@ mark_maybe_object (Lisp_Object obj)
}
}
-/* Return true if P can point to Lisp data, and false otherwise.
+void
+mark_maybe_objects (Lisp_Object const *array, ptrdiff_t nelts)
+{
+ for (Lisp_Object const *lim = array + nelts; array < lim; array++)
+ mark_maybe_object (*array);
+}
+
+/* Return true if P might point to Lisp data that can be garbage
+ collected, and false otherwise (i.e., false if it is easy to see
+ that P cannot point to Lisp data that can be garbage collected).
Symbols are implemented via offsets not pointers, but the offsets
- are also multiples of GCALIGNMENT. */
+ are also multiples of LISP_ALIGNMENT. */
static bool
maybe_lisp_pointer (void *p)
{
- return (uintptr_t) p % GCALIGNMENT == 0;
+ return (uintptr_t) p % LISP_ALIGNMENT == 0;
}
#ifndef HAVE_MODULES
@@ -4856,9 +4859,8 @@ mark_maybe_pointer (void *p)
{
struct mem_node *m;
-#if USE_VALGRIND
- if (valgrind_p)
- VALGRIND_MAKE_MEM_DEFINED (&p, sizeof (p));
+#ifdef USE_VALGRIND
+ VALGRIND_MAKE_MEM_DEFINED (&p, sizeof (p));
#endif
if (sizeof (Lisp_Object) == sizeof (void *) || !HAVE_MODULES)
@@ -4870,7 +4872,18 @@ mark_maybe_pointer (void *p)
{
/* For the wide-int case, also mark emacs_value tagged pointers,
which can be generated by emacs-module.c's value_to_lisp. */
- p = (void *) ((uintptr_t) p & ~(GCALIGNMENT - 1));
+ p = (void *) ((uintptr_t) p & ~((1 << GCTYPEBITS) - 1));
+ }
+
+ if (pdumper_object_p (p))
+ {
+ enum Lisp_Type type = pdumper_find_object_type (p);
+ if (type != PDUMPER_NO_OBJECT)
+ mark_object ((type == Lisp_Symbol)
+ ? make_lisp_symbol(p)
+ : make_lisp_ptr(p, type));
+ /* See mark_maybe_object for why we can confidently return. */
+ return;
}
m = mem_find (p);
@@ -4897,10 +4910,6 @@ mark_maybe_pointer (void *p)
obj = live_string_holding (m, p);
break;
- case MEM_TYPE_MISC:
- obj = live_misc_holding (m, p);
- break;
-
case MEM_TYPE_SYMBOL:
obj = live_symbol_holding (m, p);
break;
@@ -4934,15 +4943,15 @@ mark_maybe_pointer (void *p)
or END+OFFSET..START. */
static void ATTRIBUTE_NO_SANITIZE_ADDRESS
-mark_memory (void *start, void *end)
+mark_memory (void const *start, void const *end)
{
- char *pp;
+ char const *pp;
/* Make START the pointer to the start of the memory region,
if it isn't already. */
if (end < start)
{
- void *tem = start;
+ void const *tem = start;
start = end;
end = tem;
}
@@ -4958,7 +4967,7 @@ mark_memory (void *start, void *end)
{
Lisp_Object obj = build_string ("test");
struct Lisp_String *s = XSTRING (obj);
- Fgarbage_collect ();
+ garbage_collect ();
fprintf (stderr, "test '%s'\n", s->u.s.data);
return Qnil;
}
@@ -4967,14 +4976,14 @@ mark_memory (void *start, void *end)
away. The only reference to the life string is through the
pointer `s'. */
- for (pp = start; (void *) pp < end; pp += GC_POINTER_ALIGNMENT)
+ for (pp = start; (void const *) pp < end; pp += GC_POINTER_ALIGNMENT)
{
- mark_maybe_pointer (*(void **) pp);
+ mark_maybe_pointer (*(void *const *) pp);
verify (alignof (Lisp_Object) % GC_POINTER_ALIGNMENT == 0);
if (alignof (Lisp_Object) == GC_POINTER_ALIGNMENT
|| (uintptr_t) pp % alignof (Lisp_Object) == 0)
- mark_maybe_object (*(Lisp_Object *) pp);
+ mark_maybe_object (*(Lisp_Object const *) pp);
}
}
@@ -5176,7 +5185,7 @@ typedef union
from the stack start. */
void
-mark_stack (char *bottom, char *end)
+mark_stack (char const *bottom, char const *end)
{
/* This assumes that the stack is a contiguous region in memory. If
that's not the case, something has to be done here to iterate
@@ -5233,6 +5242,12 @@ valid_pointer_p (void *p)
return p ? -1 : 0;
int fd[2];
+ static int under_rr_state;
+
+ if (!under_rr_state)
+ under_rr_state = getenv ("RUNNING_UNDER_RR") ? -1 : 1;
+ if (under_rr_state < 0)
+ return under_rr_state;
/* Obviously, we cannot just access it (we would SEGV trying), so we
trick the o/s to tell us whether p is a valid pointer.
@@ -5253,15 +5268,13 @@ valid_pointer_p (void *p)
/* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
- cannot validate OBJ. This function can be quite slow, so its primary
- use is the manual debugging. The only exception is print_object, where
- we use it to check whether the memory referenced by the pointer of
- Lisp_Save_Value object contains valid objects. */
+ cannot validate OBJ. This function can be quite slow, and is used
+ only in debugging. */
int
valid_lisp_object_p (Lisp_Object obj)
{
- if (INTEGERP (obj))
+ if (FIXNUMP (obj))
return 1;
void *p = XPNTR (obj);
@@ -5274,6 +5287,9 @@ valid_lisp_object_p (Lisp_Object obj)
if (p == &buffer_defaults || p == &buffer_local_symbols)
return 2;
+ if (pdumper_object_p (p))
+ return pdumper_object_p_precise (p) ? 1 : 0;
+
struct mem_node *m = mem_find (p);
if (m == MEM_NIL)
@@ -5303,9 +5319,6 @@ valid_lisp_object_p (Lisp_Object obj)
case MEM_TYPE_STRING:
return live_string_p (m, p);
- case MEM_TYPE_MISC:
- return live_misc_p (m, p);
-
case MEM_TYPE_SYMBOL:
return live_symbol_p (m, p);
@@ -5329,7 +5342,8 @@ valid_lisp_object_p (Lisp_Object obj)
/* Allocate room for SIZE bytes from pure Lisp storage and return a
pointer to it. TYPE is the Lisp type for which the memory is
- allocated. TYPE < 0 means it's not used for a Lisp object. */
+ allocated. TYPE < 0 means it's not used for a Lisp object,
+ and that the result should have an alignment of -TYPE. */
static void *
pure_alloc (size_t size, int type)
@@ -5341,20 +5355,23 @@ pure_alloc (size_t size, int type)
{
/* Allocate space for a Lisp object from the beginning of the free
space with taking account of alignment. */
- result = pointer_align (purebeg + pure_bytes_used_lisp, GCALIGNMENT);
+ result = pointer_align (purebeg + pure_bytes_used_lisp, LISP_ALIGNMENT);
pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size;
}
else
{
/* Allocate space for a non-Lisp object from the end of the free
space. */
- pure_bytes_used_non_lisp += size;
- result = purebeg + pure_size - pure_bytes_used_non_lisp;
+ ptrdiff_t unaligned_non_lisp = pure_bytes_used_non_lisp + size;
+ char *unaligned = purebeg + pure_size - unaligned_non_lisp;
+ int decr = (intptr_t) unaligned & (-1 - type);
+ pure_bytes_used_non_lisp = unaligned_non_lisp + decr;
+ result = unaligned - decr;
}
pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp;
if (pure_bytes_used <= pure_size)
- return result;
+ return ptr_bounds_clip (result, size);
/* Don't allocate a large amount here,
because it might get mmap'd and then its address
@@ -5368,7 +5385,7 @@ pure_alloc (size_t size, int type)
}
-#ifndef CANNOT_DUMP
+#ifdef HAVE_UNEXEC
/* Print a warning if PURESIZE is too small. */
@@ -5439,7 +5456,7 @@ find_string_data_in_pure (const char *data, ptrdiff_t nbytes)
/* Check the remaining characters. */
if (memcmp (data, non_lisp_beg + start, nbytes) == 0)
/* Found. */
- return non_lisp_beg + start;
+ return ptr_bounds_clip (non_lisp_beg + start, nbytes + 1);
start += last_char_skip;
}
@@ -5486,7 +5503,7 @@ make_pure_c_string (const char *data, ptrdiff_t nchars)
Lisp_Object string;
struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String);
s->u.s.size = nchars;
- s->u.s.size_byte = -1;
+ s->u.s.size_byte = -2;
s->u.s.data = (unsigned char *) data;
s->u.s.intervals = NULL;
XSETSTRING (string, s);
@@ -5522,6 +5539,33 @@ make_pure_float (double num)
return new;
}
+/* Value is a bignum object with value VALUE allocated from pure
+ space. */
+
+static Lisp_Object
+make_pure_bignum (struct Lisp_Bignum *value)
+{
+ size_t i, nlimbs = mpz_size (value->value);
+ size_t nbytes = nlimbs * sizeof (mp_limb_t);
+ mp_limb_t *pure_limbs;
+ mp_size_t new_size;
+
+ struct Lisp_Bignum *b = pure_alloc (sizeof *b, Lisp_Vectorlike);
+ XSETPVECTYPESIZE (b, PVEC_BIGNUM, 0, VECSIZE (struct Lisp_Bignum));
+
+ int limb_alignment = alignof (mp_limb_t);
+ pure_limbs = pure_alloc (nbytes, - limb_alignment);
+ for (i = 0; i < nlimbs; ++i)
+ pure_limbs[i] = mpz_getlimbn (value->value, i);
+
+ new_size = nlimbs;
+ if (mpz_sgn (value->value) < 0)
+ new_size = -new_size;
+
+ mpz_roinit_n (b->value, pure_limbs, new_size);
+
+ return make_lisp_ptr (b, Lisp_Vectorlike);
+}
/* Return a vector with room for LEN Lisp_Objects allocated from
pure space. */
@@ -5594,8 +5638,8 @@ static struct pinned_object
static Lisp_Object
purecopy (Lisp_Object obj)
{
- if (INTEGERP (obj)
- || (! SYMBOLP (obj) && PURE_P (XPNTR_OR_SYMBOL_OFFSET (obj)))
+ if (FIXNUMP (obj)
+ || (! SYMBOLP (obj) && PURE_P (XPNTR (obj)))
|| SUBRP (obj))
return obj; /* Already pure. */
@@ -5663,6 +5707,8 @@ purecopy (Lisp_Object obj)
/* Don't hash-cons it. */
return obj;
}
+ else if (BIGNUMP (obj))
+ obj = make_pure_bignum (XBIGNUM (obj));
else
{
AUTO_STRING (fmt, "Don't know how to purify: %S");
@@ -5685,8 +5731,10 @@ purecopy (Lisp_Object obj)
VARADDRESS. */
void
-staticpro (Lisp_Object *varaddress)
+staticpro (Lisp_Object const *varaddress)
{
+ for (int i = 0; i < staticidx; i++)
+ eassert (staticvec[i] != varaddress);
if (staticidx >= NSTATICS)
fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
staticvec[staticidx++] = varaddress;
@@ -5704,33 +5752,33 @@ inhibit_garbage_collection (void)
{
ptrdiff_t count = SPECPDL_INDEX ();
- specbind (Qgc_cons_threshold, make_number (MOST_POSITIVE_FIXNUM));
+ specbind (Qgc_cons_threshold, make_fixnum (MOST_POSITIVE_FIXNUM));
return count;
}
-/* Used to avoid possible overflows when
- converting from C to Lisp integers. */
+/* Return the number of bytes in N objects each of size S, guarding
+ against overflow if size_t is narrower than byte_ct. */
-static Lisp_Object
-bounded_number (EMACS_INT number)
+static byte_ct
+object_bytes (object_ct n, size_t s)
{
- return make_number (min (MOST_POSITIVE_FIXNUM, number));
+ byte_ct b = s;
+ return n * b;
}
/* Calculate total bytes of live objects. */
-static size_t
+static byte_ct
total_bytes_of_live_objects (void)
{
- size_t tot = 0;
- tot += total_conses * sizeof (struct Lisp_Cons);
- tot += total_symbols * sizeof (struct Lisp_Symbol);
- tot += total_markers * sizeof (union Lisp_Misc);
- tot += total_string_bytes;
- tot += total_vector_slots * word_size;
- tot += total_floats * sizeof (struct Lisp_Float);
- tot += total_intervals * sizeof (struct interval);
- tot += total_strings * sizeof (struct Lisp_String);
+ byte_ct tot = 0;
+ tot += object_bytes (gcstat.total_conses, sizeof (struct Lisp_Cons));
+ tot += object_bytes (gcstat.total_symbols, sizeof (struct Lisp_Symbol));
+ tot += gcstat.total_string_bytes;
+ tot += object_bytes (gcstat.total_vector_slots, word_size);
+ tot += object_bytes (gcstat.total_floats, sizeof (struct Lisp_Float));
+ tot += object_bytes (gcstat.total_intervals, sizeof (struct interval));
+ tot += object_bytes (gcstat.total_strings, sizeof (struct Lisp_String));
return tot;
}
@@ -5751,7 +5799,7 @@ compact_font_cache_entry (Lisp_Object entry)
/* Consider OBJ if it is (font-spec . [font-entity font-entity ...]). */
if (CONSP (obj) && GC_FONT_SPEC_P (XCAR (obj))
- && !VECTOR_MARKED_P (GC_XFONT_SPEC (XCAR (obj)))
+ && !vectorlike_marked_p (&GC_XFONT_SPEC (XCAR (obj))->header)
/* Don't use VECTORP here, as that calls ASIZE, which could
hit assertion violation during GC. */
&& (VECTORLIKEP (XCDR (obj))
@@ -5767,7 +5815,8 @@ compact_font_cache_entry (Lisp_Object entry)
{
Lisp_Object objlist;
- if (VECTOR_MARKED_P (GC_XFONT_ENTITY (AREF (obj_cdr, i))))
+ if (vectorlike_marked_p (
+ &GC_XFONT_ENTITY (AREF (obj_cdr, i))->header))
break;
objlist = AREF (AREF (obj_cdr, i), FONT_OBJLIST_INDEX);
@@ -5777,7 +5826,7 @@ compact_font_cache_entry (Lisp_Object entry)
struct font *font = GC_XFONT_OBJECT (val);
if (!NILP (AREF (val, FONT_TYPE_INDEX))
- && VECTOR_MARKED_P(font))
+ && vectorlike_marked_p(&font->header))
break;
}
if (CONSP (objlist))
@@ -5846,7 +5895,7 @@ compact_undo_list (Lisp_Object list)
{
if (CONSP (XCAR (tail))
&& MARKERP (XCAR (XCAR (tail)))
- && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
+ && !vectorlike_marked_p (&XMARKER (XCAR (XCAR (tail)))->header))
*prev = XCDR (tail);
else
prev = xcdr_addr (tail);
@@ -5879,29 +5928,122 @@ mark_pinned_symbols (void)
}
}
-/* Subroutine of Fgarbage_collect that does most of the work. It is a
- separate function so that we could limit mark_stack in searching
- the stack frames below this function, thus avoiding the rare cases
- where mark_stack finds values that look like live Lisp objects on
- portions of stack that couldn't possibly contain such live objects.
- For more details of this, see the discussion at
- https://lists.gnu.org/r/emacs-devel/2014-05/msg00270.html. */
-static Lisp_Object
-garbage_collect_1 (void *end)
+static void
+visit_vectorlike_root (struct gc_root_visitor visitor,
+ struct Lisp_Vector *ptr,
+ enum gc_root_type type)
+{
+ ptrdiff_t size = ptr->header.size;
+ ptrdiff_t i;
+
+ if (size & PSEUDOVECTOR_FLAG)
+ size &= PSEUDOVECTOR_SIZE_MASK;
+ for (i = 0; i < size; i++)
+ visitor.visit (&ptr->contents[i], type, visitor.data);
+}
+
+static void
+visit_buffer_root (struct gc_root_visitor visitor,
+ struct buffer *buffer,
+ enum gc_root_type type)
+{
+ /* Buffers that are roots don't have intervals, an undo list, or
+ other constructs that real buffers have. */
+ eassert (buffer->base_buffer == NULL);
+ eassert (buffer->overlays_before == NULL);
+ eassert (buffer->overlays_after == NULL);
+
+ /* Visit the buffer-locals. */
+ visit_vectorlike_root (visitor, (struct Lisp_Vector *) buffer, type);
+}
+
+/* Visit GC roots stored in the Emacs data section. Used by both core
+ GC and by the portable dumping code.
+
+ There are other GC roots of course, but these roots are dynamic
+ runtime data structures that pdump doesn't care about and so we can
+ continue to mark those directly in garbage_collect_1. */
+void
+visit_static_gc_roots (struct gc_root_visitor visitor)
+{
+ visit_buffer_root (visitor,
+ &buffer_defaults,
+ GC_ROOT_BUFFER_LOCAL_DEFAULT);
+ visit_buffer_root (visitor,
+ &buffer_local_symbols,
+ GC_ROOT_BUFFER_LOCAL_NAME);
+
+ for (int i = 0; i < ARRAYELTS (lispsym); i++)
+ {
+ Lisp_Object sptr = builtin_lisp_symbol (i);
+ visitor.visit (&sptr, GC_ROOT_C_SYMBOL, visitor.data);
+ }
+
+ for (int i = 0; i < staticidx; i++)
+ visitor.visit (staticvec[i], GC_ROOT_STATICPRO, visitor.data);
+}
+
+static void
+mark_object_root_visitor (Lisp_Object const *root_ptr,
+ enum gc_root_type type,
+ void *data)
+{
+ mark_object (*root_ptr);
+}
+
+/* List of weak hash tables we found during marking the Lisp heap.
+ Will be NULL on entry to garbage_collect_1 and after it
+ returns. */
+static struct Lisp_Hash_Table *weak_hash_tables;
+
+NO_INLINE /* For better stack traces */
+static void
+mark_and_sweep_weak_table_contents (void)
+{
+ struct Lisp_Hash_Table *h;
+ bool marked;
+
+ /* Mark all keys and values that are in use. Keep on marking until
+ there is no more change. This is necessary for cases like
+ value-weak table A containing an entry X -> Y, where Y is used in a
+ key-weak table B, Z -> Y. If B comes after A in the list of weak
+ tables, X -> Y might be removed from A, although when looking at B
+ one finds that it shouldn't. */
+ do
+ {
+ marked = false;
+ for (h = weak_hash_tables; h; h = h->next_weak)
+ marked |= sweep_weak_table (h, false);
+ }
+ while (marked);
+
+ /* Remove hash table entries that aren't used. */
+ while (weak_hash_tables)
+ {
+ h = weak_hash_tables;
+ weak_hash_tables = h->next_weak;
+ h->next_weak = NULL;
+ sweep_weak_table (h, true);
+ }
+}
+
+/* Subroutine of Fgarbage_collect that does most of the work. */
+static bool
+garbage_collect_1 (struct gcstat *gcst)
{
struct buffer *nextb;
char stack_top_variable;
- ptrdiff_t i;
bool message_p;
ptrdiff_t count = SPECPDL_INDEX ();
struct timespec start;
- Lisp_Object retval = Qnil;
- size_t tot_before = 0;
+ byte_ct tot_before = 0;
+
+ eassert (weak_hash_tables == NULL);
/* Can't GC if pure storage overflowed because we can't determine
if something is a pure object or not. */
if (pure_bytes_used_before_overflow)
- return Qnil;
+ return false;
/* Record this function, so it appears on the profiler's backtraces. */
record_in_backtrace (QAutomatic_GC, 0, 0);
@@ -5937,7 +6079,7 @@ garbage_collect_1 (void *end)
#if MAX_SAVE_STACK > 0
if (NILP (Vpurify_flag))
{
- char *stack;
+ char const *stack;
ptrdiff_t stack_size;
if (&stack_top_variable < stack_bottom)
{
@@ -5956,6 +6098,7 @@ garbage_collect_1 (void *end)
stack_copy = xrealloc (stack_copy, stack_size);
stack_copy_size = stack_size;
}
+ stack = ptr_bounds_set (stack, stack_size);
no_sanitize_memcpy (stack_copy, stack, stack_size);
}
}
@@ -5972,14 +6115,8 @@ garbage_collect_1 (void *end)
/* Mark all the special slots that serve as the roots of accessibility. */
- mark_buffer (&buffer_defaults);
- mark_buffer (&buffer_local_symbols);
-
- for (i = 0; i < ARRAYELTS (lispsym); i++)
- mark_object (builtin_lisp_symbol (i));
-
- for (i = 0; i < staticidx; i++)
- mark_object (*staticvec[i]);
+ struct gc_root_visitor visitor = { .visit = mark_object_root_visitor };
+ visit_static_gc_roots (visitor);
mark_pinned_objects ();
mark_pinned_symbols ();
@@ -6024,11 +6161,13 @@ garbage_collect_1 (void *end)
queue_doomed_finalizers (&doomed_finalizers, &finalizers);
mark_finalizer_list (&doomed_finalizers);
+ /* Must happen after all other marking and before gc_sweep. */
+ mark_and_sweep_weak_table_contents ();
+ eassert (weak_hash_tables == NULL);
+
gc_sweep ();
- /* Clear the mark bits that we set in certain root slots. */
- VECTOR_UNMARK (&buffer_defaults);
- VECTOR_UNMARK (&buffer_local_symbols);
+ unmark_main_thread ();
check_cons_list ();
@@ -6048,10 +6187,10 @@ garbage_collect_1 (void *end)
tot *= XFLOAT_DATA (Vgc_cons_percentage);
if (0 < tot)
{
- if (tot < TYPE_MAXIMUM (EMACS_INT))
+ if (tot < UINTPTR_MAX)
gc_relative_threshold = tot;
else
- gc_relative_threshold = TYPE_MAXIMUM (EMACS_INT);
+ gc_relative_threshold = UINTPTR_MAX;
}
}
@@ -6065,43 +6204,7 @@ garbage_collect_1 (void *end)
unbind_to (count, Qnil);
- Lisp_Object total[] = {
- list4 (Qconses, make_number (sizeof (struct Lisp_Cons)),
- bounded_number (total_conses),
- bounded_number (total_free_conses)),
- list4 (Qsymbols, make_number (sizeof (struct Lisp_Symbol)),
- bounded_number (total_symbols),
- bounded_number (total_free_symbols)),
- list4 (Qmiscs, make_number (sizeof (union Lisp_Misc)),
- bounded_number (total_markers),
- bounded_number (total_free_markers)),
- list4 (Qstrings, make_number (sizeof (struct Lisp_String)),
- bounded_number (total_strings),
- bounded_number (total_free_strings)),
- list3 (Qstring_bytes, make_number (1),
- bounded_number (total_string_bytes)),
- list3 (Qvectors,
- make_number (header_size + sizeof (Lisp_Object)),
- bounded_number (total_vectors)),
- list4 (Qvector_slots, make_number (word_size),
- bounded_number (total_vector_slots),
- bounded_number (total_free_vector_slots)),
- list4 (Qfloats, make_number (sizeof (struct Lisp_Float)),
- bounded_number (total_floats),
- bounded_number (total_free_floats)),
- list4 (Qintervals, make_number (sizeof (struct interval)),
- bounded_number (total_intervals),
- bounded_number (total_free_intervals)),
- list3 (Qbuffers, make_number (sizeof (struct buffer)),
- bounded_number (total_buffers)),
-
-#ifdef DOUG_LEA_MALLOC
- list4 (Qheap, make_number (1024),
- bounded_number ((mallinfo ().uordblks + 1023) >> 10),
- bounded_number ((mallinfo ().fordblks + 1023) >> 10)),
-#endif
- };
- retval = CALLMANY (Flist, total);
+ *gcst = gcstat;
/* GC is complete: now we can run our finalizer callbacks. */
run_finalizers (&doomed_finalizers);
@@ -6126,14 +6229,19 @@ garbage_collect_1 (void *end)
/* Collect profiling data. */
if (profiler_memory_running)
{
- size_t swept = 0;
- size_t tot_after = total_bytes_of_live_objects ();
- if (tot_before > tot_after)
- swept = tot_before - tot_after;
- malloc_probe (swept);
+ byte_ct tot_after = total_bytes_of_live_objects ();
+ byte_ct swept = tot_before <= tot_after ? 0 : tot_before - tot_after;
+ malloc_probe (min (swept, SIZE_MAX));
}
- return retval;
+ return true;
+}
+
+void
+garbage_collect (void)
+{
+ struct gcstat gcst;
+ garbage_collect_1 (&gcst);
}
DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
@@ -6150,13 +6258,47 @@ where each entry has the form (NAME SIZE USED FREE), where:
to return them to the OS).
However, if there was overflow in pure space, `garbage-collect'
returns nil, because real GC can't be done.
-See Info node `(elisp)Garbage Collection'. */
- attributes: noinline)
+See Info node `(elisp)Garbage Collection'. */)
(void)
{
- void *end;
- SET_STACK_TOP_ADDRESS (&end);
- return garbage_collect_1 (end);
+ struct gcstat gcst;
+ if (!garbage_collect_1 (&gcst))
+ return Qnil;
+
+ Lisp_Object total[] = {
+ list4 (Qconses, make_fixnum (sizeof (struct Lisp_Cons)),
+ make_int (gcst.total_conses),
+ make_int (gcst.total_free_conses)),
+ list4 (Qsymbols, make_fixnum (sizeof (struct Lisp_Symbol)),
+ make_int (gcst.total_symbols),
+ make_int (gcst.total_free_symbols)),
+ list4 (Qstrings, make_fixnum (sizeof (struct Lisp_String)),
+ make_int (gcst.total_strings),
+ make_int (gcst.total_free_strings)),
+ list3 (Qstring_bytes, make_fixnum (1),
+ make_int (gcst.total_string_bytes)),
+ list3 (Qvectors,
+ make_fixnum (header_size + sizeof (Lisp_Object)),
+ make_int (gcst.total_vectors)),
+ list4 (Qvector_slots, make_fixnum (word_size),
+ make_int (gcst.total_vector_slots),
+ make_int (gcst.total_free_vector_slots)),
+ list4 (Qfloats, make_fixnum (sizeof (struct Lisp_Float)),
+ make_int (gcst.total_floats),
+ make_int (gcst.total_free_floats)),
+ list4 (Qintervals, make_fixnum (sizeof (struct interval)),
+ make_int (gcst.total_intervals),
+ make_int (gcst.total_free_intervals)),
+ list3 (Qbuffers, make_fixnum (sizeof (struct buffer)),
+ make_int (gcst.total_buffers)),
+
+#ifdef DOUG_LEA_MALLOC
+ list4 (Qheap, make_fixnum (1024),
+ make_int ((mallinfo ().uordblks + 1023) >> 10),
+ make_int ((mallinfo ().fordblks + 1023) >> 10)),
+#endif
+ };
+ return CALLMANY (Flist, total);
}
/* Mark Lisp objects in glyph matrix MATRIX. Currently the
@@ -6179,17 +6321,13 @@ mark_glyph_matrix (struct glyph_matrix *matrix)
for (; glyph < end_glyph; ++glyph)
if (STRINGP (glyph->object)
- && !STRING_MARKED_P (XSTRING (glyph->object)))
+ && !string_marked_p (XSTRING (glyph->object)))
mark_object (glyph->object);
}
}
}
-/* Mark reference to a Lisp_Object.
- If the object referred to has not been seen yet, recursively mark
- all the references contained in it. */
-
-#define LAST_MARKED_SIZE 500
+enum { LAST_MARKED_SIZE = 1 << 9 }; /* Must be a power of 2. */
Lisp_Object last_marked[LAST_MARKED_SIZE] EXTERNALLY_VISIBLE;
static int last_marked_index;
@@ -6200,13 +6338,18 @@ static int last_marked_index;
ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE;
static void
-mark_vectorlike (struct Lisp_Vector *ptr)
+mark_vectorlike (union vectorlike_header *header)
{
+ struct Lisp_Vector *ptr = (struct Lisp_Vector *) header;
ptrdiff_t size = ptr->header.size;
ptrdiff_t i;
- eassert (!VECTOR_MARKED_P (ptr));
- VECTOR_MARK (ptr); /* Else mark it. */
+ eassert (!vector_marked_p (ptr));
+
+ /* Bool vectors have a different case in mark_object. */
+ eassert (PSEUDOVECTOR_TYPE (ptr) != PVEC_BOOL_VECTOR);
+
+ set_vector_marked (ptr); /* Else mark it. */
if (size & PSEUDOVECTOR_FLAG)
size &= PSEUDOVECTOR_SIZE_MASK;
@@ -6229,17 +6372,18 @@ mark_char_table (struct Lisp_Vector *ptr, enum pvec_type pvectype)
/* Consult the Lisp_Sub_Char_Table layout before changing this. */
int i, idx = (pvectype == PVEC_SUB_CHAR_TABLE ? SUB_CHAR_TABLE_OFFSET : 0);
- eassert (!VECTOR_MARKED_P (ptr));
- VECTOR_MARK (ptr);
+ eassert (!vector_marked_p (ptr));
+ set_vector_marked (ptr);
for (i = idx; i < size; i++)
{
Lisp_Object val = ptr->contents[i];
- if (INTEGERP (val) || (SYMBOLP (val) && XSYMBOL (val)->u.s.gcmarkbit))
+ if (FIXNUMP (val) ||
+ (SYMBOLP (val) && symbol_marked_p (XSYMBOL (val))))
continue;
if (SUB_CHAR_TABLE_P (val))
{
- if (! VECTOR_MARKED_P (XVECTOR (val)))
+ if (! vector_marked_p (XVECTOR (val)))
mark_char_table (XVECTOR (val), PVEC_SUB_CHAR_TABLE);
}
else
@@ -6253,7 +6397,7 @@ mark_compiled (struct Lisp_Vector *ptr)
{
int i, size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
- VECTOR_MARK (ptr);
+ set_vector_marked (ptr);
for (i = 0; i < size; i++)
if (i != COMPILED_CONSTANTS)
mark_object (ptr->contents[i]);
@@ -6265,12 +6409,12 @@ mark_compiled (struct Lisp_Vector *ptr)
static void
mark_overlay (struct Lisp_Overlay *ptr)
{
- for (; ptr && !ptr->gcmarkbit; ptr = ptr->next)
+ for (; ptr && !vectorlike_marked_p (&ptr->header); ptr = ptr->next)
{
- ptr->gcmarkbit = 1;
+ set_vectorlike_marked (&ptr->header);
/* These two are always markers and can be marked fast. */
- XMARKER (ptr->start)->gcmarkbit = 1;
- XMARKER (ptr->end)->gcmarkbit = 1;
+ set_vectorlike_marked (&XMARKER (ptr->start)->header);
+ set_vectorlike_marked (&XMARKER (ptr->end)->header);
mark_object (ptr->plist);
}
}
@@ -6281,11 +6425,11 @@ static void
mark_buffer (struct buffer *buffer)
{
/* This is handled much like other pseudovectors... */
- mark_vectorlike ((struct Lisp_Vector *) buffer);
+ mark_vectorlike (&buffer->header);
/* ...but there are some buffer-specific things. */
- MARK_INTERVAL_TREE (buffer_intervals (buffer));
+ mark_interval_tree (buffer_intervals (buffer));
/* For now, we just don't mark the undo_list. It's done later in
a special way just before the sweep phase, and after stripping
@@ -6295,7 +6439,8 @@ mark_buffer (struct buffer *buffer)
mark_overlay (buffer->overlays_after);
/* If this is an indirect buffer, mark its base buffer. */
- if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer))
+ if (buffer->base_buffer &&
+ !vectorlike_marked_p (&buffer->base_buffer->header))
mark_buffer (buffer->base_buffer);
}
@@ -6314,8 +6459,8 @@ mark_face_cache (struct face_cache *c)
if (face)
{
- if (face->font && !VECTOR_MARKED_P (face->font))
- mark_vectorlike ((struct Lisp_Vector *) face->font);
+ if (face->font && !vectorlike_marked_p (&face->font->header))
+ mark_vectorlike (&face->font->header);
for (j = 0; j < LFACE_VECTOR_SIZE; ++j)
mark_object (face->lface[j]);
@@ -6338,30 +6483,6 @@ mark_localized_symbol (struct Lisp_Symbol *ptr)
mark_object (blv->defcell);
}
-NO_INLINE /* To reduce stack depth in mark_object. */
-static void
-mark_save_value (struct Lisp_Save_Value *ptr)
-{
- /* If `save_type' is zero, `data[0].pointer' is the address
- of a memory area containing `data[1].integer' potential
- Lisp_Objects. */
- if (ptr->save_type == SAVE_TYPE_MEMORY)
- {
- Lisp_Object *p = ptr->data[0].pointer;
- ptrdiff_t nelt;
- for (nelt = ptr->data[1].integer; nelt > 0; nelt--, p++)
- mark_maybe_object (*p);
- }
- else
- {
- /* Find Lisp_Objects in `data[N]' slots and mark them. */
- int i;
- for (i = 0; i < SAVE_VALUE_SLOTS; i++)
- if (save_type (ptr, i) == SAVE_OBJECT)
- mark_object (ptr->data[i].object);
- }
-}
-
/* Remove killed buffers or items whose car is a killed buffer from
LIST, and mark other items. Return changed LIST, which is marked. */
@@ -6370,7 +6491,7 @@ mark_discard_killed_buffers (Lisp_Object list)
{
Lisp_Object tail, *prev = &list;
- for (tail = list; CONSP (tail) && !CONS_MARKED_P (XCONS (tail));
+ for (tail = list; CONSP (tail) && !cons_marked_p (XCONS (tail));
tail = XCDR (tail))
{
Lisp_Object tem = XCAR (tail);
@@ -6380,7 +6501,7 @@ mark_discard_killed_buffers (Lisp_Object list)
*prev = XCDR (tail);
else
{
- CONS_MARK (XCONS (tail));
+ set_cons_marked (XCONS (tail));
mark_object (XCAR (tail));
prev = xcdr_addr (tail);
}
@@ -6389,6 +6510,72 @@ mark_discard_killed_buffers (Lisp_Object list)
return list;
}
+static void
+mark_frame (struct Lisp_Vector *ptr)
+{
+ struct frame *f = (struct frame *) ptr;
+ mark_vectorlike (&ptr->header);
+ mark_face_cache (f->face_cache);
+#ifdef HAVE_WINDOW_SYSTEM
+ if (FRAME_WINDOW_P (f) && FRAME_X_OUTPUT (f))
+ {
+ struct font *font = FRAME_FONT (f);
+
+ if (font && !vectorlike_marked_p (&font->header))
+ mark_vectorlike (&font->header);
+ }
+#endif
+}
+
+static void
+mark_window (struct Lisp_Vector *ptr)
+{
+ struct window *w = (struct window *) ptr;
+
+ mark_vectorlike (&ptr->header);
+
+ /* Mark glyph matrices, if any. Marking window
+ matrices is sufficient because frame matrices
+ use the same glyph memory. */
+ if (w->current_matrix)
+ {
+ mark_glyph_matrix (w->current_matrix);
+ mark_glyph_matrix (w->desired_matrix);
+ }
+
+ /* Filter out killed buffers from both buffer lists
+ in attempt to help GC to reclaim killed buffers faster.
+ We can do it elsewhere for live windows, but this is the
+ best place to do it for dead windows. */
+ wset_prev_buffers
+ (w, mark_discard_killed_buffers (w->prev_buffers));
+ wset_next_buffers
+ (w, mark_discard_killed_buffers (w->next_buffers));
+}
+
+static void
+mark_hash_table (struct Lisp_Vector *ptr)
+{
+ struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *) ptr;
+
+ mark_vectorlike (&h->header);
+ mark_object (h->test.name);
+ mark_object (h->test.user_hash_function);
+ mark_object (h->test.user_cmp_function);
+ /* If hash table is not weak, mark all keys and values. For weak
+ tables, mark only the vector and not its contents --- that's what
+ makes it weak. */
+ if (NILP (h->weak))
+ mark_object (h->key_and_value);
+ else
+ {
+ eassert (h->next_weak == NULL);
+ h->next_weak = weak_hash_tables;
+ weak_hash_tables = h;
+ set_vector_marked (XVECTOR (h->key_and_value));
+ }
+}
+
/* Determine type of generic Lisp_Object and mark it accordingly.
This function implements a straightforward depth-first marking
@@ -6403,7 +6590,7 @@ mark_object (Lisp_Object arg)
register Lisp_Object obj;
void *po;
#if GC_CHECK_MARKED_OBJECTS
- struct mem_node *m;
+ struct mem_node *m = NULL;
#endif
ptrdiff_t cdr_count = 0;
@@ -6415,8 +6602,7 @@ mark_object (Lisp_Object arg)
return;
last_marked[last_marked_index++] = obj;
- if (last_marked_index == LAST_MARKED_SIZE)
- last_marked_index = 0;
+ last_marked_index &= LAST_MARKED_SIZE - 1;
/* Perform some sanity checks on the objects marked here. Abort if
we encounter an object we know is bogus. This increases GC time
@@ -6427,6 +6613,12 @@ mark_object (Lisp_Object arg)
structure allocated from the heap. */
#define CHECK_ALLOCATED() \
do { \
+ if (pdumper_object_p(po)) \
+ { \
+ if (!pdumper_object_p_precise (po)) \
+ emacs_abort (); \
+ break; \
+ } \
m = mem_find (po); \
if (m == MEM_NIL) \
emacs_abort (); \
@@ -6436,6 +6628,8 @@ mark_object (Lisp_Object arg)
function LIVEP. */
#define CHECK_LIVE(LIVEP) \
do { \
+ if (pdumper_object_p(po)) \
+ break; \
if (!LIVEP (m, po)) \
emacs_abort (); \
} while (0)
@@ -6470,11 +6664,11 @@ mark_object (Lisp_Object arg)
case Lisp_String:
{
register struct Lisp_String *ptr = XSTRING (obj);
- if (STRING_MARKED_P (ptr))
- break;
+ if (string_marked_p (ptr))
+ break;
CHECK_ALLOCATED_AND_LIVE (live_string_p);
- MARK_STRING (ptr);
- MARK_INTERVAL_TREE (ptr->u.s.intervals);
+ set_string_marked (ptr);
+ mark_interval_tree (ptr->u.s.intervals);
#ifdef GC_CHECK_STRING_BYTES
/* Check that the string size recorded in the string is the
same as the one recorded in the sdata structure. */
@@ -6487,22 +6681,25 @@ mark_object (Lisp_Object arg)
{
register struct Lisp_Vector *ptr = XVECTOR (obj);
- if (VECTOR_MARKED_P (ptr))
+ if (vector_marked_p (ptr))
break;
-#if GC_CHECK_MARKED_OBJECTS
- m = mem_find (po);
- if (m == MEM_NIL && !SUBRP (obj) && !main_thread_p (po))
- emacs_abort ();
+#ifdef GC_CHECK_MARKED_OBJECTS
+ if (!pdumper_object_p(po))
+ {
+ m = mem_find (po);
+ if (m == MEM_NIL && !SUBRP (obj) && !main_thread_p (po))
+ emacs_abort ();
+ }
#endif /* GC_CHECK_MARKED_OBJECTS */
enum pvec_type pvectype
= PSEUDOVECTOR_TYPE (ptr);
- if (pvectype != PVEC_SUBR
- && pvectype != PVEC_BUFFER
- && !main_thread_p (po))
- CHECK_LIVE (live_vector_p);
+ if (pvectype != PVEC_SUBR &&
+ pvectype != PVEC_BUFFER &&
+ !main_thread_p (po))
+ CHECK_LIVE (live_vector_p);
switch (pvectype)
{
@@ -6518,77 +6715,28 @@ mark_object (Lisp_Object arg)
}
#endif /* GC_CHECK_MARKED_OBJECTS */
mark_buffer ((struct buffer *) ptr);
- break;
-
- case PVEC_COMPILED:
- /* Although we could treat this just like a vector, mark_compiled
- returns the COMPILED_CONSTANTS element, which is marked at the
- next iteration of goto-loop here. This is done to avoid a few
- recursive calls to mark_object. */
- obj = mark_compiled (ptr);
- if (!NILP (obj))
- goto loop;
- break;
-
- case PVEC_FRAME:
- {
- struct frame *f = (struct frame *) ptr;
-
- mark_vectorlike (ptr);
- mark_face_cache (f->face_cache);
-#ifdef HAVE_WINDOW_SYSTEM
- if (FRAME_WINDOW_P (f) && FRAME_X_OUTPUT (f))
- {
- struct font *font = FRAME_FONT (f);
-
- if (font && !VECTOR_MARKED_P (font))
- mark_vectorlike ((struct Lisp_Vector *) font);
- }
-#endif
- }
- break;
-
- case PVEC_WINDOW:
- {
- struct window *w = (struct window *) ptr;
-
- mark_vectorlike (ptr);
-
- /* Mark glyph matrices, if any. Marking window
- matrices is sufficient because frame matrices
- use the same glyph memory. */
- if (w->current_matrix)
- {
- mark_glyph_matrix (w->current_matrix);
- mark_glyph_matrix (w->desired_matrix);
- }
-
- /* Filter out killed buffers from both buffer lists
- in attempt to help GC to reclaim killed buffers faster.
- We can do it elsewhere for live windows, but this is the
- best place to do it for dead windows. */
- wset_prev_buffers
- (w, mark_discard_killed_buffers (w->prev_buffers));
- wset_next_buffers
- (w, mark_discard_killed_buffers (w->next_buffers));
- }
- break;
+ break;
+
+ case PVEC_COMPILED:
+ /* Although we could treat this just like a vector, mark_compiled
+ returns the COMPILED_CONSTANTS element, which is marked at the
+ next iteration of goto-loop here. This is done to avoid a few
+ recursive calls to mark_object. */
+ obj = mark_compiled (ptr);
+ if (!NILP (obj))
+ goto loop;
+ break;
+
+ case PVEC_FRAME:
+ mark_frame (ptr);
+ break;
+
+ case PVEC_WINDOW:
+ mark_window (ptr);
+ break;
case PVEC_HASH_TABLE:
- {
- struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *) ptr;
-
- mark_vectorlike (ptr);
- mark_object (h->test.name);
- mark_object (h->test.user_hash_function);
- mark_object (h->test.user_cmp_function);
- /* If hash table is not weak, mark all keys and values.
- For weak tables, mark only the vector. */
- if (NILP (h->weak))
- mark_object (h->key_and_value);
- else
- VECTOR_MARK (XVECTOR (h->key_and_value));
- }
+ mark_hash_table (ptr);
break;
case PVEC_CHAR_TABLE:
@@ -6596,9 +6744,18 @@ mark_object (Lisp_Object arg)
mark_char_table (ptr, (enum pvec_type) pvectype);
break;
- case PVEC_BOOL_VECTOR:
- /* No Lisp_Objects to mark in a bool vector. */
- VECTOR_MARK (ptr);
+ case PVEC_BOOL_VECTOR:
+ /* bool vectors in a dump are permanently "marked", since
+ they're in the old section and don't have mark bits.
+ If we're looking at a dumped bool vector, we should
+ have aborted above when we called vector_marked_p(), so
+ we should never get here. */
+ eassert (!pdumper_object_p (ptr));
+ set_vector_marked (ptr);
+ break;
+
+ case PVEC_OVERLAY:
+ mark_overlay (XOVERLAY (obj));
break;
case PVEC_SUBR:
@@ -6608,7 +6765,9 @@ mark_object (Lisp_Object arg)
emacs_abort ();
default:
- mark_vectorlike (ptr);
+ /* A regular vector, or a pseudovector needing no special
+ treatment. */
+ mark_vectorlike (&ptr->header);
}
}
break;
@@ -6617,10 +6776,10 @@ mark_object (Lisp_Object arg)
{
struct Lisp_Symbol *ptr = XSYMBOL (obj);
nextsym:
- if (ptr->u.s.gcmarkbit)
- break;
- CHECK_ALLOCATED_AND_LIVE_SYMBOL ();
- ptr->u.s.gcmarkbit = 1;
+ if (symbol_marked_p (ptr))
+ break;
+ CHECK_ALLOCATED_AND_LIVE_SYMBOL ();
+ set_symbol_marked(ptr);
/* Attempt to catch bogus objects. */
eassert (valid_lisp_object_p (ptr->u.s.function));
mark_object (ptr->u.s.function);
@@ -6647,8 +6806,8 @@ mark_object (Lisp_Object arg)
default: emacs_abort ();
}
if (!PURE_P (XSTRING (ptr->u.s.name)))
- MARK_STRING (XSTRING (ptr->u.s.name));
- MARK_INTERVAL_TREE (string_intervals (ptr->u.s.name));
+ set_string_marked (XSTRING (ptr->u.s.name));
+ mark_interval_tree (string_intervals (ptr->u.s.name));
/* Inner loop to mark next symbol in this bucket, if any. */
po = ptr = ptr->u.s.next;
if (ptr)
@@ -6656,55 +6815,15 @@ mark_object (Lisp_Object arg)
}
break;
- case Lisp_Misc:
- CHECK_ALLOCATED_AND_LIVE (live_misc_p);
-
- if (XMISCANY (obj)->gcmarkbit)
- break;
-
- switch (XMISCTYPE (obj))
- {
- case Lisp_Misc_Marker:
- /* DO NOT mark thru the marker's chain.
- The buffer's markers chain does not preserve markers from gc;
- instead, markers are removed from the chain when freed by gc. */
- XMISCANY (obj)->gcmarkbit = 1;
- break;
-
- case Lisp_Misc_Save_Value:
- XMISCANY (obj)->gcmarkbit = 1;
- mark_save_value (XSAVE_VALUE (obj));
- break;
-
- case Lisp_Misc_Overlay:
- mark_overlay (XOVERLAY (obj));
- break;
-
- case Lisp_Misc_Finalizer:
- XMISCANY (obj)->gcmarkbit = true;
- mark_object (XFINALIZER (obj)->function);
- break;
-
-#ifdef HAVE_MODULES
- case Lisp_Misc_User_Ptr:
- XMISCANY (obj)->gcmarkbit = true;
- break;
-#endif
-
- default:
- emacs_abort ();
- }
- break;
-
case Lisp_Cons:
{
- register struct Lisp_Cons *ptr = XCONS (obj);
- if (CONS_MARKED_P (ptr))
+ struct Lisp_Cons *ptr = XCONS (obj);
+ if (cons_marked_p (ptr))
break;
CHECK_ALLOCATED_AND_LIVE (live_cons_p);
- CONS_MARK (ptr);
+ set_cons_marked (ptr);
/* If the cdr is nil, avoid recursion for the car. */
- if (EQ (ptr->u.s.u.cdr, Qnil))
+ if (NILP (ptr->u.s.u.cdr))
{
obj = ptr->u.s.car;
cdr_count = 0;
@@ -6720,7 +6839,12 @@ mark_object (Lisp_Object arg)
case Lisp_Float:
CHECK_ALLOCATED_AND_LIVE (live_float_p);
- FLOAT_MARK (XFLOAT (obj));
+ /* Do not mark floats stored in a dump image: these floats are
+ "cold" and do not have mark bits. */
+ if (pdumper_object_p (XFLOAT (obj)))
+ eassert (pdumper_cold_object_p (XFLOAT (obj)));
+ else if (!XFLOAT_MARKED_P (XFLOAT (obj)))
+ XFLOAT_MARK (XFLOAT (obj));
break;
case_Lisp_Int:
@@ -6734,6 +6858,7 @@ mark_object (Lisp_Object arg)
#undef CHECK_ALLOCATED
#undef CHECK_ALLOCATED_AND_LIVE
}
+
/* Mark the Lisp pointers in the terminal objects.
Called by Fgarbage_collect. */
@@ -6750,13 +6875,11 @@ mark_terminals (void)
gets marked. */
mark_image_cache (t->image_cache);
#endif /* HAVE_WINDOW_SYSTEM */
- if (!VECTOR_MARKED_P (t))
- mark_vectorlike ((struct Lisp_Vector *)t);
+ if (!vectorlike_marked_p (&t->header))
+ mark_vectorlike (&t->header);
}
}
-
-
/* Value is non-zero if OBJ will survive the current GC because it's
either marked or does not need to be marked to survive. */
@@ -6768,31 +6891,29 @@ survives_gc_p (Lisp_Object obj)
switch (XTYPE (obj))
{
case_Lisp_Int:
- survives_p = 1;
+ survives_p = true;
break;
case Lisp_Symbol:
- survives_p = XSYMBOL (obj)->u.s.gcmarkbit;
- break;
-
- case Lisp_Misc:
- survives_p = XMISCANY (obj)->gcmarkbit;
+ survives_p = symbol_marked_p (XSYMBOL (obj));
break;
case Lisp_String:
- survives_p = STRING_MARKED_P (XSTRING (obj));
+ survives_p = string_marked_p (XSTRING (obj));
break;
case Lisp_Vectorlike:
- survives_p = SUBRP (obj) || VECTOR_MARKED_P (XVECTOR (obj));
+ survives_p = SUBRP (obj) || vector_marked_p (XVECTOR (obj));
break;
case Lisp_Cons:
- survives_p = CONS_MARKED_P (XCONS (obj));
+ survives_p = cons_marked_p (XCONS (obj));
break;
case Lisp_Float:
- survives_p = FLOAT_MARKED_P (XFLOAT (obj));
+ survives_p =
+ XFLOAT_MARKED_P (XFLOAT (obj)) ||
+ pdumper_object_p (XFLOAT (obj));
break;
default:
@@ -6809,14 +6930,13 @@ NO_INLINE /* For better stack traces */
static void
sweep_conses (void)
{
- struct cons_block *cblk;
struct cons_block **cprev = &cons_block;
int lim = cons_block_index;
- EMACS_INT num_free = 0, num_used = 0;
+ object_ct num_free = 0, num_used = 0;
cons_free_list = 0;
- for (cblk = cons_block; cblk; cblk = *cprev)
+ for (struct cons_block *cblk; (cblk = *cprev); )
{
int i = 0;
int this_free = 0;
@@ -6845,7 +6965,9 @@ sweep_conses (void)
for (pos = start; pos < stop; pos++)
{
- if (!CONS_MARKED_P (&cblk->conses[pos]))
+ struct Lisp_Cons *acons
+ = ptr_bounds_copy (&cblk->conses[pos], cblk);
+ if (!XCONS_MARKED_P (acons))
{
this_free++;
cblk->conses[pos].u.s.u.chain = cons_free_list;
@@ -6855,7 +6977,7 @@ sweep_conses (void)
else
{
num_used++;
- CONS_UNMARK (&cblk->conses[pos]);
+ XUNMARK_CONS (acons);
}
}
}
@@ -6878,37 +7000,38 @@ sweep_conses (void)
cprev = &cblk->next;
}
}
- total_conses = num_used;
- total_free_conses = num_free;
+ gcstat.total_conses = num_used;
+ gcstat.total_free_conses = num_free;
}
NO_INLINE /* For better stack traces */
static void
sweep_floats (void)
{
- register struct float_block *fblk;
struct float_block **fprev = &float_block;
- register int lim = float_block_index;
- EMACS_INT num_free = 0, num_used = 0;
+ int lim = float_block_index;
+ object_ct num_free = 0, num_used = 0;
float_free_list = 0;
- for (fblk = float_block; fblk; fblk = *fprev)
+ for (struct float_block *fblk; (fblk = *fprev); )
{
- register int i;
int this_free = 0;
- for (i = 0; i < lim; i++)
- if (!FLOAT_MARKED_P (&fblk->floats[i]))
- {
- this_free++;
- fblk->floats[i].u.chain = float_free_list;
- float_free_list = &fblk->floats[i];
- }
- else
- {
- num_used++;
- FLOAT_UNMARK (&fblk->floats[i]);
- }
+ for (int i = 0; i < lim; i++)
+ {
+ struct Lisp_Float *afloat = ptr_bounds_copy (&fblk->floats[i], fblk);
+ if (!XFLOAT_MARKED_P (afloat))
+ {
+ this_free++;
+ fblk->floats[i].u.chain = float_free_list;
+ float_free_list = &fblk->floats[i];
+ }
+ else
+ {
+ num_used++;
+ XFLOAT_UNMARK (afloat);
+ }
+ }
lim = FLOAT_BLOCK_SIZE;
/* If this block contains only free floats and we have already
seen more than two blocks worth of free floats then deallocate
@@ -6926,27 +7049,25 @@ sweep_floats (void)
fprev = &fblk->next;
}
}
- total_floats = num_used;
- total_free_floats = num_free;
+ gcstat.total_floats = num_used;
+ gcstat.total_free_floats = num_free;
}
NO_INLINE /* For better stack traces */
static void
sweep_intervals (void)
{
- register struct interval_block *iblk;
struct interval_block **iprev = &interval_block;
- register int lim = interval_block_index;
- EMACS_INT num_free = 0, num_used = 0;
+ int lim = interval_block_index;
+ object_ct num_free = 0, num_used = 0;
interval_free_list = 0;
- for (iblk = interval_block; iblk; iblk = *iprev)
+ for (struct interval_block *iblk; (iblk = *iprev); )
{
- register int i;
int this_free = 0;
- for (i = 0; i < lim; i++)
+ for (int i = 0; i < lim; i++)
{
if (!iblk->intervals[i].gcmarkbit)
{
@@ -6977,8 +7098,8 @@ sweep_intervals (void)
iprev = &iblk->next;
}
}
- total_intervals = num_used;
- total_free_intervals = num_free;
+ gcstat.total_intervals = num_used;
+ gcstat.total_free_intervals = num_free;
}
NO_INLINE /* For better stack traces */
@@ -6988,7 +7109,7 @@ sweep_symbols (void)
struct symbol_block *sblk;
struct symbol_block **sprev = &symbol_block;
int lim = symbol_block_index;
- EMACS_INT num_free = 0, num_used = ARRAYELTS (lispsym);
+ object_ct num_free = 0, num_used = ARRAYELTS (lispsym);
symbol_free_list = NULL;
@@ -7046,100 +7167,48 @@ sweep_symbols (void)
sprev = &sblk->next;
}
}
- total_symbols = num_used;
- total_free_symbols = num_free;
+ gcstat.total_symbols = num_used;
+ gcstat.total_free_symbols = num_free;
}
-NO_INLINE /* For better stack traces. */
+/* Remove BUFFER's markers that are due to be swept. This is needed since
+ we treat BUF_MARKERS and markers's `next' field as weak pointers. */
static void
-sweep_misc (void)
+unchain_dead_markers (struct buffer *buffer)
{
- register struct marker_block *mblk;
- struct marker_block **mprev = &marker_block;
- register int lim = marker_block_index;
- EMACS_INT num_free = 0, num_used = 0;
-
- /* Put all unmarked misc's on free list. For a marker, first
- unchain it from the buffer it points into. */
-
- marker_free_list = 0;
-
- for (mblk = marker_block; mblk; mblk = *mprev)
- {
- register int i;
- int this_free = 0;
-
- for (i = 0; i < lim; i++)
- {
- if (!mblk->markers[i].m.u_any.gcmarkbit)
- {
- if (mblk->markers[i].m.u_any.type == Lisp_Misc_Marker)
- unchain_marker (&mblk->markers[i].m.u_marker);
- else if (mblk->markers[i].m.u_any.type == Lisp_Misc_Finalizer)
- unchain_finalizer (&mblk->markers[i].m.u_finalizer);
-#ifdef HAVE_MODULES
- else if (mblk->markers[i].m.u_any.type == Lisp_Misc_User_Ptr)
- {
- struct Lisp_User_Ptr *uptr = &mblk->markers[i].m.u_user_ptr;
- if (uptr->finalizer)
- uptr->finalizer (uptr->p);
- }
-#endif
- /* Set the type of the freed object to Lisp_Misc_Free.
- We could leave the type alone, since nobody checks it,
- but this might catch bugs faster. */
- mblk->markers[i].m.u_marker.type = Lisp_Misc_Free;
- mblk->markers[i].m.u_free.chain = marker_free_list;
- marker_free_list = &mblk->markers[i].m;
- this_free++;
- }
- else
- {
- num_used++;
- mblk->markers[i].m.u_any.gcmarkbit = 0;
- }
- }
- lim = MARKER_BLOCK_SIZE;
- /* If this block contains only free markers and we have already
- seen more than two blocks worth of free markers then deallocate
- this block. */
- if (this_free == MARKER_BLOCK_SIZE && num_free > MARKER_BLOCK_SIZE)
- {
- *mprev = mblk->next;
- /* Unhook from the free list. */
- marker_free_list = mblk->markers[0].m.u_free.chain;
- lisp_free (mblk);
- }
- else
- {
- num_free += this_free;
- mprev = &mblk->next;
- }
- }
+ struct Lisp_Marker *this, **prev = &BUF_MARKERS (buffer);
- total_markers = num_used;
- total_free_markers = num_free;
+ while ((this = *prev))
+ if (vectorlike_marked_p (&this->header))
+ prev = &this->next;
+ else
+ {
+ this->buffer = NULL;
+ *prev = this->next;
+ }
}
NO_INLINE /* For better stack traces */
static void
sweep_buffers (void)
{
- register struct buffer *buffer, **bprev = &all_buffers;
+ struct buffer *buffer, **bprev = &all_buffers;
- total_buffers = 0;
+ gcstat.total_buffers = 0;
for (buffer = all_buffers; buffer; buffer = *bprev)
- if (!VECTOR_MARKED_P (buffer))
+ if (!vectorlike_marked_p (&buffer->header))
{
*bprev = buffer->next;
lisp_free (buffer);
}
else
{
- VECTOR_UNMARK (buffer);
+ if (!pdumper_object_p (buffer))
+ XUNMARK_VECTOR (buffer);
/* Do not use buffer_(set|get)_intervals here. */
buffer->text->intervals = balance_intervals (buffer->text->intervals);
- total_buffers++;
+ unchain_dead_markers (buffer);
+ gcstat.total_buffers++;
bprev = &buffer->next;
}
}
@@ -7148,19 +7217,15 @@ sweep_buffers (void)
static void
gc_sweep (void)
{
- /* Remove or mark entries in weak hash tables.
- This must be done before any object is unmarked. */
- sweep_weak_hash_tables ();
-
sweep_strings ();
check_string_bytes (!noninteractive);
sweep_conses ();
sweep_floats ();
sweep_intervals ();
sweep_symbols ();
- sweep_misc ();
sweep_buffers ();
sweep_vectors ();
+ pdumper_clear_marks ();
check_string_bytes (!noninteractive);
}
@@ -7214,48 +7279,27 @@ or memory information can't be obtained, return nil. */)
/* Debugging aids. */
-DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, 0,
- doc: /* Return the address of the last byte Emacs has allocated, divided by 1024.
-This may be helpful in debugging Emacs's memory usage.
-We divide the value by 1024 to make sure it fits in a Lisp integer. */)
- (void)
-{
- Lisp_Object end;
-
-#if defined HAVE_NS || defined __APPLE__ || !HAVE_SBRK
- /* Avoid warning. sbrk has no relation to memory allocated anyway. */
- XSETINT (end, 0);
-#else
- XSETINT (end, (intptr_t) (char *) sbrk (0) / 1024);
-#endif
-
- return end;
-}
-
DEFUN ("memory-use-counts", Fmemory_use_counts, Smemory_use_counts, 0, 0, 0,
doc: /* Return a list of counters that measure how much consing there has been.
Each of these counters increments for a certain kind of object.
The counters wrap around from the largest positive integer to zero.
Garbage collection does not decrease them.
The elements of the value are as follows:
- (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
+ (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS INTERVALS STRINGS)
All are in units of 1 = one object consed
except for VECTOR-CELLS and STRING-CHARS, which count the total length of
objects consed.
-MISCS include overlays, markers, and some internal types.
Frames, windows, buffers, and subprocesses count as vectors
(but the contents of a buffer's text do not count here). */)
(void)
{
- return listn (CONSTYPE_HEAP, 8,
- bounded_number (cons_cells_consed),
- bounded_number (floats_consed),
- bounded_number (vector_cells_consed),
- bounded_number (symbols_consed),
- bounded_number (string_chars_consed),
- bounded_number (misc_objects_consed),
- bounded_number (intervals_consed),
- bounded_number (strings_consed));
+ return list (make_int (cons_cells_consed),
+ make_int (floats_consed),
+ make_int (vector_cells_consed),
+ make_int (symbols_consed),
+ make_int (string_chars_consed),
+ make_int (intervals_consed),
+ make_int (strings_consed));
}
static bool
@@ -7318,8 +7362,7 @@ which_symbols (Lisp_Object obj, EMACS_INT find_max)
}
out:
- unbind_to (gc_count, Qnil);
- return found;
+ return unbind_to (gc_count, found);
}
#ifdef SUSPICIOUS_OBJECT_CHECKING
@@ -7434,19 +7477,34 @@ verify_alloca (void)
/* Initialization. */
+static void init_alloc_once_for_pdumper (void);
+
void
init_alloc_once (void)
{
+ gc_cons_threshold = GC_DEFAULT_THRESHOLD;
/* Even though Qt's contents are not set up, its address is known. */
Vpurify_flag = Qt;
- purebeg = PUREBEG;
- pure_size = PURESIZE;
+ PDUMPER_REMEMBER_SCALAR (buffer_defaults.header);
+ PDUMPER_REMEMBER_SCALAR (buffer_local_symbols.header);
+
+ /* Call init_alloc_once_for_pdumper now so we run mem_init early.
+ Keep in mind that when we reload from a dump, we'll run _only_
+ init_alloc_once_for_pdumper and not init_alloc_once at all. */
+ pdumper_do_now_and_after_load (init_alloc_once_for_pdumper);
verify_alloca ();
- init_finalizer_list (&finalizers);
- init_finalizer_list (&doomed_finalizers);
+ init_strings ();
+ init_vectors ();
+}
+
+static void
+init_alloc_once_for_pdumper (void)
+{
+ purebeg = PUREBEG;
+ pure_size = PURESIZE;
mem_init ();
Vdead = make_pure_string ("DEAD", 4, 4, 0);
@@ -7455,11 +7513,11 @@ init_alloc_once (void)
mallopt (M_MMAP_THRESHOLD, 64 * 1024); /* Mmap threshold. */
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* Max. number of mmap'ed areas. */
#endif
- init_strings ();
- init_vectors ();
+
+ init_finalizer_list (&finalizers);
+ init_finalizer_list (&doomed_finalizers);
refill_memory_reserve ();
- gc_cons_threshold = GC_DEFAULT_THRESHOLD;
}
void
@@ -7467,10 +7525,6 @@ init_alloc (void)
{
Vgc_elapsed = make_float (0.0);
gcs_done = 0;
-
-#if USE_VALGRIND
- valgrind_p = RUNNING_ON_VALGRIND != 0;
-#endif
}
void
@@ -7513,11 +7567,6 @@ If this portion is smaller than `gc-cons-threshold', this is ignored. */);
DEFVAR_INT ("string-chars-consed", string_chars_consed,
doc: /* Number of string characters that have been consed so far. */);
- DEFVAR_INT ("misc-objects-consed", misc_objects_consed,
- doc: /* Number of miscellaneous objects that have been consed so far.
-These include markers and overlays, plus certain objects not visible
-to users. */);
-
DEFVAR_INT ("intervals-consed", intervals_consed,
doc: /* Number of intervals that have been consed so far. */);
@@ -7544,8 +7593,10 @@ do hash-consing of the objects allocated to pure space. */);
/* We build this in advance because if we wait until we need it, we might
not be able to allocate the memory to hold it. */
Vmemory_signal_data
- = listn (CONSTYPE_PURE, 2, Qerror,
- build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
+ = pure_list (Qerror,
+ build_pure_c_string ("Memory exhausted--use"
+ " M-x save-some-buffers then"
+ " exit and restart Emacs"));
DEFVAR_LISP ("memory-full", Vmemory_full,
doc: /* Non-nil means Emacs cannot get much more Lisp memory. */);
@@ -7553,7 +7604,6 @@ do hash-consing of the objects allocated to pure space. */);
DEFSYM (Qconses, "conses");
DEFSYM (Qsymbols, "symbols");
- DEFSYM (Qmiscs, "miscs");
DEFSYM (Qstrings, "strings");
DEFSYM (Qvectors, "vectors");
DEFSYM (Qfloats, "floats");
@@ -7573,6 +7623,11 @@ The time is in seconds as a floating point value. */);
DEFVAR_INT ("gcs-done", gcs_done,
doc: /* Accumulated number of garbage collections done. */);
+ DEFVAR_INT ("integer-width", integer_width,
+ doc: /* Maximum number of bits in bignums.
+Integers outside the fixnum range are limited to absolute values less
+than 2**N, where N is this variable's value. N should be nonnegative. */);
+
defsubr (&Scons);
defsubr (&Slist);
defsubr (&Svector);
@@ -7589,12 +7644,17 @@ The time is in seconds as a floating point value. */);
defsubr (&Smake_finalizer);
defsubr (&Spurecopy);
defsubr (&Sgarbage_collect);
- defsubr (&Smemory_limit);
defsubr (&Smemory_info);
defsubr (&Smemory_use_counts);
defsubr (&Ssuspicious_object);
}
+#ifdef HAVE_X_WINDOWS
+enum defined_HAVE_X_WINDOWS { defined_HAVE_X_WINDOWS = true };
+#else
+enum defined_HAVE_X_WINDOWS { defined_HAVE_X_WINDOWS = false };
+#endif
+
/* When compiled with GCC, GDB might say "No enum type named
pvec_type" if we don't have at least one symbol with that type, and
then xbacktrace could fail. Similarly for the other enums and
@@ -7613,5 +7673,6 @@ union
enum MAX_ALLOCA MAX_ALLOCA;
enum More_Lisp_Bits More_Lisp_Bits;
enum pvec_type pvec_type;
+ enum defined_HAVE_X_WINDOWS defined_HAVE_X_WINDOWS;
} const EXTERNALLY_VISIBLE gdb_make_enums_visible = {0};
#endif /* __GNUC__ */
diff --git a/src/atimer.c b/src/atimer.c
index 8723573070e..8387b8aa0e0 100644
--- a/src/atimer.c
+++ b/src/atimer.c
@@ -28,7 +28,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifdef HAVE_TIMERFD
#include <errno.h>
-# include <sys/timerfd.h>
+#include <sys/timerfd.h>
+# ifdef CYGWIN
+# include <sys/utsname.h>
+# endif
#endif
#ifdef MSDOS
@@ -113,10 +116,10 @@ start_atimer (enum atimer_type type, struct timespec timestamp,
sigset_t oldset;
/* Round TIMESTAMP up to the next full second if we don't have itimers. */
-#ifndef HAVE_SETITIMER
+#if ! (defined HAVE_ITIMERSPEC || defined HAVE_SETITIMER)
if (timestamp.tv_nsec != 0 && timestamp.tv_sec < TYPE_MAXIMUM (time_t))
timestamp = make_timespec (timestamp.tv_sec + 1, 0);
-#endif /* not HAVE_SETITIMER */
+#endif
/* Get an atimer structure from the free-list, or allocate
a new one. */
@@ -494,15 +497,14 @@ debug_timer_callback (struct atimer *t)
r->intime = 0;
else if (result >= 0)
{
-#ifdef HAVE_SETITIMER
+ bool intime = true;
+#if defined HAVE_ITIMERSPEC || defined HAVE_SETITIMER
struct timespec delta = timespec_sub (now, r->expected);
/* Too late if later than expected + 0.02s. FIXME:
this should depend from system clock resolution. */
- if (timespec_cmp (delta, make_timespec (0, 20000000)) > 0)
- r->intime = 0;
- else
-#endif /* HAVE_SETITIMER */
- r->intime = 1;
+ intime = timespec_cmp (delta, make_timespec (0, 20000000)) <= 0;
+#endif
+ r->intime = intime;
}
}
@@ -558,13 +560,28 @@ Return t if all self-tests are passed, nil otherwise. */)
#endif /* ENABLE_CHECKING */
+/* Cygwin has the timerfd interface starting with release 3.0.0, but
+ it is buggy until release 3.0.2. */
+#ifdef HAVE_TIMERFD
+static bool
+have_buggy_timerfd (void)
+{
+# ifdef CYGWIN
+ struct utsname name;
+ return uname (&name) < 0 || strverscmp (name.release, "3.0.2") < 0;
+# else
+ return false;
+# endif
+}
+#endif
+
void
init_atimer (void)
{
#ifdef HAVE_ITIMERSPEC
# ifdef HAVE_TIMERFD
/* Until this feature is considered stable, you can ask to not use it. */
- timerfd = (egetenv ("EMACS_IGNORE_TIMERFD") ? -1 :
+ timerfd = (egetenv ("EMACS_IGNORE_TIMERFD") || have_buggy_timerfd () ? -1 :
timerfd_create (CLOCK_REALTIME, TFD_NONBLOCK | TFD_CLOEXEC));
# endif
if (timerfd < 0)
@@ -585,6 +602,7 @@ init_atimer (void)
sigaction (SIGALRM, &action, 0);
#ifdef ENABLE_CHECKING
- defsubr (&Sdebug_timer_check);
+ if (!initialized)
+ defsubr (&Sdebug_timer_check);
#endif
}
diff --git a/src/bidi.c b/src/bidi.c
index 216279cbc3a..c530d49c107 100644
--- a/src/bidi.c
+++ b/src/bidi.c
@@ -1,6 +1,8 @@
/* Low-level bidirectional buffer/string-scanning functions for GNU Emacs.
- Copyright (C) 2000-2001, 2004-2005, 2009-2019 Free Software
- Foundation, Inc.
+
+Copyright (C) 2000-2001, 2004-2005, 2009-2019 Free Software Foundation, Inc.
+
+Author: Eli Zaretskii <eliz@gnu.org>
This file is part of GNU Emacs.
@@ -17,9 +19,7 @@ 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 <https://www.gnu.org/licenses/>. */
-/* Written by Eli Zaretskii <eliz@gnu.org>.
-
- A sequential implementation of the Unicode Bidirectional algorithm,
+/* A sequential implementation of the Unicode Bidirectional algorithm,
(UBA) as per UAX#9, a part of the Unicode Standard.
Unlike the Reference Implementation and most other implementations,
@@ -280,7 +280,7 @@ bidi_get_type (int ch, bidi_dir_t override)
if (ch < 0 || ch > MAX_CHAR)
emacs_abort ();
- default_type = (bidi_type_t) XINT (CHAR_TABLE_REF (bidi_type_table, ch));
+ default_type = (bidi_type_t) XFIXNUM (CHAR_TABLE_REF (bidi_type_table, ch));
/* Every valid character code, even those that are unassigned by the
UCD, have some bidi-class property, according to
DerivedBidiClass.txt file. Therefore, if we ever get UNKNOWN_BT
@@ -379,15 +379,15 @@ bidi_mirror_char (int c)
emacs_abort ();
val = CHAR_TABLE_REF (bidi_mirror_table, c);
- if (INTEGERP (val))
+ if (FIXNUMP (val))
{
int v;
/* When debugging, check before assigning to V, so that the check
isn't broken by undefined behavior due to int overflow. */
- eassert (CHAR_VALID_P (XINT (val)));
+ eassert (CHAR_VALID_P (XFIXNUM (val)));
- v = XINT (val);
+ v = XFIXNUM (val);
/* Minimal test we must do in optimized builds, to prevent weird
crashes further down the road. */
@@ -409,7 +409,7 @@ bidi_paired_bracket_type (int c)
if (c < 0 || c > MAX_CHAR)
emacs_abort ();
- return (bidi_bracket_type_t) XINT (CHAR_TABLE_REF (bidi_brackets_table, c));
+ return (bidi_bracket_type_t) XFIXNUM (CHAR_TABLE_REF (bidi_brackets_table, c));
}
/* Determine the start-of-sequence (sos) directional type given the two
@@ -1805,7 +1805,7 @@ bidi_explicit_dir_char (int ch)
eassert (ch == BIDI_EOB);
return false;
}
- ch_type = (bidi_type_t) XINT (CHAR_TABLE_REF (bidi_type_table, ch));
+ ch_type = (bidi_type_t) XFIXNUM (CHAR_TABLE_REF (bidi_type_table, ch));
return (ch_type == LRE || ch_type == LRO
|| ch_type == RLE || ch_type == RLO
|| ch_type == PDF);
@@ -2335,7 +2335,7 @@ bidi_resolve_weak (struct bidi_it *bidi_it)
and make it L right away, to avoid the
potentially costly loop below. This is
important when the buffer has a long series of
- control characters, like binary nulls, and no
+ control characters, like binary NULs, and no
R2L characters at all. */
&& new_level == 0
&& !bidi_explicit_dir_char (bidi_it->ch)
@@ -2993,7 +2993,7 @@ bidi_resolve_neutral (struct bidi_it *bidi_it)
}
/* The next two "else if" clauses are shortcuts for the
important special case when we have a long sequence of
- neutral or WEAK_BN characters, such as whitespace or nulls or
+ neutral or WEAK_BN characters, such as whitespace or NULs or
other control characters, on the base embedding level of the
paragraph, and that sequence goes all the way to the end of
the paragraph and follows a character whose resolved
diff --git a/src/bignum.c b/src/bignum.c
new file mode 100644
index 00000000000..009d73118c2
--- /dev/null
+++ b/src/bignum.c
@@ -0,0 +1,351 @@
+/* Big numbers for Emacs.
+
+Copyright 2018-2019 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#include "bignum.h"
+
+#include "lisp.h"
+
+#include <math.h>
+#include <stdlib.h>
+
+/* mpz global temporaries. Making them global saves the trouble of
+ properly using mpz_init and mpz_clear on temporaries even when
+ storage is exhausted. Admittedly this is not ideal. An mpz value
+ in a temporary is made permanent by mpz_swapping it with a bignum's
+ value. Although typically at most two temporaries are needed,
+ time_arith, rounddiv_q and rounding_driver each need four. */
+
+mpz_t mpz[4];
+
+static void *
+xrealloc_for_gmp (void *ptr, size_t ignore, size_t size)
+{
+ return xrealloc (ptr, size);
+}
+
+static void
+xfree_for_gmp (void *ptr, size_t ignore)
+{
+ xfree (ptr);
+}
+
+void
+init_bignum (void)
+{
+ eassert (mp_bits_per_limb == GMP_NUMB_BITS);
+ integer_width = 1 << 16;
+ mp_set_memory_functions (xmalloc, xrealloc_for_gmp, xfree_for_gmp);
+
+ for (int i = 0; i < ARRAYELTS (mpz); i++)
+ mpz_init (mpz[i]);
+}
+
+/* Return the value of the Lisp bignum N, as a double. */
+double
+bignum_to_double (Lisp_Object n)
+{
+ return mpz_get_d_rounded (XBIGNUM (n)->value);
+}
+
+/* Return D, converted to a Lisp integer. Discard any fraction.
+ Signal an error if D cannot be converted. */
+Lisp_Object
+double_to_integer (double d)
+{
+ if (!isfinite (d))
+ overflow_error ();
+ mpz_set_d (mpz[0], d);
+ return make_integer_mpz ();
+}
+
+/* Return a Lisp integer equal to mpz[0], which has BITS bits and which
+ must not be in fixnum range. Set mpz[0] to a junk value. */
+static Lisp_Object
+make_bignum_bits (size_t bits)
+{
+ /* The documentation says integer-width should be nonnegative, so
+ a single comparison suffices even though 'bits' is unsigned. */
+ if (integer_width < bits)
+ overflow_error ();
+
+ struct Lisp_Bignum *b = ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Bignum,
+ PVEC_BIGNUM);
+ mpz_init (b->value);
+ mpz_swap (b->value, mpz[0]);
+ return make_lisp_ptr (b, Lisp_Vectorlike);
+}
+
+/* Return a Lisp integer equal to mpz[0], which must not be in fixnum range.
+ Set mpz[0] to a junk value. */
+static Lisp_Object
+make_bignum (void)
+{
+ return make_bignum_bits (mpz_sizeinbase (mpz[0], 2));
+}
+
+/* Return a Lisp integer equal to N, which must not be in fixnum range. */
+Lisp_Object
+make_bigint (intmax_t n)
+{
+ eassert (FIXNUM_OVERFLOW_P (n));
+ mpz_set_intmax (mpz[0], n);
+ return make_bignum ();
+}
+Lisp_Object
+make_biguint (uintmax_t n)
+{
+ eassert (FIXNUM_OVERFLOW_P (n));
+ mpz_set_uintmax (mpz[0], n);
+ return make_bignum ();
+}
+
+/* Return a Lisp integer equal to -N, which must not be in fixnum range. */
+Lisp_Object
+make_neg_biguint (uintmax_t n)
+{
+ eassert (-MOST_NEGATIVE_FIXNUM < n);
+ mpz_set_uintmax (mpz[0], n);
+ mpz_neg (mpz[0], mpz[0]);
+ return make_bignum ();
+}
+
+/* Return a Lisp integer with value taken from mpz[0].
+ Set mpz[0] to a junk value. */
+Lisp_Object
+make_integer_mpz (void)
+{
+ size_t bits = mpz_sizeinbase (mpz[0], 2);
+
+ if (bits <= FIXNUM_BITS)
+ {
+ EMACS_INT v = 0;
+ int i = 0, shift = 0;
+
+ do
+ {
+ EMACS_INT limb = mpz_getlimbn (mpz[0], i++);
+ v += limb << shift;
+ shift += GMP_NUMB_BITS;
+ }
+ while (shift < bits);
+
+ if (mpz_sgn (mpz[0]) < 0)
+ v = -v;
+
+ if (!FIXNUM_OVERFLOW_P (v))
+ return make_fixnum (v);
+ }
+
+ return make_bignum_bits (bits);
+}
+
+/* Set RESULT to V. This code is for when intmax_t is wider than long. */
+void
+mpz_set_intmax_slow (mpz_t result, intmax_t v)
+{
+ int maxlimbs = (INTMAX_WIDTH + GMP_NUMB_BITS - 1) / GMP_NUMB_BITS;
+ mp_limb_t *limb = mpz_limbs_write (result, maxlimbs);
+ int n = 0;
+ uintmax_t u = v;
+ bool negative = v < 0;
+ if (negative)
+ {
+ uintmax_t two = 2;
+ u = -u & ((two << (UINTMAX_WIDTH - 1)) - 1);
+ }
+
+ do
+ {
+ limb[n++] = u;
+ u = GMP_NUMB_BITS < UINTMAX_WIDTH ? u >> GMP_NUMB_BITS : 0;
+ }
+ while (u != 0);
+
+ mpz_limbs_finish (result, negative ? -n : n);
+}
+void
+mpz_set_uintmax_slow (mpz_t result, uintmax_t v)
+{
+ int maxlimbs = (UINTMAX_WIDTH + GMP_NUMB_BITS - 1) / GMP_NUMB_BITS;
+ mp_limb_t *limb = mpz_limbs_write (result, maxlimbs);
+ int n = 0;
+
+ do
+ {
+ limb[n++] = v;
+ v = GMP_NUMB_BITS < INTMAX_WIDTH ? v >> GMP_NUMB_BITS : 0;
+ }
+ while (v != 0);
+
+ mpz_limbs_finish (result, n);
+}
+
+/* If Z fits into *PI, store its value there and return true.
+ Return false otherwise. */
+bool
+mpz_to_intmax (mpz_t const z, intmax_t *pi)
+{
+ ptrdiff_t bits = mpz_sizeinbase (z, 2);
+ bool negative = mpz_sgn (z) < 0;
+
+ if (bits < INTMAX_WIDTH)
+ {
+ intmax_t v = 0;
+ int i = 0, shift = 0;
+
+ do
+ {
+ intmax_t limb = mpz_getlimbn (z, i++);
+ v += limb << shift;
+ shift += GMP_NUMB_BITS;
+ }
+ while (shift < bits);
+
+ *pi = negative ? -v : v;
+ return true;
+ }
+ if (bits == INTMAX_WIDTH && INTMAX_MIN < -INTMAX_MAX && negative
+ && mpz_scan1 (z, 0) == INTMAX_WIDTH - 1)
+ {
+ *pi = INTMAX_MIN;
+ return true;
+ }
+ return false;
+}
+bool
+mpz_to_uintmax (mpz_t const z, uintmax_t *pi)
+{
+ if (mpz_sgn (z) < 0)
+ return false;
+ ptrdiff_t bits = mpz_sizeinbase (z, 2);
+ if (UINTMAX_WIDTH < bits)
+ return false;
+
+ uintmax_t v = 0;
+ int i = 0, shift = 0;
+
+ do
+ {
+ uintmax_t limb = mpz_getlimbn (z, i++);
+ v += limb << shift;
+ shift += GMP_NUMB_BITS;
+ }
+ while (shift < bits);
+
+ *pi = v;
+ return true;
+}
+
+/* Return the value of the bignum X if it fits, 0 otherwise.
+ A bignum cannot be zero, so 0 indicates failure reliably. */
+intmax_t
+bignum_to_intmax (Lisp_Object x)
+{
+ intmax_t i;
+ return mpz_to_intmax (XBIGNUM (x)->value, &i) ? i : 0;
+}
+uintmax_t
+bignum_to_uintmax (Lisp_Object x)
+{
+ uintmax_t i;
+ return mpz_to_uintmax (XBIGNUM (x)->value, &i) ? i : 0;
+}
+
+/* Yield an upper bound on the buffer size needed to contain a C
+ string representing the NUM in base BASE. This includes any
+ preceding '-' and the terminating NUL. */
+static ptrdiff_t
+mpz_bufsize (mpz_t const num, int base)
+{
+ return mpz_sizeinbase (num, base) + 2;
+}
+ptrdiff_t
+bignum_bufsize (Lisp_Object num, int base)
+{
+ return mpz_bufsize (XBIGNUM (num)->value, base);
+}
+
+/* Convert NUM to a nearest double, as opposed to mpz_get_d which
+ truncates toward zero. */
+double
+mpz_get_d_rounded (mpz_t const num)
+{
+ ptrdiff_t size = mpz_bufsize (num, 10);
+
+ /* Use mpz_get_d as a shortcut for a bignum so small that rounding
+ errors cannot occur, which is possible if EMACS_INT (not counting
+ sign) has fewer bits than a double significand. */
+ if (! ((FLT_RADIX == 2 && DBL_MANT_DIG <= FIXNUM_BITS - 1)
+ || (FLT_RADIX == 16 && DBL_MANT_DIG * 4 <= FIXNUM_BITS - 1))
+ && size <= DBL_DIG + 2)
+ return mpz_get_d (num);
+
+ USE_SAFE_ALLOCA;
+ char *buf = SAFE_ALLOCA (size);
+ mpz_get_str (buf, 10, num);
+ double result = strtod (buf, NULL);
+ SAFE_FREE ();
+ return result;
+}
+
+/* Store into BUF (of size SIZE) the value of NUM as a base-BASE string.
+ If BASE is negative, use upper-case digits in base -BASE.
+ Return the string's length.
+ SIZE must equal bignum_bufsize (NUM, abs (BASE)). */
+ptrdiff_t
+bignum_to_c_string (char *buf, ptrdiff_t size, Lisp_Object num, int base)
+{
+ eassert (bignum_bufsize (num, abs (base)) == size);
+ mpz_get_str (buf, base, XBIGNUM (num)->value);
+ ptrdiff_t n = size - 2;
+ return !buf[n - 1] ? n - 1 : n + !!buf[n];
+}
+
+/* Convert NUM to a base-BASE Lisp string.
+ If BASE is negative, use upper-case digits in base -BASE. */
+
+Lisp_Object
+bignum_to_string (Lisp_Object num, int base)
+{
+ ptrdiff_t size = bignum_bufsize (num, abs (base));
+ USE_SAFE_ALLOCA;
+ char *str = SAFE_ALLOCA (size);
+ ptrdiff_t len = bignum_to_c_string (str, size, num, base);
+ Lisp_Object result = make_unibyte_string (str, len);
+ SAFE_FREE ();
+ return result;
+}
+
+/* Create a bignum by scanning NUM, with digits in BASE.
+ NUM must consist of an optional '-', a nonempty sequence
+ of base-BASE digits, and a terminating NUL byte, and
+ the represented number must not be in fixnum range. */
+
+Lisp_Object
+make_bignum_str (char const *num, int base)
+{
+ struct Lisp_Bignum *b = ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Bignum,
+ PVEC_BIGNUM);
+ mpz_init (b->value);
+ int check = mpz_set_str (b->value, num, base);
+ eassert (check == 0);
+ return make_lisp_ptr (b, Lisp_Vectorlike);
+}
diff --git a/src/bignum.h b/src/bignum.h
new file mode 100644
index 00000000000..4c670bd906f
--- /dev/null
+++ b/src/bignum.h
@@ -0,0 +1,99 @@
+/* Big numbers for Emacs.
+
+Copyright 2018-2019 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 <https://www.gnu.org/licenses/>. */
+
+/* Include this header only if access to bignum internals is needed. */
+
+#ifndef BIGNUM_H
+#define BIGNUM_H
+
+#ifdef HAVE_GMP
+# include <gmp.h>
+#else
+# include "mini-gmp.h"
+#endif
+
+#include "lisp.h"
+
+/* Number of data bits in a limb. */
+#ifndef GMP_NUMB_BITS
+enum { GMP_NUMB_BITS = TYPE_WIDTH (mp_limb_t) };
+#endif
+
+struct Lisp_Bignum
+{
+ union vectorlike_header header;
+ mpz_t value;
+} GCALIGNED_STRUCT;
+
+extern mpz_t mpz[4];
+
+extern void init_bignum (void);
+extern Lisp_Object make_integer_mpz (void);
+extern bool mpz_to_intmax (mpz_t const, intmax_t *) ARG_NONNULL ((1, 2));
+extern bool mpz_to_uintmax (mpz_t const, uintmax_t *) ARG_NONNULL ((1, 2));
+extern void mpz_set_intmax_slow (mpz_t, intmax_t) ARG_NONNULL ((1));
+extern void mpz_set_uintmax_slow (mpz_t, uintmax_t) ARG_NONNULL ((1));
+extern double mpz_get_d_rounded (mpz_t const);
+
+INLINE_HEADER_BEGIN
+
+INLINE struct Lisp_Bignum *
+XBIGNUM (Lisp_Object a)
+{
+ eassert (BIGNUMP (a));
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Bignum);
+}
+
+INLINE void ARG_NONNULL ((1))
+mpz_set_intmax (mpz_t result, intmax_t v)
+{
+ /* mpz_set_si works in terms of long, but Emacs may use a wider
+ integer type, and so sometimes will have to construct the mpz_t
+ by hand. */
+ if (LONG_MIN <= v && v <= LONG_MAX)
+ mpz_set_si (result, v);
+ else
+ mpz_set_intmax_slow (result, v);
+}
+INLINE void ARG_NONNULL ((1))
+mpz_set_uintmax (mpz_t result, uintmax_t v)
+{
+ if (v <= ULONG_MAX)
+ mpz_set_ui (result, v);
+ else
+ mpz_set_uintmax_slow (result, v);
+}
+
+/* Return a pointer to an mpz_t that is equal to the Lisp integer I.
+ If I is a bignum this returns a pointer to I's representation;
+ otherwise this sets *TMP to I's value and returns TMP. */
+INLINE mpz_t *
+bignum_integer (mpz_t *tmp, Lisp_Object i)
+{
+ if (FIXNUMP (i))
+ {
+ mpz_set_intmax (*tmp, XFIXNUM (i));
+ return tmp;
+ }
+ return &XBIGNUM (i)->value;
+}
+
+INLINE_HEADER_END
+
+#endif /* BIGNUM_H */
diff --git a/src/buffer.c b/src/buffer.c
index 12620f0d4aa..ab477481912 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -37,6 +37,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "window.h"
#include "commands.h"
#include "character.h"
+#include "coding.h"
#include "buffer.h"
#include "region-cache.h"
#include "indent.h"
@@ -44,6 +45,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "keymap.h"
#include "frame.h"
#include "xwidget.h"
+#include "pdumper.h"
#ifdef WINDOWSNT
#include "w32heap.h" /* for mmap_* */
@@ -466,7 +468,7 @@ See also `find-buffer-visiting'. */)
filename = Fexpand_file_name (filename, Qnil);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (filename, Qget_file_buffer);
if (!NILP (handler))
{
@@ -529,6 +531,8 @@ even if it is dead. The return value is never nil. */)
/* No one shows us now. */
b->window_count = 0;
+ memset (&b->local_flags, 0, sizeof (b->local_flags));
+
BUF_GAP_SIZE (b) = 20;
block_input ();
/* We allocate extra 1-byte at the tail and keep it always '\0' for
@@ -580,6 +584,11 @@ even if it is dead. The return value is never nil. */)
set_string_intervals (name, NULL);
bset_name (b, name);
+ b->inhibit_buffer_hooks
+ = (STRINGP (Vcode_conversion_workbuf_name)
+ && strncmp (SSDATA (name), SSDATA (Vcode_conversion_workbuf_name),
+ SBYTES (Vcode_conversion_workbuf_name)) == 0);
+
bset_undo_list (b, SREF (name, 0) != ' ' ? Qnil : Qt);
reset_buffer (b);
@@ -592,7 +601,7 @@ even if it is dead. The return value is never nil. */)
XSETBUFFER (buffer, b);
Vbuffer_alist = nconc2 (Vbuffer_alist, list1 (Fcons (name, buffer)));
/* And run buffer-list-update-hook. */
- if (!NILP (Vrun_hooks))
+ if (!NILP (Vrun_hooks) && !b->inhibit_buffer_hooks)
call1 (Vrun_hooks, Qbuffer_list_update_hook);
return buffer;
@@ -781,6 +790,8 @@ CLONE nil means the indirect buffer's state is reset to default values. */)
/* Always -1 for an indirect buffer. */
b->window_count = -1;
+ memset (&b->local_flags, 0, sizeof (b->local_flags));
+
b->pt = b->base_buffer->pt;
b->begv = b->base_buffer->begv;
b->zv = b->base_buffer->zv;
@@ -849,7 +860,7 @@ CLONE nil means the indirect buffer's state is reset to default values. */)
clone_per_buffer_values (b->base_buffer, b);
bset_filename (b, Qnil);
bset_file_truename (b, Qnil);
- bset_display_count (b, make_number (0));
+ bset_display_count (b, make_fixnum (0));
bset_backed_up (b, Qnil);
bset_auto_save_file_name (b, Qnil);
set_buffer_internal_1 (b);
@@ -939,7 +950,7 @@ reset_buffer (register struct buffer *b)
bset_file_format (b, Qnil);
bset_auto_save_file_format (b, Qt);
bset_last_selected_window (b, Qnil);
- bset_display_count (b, make_number (0));
+ bset_display_count (b, make_fixnum (0));
bset_display_time (b, Qnil);
bset_enable_multibyte_characters
(b, BVAR (&buffer_defaults, enable_multibyte_characters));
@@ -1102,8 +1113,8 @@ is first appended to NAME, to speed up finding a non-existent buffer. */)
{
char number[sizeof "-999999"];
- /* Use XINT instead of XFASTINT to work around GCC bug 80776. */
- int i = XINT (Frandom (make_number (1000000)));
+ /* Use XFIXNUM instead of XFIXNAT to work around GCC bug 80776. */
+ int i = XFIXNUM (Frandom (make_fixnum (1000000)));
eassume (0 <= i && i < 1000000);
AUTO_STRING_WITH_LEN (lnumber, number, sprintf (number, "-%d", i));
@@ -1196,7 +1207,7 @@ buffer_local_value (Lisp_Object variable, Lisp_Object buffer)
result = Fassoc (variable, BVAR (buf, local_var_alist), Qnil);
if (!NILP (result))
{
- if (blv->fwd)
+ if (blv->fwd.fwdptr)
{ /* What binding is loaded right now? */
Lisp_Object current_alist_element = blv->valcell;
@@ -1217,7 +1228,7 @@ buffer_local_value (Lisp_Object variable, Lisp_Object buffer)
}
case SYMBOL_FORWARDED:
{
- union Lisp_Fwd *fwd = SYMBOL_FWD (sym);
+ lispfwd fwd = SYMBOL_FWD (sym);
if (BUFFER_OBJFWDP (fwd))
result = per_buffer_value (buf, XBUFFER_OBJFWD (fwd)->offset);
else
@@ -1408,7 +1419,7 @@ state of the current buffer. Use with care. */)
/* If SAVE_MODIFF == auto_save_modified == MODIFF,
we can either decrease SAVE_MODIFF and auto_save_modified
or increase MODIFF. */
- : MODIFF++);
+ : modiff_incr (&MODIFF));
return flag;
}
@@ -1417,11 +1428,11 @@ DEFUN ("buffer-modified-tick", Fbuffer_modified_tick, Sbuffer_modified_tick,
0, 1, 0,
doc: /* Return BUFFER's tick counter, incremented for each change in text.
Each buffer has a tick counter which is incremented each time the
-text in that buffer is changed. It wraps around occasionally.
-No argument or nil as argument means use current buffer as BUFFER. */)
- (register Lisp_Object buffer)
+text in that buffer is changed. No argument or nil as argument means
+use current buffer as BUFFER. */)
+ (Lisp_Object buffer)
{
- return make_number (BUF_MODIFF (decode_buffer (buffer)));
+ return modiff_to_integer (BUF_MODIFF (decode_buffer (buffer)));
}
DEFUN ("buffer-chars-modified-tick", Fbuffer_chars_modified_tick,
@@ -1434,9 +1445,9 @@ values returned by two individual calls of `buffer-chars-modified-tick',
you can tell whether a character change occurred in that buffer in
between these calls. No argument or nil as argument means use current
buffer as BUFFER. */)
- (register Lisp_Object buffer)
+ (Lisp_Object buffer)
{
- return make_number (BUF_CHARS_MODIFF (decode_buffer (buffer)));
+ return modiff_to_integer (BUF_CHARS_MODIFF (decode_buffer (buffer)));
}
DEFUN ("rename-buffer", Frename_buffer, Srename_buffer, 1, 2,
@@ -1488,7 +1499,7 @@ This does not change the name of the visited file (if any). */)
call0 (intern ("rename-auto-save-file"));
/* Run buffer-list-update-hook. */
- if (!NILP (Vrun_hooks))
+ if (!NILP (Vrun_hooks) && !current_buffer->inhibit_buffer_hooks)
call1 (Vrun_hooks, Qbuffer_list_update_hook);
/* Refetch since that last call may have done GC. */
@@ -1696,15 +1707,18 @@ cleaning up all windows currently displaying the buffer to be killed. */)
{
ptrdiff_t count = SPECPDL_INDEX ();
- record_unwind_protect (save_excursion_restore, save_excursion_save ());
+ record_unwind_protect_excursion ();
set_buffer_internal (b);
/* First run the query functions; if any query is answered no,
don't kill the buffer. */
- tem = CALLN (Frun_hook_with_args_until_failure,
- Qkill_buffer_query_functions);
- if (NILP (tem))
- return unbind_to (count, Qnil);
+ if (!b->inhibit_buffer_hooks)
+ {
+ tem = CALLN (Frun_hook_with_args_until_failure,
+ Qkill_buffer_query_functions);
+ if (NILP (tem))
+ return unbind_to (count, Qnil);
+ }
/* Query if the buffer is still modified. */
if (INTERACTIVE && !NILP (BVAR (b, filename))
@@ -1721,7 +1735,8 @@ cleaning up all windows currently displaying the buffer to be killed. */)
return unbind_to (count, Qt);
/* Then run the hooks. */
- run_hook (Qkill_buffer_hook);
+ if (!b->inhibit_buffer_hooks)
+ run_hook (Qkill_buffer_hook);
unbind_to (count, Qnil);
}
@@ -1923,7 +1938,7 @@ cleaning up all windows currently displaying the buffer to be killed. */)
bset_undo_list (b, Qnil);
/* Run buffer-list-update-hook. */
- if (!NILP (Vrun_hooks))
+ if (!NILP (Vrun_hooks) && !b->inhibit_buffer_hooks)
call1 (Vrun_hooks, Qbuffer_list_update_hook);
return Qt;
@@ -1965,7 +1980,7 @@ record_buffer (Lisp_Object buffer)
fset_buried_buffer_list (f, Fdelq (buffer, f->buried_buffer_list));
/* Run buffer-list-update-hook. */
- if (!NILP (Vrun_hooks))
+ if (!NILP (Vrun_hooks) && !XBUFFER (buffer)->inhibit_buffer_hooks)
call1 (Vrun_hooks, Qbuffer_list_update_hook);
}
@@ -2004,7 +2019,7 @@ DEFUN ("bury-buffer-internal", Fbury_buffer_internal, Sbury_buffer_internal,
(f, Fcons (buffer, Fdelq (buffer, f->buried_buffer_list)));
/* Run buffer-list-update-hook. */
- if (!NILP (Vrun_hooks))
+ if (!NILP (Vrun_hooks) && !XBUFFER (buffer)->inhibit_buffer_hooks)
call1 (Vrun_hooks, Qbuffer_list_update_hook);
return Qnil;
@@ -2125,7 +2140,7 @@ void set_buffer_internal_2 (register struct buffer *b)
Lisp_Object var = XCAR (XCAR (tail));
struct Lisp_Symbol *sym = XSYMBOL (var);
if (sym->u.s.redirect == SYMBOL_LOCALIZED /* Just to be sure. */
- && SYMBOL_BLV (sym)->fwd)
+ && SYMBOL_BLV (sym)->fwd.fwdptr)
/* Just reference the variable
to cause it to become set for this buffer. */
Fsymbol_value (var);
@@ -2203,7 +2218,7 @@ If the text under POSITION (which defaults to point) has the
if (NILP (position))
XSETFASTINT (position, PT);
else
- CHECK_NUMBER (position);
+ CHECK_FIXNUM (position);
if (!NILP (BVAR (current_buffer, read_only))
&& NILP (Vinhibit_read_only)
@@ -2233,16 +2248,16 @@ so the buffer is truly empty after this. */)
void
validate_region (register Lisp_Object *b, register Lisp_Object *e)
{
- CHECK_NUMBER_COERCE_MARKER (*b);
- CHECK_NUMBER_COERCE_MARKER (*e);
+ CHECK_FIXNUM_COERCE_MARKER (*b);
+ CHECK_FIXNUM_COERCE_MARKER (*e);
- if (XINT (*b) > XINT (*e))
+ if (XFIXNUM (*b) > XFIXNUM (*e))
{
Lisp_Object tem;
tem = *b; *b = *e; *e = tem;
}
- if (! (BEGV <= XINT (*b) && XINT (*e) <= ZV))
+ if (! (BEGV <= XFIXNUM (*b) && XFIXNUM (*e) <= ZV))
args_out_of_range_3 (Fcurrent_buffer (), *b, *e);
}
@@ -2370,9 +2385,12 @@ results, see Info node `(elisp)Swapping Text'. */)
bset_point_before_scroll (current_buffer, Qnil);
bset_point_before_scroll (other_buffer, Qnil);
- current_buffer->text->modiff++; other_buffer->text->modiff++;
- current_buffer->text->chars_modiff++; other_buffer->text->chars_modiff++;
- current_buffer->text->overlay_modiff++; other_buffer->text->overlay_modiff++;
+ modiff_incr (&current_buffer->text->modiff);
+ modiff_incr (&other_buffer->text->modiff);
+ modiff_incr (&current_buffer->text->chars_modiff);
+ modiff_incr (&other_buffer->text->chars_modiff);
+ modiff_incr (&current_buffer->text->overlay_modiff);
+ modiff_incr (&other_buffer->text->overlay_modiff);
current_buffer->text->beg_unchanged = current_buffer->text->gpt;
current_buffer->text->end_unchanged = current_buffer->text->gpt;
other_buffer->text->beg_unchanged = other_buffer->text->gpt;
@@ -2409,7 +2427,7 @@ results, see Info node `(elisp)Swapping Text'. */)
&& (EQ (XWINDOW (w)->contents, buf1)
|| EQ (XWINDOW (w)->contents, buf2)))
Fset_marker (XWINDOW (w)->pointm,
- make_number
+ make_fixnum
(BUF_BEGV (XBUFFER (XWINDOW (w)->contents))),
XWINDOW (w)->contents);
/* Blindly copied from pointm part. */
@@ -2417,14 +2435,14 @@ results, see Info node `(elisp)Swapping Text'. */)
&& (EQ (XWINDOW (w)->contents, buf1)
|| EQ (XWINDOW (w)->contents, buf2)))
Fset_marker (XWINDOW (w)->old_pointm,
- make_number
+ make_fixnum
(BUF_BEGV (XBUFFER (XWINDOW (w)->contents))),
XWINDOW (w)->contents);
if (MARKERP (XWINDOW (w)->start)
&& (EQ (XWINDOW (w)->contents, buf1)
|| EQ (XWINDOW (w)->contents, buf2)))
Fset_marker (XWINDOW (w)->start,
- make_number
+ make_fixnum
(XBUFFER (XWINDOW (w)->contents)->last_window_start),
XWINDOW (w)->contents);
w = Fnext_window (w, Qt, Qt);
@@ -2547,7 +2565,7 @@ current buffer is cleared. */)
}
}
if (narrowed)
- Fnarrow_to_region (make_number (begv), make_number (zv));
+ Fnarrow_to_region (make_fixnum (begv), make_fixnum (zv));
}
else
{
@@ -2628,7 +2646,7 @@ current buffer is cleared. */)
TEMP_SET_PT (pt);
if (narrowed)
- Fnarrow_to_region (make_number (begv), make_number (zv));
+ Fnarrow_to_region (make_fixnum (begv), make_fixnum (zv));
/* Do this first, so that chars_in_text asks the right question.
set_intervals_multibyte needs it too. */
@@ -2789,8 +2807,6 @@ overlays_at (EMACS_INT pos, bool extend, Lisp_Object **vec_ptr,
ptrdiff_t *len_ptr,
ptrdiff_t *next_ptr, ptrdiff_t *prev_ptr, bool change_req)
{
- Lisp_Object overlay, start, end;
- struct Lisp_Overlay *tail;
ptrdiff_t idx = 0;
ptrdiff_t len = *len_ptr;
Lisp_Object *vec = *vec_ptr;
@@ -2798,22 +2814,20 @@ overlays_at (EMACS_INT pos, bool extend, Lisp_Object **vec_ptr,
ptrdiff_t prev = BEGV;
bool inhibit_storing = 0;
- for (tail = current_buffer->overlays_before; tail; tail = tail->next)
+ for (struct Lisp_Overlay *tail = current_buffer->overlays_before;
+ tail; tail = tail->next)
{
- ptrdiff_t startpos, endpos;
-
- XSETMISC (overlay, tail);
-
- start = OVERLAY_START (overlay);
- end = OVERLAY_END (overlay);
- endpos = OVERLAY_POSITION (end);
+ Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike);
+ Lisp_Object start = OVERLAY_START (overlay);
+ Lisp_Object end = OVERLAY_END (overlay);
+ ptrdiff_t endpos = OVERLAY_POSITION (end);
if (endpos < pos)
{
if (prev < endpos)
prev = endpos;
break;
}
- startpos = OVERLAY_POSITION (start);
+ ptrdiff_t startpos = OVERLAY_POSITION (start);
/* This one ends at or after POS
so its start counts for PREV_PTR if it's before POS. */
if (prev < startpos && startpos < pos)
@@ -2846,22 +2860,20 @@ overlays_at (EMACS_INT pos, bool extend, Lisp_Object **vec_ptr,
next = startpos;
}
- for (tail = current_buffer->overlays_after; tail; tail = tail->next)
+ for (struct Lisp_Overlay *tail = current_buffer->overlays_after;
+ tail; tail = tail->next)
{
- ptrdiff_t startpos, endpos;
-
- XSETMISC (overlay, tail);
-
- start = OVERLAY_START (overlay);
- end = OVERLAY_END (overlay);
- startpos = OVERLAY_POSITION (start);
+ Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike);
+ Lisp_Object start = OVERLAY_START (overlay);
+ Lisp_Object end = OVERLAY_END (overlay);
+ ptrdiff_t startpos = OVERLAY_POSITION (start);
if (pos < startpos)
{
if (startpos < next)
next = startpos;
break;
}
- endpos = OVERLAY_POSITION (end);
+ ptrdiff_t endpos = OVERLAY_POSITION (end);
if (pos < endpos)
{
if (idx == len)
@@ -2923,8 +2935,6 @@ overlays_in (EMACS_INT beg, EMACS_INT end, bool extend,
Lisp_Object **vec_ptr, ptrdiff_t *len_ptr,
ptrdiff_t *next_ptr, ptrdiff_t *prev_ptr)
{
- Lisp_Object overlay, ostart, oend;
- struct Lisp_Overlay *tail;
ptrdiff_t idx = 0;
ptrdiff_t len = *len_ptr;
Lisp_Object *vec = *vec_ptr;
@@ -2933,22 +2943,20 @@ overlays_in (EMACS_INT beg, EMACS_INT end, bool extend,
bool inhibit_storing = 0;
bool end_is_Z = end == Z;
- for (tail = current_buffer->overlays_before; tail; tail = tail->next)
+ for (struct Lisp_Overlay *tail = current_buffer->overlays_before;
+ tail; tail = tail->next)
{
- ptrdiff_t startpos, endpos;
-
- XSETMISC (overlay, tail);
-
- ostart = OVERLAY_START (overlay);
- oend = OVERLAY_END (overlay);
- endpos = OVERLAY_POSITION (oend);
+ Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike);
+ Lisp_Object ostart = OVERLAY_START (overlay);
+ Lisp_Object oend = OVERLAY_END (overlay);
+ ptrdiff_t endpos = OVERLAY_POSITION (oend);
if (endpos < beg)
{
if (prev < endpos)
prev = endpos;
break;
}
- startpos = OVERLAY_POSITION (ostart);
+ ptrdiff_t startpos = OVERLAY_POSITION (ostart);
/* Count an interval if it overlaps the range, is empty at the
start of the range, or is empty at END provided END denotes the
end of the buffer. */
@@ -2980,22 +2988,20 @@ overlays_in (EMACS_INT beg, EMACS_INT end, bool extend,
next = startpos;
}
- for (tail = current_buffer->overlays_after; tail; tail = tail->next)
+ for (struct Lisp_Overlay *tail = current_buffer->overlays_after;
+ tail; tail = tail->next)
{
- ptrdiff_t startpos, endpos;
-
- XSETMISC (overlay, tail);
-
- ostart = OVERLAY_START (overlay);
- oend = OVERLAY_END (overlay);
- startpos = OVERLAY_POSITION (ostart);
+ Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike);
+ Lisp_Object ostart = OVERLAY_START (overlay);
+ Lisp_Object oend = OVERLAY_END (overlay);
+ ptrdiff_t startpos = OVERLAY_POSITION (ostart);
if (end < startpos)
{
if (startpos < next)
next = startpos;
break;
}
- endpos = OVERLAY_POSITION (oend);
+ ptrdiff_t endpos = OVERLAY_POSITION (oend);
/* Count an interval if it overlaps the range, is empty at the
start of the range, or is empty at END provided END denotes the
end of the buffer. */
@@ -3097,31 +3103,26 @@ disable_line_numbers_overlay_at_eob (void)
bool
overlay_touches_p (ptrdiff_t pos)
{
- Lisp_Object overlay;
- struct Lisp_Overlay *tail;
-
- for (tail = current_buffer->overlays_before; tail; tail = tail->next)
+ for (struct Lisp_Overlay *tail = current_buffer->overlays_before;
+ tail; tail = tail->next)
{
- ptrdiff_t endpos;
-
- XSETMISC (overlay ,tail);
+ Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike);
eassert (OVERLAYP (overlay));
- endpos = OVERLAY_POSITION (OVERLAY_END (overlay));
+ ptrdiff_t endpos = OVERLAY_POSITION (OVERLAY_END (overlay));
if (endpos < pos)
break;
if (endpos == pos || OVERLAY_POSITION (OVERLAY_START (overlay)) == pos)
return 1;
}
- for (tail = current_buffer->overlays_after; tail; tail = tail->next)
+ for (struct Lisp_Overlay *tail = current_buffer->overlays_after;
+ tail; tail = tail->next)
{
- ptrdiff_t startpos;
-
- XSETMISC (overlay, tail);
+ Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike);
eassert (OVERLAYP (overlay));
- startpos = OVERLAY_POSITION (OVERLAY_START (overlay));
+ ptrdiff_t startpos = OVERLAY_POSITION (OVERLAY_START (overlay));
if (pos < startpos)
break;
if (startpos == pos || OVERLAY_POSITION (OVERLAY_END (overlay)) == pos)
@@ -3212,17 +3213,17 @@ sort_overlays (Lisp_Object *overlay_vec, ptrdiff_t noverlays, struct window *w)
sortvec[j].priority = 0;
sortvec[j].spriority = 0;
}
- else if (INTEGERP (tem))
+ else if (FIXNUMP (tem))
{
- sortvec[j].priority = XINT (tem);
+ sortvec[j].priority = XFIXNUM (tem);
sortvec[j].spriority = 0;
}
else if (CONSP (tem))
{
Lisp_Object car = XCAR (tem);
Lisp_Object cdr = XCDR (tem);
- sortvec[j].priority = INTEGERP (car) ? XINT (car) : 0;
- sortvec[j].spriority = INTEGERP (cdr) ? XINT (cdr) : 0;
+ sortvec[j].priority = FIXNUMP (car) ? XFIXNUM (car) : 0;
+ sortvec[j].spriority = FIXNUMP (cdr) ? XFIXNUM (cdr) : 0;
}
j++;
}
@@ -3290,7 +3291,7 @@ record_overlay_string (struct sortstrlist *ssl, Lisp_Object str,
ssl->buf[ssl->used].string = str;
ssl->buf[ssl->used].string2 = str2;
ssl->buf[ssl->used].size = size;
- ssl->buf[ssl->used].priority = (INTEGERP (pri) ? XINT (pri) : 0);
+ ssl->buf[ssl->used].priority = (FIXNUMP (pri) ? XFIXNUM (pri) : 0);
ssl->used++;
if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
@@ -3337,27 +3338,26 @@ record_overlay_string (struct sortstrlist *ssl, Lisp_Object str,
ptrdiff_t
overlay_strings (ptrdiff_t pos, struct window *w, unsigned char **pstr)
{
- Lisp_Object overlay, window, str;
- struct Lisp_Overlay *ov;
- ptrdiff_t startpos, endpos;
bool multibyte = ! NILP (BVAR (current_buffer, enable_multibyte_characters));
overlay_heads.used = overlay_heads.bytes = 0;
overlay_tails.used = overlay_tails.bytes = 0;
- for (ov = current_buffer->overlays_before; ov; ov = ov->next)
+ for (struct Lisp_Overlay *ov = current_buffer->overlays_before;
+ ov; ov = ov->next)
{
- XSETMISC (overlay, ov);
+ Lisp_Object overlay = make_lisp_ptr (ov, Lisp_Vectorlike);
eassert (OVERLAYP (overlay));
- startpos = OVERLAY_POSITION (OVERLAY_START (overlay));
- endpos = OVERLAY_POSITION (OVERLAY_END (overlay));
+ ptrdiff_t startpos = OVERLAY_POSITION (OVERLAY_START (overlay));
+ ptrdiff_t endpos = OVERLAY_POSITION (OVERLAY_END (overlay));
if (endpos < pos)
break;
if (endpos != pos && startpos != pos)
continue;
- window = Foverlay_get (overlay, Qwindow);
+ Lisp_Object window = Foverlay_get (overlay, Qwindow);
if (WINDOWP (window) && XWINDOW (window) != w)
continue;
+ Lisp_Object str;
if (startpos == pos
&& (str = Foverlay_get (overlay, Qbefore_string), STRINGP (str)))
record_overlay_string (&overlay_heads, str,
@@ -3372,20 +3372,22 @@ overlay_strings (ptrdiff_t pos, struct window *w, unsigned char **pstr)
Foverlay_get (overlay, Qpriority),
endpos - startpos);
}
- for (ov = current_buffer->overlays_after; ov; ov = ov->next)
+ for (struct Lisp_Overlay *ov = current_buffer->overlays_after;
+ ov; ov = ov->next)
{
- XSETMISC (overlay, ov);
+ Lisp_Object overlay = make_lisp_ptr (ov, Lisp_Vectorlike);
eassert (OVERLAYP (overlay));
- startpos = OVERLAY_POSITION (OVERLAY_START (overlay));
- endpos = OVERLAY_POSITION (OVERLAY_END (overlay));
+ ptrdiff_t startpos = OVERLAY_POSITION (OVERLAY_START (overlay));
+ ptrdiff_t endpos = OVERLAY_POSITION (OVERLAY_END (overlay));
if (startpos > pos)
break;
if (endpos != pos && startpos != pos)
continue;
- window = Foverlay_get (overlay, Qwindow);
+ Lisp_Object window = Foverlay_get (overlay, Qwindow);
if (WINDOWP (window) && XWINDOW (window) != w)
continue;
+ Lisp_Object str;
if (startpos == pos
&& (str = Foverlay_get (overlay, Qbefore_string), STRINGP (str)))
record_overlay_string (&overlay_heads, str,
@@ -3460,8 +3462,7 @@ overlay_strings (ptrdiff_t pos, struct window *w, unsigned char **pstr)
void
recenter_overlay_lists (struct buffer *buf, ptrdiff_t pos)
{
- Lisp_Object overlay, beg, end;
- struct Lisp_Overlay *prev, *tail, *next;
+ struct Lisp_Overlay *prev, *next;
/* See if anything in overlays_before should move to overlays_after. */
@@ -3469,14 +3470,15 @@ recenter_overlay_lists (struct buffer *buf, ptrdiff_t pos)
But we use it for symmetry and in case that should cease to be true
with some future change. */
prev = NULL;
- for (tail = buf->overlays_before; tail; prev = tail, tail = next)
+ for (struct Lisp_Overlay *tail = buf->overlays_before;
+ tail; prev = tail, tail = next)
{
next = tail->next;
- XSETMISC (overlay, tail);
+ Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike);
eassert (OVERLAYP (overlay));
- beg = OVERLAY_START (overlay);
- end = OVERLAY_END (overlay);
+ Lisp_Object beg = OVERLAY_START (overlay);
+ Lisp_Object end = OVERLAY_END (overlay);
if (OVERLAY_POSITION (end) > pos)
{
@@ -3495,12 +3497,10 @@ recenter_overlay_lists (struct buffer *buf, ptrdiff_t pos)
for (other = buf->overlays_after; other;
other_prev = other, other = other->next)
{
- Lisp_Object otherbeg, otheroverlay;
-
- XSETMISC (otheroverlay, other);
+ Lisp_Object otheroverlay = make_lisp_ptr (other, Lisp_Vectorlike);
eassert (OVERLAYP (otheroverlay));
- otherbeg = OVERLAY_START (otheroverlay);
+ Lisp_Object otherbeg = OVERLAY_START (otheroverlay);
if (OVERLAY_POSITION (otherbeg) >= where)
break;
}
@@ -3522,14 +3522,15 @@ recenter_overlay_lists (struct buffer *buf, ptrdiff_t pos)
/* See if anything in overlays_after should be in overlays_before. */
prev = NULL;
- for (tail = buf->overlays_after; tail; prev = tail, tail = next)
+ for (struct Lisp_Overlay *tail = buf->overlays_after;
+ tail; prev = tail, tail = next)
{
next = tail->next;
- XSETMISC (overlay, tail);
+ Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike);
eassert (OVERLAYP (overlay));
- beg = OVERLAY_START (overlay);
- end = OVERLAY_END (overlay);
+ Lisp_Object beg = OVERLAY_START (overlay);
+ Lisp_Object end = OVERLAY_END (overlay);
/* Stop looking, when we know that nothing further
can possibly end before POS. */
@@ -3553,12 +3554,10 @@ recenter_overlay_lists (struct buffer *buf, ptrdiff_t pos)
for (other = buf->overlays_before; other;
other_prev = other, other = other->next)
{
- Lisp_Object otherend, otheroverlay;
-
- XSETMISC (otheroverlay, other);
+ Lisp_Object otheroverlay = make_lisp_ptr (other, Lisp_Vectorlike);
eassert (OVERLAYP (otheroverlay));
- otherend = OVERLAY_END (otheroverlay);
+ Lisp_Object otherend = OVERLAY_END (otheroverlay);
if (OVERLAY_POSITION (otherend) <= where)
break;
}
@@ -3613,7 +3612,6 @@ adjust_overlays_for_delete (ptrdiff_t pos, ptrdiff_t length)
void
fix_start_end_in_overlays (register ptrdiff_t start, register ptrdiff_t end)
{
- Lisp_Object overlay;
struct Lisp_Overlay *before_list UNINIT;
struct Lisp_Overlay *after_list UNINIT;
/* These are either nil, indicating that before_list or after_list
@@ -3623,8 +3621,7 @@ fix_start_end_in_overlays (register ptrdiff_t start, register ptrdiff_t end)
/* 'Parent', likewise, indicates a cons cell or
current_buffer->overlays_before or overlays_after, depending
which loop we're in. */
- struct Lisp_Overlay *tail, *parent;
- ptrdiff_t startpos, endpos;
+ struct Lisp_Overlay *parent;
/* This algorithm shifts links around instead of consing and GCing.
The loop invariant is that before_list (resp. after_list) is a
@@ -3633,18 +3630,20 @@ fix_start_end_in_overlays (register ptrdiff_t start, register ptrdiff_t end)
(after_list) if it is, is still uninitialized. So it's not a bug
that before_list isn't initialized, although it may look
strange. */
- for (parent = NULL, tail = current_buffer->overlays_before; tail;)
+ parent = NULL;
+ for (struct Lisp_Overlay *tail = current_buffer->overlays_before;
+ tail; tail = tail->next)
{
- XSETMISC (overlay, tail);
+ Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike);
- endpos = OVERLAY_POSITION (OVERLAY_END (overlay));
- startpos = OVERLAY_POSITION (OVERLAY_START (overlay));
+ ptrdiff_t endpos = OVERLAY_POSITION (OVERLAY_END (overlay));
+ ptrdiff_t startpos = OVERLAY_POSITION (OVERLAY_START (overlay));
/* If the overlay is backwards, make it empty. */
if (endpos < startpos)
{
startpos = endpos;
- Fset_marker (OVERLAY_START (overlay), make_number (startpos),
+ Fset_marker (OVERLAY_START (overlay), make_fixnum (startpos),
Qnil);
}
@@ -3676,23 +3675,24 @@ fix_start_end_in_overlays (register ptrdiff_t start, register ptrdiff_t end)
set_buffer_overlays_before (current_buffer, tail->next);
else
parent->next = tail->next;
- tail = tail->next;
}
else
- parent = tail, tail = parent->next;
+ parent = tail;
}
- for (parent = NULL, tail = current_buffer->overlays_after; tail;)
+ parent = NULL;
+ for (struct Lisp_Overlay *tail = current_buffer->overlays_after;
+ tail; tail = tail->next)
{
- XSETMISC (overlay, tail);
+ Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike);
- startpos = OVERLAY_POSITION (OVERLAY_START (overlay));
- endpos = OVERLAY_POSITION (OVERLAY_END (overlay));
+ ptrdiff_t startpos = OVERLAY_POSITION (OVERLAY_START (overlay));
+ ptrdiff_t endpos = OVERLAY_POSITION (OVERLAY_END (overlay));
/* If the overlay is backwards, make it empty. */
if (endpos < startpos)
{
startpos = endpos;
- Fset_marker (OVERLAY_START (overlay), make_number (startpos),
+ Fset_marker (OVERLAY_START (overlay), make_fixnum (startpos),
Qnil);
}
@@ -3722,10 +3722,9 @@ fix_start_end_in_overlays (register ptrdiff_t start, register ptrdiff_t end)
set_buffer_overlays_after (current_buffer, tail->next);
else
parent->next = tail->next;
- tail = tail->next;
}
else
- parent = tail, tail = parent->next;
+ parent = tail;
}
/* Splice the constructed (wrong) lists into the buffer's lists,
@@ -3776,7 +3775,7 @@ fix_overlays_before (struct buffer *bp, ptrdiff_t prev, ptrdiff_t pos)
overlay whose ending marker is after-insertion-marker if disorder
exists). */
while (tail
- && (XSETMISC (tem, tail),
+ && (tem = make_lisp_ptr (tail, Lisp_Vectorlike),
(end = OVERLAY_POSITION (OVERLAY_END (tem))) >= pos))
{
parent = tail;
@@ -3801,7 +3800,7 @@ fix_overlays_before (struct buffer *bp, ptrdiff_t prev, ptrdiff_t pos)
overlays are in correct order. */
while (tail)
{
- XSETMISC (tem, tail);
+ tem = make_lisp_ptr (tail, Lisp_Vectorlike);
end = OVERLAY_POSITION (OVERLAY_END (tem));
if (end == pos)
@@ -3867,10 +3866,10 @@ for the rear of the overlay advance when text is inserted there
if (MARKERP (end) && !EQ (Fmarker_buffer (end), buffer))
signal_error ("Marker points into wrong buffer", end);
- CHECK_NUMBER_COERCE_MARKER (beg);
- CHECK_NUMBER_COERCE_MARKER (end);
+ CHECK_FIXNUM_COERCE_MARKER (beg);
+ CHECK_FIXNUM_COERCE_MARKER (end);
- if (XINT (beg) > XINT (end))
+ if (XFIXNUM (beg) > XFIXNUM (end))
{
Lisp_Object temp;
temp = beg; beg = end; end = temp;
@@ -3927,7 +3926,7 @@ modify_overlay (struct buffer *buf, ptrdiff_t start, ptrdiff_t end)
bset_redisplay (buf);
- ++BUF_OVERLAY_MODIFF (buf);
+ modiff_incr (&BUF_OVERLAY_MODIFF (buf));
}
/* Remove OVERLAY from LIST. */
@@ -3987,10 +3986,10 @@ buffer. */)
if (MARKERP (end) && !EQ (Fmarker_buffer (end), buffer))
signal_error ("Marker points into wrong buffer", end);
- CHECK_NUMBER_COERCE_MARKER (beg);
- CHECK_NUMBER_COERCE_MARKER (end);
+ CHECK_FIXNUM_COERCE_MARKER (beg);
+ CHECK_FIXNUM_COERCE_MARKER (end);
- if (XINT (beg) > XINT (end))
+ if (XFIXNUM (beg) > XFIXNUM (end))
{
Lisp_Object temp;
temp = beg; beg = end; end = temp;
@@ -4010,6 +4009,16 @@ buffer. */)
unchain_both (ob, overlay);
}
+ else
+ /* An overlay not associated with any buffer will normally have its
+ `next' field set to NULL, but not always: when killing a buffer,
+ we just set its overlays_after and overlays_before to NULL without
+ manually setting each overlay's `next' field to NULL.
+ Let's correct it here, to simplify subsequent assertions.
+ FIXME: Maybe the better fix is to change `kill-buffer'!? */
+ XOVERLAY (overlay)->next = NULL;
+
+ eassert (XOVERLAY (overlay)->next == NULL);
/* Set the overlay boundaries, which may clip them. */
Fset_marker (OVERLAY_START (overlay), beg, buffer);
@@ -4039,10 +4048,20 @@ buffer. */)
modify_overlay (b, min (o_beg, n_beg), max (o_end, n_end));
}
+ eassert (XOVERLAY (overlay)->next == NULL);
+
/* Delete the overlay if it is empty after clipping and has the
evaporate property. */
if (n_beg == n_end && !NILP (Foverlay_get (overlay, Qevaporate)))
- return unbind_to (count, Fdelete_overlay (overlay));
+ { /* We used to call `Fdelete_overlay' here, but it causes problems:
+ - At this stage, `overlay' is not included in its buffer's lists
+ of overlays (the data-structure is in an inconsistent state),
+ contrary to `Fdelete_overlay's assumptions.
+ - Most of the work done by Fdelete_overlay has already been done
+ here for other reasons. */
+ drop_overlay (XBUFFER (buffer), XOVERLAY (overlay));
+ return unbind_to (count, overlay);
+ }
/* Put the overlay into the new buffer's overlay lists, first on the
wrong list. */
@@ -4156,7 +4175,7 @@ If SORTED is non-nil, then sort them by decreasing priority. */)
Lisp_Object *overlay_vec;
Lisp_Object result;
- CHECK_NUMBER_COERCE_MARKER (pos);
+ CHECK_FIXNUM_COERCE_MARKER (pos);
if (!buffer_has_overlays ())
return Qnil;
@@ -4167,7 +4186,7 @@ If SORTED is non-nil, then sort them by decreasing priority. */)
/* Put all the overlays we want in a vector in overlay_vec.
Store the length in len. */
- noverlays = overlays_at (XINT (pos), 1, &overlay_vec, &len,
+ noverlays = overlays_at (XFIXNUM (pos), 1, &overlay_vec, &len,
NULL, NULL, 0);
if (!NILP (sorted))
@@ -4200,8 +4219,8 @@ end of the buffer. */)
Lisp_Object *overlay_vec;
Lisp_Object result;
- CHECK_NUMBER_COERCE_MARKER (beg);
- CHECK_NUMBER_COERCE_MARKER (end);
+ CHECK_FIXNUM_COERCE_MARKER (beg);
+ CHECK_FIXNUM_COERCE_MARKER (end);
if (!buffer_has_overlays ())
return Qnil;
@@ -4211,7 +4230,7 @@ end of the buffer. */)
/* Put all the overlays we want in a vector in overlay_vec.
Store the length in len. */
- noverlays = overlays_in (XINT (beg), XINT (end), 1, &overlay_vec, &len,
+ noverlays = overlays_in (XFIXNUM (beg), XFIXNUM (end), 1, &overlay_vec, &len,
NULL, NULL);
/* Make a list of them all. */
@@ -4232,10 +4251,10 @@ the value is (point-max). */)
ptrdiff_t endpos;
Lisp_Object *overlay_vec;
- CHECK_NUMBER_COERCE_MARKER (pos);
+ CHECK_FIXNUM_COERCE_MARKER (pos);
if (!buffer_has_overlays ())
- return make_number (ZV);
+ return make_fixnum (ZV);
len = 10;
overlay_vec = xmalloc (len * sizeof *overlay_vec);
@@ -4243,7 +4262,7 @@ the value is (point-max). */)
/* Put all the overlays we want in a vector in overlay_vec.
Store the length in len.
endpos gets the position where the next overlay starts. */
- noverlays = overlays_at (XINT (pos), 1, &overlay_vec, &len,
+ noverlays = overlays_at (XFIXNUM (pos), 1, &overlay_vec, &len,
&endpos, 0, 1);
/* If any of these overlays ends before endpos,
@@ -4260,7 +4279,7 @@ the value is (point-max). */)
}
xfree (overlay_vec);
- return make_number (endpos);
+ return make_fixnum (endpos);
}
DEFUN ("previous-overlay-change", Fprevious_overlay_change,
@@ -4274,14 +4293,14 @@ the value is (point-min). */)
Lisp_Object *overlay_vec;
ptrdiff_t len;
- CHECK_NUMBER_COERCE_MARKER (pos);
+ CHECK_FIXNUM_COERCE_MARKER (pos);
if (!buffer_has_overlays ())
- return make_number (BEGV);
+ return make_fixnum (BEGV);
/* At beginning of buffer, we know the answer;
avoid bug subtracting 1 below. */
- if (XINT (pos) == BEGV)
+ if (XFIXNUM (pos) == BEGV)
return pos;
len = 10;
@@ -4290,11 +4309,11 @@ the value is (point-min). */)
/* Put all the overlays we want in a vector in overlay_vec.
Store the length in len.
prevpos gets the position of the previous change. */
- overlays_at (XINT (pos), 1, &overlay_vec, &len,
+ overlays_at (XFIXNUM (pos), 1, &overlay_vec, &len,
0, &prevpos, 1);
xfree (overlay_vec);
- return make_number (prevpos);
+ return make_fixnum (prevpos);
}
/* These functions are for debugging overlays. */
@@ -4308,19 +4327,14 @@ The lists you get are copies, so that changing them has no effect.
However, the overlays you get are the real objects that the buffer uses. */)
(void)
{
- struct Lisp_Overlay *ol;
- Lisp_Object before = Qnil, after = Qnil, tmp;
+ Lisp_Object before = Qnil, after = Qnil;
- for (ol = current_buffer->overlays_before; ol; ol = ol->next)
- {
- XSETMISC (tmp, ol);
- before = Fcons (tmp, before);
- }
- for (ol = current_buffer->overlays_after; ol; ol = ol->next)
- {
- XSETMISC (tmp, ol);
- after = Fcons (tmp, after);
- }
+ for (struct Lisp_Overlay *ol = current_buffer->overlays_before;
+ ol; ol = ol->next)
+ before = Fcons (make_lisp_ptr (ol, Lisp_Vectorlike), before);
+ for (struct Lisp_Overlay *ol = current_buffer->overlays_after;
+ ol; ol = ol->next)
+ after = Fcons (make_lisp_ptr (ol, Lisp_Vectorlike), after);
return Fcons (Fnreverse (before), Fnreverse (after));
}
@@ -4332,9 +4346,9 @@ for positions far away from POS). */)
(Lisp_Object pos)
{
ptrdiff_t p;
- CHECK_NUMBER_COERCE_MARKER (pos);
+ CHECK_FIXNUM_COERCE_MARKER (pos);
- p = clip_to_bounds (PTRDIFF_MIN, XINT (pos), PTRDIFF_MAX);
+ p = clip_to_bounds (PTRDIFF_MIN, XFIXNUM (pos), PTRDIFF_MAX);
recenter_overlay_lists (current_buffer, p);
return Qnil;
}
@@ -4439,13 +4453,8 @@ void
report_overlay_modification (Lisp_Object start, Lisp_Object end, bool after,
Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
{
- Lisp_Object prop, overlay;
- struct Lisp_Overlay *tail;
/* True if this change is an insertion. */
- bool insertion = (after ? XFASTINT (arg3) == 0 : EQ (start, end));
-
- overlay = Qnil;
- tail = NULL;
+ bool insertion = (after ? XFIXNAT (arg3) == 0 : EQ (start, end));
/* We used to run the functions as soon as we found them and only register
them in last_overlay_modification_hooks for the purpose of the `after'
@@ -4460,75 +4469,77 @@ report_overlay_modification (Lisp_Object start, Lisp_Object end, bool after,
/* We are being called before a change.
Scan the overlays to find the functions to call. */
last_overlay_modification_hooks_used = 0;
- for (tail = current_buffer->overlays_before; tail; tail = tail->next)
+ for (struct Lisp_Overlay *tail = current_buffer->overlays_before;
+ tail; tail = tail->next)
{
ptrdiff_t startpos, endpos;
Lisp_Object ostart, oend;
- XSETMISC (overlay, tail);
+ Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike);
ostart = OVERLAY_START (overlay);
oend = OVERLAY_END (overlay);
endpos = OVERLAY_POSITION (oend);
- if (XFASTINT (start) > endpos)
+ if (XFIXNAT (start) > endpos)
break;
startpos = OVERLAY_POSITION (ostart);
- if (insertion && (XFASTINT (start) == startpos
- || XFASTINT (end) == startpos))
+ if (insertion && (XFIXNAT (start) == startpos
+ || XFIXNAT (end) == startpos))
{
- prop = Foverlay_get (overlay, Qinsert_in_front_hooks);
+ Lisp_Object prop = Foverlay_get (overlay, Qinsert_in_front_hooks);
if (!NILP (prop))
add_overlay_mod_hooklist (prop, overlay);
}
- if (insertion && (XFASTINT (start) == endpos
- || XFASTINT (end) == endpos))
+ if (insertion && (XFIXNAT (start) == endpos
+ || XFIXNAT (end) == endpos))
{
- prop = Foverlay_get (overlay, Qinsert_behind_hooks);
+ Lisp_Object prop = Foverlay_get (overlay, Qinsert_behind_hooks);
if (!NILP (prop))
add_overlay_mod_hooklist (prop, overlay);
}
/* Test for intersecting intervals. This does the right thing
for both insertion and deletion. */
- if (XFASTINT (end) > startpos && XFASTINT (start) < endpos)
+ if (XFIXNAT (end) > startpos && XFIXNAT (start) < endpos)
{
- prop = Foverlay_get (overlay, Qmodification_hooks);
+ Lisp_Object prop = Foverlay_get (overlay, Qmodification_hooks);
if (!NILP (prop))
add_overlay_mod_hooklist (prop, overlay);
}
}
- for (tail = current_buffer->overlays_after; tail; tail = tail->next)
+ for (struct Lisp_Overlay *tail = current_buffer->overlays_after;
+ tail; tail = tail->next)
{
ptrdiff_t startpos, endpos;
Lisp_Object ostart, oend;
- XSETMISC (overlay, tail);
+ Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike);
ostart = OVERLAY_START (overlay);
oend = OVERLAY_END (overlay);
startpos = OVERLAY_POSITION (ostart);
endpos = OVERLAY_POSITION (oend);
- if (XFASTINT (end) < startpos)
+ if (XFIXNAT (end) < startpos)
break;
- if (insertion && (XFASTINT (start) == startpos
- || XFASTINT (end) == startpos))
+ if (insertion && (XFIXNAT (start) == startpos
+ || XFIXNAT (end) == startpos))
{
- prop = Foverlay_get (overlay, Qinsert_in_front_hooks);
+ Lisp_Object prop = Foverlay_get (overlay, Qinsert_in_front_hooks);
if (!NILP (prop))
add_overlay_mod_hooklist (prop, overlay);
}
- if (insertion && (XFASTINT (start) == endpos
- || XFASTINT (end) == endpos))
+ if (insertion && (XFIXNAT (start) == endpos
+ || XFIXNAT (end) == endpos))
{
- prop = Foverlay_get (overlay, Qinsert_behind_hooks);
+ Lisp_Object prop = Foverlay_get (overlay, Qinsert_behind_hooks);
if (!NILP (prop))
add_overlay_mod_hooklist (prop, overlay);
}
/* Test for intersecting intervals. This does the right thing
for both insertion and deletion. */
- if (XFASTINT (end) > startpos && XFASTINT (start) < endpos)
+ if (XFIXNAT (end) > startpos && XFIXNAT (start) < endpos)
{
- prop = Foverlay_get (overlay, Qmodification_hooks);
+ Lisp_Object prop = Foverlay_get (overlay, Qmodification_hooks);
if (!NILP (prop))
add_overlay_mod_hooklist (prop, overlay);
}
@@ -4584,16 +4595,13 @@ call_overlay_mod_hooks (Lisp_Object list, Lisp_Object overlay, bool after,
void
evaporate_overlays (ptrdiff_t pos)
{
- Lisp_Object overlay, hit_list;
- struct Lisp_Overlay *tail;
-
- hit_list = Qnil;
+ Lisp_Object hit_list = Qnil;
if (pos <= current_buffer->overlay_center)
- for (tail = current_buffer->overlays_before; tail; tail = tail->next)
+ for (struct Lisp_Overlay *tail = current_buffer->overlays_before;
+ tail; tail = tail->next)
{
- ptrdiff_t endpos;
- XSETMISC (overlay, tail);
- endpos = OVERLAY_POSITION (OVERLAY_END (overlay));
+ Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike);
+ ptrdiff_t endpos = OVERLAY_POSITION (OVERLAY_END (overlay));
if (endpos < pos)
break;
if (endpos == pos && OVERLAY_POSITION (OVERLAY_START (overlay)) == pos
@@ -4601,11 +4609,11 @@ evaporate_overlays (ptrdiff_t pos)
hit_list = Fcons (overlay, hit_list);
}
else
- for (tail = current_buffer->overlays_after; tail; tail = tail->next)
+ for (struct Lisp_Overlay *tail = current_buffer->overlays_after;
+ tail; tail = tail->next)
{
- ptrdiff_t startpos;
- XSETMISC (overlay, tail);
- startpos = OVERLAY_POSITION (OVERLAY_START (overlay));
+ Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike);
+ ptrdiff_t startpos = OVERLAY_POSITION (OVERLAY_START (overlay));
if (startpos > pos)
break;
if (startpos == pos && OVERLAY_POSITION (OVERLAY_END (overlay)) == pos
@@ -5011,24 +5019,37 @@ alloc_buffer_text (struct buffer *b, ptrdiff_t nbytes)
void
enlarge_buffer_text (struct buffer *b, ptrdiff_t delta)
{
- void *p;
- ptrdiff_t nbytes = (BUF_Z_BYTE (b) - BUF_BEG_BYTE (b) + BUF_GAP_SIZE (b) + 1
- + delta);
block_input ();
+ void *p;
+ unsigned char *old_beg = b->text->beg;
+ ptrdiff_t old_nbytes =
+ BUF_Z_BYTE (b) - BUF_BEG_BYTE (b) + BUF_GAP_SIZE (b) + 1;
+ ptrdiff_t new_nbytes = old_nbytes + delta;
+
+ if (pdumper_object_p (old_beg))
+ b->text->beg = NULL;
+ else
+ old_beg = NULL;
+
#if defined USE_MMAP_FOR_BUFFERS
- p = mmap_realloc ((void **) &b->text->beg, nbytes);
+ p = mmap_realloc ((void **) &b->text->beg, new_nbytes);
#elif defined REL_ALLOC
- p = r_re_alloc ((void **) &b->text->beg, nbytes);
+ p = r_re_alloc ((void **) &b->text->beg, new_nbytes);
#else
- p = xrealloc (b->text->beg, nbytes);
+ p = xrealloc (b->text->beg, new_nbytes);
#endif
if (p == NULL)
{
+ if (old_beg)
+ b->text->beg = old_beg;
unblock_input ();
- memory_full (nbytes);
+ memory_full (new_nbytes);
}
+ if (old_beg)
+ memcpy (p, old_beg, min (old_nbytes, new_nbytes));
+
BUF_BEG_ADDR (b) = p;
unblock_input ();
}
@@ -5041,13 +5062,16 @@ free_buffer_text (struct buffer *b)
{
block_input ();
+ if (!pdumper_object_p (b->text->beg))
+ {
#if defined USE_MMAP_FOR_BUFFERS
- mmap_free ((void **) &b->text->beg);
+ mmap_free ((void **) &b->text->beg);
#elif defined REL_ALLOC
- r_alloc_free ((void **) &b->text->beg);
+ r_alloc_free ((void **) &b->text->beg);
#else
- xfree (b->text->beg);
+ xfree (b->text->beg);
#endif
+ }
BUF_BEG_ADDR (b) = NULL;
unblock_input ();
@@ -5058,53 +5082,64 @@ free_buffer_text (struct buffer *b)
/***********************************************************************
Initialization
***********************************************************************/
-
void
init_buffer_once (void)
{
+ /* TODO: clean up the buffer-local machinery. Right now,
+ we have:
+
+ buffer_defaults: default values of buffer-locals
+ buffer_local_flags: metadata
+ buffer_permanent_local_flags: metadata
+ buffer_local_symbols: metadata
+
+ There must be a simpler way to store the metadata.
+ */
+
int idx;
/* Items flagged permanent get an explicit permanent-local property
added in bindings.el, for clarity. */
+ PDUMPER_REMEMBER_SCALAR (buffer_permanent_local_flags);
memset (buffer_permanent_local_flags, 0, sizeof buffer_permanent_local_flags);
/* 0 means not a lisp var, -1 means always local, else mask. */
memset (&buffer_local_flags, 0, sizeof buffer_local_flags);
- bset_filename (&buffer_local_flags, make_number (-1));
- bset_directory (&buffer_local_flags, make_number (-1));
- bset_backed_up (&buffer_local_flags, make_number (-1));
- bset_save_length (&buffer_local_flags, make_number (-1));
- bset_auto_save_file_name (&buffer_local_flags, make_number (-1));
- bset_read_only (&buffer_local_flags, make_number (-1));
- bset_major_mode (&buffer_local_flags, make_number (-1));
- bset_mode_name (&buffer_local_flags, make_number (-1));
- bset_undo_list (&buffer_local_flags, make_number (-1));
- bset_mark_active (&buffer_local_flags, make_number (-1));
- bset_point_before_scroll (&buffer_local_flags, make_number (-1));
- bset_file_truename (&buffer_local_flags, make_number (-1));
- bset_invisibility_spec (&buffer_local_flags, make_number (-1));
- bset_file_format (&buffer_local_flags, make_number (-1));
- bset_auto_save_file_format (&buffer_local_flags, make_number (-1));
- bset_display_count (&buffer_local_flags, make_number (-1));
- bset_display_time (&buffer_local_flags, make_number (-1));
- bset_enable_multibyte_characters (&buffer_local_flags, make_number (-1));
+ bset_filename (&buffer_local_flags, make_fixnum (-1));
+ bset_directory (&buffer_local_flags, make_fixnum (-1));
+ bset_backed_up (&buffer_local_flags, make_fixnum (-1));
+ bset_save_length (&buffer_local_flags, make_fixnum (-1));
+ bset_auto_save_file_name (&buffer_local_flags, make_fixnum (-1));
+ bset_read_only (&buffer_local_flags, make_fixnum (-1));
+ bset_major_mode (&buffer_local_flags, make_fixnum (-1));
+ bset_mode_name (&buffer_local_flags, make_fixnum (-1));
+ bset_undo_list (&buffer_local_flags, make_fixnum (-1));
+ bset_mark_active (&buffer_local_flags, make_fixnum (-1));
+ bset_point_before_scroll (&buffer_local_flags, make_fixnum (-1));
+ bset_file_truename (&buffer_local_flags, make_fixnum (-1));
+ bset_invisibility_spec (&buffer_local_flags, make_fixnum (-1));
+ bset_file_format (&buffer_local_flags, make_fixnum (-1));
+ bset_auto_save_file_format (&buffer_local_flags, make_fixnum (-1));
+ bset_display_count (&buffer_local_flags, make_fixnum (-1));
+ bset_display_time (&buffer_local_flags, make_fixnum (-1));
+ bset_enable_multibyte_characters (&buffer_local_flags, make_fixnum (-1));
/* These used to be stuck at 0 by default, but now that the all-zero value
means Qnil, we have to initialize them explicitly. */
- bset_name (&buffer_local_flags, make_number (0));
- bset_mark (&buffer_local_flags, make_number (0));
- bset_local_var_alist (&buffer_local_flags, make_number (0));
- bset_keymap (&buffer_local_flags, make_number (0));
- bset_downcase_table (&buffer_local_flags, make_number (0));
- bset_upcase_table (&buffer_local_flags, make_number (0));
- bset_case_canon_table (&buffer_local_flags, make_number (0));
- bset_case_eqv_table (&buffer_local_flags, make_number (0));
- bset_minor_modes (&buffer_local_flags, make_number (0));
- bset_width_table (&buffer_local_flags, make_number (0));
- bset_pt_marker (&buffer_local_flags, make_number (0));
- bset_begv_marker (&buffer_local_flags, make_number (0));
- bset_zv_marker (&buffer_local_flags, make_number (0));
- bset_last_selected_window (&buffer_local_flags, make_number (0));
+ bset_name (&buffer_local_flags, make_fixnum (0));
+ bset_mark (&buffer_local_flags, make_fixnum (0));
+ bset_local_var_alist (&buffer_local_flags, make_fixnum (0));
+ bset_keymap (&buffer_local_flags, make_fixnum (0));
+ bset_downcase_table (&buffer_local_flags, make_fixnum (0));
+ bset_upcase_table (&buffer_local_flags, make_fixnum (0));
+ bset_case_canon_table (&buffer_local_flags, make_fixnum (0));
+ bset_case_eqv_table (&buffer_local_flags, make_fixnum (0));
+ bset_minor_modes (&buffer_local_flags, make_fixnum (0));
+ bset_width_table (&buffer_local_flags, make_fixnum (0));
+ bset_pt_marker (&buffer_local_flags, make_fixnum (0));
+ bset_begv_marker (&buffer_local_flags, make_fixnum (0));
+ bset_zv_marker (&buffer_local_flags, make_fixnum (0));
+ bset_last_selected_window (&buffer_local_flags, make_fixnum (0));
idx = 1;
XSETFASTINT (BVAR (&buffer_local_flags, mode_line_format), idx); ++idx;
@@ -5115,7 +5150,9 @@ init_buffer_once (void)
XSETFASTINT (BVAR (&buffer_local_flags, selective_display), idx); ++idx;
XSETFASTINT (BVAR (&buffer_local_flags, selective_display_ellipses), idx); ++idx;
XSETFASTINT (BVAR (&buffer_local_flags, tab_width), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, truncate_lines), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, truncate_lines), idx);
+ /* Make this one a permanent local. */
+ buffer_permanent_local_flags[idx++] = 1;
XSETFASTINT (BVAR (&buffer_local_flags, word_wrap), idx); ++idx;
XSETFASTINT (BVAR (&buffer_local_flags, ctl_arrow), idx); ++idx;
XSETFASTINT (BVAR (&buffer_local_flags, fill_column), idx); ++idx;
@@ -5152,10 +5189,15 @@ init_buffer_once (void)
XSETFASTINT (BVAR (&buffer_local_flags, extra_line_spacing), idx); ++idx;
XSETFASTINT (BVAR (&buffer_local_flags, cursor_in_non_selected_windows), idx); ++idx;
+ /* buffer_local_flags contains no pointers, so it's safe to treat it
+ as a blob for pdumper. */
+ PDUMPER_REMEMBER_SCALAR (buffer_local_flags);
+
/* Need more room? */
if (idx >= MAX_PER_BUFFER_VARS)
emacs_abort ();
last_per_buffer_idx = idx;
+ PDUMPER_REMEMBER_SCALAR (last_per_buffer_idx);
/* Make sure all markable slots in buffer_defaults
are initialized reasonably, so mark_buffer won't choke. */
@@ -5250,7 +5292,9 @@ init_buffer_once (void)
Vbuffer_alist = Qnil;
current_buffer = 0;
+ pdumper_remember_lv_ptr_raw (&current_buffer, Lisp_Vectorlike);
all_buffers = 0;
+ pdumper_remember_lv_ptr_raw (&all_buffers, Lisp_Vectorlike);
QSFundamental = build_pure_c_string ("Fundamental");
@@ -5274,14 +5318,12 @@ init_buffer_once (void)
}
void
-init_buffer (int initialized)
+init_buffer (void)
{
- char *pwd;
Lisp_Object temp;
- ptrdiff_t len;
#ifdef USE_MMAP_FOR_BUFFERS
- if (initialized)
+ if (dumped_with_unexec_p ())
{
struct buffer *b;
@@ -5322,9 +5364,6 @@ init_buffer (int initialized)
eassert (b->text->beg != NULL);
}
}
-#else /* not USE_MMAP_FOR_BUFFERS */
- /* Avoid compiler warnings. */
- (void) initialized;
#endif /* USE_MMAP_FOR_BUFFERS */
AUTO_STRING (scratch, "*scratch*");
@@ -5332,7 +5371,7 @@ init_buffer (int initialized)
if (NILP (BVAR (&buffer_defaults, enable_multibyte_characters)))
Fset_buffer_multibyte (Qnil);
- pwd = emacs_get_current_dir_name ();
+ char const *pwd = emacs_wd;
if (!pwd)
{
@@ -5344,22 +5383,16 @@ init_buffer (int initialized)
{
/* Maybe this should really use some standard subroutine
whose definition is filename syntax dependent. */
- len = strlen (pwd);
- if (!(IS_DIRECTORY_SEP (pwd[len - 1])))
- {
- /* Grow buffer to add directory separator and '\0'. */
- pwd = realloc (pwd, len + 2);
- if (!pwd)
- fatal ("get_current_dir_name: %s\n", strerror (errno));
- pwd[len] = DIRECTORY_SEP;
- pwd[len + 1] = '\0';
- len++;
- }
+ ptrdiff_t len = strlen (pwd);
+ bool add_slash = ! IS_DIRECTORY_SEP (pwd[len - 1]);
/* At this moment, we still don't know how to decode the directory
name. So, we keep the bytes in unibyte form so that file I/O
routines correctly get the original bytes. */
- bset_directory (current_buffer, make_unibyte_string (pwd, len));
+ Lisp_Object dirname = make_unibyte_string (pwd, len + add_slash);
+ if (add_slash)
+ SSET (dirname, len, DIRECTORY_SEP);
+ bset_directory (current_buffer, dirname);
/* Add /: to the front of the name
if it would otherwise be treated as magic. */
@@ -5380,8 +5413,6 @@ init_buffer (int initialized)
temp = get_minibuffer (0);
bset_directory (XBUFFER (temp), BVAR (current_buffer, directory));
-
- free (pwd);
}
/* Similar to defvar_lisp but define a variable whose value is the
@@ -5413,7 +5444,7 @@ defvar_per_buffer (struct Lisp_Buffer_Objfwd *bo_fwd, const char *namestring,
bo_fwd->predicate = predicate;
sym->u.s.declared_special = true;
sym->u.s.redirect = SYMBOL_FORWARDED;
- SET_SYMBOL_FWD (sym, (union Lisp_Fwd *) bo_fwd);
+ SET_SYMBOL_FWD (sym, bo_fwd);
XSETSYMBOL (PER_BUFFER_SYMBOL (offset), sym);
if (PER_BUFFER_IDX (offset) == 0)
@@ -5428,8 +5459,7 @@ void
syms_of_buffer (void)
{
staticpro (&last_overlay_modification_hooks);
- last_overlay_modification_hooks
- = Fmake_vector (make_number (10), Qnil);
+ last_overlay_modification_hooks = make_nil_vector (10);
staticpro (&QSFundamental);
staticpro (&Vbuffer_alist);
@@ -5467,7 +5497,7 @@ syms_of_buffer (void)
Qoverwrite_mode_binary));
Fput (Qprotected_field, Qerror_conditions,
- listn (CONSTYPE_PURE, 2, Qprotected_field, Qerror));
+ pure_list (Qprotected_field, Qerror));
Fput (Qprotected_field, Qerror_message,
build_pure_c_string ("Attempt to modify a protected field"));
@@ -5570,17 +5600,17 @@ Use the command `abbrev-mode' to change this variable. */);
doc: /* Non-nil if searches and matches should ignore case. */);
DEFVAR_PER_BUFFER ("fill-column", &BVAR (current_buffer, fill_column),
- Qintegerp,
+ Qfixnump,
doc: /* Column beyond which automatic line-wrapping should happen.
Interactively, you can set the buffer local value using \\[set-fill-column]. */);
DEFVAR_PER_BUFFER ("left-margin", &BVAR (current_buffer, left_margin),
- Qintegerp,
+ Qfixnump,
doc: /* Column for the default `indent-line-function' to indent to.
Linefeed indents to this column in Fundamental mode. */);
DEFVAR_PER_BUFFER ("tab-width", &BVAR (current_buffer, tab_width),
- Qintegerp,
+ Qfixnump,
doc: /* Distance between tab stops (for display of tab characters), in columns.
NOTE: This controls the display width of a TAB character, and not
the size of an indentation step.
@@ -5714,8 +5744,8 @@ visual lines rather than logical lines. See the documentation of
DEFVAR_PER_BUFFER ("default-directory", &BVAR (current_buffer, directory),
Qstringp,
doc: /* Name of default directory of current buffer.
-It should be a directory name (as opposed to a directory file-name).
-On GNU and Unix systems, directory names end in a slash `/'.
+It should be an absolute directory name; on GNU and Unix systems,
+these names start with `/' or `~' and end with `/'.
To interactively change the default directory, use command `cd'. */);
DEFVAR_PER_BUFFER ("auto-fill-function", &BVAR (current_buffer, auto_fill_function),
@@ -5751,7 +5781,7 @@ If it is nil, that means don't auto-save this buffer. */);
Backing up is done before the first time the file is saved. */);
DEFVAR_PER_BUFFER ("buffer-saved-size", &BVAR (current_buffer, save_length),
- Qintegerp,
+ Qfixnump,
doc: /* Length of current buffer when last read in, saved or auto-saved.
0 initially.
-1 means auto-saving turned off until next real save.
@@ -5825,7 +5855,7 @@ In addition, a char-table has six extra slots to control the display of:
See also the functions `display-table-slot' and `set-display-table-slot'. */);
DEFVAR_PER_BUFFER ("left-margin-width", &BVAR (current_buffer, left_margin_cols),
- Qintegerp,
+ Qfixnump,
doc: /* Width in columns of left marginal area for display of a buffer.
A value of nil means no marginal area.
@@ -5833,7 +5863,7 @@ Setting this variable does not take effect until a new buffer is displayed
in a window. To make the change take effect, call `set-window-buffer'. */);
DEFVAR_PER_BUFFER ("right-margin-width", &BVAR (current_buffer, right_margin_cols),
- Qintegerp,
+ Qfixnump,
doc: /* Width in columns of right marginal area for display of a buffer.
A value of nil means no marginal area.
@@ -5841,7 +5871,7 @@ Setting this variable does not take effect until a new buffer is displayed
in a window. To make the change take effect, call `set-window-buffer'. */);
DEFVAR_PER_BUFFER ("left-fringe-width", &BVAR (current_buffer, left_fringe_width),
- Qintegerp,
+ Qfixnump,
doc: /* Width of this buffer's left fringe (in pixels).
A value of 0 means no left fringe is shown in this buffer's window.
A value of nil means to use the left fringe width from the window's frame.
@@ -5850,7 +5880,7 @@ Setting this variable does not take effect until a new buffer is displayed
in a window. To make the change take effect, call `set-window-buffer'. */);
DEFVAR_PER_BUFFER ("right-fringe-width", &BVAR (current_buffer, right_fringe_width),
- Qintegerp,
+ Qfixnump,
doc: /* Width of this buffer's right fringe (in pixels).
A value of 0 means no right fringe is shown in this buffer's window.
A value of nil means to use the right fringe width from the window's frame.
@@ -5867,12 +5897,12 @@ Setting this variable does not take effect until a new buffer is displayed
in a window. To make the change take effect, call `set-window-buffer'. */);
DEFVAR_PER_BUFFER ("scroll-bar-width", &BVAR (current_buffer, scroll_bar_width),
- Qintegerp,
+ Qfixnump,
doc: /* Width of this buffer's vertical scroll bars in pixels.
A value of nil means to use the scroll bar width from the window's frame. */);
DEFVAR_PER_BUFFER ("scroll-bar-height", &BVAR (current_buffer, scroll_bar_height),
- Qintegerp,
+ Qfixnump,
doc: /* Height of this buffer's horizontal scroll bars in pixels.
A value of nil means to use the scroll bar height from the window's frame. */);
@@ -6038,11 +6068,11 @@ An entry (TEXT . POSITION) represents the deletion of the string TEXT
from (abs POSITION). If POSITION is positive, point was at the front
of the text being deleted; if negative, point was at the end.
-An entry (t HIGH LOW USEC PSEC) indicates that the buffer was previously
-unmodified; (HIGH LOW USEC PSEC) is in the same style as (current-time)
-and is the visited file's modification time, as of that time. If the
-modification time of the most recent save is different, this entry is
-obsolete.
+An entry (t . TIMESTAMP), where TIMESTAMP is in the style of
+`current-time', indicates that the buffer was previously unmodified;
+TIMESTAMP is the visited file's modification time, as of that time.
+If the modification time of the most recent save is different, this
+entry is obsolete.
An entry (t . 0) means the buffer was previously unmodified but
its time stamp was unknown because it was not associated with a file.
@@ -6142,7 +6172,7 @@ Setting this variable is very fast, much faster than scanning all the text in
the buffer looking for properties to change. */);
DEFVAR_PER_BUFFER ("buffer-display-count",
- &BVAR (current_buffer, display_count), Qintegerp,
+ &BVAR (current_buffer, display_count), Qfixnump,
doc: /* A number incremented each time this buffer is displayed in a window.
The function `set-window-buffer' increments it. */);
diff --git a/src/buffer.h b/src/buffer.h
index b8322294031..f42c3e97b97 100644
--- a/src/buffer.h
+++ b/src/buffer.h
@@ -288,28 +288,6 @@ extern void enlarge_buffer_text (struct buffer *, ptrdiff_t);
or convert between a byte position and an address.
These macros do not check that the position is in range. */
-/* Access a Lisp position value in POS,
- and store the charpos in CHARPOS and the bytepos in BYTEPOS. */
-
-#define DECODE_POSITION(charpos, bytepos, pos) \
- do \
- { \
- Lisp_Object __pos = (pos); \
- if (NUMBERP (__pos)) \
- { \
- charpos = __pos; \
- bytepos = buf_charpos_to_bytepos (current_buffer, __pos); \
- } \
- else if (MARKERP (__pos)) \
- { \
- charpos = marker_position (__pos); \
- bytepos = marker_byte_position (__pos); \
- } \
- else \
- wrong_type_argument (Qinteger_or_marker_p, __pos); \
- } \
- while (false)
-
/* Maximum number of bytes in a buffer.
A buffer cannot contain more bytes than a 1-origin fixnum can represent,
nor can it be so large that C pointer arithmetic stops working.
@@ -444,20 +422,20 @@ struct buffer_text
ptrdiff_t gpt_byte; /* Byte pos of gap in buffer. */
ptrdiff_t z_byte; /* Byte pos of end of buffer. */
ptrdiff_t gap_size; /* Size of buffer's gap. */
- EMACS_INT modiff; /* This counts buffer-modification events
+ modiff_count modiff; /* This counts buffer-modification events
for this buffer. It is incremented for
each such event, and never otherwise
changed. */
- EMACS_INT chars_modiff; /* This is modified with character change
+ modiff_count chars_modiff; /* This is modified with character change
events for this buffer. It is set to
modiff for each such event, and never
otherwise changed. */
- EMACS_INT save_modiff; /* Previous value of modiff, as of last
+ modiff_count save_modiff; /* Previous value of modiff, as of last
time buffer visited or saved a file. */
- EMACS_INT overlay_modiff; /* Counts modifications to overlays. */
+ modiff_count overlay_modiff; /* Counts modifications to overlays. */
- EMACS_INT compact; /* Set to modiff each time when compact_buffer
+ modiff_count compact; /* Set to modiff each time when compact_buffer
is called for this buffer. */
/* Minimum value of GPT - BEG since last redisplay that finished. */
@@ -468,12 +446,12 @@ struct buffer_text
/* MODIFF as of last redisplay that finished; if it matches MODIFF,
beg_unchanged and end_unchanged contain no useful information. */
- EMACS_INT unchanged_modified;
+ modiff_count unchanged_modified;
/* BUF_OVERLAY_MODIFF of current buffer, as of last redisplay that
finished; if it matches BUF_OVERLAY_MODIFF, beg_unchanged and
end_unchanged contain no useful information. */
- EMACS_INT overlay_unchanged_modified;
+ modiff_count overlay_unchanged_modified;
/* Properties of this buffer's text. */
INTERVAL intervals;
@@ -763,8 +741,8 @@ struct buffer
See `cursor-type' for other values. */
Lisp_Object cursor_in_non_selected_windows_;
- /* No more Lisp_Object beyond this point. Except undo_list,
- which is handled specially in Fgarbage_collect. */
+ /* No more Lisp_Object beyond cursor_in_non_selected_windows_.
+ Except undo_list, which is handled specially in Fgarbage_collect. */
/* This structure holds the coordinates of the buffer contents
in ordinary buffers. In indirect buffers, this is not used. */
@@ -834,11 +812,11 @@ struct buffer
off_t modtime_size;
/* The value of text->modiff at the last auto-save. */
- EMACS_INT auto_save_modified;
+ modiff_count auto_save_modified;
/* The value of text->modiff at the last display error.
Redisplay of this buffer is inhibited until it changes again. */
- EMACS_INT display_error_modiff;
+ modiff_count display_error_modiff;
/* The time at which we detected a failure to auto-save,
Or 0 if we didn't have a failure. */
@@ -877,6 +855,13 @@ struct buffer
/* Non-zero whenever the narrowing is changed in this buffer. */
bool_bf clip_changed : 1;
+ /* Non-zero for internally used temporary buffers that don't need to
+ run hooks kill-buffer-hook, buffer-list-update-hook, and
+ kill-buffer-query-functions. This is used in coding.c to avoid
+ slowing down en/decoding when there are a lot of these hooks
+ defined. */
+ bool_bf inhibit_buffer_hooks : 1;
+
/* List of overlays that end at or before the current center,
in order of end-position. */
struct Lisp_Overlay *overlays_before;
@@ -912,7 +897,7 @@ INLINE struct buffer *
XBUFFER (Lisp_Object a)
{
eassert (BUFFERP (a));
- return XUNTAG (a, Lisp_Vectorlike);
+ return XUNTAG (a, Lisp_Vectorlike, struct buffer);
}
/* Most code should use these functions to set Lisp fields in struct
@@ -1034,14 +1019,12 @@ bset_width_table (struct buffer *b, Lisp_Object val)
structure, make sure that this is still correct. */
#define BUFFER_LISP_SIZE \
- ((offsetof (struct buffer, own_text) - header_size) / word_size)
+ PSEUDOVECSIZE (struct buffer, cursor_in_non_selected_windows_)
-/* Size of the struct buffer part beyond leading Lisp_Objects, in word_size
- units. Rounding is needed for --with-wide-int configuration. */
+/* Allocated size of the struct buffer part beyond leading
+ Lisp_Objects, in word_size units. */
-#define BUFFER_REST_SIZE \
- ((((sizeof (struct buffer) - offsetof (struct buffer, own_text)) \
- + (word_size - 1)) & ~(word_size - 1)) / word_size)
+#define BUFFER_REST_SIZE (VECSIZE (struct buffer) - BUFFER_LISP_SIZE)
/* Initialize the pseudovector header of buffer object. BUFFER_LISP_SIZE
is required for GC, but BUFFER_REST_SIZE is set up just to be consistent
@@ -1349,7 +1332,7 @@ extern int last_per_buffer_idx;
#define PER_BUFFER_IDX(OFFSET) \
- XINT (*(Lisp_Object *)((OFFSET) + (char *) &buffer_local_flags))
+ XFIXNUM (*(Lisp_Object *)((OFFSET) + (char *) &buffer_local_flags))
/* Functions to get and set default value of the per-buffer
variable at offset OFFSET in the buffer structure. */
@@ -1387,7 +1370,7 @@ downcase (int c)
{
Lisp_Object downcase_table = BVAR (current_buffer, downcase_table);
Lisp_Object down = CHAR_TABLE_REF (downcase_table, c);
- return NATNUMP (down) ? XFASTINT (down) : c;
+ return FIXNATP (down) ? XFIXNAT (down) : c;
}
/* Upcase a character C, or make no change if that cannot be done. */
@@ -1396,7 +1379,7 @@ upcase (int c)
{
Lisp_Object upcase_table = BVAR (current_buffer, upcase_table);
Lisp_Object up = CHAR_TABLE_REF (upcase_table, c);
- return NATNUMP (up) ? XFASTINT (up) : c;
+ return FIXNATP (up) ? XFIXNAT (up) : c;
}
/* True if C is upper case. */
diff --git a/src/bytecode.c b/src/bytecode.c
index a5c7576269f..40977799bfc 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -24,6 +24,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "character.h"
#include "buffer.h"
#include "keyboard.h"
+#include "ptr-bounds.h"
#include "syntax.h"
#include "window.h"
@@ -62,14 +63,14 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
{ \
if (byte_metering_on) \
{ \
- if (XFASTINT (METER_1 (this_code)) < MOST_POSITIVE_FIXNUM) \
+ if (XFIXNAT (METER_1 (this_code)) < MOST_POSITIVE_FIXNUM) \
XSETFASTINT (METER_1 (this_code), \
- XFASTINT (METER_1 (this_code)) + 1); \
+ XFIXNAT (METER_1 (this_code)) + 1); \
if (last_code \
- && (XFASTINT (METER_2 (last_code, this_code)) \
+ && (XFIXNAT (METER_2 (last_code, this_code)) \
< MOST_POSITIVE_FIXNUM)) \
XSETFASTINT (METER_2 (last_code, this_code), \
- XFASTINT (METER_2 (last_code, this_code)) + 1); \
+ XFIXNAT (METER_2 (last_code, this_code)) + 1); \
} \
}
@@ -345,7 +346,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
CHECK_STRING (bytestr);
CHECK_VECTOR (vector);
- CHECK_NATNUM (maxdepth);
+ CHECK_FIXNAT (maxdepth);
ptrdiff_t const_length = ASIZE (vector);
@@ -361,31 +362,33 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
Lisp_Object *vectorp = XVECTOR (vector)->contents;
unsigned char quitcounter = 1;
- EMACS_INT stack_items = XFASTINT (maxdepth) + 1;
+ EMACS_INT stack_items = XFIXNAT (maxdepth) + 1;
USE_SAFE_ALLOCA;
- Lisp_Object *stack_base;
- SAFE_ALLOCA_LISP_EXTRA (stack_base, stack_items, bytestr_length);
- Lisp_Object *stack_lim = stack_base + stack_items;
+ void *alloc;
+ SAFE_ALLOCA_LISP_EXTRA (alloc, stack_items, bytestr_length);
+ ptrdiff_t item_bytes = stack_items * word_size;
+ Lisp_Object *stack_base = ptr_bounds_clip (alloc, item_bytes);
Lisp_Object *top = stack_base;
*top = vector; /* Ensure VECTOR survives GC (Bug#33014). */
- memcpy (stack_lim, SDATA (bytestr), bytestr_length);
- void *void_stack_lim = stack_lim;
- unsigned char const *bytestr_data = void_stack_lim;
+ Lisp_Object *stack_lim = stack_base + stack_items;
+ unsigned char *bytestr_data = alloc;
+ bytestr_data = ptr_bounds_clip (bytestr_data + item_bytes, bytestr_length);
+ memcpy (bytestr_data, SDATA (bytestr), bytestr_length);
unsigned char const *pc = bytestr_data;
ptrdiff_t count = SPECPDL_INDEX ();
if (!NILP (args_template))
{
- eassert (INTEGERP (args_template));
- ptrdiff_t at = XINT (args_template);
+ eassert (FIXNUMP (args_template));
+ ptrdiff_t at = XFIXNUM (args_template);
bool rest = (at & 128) != 0;
int mandatory = at & 127;
ptrdiff_t nonrest = at >> 8;
ptrdiff_t maxargs = rest ? PTRDIFF_MAX : nonrest;
if (! (mandatory <= nargs && nargs <= maxargs))
Fsignal (Qwrong_number_of_arguments,
- list2 (Fcons (make_number (mandatory), make_number (nonrest)),
- make_number (nargs)));
+ list2 (Fcons (make_fixnum (mandatory), make_fixnum (nonrest)),
+ make_fixnum (nargs)));
ptrdiff_t pushedargs = min (nonrest, nargs);
for (ptrdiff_t i = 0; i < pushedargs; i++, args++)
PUSH (*args);
@@ -619,10 +622,10 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
{
Lisp_Object v1 = TOP;
Lisp_Object v2 = Fget (v1, Qbyte_code_meter);
- if (INTEGERP (v2)
- && XINT (v2) < MOST_POSITIVE_FIXNUM)
+ if (FIXNUMP (v2)
+ && XFIXNUM (v2) < MOST_POSITIVE_FIXNUM)
{
- XSETINT (v2, XINT (v2) + 1);
+ XSETINT (v2, XFIXNUM (v2) + 1);
Fput (v1, Qbyte_code_meter, v2);
}
}
@@ -737,8 +740,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
NEXT;
CASE (Bsave_excursion):
- record_unwind_protect (save_excursion_restore,
- save_excursion_save ());
+ record_unwind_protect_excursion ();
NEXT;
CASE (Bsave_current_buffer): /* Obsolete since ??. */
@@ -831,13 +833,14 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
CASE (Bnth):
{
Lisp_Object v2 = POP, v1 = TOP;
- CHECK_NUMBER (v1);
- for (EMACS_INT n = XINT (v1); 0 < n && CONSP (v2); n--)
+ if (RANGED_FIXNUMP (0, v1, SMALL_LIST_LEN_MAX))
{
- v2 = XCDR (v2);
- rarely_quit (n);
+ for (EMACS_INT n = XFIXNUM (v1); 0 < n && CONSP (v2); n--)
+ v2 = XCDR (v2);
+ TOP = CAR (v2);
}
- TOP = CAR (v2);
+ else
+ TOP = Fnth (v1, v2);
NEXT;
}
@@ -971,24 +974,21 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
NEXT;
CASE (Bsub1):
- TOP = INTEGERP (TOP) ? make_number (XINT (TOP) - 1) : Fsub1 (TOP);
+ TOP = (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM
+ ? make_fixnum (XFIXNUM (TOP) - 1)
+ : Fsub1 (TOP));
NEXT;
CASE (Badd1):
- TOP = INTEGERP (TOP) ? make_number (XINT (TOP) + 1) : Fadd1 (TOP);
+ TOP = (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_POSITIVE_FIXNUM
+ ? make_fixnum (XFIXNUM (TOP) + 1)
+ : Fadd1 (TOP));
NEXT;
CASE (Beqlsign):
{
- Lisp_Object v2 = POP, v1 = TOP;
- if (FLOATP (v1) || FLOATP (v2))
- TOP = arithcompare (v1, v2, ARITH_EQUAL);
- else
- {
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1);
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2);
- TOP = EQ (v1, v2) ? Qt : Qnil;
- }
+ Lisp_Object v1 = POP;
+ TOP = arithcompare (TOP, v1, ARITH_EQUAL);
NEXT;
}
@@ -1026,7 +1026,9 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
NEXT;
CASE (Bnegate):
- TOP = INTEGERP (TOP) ? make_number (- XINT (TOP)) : Fminus (1, &TOP);
+ TOP = (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM
+ ? make_fixnum (- XFIXNUM (TOP))
+ : Fminus (1, &TOP));
NEXT;
CASE (Bplus):
@@ -1062,7 +1064,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
}
CASE (Bpoint):
- PUSH (make_natnum (PT));
+ PUSH (make_fixed_natnum (PT));
NEXT;
CASE (Bgoto_char):
@@ -1088,7 +1090,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
}
CASE (Bpoint_min):
- PUSH (make_natnum (BEGV));
+ PUSH (make_fixed_natnum (BEGV));
NEXT;
CASE (Bchar_after):
@@ -1104,7 +1106,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
NEXT;
CASE (Bcurrent_column):
- PUSH (make_natnum (current_column ()));
+ PUSH (make_fixed_natnum (current_column ()));
NEXT;
CASE (Bindent_to):
@@ -1168,7 +1170,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
CASE (Bchar_syntax):
{
CHECK_CHARACTER (TOP);
- int c = XFASTINT (TOP);
+ int c = XFIXNAT (TOP);
if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
MAKE_CHAR_MULTIBYTE (c);
XSETFASTINT (TOP, syntax_code_spec[SYNTAX (c)]);
@@ -1257,23 +1259,16 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
CASE (Belt):
{
- if (CONSP (TOP))
+ Lisp_Object v2 = POP, v1 = TOP;
+ if (CONSP (v1) && RANGED_FIXNUMP (0, v2, SMALL_LIST_LEN_MAX))
{
- /* Exchange args and then do nth. */
- Lisp_Object v2 = POP, v1 = TOP;
- CHECK_NUMBER (v2);
- for (EMACS_INT n = XINT (v2); 0 < n && CONSP (v1); n--)
- {
- v1 = XCDR (v1);
- rarely_quit (n);
- }
+ /* Like the fast case for Bnth, but with args reversed. */
+ for (EMACS_INT n = XFIXNUM (v2); 0 < n && CONSP (v1); n--)
+ v1 = XCDR (v1);
TOP = CAR (v1);
}
else
- {
- Lisp_Object v1 = POP;
- TOP = Felt (TOP, v1);
- }
+ TOP = Felt (v1, v2);
NEXT;
}
@@ -1403,10 +1398,11 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
search as the jump table. */
Lisp_Object jmp_table = POP;
if (BYTE_CODE_SAFE && !HASH_TABLE_P (jmp_table))
- emacs_abort ();
+ emacs_abort ();
Lisp_Object v1 = POP;
ptrdiff_t i;
struct Lisp_Hash_Table *h = XHASH_TABLE (jmp_table);
+ hash_rehash_if_needed (h);
/* h->count is a faster approximation for HASH_TABLE_SIZE (h)
here. */
@@ -1414,7 +1410,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
{ /* Do a linear search if there are not many cases
FIXME: 5 is arbitrarily chosen. */
Lisp_Object hash_code = h->test.cmpfn
- ? make_number (h->test.hashfn (&h->test, v1)) : Qnil;
+ ? make_fixnum (h->test.hashfn (&h->test, v1)) : Qnil;
for (i = h->count; 0 <= --i; )
if (EQ (v1, HASH_KEY (h, i))
@@ -1430,9 +1426,9 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
if (i >= 0)
{
Lisp_Object val = HASH_VALUE (h, i);
- if (BYTE_CODE_SAFE && !INTEGERP (val))
+ if (BYTE_CODE_SAFE && !FIXNUMP (val))
emacs_abort ();
- op = XINT (val);
+ op = XFIXNUM (val);
goto op_branch;
}
}
@@ -1467,14 +1463,14 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
Lisp_Object
get_byte_code_arity (Lisp_Object args_template)
{
- eassert (NATNUMP (args_template));
- EMACS_INT at = XINT (args_template);
+ eassert (FIXNATP (args_template));
+ EMACS_INT at = XFIXNUM (args_template);
bool rest = (at & 128) != 0;
int mandatory = at & 127;
EMACS_INT nonrest = at >> 8;
- return Fcons (make_number (mandatory),
- rest ? Qmany : make_number (nonrest));
+ return Fcons (make_fixnum (mandatory),
+ rest ? Qmany : make_fixnum (nonrest));
}
void
@@ -1499,13 +1495,9 @@ If a symbol has a property named `byte-code-meter' whose value is an
integer, it is incremented each time that symbol's function is called. */);
byte_metering_on = false;
- Vbyte_code_meter = Fmake_vector (make_number (256), make_number (0));
+ Vbyte_code_meter = make_nil_vector (256);
DEFSYM (Qbyte_code_meter, "byte-code-meter");
- {
- int i = 256;
- while (i--)
- ASET (Vbyte_code_meter, i,
- Fmake_vector (make_number (256), make_number (0)));
- }
+ for (int i = 0; i < 256; i++)
+ ASET (Vbyte_code_meter, i, make_vector (256, make_fixnum (0)));
#endif
}
diff --git a/src/callint.c b/src/callint.c
index 82e407fb966..88a3c348d0a 100644
--- a/src/callint.c
+++ b/src/callint.c
@@ -21,6 +21,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <config.h>
#include "lisp.h"
+#include "ptr-bounds.h"
#include "character.h"
#include "buffer.h"
#include "keyboard.h"
@@ -199,8 +200,8 @@ fix_command (Lisp_Object input, Lisp_Object values)
carelt = XCAR (elt);
/* If it is (if X Y), look at Y. */
if (EQ (carelt, Qif)
- && EQ (Fnthcdr (make_number (3), elt), Qnil))
- elt = Fnth (make_number (2), elt);
+ && NILP (Fnthcdr (make_fixnum (3), elt)))
+ elt = Fnth (make_fixnum (2), elt);
/* If it is (when ... Y), look at Y. */
else if (EQ (carelt, Qwhen))
{
@@ -261,7 +262,7 @@ to the function `interactive' at the top level of the function body.
See `interactive'.
Optional second arg RECORD-FLAG non-nil
-means unconditionally put this command in the command-history.
+means unconditionally put this command in the variable `command-history'.
Otherwise, this is done only if an arg is read using the minibuffer.
Optional third arg KEYS, if given, specifies the sequence of events to
@@ -270,44 +271,16 @@ invoke it. If KEYS is omitted or nil, the return value of
`this-command-keys-vector' is used. */)
(Lisp_Object function, Lisp_Object record_flag, Lisp_Object keys)
{
- /* `args' will contain the array of arguments to pass to the function.
- `visargs' will contain the same list but in a nicer form, so that if we
- pass it to Fformat_message it will be understandable to a human. */
- Lisp_Object *args, *visargs;
- Lisp_Object specs;
- Lisp_Object filter_specs;
- Lisp_Object teml;
- Lisp_Object up_event;
- Lisp_Object enable;
- USE_SAFE_ALLOCA;
ptrdiff_t speccount = SPECPDL_INDEX ();
- /* The index of the next element of this_command_keys to examine for
- the 'e' interactive code. */
- ptrdiff_t next_event;
-
- Lisp_Object prefix_arg;
- char *string;
- const char *tem;
-
- /* If varies[i] > 0, the i'th argument shouldn't just have its value
- in this call quoted in the command history. It should be
- recorded as a call to the function named callint_argfuns[varies[i]]. */
- signed char *varies;
-
- ptrdiff_t i, nargs;
- ptrdiff_t mark;
- bool arg_from_tty = 0;
+ bool arg_from_tty = false;
ptrdiff_t key_count;
- bool record_then_fail = 0;
-
- Lisp_Object save_this_command, save_last_command;
- Lisp_Object save_this_original_command, save_real_this_command;
+ bool record_then_fail = false;
- save_this_command = Vthis_command;
- save_this_original_command = Vthis_original_command;
- save_real_this_command = Vreal_this_command;
- save_last_command = KVAR (current_kboard, Vlast_command);
+ Lisp_Object save_this_command = Vthis_command;
+ Lisp_Object save_this_original_command = Vthis_original_command;
+ Lisp_Object save_real_this_command = Vreal_this_command;
+ Lisp_Object save_last_command = KVAR (current_kboard, Vlast_command);
if (NILP (keys))
keys = this_command_keys, key_count = this_command_key_count;
@@ -318,66 +291,45 @@ invoke it. If KEYS is omitted or nil, the return value of
}
/* Save this now, since use of minibuffer will clobber it. */
- prefix_arg = Vcurrent_prefix_arg;
+ Lisp_Object prefix_arg = Vcurrent_prefix_arg;
- if (SYMBOLP (function))
- enable = Fget (function, Qenable_recursive_minibuffers);
- else
- enable = Qnil;
-
- specs = Qnil;
- string = 0;
- /* The idea of FILTER_SPECS is to provide a way to
- specify how to represent the arguments in command history.
- The feature is not fully implemented. */
- filter_specs = Qnil;
+ Lisp_Object enable = (SYMBOLP (function)
+ ? Fget (function, Qenable_recursive_minibuffers)
+ : Qnil);
/* If k or K discard an up-event, save it here so it can be retrieved with
U. */
- up_event = Qnil;
+ Lisp_Object up_event = Qnil;
/* Set SPECS to the interactive form, or barf if not interactive. */
- {
- Lisp_Object form;
- form = Finteractive_form (function);
- if (CONSP (form))
- specs = filter_specs = Fcar (XCDR (form));
- else
- wrong_type_argument (Qcommandp, function);
- }
+ Lisp_Object form = Finteractive_form (function);
+ if (! CONSP (form))
+ wrong_type_argument (Qcommandp, function);
+ Lisp_Object specs = Fcar (XCDR (form));
+
+ /* At this point the value of SPECS could help provide a way to
+ specify how to represent the arguments in command history.
+ The feature is not fully implemented. */
/* If SPECS is not a string, invent one. */
if (! STRINGP (specs))
{
- Lisp_Object input;
Lisp_Object funval = Findirect_function (function, Qt);
uintmax_t events = num_input_events;
- input = specs;
+ Lisp_Object input = specs;
/* Compute the arg values using the user's expression. */
specs = Feval (specs,
CONSP (funval) && EQ (Qclosure, XCAR (funval))
? CAR_SAFE (XCDR (funval)) : Qnil);
if (events != num_input_events || !NILP (record_flag))
{
- /* We should record this command on the command history. */
- Lisp_Object values;
- Lisp_Object this_cmd;
- /* Make a copy of the list of values, for the command history,
+ /* We should record this command on the command history.
+ Make a copy of the list of values, for the command history,
and turn them into things we can eval. */
- values = quotify_args (Fcopy_sequence (specs));
+ Lisp_Object values = quotify_args (Fcopy_sequence (specs));
fix_command (input, values);
- this_cmd = Fcons (function, values);
- if (history_delete_duplicates)
- Vcommand_history = Fdelete (this_cmd, Vcommand_history);
- Vcommand_history = Fcons (this_cmd, Vcommand_history);
-
- /* Don't keep command history around forever. */
- if (INTEGERP (Vhistory_length) && XINT (Vhistory_length) > 0)
- {
- teml = Fnthcdr (Vhistory_length, Vcommand_history);
- if (CONSP (teml))
- XSETCDR (teml, Qnil);
- }
+ call4 (intern ("add-to-history"), intern ("command-history"),
+ Fcons (function, values), Qnil, Qt);
}
Vthis_command = save_this_command;
@@ -385,46 +337,42 @@ invoke it. If KEYS is omitted or nil, the return value of
Vreal_this_command = save_real_this_command;
kset_last_command (current_kboard, save_last_command);
- Lisp_Object result
- = unbind_to (speccount, CALLN (Fapply, Qfuncall_interactively,
- function, specs));
- SAFE_FREE ();
- return result;
+ return unbind_to (speccount, CALLN (Fapply, Qfuncall_interactively,
+ function, specs));
}
/* SPECS is set to a string; use it as an interactive prompt.
Copy it so that STRING will be valid even if a GC relocates SPECS. */
- SAFE_ALLOCA_STRING (string, specs);
-
- /* Here if function specifies a string to control parsing the defaults. */
+ USE_SAFE_ALLOCA;
+ ptrdiff_t string_len = SBYTES (specs);
+ char *string = SAFE_ALLOCA (string_len + 1);
+ memcpy (string, SDATA (specs), string_len + 1);
+ char *string_end = string + string_len;
- /* Set next_event to point to the first event with parameters. */
+ /* The index of the next element of this_command_keys to examine for
+ the 'e' interactive code. Initialize it to point to the first
+ event with parameters. */
+ ptrdiff_t next_event;
for (next_event = 0; next_event < key_count; next_event++)
if (EVENT_HAS_PARAMETERS (AREF (keys, next_event)))
break;
/* Handle special starting chars `*' and `@'. Also `-'. */
/* Note that `+' is reserved for user extensions. */
- while (1)
+ for (;; string++)
{
if (*string == '+')
error ("`+' is not used in `interactive' for ordinary commands");
else if (*string == '*')
{
- string++;
if (!NILP (BVAR (current_buffer, read_only)))
{
if (!NILP (record_flag))
{
- char *p = string;
- while (*p)
- {
- if (! (*p == 'r' || *p == 'p' || *p == 'P'
- || *p == '\n'))
- Fbarf_if_buffer_read_only (Qnil);
- p++;
- }
- record_then_fail = 1;
+ for (char *p = string + 1; p < string_end; p++)
+ if (! (*p == 'r' || *p == 'p' || *p == 'P' || *p == '\n'))
+ Fbarf_if_buffer_read_only (Qnil);
+ record_then_fail = true;
}
else
Fbarf_if_buffer_read_only (Qnil);
@@ -432,14 +380,12 @@ invoke it. If KEYS is omitted or nil, the return value of
}
/* Ignore this for semi-compatibility with Lucid. */
else if (*string == '-')
- string++;
+ ;
else if (*string == '@')
{
- Lisp_Object event, w;
-
- event = (next_event < key_count
- ? AREF (keys, next_event)
- : Qnil);
+ Lisp_Object w, event = (next_event < key_count
+ ? AREF (keys, next_event)
+ : Qnil);
if (EVENT_HAS_PARAMETERS (event)
&& (w = XCDR (event), CONSP (w))
&& (w = XCAR (w), CONSP (w))
@@ -454,32 +400,23 @@ invoke it. If KEYS is omitted or nil, the return value of
Fselect_window (w, Qnil);
}
- string++;
}
else if (*string == '^')
- {
- call0 (Qhandle_shift_selection);
- string++;
- }
+ call0 (Qhandle_shift_selection);
else break;
}
/* Count the number of arguments, which is two (the function itself and
`funcall-interactively') plus the number of arguments the interactive spec
would have us give to the function. */
- tem = string;
- for (nargs = 2; *tem; )
+ ptrdiff_t nargs = 2;
+ for (char const *tem = string; tem < string_end; tem++)
{
/* 'r' specifications ("point and mark as 2 numeric args")
produce *two* arguments. */
- if (*tem == 'r')
- nargs += 2;
- else
- nargs++;
- tem = strchr (tem, '\n');
- if (tem)
- ++tem;
- else
+ nargs += 1 + (*tem == 'r');
+ tem = memchr (tem, '\n', string_len - (tem - string));
+ if (!tem)
break;
}
@@ -487,21 +424,34 @@ invoke it. If KEYS is omitted or nil, the return value of
&& MOST_POSITIVE_FIXNUM < nargs)
memory_full (SIZE_MAX);
- /* Allocate them all at one go. This wastes a bit of memory, but
+ /* ARGS will contain the array of arguments to pass to the function.
+ VISARGS will contain the same list but in a nicer form, so that if we
+ pass it to Fformat_message it will be understandable to a human.
+ Allocate them all at one go. This wastes a bit of memory, but
it's OK to trade space for speed. */
+ Lisp_Object *args;
SAFE_NALLOCA (args, 3, nargs);
- visargs = args + nargs;
- varies = (signed char *) (visargs + nargs);
+ Lisp_Object *visargs = args + nargs;
+ /* If varies[I] > 0, the Ith argument shouldn't just have its value
+ in this call quoted in the command history. It should be
+ recorded as a call to the function named callint_argfuns[varies[I]]. */
+ signed char *varies = (signed char *) (visargs + nargs);
memclear (args, nargs * (2 * word_size + 1));
+ args = ptr_bounds_clip (args, nargs * sizeof *args);
+ visargs = ptr_bounds_clip (visargs, nargs * sizeof *visargs);
+ varies = ptr_bounds_clip (varies, nargs * sizeof *varies);
if (!NILP (enable))
specbind (Qenable_recursive_minibuffers, Qt);
- tem = string;
- for (i = 2; *tem; i++)
+ char const *tem = string;
+ for (ptrdiff_t i = 2; tem < string_end; i++)
{
- visargs[1] = make_string (tem + 1, strcspn (tem + 1, "\n"));
+ char *pnl = memchr (tem + 1, '\n', string_len - (tem + 1 - string));
+ ptrdiff_t sz = pnl ? pnl - (tem + 1) : string_end - (tem + 1);
+
+ visargs[1] = make_string (tem + 1, sz);
callint_message = Fformat_message (i - 1, visargs + 1);
switch (*tem)
@@ -510,9 +460,7 @@ invoke it. If KEYS is omitted or nil, the return value of
visargs[i] = Fcompleting_read (callint_message,
Vobarray, Qfboundp, Qt,
Qnil, Qnil, Qnil, Qnil);
- /* Passing args[i] directly stimulates compiler bug. */
- teml = visargs[i];
- args[i] = Fintern (teml, Qnil);
+ args[i] = Fintern (visargs[i], Qnil);
break;
case 'b': /* Name of existing buffer. */
@@ -524,31 +472,29 @@ invoke it. If KEYS is omitted or nil, the return value of
case 'B': /* Name of buffer, possibly nonexistent. */
args[i] = Fread_buffer (callint_message,
- Fother_buffer (Fcurrent_buffer (), Qnil, Qnil),
+ Fother_buffer (Fcurrent_buffer (),
+ Qnil, Qnil),
Qnil, Qnil);
break;
case 'c': /* Character. */
/* Prompt in `minibuffer-prompt' face. */
- Fput_text_property (make_number (0),
- make_number (SCHARS (callint_message)),
+ Fput_text_property (make_fixnum (0),
+ make_fixnum (SCHARS (callint_message)),
Qface, Qminibuffer_prompt, callint_message);
args[i] = Fread_char (callint_message, Qnil, Qnil);
message1_nolog (0);
- /* Passing args[i] directly stimulates compiler bug. */
- teml = args[i];
/* See bug#8479. */
- if (! CHARACTERP (teml)) error ("Non-character input-event");
- visargs[i] = Fchar_to_string (teml);
+ if (! CHARACTERP (args[i]))
+ error ("Non-character input-event");
+ visargs[i] = Fchar_to_string (args[i]);
break;
case 'C': /* Command: symbol with interactive function. */
visargs[i] = Fcompleting_read (callint_message,
Vobarray, Qcommandp,
Qt, Qnil, Qnil, Qnil, Qnil);
- /* Passing args[i] directly stimulates compiler bug. */
- teml = visargs[i];
- args[i] = Fintern (teml, Qnil);
+ args[i] = Fintern (visargs[i], Qnil);
break;
case 'd': /* Value of point. Does not do I/O. */
@@ -559,8 +505,8 @@ invoke it. If KEYS is omitted or nil, the return value of
break;
case 'D': /* Directory name. */
- args[i] = read_file_name (BVAR (current_buffer, directory), Qlambda, Qnil,
- Qfile_directory_p);
+ args[i] = read_file_name (BVAR (current_buffer, directory), Qlambda,
+ Qnil, Qfile_directory_p);
break;
case 'f': /* Existing file name. */
@@ -585,27 +531,25 @@ invoke it. If KEYS is omitted or nil, the return value of
ptrdiff_t speccount1 = SPECPDL_INDEX ();
specbind (Qcursor_in_echo_area, Qt);
/* Prompt in `minibuffer-prompt' face. */
- Fput_text_property (make_number (0),
- make_number (SCHARS (callint_message)),
+ Fput_text_property (make_fixnum (0),
+ make_fixnum (SCHARS (callint_message)),
Qface, Qminibuffer_prompt, callint_message);
args[i] = Fread_key_sequence (callint_message,
Qnil, Qnil, Qnil, Qnil);
unbind_to (speccount1, Qnil);
- teml = args[i];
- visargs[i] = Fkey_description (teml, Qnil);
+ visargs[i] = Fkey_description (args[i], Qnil);
/* If the key sequence ends with a down-event,
discard the following up-event. */
- teml = Faref (args[i], make_number (XINT (Flength (args[i])) - 1));
+ Lisp_Object teml
+ = Faref (args[i], make_fixnum (XFIXNUM (Flength (args[i])) - 1));
if (CONSP (teml))
teml = XCAR (teml);
if (SYMBOLP (teml))
{
- Lisp_Object tem2;
-
teml = Fget (teml, Qevent_symbol_elements);
/* Ignore first element, which is the base key. */
- tem2 = Fmemq (Qdown, Fcdr (teml));
+ Lisp_Object tem2 = Fmemq (Qdown, Fcdr (teml));
if (! NILP (tem2))
up_event = Fread_event (Qnil, Qnil, Qnil);
}
@@ -617,27 +561,25 @@ invoke it. If KEYS is omitted or nil, the return value of
ptrdiff_t speccount1 = SPECPDL_INDEX ();
specbind (Qcursor_in_echo_area, Qt);
/* Prompt in `minibuffer-prompt' face. */
- Fput_text_property (make_number (0),
- make_number (SCHARS (callint_message)),
+ Fput_text_property (make_fixnum (0),
+ make_fixnum (SCHARS (callint_message)),
Qface, Qminibuffer_prompt, callint_message);
args[i] = Fread_key_sequence_vector (callint_message,
Qnil, Qt, Qnil, Qnil);
- teml = args[i];
- visargs[i] = Fkey_description (teml, Qnil);
+ visargs[i] = Fkey_description (args[i], Qnil);
unbind_to (speccount1, Qnil);
/* If the key sequence ends with a down-event,
discard the following up-event. */
- teml = Faref (args[i], make_number (XINT (Flength (args[i])) - 1));
+ Lisp_Object teml
+ = Faref (args[i], make_fixnum (ASIZE (args[i]) - 1));
if (CONSP (teml))
teml = XCAR (teml);
if (SYMBOLP (teml))
{
- Lisp_Object tem2;
-
teml = Fget (teml, Qevent_symbol_elements);
/* Ignore first element, which is the base key. */
- tem2 = Fmemq (Qdown, Fcdr (teml));
+ Lisp_Object tem2 = Fmemq (Qdown, Fcdr (teml));
if (! NILP (tem2))
up_event = Fread_event (Qnil, Qnil, Qnil);
}
@@ -647,10 +589,9 @@ invoke it. If KEYS is omitted or nil, the return value of
case 'U': /* Up event from last k or K. */
if (!NILP (up_event))
{
- args[i] = Fmake_vector (make_number (1), up_event);
+ args[i] = make_vector (1, up_event);
up_event = Qnil;
- teml = args[i];
- visargs[i] = Fkey_description (teml, Qnil);
+ visargs[i] = Fkey_description (args[i], Qnil);
}
break;
@@ -661,18 +602,18 @@ invoke it. If KEYS is omitted or nil, the return value of
? SSDATA (SYMBOL_NAME (function))
: "command"));
args[i] = AREF (keys, next_event);
- next_event++;
varies[i] = -1;
/* Find the next parameterized event. */
- while (next_event < key_count
- && !(EVENT_HAS_PARAMETERS (AREF (keys, next_event))))
+ do
next_event++;
+ while (next_event < key_count
+ && ! EVENT_HAS_PARAMETERS (AREF (keys, next_event)));
break;
case 'm': /* Value of mark. Does not do I/O. */
- check_mark (0);
+ check_mark (false);
/* visargs[i] = Qnil; */
args[i] = BVAR (current_buffer, mark);
varies[i] = 2;
@@ -690,9 +631,7 @@ invoke it. If KEYS is omitted or nil, the return value of
FALLTHROUGH;
case 'n': /* Read number from minibuffer. */
args[i] = call1 (Qread_number, callint_message);
- /* Passing args[i] directly stimulates compiler bug. */
- teml = args[i];
- visargs[i] = Fnumber_to_string (teml);
+ visargs[i] = Fnumber_to_string (args[i]);
break;
case 'P': /* Prefix arg in raw form. Does no I/O. */
@@ -709,15 +648,16 @@ invoke it. If KEYS is omitted or nil, the return value of
break;
case 'r': /* Region, point and mark as 2 args. */
- check_mark (1);
- set_marker_both (point_marker, Qnil, PT, PT_BYTE);
- /* visargs[i+1] = Qnil; */
- mark = marker_position (BVAR (current_buffer, mark));
- /* visargs[i] = Qnil; */
- args[i] = PT < mark ? point_marker : BVAR (current_buffer, mark);
- varies[i] = 3;
- args[++i] = PT > mark ? point_marker : BVAR (current_buffer, mark);
- varies[i] = 4;
+ {
+ check_mark (true);
+ set_marker_both (point_marker, Qnil, PT, PT_BYTE);
+ ptrdiff_t mark = marker_position (BVAR (current_buffer, mark));
+ /* visargs[i] = visargs[i + 1] = Qnil; */
+ args[i] = PT < mark ? point_marker : BVAR (current_buffer, mark);
+ varies[i] = 3;
+ args[++i] = PT > mark ? point_marker : BVAR (current_buffer, mark);
+ varies[i] = 4;
+ }
break;
case 's': /* String read via minibuffer without
@@ -729,9 +669,7 @@ invoke it. If KEYS is omitted or nil, the return value of
case 'S': /* Any symbol. */
visargs[i] = Fread_string (callint_message,
Qnil, Qnil, Qnil, Qnil);
- /* Passing args[i] directly stimulates compiler bug. */
- teml = visargs[i];
- args[i] = Fintern (teml, Qnil);
+ args[i] = Fintern (visargs[i], Qnil);
break;
case 'v': /* Variable name: symbol that is
@@ -776,8 +714,8 @@ invoke it. If KEYS is omitted or nil, the return value of
default:
{
/* How many bytes are left unprocessed in the specs string?
- (Note that this excludes the trailing null byte.) */
- ptrdiff_t bytes_left = SBYTES (specs) - (tem - string);
+ (Note that this excludes the trailing NUL byte.) */
+ ptrdiff_t bytes_left = string_len - (tem - string);
unsigned letter;
/* If we have enough bytes left to treat the sequence as a
@@ -788,20 +726,21 @@ invoke it. If KEYS is omitted or nil, the return value of
else
letter = *((unsigned char *) tem);
- error ("Invalid control letter `%c' (#o%03o, #x%04x) in interactive calling string",
+ error (("Invalid control letter `%c' (#o%03o, #x%04x)"
+ " in interactive calling string"),
(int) letter, letter, letter);
}
}
if (varies[i] == 0)
- arg_from_tty = 1;
+ arg_from_tty = true;
if (NILP (visargs[i]) && STRINGP (args[i]))
visargs[i] = args[i];
- tem = strchr (tem, '\n');
+ tem = memchr (tem, '\n', string_len - (tem - string));
if (tem) tem++;
- else tem = "";
+ else tem = string_end;
}
unbind_to (speccount, Qnil);
@@ -815,27 +754,17 @@ invoke it. If KEYS is omitted or nil, the return value of
/* We don't need `visargs' any more, so let's recycle it since we need
an array of just the same size. */
visargs[1] = function;
- for (i = 2; i < nargs; i++)
- {
- if (varies[i] > 0)
- visargs[i] = list1 (intern (callint_argfuns[varies[i]]));
- else
- visargs[i] = quotify_arg (args[i]);
- }
- Vcommand_history = Fcons (Flist (nargs - 1, visargs + 1),
- Vcommand_history);
- /* Don't keep command history around forever. */
- if (INTEGERP (Vhistory_length) && XINT (Vhistory_length) > 0)
- {
- teml = Fnthcdr (Vhistory_length, Vcommand_history);
- if (CONSP (teml))
- XSETCDR (teml, Qnil);
- }
+ for (ptrdiff_t i = 2; i < nargs; i++)
+ visargs[i] = (varies[i] > 0
+ ? list1 (intern (callint_argfuns[varies[i]]))
+ : quotify_arg (args[i]));
+ call4 (intern ("add-to-history"), intern ("command-history"),
+ Flist (nargs - 1, visargs + 1), Qnil, Qt);
}
/* If we used a marker to hold point, mark, or an end of the region,
temporarily, convert it to an integer now. */
- for (i = 2; i < nargs; i++)
+ for (ptrdiff_t i = 2; i < nargs; i++)
if (varies[i] >= 1 && varies[i] <= 4)
XSETINT (args[i], marker_position (args[i]));
@@ -847,15 +776,10 @@ invoke it. If KEYS is omitted or nil, the return value of
Vreal_this_command = save_real_this_command;
kset_last_command (current_kboard, save_last_command);
- {
- Lisp_Object val;
- specbind (Qcommand_debug_status, Qnil);
+ specbind (Qcommand_debug_status, Qnil);
- val = Ffuncall (nargs, args);
- val = unbind_to (speccount, val);
- SAFE_FREE ();
- return val;
- }
+ Lisp_Object val = Ffuncall (nargs, args);
+ return SAFE_FREE_UNBIND_TO (speccount, val);
}
DEFUN ("prefix-numeric-value", Fprefix_numeric_value, Sprefix_numeric_value,
@@ -871,9 +795,9 @@ Its numeric meaning is what you would get from `(interactive "p")'. */)
XSETFASTINT (val, 1);
else if (EQ (raw, Qminus))
XSETINT (val, -1);
- else if (CONSP (raw) && INTEGERP (XCAR (raw)))
- XSETINT (val, XINT (XCAR (raw)));
- else if (INTEGERP (raw))
+ else if (CONSP (raw) && FIXNUMP (XCAR (raw)))
+ XSETINT (val, XFIXNUM (XCAR (raw)));
+ else if (FIXNUMP (raw))
val = raw;
else
XSETFASTINT (val, 1);
@@ -890,11 +814,11 @@ syms_of_callint (void)
callint_message = Qnil;
staticpro (&callint_message);
- preserved_fns = listn (CONSTYPE_PURE, 4,
- intern_c_string ("region-beginning"),
- intern_c_string ("region-end"),
- intern_c_string ("point"),
- intern_c_string ("mark"));
+ preserved_fns = pure_list (intern_c_string ("region-beginning"),
+ intern_c_string ("region-end"),
+ intern_c_string ("point"),
+ intern_c_string ("mark"));
+ staticpro (&preserved_fns);
DEFSYM (Qlist, "list");
DEFSYM (Qlet, "let");
diff --git a/src/callproc.c b/src/callproc.c
index fa12d02e394..a3d09609d7b 100644
--- a/src/callproc.c
+++ b/src/callproc.c
@@ -83,7 +83,7 @@ static pid_t synch_process_pid;
#ifdef MSDOS
static Lisp_Object synch_process_tempfile;
#else
-# define synch_process_tempfile make_number (0)
+# define synch_process_tempfile make_fixnum (0)
#endif
/* Indexes of file descriptors that need closing on call_process_kill. */
@@ -329,7 +329,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
#ifndef subprocesses
/* Without asynchronous processes we cannot have BUFFER == 0. */
if (nargs >= 3
- && (INTEGERP (CONSP (args[2]) ? XCAR (args[2]) : args[2])))
+ && (FIXNUMP (CONSP (args[2]) ? XCAR (args[2]) : args[2])))
error ("Operating system cannot handle asynchronous subprocesses");
#endif /* subprocesses */
@@ -408,7 +408,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
buffer = Qnil;
}
- if (! (NILP (buffer) || EQ (buffer, Qt) || INTEGERP (buffer)))
+ if (! (NILP (buffer) || EQ (buffer, Qt) || FIXNUMP (buffer)))
{
Lisp_Object spec_buffer;
spec_buffer = buffer;
@@ -436,7 +436,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
for (i = 0; i < CALLPROC_FDS; i++)
callproc_fd[i] = -1;
#ifdef MSDOS
- synch_process_tempfile = make_number (0);
+ synch_process_tempfile = make_fixnum (0);
#endif
record_unwind_protect_ptr (call_process_kill, callproc_fd);
@@ -445,7 +445,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
int ok;
ok = openp (Vexec_path, args[0], Vexec_suffixes, &path,
- make_number (X_OK), false);
+ make_fixnum (X_OK), false);
if (ok < 0)
report_file_error ("Searching for program", args[0]);
}
@@ -476,7 +476,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
path = ENCODE_FILE (path);
new_argv[0] = SSDATA (path);
- discard_output = INTEGERP (buffer) || (NILP (buffer) && NILP (output_file));
+ discard_output = FIXNUMP (buffer) || (NILP (buffer) && NILP (output_file));
#ifdef MSDOS
if (! discard_output && ! STRINGP (output_file))
@@ -604,7 +604,6 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
Lisp_Object volatile coding_systems_volatile = coding_systems;
Lisp_Object volatile current_dir_volatile = current_dir;
bool volatile display_p_volatile = display_p;
- bool volatile sa_must_free_volatile = sa_must_free;
int volatile fd_error_volatile = fd_error;
int volatile filefd_volatile = filefd;
ptrdiff_t volatile count_volatile = count;
@@ -621,7 +620,6 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
coding_systems = coding_systems_volatile;
current_dir = current_dir_volatile;
display_p = display_p_volatile;
- sa_must_free = sa_must_free_volatile;
fd_error = fd_error_volatile;
filefd = filefd_volatile;
count = count_volatile;
@@ -645,19 +643,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
#endif
unblock_child_signal (&oldset);
-
-#ifdef DARWIN_OS
- /* Darwin doesn't let us run setsid after a vfork, so use
- TIOCNOTTY when necessary. */
- int j = emacs_open (DEV_TTY, O_RDWR, 0);
- if (j >= 0)
- {
- ioctl (j, TIOCNOTTY, 0);
- emacs_close (j);
- }
-#else
- setsid ();
-#endif
+ dissociate_controlling_tty ();
/* Emacs ignores SIGPIPE, but the child should not. */
signal (SIGPIPE, SIG_DFL);
@@ -677,7 +663,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
{
synch_process_pid = pid;
- if (INTEGERP (buffer))
+ if (FIXNUMP (buffer))
{
if (tempfile_index < 0)
record_deleted_pid (pid, Qnil);
@@ -710,7 +696,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
#endif /* not MSDOS */
- if (INTEGERP (buffer))
+ if (FIXNUMP (buffer))
return unbind_to (count, Qnil);
if (BUFFERP (buffer))
@@ -877,7 +863,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
coding-system used to decode the process output. */
if (inherit_process_coding_system)
call1 (intern ("after-insert-file-set-buffer-file-coding-system"),
- make_number (total_read));
+ make_fixnum (total_read));
}
bool wait_ok = true;
@@ -890,8 +876,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
when exiting. */
synch_process_pid = 0;
- SAFE_FREE ();
- unbind_to (count, Qnil);
+ SAFE_FREE_UNBIND_TO (count, Qnil);
if (!wait_ok)
return build_unibyte_string ("internal error");
@@ -911,7 +896,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
}
eassert (WIFEXITED (status));
- return make_number (WEXITSTATUS (status));
+ return make_fixnum (WEXITSTATUS (status));
}
/* Create a temporary file suitable for storing the input data of
@@ -1075,7 +1060,7 @@ usage: (call-process-region START END PROGRAM &optional DELETE BUFFER DISPLAY &r
validate_region (&args[0], &args[1]);
start = args[0];
end = args[1];
- empty_input = XINT (start) == XINT (end);
+ empty_input = XFIXNUM (start) == XFIXNUM (end);
}
if (!empty_input)
@@ -1604,9 +1589,7 @@ init_callproc (void)
}
}
-#ifndef CANNOT_DUMP
- if (initialized)
-#endif
+ if (!will_dump_p ())
{
tempdir = Fdirectory_file_name (Vexec_directory);
if (! file_accessible_directory_p (tempdir))
@@ -1653,7 +1636,7 @@ syms_of_callproc (void)
staticpro (&Vtemp_file_name_pattern);
#ifdef MSDOS
- synch_process_tempfile = make_number (0);
+ synch_process_tempfile = make_fixnum (0);
staticpro (&synch_process_tempfile);
#endif
diff --git a/src/casefiddle.c b/src/casefiddle.c
index 1e459437142..3f407eadede 100644
--- a/src/casefiddle.c
+++ b/src/casefiddle.c
@@ -152,7 +152,7 @@ case_character_impl (struct casing_str_buf *buf,
prop = CHAR_TABLE_REF (ctx->titlecase_char_table, ch);
if (CHARACTERP (prop))
{
- cased = XFASTINT (prop);
+ cased = XFIXNAT (prop);
cased_is_set = true;
}
}
@@ -225,7 +225,7 @@ do_casify_natnum (struct casing_context *ctx, Lisp_Object obj)
{
int flagbits = (CHAR_ALT | CHAR_SUPER | CHAR_HYPER
| CHAR_SHIFT | CHAR_CTL | CHAR_META);
- int ch = XFASTINT (obj);
+ int ch = XFIXNAT (obj);
/* If the character has higher bits set above the flags, return it unchanged.
It is not a real character. */
@@ -250,7 +250,7 @@ do_casify_natnum (struct casing_context *ctx, Lisp_Object obj)
if (! multibyte)
MAKE_CHAR_UNIBYTE (cased);
- return make_natnum (cased | flags);
+ return make_fixed_natnum (cased | flags);
}
static Lisp_Object
@@ -319,7 +319,7 @@ casify_object (enum case_action flag, Lisp_Object obj)
struct casing_context ctx;
prepare_casing_context (&ctx, flag, false);
- if (NATNUMP (obj))
+ if (FIXNATP (obj))
return do_casify_natnum (&ctx, obj);
else if (!STRINGP (obj))
wrong_type_argument (Qchar_or_string_p, obj);
@@ -485,8 +485,8 @@ casify_region (enum case_action flag, Lisp_Object b, Lisp_Object e)
struct casing_context ctx;
validate_region (&b, &e);
- ptrdiff_t start = XFASTINT (b);
- ptrdiff_t end = XFASTINT (e);
+ ptrdiff_t start = XFIXNAT (b);
+ ptrdiff_t end = XFIXNAT (e);
if (start == end)
/* Not modifying because nothing marked. */
return end;
@@ -601,11 +601,11 @@ character positions to operate on. */)
static Lisp_Object
casify_word (enum case_action flag, Lisp_Object arg)
{
- CHECK_NUMBER (arg);
- ptrdiff_t farend = scan_words (PT, XINT (arg));
+ CHECK_FIXNUM (arg);
+ ptrdiff_t farend = scan_words (PT, XFIXNUM (arg));
if (!farend)
- farend = XINT (arg) <= 0 ? BEGV : ZV;
- SET_PT (casify_region (flag, make_number (PT), make_number (farend)));
+ farend = XFIXNUM (arg) <= 0 ? BEGV : ZV;
+ SET_PT (casify_region (flag, make_fixnum (PT), make_fixnum (farend)));
return Qnil;
}
diff --git a/src/casetab.c b/src/casetab.c
index a405fbec76f..b3ee24c4fa0 100644
--- a/src/casetab.c
+++ b/src/casetab.c
@@ -144,7 +144,8 @@ set_case_table (Lisp_Object table, bool standard)
set_char_table_extras (table, 2, eqv);
}
- /* This is so set_image_of_range_1 in regex.c can find the EQV table. */
+ /* This is so set_image_of_range_1 in regex-emacs.c can find the EQV
+ table. */
set_char_table_extras (canon, 2, eqv);
if (standard)
@@ -178,7 +179,7 @@ set_canon (Lisp_Object case_table, Lisp_Object range, Lisp_Object elt)
Lisp_Object up = XCHAR_TABLE (case_table)->extras[0];
Lisp_Object canon = XCHAR_TABLE (case_table)->extras[1];
- if (NATNUMP (elt))
+ if (FIXNATP (elt))
Fset_char_table_range (canon, range, Faref (case_table, Faref (up, elt)));
}
@@ -190,21 +191,21 @@ set_canon (Lisp_Object case_table, Lisp_Object range, Lisp_Object elt)
static void
set_identity (Lisp_Object table, Lisp_Object c, Lisp_Object elt)
{
- if (NATNUMP (elt))
+ if (FIXNATP (elt))
{
int from, to;
if (CONSP (c))
{
- from = XINT (XCAR (c));
- to = XINT (XCDR (c));
+ from = XFIXNUM (XCAR (c));
+ to = XFIXNUM (XCDR (c));
}
else
- from = to = XINT (c);
+ from = to = XFIXNUM (c);
to++;
for (; from < to; from++)
- CHAR_TABLE_SET (table, from, make_number (from));
+ CHAR_TABLE_SET (table, from, make_fixnum (from));
}
}
@@ -216,24 +217,24 @@ set_identity (Lisp_Object table, Lisp_Object c, Lisp_Object elt)
static void
shuffle (Lisp_Object table, Lisp_Object c, Lisp_Object elt)
{
- if (NATNUMP (elt))
+ if (FIXNATP (elt))
{
int from, to;
if (CONSP (c))
{
- from = XINT (XCAR (c));
- to = XINT (XCDR (c));
+ from = XFIXNUM (XCAR (c));
+ to = XFIXNUM (XCDR (c));
}
else
- from = to = XINT (c);
+ from = to = XFIXNUM (c);
to++;
for (; from < to; from++)
{
Lisp_Object tem = Faref (table, elt);
- Faset (table, elt, make_number (from));
- Faset (table, make_number (from), tem);
+ Faset (table, elt, make_fixnum (from));
+ Faset (table, make_fixnum (from), tem);
}
}
}
@@ -245,7 +246,7 @@ init_casetab_once (void)
Lisp_Object down, up, eqv;
DEFSYM (Qcase_table, "case-table");
- Fput (Qcase_table, Qchar_table_extra_slots, make_number (3));
+ Fput (Qcase_table, Qchar_table_extra_slots, make_fixnum (3));
down = Fmake_char_table (Qcase_table, Qnil);
Vascii_downcase_table = down;
@@ -254,7 +255,7 @@ init_casetab_once (void)
for (i = 0; i < 128; i++)
{
int c = (i >= 'A' && i <= 'Z') ? i + ('a' - 'A') : i;
- CHAR_TABLE_SET (down, i, make_number (c));
+ CHAR_TABLE_SET (down, i, make_fixnum (c));
}
set_char_table_extras (down, 1, Fcopy_sequence (down));
@@ -265,7 +266,7 @@ init_casetab_once (void)
for (i = 0; i < 128; i++)
{
int c = (i >= 'a' && i <= 'z') ? i + ('A' - 'a') : i;
- CHAR_TABLE_SET (up, i, make_number (c));
+ CHAR_TABLE_SET (up, i, make_fixnum (c));
}
eqv = Fmake_char_table (Qcase_table, Qnil);
@@ -275,7 +276,7 @@ init_casetab_once (void)
int c = ((i >= 'A' && i <= 'Z') ? i + ('a' - 'A')
: ((i >= 'a' && i <= 'z') ? i + ('A' - 'a')
: i));
- CHAR_TABLE_SET (eqv, i, make_number (c));
+ CHAR_TABLE_SET (eqv, i, make_fixnum (c));
}
set_char_table_extras (down, 2, eqv);
diff --git a/src/category.c b/src/category.c
index dddb1b79aba..132fae9d404 100644
--- a/src/category.c
+++ b/src/category.c
@@ -42,15 +42,6 @@ bset_category_table (struct buffer *b, Lisp_Object val)
b->category_table_ = val;
}
-/* The version number of the latest category table. Each category
- table has a unique version number. It is assigned a new number
- also when it is modified. When a regular expression is compiled
- into the struct re_pattern_buffer, the version number of the
- category table (of the current buffer) at that moment is also
- embedded in the structure.
-
- For the moment, we are not using this feature. */
-static int category_table_version;
/* Category set staff. */
@@ -103,7 +94,7 @@ those categories. */)
while (--len >= 0)
{
unsigned char cat = SREF (categories, len);
- Lisp_Object category = make_number (cat);
+ Lisp_Object category = make_fixnum (cat);
CHECK_CATEGORY (category);
set_category_set (val, cat, 1);
@@ -130,11 +121,11 @@ the current buffer's category table. */)
CHECK_STRING (docstring);
table = check_category_table (table);
- if (!NILP (CATEGORY_DOCSTRING (table, XFASTINT (category))))
- error ("Category `%c' is already defined", (int) XFASTINT (category));
+ if (!NILP (CATEGORY_DOCSTRING (table, XFIXNAT (category))))
+ error ("Category `%c' is already defined", (int) XFIXNAT (category));
if (!NILP (Vpurify_flag))
docstring = Fpurecopy (docstring);
- SET_CATEGORY_DOCSTRING (table, XFASTINT (category), docstring);
+ SET_CATEGORY_DOCSTRING (table, XFIXNAT (category), docstring);
return Qnil;
}
@@ -148,7 +139,7 @@ category table. */)
CHECK_CATEGORY (category);
table = check_category_table (table);
- return CATEGORY_DOCSTRING (table, XFASTINT (category));
+ return CATEGORY_DOCSTRING (table, XFIXNAT (category));
}
DEFUN ("get-unused-category", Fget_unused_category, Sget_unused_category,
@@ -165,7 +156,7 @@ it defaults to the current buffer's category table. */)
for (i = ' '; i <= '~'; i++)
if (NILP (CATEGORY_DOCSTRING (table, i)))
- return make_number (i);
+ return make_fixnum (i);
return Qnil;
}
@@ -220,9 +211,9 @@ copy_category_entry (Lisp_Object table, Lisp_Object c, Lisp_Object val)
{
val = Fcopy_sequence (val);
if (CONSP (c))
- char_table_set_range (table, XINT (XCAR (c)), XINT (XCDR (c)), val);
+ char_table_set_range (table, XFIXNUM (XCAR (c)), XFIXNUM (XCDR (c)), val);
else
- char_table_set (table, XINT (c), val);
+ char_table_set (table, XFIXNUM (c), val);
}
/* Return a copy of category table TABLE. We can't simply use the
@@ -271,8 +262,7 @@ DEFUN ("make-category-table", Fmake_category_table, Smake_category_table,
set_char_table_defalt (val, MAKE_CATEGORY_SET);
for (i = 0; i < (1 << CHARTAB_SIZE_BITS_0); i++)
set_char_table_contents (val, i, MAKE_CATEGORY_SET);
- Fset_char_table_extra_slot (val, make_number (0),
- Fmake_vector (make_number (95), Qnil));
+ Fset_char_table_extra_slot (val, make_fixnum (0), make_nil_vector (95));
return val;
}
@@ -303,7 +293,7 @@ usage: (char-category-set CHAR) */)
(Lisp_Object ch)
{
CHECK_CHARACTER (ch);
- return CATEGORY_SET (XFASTINT (ch));
+ return CATEGORY_SET (XFIXNAT (ch));
}
DEFUN ("category-set-mnemonics", Fcategory_set_mnemonics,
@@ -346,25 +336,25 @@ then delete CATEGORY from the category set instead of adding it. */)
int start, end;
int from, to;
- if (INTEGERP (character))
+ if (FIXNUMP (character))
{
CHECK_CHARACTER (character);
- start = end = XFASTINT (character);
+ start = end = XFIXNAT (character);
}
else
{
CHECK_CONS (character);
CHECK_CHARACTER_CAR (character);
CHECK_CHARACTER_CDR (character);
- start = XFASTINT (XCAR (character));
- end = XFASTINT (XCDR (character));
+ start = XFIXNAT (XCAR (character));
+ end = XFIXNAT (XCDR (character));
}
CHECK_CATEGORY (category);
table = check_category_table (table);
- if (NILP (CATEGORY_DOCSTRING (table, XFASTINT (category))))
- error ("Undefined category: %c", (int) XFASTINT (category));
+ if (NILP (CATEGORY_DOCSTRING (table, XFIXNAT (category))))
+ error ("Undefined category: %c", (int) XFIXNAT (category));
set_value = NILP (reset);
@@ -372,10 +362,10 @@ then delete CATEGORY from the category set instead of adding it. */)
{
from = start, to = end;
category_set = char_table_ref_and_range (table, start, &from, &to);
- if (CATEGORY_MEMBER (XFASTINT (category), category_set) != NILP (reset))
+ if (CATEGORY_MEMBER (XFIXNAT (category), category_set) != NILP (reset))
{
category_set = Fcopy_sequence (category_set);
- set_category_set (category_set, XFASTINT (category), set_value);
+ set_category_set (category_set, XFIXNAT (category), set_value);
category_set = hash_get_category_set (table, category_set);
char_table_set_range (table, start, to, category_set);
}
@@ -423,12 +413,12 @@ word_boundary_p (int c1, int c2)
if (CONSP (elt)
&& (NILP (XCAR (elt))
|| (CATEGORYP (XCAR (elt))
- && CATEGORY_MEMBER (XFASTINT (XCAR (elt)), category_set1)
- && ! CATEGORY_MEMBER (XFASTINT (XCAR (elt)), category_set2)))
+ && CATEGORY_MEMBER (XFIXNAT (XCAR (elt)), category_set1)
+ && ! CATEGORY_MEMBER (XFIXNAT (XCAR (elt)), category_set2)))
&& (NILP (XCDR (elt))
|| (CATEGORYP (XCDR (elt))
- && ! CATEGORY_MEMBER (XFASTINT (XCDR (elt)), category_set1)
- && CATEGORY_MEMBER (XFASTINT (XCDR (elt)), category_set2))))
+ && ! CATEGORY_MEMBER (XFIXNAT (XCDR (elt)), category_set1)
+ && CATEGORY_MEMBER (XFIXNAT (XCDR (elt)), category_set2))))
return !default_result;
}
return default_result;
@@ -440,13 +430,13 @@ init_category_once (void)
{
/* This has to be done here, before we call Fmake_char_table. */
DEFSYM (Qcategory_table, "category-table");
- Fput (Qcategory_table, Qchar_table_extra_slots, make_number (2));
+ Fput (Qcategory_table, Qchar_table_extra_slots, make_fixnum (2));
Vstandard_category_table = Fmake_char_table (Qcategory_table, Qnil);
/* Set a category set which contains nothing to the default. */
set_char_table_defalt (Vstandard_category_table, MAKE_CATEGORY_SET);
- Fset_char_table_extra_slot (Vstandard_category_table, make_number (0),
- Fmake_vector (make_number (95), Qnil));
+ Fset_char_table_extra_slot (Vstandard_category_table, make_fixnum (0),
+ make_nil_vector (95));
}
void
@@ -513,6 +503,4 @@ See the documentation of the variable `word-combining-categories'. */);
defsubr (&Schar_category_set);
defsubr (&Scategory_set_mnemonics);
defsubr (&Smodify_category_entry);
-
- category_table_version = 0;
}
diff --git a/src/category.h b/src/category.h
index c4feedd358f..cc329904784 100644
--- a/src/category.h
+++ b/src/category.h
@@ -59,7 +59,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
INLINE_HEADER_BEGIN
-#define CATEGORYP(x) RANGED_INTEGERP (0x20, x, 0x7E)
+#define CATEGORYP(x) RANGED_FIXNUMP (0x20, x, 0x7E)
#define CHECK_CATEGORY(x) \
CHECK_TYPE (CATEGORYP (x), Qcategoryp, x)
@@ -68,7 +68,7 @@ INLINE_HEADER_BEGIN
(BOOL_VECTOR_P (x) && bool_vector_size (x) == 128)
/* Return a new empty category set. */
-#define MAKE_CATEGORY_SET (Fmake_bool_vector (make_number (128), Qnil))
+#define MAKE_CATEGORY_SET (Fmake_bool_vector (make_fixnum (128), Qnil))
#define CHECK_CATEGORY_SET(x) \
CHECK_TYPE (CATEGORY_SET_P (x), Qcategorysetp, x)
@@ -77,7 +77,7 @@ INLINE_HEADER_BEGIN
#define CATEGORY_SET(c) char_category_set (c)
/* Return true if CATEGORY_SET contains CATEGORY.
- Faster than '!NILP (Faref (category_set, make_number (category)))'. */
+ Faster than '!NILP (Faref (category_set, make_fixnum (category)))'. */
INLINE bool
CATEGORY_MEMBER (EMACS_INT category, Lisp_Object category_set)
{
@@ -98,16 +98,16 @@ CHAR_HAS_CATEGORY (int ch, int category)
/* Return the doc string of CATEGORY in category table TABLE. */
#define CATEGORY_DOCSTRING(table, category) \
- AREF (Fchar_table_extra_slot (table, make_number (0)), ((category) - ' '))
+ AREF (Fchar_table_extra_slot (table, make_fixnum (0)), ((category) - ' '))
/* Set the doc string of CATEGORY to VALUE in category table TABLE. */
#define SET_CATEGORY_DOCSTRING(table, category, value) \
- ASET (Fchar_table_extra_slot (table, make_number (0)), ((category) - ' '), value)
+ ASET (Fchar_table_extra_slot (table, make_fixnum (0)), ((category) - ' '), value)
/* Return the version number of category table TABLE. Not used for
the moment. */
#define CATEGORY_TABLE_VERSION (table) \
- Fchar_table_extra_slot (table, make_number (1))
+ Fchar_table_extra_slot (table, make_fixnum (1))
/* Return true if there is a word boundary between two
word-constituent characters C1 and C2 if they appear in this order.
diff --git a/src/ccl.c b/src/ccl.c
index e258b12b01b..ec108e30d86 100644
--- a/src/ccl.c
+++ b/src/ccl.c
@@ -629,7 +629,7 @@ do \
stack_idx++; \
ccl_prog = called_ccl.prog; \
ic = CCL_HEADER_MAIN; \
- eof_ic = XFASTINT (ccl_prog[CCL_HEADER_EOF]); \
+ eof_ic = XFIXNAT (ccl_prog[CCL_HEADER_EOF]); \
goto ccl_repeat; \
} \
while (0)
@@ -736,7 +736,7 @@ while (0)
#define GET_CCL_RANGE(var, ccl_prog, ic, lo, hi) \
do \
{ \
- EMACS_INT prog_word = XINT ((ccl_prog)[ic]); \
+ EMACS_INT prog_word = XFIXNUM ((ccl_prog)[ic]); \
if (! ASCENDING_ORDER (lo, prog_word, hi)) \
CCL_INVALID_CMD; \
(var) = prog_word; \
@@ -769,12 +769,12 @@ while (0)
CCL_INVALID_CMD; \
else if (dst + len <= dst_end) \
{ \
- if (XFASTINT (ccl_prog[ic]) & 0x1000000) \
+ if (XFIXNAT (ccl_prog[ic]) & 0x1000000) \
for (ccli = 0; ccli < len; ccli++) \
- *dst++ = XFASTINT (ccl_prog[ic + ccli]) & 0xFFFFFF; \
+ *dst++ = XFIXNAT (ccl_prog[ic + ccli]) & 0xFFFFFF; \
else \
for (ccli = 0; ccli < len; ccli++) \
- *dst++ = ((XFASTINT (ccl_prog[ic + (ccli / 3)])) \
+ *dst++ = ((XFIXNAT (ccl_prog[ic + (ccli / 3)])) \
>> ((2 - (ccli % 3)) * 8)) & 0xFF; \
} \
else \
@@ -926,14 +926,14 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
break;
case CCL_SetConst: /* 00000000000000000000rrrXXXXX */
- reg[rrr] = XINT (ccl_prog[ic++]);
+ reg[rrr] = XFIXNUM (ccl_prog[ic++]);
break;
case CCL_SetArray: /* CCCCCCCCCCCCCCCCCCCCRRRrrrXXXXX */
i = reg[RRR];
j = field1 >> 3;
if (0 <= i && i < j)
- reg[rrr] = XINT (ccl_prog[ic + i]);
+ reg[rrr] = XFIXNUM (ccl_prog[ic + i]);
ic += j;
break;
@@ -961,13 +961,13 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
break;
case CCL_WriteConstJump: /* A--D--D--R--E--S--S-000XXXXX */
- i = XINT (ccl_prog[ic]);
+ i = XFIXNUM (ccl_prog[ic]);
CCL_WRITE_CHAR (i);
ic += ADDR;
break;
case CCL_WriteConstReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
- i = XINT (ccl_prog[ic]);
+ i = XFIXNUM (ccl_prog[ic]);
CCL_WRITE_CHAR (i);
ic++;
CCL_READ_CHAR (reg[rrr]);
@@ -975,17 +975,17 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
break;
case CCL_WriteStringJump: /* A--D--D--R--E--S--S-000XXXXX */
- j = XINT (ccl_prog[ic++]);
+ j = XFIXNUM (ccl_prog[ic++]);
CCL_WRITE_STRING (j);
ic += ADDR - 1;
break;
case CCL_WriteArrayReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
i = reg[rrr];
- j = XINT (ccl_prog[ic]);
+ j = XFIXNUM (ccl_prog[ic]);
if (0 <= i && i < j)
{
- i = XINT (ccl_prog[ic + 1 + i]);
+ i = XFIXNUM (ccl_prog[ic + 1 + i]);
CCL_WRITE_CHAR (i);
}
ic += j + 2;
@@ -1004,7 +1004,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
case CCL_Branch: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
{
int ioff = 0 <= reg[rrr] && reg[rrr] < field1 ? reg[rrr] : field1;
- int incr = XINT (ccl_prog[ic + ioff]);
+ int incr = XFIXNUM (ccl_prog[ic + ioff]);
ic += incr;
}
break;
@@ -1023,7 +1023,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
case CCL_WriteExprConst: /* 1:00000OPERATION000RRR000XXXXX */
rrr = 7;
i = reg[RRR];
- j = XINT (ccl_prog[ic]);
+ j = XFIXNUM (ccl_prog[ic]);
op = field1 >> 6;
jump_address = ic + 1;
goto ccl_set_expr;
@@ -1056,7 +1056,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
/* If FFF is nonzero, the CCL program ID is in the
following code. */
if (rrr)
- prog_id = XINT (ccl_prog[ic++]);
+ prog_id = XFIXNUM (ccl_prog[ic++]);
else
prog_id = field1;
@@ -1081,7 +1081,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
stack_idx++;
ccl_prog = XVECTOR (AREF (slot, 1))->contents;
ic = CCL_HEADER_MAIN;
- eof_ic = XFASTINT (ccl_prog[CCL_HEADER_EOF]);
+ eof_ic = XFIXNAT (ccl_prog[CCL_HEADER_EOF]);
}
break;
@@ -1099,7 +1099,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
i = reg[rrr];
if (0 <= i && i < field1)
{
- j = XINT (ccl_prog[ic + i]);
+ j = XFIXNUM (ccl_prog[ic + i]);
CCL_WRITE_CHAR (j);
}
ic += field1;
@@ -1124,7 +1124,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
CCL_SUCCESS;
case CCL_ExprSelfConst: /* 00000OPERATION000000rrrXXXXX */
- i = XINT (ccl_prog[ic++]);
+ i = XFIXNUM (ccl_prog[ic++]);
op = field1 >> 6;
goto ccl_expr_self;
@@ -1160,7 +1160,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
case CCL_SetExprConst: /* 00000OPERATION000RRRrrrXXXXX */
i = reg[RRR];
- j = XINT (ccl_prog[ic++]);
+ j = XFIXNUM (ccl_prog[ic++]);
op = field1 >> 6;
jump_address = ic;
goto ccl_set_expr;
@@ -1178,8 +1178,8 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
case CCL_JumpCondExprConst: /* A--D--D--R--E--S--S-rrrXXXXX */
i = reg[rrr];
jump_address = ic + ADDR;
- op = XINT (ccl_prog[ic++]);
- j = XINT (ccl_prog[ic++]);
+ op = XFIXNUM (ccl_prog[ic++]);
+ j = XFIXNUM (ccl_prog[ic++]);
rrr = 7;
goto ccl_set_expr;
@@ -1189,7 +1189,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
case CCL_JumpCondExprReg:
i = reg[rrr];
jump_address = ic + ADDR;
- op = XINT (ccl_prog[ic++]);
+ op = XFIXNUM (ccl_prog[ic++]);
GET_CCL_RANGE (j, ccl_prog, ic++, 0, 7);
j = reg[j];
rrr = 7;
@@ -1291,7 +1291,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
: -1));
h = GET_HASH_TABLE (eop);
- eop = hash_lookup (h, make_number (reg[RRR]), NULL);
+ eop = hash_lookup (h, make_fixnum (reg[RRR]), NULL);
if (eop >= 0)
{
Lisp_Object opl;
@@ -1318,14 +1318,14 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
i = CCL_DECODE_CHAR (reg[RRR], reg[rrr]);
h = GET_HASH_TABLE (eop);
- eop = hash_lookup (h, make_number (i), NULL);
+ eop = hash_lookup (h, make_fixnum (i), NULL);
if (eop >= 0)
{
Lisp_Object opl;
opl = HASH_VALUE (h, eop);
- if (! (INTEGERP (opl) && IN_INT_RANGE (XINT (opl))))
+ if (! (FIXNUMP (opl) && IN_INT_RANGE (XFIXNUM (opl))))
CCL_INVALID_CMD;
- reg[RRR] = XINT (opl);
+ reg[RRR] = XFIXNUM (opl);
reg[7] = 1; /* r7 true for success */
}
else
@@ -1340,7 +1340,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
ptrdiff_t size;
int fin_ic;
- j = XINT (ccl_prog[ic++]); /* number of maps. */
+ j = XFIXNUM (ccl_prog[ic++]); /* number of maps. */
fin_ic = ic + j;
op = reg[rrr];
if ((j > reg[RRR]) && (j >= 0))
@@ -1359,7 +1359,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
{
if (!VECTORP (Vcode_conversion_map_vector)) continue;
size = ASIZE (Vcode_conversion_map_vector);
- point = XINT (ccl_prog[ic++]);
+ point = XFIXNUM (ccl_prog[ic++]);
if (! (0 <= point && point < size)) continue;
map = AREF (Vcode_conversion_map_vector, point);
@@ -1375,19 +1375,19 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
/* check map type,
[STARTPOINT VAL1 VAL2 ...] or
[t ELEMENT STARTPOINT ENDPOINT] */
- if (INTEGERP (content))
+ if (FIXNUMP (content))
{
- point = XINT (content);
+ point = XFIXNUM (content);
if (!(point <= op && op - point + 1 < size)) continue;
content = AREF (map, op - point + 1);
}
else if (EQ (content, Qt))
{
if (size != 4) continue;
- if (INTEGERP (AREF (map, 2))
- && XINT (AREF (map, 2)) <= op
- && INTEGERP (AREF (map, 3))
- && op < XINT (AREF (map, 3)))
+ if (FIXNUMP (AREF (map, 2))
+ && XFIXNUM (AREF (map, 2)) <= op
+ && FIXNUMP (AREF (map, 3))
+ && op < XFIXNUM (AREF (map, 3)))
content = AREF (map, 1);
else
continue;
@@ -1397,10 +1397,10 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
if (NILP (content))
continue;
- else if (INTEGERP (content) && IN_INT_RANGE (XINT (content)))
+ else if (FIXNUMP (content) && IN_INT_RANGE (XFIXNUM (content)))
{
reg[RRR] = i;
- reg[rrr] = XINT (content);
+ reg[rrr] = XFIXNUM (content);
break;
}
else if (EQ (content, Qt) || EQ (content, Qlambda))
@@ -1412,11 +1412,11 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
{
attrib = XCAR (content);
value = XCDR (content);
- if (! (INTEGERP (attrib) && INTEGERP (value)
- && IN_INT_RANGE (XINT (value))))
+ if (! (FIXNUMP (attrib) && FIXNUMP (value)
+ && IN_INT_RANGE (XFIXNUM (value))))
continue;
reg[RRR] = i;
- reg[rrr] = XINT (value);
+ reg[rrr] = XFIXNUM (value);
break;
}
else if (SYMBOLP (content))
@@ -1453,7 +1453,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
stack_idx_of_map_multiple = 0;
/* Get number of maps and separators. */
- map_set_rest_length = XINT (ccl_prog[ic++]);
+ map_set_rest_length = XFIXNUM (ccl_prog[ic++]);
fin_ic = ic + map_set_rest_length;
op = reg[rrr];
@@ -1524,7 +1524,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
do {
for (;map_set_rest_length > 0;i++, ic++, map_set_rest_length--)
{
- point = XINT (ccl_prog[ic]);
+ point = XFIXNUM (ccl_prog[ic]);
if (point < 0)
{
/* +1 is for including separator. */
@@ -1554,19 +1554,19 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
/* check map type,
[STARTPOINT VAL1 VAL2 ...] or
[t ELEMENT STARTPOINT ENDPOINT] */
- if (INTEGERP (content))
+ if (FIXNUMP (content))
{
- point = XINT (content);
+ point = XFIXNUM (content);
if (!(point <= op && op - point + 1 < size)) continue;
content = AREF (map, op - point + 1);
}
else if (EQ (content, Qt))
{
if (size != 4) continue;
- if (INTEGERP (AREF (map, 2))
- && XINT (AREF (map, 2)) <= op
- && INTEGERP (AREF (map, 3))
- && op < XINT (AREF (map, 3)))
+ if (FIXNUMP (AREF (map, 2))
+ && XFIXNUM (AREF (map, 2)) <= op
+ && FIXNUMP (AREF (map, 3))
+ && op < XFIXNUM (AREF (map, 3)))
content = AREF (map, 1);
else
continue;
@@ -1578,9 +1578,9 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
continue;
reg[RRR] = i;
- if (INTEGERP (content) && IN_INT_RANGE (XINT (content)))
+ if (FIXNUMP (content) && IN_INT_RANGE (XFIXNUM (content)))
{
- op = XINT (content);
+ op = XFIXNUM (content);
i += map_set_rest_length - 1;
ic += map_set_rest_length - 1;
POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
@@ -1590,10 +1590,10 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
{
attrib = XCAR (content);
value = XCDR (content);
- if (! (INTEGERP (attrib) && INTEGERP (value)
- && IN_INT_RANGE (XINT (value))))
+ if (! (FIXNUMP (attrib) && FIXNUMP (value)
+ && IN_INT_RANGE (XFIXNUM (value))))
continue;
- op = XINT (value);
+ op = XFIXNUM (value);
i += map_set_rest_length - 1;
ic += map_set_rest_length - 1;
POP_MAPPING_STACK (map_set_rest_length, reg[rrr]);
@@ -1639,7 +1639,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
{
Lisp_Object map, attrib, value, content;
int point;
- j = XINT (ccl_prog[ic++]); /* map_id */
+ j = XFIXNUM (ccl_prog[ic++]); /* map_id */
op = reg[rrr];
if (! (VECTORP (Vcode_conversion_map_vector)
&& j < ASIZE (Vcode_conversion_map_vector)))
@@ -1656,29 +1656,29 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
map = XCDR (map);
if (! (VECTORP (map)
&& 0 < ASIZE (map)
- && INTEGERP (AREF (map, 0))
- && XINT (AREF (map, 0)) <= op
- && op - XINT (AREF (map, 0)) + 1 < ASIZE (map)))
+ && FIXNUMP (AREF (map, 0))
+ && XFIXNUM (AREF (map, 0)) <= op
+ && op - XFIXNUM (AREF (map, 0)) + 1 < ASIZE (map)))
{
reg[RRR] = -1;
break;
}
- point = op - XINT (AREF (map, 0)) + 1;
+ point = op - XFIXNUM (AREF (map, 0)) + 1;
reg[RRR] = 0;
content = AREF (map, point);
if (NILP (content))
reg[RRR] = -1;
- else if (TYPE_RANGED_INTEGERP (int, content))
- reg[rrr] = XINT (content);
+ else if (TYPE_RANGED_FIXNUMP (int, content))
+ reg[rrr] = XFIXNUM (content);
else if (EQ (content, Qt));
else if (CONSP (content))
{
attrib = XCAR (content);
value = XCDR (content);
- if (!INTEGERP (attrib)
- || !TYPE_RANGED_INTEGERP (int, value))
+ if (!FIXNUMP (attrib)
+ || !TYPE_RANGED_FIXNUMP (int, value))
continue;
- reg[rrr] = XINT (value);
+ reg[rrr] = XFIXNUM (value);
break;
}
else if (SYMBOLP (content))
@@ -1809,7 +1809,7 @@ resolve_symbol_ccl_program (Lisp_Object ccl)
for (i = 0; i < veclen; i++)
{
contents = AREF (result, i);
- if (TYPE_RANGED_INTEGERP (int, contents))
+ if (TYPE_RANGED_FIXNUMP (int, contents))
continue;
else if (CONSP (contents)
&& SYMBOLP (XCAR (contents))
@@ -1819,7 +1819,7 @@ resolve_symbol_ccl_program (Lisp_Object ccl)
(SYMBOL . PROPERTY). (get SYMBOL PROPERTY) should give
an index number. */
val = Fget (XCAR (contents), XCDR (contents));
- if (RANGED_INTEGERP (0, val, INT_MAX))
+ if (RANGED_FIXNUMP (0, val, INT_MAX))
ASET (result, i, val);
else
unresolved = 1;
@@ -1831,17 +1831,17 @@ resolve_symbol_ccl_program (Lisp_Object ccl)
may lead to a bug if, for instance, a translation table
and a code conversion map have the same name. */
val = Fget (contents, Qtranslation_table_id);
- if (RANGED_INTEGERP (0, val, INT_MAX))
+ if (RANGED_FIXNUMP (0, val, INT_MAX))
ASET (result, i, val);
else
{
val = Fget (contents, Qcode_conversion_map_id);
- if (RANGED_INTEGERP (0, val, INT_MAX))
+ if (RANGED_FIXNUMP (0, val, INT_MAX))
ASET (result, i, val);
else
{
val = Fget (contents, Qccl_program_idx);
- if (RANGED_INTEGERP (0, val, INT_MAX))
+ if (RANGED_FIXNUMP (0, val, INT_MAX))
ASET (result, i, val);
else
unresolved = 1;
@@ -1852,8 +1852,8 @@ resolve_symbol_ccl_program (Lisp_Object ccl)
return Qnil;
}
- if (! (0 <= XINT (AREF (result, CCL_HEADER_BUF_MAG))
- && ASCENDING_ORDER (0, XINT (AREF (result, CCL_HEADER_EOF)),
+ if (! (0 <= XFIXNUM (AREF (result, CCL_HEADER_BUF_MAG))
+ && ASCENDING_ORDER (0, XFIXNUM (AREF (result, CCL_HEADER_EOF)),
ASIZE (ccl))))
return Qnil;
@@ -1881,15 +1881,15 @@ ccl_get_compiled_code (Lisp_Object ccl_prog, ptrdiff_t *idx)
return Qnil;
val = Fget (ccl_prog, Qccl_program_idx);
- if (! NATNUMP (val)
- || XINT (val) >= ASIZE (Vccl_program_table))
+ if (! FIXNATP (val)
+ || XFIXNUM (val) >= ASIZE (Vccl_program_table))
return Qnil;
- slot = AREF (Vccl_program_table, XINT (val));
+ slot = AREF (Vccl_program_table, XFIXNUM (val));
if (! VECTORP (slot)
|| ASIZE (slot) != 4
|| ! VECTORP (AREF (slot, 1)))
return Qnil;
- *idx = XINT (val);
+ *idx = XFIXNUM (val);
if (NILP (AREF (slot, 2)))
{
val = resolve_symbol_ccl_program (AREF (slot, 1));
@@ -1920,8 +1920,8 @@ setup_ccl_program (struct ccl_program *ccl, Lisp_Object ccl_prog)
vp = XVECTOR (ccl_prog);
ccl->size = vp->header.size;
ccl->prog = vp->contents;
- ccl->eof_ic = XINT (vp->contents[CCL_HEADER_EOF]);
- ccl->buf_magnification = XINT (vp->contents[CCL_HEADER_BUF_MAG]);
+ ccl->eof_ic = XFIXNUM (vp->contents[CCL_HEADER_EOF]);
+ ccl->buf_magnification = XFIXNUM (vp->contents[CCL_HEADER_BUF_MAG]);
if (ccl->idx >= 0)
{
Lisp_Object slot;
@@ -1956,8 +1956,8 @@ See the documentation of `define-ccl-program' for the detail of CCL program. */
return Qnil;
val = Fget (object, Qccl_program_idx);
- return ((! NATNUMP (val)
- || XINT (val) >= ASIZE (Vccl_program_table))
+ return ((! FIXNATP (val)
+ || XFIXNUM (val) >= ASIZE (Vccl_program_table))
? Qnil : Qt);
}
@@ -1990,8 +1990,8 @@ programs. */)
error ("Length of vector REGISTERS is not 8");
for (i = 0; i < 8; i++)
- ccl.reg[i] = (TYPE_RANGED_INTEGERP (int, AREF (reg, i))
- ? XINT (AREF (reg, i))
+ ccl.reg[i] = (TYPE_RANGED_FIXNUMP (int, AREF (reg, i))
+ ? XFIXNUM (AREF (reg, i))
: 0);
ccl_driver (&ccl, NULL, NULL, 0, 0, Qnil);
@@ -2000,7 +2000,7 @@ programs. */)
error ("Error in CCL program at %dth code", ccl.ic);
for (i = 0; i < 8; i++)
- ASET (reg, i, make_number (ccl.reg[i]));
+ ASET (reg, i, make_fixnum (ccl.reg[i]));
return Qnil;
}
@@ -2058,13 +2058,13 @@ usage: (ccl-execute-on-string CCL-PROGRAM STATUS STRING &optional CONTINUE UNIBY
for (i = 0; i < 8; i++)
{
if (NILP (AREF (status, i)))
- ASET (status, i, make_number (0));
- if (TYPE_RANGED_INTEGERP (int, AREF (status, i)))
- ccl.reg[i] = XINT (AREF (status, i));
+ ASET (status, i, make_fixnum (0));
+ if (TYPE_RANGED_FIXNUMP (int, AREF (status, i)))
+ ccl.reg[i] = XFIXNUM (AREF (status, i));
}
- if (INTEGERP (AREF (status, i)))
+ if (FIXNUMP (AREF (status, i)))
{
- i = XFASTINT (AREF (status, 8));
+ i = XFIXNAT (AREF (status, 8));
if (ccl.ic < i && i < ccl.size)
ccl.ic = i;
}
@@ -2139,8 +2139,8 @@ usage: (ccl-execute-on-string CCL-PROGRAM STATUS STRING &optional CONTINUE UNIBY
error ("CCL program interrupted at %dth code", ccl.ic);
for (i = 0; i < 8; i++)
- ASET (status, i, make_number (ccl.reg[i]));
- ASET (status, 8, make_number (ccl.ic));
+ ASET (status, i, make_fixnum (ccl.reg[i]));
+ ASET (status, 8, make_fixnum (ccl.ic));
val = make_specified_string ((const char *) outbuf, produced_chars,
outp - outbuf, NILP (unibyte_p));
@@ -2193,7 +2193,7 @@ Return index number of the registered CCL program. */)
ASET (slot, 1, ccl_prog);
ASET (slot, 2, resolved);
ASET (slot, 3, Qt);
- return make_number (idx);
+ return make_fixnum (idx);
}
}
@@ -2211,8 +2211,8 @@ Return index number of the registered CCL program. */)
ASET (Vccl_program_table, idx, elt);
}
- Fput (name, Qccl_program_idx, make_number (idx));
- return make_number (idx);
+ Fput (name, Qccl_program_idx, make_fixnum (idx));
+ return make_fixnum (idx);
}
/* Register code conversion map.
@@ -2251,7 +2251,7 @@ Return index number of the registered map. */)
if (EQ (symbol, XCAR (slot)))
{
- idx = make_number (i);
+ idx = make_fixnum (i);
XSETCDR (slot, map);
Fput (symbol, Qcode_conversion_map, map);
Fput (symbol, Qcode_conversion_map_id, idx);
@@ -2263,7 +2263,7 @@ Return index number of the registered map. */)
Vcode_conversion_map_vector = larger_vector (Vcode_conversion_map_vector,
1, -1);
- idx = make_number (i);
+ idx = make_fixnum (i);
Fput (symbol, Qcode_conversion_map, map);
Fput (symbol, Qcode_conversion_map_id, idx);
ASET (Vcode_conversion_map_vector, i, Fcons (symbol, map));
@@ -2275,7 +2275,7 @@ void
syms_of_ccl (void)
{
staticpro (&Vccl_program_table);
- Vccl_program_table = Fmake_vector (make_number (32), Qnil);
+ Vccl_program_table = make_nil_vector (32);
DEFSYM (Qccl, "ccl");
DEFSYM (Qcclp, "cclp");
@@ -2291,7 +2291,7 @@ syms_of_ccl (void)
DEFVAR_LISP ("code-conversion-map-vector", Vcode_conversion_map_vector,
doc: /* Vector of code conversion maps. */);
- Vcode_conversion_map_vector = Fmake_vector (make_number (16), Qnil);
+ Vcode_conversion_map_vector = make_nil_vector (16);
DEFVAR_LISP ("font-ccl-encoder-alist", Vfont_ccl_encoder_alist,
doc: /* Alist of fontname patterns vs corresponding CCL program.
diff --git a/src/character.c b/src/character.c
index 021ac83cbe0..d14d0df29f8 100644
--- a/src/character.c
+++ b/src/character.c
@@ -207,7 +207,7 @@ translate_char (Lisp_Object table, int c)
ch = CHAR_TABLE_REF (table, c);
if (CHARACTERP (ch))
- c = XINT (ch);
+ c = XFIXNUM (ch);
}
else
{
@@ -234,7 +234,7 @@ DEFUN ("max-char", Fmax_char, Smax_char, 0, 0, 0,
attributes: const)
(void)
{
- return make_number (MAX_CHAR);
+ return make_fixnum (MAX_CHAR);
}
DEFUN ("unibyte-char-to-multibyte", Funibyte_char_to_multibyte,
@@ -245,11 +245,11 @@ DEFUN ("unibyte-char-to-multibyte", Funibyte_char_to_multibyte,
int c;
CHECK_CHARACTER (ch);
- c = XFASTINT (ch);
+ c = XFIXNAT (ch);
if (c >= 0x100)
error ("Not a unibyte character: %d", c);
MAKE_CHAR_MULTIBYTE (c);
- return make_number (c);
+ return make_fixnum (c);
}
DEFUN ("multibyte-char-to-unibyte", Fmultibyte_char_to_unibyte,
@@ -261,7 +261,7 @@ If the multibyte character does not represent a byte, return -1. */)
int cm;
CHECK_CHARACTER (ch);
- cm = XFASTINT (ch);
+ cm = XFIXNAT (ch);
if (cm < 256)
/* Can't distinguish a byte read from a unibyte buffer from
a latin1 char, so let's let it slide. */
@@ -269,7 +269,7 @@ If the multibyte character does not represent a byte, return -1. */)
else
{
int cu = CHAR_TO_BYTE_SAFE (cm);
- return make_number (cu);
+ return make_fixnum (cu);
}
}
@@ -294,7 +294,7 @@ char_width (int c, struct Lisp_Char_Table *dp)
if (GLYPH_CODE_P (ch))
c = GLYPH_CODE_CHAR (ch);
else if (CHARACTERP (ch))
- c = XFASTINT (ch);
+ c = XFIXNUM (ch);
if (c >= 0)
{
int w = CHARACTER_WIDTH (c);
@@ -318,9 +318,9 @@ usage: (char-width CHAR) */)
ptrdiff_t width;
CHECK_CHARACTER (ch);
- c = XINT (ch);
+ c = XFIXNUM (ch);
width = char_width (c, buffer_display_table ());
- return make_number (width);
+ return make_fixnum (width);
}
/* Return width of string STR of length LEN when displayed in the
@@ -861,7 +861,7 @@ usage: (string &rest CHARACTERS) */)
for (i = 0; i < n; i++)
{
CHECK_CHARACTER (args[i]);
- c = XINT (args[i]);
+ c = XFIXNUM (args[i]);
p += CHAR_STRING (c, p);
}
@@ -884,7 +884,7 @@ usage: (unibyte-string &rest BYTES) */)
for (i = 0; i < n; i++)
{
CHECK_RANGED_INTEGER (args[i], 0, 255);
- *p++ = XINT (args[i]);
+ *p++ = XFIXNUM (args[i]);
}
str = make_string_from_bytes ((char *) buf, n, p - buf);
@@ -902,9 +902,9 @@ usage: (char-resolve-modifiers CHAR) */)
{
EMACS_INT c;
- CHECK_NUMBER (character);
- c = XINT (character);
- return make_number (char_resolve_modifier_mask (c));
+ CHECK_FIXNUM (character);
+ c = XFIXNUM (character);
+ return make_fixnum (char_resolve_modifier_mask (c));
}
DEFUN ("get-byte", Fget_byte, Sget_byte, 0, 2, 0,
@@ -931,14 +931,14 @@ character is not ASCII nor 8-bit character, an error is signaled. */)
}
else
{
- CHECK_NUMBER_COERCE_MARKER (position);
- if (XINT (position) < BEGV || XINT (position) >= ZV)
- args_out_of_range_3 (position, make_number (BEGV), make_number (ZV));
- pos = XFASTINT (position);
+ CHECK_FIXNUM_COERCE_MARKER (position);
+ if (XFIXNUM (position) < BEGV || XFIXNUM (position) >= ZV)
+ args_out_of_range_3 (position, make_fixnum (BEGV), make_fixnum (ZV));
+ pos = XFIXNAT (position);
p = CHAR_POS_ADDR (pos);
}
if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
- return make_number (*p);
+ return make_fixnum (*p);
}
else
{
@@ -949,21 +949,21 @@ character is not ASCII nor 8-bit character, an error is signaled. */)
}
else
{
- CHECK_NATNUM (position);
- if (XINT (position) >= SCHARS (string))
+ CHECK_FIXNAT (position);
+ if (XFIXNUM (position) >= SCHARS (string))
args_out_of_range (string, position);
- pos = XFASTINT (position);
+ pos = XFIXNAT (position);
p = SDATA (string) + string_char_to_byte (string, pos);
}
if (! STRING_MULTIBYTE (string))
- return make_number (*p);
+ return make_fixnum (*p);
}
c = STRING_CHAR (p);
if (CHAR_BYTE8_P (c))
c = CHAR_TO_BYTE8 (c);
else if (! ASCII_CHAR_P (c))
error ("Not an ASCII nor an 8-bit character: %d", c);
- return make_number (c);
+ return make_fixnum (c);
}
/* Return true if C is an alphabetic character. */
@@ -971,9 +971,9 @@ bool
alphabeticp (int c)
{
Lisp_Object category = CHAR_TABLE_REF (Vunicode_category_table, c);
- if (! INTEGERP (category))
+ if (! FIXNUMP (category))
return false;
- EMACS_INT gen_cat = XINT (category);
+ EMACS_INT gen_cat = XFIXNUM (category);
/* See UTS #18. There are additional characters that should be
here, those designated as Other_uppercase, Other_lowercase,
@@ -994,9 +994,9 @@ bool
alphanumericp (int c)
{
Lisp_Object category = CHAR_TABLE_REF (Vunicode_category_table, c);
- if (! INTEGERP (category))
+ if (! FIXNUMP (category))
return false;
- EMACS_INT gen_cat = XINT (category);
+ EMACS_INT gen_cat = XFIXNUM (category);
/* See UTS #18. Same comment as for alphabeticp applies. FIXME. */
return (gen_cat == UNICODE_CATEGORY_Lu
@@ -1016,9 +1016,9 @@ bool
graphicp (int c)
{
Lisp_Object category = CHAR_TABLE_REF (Vunicode_category_table, c);
- if (! INTEGERP (category))
+ if (! FIXNUMP (category))
return false;
- EMACS_INT gen_cat = XINT (category);
+ EMACS_INT gen_cat = XFIXNUM (category);
/* See UTS #18. */
return (!(gen_cat == UNICODE_CATEGORY_Zs /* space separator */
@@ -1034,9 +1034,9 @@ bool
printablep (int c)
{
Lisp_Object category = CHAR_TABLE_REF (Vunicode_category_table, c);
- if (! INTEGERP (category))
+ if (! FIXNUMP (category))
return false;
- EMACS_INT gen_cat = XINT (category);
+ EMACS_INT gen_cat = XFIXNUM (category);
/* See UTS #18. */
return (!(gen_cat == UNICODE_CATEGORY_Cc /* control */
@@ -1050,10 +1050,36 @@ bool
blankp (int c)
{
Lisp_Object category = CHAR_TABLE_REF (Vunicode_category_table, c);
- if (! INTEGERP (category))
+ if (! FIXNUMP (category))
return false;
- return XINT (category) == UNICODE_CATEGORY_Zs; /* separator, space */
+ return XFIXNUM (category) == UNICODE_CATEGORY_Zs; /* separator, space */
+}
+
+
+/* Return true for characters that would read as symbol characters,
+ but graphically may be confused with some kind of punctuation. We
+ require an escaping backslash, when such characters begin a
+ symbol. */
+bool
+confusable_symbol_character_p (int ch)
+{
+ switch (ch)
+ {
+ case 0x2018: /* LEFT SINGLE QUOTATION MARK */
+ case 0x2019: /* RIGHT SINGLE QUOTATION MARK */
+ case 0x201B: /* SINGLE HIGH-REVERSED-9 QUOTATION MARK */
+ case 0x201C: /* LEFT DOUBLE QUOTATION MARK */
+ case 0x201D: /* RIGHT DOUBLE QUOTATION MARK */
+ case 0x201F: /* DOUBLE HIGH-REVERSED-9 QUOTATION MARK */
+ case 0x301E: /* DOUBLE PRIME QUOTATION MARK */
+ case 0xFF02: /* FULLWIDTH QUOTATION MARK */
+ case 0xFF07: /* FULLWIDTH APOSTROPHE */
+ return true;
+
+ default:
+ return false;
+ }
}
signed char HEXDIGIT_CONST hexdigit[UCHAR_MAX + 1] =
@@ -1098,7 +1124,7 @@ syms_of_character (void)
Vector recording all translation tables ever defined.
Each element is a pair (SYMBOL . TABLE) relating the table to the
symbol naming it. The ID of a translation table is an index into this vector. */);
- Vtranslation_table_vector = Fmake_vector (make_number (16), Qnil);
+ Vtranslation_table_vector = make_nil_vector (16);
DEFVAR_LISP ("auto-fill-chars", Vauto_fill_chars,
doc: /*
@@ -1111,26 +1137,26 @@ Such characters have value t in this table. */);
DEFVAR_LISP ("char-width-table", Vchar_width_table,
doc: /*
A char-table for width (columns) of each character. */);
- Vchar_width_table = Fmake_char_table (Qnil, make_number (1));
- char_table_set_range (Vchar_width_table, 0x80, 0x9F, make_number (4));
+ Vchar_width_table = Fmake_char_table (Qnil, make_fixnum (1));
+ char_table_set_range (Vchar_width_table, 0x80, 0x9F, make_fixnum (4));
char_table_set_range (Vchar_width_table, MAX_5_BYTE_CHAR + 1, MAX_CHAR,
- make_number (4));
+ make_fixnum (4));
DEFVAR_LISP ("printable-chars", Vprintable_chars,
doc: /* A char-table for each printable character. */);
Vprintable_chars = Fmake_char_table (Qnil, Qnil);
Fset_char_table_range (Vprintable_chars,
- Fcons (make_number (32), make_number (126)), Qt);
+ Fcons (make_fixnum (32), make_fixnum (126)), Qt);
Fset_char_table_range (Vprintable_chars,
- Fcons (make_number (160),
- make_number (MAX_5_BYTE_CHAR)), Qt);
+ Fcons (make_fixnum (160),
+ make_fixnum (MAX_5_BYTE_CHAR)), Qt);
DEFVAR_LISP ("char-script-table", Vchar_script_table,
doc: /* Char table of script symbols.
It has one extra slot whose value is a list of script symbols. */);
DEFSYM (Qchar_script_table, "char-script-table");
- Fput (Qchar_script_table, Qchar_table_extra_slots, make_number (1));
+ Fput (Qchar_script_table, Qchar_table_extra_slots, make_fixnum (1));
Vchar_script_table = Fmake_char_table (Qchar_script_table, Qnil);
DEFVAR_LISP ("script-representative-chars", Vscript_representative_chars,
diff --git a/src/character.h b/src/character.h
index bc65759aa2a..5dff85aed47 100644
--- a/src/character.h
+++ b/src/character.h
@@ -123,7 +123,7 @@ enum
#define MAX_MULTIBYTE_LENGTH 5
/* Nonzero iff X is a character. */
-#define CHARACTERP(x) (NATNUMP (x) && XFASTINT (x) <= MAX_CHAR)
+#define CHARACTERP(x) (FIXNATP (x) && XFIXNAT (x) <= MAX_CHAR)
/* Nonzero iff C is valid as a character code. */
#define CHAR_VALID_P(c) UNSIGNED_CMP (c, <=, MAX_CHAR)
@@ -559,7 +559,7 @@ enum
/* Return a non-outlandish value for the tab width. */
#define SANE_TAB_WIDTH(buf) \
- sanitize_tab_width (XFASTINT (BVAR (buf, tab_width)))
+ sanitize_tab_width (XFIXNAT (BVAR (buf, tab_width)))
INLINE int
sanitize_tab_width (EMACS_INT width)
{
@@ -595,7 +595,7 @@ sanitize_char_width (EMACS_INT width)
#define CHARACTER_WIDTH(c) \
(ASCII_CHAR_P (c) \
? ASCII_CHAR_WIDTH (c) \
- : sanitize_char_width (XINT (CHAR_TABLE_REF (Vchar_width_table, c))))
+ : sanitize_char_width (XFIXNUM (CHAR_TABLE_REF (Vchar_width_table, c))))
/* If C is a variation selector, return the index of the
variation selector (1..256). Otherwise, return 0. */
@@ -683,6 +683,8 @@ extern bool graphicp (int);
extern bool printablep (int);
extern bool blankp (int);
+extern bool confusable_symbol_character_p (int ch);
+
/* Return a translation table of id number ID. */
#define GET_TRANSLATION_TABLE(id) \
(XCDR (XVECTOR (Vtranslation_table_vector)->contents[(id)]))
@@ -698,7 +700,7 @@ char_table_translate (Lisp_Object obj, int ch)
eassert (CHAR_VALID_P (ch));
eassert (CHAR_TABLE_P (obj));
obj = CHAR_TABLE_REF (obj, ch);
- return CHARACTERP (obj) ? XINT (obj) : ch;
+ return CHARACTERP (obj) ? XFIXNUM (obj) : ch;
}
#if defined __GNUC__ && !defined __STRICT_ANSI__
diff --git a/src/charset.c b/src/charset.c
index 463eb193abe..c0700f972ee 100644
--- a/src/charset.c
+++ b/src/charset.c
@@ -39,6 +39,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "coding.h"
#include "buffer.h"
#include "sysstdio.h"
+#include "pdumper.h"
/*** GENERAL NOTES on CODED CHARACTER SETS (CHARSETS) ***
@@ -61,8 +62,7 @@ Lisp_Object Vcharset_hash_table;
/* Table of struct charset. */
struct charset *charset_table;
-
-static ptrdiff_t charset_table_size;
+int charset_table_size;
static int charset_table_used;
/* Special charsets corresponding to symbols. */
@@ -261,7 +261,7 @@ load_charset_map (struct charset *charset, struct charset_map_entries *entries,
{
int n = CODE_POINT_TO_INDEX (charset, max_code) + 1;
- vec = Fmake_vector (make_number (n), make_number (-1));
+ vec = make_vector (n, make_fixnum (-1));
set_charset_attr (charset, charset_decoder, vec);
}
else
@@ -340,12 +340,12 @@ load_charset_map (struct charset *charset, struct charset_map_entries *entries,
{
if (charset->method == CHARSET_METHOD_MAP)
for (; from_index < lim_index; from_index++, from_c++)
- ASET (vec, from_index, make_number (from_c));
+ ASET (vec, from_index, make_fixnum (from_c));
else
for (; from_index < lim_index; from_index++, from_c++)
CHAR_TABLE_SET (Vchar_unify_table,
CHARSET_CODE_OFFSET (charset) + from_index,
- make_number (from_c));
+ make_fixnum (from_c));
}
else if (control_flag == 2)
{
@@ -357,13 +357,13 @@ load_charset_map (struct charset *charset, struct charset_map_entries *entries,
code = INDEX_TO_CODE_POINT (charset, code);
if (NILP (CHAR_TABLE_REF (table, from_c)))
- CHAR_TABLE_SET (table, from_c, make_number (code));
+ CHAR_TABLE_SET (table, from_c, make_fixnum (code));
}
else
for (; from_index < lim_index; from_index++, from_c++)
{
if (NILP (CHAR_TABLE_REF (table, from_c)))
- CHAR_TABLE_SET (table, from_c, make_number (from_index));
+ CHAR_TABLE_SET (table, from_c, make_fixnum (from_index));
}
}
else if (control_flag == 3)
@@ -587,14 +587,14 @@ load_charset_map_from_vector (struct charset *charset, Lisp_Object vec, int cont
{
val2 = XCDR (val);
val = XCAR (val);
- from = XFASTINT (val);
- to = XFASTINT (val2);
+ from = XFIXNAT (val);
+ to = XFIXNAT (val2);
}
else
- from = to = XFASTINT (val);
+ from = to = XFIXNAT (val);
val = AREF (vec, i + 1);
- CHECK_NATNUM (val);
- c = XFASTINT (val);
+ CHECK_FIXNAT (val);
+ c = XFIXNAT (val);
if (from < min_code || to > max_code || from > to || c > MAX_CHAR)
continue;
@@ -675,11 +675,11 @@ map_charset_for_dump (void (*c_function) (Lisp_Object, Lisp_Object),
if (idx >= from_idx && idx <= to_idx)
{
if (NILP (XCAR (range)))
- XSETCAR (range, make_number (c));
+ XSETCAR (range, make_fixnum (c));
}
else if (! NILP (XCAR (range)))
{
- XSETCDR (range, make_number (c - 1));
+ XSETCDR (range, make_fixnum (c - 1));
if (c_function)
(*c_function) (arg, range);
else
@@ -692,7 +692,7 @@ map_charset_for_dump (void (*c_function) (Lisp_Object, Lisp_Object),
{
if (! NILP (XCAR (range)))
{
- XSETCDR (range, make_number (c));
+ XSETCDR (range, make_fixnum (c));
if (c_function)
(*c_function) (arg, range);
else
@@ -734,7 +734,7 @@ map_charset_chars (void (*c_function)(Lisp_Object, Lisp_Object), Lisp_Object fun
map_charset_for_dump (c_function, function, arg, from, to);
}
- range = Fcons (make_number (from_c), make_number (to_c));
+ range = Fcons (make_fixnum (from_c), make_fixnum (to_c));
if (NILP (function))
(*c_function) (arg, range);
else
@@ -757,14 +757,14 @@ map_charset_chars (void (*c_function)(Lisp_Object, Lisp_Object), Lisp_Object fun
int offset;
subset_info = CHARSET_SUBSET (charset);
- charset = CHARSET_FROM_ID (XFASTINT (AREF (subset_info, 0)));
- offset = XINT (AREF (subset_info, 3));
+ charset = CHARSET_FROM_ID (XFIXNAT (AREF (subset_info, 0)));
+ offset = XFIXNUM (AREF (subset_info, 3));
from -= offset;
- if (from < XFASTINT (AREF (subset_info, 1)))
- from = XFASTINT (AREF (subset_info, 1));
+ if (from < XFIXNAT (AREF (subset_info, 1)))
+ from = XFIXNAT (AREF (subset_info, 1));
to -= offset;
- if (to > XFASTINT (AREF (subset_info, 2)))
- to = XFASTINT (AREF (subset_info, 2));
+ if (to > XFIXNAT (AREF (subset_info, 2)))
+ to = XFIXNAT (AREF (subset_info, 2));
map_charset_chars (c_function, function, arg, charset, from, to);
}
else /* i.e. CHARSET_METHOD_SUPERSET */
@@ -777,8 +777,8 @@ map_charset_chars (void (*c_function)(Lisp_Object, Lisp_Object), Lisp_Object fun
int offset;
unsigned this_from, this_to;
- charset = CHARSET_FROM_ID (XFASTINT (XCAR (XCAR (parents))));
- offset = XINT (XCDR (XCAR (parents)));
+ charset = CHARSET_FROM_ID (XFIXNAT (XCAR (XCAR (parents))));
+ offset = XFIXNUM (XCDR (XCAR (parents)));
this_from = from > offset ? from - offset : 0;
this_to = to > offset ? to - offset : 0;
if (this_from < CHARSET_MIN_CODE (charset))
@@ -811,7 +811,7 @@ range of code points (in CHARSET) of target characters. */)
from = CHARSET_MIN_CODE (cs);
else
{
- from = XINT (from_code);
+ from = XFIXNUM (from_code);
if (from < CHARSET_MIN_CODE (cs))
from = CHARSET_MIN_CODE (cs);
}
@@ -819,7 +819,7 @@ range of code points (in CHARSET) of target characters. */)
to = CHARSET_MAX_CODE (cs);
else
{
- to = XINT (to_code);
+ to = XFIXNUM (to_code);
if (to > CHARSET_MAX_CODE (cs))
to = CHARSET_MAX_CODE (cs);
}
@@ -851,12 +851,14 @@ usage: (define-charset-internal ...) */)
bool new_definition_p;
int nchars;
+ memset (&charset, 0, sizeof (charset));
+
if (nargs != charset_arg_max)
Fsignal (Qwrong_number_of_arguments,
Fcons (intern ("define-charset-internal"),
- make_number (nargs)));
+ make_fixnum (nargs)));
- attrs = Fmake_vector (make_number (charset_attr_max), Qnil);
+ attrs = make_nil_vector (charset_attr_max);
CHECK_SYMBOL (args[charset_arg_name]);
ASET (attrs, charset_name, args[charset_arg_name]);
@@ -867,12 +869,12 @@ usage: (define-charset-internal ...) */)
Lisp_Object min_byte_obj, max_byte_obj;
int min_byte, max_byte;
- min_byte_obj = Faref (val, make_number (i * 2));
- max_byte_obj = Faref (val, make_number (i * 2 + 1));
+ min_byte_obj = Faref (val, make_fixnum (i * 2));
+ max_byte_obj = Faref (val, make_fixnum (i * 2 + 1));
CHECK_RANGED_INTEGER (min_byte_obj, 0, 255);
- min_byte = XINT (min_byte_obj);
+ min_byte = XFIXNUM (min_byte_obj);
CHECK_RANGED_INTEGER (max_byte_obj, min_byte, 255);
- max_byte = XINT (max_byte_obj);
+ max_byte = XFIXNUM (max_byte_obj);
charset.code_space[i * 4] = min_byte;
charset.code_space[i * 4 + 1] = max_byte;
charset.code_space[i * 4 + 2] = max_byte - min_byte + 1;
@@ -890,7 +892,7 @@ usage: (define-charset-internal ...) */)
else
{
CHECK_RANGED_INTEGER (val, 1, 4);
- charset.dimension = XINT (val);
+ charset.dimension = XFIXNUM (val);
}
charset.code_linear_p
@@ -929,8 +931,8 @@ usage: (define-charset-internal ...) */)
if (code < charset.min_code
|| code > charset.max_code)
- args_out_of_range_3 (make_fixnum_or_float (charset.min_code),
- make_fixnum_or_float (charset.max_code), val);
+ args_out_of_range_3 (INT_TO_INTEGER (charset.min_code),
+ INT_TO_INTEGER (charset.max_code), val);
charset.char_index_offset = CODE_POINT_TO_INDEX (&charset, code);
charset.min_code = code;
}
@@ -942,8 +944,8 @@ usage: (define-charset-internal ...) */)
if (code < charset.min_code
|| code > charset.max_code)
- args_out_of_range_3 (make_fixnum_or_float (charset.min_code),
- make_fixnum_or_float (charset.max_code), val);
+ args_out_of_range_3 (INT_TO_INTEGER (charset.min_code),
+ INT_TO_INTEGER (charset.max_code), val);
charset.max_code = code;
}
@@ -970,10 +972,10 @@ usage: (define-charset-internal ...) */)
charset.iso_final = -1;
else
{
- CHECK_NUMBER (val);
- if (XINT (val) < '0' || XINT (val) > 127)
- error ("Invalid iso-final-char: %"pI"d", XINT (val));
- charset.iso_final = XINT (val);
+ CHECK_FIXNUM (val);
+ if (XFIXNUM (val) < '0' || XFIXNUM (val) > 127)
+ error ("Invalid iso-final-char: %"pI"d", XFIXNUM (val));
+ charset.iso_final = XFIXNUM (val);
}
val = args[charset_arg_iso_revision];
@@ -982,7 +984,7 @@ usage: (define-charset-internal ...) */)
else
{
CHECK_RANGED_INTEGER (val, -1, 63);
- charset.iso_revision = XINT (val);
+ charset.iso_revision = XFIXNUM (val);
}
val = args[charset_arg_emacs_mule_id];
@@ -990,10 +992,10 @@ usage: (define-charset-internal ...) */)
charset.emacs_mule_id = -1;
else
{
- CHECK_NATNUM (val);
- if ((XINT (val) > 0 && XINT (val) <= 128) || XINT (val) >= 256)
- error ("Invalid emacs-mule-id: %"pI"d", XINT (val));
- charset.emacs_mule_id = XINT (val);
+ CHECK_FIXNAT (val);
+ if ((XFIXNUM (val) > 0 && XFIXNUM (val) <= 128) || XFIXNUM (val) >= 256)
+ error ("Invalid emacs-mule-id: %"pI"d", XFIXNUM (val));
+ charset.emacs_mule_id = XFIXNUM (val);
}
charset.ascii_compatible_p = ! NILP (args[charset_arg_ascii_compatible_p]);
@@ -1010,7 +1012,7 @@ usage: (define-charset-internal ...) */)
CHECK_CHARACTER (val);
charset.method = CHARSET_METHOD_OFFSET;
- charset.code_offset = XINT (val);
+ charset.code_offset = XFIXNUM (val);
i = CODE_POINT_TO_INDEX (&charset, charset.max_code);
if (MAX_CHAR - charset.code_offset < i)
@@ -1043,14 +1045,14 @@ usage: (define-charset-internal ...) */)
val = args[charset_arg_subset];
parent = Fcar (val);
CHECK_CHARSET_GET_CHARSET (parent, parent_charset);
- parent_min_code = Fnth (make_number (1), val);
- CHECK_NATNUM (parent_min_code);
- parent_max_code = Fnth (make_number (2), val);
- CHECK_NATNUM (parent_max_code);
- parent_code_offset = Fnth (make_number (3), val);
- CHECK_NUMBER (parent_code_offset);
+ parent_min_code = Fnth (make_fixnum (1), val);
+ CHECK_FIXNAT (parent_min_code);
+ parent_max_code = Fnth (make_fixnum (2), val);
+ CHECK_FIXNAT (parent_max_code);
+ parent_code_offset = Fnth (make_fixnum (3), val);
+ CHECK_FIXNUM (parent_code_offset);
val = make_uninit_vector (4);
- ASET (val, 0, make_number (parent_charset->id));
+ ASET (val, 0, make_fixnum (parent_charset->id));
ASET (val, 1, parent_min_code);
ASET (val, 2, parent_max_code);
ASET (val, 3, parent_code_offset);
@@ -1089,14 +1091,14 @@ usage: (define-charset-internal ...) */)
cdr_part = XCDR (elt);
CHECK_CHARSET_GET_ID (car_part, this_id);
CHECK_TYPE_RANGED_INTEGER (int, cdr_part);
- offset = XINT (cdr_part);
+ offset = XFIXNUM (cdr_part);
}
else
{
CHECK_CHARSET_GET_ID (elt, this_id);
offset = 0;
}
- XSETCAR (val, Fcons (make_number (this_id), make_number (offset)));
+ XSETCAR (val, Fcons (make_fixnum (this_id), make_fixnum (offset)));
this_charset = CHARSET_FROM_ID (this_id);
if (charset.min_char > this_charset->min_char)
@@ -1123,7 +1125,7 @@ usage: (define-charset-internal ...) */)
if (charset.hash_index >= 0)
{
new_definition_p = 0;
- id = XFASTINT (CHARSET_SYMBOL_ID (args[charset_arg_name]));
+ id = XFIXNAT (CHARSET_SYMBOL_ID (args[charset_arg_name]));
set_hash_value_slot (hash_table, charset.hash_index, attrs);
}
else
@@ -1142,9 +1144,9 @@ usage: (define-charset-internal ...) */)
struct charset *new_table =
xpalloc (0, &new_size, 1,
min (INT_MAX, MOST_POSITIVE_FIXNUM),
- sizeof *charset_table);
- memcpy (new_table, charset_table, old_size * sizeof *new_table);
- charset_table = new_table;
+ sizeof *charset_table);
+ memcpy (new_table, charset_table, old_size * sizeof *new_table);
+ charset_table = new_table;
charset_table_size = new_size;
/* FIXME: This leaks memory, as the old charset_table becomes
unreachable. If the old charset table is charset_table_init
@@ -1158,7 +1160,7 @@ usage: (define-charset-internal ...) */)
new_definition_p = 1;
}
- ASET (attrs, charset_id, make_number (id));
+ ASET (attrs, charset_id, make_fixnum (id));
charset.id = id;
charset_table[id] = charset;
@@ -1173,8 +1175,7 @@ usage: (define-charset-internal ...) */)
ISO_CHARSET_TABLE (charset.dimension, charset.iso_chars_96,
charset.iso_final) = id;
if (new_definition_p)
- Viso_2022_charset_list = nconc2 (Viso_2022_charset_list,
- list1 (make_number (id)));
+ Viso_2022_charset_list = nconc2 (Viso_2022_charset_list, list1i (id));
if (ISO_CHARSET_TABLE (1, 0, 'J') == id)
charset_jisx0201_roman = id;
else if (ISO_CHARSET_TABLE (2, 0, '@') == id)
@@ -1194,37 +1195,36 @@ usage: (define-charset-internal ...) */)
emacs_mule_bytes[charset.emacs_mule_id] = charset.dimension + 2;
if (new_definition_p)
Vemacs_mule_charset_list = nconc2 (Vemacs_mule_charset_list,
- list1 (make_number (id)));
+ list1i (id));
}
if (new_definition_p)
{
Vcharset_list = Fcons (args[charset_arg_name], Vcharset_list);
if (charset.supplementary_p)
- Vcharset_ordered_list = nconc2 (Vcharset_ordered_list,
- list1 (make_number (id)));
+ Vcharset_ordered_list = nconc2 (Vcharset_ordered_list, list1i (id));
else
{
Lisp_Object tail;
for (tail = Vcharset_ordered_list; CONSP (tail); tail = XCDR (tail))
{
- struct charset *cs = CHARSET_FROM_ID (XINT (XCAR (tail)));
+ struct charset *cs = CHARSET_FROM_ID (XFIXNUM (XCAR (tail)));
if (cs->supplementary_p)
break;
}
if (EQ (tail, Vcharset_ordered_list))
- Vcharset_ordered_list = Fcons (make_number (id),
+ Vcharset_ordered_list = Fcons (make_fixnum (id),
Vcharset_ordered_list);
else if (NILP (tail))
Vcharset_ordered_list = nconc2 (Vcharset_ordered_list,
- list1 (make_number (id)));
+ list1i (id));
else
{
val = Fcons (XCAR (tail), XCDR (tail));
XSETCDR (tail, val);
- XSETCAR (tail, make_number (id));
+ XSETCAR (tail, make_fixnum (id));
}
}
charset_ordered_list_tick++;
@@ -1254,30 +1254,29 @@ define_charset_internal (Lisp_Object name,
int i;
args[charset_arg_name] = name;
- args[charset_arg_dimension] = make_number (dimension);
+ args[charset_arg_dimension] = make_fixnum (dimension);
val = make_uninit_vector (8);
for (i = 0; i < 8; i++)
- ASET (val, i, make_number (code_space[i]));
+ ASET (val, i, make_fixnum (code_space[i]));
args[charset_arg_code_space] = val;
- args[charset_arg_min_code] = make_number (min_code);
- args[charset_arg_max_code] = make_number (max_code);
+ args[charset_arg_min_code] = make_fixnum (min_code);
+ args[charset_arg_max_code] = make_fixnum (max_code);
args[charset_arg_iso_final]
- = (iso_final < 0 ? Qnil : make_number (iso_final));
- args[charset_arg_iso_revision] = make_number (iso_revision);
+ = (iso_final < 0 ? Qnil : make_fixnum (iso_final));
+ args[charset_arg_iso_revision] = make_fixnum (iso_revision);
args[charset_arg_emacs_mule_id]
- = (emacs_mule_id < 0 ? Qnil : make_number (emacs_mule_id));
+ = (emacs_mule_id < 0 ? Qnil : make_fixnum (emacs_mule_id));
args[charset_arg_ascii_compatible_p] = ascii_compatible ? Qt : Qnil;
args[charset_arg_supplementary_p] = supplementary ? Qt : Qnil;
args[charset_arg_invalid_code] = Qnil;
- args[charset_arg_code_offset] = make_number (code_offset);
+ args[charset_arg_code_offset] = make_fixnum (code_offset);
args[charset_arg_map] = Qnil;
args[charset_arg_subset] = Qnil;
args[charset_arg_superset] = Qnil;
args[charset_arg_unify_map] = Qnil;
args[charset_arg_plist] =
- listn (CONSTYPE_HEAP, 14,
- QCname,
+ list (QCname,
args[charset_arg_name],
intern_c_string (":dimension"),
args[charset_arg_dimension],
@@ -1293,7 +1292,7 @@ define_charset_internal (Lisp_Object name,
args[charset_arg_code_offset]);
Fdefine_charset_internal (charset_arg_max, args);
- return XINT (CHARSET_SYMBOL_ID (name));
+ return XFIXNUM (CHARSET_SYMBOL_ID (name));
}
@@ -1396,19 +1395,19 @@ static bool
check_iso_charset_parameter (Lisp_Object dimension, Lisp_Object chars,
Lisp_Object final_char)
{
- CHECK_NUMBER (dimension);
- CHECK_NUMBER (chars);
+ CHECK_FIXNUM (dimension);
+ CHECK_FIXNUM (chars);
CHECK_CHARACTER (final_char);
- if (! (1 <= XINT (dimension) && XINT (dimension) <= 3))
+ if (! (1 <= XFIXNUM (dimension) && XFIXNUM (dimension) <= 3))
error ("Invalid DIMENSION %"pI"d, it should be 1, 2, or 3",
- XINT (dimension));
+ XFIXNUM (dimension));
- bool chars_flag = XINT (chars) == 96;
- if (! (chars_flag || XINT (chars) == 94))
- error ("Invalid CHARS %"pI"d, it should be 94 or 96", XINT (chars));
+ bool chars_flag = XFIXNUM (chars) == 96;
+ if (! (chars_flag || XFIXNUM (chars) == 94))
+ error ("Invalid CHARS %"pI"d, it should be 94 or 96", XFIXNUM (chars));
- int final_ch = XFASTINT (final_char);
+ int final_ch = XFIXNAT (final_char);
if (! ('0' <= final_ch && final_ch <= '~'))
error ("Invalid FINAL-CHAR `%c', it should be `0'..`~'", final_ch);
@@ -1428,10 +1427,10 @@ return nil. */)
(Lisp_Object dimension, Lisp_Object chars)
{
bool chars_flag = check_iso_charset_parameter (dimension, chars,
- make_number ('0'));
+ make_fixnum ('0'));
for (int final_char = '0'; final_char <= '?'; final_char++)
- if (ISO_CHARSET_TABLE (XINT (dimension), chars_flag, final_char) < 0)
- return make_number (final_char);
+ if (ISO_CHARSET_TABLE (XFIXNUM (dimension), chars_flag, final_char) < 0)
+ return make_fixnum (final_char);
return Qnil;
}
@@ -1449,7 +1448,7 @@ if CHARSET is designated instead. */)
CHECK_CHARSET_GET_ID (charset, id);
bool chars_flag = check_iso_charset_parameter (dimension, chars, final_char);
- ISO_CHARSET_TABLE (XINT (dimension), chars_flag, XFASTINT (final_char)) = id;
+ ISO_CHARSET_TABLE (XFIXNUM (dimension), chars_flag, XFIXNAT (final_char)) = id;
return Qnil;
}
@@ -1550,8 +1549,8 @@ only `ascii', `eight-bit-control', and `eight-bit-graphic'. */)
bool multibyte = ! NILP (BVAR (current_buffer, enable_multibyte_characters));
validate_region (&beg, &end);
- from = XFASTINT (beg);
- stop = to = XFASTINT (end);
+ from = XFIXNAT (beg);
+ stop = to = XFIXNAT (end);
if (from < GPT && GPT < to)
{
@@ -1563,7 +1562,7 @@ only `ascii', `eight-bit-control', and `eight-bit-graphic'. */)
from_byte = CHAR_TO_BYTE (from);
- charsets = Fmake_vector (make_number (charset_table_used), Qnil);
+ charsets = make_nil_vector (charset_table_used);
while (1)
{
find_charsets_in_text (BYTE_POS_ADDR (from_byte), stop - from,
@@ -1594,18 +1593,14 @@ If STR is unibyte, the returned list may contain
only `ascii', `eight-bit-control', and `eight-bit-graphic'. */)
(Lisp_Object str, Lisp_Object table)
{
- Lisp_Object charsets;
- int i;
- Lisp_Object val;
-
CHECK_STRING (str);
- charsets = Fmake_vector (make_number (charset_table_used), Qnil);
+ Lisp_Object charsets = make_nil_vector (charset_table_used);
find_charsets_in_text (SDATA (str), SCHARS (str), SBYTES (str),
charsets, table,
STRING_MULTIBYTE (str));
- val = Qnil;
- for (i = charset_table_used - 1; i >= 0; i--)
+ Lisp_Object val = Qnil;
+ for (int i = charset_table_used - 1; i >= 0; i--)
if (!NILP (AREF (charsets, i)))
val = Fcons (CHARSET_NAME (charset_table + i), val);
return val;
@@ -1621,8 +1616,8 @@ maybe_unify_char (int c, Lisp_Object val)
{
struct charset *charset;
- if (INTEGERP (val))
- return XFASTINT (val);
+ if (FIXNUMP (val))
+ return XFIXNAT (val);
if (NILP (val))
return c;
@@ -1638,7 +1633,7 @@ maybe_unify_char (int c, Lisp_Object val)
{
val = CHAR_TABLE_REF (Vchar_unify_table, c);
if (! NILP (val))
- c = XFASTINT (val);
+ c = XFIXNAT (val);
}
else
{
@@ -1672,10 +1667,10 @@ decode_char (struct charset *charset, unsigned int code)
Lisp_Object subset_info;
subset_info = CHARSET_SUBSET (charset);
- charset = CHARSET_FROM_ID (XFASTINT (AREF (subset_info, 0)));
- code -= XINT (AREF (subset_info, 3));
- if (code < XFASTINT (AREF (subset_info, 1))
- || code > XFASTINT (AREF (subset_info, 2)))
+ charset = CHARSET_FROM_ID (XFIXNAT (AREF (subset_info, 0)));
+ code -= XFIXNUM (AREF (subset_info, 3));
+ if (code < XFIXNAT (AREF (subset_info, 1))
+ || code > XFIXNAT (AREF (subset_info, 2)))
c = -1;
else
c = DECODE_CHAR (charset, code);
@@ -1688,8 +1683,8 @@ decode_char (struct charset *charset, unsigned int code)
c = -1;
for (; CONSP (parents); parents = XCDR (parents))
{
- int id = XINT (XCAR (XCAR (parents)));
- int code_offset = XINT (XCDR (XCAR (parents)));
+ int id = XFIXNUM (XCAR (XCAR (parents)));
+ int code_offset = XFIXNUM (XCDR (XCAR (parents)));
unsigned this_code = code - code_offset;
charset = CHARSET_FROM_ID (id);
@@ -1714,7 +1709,7 @@ decode_char (struct charset *charset, unsigned int code)
decoder = CHARSET_DECODER (charset);
}
if (VECTORP (decoder))
- c = XINT (AREF (decoder, char_index));
+ c = XFIXNUM (AREF (decoder, char_index));
else
c = GET_TEMP_CHARSET_WORK_DECODER (char_index);
}
@@ -1762,8 +1757,8 @@ encode_char (struct charset *charset, int c)
{
Lisp_Object deunified = CHAR_TABLE_REF (deunifier, c);
- if (INTEGERP (deunified))
- code_index = XINT (deunified);
+ if (FIXNUMP (deunified))
+ code_index = XFIXNUM (deunified);
}
else
{
@@ -1779,13 +1774,13 @@ encode_char (struct charset *charset, int c)
struct charset *this_charset;
subset_info = CHARSET_SUBSET (charset);
- this_charset = CHARSET_FROM_ID (XFASTINT (AREF (subset_info, 0)));
+ this_charset = CHARSET_FROM_ID (XFIXNAT (AREF (subset_info, 0)));
code = ENCODE_CHAR (this_charset, c);
if (code == CHARSET_INVALID_CODE (this_charset)
- || code < XFASTINT (AREF (subset_info, 1))
- || code > XFASTINT (AREF (subset_info, 2)))
+ || code < XFIXNAT (AREF (subset_info, 1))
+ || code > XFIXNAT (AREF (subset_info, 2)))
return CHARSET_INVALID_CODE (charset);
- code += XINT (AREF (subset_info, 3));
+ code += XFIXNUM (AREF (subset_info, 3));
return code;
}
@@ -1796,8 +1791,8 @@ encode_char (struct charset *charset, int c)
parents = CHARSET_SUPERSET (charset);
for (; CONSP (parents); parents = XCDR (parents))
{
- int id = XINT (XCAR (XCAR (parents)));
- int code_offset = XINT (XCDR (XCAR (parents)));
+ int id = XFIXNUM (XCAR (XCAR (parents)));
+ int code_offset = XFIXNUM (XCDR (XCAR (parents)));
struct charset *this_charset = CHARSET_FROM_ID (id);
code = ENCODE_CHAR (this_charset, c);
@@ -1827,7 +1822,7 @@ encode_char (struct charset *charset, int c)
val = CHAR_TABLE_REF (encoder, c);
if (NILP (val))
return CHARSET_INVALID_CODE (charset);
- code = XINT (val);
+ code = XFIXNUM (val);
if (! CHARSET_COMPACT_CODES_P (charset))
code = INDEX_TO_CODE_POINT (charset, code);
}
@@ -1852,7 +1847,8 @@ DEFUN ("decode-char", Fdecode_char, Sdecode_char, 2, 2, 0,
doc: /* Decode the pair of CHARSET and CODE-POINT into a character.
Return nil if CODE-POINT is not valid in CHARSET.
-CODE-POINT may be a cons (HIGHER-16-BIT-VALUE . LOWER-16-BIT-VALUE). */)
+CODE-POINT may be a cons (HIGHER-16-BIT-VALUE . LOWER-16-BIT-VALUE),
+although this usage is obsolescent. */)
(Lisp_Object charset, Lisp_Object code_point)
{
int c, id;
@@ -1863,13 +1859,15 @@ CODE-POINT may be a cons (HIGHER-16-BIT-VALUE . LOWER-16-BIT-VALUE). */)
code = cons_to_unsigned (code_point, UINT_MAX);
charsetp = CHARSET_FROM_ID (id);
c = DECODE_CHAR (charsetp, code);
- return (c >= 0 ? make_number (c) : Qnil);
+ return (c >= 0 ? make_fixnum (c) : Qnil);
}
DEFUN ("encode-char", Fencode_char, Sencode_char, 2, 2, 0,
doc: /* Encode the character CH into a code-point of CHARSET.
-Return nil if CHARSET doesn't include CH. */)
+Return the encoded code-point, a fixnum if its value is small enough,
+otherwise a bignum.
+Return nil if CHARSET doesn't support CH. */)
(Lisp_Object ch, Lisp_Object charset)
{
int c, id;
@@ -1878,12 +1876,19 @@ Return nil if CHARSET doesn't include CH. */)
CHECK_CHARSET_GET_ID (charset, id);
CHECK_CHARACTER (ch);
- c = XFASTINT (ch);
+ c = XFIXNAT (ch);
charsetp = CHARSET_FROM_ID (id);
code = ENCODE_CHAR (charsetp, c);
if (code == CHARSET_INVALID_CODE (charsetp))
return Qnil;
- return INTEGER_TO_CONS (code);
+ /* There are much fewer codepoints in the world than we have positive
+ fixnums, so it could be argued that we never really need a bignum,
+ e.g. Unicode codepoints only need 21bit, and China's GB-10830
+ can fit in 22bit. Yet we encode GB-10830's chars in a sparse way
+ (we just take the 4byte sequences as a 32bit int), so some
+ GB-10830 chars (such as 0x81308130 in etc/charsets/gb108304.map) end
+ up represented as bignums if EMACS_INT is 32 bits. */
+ return INT_TO_INTEGER (code);
}
@@ -1910,10 +1915,10 @@ is specified. */)
? 0 : CHARSET_MIN_CODE (charsetp));
else
{
- CHECK_NATNUM (code1);
- if (XFASTINT (code1) >= 0x100)
- args_out_of_range (make_number (0xFF), code1);
- code = XFASTINT (code1);
+ CHECK_FIXNAT (code1);
+ if (XFIXNAT (code1) >= 0x100)
+ args_out_of_range (make_fixnum (0xFF), code1);
+ code = XFIXNAT (code1);
if (dimension > 1)
{
@@ -1922,10 +1927,10 @@ is specified. */)
code |= charsetp->code_space[(dimension - 2) * 4];
else
{
- CHECK_NATNUM (code2);
- if (XFASTINT (code2) >= 0x100)
- args_out_of_range (make_number (0xFF), code2);
- code |= XFASTINT (code2);
+ CHECK_FIXNAT (code2);
+ if (XFIXNAT (code2) >= 0x100)
+ args_out_of_range (make_fixnum (0xFF), code2);
+ code |= XFIXNAT (code2);
}
if (dimension > 2)
@@ -1935,10 +1940,10 @@ is specified. */)
code |= charsetp->code_space[(dimension - 3) * 4];
else
{
- CHECK_NATNUM (code3);
- if (XFASTINT (code3) >= 0x100)
- args_out_of_range (make_number (0xFF), code3);
- code |= XFASTINT (code3);
+ CHECK_FIXNAT (code3);
+ if (XFIXNAT (code3) >= 0x100)
+ args_out_of_range (make_fixnum (0xFF), code3);
+ code |= XFIXNAT (code3);
}
if (dimension > 3)
@@ -1948,10 +1953,10 @@ is specified. */)
code |= charsetp->code_space[0];
else
{
- CHECK_NATNUM (code4);
- if (XFASTINT (code4) >= 0x100)
- args_out_of_range (make_number (0xFF), code4);
- code |= XFASTINT (code4);
+ CHECK_FIXNAT (code4);
+ if (XFIXNAT (code4) >= 0x100)
+ args_out_of_range (make_fixnum (0xFF), code4);
+ code |= XFIXNAT (code4);
}
}
}
@@ -1963,7 +1968,7 @@ is specified. */)
c = DECODE_CHAR (charsetp, code);
if (c < 0)
error ("Invalid code(s)");
- return make_number (c);
+ return make_fixnum (c);
}
@@ -1983,7 +1988,7 @@ char_charset (int c, Lisp_Object charset_list, unsigned int *code_return)
while (CONSP (charset_list))
{
- struct charset *charset = CHARSET_FROM_ID (XINT (XCAR (charset_list)));
+ struct charset *charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list)));
unsigned code = ENCODE_CHAR (charset, c);
if (code != CHARSET_INVALID_CODE (charset))
@@ -2018,7 +2023,7 @@ CH in the charset. */)
Lisp_Object val;
CHECK_CHARACTER (ch);
- c = XFASTINT (ch);
+ c = XFIXNAT (ch);
charset = CHAR_CHARSET (c);
if (! charset)
emacs_abort ();
@@ -2028,7 +2033,7 @@ CH in the charset. */)
dimension = CHARSET_DIMENSION (charset);
for (val = Qnil; dimension > 0; dimension--)
{
- val = Fcons (make_number (code & 0xFF), val);
+ val = Fcons (make_fixnum (code & 0xFF), val);
code >>= 8;
}
return Fcons (CHARSET_NAME (charset), val);
@@ -2048,12 +2053,12 @@ that case, find the charset from what supported by that coding system. */)
CHECK_CHARACTER (ch);
if (NILP (restriction))
- charset = CHAR_CHARSET (XINT (ch));
+ charset = CHAR_CHARSET (XFIXNUM (ch));
else
{
if (CONSP (restriction))
{
- int c = XFASTINT (ch);
+ int c = XFIXNAT (ch);
for (; CONSP (restriction); restriction = XCDR (restriction))
{
@@ -2066,7 +2071,7 @@ that case, find the charset from what supported by that coding system. */)
return Qnil;
}
restriction = coding_system_charset_list (restriction);
- charset = char_charset (XINT (ch), restriction, NULL);
+ charset = char_charset (XFIXNUM (ch), restriction, NULL);
if (! charset)
return Qnil;
}
@@ -2085,9 +2090,9 @@ If POS is out of range, the value is nil. */)
struct charset *charset;
ch = Fchar_after (pos);
- if (! INTEGERP (ch))
+ if (! FIXNUMP (ch))
return ch;
- charset = CHAR_CHARSET (XINT (ch));
+ charset = CHAR_CHARSET (XFIXNUM (ch));
return (CHARSET_NAME (charset));
}
@@ -2104,8 +2109,8 @@ DIMENSION, CHARS, and FINAL-CHAR. */)
(Lisp_Object dimension, Lisp_Object chars, Lisp_Object final_char)
{
bool chars_flag = check_iso_charset_parameter (dimension, chars, final_char);
- int id = ISO_CHARSET_TABLE (XINT (dimension), chars_flag,
- XFASTINT (final_char));
+ int id = ISO_CHARSET_TABLE (XFIXNUM (dimension), chars_flag,
+ XFIXNAT (final_char));
return (id >= 0 ? CHARSET_NAME (CHARSET_FROM_ID (id)) : Qnil);
}
@@ -2139,11 +2144,11 @@ HIGHESTP non-nil means just return the highest priority one. */)
Lisp_Object val = Qnil, list = Vcharset_ordered_list;
if (!NILP (highestp))
- return CHARSET_NAME (CHARSET_FROM_ID (XINT (Fcar (list))));
+ return CHARSET_NAME (CHARSET_FROM_ID (XFIXNUM (Fcar (list))));
while (!NILP (list))
{
- val = Fcons (CHARSET_NAME (CHARSET_FROM_ID (XINT (XCAR (list)))), val);
+ val = Fcons (CHARSET_NAME (CHARSET_FROM_ID (XFIXNUM (XCAR (list)))), val);
list = XCDR (list);
}
return Fnreverse (val);
@@ -2165,14 +2170,14 @@ usage: (set-charset-priority &rest charsets) */)
for (i = 0; i < nargs; i++)
{
CHECK_CHARSET_GET_ID (args[i], id);
- if (! NILP (Fmemq (make_number (id), old_list)))
+ if (! NILP (Fmemq (make_fixnum (id), old_list)))
{
- old_list = Fdelq (make_number (id), old_list);
- new_head = Fcons (make_number (id), new_head);
+ old_list = Fdelq (make_fixnum (id), old_list);
+ new_head = Fcons (make_fixnum (id), new_head);
}
}
Vcharset_non_preferred_head = old_list;
- Vcharset_ordered_list = CALLN (Fnconc, Fnreverse (new_head), old_list);
+ Vcharset_ordered_list = nconc2 (Fnreverse (new_head), old_list);
charset_ordered_list_tick++;
@@ -2186,7 +2191,7 @@ usage: (set-charset-priority &rest charsets) */)
list_emacs_mule = Fcons (XCAR (old_list), list_emacs_mule);
if (charset_unibyte < 0)
{
- struct charset *charset = CHARSET_FROM_ID (XINT (XCAR (old_list)));
+ struct charset *charset = CHARSET_FROM_ID (XFIXNUM (XCAR (old_list)));
if (CHARSET_DIMENSION (charset) == 1
&& CHARSET_ASCII_COMPATIBLE_P (charset)
@@ -2211,7 +2216,7 @@ Return charset identification number of CHARSET. */)
int id;
CHECK_CHARSET_GET_ID (charset, id);
- return make_number (id);
+ return make_fixnum (id);
}
struct charset_sort_data
@@ -2236,8 +2241,7 @@ Return the sorted list. CHARSETS is modified by side effects.
See also `charset-priority-list' and `set-charset-priority'. */)
(Lisp_Object charsets)
{
- Lisp_Object len = Flength (charsets);
- ptrdiff_t n = XFASTINT (len), i, j;
+ ptrdiff_t n = list_length (charsets), i, j;
int done;
Lisp_Object tail, elt, attrs;
struct charset_sort_data *sort_data;
@@ -2252,7 +2256,7 @@ See also `charset-priority-list' and `set-charset-priority'. */)
elt = XCAR (tail);
CHECK_CHARSET_GET_ATTR (elt, attrs);
sort_data[i].charset = elt;
- sort_data[i].id = id = XINT (CHARSET_ATTR_ID (attrs));
+ sort_data[i].id = id = XFIXNUM (CHARSET_ATTR_ID (attrs));
if (id < min_id)
min_id = id;
if (id > max_id)
@@ -2262,7 +2266,7 @@ See also `charset-priority-list' and `set-charset-priority'. */)
done < n && CONSP (tail); tail = XCDR (tail), i++)
{
elt = XCAR (tail);
- id = XFASTINT (elt);
+ id = XFIXNAT (elt);
if (id >= min_id && id <= max_id)
for (j = 0; j < n; j++)
if (sort_data[j].id == id)
@@ -2311,19 +2315,28 @@ init_charset_once (void)
for (i = 0; i < ISO_MAX_DIMENSION; i++)
for (j = 0; j < ISO_MAX_CHARS; j++)
for (k = 0; k < ISO_MAX_FINAL; k++)
- iso_charset_table[i][j][k] = -1;
+ iso_charset_table[i][j][k] = -1;
+
+ PDUMPER_REMEMBER_SCALAR (iso_charset_table);
for (i = 0; i < 256; i++)
emacs_mule_charset[i] = -1;
+ PDUMPER_REMEMBER_SCALAR (emacs_mule_charset);
+
charset_jisx0201_roman = -1;
+ PDUMPER_REMEMBER_SCALAR (charset_jisx0201_roman);
+
charset_jisx0208_1978 = -1;
+ PDUMPER_REMEMBER_SCALAR (charset_jisx0208_1978);
+
charset_jisx0208 = -1;
+ PDUMPER_REMEMBER_SCALAR (charset_jisx0208);
+
charset_ksc5601 = -1;
+ PDUMPER_REMEMBER_SCALAR (charset_ksc5601);
}
-#ifdef emacs
-
/* Allocate an initial charset table that is large enough to handle
Emacs while it is bootstrapping. As of September 2011, the size
needs to be at least 166; make it a bit bigger to allow for future
@@ -2362,7 +2375,9 @@ syms_of_charset (void)
charset_table = charset_table_init;
charset_table_size = ARRAYELTS (charset_table_init);
+ PDUMPER_REMEMBER_SCALAR (charset_table_size);
charset_table_used = 0;
+ PDUMPER_REMEMBER_SCALAR (charset_table_used);
defsubr (&Scharsetp);
defsubr (&Smap_charset_chars);
@@ -2408,21 +2423,30 @@ the value may be a list of mnemonics. */);
charset_ascii
= define_charset_internal (Qascii, 1, "\x00\x7F\0\0\0\0\0",
- 0, 127, 'B', -1, 0, 1, 0, 0);
+ 0, 127, 'B', -1, 0, 1, 0, 0);
+ PDUMPER_REMEMBER_SCALAR (charset_ascii);
+
charset_iso_8859_1
= define_charset_internal (Qiso_8859_1, 1, "\x00\xFF\0\0\0\0\0",
- 0, 255, -1, -1, -1, 1, 0, 0);
+ 0, 255, -1, -1, -1, 1, 0, 0);
+ PDUMPER_REMEMBER_SCALAR (charset_iso_8859_1);
+
charset_unicode
= define_charset_internal (Qunicode, 3, "\x00\xFF\x00\xFF\x00\x10\0",
- 0, MAX_UNICODE_CHAR, -1, 0, -1, 1, 0, 0);
+ 0, MAX_UNICODE_CHAR, -1, 0, -1, 1, 0, 0);
+ PDUMPER_REMEMBER_SCALAR (charset_unicode);
+
charset_emacs
= define_charset_internal (Qemacs, 3, "\x00\xFF\x00\xFF\x00\x3F\0",
- 0, MAX_5_BYTE_CHAR, -1, 0, -1, 1, 1, 0);
+ 0, MAX_5_BYTE_CHAR, -1, 0, -1, 1, 1, 0);
+ PDUMPER_REMEMBER_SCALAR (charset_emacs);
+
charset_eight_bit
= define_charset_internal (Qeight_bit, 1, "\x80\xFF\0\0\0\0\0",
128, 255, -1, 0, -1, 0, 1,
- MAX_5_BYTE_CHAR + 1);
+ MAX_5_BYTE_CHAR + 1);
+ PDUMPER_REMEMBER_SCALAR (charset_eight_bit);
+
charset_unibyte = charset_iso_8859_1;
+ PDUMPER_REMEMBER_SCALAR (charset_unibyte);
}
-
-#endif /* emacs */
diff --git a/src/charset.h b/src/charset.h
index 1ecbb55052d..7042a71a469 100644
--- a/src/charset.h
+++ b/src/charset.h
@@ -248,6 +248,7 @@ extern Lisp_Object Vcharset_hash_table;
/* Table of struct charset. */
extern struct charset *charset_table;
+extern int charset_table_size;
#define CHARSET_FROM_ID(id) (charset_table + (id))
@@ -355,7 +356,7 @@ set_charset_attr (struct charset *charset, enum charset_attr_index idx,
\
if (! SYMBOLP (x) || (idx = CHARSET_SYMBOL_HASH_INDEX (x)) < 0) \
wrong_type_argument (Qcharsetp, (x)); \
- id = XINT (AREF (HASH_VALUE (XHASH_TABLE (Vcharset_hash_table), idx), \
+ id = XFIXNUM (AREF (HASH_VALUE (XHASH_TABLE (Vcharset_hash_table), idx), \
charset_id)); \
} while (false)
@@ -416,7 +417,7 @@ extern Lisp_Object Vchar_charset_set;
: (charset)->method == CHARSET_METHOD_MAP \
? (((charset)->code_linear_p \
&& VECTORP (CHARSET_DECODER (charset))) \
- ? XINT (AREF (CHARSET_DECODER (charset), \
+ ? XFIXNUM (AREF (CHARSET_DECODER (charset), \
(code) - (charset)->min_code)) \
: decode_char ((charset), (code))) \
: decode_char ((charset), (code)))
@@ -447,7 +448,7 @@ extern Lisp_Object charset_work;
? (charset_work = CHAR_TABLE_REF (CHARSET_ENCODER (charset), c), \
(NILP (charset_work) \
? (charset)->invalid_code \
- : (unsigned) XFASTINT (charset_work))) \
+ : (unsigned) XFIXNAT (charset_work))) \
: encode_char (charset, c)) \
: encode_char (charset, c))))
diff --git a/src/chartab.c b/src/chartab.c
index 065ae4f9f20..16017f4a49a 100644
--- a/src/chartab.c
+++ b/src/chartab.c
@@ -118,14 +118,14 @@ the char-table has no extra slot. */)
n_extras = 0;
else
{
- CHECK_NATNUM (n);
- if (XINT (n) > 10)
+ CHECK_FIXNAT (n);
+ if (XFIXNUM (n) > 10)
args_out_of_range (n, Qnil);
- n_extras = XINT (n);
+ n_extras = XFIXNUM (n);
}
size = CHAR_TABLE_STANDARD_SLOTS + n_extras;
- vector = Fmake_vector (make_number (size), init);
+ vector = make_vector (size, init);
XSETPVECTYPE (XVECTOR (vector), PVEC_CHAR_TABLE);
set_char_table_parent (vector, Qnil);
set_char_table_purpose (vector, purpose);
@@ -184,16 +184,13 @@ copy_sub_char_table (Lisp_Object table)
Lisp_Object
copy_char_table (Lisp_Object table)
{
- Lisp_Object copy;
int size = PVSIZE (table);
- int i;
-
- copy = Fmake_vector (make_number (size), Qnil);
+ Lisp_Object copy = make_nil_vector (size);
XSETPVECTYPE (XVECTOR (copy), PVEC_CHAR_TABLE);
set_char_table_defalt (copy, XCHAR_TABLE (table)->defalt);
set_char_table_parent (copy, XCHAR_TABLE (table)->parent);
set_char_table_purpose (copy, XCHAR_TABLE (table)->purpose);
- for (i = 0; i < chartab_size[0]; i++)
+ for (int i = 0; i < chartab_size[0]; i++)
set_char_table_contents
(copy, i,
(SUB_CHAR_TABLE_P (XCHAR_TABLE (table)->contents[i])
@@ -201,7 +198,7 @@ copy_char_table (Lisp_Object table)
: XCHAR_TABLE (table)->contents[i]));
set_char_table_ascii (copy, char_table_ascii (copy));
size -= CHAR_TABLE_STANDARD_SLOTS;
- for (i = 0; i < size; i++)
+ for (int i = 0; i < size; i++)
set_char_table_extras (copy, i, XCHAR_TABLE (table)->extras[i]);
XSETCHAR_TABLE (copy, XCHAR_TABLE (copy));
@@ -571,12 +568,12 @@ DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot,
(Lisp_Object char_table, Lisp_Object n)
{
CHECK_CHAR_TABLE (char_table);
- CHECK_NUMBER (n);
- if (XINT (n) < 0
- || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
+ CHECK_FIXNUM (n);
+ if (XFIXNUM (n) < 0
+ || XFIXNUM (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
args_out_of_range (char_table, n);
- return XCHAR_TABLE (char_table)->extras[XINT (n)];
+ return XCHAR_TABLE (char_table)->extras[XFIXNUM (n)];
}
DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot,
@@ -586,12 +583,12 @@ DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot,
(Lisp_Object char_table, Lisp_Object n, Lisp_Object value)
{
CHECK_CHAR_TABLE (char_table);
- CHECK_NUMBER (n);
- if (XINT (n) < 0
- || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
+ CHECK_FIXNUM (n);
+ if (XFIXNUM (n) < 0
+ || XFIXNUM (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
args_out_of_range (char_table, n);
- set_char_table_extras (char_table, XINT (n), value);
+ set_char_table_extras (char_table, XFIXNUM (n), value);
return value;
}
@@ -605,18 +602,18 @@ a cons of character codes (for characters in the range), or a character code. *
Lisp_Object val;
CHECK_CHAR_TABLE (char_table);
- if (EQ (range, Qnil))
+ if (NILP (range))
val = XCHAR_TABLE (char_table)->defalt;
else if (CHARACTERP (range))
- val = CHAR_TABLE_REF (char_table, XFASTINT (range));
+ val = CHAR_TABLE_REF (char_table, XFIXNAT (range));
else if (CONSP (range))
{
int from, to;
CHECK_CHARACTER_CAR (range);
CHECK_CHARACTER_CDR (range);
- from = XFASTINT (XCAR (range));
- to = XFASTINT (XCDR (range));
+ from = XFIXNAT (XCAR (range));
+ to = XFIXNAT (XCDR (range));
val = char_table_ref_and_range (char_table, from, &from, &to);
/* Not yet implemented. */
}
@@ -642,16 +639,16 @@ or a character code. Return VALUE. */)
for (i = 0; i < chartab_size[0]; i++)
set_char_table_contents (char_table, i, value);
}
- else if (EQ (range, Qnil))
+ else if (NILP (range))
set_char_table_defalt (char_table, value);
else if (CHARACTERP (range))
- char_table_set (char_table, XINT (range), value);
+ char_table_set (char_table, XFIXNUM (range), value);
else if (CONSP (range))
{
CHECK_CHARACTER_CAR (range);
CHECK_CHARACTER_CDR (range);
char_table_set_range (char_table,
- XINT (XCAR (range)), XINT (XCDR (range)), value);
+ XFIXNUM (XCAR (range)), XFIXNUM (XCDR (range)), value);
}
else
error ("Invalid RANGE argument to `set-char-table-range'");
@@ -742,7 +739,7 @@ map_sub_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object),
int min_char, max_char;
/* Number of characters covered by one element of TABLE. */
int chars_in_block;
- int from = XINT (XCAR (range)), to = XINT (XCDR (range));
+ int from = XFIXNUM (XCAR (range)), to = XFIXNUM (XCDR (range));
int i, c;
bool is_uniprop = UNIPROP_TABLE_P (top);
uniprop_decoder_t decoder = UNIPROP_GET_DECODER (top);
@@ -783,7 +780,7 @@ map_sub_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object),
if (SUB_CHAR_TABLE_P (this))
{
if (to >= nextc)
- XSETCDR (range, make_number (nextc - 1));
+ XSETCDR (range, make_fixnum (nextc - 1));
val = map_sub_char_table (c_function, function, this, arg,
val, range, top);
}
@@ -807,7 +804,7 @@ map_sub_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object),
set_char_table_parent (parent, Qnil);
val = CHAR_TABLE_REF (parent, from);
set_char_table_parent (parent, temp);
- XSETCDR (range, make_number (c - 1));
+ XSETCDR (range, make_fixnum (c - 1));
val = map_sub_char_table (c_function, function,
parent, arg, val, range,
parent);
@@ -817,7 +814,7 @@ map_sub_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object),
}
if (! NILP (val) && different_value)
{
- XSETCDR (range, make_number (c - 1));
+ XSETCDR (range, make_fixnum (c - 1));
if (EQ (XCAR (range), XCDR (range)))
{
if (c_function)
@@ -843,10 +840,10 @@ map_sub_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object),
}
val = this;
from = c;
- XSETCAR (range, make_number (c));
+ XSETCAR (range, make_fixnum (c));
}
}
- XSETCDR (range, make_number (to));
+ XSETCDR (range, make_fixnum (to));
}
return val;
}
@@ -864,7 +861,7 @@ map_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object),
Lisp_Object range, val, parent;
uniprop_decoder_t decoder = UNIPROP_GET_DECODER (table);
- range = Fcons (make_number (0), make_number (MAX_CHAR));
+ range = Fcons (make_fixnum (0), make_fixnum (MAX_CHAR));
parent = XCHAR_TABLE (table)->parent;
val = XCHAR_TABLE (table)->ascii;
@@ -878,7 +875,7 @@ map_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object),
while (NILP (val) && ! NILP (XCHAR_TABLE (table)->parent))
{
Lisp_Object temp;
- int from = XINT (XCAR (range));
+ int from = XFIXNUM (XCAR (range));
parent = XCHAR_TABLE (table)->parent;
temp = XCHAR_TABLE (parent)->parent;
@@ -957,7 +954,7 @@ map_sub_char_table_for_charset (void (*c_function) (Lisp_Object, Lisp_Object),
{
if (! NILP (XCAR (range)))
{
- XSETCDR (range, make_number (c - 1));
+ XSETCDR (range, make_fixnum (c - 1));
if (c_function)
(*c_function) (arg, range);
else
@@ -980,7 +977,7 @@ map_sub_char_table_for_charset (void (*c_function) (Lisp_Object, Lisp_Object),
{
if (! NILP (XCAR (range)))
{
- XSETCDR (range, make_number (c - 1));
+ XSETCDR (range, make_fixnum (c - 1));
if (c_function)
(*c_function) (arg, range);
else
@@ -991,7 +988,7 @@ map_sub_char_table_for_charset (void (*c_function) (Lisp_Object, Lisp_Object),
else
{
if (NILP (XCAR (range)))
- XSETCAR (range, make_number (c));
+ XSETCAR (range, make_fixnum (c));
}
}
}
@@ -1041,7 +1038,7 @@ map_char_table_for_charset (void (*c_function) (Lisp_Object, Lisp_Object),
{
if (! NILP (XCAR (range)))
{
- XSETCDR (range, make_number (c - 1));
+ XSETCDR (range, make_fixnum (c - 1));
if (c_function)
(*c_function) (arg, range);
else
@@ -1052,7 +1049,7 @@ map_char_table_for_charset (void (*c_function) (Lisp_Object, Lisp_Object),
}
if (! NILP (XCAR (range)))
{
- XSETCDR (range, make_number (c - 1));
+ XSETCDR (range, make_fixnum (c - 1));
if (c_function)
(*c_function) (arg, range);
else
@@ -1125,7 +1122,7 @@ uniprop_table_uncompress (Lisp_Object table, int idx)
{
int v = STRING_CHAR_ADVANCE (p);
set_sub_char_table_contents
- (sub, idx++, v > 0 ? make_number (v) : Qnil);
+ (sub, idx++, v > 0 ? make_fixnum (v) : Qnil);
}
}
else if (*p == 2)
@@ -1150,7 +1147,7 @@ uniprop_table_uncompress (Lisp_Object table, int idx)
}
}
while (count-- > 0)
- set_sub_char_table_contents (sub, idx++, make_number (v));
+ set_sub_char_table_contents (sub, idx++, make_fixnum (v));
}
}
/* It seems that we don't need this function because C code won't need
@@ -1174,8 +1171,8 @@ uniprop_decode_value_run_length (Lisp_Object table, Lisp_Object value)
{
Lisp_Object valvec = XCHAR_TABLE (table)->extras[4];
- if (XINT (value) >= 0 && XINT (value) < ASIZE (valvec))
- value = AREF (valvec, XINT (value));
+ if (XFIXNUM (value) >= 0 && XFIXNUM (value) < ASIZE (valvec))
+ value = AREF (valvec, XFIXNUM (value));
}
return value;
}
@@ -1192,9 +1189,9 @@ uniprop_get_decoder (Lisp_Object table)
{
EMACS_INT i;
- if (! INTEGERP (XCHAR_TABLE (table)->extras[1]))
+ if (! FIXNUMP (XCHAR_TABLE (table)->extras[1]))
return NULL;
- i = XINT (XCHAR_TABLE (table)->extras[1]);
+ i = XFIXNUM (XCHAR_TABLE (table)->extras[1]);
if (i < 0 || i >= uniprop_decoder_count)
return NULL;
return uniprop_decoder[i];
@@ -1227,7 +1224,7 @@ uniprop_encode_value_run_length (Lisp_Object table, Lisp_Object value)
break;
if (i == size)
wrong_type_argument (build_string ("Unicode property value"), value);
- return make_number (i);
+ return make_fixnum (i);
}
@@ -1240,17 +1237,17 @@ uniprop_encode_value_numeric (Lisp_Object table, Lisp_Object value)
Lisp_Object *value_table = XVECTOR (XCHAR_TABLE (table)->extras[4])->contents;
int i, size = ASIZE (XCHAR_TABLE (table)->extras[4]);
- CHECK_NUMBER (value);
+ CHECK_FIXNUM (value);
for (i = 0; i < size; i++)
if (EQ (value, value_table[i]))
break;
- value = make_number (i);
+ value = make_fixnum (i);
if (i == size)
set_char_table_extras (table, 4,
CALLN (Fvconcat,
XCHAR_TABLE (table)->extras[4],
- Fmake_vector (make_number (1), value)));
- return make_number (i);
+ make_vector (1, value)));
+ return make_fixnum (i);
}
static uniprop_encoder_t uniprop_encoder[] =
@@ -1267,9 +1264,9 @@ uniprop_get_encoder (Lisp_Object table)
{
EMACS_INT i;
- if (! INTEGERP (XCHAR_TABLE (table)->extras[2]))
+ if (! FIXNUMP (XCHAR_TABLE (table)->extras[2]))
return NULL;
- i = XINT (XCHAR_TABLE (table)->extras[2]);
+ i = XFIXNUM (XCHAR_TABLE (table)->extras[2]);
if (i < 0 || i >= uniprop_encoder_count)
return NULL;
return uniprop_encoder[i];
@@ -1300,8 +1297,8 @@ uniprop_table (Lisp_Object prop)
|| ! UNIPROP_TABLE_P (table))
return Qnil;
val = XCHAR_TABLE (table)->extras[1];
- if (INTEGERP (val)
- ? (XINT (val) < 0 || XINT (val) >= uniprop_decoder_count)
+ if (FIXNUMP (val)
+ ? (XFIXNUM (val) < 0 || XFIXNUM (val) >= uniprop_decoder_count)
: ! NILP (val))
return Qnil;
/* Prepare ASCII values in advance for CHAR_TABLE_REF. */
@@ -1337,7 +1334,7 @@ CHAR-TABLE must be what returned by `unicode-property-table-internal'. */)
CHECK_CHARACTER (ch);
if (! UNIPROP_TABLE_P (char_table))
error ("Invalid Unicode property table");
- val = CHAR_TABLE_REF (char_table, XINT (ch));
+ val = CHAR_TABLE_REF (char_table, XFIXNUM (ch));
decoder = uniprop_get_decoder (char_table);
return (decoder ? decoder (char_table, val) : val);
}
@@ -1357,7 +1354,7 @@ CHAR-TABLE must be what returned by `unicode-property-table-internal'. */)
encoder = uniprop_get_encoder (char_table);
if (encoder)
value = encoder (char_table, value);
- CHAR_TABLE_SET (char_table, XINT (ch), value);
+ CHAR_TABLE_SET (char_table, XFIXNUM (ch), value);
return Qnil;
}
diff --git a/src/cmds.c b/src/cmds.c
index c92df6a8356..9f3c8610e62 100644
--- a/src/cmds.c
+++ b/src/cmds.c
@@ -35,9 +35,9 @@ DEFUN ("forward-point", Fforward_point, Sforward_point, 1, 1, 0,
doc: /* Return buffer position N characters after (before if N negative) point. */)
(Lisp_Object n)
{
- CHECK_NUMBER (n);
+ CHECK_FIXNUM (n);
- return make_number (PT + XINT (n));
+ return make_fixnum (PT + XFIXNUM (n));
}
/* Add N to point; or subtract N if FORWARD is false. N defaults to 1.
@@ -45,7 +45,7 @@ DEFUN ("forward-point", Fforward_point, Sforward_point, 1, 1, 0,
static Lisp_Object
move_point (Lisp_Object n, bool forward)
{
- /* This used to just set point to point + XINT (n), and then check
+ /* This used to just set point to point + XFIXNUM (n), and then check
to see if it was within boundaries. But now that SET_PT can
potentially do a lot of stuff (calling entering and exiting
hooks, etcetera), that's not a good approach. So we validate the
@@ -56,9 +56,9 @@ move_point (Lisp_Object n, bool forward)
if (NILP (n))
XSETFASTINT (n, 1);
else
- CHECK_NUMBER (n);
+ CHECK_FIXNUM (n);
- new_point = PT + (forward ? XINT (n) : - XINT (n));
+ new_point = PT + (forward ? XFIXNUM (n) : - XFIXNUM (n));
if (new_point < BEGV)
{
@@ -121,28 +121,36 @@ it as a line moved across, even though there is no next line to
go to its beginning. */)
(Lisp_Object n)
{
- ptrdiff_t opoint = PT, pos, pos_byte, shortage, count;
+ ptrdiff_t opoint = PT, pos, pos_byte, count;
+ bool excessive = false;
if (NILP (n))
count = 1;
else
{
- CHECK_NUMBER (n);
- count = XINT (n);
+ CHECK_INTEGER (n);
+ if (FIXNUMP (n)
+ && -BUF_BYTES_MAX <= XFIXNUM (n) && XFIXNUM (n) <= BUF_BYTES_MAX)
+ count = XFIXNUM (n);
+ else
+ {
+ count = !NILP (Fnatnump (n)) ? BUF_BYTES_MAX : -BUF_BYTES_MAX;
+ excessive = true;
+ }
}
- shortage = scan_newline_from_point (count, &pos, &pos_byte);
+ ptrdiff_t counted = scan_newline_from_point (count, &pos, &pos_byte);
SET_PT_BOTH (pos, pos_byte);
- if (shortage > 0
- && (count <= 0
- || (ZV > BEGV
- && PT != opoint
- && (FETCH_BYTE (PT_BYTE - 1) != '\n'))))
- shortage--;
-
- return make_number (count <= 0 ? - shortage : shortage);
+ ptrdiff_t shortage = count - (count <= 0) - counted;
+ if (shortage != 0)
+ shortage -= (count <= 0 ? -1
+ : (BEGV < ZV && PT != opoint
+ && FETCH_BYTE (PT_BYTE - 1) != '\n'));
+ return (excessive
+ ? CALLN (Fplus, make_fixnum (shortage - count), n)
+ : make_fixnum (shortage));
}
DEFUN ("beginning-of-line", Fbeginning_of_line, Sbeginning_of_line, 0, 1, "^p",
@@ -162,9 +170,9 @@ instead. For instance, `(forward-line 0)' does the same thing as
if (NILP (n))
XSETFASTINT (n, 1);
else
- CHECK_NUMBER (n);
+ CHECK_FIXNUM (n);
- SET_PT (XINT (Fline_beginning_position (n)));
+ SET_PT (XFIXNUM (Fline_beginning_position (n)));
return Qnil;
}
@@ -187,11 +195,11 @@ to t. */)
if (NILP (n))
XSETFASTINT (n, 1);
else
- CHECK_NUMBER (n);
+ CHECK_FIXNUM (n);
while (1)
{
- newpos = XINT (Fline_end_position (n));
+ newpos = XFIXNUM (Fline_end_position (n));
SET_PT (newpos);
if (PT > newpos
@@ -210,7 +218,7 @@ to t. */)
/* If we skipped something intangible
and now we're not really at eol,
keep going. */
- n = make_number (1);
+ n = make_fixnum (1);
else
break;
}
@@ -230,15 +238,15 @@ because it respects values of `delete-active-region' and `overwrite-mode'. */)
{
EMACS_INT pos;
- CHECK_NUMBER (n);
+ CHECK_FIXNUM (n);
- if (eabs (XINT (n)) < 2)
+ if (eabs (XFIXNUM (n)) < 2)
call0 (Qundo_auto_amalgamate);
- pos = PT + XINT (n);
+ pos = PT + XFIXNUM (n);
if (NILP (killflag))
{
- if (XINT (n) < 0)
+ if (XFIXNUM (n) < 0)
{
if (pos < BEGV)
xsignal0 (Qbeginning_of_buffer);
@@ -260,11 +268,10 @@ because it respects values of `delete-active-region' and `overwrite-mode'. */)
return Qnil;
}
-/* Note that there's code in command_loop_1 which typically avoids
- calling this. */
-DEFUN ("self-insert-command", Fself_insert_command, Sself_insert_command, 1, 1, "p",
+DEFUN ("self-insert-command", Fself_insert_command, Sself_insert_command, 1, 2,
+ "(list (prefix-numeric-value current-prefix-arg) last-command-event)",
doc: /* Insert the character you type.
-Whichever character you type to run this command is inserted.
+Whichever character C you type to run this command is inserted.
The numeric prefix argument N says how many times to repeat the insertion.
Before insertion, `expand-abbrev' is executed if the inserted character does
not have word syntax and the previous character in the buffer does.
@@ -272,23 +279,27 @@ After insertion, `internal-auto-fill' is called if
`auto-fill-function' is non-nil and if the `auto-fill-chars' table has
a non-nil value for the inserted character. At the end, it runs
`post-self-insert-hook'. */)
- (Lisp_Object n)
+ (Lisp_Object n, Lisp_Object c)
{
- CHECK_NUMBER (n);
+ CHECK_FIXNUM (n);
+
+ /* Backward compatibility. */
+ if (NILP (c))
+ c = last_command_event;
- if (XINT (n) < 0)
- error ("Negative repetition argument %"pI"d", XINT (n));
+ if (XFIXNUM (n) < 0)
+ error ("Negative repetition argument %"pI"d", XFIXNUM (n));
- if (XFASTINT (n) < 2)
+ if (XFIXNAT (n) < 2)
call0 (Qundo_auto_amalgamate);
/* Barf if the key that invoked this was not a character. */
- if (!CHARACTERP (last_command_event))
+ if (!CHARACTERP (c))
bitch_at_user ();
else {
int character = translate_char (Vtranslation_table_for_input,
- XINT (last_command_event));
- int val = internal_self_insert (character, XFASTINT (n));
+ XFIXNUM (c));
+ int val = internal_self_insert (character, XFIXNAT (n));
if (val == 2)
Fset (Qundo_auto__this_command_amalgamating, Qnil);
frame_make_pointer_invisible (SELECTED_FRAME ());
@@ -360,7 +371,7 @@ internal_self_insert (int c, EMACS_INT n)
if (EQ (overwrite, Qoverwrite_mode_binary))
chars_to_delete = min (n, PTRDIFF_MAX);
else if (c != '\n' && c2 != '\n'
- && (cwidth = XFASTINT (Fchar_width (make_number (c)))) != 0)
+ && (cwidth = XFIXNAT (Fchar_width (make_fixnum (c)))) != 0)
{
ptrdiff_t pos = PT;
ptrdiff_t pos_byte = PT_BYTE;
@@ -378,7 +389,7 @@ internal_self_insert (int c, EMACS_INT n)
character. In that case, the new point is set after
that character. */
ptrdiff_t actual_clm
- = XFASTINT (Fmove_to_column (make_number (target_clm), Qnil));
+ = XFIXNAT (Fmove_to_column (make_fixnum (target_clm), Qnil));
chars_to_delete = PT - pos;
@@ -408,11 +419,11 @@ internal_self_insert (int c, EMACS_INT n)
&& NILP (BVAR (current_buffer, read_only))
&& PT > BEGV
&& (SYNTAX (!NILP (BVAR (current_buffer, enable_multibyte_characters))
- ? XFASTINT (Fprevious_char ())
- : UNIBYTE_TO_CHAR (XFASTINT (Fprevious_char ())))
+ ? XFIXNAT (Fprevious_char ())
+ : UNIBYTE_TO_CHAR (XFIXNAT (Fprevious_char ())))
== Sword))
{
- EMACS_INT modiff = MODIFF;
+ modiff_count modiff = MODIFF;
Lisp_Object sym;
sym = call0 (Qexpand_abbrev);
@@ -439,17 +450,18 @@ internal_self_insert (int c, EMACS_INT n)
int mc = ((NILP (BVAR (current_buffer, enable_multibyte_characters))
&& SINGLE_BYTE_CHAR_P (c))
? UNIBYTE_TO_CHAR (c) : c);
- Lisp_Object string = Fmake_string (make_number (n), make_number (mc));
+ Lisp_Object string = Fmake_string (make_fixnum (n), make_fixnum (mc),
+ Qnil);
if (spaces_to_insert)
{
- tem = Fmake_string (make_number (spaces_to_insert),
- make_number (' '));
+ tem = Fmake_string (make_fixnum (spaces_to_insert),
+ make_fixnum (' '), Qnil);
string = concat2 (string, tem);
}
replace_range (PT, PT + chars_to_delete, string, 1, 1, 1, 0);
- Fforward_char (make_number (n));
+ Fforward_char (make_fixnum (n));
}
else if (n > 1)
{
diff --git a/src/coding.c b/src/coding.c
index 249abd9dd4e..e351cc72fab 100644
--- a/src/coding.c
+++ b/src/coding.c
@@ -298,6 +298,7 @@ encode_coding_XXX (struct coding_system *coding)
#include "composite.h"
#include "coding.h"
#include "termhooks.h"
+#include "pdumper.h"
Lisp_Object Vcoding_system_hash_table;
@@ -307,16 +308,12 @@ Lisp_Object Vcoding_system_hash_table;
file and process), not for in-buffer or Lisp string encoding. */
static Lisp_Object system_eol_type;
-#ifdef emacs
-
/* Coding-systems are handed between Emacs Lisp programs and C internal
routines by the following three variables. */
/* Coding system to be used to encode text for terminal display when
terminal coding system is nil. */
struct coding_system safe_terminal_coding;
-#endif /* emacs */
-
/* Two special coding systems. */
static Lisp_Object Vsjis_coding_system;
static Lisp_Object Vbig5_coding_system;
@@ -324,7 +321,7 @@ static Lisp_Object Vbig5_coding_system;
/* ISO2022 section */
#define CODING_ISO_INITIAL(coding, reg) \
- (XINT (AREF (AREF (CODING_ID_ATTRS ((coding)->id), \
+ (XFIXNUM (AREF (AREF (CODING_ID_ATTRS ((coding)->id), \
coding_attr_iso_initial), \
reg)))
@@ -617,23 +614,7 @@ inhibit_flag (int encoded_flag, bool var)
do { \
(attrs) = CODING_ID_ATTRS ((coding)->id); \
(charset_list) = CODING_ATTR_CHARSET_LIST (attrs); \
- } while (0)
-
-static void
-CHECK_NATNUM_CAR (Lisp_Object x)
-{
- Lisp_Object tmp = XCAR (x);
- CHECK_NATNUM (tmp);
- XSETCAR (x, tmp);
-}
-
-static void
-CHECK_NATNUM_CDR (Lisp_Object x)
-{
- Lisp_Object tmp = XCDR (x);
- CHECK_NATNUM (tmp);
- XSETCDR (x, tmp);
-}
+ } while (false)
/* True if CODING's destination can be grown. */
@@ -2622,7 +2603,7 @@ encode_coding_emacs_mule (struct coding_system *coding)
case CODING_ANNOTATE_CHARSET_MASK:
preferred_charset_id = charbuf[3];
if (preferred_charset_id >= 0
- && NILP (Fmemq (make_number (preferred_charset_id),
+ && NILP (Fmemq (make_fixnum (preferred_charset_id),
charset_list)))
preferred_charset_id = -1;
break;
@@ -2888,7 +2869,7 @@ setup_iso_safe_charsets (Lisp_Object attrs)
Lisp_Object reg_usage;
Lisp_Object tail;
EMACS_INT reg94, reg96;
- int flags = XINT (AREF (attrs, coding_attr_iso_flags));
+ int flags = XFIXNUM (AREF (attrs, coding_attr_iso_flags));
int max_charset_id;
charset_list = CODING_ATTR_CHARSET_LIST (attrs);
@@ -2906,7 +2887,7 @@ setup_iso_safe_charsets (Lisp_Object attrs)
max_charset_id = 0;
for (tail = charset_list; CONSP (tail); tail = XCDR (tail))
{
- int id = XINT (XCAR (tail));
+ int id = XFIXNUM (XCAR (tail));
if (max_charset_id < id)
max_charset_id = id;
}
@@ -2915,8 +2896,8 @@ setup_iso_safe_charsets (Lisp_Object attrs)
memset (SDATA (safe_charsets), 255, max_charset_id + 1);
request = AREF (attrs, coding_attr_iso_request);
reg_usage = AREF (attrs, coding_attr_iso_usage);
- reg94 = XINT (XCAR (reg_usage));
- reg96 = XINT (XCDR (reg_usage));
+ reg94 = XFIXNUM (XCAR (reg_usage));
+ reg96 = XFIXNUM (XCDR (reg_usage));
for (tail = charset_list; CONSP (tail); tail = XCDR (tail))
{
@@ -2925,19 +2906,19 @@ setup_iso_safe_charsets (Lisp_Object attrs)
struct charset *charset;
id = XCAR (tail);
- charset = CHARSET_FROM_ID (XINT (id));
+ charset = CHARSET_FROM_ID (XFIXNUM (id));
reg = Fcdr (Fassq (id, request));
if (! NILP (reg))
- SSET (safe_charsets, XINT (id), XINT (reg));
+ SSET (safe_charsets, XFIXNUM (id), XFIXNUM (reg));
else if (charset->iso_chars_96)
{
if (reg96 < 4)
- SSET (safe_charsets, XINT (id), reg96);
+ SSET (safe_charsets, XFIXNUM (id), reg96);
}
else
{
if (reg94 < 4)
- SSET (safe_charsets, XINT (id), reg94);
+ SSET (safe_charsets, XFIXNUM (id), reg94);
}
}
ASET (attrs, coding_attr_safe_charsets, safe_charsets);
@@ -4459,7 +4440,7 @@ encode_coding_iso_2022 (struct coding_system *coding)
case CODING_ANNOTATE_CHARSET_MASK:
preferred_charset_id = charbuf[2];
if (preferred_charset_id >= 0
- && NILP (Fmemq (make_number (preferred_charset_id),
+ && NILP (Fmemq (make_fixnum (preferred_charset_id),
charset_list)))
preferred_charset_id = -1;
break;
@@ -4611,8 +4592,7 @@ detect_coding_sjis (struct coding_system *coding,
int max_first_byte_of_2_byte_code;
CODING_GET_INFO (coding, attrs, charset_list);
- max_first_byte_of_2_byte_code
- = (XINT (Flength (charset_list)) > 3 ? 0xFC : 0xEF);
+ max_first_byte_of_2_byte_code = list_length (charset_list) <= 3 ? 0xEF : 0xFC;
detect_info->checked |= CATEGORY_MASK_SJIS;
/* A coding system of this category is always ASCII compatible. */
@@ -4725,10 +4705,10 @@ decode_coding_sjis (struct coding_system *coding)
CODING_GET_INFO (coding, attrs, charset_list);
val = charset_list;
- charset_roman = CHARSET_FROM_ID (XINT (XCAR (val))), val = XCDR (val);
- charset_kana = CHARSET_FROM_ID (XINT (XCAR (val))), val = XCDR (val);
- charset_kanji = CHARSET_FROM_ID (XINT (XCAR (val))), val = XCDR (val);
- charset_kanji2 = NILP (val) ? NULL : CHARSET_FROM_ID (XINT (XCAR (val)));
+ charset_roman = CHARSET_FROM_ID (XFIXNUM (XCAR (val))), val = XCDR (val);
+ charset_kana = CHARSET_FROM_ID (XFIXNUM (XCAR (val))), val = XCDR (val);
+ charset_kanji = CHARSET_FROM_ID (XFIXNUM (XCAR (val))), val = XCDR (val);
+ charset_kanji2 = NILP (val) ? NULL : CHARSET_FROM_ID (XFIXNUM (XCAR (val)));
while (1)
{
@@ -4840,8 +4820,8 @@ decode_coding_big5 (struct coding_system *coding)
CODING_GET_INFO (coding, attrs, charset_list);
val = charset_list;
- charset_roman = CHARSET_FROM_ID (XINT (XCAR (val))), val = XCDR (val);
- charset_big5 = CHARSET_FROM_ID (XINT (XCAR (val)));
+ charset_roman = CHARSET_FROM_ID (XFIXNUM (XCAR (val))), val = XCDR (val);
+ charset_big5 = CHARSET_FROM_ID (XFIXNUM (XCAR (val)));
while (1)
{
@@ -4936,9 +4916,9 @@ encode_coding_sjis (struct coding_system *coding)
CODING_GET_INFO (coding, attrs, charset_list);
val = XCDR (charset_list);
- charset_kana = CHARSET_FROM_ID (XINT (XCAR (val))), val = XCDR (val);
- charset_kanji = CHARSET_FROM_ID (XINT (XCAR (val))), val = XCDR (val);
- charset_kanji2 = NILP (val) ? NULL : CHARSET_FROM_ID (XINT (XCAR (val)));
+ charset_kana = CHARSET_FROM_ID (XFIXNUM (XCAR (val))), val = XCDR (val);
+ charset_kanji = CHARSET_FROM_ID (XFIXNUM (XCAR (val))), val = XCDR (val);
+ charset_kanji2 = NILP (val) ? NULL : CHARSET_FROM_ID (XFIXNUM (XCAR (val)));
ascii_compatible = ! NILP (CODING_ATTR_ASCII_COMPAT (attrs));
@@ -5029,7 +5009,7 @@ encode_coding_big5 (struct coding_system *coding)
CODING_GET_INFO (coding, attrs, charset_list);
val = XCDR (charset_list);
- charset_big5 = CHARSET_FROM_ID (XINT (XCAR (val)));
+ charset_big5 = CHARSET_FROM_ID (XFIXNUM (XCAR (val)));
ascii_compatible = ! NILP (CODING_ATTR_ASCII_COMPAT (attrs));
while (charbuf < charbuf_end)
@@ -5440,9 +5420,9 @@ detect_coding_charset (struct coding_system *coding,
break;
found = CATEGORY_MASK_CHARSET;
}
- if (INTEGERP (val))
+ if (FIXNUMP (val))
{
- charset = CHARSET_FROM_ID (XFASTINT (val));
+ charset = CHARSET_FROM_ID (XFIXNAT (val));
dim = CHARSET_DIMENSION (charset);
for (idx = 1; idx < dim; idx++)
{
@@ -5461,7 +5441,7 @@ detect_coding_charset (struct coding_system *coding,
idx = 1;
for (; CONSP (val); val = XCDR (val))
{
- charset = CHARSET_FROM_ID (XFASTINT (XCAR (val)));
+ charset = CHARSET_FROM_ID (XFIXNAT (XCAR (val)));
dim = CHARSET_DIMENSION (charset);
while (idx < dim)
{
@@ -5551,11 +5531,11 @@ decode_coding_charset (struct coding_system *coding)
code = c;
val = AREF (valids, c);
- if (! INTEGERP (val) && ! CONSP (val))
+ if (! FIXNUMP (val) && ! CONSP (val))
goto invalid_code;
- if (INTEGERP (val))
+ if (FIXNUMP (val))
{
- charset = CHARSET_FROM_ID (XFASTINT (val));
+ charset = CHARSET_FROM_ID (XFIXNAT (val));
dim = CHARSET_DIMENSION (charset);
while (len < dim)
{
@@ -5573,7 +5553,7 @@ decode_coding_charset (struct coding_system *coding)
comes first). */
while (CONSP (val))
{
- charset = CHARSET_FROM_ID (XFASTINT (XCAR (val)));
+ charset = CHARSET_FROM_ID (XFIXNAT (XCAR (val)));
dim = CHARSET_DIMENSION (charset);
while (len < dim)
{
@@ -5726,7 +5706,7 @@ setup_coding_system (Lisp_Object coding_system, struct coding_system *coding)
val = CODING_ATTR_SAFE_CHARSETS (attrs);
coding->max_charset_id = SCHARS (val) - 1;
coding->safe_charsets = SDATA (val);
- coding->default_char = XINT (CODING_ATTR_DEFAULT_CHAR (attrs));
+ coding->default_char = XFIXNUM (CODING_ATTR_DEFAULT_CHAR (attrs));
coding->carryover_bytes = 0;
coding->raw_destination = 0;
@@ -5739,7 +5719,7 @@ setup_coding_system (Lisp_Object coding_system, struct coding_system *coding)
coding->common_flags |= CODING_REQUIRE_DETECTION_MASK;
coding->spec.undecided.inhibit_nbd
= (encode_inhibit_flag
- (AREF (attrs, coding_attr_undecided_inhibit_null_byte_detection)));
+ (AREF (attrs, coding_attr_undecided_inhibit_nul_byte_detection)));
coding->spec.undecided.inhibit_ied
= (encode_inhibit_flag
(AREF (attrs, coding_attr_undecided_inhibit_iso_escape_detection)));
@@ -5749,7 +5729,7 @@ setup_coding_system (Lisp_Object coding_system, struct coding_system *coding)
else if (EQ (coding_type, Qiso_2022))
{
int i;
- int flags = XINT (AREF (attrs, coding_attr_iso_flags));
+ int flags = XFIXNUM (AREF (attrs, coding_attr_iso_flags));
/* Invoke graphic register 0 to plane 0. */
CODING_ISO_INVOCATION (coding, 0) = 0;
@@ -5852,13 +5832,13 @@ setup_coding_system (Lisp_Object coding_system, struct coding_system *coding)
for (tail = Vemacs_mule_charset_list; CONSP (tail);
tail = XCDR (tail))
- if (max_charset_id < XFASTINT (XCAR (tail)))
- max_charset_id = XFASTINT (XCAR (tail));
+ if (max_charset_id < XFIXNAT (XCAR (tail)))
+ max_charset_id = XFIXNAT (XCAR (tail));
safe_charsets = make_uninit_string (max_charset_id + 1);
memset (SDATA (safe_charsets), 255, max_charset_id + 1);
for (tail = Vemacs_mule_charset_list; CONSP (tail);
tail = XCDR (tail))
- SSET (safe_charsets, XFASTINT (XCAR (tail)), 0);
+ SSET (safe_charsets, XFIXNAT (XCAR (tail)), 0);
coding->max_charset_id = max_charset_id;
coding->safe_charsets = SDATA (safe_charsets);
}
@@ -5908,7 +5888,7 @@ coding_charset_list (struct coding_system *coding)
CODING_GET_INFO (coding, attrs, charset_list);
if (EQ (CODING_ATTR_TYPE (attrs), Qiso_2022))
{
- int flags = XINT (AREF (attrs, coding_attr_iso_flags));
+ int flags = XFIXNUM (AREF (attrs, coding_attr_iso_flags));
if (flags & CODING_ISO_FLAG_FULL_SUPPORT)
charset_list = Viso_2022_charset_list;
@@ -5934,7 +5914,7 @@ coding_system_charset_list (Lisp_Object coding_system)
if (EQ (CODING_ATTR_TYPE (attrs), Qiso_2022))
{
- int flags = XINT (AREF (attrs, coding_attr_iso_flags));
+ int flags = XFIXNUM (AREF (attrs, coding_attr_iso_flags));
if (flags & CODING_ISO_FLAG_FULL_SUPPORT)
charset_list = Viso_2022_charset_list;
@@ -6356,6 +6336,27 @@ check_utf_8 (struct coding_system *coding)
}
+/* Return whether STRING is a valid UTF-8 string. STRING must be a
+ unibyte string. */
+
+bool
+utf8_string_p (Lisp_Object string)
+{
+ eassert (!STRING_MULTIBYTE (string));
+ struct coding_system coding;
+ setup_coding_system (Qutf_8_unix, &coding);
+ /* We initialize only the fields that check_utf_8 accesses. */
+ coding.head_ascii = -1;
+ coding.src_pos = 0;
+ coding.src_pos_byte = 0;
+ coding.src_chars = SCHARS (string);
+ coding.src_bytes = SBYTES (string);
+ coding.src_object = string;
+ coding.eol_seen = EOL_SEEN_NONE;
+ return check_utf_8 (&coding) != -1;
+}
+
+
/* Detect how end-of-line of a text of length SRC_BYTES pointed by
SOURCE is encoded. If CATEGORY is one of
coding_category_utf_16_XXXX, assume that CR and LF are encoded by
@@ -6513,9 +6514,9 @@ detect_coding (struct coding_system *coding)
{
int c, i;
struct coding_detection_info detect_info;
- bool null_byte_found = 0, eight_bit_found = 0;
+ bool nul_byte_found = 0, eight_bit_found = 0;
bool inhibit_nbd = inhibit_flag (coding->spec.undecided.inhibit_nbd,
- inhibit_null_byte_detection);
+ inhibit_nul_byte_detection);
bool inhibit_ied = inhibit_flag (coding->spec.undecided.inhibit_ied,
inhibit_iso_escape_detection);
bool prefer_utf_8 = coding->spec.undecided.prefer_utf_8;
@@ -6528,7 +6529,7 @@ detect_coding (struct coding_system *coding)
if (c & 0x80)
{
eight_bit_found = 1;
- if (null_byte_found)
+ if (nul_byte_found)
break;
}
else if (c < 0x20)
@@ -6543,7 +6544,7 @@ detect_coding (struct coding_system *coding)
if (! (detect_info.rejected & CATEGORY_MASK_ISO_7_ELSE))
{
/* We didn't find an 8-bit code. We may
- have found a null-byte, but it's very
+ have found a NUL-byte, but it's very
rare that a binary file conforms to
ISO-2022. */
src = src_end;
@@ -6555,7 +6556,7 @@ detect_coding (struct coding_system *coding)
}
else if (! c && !inhibit_nbd)
{
- null_byte_found = 1;
+ nul_byte_found = 1;
if (eight_bit_found)
break;
}
@@ -6587,7 +6588,7 @@ detect_coding (struct coding_system *coding)
coding->head_ascii++;
}
- if (null_byte_found || eight_bit_found
+ if (nul_byte_found || eight_bit_found
|| coding->head_ascii < coding->src_bytes
|| detect_info.found)
{
@@ -6605,7 +6606,7 @@ detect_coding (struct coding_system *coding)
}
else
{
- if (null_byte_found)
+ if (nul_byte_found)
{
detect_info.checked |= ~CATEGORY_MASK_UTF_16;
detect_info.rejected |= ~CATEGORY_MASK_UTF_16;
@@ -6678,7 +6679,7 @@ detect_coding (struct coding_system *coding)
else
found = CODING_ID_NAME (this->id);
}
- else if (null_byte_found)
+ else if (nul_byte_found)
found = Qno_conversion;
else if ((detect_info.rejected & CATEGORY_MASK_ANY)
== CATEGORY_MASK_ANY)
@@ -6693,7 +6694,7 @@ detect_coding (struct coding_system *coding)
}
}
}
- else if (XINT (CODING_ATTR_CATEGORY (CODING_ID_ATTRS (coding->id)))
+ else if (XFIXNUM (CODING_ATTR_CATEGORY (CODING_ID_ATTRS (coding->id)))
== coding_category_utf_8_auto)
{
Lisp_Object coding_systems;
@@ -6719,7 +6720,7 @@ detect_coding (struct coding_system *coding)
}
}
}
- else if (XINT (CODING_ATTR_CATEGORY (CODING_ID_ATTRS (coding->id)))
+ else if (XFIXNUM (CODING_ATTR_CATEGORY (CODING_ID_ATTRS (coding->id)))
== coding_category_utf_16_auto)
{
Lisp_Object coding_systems;
@@ -6903,8 +6904,8 @@ get_translation_table (Lisp_Object attrs, bool encodep, int *max_lookup)
&& CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (translation_table)) > 1)
{
val = XCHAR_TABLE (translation_table)->extras[1];
- if (NATNUMP (val) && *max_lookup < XFASTINT (val))
- *max_lookup = min (XFASTINT (val), MAX_LOOKUP_MAX);
+ if (FIXNATP (val) && *max_lookup < XFIXNAT (val))
+ *max_lookup = min (XFIXNAT (val), MAX_LOOKUP_MAX);
}
else if (CONSP (translation_table))
{
@@ -6915,8 +6916,8 @@ get_translation_table (Lisp_Object attrs, bool encodep, int *max_lookup)
&& CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (XCAR (tail))) > 1)
{
Lisp_Object tailval = XCHAR_TABLE (XCAR (tail))->extras[1];
- if (NATNUMP (tailval) && *max_lookup < XFASTINT (tailval))
- *max_lookup = min (XFASTINT (tailval), MAX_LOOKUP_MAX);
+ if (FIXNATP (tailval) && *max_lookup < XFIXNAT (tailval))
+ *max_lookup = min (XFIXNAT (tailval), MAX_LOOKUP_MAX);
}
}
}
@@ -6930,7 +6931,7 @@ get_translation_table (Lisp_Object attrs, bool encodep, int *max_lookup)
{ \
trans = CHAR_TABLE_REF (table, c); \
if (CHARACTERP (trans)) \
- c = XFASTINT (trans), trans = Qnil; \
+ c = XFIXNAT (trans), trans = Qnil; \
} \
else if (CONSP (table)) \
{ \
@@ -6941,7 +6942,7 @@ get_translation_table (Lisp_Object attrs, bool encodep, int *max_lookup)
{ \
trans = CHAR_TABLE_REF (XCAR (tail), c); \
if (CHARACTERP (trans)) \
- c = XFASTINT (trans), trans = Qnil; \
+ c = XFIXNAT (trans), trans = Qnil; \
else if (! NILP (trans)) \
break; \
} \
@@ -6960,7 +6961,7 @@ get_translation_table (Lisp_Object attrs, bool encodep, int *max_lookup)
static Lisp_Object
get_translation (Lisp_Object trans, int *buf, int *buf_end, ptrdiff_t *nchars)
{
- if (INTEGERP (trans) || VECTORP (trans))
+ if (FIXNUMP (trans) || VECTORP (trans))
{
*nchars = 1;
return trans;
@@ -6976,7 +6977,7 @@ get_translation (Lisp_Object trans, int *buf, int *buf_end, ptrdiff_t *nchars)
{
if (buf + i == buf_end)
return Qt;
- if (XINT (AREF (from, i)) != buf[i])
+ if (XFIXNUM (AREF (from, i)) != buf[i])
break;
}
if (i == len)
@@ -7027,12 +7028,12 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table,
if (! NILP (trans))
{
trans = get_translation (trans, buf, buf_end, &from_nchars);
- if (INTEGERP (trans))
- c = XINT (trans);
+ if (FIXNUMP (trans))
+ c = XFIXNUM (trans);
else if (VECTORP (trans))
{
to_nchars = ASIZE (trans);
- c = XINT (AREF (trans, 0));
+ c = XFIXNUM (AREF (trans, 0));
}
else if (EQ (trans, Qt) && ! last_block)
break;
@@ -7060,7 +7061,7 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table,
for (i = 0; i < to_nchars; i++)
{
if (i > 0)
- c = XINT (AREF (trans, i));
+ c = XFIXNUM (AREF (trans, i));
if (coding->dst_multibyte
|| ! CHAR_BYTE8_P (c))
CHAR_STRING_ADVANCE_NO_UNIFY (c, dst);
@@ -7218,11 +7219,11 @@ produce_composition (struct coding_system *coding, int *charbuf, ptrdiff_t pos)
for (i = j = 0; i < len && charbuf[i] != -1; i++, j++)
{
if (charbuf[i] >= 0)
- args[j] = make_number (charbuf[i]);
+ args[j] = make_fixnum (charbuf[i]);
else
{
i++;
- args[j] = make_number (charbuf[i] % 0x100);
+ args[j] = make_fixnum (charbuf[i] % 0x100);
}
}
components = (i == j ? Fstring (j, args) : Fvector (j, args));
@@ -7242,7 +7243,7 @@ produce_charset (struct coding_system *coding, int *charbuf, ptrdiff_t pos)
ptrdiff_t from = pos - charbuf[2];
struct charset *charset = CHARSET_FROM_ID (charbuf[3]);
- Fput_text_property (make_number (from), make_number (pos),
+ Fput_text_property (make_fixnum (from), make_fixnum (pos),
Qcharset, CHARSET_NAME (charset),
coding->dst_object);
}
@@ -7513,7 +7514,7 @@ handle_composition_annotation (ptrdiff_t pos, ptrdiff_t limit,
{
len = ASIZE (components);
for (i = 0; i < len; i++)
- *buf++ = XINT (AREF (components, i));
+ *buf++ = XFIXNUM (AREF (components, i));
}
else if (STRINGP (components))
{
@@ -7525,16 +7526,16 @@ handle_composition_annotation (ptrdiff_t pos, ptrdiff_t limit,
buf++;
}
}
- else if (INTEGERP (components))
+ else if (FIXNUMP (components))
{
len = 1;
- *buf++ = XINT (components);
+ *buf++ = XFIXNUM (components);
}
else if (CONSP (components))
{
for (len = 0; CONSP (components);
len++, components = XCDR (components))
- *buf++ = XINT (XCAR (components));
+ *buf++ = XFIXNUM (XCAR (components));
}
else
emacs_abort ();
@@ -7570,16 +7571,16 @@ handle_charset_annotation (ptrdiff_t pos, ptrdiff_t limit,
Lisp_Object val, next;
int id;
- val = Fget_text_property (make_number (pos), Qcharset, coding->src_object);
+ val = Fget_text_property (make_fixnum (pos), Qcharset, coding->src_object);
if (! NILP (val) && CHARSETP (val))
- id = XINT (CHARSET_SYMBOL_ID (val));
+ id = XFIXNUM (CHARSET_SYMBOL_ID (val));
else
id = -1;
ADD_CHARSET_DATA (buf, 0, id);
- next = Fnext_single_property_change (make_number (pos), Qcharset,
+ next = Fnext_single_property_change (make_fixnum (pos), Qcharset,
coding->src_object,
- make_number (limit));
- *stop = XINT (next);
+ make_fixnum (limit));
+ *stop = XFIXNUM (next);
return buf;
}
@@ -7688,20 +7689,20 @@ consume_chars (struct coding_system *coding, Lisp_Object translation_table,
lookup_buf_end = lookup_buf + i;
trans = get_translation (trans, lookup_buf, lookup_buf_end,
&from_nchars);
- if (INTEGERP (trans))
- c = XINT (trans);
+ if (FIXNUMP (trans))
+ c = XFIXNUM (trans);
else if (VECTORP (trans))
{
to_nchars = ASIZE (trans);
if (buf_end - buf < to_nchars)
break;
- c = XINT (AREF (trans, 0));
+ c = XFIXNUM (AREF (trans, 0));
}
else
break;
*buf++ = c;
for (i = 1; i < to_nchars; i++)
- *buf++ = XINT (AREF (trans, i));
+ *buf++ = XFIXNUM (AREF (trans, i));
for (i = 1; i < from_nchars; i++, pos++)
src += MULTIBYTE_LENGTH_NO_CHECK (src);
}
@@ -7784,7 +7785,7 @@ encode_coding (struct coding_system *coding)
/* Name (or base name) of work buffer for code conversion. */
-static Lisp_Object Vcode_conversion_workbuf_name;
+Lisp_Object Vcode_conversion_workbuf_name;
/* A working buffer used by the top level conversion. Once it is
created, it is never destroyed. It has the name
@@ -7796,43 +7797,6 @@ static Lisp_Object Vcode_conversion_reused_workbuf;
/* True iff Vcode_conversion_reused_workbuf is already in use. */
static bool reused_workbuf_in_use;
-
-/* Return a working buffer of code conversion. MULTIBYTE specifies the
- multibyteness of returning buffer. */
-
-static Lisp_Object
-make_conversion_work_buffer (bool multibyte)
-{
- Lisp_Object name, workbuf;
- struct buffer *current;
-
- if (reused_workbuf_in_use)
- {
- name = Fgenerate_new_buffer_name (Vcode_conversion_workbuf_name, Qnil);
- workbuf = Fget_buffer_create (name);
- }
- else
- {
- reused_workbuf_in_use = 1;
- if (NILP (Fbuffer_live_p (Vcode_conversion_reused_workbuf)))
- Vcode_conversion_reused_workbuf
- = Fget_buffer_create (Vcode_conversion_workbuf_name);
- workbuf = Vcode_conversion_reused_workbuf;
- }
- current = current_buffer;
- set_buffer_internal (XBUFFER (workbuf));
- /* We can't allow modification hooks to run in the work buffer. For
- instance, directory_files_internal assumes that file decoding
- doesn't compile new regexps. */
- Fset (Fmake_local_variable (Qinhibit_modification_hooks), Qt);
- Ferase_buffer ();
- bset_undo_list (current_buffer, Qt);
- bset_enable_multibyte_characters (current_buffer, multibyte ? Qt : Qnil);
- set_buffer_internal (current);
- return workbuf;
-}
-
-
static void
code_conversion_restore (Lisp_Object arg)
{
@@ -7856,9 +7820,39 @@ code_conversion_save (bool with_work_buf, bool multibyte)
Lisp_Object workbuf = Qnil;
if (with_work_buf)
- workbuf = make_conversion_work_buffer (multibyte);
+ {
+ if (reused_workbuf_in_use)
+ {
+ Lisp_Object name
+ = Fgenerate_new_buffer_name (Vcode_conversion_workbuf_name, Qnil);
+ workbuf = Fget_buffer_create (name);
+ }
+ else
+ {
+ if (NILP (Fbuffer_live_p (Vcode_conversion_reused_workbuf)))
+ Vcode_conversion_reused_workbuf
+ = Fget_buffer_create (Vcode_conversion_workbuf_name);
+ workbuf = Vcode_conversion_reused_workbuf;
+ }
+ }
record_unwind_protect (code_conversion_restore,
Fcons (Fcurrent_buffer (), workbuf));
+ if (!NILP (workbuf))
+ {
+ struct buffer *current = current_buffer;
+ set_buffer_internal (XBUFFER (workbuf));
+ /* We can't allow modification hooks to run in the work buffer. For
+ instance, directory_files_internal assumes that file decoding
+ doesn't compile new regexps. */
+ Fset (Fmake_local_variable (Qinhibit_modification_hooks), Qt);
+ Ferase_buffer ();
+ bset_undo_list (current_buffer, Qt);
+ bset_enable_multibyte_characters (current_buffer, multibyte ? Qt : Qnil);
+ if (EQ (workbuf, Vcode_conversion_reused_workbuf))
+ reused_workbuf_in_use = 1;
+ set_buffer_internal (current);
+ }
+
return workbuf;
}
@@ -7984,18 +7978,16 @@ decode_coding_gap (struct coding_system *coding,
ptrdiff_t prev_Z = Z, prev_Z_BYTE = Z_BYTE;
Lisp_Object val;
Lisp_Object undo_list = BVAR (current_buffer, undo_list);
- ptrdiff_t count1 = SPECPDL_INDEX ();
record_unwind_protect (coding_restore_undo_list,
Fcons (undo_list, Fcurrent_buffer ()));
bset_undo_list (current_buffer, Qt);
TEMP_SET_PT_BOTH (coding->dst_pos, coding->dst_pos_byte);
val = call1 (CODING_ATTR_POST_READ (attrs),
- make_number (coding->produced_char));
- CHECK_NATNUM (val);
+ make_fixnum (coding->produced_char));
+ CHECK_FIXNAT (val);
coding->produced_char += Z - prev_Z;
coding->produced += Z_BYTE - prev_Z_BYTE;
- unbind_to (count1, Qnil);
}
unbind_to (count, Qnil);
@@ -8144,8 +8136,8 @@ decode_coding_object (struct coding_system *coding,
bset_undo_list (current_buffer, Qt);
TEMP_SET_PT_BOTH (coding->dst_pos, coding->dst_pos_byte);
val = safe_call1 (CODING_ATTR_POST_READ (attrs),
- make_number (coding->produced_char));
- CHECK_NATNUM (val);
+ make_fixnum (coding->produced_char));
+ CHECK_FIXNAT (val);
coding->produced_char += Z - prev_Z;
coding->produced += Z_BYTE - prev_Z_BYTE;
unbind_to (count1, Qnil);
@@ -8274,7 +8266,7 @@ encode_coding_object (struct coding_system *coding,
}
safe_call2 (CODING_ATTR_PRE_WRITE (attrs),
- make_number (BEG), make_number (Z));
+ make_fixnum (BEG), make_fixnum (Z));
if (XBUFFER (coding->src_object) != current_buffer)
kill_src_buffer = 1;
coding->src_object = Fcurrent_buffer ();
@@ -8440,7 +8432,7 @@ from_unicode (Lisp_Object str)
if (!STRING_MULTIBYTE (str) &&
SBYTES (str) & 1)
{
- str = Fsubstring (str, make_number (0), make_number (-1));
+ str = Fsubstring (str, make_fixnum (0), make_fixnum (-1));
}
return code_convert_string_norecord (str, Qutf_16le, 0);
@@ -8449,7 +8441,7 @@ from_unicode (Lisp_Object str)
Lisp_Object
from_unicode_buffer (const wchar_t *wstr)
{
- /* We get one of the two final null bytes for free. */
+ /* We get one of the two final NUL bytes for free. */
ptrdiff_t len = 1 + sizeof (wchar_t) * wcslen (wstr);
AUTO_STRING_WITH_LEN (str, (char *) wstr, len);
return from_unicode (str);
@@ -8462,7 +8454,7 @@ to_unicode (Lisp_Object str, Lisp_Object *buf)
/* We need to make another copy (in addition to the one made by
code_convert_string_norecord) to ensure that the final string is
_doubly_ zero terminated --- that is, that the string is
- terminated by two zero bytes and one utf-16le null character.
+ terminated by two zero bytes and one utf-16le NUL character.
Because strings are already terminated with a single zero byte,
we just add one additional zero. */
str = make_uninit_string (SBYTES (*buf) + 1);
@@ -8475,7 +8467,6 @@ to_unicode (Lisp_Object str, Lisp_Object *buf)
#endif /* WINDOWSNT || CYGWIN */
-#ifdef emacs
/*** 8. Emacs Lisp library functions ***/
DEFUN ("coding-system-p", Fcoding_system_p, Scoding_system_p, 1, 1, 0,
@@ -8524,7 +8515,7 @@ are lower-case). */)
val = Fcompleting_read (prompt, Vcoding_system_alist, Qnil,
Qt, Qnil, Qcoding_system_history,
default_coding_system, Qnil);
- unbind_to (count, Qnil);
+ val = unbind_to (count, val);
return (SCHARS (val) == 0 ? Qnil : Fintern (val, Qnil));
}
@@ -8579,7 +8570,7 @@ detect_coding_system (const unsigned char *src,
ptrdiff_t id;
struct coding_detection_info detect_info;
enum coding_category base_category;
- bool null_byte_found = 0, eight_bit_found = 0;
+ bool nul_byte_found = 0, eight_bit_found = 0;
if (NILP (coding_system))
coding_system = Qundecided;
@@ -8599,14 +8590,14 @@ detect_coding_system (const unsigned char *src,
detect_info.checked = detect_info.found = detect_info.rejected = 0;
/* At first, detect text-format if necessary. */
- base_category = XINT (CODING_ATTR_CATEGORY (attrs));
+ base_category = XFIXNUM (CODING_ATTR_CATEGORY (attrs));
if (base_category == coding_category_undecided)
{
enum coding_category category UNINIT;
struct coding_system *this UNINIT;
int c, i;
bool inhibit_nbd = inhibit_flag (coding.spec.undecided.inhibit_nbd,
- inhibit_null_byte_detection);
+ inhibit_nul_byte_detection);
bool inhibit_ied = inhibit_flag (coding.spec.undecided.inhibit_ied,
inhibit_iso_escape_detection);
bool prefer_utf_8 = coding.spec.undecided.prefer_utf_8;
@@ -8618,7 +8609,7 @@ detect_coding_system (const unsigned char *src,
if (c & 0x80)
{
eight_bit_found = 1;
- if (null_byte_found)
+ if (nul_byte_found)
break;
}
else if (c < 0x20)
@@ -8633,7 +8624,7 @@ detect_coding_system (const unsigned char *src,
if (! (detect_info.rejected & CATEGORY_MASK_ISO_7_ELSE))
{
/* We didn't find an 8-bit code. We may
- have found a null-byte, but it's very
+ have found a NUL-byte, but it's very
rare that a binary file confirm to
ISO-2022. */
src = src_end;
@@ -8645,7 +8636,7 @@ detect_coding_system (const unsigned char *src,
}
else if (! c && !inhibit_nbd)
{
- null_byte_found = 1;
+ nul_byte_found = 1;
if (eight_bit_found)
break;
}
@@ -8656,7 +8647,7 @@ detect_coding_system (const unsigned char *src,
coding.head_ascii++;
}
- if (null_byte_found || eight_bit_found
+ if (nul_byte_found || eight_bit_found
|| coding.head_ascii < coding.src_bytes
|| detect_info.found)
{
@@ -8671,7 +8662,7 @@ detect_coding_system (const unsigned char *src,
}
else
{
- if (null_byte_found)
+ if (nul_byte_found)
{
detect_info.checked |= ~CATEGORY_MASK_UTF_16;
detect_info.rejected |= ~CATEGORY_MASK_UTF_16;
@@ -8718,24 +8709,24 @@ detect_coding_system (const unsigned char *src,
}
if ((detect_info.rejected & CATEGORY_MASK_ANY) == CATEGORY_MASK_ANY
- || null_byte_found)
+ || nul_byte_found)
{
detect_info.found = CATEGORY_MASK_RAW_TEXT;
id = CODING_SYSTEM_ID (Qno_conversion);
- val = list1 (make_number (id));
+ val = list1i (id);
}
else if (! detect_info.rejected && ! detect_info.found)
{
detect_info.found = CATEGORY_MASK_ANY;
id = coding_categories[coding_category_undecided].id;
- val = list1 (make_number (id));
+ val = list1i (id);
}
else if (highest)
{
if (detect_info.found)
{
detect_info.found = 1 << category;
- val = list1 (make_number (this->id));
+ val = list1i (this->id);
}
else
for (i = 0; i < coding_category_raw_text; i++)
@@ -8743,7 +8734,7 @@ detect_coding_system (const unsigned char *src,
{
detect_info.found = 1 << coding_priorities[i];
id = coding_categories[coding_priorities[i]].id;
- val = list1 (make_number (id));
+ val = list1i (id);
break;
}
}
@@ -8760,7 +8751,7 @@ detect_coding_system (const unsigned char *src,
found |= 1 << category;
id = coding_categories[category].id;
if (id >= 0)
- val = list1 (make_number (id));
+ val = list1i (id);
}
}
for (i = coding_category_raw_text - 1; i >= 0; i--)
@@ -8769,7 +8760,7 @@ detect_coding_system (const unsigned char *src,
if (detect_info.found & (1 << category))
{
id = coding_categories[category].id;
- val = Fcons (make_number (id), val);
+ val = Fcons (make_fixnum (id), val);
}
}
detect_info.found |= found;
@@ -8785,7 +8776,7 @@ detect_coding_system (const unsigned char *src,
this = coding_categories + coding_category_utf_8_sig;
else
this = coding_categories + coding_category_utf_8_nosig;
- val = list1 (make_number (this->id));
+ val = list1i (this->id);
}
}
else if (base_category == coding_category_utf_16_auto)
@@ -8802,13 +8793,13 @@ detect_coding_system (const unsigned char *src,
this = coding_categories + coding_category_utf_16_be_nosig;
else
this = coding_categories + coding_category_utf_16_le_nosig;
- val = list1 (make_number (this->id));
+ val = list1i (this->id);
}
}
else
{
- detect_info.found = 1 << XINT (CODING_ATTR_CATEGORY (attrs));
- val = list1 (make_number (coding.id));
+ detect_info.found = 1 << XFIXNUM (CODING_ATTR_CATEGORY (attrs));
+ val = list1i (coding.id);
}
/* Then, detect eol-format if necessary. */
@@ -8820,7 +8811,7 @@ detect_coding_system (const unsigned char *src,
{
if (detect_info.found & ~CATEGORY_MASK_UTF_16)
{
- if (null_byte_found)
+ if (nul_byte_found)
normal_eol = EOL_SEEN_LF;
else
normal_eol = detect_eol (coding.source, src_bytes,
@@ -8850,9 +8841,9 @@ detect_coding_system (const unsigned char *src,
enum coding_category category;
int this_eol;
- id = XINT (XCAR (tail));
+ id = XFIXNUM (XCAR (tail));
attrs = CODING_ID_ATTRS (id);
- category = XINT (CODING_ATTR_CATEGORY (attrs));
+ category = XFIXNUM (CODING_ATTR_CATEGORY (attrs));
eol_type = CODING_ID_EOL_TYPE (id);
if (VECTORP (eol_type))
{
@@ -8903,7 +8894,7 @@ highest priority. */)
ptrdiff_t from_byte, to_byte;
validate_region (&start, &end);
- from = XINT (start), to = XINT (end);
+ from = XFIXNUM (start), to = XFIXNUM (end);
from_byte = CHAR_TO_BYTE (from);
to_byte = CHAR_TO_BYTE (to);
@@ -8956,7 +8947,7 @@ char_encodable_p (int c, Lisp_Object attrs)
for (tail = CODING_ATTR_CHARSET_LIST (attrs);
CONSP (tail); tail = XCDR (tail))
{
- charset = CHARSET_FROM_ID (XINT (XCAR (tail)));
+ charset = CHARSET_FROM_ID (XFIXNUM (XCAR (tail)));
if (CHAR_CHARSET_P (c, charset))
break;
}
@@ -8992,23 +8983,23 @@ DEFUN ("find-coding-systems-region-internal",
}
else
{
- CHECK_NUMBER_COERCE_MARKER (start);
- CHECK_NUMBER_COERCE_MARKER (end);
- if (XINT (start) < BEG || XINT (end) > Z || XINT (start) > XINT (end))
+ CHECK_FIXNUM_COERCE_MARKER (start);
+ CHECK_FIXNUM_COERCE_MARKER (end);
+ if (XFIXNUM (start) < BEG || XFIXNUM (end) > Z || XFIXNUM (start) > XFIXNUM (end))
args_out_of_range (start, end);
if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
return Qt;
- start_byte = CHAR_TO_BYTE (XINT (start));
- end_byte = CHAR_TO_BYTE (XINT (end));
- if (XINT (end) - XINT (start) == end_byte - start_byte)
+ start_byte = CHAR_TO_BYTE (XFIXNUM (start));
+ end_byte = CHAR_TO_BYTE (XFIXNUM (end));
+ if (XFIXNUM (end) - XFIXNUM (start) == end_byte - start_byte)
return Qt;
- if (XINT (start) < GPT && XINT (end) > GPT)
+ if (XFIXNUM (start) < GPT && XFIXNUM (end) > GPT)
{
- if ((GPT - XINT (start)) < (XINT (end) - GPT))
- move_gap_both (XINT (start), start_byte);
+ if ((GPT - XFIXNUM (start)) < (XFIXNUM (end) - GPT))
+ move_gap_both (XFIXNUM (start), start_byte);
else
- move_gap_both (XINT (end), end_byte);
+ move_gap_both (XFIXNUM (end), end_byte);
}
}
@@ -9127,8 +9118,8 @@ to the string and treated as in `substring'. */)
if (NILP (string))
{
validate_region (&start, &end);
- from = XINT (start);
- to = XINT (end);
+ from = XFIXNUM (start);
+ to = XFIXNUM (end);
if (NILP (BVAR (current_buffer, enable_multibyte_characters))
|| (ascii_compatible
&& (to - from) == (CHAR_TO_BYTE (to) - (CHAR_TO_BYTE (from)))))
@@ -9156,8 +9147,8 @@ to the string and treated as in `substring'. */)
n = 1;
else
{
- CHECK_NATNUM (count);
- n = XINT (count);
+ CHECK_FIXNAT (count);
+ n = XFIXNUM (count);
}
positions = Qnil;
@@ -9182,7 +9173,7 @@ to the string and treated as in `substring'. */)
&& ! char_charset (translate_char (translation_table, c),
charset_list, NULL))
{
- positions = Fcons (make_number (from), positions);
+ positions = Fcons (make_fixnum (from), positions);
n--;
if (n == 0)
break;
@@ -9246,25 +9237,25 @@ is nil. */)
}
else
{
- CHECK_NUMBER_COERCE_MARKER (start);
- CHECK_NUMBER_COERCE_MARKER (end);
- if (XINT (start) < BEG || XINT (end) > Z || XINT (start) > XINT (end))
+ CHECK_FIXNUM_COERCE_MARKER (start);
+ CHECK_FIXNUM_COERCE_MARKER (end);
+ if (XFIXNUM (start) < BEG || XFIXNUM (end) > Z || XFIXNUM (start) > XFIXNUM (end))
args_out_of_range (start, end);
if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
return Qnil;
- start_byte = CHAR_TO_BYTE (XINT (start));
- end_byte = CHAR_TO_BYTE (XINT (end));
- if (XINT (end) - XINT (start) == end_byte - start_byte)
+ start_byte = CHAR_TO_BYTE (XFIXNUM (start));
+ end_byte = CHAR_TO_BYTE (XFIXNUM (end));
+ if (XFIXNUM (end) - XFIXNUM (start) == end_byte - start_byte)
return Qnil;
- if (XINT (start) < GPT && XINT (end) > GPT)
+ if (XFIXNUM (start) < GPT && XFIXNUM (end) > GPT)
{
- if ((GPT - XINT (start)) < (XINT (end) - GPT))
- move_gap_both (XINT (start), start_byte);
+ if ((GPT - XFIXNUM (start)) < (XFIXNUM (end) - GPT))
+ move_gap_both (XFIXNUM (start), start_byte);
else
- move_gap_both (XINT (end), end_byte);
+ move_gap_both (XFIXNUM (end), end_byte);
}
- pos = XINT (start);
+ pos = XFIXNUM (start);
}
list = Qnil;
@@ -9299,7 +9290,7 @@ is nil. */)
{
elt = XCDR (XCAR (tail));
if (! char_encodable_p (c, XCAR (elt)))
- XSETCDR (elt, Fcons (make_number (pos), XCDR (elt)));
+ XSETCDR (elt, Fcons (make_fixnum (pos), XCDR (elt)));
}
if (charset_map_loaded)
{
@@ -9350,9 +9341,9 @@ code_convert_region (Lisp_Object start, Lisp_Object end,
CHECK_BUFFER (dst_object);
validate_region (&start, &end);
- from = XFASTINT (start);
+ from = XFIXNAT (start);
from_byte = CHAR_TO_BYTE (from);
- to = XFASTINT (end);
+ to = XFIXNAT (end);
to_byte = CHAR_TO_BYTE (to);
setup_coding_system (coding_system, &coding);
@@ -9376,7 +9367,7 @@ code_convert_region (Lisp_Object start, Lisp_Object end,
Vlast_coding_system_used = CODING_ID_NAME (coding.id);
return (BUFFERP (dst_object)
- ? make_number (coding.produced_char)
+ ? make_fixnum (coding.produced_char)
: coding.dst_object);
}
@@ -9472,7 +9463,7 @@ code_convert_string (Lisp_Object string, Lisp_Object coding_system,
Vlast_coding_system_used = CODING_ID_NAME (coding.id);
return (BUFFERP (dst_object)
- ? make_number (coding.produced_char)
+ ? make_fixnum (coding.produced_char)
: coding.dst_object);
}
@@ -9591,8 +9582,8 @@ Return the corresponding character. */)
EMACS_INT ch;
int c;
- CHECK_NATNUM (code);
- ch = XFASTINT (code);
+ CHECK_FIXNAT (code);
+ ch = XFIXNAT (code);
CHECK_CODING_SYSTEM_GET_SPEC (Vsjis_coding_system, spec);
attrs = AREF (spec, 0);
@@ -9601,9 +9592,9 @@ Return the corresponding character. */)
return code;
val = CODING_ATTR_CHARSET_LIST (attrs);
- charset_roman = CHARSET_FROM_ID (XINT (XCAR (val))), val = XCDR (val);
- charset_kana = CHARSET_FROM_ID (XINT (XCAR (val))), val = XCDR (val);
- charset_kanji = CHARSET_FROM_ID (XINT (XCAR (val)));
+ charset_roman = CHARSET_FROM_ID (XFIXNUM (XCAR (val))), val = XCDR (val);
+ charset_kana = CHARSET_FROM_ID (XFIXNUM (XCAR (val))), val = XCDR (val);
+ charset_kanji = CHARSET_FROM_ID (XFIXNUM (XCAR (val)));
if (ch <= 0x7F)
{
@@ -9630,7 +9621,7 @@ Return the corresponding character. */)
c = DECODE_CHAR (charset, c);
if (c < 0)
error ("Invalid code: %"pI"d", ch);
- return make_number (c);
+ return make_fixnum (c);
}
@@ -9645,7 +9636,7 @@ Return the corresponding code in SJIS. */)
unsigned code;
CHECK_CHARACTER (ch);
- c = XFASTINT (ch);
+ c = XFIXNAT (ch);
CHECK_CODING_SYSTEM_GET_SPEC (Vsjis_coding_system, spec);
attrs = AREF (spec, 0);
@@ -9659,7 +9650,7 @@ Return the corresponding code in SJIS. */)
error ("Can't encode by shift_jis encoding: %c", c);
JIS_TO_SJIS (code);
- return make_number (code);
+ return make_fixnum (code);
}
DEFUN ("decode-big5-char", Fdecode_big5_char, Sdecode_big5_char, 1, 1, 0,
@@ -9672,8 +9663,8 @@ Return the corresponding character. */)
EMACS_INT ch;
int c;
- CHECK_NATNUM (code);
- ch = XFASTINT (code);
+ CHECK_FIXNAT (code);
+ ch = XFIXNAT (code);
CHECK_CODING_SYSTEM_GET_SPEC (Vbig5_coding_system, spec);
attrs = AREF (spec, 0);
@@ -9682,8 +9673,8 @@ Return the corresponding character. */)
return code;
val = CODING_ATTR_CHARSET_LIST (attrs);
- charset_roman = CHARSET_FROM_ID (XINT (XCAR (val))), val = XCDR (val);
- charset_big5 = CHARSET_FROM_ID (XINT (XCAR (val)));
+ charset_roman = CHARSET_FROM_ID (XFIXNUM (XCAR (val))), val = XCDR (val);
+ charset_big5 = CHARSET_FROM_ID (XFIXNUM (XCAR (val)));
if (ch <= 0x7F)
{
@@ -9703,7 +9694,7 @@ Return the corresponding character. */)
c = DECODE_CHAR (charset, c);
if (c < 0)
error ("Invalid code: %"pI"d", ch);
- return make_number (c);
+ return make_fixnum (c);
}
DEFUN ("encode-big5-char", Fencode_big5_char, Sencode_big5_char, 1, 1, 0,
@@ -9717,7 +9708,7 @@ Return the corresponding character code in Big5. */)
unsigned code;
CHECK_CHARACTER (ch);
- c = XFASTINT (ch);
+ c = XFIXNAT (ch);
CHECK_CODING_SYSTEM_GET_SPEC (Vbig5_coding_system, spec);
attrs = AREF (spec, 0);
if (ASCII_CHAR_P (c)
@@ -9729,7 +9720,7 @@ Return the corresponding character code in Big5. */)
if (code == CHARSET_INVALID_CODE (charset))
error ("Can't encode by Big5 encoding: %c", c);
- return make_number (code);
+ return make_fixnum (code);
}
@@ -9751,7 +9742,7 @@ DEFUN ("set-terminal-coding-system-internal", Fset_terminal_coding_system_intern
tset_charset_list
(term, (terminal_coding->common_flags & CODING_REQUIRE_ENCODING_MASK
? coding_charset_list (terminal_coding)
- : list1 (make_number (charset_ascii))));
+ : list1i (charset_ascii)));
return Qnil;
}
@@ -9864,19 +9855,19 @@ usage: (find-operation-coding-system OPERATION ARGUMENTS...) */)
error ("Too few arguments");
operation = args[0];
if (!SYMBOLP (operation)
- || (target_idx = Fget (operation, Qtarget_idx), !NATNUMP (target_idx)))
+ || (target_idx = Fget (operation, Qtarget_idx), !FIXNATP (target_idx)))
error ("Invalid first argument");
- if (nargs <= 1 + XFASTINT (target_idx))
+ if (nargs <= 1 + XFIXNAT (target_idx))
error ("Too few arguments for operation `%s'",
SDATA (SYMBOL_NAME (operation)));
- target = args[XFASTINT (target_idx) + 1];
+ target = args[XFIXNAT (target_idx) + 1];
if (!(STRINGP (target)
|| (EQ (operation, Qinsert_file_contents) && CONSP (target)
&& STRINGP (XCAR (target)) && BUFFERP (XCDR (target)))
|| (EQ (operation, Qopen_network_stream)
- && (INTEGERP (target) || EQ (target, Qt)))))
+ && (FIXNUMP (target) || EQ (target, Qt)))))
error ("Invalid argument %"pI"d of operation `%s'",
- XFASTINT (target_idx) + 1, SDATA (SYMBOL_NAME (operation)));
+ XFIXNAT (target_idx) + 1, SDATA (SYMBOL_NAME (operation)));
if (CONSP (target))
target = XCAR (target);
@@ -9898,7 +9889,7 @@ usage: (find-operation-coding-system OPERATION ARGUMENTS...) */)
&& ((STRINGP (target)
&& STRINGP (XCAR (elt))
&& fast_string_match (XCAR (elt), target) >= 0)
- || (INTEGERP (target) && EQ (target, XCAR (elt)))))
+ || (FIXNUMP (target) && EQ (target, XCAR (elt)))))
{
val = XCDR (elt);
/* Here, if VAL is both a valid coding system and a valid
@@ -9948,7 +9939,7 @@ usage: (set-coding-system-priority &rest coding-systems) */)
CHECK_CODING_SYSTEM_GET_SPEC (args[i], spec);
attrs = AREF (spec, 0);
- category = XINT (CODING_ATTR_CATEGORY (attrs));
+ category = XFIXNUM (CODING_ATTR_CATEGORY (attrs));
if (changed[category])
/* Ignore this coding system because a coding system of the
same category already had a higher priority. */
@@ -10043,36 +10034,28 @@ DEFUN ("define-coding-system-internal", Fdefine_coding_system_internal,
usage: (define-coding-system-internal ...) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- Lisp_Object name;
- Lisp_Object spec_vec; /* [ ATTRS ALIASE EOL_TYPE ] */
- Lisp_Object attrs; /* Vector of attributes. */
- Lisp_Object eol_type;
- Lisp_Object aliases;
- Lisp_Object coding_type, charset_list, safe_charsets;
enum coding_category category;
- Lisp_Object tail, val;
int max_charset_id = 0;
- int i;
if (nargs < coding_arg_max)
goto short_args;
- attrs = Fmake_vector (make_number (coding_attr_last_index), Qnil);
+ Lisp_Object attrs = make_nil_vector (coding_attr_last_index);
- name = args[coding_arg_name];
+ Lisp_Object name = args[coding_arg_name];
CHECK_SYMBOL (name);
ASET (attrs, coding_attr_base_name, name);
- val = args[coding_arg_mnemonic];
+ Lisp_Object val = args[coding_arg_mnemonic];
if (! STRINGP (val))
CHECK_CHARACTER (val);
ASET (attrs, coding_attr_mnemonic, val);
- coding_type = args[coding_arg_coding_type];
+ Lisp_Object coding_type = args[coding_arg_coding_type];
CHECK_SYMBOL (coding_type);
ASET (attrs, coding_attr_type, coding_type);
- charset_list = args[coding_arg_charset_list];
+ Lisp_Object charset_list = args[coding_arg_charset_list];
if (SYMBOLP (charset_list))
{
if (EQ (charset_list, Qiso_2022))
@@ -10087,18 +10070,18 @@ usage: (define-coding-system-internal ...) */)
error ("Invalid charset-list");
charset_list = Vemacs_mule_charset_list;
}
- for (tail = charset_list; CONSP (tail); tail = XCDR (tail))
+ for (Lisp_Object tail = charset_list; CONSP (tail); tail = XCDR (tail))
{
- if (! RANGED_INTEGERP (0, XCAR (tail), INT_MAX - 1))
+ if (! RANGED_FIXNUMP (0, XCAR (tail), INT_MAX - 1))
error ("Invalid charset-list");
- if (max_charset_id < XFASTINT (XCAR (tail)))
- max_charset_id = XFASTINT (XCAR (tail));
+ if (max_charset_id < XFIXNAT (XCAR (tail)))
+ max_charset_id = XFIXNAT (XCAR (tail));
}
}
else
{
charset_list = Fcopy_sequence (charset_list);
- for (tail = charset_list; CONSP (tail); tail = XCDR (tail))
+ for (Lisp_Object tail = charset_list; CONSP (tail); tail = XCDR (tail))
{
struct charset *charset;
@@ -10112,17 +10095,17 @@ usage: (define-coding-system-internal ...) */)
error ("Can't handle charset `%s'",
SDATA (SYMBOL_NAME (CHARSET_NAME (charset))));
- XSETCAR (tail, make_number (charset->id));
+ XSETCAR (tail, make_fixnum (charset->id));
if (max_charset_id < charset->id)
max_charset_id = charset->id;
}
}
ASET (attrs, coding_attr_charset_list, charset_list);
- safe_charsets = make_uninit_string (max_charset_id + 1);
+ Lisp_Object safe_charsets = make_uninit_string (max_charset_id + 1);
memset (SDATA (safe_charsets), 255, max_charset_id + 1);
- for (tail = charset_list; CONSP (tail); tail = XCDR (tail))
- SSET (safe_charsets, XFASTINT (XCAR (tail)), 0);
+ for (Lisp_Object tail = charset_list; CONSP (tail); tail = XCDR (tail))
+ SSET (safe_charsets, XFIXNAT (XCAR (tail)), 0);
ASET (attrs, coding_attr_safe_charsets, safe_charsets);
ASET (attrs, coding_attr_ascii_compat, args[coding_arg_ascii_compatible_p]);
@@ -10147,7 +10130,7 @@ usage: (define-coding-system-internal ...) */)
val = args[coding_arg_default_char];
if (NILP (val))
- ASET (attrs, coding_attr_default_char, make_number (' '));
+ ASET (attrs, coding_attr_default_char, make_fixnum (' '));
else
{
CHECK_CHARACTER (val);
@@ -10175,18 +10158,18 @@ usage: (define-coding-system-internal ...) */)
If Nth element is a list of charset IDs, N is the first byte
of one of them. The list is sorted by dimensions of the
charsets. A charset of smaller dimension comes first. */
- val = Fmake_vector (make_number (256), Qnil);
+ val = make_nil_vector (256);
- for (tail = charset_list; CONSP (tail); tail = XCDR (tail))
+ for (Lisp_Object tail = charset_list; CONSP (tail); tail = XCDR (tail))
{
- struct charset *charset = CHARSET_FROM_ID (XFASTINT (XCAR (tail)));
+ struct charset *charset = CHARSET_FROM_ID (XFIXNAT (XCAR (tail)));
int dim = CHARSET_DIMENSION (charset);
int idx = (dim - 1) * 4;
if (CHARSET_ASCII_COMPATIBLE_P (charset))
ASET (attrs, coding_attr_ascii_compat, Qt);
- for (i = charset->code_space[idx];
+ for (int i = charset->code_space[idx];
i <= charset->code_space[idx + 1]; i++)
{
Lisp_Object tmp, tmp2;
@@ -10195,9 +10178,9 @@ usage: (define-coding-system-internal ...) */)
tmp = AREF (val, i);
if (NILP (tmp))
tmp = XCAR (tail);
- else if (NUMBERP (tmp))
+ else if (FIXNATP (tmp))
{
- dim2 = CHARSET_DIMENSION (CHARSET_FROM_ID (XFASTINT (tmp)));
+ dim2 = CHARSET_DIMENSION (CHARSET_FROM_ID (XFIXNAT (tmp)));
if (dim < dim2)
tmp = list2 (XCAR (tail), tmp);
else
@@ -10207,7 +10190,7 @@ usage: (define-coding-system-internal ...) */)
{
for (tmp2 = tmp; CONSP (tmp2); tmp2 = XCDR (tmp2))
{
- dim2 = CHARSET_DIMENSION (CHARSET_FROM_ID (XFASTINT (XCAR (tmp2))));
+ dim2 = CHARSET_DIMENSION (CHARSET_FROM_ID (XFIXNAT (XCAR (tmp2))));
if (dim < dim2)
break;
}
@@ -10245,33 +10228,27 @@ usage: (define-coding-system-internal ...) */)
ASET (attrs, coding_attr_ccl_encoder, val);
val = args[coding_arg_ccl_valids];
- valids = Fmake_string (make_number (256), make_number (0));
- for (tail = val; CONSP (tail); tail = XCDR (tail))
+ valids = Fmake_string (make_fixnum (256), make_fixnum (0), Qnil);
+ for (Lisp_Object tail = val; CONSP (tail); tail = XCDR (tail))
{
int from, to;
val = XCAR (tail);
- if (INTEGERP (val))
+ if (FIXNUMP (val))
{
- if (! (0 <= XINT (val) && XINT (val) <= 255))
- args_out_of_range_3 (val, make_number (0), make_number (255));
- from = to = XINT (val);
+ if (! (0 <= XFIXNUM (val) && XFIXNUM (val) <= 255))
+ args_out_of_range_3 (val, make_fixnum (0), make_fixnum (255));
+ from = to = XFIXNUM (val);
}
else
{
CHECK_CONS (val);
- CHECK_NATNUM_CAR (val);
- CHECK_NUMBER_CDR (val);
- if (XINT (XCAR (val)) > 255)
- args_out_of_range_3 (XCAR (val),
- make_number (0), make_number (255));
- from = XINT (XCAR (val));
- if (! (from <= XINT (XCDR (val)) && XINT (XCDR (val)) <= 255))
- args_out_of_range_3 (XCDR (val),
- XCAR (val), make_number (255));
- to = XINT (XCDR (val));
+ CHECK_RANGED_INTEGER (XCAR (val), 0, 255);
+ from = XFIXNUM (XCAR (val));
+ CHECK_RANGED_INTEGER (XCDR (val), from, 255);
+ to = XFIXNUM (XCDR (val));
}
- for (i = from; i <= to; i++)
+ for (int i = from; i <= to; i++)
SSET (valids, i, 1);
}
ASET (attrs, coding_attr_ccl_valids, valids);
@@ -10325,7 +10302,7 @@ usage: (define-coding-system-internal ...) */)
initial = Fcopy_sequence (args[coding_arg_iso2022_initial]);
CHECK_VECTOR (initial);
- for (i = 0; i < 4; i++)
+ for (int i = 0; i < 4; i++)
{
val = AREF (initial, i);
if (! NILP (val))
@@ -10333,41 +10310,37 @@ usage: (define-coding-system-internal ...) */)
struct charset *charset;
CHECK_CHARSET_GET_CHARSET (val, charset);
- ASET (initial, i, make_number (CHARSET_ID (charset)));
+ ASET (initial, i, make_fixnum (CHARSET_ID (charset)));
if (i == 0 && CHARSET_ASCII_COMPATIBLE_P (charset))
ASET (attrs, coding_attr_ascii_compat, Qt);
}
else
- ASET (initial, i, make_number (-1));
+ ASET (initial, i, make_fixnum (-1));
}
reg_usage = args[coding_arg_iso2022_reg_usage];
CHECK_CONS (reg_usage);
- CHECK_NUMBER_CAR (reg_usage);
- CHECK_NUMBER_CDR (reg_usage);
+ CHECK_FIXNUM (XCAR (reg_usage));
+ CHECK_FIXNUM (XCDR (reg_usage));
request = Fcopy_sequence (args[coding_arg_iso2022_request]);
- for (tail = request; CONSP (tail); tail = XCDR (tail))
+ for (Lisp_Object tail = request; CONSP (tail); tail = XCDR (tail))
{
int id;
- Lisp_Object tmp1;
val = XCAR (tail);
CHECK_CONS (val);
- tmp1 = XCAR (val);
- CHECK_CHARSET_GET_ID (tmp1, id);
- CHECK_NATNUM_CDR (val);
- if (XINT (XCDR (val)) >= 4)
- error ("Invalid graphic register number: %"pI"d", XINT (XCDR (val)));
- XSETCAR (val, make_number (id));
+ CHECK_CHARSET_GET_ID (XCAR (val), id);
+ CHECK_RANGED_INTEGER (XCDR (val), 0, 3);
+ XSETCAR (val, make_fixnum (id));
}
flags = args[coding_arg_iso2022_flags];
- CHECK_NATNUM (flags);
- i = XINT (flags) & INT_MAX;
+ CHECK_FIXNAT (flags);
+ int i = XFIXNUM (flags) & INT_MAX;
if (EQ (args[coding_arg_charset_list], Qiso_2022))
i |= CODING_ISO_FLAG_FULL_SUPPORT;
- flags = make_number (i);
+ flags = make_fixnum (i);
ASET (attrs, coding_attr_iso_initial, initial);
ASET (attrs, coding_attr_iso_usage, reg_usage);
@@ -10384,7 +10357,7 @@ usage: (define-coding-system-internal ...) */)
: coding_category_iso_7_tight);
else
{
- int id = XINT (AREF (initial, 1));
+ int id = XFIXNUM (AREF (initial, 1));
category = (((i & CODING_ISO_FLAG_LOCKING_SHIFT)
|| EQ (args[coding_arg_charset_list], Qiso_2022)
@@ -10407,14 +10380,11 @@ usage: (define-coding-system-internal ...) */)
}
else if (EQ (coding_type, Qshift_jis))
{
-
- struct charset *charset;
-
- if (XINT (Flength (charset_list)) != 3
- && XINT (Flength (charset_list)) != 4)
+ ptrdiff_t charset_list_len = list_length (charset_list);
+ if (charset_list_len != 3 && charset_list_len != 4)
error ("There should be three or four charsets");
- charset = CHARSET_FROM_ID (XINT (XCAR (charset_list)));
+ struct charset *charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list)));
if (CHARSET_DIMENSION (charset) != 1)
error ("Dimension of charset %s is not one",
SDATA (SYMBOL_NAME (CHARSET_NAME (charset))));
@@ -10422,13 +10392,13 @@ usage: (define-coding-system-internal ...) */)
ASET (attrs, coding_attr_ascii_compat, Qt);
charset_list = XCDR (charset_list);
- charset = CHARSET_FROM_ID (XINT (XCAR (charset_list)));
+ charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list)));
if (CHARSET_DIMENSION (charset) != 1)
error ("Dimension of charset %s is not one",
SDATA (SYMBOL_NAME (CHARSET_NAME (charset))));
charset_list = XCDR (charset_list);
- charset = CHARSET_FROM_ID (XINT (XCAR (charset_list)));
+ charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list)));
if (CHARSET_DIMENSION (charset) != 2)
error ("Dimension of charset %s is not two",
SDATA (SYMBOL_NAME (CHARSET_NAME (charset))));
@@ -10436,7 +10406,7 @@ usage: (define-coding-system-internal ...) */)
charset_list = XCDR (charset_list);
if (! NILP (charset_list))
{
- charset = CHARSET_FROM_ID (XINT (XCAR (charset_list)));
+ charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list)));
if (CHARSET_DIMENSION (charset) != 2)
error ("Dimension of charset %s is not two",
SDATA (SYMBOL_NAME (CHARSET_NAME (charset))));
@@ -10449,10 +10419,10 @@ usage: (define-coding-system-internal ...) */)
{
struct charset *charset;
- if (XINT (Flength (charset_list)) != 2)
+ if (list_length (charset_list) != 2)
error ("There should be just two charsets");
- charset = CHARSET_FROM_ID (XINT (XCAR (charset_list)));
+ charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list)));
if (CHARSET_DIMENSION (charset) != 1)
error ("Dimension of charset %s is not one",
SDATA (SYMBOL_NAME (CHARSET_NAME (charset))));
@@ -10460,7 +10430,7 @@ usage: (define-coding-system-internal ...) */)
ASET (attrs, coding_attr_ascii_compat, Qt);
charset_list = XCDR (charset_list);
- charset = CHARSET_FROM_ID (XINT (XCAR (charset_list)));
+ charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list)));
if (CHARSET_DIMENSION (charset) != 2)
error ("Dimension of charset %s is not two",
SDATA (SYMBOL_NAME (CHARSET_NAME (charset))));
@@ -10501,8 +10471,8 @@ usage: (define-coding-system-internal ...) */)
{
if (nargs < coding_arg_undecided_max)
goto short_args;
- ASET (attrs, coding_attr_undecided_inhibit_null_byte_detection,
- args[coding_arg_undecided_inhibit_null_byte_detection]);
+ ASET (attrs, coding_attr_undecided_inhibit_nul_byte_detection,
+ args[coding_arg_undecided_inhibit_nul_byte_detection]);
ASET (attrs, coding_attr_undecided_inhibit_iso_escape_detection,
args[coding_arg_undecided_inhibit_iso_escape_detection]);
ASET (attrs, coding_attr_undecided_prefer_utf_8,
@@ -10513,7 +10483,7 @@ usage: (define-coding-system-internal ...) */)
error ("Invalid coding system type: %s",
SDATA (SYMBOL_NAME (coding_type)));
- ASET (attrs, coding_attr_category, make_number (category));
+ ASET (attrs, coding_attr_category, make_fixnum (category));
ASET (attrs, coding_attr_plist,
Fcons (QCcategory,
Fcons (AREF (Vcoding_category_table, category),
@@ -10523,19 +10493,19 @@ usage: (define-coding-system-internal ...) */)
Fcons (CODING_ATTR_ASCII_COMPAT (attrs),
CODING_ATTR_PLIST (attrs))));
- eol_type = args[coding_arg_eol_type];
+ Lisp_Object eol_type = args[coding_arg_eol_type];
if (! NILP (eol_type)
&& ! EQ (eol_type, Qunix)
&& ! EQ (eol_type, Qdos)
&& ! EQ (eol_type, Qmac))
error ("Invalid eol-type");
- aliases = list1 (name);
+ Lisp_Object aliases = list1 (name);
if (NILP (eol_type))
{
eol_type = make_subsidiaries (name);
- for (i = 0; i < 3; i++)
+ for (int i = 0; i < 3; i++)
{
Lisp_Object this_spec, this_name, this_aliases, this_eol_type;
@@ -10556,7 +10526,7 @@ usage: (define-coding-system-internal ...) */)
}
}
- spec_vec = make_uninit_vector (3);
+ Lisp_Object spec_vec = make_uninit_vector (3);
ASET (spec_vec, 0, attrs);
ASET (spec_vec, 1, aliases);
ASET (spec_vec, 2, eol_type);
@@ -10568,19 +10538,16 @@ usage: (define-coding-system-internal ...) */)
Vcoding_system_alist = Fcons (Fcons (Fsymbol_name (name), Qnil),
Vcoding_system_alist);
- {
- int id = coding_categories[category].id;
-
- if (id < 0 || EQ (name, CODING_ID_NAME (id)))
+ int id = coding_categories[category].id;
+ if (id < 0 || EQ (name, CODING_ID_NAME (id)))
setup_coding_system (name, &coding_categories[category]);
- }
return Qnil;
short_args:
Fsignal (Qwrong_number_of_arguments,
Fcons (intern ("define-coding-system-internal"),
- make_number (nargs)));
+ make_fixnum (nargs)));
}
@@ -10602,7 +10569,7 @@ DEFUN ("coding-system-put", Fcoding_system_put, Scoding_system_put,
else if (EQ (prop, QCdefault_char))
{
if (NILP (val))
- val = make_number (' ');
+ val = make_fixnum (' ');
else
CHECK_CHARACTER (val);
ASET (attrs, coding_attr_default_char, val);
@@ -10747,11 +10714,9 @@ coding system whose eol-type is N. */)
if (VECTORP (eol_type))
return Fcopy_sequence (eol_type);
n = EQ (eol_type, Qunix) ? 0 : EQ (eol_type, Qdos) ? 1 : 2;
- return make_number (n);
+ return make_fixnum (n);
}
-#endif /* emacs */
-
/*** 9. Post-amble ***/
@@ -10766,6 +10731,9 @@ init_coding_once (void)
coding_priorities[i] = i;
}
+ PDUMPER_REMEMBER_SCALAR (coding_categories);
+ PDUMPER_REMEMBER_SCALAR (coding_priorities);
+
/* ISO2022 specific initialize routine. */
for (i = 0; i < 0x20; i++)
iso_code_class[i] = ISO_control_0;
@@ -10785,6 +10753,8 @@ init_coding_once (void)
iso_code_class[ISO_CODE_SS3] = ISO_single_shift_3;
iso_code_class[ISO_CODE_CSI] = ISO_control_sequence_introducer;
+ PDUMPER_REMEMBER_SCALAR (iso_code_class);
+
for (i = 0; i < 256; i++)
{
emacs_mule_bytes[i] = 1;
@@ -10793,9 +10763,11 @@ init_coding_once (void)
emacs_mule_bytes[EMACS_MULE_LEADING_CODE_PRIVATE_12] = 3;
emacs_mule_bytes[EMACS_MULE_LEADING_CODE_PRIVATE_21] = 4;
emacs_mule_bytes[EMACS_MULE_LEADING_CODE_PRIVATE_22] = 4;
+
+ PDUMPER_REMEMBER_SCALAR (emacs_mule_bytes);
}
-#ifdef emacs
+static void reset_coding_after_pdumper_load (void);
void
syms_of_coding (void)
@@ -10816,6 +10788,7 @@ syms_of_coding (void)
Vcode_conversion_workbuf_name = build_pure_c_string (" *code-conversion-work*");
reused_workbuf_in_use = 0;
+ PDUMPER_REMEMBER_SCALAR (reused_workbuf_in_use);
DEFSYM (Qcharset, "charset");
DEFSYM (Qtarget_idx, "target-idx");
@@ -10823,25 +10796,25 @@ syms_of_coding (void)
Fset (Qcoding_system_history, Qnil);
/* Target FILENAME is the first argument. */
- Fput (Qinsert_file_contents, Qtarget_idx, make_number (0));
+ Fput (Qinsert_file_contents, Qtarget_idx, make_fixnum (0));
/* Target FILENAME is the third argument. */
- Fput (Qwrite_region, Qtarget_idx, make_number (2));
+ Fput (Qwrite_region, Qtarget_idx, make_fixnum (2));
DEFSYM (Qcall_process, "call-process");
/* Target PROGRAM is the first argument. */
- Fput (Qcall_process, Qtarget_idx, make_number (0));
+ Fput (Qcall_process, Qtarget_idx, make_fixnum (0));
DEFSYM (Qcall_process_region, "call-process-region");
/* Target PROGRAM is the third argument. */
- Fput (Qcall_process_region, Qtarget_idx, make_number (2));
+ Fput (Qcall_process_region, Qtarget_idx, make_fixnum (2));
DEFSYM (Qstart_process, "start-process");
/* Target PROGRAM is the third argument. */
- Fput (Qstart_process, Qtarget_idx, make_number (2));
+ Fput (Qstart_process, Qtarget_idx, make_fixnum (2));
DEFSYM (Qopen_network_stream, "open-network-stream");
/* Target SERVICE is the fourth argument. */
- Fput (Qopen_network_stream, Qtarget_idx, make_number (3));
+ Fput (Qopen_network_stream, Qtarget_idx, make_fixnum (3));
DEFSYM (Qunix, "unix");
DEFSYM (Qdos, "dos");
@@ -10851,10 +10824,12 @@ syms_of_coding (void)
DEFSYM (Qundecided, "undecided");
DEFSYM (Qno_conversion, "no-conversion");
DEFSYM (Qraw_text, "raw-text");
+ DEFSYM (Qus_ascii, "us-ascii");
DEFSYM (Qiso_2022, "iso-2022");
DEFSYM (Qutf_8, "utf-8");
+ DEFSYM (Qutf_8_unix, "utf-8-unix");
DEFSYM (Qutf_8_emacs, "utf-8-emacs");
#if defined (WINDOWSNT) || defined (CYGWIN)
@@ -10874,12 +10849,12 @@ syms_of_coding (void)
/* Error signaled when there's a problem with detecting a coding system. */
DEFSYM (Qcoding_system_error, "coding-system-error");
Fput (Qcoding_system_error, Qerror_conditions,
- listn (CONSTYPE_PURE, 2, Qcoding_system_error, Qerror));
+ pure_list (Qcoding_system_error, Qerror));
Fput (Qcoding_system_error, Qerror_message,
build_pure_c_string ("Invalid coding system"));
DEFSYM (Qtranslation_table, "translation-table");
- Fput (Qtranslation_table, Qchar_table_extra_slots, make_number (2));
+ Fput (Qtranslation_table, Qchar_table_extra_slots, make_fixnum (2));
DEFSYM (Qtranslation_table_id, "translation-table-id");
/* Coding system emacs-mule and raw-text are for converting only
@@ -10895,8 +10870,7 @@ syms_of_coding (void)
DEFSYM (QCpre_write_conversion, ":pre-write-conversion");
DEFSYM (QCascii_compatible_p, ":ascii-compatible-p");
- Vcoding_category_table
- = Fmake_vector (make_number (coding_category_max), Qnil);
+ Vcoding_category_table = make_nil_vector (coding_category_max);
staticpro (&Vcoding_category_table);
/* Followings are target of code detection. */
ASET (Vcoding_category_table, coding_category_iso_7,
@@ -11200,7 +11174,7 @@ a coding system of ISO 2022 variant which has a flag
`accept-latin-extra-code' t (e.g. iso-latin-1) on reading a file
or reading output of a subprocess.
Only 128th through 159th elements have a meaning. */);
- Vlatin_extra_code_table = Fmake_vector (make_number (256), Qnil);
+ Vlatin_extra_code_table = make_nil_vector (256);
DEFVAR_LISP ("select-safe-coding-system-function",
Vselect_safe_coding_system_function,
@@ -11253,18 +11227,18 @@ to explicitly specify some coding system that doesn't use ISO-2022
escape sequence (e.g., `latin-1') on reading by \\[universal-coding-system-argument]. */);
inhibit_iso_escape_detection = 0;
- DEFVAR_BOOL ("inhibit-null-byte-detection",
- inhibit_null_byte_detection,
- doc: /* If non-nil, Emacs ignores null bytes on code detection.
+ DEFVAR_BOOL ("inhibit-nul-byte-detection",
+ inhibit_nul_byte_detection,
+ doc: /* If non-nil, Emacs ignores NUL bytes on code detection.
By default, Emacs treats it as binary data, and does not attempt to
decode it. The effect is as if you specified `no-conversion' for
reading that text.
-Set this to non-nil when a regular text happens to include null bytes.
-Examples are Index nodes of Info files and null-byte delimited output
-from GNU Find and GNU Grep. Emacs will then ignore the null bytes and
+Set this to non-nil when a regular text happens to include NUL bytes.
+Examples are Index nodes of Info files and NUL-byte delimited output
+from GNU Find and GNU Grep. Emacs will then ignore the NUL bytes and
decode text as usual. */);
- inhibit_null_byte_detection = 0;
+ inhibit_nul_byte_detection = 0;
DEFVAR_BOOL ("disable-ascii-optimization", disable_ascii_optimization,
doc: /* If non-nil, Emacs does not optimize code decoder for ASCII files.
@@ -11289,13 +11263,13 @@ internal character representation. */);
QCname,
args[coding_arg_name] = Qno_conversion,
QCmnemonic,
- args[coding_arg_mnemonic] = make_number ('='),
+ args[coding_arg_mnemonic] = make_fixnum ('='),
intern_c_string (":coding-type"),
args[coding_arg_coding_type] = Qraw_text,
QCascii_compatible_p,
args[coding_arg_ascii_compatible_p] = Qt,
QCdefault_char,
- args[coding_arg_default_char] = make_number (0),
+ args[coding_arg_default_char] = make_fixnum (0),
intern_c_string (":for-unibyte"),
args[coding_arg_for_unibyte] = Qt,
intern_c_string (":docstring"),
@@ -11312,19 +11286,19 @@ internal character representation. */);
Fdefine_coding_system_internal (coding_arg_max, args);
plist[1] = args[coding_arg_name] = Qundecided;
- plist[3] = args[coding_arg_mnemonic] = make_number ('-');
+ plist[3] = args[coding_arg_mnemonic] = make_fixnum ('-');
plist[5] = args[coding_arg_coding_type] = Qundecided;
/* This is already set.
plist[7] = args[coding_arg_ascii_compatible_p] = Qt; */
plist[8] = intern_c_string (":charset-list");
- plist[9] = args[coding_arg_charset_list] = Fcons (Qascii, Qnil);
+ plist[9] = args[coding_arg_charset_list] = list1 (Qascii);
plist[11] = args[coding_arg_for_unibyte] = Qnil;
plist[13] = build_pure_c_string ("No conversion on encoding, "
"automatic conversion on decoding.");
plist[15] = args[coding_arg_eol_type] = Qnil;
args[coding_arg_plist] = CALLMANY (Flist, plist);
- args[coding_arg_undecided_inhibit_null_byte_detection] = make_number (0);
- args[coding_arg_undecided_inhibit_iso_escape_detection] = make_number (0);
+ args[coding_arg_undecided_inhibit_nul_byte_detection] = make_fixnum (0);
+ args[coding_arg_undecided_inhibit_iso_escape_detection] = make_fixnum (0);
Fdefine_coding_system_internal (coding_arg_undecided_max, args);
setup_coding_system (Qno_conversion, &safe_terminal_coding);
@@ -11338,5 +11312,32 @@ internal character representation. */);
system_eol_type = Qunix;
#endif
staticpro (&system_eol_type);
+
+ pdumper_do_now_and_after_load (reset_coding_after_pdumper_load);
+}
+
+static void
+reset_coding_after_pdumper_load (void)
+{
+ if (!dumped_with_pdumper_p ())
+ return;
+ for (struct coding_system *this = &coding_categories[0];
+ this < &coding_categories[coding_category_max];
+ ++this)
+ {
+ int id = this->id;
+ if (id >= 0)
+ {
+ /* Need to rebuild the coding system object because we
+ persisted it as a scalar and it's full of gunk that's now
+ invalid. */
+ memset (this, 0, sizeof (*this));
+ setup_coding_system (CODING_ID_NAME (id), this);
+ }
+ }
+ /* In temacs the below is done by mule-conf.el, because we need to
+ define us-ascii first. But in dumped Emacs us-ascii is restored
+ by the above loop, and mule-conf.el will not be loaded, so we set
+ it up now; otherwise safe_terminal_coding will remain zeroed. */
+ Fset_safe_terminal_coding_system_internal (Qus_ascii);
}
-#endif /* emacs */
diff --git a/src/coding.h b/src/coding.h
index aab8c2d4380..0c03d1a44ed 100644
--- a/src/coding.h
+++ b/src/coding.h
@@ -82,7 +82,7 @@ enum define_coding_ccl_arg_index
enum define_coding_undecided_arg_index
{
- coding_arg_undecided_inhibit_null_byte_detection = coding_arg_max,
+ coding_arg_undecided_inhibit_nul_byte_detection = coding_arg_max,
coding_arg_undecided_inhibit_iso_escape_detection,
coding_arg_undecided_prefer_utf_8,
coding_arg_undecided_max
@@ -97,6 +97,8 @@ enum define_coding_undecided_arg_index
extern Lisp_Object Vcoding_system_hash_table;
+/* Name (or base name) of work buffer for code conversion. */
+extern Lisp_Object Vcode_conversion_workbuf_name;
/* Enumeration of index to an attribute vector of a coding system. */
@@ -137,7 +139,7 @@ enum coding_attr_index
coding_attr_emacs_mule_full,
- coding_attr_undecided_inhibit_null_byte_detection,
+ coding_attr_undecided_inhibit_nul_byte_detection,
coding_attr_undecided_inhibit_iso_escape_detection,
coding_attr_undecided_prefer_utf_8,
@@ -351,7 +353,7 @@ struct emacs_mule_spec
struct undecided_spec
{
- /* Inhibit null byte detection. 1 means always inhibit,
+ /* Inhibit NUL byte detection. 1 means always inhibit,
-1 means do not inhibit, 0 means rely on user variable. */
int inhibit_nbd;
@@ -676,21 +678,10 @@ struct coding_system
#define UTF_16_LOW_SURROGATE_P(val) \
(((val) & 0xFC00) == 0xDC00)
-/* Return the Unicode code point for the given UTF-16 surrogates. */
-
-INLINE int
-surrogates_to_codepoint (int low, int high)
-{
- eassert (0 <= low && low <= 0xFFFF);
- eassert (0 <= high && high <= 0xFFFF);
- eassert (UTF_16_LOW_SURROGATE_P (low));
- eassert (UTF_16_HIGH_SURROGATE_P (high));
- return 0x10000 + (low - 0xDC00) + ((high - 0xD800) * 0x400);
-}
-
/* Extern declarations. */
extern Lisp_Object code_conversion_save (bool, bool);
extern bool encode_coding_utf_8 (struct coding_system *);
+extern bool utf8_string_p (Lisp_Object);
extern void setup_coding_system (Lisp_Object, struct coding_system *);
extern Lisp_Object coding_charset_list (struct coding_system *);
extern Lisp_Object coding_system_charset_list (Lisp_Object);
@@ -713,6 +704,8 @@ extern void decode_coding_object (struct coding_system *,
extern void encode_coding_object (struct coding_system *,
Lisp_Object, ptrdiff_t, ptrdiff_t,
ptrdiff_t, ptrdiff_t, Lisp_Object);
+/* Defined in this file. */
+INLINE int surrogates_to_codepoint (int, int);
#if defined (WINDOWSNT) || defined (CYGWIN)
@@ -757,17 +750,24 @@ extern Lisp_Object from_unicode_buffer (const wchar_t *wstr);
} while (false)
-extern Lisp_Object preferred_coding_system (void);
+/* Return the Unicode code point for the given UTF-16 surrogates. */
+INLINE int
+surrogates_to_codepoint (int low, int high)
+{
+ eassert (0 <= low && low <= 0xFFFF);
+ eassert (0 <= high && high <= 0xFFFF);
+ eassert (UTF_16_LOW_SURROGATE_P (low));
+ eassert (UTF_16_HIGH_SURROGATE_P (high));
+ return 0x10000 + (low - 0xDC00) + ((high - 0xD800) * 0x400);
+}
-#ifdef emacs
+extern Lisp_Object preferred_coding_system (void);
/* Coding system to be used to encode text for terminal display when
terminal coding system is nil. */
extern struct coding_system safe_terminal_coding;
-#endif
-
extern char emacs_mule_bytes[256];
INLINE_HEADER_END
diff --git a/src/composite.c b/src/composite.c
index ec533a6969b..88f1235f116 100644
--- a/src/composite.c
+++ b/src/composite.c
@@ -193,12 +193,12 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars,
goto invalid_composition;
id = XCAR (prop);
- if (INTEGERP (id))
+ if (FIXNUMP (id))
{
/* PROP should be Form-B. */
- if (XINT (id) < 0 || XINT (id) >= n_compositions)
+ if (XFIXNUM (id) < 0 || XFIXNUM (id) >= n_compositions)
goto invalid_composition;
- return XINT (id);
+ return XFIXNUM (id);
}
/* PROP should be Form-A.
@@ -206,7 +206,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars,
if (!CONSP (id))
goto invalid_composition;
length = XCAR (id);
- if (!INTEGERP (length) || XINT (length) != nchars)
+ if (!FIXNUMP (length) || XFIXNUM (length) != nchars)
goto invalid_composition;
components = XCDR (id);
@@ -215,8 +215,8 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars,
by consulting composition_hash_table. The key for this table is
COMPONENTS (converted to a vector COMPONENTS-VEC) or, if it is
nil, vector of characters in the composition range. */
- if (INTEGERP (components))
- key = Fmake_vector (make_number (1), components);
+ if (FIXNUMP (components))
+ key = make_vector (1, components);
else if (STRINGP (components) || CONSP (components))
key = Fvconcat (1, &components);
else if (VECTORP (components))
@@ -228,13 +228,13 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars,
for (i = 0; i < nchars; i++)
{
FETCH_STRING_CHAR_ADVANCE (ch, string, charpos, bytepos);
- ASET (key, i, make_number (ch));
+ ASET (key, i, make_fixnum (ch));
}
else
for (i = 0; i < nchars; i++)
{
FETCH_CHAR_ADVANCE (ch, charpos, bytepos);
- ASET (key, i, make_number (ch));
+ ASET (key, i, make_fixnum (ch));
}
}
else
@@ -250,8 +250,8 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars,
key = HASH_KEY (hash_table, hash_index);
id = HASH_VALUE (hash_table, hash_index);
XSETCAR (prop, id);
- XSETCDR (prop, Fcons (make_number (nchars), Fcons (key, XCDR (prop))));
- return XINT (id);
+ XSETCDR (prop, Fcons (make_fixnum (nchars), Fcons (key, XCDR (prop))));
+ return XFIXNUM (id);
}
/* This composition is a new one. We must register it. */
@@ -289,7 +289,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars,
composition rule). */
for (i = 0; i < len; i++)
{
- if (!INTEGERP (key_contents[i]))
+ if (!FIXNUMP (key_contents[i]))
goto invalid_composition;
}
}
@@ -298,14 +298,14 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars,
the cons cell of PROP because it is not shared. */
XSETFASTINT (id, n_compositions);
XSETCAR (prop, id);
- XSETCDR (prop, Fcons (make_number (nchars), Fcons (key, XCDR (prop))));
+ XSETCDR (prop, Fcons (make_fixnum (nchars), Fcons (key, XCDR (prop))));
/* Register the composition in composition_hash_table. */
hash_index = hash_put (hash_table, key, id, hash_code);
method = (NILP (components)
? COMPOSITION_RELATIVE
- : ((INTEGERP (components) || STRINGP (components))
+ : ((FIXNUMP (components) || STRINGP (components))
? COMPOSITION_WITH_ALTCHARS
: COMPOSITION_WITH_RULE_ALTCHARS));
@@ -332,7 +332,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars,
for (i = 0; i < glyph_len; i++)
{
int this_width;
- ch = XINT (key_contents[i]);
+ ch = XFIXNUM (key_contents[i]);
/* TAB in a composition means display glyphs with padding
space on the left or right. */
this_width = (ch == '\t' ? 1 : CHARACTER_WIDTH (ch));
@@ -345,7 +345,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars,
/* Rule-base composition. */
double leftmost = 0.0, rightmost;
- ch = XINT (key_contents[0]);
+ ch = XFIXNUM (key_contents[0]);
rightmost = ch != '\t' ? CHARACTER_WIDTH (ch) : 1;
for (i = 1; i < glyph_len; i += 2)
@@ -354,8 +354,8 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars,
int this_width;
double this_left;
- rule = XINT (key_contents[i]);
- ch = XINT (key_contents[i + 1]);
+ rule = XFIXNUM (key_contents[i]);
+ ch = XFIXNUM (key_contents[i + 1]);
this_width = ch != '\t' ? CHARACTER_WIDTH (ch) : 1;
/* A composition rule is specified by an integer value
@@ -431,9 +431,9 @@ find_composition (ptrdiff_t pos, ptrdiff_t limit,
if (limit > pos) /* search forward */
{
- val = Fnext_single_property_change (make_number (pos), Qcomposition,
- object, make_number (limit));
- pos = XINT (val);
+ val = Fnext_single_property_change (make_fixnum (pos), Qcomposition,
+ object, make_fixnum (limit));
+ pos = XFIXNUM (val);
if (pos == limit)
return 0;
}
@@ -442,9 +442,9 @@ find_composition (ptrdiff_t pos, ptrdiff_t limit,
if (get_property_and_range (pos - 1, Qcomposition, prop, start, end,
object))
return 1;
- val = Fprevious_single_property_change (make_number (pos), Qcomposition,
- object, make_number (limit));
- pos = XINT (val);
+ val = Fprevious_single_property_change (make_fixnum (pos), Qcomposition,
+ object, make_fixnum (limit));
+ pos = XFIXNUM (val);
if (pos == limit)
return 0;
pos--;
@@ -474,7 +474,7 @@ run_composition_function (ptrdiff_t from, ptrdiff_t to, Lisp_Object prop)
&& !composition_valid_p (start, end, prop))
to = end;
if (!NILP (Ffboundp (func)))
- call2 (func, make_number (from), make_number (to));
+ call2 (func, make_fixnum (from), make_fixnum (to));
}
/* Make invalid compositions adjacent to or inside FROM and TO valid.
@@ -519,7 +519,7 @@ update_compositions (ptrdiff_t from, ptrdiff_t to, int check_mask)
if (end > to)
max_pos = end;
if (from < end)
- Fput_text_property (make_number (from), make_number (end),
+ Fput_text_property (make_fixnum (from), make_fixnum (end),
Qcomposition,
Fcons (XCAR (prop), XCDR (prop)), Qnil);
run_composition_function (start, end, prop);
@@ -560,7 +560,7 @@ update_compositions (ptrdiff_t from, ptrdiff_t to, int check_mask)
the former to the copy of it. */
if (to < end)
{
- Fput_text_property (make_number (start), make_number (to),
+ Fput_text_property (make_fixnum (start), make_fixnum (to),
Qcomposition,
Fcons (XCAR (prop), XCDR (prop)), Qnil);
max_pos = end;
@@ -582,8 +582,8 @@ update_compositions (ptrdiff_t from, ptrdiff_t to, int check_mask)
specbind (Qinhibit_read_only, Qt);
specbind (Qinhibit_modification_hooks, Qt);
specbind (Qinhibit_point_motion_hooks, Qt);
- Fremove_list_of_text_properties (make_number (min_pos),
- make_number (max_pos),
+ Fremove_list_of_text_properties (make_fixnum (min_pos),
+ make_fixnum (max_pos),
list1 (Qauto_composed), Qnil);
unbind_to (count, Qnil);
}
@@ -625,9 +625,9 @@ compose_text (ptrdiff_t start, ptrdiff_t end, Lisp_Object components,
{
Lisp_Object prop;
- prop = Fcons (Fcons (make_number (end - start), components),
+ prop = Fcons (Fcons (make_fixnum (end - start), components),
modification_func);
- Fput_text_property (make_number (start), make_number (end),
+ Fput_text_property (make_fixnum (start), make_fixnum (end),
Qcomposition, prop, string);
}
@@ -654,27 +654,23 @@ Lisp_Object
composition_gstring_put_cache (Lisp_Object gstring, ptrdiff_t len)
{
struct Lisp_Hash_Table *h = XHASH_TABLE (gstring_hash_table);
- EMACS_UINT hash;
- Lisp_Object header, copy;
- ptrdiff_t i;
-
- header = LGSTRING_HEADER (gstring);
- hash = h->test.hashfn (&h->test, header);
+ hash_rehash_if_needed (h);
+ Lisp_Object header = LGSTRING_HEADER (gstring);
+ EMACS_UINT hash = h->test.hashfn (&h->test, header);
if (len < 0)
{
- ptrdiff_t j, glyph_len = LGSTRING_GLYPH_LEN (gstring);
- for (j = 0; j < glyph_len; j++)
- if (NILP (LGSTRING_GLYPH (gstring, j)))
+ ptrdiff_t glyph_len = LGSTRING_GLYPH_LEN (gstring);
+ for (len = 0; len < glyph_len; len++)
+ if (NILP (LGSTRING_GLYPH (gstring, len)))
break;
- len = j;
}
- copy = Fmake_vector (make_number (len + 2), Qnil);
+ Lisp_Object copy = make_nil_vector (len + 2);
LGSTRING_SET_HEADER (copy, Fcopy_sequence (header));
- for (i = 0; i < len; i++)
+ for (ptrdiff_t i = 0; i < len; i++)
LGSTRING_SET_GLYPH (copy, i, Fcopy_sequence (LGSTRING_GLYPH (gstring, i)));
- i = hash_put (h, LGSTRING_HEADER (copy), copy, hash);
- LGSTRING_SET_ID (copy, make_number (i));
+ ptrdiff_t id = hash_put (h, LGSTRING_HEADER (copy), copy, hash);
+ LGSTRING_SET_ID (copy, make_fixnum (id));
return copy;
}
@@ -692,7 +688,7 @@ DEFUN ("clear-composition-cache", Fclear_composition_cache,
Clear composition cache. */)
(void)
{
- Lisp_Object args[] = {QCtest, Qequal, QCsize, make_number (311)};
+ Lisp_Object args[] = {QCtest, Qequal, QCsize, make_fixnum (311)};
gstring_hash_table = CALLMANY (Fmake_hash_table, args);
/* Fixme: We call Fclear_face_cache to force complete re-building of
display glyphs. But, it may be better to call this function from
@@ -716,9 +712,9 @@ composition_gstring_p (Lisp_Object gstring)
&& ! CODING_SYSTEM_P (LGSTRING_FONT (gstring))))
return 0;
for (i = 1; i < ASIZE (LGSTRING_HEADER (gstring)); i++)
- if (! NATNUMP (AREF (LGSTRING_HEADER (gstring), i)))
+ if (! FIXNATP (AREF (LGSTRING_HEADER (gstring), i)))
return 0;
- if (! NILP (LGSTRING_ID (gstring)) && ! NATNUMP (LGSTRING_ID (gstring)))
+ if (! NILP (LGSTRING_ID (gstring)) && ! FIXNATP (LGSTRING_ID (gstring)))
return 0;
for (i = 0; i < LGSTRING_GLYPH_LEN (gstring); i++)
{
@@ -791,28 +787,19 @@ static Lisp_Object gstring_work;
static Lisp_Object gstring_work_headers;
static Lisp_Object
-fill_gstring_header (Lisp_Object header, ptrdiff_t from, ptrdiff_t from_byte,
+fill_gstring_header (ptrdiff_t from, ptrdiff_t from_byte,
ptrdiff_t to, Lisp_Object font_object, Lisp_Object string)
{
- ptrdiff_t len = to - from, i;
-
+ ptrdiff_t len = to - from;
if (len == 0)
error ("Attempt to shape zero-length text");
- if (VECTORP (header))
- {
- if (ASIZE (header) != len + 1)
- args_out_of_range (header, make_number (len + 1));
- }
- else
- {
- if (len <= 8)
- header = AREF (gstring_work_headers, len - 1);
- else
- header = make_uninit_vector (len + 1);
- }
+ eassume (0 < len);
+ Lisp_Object header = (len <= 8
+ ? AREF (gstring_work_headers, len - 1)
+ : make_uninit_vector (len + 1));
ASET (header, 0, font_object);
- for (i = 0; i < len; i++)
+ for (ptrdiff_t i = 0; i < len; i++)
{
int c;
@@ -820,7 +807,7 @@ fill_gstring_header (Lisp_Object header, ptrdiff_t from, ptrdiff_t from_byte,
FETCH_CHAR_ADVANCE_NO_CHECK (c, from, from_byte);
else
FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string, from, from_byte);
- ASET (header, i + 1, make_number (c));
+ ASET (header, i + 1, make_fixnum (c));
}
return header;
}
@@ -836,7 +823,7 @@ fill_gstring_body (Lisp_Object gstring)
for (i = 0; i < len; i++)
{
Lisp_Object g = LGSTRING_GLYPH (gstring, i);
- int c = XFASTINT (AREF (header, i + 1));
+ int c = XFIXNAT (AREF (header, i + 1));
if (NILP (g))
{
@@ -852,7 +839,7 @@ fill_gstring_body (Lisp_Object gstring)
}
else
{
- int width = XFASTINT (CHAR_TABLE_REF (Vchar_width_table, c));
+ int width = XFIXNAT (CHAR_TABLE_REF (Vchar_width_table, c));
LGLYPH_SET_CODE (g, c);
LGLYPH_SET_LBEARING (g, 0);
@@ -881,7 +868,7 @@ autocmp_chars (Lisp_Object rule, ptrdiff_t charpos, ptrdiff_t bytepos,
Lisp_Object string)
{
ptrdiff_t count = SPECPDL_INDEX ();
- Lisp_Object pos = make_number (charpos);
+ Lisp_Object pos = make_fixnum (charpos);
ptrdiff_t to;
ptrdiff_t pt = PT, pt_byte = PT_BYTE;
Lisp_Object re, font_object, lgstring;
@@ -917,7 +904,7 @@ autocmp_chars (Lisp_Object rule, ptrdiff_t charpos, ptrdiff_t bytepos,
return unbind_to (count, Qnil);
}
#endif
- lgstring = Fcomposition_get_gstring (pos, make_number (to), font_object,
+ lgstring = Fcomposition_get_gstring (pos, make_fixnum (to), font_object,
string);
if (NILP (LGSTRING_ID (lgstring)))
{
@@ -926,7 +913,7 @@ autocmp_chars (Lisp_Object rule, ptrdiff_t charpos, ptrdiff_t bytepos,
record_unwind_protect (restore_point_unwind,
build_marker (current_buffer, pt, pt_byte));
lgstring = safe_call (6, Vauto_composition_function, AREF (rule, 2),
- pos, make_number (to), font_object, string);
+ pos, make_fixnum (to), font_object, string);
}
return unbind_to (count, lgstring);
}
@@ -941,7 +928,7 @@ char_composable_p (int c)
return (c > ' '
&& (c == ZERO_WIDTH_NON_JOINER || c == ZERO_WIDTH_JOINER
|| (val = CHAR_TABLE_REF (Vunicode_category_table, c),
- (INTEGERP (val) && (XINT (val) <= UNICODE_CATEGORY_So)))));
+ (FIXNUMP (val) && (XFIXNUM (val) <= UNICODE_CATEGORY_So)))));
}
/* Update cmp_it->stop_pos to the next position after CHARPOS (and
@@ -1030,11 +1017,11 @@ composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos,
{
Lisp_Object elt = XCAR (val);
if (VECTORP (elt) && ASIZE (elt) == 3
- && NATNUMP (AREF (elt, 1))
- && charpos - 1 - XFASTINT (AREF (elt, 1)) >= start)
+ && FIXNATP (AREF (elt, 1))
+ && charpos - 1 - XFIXNAT (AREF (elt, 1)) >= start)
{
cmp_it->rule_idx = ridx;
- cmp_it->lookback = XFASTINT (AREF (elt, 1));
+ cmp_it->lookback = XFIXNAT (AREF (elt, 1));
cmp_it->stop_pos = charpos - 1 - cmp_it->lookback;
cmp_it->ch = c;
return;
@@ -1081,10 +1068,10 @@ composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos,
{
Lisp_Object elt = XCAR (val);
if (VECTORP (elt) && ASIZE (elt) == 3
- && NATNUMP (AREF (elt, 1))
- && charpos - XFASTINT (AREF (elt, 1)) > endpos)
+ && FIXNATP (AREF (elt, 1))
+ && charpos - XFIXNAT (AREF (elt, 1)) > endpos)
{
- ptrdiff_t back = XFASTINT (AREF (elt, 1));
+ ptrdiff_t back = XFIXNAT (AREF (elt, 1));
ptrdiff_t cpos = charpos - back, bpos;
if (back == 0)
@@ -1221,9 +1208,9 @@ composition_reseat_it (struct composition_it *cmp_it, ptrdiff_t charpos,
{
elt = XCAR (val);
if (! VECTORP (elt) || ASIZE (elt) != 3
- || ! INTEGERP (AREF (elt, 1)))
+ || ! FIXNUMP (AREF (elt, 1)))
continue;
- if (XFASTINT (AREF (elt, 1)) != cmp_it->lookback)
+ if (XFIXNAT (AREF (elt, 1)) != cmp_it->lookback)
goto no_composition;
lgstring = autocmp_chars (elt, charpos, bytepos, endpos,
w, face, string);
@@ -1262,7 +1249,7 @@ composition_reseat_it (struct composition_it *cmp_it, ptrdiff_t charpos,
goto no_composition;
if (NILP (LGSTRING_ID (lgstring)))
lgstring = composition_gstring_put_cache (lgstring, -1);
- cmp_it->id = XINT (LGSTRING_ID (lgstring));
+ cmp_it->id = XFIXNUM (LGSTRING_ID (lgstring));
int i;
for (i = 0; i < LGSTRING_GLYPH_LEN (lgstring); i++)
if (NILP (LGSTRING_GLYPH (lgstring, i)))
@@ -1391,7 +1378,7 @@ composition_update_it (struct composition_it *cmp_it, ptrdiff_t charpos, ptrdiff
cmp_it->width = 0;
for (i = cmp_it->nchars - 1; i >= 0; i--)
{
- c = XINT (LGSTRING_CHAR (gstring, from + i));
+ c = XFIXNUM (LGSTRING_CHAR (gstring, from + i));
cmp_it->nbytes += CHAR_BYTES (c);
cmp_it->width += CHARACTER_WIDTH (c);
}
@@ -1559,9 +1546,9 @@ find_automatic_composition (ptrdiff_t pos, ptrdiff_t limit,
{
Lisp_Object elt = XCAR (val);
- if (VECTORP (elt) && ASIZE (elt) == 3 && NATNUMP (AREF (elt, 1)))
+ if (VECTORP (elt) && ASIZE (elt) == 3 && FIXNATP (AREF (elt, 1)))
{
- EMACS_INT check_pos = cur.pos - XFASTINT (AREF (elt, 1));
+ EMACS_INT check_pos = cur.pos - XFIXNAT (AREF (elt, 1));
struct position_record check;
if (check_pos < head
@@ -1739,8 +1726,8 @@ should be ignored. */)
if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
error ("Attempt to shape unibyte text");
validate_region (&from, &to);
- frompos = XFASTINT (from);
- topos = XFASTINT (to);
+ frompos = XFIXNAT (from);
+ topos = XFIXNAT (to);
frombyte = CHAR_TO_BYTE (frompos);
}
else
@@ -1752,14 +1739,14 @@ should be ignored. */)
frombyte = string_char_to_byte (string, frompos);
}
- header = fill_gstring_header (Qnil, frompos, frombyte,
+ header = fill_gstring_header (frompos, frombyte,
topos, font_object, string);
gstring = gstring_lookup_cache (header);
if (! NILP (gstring))
return gstring;
if (LGSTRING_GLYPH_LEN (gstring_work) < topos - frompos)
- gstring_work = Fmake_vector (make_number (topos - frompos + 2), Qnil);
+ gstring_work = make_nil_vector (topos - frompos + 2);
LGSTRING_SET_HEADER (gstring_work, header);
LGSTRING_SET_ID (gstring_work, Qnil);
fill_gstring_body (gstring_work);
@@ -1780,12 +1767,12 @@ for the composition. See `compose-region' for more details. */)
{
validate_region (&start, &end);
if (!NILP (components)
- && !INTEGERP (components)
+ && !FIXNUMP (components)
&& !CONSP (components)
&& !STRINGP (components))
CHECK_VECTOR (components);
- compose_text (XINT (start), XINT (end), components, modification_func, Qnil);
+ compose_text (XFIXNUM (start), XFIXNUM (end), components, modification_func, Qnil);
return Qnil;
}
@@ -1820,11 +1807,11 @@ See `find-composition' for more details. */)
ptrdiff_t start, end, from, to;
int id;
- CHECK_NUMBER_COERCE_MARKER (pos);
+ CHECK_FIXNUM_COERCE_MARKER (pos);
if (!NILP (limit))
{
- CHECK_NUMBER_COERCE_MARKER (limit);
- to = min (XINT (limit), ZV);
+ CHECK_FIXNUM_COERCE_MARKER (limit);
+ to = min (XFIXNUM (limit), ZV);
}
else
to = -1;
@@ -1832,15 +1819,15 @@ See `find-composition' for more details. */)
if (!NILP (string))
{
CHECK_STRING (string);
- if (XINT (pos) < 0 || XINT (pos) > SCHARS (string))
+ if (XFIXNUM (pos) < 0 || XFIXNUM (pos) > SCHARS (string))
args_out_of_range (string, pos);
}
else
{
- if (XINT (pos) < BEGV || XINT (pos) > ZV)
+ if (XFIXNUM (pos) < BEGV || XFIXNUM (pos) > ZV)
args_out_of_range (Fcurrent_buffer (), pos);
}
- from = XINT (pos);
+ from = XFIXNUM (pos);
if (!find_composition (from, to, &start, &end, &prop, string))
{
@@ -1848,21 +1835,21 @@ See `find-composition' for more details. */)
&& ! NILP (Vauto_composition_mode)
&& find_automatic_composition (from, to, &start, &end, &gstring,
string))
- return list3 (make_number (start), make_number (end), gstring);
+ return list3 (make_fixnum (start), make_fixnum (end), gstring);
return Qnil;
}
- if ((end <= XINT (pos) || start > XINT (pos)))
+ if ((end <= XFIXNUM (pos) || start > XFIXNUM (pos)))
{
ptrdiff_t s, e;
if (find_automatic_composition (from, to, &s, &e, &gstring, string)
- && (e <= XINT (pos) ? e > end : s < start))
- return list3 (make_number (s), make_number (e), gstring);
+ && (e <= XFIXNUM (pos) ? e > end : s < start))
+ return list3 (make_fixnum (s), make_fixnum (e), gstring);
}
if (!composition_valid_p (start, end, prop))
- return list3 (make_number (start), make_number (end), Qnil);
+ return list3 (make_fixnum (start), make_fixnum (end), Qnil);
if (NILP (detail_p))
- return list3 (make_number (start), make_number (end), Qt);
+ return list3 (make_fixnum (start), make_fixnum (end), Qt);
if (composition_registered_p (prop))
id = COMPOSITION_ID (prop);
@@ -1884,12 +1871,12 @@ See `find-composition' for more details. */)
relative_p = (method == COMPOSITION_WITH_RULE_ALTCHARS
? Qnil : Qt);
mod_func = COMPOSITION_MODIFICATION_FUNC (prop);
- tail = list4 (components, relative_p, mod_func, make_number (width));
+ tail = list4 (components, relative_p, mod_func, make_fixnum (width));
}
else
tail = Qnil;
- return Fcons (make_number (start), Fcons (make_number (end), tail));
+ return Fcons (make_fixnum (start), Fcons (make_fixnum (end), tail));
}
@@ -1906,7 +1893,7 @@ syms_of_composite (void)
created compositions are repeatedly used in an Emacs session,
and thus it's not worth to save memory in such a way. So, we
make the table not weak. */
- Lisp_Object args[] = {QCtest, Qequal, QCsize, make_number (311)};
+ Lisp_Object args[] = {QCtest, Qequal, QCsize, make_fixnum (311)};
composition_hash_table = CALLMANY (Fmake_hash_table, args);
staticpro (&composition_hash_table);
@@ -1917,9 +1904,9 @@ syms_of_composite (void)
staticpro (&gstring_work_headers);
gstring_work_headers = make_uninit_vector (8);
for (i = 0; i < 8; i++)
- ASET (gstring_work_headers, i, Fmake_vector (make_number (i + 2), Qnil));
+ ASET (gstring_work_headers, i, make_nil_vector (i + 2));
staticpro (&gstring_work);
- gstring_work = Fmake_vector (make_number (10), Qnil);
+ gstring_work = make_nil_vector (10);
/* Text property `composition' should be nonsticky by default. */
Vtext_property_default_nonsticky
diff --git a/src/composite.h b/src/composite.h
index de138225c01..86751633c27 100644
--- a/src/composite.h
+++ b/src/composite.h
@@ -59,17 +59,17 @@ enum composition_method {
INLINE bool
composition_registered_p (Lisp_Object prop)
{
- return INTEGERP (XCAR (prop));
+ return FIXNUMP (XCAR (prop));
}
/* Return ID number of the already registered composition. */
-#define COMPOSITION_ID(prop) XINT (XCAR (prop))
+#define COMPOSITION_ID(prop) XFIXNUM (XCAR (prop))
/* Return length of the composition. */
#define COMPOSITION_LENGTH(prop) \
(composition_registered_p (prop) \
- ? XINT (XCAR (XCDR (prop))) \
- : XINT (XCAR (XCAR (prop))))
+ ? XFIXNUM (XCAR (XCDR (prop))) \
+ : XFIXNUM (XCAR (XCAR (prop))))
/* Return components of the composition. */
#define COMPOSITION_COMPONENTS(prop) \
@@ -86,7 +86,7 @@ composition_registered_p (Lisp_Object prop)
/* Return the Nth glyph of composition specified by CMP. CMP is a
pointer to `struct composition'. */
#define COMPOSITION_GLYPH(cmp, n) \
- XINT (XVECTOR (XVECTOR (XHASH_TABLE (composition_hash_table) \
+ XFIXNUM (XVECTOR (XVECTOR (XHASH_TABLE (composition_hash_table) \
->key_and_value) \
->contents[cmp->hash_index * 2]) \
->contents[cmp->method == COMPOSITION_WITH_RULE_ALTCHARS \
@@ -96,7 +96,7 @@ composition_registered_p (Lisp_Object prop)
rule-base composition specified by CMP. CMP is a pointer to
`struct composition'. */
#define COMPOSITION_RULE(cmp, n) \
- XINT (XVECTOR (XVECTOR (XHASH_TABLE (composition_hash_table) \
+ XFIXNUM (XVECTOR (XVECTOR (XHASH_TABLE (composition_hash_table) \
->key_and_value) \
->contents[cmp->hash_index * 2]) \
->contents[(n) * 2 - 1])
@@ -213,7 +213,7 @@ composition_method (Lisp_Object prop)
Lisp_Object temp = XCDR (XCAR (prop));
return (NILP (temp)
? COMPOSITION_RELATIVE
- : INTEGERP (temp) || STRINGP (temp)
+ : FIXNUMP (temp) || STRINGP (temp)
? COMPOSITION_WITH_ALTCHARS
: COMPOSITION_WITH_RULE_ALTCHARS);
}
@@ -234,7 +234,7 @@ composition_valid_p (ptrdiff_t start, ptrdiff_t end, Lisp_Object prop)
&& (NILP (XCDR (XCAR (prop)))
|| STRINGP (XCDR (XCAR (prop)))
|| VECTORP (XCDR (XCAR (prop)))
- || INTEGERP (XCDR (XCAR (prop)))
+ || FIXNUMP (XCDR (XCAR (prop)))
|| CONSP (XCDR (XCAR (prop))))))
&& COMPOSITION_LENGTH (prop) == end - start);
}
@@ -274,41 +274,41 @@ enum lglyph_indices
LGLYPH_SIZE
};
-#define LGLYPH_NEW() Fmake_vector (make_number (LGLYPH_SIZE), Qnil)
-#define LGLYPH_FROM(g) XINT (AREF ((g), LGLYPH_IX_FROM))
-#define LGLYPH_TO(g) XINT (AREF ((g), LGLYPH_IX_TO))
-#define LGLYPH_CHAR(g) XINT (AREF ((g), LGLYPH_IX_CHAR))
+#define LGLYPH_NEW() make_nil_vector (LGLYPH_SIZE)
+#define LGLYPH_FROM(g) XFIXNUM (AREF ((g), LGLYPH_IX_FROM))
+#define LGLYPH_TO(g) XFIXNUM (AREF ((g), LGLYPH_IX_TO))
+#define LGLYPH_CHAR(g) XFIXNUM (AREF ((g), LGLYPH_IX_CHAR))
#define LGLYPH_CODE(g) \
(NILP (AREF ((g), LGLYPH_IX_CODE)) \
? FONT_INVALID_CODE \
: cons_to_unsigned (AREF (g, LGLYPH_IX_CODE), TYPE_MAXIMUM (unsigned)))
-#define LGLYPH_WIDTH(g) XINT (AREF ((g), LGLYPH_IX_WIDTH))
-#define LGLYPH_LBEARING(g) XINT (AREF ((g), LGLYPH_IX_LBEARING))
-#define LGLYPH_RBEARING(g) XINT (AREF ((g), LGLYPH_IX_RBEARING))
-#define LGLYPH_ASCENT(g) XINT (AREF ((g), LGLYPH_IX_ASCENT))
-#define LGLYPH_DESCENT(g) XINT (AREF ((g), LGLYPH_IX_DESCENT))
+#define LGLYPH_WIDTH(g) XFIXNUM (AREF ((g), LGLYPH_IX_WIDTH))
+#define LGLYPH_LBEARING(g) XFIXNUM (AREF ((g), LGLYPH_IX_LBEARING))
+#define LGLYPH_RBEARING(g) XFIXNUM (AREF ((g), LGLYPH_IX_RBEARING))
+#define LGLYPH_ASCENT(g) XFIXNUM (AREF ((g), LGLYPH_IX_ASCENT))
+#define LGLYPH_DESCENT(g) XFIXNUM (AREF ((g), LGLYPH_IX_DESCENT))
#define LGLYPH_ADJUSTMENT(g) AREF ((g), LGLYPH_IX_ADJUSTMENT)
-#define LGLYPH_SET_FROM(g, val) ASET ((g), LGLYPH_IX_FROM, make_number (val))
-#define LGLYPH_SET_TO(g, val) ASET ((g), LGLYPH_IX_TO, make_number (val))
-#define LGLYPH_SET_CHAR(g, val) ASET ((g), LGLYPH_IX_CHAR, make_number (val))
+#define LGLYPH_SET_FROM(g, val) ASET ((g), LGLYPH_IX_FROM, make_fixnum (val))
+#define LGLYPH_SET_TO(g, val) ASET ((g), LGLYPH_IX_TO, make_fixnum (val))
+#define LGLYPH_SET_CHAR(g, val) ASET ((g), LGLYPH_IX_CHAR, make_fixnum (val))
/* Callers must assure that VAL is not negative! */
#define LGLYPH_SET_CODE(g, val) \
ASET (g, LGLYPH_IX_CODE, \
- val == FONT_INVALID_CODE ? Qnil : INTEGER_TO_CONS (val))
+ val == FONT_INVALID_CODE ? Qnil : INT_TO_INTEGER (val))
-#define LGLYPH_SET_WIDTH(g, val) ASET ((g), LGLYPH_IX_WIDTH, make_number (val))
-#define LGLYPH_SET_LBEARING(g, val) ASET ((g), LGLYPH_IX_LBEARING, make_number (val))
-#define LGLYPH_SET_RBEARING(g, val) ASET ((g), LGLYPH_IX_RBEARING, make_number (val))
-#define LGLYPH_SET_ASCENT(g, val) ASET ((g), LGLYPH_IX_ASCENT, make_number (val))
-#define LGLYPH_SET_DESCENT(g, val) ASET ((g), LGLYPH_IX_DESCENT, make_number (val))
+#define LGLYPH_SET_WIDTH(g, val) ASET ((g), LGLYPH_IX_WIDTH, make_fixnum (val))
+#define LGLYPH_SET_LBEARING(g, val) ASET ((g), LGLYPH_IX_LBEARING, make_fixnum (val))
+#define LGLYPH_SET_RBEARING(g, val) ASET ((g), LGLYPH_IX_RBEARING, make_fixnum (val))
+#define LGLYPH_SET_ASCENT(g, val) ASET ((g), LGLYPH_IX_ASCENT, make_fixnum (val))
+#define LGLYPH_SET_DESCENT(g, val) ASET ((g), LGLYPH_IX_DESCENT, make_fixnum (val))
#define LGLYPH_SET_ADJUSTMENT(g, val) ASET ((g), LGLYPH_IX_ADJUSTMENT, (val))
#define LGLYPH_XOFF(g) (VECTORP (LGLYPH_ADJUSTMENT (g)) \
- ? XINT (AREF (LGLYPH_ADJUSTMENT (g), 0)) : 0)
+ ? XFIXNUM (AREF (LGLYPH_ADJUSTMENT (g), 0)) : 0)
#define LGLYPH_YOFF(g) (VECTORP (LGLYPH_ADJUSTMENT (g)) \
- ? XINT (AREF (LGLYPH_ADJUSTMENT (g), 1)) : 0)
+ ? XFIXNUM (AREF (LGLYPH_ADJUSTMENT (g), 1)) : 0)
#define LGLYPH_WADJUST(g) (VECTORP (LGLYPH_ADJUSTMENT (g)) \
- ? XINT (AREF (LGLYPH_ADJUSTMENT (g), 2)) : 0)
+ ? XFIXNUM (AREF (LGLYPH_ADJUSTMENT (g), 2)) : 0)
extern Lisp_Object composition_gstring_put_cache (Lisp_Object, ptrdiff_t);
extern Lisp_Object composition_gstring_from_id (ptrdiff_t);
diff --git a/src/conf_post.h b/src/conf_post.h
index 3c87d87ec26..f8254cfa9df 100644
--- a/src/conf_post.h
+++ b/src/conf_post.h
@@ -20,9 +20,16 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
/* Put the code here rather than in configure.ac using AH_BOTTOM.
This way, the code does not get processed by autoheader. For
- example, undefs here are not commented out.
+ example, undefs here are not commented out. */
- To help make dependencies clearer elsewhere, this file typically
+/* Disable 'assert' unless enabling checking. Do this early, in
+ case some misguided implementation depends on NDEBUG in some
+ include file other than assert.h. */
+#if !defined ENABLE_CHECKING && !defined NDEBUG
+# define NDEBUG
+#endif
+
+/* To help make dependencies clearer elsewhere, this file typically
does not #include other files. The exceptions are first stdbool.h
because it is unlikely to interfere with configuration and bool is
such a core part of the C language, and second ms-w32.h (DOS_NT
@@ -69,14 +76,7 @@ typedef bool bool_bf;
# define __has_attribute_externally_visible GNUC_PREREQ (4, 1, 0)
# define __has_attribute_no_address_safety_analysis false
# define __has_attribute_no_sanitize_address GNUC_PREREQ (4, 8, 0)
-#endif
-
-/* Simulate __has_builtin on compilers that lack it. It is used only
- on arguments like __builtin_assume_aligned that are handled in this
- simulation. */
-#ifndef __has_builtin
-# define __has_builtin(a) __has_builtin_##a
-# define __has_builtin___builtin_assume_aligned GNUC_PREREQ (4, 7, 0)
+# define __has_attribute_no_sanitize_undefined GNUC_PREREQ (4, 9, 0)
#endif
/* Simulate __has_feature on compilers that lack it. It is used only
@@ -92,18 +92,11 @@ typedef bool bool_bf;
# define ADDRESS_SANITIZER false
#endif
-/* Yield PTR, which must be aligned to ALIGNMENT. */
-#if ! __has_builtin (__builtin_assume_aligned)
-# define __builtin_assume_aligned(ptr, ...) ((void *) (ptr))
-#endif
-
-#ifdef DARWIN_OS
-#if defined emacs && !defined CANNOT_DUMP
-#define malloc unexec_malloc
-#define realloc unexec_realloc
-#define free unexec_free
+#if defined DARWIN_OS && defined emacs && defined HAVE_UNEXEC
+# define malloc unexec_malloc
+# define realloc unexec_realloc
+# define free unexec_free
#endif
-#endif /* DARWIN_OS */
/* If HYBRID_MALLOC is defined (e.g., on Cygwin), emacs will use
gmalloc before dumping and the system malloc after dumping.
@@ -220,7 +213,7 @@ extern void _DebPrint (const char *fmt, ...);
/* Tell regex.c to use a type compatible with Emacs. */
#define RE_TRANSLATE_TYPE Lisp_Object
#define RE_TRANSLATE(TBL, C) char_table_translate (TBL, C)
-#define RE_TRANSLATE_P(TBL) (!EQ (TBL, make_number (0)))
+#define RE_TRANSLATE_P(TBL) (!EQ (TBL, make_fixnum (0)))
#endif
/* Tell time_rz.c to use Emacs's getter and setter for TZ.
@@ -284,6 +277,7 @@ extern int emacs_setenv_TZ (char const *);
#define ATTRIBUTE_FORMAT_PRINTF(string_index, first_to_check) \
ATTRIBUTE_FORMAT ((PRINTF_ARCHETYPE, string_index, first_to_check))
+#define ARG_NONNULL _GL_ARG_NONNULL
#define ATTRIBUTE_CONST _GL_ATTRIBUTE_CONST
#define ATTRIBUTE_UNUSED _GL_UNUSED
@@ -303,8 +297,10 @@ extern int emacs_setenv_TZ (char const *);
#if 3 <= __GNUC__
# define ATTRIBUTE_MALLOC __attribute__ ((__malloc__))
+# define ATTRIBUTE_SECTION(name) __attribute__((section (name)))
#else
# define ATTRIBUTE_MALLOC
+#define ATTRIBUTE_SECTION(name)
#endif
#if __has_attribute (alloc_size)
@@ -340,12 +336,28 @@ extern int emacs_setenv_TZ (char const *);
# define ATTRIBUTE_NO_SANITIZE_ADDRESS
#endif
-/* gcc -fsanitize=address does not work with vfork in Fedora 25 x86-64.
+/* Attribute of functions whose undefined behavior should not be sanitized. */
+
+#if __has_attribute (no_sanitize_undefined)
+# define ATTRIBUTE_NO_SANITIZE_UNDEFINED __attribute__ ((no_sanitize_undefined))
+#elif __has_attribute (no_sanitize)
+# define ATTRIBUTE_NO_SANITIZE_UNDEFINED \
+ __attribute__ ((no_sanitize ("undefined")))
+#else
+# define ATTRIBUTE_NO_SANITIZE_UNDEFINED
+#endif
+
+/* gcc -fsanitize=address does not work with vfork in Fedora 28 x86-64. See:
+ https://lists.gnu.org/r/emacs-devel/2017-05/msg00464.html
For now, assume that this problem occurs on all platforms. */
#if ADDRESS_SANITIZER && !defined vfork
# define vfork fork
#endif
+#if ! (defined __FreeBSD__ || defined GNU_LINUX || defined __MINGW32__)
+# undef PROFILING
+#endif
+
/* Some versions of GNU/Linux define noinline in their headers. */
#ifdef noinline
#undef noinline
diff --git a/src/data.c b/src/data.c
index ed6dedbe243..11cd598ed85 100644
--- a/src/data.c
+++ b/src/data.c
@@ -29,6 +29,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <intprops.h>
#include "lisp.h"
+#include "bignum.h"
#include "puresize.h"
#include "character.h"
#include "buffer.h"
@@ -41,49 +42,49 @@ static void swap_in_symval_forwarding (struct Lisp_Symbol *,
struct Lisp_Buffer_Local_Value *);
static bool
-BOOLFWDP (union Lisp_Fwd *a)
+BOOLFWDP (lispfwd a)
{
return XFWDTYPE (a) == Lisp_Fwd_Bool;
}
static bool
-INTFWDP (union Lisp_Fwd *a)
+INTFWDP (lispfwd a)
{
return XFWDTYPE (a) == Lisp_Fwd_Int;
}
static bool
-KBOARD_OBJFWDP (union Lisp_Fwd *a)
+KBOARD_OBJFWDP (lispfwd a)
{
return XFWDTYPE (a) == Lisp_Fwd_Kboard_Obj;
}
static bool
-OBJFWDP (union Lisp_Fwd *a)
+OBJFWDP (lispfwd a)
{
return XFWDTYPE (a) == Lisp_Fwd_Obj;
}
-static struct Lisp_Boolfwd *
-XBOOLFWD (union Lisp_Fwd *a)
+static struct Lisp_Boolfwd const *
+XBOOLFWD (lispfwd a)
{
eassert (BOOLFWDP (a));
- return &a->u_boolfwd;
+ return a.fwdptr;
}
-static struct Lisp_Kboard_Objfwd *
-XKBOARD_OBJFWD (union Lisp_Fwd *a)
+static struct Lisp_Kboard_Objfwd const *
+XKBOARD_OBJFWD (lispfwd a)
{
eassert (KBOARD_OBJFWDP (a));
- return &a->u_kboard_objfwd;
+ return a.fwdptr;
}
-static struct Lisp_Intfwd *
-XINTFWD (union Lisp_Fwd *a)
+static struct Lisp_Intfwd const *
+XFIXNUMFWD (lispfwd a)
{
eassert (INTFWDP (a));
- return &a->u_intfwd;
+ return a.fwdptr;
}
-static struct Lisp_Objfwd *
-XOBJFWD (union Lisp_Fwd *a)
+static struct Lisp_Objfwd const *
+XOBJFWD (lispfwd a)
{
eassert (OBJFWDP (a));
- return &a->u_objfwd;
+ return a.fwdptr;
}
static void
@@ -132,13 +133,13 @@ set_blv_valcell (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
static _Noreturn void
wrong_length_argument (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
{
- Lisp_Object size1 = make_number (bool_vector_size (a1));
- Lisp_Object size2 = make_number (bool_vector_size (a2));
+ Lisp_Object size1 = make_fixnum (bool_vector_size (a1));
+ Lisp_Object size2 = make_fixnum (bool_vector_size (a2));
if (NILP (a3))
xsignal2 (Qwrong_length_argument, size1, size2);
else
xsignal3 (Qwrong_length_argument, size1, size2,
- make_number (bool_vector_size (a3)));
+ make_fixnum (bool_vector_size (a3)));
}
_Noreturn void
@@ -221,27 +222,17 @@ for example, (type-of 1) returns `integer'. */)
case Lisp_Cons:
return Qcons;
- case Lisp_Misc:
- switch (XMISCTYPE (object))
- {
- case Lisp_Misc_Marker:
- return Qmarker;
- case Lisp_Misc_Overlay:
- return Qoverlay;
- case Lisp_Misc_Finalizer:
- return Qfinalizer;
-#ifdef HAVE_MODULES
- case Lisp_Misc_User_Ptr:
- return Quser_ptr;
-#endif
- default:
- emacs_abort ();
- }
-
case Lisp_Vectorlike:
switch (PSEUDOVECTOR_TYPE (XVECTOR (object)))
{
case PVEC_NORMAL_VECTOR: return Qvector;
+ case PVEC_BIGNUM: return Qinteger;
+ case PVEC_MARKER: return Qmarker;
+ case PVEC_OVERLAY: return Qoverlay;
+ case PVEC_FINALIZER: return Qfinalizer;
+#ifdef HAVE_MODULES
+ case PVEC_USER_PTR: return Quser_ptr;
+#endif
case PVEC_WINDOW_CONFIGURATION: return Qwindow_configuration;
case PVEC_PROCESS: return Qprocess;
case PVEC_WINDOW: return Qwindow;
@@ -281,6 +272,7 @@ for example, (type-of 1) returns `integer'. */)
case PVEC_XWIDGET_VIEW:
return Qxwidget_view;
/* "Impossible" cases. */
+ case PVEC_MISC_PTR:
case PVEC_OTHER:
case PVEC_SUB_CHAR_TABLE:
case PVEC_FREE: ;
@@ -534,9 +526,9 @@ DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
attributes: const)
(Lisp_Object object)
{
- if (NATNUMP (object))
- return Qt;
- return Qnil;
+ return ((FIXNUMP (object) ? 0 <= XFIXNUM (object)
+ : BIGNUMP (object) && 0 <= mpz_sgn (XBIGNUM (object)->value))
+ ? Qt : Qnil);
}
DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
@@ -677,7 +669,7 @@ global value outside of any lexical scope. */)
case SYMBOL_LOCALIZED:
{
struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
- if (blv->fwd)
+ if (blv->fwd.fwdptr)
/* In set_internal, we un-forward vars when their value is
set to Qunbound. */
return Qt;
@@ -768,7 +760,9 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
register Lisp_Object function;
CHECK_SYMBOL (symbol);
/* Perhaps not quite the right error signal, but seems good enough. */
- if (NILP (symbol))
+ if (NILP (symbol) && !NILP (definition))
+ /* There are so many other ways to shoot oneself in the foot, I don't
+ think this one little sanity check is worth its cost, but anyway. */
xsignal1 (Qsetting_constant, symbol);
function = XSYMBOL (symbol)->u.s.function;
@@ -810,7 +804,7 @@ The return value is undefined. */)
{
bool autoload = AUTOLOADP (definition);
- if (NILP (Vpurify_flag) || !autoload)
+ if (!will_dump_p () || !autoload)
{ /* Only add autoload entries after dumping, because the ones before are
not useful and else we get loads of them from the loaddefs.el. */
@@ -858,10 +852,10 @@ function with `&rest' args, or `unevalled' for a special form. */)
CHECK_SUBR (subr);
minargs = XSUBR (subr)->min_args;
maxargs = XSUBR (subr)->max_args;
- return Fcons (make_number (minargs),
+ return Fcons (make_fixnum (minargs),
maxargs == MANY ? Qmany
: maxargs == UNEVALLED ? Qunevalled
- : make_number (maxargs));
+ : make_fixnum (maxargs));
}
DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0,
@@ -986,14 +980,12 @@ chain of aliases, signal a `cyclic-variable-indirection' error. */)
swap_in_symval_forwarding for that. */
Lisp_Object
-do_symval_forwarding (register union Lisp_Fwd *valcontents)
+do_symval_forwarding (lispfwd valcontents)
{
- register Lisp_Object val;
switch (XFWDTYPE (valcontents))
{
case Lisp_Fwd_Int:
- XSETINT (val, *XINTFWD (valcontents)->intvar);
- return val;
+ return make_int (*XFIXNUMFWD (valcontents)->intvar);
case Lisp_Fwd_Bool:
return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
@@ -1029,7 +1021,7 @@ do_symval_forwarding (register union Lisp_Fwd *valcontents)
void
wrong_choice (Lisp_Object choice, Lisp_Object wrong)
{
- ptrdiff_t i = 0, len = XINT (Flength (choice));
+ ptrdiff_t i = 0, len = list_length (choice);
Lisp_Object obj, *args;
AUTO_STRING (one_of, "One of ");
AUTO_STRING (comma, ", ");
@@ -1049,7 +1041,10 @@ wrong_choice (Lisp_Object choice, Lisp_Object wrong)
}
obj = Fconcat (i, args);
- SAFE_FREE ();
+
+ /* No need to call SAFE_FREE, since signaling does that for us. */
+ (void) sa_count;
+
xsignal2 (Qerror, obj, wrong);
}
@@ -1076,13 +1071,19 @@ wrong_range (Lisp_Object min, Lisp_Object max, Lisp_Object wrong)
current buffer. This only plays a role for per-buffer variables. */
static void
-store_symval_forwarding (union Lisp_Fwd *valcontents, register Lisp_Object newval, struct buffer *buf)
+store_symval_forwarding (lispfwd valcontents, Lisp_Object newval,
+ struct buffer *buf)
{
switch (XFWDTYPE (valcontents))
{
case Lisp_Fwd_Int:
- CHECK_NUMBER (newval);
- *XINTFWD (valcontents)->intvar = XINT (newval);
+ {
+ intmax_t i;
+ CHECK_INTEGER (newval);
+ if (! integer_to_intmax (newval, &i))
+ xsignal1 (Qoverflow_error, newval);
+ *XFIXNUMFWD (valcontents)->intvar = i;
+ }
break;
case Lisp_Fwd_Bool:
@@ -1178,12 +1179,12 @@ swap_in_global_binding (struct Lisp_Symbol *symbol)
struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (symbol);
/* Unload the previously loaded binding. */
- if (blv->fwd)
+ if (blv->fwd.fwdptr)
set_blv_value (blv, do_symval_forwarding (blv->fwd));
/* Select the global binding in the symbol. */
set_blv_valcell (blv, blv->defcell);
- if (blv->fwd)
+ if (blv->fwd.fwdptr)
store_symval_forwarding (blv->fwd, XCDR (blv->defcell), NULL);
/* Indicate that the global binding is set up now. */
@@ -1213,7 +1214,7 @@ swap_in_symval_forwarding (struct Lisp_Symbol *symbol, struct Lisp_Buffer_Local_
/* Unload the previously loaded binding. */
tem1 = blv->valcell;
- if (blv->fwd)
+ if (blv->fwd.fwdptr)
set_blv_value (blv, do_symval_forwarding (blv->fwd));
/* Choose the new binding. */
{
@@ -1227,7 +1228,7 @@ swap_in_symval_forwarding (struct Lisp_Symbol *symbol, struct Lisp_Buffer_Local_
/* Load the new binding. */
set_blv_valcell (blv, tem1);
- if (blv->fwd)
+ if (blv->fwd.fwdptr)
store_symval_forwarding (blv->fwd, blv_value (blv), NULL);
}
}
@@ -1255,7 +1256,9 @@ find_symbol_value (Lisp_Object symbol)
{
struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
swap_in_symval_forwarding (sym, blv);
- return blv->fwd ? do_symval_forwarding (blv->fwd) : blv_value (blv);
+ return (blv->fwd.fwdptr
+ ? do_symval_forwarding (blv->fwd)
+ : blv_value (blv));
}
case SYMBOL_FORWARDED:
return do_symval_forwarding (SYMBOL_FWD (sym));
@@ -1357,7 +1360,7 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where,
We need to unload it, and choose a new binding. */
/* Write out `realvalue' to the old loaded binding. */
- if (blv->fwd)
+ if (blv->fwd.fwdptr)
set_blv_value (blv, do_symval_forwarding (blv->fwd));
/* Find the new binding. */
@@ -1404,12 +1407,12 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where,
/* Store the new value in the cons cell. */
set_blv_value (blv, newval);
- if (blv->fwd)
+ if (blv->fwd.fwdptr)
{
if (voide)
/* If storing void (making the symbol void), forward only through
buffer-local indicator, not through Lisp_Objfwd, etc. */
- blv->fwd = NULL;
+ blv->fwd.fwdptr = NULL;
else
store_symval_forwarding (blv->fwd, newval,
BUFFERP (where)
@@ -1421,7 +1424,7 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where,
{
struct buffer *buf
= BUFFERP (where) ? XBUFFER (where) : current_buffer;
- union Lisp_Fwd *innercontents = SYMBOL_FWD (sym);
+ lispfwd innercontents = SYMBOL_FWD (sym);
if (BUFFER_OBJFWDP (innercontents))
{
int offset = XBUFFER_OBJFWD (innercontents)->offset;
@@ -1593,14 +1596,14 @@ default_value (Lisp_Object symbol)
But the `realvalue' slot may be more up to date, since
ordinary setq stores just that slot. So use that. */
struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
- if (blv->fwd && EQ (blv->valcell, blv->defcell))
+ if (blv->fwd.fwdptr && EQ (blv->valcell, blv->defcell))
return do_symval_forwarding (blv->fwd);
else
return XCDR (blv->defcell);
}
case SYMBOL_FORWARDED:
{
- union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
+ lispfwd valcontents = SYMBOL_FWD (sym);
/* For a built-in buffer-local variable, get the default value
rather than letting do_symval_forwarding get the current value. */
@@ -1688,13 +1691,13 @@ set_default_internal (Lisp_Object symbol, Lisp_Object value,
XSETCDR (blv->defcell, value);
/* If the default binding is now loaded, set the REALVALUE slot too. */
- if (blv->fwd && EQ (blv->defcell, blv->valcell))
+ if (blv->fwd.fwdptr && EQ (blv->defcell, blv->valcell))
store_symval_forwarding (blv->fwd, value, NULL);
return;
}
case SYMBOL_FORWARDED:
{
- union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
+ lispfwd valcontents = SYMBOL_FWD (sym);
/* Handle variables like case-fold-search that have special slots
in the buffer.
@@ -1710,11 +1713,21 @@ set_default_internal (Lisp_Object symbol, Lisp_Object value,
set it in the buffers that don't nominally have a local value. */
if (idx > 0)
{
- struct buffer *b;
+ Lisp_Object buf, tail;
+
+ /* Do this only in live buffers, so that if there are
+ a lot of buffers which are dead, that doesn't slow
+ down let-binding of variables that are
+ automatically local when set, like
+ case-fold-search. This is for Lisp programs that
+ let-bind such variables in their inner loops. */
+ FOR_EACH_LIVE_BUFFER (tail, buf)
+ {
+ struct buffer *b = XBUFFER (buf);
- FOR_EACH_BUFFER (b)
- if (!PER_BUFFER_VALUE_P (b, idx))
- set_per_buffer_value (b, offset, value);
+ if (!PER_BUFFER_VALUE_P (b, idx))
+ set_per_buffer_value (b, offset, value);
+ }
}
}
else
@@ -1734,43 +1747,13 @@ for this variable. */)
set_default_internal (symbol, value, SET_INTERNAL_SET);
return value;
}
-
-DEFUN ("setq-default", Fsetq_default, Ssetq_default, 0, UNEVALLED, 0,
- doc: /* Set the default value of variable VAR to VALUE.
-VAR, the variable name, is literal (not evaluated);
-VALUE is an expression: it is evaluated and its value returned.
-The default value of a variable is seen in buffers
-that do not have their own values for the variable.
-
-More generally, you can use multiple variables and values, as in
- (setq-default VAR VALUE VAR VALUE...)
-This sets each VAR's default value to the corresponding VALUE.
-The VALUE for the Nth VAR can refer to the new default values
-of previous VARs.
-usage: (setq-default [VAR VALUE]...) */)
- (Lisp_Object args)
-{
- Lisp_Object args_left, symbol, val;
-
- args_left = val = args;
-
- while (CONSP (args_left))
- {
- val = eval_sub (Fcar (XCDR (args_left)));
- symbol = XCAR (args_left);
- Fset_default (symbol, val);
- args_left = Fcdr (XCDR (args_left));
- }
-
- return val;
-}
/* Lisp functions for creating and removing buffer-local variables. */
union Lisp_Val_Fwd
{
Lisp_Object value;
- union Lisp_Fwd *fwd;
+ lispfwd fwd;
};
static struct Lisp_Buffer_Local_Value *
@@ -1790,7 +1773,10 @@ make_blv (struct Lisp_Symbol *sym, bool forwarded,
or keyboard-local forwarding. */
eassert (!(forwarded && BUFFER_OBJFWDP (valcontents.fwd)));
eassert (!(forwarded && KBOARD_OBJFWDP (valcontents.fwd)));
- blv->fwd = forwarded ? valcontents.fwd : NULL;
+ if (forwarded)
+ blv->fwd = valcontents.fwd;
+ else
+ blv->fwd.fwdptr = NULL;
set_blv_where (blv, Qnil);
blv->local_if_set = 0;
set_blv_defcell (blv, tem);
@@ -1821,7 +1807,7 @@ The function `default-value' gets the default value and `set-default' sets it.
{
struct Lisp_Symbol *sym;
struct Lisp_Buffer_Local_Value *blv = NULL;
- union Lisp_Val_Fwd valcontents;
+ union Lisp_Val_Fwd valcontents UNINIT;
bool forwarded UNINIT;
CHECK_SYMBOL (variable);
@@ -1851,7 +1837,7 @@ The function `default-value' gets the default value and `set-default' sets it.
}
if (SYMBOL_CONSTANT_P (variable))
- error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable)));
+ xsignal1 (Qsetting_constant, variable);
if (!blv)
{
@@ -1888,7 +1874,7 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */)
{
Lisp_Object tem;
bool forwarded UNINIT;
- union Lisp_Val_Fwd valcontents;
+ union Lisp_Val_Fwd valcontents UNINIT;
struct Lisp_Symbol *sym;
struct Lisp_Buffer_Local_Value *blv = NULL;
@@ -1914,8 +1900,7 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */)
}
if (sym->u.s.trapped_write == SYMBOL_NOWRITE)
- error ("Symbol %s may not be buffer-local",
- SDATA (SYMBOL_NAME (variable)));
+ xsignal1 (Qsetting_constant, variable);
if (blv ? blv->local_if_set
: (forwarded && BUFFER_OBJFWDP (valcontents.fwd)))
@@ -1962,7 +1947,7 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */)
Otherwise, if C code modifies the variable before we load the
binding in, then that new value would clobber the default binding
the next time we unload it. See bug#34318. */
- if (blv->fwd)
+ if (blv->fwd.fwdptr)
swap_in_symval_forwarding (sym, blv);
}
@@ -1989,7 +1974,7 @@ From now on the default value will apply in this buffer. Return VARIABLE. */)
case SYMBOL_PLAINVAL: return variable;
case SYMBOL_FORWARDED:
{
- union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
+ lispfwd valcontents = SYMBOL_FWD (sym);
if (BUFFER_OBJFWDP (valcontents))
{
int offset = XBUFFER_OBJFWD (valcontents)->offset;
@@ -2072,7 +2057,7 @@ BUFFER defaults to the current buffer. */)
}
case SYMBOL_FORWARDED:
{
- union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
+ lispfwd valcontents = SYMBOL_FWD (sym);
if (BUFFER_OBJFWDP (valcontents))
{
int offset = XBUFFER_OBJFWD (valcontents)->offset;
@@ -2143,7 +2128,7 @@ If the current binding is global (the default), the value is nil. */)
case SYMBOL_PLAINVAL: return Qnil;
case SYMBOL_FORWARDED:
{
- union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
+ lispfwd valcontents = SYMBOL_FWD (sym);
if (KBOARD_OBJFWDP (valcontents))
return Fframe_terminal (selected_frame);
else if (!BUFFER_OBJFWDP (valcontents))
@@ -2164,47 +2149,6 @@ If the current binding is global (the default), the value is nil. */)
}
}
-/* This code is disabled now that we use the selected frame to return
- keyboard-local-values. */
-#if 0
-extern struct terminal *get_terminal (Lisp_Object display, int);
-
-DEFUN ("terminal-local-value", Fterminal_local_value,
- Sterminal_local_value, 2, 2, 0,
- doc: /* Return the terminal-local value of SYMBOL on TERMINAL.
-If SYMBOL is not a terminal-local variable, then return its normal
-value, like `symbol-value'.
-
-TERMINAL may be a terminal object, a frame, or nil (meaning the
-selected frame's terminal device). */)
- (Lisp_Object symbol, Lisp_Object terminal)
-{
- Lisp_Object result;
- struct terminal *t = get_terminal (terminal, 1);
- push_kboard (t->kboard);
- result = Fsymbol_value (symbol);
- pop_kboard ();
- return result;
-}
-
-DEFUN ("set-terminal-local-value", Fset_terminal_local_value,
- Sset_terminal_local_value, 3, 3, 0,
- doc: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
-If VARIABLE is not a terminal-local variable, then set its normal
-binding, like `set'.
-
-TERMINAL may be a terminal object, a frame, or nil (meaning the
-selected frame's terminal device). */)
- (Lisp_Object symbol, Lisp_Object terminal, Lisp_Object value)
-{
- Lisp_Object result;
- struct terminal *t = get_terminal (terminal, 1);
- push_kboard (d->kboard);
- result = Fset (symbol, value);
- pop_kboard ();
- return result;
-}
-#endif
/* Find the function at the end of a chain of symbol function indirections. */
@@ -2271,8 +2215,8 @@ or a byte-code object. IDX starts at 0. */)
{
register EMACS_INT idxval;
- CHECK_NUMBER (idx);
- idxval = XINT (idx);
+ CHECK_FIXNUM (idx);
+ idxval = XFIXNUM (idx);
if (STRINGP (array))
{
int c;
@@ -2281,11 +2225,11 @@ or a byte-code object. IDX starts at 0. */)
if (idxval < 0 || idxval >= SCHARS (array))
args_out_of_range (array, idx);
if (! STRING_MULTIBYTE (array))
- return make_number ((unsigned char) SREF (array, idxval));
+ return make_fixnum ((unsigned char) SREF (array, idxval));
idxval_byte = string_char_to_byte (array, idxval);
c = STRING_CHAR (SDATA (array) + idxval_byte);
- return make_number (c);
+ return make_fixnum (c);
}
else if (BOOL_VECTOR_P (array))
{
@@ -2322,8 +2266,8 @@ bool-vector. IDX starts at 0. */)
{
register EMACS_INT idxval;
- CHECK_NUMBER (idx);
- idxval = XINT (idx);
+ CHECK_FIXNUM (idx);
+ idxval = XFIXNUM (idx);
if (! RECORDP (array))
CHECK_ARRAY (array, Qarrayp);
@@ -2359,7 +2303,7 @@ bool-vector. IDX starts at 0. */)
if (idxval < 0 || idxval >= SCHARS (array))
args_out_of_range (array, idx);
CHECK_CHARACTER (newelt);
- c = XFASTINT (newelt);
+ c = XFIXNAT (newelt);
if (STRING_MULTIBYTE (array))
{
@@ -2413,39 +2357,113 @@ bool-vector. IDX starts at 0. */)
return newelt;
}
+/* GMP tests for this value and aborts (!) if it is exceeded.
+ This is as of GMP 6.1.2 (2016); perhaps future versions will differ. */
+enum { GMP_NLIMBS_MAX = min (INT_MAX, ULONG_MAX / GMP_NUMB_BITS) };
+
+/* An upper bound on limb counts, needed to prevent libgmp and/or
+ Emacs from aborting or otherwise misbehaving. This bound applies
+ to estimates of mpz_t sizes before the mpz_t objects are created,
+ as opposed to integer-width which operates on mpz_t values after
+ creation and before conversion to Lisp bignums. */
+enum
+ {
+ NLIMBS_LIMIT = min (min (/* libgmp needs to store limb counts. */
+ GMP_NLIMBS_MAX,
+
+ /* Size calculations need to work. */
+ min (PTRDIFF_MAX, SIZE_MAX) / sizeof (mp_limb_t)),
+
+ /* Emacs puts bit counts into fixnums. */
+ MOST_POSITIVE_FIXNUM / GMP_NUMB_BITS)
+ };
+
+/* Like mpz_size, but tell the compiler the result is a nonnegative int. */
+
+static int
+emacs_mpz_size (mpz_t const op)
+{
+ mp_size_t size = mpz_size (op);
+ eassume (0 <= size && size <= INT_MAX);
+ return size;
+}
+
+/* Wrappers to work around GMP limitations. As of GMP 6.1.2 (2016),
+ the library code aborts when a number is too large. These wrappers
+ avoid the problem for functions that can return numbers much larger
+ than their arguments. For slowly-growing numbers, the integer
+ width checks in bignum.c should suffice. */
+
+static void
+emacs_mpz_mul (mpz_t rop, mpz_t const op1, mpz_t const op2)
+{
+ if (NLIMBS_LIMIT - emacs_mpz_size (op1) < emacs_mpz_size (op2))
+ overflow_error ();
+ mpz_mul (rop, op1, op2);
+}
+
+static void
+emacs_mpz_mul_2exp (mpz_t rop, mpz_t const op1, EMACS_INT op2)
+{
+ /* Fudge factor derived from GMP 6.1.2, to avoid an abort in
+ mpz_mul_2exp (look for the '+ 1' in its source code). */
+ enum { mul_2exp_extra_limbs = 1 };
+ enum { lim = min (NLIMBS_LIMIT, GMP_NLIMBS_MAX - mul_2exp_extra_limbs) };
+
+ EMACS_INT op2limbs = op2 / GMP_NUMB_BITS;
+ if (lim - emacs_mpz_size (op1) < op2limbs)
+ overflow_error ();
+ mpz_mul_2exp (rop, op1, op2);
+}
+
+static void
+emacs_mpz_pow_ui (mpz_t rop, mpz_t const base, unsigned long exp)
+{
+ /* This fudge factor is derived from GMP 6.1.2, to avoid an abort in
+ mpz_n_pow_ui (look for the '5' in its source code). */
+ enum { pow_ui_extra_limbs = 5 };
+ enum { lim = min (NLIMBS_LIMIT, GMP_NLIMBS_MAX - pow_ui_extra_limbs) };
+
+ int nbase = emacs_mpz_size (base), n;
+ if (INT_MULTIPLY_WRAPV (nbase, exp, &n) || lim < n)
+ overflow_error ();
+ mpz_pow_ui (rop, base, exp);
+}
+
+
/* Arithmetic functions */
Lisp_Object
arithcompare (Lisp_Object num1, Lisp_Object num2,
enum Arith_Comparison comparison)
{
- double f1, f2;
- EMACS_INT i1, i2;
- bool lt, eq, gt;
+ EMACS_INT i1 = 0, i2 = 0;
+ bool lt, eq = true, gt;
bool test;
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1);
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2);
+ CHECK_NUMBER_COERCE_MARKER (num1);
+ CHECK_NUMBER_COERCE_MARKER (num2);
- /* If either arg is floating point, set F1 and F2 to the 'double'
- approximations of the two arguments, and set LT, EQ, and GT to
- the <, ==, > floating-point comparisons of F1 and F2
+ /* If the comparison is mostly done by comparing two doubles,
+ set LT, EQ, and GT to the <, ==, > results of that comparison,
respectively, taking care to avoid problems if either is a NaN,
and trying to avoid problems on platforms where variables (in
violation of the C standard) can contain excess precision.
Regardless, set I1 and I2 to integers that break ties if the
- floating-point comparison is either not done or reports
+ two-double comparison is either not done or reports
equality. */
if (FLOATP (num1))
{
- f1 = XFLOAT_DATA (num1);
+ double f1 = XFLOAT_DATA (num1);
if (FLOATP (num2))
{
- i1 = i2 = 0;
- f2 = XFLOAT_DATA (num2);
+ double f2 = XFLOAT_DATA (num2);
+ lt = f1 < f2;
+ eq = f1 == f2;
+ gt = f1 > f2;
}
- else
+ else if (FIXNUMP (num2))
{
/* Compare a float NUM1 to an integer NUM2 by converting the
integer I2 (i.e., NUM2) to the double F2 (a conversion that
@@ -2455,35 +2473,56 @@ arithcompare (Lisp_Object num1, Lisp_Object num2,
floating-point comparison reports a tie, NUM1 = F1 = F2 = I1
(exactly) so I1 - I2 = NUM1 - NUM2 (exactly), so comparing I1
to I2 will break the tie correctly. */
- i1 = f2 = i2 = XINT (num2);
+ double f2 = XFIXNUM (num2);
+ lt = f1 < f2;
+ eq = f1 == f2;
+ gt = f1 > f2;
+ i1 = f2;
+ i2 = XFIXNUM (num2);
}
- lt = f1 < f2;
- eq = f1 == f2;
- gt = f1 > f2;
+ else if (isnan (f1))
+ lt = eq = gt = false;
+ else
+ i2 = mpz_cmp_d (XBIGNUM (num2)->value, f1);
}
- else
+ else if (FIXNUMP (num1))
{
- i1 = XINT (num1);
if (FLOATP (num2))
{
/* Compare an integer NUM1 to a float NUM2. This is the
converse of comparing float to integer (see above). */
- i2 = f1 = i1;
- f2 = XFLOAT_DATA (num2);
+ double f1 = XFIXNUM (num1), f2 = XFLOAT_DATA (num2);
lt = f1 < f2;
eq = f1 == f2;
gt = f1 > f2;
+ i1 = XFIXNUM (num1);
+ i2 = f1;
}
- else
+ else if (FIXNUMP (num2))
{
- i2 = XINT (num2);
- eq = true;
+ i1 = XFIXNUM (num1);
+ i2 = XFIXNUM (num2);
}
+ else
+ i2 = mpz_sgn (XBIGNUM (num2)->value);
+ }
+ else if (FLOATP (num2))
+ {
+ double f2 = XFLOAT_DATA (num2);
+ if (isnan (f2))
+ lt = eq = gt = false;
+ else
+ i1 = mpz_cmp_d (XBIGNUM (num1)->value, f2);
}
+ else if (FIXNUMP (num2))
+ i1 = mpz_sgn (XBIGNUM (num1)->value);
+ else
+ i1 = mpz_cmp (XBIGNUM (num1)->value, XBIGNUM (num2)->value);
if (eq)
{
- /* Break a floating-point tie by comparing the integers. */
+ /* The two-double comparison either reported equality, or was not done.
+ Break the tie by comparing the integers. */
lt = i1 < i2;
eq = i1 == i2;
gt = i1 > i2;
@@ -2579,48 +2618,21 @@ DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
return arithcompare (num1, num2, ARITH_NOTEQUAL);
}
-/* Convert the integer I to a cons-of-integers, where I is not in
- fixnum range. */
-
-#define INTBIG_TO_LISP(i, extremum) \
- (eassert (FIXNUM_OVERFLOW_P (i)), \
- (! (FIXNUM_OVERFLOW_P ((extremum) >> 16) \
- && FIXNUM_OVERFLOW_P ((i) >> 16)) \
- ? Fcons (make_number ((i) >> 16), make_number ((i) & 0xffff)) \
- : ! (FIXNUM_OVERFLOW_P ((extremum) >> 16 >> 24) \
- && FIXNUM_OVERFLOW_P ((i) >> 16 >> 24)) \
- ? Fcons (make_number ((i) >> 16 >> 24), \
- Fcons (make_number ((i) >> 16 & 0xffffff), \
- make_number ((i) & 0xffff))) \
- : make_float (i)))
-
-Lisp_Object
-intbig_to_lisp (intmax_t i)
-{
- return INTBIG_TO_LISP (i, INTMAX_MIN);
-}
-
-Lisp_Object
-uintbig_to_lisp (uintmax_t i)
-{
- return INTBIG_TO_LISP (i, UINTMAX_MAX);
-}
-
/* Convert the cons-of-integers, integer, or float value C to an
unsigned value with maximum value MAX, where MAX is one less than a
power of 2. Signal an error if C does not have a valid format or
- is out of range. */
+ is out of range.
+
+ Although Emacs represents large integers with bignums instead of
+ cons-of-integers or floats, for now this function still accepts the
+ obsolete forms in case some old Lisp code still generates them. */
uintmax_t
cons_to_unsigned (Lisp_Object c, uintmax_t max)
{
bool valid = false;
uintmax_t val UNINIT;
- if (INTEGERP (c))
- {
- valid = XINT (c) >= 0;
- val = XINT (c);
- }
- else if (FLOATP (c))
+
+ if (FLOATP (c))
{
double d = XFLOAT_DATA (c);
if (d >= 0 && d < 1.0 + max)
@@ -2629,27 +2641,34 @@ cons_to_unsigned (Lisp_Object c, uintmax_t max)
valid = val == d;
}
}
- else if (CONSP (c) && NATNUMP (XCAR (c)))
+ else
{
- uintmax_t top = XFASTINT (XCAR (c));
- Lisp_Object rest = XCDR (c);
- if (top <= UINTMAX_MAX >> 24 >> 16
- && CONSP (rest)
- && NATNUMP (XCAR (rest)) && XFASTINT (XCAR (rest)) < 1 << 24
- && NATNUMP (XCDR (rest)) && XFASTINT (XCDR (rest)) < 1 << 16)
- {
- uintmax_t mid = XFASTINT (XCAR (rest));
- val = top << 24 << 16 | mid << 16 | XFASTINT (XCDR (rest));
- valid = true;
- }
- else if (top <= UINTMAX_MAX >> 16)
+ Lisp_Object hi = CONSP (c) ? XCAR (c) : c;
+ valid = INTEGERP (hi) && integer_to_uintmax (hi, &val);
+
+ if (valid && CONSP (c))
{
- if (CONSP (rest))
- rest = XCAR (rest);
- if (NATNUMP (rest) && XFASTINT (rest) < 1 << 16)
+ uintmax_t top = val;
+ Lisp_Object rest = XCDR (c);
+ if (top <= UINTMAX_MAX >> 24 >> 16
+ && CONSP (rest)
+ && FIXNATP (XCAR (rest)) && XFIXNAT (XCAR (rest)) < 1 << 24
+ && FIXNATP (XCDR (rest)) && XFIXNAT (XCDR (rest)) < 1 << 16)
+ {
+ uintmax_t mid = XFIXNAT (XCAR (rest));
+ val = top << 24 << 16 | mid << 16 | XFIXNAT (XCDR (rest));
+ }
+ else
{
- val = top << 16 | XFASTINT (rest);
- valid = true;
+ valid = top <= UINTMAX_MAX >> 16;
+ if (valid)
+ {
+ if (CONSP (rest))
+ rest = XCAR (rest);
+ valid = FIXNATP (rest) && XFIXNAT (rest) < 1 << 16;
+ if (valid)
+ val = top << 16 | XFIXNAT (rest);
+ }
}
}
}
@@ -2663,18 +2682,18 @@ cons_to_unsigned (Lisp_Object c, uintmax_t max)
value with extrema MIN and MAX. MAX should be one less than a
power of 2, and MIN should be zero or the negative of a power of 2.
Signal an error if C does not have a valid format or is out of
- range. */
+ range.
+
+ Although Emacs represents large integers with bignums instead of
+ cons-of-integers or floats, for now this function still accepts the
+ obsolete forms in case some old Lisp code still generates them. */
intmax_t
cons_to_signed (Lisp_Object c, intmax_t min, intmax_t max)
{
bool valid = false;
intmax_t val UNINIT;
- if (INTEGERP (c))
- {
- val = XINT (c);
- valid = true;
- }
- else if (FLOATP (c))
+
+ if (FLOATP (c))
{
double d = XFLOAT_DATA (c);
if (d >= min && d < 1.0 + max)
@@ -2683,27 +2702,34 @@ cons_to_signed (Lisp_Object c, intmax_t min, intmax_t max)
valid = val == d;
}
}
- else if (CONSP (c) && INTEGERP (XCAR (c)))
+ else
{
- intmax_t top = XINT (XCAR (c));
- Lisp_Object rest = XCDR (c);
- if (top >= INTMAX_MIN >> 24 >> 16 && top <= INTMAX_MAX >> 24 >> 16
- && CONSP (rest)
- && NATNUMP (XCAR (rest)) && XFASTINT (XCAR (rest)) < 1 << 24
- && NATNUMP (XCDR (rest)) && XFASTINT (XCDR (rest)) < 1 << 16)
- {
- intmax_t mid = XFASTINT (XCAR (rest));
- val = top << 24 << 16 | mid << 16 | XFASTINT (XCDR (rest));
- valid = true;
- }
- else if (top >= INTMAX_MIN >> 16 && top <= INTMAX_MAX >> 16)
+ Lisp_Object hi = CONSP (c) ? XCAR (c) : c;
+ valid = INTEGERP (hi) && integer_to_intmax (hi, &val);
+
+ if (valid && CONSP (c))
{
- if (CONSP (rest))
- rest = XCAR (rest);
- if (NATNUMP (rest) && XFASTINT (rest) < 1 << 16)
+ intmax_t top = val;
+ Lisp_Object rest = XCDR (c);
+ if (top >= INTMAX_MIN >> 24 >> 16 && top <= INTMAX_MAX >> 24 >> 16
+ && CONSP (rest)
+ && FIXNATP (XCAR (rest)) && XFIXNAT (XCAR (rest)) < 1 << 24
+ && FIXNATP (XCDR (rest)) && XFIXNAT (XCDR (rest)) < 1 << 16)
+ {
+ intmax_t mid = XFIXNAT (XCAR (rest));
+ val = top << 24 << 16 | mid << 16 | XFIXNAT (XCDR (rest));
+ }
+ else
{
- val = top << 16 | XFASTINT (rest);
- valid = true;
+ valid = INTMAX_MIN >> 16 <= top && top <= INTMAX_MAX >> 16;
+ if (valid)
+ {
+ if (CONSP (rest))
+ rest = XCAR (rest);
+ valid = FIXNATP (rest) && XFIXNAT (rest) < 1 << 16;
+ if (valid)
+ val = top << 16 | XFIXNAT (rest);
+ }
}
}
}
@@ -2722,12 +2748,15 @@ NUMBER may be an integer or a floating point number. */)
char buffer[max (FLOAT_TO_STRING_BUFSIZE, INT_BUFSIZE_BOUND (EMACS_INT))];
int len;
- CHECK_NUMBER_OR_FLOAT (number);
+ CHECK_NUMBER (number);
+
+ if (BIGNUMP (number))
+ return bignum_to_string (number, 10);
if (FLOATP (number))
len = float_to_string (buffer, XFLOAT_DATA (number));
else
- len = sprintf (buffer, "%"pI"d", XINT (number));
+ len = sprintf (buffer, "%"pI"d", XFIXNUM (number));
return make_unibyte_string (buffer, len);
}
@@ -2742,9 +2771,7 @@ present, base 10 is used. BASE must be between 2 and 16 (inclusive).
If the base used is not 10, STRING is always parsed as an integer. */)
(register Lisp_Object string, Lisp_Object base)
{
- register char *p;
- register int b;
- Lisp_Object val;
+ int b;
CHECK_STRING (string);
@@ -2752,18 +2779,18 @@ If the base used is not 10, STRING is always parsed as an integer. */)
b = 10;
else
{
- CHECK_NUMBER (base);
- if (! (XINT (base) >= 2 && XINT (base) <= 16))
+ CHECK_FIXNUM (base);
+ if (! (XFIXNUM (base) >= 2 && XFIXNUM (base) <= 16))
xsignal1 (Qargs_out_of_range, base);
- b = XINT (base);
+ b = XFIXNUM (base);
}
- p = SSDATA (string);
+ char *p = SSDATA (string);
while (*p == ' ' || *p == '\t')
p++;
- val = string_to_number (p, b, 1);
- return NILP (val) ? make_number (0) : val;
+ Lisp_Object val = string_to_number (p, b, 0);
+ return NILP (val) ? make_fixnum (0) : val;
}
enum arithop
@@ -2776,151 +2803,178 @@ enum arithop
Alogior,
Alogxor
};
+static bool
+floating_point_op (enum arithop code)
+{
+ return code <= Adiv;
+}
+
+/* Return the result of applying the floating-point operation CODE to
+ the NARGS arguments starting at ARGS. If ARGNUM is positive,
+ ARGNUM of the arguments were already consumed, yielding ACCUM.
+ 0 <= ARGNUM < NARGS, 2 <= NARGS, and NEXT is the value of
+ ARGS[ARGSNUM], converted to double. */
-static Lisp_Object float_arith_driver (double, ptrdiff_t, enum arithop,
- ptrdiff_t, Lisp_Object *);
static Lisp_Object
-arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args)
+floatop_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args,
+ ptrdiff_t argnum, double accum, double next)
{
- Lisp_Object val;
- ptrdiff_t argnum, ok_args;
- EMACS_INT accum = 0;
- EMACS_INT next, ok_accum;
- bool overflow = 0;
-
- switch (code)
- {
- case Alogior:
- case Alogxor:
- case Aadd:
- case Asub:
- accum = 0;
- break;
- case Amult:
- case Adiv:
- accum = 1;
- break;
- case Alogand:
- accum = -1;
- break;
- default:
- break;
+ if (argnum == 0)
+ {
+ accum = next;
+ goto next_arg;
}
- for (argnum = 0; argnum < nargs; argnum++)
+ while (true)
{
- if (! overflow)
- {
- ok_args = argnum;
- ok_accum = accum;
- }
-
- /* Using args[argnum] as argument to CHECK_NUMBER_... */
- val = args[argnum];
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val);
-
- if (FLOATP (val))
- return float_arith_driver (ok_accum, ok_args, code,
- nargs, args);
- args[argnum] = val;
- next = XINT (args[argnum]);
switch (code)
{
- case Aadd:
- overflow |= INT_ADD_WRAPV (accum, next, &accum);
- break;
- case Asub:
- if (! argnum)
- accum = nargs == 1 ? - next : next;
- else
- overflow |= INT_SUBTRACT_WRAPV (accum, next, &accum);
- break;
- case Amult:
- overflow |= INT_MULTIPLY_WRAPV (accum, next, &accum);
- break;
+ case Aadd : accum += next; break;
+ case Asub : accum -= next; break;
+ case Amult: accum *= next; break;
case Adiv:
- if (! (argnum || nargs == 1))
- accum = next;
- else
- {
- if (next == 0)
- xsignal0 (Qarith_error);
- if (INT_DIVIDE_OVERFLOW (accum, next))
- overflow = true;
- else
- accum /= next;
- }
- break;
- case Alogand:
- accum &= next;
- break;
- case Alogior:
- accum |= next;
- break;
- case Alogxor:
- accum ^= next;
+ if (! IEEE_FLOATING_POINT && next == 0)
+ xsignal0 (Qarith_error);
+ accum /= next;
break;
+ default: eassume (false);
}
+
+ next_arg:
+ argnum++;
+ if (argnum == nargs)
+ return make_float (accum);
+ Lisp_Object val = args[argnum];
+ CHECK_NUMBER_COERCE_MARKER (val);
+ next = XFLOATINT (val);
}
+}
- XSETINT (val, accum);
- return val;
+/* Like floatop_arith_driver, except CODE might not be a floating-point
+ operation, and NEXT is a Lisp float rather than a C double. */
+
+static Lisp_Object
+float_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args,
+ ptrdiff_t argnum, double accum, Lisp_Object next)
+{
+ if (! floating_point_op (code))
+ wrong_type_argument (Qinteger_or_marker_p, next);
+ return floatop_arith_driver (code, nargs, args, argnum, accum,
+ XFLOAT_DATA (next));
}
-#ifndef isnan
-# define isnan(x) ((x) != (x))
-#endif
+/* Return the result of applying the arithmetic operation CODE to the
+ NARGS arguments starting at ARGS. If ARGNUM is positive, ARGNUM of
+ the arguments were already consumed, yielding IACCUM. 0 <= ARGNUM
+ < NARGS, 2 <= NARGS, and VAL is the value of ARGS[ARGSNUM],
+ converted to integer. */
static Lisp_Object
-float_arith_driver (double accum, ptrdiff_t argnum, enum arithop code,
- ptrdiff_t nargs, Lisp_Object *args)
+bignum_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args,
+ ptrdiff_t argnum, intmax_t iaccum, Lisp_Object val)
{
- register Lisp_Object val;
- double next;
+ mpz_t *accum;
+ if (argnum == 0)
+ {
+ accum = bignum_integer (&mpz[0], val);
+ goto next_arg;
+ }
+ mpz_set_intmax (mpz[0], iaccum);
+ accum = &mpz[0];
- for (; argnum < nargs; argnum++)
+ while (true)
{
- val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val);
+ mpz_t *next = bignum_integer (&mpz[1], val);
- if (FLOATP (val))
- {
- next = XFLOAT_DATA (val);
- }
- else
- {
- args[argnum] = val; /* runs into a compiler bug. */
- next = XINT (args[argnum]);
- }
switch (code)
{
- case Aadd:
- accum += next;
- break;
- case Asub:
- accum = argnum ? accum - next : nargs == 1 ? - next : next;
- break;
- case Amult:
- accum *= next;
- break;
+ case Aadd : mpz_add (mpz[0], *accum, *next); break;
+ case Asub : mpz_sub (mpz[0], *accum, *next); break;
+ case Amult : emacs_mpz_mul (mpz[0], *accum, *next); break;
+ case Alogand: mpz_and (mpz[0], *accum, *next); break;
+ case Alogior: mpz_ior (mpz[0], *accum, *next); break;
+ case Alogxor: mpz_xor (mpz[0], *accum, *next); break;
case Adiv:
- if (! (argnum || nargs == 1))
- accum = next;
- else
- {
- if (! IEEE_FLOATING_POINT && next == 0)
- xsignal0 (Qarith_error);
- accum /= next;
- }
+ if (mpz_sgn (*next) == 0)
+ xsignal0 (Qarith_error);
+ mpz_tdiv_q (mpz[0], *accum, *next);
break;
- case Alogand:
- case Alogior:
- case Alogxor:
- wrong_type_argument (Qinteger_or_marker_p, val);
+ default:
+ eassume (false);
}
+ accum = &mpz[0];
+
+ next_arg:
+ argnum++;
+ if (argnum == nargs)
+ return make_integer_mpz ();
+ val = args[argnum];
+ CHECK_NUMBER_COERCE_MARKER (val);
+ if (FLOATP (val))
+ return float_arith_driver (code, nargs, args, argnum,
+ mpz_get_d_rounded (*accum), val);
}
+}
+
+/* Return the result of applying the arithmetic operation CODE to the
+ NARGS arguments starting at ARGS, with the first argument being the
+ number VAL. 2 <= NARGS. Check that the remaining arguments are
+ numbers or markers. */
- return make_float (accum);
+static Lisp_Object
+arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args,
+ Lisp_Object val)
+{
+ eassume (2 <= nargs);
+
+ ptrdiff_t argnum = 0;
+ /* Set ACCUM to VAL's value if it is a fixnum, otherwise to some
+ ignored value to avoid using an uninitialized variable later. */
+ intmax_t accum = XFIXNUM (val);
+
+ if (FIXNUMP (val))
+ while (true)
+ {
+ argnum++;
+ if (argnum == nargs)
+ return make_int (accum);
+ val = args[argnum];
+ CHECK_NUMBER_COERCE_MARKER (val);
+
+ /* Set NEXT to the next value if it fits, else exit the loop. */
+ intmax_t next;
+ if (! (INTEGERP (val) && integer_to_intmax (val, &next)))
+ break;
+
+ /* Set ACCUM to the next operation's result if it fits,
+ else exit the loop. */
+ bool overflow = false;
+ intmax_t a UNINIT;
+ switch (code)
+ {
+ case Aadd : overflow = INT_ADD_WRAPV (accum, next, &a); break;
+ case Amult: overflow = INT_MULTIPLY_WRAPV (accum, next, &a); break;
+ case Asub : overflow = INT_SUBTRACT_WRAPV (accum, next, &a); break;
+ case Adiv:
+ if (next == 0)
+ xsignal0 (Qarith_error);
+ overflow = INT_DIVIDE_OVERFLOW (accum, next);
+ if (!overflow)
+ a = accum / next;
+ break;
+ case Alogand: accum &= next; continue;
+ case Alogior: accum |= next; continue;
+ case Alogxor: accum ^= next; continue;
+ default: eassume (false);
+ }
+ if (overflow)
+ break;
+ accum = a;
+ }
+
+ return (FLOATP (val)
+ ? float_arith_driver (code, nargs, args, argnum, accum, val)
+ : bignum_arith_driver (code, nargs, args, argnum, accum, val));
}
@@ -2929,7 +2983,11 @@ DEFUN ("+", Fplus, Splus, 0, MANY, 0,
usage: (+ &rest NUMBERS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- return arith_driver (Aadd, nargs, args);
+ if (nargs == 0)
+ return make_fixnum (0);
+ Lisp_Object a = args[0];
+ CHECK_NUMBER_COERCE_MARKER (a);
+ return nargs == 1 ? a : arith_driver (Aadd, nargs, args, a);
}
DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
@@ -2939,7 +2997,20 @@ subtracts all but the first from the first.
usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- return arith_driver (Asub, nargs, args);
+ if (nargs == 0)
+ return make_fixnum (0);
+ Lisp_Object a = args[0];
+ CHECK_NUMBER_COERCE_MARKER (a);
+ if (nargs == 1)
+ {
+ if (FIXNUMP (a))
+ return make_int (-XFIXNUM (a));
+ if (FLOATP (a))
+ return make_float (-XFLOAT_DATA (a));
+ mpz_neg (mpz[0], XBIGNUM (a)->value);
+ return make_integer_mpz ();
+ }
+ return arith_driver (Asub, nargs, args, a);
}
DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
@@ -2947,7 +3018,11 @@ DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
usage: (* &rest NUMBERS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- return arith_driver (Amult, nargs, args);
+ if (nargs == 0)
+ return make_fixnum (1);
+ Lisp_Object a = args[0];
+ CHECK_NUMBER_COERCE_MARKER (a);
+ return nargs == 1 ? a : arith_driver (Amult, nargs, args, a);
}
DEFUN ("/", Fquo, Squo, 1, MANY, 0,
@@ -2958,11 +3033,31 @@ The arguments must be numbers or markers.
usage: (/ NUMBER &rest DIVISORS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- ptrdiff_t argnum;
- for (argnum = 2; argnum < nargs; argnum++)
+ Lisp_Object a = args[0];
+ CHECK_NUMBER_COERCE_MARKER (a);
+ if (nargs == 1)
+ {
+ if (FIXNUMP (a))
+ {
+ if (XFIXNUM (a) == 0)
+ xsignal0 (Qarith_error);
+ return make_fixnum (1 / XFIXNUM (a));
+ }
+ if (FLOATP (a))
+ {
+ if (! IEEE_FLOATING_POINT && XFLOAT_DATA (a) == 0)
+ xsignal0 (Qarith_error);
+ return make_float (1 / XFLOAT_DATA (a));
+ }
+ /* Dividing 1 by any bignum yields 0. */
+ return make_fixnum (0);
+ }
+
+ /* Do all computation in floating-point if any arg is a float. */
+ for (ptrdiff_t argnum = 2; argnum < nargs; argnum++)
if (FLOATP (args[argnum]))
- return float_arith_driver (0, 0, Adiv, nargs, args);
- return arith_driver (Adiv, nargs, args);
+ return floatop_arith_driver (Adiv, nargs, args, 0, 0, XFLOATINT (a));
+ return arith_driver (Adiv, nargs, args, a);
}
DEFUN ("%", Frem, Srem, 2, 2, 0,
@@ -2970,16 +3065,22 @@ DEFUN ("%", Frem, Srem, 2, 2, 0,
Both must be integers or markers. */)
(register Lisp_Object x, Lisp_Object y)
{
- Lisp_Object val;
-
- CHECK_NUMBER_COERCE_MARKER (x);
- CHECK_NUMBER_COERCE_MARKER (y);
+ CHECK_INTEGER_COERCE_MARKER (x);
+ CHECK_INTEGER_COERCE_MARKER (y);
- if (XINT (y) == 0)
+ /* A bignum can never be 0, so don't check that case. */
+ if (FIXNUMP (y) && XFIXNUM (y) == 0)
xsignal0 (Qarith_error);
- XSETINT (val, XINT (x) % XINT (y));
- return val;
+ if (FIXNUMP (x) && FIXNUMP (y))
+ return make_fixnum (XFIXNUM (x) % XFIXNUM (y));
+ else
+ {
+ mpz_tdiv_r (mpz[0],
+ *bignum_integer (&mpz[0], x),
+ *bignum_integer (&mpz[1], y));
+ return make_integer_mpz ();
+ }
}
DEFUN ("mod", Fmod, Smod, 2, 2, 0,
@@ -2988,29 +3089,45 @@ The result falls between zero (inclusive) and Y (exclusive).
Both X and Y must be numbers or markers. */)
(register Lisp_Object x, Lisp_Object y)
{
- Lisp_Object val;
- EMACS_INT i1, i2;
+ CHECK_NUMBER_COERCE_MARKER (x);
+ CHECK_NUMBER_COERCE_MARKER (y);
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x);
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y);
+ /* Note that a bignum can never be 0, so we don't need to check that
+ case. */
+ if (FIXNUMP (y) && XFIXNUM (y) == 0)
+ xsignal0 (Qarith_error);
if (FLOATP (x) || FLOATP (y))
return fmod_float (x, y);
- i1 = XINT (x);
- i2 = XINT (y);
+ if (FIXNUMP (x) && FIXNUMP (y))
+ {
+ EMACS_INT i1 = XFIXNUM (x), i2 = XFIXNUM (y);
- if (i2 == 0)
- xsignal0 (Qarith_error);
+ if (i2 == 0)
+ xsignal0 (Qarith_error);
- i1 %= i2;
+ i1 %= i2;
- /* If the "remainder" comes out with the wrong sign, fix it. */
- if (i2 < 0 ? i1 > 0 : i1 < 0)
- i1 += i2;
+ /* If the "remainder" comes out with the wrong sign, fix it. */
+ if (i2 < 0 ? i1 > 0 : i1 < 0)
+ i1 += i2;
- XSETINT (val, i1);
- return val;
+ return make_fixnum (i1);
+ }
+ else
+ {
+ mpz_t *ym = bignum_integer (&mpz[1], y);
+ bool neg_y = mpz_sgn (*ym) < 0;
+ mpz_mod (mpz[0], *bignum_integer (&mpz[0], x), *ym);
+
+ /* Fix the sign if needed. */
+ int sgn_r = mpz_sgn (mpz[0]);
+ if (neg_y ? sgn_r > 0 : sgn_r < 0)
+ mpz_add (mpz[0], mpz[0], *ym);
+
+ return make_integer_mpz ();
+ }
}
static Lisp_Object
@@ -3018,11 +3135,11 @@ minmax_driver (ptrdiff_t nargs, Lisp_Object *args,
enum Arith_Comparison comparison)
{
Lisp_Object accum = args[0];
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (accum);
+ CHECK_NUMBER_COERCE_MARKER (accum);
for (ptrdiff_t argnum = 1; argnum < nargs; argnum++)
{
Lisp_Object val = args[argnum];
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val);
+ CHECK_NUMBER_COERCE_MARKER (val);
if (!NILP (arithcompare (val, accum, comparison)))
accum = val;
else if (FLOATP (val) && isnan (XFLOAT_DATA (val)))
@@ -3055,7 +3172,11 @@ Arguments may be integers, or markers converted to integers.
usage: (logand &rest INTS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- return arith_driver (Alogand, nargs, args);
+ if (nargs == 0)
+ return make_fixnum (-1);
+ Lisp_Object a = args[0];
+ CHECK_INTEGER_COERCE_MARKER (a);
+ return nargs == 1 ? a : arith_driver (Alogand, nargs, args, a);
}
DEFUN ("logior", Flogior, Slogior, 0, MANY, 0,
@@ -3064,7 +3185,11 @@ Arguments may be integers, or markers converted to integers.
usage: (logior &rest INTS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- return arith_driver (Alogior, nargs, args);
+ if (nargs == 0)
+ return make_fixnum (0);
+ Lisp_Object a = args[0];
+ CHECK_INTEGER_COERCE_MARKER (a);
+ return nargs == 1 ? a : arith_driver (Alogior, nargs, args, a);
}
DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
@@ -3073,48 +3198,108 @@ Arguments may be integers, or markers converted to integers.
usage: (logxor &rest INTS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- return arith_driver (Alogxor, nargs, args);
+ if (nargs == 0)
+ return make_fixnum (0);
+ Lisp_Object a = args[0];
+ CHECK_INTEGER_COERCE_MARKER (a);
+ return nargs == 1 ? a : arith_driver (Alogxor, nargs, args, a);
}
-static Lisp_Object
-ash_lsh_impl (Lisp_Object value, Lisp_Object count, bool lsh)
+DEFUN ("logcount", Flogcount, Slogcount, 1, 1, 0,
+ doc: /* Return population count of VALUE.
+This is the number of one bits in the two's complement representation
+of VALUE. If VALUE is negative, return the number of zero bits in the
+representation. */)
+ (Lisp_Object value)
{
- /* This code assumes that signed right shifts are arithmetic. */
- verify ((EMACS_INT) -1 >> 1 == -1);
+ CHECK_INTEGER (value);
- Lisp_Object val;
-
- CHECK_NUMBER (value);
- CHECK_NUMBER (count);
+ if (BIGNUMP (value))
+ {
+ mpz_t *nonneg = &XBIGNUM (value)->value;
+ if (mpz_sgn (*nonneg) < 0)
+ {
+ mpz_com (mpz[0], *nonneg);
+ nonneg = &mpz[0];
+ }
+ return make_fixnum (mpz_popcount (*nonneg));
+ }
- if (XINT (count) >= EMACS_INT_WIDTH)
- XSETINT (val, 0);
- else if (XINT (count) > 0)
- XSETINT (val, XUINT (value) << XINT (count));
- else if (XINT (count) <= -EMACS_INT_WIDTH)
- XSETINT (val, lsh ? 0 : XINT (value) < 0 ? -1 : 0);
- else
- XSETINT (val, (lsh ? XUINT (value) >> -XINT (count)
- : XINT (value) >> -XINT (count)));
- return val;
+ eassume (FIXNUMP (value));
+ EMACS_INT v = XFIXNUM (value) < 0 ? -1 - XFIXNUM (value) : XFIXNUM (value);
+ return make_fixnum (EMACS_UINT_WIDTH <= UINT_WIDTH
+ ? count_one_bits (v)
+ : EMACS_UINT_WIDTH <= ULONG_WIDTH
+ ? count_one_bits_l (v)
+ : count_one_bits_ll (v));
}
DEFUN ("ash", Fash, Sash, 2, 2, 0,
doc: /* Return VALUE with its bits shifted left by COUNT.
If COUNT is negative, shifting is actually to the right.
In this case, the sign bit is duplicated. */)
- (register Lisp_Object value, Lisp_Object count)
+ (Lisp_Object value, Lisp_Object count)
{
- return ash_lsh_impl (value, count, false);
+ CHECK_INTEGER (value);
+ CHECK_INTEGER (count);
+
+ if (! FIXNUMP (count))
+ {
+ if (EQ (value, make_fixnum (0)))
+ return value;
+ if (mpz_sgn (XBIGNUM (count)->value) < 0)
+ {
+ EMACS_INT v = (FIXNUMP (value) ? XFIXNUM (value)
+ : mpz_sgn (XBIGNUM (value)->value));
+ return make_fixnum (v < 0 ? -1 : 0);
+ }
+ overflow_error ();
+ }
+
+ if (XFIXNUM (count) <= 0)
+ {
+ if (XFIXNUM (count) == 0)
+ return value;
+
+ if ((EMACS_INT) -1 >> 1 == -1 && FIXNUMP (value))
+ {
+ EMACS_INT shift = -XFIXNUM (count);
+ EMACS_INT result
+ = (shift < EMACS_INT_WIDTH ? XFIXNUM (value) >> shift
+ : XFIXNUM (value) < 0 ? -1 : 0);
+ return make_fixnum (result);
+ }
+ }
+
+ mpz_t *zval = bignum_integer (&mpz[0], value);
+ if (XFIXNUM (count) < 0)
+ {
+ if (TYPE_MAXIMUM (mp_bitcnt_t) < - XFIXNUM (count))
+ return make_fixnum (mpz_sgn (*zval) < 0 ? -1 : 0);
+ mpz_fdiv_q_2exp (mpz[0], *zval, - XFIXNUM (count));
+ }
+ else
+ emacs_mpz_mul_2exp (mpz[0], *zval, XFIXNUM (count));
+ return make_integer_mpz ();
}
-DEFUN ("lsh", Flsh, Slsh, 2, 2, 0,
- doc: /* Return VALUE with its bits shifted left by COUNT.
-If COUNT is negative, shifting is actually to the right.
-In this case, zeros are shifted in on the left. */)
- (register Lisp_Object value, Lisp_Object count)
-{
- return ash_lsh_impl (value, count, true);
+/* Return X ** Y as an integer. X and Y must be integers, and Y must
+ be nonnegative. */
+
+Lisp_Object
+expt_integer (Lisp_Object x, Lisp_Object y)
+{
+ unsigned long exp;
+ if (TYPE_RANGED_FIXNUMP (unsigned long, y))
+ exp = XFIXNUM (y);
+ else if (MOST_POSITIVE_FIXNUM < ULONG_MAX && BIGNUMP (y)
+ && mpz_fits_ulong_p (XBIGNUM (y)->value))
+ exp = mpz_get_ui (XBIGNUM (y)->value);
+ else
+ overflow_error ();
+
+ emacs_mpz_pow_ui (mpz[0], *bignum_integer (&mpz[0], x), exp);
+ return make_integer_mpz ();
}
DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
@@ -3122,13 +3307,14 @@ DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
Markers are converted to integers. */)
(register Lisp_Object number)
{
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number);
+ CHECK_NUMBER_COERCE_MARKER (number);
+ if (FIXNUMP (number))
+ return make_int (XFIXNUM (number) + 1);
if (FLOATP (number))
return (make_float (1.0 + XFLOAT_DATA (number)));
-
- XSETINT (number, XINT (number) + 1);
- return number;
+ mpz_add_ui (mpz[0], XBIGNUM (number)->value, 1);
+ return make_integer_mpz ();
}
DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
@@ -3136,22 +3322,25 @@ DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
Markers are converted to integers. */)
(register Lisp_Object number)
{
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number);
+ CHECK_NUMBER_COERCE_MARKER (number);
+ if (FIXNUMP (number))
+ return make_int (XFIXNUM (number) - 1);
if (FLOATP (number))
return (make_float (-1.0 + XFLOAT_DATA (number)));
-
- XSETINT (number, XINT (number) - 1);
- return number;
+ mpz_sub_ui (mpz[0], XBIGNUM (number)->value, 1);
+ return make_integer_mpz ();
}
DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
doc: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
(register Lisp_Object number)
{
- CHECK_NUMBER (number);
- XSETINT (number, ~XINT (number));
- return number;
+ CHECK_INTEGER (number);
+ if (FIXNUMP (number))
+ return make_fixnum (~XFIXNUM (number));
+ mpz_com (mpz[0], XBIGNUM (number)->value);
+ return make_integer_mpz ();
}
DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0,
@@ -3164,7 +3353,7 @@ lowercase l) for small endian machines. */
unsigned i = 0x04030201;
int order = *(char *)&i == 1 ? 108 : 66;
- return make_number (order);
+ return make_fixnum (order);
}
/* Because we round up the bool vector allocate size to word_size
@@ -3517,7 +3706,7 @@ value from A's length. */)
for (i = 0; i < nwords; i++)
count += count_one_bits_word (adata[i]);
- return make_number (count);
+ return make_fixnum (count);
}
DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive,
@@ -3536,16 +3725,16 @@ A is a bool vector, B is t or nil, and I is an index into A. */)
ptrdiff_t nr_words;
CHECK_BOOL_VECTOR (a);
- CHECK_NATNUM (i);
+ CHECK_FIXNAT (i);
nr_bits = bool_vector_size (a);
- if (XFASTINT (i) > nr_bits) /* Allow one past the end for convenience */
+ if (XFIXNAT (i) > nr_bits) /* Allow one past the end for convenience */
args_out_of_range (a, i);
adata = bool_vector_data (a);
nr_words = bool_vector_words (nr_bits);
- pos = XFASTINT (i) / BITS_PER_BITS_WORD;
- offset = XFASTINT (i) % BITS_PER_BITS_WORD;
+ pos = XFIXNAT (i) / BITS_PER_BITS_WORD;
+ offset = XFIXNAT (i) % BITS_PER_BITS_WORD;
count = 0;
/* By XORing with twiddle, we transform the problem of "count
@@ -3566,7 +3755,7 @@ A is a bool vector, B is t or nil, and I is an index into A. */)
count = count_trailing_zero_bits (mword);
pos++;
if (count + offset < BITS_PER_BITS_WORD)
- return make_number (count);
+ return make_fixnum (count);
}
/* Scan whole words until we either reach the end of the vector or
@@ -3593,7 +3782,7 @@ A is a bool vector, B is t or nil, and I is an index into A. */)
count -= BITS_PER_BITS_WORD - nr_bits % BITS_PER_BITS_WORD;
}
- return make_number (count);
+ return make_fixnum (count);
}
@@ -3636,6 +3825,7 @@ syms_of_data (void)
DEFSYM (Qlistp, "listp");
DEFSYM (Qconsp, "consp");
DEFSYM (Qsymbolp, "symbolp");
+ DEFSYM (Qfixnump, "fixnump");
DEFSYM (Qintegerp, "integerp");
DEFSYM (Qnatnump, "natnump");
DEFSYM (Qwholenump, "wholenump");
@@ -3833,17 +4023,12 @@ syms_of_data (void)
defsubr (&Sdefault_boundp);
defsubr (&Sdefault_value);
defsubr (&Sset_default);
- defsubr (&Ssetq_default);
defsubr (&Smake_variable_buffer_local);
defsubr (&Smake_local_variable);
defsubr (&Skill_local_variable);
defsubr (&Slocal_variable_p);
defsubr (&Slocal_variable_if_set_p);
defsubr (&Svariable_binding_locus);
-#if 0 /* XXX Remove this. --lorentey */
- defsubr (&Sterminal_local_value);
- defsubr (&Sset_terminal_local_value);
-#endif
defsubr (&Saref);
defsubr (&Saset);
defsubr (&Snumber_to_string);
@@ -3865,7 +4050,7 @@ syms_of_data (void)
defsubr (&Slogand);
defsubr (&Slogior);
defsubr (&Slogxor);
- defsubr (&Slsh);
+ defsubr (&Slogcount);
defsubr (&Sash);
defsubr (&Sadd1);
defsubr (&Ssub1);
@@ -3889,15 +4074,15 @@ syms_of_data (void)
set_symbol_function (Qwholenump, XSYMBOL (Qnatnump)->u.s.function);
DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum,
- doc: /* The largest value that is representable in a Lisp integer.
+ doc: /* The greatest integer that is represented efficiently.
This variable cannot be set; trying to do so will signal an error. */);
- Vmost_positive_fixnum = make_number (MOST_POSITIVE_FIXNUM);
+ Vmost_positive_fixnum = make_fixnum (MOST_POSITIVE_FIXNUM);
make_symbol_constant (intern_c_string ("most-positive-fixnum"));
DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum,
- doc: /* The smallest value that is representable in a Lisp integer.
+ doc: /* The least integer that is represented efficiently.
This variable cannot be set; trying to do so will signal an error. */);
- Vmost_negative_fixnum = make_number (MOST_NEGATIVE_FIXNUM);
+ Vmost_negative_fixnum = make_fixnum (MOST_NEGATIVE_FIXNUM);
make_symbol_constant (intern_c_string ("most-negative-fixnum"));
DEFSYM (Qwatchers, "watchers");
diff --git a/src/dbusbind.c b/src/dbusbind.c
index 6ae9bc7f538..0afae6b05ad 100644
--- a/src/dbusbind.c
+++ b/src/dbusbind.c
@@ -200,17 +200,17 @@ xd_symbol_to_dbus_type (Lisp_Object object)
`dbus-send-signal', into corresponding C values appended as
arguments to a D-Bus message. */
#define XD_OBJECT_TO_DBUS_TYPE(object) \
- ((EQ (object, Qt) || EQ (object, Qnil)) ? DBUS_TYPE_BOOLEAN \
- : (NATNUMP (object)) ? DBUS_TYPE_UINT32 \
- : (INTEGERP (object)) ? DBUS_TYPE_INT32 \
+ ((EQ (object, Qt) || NILP (object)) ? DBUS_TYPE_BOOLEAN \
+ : (FIXNATP (object)) ? DBUS_TYPE_UINT32 \
+ : (FIXNUMP (object)) ? DBUS_TYPE_INT32 \
: (FLOATP (object)) ? DBUS_TYPE_DOUBLE \
: (STRINGP (object)) ? DBUS_TYPE_STRING \
: (XD_DBUS_TYPE_P (object)) ? xd_symbol_to_dbus_type (object) \
: (CONSP (object)) \
- ? ((XD_DBUS_TYPE_P (CAR_SAFE (object))) \
- ? ((XD_BASIC_DBUS_TYPE (xd_symbol_to_dbus_type (CAR_SAFE (object)))) \
+ ? ((XD_DBUS_TYPE_P (XCAR (object))) \
+ ? ((XD_BASIC_DBUS_TYPE (xd_symbol_to_dbus_type (XCAR (object)))) \
? DBUS_TYPE_ARRAY \
- : xd_symbol_to_dbus_type (CAR_SAFE (object))) \
+ : xd_symbol_to_dbus_type (XCAR (object))) \
: DBUS_TYPE_ARRAY) \
: DBUS_TYPE_INVALID)
@@ -355,18 +355,18 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object)
{
case DBUS_TYPE_BYTE:
case DBUS_TYPE_UINT16:
- CHECK_NATNUM (object);
+ CHECK_FIXNAT (object);
sprintf (signature, "%c", dtype);
break;
case DBUS_TYPE_BOOLEAN:
- if (!EQ (object, Qt) && !EQ (object, Qnil))
+ if (!EQ (object, Qt) && !NILP (object))
wrong_type_argument (intern ("booleanp"), object);
sprintf (signature, "%c", dtype);
break;
case DBUS_TYPE_INT16:
- CHECK_NUMBER (object);
+ CHECK_FIXNUM (object);
sprintf (signature, "%c", dtype);
break;
@@ -378,7 +378,7 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object)
case DBUS_TYPE_INT32:
case DBUS_TYPE_INT64:
case DBUS_TYPE_DOUBLE:
- CHECK_NUMBER_OR_FLOAT (object);
+ CHECK_NUMBER (object);
sprintf (signature, "%c", dtype);
break;
@@ -396,7 +396,7 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object)
CHECK_CONS (object);
/* Type symbol is optional. */
- if (EQ (QCarray, CAR_SAFE (elt)))
+ if (EQ (QCarray, XCAR (elt)))
elt = XD_NEXT_VALUE (elt);
/* If the array is empty, DBUS_TYPE_STRING is the default
@@ -416,10 +416,12 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object)
/* If the element type is DBUS_TYPE_SIGNATURE, and this is the
only element, the value of this element is used as the
array's element signature. */
- if ((subtype == DBUS_TYPE_SIGNATURE)
- && STRINGP (CAR_SAFE (XD_NEXT_VALUE (elt)))
- && NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
- subsig = SSDATA (CAR_SAFE (XD_NEXT_VALUE (elt)));
+ if (subtype == DBUS_TYPE_SIGNATURE)
+ {
+ Lisp_Object elt1 = XD_NEXT_VALUE (elt);
+ if (CONSP (elt1) && STRINGP (XCAR (elt1)) && NILP (XCDR (elt1)))
+ subsig = SSDATA (XCAR (elt1));
+ }
while (!NILP (elt))
{
@@ -517,11 +519,12 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object)
static intmax_t
xd_extract_signed (Lisp_Object x, intmax_t lo, intmax_t hi)
{
- CHECK_NUMBER_OR_FLOAT (x);
+ CHECK_NUMBER (x);
if (INTEGERP (x))
{
- if (lo <= XINT (x) && XINT (x) <= hi)
- return XINT (x);
+ intmax_t i;
+ if (integer_to_intmax (x, &i) && lo <= i && i <= hi)
+ return i;
}
else
{
@@ -533,23 +536,23 @@ xd_extract_signed (Lisp_Object x, intmax_t lo, intmax_t hi)
return n;
}
}
+
if (xd_in_read_queued_messages)
Fthrow (Qdbus_error, Qnil);
else
- args_out_of_range_3 (x,
- make_fixnum_or_float (lo),
- make_fixnum_or_float (hi));
+ args_out_of_range_3 (x, INT_TO_INTEGER (lo), INT_TO_INTEGER (hi));
}
/* Convert X to an unsigned integer with bounds 0 and HI. */
static uintmax_t
xd_extract_unsigned (Lisp_Object x, uintmax_t hi)
{
- CHECK_NUMBER_OR_FLOAT (x);
+ CHECK_NUMBER (x);
if (INTEGERP (x))
{
- if (0 <= XINT (x) && XINT (x) <= hi)
- return XINT (x);
+ uintmax_t i;
+ if (integer_to_uintmax (x, &i) && i <= hi)
+ return i;
}
else
{
@@ -561,10 +564,11 @@ xd_extract_unsigned (Lisp_Object x, uintmax_t hi)
return n;
}
}
+
if (xd_in_read_queued_messages)
Fthrow (Qdbus_error, Qnil);
else
- args_out_of_range_3 (x, make_number (0), make_fixnum_or_float (hi));
+ args_out_of_range_3 (x, make_fixnum (0), INT_TO_INTEGER (hi));
}
/* Append C value, extracted from Lisp OBJECT, to iteration ITER.
@@ -582,9 +586,9 @@ xd_append_arg (int dtype, Lisp_Object object, DBusMessageIter *iter)
switch (dtype)
{
case DBUS_TYPE_BYTE:
- CHECK_NATNUM (object);
+ CHECK_FIXNAT (object);
{
- unsigned char val = XFASTINT (object) & 0xFF;
+ unsigned char val = XFIXNAT (object) & 0xFF;
XD_DEBUG_MESSAGE ("%c %u", dtype, val);
if (!dbus_message_iter_append_basic (iter, dtype, &val))
XD_SIGNAL2 (build_string ("Unable to append argument"), object);
@@ -748,7 +752,7 @@ xd_append_arg (int dtype, Lisp_Object object, DBusMessageIter *iter)
if (!dbus_message_iter_open_container (iter, dtype,
signature, &subiter))
XD_SIGNAL3 (build_string ("Cannot open container"),
- make_number (dtype), build_string (signature));
+ make_fixnum (dtype), build_string (signature));
break;
case DBUS_TYPE_VARIANT:
@@ -761,7 +765,7 @@ xd_append_arg (int dtype, Lisp_Object object, DBusMessageIter *iter)
if (!dbus_message_iter_open_container (iter, dtype,
signature, &subiter))
XD_SIGNAL3 (build_string ("Cannot open container"),
- make_number (dtype), build_string (signature));
+ make_fixnum (dtype), build_string (signature));
break;
case DBUS_TYPE_STRUCT:
@@ -770,7 +774,7 @@ xd_append_arg (int dtype, Lisp_Object object, DBusMessageIter *iter)
XD_DEBUG_MESSAGE ("%c %s", dtype, XD_OBJECT_TO_STRING (object));
if (!dbus_message_iter_open_container (iter, dtype, NULL, &subiter))
XD_SIGNAL2 (build_string ("Cannot open container"),
- make_number (dtype));
+ make_fixnum (dtype));
break;
}
@@ -788,7 +792,7 @@ xd_append_arg (int dtype, Lisp_Object object, DBusMessageIter *iter)
/* Close the subiteration. */
if (!dbus_message_iter_close_container (iter, &subiter))
XD_SIGNAL2 (build_string ("Cannot close container"),
- make_number (dtype));
+ make_fixnum (dtype));
}
}
@@ -808,7 +812,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter)
dbus_message_iter_get_basic (iter, &val);
val = val & 0xFF;
XD_DEBUG_MESSAGE ("%c %u", dtype, val);
- return make_number (val);
+ return make_fixnum (val);
}
case DBUS_TYPE_BOOLEAN:
@@ -826,7 +830,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter)
dbus_message_iter_get_basic (iter, &val);
pval = val;
XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
- return make_number (val);
+ return make_fixnum (val);
}
case DBUS_TYPE_UINT16:
@@ -836,7 +840,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter)
dbus_message_iter_get_basic (iter, &val);
pval = val;
XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
- return make_number (val);
+ return make_fixnum (val);
}
case DBUS_TYPE_INT32:
@@ -846,7 +850,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter)
dbus_message_iter_get_basic (iter, &val);
pval = val;
XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
- return make_fixnum_or_float (val);
+ return INT_TO_INTEGER (val);
}
case DBUS_TYPE_UINT32:
@@ -859,7 +863,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter)
dbus_message_iter_get_basic (iter, &val);
pval = val;
XD_DEBUG_MESSAGE ("%c %u", dtype, pval);
- return make_fixnum_or_float (val);
+ return INT_TO_INTEGER (val);
}
case DBUS_TYPE_INT64:
@@ -869,7 +873,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter)
dbus_message_iter_get_basic (iter, &val);
pval = val;
XD_DEBUG_MESSAGE ("%c %"pMd, dtype, pval);
- return make_fixnum_or_float (val);
+ return INT_TO_INTEGER (val);
}
case DBUS_TYPE_UINT64:
@@ -879,7 +883,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter)
dbus_message_iter_get_basic (iter, &val);
pval = val;
XD_DEBUG_MESSAGE ("%c %"pMu, dtype, pval);
- return make_fixnum_or_float (val);
+ return INT_TO_INTEGER (val);
}
case DBUS_TYPE_DOUBLE:
@@ -944,7 +948,7 @@ xd_get_connection_references (DBusConnection *connection)
static DBusConnection *
xd_lisp_dbus_to_dbus (Lisp_Object bus)
{
- return (DBusConnection *) XSAVE_POINTER (bus, 0);
+ return xmint_pointer (bus);
}
/* Return D-Bus connection address. BUS is either a Lisp symbol,
@@ -1187,7 +1191,7 @@ this connection to those buses. */)
XD_SIGNAL1 (build_string ("Cannot add watch functions"));
/* Add bus to list of registered buses. */
- val = make_save_ptr (connection);
+ val = make_mint_ptr (connection);
xd_registered_buses = Fcons (Fcons (bus, val), xd_registered_buses);
/* Cleanup. */
@@ -1198,7 +1202,7 @@ this connection to those buses. */)
refcount = xd_get_connection_references (connection);
XD_DEBUG_MESSAGE ("Bus %s, Reference counter %"pD"d",
XD_OBJECT_TO_STRING (bus), refcount);
- return make_number (refcount);
+ return make_fixnum (refcount);
}
DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name,
@@ -1273,11 +1277,11 @@ usage: (dbus-message-internal &rest REST) */)
service = args[2];
handler = Qnil;
- CHECK_NATNUM (message_type);
- if (! (DBUS_MESSAGE_TYPE_INVALID < XFASTINT (message_type)
- && XFASTINT (message_type) < DBUS_NUM_MESSAGE_TYPES))
+ CHECK_FIXNAT (message_type);
+ if (! (DBUS_MESSAGE_TYPE_INVALID < XFIXNAT (message_type)
+ && XFIXNAT (message_type) < DBUS_NUM_MESSAGE_TYPES))
XD_SIGNAL2 (build_string ("Invalid message type"), message_type);
- mtype = XFASTINT (message_type);
+ mtype = XFIXNAT (message_type);
if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
|| (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
@@ -1301,7 +1305,7 @@ usage: (dbus-message-internal &rest REST) */)
if (nargs < count)
xsignal2 (Qwrong_number_of_arguments,
Qdbus_message_internal,
- make_number (nargs));
+ make_fixnum (nargs));
if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
|| (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
@@ -1407,8 +1411,8 @@ usage: (dbus-message-internal &rest REST) */)
/* Check for timeout parameter. */
if ((count + 2 <= nargs) && EQ (args[count], QCtimeout))
{
- CHECK_NATNUM (args[count+1]);
- timeout = min (XFASTINT (args[count+1]), INT_MAX);
+ CHECK_FIXNAT (args[count+1]);
+ timeout = min (XFIXNAT (args[count+1]), INT_MAX);
count = count+2;
}
@@ -1452,7 +1456,7 @@ usage: (dbus-message-internal &rest REST) */)
/* The result is the key in Vdbus_registered_objects_table. */
serial = dbus_message_get_serial (dmessage);
- result = list3 (QCserial, bus, make_fixnum_or_float (serial));
+ result = list3 (QCserial, bus, INT_TO_INTEGER (serial));
/* Create a hash table entry. */
Fputhash (result, handler, Vdbus_registered_objects_table);
@@ -1539,7 +1543,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
|| (mtype == DBUS_MESSAGE_TYPE_ERROR))
{
/* Search for a registered function of the message. */
- key = list3 (QCserial, bus, make_fixnum_or_float (serial));
+ key = list3 (QCserial, bus, INT_TO_INTEGER (serial));
value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
/* There shall be exactly one entry. Construct an event. */
@@ -1606,8 +1610,8 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
event.arg);
event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
event.arg);
- event.arg = Fcons (make_fixnum_or_float (serial), event.arg);
- event.arg = Fcons (make_number (mtype), event.arg);
+ event.arg = Fcons (INT_TO_INTEGER (serial), event.arg);
+ event.arg = Fcons (make_fixnum (mtype), event.arg);
/* Add the bus symbol to the event. */
event.arg = Fcons (bus, event.arg);
@@ -1752,28 +1756,28 @@ syms_of_dbusbind (void)
DEFVAR_LISP ("dbus-message-type-invalid",
Vdbus_message_type_invalid,
doc: /* This value is never a valid message type. */);
- Vdbus_message_type_invalid = make_number (DBUS_MESSAGE_TYPE_INVALID);
+ Vdbus_message_type_invalid = make_fixnum (DBUS_MESSAGE_TYPE_INVALID);
DEFVAR_LISP ("dbus-message-type-method-call",
Vdbus_message_type_method_call,
doc: /* Message type of a method call message. */);
- Vdbus_message_type_method_call = make_number (DBUS_MESSAGE_TYPE_METHOD_CALL);
+ Vdbus_message_type_method_call = make_fixnum (DBUS_MESSAGE_TYPE_METHOD_CALL);
DEFVAR_LISP ("dbus-message-type-method-return",
Vdbus_message_type_method_return,
doc: /* Message type of a method return message. */);
Vdbus_message_type_method_return
- = make_number (DBUS_MESSAGE_TYPE_METHOD_RETURN);
+ = make_fixnum (DBUS_MESSAGE_TYPE_METHOD_RETURN);
DEFVAR_LISP ("dbus-message-type-error",
Vdbus_message_type_error,
doc: /* Message type of an error reply message. */);
- Vdbus_message_type_error = make_number (DBUS_MESSAGE_TYPE_ERROR);
+ Vdbus_message_type_error = make_fixnum (DBUS_MESSAGE_TYPE_ERROR);
DEFVAR_LISP ("dbus-message-type-signal",
Vdbus_message_type_signal,
doc: /* Message type of a signal message. */);
- Vdbus_message_type_signal = make_number (DBUS_MESSAGE_TYPE_SIGNAL);
+ Vdbus_message_type_signal = make_fixnum (DBUS_MESSAGE_TYPE_SIGNAL);
DEFVAR_LISP ("dbus-registered-objects-table",
Vdbus_registered_objects_table,
@@ -1827,6 +1831,8 @@ be called when the D-Bus reply message arrives. */);
xd_registered_buses = Qnil;
staticpro (&xd_registered_buses);
+ // TODO: reset buses on dump load
+
Fprovide (intern_c_string ("dbusbind"), Qnil);
}
diff --git a/src/decompress.c b/src/decompress.c
index a24b9f0678e..4ca6a50b2a2 100644
--- a/src/decompress.c
+++ b/src/decompress.c
@@ -24,11 +24,13 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "lisp.h"
#include "buffer.h"
+#include "composite.h"
#include <verify.h>
#ifdef WINDOWSNT
# include <windows.h>
+# include "w32common.h"
# include "w32.h"
DEF_DLL_FN (int, inflateInit2_,
@@ -66,7 +68,7 @@ init_zlib_functions (void)
struct decompress_unwind_data
{
- ptrdiff_t old_point, start, nbytes;
+ ptrdiff_t old_point, orig, start, nbytes;
z_stream *stream;
};
@@ -76,10 +78,19 @@ unwind_decompress (void *ddata)
struct decompress_unwind_data *data = ddata;
inflateEnd (data->stream);
- /* Delete any uncompressed data already inserted on error. */
+ /* Delete any uncompressed data already inserted on error, but
+ without calling the change hooks. */
if (data->start)
- del_range (data->start, data->start + data->nbytes);
-
+ {
+ del_range_2 (data->start, data->start, /* byte, char offsets the same */
+ data->start + data->nbytes, data->start + data->nbytes,
+ 0);
+ update_compositions (data->start, data->start, CHECK_HEAD);
+ /* "Balance" the before-change-functions call, which would
+ otherwise be left "hanging". */
+ signal_after_change (data->orig, data->start - data->orig,
+ data->start - data->orig);
+ }
/* Put point where it was, or if the buffer has shrunk because the
compressed data is bigger than the uncompressed, at
point-max. */
@@ -109,12 +120,18 @@ DEFUN ("zlib-available-p", Fzlib_available_p, Szlib_available_p, 0, 0, 0,
DEFUN ("zlib-decompress-region", Fzlib_decompress_region,
Szlib_decompress_region,
- 2, 2, 0,
+ 2, 3, 0,
doc: /* Decompress a gzip- or zlib-compressed region.
Replace the text in the region by the decompressed data.
-On failure, return nil and leave the data in place.
+
+If optional parameter ALLOW-PARTIAL is nil or omitted, then on
+failure, return nil and leave the data in place. Otherwise, return
+the number of bytes that were not decompressed and replace the region
+text by whatever data was successfully decompressed (similar to gzip).
+If decompression is completely successful return t.
+
This function can be called only in unibyte buffers. */)
- (Lisp_Object start, Lisp_Object end)
+ (Lisp_Object start, Lisp_Object end, Lisp_Object allow_partial)
{
ptrdiff_t istart, iend, pos_byte;
z_stream stream;
@@ -139,8 +156,12 @@ This function can be called only in unibyte buffers. */)
/* This is a unibyte buffer, so character positions and bytes are
the same. */
- istart = XINT (start);
- iend = XINT (end);
+ istart = XFIXNUM (start);
+ iend = XFIXNUM (end);
+
+ /* Do the following before manipulating the gap. */
+ modify_text (istart, iend);
+
move_gap_both (iend, iend);
stream.zalloc = Z_NULL;
@@ -154,6 +175,7 @@ This function can be called only in unibyte buffers. */)
if (inflateInit2 (&stream, MAX_WBITS + 32) != Z_OK)
return Qnil;
+ unwind_data.orig = istart;
unwind_data.start = iend;
unwind_data.stream = &stream;
unwind_data.old_point = PT;
@@ -190,15 +212,25 @@ This function can be called only in unibyte buffers. */)
}
while (inflate_status == Z_OK);
+ Lisp_Object ret = Qt;
if (inflate_status != Z_STREAM_END)
- return unbind_to (count, Qnil);
+ {
+ if (!NILP (allow_partial))
+ ret = make_int (iend - pos_byte);
+ else
+ return unbind_to (count, Qnil);
+ }
unwind_data.start = 0;
/* Delete the compressed data. */
- del_range (istart, iend);
+ del_range_2 (istart, istart, /* byte and char offsets are the same. */
+ iend, iend, 0);
+
+ signal_after_change (istart, iend - istart, unwind_data.nbytes);
+ update_compositions (istart, istart, CHECK_HEAD);
- return unbind_to (count, Qt);
+ return unbind_to (count, ret);
}
diff --git a/src/deps.mk b/src/deps.mk
index 4db66e79da6..2cdeba8d4ae 100644
--- a/src/deps.mk
+++ b/src/deps.mk
@@ -71,7 +71,7 @@ cmds.o: cmds.c syntax.h buffer.h character.h commands.h window.h lisp.h \
pre-crt0.o: pre-crt0.c
dbusbind.o: dbusbind.c termhooks.h frame.h keyboard.h lisp.h $(config_h)
dired.o: dired.c commands.h buffer.h lisp.h $(config_h) character.h charset.h \
- coding.h regex.h systime.h blockinput.h atimer.h composite.h \
+ coding.h regex-emacs.h systime.h blockinput.h atimer.h composite.h \
../lib/filemode.h ../lib/unistd.h globals.h
dispnew.o: dispnew.c systime.h commands.h process.h frame.h coding.h \
window.h buffer.h termchar.h termopts.h termhooks.h cm.h \
@@ -169,20 +169,21 @@ process.o: process.c process.h buffer.h window.h termhooks.h termopts.h \
blockinput.h atimer.h coding.h msdos.h nsterm.h composite.h \
keyboard.h lisp.h globals.h $(config_h) character.h xgselect.h sysselect.h \
../lib/unistd.h gnutls.h
-regex.o: regex.c syntax.h buffer.h lisp.h globals.h $(config_h) regex.h \
+regex-emacs.o: regex-emacs.c syntax.h buffer.h lisp.h globals.h \
+ $(config_h) regex-emacs.h \
category.h character.h
region-cache.o: region-cache.c buffer.h region-cache.h \
lisp.h globals.h $(config_h)
scroll.o: scroll.c termchar.h dispextern.h frame.h msdos.h keyboard.h \
termhooks.h lisp.h globals.h $(config_h) systime.h coding.h composite.h \
window.h
-search.o: search.c regex.h commands.h buffer.h region-cache.h syntax.h \
+search.o: search.c regex-emacs.h commands.h buffer.h region-cache.h syntax.h \
blockinput.h atimer.h systime.h category.h character.h charset.h \
$(INTERVALS_H) lisp.h globals.h $(config_h)
sound.o: sound.c dispextern.h syssignal.h lisp.h globals.h $(config_h) \
atimer.h systime.h ../lib/unistd.h msdos.h
syntax.o: syntax.c syntax.h buffer.h commands.h category.h character.h \
- keymap.h regex.h $(INTERVALS_H) lisp.h globals.h $(config_h)
+ keymap.h regex-emacs.h $(INTERVALS_H) lisp.h globals.h $(config_h)
sysdep.o: sysdep.c syssignal.h systty.h systime.h syswait.h blockinput.h \
process.h dispextern.h termhooks.h termchar.h termopts.h coding.h \
frame.h atimer.h window.h msdos.h dosfns.h keyboard.h cm.h lisp.h \
diff --git a/src/dired.c b/src/dired.c
index aa5b06a8ef6..493758292b9 100644
--- a/src/dired.c
+++ b/src/dired.c
@@ -40,7 +40,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "systime.h"
#include "buffer.h"
#include "coding.h"
-#include "regex.h"
#ifdef MSDOS
#include "msdos.h" /* for fstatat */
@@ -171,7 +170,6 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full,
{
ptrdiff_t directory_nbytes;
Lisp_Object list, dirfilename, encoded_directory;
- struct re_pattern_buffer *bufp = NULL;
bool needsep = 0;
ptrdiff_t count = SPECPDL_INDEX ();
#ifdef WINDOWSNT
@@ -187,33 +185,12 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full,
list = encoded_directory = dirfilename = Qnil;
dirfilename = Fdirectory_file_name (directory);
- if (!NILP (match))
- {
- CHECK_STRING (match);
-
- /* MATCH might be a flawed regular expression. Rather than
- catching and signaling our own errors, we just call
- compile_pattern to do the work for us. */
- /* Pass 1 for the MULTIBYTE arg
- because we do make multibyte strings if the contents warrant. */
-# ifdef WINDOWSNT
- /* Windows users want case-insensitive wildcards. */
- bufp = compile_pattern (match, 0,
- BVAR (&buffer_defaults, case_canon_table), 0, 1);
-# else /* !WINDOWSNT */
- bufp = compile_pattern (match, 0, Qnil, 0, 1);
-# endif /* !WINDOWSNT */
- }
-
/* Note: ENCODE_FILE and DECODE_FILE can GC because they can run
run_pre_post_conversion_on_str which calls Lisp directly and
indirectly. */
dirfilename = ENCODE_FILE (dirfilename);
encoded_directory = ENCODE_FILE (directory);
- /* Now *bufp is the compiled form of MATCH; don't call anything
- which might compile a new regexp until we're done with the loop! */
-
int fd;
DIR *d = open_directory (dirfilename, &fd);
@@ -250,6 +227,18 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full,
|| !IS_ANY_SEP (SREF (directory, directory_nbytes - 1)))
needsep = 1;
+ /* Windows users want case-insensitive wildcards. */
+ Lisp_Object case_table =
+#ifdef WINDOWSNT
+ BVAR (&buffer_defaults, case_canon_table)
+#else
+ Qnil
+#endif
+ ;
+
+ if (!NILP (match))
+ CHECK_STRING (match);
+
/* Loop reading directory entries. */
for (struct dirent *dp; (dp = read_dirent (d, directory)); )
{
@@ -266,8 +255,9 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full,
allow matching to be interrupted. */
maybe_quit ();
- bool wanted = (NILP (match)
- || re_search (bufp, SSDATA (name), len, 0, len, 0) >= 0);
+ bool wanted = (NILP (match) ||
+ fast_string_match_internal (
+ match, name, case_table) >= 0);
if (wanted)
{
@@ -346,7 +336,7 @@ If NOSORT is non-nil, the list is not sorted--its order is unpredictable.
directory = Fexpand_file_name (directory, Qnil);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (directory, Qdirectory_files);
if (!NILP (handler))
return call5 (handler, Qdirectory_files, directory,
@@ -360,7 +350,7 @@ DEFUN ("directory-files-and-attributes", Fdirectory_files_and_attributes,
doc: /* Return a list of names of files and their attributes in DIRECTORY.
Value is a list of the form:
- ((FILE1 FILE1-ATTRS) (FILE2 FILE2-ATTRS) ...)
+ ((FILE1 . FILE1-ATTRS) (FILE2 . FILE2-ATTRS) ...)
where each FILEn-ATTRS is the attributes of FILEn as returned
by `file-attributes'.
@@ -381,7 +371,7 @@ which see. */)
directory = Fexpand_file_name (directory, Qnil);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (directory, Qdirectory_files_and_attributes);
if (!NILP (handler))
return call6 (handler, Qdirectory_files_and_attributes,
@@ -416,13 +406,13 @@ is matched against file and directory names relative to DIRECTORY. */)
directory = Fexpand_file_name (directory, Qnil);
/* If the directory name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (directory, Qfile_name_completion);
if (!NILP (handler))
return call4 (handler, Qfile_name_completion, file, directory, predicate);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (file, Qfile_name_completion);
if (!NILP (handler))
return call4 (handler, Qfile_name_completion, file, directory, predicate);
@@ -444,13 +434,13 @@ is matched against file and directory names relative to DIRECTORY. */)
directory = Fexpand_file_name (directory, Qnil);
/* If the directory name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (directory, Qfile_name_all_completions);
if (!NILP (handler))
return call3 (handler, Qfile_name_all_completions, file, directory);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (file, Qfile_name_all_completions);
if (!NILP (handler))
return call3 (handler, Qfile_name_all_completions, file, directory);
@@ -684,15 +674,15 @@ file_name_completion (Lisp_Object file, Lisp_Object dirname, bool all_flag,
/* Reject entries where the encoded strings match, but the
decoded don't. For example, "a" should not match "a-ring" on
file systems that store decomposed characters. */
- Lisp_Object zero = make_number (0);
+ Lisp_Object zero = make_fixnum (0);
if (check_decoded && SCHARS (file) <= SCHARS (name))
{
/* FIXME: This is a copy of the code below. */
ptrdiff_t compare = SCHARS (file);
Lisp_Object cmp
- = Fcompare_strings (name, zero, make_number (compare),
- file, zero, make_number (compare),
+ = Fcompare_strings (name, zero, make_fixnum (compare),
+ file, zero, make_fixnum (compare),
completion_ignore_case ? Qt : Qnil);
if (!EQ (cmp, Qt))
continue;
@@ -714,10 +704,10 @@ file_name_completion (Lisp_Object file, Lisp_Object dirname, bool all_flag,
/* FIXME: This is a copy of the code in Ftry_completion. */
ptrdiff_t compare = min (bestmatchsize, SCHARS (name));
Lisp_Object cmp
- = Fcompare_strings (bestmatch, zero, make_number (compare),
- name, zero, make_number (compare),
+ = Fcompare_strings (bestmatch, zero, make_fixnum (compare),
+ name, zero, make_fixnum (compare),
completion_ignore_case ? Qt : Qnil);
- ptrdiff_t matchsize = EQ (cmp, Qt) ? compare : eabs (XINT (cmp)) - 1;
+ ptrdiff_t matchsize = EQ (cmp, Qt) ? compare : eabs (XFIXNUM (cmp)) - 1;
if (completion_ignore_case)
{
@@ -742,13 +732,13 @@ file_name_completion (Lisp_Object file, Lisp_Object dirname, bool all_flag,
==
(matchsize + directoryp == SCHARS (bestmatch)))
&& (cmp = Fcompare_strings (name, zero,
- make_number (SCHARS (file)),
+ make_fixnum (SCHARS (file)),
file, zero,
Qnil,
Qnil),
EQ (Qt, cmp))
&& (cmp = Fcompare_strings (bestmatch, zero,
- make_number (SCHARS (file)),
+ make_fixnum (SCHARS (file)),
file, zero,
Qnil,
Qnil),
@@ -782,8 +772,8 @@ file_name_completion (Lisp_Object file, Lisp_Object dirname, bool all_flag,
it does not require any change to be made. */
if (matchcount == 1 && !NILP (Fequal (bestmatch, file)))
return Qt;
- bestmatch = Fsubstring (bestmatch, make_number (0),
- make_number (bestmatchsize));
+ bestmatch = Fsubstring (bestmatch, make_fixnum (0),
+ make_fixnum (bestmatchsize));
return bestmatch;
}
@@ -879,28 +869,22 @@ provided: `file-attribute-type', `file-attribute-link-number',
Elements of the attribute list are:
0. t for directory, string (name linked to) for symbolic link, or nil.
1. Number of links to file.
- 2. File uid as a string or a number. If a string value cannot be
- looked up, a numeric value, either an integer or a float, is returned.
+ 2. File uid as a string or (if ID-FORMAT is `integer' or a string value
+ cannot be looked up) as an integer.
3. File gid, likewise.
- 4. Last access time, as a list of integers (HIGH LOW USEC PSEC) in the
- same style as (current-time).
+ 4. Last access time, in the style of `current-time'.
(See a note below about access time on FAT-based filesystems.)
5. Last modification time, likewise. This is the time of the last
change to the file's contents.
6. Last status change time, likewise. This is the time of last change
to the file's attributes: owner and group, access mode bits, etc.
- 7. Size in bytes.
- This is a floating point number if the size is too large for an integer.
+ 7. Size in bytes, as an integer.
8. File modes, as a string of ten letters or dashes as in ls -l.
9. An unspecified value, present only for backward compatibility.
-10. inode number. If it is larger than what an Emacs integer can hold,
- this is of the form (HIGH . LOW): first the high bits, then the low 16 bits.
- If even HIGH is too large for an Emacs integer, this is instead of the form
- (HIGH MIDDLE . LOW): first the high bits, then the middle 24 bits,
- and finally the low 16 bits.
-11. Filesystem device number. If it is larger than what the Emacs
- integer can hold, this is a cons cell, similar to the inode number.
+10. inode number, as a nonnegative integer.
+11. Filesystem device number, as an integer.
+Large integers are bignums, so `eq' might not work on them.
On most filesystems, the combination of the inode and the device
number uniquely identifies the file.
@@ -920,11 +904,12 @@ so last access time will always be midnight of that day. */)
return Qnil;
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (filename, Qfile_attributes);
if (!NILP (handler))
- { /* Only pass the extra arg if it is used to help backward compatibility
- with old file handlers which do not implement the new arg. --Stef */
+ { /* Only pass the extra arg if it is used to help backward
+ compatibility with old file name handlers which do not
+ implement the new arg. --Stef */
if (NILP (id_format))
return call2 (handler, Qfile_attributes, filename);
else
@@ -945,7 +930,7 @@ file_attributes (int fd, char const *name,
struct stat s;
/* An array to hold the mode string generated by filemodestring,
- including its terminating space and null byte. */
+ including its terminating space and NUL byte. */
char modes[sizeof "-rwxr-xr-x "];
char *uname = NULL, *gname = NULL;
@@ -1022,13 +1007,13 @@ file_attributes (int fd, char const *name,
return CALLN (Flist,
file_type,
- make_number (s.st_nlink),
+ make_fixnum (s.st_nlink),
(uname
? DECODE_SYSTEM (build_unibyte_string (uname))
- : make_fixnum_or_float (s.st_uid)),
+ : INT_TO_INTEGER (s.st_uid)),
(gname
? DECODE_SYSTEM (build_unibyte_string (gname))
- : make_fixnum_or_float (s.st_gid)),
+ : INT_TO_INTEGER (s.st_gid)),
make_lisp_time (get_stat_atime (&s)),
make_lisp_time (get_stat_mtime (&s)),
make_lisp_time (get_stat_ctime (&s)),
@@ -1037,14 +1022,14 @@ file_attributes (int fd, char const *name,
files of sizes in the 2-4 GiB range wrap around to
negative values, as this is a common bug on older
32-bit platforms. */
- make_fixnum_or_float (sizeof (s.st_size) == 4
- ? s.st_size & 0xffffffffu
- : s.st_size),
+ INT_TO_INTEGER (sizeof (s.st_size) == 4
+ ? s.st_size & 0xffffffffu
+ : s.st_size),
make_string (modes, 10),
Qt,
- INTEGER_TO_CONS (s.st_ino),
- INTEGER_TO_CONS (s.st_dev));
+ INT_TO_INTEGER (s.st_ino),
+ INT_TO_INTEGER (s.st_dev));
}
DEFUN ("file-attributes-lessp", Ffile_attributes_lessp, Sfile_attributes_lessp, 2, 2, 0,
@@ -1071,7 +1056,7 @@ return a list with one element, taken from `user-real-login-name'. */)
endpwent ();
#endif
- if (EQ (users, Qnil))
+ if (NILP (users))
/* At least current user is always known. */
users = list1 (Vuser_real_login_name);
return users;
diff --git a/src/dispextern.h b/src/dispextern.h
index 673e1c2fab6..1a536563532 100644
--- a/src/dispextern.h
+++ b/src/dispextern.h
@@ -31,6 +31,9 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <X11/Intrinsic.h>
#endif /* USE_X_TOOLKIT */
+#ifdef HAVE_XRENDER
+# include <X11/extensions/Xrender.h>
+#endif
#else /* !HAVE_X_WINDOWS */
/* X-related stuff used by non-X gui code. */
@@ -74,10 +77,13 @@ typedef HDC XImagePtr_or_DC;
#ifdef HAVE_NS
#include "nsgui.h"
+#define FACE_COLOR_TO_PIXEL(face_color, frame) ns_color_index_to_rgba(face_color, frame)
/* Following typedef needed to accommodate the MSDOS port, believe it or not. */
typedef struct ns_display_info Display_Info;
typedef Pixmap XImagePtr;
typedef XImagePtr XImagePtr_or_DC;
+#else
+#define FACE_COLOR_TO_PIXEL(face_color, frame) face_color
#endif
#ifdef HAVE_WINDOW_SYSTEM
@@ -306,24 +312,24 @@ INLINE int
GLYPH_CODE_CHAR (Lisp_Object gc)
{
return (CONSP (gc)
- ? XINT (XCAR (gc))
- : XINT (gc) & MAX_CHAR);
+ ? XFIXNUM (XCAR (gc))
+ : XFIXNUM (gc) & MAX_CHAR);
}
INLINE int
GLYPH_CODE_FACE (Lisp_Object gc)
{
- return CONSP (gc) ? XINT (XCDR (gc)) : XINT (gc) >> CHARACTERBITS;
+ return CONSP (gc) ? XFIXNUM (XCDR (gc)) : XFIXNUM (gc) >> CHARACTERBITS;
}
#define SET_GLYPH_FROM_GLYPH_CODE(glyph, gc) \
do \
{ \
if (CONSP (gc)) \
- SET_GLYPH (glyph, XINT (XCAR (gc)), XINT (XCDR (gc))); \
+ SET_GLYPH (glyph, XFIXNUM (XCAR (gc)), XFIXNUM (XCDR (gc))); \
else \
- SET_GLYPH (glyph, (XINT (gc) & ((1 << CHARACTERBITS)-1)), \
- (XINT (gc) >> CHARACTERBITS)); \
+ SET_GLYPH (glyph, (XFIXNUM (gc) & ((1 << CHARACTERBITS)-1)), \
+ (XFIXNUM (gc) >> CHARACTERBITS)); \
} \
while (false)
@@ -1837,8 +1843,8 @@ GLYPH_CODE_P (Lisp_Object gc)
{
return (CONSP (gc)
? (CHARACTERP (XCAR (gc))
- && RANGED_INTEGERP (0, XCDR (gc), MAX_FACE_ID))
- : (RANGED_INTEGERP
+ && RANGED_FIXNUMP (0, XCDR (gc), MAX_FACE_ID))
+ : (RANGED_FIXNUMP
(0, gc,
(MAX_FACE_ID < TYPE_MAXIMUM (EMACS_INT) >> CHARACTERBITS
? ((EMACS_INT) MAX_FACE_ID << CHARACTERBITS) | MAX_CHAR
@@ -1931,7 +1937,7 @@ struct bidi_string_data {
Lisp_Object lstring; /* Lisp string to reorder, or nil */
const unsigned char *s; /* string data, or NULL if reordering buffer */
ptrdiff_t schars; /* the number of characters in the string,
- excluding the terminating null */
+ excluding the terminating NUL */
ptrdiff_t bufpos; /* buffer position of lstring, or 0 if N/A */
bool_bf from_disp_str : 1; /* True means the string comes from a
display property */
@@ -2482,7 +2488,7 @@ struct it
If `what' is anything else, these two are undefined (will
probably hold values for the last IT_CHARACTER or IT_COMPOSITION
- traversed by the iterator.
+ traversed by the iterator).
The values are updated by get_next_display_element, so they are
out of sync with the value returned by IT_CHARPOS between the
@@ -2932,33 +2938,9 @@ struct redisplay_interface
#ifdef HAVE_WINDOW_SYSTEM
-/* Each image format (JPEG, TIFF, ...) supported is described by
- a structure of the type below. */
-
-struct image_type
-{
- /* Index of a symbol uniquely identifying the image type, e.g., 'jpeg'. */
- int type;
-
- /* Check that SPEC is a valid image specification for the given
- image type. Value is true if SPEC is valid. */
- bool (* valid_p) (Lisp_Object spec);
-
- /* Load IMG which is used on frame F from information contained in
- IMG->spec. Value is true if successful. */
- bool (* load) (struct frame *f, struct image *img);
-
- /* Free resources of image IMG which is used on frame F. */
- void (* free) (struct frame *f, struct image *img);
-
- /* Initialization function (used for dynamic loading of image
- libraries on Windows), or NULL if none. */
- bool (* init) (void);
-
- /* Next in list of all supported image types. */
- struct image_type *next;
-};
-
+# if defined USE_CAIRO || defined HAVE_XRENDER || defined HAVE_NS || defined HAVE_NTGUI
+# define HAVE_NATIVE_SCALING
+# endif
/* Structure describing an image. Specific image formats like XBM are
converted into this form, so that display only has to deal with
@@ -2975,7 +2957,6 @@ struct image
#ifdef USE_CAIRO
void *cr_data;
- void *cr_data2;
#endif
#ifdef HAVE_X_WINDOWS
/* X images of the image, corresponding to the above Pixmaps.
@@ -2983,6 +2964,11 @@ struct image
and the latter is outdated. NULL means the X image has been
synchronized to Pixmap. */
XImagePtr ximg, mask_img;
+
+# ifdef HAVE_NATIVE_SCALING
+ /* Picture versions of pixmap and mask for compositing. */
+ Picture picture, mask_picture;
+# endif
#endif
/* Colors allocated for this image, if any. Allocated via xmalloc. */
@@ -3429,11 +3415,12 @@ char *choose_face_font (struct frame *, Lisp_Object *, Lisp_Object,
#ifdef HAVE_WINDOW_SYSTEM
void prepare_face_for_display (struct frame *, struct face *);
#endif
-int lookup_named_face (struct frame *, Lisp_Object, bool);
-int lookup_basic_face (struct frame *, int);
+int lookup_named_face (struct window *, struct frame *, Lisp_Object, bool);
+int lookup_basic_face (struct window *, struct frame *, int);
int smaller_face (struct frame *, int, int);
int face_with_height (struct frame *, int, int);
-int lookup_derived_face (struct frame *, Lisp_Object, int, bool);
+int lookup_derived_face (struct window *, struct frame *,
+ Lisp_Object, int, bool);
void init_frame_faces (struct frame *);
void free_frame_faces (struct frame *);
void recompute_basic_faces (struct frame *);
@@ -3443,7 +3430,7 @@ int face_for_overlay_string (struct window *, ptrdiff_t, ptrdiff_t *, ptrdiff_t,
bool, Lisp_Object);
int face_at_string_position (struct window *, Lisp_Object, ptrdiff_t, ptrdiff_t,
ptrdiff_t *, enum face_id, bool);
-int merge_faces (struct frame *, Lisp_Object, int, int);
+int merge_faces (struct window *, Lisp_Object, int, int);
int compute_char_face (struct frame *, int, Lisp_Object);
void free_all_realized_faces (Lisp_Object);
extern char unspecified_fg[], unspecified_bg[];
@@ -3462,15 +3449,6 @@ void gamma_correct (struct frame *, COLORREF *);
void x_implicitly_set_name (struct frame *, Lisp_Object, Lisp_Object);
void x_change_tool_bar_height (struct frame *f, int);
-/* The frame used to display a tooltip.
-
- Note: In a GTK build with non-zero x_gtk_use_system_tooltips, this
- variable holds the frame that shows the tooltip, not the frame of
- the tooltip itself, so checking whether a frame is a tooltip frame
- cannot just compare the frame to what this variable holds. */
-extern Lisp_Object tip_frame;
-
-extern Window tip_window;
extern frame_parm_handler x_frame_parm_handlers[];
extern void start_hourglass (void);
@@ -3577,6 +3555,10 @@ extern void create_tty_output (struct frame *);
extern struct terminal *init_tty (const char *, const char *, bool);
extern void tty_append_glyph (struct it *);
+/* All scrolling costs measured in characters.
+ So no cost can exceed the area of a frame, measured in characters.
+ Let's hope this is never more than 1000000 characters. */
+enum { SCROLL_INFINITY = 1000000 };
/* Defined in scroll.c */
diff --git a/src/dispnew.c b/src/dispnew.c
index 03fac54e05b..ccb08ec1b95 100644
--- a/src/dispnew.c
+++ b/src/dispnew.c
@@ -25,6 +25,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <unistd.h>
#include "lisp.h"
+#include "ptr-bounds.h"
#include "termchar.h"
/* cm.h must come after dispextern.h on Windows. */
#include "dispextern.h"
@@ -41,6 +42,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "systime.h"
#include "tparam.h"
#include "xwidget.h"
+#include "pdumper.h"
#ifdef HAVE_WINDOW_SYSTEM
#include TERM_HEADER
@@ -233,9 +235,7 @@ DEFUN ("dump-redisplay-history", Fdump_redisplay_history,
#endif /* GLYPH_DEBUG */
-#if (defined PROFILING \
- && (defined __FreeBSD__ || defined GNU_LINUX || defined __MINGW32__) \
- && !HAVE___EXECUTABLE_START)
+#if defined PROFILING && !HAVE___EXECUTABLE_START
/* This function comes first in the Emacs executable and is used only
to estimate the text start for profiling. */
void
@@ -767,7 +767,7 @@ clear_current_matrices (register struct frame *f)
clear_glyph_matrix (XWINDOW (f->menu_bar_window)->current_matrix);
#endif
-#if defined (HAVE_WINDOW_SYSTEM) && ! defined (USE_GTK) && ! defined (HAVE_NS)
+#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_TOOL_BAR)
/* Clear the matrix of the tool-bar window, if any. */
if (WINDOWP (f->tool_bar_window))
clear_glyph_matrix (XWINDOW (f->tool_bar_window)->current_matrix);
@@ -792,7 +792,7 @@ clear_desired_matrices (register struct frame *f)
clear_glyph_matrix (XWINDOW (f->menu_bar_window)->desired_matrix);
#endif
-#if defined (HAVE_WINDOW_SYSTEM) && ! defined (USE_GTK) && ! defined (HAVE_NS)
+#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_TOOL_BAR)
if (WINDOWP (f->tool_bar_window))
clear_glyph_matrix (XWINDOW (f->tool_bar_window)->desired_matrix);
#endif
@@ -1281,7 +1281,7 @@ row_equal_p (struct glyph_row *a, struct glyph_row *b, bool mouse_face_p)
with zeros. If GLYPH_DEBUG and ENABLE_CHECKING are in effect, the global
variable glyph_pool_count is incremented for each pool allocated. */
-static struct glyph_pool *
+static struct glyph_pool * ATTRIBUTE_MALLOC
new_glyph_pool (void)
{
struct glyph_pool *result = xzalloc (sizeof *result);
@@ -2106,7 +2106,7 @@ adjust_frame_glyphs_for_window_redisplay (struct frame *f)
}
#endif
-#if defined (HAVE_WINDOW_SYSTEM) && ! defined (USE_GTK) && ! defined (HAVE_NS)
+#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_TOOL_BAR)
{
/* Allocate/ reallocate matrices of the tool bar window. If we
don't have a tool bar window yet, make one. */
@@ -2188,7 +2188,7 @@ free_glyphs (struct frame *f)
}
#endif
-#if defined (HAVE_WINDOW_SYSTEM) && ! defined (USE_GTK) && ! defined (HAVE_NS)
+#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_TOOL_BAR)
/* Free the tool bar window and its glyph matrices. */
if (!NILP (f->tool_bar_window))
{
@@ -2509,8 +2509,7 @@ spec_glyph_lookup_face (struct window *w, GLYPH *glyph)
/* Convert the glyph's specified face to a realized (cache) face. */
if (lface_id > 0)
{
- int face_id = merge_faces (XFRAME (w->frame),
- Qt, lface_id, DEFAULT_FACE_ID);
+ int face_id = merge_faces (w, Qt, lface_id, DEFAULT_FACE_ID);
SET_GLYPH_FACE (*glyph, face_id);
}
}
@@ -3083,7 +3082,7 @@ update_frame (struct frame *f, bool force_p, bool inhibit_hairy_id_p)
update_window (XWINDOW (f->menu_bar_window), true);
#endif
-#if defined (HAVE_WINDOW_SYSTEM) && ! defined (USE_GTK) && ! defined (HAVE_NS)
+#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_TOOL_BAR)
/* Update the tool-bar window, if present. */
if (WINDOWP (f->tool_bar_window))
{
@@ -3390,7 +3389,7 @@ update_window (struct window *w, bool force_p)
{
struct glyph_matrix *desired_matrix = w->desired_matrix;
bool paused_p;
- int preempt_count = baud_rate / 2400 + 1;
+ int preempt_count = clip_to_bounds (1, baud_rate / 2400 + 1, INT_MAX);
struct redisplay_interface *rif = FRAME_RIF (XFRAME (WINDOW_FRAME (w)));
#ifdef GLYPH_DEBUG
/* Check that W's frame doesn't have glyph matrices. */
@@ -4486,16 +4485,13 @@ update_frame_1 (struct frame *f, bool force_p, bool inhibit_id_p,
struct glyph_matrix *desired_matrix = f->desired_matrix;
int i;
bool pause_p;
- int preempt_count = baud_rate / 2400 + 1;
+ int preempt_count = clip_to_bounds (1, baud_rate / 2400 + 1, INT_MAX);
eassert (current_matrix && desired_matrix);
if (baud_rate != FRAME_COST_BAUD_RATE (f))
calculate_costs (f);
- if (preempt_count <= 0)
- preempt_count = 1;
-
if (!force_p && detect_input_pending_ignore_squeezables ())
{
pause_p = 1;
@@ -4657,6 +4653,11 @@ scrolling (struct frame *frame)
unsigned *new_hash = old_hash + height;
int *draw_cost = (int *) (new_hash + height);
int *old_draw_cost = draw_cost + height;
+ old_hash = ptr_bounds_clip (old_hash, height * sizeof *old_hash);
+ new_hash = ptr_bounds_clip (new_hash, height * sizeof *new_hash);
+ draw_cost = ptr_bounds_clip (draw_cost, height * sizeof *draw_cost);
+ old_draw_cost = ptr_bounds_clip (old_draw_cost,
+ height * sizeof *old_draw_cost);
eassert (current_matrix);
@@ -4679,8 +4680,7 @@ scrolling (struct frame *frame)
{
/* This line cannot be redrawn, so don't let scrolling mess it. */
new_hash[i] = old_hash[i];
-#define INFINITY 1000000 /* Taken from scroll.c */
- draw_cost[i] = INFINITY;
+ draw_cost[i] = SCROLL_INFINITY;
}
else
{
@@ -5721,8 +5721,8 @@ additional wait period, in milliseconds; this is for backwards compatibility.
if (!NILP (milliseconds))
{
- CHECK_NUMBER (milliseconds);
- duration += XINT (milliseconds) / 1000.0;
+ CHECK_FIXNUM (milliseconds);
+ duration += XFIXNUM (milliseconds) / 1000.0;
}
if (duration > 0)
@@ -5772,9 +5772,18 @@ sit_for (Lisp_Object timeout, bool reading, int display_option)
if (INTEGERP (timeout))
{
- sec = XINT (timeout);
- if (sec <= 0)
- return Qt;
+ if (integer_to_intmax (timeout, &sec))
+ {
+ if (sec <= 0)
+ return Qt;
+ sec = min (sec, WAIT_READING_MAX);
+ }
+ else
+ {
+ if (NILP (Fnatnump (timeout)))
+ return Qt;
+ sec = WAIT_READING_MAX;
+ }
nsec = 0;
}
else if (FLOATP (timeout))
@@ -5832,8 +5841,7 @@ immediately by pending input. */)
if (!NILP (force) && !redisplay_dont_pause)
specbind (Qredisplay_dont_pause, Qt);
redisplay_preserve_echo_area (2);
- unbind_to (count, Qnil);
- return Qt;
+ return unbind_to (count, Qt);
}
@@ -5930,7 +5938,7 @@ pass nil for VARIABLE. */)
|| n + 20 < ASIZE (state) / 2)
/* Add 20 extra so we grow it less often. */
{
- state = Fmake_vector (make_number (n + 20), Qlambda);
+ state = make_vector (n + 20, Qlambda);
if (! NILP (variable))
Fset (variable, state);
else
@@ -5977,12 +5985,24 @@ pass nil for VARIABLE. */)
Initialization
***********************************************************************/
+static void
+init_faces_initial (void)
+{
+ /* For the initial frame, we don't have any way of knowing what
+ are the foreground and background colors of the terminal. */
+ struct frame *sf = SELECTED_FRAME ();
+
+ FRAME_FOREGROUND_PIXEL (sf) = FACE_TTY_DEFAULT_FG_COLOR;
+ FRAME_BACKGROUND_PIXEL (sf) = FACE_TTY_DEFAULT_BG_COLOR;
+ call0 (intern ("tty-set-up-initial-frame-faces"));
+}
+
/* Initialization done when Emacs fork is started, before doing stty.
Determine terminal type and set terminal_driver. Then invoke its
decoding routine to set up variables in the terminal package. */
-void
-init_display (void)
+static void
+init_display_interactive (void)
{
char *terminal_type;
@@ -6002,9 +6022,7 @@ init_display (void)
with. Otherwise newly opened tty frames will not resize
automatically. */
#ifdef SIGWINCH
-#ifndef CANNOT_DUMP
- if (initialized)
-#endif /* CANNOT_DUMP */
+ if (!will_dump_p ())
{
struct sigaction action;
emacs_sigaction_init (&action, deliver_window_change_signal);
@@ -6014,10 +6032,21 @@ init_display (void)
/* If running as a daemon, no need to initialize any frames/terminal,
except on Windows, where we at least want to initialize it. */
-#ifndef WINDOWSNT
if (IS_DAEMON)
+ {
+ /* Pdump'ed Emacs doesn't record the initial frame from temacs,
+ so the non-basic faces realized for that frame in temacs
+ aren't in emacs. This causes errors when users try to
+ customize those faces in their init file. The call to
+ init_faces_initial will realize these faces now. (Non-daemon
+ Emacs does this either near the end of this function or when
+ the GUI frame is created.) */
+ if (dumped_with_pdumper_p ())
+ init_faces_initial ();
+#ifndef WINDOWSNT
return;
#endif
+ }
/* If the user wants to use a window system, we shouldn't bother
initializing the terminal. This is especially important when the
@@ -6046,7 +6075,7 @@ init_display (void)
{
Vinitial_window_system = Qx;
#ifdef HAVE_X11
- Vwindow_system_version = make_number (11);
+ Vwindow_system_version = make_fixnum (11);
#endif
#ifdef USE_NCURSES
/* In some versions of ncurses,
@@ -6062,20 +6091,16 @@ init_display (void)
if (!inhibit_window_system)
{
Vinitial_window_system = Qw32;
- Vwindow_system_version = make_number (1);
+ Vwindow_system_version = make_fixnum (1);
return;
}
#endif /* HAVE_NTGUI */
#ifdef HAVE_NS
- if (!inhibit_window_system
-#ifndef CANNOT_DUMP
- && initialized
-#endif
- )
+ if (!inhibit_window_system && !will_dump_p ())
{
Vinitial_window_system = Qns;
- Vwindow_system_version = make_number (10);
+ Vwindow_system_version = make_fixnum (10);
return;
}
#endif
@@ -6160,22 +6185,23 @@ init_display (void)
calculate_costs (XFRAME (selected_frame));
- /* Set up faces of the initial terminal frame of a dumped Emacs. */
- if (initialized
- && !noninteractive
- && NILP (Vinitial_window_system))
- {
- /* For the initial frame, we don't have any way of knowing what
- are the foreground and background colors of the terminal. */
- struct frame *sf = SELECTED_FRAME ();
+ /* Set up faces of the initial terminal frame. */
+ if (initialized && !noninteractive && NILP (Vinitial_window_system))
+ init_faces_initial ();
+}
- FRAME_FOREGROUND_PIXEL (sf) = FACE_TTY_DEFAULT_FG_COLOR;
- FRAME_BACKGROUND_PIXEL (sf) = FACE_TTY_DEFAULT_BG_COLOR;
- call0 (intern ("tty-set-up-initial-frame-faces"));
+void
+init_display (void)
+{
+ if (noninteractive)
+ {
+ if (dumped_with_pdumper_p ())
+ init_faces_initial ();
}
+ else
+ init_display_interactive ();
}
-
/***********************************************************************
Blinking cursor
@@ -6210,6 +6236,8 @@ WINDOW nil or omitted means report on the selected window. */)
Initialization
***********************************************************************/
+static void syms_of_display_for_pdumper (void);
+
void
syms_of_display (void)
{
@@ -6228,7 +6256,7 @@ syms_of_display (void)
defsubr (&Sdump_redisplay_history);
#endif
- frame_and_buffer_state = Fmake_vector (make_number (20), Qlambda);
+ frame_and_buffer_state = make_vector (20, Qlambda);
staticpro (&frame_and_buffer_state);
/* This is the "purpose" slot of a display table. */
@@ -6317,11 +6345,12 @@ See `buffer-display-table' for more information. */);
beginning of the next redisplay). */
redisplay_dont_pause = true;
-#ifdef CANNOT_DUMP
- if (noninteractive)
-#endif
- {
- Vinitial_window_system = Qnil;
- Vwindow_system_version = Qnil;
- }
+ pdumper_do_now_and_after_load (syms_of_display_for_pdumper);
+}
+
+static void
+syms_of_display_for_pdumper (void)
+{
+ Vinitial_window_system = Qnil;
+ Vwindow_system_version = Qnil;
}
diff --git a/src/disptab.h b/src/disptab.h
index a8f75f9b084..f7a162898b5 100644
--- a/src/disptab.h
+++ b/src/disptab.h
@@ -72,14 +72,14 @@ extern struct Lisp_Char_Table *buffer_display_table (void);
/* Given BASE and LEN returned by the two previous macros,
return nonzero if GLYPH code G is aliased to a different code. */
#define GLYPH_ALIAS_P(base,len,g) \
- (GLYPH_FACE (g) == DEFAULT_FACE_ID && GLYPH_CHAR (g) < (len) && INTEGERP (base[GLYPH_CHAR (g)]))
+ (GLYPH_FACE (g) == DEFAULT_FACE_ID && GLYPH_CHAR (g) < (len) && FIXNUMP (base[GLYPH_CHAR (g)]))
/* Follow all aliases for G in the glyph table given by (BASE,
LENGTH), and set G to the final glyph. */
#define GLYPH_FOLLOW_ALIASES(base, length, g) \
do { \
while (GLYPH_ALIAS_P ((base), (length), (g))) \
- SET_GLYPH_CHAR ((g), XINT ((base)[GLYPH_CHAR (g)])); \
+ SET_GLYPH_CHAR ((g), XFIXNUM ((base)[GLYPH_CHAR (g)])); \
if (!GLYPH_CHAR_VALID_P (g)) \
SET_GLYPH_CHAR (g, ' '); \
} while (false)
diff --git a/src/dmpstruct.awk b/src/dmpstruct.awk
new file mode 100644
index 00000000000..55626cf8b21
--- /dev/null
+++ b/src/dmpstruct.awk
@@ -0,0 +1,45 @@
+# Copyright (C) 2018-2019 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 <https://www.gnu.org/licenses/>.
+
+BEGIN {
+ print "/* Generated by dmpstruct.awk */"
+ print "#ifndef EMACS_DMPSTRUCT_H"
+ print "#define EMACS_DMPSTRUCT_H"
+ struct_name = ""
+ tmpfile = "dmpstruct.tmp"
+}
+# Match a type followed by optional syntactic whitespace
+/^(enum|struct|union) [a-zA-Z0-9_]+([\t ]|\/\*.*\*\/)*$/ {
+ struct_name = $2
+ close (tmpfile)
+}
+/^(enum|struct|union) [a-zA-Z0-9_]+([\t ]|\/\*.*\*\/)*$/, /^( )?};$/ {
+ print $0 > tmpfile
+}
+/^( )?} *(GCALIGNED_STRUCT)? *;$/ {
+ if (struct_name != "") {
+ fflush (tmpfile)
+ cmd = "../lib-src/make-fingerprint -r " tmpfile
+ cmd | getline hash
+ close (cmd)
+ printf "#define HASH_%s_%.10s\n", struct_name, hash
+ struct_name = ""
+ }
+}
+END {
+ print "#endif /* EMACS_DMPSTRUCT_H */"
+}
diff --git a/src/doc.c b/src/doc.c
index 7633b8552bc..372e376c625 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -86,10 +86,10 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition)
int offset;
EMACS_INT position;
Lisp_Object file, tem, pos;
- ptrdiff_t count;
+ ptrdiff_t count = SPECPDL_INDEX ();
USE_SAFE_ALLOCA;
- if (INTEGERP (filepos))
+ if (FIXNUMP (filepos))
{
file = Vdoc_file_name;
pos = filepos;
@@ -102,7 +102,7 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition)
else
return Qnil;
- position = eabs (XINT (pos));
+ position = eabs (XFIXNUM (pos));
if (!STRINGP (Vdoc_directory))
return Qnil;
@@ -118,17 +118,15 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition)
Lisp_Object docdir
= NILP (tem) ? ENCODE_FILE (Vdoc_directory) : empty_unibyte_string;
ptrdiff_t docdir_sizemax = SBYTES (docdir) + 1;
-#ifndef CANNOT_DUMP
- docdir_sizemax = max (docdir_sizemax, sizeof sibling_etc);
-#endif
+ if (will_dump_p ())
+ docdir_sizemax = max (docdir_sizemax, sizeof sibling_etc);
name = SAFE_ALLOCA (docdir_sizemax + SBYTES (file));
lispstpcpy (lispstpcpy (name, docdir), file);
fd = emacs_open (name, O_RDONLY, 0);
if (fd < 0)
{
-#ifndef CANNOT_DUMP
- if (!NILP (Vpurify_flag))
+ if (will_dump_p ())
{
/* Preparing to dump; DOC file is probably not installed.
So check in ../etc. */
@@ -136,7 +134,6 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition)
fd = emacs_open (name, O_RDONLY, 0);
}
-#endif
if (fd < 0)
{
if (errno == EMFILE || errno == ENFILE)
@@ -148,7 +145,6 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition)
return concat3 (cannot_open, file, quote_nl);
}
}
- count = SPECPDL_INDEX ();
record_unwind_protect_int (close_file_unwind, fd);
/* Seek only to beginning of disk block. */
@@ -204,8 +200,7 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition)
}
p += nread;
}
- unbind_to (count, Qnil);
- SAFE_FREE ();
+ SAFE_FREE_UNBIND_TO (count, Qnil);
/* Sanity checking. */
if (CONSP (filepos))
@@ -238,7 +233,7 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition)
}
/* Scan the text and perform quoting with ^A (char code 1).
- ^A^A becomes ^A, ^A0 becomes a null char, and ^A_ becomes a ^_. */
+ ^A^A becomes ^A, ^A0 becomes a NUL char, and ^A_ becomes a ^_. */
from = get_doc_string_buffer + offset;
to = get_doc_string_buffer + offset;
while (from != p)
@@ -341,7 +336,7 @@ string is passed through `substitute-command-keys'. */)
if (CONSP (fun) && EQ (XCAR (fun), Qmacro))
fun = XCDR (fun);
if (SUBRP (fun))
- doc = make_number (XSUBR (fun)->doc);
+ doc = make_fixnum (XSUBR (fun)->doc);
else if (MODULE_FUNCTIONP (fun))
doc = XMODULE_FUNCTION (fun)->documentation;
else if (COMPILEDP (fun))
@@ -353,7 +348,7 @@ string is passed through `substitute-command-keys'. */)
Lisp_Object tem = AREF (fun, COMPILED_DOC_STRING);
if (STRINGP (tem))
doc = tem;
- else if (NATNUMP (tem) || CONSP (tem))
+ else if (FIXNATP (tem) || CONSP (tem))
doc = tem;
else
return Qnil;
@@ -380,7 +375,7 @@ string is passed through `substitute-command-keys'. */)
doc = tem;
/* Handle a doc reference--but these never come last
in the function body, so reject them if they are last. */
- else if ((NATNUMP (tem) || (CONSP (tem) && INTEGERP (XCDR (tem))))
+ else if ((FIXNATP (tem) || (CONSP (tem) && FIXNUMP (XCDR (tem))))
&& !NILP (XCDR (tem1)))
doc = tem;
else
@@ -397,9 +392,9 @@ string is passed through `substitute-command-keys'. */)
/* If DOC is 0, it's typically because of a dumped file missing
from the DOC file (bug in src/Makefile.in). */
- if (EQ (doc, make_number (0)))
+ if (EQ (doc, make_fixnum (0)))
doc = Qnil;
- if (INTEGERP (doc) || CONSP (doc))
+ if (FIXNUMP (doc) || CONSP (doc))
{
Lisp_Object tem;
tem = get_doc_string (doc, 0, 0);
@@ -439,9 +434,9 @@ aren't strings. */)
documentation_property:
tem = Fget (symbol, prop);
- if (EQ (tem, make_number (0)))
+ if (EQ (tem, make_fixnum (0)))
tem = Qnil;
- if (INTEGERP (tem) || (CONSP (tem) && INTEGERP (XCDR (tem))))
+ if (FIXNUMP (tem) || (CONSP (tem) && FIXNUMP (XCDR (tem))))
{
Lisp_Object doc = tem;
tem = get_doc_string (tem, 0, 0);
@@ -488,10 +483,10 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset)
|| (EQ (tem, Qclosure) && (fun = XCDR (fun), 1)))
{
tem = Fcdr (Fcdr (fun));
- if (CONSP (tem) && INTEGERP (XCAR (tem)))
+ if (CONSP (tem) && FIXNUMP (XCAR (tem)))
/* FIXME: This modifies typically pure hash-cons'd data, so its
correctness is quite delicate. */
- XSETCAR (tem, make_number (offset));
+ XSETCAR (tem, make_fixnum (offset));
}
}
@@ -505,7 +500,7 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset)
/* This bytecode object must have a slot for the
docstring, since we've found a docstring for it. */
if (PVSIZE (fun) > COMPILED_DOC_STRING)
- ASET (fun, COMPILED_DOC_STRING, make_number (offset));
+ ASET (fun, COMPILED_DOC_STRING, make_fixnum (offset));
else
{
AUTO_STRING (format, "No docstring slot for %s");
@@ -535,7 +530,6 @@ the same file name is found in the `doc-directory'. */)
EMACS_INT pos;
Lisp_Object sym;
char *p, *name;
- bool skip_file = 0;
ptrdiff_t count;
char const *dirname;
ptrdiff_t dirlen;
@@ -548,12 +542,7 @@ the same file name is found in the `doc-directory'. */)
CHECK_STRING (filename);
- if
-#ifndef CANNOT_DUMP
- (!NILP (Vpurify_flag))
-#else /* CANNOT_DUMP */
- (0)
-#endif /* CANNOT_DUMP */
+ if (will_dump_p ())
{
dirname = sibling_etc;
dirlen = sizeof sibling_etc - 1;
@@ -609,34 +598,24 @@ the same file name is found in the `doc-directory'. */)
{
end = strchr (p, '\n');
- /* See if this is a file name, and if it is a file in build-files. */
- if (p[1] == 'S')
- {
- skip_file = 0;
- if (end - p > 4 && end[-2] == '.'
- && (end[-1] == 'o' || end[-1] == 'c'))
- {
- ptrdiff_t len = end - p - 2;
- char *fromfile = SAFE_ALLOCA (len + 1);
- memcpy (fromfile, &p[2], len);
- fromfile[len] = 0;
- if (fromfile[len-1] == 'c')
- fromfile[len-1] = 'o';
-
- skip_file = NILP (Fmember (build_string (fromfile),
- Vbuild_files));
- }
- }
+ /* We used to skip files not in build_files, so that when a
+ function was defined several times in different files
+ (typically, once in xterm, once in w32term, ...), we only
+ paid attention to the relevant one.
+
+ But this meant the doc had to be kept and updated in
+ multiple files. Nowadays we keep the doc only in eg xterm.
+ The (f)boundp checks below ensure we don't report
+ docs for eg w32-specific items on X.
+ */
sym = oblookup (Vobarray, p + 2,
multibyte_chars_in_text ((unsigned char *) p + 2,
end - p - 2),
end - p - 2);
- /* Check skip_file so that when a function is defined several
- times in different files (typically, once in xterm, once in
- w32term, ...), we only pay attention to the one that
- matters. */
- if (! skip_file && SYMBOLP (sym))
+ /* Ignore docs that start with SKIP. These mark
+ placeholders where the real doc is elsewhere. */
+ if (SYMBOLP (sym))
{
/* Attach a docstring to a variable? */
if (p[1] == 'V')
@@ -644,17 +623,18 @@ the same file name is found in the `doc-directory'. */)
/* Install file-position as variable-documentation property
and make it negative for a user-variable
(doc starts with a `*'). */
- if (!NILP (Fboundp (sym))
+ if ((!NILP (Fboundp (sym))
|| !NILP (Fmemq (sym, delayed_init)))
+ && strncmp (end, "\nSKIP", 5))
Fput (sym, Qvariable_documentation,
- make_number ((pos + end + 1 - buf)
+ make_fixnum ((pos + end + 1 - buf)
* (end[1] == '*' ? -1 : 1)));
}
/* Attach a docstring to a function? */
else if (p[1] == 'F')
{
- if (!NILP (Ffboundp (sym)))
+ if (!NILP (Ffboundp (sym)) && strncmp (end, "\nSKIP", 5))
store_function_docstring (sym, pos + end + 1 - buf);
}
else if (p[1] == 'S')
@@ -669,8 +649,7 @@ the same file name is found in the `doc-directory'. */)
memmove (buf, end, filled);
}
- SAFE_FREE ();
- return unbind_to (count, Qnil);
+ return SAFE_FREE_UNBIND_TO (count, Qnil);
}
/* Return true if text quoting style should default to quote `like this'. */
@@ -684,7 +663,7 @@ default_to_grave_quoting_style (void)
Lisp_Object dv = DISP_CHAR_VECTOR (XCHAR_TABLE (Vstandard_display_table),
LEFT_SINGLE_QUOTATION_MARK);
return (VECTORP (dv) && ASIZE (dv) == 1
- && EQ (AREF (dv, 0), make_number ('`')));
+ && EQ (AREF (dv, 0), make_fixnum ('`')));
}
/* Return the current effective text quoting style. */
diff --git a/src/doprnt.c b/src/doprnt.c
index 363eece5c27..5fb70634048 100644
--- a/src/doprnt.c
+++ b/src/doprnt.c
@@ -35,7 +35,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
sequence.
. It accepts a pointer to the end of the format string, so the format string
- could include embedded null characters.
+ could include embedded NUL characters.
. It signals an error if the length of the formatted string is about to
overflow ptrdiff_t or size_t, to avoid producing strings longer than what
@@ -123,7 +123,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
to fit and return BUFSIZE - 1; if this truncates a multibyte
sequence, store '\0' into the sequence's first byte.
Returns the number of bytes stored into BUFFER, excluding
- the terminating null byte. Output is always null-terminated.
+ the terminating NUL byte. Output is always NUL-terminated.
String arguments are passed as C strings.
Integers are passed as C integers. */
@@ -503,7 +503,7 @@ esprintf (char *buf, char const *format, ...)
return nbytes;
}
-#if HAVE_MODULES || (defined HAVE_X_WINDOWS && defined USE_X_TOOLKIT)
+#if defined HAVE_X_WINDOWS && defined USE_X_TOOLKIT
/* Format to buffer *BUF of positive size *BUFSIZE, reallocating *BUF
and updating *BUFSIZE if the buffer is too small, and otherwise
diff --git a/src/dosfns.c b/src/dosfns.c
index cc371ce22c1..47c545007ad 100644
--- a/src/dosfns.c
+++ b/src/dosfns.c
@@ -66,33 +66,33 @@ REGISTERS should be a vector produced by `make-register' and
int no;
union REGS inregs, outregs;
- CHECK_NUMBER (interrupt);
- no = (unsigned long) XINT (interrupt);
+ CHECK_FIXNUM (interrupt);
+ no = (unsigned long) XFIXNUM (interrupt);
CHECK_VECTOR (registers);
if (no < 0 || no > 0xff || ASIZE (registers) != 8)
return Qnil;
for (i = 0; i < 8; i++)
- CHECK_NUMBER (AREF (registers, i));
+ CHECK_FIXNUM (AREF (registers, i));
- inregs.x.ax = (unsigned long) XFASTINT (AREF (registers, 0));
- inregs.x.bx = (unsigned long) XFASTINT (AREF (registers, 1));
- inregs.x.cx = (unsigned long) XFASTINT (AREF (registers, 2));
- inregs.x.dx = (unsigned long) XFASTINT (AREF (registers, 3));
- inregs.x.si = (unsigned long) XFASTINT (AREF (registers, 4));
- inregs.x.di = (unsigned long) XFASTINT (AREF (registers, 5));
- inregs.x.cflag = (unsigned long) XFASTINT (AREF (registers, 6));
- inregs.x.flags = (unsigned long) XFASTINT (AREF (registers, 7));
+ inregs.x.ax = (unsigned long) XFIXNAT (AREF (registers, 0));
+ inregs.x.bx = (unsigned long) XFIXNAT (AREF (registers, 1));
+ inregs.x.cx = (unsigned long) XFIXNAT (AREF (registers, 2));
+ inregs.x.dx = (unsigned long) XFIXNAT (AREF (registers, 3));
+ inregs.x.si = (unsigned long) XFIXNAT (AREF (registers, 4));
+ inregs.x.di = (unsigned long) XFIXNAT (AREF (registers, 5));
+ inregs.x.cflag = (unsigned long) XFIXNAT (AREF (registers, 6));
+ inregs.x.flags = (unsigned long) XFIXNAT (AREF (registers, 7));
int86 (no, &inregs, &outregs);
- ASET (registers, 0, make_number (outregs.x.ax));
- ASET (registers, 1, make_number (outregs.x.bx));
- ASET (registers, 2, make_number (outregs.x.cx));
- ASET (registers, 3, make_number (outregs.x.dx));
- ASET (registers, 4, make_number (outregs.x.si));
- ASET (registers, 5, make_number (outregs.x.di));
- ASET (registers, 6, make_number (outregs.x.cflag));
- ASET (registers, 7, make_number (outregs.x.flags));
+ ASET (registers, 0, make_fixnum (outregs.x.ax));
+ ASET (registers, 1, make_fixnum (outregs.x.bx));
+ ASET (registers, 2, make_fixnum (outregs.x.cx));
+ ASET (registers, 3, make_fixnum (outregs.x.dx));
+ ASET (registers, 4, make_fixnum (outregs.x.si));
+ ASET (registers, 5, make_fixnum (outregs.x.di));
+ ASET (registers, 6, make_fixnum (outregs.x.cflag));
+ ASET (registers, 7, make_fixnum (outregs.x.flags));
return registers;
}
@@ -106,8 +106,8 @@ Return the updated VECTOR. */)
int offs, len;
char *buf;
- CHECK_NUMBER (address);
- offs = (unsigned long) XINT (address);
+ CHECK_FIXNUM (address);
+ offs = (unsigned long) XFIXNUM (address);
CHECK_VECTOR (vector);
len = ASIZE (vector);
if (len < 1 || len > 2048 || offs < 0 || offs > 0xfffff - len)
@@ -116,7 +116,7 @@ Return the updated VECTOR. */)
dosmemget (offs, len, buf);
for (i = 0; i < len; i++)
- ASET (vector, i, make_number (buf[i]));
+ ASET (vector, i, make_fixnum (buf[i]));
return vector;
}
@@ -129,8 +129,8 @@ DEFUN ("msdos-memput", Fdos_memput, Sdos_memput, 2, 2, 0,
int offs, len;
char *buf;
- CHECK_NUMBER (address);
- offs = (unsigned long) XINT (address);
+ CHECK_FIXNUM (address);
+ offs = (unsigned long) XFIXNUM (address);
CHECK_VECTOR (vector);
len = ASIZE (vector);
if (len < 1 || len > 2048 || offs < 0 || offs > 0xfffff - len)
@@ -139,8 +139,8 @@ DEFUN ("msdos-memput", Fdos_memput, Sdos_memput, 2, 2, 0,
for (i = 0; i < len; i++)
{
- CHECK_NUMBER (AREF (vector, i));
- buf[i] = (unsigned char) XFASTINT (AREF (vector, i)) & 0xFF;
+ CHECK_FIXNUM (AREF (vector, i));
+ buf[i] = (unsigned char) XFIXNAT (AREF (vector, i)) & 0xFF;
}
dosmemput (buf, len, offs);
@@ -154,8 +154,8 @@ all keys; otherwise it is only used when the ALT key is pressed.
The current keyboard layout is available in dos-keyboard-code. */)
(Lisp_Object country_code, Lisp_Object allkeys)
{
- CHECK_NUMBER (country_code);
- if (!dos_set_keyboard (XINT (country_code), !NILP (allkeys)))
+ CHECK_FIXNUM (country_code);
+ if (!dos_set_keyboard (XFIXNUM (country_code), !NILP (allkeys)))
return Qnil;
return Qt;
}
@@ -280,7 +280,7 @@ init_dosfns (void)
regs.x.ax = 0x3000;
intdos (&regs, &regs);
- Vdos_version = Fcons (make_number (regs.h.al), make_number (regs.h.ah));
+ Vdos_version = Fcons (make_fixnum (regs.h.al), make_fixnum (regs.h.ah));
/* Obtain the country code via DPMI, use DJGPP transfer buffer. */
dpmiregs.x.ax = 0x3800;
@@ -341,7 +341,7 @@ init_dosfns (void)
{
dos_windows_version = dpmiregs.x.ax;
Vdos_windows_version =
- Fcons (make_number (dpmiregs.h.al), make_number (dpmiregs.h.ah));
+ Fcons (make_fixnum (dpmiregs.h.al), make_fixnum (dpmiregs.h.ah));
/* Save the current title of this virtual machine, so we can restore
it before exiting. Otherwise, Windows 95 will continue to use
@@ -480,11 +480,7 @@ x_set_title (struct frame *f, Lisp_Object name)
#endif /* !HAVE_X_WINDOWS */
DEFUN ("file-system-info", Ffile_system_info, Sfile_system_info, 1, 1, 0,
- doc: /* Return storage information about the file system FILENAME is on.
-Value is a list of floats (TOTAL FREE AVAIL), where TOTAL is the total
-storage of the file system, FREE is the free storage, and AVAIL is the
-storage available to a non-superuser. All 3 numbers are in bytes.
-If the underlying system call fails, value is nil. */)
+ doc: /* SKIP: real doc in fileio.c. */)
(Lisp_Object filename)
{
struct statfs stfs;
@@ -513,7 +509,7 @@ list_system_processes (void)
{
Lisp_Object proclist = Qnil;
- proclist = Fcons (make_fixnum_or_float (getpid ()), proclist);
+ proclist = Fcons (INT_TO_INTEGER (getpid ()), proclist);
return proclist;
}
@@ -524,8 +520,8 @@ system_process_attributes (Lisp_Object pid)
int proc_id;
Lisp_Object attrs = Qnil;
- CHECK_NUMBER_OR_FLOAT (pid);
- proc_id = FLOATP (pid) ? XFLOAT_DATA (pid) : XINT (pid);
+ CHECK_NUMBER (pid);
+ proc_id = XFLOATINT (pid);
if (proc_id == getpid ())
{
@@ -543,12 +539,12 @@ system_process_attributes (Lisp_Object pid)
#endif
uid = getuid ();
- attrs = Fcons (Fcons (Qeuid, make_fixnum_or_float (uid)), attrs);
+ attrs = Fcons (Fcons (Qeuid, INT_TO_INTEGER (uid)), attrs);
usr = getlogin ();
if (usr)
attrs = Fcons (Fcons (Quser, build_string (usr)), attrs);
gid = getgid ();
- attrs = Fcons (Fcons (Qegid, make_fixnum_or_float (gid)), attrs);
+ attrs = Fcons (Fcons (Qegid, INT_TO_INTEGER (gid)), attrs);
gr = getgrgid (gid);
if (gr)
attrs = Fcons (Fcons (Qgroup, build_string (gr->gr_name)), attrs);
@@ -559,18 +555,18 @@ system_process_attributes (Lisp_Object pid)
Vlocale_coding_system, 0);
attrs = Fcons (Fcons (Qcomm, decoded_cmd), attrs);
/* Pretend we have 0 as PPID. */
- attrs = Fcons (Fcons (Qppid, make_number (0)), attrs);
+ attrs = Fcons (Fcons (Qppid, make_fixnum (0)), attrs);
attrs = Fcons (Fcons (Qpgrp, pid), attrs);
attrs = Fcons (Fcons (Qttname, build_string ("/dev/tty")), attrs);
/* We are never idle! */
tem = Fget_internal_run_time ();
attrs = Fcons (Fcons (Qtime, tem), attrs);
- attrs = Fcons (Fcons (Qthcount, make_number (1)), attrs);
+ attrs = Fcons (Fcons (Qthcount, make_fixnum (1)), attrs);
attrs = Fcons (Fcons (Qstart,
Fsymbol_value (intern ("before-init-time"))),
attrs);
attrs = Fcons (Fcons (Qvsize,
- make_fixnum_or_float ((unsigned long)sbrk (0)/1024)),
+ INT_TO_INTEGER ((unsigned long) sbrk (0) / 1024)),
attrs);
attrs = Fcons (Fcons (Qetime, tem), attrs);
#ifndef SYSTEM_MALLOC
diff --git a/src/dynlib.c b/src/dynlib.c
index 45b85353325..878044558a6 100644
--- a/src/dynlib.c
+++ b/src/dynlib.c
@@ -156,9 +156,8 @@ dynlib_addr (void *addr, const char **fname, const char **symname)
address we pass to it is not an address of a string, but
an address of a function. So we don't care about the
Unicode version. */
- s_pfn_Get_Module_HandleExA =
- (GetModuleHandleExA_Proc) GetProcAddress (hm_kernel32,
- "GetModuleHandleExA");
+ s_pfn_Get_Module_HandleExA = (GetModuleHandleExA_Proc)
+ get_proc_addr (hm_kernel32, "GetModuleHandleExA");
}
if (s_pfn_Get_Module_HandleExA)
{
diff --git a/src/editfns.c b/src/editfns.c
index 9b76ae23ffd..6fb43af4e9c 100644
--- a/src/editfns.c
+++ b/src/editfns.c
@@ -35,57 +35,27 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "lisp.h"
-/* systime.h includes <sys/time.h> which, on some systems, is required
- for <sys/resource.h>; thus systime.h must be included before
- <sys/resource.h> */
-#include "systime.h"
-
-#if defined HAVE_SYS_RESOURCE_H
-#include <sys/resource.h>
-#endif
-
-#include <errno.h>
#include <float.h>
#include <limits.h>
+#include <math.h>
#include <c-ctype.h>
#include <intprops.h>
#include <stdlib.h>
-#include <strftime.h>
#include <verify.h>
#include "composite.h"
#include "intervals.h"
+#include "ptr-bounds.h"
+#include "systime.h"
#include "character.h"
#include "buffer.h"
-#include "coding.h"
#include "window.h"
#include "blockinput.h"
-#define TM_YEAR_BASE 1900
-
-#ifdef WINDOWSNT
-extern Lisp_Object w32_get_internal_run_time (void);
-#endif
-
-static struct lisp_time lisp_time_struct (Lisp_Object, int *);
-static Lisp_Object format_time_string (char const *, ptrdiff_t, struct timespec,
- Lisp_Object, struct tm *);
-static long int tm_gmtoff (struct tm *);
-static int tm_diff (struct tm *, struct tm *);
static void update_buffer_properties (ptrdiff_t, ptrdiff_t);
static Lisp_Object styled_format (ptrdiff_t, Lisp_Object *, bool);
-#ifndef HAVE_TM_GMTOFF
-# define HAVE_TM_GMTOFF false
-#endif
-
-enum { tzeqlen = sizeof "TZ=" - 1 };
-
-/* Time zones equivalent to current local time and to UTC, respectively. */
-static timezone_t local_tz;
-static timezone_t const utc_tz = 0;
-
/* The cached value of Vsystem_name. This is used only to compare it
to Vsystem_name, so it need not be visible to the GC. */
static Lisp_Object cached_system_name;
@@ -97,141 +67,9 @@ init_and_cache_system_name (void)
cached_system_name = Vsystem_name;
}
-static struct tm *
-emacs_localtime_rz (timezone_t tz, time_t const *t, struct tm *tm)
-{
- tm = localtime_rz (tz, t, tm);
- if (!tm && errno == ENOMEM)
- memory_full (SIZE_MAX);
- return tm;
-}
-
-static time_t
-emacs_mktime_z (timezone_t tz, struct tm *tm)
-{
- errno = 0;
- time_t t = mktime_z (tz, tm);
- if (t == (time_t) -1 && errno == ENOMEM)
- memory_full (SIZE_MAX);
- return t;
-}
-
-/* Allocate a timezone, signaling on failure. */
-static timezone_t
-xtzalloc (char const *name)
-{
- timezone_t tz = tzalloc (name);
- if (!tz)
- memory_full (SIZE_MAX);
- return tz;
-}
-
-/* Free a timezone, except do not free the time zone for local time.
- Freeing utc_tz is also a no-op. */
-static void
-xtzfree (timezone_t tz)
-{
- if (tz != local_tz)
- tzfree (tz);
-}
-
-/* Convert the Lisp time zone rule ZONE to a timezone_t object.
- The returned value either is 0, or is LOCAL_TZ, or is newly allocated.
- If SETTZ, set Emacs local time to the time zone rule; otherwise,
- the caller should eventually pass the returned value to xtzfree. */
-static timezone_t
-tzlookup (Lisp_Object zone, bool settz)
-{
- static char const tzbuf_format[] = "<%+.*"pI"d>%s%"pI"d:%02d:%02d";
- char const *trailing_tzbuf_format = tzbuf_format + sizeof "<%+.*"pI"d" - 1;
- char tzbuf[sizeof tzbuf_format + 2 * INT_STRLEN_BOUND (EMACS_INT)];
- char const *zone_string;
- timezone_t new_tz;
-
- if (NILP (zone))
- return local_tz;
- else if (EQ (zone, Qt))
- {
- zone_string = "UTC0";
- new_tz = utc_tz;
- }
- else
- {
- bool plain_integer = INTEGERP (zone);
-
- if (EQ (zone, Qwall))
- zone_string = 0;
- else if (STRINGP (zone))
- zone_string = SSDATA (ENCODE_SYSTEM (zone));
- else if (plain_integer || (CONSP (zone) && INTEGERP (XCAR (zone))
- && CONSP (XCDR (zone))))
- {
- Lisp_Object abbr;
- if (!plain_integer)
- {
- abbr = XCAR (XCDR (zone));
- zone = XCAR (zone);
- }
-
- EMACS_INT abszone = eabs (XINT (zone)), hour = abszone / (60 * 60);
- int hour_remainder = abszone % (60 * 60);
- int min = hour_remainder / 60, sec = hour_remainder % 60;
-
- if (plain_integer)
- {
- int prec = 2;
- EMACS_INT numzone = hour;
- if (hour_remainder != 0)
- {
- prec += 2, numzone = 100 * numzone + min;
- if (sec != 0)
- prec += 2, numzone = 100 * numzone + sec;
- }
- sprintf (tzbuf, tzbuf_format, prec,
- XINT (zone) < 0 ? -numzone : numzone,
- &"-"[XINT (zone) < 0], hour, min, sec);
- zone_string = tzbuf;
- }
- else
- {
- AUTO_STRING (leading, "<");
- AUTO_STRING_WITH_LEN (trailing, tzbuf,
- sprintf (tzbuf, trailing_tzbuf_format,
- &"-"[XINT (zone) < 0],
- hour, min, sec));
- zone_string = SSDATA (concat3 (leading, ENCODE_SYSTEM (abbr),
- trailing));
- }
- }
- else
- xsignal2 (Qerror, build_string ("Invalid time zone specification"),
- zone);
- new_tz = xtzalloc (zone_string);
- }
-
- if (settz)
- {
- block_input ();
- emacs_setenv_TZ (zone_string);
- tzset ();
- timezone_t old_tz = local_tz;
- local_tz = new_tz;
- tzfree (old_tz);
- unblock_input ();
- }
-
- return new_tz;
-}
-
void
-init_editfns (bool dumping)
+init_editfns (void)
{
-#if !defined CANNOT_DUMP
- /* A valid but unlikely setting for the TZ environment variable.
- It is OK (though a bit slower) if the user chooses this value. */
- static char dump_tz_string[] = "TZ=UtC0";
-#endif
-
const char *user_name;
register char *p;
struct passwd *pw; /* password entry for the current user */
@@ -240,37 +78,6 @@ init_editfns (bool dumping)
/* Set up system_name even when dumping. */
init_and_cache_system_name ();
-#ifndef CANNOT_DUMP
- /* When just dumping out, set the time zone to a known unlikely value
- and skip the rest of this function. */
- if (dumping)
- {
- xputenv (dump_tz_string);
- tzset ();
- return;
- }
-#endif
-
- char *tz = getenv ("TZ");
-
-#if !defined CANNOT_DUMP
- /* If the execution TZ happens to be the same as the dump TZ,
- change it to some other value and then change it back,
- to force the underlying implementation to reload the TZ info.
- This is needed on implementations that load TZ info from files,
- since the TZ file contents may differ between dump and execution. */
- if (tz && strcmp (tz, &dump_tz_string[tzeqlen]) == 0)
- {
- ++*tz;
- tzset ();
- --*tz;
- }
-#endif
-
- /* Set the time zone rule now, so that the call to putenv is done
- before multiple threads are active. */
- tzlookup (tz ? build_string (tz) : Qwall, true);
-
pw = getpwuid (getuid ());
#ifdef MSDOS
/* We let the real user name default to "root" because that's quite
@@ -305,7 +112,7 @@ init_editfns (bool dumping)
else
{
uid_t euid = geteuid ();
- tem = make_fixnum_or_float (euid);
+ tem = INT_TO_INTEGER (euid);
}
Vuser_full_name = Fuser_full_name (tem);
@@ -335,7 +142,7 @@ usage: (char-to-string CHAR) */)
unsigned char str[MAX_MULTIBYTE_LENGTH];
CHECK_CHARACTER (character);
- c = XFASTINT (character);
+ c = XFIXNAT (character);
len = CHAR_STRING (c, str);
return make_string_from_bytes ((char *) str, 1, len);
@@ -346,10 +153,10 @@ DEFUN ("byte-to-string", Fbyte_to_string, Sbyte_to_string, 1, 1, 0,
(Lisp_Object byte)
{
unsigned char b;
- CHECK_NUMBER (byte);
- if (XINT (byte) < 0 || XINT (byte) > 255)
+ CHECK_FIXNUM (byte);
+ if (XFIXNUM (byte) < 0 || XFIXNUM (byte) > 255)
error ("Invalid byte");
- b = XINT (byte);
+ b = XFIXNUM (byte);
return make_string_from_bytes ((char *) &b, 1, 1);
}
@@ -397,8 +204,8 @@ The return value is POSITION. */)
{
if (MARKERP (position))
set_point_from_marker (position);
- else if (INTEGERP (position))
- SET_PT (clip_to_bounds (BEGV, XINT (position), ZV));
+ else if (FIXNUMP (position))
+ SET_PT (clip_to_bounds (BEGV, XFIXNUM (position), ZV));
else
wrong_type_argument (Qinteger_or_marker_p, position);
return position;
@@ -424,9 +231,9 @@ region_limit (bool beginningp)
error ("The mark is not set now, so there is no region");
/* Clip to the current narrowing (bug#11770). */
- return make_number ((PT < XFASTINT (m)) == beginningp
+ return make_fixnum ((PT < XFIXNAT (m)) == beginningp
? PT
- : clip_to_bounds (BEGV, XFASTINT (m), ZV));
+ : clip_to_bounds (BEGV, XFIXNAT (m), ZV));
}
DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 0, 0,
@@ -460,21 +267,18 @@ If you set the marker not to point anywhere, the buffer will have no mark. */)
static ptrdiff_t
overlays_around (EMACS_INT pos, Lisp_Object *vec, ptrdiff_t len)
{
- Lisp_Object overlay, start, end;
- struct Lisp_Overlay *tail;
- ptrdiff_t startpos, endpos;
ptrdiff_t idx = 0;
- for (tail = current_buffer->overlays_before; tail; tail = tail->next)
+ for (struct Lisp_Overlay *tail = current_buffer->overlays_before;
+ tail; tail = tail->next)
{
- XSETMISC (overlay, tail);
-
- end = OVERLAY_END (overlay);
- endpos = OVERLAY_POSITION (end);
+ Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike);
+ Lisp_Object end = OVERLAY_END (overlay);
+ ptrdiff_t endpos = OVERLAY_POSITION (end);
if (endpos < pos)
break;
- start = OVERLAY_START (overlay);
- startpos = OVERLAY_POSITION (start);
+ Lisp_Object start = OVERLAY_START (overlay);
+ ptrdiff_t startpos = OVERLAY_POSITION (start);
if (startpos <= pos)
{
if (idx < len)
@@ -484,16 +288,16 @@ overlays_around (EMACS_INT pos, Lisp_Object *vec, ptrdiff_t len)
}
}
- for (tail = current_buffer->overlays_after; tail; tail = tail->next)
+ for (struct Lisp_Overlay *tail = current_buffer->overlays_after;
+ tail; tail = tail->next)
{
- XSETMISC (overlay, tail);
-
- start = OVERLAY_START (overlay);
- startpos = OVERLAY_POSITION (start);
+ Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike);
+ Lisp_Object start = OVERLAY_START (overlay);
+ ptrdiff_t startpos = OVERLAY_POSITION (start);
if (pos < startpos)
break;
- end = OVERLAY_END (overlay);
- endpos = OVERLAY_POSITION (end);
+ Lisp_Object end = OVERLAY_END (overlay);
+ ptrdiff_t endpos = OVERLAY_POSITION (end);
if (pos <= endpos)
{
if (idx < len)
@@ -515,7 +319,7 @@ i.e. the property that a char would inherit if it were inserted
at POSITION. */)
(Lisp_Object position, register Lisp_Object prop, Lisp_Object object)
{
- CHECK_NUMBER_COERCE_MARKER (position);
+ CHECK_FIXNUM_COERCE_MARKER (position);
if (NILP (object))
XSETBUFFER (object, current_buffer);
@@ -529,7 +333,7 @@ at POSITION. */)
return Fget_text_property (position, prop, object);
else
{
- EMACS_INT posn = XINT (position);
+ EMACS_INT posn = XFIXNUM (position);
ptrdiff_t noverlays;
Lisp_Object *overlay_vec, tem;
struct buffer *obuf = current_buffer;
@@ -582,8 +386,8 @@ at POSITION. */)
if (stickiness > 0)
return Fget_text_property (position, prop, object);
else if (stickiness < 0
- && XINT (position) > BUF_BEGV (XBUFFER (object)))
- return Fget_text_property (make_number (XINT (position) - 1),
+ && XFIXNUM (position) > BUF_BEGV (XBUFFER (object)))
+ return Fget_text_property (make_fixnum (XFIXNUM (position) - 1),
prop, object);
else
return Qnil;
@@ -626,13 +430,13 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary,
if (NILP (pos))
XSETFASTINT (pos, PT);
else
- CHECK_NUMBER_COERCE_MARKER (pos);
+ CHECK_FIXNUM_COERCE_MARKER (pos);
after_field
= get_char_property_and_overlay (pos, Qfield, Qnil, NULL);
before_field
- = (XFASTINT (pos) > BEGV
- ? get_char_property_and_overlay (make_number (XINT (pos) - 1),
+ = (XFIXNAT (pos) > BEGV
+ ? get_char_property_and_overlay (make_fixnum (XFIXNUM (pos) - 1),
Qfield, Qnil, NULL)
/* Using nil here would be a more obvious choice, but it would
fail when the buffer starts with a non-sticky field. */
@@ -686,7 +490,7 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary,
if (at_field_start)
/* POS is at the edge of a field, and we should consider it as
the beginning of the following field. */
- *beg = XFASTINT (pos);
+ *beg = XFIXNAT (pos);
else
/* Find the previous field boundary. */
{
@@ -698,7 +502,7 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary,
p = Fprevious_single_char_property_change (p, Qfield, Qnil,
beg_limit);
- *beg = NILP (p) ? BEGV : XFASTINT (p);
+ *beg = NILP (p) ? BEGV : XFIXNAT (p);
}
}
@@ -707,7 +511,7 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary,
if (at_field_end)
/* POS is at the edge of a field, and we should consider it as
the end of the previous field. */
- *end = XFASTINT (pos);
+ *end = XFIXNAT (pos);
else
/* Find the next field boundary. */
{
@@ -718,7 +522,7 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary,
pos = Fnext_single_char_property_change (pos, Qfield, Qnil,
end_limit);
- *end = NILP (pos) ? ZV : XFASTINT (pos);
+ *end = NILP (pos) ? ZV : XFIXNAT (pos);
}
}
}
@@ -771,7 +575,7 @@ is before LIMIT, then LIMIT will be returned instead. */)
{
ptrdiff_t beg;
find_field (pos, escape_from_edge, limit, &beg, Qnil, 0);
- return make_number (beg);
+ return make_fixnum (beg);
}
DEFUN ("field-end", Ffield_end, Sfield_end, 0, 3, 0,
@@ -786,7 +590,7 @@ is after LIMIT, then LIMIT will be returned instead. */)
{
ptrdiff_t end;
find_field (pos, escape_from_edge, Qnil, 0, limit, &end);
- return make_number (end);
+ return make_fixnum (end);
}
DEFUN ("constrain-to-field", Fconstrain_to_field, Sconstrain_to_field, 2, 5, 0,
@@ -832,13 +636,13 @@ Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
XSETFASTINT (new_pos, PT);
}
- CHECK_NUMBER_COERCE_MARKER (new_pos);
- CHECK_NUMBER_COERCE_MARKER (old_pos);
+ CHECK_FIXNUM_COERCE_MARKER (new_pos);
+ CHECK_FIXNUM_COERCE_MARKER (old_pos);
- fwd = (XINT (new_pos) > XINT (old_pos));
+ fwd = (XFIXNUM (new_pos) > XFIXNUM (old_pos));
- prev_old = make_number (XINT (old_pos) - 1);
- prev_new = make_number (XINT (new_pos) - 1);
+ prev_old = make_fixnum (XFIXNUM (old_pos) - 1);
+ prev_new = make_fixnum (XFIXNUM (new_pos) - 1);
if (NILP (Vinhibit_field_text_motion)
&& !EQ (new_pos, old_pos)
@@ -848,16 +652,16 @@ Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
previous positions; we could use `Fget_pos_property'
instead, but in itself that would fail inside non-sticky
fields (like comint prompts). */
- || (XFASTINT (new_pos) > BEGV
+ || (XFIXNAT (new_pos) > BEGV
&& !NILP (Fget_char_property (prev_new, Qfield, Qnil)))
- || (XFASTINT (old_pos) > BEGV
+ || (XFIXNAT (old_pos) > BEGV
&& !NILP (Fget_char_property (prev_old, Qfield, Qnil))))
&& (NILP (inhibit_capture_property)
/* Field boundaries are again a problem; but now we must
decide the case exactly, so we need to call
`get_pos_property' as well. */
|| (NILP (Fget_pos_property (old_pos, inhibit_capture_property, Qnil))
- && (XFASTINT (old_pos) <= BEGV
+ && (XFIXNAT (old_pos) <= BEGV
|| NILP (Fget_char_property
(old_pos, inhibit_capture_property, Qnil))
|| NILP (Fget_char_property
@@ -865,7 +669,7 @@ Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
/* It is possible that NEW_POS is not within the same field as
OLD_POS; try to move NEW_POS so that it is. */
{
- ptrdiff_t shortage;
+ ptrdiff_t counted;
Lisp_Object field_bound;
if (fwd)
@@ -877,7 +681,7 @@ Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
other side of NEW_POS, which would mean that NEW_POS is
already acceptable, and it's not necessary to constrain it
to FIELD_BOUND. */
- ((XFASTINT (field_bound) < XFASTINT (new_pos)) ? fwd : !fwd)
+ ((XFIXNAT (field_bound) < XFIXNAT (new_pos)) ? fwd : !fwd)
/* NEW_POS should be constrained, but only if either
ONLY_IN_LINE is nil (in which case any constraint is OK),
or NEW_POS and FIELD_BOUND are on the same line (in which
@@ -886,16 +690,16 @@ Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
/* This is the ONLY_IN_LINE case, check that NEW_POS and
FIELD_BOUND are on the same line by seeing whether
there's an intervening newline or not. */
- || (find_newline (XFASTINT (new_pos), -1,
- XFASTINT (field_bound), -1,
- fwd ? -1 : 1, &shortage, NULL, 1),
- shortage != 0)))
+ || (find_newline (XFIXNAT (new_pos), -1,
+ XFIXNAT (field_bound), -1,
+ fwd ? -1 : 1, &counted, NULL, 1),
+ counted == 0)))
/* Constrain NEW_POS to FIELD_BOUND. */
new_pos = field_bound;
- if (orig_point && XFASTINT (new_pos) != orig_point)
+ if (orig_point && XFIXNAT (new_pos) != orig_point)
/* The NEW_POS argument was originally nil, so automatically set PT. */
- SET_PT (XFASTINT (new_pos));
+ SET_PT (XFIXNAT (new_pos));
}
return new_pos;
@@ -926,13 +730,13 @@ This function does not move point. */)
if (NILP (n))
XSETFASTINT (n, 1);
else
- CHECK_NUMBER (n);
+ CHECK_FIXNUM (n);
- scan_newline_from_point (XINT (n) - 1, &charpos, &bytepos);
+ scan_newline_from_point (XFIXNUM (n) - 1, &charpos, &bytepos);
/* Return END constrained to the current input field. */
- return Fconstrain_to_field (make_number (charpos), make_number (PT),
- XINT (n) != 1 ? Qt : Qnil,
+ return Fconstrain_to_field (make_fixnum (charpos), make_fixnum (PT),
+ XFIXNUM (n) != 1 ? Qt : Qnil,
Qt, Qnil);
}
@@ -961,69 +765,57 @@ This function does not move point. */)
if (NILP (n))
XSETFASTINT (n, 1);
else
- CHECK_NUMBER (n);
+ CHECK_FIXNUM (n);
- clipped_n = clip_to_bounds (PTRDIFF_MIN + 1, XINT (n), PTRDIFF_MAX);
+ clipped_n = clip_to_bounds (PTRDIFF_MIN + 1, XFIXNUM (n), PTRDIFF_MAX);
end_pos = find_before_next_newline (orig, 0, clipped_n - (clipped_n <= 0),
NULL);
/* Return END_POS constrained to the current input field. */
- return Fconstrain_to_field (make_number (end_pos), make_number (orig),
+ return Fconstrain_to_field (make_fixnum (end_pos), make_fixnum (orig),
Qnil, Qt, Qnil);
}
-/* Save current buffer state for `save-excursion' special form.
- We (ab)use Lisp_Misc_Save_Value to allow explicit free and so
- offload some work from GC. */
+/* Save current buffer state for save-excursion special form. */
-Lisp_Object
-save_excursion_save (void)
+void
+save_excursion_save (union specbinding *pdl)
{
- return make_save_obj_obj_obj_obj
- (Fpoint_marker (),
- Qnil,
- /* Selected window if current buffer is shown in it, nil otherwise. */
- (EQ (XWINDOW (selected_window)->contents, Fcurrent_buffer ())
- ? selected_window : Qnil),
- Qnil);
+ eassert (pdl->unwind_excursion.kind == SPECPDL_UNWIND_EXCURSION);
+ pdl->unwind_excursion.marker = Fpoint_marker ();
+ /* Selected window if current buffer is shown in it, nil otherwise. */
+ pdl->unwind_excursion.window
+ = (EQ (XWINDOW (selected_window)->contents, Fcurrent_buffer ())
+ ? selected_window : Qnil);
}
/* Restore saved buffer before leaving `save-excursion' special form. */
void
-save_excursion_restore (Lisp_Object info)
+save_excursion_restore (Lisp_Object marker, Lisp_Object window)
{
- Lisp_Object tem, tem1;
-
- tem = Fmarker_buffer (XSAVE_OBJECT (info, 0));
+ Lisp_Object buffer = Fmarker_buffer (marker);
/* If we're unwinding to top level, saved buffer may be deleted. This
- means that all of its markers are unchained and so tem is nil. */
- if (NILP (tem))
- goto out;
+ means that all of its markers are unchained and so BUFFER is nil. */
+ if (NILP (buffer))
+ return;
- Fset_buffer (tem);
+ Fset_buffer (buffer);
/* Point marker. */
- tem = XSAVE_OBJECT (info, 0);
- Fgoto_char (tem);
- unchain_marker (XMARKER (tem));
+ Fgoto_char (marker);
+ unchain_marker (XMARKER (marker));
/* If buffer was visible in a window, and a different window was
selected, and the old selected window is still showing this
buffer, restore point in that window. */
- tem = XSAVE_OBJECT (info, 2);
- if (WINDOWP (tem)
- && !EQ (tem, selected_window)
- && (tem1 = XWINDOW (tem)->contents,
- (/* Window is live... */
- BUFFERP (tem1)
- /* ...and it shows the current buffer. */
- && XBUFFER (tem1) == current_buffer)))
- Fset_window_point (tem, make_number (PT));
-
- out:
-
- free_misc (info);
+ if (WINDOWP (window) && !EQ (window, selected_window))
+ {
+ /* Set window point if WINDOW is live and shows the current buffer. */
+ Lisp_Object contents = XWINDOW (window)->contents;
+ if (BUFFERP (contents) && XBUFFER (contents) == current_buffer)
+ Fset_window_point (window, make_fixnum (PT));
+ }
}
DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0,
@@ -1045,7 +837,7 @@ usage: (save-excursion &rest BODY) */)
register Lisp_Object val;
ptrdiff_t count = SPECPDL_INDEX ();
- record_unwind_protect (save_excursion_restore, save_excursion_save ());
+ record_unwind_protect_excursion ();
val = Fprogn (args);
return unbind_to (count, val);
@@ -1076,11 +868,11 @@ in some other BUFFER, use
(Lisp_Object buffer)
{
if (NILP (buffer))
- return make_number (Z - BEG);
+ return make_fixnum (Z - BEG);
else
{
CHECK_BUFFER (buffer);
- return make_number (BUF_Z (XBUFFER (buffer))
+ return make_fixnum (BUF_Z (XBUFFER (buffer))
- BUF_BEG (XBUFFER (buffer)));
}
}
@@ -1148,10 +940,10 @@ DEFUN ("position-bytes", Fposition_bytes, Sposition_bytes, 1, 1, 0,
If POSITION is out of range, the value is nil. */)
(Lisp_Object position)
{
- CHECK_NUMBER_COERCE_MARKER (position);
- if (XINT (position) < BEG || XINT (position) > Z)
+ CHECK_FIXNUM_COERCE_MARKER (position);
+ if (XFIXNUM (position) < BEG || XFIXNUM (position) > Z)
return Qnil;
- return make_number (CHAR_TO_BYTE (XINT (position)));
+ return make_fixnum (CHAR_TO_BYTE (XFIXNUM (position)));
}
DEFUN ("byte-to-position", Fbyte_to_position, Sbyte_to_position, 1, 1, 0,
@@ -1161,8 +953,8 @@ If BYTEPOS is out of range, the value is nil. */)
{
ptrdiff_t pos_byte;
- CHECK_NUMBER (bytepos);
- pos_byte = XINT (bytepos);
+ CHECK_FIXNUM (bytepos);
+ pos_byte = XFIXNUM (bytepos);
if (pos_byte < BEG_BYTE || pos_byte > Z_BYTE)
return Qnil;
if (Z != Z_BYTE)
@@ -1172,7 +964,7 @@ If BYTEPOS is out of range, the value is nil. */)
character. */
while (!CHAR_HEAD_P (FETCH_BYTE (pos_byte)))
pos_byte--;
- return make_number (BYTE_TO_CHAR (pos_byte));
+ return make_fixnum (BYTE_TO_CHAR (pos_byte));
}
DEFUN ("following-char", Ffollowing_char, Sfollowing_char, 0, 0, 0,
@@ -1257,10 +1049,10 @@ If POS is out of range, the value is nil. */)
if (NILP (pos))
{
pos_byte = PT_BYTE;
- XSETFASTINT (pos, PT);
+ if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE)
+ return Qnil;
}
-
- if (MARKERP (pos))
+ else if (MARKERP (pos))
{
pos_byte = marker_byte_position (pos);
if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE)
@@ -1268,14 +1060,14 @@ If POS is out of range, the value is nil. */)
}
else
{
- CHECK_NUMBER_COERCE_MARKER (pos);
- if (XINT (pos) < BEGV || XINT (pos) >= ZV)
+ CHECK_FIXNUM_COERCE_MARKER (pos);
+ if (XFIXNUM (pos) < BEGV || XFIXNUM (pos) >= ZV)
return Qnil;
- pos_byte = CHAR_TO_BYTE (XINT (pos));
+ pos_byte = CHAR_TO_BYTE (XFIXNUM (pos));
}
- return make_number (FETCH_CHAR (pos_byte));
+ return make_fixnum (FETCH_CHAR (pos_byte));
}
DEFUN ("char-before", Fchar_before, Schar_before, 0, 1, 0,
@@ -1302,12 +1094,12 @@ If POS is out of range, the value is nil. */)
}
else
{
- CHECK_NUMBER_COERCE_MARKER (pos);
+ CHECK_FIXNUM_COERCE_MARKER (pos);
- if (XINT (pos) <= BEGV || XINT (pos) > ZV)
+ if (XFIXNUM (pos) <= BEGV || XFIXNUM (pos) > ZV)
return Qnil;
- pos_byte = CHAR_TO_BYTE (XINT (pos));
+ pos_byte = CHAR_TO_BYTE (XFIXNUM (pos));
}
if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
@@ -1329,7 +1121,7 @@ This is based on the effective uid, not the real uid.
Also, if the environment variables LOGNAME or USER are set,
that determines the value of this function.
-If optional argument UID is an integer or a float, return the login name
+If optional argument UID is an integer, return the login name
of the user with that uid, or nil if there is no such user. */)
(Lisp_Object uid)
{
@@ -1340,7 +1132,7 @@ of the user with that uid, or nil if there is no such user. */)
(That can happen if Emacs is dumpable
but you decide to run `temacs -l loadup' and not dump. */
if (NILP (Vuser_login_name))
- init_editfns (false);
+ init_editfns ();
if (NILP (uid))
return Vuser_login_name;
@@ -1363,44 +1155,62 @@ This ignores the environment variables LOGNAME and USER, so it differs from
(That can happen if Emacs is dumpable
but you decide to run `temacs -l loadup' and not dump. */
if (NILP (Vuser_login_name))
- init_editfns (false);
+ init_editfns ();
return Vuser_real_login_name;
}
DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0,
doc: /* Return the effective uid of Emacs.
-Value is an integer or a float, depending on the value. */)
+Value is a fixnum, if it's small enough, otherwise a bignum. */)
(void)
{
uid_t euid = geteuid ();
- return make_fixnum_or_float (euid);
+ return INT_TO_INTEGER (euid);
}
DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0,
doc: /* Return the real uid of Emacs.
-Value is an integer or a float, depending on the value. */)
+Value is a fixnum, if it's small enough, otherwise a bignum. */)
(void)
{
uid_t uid = getuid ();
- return make_fixnum_or_float (uid);
+ return INT_TO_INTEGER (uid);
+}
+
+DEFUN ("group-name", Fgroup_name, Sgroup_name, 1, 1, 0,
+ doc: /* Return the name of the group whose numeric group ID is GID.
+The argument GID should be an integer or a float.
+Return nil if a group with such GID does not exists or is not known. */)
+ (Lisp_Object gid)
+{
+ struct group *gr;
+ gid_t id;
+
+ if (!NUMBERP (gid) && !CONSP (gid))
+ error ("Invalid GID specification");
+ CONS_TO_INTEGER (gid, gid_t, id);
+ block_input ();
+ gr = getgrgid (id);
+ unblock_input ();
+ return gr ? build_string (gr->gr_name) : Qnil;
}
DEFUN ("group-gid", Fgroup_gid, Sgroup_gid, 0, 0, 0,
doc: /* Return the effective gid of Emacs.
-Value is an integer or a float, depending on the value. */)
+Value is a fixnum, if it's small enough, otherwise a bignum. */)
(void)
{
gid_t egid = getegid ();
- return make_fixnum_or_float (egid);
+ return INT_TO_INTEGER (egid);
}
DEFUN ("group-real-gid", Fgroup_real_gid, Sgroup_real_gid, 0, 0, 0,
doc: /* Return the real gid of Emacs.
-Value is an integer or a float, depending on the value. */)
+Value is a fixnum, if it's small enough, otherwise a bignum. */)
(void)
{
gid_t gid = getgid ();
- return make_fixnum_or_float (gid);
+ return INT_TO_INTEGER (gid);
}
DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 1, 0,
@@ -1408,7 +1218,7 @@ DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 1, 0,
If the full name corresponding to Emacs's userid is not known,
return "unknown".
-If optional argument UID is an integer or float, return the full name
+If optional argument UID is an integer, return the full name
of the user with that uid, or nil if there is no such user.
If UID is a string, return the full name of the user with that login
name, or nil if there is no such user. */)
@@ -1451,7 +1261,7 @@ name, or nil if there is no such user. */)
/* Substitute the login name for the &, upcasing the first character. */
if (q)
{
- Lisp_Object login = Fuser_login_name (make_number (pw->pw_uid));
+ Lisp_Object login = Fuser_login_name (INT_TO_INTEGER (pw->pw_uid));
USE_SAFE_ALLOCA;
char *r = SAFE_ALLOCA (strlen (p) + SBYTES (login) + 1);
memcpy (r, p, q - p);
@@ -1476,1028 +1286,14 @@ DEFUN ("system-name", Fsystem_name, Ssystem_name, 0, 0, 0,
}
DEFUN ("emacs-pid", Femacs_pid, Semacs_pid, 0, 0, 0,
- doc: /* Return the process ID of Emacs, as a number. */)
+ doc: /* Return the process ID of Emacs, as a number.
+Value is a fixnum, if it's small enough, otherwise a bignum. */)
(void)
{
pid_t pid = getpid ();
- return make_fixnum_or_float (pid);
-}
-
-
-
-#ifndef TIME_T_MIN
-# define TIME_T_MIN TYPE_MINIMUM (time_t)
-#endif
-#ifndef TIME_T_MAX
-# define TIME_T_MAX TYPE_MAXIMUM (time_t)
-#endif
-
-/* Report that a time value is out of range for Emacs. */
-void
-time_overflow (void)
-{
- error ("Specified time is not representable");
-}
-
-static _Noreturn void
-invalid_time (void)
-{
- error ("Invalid time specification");
-}
-
-/* Check a return value compatible with that of decode_time_components. */
-static void
-check_time_validity (int validity)
-{
- if (validity <= 0)
- {
- if (validity < 0)
- time_overflow ();
- else
- invalid_time ();
- }
-}
-
-/* Return the upper part of the time T (everything but the bottom 16 bits). */
-static EMACS_INT
-hi_time (time_t t)
-{
- time_t hi = t >> LO_TIME_BITS;
- if (FIXNUM_OVERFLOW_P (hi))
- time_overflow ();
- return hi;
-}
-
-/* Return the bottom bits of the time T. */
-static int
-lo_time (time_t t)
-{
- return t & ((1 << LO_TIME_BITS) - 1);
-}
-
-DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0,
- doc: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
-The time is returned as a list of integers (HIGH LOW USEC PSEC).
-HIGH has the most significant bits of the seconds, while LOW has the
-least significant 16 bits. USEC and PSEC are the microsecond and
-picosecond counts. */)
- (void)
-{
- return make_lisp_time (current_timespec ());
-}
-
-static struct lisp_time
-time_add (struct lisp_time ta, struct lisp_time tb)
-{
- EMACS_INT hi = ta.hi + tb.hi;
- int lo = ta.lo + tb.lo;
- int us = ta.us + tb.us;
- int ps = ta.ps + tb.ps;
- us += (1000000 <= ps);
- ps -= (1000000 <= ps) * 1000000;
- lo += (1000000 <= us);
- us -= (1000000 <= us) * 1000000;
- hi += (1 << LO_TIME_BITS <= lo);
- lo -= (1 << LO_TIME_BITS <= lo) << LO_TIME_BITS;
- return (struct lisp_time) { hi, lo, us, ps };
-}
-
-static struct lisp_time
-time_subtract (struct lisp_time ta, struct lisp_time tb)
-{
- EMACS_INT hi = ta.hi - tb.hi;
- int lo = ta.lo - tb.lo;
- int us = ta.us - tb.us;
- int ps = ta.ps - tb.ps;
- us -= (ps < 0);
- ps += (ps < 0) * 1000000;
- lo -= (us < 0);
- us += (us < 0) * 1000000;
- hi -= (lo < 0);
- lo += (lo < 0) << LO_TIME_BITS;
- return (struct lisp_time) { hi, lo, us, ps };
-}
-
-static Lisp_Object
-time_arith (Lisp_Object a, Lisp_Object b,
- struct lisp_time (*op) (struct lisp_time, struct lisp_time))
-{
- int alen, blen;
- struct lisp_time ta = lisp_time_struct (a, &alen);
- struct lisp_time tb = lisp_time_struct (b, &blen);
- struct lisp_time t = op (ta, tb);
- if (FIXNUM_OVERFLOW_P (t.hi))
- time_overflow ();
- Lisp_Object val = Qnil;
-
- switch (max (alen, blen))
- {
- default:
- val = Fcons (make_number (t.ps), val);
- FALLTHROUGH;
- case 3:
- val = Fcons (make_number (t.us), val);
- FALLTHROUGH;
- case 2:
- val = Fcons (make_number (t.lo), val);
- val = Fcons (make_number (t.hi), val);
- break;
- }
-
- return val;
-}
-
-DEFUN ("time-add", Ftime_add, Stime_add, 2, 2, 0,
- doc: /* Return the sum of two time values A and B, as a time value.
-A nil value for either argument stands for the current time.
-See `current-time-string' for the various forms of a time value. */)
- (Lisp_Object a, Lisp_Object b)
-{
- return time_arith (a, b, time_add);
-}
-
-DEFUN ("time-subtract", Ftime_subtract, Stime_subtract, 2, 2, 0,
- doc: /* Return the difference between two time values A and B, as a time value.
-Use `float-time' to convert the difference into elapsed seconds.
-A nil value for either argument stands for the current time.
-See `current-time-string' for the various forms of a time value. */)
- (Lisp_Object a, Lisp_Object b)
-{
- return time_arith (a, b, time_subtract);
-}
-
-DEFUN ("time-less-p", Ftime_less_p, Stime_less_p, 2, 2, 0,
- doc: /* Return non-nil if time value T1 is earlier than time value T2.
-A nil value for either argument stands for the current time.
-See `current-time-string' for the various forms of a time value. */)
- (Lisp_Object t1, Lisp_Object t2)
-{
- int t1len, t2len;
- struct lisp_time a = lisp_time_struct (t1, &t1len);
- struct lisp_time b = lisp_time_struct (t2, &t2len);
- return ((a.hi != b.hi ? a.hi < b.hi
- : a.lo != b.lo ? a.lo < b.lo
- : a.us != b.us ? a.us < b.us
- : a.ps < b.ps)
- ? Qt : Qnil);
-}
-
-
-DEFUN ("get-internal-run-time", Fget_internal_run_time, Sget_internal_run_time,
- 0, 0, 0,
- doc: /* Return the current run time used by Emacs.
-The time is returned as a list (HIGH LOW USEC PSEC), using the same
-style as (current-time).
-
-On systems that can't determine the run time, `get-internal-run-time'
-does the same thing as `current-time'. */)
- (void)
-{
-#ifdef HAVE_GETRUSAGE
- struct rusage usage;
- time_t secs;
- int usecs;
-
- if (getrusage (RUSAGE_SELF, &usage) < 0)
- /* This shouldn't happen. What action is appropriate? */
- xsignal0 (Qerror);
-
- /* Sum up user time and system time. */
- secs = usage.ru_utime.tv_sec + usage.ru_stime.tv_sec;
- usecs = usage.ru_utime.tv_usec + usage.ru_stime.tv_usec;
- if (usecs >= 1000000)
- {
- usecs -= 1000000;
- secs++;
- }
- return make_lisp_time (make_timespec (secs, usecs * 1000));
-#else /* ! HAVE_GETRUSAGE */
-#ifdef WINDOWSNT
- return w32_get_internal_run_time ();
-#else /* ! WINDOWSNT */
- return Fcurrent_time ();
-#endif /* WINDOWSNT */
-#endif /* HAVE_GETRUSAGE */
-}
-
-
-/* Make a Lisp list that represents the Emacs time T. T may be an
- invalid time, with a slightly negative tv_nsec value such as
- UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
- correspondingly negative picosecond count. */
-Lisp_Object
-make_lisp_time (struct timespec t)
-{
- time_t s = t.tv_sec;
- int ns = t.tv_nsec;
- return list4i (hi_time (s), lo_time (s), ns / 1000, ns % 1000 * 1000);
-}
-
-/* Decode a Lisp list SPECIFIED_TIME that represents a time.
- Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
- Return 2, 3, or 4 to indicate the effective length of SPECIFIED_TIME
- if successful, 0 if unsuccessful. */
-static int
-disassemble_lisp_time (Lisp_Object specified_time, Lisp_Object *phigh,
- Lisp_Object *plow, Lisp_Object *pusec,
- Lisp_Object *ppsec)
-{
- Lisp_Object high = make_number (0);
- Lisp_Object low = specified_time;
- Lisp_Object usec = make_number (0);
- Lisp_Object psec = make_number (0);
- int len = 4;
-
- if (CONSP (specified_time))
- {
- high = XCAR (specified_time);
- low = XCDR (specified_time);
- if (CONSP (low))
- {
- Lisp_Object low_tail = XCDR (low);
- low = XCAR (low);
- if (CONSP (low_tail))
- {
- usec = XCAR (low_tail);
- low_tail = XCDR (low_tail);
- if (CONSP (low_tail))
- psec = XCAR (low_tail);
- else
- len = 3;
- }
- else if (!NILP (low_tail))
- {
- usec = low_tail;
- len = 3;
- }
- else
- len = 2;
- }
- else
- len = 2;
-
- /* When combining components, require LOW to be an integer,
- as otherwise it would be a pain to add up times. */
- if (! INTEGERP (low))
- return 0;
- }
- else if (INTEGERP (specified_time))
- len = 2;
-
- *phigh = high;
- *plow = low;
- *pusec = usec;
- *ppsec = psec;
- return len;
-}
-
-/* Convert T into an Emacs time *RESULT, truncating toward minus infinity.
- Return true if T is in range, false otherwise. */
-static bool
-decode_float_time (double t, struct lisp_time *result)
-{
- double lo_multiplier = 1 << LO_TIME_BITS;
- double emacs_time_min = MOST_NEGATIVE_FIXNUM * lo_multiplier;
- if (! (emacs_time_min <= t && t < -emacs_time_min))
- return false;
-
- double small_t = t / lo_multiplier;
- EMACS_INT hi = small_t;
- double t_sans_hi = t - hi * lo_multiplier;
- int lo = t_sans_hi;
- long double fracps = (t_sans_hi - lo) * 1e12L;
-#ifdef INT_FAST64_MAX
- int_fast64_t ifracps = fracps;
- int us = ifracps / 1000000;
- int ps = ifracps % 1000000;
-#else
- int us = fracps / 1e6L;
- int ps = fracps - us * 1e6L;
-#endif
- us -= (ps < 0);
- ps += (ps < 0) * 1000000;
- lo -= (us < 0);
- us += (us < 0) * 1000000;
- hi -= (lo < 0);
- lo += (lo < 0) << LO_TIME_BITS;
- result->hi = hi;
- result->lo = lo;
- result->us = us;
- result->ps = ps;
- return true;
-}
-
-/* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
- list, generate the corresponding time value.
- If LOW is floating point, the other components should be zero.
-
- If RESULT is not null, store into *RESULT the converted time.
- If *DRESULT is not null, store into *DRESULT the number of
- seconds since the start of the POSIX Epoch.
-
- Return 1 if successful, 0 if the components are of the
- wrong type, and -1 if the time is out of range. */
-int
-decode_time_components (Lisp_Object high, Lisp_Object low, Lisp_Object usec,
- Lisp_Object psec,
- struct lisp_time *result, double *dresult)
-{
- EMACS_INT hi, lo, us, ps;
- if (! (INTEGERP (high)
- && INTEGERP (usec) && INTEGERP (psec)))
- return 0;
- if (! INTEGERP (low))
- {
- if (FLOATP (low))
- {
- double t = XFLOAT_DATA (low);
- if (result && ! decode_float_time (t, result))
- return -1;
- if (dresult)
- *dresult = t;
- return 1;
- }
- else if (NILP (low))
- {
- struct timespec now = current_timespec ();
- if (result)
- {
- result->hi = hi_time (now.tv_sec);
- result->lo = lo_time (now.tv_sec);
- result->us = now.tv_nsec / 1000;
- result->ps = now.tv_nsec % 1000 * 1000;
- }
- if (dresult)
- *dresult = now.tv_sec + now.tv_nsec / 1e9;
- return 1;
- }
- else
- return 0;
- }
-
- hi = XINT (high);
- lo = XINT (low);
- us = XINT (usec);
- ps = XINT (psec);
-
- /* Normalize out-of-range lower-order components by carrying
- each overflow into the next higher-order component. */
- us += ps / 1000000 - (ps % 1000000 < 0);
- lo += us / 1000000 - (us % 1000000 < 0);
- hi += lo >> LO_TIME_BITS;
- ps = ps % 1000000 + 1000000 * (ps % 1000000 < 0);
- us = us % 1000000 + 1000000 * (us % 1000000 < 0);
- lo &= (1 << LO_TIME_BITS) - 1;
-
- if (result)
- {
- if (FIXNUM_OVERFLOW_P (hi))
- return -1;
- result->hi = hi;
- result->lo = lo;
- result->us = us;
- result->ps = ps;
- }
-
- if (dresult)
- {
- double dhi = hi;
- *dresult = (us * 1e6 + ps) / 1e12 + lo + dhi * (1 << LO_TIME_BITS);
- }
-
- return 1;
-}
-
-struct timespec
-lisp_to_timespec (struct lisp_time t)
-{
- if (! ((TYPE_SIGNED (time_t) ? TIME_T_MIN >> LO_TIME_BITS <= t.hi : 0 <= t.hi)
- && t.hi <= TIME_T_MAX >> LO_TIME_BITS))
- return invalid_timespec ();
- time_t s = (t.hi << LO_TIME_BITS) + t.lo;
- int ns = t.us * 1000 + t.ps / 1000;
- return make_timespec (s, ns);
-}
-
-/* Decode a Lisp list SPECIFIED_TIME that represents a time.
- Store its effective length into *PLEN.
- If SPECIFIED_TIME is nil, use the current time.
- Signal an error if SPECIFIED_TIME does not represent a time. */
-static struct lisp_time
-lisp_time_struct (Lisp_Object specified_time, int *plen)
-{
- Lisp_Object high, low, usec, psec;
- struct lisp_time t;
- int len = disassemble_lisp_time (specified_time, &high, &low, &usec, &psec);
- if (!len)
- invalid_time ();
- int val = decode_time_components (high, low, usec, psec, &t, 0);
- check_time_validity (val);
- *plen = len;
- return t;
-}
-
-/* Like lisp_time_struct, except return a struct timespec.
- Discard any low-order digits. */
-struct timespec
-lisp_time_argument (Lisp_Object specified_time)
-{
- int len;
- struct lisp_time lt = lisp_time_struct (specified_time, &len);
- struct timespec t = lisp_to_timespec (lt);
- if (! timespec_valid_p (t))
- time_overflow ();
- return t;
-}
-
-/* Like lisp_time_argument, except decode only the seconds part,
- and do not check the subseconds part. */
-static time_t
-lisp_seconds_argument (Lisp_Object specified_time)
-{
- Lisp_Object high, low, usec, psec;
- struct lisp_time t;
-
- int val = disassemble_lisp_time (specified_time, &high, &low, &usec, &psec);
- if (val != 0)
- {
- val = decode_time_components (high, low, make_number (0),
- make_number (0), &t, 0);
- if (0 < val
- && ! ((TYPE_SIGNED (time_t)
- ? TIME_T_MIN >> LO_TIME_BITS <= t.hi
- : 0 <= t.hi)
- && t.hi <= TIME_T_MAX >> LO_TIME_BITS))
- val = -1;
- }
- check_time_validity (val);
- return (t.hi << LO_TIME_BITS) + t.lo;
-}
-
-DEFUN ("float-time", Ffloat_time, Sfloat_time, 0, 1, 0,
- doc: /* Return the current time, as a float number of seconds since the epoch.
-If SPECIFIED-TIME is given, it is the time to convert to float
-instead of the current time. The argument should have the form
-\(HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
-you can use times from `current-time' and from `file-attributes'.
-SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
-considered obsolete.
-
-WARNING: Since the result is floating point, it may not be exact.
-If precise time stamps are required, use either `current-time',
-or (if you need time as a string) `format-time-string'. */)
- (Lisp_Object specified_time)
-{
- double t;
- Lisp_Object high, low, usec, psec;
- if (! (disassemble_lisp_time (specified_time, &high, &low, &usec, &psec)
- && decode_time_components (high, low, usec, psec, 0, &t)))
- invalid_time ();
- return make_float (t);
-}
-
-/* Write information into buffer S of size MAXSIZE, according to the
- FORMAT of length FORMAT_LEN, using time information taken from *TP.
- Use the time zone specified by TZ.
- Use NS as the number of nanoseconds in the %N directive.
- Return the number of bytes written, not including the terminating
- '\0'. If S is NULL, nothing will be written anywhere; so to
- determine how many bytes would be written, use NULL for S and
- ((size_t) -1) for MAXSIZE.
-
- This function behaves like nstrftime, except it allows null
- bytes in FORMAT and it does not support nanoseconds. */
-static size_t
-emacs_nmemftime (char *s, size_t maxsize, const char *format,
- size_t format_len, const struct tm *tp, timezone_t tz, int ns)
-{
- size_t total = 0;
-
- /* Loop through all the null-terminated strings in the format
- argument. Normally there's just one null-terminated string, but
- there can be arbitrarily many, concatenated together, if the
- format contains '\0' bytes. nstrftime stops at the first
- '\0' byte so we must invoke it separately for each such string. */
- for (;;)
- {
- size_t len;
- size_t result;
-
- if (s)
- s[0] = '\1';
-
- result = nstrftime (s, maxsize, format, tp, tz, ns);
-
- if (s)
- {
- if (result == 0 && s[0] != '\0')
- return 0;
- s += result + 1;
- }
-
- maxsize -= result + 1;
- total += result;
- len = strlen (format);
- if (len == format_len)
- return total;
- total++;
- format += len + 1;
- format_len -= len + 1;
- }
-}
-
-DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0,
- doc: /* Use FORMAT-STRING to format the time TIME, or now if omitted or nil.
-TIME is specified as (HIGH LOW USEC PSEC), as returned by
-`current-time' or `file-attributes'. It can also be a single integer
-number of seconds since the epoch. The obsolete form (HIGH . LOW) is
-also still accepted.
-
-The optional ZONE is omitted or nil for Emacs local time, t for
-Universal Time, `wall' for system wall clock time, or a string as in
-the TZ environment variable. It can also be a list (as from
-`current-time-zone') or an integer (as from `decode-time') applied
-without consideration for daylight saving time.
-
-The value is a copy of FORMAT-STRING, but with certain constructs replaced
-by text that describes the specified date and time in TIME:
-
-%Y is the year, %y within the century, %C the century.
-%G is the year corresponding to the ISO week, %g within the century.
-%m is the numeric month.
-%b and %h are the locale's abbreviated month name, %B the full name.
- (%h is not supported on MS-Windows.)
-%d is the day of the month, zero-padded, %e is blank-padded.
-%u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
-%a is the locale's abbreviated name of the day of week, %A the full name.
-%U is the week number starting on Sunday, %W starting on Monday,
- %V according to ISO 8601.
-%j is the day of the year.
-
-%H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
- only blank-padded, %l is like %I blank-padded.
-%p is the locale's equivalent of either AM or PM.
-%q is the calendar quarter (1–4).
-%M is the minute (00-59).
-%S is the second (00-59; 00-60 on platforms with leap seconds)
-%s is the number of seconds since 1970-01-01 00:00:00 +0000.
-%N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
-%Z is the time zone abbreviation, %z is the numeric form.
-
-%c is the locale's date and time format.
-%x is the locale's "preferred" date format.
-%D is like "%m/%d/%y".
-%F is the ISO 8601 date format (like "%Y-%m-%d").
-
-%R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
-%X is the locale's "preferred" time format.
-
-Finally, %n is a newline, %t is a tab, %% is a literal %, and
-unrecognized %-sequences stand for themselves.
-
-Certain flags and modifiers are available with some format controls.
-The flags are `_', `-', `^' and `#'. For certain characters X,
-%_X is like %X, but padded with blanks; %-X is like %X,
-but without padding. %^X is like %X, but with all textual
-characters up-cased; %#X is like %X, but with letter-case of
-all textual characters reversed.
-%NX (where N stands for an integer) is like %X,
-but takes up at least N (a number) positions.
-The modifiers are `E' and `O'. For certain characters X,
-%EX is a locale's alternative version of %X;
-%OX is like %X, but uses the locale's number symbols.
-
-For example, to produce full ISO 8601 format, use "%FT%T%z".
-
-usage: (format-time-string FORMAT-STRING &optional TIME ZONE) */)
- (Lisp_Object format_string, Lisp_Object timeval, Lisp_Object zone)
-{
- struct timespec t = lisp_time_argument (timeval);
- struct tm tm;
-
- CHECK_STRING (format_string);
- format_string = code_convert_string_norecord (format_string,
- Vlocale_coding_system, 1);
- return format_time_string (SSDATA (format_string), SBYTES (format_string),
- t, zone, &tm);
-}
-
-static Lisp_Object
-format_time_string (char const *format, ptrdiff_t formatlen,
- struct timespec t, Lisp_Object zone, struct tm *tmp)
-{
- char buffer[4000];
- char *buf = buffer;
- ptrdiff_t size = sizeof buffer;
- size_t len;
- int ns = t.tv_nsec;
- USE_SAFE_ALLOCA;
-
- timezone_t tz = tzlookup (zone, false);
- /* On some systems, like 32-bit MinGW, tv_sec of struct timespec is
- a 64-bit type, but time_t is a 32-bit type. emacs_localtime_rz
- expects a pointer to time_t value. */
- time_t tsec = t.tv_sec;
- tmp = emacs_localtime_rz (tz, &tsec, tmp);
- if (! tmp)
- {
- xtzfree (tz);
- time_overflow ();
- }
- synchronize_system_time_locale ();
-
- while (true)
- {
- buf[0] = '\1';
- len = emacs_nmemftime (buf, size, format, formatlen, tmp, tz, ns);
- if ((0 < len && len < size) || (len == 0 && buf[0] == '\0'))
- break;
-
- /* Buffer was too small, so make it bigger and try again. */
- len = emacs_nmemftime (NULL, SIZE_MAX, format, formatlen, tmp, tz, ns);
- if (STRING_BYTES_BOUND <= len)
- {
- xtzfree (tz);
- string_overflow ();
- }
- size = len + 1;
- buf = SAFE_ALLOCA (size);
- }
-
- xtzfree (tz);
- AUTO_STRING_WITH_LEN (bufstring, buf, len);
- Lisp_Object result = code_convert_string_norecord (bufstring,
- Vlocale_coding_system, 0);
- SAFE_FREE ();
- return result;
-}
-
-DEFUN ("decode-time", Fdecode_time, Sdecode_time, 0, 2, 0,
- doc: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF).
-The optional TIME should be a list of (HIGH LOW . IGNORED),
-as from `current-time' and `file-attributes', or nil to use the
-current time. It can also be a single integer number of seconds since
-the epoch. The obsolete form (HIGH . LOW) is also still accepted.
-
-The optional ZONE is omitted or nil for Emacs local time, t for
-Universal Time, `wall' for system wall clock time, or a string as in
-the TZ environment variable. It can also be a list (as from
-`current-time-zone') or an integer (the UTC offset in seconds) applied
-without consideration for daylight saving time.
-
-The list has the following nine members: SEC is an integer between 0
-and 60; SEC is 60 for a leap second, which only some operating systems
-support. MINUTE is an integer between 0 and 59. HOUR is an integer
-between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
-integer between 1 and 12. YEAR is an integer indicating the
-four-digit year. DOW is the day of week, an integer between 0 and 6,
-where 0 is Sunday. DST is t if daylight saving time is in effect,
-otherwise nil. UTCOFF is an integer indicating the UTC offset in
-seconds, i.e., the number of seconds east of Greenwich. (Note that
-Common Lisp has different meanings for DOW and UTCOFF.)
-
-usage: (decode-time &optional TIME ZONE) */)
- (Lisp_Object specified_time, Lisp_Object zone)
-{
- time_t time_spec = lisp_seconds_argument (specified_time);
- struct tm local_tm, gmt_tm;
- timezone_t tz = tzlookup (zone, false);
- struct tm *tm = emacs_localtime_rz (tz, &time_spec, &local_tm);
- xtzfree (tz);
-
- if (! (tm
- && MOST_NEGATIVE_FIXNUM - TM_YEAR_BASE <= local_tm.tm_year
- && local_tm.tm_year <= MOST_POSITIVE_FIXNUM - TM_YEAR_BASE))
- time_overflow ();
-
- /* Avoid overflow when INT_MAX < EMACS_INT_MAX. */
- EMACS_INT tm_year_base = TM_YEAR_BASE;
-
- return CALLN (Flist,
- make_number (local_tm.tm_sec),
- make_number (local_tm.tm_min),
- make_number (local_tm.tm_hour),
- make_number (local_tm.tm_mday),
- make_number (local_tm.tm_mon + 1),
- make_number (local_tm.tm_year + tm_year_base),
- make_number (local_tm.tm_wday),
- local_tm.tm_isdst ? Qt : Qnil,
- (HAVE_TM_GMTOFF
- ? make_number (tm_gmtoff (&local_tm))
- : gmtime_r (&time_spec, &gmt_tm)
- ? make_number (tm_diff (&local_tm, &gmt_tm))
- : Qnil));
-}
-
-/* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
- the result is representable as an int. */
-static int
-check_tm_member (Lisp_Object obj, int offset)
-{
- CHECK_NUMBER (obj);
- EMACS_INT n = XINT (obj);
- int result;
- if (INT_SUBTRACT_WRAPV (n, offset, &result))
- time_overflow ();
- return result;
-}
-
-DEFUN ("encode-time", Fencode_time, Sencode_time, 6, MANY, 0,
- doc: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
-This is the reverse operation of `decode-time', which see.
-
-The optional ZONE is omitted or nil for Emacs local time, t for
-Universal Time, `wall' for system wall clock time, or a string as in
-the TZ environment variable. It can also be a list (as from
-`current-time-zone') or an integer (as from `decode-time') applied
-without consideration for daylight saving time.
-
-You can pass more than 7 arguments; then the first six arguments
-are used as SECOND through YEAR, and the *last* argument is used as ZONE.
-The intervening arguments are ignored.
-This feature lets (apply \\='encode-time (decode-time ...)) work.
-
-Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
-for example, a DAY of 0 means the day preceding the given month.
-Year numbers less than 100 are treated just like other year numbers.
-If you want them to stand for years in this century, you must do that yourself.
-
-Years before 1970 are not guaranteed to work. On some systems,
-year values as low as 1901 do work.
-
-usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
- (ptrdiff_t nargs, Lisp_Object *args)
-{
- time_t value;
- struct tm tm;
- Lisp_Object zone = (nargs > 6 ? args[nargs - 1] : Qnil);
-
- tm.tm_sec = check_tm_member (args[0], 0);
- tm.tm_min = check_tm_member (args[1], 0);
- tm.tm_hour = check_tm_member (args[2], 0);
- tm.tm_mday = check_tm_member (args[3], 0);
- tm.tm_mon = check_tm_member (args[4], 1);
- tm.tm_year = check_tm_member (args[5], TM_YEAR_BASE);
- tm.tm_isdst = -1;
-
- timezone_t tz = tzlookup (zone, false);
- value = emacs_mktime_z (tz, &tm);
- xtzfree (tz);
-
- if (value == (time_t) -1)
- time_overflow ();
-
- return list2i (hi_time (value), lo_time (value));
+ return INT_TO_INTEGER (pid);
}
-DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string,
- 0, 2, 0,
- doc: /* Return the current local time, as a human-readable string.
-Programs can use this function to decode a time,
-since the number of columns in each field is fixed
-if the year is in the range 1000-9999.
-The format is `Sun Sep 16 01:03:52 1973'.
-However, see also the functions `decode-time' and `format-time-string'
-which provide a much more powerful and general facility.
-
-If SPECIFIED-TIME is given, it is a time to format instead of the
-current time. The argument should have the form (HIGH LOW . IGNORED).
-Thus, you can use times obtained from `current-time' and from
-`file-attributes'. SPECIFIED-TIME can also be a single integer number
-of seconds since the epoch. The obsolete form (HIGH . LOW) is also
-still accepted.
-
-The optional ZONE is omitted or nil for Emacs local time, t for
-Universal Time, `wall' for system wall clock time, or a string as in
-the TZ environment variable. It can also be a list (as from
-`current-time-zone') or an integer (as from `decode-time') applied
-without consideration for daylight saving time. */)
- (Lisp_Object specified_time, Lisp_Object zone)
-{
- time_t value = lisp_seconds_argument (specified_time);
- timezone_t tz = tzlookup (zone, false);
-
- /* Convert to a string in ctime format, except without the trailing
- newline, and without the 4-digit year limit. Don't use asctime
- or ctime, as they might dump core if the year is outside the
- range -999 .. 9999. */
- struct tm tm;
- struct tm *tmp = emacs_localtime_rz (tz, &value, &tm);
- xtzfree (tz);
- if (! tmp)
- time_overflow ();
-
- static char const wday_name[][4] =
- { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
- static char const mon_name[][4] =
- { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
- "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
- printmax_t year_base = TM_YEAR_BASE;
- char buf[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
- int len = sprintf (buf, "%s %s%3d %02d:%02d:%02d %"pMd,
- wday_name[tm.tm_wday], mon_name[tm.tm_mon], tm.tm_mday,
- tm.tm_hour, tm.tm_min, tm.tm_sec,
- tm.tm_year + year_base);
-
- return make_unibyte_string (buf, len);
-}
-
-/* Yield A - B, measured in seconds.
- This function is copied from the GNU C Library. */
-static int
-tm_diff (struct tm *a, struct tm *b)
-{
- /* Compute intervening leap days correctly even if year is negative.
- Take care to avoid int overflow in leap day calculations,
- but it's OK to assume that A and B are close to each other. */
- int a4 = (a->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (a->tm_year & 3);
- int b4 = (b->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (b->tm_year & 3);
- int a100 = a4 / 25 - (a4 % 25 < 0);
- int b100 = b4 / 25 - (b4 % 25 < 0);
- int a400 = a100 >> 2;
- int b400 = b100 >> 2;
- int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400);
- int years = a->tm_year - b->tm_year;
- int days = (365 * years + intervening_leap_days
- + (a->tm_yday - b->tm_yday));
- return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour))
- + (a->tm_min - b->tm_min))
- + (a->tm_sec - b->tm_sec));
-}
-
-/* Yield A's UTC offset, or an unspecified value if unknown. */
-static long int
-tm_gmtoff (struct tm *a)
-{
-#if HAVE_TM_GMTOFF
- return a->tm_gmtoff;
-#else
- return 0;
-#endif
-}
-
-DEFUN ("current-time-zone", Fcurrent_time_zone, Scurrent_time_zone, 0, 2, 0,
- doc: /* Return the offset and name for the local time zone.
-This returns a list of the form (OFFSET NAME).
-OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
- A negative value means west of Greenwich.
-NAME is a string giving the name of the time zone.
-If SPECIFIED-TIME is given, the time zone offset is determined from it
-instead of using the current time. The argument should have the form
-\(HIGH LOW . IGNORED). Thus, you can use times obtained from
-`current-time' and from `file-attributes'. SPECIFIED-TIME can also be
-a single integer number of seconds since the epoch. The obsolete form
-(HIGH . LOW) is also still accepted.
-
-The optional ZONE is omitted or nil for Emacs local time, t for
-Universal Time, `wall' for system wall clock time, or a string as in
-the TZ environment variable. It can also be a list (as from
-`current-time-zone') or an integer (as from `decode-time') applied
-without consideration for daylight saving time.
-
-Some operating systems cannot provide all this information to Emacs;
-in this case, `current-time-zone' returns a list containing nil for
-the data it can't find. */)
- (Lisp_Object specified_time, Lisp_Object zone)
-{
- struct timespec value;
- struct tm local_tm, gmt_tm;
- Lisp_Object zone_offset, zone_name;
-
- zone_offset = Qnil;
- value = make_timespec (lisp_seconds_argument (specified_time), 0);
- zone_name = format_time_string ("%Z", sizeof "%Z" - 1, value,
- zone, &local_tm);
-
- /* gmtime_r expects a pointer to time_t, but tv_sec of struct
- timespec on some systems (MinGW) is a 64-bit field. */
- time_t tsec = value.tv_sec;
- if (HAVE_TM_GMTOFF || gmtime_r (&tsec, &gmt_tm))
- {
- long int offset = (HAVE_TM_GMTOFF
- ? tm_gmtoff (&local_tm)
- : tm_diff (&local_tm, &gmt_tm));
- zone_offset = make_number (offset);
- if (SCHARS (zone_name) == 0)
- {
- /* No local time zone name is available; use numeric zone instead. */
- long int hour = offset / 3600;
- int min_sec = offset % 3600;
- int amin_sec = min_sec < 0 ? - min_sec : min_sec;
- int min = amin_sec / 60;
- int sec = amin_sec % 60;
- int min_prec = min_sec ? 2 : 0;
- int sec_prec = sec ? 2 : 0;
- char buf[sizeof "+0000" + INT_STRLEN_BOUND (long int)];
- zone_name = make_formatted_string (buf, "%c%.2ld%.*d%.*d",
- (offset < 0 ? '-' : '+'),
- hour, min_prec, min, sec_prec, sec);
- }
- }
-
- return list2 (zone_offset, zone_name);
-}
-
-DEFUN ("set-time-zone-rule", Fset_time_zone_rule, Sset_time_zone_rule, 1, 1, 0,
- doc: /* Set the Emacs local time zone using TZ, a string specifying a time zone rule.
-If TZ is nil or `wall', use system wall clock time; this differs from
-the usual Emacs convention where nil means current local time. If TZ
-is t, use Universal Time. If TZ is a list (as from
-`current-time-zone') or an integer (as from `decode-time'), use the
-specified time zone without consideration for daylight saving time.
-
-Instead of calling this function, you typically want something else.
-To temporarily use a different time zone rule for just one invocation
-of `decode-time', `encode-time', or `format-time-string', pass the
-function a ZONE argument. To change local time consistently
-throughout Emacs, call (setenv "TZ" TZ): this changes both the
-environment of the Emacs process and the variable
-`process-environment', whereas `set-time-zone-rule' affects only the
-former. */)
- (Lisp_Object tz)
-{
- tzlookup (NILP (tz) ? Qwall : tz, true);
- return Qnil;
-}
-
-/* A buffer holding a string of the form "TZ=value", intended
- to be part of the environment. If TZ is supposed to be unset,
- the buffer string is "tZ=". */
- static char *tzvalbuf;
-
-/* Get the local time zone rule. */
-char *
-emacs_getenv_TZ (void)
-{
- return tzvalbuf[0] == 'T' ? tzvalbuf + tzeqlen : 0;
-}
-
-/* Set the local time zone rule to TZSTRING, which can be null to
- denote wall clock time. Do not record the setting in LOCAL_TZ.
-
- This function is not thread-safe, in theory because putenv is not,
- but mostly because of the static storage it updates. Other threads
- that invoke localtime etc. may be adversely affected while this
- function is executing. */
-
-int
-emacs_setenv_TZ (const char *tzstring)
-{
- static ptrdiff_t tzvalbufsize;
- ptrdiff_t tzstringlen = tzstring ? strlen (tzstring) : 0;
- char *tzval = tzvalbuf;
- bool new_tzvalbuf = tzvalbufsize <= tzeqlen + tzstringlen;
-
- if (new_tzvalbuf)
- {
- /* Do not attempt to free the old tzvalbuf, since another thread
- may be using it. In practice, the first allocation is large
- enough and memory does not leak. */
- tzval = xpalloc (NULL, &tzvalbufsize,
- tzeqlen + tzstringlen - tzvalbufsize + 1, -1, 1);
- tzvalbuf = tzval;
- tzval[1] = 'Z';
- tzval[2] = '=';
- }
-
- if (tzstring)
- {
- /* Modify TZVAL in place. Although this is dicey in a
- multithreaded environment, we know of no portable alternative.
- Calling putenv or setenv could crash some other thread. */
- tzval[0] = 'T';
- strcpy (tzval + tzeqlen, tzstring);
- }
- else
- {
- /* Turn 'TZ=whatever' into an empty environment variable 'tZ='.
- Although this is also dicey, calling unsetenv here can crash Emacs.
- See Bug#8705. */
- tzval[0] = 't';
- tzval[tzeqlen] = 0;
- }
-
-
-#ifndef WINDOWSNT
- /* Modifying *TZVAL merely requires calling tzset (which is the
- caller's responsibility). However, modifying TZVAL requires
- calling putenv; although this is not thread-safe, in practice this
- runs only on startup when there is only one thread. */
- bool need_putenv = new_tzvalbuf;
-#else
- /* MS-Windows 'putenv' copies the argument string into a block it
- allocates, so modifying *TZVAL will not change the environment.
- However, the other threads run by Emacs on MS-Windows never call
- 'xputenv' or 'putenv' or 'unsetenv', so the original cause for the
- dicey in-place modification technique doesn't exist there in the
- first place. */
- bool need_putenv = true;
-#endif
- if (need_putenv)
- xputenv (tzval);
-
- return 0;
-}
/* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
(if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
@@ -2520,7 +1316,7 @@ general_insert_function (void (*insert_func)
val = args[argnum];
if (CHARACTERP (val))
{
- int c = XFASTINT (val);
+ int c = XFIXNAT (val);
unsigned char str[MAX_MULTIBYTE_LENGTH];
int len;
@@ -2676,18 +1472,19 @@ called interactively, INHERIT is t. */)
CHECK_CHARACTER (character);
if (NILP (count))
XSETFASTINT (count, 1);
- CHECK_NUMBER (count);
- c = XFASTINT (character);
+ else
+ CHECK_FIXNUM (count);
+ c = XFIXNAT (character);
if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
len = CHAR_STRING (c, str);
else
str[0] = c, len = 1;
- if (XINT (count) <= 0)
+ if (XFIXNUM (count) <= 0)
return Qnil;
- if (BUF_BYTES_MAX / len < XINT (count))
+ if (BUF_BYTES_MAX / len < XFIXNUM (count))
buffer_overflow ();
- n = XINT (count) * len;
+ n = XFIXNUM (count) * len;
stringlen = min (n, sizeof string - sizeof string % len);
for (i = 0; i < stringlen; i++)
string[i] = str[i % len];
@@ -2720,12 +1517,12 @@ The optional third arg INHERIT, if non-nil, says to inherit text properties
from adjoining text, if those properties are sticky. */)
(Lisp_Object byte, Lisp_Object count, Lisp_Object inherit)
{
- CHECK_NUMBER (byte);
- if (XINT (byte) < 0 || XINT (byte) > 255)
- args_out_of_range_3 (byte, make_number (0), make_number (255));
- if (XINT (byte) >= 128
+ CHECK_FIXNUM (byte);
+ if (XFIXNUM (byte) < 0 || XFIXNUM (byte) > 255)
+ args_out_of_range_3 (byte, make_fixnum (0), make_fixnum (255));
+ if (XFIXNUM (byte) >= 128
&& ! NILP (BVAR (current_buffer, enable_multibyte_characters)))
- XSETFASTINT (byte, BYTE8_TO_CHAR (XINT (byte)));
+ XSETFASTINT (byte, BYTE8_TO_CHAR (XFIXNUM (byte)));
return Finsert_char (byte, count, inherit);
}
@@ -2808,10 +1605,10 @@ make_buffer_string_both (ptrdiff_t start, ptrdiff_t start_byte,
{
update_buffer_properties (start, end);
- tem = Fnext_property_change (make_number (start), Qnil, make_number (end));
- tem1 = Ftext_properties_at (make_number (start), Qnil);
+ tem = Fnext_property_change (make_fixnum (start), Qnil, make_fixnum (end));
+ tem1 = Ftext_properties_at (make_fixnum (start), Qnil);
- if (XINT (tem) != end || !NILP (tem1))
+ if (XFIXNUM (tem) != end || !NILP (tem1))
copy_intervals_to_string (result, current_buffer, start,
end - start);
}
@@ -2834,7 +1631,7 @@ update_buffer_properties (ptrdiff_t start, ptrdiff_t end)
if (!NILP (Vbuffer_access_fontified_property))
{
Lisp_Object tem
- = Ftext_property_any (make_number (start), make_number (end),
+ = Ftext_property_any (make_fixnum (start), make_fixnum (end),
Vbuffer_access_fontified_property,
Qnil, Qnil);
if (NILP (tem))
@@ -2842,7 +1639,7 @@ update_buffer_properties (ptrdiff_t start, ptrdiff_t end)
}
CALLN (Frun_hook_with_args, Qbuffer_access_fontify_functions,
- make_number (start), make_number (end));
+ make_fixnum (start), make_fixnum (end));
}
}
@@ -2860,8 +1657,8 @@ use `buffer-substring-no-properties' instead. */)
register ptrdiff_t b, e;
validate_region (&start, &end);
- b = XINT (start);
- e = XINT (end);
+ b = XFIXNUM (start);
+ e = XFIXNUM (end);
return make_buffer_string (b, e, 1);
}
@@ -2876,8 +1673,8 @@ they can be in either order. */)
register ptrdiff_t b, e;
validate_region (&start, &end);
- b = XINT (start);
- e = XINT (end);
+ b = XFIXNUM (start);
+ e = XFIXNUM (end);
return make_buffer_string (b, e, 0);
}
@@ -2922,15 +1719,15 @@ using `string-make-multibyte' or `string-make-unibyte', which see. */)
b = BUF_BEGV (bp);
else
{
- CHECK_NUMBER_COERCE_MARKER (start);
- b = XINT (start);
+ CHECK_FIXNUM_COERCE_MARKER (start);
+ b = XFIXNUM (start);
}
if (NILP (end))
e = BUF_ZV (bp);
else
{
- CHECK_NUMBER_COERCE_MARKER (end);
- e = XINT (end);
+ CHECK_FIXNUM_COERCE_MARKER (end);
+ e = XFIXNUM (end);
}
if (b > e)
@@ -2990,15 +1787,15 @@ determines whether case is significant or ignored. */)
begp1 = BUF_BEGV (bp1);
else
{
- CHECK_NUMBER_COERCE_MARKER (start1);
- begp1 = XINT (start1);
+ CHECK_FIXNUM_COERCE_MARKER (start1);
+ begp1 = XFIXNUM (start1);
}
if (NILP (end1))
endp1 = BUF_ZV (bp1);
else
{
- CHECK_NUMBER_COERCE_MARKER (end1);
- endp1 = XINT (end1);
+ CHECK_FIXNUM_COERCE_MARKER (end1);
+ endp1 = XFIXNUM (end1);
}
if (begp1 > endp1)
@@ -3028,15 +1825,15 @@ determines whether case is significant or ignored. */)
begp2 = BUF_BEGV (bp2);
else
{
- CHECK_NUMBER_COERCE_MARKER (start2);
- begp2 = XINT (start2);
+ CHECK_FIXNUM_COERCE_MARKER (start2);
+ begp2 = XFIXNUM (start2);
}
if (NILP (end2))
endp2 = BUF_ZV (bp2);
else
{
- CHECK_NUMBER_COERCE_MARKER (end2);
- endp2 = XINT (end2);
+ CHECK_FIXNUM_COERCE_MARKER (end2);
+ endp2 = XFIXNUM (end2);
}
if (begp2 > endp2)
@@ -3091,7 +1888,7 @@ determines whether case is significant or ignored. */)
}
if (c1 != c2)
- return make_number (c1 < c2 ? -1 - chars : chars + 1);
+ return make_fixnum (c1 < c2 ? -1 - chars : chars + 1);
chars++;
rarely_quit (chars);
@@ -3100,12 +1897,12 @@ determines whether case is significant or ignored. */)
/* The strings match as far as they go.
If one is shorter, that one is less. */
if (chars < endp1 - begp1)
- return make_number (chars + 1);
+ return make_fixnum (chars + 1);
else if (chars < endp2 - begp2)
- return make_number (- chars - 1);
+ return make_fixnum (- chars - 1);
/* Same length too => they are equal. */
- return make_number (0);
+ return make_fixnum (0);
}
@@ -3114,6 +1911,7 @@ determines whether case is significant or ignored. */)
#undef ELEMENT
#undef EQUAL
+#define USE_HEURISTIC
/* Counter used to rarely_quit in replace-buffer-contents. */
static unsigned short rbc_quitcounter;
@@ -3136,30 +1934,53 @@ static unsigned short rbc_quitcounter;
/* Bit vectors recording for each character whether it was deleted
or inserted. */ \
unsigned char *deletions; \
- unsigned char *insertions;
+ unsigned char *insertions; \
+ struct timespec time_limit; \
+ unsigned int early_abort_tests;
#define NOTE_DELETE(ctx, xoff) set_bit ((ctx)->deletions, (xoff))
#define NOTE_INSERT(ctx, yoff) set_bit ((ctx)->insertions, (yoff))
+#define EARLY_ABORT(ctx) compareseq_early_abort (ctx)
struct context;
static void set_bit (unsigned char *, OFFSET);
static bool bit_is_set (const unsigned char *, OFFSET);
static bool buffer_chars_equal (struct context *, OFFSET, OFFSET);
+static bool compareseq_early_abort (struct context *);
#include "minmax.h"
#include "diffseq.h"
DEFUN ("replace-buffer-contents", Freplace_buffer_contents,
- Sreplace_buffer_contents, 1, 1, "bSource buffer: ",
+ Sreplace_buffer_contents, 1, 3, "bSource buffer: ",
doc: /* Replace accessible portion of current buffer with that of SOURCE.
SOURCE can be a buffer or a string that names a buffer.
Interactively, prompt for SOURCE.
+
As far as possible the replacement is non-destructive, i.e. existing
buffer contents, markers, properties, and overlays in the current
buffer stay intact.
-Warning: this function can be slow if there's a large number of small
-differences between the two buffers. */)
- (Lisp_Object source)
+
+Because this function can be very slow if there is a large number of
+differences between the two buffers, there are two optional arguments
+mitigating this issue.
+
+The MAX-SECS argument, if given, defines a hard limit on the time used
+for comparing the buffers. If it takes longer than MAX-SECS, the
+function falls back to a plain `delete-region' and
+`insert-buffer-substring'. (Note that the checks are not performed
+too evenly over time, so in some cases it may run a bit longer than
+allowed).
+
+The optional argument MAX-COSTS defines the quality of the difference
+computation. If the actual costs exceed this limit, heuristics are
+used to provide a faster but suboptimal solution. The default value
+is 1000000.
+
+This function returns t if a non-destructive replacement could be
+performed. Otherwise, i.e., if MAX-SECS was exceeded, it returns
+nil. */)
+ (Lisp_Object source, Lisp_Object max_secs, Lisp_Object max_costs)
{
struct buffer *a = current_buffer;
Lisp_Object source_buffer = Fget_buffer (source);
@@ -3184,17 +2005,22 @@ differences between the two buffers. */)
empty. */
if (a_empty && b_empty)
- return Qnil;
+ return Qt;
if (a_empty)
- return Finsert_buffer_substring (source, Qnil, Qnil);
+ {
+ Finsert_buffer_substring (source, Qnil, Qnil);
+ return Qt;
+ }
if (b_empty)
{
del_range_both (BEGV, BEGV_BYTE, ZV, ZV_BYTE, true);
- return Qnil;
+ return Qt;
}
+ ptrdiff_t count = SPECPDL_INDEX ();
+
/* FIXME: It is not documented how to initialize the contents of the
context structure. This code cargo-cults from the existing
caller in src/analyze.c of GNU Diffutils, which appears to
@@ -3204,6 +2030,23 @@ differences between the two buffers. */)
ptrdiff_t *buffer;
USE_SAFE_ALLOCA;
SAFE_NALLOCA (buffer, 2, diags);
+
+ if (NILP (max_costs))
+ XSETFASTINT (max_costs, 1000000);
+ else
+ CHECK_FIXNUM (max_costs);
+
+ struct timespec time_limit = make_timespec (0, -1);
+ if (!NILP (max_secs))
+ {
+ struct timespec
+ tlim = timespec_add (current_timespec (),
+ lisp_time_argument (max_secs)),
+ tmax = make_timespec (TYPE_MAXIMUM (time_t), TIMESPEC_HZ - 1);
+ if (timespec_cmp (tlim, tmax) < 0)
+ time_limit = tlim;
+ }
+
/* Micro-optimization: Casting to size_t generates much better
code. */
ptrdiff_t del_bytes = (size_t) size_a / CHAR_BIT + 1;
@@ -3219,24 +2062,31 @@ differences between the two buffers. */)
.insertions = SAFE_ALLOCA (ins_bytes),
.fdiag = buffer + size_b + 1,
.bdiag = buffer + diags + size_b + 1,
- /* FIXME: Find a good number for .too_expensive. */
- .too_expensive = 1000000,
+ .heuristic = true,
+ .too_expensive = XFIXNUM (max_costs),
+ .time_limit = time_limit,
+ .early_abort_tests = 0
};
memclear (ctx.deletions, del_bytes);
memclear (ctx.insertions, ins_bytes);
+
/* compareseq requires indices to be zero-based. We add BEGV back
later. */
bool early_abort = compareseq (0, size_a, 0, size_b, false, &ctx);
- /* Since we didn’t define EARLY_ABORT, we should never abort
- early. */
- eassert (! early_abort);
+
+ if (early_abort)
+ {
+ del_range (min_a, ZV);
+ Finsert_buffer_substring (source, Qnil,Qnil);
+ SAFE_FREE_UNBIND_TO (count, Qnil);
+ return Qnil;
+ }
rbc_quitcounter = 0;
Fundo_boundary ();
bool modification_hooks_inhibited = false;
- ptrdiff_t count = SPECPDL_INDEX ();
- record_unwind_protect (save_excursion_restore, save_excursion_save ());
+ record_unwind_protect_excursion ();
/* We are going to make a lot of small modifications, and having the
modification hooks called for each of them will slow us down.
@@ -3285,15 +2135,15 @@ differences between the two buffers. */)
if (beg_b < end_b)
{
SET_PT (beg_a);
- Finsert_buffer_substring (source, make_natnum (beg_b),
- make_natnum (end_b));
+ Finsert_buffer_substring (source, make_fixed_natnum (beg_b),
+ make_fixed_natnum (end_b));
}
}
--i;
--j;
}
- unbind_to (count, Qnil);
- SAFE_FREE ();
+
+ SAFE_FREE_UNBIND_TO (count, Qnil);
rbc_quitcounter = 0;
if (modification_hooks_inhibited)
@@ -3302,7 +2152,7 @@ differences between the two buffers. */)
update_compositions (BEGV, ZV, CHECK_INSIDE);
}
- return Qnil;
+ return Qt;
}
static void
@@ -3369,6 +2219,14 @@ buffer_chars_equal (struct context *ctx,
== BUF_FETCH_MULTIBYTE_CHAR (ctx->buffer_b, bpos_b);
}
+static bool
+compareseq_early_abort (struct context *ctx)
+{
+ if (ctx->time_limit.tv_nsec < 0)
+ return false;
+ return timespec_cmp (ctx->time_limit, current_timespec ()) < 0;
+}
+
static void
subst_char_in_region_unwind (Lisp_Object arg)
@@ -3414,8 +2272,8 @@ Both characters must have the same length of multi-byte form. */)
validate_region (&start, &end);
CHECK_CHARACTER (fromchar);
CHECK_CHARACTER (tochar);
- fromc = XFASTINT (fromchar);
- toc = XFASTINT (tochar);
+ fromc = XFIXNAT (fromchar);
+ toc = XFIXNAT (tochar);
if (multibyte_p)
{
@@ -3441,9 +2299,9 @@ Both characters must have the same length of multi-byte form. */)
tostr[0] = toc;
}
- pos = XINT (start);
+ pos = XFIXNUM (start);
pos_byte = CHAR_TO_BYTE (pos);
- stop = CHAR_TO_BYTE (XINT (end));
+ stop = CHAR_TO_BYTE (XFIXNUM (end));
end_byte = stop;
/* If we don't want undo, turn off putting stuff on the list.
@@ -3491,14 +2349,15 @@ Both characters must have the same length of multi-byte form. */)
else if (!changed)
{
changed = -1;
- modify_text (pos, XINT (end));
+ modify_text (pos, XFIXNUM (end));
if (! NILP (noundo))
{
- if (MODIFF - 1 == SAVE_MODIFF)
- SAVE_MODIFF++;
- if (MODIFF - 1 == BUF_AUTOSAVE_MODIFF (current_buffer))
- BUF_AUTOSAVE_MODIFF (current_buffer)++;
+ modiff_count m = MODIFF;
+ if (SAVE_MODIFF == m - 1)
+ SAVE_MODIFF = m;
+ if (BUF_AUTOSAVE_MODIFF (current_buffer) == m - 1)
+ BUF_AUTOSAVE_MODIFF (current_buffer) = m;
}
/* The before-change-function may have moved the gap
@@ -3526,7 +2385,7 @@ Both characters must have the same length of multi-byte form. */)
/* replace_range is less efficient, because it moves the gap,
but it handles combining correctly. */
replace_range (pos, pos + 1, string,
- 0, 0, 1, 0);
+ false, false, true, false);
pos_byte_next = CHAR_TO_BYTE (pos);
if (pos_byte_next > pos_byte)
/* Before combining happened. We should not increment
@@ -3558,8 +2417,7 @@ Both characters must have the same length of multi-byte form. */)
update_compositions (changed, last_changed, CHECK_ALL);
}
- unbind_to (count, Qnil);
- return Qnil;
+ return unbind_to (count, Qnil);
}
@@ -3615,7 +2473,7 @@ check_translation (ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t end,
buf[buf_used++] = STRING_CHAR_AND_LENGTH (p, len1);
pos_byte += len1;
}
- if (XINT (AREF (elt, i)) != buf[i])
+ if (XFIXNUM (AREF (elt, i)) != buf[i])
break;
}
if (i == len)
@@ -3638,60 +2496,53 @@ From START to END, translate characters according to TABLE.
TABLE is a string or a char-table; the Nth character in it is the
mapping for the character with code N.
It returns the number of characters changed. */)
- (Lisp_Object start, Lisp_Object end, register Lisp_Object table)
+ (Lisp_Object start, Lisp_Object end, Lisp_Object table)
{
- register unsigned char *tt; /* Trans table. */
- register int nc; /* New character. */
- int cnt; /* Number of changes made. */
- ptrdiff_t size; /* Size of translate table. */
- ptrdiff_t pos, pos_byte, end_pos;
+ int translatable_chars = MAX_CHAR + 1;
bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
bool string_multibyte UNINIT;
validate_region (&start, &end);
- if (CHAR_TABLE_P (table))
+ if (STRINGP (table))
{
- if (! EQ (XCHAR_TABLE (table)->purpose, Qtranslation_table))
- error ("Not a translation table");
- size = MAX_CHAR;
- tt = NULL;
- }
- else
- {
- CHECK_STRING (table);
-
- if (! multibyte && (SCHARS (table) < SBYTES (table)))
+ if (! multibyte)
table = string_make_unibyte (table);
- string_multibyte = SCHARS (table) < SBYTES (table);
- size = SBYTES (table);
- tt = SDATA (table);
+ translatable_chars = min (translatable_chars, SBYTES (table));
+ string_multibyte = STRING_MULTIBYTE (table);
}
+ else if (! (CHAR_TABLE_P (table)
+ && EQ (XCHAR_TABLE (table)->purpose, Qtranslation_table)))
+ error ("Not a translation table");
- pos = XINT (start);
- pos_byte = CHAR_TO_BYTE (pos);
- end_pos = XINT (end);
+ ptrdiff_t pos = XFIXNUM (start);
+ ptrdiff_t pos_byte = CHAR_TO_BYTE (pos);
+ ptrdiff_t end_pos = XFIXNUM (end);
modify_text (pos, end_pos);
- cnt = 0;
- for (; pos < end_pos; )
+ ptrdiff_t characters_changed = 0;
+
+ while (pos < end_pos)
{
unsigned char *p = BYTE_POS_ADDR (pos_byte);
unsigned char *str UNINIT;
unsigned char buf[MAX_MULTIBYTE_LENGTH];
- int len, str_len;
- int oc;
- Lisp_Object val;
+ int len, oc;
if (multibyte)
oc = STRING_CHAR_AND_LENGTH (p, len);
else
oc = *p, len = 1;
- if (oc < size)
+ if (oc < translatable_chars)
{
- if (tt)
+ int nc; /* New character. */
+ int str_len;
+ Lisp_Object val;
+
+ if (STRINGP (table))
{
/* Reload as signal_after_change in last iteration may GC. */
- tt = SDATA (table);
+ unsigned char *tt = SDATA (table);
+
if (string_multibyte)
{
str = tt + string_char_to_byte (table, oc);
@@ -3718,7 +2569,7 @@ It returns the number of characters changed. */)
val = CHAR_TABLE_REF (table, oc);
if (CHARACTERP (val))
{
- nc = XFASTINT (val);
+ nc = XFIXNAT (val);
str_len = CHAR_STRING (nc, buf);
str = buf;
}
@@ -3740,7 +2591,8 @@ It returns the number of characters changed. */)
/* This is less efficient, because it moves the gap,
but it should handle multibyte characters correctly. */
string = make_multibyte_string ((char *) str, 1, str_len);
- replace_range (pos, pos + 1, string, 1, 0, 1, 0);
+ replace_range (pos, pos + 1, string,
+ true, false, true, false);
len = str_len;
}
else
@@ -3751,12 +2603,10 @@ It returns the number of characters changed. */)
signal_after_change (pos, 1, 1);
update_compositions (pos, pos + 1, CHECK_BORDER);
}
- ++cnt;
+ characters_changed++;
}
else if (nc < 0)
{
- Lisp_Object string;
-
if (CONSP (val))
{
val = check_translation (pos, pos_byte, end_pos, val);
@@ -3773,18 +2623,14 @@ It returns the number of characters changed. */)
else
len = 1;
- if (VECTORP (val))
- {
- string = Fconcat (1, &val);
- }
- else
- {
- string = Fmake_string (make_number (1), val);
- }
- replace_range (pos, pos + len, string, 1, 0, 1, 0);
+ Lisp_Object string
+ = (VECTORP (val)
+ ? Fconcat (1, &val)
+ : Fmake_string (make_fixnum (1), val, Qnil));
+ replace_range (pos, pos + len, string, true, false, true, false);
pos_byte += SBYTES (string);
pos += SCHARS (string);
- cnt += SCHARS (string);
+ characters_changed += SCHARS (string);
end_pos += SCHARS (string) - len;
continue;
}
@@ -3793,7 +2639,7 @@ It returns the number of characters changed. */)
pos++;
}
- return make_number (cnt);
+ return make_fixnum (characters_changed);
}
DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r",
@@ -3803,7 +2649,7 @@ This command deletes buffer text without modifying the kill ring. */)
(Lisp_Object start, Lisp_Object end)
{
validate_region (&start, &end);
- del_range (XINT (start), XINT (end));
+ del_range (XFIXNUM (start), XFIXNUM (end));
return Qnil;
}
@@ -3813,9 +2659,9 @@ DEFUN ("delete-and-extract-region", Fdelete_and_extract_region,
(Lisp_Object start, Lisp_Object end)
{
validate_region (&start, &end);
- if (XINT (start) == XINT (end))
+ if (XFIXNUM (start) == XFIXNUM (end))
return empty_unibyte_string;
- return del_range_1 (XINT (start), XINT (end), 1, 1);
+ return del_range_1 (XFIXNUM (start), XFIXNUM (end), 1, 1);
}
DEFUN ("widen", Fwiden, Swiden, 0, 0, "",
@@ -3845,27 +2691,27 @@ positions (integers or markers) bounding the text that should
remain visible. */)
(register Lisp_Object start, Lisp_Object end)
{
- CHECK_NUMBER_COERCE_MARKER (start);
- CHECK_NUMBER_COERCE_MARKER (end);
+ CHECK_FIXNUM_COERCE_MARKER (start);
+ CHECK_FIXNUM_COERCE_MARKER (end);
- if (XINT (start) > XINT (end))
+ if (XFIXNUM (start) > XFIXNUM (end))
{
Lisp_Object tem;
tem = start; start = end; end = tem;
}
- if (!(BEG <= XINT (start) && XINT (start) <= XINT (end) && XINT (end) <= Z))
+ if (!(BEG <= XFIXNUM (start) && XFIXNUM (start) <= XFIXNUM (end) && XFIXNUM (end) <= Z))
args_out_of_range (start, end);
- if (BEGV != XFASTINT (start) || ZV != XFASTINT (end))
+ if (BEGV != XFIXNAT (start) || ZV != XFIXNAT (end))
current_buffer->clip_changed = 1;
- SET_BUF_BEGV (current_buffer, XFASTINT (start));
- SET_BUF_ZV (current_buffer, XFASTINT (end));
- if (PT < XFASTINT (start))
- SET_PT (XFASTINT (start));
- if (PT > XFASTINT (end))
- SET_PT (XFASTINT (end));
+ SET_BUF_BEGV (current_buffer, XFIXNAT (start));
+ SET_BUF_ZV (current_buffer, XFIXNAT (end));
+ if (PT < XFIXNAT (start))
+ SET_PT (XFIXNAT (start));
+ if (PT > XFIXNAT (end))
+ SET_PT (XFIXNAT (end));
/* Changing the buffer bounds invalidates any recorded current column. */
invalidate_current_column ();
return Qnil;
@@ -3991,6 +2837,25 @@ usage: (save-restriction &rest BODY) */)
return unbind_to (count, val);
}
+/* i18n (internationalization). */
+
+DEFUN ("ngettext", Fngettext, Sngettext, 3, 3, 0,
+ doc: /* Return the translation of MSGID (plural MSGID_PLURAL) depending on N.
+MSGID is the singular form of the string to be converted;
+use it as the key for the search in the translation catalog.
+MSGID_PLURAL is the plural form. Use N to select the proper translation.
+If no message catalog is found, MSGID is returned if N is equal to 1,
+otherwise MSGID_PLURAL. */)
+ (Lisp_Object msgid, Lisp_Object msgid_plural, Lisp_Object n)
+{
+ CHECK_STRING (msgid);
+ CHECK_STRING (msgid_plural);
+ CHECK_INTEGER (n);
+
+ /* Placeholder implementation until we get our act together. */
+ return EQ (n, make_fixnum (1)) ? msgid : msgid_plural;
+}
+
DEFUN ("message", Fmessage, Smessage, 1, MANY, 0,
doc: /* Display a message at the bottom of the screen.
The message also goes into the `*Messages*' buffer, if `message-log-max'
@@ -4111,8 +2976,8 @@ usage: (propertize STRING &rest PROPERTIES) */)
for (i = 1; i < nargs; i += 2)
properties = Fcons (args[i], Fcons (args[i + 1], properties));
- Fadd_text_properties (make_number (0),
- make_number (SCHARS (string)),
+ Fadd_text_properties (make_fixnum (0),
+ make_fixnum (SCHARS (string)),
properties, string);
return string;
}
@@ -4144,8 +3009,8 @@ the next available argument, or the argument explicitly specified:
%s means print a string argument. Actually, prints any object, with `princ'.
%d means print as signed number in decimal.
-%o means print as unsigned number in octal.
-%x means print as unsigned number in hex.
+%o means print a number in octal.
+%x means print a number in hex.
%X is like %x, but uses upper case.
%e means print a number in exponential notation.
%f means print a number in decimal-point notation.
@@ -4156,6 +3021,8 @@ the next available argument, or the argument explicitly specified:
%S means print any object as an s-expression (using `prin1').
The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
+%o, %x, and %X treat arguments as unsigned if `binary-as-unsigned' is t
+ (this is experimental; email 32252@debbugs.gnu.org if you need it).
Use %% to put a single % into the output.
A %-sequence other than %% may contain optional field number, flag,
@@ -4172,14 +3039,14 @@ Nth argument is substituted instead of the next one. A format can
contain either numbered or unnumbered %-sequences but not both, except
that %% can be mixed with numbered %-sequences.
-The + flag character inserts a + before any positive number, while a
-space inserts a space before any positive number; these flags only
-affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
+The + flag character inserts a + before any nonnegative number, while a
+space inserts a space before any nonnegative number; these flags
+affect only numeric %-sequences, and the + flag takes precedence.
The - and 0 flags affect the width specifier, as described below.
The # flag means to use an alternate display form for %o, %x, %X, %e,
%f, and %g sequences: for %o, it ensures that the result begins with
-\"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
+\"0\"; for %x and %X, it prefixes nonzero results with \"0x\" or \"0X\";
for %e and %f, it causes a decimal point to be included even if the
precision is zero; for %g, it causes a decimal point to be
included even if the precision is zero, and also forces trailing
@@ -4229,8 +3096,26 @@ usage: (format-message STRING &rest OBJECTS) */)
static Lisp_Object
styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
{
+ enum
+ {
+ /* Maximum precision for a %f conversion such that the trailing
+ output digit might be nonzero. Any precision larger than this
+ will not yield useful information. */
+ USEFUL_PRECISION_MAX = ((1 - LDBL_MIN_EXP)
+ * (FLT_RADIX == 2 || FLT_RADIX == 10 ? 1
+ : FLT_RADIX == 16 ? 4
+ : -1)),
+
+ /* Maximum number of bytes (including terminating NUL) generated
+ by any format, if precision is no more than USEFUL_PRECISION_MAX.
+ On all practical hosts, %Lf is the worst case. */
+ SPRINTF_BUFSIZE = (sizeof "-." + (LDBL_MAX_10_EXP + 1)
+ + USEFUL_PRECISION_MAX)
+ };
+ verify (USEFUL_PRECISION_MAX > 0);
+
ptrdiff_t n; /* The number of the next arg to substitute. */
- char initial_buffer[4000];
+ char initial_buffer[1000 + SPRINTF_BUFSIZE];
char *buf = initial_buffer;
ptrdiff_t bufsize = sizeof initial_buffer;
ptrdiff_t max_bufsize = STRING_BYTES_BOUND + 1;
@@ -4274,9 +3159,9 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
ptrdiff_t nspec_bound = SCHARS (args[0]) >> 1;
/* Allocate the info and discarded tables. */
- ptrdiff_t alloca_size;
- if (INT_MULTIPLY_WRAPV (nspec_bound, sizeof *info, &alloca_size)
- || INT_ADD_WRAPV (formatlen, alloca_size, &alloca_size)
+ ptrdiff_t info_size, alloca_size;
+ if (INT_MULTIPLY_WRAPV (nspec_bound, sizeof *info, &info_size)
+ || INT_ADD_WRAPV (formatlen, info_size, &alloca_size)
|| SIZE_MAX < alloca_size)
memory_full (SIZE_MAX);
info = SAFE_ALLOCA (alloca_size);
@@ -4284,6 +3169,8 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
string was not copied into the output.
It is 2 if byte I was not the first byte of its character. */
char *discarded = (char *) &info[nspec_bound];
+ info = ptr_bounds_clip (info, info_size);
+ discarded = ptr_bounds_clip (discarded, formatlen);
memset (discarded, 0, formatlen);
/* Try to determine whether the result should be multibyte.
@@ -4333,8 +3220,14 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
char const *convsrc = format;
unsigned char format_char = *format++;
- /* Bytes needed to represent the output of this conversion. */
+ /* Number of bytes to be preallocated for the next directive's
+ output. At the end of each iteration this is at least
+ CONVBYTES_ROOM, and is greater if the current directive
+ output was so large that it will be retried after buffer
+ reallocation. */
ptrdiff_t convbytes = 1;
+ enum { CONVBYTES_ROOM = SPRINTF_BUFSIZE - 1 };
+ eassert (p <= buf + bufsize - SPRINTF_BUFSIZE);
if (format_char == '%')
{
@@ -4454,7 +3347,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
}
else if (conversion == 'c')
{
- if (INTEGERP (arg) && ! ASCII_CHAR_P (XINT (arg)))
+ if (FIXNUMP (arg) && ! ASCII_CHAR_P (XFIXNUM (arg)))
{
if (!multibyte)
{
@@ -4570,7 +3463,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
spec->intervals = arg_intervals = true;
new_result = true;
- continue;
+ convbytes = CONVBYTES_ROOM;
}
}
else if (! (conversion == 'c' || conversion == 'd'
@@ -4579,43 +3472,13 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
|| conversion == 'X'))
error ("Invalid format operation %%%c",
STRING_CHAR ((unsigned char *) format - 1));
- else if (! (INTEGERP (arg) || (FLOATP (arg) && conversion != 'c')))
+ else if (! (FIXNUMP (arg) || ((BIGNUMP (arg) || FLOATP (arg))
+ && conversion != 'c')))
error ("Format specifier doesn't match argument type");
else
{
- enum
- {
- /* Lower bound on the number of bits per
- base-FLT_RADIX digit. */
- DIG_BITS_LBOUND = FLT_RADIX < 16 ? 1 : 4,
-
- /* 1 if integers should be formatted as long doubles,
- because they may be so large that there is a rounding
- error when converting them to double, and long doubles
- are wider than doubles. */
- INT_AS_LDBL = (DIG_BITS_LBOUND * DBL_MANT_DIG < FIXNUM_BITS - 1
- && DBL_MANT_DIG < LDBL_MANT_DIG),
-
- /* Maximum precision for a %f conversion such that the
- trailing output digit might be nonzero. Any precision
- larger than this will not yield useful information. */
- USEFUL_PRECISION_MAX =
- ((1 - LDBL_MIN_EXP)
- * (FLT_RADIX == 2 || FLT_RADIX == 10 ? 1
- : FLT_RADIX == 16 ? 4
- : -1)),
-
- /* Maximum number of bytes generated by any format, if
- precision is no more than USEFUL_PRECISION_MAX.
- On all practical hosts, %f is the worst case. */
- SPRINTF_BUFSIZE =
- sizeof "-." + (LDBL_MAX_10_EXP + 1) + USEFUL_PRECISION_MAX,
-
- /* Length of pM (that is, of pMd without the
- trailing "d"). */
- pMlen = sizeof pMd - 2
- };
- verify (USEFUL_PRECISION_MAX > 0);
+ /* Length of pM (that is, of pMd without the trailing "d"). */
+ enum { pMlen = sizeof pMd - 2 };
/* Avoid undefined behavior in underlying sprintf. */
if (conversion == 'd' || conversion == 'i')
@@ -4626,219 +3489,308 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
with "L" possibly inserted for floating-point formats,
and with pM inserted for integer formats.
At most two flags F can be specified at once. */
- char convspec[sizeof "%FF.*d" + max (INT_AS_LDBL, pMlen)];
- {
- char *f = convspec;
- *f++ = '%';
- /* MINUS_FLAG and ZERO_FLAG are dealt with later. */
- *f = '+'; f += plus_flag;
- *f = ' '; f += space_flag;
- *f = '#'; f += sharp_flag;
- *f++ = '.';
- *f++ = '*';
- if (float_conversion)
- {
- if (INT_AS_LDBL)
- {
- *f = 'L';
- f += INTEGERP (arg);
- }
- }
- else if (conversion != 'c')
- {
- memcpy (f, pMd, pMlen);
- f += pMlen;
- zero_flag &= ! precision_given;
- }
- *f++ = conversion;
- *f = '\0';
- }
+ char convspec[sizeof "%FF.*d" + max (sizeof "L" - 1, pMlen)];
+ char *f = convspec;
+ *f++ = '%';
+ /* MINUS_FLAG and ZERO_FLAG are dealt with later. */
+ *f = '+'; f += plus_flag;
+ *f = ' '; f += space_flag;
+ *f = '#'; f += sharp_flag;
+ *f++ = '.';
+ *f++ = '*';
+ if (! (float_conversion || conversion == 'c'))
+ {
+ memcpy (f, pMd, pMlen);
+ f += pMlen;
+ zero_flag &= ! precision_given;
+ }
+ *f++ = conversion;
+ *f = '\0';
int prec = -1;
if (precision_given)
prec = min (precision, USEFUL_PRECISION_MAX);
- /* Use sprintf to format this number into sprintf_buf. Omit
+ /* Characters to be inserted after spaces and before
+ leading zeros. This can occur with bignums, since
+ bignum_to_string does only leading '-'. */
+ char prefix[sizeof "-0x" - 1];
+ int prefixlen = 0;
+
+ /* Use sprintf or bignum_to_string to format this number. Omit
padding and excess precision, though, because sprintf limits
- output length to INT_MAX.
+ output length to INT_MAX and bignum_to_string doesn't
+ do padding or precision.
- There are four types of conversion: double, unsigned
+ Use five sprintf conversions: double, long double, unsigned
char (passed as int), wide signed int, and wide
unsigned int. Treat them separately because the
sprintf ABI is sensitive to which type is passed. Be
careful about integer overflow, NaNs, infinities, and
conversions; for example, the min and max macros are
not suitable here. */
- char sprintf_buf[SPRINTF_BUFSIZE];
ptrdiff_t sprintf_bytes;
if (float_conversion)
{
- if (INT_AS_LDBL && INTEGERP (arg))
+ /* Format as a long double if the arg is an integer
+ that would lose less information than when formatting
+ it as a double. Otherwise, format as a double;
+ this is likely to be faster and better-tested. */
+
+ bool format_as_long_double = false;
+ double darg;
+ long double ldarg UNINIT;
+
+ if (FLOATP (arg))
+ darg = XFLOAT_DATA (arg);
+ else
{
- /* Although long double may have a rounding error if
- DIG_BITS_LBOUND * LDBL_MANT_DIG < FIXNUM_BITS - 1,
- it is more accurate than plain 'double'. */
- long double x = XINT (arg);
- sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x);
+ bool format_bignum_as_double = false;
+ if (LDBL_MANT_DIG <= DBL_MANT_DIG)
+ {
+ if (FIXNUMP (arg))
+ darg = XFIXNUM (arg);
+ else
+ format_bignum_as_double = true;
+ }
+ else
+ {
+ if (INTEGERP (arg))
+ {
+ intmax_t iarg;
+ uintmax_t uarg;
+ if (integer_to_intmax (arg, &iarg))
+ ldarg = iarg;
+ else if (integer_to_uintmax (arg, &uarg))
+ ldarg = uarg;
+ else
+ format_bignum_as_double = true;
+ }
+ if (!format_bignum_as_double)
+ {
+ darg = ldarg;
+ format_as_long_double = darg != ldarg;
+ }
+ }
+ if (format_bignum_as_double)
+ darg = bignum_to_double (arg);
+ }
+
+ if (format_as_long_double)
+ {
+ f[-1] = 'L';
+ *f++ = conversion;
+ *f = '\0';
+ sprintf_bytes = sprintf (p, convspec, prec, ldarg);
}
else
- sprintf_bytes = sprintf (sprintf_buf, convspec, prec,
- XFLOATINT (arg));
+ sprintf_bytes = sprintf (p, convspec, prec, darg);
}
else if (conversion == 'c')
{
/* Don't use sprintf here, as it might mishandle prec. */
- sprintf_buf[0] = XINT (arg);
+ p[0] = XFIXNUM (arg);
+ p[1] = '\0';
sprintf_bytes = prec != 0;
}
+ else if (BIGNUMP (arg))
+ {
+ int base = ((conversion == 'd' || conversion == 'i') ? 10
+ : conversion == 'o' ? 8 : 16);
+ sprintf_bytes = bignum_bufsize (arg, base);
+ if (sprintf_bytes <= buf + bufsize - p)
+ {
+ int signedbase = conversion == 'X' ? -base : base;
+ sprintf_bytes = bignum_to_c_string (p, sprintf_bytes,
+ arg, signedbase);
+ bool negative = p[0] == '-';
+ prec = min (precision, sprintf_bytes - prefixlen);
+ prefix[prefixlen] = plus_flag ? '+' : ' ';
+ prefixlen += (plus_flag | space_flag) & !negative;
+ prefix[prefixlen] = '0';
+ prefix[prefixlen + 1] = conversion;
+ prefixlen += sharp_flag && base == 16 ? 2 : 0;
+ }
+ }
else if (conversion == 'd' || conversion == 'i')
{
- /* For float, maybe we should use "%1.0f"
- instead so it also works for values outside
- the integer range. */
- printmax_t x;
- if (INTEGERP (arg))
- x = XINT (arg);
+ if (FIXNUMP (arg))
+ {
+ printmax_t x = XFIXNUM (arg);
+ sprintf_bytes = sprintf (p, convspec, prec, x);
+ }
else
{
- double d = XFLOAT_DATA (arg);
- if (d < 0)
- {
- x = TYPE_MINIMUM (printmax_t);
- if (x < d)
- x = d;
- }
- else
- {
- x = TYPE_MAXIMUM (printmax_t);
- if (d < x)
- x = d;
- }
+ strcpy (f - pMlen - 1, "f");
+ double x = XFLOAT_DATA (arg);
+
+ /* Truncate and then convert -0 to 0, to be more
+ consistent with %x etc.; see Bug#31938. */
+ x = trunc (x);
+ x = x ? x : 0;
+
+ sprintf_bytes = sprintf (p, convspec, 0, x);
+ bool signedp = ! c_isdigit (p[0]);
+ prec = min (precision, sprintf_bytes - signedp);
}
- sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x);
}
else
{
- /* Don't sign-extend for octal or hex printing. */
uprintmax_t x;
- if (INTEGERP (arg))
- x = XUINT (arg);
- else
+ bool negative;
+ if (FIXNUMP (arg))
{
- double d = XFLOAT_DATA (arg);
- if (d < 0)
- x = 0;
+ if (binary_as_unsigned)
+ {
+ x = XUFIXNUM (arg);
+ negative = false;
+ }
else
{
- x = TYPE_MAXIMUM (uprintmax_t);
- if (d < x)
- x = d;
+ EMACS_INT i = XFIXNUM (arg);
+ negative = i < 0;
+ x = negative ? -i : i;
}
}
- sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x);
+ else
+ {
+ double d = XFLOAT_DATA (arg);
+ double uprintmax = TYPE_MAXIMUM (uprintmax_t);
+ if (! (0 <= d && d < uprintmax + 1))
+ xsignal1 (Qoverflow_error, arg);
+ x = d;
+ negative = false;
+ }
+ p[0] = negative ? '-' : plus_flag ? '+' : ' ';
+ bool signedp = negative | plus_flag | space_flag;
+ sprintf_bytes = sprintf (p + signedp, convspec, prec, x);
+ sprintf_bytes += signedp;
}
/* Now the length of the formatted item is known, except it omits
padding and excess precision. Deal with excess precision
- first. This happens only when the format specifies
- ridiculously large precision. */
+ first. This happens when the format specifies ridiculously
+ large precision, or when %d or %i formats a float that would
+ ordinarily need fewer digits than a specified precision,
+ or when a bignum is formatted using an integer format
+ with enough precision. */
ptrdiff_t excess_precision
= precision_given ? precision - prec : 0;
- ptrdiff_t leading_zeros = 0, trailing_zeros = 0;
- if (excess_precision)
+ ptrdiff_t trailing_zeros = 0;
+ if (excess_precision != 0 && float_conversion)
{
- if (float_conversion)
- {
- if ((conversion == 'g' && ! sharp_flag)
- || ! ('0' <= sprintf_buf[sprintf_bytes - 1]
- && sprintf_buf[sprintf_bytes - 1] <= '9'))
- excess_precision = 0;
- else
- {
- if (conversion == 'g')
- {
- char *dot = strchr (sprintf_buf, '.');
- if (!dot)
- excess_precision = 0;
- }
- }
- trailing_zeros = excess_precision;
- }
- else
- leading_zeros = excess_precision;
+ if (! c_isdigit (p[sprintf_bytes - 1])
+ || (conversion == 'g'
+ && ! (sharp_flag && strchr (p, '.'))))
+ excess_precision = 0;
+ trailing_zeros = excess_precision;
}
+ ptrdiff_t leading_zeros = excess_precision - trailing_zeros;
/* Compute the total bytes needed for this item, including
excess precision and padding. */
ptrdiff_t numwidth;
- if (INT_ADD_WRAPV (sprintf_bytes, excess_precision, &numwidth))
+ if (INT_ADD_WRAPV (prefixlen + sprintf_bytes, excess_precision,
+ &numwidth))
numwidth = PTRDIFF_MAX;
ptrdiff_t padding
= numwidth < field_width ? field_width - numwidth : 0;
- if (max_bufsize - sprintf_bytes <= excess_precision
+ if (max_bufsize - (prefixlen + sprintf_bytes) <= excess_precision
|| max_bufsize - padding <= numwidth)
string_overflow ();
convbytes = numwidth + padding;
if (convbytes <= buf + bufsize - p)
{
- /* Copy the formatted item from sprintf_buf into buf,
- inserting padding and excess-precision zeros. */
-
- char *src = sprintf_buf;
- char src0 = src[0];
- int exponent_bytes = 0;
- bool signedp = src0 == '-' || src0 == '+' || src0 == ' ';
- unsigned char after_sign = src[signedp];
- if (zero_flag && 0 <= char_hexdigit (after_sign))
+ bool signedp = p[0] == '-' || p[0] == '+' || p[0] == ' ';
+ int beglen = (signedp
+ + ((p[signedp] == '0'
+ && (p[signedp + 1] == 'x'
+ || p[signedp + 1] == 'X'))
+ ? 2 : 0));
+ eassert (prefixlen == 0 || beglen == 0
+ || (beglen == 1 && p[0] == '-'
+ && ! (prefix[0] == '-' || prefix[0] == '+'
+ || prefix[0] == ' ')));
+ if (zero_flag && 0 <= char_hexdigit (p[beglen]))
{
leading_zeros += padding;
padding = 0;
}
+ if (leading_zeros == 0 && sharp_flag && conversion == 'o'
+ && p[beglen] != '0')
+ {
+ leading_zeros++;
+ padding -= padding != 0;
+ }
- if (excess_precision
+ int endlen = 0;
+ if (trailing_zeros
&& (conversion == 'e' || conversion == 'g'))
{
- char *e = strchr (src, 'e');
+ char *e = strchr (p, 'e');
if (e)
- exponent_bytes = src + sprintf_bytes - e;
+ endlen = p + sprintf_bytes - e;
}
- spec->start = nchars;
- if (! minus_flag)
- {
- memset (p, ' ', padding);
- p += padding;
- nchars += padding;
- }
+ ptrdiff_t midlen = sprintf_bytes - beglen - endlen;
+ ptrdiff_t leading_padding = minus_flag ? 0 : padding;
+ ptrdiff_t trailing_padding = padding - leading_padding;
- *p = src0;
- src += signedp;
- p += signedp;
- memset (p, '0', leading_zeros);
- p += leading_zeros;
- int significand_bytes
- = sprintf_bytes - signedp - exponent_bytes;
- memcpy (p, src, significand_bytes);
- p += significand_bytes;
- src += significand_bytes;
- memset (p, '0', trailing_zeros);
- p += trailing_zeros;
- memcpy (p, src, exponent_bytes);
- p += exponent_bytes;
-
- nchars += leading_zeros + sprintf_bytes + trailing_zeros;
+ /* Insert padding and excess-precision zeros. The output
+ contains the following components, in left-to-right order:
- if (minus_flag)
+ LEADING_PADDING spaces.
+ BEGLEN bytes taken from the start of sprintf output.
+ PREFIXLEN bytes taken from the start of the prefix array.
+ LEADING_ZEROS zeros.
+ MIDLEN bytes taken from the middle of sprintf output.
+ TRAILING_ZEROS zeros.
+ ENDLEN bytes taken from the end of sprintf output.
+ TRAILING_PADDING spaces.
+
+ The sprintf output is taken from the buffer starting at
+ P and continuing for SPRINTF_BYTES bytes. */
+
+ ptrdiff_t incr
+ = (padding + leading_zeros + prefixlen
+ + sprintf_bytes + trailing_zeros);
+
+ /* Optimize for the typical case with padding or zeros. */
+ if (incr != sprintf_bytes)
{
- memset (p, ' ', padding);
- p += padding;
- nchars += padding;
+ /* Move data to make room to insert spaces and '0's.
+ As this may entail overlapping moves, process
+ the output right-to-left and use memmove.
+ With any luck this code is rarely executed. */
+ char *src = p + sprintf_bytes;
+ char *dst = p + incr;
+ dst -= trailing_padding;
+ memset (dst, ' ', trailing_padding);
+ src -= endlen;
+ dst -= endlen;
+ memmove (dst, src, endlen);
+ dst -= trailing_zeros;
+ memset (dst, '0', trailing_zeros);
+ src -= midlen;
+ dst -= midlen;
+ memmove (dst, src, midlen);
+ dst -= leading_zeros;
+ memset (dst, '0', leading_zeros);
+ dst -= prefixlen;
+ memcpy (dst, prefix, prefixlen);
+ src -= beglen;
+ dst -= beglen;
+ memmove (dst, src, beglen);
+ dst -= leading_padding;
+ memset (dst, ' ', leading_padding);
}
- spec->end = nchars;
+ p += incr;
+ spec->start = nchars;
+ spec->end = nchars += incr;
new_result = true;
- continue;
+ convbytes = CONVBYTES_ROOM;
}
}
}
@@ -4891,43 +3843,51 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
}
copy_char:
- if (convbytes <= buf + bufsize - p)
- {
- memcpy (p, convsrc, convbytes);
- p += convbytes;
- nchars++;
- continue;
- }
+ memcpy (p, convsrc, convbytes);
+ p += convbytes;
+ nchars++;
+ convbytes = CONVBYTES_ROOM;
}
- /* There wasn't enough room to store this conversion or single
- character. CONVBYTES says how much room is needed. Allocate
- enough room (and then some) and do it again. */
-
ptrdiff_t used = p - buf;
- if (max_bufsize - used < convbytes)
+ ptrdiff_t buflen_needed;
+ if (INT_ADD_WRAPV (used, convbytes, &buflen_needed))
string_overflow ();
- bufsize = used + convbytes;
- bufsize = bufsize < max_bufsize / 2 ? bufsize * 2 : max_bufsize;
-
- if (buf == initial_buffer)
+ if (bufsize <= buflen_needed)
{
- buf = xmalloc (bufsize);
- sa_must_free = true;
- buf_save_value_index = SPECPDL_INDEX ();
- record_unwind_protect_ptr (xfree, buf);
- memcpy (buf, initial_buffer, used);
- }
- else
- {
- buf = xrealloc (buf, bufsize);
- set_unwind_protect_ptr (buf_save_value_index, xfree, buf);
- }
+ if (max_bufsize <= buflen_needed)
+ string_overflow ();
+
+ /* Either there wasn't enough room to store this conversion,
+ or there won't be enough room to do a sprintf the next
+ time through the loop. Allocate enough room (and then some). */
+
+ bufsize = (buflen_needed <= max_bufsize / 2
+ ? buflen_needed * 2 : max_bufsize);
- p = buf + used;
- format = format0;
- n = n0;
- ispec = ispec0;
+ if (buf == initial_buffer)
+ {
+ buf = xmalloc (bufsize);
+ buf_save_value_index = SPECPDL_INDEX ();
+ record_unwind_protect_ptr (xfree, buf);
+ memcpy (buf, initial_buffer, used);
+ }
+ else
+ {
+ buf = xrealloc (buf, bufsize);
+ set_unwind_protect_ptr (buf_save_value_index, xfree, buf);
+ }
+
+ p = buf + used;
+ if (convbytes != CONVBYTES_ROOM)
+ {
+ /* There wasn't enough room for this conversion; do it over. */
+ eassert (CONVBYTES_ROOM < convbytes);
+ format = format0;
+ n = n0;
+ ispec = ispec0;
+ }
+ }
}
if (bufsize < p - buf)
@@ -4950,8 +3910,8 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
if (string_intervals (args[0]) || arg_intervals)
{
/* Add text properties from the format string. */
- Lisp_Object len = make_number (SCHARS (args[0]));
- Lisp_Object props = text_property_list (args[0], make_number (0),
+ Lisp_Object len = make_fixnum (SCHARS (args[0]));
+ Lisp_Object props = text_property_list (args[0], make_fixnum (0),
len, Qnil);
if (CONSP (props))
{
@@ -4975,7 +3935,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
Lisp_Object item = XCAR (list);
/* First adjust the property start position. */
- ptrdiff_t pos = XINT (XCAR (item));
+ ptrdiff_t pos = XFIXNUM (XCAR (item));
/* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
up to this position. */
@@ -4996,10 +3956,10 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
}
}
- XSETCAR (item, make_number (translated));
+ XSETCAR (item, make_fixnum (translated));
/* Likewise adjust the property end position. */
- pos = XINT (XCAR (XCDR (item)));
+ pos = XFIXNUM (XCAR (XCDR (item)));
for (; position < pos; bytepos++)
{
@@ -5018,10 +3978,10 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
}
}
- XSETCAR (XCDR (item), make_number (translated));
+ XSETCAR (XCDR (item), make_fixnum (translated));
}
- add_text_properties_from_list (val, props, make_number (0));
+ add_text_properties_from_list (val, props, make_fixnum (0));
}
/* Add text properties from arguments. */
@@ -5029,17 +3989,17 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
for (ptrdiff_t i = 0; i < nspec; i++)
if (info[i].intervals)
{
- len = make_number (SCHARS (info[i].argument));
- Lisp_Object new_len = make_number (info[i].end - info[i].start);
+ len = make_fixnum (SCHARS (info[i].argument));
+ Lisp_Object new_len = make_fixnum (info[i].end - info[i].start);
props = text_property_list (info[i].argument,
- make_number (0), len, Qnil);
+ make_fixnum (0), len, Qnil);
props = extend_property_ranges (props, len, new_len);
/* If successive arguments have properties, be sure that
the value of `composition' property be the copy. */
if (1 < i && info[i - 1].end)
make_composition_value_copy (props);
add_text_properties_from_list (val, props,
- make_number (info[i].start));
+ make_fixnum (info[i].start));
}
}
@@ -5062,13 +4022,13 @@ Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
CHECK_CHARACTER (c1);
CHECK_CHARACTER (c2);
- if (XINT (c1) == XINT (c2))
+ if (XFIXNUM (c1) == XFIXNUM (c2))
return Qt;
if (NILP (BVAR (current_buffer, case_fold_search)))
return Qnil;
- i1 = XFASTINT (c1);
- i2 = XFASTINT (c2);
+ i1 = XFIXNAT (c1);
+ i2 = XFIXNAT (c2);
/* FIXME: It is possible to compare multibyte characters even when
the current buffer is unibyte. Unfortunately this is ambiguous
@@ -5171,7 +4131,16 @@ transpose_markers (ptrdiff_t start1, ptrdiff_t end1,
}
}
-DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5, 0,
+DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5,
+ "(if (< (length mark-ring) 2)\
+ (error \"Other region must be marked before transposing two regions\")\
+ (let* ((num (if current-prefix-arg\
+ (prefix-numeric-value current-prefix-arg)\
+ 0))\
+ (ring-length (length mark-ring))\
+ (eltnum (mod num ring-length))\
+ (eltnum2 (mod (1+ num) ring-length)))\
+ (list (point) (mark) (elt mark-ring eltnum) (elt mark-ring eltnum2))))",
doc: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
The regions should not be overlapping, because the size of the buffer is
never changed in a transposition.
@@ -5179,7 +4148,14 @@ never changed in a transposition.
Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
any markers that happen to be located in the regions.
-Transposing beyond buffer boundaries is an error. */)
+Transposing beyond buffer boundaries is an error.
+
+Interactively, STARTR1 and ENDR1 are point and mark; STARTR2 and ENDR2
+are the last two marks pushed to the mark ring; LEAVE-MARKERS is nil.
+If a prefix argument N is given, STARTR2 and ENDR2 are the two
+successive marks N entries back in the mark ring. A negative prefix
+argument instead counts forward from the oldest mark in the mark
+ring. */)
(Lisp_Object startr1, Lisp_Object endr1, Lisp_Object startr2, Lisp_Object endr2, Lisp_Object leave_markers)
{
register ptrdiff_t start1, end1, start2, end2;
@@ -5196,10 +4172,10 @@ Transposing beyond buffer boundaries is an error. */)
validate_region (&startr1, &endr1);
validate_region (&startr2, &endr2);
- start1 = XFASTINT (startr1);
- end1 = XFASTINT (endr1);
- start2 = XFASTINT (startr2);
- end2 = XFASTINT (endr2);
+ start1 = XFIXNAT (startr1);
+ end1 = XFIXNAT (endr1);
+ start2 = XFIXNAT (startr2);
+ end2 = XFIXNAT (endr2);
gap = GPT;
/* Swap the regions if they're reversed. */
@@ -5352,8 +4328,7 @@ Transposing beyond buffer boundaries is an error. */)
{
USE_SAFE_ALLOCA;
- modify_text (start1, end1);
- modify_text (start2, end2);
+ modify_text (start1, end2);
record_change (start1, len1);
record_change (start2, len2);
tmp_interval1 = copy_intervals (cur_intv, start1, len1);
@@ -5526,6 +4501,18 @@ functions if all the text being accessed has this property. */);
DEFVAR_LISP ("operating-system-release", Voperating_system_release,
doc: /* The release of the operating system Emacs is running on. */);
+ DEFVAR_BOOL ("binary-as-unsigned",
+ binary_as_unsigned,
+ doc: /* Non-nil means `format' %x and %o treat integers as unsigned.
+This has machine-dependent results. Nil means to treat integers as
+signed, which is portable and is the default; for example, if N is a
+negative integer, (read (format "#x%x" N)) returns N only when this
+variable is nil.
+
+This variable is experimental; email 32252@debbugs.gnu.org if you need
+it to be non-nil. */);
+ binary_as_unsigned = false;
+
defsubr (&Spropertize);
defsubr (&Schar_equal);
defsubr (&Sgoto_char);
@@ -5587,7 +4574,10 @@ functions if all the text being accessed has this property. */);
defsubr (&Sinsert_char);
defsubr (&Sinsert_byte);
+ defsubr (&Sngettext);
+
defsubr (&Suser_login_name);
+ defsubr (&Sgroup_name);
defsubr (&Suser_real_login_name);
defsubr (&Suser_uid);
defsubr (&Suser_real_uid);
@@ -5595,18 +4585,6 @@ functions if all the text being accessed has this property. */);
defsubr (&Sgroup_real_gid);
defsubr (&Suser_full_name);
defsubr (&Semacs_pid);
- defsubr (&Scurrent_time);
- defsubr (&Stime_add);
- defsubr (&Stime_subtract);
- defsubr (&Stime_less_p);
- defsubr (&Sget_internal_run_time);
- defsubr (&Sformat_time_string);
- defsubr (&Sfloat_time);
- defsubr (&Sdecode_time);
- defsubr (&Sencode_time);
- defsubr (&Scurrent_time_string);
- defsubr (&Scurrent_time_zone);
- defsubr (&Sset_time_zone_rule);
defsubr (&Ssystem_name);
defsubr (&Smessage);
defsubr (&Smessage_box);
diff --git a/src/emacs-module.c b/src/emacs-module.c
index 0abfd3f6f16..47ca3368c0f 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -25,6 +25,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <stddef.h>
#include <stdint.h>
#include <stdio.h>
+#include <stdlib.h>
#include "lisp.h"
#include "dynlib.h"
@@ -36,6 +37,11 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <intprops.h>
#include <verify.h>
+/* Work around GCC bug 83162. */
+#if GNUC_PREREQ (4, 3, 0)
+# pragma GCC diagnostic ignored "-Wclobbered"
+#endif
+
/* This module is lackadaisical about function casts. */
#if GNUC_PREREQ (8, 0, 0)
# pragma GCC diagnostic ignored "-Wcast-function-type"
@@ -60,18 +66,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "w32term.h"
#endif
-/* True if Lisp_Object and emacs_value have the same representation.
- This is typically true unless WIDE_EMACS_INT. In practice, having
- the same sizes and alignments and maximums should be a good enough
- proxy for equality of representation. */
-enum
- {
- plain_values
- = (sizeof (Lisp_Object) == sizeof (emacs_value)
- && alignof (Lisp_Object) == alignof (emacs_value)
- && INTPTR_MAX == EMACS_INT_MAX)
- };
-
/* Function prototype for the module init function. */
typedef int (*emacs_init_function) (struct emacs_runtime *);
@@ -82,6 +76,43 @@ typedef int (*emacs_init_function) (struct emacs_runtime *);
typedef void (*emacs_finalizer_function) (void *);
+/* Memory management. */
+
+/* An `emacs_value' is just a pointer to a structure holding an
+ internal Lisp object. */
+struct emacs_value_tag { Lisp_Object v; };
+
+/* Local value objects use a simple fixed-sized block allocation
+ scheme without explicit deallocation. All local values are
+ deallocated when the lifetime of their environment ends. Keep
+ track of a current frame from which new values are allocated,
+ appending further dynamically-allocated frames if necessary. */
+
+enum { value_frame_size = 512 };
+
+/* A block from which `emacs_value' object can be allocated. */
+struct emacs_value_frame
+{
+ /* Storage for values. */
+ struct emacs_value_tag objects[value_frame_size];
+
+ /* Index of the next free value in `objects'. */
+ int offset;
+
+ /* Pointer to next frame, if any. */
+ struct emacs_value_frame *next;
+};
+
+/* A structure that holds an initial frame (so that the first local
+ values require no dynamic allocation) and keeps track of the
+ current frame. */
+static struct emacs_value_storage
+{
+ struct emacs_value_frame initial;
+ struct emacs_value_frame *current;
+} global_storage;
+
+
/* Private runtime and environment members. */
/* The private part of an environment stores the current non local exit state
@@ -94,12 +125,9 @@ struct emacs_env_private
/* Dedicated storage for non-local exit symbol and data so that
storage is always available for them, even in an out-of-memory
situation. */
- Lisp_Object non_local_exit_symbol, non_local_exit_data;
+ struct emacs_value_tag non_local_exit_symbol, non_local_exit_data;
- /* List of values allocated from this environment. The code uses
- this only if the user gave the -module-assertions command-line
- option. */
- Lisp_Object values;
+ struct emacs_value_storage storage;
};
/* The private parts of an `emacs_runtime' object contain the initial
@@ -113,6 +141,7 @@ struct emacs_runtime_private
/* Forward declarations. */
static Lisp_Object value_to_lisp (emacs_value);
+static emacs_value allocate_emacs_value (emacs_env *, struct emacs_value_storage *, Lisp_Object);
static emacs_value lisp_to_value (emacs_env *, Lisp_Object);
static enum emacs_funcall_exit module_non_local_exit_check (emacs_env *);
static void module_assert_thread (void);
@@ -134,16 +163,7 @@ static void module_non_local_exit_throw_1 (emacs_env *,
static void module_out_of_memory (emacs_env *);
static void module_reset_handlerlist (struct handler **);
-/* We used to return NULL when emacs_value was a different type from
- Lisp_Object, but nowadays we just use Qnil instead. Although they
- happen to be the same thing in the current implementation, module
- code should not assume this. */
-verify (NIL_IS_ZERO);
-static emacs_value const module_nil = 0;
-
static bool module_assertions = false;
-static emacs_env *global_env;
-static struct emacs_env_private global_env_private;
/* Convenience macros for non-local exit handling. */
@@ -288,7 +308,7 @@ module_get_environment (struct emacs_runtime *ert)
static emacs_value
module_make_global_ref (emacs_env *env, emacs_value ref)
{
- MODULE_FUNCTION_BEGIN (module_nil);
+ MODULE_FUNCTION_BEGIN (NULL);
struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash);
Lisp_Object new_obj = value_to_lisp (ref);
EMACS_UINT hashcode;
@@ -297,18 +317,18 @@ module_make_global_ref (emacs_env *env, emacs_value ref)
if (i >= 0)
{
Lisp_Object value = HASH_VALUE (h, i);
- EMACS_INT refcount = XFASTINT (value) + 1;
+ EMACS_INT refcount = XFIXNAT (value) + 1;
if (MOST_POSITIVE_FIXNUM < refcount)
- xsignal0 (Qoverflow_error);
- value = make_natnum (refcount);
+ overflow_error ();
+ value = make_fixed_natnum (refcount);
set_hash_value_slot (h, i, value);
}
else
{
- hash_put (h, new_obj, make_natnum (1), hashcode);
+ hash_put (h, new_obj, make_fixed_natnum (1), hashcode);
}
- return lisp_to_value (module_assertions ? global_env : env, new_obj);
+ return allocate_emacs_value (env, &global_storage, new_obj);
}
static void
@@ -324,9 +344,9 @@ module_free_global_ref (emacs_env *env, emacs_value ref)
if (i >= 0)
{
- EMACS_INT refcount = XFASTINT (HASH_VALUE (h, i)) - 1;
+ EMACS_INT refcount = XFIXNAT (HASH_VALUE (h, i)) - 1;
if (refcount > 0)
- set_hash_value_slot (h, i, make_natnum (refcount));
+ set_hash_value_slot (h, i, make_fixed_natnum (refcount));
else
{
eassert (refcount == 0);
@@ -336,23 +356,16 @@ module_free_global_ref (emacs_env *env, emacs_value ref)
if (module_assertions)
{
- Lisp_Object globals = global_env_private.values;
- Lisp_Object prev = Qnil;
ptrdiff_t count = 0;
- for (Lisp_Object tail = globals; CONSP (tail);
- tail = XCDR (tail))
+ for (struct emacs_value_frame *frame = &global_storage.initial;
+ frame != NULL; frame = frame->next)
{
- emacs_value global = XSAVE_POINTER (XCAR (tail), 0);
- if (global == ref)
+ for (int i = 0; i < frame->offset; ++i)
{
- if (NILP (prev))
- global_env_private.values = XCDR (globals);
- else
- XSETCDR (prev, XCDR (tail));
- return;
+ if (&frame->objects[i] == ref)
+ return;
+ ++count;
}
- ++count;
- prev = tail;
}
module_abort ("Global value was not found in list of %"pD"d globals",
count);
@@ -383,9 +396,8 @@ module_non_local_exit_get (emacs_env *env, emacs_value *sym, emacs_value *data)
struct emacs_env_private *p = env->private_members;
if (p->pending_non_local_exit != emacs_funcall_exit_return)
{
- /* FIXME: lisp_to_value can exit non-locally. */
- *sym = lisp_to_value (env, p->non_local_exit_symbol);
- *data = lisp_to_value (env, p->non_local_exit_data);
+ *sym = &p->non_local_exit_symbol;
+ *data = &p->non_local_exit_data;
}
return p->pending_non_local_exit;
}
@@ -415,7 +427,7 @@ static struct Lisp_Module_Function *
allocate_module_function (void)
{
return ALLOCATE_PSEUDOVECTOR (struct Lisp_Module_Function,
- min_arity, PVEC_MODULE_FUNCTION);
+ documentation, PVEC_MODULE_FUNCTION);
}
#define XSET_MODULE_FUNCTION(var, ptr) \
@@ -429,14 +441,14 @@ module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity,
emacs_subr subr, const char *documentation,
void *data)
{
- MODULE_FUNCTION_BEGIN (module_nil);
+ MODULE_FUNCTION_BEGIN (NULL);
if (! (0 <= min_arity
&& (max_arity < 0
? (min_arity <= MOST_POSITIVE_FIXNUM
&& max_arity == emacs_variadic_function)
: min_arity <= max_arity && max_arity <= MOST_POSITIVE_FIXNUM)))
- xsignal2 (Qinvalid_arity, make_number (min_arity), make_number (max_arity));
+ xsignal2 (Qinvalid_arity, make_fixnum (min_arity), make_fixnum (max_arity));
struct Lisp_Module_Function *function = allocate_module_function ();
function->min_arity = min_arity;
@@ -462,7 +474,7 @@ static emacs_value
module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs,
emacs_value args[])
{
- MODULE_FUNCTION_BEGIN (module_nil);
+ MODULE_FUNCTION_BEGIN (NULL);
/* Make a new Lisp_Object array starting with the function as the
first arg, because that's what Ffuncall takes. */
@@ -470,7 +482,7 @@ module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs,
USE_SAFE_ALLOCA;
ptrdiff_t nargs1;
if (INT_ADD_WRAPV (nargs, 1, &nargs1))
- xsignal0 (Qoverflow_error);
+ overflow_error ();
SAFE_ALLOCA_LISP (newargs, nargs1);
newargs[0] = value_to_lisp (fun);
for (ptrdiff_t i = 0; i < nargs; i++)
@@ -483,14 +495,14 @@ module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs,
static emacs_value
module_intern (emacs_env *env, const char *name)
{
- MODULE_FUNCTION_BEGIN (module_nil);
+ MODULE_FUNCTION_BEGIN (NULL);
return lisp_to_value (env, intern (name));
}
static emacs_value
module_type_of (emacs_env *env, emacs_value value)
{
- MODULE_FUNCTION_BEGIN (module_nil);
+ MODULE_FUNCTION_BEGIN (NULL);
return lisp_to_value (env, Ftype_of (value_to_lisp (value)));
}
@@ -513,17 +525,18 @@ module_extract_integer (emacs_env *env, emacs_value n)
{
MODULE_FUNCTION_BEGIN (0);
Lisp_Object l = value_to_lisp (n);
- CHECK_NUMBER (l);
- return XINT (l);
+ CHECK_INTEGER (l);
+ intmax_t i;
+ if (! integer_to_intmax (l, &i))
+ xsignal1 (Qoverflow_error, l);
+ return i;
}
static emacs_value
module_make_integer (emacs_env *env, intmax_t n)
{
- MODULE_FUNCTION_BEGIN (module_nil);
- if (FIXNUM_OVERFLOW_P (n))
- xsignal0 (Qoverflow_error);
- return lisp_to_value (env, make_number (n));
+ MODULE_FUNCTION_BEGIN (NULL);
+ return lisp_to_value (env, make_int (n));
}
static double
@@ -538,7 +551,7 @@ module_extract_float (emacs_env *env, emacs_value f)
static emacs_value
module_make_float (emacs_env *env, double d)
{
- MODULE_FUNCTION_BEGIN (module_nil);
+ MODULE_FUNCTION_BEGIN (NULL);
return lisp_to_value (env, make_float (d));
}
@@ -575,10 +588,10 @@ module_copy_string_contents (emacs_env *env, emacs_value value, char *buffer,
static emacs_value
module_make_string (emacs_env *env, const char *str, ptrdiff_t length)
{
- MODULE_FUNCTION_BEGIN (module_nil);
+ MODULE_FUNCTION_BEGIN (NULL);
if (! (0 <= length && length <= STRING_BYTES_BOUND))
- xsignal0 (Qoverflow_error);
- /* FIXME: AUTO_STRING_WITH_LEN requires STR to be null-terminated,
+ overflow_error ();
+ /* FIXME: AUTO_STRING_WITH_LEN requires STR to be NUL-terminated,
but we shouldn't require that. */
AUTO_STRING_WITH_LEN (lstr, str, length);
return lisp_to_value (env,
@@ -588,7 +601,7 @@ module_make_string (emacs_env *env, const char *str, ptrdiff_t length)
static emacs_value
module_make_user_ptr (emacs_env *env, emacs_finalizer_function fin, void *ptr)
{
- MODULE_FUNCTION_BEGIN (module_nil);
+ MODULE_FUNCTION_BEGIN (NULL);
return lisp_to_value (env, make_user_ptr (fin, ptr));
}
@@ -634,8 +647,8 @@ check_vec_index (Lisp_Object lvec, ptrdiff_t i)
{
CHECK_VECTOR (lvec);
if (! (0 <= i && i < ASIZE (lvec)))
- args_out_of_range_3 (make_fixnum_or_float (i),
- make_number (0), make_number (ASIZE (lvec) - 1));
+ args_out_of_range_3 (INT_TO_INTEGER (i),
+ make_fixnum (0), make_fixnum (ASIZE (lvec) - 1));
}
static void
@@ -650,7 +663,7 @@ module_vec_set (emacs_env *env, emacs_value vec, ptrdiff_t i, emacs_value val)
static emacs_value
module_vec_get (emacs_env *env, emacs_value vec, ptrdiff_t i)
{
- MODULE_FUNCTION_BEGIN (module_nil);
+ MODULE_FUNCTION_BEGIN (NULL);
Lisp_Object lvec = value_to_lisp (vec);
check_vec_index (lvec, i);
return lisp_to_value (env, AREF (lvec, i));
@@ -665,13 +678,21 @@ module_vec_size (emacs_env *env, emacs_value vec)
return ASIZE (lvec);
}
-/* This function should return true if and only if maybe_quit would do
- anything. */
+/* This function should return true if and only if maybe_quit would
+ quit. */
static bool
module_should_quit (emacs_env *env)
{
MODULE_FUNCTION_BEGIN_NO_CATCH (false);
- return (! NILP (Vquit_flag) && NILP (Vinhibit_quit)) || pending_signals;
+ return QUITP;
+}
+
+static enum emacs_process_input_result
+module_process_input (emacs_env *env)
+{
+ MODULE_FUNCTION_BEGIN (emacs_process_input_quit);
+ maybe_quit ();
+ return emacs_process_input_continue;
}
@@ -685,9 +706,11 @@ module_signal_or_throw (struct emacs_env_private *env)
case emacs_funcall_exit_return:
return;
case emacs_funcall_exit_signal:
- xsignal (env->non_local_exit_symbol, env->non_local_exit_data);
+ xsignal (value_to_lisp (&env->non_local_exit_symbol),
+ value_to_lisp (&env->non_local_exit_data));
case emacs_funcall_exit_throw:
- Fthrow (env->non_local_exit_symbol, env->non_local_exit_data);
+ Fthrow (value_to_lisp (&env->non_local_exit_symbol),
+ value_to_lisp (&env->non_local_exit_data));
default:
eassume (false);
}
@@ -730,7 +753,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0,
rt->private_members = &rt_priv;
rt->get_environment = module_get_environment;
- Vmodule_runtimes = Fcons (make_save_ptr (rt), Vmodule_runtimes);
+ Vmodule_runtimes = Fcons (make_mint_ptr (rt), Vmodule_runtimes);
ptrdiff_t count = SPECPDL_INDEX ();
record_unwind_protect_ptr (finalize_runtime_unwind, rt);
@@ -741,11 +764,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0,
maybe_quit ();
if (r != 0)
- {
- if (FIXNUM_OVERFLOW_P (r))
- xsignal0 (Qoverflow_error);
- xsignal2 (Qmodule_init_failed, file, make_number (r));
- }
+ xsignal2 (Qmodule_init_failed, file, INT_TO_INTEGER (r));
module_signal_or_throw (&env_priv);
return unbind_to (count, Qt);
@@ -758,7 +777,7 @@ funcall_module (Lisp_Object function, ptrdiff_t nargs, Lisp_Object *arglist)
eassume (0 <= func->min_arity);
if (! (func->min_arity <= nargs
&& (func->max_arity < 0 || nargs <= func->max_arity)))
- xsignal2 (Qwrong_number_of_arguments, function, make_number (nargs));
+ xsignal2 (Qwrong_number_of_arguments, function, make_fixnum (nargs));
emacs_env pub;
struct emacs_env_private priv;
@@ -767,21 +786,15 @@ funcall_module (Lisp_Object function, ptrdiff_t nargs, Lisp_Object *arglist)
record_unwind_protect_ptr (finalize_environment_unwind, env);
USE_SAFE_ALLOCA;
- ATTRIBUTE_MAY_ALIAS emacs_value *args;
- if (plain_values && ! module_assertions)
- /* FIXME: The cast below is incorrect because the argument array
- is not declared as const, so module functions can modify it.
- Either declare it as const, or remove this branch. */
- args = (emacs_value *) arglist;
- else
+ emacs_value *args = nargs > 0 ? SAFE_ALLOCA (nargs * sizeof *args) : NULL;
+ for (ptrdiff_t i = 0; i < nargs; ++i)
{
- args = SAFE_ALLOCA (nargs * sizeof *args);
- for (ptrdiff_t i = 0; i < nargs; i++)
- args[i] = lisp_to_value (env, arglist[i]);
+ args[i] = lisp_to_value (env, arglist[i]);
+ if (! args[i])
+ memory_full (sizeof *args[i]);
}
emacs_value ret = func->subr (env, nargs, args, func->data);
- SAFE_FREE ();
eassert (&priv == env->private_members);
@@ -790,7 +803,7 @@ funcall_module (Lisp_Object function, ptrdiff_t nargs, Lisp_Object *arglist)
maybe_quit ();
module_signal_or_throw (&priv);
- return unbind_to (count, value_to_lisp (ret));
+ return SAFE_FREE_UNBIND_TO (count, value_to_lisp (ret));
}
Lisp_Object
@@ -798,25 +811,13 @@ module_function_arity (const struct Lisp_Module_Function *const function)
{
ptrdiff_t minargs = function->min_arity;
ptrdiff_t maxargs = function->max_arity;
- return Fcons (make_number (minargs),
- maxargs == MANY ? Qmany : make_number (maxargs));
+ return Fcons (make_fixnum (minargs),
+ maxargs == MANY ? Qmany : make_fixnum (maxargs));
}
/* Helper functions. */
-static bool
-in_current_thread (void)
-{
- if (current_thread == NULL)
- return false;
-#ifdef HAVE_PTHREAD
- return pthread_equal (pthread_self (), current_thread->thread_id);
-#elif defined WINDOWSNT
- return GetCurrentThreadId () == current_thread->thread_id;
-#endif
-}
-
static void
module_assert_thread (void)
{
@@ -837,7 +838,7 @@ module_assert_runtime (struct emacs_runtime *ert)
ptrdiff_t count = 0;
for (Lisp_Object tail = Vmodule_runtimes; CONSP (tail); tail = XCDR (tail))
{
- if (XSAVE_POINTER (XCAR (tail), 0) == ert)
+ if (xmint_pointer (XCAR (tail)) == ert)
return;
++count;
}
@@ -854,7 +855,7 @@ module_assert_env (emacs_env *env)
for (Lisp_Object tail = Vmodule_environments; CONSP (tail);
tail = XCDR (tail))
{
- if (XSAVE_POINTER (XCAR (tail), 0) == env)
+ if (xmint_pointer (XCAR (tail)) == env)
return;
++count;
}
@@ -870,8 +871,8 @@ module_non_local_exit_signal_1 (emacs_env *env, Lisp_Object sym,
if (p->pending_non_local_exit == emacs_funcall_exit_return)
{
p->pending_non_local_exit = emacs_funcall_exit_signal;
- p->non_local_exit_symbol = sym;
- p->non_local_exit_data = data;
+ p->non_local_exit_symbol.v = sym;
+ p->non_local_exit_data.v = data;
}
}
@@ -883,8 +884,8 @@ module_non_local_exit_throw_1 (emacs_env *env, Lisp_Object tag,
if (p->pending_non_local_exit == emacs_funcall_exit_return)
{
p->pending_non_local_exit = emacs_funcall_exit_throw;
- p->non_local_exit_symbol = tag;
- p->non_local_exit_data = value;
+ p->non_local_exit_symbol.v = tag;
+ p->non_local_exit_data.v = value;
}
}
@@ -901,54 +902,8 @@ module_out_of_memory (emacs_env *env)
/* Value conversion. */
-/* We represent Lisp objects differently depending on whether the user
- gave -module-assertions. If assertions are disabled, emacs_value
- objects are Lisp_Objects cast to emacs_value. If assertions are
- enabled, emacs_value objects are pointers to Lisp_Object objects
- allocated from the free store; they are never freed, which ensures
- that their addresses are unique and can be used for liveness
- checking. */
-
-/* Unique Lisp_Object used to mark those emacs_values which are really
- just containers holding a Lisp_Object that does not fit as an emacs_value,
- either because it is an integer out of range, or is not properly aligned.
- Used only if !plain_values. */
-static Lisp_Object ltv_mark;
-
-/* Convert V to the corresponding internal object O, such that
- V == lisp_to_value_bits (O). Never fails. */
-static Lisp_Object
-value_to_lisp_bits (emacs_value v)
-{
- intptr_t i = (intptr_t) v;
- if (plain_values || USE_LSB_TAG)
- return XIL (i);
-
- /* With wide EMACS_INT and when tag bits are the most significant,
- reassembling integers differs from reassembling pointers in two
- ways. First, save and restore the least-significant bits of the
- integer, not the most-significant bits. Second, sign-extend the
- integer when restoring, but zero-extend pointers because that
- makes TAG_PTR faster. */
-
- EMACS_UINT tag = i & (GCALIGNMENT - 1);
- EMACS_UINT untagged = i - tag;
- switch (tag)
- {
- case_Lisp_Int:
- {
- bool negative = tag & 1;
- EMACS_UINT sign_extension
- = negative ? VALMASK & ~(INTPTR_MAX >> INTTYPEBITS): 0;
- uintptr_t u = i;
- intptr_t all_but_sign = u >> GCTYPEBITS;
- untagged = sign_extension + all_but_sign;
- break;
- }
- }
-
- return XIL ((tag << VALBITS) + untagged);
-}
+/* Convert an `emacs_value' to the corresponding internal object.
+ Never fails. */
/* If V was computed from lisp_to_value (O), then return O.
Exits non-locally only if the stack overflows. */
@@ -959,82 +914,134 @@ value_to_lisp (emacs_value v)
{
/* Check the liveness of the value by iterating over all live
environments. */
- void *vptr = v;
- ATTRIBUTE_MAY_ALIAS Lisp_Object *optr = vptr;
ptrdiff_t num_environments = 0;
ptrdiff_t num_values = 0;
for (Lisp_Object environments = Vmodule_environments;
CONSP (environments); environments = XCDR (environments))
{
- emacs_env *env = XSAVE_POINTER (XCAR (environments), 0);
- for (Lisp_Object values = env->private_members->values;
- CONSP (values); values = XCDR (values))
+ emacs_env *env = xmint_pointer (XCAR (environments));
+ struct emacs_env_private *priv = env->private_members;
+ /* The value might be one of the nonlocal exit values. Note
+ that we don't check whether a nonlocal exit is currently
+ pending, because the module might have cleared the flag
+ in the meantime. */
+ if (&priv->non_local_exit_symbol == v
+ || &priv->non_local_exit_data == v)
+ goto ok;
+ for (struct emacs_value_frame *frame = &priv->storage.initial;
+ frame != NULL; frame = frame->next)
{
- Lisp_Object *p = XSAVE_POINTER (XCAR (values), 0);
- if (p == optr)
- return *p;
- ++num_values;
+ for (int i = 0; i < frame->offset; ++i)
+ {
+ if (&frame->objects[i] == v)
+ goto ok;
+ ++num_values;
+ }
}
++num_environments;
}
+ /* Also check global values. */
+ for (struct emacs_value_frame *frame = &global_storage.initial;
+ frame != NULL; frame = frame->next)
+ {
+ for (int i = 0; i < frame->offset; ++i)
+ {
+ if (&frame->objects[i] == v)
+ goto ok;
+ ++num_values;
+ }
+ }
module_abort (("Emacs value not found in %"pD"d values "
"of %"pD"d environments"),
num_values, num_environments);
}
- Lisp_Object o = value_to_lisp_bits (v);
- if (! plain_values && CONSP (o) && EQ (XCDR (o), ltv_mark))
- o = XCAR (o);
- return o;
+ ok: return v->v;
}
-/* Attempt to convert O to an emacs_value. Do not do any checking
- or allocate any storage; the caller should prevent or detect
- any resulting bit pattern that is not a valid emacs_value. */
+/* Convert an internal object to an `emacs_value'. Allocate storage
+ from the environment; return NULL if allocation fails. */
static emacs_value
-lisp_to_value_bits (Lisp_Object o)
+lisp_to_value (emacs_env *env, Lisp_Object o)
{
- EMACS_UINT u = XLI (o);
+ struct emacs_env_private *p = env->private_members;
+ if (p->pending_non_local_exit != emacs_funcall_exit_return)
+ return NULL;
+ return allocate_emacs_value (env, &p->storage, o);
+}
- /* Compress U into the space of a pointer, possibly losing information. */
- uintptr_t p = (plain_values || USE_LSB_TAG
- ? u
- : (INTEGERP (o) ? u << VALBITS : u & VALMASK) + XTYPE (o));
- return (emacs_value) p;
+/* Must be called for each frame before it can be used for allocation. */
+static void
+initialize_frame (struct emacs_value_frame *frame)
+{
+ frame->offset = 0;
+ frame->next = NULL;
}
-/* Convert O to an emacs_value. Allocate storage if needed; this can
- signal if memory is exhausted. Must be an injective function. */
-static emacs_value
-lisp_to_value (emacs_env *env, Lisp_Object o)
+/* Must be called for any storage object before it can be used for
+ allocation. */
+static void
+initialize_storage (struct emacs_value_storage *storage)
{
- if (module_assertions)
+ initialize_frame (&storage->initial);
+ storage->current = &storage->initial;
+}
+
+/* Must be called for any initialized storage object before its
+ lifetime ends. Free all dynamically-allocated frames. */
+static void
+finalize_storage (struct emacs_value_storage *storage)
+{
+ struct emacs_value_frame *next = storage->initial.next;
+ while (next != NULL)
{
- /* Add the new value to the list of values allocated from this
- environment. The value is actually a pointer to the
- Lisp_Object cast to emacs_value. We make a copy of the
- object on the free store to guarantee unique addresses. */
- ATTRIBUTE_MAY_ALIAS Lisp_Object *optr = xmalloc (sizeof o);
- *optr = o;
- void *vptr = optr;
- ATTRIBUTE_MAY_ALIAS emacs_value ret = vptr;
- struct emacs_env_private *priv = env->private_members;
- priv->values = Fcons (make_save_ptr (ret), priv->values);
- return ret;
+ struct emacs_value_frame *current = next;
+ next = current->next;
+ free (current);
}
+}
- emacs_value v = lisp_to_value_bits (o);
-
- if (! EQ (o, value_to_lisp_bits (v)))
+/* Allocate a new value from STORAGE and stores OBJ in it. Return
+ NULL if allocation fails and use ENV for non local exit reporting. */
+static emacs_value
+allocate_emacs_value (emacs_env *env, struct emacs_value_storage *storage,
+ Lisp_Object obj)
+{
+ eassert (storage->current);
+ eassert (storage->current->offset < value_frame_size);
+ eassert (! storage->current->next);
+ if (storage->current->offset == value_frame_size - 1)
{
- /* Package the incompressible object pointer inside a pair
- that is compressible. */
- Lisp_Object pair = Fcons (o, ltv_mark);
- v = (emacs_value) ((intptr_t) XCONS (pair) + Lisp_Cons);
+ storage->current->next = malloc (sizeof *storage->current->next);
+ if (! storage->current->next)
+ {
+ module_out_of_memory (env);
+ return NULL;
+ }
+ initialize_frame (storage->current->next);
+ storage->current = storage->current->next;
}
+ emacs_value value = storage->current->objects + storage->current->offset;
+ value->v = obj;
+ ++storage->current->offset;
+ return value;
+}
- eassert (EQ (o, value_to_lisp (v)));
- return v;
+/* Mark all objects allocated from local environments so that they
+ don't get garbage-collected. */
+void
+mark_modules (void)
+{
+ for (Lisp_Object tem = Vmodule_environments; CONSP (tem); tem = XCDR (tem))
+ {
+ emacs_env *env = xmint_pointer (XCAR (tem));
+ struct emacs_env_private *priv = env->private_members;
+ for (struct emacs_value_frame *frame = &priv->storage.initial;
+ frame != NULL;
+ frame = frame->next)
+ for (int i = 0; i < frame->offset; ++i)
+ mark_object (frame->objects[i].v);
+ }
}
@@ -1053,7 +1060,7 @@ initialize_environment (emacs_env *env, struct emacs_env_private *priv)
env = xmalloc (sizeof *env);
priv->pending_non_local_exit = emacs_funcall_exit_return;
- priv->values = priv->non_local_exit_symbol = priv->non_local_exit_data = Qnil;
+ initialize_storage (&priv->storage);
env->size = sizeof *env;
env->private_members = priv;
env->make_global_ref = module_make_global_ref;
@@ -1084,7 +1091,8 @@ initialize_environment (emacs_env *env, struct emacs_env_private *priv)
env->vec_get = module_vec_get;
env->vec_size = module_vec_size;
env->should_quit = module_should_quit;
- Vmodule_environments = Fcons (make_save_ptr (env), Vmodule_environments);
+ env->process_input = module_process_input;
+ Vmodule_environments = Fcons (make_mint_ptr (env), Vmodule_environments);
return env;
}
@@ -1093,11 +1101,9 @@ initialize_environment (emacs_env *env, struct emacs_env_private *priv)
static void
finalize_environment (emacs_env *env)
{
- eassert (XSAVE_POINTER (XCAR (Vmodule_environments), 0) == env);
+ finalize_storage (&env->private_members->storage);
+ eassert (xmint_pointer (XCAR (Vmodule_environments)) == env);
Vmodule_environments = XCDR (Vmodule_environments);
- if (module_assertions)
- /* There is always at least the global environment. */
- eassert (CONSP (Vmodule_environments));
}
static void
@@ -1107,28 +1113,14 @@ finalize_environment_unwind (void *env)
}
static void
-finalize_runtime_unwind (void* raw_ert)
+finalize_runtime_unwind (void *raw_ert)
{
struct emacs_runtime *ert = raw_ert;
- eassert (XSAVE_POINTER (XCAR (Vmodule_runtimes), 0) == ert);
+ eassert (xmint_pointer (XCAR (Vmodule_runtimes)) == ert);
Vmodule_runtimes = XCDR (Vmodule_runtimes);
finalize_environment (ert->private_members->env);
}
-void
-mark_modules (void)
-{
- for (Lisp_Object tail = Vmodule_environments; CONSP (tail);
- tail = XCDR (tail))
- {
- emacs_env *env = XSAVE_POINTER (XCAR (tail), 0);
- struct emacs_env_private *priv = env->private_members;
- mark_object (priv->non_local_exit_symbol);
- mark_object (priv->non_local_exit_data);
- mark_object (priv->values);
- }
-}
-
/* Non-local exit handling. */
@@ -1165,15 +1157,10 @@ module_handle_throw (emacs_env *env, Lisp_Object tag_val)
void
init_module_assertions (bool enable)
{
+ /* If enabling module assertions, use a hidden environment for
+ storing the globals. This environment is never freed. */
module_assertions = enable;
- if (enable)
- {
- /* We use a hidden environment for storing the globals. This
- environment is never freed. */
- emacs_env env;
- global_env = initialize_environment (&env, &global_env_private);
- eassert (global_env != &env);
- }
+ initialize_storage (&global_storage);
}
static _Noreturn void
@@ -1196,10 +1183,6 @@ module_abort (const char *format, ...)
void
syms_of_module (void)
{
- if (!plain_values)
- ltv_mark = Fcons (Qnil, Qnil);
- eassert (NILP (value_to_lisp (module_nil)));
-
DEFSYM (Qmodule_refs_hash, "module-refs-hash");
DEFVAR_LISP ("module-refs-hash", Vmodule_refs_hash,
doc: /* Module global reference table. */);
@@ -1228,42 +1211,38 @@ syms_of_module (void)
DEFSYM (Qmodule_load_failed, "module-load-failed");
Fput (Qmodule_load_failed, Qerror_conditions,
- listn (CONSTYPE_PURE, 2, Qmodule_load_failed, Qerror));
+ pure_list (Qmodule_load_failed, Qerror));
Fput (Qmodule_load_failed, Qerror_message,
build_pure_c_string ("Module load failed"));
DEFSYM (Qmodule_open_failed, "module-open-failed");
Fput (Qmodule_open_failed, Qerror_conditions,
- listn (CONSTYPE_PURE, 3,
- Qmodule_open_failed, Qmodule_load_failed, Qerror));
+ pure_list (Qmodule_open_failed, Qmodule_load_failed, Qerror));
Fput (Qmodule_open_failed, Qerror_message,
build_pure_c_string ("Module could not be opened"));
DEFSYM (Qmodule_not_gpl_compatible, "module-not-gpl-compatible");
Fput (Qmodule_not_gpl_compatible, Qerror_conditions,
- listn (CONSTYPE_PURE, 3,
- Qmodule_not_gpl_compatible, Qmodule_load_failed, Qerror));
+ pure_list (Qmodule_not_gpl_compatible, Qmodule_load_failed, Qerror));
Fput (Qmodule_not_gpl_compatible, Qerror_message,
build_pure_c_string ("Module is not GPL compatible"));
DEFSYM (Qmissing_module_init_function, "missing-module-init-function");
Fput (Qmissing_module_init_function, Qerror_conditions,
- listn (CONSTYPE_PURE, 3,
- Qmissing_module_init_function, Qmodule_load_failed, Qerror));
+ pure_list (Qmissing_module_init_function, Qmodule_load_failed,
+ Qerror));
Fput (Qmissing_module_init_function, Qerror_message,
build_pure_c_string ("Module does not export an "
"initialization function"));
DEFSYM (Qmodule_init_failed, "module-init-failed");
Fput (Qmodule_init_failed, Qerror_conditions,
- listn (CONSTYPE_PURE, 3,
- Qmodule_init_failed, Qmodule_load_failed, Qerror));
+ pure_list (Qmodule_init_failed, Qmodule_load_failed, Qerror));
Fput (Qmodule_init_failed, Qerror_message,
build_pure_c_string ("Module initialization failed"));
DEFSYM (Qinvalid_arity, "invalid-arity");
- Fput (Qinvalid_arity, Qerror_conditions,
- listn (CONSTYPE_PURE, 2, Qinvalid_arity, Qerror));
+ Fput (Qinvalid_arity, Qerror_conditions, pure_list (Qinvalid_arity, Qerror));
Fput (Qinvalid_arity, Qerror_message,
build_pure_c_string ("Invalid function arity"));
diff --git a/src/emacs-module.h.in b/src/emacs-module.h.in
index 4c5286f6257..009d1583fef 100644
--- a/src/emacs-module.h.in
+++ b/src/emacs-module.h.in
@@ -47,7 +47,7 @@ extern "C" {
#endif
/* Current environment. */
-typedef struct emacs_env_26 emacs_env;
+typedef struct emacs_env_27 emacs_env;
/* Opaque pointer representing an Emacs Lisp value.
BEWARE: Do not assume NULL is a valid value! */
@@ -83,6 +83,16 @@ enum emacs_funcall_exit
emacs_funcall_exit_throw = 2
};
+/* Possible return values for emacs_env.process_input. */
+enum emacs_process_input_result
+{
+ /* Module code may continue */
+ emacs_process_input_continue = 0,
+
+ /* Module code should return control to Emacs as soon as possible. */
+ emacs_process_input_quit = 1
+};
+
struct emacs_env_25
{
@module_env_snippet_25@
@@ -95,6 +105,15 @@ struct emacs_env_26
@module_env_snippet_26@
};
+struct emacs_env_27
+{
+@module_env_snippet_25@
+
+@module_env_snippet_26@
+
+@module_env_snippet_27@
+};
+
/* Every module should define a function as follows. */
extern int emacs_module_init (struct emacs_runtime *ert)
EMACS_NOEXCEPT
diff --git a/src/emacs.c b/src/emacs.c
index 41a93279418..6ed4b0ed87a 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -66,6 +66,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include TERM_HEADER
#endif /* HAVE_WINDOW_SYSTEM */
+#include "bignum.h"
#include "intervals.h"
#include "character.h"
#include "buffer.h"
@@ -83,7 +84,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "charset.h"
#include "composite.h"
#include "dispextern.h"
-#include "regex.h"
+#include "ptr-bounds.h"
+#include "regex-emacs.h"
#include "sheap.h"
#include "syntax.h"
#include "sysselect.h"
@@ -93,10 +95,14 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "getpagesize.h"
#include "gnutls.h"
-#if (defined PROFILING \
- && (defined __FreeBSD__ || defined GNU_LINUX || defined __MINGW32__))
+#ifdef PROFILING
# include <sys/gmon.h>
extern void moncontrol (int mode);
+# ifdef __MINGW32__
+extern unsigned char etext asm ("etext");
+# else
+extern char etext;
+# endif
#endif
#ifdef HAVE_SETLOCALE
@@ -112,6 +118,9 @@ extern void moncontrol (int mode);
#include <sys/resource.h>
#endif
+#include "pdumper.h"
+#include "epaths.h"
+
static const char emacs_version[] = PACKAGE_VERSION;
static const char emacs_copyright[] = COPYRIGHT;
static const char emacs_bugreport[] = PACKAGE_BUGREPORT;
@@ -124,19 +133,9 @@ Lisp_Object empty_unibyte_string, empty_multibyte_string;
Lisp_Object Vlibrary_cache;
#endif
-/* Set after Emacs has started up the first time.
- Prevents reinitialization of the Lisp world and keymaps
- on subsequent starts. */
+struct gflags gflags;
bool initialized;
-#ifndef CANNOT_DUMP
-/* Set to true if this instance of Emacs might dump. */
-# ifndef DOUG_LEA_MALLOC
-static
-# endif
-bool might_dump;
-#endif
-
/* If true, Emacs should not attempt to use a window-specific code,
but instead should use the virtual terminal under which it was started. */
bool inhibit_window_system;
@@ -150,7 +149,7 @@ bool running_asynch_code;
bool display_arg;
#endif
-#if defined GNU_LINUX && !defined CANNOT_DUMP
+#if defined GNU_LINUX && defined HAVE_UNEXEC
/* The gap between BSS end and heap start as far as we can tell. */
static uprintmax_t heap_bss_diff;
#endif
@@ -203,6 +202,9 @@ HANDLE w32_daemon_event;
char **initial_argv;
int initial_argc;
+/* The name of the working directory, or NULL if this info is unavailable. */
+char const *emacs_wd;
+
static void sort_args (int argc, char **argv);
static void syms_of_emacs (void);
@@ -234,6 +236,11 @@ Initialization options:\n\
--module-assertions assert behavior of dynamic modules\n\
",
#endif
+#ifdef HAVE_PDUMPER
+ "\
+--dump-file FILE read dumped state from FILE\n\
+",
+#endif
"\
--no-build-details do not add build details such as time stamps\n\
--no-desktop do not load a saved desktop\n\
@@ -377,7 +384,7 @@ terminate_due_to_signal (int sig, int backtrace_limit)
totally_unblock_input ();
if (sig == SIGTERM || sig == SIGHUP || sig == SIGINT)
- Fkill_emacs (make_number (sig));
+ Fkill_emacs (make_fixnum (sig));
shut_down_emacs (sig, Qnil);
emacs_backtrace (backtrace_limit);
@@ -405,7 +412,7 @@ terminate_due_to_signal (int sig, int backtrace_limit)
/* Code for dealing with Lisp access to the Unix command line. */
static void
-init_cmdargs (int argc, char **argv, int skip_args, char *original_pwd)
+init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd)
{
int i;
Lisp_Object name, dir, handler;
@@ -446,7 +453,7 @@ init_cmdargs (int argc, char **argv, int skip_args, char *original_pwd)
{
Lisp_Object found;
int yes = openp (Vexec_path, Vinvocation_name,
- Vexec_suffixes, &found, make_number (X_OK), false);
+ Vexec_suffixes, &found, make_fixnum (X_OK), false);
if (yes == 1)
{
/* Add /: to the front of the name
@@ -515,8 +522,7 @@ init_cmdargs (int argc, char **argv, int skip_args, char *original_pwd)
etc_exists = Ffile_exists_p (tem);
if (!NILP (etc_exists))
{
- Vinstallation_directory
- = Ffile_name_as_directory (dir);
+ Vinstallation_directory = Ffile_name_as_directory (dir);
break;
}
}
@@ -541,8 +547,7 @@ init_cmdargs (int argc, char **argv, int skip_args, char *original_pwd)
if (!NILP (etc_exists))
{
tem = Fexpand_file_name (build_string (".."), dir);
- Vinstallation_directory
- = Ffile_name_as_directory (tem);
+ Vinstallation_directory = Ffile_name_as_directory (tem);
break;
}
}
@@ -673,6 +678,160 @@ close_output_streams (void)
_exit (EXIT_FAILURE);
}
+#ifdef HAVE_PDUMPER
+
+static const char *
+dump_error_to_string (enum pdumper_load_result result)
+{
+ switch (result)
+ {
+ case PDUMPER_LOAD_SUCCESS:
+ return "success";
+ case PDUMPER_LOAD_OOM:
+ return "out of memory";
+ case PDUMPER_NOT_LOADED:
+ return "not loaded";
+ case PDUMPER_LOAD_FILE_NOT_FOUND:
+ return "could not open file";
+ case PDUMPER_LOAD_BAD_FILE_TYPE:
+ return "not a dump file";
+ case PDUMPER_LOAD_FAILED_DUMP:
+ return "dump file is result of failed dump attempt";
+ case PDUMPER_LOAD_VERSION_MISMATCH:
+ return "not built for this Emacs executable";
+ default:
+ return "generic error";
+ }
+}
+
+static enum pdumper_load_result
+load_pdump (int argc, char **argv)
+{
+ const char *const suffix = ".pdmp";
+ enum pdumper_load_result result;
+#ifdef WINDOWSNT
+ size_t argv0_len;
+#endif
+
+ /* TODO: maybe more thoroughly scrub process environment in order to
+ make this use case (loading a pdumper image in an unexeced emacs)
+ possible? Right now, we assume that things we don't touch are
+ zero-initialized, and in an unexeced Emacs, this assumption
+ doesn't hold. */
+ if (initialized)
+ fatal ("cannot load pdumper image in unexeced Emacs");
+
+ /* Look for an explicitly-specified dump file. */
+ const char *path_exec = PATH_EXEC;
+ char *dump_file = NULL;
+ int skip_args = 0;
+ while (skip_args < argc - 1)
+ {
+ if (argmatch (argv, argc, "-dump-file", "--dump-file", 6,
+ &dump_file, &skip_args)
+ || argmatch (argv, argc, "--", NULL, 2, NULL, &skip_args))
+ break;
+ skip_args++;
+ }
+
+ result = PDUMPER_NOT_LOADED;
+ if (dump_file)
+ {
+ result = pdumper_load (dump_file);
+
+ if (result != PDUMPER_LOAD_SUCCESS)
+ fatal ("could not load dump file \"%s\": %s",
+ dump_file, dump_error_to_string (result));
+ else
+ goto out;
+ }
+
+ /* Look for a dump file in the same directory as the executable; it
+ should have the same basename. */
+
+ dump_file = alloca (strlen (argv[0]) + strlen (suffix) + 1);
+#ifdef DOS_NT
+ /* Remove the .exe extension if present. */
+ argv0_len = strlen (argv[0]);
+ if (argv0_len >= 4 && c_strcasecmp (argv[0] + argv0_len - 4, ".exe") == 0)
+ sprintf (dump_file, "%.*s%s", (int)(argv0_len - 4), argv[0], suffix);
+ else
+#endif
+ sprintf (dump_file, "%s%s", argv[0], suffix);
+
+ result = pdumper_load (dump_file);
+ if (result == PDUMPER_LOAD_SUCCESS)
+ goto out;
+
+ if (result != PDUMPER_LOAD_FILE_NOT_FOUND)
+ fatal ("could not load dump file \"%s\": %s",
+ dump_file, dump_error_to_string (result));
+
+#ifdef WINDOWSNT
+ /* On MS-Windows, PATH_EXEC normally starts with a literal
+ "%emacs_dir%", so it will never work without some tweaking. */
+ path_exec = w32_relocate (path_exec);
+#endif
+
+ /* Look for "emacs.pdmp" in PATH_EXEC. We hardcode "emacs" in
+ "emacs.pdmp" so that the Emacs binary still works if the user
+ copies and renames it. */
+ const char *argv0_base = "emacs";
+ dump_file = alloca (strlen (path_exec)
+ + 1
+ + strlen (argv0_base)
+ + strlen (suffix)
+ + 1);
+ sprintf (dump_file, "%s%c%s%s",
+ path_exec, DIRECTORY_SEP, argv0_base, suffix);
+ result = pdumper_load (dump_file);
+ if (result == PDUMPER_LOAD_SUCCESS)
+ goto out;
+
+ if (result == PDUMPER_LOAD_FILE_NOT_FOUND)
+ {
+ /* Finally, look for basename(argv[0])+".pdmp" in PATH_EXEC.
+ This way, they can rename both the executable and its pdump
+ file in PATH_EXEC, and have several Emacs configurations in
+ the same versioned libexec subdirectory. */
+ char *p, *last_sep = NULL;
+ for (p = argv[0]; *p; p++)
+ {
+ if (IS_DIRECTORY_SEP (*p))
+ last_sep = p;
+ }
+ argv0_base = last_sep ? last_sep + 1 : argv[0];
+ dump_file = alloca (strlen (path_exec)
+ + 1
+ + strlen (argv0_base)
+ + strlen (suffix)
+ + 1);
+#ifdef DOS_NT
+ argv0_len = strlen (argv0_base);
+ if (argv0_len >= 4
+ && c_strcasecmp (argv0_base + argv0_len - 4, ".exe") == 0)
+ sprintf (dump_file, "%s%c%.*s%s", path_exec, DIRECTORY_SEP,
+ (int)(argv0_len - 4), argv0_base, suffix);
+ else
+#endif
+ sprintf (dump_file, "%s%c%s%s",
+ path_exec, DIRECTORY_SEP, argv0_base, suffix);
+ result = pdumper_load (dump_file);
+ }
+
+ if (result != PDUMPER_LOAD_SUCCESS)
+ {
+ if (result != PDUMPER_LOAD_FILE_NOT_FOUND)
+ fatal ("could not load dump file \"%s\": %s",
+ dump_file, dump_error_to_string (result));
+ dump_file = NULL;
+ }
+
+ out:
+ return result;
+}
+#endif /* HAVE_PDUMPER */
+
/* ARGSUSED */
int
main (int argc, char **argv)
@@ -682,8 +841,6 @@ main (int argc, char **argv)
void *stack_bottom_variable;
bool do_initial_setlocale;
- bool dumping;
- int skip_args = 0;
bool no_loadup = false;
char *junk = 0;
char *dname_arg = 0;
@@ -693,56 +850,99 @@ main (int argc, char **argv)
char *ch_to_dir = 0;
/* If we use --chdir, this records the original directory. */
- char *original_pwd = 0;
+ char const *original_pwd = 0;
/* Record (approximately) where the stack begins. */
stack_bottom = (char *) &stack_bottom_variable;
-#ifndef CANNOT_DUMP
- dumping = !initialized && (strcmp (argv[argc - 1], "dump") == 0
- || strcmp (argv[argc - 1], "bootstrap") == 0);
-#else
- dumping = false;
+ const char *dump_mode = NULL;
+ int skip_args = 0;
+ char *temacs = NULL;
+ while (skip_args < argc - 1)
+ {
+ if (argmatch (argv, argc, "-temacs", "--temacs", 8, &temacs, &skip_args)
+ || argmatch (argv, argc, "--", NULL, 2, NULL, &skip_args))
+ break;
+ skip_args++;
+ }
+#ifdef HAVE_PDUMPER
+ bool attempt_load_pdump = false;
#endif
- /* True if address randomization interferes with memory allocation. */
-# ifdef __PPC64__
- bool disable_aslr = true;
-# else
- bool disable_aslr = dumping;
-# endif
-
- if (disable_aslr && disable_address_randomization ()
- && !getenv ("EMACS_HEAP_EXEC"))
+ /* Look for this argument first, before any heap allocation, so we
+ can set heap flags properly if we're going to unexec. */
+ if (!initialized && temacs)
{
- /* Set this so the personality will be reverted before execs
- after this one, and to work around an re-exec loop on buggy
- kernels (Bug#32083). */
- xputenv ("EMACS_HEAP_EXEC=true");
-
- /* Address randomization was enabled, but is now disabled.
- Re-execute Emacs to get a clean slate. */
- execvp (argv[0], argv);
-
- /* If the exec fails, warn and then try anyway. */
- perror (argv[0]);
+#ifdef HAVE_UNEXEC
+ if (strcmp (temacs, "dump") == 0 ||
+ strcmp (temacs, "bootstrap") == 0)
+ gflags.will_dump_with_unexec_ = true;
+#endif
+#ifdef HAVE_PDUMPER
+ if (strcmp (temacs, "pdump") == 0 ||
+ strcmp (temacs, "pbootstrap") == 0)
+ gflags.will_dump_with_pdumper_ = true;
+#endif
+#if defined HAVE_PDUMPER || defined HAVE_UNEXEC
+ if (strcmp (temacs, "bootstrap") == 0 ||
+ strcmp (temacs, "pbootstrap") == 0)
+ gflags.will_bootstrap_ = true;
+ gflags.will_dump_ =
+ will_dump_with_pdumper_p () ||
+ will_dump_with_unexec_p ();
+ if (will_dump_p ())
+ dump_mode = temacs;
+#endif
+ if (!dump_mode)
+ fatal ("Invalid temacs mode '%s'", temacs);
+ }
+ else if (temacs)
+ {
+ fatal ("--temacs not supported for unexeced emacs");
+ }
+ else
+ {
+ eassert (!temacs);
+#ifndef HAVE_UNEXEC
+ eassert (!initialized);
+#endif
+#ifdef HAVE_PDUMPER
+ if (!initialized)
+ attempt_load_pdump = true;
+#endif
}
-#ifndef CANNOT_DUMP
- might_dump = !initialized;
+#ifdef HAVE_UNEXEC
+ if (!will_dump_with_unexec_p ())
+ gflags.will_not_unexec_ = true;
+#endif
-# ifdef GNU_LINUX
- if (!initialized)
+#ifdef WINDOWSNT
+ /* Grab our malloc arena space now, before anything important
+ happens. This relies on the static heap being needed only in
+ temacs and only if we are going to dump with unexec. */
+ bool use_dynamic_heap = true;
+ if (temacs)
{
- char *heap_start = my_heap_start ();
- heap_bss_diff = heap_start - max (my_endbss, my_endbss_static);
+ char *temacs_str = NULL, *p;
+ for (p = argv[0]; (p = strstr (p, "temacs")) != NULL; p++)
+ temacs_str = p;
+ if (temacs_str != NULL
+ && (temacs_str == argv[0] || IS_DIRECTORY_SEP (temacs_str[-1])))
+ {
+ /* Note that gflags are set at this point only if we have been
+ called with the --temacs=METHOD option. We assume here that
+ temacs is always called that way, otherwise the functions
+ that rely on gflags, like will_dump_with_pdumper_p below,
+ will not do their job. */
+ use_dynamic_heap = will_dump_with_pdumper_p ();
+ }
}
-# endif
+ init_heap (use_dynamic_heap);
#endif
-
#if defined WINDOWSNT || defined HAVE_NTGUI
/* Set global variables used to detect Windows version. Do this as
- early as possible. (unexw32.c calls this function as well, but
+ early as possible. (w32proc.c calls this function as well, but
the additional call here is harmless.) */
cache_system_info ();
#ifdef WINDOWSNT
@@ -753,17 +953,35 @@ main (int argc, char **argv)
/* Initialize the codepage for file names, needed to decode
non-ASCII file names during startup. */
w32_init_file_name_codepage ();
+ /* Initialize the startup directory, needed for emacs_wd below. */
+ w32_init_current_directory ();
#endif
w32_init_main_thread ();
#endif
+#ifdef HAVE_PDUMPER
+ if (attempt_load_pdump)
+ load_pdump (argc, argv);
+#endif
+
+ argc = maybe_disable_address_randomization (
+ will_dump_with_unexec_p (), argc, argv);
+
+#if defined GNU_LINUX && defined HAVE_UNEXEC
+ if (!initialized)
+ {
+ char *heap_start = my_heap_start ();
+ heap_bss_diff = heap_start - max (my_endbss, my_endbss_static);
+ }
+#endif
+
#ifdef RUN_TIME_REMAP
if (initialized)
run_time_remap (argv[0]);
#endif
/* If using unexmacosx.c (set by s/darwin.h), we must do this. */
-#if defined DARWIN_OS && !defined CANNOT_DUMP
+#if defined DARWIN_OS && defined HAVE_UNEXEC
if (!initialized)
unexec_init_emacs_zone ();
#endif
@@ -775,6 +993,7 @@ main (int argc, char **argv)
argc = 0;
while (argv[argc]) argc++;
+ skip_args = 0;
if (argmatch (argv, argc, "-version", "--version", 3, NULL, &skip_args))
{
const char *version, *copyright;
@@ -814,6 +1033,12 @@ main (int argc, char **argv)
exit (0);
}
+ emacs_wd = emacs_get_current_dir_name ();
+#ifdef HAVE_PDUMPER
+ if (dumped_with_pdumper_p ())
+ pdumper_record_wd (emacs_wd);
+#endif
+
if (argmatch (argv, argc, "-chdir", "--chdir", 4, &ch_to_dir, &skip_args))
{
#ifdef WINDOWSNT
@@ -824,13 +1049,18 @@ main (int argc, char **argv)
filename_from_ansi (ch_to_dir, newdir);
ch_to_dir = newdir;
#endif
- original_pwd = emacs_get_current_dir_name ();
if (chdir (ch_to_dir) != 0)
{
fprintf (stderr, "%s: Can't chdir to %s: %s\n",
argv[0], ch_to_dir, strerror (errno));
exit (1);
}
+ original_pwd = emacs_wd;
+#ifdef WINDOWSNT
+ /* Reinitialize Emacs's notion of the startup directory. */
+ w32_init_current_directory ();
+#endif
+ emacs_wd = emacs_get_current_dir_name ();
}
#if defined (HAVE_SETRLIMIT) && defined (RLIMIT_STACK) && !defined (CYGWIN)
@@ -846,9 +1076,9 @@ main (int argc, char **argv)
{
rlim_t lim = rlim.rlim_cur;
- /* Approximate the amount regex.c needs per unit of
+ /* Approximate the amount regex-emacs.c needs per unit of
emacs_re_max_failures, then add 33% to cover the size of the
- smaller stacks that regex.c successively allocates and
+ smaller stacks that regex-emacs.c successively allocates and
discards on its way to the maximum. */
int min_ratio = 20 * sizeof (char *);
int ratio = min_ratio + min_ratio / 3;
@@ -858,10 +1088,7 @@ main (int argc, char **argv)
frames. */
int extra = (30 * 1000) * 50;
- bool try_to_grow_stack = true;
-#ifndef CANNOT_DUMP
- try_to_grow_stack = !noninteractive || initialized;
-#endif
+ bool try_to_grow_stack = !noninteractive || initialized;
if (try_to_grow_stack)
{
@@ -888,12 +1115,13 @@ main (int argc, char **argv)
lim = newlim;
}
}
- /* If the stack is big enough, let regex.c more of it before
- falling back to heap allocation. */
+ /* If the stack is big enough, let regex-emacs.c use more of it
+ before falling back to heap allocation. */
if (lim < extra)
- lim = extra; /* avoid wrap-around in unsigned subtraction */
- emacs_re_safe_alloca =
- max (min (lim - extra, SIZE_MAX) * (min_ratio / ratio), MAX_ALLOCA);
+ lim = extra; /* avoid wrap-around in unsigned subtraction */
+ ptrdiff_t max_failures
+ = min (lim - extra, min (PTRDIFF_MAX, SIZE_MAX)) / ratio;
+ emacs_re_safe_alloca = max (max_failures * min_ratio, MAX_ALLOCA);
}
#endif /* HAVE_SETRLIMIT and RLIMIT_STACK and not CYGWIN */
@@ -1191,17 +1419,15 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
#if defined HAVE_PTHREAD && !defined SYSTEM_MALLOC \
&& !defined DOUG_LEA_MALLOC && !defined HYBRID_MALLOC
-# ifndef CANNOT_DUMP
/* Do not make gmalloc thread-safe when creating bootstrap-emacs, as
that causes an infinite recursive loop with FreeBSD. See
Bug#14569. The part of this bug involving Cygwin is no longer
relevant, now that Cygwin defines HYBRID_MALLOC. */
- if (!noninteractive || initialized)
-# endif
+ if (!noninteractive || !will_dump_p ())
malloc_enable_thread ();
#endif
- init_signals (dumping);
+ init_signals ();
noninteractive1 = noninteractive;
@@ -1211,7 +1437,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
{
init_alloc_once ();
init_threads_once ();
- init_obarray ();
+ init_obarray_once ();
init_eval_once ();
init_charset_once ();
init_coding_once ();
@@ -1233,7 +1459,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
/* Call syms_of_keyboard before init_window_once because
keyboard sets up symbols that include some face names that
the X support will want to use. This can happen when
- CANNOT_DUMP is defined. */
+ Emacs starts up from scratch (e.g., temacs). */
syms_of_keyboard ();
/* Called before syms_of_fileio, because it sets up Qerror_condition. */
@@ -1249,7 +1475,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
/* Before init_window_once, because it sets up the
Vcoding_system_hash_table. */
syms_of_coding (); /* This should be after syms_of_fileio. */
-
+ init_frame_once (); /* Before init_window_once. */
init_window_once (); /* Init the window system. */
#ifdef HAVE_WINDOW_SYSTEM
init_fringe_once (); /* Swap bitmaps if necessary. */
@@ -1257,6 +1483,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
}
init_alloc ();
+ init_bignum ();
init_threads ();
if (do_initial_setlocale)
@@ -1271,6 +1498,15 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
running_asynch_code = 0;
init_random ();
+#ifdef HAVE_PDUMPER
+ if (dumped_with_pdumper_p ())
+ init_xfaces ();
+#endif
+
+#if defined HAVE_JSON && !defined WINDOWSNT
+ init_json ();
+#endif
+
no_loadup
= argmatch (argv, argc, "-nl", "--no-loadup", 6, NULL, &skip_args);
@@ -1284,7 +1520,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
bool module_assertions
= argmatch (argv, argc, "-module-assertions", "--module-assertions", 15,
NULL, &skip_args);
- if (dumping && module_assertions)
+ if (will_dump_p () && module_assertions)
{
fputs ("Module assertions are not supported during dumping\n", stderr);
exit (1);
@@ -1303,21 +1539,21 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
{
#ifdef NS_IMPL_COCOA
/* Started from GUI? */
- /* FIXME: Do the right thing if getenv returns NULL, or if
+ /* FIXME: Do the right thing if get_homedir returns "", or if
chdir fails. */
if (! inhibit_window_system && ! isatty (STDIN_FILENO) && ! ch_to_dir)
- chdir (getenv ("HOME"));
+ chdir (get_homedir ());
if (skip_args < argc)
{
if (!strncmp (argv[skip_args], "-psn", 4))
{
skip_args += 1;
- if (! ch_to_dir) chdir (getenv ("HOME"));
+ if (! ch_to_dir) chdir (get_homedir ());
}
else if (skip_args+1 < argc && !strncmp (argv[skip_args+1], "-psn", 4))
{
skip_args += 2;
- if (! ch_to_dir) chdir (getenv ("HOME"));
+ if (! ch_to_dir) chdir (get_homedir ());
}
}
#endif /* COCOA */
@@ -1421,7 +1657,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
/* egetenv is a pretty low-level facility, which may get called in
many circumstances; it seems flimsy to put off initializing it
until calling init_callproc. Do not do it when dumping. */
- if (! dumping)
+ if (!will_dump_p ())
set_initial_environment ();
#ifdef WINDOWSNT
@@ -1435,7 +1671,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
variables from the parent process without modifications from
Emacs. */
init_environment (argv);
- init_ntproc (dumping); /* must precede init_editfns. */
+ init_ntproc (will_dump_p ()); /* must precede init_editfns. */
#endif
/* AIX crashes are reported in system versions 3.2.3 and 3.2.4
@@ -1447,7 +1683,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
#endif
/* Init buffer storage and default directory of main buffer. */
- init_buffer (initialized);
+ init_buffer ();
init_callproc_1 (); /* Must precede init_cmdargs and init_sys_modes. */
@@ -1508,6 +1744,8 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
syms_of_minibuf ();
syms_of_process ();
syms_of_search ();
+ syms_of_sysdep ();
+ syms_of_timefns ();
syms_of_frame ();
syms_of_syntax ();
syms_of_terminal ();
@@ -1551,9 +1789,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
#endif
#endif /* HAVE_X_WINDOWS */
-#ifdef HAVE_LIBXML2
syms_of_xml ();
-#endif
#ifdef HAVE_LCMS2
syms_of_lcms2 ();
@@ -1572,6 +1808,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
syms_of_fontset ();
#endif /* HAVE_NTGUI */
+#if defined HAVE_NTGUI || defined CYGWIN
+ syms_of_w32cygwinx ();
+#endif
+
#if defined WINDOWSNT || defined HAVE_NTGUI
syms_of_w32select ();
#endif
@@ -1618,6 +1858,11 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
syms_of_threads ();
syms_of_profiler ();
+ syms_of_pdumper ();
+
+#ifdef HAVE_JSON
+ syms_of_json ();
+#endif
keys_of_casefiddle ();
keys_of_cmds ();
@@ -1643,9 +1888,11 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
init_charset ();
- /* This calls putenv and so must precede init_process_emacs. Also,
- it sets Voperating_system_release, which init_process_emacs uses. */
- init_editfns (dumping);
+ /* This calls putenv and so must precede init_process_emacs. */
+ init_timefns ();
+
+ /* This sets Voperating_system_release, which init_process_emacs uses. */
+ init_editfns ();
/* These two call putenv. */
#ifdef HAVE_DBUS
@@ -1661,10 +1908,9 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
init_process_emacs (sockfd);
init_keyboard (); /* This too must precede init_sys_modes. */
- if (!noninteractive)
- init_display (); /* Determine terminal type. Calls init_sys_modes. */
+ init_display (); /* Determine terminal type. Calls init_sys_modes. */
#if HAVE_W32NOTIFY
- else
+ if (noninteractive)
init_crit (); /* w32notify.c needs this in batch mode. */
#endif /* HAVE_W32NOTIFY */
init_xdisp ();
@@ -1698,25 +1944,20 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
GNU/Linux and MinGW. It might work on some other systems too.
Give it a try and tell us if it works on your system. To compile
for profiling, use the configure option --enable-profiling. */
-#if defined (__FreeBSD__) || defined (GNU_LINUX) || defined (__MINGW32__)
#ifdef PROFILING
if (initialized)
{
-#ifdef __MINGW32__
- extern unsigned char etext asm ("etext");
-#else
- extern char etext;
-#endif
-
atexit (_mcleanup);
monstartup ((uintptr_t) __executable_start, (uintptr_t) &etext);
}
else
moncontrol (0);
#endif
-#endif
- initialized = 1;
+ initialized = true;
+
+ if (dump_mode)
+ Vdump_mode = build_string (dump_mode);
/* Enter editor command loop. This never returns. */
Frecursive_edit ();
@@ -1806,6 +2047,12 @@ static const struct standard_args standard_args[] =
{ "-color", "--color", 5, 0},
{ "-no-splash", "--no-splash", 3, 0 },
{ "-no-desktop", "--no-desktop", 3, 0 },
+ /* The following two must be just above the file-name args, to get
+ them out of our way, but without mixing them with file names. */
+ { "-temacs", "--temacs", 1, 1 },
+#ifdef HAVE_PDUMPER
+ { "-dump-file", "--dump-file", 1, 1 },
+#endif
#ifdef HAVE_NS
{ "-NSAutoLaunch", 0, 5, 1 },
{ "-NXAutoLaunch", 0, 5, 1 },
@@ -2019,6 +2266,10 @@ all of which are called before Emacs is actually killed. */
{
int exit_code;
+#ifdef HAVE_LIBSYSTEMD
+ sd_notify(0, "STOPPING=1");
+#endif /* HAVE_LIBSYSTEMD */
+
/* Fsignal calls emacs_abort () if it sees that waiting_for_input is
set. */
waiting_for_input = 0;
@@ -2048,10 +2299,10 @@ all of which are called before Emacs is actually killed. */
unlink (SSDATA (listfile));
}
- if (INTEGERP (arg))
- exit_code = (XINT (arg) < 0
- ? XINT (arg) | INT_MIN
- : XINT (arg) & INT_MAX);
+ if (FIXNUMP (arg))
+ exit_code = (XFIXNUM (arg) < 0
+ ? XFIXNUM (arg) | INT_MIN
+ : XFIXNUM (arg) & INT_MAX);
else
exit_code = EXIT_SUCCESS;
exit (exit_code);
@@ -2141,7 +2392,7 @@ shut_down_emacs (int sig, Lisp_Object stuff)
-#ifndef CANNOT_DUMP
+#ifdef HAVE_UNEXEC
#include "unexec.h"
@@ -2162,13 +2413,16 @@ You must run Emacs in batch mode in order to dump it. */)
if (! noninteractive)
error ("Dumping Emacs works only in batch mode");
- if (!might_dump)
- error ("Emacs can be dumped only once");
+ if (dumped_with_unexec_p ())
+ error ("Emacs can be dumped using unexec only once");
+
+ if (definitely_will_not_unexec_p ())
+ error ("This Emacs instance was not started in temacs mode");
-#if defined GNU_LINUX && !defined CANNOT_DUMP
+# if defined GNU_LINUX && defined HAVE_UNEXEC
/* Warn if the gap between BSS end and heap start is larger than this. */
-# define MAX_HEAP_BSS_DIFF (1024*1024)
+# define MAX_HEAP_BSS_DIFF (1024 * 1024)
if (heap_bss_diff > MAX_HEAP_BSS_DIFF)
{
@@ -2181,7 +2435,7 @@ You must run Emacs in batch mode in order to dump it. */)
fprintf (stderr, "exec-shield in etc/PROBLEMS for more information.\n");
fprintf (stderr, "**************************************************\n");
}
-#endif /* GNU_LINUX */
+# endif
/* Bind `command-line-processed' to nil before dumping,
so that the dumped Emacs will process its command line
@@ -2205,7 +2459,7 @@ You must run Emacs in batch mode in order to dump it. */)
tem = Vpurify_flag;
Vpurify_flag = Qnil;
-#ifdef HYBRID_MALLOC
+# ifdef HYBRID_MALLOC
{
static char const fmt[] = "%d of %d static heap bytes used";
char buf[sizeof fmt + 2 * (INT_STRLEN_BOUND (int) - 2)];
@@ -2214,18 +2468,21 @@ You must run Emacs in batch mode in order to dump it. */)
/* Don't log messages, because at this point buffers cannot be created. */
message1_nolog (buf);
}
-#endif
+# endif
fflush_unlocked (stdout);
/* Tell malloc where start of impure now is. */
/* Also arrange for warnings when nearly out of space. */
-#if !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC
-#ifndef WINDOWSNT
+# if !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC && !defined WINDOWSNT
/* On Windows, this was done before dumping, and that once suffices.
Meanwhile, my_edata is not valid on Windows. */
memory_warnings (my_edata, malloc_warning);
-#endif /* not WINDOWSNT */
-#endif /* not SYSTEM_MALLOC and not HYBRID_MALLOC */
+# endif
+
+ struct gflags old_gflags = gflags;
+ gflags.will_dump_ = false;
+ gflags.will_dump_with_unexec_ = false;
+ gflags.dumped_with_unexec_ = true;
alloc_unexec_pre ();
@@ -2233,19 +2490,22 @@ You must run Emacs in batch mode in order to dump it. */)
alloc_unexec_post ();
-#ifdef WINDOWSNT
+ gflags = old_gflags;
+
+# ifdef WINDOWSNT
Vlibrary_cache = Qnil;
-#endif
-#ifdef HAVE_WINDOW_SYSTEM
+# endif
+# ifdef HAVE_WINDOW_SYSTEM
reset_image_types ();
-#endif
+# endif
Vpurify_flag = tem;
return unbind_to (count, Qnil);
}
-#endif /* not CANNOT_DUMP */
+#endif
+
#if HAVE_SETLOCALE
/* Recover from setlocale (LC_ALL, ""). */
@@ -2384,7 +2644,7 @@ decode_env_path (const char *evarname, const char *defalt, bool empty)
}
}
else if (cnv_result != 0 && d > path_utf8)
- d[-1] = '\0'; /* remove last semi-colon and null-terminate PATH */
+ d[-1] = '\0'; /* remove last semi-colon and NUL-terminate PATH */
} while (q);
path_copy = path_utf8;
#else /* MSDOS */
@@ -2412,7 +2672,7 @@ decode_env_path (const char *evarname, const char *defalt, bool empty)
&& strncmp (path, emacs_dir_env, emacs_dir_len) == 0)
element = Fexpand_file_name (Fsubstring
(element,
- make_number (emacs_dir_len),
+ make_fixnum (emacs_dir_len),
Qnil),
build_unibyte_string (emacs_dir));
#endif
@@ -2479,6 +2739,13 @@ from the parent process and its tty file descriptors. */)
error ("This function can only be called after loading the init files");
#ifndef WINDOWSNT
+ if (daemon_type == 1)
+ {
+#ifdef HAVE_LIBSYSTEMD
+ sd_notify(0, "READY=1");
+#endif /* HAVE_LIBSYSTEMD */
+ }
+
if (daemon_type == 2)
{
int nfd;
@@ -2526,7 +2793,7 @@ syms_of_emacs (void)
DEFSYM (Qkill_emacs, "kill-emacs");
DEFSYM (Qkill_emacs_hook, "kill-emacs-hook");
-#ifndef CANNOT_DUMP
+#ifdef HAVE_UNEXEC
defsubr (&Sdump_emacs);
#endif
@@ -2574,7 +2841,7 @@ Don't rely on it for testing whether a feature you want to use is available. */
Vsystem_configuration_features = build_string (EMACS_CONFIG_FEATURES);
DEFVAR_BOOL ("noninteractive", noninteractive1,
- doc: /* Non-nil means Emacs is running without interactive terminal. */);
+ doc: /* Non-nil means Emacs is running without interactive terminal. */);
DEFVAR_LISP ("kill-emacs-hook", Vkill_emacs_hook,
doc: /* Hook run when `kill-emacs' is called.
@@ -2659,6 +2926,9 @@ component .BUILD is present. This is now stored separately in
doc: /* Address of mailing list for GNU Emacs bugs. */);
Vreport_emacs_bug_address = build_string (emacs_bugreport);
+ DEFVAR_LISP ("dump-mode", Vdump_mode,
+ doc: /* Non-nil when Emacs is dumping itself. */);
+
DEFVAR_LISP ("dynamic-library-alist", Vdynamic_library_alist,
doc: /* Alist of dynamic libraries vs external files implementing them.
Each element is a list (LIBRARY FILE...), where the car is a symbol
diff --git a/src/eval.c b/src/eval.c
index 0dc8639a8d4..e9f118c5cb9 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -29,6 +29,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "keyboard.h"
#include "dispextern.h"
#include "buffer.h"
+#include "pdumper.h"
/* CACHEABLE is ordinarily nothing, except it is 'volatile' if
necessary to cajole GCC into not warning incorrectly that a
@@ -39,10 +40,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
# define CACHEABLE /* empty */
#endif
-/* Chain of condition and catch handlers currently in effect. */
-
-/* struct handler *handlerlist; */
-
/* Non-nil means record all fset's and provide's, to be undone
if the file being autoloaded is not fully loaded.
They are recorded by being consed onto the front of Vautoload_queue:
@@ -55,26 +52,6 @@ Lisp_Object Vautoload_queue;
is shutting down. */
Lisp_Object Vrun_hooks;
-/* The commented-out variables below are macros defined in thread.h. */
-
-/* Current number of specbindings allocated in specpdl, not counting
- the dummy entry specpdl[-1]. */
-
-/* ptrdiff_t specpdl_size; */
-
-/* Pointer to beginning of specpdl. A dummy entry specpdl[-1] exists
- only so that its address can be taken. */
-
-/* union specbinding *specpdl; */
-
-/* Pointer to first unused element in specpdl. */
-
-/* union specbinding *specpdl_ptr; */
-
-/* Depth in Lisp evaluations and function calls. */
-
-/* static EMACS_INT lisp_eval_depth; */
-
/* The value of num_nonmacro_input_events as of the last time we
started to enter the debugger. If we decide to enter the debugger
again when this is still equal to num_nonmacro_input_events, then we
@@ -82,17 +59,13 @@ Lisp_Object Vrun_hooks;
signal the error instead of entering an infinite loop of debugger
invocations. */
-static EMACS_INT when_entered_debugger;
+static intmax_t when_entered_debugger;
/* The function from which the last `signal' was called. Set in
Fsignal. */
/* FIXME: We should probably get rid of this! */
Lisp_Object Vsignaling_function;
-/* If non-nil, Lisp code must not be run since some part of Emacs is in
- an inconsistent state. Currently unused. */
-Lisp_Object inhibit_lisp_code;
-
/* These would ordinarily be static, but they need to be visible to GDB. */
bool backtrace_p (union specbinding *) EXTERNALLY_VISIBLE;
Lisp_Object *backtrace_args (union specbinding *) EXTERNALLY_VISIBLE;
@@ -202,17 +175,36 @@ set_backtrace_debug_on_exit (union specbinding *pdl, bool doe)
bool
backtrace_p (union specbinding *pdl)
-{ return pdl >= specpdl; }
+{ return specpdl ? pdl >= specpdl : false; }
+
+static bool
+backtrace_thread_p (struct thread_state *tstate, union specbinding *pdl)
+{ return pdl >= tstate->m_specpdl; }
union specbinding *
backtrace_top (void)
{
+ /* This is so "xbacktrace" doesn't crash in pdumped Emacs if they
+ invoke the command before init_eval_once_for_pdumper initializes
+ specpdl machinery. See also backtrace_p above. */
+ if (!specpdl)
+ return NULL;
+
union specbinding *pdl = specpdl_ptr - 1;
while (backtrace_p (pdl) && pdl->kind != SPECPDL_BACKTRACE)
pdl--;
return pdl;
}
+static union specbinding *
+backtrace_thread_top (struct thread_state *tstate)
+{
+ union specbinding *pdl = tstate->m_specpdl_ptr - 1;
+ while (backtrace_thread_p (tstate, pdl) && pdl->kind != SPECPDL_BACKTRACE)
+ pdl--;
+ return pdl;
+}
+
union specbinding *
backtrace_next (union specbinding *pdl)
{
@@ -222,21 +214,35 @@ backtrace_next (union specbinding *pdl)
return pdl;
}
+static void init_eval_once_for_pdumper (void);
+
+static union specbinding *
+backtrace_thread_next (struct thread_state *tstate, union specbinding *pdl)
+{
+ pdl--;
+ while (backtrace_thread_p (tstate, pdl) && pdl->kind != SPECPDL_BACKTRACE)
+ pdl--;
+ return pdl;
+}
+
void
init_eval_once (void)
{
- enum { size = 50 };
- union specbinding *pdlvec = xmalloc ((size + 1) * sizeof *specpdl);
- specpdl_size = size;
- specpdl = specpdl_ptr = pdlvec + 1;
/* Don't forget to update docs (lispref node "Local Variables"). */
max_specpdl_size = 1300; /* 1000 is not enough for CEDET's c-by.el. */
max_lisp_eval_depth = 800;
-
Vrun_hooks = Qnil;
+ pdumper_do_now_and_after_load (init_eval_once_for_pdumper);
}
-/* static struct handler handlerlist_sentinel; */
+static void
+init_eval_once_for_pdumper (void)
+{
+ enum { size = 50 };
+ union specbinding *pdlvec = malloc ((size + 1) * sizeof *specpdl);
+ specpdl_size = size;
+ specpdl = specpdl_ptr = pdlvec + 1;
+}
void
init_eval (void)
@@ -259,13 +265,23 @@ init_eval (void)
when_entered_debugger = -1;
}
+/* Ensure that *M is at least A + B if possible, or is its maximum
+ value otherwise. */
+
+static void
+max_ensure_room (intmax_t *m, intmax_t a, intmax_t b)
+{
+ intmax_t sum = INT_ADD_WRAPV (a, b, &sum) ? INTMAX_MAX : sum;
+ *m = max (*m, sum);
+}
+
/* Unwind-protect function used by call_debugger. */
static void
restore_stack_limits (Lisp_Object data)
{
- max_specpdl_size = XINT (XCAR (data));
- max_lisp_eval_depth = XINT (XCDR (data));
+ integer_to_intmax (XCAR (data), &max_specpdl_size);
+ integer_to_intmax (XCDR (data), &max_lisp_eval_depth);
}
static void grow_specpdl (void);
@@ -278,21 +294,19 @@ call_debugger (Lisp_Object arg)
bool debug_while_redisplaying;
ptrdiff_t count = SPECPDL_INDEX ();
Lisp_Object val;
- EMACS_INT old_depth = max_lisp_eval_depth;
+ intmax_t old_depth = max_lisp_eval_depth;
/* Do not allow max_specpdl_size less than actual depth (Bug#16603). */
- EMACS_INT old_max = max (max_specpdl_size, count);
+ intmax_t old_max = max (max_specpdl_size, count);
/* The previous value of 40 is too small now that the debugger
prints using cl-prin1 instead of prin1. Printing lists nested 8
deep (which is the value of print-level used in the debugger)
currently requires 77 additional frames. See bug#31919. */
- if (lisp_eval_depth + 100 > max_lisp_eval_depth)
- max_lisp_eval_depth = lisp_eval_depth + 100;
+ max_ensure_room (&max_lisp_eval_depth, lisp_eval_depth, 100);
/* While debugging Bug#16603, previous value of 100 was found
too small to avoid specpdl overflow in the debugger itself. */
- if (max_specpdl_size - 200 < count)
- max_specpdl_size = count + 200;
+ max_ensure_room (&max_specpdl_size, count, 200);
if (old_max == count)
{
@@ -303,8 +317,7 @@ call_debugger (Lisp_Object arg)
/* Restore limits after leaving the debugger. */
record_unwind_protect (restore_stack_limits,
- Fcons (make_number (old_max),
- make_number (old_depth)));
+ Fcons (make_int (old_max), make_int (old_depth)));
#ifdef HAVE_WINDOW_SYSTEM
if (display_hourglass_p)
@@ -482,17 +495,6 @@ usage: (prog1 FIRST BODY...) */)
return val;
}
-DEFUN ("prog2", Fprog2, Sprog2, 2, UNEVALLED, 0,
- doc: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
-The value of FORM2 is saved during the evaluation of the
-remaining args, whose values are discarded.
-usage: (prog2 FORM1 FORM2 BODY...) */)
- (Lisp_Object args)
-{
- eval_sub (XCAR (args));
- return Fprog1 (XCDR (args));
-}
-
DEFUN ("setq", Fsetq, Ssetq, 0, UNEVALLED, 0,
doc: /* Set each SYM to the value of its VAL.
The symbols SYM are variables; they are literal (not evaluated).
@@ -511,7 +513,7 @@ usage: (setq [SYM VAL]...) */)
Lisp_Object sym = XCAR (tail), lex_binding;
tail = XCDR (tail);
if (!CONSP (tail))
- xsignal2 (Qwrong_number_of_arguments, Qsetq, make_number (nargs + 1));
+ xsignal2 (Qwrong_number_of_arguments, Qsetq, make_fixnum (nargs + 1));
Lisp_Object arg = XCAR (tail);
tail = XCDR (tail);
val = eval_sub (arg);
@@ -627,6 +629,16 @@ The return value is BASE-VARIABLE. */)
if (NILP (Fboundp (base_variable)))
set_internal (base_variable, find_symbol_value (new_alias),
Qnil, SET_INTERNAL_BIND);
+ else if (!NILP (Fboundp (new_alias))
+ && !EQ (find_symbol_value (new_alias),
+ find_symbol_value (base_variable)))
+ call2 (intern ("display-warning"),
+ list3 (intern ("defvaralias"), intern ("losing-value"), new_alias),
+ CALLN (Fformat_message,
+ build_string
+ ("Overwriting value of `%s' by aliasing to `%s'"),
+ new_alias, base_variable));
+
{
union specbinding *p;
@@ -667,8 +679,10 @@ default_toplevel_binding (Lisp_Object symbol)
break;
case SPECPDL_UNWIND:
+ case SPECPDL_UNWIND_ARRAY:
case SPECPDL_UNWIND_PTR:
case SPECPDL_UNWIND_INT:
+ case SPECPDL_UNWIND_EXCURSION:
case SPECPDL_UNWIND_VOID:
case SPECPDL_BACKTRACE:
case SPECPDL_LET_LOCAL:
@@ -741,6 +755,8 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
sym = XCAR (args);
tail = XCDR (args);
+ CHECK_SYMBOL (sym);
+
if (!NILP (tail))
{
if (!NILP (XCDR (tail)) && !NILP (XCDR (XCDR (tail))))
@@ -915,16 +931,15 @@ usage: (let VARLIST BODY...) */)
(Lisp_Object args)
{
Lisp_Object *temps, tem, lexenv;
- Lisp_Object elt, varlist;
+ Lisp_Object elt;
ptrdiff_t count = SPECPDL_INDEX ();
ptrdiff_t argnum;
USE_SAFE_ALLOCA;
- varlist = XCAR (args);
- CHECK_LIST (varlist);
+ Lisp_Object varlist = XCAR (args);
/* Make space to hold the values to give the bound variables. */
- EMACS_INT varlist_len = XFASTINT (Flength (varlist));
+ EMACS_INT varlist_len = list_length (varlist);
SAFE_ALLOCA_LISP (temps, varlist_len);
ptrdiff_t nvars = varlist_len;
@@ -971,8 +986,7 @@ usage: (let VARLIST BODY...) */)
specbind (Qinternal_interpreter_environment, lexenv);
elt = Fprogn (XCDR (args));
- SAFE_FREE ();
- return unbind_to (count, elt);
+ return SAFE_FREE_UNBIND_TO (count, elt);
}
DEFUN ("while", Fwhile, Swhile, 1, UNEVALLED, 0,
@@ -1202,9 +1216,11 @@ Executes BODYFORM and returns its value if no error happens.
Each element of HANDLERS looks like (CONDITION-NAME BODY...)
where the BODY is made of Lisp expressions.
-A handler is applicable to an error
-if CONDITION-NAME is one of the error's condition names.
-If an error happens, the first applicable handler is run.
+A handler is applicable to an error if CONDITION-NAME is one of the
+error's condition names. Handlers may also apply when non-error
+symbols are signaled (e.g., `quit'). A CONDITION-NAME of t applies to
+any symbol, including non-error symbols. If multiple handlers are
+applicable, only the first one runs.
The car of a handler may be a list of condition names instead of a
single condition name; then it handles all of them. If the special
@@ -1420,6 +1436,57 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
}
}
+static Lisp_Object
+internal_catch_all_1 (Lisp_Object (*function) (void *), void *argument)
+{
+ struct handler *c = push_handler_nosignal (Qt, CATCHER_ALL);
+ if (c == NULL)
+ return Qcatch_all_memory_full;
+
+ if (sys_setjmp (c->jmp) == 0)
+ {
+ Lisp_Object val = function (argument);
+ eassert (handlerlist == c);
+ handlerlist = c->next;
+ return val;
+ }
+ else
+ {
+ eassert (handlerlist == c);
+ Lisp_Object val = c->val;
+ handlerlist = c->next;
+ Fsignal (Qno_catch, val);
+ }
+}
+
+/* Like a combination of internal_condition_case_1 and internal_catch.
+ Catches all signals and throws. Never exits nonlocally; returns
+ Qcatch_all_memory_full if no handler could be allocated. */
+
+Lisp_Object
+internal_catch_all (Lisp_Object (*function) (void *), void *argument,
+ Lisp_Object (*handler) (Lisp_Object))
+{
+ struct handler *c = push_handler_nosignal (Qt, CONDITION_CASE);
+ if (c == NULL)
+ return Qcatch_all_memory_full;
+
+ if (sys_setjmp (c->jmp) == 0)
+ {
+ Lisp_Object val = internal_catch_all_1 (function, argument);
+ eassert (handlerlist == c);
+ handlerlist = c->next;
+ return val;
+ }
+ else
+ {
+ eassert (handlerlist == c);
+ Lisp_Object val = c->val;
+ handlerlist = c->next;
+ return handler (val);
+ }
+}
+
struct handler *
push_handler (Lisp_Object tag_ch_val, enum handlertype handlertype)
{
@@ -1484,10 +1551,7 @@ process_quit_flag (void)
If quit-flag is set to `kill-emacs' the SIGINT handler has received
a request to exit Emacs when it is safe to do.
- When not quitting, process any pending signals.
-
- If you change this function, also adapt module_should_quit in
- emacs-module.c. */
+ When not quitting, process any pending signals. */
void
maybe_quit (void)
@@ -1566,11 +1630,8 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
&& specpdl_ptr < specpdl + specpdl_size)
{
/* Edebug takes care of restoring these variables when it exits. */
- if (lisp_eval_depth + 20 > max_lisp_eval_depth)
- max_lisp_eval_depth = lisp_eval_depth + 20;
-
- if (SPECPDL_INDEX () + 40 > max_specpdl_size)
- max_specpdl_size = SPECPDL_INDEX () + 40;
+ max_ensure_room (&max_lisp_eval_depth, lisp_eval_depth, 20);
+ max_ensure_room (&max_specpdl_size, SPECPDL_INDEX (), 40);
call2 (Vsignal_hook_function, error_symbol, data);
}
@@ -1671,33 +1732,25 @@ xsignal3 (Lisp_Object error_symbol, Lisp_Object arg1, Lisp_Object arg2, Lisp_Obj
}
/* Signal `error' with message S, and additional arg ARG.
- If ARG is not a genuine list, make it a one-element list. */
+ If ARG is not a proper list, make it a one-element list. */
void
signal_error (const char *s, Lisp_Object arg)
{
- Lisp_Object tortoise, hare;
-
- hare = tortoise = arg;
- while (CONSP (hare))
- {
- hare = XCDR (hare);
- if (!CONSP (hare))
- break;
-
- hare = XCDR (hare);
- tortoise = XCDR (tortoise);
-
- if (EQ (hare, tortoise))
- break;
- }
-
- if (!NILP (hare))
+ if (NILP (Fproper_list_p (arg)))
arg = list1 (arg);
xsignal (Qerror, Fcons (build_string (s), arg));
}
+/* Use this for arithmetic overflow, e.g., when an integer result is
+ too large even for a bignum. */
+void
+overflow_error (void)
+{
+ xsignal0 (Qoverflow_error);
+}
+
/* Return true if LIST is a non-nil atom or
a list containing one of CONDITIONS. */
@@ -1809,7 +1862,9 @@ find_handler_clause (Lisp_Object handlers, Lisp_Object conditions)
for (h = handlers; CONSP (h); h = XCDR (h))
{
Lisp_Object handler = XCAR (h);
- if (!NILP (Fmemq (handler, conditions)))
+ if (!NILP (Fmemq (handler, conditions))
+ /* t is also used as a catch-all by Lisp code. */
+ || EQ (handler, Qt))
return handlers;
}
@@ -1946,12 +2001,12 @@ this does nothing and returns nil. */)
&& !AUTOLOADP (XSYMBOL (function)->u.s.function))
return Qnil;
- if (!NILP (Vpurify_flag) && EQ (docstring, make_number (0)))
+ if (!NILP (Vpurify_flag) && EQ (docstring, make_fixnum (0)))
/* `read1' in lread.c has found the docstring starting with "\
and assumed the docstring will be provided by Snarf-documentation, so it
passed us 0 instead. But that leads to accidental sharing in purecopy's
hash-consing, so we use a (hopefully) unique integer instead. */
- docstring = make_number (XHASH (function));
+ docstring = make_fixnum (XHASH (function));
return Fdefalias (function,
list5 (Qautoload, file, docstring, interactive, type),
Qnil);
@@ -1971,7 +2026,7 @@ un_autoload (Lisp_Object oldqueue)
first = XCAR (queue);
second = Fcdr (first);
first = Fcar (first);
- if (EQ (first, make_number (0)))
+ if (EQ (first, make_fixnum (0)))
Vfeatures = second;
else
Ffset (first, second);
@@ -1996,16 +2051,14 @@ it defines a macro. */)
if (!CONSP (fundef) || !EQ (Qautoload, XCAR (fundef)))
return fundef;
- if (EQ (macro_only, Qmacro))
- {
- Lisp_Object kind = Fnth (make_number (4), fundef);
- if (! (EQ (kind, Qt) || EQ (kind, Qmacro)))
- return fundef;
- }
+ Lisp_Object kind = Fnth (make_fixnum (4), fundef);
+ if (EQ (macro_only, Qmacro)
+ && !(EQ (kind, Qt) || EQ (kind, Qmacro)))
+ return fundef;
/* This is to make sure that loadup.el gives a clear picture
of what files are preloaded and when. */
- if (! NILP (Vpurify_flag))
+ if (will_dump_p () && !will_bootstrap_p ())
error ("Attempt to autoload %s while preparing to dump",
SDATA (SYMBOL_NAME (funname)));
@@ -2024,15 +2077,18 @@ it defines a macro. */)
The value saved here is to be restored into Vautoload_queue. */
record_unwind_protect (un_autoload, Vautoload_queue);
Vautoload_queue = Qt;
- /* If `macro_only', assume this autoload to be a "best-effort",
+ /* If `macro_only' is set and fundef isn't a macro, assume this autoload to
+ be a "best-effort" (e.g. to try and find a compiler macro),
so don't signal an error if autoloading fails. */
- Fload (Fcar (Fcdr (fundef)), macro_only, Qt, Qnil, Qt);
+ Lisp_Object ignore_errors
+ = (EQ (kind, Qt) || EQ (kind, Qmacro)) ? Qnil : macro_only;
+ Fload (Fcar (Fcdr (fundef)), ignore_errors, Qt, Qnil, Qt);
/* Once loading finishes, don't undo it. */
Vautoload_queue = Qt;
unbind_to (count, Qnil);
- if (NILP (funname))
+ if (NILP (funname) || !NILP (ignore_errors))
return Qnil;
else
{
@@ -2173,21 +2229,22 @@ eval_sub (Lisp_Object form)
/* Optimize for no indirection. */
fun = original_fun;
if (!SYMBOLP (fun))
- fun = Ffunction (Fcons (fun, Qnil));
+ fun = Ffunction (list1 (fun));
else if (!NILP (fun) && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun)))
fun = indirect_function (fun);
if (SUBRP (fun))
{
Lisp_Object args_left = original_args;
- Lisp_Object numargs = Flength (args_left);
+ ptrdiff_t numargs = list_length (args_left);
check_cons_list ();
- if (XINT (numargs) < XSUBR (fun)->min_args
+ if (numargs < XSUBR (fun)->min_args
|| (XSUBR (fun)->max_args >= 0
- && XSUBR (fun)->max_args < XINT (numargs)))
- xsignal2 (Qwrong_number_of_arguments, original_fun, numargs);
+ && XSUBR (fun)->max_args < numargs))
+ xsignal2 (Qwrong_number_of_arguments, original_fun,
+ make_fixnum (numargs));
else if (XSUBR (fun)->max_args == UNEVALLED)
val = (XSUBR (fun)->function.aUNEVALLED) (args_left);
@@ -2198,9 +2255,9 @@ eval_sub (Lisp_Object form)
ptrdiff_t argnum = 0;
USE_SAFE_ALLOCA;
- SAFE_ALLOCA_LISP (vals, XINT (numargs));
+ SAFE_ALLOCA_LISP (vals, numargs);
- while (CONSP (args_left) && argnum < XINT (numargs))
+ while (CONSP (args_left) && argnum < numargs)
{
Lisp_Object arg = XCAR (args_left);
args_left = XCDR (args_left);
@@ -2230,7 +2287,7 @@ eval_sub (Lisp_Object form)
args_left = Fcdr (args_left);
}
- set_backtrace_args (specpdl + count, argvals, XINT (numargs));
+ set_backtrace_args (specpdl + count, argvals, numargs);
switch (i)
{
@@ -2308,7 +2365,7 @@ eval_sub (Lisp_Object form)
specbind (Qlexical_binding,
NILP (Vinternal_interpreter_environment) ? Qnil : Qt);
exp = apply1 (Fcdr (fun), original_args);
- unbind_to (count1, Qnil);
+ exp = unbind_to (count1, exp);
val = eval_sub (exp);
}
else if (EQ (funcar, Qlambda)
@@ -2334,16 +2391,13 @@ Thus, (apply \\='+ 1 2 \\='(3 4)) returns 10.
usage: (apply FUNCTION &rest ARGUMENTS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- ptrdiff_t i, numargs, funcall_nargs;
- register Lisp_Object *funcall_args = NULL;
- register Lisp_Object spread_arg = args[nargs - 1];
+ ptrdiff_t i, funcall_nargs;
+ Lisp_Object *funcall_args = NULL;
+ Lisp_Object spread_arg = args[nargs - 1];
Lisp_Object fun = args[0];
- Lisp_Object retval;
USE_SAFE_ALLOCA;
- CHECK_LIST (spread_arg);
-
- numargs = XINT (Flength (spread_arg));
+ ptrdiff_t numargs = list_length (spread_arg);
if (numargs == 0)
return Ffuncall (nargs - 1, args);
@@ -2393,7 +2447,7 @@ usage: (apply FUNCTION &rest ARGUMENTS) */)
spread_arg = XCDR (spread_arg);
}
- retval = Ffuncall (funcall_nargs, funcall_args);
+ Lisp_Object retval = Ffuncall (funcall_nargs, funcall_args);
SAFE_FREE ();
return retval;
@@ -2817,7 +2871,7 @@ funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args)
{
Lisp_Object fun;
XSETSUBR (fun, subr);
- xsignal2 (Qwrong_number_of_arguments, fun, make_number (numargs));
+ xsignal2 (Qwrong_number_of_arguments, fun, make_fixnum (numargs));
}
else if (subr->max_args == UNEVALLED)
@@ -2891,25 +2945,22 @@ funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args)
static Lisp_Object
apply_lambda (Lisp_Object fun, Lisp_Object args, ptrdiff_t count)
{
- Lisp_Object args_left;
- ptrdiff_t i;
- EMACS_INT numargs;
Lisp_Object *arg_vector;
Lisp_Object tem;
USE_SAFE_ALLOCA;
- numargs = XFASTINT (Flength (args));
+ ptrdiff_t numargs = list_length (args);
SAFE_ALLOCA_LISP (arg_vector, numargs);
- args_left = args;
+ Lisp_Object args_left = args;
- for (i = 0; i < numargs; )
+ for (ptrdiff_t i = 0; i < numargs; i++)
{
tem = Fcar (args_left), args_left = Fcdr (args_left);
tem = eval_sub (tem);
- arg_vector[i++] = tem;
+ arg_vector[i] = tem;
}
- set_backtrace_args (specpdl + count, arg_vector, i);
+ set_backtrace_args (specpdl + count, arg_vector, numargs);
tem = funcall_lambda (fun, numargs, arg_vector);
check_cons_list ();
@@ -2960,7 +3011,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
if (size <= COMPILED_STACK_DEPTH)
xsignal1 (Qinvalid_function, fun);
syms_left = AREF (fun, COMPILED_ARGLIST);
- if (INTEGERP (syms_left))
+ if (FIXNUMP (syms_left))
/* A byte-code object with an integer args template means we
shouldn't bind any arguments, instead just call the byte-code
interpreter directly; it will push arguments as necessary.
@@ -2990,7 +3041,6 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
emacs_abort ();
i = optional = rest = 0;
- bool previous_optional_or_rest = false;
for (; CONSP (syms_left); syms_left = XCDR (syms_left))
{
maybe_quit ();
@@ -3001,17 +3051,15 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
if (EQ (next, Qand_rest))
{
- if (rest || previous_optional_or_rest)
+ if (rest)
xsignal1 (Qinvalid_function, fun);
rest = 1;
- previous_optional_or_rest = true;
}
else if (EQ (next, Qand_optional))
{
- if (optional || rest || previous_optional_or_rest)
+ if (optional || rest)
xsignal1 (Qinvalid_function, fun);
optional = 1;
- previous_optional_or_rest = true;
}
else
{
@@ -3024,7 +3072,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
else if (i < nargs)
arg = arg_vector[i++];
else if (!optional)
- xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs));
+ xsignal2 (Qwrong_number_of_arguments, fun, make_fixnum (nargs));
else
arg = Qnil;
@@ -3035,14 +3083,13 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
else
/* Dynamically bind NEXT. */
specbind (next, arg);
- previous_optional_or_rest = false;
}
}
- if (!NILP (syms_left) || previous_optional_or_rest)
+ if (!NILP (syms_left))
xsignal1 (Qinvalid_function, fun);
else if (i < nargs)
- xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs));
+ xsignal2 (Qwrong_number_of_arguments, fun, make_fixnum (nargs));
if (!EQ (lexenv, Vinternal_interpreter_environment))
/* Instantiate a new lexical environment. */
@@ -3149,7 +3196,7 @@ lambda_arity (Lisp_Object fun)
if (size <= COMPILED_STACK_DEPTH)
xsignal1 (Qinvalid_function, fun);
syms_left = AREF (fun, COMPILED_ARGLIST);
- if (INTEGERP (syms_left))
+ if (FIXNUMP (syms_left))
return get_byte_code_arity (syms_left);
}
else
@@ -3164,7 +3211,7 @@ lambda_arity (Lisp_Object fun)
xsignal1 (Qinvalid_function, fun);
if (EQ (next, Qand_rest))
- return Fcons (make_number (minargs), Qmany);
+ return Fcons (make_fixnum (minargs), Qmany);
else if (EQ (next, Qand_optional))
optional = true;
else
@@ -3178,7 +3225,7 @@ lambda_arity (Lisp_Object fun)
if (!NILP (syms_left))
xsignal1 (Qinvalid_function, fun);
- return Fcons (make_number (minargs), make_number (maxargs));
+ return Fcons (make_fixnum (minargs), make_fixnum (maxargs));
}
DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode,
@@ -3350,6 +3397,16 @@ record_unwind_protect (void (*function) (Lisp_Object), Lisp_Object arg)
specpdl_ptr->unwind.kind = SPECPDL_UNWIND;
specpdl_ptr->unwind.func = function;
specpdl_ptr->unwind.arg = arg;
+ specpdl_ptr->unwind.eval_depth = lisp_eval_depth;
+ grow_specpdl ();
+}
+
+void
+record_unwind_protect_array (Lisp_Object *array, ptrdiff_t nelts)
+{
+ specpdl_ptr->unwind_array.kind = SPECPDL_UNWIND_ARRAY;
+ specpdl_ptr->unwind_array.array = array;
+ specpdl_ptr->unwind_array.nelts = nelts;
grow_specpdl ();
}
@@ -3372,6 +3429,14 @@ record_unwind_protect_int (void (*function) (int), int arg)
}
void
+record_unwind_protect_excursion (void)
+{
+ specpdl_ptr->unwind_excursion.kind = SPECPDL_UNWIND_EXCURSION;
+ save_excursion_save (specpdl_ptr);
+ grow_specpdl ();
+}
+
+void
record_unwind_protect_void (void (*function) (void))
{
specpdl_ptr->unwind_void.kind = SPECPDL_UNWIND_VOID;
@@ -3405,8 +3470,12 @@ do_one_unbind (union specbinding *this_binding, bool unwinding,
switch (this_binding->kind)
{
case SPECPDL_UNWIND:
+ lisp_eval_depth = this_binding->unwind.eval_depth;
this_binding->unwind.func (this_binding->unwind.arg);
break;
+ case SPECPDL_UNWIND_ARRAY:
+ xfree (this_binding->unwind_array.array);
+ break;
case SPECPDL_UNWIND_PTR:
this_binding->unwind_ptr.func (this_binding->unwind_ptr.arg);
break;
@@ -3416,6 +3485,10 @@ do_one_unbind (union specbinding *this_binding, bool unwinding,
case SPECPDL_UNWIND_VOID:
this_binding->unwind_void.func ();
break;
+ case SPECPDL_UNWIND_EXCURSION:
+ save_excursion_restore (this_binding->unwind_excursion.marker,
+ this_binding->unwind_excursion.window);
+ break;
case SPECPDL_BACKTRACE:
break;
case SPECPDL_LET:
@@ -3492,6 +3565,7 @@ set_unwind_protect (ptrdiff_t count, void (*func) (Lisp_Object),
p->unwind.kind = SPECPDL_UNWIND;
p->unwind.func = func;
p->unwind.arg = arg;
+ p->unwind.eval_depth = lisp_eval_depth;
}
void
@@ -3581,11 +3655,11 @@ get_backtrace_frame (Lisp_Object nframes, Lisp_Object base)
{
register EMACS_INT i;
- CHECK_NATNUM (nframes);
+ CHECK_FIXNAT (nframes);
union specbinding *pdl = get_backtrace_starting_at (base);
/* Find the frame requested. */
- for (i = XFASTINT (nframes); i > 0 && backtrace_p (pdl); i--)
+ for (i = XFIXNAT (nframes); i > 0 && backtrace_p (pdl); i--)
pdl = backtrace_next (pdl);
return pdl;
@@ -3599,7 +3673,7 @@ backtrace_frame_apply (Lisp_Object function, union specbinding *pdl)
Lisp_Object flags = Qnil;
if (backtrace_debug_on_exit (pdl))
- flags = Fcons (QCdebug_on_exit, Fcons (Qt, Qnil));
+ flags = list2 (QCdebug_on_exit, Qt);
if (backtrace_nargs (pdl) == UNEVALLED)
return call4 (function, Qnil, backtrace_function (pdl), *backtrace_args (pdl), flags);
@@ -3615,7 +3689,7 @@ DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
The debugger is entered when that frame exits, if the flag is non-nil. */)
(Lisp_Object level, Lisp_Object flag)
{
- CHECK_NUMBER (level);
+ CHECK_FIXNUM (level);
union specbinding *pdl = get_backtrace_frame(level, Qnil);
if (backtrace_p (pdl))
@@ -3662,6 +3736,42 @@ Return the result of FUNCTION, or nil if no matching frame could be found. */)
return backtrace_frame_apply (function, get_backtrace_frame (nframes, base));
}
+DEFUN ("backtrace--frames-from-thread", Fbacktrace_frames_from_thread,
+ Sbacktrace_frames_from_thread, 1, 1, NULL,
+ doc: /* Return the list of backtrace frames from current execution point in THREAD.
+If a frame has not evaluated the arguments yet (or is a special form),
+the value of the list element is (nil FUNCTION ARG-FORMS...).
+If a frame has evaluated its arguments and called its function already,
+the value of the list element is (t FUNCTION ARG-VALUES...).
+A &rest arg is represented as the tail of the list ARG-VALUES.
+FUNCTION is whatever was supplied as car of evaluated list,
+or a lambda expression for macro calls. */)
+ (Lisp_Object thread)
+{
+ struct thread_state *tstate;
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ union specbinding *pdl = backtrace_thread_top (tstate);
+ Lisp_Object list = Qnil;
+
+ while (backtrace_thread_p (tstate, pdl))
+ {
+ Lisp_Object frame;
+ if (backtrace_nargs (pdl) == UNEVALLED)
+ frame = Fcons (Qnil,
+ Fcons (backtrace_function (pdl), *backtrace_args (pdl)));
+ else
+ {
+ Lisp_Object tem = Flist (backtrace_nargs (pdl), backtrace_args (pdl));
+ frame = Fcons (Qt, Fcons (backtrace_function (pdl), tem));
+ }
+ list = Fcons (frame, list);
+ pdl = backtrace_thread_next (tstate, pdl);
+ }
+ return Fnreverse (list);
+}
+
/* For backtrace-eval, we want to temporarily unwind the last few elements of
the specpdl stack, and then rewind them. We store the pre-unwind values
directly in the pre-existing specpdl elements (i.e. we swap the current
@@ -3690,18 +3800,22 @@ backtrace_eval_unrewind (int distance)
unwind_protect, but the problem is that we don't know how to
rewind them afterwards. */
case SPECPDL_UNWIND:
- {
- Lisp_Object oldarg = tmp->unwind.arg;
- if (tmp->unwind.func == set_buffer_if_live)
+ if (tmp->unwind.func == set_buffer_if_live)
+ {
+ Lisp_Object oldarg = tmp->unwind.arg;
tmp->unwind.arg = Fcurrent_buffer ();
- else if (tmp->unwind.func == save_excursion_restore)
- tmp->unwind.arg = save_excursion_save ();
- else
- break;
- tmp->unwind.func (oldarg);
- break;
+ set_buffer_if_live (oldarg);
+ }
+ break;
+ case SPECPDL_UNWIND_EXCURSION:
+ {
+ Lisp_Object marker = tmp->unwind_excursion.marker;
+ Lisp_Object window = tmp->unwind_excursion.window;
+ save_excursion_save (tmp);
+ save_excursion_restore (marker, window);
}
-
+ break;
+ case SPECPDL_UNWIND_ARRAY:
case SPECPDL_UNWIND_PTR:
case SPECPDL_UNWIND_INT:
case SPECPDL_UNWIND_VOID:
@@ -3782,7 +3896,7 @@ NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'.
{
union specbinding *frame = get_backtrace_frame (nframes, base);
union specbinding *prevframe
- = get_backtrace_frame (make_number (XFASTINT (nframes) - 1), base);
+ = get_backtrace_frame (make_fixnum (XFIXNAT (nframes) - 1), base);
ptrdiff_t distance = specpdl_ptr - frame;
Lisp_Object result = Qnil;
eassert (distance >= 0);
@@ -3834,8 +3948,10 @@ NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'.
break;
case SPECPDL_UNWIND:
+ case SPECPDL_UNWIND_ARRAY:
case SPECPDL_UNWIND_PTR:
case SPECPDL_UNWIND_INT:
+ case SPECPDL_UNWIND_EXCURSION:
case SPECPDL_UNWIND_VOID:
case SPECPDL_BACKTRACE:
break;
@@ -3860,11 +3976,20 @@ mark_specpdl (union specbinding *first, union specbinding *ptr)
for (pdl = first; pdl != ptr; pdl++)
{
switch (pdl->kind)
- {
+ {
case SPECPDL_UNWIND:
mark_object (specpdl_arg (pdl));
break;
+ case SPECPDL_UNWIND_ARRAY:
+ mark_maybe_objects (pdl->unwind_array.array, pdl->unwind_array.nelts);
+ break;
+
+ case SPECPDL_UNWIND_EXCURSION:
+ mark_object (pdl->unwind_excursion.marker);
+ mark_object (pdl->unwind_excursion.window);
+ break;
+
case SPECPDL_BACKTRACE:
{
ptrdiff_t nargs = backtrace_nargs (pdl);
@@ -3888,7 +4013,7 @@ mark_specpdl (union specbinding *first, union specbinding *ptr)
case SPECPDL_UNWIND_PTR:
case SPECPDL_UNWIND_INT:
- case SPECPDL_UNWIND_VOID:
+ case SPECPDL_UNWIND_VOID:
break;
default:
@@ -4074,7 +4199,8 @@ alist of active lexical bindings. */);
staticpro (&Vsignaling_function);
Vsignaling_function = Qnil;
- inhibit_lisp_code = Qnil;
+ DEFSYM (Qcatch_all_memory_full, "catch-all-memory-full");
+ Funintern (Qcatch_all_memory_full, Qnil);
defsubr (&Sor);
defsubr (&Sand);
@@ -4082,7 +4208,6 @@ alist of active lexical bindings. */);
defsubr (&Scond);
defsubr (&Sprogn);
defsubr (&Sprog1);
- defsubr (&Sprog2);
defsubr (&Ssetq);
defsubr (&Squote);
defsubr (&Sfunction);
@@ -4119,6 +4244,7 @@ alist of active lexical bindings. */);
DEFSYM (QCdebug_on_exit, ":debug-on-exit");
defsubr (&Smapbacktrace);
defsubr (&Sbacktrace_frame_internal);
+ defsubr (&Sbacktrace_frames_from_thread);
defsubr (&Sbacktrace_eval);
defsubr (&Sbacktrace__locals);
defsubr (&Sspecial_variable_p);
diff --git a/src/fileio.c b/src/fileio.c
index ba7caddc978..4ee125d7de2 100644
--- a/src/fileio.c
+++ b/src/fileio.c
@@ -96,6 +96,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <acl.h>
#include <allocator.h>
#include <careadlinkat.h>
+#include <dosname.h>
+#include <fsusage.h>
#include <stat-time.h>
#include <tempname.h>
@@ -138,7 +140,7 @@ static bool e_write (int, Lisp_Object, ptrdiff_t, ptrdiff_t,
struct coding_system *);
-/* Return true if FILENAME exists. */
+/* Return true if FILENAME exists, otherwise return false and set errno. */
static bool
check_existing (const char *filename)
@@ -231,6 +233,7 @@ report_file_error (char const *string, Lisp_Object name)
report_file_errno (string, name, errno);
}
+#ifdef USE_FILE_NOTIFY
/* Like report_file_error, but reports a file-notify-error instead. */
void
@@ -245,6 +248,7 @@ report_file_notify_error (const char *string, Lisp_Object name)
xsignal (Qfile_notify_error, Fcons (build_string (string), errdata));
}
+#endif
void
close_file_unwind (int fd)
@@ -343,7 +347,7 @@ Given a Unix syntax file name, returns a string ending in slash. */)
CHECK_STRING (filename);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (filename, Qfile_name_directory);
if (!NILP (handler))
{
@@ -438,7 +442,7 @@ or the entire name if it contains no slash. */)
CHECK_STRING (filename);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (filename, Qfile_name_nondirectory);
if (!NILP (handler))
{
@@ -469,7 +473,7 @@ DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory,
Sunhandled_file_name_directory, 1, 1, 0,
doc: /* Return a directly usable directory name somehow associated with FILENAME.
A `directly usable' directory name is one that may be used without the
-intervention of any file handler.
+intervention of any file name handler.
If FILENAME is a directly usable file itself, return
\(file-name-as-directory FILENAME).
If FILENAME refers to a file which is not accessible from a local process,
@@ -481,7 +485,7 @@ get a current directory to run processes in. */)
Lisp_Object handler;
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (filename, Qunhandled_file_name_directory);
if (!NILP (handler))
{
@@ -543,7 +547,7 @@ is already present. */)
CHECK_STRING (file);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (file, Qfile_name_as_directory);
if (!NILP (handler))
{
@@ -634,7 +638,7 @@ In Unix-syntax, this function just removes the final slash. */)
CHECK_STRING (directory);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (directory, Qdirectory_file_name);
if (!NILP (handler))
{
@@ -688,7 +692,7 @@ This function does not grok magic file names. */)
memset (data + prefix_len, 'X', nX);
memcpy (data + prefix_len + nX, SSDATA (encoded_suffix), suffix_len);
int kind = (NILP (dir_flag) ? GT_FILE
- : EQ (dir_flag, make_number (0)) ? GT_NOCREATE
+ : EQ (dir_flag, make_fixnum (0)) ? GT_NOCREATE
: GT_DIR);
int fd = gen_tempname (data, suffix_len, O_BINARY | O_CLOEXEC, kind);
bool failed = fd < 0;
@@ -729,7 +733,7 @@ later creating the file, which opens all kinds of security holes.
For that reason, you should normally use `make-temp-file' instead. */)
(Lisp_Object prefix)
{
- return Fmake_temp_file_internal (prefix, make_number (0),
+ return Fmake_temp_file_internal (prefix, make_fixnum (0),
empty_unibyte_string, Qnil);
}
@@ -786,7 +790,7 @@ the root directory. */)
CHECK_STRING (name);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (name, Qexpand_file_name);
if (!NILP (handler))
{
@@ -818,17 +822,14 @@ the root directory. */)
#endif
}
- if (!NILP (default_directory))
+ handler = Ffind_file_name_handler (default_directory, Qexpand_file_name);
+ if (!NILP (handler))
{
- handler = Ffind_file_name_handler (default_directory, Qexpand_file_name);
- if (!NILP (handler))
- {
- handled_name = call3 (handler, Qexpand_file_name,
- name, default_directory);
- if (STRINGP (handled_name))
- return handled_name;
- error ("Invalid handler in `file-name-handler-alist'");
- }
+ handled_name = call3 (handler, Qexpand_file_name,
+ name, default_directory);
+ if (STRINGP (handled_name))
+ return handled_name;
+ error ("Invalid handler in `file-name-handler-alist'");
}
{
@@ -1093,23 +1094,11 @@ the root directory. */)
{
Lisp_Object tem;
- if (!(newdir = egetenv ("HOME")))
- newdir = newdirlim = "";
+ newdir = get_homedir ();
nm++;
-#ifdef WINDOWSNT
- if (newdir[0])
- {
- char newdir_utf8[MAX_UTF8_PATH];
-
- filename_from_ansi (newdir, newdir_utf8);
- tem = make_unibyte_string (newdir_utf8, strlen (newdir_utf8));
- newdir = SSDATA (tem);
- }
- else
-#endif
- tem = build_string (newdir);
+ tem = build_string (newdir);
newdirlim = newdir + SBYTES (tem);
- /* `egetenv' may return a unibyte string, which will bite us
+ /* get_homedir may return a unibyte string, which will bite us
if we expect the directory to be multibyte. */
if (multibyte && !STRING_MULTIBYTE (tem))
{
@@ -1458,7 +1447,7 @@ the root directory. */)
}
/* Again look to see if the file name has special constructs in it
- and perhaps call the corresponding file handler. This is needed
+ and perhaps call the corresponding file name handler. This is needed
for filenames such as "/foo/../user@host:/bar/../baz". Expanding
the ".." component gives us "/user@host:/bar/../baz" which needs
to be expanded again. */
@@ -1637,8 +1626,7 @@ See also the function `substitute-in-file-name'.")
}
#endif
-/* If /~ or // appears, discard everything through first slash. */
-static bool
+bool
file_name_absolute_p (const char *filename)
{
return
@@ -1650,6 +1638,102 @@ file_name_absolute_p (const char *filename)
);
}
+/* Put into BUF the concatenation of DIR and FILE, with an intervening
+ directory separator if needed. Return a pointer to the NUL byte
+ at the end of the concatenated string. */
+char *
+splice_dir_file (char *buf, char const *dir, char const *file)
+{
+ char *e = stpcpy (buf, dir);
+ *e = DIRECTORY_SEP;
+ e += ! (buf < e && IS_DIRECTORY_SEP (e[-1]));
+ return stpcpy (e, file);
+}
+
+/* Get the home directory, an absolute file name. Return the empty
+ string on failure. The returned value does not survive garbage
+ collection, calls to this function, or calls to the getpwnam class
+ of functions. */
+char const *
+get_homedir (void)
+{
+ char const *home = egetenv ("HOME");
+
+#ifdef WINDOWSNT
+ /* getpw* functions return UTF-8 encoded file names, whereas egetenv
+ returns strings in locale encoding, so we need to convert for
+ consistency. */
+ static char homedir_utf8[MAX_UTF8_PATH];
+ if (home)
+ {
+ filename_from_ansi (home, homedir_utf8);
+ home = homedir_utf8;
+ }
+#endif
+
+ if (!home)
+ {
+ static char const *userenv[] = {"LOGNAME", "USER"};
+ struct passwd *pw = NULL;
+ for (int i = 0; i < ARRAYELTS (userenv); i++)
+ {
+ char *user = egetenv (userenv[i]);
+ if (user)
+ {
+ pw = getpwnam (user);
+ if (pw)
+ break;
+ }
+ }
+ if (!pw)
+ pw = getpwuid (getuid ());
+ if (pw)
+ home = pw->pw_dir;
+ if (!home)
+ return "";
+ }
+#ifdef DOS_NT
+ /* If home is a drive-relative directory, expand it. */
+ if (IS_DRIVE (*home)
+ && IS_DEVICE_SEP (home[1])
+ && !IS_DIRECTORY_SEP (home[2]))
+ {
+# ifdef WINDOWSNT
+ static char hdir[MAX_UTF8_PATH];
+# else
+ static char hdir[MAXPATHLEN];
+# endif
+ if (!getdefdir (c_toupper (*home) - 'A' + 1, hdir))
+ {
+ hdir[0] = c_toupper (*home);
+ hdir[1] = ':';
+ hdir[2] = '/';
+ hdir[3] = '\0';
+ }
+ if (home[2])
+ {
+ size_t homelen = strlen (hdir);
+ if (!IS_DIRECTORY_SEP (hdir[homelen - 1]))
+ strcat (hdir, "/");
+ strcat (hdir, home + 2);
+ }
+ home = hdir;
+ }
+#endif
+ if (IS_ABSOLUTE_FILE_NAME (home))
+ return home;
+ if (!emacs_wd)
+ error ("$HOME is relative to unknown directory");
+ static char *ahome;
+ static ptrdiff_t ahomesize;
+ ptrdiff_t ahomelenbound = strlen (emacs_wd) + 1 + strlen (home) + 1;
+ if (ahomesize <= ahomelenbound)
+ ahome = xpalloc (ahome, &ahomesize, ahomelenbound + 1 - ahomesize, -1, 1);
+ splice_dir_file (ahome, emacs_wd, home);
+ return ahome;
+}
+
+/* If /~ or // appears, discard everything through first slash. */
static char *
search_embedded_absfilename (char *nm, char *endp)
{
@@ -1716,7 +1800,7 @@ those `/' is discarded. */)
multibyte = STRING_MULTIBYTE (filename);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (filename, Qsubstitute_in_file_name);
if (!NILP (handler))
{
@@ -1930,7 +2014,7 @@ permissions. */)
newname = expand_cp_target (file, newname);
/* If the input file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (file, Qcopy_file);
/* Likewise for output file name. */
if (NILP (handler))
@@ -1945,9 +2029,9 @@ permissions. */)
#ifdef WINDOWSNT
if (NILP (ok_if_already_exists)
- || INTEGERP (ok_if_already_exists))
+ || FIXNUMP (ok_if_already_exists))
barf_or_query_if_file_exists (newname, false, "copy to it",
- INTEGERP (ok_if_already_exists), false);
+ FIXNUMP (ok_if_already_exists), false);
result = w32_copy_file (SSDATA (encoded_file), SSDATA (encoded_newname),
!NILP (keep_time), !NILP (preserve_uid_gid),
@@ -2002,9 +2086,9 @@ permissions. */)
new_mask);
if (ofd < 0 && errno == EEXIST)
{
- if (NILP (ok_if_already_exists) || INTEGERP (ok_if_already_exists))
+ if (NILP (ok_if_already_exists) || FIXNUMP (ok_if_already_exists))
barf_or_query_if_file_exists (newname, true, "copy to it",
- INTEGERP (ok_if_already_exists), false);
+ FIXNUMP (ok_if_already_exists), false);
already_exists = true;
ofd = emacs_open (SSDATA (encoded_newname), O_WRONLY, 0);
}
@@ -2291,11 +2375,26 @@ The arg must be a string. */)
filename = Fexpand_file_name (filename, Qnil);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (filename, Qfile_name_case_insensitive_p);
if (!NILP (handler))
return call2 (handler, Qfile_name_case_insensitive_p, filename);
+ /* If the file doesn't exist, move up the filesystem tree until we
+ reach an existing directory or the root. */
+ if (NILP (Ffile_exists_p (filename)))
+ {
+ filename = Ffile_name_directory (filename);
+ while (NILP (Ffile_exists_p (filename)))
+ {
+ Lisp_Object newname = expand_and_dir_to_file (filename);
+ /* Avoid infinite loop if the root is reported as non-existing
+ (impossible?). */
+ if (!NILP (Fstring_equal (newname, filename)))
+ break;
+ filename = newname;
+ }
+ }
filename = ENCODE_FILE (filename);
return file_name_case_insensitive_p (SSDATA (filename)) ? Qt : Qnil;
}
@@ -2337,7 +2436,7 @@ This is what happens in interactive use with M-x. */)
newname = expand_cp_target (Fdirectory_file_name (file), newname);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (file, Qrename_file);
if (NILP (handler))
handler = Ffind_file_name_handler (newname, Qrename_file);
@@ -2350,7 +2449,7 @@ This is what happens in interactive use with M-x. */)
bool plain_rename = (case_only_rename
|| (!NILP (ok_if_already_exists)
- && !INTEGERP (ok_if_already_exists)));
+ && !FIXNUMP (ok_if_already_exists)));
int rename_errno UNINIT;
if (!plain_rename)
{
@@ -2368,7 +2467,7 @@ This is what happens in interactive use with M-x. */)
#endif
barf_or_query_if_file_exists (newname, rename_errno == EEXIST,
"rename to it",
- INTEGERP (ok_if_already_exists),
+ FIXNUMP (ok_if_already_exists),
false);
plain_rename = true;
break;
@@ -2439,14 +2538,14 @@ This is what happens in interactive use with M-x. */)
newname = expand_cp_target (file, newname);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (file, Qadd_name_to_file);
if (!NILP (handler))
return call4 (handler, Qadd_name_to_file, file,
newname, ok_if_already_exists);
/* If the new name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (newname, Qadd_name_to_file);
if (!NILP (handler))
return call4 (handler, Qadd_name_to_file, file,
@@ -2461,9 +2560,9 @@ This is what happens in interactive use with M-x. */)
if (errno == EEXIST)
{
if (NILP (ok_if_already_exists)
- || INTEGERP (ok_if_already_exists))
+ || FIXNUMP (ok_if_already_exists))
barf_or_query_if_file_exists (newname, true, "make it a new name",
- INTEGERP (ok_if_already_exists), false);
+ FIXNUMP (ok_if_already_exists), false);
unlink (SSDATA (newname));
if (link (SSDATA (encoded_file), SSDATA (encoded_newname)) == 0)
return Qnil;
@@ -2489,17 +2588,17 @@ This happens for interactive use with M-x. */)
Lisp_Object encoded_target, encoded_linkname;
CHECK_STRING (target);
- if (INTEGERP (ok_if_already_exists))
+ if (FIXNUMP (ok_if_already_exists))
{
if (SREF (target, 0) == '~')
target = Fexpand_file_name (target, Qnil);
else if (SREF (target, 0) == '/' && SREF (target, 1) == ':')
- target = Fsubstring_no_properties (target, make_number (2), Qnil);
+ target = Fsubstring_no_properties (target, make_fixnum (2), Qnil);
}
linkname = expand_cp_target (target, linkname);
/* If the new link name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (linkname, Qmake_symbolic_link);
if (!NILP (handler))
return call4 (handler, Qmake_symbolic_link, target,
@@ -2518,9 +2617,9 @@ This happens for interactive use with M-x. */)
if (errno == EEXIST)
{
if (NILP (ok_if_already_exists)
- || INTEGERP (ok_if_already_exists))
+ || FIXNUMP (ok_if_already_exists))
barf_or_query_if_file_exists (linkname, true, "make it a link",
- INTEGERP (ok_if_already_exists), false);
+ FIXNUMP (ok_if_already_exists), false);
unlink (SSDATA (encoded_linkname));
if (symlink (SSDATA (encoded_target), SSDATA (encoded_linkname)) == 0)
return Qnil;
@@ -2554,7 +2653,7 @@ Use `file-symlink-p' to test for such links. */)
absname = Fexpand_file_name (filename, Qnil);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (absname, Qfile_exists_p);
if (!NILP (handler))
{
@@ -2582,7 +2681,7 @@ purpose, though.) */)
absname = Fexpand_file_name (filename, Qnil);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (absname, Qfile_executable_p);
if (!NILP (handler))
return call2 (handler, Qfile_executable_p, absname);
@@ -2604,7 +2703,7 @@ See also `file-exists-p' and `file-attributes'. */)
absname = Fexpand_file_name (filename, Qnil);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (absname, Qfile_readable_p);
if (!NILP (handler))
return call2 (handler, Qfile_readable_p, absname);
@@ -2625,7 +2724,7 @@ DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0,
absname = Fexpand_file_name (filename, Qnil);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (absname, Qfile_writable_p);
if (!NILP (handler))
return call2 (handler, Qfile_writable_p, absname);
@@ -2647,7 +2746,7 @@ DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0,
/* The read-only attribute of the parent directory doesn't affect
whether a file or directory can be created within it. Some day we
should check ACLs though, which do affect this. */
- return file_directory_p (SSDATA (dir)) ? Qt : Qnil;
+ return file_directory_p (dir) ? Qt : Qnil;
#else
return check_writable (SSDATA (dir), W_OK | X_OK) ? Qt : Qnil;
#endif
@@ -2667,7 +2766,7 @@ If there is no error, returns nil. */)
CHECK_STRING (string);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (absname, Qaccess_file);
if (!NILP (handler))
return call3 (handler, Qaccess_file, absname, string);
@@ -2715,7 +2814,7 @@ This function does not check whether the link target exists. */)
filename = Fexpand_file_name (filename, Qnil);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (filename, Qfile_symlink_p);
if (!NILP (handler))
return call2 (handler, Qfile_symlink_p, filename);
@@ -2734,26 +2833,54 @@ See `file-symlink-p' to distinguish symlinks. */)
Lisp_Object absname = expand_and_dir_to_file (filename);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
Lisp_Object handler = Ffind_file_name_handler (absname, Qfile_directory_p);
if (!NILP (handler))
return call2 (handler, Qfile_directory_p, absname);
absname = ENCODE_FILE (absname);
- return file_directory_p (SSDATA (absname)) ? Qt : Qnil;
+ return file_directory_p (absname) ? Qt : Qnil;
}
-/* Return true if FILE is a directory or a symlink to a directory. */
+/* Return true if FILE is a directory or a symlink to a directory.
+ Otherwise return false and set errno. */
bool
-file_directory_p (char const *file)
+file_directory_p (Lisp_Object file)
{
-#ifdef WINDOWSNT
+#ifdef DOS_NT
/* This is cheaper than 'stat'. */
- return faccessat (AT_FDCWD, file, D_OK, AT_EACCESS) == 0;
+ return faccessat (AT_FDCWD, SSDATA (file), D_OK, AT_EACCESS) == 0;
#else
+# ifdef O_PATH
+ /* Use O_PATH if available, as it avoids races and EOVERFLOW issues. */
+ int fd = openat (AT_FDCWD, SSDATA (file), O_PATH | O_CLOEXEC | O_DIRECTORY);
+ if (0 <= fd)
+ {
+ emacs_close (fd);
+ return true;
+ }
+ if (errno != EINVAL)
+ return false;
+ /* O_PATH is defined but evidently this Linux kernel predates 2.6.39.
+ Fall back on generic POSIX code. */
+# endif
+ /* Use file_accessible_directory, as it avoids stat EOVERFLOW
+ problems and could be cheaper. However, if it fails because FILE
+ is inaccessible, fall back on stat; if the latter fails with
+ EOVERFLOW then FILE must have been a directory unless a race
+ condition occurred (a problem hard to work around portably). */
+ if (file_accessible_directory_p (file))
+ return true;
+ if (errno != EACCES)
+ return false;
struct stat st;
- return stat (file, &st) == 0 && S_ISDIR (st.st_mode);
+ if (stat (SSDATA (file), &st) != 0)
+ return errno == EOVERFLOW;
+ if (S_ISDIR (st.st_mode))
+ return true;
+ errno = ENOTDIR;
+ return false;
#endif
}
@@ -2775,7 +2902,7 @@ really is a readable and searchable directory. */)
absname = Fexpand_file_name (filename, Qnil);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (absname, Qfile_accessible_directory_p);
if (!NILP (handler))
{
@@ -2814,7 +2941,7 @@ file_accessible_directory_p (Lisp_Object file)
return (SBYTES (file) == 0
|| w32_accessible_directory_p (SSDATA (file), SBYTES (file)));
# else /* MSDOS */
- return file_directory_p (SSDATA (file));
+ return file_directory_p (file);
# endif /* MSDOS */
#else /* !DOS_NT */
/* On POSIXish platforms, use just one system call; this avoids a
@@ -2835,12 +2962,15 @@ file_accessible_directory_p (Lisp_Object file)
dir = data;
else
{
- /* Just check for trailing '/' when deciding whether to append '/'.
- That's simpler than testing the two special cases "/" and "//",
- and it's a safe optimization here. */
- char *buf = SAFE_ALLOCA (len + 3);
+ /* Just check for trailing '/' when deciding whether append '/'
+ before appending '.'. That's simpler than testing the two
+ special cases "/" and "//", and it's a safe optimization
+ here. After appending '.', append another '/' to work around
+ a macOS bug (Bug#30350). */
+ static char const appended[] = "/./";
+ char *buf = SAFE_ALLOCA (len + sizeof appended);
memcpy (buf, data, len);
- strcpy (buf + len, &"/."[data[len - 1] == '/']);
+ strcpy (buf + len, &appended[data[len - 1] == '/']);
dir = buf;
}
@@ -2863,7 +2993,7 @@ See `file-symlink-p' to distinguish symlinks. */)
Lisp_Object absname = expand_and_dir_to_file (filename);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
Lisp_Object handler = Ffind_file_name_handler (absname, Qfile_regular_p);
if (!NILP (handler))
return call2 (handler, Qfile_regular_p, absname);
@@ -2906,7 +3036,7 @@ or if SELinux is disabled, or if Emacs lacks SELinux support. */)
Lisp_Object absname = expand_and_dir_to_file (filename);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
Lisp_Object handler = Ffind_file_name_handler (absname,
Qfile_selinux_context);
if (!NILP (handler))
@@ -2968,7 +3098,7 @@ or if Emacs was not compiled with SELinux support. */)
absname = Fexpand_file_name (filename, BVAR (current_buffer, directory));
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (absname, Qset_file_selinux_context);
if (!NILP (handler))
return call3 (handler, Qset_file_selinux_context, absname, context);
@@ -3038,7 +3168,7 @@ was unable to determine the ACL entries. */)
Lisp_Object absname = expand_and_dir_to_file (filename);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
Lisp_Object handler = Ffind_file_name_handler (absname, Qfile_acl);
if (!NILP (handler))
return call2 (handler, Qfile_acl, absname);
@@ -3093,7 +3223,7 @@ support. */)
absname = Fexpand_file_name (filename, BVAR (current_buffer, directory));
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (absname, Qset_file_acl);
if (!NILP (handler))
return call3 (handler, Qset_file_acl, absname, acl_string);
@@ -3135,7 +3265,7 @@ Return nil, if file does not exist or is not accessible. */)
Lisp_Object absname = expand_and_dir_to_file (filename);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
Lisp_Object handler = Ffind_file_name_handler (absname, Qfile_modes);
if (!NILP (handler))
return call2 (handler, Qfile_modes, absname);
@@ -3145,7 +3275,7 @@ Return nil, if file does not exist or is not accessible. */)
if (stat (SSDATA (absname), &st) < 0)
return Qnil;
- return make_number (st.st_mode & 07777);
+ return make_fixnum (st.st_mode & 07777);
}
DEFUN ("set-file-modes", Fset_file_modes, Sset_file_modes, 2, 2,
@@ -3162,17 +3292,17 @@ symbolic notation, like the `chmod' command from GNU Coreutils. */)
Lisp_Object handler;
absname = Fexpand_file_name (filename, BVAR (current_buffer, directory));
- CHECK_NUMBER (mode);
+ CHECK_FIXNUM (mode);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (absname, Qset_file_modes);
if (!NILP (handler))
return call3 (handler, Qset_file_modes, absname, mode);
encoded_absname = ENCODE_FILE (absname);
- if (chmod (SSDATA (encoded_absname), XINT (mode) & 07777) < 0)
+ if (chmod (SSDATA (encoded_absname), XFIXNUM (mode) & 07777) < 0)
report_file_error ("Doing chmod", absname);
return Qnil;
@@ -3193,9 +3323,9 @@ by having the corresponding bit in the mask reset. */)
(Lisp_Object mode)
{
mode_t oldrealmask, oldumask, newumask;
- CHECK_NUMBER (mode);
+ CHECK_FIXNUM (mode);
oldrealmask = realmask;
- newumask = ~ XINT (mode) & 0777;
+ newumask = ~ XFIXNUM (mode) & 0777;
block_input ();
realmask = newumask;
@@ -3232,7 +3362,7 @@ Use the current time if TIMESTAMP is nil. TIMESTAMP is in the format of
absname = Fexpand_file_name (filename, BVAR (current_buffer, directory));
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (absname, Qset_file_times);
if (!NILP (handler))
return call3 (handler, Qset_file_times, absname, timestamp);
@@ -3244,7 +3374,7 @@ Use the current time if TIMESTAMP is nil. TIMESTAMP is in the format of
{
#ifdef MSDOS
/* Setting times on a directory always fails. */
- if (file_directory_p (SSDATA (encoded_absname)))
+ if (file_directory_p (encoded_absname))
return Qnil;
#endif
report_file_error ("Setting file times", absname);
@@ -3280,7 +3410,7 @@ otherwise, if FILE2 does not exist, the answer is t. */)
Lisp_Object absname2 = expand_and_dir_to_file (file2);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
Lisp_Object handler = Ffind_file_name_handler (absname1,
Qfile_newer_than_file_p);
if (NILP (handler))
@@ -3339,21 +3469,28 @@ decide_coding_unwind (Lisp_Object unwind_data)
bset_undo_list (current_buffer, undo_list);
}
-/* Read from a non-regular file. STATE is a Lisp_Save_Value
- object where slot 0 is the file descriptor, slot 1 specifies
- an offset to put the read bytes, and slot 2 is the maximum
- amount of bytes to read. Value is the number of bytes read. */
+/* Read from a non-regular file. Return the number of bytes read. */
+
+union read_non_regular
+{
+ struct
+ {
+ int fd;
+ ptrdiff_t inserted, trytry;
+ } s;
+ GCALIGNED_UNION_MEMBER
+};
+verify (GCALIGNED (union read_non_regular));
static Lisp_Object
read_non_regular (Lisp_Object state)
{
- int nbytes = emacs_read_quit (XSAVE_INTEGER (state, 0),
+ union read_non_regular *data = XFIXNUMPTR (state);
+ int nbytes = emacs_read_quit (data->s.fd,
((char *) BEG_ADDR + PT_BYTE - BEG_BYTE
- + XSAVE_INTEGER (state, 1)),
- XSAVE_INTEGER (state, 2));
- /* Fast recycle this object for the likely next call. */
- free_misc (state);
- return make_number (nbytes);
+ + data->s.inserted),
+ data->s.trytry);
+ return make_fixnum (nbytes);
}
@@ -3371,10 +3508,13 @@ read_non_regular_quit (Lisp_Object ignore)
static off_t
file_offset (Lisp_Object val)
{
- if (RANGED_INTEGERP (0, val, TYPE_MAXIMUM (off_t)))
- return XINT (val);
-
- if (FLOATP (val))
+ if (INTEGERP (val))
+ {
+ intmax_t v;
+ if (integer_to_intmax (val, &v) && 0 <= v && v <= TYPE_MAXIMUM (off_t))
+ return v;
+ }
+ else if (FLOATP (val))
{
double v = XFLOAT_DATA (val);
if (0 <= v && v < 1.0 + TYPE_MAXIMUM (off_t))
@@ -3431,16 +3571,16 @@ restore_window_points (Lisp_Object window_markers, ptrdiff_t inserted,
Lisp_Object car = XCAR (window_markers);
Lisp_Object marker = XCAR (car);
Lisp_Object oldpos = XCDR (car);
- if (MARKERP (marker) && INTEGERP (oldpos)
- && XINT (oldpos) > same_at_start
- && XINT (oldpos) < same_at_end)
+ if (MARKERP (marker) && FIXNUMP (oldpos)
+ && XFIXNUM (oldpos) > same_at_start
+ && XFIXNUM (oldpos) < same_at_end)
{
ptrdiff_t oldsize = same_at_end - same_at_start;
ptrdiff_t newsize = inserted;
double growth = newsize / (double)oldsize;
ptrdiff_t newpos
- = same_at_start + growth * (XINT (oldpos) - same_at_start);
- Fset_marker (marker, make_number (newpos), Qnil);
+ = same_at_start + growth * (XFIXNUM (oldpos) - same_at_start);
+ Fset_marker (marker, make_fixnum (newpos), Qnil);
}
}
}
@@ -3546,15 +3686,15 @@ by calling `format-decode', which see. */)
coding_system = Qnil;
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (filename, Qinsert_file_contents);
if (!NILP (handler))
{
val = call6 (handler, Qinsert_file_contents, filename,
visit, beg, end, replace);
if (CONSP (val) && CONSP (XCDR (val))
- && RANGED_INTEGERP (0, XCAR (XCDR (val)), ZV - PT))
- inserted = XINT (XCAR (XCDR (val)));
+ && RANGED_FIXNUMP (0, XCAR (XCDR (val)), ZV - PT))
+ inserted = XFIXNUM (XCAR (XCDR (val)));
goto handled;
}
@@ -3739,7 +3879,7 @@ by calling `format-decode', which see. */)
insert_1_both ((char *) read_buf, nread, nread, 0, 0, 0);
TEMP_SET_PT_BOTH (BEG, BEG_BYTE);
coding_system = call2 (Vset_auto_coding_function,
- filename, make_number (nread));
+ filename, make_fixnum (nread));
set_buffer_internal (prev);
/* Discard the unwind protect for recovering the
@@ -4207,9 +4347,9 @@ by calling `format-decode', which see. */)
/* Read from the file, capturing `quit'. When an
error occurs, end the loop, and arrange for a quit
to be signaled after decoding the text we read. */
+ union read_non_regular data = {{fd, inserted, trytry}};
nbytes = internal_condition_case_1
- (read_non_regular,
- make_save_int_int_int (fd, inserted, trytry),
+ (read_non_regular, make_pointer_integer (&data),
Qerror, read_non_regular_quit);
if (NILP (nbytes))
@@ -4218,7 +4358,7 @@ by calling `format-decode', which see. */)
break;
}
- this = XINT (nbytes);
+ this = XFIXNUM (nbytes);
}
else
{
@@ -4314,7 +4454,7 @@ by calling `format-decode', which see. */)
if (inserted > 0 && ! NILP (Vset_auto_coding_function))
{
coding_system = call2 (Vset_auto_coding_function,
- filename, make_number (inserted));
+ filename, make_fixnum (inserted));
}
if (NILP (coding_system))
@@ -4433,13 +4573,13 @@ by calling `format-decode', which see. */)
if (! NILP (Ffboundp (Qafter_insert_file_set_coding)))
{
- insval = call2 (Qafter_insert_file_set_coding, make_number (inserted),
+ insval = call2 (Qafter_insert_file_set_coding, make_fixnum (inserted),
visit);
if (! NILP (insval))
{
- if (! RANGED_INTEGERP (0, insval, ZV - PT))
+ if (! RANGED_FIXNUMP (0, insval, ZV - PT))
wrong_type_argument (intern ("inserted-chars"), insval);
- inserted = XFASTINT (insval);
+ inserted = XFIXNAT (insval);
}
}
@@ -4459,10 +4599,10 @@ by calling `format-decode', which see. */)
if (NILP (replace))
{
insval = call3 (Qformat_decode,
- Qnil, make_number (inserted), visit);
- if (! RANGED_INTEGERP (0, insval, ZV - PT))
+ Qnil, make_fixnum (inserted), visit);
+ if (! RANGED_FIXNUMP (0, insval, ZV - PT))
wrong_type_argument (intern ("inserted-chars"), insval);
- inserted = XFASTINT (insval);
+ inserted = XFIXNAT (insval);
}
else
{
@@ -4478,12 +4618,12 @@ by calling `format-decode', which see. */)
ptrdiff_t opoint = PT;
ptrdiff_t opoint_byte = PT_BYTE;
ptrdiff_t oinserted = ZV - BEGV;
- EMACS_INT ochars_modiff = CHARS_MODIFF;
+ modiff_count ochars_modiff = CHARS_MODIFF;
TEMP_SET_PT_BOTH (BEGV, BEGV_BYTE);
insval = call3 (Qformat_decode,
- Qnil, make_number (oinserted), visit);
- if (! RANGED_INTEGERP (0, insval, ZV - PT))
+ Qnil, make_fixnum (oinserted), visit);
+ if (! RANGED_FIXNUMP (0, insval, ZV - PT))
wrong_type_argument (intern ("inserted-chars"), insval);
if (ochars_modiff == CHARS_MODIFF)
/* format_decode didn't modify buffer's characters => move
@@ -4493,7 +4633,7 @@ by calling `format-decode', which see. */)
else
/* format_decode modified buffer's characters => consider
entire buffer changed and leave point at point-min. */
- inserted = XFASTINT (insval);
+ inserted = XFIXNAT (insval);
}
/* For consistency with format-decode call these now iff inserted > 0
@@ -4503,12 +4643,12 @@ by calling `format-decode', which see. */)
{
if (NILP (replace))
{
- insval = call1 (XCAR (p), make_number (inserted));
+ insval = call1 (XCAR (p), make_fixnum (inserted));
if (!NILP (insval))
{
- if (! RANGED_INTEGERP (0, insval, ZV - PT))
+ if (! RANGED_FIXNUMP (0, insval, ZV - PT))
wrong_type_argument (intern ("inserted-chars"), insval);
- inserted = XFASTINT (insval);
+ inserted = XFIXNAT (insval);
}
}
else
@@ -4518,13 +4658,13 @@ by calling `format-decode', which see. */)
ptrdiff_t opoint = PT;
ptrdiff_t opoint_byte = PT_BYTE;
ptrdiff_t oinserted = ZV - BEGV;
- EMACS_INT ochars_modiff = CHARS_MODIFF;
+ modiff_count ochars_modiff = CHARS_MODIFF;
TEMP_SET_PT_BOTH (BEGV, BEGV_BYTE);
- insval = call1 (XCAR (p), make_number (oinserted));
+ insval = call1 (XCAR (p), make_fixnum (oinserted));
if (!NILP (insval))
{
- if (! RANGED_INTEGERP (0, insval, ZV - PT))
+ if (! RANGED_FIXNUMP (0, insval, ZV - PT))
wrong_type_argument (intern ("inserted-chars"), insval);
if (ochars_modiff == CHARS_MODIFF)
/* after_insert_file_functions didn't modify
@@ -4536,7 +4676,7 @@ by calling `format-decode', which see. */)
/* after_insert_file_functions did modify buffer's
characters => consider entire buffer changed and
leave point at point-min. */
- inserted = XFASTINT (insval);
+ inserted = XFIXNAT (insval);
}
}
@@ -4552,10 +4692,10 @@ by calling `format-decode', which see. */)
/* Adjust the last undo record for the size change during
the format conversion. */
Lisp_Object tem = XCAR (old_undo);
- if (CONSP (tem) && INTEGERP (XCAR (tem))
- && INTEGERP (XCDR (tem))
- && XFASTINT (XCDR (tem)) == PT + old_inserted)
- XSETCDR (tem, make_number (PT + inserted));
+ if (CONSP (tem) && FIXNUMP (XCAR (tem))
+ && FIXNUMP (XCDR (tem))
+ && XFIXNAT (XCDR (tem)) == PT + old_inserted)
+ XSETCDR (tem, make_fixnum (PT + inserted));
}
}
else
@@ -4590,7 +4730,7 @@ by calling `format-decode', which see. */)
/* Retval needs to be dealt with in all cases consistently. */
if (NILP (val))
- val = list2 (orig_filename, make_number (inserted));
+ val = list2 (orig_filename, make_fixnum (inserted));
return unbind_to (count, val);
}
@@ -4714,7 +4854,7 @@ choose_write_coding_system (Lisp_Object start, Lisp_Object end, Lisp_Object file
val = coding_inherit_eol_type (val, eol_parent);
setup_coding_system (val, coding);
- if (!STRINGP (start) && !NILP (BVAR (current_buffer, selective_display)))
+ if (!STRINGP (start) && EQ (Qt, BVAR (current_buffer, selective_display)))
coding->mode |= CODING_MODE_SELECTIVE_DISPLAY;
return val;
}
@@ -4817,7 +4957,7 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename,
annotations = Qnil;
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (filename, Qwrite_region);
/* If FILENAME has no handler, see if VISIT has one. */
if (NILP (handler) && STRINGP (visit))
@@ -4932,14 +5072,14 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename,
if (STRINGP (start))
ok = a_write (desc, start, 0, SCHARS (start), &annotations, &coding);
- else if (XINT (start) != XINT (end))
- ok = a_write (desc, Qnil, XINT (start), XINT (end) - XINT (start),
+ else if (XFIXNUM (start) != XFIXNUM (end))
+ ok = a_write (desc, Qnil, XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start),
&annotations, &coding);
else
{
/* If file was empty, still need to write the annotations. */
coding.mode |= CODING_MODE_LAST_BLOCK;
- ok = a_write (desc, Qnil, XINT (end), 0, &annotations, &coding);
+ ok = a_write (desc, Qnil, XFIXNUM (end), 0, &annotations, &coding);
}
save_errno = errno;
@@ -5186,7 +5326,7 @@ build_annotations (Lisp_Object start, Lisp_Object end)
has written annotations to a temporary buffer, which is now
current. */
res = call5 (Qformat_annotate_function, XCAR (p), start, end,
- original_buffer, make_number (i));
+ original_buffer, make_fixnum (i));
if (current_buffer != given_buffer)
{
XSETFASTINT (start, BEGV);
@@ -5225,8 +5365,8 @@ a_write (int desc, Lisp_Object string, ptrdiff_t pos,
{
tem = Fcar_safe (Fcar (*annot));
nextpos = pos - 1;
- if (INTEGERP (tem))
- nextpos = XFASTINT (tem);
+ if (FIXNUMP (tem))
+ nextpos = XFIXNAT (tem);
/* If there are no more annotations in this range,
output the rest of the range all at once. */
@@ -5377,7 +5517,7 @@ See Info node `(elisp)Modification Time' for more details. */)
if (b->modtime.tv_nsec == UNKNOWN_MODTIME_NSECS) return Qt;
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (BVAR (b, filename),
Qverify_visited_file_modtime);
if (!NILP (handler))
@@ -5398,16 +5538,15 @@ See Info node `(elisp)Modification Time' for more details. */)
DEFUN ("visited-file-modtime", Fvisited_file_modtime,
Svisited_file_modtime, 0, 0, 0,
doc: /* Return the current buffer's recorded visited file modification time.
-The value is a list of the form (HIGH LOW USEC PSEC), like the time values that
-`file-attributes' returns. If the current buffer has no recorded file
-modification time, this function returns 0. If the visited file
-doesn't exist, return -1.
+Return a Lisp timestamp (as in `current-time') if the current buffer
+has a recorded file modification time, 0 if it doesn't, and -1 if the
+visited file doesn't exist.
See Info node `(elisp)Modification Time' for more details. */)
(void)
{
int ns = current_buffer->modtime.tv_nsec;
if (ns < 0)
- return make_number (UNKNOWN_MODTIME_NSECS - ns);
+ return make_fixnum (UNKNOWN_MODTIME_NSECS - ns);
return make_lisp_time (current_buffer->modtime);
}
@@ -5417,18 +5556,17 @@ DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime,
Useful if the buffer was not read from the file normally
or if the file itself has been changed for some known benign reason.
An argument specifies the modification time value to use
-\(instead of that of the visited file), in the form of a list
-\(HIGH LOW USEC PSEC) or an integer flag as returned by
-`visited-file-modtime'. */)
+\(instead of that of the visited file), in the form of a time value as
+in `current-time' or an integer flag as returned by `visited-file-modtime'. */)
(Lisp_Object time_flag)
{
if (!NILP (time_flag))
{
struct timespec mtime;
- if (INTEGERP (time_flag))
+ if (FIXNUMP (time_flag))
{
CHECK_RANGED_INTEGER (time_flag, -1, 0);
- mtime = make_timespec (0, UNKNOWN_MODTIME_NSECS - XINT (time_flag));
+ mtime = make_timespec (0, UNKNOWN_MODTIME_NSECS - XFIXNUM (time_flag));
}
else
mtime = lisp_time_argument (time_flag);
@@ -5445,7 +5583,7 @@ An argument specifies the modification time value to use
filename = Fexpand_file_name (BVAR (current_buffer, filename), Qnil);
/* If the file name has special constructs in it,
- call the corresponding file handler. */
+ call the corresponding file name handler. */
handler = Ffind_file_name_handler (filename, Qset_visited_file_modtime);
if (!NILP (handler))
/* The handler can find the file name the same way we did. */
@@ -5494,9 +5632,9 @@ auto_save_1 (void)
/* But make sure we can overwrite it later! */
auto_save_mode_bits = (st.st_mode | 0600) & 0777;
else if (modes = Ffile_modes (BVAR (current_buffer, filename)),
- INTEGERP (modes))
+ FIXNUMP (modes))
/* Remote files don't cooperate with stat. */
- auto_save_mode_bits = (XINT (modes) | 0600) & 0777;
+ auto_save_mode_bits = (XFIXNUM (modes) | 0600) & 0777;
}
return
@@ -5568,8 +5706,9 @@ A non-nil CURRENT-ONLY argument means save only current buffer. */)
bool old_message_p = 0;
struct auto_save_unwind auto_save_unwind;
- if (max_specpdl_size < specpdl_size + 40)
- max_specpdl_size = specpdl_size + 40;
+ intmax_t sum = INT_ADD_WRAPV (specpdl_size, 40, &sum) ? INTMAX_MAX : sum;
+ if (max_specpdl_size < sum)
+ max_specpdl_size = sum;
if (minibuf_level)
no_message = Qt;
@@ -5663,7 +5802,7 @@ A non-nil CURRENT-ONLY argument means save only current buffer. */)
&& BUF_SAVE_MODIFF (b) < BUF_MODIFF (b)
&& BUF_AUTOSAVE_MODIFF (b) < BUF_MODIFF (b)
/* -1 means we've turned off autosaving for a while--see below. */
- && XINT (BVAR (b, save_length)) >= 0
+ && XFIXNUM (BVAR (b, save_length)) >= 0
&& (do_handled_files
|| NILP (Ffind_file_name_handler (BVAR (b, auto_save_file_name),
Qwrite_region))))
@@ -5678,13 +5817,13 @@ A non-nil CURRENT-ONLY argument means save only current buffer. */)
set_buffer_internal (b);
if (NILP (Vauto_save_include_big_deletions)
- && (XFASTINT (BVAR (b, save_length)) * 10
+ && (XFIXNAT (BVAR (b, save_length)) * 10
> (BUF_Z (b) - BUF_BEG (b)) * 13)
/* A short file is likely to change a large fraction;
spare the user annoying messages. */
- && XFASTINT (BVAR (b, save_length)) > 5000
+ && XFIXNAT (BVAR (b, save_length)) > 5000
/* These messages are frequent and annoying for `*mail*'. */
- && !EQ (BVAR (b, filename), Qnil)
+ && !NILP (BVAR (b, filename))
&& NILP (no_message))
{
/* It has shrunk too much; turn off auto-saving here. */
@@ -5695,7 +5834,7 @@ A non-nil CURRENT-ONLY argument means save only current buffer. */)
/* Turn off auto-saving until there's a real save,
and prevent any more warnings. */
XSETINT (BVAR (b, save_length), -1);
- Fsleep_for (make_number (1), Qnil);
+ Fsleep_for (make_fixnum (1), Qnil);
continue;
}
if (!auto_saved && NILP (no_message))
@@ -5724,7 +5863,7 @@ A non-nil CURRENT-ONLY argument means save only current buffer. */)
{
/* If we are going to restore an old message,
give time to read ours. */
- sit_for (make_number (1), 0, 0);
+ sit_for (make_fixnum (1), 0, 0);
restore_message ();
}
else if (!auto_save_error_occurred)
@@ -5737,8 +5876,7 @@ A non-nil CURRENT-ONLY argument means save only current buffer. */)
Vquit_flag = oquit;
/* This restores the message-stack status. */
- unbind_to (count, Qnil);
- return Qnil;
+ return unbind_to (count, Qnil);
}
DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved,
@@ -5839,6 +5977,52 @@ effect except for flushing STREAM's data. */)
return (set_binary_mode (fileno (fp), binmode) == O_BINARY) ? Qt : Qnil;
}
+#ifndef DOS_NT
+
+/* Yield a Lisp float as close as possible to BLOCKSIZE * BLOCKS, with
+ the result negated if NEGATE. */
+static Lisp_Object
+blocks_to_bytes (uintmax_t blocksize, uintmax_t blocks, bool negate)
+{
+ /* On typical platforms the following code is accurate to 53 bits,
+ which is close enough. BLOCKSIZE is invariably a power of 2, so
+ converting it to double does not lose information. */
+ double bs = blocksize;
+ return make_float (negate ? -bs * -blocks : bs * blocks);
+}
+
+DEFUN ("file-system-info", Ffile_system_info, Sfile_system_info, 1, 1, 0,
+ doc: /* Return storage information about the file system FILENAME is on.
+Value is a list of numbers (TOTAL FREE AVAIL), where TOTAL is the total
+storage of the file system, FREE is the free storage, and AVAIL is the
+storage available to a non-superuser. All 3 numbers are in bytes.
+If the underlying system call fails, value is nil. */)
+ (Lisp_Object filename)
+{
+ Lisp_Object encoded = ENCODE_FILE (Fexpand_file_name (filename, Qnil));
+
+ /* If the file name has special constructs in it,
+ call the corresponding file name handler. */
+ Lisp_Object handler = Ffind_file_name_handler (encoded, Qfile_system_info);
+ if (!NILP (handler))
+ {
+ Lisp_Object result = call2 (handler, Qfile_system_info, encoded);
+ if (CONSP (result) || NILP (result))
+ return result;
+ error ("Invalid handler in `file-name-handler-alist'");
+ }
+
+ struct fs_usage u;
+ if (get_fs_usage (SSDATA (encoded), NULL, &u) != 0)
+ return Qnil;
+ return list3 (blocks_to_bytes (u.fsu_blocksize, u.fsu_blocks, false),
+ blocks_to_bytes (u.fsu_blocksize, u.fsu_bfree, false),
+ blocks_to_bytes (u.fsu_blocksize, u.fsu_bavail,
+ u.fsu_bavail_top_bit_set));
+}
+
+#endif /* !DOS_NT */
+
void
init_fileio (void)
{
@@ -5909,6 +6093,7 @@ syms_of_fileio (void)
DEFSYM (Qwrite_region, "write-region");
DEFSYM (Qverify_visited_file_modtime, "verify-visited-file-modtime");
DEFSYM (Qset_visited_file_modtime, "set-visited-file-modtime");
+ DEFSYM (Qfile_system_info, "file-system-info");
/* The symbol bound to coding-system-for-read when
insert-file-contents is called for recovering a file. This is not
@@ -6189,6 +6374,10 @@ This includes interactive calls to `delete-file' and
defsubr (&Sset_binary_mode);
+#ifndef DOS_NT
+ defsubr (&Sfile_system_info);
+#endif
+
#ifdef HAVE_SYNC
defsubr (&Sunix_sync);
#endif
diff --git a/src/filelock.c b/src/filelock.c
index 81d98f36fa4..baf87b7f635 100644
--- a/src/filelock.c
+++ b/src/filelock.c
@@ -171,13 +171,10 @@ get_boot_time (void)
}
#if defined (BOOT_TIME)
-#ifndef CANNOT_DUMP
- /* The utmp routines maintain static state.
- Don't touch that state unless we are initialized,
- since it might not survive dumping. */
- if (! initialized)
+ /* The utmp routines maintain static state. Don't touch that state
+ if we are going to dump, since it might not survive dumping. */
+ if (will_dump_p ())
return boot_time;
-#endif /* not CANNOT_DUMP */
/* Try to get boot time from utmp before wtmp,
since utmp is typically much smaller than wtmp.
@@ -299,7 +296,7 @@ typedef struct
/* Write the name of the lock file for FNAME into LOCKNAME. Length
will be that of FNAME plus two more for the leading ".#", plus one
- for the null. */
+ for the NUL. */
#define MAKE_LOCK_NAME(lockname, fname) \
(lockname = SAFE_ALLOCA (SBYTES (fname) + 2 + 1), \
fill_in_lock_file_name (lockname, fname))
@@ -666,7 +663,7 @@ lock_file (Lisp_Object fn)
/* Don't do locking while dumping Emacs.
Uncompressing wtmp files uses call-process, which does not work
in an uninitialized Emacs. */
- if (! NILP (Vpurify_flag))
+ if (will_dump_p ())
return;
orig_fn = fn;
@@ -825,6 +822,7 @@ t if it is locked by you, else a string saying which user has locked it. */)
USE_SAFE_ALLOCA;
filename = Fexpand_file_name (filename, Qnil);
+ filename = ENCODE_FILE (filename);
MAKE_LOCK_NAME (lfname, filename);
diff --git a/src/fingerprint.h b/src/fingerprint.h
new file mode 100644
index 00000000000..0b195fd0ca7
--- /dev/null
+++ b/src/fingerprint.h
@@ -0,0 +1,29 @@
+/* Header file for the Emacs build fingerprint.
+
+Copyright (C) 2016, 2018-2019 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 <http://www.gnu.org/licenses/>. */
+
+#ifndef EMACS_FINGERPRINT_H
+#define EMACS_FINGERPRINT_H
+
+/* We generate fingerprint.c and fingerprint.o from all the sources in
+ Emacs. This way, we have a unique value that we can use to pair
+ data files (like a portable dump image) with a specific build of
+ Emacs. */
+extern unsigned char const fingerprint[32];
+
+#endif
diff --git a/src/floatfns.c b/src/floatfns.c
index 13ecc66fbfa..a913aad5aac 100644
--- a/src/floatfns.c
+++ b/src/floatfns.c
@@ -42,18 +42,12 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <config.h>
#include "lisp.h"
+#include "bignum.h"
#include <math.h>
#include <count-leading-zeros.h>
-#ifndef isfinite
-# define isfinite(x) ((x) - (x) == 0)
-#endif
-#ifndef isnan
-# define isnan(x) ((x) != (x))
-#endif
-
/* Check that X is a floating point number. */
static void
@@ -67,7 +61,7 @@ CHECK_FLOAT (Lisp_Object x)
double
extract_float (Lisp_Object num)
{
- CHECK_NUMBER_OR_FLOAT (num);
+ CHECK_NUMBER (num);
return XFLOATINT (num);
}
@@ -185,7 +179,7 @@ If X is zero, both parts (SGNFCAND and EXP) are zero. */)
double f = extract_float (x);
int exponent;
double sgnfcand = frexp (f, &exponent);
- return Fcons (make_float (sgnfcand), make_number (exponent));
+ return Fcons (make_float (sgnfcand), make_fixnum (exponent));
}
DEFUN ("ldexp", Fldexp, Sldexp, 2, 2, 0,
@@ -193,8 +187,8 @@ DEFUN ("ldexp", Fldexp, Sldexp, 2, 2, 0,
EXPONENT must be an integer. */)
(Lisp_Object sgnfcand, Lisp_Object exponent)
{
- CHECK_NUMBER (exponent);
- int e = min (max (INT_MIN, XINT (exponent)), INT_MAX);
+ CHECK_FIXNUM (exponent);
+ int e = min (max (INT_MIN, XFIXNUM (exponent)), INT_MAX);
return make_float (ldexp (extract_float (sgnfcand), e));
}
@@ -211,29 +205,14 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
doc: /* Return the exponential ARG1 ** ARG2. */)
(Lisp_Object arg1, Lisp_Object arg2)
{
- CHECK_NUMBER_OR_FLOAT (arg1);
- CHECK_NUMBER_OR_FLOAT (arg2);
- if (INTEGERP (arg1) /* common lisp spec */
- && INTEGERP (arg2) /* don't promote, if both are ints, and */
- && XINT (arg2) >= 0) /* we are sure the result is not fractional */
- { /* this can be improved by pre-calculating */
- EMACS_INT y; /* some binary powers of x then accumulating */
- EMACS_UINT acc, x; /* Unsigned so that overflow is well defined. */
- Lisp_Object val;
-
- x = XINT (arg1);
- y = XINT (arg2);
- acc = (y & 1 ? x : 1);
-
- while ((y >>= 1) != 0)
- {
- x *= x;
- if (y & 1)
- acc *= x;
- }
- XSETINT (val, acc);
- return val;
- }
+ CHECK_NUMBER (arg1);
+ CHECK_NUMBER (arg2);
+
+ /* Common Lisp spec: don't promote if both are integers, and if the
+ result is not fractional. */
+ if (INTEGERP (arg1) && !NILP (Fnatnump (arg2)))
+ return expt_integer (arg1, arg2);
+
return make_float (pow (XFLOATINT (arg1), XFLOATINT (arg2)));
}
@@ -273,14 +252,28 @@ DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0,
DEFUN ("abs", Fabs, Sabs, 1, 1, 0,
doc: /* Return the absolute value of ARG. */)
- (register Lisp_Object arg)
+ (Lisp_Object arg)
{
- CHECK_NUMBER_OR_FLOAT (arg);
+ CHECK_NUMBER (arg);
- if (FLOATP (arg))
- arg = make_float (fabs (XFLOAT_DATA (arg)));
- else if (XINT (arg) < 0)
- XSETINT (arg, - XINT (arg));
+ if (FIXNUMP (arg))
+ {
+ if (XFIXNUM (arg) < 0)
+ arg = make_int (-XFIXNUM (arg));
+ }
+ else if (FLOATP (arg))
+ {
+ if (signbit (XFLOAT_DATA (arg)))
+ arg = make_float (- XFLOAT_DATA (arg));
+ }
+ else
+ {
+ if (mpz_sgn (XBIGNUM (arg)->value) < 0)
+ {
+ mpz_neg (mpz[0], XBIGNUM (arg)->value);
+ arg = make_integer_mpz ();
+ }
+ }
return arg;
}
@@ -289,12 +282,9 @@ DEFUN ("float", Ffloat, Sfloat, 1, 1, 0,
doc: /* Return the floating point number equal to ARG. */)
(register Lisp_Object arg)
{
- CHECK_NUMBER_OR_FLOAT (arg);
-
- if (INTEGERP (arg))
- return make_float ((double) XINT (arg));
- else /* give 'em the same float back */
- return arg;
+ CHECK_NUMBER (arg);
+ /* If ARG is a float, give 'em the same float back. */
+ return FLOATP (arg) ? arg : make_float (XFLOATINT (arg));
}
static int
@@ -311,44 +301,54 @@ This is the same as the exponent of a float. */)
(Lisp_Object arg)
{
EMACS_INT value;
- CHECK_NUMBER_OR_FLOAT (arg);
+ CHECK_NUMBER (arg);
if (FLOATP (arg))
{
double f = XFLOAT_DATA (arg);
-
if (f == 0)
- value = MOST_NEGATIVE_FIXNUM;
- else if (isfinite (f))
- {
- int ivalue;
- frexp (f, &ivalue);
- value = ivalue - 1;
- }
- else
- value = MOST_POSITIVE_FIXNUM;
+ return make_float (-HUGE_VAL);
+ if (!isfinite (f))
+ return f < 0 ? make_float (-f) : arg;
+ int ivalue;
+ frexp (f, &ivalue);
+ value = ivalue - 1;
}
+ else if (!FIXNUMP (arg))
+ value = mpz_sizeinbase (XBIGNUM (arg)->value, 2) - 1;
else
{
- EMACS_INT i = eabs (XINT (arg));
- value = (i == 0
- ? MOST_NEGATIVE_FIXNUM
- : EMACS_UINT_WIDTH - 1 - ecount_leading_zeros (i));
+ EMACS_INT i = XFIXNUM (arg);
+ if (i == 0)
+ return make_float (-HUGE_VAL);
+ value = EMACS_UINT_WIDTH - 1 - ecount_leading_zeros (eabs (i));
}
- return make_number (value);
+ return make_fixnum (value);
}
+/* True if A is exactly representable as an integer. */
+
+static bool
+integer_value (Lisp_Object a)
+{
+ if (FLOATP (a))
+ {
+ double d = XFLOAT_DATA (a);
+ return d == floor (d) && isfinite (d);
+ }
+ return true;
+}
/* the rounding functions */
static Lisp_Object
rounding_driver (Lisp_Object arg, Lisp_Object divisor,
double (*double_round) (double),
- EMACS_INT (*int_round2) (EMACS_INT, EMACS_INT),
- const char *name)
+ void (*int_divide) (mpz_t, mpz_t const, mpz_t const),
+ EMACS_INT (*fixnum_divide) (EMACS_INT, EMACS_INT))
{
- CHECK_NUMBER_OR_FLOAT (arg);
+ CHECK_NUMBER (arg);
double d;
if (NILP (divisor))
@@ -359,18 +359,36 @@ rounding_driver (Lisp_Object arg, Lisp_Object divisor,
}
else
{
- CHECK_NUMBER_OR_FLOAT (divisor);
- if (!FLOATP (arg) && !FLOATP (divisor))
+ CHECK_NUMBER (divisor);
+ if (integer_value (arg) && integer_value (divisor))
{
- if (XINT (divisor) == 0)
- xsignal0 (Qarith_error);
- return make_number (int_round2 (XINT (arg), XINT (divisor)));
+ /* Divide as integers. Converting to double might lose
+ info, even for fixnums; also see the FIXME below. */
+
+ if (FLOATP (arg))
+ arg = double_to_integer (XFLOAT_DATA (arg));
+ if (FLOATP (divisor))
+ divisor = double_to_integer (XFLOAT_DATA (divisor));
+
+ if (FIXNUMP (divisor))
+ {
+ if (XFIXNUM (divisor) == 0)
+ xsignal0 (Qarith_error);
+ if (FIXNUMP (arg))
+ return make_int (fixnum_divide (XFIXNUM (arg),
+ XFIXNUM (divisor)));
+ }
+ int_divide (mpz[0],
+ *bignum_integer (&mpz[0], arg),
+ *bignum_integer (&mpz[1], divisor));
+ return make_integer_mpz ();
}
- double f1 = FLOATP (arg) ? XFLOAT_DATA (arg) : XINT (arg);
- double f2 = FLOATP (divisor) ? XFLOAT_DATA (divisor) : XINT (divisor);
+ double f1 = XFLOATINT (arg);
+ double f2 = XFLOATINT (divisor);
if (! IEEE_FLOATING_POINT && f2 == 0)
xsignal0 (Qarith_error);
+ /* FIXME: This division rounds, so the result is double-rounded. */
d = f1 / f2;
}
@@ -383,42 +401,61 @@ rounding_driver (Lisp_Object arg, Lisp_Object divisor,
{
EMACS_INT ir = dr;
if (! FIXNUM_OVERFLOW_P (ir))
- return make_number (ir);
+ return make_fixnum (ir);
}
- xsignal2 (Qrange_error, build_string (name), arg);
+ return double_to_integer (dr);
}
static EMACS_INT
-ceiling2 (EMACS_INT i1, EMACS_INT i2)
+ceiling2 (EMACS_INT n, EMACS_INT d)
{
- return i1 / i2 + ((i1 % i2 != 0) & ((i1 < 0) == (i2 < 0)));
+ return n / d + ((n % d != 0) & ((n < 0) == (d < 0)));
}
static EMACS_INT
-floor2 (EMACS_INT i1, EMACS_INT i2)
+floor2 (EMACS_INT n, EMACS_INT d)
{
- return i1 / i2 - ((i1 % i2 != 0) & ((i1 < 0) != (i2 < 0)));
+ return n / d - ((n % d != 0) & ((n < 0) != (d < 0)));
}
static EMACS_INT
-truncate2 (EMACS_INT i1, EMACS_INT i2)
+truncate2 (EMACS_INT n, EMACS_INT d)
{
- return i1 / i2;
+ return n / d;
}
static EMACS_INT
-round2 (EMACS_INT i1, EMACS_INT i2)
-{
- /* The C language's division operator gives us one remainder R, but
- we want the remainder R1 on the other side of 0 if R1 is closer
- to 0 than R is; because we want to round to even, we also want R1
- if R and R1 are the same distance from 0 and if C's quotient is
- odd. */
- EMACS_INT q = i1 / i2;
- EMACS_INT r = i1 % i2;
+round2 (EMACS_INT n, EMACS_INT d)
+{
+ /* The C language's division operator gives us the remainder R
+ corresponding to truncated division, but we want the remainder R1
+ on the other side of 0 if R1 is closer to 0 than R is; because we
+ want to round to even, we also want R1 if R and R1 are the same
+ distance from 0 and if the truncated quotient is odd. */
+ EMACS_INT q = n / d;
+ EMACS_INT r = n % d;
+ bool neg_d = d < 0;
+ bool neg_r = r < 0;
EMACS_INT abs_r = eabs (r);
- EMACS_INT abs_r1 = eabs (i2) - abs_r;
- return q + (abs_r + (q & 1) <= abs_r1 ? 0 : (i2 ^ r) < 0 ? -1 : 1);
+ EMACS_INT abs_r1 = eabs (d) - abs_r;
+ if (abs_r1 < abs_r + (q & 1))
+ q += neg_d == neg_r ? 1 : -1;
+ return q;
+}
+
+static void
+rounddiv_q (mpz_t q, mpz_t const n, mpz_t const d)
+{
+ /* Mimic the source code of round2, using mpz_t instead of EMACS_INT. */
+ mpz_t *r = &mpz[2], *abs_r = r, *abs_r1 = &mpz[3];
+ mpz_tdiv_qr (q, *r, n, d);
+ bool neg_d = mpz_sgn (d) < 0;
+ bool neg_r = mpz_sgn (*r) < 0;
+ mpz_abs (*abs_r, *r);
+ mpz_abs (*abs_r1, d);
+ mpz_sub (*abs_r1, *abs_r1, *abs_r);
+ if (mpz_cmp (*abs_r1, *abs_r) < (mpz_odd_p (q) != 0))
+ (neg_d == neg_r ? mpz_add_ui : mpz_sub_ui) (q, q, 1);
}
/* The code uses emacs_rint, so that it works to undefine HAVE_RINT
@@ -435,11 +472,9 @@ emacs_rint (double d)
}
#endif
-#ifdef HAVE_TRUNC
-#define emacs_trunc trunc
-#else
-static double
-emacs_trunc (double d)
+#ifndef HAVE_TRUNC
+double
+trunc (double d)
{
return (d < 0 ? ceil : floor) (d);
}
@@ -451,7 +486,7 @@ This rounds the value towards +inf.
With optional DIVISOR, return the smallest integer no less than ARG/DIVISOR. */)
(Lisp_Object arg, Lisp_Object divisor)
{
- return rounding_driver (arg, divisor, ceil, ceiling2, "ceiling");
+ return rounding_driver (arg, divisor, ceil, mpz_cdiv_q, ceiling2);
}
DEFUN ("floor", Ffloor, Sfloor, 1, 2, 0,
@@ -460,7 +495,7 @@ This rounds the value towards -inf.
With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR. */)
(Lisp_Object arg, Lisp_Object divisor)
{
- return rounding_driver (arg, divisor, floor, floor2, "floor");
+ return rounding_driver (arg, divisor, floor, mpz_fdiv_q, floor2);
}
DEFUN ("round", Fround, Sround, 1, 2, 0,
@@ -473,7 +508,14 @@ your machine. For example, (round 2.5) can return 3 on some
systems, but 2 on others. */)
(Lisp_Object arg, Lisp_Object divisor)
{
- return rounding_driver (arg, divisor, emacs_rint, round2, "round");
+ return rounding_driver (arg, divisor, emacs_rint, rounddiv_q, round2);
+}
+
+/* Since rounding_driver truncates anyway, no need to call 'trunc'. */
+static double
+identity (double x)
+{
+ return x;
}
DEFUN ("truncate", Ftruncate, Struncate, 1, 2, 0,
@@ -482,18 +524,15 @@ Rounds ARG toward zero.
With optional DIVISOR, truncate ARG/DIVISOR. */)
(Lisp_Object arg, Lisp_Object divisor)
{
- return rounding_driver (arg, divisor, emacs_trunc, truncate2,
- "truncate");
+ return rounding_driver (arg, divisor, identity, mpz_tdiv_q, truncate2);
}
Lisp_Object
fmod_float (Lisp_Object x, Lisp_Object y)
{
- double f1, f2;
-
- f1 = FLOATP (x) ? XFLOAT_DATA (x) : XINT (x);
- f2 = FLOATP (y) ? XFLOAT_DATA (y) : XINT (y);
+ double f1 = XFLOATINT (x);
+ double f2 = XFLOATINT (y);
f1 = fmod (f1, f2);
@@ -543,7 +582,7 @@ DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0,
{
CHECK_FLOAT (arg);
double d = XFLOAT_DATA (arg);
- d = emacs_trunc (d);
+ d = trunc (d);
return make_float (d);
}
diff --git a/src/fns.c b/src/fns.c
index d6299755201..c3202495daf 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -28,6 +28,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <errno.h>
#include "lisp.h"
+#include "bignum.h"
#include "character.h"
#include "coding.h"
#include "composite.h"
@@ -56,15 +57,12 @@ DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
}
DEFUN ("random", Frandom, Srandom, 0, 1, 0,
- doc: /* Return a pseudo-random number.
-All integers representable in Lisp, i.e. between `most-negative-fixnum'
-and `most-positive-fixnum', inclusive, are equally likely.
-
-With positive integer LIMIT, return random number in interval [0,LIMIT).
+ doc: /* Return a pseudo-random integer.
+By default, return a fixnum; all fixnums are equally likely.
+With positive fixnum LIMIT, return random integer in interval [0,LIMIT).
With argument t, set the random number seed from the system's entropy
pool if available, otherwise from less-random volatile data such as the time.
With a string argument, set the seed based on the string's contents.
-Other values of LIMIT are ignored.
See Info node `(elisp)Random Numbers' for more details. */)
(Lisp_Object limit)
@@ -77,71 +75,96 @@ See Info node `(elisp)Random Numbers' for more details. */)
seed_random (SSDATA (limit), SBYTES (limit));
val = get_random ();
- if (INTEGERP (limit) && 0 < XINT (limit))
+ if (FIXNUMP (limit) && 0 < XFIXNUM (limit))
while (true)
{
/* Return the remainder, except reject the rare case where
get_random returns a number so close to INTMASK that the
remainder isn't random. */
- EMACS_INT remainder = val % XINT (limit);
- if (val - remainder <= INTMASK - XINT (limit) + 1)
- return make_number (remainder);
+ EMACS_INT remainder = val % XFIXNUM (limit);
+ if (val - remainder <= INTMASK - XFIXNUM (limit) + 1)
+ return make_fixnum (remainder);
val = get_random ();
}
- return make_number (val);
+ return make_fixnum (val);
}
/* Random data-structure functions. */
+/* Return LIST's length. Signal an error if LIST is not a proper list. */
+
+ptrdiff_t
+list_length (Lisp_Object list)
+{
+ intptr_t i = 0;
+ FOR_EACH_TAIL (list)
+ i++;
+ CHECK_LIST_END (list, list);
+ return i;
+}
+
+
DEFUN ("length", Flength, Slength, 1, 1, 0,
doc: /* Return the length of vector, list or string SEQUENCE.
A byte-code function object is also allowed.
If the string contains multibyte characters, this is not necessarily
the number of bytes in the string; it is the number of characters.
To get the number of bytes, use `string-bytes'. */)
- (register Lisp_Object sequence)
+ (Lisp_Object sequence)
{
- register Lisp_Object val;
+ EMACS_INT val;
if (STRINGP (sequence))
- XSETFASTINT (val, SCHARS (sequence));
+ val = SCHARS (sequence);
else if (VECTORP (sequence))
- XSETFASTINT (val, ASIZE (sequence));
+ val = ASIZE (sequence);
else if (CHAR_TABLE_P (sequence))
- XSETFASTINT (val, MAX_CHAR);
+ val = MAX_CHAR;
else if (BOOL_VECTOR_P (sequence))
- XSETFASTINT (val, bool_vector_size (sequence));
+ val = bool_vector_size (sequence);
else if (COMPILEDP (sequence) || RECORDP (sequence))
- XSETFASTINT (val, PVSIZE (sequence));
+ val = PVSIZE (sequence);
else if (CONSP (sequence))
- {
- intptr_t i = 0;
- FOR_EACH_TAIL (sequence)
- i++;
- CHECK_LIST_END (sequence, sequence);
- if (MOST_POSITIVE_FIXNUM < i)
- error ("List too long");
- val = make_number (i);
- }
+ val = list_length (sequence);
else if (NILP (sequence))
- XSETFASTINT (val, 0);
+ val = 0;
else
wrong_type_argument (Qsequencep, sequence);
- return val;
+ return make_fixnum (val);
}
DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
doc: /* Return the length of a list, but avoid error or infinite loop.
This function never gets an error. If LIST is not really a list,
-it returns 0. If LIST is circular, it returns a finite value
-which is at least the number of distinct elements. */)
+it returns 0. If LIST is circular, it returns an integer that is at
+least the number of distinct elements. */)
(Lisp_Object list)
{
intptr_t len = 0;
FOR_EACH_TAIL_SAFE (list)
len++;
- return make_fixnum_or_float (len);
+ return make_fixnum (len);
+}
+
+DEFUN ("proper-list-p", Fproper_list_p, Sproper_list_p, 1, 1, 0,
+ doc: /* Return OBJECT's length if it is a proper list, nil otherwise.
+A proper list is neither circular nor dotted (i.e., its last cdr is nil). */
+ attributes: const)
+ (Lisp_Object object)
+{
+ intptr_t len = 0;
+ Lisp_Object last_tail = object;
+ Lisp_Object tail = object;
+ FOR_EACH_TAIL_SAFE (tail)
+ {
+ len++;
+ rarely_quit (len);
+ last_tail = XCDR (tail);
+ }
+ if (!NILP (last_tail))
+ return Qnil;
+ return make_fixnum (len);
}
DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
@@ -150,7 +173,73 @@ If STRING is multibyte, this may be greater than the length of STRING. */)
(Lisp_Object string)
{
CHECK_STRING (string);
- return make_number (SBYTES (string));
+ return make_fixnum (SBYTES (string));
+}
+
+DEFUN ("string-distance", Fstring_distance, Sstring_distance, 2, 3, 0,
+ doc: /* Return Levenshtein distance between STRING1 and STRING2.
+The distance is the number of deletions, insertions, and substitutions
+required to transform STRING1 into STRING2.
+If BYTECOMPARE is nil or omitted, compute distance in terms of characters.
+If BYTECOMPARE is non-nil, compute distance in terms of bytes.
+Letter-case is significant, but text properties are ignored. */)
+ (Lisp_Object string1, Lisp_Object string2, Lisp_Object bytecompare)
+
+{
+ CHECK_STRING (string1);
+ CHECK_STRING (string2);
+
+ bool use_byte_compare =
+ !NILP (bytecompare)
+ || (!STRING_MULTIBYTE (string1) && !STRING_MULTIBYTE (string2));
+ ptrdiff_t len1 = use_byte_compare ? SBYTES (string1) : SCHARS (string1);
+ ptrdiff_t len2 = use_byte_compare ? SBYTES (string2) : SCHARS (string2);
+ ptrdiff_t x, y, lastdiag, olddiag;
+
+ USE_SAFE_ALLOCA;
+ ptrdiff_t *column = SAFE_ALLOCA ((len1 + 1) * sizeof (ptrdiff_t));
+ for (y = 1; y <= len1; y++)
+ column[y] = y;
+
+ if (use_byte_compare)
+ {
+ char *s1 = SSDATA (string1);
+ char *s2 = SSDATA (string2);
+
+ for (x = 1; x <= len2; x++)
+ {
+ column[0] = x;
+ for (y = 1, lastdiag = x - 1; y <= len1; y++)
+ {
+ olddiag = column[y];
+ column[y] = min (min (column[y] + 1, column[y-1] + 1),
+ lastdiag + (s1[y-1] == s2[x-1] ? 0 : 1));
+ lastdiag = olddiag;
+ }
+ }
+ }
+ else
+ {
+ int c1, c2;
+ ptrdiff_t i1, i1_byte, i2 = 0, i2_byte = 0;
+ for (x = 1; x <= len2; x++)
+ {
+ column[0] = x;
+ FETCH_STRING_CHAR_ADVANCE (c2, string2, i2, i2_byte);
+ i1 = i1_byte = 0;
+ for (y = 1, lastdiag = x - 1; y <= len1; y++)
+ {
+ olddiag = column[y];
+ FETCH_STRING_CHAR_ADVANCE (c1, string1, i1, i1_byte);
+ column[y] = min (min (column[y] + 1, column[y-1] + 1),
+ lastdiag + (c1 == c2 ? 0 : 1));
+ lastdiag = olddiag;
+ }
+ }
+ }
+
+ SAFE_FREE ();
+ return make_fixnum (column[len1]);
}
DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
@@ -204,10 +293,10 @@ If string STR1 is greater, the value is a positive number N;
/* For backward compatibility, silently bring too-large positive end
values into range. */
- if (INTEGERP (end1) && SCHARS (str1) < XINT (end1))
- end1 = make_number (SCHARS (str1));
- if (INTEGERP (end2) && SCHARS (str2) < XINT (end2))
- end2 = make_number (SCHARS (str2));
+ if (FIXNUMP (end1) && SCHARS (str1) < XFIXNUM (end1))
+ end1 = make_fixnum (SCHARS (str1));
+ if (FIXNUMP (end2) && SCHARS (str2) < XFIXNUM (end2))
+ end2 = make_fixnum (SCHARS (str2));
validate_subarray (str1, start1, end1, SCHARS (str1), &from1, &to1);
validate_subarray (str2, start2, end2, SCHARS (str2), &from2, &to2);
@@ -232,8 +321,8 @@ If string STR1 is greater, the value is a positive number N;
if (! NILP (ignore_case))
{
- c1 = XINT (Fupcase (make_number (c1)));
- c2 = XINT (Fupcase (make_number (c2)));
+ c1 = XFIXNUM (Fupcase (make_fixnum (c1)));
+ c2 = XFIXNUM (Fupcase (make_fixnum (c2)));
}
if (c1 == c2)
@@ -243,15 +332,15 @@ If string STR1 is greater, the value is a positive number N;
past the character that we are comparing;
hence we don't add or subtract 1 here. */
if (c1 < c2)
- return make_number (- i1 + from1);
+ return make_fixnum (- i1 + from1);
else
- return make_number (i1 - from1);
+ return make_fixnum (i1 - from1);
}
if (i1 < to1)
- return make_number (i1 - from1 + 1);
+ return make_fixnum (i1 - from1 + 1);
if (i2 < to2)
- return make_number (- i1 + from1 - 1);
+ return make_fixnum (- i1 + from1 - 1);
return Qt;
}
@@ -323,7 +412,7 @@ Symbols are also allowed; their print names are used instead. */)
while ((cmp = filevercmp (p1, p2)) == 0)
{
- /* If the strings are identical through their first null bytes,
+ /* If the strings are identical through their first NUL bytes,
skip past identical prefixes and try again. */
ptrdiff_t size = strlen (p1) + 1;
p1 += size;
@@ -579,7 +668,7 @@ concat (ptrdiff_t nargs, Lisp_Object *args,
{
EMACS_INT len;
this = args[argnum];
- len = XFASTINT (Flength (this));
+ len = XFIXNAT (Flength (this));
if (target_type == Lisp_String)
{
/* We must count the number of bytes needed in the string
@@ -594,7 +683,7 @@ concat (ptrdiff_t nargs, Lisp_Object *args,
{
ch = AREF (this, i);
CHECK_CHARACTER (ch);
- c = XFASTINT (ch);
+ c = XFIXNAT (ch);
this_len_byte = CHAR_BYTES (c);
if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
string_overflow ();
@@ -603,13 +692,13 @@ concat (ptrdiff_t nargs, Lisp_Object *args,
some_multibyte = 1;
}
else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
- wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
+ wrong_type_argument (Qintegerp, Faref (this, make_fixnum (0)));
else if (CONSP (this))
for (; CONSP (this); this = XCDR (this))
{
ch = XCAR (this);
CHECK_CHARACTER (ch);
- c = XFASTINT (ch);
+ c = XFIXNAT (ch);
this_len_byte = CHAR_BYTES (c);
if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
string_overflow ();
@@ -643,16 +732,16 @@ concat (ptrdiff_t nargs, Lisp_Object *args,
/* Create the output object. */
if (target_type == Lisp_Cons)
- val = Fmake_list (make_number (result_len), Qnil);
+ val = Fmake_list (make_fixnum (result_len), Qnil);
else if (target_type == Lisp_Vectorlike)
- val = Fmake_vector (make_number (result_len), Qnil);
+ val = make_nil_vector (result_len);
else if (some_multibyte)
val = make_uninit_multibyte_string (result_len, result_len_byte);
else
val = make_uninit_string (result_len);
/* In `append', if all but last arg are nil, return last arg. */
- if (target_type == Lisp_Cons && EQ (val, Qnil))
+ if (target_type == Lisp_Cons && NILP (val))
return last_tail;
/* Copy the contents of the args into the result. */
@@ -674,7 +763,7 @@ concat (ptrdiff_t nargs, Lisp_Object *args,
this = args[argnum];
if (!CONSP (this))
- thislen = Flength (this), thisleni = XINT (thislen);
+ thislen = Flength (this), thisleni = XFIXNUM (thislen);
/* Between strings of the same kind, copy fast. */
if (STRINGP (this) && STRINGP (val)
@@ -761,7 +850,7 @@ concat (ptrdiff_t nargs, Lisp_Object *args,
{
int c;
CHECK_CHARACTER (elt);
- c = XFASTINT (elt);
+ c = XFIXNAT (elt);
if (some_multibyte)
toindex_byte += CHAR_STRING (c, SDATA (val) + toindex_byte);
else
@@ -782,15 +871,15 @@ concat (ptrdiff_t nargs, Lisp_Object *args,
{
this = args[textprops[argnum].argnum];
props = text_property_list (this,
- make_number (0),
- make_number (SCHARS (this)),
+ make_fixnum (0),
+ make_fixnum (SCHARS (this)),
Qnil);
/* If successive arguments have properties, be sure that the
value of `composition' property be the copy. */
if (last_to_end == textprops[argnum].to)
make_composition_value_copy (props);
add_text_properties_from_list (val, props,
- make_number (textprops[argnum].to));
+ make_fixnum (textprops[argnum].to));
last_to_end = textprops[argnum].to + SCHARS (this);
}
}
@@ -1192,9 +1281,9 @@ validate_subarray (Lisp_Object array, Lisp_Object from, Lisp_Object to,
{
EMACS_INT f, t;
- if (INTEGERP (from))
+ if (FIXNUMP (from))
{
- f = XINT (from);
+ f = XFIXNUM (from);
if (f < 0)
f += size;
}
@@ -1203,9 +1292,9 @@ validate_subarray (Lisp_Object array, Lisp_Object from, Lisp_Object to,
else
wrong_type_argument (Qintegerp, from);
- if (INTEGERP (to))
+ if (FIXNUMP (to))
{
- t = XINT (to);
+ t = XFIXNUM (to);
if (t < 0)
t += size;
}
@@ -1251,8 +1340,8 @@ With one argument, just copy STRING (with properties, if any). */)
res = make_specified_string (SSDATA (string) + from_byte,
ito - ifrom, to_byte - from_byte,
STRING_MULTIBYTE (string));
- copy_text_properties (make_number (ifrom), make_number (ito),
- string, make_number (0), res, Qnil);
+ copy_text_properties (make_fixnum (ifrom), make_fixnum (ito),
+ string, make_fixnum (0), res, Qnil);
}
else
res = Fvector (ito - ifrom, aref_addr (string, ifrom));
@@ -1297,15 +1386,15 @@ substring_both (Lisp_Object string, ptrdiff_t from, ptrdiff_t from_byte,
ptrdiff_t size = CHECK_VECTOR_OR_STRING (string);
if (!(0 <= from && from <= to && to <= size))
- args_out_of_range_3 (string, make_number (from), make_number (to));
+ args_out_of_range_3 (string, make_fixnum (from), make_fixnum (to));
if (STRINGP (string))
{
res = make_specified_string (SSDATA (string) + from_byte,
to - from, to_byte - from_byte,
STRING_MULTIBYTE (string));
- copy_text_properties (make_number (from), make_number (to),
- string, make_number (0), res, Qnil);
+ copy_text_properties (make_fixnum (from), make_fixnum (to),
+ string, make_fixnum (0), res, Qnil);
}
else
res = Fvector (to - from, aref_addr (string, from));
@@ -1317,15 +1406,89 @@ DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
doc: /* Take cdr N times on LIST, return the result. */)
(Lisp_Object n, Lisp_Object list)
{
- CHECK_NUMBER (n);
Lisp_Object tail = list;
- for (EMACS_INT num = XINT (n); 0 < num; num--)
+
+ CHECK_INTEGER (n);
+
+ /* A huge but in-range EMACS_INT that can be substituted for a
+ positive bignum while counting down. It does not introduce
+ miscounts because a list or cycle cannot possibly be this long,
+ and any counting error is fixed up later. */
+ EMACS_INT large_num = EMACS_INT_MAX;
+
+ EMACS_INT num;
+ if (FIXNUMP (n))
{
- if (! CONSP (tail))
+ num = XFIXNUM (n);
+
+ /* Speed up small lists by omitting circularity and quit checking. */
+ if (num <= SMALL_LIST_LEN_MAX)
+ {
+ for (; 0 < num; num--, tail = XCDR (tail))
+ if (! CONSP (tail))
+ {
+ CHECK_LIST_END (tail, list);
+ return Qnil;
+ }
+ return tail;
+ }
+ }
+ else
+ {
+ if (mpz_sgn (XBIGNUM (n)->value) < 0)
+ return tail;
+ num = large_num;
+ }
+
+ EMACS_INT tortoise_num = num;
+ Lisp_Object saved_tail = tail;
+ FOR_EACH_TAIL_SAFE (tail)
+ {
+ /* If the tortoise just jumped (which is rare),
+ update TORTOISE_NUM accordingly. */
+ if (EQ (tail, li.tortoise))
+ tortoise_num = num;
+
+ saved_tail = XCDR (tail);
+ num--;
+ if (num == 0)
+ return saved_tail;
+ rarely_quit (num);
+ }
+
+ tail = saved_tail;
+ if (! CONSP (tail))
+ {
+ CHECK_LIST_END (tail, list);
+ return Qnil;
+ }
+
+ /* TAIL is part of a cycle. Reduce NUM modulo the cycle length to
+ avoid going around this cycle repeatedly. */
+ intptr_t cycle_length = tortoise_num - num;
+ if (! FIXNUMP (n))
+ {
+ /* Undo any error introduced when LARGE_NUM was substituted for
+ N, by adding N - LARGE_NUM to NUM, using arithmetic modulo
+ CYCLE_LENGTH. */
+ /* Add N mod CYCLE_LENGTH to NUM. */
+ if (cycle_length <= ULONG_MAX)
+ num += mpz_tdiv_ui (XBIGNUM (n)->value, cycle_length);
+ else
{
- CHECK_LIST_END (tail, list);
- return Qnil;
+ mpz_set_intmax (mpz[0], cycle_length);
+ mpz_tdiv_r (mpz[0], XBIGNUM (n)->value, mpz[0]);
+ intptr_t iz;
+ mpz_export (&iz, NULL, -1, sizeof iz, 0, 0, mpz[0]);
+ num += iz;
}
+ num += cycle_length - large_num % cycle_length;
+ }
+ num %= cycle_length;
+
+ /* One last time through the cycle. */
+ for (; 0 < num; num--)
+ {
tail = XCDR (tail);
rarely_quit (num);
}
@@ -1342,9 +1505,8 @@ N counts from zero. If LIST is not that long, nil is returned. */)
DEFUN ("elt", Felt, Selt, 2, 2, 0,
doc: /* Return element of SEQUENCE at index N. */)
- (register Lisp_Object sequence, Lisp_Object n)
+ (Lisp_Object sequence, Lisp_Object n)
{
- CHECK_NUMBER (n);
if (CONSP (sequence) || NILP (sequence))
return Fcar (Fnthcdr (n, sequence));
@@ -1353,6 +1515,29 @@ DEFUN ("elt", Felt, Selt, 2, 2, 0,
return Faref (sequence, n);
}
+enum { WORDS_PER_DOUBLE = (sizeof (double) / sizeof (EMACS_UINT)
+ + (sizeof (double) % sizeof (EMACS_UINT) != 0)) };
+union double_and_words
+{
+ double val;
+ EMACS_UINT word[WORDS_PER_DOUBLE];
+};
+
+/* Return true if X and Y are the same floating-point value.
+ This looks at X's and Y's representation, since (unlike '==')
+ it returns true if X and Y are the same NaN. */
+static bool
+same_float (Lisp_Object x, Lisp_Object y)
+{
+ union double_and_words
+ xu = { .val = XFLOAT_DATA (x) },
+ yu = { .val = XFLOAT_DATA (y) };
+ EMACS_UINT neql = 0;
+ for (int i = 0; i < WORDS_PER_DOUBLE; i++)
+ neql |= xu.word[i] ^ yu.word[i];
+ return !neql;
+}
+
DEFUN ("member", Fmember, Smember, 2, 2, 0,
doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
The value is actually the tail of LIST whose car is ELT. */)
@@ -1391,7 +1576,7 @@ The value is actually the tail of LIST whose car is ELT. */)
FOR_EACH_TAIL (tail)
{
Lisp_Object tem = XCAR (tail);
- if (FLOATP (tem) && equal_no_quit (elt, tem))
+ if (FLOATP (tem) && same_float (elt, tem))
return tail;
}
CHECK_LIST_END (tail, list);
@@ -1579,7 +1764,7 @@ changing the value of a sequence `foo'. */)
cbytes = 1;
}
- if (!INTEGERP (elt) || c != XINT (elt))
+ if (!FIXNUMP (elt) || c != XFIXNUM (elt))
{
++nchars;
nbytes += cbytes;
@@ -1609,7 +1794,7 @@ changing the value of a sequence `foo'. */)
cbytes = 1;
}
- if (!INTEGERP (elt) || c != XINT (elt))
+ if (!FIXNUMP (elt) || c != XFIXNUM (elt))
{
unsigned char *from = SDATA (seq) + ibyte;
unsigned char *to = SDATA (tem) + nbytes;
@@ -1774,24 +1959,15 @@ See also the function `nreverse', which is used more often. */)
static Lisp_Object
sort_list (Lisp_Object list, Lisp_Object predicate)
{
- Lisp_Object front, back;
- Lisp_Object len, tem;
- EMACS_INT length;
-
- front = list;
- len = Flength (list);
- length = XINT (len);
+ ptrdiff_t length = list_length (list);
if (length < 2)
return list;
- XSETINT (len, (length / 2) - 1);
- tem = Fnthcdr (len, list);
- back = Fcdr (tem);
+ Lisp_Object tem = Fnthcdr (make_fixnum (length / 2 - 1), list);
+ Lisp_Object back = Fcdr (tem);
Fsetcdr (tem, Qnil);
- front = Fsort (front, predicate);
- back = Fsort (back, predicate);
- return merge (front, back, predicate);
+ return merge (Fsort (list, predicate), Fsort (back, predicate), predicate);
}
/* Using PRED to compare, return whether A and B are in order.
@@ -1889,7 +2065,7 @@ sort_vector (Lisp_Object vector, Lisp_Object predicate)
USE_SAFE_ALLOCA;
SAFE_ALLOCA_LISP (tmp, halflen);
for (ptrdiff_t i = 0; i < halflen; i++)
- tmp[i] = make_number (0);
+ tmp[i] = make_fixnum (0);
sort_vector_inplace (predicate, len, XVECTOR (vector)->contents, tmp);
SAFE_FREE ();
}
@@ -1907,7 +2083,7 @@ the second. */)
else if (VECTORP (seq))
sort_vector (seq, predicate);
else if (!NILP (seq))
- wrong_type_argument (Qsequencep, seq);
+ wrong_type_argument (Qlist_or_vector_p, seq);
return seq;
}
@@ -2104,11 +2280,15 @@ The PLIST is modified by side effects. */)
}
DEFUN ("eql", Feql, Seql, 2, 2, 0,
- doc: /* Return t if the two args are the same Lisp object.
-Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
+ doc: /* Return t if the two args are `eq' or are indistinguishable numbers.
+Floating-point values with the same sign, exponent and fraction are `eql'.
+This differs from numeric comparison: (eql 0.0 -0.0) returns nil and
+\(eql 0.0e+NaN 0.0e+NaN) returns t, whereas `=' does the opposite. */)
(Lisp_Object obj1, Lisp_Object obj2)
{
if (FLOATP (obj1))
+ return FLOATP (obj2) && same_float (obj1, obj2) ? Qt : Qnil;
+ else if (BIGNUMP (obj1))
return equal_no_quit (obj1, obj2) ? Qt : Qnil;
else
return EQ (obj1, obj2) ? Qt : Qnil;
@@ -2119,8 +2299,8 @@ DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
They must have the same data type.
Conses are compared by comparing the cars and the cdrs.
Vectors and strings are compared element by element.
-Numbers are compared by value, but integers cannot equal floats.
- (Use `=' if you want integers and floats to be able to be equal.)
+Numbers are compared via `eql', so integers do not equal floats.
+\(Use `=' if you want integers and floats to be able to be equal.)
Symbols must match exactly. */)
(Lisp_Object o1, Lisp_Object o2)
{
@@ -2172,7 +2352,7 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind,
ht = CALLN (Fmake_hash_table, QCtest, Qeq);
switch (XTYPE (o1))
{
- case Lisp_Cons: case Lisp_Misc: case Lisp_Vectorlike:
+ case Lisp_Cons: case Lisp_Vectorlike:
{
struct Lisp_Hash_Table *h = XHASH_TABLE (ht);
EMACS_UINT hash;
@@ -2200,13 +2380,7 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind,
switch (XTYPE (o1))
{
case Lisp_Float:
- {
- double d1 = XFLOAT_DATA (o1);
- double d2 = XFLOAT_DATA (o2);
- /* If d is a NaN, then d != d. Two NaNs should be `equal' even
- though they are not =. */
- return d1 == d2 || (d1 != d1 && d2 != d2);
- }
+ return same_float (o1, o2);
case Lisp_Cons:
if (equal_kind == EQUAL_NO_QUIT)
@@ -2235,29 +2409,6 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind,
depth++;
goto tail_recurse;
- case Lisp_Misc:
- if (XMISCTYPE (o1) != XMISCTYPE (o2))
- return false;
- if (OVERLAYP (o1))
- {
- if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2),
- equal_kind, depth + 1, ht)
- || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2),
- equal_kind, depth + 1, ht))
- return false;
- o1 = XOVERLAY (o1)->plist;
- o2 = XOVERLAY (o2)->plist;
- depth++;
- goto tail_recurse;
- }
- if (MARKERP (o1))
- {
- return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
- && (XMARKER (o1)->buffer == 0
- || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos));
- }
- break;
-
case Lisp_Vectorlike:
{
register int i;
@@ -2267,6 +2418,26 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind,
same size. */
if (ASIZE (o2) != size)
return false;
+ if (BIGNUMP (o1))
+ return mpz_cmp (XBIGNUM (o1)->value, XBIGNUM (o2)->value) == 0;
+ if (OVERLAYP (o1))
+ {
+ if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2),
+ equal_kind, depth + 1, ht)
+ || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2),
+ equal_kind, depth + 1, ht))
+ return false;
+ o1 = XOVERLAY (o1)->plist;
+ o2 = XOVERLAY (o2)->plist;
+ depth++;
+ goto tail_recurse;
+ }
+ if (MARKERP (o1))
+ {
+ return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
+ && (XMARKER (o1)->buffer == 0
+ || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos));
+ }
/* Boolvectors are compared much like strings. */
if (BOOL_VECTOR_P (o1))
{
@@ -2349,7 +2520,7 @@ ARRAY is a vector, string, char-table, or bool-vector. */)
register unsigned char *p = SDATA (array);
int charval;
CHECK_CHARACTER (item);
- charval = XFASTINT (item);
+ charval = XFIXNAT (item);
size = SCHARS (array);
if (STRING_MULTIBYTE (array))
{
@@ -2416,7 +2587,7 @@ usage: (nconc &rest LISTS) */)
CHECK_CONS (tem);
- Lisp_Object tail;
+ Lisp_Object tail UNINIT;
FOR_EACH_TAIL (tem)
tail = tem;
@@ -2501,7 +2672,7 @@ SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
(Lisp_Object function, Lisp_Object sequence, Lisp_Object separator)
{
USE_SAFE_ALLOCA;
- EMACS_INT leni = XFASTINT (Flength (sequence));
+ EMACS_INT leni = XFIXNAT (Flength (sequence));
if (CHAR_TABLE_P (sequence))
wrong_type_argument (Qlistp, sequence);
EMACS_INT args_alloc = 2 * leni - 1;
@@ -2530,7 +2701,7 @@ SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
(Lisp_Object function, Lisp_Object sequence)
{
USE_SAFE_ALLOCA;
- EMACS_INT leni = XFASTINT (Flength (sequence));
+ EMACS_INT leni = XFIXNAT (Flength (sequence));
if (CHAR_TABLE_P (sequence))
wrong_type_argument (Qlistp, sequence);
Lisp_Object *args;
@@ -2549,7 +2720,7 @@ SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
{
register EMACS_INT leni;
- leni = XFASTINT (Flength (sequence));
+ leni = XFIXNAT (Flength (sequence));
if (CHAR_TABLE_P (sequence))
wrong_type_argument (Qlistp, sequence);
mapcar1 (leni, 0, function, sequence);
@@ -2564,7 +2735,7 @@ SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
(Lisp_Object function, Lisp_Object sequence)
{
USE_SAFE_ALLOCA;
- EMACS_INT leni = XFASTINT (Flength (sequence));
+ EMACS_INT leni = XFIXNAT (Flength (sequence));
if (CHAR_TABLE_P (sequence))
wrong_type_argument (Qlistp, sequence);
Lisp_Object *args;
@@ -2629,7 +2800,7 @@ if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
Fding (Qnil);
Fdiscard_input ();
message1 ("Please answer yes or no.");
- Fsleep_for (make_number (2), Qnil);
+ Fsleep_for (make_fixnum (2), Qnil);
}
}
@@ -2661,7 +2832,7 @@ advisable. */)
while (loads-- > 0)
{
Lisp_Object load = (NILP (use_floats)
- ? make_number (100.0 * load_ave[loads])
+ ? make_fixnum (100.0 * load_ave[loads])
: make_float (load_ave[loads]));
ret = Fcons (load, ret);
}
@@ -2697,7 +2868,7 @@ particular subfeatures supported in this version of FEATURE. */)
CHECK_SYMBOL (feature);
CHECK_LIST (subfeatures);
if (!NILP (Vautoload_queue))
- Vautoload_queue = Fcons (Fcons (make_number (0), Vfeatures),
+ Vautoload_queue = Fcons (Fcons (make_fixnum (0), Vfeatures),
Vautoload_queue);
tem = Fmemq (feature, Vfeatures);
if (NILP (tem))
@@ -2777,7 +2948,7 @@ suppressed. */)
/* This is to make sure that loadup.el gives a clear picture
of what files are preloaded and when. */
- if (! NILP (Vpurify_flag))
+ if (will_dump_p () && !will_bootstrap_p ())
error ("(require %s) while preparing to dump",
SDATA (SYMBOL_NAME (feature)));
@@ -2928,8 +3099,9 @@ ITEM should be one of the following:
`months', returning a 12-element vector of month names (locale items MON_n);
-`paper', returning a list (WIDTH HEIGHT) for the default paper size,
- both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
+`paper', returning a list of 2 integers (WIDTH HEIGHT) for the default
+ paper size, both measured in millimeters (locale items _NL_PAPER_WIDTH,
+ _NL_PAPER_HEIGHT).
If the system can't provide such information through a call to
`nl_langinfo', or if ITEM isn't from the list above, return nil.
@@ -2946,10 +3118,10 @@ The data read from the system are decoded using `locale-coding-system'. */)
str = nl_langinfo (CODESET);
return build_string (str);
}
-#ifdef DAY_1
- else if (EQ (item, Qdays)) /* e.g. for calendar-day-name-array */
+# ifdef DAY_1
+ if (EQ (item, Qdays)) /* E.g., for calendar-day-name-array. */
{
- Lisp_Object v = Fmake_vector (make_number (7), Qnil);
+ Lisp_Object v = make_nil_vector (7);
const int days[7] = {DAY_1, DAY_2, DAY_3, DAY_4, DAY_5, DAY_6, DAY_7};
int i;
synchronize_system_time_locale ();
@@ -2964,16 +3136,15 @@ The data read from the system are decoded using `locale-coding-system'. */)
}
return v;
}
-#endif /* DAY_1 */
-#ifdef MON_1
- else if (EQ (item, Qmonths)) /* e.g. for calendar-month-name-array */
+# endif
+# ifdef MON_1
+ if (EQ (item, Qmonths)) /* E.g., for calendar-month-name-array. */
{
- Lisp_Object v = Fmake_vector (make_number (12), Qnil);
+ Lisp_Object v = make_nil_vector (12);
const int months[12] = {MON_1, MON_2, MON_3, MON_4, MON_5, MON_6, MON_7,
MON_8, MON_9, MON_10, MON_11, MON_12};
- int i;
synchronize_system_time_locale ();
- for (i = 0; i < 12; i++)
+ for (int i = 0; i < 12; i++)
{
str = nl_langinfo (months[i]);
AUTO_STRING (val, str);
@@ -2982,13 +3153,12 @@ The data read from the system are decoded using `locale-coding-system'. */)
}
return v;
}
-#endif /* MON_1 */
-/* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
- but is in the locale files. This could be used by ps-print. */
-#ifdef PAPER_WIDTH
- else if (EQ (item, Qpaper))
- return list2i (nl_langinfo (PAPER_WIDTH), nl_langinfo (PAPER_HEIGHT));
-#endif /* PAPER_WIDTH */
+# endif
+# ifdef HAVE_LANGINFO__NL_PAPER_WIDTH
+ if (EQ (item, Qpaper))
+ return list2i ((intptr_t) nl_langinfo (_NL_PAPER_WIDTH),
+ (intptr_t) nl_langinfo (_NL_PAPER_HEIGHT));
+# endif
#endif /* HAVE_LANGINFO_CODESET*/
return Qnil;
}
@@ -3091,9 +3261,9 @@ into shorter lines. */)
validate_region (&beg, &end);
- ibeg = CHAR_TO_BYTE (XFASTINT (beg));
- iend = CHAR_TO_BYTE (XFASTINT (end));
- move_gap_both (XFASTINT (beg), ibeg);
+ ibeg = CHAR_TO_BYTE (XFIXNAT (beg));
+ iend = CHAR_TO_BYTE (XFIXNAT (end));
+ move_gap_both (XFIXNAT (beg), ibeg);
/* We need to allocate enough room for encoding the text.
We need 33 1/3% more space, plus a newline every 76
@@ -3118,21 +3288,21 @@ into shorter lines. */)
/* Now we have encoded the region, so we insert the new contents
and delete the old. (Insert first in order to preserve markers.) */
- SET_PT_BOTH (XFASTINT (beg), ibeg);
+ SET_PT_BOTH (XFIXNAT (beg), ibeg);
insert (encoded, encoded_length);
SAFE_FREE ();
del_range_byte (ibeg + encoded_length, iend + encoded_length);
/* If point was outside of the region, restore it exactly; else just
move to the beginning of the region. */
- if (old_pos >= XFASTINT (end))
- old_pos += encoded_length - (XFASTINT (end) - XFASTINT (beg));
- else if (old_pos > XFASTINT (beg))
- old_pos = XFASTINT (beg);
+ if (old_pos >= XFIXNAT (end))
+ old_pos += encoded_length - (XFIXNAT (end) - XFIXNAT (beg));
+ else if (old_pos > XFIXNAT (beg))
+ old_pos = XFIXNAT (beg);
SET_PT (old_pos);
/* We return the length of the encoded text. */
- return make_number (encoded_length);
+ return make_fixnum (encoded_length);
}
DEFUN ("base64-encode-string", Fbase64_encode_string, Sbase64_encode_string,
@@ -3291,8 +3461,8 @@ If the region can't be decoded, signal an error and don't modify the buffer. */
validate_region (&beg, &end);
- ibeg = CHAR_TO_BYTE (XFASTINT (beg));
- iend = CHAR_TO_BYTE (XFASTINT (end));
+ ibeg = CHAR_TO_BYTE (XFIXNAT (beg));
+ iend = CHAR_TO_BYTE (XFIXNAT (end));
length = iend - ibeg;
@@ -3302,7 +3472,7 @@ If the region can't be decoded, signal an error and don't modify the buffer. */
allength = multibyte ? length * 2 : length;
decoded = SAFE_ALLOCA (allength);
- move_gap_both (XFASTINT (beg), ibeg);
+ move_gap_both (XFIXNAT (beg), ibeg);
decoded_length = base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg),
decoded, length,
multibyte, &inserted_chars);
@@ -3317,23 +3487,24 @@ If the region can't be decoded, signal an error and don't modify the buffer. */
/* Now we have decoded the region, so we insert the new contents
and delete the old. (Insert first in order to preserve markers.) */
- TEMP_SET_PT_BOTH (XFASTINT (beg), ibeg);
+ TEMP_SET_PT_BOTH (XFIXNAT (beg), ibeg);
insert_1_both (decoded, inserted_chars, decoded_length, 0, 1, 0);
+ signal_after_change (XFIXNAT (beg), 0, inserted_chars);
SAFE_FREE ();
/* Delete the original text. */
- del_range_both (PT, PT_BYTE, XFASTINT (end) + inserted_chars,
+ del_range_both (PT, PT_BYTE, XFIXNAT (end) + inserted_chars,
iend + decoded_length, 1);
/* If point was outside of the region, restore it exactly; else just
move to the beginning of the region. */
- if (old_pos >= XFASTINT (end))
- old_pos += inserted_chars - (XFASTINT (end) - XFASTINT (beg));
- else if (old_pos > XFASTINT (beg))
- old_pos = XFASTINT (beg);
+ if (old_pos >= XFIXNAT (end))
+ old_pos += inserted_chars - (XFIXNAT (end) - XFIXNAT (beg));
+ else if (old_pos > XFIXNAT (beg))
+ old_pos = XFIXNAT (beg);
SET_PT (old_pos > ZV ? ZV : old_pos);
- return make_number (inserted_chars);
+ return make_fixnum (inserted_chars);
}
DEFUN ("base64-decode-string", Fbase64_decode_string, Sbase64_decode_string,
@@ -3476,10 +3647,6 @@ base64_decode_1 (const char *from, char *to, ptrdiff_t length,
if a `:linear-search t' argument is given to make-hash-table. */
-/* The list of all weak hash tables. Don't staticpro this one. */
-
-static struct Lisp_Hash_Table *weak_hash_tables;
-
/***********************************************************************
Utilities
@@ -3504,7 +3671,7 @@ set_hash_next (struct Lisp_Hash_Table *h, Lisp_Object next)
static void
set_hash_next_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, ptrdiff_t val)
{
- gc_aset (h->next, idx, make_number (val));
+ gc_aset (h->next, idx, make_fixnum (val));
}
static void
set_hash_hash (struct Lisp_Hash_Table *h, Lisp_Object hash)
@@ -3524,7 +3691,7 @@ set_hash_index (struct Lisp_Hash_Table *h, Lisp_Object index)
static void
set_hash_index_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, ptrdiff_t val)
{
- gc_aset (h->index, idx, make_number (val));
+ gc_aset (h->index, idx, make_fixnum (val));
}
/* If OBJ is a Lisp hash table, return a pointer to its struct
@@ -3627,7 +3794,7 @@ larger_vector (Lisp_Object vec, ptrdiff_t incr_min, ptrdiff_t nitems_max)
static ptrdiff_t
HASH_NEXT (struct Lisp_Hash_Table *h, ptrdiff_t idx)
{
- return XINT (AREF (h->next, idx));
+ return XFIXNUM (AREF (h->next, idx));
}
/* Return the index of the element in hash table H that is the start
@@ -3636,27 +3803,29 @@ HASH_NEXT (struct Lisp_Hash_Table *h, ptrdiff_t idx)
static ptrdiff_t
HASH_INDEX (struct Lisp_Hash_Table *h, ptrdiff_t idx)
{
- return XINT (AREF (h->index, idx));
+ return XFIXNUM (AREF (h->index, idx));
}
-/* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
- HASH2 in hash table H using `eql'. Value is true if KEY1 and
- KEY2 are the same. */
+/* Compare KEY1 and KEY2 in hash table HT using `eql'. Value is true
+ if KEY1 and KEY2 are the same. KEY1 and KEY2 must not be eq. */
static bool
cmpfn_eql (struct hash_table_test *ht,
Lisp_Object key1,
Lisp_Object key2)
{
- return (FLOATP (key1)
- && FLOATP (key2)
- && XFLOAT_DATA (key1) == XFLOAT_DATA (key2));
+ if (FLOATP (key1)
+ && FLOATP (key2)
+ && same_float (key1, key2))
+ return true;
+ return (BIGNUMP (key1)
+ && BIGNUMP (key2)
+ && mpz_cmp (XBIGNUM (key1)->value, XBIGNUM (key2)->value) == 0);
}
-/* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
- HASH2 in hash table H using `equal'. Value is true if KEY1 and
- KEY2 are the same. */
+/* Compare KEY1 and KEY2 in hash table HT using `equal'. Value is
+ true if KEY1 and KEY2 are the same. */
static bool
cmpfn_equal (struct hash_table_test *ht,
@@ -3667,9 +3836,8 @@ cmpfn_equal (struct hash_table_test *ht,
}
-/* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
- HASH2 in hash table H using H->user_cmp_function. Value is true
- if KEY1 and KEY2 are the same. */
+/* Compare KEY1 and KEY2 in hash table HT using HT->user_cmp_function.
+ Value is true if KEY1 and KEY2 are the same. */
static bool
cmpfn_user_defined (struct hash_table_test *ht,
@@ -3693,7 +3861,7 @@ hashfn_eq (struct hash_table_test *ht, Lisp_Object key)
`equal' to compare keys. The hash code returned is guaranteed to fit
in a Lisp integer. */
-static EMACS_UINT
+EMACS_UINT
hashfn_equal (struct hash_table_test *ht, Lisp_Object key)
{
return sxhash (key, 0);
@@ -3703,10 +3871,12 @@ hashfn_equal (struct hash_table_test *ht, Lisp_Object key)
`eql' to compare keys. The hash code returned is guaranteed to fit
in a Lisp integer. */
-static EMACS_UINT
+EMACS_UINT
hashfn_eql (struct hash_table_test *ht, Lisp_Object key)
{
- return FLOATP (key) ? hashfn_equal (ht, key) : hashfn_eq (ht, key);
+ return ((FLOATP (key) || BIGNUMP (key))
+ ? hashfn_equal (ht, key)
+ : hashfn_eq (ht, key));
}
/* Value is a hash code for KEY for use in hash table H which uses as
@@ -3734,7 +3904,7 @@ static struct Lisp_Hash_Table *
allocate_hash_table (void)
{
return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table,
- count, PVEC_HASH_TABLE);
+ index, PVEC_HASH_TABLE);
}
/* An upper bound on the size of a hash table index. It must fit in
@@ -3805,10 +3975,11 @@ make_hash_table (struct hash_table_test test, EMACS_INT size,
h->rehash_threshold = rehash_threshold;
h->rehash_size = rehash_size;
h->count = 0;
- h->key_and_value = Fmake_vector (make_number (2 * size), Qnil);
- h->hash = Fmake_vector (make_number (size), Qnil);
- h->next = Fmake_vector (make_number (size), make_number (-1));
- h->index = Fmake_vector (make_number (index_size), make_number (-1));
+ h->key_and_value = make_nil_vector (2 * size);
+ h->hash = make_nil_vector (size);
+ h->next = make_vector (size, make_fixnum (-1));
+ h->index = make_vector (index_size, make_fixnum (-1));
+ h->next_weak = NULL;
h->pure = pure;
/* Set up the free list. */
@@ -3820,13 +3991,6 @@ make_hash_table (struct hash_table_test test, EMACS_INT size,
eassert (HASH_TABLE_P (table));
eassert (XHASH_TABLE (table) == h);
- /* Maybe add this hash table to the list of all weak hash tables. */
- if (! NILP (weak))
- {
- h->next_weak = weak_hash_tables;
- weak_hash_tables = h;
- }
-
return table;
}
@@ -3848,13 +4012,6 @@ copy_hash_table (struct Lisp_Hash_Table *h1)
h2->index = Fcopy_sequence (h1->index);
XSET_HASH_TABLE (table, h2);
- /* Maybe add this hash table to the list of all weak hash tables. */
- if (!NILP (h2->weak))
- {
- h2->next_weak = h1->next_weak;
- h1->next_weak = h2;
- }
-
return table;
}
@@ -3903,8 +4060,7 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h)
set_hash_key_and_value (h, larger_vector (h->key_and_value,
2 * (new_size - old_size), -1));
set_hash_hash (h, larger_vector (h->hash, new_size - old_size, -1));
- set_hash_index (h, Fmake_vector (make_number (index_size),
- make_number (-1)));
+ set_hash_index (h, make_vector (index_size, make_fixnum (-1)));
set_hash_next (h, larger_vecalloc (h->next, new_size - old_size, -1));
/* Update the free list. Do it so that new entries are added at
@@ -3933,7 +4089,7 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h)
for (i = 0; i < old_size; ++i)
if (!NILP (HASH_HASH (h, i)))
{
- EMACS_UINT hash_code = XUINT (HASH_HASH (h, i));
+ EMACS_UINT hash_code = XUFIXNUM (HASH_HASH (h, i));
ptrdiff_t start_of_bucket = hash_code % ASIZE (h->index);
set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket));
set_hash_index_slot (h, start_of_bucket, i);
@@ -3941,6 +4097,43 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h)
}
}
+void
+hash_table_rehash (struct Lisp_Hash_Table *h)
+{
+ ptrdiff_t size = HASH_TABLE_SIZE (h);
+
+ /* Recompute the actual hash codes for each entry in the table.
+ Order is still invalid. */
+ for (ptrdiff_t i = 0; i < size; ++i)
+ if (!NILP (HASH_HASH (h, i)))
+ {
+ Lisp_Object key = HASH_KEY (h, i);
+ EMACS_UINT hash_code = h->test.hashfn (&h->test, key);
+ set_hash_hash_slot (h, i, make_fixnum (hash_code));
+ }
+
+ /* Reset the index so that any slot we don't fill below is marked
+ invalid. */
+ Ffillarray (h->index, make_fixnum (-1));
+
+ /* Rebuild the collision chains. */
+ for (ptrdiff_t i = 0; i < size; ++i)
+ if (!NILP (HASH_HASH (h, i)))
+ {
+ EMACS_UINT hash_code = XUFIXNUM (HASH_HASH (h, i));
+ ptrdiff_t start_of_bucket = hash_code % ASIZE (h->index);
+ set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket));
+ set_hash_index_slot (h, start_of_bucket, i);
+ eassert (HASH_NEXT (h, i) != i); /* Stop loops. */
+ }
+
+ /* Finally, mark the hash table as having a valid hash order.
+ Do this last so that if we're interrupted, we retry on next
+ access. */
+ eassert (h->count < 0);
+ h->count = -h->count;
+ eassert (!hash_rehash_needed_p (h));
+}
/* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
the hash code of KEY. Value is the index of the entry in H
@@ -3952,6 +4145,8 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, EMACS_UINT *hash)
EMACS_UINT hash_code;
ptrdiff_t start_of_bucket, i;
+ hash_rehash_if_needed (h);
+
hash_code = h->test.hashfn (&h->test, key);
eassert ((hash_code & ~INTMASK) == 0);
if (hash)
@@ -3962,7 +4157,7 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, EMACS_UINT *hash)
for (i = HASH_INDEX (h, start_of_bucket); 0 <= i; i = HASH_NEXT (h, i))
if (EQ (key, HASH_KEY (h, i))
|| (h->test.cmpfn
- && hash_code == XUINT (HASH_HASH (h, i))
+ && hash_code == XUFIXNUM (HASH_HASH (h, i))
&& h->test.cmpfn (&h->test, key, HASH_KEY (h, i))))
break;
@@ -3980,6 +4175,8 @@ hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value,
{
ptrdiff_t start_of_bucket, i;
+ hash_rehash_if_needed (h);
+
eassert ((hash & ~INTMASK) == 0);
/* Increment count after resizing because resizing may fail. */
@@ -3993,7 +4190,7 @@ hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value,
set_hash_value_slot (h, i, value);
/* Remember its hash code. */
- set_hash_hash_slot (h, i, make_number (hash));
+ set_hash_hash_slot (h, i, make_fixnum (hash));
/* Add new entry to its collision chain. */
start_of_bucket = hash % ASIZE (h->index);
@@ -4013,13 +4210,15 @@ hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key)
ptrdiff_t start_of_bucket = hash_code % ASIZE (h->index);
ptrdiff_t prev = -1;
+ hash_rehash_if_needed (h);
+
for (ptrdiff_t i = HASH_INDEX (h, start_of_bucket);
0 <= i;
i = HASH_NEXT (h, i))
{
if (EQ (key, HASH_KEY (h, i))
|| (h->test.cmpfn
- && hash_code == XUINT (HASH_HASH (h, i))
+ && hash_code == XUFIXNUM (HASH_HASH (h, i))
&& h->test.cmpfn (&h->test, key, HASH_KEY (h, i))))
{
/* Take entry out of collision chain. */
@@ -4063,7 +4262,7 @@ hash_clear (struct Lisp_Hash_Table *h)
}
for (i = 0; i < ASIZE (h->index); ++i)
- ASET (h->index, i, make_number (-1));
+ ASET (h->index, i, make_fixnum (-1));
h->next_free = 0;
h->count = 0;
@@ -4081,7 +4280,7 @@ hash_clear (struct Lisp_Hash_Table *h)
!REMOVE_ENTRIES_P means mark entries that are in use. Value is
true if anything was marked. */
-static bool
+bool
sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p)
{
ptrdiff_t n = gc_asize (h->index);
@@ -4089,12 +4288,14 @@ sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p)
for (ptrdiff_t bucket = 0; bucket < n; ++bucket)
{
- /* Follow collision chain, removing entries that
- don't survive this garbage collection. */
+ /* Follow collision chain, removing entries that don't survive
+ this garbage collection. It's okay if hash_rehash_needed_p
+ (h) is true, since we're operating entirely on the cached
+ hash values. */
ptrdiff_t prev = -1;
ptrdiff_t next;
for (ptrdiff_t i = HASH_INDEX (h, bucket); 0 <= i; i = next)
- {
+ {
bool key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i));
bool value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i));
bool remove_p;
@@ -4129,10 +4330,11 @@ sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p)
/* Clear key, value, and hash. */
set_hash_key_slot (h, i, Qnil);
set_hash_value_slot (h, i, Qnil);
- set_hash_hash_slot (h, i, Qnil);
+ set_hash_hash_slot (h, i, Qnil);
- h->count--;
- }
+ eassert (h->count != 0);
+ h->count += h->count > 0 ? -1 : 1;
+ }
else
{
prev = i;
@@ -4146,13 +4348,13 @@ sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p)
if (!key_known_to_survive_p)
{
mark_object (HASH_KEY (h, i));
- marked = 1;
+ marked = true;
}
if (!value_known_to_survive_p)
{
mark_object (HASH_VALUE (h, i));
- marked = 1;
+ marked = true;
}
}
}
@@ -4162,55 +4364,6 @@ sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p)
return marked;
}
-/* Remove elements from weak hash tables that don't survive the
- current garbage collection. Remove weak tables that don't survive
- from Vweak_hash_tables. Called from gc_sweep. */
-
-NO_INLINE /* For better stack traces */
-void
-sweep_weak_hash_tables (void)
-{
- struct Lisp_Hash_Table *h, *used, *next;
- bool marked;
-
- /* Mark all keys and values that are in use. Keep on marking until
- there is no more change. This is necessary for cases like
- value-weak table A containing an entry X -> Y, where Y is used in a
- key-weak table B, Z -> Y. If B comes after A in the list of weak
- tables, X -> Y might be removed from A, although when looking at B
- one finds that it shouldn't. */
- do
- {
- marked = 0;
- for (h = weak_hash_tables; h; h = h->next_weak)
- {
- if (h->header.size & ARRAY_MARK_FLAG)
- marked |= sweep_weak_table (h, 0);
- }
- }
- while (marked);
-
- /* Remove tables and entries that aren't used. */
- for (h = weak_hash_tables, used = NULL; h; h = next)
- {
- next = h->next_weak;
-
- if (h->header.size & ARRAY_MARK_FLAG)
- {
- /* TABLE is marked as used. Sweep its contents. */
- if (h->count > 0)
- sweep_weak_table (h, 1);
-
- /* Add table to the list of used weak hash tables. */
- h->next_weak = used;
- used = h;
- }
- }
-
- weak_hash_tables = used;
-}
-
-
/***********************************************************************
Hash Code Computation
@@ -4261,18 +4414,8 @@ static EMACS_UINT
sxhash_float (double val)
{
EMACS_UINT hash = 0;
- enum {
- WORDS_PER_DOUBLE = (sizeof val / sizeof hash
- + (sizeof val % sizeof hash != 0))
- };
- union {
- double val;
- EMACS_UINT word[WORDS_PER_DOUBLE];
- } u;
- int i;
- u.val = val;
- memset (&u.val + 1, 0, sizeof u - sizeof u.val);
- for (i = 0; i < WORDS_PER_DOUBLE; i++)
+ union double_and_words u = { .val = val };
+ for (int i = 0; i < WORDS_PER_DOUBLE; i++)
hash = sxhash_combine (hash, u.word[i]);
return SXHASH_REDUCE (hash);
}
@@ -4340,6 +4483,20 @@ sxhash_bool_vector (Lisp_Object vec)
return SXHASH_REDUCE (hash);
}
+/* Return a hash for a bignum. */
+
+static EMACS_UINT
+sxhash_bignum (struct Lisp_Bignum *bignum)
+{
+ size_t i, nlimbs = mpz_size (bignum->value);
+ EMACS_UINT hash = 0;
+
+ for (i = 0; i < nlimbs; ++i)
+ hash = sxhash_combine (hash, mpz_getlimbn (bignum->value, i));
+
+ return SXHASH_REDUCE (hash);
+}
+
/* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
structure. Value is an unsigned integer clipped to INTMASK. */
@@ -4355,10 +4512,9 @@ sxhash (Lisp_Object obj, int depth)
switch (XTYPE (obj))
{
case_Lisp_Int:
- hash = XUINT (obj);
+ hash = XUFIXNUM (obj);
break;
- case Lisp_Misc:
case Lisp_Symbol:
hash = XHASH (obj);
break;
@@ -4369,7 +4525,9 @@ sxhash (Lisp_Object obj, int depth)
/* This can be everything from a vector to an overlay. */
case Lisp_Vectorlike:
- if (VECTORP (obj) || RECORDP (obj))
+ if (BIGNUMP (obj))
+ hash = sxhash_bignum (XBIGNUM (obj));
+ else if (VECTORP (obj) || RECORDP (obj))
/* According to the CL HyperSpec, two arrays are equal only if
they are `eq', except for strings and bit-vectors. In
Emacs, this works differently. We have to compare element
@@ -4409,7 +4567,7 @@ DEFUN ("sxhash-eq", Fsxhash_eq, Ssxhash_eq, 1, 1, 0,
If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)). */)
(Lisp_Object obj)
{
- return make_number (hashfn_eq (NULL, obj));
+ return make_fixnum (hashfn_eq (NULL, obj));
}
DEFUN ("sxhash-eql", Fsxhash_eql, Ssxhash_eql, 1, 1, 0,
@@ -4417,7 +4575,7 @@ DEFUN ("sxhash-eql", Fsxhash_eql, Ssxhash_eql, 1, 1, 0,
If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)). */)
(Lisp_Object obj)
{
- return make_number (hashfn_eql (NULL, obj));
+ return make_fixnum (hashfn_eql (NULL, obj));
}
DEFUN ("sxhash-equal", Fsxhash_equal, Ssxhash_equal, 1, 1, 0,
@@ -4425,7 +4583,7 @@ DEFUN ("sxhash-equal", Fsxhash_equal, Ssxhash_equal, 1, 1, 0,
If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)). */)
(Lisp_Object obj)
{
- return make_number (hashfn_equal (NULL, obj));
+ return make_fixnum (hashfn_equal (NULL, obj));
}
DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
@@ -4511,8 +4669,8 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */)
EMACS_INT size;
if (NILP (size_arg))
size = DEFAULT_HASH_SIZE;
- else if (NATNUMP (size_arg))
- size = XFASTINT (size_arg);
+ else if (FIXNATP (size_arg))
+ size = XFIXNAT (size_arg);
else
signal_error ("Invalid hash table size", size_arg);
@@ -4521,8 +4679,8 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */)
i = get_key_arg (QCrehash_size, nargs, args, used);
if (!i)
rehash_size = DEFAULT_REHASH_SIZE;
- else if (INTEGERP (args[i]) && 0 < XINT (args[i]))
- rehash_size = - XINT (args[i]);
+ else if (FIXNUMP (args[i]) && 0 < XFIXNUM (args[i]))
+ rehash_size = - XFIXNUM (args[i]);
else if (FLOATP (args[i]) && 0 < (float) (XFLOAT_DATA (args[i]) - 1))
rehash_size = (float) (XFLOAT_DATA (args[i]) - 1);
else
@@ -4571,7 +4729,7 @@ DEFUN ("hash-table-count", Fhash_table_count, Shash_table_count, 1, 1, 0,
doc: /* Return the number of elements in TABLE. */)
(Lisp_Object table)
{
- return make_number (check_hash_table (table)->count);
+ return make_fixnum (check_hash_table (table)->count);
}
@@ -4584,7 +4742,7 @@ DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size,
if (rehash_size < 0)
{
EMACS_INT s = -rehash_size;
- return make_number (min (s, MOST_POSITIVE_FIXNUM));
+ return make_fixnum (min (s, MOST_POSITIVE_FIXNUM));
}
else
return make_float (rehash_size + 1);
@@ -4608,7 +4766,7 @@ without need for resizing. */)
(Lisp_Object table)
{
struct Lisp_Hash_Table *h = check_hash_table (table);
- return make_number (HASH_TABLE_SIZE (h));
+ return make_fixnum (HASH_TABLE_SIZE (h));
}
@@ -4756,13 +4914,7 @@ DEFUN ("secure-hash-algorithms", Fsecure_hash_algorithms,
doc: /* Return a list of all the supported `secure_hash' algorithms. */)
(void)
{
- return listn (CONSTYPE_HEAP, 6,
- Qmd5,
- Qsha1,
- Qsha224,
- Qsha256,
- Qsha384,
- Qsha512);
+ return list (Qmd5, Qsha1, Qsha224, Qsha256, Qsha384, Qsha512);
}
/* Extract data from a string or a buffer. SPEC is a list of
@@ -4812,7 +4964,8 @@ extract_data_from_object (Lisp_Object spec,
}
if (STRING_MULTIBYTE (object))
- object = code_convert_string (object, coding_system, Qnil, 1, 0, 1);
+ object = code_convert_string (object, coding_system,
+ Qnil, true, false, true);
ptrdiff_t size = SCHARS (object), start_char, end_char;
validate_subarray (object, start, end, size, &start_char, &end_char);
@@ -4829,8 +4982,6 @@ extract_data_from_object (Lisp_Object spec,
record_unwind_current_buffer ();
- CHECK_BUFFER (object);
-
struct buffer *bp = XBUFFER (object);
set_buffer_internal (bp);
@@ -4838,16 +4989,16 @@ extract_data_from_object (Lisp_Object spec,
b = BEGV;
else
{
- CHECK_NUMBER_COERCE_MARKER (start);
- b = XINT (start);
+ CHECK_FIXNUM_COERCE_MARKER (start);
+ b = XFIXNUM (start);
}
if (NILP (end))
e = ZV;
else
{
- CHECK_NUMBER_COERCE_MARKER (end);
- e = XINT (end);
+ CHECK_FIXNUM_COERCE_MARKER (end);
+ e = XFIXNUM (end);
}
if (b > e)
@@ -4869,7 +5020,7 @@ extract_data_from_object (Lisp_Object spec,
coding_system = Vcoding_system_for_write;
else
{
- bool force_raw_text = 0;
+ bool force_raw_text = false;
coding_system = BVAR (XBUFFER (object), buffer_file_coding_system);
if (NILP (coding_system)
@@ -4877,14 +5028,15 @@ extract_data_from_object (Lisp_Object spec,
{
coding_system = Qnil;
if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
- force_raw_text = 1;
+ force_raw_text = true;
}
if (NILP (coding_system) && !NILP (Fbuffer_file_name (object)))
{
/* Check file-coding-system-alist. */
Lisp_Object val = CALLN (Ffind_operation_coding_system,
- Qwrite_region, start, end,
+ Qwrite_region,
+ make_fixnum (b), make_fixnum (e),
Fbuffer_file_name (object));
if (CONSP (val) && !NILP (XCDR (val)))
coding_system = XCDR (val);
@@ -4902,7 +5054,7 @@ extract_data_from_object (Lisp_Object spec,
&& !NILP (Ffboundp (Vselect_safe_coding_system_function)))
/* Confirm that VAL can surely encode the current region. */
coding_system = call4 (Vselect_safe_coding_system_function,
- make_number (b), make_number (e),
+ make_fixnum (b), make_fixnum (e),
coding_system, Qnil);
if (force_raw_text)
@@ -4920,14 +5072,15 @@ extract_data_from_object (Lisp_Object spec,
}
}
- object = make_buffer_string (b, e, 0);
+ object = make_buffer_string (b, e, false);
set_buffer_internal (prev);
/* Discard the unwind protect for recovering the current
buffer. */
specpdl_ptr--;
if (STRING_MULTIBYTE (object))
- object = code_convert_string (object, coding_system, Qnil, 1, 0, 0);
+ object = code_convert_string (object, coding_system,
+ Qnil, true, false, false);
*start_byte = 0;
*end_byte = SBYTES (object);
}
@@ -4936,11 +5089,11 @@ extract_data_from_object (Lisp_Object spec,
#ifdef HAVE_GNUTLS3
/* Format: (iv-auto REQUIRED-LENGTH). */
- if (! NATNUMP (start))
+ if (! FIXNATP (start))
error ("Without a length, `iv-auto' can't be used; see ELisp manual");
else
{
- EMACS_INT start_hold = XFASTINT (start);
+ EMACS_INT start_hold = XFIXNAT (start);
object = make_uninit_string (start_hold);
gnutls_rnd (GNUTLS_RND_NONCE, SSDATA (object), start_hold);
@@ -5114,6 +5267,7 @@ disregarding any coding systems. If nil, use the current buffer. */ )
}
+
void
syms_of_fns (void)
{
@@ -5197,6 +5351,7 @@ Used by `featurep' and `require', and altered by `provide'. */);
DEFSYM (Qsubfeatures, "subfeatures");
DEFSYM (Qfuncall, "funcall");
DEFSYM (Qplistp, "plistp");
+ DEFSYM (Qlist_or_vector_p, "list-or-vector-p");
#ifdef HAVE_LANGINFO_CODESET
DEFSYM (Qcodeset, "codeset");
@@ -5212,7 +5367,7 @@ invoked by mouse clicks and mouse menu items.
On some platforms, file selection dialogs are also enabled if this is
non-nil. */);
- use_dialog_box = 1;
+ use_dialog_box = true;
DEFVAR_BOOL ("use-file-dialog", use_file_dialog,
doc: /* Non-nil means mouse commands use a file dialog to ask for files.
@@ -5220,13 +5375,15 @@ This applies to commands from menus and tool bar buttons even when
they are initiated from the keyboard. If `use-dialog-box' is nil,
that disables the use of a file dialog, regardless of the value of
this variable. */);
- use_file_dialog = 1;
+ use_file_dialog = true;
defsubr (&Sidentity);
defsubr (&Srandom);
defsubr (&Slength);
defsubr (&Ssafe_length);
+ defsubr (&Sproper_list_p);
defsubr (&Sstring_bytes);
+ defsubr (&Sstring_distance);
defsubr (&Sstring_equal);
defsubr (&Scompare_strings);
defsubr (&Sstring_lessp);
diff --git a/src/font.c b/src/font.c
index 24075c7e635..5ca89c97dcf 100644
--- a/src/font.c
+++ b/src/font.c
@@ -38,6 +38,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "fontset.h"
#include "font.h"
#include "termhooks.h"
+#include "pdumper.h"
#ifdef HAVE_WINDOW_SYSTEM
#include TERM_HEADER
@@ -201,7 +202,7 @@ font_make_object (int size, Lisp_Object entity, int pixelsize)
= Fcopy_alist (AREF (entity, FONT_EXTRA_INDEX));
}
if (size > 0)
- font->props[FONT_SIZE_INDEX] = make_number (pixelsize);
+ font->props[FONT_SIZE_INDEX] = make_fixnum (pixelsize);
return font_object;
}
@@ -270,7 +271,7 @@ font_intern_prop (const char *str, ptrdiff_t len, bool force_symbol)
(n += str[i++] - '0') <= MOST_POSITIVE_FIXNUM; )
{
if (i == len)
- return make_number (n);
+ return make_fixnum (n);
if (INT_MULTIPLY_WRAPV (n, 10, &n))
break;
}
@@ -302,8 +303,8 @@ font_pixel_size (struct frame *f, Lisp_Object spec)
int dpi, pixel_size;
Lisp_Object val;
- if (INTEGERP (size))
- return XINT (size);
+ if (FIXNUMP (size))
+ return XFIXNUM (size);
if (NILP (size))
return 0;
if (FRAME_WINDOW_P (f))
@@ -311,8 +312,8 @@ font_pixel_size (struct frame *f, Lisp_Object spec)
eassert (FLOATP (size));
point_size = XFLOAT_DATA (size);
val = AREF (spec, FONT_DPI_INDEX);
- if (INTEGERP (val))
- dpi = XINT (val);
+ if (FIXNUMP (val))
+ dpi = XFIXNUM (val);
else
dpi = FRAME_RES_Y (f);
pixel_size = POINT_TO_PIXEL (point_size, dpi);
@@ -353,8 +354,8 @@ font_style_to_value (enum font_property_index prop, Lisp_Object val,
for (j = 1; j < ASIZE (AREF (table, i)); j++)
if (EQ (val, AREF (AREF (table, i), j)))
{
- CHECK_NUMBER (AREF (AREF (table, i), 0));
- return ((XINT (AREF (AREF (table, i), 0)) << 8)
+ CHECK_FIXNUM (AREF (AREF (table, i), 0));
+ return ((XFIXNUM (AREF (AREF (table, i), 0)) << 8)
| (i << 4) | (j - 1));
}
}
@@ -366,32 +367,32 @@ font_style_to_value (enum font_property_index prop, Lisp_Object val,
elt = AREF (AREF (table, i), j);
if (xstrcasecmp (s, SSDATA (SYMBOL_NAME (elt))) == 0)
{
- CHECK_NUMBER (AREF (AREF (table, i), 0));
- return ((XINT (AREF (AREF (table, i), 0)) << 8)
+ CHECK_FIXNUM (AREF (AREF (table, i), 0));
+ return ((XFIXNUM (AREF (AREF (table, i), 0)) << 8)
| (i << 4) | (j - 1));
}
}
if (! noerror)
return -1;
eassert (len < 255);
- elt = Fmake_vector (make_number (2), make_number (100));
+ elt = make_vector (2, make_fixnum (100));
ASET (elt, 1, val);
ASET (font_style_table, prop - FONT_WEIGHT_INDEX,
- CALLN (Fvconcat, table, Fmake_vector (make_number (1), elt)));
+ CALLN (Fvconcat, table, make_vector (1, elt)));
return (100 << 8) | (i << 4);
}
else
{
int i, last_n;
- EMACS_INT numeric = XINT (val);
+ EMACS_INT numeric = XFIXNUM (val);
for (i = 0, last_n = -1; i < len; i++)
{
int n;
CHECK_VECTOR (AREF (table, i));
- CHECK_NUMBER (AREF (AREF (table, i), 0));
- n = XINT (AREF (AREF (table, i), 0));
+ CHECK_FIXNUM (AREF (AREF (table, i), 0));
+ n = XFIXNUM (AREF (AREF (table, i), 0));
if (numeric == n)
return (n << 8) | (i << 4);
if (numeric < n)
@@ -421,7 +422,7 @@ font_style_symbolic (Lisp_Object font, enum font_property_index prop,
return Qnil;
table = AREF (font_style_table, prop - FONT_WEIGHT_INDEX);
CHECK_VECTOR (table);
- i = XINT (val) & 0xFF;
+ i = XFIXNUM (val) & 0xFF;
eassert (((i >> 4) & 0xF) < ASIZE (table));
elt = AREF (table, ((i >> 4) & 0xF));
CHECK_VECTOR (elt);
@@ -470,33 +471,33 @@ font_registry_charsets (Lisp_Object registry, struct charset **encoding, struct
val = XCDR (val);
if (NILP (val))
return -1;
- encoding_id = XINT (XCAR (val));
- repertory_id = XINT (XCDR (val));
+ encoding_id = XFIXNUM (XCAR (val));
+ repertory_id = XFIXNUM (XCDR (val));
}
else
{
val = find_font_encoding (SYMBOL_NAME (registry));
if (SYMBOLP (val) && CHARSETP (val))
{
- encoding_id = repertory_id = XINT (CHARSET_SYMBOL_ID (val));
+ encoding_id = repertory_id = XFIXNUM (CHARSET_SYMBOL_ID (val));
}
else if (CONSP (val))
{
if (! CHARSETP (XCAR (val)))
goto invalid_entry;
- encoding_id = XINT (CHARSET_SYMBOL_ID (XCAR (val)));
+ encoding_id = XFIXNUM (CHARSET_SYMBOL_ID (XCAR (val)));
if (NILP (XCDR (val)))
repertory_id = -1;
else
{
if (! CHARSETP (XCDR (val)))
goto invalid_entry;
- repertory_id = XINT (CHARSET_SYMBOL_ID (XCDR (val)));
+ repertory_id = XFIXNUM (CHARSET_SYMBOL_ID (XCDR (val)));
}
}
else
goto invalid_entry;
- val = Fcons (make_number (encoding_id), make_number (repertory_id));
+ val = Fcons (make_fixnum (encoding_id), make_fixnum (repertory_id));
font_charset_alist
= nconc2 (font_charset_alist, list1 (Fcons (registry, val)));
}
@@ -543,9 +544,9 @@ font_prop_validate_style (Lisp_Object style, Lisp_Object val)
enum font_property_index prop = (EQ (style, QCweight) ? FONT_WEIGHT_INDEX
: EQ (style, QCslant) ? FONT_SLANT_INDEX
: FONT_WIDTH_INDEX);
- if (INTEGERP (val))
+ if (FIXNUMP (val))
{
- EMACS_INT n = XINT (val);
+ EMACS_INT n = XFIXNUM (val);
CHECK_VECTOR (AREF (font_style_table, prop - FONT_WEIGHT_INDEX));
if (((n >> 4) & 0xF)
>= ASIZE (AREF (font_style_table, prop - FONT_WEIGHT_INDEX)))
@@ -559,8 +560,8 @@ font_prop_validate_style (Lisp_Object style, Lisp_Object val)
val = Qerror;
else
{
- CHECK_NUMBER (AREF (elt, 0));
- if (XINT (AREF (elt, 0)) != (n >> 8))
+ CHECK_FIXNUM (AREF (elt, 0));
+ if (XFIXNUM (AREF (elt, 0)) != (n >> 8))
val = Qerror;
}
}
@@ -569,7 +570,7 @@ font_prop_validate_style (Lisp_Object style, Lisp_Object val)
{
int n = font_style_to_value (prop, val, 0);
- val = n >= 0 ? make_number (n) : Qerror;
+ val = n >= 0 ? make_fixnum (n) : Qerror;
}
else
val = Qerror;
@@ -579,27 +580,27 @@ font_prop_validate_style (Lisp_Object style, Lisp_Object val)
static Lisp_Object
font_prop_validate_non_neg (Lisp_Object prop, Lisp_Object val)
{
- return (NATNUMP (val) || (FLOATP (val) && XFLOAT_DATA (val) >= 0)
+ return (FIXNATP (val) || (FLOATP (val) && XFLOAT_DATA (val) >= 0)
? val : Qerror);
}
static Lisp_Object
font_prop_validate_spacing (Lisp_Object prop, Lisp_Object val)
{
- if (NILP (val) || (NATNUMP (val) && XINT (val) <= FONT_SPACING_CHARCELL))
+ if (NILP (val) || (FIXNATP (val) && XFIXNUM (val) <= FONT_SPACING_CHARCELL))
return val;
if (SYMBOLP (val) && SBYTES (SYMBOL_NAME (val)) == 1)
{
char spacing = SDATA (SYMBOL_NAME (val))[0];
if (spacing == 'c' || spacing == 'C')
- return make_number (FONT_SPACING_CHARCELL);
+ return make_fixnum (FONT_SPACING_CHARCELL);
if (spacing == 'm' || spacing == 'M')
- return make_number (FONT_SPACING_MONO);
+ return make_fixnum (FONT_SPACING_MONO);
if (spacing == 'p' || spacing == 'P')
- return make_number (FONT_SPACING_PROPORTIONAL);
+ return make_fixnum (FONT_SPACING_PROPORTIONAL);
if (spacing == 'd' || spacing == 'D')
- return make_number (FONT_SPACING_DUAL);
+ return make_fixnum (FONT_SPACING_DUAL);
}
return Qerror;
}
@@ -875,9 +876,9 @@ font_expand_wildcards (Lisp_Object *field, int n)
int from, to;
unsigned mask;
- if (INTEGERP (val))
+ if (FIXNUMP (val))
{
- EMACS_INT numeric = XINT (val);
+ EMACS_INT numeric = XFIXNUM (val);
if (i + 1 == n)
from = to = XLFD_ENCODING_INDEX,
@@ -999,14 +1000,14 @@ font_expand_wildcards (Lisp_Object *field, int n)
if (! NILP (tmp[n - 1]) && j < XLFD_REGISTRY_INDEX)
return -1;
memclear (field + j, (XLFD_LAST_INDEX - j) * word_size);
- if (INTEGERP (field[XLFD_ENCODING_INDEX]))
+ if (FIXNUMP (field[XLFD_ENCODING_INDEX]))
field[XLFD_ENCODING_INDEX]
= Fintern (Fnumber_to_string (field[XLFD_ENCODING_INDEX]), Qnil);
return 0;
}
-/* Parse NAME (null terminated) as XLFD and store information in FONT
+/* Parse NAME (NUL terminated) as XLFD and store information in FONT
(font-spec or font-entity). Size property of FONT is set as
follows:
specified XLFD fields FONT property
@@ -1064,7 +1065,7 @@ font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font)
{
if ((n = font_style_to_value (j, INTERN_FIELD_SYM (i), 0)) < 0)
return -1;
- ASET (font, j, make_number (n));
+ ASET (font, j, make_fixnum (n));
}
}
ASET (font, FONT_ADSTYLE_INDEX, INTERN_FIELD_SYM (XLFD_ADSTYLE_INDEX));
@@ -1077,11 +1078,11 @@ font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font)
1));
p = f[XLFD_PIXEL_INDEX];
if (*p == '[' && (pixel_size = parse_matrix (p)) >= 0)
- ASET (font, FONT_SIZE_INDEX, make_number (pixel_size));
+ ASET (font, FONT_SIZE_INDEX, make_fixnum (pixel_size));
else
{
val = INTERN_FIELD (XLFD_PIXEL_INDEX);
- if (INTEGERP (val))
+ if (FIXNUMP (val))
ASET (font, FONT_SIZE_INDEX, val);
else if (FONT_ENTITY_P (font))
return -1;
@@ -1101,14 +1102,14 @@ font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font)
}
val = INTERN_FIELD (XLFD_RESY_INDEX);
- if (! NILP (val) && ! INTEGERP (val))
+ if (! NILP (val) && ! FIXNUMP (val))
return -1;
ASET (font, FONT_DPI_INDEX, val);
val = INTERN_FIELD (XLFD_SPACING_INDEX);
if (! NILP (val))
{
val = font_prop_validate_spacing (QCspacing, val);
- if (! INTEGERP (val))
+ if (! FIXNUMP (val))
return -1;
ASET (font, FONT_SPACING_INDEX, val);
}
@@ -1116,7 +1117,7 @@ font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font)
if (*p == '~')
p++;
val = font_intern_prop (p, f[XLFD_REGISTRY_INDEX] - 1 - p, 0);
- if (! NILP (val) && ! INTEGERP (val))
+ if (! NILP (val) && ! FIXNUMP (val))
return -1;
ASET (font, FONT_AVGWIDTH_INDEX, val);
}
@@ -1154,7 +1155,7 @@ font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font)
{
if ((n = font_style_to_value (j, prop[i], 1)) < 0)
return -1;
- ASET (font, j, make_number (n));
+ ASET (font, j, make_fixnum (n));
}
ASET (font, FONT_ADSTYLE_INDEX, prop[XLFD_ADSTYLE_INDEX]);
val = prop[XLFD_REGISTRY_INDEX];
@@ -1181,26 +1182,26 @@ font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font)
if (! NILP (val))
ASET (font, FONT_REGISTRY_INDEX, Fintern (val, Qnil));
- if (INTEGERP (prop[XLFD_PIXEL_INDEX]))
+ if (FIXNUMP (prop[XLFD_PIXEL_INDEX]))
ASET (font, FONT_SIZE_INDEX, prop[XLFD_PIXEL_INDEX]);
- else if (INTEGERP (prop[XLFD_POINT_INDEX]))
+ else if (FIXNUMP (prop[XLFD_POINT_INDEX]))
{
- double point_size = XINT (prop[XLFD_POINT_INDEX]);
+ double point_size = XFIXNUM (prop[XLFD_POINT_INDEX]);
ASET (font, FONT_SIZE_INDEX, make_float (point_size / 10));
}
- if (INTEGERP (prop[XLFD_RESX_INDEX]))
+ if (FIXNUMP (prop[XLFD_RESX_INDEX]))
ASET (font, FONT_DPI_INDEX, prop[XLFD_RESY_INDEX]);
if (! NILP (prop[XLFD_SPACING_INDEX]))
{
val = font_prop_validate_spacing (QCspacing,
prop[XLFD_SPACING_INDEX]);
- if (! INTEGERP (val))
+ if (! FIXNUMP (val))
return -1;
ASET (font, FONT_SPACING_INDEX, val);
}
- if (INTEGERP (prop[XLFD_AVGWIDTH_INDEX]))
+ if (FIXNUMP (prop[XLFD_AVGWIDTH_INDEX]))
ASET (font, FONT_AVGWIDTH_INDEX, prop[XLFD_AVGWIDTH_INDEX]);
}
@@ -1289,13 +1290,15 @@ font_unparse_xlfd (Lisp_Object font, int pixel_size, char *name, int nbytes)
1 + DBL_MAX_10_EXP + 1)];
if (INTEGERP (val))
{
- EMACS_INT v = XINT (val);
- if (v <= 0)
+ intmax_t v;
+ if (! (integer_to_intmax (val, &v)
+ && 0 < v && v <= TYPE_MAXIMUM (uprintmax_t)))
v = pixel_size;
if (v > 0)
{
+ uprintmax_t u = v;
f[XLFD_PIXEL_INDEX] = p = font_size_index_buf;
- sprintf (p, "%"pI"d-*", v);
+ sprintf (p, "%"pMu"-*", u);
}
else
f[XLFD_PIXEL_INDEX] = "*-*";
@@ -1310,18 +1313,18 @@ font_unparse_xlfd (Lisp_Object font, int pixel_size, char *name, int nbytes)
f[XLFD_PIXEL_INDEX] = "*-*";
char dpi_index_buf[sizeof "-" + 2 * INT_STRLEN_BOUND (EMACS_INT)];
- if (INTEGERP (AREF (font, FONT_DPI_INDEX)))
+ if (FIXNUMP (AREF (font, FONT_DPI_INDEX)))
{
- EMACS_INT v = XINT (AREF (font, FONT_DPI_INDEX));
+ EMACS_INT v = XFIXNUM (AREF (font, FONT_DPI_INDEX));
f[XLFD_RESX_INDEX] = p = dpi_index_buf;
sprintf (p, "%"pI"d-%"pI"d", v, v);
}
else
f[XLFD_RESX_INDEX] = "*-*";
- if (INTEGERP (AREF (font, FONT_SPACING_INDEX)))
+ if (FIXNUMP (AREF (font, FONT_SPACING_INDEX)))
{
- EMACS_INT spacing = XINT (AREF (font, FONT_SPACING_INDEX));
+ EMACS_INT spacing = XFIXNUM (AREF (font, FONT_SPACING_INDEX));
f[XLFD_SPACING_INDEX] = (spacing <= FONT_SPACING_PROPORTIONAL ? "p"
: spacing <= FONT_SPACING_DUAL ? "d"
@@ -1332,10 +1335,10 @@ font_unparse_xlfd (Lisp_Object font, int pixel_size, char *name, int nbytes)
f[XLFD_SPACING_INDEX] = "*";
char avgwidth_index_buf[INT_BUFSIZE_BOUND (EMACS_INT)];
- if (INTEGERP (AREF (font, FONT_AVGWIDTH_INDEX)))
+ if (FIXNUMP (AREF (font, FONT_AVGWIDTH_INDEX)))
{
f[XLFD_AVGWIDTH_INDEX] = p = avgwidth_index_buf;
- sprintf (p, "%"pI"d", XINT (AREF (font, FONT_AVGWIDTH_INDEX)));
+ sprintf (p, "%"pI"d", XFIXNUM (AREF (font, FONT_AVGWIDTH_INDEX)));
}
else
f[XLFD_AVGWIDTH_INDEX] = "*";
@@ -1350,7 +1353,7 @@ font_unparse_xlfd (Lisp_Object font, int pixel_size, char *name, int nbytes)
return len < nbytes ? len : -1;
}
-/* Parse NAME (null terminated) and store information in FONT
+/* Parse NAME (NUL terminated) and store information in FONT
(font-spec or font-entity). NAME is supplied in either the
Fontconfig or GTK font name format. If NAME is successfully
parsed, return 0. Otherwise return -1.
@@ -1456,19 +1459,19 @@ font_parse_fcname (char *name, ptrdiff_t len, Lisp_Object font)
FONT_SET_STYLE (font, FONT_SLANT_INDEX, val);
else if (PROP_MATCH ("charcell"))
ASET (font, FONT_SPACING_INDEX,
- make_number (FONT_SPACING_CHARCELL));
+ make_fixnum (FONT_SPACING_CHARCELL));
else if (PROP_MATCH ("mono"))
ASET (font, FONT_SPACING_INDEX,
- make_number (FONT_SPACING_MONO));
+ make_fixnum (FONT_SPACING_MONO));
else if (PROP_MATCH ("proportional"))
ASET (font, FONT_SPACING_INDEX,
- make_number (FONT_SPACING_PROPORTIONAL));
+ make_fixnum (FONT_SPACING_PROPORTIONAL));
#undef PROP_MATCH
}
else
{
/* KEY=VAL pairs */
- Lisp_Object key;
+ Lisp_Object key UNINIT;
int prop;
if (q - p == 10 && memcmp (p + 1, "pixelsize", 9) == 0)
@@ -1621,10 +1624,10 @@ font_unparse_fcname (Lisp_Object font, int pixel_size, char *name, int nbytes)
}
val = AREF (font, FONT_SIZE_INDEX);
- if (INTEGERP (val))
+ if (FIXNUMP (val))
{
- if (XINT (val) != 0)
- pixel_size = XINT (val);
+ if (XFIXNUM (val) != 0)
+ pixel_size = XFIXNUM (val);
point_size = -1;
}
else
@@ -1688,28 +1691,28 @@ font_unparse_fcname (Lisp_Object font, int pixel_size, char *name, int nbytes)
p += len;
}
- if (INTEGERP (AREF (font, FONT_DPI_INDEX)))
+ if (FIXNUMP (AREF (font, FONT_DPI_INDEX)))
{
int len = snprintf (p, lim - p, ":dpi=%"pI"d",
- XINT (AREF (font, FONT_DPI_INDEX)));
+ XFIXNUM (AREF (font, FONT_DPI_INDEX)));
if (! (0 <= len && len < lim - p))
return -1;
p += len;
}
- if (INTEGERP (AREF (font, FONT_SPACING_INDEX)))
+ if (FIXNUMP (AREF (font, FONT_SPACING_INDEX)))
{
int len = snprintf (p, lim - p, ":spacing=%"pI"d",
- XINT (AREF (font, FONT_SPACING_INDEX)));
+ XFIXNUM (AREF (font, FONT_SPACING_INDEX)));
if (! (0 <= len && len < lim - p))
return -1;
p += len;
}
- if (INTEGERP (AREF (font, FONT_AVGWIDTH_INDEX)))
+ if (FIXNUMP (AREF (font, FONT_AVGWIDTH_INDEX)))
{
int len = snprintf (p, lim - p,
- (XINT (AREF (font, FONT_AVGWIDTH_INDEX)) == 0
+ (XFIXNUM (AREF (font, FONT_AVGWIDTH_INDEX)) == 0
? ":scalable=true"
: ":scalable=false"));
if (! (0 <= len && len < lim - p))
@@ -1722,7 +1725,7 @@ font_unparse_fcname (Lisp_Object font, int pixel_size, char *name, int nbytes)
#endif
-/* Parse NAME (null terminated) and store information in FONT
+/* Parse NAME (NUL terminated) and store information in FONT
(font-spec or font-entity). If NAME is successfully parsed, return
0. Otherwise return -1. */
@@ -1807,15 +1810,15 @@ check_gstring (Lisp_Object gstring)
goto err;
CHECK_FONT_OBJECT (LGSTRING_FONT (gstring));
if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_LBEARING)))
- CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_LBEARING));
+ CHECK_FIXNUM (LGSTRING_SLOT (gstring, LGSTRING_IX_LBEARING));
if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_RBEARING)))
- CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_RBEARING));
+ CHECK_FIXNUM (LGSTRING_SLOT (gstring, LGSTRING_IX_RBEARING));
if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_WIDTH)))
- CHECK_NATNUM (LGSTRING_SLOT (gstring, LGSTRING_IX_WIDTH));
+ CHECK_FIXNAT (LGSTRING_SLOT (gstring, LGSTRING_IX_WIDTH));
if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT)))
- CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT));
+ CHECK_FIXNUM (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT));
if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT)))
- CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT));
+ CHECK_FIXNUM (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT));
for (i = 0; i < LGSTRING_GLYPH_LEN (gstring); i++)
{
@@ -1825,13 +1828,13 @@ check_gstring (Lisp_Object gstring)
goto err;
if (NILP (AREF (val, LGLYPH_IX_CHAR)))
break;
- CHECK_NATNUM (AREF (val, LGLYPH_IX_FROM));
- CHECK_NATNUM (AREF (val, LGLYPH_IX_TO));
+ CHECK_FIXNAT (AREF (val, LGLYPH_IX_FROM));
+ CHECK_FIXNAT (AREF (val, LGLYPH_IX_TO));
CHECK_CHARACTER (AREF (val, LGLYPH_IX_CHAR));
if (!NILP (AREF (val, LGLYPH_IX_CODE)))
- CHECK_NATNUM (AREF (val, LGLYPH_IX_CODE));
+ CHECK_FIXNAT (AREF (val, LGLYPH_IX_CODE));
if (!NILP (AREF (val, LGLYPH_IX_WIDTH)))
- CHECK_NATNUM (AREF (val, LGLYPH_IX_WIDTH));
+ CHECK_FIXNAT (AREF (val, LGLYPH_IX_WIDTH));
if (!NILP (AREF (val, LGLYPH_IX_ADJUSTMENT)))
{
val = AREF (val, LGLYPH_IX_ADJUSTMENT);
@@ -1839,7 +1842,7 @@ check_gstring (Lisp_Object gstring)
if (ASIZE (val) < 3)
goto err;
for (j = 0; j < 3; j++)
- CHECK_NUMBER (AREF (val, j));
+ CHECK_FIXNUM (AREF (val, j));
}
}
return i;
@@ -1897,11 +1900,11 @@ otf_open (Lisp_Object file)
OTF *otf;
if (! NILP (val))
- otf = XSAVE_POINTER (XCDR (val), 0);
+ otf = xmint_pointer (XCDR (val));
else
{
otf = STRINGP (file) ? OTF_open (SSDATA (file)) : NULL;
- val = make_save_ptr (otf);
+ val = make_mint_ptr (otf);
otf_list = Fcons (Fcons (file, val), otf_list);
}
return otf;
@@ -2026,23 +2029,23 @@ font_otf_DeviceTable (OTF_DeviceTable *device_table)
{
int len = device_table->StartSize - device_table->EndSize + 1;
- return Fcons (make_number (len),
+ return Fcons (make_fixnum (len),
make_unibyte_string (device_table->DeltaValue, len));
}
Lisp_Object
font_otf_ValueRecord (int value_format, OTF_ValueRecord *value_record)
{
- Lisp_Object val = Fmake_vector (make_number (8), Qnil);
+ Lisp_Object val = make_nil_vector (8);
if (value_format & OTF_XPlacement)
- ASET (val, 0, make_number (value_record->XPlacement));
+ ASET (val, 0, make_fixnum (value_record->XPlacement));
if (value_format & OTF_YPlacement)
- ASET (val, 1, make_number (value_record->YPlacement));
+ ASET (val, 1, make_fixnum (value_record->YPlacement));
if (value_format & OTF_XAdvance)
- ASET (val, 2, make_number (value_record->XAdvance));
+ ASET (val, 2, make_fixnum (value_record->XAdvance));
if (value_format & OTF_YAdvance)
- ASET (val, 3, make_number (value_record->YAdvance));
+ ASET (val, 3, make_fixnum (value_record->YAdvance));
if (value_format & OTF_XPlaDevice)
ASET (val, 4, font_otf_DeviceTable (&value_record->XPlaDevice));
if (value_format & OTF_YPlaDevice)
@@ -2057,13 +2060,11 @@ font_otf_ValueRecord (int value_format, OTF_ValueRecord *value_record)
Lisp_Object
font_otf_Anchor (OTF_Anchor *anchor)
{
- Lisp_Object val;
-
- val = Fmake_vector (make_number (anchor->AnchorFormat + 1), Qnil);
- ASET (val, 0, make_number (anchor->XCoordinate));
- ASET (val, 1, make_number (anchor->YCoordinate));
+ Lisp_Object val = make_nil_vector (anchor->AnchorFormat + 1);
+ ASET (val, 0, make_fixnum (anchor->XCoordinate));
+ ASET (val, 1, make_fixnum (anchor->YCoordinate));
if (anchor->AnchorFormat == 2)
- ASET (val, 2, make_number (anchor->f.f1.AnchorPoint));
+ ASET (val, 2, make_fixnum (anchor->f.f1.AnchorPoint));
else
{
ASET (val, 3, font_otf_DeviceTable (&anchor->f.f2.XDeviceTable));
@@ -2134,20 +2135,20 @@ font_score (Lisp_Object entity, Lisp_Object *spec_prop)
for (i = FONT_WEIGHT_INDEX; i <= FONT_WIDTH_INDEX; i++)
if (! NILP (spec_prop[i]) && ! EQ (AREF (entity, i), spec_prop[i]))
{
- EMACS_INT diff = ((XINT (AREF (entity, i)) >> 8)
- - (XINT (spec_prop[i]) >> 8));
+ EMACS_INT diff = ((XFIXNUM (AREF (entity, i)) >> 8)
+ - (XFIXNUM (spec_prop[i]) >> 8));
score |= min (eabs (diff), 127) << sort_shift_bits[i];
}
/* Score the size. Maximum difference is 127. */
if (! NILP (spec_prop[FONT_SIZE_INDEX])
- && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0)
+ && XFIXNUM (AREF (entity, FONT_SIZE_INDEX)) > 0)
{
/* We use the higher 6-bit for the actual size difference. The
lowest bit is set if the DPI is different. */
EMACS_INT diff;
- EMACS_INT pixel_size = XINT (spec_prop[FONT_SIZE_INDEX]);
- EMACS_INT entity_size = XINT (AREF (entity, FONT_SIZE_INDEX));
+ EMACS_INT pixel_size = XFIXNUM (spec_prop[FONT_SIZE_INDEX]);
+ EMACS_INT entity_size = XFIXNUM (AREF (entity, FONT_SIZE_INDEX));
if (CONSP (Vface_font_rescale_alist))
pixel_size *= font_rescale_ratio (entity);
@@ -2174,13 +2175,12 @@ font_score (Lisp_Object entity, Lisp_Object *spec_prop)
static Lisp_Object
font_vconcat_entity_vectors (Lisp_Object list)
{
- EMACS_INT nargs = XFASTINT (Flength (list));
+ ptrdiff_t nargs = list_length (list);
Lisp_Object *args;
USE_SAFE_ALLOCA;
SAFE_ALLOCA_LISP (args, nargs);
- ptrdiff_t i;
- for (i = 0; i < nargs; i++, list = XCDR (list))
+ for (ptrdiff_t i = 0; i < nargs; i++, list = XCDR (list))
args[i] = XCAR (list);
Lisp_Object result = Fvconcat (nargs, args);
SAFE_FREE ();
@@ -2244,7 +2244,7 @@ font_sort_entities (Lisp_Object list, Lisp_Object prefer,
prefer_prop[i] = AREF (prefer, i);
if (FLOATP (prefer_prop[FONT_SIZE_INDEX]))
prefer_prop[FONT_SIZE_INDEX]
- = make_number (font_pixel_size (f, prefer));
+ = make_fixnum (font_pixel_size (f, prefer));
if (NILP (XCDR (list)))
{
@@ -2446,7 +2446,7 @@ font_match_p (Lisp_Object spec, Lisp_Object font)
for (i = FONT_FOUNDRY_INDEX; i < FONT_SIZE_INDEX; i++)
prop[i] = AREF (spec, i);
prop[FONT_SIZE_INDEX]
- = make_number (font_pixel_size (XFRAME (selected_frame), spec));
+ = make_fixnum (font_pixel_size (XFRAME (selected_frame), spec));
props = prop;
}
@@ -2492,7 +2492,7 @@ font_match_p (Lisp_Object spec, Lisp_Object font)
{
if (! CHARACTERP (XCAR (val2)))
continue;
- if (font_encode_char (font, XFASTINT (XCAR (val2)))
+ if (font_encode_char (font, XFIXNAT (XCAR (val2)))
== FONT_INVALID_CODE)
return 0;
}
@@ -2504,7 +2504,7 @@ font_match_p (Lisp_Object spec, Lisp_Object font)
{
if (! CHARACTERP (AREF (val2, i)))
continue;
- if (font_encode_char (font, XFASTINT (AREF (val2, i)))
+ if (font_encode_char (font, XFIXNAT (AREF (val2, i)))
!= FONT_INVALID_CODE)
break;
}
@@ -2559,13 +2559,13 @@ font_prepare_cache (struct frame *f, struct font_driver const *driver)
val = XCDR (val);
if (NILP (val))
{
- val = list2 (driver->type, make_number (1));
+ val = list2 (driver->type, make_fixnum (1));
XSETCDR (cache, Fcons (val, XCDR (cache)));
}
else
{
val = XCDR (XCAR (val));
- XSETCAR (val, make_number (XINT (XCAR (val)) + 1));
+ XSETCAR (val, make_fixnum (XFIXNUM (XCAR (val)) + 1));
}
}
@@ -2582,8 +2582,8 @@ font_finish_cache (struct frame *f, struct font_driver const *driver)
cache = val, val = XCDR (val);
eassert (! NILP (val));
tmp = XCDR (XCAR (val));
- XSETCAR (tmp, make_number (XINT (XCAR (tmp)) - 1));
- if (XINT (XCAR (tmp)) == 0)
+ XSETCAR (tmp, make_fixnum (XFIXNUM (XCAR (tmp)) - 1));
+ if (XFIXNUM (XCAR (tmp)) == 0)
{
font_clear_cache (f, XCAR (val), driver);
XSETCDR (cache, XCDR (val));
@@ -2698,29 +2698,29 @@ font_delete_unmatched (Lisp_Object vec, Lisp_Object spec, int size)
continue;
}
for (prop = FONT_WEIGHT_INDEX; prop < FONT_SIZE_INDEX; prop++)
- if (INTEGERP (AREF (spec, prop))
- && ((XINT (AREF (spec, prop)) >> 8)
- != (XINT (AREF (entity, prop)) >> 8)))
+ if (FIXNUMP (AREF (spec, prop))
+ && ((XFIXNUM (AREF (spec, prop)) >> 8)
+ != (XFIXNUM (AREF (entity, prop)) >> 8)))
prop = FONT_SPEC_MAX;
if (prop < FONT_SPEC_MAX
&& size
- && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0)
+ && XFIXNUM (AREF (entity, FONT_SIZE_INDEX)) > 0)
{
- int diff = XINT (AREF (entity, FONT_SIZE_INDEX)) - size;
+ int diff = XFIXNUM (AREF (entity, FONT_SIZE_INDEX)) - size;
if (eabs (diff) > FONT_PIXEL_SIZE_QUANTUM)
prop = FONT_SPEC_MAX;
}
if (prop < FONT_SPEC_MAX
- && INTEGERP (AREF (spec, FONT_DPI_INDEX))
- && INTEGERP (AREF (entity, FONT_DPI_INDEX))
- && XINT (AREF (entity, FONT_DPI_INDEX)) != 0
+ && FIXNUMP (AREF (spec, FONT_DPI_INDEX))
+ && FIXNUMP (AREF (entity, FONT_DPI_INDEX))
+ && XFIXNUM (AREF (entity, FONT_DPI_INDEX)) != 0
&& ! EQ (AREF (spec, FONT_DPI_INDEX), AREF (entity, FONT_DPI_INDEX)))
prop = FONT_SPEC_MAX;
if (prop < FONT_SPEC_MAX
- && INTEGERP (AREF (spec, FONT_AVGWIDTH_INDEX))
- && INTEGERP (AREF (entity, FONT_AVGWIDTH_INDEX))
- && XINT (AREF (entity, FONT_AVGWIDTH_INDEX)) != 0
+ && FIXNUMP (AREF (spec, FONT_AVGWIDTH_INDEX))
+ && FIXNUMP (AREF (entity, FONT_AVGWIDTH_INDEX))
+ && XFIXNUM (AREF (entity, FONT_AVGWIDTH_INDEX)) != 0
&& ! EQ (AREF (spec, FONT_AVGWIDTH_INDEX),
AREF (entity, FONT_AVGWIDTH_INDEX)))
prop = FONT_SPEC_MAX;
@@ -2747,8 +2747,8 @@ font_list_entities (struct frame *f, Lisp_Object spec)
eassert (FONT_SPEC_P (spec));
- if (INTEGERP (AREF (spec, FONT_SIZE_INDEX)))
- size = XINT (AREF (spec, FONT_SIZE_INDEX));
+ if (FIXNUMP (AREF (spec, FONT_SIZE_INDEX)))
+ size = XFIXNUM (AREF (spec, FONT_SIZE_INDEX));
else if (FLOATP (AREF (spec, FONT_SIZE_INDEX)))
size = font_pixel_size (f, spec);
else
@@ -2781,7 +2781,7 @@ font_list_entities (struct frame *f, Lisp_Object spec)
{
Lisp_Object copy;
- val = driver_list->driver->list (f, scratch_font_spec);
+ val = (driver_list->driver->list) (f, scratch_font_spec);
/* We put zero_vector in the font-cache to indicate that
no fonts matching SPEC were found on the system.
Failure to have this indication in the font cache can
@@ -2824,7 +2824,7 @@ font_matching_entity (struct frame *f, Lisp_Object *attrs, Lisp_Object spec)
size = AREF (spec, FONT_SIZE_INDEX);
if (FLOATP (size))
- ASET (work, FONT_SIZE_INDEX, make_number (font_pixel_size (f, spec)));
+ ASET (work, FONT_SIZE_INDEX, make_fixnum (font_pixel_size (f, spec)));
FONT_SET_STYLE (work, FONT_WEIGHT_INDEX, attrs[LFACE_WEIGHT_INDEX]);
FONT_SET_STYLE (work, FONT_SLANT_INDEX, attrs[LFACE_SLANT_INDEX]);
FONT_SET_STYLE (work, FONT_WIDTH_INDEX, attrs[LFACE_SWIDTH_INDEX]);
@@ -2873,8 +2873,8 @@ font_open_entity (struct frame *f, Lisp_Object entity, int pixel_size)
eassert (FONT_ENTITY_P (entity));
size = AREF (entity, FONT_SIZE_INDEX);
- if (XINT (size) != 0)
- pixel_size = XINT (size);
+ if (XFIXNUM (size) != 0)
+ pixel_size = XFIXNUM (size);
val = AREF (entity, FONT_TYPE_INDEX);
for (driver_list = f->font_driver_list;
@@ -2910,7 +2910,7 @@ font_open_entity (struct frame *f, Lisp_Object entity, int pixel_size)
if (psize > pixel_size + 15)
return Qnil;
}
- ASET (font_object, FONT_SIZE_INDEX, make_number (pixel_size));
+ ASET (font_object, FONT_SIZE_INDEX, make_fixnum (pixel_size));
FONT_ADD_LOG ("open", entity, font_object);
ASET (entity, FONT_OBJLIST_INDEX,
Fcons (font_object, AREF (entity, FONT_OBJLIST_INDEX)));
@@ -3133,7 +3133,7 @@ font_select_entity (struct frame *f, Lisp_Object entities,
FONT_SET_STYLE (prefer, FONT_SLANT_INDEX, attrs[LFACE_SLANT_INDEX]);
if (NILP (AREF (prefer, FONT_WIDTH_INDEX)))
FONT_SET_STYLE (prefer, FONT_WIDTH_INDEX, attrs[LFACE_SWIDTH_INDEX]);
- ASET (prefer, FONT_SIZE_INDEX, make_number (pixel_size));
+ ASET (prefer, FONT_SIZE_INDEX, make_fixnum (pixel_size));
return font_sort_entities (entities, prefer, f, c);
}
@@ -3179,9 +3179,9 @@ font_find_for_lface (struct frame *f, Lisp_Object *attrs, Lisp_Object spec, int
work = copy_font_spec (spec);
ASET (work, FONT_TYPE_INDEX, AREF (spec, FONT_TYPE_INDEX));
pixel_size = font_pixel_size (f, spec);
- if (pixel_size == 0 && INTEGERP (attrs[LFACE_HEIGHT_INDEX]))
+ if (pixel_size == 0 && FIXNUMP (attrs[LFACE_HEIGHT_INDEX]))
{
- double pt = XINT (attrs[LFACE_HEIGHT_INDEX]);
+ double pt = XFIXNUM (attrs[LFACE_HEIGHT_INDEX]);
pixel_size = POINT_TO_PIXEL (pt / 10, FRAME_RES_Y (f));
if (pixel_size < 1)
@@ -3241,7 +3241,7 @@ font_find_for_lface (struct frame *f, Lisp_Object *attrs, Lisp_Object spec, int
if (! NILP (alters))
{
- EMACS_INT alterslen = XFASTINT (Flength (alters));
+ EMACS_INT alterslen = list_length (alters);
SAFE_ALLOCA_LISP (family, alterslen + 2);
for (i = 0; CONSP (alters); i++, alters = XCDR (alters))
family[i] = XCAR (alters);
@@ -3298,9 +3298,9 @@ font_open_for_lface (struct frame *f, Lisp_Object entity, Lisp_Object *attrs, Li
{
int size;
- if (INTEGERP (AREF (entity, FONT_SIZE_INDEX))
- && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0)
- size = XINT (AREF (entity, FONT_SIZE_INDEX));
+ if (FIXNUMP (AREF (entity, FONT_SIZE_INDEX))
+ && XFIXNUM (AREF (entity, FONT_SIZE_INDEX)) > 0)
+ size = XFIXNUM (AREF (entity, FONT_SIZE_INDEX));
else
{
if (FONT_SPEC_P (spec) && ! NILP (AREF (spec, FONT_SIZE_INDEX)))
@@ -3308,14 +3308,14 @@ font_open_for_lface (struct frame *f, Lisp_Object entity, Lisp_Object *attrs, Li
else
{
double pt;
- if (INTEGERP (attrs[LFACE_HEIGHT_INDEX]))
- pt = XINT (attrs[LFACE_HEIGHT_INDEX]);
+ if (FIXNUMP (attrs[LFACE_HEIGHT_INDEX]))
+ pt = XFIXNUM (attrs[LFACE_HEIGHT_INDEX]);
else
{
struct face *def = FACE_FROM_ID (f, DEFAULT_FACE_ID);
Lisp_Object height = def->lface[LFACE_HEIGHT_INDEX];
- eassert (INTEGERP (height));
- pt = XINT (height);
+ eassert (FIXNUMP (height));
+ pt = XFIXNUM (height);
}
pt /= 10;
@@ -3325,7 +3325,8 @@ font_open_for_lface (struct frame *f, Lisp_Object entity, Lisp_Object *attrs, Li
{
Lisp_Object ffsize = get_frame_param (f, Qfontsize);
size = (NUMBERP (ffsize)
- ? POINT_TO_PIXEL (XINT (ffsize), FRAME_RES_Y (f)) : 0);
+ ? POINT_TO_PIXEL (XFLOATINT (ffsize), FRAME_RES_Y (f))
+ : 0);
}
#endif
}
@@ -3372,7 +3373,7 @@ font_load_for_lface (struct frame *f, Lisp_Object *attrs, Lisp_Object spec)
Lisp_Object lsize = Ffont_get (spec, QCsize);
if ((FLOATP (lsize) && XFLOAT_DATA (lsize) == font_size)
- || (INTEGERP (lsize) && XINT (lsize) == font_size))
+ || (FIXNUMP (lsize) && XFIXNUM (lsize) == font_size))
{
ASET (spec, FONT_FAMILY_INDEX,
font_intern_prop (p, tail - p, 1));
@@ -3433,9 +3434,9 @@ font_open_by_spec (struct frame *f, Lisp_Object spec)
attrs[LFACE_SWIDTH_INDEX] = attrs[LFACE_WEIGHT_INDEX]
= attrs[LFACE_SLANT_INDEX] = Qnormal;
#ifndef HAVE_NS
- attrs[LFACE_HEIGHT_INDEX] = make_number (120);
+ attrs[LFACE_HEIGHT_INDEX] = make_fixnum (120);
#else
- attrs[LFACE_HEIGHT_INDEX] = make_number (0);
+ attrs[LFACE_HEIGHT_INDEX] = make_fixnum (0);
#endif
attrs[LFACE_FONT_INDEX] = Qnil;
@@ -3632,10 +3633,10 @@ font_put_frame_data (struct frame *f, Lisp_Object driver, void *data)
else
{
if (NILP (val))
- fset_font_data (f, Fcons (Fcons (driver, make_save_ptr (data)),
+ fset_font_data (f, Fcons (Fcons (driver, make_mint_ptr (data)),
f->font_data));
else
- XSETCDR (val, make_save_ptr (data));
+ XSETCDR (val, make_mint_ptr (data));
}
}
@@ -3644,7 +3645,7 @@ font_get_frame_data (struct frame *f, Lisp_Object driver)
{
Lisp_Object val = assq_no_quit (driver, f->font_data);
- return NILP (val) ? NULL : XSAVE_POINTER (XCDR (val), 0);
+ return NILP (val) ? NULL : xmint_pointer (XCDR (val));
}
#endif /* HAVE_XFT || HAVE_FREETYPE */
@@ -3673,7 +3674,7 @@ font_filter_properties (Lisp_Object font,
if (strcmp (boolean_properties[i], keystr) == 0)
{
- const char *str = INTEGERP (val) ? (XINT (val) ? "true" : "false")
+ const char *str = FIXNUMP (val) ? (XFIXNUM (val) ? "true" : "false")
: SYMBOLP (val) ? SSDATA (SYMBOL_NAME (val))
: "true";
@@ -3810,7 +3811,7 @@ font_range (ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t *limit,
face_id =
NILP (Vface_remapping_alist)
? DEFAULT_FACE_ID
- : lookup_basic_face (f, DEFAULT_FACE_ID);
+ : lookup_basic_face (w, f, DEFAULT_FACE_ID);
face_id = face_at_string_position (w, string, pos, 0, &ignore,
face_id, false);
@@ -3827,8 +3828,8 @@ font_range (ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t *limit,
else
FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string, pos, pos_byte);
category = CHAR_TABLE_REF (Vunicode_category_table, c);
- if (INTEGERP (category)
- && (XINT (category) == UNICODE_CATEGORY_Cf
+ if (FIXNUMP (category)
+ && (XFIXNUM (category) == UNICODE_CATEGORY_Cf
|| CHAR_VARIATION_SELECTOR_P (c)))
continue;
if (NILP (font_object))
@@ -4142,17 +4143,17 @@ are to be displayed on. If omitted, the selected frame is used. */)
}
val = AREF (font, FONT_SIZE_INDEX);
- if (INTEGERP (val))
+ if (FIXNUMP (val))
{
Lisp_Object font_dpi = AREF (font, FONT_DPI_INDEX);
- int dpi = INTEGERP (font_dpi) ? XINT (font_dpi) : FRAME_RES_Y (f);
+ int dpi = FIXNUMP (font_dpi) ? XFIXNUM (font_dpi) : FRAME_RES_Y (f);
plist[n++] = QCheight;
- plist[n++] = make_number (PIXEL_TO_POINT (XINT (val) * 10, dpi));
+ plist[n++] = make_fixnum (PIXEL_TO_POINT (XFIXNUM (val) * 10, dpi));
}
else if (FLOATP (val))
{
plist[n++] = QCheight;
- plist[n++] = make_number (10 * (int) XFLOAT_DATA (val));
+ plist[n++] = make_fixnum (10 * (int) XFLOAT_DATA (val));
}
val = FONT_WEIGHT_FOR_FACE (font);
@@ -4231,8 +4232,8 @@ how close they are to PREFER. */)
CHECK_FONT_SPEC (font_spec);
if (! NILP (num))
{
- CHECK_NUMBER (num);
- n = XINT (num);
+ CHECK_FIXNUM (num);
+ n = XFIXNUM (num);
if (n <= 0)
return Qnil;
}
@@ -4289,7 +4290,7 @@ DEFUN ("find-font", Ffind_font, Sfind_font, 1, 2, 0,
Optional 2nd argument FRAME, if non-nil, specifies the target frame. */)
(Lisp_Object font_spec, Lisp_Object frame)
{
- Lisp_Object val = Flist_fonts (font_spec, frame, make_number (1), Qnil);
+ Lisp_Object val = Flist_fonts (font_spec, frame, make_fixnum (1), Qnil);
if (CONSP (val))
val = XCAR (val);
@@ -4354,12 +4355,11 @@ clear_font_cache (struct frame *f)
Lisp_Object val, tmp, cache = driver_list->driver->get_cache (f);
val = XCDR (cache);
- while (! NILP (val)
- && ! EQ (XCAR (XCAR (val)), driver_list->driver->type))
+ while (eassert (CONSP (val)),
+ ! EQ (XCAR (XCAR (val)), driver_list->driver->type))
val = XCDR (val);
- eassert (! NILP (val));
tmp = XCDR (XCAR (val));
- if (XINT (XCAR (tmp)) == 0)
+ if (XFIXNUM (XCAR (tmp)) == 0)
{
font_clear_cache (f, XCAR (val), driver_list->driver);
XSETCDR (cache, XCDR (val));
@@ -4428,15 +4428,15 @@ GSTRING. */)
for (i = 0; i < 3; i++)
{
n = font->driver->shape (gstring);
- if (INTEGERP (n))
+ if (FIXNUMP (n))
break;
gstring = larger_vector (gstring,
LGSTRING_GLYPH_LEN (gstring), -1);
}
- if (i == 3 || XINT (n) == 0)
+ if (i == 3 || XFIXNUM (n) == 0)
return Qnil;
- if (XINT (n) < LGSTRING_GLYPH_LEN (gstring))
- LGSTRING_SET_GLYPH (gstring, XINT (n), Qnil);
+ if (XFIXNUM (n) < LGSTRING_GLYPH_LEN (gstring))
+ LGSTRING_SET_GLYPH (gstring, XFIXNUM (n), Qnil);
/* Check FROM_IDX and TO_IDX of each GLYPH in GSTRING to assure that
GLYPHS covers all characters (except for the last few ones) in
@@ -4470,7 +4470,7 @@ GSTRING. */)
from = LGLYPH_FROM (glyph);
to = LGLYPH_TO (glyph);
}
- return composition_gstring_put_cache (gstring, XINT (n));
+ return composition_gstring_put_cache (gstring, XFIXNUM (n));
shaper_error:
return Qnil;
@@ -4483,7 +4483,8 @@ Each element of the value is a cons (VARIATION-SELECTOR . GLYPH-ID),
where
VARIATION-SELECTOR is a character code of variation selection
(#xFE00..#xFE0F or #xE0100..#xE01EF)
- GLYPH-ID is a glyph code of the corresponding variation glyph. */)
+ GLYPH-ID is a glyph code of the corresponding variation glyph,
+a fixnum, if it's small enough, otherwise a bignum. */)
(Lisp_Object font_object, Lisp_Object character)
{
unsigned variations[256];
@@ -4496,7 +4497,7 @@ where
font = XFONT_OBJECT (font_object);
if (! font->driver->get_variation_glyphs)
return Qnil;
- n = font->driver->get_variation_glyphs (font, XINT (character), variations);
+ n = font->driver->get_variation_glyphs (font, XFIXNUM (character), variations);
if (! n)
return Qnil;
val = Qnil;
@@ -4504,8 +4505,8 @@ where
if (variations[i])
{
int vs = (i < 16 ? 0xFE00 + i : 0xE0100 + (i - 16));
- Lisp_Object code = INTEGER_TO_CONS (variations[i]);
- val = Fcons (Fcons (make_number (vs), code), val);
+ Lisp_Object code = INT_TO_INTEGER (variations[i]);
+ val = Fcons (Fcons (make_fixnum (vs), code), val);
}
return val;
}
@@ -4520,7 +4521,8 @@ where
that apply to POSITION. POSITION may be nil, in which case,
FONT-SPEC is the font for displaying the character CH with the
default face. GLYPH-CODE is the glyph code in the font to use for
- the character.
+ the character, it is a fixnum, if it is small enough, otherwise a
+ bignum.
For a text terminal, return a nonnegative integer glyph code for
the character, or a negative integer if the character is not
@@ -4557,9 +4559,9 @@ DEFUN ("internal-char-font", Finternal_char_font, Sinternal_char_font, 1, 2, 0,
if (NILP (position))
{
CHECK_CHARACTER (ch);
- c = XINT (ch);
+ c = XFIXNUM (ch);
f = XFRAME (selected_frame);
- face_id = lookup_basic_face (f, DEFAULT_FACE_ID);
+ face_id = lookup_basic_face (NULL, f, DEFAULT_FACE_ID);
pos = -1;
}
else
@@ -4567,17 +4569,17 @@ DEFUN ("internal-char-font", Finternal_char_font, Sinternal_char_font, 1, 2, 0,
Lisp_Object window;
struct window *w;
- CHECK_NUMBER_COERCE_MARKER (position);
- if (! (BEGV <= XINT (position) && XINT (position) < ZV))
- args_out_of_range_3 (position, make_number (BEGV), make_number (ZV));
- pos = XINT (position);
+ CHECK_FIXNUM_COERCE_MARKER (position);
+ if (! (BEGV <= XFIXNUM (position) && XFIXNUM (position) < ZV))
+ args_out_of_range_3 (position, make_fixnum (BEGV), make_fixnum (ZV));
+ pos = XFIXNUM (position);
pos_byte = CHAR_TO_BYTE (pos);
if (NILP (ch))
c = FETCH_CHAR (pos_byte);
else
{
- CHECK_NATNUM (ch);
- c = XINT (ch);
+ CHECK_FIXNAT (ch);
+ c = XFIXNUM (ch);
}
window = Fget_buffer_window (Fcurrent_buffer (), Qnil);
if (NILP (window))
@@ -4607,7 +4609,7 @@ DEFUN ("internal-char-font", Finternal_char_font, Sinternal_char_font, 1, 2, 0,
return Qnil;
Lisp_Object font_object;
XSETFONT (font_object, face->font);
- return Fcons (font_object, INTEGER_TO_CONS (code));
+ return Fcons (font_object, INT_TO_INTEGER (code));
}
#if 0
@@ -4666,20 +4668,20 @@ glyph-string. */)
CHECK_CONS (val);
len = check_gstring (gstring_in);
CHECK_VECTOR (gstring_out);
- CHECK_NATNUM (from);
- CHECK_NATNUM (to);
- CHECK_NATNUM (index);
-
- if (XINT (from) >= XINT (to) || XINT (to) > len)
- args_out_of_range_3 (from, to, make_number (len));
- if (XINT (index) >= ASIZE (gstring_out))
- args_out_of_range (index, make_number (ASIZE (gstring_out)));
+ CHECK_FIXNAT (from);
+ CHECK_FIXNAT (to);
+ CHECK_FIXNAT (index);
+
+ if (XFIXNUM (from) >= XFIXNUM (to) || XFIXNUM (to) > len)
+ args_out_of_range_3 (from, to, make_fixnum (len));
+ if (XFIXNUM (index) >= ASIZE (gstring_out))
+ args_out_of_range (index, make_fixnum (ASIZE (gstring_out)));
num = font->driver->otf_drive (font, otf_features,
- gstring_in, XINT (from), XINT (to),
- gstring_out, XINT (index), 0);
+ gstring_in, XFIXNUM (from), XFIXNUM (to),
+ gstring_out, XFIXNUM (index), 0);
if (num < 0)
return Qnil;
- return make_number (num);
+ return make_fixnum (num);
}
DEFUN ("font-otf-alternates", Ffont_otf_alternates, Sfont_otf_alternates,
@@ -4707,14 +4709,14 @@ corresponding character. */)
CHECK_CHARACTER (character);
CHECK_CONS (otf_features);
- gstring_in = Ffont_make_gstring (font_object, make_number (1));
+ gstring_in = Ffont_make_gstring (font_object, make_fixnum (1));
g = LGSTRING_GLYPH (gstring_in, 0);
- LGLYPH_SET_CHAR (g, XINT (character));
- gstring_out = Ffont_make_gstring (font_object, make_number (10));
+ LGLYPH_SET_CHAR (g, XFIXNUM (character));
+ gstring_out = Ffont_make_gstring (font_object, make_fixnum (10));
while ((num = font->driver->otf_drive (font, otf_features, gstring_in, 0, 1,
gstring_out, 0, 1)) < 0)
gstring_out = Ffont_make_gstring (font_object,
- make_number (ASIZE (gstring_out) * 2));
+ make_fixnum (ASIZE (gstring_out) * 2));
alternates = Qnil;
for (i = 0; i < num; i++)
{
@@ -4722,8 +4724,8 @@ corresponding character. */)
int c = LGLYPH_CHAR (g);
unsigned code = LGLYPH_CODE (g);
- alternates = Fcons (Fcons (make_number (code),
- c > 0 ? make_number (c) : Qnil),
+ alternates = Fcons (Fcons (make_fixnum (code),
+ c > 0 ? make_fixnum (c) : Qnil),
alternates);
}
return Fnreverse (alternates);
@@ -4736,20 +4738,20 @@ DEFUN ("open-font", Fopen_font, Sopen_font, 1, 3, 0,
doc: /* Open FONT-ENTITY. */)
(Lisp_Object font_entity, Lisp_Object size, Lisp_Object frame)
{
- EMACS_INT isize;
+ intmax_t isize;
struct frame *f = decode_live_frame (frame);
CHECK_FONT_ENTITY (font_entity);
if (NILP (size))
- isize = XINT (AREF (font_entity, FONT_SIZE_INDEX));
+ isize = XFIXNUM (AREF (font_entity, FONT_SIZE_INDEX));
else
{
- CHECK_NUMBER_OR_FLOAT (size);
+ CHECK_NUMBER (size);
if (FLOATP (size))
isize = POINT_TO_PIXEL (XFLOAT_DATA (size), FRAME_RES_Y (f));
- else
- isize = XINT (size);
+ else if (! integer_to_intmax (size, &isize))
+ args_out_of_range (font_entity, size);
if (! (INT_MIN <= isize && isize <= INT_MAX))
args_out_of_range (font_entity, size);
if (isize == 0)
@@ -4815,12 +4817,12 @@ If the font is not OpenType font, CAPABILITY is nil. */)
ASET (val, 0, AREF (font_object, FONT_NAME_INDEX));
ASET (val, 1, AREF (font_object, FONT_FILE_INDEX));
- ASET (val, 2, make_number (font->pixel_size));
- ASET (val, 3, make_number (font->max_width));
- ASET (val, 4, make_number (font->ascent));
- ASET (val, 5, make_number (font->descent));
- ASET (val, 6, make_number (font->space_width));
- ASET (val, 7, make_number (font->average_width));
+ ASET (val, 2, make_fixnum (font->pixel_size));
+ ASET (val, 3, make_fixnum (font->max_width));
+ ASET (val, 4, make_fixnum (font->ascent));
+ ASET (val, 5, make_fixnum (font->descent));
+ ASET (val, 6, make_fixnum (font->space_width));
+ ASET (val, 7, make_fixnum (font->average_width));
if (font->driver->otf_capability)
ASET (val, 8, Fcons (Qopentype, font->driver->otf_capability (font)));
else
@@ -4863,15 +4865,15 @@ the corresponding element is nil. */)
validate_region (&from, &to);
if (EQ (from, to))
return Qnil;
- len = XFASTINT (to) - XFASTINT (from);
+ len = XFIXNAT (to) - XFIXNAT (from);
SAFE_ALLOCA_LISP (chars, len);
- charpos = XFASTINT (from);
+ charpos = XFIXNAT (from);
bytepos = CHAR_TO_BYTE (charpos);
- for (i = 0; charpos < XFASTINT (to); i++)
+ for (i = 0; charpos < XFIXNAT (to); i++)
{
int c;
FETCH_CHAR_ADVANCE (c, charpos, bytepos);
- chars[i] = make_number (c);
+ chars[i] = make_fixnum (c);
}
}
else if (STRINGP (object))
@@ -4897,12 +4899,12 @@ the corresponding element is nil. */)
for (i = 0; i < len; i++)
{
c = STRING_CHAR_ADVANCE (p);
- chars[i] = make_number (c);
+ chars[i] = make_fixnum (c);
}
}
else
for (i = 0; i < len; i++)
- chars[i] = make_number (p[ifrom + i]);
+ chars[i] = make_fixnum (p[ifrom + i]);
}
else if (VECTORP (object))
{
@@ -4926,7 +4928,7 @@ the corresponding element is nil. */)
for (i = 0; i < len; i++)
{
Lisp_Object g;
- int c = XFASTINT (chars[i]);
+ int c = XFIXNAT (chars[i]);
unsigned code;
struct font_metrics metrics;
@@ -4979,19 +4981,19 @@ character at index specified by POSITION. */)
{
if (XBUFFER (w->contents) != current_buffer)
error ("Specified window is not displaying the current buffer");
- CHECK_NUMBER_COERCE_MARKER (position);
- if (! (BEGV <= XINT (position) && XINT (position) < ZV))
- args_out_of_range_3 (position, make_number (BEGV), make_number (ZV));
+ CHECK_FIXNUM_COERCE_MARKER (position);
+ if (! (BEGV <= XFIXNUM (position) && XFIXNUM (position) < ZV))
+ args_out_of_range_3 (position, make_fixnum (BEGV), make_fixnum (ZV));
}
else
{
- CHECK_NUMBER (position);
+ CHECK_FIXNUM (position);
CHECK_STRING (string);
- if (! (0 <= XINT (position) && XINT (position) < SCHARS (string)))
+ if (! (0 <= XFIXNUM (position) && XFIXNUM (position) < SCHARS (string)))
args_out_of_range (string, position);
}
- return font_at (-1, XINT (position), NULL, w, string);
+ return font_at (-1, XFIXNUM (position), NULL, w, string);
}
#if 0
@@ -5014,9 +5016,9 @@ Type C-l to recover what previously shown. */)
code = alloca (sizeof (unsigned) * len);
for (i = 0; i < len; i++)
{
- Lisp_Object ch = Faref (string, make_number (i));
+ Lisp_Object ch = Faref (string, make_fixnum (i));
Lisp_Object val;
- int c = XINT (ch);
+ int c = XFIXNUM (ch);
code[i] = font->driver->encode_char (font, c);
if (code[i] == FONT_INVALID_CODE)
@@ -5031,7 +5033,7 @@ Type C-l to recover what previously shown. */)
if (font->driver->done_face)
font->driver->done_face (f, face);
face->fontp = NULL;
- return make_number (len);
+ return make_fixnum (len);
}
#endif
@@ -5134,16 +5136,16 @@ If the named font is not yet loaded, return nil. */)
info = make_uninit_vector (14);
ASET (info, 0, AREF (font_object, FONT_NAME_INDEX));
ASET (info, 1, AREF (font_object, FONT_FULLNAME_INDEX));
- ASET (info, 2, make_number (font->pixel_size));
- ASET (info, 3, make_number (font->height));
- ASET (info, 4, make_number (font->baseline_offset));
- ASET (info, 5, make_number (font->relative_compose));
- ASET (info, 6, make_number (font->default_ascent));
- ASET (info, 7, make_number (font->max_width));
- ASET (info, 8, make_number (font->ascent));
- ASET (info, 9, make_number (font->descent));
- ASET (info, 10, make_number (font->space_width));
- ASET (info, 11, make_number (font->average_width));
+ ASET (info, 2, make_fixnum (font->pixel_size));
+ ASET (info, 3, make_fixnum (font->height));
+ ASET (info, 4, make_fixnum (font->baseline_offset));
+ ASET (info, 5, make_fixnum (font->relative_compose));
+ ASET (info, 6, make_fixnum (font->default_ascent));
+ ASET (info, 7, make_fixnum (font->max_width));
+ ASET (info, 8, make_fixnum (font->ascent));
+ ASET (info, 9, make_fixnum (font->descent));
+ ASET (info, 10, make_fixnum (font->space_width));
+ ASET (info, 11, make_fixnum (font->average_width));
ASET (info, 12, AREF (font_object, FONT_FILE_INDEX));
if (font->driver->otf_capability)
ASET (info, 13, Fcons (Qopentype, font->driver->otf_capability (font)));
@@ -5166,15 +5168,14 @@ If the named font is not yet loaded, return nil. */)
static Lisp_Object
build_style_table (const struct table_entry *entry, int nelement)
{
- int i, j;
- Lisp_Object table, elt;
-
- table = make_uninit_vector (nelement);
- for (i = 0; i < nelement; i++)
+ Lisp_Object table = make_uninit_vector (nelement);
+ for (int i = 0; i < nelement; i++)
{
- for (j = 0; entry[i].names[j]; j++);
- elt = Fmake_vector (make_number (j + 1), Qnil);
- ASET (elt, 0, make_number (entry[i].numeric));
+ int j;
+ for (j = 0; entry[i].names[j]; j++)
+ continue;
+ Lisp_Object elt = make_nil_vector (j + 1);
+ ASET (elt, 0, make_fixnum (entry[i].numeric));
for (j = 0; entry[i].names[j]; j++)
ASET (elt, j + 1, intern_c_string (entry[i].names[j]));
ASET (table, i, elt);
@@ -5309,9 +5310,10 @@ syms_of_font (void)
sort_shift_bits[FONT_SIZE_INDEX] = 16;
sort_shift_bits[FONT_WIDTH_INDEX] = 23;
/* Note that the other elements in sort_shift_bits are not used. */
+ PDUMPER_REMEMBER_SCALAR (sort_shift_bits);
- staticpro (&font_charset_alist);
font_charset_alist = Qnil;
+ staticpro (&font_charset_alist);
DEFSYM (Qopentype, "opentype");
@@ -5349,13 +5351,13 @@ syms_of_font (void)
DEFSYM (QCuser_spec, ":user-spec");
- staticpro (&scratch_font_spec);
scratch_font_spec = Ffont_spec (0, NULL);
- staticpro (&scratch_font_prefer);
+ staticpro (&scratch_font_spec);
scratch_font_prefer = Ffont_spec (0, NULL);
+ staticpro (&scratch_font_prefer);
+ Vfont_log_deferred = make_nil_vector (3);
staticpro (&Vfont_log_deferred);
- Vfont_log_deferred = Fmake_vector (make_number (3), Qnil);
#if 0
#ifdef HAVE_LIBOTF
diff --git a/src/font.h b/src/font.h
index b6e43b0c9ca..3720650a2e1 100644
--- a/src/font.h
+++ b/src/font.h
@@ -185,16 +185,16 @@ enum font_property_index
/* Return the numeric weight value of FONT. */
#define FONT_WEIGHT_NUMERIC(font) \
- (INTEGERP (AREF ((font), FONT_WEIGHT_INDEX)) \
- ? (XINT (AREF ((font), FONT_WEIGHT_INDEX)) >> 8) : -1)
+ (FIXNUMP (AREF ((font), FONT_WEIGHT_INDEX)) \
+ ? (XFIXNUM (AREF ((font), FONT_WEIGHT_INDEX)) >> 8) : -1)
/* Return the numeric slant value of FONT. */
#define FONT_SLANT_NUMERIC(font) \
- (INTEGERP (AREF ((font), FONT_SLANT_INDEX)) \
- ? (XINT (AREF ((font), FONT_SLANT_INDEX)) >> 8) : -1)
+ (FIXNUMP (AREF ((font), FONT_SLANT_INDEX)) \
+ ? (XFIXNUM (AREF ((font), FONT_SLANT_INDEX)) >> 8) : -1)
/* Return the numeric width value of FONT. */
#define FONT_WIDTH_NUMERIC(font) \
- (INTEGERP (AREF ((font), FONT_WIDTH_INDEX)) \
- ? (XINT (AREF ((font), FONT_WIDTH_INDEX)) >> 8) : -1)
+ (FIXNUMP (AREF ((font), FONT_WIDTH_INDEX)) \
+ ? (XFIXNUM (AREF ((font), FONT_WIDTH_INDEX)) >> 8) : -1)
/* Return the symbolic weight value of FONT. */
#define FONT_WEIGHT_SYMBOLIC(font) \
font_style_symbolic (font, FONT_WEIGHT_INDEX, false)
@@ -228,7 +228,7 @@ enum font_property_index
style-related font property index (FONT_WEIGHT/SLANT/WIDTH_INDEX).
VAL (integer or symbol) is the numeric or symbolic style value. */
#define FONT_SET_STYLE(font, prop, val) \
- ASET ((font), prop, make_number (font_style_to_value (prop, val, true)))
+ ASET ((font), prop, make_fixnum (font_style_to_value (prop, val, true)))
#ifndef MSDOS
#define FONT_WIDTH(f) ((f)->max_width)
@@ -494,42 +494,42 @@ INLINE struct font_spec *
XFONT_SPEC (Lisp_Object p)
{
eassert (FONT_SPEC_P (p));
- return XUNTAG (p, Lisp_Vectorlike);
+ return XUNTAG (p, Lisp_Vectorlike, struct font_spec);
}
INLINE struct font_spec *
GC_XFONT_SPEC (Lisp_Object p)
{
eassert (GC_FONT_SPEC_P (p));
- return XUNTAG (p, Lisp_Vectorlike);
+ return XUNTAG (p, Lisp_Vectorlike, struct font_spec);
}
INLINE struct font_entity *
XFONT_ENTITY (Lisp_Object p)
{
eassert (FONT_ENTITY_P (p));
- return XUNTAG (p, Lisp_Vectorlike);
+ return XUNTAG (p, Lisp_Vectorlike, struct font_entity);
}
INLINE struct font_entity *
GC_XFONT_ENTITY (Lisp_Object p)
{
eassert (GC_FONT_ENTITY_P (p));
- return XUNTAG (p, Lisp_Vectorlike);
+ return XUNTAG (p, Lisp_Vectorlike, struct font_entity);
}
INLINE struct font *
XFONT_OBJECT (Lisp_Object p)
{
eassert (FONT_OBJECT_P (p));
- return XUNTAG (p, Lisp_Vectorlike);
+ return XUNTAG (p, Lisp_Vectorlike, struct font);
}
INLINE struct font *
GC_XFONT_OBJECT (Lisp_Object p)
{
eassert (GC_FONT_OBJECT_P (p));
- return XUNTAG (p, Lisp_Vectorlike);
+ return XUNTAG (p, Lisp_Vectorlike, struct font);
}
#define XSETFONT(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_FONT))
@@ -606,14 +606,14 @@ struct font_driver
The properties that the font-entity has are the same as described
for the `list' method above. */
- Lisp_Object (*match) (struct frame *f, Lisp_Object spec);
+ Lisp_Object (*match) (struct frame *f, Lisp_Object font_spec);
/* Optional.
List available families. The value is a list of family names
(symbols). */
Lisp_Object (*list_family) (struct frame *f);
- /* Optional (if FONT_EXTRA_INDEX is not Lisp_Save_Value).
+ /* Optional.
Free FONT_EXTRA_INDEX field of FONT_ENTITY. */
void (*free_entity) (Lisp_Object font_entity);
diff --git a/src/fontset.c b/src/fontset.c
index 34e0c0d4820..eec1e0da4cc 100644
--- a/src/fontset.c
+++ b/src/fontset.c
@@ -39,6 +39,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include TERM_HEADER
#endif /* HAVE_WINDOW_SYSTEM */
#include "font.h"
+#include "pdumper.h"
/* FONTSET
@@ -266,7 +267,7 @@ set_fontset_fallback (Lisp_Object fontset, Lisp_Object fallback)
#define RFONT_DEF_FACE(rfont_def) AREF (rfont_def, 0)
#define RFONT_DEF_SET_FACE(rfont_def, face_id) \
- ASET ((rfont_def), 0, make_number (face_id))
+ ASET ((rfont_def), 0, make_fixnum (face_id))
#define RFONT_DEF_FONT_DEF(rfont_def) AREF (rfont_def, 1)
#define RFONT_DEF_SPEC(rfont_def) FONT_DEF_SPEC (AREF (rfont_def, 1))
#define RFONT_DEF_OBJECT(rfont_def) AREF (rfont_def, 2)
@@ -276,15 +277,15 @@ set_fontset_fallback (Lisp_Object fontset, Lisp_Object fallback)
the order of listing by font backends, the higher bits represents
the order given by charset priority list. The smaller value is
preferable. */
-#define RFONT_DEF_SCORE(rfont_def) XINT (AREF (rfont_def, 3))
+#define RFONT_DEF_SCORE(rfont_def) XFIXNUM (AREF (rfont_def, 3))
#define RFONT_DEF_SET_SCORE(rfont_def, score) \
- ASET ((rfont_def), 3, make_number (score))
+ ASET ((rfont_def), 3, make_fixnum (score))
#define RFONT_DEF_NEW(rfont_def, font_def) \
do { \
- (rfont_def) = Fmake_vector (make_number (4), Qnil); \
- ASET ((rfont_def), 1, (font_def)); \
- RFONT_DEF_SET_SCORE ((rfont_def), 0); \
- } while (0)
+ (rfont_def) = make_nil_vector (4); \
+ ASET (rfont_def, 1, font_def); \
+ RFONT_DEF_SET_SCORE (rfont_def, 0); \
+ } while (false)
/* Return the element of FONTSET for the character C. If FONTSET is a
@@ -327,11 +328,8 @@ fontset_ref (Lisp_Object fontset, int c)
#define FONTSET_ADD(fontset, range, elt, add) \
(NILP (add) \
? (NILP (range) \
- ? (set_fontset_fallback \
- (fontset, Fmake_vector (make_number (1), (elt)))) \
- : ((void) \
- Fset_char_table_range (fontset, range, \
- Fmake_vector (make_number (1), elt)))) \
+ ? set_fontset_fallback (fontset, make_vector (1, elt)) \
+ : (void) Fset_char_table_range (fontset, range, make_vector (1, elt))) \
: fontset_add ((fontset), (range), (elt), (add)))
static void
@@ -340,12 +338,12 @@ fontset_add (Lisp_Object fontset, Lisp_Object range, Lisp_Object elt, Lisp_Objec
Lisp_Object args[2];
int idx = (EQ (add, Qappend) ? 0 : 1);
- args[1 - idx] = Fmake_vector (make_number (1), elt);
+ args[1 - idx] = make_vector (1, elt);
if (CONSP (range))
{
- int from = XINT (XCAR (range));
- int to = XINT (XCDR (range));
+ int from = XFIXNUM (XCAR (range));
+ int to = XFIXNUM (XCDR (range));
int from1, to1;
do {
@@ -456,7 +454,7 @@ reorder_font_vector (Lisp_Object font_group, struct font *font)
qsort (XVECTOR (vec)->contents, size, word_size,
fontset_compare_rfontdef);
EMACS_INT low_tick_bits = charset_ordered_list_tick & MOST_POSITIVE_FIXNUM;
- XSETCAR (font_group, make_number (low_tick_bits));
+ XSETCAR (font_group, make_fixnum (low_tick_bits));
}
/* Return a font-group (actually a cons (CHARSET_ORDERED_LIST_TICK
@@ -496,7 +494,7 @@ fontset_get_font_group (Lisp_Object fontset, int c)
for C, or the fontset does not have fallback fonts. */
if (NILP (font_group))
{
- font_group = make_number (0);
+ font_group = make_fixnum (0);
if (c >= 0)
/* Record that FONTSET does not specify fonts for C. As
there's a possibility that a font is found in a fallback
@@ -520,7 +518,7 @@ fontset_get_font_group (Lisp_Object fontset, int c)
RFONT_DEF_SET_SCORE (rfont_def, i);
ASET (font_group, i, rfont_def);
}
- font_group = Fcons (make_number (-1), font_group);
+ font_group = Fcons (make_fixnum (-1), font_group);
if (c >= 0)
char_table_set_range (fontset, from, to, font_group);
else
@@ -561,7 +559,7 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face,
if (ASIZE (vec) > 1)
{
- if (XINT (XCAR (font_group)) != charset_ordered_list_tick)
+ if (XFIXNUM (XCAR (font_group)) != charset_ordered_list_tick)
/* We have just created the font-group,
or the charset priorities were changed. */
reorder_font_vector (font_group, face->ascii_face->font);
@@ -577,7 +575,7 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face,
break;
repertory = FONT_DEF_REPERTORY (RFONT_DEF_FONT_DEF (rfont_def));
- if (XINT (repertory) == charset_id)
+ if (XFIXNUM (repertory) == charset_id)
{
charset_matched = i;
break;
@@ -633,8 +631,8 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face,
/* This is a sign of not to try the other fonts. */
return Qt;
}
- if (INTEGERP (RFONT_DEF_FACE (rfont_def))
- && XINT (RFONT_DEF_FACE (rfont_def)) < 0)
+ if (FIXNUMP (RFONT_DEF_FACE (rfont_def))
+ && XFIXNUM (RFONT_DEF_FACE (rfont_def)) < 0)
/* We couldn't open this font last time. */
continue;
@@ -701,7 +699,6 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face,
{
/* We found a font. Open it and insert a new element for
that font in VEC. */
- Lisp_Object new_vec;
int j;
font_object = font_open_for_lface (f, font_entity, face->lface,
@@ -711,7 +708,7 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face,
RFONT_DEF_NEW (rfont_def, font_def);
RFONT_DEF_SET_OBJECT (rfont_def, font_object);
RFONT_DEF_SET_SCORE (rfont_def, RFONT_DEF_SCORE (rfont_def));
- new_vec = Fmake_vector (make_number (ASIZE (vec) + 1), Qnil);
+ Lisp_Object new_vec = make_nil_vector (ASIZE (vec) + 1);
found_index++;
for (j = 0; j < found_index; j++)
ASET (new_vec, j, AREF (vec, j));
@@ -727,7 +724,7 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face,
}
/* Record that no font in this font group supports C. */
- FONTSET_SET (fontset, make_number (c), make_number (0));
+ FONTSET_SET (fontset, make_fixnum (c), make_fixnum (0));
return Qnil;
found:
@@ -756,12 +753,12 @@ fontset_font (Lisp_Object fontset, int c, struct face *face, int id)
Lisp_Object base_fontset;
/* Try a font-group of FONTSET. */
- FONT_DEFERRED_LOG ("current fontset: font for", make_number (c), Qnil);
+ FONT_DEFERRED_LOG ("current fontset: font for", make_fixnum (c), Qnil);
rfont_def = fontset_find_font (fontset, c, face, id, 0);
if (VECTORP (rfont_def))
return rfont_def;
if (NILP (rfont_def))
- FONTSET_SET (fontset, make_number (c), make_number (0));
+ FONTSET_SET (fontset, make_fixnum (c), make_fixnum (0));
/* Try a font-group of the default fontset. */
base_fontset = FONTSET_BASE (fontset);
@@ -771,37 +768,37 @@ fontset_font (Lisp_Object fontset, int c, struct face *face, int id)
set_fontset_default
(fontset,
make_fontset (FONTSET_FRAME (fontset), Qnil, Vdefault_fontset));
- FONT_DEFERRED_LOG ("default fontset: font for", make_number (c), Qnil);
+ FONT_DEFERRED_LOG ("default fontset: font for", make_fixnum (c), Qnil);
default_rfont_def
= fontset_find_font (FONTSET_DEFAULT (fontset), c, face, id, 0);
if (VECTORP (default_rfont_def))
return default_rfont_def;
if (NILP (default_rfont_def))
- FONTSET_SET (FONTSET_DEFAULT (fontset), make_number (c),
- make_number (0));
+ FONTSET_SET (FONTSET_DEFAULT (fontset), make_fixnum (c),
+ make_fixnum (0));
}
/* Try a fallback font-group of FONTSET. */
if (! EQ (rfont_def, Qt))
{
- FONT_DEFERRED_LOG ("current fallback: font for", make_number (c), Qnil);
+ FONT_DEFERRED_LOG ("current fallback: font for", make_fixnum (c), Qnil);
rfont_def = fontset_find_font (fontset, c, face, id, 1);
if (VECTORP (rfont_def))
return rfont_def;
/* Remember that FONTSET has no font for C. */
- FONTSET_SET (fontset, make_number (c), Qt);
+ FONTSET_SET (fontset, make_fixnum (c), Qt);
}
/* Try a fallback font-group of the default fontset. */
if (! EQ (base_fontset, Vdefault_fontset)
&& ! EQ (default_rfont_def, Qt))
{
- FONT_DEFERRED_LOG ("default fallback: font for", make_number (c), Qnil);
+ FONT_DEFERRED_LOG ("default fallback: font for", make_fixnum (c), Qnil);
rfont_def = fontset_find_font (FONTSET_DEFAULT (fontset), c, face, id, 1);
if (VECTORP (rfont_def))
return rfont_def;
/* Remember that the default fontset has no font for C. */
- FONTSET_SET (FONTSET_DEFAULT (fontset), make_number (c), Qt);
+ FONTSET_SET (FONTSET_DEFAULT (fontset), make_fixnum (c), Qt);
}
return Qnil;
@@ -830,7 +827,7 @@ make_fontset (Lisp_Object frame, Lisp_Object name, Lisp_Object base)
fontset = Fmake_char_table (Qfontset, Qnil);
- set_fontset_id (fontset, make_number (id));
+ set_fontset_id (fontset, make_fixnum (id));
if (NILP (base))
set_fontset_name (fontset, name);
else
@@ -892,7 +889,7 @@ free_face_fontset (struct frame *f, struct face *face)
next_fontset_id = face->fontset;
if (! NILP (FONTSET_DEFAULT (fontset)))
{
- int id = XINT (FONTSET_ID (FONTSET_DEFAULT (fontset)));
+ int id = XFIXNUM (FONTSET_ID (FONTSET_DEFAULT (fontset)));
fontset = AREF (Vfontset_table, id);
eassert (!NILP (fontset) && ! BASE_FONTSET_P (fontset));
@@ -973,7 +970,7 @@ face_for_char (struct frame *f, struct face *face, int c,
}
else
{
- charset = Fget_char_property (make_number (pos), Qcharset, object);
+ charset = Fget_char_property (make_fixnum (pos), Qcharset, object);
if (CHARSETP (charset))
{
Lisp_Object val;
@@ -981,7 +978,7 @@ face_for_char (struct frame *f, struct face *face, int c,
val = assq_no_quit (charset, Vfont_encoding_charset_alist);
if (CONSP (val) && CHARSETP (XCDR (val)))
charset = XCDR (val);
- id = XINT (CHARSET_SYMBOL_ID (charset));
+ id = XFIXNUM (CHARSET_SYMBOL_ID (charset));
}
else
id = -1;
@@ -990,8 +987,8 @@ face_for_char (struct frame *f, struct face *face, int c,
rfont_def = fontset_font (fontset, c, face, id);
if (VECTORP (rfont_def))
{
- if (INTEGERP (RFONT_DEF_FACE (rfont_def)))
- face_id = XINT (RFONT_DEF_FACE (rfont_def));
+ if (FIXNUMP (RFONT_DEF_FACE (rfont_def)))
+ face_id = XFIXNUM (RFONT_DEF_FACE (rfont_def));
else
{
Lisp_Object font_object;
@@ -1003,12 +1000,12 @@ face_for_char (struct frame *f, struct face *face, int c,
}
else
{
- if (INTEGERP (FONTSET_NOFONT_FACE (fontset)))
- face_id = XINT (FONTSET_NOFONT_FACE (fontset));
+ if (FIXNUMP (FONTSET_NOFONT_FACE (fontset)))
+ face_id = XFIXNUM (FONTSET_NOFONT_FACE (fontset));
else
{
face_id = face_for_font (f, Qnil, face);
- set_fontset_nofont_face (fontset, make_number (face_id));
+ set_fontset_nofont_face (fontset, make_fixnum (face_id));
}
}
eassert (face_id >= 0);
@@ -1040,7 +1037,7 @@ font_for_char (struct face *face, int c, ptrdiff_t pos, Lisp_Object object)
}
else
{
- charset = Fget_char_property (make_number (pos), Qcharset, object);
+ charset = Fget_char_property (make_fixnum (pos), Qcharset, object);
if (CHARSETP (charset))
{
Lisp_Object val;
@@ -1048,7 +1045,7 @@ font_for_char (struct face *face, int c, ptrdiff_t pos, Lisp_Object object)
val = assq_no_quit (charset, Vfont_encoding_charset_alist);
if (CONSP (val) && CHARSETP (XCDR (val)))
charset = XCDR (val);
- id = XINT (CHARSET_SYMBOL_ID (charset));
+ id = XFIXNUM (CHARSET_SYMBOL_ID (charset));
}
else
id = -1;
@@ -1083,7 +1080,7 @@ make_fontset_for_ascii_face (struct frame *f, int base_fontset_id, struct face *
base_fontset = Vdefault_fontset;
fontset = make_fontset (frame, Qnil, base_fontset);
- return XINT (FONTSET_ID (fontset));
+ return XFIXNUM (FONTSET_ID (fontset));
}
@@ -1306,7 +1303,7 @@ free_realized_fontsets (Lisp_Object base)
tail = XCDR (tail))
{
struct frame *f = XFRAME (FONTSET_FRAME (this));
- int face_id = XINT (XCDR (XCAR (tail)));
+ int face_id = XFIXNUM (XCDR (XCAR (tail)));
struct face *face = FACE_FROM_ID_OR_NULL (f, face_id);
/* Face THIS itself is also freed by the following call. */
@@ -1399,7 +1396,7 @@ static void
set_fontset_font (Lisp_Object arg, Lisp_Object range)
{
Lisp_Object fontset, font_def, add, ascii, script_range_list;
- int from = XINT (XCAR (range)), to = XINT (XCDR (range));
+ int from = XFIXNUM (XCAR (range)), to = XFIXNUM (XCDR (range));
fontset = AREF (arg, 0);
font_def = AREF (arg, 1);
@@ -1412,11 +1409,11 @@ set_fontset_font (Lisp_Object arg, Lisp_Object range)
if (to < 0x80)
return;
from = 0x80;
- range = Fcons (make_number (0x80), XCDR (range));
+ range = Fcons (make_fixnum (0x80), XCDR (range));
}
-#define SCRIPT_FROM XINT (XCAR (XCAR (script_range_list)))
-#define SCRIPT_TO XINT (XCDR (XCAR (script_range_list)))
+#define SCRIPT_FROM XFIXNUM (XCAR (XCAR (script_range_list)))
+#define SCRIPT_TO XFIXNUM (XCDR (XCAR (script_range_list)))
#define POP_SCRIPT_RANGE() script_range_list = XCDR (script_range_list)
for (; CONSP (script_range_list) && SCRIPT_TO < from; POP_SCRIPT_RANGE ())
@@ -1424,11 +1421,11 @@ set_fontset_font (Lisp_Object arg, Lisp_Object range)
if (CONSP (script_range_list))
{
if (SCRIPT_FROM < from)
- range = Fcons (make_number (SCRIPT_FROM), XCDR (range));
+ range = Fcons (make_fixnum (SCRIPT_FROM), XCDR (range));
while (CONSP (script_range_list) && SCRIPT_TO <= to)
POP_SCRIPT_RANGE ();
if (CONSP (script_range_list) && SCRIPT_FROM <= to)
- XSETCAR (XCAR (script_range_list), make_number (to + 1));
+ XSETCAR (XCAR (script_range_list), make_fixnum (to + 1));
}
FONTSET_ADD (fontset, range, font_def, add);
@@ -1547,7 +1544,7 @@ appended. By default, FONT-SPEC overrides the previous settings. */)
if (CHARACTERP (target))
{
- if (XFASTINT (target) < 0x80)
+ if (XFIXNAT (target) < 0x80)
error ("Can't set a font for partial ASCII range");
range_list = list1 (Fcons (target, target));
}
@@ -1559,9 +1556,9 @@ appended. By default, FONT-SPEC overrides the previous settings. */)
to = Fcdr (target);
CHECK_CHARACTER (from);
CHECK_CHARACTER (to);
- if (XFASTINT (from) < 0x80)
+ if (XFIXNAT (from) < 0x80)
{
- if (XFASTINT (from) != 0 || XFASTINT (to) < 0x7F)
+ if (XFIXNAT (from) != 0 || XFIXNAT (to) < 0x7F)
error ("Can't set a font for partial ASCII range");
ascii_changed = 1;
}
@@ -1632,7 +1629,7 @@ appended. By default, FONT-SPEC overrides the previous settings. */)
if (ascii_changed)
{
Lisp_Object tail, fr;
- int fontset_id = XINT (FONTSET_ID (fontset));
+ int fontset_id = XFIXNUM (FONTSET_ID (fontset));
set_fontset_ascii (fontset, fontname);
name = FONTSET_NAME (fontset);
@@ -1765,7 +1762,7 @@ fontset_from_font (Lisp_Object font_object)
val = assoc_no_quit (font_spec, auto_fontset_alist);
if (CONSP (val))
- return XINT (FONTSET_ID (XCDR (val)));
+ return XFIXNUM (FONTSET_ID (XCDR (val)));
if (num_auto_fontsets++ == 0)
alias = intern ("fontset-startup");
else
@@ -1800,7 +1797,7 @@ fontset_from_font (Lisp_Object font_object)
set_fontset_ascii (fontset, font_name);
- return XINT (FONTSET_ID (fontset));
+ return XFIXNUM (FONTSET_ID (fontset));
}
@@ -1988,7 +1985,7 @@ patterns. */)
fontset = check_fontset_name (name, &frame);
CHECK_CHARACTER (ch);
- c = XINT (ch);
+ c = XFIXNUM (ch);
list = Qnil;
while (1)
{
@@ -2003,9 +2000,9 @@ patterns. */)
if (NILP (val))
return Qnil;
repertory = AREF (val, 1);
- if (INTEGERP (repertory))
+ if (FIXNUMP (repertory))
{
- struct charset *charset = CHARSET_FROM_ID (XINT (repertory));
+ struct charset *charset = CHARSET_FROM_ID (XFIXNUM (repertory));
if (! CHAR_CHARSET_P (c, charset))
continue;
@@ -2062,9 +2059,7 @@ Lisp_Object dump_fontset (Lisp_Object) EXTERNALLY_VISIBLE;
Lisp_Object
dump_fontset (Lisp_Object fontset)
{
- Lisp_Object vec;
-
- vec = Fmake_vector (make_number (3), Qnil);
+ Lisp_Object vec = make_nil_vector (3);
ASET (vec, 0, FONTSET_ID (fontset));
if (BASE_FONTSET_P (fontset))
@@ -2112,9 +2107,9 @@ void
syms_of_fontset (void)
{
DEFSYM (Qfontset, "fontset");
- Fput (Qfontset, Qchar_table_extra_slots, make_number (8));
+ Fput (Qfontset, Qchar_table_extra_slots, make_fixnum (8));
DEFSYM (Qfontset_info, "fontset-info");
- Fput (Qfontset_info, Qchar_table_extra_slots, make_number (1));
+ Fput (Qfontset_info, Qchar_table_extra_slots, make_fixnum (1));
DEFSYM (Qappend, "append");
DEFSYM (Qlatin, "latin");
@@ -2122,17 +2117,18 @@ syms_of_fontset (void)
Vcached_fontset_data = Qnil;
staticpro (&Vcached_fontset_data);
- Vfontset_table = Fmake_vector (make_number (32), Qnil);
+ Vfontset_table = make_nil_vector (32);
staticpro (&Vfontset_table);
Vdefault_fontset = Fmake_char_table (Qfontset, Qnil);
staticpro (&Vdefault_fontset);
- set_fontset_id (Vdefault_fontset, make_number (0));
+ set_fontset_id (Vdefault_fontset, make_fixnum (0));
set_fontset_name
(Vdefault_fontset,
build_pure_c_string ("-*-*-*-*-*-*-*-*-*-*-*-*-fontset-default"));
ASET (Vfontset_table, 0, Vdefault_fontset);
next_fontset_id = 1;
+ PDUMPER_REMEMBER_SCALAR (next_fontset_id);
auto_fontset_alist = Qnil;
staticpro (&auto_fontset_alist);
diff --git a/src/frame.c b/src/frame.c
index 9c3ff72271a..192ef4244fb 100644
--- a/src/frame.c
+++ b/src/frame.c
@@ -35,6 +35,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "buffer.h"
/* These help us bind and responding to switch-frame events. */
#include "keyboard.h"
+#include "ptr-bounds.h"
#include "frame.h"
#include "blockinput.h"
#include "termchar.h"
@@ -52,11 +53,14 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifdef USE_X_TOOLKIT
#include "widget.h"
#endif
+#include "pdumper.h"
/* The currently selected frame. */
-
Lisp_Object selected_frame;
+/* The selected frame the last time window change functions were run. */
+Lisp_Object old_selected_frame;
+
/* A frame which is not just a mini-buffer, or NULL if there are no such
frames. This is usually the most recent such frame that was selected. */
@@ -66,7 +70,7 @@ static struct frame *last_nonminibuf_frame;
bool frame_garbaged;
/* The default tool bar height for future frames. */
-#if defined USE_GTK || defined HAVE_NS
+#ifdef HAVE_EXT_TOOL_BAR
enum { frame_default_tool_bar_height = 0 };
#else
int frame_default_tool_bar_height;
@@ -138,14 +142,9 @@ check_window_system (struct frame *f)
/* Return the value of frame parameter PROP in frame FRAME. */
Lisp_Object
-get_frame_param (register struct frame *frame, Lisp_Object prop)
+get_frame_param (struct frame *frame, Lisp_Object prop)
{
- register Lisp_Object tem;
-
- tem = Fassq (prop, frame->param_alist);
- if (EQ (tem, Qnil))
- return tem;
- return Fcdr (tem);
+ return Fcdr (Fassq (prop, frame->param_alist));
}
@@ -157,17 +156,15 @@ frame_size_history_add (struct frame *f, Lisp_Object fun_symbol,
XSETFRAME (frame, f);
if (CONSP (frame_size_history)
- && INTEGERP (XCAR (frame_size_history))
- && 0 < XINT (XCAR (frame_size_history)))
+ && FIXNUMP (XCAR (frame_size_history))
+ && 0 < XFIXNUM (XCAR (frame_size_history)))
frame_size_history =
- Fcons (make_number (XINT (XCAR (frame_size_history)) - 1),
+ Fcons (make_fixnum (XFIXNUM (XCAR (frame_size_history)) - 1),
Fcons (list4
(frame, fun_symbol,
((width > 0)
- ? list4 (make_number (FRAME_TEXT_WIDTH (f)),
- make_number (FRAME_TEXT_HEIGHT (f)),
- make_number (width),
- make_number (height))
+ ? list4i (FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f),
+ width, height)
: Qnil),
rest),
XCDR (frame_size_history)));
@@ -188,9 +185,9 @@ frame_inhibit_resize (struct frame *f, bool horizontal, Lisp_Object parameter)
|| (CONSP (frame_inhibit_implied_resize)
&& !NILP (Fmemq (parameter, frame_inhibit_implied_resize)))
|| (horizontal
- && !EQ (fullscreen, Qnil) && !EQ (fullscreen, Qfullheight))
+ && !NILP (fullscreen) && !EQ (fullscreen, Qfullheight))
|| (!horizontal
- && !EQ (fullscreen, Qnil) && !EQ (fullscreen, Qfullwidth))
+ && !NILP (fullscreen) && !EQ (fullscreen, Qfullwidth))
|| FRAME_TERMCAP_P (f) || FRAME_MSDOS_P (f))
: ((horizontal && f->inhibit_horizontal_resize)
|| (!horizontal && f->inhibit_vertical_resize)));
@@ -218,8 +215,8 @@ set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
if (FRAME_MINIBUF_ONLY_P (f))
return;
- if (TYPE_RANGED_INTEGERP (int, value))
- nlines = XINT (value);
+ if (TYPE_RANGED_FIXNUMP (int, value))
+ nlines = XFIXNUM (value);
else
nlines = 0;
@@ -316,12 +313,12 @@ predicates which report frame's specific UI-related capabilities. */)
/* Placeholder used by temacs -nw before window.el is loaded. */
DEFUN ("frame-windows-min-size", Fframe_windows_min_size,
Sframe_windows_min_size, 4, 4, 0,
- doc: /* */
+ doc: /* SKIP: real doc in window.el. */
attributes: const)
(Lisp_Object frame, Lisp_Object horizontal,
Lisp_Object ignore, Lisp_Object pixelwise)
{
- return make_number (0);
+ return make_fixnum (0);
}
/**
@@ -354,11 +351,15 @@ frame_windows_min_size (Lisp_Object frame, Lisp_Object horizontal,
int retval;
if ((!NILP (horizontal)
- && NUMBERP (par_size = get_frame_param (f, Qmin_width)))
+ && RANGED_FIXNUMP (INT_MIN,
+ par_size = get_frame_param (f, Qmin_width),
+ INT_MAX))
|| (NILP (horizontal)
- && NUMBERP (par_size = get_frame_param (f, Qmin_height))))
+ && RANGED_FIXNUMP (INT_MIN,
+ par_size = get_frame_param (f, Qmin_height),
+ INT_MAX)))
{
- int min_size = XINT (par_size);
+ int min_size = XFIXNUM (par_size);
/* Don't allow phantom frames. */
if (min_size < 1)
@@ -371,7 +372,7 @@ frame_windows_min_size (Lisp_Object frame, Lisp_Object horizontal,
: FRAME_COLUMN_WIDTH (f)));
}
else
- retval = XINT (call4 (Qframe_windows_min_size, frame, horizontal,
+ retval = XFIXNUM (call4 (Qframe_windows_min_size, frame, horizontal,
ignore, pixelwise));
/* Don't allow too small height of text-mode frames, or else cm.c
might abort in cmcheckmagic. */
@@ -595,7 +596,7 @@ adjust_frame_size (struct frame *f, int new_width, int new_height, int inhibit,
frame_size_history_add
(f, Qadjust_frame_size_1, new_text_width, new_text_height,
- list2 (parameter, make_number (inhibit)));
+ list2 (parameter, make_fixnum (inhibit)));
/* The following two values are calculated from the old window body
sizes and any "new" settings for scroll bars, dividers, fringes and
@@ -711,7 +712,7 @@ adjust_frame_size (struct frame *f, int new_width, int new_height, int inhibit,
if ((FRAME_TERMCAP_P (f) && !pretend) || FRAME_MSDOS_P (f))
FrameCols (FRAME_TTY (f)) = new_cols;
-#if defined (HAVE_WINDOW_SYSTEM) && ! defined (USE_GTK) && ! defined (HAVE_NS)
+#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_TOOL_BAR)
if (WINDOWP (f->tool_bar_window))
{
XWINDOW (f->tool_bar_window)->pixel_width = new_windows_width;
@@ -741,8 +742,8 @@ adjust_frame_size (struct frame *f, int new_width, int new_height, int inhibit,
frame_size_history_add
(f, Qadjust_frame_size_3, new_text_width, new_text_height,
- list4 (make_number (old_pixel_width), make_number (old_pixel_height),
- make_number (new_pixel_width), make_number (new_pixel_height)));
+ list4i (old_pixel_width, old_pixel_height,
+ new_pixel_width, new_pixel_height));
/* Assign new sizes. */
FRAME_TEXT_WIDTH (f) = new_text_width;
@@ -797,7 +798,8 @@ adjust_frame_size (struct frame *f, int new_width, int new_height, int inhibit,
static struct frame *
allocate_frame (void)
{
- return ALLOCATE_ZEROED_PSEUDOVECTOR (struct frame, face_cache, PVEC_FRAME);
+ return ALLOCATE_ZEROED_PSEUDOVECTOR (struct frame, tool_bar_items,
+ PVEC_FRAME);
}
struct frame *
@@ -846,7 +848,8 @@ make_frame (bool mini_p)
f->no_focus_on_map = false;
f->no_accept_focus = false;
f->z_group = z_group_none;
-#if ! defined (USE_GTK) && ! defined (HAVE_NS)
+ f->tooltip = false;
+#ifndef HAVE_EXT_TOOL_BAR
f->last_tool_bar_item = -1;
#endif
#ifdef NS_IMPL_COCOA
@@ -854,7 +857,8 @@ make_frame (bool mini_p)
f->ns_transparent_titlebar = false;
#endif
#endif
-
+ /* This one should never be zero. */
+ f->change_stamp = 1;
root_window = make_window ();
rw = XWINDOW (root_window);
if (mini_p)
@@ -1047,10 +1051,7 @@ make_initial_frame (void)
Lisp_Object frame;
eassert (initial_kboard);
-
- /* The first call must initialize Vframe_list. */
- if (! (NILP (Vframe_list) || CONSP (Vframe_list)))
- Vframe_list = Qnil;
+ eassert (NILP (Vframe_list) || CONSP (Vframe_list));
terminal = init_initial_terminal ();
@@ -1078,7 +1079,7 @@ make_initial_frame (void)
#endif
/* The default value of menu-bar-mode is t. */
- set_menu_bar_lines (f, make_number (1), Qnil);
+ set_menu_bar_lines (f, make_fixnum (1), Qnil);
/* Allocate glyph matrices. */
adjust_frame_glyphs (f);
@@ -1450,26 +1451,19 @@ This function returns FRAME, or nil if FRAME has been deleted. */)
return do_switch_frame (frame, 1, 0, norecord);
}
-DEFUN ("handle-switch-frame", Fhandle_switch_frame, Shandle_switch_frame, 1, 1, "^e",
+DEFUN ("handle-switch-frame", Fhandle_switch_frame,
+ Shandle_switch_frame, 1, 1, "^e",
doc: /* Handle a switch-frame event EVENT.
Switch-frame events are usually bound to this function.
-A switch-frame event tells Emacs that the window manager has requested
-that the user's events be directed to the frame mentioned in the event.
-This function selects the selected window of the frame of EVENT.
-
-If EVENT is frame object, handle it as if it were a switch-frame event
-to that frame. */)
+A switch-frame event is an event Emacs sends itself to
+indicate that input is arriving in a new frame. It does not
+necessarily represent user-visible input focus. */)
(Lisp_Object event)
{
- Lisp_Object value;
-
/* Preserve prefix arg that the command loop just cleared. */
kset_prefix_arg (current_kboard, Vcurrent_prefix_arg);
run_hook (Qmouse_leave_buffer_hook);
- /* `switch-frame' implies a focus in. */
- value = do_switch_frame (event, 0, 0, Qnil);
- call1 (intern ("handle-focus-in"), event);
- return value;
+ return do_switch_frame (event, 0, 0, Qnil);
}
DEFUN ("selected-frame", Fselected_frame, Sselected_frame, 0, 0, 0,
@@ -1478,23 +1472,36 @@ DEFUN ("selected-frame", Fselected_frame, Sselected_frame, 0, 0, 0,
{
return selected_frame;
}
+
+DEFUN ("old-selected-frame", Fold_selected_frame,
+ Sold_selected_frame, 0, 0, 0,
+ doc: /* Return the old selected FRAME.
+FRAME must be a live frame and defaults to the selected one.
+
+The return value is the frame selected the last time window change
+functions were run. */)
+ (void)
+{
+ return old_selected_frame;
+}
DEFUN ("frame-list", Fframe_list, Sframe_list,
0, 0, 0,
- doc: /* Return a list of all live frames. */)
+ doc: /* Return a list of all live frames.
+The return value does not include any tooltip frame. */)
(void)
{
- Lisp_Object frames;
- frames = Fcopy_sequence (Vframe_list);
#ifdef HAVE_WINDOW_SYSTEM
- if (FRAMEP (tip_frame)
-#ifdef USE_GTK
- && !NILP (Fframe_parameter (tip_frame, Qtooltip))
-#endif
- )
- frames = Fdelq (tip_frame, frames);
-#endif
- return frames;
+ Lisp_Object list = Qnil, tail, frame;
+
+ FOR_EACH_FRAME (tail, frame)
+ if (!FRAME_TOOLTIP_P (XFRAME (frame)))
+ list = Fcons (frame, list);
+ /* Reverse list for consistency with the !HAVE_WINDOW_SYSTEM case. */
+ return Fnreverse (list);
+#else /* !HAVE_WINDOW_SYSTEM */
+ return Fcopy_sequence (Vframe_list);
+#endif /* HAVE_WINDOW_SYSTEM */
}
DEFUN ("frame-parent", Fframe_parent, Sframe_parent,
@@ -1603,7 +1610,7 @@ candidate_frame (Lisp_Object candidate, Lisp_Object frame, Lisp_Object minibuf)
FRAME_FOCUS_FRAME (c)))
return candidate;
}
- else if (INTEGERP (minibuf) && XINT (minibuf) == 0)
+ else if (FIXNUMP (minibuf) && XFIXNUM (minibuf) == 0)
{
if (FRAME_VISIBLE_P (c) || FRAME_ICONIFIED_P (c))
return candidate;
@@ -1725,7 +1732,8 @@ DEFUN ("last-nonminibuffer-frame", Flast_nonminibuf_frame,
* other_frames:
*
* Return true if there exists at least one visible or iconified frame
- * but F. Return false otherwise.
+ * but F. Tooltip frames do not qualify as candidates. Return false
+ * if no such frame exists.
*
* INVISIBLE true means we are called from make_frame_invisible where
* such a frame must be visible or iconified. INVISIBLE nil means we
@@ -1739,7 +1747,6 @@ static bool
other_frames (struct frame *f, bool invisible, bool force)
{
Lisp_Object frames, frame, frame1;
- struct frame *f1;
Lisp_Object minibuffer_window = FRAME_MINIBUF_WINDOW (f);
XSETFRAME (frame, f);
@@ -1749,7 +1756,8 @@ other_frames (struct frame *f, bool invisible, bool force)
FOR_EACH_FRAME (frames, frame1)
{
- f1 = XFRAME (frame1);
+ struct frame *f1 = XFRAME (frame1);
+
if (f != f1)
{
/* Verify that we can still talk to the frame's X window, and
@@ -1758,7 +1766,7 @@ other_frames (struct frame *f, bool invisible, bool force)
if (FRAME_WINDOW_P (f1))
x_sync (f1);
#endif
- if (NILP (Fframe_parameter (frame1, Qtooltip))
+ if (!FRAME_TOOLTIP_P (f1)
/* Tooltips and child frames count neither for
invisibility nor for deletions. */
&& !FRAME_PARENT_FRAME (f1)
@@ -1794,7 +1802,7 @@ check_minibuf_window (Lisp_Object frame, int select)
if (WINDOWP (minibuf_window) && EQ (f->minibuffer_window, minibuf_window))
{
- Lisp_Object frames, this, window = make_number (0);
+ Lisp_Object frames, this, window = make_fixnum (0);
if (!EQ (frame, selected_frame)
&& FRAME_HAS_MINIBUF_P (XFRAME (selected_frame)))
@@ -1842,6 +1850,7 @@ delete_frame (Lisp_Object frame, Lisp_Object force)
Lisp_Object frames, frame1;
int minibuffer_selected, is_tooltip_frame;
bool nochild = !FRAME_PARENT_FRAME (f);
+ Lisp_Object minibuffer_child_frame = Qnil;
if (!FRAME_LIVE_P (f))
return Qnil;
@@ -1858,13 +1867,33 @@ delete_frame (Lisp_Object frame, Lisp_Object force)
/* Softly delete all frames with this frame as their parent frame or
as their `delete-before' frame parameter value. */
FOR_EACH_FRAME (frames, frame1)
- if (FRAME_PARENT_FRAME (XFRAME (frame1)) == f
+ {
+ struct frame *f1 = XFRAME (frame1);
+
+ if (EQ (frame1, frame) || FRAME_TOOLTIP_P (f1))
+ continue;
+ else if (FRAME_PARENT_FRAME (f1) == f)
+ {
+ if (FRAME_HAS_MINIBUF_P (f1) && !FRAME_HAS_MINIBUF_P (f)
+ && EQ (FRAME_MINIBUF_WINDOW (f), FRAME_MINIBUF_WINDOW (f1)))
+ /* frame1 owns frame's minibuffer window so we must not
+ delete it here to avoid a surrogate minibuffer error.
+ Unparent frame1 and make it a top-level frame. */
+ {
+ Fmodify_frame_parameters
+ (frame1, Fcons (Fcons (Qparent_frame, Qnil), Qnil));
+ minibuffer_child_frame = frame1;
+ }
+ else
+ delete_frame (frame1, Qnil);
+ }
+ else if (nochild
+ && EQ (get_frame_param (XFRAME (frame1), Qdelete_before), frame))
/* Process `delete-before' parameter iff FRAME is not a child
frame. This avoids that we enter an infinite chain of mixed
dependencies. */
- || (nochild
- && EQ (get_frame_param (XFRAME (frame1), Qdelete_before), frame)))
- delete_frame (frame1, Qnil);
+ delete_frame (frame1, Qnil);
+ }
/* Does this frame have a minibuffer, and is it the surrogate
minibuffer for any other frame? */
@@ -1891,7 +1920,7 @@ delete_frame (Lisp_Object frame, Lisp_Object force)
}
}
- is_tooltip_frame = !NILP (Fframe_parameter (frame, Qtooltip));
+ is_tooltip_frame = FRAME_TOOLTIP_P (f);
/* Run `delete-frame-functions' unless FORCE is `noelisp' or
frame is a tooltip. FORCE is set to `noelisp' when handling
@@ -1940,27 +1969,31 @@ delete_frame (Lisp_Object frame, Lisp_Object force)
Do not call next_frame here because it may loop forever.
See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=15025. */
FOR_EACH_FRAME (tail, frame1)
- if (!EQ (frame, frame1)
- && NILP (Fframe_parameter (frame1, Qtooltip))
- && (FRAME_TERMINAL (XFRAME (frame))
- == FRAME_TERMINAL (XFRAME (frame1)))
- && FRAME_VISIBLE_P (XFRAME (frame1)))
- break;
+ {
+ struct frame *f1 = XFRAME (frame1);
+
+ if (!EQ (frame, frame1)
+ && !FRAME_TOOLTIP_P (f1)
+ && FRAME_TERMINAL (f) == FRAME_TERMINAL (f1)
+ && FRAME_VISIBLE_P (f1))
+ break;
+ }
/* If there is none, find *some* other frame. */
if (NILP (frame1) || EQ (frame1, frame))
{
FOR_EACH_FRAME (tail, frame1)
{
+ struct frame *f1 = XFRAME (frame1);
+
if (!EQ (frame, frame1)
- && FRAME_LIVE_P (XFRAME (frame1))
- && NILP (Fframe_parameter (frame1, Qtooltip)))
+ && FRAME_LIVE_P (f1)
+ && !FRAME_TOOLTIP_P (f1))
{
- /* Do not change a text terminal's top-frame. */
- struct frame *f1 = XFRAME (frame1);
if (FRAME_TERMCAP_P (f1) || FRAME_MSDOS_P (f1))
{
Lisp_Object top_frame = FRAME_TTY (f1)->top_frame;
+
if (!EQ (top_frame, frame))
frame1 = top_frame;
}
@@ -2125,18 +2158,27 @@ delete_frame (Lisp_Object frame, Lisp_Object force)
{
struct frame *f1 = XFRAME (frame1);
- /* Consider only frames on the same kboard
- and only those with minibuffers. */
- if (kb == FRAME_KBOARD (f1)
- && FRAME_HAS_MINIBUF_P (f1))
+ /* Set frame_on_same_kboard to frame1 if it is on the same
+ keyboard. Set frame_with_minibuf to frame1 if it also
+ has a minibuffer. Leave the loop immediately if frame1
+ is also minibuffer-only.
+
+ Emacs 26 does _not_ set frame_on_same_kboard here when it
+ finds a minibuffer-only frame and subsequently fails to
+ set default_minibuffer_frame below. Not a great deal and
+ never noticed since make_frame_without_minibuffer creates
+ a new minibuffer frame in that case (which can be a minor
+ annoyance though). To consider for Emacs 26.3. */
+ if (kb == FRAME_KBOARD (f1))
{
- frame_with_minibuf = frame1;
- if (FRAME_MINIBUF_ONLY_P (f1))
- break;
+ frame_on_same_kboard = frame1;
+ if (FRAME_HAS_MINIBUF_P (f1))
+ {
+ frame_with_minibuf = frame1;
+ if (FRAME_MINIBUF_ONLY_P (f1))
+ break;
+ }
}
-
- if (kb == FRAME_KBOARD (f1))
- frame_on_same_kboard = frame1;
}
if (!NILP (frame_on_same_kboard))
@@ -2161,6 +2203,55 @@ delete_frame (Lisp_Object frame, Lisp_Object force)
if (!is_tooltip_frame)
update_mode_lines = 15;
+ /* Now run the post-deletion hooks. */
+ if (NILP (Vrun_hooks) || is_tooltip_frame)
+ ;
+ else if (EQ (force, Qnoelisp))
+ pending_funcalls
+ = Fcons (list3 (Qrun_hook_with_args, Qafter_delete_frame_functions, frame),
+ pending_funcalls);
+ else
+ safe_call2 (Qrun_hook_with_args, Qafter_delete_frame_functions, frame);
+
+ if (!NILP (minibuffer_child_frame))
+ /* If minibuffer_child_frame is non-nil, it was FRAME's minibuffer
+ child frame. Delete it unless it's also the minibuffer frame
+ of another frame in which case we make sure it's visible. */
+ {
+ struct frame *f1 = XFRAME (minibuffer_child_frame);
+
+ if (FRAME_LIVE_P (f1))
+ {
+ Lisp_Object window1 = FRAME_ROOT_WINDOW (f1);
+ Lisp_Object frame2;
+
+ FOR_EACH_FRAME (frames, frame2)
+ {
+ struct frame *f2 = XFRAME (frame2);
+
+ if (EQ (frame2, minibuffer_child_frame) || FRAME_TOOLTIP_P (f2))
+ continue;
+ else if (EQ (FRAME_MINIBUF_WINDOW (f2), window1))
+ {
+ /* minibuffer_child_frame serves as minibuffer frame
+ for at least one other frame - so make it visible
+ and quit. */
+ if (!FRAME_VISIBLE_P (f1) && !FRAME_ICONIFIED_P (f1))
+ Fmake_frame_visible (minibuffer_child_frame);
+
+ return Qnil;
+ }
+ }
+
+ /* No other frame found that uses minibuffer_child_frame as
+ minibuffer frame. If FORCE is Qnoelisp or there are
+ other visible frames left, delete minibuffer_child_frame
+ since it presumably was used by FRAME only. */
+ if (EQ (force, Qnoelisp) || other_frames (f1, false, !NILP (force)))
+ delete_frame (minibuffer_child_frame, Qnoelisp);
+ }
+ }
+
return Qnil;
}
@@ -2310,8 +2401,8 @@ and returns whatever that function returns. */)
if (! NILP (x))
{
- int col = XINT (x);
- int row = XINT (y);
+ int col = XFIXNUM (x);
+ int row = XFIXNUM (y);
pixel_to_glyph_coords (f, col, row, &col, &row, NULL, 1);
XSETINT (x, col);
XSETINT (y, row);
@@ -2420,19 +2511,19 @@ before calling this function on it, like this.
#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), XINT (x), XINT (y));
+ frame_set_mouse_position (XFRAME (frame), XFIXNUM (x), XFIXNUM (y));
#else
#if defined (MSDOS)
if (FRAME_MSDOS_P (XFRAME (frame)))
{
Fselect_frame (frame, Qnil);
- mouse_moveto (XINT (x), XINT (y));
+ mouse_moveto (XFIXNUM (x), XFIXNUM (y));
}
#else
#ifdef HAVE_GPM
{
Fselect_frame (frame, Qnil);
- term_mouse_moveto (XINT (x), XINT (y));
+ term_mouse_moveto (XFIXNUM (x), XFIXNUM (y));
}
#endif
#endif
@@ -2461,19 +2552,19 @@ before calling this function on it, like this.
#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), XINT (x), XINT (y));
+ frame_set_mouse_pixel_position (XFRAME (frame), XFIXNUM (x), XFIXNUM (y));
#else
#if defined (MSDOS)
if (FRAME_MSDOS_P (XFRAME (frame)))
{
Fselect_frame (frame, Qnil);
- mouse_moveto (XINT (x), XINT (y));
+ mouse_moveto (XFIXNUM (x), XFIXNUM (y));
}
#else
#ifdef HAVE_GPM
{
Fselect_frame (frame, Qnil);
- term_mouse_moveto (XINT (x), XINT (y));
+ term_mouse_moveto (XFIXNUM (x), XFIXNUM (y));
}
#endif
#endif
@@ -2798,10 +2889,8 @@ frames_discard_buffer (Lisp_Object buffer)
void
store_in_alist (Lisp_Object *alistptr, Lisp_Object prop, Lisp_Object val)
{
- register Lisp_Object tem;
-
- tem = Fassq (prop, *alistptr);
- if (EQ (tem, Qnil))
+ Lisp_Object tem = Fassq (prop, *alistptr);
+ if (NILP (tem))
*alistptr = Fcons (Fcons (prop, val), *alistptr);
else
Fsetcdr (tem, val);
@@ -2954,6 +3043,13 @@ store_frame_param (struct frame *f, Lisp_Object prop, Lisp_Object val)
fset_buried_buffer_list (f, Fnreverse (list));
return;
}
+ else if ((EQ (prop, Qscroll_bar_width) || EQ (prop, Qscroll_bar_height))
+ && !NILP (val) && !RANGED_FIXNUMP (1, val, INT_MAX))
+ {
+ Lisp_Object old_val = Fcdr (Fassq (prop, f->param_alist));
+
+ val = old_val;
+ }
/* The tty color needed to be set before the frame's parameter
alist was updated with the new value. This is not true any more,
@@ -2965,7 +3061,7 @@ store_frame_param (struct frame *f, Lisp_Object prop, Lisp_Object val)
/* Update the frame parameter alist. */
old_alist_elt = Fassq (prop, f->param_alist);
- if (EQ (old_alist_elt, Qnil))
+ if (NILP (old_alist_elt))
fset_param_alist (f, Fcons (Fcons (prop, val), f->param_alist));
else
Fsetcdr (old_alist_elt, val);
@@ -2979,7 +3075,7 @@ store_frame_param (struct frame *f, Lisp_Object prop, Lisp_Object val)
if (! FRAME_WINDOW_P (f))
{
if (EQ (prop, Qmenu_bar_lines))
- set_menu_bar_lines (f, val, make_number (FRAME_MENU_BAR_LINES (f)));
+ set_menu_bar_lines (f, val, make_fixnum (FRAME_MENU_BAR_LINES (f)));
else if (EQ (prop, Qname))
set_term_frame_name (f, val);
}
@@ -3052,13 +3148,13 @@ If FRAME is omitted or nil, return information on the currently selected frame.
? (f->new_height / FRAME_LINE_HEIGHT (f))
: f->new_height)
: FRAME_LINES (f));
- store_in_alist (&alist, Qheight, make_number (height));
+ store_in_alist (&alist, Qheight, make_fixnum (height));
width = (f->new_width
? (f->new_pixelwise
? (f->new_width / FRAME_COLUMN_WIDTH (f))
: f->new_width)
: FRAME_COLS (f));
- store_in_alist (&alist, Qwidth, make_number (width));
+ store_in_alist (&alist, Qwidth, make_fixnum (width));
store_in_alist (&alist, Qmodeline, (FRAME_WANTS_MODELINE_P (f) ? Qt : Qnil));
store_in_alist (&alist, Qunsplittable, (FRAME_NO_SPLIT_P (f) ? Qt : Qnil));
store_in_alist (&alist, Qbuffer_list, f->buffer_list);
@@ -3110,7 +3206,7 @@ If FRAME is nil, describe the currently selected frame. */)
else if (EQ (parameter, Qline_spacing) && f->extra_line_spacing == 0)
/* If this is non-zero, we can't determine whether the user specified
an integer or float value without looking through 'param_alist'. */
- value = make_number (0);
+ value = make_fixnum (0);
else if (EQ (parameter, Qfont) && FRAME_X_P (f))
value = FRAME_FONT (f)->props[FONT_NAME_INDEX];
#endif /* HAVE_WINDOW_SYSTEM */
@@ -3183,7 +3279,7 @@ list, but are otherwise ignored. */)
#endif
{
- EMACS_INT length = XFASTINT (Flength (alist));
+ EMACS_INT length = list_length (alist);
ptrdiff_t i;
Lisp_Object *parms;
Lisp_Object *values;
@@ -3231,10 +3327,10 @@ For a terminal frame, the value is always 1. */)
struct frame *f = decode_any_frame (frame);
if (FRAME_WINDOW_P (f))
- return make_number (FRAME_LINE_HEIGHT (f));
+ return make_fixnum (FRAME_LINE_HEIGHT (f));
else
#endif
- return make_number (1);
+ return make_fixnum (1);
}
@@ -3250,10 +3346,10 @@ For a terminal screen, the value is always 1. */)
struct frame *f = decode_any_frame (frame);
if (FRAME_WINDOW_P (f))
- return make_number (FRAME_COLUMN_WIDTH (f));
+ return make_fixnum (FRAME_COLUMN_WIDTH (f));
else
#endif
- return make_number (1);
+ return make_fixnum (1);
}
DEFUN ("frame-native-width", Fframe_native_width,
@@ -3267,10 +3363,10 @@ If FRAME is omitted or nil, the selected frame is used. */)
#ifdef HAVE_WINDOW_SYSTEM
if (FRAME_WINDOW_P (f))
- return make_number (FRAME_PIXEL_WIDTH (f));
+ return make_fixnum (FRAME_PIXEL_WIDTH (f));
else
#endif
- return make_number (FRAME_TOTAL_COLS (f));
+ return make_fixnum (FRAME_TOTAL_COLS (f));
}
DEFUN ("frame-native-height", Fframe_native_height,
@@ -3293,10 +3389,10 @@ to `frame-height'). */)
#ifdef HAVE_WINDOW_SYSTEM
if (FRAME_WINDOW_P (f))
- return make_number (FRAME_PIXEL_HEIGHT (f));
+ return make_fixnum (FRAME_PIXEL_HEIGHT (f));
else
#endif
- return make_number (FRAME_TOTAL_LINES (f));
+ return make_fixnum (FRAME_TOTAL_LINES (f));
}
DEFUN ("tool-bar-pixel-width", Ftool_bar_pixel_width,
@@ -3311,93 +3407,93 @@ is used. */)
struct frame *f = decode_any_frame (frame);
if (FRAME_WINDOW_P (f))
- return make_number (FRAME_TOOLBAR_WIDTH (f));
+ return make_fixnum (FRAME_TOOLBAR_WIDTH (f));
#endif
- return make_number (0);
+ return make_fixnum (0);
}
DEFUN ("frame-text-cols", Fframe_text_cols, Sframe_text_cols, 0, 1, 0,
doc: /* Return width in columns of FRAME's text area. */)
(Lisp_Object frame)
{
- return make_number (FRAME_COLS (decode_any_frame (frame)));
+ return make_fixnum (FRAME_COLS (decode_any_frame (frame)));
}
DEFUN ("frame-text-lines", Fframe_text_lines, Sframe_text_lines, 0, 1, 0,
doc: /* Return height in lines of FRAME's text area. */)
(Lisp_Object frame)
{
- return make_number (FRAME_LINES (decode_any_frame (frame)));
+ return make_fixnum (FRAME_LINES (decode_any_frame (frame)));
}
DEFUN ("frame-total-cols", Fframe_total_cols, Sframe_total_cols, 0, 1, 0,
doc: /* Return number of total columns of FRAME. */)
(Lisp_Object frame)
{
- return make_number (FRAME_TOTAL_COLS (decode_any_frame (frame)));
+ return make_fixnum (FRAME_TOTAL_COLS (decode_any_frame (frame)));
}
DEFUN ("frame-total-lines", Fframe_total_lines, Sframe_total_lines, 0, 1, 0,
doc: /* Return number of total lines of FRAME. */)
(Lisp_Object frame)
{
- return make_number (FRAME_TOTAL_LINES (decode_any_frame (frame)));
+ return make_fixnum (FRAME_TOTAL_LINES (decode_any_frame (frame)));
}
DEFUN ("frame-text-width", Fframe_text_width, Sframe_text_width, 0, 1, 0,
doc: /* Return text area width of FRAME in pixels. */)
(Lisp_Object frame)
{
- return make_number (FRAME_TEXT_WIDTH (decode_any_frame (frame)));
+ return make_fixnum (FRAME_TEXT_WIDTH (decode_any_frame (frame)));
}
DEFUN ("frame-text-height", Fframe_text_height, Sframe_text_height, 0, 1, 0,
doc: /* Return text area height of FRAME in pixels. */)
(Lisp_Object frame)
{
- return make_number (FRAME_TEXT_HEIGHT (decode_any_frame (frame)));
+ return make_fixnum (FRAME_TEXT_HEIGHT (decode_any_frame (frame)));
}
DEFUN ("frame-scroll-bar-width", Fscroll_bar_width, Sscroll_bar_width, 0, 1, 0,
doc: /* Return scroll bar width of FRAME in pixels. */)
(Lisp_Object frame)
{
- return make_number (FRAME_SCROLL_BAR_AREA_WIDTH (decode_any_frame (frame)));
+ return make_fixnum (FRAME_SCROLL_BAR_AREA_WIDTH (decode_any_frame (frame)));
}
DEFUN ("frame-scroll-bar-height", Fscroll_bar_height, Sscroll_bar_height, 0, 1, 0,
doc: /* Return scroll bar height of FRAME in pixels. */)
(Lisp_Object frame)
{
- return make_number (FRAME_SCROLL_BAR_AREA_HEIGHT (decode_any_frame (frame)));
+ return make_fixnum (FRAME_SCROLL_BAR_AREA_HEIGHT (decode_any_frame (frame)));
}
DEFUN ("frame-fringe-width", Ffringe_width, Sfringe_width, 0, 1, 0,
doc: /* Return fringe width of FRAME in pixels. */)
(Lisp_Object frame)
{
- return make_number (FRAME_TOTAL_FRINGE_WIDTH (decode_any_frame (frame)));
+ return make_fixnum (FRAME_TOTAL_FRINGE_WIDTH (decode_any_frame (frame)));
}
DEFUN ("frame-internal-border-width", Fframe_internal_border_width, Sframe_internal_border_width, 0, 1, 0,
doc: /* Return width of FRAME's internal border in pixels. */)
(Lisp_Object frame)
{
- return make_number (FRAME_INTERNAL_BORDER_WIDTH (decode_any_frame (frame)));
+ return make_fixnum (FRAME_INTERNAL_BORDER_WIDTH (decode_any_frame (frame)));
}
DEFUN ("frame-right-divider-width", Fright_divider_width, Sright_divider_width, 0, 1, 0,
doc: /* Return width (in pixels) of vertical window dividers on FRAME. */)
(Lisp_Object frame)
{
- return make_number (FRAME_RIGHT_DIVIDER_WIDTH (decode_any_frame (frame)));
+ return make_fixnum (FRAME_RIGHT_DIVIDER_WIDTH (decode_any_frame (frame)));
}
DEFUN ("frame-bottom-divider-width", Fbottom_divider_width, Sbottom_divider_width, 0, 1, 0,
doc: /* Return width (in pixels) of horizontal window dividers on FRAME. */)
(Lisp_Object frame)
{
- return make_number (FRAME_BOTTOM_DIVIDER_WIDTH (decode_any_frame (frame)));
+ return make_fixnum (FRAME_BOTTOM_DIVIDER_WIDTH (decode_any_frame (frame)));
}
DEFUN ("set-frame-height", Fset_frame_height, Sset_frame_height, 2, 4, 0,
@@ -3418,8 +3514,8 @@ multiple of the default frame font height. */)
CHECK_TYPE_RANGED_INTEGER (int, height);
pixel_height = (!NILP (pixelwise)
- ? XINT (height)
- : XINT (height) * FRAME_LINE_HEIGHT (f));
+ ? XFIXNUM (height)
+ : XFIXNUM (height) * FRAME_LINE_HEIGHT (f));
adjust_frame_size (f, -1, pixel_height, 1, !NILP (pretend), Qheight);
return Qnil;
@@ -3443,8 +3539,8 @@ multiple of the default frame font width. */)
CHECK_TYPE_RANGED_INTEGER (int, width);
pixel_width = (!NILP (pixelwise)
- ? XINT (width)
- : XINT (width) * FRAME_COLUMN_WIDTH (f));
+ ? XFIXNUM (width)
+ : XFIXNUM (width) * FRAME_COLUMN_WIDTH (f));
adjust_frame_size (f, pixel_width, -1, 1, !NILP (pretend), Qwidth);
return Qnil;
@@ -3466,11 +3562,11 @@ font height. */)
CHECK_TYPE_RANGED_INTEGER (int, height);
pixel_width = (!NILP (pixelwise)
- ? XINT (width)
- : XINT (width) * FRAME_COLUMN_WIDTH (f));
+ ? XFIXNUM (width)
+ : XFIXNUM (width) * FRAME_COLUMN_WIDTH (f));
pixel_height = (!NILP (pixelwise)
- ? XINT (height)
- : XINT (height) * FRAME_LINE_HEIGHT (f));
+ ? XFIXNUM (height)
+ : XFIXNUM (height) * FRAME_LINE_HEIGHT (f));
adjust_frame_size (f, pixel_width, pixel_height, 1, 0, Qsize);
return Qnil;
@@ -3487,7 +3583,7 @@ display. */)
{
register struct frame *f = decode_live_frame (frame);
- return Fcons (make_number (f->left_pos), make_number (f->top_pos));
+ return Fcons (make_fixnum (f->left_pos), make_fixnum (f->top_pos));
}
DEFUN ("set-frame-position", Fset_frame_position,
@@ -3510,12 +3606,46 @@ bottom edge of FRAME's display. */)
if (FRAME_WINDOW_P (f))
{
#ifdef HAVE_WINDOW_SYSTEM
- x_set_offset (f, XINT (x), XINT (y), 1);
+ x_set_offset (f, XFIXNUM (x), XFIXNUM (y), 1);
#endif
}
return Qt;
}
+
+DEFUN ("frame-window-state-change", Fframe_window_state_change,
+ Sframe_window_state_change, 0, 1, 0,
+ doc: /* Return t if FRAME's window state change flag is set, nil otherwise.
+FRAME must be a live frame and defaults to the selected one.
+
+If FRAME's window state change flag is set, the default values of
+`window-state-change-functions' and `window-state-change-hook' will be
+run during next redisplay, regardless of whether a window state change
+actually occurred on FRAME or not. After that, the value of this flag
+is reset. */)
+ (Lisp_Object frame)
+{
+ return FRAME_WINDOW_STATE_CHANGE (decode_live_frame (frame)) ? Qt : Qnil;
+}
+
+DEFUN ("set-frame-window-state-change", Fset_frame_window_state_change,
+ Sset_frame_window_state_change, 0, 2, 0,
+ doc: /* Set FRAME's window state change flag according to ARG.
+Set FRAME's window state change flag if ARG is non-nil, reset it
+otherwise.
+
+If FRAME's window state change flag is set, the default values of
+`window-state-change-functions' and `window-state-change-hook' will be
+run during next redisplay, regardless of whether a window state change
+actually occurred on FRAME or not. After that, the value of FRAME's
+window state change flag is reset. */)
+ (Lisp_Object frame, Lisp_Object arg)
+{
+ struct frame *f = decode_live_frame (frame);
+
+ return (FRAME_WINDOW_STATE_CHANGE (f) = !NILP (arg)) ? Qt : Qnil;
+}
+
/***********************************************************************
Frame Parameters
@@ -3679,10 +3809,10 @@ frame_float (struct frame *f, Lisp_Object val, enum frame_float_type what,
}
/* Workarea available. */
- parent_left = XINT (Fnth (make_number (0), workarea));
- parent_top = XINT (Fnth (make_number (1), workarea));
- parent_width = XINT (Fnth (make_number (2), workarea));
- parent_height = XINT (Fnth (make_number (3), workarea));
+ parent_left = XFIXNUM (Fnth (make_fixnum (0), workarea));
+ parent_top = XFIXNUM (Fnth (make_fixnum (1), workarea));
+ parent_width = XFIXNUM (Fnth (make_fixnum (2), workarea));
+ parent_height = XFIXNUM (Fnth (make_fixnum (3), workarea));
*parent_done = 1;
}
}
@@ -3710,12 +3840,12 @@ frame_float (struct frame *f, Lisp_Object val, enum frame_float_type what,
if (!NILP (outer_edges))
{
outer_minus_text_width
- = (XINT (Fnth (make_number (2), outer_edges))
- - XINT (Fnth (make_number (0), outer_edges))
+ = (XFIXNUM (Fnth (make_fixnum (2), outer_edges))
+ - XFIXNUM (Fnth (make_fixnum (0), outer_edges))
- FRAME_TEXT_WIDTH (f));
outer_minus_text_height
- = (XINT (Fnth (make_number (3), outer_edges))
- - XINT (Fnth (make_number (1), outer_edges))
+ = (XFIXNUM (Fnth (make_fixnum (3), outer_edges))
+ - XFIXNUM (Fnth (make_fixnum (1), outer_edges))
- FRAME_TEXT_HEIGHT (f));
}
else
@@ -3795,7 +3925,7 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist)
Lisp_Object icon_left, icon_top;
/* And with this. */
- Lisp_Object fullscreen;
+ Lisp_Object fullscreen UNINIT;
bool fullscreen_change = false;
/* Record in these vectors all the parms specified. */
@@ -3864,22 +3994,22 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist)
if (EQ (prop, Qwidth))
{
- if (RANGED_INTEGERP (0, val, INT_MAX))
- width = XFASTINT (val) * FRAME_COLUMN_WIDTH (f) ;
+ if (RANGED_FIXNUMP (0, val, INT_MAX))
+ width = XFIXNAT (val) * FRAME_COLUMN_WIDTH (f) ;
else if (CONSP (val) && EQ (XCAR (val), Qtext_pixels)
- && RANGED_INTEGERP (0, XCDR (val), INT_MAX))
- width = XFASTINT (XCDR (val));
+ && RANGED_FIXNUMP (0, XCDR (val), INT_MAX))
+ width = XFIXNAT (XCDR (val));
else if (FLOATP (val))
width = frame_float (f, val, FRAME_FLOAT_WIDTH, &parent_done,
&outer_done, -1);
}
else if (EQ (prop, Qheight))
{
- if (RANGED_INTEGERP (0, val, INT_MAX))
- height = XFASTINT (val) * FRAME_LINE_HEIGHT (f);
+ if (RANGED_FIXNUMP (0, val, INT_MAX))
+ height = XFIXNAT (val) * FRAME_LINE_HEIGHT (f);
else if (CONSP (val) && EQ (XCAR (val), Qtext_pixels)
- && RANGED_INTEGERP (0, XCDR (val), INT_MAX))
- height = XFASTINT (XCDR (val));
+ && RANGED_FIXNUMP (0, XCDR (val), INT_MAX))
+ height = XFIXNAT (XCDR (val));
else if (FLOATP (val))
height = frame_float (f, val, FRAME_FLOAT_HEIGHT, &parent_done,
&outer_done, -1);
@@ -3906,10 +4036,10 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist)
store_frame_param (f, prop, val);
param_index = Fget (prop, Qx_frame_parameter);
- if (NATNUMP (param_index)
- && XFASTINT (param_index) < ARRAYELTS (frame_parms)
- && FRAME_RIF (f)->frame_parm_handlers[XINT (param_index)])
- (*(FRAME_RIF (f)->frame_parm_handlers[XINT (param_index)])) (f, val, old_value);
+ if (FIXNATP (param_index)
+ && XFIXNAT (param_index) < ARRAYELTS (frame_parms)
+ && FRAME_RIF (f)->frame_parm_handlers[XFIXNUM (param_index)])
+ (*(FRAME_RIF (f)->frame_parm_handlers[XFIXNUM (param_index)])) (f, val, old_value);
}
}
@@ -3918,7 +4048,7 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist)
{
left_no_change = 1;
if (f->left_pos < 0)
- left = list2 (Qplus, make_number (f->left_pos));
+ left = list2 (Qplus, make_fixnum (f->left_pos));
else
XSETINT (left, f->left_pos);
}
@@ -3926,13 +4056,13 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist)
{
top_no_change = 1;
if (f->top_pos < 0)
- top = list2 (Qplus, make_number (f->top_pos));
+ top = list2 (Qplus, make_fixnum (f->top_pos));
else
XSETINT (top, f->top_pos);
}
/* If one of the icon positions was not set, preserve or default it. */
- if (! TYPE_RANGED_INTEGERP (int, icon_left))
+ if (! TYPE_RANGED_FIXNUMP (int, icon_left))
{
#ifdef HAVE_X_WINDOWS
icon_left_no_change = 1;
@@ -3941,7 +4071,7 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist)
if (NILP (icon_left))
XSETINT (icon_left, 0);
}
- if (! TYPE_RANGED_INTEGERP (int, icon_top))
+ if (! TYPE_RANGED_FIXNUMP (int, icon_top))
{
#ifdef HAVE_X_WINDOWS
icon_top_no_change = 1;
@@ -3971,8 +4101,8 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist)
if ((!NILP (left) || !NILP (top))
&& ! (left_no_change && top_no_change)
- && ! (NUMBERP (left) && XINT (left) == f->left_pos
- && NUMBERP (top) && XINT (top) == f->top_pos))
+ && ! (FIXNUMP (left) && XFIXNUM (left) == f->left_pos
+ && FIXNUMP (top) && XFIXNUM (top) == f->top_pos))
{
int leftpos = 0;
int toppos = 0;
@@ -3981,46 +4111,46 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist)
f->size_hint_flags &= ~ (XNegative | YNegative);
if (EQ (left, Qminus))
f->size_hint_flags |= XNegative;
- else if (TYPE_RANGED_INTEGERP (int, left))
+ else if (TYPE_RANGED_FIXNUMP (int, left))
{
- leftpos = XINT (left);
+ leftpos = XFIXNUM (left);
if (leftpos < 0)
f->size_hint_flags |= XNegative;
}
else if (CONSP (left) && EQ (XCAR (left), Qminus)
&& CONSP (XCDR (left))
- && RANGED_INTEGERP (-INT_MAX, XCAR (XCDR (left)), INT_MAX))
+ && RANGED_FIXNUMP (-INT_MAX, XCAR (XCDR (left)), INT_MAX))
{
- leftpos = - XINT (XCAR (XCDR (left)));
+ leftpos = - XFIXNUM (XCAR (XCDR (left)));
f->size_hint_flags |= XNegative;
}
else if (CONSP (left) && EQ (XCAR (left), Qplus)
&& CONSP (XCDR (left))
- && TYPE_RANGED_INTEGERP (int, XCAR (XCDR (left))))
- leftpos = XINT (XCAR (XCDR (left)));
+ && TYPE_RANGED_FIXNUMP (int, XCAR (XCDR (left))))
+ leftpos = XFIXNUM (XCAR (XCDR (left)));
else if (FLOATP (left))
leftpos = frame_float (f, left, FRAME_FLOAT_LEFT, &parent_done,
&outer_done, 0);
if (EQ (top, Qminus))
f->size_hint_flags |= YNegative;
- else if (TYPE_RANGED_INTEGERP (int, top))
+ else if (TYPE_RANGED_FIXNUMP (int, top))
{
- toppos = XINT (top);
+ toppos = XFIXNUM (top);
if (toppos < 0)
f->size_hint_flags |= YNegative;
}
else if (CONSP (top) && EQ (XCAR (top), Qminus)
&& CONSP (XCDR (top))
- && RANGED_INTEGERP (-INT_MAX, XCAR (XCDR (top)), INT_MAX))
+ && RANGED_FIXNUMP (-INT_MAX, XCAR (XCDR (top)), INT_MAX))
{
- toppos = - XINT (XCAR (XCDR (top)));
+ toppos = - XFIXNUM (XCAR (XCDR (top)));
f->size_hint_flags |= YNegative;
}
else if (CONSP (top) && EQ (XCAR (top), Qplus)
&& CONSP (XCDR (top))
- && TYPE_RANGED_INTEGERP (int, XCAR (XCDR (top))))
- toppos = XINT (XCAR (XCDR (top)));
+ && TYPE_RANGED_FIXNUMP (int, XCAR (XCDR (top))))
+ toppos = XFIXNUM (XCAR (XCDR (top)));
else if (FLOATP (top))
toppos = frame_float (f, top, FRAME_FLOAT_TOP, &parent_done,
&outer_done, 0);
@@ -4051,7 +4181,7 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist)
#ifdef HAVE_X_WINDOWS
if ((!NILP (icon_left) || !NILP (icon_top))
&& ! (icon_left_no_change && icon_top_no_change))
- x_wm_set_icon_position (f, XINT (icon_left), XINT (icon_top));
+ x_wm_set_icon_position (f, XFIXNUM (icon_left), XFIXNUM (icon_top));
#endif /* HAVE_X_WINDOWS */
SAFE_FREE ();
@@ -4086,31 +4216,27 @@ x_report_frame_params (struct frame *f, Lisp_Object *alistptr)
store_in_alist (alistptr, Qtop, list2 (Qplus, tem));
store_in_alist (alistptr, Qborder_width,
- make_number (f->border_width));
+ make_fixnum (f->border_width));
store_in_alist (alistptr, Qinternal_border_width,
- make_number (FRAME_INTERNAL_BORDER_WIDTH (f)));
+ make_fixnum (FRAME_INTERNAL_BORDER_WIDTH (f)));
store_in_alist (alistptr, Qright_divider_width,
- make_number (FRAME_RIGHT_DIVIDER_WIDTH (f)));
+ make_fixnum (FRAME_RIGHT_DIVIDER_WIDTH (f)));
store_in_alist (alistptr, Qbottom_divider_width,
- make_number (FRAME_BOTTOM_DIVIDER_WIDTH (f)));
+ make_fixnum (FRAME_BOTTOM_DIVIDER_WIDTH (f)));
store_in_alist (alistptr, Qleft_fringe,
- make_number (FRAME_LEFT_FRINGE_WIDTH (f)));
+ make_fixnum (FRAME_LEFT_FRINGE_WIDTH (f)));
store_in_alist (alistptr, Qright_fringe,
- make_number (FRAME_RIGHT_FRINGE_WIDTH (f)));
+ make_fixnum (FRAME_RIGHT_FRINGE_WIDTH (f)));
store_in_alist (alistptr, Qscroll_bar_width,
- (! FRAME_HAS_VERTICAL_SCROLL_BARS (f)
- ? make_number (0)
- : FRAME_CONFIG_SCROLL_BAR_WIDTH (f) > 0
- ? make_number (FRAME_CONFIG_SCROLL_BAR_WIDTH (f))
+ (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) > 0
+ ? make_fixnum (FRAME_CONFIG_SCROLL_BAR_WIDTH (f))
/* nil means "use default width"
for non-toolkit scroll bar.
ruler-mode.el depends on this. */
: Qnil));
store_in_alist (alistptr, Qscroll_bar_height,
- (! FRAME_HAS_HORIZONTAL_SCROLL_BARS (f)
- ? make_number (0)
- : FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) > 0
- ? make_number (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f))
+ (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) > 0
+ ? make_fixnum (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f))
/* nil means "use default height"
for non-toolkit scroll bar. */
: Qnil));
@@ -4140,7 +4266,7 @@ x_report_frame_params (struct frame *f, Lisp_Object *alistptr)
if (FRAME_X_OUTPUT (f)->parent_desc == FRAME_DISPLAY_INFO (f)->root_window)
tem = Qnil;
else
- tem = make_natnum ((uintptr_t) FRAME_X_OUTPUT (f)->parent_desc);
+ tem = make_fixed_natnum ((uintptr_t) FRAME_X_OUTPUT (f)->parent_desc);
store_in_alist (alistptr, Qexplicit_name, (f->explicit_name ? Qt : Qnil));
store_in_alist (alistptr, Qparent_id, tem);
store_in_alist (alistptr, Qtool_bar_position, FRAME_TOOL_BAR_POSITION (f));
@@ -4177,8 +4303,8 @@ x_set_line_spacing (struct frame *f, Lisp_Object new_value, Lisp_Object old_valu
{
if (NILP (new_value))
f->extra_line_spacing = 0;
- else if (RANGED_INTEGERP (0, new_value, INT_MAX))
- f->extra_line_spacing = XFASTINT (new_value);
+ else if (RANGED_FIXNUMP (0, new_value, INT_MAX))
+ f->extra_line_spacing = XFIXNAT (new_value);
else if (FLOATP (new_value))
{
int new_spacing = XFLOAT_DATA (new_value) * FRAME_LINE_HEIGHT (f) + 0.5;
@@ -4216,10 +4342,10 @@ x_set_screen_gamma (struct frame *f, Lisp_Object new_value, Lisp_Object old_valu
if (CONSP (bgcolor) && (bgcolor = XCDR (bgcolor), STRINGP (bgcolor)))
{
Lisp_Object parm_index = Fget (Qbackground_color, Qx_frame_parameter);
- if (NATNUMP (parm_index)
- && XFASTINT (parm_index) < ARRAYELTS (frame_parms)
- && FRAME_RIF (f)->frame_parm_handlers[XFASTINT (parm_index)])
- (*FRAME_RIF (f)->frame_parm_handlers[XFASTINT (parm_index)])
+ if (FIXNATP (parm_index)
+ && XFIXNAT (parm_index) < ARRAYELTS (frame_parms)
+ && FRAME_RIF (f)->frame_parm_handlers[XFIXNAT (parm_index)])
+ (*FRAME_RIF (f)->frame_parm_handlers[XFIXNAT (parm_index)])
(f, bgcolor, Qnil);
}
@@ -4404,8 +4530,8 @@ x_set_left_fringe (struct frame *f, Lisp_Object new_value, Lisp_Object old_value
int old_width = FRAME_LEFT_FRINGE_WIDTH (f);
int new_width;
- new_width = (RANGED_INTEGERP (-INT_MAX, new_value, INT_MAX)
- ? eabs (XINT (new_value)) : 8);
+ new_width = (RANGED_FIXNUMP (-INT_MAX, new_value, INT_MAX)
+ ? eabs (XFIXNUM (new_value)) : 8);
if (new_width != old_width)
{
@@ -4428,8 +4554,8 @@ x_set_right_fringe (struct frame *f, Lisp_Object new_value, Lisp_Object old_valu
int old_width = FRAME_RIGHT_FRINGE_WIDTH (f);
int new_width;
- new_width = (RANGED_INTEGERP (-INT_MAX, new_value, INT_MAX)
- ? eabs (XINT (new_value)) : 8);
+ new_width = (RANGED_FIXNUMP (-INT_MAX, new_value, INT_MAX)
+ ? eabs (XFIXNUM (new_value)) : 8);
if (new_width != old_width)
{
@@ -4450,13 +4576,13 @@ x_set_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
{
CHECK_TYPE_RANGED_INTEGER (int, arg);
- if (XINT (arg) == f->border_width)
+ if (XFIXNUM (arg) == f->border_width)
return;
if (FRAME_X_WINDOW (f) != 0)
error ("Cannot change the border width of a frame");
- f->border_width = XINT (arg);
+ f->border_width = XFIXNUM (arg);
}
void
@@ -4464,7 +4590,7 @@ x_set_right_divider_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
{
int old = FRAME_RIGHT_DIVIDER_WIDTH (f);
CHECK_TYPE_RANGED_INTEGER (int, arg);
- int new = max (0, XINT (arg));
+ int new = max (0, XFIXNUM (arg));
if (new != old)
{
f->right_divider_width = new;
@@ -4479,7 +4605,7 @@ x_set_bottom_divider_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval
{
int old = FRAME_BOTTOM_DIVIDER_WIDTH (f);
CHECK_TYPE_RANGED_INTEGER (int, arg);
- int new = max (0, XINT (arg));
+ int new = max (0, XFIXNUM (arg));
if (new != old)
{
f->bottom_divider_width = new;
@@ -4506,13 +4632,13 @@ x_set_visibility (struct frame *f, Lisp_Object value, Lisp_Object oldval)
void
x_set_autoraise (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
{
- f->auto_raise = !EQ (Qnil, arg);
+ f->auto_raise = !NILP (arg);
}
void
x_set_autolower (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
{
- f->auto_lower = !EQ (Qnil, arg);
+ f->auto_lower = !NILP (arg);
}
void
@@ -4579,20 +4705,20 @@ x_set_scroll_bar_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
{
int unit = FRAME_COLUMN_WIDTH (f);
- if (NILP (arg))
+ if (RANGED_FIXNUMP (1, arg, INT_MAX)
+ && XFIXNAT (arg) != FRAME_CONFIG_SCROLL_BAR_WIDTH (f))
{
- x_set_scroll_bar_default_width (f);
-
+ FRAME_CONFIG_SCROLL_BAR_WIDTH (f) = XFIXNAT (arg);
+ FRAME_CONFIG_SCROLL_BAR_COLS (f) = (XFIXNAT (arg) + unit - 1) / unit;
if (FRAME_X_WINDOW (f))
adjust_frame_size (f, -1, -1, 3, 0, Qscroll_bar_width);
SET_FRAME_GARBAGED (f);
}
- else if (RANGED_INTEGERP (1, arg, INT_MAX)
- && XFASTINT (arg) != FRAME_CONFIG_SCROLL_BAR_WIDTH (f))
+ else
{
- FRAME_CONFIG_SCROLL_BAR_WIDTH (f) = XFASTINT (arg);
- FRAME_CONFIG_SCROLL_BAR_COLS (f) = (XFASTINT (arg) + unit - 1) / unit;
+ x_set_scroll_bar_default_width (f);
+
if (FRAME_X_WINDOW (f))
adjust_frame_size (f, -1, -1, 3, 0, Qscroll_bar_width);
@@ -4609,20 +4735,20 @@ x_set_scroll_bar_height (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
#if USE_HORIZONTAL_SCROLL_BARS
int unit = FRAME_LINE_HEIGHT (f);
- if (NILP (arg))
+ if (RANGED_FIXNUMP (1, arg, INT_MAX)
+ && XFIXNAT (arg) != FRAME_CONFIG_SCROLL_BAR_HEIGHT (f))
{
- x_set_scroll_bar_default_height (f);
-
+ FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) = XFIXNAT (arg);
+ FRAME_CONFIG_SCROLL_BAR_LINES (f) = (XFIXNAT (arg) + unit - 1) / unit;
if (FRAME_X_WINDOW (f))
adjust_frame_size (f, -1, -1, 3, 0, Qscroll_bar_height);
SET_FRAME_GARBAGED (f);
}
- else if (RANGED_INTEGERP (1, arg, INT_MAX)
- && XFASTINT (arg) != FRAME_CONFIG_SCROLL_BAR_HEIGHT (f))
+ else
{
- FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) = XFASTINT (arg);
- FRAME_CONFIG_SCROLL_BAR_LINES (f) = (XFASTINT (arg) + unit - 1) / unit;
+ x_set_scroll_bar_default_height (f);
+
if (FRAME_X_WINDOW (f))
adjust_frame_size (f, -1, -1, 3, 0, Qscroll_bar_height);
@@ -4661,11 +4787,11 @@ x_set_alpha (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
if (! (0 <= alpha && alpha <= 1.0))
args_out_of_range (make_float (0.0), make_float (1.0));
}
- else if (INTEGERP (item))
+ else if (FIXNUMP (item))
{
- EMACS_INT ialpha = XINT (item);
+ EMACS_INT ialpha = XFIXNUM (item);
if (! (0 <= ialpha && ialpha <= 100))
- args_out_of_range (make_number (0), make_number (100));
+ args_out_of_range (make_fixnum (0), make_fixnum (100));
alpha = ialpha / 100.0;
}
else
@@ -4833,6 +4959,8 @@ xrdb_get_resource (XrmDatabase rdb, Lisp_Object attribute, Lisp_Object class, Li
USE_SAFE_ALLOCA;
char *name_key = SAFE_ALLOCA (name_keysize + class_keysize);
char *class_key = name_key + name_keysize;
+ name_key = ptr_bounds_clip (name_key, name_keysize);
+ class_key = ptr_bounds_clip (class_key, class_keysize);
/* Start with emacs.FRAMENAME for the name (the specific one)
and with `Emacs' for the class key (the general one). */
@@ -4911,6 +5039,8 @@ x_get_resource_string (const char *attribute, const char *class)
ptrdiff_t class_keysize = sizeof (EMACS_CLASS) - 1 + strlen (class) + 2;
char *name_key = SAFE_ALLOCA (name_keysize + class_keysize);
char *class_key = name_key + name_keysize;
+ name_key = ptr_bounds_clip (name_key, name_keysize);
+ class_key = ptr_bounds_clip (class_key, class_keysize);
esprintf (name_key, "%s.%s", SSDATA (Vinvocation_name), attribute);
sprintf (class_key, "%s.%s", EMACS_CLASS, class);
@@ -4959,7 +5089,7 @@ x_get_arg (Display_Info *dpyinfo, Lisp_Object alist, Lisp_Object param,
/* If it wasn't specified in ALIST or the Lisp-level defaults,
look in the X resources. */
- if (EQ (tem, Qnil))
+ if (NILP (tem))
{
if (attribute && dpyinfo)
{
@@ -4973,13 +5103,13 @@ x_get_arg (Display_Info *dpyinfo, Lisp_Object alist, Lisp_Object param,
switch (type)
{
case RES_TYPE_NUMBER:
- return make_number (atoi (SSDATA (tem)));
+ return make_fixnum (atoi (SSDATA (tem)));
case RES_TYPE_BOOLEAN_NUMBER:
if (!strcmp (SSDATA (tem), "on")
|| !strcmp (SSDATA (tem), "true"))
- return make_number (1);
- return make_number (atoi (SSDATA (tem)));
+ return make_fixnum (1);
+ return make_fixnum (atoi (SSDATA (tem)));
break;
case RES_TYPE_FLOAT:
@@ -5208,11 +5338,11 @@ On Nextstep, this just calls `ns-parse-geometry'. */)
Lisp_Object element;
if (x >= 0 && (geometry & XNegative))
- element = list3 (Qleft, Qminus, make_number (-x));
+ element = list3 (Qleft, Qminus, make_fixnum (-x));
else if (x < 0 && ! (geometry & XNegative))
- element = list3 (Qleft, Qplus, make_number (x));
+ element = list3 (Qleft, Qplus, make_fixnum (x));
else
- element = Fcons (Qleft, make_number (x));
+ element = Fcons (Qleft, make_fixnum (x));
result = Fcons (element, result);
}
@@ -5221,18 +5351,18 @@ On Nextstep, this just calls `ns-parse-geometry'. */)
Lisp_Object element;
if (y >= 0 && (geometry & YNegative))
- element = list3 (Qtop, Qminus, make_number (-y));
+ element = list3 (Qtop, Qminus, make_fixnum (-y));
else if (y < 0 && ! (geometry & YNegative))
- element = list3 (Qtop, Qplus, make_number (y));
+ element = list3 (Qtop, Qplus, make_fixnum (y));
else
- element = Fcons (Qtop, make_number (y));
+ element = Fcons (Qtop, make_fixnum (y));
result = Fcons (element, result);
}
if (geometry & WidthValue)
- result = Fcons (Fcons (Qwidth, make_number (width)), result);
+ result = Fcons (Fcons (Qwidth, make_fixnum (width)), result);
if (geometry & HeightValue)
- result = Fcons (Fcons (Qheight, make_number (height)), result);
+ result = Fcons (Fcons (Qheight, make_fixnum (height)), result);
return result;
}
@@ -5284,15 +5414,15 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p, int *x
{
int margin, relief;
- relief = (tool_bar_button_relief >= 0
- ? tool_bar_button_relief
- : DEFAULT_TOOL_BAR_BUTTON_RELIEF);
+ relief = (tool_bar_button_relief < 0
+ ? DEFAULT_TOOL_BAR_BUTTON_RELIEF
+ : min (tool_bar_button_relief, 1000000));
- if (RANGED_INTEGERP (1, Vtool_bar_button_margin, INT_MAX))
- margin = XFASTINT (Vtool_bar_button_margin);
+ if (RANGED_FIXNUMP (1, Vtool_bar_button_margin, INT_MAX))
+ margin = XFIXNAT (Vtool_bar_button_margin);
else if (CONSP (Vtool_bar_button_margin)
- && RANGED_INTEGERP (1, XCDR (Vtool_bar_button_margin), INT_MAX))
- margin = XFASTINT (XCDR (Vtool_bar_button_margin));
+ && RANGED_FIXNUMP (1, XCDR (Vtool_bar_button_margin), INT_MAX))
+ margin = XFIXNAT (XCDR (Vtool_bar_button_margin));
else
margin = 0;
@@ -5313,13 +5443,13 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p, int *x
{
if (CONSP (width) && EQ (XCAR (width), Qtext_pixels))
{
- CHECK_NUMBER (XCDR (width));
- if ((XINT (XCDR (width)) < 0 || XINT (XCDR (width)) > INT_MAX))
+ CHECK_FIXNUM (XCDR (width));
+ if ((XFIXNUM (XCDR (width)) < 0 || XFIXNUM (XCDR (width)) > INT_MAX))
xsignal1 (Qargs_out_of_range, XCDR (width));
- SET_FRAME_WIDTH (f, XINT (XCDR (width)));
+ SET_FRAME_WIDTH (f, XFIXNUM (XCDR (width)));
f->inhibit_horizontal_resize = true;
- *x_width = XINT (XCDR (width));
+ *x_width = XFIXNUM (XCDR (width));
}
else if (FLOATP (width))
{
@@ -5338,11 +5468,11 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p, int *x
}
else
{
- CHECK_NUMBER (width);
- if ((XINT (width) < 0 || XINT (width) > INT_MAX))
+ CHECK_FIXNUM (width);
+ if ((XFIXNUM (width) < 0 || XFIXNUM (width) > INT_MAX))
xsignal1 (Qargs_out_of_range, width);
- SET_FRAME_WIDTH (f, XINT (width) * FRAME_COLUMN_WIDTH (f));
+ SET_FRAME_WIDTH (f, XFIXNUM (width) * FRAME_COLUMN_WIDTH (f));
}
}
@@ -5350,13 +5480,13 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p, int *x
{
if (CONSP (height) && EQ (XCAR (height), Qtext_pixels))
{
- CHECK_NUMBER (XCDR (height));
- if ((XINT (XCDR (height)) < 0 || XINT (XCDR (height)) > INT_MAX))
+ CHECK_FIXNUM (XCDR (height));
+ if ((XFIXNUM (XCDR (height)) < 0 || XFIXNUM (XCDR (height)) > INT_MAX))
xsignal1 (Qargs_out_of_range, XCDR (height));
- SET_FRAME_HEIGHT (f, XINT (XCDR (height)));
+ SET_FRAME_HEIGHT (f, XFIXNUM (XCDR (height)));
f->inhibit_vertical_resize = true;
- *x_height = XINT (XCDR (height));
+ *x_height = XFIXNUM (XCDR (height));
}
else if (FLOATP (height))
{
@@ -5375,11 +5505,11 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p, int *x
}
else
{
- CHECK_NUMBER (height);
- if ((XINT (height) < 0) || (XINT (height) > INT_MAX))
+ CHECK_FIXNUM (height);
+ if ((XFIXNUM (height) < 0) || (XFIXNUM (height) > INT_MAX))
xsignal1 (Qargs_out_of_range, height);
- SET_FRAME_HEIGHT (f, XINT (height) * FRAME_LINE_HEIGHT (f));
+ SET_FRAME_HEIGHT (f, XFIXNUM (height) * FRAME_LINE_HEIGHT (f));
}
}
@@ -5402,16 +5532,16 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p, int *x
}
else if (CONSP (top) && EQ (XCAR (top), Qminus)
&& CONSP (XCDR (top))
- && RANGED_INTEGERP (-INT_MAX, XCAR (XCDR (top)), INT_MAX))
+ && RANGED_FIXNUMP (-INT_MAX, XCAR (XCDR (top)), INT_MAX))
{
- f->top_pos = - XINT (XCAR (XCDR (top)));
+ f->top_pos = - XFIXNUM (XCAR (XCDR (top)));
window_prompting |= YNegative;
}
else if (CONSP (top) && EQ (XCAR (top), Qplus)
&& CONSP (XCDR (top))
- && TYPE_RANGED_INTEGERP (int, XCAR (XCDR (top))))
+ && TYPE_RANGED_FIXNUMP (int, XCAR (XCDR (top))))
{
- f->top_pos = XINT (XCAR (XCDR (top)));
+ f->top_pos = XFIXNUM (XCAR (XCDR (top)));
}
else if (FLOATP (top))
f->top_pos = frame_float (f, top, FRAME_FLOAT_TOP, &parent_done,
@@ -5421,7 +5551,7 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p, int *x
else
{
CHECK_TYPE_RANGED_INTEGER (int, top);
- f->top_pos = XINT (top);
+ f->top_pos = XFIXNUM (top);
if (f->top_pos < 0)
window_prompting |= YNegative;
}
@@ -5433,16 +5563,16 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p, int *x
}
else if (CONSP (left) && EQ (XCAR (left), Qminus)
&& CONSP (XCDR (left))
- && RANGED_INTEGERP (-INT_MAX, XCAR (XCDR (left)), INT_MAX))
+ && RANGED_FIXNUMP (-INT_MAX, XCAR (XCDR (left)), INT_MAX))
{
- f->left_pos = - XINT (XCAR (XCDR (left)));
+ f->left_pos = - XFIXNUM (XCAR (XCDR (left)));
window_prompting |= XNegative;
}
else if (CONSP (left) && EQ (XCAR (left), Qplus)
&& CONSP (XCDR (left))
- && TYPE_RANGED_INTEGERP (int, XCAR (XCDR (left))))
+ && TYPE_RANGED_FIXNUMP (int, XCAR (XCDR (left))))
{
- f->left_pos = XINT (XCAR (XCDR (left)));
+ f->left_pos = XFIXNUM (XCAR (XCDR (left)));
}
else if (FLOATP (left))
f->left_pos = frame_float (f, left, FRAME_FLOAT_LEFT, &parent_done,
@@ -5452,7 +5582,7 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p, int *x
else
{
CHECK_TYPE_RANGED_INTEGER (int, left);
- f->left_pos = XINT (left);
+ f->left_pos = XFIXNUM (left);
if (f->left_pos < 0)
window_prompting |= XNegative;
}
@@ -5533,8 +5663,8 @@ selected frame. This is useful when `make-pointer-invisible' is set. */)
#ifdef HAVE_WINDOW_SYSTEM
-# if (defined HAVE_NS \
- || (!defined USE_GTK && (defined HAVE_XINERAMA || defined HAVE_XRANDR)))
+# if (defined USE_GTK || defined HAVE_NS || defined HAVE_XINERAMA \
+ || defined HAVE_XRANDR)
void
free_monitors (struct MonitorInfo *monitors, int n_monitors)
{
@@ -5599,6 +5729,26 @@ make_monitor_attribute_list (struct MonitorInfo *monitors,
Initialization
***********************************************************************/
+static void init_frame_once_for_pdumper (void);
+
+void
+init_frame_once (void)
+{
+ staticpro (&Vframe_list);
+ staticpro (&selected_frame);
+ PDUMPER_IGNORE (last_nonminibuf_frame);
+ Vframe_list = Qnil;
+ selected_frame = Qnil;
+ pdumper_do_now_and_after_load (init_frame_once_for_pdumper);
+}
+
+static void
+init_frame_once_for_pdumper (void)
+{
+ PDUMPER_RESET_LV (Vframe_list, Qnil);
+ PDUMPER_RESET_LV (selected_frame, Qnil);
+}
+
void
syms_of_frame (void)
{
@@ -5777,7 +5927,7 @@ syms_of_frame (void)
Lisp_Object v = (frame_parms[i].sym < 0
? intern_c_string (frame_parms[i].name)
: builtin_lisp_symbol (frame_parms[i].sym));
- Fput (v, Qx_frame_parameter, make_number (i));
+ Fput (v, Qx_frame_parameter, make_fixnum (i));
}
}
@@ -5810,7 +5960,7 @@ is a reasonable practice. See also the variable `x-resource-name'. */);
doc: /* The lower limit of the frame opacity (alpha transparency).
The value should range from 0 (invisible) to 100 (completely opaque).
You can also use a floating number between 0.0 and 1.0. */);
- Vframe_alpha_lower_limit = make_number (20);
+ Vframe_alpha_lower_limit = make_fixnum (20);
#endif
DEFVAR_LISP ("default-frame-alist", Vdefault_frame_alist,
@@ -5876,15 +6026,6 @@ when the mouse is over clickable text. */);
The pointer becomes visible again when the mouse is moved. */);
Vmake_pointer_invisible = Qt;
- DEFVAR_LISP ("focus-in-hook", Vfocus_in_hook,
- doc: /* Normal hook run when a frame gains input focus.
-The frame gaining focus is selected at the time this hook is run. */);
- Vfocus_in_hook = Qnil;
-
- DEFVAR_LISP ("focus-out-hook", Vfocus_out_hook,
- doc: /* Normal hook run when all frames lost input focus. */);
- Vfocus_out_hook = Qnil;
-
DEFVAR_LISP ("move-frame-functions", Vmove_frame_functions,
doc: /* Functions run after a frame was moved.
The functions are run with one arg, the frame that moved. */);
@@ -5902,6 +6043,14 @@ recursively). */);
Vdelete_frame_functions = Qnil;
DEFSYM (Qdelete_frame_functions, "delete-frame-functions");
+ DEFVAR_LISP ("after-delete-frame-functions",
+ Vafter_delete_frame_functions,
+ doc: /* Functions run after deleting a frame.
+The functions are run with one arg, the frame that was deleted and
+which is now dead. */);
+ Vafter_delete_frame_functions = Qnil;
+ DEFSYM (Qafter_delete_frame_functions, "after-delete-frame-functions");
+
DEFVAR_LISP ("menu-bar-mode", Vmenu_bar_mode,
doc: /* Non-nil if Menu-Bar mode is enabled.
See the command `menu-bar-mode' for a description of this minor mode.
@@ -5931,6 +6080,19 @@ setting this variable does not change that frame's previous association.
This variable is local to the current terminal and cannot be buffer-local. */);
+ DEFVAR_LISP ("resize-mini-frames", resize_mini_frames,
+ doc: /* Non-nil means resize minibuffer-only frames automatically.
+If this is nil, do not resize minibuffer-only frames automatically.
+
+If this is a function, call that function with the minibuffer-only
+frame that shall be resized as sole argument. The buffer of the root
+window of that frame is the buffer whose text will be eventually shown
+in the minibuffer window.
+
+Any other non-nil value means to resize minibuffer-only frames by
+calling `fit-frame-to-buffer'. */);
+ resize_mini_frames = Qnil;
+
DEFVAR_LISP ("focus-follows-mouse", focus_follows_mouse,
doc: /* Non-nil if window system changes focus when you move the mouse.
You should set this variable to tell Emacs how your window manager
@@ -6081,16 +6243,15 @@ making the child frame unresponsive to user actions, the default is to
iconify the top level frame instead. */);
iconify_child_frame = Qiconify_top_level;
- staticpro (&Vframe_list);
-
defsubr (&Sframep);
defsubr (&Sframe_live_p);
defsubr (&Swindow_system);
defsubr (&Sframe_windows_min_size);
defsubr (&Smake_terminal_frame);
- defsubr (&Shandle_switch_frame);
defsubr (&Sselect_frame);
+ defsubr (&Shandle_switch_frame);
defsubr (&Sselected_frame);
+ defsubr (&Sold_selected_frame);
defsubr (&Sframe_list);
defsubr (&Sframe_parent);
defsubr (&Sframe_ancestor_p);
@@ -6143,6 +6304,8 @@ iconify the top level frame instead. */);
defsubr (&Sframe_position);
defsubr (&Sset_frame_position);
defsubr (&Sframe_pointer_visible_p);
+ defsubr (&Sframe_window_state_change);
+ defsubr (&Sset_frame_window_state_change);
#ifdef HAVE_WINDOW_SYSTEM
defsubr (&Sx_get_resource);
diff --git a/src/frame.h b/src/frame.h
index c069d18dde8..ec8f61465f2 100644
--- a/src/frame.h
+++ b/src/frame.h
@@ -125,6 +125,10 @@ struct frame
The selected window of the selected frame is Emacs's selected window. */
Lisp_Object selected_window;
+ /* This frame's selected window when run_window_change_functions was
+ called the last time on this frame. */
+ Lisp_Object old_selected_window;
+
/* This frame's minibuffer window.
Most frames have their own minibuffer windows,
but only the selected frame's minibuffer window
@@ -177,7 +181,7 @@ struct frame
Lisp_Object menu_bar_window;
#endif
-#if defined (HAVE_WINDOW_SYSTEM) && ! defined (USE_GTK) && ! defined (HAVE_NS)
+#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_TOOL_BAR)
/* A window used to display the tool-bar of a frame. */
Lisp_Object tool_bar_window;
@@ -186,9 +190,6 @@ struct frame
Lisp_Object current_tool_bar_string;
#endif
- /* Desired and current tool-bar items. */
- Lisp_Object tool_bar_items;
-
#ifdef USE_GTK
/* Where tool bar is, can be left, right, top or bottom.
Except with GTK, the only supported position is `top'. */
@@ -200,12 +201,14 @@ struct frame
Lisp_Object font_data;
#endif
- /* Beyond here, there should be no more Lisp_Object components. */
+ /* Desired and current tool-bar items. */
+ Lisp_Object tool_bar_items;
+ /* tool_bar_items should be the last Lisp_Object member. */
/* Cache of realized faces. */
struct face_cache *face_cache;
-#if defined (HAVE_WINDOW_SYSTEM) && ! defined (USE_GTK) && ! defined (HAVE_NS)
+#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_TOOL_BAR)
/* Tool-bar item index of the item on which a mouse button was pressed. */
int last_tool_bar_item;
#endif
@@ -253,13 +256,13 @@ struct frame
/* Set to true when current redisplay has updated frame. */
bool_bf updated_p : 1;
-#if defined (HAVE_WINDOW_SYSTEM) && ! defined (USE_GTK) && ! defined (HAVE_NS)
+#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_TOOL_BAR)
/* Set to true to minimize tool-bar height even when
auto-resize-tool-bar is set to grow-only. */
bool_bf minimize_tool_bar_window_p : 1;
#endif
-#if defined (USE_GTK) || defined (HAVE_NS)
+#ifdef HAVE_EXT_TOOL_BAR
/* True means using a tool bar that comes from the toolkit. */
bool_bf external_tool_bar : 1;
#endif
@@ -274,9 +277,8 @@ struct frame
/* True if it needs to be redisplayed. */
bool_bf redisplay : 1;
-#if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \
- || defined (HAVE_NS) || defined (USE_GTK)
- /* True means using a menu bar that comes from the X toolkit. */
+#ifdef HAVE_EXT_MENU_BAR
+ /* True means using a menu bar that comes from the toolkit. */
bool_bf external_menu_bar : 1;
#endif
@@ -321,9 +323,18 @@ struct frame
cleared. */
bool_bf explicit_name : 1;
- /* True if configuration of windows on this frame has changed since
- last call of run_window_size_change_functions. */
- bool_bf window_configuration_changed : 1;
+ /* True if at least one window on this frame changed since the last
+ call of run_window_change_functions. Changes are either "state
+ changes" (a window has been created, deleted or got assigned
+ another buffer) or "size changes" (the total or body size of a
+ window changed). run_window_change_functions exits early unless
+ either this flag is true or a window selection happened on this
+ frame. */
+ bool_bf window_change : 1;
+
+ /* True if running window state change functions has been explicitly
+ requested for this frame since last redisplay. */
+ bool_bf window_state_change : 1;
/* True if the mouse has moved on this display device
since the last time we checked. */
@@ -342,6 +353,9 @@ struct frame
ENUM_BF (output_method) output_method : 3;
#ifdef HAVE_WINDOW_SYSTEM
+ /* True if this frame is a tooltip frame. */
+ bool_bf tooltip : 1;
+
/* See FULLSCREEN_ enum on top. */
ENUM_BF (fullscreen_type) want_fullscreen : 4;
@@ -351,9 +365,7 @@ struct frame
/* Nonzero if we should actually display horizontal scroll bars on this frame. */
bool_bf horizontal_scroll_bars : 1;
-#endif /* HAVE_WINDOW_SYSTEM */
-#if defined (HAVE_WINDOW_SYSTEM)
/* True if this is an undecorated frame. */
bool_bf undecorated : 1;
@@ -403,8 +415,26 @@ struct frame
/* Non-zero if this frame's faces need to be recomputed. */
bool_bf face_change : 1;
+ /* Non-zero if this frame's image cache cannot be freed because the
+ frame is in the process of being redisplayed. */
+ bool_bf inhibit_clear_image_cache : 1;
+
/* Bitfield area ends here. */
+ /* This frame's change stamp, set the last time window change
+ functions were run for this frame. Should never be 0 because
+ that's the change stamp of a new window. A window was not on a
+ frame the last run_window_change_functions was called on it if
+ it's change stamp differs from that of its frame. */
+ int change_stamp;
+
+ /* This frame's number of windows, set the last time window change
+ functions were run for this frame. Should never be 0 even for
+ minibuffer-only frames. If no window has been added, this allows
+ to detect whether a window was deleted on this frame since the
+ last time run_window_change_functions was called on it. */
+ ptrdiff_t number_of_windows;
+
/* Number of lines (rounded up) of tool bar. REMOVE THIS */
int tool_bar_lines;
@@ -552,7 +582,7 @@ struct frame
int config_scroll_bar_lines;
/* The baud rate that was used to calculate costs for this frame. */
- int cost_calculation_baud_rate;
+ intmax_t cost_calculation_baud_rate;
/* Frame opacity
alpha[0]: alpha transparency of the active frame
@@ -577,7 +607,7 @@ struct frame
enum ns_appearance_type ns_appearance;
bool_bf ns_transparent_titlebar;
#endif
-};
+} GCALIGNED_STRUCT;
/* Most code should use these functions to set Lisp fields in struct frame. */
@@ -661,6 +691,11 @@ fset_selected_window (struct frame *f, Lisp_Object val)
f->selected_window = val;
}
INLINE void
+fset_old_selected_window (struct frame *f, Lisp_Object val)
+{
+ f->old_selected_window = val;
+}
+INLINE void
fset_title (struct frame *f, Lisp_Object val)
{
f->title = val;
@@ -677,7 +712,7 @@ fset_tool_bar_position (struct frame *f, Lisp_Object val)
f->tool_bar_position = val;
}
#endif /* USE_GTK */
-#if defined (HAVE_WINDOW_SYSTEM) && ! defined (USE_GTK) && ! defined (HAVE_NS)
+#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_TOOL_BAR)
INLINE void
fset_tool_bar_window (struct frame *f, Lisp_Object val)
{
@@ -725,7 +760,7 @@ default_pixels_per_inch_y (void)
#define FRAME_IMAGE_CACHE(F) ((F)->terminal->image_cache)
#define XFRAME(p) \
- (eassert (FRAMEP (p)), (struct frame *) XUNTAG (p, Lisp_Vectorlike))
+ (eassert (FRAMEP (p)), XUNTAG (p, Lisp_Vectorlike, struct frame))
#define XSETFRAME(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_FRAME))
/* Given a window, return its frame as a Lisp_Object. */
@@ -845,7 +880,7 @@ default_pixels_per_inch_y (void)
/* True if this frame should display a tool bar
in a way that does not use any text lines. */
-#if defined (USE_GTK) || defined (HAVE_NS)
+#ifdef HAVE_EXT_TOOL_BAR
#define FRAME_EXTERNAL_TOOL_BAR(f) (f)->external_tool_bar
#else
#define FRAME_EXTERNAL_TOOL_BAR(f) false
@@ -874,8 +909,7 @@ default_pixels_per_inch_y (void)
/* True if this frame should display a menu bar
in a way that does not use any text lines. */
-#if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \
- || defined (HAVE_NS) || defined (USE_GTK)
+#ifdef HAVE_EXT_MENU_BAR
#define FRAME_EXTERNAL_MENU_BAR(f) (f)->external_menu_bar
#else
#define FRAME_EXTERNAL_MENU_BAR(f) false
@@ -907,10 +941,13 @@ default_pixels_per_inch_y (void)
are frozen on frame F. */
#define FRAME_WINDOWS_FROZEN(f) (f)->frozen_window_starts
-/* True if the frame's window configuration has changed since last call
- of run_window_size_change_functions. */
-#define FRAME_WINDOW_CONFIGURATION_CHANGED(f) \
- (f)->window_configuration_changed
+/* True if at least one window changed on frame F since the last time
+ window change functions were run on F. */
+#define FRAME_WINDOW_CHANGE(f) (f)->window_change
+
+/* True if running window state change functions has been explicitly
+ requested for this frame since last redisplay. */
+#define FRAME_WINDOW_STATE_CHANGE(f) (f)->window_state_change
/* The minibuffer window of frame F, if it has one; otherwise nil. */
#define FRAME_MINIBUF_WINDOW(f) f->minibuffer_window
@@ -918,8 +955,10 @@ default_pixels_per_inch_y (void)
/* The root window of the window tree of frame F. */
#define FRAME_ROOT_WINDOW(f) f->root_window
-/* The currently selected window of the window tree of frame F. */
+/* The currently selected window of frame F. */
#define FRAME_SELECTED_WINDOW(f) f->selected_window
+/* The old selected window of frame F. */
+#define FRAME_OLD_SELECTED_WINDOW(f) f->old_selected_window
#define FRAME_INSERT_COST(f) (f)->insert_line_cost
#define FRAME_DELETE_COST(f) (f)->delete_line_cost
@@ -967,6 +1006,7 @@ default_pixels_per_inch_y (void)
#define FRAME_Z_GROUP_ABOVE_SUSPENDED(f) \
((f)->z_group == z_group_above_suspended)
#define FRAME_Z_GROUP_BELOW(f) ((f)->z_group == z_group_below)
+#define FRAME_TOOLTIP_P(f) ((f)->tooltip)
#ifdef NS_IMPL_COCOA
#define FRAME_NS_APPEARANCE(f) ((f)->ns_appearance)
#define FRAME_NS_TRANSPARENT_TITLEBAR(f) ((f)->ns_transparent_titlebar)
@@ -983,6 +1023,7 @@ default_pixels_per_inch_y (void)
#define FRAME_Z_GROUP_NONE(f) ((void) (f), true)
#define FRAME_Z_GROUP_ABOVE(f) ((void) (f), false)
#define FRAME_Z_GROUP_BELOW(f) ((void) (f), false)
+#define FRAME_TOOLTIP_P(f) ((void) f, false)
#endif /* HAVE_WINDOW_SYSTEM */
/* Whether horizontal scroll bars are currently enabled for frame F. */
@@ -1212,8 +1253,9 @@ SET_FRAME_VISIBLE (struct frame *f, int v)
(f)->iconified = (eassert (0 <= (i) && (i) <= 1), (i))
extern Lisp_Object selected_frame;
+extern Lisp_Object old_selected_frame;
-#if ! (defined USE_GTK || defined HAVE_NS)
+#ifndef HAVE_EXT_TOOL_BAR
extern int frame_default_tool_bar_height;
#endif
@@ -1357,17 +1399,13 @@ FRAME_BOTTOM_DIVIDER_WIDTH (struct frame *f)
canonical char width is to be used. X must be a Lisp integer or
float. Value is a C integer. */
#define FRAME_PIXEL_X_FROM_CANON_X(F, X) \
- (INTEGERP (X) \
- ? XINT (X) * FRAME_COLUMN_WIDTH (F) \
- : (int) (XFLOAT_DATA (X) * FRAME_COLUMN_WIDTH (F)))
+ ((int) (XFLOATINT (X) * FRAME_COLUMN_WIDTH (F)))
/* Convert canonical value Y to pixels. F is the frame whose
canonical character height is to be used. X must be a Lisp integer
or float. Value is a C integer. */
#define FRAME_PIXEL_Y_FROM_CANON_Y(F, Y) \
- (INTEGERP (Y) \
- ? XINT (Y) * FRAME_LINE_HEIGHT (F) \
- : (int) (XFLOAT_DATA (Y) * FRAME_LINE_HEIGHT (F)))
+ ((int) (XFLOATINT (Y) * FRAME_LINE_HEIGHT (F)))
/* Convert pixel-value X to canonical units. F is the frame whose
canonical character width is to be used. X is a C integer. Result
@@ -1376,7 +1414,7 @@ FRAME_BOTTOM_DIVIDER_WIDTH (struct frame *f)
#define FRAME_CANON_X_FROM_PIXEL_X(F, X) \
((X) % FRAME_COLUMN_WIDTH (F) != 0 \
? make_float ((double) (X) / FRAME_COLUMN_WIDTH (F)) \
- : make_number ((X) / FRAME_COLUMN_WIDTH (F)))
+ : make_fixnum ((X) / FRAME_COLUMN_WIDTH (F)))
/* Convert pixel-value Y to canonical units. F is the frame whose
canonical character height is to be used. Y is a C integer.
@@ -1385,7 +1423,7 @@ FRAME_BOTTOM_DIVIDER_WIDTH (struct frame *f)
#define FRAME_CANON_Y_FROM_PIXEL_Y(F, Y) \
((Y) % FRAME_LINE_HEIGHT (F) \
? make_float ((double) (Y) / FRAME_LINE_HEIGHT (F)) \
- : make_number ((Y) / FRAME_LINE_HEIGHT (F)))
+ : make_fixnum ((Y) / FRAME_LINE_HEIGHT (F)))
diff --git a/src/fringe.c b/src/fringe.c
index 4151386ceb8..335a6eb0468 100644
--- a/src/fringe.c
+++ b/src/fringe.c
@@ -24,11 +24,13 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "lisp.h"
#include "frame.h"
+#include "ptr-bounds.h"
#include "window.h"
#include "dispextern.h"
#include "buffer.h"
#include "blockinput.h"
#include "termhooks.h"
+#include "pdumper.h"
/* Fringe bitmaps are represented in three different ways:
@@ -487,10 +489,10 @@ lookup_fringe_bitmap (Lisp_Object bitmap)
EMACS_INT bn;
bitmap = Fget (bitmap, Qfringe);
- if (!INTEGERP (bitmap))
+ if (!FIXNUMP (bitmap))
return 0;
- bn = XINT (bitmap);
+ bn = XFIXNUM (bitmap);
if (bn > NO_FRINGE_BITMAP
&& bn < max_used_fringe_bitmap
&& (bn < MAX_STANDARD_FRINGE_BITMAPS
@@ -518,7 +520,7 @@ get_fringe_bitmap_name (int bn)
return Qnil;
bitmaps = Vfringe_bitmaps;
- num = make_number (bn);
+ num = make_fixnum (bn);
while (CONSP (bitmaps))
{
@@ -586,8 +588,8 @@ draw_fringe_bitmap_1 (struct window *w, struct glyph_row *row, int left_p, int o
if (face_id == DEFAULT_FACE_ID)
{
Lisp_Object face = fringe_faces[which];
- face_id = NILP (face) ? lookup_named_face (f, Qfringe, false)
- : lookup_derived_face (f, face, FRINGE_FACE_ID, 0);
+ face_id = NILP (face) ? lookup_named_face (w, f, Qfringe, false)
+ : lookup_derived_face (w, f, face, FRINGE_FACE_ID, 0);
if (face_id < 0)
face_id = FRINGE_FACE_ID;
}
@@ -718,7 +720,7 @@ static int
get_logical_fringe_bitmap (struct window *w, Lisp_Object bitmap, int right_p, int partial_p)
{
Lisp_Object cmap, bm1 = Qnil, bm2 = Qnil, bm;
- EMACS_INT ln1 = 0, ln2 = 0;
+ ptrdiff_t ln1 = 0, ln2 = 0;
int ix1 = right_p;
int ix2 = ix1 + (partial_p ? 2 : 0);
@@ -742,12 +744,12 @@ get_logical_fringe_bitmap (struct window *w, Lisp_Object bitmap, int right_p, in
return NO_FRINGE_BITMAP;
if (CONSP (bm1))
{
- ln1 = XINT (Flength (bm1));
+ ln1 = list_length (bm1);
if (partial_p)
{
if (ln1 > ix2)
{
- bm = Fnth (make_number (ix2), bm1);
+ bm = Fnth (make_fixnum (ix2), bm1);
if (!EQ (bm, Qt))
goto found;
}
@@ -756,7 +758,7 @@ get_logical_fringe_bitmap (struct window *w, Lisp_Object bitmap, int right_p, in
{
if (ln1 > ix1)
{
- bm = Fnth (make_number (ix1), bm1);
+ bm = Fnth (make_fixnum (ix1), bm1);
if (!EQ (bm, Qt))
goto found;
}
@@ -777,12 +779,12 @@ get_logical_fringe_bitmap (struct window *w, Lisp_Object bitmap, int right_p, in
{
if (CONSP (bm2))
{
- ln2 = XINT (Flength (bm2));
+ ln2 = list_length (bm2);
if (partial_p)
{
if (ln2 > ix2)
{
- bm = Fnth (make_number (ix2), bm2);
+ bm = Fnth (make_fixnum (ix2), bm2);
if (!EQ (bm, Qt))
goto found;
}
@@ -794,14 +796,14 @@ get_logical_fringe_bitmap (struct window *w, Lisp_Object bitmap, int right_p, in
if (ln1 > ix1)
{
- bm = Fnth (make_number (ix1), bm1);
+ bm = Fnth (make_fixnum (ix1), bm1);
if (!EQ (bm, Qt))
goto found;
}
if (ln2 > ix1)
{
- bm = Fnth (make_number (ix1), bm2);
+ bm = Fnth (make_fixnum (ix1), bm2);
if (!EQ (bm, Qt))
goto found;
return NO_FRINGE_BITMAP;
@@ -908,6 +910,12 @@ draw_window_fringes (struct window *w, bool no_fringe_p)
if (w->pseudo_window_p)
return updated_p;
+ /* We must switch to the window's buffer to use its local value of
+ the fringe face, in case it's been remapped in face-remapping-alist. */
+ Lisp_Object window_buffer = w->contents;
+ struct buffer *oldbuf = current_buffer;
+ set_buffer_internal_1 (XBUFFER (window_buffer));
+
/* Must draw line if no fringe */
if (no_fringe_p
&& (WINDOW_LEFT_FRINGE_WIDTH (w) == 0
@@ -925,6 +933,8 @@ draw_window_fringes (struct window *w, bool no_fringe_p)
updated_p = 1;
}
+ set_buffer_internal_1 (oldbuf);
+
return updated_p;
}
@@ -1508,8 +1518,8 @@ If BITMAP already exists, the existing definition is replaced. */)
fb.height = h;
else
{
- CHECK_NUMBER (height);
- fb.height = max (0, min (XINT (height), 255));
+ CHECK_FIXNUM (height);
+ fb.height = max (0, min (XFIXNUM (height), 255));
if (fb.height > h)
{
fill1 = (fb.height - h) / 2;
@@ -1521,8 +1531,8 @@ If BITMAP already exists, the existing definition is replaced. */)
fb.width = 8;
else
{
- CHECK_NUMBER (width);
- fb.width = max (0, min (XINT (width), 255));
+ CHECK_FIXNUM (width);
+ fb.width = max (0, min (XFIXNUM (width), 255));
}
fb.period = 0;
@@ -1585,13 +1595,15 @@ If BITMAP already exists, the existing definition is replaced. */)
}
Vfringe_bitmaps = Fcons (bitmap, Vfringe_bitmaps);
- Fput (bitmap, Qfringe, make_number (n));
+ Fput (bitmap, Qfringe, make_fixnum (n));
}
fb.dynamic = true;
xfb = xmalloc (sizeof fb + fb.height * BYTES_PER_BITMAP_ROW);
- fb.bits = b = (unsigned short *) (xfb + 1);
+ fb.bits = b = ((unsigned short *)
+ ptr_bounds_clip (xfb + 1, fb.height * BYTES_PER_BITMAP_ROW));
+ xfb = ptr_bounds_clip (xfb, sizeof *xfb);
memset (b, 0, fb.height);
j = 0;
@@ -1601,8 +1613,8 @@ If BITMAP already exists, the existing definition is replaced. */)
b[j++] = 0;
for (i = 0; i < h && j < fb.height; i++)
{
- Lisp_Object elt = Faref (bits, make_number (i));
- b[j++] = NUMBERP (elt) ? XINT (elt) : 0;
+ Lisp_Object elt = Faref (bits, make_fixnum (i));
+ b[j++] = FIXNUMP (elt) ? XFIXNUM (elt) : 0;
}
for (i = 0; i < fill2 && j < fb.height; i++)
b[j++] = 0;
@@ -1630,20 +1642,10 @@ If FACE is nil, reset face to default fringe face. */)
if (!n)
error ("Undefined fringe bitmap");
- /* The purpose of the following code is to signal an error if FACE
- is not a face. This is for the caller's convenience only; the
- redisplay code should be able to fail gracefully. Skip the check
- if FRINGE_FACE_ID is unrealized (as in batch mode and during
- daemon startup). */
- if (!NILP (face))
- {
- struct frame *f = SELECTED_FRAME ();
-
- if (FACE_FROM_ID_OR_NULL (f, FRINGE_FACE_ID)
- && lookup_derived_face (f, face, FRINGE_FACE_ID, 1) < 0)
- error ("No such face");
- }
-
+ /* We used to check, as a convenience to callers, for basic face
+ validity here, but since validity can depend on the specific
+ _window_ in which this buffer is being displayed, defer the check
+ to redisplay, which can cope with bad face specifications. */
fringe_faces[n] = face;
return Qnil;
}
@@ -1668,10 +1670,10 @@ Return nil if POS is not visible in WINDOW. */)
if (!NILP (pos))
{
- CHECK_NUMBER_COERCE_MARKER (pos);
- if (! (BEGV <= XINT (pos) && XINT (pos) <= ZV))
+ CHECK_FIXNUM_COERCE_MARKER (pos);
+ if (! (BEGV <= XFIXNUM (pos) && XFIXNUM (pos) <= ZV))
args_out_of_range (window, pos);
- textpos = XINT (pos);
+ textpos = XFIXNUM (pos);
}
else if (w == XWINDOW (selected_window))
textpos = PT;
@@ -1738,12 +1740,18 @@ mark_fringe_data (void)
/* Initialize this module when Emacs starts. */
+static void init_fringe_once_for_pdumper (void);
+
void
init_fringe_once (void)
{
- int bt;
+ pdumper_do_now_and_after_load (init_fringe_once_for_pdumper);
+}
- for (bt = NO_FRINGE_BITMAP + 1; bt < MAX_STANDARD_FRINGE_BITMAPS; bt++)
+static void
+init_fringe_once_for_pdumper (void)
+{
+ for (int bt = NO_FRINGE_BITMAP + 1; bt < MAX_STANDARD_FRINGE_BITMAPS; bt++)
init_fringe_bitmap (bt, &standard_bitmaps[bt], 1);
}
diff --git a/src/ftcrfont.c b/src/ftcrfont.c
index 62f44573a86..3a98e78d63e 100644
--- a/src/ftcrfont.c
+++ b/src/ftcrfont.c
@@ -26,34 +26,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "blockinput.h"
#include "font.h"
#include "ftfont.h"
-
-/* FTCR font driver. */
-
-/* The actual structure for FTCR font. A pointer to this structure
- can be cast to struct font *. */
-
-struct ftcrfont_info
-{
- struct font font;
- /* The following members up to and including 'matrix' must be here
- in this order to be compatible with struct ftfont_info (in
- ftfont.c). */
-#ifdef HAVE_LIBOTF
- bool maybe_otf; /* Flag to tell if this may be OTF or not. */
- OTF *otf;
-#endif /* HAVE_LIBOTF */
- FT_Size ft_size;
- int index;
- FT_Matrix matrix;
-
- cairo_font_face_t *cr_font_face;
- /* To prevent cairo from cluttering the activated FT_Size maintained
- in ftfont.c, we activate this special FT_Size before drawing. */
- FT_Size ft_size_draw;
- /* Font metrics cache. */
- struct font_metrics **metrics;
- short metrics_nrows;
-};
+#include "pdumper.h"
#define METRICS_NCOLS_PER_ROW (128)
@@ -71,7 +44,7 @@ ftcrfont_glyph_extents (struct font *font,
unsigned glyph,
struct font_metrics *metrics)
{
- struct ftcrfont_info *ftcrfont_info = (struct ftcrfont_info *) font;
+ struct font_info *ftcrfont_info = (struct font_info *) font;
int row, col;
struct font_metrics *cache;
@@ -133,22 +106,22 @@ ftcrfont_open (struct frame *f, Lisp_Object entity, int pixel_size)
{
Lisp_Object font_object;
struct font *font;
- struct ftcrfont_info *ftcrfont_info;
+ struct font_info *ftcrfont_info;
FT_Face ft_face;
FT_UInt size;
block_input ();
- size = XINT (AREF (entity, FONT_SIZE_INDEX));
+ size = XFIXNUM (AREF (entity, FONT_SIZE_INDEX));
if (size == 0)
size = pixel_size;
- font_object = font_build_object (VECSIZE (struct ftcrfont_info),
+ font_object = font_build_object (VECSIZE (struct font_info),
Qftcr, entity, size);
font_object = ftfont_open2 (f, entity, pixel_size, font_object);
if (NILP (font_object)) return Qnil;
font = XFONT_OBJECT (font_object);
font->driver = &ftcrfont_driver;
- ftcrfont_info = (struct ftcrfont_info *) font;
+ ftcrfont_info = (struct font_info *) font;
ft_face = ftcrfont_info->ft_size->face;
FT_New_Size (ft_face, &ftcrfont_info->ft_size_draw);
FT_Activate_Size (ftcrfont_info->ft_size_draw);
@@ -168,7 +141,7 @@ ftcrfont_close (struct font *font)
if (font_data_structures_may_be_ill_formed ())
return;
- struct ftcrfont_info *ftcrfont_info = (struct ftcrfont_info *) font;
+ struct font_info *ftcrfont_info = (struct font_info *) font;
int i;
block_input ();
@@ -224,7 +197,7 @@ ftcrfont_draw (struct glyph_string *s,
{
struct frame *f = s->f;
struct face *face = s->face;
- struct ftcrfont_info *ftcrfont_info = (struct ftcrfont_info *) s->font;
+ struct font_info *ftcrfont_info = (struct font_info *) s->font;
cairo_t *cr;
cairo_glyph_t *glyphs;
cairo_surface_t *surface;
@@ -282,6 +255,8 @@ ftcrfont_draw (struct glyph_string *s,
+static void syms_of_ftcrfont_for_pdumper (void);
+
struct font_driver const ftcrfont_driver =
{
.type = LISPSYM_INITIALLY (Qftcr),
@@ -313,9 +288,12 @@ struct font_driver const ftcrfont_driver =
void
syms_of_ftcrfont (void)
{
- if (ftfont_info_size != offsetof (struct ftcrfont_info, cr_font_face))
- abort ();
-
DEFSYM (Qftcr, "ftcr");
+ pdumper_do_now_and_after_load (syms_of_ftcrfont_for_pdumper);
+}
+
+static void
+syms_of_ftcrfont_for_pdumper (void)
+{
register_font_driver (&ftcrfont_driver, NULL);
}
diff --git a/src/ftfont.c b/src/ftfont.c
index 823fb2095ce..3e820f583ff 100644
--- a/src/ftfont.c
+++ b/src/ftfont.c
@@ -24,6 +24,17 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <fontconfig/fontconfig.h>
#include <fontconfig/fcfreetype.h>
+/* These two blocks are here because this file is built when using XFT
+ and when using Cairo, so struct font_info in ftfont.h needs access
+ to the appropriate types. */
+#ifdef HAVE_XFT
+# include <X11/Xlib.h>
+# include <X11/Xft/Xft.h>
+#endif
+#ifdef USE_CAIRO
+# include <cairo-ft.h>
+#endif
+
#include <c-strcase.h>
#include "lisp.h"
@@ -34,6 +45,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "composite.h"
#include "font.h"
#include "ftfont.h"
+#include "pdumper.h"
static struct font_driver const ftfont_driver;
@@ -49,26 +61,6 @@ static Lisp_Object freetype_font_cache;
/* Cache for FT_Face and FcCharSet. */
static Lisp_Object ft_face_cache;
-/* The actual structure for FreeType font that can be cast to struct
- font. */
-
-struct ftfont_info
-{
- struct font font;
-#ifdef HAVE_LIBOTF
- /* The following members up to and including 'matrix' must be here in
- this order to be compatible with struct xftfont_info (in
- xftfont.c). */
- bool maybe_otf; /* Flag to tell if this may be OTF or not. */
- OTF *otf;
-#endif /* HAVE_LIBOTF */
- FT_Size ft_size;
- int index;
- FT_Matrix matrix;
-};
-
-size_t ftfont_info_size = sizeof (struct ftfont_info);
-
enum ftfont_cache_for
{
FTFONT_CACHE_FOR_FACE,
@@ -197,7 +189,7 @@ ftfont_pattern_entity (FcPattern *p, Lisp_Object extra)
return Qnil;
file = (char *) str;
- key = Fcons (build_unibyte_string (file), make_number (idx));
+ key = Fcons (build_unibyte_string (file), make_fixnum (idx));
cache = ftfont_lookup_cache (key, FTFONT_CACHE_FOR_ENTITY);
entity = XCAR (cache);
if (! NILP (entity))
@@ -233,35 +225,35 @@ ftfont_pattern_entity (FcPattern *p, Lisp_Object extra)
{
if (numeric >= FC_WEIGHT_REGULAR && numeric < FC_WEIGHT_MEDIUM)
numeric = FC_WEIGHT_MEDIUM;
- FONT_SET_STYLE (entity, FONT_WEIGHT_INDEX, make_number (numeric));
+ FONT_SET_STYLE (entity, FONT_WEIGHT_INDEX, make_fixnum (numeric));
}
if (FcPatternGetInteger (p, FC_SLANT, 0, &numeric) == FcResultMatch)
{
numeric += 100;
- FONT_SET_STYLE (entity, FONT_SLANT_INDEX, make_number (numeric));
+ FONT_SET_STYLE (entity, FONT_SLANT_INDEX, make_fixnum (numeric));
}
if (FcPatternGetInteger (p, FC_WIDTH, 0, &numeric) == FcResultMatch)
{
- FONT_SET_STYLE (entity, FONT_WIDTH_INDEX, make_number (numeric));
+ FONT_SET_STYLE (entity, FONT_WIDTH_INDEX, make_fixnum (numeric));
}
if (FcPatternGetDouble (p, FC_PIXEL_SIZE, 0, &dbl) == FcResultMatch)
{
- ASET (entity, FONT_SIZE_INDEX, make_number (dbl));
+ ASET (entity, FONT_SIZE_INDEX, make_fixnum (dbl));
}
else
- ASET (entity, FONT_SIZE_INDEX, make_number (0));
+ ASET (entity, FONT_SIZE_INDEX, make_fixnum (0));
if (FcPatternGetInteger (p, FC_SPACING, 0, &numeric) == FcResultMatch)
- ASET (entity, FONT_SPACING_INDEX, make_number (numeric));
+ ASET (entity, FONT_SPACING_INDEX, make_fixnum (numeric));
if (FcPatternGetDouble (p, FC_DPI, 0, &dbl) == FcResultMatch)
{
int dpi = dbl;
- ASET (entity, FONT_DPI_INDEX, make_number (dpi));
+ ASET (entity, FONT_DPI_INDEX, make_fixnum (dpi));
}
if (FcPatternGetBool (p, FC_SCALABLE, 0, &b) == FcResultMatch
&& b == FcTrue)
{
- ASET (entity, FONT_SIZE_INDEX, make_number (0));
- ASET (entity, FONT_AVGWIDTH_INDEX, make_number (0));
+ ASET (entity, FONT_SIZE_INDEX, make_fixnum (0));
+ ASET (entity, FONT_AVGWIDTH_INDEX, make_fixnum (0));
}
else
{
@@ -277,7 +269,7 @@ ftfont_pattern_entity (FcPattern *p, Lisp_Object extra)
if (FT_Get_BDF_Property (ft_face, "AVERAGE_WIDTH", &rec) == 0
&& rec.type == BDF_PROPERTY_TYPE_INTEGER)
- ASET (entity, FONT_AVGWIDTH_INDEX, make_number (rec.u.integer));
+ ASET (entity, FONT_AVGWIDTH_INDEX, make_fixnum (rec.u.integer));
FT_Done_Face (ft_face);
}
}
@@ -346,6 +338,7 @@ struct ftfont_cache_data
{
FT_Face ft_face;
FcCharSet *fc_charset;
+ intptr_t face_refcount;
};
static Lisp_Object
@@ -372,17 +365,15 @@ ftfont_lookup_cache (Lisp_Object key, enum ftfont_cache_for cache_for)
{
if (NILP (ft_face_cache))
ft_face_cache = CALLN (Fmake_hash_table, QCtest, Qequal);
- cache_data = xmalloc (sizeof *cache_data);
- cache_data->ft_face = NULL;
- cache_data->fc_charset = NULL;
- val = make_save_ptr_int (cache_data, 0);
+ cache_data = xzalloc (sizeof *cache_data);
+ val = make_mint_ptr (cache_data);
cache = Fcons (Qnil, val);
Fputhash (key, cache, ft_face_cache);
}
else
{
val = XCDR (cache);
- cache_data = XSAVE_POINTER (val, 0);
+ cache_data = xmint_pointer (val);
}
if (cache_for == FTFONT_CACHE_FOR_ENTITY)
@@ -392,7 +383,7 @@ ftfont_lookup_cache (Lisp_Object key, enum ftfont_cache_for cache_for)
? ! cache_data->ft_face : ! cache_data->fc_charset)
{
char *filename = SSDATA (XCAR (key));
- int idx = XINT (XCDR (key));
+ int idx = XFIXNUM (XCDR (key));
if (cache_for == FTFONT_CACHE_FOR_FACE)
{
@@ -448,13 +439,13 @@ ftfont_get_fc_charset (Lisp_Object entity)
cache = ftfont_lookup_cache (entity, FTFONT_CACHE_FOR_CHARSET);
val = XCDR (cache);
- cache_data = XSAVE_POINTER (val, 0);
+ cache_data = xmint_pointer (val);
return cache_data->fc_charset;
}
#ifdef HAVE_LIBOTF
static OTF *
-ftfont_get_otf (struct ftfont_info *ftfont_info)
+ftfont_get_otf (struct font_info *ftfont_info)
{
OTF *otf;
@@ -595,16 +586,14 @@ ftfont_get_open_type_spec (Lisp_Object otf_spec)
spec->nfeatures[0] = spec->nfeatures[1] = 0;
for (i = 0; i < 2 && ! NILP (otf_spec); i++, otf_spec = XCDR (otf_spec))
{
- Lisp_Object len;
-
val = XCAR (otf_spec);
if (NILP (val))
continue;
- len = Flength (val);
+ ptrdiff_t len = list_length (val);
spec->features[i] =
- (min (PTRDIFF_MAX, SIZE_MAX) / sizeof (int) < XINT (len)
+ (min (PTRDIFF_MAX, SIZE_MAX) / sizeof (int) < len
? 0
- : malloc (XINT (len) * sizeof *spec->features[i]));
+ : malloc (len * sizeof *spec->features[i]));
if (! spec->features[i])
{
if (i > 0 && spec->features[0])
@@ -648,10 +637,10 @@ ftfont_spec_pattern (Lisp_Object spec, char *otlayout, struct OpenTypeSpec **ots
/* Fontconfig doesn't support reverse-italic/oblique. */
return NULL;
- if (INTEGERP (AREF (spec, FONT_DPI_INDEX)))
- dpi = XINT (AREF (spec, FONT_DPI_INDEX));
- if (INTEGERP (AREF (spec, FONT_AVGWIDTH_INDEX))
- && XINT (AREF (spec, FONT_AVGWIDTH_INDEX)) == 0)
+ if (FIXNUMP (AREF (spec, FONT_DPI_INDEX)))
+ dpi = XFIXNUM (AREF (spec, FONT_DPI_INDEX));
+ if (FIXNUMP (AREF (spec, FONT_AVGWIDTH_INDEX))
+ && XFIXNUM (AREF (spec, FONT_AVGWIDTH_INDEX)) == 0)
scalable = 1;
registry = AREF (spec, FONT_REGISTRY_INDEX);
@@ -688,8 +677,8 @@ ftfont_spec_pattern (Lisp_Object spec, char *otlayout, struct OpenTypeSpec **ots
key = XCAR (XCAR (extra)), val = XCDR (XCAR (extra));
if (EQ (key, QCdpi))
{
- if (INTEGERP (val))
- dpi = XINT (val);
+ if (FIXNUMP (val))
+ dpi = XFIXNUM (val);
}
else if (EQ (key, QClang))
{
@@ -737,7 +726,7 @@ ftfont_spec_pattern (Lisp_Object spec, char *otlayout, struct OpenTypeSpec **ots
goto err;
for (chars = XCDR (chars); CONSP (chars); chars = XCDR (chars))
if (CHARACTERP (XCAR (chars))
- && ! FcCharSetAddChar (charset, XFASTINT (XCAR (chars))))
+ && ! FcCharSetAddChar (charset, XFIXNAT (XCAR (chars))))
goto err;
}
}
@@ -834,8 +823,8 @@ ftfont_list (struct frame *f, Lisp_Object spec)
}
val = Qnil;
}
- if (INTEGERP (AREF (spec, FONT_SPACING_INDEX)))
- spacing = XINT (AREF (spec, FONT_SPACING_INDEX));
+ if (FIXNUMP (AREF (spec, FONT_SPACING_INDEX)))
+ spacing = XFIXNUM (AREF (spec, FONT_SPACING_INDEX));
family = AREF (spec, FONT_FAMILY_INDEX);
if (! NILP (family))
{
@@ -957,8 +946,8 @@ ftfont_list (struct frame *f, Lisp_Object spec)
!= FcResultMatch)
continue;
for (j = 0; j < ASIZE (chars); j++)
- if (TYPE_RANGED_INTEGERP (FcChar32, AREF (chars, j))
- && FcCharSetHasChar (charset, XFASTINT (AREF (chars, j))))
+ if (TYPE_RANGED_FIXNUMP (FcChar32, AREF (chars, j))
+ && FcCharSetHasChar (charset, XFIXNAT (AREF (chars, j))))
break;
if (j == ASIZE (chars))
continue;
@@ -1018,12 +1007,12 @@ ftfont_match (struct frame *f, Lisp_Object spec)
if (! pattern)
return Qnil;
- if (INTEGERP (AREF (spec, FONT_SIZE_INDEX)))
+ if (FIXNUMP (AREF (spec, FONT_SIZE_INDEX)))
{
FcValue value;
value.type = FcTypeDouble;
- value.u.d = XINT (AREF (spec, FONT_SIZE_INDEX));
+ value.u.d = XFIXNUM (AREF (spec, FONT_SIZE_INDEX));
FcPatternAdd (pattern, FC_PIXEL_SIZE, value, FcFalse);
}
if (FcConfigSubstitute (NULL, pattern, FcMatchPattern) == FcTrue)
@@ -1097,7 +1086,7 @@ ftfont_open2 (struct frame *f,
int pixel_size,
Lisp_Object font_object)
{
- struct ftfont_info *ftfont_info;
+ struct font_info *ftfont_info;
struct font *font;
struct ftfont_cache_data *cache_data;
FT_Face ft_face;
@@ -1119,9 +1108,9 @@ ftfont_open2 (struct frame *f,
filename = XCAR (val);
idx = XCDR (val);
val = XCDR (cache);
- cache_data = XSAVE_POINTER (XCDR (cache), 0);
+ cache_data = xmint_pointer (XCDR (cache));
ft_face = cache_data->ft_face;
- if (XSAVE_INTEGER (val, 1) > 0)
+ if (cache_data->face_refcount > 0)
{
/* FT_Face in this cache is already used by the different size. */
if (FT_New_Size (ft_face, &ft_size) != 0)
@@ -1132,22 +1121,25 @@ ftfont_open2 (struct frame *f,
return Qnil;
}
}
- set_save_integer (val, 1, XSAVE_INTEGER (val, 1) + 1);
- size = XINT (AREF (entity, FONT_SIZE_INDEX));
+ size = XFIXNUM (AREF (entity, FONT_SIZE_INDEX));
if (size == 0)
size = pixel_size;
if (FT_Set_Pixel_Sizes (ft_face, size, size) != 0)
{
- if (XSAVE_INTEGER (val, 1) == 0)
- FT_Done_Face (ft_face);
+ if (cache_data->face_refcount == 0)
+ {
+ FT_Done_Face (ft_face);
+ cache_data->ft_face = NULL;
+ }
return Qnil;
}
+ cache_data->face_refcount++;
ASET (font_object, FONT_FILE_INDEX, filename);
font = XFONT_OBJECT (font_object);
- ftfont_info = (struct ftfont_info *) font;
+ ftfont_info = (struct font_info *) font;
ftfont_info->ft_size = ft_face->size;
- ftfont_info->index = XINT (idx);
+ ftfont_info->index = XFIXNUM (idx);
#ifdef HAVE_LIBOTF
ftfont_info->maybe_otf = (ft_face->face_flags & FT_FACE_FLAG_SFNT) != 0;
ftfont_info->otf = NULL;
@@ -1159,8 +1151,8 @@ ftfont_open2 (struct frame *f,
font->encoding_charset = font->repertory_charset = -1;
upEM = ft_face->units_per_EM;
- scalable = (INTEGERP (AREF (entity, FONT_AVGWIDTH_INDEX))
- && XINT (AREF (entity, FONT_AVGWIDTH_INDEX)) == 0);
+ scalable = (FIXNUMP (AREF (entity, FONT_AVGWIDTH_INDEX))
+ && XFIXNUM (AREF (entity, FONT_AVGWIDTH_INDEX)) == 0);
if (scalable)
{
font->ascent = ft_face->ascender * size / upEM + 0.5;
@@ -1173,8 +1165,8 @@ ftfont_open2 (struct frame *f,
font->descent = - ft_face->size->metrics.descender >> 6;
font->height = ft_face->size->metrics.height >> 6;
}
- if (INTEGERP (AREF (entity, FONT_SPACING_INDEX)))
- spacing = XINT (AREF (entity, FONT_SPACING_INDEX));
+ if (FIXNUMP (AREF (entity, FONT_SPACING_INDEX)))
+ spacing = XFIXNUM (AREF (entity, FONT_SPACING_INDEX));
else
spacing = FC_PROPORTIONAL;
if (spacing != FC_PROPORTIONAL
@@ -1232,10 +1224,10 @@ ftfont_open (struct frame *f, Lisp_Object entity, int pixel_size)
{
Lisp_Object font_object;
FT_UInt size;
- size = XINT (AREF (entity, FONT_SIZE_INDEX));
+ size = XFIXNUM (AREF (entity, FONT_SIZE_INDEX));
if (size == 0)
size = pixel_size;
- font_object = font_build_object (VECSIZE (struct ftfont_info),
+ font_object = font_build_object (VECSIZE (struct font_info),
Qfreetype, entity, size);
return ftfont_open2 (f, entity, pixel_size, font_object);
}
@@ -1246,18 +1238,17 @@ ftfont_close (struct font *font)
if (font_data_structures_may_be_ill_formed ())
return;
- struct ftfont_info *ftfont_info = (struct ftfont_info *) font;
+ struct font_info *ftfont_info = (struct font_info *) font;
Lisp_Object val, cache;
- val = Fcons (font->props[FONT_FILE_INDEX], make_number (ftfont_info->index));
+ val = Fcons (font->props[FONT_FILE_INDEX], make_fixnum (ftfont_info->index));
cache = ftfont_lookup_cache (val, FTFONT_CACHE_FOR_FACE);
eassert (CONSP (cache));
val = XCDR (cache);
- set_save_integer (val, 1, XSAVE_INTEGER (val, 1) - 1);
- if (XSAVE_INTEGER (val, 1) == 0)
+ struct ftfont_cache_data *cache_data = xmint_pointer (val);
+ cache_data->face_refcount--;
+ if (cache_data->face_refcount == 0)
{
- struct ftfont_cache_data *cache_data = XSAVE_POINTER (val, 0);
-
FT_Done_Face (cache_data->ft_face);
#ifdef HAVE_LIBOTF
if (ftfont_info->otf)
@@ -1291,9 +1282,9 @@ ftfont_has_char (Lisp_Object font, int c)
}
else
{
- struct ftfont_info *ftfont_info;
+ struct font_info *ftfont_info;
- ftfont_info = (struct ftfont_info *) XFONT_OBJECT (font);
+ ftfont_info = (struct font_info *) XFONT_OBJECT (font);
return (FT_Get_Char_Index (ftfont_info->ft_size->face, (FT_ULong) c)
!= 0);
}
@@ -1302,7 +1293,7 @@ ftfont_has_char (Lisp_Object font, int c)
unsigned
ftfont_encode_char (struct font *font, int c)
{
- struct ftfont_info *ftfont_info = (struct ftfont_info *) font;
+ struct font_info *ftfont_info = (struct font_info *) font;
FT_Face ft_face = ftfont_info->ft_size->face;
FT_ULong charcode = c;
FT_UInt code = FT_Get_Char_Index (ft_face, charcode);
@@ -1314,7 +1305,7 @@ void
ftfont_text_extents (struct font *font, unsigned int *code,
int nglyphs, struct font_metrics *metrics)
{
- struct ftfont_info *ftfont_info = (struct ftfont_info *) font;
+ struct font_info *ftfont_info = (struct font_info *) font;
FT_Face ft_face = ftfont_info->ft_size->face;
int i, width = 0;
bool first;
@@ -1357,7 +1348,7 @@ ftfont_text_extents (struct font *font, unsigned int *code,
int
ftfont_get_bitmap (struct font *font, unsigned int code, struct font_bitmap *bitmap, int bits_per_pixel)
{
- struct ftfont_info *ftfont_info = (struct ftfont_info *) font;
+ struct font_info *ftfont_info = (struct font_info *) font;
FT_Face ft_face = ftfont_info->ft_size->face;
FT_Int32 load_flags = FT_LOAD_RENDER;
@@ -1401,7 +1392,7 @@ int
ftfont_anchor_point (struct font *font, unsigned int code, int idx,
int *x, int *y)
{
- struct ftfont_info *ftfont_info = (struct ftfont_info *) font;
+ struct font_info *ftfont_info = (struct font_info *) font;
FT_Face ft_face = ftfont_info->ft_size->face;
if (ftfont_info->ft_size != ft_face->size)
@@ -1466,7 +1457,7 @@ ftfont_otf_features (OTF_GSUB_GPOS *gsub_gpos)
Lisp_Object
ftfont_otf_capability (struct font *font)
{
- struct ftfont_info *ftfont_info = (struct ftfont_info *) font;
+ struct font_info *ftfont_info = (struct font_info *) font;
OTF *otf = ftfont_get_otf (ftfont_info);
Lisp_Object gsub_gpos;
@@ -2534,7 +2525,7 @@ ftfont_shape_by_flt (Lisp_Object lgstring, struct font *font,
flt = mflt_find (LGLYPH_CHAR (LGSTRING_GLYPH (lgstring, 0)),
&flt_font_ft.flt_font);
if (! flt)
- return make_number (0);
+ return make_fixnum (0);
}
MFLTGlyphFT *glyphs = (MFLTGlyphFT *) gstring.glyphs;
@@ -2603,20 +2594,20 @@ ftfont_shape_by_flt (Lisp_Object lgstring, struct font *font,
{
Lisp_Object vec = make_uninit_vector (3);
- ASET (vec, 0, make_number (g->g.xoff >> 6));
- ASET (vec, 1, make_number (g->g.yoff >> 6));
- ASET (vec, 2, make_number (g->g.xadv >> 6));
+ ASET (vec, 0, make_fixnum (g->g.xoff >> 6));
+ ASET (vec, 1, make_fixnum (g->g.yoff >> 6));
+ ASET (vec, 2, make_fixnum (g->g.xadv >> 6));
LGLYPH_SET_ADJUSTMENT (lglyph, vec);
}
}
- return make_number (i);
+ return make_fixnum (i);
}
Lisp_Object
ftfont_shape (Lisp_Object lgstring)
{
struct font *font = CHECK_FONT_GET_OBJECT (LGSTRING_FONT (lgstring));
- struct ftfont_info *ftfont_info = (struct ftfont_info *) font;
+ struct font_info *ftfont_info = (struct font_info *) font;
OTF *otf = ftfont_get_otf (ftfont_info);
return ftfont_shape_by_flt (lgstring, font, ftfont_info->ft_size->face, otf,
@@ -2630,7 +2621,7 @@ ftfont_shape (Lisp_Object lgstring)
int
ftfont_variation_glyphs (struct font *font, int c, unsigned variations[256])
{
- struct ftfont_info *ftfont_info = (struct ftfont_info *) font;
+ struct font_info *ftfont_info = (struct font_info *) font;
OTF *otf = ftfont_get_otf (ftfont_info);
if (! otf)
@@ -2702,6 +2693,8 @@ ftfont_combining_capability (struct font *font)
#endif
}
+static void syms_of_ftfont_for_pdumper (void);
+
static struct font_driver const ftfont_driver =
{
/* We can't draw a text without device dependent functions. */
@@ -2753,5 +2746,12 @@ syms_of_ftfont (void)
staticpro (&ft_face_cache);
ft_face_cache = Qnil;
+ pdumper_do_now_and_after_load (syms_of_ftfont_for_pdumper);
+}
+
+static void
+syms_of_ftfont_for_pdumper (void)
+{
+ PDUMPER_RESET_LV (ft_face_cache, Qnil);
register_font_driver (&ftfont_driver, NULL);
}
diff --git a/src/ftfont.h b/src/ftfont.h
index 4201b2c2d67..b6b0c5ba47b 100644
--- a/src/ftfont.h
+++ b/src/ftfont.h
@@ -26,13 +26,13 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include FT_FREETYPE_H
#include FT_SIZES_H
#ifdef FT_BDF_H
-#include FT_BDF_H
+# include FT_BDF_H
#endif
#ifdef HAVE_LIBOTF
-#include <otf.h>
+# include <otf.h>
#ifdef HAVE_M17N_FLT
-#include <m17n-flt.h>
+# include <m17n-flt.h>
#endif /* HAVE_M17N_FLT */
#endif /* HAVE_LIBOTF */
@@ -41,6 +41,35 @@ extern Lisp_Object ftfont_open2 (struct frame *f,
Lisp_Object entity,
int pixel_size,
Lisp_Object font_object);
-extern size_t ftfont_info_size;
+
+/* This struct is shared by the XFT, Freetype, and Cairo font
+ backends. Members up to and including 'matrix' are common, the
+ rest depend on which backend is in use. */
+struct font_info
+{
+ struct font font;
+#ifdef HAVE_LIBOTF
+ bool maybe_otf; /* Flag to tell if this may be OTF or not. */
+ OTF *otf;
+#endif /* HAVE_LIBOTF */
+ FT_Size ft_size;
+ int index;
+ FT_Matrix matrix;
+
+#ifdef USE_CAIRO
+ cairo_font_face_t *cr_font_face;
+ /* To prevent cairo from cluttering the activated FT_Size maintained
+ in ftfont.c, we activate this special FT_Size before drawing. */
+ FT_Size ft_size_draw;
+ /* Font metrics cache. */
+ struct font_metrics **metrics;
+ short metrics_nrows;
+#else
+ /* These are used by the XFT backend. */
+ Display *display;
+ XftFont *xftfont;
+ unsigned x_display_id;
+#endif
+};
#endif /* EMACS_FTFONT_H */
diff --git a/src/ftxfont.c b/src/ftxfont.c
index 726e0a845b1..f9a69c35151 100644
--- a/src/ftxfont.c
+++ b/src/ftxfont.c
@@ -28,6 +28,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "frame.h"
#include "blockinput.h"
#include "font.h"
+#include "pdumper.h"
/* FTX font driver. */
@@ -339,6 +340,8 @@ ftxfont_end_for_frame (struct frame *f)
+static void syms_of_ftxfont_for_pdumper (void);
+
struct font_driver const ftxfont_driver =
{
/* We can't draw a text without device dependent functions. */
@@ -373,5 +376,11 @@ void
syms_of_ftxfont (void)
{
DEFSYM (Qftx, "ftx");
+ pdumper_do_now_and_after_load (syms_of_ftxfont_for_pdumper);
+}
+
+static void
+syms_of_ftxfont_for_pdumper (void)
+{
register_font_driver (&ftxfont_driver, NULL);
}
diff --git a/src/gfilenotify.c b/src/gfilenotify.c
index 1e0f4160816..a9f33c99004 100644
--- a/src/gfilenotify.c
+++ b/src/gfilenotify.c
@@ -77,7 +77,6 @@ dir_monitor_callback (GFileMonitor *monitor,
/* Determine callback function. */
monitor_object = make_pointer_integer (monitor);
- eassert (INTEGERP (monitor_object));
watch_object = assq_no_quit (monitor_object, watch_list);
if (CONSP (watch_object))
@@ -87,11 +86,11 @@ dir_monitor_callback (GFileMonitor *monitor,
/* Check, whether event_type is expected. */
flags = XCAR (XCDR (XCDR (watch_object)));
- if ((!NILP (Fmember (Qchange, flags)) &&
- !NILP (Fmember (symbol, list5 (Qchanged, Qchanges_done_hint,
- Qdeleted, Qcreated, Qmoved)))) ||
- (!NILP (Fmember (Qattribute_change, flags)) &&
- ((EQ (symbol, Qattribute_changed)))))
+ if ((!NILP (Fmember (Qchange, flags))
+ && !NILP (Fmember (symbol, list5 (Qchanged, Qchanges_done_hint,
+ Qdeleted, Qcreated, Qmoved))))
+ || (!NILP (Fmember (Qattribute_change, flags))
+ && EQ (symbol, Qattribute_changed)))
{
/* Construct an event. */
EVENT_INIT (event);
@@ -109,9 +108,9 @@ dir_monitor_callback (GFileMonitor *monitor,
}
/* Cancel monitor if file or directory is deleted. */
- if (!NILP (Fmember (symbol, list2 (Qdeleted, Qmoved))) &&
- (strcmp (name, SSDATA (XCAR (XCDR (watch_object)))) == 0) &&
- !g_file_monitor_is_cancelled (monitor))
+ if (!NILP (Fmember (symbol, list2 (Qdeleted, Qmoved)))
+ && strcmp (name, SSDATA (XCAR (XCDR (watch_object)))) == 0
+ && !g_file_monitor_is_cancelled (monitor))
g_file_monitor_cancel (monitor);
}
@@ -203,10 +202,10 @@ will be reported only in case of the `moved' event. */)
if (! monitor)
xsignal2 (Qfile_notify_error, build_string ("Cannot watch file"), file);
- Lisp_Object watch_descriptor = make_pointer_integer (monitor);
+ Lisp_Object watch_descriptor = make_pointer_integer_unsafe (monitor);
- /* Check the dicey assumption that make_pointer_integer is safe. */
- if (! INTEGERP (watch_descriptor))
+ if (! (FIXNUMP (watch_descriptor)
+ && XFIXNUMPTR (watch_descriptor) == monitor))
{
g_object_unref (monitor);
xsignal2 (Qfile_notify_error, build_string ("Unsupported file watcher"),
@@ -239,12 +238,12 @@ WATCH-DESCRIPTOR should be an object returned by `gfile-add-watch'. */)
xsignal2 (Qfile_notify_error, build_string ("Not a watch descriptor"),
watch_descriptor);
- eassert (INTEGERP (watch_descriptor));
- GFileMonitor *monitor = XINTPTR (watch_descriptor);
- if (!g_file_monitor_is_cancelled (monitor) &&
- !g_file_monitor_cancel (monitor))
- xsignal2 (Qfile_notify_error, build_string ("Could not rm watch"),
- watch_descriptor);
+ eassert (FIXNUMP (watch_descriptor));
+ GFileMonitor *monitor = XFIXNUMPTR (watch_descriptor);
+ if (!g_file_monitor_is_cancelled (monitor)
+ && !g_file_monitor_cancel (monitor))
+ xsignal2 (Qfile_notify_error, build_string ("Could not rm watch"),
+ watch_descriptor);
/* Remove watch descriptor from watch list. */
watch_list = Fdelq (watch_object, watch_list);
@@ -271,7 +270,7 @@ invalid. */)
return Qnil;
else
{
- GFileMonitor *monitor = XINTPTR (watch_descriptor);
+ GFileMonitor *monitor = XFIXNUMPTR (watch_descriptor);
return g_file_monitor_is_cancelled (monitor) ? Qnil : Qt;
}
}
@@ -290,7 +289,7 @@ If WATCH-DESCRIPTOR is not valid, nil is returned. */)
return Qnil;
else
{
- GFileMonitor *monitor = XINTPTR (watch_descriptor);
+ GFileMonitor *monitor = XFIXNUMPTR (watch_descriptor);
return intern (G_OBJECT_TYPE_NAME (monitor));
}
}
diff --git a/src/gmalloc.c b/src/gmalloc.c
index f3b3d77aac9..b6a96d55727 100644
--- a/src/gmalloc.c
+++ b/src/gmalloc.c
@@ -36,9 +36,9 @@ License along with this library. If not, see <https://www.gnu.org/licenses/>.
#include <pthread.h>
#endif
-#ifdef emacs
-# include "lisp.h"
-#endif
+#include "lisp.h"
+
+#include "ptr-bounds.h"
#ifdef HAVE_MALLOC_H
# if GNUC_PREREQ (4, 2, 0)
@@ -76,7 +76,6 @@ extern void *(*__morecore) (ptrdiff_t);
#ifdef HYBRID_MALLOC
# include "sheap.h"
-# define DUMPED bss_sbrk_did_unexec
#endif
#ifdef __cplusplus
@@ -201,7 +200,8 @@ extern size_t _bytes_free;
/* Internal versions of `malloc', `realloc', and `free'
used when these functions need to call each other.
- They are the same but don't call the hooks. */
+ They are the same but don't call the hooks
+ and don't bound the resulting pointers. */
extern void *_malloc_internal (size_t);
extern void *_realloc_internal (void *, size_t);
extern void _free_internal (void *);
@@ -558,7 +558,7 @@ malloc_initialize_1 (void)
_heapinfo[0].free.size = 0;
_heapinfo[0].free.next = _heapinfo[0].free.prev = 0;
_heapindex = 0;
- _heapbase = (char *) _heapinfo;
+ _heapbase = (char *) ptr_bounds_init (_heapinfo);
_heaplimit = BLOCK (_heapbase + heapsize * sizeof (malloc_info));
register_heapinfo ();
@@ -919,7 +919,8 @@ malloc (size_t size)
among multiple threads. We just leave it for compatibility with
glibc malloc (i.e., assignments to gmalloc_hook) for now. */
hook = gmalloc_hook;
- return (hook != NULL ? *hook : _malloc_internal) (size);
+ void *result = (hook ? hook : _malloc_internal) (size);
+ return ptr_bounds_clip (result, size);
}
#if !(defined (_LIBC) || defined (HYBRID_MALLOC))
@@ -997,6 +998,7 @@ _free_internal_nolock (void *ptr)
if (ptr == NULL)
return;
+ ptr = ptr_bounds_init (ptr);
PROTECT_MALLOC_STATE (0);
@@ -1308,6 +1310,7 @@ _realloc_internal_nolock (void *ptr, size_t size)
else if (ptr == NULL)
return _malloc_internal_nolock (size);
+ ptr = ptr_bounds_init (ptr);
block = BLOCK (ptr);
PROTECT_MALLOC_STATE (0);
@@ -1430,7 +1433,8 @@ realloc (void *ptr, size_t size)
return NULL;
hook = grealloc_hook;
- return (hook != NULL ? *hook : _realloc_internal) (ptr, size);
+ void *result = (hook ? hook : _realloc_internal) (ptr, size);
+ return ptr_bounds_clip (result, size);
}
/* Copyright (C) 1991, 1992, 1994 Free Software Foundation, Inc.
@@ -1503,7 +1507,7 @@ static void *
gdefault_morecore (ptrdiff_t increment)
{
#ifdef HYBRID_MALLOC
- if (!DUMPED)
+ if (!definitely_will_not_unexec_p ())
{
return bss_sbrk (increment);
}
@@ -1604,6 +1608,7 @@ aligned_alloc (size_t alignment, size_t size)
{
l->exact = result;
result = l->aligned = (char *) result + adj;
+ result = ptr_bounds_clip (result, size);
}
UNLOCK_ALIGNED_BLOCKS ();
if (l == NULL)
@@ -1720,6 +1725,8 @@ extern int posix_memalign (void **memptr, size_t alignment, size_t size);
static bool
allocated_via_gmalloc (void *ptr)
{
+ if (!__malloc_initialized)
+ return false;
size_t block = BLOCK (ptr);
size_t blockmax = _heaplimit - 1;
return block <= blockmax && _heapinfo[block].busy.type != 0;
@@ -1731,7 +1738,7 @@ allocated_via_gmalloc (void *ptr)
void *
hybrid_malloc (size_t size)
{
- if (DUMPED)
+ if (definitely_will_not_unexec_p ())
return malloc (size);
return gmalloc (size);
}
@@ -1739,7 +1746,7 @@ hybrid_malloc (size_t size)
void *
hybrid_calloc (size_t nmemb, size_t size)
{
- if (DUMPED)
+ if (definitely_will_not_unexec_p ())
return calloc (nmemb, size);
return gcalloc (nmemb, size);
}
@@ -1757,7 +1764,7 @@ hybrid_free (void *ptr)
void *
hybrid_aligned_alloc (size_t alignment, size_t size)
{
- if (!DUMPED)
+ if (!definitely_will_not_unexec_p ())
return galigned_alloc (alignment, size);
/* The following is copied from alloc.c */
#ifdef HAVE_ALIGNED_ALLOC
@@ -1780,7 +1787,7 @@ hybrid_realloc (void *ptr, size_t size)
return hybrid_malloc (size);
if (!allocated_via_gmalloc (ptr))
return realloc (ptr, size);
- if (!DUMPED)
+ if (!definitely_will_not_unexec_p ())
return grealloc (ptr, size);
/* The dumped emacs is trying to realloc storage allocated before
@@ -2014,11 +2021,7 @@ mabort (enum mcheck_status status)
#else
fprintf (stderr, "mcheck: %s\n", msg);
fflush (stderr);
-# ifdef emacs
emacs_abort ();
-# else
- abort ();
-# endif
#endif
}
diff --git a/src/gnutls.c b/src/gnutls.c
index 3c16b6c9c31..1afbb2bd4e5 100644
--- a/src/gnutls.c
+++ b/src/gnutls.c
@@ -25,36 +25,23 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "gnutls.h"
#include "coding.h"
#include "buffer.h"
+#include "pdumper.h"
#if GNUTLS_VERSION_NUMBER >= 0x030014
# define HAVE_GNUTLS_X509_SYSTEM_TRUST
#endif
-/* Although AEAD support started in GnuTLS 3.4.0 and works in 3.5.14,
- it was broken through at least GnuTLS 3.4.10; see:
- https://lists.gnu.org/r/emacs-devel/2017-07/msg00992.html
- The relevant fix seems to have been made in GnuTLS 3.5.1; see:
- https://gitlab.com/gnutls/gnutls/commit/568935848dd6b82b9315d8b6c529d00e2605e03d
- So, require 3.5.1. */
-#if GNUTLS_VERSION_NUMBER >= 0x030501
-# define HAVE_GNUTLS_AEAD
-#elif GNUTLS_VERSION_NUMBER < 0x030202
-/* gnutls_cipher_get_tag_size was introduced in 3.2.2, but it's only
- relevant for AEAD ciphers. */
-# define gnutls_cipher_get_tag_size(cipher) 0
+#if GNUTLS_VERSION_NUMBER >= 0x030200
+# define HAVE_GNUTLS_CIPHER_GET_IV_SIZE
#endif
-#if GNUTLS_VERSION_NUMBER < 0x030200
-/* gnutls_cipher_get_iv_size was introduced in 3.2.0. For the ciphers
- available in previous versions, block size is equivalent. */
-#define gnutls_cipher_get_iv_size(cipher) gnutls_cipher_get_block_size (cipher)
+#if GNUTLS_VERSION_NUMBER >= 0x030202
+# define HAVE_GNUTLS_CIPHER_GET_TAG_SIZE
+# define HAVE_GNUTLS_DIGEST_LIST /* also gnutls_digest_get_name */
#endif
-#if GNUTLS_VERSION_NUMBER < 0x030202
-/* gnutls_digest_list and gnutls_digest_get_name were added in 3.2.2.
- For previous versions, the mac algorithms are equivalent. */
-# define gnutls_digest_list() ((const gnutls_digest_algorithm_t *) gnutls_mac_list ())
-# define gnutls_digest_get_name(id) gnutls_mac_get_name ((gnutls_mac_algorithm_t) id)
+#if GNUTLS_VERSION_NUMBER >= 0x030205
+# define HAVE_GNUTLS_EXT__DUMBFW
#endif
/* gnutls_mac_get_nonce_size was added in GnuTLS 3.2.0, but was
@@ -67,18 +54,25 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
# define HAVE_GNUTLS_EXT_GET_NAME
#endif
-#if GNUTLS_VERSION_NUMBER >= 0x030205
-# define HAVE_GNUTLS_EXT__DUMBFW
+/* Although AEAD support started in GnuTLS 3.4.0 and works in 3.5.14,
+ it was broken through at least GnuTLS 3.4.10; see:
+ https://lists.gnu.org/r/emacs-devel/2017-07/msg00992.html
+ The relevant fix seems to have been made in GnuTLS 3.5.1; see:
+ https://gitlab.com/gnutls/gnutls/commit/568935848dd6b82b9315d8b6c529d00e2605e03d
+ So, require 3.5.1. */
+#if GNUTLS_VERSION_NUMBER >= 0x030501
+# define HAVE_GNUTLS_AEAD
#endif
#ifdef HAVE_GNUTLS
# ifdef WINDOWSNT
# include <windows.h>
+# include "w32common.h"
# include "w32.h"
# endif
-static bool emacs_gnutls_handle_error (gnutls_session_t, int);
+static int emacs_gnutls_handle_error (gnutls_session_t, int);
static bool gnutls_global_initialized;
@@ -222,19 +216,17 @@ DEF_DLL_FN (const gnutls_mac_algorithm_t *, gnutls_mac_list, (void));
DEF_DLL_FN (size_t, gnutls_mac_get_nonce_size, (gnutls_mac_algorithm_t));
# endif
DEF_DLL_FN (size_t, gnutls_mac_get_key_size, (gnutls_mac_algorithm_t));
-# ifndef gnutls_digest_list
+# ifdef HAVE_GNUTLS_DIGEST_LIST
DEF_DLL_FN (const gnutls_digest_algorithm_t *, gnutls_digest_list, (void));
-# endif
-# ifndef gnutls_digest_get_name
DEF_DLL_FN (const char *, gnutls_digest_get_name, (gnutls_digest_algorithm_t));
# endif
DEF_DLL_FN (gnutls_cipher_algorithm_t *, gnutls_cipher_list, (void));
-# ifndef gnutls_cipher_get_iv_size
+# ifdef HAVE_GNUTLS_CIPHER_GET_IV_SIZE
DEF_DLL_FN (int, gnutls_cipher_get_iv_size, (gnutls_cipher_algorithm_t));
# endif
DEF_DLL_FN (size_t, gnutls_cipher_get_key_size, (gnutls_cipher_algorithm_t));
DEF_DLL_FN (int, gnutls_cipher_get_block_size, (gnutls_cipher_algorithm_t));
-# ifndef gnutls_cipher_get_tag_size
+# ifdef HAVE_GNUTLS_CIPHER_GET_TAG_SIZE
DEF_DLL_FN (int, gnutls_cipher_get_tag_size, (gnutls_cipher_algorithm_t));
# endif
DEF_DLL_FN (int, gnutls_cipher_init,
@@ -364,19 +356,17 @@ init_gnutls_functions (void)
LOAD_DLL_FN (library, gnutls_mac_get_nonce_size);
# endif
LOAD_DLL_FN (library, gnutls_mac_get_key_size);
-# ifndef gnutls_digest_list
+# ifdef HAVE_GNUTLS_DIGEST_LIST
LOAD_DLL_FN (library, gnutls_digest_list);
-# endif
-# ifndef gnutls_digest_get_name
LOAD_DLL_FN (library, gnutls_digest_get_name);
# endif
LOAD_DLL_FN (library, gnutls_cipher_list);
-# ifndef gnutls_cipher_get_iv_size
+# ifdef HAVE_GNUTLS_CIPHER_GET_IV_SIZE
LOAD_DLL_FN (library, gnutls_cipher_get_iv_size);
# endif
LOAD_DLL_FN (library, gnutls_cipher_get_key_size);
LOAD_DLL_FN (library, gnutls_cipher_get_block_size);
-# ifndef gnutls_cipher_get_tag_size
+# ifdef HAVE_GNUTLS_CIPHER_GET_TAG_SIZE
LOAD_DLL_FN (library, gnutls_cipher_get_tag_size);
# endif
LOAD_DLL_FN (library, gnutls_cipher_init);
@@ -405,8 +395,7 @@ init_gnutls_functions (void)
# endif
# endif /* HAVE_GNUTLS3 */
- max_log_level = global_gnutls_log_level;
-
+ max_log_level = clip_to_bounds (INT_MIN, global_gnutls_log_level, INT_MAX);
{
Lisp_Object name = CAR_SAFE (Fget (Qgnutls, QCloaded_from));
GNUTLS_LOG2 (1, max_log_level, "GnuTLS library loaded:",
@@ -488,19 +477,17 @@ init_gnutls_functions (void)
# define gnutls_mac_get_nonce_size fn_gnutls_mac_get_nonce_size
# endif
# define gnutls_mac_get_key_size fn_gnutls_mac_get_key_size
-# ifndef gnutls_digest_list
+# ifdef HAVE_GNUTLS_DIGEST_LIST
# define gnutls_digest_list fn_gnutls_digest_list
-# endif
-# ifndef gnutls_digest_get_name
# define gnutls_digest_get_name fn_gnutls_digest_get_name
# endif
# define gnutls_cipher_list fn_gnutls_cipher_list
-# ifndef gnutls_cipher_get_iv_size
+# ifdef HAVE_GNUTLS_CIPHER_GET_IV_SIZE
# define gnutls_cipher_get_iv_size fn_gnutls_cipher_get_iv_size
# endif
# define gnutls_cipher_get_key_size fn_gnutls_cipher_get_key_size
# define gnutls_cipher_get_block_size fn_gnutls_cipher_get_block_size
-# ifndef gnutls_cipher_get_tag_size
+# ifdef HAVE_GNUTLS_CIPHER_GET_TAG_SIZE
# define gnutls_cipher_get_tag_size fn_gnutls_cipher_get_tag_size
# endif
# define gnutls_cipher_init fn_gnutls_cipher_init
@@ -591,15 +578,17 @@ gnutls_try_handshake (struct Lisp_Process *proc)
if (non_blocking)
proc->gnutls_p = true;
- do
+ while ((ret = gnutls_handshake (state)) < 0)
{
- ret = gnutls_handshake (state);
- emacs_gnutls_handle_error (state, ret);
+ do
+ ret = gnutls_handshake (state);
+ while (ret == GNUTLS_E_INTERRUPTED);
+
+ if (0 <= ret || emacs_gnutls_handle_error (state, ret) == 0
+ || non_blocking)
+ break;
maybe_quit ();
}
- while (ret < 0
- && gnutls_error_is_fatal (ret) == 0
- && ! non_blocking);
proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
@@ -694,8 +683,6 @@ emacs_gnutls_transport_set_errno (gnutls_session_t state, int err)
ptrdiff_t
emacs_gnutls_write (struct Lisp_Process *proc, const char *buf, ptrdiff_t nbyte)
{
- ssize_t rtnval = 0;
- ptrdiff_t bytes_written;
gnutls_session_t state = proc->gnutls_state;
if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
@@ -704,25 +691,19 @@ emacs_gnutls_write (struct Lisp_Process *proc, const char *buf, ptrdiff_t nbyte)
return 0;
}
- bytes_written = 0;
+ ptrdiff_t bytes_written = 0;
while (nbyte > 0)
{
- rtnval = gnutls_record_send (state, buf, nbyte);
+ ssize_t rtnval;
+ do
+ rtnval = gnutls_record_send (state, buf, nbyte);
+ while (rtnval == GNUTLS_E_INTERRUPTED);
if (rtnval < 0)
{
- if (rtnval == GNUTLS_E_INTERRUPTED)
- continue;
- else
- {
- /* If we get GNUTLS_E_AGAIN, then set errno
- appropriately so that send_process retries the
- correct way instead of erroring out. */
- if (rtnval == GNUTLS_E_AGAIN)
- errno = EAGAIN;
- break;
- }
+ emacs_gnutls_handle_error (state, rtnval);
+ break;
}
buf += rtnval;
@@ -730,14 +711,12 @@ emacs_gnutls_write (struct Lisp_Process *proc, const char *buf, ptrdiff_t nbyte)
bytes_written += rtnval;
}
- emacs_gnutls_handle_error (state, rtnval);
return (bytes_written);
}
ptrdiff_t
emacs_gnutls_read (struct Lisp_Process *proc, char *buf, ptrdiff_t nbyte)
{
- ssize_t rtnval;
gnutls_session_t state = proc->gnutls_state;
if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
@@ -746,19 +725,18 @@ emacs_gnutls_read (struct Lisp_Process *proc, char *buf, ptrdiff_t nbyte)
return -1;
}
- rtnval = gnutls_record_recv (state, buf, nbyte);
+ ssize_t rtnval;
+ do
+ rtnval = gnutls_record_recv (state, buf, nbyte);
+ while (rtnval == GNUTLS_E_INTERRUPTED);
+
if (rtnval >= 0)
return rtnval;
else if (rtnval == GNUTLS_E_UNEXPECTED_PACKET_LENGTH)
/* The peer closed the connection. */
return 0;
- else if (emacs_gnutls_handle_error (state, rtnval))
- /* non-fatal error */
- return -1;
- else {
- /* a fatal error occurred */
- return 0;
- }
+ else
+ return emacs_gnutls_handle_error (state, rtnval);
}
static char const *
@@ -769,25 +747,25 @@ emacs_gnutls_strerror (int err)
}
/* Report a GnuTLS error to the user.
- Return true if the error code was successfully handled. */
-static bool
+ SESSION is the GnuTLS session, ERR is the (negative) GnuTLS error code.
+ Return 0 if the error was fatal, -1 (setting errno) otherwise so
+ that the caller can notice the error and attempt a repair. */
+static int
emacs_gnutls_handle_error (gnutls_session_t session, int err)
{
- int max_log_level = 0;
-
- bool ret;
+ int ret;
/* TODO: use a Lisp_Object generated by gnutls_make_error? */
- if (err >= 0)
- return 1;
check_memory_full (err);
- max_log_level = global_gnutls_log_level;
+ int max_log_level
+ = clip_to_bounds (INT_MIN, global_gnutls_log_level, INT_MAX);
/* TODO: use gnutls-error-fatalp and gnutls-error-string. */
char const *str = emacs_gnutls_strerror (err);
+ int errnum = EINVAL;
if (gnutls_error_is_fatal (err))
{
@@ -801,11 +779,11 @@ emacs_gnutls_handle_error (gnutls_session_t session, int err)
# endif
GNUTLS_LOG2 (level, max_log_level, "fatal error:", str);
- ret = false;
+ ret = 0;
}
else
{
- ret = true;
+ ret = -1;
switch (err)
{
@@ -821,6 +799,26 @@ emacs_gnutls_handle_error (gnutls_session_t session, int err)
"non-fatal error:",
str);
}
+
+ switch (err)
+ {
+ case GNUTLS_E_AGAIN:
+ errnum = EAGAIN;
+ break;
+
+# ifdef EMSGSIZE
+ case GNUTLS_E_LARGE_PACKET:
+ case GNUTLS_E_PUSH_ERROR:
+ errnum = EMSGSIZE;
+ break;
+# endif
+
+# if defined HAVE_GNUTLS3 && defined ECONNRESET
+ case GNUTLS_E_PREMATURE_TERMINATION:
+ errnum = ECONNRESET;
+ break;
+# endif
+ }
}
if (err == GNUTLS_E_WARNING_ALERT_RECEIVED
@@ -834,6 +832,8 @@ emacs_gnutls_handle_error (gnutls_session_t session, int err)
GNUTLS_LOG2 (level, max_log_level, "Received alert: ", str);
}
+
+ errno = errnum;
return ret;
}
@@ -857,7 +857,20 @@ gnutls_make_error (int err)
}
check_memory_full (err);
- return make_number (err);
+ return make_fixnum (err);
+}
+
+static void
+gnutls_deinit_certificates (struct Lisp_Process *p)
+{
+ if (! p->gnutls_certificates)
+ return;
+
+ for (int i = 0; i < p->gnutls_certificates_length; i++)
+ gnutls_x509_crt_deinit (p->gnutls_certificates[i]);
+
+ xfree (p->gnutls_certificates);
+ p->gnutls_certificates = NULL;
}
Lisp_Object
@@ -894,6 +907,9 @@ emacs_gnutls_deinit (Lisp_Object proc)
GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1;
}
+ if (XPROCESS (proc)->gnutls_certificates)
+ gnutls_deinit_certificates (XPROCESS (proc));
+
XPROCESS (proc)->gnutls_p = false;
return Qt;
}
@@ -918,7 +934,7 @@ See also `gnutls-boot'. */)
{
CHECK_PROCESS (proc);
- return make_number (GNUTLS_INITSTAGE (proc));
+ return make_fixnum (GNUTLS_INITSTAGE (proc));
}
DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0,
@@ -958,10 +974,10 @@ Usage: (gnutls-error-fatalp ERROR) */)
}
}
- if (! TYPE_RANGED_INTEGERP (int, err))
+ if (! TYPE_RANGED_FIXNUMP (int, err))
error ("Not an error symbol or code");
- if (0 == gnutls_error_is_fatal (XINT (err)))
+ if (0 == gnutls_error_is_fatal (XFIXNUM (err)))
return Qnil;
return Qt;
@@ -990,10 +1006,10 @@ usage: (gnutls-error-string ERROR) */)
}
}
- if (! TYPE_RANGED_INTEGERP (int, err))
+ if (! TYPE_RANGED_FIXNUMP (int, err))
return build_string ("Not an error symbol or code");
- return build_string (emacs_gnutls_strerror (XINT (err)));
+ return build_string (emacs_gnutls_strerror (XFIXNUM (err)));
}
DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0,
@@ -1037,7 +1053,7 @@ gnutls_certificate_details (gnutls_x509_crt_t cert)
check_memory_full (version);
if (version >= GNUTLS_E_SUCCESS)
res = nconc2 (res, list2 (intern (":version"),
- make_number (version)));
+ make_fixnum (version)));
}
/* Serial. */
@@ -1235,9 +1251,17 @@ DEFUN ("gnutls-peer-status-warning-describe", Fgnutls_peer_status_warning_descri
DEFUN ("gnutls-peer-status", Fgnutls_peer_status, Sgnutls_peer_status, 1, 1, 0,
doc: /* Describe a GnuTLS PROC peer certificate and any warnings about it.
+
The return value is a property list with top-level keys :warnings and
-:certificate. The :warnings entry is a list of symbols you can describe with
-`gnutls-peer-status-warning-describe'. */)
+:certificates.
+
+The :warnings entry is a list of symbols you can get a description of
+with `gnutls-peer-status-warning-describe', and :certificates is the
+certificate chain for the connection, with the host certificate
+first, and intermediary certificates (if any) following it.
+
+In addition, for backwards compatibility, the host certificate is also
+returned as the :certificate entry. */)
(Lisp_Object proc)
{
Lisp_Object warnings = Qnil, result = Qnil;
@@ -1279,9 +1303,9 @@ The return value is a property list with top-level keys :warnings and
/* This could get called in the INIT stage, when the certificate is
not yet set. */
- if (XPROCESS (proc)->gnutls_certificate != NULL &&
- gnutls_x509_crt_check_issuer(XPROCESS (proc)->gnutls_certificate,
- XPROCESS (proc)->gnutls_certificate))
+ if (XPROCESS (proc)->gnutls_certificates != NULL &&
+ gnutls_x509_crt_check_issuer(XPROCESS (proc)->gnutls_certificates[0],
+ XPROCESS (proc)->gnutls_certificates[0]))
warnings = Fcons (intern (":self-signed"), warnings);
if (!NILP (warnings))
@@ -1289,10 +1313,21 @@ The return value is a property list with top-level keys :warnings and
/* This could get called in the INIT stage, when the certificate is
not yet set. */
- if (XPROCESS (proc)->gnutls_certificate != NULL)
- result = nconc2 (result, list2
- (intern (":certificate"),
- gnutls_certificate_details (XPROCESS (proc)->gnutls_certificate)));
+ if (XPROCESS (proc)->gnutls_certificates != NULL)
+ {
+ Lisp_Object certs = Qnil;
+
+ /* Return all the certificates in a list. */
+ for (int i = 0; i < XPROCESS (proc)->gnutls_certificates_length; i++)
+ certs = nconc2 (certs, list1 (gnutls_certificate_details
+ (XPROCESS (proc)->gnutls_certificates[i])));
+
+ result = nconc2 (result, list2 (intern (":certificates"), certs));
+
+ /* Return the host certificate in its own element for
+ compatibility reasons. */
+ result = nconc2 (result, list2 (intern (":certificate"), Fcar (certs)));
+ }
state = XPROCESS (proc)->gnutls_state;
@@ -1302,7 +1337,7 @@ The return value is a property list with top-level keys :warnings and
check_memory_full (bits);
if (bits > 0)
result = nconc2 (result, list2 (intern (":diffie-hellman-prime-bits"),
- make_number (bits)));
+ make_fixnum (bits)));
}
/* Key exchange. */
@@ -1435,7 +1470,7 @@ gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist)
if (ret < GNUTLS_E_SUCCESS)
return gnutls_make_error (ret);
- XPROCESS (proc)->gnutls_peer_verification = peer_verification;
+ p->gnutls_peer_verification = peer_verification;
warnings = Fplist_get (Fgnutls_peer_status (proc), intern (":warnings"));
if (!NILP (warnings))
@@ -1472,49 +1507,60 @@ gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist)
can be easily extended to work with openpgp keys as well. */
if (gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
{
- gnutls_x509_crt_t gnutls_verify_cert;
- const gnutls_datum_t *gnutls_verify_cert_list;
- unsigned int gnutls_verify_cert_list_size;
+ const gnutls_datum_t *cert_list;
+ unsigned int cert_list_length;
+ int failed_import = 0;
- ret = gnutls_x509_crt_init (&gnutls_verify_cert);
- if (ret < GNUTLS_E_SUCCESS)
- return gnutls_make_error (ret);
-
- gnutls_verify_cert_list
- = gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
+ cert_list = gnutls_certificate_get_peers (state, &cert_list_length);
- if (gnutls_verify_cert_list == NULL)
+ if (cert_list == NULL)
{
- gnutls_x509_crt_deinit (gnutls_verify_cert);
emacs_gnutls_deinit (proc);
boot_error (p, "No x509 certificate was found\n");
return Qnil;
}
- /* Check only the first certificate in the given chain. */
- ret = gnutls_x509_crt_import (gnutls_verify_cert,
- &gnutls_verify_cert_list[0],
- GNUTLS_X509_FMT_DER);
+ /* Check only the first certificate in the given chain, but
+ store them all. */
+ p->gnutls_certificates =
+ xmalloc (cert_list_length * sizeof (gnutls_x509_crt_t));
+ p->gnutls_certificates_length = cert_list_length;
- if (ret < GNUTLS_E_SUCCESS)
+ for (int i = cert_list_length - 1; i >= 0; i--)
{
- gnutls_x509_crt_deinit (gnutls_verify_cert);
- return gnutls_make_error (ret);
+ gnutls_x509_crt_t cert;
+
+ gnutls_x509_crt_init (&cert);
+
+ if (ret < GNUTLS_E_SUCCESS)
+ failed_import = ret;
+ else
+ {
+ ret = gnutls_x509_crt_import (cert, &cert_list[i],
+ GNUTLS_X509_FMT_DER);
+
+ if (ret < GNUTLS_E_SUCCESS)
+ failed_import = ret;
+ }
+
+ p->gnutls_certificates[i] = cert;
}
- XPROCESS (proc)->gnutls_certificate = gnutls_verify_cert;
+ if (failed_import != 0)
+ {
+ gnutls_deinit_certificates (p);
+ return gnutls_make_error (failed_import);
+ }
- int err = gnutls_x509_crt_check_hostname (gnutls_verify_cert,
+ int err = gnutls_x509_crt_check_hostname (p->gnutls_certificates[0],
c_hostname);
check_memory_full (err);
if (!err)
{
- XPROCESS (proc)->gnutls_extra_peer_verification
- |= CERTIFICATE_NOT_MATCHING;
+ p->gnutls_extra_peer_verification |= CERTIFICATE_NOT_MATCHING;
if (verify_error_all
|| !NILP (Fmember (QChostname, verify_error)))
{
- gnutls_x509_crt_deinit (gnutls_verify_cert);
emacs_gnutls_deinit (proc);
boot_error (p, "The x509 certificate does not match \"%s\"",
c_hostname);
@@ -1527,7 +1573,7 @@ gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist)
}
/* Set this flag only if the whole initialization succeeded. */
- XPROCESS (proc)->gnutls_p = true;
+ p->gnutls_p = true;
return gnutls_make_error (ret);
}
@@ -1645,14 +1691,17 @@ one trustfile (usually a CA bundle). */)
state = XPROCESS (proc)->gnutls_state;
- if (TYPE_RANGED_INTEGERP (int, loglevel))
+ if (INTEGERP (loglevel))
{
gnutls_global_set_log_function (gnutls_log_function);
# ifdef HAVE_GNUTLS3
gnutls_global_set_audit_log_function (gnutls_audit_log_function);
# endif
- gnutls_global_set_log_level (XINT (loglevel));
- max_log_level = XINT (loglevel);
+ int level = (FIXNUMP (loglevel)
+ ? clip_to_bounds (INT_MIN, XFIXNUM (loglevel), INT_MAX)
+ : NILP (Fnatnump (loglevel)) ? INT_MIN : INT_MAX);
+ gnutls_global_set_log_level (level);
+ max_log_level = level;
XPROCESS (proc)->gnutls_log_level = max_log_level;
}
@@ -1685,9 +1734,9 @@ one trustfile (usually a CA bundle). */)
XPROCESS (proc)->gnutls_x509_cred = x509_cred;
verify_flags = Fplist_get (proplist, QCverify_flags);
- if (TYPE_RANGED_INTEGERP (unsigned int, verify_flags))
+ if (TYPE_RANGED_FIXNUMP (unsigned int, verify_flags))
{
- gnutls_verify_flags = XFASTINT (verify_flags);
+ gnutls_verify_flags = XFIXNAT (verify_flags);
GNUTLS_LOG (2, max_log_level, "setting verification flags");
}
else if (NILP (verify_flags))
@@ -1846,8 +1895,8 @@ one trustfile (usually a CA bundle). */)
GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
- if (INTEGERP (prime_bits))
- gnutls_dh_set_prime_bits (state, XUINT (prime_bits));
+ if (FIXNUMP (prime_bits))
+ gnutls_dh_set_prime_bits (state, XUFIXNUM (prime_bits));
ret = EQ (type, Qgnutls_x509pki)
? gnutls_credentials_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred)
@@ -1896,7 +1945,8 @@ This function may also return `gnutls-e-again', or
state = XPROCESS (proc)->gnutls_state;
- gnutls_x509_crt_deinit (XPROCESS (proc)->gnutls_certificate);
+ if (XPROCESS (proc)->gnutls_certificates)
+ gnutls_deinit_certificates (XPROCESS (proc));
ret = gnutls_bye (state, NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR);
@@ -1907,6 +1957,24 @@ This function may also return `gnutls-e-again', or
#ifdef HAVE_GNUTLS3
+# ifndef HAVE_GNUTLS_CIPHER_GET_IV_SIZE
+ /* Block size is equivalent. */
+# define gnutls_cipher_get_iv_size(cipher) gnutls_cipher_get_block_size (cipher)
+# endif
+
+# ifndef HAVE_GNUTLS_CIPHER_GET_TAG_SIZE
+ /* Tag size is irrelevant. */
+# define gnutls_cipher_get_tag_size(cipher) 0
+# endif
+
+# ifndef HAVE_GNUTLS_DIGEST_LIST
+ /* The mac algorithms are equivalent. */
+# define gnutls_digest_list() \
+ ((gnutls_digest_algorithm_t const *) gnutls_mac_list ())
+# define gnutls_digest_get_name(id) \
+ gnutls_mac_get_name ((gnutls_mac_algorithm_t) (id))
+# endif
+
DEFUN ("gnutls-ciphers", Fgnutls_ciphers, Sgnutls_ciphers, 0, 0, 0,
doc: /* Return alist of GnuTLS symmetric cipher descriptions as plists.
The alist key is the cipher name. */)
@@ -1930,20 +1998,20 @@ The alist key is the cipher name. */)
ptrdiff_t cipher_tag_size = gnutls_cipher_get_tag_size (gca);
Lisp_Object cp
- = listn (CONSTYPE_HEAP, 15, cipher_symbol,
- QCcipher_id, make_number (gca),
+ = list (cipher_symbol,
+ QCcipher_id, make_fixnum (gca),
QCtype, Qgnutls_type_cipher,
QCcipher_aead_capable, cipher_tag_size == 0 ? Qnil : Qt,
- QCcipher_tagsize, make_number (cipher_tag_size),
+ QCcipher_tagsize, make_fixnum (cipher_tag_size),
QCcipher_blocksize,
- make_number (gnutls_cipher_get_block_size (gca)),
+ make_fixnum (gnutls_cipher_get_block_size (gca)),
QCcipher_keysize,
- make_number (gnutls_cipher_get_key_size (gca)),
+ make_fixnum (gnutls_cipher_get_key_size (gca)),
QCcipher_ivsize,
- make_number (gnutls_cipher_get_iv_size (gca)));
+ make_fixnum (gnutls_cipher_get_iv_size (gca)));
ciphers = Fcons (cp, ciphers);
}
@@ -2073,16 +2141,16 @@ gnutls_symmetric (bool encrypting, Lisp_Object cipher,
cipher);
info = XCDR (info);
}
- else if (TYPE_RANGED_INTEGERP (gnutls_cipher_algorithm_t, cipher))
- gca = XINT (cipher);
+ else if (TYPE_RANGED_FIXNUMP (gnutls_cipher_algorithm_t, cipher))
+ gca = XFIXNUM (cipher);
else
info = cipher;
if (!NILP (info) && CONSP (info))
{
Lisp_Object v = Fplist_get (info, QCcipher_id);
- if (TYPE_RANGED_INTEGERP (gnutls_cipher_algorithm_t, v))
- gca = XINT (v);
+ if (TYPE_RANGED_FIXNUMP (gnutls_cipher_algorithm_t, v))
+ gca = XFIXNUM (v);
}
ptrdiff_t key_size = gnutls_cipher_get_key_size (gca);
@@ -2258,21 +2326,21 @@ name. */)
Lisp_Object gma_symbol = intern (gnutls_mac_get_name (gma));
size_t nonce_size = 0;
-#ifdef HAVE_GNUTLS_MAC_GET_NONCE_SIZE
+# ifdef HAVE_GNUTLS_MAC_GET_NONCE_SIZE
nonce_size = gnutls_mac_get_nonce_size (gma);
-#endif
- Lisp_Object mp = listn (CONSTYPE_HEAP, 11, gma_symbol,
- QCmac_algorithm_id, make_number (gma),
+# endif
+ Lisp_Object mp = list (gma_symbol,
+ QCmac_algorithm_id, make_fixnum (gma),
QCtype, Qgnutls_type_mac_algorithm,
QCmac_algorithm_length,
- make_number (gnutls_hmac_get_len (gma)),
+ make_fixnum (gnutls_hmac_get_len (gma)),
QCmac_algorithm_keysize,
- make_number (gnutls_mac_get_key_size (gma)),
+ make_fixnum (gnutls_mac_get_key_size (gma)),
QCmac_algorithm_noncesize,
- make_number (nonce_size));
+ make_fixnum (nonce_size));
mac_algorithms = Fcons (mp, mac_algorithms);
}
@@ -2296,12 +2364,12 @@ method name. */)
/* A symbol representing the GnuTLS digest algorithm. */
Lisp_Object gda_symbol = intern (gnutls_digest_get_name (gda));
- Lisp_Object mp = listn (CONSTYPE_HEAP, 7, gda_symbol,
- QCdigest_algorithm_id, make_number (gda),
+ Lisp_Object mp = list (gda_symbol,
+ QCdigest_algorithm_id, make_fixnum (gda),
QCtype, Qgnutls_type_digest_algorithm,
QCdigest_algorithm_length,
- make_number (gnutls_hash_get_len (gda)));
+ make_fixnum (gnutls_hash_get_len (gda)));
digest_algorithms = Fcons (mp, digest_algorithms);
}
@@ -2352,16 +2420,16 @@ itself. */)
hash_method);
info = XCDR (info);
}
- else if (TYPE_RANGED_INTEGERP (gnutls_mac_algorithm_t, hash_method))
- gma = XINT (hash_method);
+ else if (TYPE_RANGED_FIXNUMP (gnutls_mac_algorithm_t, hash_method))
+ gma = XFIXNUM (hash_method);
else
info = hash_method;
if (!NILP (info) && CONSP (info))
{
Lisp_Object v = Fplist_get (info, QCmac_algorithm_id);
- if (TYPE_RANGED_INTEGERP (gnutls_mac_algorithm_t, v))
- gma = XINT (v);
+ if (TYPE_RANGED_FIXNUMP (gnutls_mac_algorithm_t, v))
+ gma = XFIXNUM (v);
}
ptrdiff_t digest_length = gnutls_hmac_get_len (gma);
@@ -2442,16 +2510,16 @@ the number itself. */)
digest_method);
info = XCDR (info);
}
- else if (TYPE_RANGED_INTEGERP (gnutls_digest_algorithm_t, digest_method))
- gda = XINT (digest_method);
+ else if (TYPE_RANGED_FIXNUMP (gnutls_digest_algorithm_t, digest_method))
+ gda = XFIXNUM (digest_method);
else
info = digest_method;
if (!NILP (info) && CONSP (info))
{
Lisp_Object v = Fplist_get (info, QCdigest_algorithm_id);
- if (TYPE_RANGED_INTEGERP (gnutls_digest_algorithm_t, v))
- gda = XINT (v);
+ if (TYPE_RANGED_FIXNUMP (gnutls_digest_algorithm_t, v))
+ gda = XFIXNUM (v);
}
ptrdiff_t digest_length = gnutls_hash_get_len (gda);
@@ -2565,15 +2633,16 @@ syms_of_gnutls (void)
DEFSYM (Qlibgnutls_version, "libgnutls-version");
Fset (Qlibgnutls_version,
#ifdef HAVE_GNUTLS
- make_number (GNUTLS_VERSION_MAJOR * 10000
+ make_fixnum (GNUTLS_VERSION_MAJOR * 10000
+ GNUTLS_VERSION_MINOR * 100
+ GNUTLS_VERSION_PATCH)
#else
- make_number (-1)
+ make_fixnum (-1)
#endif
);
#ifdef HAVE_GNUTLS
gnutls_global_initialized = 0;
+ PDUMPER_IGNORE (gnutls_global_initialized);
DEFSYM (Qgnutls_code, "gnutls-code");
DEFSYM (Qgnutls_anon, "gnutls-anon");
@@ -2613,19 +2682,19 @@ syms_of_gnutls (void)
DEFSYM (Qgnutls_e_interrupted, "gnutls-e-interrupted");
Fput (Qgnutls_e_interrupted, Qgnutls_code,
- make_number (GNUTLS_E_INTERRUPTED));
+ make_fixnum (GNUTLS_E_INTERRUPTED));
DEFSYM (Qgnutls_e_again, "gnutls-e-again");
Fput (Qgnutls_e_again, Qgnutls_code,
- make_number (GNUTLS_E_AGAIN));
+ make_fixnum (GNUTLS_E_AGAIN));
DEFSYM (Qgnutls_e_invalid_session, "gnutls-e-invalid-session");
Fput (Qgnutls_e_invalid_session, Qgnutls_code,
- make_number (GNUTLS_E_INVALID_SESSION));
+ make_fixnum (GNUTLS_E_INVALID_SESSION));
DEFSYM (Qgnutls_e_not_ready_for_handshake, "gnutls-e-not-ready-for-handshake");
Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code,
- make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
+ make_fixnum (GNUTLS_E_APPLICATION_ERROR_MIN));
defsubr (&Sgnutls_get_initstage);
defsubr (&Sgnutls_asynchronous_parameters);
diff --git a/src/gtkutil.c b/src/gtkutil.c
index fe1680b21b5..b130692c87a 100644
--- a/src/gtkutil.c
+++ b/src/gtkutil.c
@@ -147,7 +147,9 @@ struct xg_frame_tb_info
GtkTextDirection dir;
};
+#ifdef HAVE_XWIDGETS
bool xg_gtk_initialized; /* Used to make sure xwidget calls are possible */
+#endif
static GtkWidget * xg_get_widget_from_map (ptrdiff_t idx);
@@ -260,8 +262,8 @@ xg_display_close (Display *dpy)
}
#if GTK_CHECK_VERSION (2, 0, 0) && ! GTK_CHECK_VERSION (2, 10, 0)
- /* GTK 2.2-2.8 has a bug that makes gdk_display_close crash (bug
- https://gitlab.gnome.org/GNOME/gtk/issues/221). This way we
+ /* GTK 2.2-2.8 has a bug that makes gdk_display_close crash
+ <https://gitlab.gnome.org/GNOME/gtk/issues/221>. This way we
can continue running, but there will be memory leaks. */
g_object_run_dispose (G_OBJECT (gdpy));
#else
@@ -366,7 +368,11 @@ xg_get_image_for_pixmap (struct frame *f,
GtkWidget *widget,
GtkImage *old_widget)
{
+#if defined USE_CAIRO && GTK_CHECK_VERSION (3, 10, 0)
+ cairo_surface_t *surface;
+#else
GdkPixbuf *icon_buf;
+#endif
/* If we have a file, let GTK do all the image handling.
This seems to be the only way to make insensitive and activated icons
@@ -394,6 +400,17 @@ xg_get_image_for_pixmap (struct frame *f,
on a monochrome display, and sometimes bad on all displays with
certain themes. */
+#if defined USE_CAIRO && GTK_CHECK_VERSION (3, 10, 0)
+ surface = img->cr_data;
+
+ if (surface)
+ {
+ if (! old_widget)
+ old_widget = GTK_IMAGE (gtk_image_new_from_surface (surface));
+ else
+ gtk_image_set_from_surface (old_widget, surface);
+ }
+#else
/* This is a workaround to make icons look good on pseudo color
displays. Apparently GTK expects the images to have an alpha
channel. If they don't, insensitive and activated icons will
@@ -414,6 +431,7 @@ xg_get_image_for_pixmap (struct frame *f,
g_object_unref (G_OBJECT (icon_buf));
}
+#endif
return GTK_WIDGET (old_widget);
}
@@ -689,6 +707,7 @@ qttip_cb (GtkWidget *widget,
g_signal_connect (x->ttip_lbl, "hierarchy-changed",
G_CALLBACK (hierarchy_ch_cb), f);
}
+
return FALSE;
}
@@ -715,7 +734,8 @@ xg_prepare_tooltip (struct frame *f,
GtkRequisition req;
Lisp_Object encoded_string;
- if (!x->ttip_lbl) return 0;
+ if (!x->ttip_lbl)
+ return FALSE;
block_input ();
encoded_string = ENCODE_UTF_8 (string);
@@ -747,7 +767,7 @@ xg_prepare_tooltip (struct frame *f,
unblock_input ();
- return 1;
+ return TRUE;
#endif /* USE_GTK_TOOLTIP */
}
@@ -764,24 +784,24 @@ xg_show_tooltip (struct frame *f, int root_x, int root_y)
block_input ();
gtk_window_move (x->ttip_window, root_x / xg_get_scale (f),
root_y / xg_get_scale (f));
- gtk_widget_show_all (GTK_WIDGET (x->ttip_window));
+ gtk_widget_show (GTK_WIDGET (x->ttip_window));
unblock_input ();
}
#endif
}
+
/* Hide tooltip if shown. Do nothing if not shown.
Return true if tip was hidden, false if not (i.e. not using
system tooltips). */
-
bool
xg_hide_tooltip (struct frame *f)
{
- bool ret = 0;
#ifdef USE_GTK_TOOLTIP
if (f->output_data.x->ttip_window)
{
GtkWindow *win = f->output_data.x->ttip_window;
+
block_input ();
gtk_widget_hide (GTK_WIDGET (win));
@@ -794,10 +814,10 @@ xg_hide_tooltip (struct frame *f)
}
unblock_input ();
- ret = 1;
+ return TRUE;
}
#endif
- return ret;
+ return FALSE;
}
@@ -963,7 +983,7 @@ xg_frame_set_char_size (struct frame *f, int width, int height)
{
frame_size_history_add
(f, Qxg_frame_set_char_size_1, width, height,
- list2 (make_number (gheight), make_number (totalheight)));
+ list2i (gheight, totalheight));
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
gwidth, totalheight);
@@ -972,7 +992,7 @@ xg_frame_set_char_size (struct frame *f, int width, int height)
{
frame_size_history_add
(f, Qxg_frame_set_char_size_2, width, height,
- list2 (make_number (gwidth), make_number (totalwidth)));
+ list2i (gwidth, totalwidth));
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
totalwidth, gheight);
@@ -981,7 +1001,7 @@ xg_frame_set_char_size (struct frame *f, int width, int height)
{
frame_size_history_add
(f, Qxg_frame_set_char_size_3, width, height,
- list2 (make_number (totalwidth), make_number (totalheight)));
+ list2i (totalwidth, totalheight));
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
totalwidth, totalheight);
@@ -1066,16 +1086,23 @@ static void
xg_set_widget_bg (struct frame *f, GtkWidget *w, unsigned long pixel)
{
#ifdef HAVE_GTK3
- GdkRGBA bg;
XColor xbg;
xbg.pixel = pixel;
if (XQueryColor (FRAME_X_DISPLAY (f), FRAME_X_COLORMAP (f), &xbg))
{
- bg.red = (double)xbg.red/65535.0;
- bg.green = (double)xbg.green/65535.0;
- bg.blue = (double)xbg.blue/65535.0;
- bg.alpha = 1.0;
- gtk_widget_override_background_color (w, GTK_STATE_FLAG_NORMAL, &bg);
+ const char format[] = "* { background-color: #%02x%02x%02x; }";
+ /* The format is always longer than the resulting string. */
+ char buffer[sizeof format];
+ int n = snprintf(buffer, sizeof buffer, format,
+ xbg.red >> 8, xbg.green >> 8, xbg.blue >> 8);
+ eassert (n > 0);
+ eassert (n < sizeof buffer);
+ GtkCssProvider *provider = gtk_css_provider_new ();
+ gtk_css_provider_load_from_data (provider, buffer, -1, NULL);
+ gtk_style_context_add_provider (gtk_widget_get_style_context(w),
+ GTK_STYLE_PROVIDER (provider),
+ GTK_STYLE_PROVIDER_PRIORITY_APPLICATION);
+ g_clear_object (&provider);
}
#else
GdkColor bg;
@@ -1239,9 +1266,11 @@ xg_create_frame_widgets (struct frame *f)
X and GTK+ drawing to a pure GTK+ build. */
gtk_widget_set_double_buffered (wfixed, FALSE);
+#if ! GTK_CHECK_VERSION (3, 22, 0)
gtk_window_set_wmclass (GTK_WINDOW (wtop),
SSDATA (Vx_resource_name),
SSDATA (Vx_resource_class));
+#endif
/* Add callback to do nothing on WM_DELETE_WINDOW. The default in
GTK is to destroy the widget. We want Emacs to do that instead. */
@@ -1372,7 +1401,6 @@ x_wm_set_size_hint (struct frame *f, long int flags, bool user_position)
GdkGeometry size_hints;
gint hint_flags = 0;
int base_width, base_height;
- int min_rows = 0, min_cols = 0;
int win_gravity = f->win_gravity;
Lisp_Object fs_state, frame;
int scale = xg_get_scale (f);
@@ -1421,13 +1449,10 @@ x_wm_set_size_hint (struct frame *f, long int flags, bool user_position)
base_height = FRAME_TEXT_LINES_TO_PIXEL_HEIGHT (f, 1)
+ FRAME_MENUBAR_HEIGHT (f) + FRAME_TOOLBAR_HEIGHT (f);
- if (min_cols > 0) --min_cols; /* We used one col in base_width = ... 1); */
- if (min_rows > 0) --min_rows; /* We used one row in base_height = ... 1); */
-
size_hints.base_width = base_width;
size_hints.base_height = base_height;
- size_hints.min_width = base_width + min_cols * FRAME_COLUMN_WIDTH (f);
- size_hints.min_height = base_height + min_rows * FRAME_LINE_HEIGHT (f);
+ size_hints.min_width = base_width;
+ size_hints.min_height = base_height;
/* These currently have a one to one mapping with the X values, but I
don't think we should rely on that. */
@@ -1859,7 +1884,7 @@ xg_maybe_add_timer (gpointer data)
if (timespec_valid_p (next_time))
{
time_t s = next_time.tv_sec;
- int per_ms = TIMESPEC_RESOLUTION / 1000;
+ int per_ms = TIMESPEC_HZ / 1000;
int ms = (next_time.tv_nsec + per_ms - 1) / per_ms;
if (s <= ((guint) -1 - ms) / 1000)
dd->timerid = g_timeout_add (s * 1000 + ms, xg_maybe_add_timer, dd);
@@ -4111,8 +4136,10 @@ xg_set_toolkit_scroll_bar_thumb (struct scroll_bar *bar,
if (int_gtk_range_get_value (GTK_RANGE (wscroll)) != value)
gtk_range_set_value (GTK_RANGE (wscroll), (gdouble)value);
+#if ! GTK_CHECK_VERSION (3, 18, 0)
else if (changed)
gtk_adjustment_changed (adj);
+#endif
xg_ignore_gtk_scrollbar = 0;
@@ -4149,7 +4176,9 @@ xg_set_toolkit_horizontal_scroll_bar_thumb (struct scroll_bar *bar,
gtk_adjustment_configure (adj, (gdouble) value, (gdouble) lower,
(gdouble) upper, (gdouble) step_increment,
(gdouble) page_increment, (gdouble) pagesize);
+#if ! GTK_CHECK_VERSION (3, 18, 0)
gtk_adjustment_changed (adj);
+#endif
unblock_input ();
}
}
@@ -4243,23 +4272,16 @@ xg_get_page_setup (void)
eassume (false);
}
- return listn (CONSTYPE_HEAP, 7,
- Fcons (Qorientation, orientation_symbol),
-#define MAKE_FLOAT_PAGE_SETUP(f) make_float (f (page_setup, GTK_UNIT_POINTS))
- Fcons (Qwidth,
- MAKE_FLOAT_PAGE_SETUP (gtk_page_setup_get_page_width)),
- Fcons (Qheight,
- MAKE_FLOAT_PAGE_SETUP (gtk_page_setup_get_page_height)),
- Fcons (Qleft_margin,
- MAKE_FLOAT_PAGE_SETUP (gtk_page_setup_get_left_margin)),
- Fcons (Qright_margin,
- MAKE_FLOAT_PAGE_SETUP (gtk_page_setup_get_right_margin)),
- Fcons (Qtop_margin,
- MAKE_FLOAT_PAGE_SETUP (gtk_page_setup_get_top_margin)),
- Fcons (Qbottom_margin,
- MAKE_FLOAT_PAGE_SETUP (gtk_page_setup_get_bottom_margin))
-#undef MAKE_FLOAT_PAGE_SETUP
- );
+#define GETSETUP(f) make_float (f (page_setup, GTK_UNIT_POINTS))
+ return
+ list (Fcons (Qorientation, orientation_symbol),
+ Fcons (Qwidth, GETSETUP (gtk_page_setup_get_page_width)),
+ Fcons (Qheight, GETSETUP (gtk_page_setup_get_page_height)),
+ Fcons (Qleft_margin, GETSETUP (gtk_page_setup_get_left_margin)),
+ Fcons (Qright_margin, GETSETUP (gtk_page_setup_get_right_margin)),
+ Fcons (Qtop_margin, GETSETUP (gtk_page_setup_get_top_margin)),
+ Fcons (Qbottom_margin, GETSETUP (gtk_page_setup_get_bottom_margin)));
+#undef GETSETUP
}
static void
@@ -4267,7 +4289,7 @@ draw_page (GtkPrintOperation *operation, GtkPrintContext *context,
gint page_nr, gpointer user_data)
{
Lisp_Object frames = *((Lisp_Object *) user_data);
- struct frame *f = XFRAME (Fnth (make_number (page_nr), frames));
+ struct frame *f = XFRAME (Fnth (make_fixnum (page_nr), frames));
cairo_t *cr = gtk_print_context_get_cairo_context (context);
x_cr_draw_frame (cr, f);
@@ -4284,7 +4306,7 @@ xg_print_frames_dialog (Lisp_Object frames)
gtk_print_operation_set_print_settings (print, print_settings);
if (page_setup != NULL)
gtk_print_operation_set_default_page_setup (print, page_setup);
- gtk_print_operation_set_n_pages (print, XINT (Flength (frames)));
+ gtk_print_operation_set_n_pages (print, list_length (frames));
g_signal_connect (print, "draw-page", G_CALLBACK (draw_page), &frames);
res = gtk_print_operation_run (print, GTK_PRINT_OPERATION_ACTION_PRINT_DIALOG,
NULL, NULL);
@@ -4755,9 +4777,15 @@ xg_tool_item_stale_p (GtkWidget *wbutton, const char *stock_name,
{
gpointer gold_img = g_object_get_data (G_OBJECT (wimage),
XG_TOOL_BAR_IMAGE_DATA);
+#if defined USE_CAIRO && GTK_CHECK_VERSION (3, 10, 0)
+ void *old_img = (void *) gold_img;
+ if (old_img != img->cr_data)
+ return 1;
+#else
Pixmap old_img = (Pixmap) gold_img;
if (old_img != img->pixmap)
return 1;
+#endif
}
/* Check button configuration and label. */
@@ -4877,18 +4905,18 @@ update_frame_tool_bar (struct frame *f)
block_input ();
- if (RANGED_INTEGERP (1, Vtool_bar_button_margin, INT_MAX))
+ if (RANGED_FIXNUMP (1, Vtool_bar_button_margin, INT_MAX))
{
- hmargin = XFASTINT (Vtool_bar_button_margin);
- vmargin = XFASTINT (Vtool_bar_button_margin);
+ hmargin = XFIXNAT (Vtool_bar_button_margin);
+ vmargin = XFIXNAT (Vtool_bar_button_margin);
}
else if (CONSP (Vtool_bar_button_margin))
{
- if (RANGED_INTEGERP (1, XCAR (Vtool_bar_button_margin), INT_MAX))
- hmargin = XFASTINT (XCAR (Vtool_bar_button_margin));
+ if (RANGED_FIXNUMP (1, XCAR (Vtool_bar_button_margin), INT_MAX))
+ hmargin = XFIXNAT (XCAR (Vtool_bar_button_margin));
- if (RANGED_INTEGERP (1, XCDR (Vtool_bar_button_margin), INT_MAX))
- vmargin = XFASTINT (XCDR (Vtool_bar_button_margin));
+ if (RANGED_FIXNUMP (1, XCDR (Vtool_bar_button_margin), INT_MAX))
+ vmargin = XFIXNAT (XCDR (Vtool_bar_button_margin));
}
/* The natural size (i.e. when GTK uses 0 as margin) looks best,
@@ -5049,7 +5077,13 @@ update_frame_tool_bar (struct frame *f)
img = IMAGE_FROM_ID (f, img_id);
prepare_image_for_display (f, img);
- if (img->load_failed_p || img->pixmap == None)
+ if (img->load_failed_p
+#if defined USE_CAIRO && GTK_CHECK_VERSION (3, 10, 0)
+ || img->cr_data == NULL
+#else
+ || img->pixmap == None
+#endif
+ )
{
if (ti)
gtk_container_remove (GTK_CONTAINER (wtoolbar),
@@ -5099,7 +5133,12 @@ update_frame_tool_bar (struct frame *f)
{
w = xg_get_image_for_pixmap (f, img, x->widget, NULL);
g_object_set_data (G_OBJECT (w), XG_TOOL_BAR_IMAGE_DATA,
- (gpointer)img->pixmap);
+#if defined USE_CAIRO && GTK_CHECK_VERSION (3, 10, 0)
+ (gpointer)img->cr_data
+#else
+ (gpointer)img->pixmap
+#endif
+ );
}
#if GTK_CHECK_VERSION (3, 14, 0)
@@ -5309,7 +5348,9 @@ xg_initialize (void)
x_last_font_name = NULL;
#endif
+#ifdef HAVE_XWIDGETS
xg_gtk_initialized = true;
+#endif
}
#endif /* USE_GTK */
diff --git a/src/image.c b/src/image.c
index 50515e1a422..6e415ef1f70 100644
--- a/src/image.c
+++ b/src/image.c
@@ -46,6 +46,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "coding.h"
#include "termhooks.h"
#include "font.h"
+#include "pdumper.h"
#ifdef HAVE_SYS_STAT_H
#include <sys/stat.h>
@@ -77,6 +78,7 @@ typedef struct x_bitmap_record Bitmap_Record;
/* We need (or want) w32.h only when we're _not_ compiling for Cygwin. */
#ifdef WINDOWSNT
+# include "w32common.h"
# include "w32.h"
#endif
@@ -322,7 +324,7 @@ x_create_bitmap_from_file (struct frame *f, Lisp_Object file)
/* Search bitmap-file-path for the file, if appropriate. */
if (openp (Vx_bitmap_file_path, file, Qnil, &found,
- make_number (R_OK), false)
+ make_fixnum (R_OK), false)
< 0)
return -1;
@@ -407,8 +409,13 @@ x_destroy_all_bitmaps (Display_Info *dpyinfo)
dpyinfo->bitmaps_last = 0;
}
+#ifndef HAVE_XRENDER
+/* Required for the definition of x_create_x_image_and_pixmap below. */
+typedef void Picture;
+#endif
+
static bool x_create_x_image_and_pixmap (struct frame *, int, int, int,
- XImagePtr *, Pixmap *);
+ XImagePtr *, Pixmap *, Picture *);
static void x_destroy_x_image (XImagePtr ximg);
#ifdef HAVE_NTGUI
@@ -471,7 +478,8 @@ x_create_bitmap_mask (struct frame *f, ptrdiff_t id)
return;
}
- result = x_create_x_image_and_pixmap (f, width, height, 1, &mask_img, &mask);
+ result = x_create_x_image_and_pixmap (f, width, height, 1,
+ &mask_img, &mask, NULL);
unblock_input ();
if (!result)
@@ -524,6 +532,33 @@ x_create_bitmap_mask (struct frame *f, ptrdiff_t id)
Image types
***********************************************************************/
+/* Each image format (JPEG, TIFF, ...) supported is described by
+ a structure of the type below. */
+
+struct image_type
+{
+ /* Index of a symbol uniquely identifying the image type, e.g., 'jpeg'. */
+ int type;
+
+ /* Check that SPEC is a valid image specification for the given
+ image type. Value is true if SPEC is valid. */
+ bool (*valid_p) (Lisp_Object spec);
+
+ /* Load IMG which is used on frame F from information contained in
+ IMG->spec. Value is true if successful. */
+ bool (*load) (struct frame *f, struct image *img);
+
+ /* Free resources of image IMG which is used on frame F. */
+ void (*free) (struct frame *f, struct image *img);
+
+ /* Initialization function (used for dynamic loading of image
+ libraries on Windows), or NULL if none. */
+ bool (*init) (void);
+
+ /* Next in list of all supported image types. */
+ struct image_type *next;
+};
+
/* List of supported image types. Use define_image_type to add new
types. Use lookup_image_type to find a type for a given symbol. */
@@ -761,23 +796,23 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords,
break;
case IMAGE_POSITIVE_INTEGER_VALUE:
- if (! RANGED_INTEGERP (1, value, INT_MAX))
+ if (! RANGED_FIXNUMP (1, value, INT_MAX))
return 0;
break;
case IMAGE_NON_NEGATIVE_INTEGER_VALUE_OR_PAIR:
- if (RANGED_INTEGERP (0, value, INT_MAX))
+ if (RANGED_FIXNUMP (0, value, INT_MAX))
break;
if (CONSP (value)
- && RANGED_INTEGERP (0, XCAR (value), INT_MAX)
- && RANGED_INTEGERP (0, XCDR (value), INT_MAX))
+ && RANGED_FIXNUMP (0, XCAR (value), INT_MAX)
+ && RANGED_FIXNUMP (0, XCDR (value), INT_MAX))
break;
return 0;
case IMAGE_ASCENT_VALUE:
if (SYMBOLP (value) && EQ (value, Qcenter))
break;
- else if (RANGED_INTEGERP (0, value, 100))
+ else if (RANGED_FIXNUMP (0, value, 100))
break;
return 0;
@@ -785,7 +820,7 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords,
/* Unlike the other integer-related cases, this one does not
verify that VALUE fits in 'int'. This is because callers
want EMACS_INT. */
- if (!INTEGERP (value) || XINT (value) < 0)
+ if (!FIXNUMP (value) || XFIXNUM (value) < 0)
return 0;
break;
@@ -804,7 +839,7 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords,
break;
case IMAGE_INTEGER_VALUE:
- if (! TYPE_RANGED_INTEGERP (int, value))
+ if (! TYPE_RANGED_FIXNUMP (int, value))
return 0;
break;
@@ -883,7 +918,7 @@ or omitted means use the selected frame. */)
size = Fcons (make_float ((double) width / FRAME_COLUMN_WIDTH (f)),
make_float ((double) height / FRAME_LINE_HEIGHT (f)));
else
- size = Fcons (make_number (width), make_number (height));
+ size = Fcons (make_fixnum (width), make_fixnum (height));
}
else
error ("Invalid image specification");
@@ -983,6 +1018,13 @@ free_image (struct frame *f, struct image *img)
c->images[img->id] = NULL;
+#ifdef HAVE_XRENDER
+ if (img->picture)
+ XRenderFreePicture (FRAME_X_DISPLAY (f), img->picture);
+ if (img->mask_picture)
+ XRenderFreePicture (FRAME_X_DISPLAY (f), img->mask_picture);
+#endif
+
/* Windows NT redefines 'free', but in this file, we need to
avoid the redefinition. */
#ifdef WINDOWSNT
@@ -1004,9 +1046,9 @@ check_image_size (struct frame *f, int width, int height)
if (width <= 0 || height <= 0)
return 0;
- if (INTEGERP (Vmax_image_size))
- return (width <= XINT (Vmax_image_size)
- && height <= XINT (Vmax_image_size));
+ if (FIXNUMP (Vmax_image_size))
+ return (width <= XFIXNUM (Vmax_image_size)
+ && height <= XFIXNUM (Vmax_image_size));
else if (FLOATP (Vmax_image_size))
{
if (f != NULL)
@@ -1115,24 +1157,22 @@ get_spec_bg_or_alpha_as_argb (struct image *img,
return bgcolor;
}
-static void
-create_cairo_image_surface (struct image *img,
- unsigned char *data,
- int width,
- int height)
+static cairo_surface_t *
+create_cairo_image_surface (int width, int height)
{
- cairo_surface_t *surface;
cairo_format_t format = CAIRO_FORMAT_ARGB32;
- int stride = cairo_format_stride_for_width (format, width);
- surface = cairo_image_surface_create_for_data (data,
- format,
- width,
- height,
- stride);
- img->width = width;
- img->height = height;
+ eassert (cairo_format_stride_for_width (format, width) == width * 4);
+
+ return cairo_image_surface_create (format, width, height);
+}
+
+static void
+set_cairo_image_surface (struct image *img, cairo_surface_t *surface)
+{
+ cairo_surface_mark_dirty (surface);
+ img->width = cairo_image_surface_get_width (surface);
+ img->height = cairo_image_surface_get_height (surface);
img->cr_data = surface;
- img->cr_data2 = data;
img->pixmap = 0;
}
#endif
@@ -1362,7 +1402,6 @@ x_clear_image (struct frame *f, struct image *img)
#ifdef USE_CAIRO
if (img->cr_data)
cairo_surface_destroy ((cairo_surface_t *)img->cr_data);
- if (img->cr_data2) xfree (img->cr_data2);
#endif
x_clear_image_1 (f, img,
CLEAR_IMAGE_PIXMAP | CLEAR_IMAGE_MASK | CLEAR_IMAGE_COLORS);
@@ -1512,7 +1551,7 @@ clear_image_cache (struct frame *f, Lisp_Object filter)
{
struct image_cache *c = FRAME_IMAGE_CACHE (f);
- if (c)
+ if (c && !f->inhibit_clear_image_cache)
{
ptrdiff_t i, nfreed = 0;
@@ -1534,7 +1573,7 @@ clear_image_cache (struct frame *f, Lisp_Object filter)
}
}
}
- else if (INTEGERP (Vimage_cache_eviction_delay))
+ else if (FIXNUMP (Vimage_cache_eviction_delay))
{
/* Free cache based on timestamp. */
struct timespec old, t;
@@ -1547,7 +1586,7 @@ clear_image_cache (struct frame *f, Lisp_Object filter)
/* If the number of cached images has grown unusually large,
decrease the cache eviction delay (Bug#6230). */
- delay = XINT (Vimage_cache_eviction_delay);
+ delay = XFIXNUM (Vimage_cache_eviction_delay);
if (nimages > 40)
delay = 1600 * delay / nimages / nimages;
delay = max (delay, 1);
@@ -1610,7 +1649,7 @@ Anything else, means only clear those images which refer to FILTER,
which is then usually a filename. */)
(Lisp_Object filter)
{
- if (!(EQ (filter, Qnil) || FRAMEP (filter)))
+ if (! (NILP (filter) || FRAMEP (filter)))
clear_image_caches (filter);
else
clear_image_cache (decode_window_system_frame (filter), Qt);
@@ -1719,6 +1758,157 @@ postprocess_image (struct frame *f, struct image *img)
}
}
+#if defined (HAVE_IMAGEMAGICK) || defined (HAVE_NATIVE_SCALING)
+/* Scale an image size by returning SIZE / DIVISOR * MULTIPLIER,
+ safely rounded and clipped to int range. */
+
+static int
+scale_image_size (int size, size_t divisor, size_t multiplier)
+{
+ if (divisor != 0)
+ {
+ double s = size;
+ double scaled = s * multiplier / divisor + 0.5;
+ if (scaled < INT_MAX)
+ return scaled;
+ }
+ return INT_MAX;
+}
+
+/* Compute the desired size of an image with native size WIDTH x HEIGHT.
+ Use SPEC to deduce the size. Store the desired size into
+ *D_WIDTH x *D_HEIGHT. Store -1 x -1 if the native size is OK. */
+static void
+compute_image_size (size_t width, size_t height,
+ Lisp_Object spec,
+ int *d_width, int *d_height)
+{
+ Lisp_Object value;
+ int desired_width = -1, desired_height = -1, max_width = -1, max_height = -1;
+ double scale = 1;
+
+ value = image_spec_value (spec, QCscale, NULL);
+ if (NUMBERP (value))
+ scale = XFLOATINT (value);
+
+ value = image_spec_value (spec, QCmax_width, NULL);
+ if (FIXNATP (value))
+ max_width = min (XFIXNAT (value), INT_MAX);
+
+ value = image_spec_value (spec, QCmax_height, NULL);
+ if (FIXNATP (value))
+ max_height = min (XFIXNAT (value), INT_MAX);
+
+ /* If width and/or height is set in the display spec assume we want
+ to scale to those values. If either h or w is unspecified, the
+ unspecified should be calculated from the specified to preserve
+ aspect ratio. */
+ value = image_spec_value (spec, QCwidth, NULL);
+ if (FIXNATP (value))
+ {
+ desired_width = min (XFIXNAT (value) * scale, INT_MAX);
+ /* :width overrides :max-width. */
+ max_width = -1;
+ }
+
+ value = image_spec_value (spec, QCheight, NULL);
+ if (FIXNATP (value))
+ {
+ desired_height = min (XFIXNAT (value) * scale, INT_MAX);
+ /* :height overrides :max-height. */
+ max_height = -1;
+ }
+
+ /* If we have both width/height set explicitly, we skip past all the
+ aspect ratio-preserving computations below. */
+ if (desired_width != -1 && desired_height != -1)
+ goto out;
+
+ width = width * scale;
+ height = height * scale;
+
+ if (desired_width != -1)
+ /* Width known, calculate height. */
+ desired_height = scale_image_size (desired_width, width, height);
+ else if (desired_height != -1)
+ /* Height known, calculate width. */
+ desired_width = scale_image_size (desired_height, height, width);
+ else
+ {
+ desired_width = width;
+ desired_height = height;
+ }
+
+ if (max_width != -1 && desired_width > max_width)
+ {
+ /* The image is wider than :max-width. */
+ desired_width = max_width;
+ desired_height = scale_image_size (desired_width, width, height);
+ }
+
+ if (max_height != -1 && desired_height > max_height)
+ {
+ /* The image is higher than :max-height. */
+ desired_height = max_height;
+ desired_width = scale_image_size (desired_height, height, width);
+ }
+
+ out:
+ *d_width = desired_width;
+ *d_height = desired_height;
+}
+#endif /* HAVE_IMAGEMAGICK || HAVE_NATIVE_SCALING */
+
+static void
+x_set_image_size (struct frame *f, struct image *img)
+{
+#ifdef HAVE_NATIVE_SCALING
+# ifdef HAVE_IMAGEMAGICK
+ /* ImageMagick images are already the correct size. */
+ if (EQ (image_spec_value (img->spec, QCtype, NULL), Qimagemagick))
+ return;
+# endif
+
+ int width, height;
+ compute_image_size (img->width, img->height, img->spec, &width, &height);
+
+# ifdef HAVE_NS
+ ns_image_set_size (img->pixmap, width, height);
+ img->width = width;
+ img->height = height;
+# endif
+
+# ifdef USE_CAIRO
+ img->width = width;
+ img->height = height;
+# elif defined HAVE_XRENDER
+ if (img->picture)
+ {
+ double xscale = img->width / (double) width;
+ double yscale = img->height / (double) height;
+
+ XTransform tmat
+ = {{{XDoubleToFixed (xscale), XDoubleToFixed (0), XDoubleToFixed (0)},
+ {XDoubleToFixed (0), XDoubleToFixed (yscale), XDoubleToFixed (0)},
+ {XDoubleToFixed (0), XDoubleToFixed (0), XDoubleToFixed (1)}}};
+
+ XRenderSetPictureFilter (FRAME_X_DISPLAY (f), img->picture, FilterBest,
+ 0, 0);
+ XRenderSetPictureTransform (FRAME_X_DISPLAY (f), img->picture, &tmat);
+
+ img->width = width;
+ img->height = height;
+ }
+# endif
+# ifdef HAVE_NTGUI
+ /* Under HAVE_NTGUI, we will scale the image on the fly, when we
+ draw it. See w32term.c:x_draw_image_foreground. */
+ img->width = width;
+ img->height = height;
+# endif
+#endif
+}
+
/* Return the id of image with Lisp specification SPEC on frame F.
SPEC must be a valid Lisp image specification (see valid_image_p). */
@@ -1761,11 +1951,11 @@ lookup_image (struct frame *f, Lisp_Object spec)
Lisp_Object value;
value = image_spec_value (spec, QCwidth, NULL);
- img->width = (INTEGERP (value)
- ? XFASTINT (value) : DEFAULT_IMAGE_WIDTH);
+ img->width = (FIXNUMP (value)
+ ? XFIXNAT (value) : DEFAULT_IMAGE_WIDTH);
value = image_spec_value (spec, QCheight, NULL);
- img->height = (INTEGERP (value)
- ? XFASTINT (value) : DEFAULT_IMAGE_HEIGHT);
+ img->height = (FIXNUMP (value)
+ ? XFIXNAT (value) : DEFAULT_IMAGE_HEIGHT);
}
else
{
@@ -1774,27 +1964,28 @@ lookup_image (struct frame *f, Lisp_Object spec)
`:background COLOR'. */
Lisp_Object ascent, margin, relief, bg;
int relief_bound;
+ x_set_image_size (f, img);
ascent = image_spec_value (spec, QCascent, NULL);
- if (INTEGERP (ascent))
- img->ascent = XFASTINT (ascent);
+ if (FIXNUMP (ascent))
+ img->ascent = XFIXNAT (ascent);
else if (EQ (ascent, Qcenter))
img->ascent = CENTERED_IMAGE_ASCENT;
margin = image_spec_value (spec, QCmargin, NULL);
- if (INTEGERP (margin))
- img->vmargin = img->hmargin = XFASTINT (margin);
+ if (FIXNUMP (margin))
+ img->vmargin = img->hmargin = XFIXNAT (margin);
else if (CONSP (margin))
{
- img->hmargin = XFASTINT (XCAR (margin));
- img->vmargin = XFASTINT (XCDR (margin));
+ img->hmargin = XFIXNAT (XCAR (margin));
+ img->vmargin = XFIXNAT (XCDR (margin));
}
relief = image_spec_value (spec, QCrelief, NULL);
relief_bound = INT_MAX - max (img->hmargin, img->vmargin);
- if (RANGED_INTEGERP (- relief_bound, relief, relief_bound))
+ if (RANGED_FIXNUMP (- relief_bound, relief, relief_bound))
{
- img->relief = XINT (relief);
+ img->relief = XFIXNUM (relief);
img->hmargin += eabs (img->relief);
img->vmargin += eabs (img->relief);
}
@@ -1948,7 +2139,7 @@ x_check_image_size (XImagePtr ximg, int width, int height)
static bool
x_create_x_image_and_pixmap (struct frame *f, int width, int height, int depth,
- XImagePtr *ximg, Pixmap *pixmap)
+ XImagePtr *ximg, Pixmap *pixmap, Picture *picture)
{
#ifdef HAVE_X_WINDOWS
Display *display = FRAME_X_DISPLAY (f);
@@ -1973,7 +2164,7 @@ x_create_x_image_and_pixmap (struct frame *f, int width, int height, int depth,
x_destroy_x_image (*ximg);
*ximg = NULL;
image_error ("Image too large (%dx%d)",
- make_number (width), make_number (height));
+ make_fixnum (width), make_fixnum (height));
return 0;
}
@@ -1990,6 +2181,36 @@ x_create_x_image_and_pixmap (struct frame *f, int width, int height, int depth,
return 0;
}
+# ifdef HAVE_XRENDER
+ int event_basep, error_basep;
+ if (picture && XRenderQueryExtension (display, &event_basep, &error_basep))
+ {
+ if (depth == 32 || depth == 24 || depth == 8)
+ {
+ XRenderPictFormat *format;
+ XRenderPictureAttributes attr;
+
+ /* FIXME: Do we need to handle all possible bit depths?
+ XRenderFindStandardFormat supports PictStandardARGB32,
+ PictStandardRGB24, PictStandardA8, PictStandardA4,
+ PictStandardA1, and PictStandardNUM (what is this?!).
+
+ XRenderFindFormat may support more, but I don't
+ understand the documentation. */
+ format = XRenderFindStandardFormat (display,
+ depth == 32 ? PictStandardARGB32
+ : depth == 24 ? PictStandardRGB24
+ : PictStandardA8);
+ *picture = XRenderCreatePicture (display, *pixmap, format, 0, &attr);
+ }
+ else
+ {
+ image_error ("Specified image bit depth is not supported by XRender");
+ *picture = 0;
+ }
+ }
+# endif
+
return 1;
#endif /* HAVE_X_WINDOWS */
@@ -2135,7 +2356,8 @@ x_put_x_image (struct frame *f, XImagePtr ximg, Pixmap pixmap, int width, int he
eassert (input_blocked_p ());
gc = XCreateGC (FRAME_X_DISPLAY (f), pixmap, 0, NULL);
- XPutImage (FRAME_X_DISPLAY (f), pixmap, gc, ximg, 0, 0, 0, 0, width, height);
+ XPutImage (FRAME_X_DISPLAY (f), pixmap, gc, ximg, 0, 0, 0, 0,
+ ximg->width, ximg->height);
XFreeGC (FRAME_X_DISPLAY (f), gc);
#endif /* HAVE_X_WINDOWS */
@@ -2163,8 +2385,13 @@ image_create_x_image_and_pixmap (struct frame *f, struct image *img,
{
eassert ((!mask_p ? img->pixmap : img->mask) == NO_PIXMAP);
+ Picture *picture = NULL;
+#ifdef HAVE_XRENDER
+ picture = !mask_p ? &img->picture : &img->mask_picture;
+#endif
return x_create_x_image_and_pixmap (f, width, height, depth, ximg,
- !mask_p ? &img->pixmap : &img->mask);
+ !mask_p ? &img->pixmap : &img->mask,
+ picture);
}
/* Put X image XIMG into image IMG on frame F, as a mask if and only
@@ -2306,16 +2533,16 @@ x_find_image_fd (Lisp_Object file, int *pfd)
/* Try to find FILE in data-directory/images, then x-bitmap-file-path. */
fd = openp (search_path, file, Qnil, &file_found,
- pfd ? Qt : make_number (R_OK), false);
+ pfd ? Qt : make_fixnum (R_OK), false);
if (fd >= 0 || fd == -2)
{
file_found = ENCODE_FILE (file_found);
if (fd == -2)
{
- /* The file exists locally, but has a file handler. (This
- happens, e.g., under Auto Image File Mode.) 'openp'
- didn't open the file, so we should, because the caller
- expects that. */
+ /* The file exists locally, but has a file name handler.
+ (This happens, e.g., under Auto Image File Mode.)
+ 'openp' didn't open the file, so we should, because the
+ caller expects that. */
fd = emacs_open (SSDATA (file_found), O_RDONLY, 0);
}
}
@@ -2512,8 +2739,8 @@ xbm_image_p (Lisp_Object object)
return 0;
data = kw[XBM_DATA].value;
- width = XFASTINT (kw[XBM_WIDTH].value);
- height = XFASTINT (kw[XBM_HEIGHT].value);
+ width = XFIXNAT (kw[XBM_WIDTH].value);
+ height = XFIXNAT (kw[XBM_HEIGHT].value);
/* Check type of data, and width and height against contents of
data. */
@@ -2875,7 +3102,7 @@ xbm_read_bitmap_data (struct frame *f, char *contents, char *end,
{
if (!inhibit_image_error)
image_error ("Image too large (%dx%d)",
- make_number (*width), make_number (*height));
+ make_fixnum (*width), make_fixnum (*height));
goto failure;
}
bytes_per_line = (*width + 7) / 8 + padding_p;
@@ -3061,8 +3288,8 @@ xbm_load (struct frame *f, struct image *img)
/* Get specified width, and height. */
if (!in_memory_file_p)
{
- img->width = XFASTINT (fmt[XBM_WIDTH].value);
- img->height = XFASTINT (fmt[XBM_HEIGHT].value);
+ img->width = XFIXNAT (fmt[XBM_WIDTH].value);
+ img->height = XFIXNAT (fmt[XBM_HEIGHT].value);
eassert (img->width > 0 && img->height > 0);
if (!check_image_size (f, img->width, img->height))
{
@@ -3740,9 +3967,9 @@ xpm_load (struct frame *f, struct image *img)
{
int width = img->ximg->width;
int height = img->ximg->height;
- void *data = xmalloc (width * height * 4);
+ cairo_surface_t *surface = create_cairo_image_surface (width, height);
int i;
- uint32_t *od = data;
+ uint32_t *od = (uint32_t *) cairo_image_surface_get_data (surface);
uint32_t *id = (uint32_t *) img->ximg->data;
char *mid = img->mask_img ? img->mask_img->data : 0;
uint32_t bgcolor = get_spec_bg_or_alpha_as_argb (img, f);
@@ -3761,7 +3988,7 @@ xpm_load (struct frame *f, struct image *img)
}
}
- create_cairo_image_surface (img, data, width, height);
+ set_cairo_image_surface (img, surface);
}
else
{
@@ -4000,7 +4227,7 @@ xpm_make_color_table_v (void (**put_func) (Lisp_Object, const char *, int,
{
*put_func = xpm_put_color_table_v;
*get_func = xpm_get_color_table_v;
- return Fmake_vector (make_number (256), Qnil);
+ return make_nil_vector (256);
}
static void
@@ -4168,7 +4395,7 @@ xpm_load_image (struct frame *f,
if (!NILP (Fxw_display_color_p (frame)))
best_key = XPM_COLOR_KEY_C;
else if (!NILP (Fx_display_grayscale_p (frame)))
- best_key = (XFASTINT (Fx_display_planes (frame)) > 2
+ best_key = (XFIXNAT (Fx_display_planes (frame)) > 2
? XPM_COLOR_KEY_G : XPM_COLOR_KEY_G4);
else
best_key = XPM_COLOR_KEY_M;
@@ -4239,7 +4466,7 @@ xpm_load_image (struct frame *f,
color_val = Qt;
else if (x_defined_color (f, SSDATA (XCDR (specified_color)),
&cdef, 0))
- color_val = make_number (cdef.pixel);
+ color_val = make_fixnum (cdef.pixel);
}
}
if (NILP (color_val) && max_key > 0)
@@ -4247,7 +4474,7 @@ xpm_load_image (struct frame *f,
if (xstrcasecmp (max_color, "None") == 0)
color_val = Qt;
else if (x_defined_color (f, max_color, &cdef, 0))
- color_val = make_number (cdef.pixel);
+ color_val = make_fixnum (cdef.pixel);
}
if (!NILP (color_val))
(*put_color_table) (color_table, beg, chars_per_pixel, color_val);
@@ -4267,7 +4494,7 @@ xpm_load_image (struct frame *f,
(*get_color_table) (color_table, str, chars_per_pixel);
XPutPixel (ximg, x, y,
- (INTEGERP (color_val) ? XINT (color_val)
+ (FIXNUMP (color_val) ? XFIXNUM (color_val)
: FRAME_FOREGROUND_PIXEL (f)));
#ifndef HAVE_NS
XPutPixel (mask_img, x, y,
@@ -4939,7 +5166,7 @@ x_edge_detection (struct frame *f, struct image *img, Lisp_Object matrix,
}
if (NILP (color_adjust))
- color_adjust = make_number (0xffff / 2);
+ color_adjust = make_fixnum (0xffff / 2);
if (i == 9 && NUMBERP (color_adjust))
x_detect_edges (f, img, trans, XFLOATINT (color_adjust));
@@ -5093,9 +5320,9 @@ x_build_heuristic_mask (struct frame *f, struct image *img, Lisp_Object how)
{
int rgb[3], i;
- for (i = 0; i < 3 && CONSP (how) && NATNUMP (XCAR (how)); ++i)
+ for (i = 0; i < 3 && CONSP (how) && FIXNATP (XCAR (how)); ++i)
{
- rgb[i] = XFASTINT (XCAR (how)) & 0xffff;
+ rgb[i] = XFIXNAT (XCAR (how)) & 0xffff;
how = XCDR (how);
}
@@ -5398,8 +5625,8 @@ pbm_load (struct frame *f, struct image *img)
height = pbm_scan_number (&p, end);
#ifdef USE_CAIRO
- void *data = xmalloc (width * height * 4);
- uint32_t *dataptr = data;
+ cairo_surface_t *surface = create_cairo_image_surface (width, height);
+ uint32_t *dataptr = (uint32_t *) cairo_image_surface_get_data (surface);
#endif
if (type != PBM_MONO)
@@ -5483,7 +5710,7 @@ pbm_load (struct frame *f, struct image *img)
if (p >= end)
{
#ifdef USE_CAIRO
- xfree (data);
+ cairo_surface_destroy (surface);
#else
x_destroy_x_image (ximg);
#endif
@@ -5529,7 +5756,7 @@ pbm_load (struct frame *f, struct image *img)
if (raw_p && p + expected_size > end)
{
#ifdef USE_CAIRO
- xfree (data);
+ cairo_surface_destroy (surface);
#else
x_destroy_x_image (ximg);
#endif
@@ -5563,7 +5790,7 @@ pbm_load (struct frame *f, struct image *img)
if (r < 0 || g < 0 || b < 0)
{
#ifdef USE_CAIRO
- xfree (data);
+ cairo_surface_destroy (surface);
#else
x_destroy_x_image (ximg);
#endif
@@ -5600,7 +5827,7 @@ pbm_load (struct frame *f, struct image *img)
/* Maybe fill in the background field while we have ximg handy. */
#ifdef USE_CAIRO
- create_cairo_image_surface (img, data, width, height);
+ set_cairo_image_surface (img, surface);
#else
if (NILP (image_spec_value (img->spec, QCbackground, NULL)))
/* Casting avoids a GCC warning. */
@@ -5734,7 +5961,7 @@ DEF_DLL_FN (void, png_read_end, (png_structp, png_infop));
DEF_DLL_FN (void, png_error, (png_structp, png_const_charp));
# if (PNG_LIBPNG_VER >= 10500)
-DEF_DLL_FN (void, png_longjmp, (png_structp, int)) PNG_NORETURN;
+DEF_DLL_FN (void, png_longjmp, (png_structp, int) PNG_NORETURN);
DEF_DLL_FN (jmp_buf *, png_set_longjmp_fn,
(png_structp, png_longjmp_ptr, size_t));
# endif /* libpng version >= 1.5 */
@@ -5946,7 +6173,7 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c)
ptrdiff_t nbytes;
#ifdef USE_CAIRO
- unsigned char *data = 0;
+ cairo_surface_t *surface;
uint32_t *dataptr;
#else
XImagePtr ximg, mask_img = NULL;
@@ -6161,8 +6388,8 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c)
}
#ifdef USE_CAIRO
- data = (unsigned char *) xmalloc (width * height * 4);
- dataptr = (uint32_t *) data;
+ surface = create_cairo_image_surface (width, height);
+ dataptr = (uint32_t *) cairo_image_surface_get_data (surface);
#else
/* Create an image and pixmap serving as mask if the PNG image
contains an alpha channel. */
@@ -6253,7 +6480,7 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c)
img->height = height;
#ifdef USE_CAIRO
- create_cairo_image_surface (img, data, width, height);
+ set_cairo_image_surface (img, surface);
#else
/* Maybe fill in the background field while we have ximg handy.
Casting avoids a GCC warning. */
@@ -6857,8 +7084,8 @@ jpeg_load_body (struct frame *f, struct image *img,
JPOOL_IMAGE, row_stride, 1);
#ifdef USE_CAIRO
{
- unsigned char *data = (unsigned char *) xmalloc (width*height*4);
- uint32_t *dataptr = (uint32_t *) data;
+ cairo_surface_t *surface = create_cairo_image_surface (width, height);
+ uint32_t *dataptr = (uint32_t *) cairo_image_surface_get_data (surface);
int r, g, b;
for (y = 0; y < height; ++y)
@@ -6875,7 +7102,7 @@ jpeg_load_body (struct frame *f, struct image *img,
}
}
- create_cairo_image_surface (img, data, width, height);
+ set_cairo_image_surface (img, surface);
}
#else
for (y = 0; y < height; ++y)
@@ -7280,9 +7507,9 @@ tiff_load (struct frame *f, struct image *img)
}
image = image_spec_value (img->spec, QCindex, NULL);
- if (INTEGERP (image))
+ if (FIXNUMP (image))
{
- EMACS_INT ino = XFASTINT (image);
+ EMACS_INT ino = XFIXNAT (image);
if (! (TYPE_MINIMUM (tdir_t) <= ino && ino <= TYPE_MAXIMUM (tdir_t)
&& TIFFSetDirectory (tiff, ino)))
{
@@ -7324,7 +7551,7 @@ tiff_load (struct frame *f, struct image *img)
if (count > 1)
img->lisp_data = Fcons (Qcount,
- Fcons (make_number (count),
+ Fcons (make_fixnum (count),
img->lisp_data));
TIFFClose (tiff);
@@ -7337,8 +7564,8 @@ tiff_load (struct frame *f, struct image *img)
#ifdef USE_CAIRO
{
- unsigned char *data = (unsigned char *) xmalloc (width*height*4);
- uint32_t *dataptr = (uint32_t *) data;
+ cairo_surface_t *surface = create_cairo_image_surface (width, height);
+ uint32_t *dataptr = (uint32_t *) cairo_image_surface_get_data (surface);
for (y = 0; y < height; ++y)
{
@@ -7354,7 +7581,7 @@ tiff_load (struct frame *f, struct image *img)
}
}
- create_cairo_image_surface (img, data, width, height);
+ set_cairo_image_surface (img, surface);
}
#else
/* Initialize the color table. */
@@ -7746,7 +7973,7 @@ gif_load (struct frame *f, struct image *img)
/* Which sub-image are we to display? */
{
Lisp_Object image_number = image_spec_value (img->spec, QCindex, NULL);
- idx = INTEGERP (image_number) ? XFASTINT (image_number) : 0;
+ idx = FIXNUMP (image_number) ? XFIXNAT (image_number) : 0;
if (idx < 0 || idx >= gif->ImageCount)
{
image_error ("Invalid image number `%s' in image `%s'",
@@ -7793,9 +8020,8 @@ gif_load (struct frame *f, struct image *img)
}
#ifdef USE_CAIRO
- /* xzalloc so data is zero => transparent */
- void *data = xzalloc (width * height * 4);
- uint32_t *data32 = data;
+ cairo_surface_t *surface = create_cairo_image_surface (width, height);
+ uint32_t *data32 = (uint32_t *) cairo_image_surface_get_data (surface);
if (STRINGP (specified_bg))
{
XColor color;
@@ -7942,7 +8168,7 @@ gif_load (struct frame *f, struct image *img)
{
#ifdef USE_CAIRO
uint32_t *dataptr =
- (data32 + ((row + subimg_top) * subimg_width
+ (data32 + ((row + subimg_top) * width
+ x + subimg_left));
int r = gif_color_map->Colors[c].Red;
int g = gif_color_map->Colors[c].Green;
@@ -7954,7 +8180,7 @@ gif_load (struct frame *f, struct image *img)
XPutPixel (ximg, x + subimg_left, row + subimg_top,
pixel_colors[c]);
#endif
- }
+ }
}
}
}
@@ -7968,7 +8194,7 @@ gif_load (struct frame *f, struct image *img)
{
#ifdef USE_CAIRO
uint32_t *dataptr =
- (data32 + ((y + subimg_top) * subimg_width
+ (data32 + ((y + subimg_top) * width
+ x + subimg_left));
int r = gif_color_map->Colors[c].Red;
int g = gif_color_map->Colors[c].Green;
@@ -8000,7 +8226,7 @@ gif_load (struct frame *f, struct image *img)
/* Append (... FUNCTION "BYTES") */
{
img->lisp_data
- = Fcons (make_number (ext->Function),
+ = Fcons (make_fixnum (ext->Function),
Fcons (make_unibyte_string ((char *) ext->Bytes,
ext->ByteCount),
img->lisp_data));
@@ -8021,7 +8247,7 @@ gif_load (struct frame *f, struct image *img)
if (gif->ImageCount > 1)
img->lisp_data = Fcons (Qcount,
- Fcons (make_number (gif->ImageCount),
+ Fcons (make_fixnum (gif->ImageCount),
img->lisp_data));
if (gif_close (gif, &gif_err) == GIF_ERROR)
@@ -8038,7 +8264,7 @@ gif_load (struct frame *f, struct image *img)
}
#ifdef USE_CAIRO
- create_cairo_image_surface (img, data, width, height);
+ set_cairo_image_surface (img, surface);
#else
/* Maybe fill in the background field while we have ximg handy. */
if (NILP (image_spec_value (img->spec, QCbackground, NULL)))
@@ -8073,105 +8299,6 @@ gif_load (struct frame *f, struct image *img)
ImageMagick
***********************************************************************/
-/* Scale an image size by returning SIZE / DIVISOR * MULTIPLIER,
- safely rounded and clipped to int range. */
-
-static int
-scale_image_size (int size, size_t divisor, size_t multiplier)
-{
- if (divisor != 0)
- {
- double s = size;
- double scaled = s * multiplier / divisor + 0.5;
- if (scaled < INT_MAX)
- return scaled;
- }
- return INT_MAX;
-}
-
-/* Compute the desired size of an image with native size WIDTH x HEIGHT.
- Use SPEC to deduce the size. Store the desired size into
- *D_WIDTH x *D_HEIGHT. Store -1 x -1 if the native size is OK. */
-static void
-compute_image_size (size_t width, size_t height,
- Lisp_Object spec,
- int *d_width, int *d_height)
-{
- Lisp_Object value;
- int desired_width = -1, desired_height = -1, max_width = -1, max_height = -1;
- double scale = 1;
-
- value = image_spec_value (spec, QCscale, NULL);
- if (NUMBERP (value))
- scale = XFLOATINT (value);
-
- value = image_spec_value (spec, QCmax_width, NULL);
- if (NATNUMP (value))
- max_width = min (XFASTINT (value), INT_MAX);
-
- value = image_spec_value (spec, QCmax_height, NULL);
- if (NATNUMP (value))
- max_height = min (XFASTINT (value), INT_MAX);
-
- /* If width and/or height is set in the display spec assume we want
- to scale to those values. If either h or w is unspecified, the
- unspecified should be calculated from the specified to preserve
- aspect ratio. */
- value = image_spec_value (spec, QCwidth, NULL);
- if (NATNUMP (value))
- {
- desired_width = min (XFASTINT (value) * scale, INT_MAX);
- /* :width overrides :max-width. */
- max_width = -1;
- }
-
- value = image_spec_value (spec, QCheight, NULL);
- if (NATNUMP (value))
- {
- desired_height = min (XFASTINT (value) * scale, INT_MAX);
- /* :height overrides :max-height. */
- max_height = -1;
- }
-
- /* If we have both width/height set explicitly, we skip past all the
- aspect ratio-preserving computations below. */
- if (desired_width != -1 && desired_height != -1)
- goto out;
-
- width = width * scale;
- height = height * scale;
-
- if (desired_width != -1)
- /* Width known, calculate height. */
- desired_height = scale_image_size (desired_width, width, height);
- else if (desired_height != -1)
- /* Height known, calculate width. */
- desired_width = scale_image_size (desired_height, height, width);
- else
- {
- desired_width = width;
- desired_height = height;
- }
-
- if (max_width != -1 && desired_width > max_width)
- {
- /* The image is wider than :max-width. */
- desired_width = max_width;
- desired_height = scale_image_size (desired_width, width, height);
- }
-
- if (max_height != -1 && desired_height > max_height)
- {
- /* The image is higher than :max-height. */
- desired_height = max_height;
- desired_width = scale_image_size (desired_height, height, width);
- }
-
- out:
- *d_width = desired_width;
- *d_height = desired_height;
-}
-
static bool imagemagick_image_p (Lisp_Object);
static bool imagemagick_load (struct frame *, struct image *);
static void imagemagick_clear_image (struct frame *, struct image *);
@@ -8272,11 +8399,20 @@ imagemagick_image_p (Lisp_Object object)
/* The GIF library also defines DrawRectangle, but its never used in Emacs.
Therefore rename the function so it doesn't collide with ImageMagick. */
#define DrawRectangle DrawRectangleGif
-#include <wand/MagickWand.h>
+
+#ifdef HAVE_IMAGEMAGICK7
+# include <MagickWand/MagickWand.h>
+# include <MagickCore/version.h>
+/* ImageMagick 7 compatibility definitions. */
+# define PixelSetMagickColor PixelSetPixelColor
+typedef PixelInfo MagickPixelPacket;
+#else
+# include <wand/MagickWand.h>
+# include <magick/version.h>
+#endif
/* ImageMagick 6.5.3 through 6.6.5 hid PixelGetMagickColor for some reason.
Emacs seems to work fine with the hidden version, so unhide it. */
-#include <magick/version.h>
#if 0x653 <= MagickLibVersion && MagickLibVersion <= 0x665
extern WandExport void PixelGetMagickColor (const PixelWand *,
MagickPixelPacket *);
@@ -8556,7 +8692,7 @@ imagemagick_load_image (struct frame *f, struct image *img,
char hint_buffer[MaxTextExtent];
char *filename_hint = NULL;
#ifdef USE_CAIRO
- void *data = NULL;
+ cairo_surface_t *surface;
#endif
/* Initialize the ImageMagick environment. */
@@ -8573,7 +8709,7 @@ imagemagick_load_image (struct frame *f, struct image *img,
find out things about it. */
image = image_spec_value (img->spec, QCindex, NULL);
- ino = INTEGERP (image) ? XFASTINT (image) : 0;
+ ino = FIXNUMP (image) ? XFIXNAT (image) : 0;
image_wand = NewMagickWand ();
if (filename)
@@ -8583,9 +8719,9 @@ imagemagick_load_image (struct frame *f, struct image *img,
Lisp_Object lwidth = image_spec_value (img->spec, QCwidth, NULL);
Lisp_Object lheight = image_spec_value (img->spec, QCheight, NULL);
- if (NATNUMP (lwidth) && NATNUMP (lheight))
+ if (FIXNATP (lwidth) && FIXNATP (lheight))
{
- MagickSetSize (image_wand, XFASTINT (lwidth), XFASTINT (lheight));
+ MagickSetSize (image_wand, XFIXNAT (lwidth), XFIXNAT (lheight));
MagickSetDepth (image_wand, 8);
}
filename_hint = imagemagick_filename_hint (img->spec, hint_buffer);
@@ -8628,7 +8764,7 @@ imagemagick_load_image (struct frame *f, struct image *img,
if (MagickGetNumberImages (image_wand) > 1)
img->lisp_data =
Fcons (Qcount,
- Fcons (make_number (MagickGetNumberImages (image_wand)),
+ Fcons (make_fixnum (MagickGetNumberImages (image_wand)),
img->lisp_data));
/* If we have an animated image, get the new wand based on the
@@ -8678,26 +8814,26 @@ imagemagick_load_image (struct frame *f, struct image *img,
efficient. */
crop = image_spec_value (img->spec, QCcrop, NULL);
- if (CONSP (crop) && TYPE_RANGED_INTEGERP (size_t, XCAR (crop)))
+ if (CONSP (crop) && TYPE_RANGED_FIXNUMP (size_t, XCAR (crop)))
{
/* After some testing, it seems MagickCropImage is the fastest crop
function in ImageMagick. This crop function seems to do less copying
than the alternatives, but it still reads the entire image into memory
before cropping, which is apparently difficult to avoid when using
imagemagick. */
- size_t crop_width = XINT (XCAR (crop));
+ size_t crop_width = XFIXNUM (XCAR (crop));
crop = XCDR (crop);
- if (CONSP (crop) && TYPE_RANGED_INTEGERP (size_t, XCAR (crop)))
+ if (CONSP (crop) && TYPE_RANGED_FIXNUMP (size_t, XCAR (crop)))
{
- size_t crop_height = XINT (XCAR (crop));
+ size_t crop_height = XFIXNUM (XCAR (crop));
crop = XCDR (crop);
- if (CONSP (crop) && TYPE_RANGED_INTEGERP (ssize_t, XCAR (crop)))
+ if (CONSP (crop) && TYPE_RANGED_FIXNUMP (ssize_t, XCAR (crop)))
{
- ssize_t crop_x = XINT (XCAR (crop));
+ ssize_t crop_x = XFIXNUM (XCAR (crop));
crop = XCDR (crop);
- if (CONSP (crop) && TYPE_RANGED_INTEGERP (ssize_t, XCAR (crop)))
+ if (CONSP (crop) && TYPE_RANGED_FIXNUMP (ssize_t, XCAR (crop)))
{
- ssize_t crop_y = XINT (XCAR (crop));
+ ssize_t crop_y = XFIXNUM (XCAR (crop));
MagickCropImage (image_wand, crop_width, crop_height,
crop_x, crop_y);
}
@@ -8768,9 +8904,9 @@ imagemagick_load_image (struct frame *f, struct image *img,
ad-hoc and needs to be more researched. */
void *dataptr;
#ifdef USE_CAIRO
- data = xmalloc (width * height * 4);
+ surface = create_cairo_image_surface (width, height);
const char *exportdepth = "BGRA";
- dataptr = data;
+ dataptr = cairo_image_surface_get_data (surface);
#else
int imagedepth = 24; /*MagickGetImageDepth(image_wand);*/
const char *exportdepth = imagedepth <= 8 ? "I" : "BGRP"; /*"RGBP";*/
@@ -8814,9 +8950,11 @@ imagemagick_load_image (struct frame *f, struct image *img,
#endif /* HAVE_MAGICKEXPORTIMAGEPIXELS */
{
size_t image_height;
- MagickRealType color_scale = 65535.0 / QuantumRange;
+ double quantum_range = QuantumRange;
+ MagickRealType color_scale = 65535.0 / quantum_range;
#ifdef USE_CAIRO
- data = xmalloc (width * height * 4);
+ surface = create_cairo_image_surface (width, height);
+ uint32_t *dataptr = (uint32_t *) cairo_image_surface_get_data (surface);
color_scale /= 256;
#else
/* Try to create a x pixmap to hold the imagemagick pixmap. */
@@ -8861,7 +8999,7 @@ imagemagick_load_image (struct frame *f, struct image *img,
{
PixelGetMagickColor (pixels[x], &pixel);
#ifdef USE_CAIRO
- ((uint32_t *)data)[width * y + x] =
+ dataptr[width * y + x] =
lookup_rgb_color (f,
color_scale * pixel.red,
color_scale * pixel.green,
@@ -8879,7 +9017,7 @@ imagemagick_load_image (struct frame *f, struct image *img,
}
#ifdef USE_CAIRO
- create_cairo_image_surface (img, data, width, height);
+ set_cairo_image_surface (img, surface);
#else
#ifdef COLOR_TABLE_SUPPORT
/* Remember colors allocated for this image. */
@@ -9302,7 +9440,7 @@ svg_load_image (struct frame *f, struct image *img, char *contents,
/* Set base_uri for properly handling referenced images (via 'href').
See rsvg bug 596114 - "image refs are relative to curdir, not .svg file"
- (https://gitlab.gnome.org/GNOME/librsvg/issues/33). */
+ <https://gitlab.gnome.org/GNOME/librsvg/issues/33>. */
if (filename)
rsvg_handle_set_base_uri(rsvg_handle, filename);
@@ -9342,13 +9480,13 @@ svg_load_image (struct frame *f, struct image *img, char *contents,
{
#ifdef USE_CAIRO
- unsigned char *data = (unsigned char *) xmalloc (width*height*4);
+ cairo_surface_t *surface = create_cairo_image_surface (width, height);
+ uint32_t *dataptr = (uint32_t *) cairo_image_surface_get_data (surface);
uint32_t bgcolor = get_spec_bg_or_alpha_as_argb (img, f);
for (int y = 0; y < height; ++y)
{
const guchar *iconptr = pixels + y * rowstride;
- uint32_t *dataptr = (uint32_t *) (data + y * rowstride);
for (int x = 0; x < width; ++x)
{
@@ -9365,7 +9503,7 @@ svg_load_image (struct frame *f, struct image *img, char *contents,
}
}
- create_cairo_image_surface (img, data, width, height);
+ set_cairo_image_surface (img, surface);
g_object_unref (pixbuf);
#else
/* Try to create a x pixmap to hold the svg pixmap. */
@@ -9551,7 +9689,7 @@ gs_image_p (Lisp_Object object)
if (CONSP (tem))
{
for (i = 0; i < 4; ++i, tem = XCDR (tem))
- if (!CONSP (tem) || !INTEGERP (XCAR (tem)))
+ if (!CONSP (tem) || !FIXNUMP (XCAR (tem)))
return 0;
if (!NILP (tem))
return 0;
@@ -9561,7 +9699,7 @@ gs_image_p (Lisp_Object object)
if (ASIZE (tem) != 4)
return 0;
for (i = 0; i < 4; ++i)
- if (!INTEGERP (AREF (tem, i)))
+ if (!FIXNUMP (AREF (tem, i)))
return 0;
}
else
@@ -9589,10 +9727,10 @@ gs_load (struct frame *f, struct image *img)
= 1/72 in, xdpi and ydpi are stored in the frame's X display
info. */
pt_width = image_spec_value (img->spec, QCpt_width, NULL);
- in_width = INTEGERP (pt_width) ? XFASTINT (pt_width) / 72.0 : 0;
+ in_width = FIXNUMP (pt_width) ? XFIXNAT (pt_width) / 72.0 : 0;
in_width *= FRAME_RES_X (f);
pt_height = image_spec_value (img->spec, QCpt_height, NULL);
- in_height = INTEGERP (pt_height) ? XFASTINT (pt_height) / 72.0 : 0;
+ in_height = FIXNUMP (pt_height) ? XFIXNAT (pt_height) / 72.0 : 0;
in_height *= FRAME_RES_Y (f);
if (! (in_width <= INT_MAX && in_height <= INT_MAX
@@ -9643,8 +9781,8 @@ gs_load (struct frame *f, struct image *img)
loader = intern ("gs-load-image");
img->lisp_data = call6 (loader, frame, img->spec,
- make_number (img->width),
- make_number (img->height),
+ make_fixnum (img->width),
+ make_fixnum (img->height),
window_and_pixmap_id,
pixel_colors);
return PROCESSP (img->lisp_data);
@@ -9768,7 +9906,7 @@ DEFUN ("lookup-image", Flookup_image, Slookup_image, 1, 1, 0,
id = lookup_image (SELECTED_FRAME (), spec);
debug_print (spec);
- return make_number (id);
+ return make_fixnum (id);
}
#endif /* GLYPH_DEBUG */
@@ -9778,6 +9916,25 @@ DEFUN ("lookup-image", Flookup_image, Slookup_image, 1, 1, 0,
Initialization
***********************************************************************/
+DEFUN ("image-scaling-p", Fimage_scaling_p, Simage_scaling_p, 0, 1, 0,
+ doc: /* Test whether FRAME supports resizing images.
+Return t if FRAME supports native scaling, nil otherwise. */)
+ (Lisp_Object frame)
+{
+#if defined (USE_CAIRO) || defined (HAVE_NS) || defined (HAVE_NTGUI)
+ return Qt;
+#elif defined (HAVE_X_WINDOWS) && defined (HAVE_XRENDER)
+ int event_basep, error_basep;
+
+ if (XRenderQueryExtension
+ (FRAME_X_DISPLAY (decode_window_system_frame (frame)),
+ &event_basep, &error_basep))
+ return Qt;
+#endif
+
+ return Qnil;
+}
+
DEFUN ("init-image-library", Finit_image_library, Sinit_image_library, 1, 1, 0,
doc: /* Initialize image library implementing image type TYPE.
Return non-nil if TYPE is a supported image type.
@@ -9846,7 +10003,7 @@ lookup_image_type (Lisp_Object type)
return NULL;
}
-#if !defined CANNOT_DUMP && defined HAVE_WINDOW_SYSTEM
+#if defined HAVE_UNEXEC && defined HAVE_WINDOW_SYSTEM
/* Reset image_types before dumping.
Called from Fdump_emacs. */
@@ -9867,7 +10024,9 @@ void
syms_of_image (void)
{
/* Initialize this only once; it will be reset before dumping. */
+ /* The portable dumper will just leave it NULL, so no need to reset. */
image_types = NULL;
+ PDUMPER_IGNORE (image_types);
/* Must be defined now because we're going to update it below, while
defining the supported image types. */
@@ -9933,27 +10092,27 @@ non-numeric, there is no explicit limit on the size of images. */);
DEFSYM (Qlibpng_version, "libpng-version");
Fset (Qlibpng_version,
#if HAVE_PNG
- make_number (PNG_LIBPNG_VER)
+ make_fixnum (PNG_LIBPNG_VER)
#else
- make_number (-1)
+ make_fixnum (-1)
#endif
);
DEFSYM (Qlibgif_version, "libgif-version");
Fset (Qlibgif_version,
#ifdef HAVE_GIF
- make_number (GIFLIB_MAJOR * 10000
+ make_fixnum (GIFLIB_MAJOR * 10000
+ GIFLIB_MINOR * 100
+ GIFLIB_RELEASE)
#else
- make_number (-1)
+ make_fixnum (-1)
#endif
);
DEFSYM (Qlibjpeg_version, "libjpeg-version");
Fset (Qlibjpeg_version,
#if HAVE_JPEG
- make_number (JPEG_LIB_VERSION)
+ make_fixnum (JPEG_LIB_VERSION)
#else
- make_number (-1)
+ make_fixnum (-1)
#endif
);
#endif
@@ -10020,6 +10179,8 @@ non-numeric, there is no explicit limit on the size of images. */);
defsubr (&Slookup_image);
#endif
+ defsubr (&Simage_scaling_p);
+
DEFVAR_BOOL ("cross-disabled-images", cross_disabled_images,
doc: /* Non-nil means always draw a cross over disabled images.
Disabled images are those having a `:conversion disabled' property.
@@ -10038,7 +10199,7 @@ a large number of images, the actual eviction time may be shorter.
The value can also be nil, meaning the cache is never cleared.
The function `clear-image-cache' disregards this variable. */);
- Vimage_cache_eviction_delay = make_number (300);
+ Vimage_cache_eviction_delay = make_fixnum (300);
#ifdef HAVE_IMAGEMAGICK
DEFVAR_INT ("imagemagick-render-type", imagemagick_render_type,
doc: /* Integer indicating which ImageMagick rendering method to use.
diff --git a/src/indent.c b/src/indent.c
index 5e3a7e05923..1d5d346e63f 100644
--- a/src/indent.c
+++ b/src/indent.c
@@ -49,7 +49,7 @@ ptrdiff_t last_known_column_point;
/* Value of MODIFF when current_column was called. */
-static EMACS_INT last_known_column_modified;
+static modiff_count last_known_column_modified;
static ptrdiff_t current_column_1 (void);
static ptrdiff_t position_indentation (ptrdiff_t);
@@ -116,7 +116,7 @@ disptab_matches_widthtab (struct Lisp_Char_Table *disptab, struct Lisp_Vector *w
for (i = 0; i < 256; i++)
if (character_width (i, disptab)
- != XFASTINT (widthtab->contents[i]))
+ != XFIXNAT (widthtab->contents[i]))
return 0;
return 1;
@@ -235,24 +235,24 @@ skip_invisible (ptrdiff_t pos, ptrdiff_t *next_boundary_p, ptrdiff_t to, Lisp_Ob
/* As for text properties, this gives a lower bound
for where the invisible text property could change. */
proplimit = Fnext_property_change (position, buffer, Qt);
- if (XFASTINT (overlay_limit) < XFASTINT (proplimit))
+ if (XFIXNAT (overlay_limit) < XFIXNAT (proplimit))
proplimit = overlay_limit;
/* PROPLIMIT is now a lower bound for the next change
in invisible status. If that is plenty far away,
use that lower bound. */
- if (XFASTINT (proplimit) > pos + 100 || XFASTINT (proplimit) >= to)
- *next_boundary_p = XFASTINT (proplimit);
+ if (XFIXNAT (proplimit) > pos + 100 || XFIXNAT (proplimit) >= to)
+ *next_boundary_p = XFIXNAT (proplimit);
/* Otherwise, scan for the next `invisible' property change. */
else
{
/* Don't scan terribly far. */
XSETFASTINT (proplimit, min (pos + 100, to));
/* No matter what, don't go past next overlay change. */
- if (XFASTINT (overlay_limit) < XFASTINT (proplimit))
+ if (XFIXNAT (overlay_limit) < XFIXNAT (proplimit))
proplimit = overlay_limit;
tmp = Fnext_single_property_change (position, Qinvisible,
buffer, proplimit);
- end = XFASTINT (tmp);
+ end = XFIXNAT (tmp);
#if 0
/* Don't put the boundary in the middle of multibyte form if
there is no actual property change. */
@@ -472,7 +472,7 @@ check_display_width (ptrdiff_t pos, ptrdiff_t col, ptrdiff_t *endpos)
Lisp_Object val, overlay;
if (CONSP (val = get_char_property_and_overlay
- (make_number (pos), Qdisplay, Qnil, &overlay))
+ (make_fixnum (pos), Qdisplay, Qnil, &overlay))
&& EQ (Qspace, XCAR (val)))
{ /* FIXME: Use calc_pixel_width_or_height. */
Lisp_Object plist = XCDR (val), prop;
@@ -483,16 +483,16 @@ check_display_width (ptrdiff_t pos, ptrdiff_t col, ptrdiff_t *endpos)
: MOST_POSITIVE_FIXNUM);
if ((prop = Fplist_get (plist, QCwidth),
- RANGED_INTEGERP (0, prop, INT_MAX))
+ RANGED_FIXNUMP (0, prop, INT_MAX))
|| (prop = Fplist_get (plist, QCrelative_width),
- RANGED_INTEGERP (0, prop, INT_MAX)))
- width = XINT (prop);
+ RANGED_FIXNUMP (0, prop, INT_MAX)))
+ width = XFIXNUM (prop);
else if (FLOATP (prop) && 0 <= XFLOAT_DATA (prop)
&& XFLOAT_DATA (prop) <= INT_MAX)
width = (int)(XFLOAT_DATA (prop) + 0.5);
else if ((prop = Fplist_get (plist, QCalign_to),
- RANGED_INTEGERP (col, prop, align_to_max)))
- width = XINT (prop) - col;
+ RANGED_FIXNUMP (col, prop, align_to_max)))
+ width = XFIXNUM (prop) - col;
else if (FLOATP (prop) && col <= XFLOAT_DATA (prop)
&& (XFLOAT_DATA (prop) <= align_to_max))
width = (int)(XFLOAT_DATA (prop) + 0.5) - col;
@@ -751,16 +751,16 @@ string_display_width (Lisp_Object string, Lisp_Object beg, Lisp_Object end)
e = SCHARS (string);
else
{
- CHECK_NUMBER (end);
- e = XINT (end);
+ CHECK_FIXNUM (end);
+ e = XFIXNUM (end);
}
if (NILP (beg))
b = 0;
else
{
- CHECK_NUMBER (beg);
- b = XINT (beg);
+ CHECK_FIXNUM (beg);
+ b = XFIXNUM (beg);
}
/* Make a pointer for decrementing through the chars before point. */
@@ -820,32 +820,32 @@ The return value is the column where the insertion ends. */)
register ptrdiff_t fromcol;
int tab_width = SANE_TAB_WIDTH (current_buffer);
- CHECK_NUMBER (column);
+ CHECK_FIXNUM (column);
if (NILP (minimum))
XSETFASTINT (minimum, 0);
- CHECK_NUMBER (minimum);
+ CHECK_FIXNUM (minimum);
fromcol = current_column ();
- mincol = fromcol + XINT (minimum);
- if (mincol < XINT (column)) mincol = XINT (column);
+ mincol = fromcol + XFIXNUM (minimum);
+ if (mincol < XFIXNUM (column)) mincol = XFIXNUM (column);
if (fromcol == mincol)
- return make_number (mincol);
+ return make_fixnum (mincol);
if (indent_tabs_mode)
{
Lisp_Object n;
XSETFASTINT (n, mincol / tab_width - fromcol / tab_width);
- if (XFASTINT (n) != 0)
+ if (XFIXNAT (n) != 0)
{
- Finsert_char (make_number ('\t'), n, Qt);
+ Finsert_char (make_fixnum ('\t'), n, Qt);
fromcol = (mincol / tab_width) * tab_width;
}
}
XSETFASTINT (column, mincol - fromcol);
- Finsert_char (make_number (' '), column, Qt);
+ Finsert_char (make_fixnum (' '), column, Qt);
last_known_column = mincol;
last_known_column_point = PT;
@@ -866,7 +866,7 @@ following any initial whitespace. */)
ptrdiff_t posbyte;
find_newline (PT, PT_BYTE, BEGV, BEGV_BYTE, -1, NULL, &posbyte, 1);
- return make_number (position_indentation (posbyte));
+ return make_fixnum (position_indentation (posbyte));
}
static ptrdiff_t
@@ -994,8 +994,8 @@ The return value is the current column. */)
EMACS_INT col;
EMACS_INT goal;
- CHECK_NATNUM (column);
- goal = XINT (column);
+ CHECK_FIXNAT (column);
+ goal = XFIXNUM (column);
col = goal;
pos = ZV;
@@ -1020,13 +1020,13 @@ The return value is the current column. */)
first so that a marker at the end of the tab gets
adjusted. */
SET_PT_BOTH (PT - 1, PT_BYTE - 1);
- Finsert_char (make_number (' '), make_number (goal - prev_col), Qt);
+ Finsert_char (make_fixnum (' '), make_fixnum (goal - prev_col), Qt);
/* Now delete the tab, and indent to COL. */
del_range (PT, PT + 1);
goal_pt = PT;
goal_pt_byte = PT_BYTE;
- Findent_to (make_number (col), Qnil);
+ Findent_to (make_fixnum (col), Qnil);
SET_PT_BOTH (goal_pt, goal_pt_byte);
/* Set the last_known... vars consistently. */
@@ -1036,13 +1036,13 @@ The return value is the current column. */)
/* If line ends prematurely, add space to the end. */
if (col < goal && EQ (force, Qt))
- Findent_to (make_number (col = goal), Qnil);
+ Findent_to (make_fixnum (col = goal), Qnil);
last_known_column = col;
last_known_column_point = PT;
last_known_column_modified = MODIFF;
- return make_number (col);
+ return make_fixnum (col);
}
/* compute_motion: compute buffer posn given screen posn and vice versa */
@@ -1128,8 +1128,8 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos,
bool ctl_arrow = !NILP (BVAR (current_buffer, ctl_arrow));
struct Lisp_Char_Table *dp = window_display_table (win);
EMACS_INT selective
- = (INTEGERP (BVAR (current_buffer, selective_display))
- ? XINT (BVAR (current_buffer, selective_display))
+ = (FIXNUMP (BVAR (current_buffer, selective_display))
+ ? XFIXNUM (BVAR (current_buffer, selective_display))
: !NILP (BVAR (current_buffer, selective_display)) ? -1 : 0);
ptrdiff_t selective_rlen
= (selective && dp && VECTORP (DISP_INVIS_VECTOR (dp))
@@ -1338,9 +1338,9 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos,
if (!NILP (Vtruncate_partial_width_windows)
&& (total_width < FRAME_COLS (XFRAME (WINDOW_FRAME (win)))))
{
- if (INTEGERP (Vtruncate_partial_width_windows))
+ if (FIXNUMP (Vtruncate_partial_width_windows))
truncate
- = total_width < XFASTINT (Vtruncate_partial_width_windows);
+ = total_width < XFIXNAT (Vtruncate_partial_width_windows);
else
truncate = 1;
}
@@ -1533,7 +1533,7 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos,
/* Is this character part of the current run? If so, extend
the run. */
if (pos - 1 == width_run_end
- && XFASTINT (width_table[c]) == width_run_width)
+ && XFIXNAT (width_table[c]) == width_run_width)
width_run_end = pos;
/* The previous run is over, since this is a character at a
@@ -1548,7 +1548,7 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos,
width_run_start, width_run_end);
/* Start recording a new width run. */
- width_run_width = XFASTINT (width_table[c]);
+ width_run_width = XFIXNAT (width_table[c]);
width_run_start = pos - 1;
width_run_end = pos;
}
@@ -1754,48 +1754,48 @@ visible section of the buffer, and pass LINE and COL as TOPOS. */)
ptrdiff_t hscroll;
int tab_offset;
- CHECK_NUMBER_COERCE_MARKER (from);
+ CHECK_FIXNUM_COERCE_MARKER (from);
CHECK_CONS (frompos);
- CHECK_NUMBER_CAR (frompos);
- CHECK_NUMBER_CDR (frompos);
- CHECK_NUMBER_COERCE_MARKER (to);
+ CHECK_FIXNUM (XCAR (frompos));
+ CHECK_FIXNUM (XCDR (frompos));
+ CHECK_FIXNUM_COERCE_MARKER (to);
if (!NILP (topos))
{
CHECK_CONS (topos);
- CHECK_NUMBER_CAR (topos);
- CHECK_NUMBER_CDR (topos);
+ CHECK_FIXNUM (XCAR (topos));
+ CHECK_FIXNUM (XCDR (topos));
}
if (!NILP (width))
- CHECK_NUMBER (width);
+ CHECK_FIXNUM (width);
if (!NILP (offsets))
{
CHECK_CONS (offsets);
- CHECK_NUMBER_CAR (offsets);
- CHECK_NUMBER_CDR (offsets);
- if (! (0 <= XINT (XCAR (offsets)) && XINT (XCAR (offsets)) <= PTRDIFF_MAX
- && 0 <= XINT (XCDR (offsets)) && XINT (XCDR (offsets)) <= INT_MAX))
+ CHECK_FIXNUM (XCAR (offsets));
+ CHECK_FIXNUM (XCDR (offsets));
+ if (! (0 <= XFIXNUM (XCAR (offsets)) && XFIXNUM (XCAR (offsets)) <= PTRDIFF_MAX
+ && 0 <= XFIXNUM (XCDR (offsets)) && XFIXNUM (XCDR (offsets)) <= INT_MAX))
args_out_of_range (XCAR (offsets), XCDR (offsets));
- hscroll = XINT (XCAR (offsets));
- tab_offset = XINT (XCDR (offsets));
+ hscroll = XFIXNUM (XCAR (offsets));
+ tab_offset = XFIXNUM (XCDR (offsets));
}
else
hscroll = tab_offset = 0;
w = decode_live_window (window);
- if (XINT (from) < BEGV || XINT (from) > ZV)
- args_out_of_range_3 (from, make_number (BEGV), make_number (ZV));
- if (XINT (to) < BEGV || XINT (to) > ZV)
- args_out_of_range_3 (to, make_number (BEGV), make_number (ZV));
+ if (XFIXNUM (from) < BEGV || XFIXNUM (from) > ZV)
+ args_out_of_range_3 (from, make_fixnum (BEGV), make_fixnum (ZV));
+ if (XFIXNUM (to) < BEGV || XFIXNUM (to) > ZV)
+ args_out_of_range_3 (to, make_fixnum (BEGV), make_fixnum (ZV));
- pos = compute_motion (XINT (from), CHAR_TO_BYTE (XINT (from)),
- XINT (XCDR (frompos)),
- XINT (XCAR (frompos)), 0,
- XINT (to),
+ pos = compute_motion (XFIXNUM (from), CHAR_TO_BYTE (XFIXNUM (from)),
+ XFIXNUM (XCDR (frompos)),
+ XFIXNUM (XCAR (frompos)), 0,
+ XFIXNUM (to),
(NILP (topos)
? window_internal_height (w)
- : XINT (XCDR (topos))),
+ : XFIXNUM (XCDR (topos))),
(NILP (topos)
? (window_body_width (w, 0)
- (
@@ -1803,8 +1803,8 @@ visible section of the buffer, and pass LINE and COL as TOPOS. */)
FRAME_WINDOW_P (XFRAME (w->frame)) ? 0 :
#endif
1))
- : XINT (XCAR (topos))),
- (NILP (width) ? -1 : XINT (width)),
+ : XFIXNUM (XCAR (topos))),
+ (NILP (width) ? -1 : XFIXNUM (width)),
hscroll, tab_offset, w);
XSETFASTINT (bufpos, pos->bufpos);
@@ -1831,8 +1831,8 @@ vmotion (register ptrdiff_t from, register ptrdiff_t from_byte,
register ptrdiff_t first;
ptrdiff_t lmargin = hscroll > 0 ? 1 - hscroll : 0;
ptrdiff_t selective
- = (INTEGERP (BVAR (current_buffer, selective_display))
- ? clip_to_bounds (-1, XINT (BVAR (current_buffer, selective_display)),
+ = (FIXNUMP (BVAR (current_buffer, selective_display))
+ ? clip_to_bounds (-1, XFIXNUM (BVAR (current_buffer, selective_display)),
PTRDIFF_MAX)
: !NILP (BVAR (current_buffer, selective_display)) ? -1 : 0);
Lisp_Object window;
@@ -1870,7 +1870,7 @@ vmotion (register ptrdiff_t from, register ptrdiff_t from_byte,
&& indented_beyond_p (prevline, bytepos, selective))
/* Watch out for newlines with `invisible' property.
When moving upward, check the newline before. */
- || (propval = Fget_char_property (make_number (prevline - 1),
+ || (propval = Fget_char_property (make_fixnum (prevline - 1),
Qinvisible,
text_prop_object),
TEXT_PROP_MEANS_INVISIBLE (propval))))
@@ -1920,7 +1920,7 @@ vmotion (register ptrdiff_t from, register ptrdiff_t from_byte,
&& indented_beyond_p (prevline, bytepos, selective))
/* Watch out for newlines with `invisible' property.
When moving downward, check the newline after. */
- || (propval = Fget_char_property (make_number (prevline),
+ || (propval = Fget_char_property (make_fixnum (prevline),
Qinvisible,
text_prop_object),
TEXT_PROP_MEANS_INVISIBLE (propval))))
@@ -2016,8 +2016,8 @@ numbers on display. */)
return make_float ((double) pixel_width / FRAME_COLUMN_WIDTH (f));
}
else if (!NILP (pixelwise))
- return make_number (pixel_width);
- return make_number (width);
+ return make_fixnum (pixel_width);
+ return make_fixnum (width);
}
/* In window W (derived from WINDOW), return x coordinate for column
@@ -2045,8 +2045,8 @@ restore_window_buffer (Lisp_Object list)
wset_buffer (w, XCAR (list));
list = XCDR (list);
set_marker_both (w->pointm, w->contents,
- XFASTINT (XCAR (list)),
- XFASTINT (XCAR (XCDR (list))));
+ XFIXNAT (XCAR (list)),
+ XFIXNAT (XCAR (XCDR (list))));
}
DEFUN ("vertical-motion", Fvertical_motion, Svertical_motion, 1, 3, 0,
@@ -2100,15 +2100,15 @@ whether or not it is currently displayed in some window. */)
lines = XCDR (lines);
}
- CHECK_NUMBER (lines);
+ CHECK_FIXNUM (lines);
w = decode_live_window (window);
if (XBUFFER (w->contents) != current_buffer)
{
/* Set the window's buffer temporarily to the current buffer. */
Lisp_Object old = list4 (window, w->contents,
- make_number (marker_position (w->pointm)),
- make_number (marker_byte_position (w->pointm)));
+ make_fixnum (marker_position (w->pointm)),
+ make_fixnum (marker_byte_position (w->pointm)));
record_unwind_protect (restore_window_buffer, old);
wset_buffer (w, Fcurrent_buffer ());
set_marker_both (w->pointm, w->contents,
@@ -2118,7 +2118,7 @@ whether or not it is currently displayed in some window. */)
if (noninteractive)
{
struct position pos;
- pos = *vmotion (PT, PT_BYTE, XINT (lines), w);
+ pos = *vmotion (PT, PT_BYTE, XFIXNUM (lines), w);
SET_PT_BOTH (pos.bufpos, pos.bytepos);
it.vpos = pos.vpos;
}
@@ -2128,7 +2128,7 @@ whether or not it is currently displayed in some window. */)
int first_x;
bool overshoot_handled = 0;
bool disp_string_at_start_p = 0;
- ptrdiff_t nlines = XINT (lines);
+ ptrdiff_t nlines = XFIXNUM (lines);
int vpos_init = 0;
double start_col UNINIT;
int start_x UNINIT;
@@ -2286,7 +2286,7 @@ whether or not it is currently displayed in some window. */)
it.current_y = 0;
/* Do this even if LINES is 0, so that we move back to the
beginning of the current line as we ought. */
- if ((nlines < 0 && IT_CHARPOS (it) > 0)
+ if ((nlines < 0 && IT_CHARPOS (it) > BEGV)
|| (nlines == 0 && !(start_x_given && start_x <= to_x)))
move_it_by_lines (&it, max (PTRDIFF_MIN, nlines));
}
@@ -2338,7 +2338,7 @@ whether or not it is currently displayed in some window. */)
and then reposition point at the requested X coordinate;
if we don't, the cursor will be placed just after the
string, which might not be the requested column. */
- if (nlines > 0 && it.area == TEXT_AREA)
+ if (nlines >= 0 && it.area == TEXT_AREA)
{
while (it.method == GET_FROM_STRING
&& !it.string_from_display_prop_p
@@ -2356,9 +2356,7 @@ whether or not it is currently displayed in some window. */)
bidi_unshelve_cache (itdata, 0);
}
- unbind_to (count, Qnil);
-
- return make_number (it.vpos);
+ return unbind_to (count, make_fixnum (it.vpos));
}
diff --git a/src/inotify.c b/src/inotify.c
index a11d1d954e9..ecbe31c1682 100644
--- a/src/inotify.c
+++ b/src/inotify.c
@@ -176,7 +176,7 @@ inotifyevent_to_event (Lisp_Object watch, struct inotify_event const *ev)
{
Lisp_Object name;
uint32_t mask;
- CONS_TO_INTEGER (Fnth (make_number (3), watch), uint32_t, mask);
+ CONS_TO_INTEGER (Fnth (make_fixnum (3), watch), uint32_t, mask);
if (! (mask & ev->mask))
return Qnil;
@@ -190,11 +190,11 @@ inotifyevent_to_event (Lisp_Object watch, struct inotify_event const *ev)
else
name = XCAR (XCDR (watch));
- return list2 (list4 (Fcons (INTEGER_TO_CONS (ev->wd), XCAR (watch)),
+ return list2 (list4 (Fcons (INT_TO_INTEGER (ev->wd), XCAR (watch)),
mask_to_aspects (ev->mask),
name,
- INTEGER_TO_CONS (ev->cookie)),
- Fnth (make_number (2), watch));
+ INT_TO_INTEGER (ev->cookie)),
+ Fnth (make_fixnum (2), watch));
}
/* Add a new watch to watch-descriptor WD watching FILENAME and using
@@ -204,10 +204,10 @@ static Lisp_Object
add_watch (int wd, Lisp_Object filename,
uint32_t imask, Lisp_Object callback)
{
- Lisp_Object descriptor = INTEGER_TO_CONS (wd);
+ Lisp_Object descriptor = INT_TO_INTEGER (wd);
Lisp_Object tail = assoc_no_quit (descriptor, watch_list);
Lisp_Object watch, watch_id;
- Lisp_Object mask = INTEGER_TO_CONS (imask);
+ Lisp_Object mask = INT_TO_INTEGER (imask);
EMACS_INT id = 0;
if (NILP (tail))
@@ -220,7 +220,7 @@ add_watch (int wd, Lisp_Object filename,
/* Assign a watch ID that is not already in use, by looking
for a gap in the existing sorted list. */
for (; ! NILP (XCDR (tail)); tail = XCDR (tail), id++)
- if (!EQ (XCAR (XCAR (XCDR (tail))), make_number (id)))
+ if (!EQ (XCAR (XCAR (XCDR (tail))), make_fixnum (id)))
break;
if (MOST_POSITIVE_FIXNUM < id)
emacs_abort ();
@@ -229,7 +229,7 @@ add_watch (int wd, Lisp_Object filename,
/* Insert the newly-assigned ID into the previously-discovered gap,
which is possibly at the end of the list. Inserting it there
keeps the list sorted. */
- watch_id = make_number (id);
+ watch_id = make_fixnum (id);
watch = list4 (watch_id, filename, callback, mask);
XSETCDR (tail, Fcons (watch, XCDR (tail)));
@@ -332,7 +332,7 @@ inotify_callback (int fd, void *_)
for (ssize_t i = 0; i < n; )
{
struct inotify_event *ev = (struct inotify_event *) &buffer[i];
- Lisp_Object descriptor = INTEGER_TO_CONS (ev->wd);
+ Lisp_Object descriptor = INT_TO_INTEGER (ev->wd);
Lisp_Object prevtail = find_descriptor (descriptor);
if (! NILP (prevtail))
@@ -446,12 +446,12 @@ static bool
valid_watch_descriptor (Lisp_Object wd)
{
return (CONSP (wd)
- && (RANGED_INTEGERP (0, XCAR (wd), INT_MAX)
+ && (RANGED_FIXNUMP (0, XCAR (wd), INT_MAX)
|| (CONSP (XCAR (wd))
- && RANGED_INTEGERP ((MOST_POSITIVE_FIXNUM >> 16) + 1,
+ && RANGED_FIXNUMP ((MOST_POSITIVE_FIXNUM >> 16) + 1,
XCAR (XCAR (wd)), INT_MAX >> 16)
- && RANGED_INTEGERP (0, XCDR (XCAR (wd)), (1 << 16) - 1)))
- && NATNUMP (XCDR (wd)));
+ && RANGED_FIXNUMP (0, XCDR (XCAR (wd)), (1 << 16) - 1)))
+ && FIXNATP (XCDR (wd)));
}
DEFUN ("inotify-rm-watch", Finotify_rm_watch, Sinotify_rm_watch, 1, 1, 0,
diff --git a/src/insdel.c b/src/insdel.c
index 550d1a0e8f6..1231bb2682b 100644
--- a/src/insdel.c
+++ b/src/insdel.c
@@ -29,6 +29,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "buffer.h"
#include "window.h"
#include "region-cache.h"
+#include "pdumper.h"
static void insert_from_string_1 (Lisp_Object, ptrdiff_t, ptrdiff_t, ptrdiff_t,
ptrdiff_t, bool, bool);
@@ -707,7 +708,7 @@ insert_char (int c)
insert ((char *) str, len);
}
-/* Insert the null-terminated string S before point. */
+/* Insert the NUL-terminated string S before point. */
void
insert_string (const char *s)
@@ -902,7 +903,7 @@ insert_1_both (const char *string,
the insertion. This, together with recording the insertion,
will add up to the right stuff in the undo list. */
record_insert (PT, nchars);
- MODIFF++;
+ modiff_incr (&MODIFF);
CHARS_MODIFF = MODIFF;
memcpy (GPT_ADDR, string, nbytes);
@@ -930,7 +931,7 @@ insert_1_both (const char *string,
offset_intervals (current_buffer, PT, nchars);
if (!inherit && buffer_intervals (current_buffer))
- set_text_properties (make_number (PT), make_number (PT + nchars),
+ set_text_properties (make_fixnum (PT), make_fixnum (PT + nchars),
Qnil, Qnil, Qnil);
adjust_point (nchars, nbytes);
@@ -1030,7 +1031,7 @@ insert_from_string_1 (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte,
#endif
record_insert (PT, nchars);
- MODIFF++;
+ modiff_incr (&MODIFF);
CHARS_MODIFF = MODIFF;
GAP_SIZE -= outgoing_nbytes;
@@ -1087,7 +1088,7 @@ insert_from_gap (ptrdiff_t nchars, ptrdiff_t nbytes, bool text_at_gap_tail)
of this dance. */
invalidate_buffer_caches (current_buffer, GPT, GPT);
record_insert (GPT, nchars);
- MODIFF++;
+ modiff_incr (&MODIFF);
GAP_SIZE -= nbytes;
if (! text_at_gap_tail)
@@ -1227,7 +1228,7 @@ insert_from_buffer_1 (struct buffer *buf,
#endif
record_insert (PT, nchars);
- MODIFF++;
+ modiff_incr (&MODIFF);
CHARS_MODIFF = MODIFF;
GAP_SIZE -= outgoing_nbytes;
@@ -1328,7 +1329,7 @@ adjust_after_replace (ptrdiff_t from, ptrdiff_t from_byte,
if (len == 0)
evaporate_overlays (from);
- MODIFF++;
+ modiff_incr (&MODIFF);
CHARS_MODIFF = MODIFF;
}
@@ -1523,7 +1524,7 @@ replace_range (ptrdiff_t from, ptrdiff_t to, Lisp_Object new,
check_markers ();
- MODIFF++;
+ modiff_incr (&MODIFF);
CHARS_MODIFF = MODIFF;
if (adjust_match_data)
@@ -1654,7 +1655,7 @@ replace_range_2 (ptrdiff_t from, ptrdiff_t from_byte,
check_markers ();
- MODIFF++;
+ modiff_incr (&MODIFF);
CHARS_MODIFF = MODIFF;
}
@@ -1829,7 +1830,7 @@ del_range_2 (ptrdiff_t from, ptrdiff_t from_byte,
at the end of the text before the gap. */
adjust_markers_for_delete (from, from_byte, to, to_byte);
- MODIFF++;
+ modiff_incr (&MODIFF);
CHARS_MODIFF = MODIFF;
/* Relocate point as if it were a marker. */
@@ -1883,7 +1884,7 @@ modify_text (ptrdiff_t start, ptrdiff_t end)
BUF_COMPUTE_UNCHANGED (current_buffer, start - 1, end);
if (MODIFF <= SAVE_MODIFF)
record_first_change ();
- MODIFF++;
+ modiff_incr (&MODIFF);
CHARS_MODIFF = MODIFF;
bset_point_before_scroll (current_buffer, Qnil);
@@ -1927,6 +1928,14 @@ prepare_to_modify_buffer_1 (ptrdiff_t start, ptrdiff_t end,
if (!NILP (BVAR (current_buffer, read_only)))
Fbarf_if_buffer_read_only (temp);
+ /* If we're about to modify a buffer the contents of which come from
+ a dump file, copy the contents to private storage first so we
+ don't take a COW fault on the buffer text and keep it around
+ forever. */
+ if (pdumper_object_p (BEG_ADDR))
+ enlarge_buffer_text (current_buffer, 0);
+ eassert (!pdumper_object_p (BEG_ADDR));
+
run_undoable_change();
bset_redisplay (current_buffer);
@@ -1936,7 +1945,7 @@ prepare_to_modify_buffer_1 (ptrdiff_t start, ptrdiff_t end,
if (preserve_ptr)
{
Lisp_Object preserve_marker;
- preserve_marker = Fcopy_marker (make_number (*preserve_ptr), Qnil);
+ preserve_marker = Fcopy_marker (make_fixnum (*preserve_ptr), Qnil);
verify_interval_modification (current_buffer, start, end);
*preserve_ptr = marker_position (preserve_marker);
unchain_marker (XMARKER (preserve_marker));
@@ -2046,7 +2055,7 @@ invalidate_buffer_caches (struct buffer *buf, ptrdiff_t start, ptrdiff_t end)
#define PRESERVE_VALUE \
if (preserve_ptr && NILP (preserve_marker)) \
- preserve_marker = Fcopy_marker (make_number (*preserve_ptr), Qnil)
+ preserve_marker = Fcopy_marker (make_fixnum (*preserve_ptr), Qnil)
#define RESTORE_VALUE \
if (! NILP (preserve_marker)) \
@@ -2103,8 +2112,8 @@ signal_before_change (ptrdiff_t start_int, ptrdiff_t end_int,
ptrdiff_t count = SPECPDL_INDEX ();
struct rvoe_arg rvoe_arg;
- start = make_number (start_int);
- end = make_number (end_int);
+ start = make_fixnum (start_int);
+ end = make_fixnum (end_int);
preserve_marker = Qnil;
start_marker = Qnil;
end_marker = Qnil;
@@ -2210,26 +2219,26 @@ signal_after_change (ptrdiff_t charpos, ptrdiff_t lendel, ptrdiff_t lenins)
/* Actually run the hook functions. */
CALLN (Frun_hook_with_args, Qafter_change_functions,
- make_number (charpos), make_number (charpos + lenins),
- make_number (lendel));
+ make_fixnum (charpos), make_fixnum (charpos + lenins),
+ make_fixnum (lendel));
/* There was no error: unarm the reset_on_error. */
rvoe_arg.errorp = 0;
}
if (buffer_has_overlays ())
- report_overlay_modification (make_number (charpos),
- make_number (charpos + lenins),
+ report_overlay_modification (make_fixnum (charpos),
+ make_fixnum (charpos + lenins),
1,
- make_number (charpos),
- make_number (charpos + lenins),
- make_number (lendel));
+ make_fixnum (charpos),
+ make_fixnum (charpos + lenins),
+ make_fixnum (lendel));
/* After an insertion, call the text properties
insert-behind-hooks or insert-in-front-hooks. */
if (lendel == 0)
- report_interval_modification (make_number (charpos),
- make_number (charpos + lenins));
+ report_interval_modification (make_fixnum (charpos),
+ make_fixnum (charpos + lenins));
unbind_to (count, Qnil);
}
@@ -2255,7 +2264,7 @@ DEFUN ("combine-after-change-execute", Fcombine_after_change_execute,
/* It is rare for combine_after_change_buffer to be invalid, but
possible. It can happen when combine-after-change-calls is
- non-nil, and insertion calls a file handler (e.g. through
+ non-nil, and insertion calls a file name handler (e.g. through
lock_file) which scribbles into a temp file -- cyd */
if (!BUFFERP (combine_after_change_buffer)
|| !BUFFER_LIVE_P (XBUFFER (combine_after_change_buffer)))
@@ -2287,17 +2296,17 @@ DEFUN ("combine-after-change-execute", Fcombine_after_change_execute,
elt = XCAR (tail);
if (! CONSP (elt))
continue;
- thisbeg = XINT (XCAR (elt));
+ thisbeg = XFIXNUM (XCAR (elt));
elt = XCDR (elt);
if (! CONSP (elt))
continue;
- thisend = XINT (XCAR (elt));
+ thisend = XFIXNUM (XCAR (elt));
elt = XCDR (elt);
if (! CONSP (elt))
continue;
- thischange = XINT (XCAR (elt));
+ thischange = XFIXNUM (XCAR (elt));
/* Merge this range into the accumulated range. */
change += thischange;
diff --git a/src/intervals.c b/src/intervals.c
index e7595b23b3a..8f39c45762f 100644
--- a/src/intervals.c
+++ b/src/intervals.c
@@ -197,7 +197,7 @@ intervals_equal (INTERVAL i0, INTERVAL i1)
}
/* i0 has something i1 doesn't. */
- if (EQ (i1_val, Qnil))
+ if (NILP (i1_val))
return false;
/* i0 and i1 both have sym, but it has different values in each. */
@@ -713,11 +713,21 @@ previous_interval (register INTERVAL interval)
return NULL;
}
-/* Find the interval containing POS given some non-NULL INTERVAL
- in the same tree. Note that we need to update interval->position
- if we go down the tree.
- To speed up the process, we assume that the ->position of
- I and all its parents is already uptodate. */
+/* Set the ->position field of I's parent, based on I->position. */
+#define SET_PARENT_POSITION(i) \
+ if (AM_LEFT_CHILD (i)) \
+ INTERVAL_PARENT (i)->position = \
+ i->position + TOTAL_LENGTH (i) - LEFT_TOTAL_LENGTH (i); \
+ else \
+ INTERVAL_PARENT (i)->position = \
+ i->position - LEFT_TOTAL_LENGTH (i) \
+ - LENGTH (INTERVAL_PARENT (i))
+
+/* Find the interval containing POS, given some non-NULL INTERVAL in
+ the same tree. Note that we update interval->position in each
+ interval we traverse, assuming it is already correctly set for the
+ argument I. We don't assume that any other interval already has a
+ correctly set ->position. */
INTERVAL
update_interval (register INTERVAL i, ptrdiff_t pos)
{
@@ -738,7 +748,10 @@ update_interval (register INTERVAL i, ptrdiff_t pos)
else if (NULL_PARENT (i))
error ("Point before start of properties");
else
- i = INTERVAL_PARENT (i);
+ {
+ SET_PARENT_POSITION (i);
+ i = INTERVAL_PARENT (i);
+ }
continue;
}
else if (pos >= INTERVAL_LAST_POS (i))
@@ -753,7 +766,10 @@ update_interval (register INTERVAL i, ptrdiff_t pos)
else if (NULL_PARENT (i))
error ("Point %"pD"d after end of properties", pos);
else
- i = INTERVAL_PARENT (i);
+ {
+ SET_PARENT_POSITION (i);
+ i = INTERVAL_PARENT (i);
+ }
continue;
}
else
@@ -1557,8 +1573,8 @@ graft_intervals_into_buffer (INTERVAL source, ptrdiff_t position,
if (!inherit && tree && length > 0)
{
XSETBUFFER (buf, buffer);
- set_text_properties_1 (make_number (position),
- make_number (position + length),
+ set_text_properties_1 (make_fixnum (position),
+ make_fixnum (position + length),
Qnil, buf,
find_interval (tree, position));
}
@@ -1793,7 +1809,7 @@ adjust_for_invis_intang (ptrdiff_t pos, ptrdiff_t test_offs, ptrdiff_t adj,
/* POS + ADJ would be beyond the buffer bounds, so do no adjustment. */
return pos;
- test_pos = make_number (pos + test_offs);
+ test_pos = make_fixnum (pos + test_offs);
invis_propval
= get_char_property_and_overlay (test_pos, Qinvisible, Qnil,
@@ -1806,7 +1822,7 @@ adjust_for_invis_intang (ptrdiff_t pos, ptrdiff_t test_offs, ptrdiff_t adj,
such that an insertion at POS would inherit it. */
&& (NILP (invis_overlay)
/* Invisible property is from a text-property. */
- ? (text_property_stickiness (Qinvisible, make_number (pos), Qnil)
+ ? (text_property_stickiness (Qinvisible, make_fixnum (pos), Qnil)
== (test_offs == 0 ? 1 : -1))
/* Invisible property is from an overlay. */
: (test_offs == 0
@@ -1926,8 +1942,8 @@ set_point_both (ptrdiff_t charpos, ptrdiff_t bytepos)
if (! NILP (intangible_propval))
{
- while (XINT (pos) > BEGV
- && EQ (Fget_char_property (make_number (XINT (pos) - 1),
+ while (XFIXNUM (pos) > BEGV
+ && EQ (Fget_char_property (make_fixnum (XFIXNUM (pos) - 1),
Qintangible, Qnil),
intangible_propval))
pos = Fprevious_char_property_change (pos, Qnil);
@@ -1937,7 +1953,7 @@ set_point_both (ptrdiff_t charpos, ptrdiff_t bytepos)
property is `front-sticky', perturb it to be one character
earlier -- this ensures that point can never move to the
beginning of an invisible/intangible/front-sticky region. */
- charpos = adjust_for_invis_intang (XINT (pos), 0, -1, 0);
+ charpos = adjust_for_invis_intang (XFIXNUM (pos), 0, -1, 0);
}
}
else
@@ -1954,12 +1970,12 @@ set_point_both (ptrdiff_t charpos, ptrdiff_t bytepos)
/* If preceding char is intangible,
skip forward over all chars with matching intangible property. */
- intangible_propval = Fget_char_property (make_number (charpos - 1),
+ intangible_propval = Fget_char_property (make_fixnum (charpos - 1),
Qintangible, Qnil);
if (! NILP (intangible_propval))
{
- while (XINT (pos) < ZV
+ while (XFIXNUM (pos) < ZV
&& EQ (Fget_char_property (pos, Qintangible, Qnil),
intangible_propval))
pos = Fnext_char_property_change (pos, Qnil);
@@ -1969,7 +1985,7 @@ set_point_both (ptrdiff_t charpos, ptrdiff_t bytepos)
property is `rear-sticky', perturb it to be one character
later -- this ensures that point can never move to the
end of an invisible/intangible/rear-sticky region. */
- charpos = adjust_for_invis_intang (XINT (pos), -1, 1, 0);
+ charpos = adjust_for_invis_intang (XFIXNUM (pos), -1, 1, 0);
}
}
@@ -2026,18 +2042,18 @@ set_point_both (ptrdiff_t charpos, ptrdiff_t bytepos)
enter_after = Qnil;
if (! EQ (leave_before, enter_before) && !NILP (leave_before))
- call2 (leave_before, make_number (old_position),
- make_number (charpos));
+ call2 (leave_before, make_fixnum (old_position),
+ make_fixnum (charpos));
if (! EQ (leave_after, enter_after) && !NILP (leave_after))
- call2 (leave_after, make_number (old_position),
- make_number (charpos));
+ call2 (leave_after, make_fixnum (old_position),
+ make_fixnum (charpos));
if (! EQ (enter_before, leave_before) && !NILP (enter_before))
- call2 (enter_before, make_number (old_position),
- make_number (charpos));
+ call2 (enter_before, make_fixnum (old_position),
+ make_fixnum (charpos));
if (! EQ (enter_after, leave_after) && !NILP (enter_after))
- call2 (enter_after, make_number (old_position),
- make_number (charpos));
+ call2 (enter_after, make_fixnum (old_position),
+ make_fixnum (charpos));
}
}
@@ -2055,7 +2071,7 @@ move_if_not_intangible (ptrdiff_t position)
if (! NILP (Vinhibit_point_motion_hooks))
/* If intangible is inhibited, always move point to POSITION. */
;
- else if (PT < position && XINT (pos) < ZV)
+ else if (PT < position && XFIXNUM (pos) < ZV)
{
/* We want to move forward, so check the text before POSITION. */
@@ -2065,23 +2081,23 @@ move_if_not_intangible (ptrdiff_t position)
/* If following char is intangible,
skip back over all chars with matching intangible property. */
if (! NILP (intangible_propval))
- while (XINT (pos) > BEGV
- && EQ (Fget_char_property (make_number (XINT (pos) - 1),
+ while (XFIXNUM (pos) > BEGV
+ && EQ (Fget_char_property (make_fixnum (XFIXNUM (pos) - 1),
Qintangible, Qnil),
intangible_propval))
pos = Fprevious_char_property_change (pos, Qnil);
}
- else if (XINT (pos) > BEGV)
+ else if (XFIXNUM (pos) > BEGV)
{
/* We want to move backward, so check the text after POSITION. */
- intangible_propval = Fget_char_property (make_number (XINT (pos) - 1),
+ intangible_propval = Fget_char_property (make_fixnum (XFIXNUM (pos) - 1),
Qintangible, Qnil);
/* If following char is intangible,
skip forward over all chars with matching intangible property. */
if (! NILP (intangible_propval))
- while (XINT (pos) < ZV
+ while (XFIXNUM (pos) < ZV
&& EQ (Fget_char_property (pos, Qintangible, Qnil),
intangible_propval))
pos = Fnext_char_property_change (pos, Qnil);
@@ -2096,7 +2112,7 @@ move_if_not_intangible (ptrdiff_t position)
try moving to POSITION (which means we actually move farther
if POSITION is inside of intangible text). */
- if (XINT (pos) != PT)
+ if (XFIXNUM (pos) != PT)
SET_PT (position);
}
diff --git a/src/intervals.h b/src/intervals.h
index 311ef79466f..e9166946d9a 100644
--- a/src/intervals.h
+++ b/src/intervals.h
@@ -29,14 +29,17 @@ INLINE_HEADER_BEGIN
struct interval
{
/* The first group of entries deal with the tree structure. */
-
ptrdiff_t total_length; /* Length of myself and both children. */
ptrdiff_t position; /* Cache of interval's character position. */
- /* This field is usually updated
- simultaneously with an interval
- traversal, there is no guarantee
- that it is valid for a random
- interval. */
+ /* This field is valid in the final
+ target interval returned by
+ find_interval, next_interval,
+ previous_interval and
+ update_interval. It cannot be
+ depended upon in any intermediate
+ intervals traversed by these
+ functions, or any other
+ interval. */
struct interval *left; /* Intervals which precede me. */
struct interval *right; /* Intervals which succeed me. */
@@ -116,7 +119,7 @@ struct interval
/* True if this is a default interval, which is the same as being null
or having no properties. */
-#define DEFAULT_INTERVAL_P(i) (!i || EQ ((i)->plist, Qnil))
+#define DEFAULT_INTERVAL_P(i) (!i || NILP ((i)->plist))
/* Test what type of parent we have. Three possibilities: another
interval, a buffer or string object, or NULL. */
diff --git a/src/json.c b/src/json.c
new file mode 100644
index 00000000000..5e1439f881a
--- /dev/null
+++ b/src/json.c
@@ -0,0 +1,1107 @@
+/* JSON parsing and serialization.
+
+Copyright (C) 2017-2019 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#include <errno.h>
+#include <stddef.h>
+#include <stdint.h>
+#include <stdlib.h>
+
+#include <jansson.h>
+
+#include "lisp.h"
+#include "buffer.h"
+#include "coding.h"
+
+#define JSON_HAS_ERROR_CODE (JANSSON_VERSION_HEX >= 0x020B00)
+
+#ifdef WINDOWSNT
+# include <windows.h>
+# include "w32common.h"
+# include "w32.h"
+
+DEF_DLL_FN (void, json_set_alloc_funcs,
+ (json_malloc_t malloc_fn, json_free_t free_fn));
+DEF_DLL_FN (void, json_delete, (json_t *json));
+DEF_DLL_FN (json_t *, json_array, (void));
+DEF_DLL_FN (int, json_array_append_new, (json_t *array, json_t *value));
+DEF_DLL_FN (size_t, json_array_size, (const json_t *array));
+DEF_DLL_FN (json_t *, json_object, (void));
+DEF_DLL_FN (int, json_object_set_new,
+ (json_t *object, const char *key, json_t *value));
+DEF_DLL_FN (json_t *, json_null, (void));
+DEF_DLL_FN (json_t *, json_true, (void));
+DEF_DLL_FN (json_t *, json_false, (void));
+DEF_DLL_FN (json_t *, json_integer, (json_int_t value));
+DEF_DLL_FN (json_t *, json_real, (double value));
+DEF_DLL_FN (json_t *, json_stringn, (const char *value, size_t len));
+DEF_DLL_FN (char *, json_dumps, (const json_t *json, size_t flags));
+DEF_DLL_FN (int, json_dump_callback,
+ (const json_t *json, json_dump_callback_t callback, void *data,
+ size_t flags));
+DEF_DLL_FN (json_int_t, json_integer_value, (const json_t *integer));
+DEF_DLL_FN (double, json_real_value, (const json_t *real));
+DEF_DLL_FN (const char *, json_string_value, (const json_t *string));
+DEF_DLL_FN (size_t, json_string_length, (const json_t *string));
+DEF_DLL_FN (json_t *, json_array_get, (const json_t *array, size_t index));
+DEF_DLL_FN (json_t *, json_object_get, (const json_t *object, const char *key));
+DEF_DLL_FN (size_t, json_object_size, (const json_t *object));
+DEF_DLL_FN (const char *, json_object_iter_key, (void *iter));
+DEF_DLL_FN (void *, json_object_iter, (json_t *object));
+DEF_DLL_FN (json_t *, json_object_iter_value, (void *iter));
+DEF_DLL_FN (void *, json_object_key_to_iter, (const char *key));
+DEF_DLL_FN (void *, json_object_iter_next, (json_t *object, void *iter));
+DEF_DLL_FN (json_t *, json_loads,
+ (const char *input, size_t flags, json_error_t *error));
+DEF_DLL_FN (json_t *, json_load_callback,
+ (json_load_callback_t callback, void *data, size_t flags,
+ json_error_t *error));
+
+/* This is called by json_decref, which is an inline function. */
+void json_delete(json_t *json)
+{
+ fn_json_delete (json);
+}
+
+static bool json_initialized;
+
+static bool
+init_json_functions (void)
+{
+ HMODULE library = w32_delayed_load (Qjson);
+
+ if (!library)
+ return false;
+
+ LOAD_DLL_FN (library, json_set_alloc_funcs);
+ LOAD_DLL_FN (library, json_delete);
+ LOAD_DLL_FN (library, json_array);
+ LOAD_DLL_FN (library, json_array_append_new);
+ LOAD_DLL_FN (library, json_array_size);
+ LOAD_DLL_FN (library, json_object);
+ LOAD_DLL_FN (library, json_object_set_new);
+ LOAD_DLL_FN (library, json_null);
+ LOAD_DLL_FN (library, json_true);
+ LOAD_DLL_FN (library, json_false);
+ LOAD_DLL_FN (library, json_integer);
+ LOAD_DLL_FN (library, json_real);
+ LOAD_DLL_FN (library, json_stringn);
+ LOAD_DLL_FN (library, json_dumps);
+ LOAD_DLL_FN (library, json_dump_callback);
+ LOAD_DLL_FN (library, json_integer_value);
+ LOAD_DLL_FN (library, json_real_value);
+ LOAD_DLL_FN (library, json_string_value);
+ LOAD_DLL_FN (library, json_string_length);
+ LOAD_DLL_FN (library, json_array_get);
+ LOAD_DLL_FN (library, json_object_get);
+ LOAD_DLL_FN (library, json_object_size);
+ LOAD_DLL_FN (library, json_object_iter_key);
+ LOAD_DLL_FN (library, json_object_iter);
+ LOAD_DLL_FN (library, json_object_iter_value);
+ LOAD_DLL_FN (library, json_object_key_to_iter);
+ LOAD_DLL_FN (library, json_object_iter_next);
+ LOAD_DLL_FN (library, json_loads);
+ LOAD_DLL_FN (library, json_load_callback);
+
+ init_json ();
+
+ return true;
+}
+
+#define json_set_alloc_funcs fn_json_set_alloc_funcs
+#define json_array fn_json_array
+#define json_array_append_new fn_json_array_append_new
+#define json_array_size fn_json_array_size
+#define json_object fn_json_object
+#define json_object_set_new fn_json_object_set_new
+#define json_null fn_json_null
+#define json_true fn_json_true
+#define json_false fn_json_false
+#define json_integer fn_json_integer
+#define json_real fn_json_real
+#define json_stringn fn_json_stringn
+#define json_dumps fn_json_dumps
+#define json_dump_callback fn_json_dump_callback
+#define json_integer_value fn_json_integer_value
+#define json_real_value fn_json_real_value
+#define json_string_value fn_json_string_value
+#define json_string_length fn_json_string_length
+#define json_array_get fn_json_array_get
+#define json_object_get fn_json_object_get
+#define json_object_size fn_json_object_size
+#define json_object_iter_key fn_json_object_iter_key
+#define json_object_iter fn_json_object_iter
+#define json_object_iter_value fn_json_object_iter_value
+#define json_object_key_to_iter fn_json_object_key_to_iter
+#define json_object_iter_next fn_json_object_iter_next
+#define json_loads fn_json_loads
+#define json_load_callback fn_json_load_callback
+
+#endif /* WINDOWSNT */
+
+/* We install a custom allocator so that we can avoid objects larger
+ than PTRDIFF_MAX. Such objects wouldn't play well with the rest of
+ Emacs's codebase, which generally uses ptrdiff_t for sizes and
+ indices. The other functions in this file also generally assume
+ that size_t values never exceed PTRDIFF_MAX.
+
+ In addition, we need to use a custom allocator because on
+ MS-Windows we replace malloc/free with our own functions, see
+ w32heap.c, so we must force the library to use our allocator, or
+ else we won't be able to free storage allocated by the library. */
+
+static void *
+json_malloc (size_t size)
+{
+ if (size > PTRDIFF_MAX)
+ {
+ errno = ENOMEM;
+ return NULL;
+ }
+ return malloc (size);
+}
+
+static void
+json_free (void *ptr)
+{
+ free (ptr);
+}
+
+void
+init_json (void)
+{
+ json_set_alloc_funcs (json_malloc, json_free);
+}
+
+#if !JSON_HAS_ERROR_CODE
+
+/* Return whether STRING starts with PREFIX. */
+
+static bool
+json_has_prefix (const char *string, const char *prefix)
+{
+ size_t string_len = strlen (string);
+ size_t prefix_len = strlen (prefix);
+ return string_len >= prefix_len && memcmp (string, prefix, prefix_len) == 0;
+}
+
+/* Return whether STRING ends with SUFFIX. */
+
+static bool
+json_has_suffix (const char *string, const char *suffix)
+{
+ size_t string_len = strlen (string);
+ size_t suffix_len = strlen (suffix);
+ return string_len >= suffix_len
+ && memcmp (string + string_len - suffix_len, suffix, suffix_len) == 0;
+}
+
+#endif
+
+/* Create a multibyte Lisp string from the UTF-8 string in
+ [DATA, DATA + SIZE). If the range [DATA, DATA + SIZE) does not
+ contain a valid UTF-8 string, an unspecified string is returned.
+ Note that all callers below either pass only value UTF-8 strings or
+ use this function for formatting error messages; in the latter case
+ correctness isn't critical. */
+
+static Lisp_Object
+json_make_string (const char *data, ptrdiff_t size)
+{
+ return code_convert_string (make_specified_string (data, -1, size, false),
+ Qutf_8_unix, Qt, false, true, true);
+}
+
+/* Create a multibyte Lisp string from the NUL-terminated UTF-8
+ string beginning at DATA. If the string is not a valid UTF-8
+ string, an unspecified string is returned. Note that all callers
+ below either pass only value UTF-8 strings or use this function for
+ formatting error messages; in the latter case correctness isn't
+ critical. */
+
+static Lisp_Object
+json_build_string (const char *data)
+{
+ return json_make_string (data, strlen (data));
+}
+
+/* Return a unibyte string containing the sequence of UTF-8 encoding
+ units of the UTF-8 representation of STRING. If STRING does not
+ represent a sequence of Unicode scalar values, return a string with
+ unspecified contents. */
+
+static Lisp_Object
+json_encode (Lisp_Object string)
+{
+ /* FIXME: Raise an error if STRING is not a scalar value
+ sequence. */
+ return code_convert_string (string, Qutf_8_unix, Qt, true, true, true);
+}
+
+static _Noreturn void
+json_out_of_memory (void)
+{
+ xsignal0 (Qjson_out_of_memory);
+}
+
+/* Signal a Lisp error corresponding to the JSON ERROR. */
+
+static _Noreturn void
+json_parse_error (const json_error_t *error)
+{
+ Lisp_Object symbol;
+#if JSON_HAS_ERROR_CODE
+ switch (json_error_code (error))
+ {
+ case json_error_premature_end_of_input:
+ symbol = Qjson_end_of_file;
+ break;
+ case json_error_end_of_input_expected:
+ symbol = Qjson_trailing_content;
+ break;
+ default:
+ symbol = Qjson_parse_error;
+ break;
+ }
+#else
+ if (json_has_suffix (error->text, "expected near end of file"))
+ symbol = Qjson_end_of_file;
+ else if (json_has_prefix (error->text, "end of file expected"))
+ symbol = Qjson_trailing_content;
+ else
+ symbol = Qjson_parse_error;
+#endif
+ xsignal (symbol,
+ list5 (json_build_string (error->text),
+ json_build_string (error->source), make_fixed_natnum (error->line),
+ make_fixed_natnum (error->column), make_fixed_natnum (error->position)));
+}
+
+static void
+json_release_object (void *object)
+{
+ json_decref (object);
+}
+
+/* Signal an error if OBJECT is not a string, or if OBJECT contains
+ embedded NUL characters. */
+
+static void
+check_string_without_embedded_nuls (Lisp_Object object)
+{
+ CHECK_STRING (object);
+ CHECK_TYPE (memchr (SDATA (object), '\0', SBYTES (object)) == NULL,
+ Qstring_without_embedded_nulls_p, object);
+}
+
+/* Signal an error of type `json-out-of-memory' if OBJECT is
+ NULL. */
+
+static json_t *
+json_check (json_t *object)
+{
+ if (object == NULL)
+ json_out_of_memory ();
+ return object;
+}
+
+/* If STRING is not a valid UTF-8 string, signal an error of type
+ `wrong-type-argument'. STRING must be a unibyte string. */
+
+static void
+json_check_utf8 (Lisp_Object string)
+{
+ CHECK_TYPE (utf8_string_p (string), Qutf_8_string_p, string);
+}
+
+enum json_object_type {
+ json_object_hashtable,
+ json_object_alist,
+ json_object_plist
+};
+
+struct json_configuration {
+ enum json_object_type object_type;
+ Lisp_Object null_object;
+ Lisp_Object false_object;
+};
+
+static json_t *lisp_to_json (Lisp_Object, struct json_configuration *conf);
+
+/* Convert a Lisp object to a toplevel JSON object (array or object). */
+
+static json_t *
+lisp_to_json_toplevel_1 (Lisp_Object lisp,
+ struct json_configuration *conf)
+{
+ json_t *json;
+ ptrdiff_t count;
+
+ if (VECTORP (lisp))
+ {
+ ptrdiff_t size = ASIZE (lisp);
+ json = json_check (json_array ());
+ count = SPECPDL_INDEX ();
+ record_unwind_protect_ptr (json_release_object, json);
+ for (ptrdiff_t i = 0; i < size; ++i)
+ {
+ int status
+ = json_array_append_new (json, lisp_to_json (AREF (lisp, i),
+ conf));
+ if (status == -1)
+ json_out_of_memory ();
+ }
+ eassert (json_array_size (json) == size);
+ }
+ else if (HASH_TABLE_P (lisp))
+ {
+ struct Lisp_Hash_Table *h = XHASH_TABLE (lisp);
+ json = json_check (json_object ());
+ count = SPECPDL_INDEX ();
+ record_unwind_protect_ptr (json_release_object, json);
+ for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
+ if (!NILP (HASH_HASH (h, i)))
+ {
+ Lisp_Object key = json_encode (HASH_KEY (h, i));
+ /* We can't specify the length, so the string must be
+ NUL-terminated. */
+ check_string_without_embedded_nuls (key);
+ const char *key_str = SSDATA (key);
+ /* Reject duplicate keys. These are possible if the hash
+ table test is not `equal'. */
+ if (json_object_get (json, key_str) != NULL)
+ wrong_type_argument (Qjson_value_p, lisp);
+ int status = json_object_set_new (json, key_str,
+ lisp_to_json (HASH_VALUE (h, i),
+ conf));
+ if (status == -1)
+ {
+ /* A failure can be caused either by an invalid key or
+ by low memory. */
+ json_check_utf8 (key);
+ json_out_of_memory ();
+ }
+ }
+ }
+ else if (NILP (lisp))
+ return json_check (json_object ());
+ else if (CONSP (lisp))
+ {
+ Lisp_Object tail = lisp;
+ json = json_check (json_object ());
+ count = SPECPDL_INDEX ();
+ record_unwind_protect_ptr (json_release_object, json);
+ bool is_plist = !CONSP (XCAR (tail));
+ FOR_EACH_TAIL (tail)
+ {
+ const char *key_str;
+ Lisp_Object value;
+ Lisp_Object key_symbol;
+ if (is_plist)
+ {
+ key_symbol = XCAR (tail);
+ tail = XCDR (tail);
+ CHECK_CONS (tail);
+ value = XCAR (tail);
+ if (EQ (tail, li.tortoise)) circular_list (lisp);
+ }
+ else
+ {
+ Lisp_Object pair = XCAR (tail);
+ CHECK_CONS (pair);
+ key_symbol = XCAR (pair);
+ value = XCDR (pair);
+ }
+ CHECK_SYMBOL (key_symbol);
+ Lisp_Object key = SYMBOL_NAME (key_symbol);
+ /* We can't specify the length, so the string must be
+ NUL-terminated. */
+ check_string_without_embedded_nuls (key);
+ key_str = SSDATA (key);
+ /* In plists, ensure leading ":" in keys is stripped. It
+ will be reconstructed later in `json_to_lisp'.*/
+ if (is_plist && ':' == key_str[0] && key_str[1])
+ {
+ key_str = &key_str[1];
+ }
+ /* Only add element if key is not already present. */
+ if (json_object_get (json, key_str) == NULL)
+ {
+ int status
+ = json_object_set_new (json, key_str, lisp_to_json (value,
+ conf));
+ if (status == -1)
+ json_out_of_memory ();
+ }
+ }
+ CHECK_LIST_END (tail, lisp);
+ }
+ else
+ wrong_type_argument (Qjson_value_p, lisp);
+
+ clear_unwind_protect (count);
+ unbind_to (count, Qnil);
+ return json;
+}
+
+/* Convert LISP to a toplevel JSON object (array or object). Signal
+ an error of type `wrong-type-argument' if LISP is not a vector,
+ hashtable, alist, or plist. */
+
+static json_t *
+lisp_to_json_toplevel (Lisp_Object lisp, struct json_configuration *conf)
+{
+ if (++lisp_eval_depth > max_lisp_eval_depth)
+ xsignal0 (Qjson_object_too_deep);
+ json_t *json = lisp_to_json_toplevel_1 (lisp, conf);
+ --lisp_eval_depth;
+ return json;
+}
+
+/* Convert LISP to any JSON object. Signal an error of type
+ `wrong-type-argument' if the type of LISP can't be converted to a
+ JSON object. */
+
+static json_t *
+lisp_to_json (Lisp_Object lisp, struct json_configuration *conf)
+{
+ if (EQ (lisp, conf->null_object))
+ return json_check (json_null ());
+ else if (EQ (lisp, conf->false_object))
+ return json_check (json_false ());
+ else if (EQ (lisp, Qt))
+ return json_check (json_true ());
+ else if (INTEGERP (lisp))
+ {
+ intmax_t low = TYPE_MINIMUM (json_int_t);
+ intmax_t high = TYPE_MAXIMUM (json_int_t);
+ intmax_t value;
+ if (! integer_to_intmax (lisp, &value) || value < low || high < value)
+ args_out_of_range_3 (lisp, make_int (low), make_int (high));
+ return json_check (json_integer (value));
+ }
+ else if (FLOATP (lisp))
+ return json_check (json_real (XFLOAT_DATA (lisp)));
+ else if (STRINGP (lisp))
+ {
+ Lisp_Object encoded = json_encode (lisp);
+ json_t *json = json_stringn (SSDATA (encoded), SBYTES (encoded));
+ if (json == NULL)
+ {
+ /* A failure can be caused either by an invalid string or by
+ low memory. */
+ json_check_utf8 (encoded);
+ json_out_of_memory ();
+ }
+ return json;
+ }
+
+ /* LISP now must be a vector, hashtable, alist, or plist. */
+ return lisp_to_json_toplevel (lisp, conf);
+}
+
+static void
+json_parse_args (ptrdiff_t nargs,
+ Lisp_Object *args,
+ struct json_configuration *conf,
+ bool configure_object_type)
+{
+ if ((nargs % 2) != 0)
+ wrong_type_argument (Qplistp, Flist (nargs, args));
+
+ /* Start from the back so keyword values appearing
+ first take precedence. */
+ for (ptrdiff_t i = nargs; i > 0; i -= 2) {
+ Lisp_Object key = args[i - 2];
+ Lisp_Object value = args[i - 1];
+ if (configure_object_type && EQ (key, QCobject_type))
+ {
+ if (EQ (value, Qhash_table))
+ conf->object_type = json_object_hashtable;
+ else if (EQ (value, Qalist))
+ conf->object_type = json_object_alist;
+ else if (EQ (value, Qplist))
+ conf->object_type = json_object_plist;
+ else
+ wrong_choice (list3 (Qhash_table, Qalist, Qplist), value);
+ }
+ else if (EQ (key, QCnull_object))
+ conf->null_object = value;
+ else if (EQ (key, QCfalse_object))
+ conf->false_object = value;
+ else if (configure_object_type)
+ wrong_choice (list3 (QCobject_type,
+ QCnull_object,
+ QCfalse_object),
+ value);
+ else
+ wrong_choice (list2 (QCnull_object,
+ QCfalse_object),
+ value);
+ }
+}
+
+DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, MANY,
+ NULL,
+ doc: /* Return the JSON representation of OBJECT as a string.
+
+OBJECT must be a vector, hashtable, alist, or plist and its elements
+can recursively contain the Lisp equivalents to the JSON null and
+false values, t, numbers, strings, or other vectors hashtables, alists
+or plists. t will be converted to the JSON true value. Vectors will
+be converted to JSON arrays, whereas hashtables, alists and plists are
+converted to JSON objects. Hashtable keys must be strings without
+embedded NUL characters and must be unique within each object. Alist
+and plist keys must be symbols; if a key is duplicate, the first
+instance is used.
+
+The Lisp equivalents to the JSON null and false values are
+configurable in the arguments ARGS, a list of keyword/argument pairs:
+
+The keyword argument `:null-object' specifies which object to use
+to represent a JSON null value. It defaults to `:null'.
+
+The keyword argument `:false-object' specifies which object to use to
+represent a JSON false value. It defaults to `:false'.
+
+In you specify the same value for `:null-object' and `:false-object',
+a potentially ambiguous situation, the JSON output will not contain
+any JSON false values.
+usage: (json-serialize OBJECT &rest ARGS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+{
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+#ifdef WINDOWSNT
+ if (!json_initialized)
+ {
+ Lisp_Object status;
+ json_initialized = init_json_functions ();
+ status = json_initialized ? Qt : Qnil;
+ Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
+ }
+ if (!json_initialized)
+ {
+ message1 ("jansson library not found");
+ return Qnil;
+ }
+#endif
+
+ struct json_configuration conf = {json_object_hashtable, QCnull, QCfalse};
+ json_parse_args (nargs - 1, args + 1, &conf, false);
+
+ json_t *json = lisp_to_json_toplevel (args[0], &conf);
+ record_unwind_protect_ptr (json_release_object, json);
+
+ /* If desired, we might want to add the following flags:
+ JSON_DECODE_ANY, JSON_ALLOW_NUL. */
+ char *string = json_dumps (json, JSON_COMPACT);
+ if (string == NULL)
+ json_out_of_memory ();
+ record_unwind_protect_ptr (json_free, string);
+
+ return unbind_to (count, json_build_string (string));
+}
+
+struct json_buffer_and_size
+{
+ const char *buffer;
+ ptrdiff_t size;
+ /* This tracks how many bytes were inserted by the callback since
+ json_dump_callback was called. */
+ ptrdiff_t inserted_bytes;
+};
+
+static Lisp_Object
+json_insert (void *data)
+{
+ struct json_buffer_and_size *buffer_and_size = data;
+ ptrdiff_t len = buffer_and_size->size;
+ ptrdiff_t inserted_bytes = buffer_and_size->inserted_bytes;
+ ptrdiff_t gap_size = GAP_SIZE - inserted_bytes;
+
+ /* Enlarge the gap if necessary. */
+ if (gap_size < len)
+ make_gap (len - gap_size);
+
+ /* Copy this chunk of data into the gap. */
+ memcpy ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE + inserted_bytes,
+ buffer_and_size->buffer, len);
+ buffer_and_size->inserted_bytes += len;
+ return Qnil;
+}
+
+struct json_insert_data
+{
+ /* This tracks how many bytes were inserted by the callback since
+ json_dump_callback was called. */
+ ptrdiff_t inserted_bytes;
+ /* nil if json_insert succeeded, otherwise the symbol
+ Qcatch_all_memory_full or a cons (ERROR-SYMBOL . ERROR-DATA). */
+ Lisp_Object error;
+};
+
+/* Callback for json_dump_callback that inserts a JSON representation
+ as a unibyte string into the gap. DATA must point to a structure
+ of type json_insert_data. This function may not exit nonlocally.
+ It catches all nonlocal exits and stores them in data->error for
+ reraising. */
+
+static int
+json_insert_callback (const char *buffer, size_t size, void *data)
+{
+ struct json_insert_data *d = data;
+ struct json_buffer_and_size buffer_and_size
+ = {.buffer = buffer, .size = size, .inserted_bytes = d->inserted_bytes};
+ d->error = internal_catch_all (json_insert, &buffer_and_size, Fidentity);
+ d->inserted_bytes = buffer_and_size.inserted_bytes;
+ return NILP (d->error) ? 0 : -1;
+}
+
+DEFUN ("json-insert", Fjson_insert, Sjson_insert, 1, MANY,
+ NULL,
+ doc: /* Insert the JSON representation of OBJECT before point.
+This is the same as (insert (json-serialize OBJECT)), but potentially
+faster. See the function `json-serialize' for allowed values of
+OBJECT.
+usage: (json-insert OBJECT &rest ARGS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+{
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+#ifdef WINDOWSNT
+ if (!json_initialized)
+ {
+ Lisp_Object status;
+ json_initialized = init_json_functions ();
+ status = json_initialized ? Qt : Qnil;
+ Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
+ }
+ if (!json_initialized)
+ {
+ message1 ("jansson library not found");
+ return Qnil;
+ }
+#endif
+
+ struct json_configuration conf = {json_object_hashtable, QCnull, QCfalse};
+ json_parse_args (nargs - 1, args + 1, &conf, false);
+
+ json_t *json = lisp_to_json (args[0], &conf);
+ record_unwind_protect_ptr (json_release_object, json);
+
+ prepare_to_modify_buffer (PT, PT, NULL);
+ move_gap_both (PT, PT_BYTE);
+ struct json_insert_data data;
+ data.inserted_bytes = 0;
+ /* If desired, we might want to add the following flags:
+ JSON_DECODE_ANY, JSON_ALLOW_NUL. */
+ int status
+ /* Could have used json_dumpb, but that became available only in
+ Jansson 2.10, whereas we want to support 2.7 and upward. */
+ = json_dump_callback (json, json_insert_callback, &data, JSON_COMPACT);
+ if (status == -1)
+ {
+ if (CONSP (data.error))
+ xsignal (XCAR (data.error), XCDR (data.error));
+ else
+ json_out_of_memory ();
+ }
+
+ ptrdiff_t inserted = 0;
+ ptrdiff_t inserted_bytes = data.inserted_bytes;
+ if (inserted_bytes > 0)
+ {
+ /* Make the inserted text part of the buffer, as unibyte text. */
+ GAP_SIZE -= inserted_bytes;
+ GPT += inserted_bytes;
+ GPT_BYTE += inserted_bytes;
+ ZV += inserted_bytes;
+ ZV_BYTE += inserted_bytes;
+ Z += inserted_bytes;
+ Z_BYTE += inserted_bytes;
+
+ if (GAP_SIZE > 0)
+ /* Put an anchor to ensure multi-byte form ends at gap. */
+ *GPT_ADDR = 0;
+
+ /* If required, decode the stuff we've read into the gap. */
+ struct coding_system coding;
+ /* JSON strings are UTF-8 encoded strings. If for some reason
+ the text returned by the Jansson library includes invalid
+ byte sequences, they will be represented by raw bytes in the
+ buffer text. */
+ setup_coding_system (Qutf_8_unix, &coding);
+ coding.dst_multibyte =
+ !NILP (BVAR (current_buffer, enable_multibyte_characters));
+ if (CODING_MAY_REQUIRE_DECODING (&coding))
+ {
+ move_gap_both (PT, PT_BYTE);
+ GAP_SIZE += inserted_bytes;
+ ZV_BYTE -= inserted_bytes;
+ Z_BYTE -= inserted_bytes;
+ ZV -= inserted_bytes;
+ Z -= inserted_bytes;
+ decode_coding_gap (&coding, inserted_bytes, inserted_bytes);
+ inserted = coding.produced_char;
+ }
+ else
+ {
+ /* The target buffer is unibyte, so we don't need to decode. */
+ invalidate_buffer_caches (current_buffer,
+ PT, PT + inserted_bytes);
+ adjust_after_insert (PT, PT_BYTE,
+ PT + inserted_bytes,
+ PT_BYTE + inserted_bytes,
+ inserted_bytes);
+ inserted = inserted_bytes;
+ }
+ }
+
+ /* Call after-change hooks. */
+ signal_after_change (PT, 0, inserted);
+ if (inserted > 0)
+ {
+ update_compositions (PT, PT, CHECK_BORDER);
+ /* Move point to after the inserted text. */
+ SET_PT_BOTH (PT + inserted, PT_BYTE + inserted_bytes);
+ }
+
+ return unbind_to (count, Qnil);
+}
+
+/* Convert a JSON object to a Lisp object. */
+
+static Lisp_Object ARG_NONNULL ((1))
+json_to_lisp (json_t *json, struct json_configuration *conf)
+{
+ switch (json_typeof (json))
+ {
+ case JSON_NULL:
+ return conf->null_object;
+ case JSON_FALSE:
+ return conf->false_object;
+ case JSON_TRUE:
+ return Qt;
+ case JSON_INTEGER:
+ {
+ json_int_t i = json_integer_value (json);
+ return INT_TO_INTEGER (i);
+ }
+ case JSON_REAL:
+ return make_float (json_real_value (json));
+ case JSON_STRING:
+ return json_make_string (json_string_value (json),
+ json_string_length (json));
+ case JSON_ARRAY:
+ {
+ if (++lisp_eval_depth > max_lisp_eval_depth)
+ xsignal0 (Qjson_object_too_deep);
+ size_t size = json_array_size (json);
+ if (PTRDIFF_MAX < size)
+ overflow_error ();
+ Lisp_Object result = make_vector (size, Qunbound);
+ for (ptrdiff_t i = 0; i < size; ++i)
+ ASET (result, i,
+ json_to_lisp (json_array_get (json, i), conf));
+ --lisp_eval_depth;
+ return result;
+ }
+ case JSON_OBJECT:
+ {
+ if (++lisp_eval_depth > max_lisp_eval_depth)
+ xsignal0 (Qjson_object_too_deep);
+ Lisp_Object result;
+ switch (conf->object_type)
+ {
+ case json_object_hashtable:
+ {
+ size_t size = json_object_size (json);
+ if (FIXNUM_OVERFLOW_P (size))
+ overflow_error ();
+ result = CALLN (Fmake_hash_table, QCtest, Qequal, QCsize,
+ make_fixed_natnum (size));
+ struct Lisp_Hash_Table *h = XHASH_TABLE (result);
+ const char *key_str;
+ json_t *value;
+ json_object_foreach (json, key_str, value)
+ {
+ Lisp_Object key = json_build_string (key_str);
+ EMACS_UINT hash;
+ ptrdiff_t i = hash_lookup (h, key, &hash);
+ /* Keys in JSON objects are unique, so the key can't
+ be present yet. */
+ eassert (i < 0);
+ hash_put (h, key, json_to_lisp (value, conf), hash);
+ }
+ break;
+ }
+ case json_object_alist:
+ {
+ result = Qnil;
+ const char *key_str;
+ json_t *value;
+ json_object_foreach (json, key_str, value)
+ {
+ Lisp_Object key = Fintern (json_build_string (key_str), Qnil);
+ result
+ = Fcons (Fcons (key, json_to_lisp (value, conf)),
+ result);
+ }
+ result = Fnreverse (result);
+ break;
+ }
+ case json_object_plist:
+ {
+ result = Qnil;
+ const char *key_str;
+ json_t *value;
+ json_object_foreach (json, key_str, value)
+ {
+ USE_SAFE_ALLOCA;
+ ptrdiff_t key_str_len = strlen (key_str);
+ char *keyword_key_str = SAFE_ALLOCA (1 + key_str_len + 1);
+ keyword_key_str[0] = ':';
+ strcpy (&keyword_key_str[1], key_str);
+ Lisp_Object key = intern_1 (keyword_key_str, key_str_len + 1);
+ /* Build the plist as value-key since we're going to
+ reverse it in the end.*/
+ result = Fcons (key, result);
+ result = Fcons (json_to_lisp (value, conf), result);
+ SAFE_FREE ();
+ }
+ result = Fnreverse (result);
+ break;
+ }
+ default:
+ /* Can't get here. */
+ emacs_abort ();
+ }
+ --lisp_eval_depth;
+ return result;
+ }
+ }
+ /* Can't get here. */
+ emacs_abort ();
+}
+
+DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, MANY,
+ NULL,
+ doc: /* Parse the JSON STRING into a Lisp object.
+
+This is essentially the reverse operation of `json-serialize', which
+see. The returned object will be a vector, hashtable, alist, or
+plist. Its elements will be the JSON null value, the JSON false
+value, t, numbers, strings, or further vectors, hashtables, alists, or
+plists. If there are duplicate keys in an object, all but the last
+one are ignored. If STRING doesn't contain a valid JSON object, an
+error of type `json-parse-error' is signaled. The arguments ARGS are
+a list of keyword/argument pairs:
+
+The keyword argument `:object-type' specifies which Lisp type is used
+to represent objects; it can be `hash-table', `alist' or `plist'.
+
+The keyword argument `:null-object' specifies which object to use
+to represent a JSON null value. It defaults to `:null'.
+
+The keyword argument `:false-object' specifies which object to use to
+represent a JSON false value. It defaults to `:false'.
+usage: (json-parse-string STRING &rest ARGS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+{
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+#ifdef WINDOWSNT
+ if (!json_initialized)
+ {
+ Lisp_Object status;
+ json_initialized = init_json_functions ();
+ status = json_initialized ? Qt : Qnil;
+ Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
+ }
+ if (!json_initialized)
+ {
+ message1 ("jansson library not found");
+ return Qnil;
+ }
+#endif
+
+ Lisp_Object string = args[0];
+ Lisp_Object encoded = json_encode (string);
+ check_string_without_embedded_nuls (encoded);
+ struct json_configuration conf = {json_object_hashtable, QCnull, QCfalse};
+ json_parse_args (nargs - 1, args + 1, &conf, true);
+
+ json_error_t error;
+ json_t *object = json_loads (SSDATA (encoded), 0, &error);
+ if (object == NULL)
+ json_parse_error (&error);
+
+ /* Avoid leaking the object in case of further errors. */
+ if (object != NULL)
+ record_unwind_protect_ptr (json_release_object, object);
+
+ return unbind_to (count, json_to_lisp (object, &conf));
+}
+
+struct json_read_buffer_data
+{
+ /* Byte position of position to read the next chunk from. */
+ ptrdiff_t point;
+};
+
+/* Callback for json_load_callback that reads from the current buffer.
+ DATA must point to a structure of type json_read_buffer_data.
+ data->point must point to the byte position to read from; after
+ reading, data->point is advanced accordingly. The buffer point
+ itself is ignored. This function may not exit nonlocally. */
+
+static size_t
+json_read_buffer_callback (void *buffer, size_t buflen, void *data)
+{
+ struct json_read_buffer_data *d = data;
+
+ /* First, parse from point to the gap or the end of the accessible
+ portion, whatever is closer. */
+ ptrdiff_t point = d->point;
+ ptrdiff_t end = BUFFER_CEILING_OF (point) + 1;
+ ptrdiff_t count = end - point;
+ if (buflen < count)
+ count = buflen;
+ memcpy (buffer, BYTE_POS_ADDR (point), count);
+ d->point += count;
+ return count;
+}
+
+DEFUN ("json-parse-buffer", Fjson_parse_buffer, Sjson_parse_buffer,
+ 0, MANY, NULL,
+ doc: /* Read JSON object from current buffer starting at point.
+This is similar to `json-parse-string', which see. Move point after
+the end of the object if parsing was successful. On error, point is
+not moved.
+usage: (json-parse-buffer &rest args) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+{
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+#ifdef WINDOWSNT
+ if (!json_initialized)
+ {
+ Lisp_Object status;
+ json_initialized = init_json_functions ();
+ status = json_initialized ? Qt : Qnil;
+ Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
+ }
+ if (!json_initialized)
+ {
+ message1 ("jansson library not found");
+ return Qnil;
+ }
+#endif
+
+ struct json_configuration conf = {json_object_hashtable, QCnull, QCfalse};
+ json_parse_args (nargs, args, &conf, true);
+
+ ptrdiff_t point = PT_BYTE;
+ struct json_read_buffer_data data = {.point = point};
+ json_error_t error;
+ json_t *object = json_load_callback (json_read_buffer_callback, &data,
+ JSON_DISABLE_EOF_CHECK, &error);
+
+ if (object == NULL)
+ json_parse_error (&error);
+
+ /* Avoid leaking the object in case of further errors. */
+ record_unwind_protect_ptr (json_release_object, object);
+
+ /* Convert and then move point only if everything succeeded. */
+ Lisp_Object lisp = json_to_lisp (object, &conf);
+
+ /* Adjust point by how much we just read. */
+ point += error.position;
+ SET_PT_BOTH (BYTE_TO_CHAR (point), point);
+
+ return unbind_to (count, lisp);
+}
+
+/* Simplified version of 'define-error' that works with pure
+ objects. */
+
+static void
+define_error (Lisp_Object name, const char *message, Lisp_Object parent)
+{
+ eassert (SYMBOLP (name));
+ eassert (SYMBOLP (parent));
+ Lisp_Object parent_conditions = Fget (parent, Qerror_conditions);
+ eassert (CONSP (parent_conditions));
+ eassert (!NILP (Fmemq (parent, parent_conditions)));
+ eassert (NILP (Fmemq (name, parent_conditions)));
+ Fput (name, Qerror_conditions, pure_cons (name, parent_conditions));
+ Fput (name, Qerror_message, build_pure_c_string (message));
+}
+
+void
+syms_of_json (void)
+{
+ DEFSYM (QCnull, ":null");
+ DEFSYM (QCfalse, ":false");
+
+ DEFSYM (Qstring_without_embedded_nulls_p, "string-without-embedded-nulls-p");
+ DEFSYM (Qjson_value_p, "json-value-p");
+ DEFSYM (Qutf_8_string_p, "utf-8-string-p");
+
+ DEFSYM (Qjson_error, "json-error");
+ DEFSYM (Qjson_out_of_memory, "json-out-of-memory");
+ DEFSYM (Qjson_parse_error, "json-parse-error");
+ DEFSYM (Qjson_end_of_file, "json-end-of-file");
+ DEFSYM (Qjson_trailing_content, "json-trailing-content");
+ DEFSYM (Qjson_object_too_deep, "json-object-too-deep");
+ define_error (Qjson_error, "generic JSON error", Qerror);
+ define_error (Qjson_out_of_memory,
+ "not enough memory for creating JSON object", Qjson_error);
+ define_error (Qjson_parse_error, "could not parse JSON stream",
+ Qjson_error);
+ define_error (Qjson_end_of_file, "end of JSON stream", Qjson_parse_error);
+ define_error (Qjson_trailing_content, "trailing content after JSON stream",
+ Qjson_parse_error);
+ define_error (Qjson_object_too_deep,
+ "object cyclic or Lisp evaluation too deep", Qjson_error);
+
+ DEFSYM (Qpure, "pure");
+ DEFSYM (Qside_effect_free, "side-effect-free");
+
+ DEFSYM (Qjson_serialize, "json-serialize");
+ DEFSYM (Qjson_parse_string, "json-parse-string");
+ Fput (Qjson_serialize, Qpure, Qt);
+ Fput (Qjson_serialize, Qside_effect_free, Qt);
+ Fput (Qjson_parse_string, Qpure, Qt);
+ Fput (Qjson_parse_string, Qside_effect_free, Qt);
+
+ DEFSYM (QCobject_type, ":object-type");
+ DEFSYM (QCnull_object, ":null-object");
+ DEFSYM (QCfalse_object, ":false-object");
+ DEFSYM (Qalist, "alist");
+ DEFSYM (Qplist, "plist");
+
+ defsubr (&Sjson_serialize);
+ defsubr (&Sjson_insert);
+ defsubr (&Sjson_parse_string);
+ defsubr (&Sjson_parse_buffer);
+}
diff --git a/src/keyboard.c b/src/keyboard.c
index 282eac72b92..8fb6db987b5 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -43,6 +43,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "systime.h"
#include "atimer.h"
#include "process.h"
+#include "menu.h"
#include <errno.h>
#ifdef HAVE_PTHREAD
@@ -67,6 +68,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <ignore-value.h>
+#include "pdumper.h"
+
#ifdef HAVE_WINDOW_SYSTEM
#include TERM_HEADER
#endif /* HAVE_WINDOW_SYSTEM */
@@ -91,7 +94,7 @@ volatile int interrupt_input_blocked;
The maybe_quit function checks this. */
volatile bool pending_signals;
-#define KBD_BUFFER_SIZE 4096
+enum { KBD_BUFFER_SIZE = 4096 };
KBOARD *initial_kboard;
KBOARD *current_kboard;
@@ -205,7 +208,7 @@ struct buffer *buffer_before_last_command_or_undo;
/* Value of num_nonmacro_input_events as of last auto save. */
-static EMACS_INT last_auto_save;
+static intmax_t last_auto_save;
/* The value of point when the last command was started. */
static ptrdiff_t last_point_position;
@@ -285,15 +288,11 @@ static bool input_was_pending;
static union buffered_input_event kbd_buffer[KBD_BUFFER_SIZE];
/* Pointer to next available character in kbd_buffer.
- If kbd_fetch_ptr == kbd_store_ptr, the buffer is empty.
- This may be kbd_buffer + KBD_BUFFER_SIZE, meaning that the
- next available char is in kbd_buffer[0]. */
+ If kbd_fetch_ptr == kbd_store_ptr, the buffer is empty. */
static union buffered_input_event *kbd_fetch_ptr;
-/* Pointer to next place to store character in kbd_buffer. This
- may be kbd_buffer + KBD_BUFFER_SIZE, meaning that the next
- character should go in kbd_buffer[0]. */
-static union buffered_input_event *volatile kbd_store_ptr;
+/* Pointer to next place to store character in kbd_buffer. */
+static union buffered_input_event *kbd_store_ptr;
/* The above pair of variables forms a "queue empty" flag. When we
enqueue a non-hook event, we increment kbd_store_ptr. When we
@@ -301,8 +300,7 @@ static union buffered_input_event *volatile kbd_store_ptr;
there is input available if the two pointers are not equal.
Why not just have a flag set and cleared by the enqueuing and
- dequeuing functions? Such a flag could be screwed up by interrupts
- at inopportune times. */
+ dequeuing functions? The code is a bit simpler this way. */
static void recursive_edit_unwind (Lisp_Object buffer);
static Lisp_Object command_loop (void);
@@ -359,9 +357,7 @@ static Lisp_Object modify_event_symbol (ptrdiff_t, int, Lisp_Object,
Lisp_Object *, ptrdiff_t);
static Lisp_Object make_lispy_switch_frame (Lisp_Object);
static Lisp_Object make_lispy_focus_in (Lisp_Object);
-#ifdef HAVE_WINDOW_SYSTEM
static Lisp_Object make_lispy_focus_out (Lisp_Object);
-#endif /* HAVE_WINDOW_SYSTEM */
static bool help_char_p (Lisp_Object);
static void save_getcjmp (sys_jmp_buf);
static void restore_getcjmp (void *);
@@ -376,6 +372,29 @@ static void deliver_user_signal (int);
static char *find_user_signal_name (int);
static void store_user_signal_events (void);
+/* Advance or retreat a buffered input event pointer. */
+
+static union buffered_input_event *
+next_kbd_event (union buffered_input_event *ptr)
+{
+ return ptr == kbd_buffer + KBD_BUFFER_SIZE - 1 ? kbd_buffer : ptr + 1;
+}
+
+static union buffered_input_event *
+prev_kbd_event (union buffered_input_event *ptr)
+{
+ return ptr == kbd_buffer ? kbd_buffer + KBD_BUFFER_SIZE - 1 : ptr - 1;
+}
+
+/* Like EVENT_START, but assume EVENT is an event.
+ This pacifies gcc -Wnull-dereference, which might otherwise
+ complain about earlier checks that EVENT is indeed an event. */
+static Lisp_Object
+xevent_start (Lisp_Object event)
+{
+ return XCAR (XCDR (event));
+}
+
/* These setters are used only in this file, so they can be private. */
static void
kset_echo_string (struct kboard *kb, Lisp_Object val)
@@ -433,7 +452,7 @@ static bool
echo_keystrokes_p (void)
{
return (FLOATP (Vecho_keystrokes) ? XFLOAT_DATA (Vecho_keystrokes) > 0.0
- : INTEGERP (Vecho_keystrokes) ? XINT (Vecho_keystrokes) > 0
+ : FIXNUMP (Vecho_keystrokes) ? XFIXNUM (Vecho_keystrokes) > 0
: false);
}
@@ -458,8 +477,8 @@ echo_add_key (Lisp_Object c)
/* If someone has passed us a composite event, use its head symbol. */
c = EVENT_HEAD (c);
- if (INTEGERP (c))
- ptr = push_key_description (XINT (c), ptr);
+ if (FIXNUMP (c))
+ ptr = push_key_description (XFIXNUM (c), ptr);
else if (SYMBOLP (c))
{
Lisp_Object name = SYMBOL_NAME (c);
@@ -527,13 +546,13 @@ echo_dash (void)
{
Lisp_Object last_char, prev_char, idx;
- idx = make_number (SCHARS (KVAR (current_kboard, echo_string)) - 2);
+ idx = make_fixnum (SCHARS (KVAR (current_kboard, echo_string)) - 2);
prev_char = Faref (KVAR (current_kboard, echo_string), idx);
- idx = make_number (SCHARS (KVAR (current_kboard, echo_string)) - 1);
+ idx = make_fixnum (SCHARS (KVAR (current_kboard, echo_string)) - 1);
last_char = Faref (KVAR (current_kboard, echo_string), idx);
- if (XINT (last_char) == '-' && XINT (prev_char) != ' ')
+ if (XFIXNUM (last_char) == '-' && XFIXNUM (prev_char) != ' ')
return;
}
@@ -635,7 +654,7 @@ echo_truncate (ptrdiff_t nchars)
if (STRINGP (es) && SCHARS (es) > nchars)
kset_echo_string (current_kboard,
Fsubstring (KVAR (current_kboard, echo_string),
- make_number (0), make_number (nchars)));
+ make_fixnum (0), make_fixnum (nchars)));
truncate_echo_area (nchars);
}
@@ -718,7 +737,8 @@ void
force_auto_save_soon (void)
{
last_auto_save = - auto_save_interval - 1;
-
+ /* FIXME: What's the relationship between forcing auto-save and adding
+ a buffer-switch event? */
record_asynch_buffer_change ();
}
#endif
@@ -778,35 +798,6 @@ recursive_edit_unwind (Lisp_Object buffer)
}
-#if 0 /* These two functions are now replaced with
- temporarily_switch_to_single_kboard. */
-static void
-any_kboard_state ()
-{
-#if 0 /* Theory: if there's anything in Vunread_command_events,
- it will right away be read by read_key_sequence,
- and then if we do switch KBOARDS, it will go into the side
- queue then. So we don't need to do anything special here -- rms. */
- if (CONSP (Vunread_command_events))
- {
- current_kboard->kbd_queue
- = nconc2 (Vunread_command_events, current_kboard->kbd_queue);
- current_kboard->kbd_queue_has_data = true;
- }
- Vunread_command_events = Qnil;
-#endif
- single_kboard = false;
-}
-
-/* Switch to the single-kboard state, making current_kboard
- the only KBOARD from which further input is accepted. */
-
-void
-single_kboard_state ()
-{
- single_kboard = true;
-}
-#endif
/* If we're in single_kboard state for kboard KBOARD,
get out of it. */
@@ -905,16 +896,6 @@ temporarily_switch_to_single_kboard (struct frame *f)
record_unwind_protect_int (restore_kboard_configuration, was_locked);
}
-#if 0 /* This function is not needed anymore. */
-void
-record_single_kboard_state ()
-{
- if (single_kboard)
- push_kboard (current_kboard);
- record_unwind_protect_int (restore_kboard_configuration, single_kboard);
-}
-#endif
-
static void
restore_kboard_configuration (int was_locked)
{
@@ -976,7 +957,7 @@ cmd_error (Lisp_Object data)
Vquit_flag = Qnil;
Vinhibit_quit = Qnil;
- return make_number (0);
+ return make_fixnum (0);
}
/* Take actions on handling an error. DATA is the data that describes
@@ -1036,7 +1017,7 @@ Default value of `command-error-function'. */)
print_error_message (data, Qexternal_debugging_output,
SSDATA (context), signal);
Fterpri (Qexternal_debugging_output, Qnil);
- Fkill_emacs (make_number (-1));
+ Fkill_emacs (make_fixnum (-1));
}
else
{
@@ -1233,7 +1214,7 @@ some_mouse_moved (void)
if (ignore_mouse_drag_p)
{
- /* ignore_mouse_drag_p = 0; */
+ /* ignore_mouse_drag_p = false; */
return 0;
}
@@ -1250,14 +1231,15 @@ some_mouse_moved (void)
/* This is the actual command reading loop,
sans error-handling encapsulation. */
-static int read_key_sequence (Lisp_Object *, int, Lisp_Object,
+enum { READ_KEY_ELTS = 30 };
+static int read_key_sequence (Lisp_Object *, Lisp_Object,
bool, bool, bool, bool);
static void adjust_point_for_property (ptrdiff_t, bool);
Lisp_Object
command_loop_1 (void)
{
- EMACS_INT prev_modiff = 0;
+ modiff_count prev_modiff = 0;
struct buffer *prev_buffer = NULL;
bool already_adjusted = 0;
@@ -1298,11 +1280,9 @@ command_loop_1 (void)
if (!CONSP (last_command_event))
kset_last_repeatable_command (current_kboard, Vreal_this_command);
- while (1)
+ while (true)
{
Lisp_Object cmd;
- Lisp_Object keybuf[30];
- int i;
if (! FRAME_LIVE_P (XFRAME (selected_frame)))
Fkill_emacs (Qnil);
@@ -1322,7 +1302,7 @@ command_loop_1 (void)
loop. (This flag is set in xdisp.c whenever the tool bar is
resized, because the resize moves text up or down, and would
generate false mouse drag events if we don't ignore them.) */
- ignore_mouse_drag_p = 0;
+ ignore_mouse_drag_p = false;
/* If minibuffer on and echo area in use,
wait a short time and redraw minibuffer. */
@@ -1349,7 +1329,7 @@ command_loop_1 (void)
if (!NILP (Vquit_flag))
{
Vquit_flag = Qnil;
- Vunread_command_events = list1 (make_number (quit_char));
+ Vunread_command_events = list1i (quit_char);
}
}
@@ -1365,8 +1345,9 @@ command_loop_1 (void)
Vthis_command_keys_shift_translated = Qnil;
/* Read next key sequence; i gets its length. */
- i = read_key_sequence (keybuf, ARRAYELTS (keybuf),
- Qnil, 0, 1, 1, 0);
+ raw_keybuf_count = 0;
+ Lisp_Object keybuf[READ_KEY_ELTS];
+ int i = read_key_sequence (keybuf, Qnil, false, true, true, false);
/* A filter may have run while we were reading the input. */
if (! FRAME_LIVE_P (XFRAME (selected_frame)))
@@ -1496,8 +1477,12 @@ command_loop_1 (void)
safe_run_hooks (Qpost_command_hook);
/* If displaying a message, resize the echo area window to fit
- that message's size exactly. */
- if (!NILP (echo_area_buffer[0]))
+ that message's size exactly. Do this only if the echo area
+ window is the minibuffer window of the selected frame. See
+ Bug#34317. */
+ if (!NILP (echo_area_buffer[0])
+ && (EQ (echo_area_window,
+ FRAME_MINIBUF_WINDOW (XFRAME (selected_frame)))))
resize_echo_area_exactly ();
/* If there are warnings waiting, process them. */
@@ -1556,7 +1541,7 @@ command_loop_1 (void)
{
Lisp_Object txt
= call1 (Fsymbol_value (Qregion_extract_function), Qnil);
- if (XINT (Flength (txt)) > 0)
+ if (XFIXNUM (Flength (txt)) > 0)
/* Don't set empty selections. */
call2 (Qgui_set_selection, QPRIMARY, txt);
}
@@ -1602,16 +1587,14 @@ command_loop_1 (void)
Lisp_Object
read_menu_command (void)
{
- Lisp_Object keybuf[30];
ptrdiff_t count = SPECPDL_INDEX ();
- int i;
/* We don't want to echo the keystrokes while navigating the
menus. */
- specbind (Qecho_keystrokes, make_number (0));
+ specbind (Qecho_keystrokes, make_fixnum (0));
- i = read_key_sequence (keybuf, ARRAYELTS (keybuf),
- Qnil, 0, 1, 1, 1);
+ Lisp_Object keybuf[READ_KEY_ELTS];
+ int i = read_key_sequence (keybuf, Qnil, false, true, true, true);
unbind_to (count, Qnil);
@@ -1659,7 +1642,7 @@ adjust_point_for_property (ptrdiff_t last_pt, bool modified)
if (check_display
&& PT > BEGV && PT < ZV
&& !NILP (val = get_char_property_and_overlay
- (make_number (PT), Qdisplay, selected_window,
+ (make_fixnum (PT), Qdisplay, selected_window,
&overlay))
&& display_prop_intangible_p (val, overlay, PT, PT_BYTE)
&& (!OVERLAYP (overlay)
@@ -1696,12 +1679,12 @@ adjust_point_for_property (ptrdiff_t last_pt, bool modified)
than skip both boundaries. However, this code
also stops anywhere in a non-sticky text-property,
which breaks (e.g.) Org mode. */
- && (val = Fget_pos_property (make_number (end),
+ && (val = Fget_pos_property (make_fixnum (end),
Qinvisible, Qnil),
TEXT_PROP_MEANS_INVISIBLE (val))
#endif
&& !NILP (val = get_char_property_and_overlay
- (make_number (end), Qinvisible, Qnil, &overlay))
+ (make_fixnum (end), Qinvisible, Qnil, &overlay))
&& (inv = TEXT_PROP_MEANS_INVISIBLE (val)))
{
ellipsis = ellipsis || inv > 1
@@ -1709,17 +1692,17 @@ adjust_point_for_property (ptrdiff_t last_pt, bool modified)
&& (!NILP (Foverlay_get (overlay, Qafter_string))
|| !NILP (Foverlay_get (overlay, Qbefore_string))));
tmp = Fnext_single_char_property_change
- (make_number (end), Qinvisible, Qnil, Qnil);
- end = NATNUMP (tmp) ? XFASTINT (tmp) : ZV;
+ (make_fixnum (end), Qinvisible, Qnil, Qnil);
+ end = FIXNATP (tmp) ? XFIXNAT (tmp) : ZV;
}
while (beg > BEGV
#if 0
- && (val = Fget_pos_property (make_number (beg),
+ && (val = Fget_pos_property (make_fixnum (beg),
Qinvisible, Qnil),
TEXT_PROP_MEANS_INVISIBLE (val))
#endif
&& !NILP (val = get_char_property_and_overlay
- (make_number (beg - 1), Qinvisible, Qnil, &overlay))
+ (make_fixnum (beg - 1), Qinvisible, Qnil, &overlay))
&& (inv = TEXT_PROP_MEANS_INVISIBLE (val)))
{
ellipsis = ellipsis || inv > 1
@@ -1727,8 +1710,8 @@ adjust_point_for_property (ptrdiff_t last_pt, bool modified)
&& (!NILP (Foverlay_get (overlay, Qafter_string))
|| !NILP (Foverlay_get (overlay, Qbefore_string))));
tmp = Fprevious_single_char_property_change
- (make_number (beg), Qinvisible, Qnil, Qnil);
- beg = NATNUMP (tmp) ? XFASTINT (tmp) : BEGV;
+ (make_fixnum (beg), Qinvisible, Qnil, Qnil);
+ beg = FIXNATP (tmp) ? XFIXNAT (tmp) : BEGV;
}
/* Move away from the inside area. */
@@ -1768,11 +1751,11 @@ adjust_point_for_property (ptrdiff_t last_pt, bool modified)
to the other end would mean moving backwards and thus
could lead to an infinite loop. */
;
- else if (val = Fget_pos_property (make_number (PT),
+ else if (val = Fget_pos_property (make_fixnum (PT),
Qinvisible, Qnil),
TEXT_PROP_MEANS_INVISIBLE (val)
&& (val = (Fget_pos_property
- (make_number (PT == beg ? end : beg),
+ (make_fixnum (PT == beg ? end : beg),
Qinvisible, Qnil)),
!TEXT_PROP_MEANS_INVISIBLE (val)))
(check_composition = check_display = true,
@@ -1869,6 +1852,7 @@ int poll_suppress_count;
static struct atimer *poll_timer;
+#if defined CYGWIN || defined DOS_NT
/* Poll for input, so that we catch a C-g if it comes in. */
void
poll_for_input_1 (void)
@@ -1877,6 +1861,7 @@ poll_for_input_1 (void)
&& !waiting_for_input)
gobble_input ();
}
+#endif
/* Timer callback function for poll_timer. TIMER is equal to
poll_timer. */
@@ -1928,20 +1913,22 @@ start_polling (void)
#endif
}
+#if defined CYGWIN || defined DOS_NT
/* True if we are using polling to handle input asynchronously. */
bool
input_polling_used (void)
{
-#ifdef POLL_FOR_INPUT
+# ifdef POLL_FOR_INPUT
/* XXX This condition was (read_socket_hook && !interrupt_input),
but read_socket_hook is not global anymore. Let's pretend that
it's always set. */
return !interrupt_input;
-#else
- return 0;
-#endif
+# else
+ return false;
+# endif
}
+#endif
/* Turn off polling. */
@@ -1984,14 +1971,14 @@ void
bind_polling_period (int n)
{
#ifdef POLL_FOR_INPUT
- EMACS_INT new = polling_period;
+ intmax_t new = polling_period;
if (n > new)
new = n;
stop_other_atimers (poll_timer);
stop_polling ();
- specbind (Qpolling_period, make_number (new));
+ specbind (Qpolling_period, make_int (new));
/* Start a new alarm with the new period. */
start_polling ();
#endif
@@ -2172,25 +2159,25 @@ read_event_from_main_queue (struct timespec *end_time,
if (single_kboard)
goto start;
current_kboard = kb;
- return make_number (-2);
+ return make_fixnum (-2);
}
/* Terminate Emacs in batch mode if at eof. */
- if (noninteractive && INTEGERP (c) && XINT (c) < 0)
- Fkill_emacs (make_number (1));
+ if (noninteractive && FIXNUMP (c) && XFIXNUM (c) < 0)
+ Fkill_emacs (make_fixnum (1));
- if (INTEGERP (c))
+ if (FIXNUMP (c))
{
/* Add in any extra modifiers, where appropriate. */
if ((extra_keyboard_modifiers & CHAR_CTL)
|| ((extra_keyboard_modifiers & 0177) < ' '
&& (extra_keyboard_modifiers & 0177) != 0))
- XSETINT (c, make_ctrl_char (XINT (c)));
+ XSETINT (c, make_ctrl_char (XFIXNUM (c)));
/* Transfer any other modifier bits directly from
extra_keyboard_modifiers to c. Ignore the actual character code
in the low 16 bits of extra_keyboard_modifiers. */
- XSETINT (c, XINT (c) | (extra_keyboard_modifiers & ~0xff7f & ~CHAR_CTL));
+ XSETINT (c, XFIXNUM (c) | (extra_keyboard_modifiers & ~0xff7f & ~CHAR_CTL));
}
return c;
@@ -2238,8 +2225,8 @@ read_decoded_event_from_main_queue (struct timespec *end_time,
int meta_key = terminal->display_info.tty->meta_key;
eassert (n < MAX_ENCODED_BYTES);
events[n++] = nextevt;
- if (NATNUMP (nextevt)
- && XINT (nextevt) < (meta_key == 1 ? 0x80 : 0x100))
+ if (FIXNATP (nextevt)
+ && XFIXNUM (nextevt) < (meta_key == 1 ? 0x80 : 0x100))
{ /* An encoded byte sequence, let's try to decode it. */
struct coding_system *coding
= TERMINAL_KEYBOARD_CODING (terminal);
@@ -2249,7 +2236,7 @@ read_decoded_event_from_main_queue (struct timespec *end_time,
int i;
if (meta_key != 2)
for (i = 0; i < n; i++)
- events[i] = make_number (XINT (events[i]) & ~0x80);
+ events[i] = make_fixnum (XFIXNUM (events[i]) & ~0x80);
}
else
{
@@ -2257,7 +2244,7 @@ read_decoded_event_from_main_queue (struct timespec *end_time,
unsigned char dest[MAX_ENCODED_BYTES * MAX_MULTIBYTE_LENGTH];
int i;
for (i = 0; i < n; i++)
- src[i] = XINT (events[i]);
+ src[i] = XFIXNUM (events[i]);
if (meta_key != 2)
for (i = 0; i < n; i++)
src[i] &= ~0x80;
@@ -2276,7 +2263,7 @@ read_decoded_event_from_main_queue (struct timespec *end_time,
eassert (coding->carryover_bytes == 0);
n = 0;
while (n < coding->produced_char)
- events[n++] = make_number (STRING_CHAR_ADVANCE (p));
+ events[n++] = make_fixnum (STRING_CHAR_ADVANCE (p));
}
}
}
@@ -2354,7 +2341,7 @@ read_char (int commandflag, Lisp_Object map,
/* Undo what read_char_x_menu_prompt did when it unread
additional keys returned by Fx_popup_menu. */
if (CONSP (c)
- && (SYMBOLP (XCAR (c)) || INTEGERP (XCAR (c)))
+ && (SYMBOLP (XCAR (c)) || FIXNUMP (XCAR (c)))
&& NILP (XCDR (c)))
c = XCAR (c);
@@ -2378,13 +2365,20 @@ read_char (int commandflag, Lisp_Object map,
if (CONSP (c) && EQ (XCAR (c), Qt))
c = XCDR (c);
else
- reread = true;
+ {
+ if (CONSP (c) && EQ (XCAR (c), Qno_record))
+ {
+ c = XCDR (c);
+ recorded = true;
+ }
+ reread = true;
+ }
/* Undo what read_char_x_menu_prompt did when it unread
additional keys returned by Fx_popup_menu. */
if (CONSP (c)
&& EQ (XCDR (c), Qdisabled)
- && (SYMBOLP (XCAR (c)) || INTEGERP (XCAR (c))))
+ && (SYMBOLP (XCAR (c)) || FIXNUMP (XCAR (c))))
{
was_disabled = true;
c = XCAR (c);
@@ -2409,7 +2403,7 @@ read_char (int commandflag, Lisp_Object map,
/* Undo what read_char_x_menu_prompt did when it unread
additional keys returned by Fx_popup_menu. */
if (CONSP (c)
- && (SYMBOLP (XCAR (c)) || INTEGERP (XCAR (c)))
+ && (SYMBOLP (XCAR (c)) || FIXNUMP (XCAR (c)))
&& NILP (XCDR (c)))
c = XCAR (c);
reread = true;
@@ -2434,16 +2428,16 @@ read_char (int commandflag, Lisp_Object map,
Also, some things replace the macro with t
to force an early exit. */
if (EQ (Vexecuting_kbd_macro, Qt)
- || executing_kbd_macro_index >= XFASTINT (Flength (Vexecuting_kbd_macro)))
+ || executing_kbd_macro_index >= XFIXNAT (Flength (Vexecuting_kbd_macro)))
{
XSETINT (c, -1);
goto exit;
}
- c = Faref (Vexecuting_kbd_macro, make_number (executing_kbd_macro_index));
+ c = Faref (Vexecuting_kbd_macro, make_int (executing_kbd_macro_index));
if (STRINGP (Vexecuting_kbd_macro)
- && (XFASTINT (c) & 0x80) && (XFASTINT (c) <= 0xff))
- XSETFASTINT (c, CHAR_META | (XFASTINT (c) & ~0x80));
+ && (XFIXNAT (c) & 0x80) && (XFIXNAT (c) <= 0xff))
+ XSETFASTINT (c, CHAR_META | (XFIXNAT (c) & ~0x80));
executing_kbd_macro_index++;
@@ -2547,7 +2541,7 @@ read_char (int commandflag, Lisp_Object map,
{
c = read_char_minibuf_menu_prompt (commandflag, map);
- if (INTEGERP (c) && XINT (c) == -2)
+ if (FIXNUMP (c) && XFIXNUM (c) == -2)
return c; /* wrong_kboard_jmpbuf */
if (! NILP (c))
@@ -2569,7 +2563,10 @@ read_char (int commandflag, Lisp_Object map,
restore_getcjmp (save_jump);
pthread_sigmask (SIG_SETMASK, &empty_mask, 0);
unbind_to (jmpcount, Qnil);
- XSETINT (c, quit_char);
+ /* If we are in while-no-input, don't trigger C-g, as that will
+ quit instead of letting while-no-input do its thing. */
+ if (!EQ (Vquit_flag, Vthrow_on_input))
+ XSETINT (c, quit_char);
internal_last_event_frame = selected_frame;
Vlast_event_frame = internal_last_event_frame;
/* If we report the quit char as an event,
@@ -2598,7 +2595,7 @@ read_char (int commandflag, Lisp_Object map,
XSETCDR (last, list1 (c));
kb->kbd_queue_has_data = true;
current_kboard = kb;
- return make_number (-2); /* wrong_kboard_jmpbuf */
+ return make_fixnum (-2); /* wrong_kboard_jmpbuf */
}
}
goto non_reread;
@@ -2659,7 +2656,7 @@ read_char (int commandflag, Lisp_Object map,
&& num_nonmacro_input_events - last_auto_save > max (auto_save_interval, 20)
&& !detect_input_pending_run_timers (0))
{
- Fdo_auto_save (Qnil, Qnil);
+ Fdo_auto_save (auto_save_no_message ? Qt : Qnil, Qnil);
/* Hooks can actually change some buffers in auto save. */
redisplay ();
}
@@ -2708,11 +2705,11 @@ read_char (int commandflag, Lisp_Object map,
/* Auto save if enough time goes by without input. */
if (commandflag != 0 && commandflag != -2
&& num_nonmacro_input_events > last_auto_save
- && INTEGERP (Vauto_save_timeout)
- && XINT (Vauto_save_timeout) > 0)
+ && FIXNUMP (Vauto_save_timeout)
+ && XFIXNUM (Vauto_save_timeout) > 0)
{
Lisp_Object tem0;
- EMACS_INT timeout = XFASTINT (Vauto_save_timeout);
+ EMACS_INT timeout = XFIXNAT (Vauto_save_timeout);
timeout = min (timeout, MOST_POSITIVE_FIXNUM / delay_level * 4);
timeout = delay_level * timeout / 4;
@@ -2720,13 +2717,13 @@ read_char (int commandflag, Lisp_Object map,
save_getcjmp (save_jump);
record_unwind_protect_ptr (restore_getcjmp, save_jump);
restore_getcjmp (local_getcjmp);
- tem0 = sit_for (make_number (timeout), 1, 1);
+ tem0 = sit_for (make_fixnum (timeout), 1, 1);
unbind_to (count1, Qnil);
if (EQ (tem0, Qt)
&& ! CONSP (Vunread_command_events))
{
- Fdo_auto_save (Qnil, Qnil);
+ Fdo_auto_save (auto_save_no_message ? Qt : Qnil, Qnil);
redisplay ();
}
}
@@ -2744,7 +2741,7 @@ read_char (int commandflag, Lisp_Object map,
interpret the next key sequence using the wrong translation
tables and function keymaps. */
if (NILP (c) && current_kboard != orig_kboard)
- return make_number (-2); /* wrong_kboard_jmpbuf */
+ return make_fixnum (-2); /* wrong_kboard_jmpbuf */
/* If this has become non-nil here, it has been set by a timer
or sentinel or filter. */
@@ -2756,7 +2753,14 @@ read_char (int commandflag, Lisp_Object map,
if (CONSP (c) && EQ (XCAR (c), Qt))
c = XCDR (c);
else
- reread = true;
+ {
+ if (CONSP (c) && EQ (XCAR (c), Qno_record))
+ {
+ c = XCDR (c);
+ recorded = true;
+ }
+ reread = true;
+ }
}
/* Read something from current KBOARD's side queue, if possible. */
@@ -2795,7 +2799,7 @@ read_char (int commandflag, Lisp_Object map,
if (kb->kbd_queue_has_data)
{
current_kboard = kb;
- return make_number (-2); /* wrong_kboard_jmpbuf */
+ return make_fixnum (-2); /* wrong_kboard_jmpbuf */
}
}
@@ -2813,11 +2817,16 @@ read_char (int commandflag, Lisp_Object map,
goto exit;
}
- if (EQ (c, make_number (-2)))
+ if (EQ (c, make_fixnum (-2)))
return c;
if (CONSP (c) && EQ (XCAR (c), Qt))
c = XCDR (c);
+ else if (CONSP (c) && EQ (XCAR (c), Qno_record))
+ {
+ c = XCDR (c);
+ recorded = true;
+ }
}
non_reread:
@@ -2856,12 +2865,16 @@ read_char (int commandflag, Lisp_Object map,
if (CONSP (c)
&& (EQ (XCAR (c), Qselect_window)
+ || EQ (XCAR (c), Qfocus_out)
#ifdef HAVE_DBUS
|| EQ (XCAR (c), Qdbus_event)
#endif
#ifdef USE_FILE_NOTIFY
|| EQ (XCAR (c), Qfile_notify)
#endif
+#ifdef THREADS_ENABLED
+ || EQ (XCAR (c), Qthread_event)
+#endif
|| EQ (XCAR (c), Qconfig_changed_event))
&& !end_time)
/* We stopped being idle for this event; undo that. This
@@ -2875,7 +2888,7 @@ read_char (int commandflag, Lisp_Object map,
/* The command may have changed the keymaps. Pretend there
is input in another keyboard and return. This will
recalculate keymaps. */
- c = make_number (-2);
+ c = make_fixnum (-2);
goto exit;
}
else
@@ -2883,18 +2896,18 @@ read_char (int commandflag, Lisp_Object map,
}
/* Handle things that only apply to characters. */
- if (INTEGERP (c))
+ if (FIXNUMP (c))
{
/* If kbd_buffer_get_event gave us an EOF, return that. */
- if (XINT (c) == -1)
+ if (XFIXNUM (c) == -1)
goto exit;
if ((STRINGP (KVAR (current_kboard, Vkeyboard_translate_table))
- && UNSIGNED_CMP (XFASTINT (c), <,
+ && UNSIGNED_CMP (XFIXNAT (c), <,
SCHARS (KVAR (current_kboard,
Vkeyboard_translate_table))))
|| (VECTORP (KVAR (current_kboard, Vkeyboard_translate_table))
- && UNSIGNED_CMP (XFASTINT (c), <,
+ && UNSIGNED_CMP (XFIXNAT (c), <,
ASIZE (KVAR (current_kboard,
Vkeyboard_translate_table))))
|| (CHAR_TABLE_P (KVAR (current_kboard, Vkeyboard_translate_table))
@@ -2913,18 +2926,18 @@ read_char (int commandflag, Lisp_Object map,
so we won't do this twice, then queue it up. */
if (EVENT_HAS_PARAMETERS (c)
&& CONSP (XCDR (c))
- && CONSP (EVENT_START (c))
- && CONSP (XCDR (EVENT_START (c))))
+ && CONSP (xevent_start (c))
+ && CONSP (XCDR (xevent_start (c))))
{
Lisp_Object posn;
- posn = POSN_POSN (EVENT_START (c));
+ posn = POSN_POSN (xevent_start (c));
/* Handle menu-bar events:
insert the dummy prefix event `menu-bar'. */
if (EQ (posn, Qmenu_bar) || EQ (posn, Qtool_bar))
{
/* Change menu-bar to (menu-bar) as the event "position". */
- POSN_SET_POSN (EVENT_START (c), list1 (posn));
+ POSN_SET_POSN (xevent_start (c), list1 (posn));
also_record = c;
Vunread_command_events = Fcons (c, Vunread_command_events);
@@ -2942,9 +2955,9 @@ read_char (int commandflag, Lisp_Object map,
/* Wipe the echo area.
But first, if we are about to use an input method,
save the echo area contents for it to refer to. */
- if (INTEGERP (c)
+ if (FIXNUMP (c)
&& ! NILP (Vinput_method_function)
- && ' ' <= XINT (c) && XINT (c) < 256 && XINT (c) != 127)
+ && ' ' <= XFIXNUM (c) && XFIXNUM (c) < 256 && XFIXNUM (c) != 127)
{
previous_echo_area_message = Fcurrent_message ();
Vinput_method_previous_message = previous_echo_area_message;
@@ -2969,12 +2982,12 @@ read_char (int commandflag, Lisp_Object map,
reread_for_input_method:
from_macro:
/* Pass this to the input method, if appropriate. */
- if (INTEGERP (c)
+ if (FIXNUMP (c)
&& ! NILP (Vinput_method_function)
/* Don't run the input method within a key sequence,
after the first event of the key sequence. */
&& NILP (prev_event)
- && ' ' <= XINT (c) && XINT (c) < 256 && XINT (c) != 127)
+ && ' ' <= XFIXNUM (c) && XFIXNUM (c) < 256 && XFIXNUM (c) != 127)
{
Lisp_Object keys;
ptrdiff_t key_count;
@@ -3125,7 +3138,7 @@ read_char (int commandflag, Lisp_Object map,
unbind_to (count, Qnil);
redisplay ();
- if (EQ (c, make_number (040)))
+ if (EQ (c, make_fixnum (040)))
{
cancel_echoing ();
do
@@ -3184,6 +3197,10 @@ help_char_p (Lisp_Object c)
static void
record_char (Lisp_Object c)
{
+ /* quail.el binds this to avoid recording keys twice. */
+ if (inhibit_record_char)
+ return;
+
int recorded = 0;
if (CONSP (c) && (EQ (XCAR (c), Qhelp_echo) || EQ (XCAR (c), Qmouse_movement)))
@@ -3258,7 +3275,10 @@ record_char (Lisp_Object c)
if (!recorded)
{
total_keys += total_keys < NUM_RECENT_KEYS;
- ASET (recent_keys, recent_keys_index, c);
+ ASET (recent_keys, recent_keys_index,
+ /* Copy the event, in case it gets modified by side-effect
+ by some remapping function (bug#30955). */
+ CONSP (c) ? Fcopy_sequence (c) : c);
if (++recent_keys_index >= NUM_RECENT_KEYS)
recent_keys_index = 0;
}
@@ -3287,15 +3307,15 @@ record_char (Lisp_Object c)
/* Write c to the dribble file. If c is a lispy event, write
the event's symbol to the dribble file, in <brackets>. Bleaugh.
If you, dear reader, have a better idea, you've got the source. :-) */
- if (dribble)
+ if (dribble && NILP (Vexecuting_kbd_macro))
{
block_input ();
- if (INTEGERP (c))
+ if (FIXNUMP (c))
{
- if (XUINT (c) < 0x100)
- putc_unlocked (XUINT (c), dribble);
+ if (XUFIXNUM (c) < 0x100)
+ putc_unlocked (XUFIXNUM (c), dribble);
else
- fprintf (dribble, " 0x%"pI"x", XUINT (c));
+ fprintf (dribble, " 0x%"pI"x", XUFIXNUM (c));
}
else
{
@@ -3348,7 +3368,7 @@ readable_events (int flags)
if (flags & READABLE_EVENTS_DO_TIMERS_NOW)
timer_check ();
- /* If the buffer contains only FOCUS_IN_EVENT events, and
+ /* If the buffer contains only FOCUS_IN/OUT_EVENT events, and
READABLE_EVENTS_FILTER_EVENTS is set, report it as empty. */
if (kbd_fetch_ptr != kbd_store_ptr)
{
@@ -3362,13 +3382,12 @@ readable_events (int flags)
do
{
- if (event == kbd_buffer + KBD_BUFFER_SIZE)
- event = kbd_buffer;
if (!(
#ifdef USE_TOOLKIT_SCROLL_BARS
(flags & READABLE_EVENTS_FILTER_EVENTS) &&
#endif
- event->kind == FOCUS_IN_EVENT)
+ (event->kind == FOCUS_IN_EVENT
+ || event->kind == FOCUS_OUT_EVENT))
#ifdef USE_TOOLKIT_SCROLL_BARS
&& !((flags & READABLE_EVENTS_IGNORE_SQUEEZABLES)
&& (event->kind == SCROLL_BAR_CLICK_EVENT
@@ -3379,7 +3398,7 @@ readable_events (int flags)
&& !((flags & READABLE_EVENTS_FILTER_EVENTS)
&& event->kind == BUFFER_SWITCH_EVENT))
return 1;
- event++;
+ event = next_kbd_event (event);
}
while (event != kbd_store_ptr);
}
@@ -3433,12 +3452,8 @@ event_to_kboard (struct input_event *event)
static int
kbd_buffer_nr_stored (void)
{
- return kbd_fetch_ptr == kbd_store_ptr
- ? 0
- : (kbd_fetch_ptr < kbd_store_ptr
- ? kbd_store_ptr - kbd_fetch_ptr
- : ((kbd_buffer + KBD_BUFFER_SIZE) - kbd_fetch_ptr
- + (kbd_store_ptr - kbd_buffer)));
+ int n = kbd_store_ptr - kbd_fetch_ptr;
+ return n + (n < 0 ? KBD_BUFFER_SIZE : 0);
}
#endif /* Store an event obtained at interrupt level into kbd_buffer, fifo */
@@ -3487,14 +3502,12 @@ kbd_buffer_store_buffered_event (union buffered_input_event *event,
{
kset_kbd_queue
(kb, list2 (make_lispy_switch_frame (event->ie.frame_or_window),
- make_number (c)));
+ make_fixnum (c)));
kb->kbd_queue_has_data = true;
- union buffered_input_event *sp;
- for (sp = kbd_fetch_ptr; sp != kbd_store_ptr; sp++)
- {
- if (sp == kbd_buffer + KBD_BUFFER_SIZE)
- sp = kbd_buffer;
+ for (union buffered_input_event *sp = kbd_fetch_ptr;
+ sp != kbd_store_ptr; sp = next_kbd_event (sp))
+ {
if (event_to_kboard (&sp->ie) == kb)
{
sp->ie.kind = NO_EVENT;
@@ -3539,22 +3552,18 @@ kbd_buffer_store_buffered_event (union buffered_input_event *event,
Just ignore the second one. */
else if (event->kind == BUFFER_SWITCH_EVENT
&& kbd_fetch_ptr != kbd_store_ptr
- && ((kbd_store_ptr == kbd_buffer
- ? kbd_buffer + KBD_BUFFER_SIZE - 1
- : kbd_store_ptr - 1)->kind) == BUFFER_SWITCH_EVENT)
+ && prev_kbd_event (kbd_store_ptr)->kind == BUFFER_SWITCH_EVENT)
return;
- if (kbd_store_ptr - kbd_buffer == KBD_BUFFER_SIZE)
- kbd_store_ptr = kbd_buffer;
-
/* Don't let the very last slot in the buffer become full,
since that would make the two pointers equal,
and that is indistinguishable from an empty buffer.
Discard the event if it would fill the last slot. */
- if (kbd_fetch_ptr - 1 != kbd_store_ptr)
+ union buffered_input_event *next_slot = next_kbd_event (kbd_store_ptr);
+ if (kbd_fetch_ptr != next_slot)
{
*kbd_store_ptr = *event;
- ++kbd_store_ptr;
+ kbd_store_ptr = next_slot;
#ifdef subprocesses
if (kbd_buffer_nr_stored () > KBD_BUFFER_SIZE / 2
&& ! kbd_on_hold_p ())
@@ -3597,11 +3606,8 @@ kbd_buffer_store_buffered_event (union buffered_input_event *event,
void
kbd_buffer_unget_event (struct selection_input_event *event)
{
- if (kbd_fetch_ptr == kbd_buffer)
- kbd_fetch_ptr = kbd_buffer + KBD_BUFFER_SIZE;
-
/* Don't let the very last slot in the buffer become full, */
- union buffered_input_event *kp = kbd_fetch_ptr - 1;
+ union buffered_input_event *kp = prev_kbd_event (kbd_fetch_ptr);
if (kp != kbd_store_ptr)
{
kp->sie = *event;
@@ -3689,12 +3695,9 @@ kbd_buffer_store_help_event (Lisp_Object frame, Lisp_Object help)
void
discard_mouse_events (void)
{
- union buffered_input_event *sp;
- for (sp = kbd_fetch_ptr; sp != kbd_store_ptr; sp++)
+ for (union buffered_input_event *sp = kbd_fetch_ptr;
+ sp != kbd_store_ptr; sp = next_kbd_event (sp))
{
- if (sp == kbd_buffer + KBD_BUFFER_SIZE)
- sp = kbd_buffer;
-
if (sp->kind == MOUSE_CLICK_EVENT
|| sp->kind == WHEEL_EVENT
|| sp->kind == HORIZ_WHEEL_EVENT
@@ -3719,25 +3722,20 @@ discard_mouse_events (void)
bool
kbd_buffer_events_waiting (void)
{
- union buffered_input_event *sp;
-
- for (sp = kbd_fetch_ptr;
- sp != kbd_store_ptr && sp->kind == NO_EVENT;
- ++sp)
- {
- if (sp == kbd_buffer + KBD_BUFFER_SIZE)
- sp = kbd_buffer;
- }
-
- kbd_fetch_ptr = sp;
- return sp != kbd_store_ptr && sp->kind != NO_EVENT;
+ for (union buffered_input_event *sp = kbd_fetch_ptr;
+ ; sp = next_kbd_event (sp))
+ if (sp == kbd_store_ptr || sp->kind != NO_EVENT)
+ {
+ kbd_fetch_ptr = sp;
+ return sp != kbd_store_ptr && sp->kind != NO_EVENT;
+ }
}
/* Clear input event EVENT. */
static void
-clear_event (union buffered_input_event *event)
+clear_event (struct input_event *event)
{
event->kind = NO_EVENT;
}
@@ -3767,7 +3765,7 @@ kbd_buffer_get_event (KBOARD **kbp,
}
#endif /* subprocesses */
-#if !defined HAVE_DBUS && !defined USE_FILE_NOTIFY
+#if !defined HAVE_DBUS && !defined USE_FILE_NOTIFY && !defined THREADS_ENABLED
if (noninteractive
/* In case we are running as a daemon, only do this before
detaching from the terminal. */
@@ -3778,7 +3776,7 @@ kbd_buffer_get_event (KBOARD **kbp,
*kbp = current_kboard;
return obj;
}
-#endif /* !defined HAVE_DBUS && !defined USE_FILE_NOTIFY */
+#endif /* !defined HAVE_DBUS && !defined USE_FILE_NOTIFY && !defined THREADS_ENABLED */
/* Wait until there is input available. */
for (;;)
@@ -3859,11 +3857,7 @@ kbd_buffer_get_event (KBOARD **kbp,
mouse movement enabled and available. */
if (kbd_fetch_ptr != kbd_store_ptr)
{
- union buffered_input_event *event;
-
- event = ((kbd_fetch_ptr < kbd_buffer + KBD_BUFFER_SIZE)
- ? kbd_fetch_ptr
- : kbd_buffer);
+ union buffered_input_event *event = kbd_fetch_ptr;
*kbp = event_to_kboard (&event->ie);
if (*kbp == 0)
@@ -3874,15 +3868,17 @@ kbd_buffer_get_event (KBOARD **kbp,
/* These two kinds of events get special handling
and don't actually appear to the command loop.
We return nil for them. */
- if (event->kind == SELECTION_REQUEST_EVENT
- || event->kind == SELECTION_CLEAR_EVENT)
+ switch (event->kind)
+ {
+ case SELECTION_REQUEST_EVENT:
+ case SELECTION_CLEAR_EVENT:
{
#ifdef HAVE_X11
/* Remove it from the buffer before processing it,
since otherwise swallow_events will see it
and process it again. */
struct selection_input_event copy = event->sie;
- kbd_fetch_ptr = event + 1;
+ kbd_fetch_ptr = next_kbd_event (event);
input_pending = readable_events (0);
x_handle_selection_event (&copy);
#else
@@ -3891,202 +3887,60 @@ kbd_buffer_get_event (KBOARD **kbp,
emacs_abort ();
#endif
}
+ break;
-#if defined (HAVE_NS)
- else if (event->kind == NS_TEXT_EVENT)
- {
- if (event->ie.code == KEY_NS_PUT_WORKING_TEXT)
- obj = list1 (intern ("ns-put-working-text"));
- else
- obj = list1 (intern ("ns-unput-working-text"));
- kbd_fetch_ptr = event + 1;
- if (used_mouse_menu)
- *used_mouse_menu = true;
- }
-#endif
-
-#if defined (HAVE_X11) || defined (HAVE_NTGUI) \
- || defined (HAVE_NS)
- else if (event->kind == DELETE_WINDOW_EVENT)
- {
- /* Make an event (delete-frame (FRAME)). */
- obj = list2 (Qdelete_frame, list1 (event->ie.frame_or_window));
- kbd_fetch_ptr = event + 1;
- }
-#endif
-
-#ifdef HAVE_NTGUI
- else if (event->kind == END_SESSION_EVENT)
- {
- /* Make an event (end-session). */
- obj = list1 (Qend_session);
- kbd_fetch_ptr = event + 1;
- }
-#endif
-
-#if defined (HAVE_X11) || defined (HAVE_NTGUI) \
- || defined (HAVE_NS)
- else if (event->kind == ICONIFY_EVENT)
- {
- /* Make an event (iconify-frame (FRAME)). */
- obj = list2 (Qiconify_frame, list1 (event->ie.frame_or_window));
- kbd_fetch_ptr = event + 1;
- }
- else if (event->kind == DEICONIFY_EVENT)
- {
- /* Make an event (make-frame-visible (FRAME)). */
- obj = list2 (Qmake_frame_visible, list1 (event->ie.frame_or_window));
- kbd_fetch_ptr = event + 1;
- }
-#endif
- else if (event->kind == BUFFER_SWITCH_EVENT)
- {
- /* The value doesn't matter here; only the type is tested. */
- XSETBUFFER (obj, current_buffer);
- kbd_fetch_ptr = event + 1;
- }
-#if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \
- || defined (HAVE_NS) || defined (USE_GTK)
- else if (event->kind == MENU_BAR_ACTIVATE_EVENT)
+#ifdef HAVE_EXT_MENU_BAR
+ case MENU_BAR_ACTIVATE_EVENT:
{
- kbd_fetch_ptr = event + 1;
+ kbd_fetch_ptr = next_kbd_event (event);
input_pending = readable_events (0);
if (FRAME_LIVE_P (XFRAME (event->ie.frame_or_window)))
x_activate_menubar (XFRAME (event->ie.frame_or_window));
}
+ break;
+#endif
+#if defined (HAVE_NS)
+ case NS_TEXT_EVENT:
+ if (used_mouse_menu)
+ *used_mouse_menu = true;
+ FALLTHROUGH;
#endif
#ifdef HAVE_NTGUI
- else if (event->kind == LANGUAGE_CHANGE_EVENT)
- {
- /* Make an event (language-change FRAME CODEPAGE LANGUAGE-ID). */
- obj = list4 (Qlanguage_change,
- event->ie.frame_or_window,
- make_number (event->ie.code),
- make_number (event->ie.modifiers));
- kbd_fetch_ptr = event + 1;
- }
+ case END_SESSION_EVENT:
+ case LANGUAGE_CHANGE_EVENT:
#endif
-#ifdef USE_FILE_NOTIFY
- else if (event->kind == FILE_NOTIFY_EVENT)
- {
-#ifdef HAVE_W32NOTIFY
- /* Make an event (file-notify (DESCRIPTOR ACTION FILE) CALLBACK). */
- obj = list3 (Qfile_notify, event->ie.arg, event->ie.frame_or_window);
-#else
- obj = make_lispy_event (&event->ie);
+#if defined (HAVE_X11) || defined (HAVE_NTGUI) || defined (HAVE_NS)
+ case DELETE_WINDOW_EVENT:
+ case ICONIFY_EVENT:
+ case DEICONIFY_EVENT:
+ case MOVE_FRAME_EVENT:
#endif
- kbd_fetch_ptr = event + 1;
- }
-#endif /* USE_FILE_NOTIFY */
- else if (event->kind == SAVE_SESSION_EVENT)
- {
- obj = list2 (Qsave_session, event->ie.arg);
- kbd_fetch_ptr = event + 1;
- }
- /* Just discard these, by returning nil.
- With MULTI_KBOARD, these events are used as placeholders
- when we need to randomly delete events from the queue.
- (They shouldn't otherwise be found in the buffer,
- but on some machines it appears they do show up
- even without MULTI_KBOARD.) */
- /* On Windows NT/9X, NO_EVENT is used to delete extraneous
- mouse events during a popup-menu call. */
- else if (event->kind == NO_EVENT)
- kbd_fetch_ptr = event + 1;
- else if (event->kind == HELP_EVENT)
- {
- Lisp_Object object, position, help, frame, window;
-
- frame = event->ie.frame_or_window;
- object = event->ie.arg;
- position = make_number (Time_to_position (event->ie.timestamp));
- window = event->ie.x;
- help = event->ie.y;
- clear_event (event);
-
- kbd_fetch_ptr = event + 1;
- if (!WINDOWP (window))
- window = Qnil;
- obj = Fcons (Qhelp_echo,
- list5 (frame, help, window, object, position));
- }
- else if (event->kind == FOCUS_IN_EVENT)
- {
- /* Notification of a FocusIn event. The frame receiving the
- focus is in event->frame_or_window. Generate a
- switch-frame event if necessary. */
- Lisp_Object frame, focus;
-
- frame = event->ie.frame_or_window;
- focus = FRAME_FOCUS_FRAME (XFRAME (frame));
- if (FRAMEP (focus))
- frame = focus;
-
- if (
-#ifdef HAVE_X11
- ! NILP (event->ie.arg)
- &&
+#ifdef USE_FILE_NOTIFY
+ case FILE_NOTIFY_EVENT:
#endif
- !EQ (frame, internal_last_event_frame)
- && !EQ (frame, selected_frame))
- obj = make_lispy_switch_frame (frame);
- else
- obj = make_lispy_focus_in (frame);
-
- internal_last_event_frame = frame;
- kbd_fetch_ptr = event + 1;
- }
- else if (event->kind == FOCUS_OUT_EVENT)
- {
-#ifdef HAVE_WINDOW_SYSTEM
-
- Display_Info *di;
- Lisp_Object frame = event->ie.frame_or_window;
- bool focused = false;
-
- for (di = x_display_list; di && ! focused; di = di->next)
- focused = di->x_highlight_frame != 0;
-
- if (!focused)
- obj = make_lispy_focus_out (frame);
-
-#endif /* HAVE_WINDOW_SYSTEM */
-
- kbd_fetch_ptr = event + 1;
- }
#ifdef HAVE_DBUS
- else if (event->kind == DBUS_EVENT)
- {
- obj = make_lispy_event (&event->ie);
- kbd_fetch_ptr = event + 1;
- }
+ case DBUS_EVENT:
#endif
-#if defined (HAVE_X11) || defined (HAVE_NTGUI) || defined (HAVE_NS)
- else if (event->kind == MOVE_FRAME_EVENT)
- {
- /* Make an event (move-frame (FRAME)). */
- obj = list2 (Qmove_frame, list1 (event->ie.frame_or_window));
- kbd_fetch_ptr = event + 1;
- }
+#ifdef THREADS_ENABLED
+ case THREAD_EVENT:
#endif
#ifdef HAVE_XWIDGETS
- else if (event->kind == XWIDGET_EVENT)
- {
- obj = make_lispy_event (&event->ie);
- kbd_fetch_ptr = event + 1;
- }
+ case XWIDGET_EVENT:
#endif
- else if (event->kind == CONFIG_CHANGED_EVENT)
- {
- obj = make_lispy_event (&event->ie);
- kbd_fetch_ptr = event + 1;
- }
- else if (event->kind == SELECT_WINDOW_EVENT)
- {
- obj = list2 (Qselect_window, list1 (event->ie.frame_or_window));
- kbd_fetch_ptr = event + 1;
- }
- else
+ case BUFFER_SWITCH_EVENT:
+ case SAVE_SESSION_EVENT:
+ case NO_EVENT:
+ case HELP_EVENT:
+ case FOCUS_IN_EVENT:
+ case CONFIG_CHANGED_EVENT:
+ case FOCUS_OUT_EVENT:
+ case SELECT_WINDOW_EVENT:
+ {
+ obj = make_lispy_event (&event->ie);
+ kbd_fetch_ptr = next_kbd_event (event);
+ }
+ break;
+ default:
{
/* If this event is on a different frame, return a switch-frame this
time, and leave the event in the queue for next time. */
@@ -4115,8 +3969,7 @@ kbd_buffer_get_event (KBOARD **kbp,
{
obj = make_lispy_event (&event->ie);
-#if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \
- || defined (HAVE_NS) || defined (USE_GTK)
+#ifdef HAVE_EXT_MENU_BAR
/* If this was a menu selection, then set the flag to inhibit
writing to last_nonmenu_event. Don't do this if the event
we're returning is (menu-bar), though; that indicates the
@@ -4136,10 +3989,11 @@ kbd_buffer_get_event (KBOARD **kbp,
#endif
/* Wipe out this event, to catch bugs. */
- clear_event (event);
- kbd_fetch_ptr = event + 1;
+ clear_event (&event->ie);
+ kbd_fetch_ptr = next_kbd_event (event);
}
}
+ }
}
/* Try generating a mouse motion event. */
else if (!NILP (do_mouse_tracking) && some_mouse_moved ())
@@ -4203,17 +4057,9 @@ kbd_buffer_get_event (KBOARD **kbp,
static void
process_special_events (void)
{
- union buffered_input_event *event;
-
- for (event = kbd_fetch_ptr; event != kbd_store_ptr; ++event)
+ for (union buffered_input_event *event = kbd_fetch_ptr;
+ event != kbd_store_ptr; event = next_kbd_event (event))
{
- if (event == kbd_buffer + KBD_BUFFER_SIZE)
- {
- event = kbd_buffer;
- if (event == kbd_store_ptr)
- break;
- }
-
/* If we find a stored X selection request, handle it now. */
if (event->kind == SELECTION_REQUEST_EVENT
|| event->kind == SELECTION_CLEAR_EVENT)
@@ -4227,28 +4073,21 @@ process_special_events (void)
cyclically. */
struct selection_input_event copy = event->sie;
- union buffered_input_event *beg
- = (kbd_fetch_ptr == kbd_buffer + KBD_BUFFER_SIZE)
- ? kbd_buffer : kbd_fetch_ptr;
+ int moved_events;
- if (event > beg)
- memmove (beg + 1, beg, (event - beg) * sizeof *beg);
- else if (event < beg)
+ if (event < kbd_fetch_ptr)
{
- if (event > kbd_buffer)
- memmove (kbd_buffer + 1, kbd_buffer,
- (event - kbd_buffer) * sizeof *kbd_buffer);
- *kbd_buffer = *(kbd_buffer + KBD_BUFFER_SIZE - 1);
- if (beg < kbd_buffer + KBD_BUFFER_SIZE - 1)
- memmove (beg + 1, beg,
- (kbd_buffer + KBD_BUFFER_SIZE - 1 - beg) * sizeof *beg);
+ memmove (kbd_buffer + 1, kbd_buffer,
+ (event - kbd_buffer) * sizeof *kbd_buffer);
+ kbd_buffer[0] = kbd_buffer[KBD_BUFFER_SIZE - 1];
+ moved_events = kbd_buffer + KBD_BUFFER_SIZE - 1 - kbd_fetch_ptr;
}
-
- if (kbd_fetch_ptr == kbd_buffer + KBD_BUFFER_SIZE)
- kbd_fetch_ptr = kbd_buffer + 1;
else
- kbd_fetch_ptr++;
+ moved_events = event - kbd_fetch_ptr;
+ memmove (kbd_fetch_ptr + 1, kbd_fetch_ptr,
+ moved_events * sizeof *kbd_fetch_ptr);
+ kbd_fetch_ptr = next_kbd_event (kbd_fetch_ptr);
input_pending = readable_events (0);
x_handle_selection_event (&copy);
#else
@@ -4325,18 +4164,13 @@ decode_timer (Lisp_Object timer, struct timespec *result)
Lisp_Object *vec;
if (! (VECTORP (timer) && ASIZE (timer) == 9))
- return 0;
+ return false;
vec = XVECTOR (timer)->contents;
if (! NILP (vec[0]))
- return 0;
- if (! INTEGERP (vec[2]))
return false;
-
- struct lisp_time t;
- if (decode_time_components (vec[1], vec[2], vec[3], vec[8], &t, 0) <= 0)
+ if (! FIXNUMP (vec[2]))
return false;
- *result = lisp_to_timespec (t);
- return timespec_valid_p (*result);
+ return list4_to_timespec (vec[1], vec[2], vec[3], vec[8], result);
}
@@ -4540,8 +4374,8 @@ timer_check (void)
DEFUN ("current-idle-time", Fcurrent_idle_time, Scurrent_idle_time, 0, 0, 0,
doc: /* Return the current length of Emacs idleness, or nil.
-The value when Emacs is idle is a list of four integers (HIGH LOW USEC PSEC)
-in the same style as (current-time).
+The value when Emacs is idle is a Lisp timestamp in the style of
+`current-time'.
The value when Emacs is not idle is nil.
@@ -5182,7 +5016,7 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y,
int xret = 0, yret = 0;
/* The window or frame under frame pixel coordinates (x,y) */
Lisp_Object window_or_frame = f
- ? window_from_coordinates (f, XINT (x), XINT (y), &part, 0)
+ ? window_from_coordinates (f, XFIXNUM (x), XFIXNUM (y), &part, 0)
: Qnil;
if (WINDOWP (window_or_frame))
@@ -5197,15 +5031,15 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y,
Lisp_Object object = Qnil;
/* Pixel coordinates relative to the window corner. */
- int wx = XINT (x) - WINDOW_LEFT_EDGE_X (w);
- int wy = XINT (y) - WINDOW_TOP_EDGE_Y (w);
+ int wx = XFIXNUM (x) - WINDOW_LEFT_EDGE_X (w);
+ int wy = XFIXNUM (y) - WINDOW_TOP_EDGE_Y (w);
/* For text area clicks, return X, Y relative to the corner of
this text area. Note that dX, dY etc are set below, by
buffer_posn_from_coords. */
if (part == ON_TEXT)
{
- xret = XINT (x) - window_box_left (w, TEXT_AREA);
+ xret = XFIXNUM (x) - window_box_left (w, TEXT_AREA);
yret = wy - WINDOW_HEADER_LINE_HEIGHT (w);
}
/* For mode line and header line clicks, return X, Y relative to
@@ -5224,7 +5058,7 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y,
string = mode_line_string (w, part, &col, &row, &charpos,
&object, &dx, &dy, &width, &height);
if (STRINGP (string))
- string_info = Fcons (string, make_number (charpos));
+ string_info = Fcons (string, make_fixnum (charpos));
textpos = -1;
xret = wx;
@@ -5243,7 +5077,7 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y,
string = marginal_area_string (w, part, &col, &row, &charpos,
&object, &dx, &dy, &width, &height);
if (STRINGP (string))
- string_info = Fcons (string, make_number (charpos));
+ string_info = Fcons (string, make_fixnum (charpos));
xret = wx;
yret = wy - WINDOW_HEADER_LINE_HEIGHT (w);
}
@@ -5325,7 +5159,7 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y,
: (part == ON_RIGHT_FRINGE || part == ON_RIGHT_MARGIN
|| (part == ON_VERTICAL_SCROLL_BAR
&& WINDOW_HAS_VERTICAL_SCROLL_BAR_ON_RIGHT (w)))
- ? (XINT (x) - window_box_left (w, TEXT_AREA))
+ ? (XFIXNUM (x) - window_box_left (w, TEXT_AREA))
: 0;
int y2 = wy;
@@ -5342,10 +5176,10 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y,
if (NILP (posn))
{
- posn = make_number (textpos);
+ posn = make_fixnum (textpos);
if (STRINGP (string2))
string_info = Fcons (string2,
- make_number (CHARPOS (p.string_pos)));
+ make_fixnum (CHARPOS (p.string_pos)));
}
if (NILP (object))
object = object2;
@@ -5367,14 +5201,14 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y,
/* Object info. */
extra_info
= list3 (object,
- Fcons (make_number (dx), make_number (dy)),
- Fcons (make_number (width), make_number (height)));
+ Fcons (make_fixnum (dx), make_fixnum (dy)),
+ Fcons (make_fixnum (width), make_fixnum (height)));
/* String info. */
extra_info = Fcons (string_info,
- Fcons (textpos < 0 ? Qnil : make_number (textpos),
- Fcons (Fcons (make_number (col),
- make_number (row)),
+ Fcons (textpos < 0 ? Qnil : make_fixnum (textpos),
+ Fcons (Fcons (make_fixnum (col),
+ make_fixnum (row)),
extra_info)));
}
@@ -5383,8 +5217,8 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y,
{
/* Return mouse pixel coordinates here. */
XSETFRAME (window_or_frame, f);
- xret = XINT (x);
- yret = XINT (y);
+ xret = XFIXNUM (x);
+ yret = XFIXNUM (y);
if (FRAME_LIVE_P (f)
&& FRAME_INTERNAL_BORDER_WIDTH (f) > 0
@@ -5403,9 +5237,9 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y,
return Fcons (window_or_frame,
Fcons (posn,
- Fcons (Fcons (make_number (xret),
- make_number (yret)),
- Fcons (make_number (t),
+ Fcons (Fcons (make_fixnum (xret),
+ make_fixnum (yret)),
+ Fcons (make_fixnum (t),
extra_info))));
}
@@ -5416,7 +5250,7 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y,
static bool
toolkit_menubar_in_use (struct frame *f)
{
-#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) || defined (HAVE_NTGUI)
+#ifdef HAVE_EXT_MENU_BAR
return !(!FRAME_WINDOW_P (f));
#else
return false;
@@ -5430,7 +5264,7 @@ static Lisp_Object
make_scroll_bar_position (struct input_event *ev, Lisp_Object type)
{
return list5 (ev->frame_or_window, type, Fcons (ev->x, ev->y),
- make_number (ev->timestamp),
+ make_fixnum (ev->timestamp),
builtin_lisp_symbol (scroll_bar_parts[ev->part]));
}
@@ -5449,7 +5283,66 @@ make_lispy_event (struct input_event *event)
switch (event->kind)
{
- /* A simple keystroke. */
+#if defined (HAVE_X11) || defined (HAVE_NTGUI) || defined (HAVE_NS)
+ case DELETE_WINDOW_EVENT:
+ /* Make an event (delete-frame (FRAME)). */
+ return list2 (Qdelete_frame, list1 (event->frame_or_window));
+
+ case ICONIFY_EVENT:
+ /* Make an event (iconify-frame (FRAME)). */
+ return list2 (Qiconify_frame, list1 (event->frame_or_window));
+
+ case DEICONIFY_EVENT:
+ /* Make an event (make-frame-visible (FRAME)). */
+ return list2 (Qmake_frame_visible, list1 (event->frame_or_window));
+
+ case MOVE_FRAME_EVENT:
+ /* Make an event (move-frame (FRAME)). */
+ return list2 (Qmove_frame, list1 (event->frame_or_window));
+#endif
+
+ case BUFFER_SWITCH_EVENT:
+ {
+ /* The value doesn't matter here; only the type is tested. */
+ Lisp_Object obj;
+ XSETBUFFER (obj, current_buffer);
+ return obj;
+ }
+
+ /* Just discard these, by returning nil.
+ With MULTI_KBOARD, these events are used as placeholders
+ when we need to randomly delete events from the queue.
+ (They shouldn't otherwise be found in the buffer,
+ but on some machines it appears they do show up
+ even without MULTI_KBOARD.) */
+ /* On Windows NT/9X, NO_EVENT is used to delete extraneous
+ mouse events during a popup-menu call. */
+ case NO_EVENT:
+ return Qnil;
+
+ case HELP_EVENT:
+ {
+ Lisp_Object frame = event->frame_or_window;
+ Lisp_Object object = event->arg;
+ Lisp_Object position
+ = make_fixnum (Time_to_position (event->timestamp));
+ Lisp_Object window = event->x;
+ Lisp_Object help = event->y;
+ clear_event (event);
+
+ if (!WINDOWP (window))
+ window = Qnil;
+ return Fcons (Qhelp_echo,
+ list5 (frame, help, window, object, position));
+ }
+
+ case FOCUS_IN_EVENT:
+ return make_lispy_focus_in (event->frame_or_window);
+
+ case FOCUS_OUT_EVENT:
+ return make_lispy_focus_out (event->frame_or_window);
+
+ /* A simple keystroke. */
case ASCII_KEYSTROKE_EVENT:
case MULTIBYTE_CHAR_KEYSTROKE_EVENT:
{
@@ -5513,6 +5406,11 @@ make_lispy_event (struct input_event *event)
}
#ifdef HAVE_NS
+ case NS_TEXT_EVENT:
+ return list1 (intern (event->code == KEY_NS_PUT_WORKING_TEXT
+ ? "ns-put-working-text"
+ : "ns-unput-working-text"));
+
/* NS_NONKEY_EVENTs are just like NON_ASCII_KEYSTROKE_EVENTs,
except that they are non-key events (last-nonmenu-event is nil). */
case NS_NONKEY_EVENT:
@@ -5575,6 +5473,17 @@ make_lispy_event (struct input_event *event)
PTRDIFF_MAX);
#ifdef HAVE_NTGUI
+ case END_SESSION_EVENT:
+ /* Make an event (end-session). */
+ return list1 (Qend_session);
+
+ case LANGUAGE_CHANGE_EVENT:
+ /* Make an event (language-change FRAME CODEPAGE LANGUAGE-ID). */
+ return list4 (Qlanguage_change,
+ event->frame_or_window,
+ make_fixnum (event->code),
+ make_fixnum (event->modifiers));
+
case MULTIMEDIA_KEY_EVENT:
if (event->code < ARRAYELTS (lispy_multimedia_keys)
&& event->code > 0 && lispy_multimedia_keys[event->code])
@@ -5628,7 +5537,7 @@ make_lispy_event (struct input_event *event)
in a menu (non-toolkit version). */
if (!toolkit_menubar_in_use (f))
{
- pixel_to_glyph_coords (f, XINT (event->x), XINT (event->y),
+ pixel_to_glyph_coords (f, XFIXNUM (event->x), XFIXNUM (event->y),
&column, &row, NULL, 1);
/* In the non-toolkit version, clicks on the menu bar
@@ -5653,8 +5562,8 @@ make_lispy_event (struct input_event *event)
pos = AREF (items, i + 3);
if (NILP (string))
break;
- if (column >= XINT (pos)
- && column < XINT (pos) + SCHARS (string))
+ if (column >= XFIXNUM (pos)
+ && column < XFIXNUM (pos) + SCHARS (string))
{
item = AREF (items, i);
break;
@@ -5667,7 +5576,7 @@ make_lispy_event (struct input_event *event)
position = list4 (event->frame_or_window,
Qmenu_bar,
Fcons (event->x, event->y),
- make_number (event->timestamp));
+ make_fixnum (event->timestamp));
return list2 (item, position);
}
@@ -5699,7 +5608,7 @@ make_lispy_event (struct input_event *event)
double-click-fuzz as is. On other frames, interpret it
as a multiple of 1/8 characters. */
struct frame *f;
- int fuzz;
+ intmax_t fuzz;
if (WINDOWP (event->frame_or_window))
f = XFRAME (XWINDOW (event->frame_or_window)->frame);
@@ -5714,18 +5623,18 @@ make_lispy_event (struct input_event *event)
fuzz = double_click_fuzz / 8;
is_double = (button == last_mouse_button
- && (eabs (XINT (event->x) - last_mouse_x) <= fuzz)
- && (eabs (XINT (event->y) - last_mouse_y) <= fuzz)
+ && (eabs (XFIXNUM (event->x) - last_mouse_x) <= fuzz)
+ && (eabs (XFIXNUM (event->y) - last_mouse_y) <= fuzz)
&& button_down_time != 0
&& (EQ (Vdouble_click_time, Qt)
- || (NATNUMP (Vdouble_click_time)
+ || (FIXNATP (Vdouble_click_time)
&& (event->timestamp - button_down_time
- < XFASTINT (Vdouble_click_time)))));
+ < XFIXNAT (Vdouble_click_time)))));
}
last_mouse_button = button;
- last_mouse_x = XINT (event->x);
- last_mouse_y = XINT (event->y);
+ last_mouse_x = XFIXNUM (event->x);
+ last_mouse_y = XFIXNUM (event->y);
/* If this is a button press, squirrel away the location, so
we can decide later whether it was a click or a drag. */
@@ -5742,7 +5651,7 @@ make_lispy_event (struct input_event *event)
double_click_count = 1;
button_down_time = event->timestamp;
*start_pos_ptr = Fcopy_alist (position);
- ignore_mouse_drag_p = 0;
+ ignore_mouse_drag_p = false;
}
/* Now we're releasing a button - check the co-ordinates to
@@ -5758,11 +5667,14 @@ make_lispy_event (struct input_event *event)
if (!CONSP (start_pos))
return Qnil;
- event->modifiers &= ~up_modifier;
+ unsigned click_or_drag_modifier = click_modifier;
+ if (ignore_mouse_drag_p)
+ ignore_mouse_drag_p = false;
+ else
{
Lisp_Object new_down, down;
- EMACS_INT xdiff = double_click_fuzz, ydiff = double_click_fuzz;
+ intmax_t xdiff = double_click_fuzz, ydiff = double_click_fuzz;
/* The third element of every position
should be the (x,y) pair. */
@@ -5770,45 +5682,43 @@ make_lispy_event (struct input_event *event)
new_down = Fcar (Fcdr (Fcdr (position)));
if (CONSP (down)
- && INTEGERP (XCAR (down)) && INTEGERP (XCDR (down)))
+ && FIXNUMP (XCAR (down)) && FIXNUMP (XCDR (down)))
{
- xdiff = XINT (XCAR (new_down)) - XINT (XCAR (down));
- ydiff = XINT (XCDR (new_down)) - XINT (XCDR (down));
+ xdiff = XFIXNUM (XCAR (new_down)) - XFIXNUM (XCAR (down));
+ ydiff = XFIXNUM (XCDR (new_down)) - XFIXNUM (XCDR (down));
}
- if (ignore_mouse_drag_p)
- {
- event->modifiers |= click_modifier;
- ignore_mouse_drag_p = 0;
- }
- else if (xdiff < double_click_fuzz && xdiff > - double_click_fuzz
- && ydiff < double_click_fuzz && ydiff > - double_click_fuzz
- /* Maybe the mouse has moved a lot, caused scrolling, and
- eventually ended up at the same screen position (but
- not buffer position) in which case it is a drag, not
- a click. */
- /* FIXME: OTOH if the buffer position has changed
- because of a timer or process filter rather than
- because of mouse movement, it should be considered as
- a click. But mouse-drag-region completely ignores
- this case and it hasn't caused any real problem, so
- it's probably OK to ignore it as well. */
- && EQ (Fcar (Fcdr (start_pos)), Fcar (Fcdr (position))))
- /* Mouse hasn't moved (much). */
- event->modifiers |= click_modifier;
- else
+ if (! (0 < double_click_fuzz
+ && - double_click_fuzz < xdiff
+ && xdiff < double_click_fuzz
+ && - double_click_fuzz < ydiff
+ && ydiff < double_click_fuzz
+ /* Maybe the mouse has moved a lot, caused scrolling, and
+ eventually ended up at the same screen position (but
+ not buffer position) in which case it is a drag, not
+ a click. */
+ /* FIXME: OTOH if the buffer position has changed
+ because of a timer or process filter rather than
+ because of mouse movement, it should be considered as
+ a click. But mouse-drag-region completely ignores
+ this case and it hasn't caused any real problem, so
+ it's probably OK to ignore it as well. */
+ && EQ (Fcar (Fcdr (start_pos)), Fcar (Fcdr (position)))))
{
+ /* Mouse has moved enough. */
button_down_time = 0;
- event->modifiers |= drag_modifier;
+ click_or_drag_modifier = drag_modifier;
}
-
- /* Don't check is_double; treat this as multiple
- if the down-event was multiple. */
- if (double_click_count > 1)
- event->modifiers |= ((double_click_count > 2)
- ? triple_modifier
- : double_modifier);
}
+
+ /* Don't check is_double; treat this as multiple if the
+ down-event was multiple. */
+ event->modifiers
+ = ((event->modifiers & ~up_modifier)
+ | click_or_drag_modifier
+ | (double_click_count < 2 ? 0
+ : double_click_count == 2 ? double_modifier
+ : triple_modifier));
}
else
/* Every mouse event should either have the down_modifier or
@@ -5828,7 +5738,7 @@ make_lispy_event (struct input_event *event)
if (event->modifiers & drag_modifier)
return list3 (head, start_pos, position);
else if (event->modifiers & (double_modifier | triple_modifier))
- return list3 (head, position, make_number (double_click_count));
+ return list3 (head, position, make_fixnum (double_click_count));
else
return list2 (head, position);
}
@@ -5857,7 +5767,7 @@ make_lispy_event (struct input_event *event)
double-click-fuzz as is. On other frames, interpret it
as a multiple of 1/8 characters. */
struct frame *fr;
- int fuzz;
+ intmax_t fuzz;
int symbol_num;
bool is_double;
@@ -5892,13 +5802,13 @@ make_lispy_event (struct input_event *event)
symbol_num += 2;
is_double = (last_mouse_button == - (1 + symbol_num)
- && (eabs (XINT (event->x) - last_mouse_x) <= fuzz)
- && (eabs (XINT (event->y) - last_mouse_y) <= fuzz)
+ && (eabs (XFIXNUM (event->x) - last_mouse_x) <= fuzz)
+ && (eabs (XFIXNUM (event->y) - last_mouse_y) <= fuzz)
&& button_down_time != 0
&& (EQ (Vdouble_click_time, Qt)
- || (NATNUMP (Vdouble_click_time)
+ || (FIXNATP (Vdouble_click_time)
&& (event->timestamp - button_down_time
- < XFASTINT (Vdouble_click_time)))));
+ < XFIXNAT (Vdouble_click_time)))));
if (is_double)
{
double_click_count++;
@@ -5915,8 +5825,8 @@ make_lispy_event (struct input_event *event)
button_down_time = event->timestamp;
/* Use a negative value to distinguish wheel from mouse button. */
last_mouse_button = - (1 + symbol_num);
- last_mouse_x = XINT (event->x);
- last_mouse_y = XINT (event->y);
+ last_mouse_x = XFIXNUM (event->x);
+ last_mouse_y = XFIXNUM (event->y);
/* Get the symbol we should use for the wheel event. */
head = modify_event_symbol (symbol_num,
@@ -5929,10 +5839,10 @@ make_lispy_event (struct input_event *event)
}
if (NUMBERP (event->arg))
- return list4 (head, position, make_number (double_click_count),
+ return list4 (head, position, make_fixnum (double_click_count),
event->arg);
else if (event->modifiers & (double_modifier | triple_modifier))
- return list3 (head, position, make_number (double_click_count));
+ return list3 (head, position, make_fixnum (double_click_count));
else
return list2 (head, position);
}
@@ -6033,8 +5943,7 @@ make_lispy_event (struct input_event *event)
return list3 (head, position, files);
}
-#if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \
- || defined (HAVE_NS) || defined (USE_GTK)
+#ifdef HAVE_EXT_MENU_BAR
case MENU_BAR_EVENT:
if (EQ (event->arg, event->frame_or_window))
/* This is the prefix key. We translate this to
@@ -6068,7 +5977,7 @@ make_lispy_event (struct input_event *event)
}
case SAVE_SESSION_EVENT:
- return Qsave_session;
+ return list2 (Qsave_session, event->arg);
#ifdef HAVE_DBUS
case DBUS_EVENT:
@@ -6077,6 +5986,13 @@ make_lispy_event (struct input_event *event)
}
#endif /* HAVE_DBUS */
+#ifdef THREADS_ENABLED
+ case THREAD_EVENT:
+ {
+ return Fcons (Qthread_event, event->arg);
+ }
+#endif /* THREADS_ENABLED */
+
#ifdef HAVE_XWIDGETS
case XWIDGET_EVENT:
{
@@ -6084,12 +6000,15 @@ make_lispy_event (struct input_event *event)
}
#endif
-#if defined HAVE_INOTIFY || defined HAVE_KQUEUE || defined HAVE_GFILENOTIFY
+#ifdef USE_FILE_NOTIFY
case FILE_NOTIFY_EVENT:
- {
- return Fcons (Qfile_notify, event->arg);
- }
-#endif /* HAVE_INOTIFY || HAVE_KQUEUE || HAVE_GFILENOTIFY */
+#ifdef HAVE_W32NOTIFY
+ /* Make an event (file-notify (DESCRIPTOR ACTION FILE) CALLBACK). */
+ return list3 (Qfile_notify, event->arg, event->frame_or_window);
+#else
+ return Fcons (Qfile_notify, event->arg);
+#endif
+#endif /* USE_FILE_NOTIFY */
case CONFIG_CHANGED_EVENT:
return list3 (Qconfig_changed_event,
@@ -6115,7 +6034,7 @@ make_lispy_movement (struct frame *frame, Lisp_Object bar_window, enum scroll_ba
list5 (bar_window,
Qvertical_scroll_bar,
Fcons (x, y),
- make_number (t),
+ make_fixnum (t),
part_sym));
}
/* Or is it an ordinary mouse movement? */
@@ -6140,16 +6059,12 @@ make_lispy_focus_in (Lisp_Object frame)
return list2 (Qfocus_in, frame);
}
-#ifdef HAVE_WINDOW_SYSTEM
-
static Lisp_Object
make_lispy_focus_out (Lisp_Object frame)
{
return list2 (Qfocus_out, frame);
}
-#endif /* HAVE_WINDOW_SYSTEM */
-
/* Manipulating modifiers. */
/* Parse the name of SYMBOL, and return the set of modifiers it contains.
@@ -6277,7 +6192,7 @@ parse_modifiers_uncached (Lisp_Object symbol, ptrdiff_t *modifier_end)
static Lisp_Object
apply_modifiers_uncached (int modifiers, char *base, int base_len, int base_len_byte)
{
- /* Since BASE could contain nulls, we can't use intern here; we have
+ /* Since BASE could contain NULs, we can't use intern here; we have
to use Fintern, which expects a genuine Lisp_String, and keeps a
reference to it. */
char new_mods[sizeof "A-C-H-M-S-s-up-down-drag-double-triple-"];
@@ -6359,15 +6274,15 @@ lispy_modifier_list (int modifiers)
SYMBOL's Qevent_symbol_element_mask property, and maintains the
Qevent_symbol_elements property. */
-#define KEY_TO_CHAR(k) (XINT (k) & ((1 << CHARACTERBITS) - 1))
+#define KEY_TO_CHAR(k) (XFIXNUM (k) & ((1 << CHARACTERBITS) - 1))
Lisp_Object
parse_modifiers (Lisp_Object symbol)
{
Lisp_Object elements;
- if (INTEGERP (symbol))
- return list2i (KEY_TO_CHAR (symbol), XINT (symbol) & CHAR_MODIFIER_MASK);
+ if (FIXNUMP (symbol))
+ return list2i (KEY_TO_CHAR (symbol), XFIXNUM (symbol) & CHAR_MODIFIER_MASK);
else if (!SYMBOLP (symbol))
return Qnil;
@@ -6434,8 +6349,8 @@ apply_modifiers (int modifiers, Lisp_Object base)
/* Mask out upper bits. We don't know where this value's been. */
modifiers &= INTMASK;
- if (INTEGERP (base))
- return make_number (XINT (base) | modifiers);
+ if (FIXNUMP (base))
+ return make_fixnum (XFIXNUM (base) | modifiers);
/* The click modifier never figures into cache indices. */
cache = Fget (base, Qmodifier_cache);
@@ -6503,7 +6418,7 @@ reorder_modifiers (Lisp_Object symbol)
Lisp_Object parsed;
parsed = parse_modifiers (symbol);
- return apply_modifiers (XFASTINT (XCAR (XCDR (parsed))),
+ return apply_modifiers (XFIXNAT (XCAR (XCDR (parsed))),
XCAR (parsed));
}
@@ -6566,12 +6481,7 @@ modify_event_symbol (ptrdiff_t symbol_num, int modifiers, Lisp_Object symbol_kin
{
if (! VECTORP (*symbol_table)
|| ASIZE (*symbol_table) != table_size)
- {
- Lisp_Object size;
-
- XSETFASTINT (size, table_size);
- *symbol_table = Fmake_vector (size, Qnil);
- }
+ *symbol_table = make_nil_vector (table_size);
value = AREF (*symbol_table, symbol_num);
}
@@ -6590,7 +6500,7 @@ modify_event_symbol (ptrdiff_t symbol_num, int modifiers, Lisp_Object symbol_kin
USE_SAFE_ALLOCA;
buf = SAFE_ALLOCA (len);
esprintf (buf, "%s-%"pI"d", SDATA (name_alist_or_stem),
- XINT (symbol_int) + 1);
+ XFIXNUM (symbol_int) + 1);
value = intern (buf);
SAFE_FREE ();
}
@@ -6673,22 +6583,22 @@ has the same base event type and all the specified modifiers. */)
if (SYMBOLP (base) && SCHARS (SYMBOL_NAME (base)) == 1)
XSETINT (base, SREF (SYMBOL_NAME (base), 0));
- if (INTEGERP (base))
+ if (FIXNUMP (base))
{
/* Turn (shift a) into A. */
if ((modifiers & shift_modifier) != 0
- && (XINT (base) >= 'a' && XINT (base) <= 'z'))
+ && (XFIXNUM (base) >= 'a' && XFIXNUM (base) <= 'z'))
{
- XSETINT (base, XINT (base) - ('a' - 'A'));
+ XSETINT (base, XFIXNUM (base) - ('a' - 'A'));
modifiers &= ~shift_modifier;
}
/* Turn (control a) into C-a. */
if (modifiers & ctrl_modifier)
- return make_number ((modifiers & ~ctrl_modifier)
- | make_ctrl_char (XINT (base)));
+ return make_fixnum ((modifiers & ~ctrl_modifier)
+ | make_ctrl_char (XFIXNUM (base)));
else
- return make_number (modifiers | XINT (base));
+ return make_fixnum (modifiers | XFIXNUM (base));
}
else if (SYMBOLP (base))
return apply_modifiers (modifiers, base);
@@ -6696,6 +6606,31 @@ has the same base event type and all the specified modifiers. */)
error ("Invalid base event");
}
+DEFUN ("internal-handle-focus-in", Finternal_handle_focus_in,
+ Sinternal_handle_focus_in, 1, 1, 0,
+ doc: /* Internally handle focus-in events.
+This function potentially generates an artifical switch-frame event. */)
+ (Lisp_Object event)
+{
+ Lisp_Object frame;
+ if (!EQ (CAR_SAFE (event), Qfocus_in) ||
+ !CONSP (XCDR (event)) ||
+ !FRAMEP ((frame = XCAR (XCDR (event)))))
+ error ("invalid focus-in event");
+
+ /* Conceptually, the concept of window manager focus on a particular
+ frame and the Emacs selected frame shouldn't be related, but for
+ a long time, we automatically switched the selected frame in
+ response to focus events, so let's keep doing that. */
+ bool switching = (!EQ (frame, internal_last_event_frame)
+ && !EQ (frame, selected_frame));
+ internal_last_event_frame = frame;
+ if (switching || !NILP (unread_switch_frame))
+ unread_switch_frame = make_lispy_switch_frame (frame);
+
+ return Qnil;
+}
+
/* Try to recognize SYMBOL as a modifier name.
Return the modifier flag bit, or 0 if not recognized. */
@@ -6806,7 +6741,7 @@ lucid_event_type_list_p (Lisp_Object object)
{
Lisp_Object elt;
elt = XCAR (tail);
- if (! (INTEGERP (elt) || SYMBOLP (elt)))
+ if (! (FIXNUMP (elt) || SYMBOLP (elt)))
return 0;
}
@@ -7455,7 +7390,7 @@ menu_bar_items (Lisp_Object old)
if (!NILP (old))
menu_bar_items_vector = old;
else
- menu_bar_items_vector = Fmake_vector (make_number (24), Qnil);
+ menu_bar_items_vector = make_nil_vector (24);
menu_bar_items_index = 0;
/* Build our list of keymaps.
@@ -7627,7 +7562,7 @@ menu_bar_item (Lisp_Object key, Lisp_Object item, Lisp_Object dummy1, void *dumm
ASET (menu_bar_items_vector, i,
AREF (item_properties, ITEM_PROPERTY_NAME)); i++;
ASET (menu_bar_items_vector, i, list1 (item)); i++;
- ASET (menu_bar_items_vector, i, make_number (0)); i++;
+ ASET (menu_bar_items_vector, i, make_fixnum (0)); i++;
menu_bar_items_index = i;
}
/* We did find an item for this KEY. Add ITEM to its list of maps. */
@@ -7698,8 +7633,7 @@ parse_menu_item (Lisp_Object item, int inmenubar)
/* Create item_properties vector if necessary. */
if (NILP (item_properties))
- item_properties
- = Fmake_vector (make_number (ITEM_PROPERTY_ENABLE + 1), Qnil);
+ item_properties = make_nil_vector (ITEM_PROPERTY_ENABLE + 1);
/* Initialize optional entries. */
for (i = ITEM_PROPERTY_DEF; i < ITEM_PROPERTY_ENABLE; i++)
@@ -8193,8 +8127,7 @@ parse_tool_bar_item (Lisp_Object key, Lisp_Object item)
set_prop (i, Qnil);
}
else
- tool_bar_item_properties
- = Fmake_vector (make_number (TOOL_BAR_ITEM_NSLOTS), Qnil);
+ tool_bar_item_properties = make_nil_vector (TOOL_BAR_ITEM_NSLOTS);
/* Set defaults. */
set_prop (TOOL_BAR_ITEM_KEY, key);
@@ -8220,7 +8153,7 @@ parse_tool_bar_item (Lisp_Object key, Lisp_Object item)
if (menu_separator_name_p (SSDATA (caption)))
{
set_prop (TOOL_BAR_ITEM_TYPE, Qt);
-#if !defined (USE_GTK) && !defined (HAVE_NS)
+#ifndef HAVE_EXT_TOOL_BAR
/* If we use build_desired_tool_bar_string to render the
tool bar, the separator is rendered as an image. */
set_prop (TOOL_BAR_ITEM_IMAGES,
@@ -8389,7 +8322,7 @@ init_tool_bar_items (Lisp_Object reuse)
if (VECTORP (reuse))
tool_bar_items_vector = reuse;
else
- tool_bar_items_vector = Fmake_vector (make_number (64), Qnil);
+ tool_bar_items_vector = make_nil_vector (64);
ntool_bar_items = 0;
}
@@ -8460,7 +8393,7 @@ read_char_x_menu_prompt (Lisp_Object map,
/* Display the menu and get the selection. */
Lisp_Object value;
- value = Fx_popup_menu (prev_event, get_keymap (map, 0, 1));
+ value = x_popup_menu_1 (prev_event, get_keymap (map, 0, 1));
if (CONSP (value))
{
Lisp_Object tem;
@@ -8479,7 +8412,7 @@ read_char_x_menu_prompt (Lisp_Object map,
{
record_menu_key (XCAR (tem));
if (SYMBOLP (XCAR (tem))
- || INTEGERP (XCAR (tem)))
+ || FIXNUMP (XCAR (tem)))
XSETCAR (tem, Fcons (XCAR (tem), Qdisabled));
}
@@ -8590,7 +8523,7 @@ read_char_minibuf_menu_prompt (int commandflag,
}
/* Ignore the element if it has no prompt string. */
- if (INTEGERP (event) && parse_menu_item (elt, -1))
+ if (FIXNUMP (event) && parse_menu_item (elt, -1))
{
/* True if the char to type matches the string. */
bool char_matches;
@@ -8601,8 +8534,8 @@ read_char_minibuf_menu_prompt (int commandflag,
upcased_event = Fupcase (event);
downcased_event = Fdowncase (event);
- char_matches = (XINT (upcased_event) == SREF (s, 0)
- || XINT (downcased_event) == SREF (s, 0));
+ char_matches = (XFIXNUM (upcased_event) == SREF (s, 0)
+ || XFIXNUM (downcased_event) == SREF (s, 0));
if (! char_matches)
desc = Fsingle_key_description (event, Qnil);
@@ -8658,8 +8591,8 @@ read_char_minibuf_menu_prompt (int commandflag,
/* Add as much of string as fits. */
thiswidth = min (SCHARS (desc), width - i);
menu_strings
- = Fcons (Fsubstring (desc, make_number (0),
- make_number (thiswidth)),
+ = Fcons (Fsubstring (desc, make_fixnum (0),
+ make_fixnum (thiswidth)),
menu_strings);
i += thiswidth;
PUSH_C_STR (" = ", menu_strings);
@@ -8669,8 +8602,8 @@ read_char_minibuf_menu_prompt (int commandflag,
/* Add as much of string as fits. */
thiswidth = min (SCHARS (s), width - i);
menu_strings
- = Fcons (Fsubstring (s, make_number (0),
- make_number (thiswidth)),
+ = Fcons (Fsubstring (s, make_fixnum (0),
+ make_fixnum (thiswidth)),
menu_strings);
i += thiswidth;
}
@@ -8707,10 +8640,10 @@ read_char_minibuf_menu_prompt (int commandflag,
while (BUFFERP (obj));
kset_defining_kbd_macro (current_kboard, orig_defn_macro);
- if (!INTEGERP (obj) || XINT (obj) == -2
+ if (!FIXNUMP (obj) || XFIXNUM (obj) == -2
|| (! EQ (obj, menu_prompt_more_char)
- && (!INTEGERP (menu_prompt_more_char)
- || ! EQ (obj, make_number (Ctl (XINT (menu_prompt_more_char)))))))
+ && (!FIXNUMP (menu_prompt_more_char)
+ || ! EQ (obj, make_fixnum (Ctl (XFIXNUM (menu_prompt_more_char)))))))
{
if (!NILP (KVAR (current_kboard, defining_kbd_macro)))
store_kbd_macro_char (obj);
@@ -8730,10 +8663,19 @@ follow_key (Lisp_Object keymap, Lisp_Object key)
}
static Lisp_Object
-active_maps (Lisp_Object first_event)
+active_maps (Lisp_Object first_event, Lisp_Object second_event)
{
Lisp_Object position
- = CONSP (first_event) ? CAR_SAFE (XCDR (first_event)) : Qnil;
+ = EVENT_HAS_PARAMETERS (first_event) ? EVENT_START (first_event) : Qnil;
+ /* The position of a click can be in the second event if the first event
+ is a fake_prefixed_key like `header-line` or `mode-line`. */
+ if (SYMBOLP (first_event)
+ && EVENT_HAS_PARAMETERS (second_event)
+ && EQ (first_event, POSN_POSN (EVENT_START (second_event))))
+ {
+ eassert (NILP (position));
+ position = EVENT_START (second_event);
+ }
return Fcons (Qkeymap, Fcurrent_active_maps (Qt, position));
}
@@ -8795,8 +8737,7 @@ access_keymap_keyremap (Lisp_Object map, Lisp_Object key, Lisp_Object prompt,
/* Do one step of the key remapping used for function-key-map and
key-translation-map:
- KEYBUF is the buffer holding the input events.
- BUFSIZE is its maximum size.
+ KEYBUF is the READ_KEY_ELTS-size buffer holding the input events.
FKEY is a pointer to the keyremap structure to use.
INPUT is the index of the last element in KEYBUF.
DOIT if true says that the remapping can actually take place.
@@ -8806,7 +8747,7 @@ access_keymap_keyremap (Lisp_Object map, Lisp_Object key, Lisp_Object prompt,
Return true if the remapping actually took place. */
static bool
-keyremap_step (Lisp_Object *keybuf, int bufsize, volatile keyremap *fkey,
+keyremap_step (Lisp_Object *keybuf, volatile keyremap *fkey,
int input, bool doit, int *diff, Lisp_Object prompt)
{
Lisp_Object next, key;
@@ -8823,12 +8764,12 @@ keyremap_step (Lisp_Object *keybuf, int bufsize, volatile keyremap *fkey,
the binding and restart with fkey->start at the end. */
if ((VECTORP (next) || STRINGP (next)) && doit)
{
- int len = XFASTINT (Flength (next));
+ int len = XFIXNAT (Flength (next));
int i;
*diff = len - (fkey->end - fkey->start);
- if (bufsize - input <= *diff)
+ if (READ_KEY_ELTS - input <= *diff)
error ("Key sequence too long");
/* Shift the keys that follow fkey->end. */
@@ -8841,7 +8782,7 @@ keyremap_step (Lisp_Object *keybuf, int bufsize, volatile keyremap *fkey,
/* Overwrite the old keys with the new ones. */
for (i = 0; i < len; i++)
keybuf[fkey->start + i]
- = Faref (next, make_number (i));
+ = Faref (next, make_fixnum (i));
fkey->start = fkey->end += *diff;
fkey->map = fkey->parent;
@@ -8870,8 +8811,13 @@ test_undefined (Lisp_Object binding)
&& EQ (Fcommand_remapping (binding, Qnil, Qnil), Qundefined)));
}
+void init_raw_keybuf_count (void)
+{
+ raw_keybuf_count = 0;
+}
+
/* Read a sequence of keys that ends with a non prefix character,
- storing it in KEYBUF, a buffer of size BUFSIZE.
+ storing it in KEYBUF, a buffer of size READ_KEY_ELTS.
Prompt with PROMPT.
Return the length of the key sequence stored.
Return -1 if the user rejected a command menu.
@@ -8911,7 +8857,7 @@ test_undefined (Lisp_Object binding)
from the selected window's buffer. */
static int
-read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
+read_key_sequence (Lisp_Object *keybuf, Lisp_Object prompt,
bool dont_downcase_last, bool can_return_switch_frame,
bool fix_current_buffer, bool prevent_redisplay)
{
@@ -8926,7 +8872,6 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
ptrdiff_t keys_start;
Lisp_Object current_binding = Qnil;
- Lisp_Object first_event = Qnil;
/* Index of the first key that has no binding.
It is useless to try fkey.start larger than that. */
@@ -8947,6 +8892,9 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
reading characters from the keyboard. */
int mock_input = 0;
+ /* Whether each event in the mocked input came from a mouse menu. */
+ bool used_mouse_menu_history[READ_KEY_ELTS] = {0};
+
/* If the sequence is unbound in submaps[], then
keybuf[fkey.start..fkey.end-1] is a prefix in Vfunction_key_map,
and fkey.map is its binding.
@@ -8981,9 +8929,11 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
/* List of events for which a fake prefix key has been generated. */
Lisp_Object fake_prefixed_keys = Qnil;
- raw_keybuf_count = 0;
-
- last_nonmenu_event = Qnil;
+ /* raw_keybuf_count is now initialized in (most of) the callers of
+ read_key_sequence. This is so that in a recursive call (for
+ mouse menus) a spurious initialization doesn't erase the contents
+ of raw_keybuf created by the outer call. */
+ /* raw_keybuf_count = 0; */
delayed_switch_frame = Qnil;
@@ -9035,17 +8985,20 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
replay_sequence:
starting_buffer = current_buffer;
- first_unbound = bufsize + 1;
+ first_unbound = READ_KEY_ELTS + 1;
+ Lisp_Object first_event = mock_input > 0 ? keybuf[0] : Qnil;
+ Lisp_Object second_event = mock_input > 1 ? keybuf[1] : Qnil;
/* Build our list of keymaps.
If we recognize a function key and replace its escape sequence in
keybuf with its symbol, or if the sequence starts with a mouse
click and we need to switch buffers, we jump back here to rebuild
the initial keymaps from the current buffer. */
- current_binding = active_maps (first_event);
+ current_binding = active_maps (first_event, second_event);
/* Start from the beginning in keybuf. */
t = 0;
+ last_nonmenu_event = Qnil;
/* These are no-ops the first time through, but if we restart, they
revert the echo area and this_command_keys to their original state. */
@@ -9113,7 +9066,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
goto replay_sequence;
}
- if (t >= bufsize)
+ if (t >= READ_KEY_ELTS)
error ("Key sequence too long");
if (INTERACTIVE)
@@ -9144,6 +9097,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
current_kboard->immediate_echo = false;
echo_now ();
}
+ used_mouse_menu = used_mouse_menu_history[t];
}
/* If not, we should actually read a character. */
@@ -9157,7 +9111,8 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
key = read_char (prevent_redisplay ? -2 : NILP (prompt),
current_binding, last_nonmenu_event,
&used_mouse_menu, NULL);
- if ((INTEGERP (key) && XINT (key) == -2) /* wrong_kboard_jmpbuf */
+ used_mouse_menu_history[t] = used_mouse_menu;
+ if ((FIXNUMP (key) && XFIXNUM (key) == -2) /* wrong_kboard_jmpbuf */
/* When switching to a new tty (with a new keyboard),
read_char returns the new buffer, rather than -2
(Bug#5095). This is because `terminal-init-xterm'
@@ -9225,7 +9180,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
/* read_char returns -1 at the end of a macro.
Emacs 18 handles this by returning immediately with a
zero, so that's what we'll do. */
- if (INTEGERP (key) && XINT (key) == -1)
+ if (FIXNUMP (key) && XFIXNUM (key) == -1)
{
t = 0;
/* The Microsoft C compiler can't handle the goto that
@@ -9260,8 +9215,8 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
/* If we have a quit that was typed in another frame, and
quit_throw_to_read_char switched buffers,
replay to get the right keymap. */
- if (INTEGERP (key)
- && XINT (key) == quit_char
+ if (FIXNUMP (key)
+ && XFIXNUM (key) == quit_char
&& current_buffer != starting_buffer)
{
GROW_RAW_KEYBUF;
@@ -9302,11 +9257,14 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
&& (XBUFFER (XWINDOW (selected_window)->contents)
!= current_buffer))
Fset_buffer (XWINDOW (selected_window)->contents);
- current_binding = active_maps (first_event);
+ current_binding = active_maps (first_event, Qnil);
}
GROW_RAW_KEYBUF;
- ASET (raw_keybuf, raw_keybuf_count, key);
+ ASET (raw_keybuf, raw_keybuf_count,
+ /* Copy the event, in case it gets modified by side-effect
+ by some remapping function (bug#30955). */
+ CONSP (key) ? Fcopy_sequence (key) : key);
raw_keybuf_count++;
}
@@ -9353,8 +9311,6 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
&& BUFFERP (XWINDOW (window)->contents)
&& XBUFFER (XWINDOW (window)->contents) != current_buffer)
{
- ASET (raw_keybuf, raw_keybuf_count, key);
- raw_keybuf_count++;
keybuf[t] = key;
mock_input = t + 1;
@@ -9383,7 +9339,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
&& (NILP (fake_prefixed_keys)
|| NILP (Fmemq (key, fake_prefixed_keys))))
{
- if (bufsize - t <= 1)
+ if (READ_KEY_ELTS - t <= 1)
error ("Key sequence too long");
keybuf[t] = posn;
@@ -9399,24 +9355,24 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
}
}
else if (CONSP (XCDR (key))
- && CONSP (EVENT_START (key))
- && CONSP (XCDR (EVENT_START (key))))
+ && CONSP (xevent_start (key))
+ && CONSP (XCDR (xevent_start (key))))
{
Lisp_Object posn;
- posn = POSN_POSN (EVENT_START (key));
+ posn = POSN_POSN (xevent_start (key));
/* Handle menu-bar events:
insert the dummy prefix event `menu-bar'. */
if (EQ (posn, Qmenu_bar) || EQ (posn, Qtool_bar))
{
- if (bufsize - t <= 1)
+ if (READ_KEY_ELTS - t <= 1)
error ("Key sequence too long");
keybuf[t] = posn;
keybuf[t + 1] = key;
/* Zap the position in key, so we know that we've
expanded it, and don't try to do so again. */
- POSN_SET_POSN (EVENT_START (key), list1 (posn));
+ POSN_SET_POSN (xevent_start (key), list1 (posn));
mock_input = t + 2;
goto replay_sequence;
@@ -9460,7 +9416,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
int modifiers;
breakdown = parse_modifiers (head);
- modifiers = XINT (XCAR (XCDR (breakdown)));
+ modifiers = XFIXNUM (XCAR (XCDR (breakdown)));
/* Attempt to reduce an unbound mouse event to a simpler
event that is bound:
Drags reduce to clicks.
@@ -9612,8 +9568,8 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
bool done;
int diff;
- done = keyremap_step (keybuf, bufsize, &indec, max (t, mock_input),
- 1, &diff, prompt);
+ done = keyremap_step (keybuf, &indec, max (t, mock_input),
+ true, &diff, prompt);
if (done)
{
mock_input = diff + max (t, mock_input);
@@ -9643,13 +9599,13 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
bool done;
int diff;
- done = keyremap_step (keybuf, bufsize, &fkey,
+ done = keyremap_step (keybuf, &fkey,
max (t, mock_input),
/* If there's a binding (i.e.
first_binding >= nmaps) we don't want
to apply this function-key-mapping. */
- fkey.end + 1 == t
- && (test_undefined (current_binding)),
+ (fkey.end + 1 == t
+ && test_undefined (current_binding)),
&diff, prompt);
if (done)
{
@@ -9669,8 +9625,8 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
bool done;
int diff;
- done = keyremap_step (keybuf, bufsize, &keytran, max (t, mock_input),
- 1, &diff, prompt);
+ done = keyremap_step (keybuf, &keytran, max (t, mock_input),
+ true, &diff, prompt);
if (done)
{
mock_input = diff + max (t, mock_input);
@@ -9690,14 +9646,14 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
use the corresponding lower-case letter instead. */
if (NILP (current_binding)
&& /* indec.start >= t && fkey.start >= t && */ keytran.start >= t
- && INTEGERP (key))
+ && FIXNUMP (key))
{
Lisp_Object new_key;
- EMACS_INT k = XINT (key);
+ EMACS_INT k = XFIXNUM (key);
if (k & shift_modifier)
XSETINT (new_key, k & ~shift_modifier);
- else if (CHARACTERP (make_number (k & ~CHAR_MODIFIER_MASK)))
+ else if (CHARACTERP (make_fixnum (k & ~CHAR_MODIFIER_MASK)))
{
int dc = downcase (k & ~CHAR_MODIFIER_MASK);
if (dc == (k & ~CHAR_MODIFIER_MASK))
@@ -9740,11 +9696,11 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
{
Lisp_Object breakdown = parse_modifiers (key);
int modifiers
- = CONSP (breakdown) ? (XINT (XCAR (XCDR (breakdown)))) : 0;
+ = CONSP (breakdown) ? (XFIXNUM (XCAR (XCDR (breakdown)))) : 0;
if (modifiers & shift_modifier
/* Treat uppercase keys as shifted. */
- || (INTEGERP (key)
+ || (FIXNUMP (key)
&& (KEY_TO_CHAR (key)
< XCHAR_TABLE (BVAR (current_buffer, downcase_table))->header.size)
&& uppercasep (KEY_TO_CHAR (key))))
@@ -9753,7 +9709,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
= (modifiers & shift_modifier
? apply_modifiers (modifiers & ~shift_modifier,
XCAR (breakdown))
- : make_number (downcase (KEY_TO_CHAR (key)) | modifiers));
+ : make_fixnum (downcase (KEY_TO_CHAR (key)) | modifiers));
original_uppercase = key;
original_uppercase_position = t - 1;
@@ -9823,8 +9779,6 @@ read_key_sequence_vs (Lisp_Object prompt, Lisp_Object continue_echo,
Lisp_Object can_return_switch_frame,
Lisp_Object cmd_loop, bool allow_string)
{
- Lisp_Object keybuf[30];
- int i;
ptrdiff_t count = SPECPDL_INDEX ();
if (!NILP (prompt))
@@ -9847,9 +9801,10 @@ read_key_sequence_vs (Lisp_Object prompt, Lisp_Object continue_echo,
cancel_hourglass ();
#endif
- i = read_key_sequence (keybuf, ARRAYELTS (keybuf),
- prompt, ! NILP (dont_downcase_last),
- ! NILP (can_return_switch_frame), 0, 0);
+ raw_keybuf_count = 0;
+ Lisp_Object keybuf[READ_KEY_ELTS];
+ int i = read_key_sequence (keybuf, prompt, ! NILP (dont_downcase_last),
+ ! NILP (can_return_switch_frame), false, false);
#if 0 /* The following is fine for code reading a key sequence and
then proceeding with a lengthy computation, but it's not good
@@ -10075,16 +10030,16 @@ Internal use only. */)
/* Kludge alert: this makes M-x be in the form expected by
novice.el. (248 is \370, a.k.a. "Meta-x".) Any better ideas? */
if (key0 == 248)
- add_command_key (make_number ('x' | meta_modifier));
+ add_command_key (make_fixnum ('x' | meta_modifier));
else
- add_command_key (make_number (key0));
+ add_command_key (make_fixnum (key0));
for (ptrdiff_t i = 1; i < SCHARS (keys); i++)
{
int key_i;
FETCH_STRING_CHAR_ADVANCE (key_i, keys, charidx, byteidx);
if (CHAR_BYTE8_P (key_i))
key_i = CHAR_TO_BYTE8 (key_i);
- add_command_key (make_number (key_i));
+ add_command_key (make_fixnum (key_i));
}
return Qnil;
}
@@ -10157,15 +10112,18 @@ DEFUN ("recursion-depth", Frecursion_depth, Srecursion_depth, 0, 0, 0,
{
EMACS_INT sum;
INT_ADD_WRAPV (command_loop_level, minibuf_level, &sum);
- return make_number (sum);
+ return make_fixnum (sum);
}
DEFUN ("open-dribble-file", Fopen_dribble_file, Sopen_dribble_file, 1, 1,
"FOpen dribble file: ",
- doc: /* Start writing all keyboard characters to a dribble file called FILE.
+ doc: /* Start writing input events to a dribble file called FILE.
If FILE is nil, close any open dribble file.
The file will be closed when Emacs exits.
+The events written to the file include keyboard and mouse input
+events, but not events from executing keyboard macros.
+
Be aware that this records ALL characters you type!
This may include sensitive information such as passwords. */)
(Lisp_Object file)
@@ -10296,15 +10254,14 @@ stuff_buffered_input (Lisp_Object stuffstring)
rms: we should stuff everything back into the kboard
it came from. */
- for (; kbd_fetch_ptr != kbd_store_ptr; kbd_fetch_ptr++)
+ for (; kbd_fetch_ptr != kbd_store_ptr;
+ kbd_fetch_ptr = next_kbd_event (kbd_fetch_ptr))
{
- if (kbd_fetch_ptr == kbd_buffer + KBD_BUFFER_SIZE)
- kbd_fetch_ptr = kbd_buffer;
if (kbd_fetch_ptr->kind == ASCII_KEYSTROKE_EVENT)
stuff_char (kbd_fetch_ptr->ie.code);
- clear_event (kbd_fetch_ptr);
+ clear_event (&kbd_fetch_ptr->ie);
}
input_pending = false;
@@ -10707,7 +10664,7 @@ See also `current-input-mode'. */)
return Qnil;
tty = t->display_info.tty;
- if (NILP (quit) || !INTEGERP (quit) || XINT (quit) < 0 || XINT (quit) > 0400)
+ if (NILP (quit) || !FIXNUMP (quit) || XFIXNUM (quit) < 0 || XFIXNUM (quit) > 0400)
error ("QUIT must be an ASCII character");
#ifndef DOS_NT
@@ -10716,7 +10673,7 @@ See also `current-input-mode'. */)
#endif
/* Don't let this value be out of range. */
- quit_char = XINT (quit) & (tty->meta_key == 0 ? 0177 : 0377);
+ quit_char = XFIXNUM (quit) & (tty->meta_key == 0 ? 0177 : 0377);
#ifndef DOS_NT
init_sys_modes (tty);
@@ -10770,7 +10727,7 @@ The elements of this list correspond to the arguments of
{
flow = FRAME_TTY (sf)->flow_control ? Qt : Qnil;
meta = (FRAME_TTY (sf)->meta_key == 2
- ? make_number (0)
+ ? make_fixnum (0)
: (CURTTY ()->meta_key == 1 ? Qt : Qnil));
}
else
@@ -10778,7 +10735,7 @@ The elements of this list correspond to the arguments of
flow = Qnil;
meta = Qt;
}
- Lisp_Object quit = make_number (quit_char);
+ Lisp_Object quit = make_fixnum (quit_char);
return list4 (interrupt, flow, meta, quit);
}
@@ -10796,12 +10753,12 @@ The return value is similar to a mouse click position:
The `posn-' functions access elements of such lists. */)
(Lisp_Object x, Lisp_Object y, Lisp_Object frame_or_window, Lisp_Object whole)
{
- CHECK_NUMBER (x);
+ CHECK_FIXNUM (x);
/* We allow X of -1, for the newline in a R2L line that overflowed
into the left fringe. */
- if (XINT (x) != -1)
- CHECK_NATNUM (x);
- CHECK_NATNUM (y);
+ if (XFIXNUM (x) != -1)
+ CHECK_FIXNAT (x);
+ CHECK_FIXNAT (y);
if (NILP (frame_or_window))
frame_or_window = selected_window;
@@ -10810,12 +10767,12 @@ The `posn-' functions access elements of such lists. */)
{
struct window *w = decode_live_window (frame_or_window);
- XSETINT (x, (XINT (x)
+ XSETINT (x, (XFIXNUM (x)
+ WINDOW_LEFT_EDGE_X (w)
+ (NILP (whole)
? window_box_left_offset (w, TEXT_AREA)
: 0)));
- XSETINT (y, WINDOW_TO_FRAME_PIXEL_Y (w, XINT (y)));
+ XSETINT (y, WINDOW_TO_FRAME_PIXEL_Y (w, XFIXNUM (y)));
frame_or_window = w->frame;
}
@@ -10848,17 +10805,17 @@ The `posn-' functions access elements of such lists. */)
Lisp_Object x = XCAR (tem);
Lisp_Object y = XCAR (XCDR (tem));
Lisp_Object aux_info = XCDR (XCDR (tem));
- int y_coord = XINT (y);
+ int y_coord = XFIXNUM (y);
/* Point invisible due to hscrolling? X can be -1 when a
newline in a R2L line overflows into the left fringe. */
- if (XINT (x) < -1)
+ if (XFIXNUM (x) < -1)
return Qnil;
if (!NILP (aux_info) && y_coord < 0)
{
- int rtop = XINT (XCAR (aux_info));
+ int rtop = XFIXNUM (XCAR (aux_info));
- y = make_number (y_coord + rtop);
+ y = make_fixnum (y_coord + rtop);
}
tem = Fposn_at_x_y (x, y, window, Qnil);
}
@@ -11053,6 +11010,8 @@ static const struct event_head head_table[] = {
{SYMBOL_INDEX (Qselect_window), SYMBOL_INDEX (Qswitch_frame)}
};
+static void syms_of_keyboard_for_pdumper (void);
+
void
syms_of_keyboard (void)
{
@@ -11063,9 +11022,11 @@ syms_of_keyboard (void)
staticpro (&Vlispy_mouse_stem);
regular_top_level_message = build_pure_c_string ("Back to top level");
+ staticpro (&regular_top_level_message);
#ifdef HAVE_STACK_OVERFLOW_HANDLING
recover_top_level_message
= build_pure_c_string ("Re-entering top level after C stack overflow");
+ staticpro (&recover_top_level_message);
#endif
DEFVAR_LISP ("internal--top-level-message", Vinternal__top_level_message,
doc: /* Message displayed by `normal-top-level'. */);
@@ -11125,6 +11086,10 @@ syms_of_keyboard (void)
DEFSYM (Qdbus_event, "dbus-event");
#endif
+#ifdef THREADS_ENABLED
+ DEFSYM (Qthread_event, "thread-event");
+#endif
+
#ifdef HAVE_XWIDGETS
DEFSYM (Qxwidget_event, "xwidget-event");
#endif
@@ -11248,33 +11213,33 @@ syms_of_keyboard (void)
Fput (var, Qevent_symbol_elements, list1 (var));
}
}
+ DEFSYM (Qno_record, "no-record");
- button_down_location = Fmake_vector (make_number (5), Qnil);
+ button_down_location = make_nil_vector (5);
staticpro (&button_down_location);
- mouse_syms = Fmake_vector (make_number (5), Qnil);
+ mouse_syms = make_nil_vector (5);
staticpro (&mouse_syms);
- wheel_syms = Fmake_vector (make_number (ARRAYELTS (lispy_wheel_names)),
- Qnil);
+ wheel_syms = make_nil_vector (ARRAYELTS (lispy_wheel_names));
staticpro (&wheel_syms);
{
int i;
int len = ARRAYELTS (modifier_names);
- modifier_symbols = Fmake_vector (make_number (len), Qnil);
+ modifier_symbols = make_nil_vector (len);
for (i = 0; i < len; i++)
if (modifier_names[i])
ASET (modifier_symbols, i, intern_c_string (modifier_names[i]));
staticpro (&modifier_symbols);
}
- recent_keys = Fmake_vector (make_number (NUM_RECENT_KEYS), Qnil);
+ recent_keys = make_nil_vector (NUM_RECENT_KEYS);
staticpro (&recent_keys);
- this_command_keys = Fmake_vector (make_number (40), Qnil);
+ this_command_keys = make_nil_vector (40);
staticpro (&this_command_keys);
- raw_keybuf = Fmake_vector (make_number (30), Qnil);
+ raw_keybuf = make_nil_vector (30);
staticpro (&raw_keybuf);
DEFSYM (Qcommand_execute, "command-execute");
@@ -11312,6 +11277,7 @@ syms_of_keyboard (void)
defsubr (&Scurrent_idle_time);
defsubr (&Sevent_symbol_parse_modifiers);
defsubr (&Sevent_convert_list);
+ defsubr (&Sinternal_handle_focus_in);
defsubr (&Sread_key_sequence);
defsubr (&Sread_key_sequence_vector);
defsubr (&Srecursive_edit);
@@ -11358,7 +11324,9 @@ so that you can determine whether the command was run by mouse or not. */);
These events are processed first, before actual keyboard input.
Events read from this list are not normally added to `this-command-keys',
as they will already have been added once as they were read for the first time.
-An element of the form (t . EVENT) forces EVENT to be added to that list. */);
+An element of the form (t . EVENT) forces EVENT to be added to that list.
+An element of the form (no-record . EVENT) means process EVENT, but do not
+record it in the keyboard macros, recent-keys, and the dribble file. */);
Vunread_command_events = Qnil;
DEFVAR_LISP ("unread-post-input-method-events", Vunread_post_input_method_events,
@@ -11437,6 +11405,10 @@ result of looking up the original command in the active keymaps. */);
Zero means disable autosaving due to number of characters typed. */);
auto_save_interval = 300;
+ DEFVAR_BOOL ("auto-save-no-message", auto_save_no_message,
+ doc: /* Non-nil means do not print any message when auto-saving. */);
+ auto_save_no_message = false;
+
DEFVAR_LISP ("auto-save-timeout", Vauto_save_timeout,
doc: /* Number of seconds idle time before auto-save.
Zero or nil means disable auto-saving due to idleness.
@@ -11448,7 +11420,7 @@ Emacs also does a garbage collection if that seems to be warranted. */);
doc: /* Nonzero means echo unfinished commands after this many seconds of pause.
The value may be integer or floating point.
If the value is zero, don't echo at all. */);
- Vecho_keystrokes = make_number (1);
+ Vecho_keystrokes = make_fixnum (1);
DEFVAR_INT ("polling-period", polling_period,
doc: /* Interval between polling for input during Lisp execution.
@@ -11462,7 +11434,7 @@ Polling is automatically disabled in all other cases. */);
Measured in milliseconds. The value nil means disable double-click
recognition; t means double-clicks have no time limit and are detected
by position only. */);
- Vdouble_click_time = make_number (500);
+ Vdouble_click_time = make_fixnum (500);
DEFVAR_INT ("double-click-fuzz", double_click_fuzz,
doc: /* Maximum mouse movement between clicks to make a double-click.
@@ -11812,7 +11784,7 @@ suppressed only after special commands that leave
doc: /* How long to display an echo-area message when the minibuffer is active.
If the value is a number, it should be specified in seconds.
If the value is not a number, such messages never time out. */);
- Vminibuffer_message_timeout = make_number (2);
+ Vminibuffer_message_timeout = make_fixnum (2);
DEFVAR_LISP ("throw-on-input", Vthrow_on_input,
doc: /* If non-nil, any keyboard input throws to this symbol.
@@ -11896,13 +11868,54 @@ preserve data in modified buffers that would otherwise be lost.
If nil, Emacs crashes immediately in response to fatal signals. */);
attempt_orderly_shutdown_on_fatal_signal = true;
- /* Create the initial keyboard. Qt means 'unset'. */
- initial_kboard = allocate_kboard (Qt);
-
DEFVAR_LISP ("while-no-input-ignore-events",
Vwhile_no_input_ignore_events,
doc: /* Ignored events from while-no-input. */);
+
+ DEFVAR_BOOL ("inhibit--record-char",
+ inhibit_record_char,
+ doc: /* If non-nil, don't record input events.
+This inhibits recording input events for the purposes of keyboard
+macros, dribble file, and `recent-keys'.
+Internal use only. */);
+
+ pdumper_do_now_and_after_load (syms_of_keyboard_for_pdumper);
+}
+
+static void
+syms_of_keyboard_for_pdumper (void)
+{
+ /* Make sure input state is pristine when restoring from a dump.
+ init_keyboard() also resets some of these, but the duplication
+ doesn't hurt and makes sure that allocate_kboard and subsequent
+ early init functions see the environment they expect. */
+
+ PDUMPER_RESET_LV (pending_funcalls, Qnil);
+ PDUMPER_RESET_LV (unread_switch_frame, Qnil);
+ PDUMPER_RESET_LV (internal_last_event_frame, Qnil);
+ PDUMPER_RESET_LV (last_command_event, Qnil);
+ PDUMPER_RESET_LV (last_nonmenu_event, Qnil);
+ PDUMPER_RESET_LV (last_input_event, Qnil);
+ PDUMPER_RESET_LV (Vunread_command_events, Qnil);
+ PDUMPER_RESET_LV (Vunread_post_input_method_events, Qnil);
+ PDUMPER_RESET_LV (Vunread_input_method_events, Qnil);
+ PDUMPER_RESET_LV (Vthis_command, Qnil);
+ PDUMPER_RESET_LV (Vreal_this_command, Qnil);
+ PDUMPER_RESET_LV (Vthis_command_keys_shift_translated, Qnil);
+ PDUMPER_RESET_LV (Vthis_original_command, Qnil);
+ PDUMPER_RESET (num_input_keys, 0);
+ PDUMPER_RESET (num_nonmacro_input_events, 0);
+ PDUMPER_RESET_LV (Vlast_event_frame, Qnil);
+ PDUMPER_RESET_LV (Vdeferred_action_list, Qnil);
+ PDUMPER_RESET_LV (Vdelayed_warnings_list, Qnil);
+
+ /* Create the initial keyboard. Qt means 'unset'. */
+ eassert (initial_kboard == NULL);
+ initial_kboard = allocate_kboard (Qt);
+
Vwhile_no_input_ignore_events = Qnil;
+
+ inhibit_record_char = false;
}
void
@@ -11963,6 +11976,12 @@ keys_of_keyboard (void)
"dbus-handle-event");
#endif
+#ifdef THREADS_ENABLED
+ /* Define a special event which is raised for thread signals. */
+ initial_define_lispy_key (Vspecial_event_map, "thread-event",
+ "thread-handle-event");
+#endif
+
#ifdef USE_FILE_NOTIFY
/* Define a special event which is raised for notification callback
functions. */
@@ -11994,8 +12013,8 @@ mark_kboards (void)
for (kb = all_kboards; kb; kb = kb->next_kboard)
{
if (kb->kbd_macro_buffer)
- for (p = kb->kbd_macro_buffer; p < kb->kbd_macro_ptr; p++)
- mark_object (*p);
+ for (p = kb->kbd_macro_buffer; p < kb->kbd_macro_ptr; p++)
+ mark_object (*p);
mark_object (KVAR (kb, Voverriding_terminal_local_map));
mark_object (KVAR (kb, Vlast_command));
mark_object (KVAR (kb, Vreal_last_command));
@@ -12015,26 +12034,18 @@ mark_kboards (void)
mark_object (KVAR (kb, echo_string));
mark_object (KVAR (kb, echo_prompt));
}
- {
- union buffered_input_event *event;
- for (event = kbd_fetch_ptr; event != kbd_store_ptr; event++)
- {
- if (event == kbd_buffer + KBD_BUFFER_SIZE)
- {
- event = kbd_buffer;
- if (event == kbd_store_ptr)
- break;
- }
- /* These two special event types has no Lisp_Objects to mark. */
- if (event->kind != SELECTION_REQUEST_EVENT
- && event->kind != SELECTION_CLEAR_EVENT)
- {
- mark_object (event->ie.x);
- mark_object (event->ie.y);
- mark_object (event->ie.frame_or_window);
- mark_object (event->ie.arg);
- }
- }
- }
+ for (union buffered_input_event *event = kbd_fetch_ptr;
+ event != kbd_store_ptr; event = next_kbd_event (event))
+ {
+ /* These two special event types have no Lisp_Objects to mark. */
+ if (event->kind != SELECTION_REQUEST_EVENT
+ && event->kind != SELECTION_CLEAR_EVENT)
+ {
+ mark_object (event->ie.x);
+ mark_object (event->ie.y);
+ mark_object (event->ie.frame_or_window);
+ mark_object (event->ie.arg);
+ }
+ }
}
diff --git a/src/keyboard.h b/src/keyboard.h
index a016ee74d6b..65c7402ddb5 100644
--- a/src/keyboard.h
+++ b/src/keyboard.h
@@ -327,9 +327,9 @@ extern Lisp_Object item_properties;
takes care of protecting all the data from GC. */
extern Lisp_Object menu_items;
-/* If non-nil, means that the global vars defined here are already in use.
+/* Whether the global vars defined here are already in use.
Used to detect cases where we try to re-enter this non-reentrant code. */
-extern Lisp_Object menu_items_inuse;
+extern bool menu_items_inuse;
/* Number of slots currently allocated in menu_items. */
extern int menu_items_allocated;
@@ -391,7 +391,7 @@ extern void unuse_menu_items (void);
#define EVENT_END(event) (CAR_SAFE (CDR_SAFE (CDR_SAFE (event))))
/* Extract the click count from a multi-click event. */
-#define EVENT_CLICK_COUNT(event) (Fnth (make_number (2), (event)))
+#define EVENT_CLICK_COUNT(event) (Fnth (make_fixnum (2), (event)))
/* Extract the fields of a position. */
#define POSN_WINDOW(posn) (CAR_SAFE (posn))
@@ -399,17 +399,17 @@ extern void unuse_menu_items (void);
#define POSN_SET_POSN(posn,x) (XSETCAR (XCDR (posn), (x)))
#define POSN_WINDOW_POSN(posn) (CAR_SAFE (CDR_SAFE (CDR_SAFE (posn))))
#define POSN_TIMESTAMP(posn) (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (posn)))))
-#define POSN_SCROLLBAR_PART(posn) (Fnth (make_number (4), (posn)))
+#define POSN_SCROLLBAR_PART(posn) (Fnth (make_fixnum (4), (posn)))
/* A cons (STRING . STRING-CHARPOS), or nil in mouse-click events.
It's a cons if the click is over a string in the mode line. */
-#define POSN_STRING(posn) (Fnth (make_number (4), (posn)))
+#define POSN_STRING(posn) (Fnth (make_fixnum (4), (posn)))
/* If POSN_STRING is nil, event refers to buffer location. */
#define POSN_INBUFFER_P(posn) (NILP (POSN_STRING (posn)))
-#define POSN_BUFFER_POSN(posn) (Fnth (make_number (5), (posn)))
+#define POSN_BUFFER_POSN(posn) (Fnth (make_fixnum (5), (posn)))
/* Getting the kind of an event head. */
#define EVENT_HEAD_KIND(event_head) \
@@ -438,6 +438,7 @@ extern unsigned int timers_run;
extern bool menu_separator_name_p (const char *);
extern bool parse_menu_item (Lisp_Object, int);
+extern void init_raw_keybuf_count (void);
extern KBOARD *allocate_kboard (Lisp_Object);
extern void delete_kboard (KBOARD *);
extern void not_single_kboard_state (KBOARD *);
diff --git a/src/keymap.c b/src/keymap.c
index 975688b9d3d..2ac3d33460c 100644
--- a/src/keymap.c
+++ b/src/keymap.c
@@ -120,11 +120,7 @@ The optional arg STRING supplies a menu name for the keymap
in case you use it as a menu with `x-popup-menu'. */)
(Lisp_Object string)
{
- Lisp_Object tail;
- if (!NILP (string))
- tail = list1 (string);
- else
- tail = Qnil;
+ Lisp_Object tail = !NILP (string) ? list1 (string) : Qnil;
return Fcons (Qkeymap,
Fcons (Fmake_char_table (Qkeymap, Qnil), tail));
}
@@ -159,7 +155,7 @@ in case you use it as a menu with `x-popup-menu'. */)
void
initial_define_key (Lisp_Object keymap, int key, const char *defname)
{
- store_in_keymap (keymap, make_number (key), intern_c_string (defname));
+ store_in_keymap (keymap, make_fixnum (key), intern_c_string (defname));
}
void
@@ -248,7 +244,7 @@ get_keymap (Lisp_Object object, bool error_if_not_keymap, bool autoload)
{
Lisp_Object tail;
- tail = Fnth (make_number (4), tem);
+ tail = Fnth (make_fixnum (4), tem);
if (EQ (tail, Qkeymap))
{
if (autoload)
@@ -379,28 +375,28 @@ access_keymap_1 (Lisp_Object map, Lisp_Object idx,
be put in the canonical order. */
if (SYMBOLP (idx))
idx = reorder_modifiers (idx);
- else if (INTEGERP (idx))
+ else if (FIXNUMP (idx))
/* Clobber the high bits that can be present on a machine
with more than 24 bits of integer. */
- XSETFASTINT (idx, XINT (idx) & (CHAR_META | (CHAR_META - 1)));
+ XSETFASTINT (idx, XFIXNUM (idx) & (CHAR_META | (CHAR_META - 1)));
/* Handle the special meta -> esc mapping. */
- if (INTEGERP (idx) && XFASTINT (idx) & meta_modifier)
+ if (FIXNUMP (idx) && XFIXNAT (idx) & meta_modifier)
{
/* See if there is a meta-map. If there's none, there is
no binding for IDX, unless a default binding exists in MAP. */
Lisp_Object event_meta_binding, event_meta_map;
/* A strange value in which Meta is set would cause
infinite recursion. Protect against that. */
- if (XINT (meta_prefix_char) & CHAR_META)
- meta_prefix_char = make_number (27);
+ if (XFIXNUM (meta_prefix_char) & CHAR_META)
+ meta_prefix_char = make_fixnum (27);
event_meta_binding = access_keymap_1 (map, meta_prefix_char, t_ok,
noinherit, autoload);
event_meta_map = get_keymap (event_meta_binding, 0, autoload);
if (CONSP (event_meta_map))
{
map = event_meta_map;
- idx = make_number (XFASTINT (idx) & ~meta_modifier);
+ idx = make_fixnum (XFIXNAT (idx) & ~meta_modifier);
}
else if (t_ok)
/* Set IDX to t, so that we only find a default binding. */
@@ -473,15 +469,15 @@ access_keymap_1 (Lisp_Object map, Lisp_Object idx,
}
else if (VECTORP (binding))
{
- if (INTEGERP (idx) && XFASTINT (idx) < ASIZE (binding))
- val = AREF (binding, XFASTINT (idx));
+ if (FIXNUMP (idx) && XFIXNAT (idx) < ASIZE (binding))
+ val = AREF (binding, XFIXNAT (idx));
}
else if (CHAR_TABLE_P (binding))
{
/* Character codes with modifiers
are not included in a char-table.
All character codes without modifiers are included. */
- if (INTEGERP (idx) && (XFASTINT (idx) & CHAR_MODIFIER_MASK) == 0)
+ if (FIXNUMP (idx) && (XFIXNAT (idx) & CHAR_MODIFIER_MASK) == 0)
{
val = Faref (binding, idx);
/* nil has a special meaning for char-tables, so
@@ -546,19 +542,29 @@ map_keymap_item (map_keymap_function_t fun, Lisp_Object args, Lisp_Object key, L
(*fun) (key, val, args, data);
}
+union map_keymap
+{
+ struct
+ {
+ map_keymap_function_t fun;
+ Lisp_Object args;
+ void *data;
+ } s;
+ GCALIGNED_UNION_MEMBER
+};
+verify (GCALIGNED (union map_keymap));
+
static void
map_keymap_char_table_item (Lisp_Object args, Lisp_Object key, Lisp_Object val)
{
if (!NILP (val))
{
- map_keymap_function_t fun
- = (map_keymap_function_t) XSAVE_FUNCPOINTER (args, 0);
/* If the key is a range, make a copy since map_char_table modifies
it in place. */
if (CONSP (key))
key = Fcons (XCAR (key), XCDR (key));
- map_keymap_item (fun, XSAVE_OBJECT (args, 2), key,
- val, XSAVE_POINTER (args, 1));
+ union map_keymap *md = XFIXNUMPTR (args);
+ map_keymap_item (md->s.fun, md->s.args, key, val, md->s.data);
}
}
@@ -594,9 +600,11 @@ map_keymap_internal (Lisp_Object map,
}
}
else if (CHAR_TABLE_P (binding))
- map_char_table (map_keymap_char_table_item, Qnil, binding,
- make_save_funcptr_ptr_obj ((voidfuncptr) fun, data,
- args));
+ {
+ union map_keymap mapdata = {{fun, args, data}};
+ map_char_table (map_keymap_char_table_item, Qnil, binding,
+ make_pointer_integer (&mapdata));
+ }
}
return tail;
@@ -770,10 +778,10 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def)
be put in the canonical order. */
if (SYMBOLP (idx))
idx = reorder_modifiers (idx);
- else if (INTEGERP (idx))
+ else if (FIXNUMP (idx))
/* Clobber the high bits that can be present on a machine
with more than 24 bits of integer. */
- XSETFASTINT (idx, XINT (idx) & (CHAR_META | (CHAR_META - 1)));
+ XSETFASTINT (idx, XFIXNUM (idx) & (CHAR_META | (CHAR_META - 1)));
/* Scan the keymap for a binding of idx. */
{
@@ -795,22 +803,22 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def)
elt = XCAR (tail);
if (VECTORP (elt))
{
- if (NATNUMP (idx) && XFASTINT (idx) < ASIZE (elt))
+ if (FIXNATP (idx) && XFIXNAT (idx) < ASIZE (elt))
{
CHECK_IMPURE (elt, XVECTOR (elt));
- ASET (elt, XFASTINT (idx), def);
+ ASET (elt, XFIXNAT (idx), def);
return def;
}
else if (CONSP (idx) && CHARACTERP (XCAR (idx)))
{
- int from = XFASTINT (XCAR (idx));
- int to = XFASTINT (XCDR (idx));
+ int from = XFIXNAT (XCAR (idx));
+ int to = XFIXNAT (XCDR (idx));
if (to >= ASIZE (elt))
to = ASIZE (elt) - 1;
for (; from <= to; from++)
ASET (elt, from, def);
- if (to == XFASTINT (XCDR (idx)))
+ if (to == XFIXNAT (XCDR (idx)))
/* We have defined all keys in IDX. */
return def;
}
@@ -821,7 +829,7 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def)
/* Character codes with modifiers
are not included in a char-table.
All character codes without modifiers are included. */
- if (NATNUMP (idx) && !(XFASTINT (idx) & CHAR_MODIFIER_MASK))
+ if (FIXNATP (idx) && !(XFIXNAT (idx) & CHAR_MODIFIER_MASK))
{
Faset (elt, idx,
/* nil has a special meaning for char-tables, so
@@ -858,11 +866,11 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def)
&& CHARACTERP (XCAR (idx))
&& CHARACTERP (XCAR (elt)))
{
- int from = XFASTINT (XCAR (idx));
- int to = XFASTINT (XCDR (idx));
+ int from = XFIXNAT (XCAR (idx));
+ int to = XFIXNAT (XCDR (idx));
- if (from <= XFASTINT (XCAR (elt))
- && to >= XFASTINT (XCAR (elt)))
+ if (from <= XFIXNAT (XCAR (elt))
+ && to >= XFIXNAT (XCAR (elt)))
{
XSETCDR (elt, def);
if (from == to)
@@ -1081,7 +1089,7 @@ binding KEY to DEF is added at the front of KEYMAP. */)
if (VECTORP (def) && ASIZE (def) > 0 && CONSP (AREF (def, 0)))
{ /* DEF is apparently an XEmacs-style keyboard macro. */
- Lisp_Object tmp = Fmake_vector (make_number (ASIZE (def)), Qnil);
+ Lisp_Object tmp = make_nil_vector (ASIZE (def));
ptrdiff_t i = ASIZE (def);
while (--i >= 0)
{
@@ -1096,7 +1104,7 @@ binding KEY to DEF is added at the front of KEYMAP. */)
idx = 0;
while (1)
{
- c = Faref (key, make_number (idx));
+ c = Faref (key, make_fixnum (idx));
if (CONSP (c))
{
@@ -1111,8 +1119,8 @@ binding KEY to DEF is added at the front of KEYMAP. */)
if (SYMBOLP (c))
silly_event_symbol_error (c);
- if (INTEGERP (c)
- && (XINT (c) & meta_bit)
+ if (FIXNUMP (c)
+ && (XFIXNUM (c) & meta_bit)
&& !metized)
{
c = meta_prefix_char;
@@ -1120,17 +1128,17 @@ binding KEY to DEF is added at the front of KEYMAP. */)
}
else
{
- if (INTEGERP (c))
- XSETINT (c, XINT (c) & ~meta_bit);
+ if (FIXNUMP (c))
+ XSETINT (c, XFIXNUM (c) & ~meta_bit);
metized = 0;
idx++;
}
- if (!INTEGERP (c) && !SYMBOLP (c)
+ if (!FIXNUMP (c) && !SYMBOLP (c)
&& (!CONSP (c)
/* If C is a range, it must be a leaf. */
- || (INTEGERP (XCAR (c)) && idx != length)))
+ || (FIXNUMP (XCAR (c)) && idx != length)))
message_with_string ("Key sequence contains invalid event %s", c, 1);
if (idx == length)
@@ -1153,8 +1161,8 @@ binding KEY to DEF is added at the front of KEYMAP. */)
error; key might be a vector, not a string. */
error ("Key sequence %s starts with non-prefix key %s%s",
SDATA (Fkey_description (key, Qnil)),
- SDATA (Fkey_description (Fsubstring (key, make_number (0),
- make_number (idx)),
+ SDATA (Fkey_description (Fsubstring (key, make_fixnum (0),
+ make_fixnum (idx)),
Qnil)),
trailing_esc);
}
@@ -1174,7 +1182,7 @@ number or marker, in which case the keymap properties at the specified
buffer position instead of point are used. The KEYMAPS argument is
ignored if POSITION is non-nil.
-If the optional argument KEYMAPS is non-nil, it should be a list of
+If the optional argument KEYMAPS is non-nil, it should be a keymap or list of
keymaps to search for command remapping. Otherwise, search for the
remapping in all currently active keymaps. */)
(Lisp_Object command, Lisp_Object position, Lisp_Object keymaps)
@@ -1187,16 +1195,15 @@ remapping in all currently active keymaps. */)
if (NILP (keymaps))
command = Fkey_binding (command_remapping_vector, Qnil, Qt, position);
else
- command = Flookup_key (Fcons (Qkeymap, keymaps),
- command_remapping_vector, Qnil);
- return INTEGERP (command) ? Qnil : command;
+ command = Flookup_key (keymaps, command_remapping_vector, Qnil);
+ return FIXNUMP (command) ? Qnil : command;
}
/* Value is number if KEY is too long; nil if valid but has no definition. */
/* GC is possible in this function. */
DEFUN ("lookup-key", Flookup_key, Slookup_key, 2, 3, 0,
- doc: /* In keymap KEYMAP, look up key sequence KEY. Return the definition.
+ doc: /* Look up key sequence KEY in KEYMAP. Return the definition.
A value of nil means undefined. See doc of `define-key'
for kinds of definitions.
@@ -1205,6 +1212,7 @@ that is, characters or symbols in it except for the last one
fail to be a valid sequence of prefix characters in KEYMAP.
The number is how many characters at the front of KEY
it takes to reach a non-prefix key.
+KEYMAP can also be a list of keymaps.
Normally, `lookup-key' ignores bindings for t, which act as default
bindings, used when nothing else in the keymap applies; this makes it
@@ -1219,7 +1227,8 @@ recognize the default bindings, just as `read-key-sequence' does. */)
ptrdiff_t length;
bool t_ok = !NILP (accept_default);
- keymap = get_keymap (keymap, 1, 1);
+ if (!CONSP (keymap) && !NILP (keymap))
+ keymap = get_keymap (keymap, true, true);
length = CHECK_VECTOR_OR_STRING (key);
if (length == 0)
@@ -1228,18 +1237,18 @@ recognize the default bindings, just as `read-key-sequence' does. */)
idx = 0;
while (1)
{
- c = Faref (key, make_number (idx++));
+ c = Faref (key, make_fixnum (idx++));
if (CONSP (c) && lucid_event_type_list_p (c))
c = Fevent_convert_list (c);
/* Turn the 8th bit of string chars into a meta modifier. */
- if (STRINGP (key) && XINT (c) & 0x80 && !STRING_MULTIBYTE (key))
- XSETINT (c, (XINT (c) | meta_modifier) & ~0x80);
+ if (STRINGP (key) && XFIXNUM (c) & 0x80 && !STRING_MULTIBYTE (key))
+ XSETINT (c, (XFIXNUM (c) | meta_modifier) & ~0x80);
/* Allow string since binding for `menu-bar-select-buffer'
includes the buffer name in the key sequence. */
- if (!INTEGERP (c) && !SYMBOLP (c) && !CONSP (c) && !STRINGP (c))
+ if (!FIXNUMP (c) && !SYMBOLP (c) && !CONSP (c) && !STRINGP (c))
message_with_string ("Key sequence contains invalid event %s", c, 1);
cmd = access_keymap (keymap, c, t_ok, 0, 1);
@@ -1248,7 +1257,7 @@ recognize the default bindings, just as `read-key-sequence' does. */)
keymap = get_keymap (cmd, 0, 1);
if (!CONSP (keymap))
- return make_number (idx);
+ return make_fixnum (idx);
maybe_quit ();
}
@@ -1288,7 +1297,7 @@ silly_event_symbol_error (Lisp_Object c)
int modifiers;
parsed = parse_modifiers (c);
- modifiers = XFASTINT (XCAR (XCDR (parsed)));
+ modifiers = XFIXNAT (XCAR (XCDR (parsed)));
base = XCAR (parsed);
name = Fsymbol_name (base);
/* This alist includes elements such as ("RET" . "\\r"). */
@@ -1462,7 +1471,7 @@ current_minor_maps (Lisp_Object **modeptr, Lisp_Object **mapptr)
static ptrdiff_t
click_position (Lisp_Object position)
{
- EMACS_INT pos = (INTEGERP (position) ? XINT (position)
+ EMACS_INT pos = (FIXNUMP (position) ? XFIXNUM (position)
: MARKERP (position) ? marker_position (position)
: PT);
if (! (BEGV <= pos && pos <= ZV))
@@ -1540,13 +1549,13 @@ like in the respective argument of `key-binding'. */)
Lisp_Object pos;
pos = POSN_BUFFER_POSN (position);
- if (INTEGERP (pos)
- && XINT (pos) >= BEG && XINT (pos) <= Z)
+ if (FIXNUMP (pos)
+ && XFIXNUM (pos) >= BEG && XFIXNUM (pos) <= Z)
{
- local_map = get_local_map (XINT (pos),
+ local_map = get_local_map (XFIXNUM (pos),
current_buffer, Qlocal_map);
- keymap = get_local_map (XINT (pos),
+ keymap = get_local_map (XFIXNUM (pos),
current_buffer, Qkeymap);
}
}
@@ -1563,9 +1572,9 @@ like in the respective argument of `key-binding'. */)
pos = XCDR (string);
string = XCAR (string);
- if (INTEGERP (pos)
- && XINT (pos) >= 0
- && XINT (pos) < SCHARS (string))
+ if (FIXNUMP (pos)
+ && XFIXNUM (pos) >= 0
+ && XFIXNUM (pos) < SCHARS (string))
{
map = Fget_text_property (pos, Qlocal_map, string);
if (!NILP (map))
@@ -1596,9 +1605,7 @@ like in the respective argument of `key-binding'. */)
keymaps = Fcons (otlp, keymaps);
}
- unbind_to (count, Qnil);
-
- return keymaps;
+ return unbind_to (count, keymaps);
}
/* GC is possible in this function if it autoloads a keymap. */
@@ -1654,10 +1661,10 @@ specified buffer position instead of point are used.
}
}
- value = Flookup_key (Fcons (Qkeymap, Fcurrent_active_maps (Qt, position)),
+ value = Flookup_key (Fcurrent_active_maps (Qt, position),
key, accept_default);
- if (NILP (value) || INTEGERP (value))
+ if (NILP (value) || FIXNUMP (value))
return Qnil;
/* If the result of the ordinary keymap lookup is an interactive
@@ -1735,7 +1742,7 @@ bindings; see the description of `lookup-key' for more details about this. */)
for (i = j = 0; i < nmaps; i++)
if (!NILP (maps[i])
&& !NILP (binding = Flookup_key (maps[i], key, accept_default))
- && !INTEGERP (binding))
+ && !FIXNUMP (binding))
{
if (KEYMAPP (binding))
maps[j++] = Fcons (modes[i], binding);
@@ -1833,7 +1840,7 @@ accessible_keymaps_1 (Lisp_Object key, Lisp_Object cmd, Lisp_Object args, void *
Lisp_Object maps = d->maps;
Lisp_Object tail = d->tail;
Lisp_Object thisseq = d->thisseq;
- bool is_metized = d->is_metized && INTEGERP (key);
+ bool is_metized = d->is_metized && FIXNUMP (key);
Lisp_Object tem;
cmd = get_keymap (get_keyelt (cmd, 0), 0, 0);
@@ -1844,12 +1851,12 @@ accessible_keymaps_1 (Lisp_Object key, Lisp_Object cmd, Lisp_Object args, void *
while (!NILP (tem = Frassq (cmd, maps)))
{
Lisp_Object prefix = XCAR (tem);
- ptrdiff_t lim = XINT (Flength (XCAR (tem)));
- if (lim <= XINT (Flength (thisseq)))
+ ptrdiff_t lim = XFIXNUM (Flength (XCAR (tem)));
+ if (lim <= XFIXNUM (Flength (thisseq)))
{ /* This keymap was already seen with a smaller prefix. */
ptrdiff_t i = 0;
- while (i < lim && EQ (Faref (prefix, make_number (i)),
- Faref (thisseq, make_number (i))))
+ while (i < lim && EQ (Faref (prefix, make_fixnum (i)),
+ Faref (thisseq, make_fixnum (i))))
i++;
if (i >= lim)
/* `prefix' is a prefix of `thisseq' => there's a cycle. */
@@ -1869,10 +1876,10 @@ accessible_keymaps_1 (Lisp_Object key, Lisp_Object cmd, Lisp_Object args, void *
if (is_metized)
{
int meta_bit = meta_modifier;
- Lisp_Object last = make_number (XINT (Flength (thisseq)) - 1);
+ Lisp_Object last = make_fixnum (XFIXNUM (Flength (thisseq)) - 1);
tem = Fcopy_sequence (thisseq);
- Faset (tem, last, make_number (XINT (key) | meta_bit));
+ Faset (tem, last, make_fixnum (XFIXNUM (key) | meta_bit));
/* This new sequence is the same length as
thisseq, so stick it in the list right
@@ -1900,7 +1907,7 @@ then the value includes only maps for prefixes that start with PREFIX. */)
(Lisp_Object keymap, Lisp_Object prefix)
{
Lisp_Object maps, tail;
- EMACS_INT prefixlen = XFASTINT (Flength (prefix));
+ EMACS_INT prefixlen = XFIXNAT (Flength (prefix));
if (!NILP (prefix))
{
@@ -1920,18 +1927,16 @@ then the value includes only maps for prefixes that start with PREFIX. */)
we don't have to deal with the possibility of a string. */
if (STRINGP (prefix))
{
- int i, i_byte, c;
- Lisp_Object copy;
-
- copy = Fmake_vector (make_number (SCHARS (prefix)), Qnil);
- for (i = 0, i_byte = 0; i < SCHARS (prefix);)
+ ptrdiff_t i_byte = 0;
+ Lisp_Object copy = make_nil_vector (SCHARS (prefix));
+ for (ptrdiff_t i = 0; i < SCHARS (prefix); )
{
- int i_before = i;
-
+ ptrdiff_t i_before = i;
+ int c;
FETCH_STRING_CHAR_ADVANCE (c, prefix, i, i_byte);
if (SINGLE_BYTE_CHAR_P (c) && (c & 0200))
c ^= 0200 | meta_modifier;
- ASET (copy, i_before, make_number (c));
+ ASET (copy, i_before, make_fixnum (c));
}
prefix = copy;
}
@@ -1959,11 +1964,11 @@ then the value includes only maps for prefixes that start with PREFIX. */)
data.thisseq = Fcar (XCAR (tail));
data.maps = maps;
data.tail = tail;
- last = make_number (XINT (Flength (data.thisseq)) - 1);
+ last = make_fixnum (XFIXNUM (Flength (data.thisseq)) - 1);
/* Does the current sequence end in the meta-prefix-char? */
- data.is_metized = (XINT (last) >= 0
+ data.is_metized = (XFIXNUM (last) >= 0
/* Don't metize the last char of PREFIX. */
- && XINT (last) >= prefixlen
+ && XFIXNUM (last) >= prefixlen
&& EQ (Faref (data.thisseq, last), meta_prefix_char));
/* Since we can't run lisp code, we can't scan autoloaded maps. */
@@ -1987,7 +1992,7 @@ For an approximate inverse of this, see `kbd'. */)
EMACS_INT i;
ptrdiff_t i_byte;
Lisp_Object *args;
- EMACS_INT size = XINT (Flength (keys));
+ EMACS_INT size = XFIXNUM (Flength (keys));
Lisp_Object list;
Lisp_Object sep = build_string (" ");
Lisp_Object key;
@@ -1996,7 +2001,7 @@ For an approximate inverse of this, see `kbd'. */)
USE_SAFE_ALLOCA;
if (!NILP (prefix))
- size += XINT (Flength (prefix));
+ size += XFIXNUM (Flength (prefix));
/* This has one extra element at the end that we don't pass to Fconcat. */
EMACS_INT size4;
@@ -2033,7 +2038,7 @@ For an approximate inverse of this, see `kbd'. */)
else if (VECTORP (list))
size = ASIZE (list);
else if (CONSP (list))
- size = XINT (Flength (list));
+ size = list_length (list);
else
wrong_type_argument (Qarrayp, list);
@@ -2062,9 +2067,9 @@ For an approximate inverse of this, see `kbd'. */)
if (add_meta)
{
- if (!INTEGERP (key)
+ if (!FIXNUMP (key)
|| EQ (key, meta_prefix_char)
- || (XINT (key) & meta_modifier))
+ || (XFIXNUM (key) & meta_modifier))
{
args[len++] = Fsingle_key_description (meta_prefix_char, Qnil);
args[len++] = sep;
@@ -2072,7 +2077,7 @@ For an approximate inverse of this, see `kbd'. */)
continue;
}
else
- XSETINT (key, XINT (key) | meta_modifier);
+ XSETINT (key, XFIXNUM (key) | meta_modifier);
add_meta = 0;
}
else if (EQ (key, meta_prefix_char))
@@ -2098,7 +2103,7 @@ push_key_description (EMACS_INT ch, char *p)
c2 = c & ~(alt_modifier | ctrl_modifier | hyper_modifier
| meta_modifier | shift_modifier | super_modifier);
- if (! CHARACTERP (make_number (c2)))
+ if (! CHARACTERP (make_fixnum (c2)))
{
/* KEY_DESCRIPTION_SIZE is large enough for this. */
p += sprintf (p, "[%d]", c);
@@ -2218,7 +2223,7 @@ See `text-char-description' for describing character codes. */)
if (CONSP (key) && lucid_event_type_list_p (key))
key = Fevent_convert_list (key);
- if (CONSP (key) && INTEGERP (XCAR (key)) && INTEGERP (XCDR (key)))
+ if (CONSP (key) && FIXNUMP (XCAR (key)) && FIXNUMP (XCDR (key)))
/* An interval from a map-char-table. */
{
AUTO_STRING (dot_dot, "..");
@@ -2229,10 +2234,10 @@ See `text-char-description' for describing character codes. */)
key = EVENT_HEAD (key);
- if (INTEGERP (key)) /* Normal character. */
+ if (FIXNUMP (key)) /* Normal character. */
{
char tem[KEY_DESCRIPTION_SIZE];
- char *p = push_key_description (XINT (key), tem);
+ char *p = push_key_description (XFIXNUM (key), tem);
*p = 0;
return make_specified_string (tem, -1, p - tem, 1);
}
@@ -2300,7 +2305,7 @@ See Info node `(elisp)Describing Characters' for examples. */)
CHECK_CHARACTER (character);
- c = XINT (character);
+ c = XFIXNUM (character);
if (!ASCII_CHAR_P (c))
{
int len = CHAR_STRING (c, (unsigned char *) str);
@@ -2322,7 +2327,7 @@ static int
preferred_sequence_p (Lisp_Object seq)
{
EMACS_INT i;
- EMACS_INT len = XFASTINT (Flength (seq));
+ EMACS_INT len = XFIXNAT (Flength (seq));
int result = 1;
for (i = 0; i < len; i++)
@@ -2332,11 +2337,11 @@ preferred_sequence_p (Lisp_Object seq)
XSETFASTINT (ii, i);
elt = Faref (seq, ii);
- if (!INTEGERP (elt))
+ if (!FIXNUMP (elt))
return 0;
else
{
- int modifiers = XINT (elt) & (CHAR_MODIFIER_MASK & ~CHAR_META);
+ int modifiers = XFIXNUM (elt) & (CHAR_MODIFIER_MASK & ~CHAR_META);
if (modifiers == where_is_preferred_modifier)
result = 2;
else if (modifiers)
@@ -2353,39 +2358,24 @@ preferred_sequence_p (Lisp_Object seq)
static void where_is_internal_1 (Lisp_Object key, Lisp_Object binding,
Lisp_Object args, void *data);
-/* Like Flookup_key, but uses a list of keymaps SHADOW instead of a single map.
- Returns the first non-nil binding found in any of those maps.
- If REMAP is true, pass the result of the lookup through command
- remapping before returning it. */
+/* Like Flookup_key, but with command remapping; just returns nil
+ if the key sequence is too long. */
static Lisp_Object
-shadow_lookup (Lisp_Object shadow, Lisp_Object key, Lisp_Object flag,
+shadow_lookup (Lisp_Object keymap, Lisp_Object key, Lisp_Object accept_default,
bool remap)
{
- Lisp_Object tail, value;
+ Lisp_Object value = Flookup_key (keymap, key, accept_default);
- for (tail = shadow; CONSP (tail); tail = XCDR (tail))
+ if (FIXNATP (value)) /* `key' is too long! */
+ return Qnil;
+ else if (!NILP (value) && remap && SYMBOLP (value))
{
- value = Flookup_key (XCAR (tail), key, flag);
- if (NATNUMP (value))
- {
- value = Flookup_key (XCAR (tail),
- Fsubstring (key, make_number (0), value), flag);
- if (!NILP (value))
- return Qnil;
- }
- else if (!NILP (value))
- {
- Lisp_Object remapping;
- if (remap && SYMBOLP (value)
- && (remapping = Fcommand_remapping (value, Qnil, shadow),
- !NILP (remapping)))
- return remapping;
- else
- return value;
- }
+ Lisp_Object remapping = Fcommand_remapping (value, Qnil, keymap);
+ return (!NILP (remapping) ? remapping : value);
}
- return Qnil;
+ else
+ return value;
}
static Lisp_Object Vmouse_events;
@@ -2457,13 +2447,13 @@ where_is_internal (Lisp_Object definition, Lisp_Object keymaps,
this = Fcar (XCAR (maps));
map = Fcdr (XCAR (maps));
- last = make_number (XINT (Flength (this)) - 1);
- last_is_meta = (XINT (last) >= 0
+ last = make_fixnum (XFIXNUM (Flength (this)) - 1);
+ last_is_meta = (XFIXNUM (last) >= 0
&& EQ (Faref (this, last), meta_prefix_char));
/* if (nomenus && !preferred_sequence_p (this)) */
- if (nomenus && XINT (last) >= 0
- && SYMBOLP (tem = Faref (this, make_number (0)))
+ if (nomenus && XFIXNUM (last) >= 0
+ && SYMBOLP (tem = Faref (this, make_fixnum (0)))
&& !NILP (Fmemq (XCAR (parse_modifiers (tem)), Vmouse_events)))
/* If no menu entries should be returned, skip over the
keymaps bound to `menu-bar' and `tool-bar' and other
@@ -2559,7 +2549,7 @@ The optional 5th arg NO-REMAP alters how command remapping is handled:
keymaps = Fcurrent_active_maps (Qnil, Qnil);
tem = Fcommand_remapping (definition, Qnil, keymaps);
- /* If `definition' is remapped to tem', then OT1H no key will run
+ /* If `definition' is remapped to `tem', then OT1H no key will run
that command (since they will run `tem' instead), so we should
return nil; but OTOH all keys bound to `definition' (or to `tem')
will run the same command.
@@ -2581,6 +2571,8 @@ The optional 5th arg NO-REMAP alters how command remapping is handled:
&& !NILP (tem = Fget (definition, QCadvertised_binding)))
{
/* We have a list of advertised bindings. */
+ /* FIXME: Not sure why we use false for shadow_lookup's remapping,
+ nor why we use `EQ' here but `Fequal' in the call further down. */
while (CONSP (tem))
if (EQ (shadow_lookup (keymaps, XCAR (tem), Qnil, 0), definition))
return XCAR (tem);
@@ -2640,9 +2632,9 @@ The optional 5th arg NO-REMAP alters how command remapping is handled:
if (! NILP (sequence))
{
Lisp_Object tem1;
- tem1 = Faref (sequence, make_number (ASIZE (sequence) - 1));
+ tem1 = Faref (sequence, make_fixnum (ASIZE (sequence) - 1));
if (STRINGP (tem1))
- Faset (sequence, make_number (ASIZE (sequence) - 1),
+ Faset (sequence, make_fixnum (ASIZE (sequence) - 1),
build_string ("(any string)"));
}
@@ -2711,10 +2703,10 @@ where_is_internal_1 (Lisp_Object key, Lisp_Object binding, Lisp_Object args, voi
return;
/* We have found a match. Construct the key sequence where we found it. */
- if (INTEGERP (key) && last_is_meta)
+ if (FIXNUMP (key) && last_is_meta)
{
sequence = Fcopy_sequence (this);
- Faset (sequence, last, make_number (XINT (key) | meta_modifier));
+ Faset (sequence, last, make_fixnum (XFIXNUM (key) | meta_modifier));
}
else
{
@@ -2780,7 +2772,7 @@ You type Translation\n\
bufend = push_key_description (translate[c], buf);
insert (buf, bufend - buf);
- Findent_to (make_number (16), make_number (1));
+ Findent_to (make_fixnum (16), make_fixnum (1));
bufend = push_key_description (c, buf);
insert (buf, bufend - buf);
@@ -2956,7 +2948,7 @@ key binding\n\
elt_prefix = Fcar (elt);
if (ASIZE (elt_prefix) >= 1)
{
- tem = Faref (elt_prefix, make_number (0));
+ tem = Faref (elt_prefix, make_fixnum (0));
if (EQ (tem, Qmenu_bar))
maps = Fdelq (elt, maps);
}
@@ -2986,38 +2978,17 @@ key binding\n\
elt = XCAR (maps);
elt_prefix = Fcar (elt);
- sub_shadows = Qnil;
-
- for (tail = shadow; CONSP (tail); tail = XCDR (tail))
- {
- Lisp_Object shmap;
-
- shmap = XCAR (tail);
-
- /* If the sequence by which we reach this keymap is zero-length,
- then the shadow map for this keymap is just SHADOW. */
- if ((STRINGP (elt_prefix) && SCHARS (elt_prefix) == 0)
- || (VECTORP (elt_prefix) && ASIZE (elt_prefix) == 0))
- ;
- /* If the sequence by which we reach this keymap actually has
- some elements, then the sequence's definition in SHADOW is
- what we should use. */
- else
- {
- shmap = Flookup_key (shmap, Fcar (elt), Qt);
- if (INTEGERP (shmap))
- shmap = Qnil;
- }
-
- /* If shmap is not nil and not a keymap,
+ sub_shadows = Flookup_key (shadow, elt_prefix, Qt);
+ if (FIXNATP (sub_shadows))
+ sub_shadows = Qnil;
+ else if (!KEYMAPP (sub_shadows)
+ && !NILP (sub_shadows)
+ && !(CONSP (sub_shadows)
+ && KEYMAPP (XCAR (sub_shadows))))
+ /* If elt_prefix is bound to something that's not a keymap,
it completely shadows this map, so don't
describe this map at all. */
- if (!NILP (shmap) && !KEYMAPP (shmap))
- goto skip;
-
- if (!NILP (shmap))
- sub_shadows = Fcons (shmap, sub_shadows);
- }
+ goto skip;
/* Maps we have already listed in this loop shadow this map. */
for (tail = orig_maps; !EQ (tail, maps); tail = XCDR (tail))
@@ -3060,7 +3031,7 @@ describe_command (Lisp_Object definition, Lisp_Object args)
else
description_column = 16;
- Findent_to (make_number (description_column), make_number (1));
+ Findent_to (make_fixnum (description_column), make_fixnum (1));
previous_description_column = description_column;
if (SYMBOLP (definition))
@@ -3082,7 +3053,7 @@ describe_translation (Lisp_Object definition, Lisp_Object args)
{
register Lisp_Object tem1;
- Findent_to (make_number (16), make_number (1));
+ Findent_to (make_fixnum (16), make_fixnum (1));
if (SYMBOLP (definition))
{
@@ -3119,12 +3090,12 @@ static int
describe_map_compare (const void *aa, const void *bb)
{
const struct describe_map_elt *a = aa, *b = bb;
- if (INTEGERP (a->event) && INTEGERP (b->event))
- return ((XINT (a->event) > XINT (b->event))
- - (XINT (a->event) < XINT (b->event)));
- if (!INTEGERP (a->event) && INTEGERP (b->event))
+ if (FIXNUMP (a->event) && FIXNUMP (b->event))
+ return ((XFIXNUM (a->event) > XFIXNUM (b->event))
+ - (XFIXNUM (a->event) < XFIXNUM (b->event)));
+ if (!FIXNUMP (a->event) && FIXNUMP (b->event))
return 1;
- if (INTEGERP (a->event) && !INTEGERP (b->event))
+ if (FIXNUMP (a->event) && !FIXNUMP (b->event))
return -1;
if (SYMBOLP (a->event) && SYMBOLP (b->event))
return (!NILP (Fstring_lessp (a->event, b->event)) ? -1
@@ -3164,7 +3135,7 @@ describe_map (Lisp_Object map, Lisp_Object prefix,
/* This vector gets used to present single keys to Flookup_key. Since
that is done once per keymap element, we don't want to cons up a
fresh vector every time. */
- kludge = Fmake_vector (make_number (1), Qnil);
+ kludge = make_nil_vector (1);
definition = Qnil;
map = call1 (Qkeymap_canonicalize, map);
@@ -3192,7 +3163,7 @@ describe_map (Lisp_Object map, Lisp_Object prefix,
/* Ignore bindings whose "prefix" are not really valid events.
(We get these in the frames and buffers menu.) */
- if (!(SYMBOLP (event) || INTEGERP (event)))
+ if (!(SYMBOLP (event) || FIXNUMP (event)))
continue;
if (nomenu && EQ (event, Qmenu_bar))
@@ -3276,10 +3247,10 @@ describe_map (Lisp_Object map, Lisp_Object prefix,
definition = vect[i].definition;
/* Find consecutive chars that are identically defined. */
- if (INTEGERP (vect[i].event))
+ if (FIXNUMP (vect[i].event))
{
while (i + 1 < slots_used
- && EQ (vect[i+1].event, make_number (XINT (vect[i].event) + 1))
+ && EQ (vect[i+1].event, make_fixnum (XFIXNUM (vect[i].event) + 1))
&& !NILP (Fequal (vect[i + 1].definition, definition))
&& vect[i].shadowed == vect[i + 1].shadowed)
i++;
@@ -3322,7 +3293,7 @@ describe_map (Lisp_Object map, Lisp_Object prefix,
static void
describe_vector_princ (Lisp_Object elt, Lisp_Object fun)
{
- Findent_to (make_number (16), make_number (1));
+ Findent_to (make_fixnum (16), make_fixnum (1));
call1 (fun, elt);
Fterpri (Qnil, Qnil);
}
@@ -3401,7 +3372,7 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args,
if (!keymap_p)
{
/* Call Fkey_description first, to avoid GC bug for the other string. */
- if (!NILP (prefix) && XFASTINT (Flength (prefix)) > 0)
+ if (!NILP (prefix) && XFIXNAT (Flength (prefix)) > 0)
{
Lisp_Object tem = Fkey_description (prefix, Qnil);
AUTO_STRING (space, " ");
@@ -3413,7 +3384,7 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args,
/* This vector gets used to present single keys to Flookup_key. Since
that is done once per vector element, we don't want to cons up a
fresh vector every time. */
- kludge = Fmake_vector (make_number (1), Qnil);
+ kludge = make_nil_vector (1);
if (partial)
suppress = intern ("suppress-keymap");
@@ -3463,7 +3434,7 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args,
if (!NILP (tem)) continue;
}
- character = make_number (starting_i);
+ character = make_fixnum (starting_i);
ASET (kludge, 0, character);
/* If this binding is shadowed by some other map, ignore it. */
@@ -3535,7 +3506,7 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args,
{
insert (" .. ", 4);
- ASET (kludge, 0, make_number (i));
+ ASET (kludge, 0, make_fixnum (i));
if (!NILP (elt_prefix))
insert1 (elt_prefix);
@@ -3612,7 +3583,7 @@ syms_of_keymap (void)
/* Now we are ready to set up this property, so we can
create char tables. */
- Fput (Qkeymap, Qchar_table_extra_slots, make_number (0));
+ Fput (Qkeymap, Qchar_table_extra_slots, make_fixnum (0));
/* Initialize the keymaps standardly used.
Each one is the value of a Lisp variable, and is also
@@ -3633,12 +3604,12 @@ syms_of_keymap (void)
Fset (intern_c_string ("ctl-x-map"), control_x_map);
Ffset (intern_c_string ("Control-X-prefix"), control_x_map);
- exclude_keys = listn (CONSTYPE_PURE, 5,
- pure_cons (build_pure_c_string ("DEL"), build_pure_c_string ("\\d")),
- pure_cons (build_pure_c_string ("TAB"), build_pure_c_string ("\\t")),
- pure_cons (build_pure_c_string ("RET"), build_pure_c_string ("\\r")),
- pure_cons (build_pure_c_string ("ESC"), build_pure_c_string ("\\e")),
- pure_cons (build_pure_c_string ("SPC"), build_pure_c_string (" ")));
+ exclude_keys = pure_list
+ (pure_cons (build_pure_c_string ("DEL"), build_pure_c_string ("\\d")),
+ pure_cons (build_pure_c_string ("TAB"), build_pure_c_string ("\\t")),
+ pure_cons (build_pure_c_string ("RET"), build_pure_c_string ("\\r")),
+ pure_cons (build_pure_c_string ("ESC"), build_pure_c_string ("\\e")),
+ pure_cons (build_pure_c_string ("SPC"), build_pure_c_string (" ")));
staticpro (&exclude_keys);
DEFVAR_LISP ("define-key-rebound-commands", Vdefine_key_rebound_commands,
@@ -3694,16 +3665,12 @@ be preferred. */);
DEFSYM (Qmode_line, "mode-line");
staticpro (&Vmouse_events);
- Vmouse_events = listn (CONSTYPE_PURE, 9,
- Qmenu_bar,
- Qtool_bar,
- Qheader_line,
- Qmode_line,
- intern_c_string ("mouse-1"),
- intern_c_string ("mouse-2"),
- intern_c_string ("mouse-3"),
- intern_c_string ("mouse-4"),
- intern_c_string ("mouse-5"));
+ Vmouse_events = pure_list (Qmenu_bar, Qtool_bar, Qheader_line, Qmode_line,
+ intern_c_string ("mouse-1"),
+ intern_c_string ("mouse-2"),
+ intern_c_string ("mouse-3"),
+ intern_c_string ("mouse-4"),
+ intern_c_string ("mouse-5"));
/* Keymap used for minibuffers when doing completion. */
/* Keymap used for minibuffers when doing completion and require a match. */
@@ -3713,7 +3680,7 @@ be preferred. */);
DEFSYM (Qremap, "remap");
DEFSYM (QCadvertised_binding, ":advertised-binding");
- command_remapping_vector = Fmake_vector (make_number (2), Qremap);
+ command_remapping_vector = make_vector (2, Qremap);
staticpro (&command_remapping_vector);
where_is_cache_keymaps = Qt;
diff --git a/src/kqueue.c b/src/kqueue.c
index 725a98b0b9f..48121bd663a 100644
--- a/src/kqueue.c
+++ b/src/kqueue.c
@@ -24,7 +24,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <sys/types.h>
#include <sys/event.h>
#include <sys/time.h>
-#include <sys/file.h>
+#include <fcntl.h>
#include "lisp.h"
#include "keyboard.h"
#include "process.h"
@@ -55,15 +55,15 @@ kqueue_directory_listing (Lisp_Object directory_files)
result = Fcons
(list5 (/* inode. */
- Fnth (make_number (11), XCAR (dl)),
+ Fnth (make_fixnum (11), XCAR (dl)),
/* filename. */
XCAR (XCAR (dl)),
/* last modification time. */
- Fnth (make_number (6), XCAR (dl)),
+ Fnth (make_fixnum (6), XCAR (dl)),
/* last status change time. */
- Fnth (make_number (7), XCAR (dl)),
+ Fnth (make_fixnum (7), XCAR (dl)),
/* size. */
- Fnth (make_number (8), XCAR (dl))),
+ Fnth (make_fixnum (8), XCAR (dl))),
result);
}
return result;
@@ -78,7 +78,7 @@ kqueue_generate_event (Lisp_Object watch_object, Lisp_Object actions,
struct input_event event;
/* Check, whether all actions shall be monitored. */
- flags = Fnth (make_number (2), watch_object);
+ flags = Fnth (make_fixnum (2), watch_object);
action = actions;
do {
if (NILP (action))
@@ -99,9 +99,9 @@ kqueue_generate_event (Lisp_Object watch_object, Lisp_Object actions,
event.arg = list2 (Fcons (XCAR (watch_object),
Fcons (actions,
NILP (file1)
- ? Fcons (file, Qnil)
+ ? list1 (file)
: list2 (file, file1))),
- Fnth (make_number (3), watch_object));
+ Fnth (make_fixnum (3), watch_object));
kbd_buffer_store_event (&event);
}
}
@@ -121,7 +121,7 @@ kqueue_compare_dir_list (Lisp_Object watch_object)
pending_dl = Qnil;
deleted_dl = Qnil;
- old_directory_files = Fnth (make_number (4), watch_object);
+ old_directory_files = Fnth (make_fixnum (4), watch_object);
old_dl = kqueue_directory_listing (old_directory_files);
/* When the directory is not accessible anymore, it has been deleted. */
@@ -155,14 +155,14 @@ kqueue_compare_dir_list (Lisp_Object watch_object)
if (strcmp (SSDATA (XCAR (XCDR (old_entry))),
SSDATA (XCAR (XCDR (new_entry)))) == 0) {
/* Modification time has been changed, the file has been written. */
- if (NILP (Fequal (Fnth (make_number (2), old_entry),
- Fnth (make_number (2), new_entry))))
+ if (NILP (Fequal (Fnth (make_fixnum (2), old_entry),
+ Fnth (make_fixnum (2), new_entry))))
kqueue_generate_event
(watch_object, Fcons (Qwrite, Qnil), XCAR (XCDR (old_entry)), Qnil);
/* Status change time has been changed, the file attributes
have changed. */
- if (NILP (Fequal (Fnth (make_number (3), old_entry),
- Fnth (make_number (3), new_entry))))
+ if (NILP (Fequal (Fnth (make_fixnum (3), old_entry),
+ Fnth (make_fixnum (3), new_entry))))
kqueue_generate_event
(watch_object, Fcons (Qattrib, Qnil),
XCAR (XCDR (old_entry)), Qnil);
@@ -233,8 +233,8 @@ kqueue_compare_dir_list (Lisp_Object watch_object)
(watch_object, Fcons (Qcreate, Qnil), XCAR (XCDR (entry)), Qnil);
/* Check size of that file. */
- Lisp_Object size = Fnth (make_number (4), entry);
- if (FLOATP (size) || (XINT (size) > 0))
+ Lisp_Object size = Fnth (make_fixnum (4), entry);
+ if (FLOATP (size) || (XFIXNUM (size) > 0))
kqueue_generate_event
(watch_object, Fcons (Qwrite, Qnil), XCAR (XCDR (entry)), Qnil);
@@ -270,7 +270,7 @@ kqueue_compare_dir_list (Lisp_Object watch_object)
report_file_error ("Pending events list not empty", pending_dl);
/* Replace old directory listing with the new one. */
- XSETCDR (Fnthcdr (make_number (3), watch_object),
+ XSETCDR (Fnthcdr (make_fixnum (3), watch_object),
Fcons (new_directory_files, Qnil));
return;
}
@@ -293,7 +293,7 @@ kqueue_callback (int fd, void *data)
}
/* Determine descriptor and file name. */
- descriptor = make_number (kev.ident);
+ descriptor = make_fixnum (kev.ident);
watch_object = assq_no_quit (descriptor, watch_list);
if (CONSP (watch_object))
file = XCAR (XCDR (watch_object));
@@ -306,7 +306,7 @@ kqueue_callback (int fd, void *data)
actions = Fcons (Qdelete, actions);
if (kev.fflags & NOTE_WRITE) {
/* Check, whether this is a directory event. */
- if (NILP (Fnth (make_number (4), watch_object)))
+ if (NILP (Fnth (make_fixnum (4), watch_object)))
actions = Fcons (Qwrite, actions);
else
kqueue_compare_dir_list (watch_object);
@@ -395,11 +395,12 @@ only when the upper directory of the renamed file is watched. */)
maxfd = 256;
/* We assume 50 file descriptors are sufficient for the rest of Emacs. */
- if ((maxfd - 50) < XINT (Flength (watch_list)))
+ ptrdiff_t watch_list_len = list_length (watch_list);
+ if (maxfd - 50 < watch_list_len)
xsignal2
(Qfile_notify_error,
build_string ("File watching not possible, no file descriptor left"),
- Flength (watch_list));
+ make_fixnum (watch_list_len));
if (kqueuefd < 0)
{
@@ -449,7 +450,7 @@ only when the upper directory of the renamed file is watched. */)
}
/* Store watch object in watch list. */
- Lisp_Object watch_descriptor = make_number (fd);
+ Lisp_Object watch_descriptor = make_fixnum (fd);
if (NILP (Ffile_directory_p (file)))
watch_object = list4 (watch_descriptor, file, flags, callback);
else {
@@ -473,8 +474,8 @@ WATCH-DESCRIPTOR should be an object returned by `kqueue-add-watch'. */)
xsignal2 (Qfile_notify_error, build_string ("Not a watch descriptor"),
watch_descriptor);
- eassert (INTEGERP (watch_descriptor));
- int fd = XINT (watch_descriptor);
+ eassert (FIXNUMP (watch_descriptor));
+ int fd = XFIXNUM (watch_descriptor);
if ( fd >= 0)
emacs_close (fd);
diff --git a/src/lastfile.c b/src/lastfile.c
index 5c7e5b8b26d..bcaf105a51b 100644
--- a/src/lastfile.c
+++ b/src/lastfile.c
@@ -43,15 +43,12 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
char my_edata[] = "End of Emacs initialized data";
#endif
-#ifndef CANNOT_DUMP
+#ifdef HAVE_UNEXEC
/* Help unexec locate the end of the .bss area used by Emacs (which
isn't always a separate section in NT executables). */
char my_endbss[1];
-/* The Alpha MSVC linker globally segregates all static and public bss
- data, so we must take both into account to determine the true extent
- of the bss area used by Emacs. */
static char _my_endbss[1];
char * my_endbss_static = _my_endbss;
diff --git a/src/lcms.c b/src/lcms.c
index 65cbf44e0f9..cd8de0e45a8 100644
--- a/src/lcms.c
+++ b/src/lcms.c
@@ -34,6 +34,7 @@ typedef struct
#ifdef WINDOWSNT
# include <windows.h>
+# include "w32common.h"
# include "w32.h"
DEF_DLL_FN (cmsFloat64Number, cmsCIE2000DeltaE,
@@ -251,10 +252,10 @@ parse_viewing_conditions (Lisp_Object view, const cmsCIEXYZ *wp,
else \
return false;
#define PARSE_VIEW_CONDITION_INT(field) \
- if (CONSP (view) && NATNUMP (XCAR (view))) \
+ if (CONSP (view) && FIXNATP (XCAR (view))) \
{ \
CHECK_RANGED_INTEGER (XCAR (view), 1, 4); \
- vc->field = XINT (XCAR (view)); \
+ vc->field = XFIXNUM (XCAR (view)); \
view = XCDR (view); \
} \
else \
@@ -554,7 +555,7 @@ Valid range of TEMPERATURE is from 4000K to 25000K. */)
}
#endif
- CHECK_NUMBER_OR_FLOAT (temperature);
+ CHECK_NUMBER (temperature);
tempK = XFLOATINT (temperature);
if (!(cmsWhitePointFromTemp (&whitepoint, tempK)))
diff --git a/src/lisp.h b/src/lisp.h
index 08c6dbdf72b..681efc3b52b 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -228,28 +228,22 @@ extern bool suppress_checking EXTERNALLY_VISIBLE;
USE_LSB_TAG not only requires the least 3 bits of pointers returned by
malloc to be 0 but also needs to be able to impose a mult-of-8 alignment
- on the few static Lisp_Objects used, all of which are aligned via
- 'char alignas (GCALIGNMENT) gcaligned;' inside a union. */
+ on some non-GC Lisp_Objects, all of which are aligned via
+ GCALIGNED_UNION_MEMBER. */
enum Lisp_Bits
{
- /* 2**GCTYPEBITS. This must be a macro that expands to a literal
- integer constant, for older versions of GCC (through at least 4.9). */
-#define GCALIGNMENT 8
-
/* Number of bits in a Lisp_Object value, not counting the tag. */
VALBITS = EMACS_INT_WIDTH - GCTYPEBITS,
- /* Number of bits in a Lisp fixnum tag. */
- INTTYPEBITS = GCTYPEBITS - 1,
-
/* Number of bits in a Lisp fixnum value, not counting the tag. */
FIXNUM_BITS = VALBITS + 1
};
-#if GCALIGNMENT != 1 << GCTYPEBITS
-# error "GCALIGNMENT and GCTYPEBITS are inconsistent"
-#endif
+/* Number of bits in a Lisp fixnum tag; can be used in #if. */
+DEFINE_GDB_SYMBOL_BEGIN (int, INTTYPEBITS)
+#define INTTYPEBITS (GCTYPEBITS - 1)
+DEFINE_GDB_SYMBOL_END (INTTYPEBITS)
/* The maximum value that can be stored in a EMACS_INT, assuming all
bits other than the type bits contribute to a nonnegative signed value.
@@ -277,6 +271,58 @@ DEFINE_GDB_SYMBOL_END (VALMASK)
error !;
#endif
+/* Minimum alignment requirement for Lisp objects, imposed by the
+ internal representation of tagged pointers. It is 2**GCTYPEBITS if
+ USE_LSB_TAG, 1 otherwise. It must be a literal integer constant,
+ for older versions of GCC (through at least 4.9). */
+#if USE_LSB_TAG
+# define GCALIGNMENT 8
+# if GCALIGNMENT != 1 << GCTYPEBITS
+# error "GCALIGNMENT and GCTYPEBITS are inconsistent"
+# endif
+#else
+# define GCALIGNMENT 1
+#endif
+
+/* To cause a union to have alignment of at least GCALIGNMENT, put
+ GCALIGNED_UNION_MEMBER in its member list.
+
+ If a struct is always GC-aligned (either by the GC, or via
+ allocation in a containing union that has GCALIGNED_UNION_MEMBER)
+ and does not contain a GC-aligned struct or union, putting
+ GCALIGNED_STRUCT after its closing '}' can help the compiler
+ generate better code.
+
+ Although these macros are reasonably portable, they are not
+ guaranteed on non-GCC platforms, as C11 does not require support
+ for alignment to GCALIGNMENT and older compilers may ignore
+ alignment requests. For any type T where garbage collection
+ requires alignment, use verify (GCALIGNED (T)) to verify the
+ requirement on the current platform. Types need this check if
+ their objects can be allocated outside the garbage collector. For
+ example, struct Lisp_Symbol needs the check because of lispsym and
+ struct Lisp_Cons needs it because of STACK_CONS. */
+
+#define GCALIGNED_UNION_MEMBER char alignas (GCALIGNMENT) gcaligned;
+#if HAVE_STRUCT_ATTRIBUTE_ALIGNED
+# define GCALIGNED_STRUCT __attribute__ ((aligned (GCALIGNMENT)))
+#else
+# define GCALIGNED_STRUCT
+#endif
+#define GCALIGNED(type) (alignof (type) % GCALIGNMENT == 0)
+
+/* Lisp_Word is a scalar word suitable for holding a tagged pointer or
+ integer. Usually it is a pointer to a deliberately-incomplete type
+ 'union Lisp_X'. However, it is EMACS_INT when Lisp_Objects and
+ pointers differ in width. */
+
+#define LISP_WORDS_ARE_POINTERS (EMACS_INT_MAX == INTPTR_MAX)
+#if LISP_WORDS_ARE_POINTERS
+typedef union Lisp_X *Lisp_Word;
+#else
+typedef EMACS_INT Lisp_Word;
+#endif
+
/* Some operations are so commonly executed that they are implemented
as macros, not functions, because otherwise runtime performance would
suffer too much when compiling with GCC without optimization.
@@ -302,26 +348,48 @@ error !;
functions, once "gcc -Og" (new to GCC 4.8) works well enough for
Emacs developers. Maybe in the year 2020. See Bug#11935.
- Commentary for these macros can be found near their corresponding
- functions, below. */
-
-#if CHECK_LISP_OBJECT_TYPE
-# define lisp_h_XLI(o) ((o).i)
-# define lisp_h_XIL(i) ((Lisp_Object) { i })
+ For the macros that have corresponding functions (defined later),
+ see these functions for commentary. */
+
+/* Convert among the various Lisp-related types: I for EMACS_INT, L
+ for Lisp_Object, P for void *. */
+#if !CHECK_LISP_OBJECT_TYPE
+# if LISP_WORDS_ARE_POINTERS
+# define lisp_h_XLI(o) ((EMACS_INT) (o))
+# define lisp_h_XIL(i) ((Lisp_Object) (i))
+# define lisp_h_XLP(o) ((void *) (o))
+# define lisp_h_XPL(p) ((Lisp_Object) (p))
+# else
+# define lisp_h_XLI(o) (o)
+# define lisp_h_XIL(i) (i)
+# define lisp_h_XLP(o) ((void *) (uintptr_t) (o))
+# define lisp_h_XPL(p) ((Lisp_Object) (uintptr_t) (p))
+# endif
#else
-# define lisp_h_XLI(o) (o)
-# define lisp_h_XIL(i) (i)
+# if LISP_WORDS_ARE_POINTERS
+# define lisp_h_XLI(o) ((EMACS_INT) (o).i)
+# define lisp_h_XIL(i) ((Lisp_Object) {(Lisp_Word) (i)})
+# define lisp_h_XLP(o) ((void *) (o).i)
+# define lisp_h_XPL(p) lisp_h_XIL (p)
+# else
+# define lisp_h_XLI(o) ((o).i)
+# define lisp_h_XIL(i) ((Lisp_Object) {i})
+# define lisp_h_XLP(o) ((void *) (uintptr_t) (o).i)
+# define lisp_h_XPL(p) ((Lisp_Object) {(uintptr_t) (p)})
+# endif
#endif
-#define lisp_h_CHECK_NUMBER(x) CHECK_TYPE (INTEGERP (x), Qintegerp, x)
+
+#define lisp_h_CHECK_FIXNUM(x) CHECK_TYPE (FIXNUMP (x), Qfixnump, x)
#define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x)
#define lisp_h_CHECK_TYPE(ok, predicate, x) \
((ok) ? (void) 0 : wrong_type_argument (predicate, x))
-#define lisp_h_CONSP(x) (XTYPE (x) == Lisp_Cons)
+#define lisp_h_CONSP(x) TAGGEDP (x, Lisp_Cons)
#define lisp_h_EQ(x, y) (XLI (x) == XLI (y))
-#define lisp_h_FLOATP(x) (XTYPE (x) == Lisp_Float)
-#define lisp_h_INTEGERP(x) ((XTYPE (x) & (Lisp_Int0 | ~Lisp_Int1)) == Lisp_Int0)
-#define lisp_h_MARKERP(x) (MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Marker)
-#define lisp_h_MISCP(x) (XTYPE (x) == Lisp_Misc)
+#define lisp_h_FIXNUMP(x) \
+ (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) \
+ - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) \
+ & ((1 << INTTYPEBITS) - 1)))
+#define lisp_h_FLOATP(x) TAGGEDP (x, Lisp_Float)
#define lisp_h_NILP(x) EQ (x, Qnil)
#define lisp_h_SET_SYMBOL_VAL(sym, v) \
(eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), \
@@ -331,29 +399,39 @@ error !;
#define lisp_h_SYMBOL_TRAPPED_WRITE_P(sym) (XSYMBOL (sym)->u.s.trapped_write)
#define lisp_h_SYMBOL_VAL(sym) \
(eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), (sym)->u.s.val.value)
-#define lisp_h_SYMBOLP(x) (XTYPE (x) == Lisp_Symbol)
-#define lisp_h_VECTORLIKEP(x) (XTYPE (x) == Lisp_Vectorlike)
+#define lisp_h_SYMBOLP(x) TAGGEDP (x, Lisp_Symbol)
+#define lisp_h_TAGGEDP(a, tag) \
+ (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \
+ - (unsigned) (tag)) \
+ & ((1 << GCTYPEBITS) - 1)))
+#define lisp_h_VECTORLIKEP(x) TAGGEDP (x, Lisp_Vectorlike)
#define lisp_h_XCAR(c) XCONS (c)->u.s.car
#define lisp_h_XCDR(c) XCONS (c)->u.s.u.cdr
#define lisp_h_XCONS(a) \
- (eassert (CONSP (a)), (struct Lisp_Cons *) XUNTAG (a, Lisp_Cons))
-#define lisp_h_XHASH(a) XUINT (a)
+ (eassert (CONSP (a)), XUNTAG (a, Lisp_Cons, struct Lisp_Cons))
+#define lisp_h_XHASH(a) XUFIXNUM (a)
#ifndef GC_CHECK_CONS_LIST
# define lisp_h_check_cons_list() ((void) 0)
#endif
#if USE_LSB_TAG
-# define lisp_h_make_number(n) \
+# define lisp_h_make_fixnum(n) \
XIL ((EMACS_INT) (((EMACS_UINT) (n) << INTTYPEBITS) + Lisp_Int0))
-# define lisp_h_XFASTINT(a) XINT (a)
-# define lisp_h_XINT(a) (XLI (a) >> INTTYPEBITS)
-# define lisp_h_XSYMBOL(a) \
+# define lisp_h_XFIXNAT(a) XFIXNUM (a)
+# define lisp_h_XFIXNUM(a) (XLI (a) >> INTTYPEBITS)
+# ifdef __CHKP__
+# define lisp_h_XSYMBOL(a) \
+ (eassert (SYMBOLP (a)), \
+ (struct Lisp_Symbol *) ((char *) XUNTAG (a, Lisp_Symbol, \
+ struct Lisp_Symbol) \
+ + (intptr_t) lispsym))
+# else
+ /* If !__CHKP__ this is equivalent, and is a bit faster as of GCC 7. */
+# define lisp_h_XSYMBOL(a) \
(eassert (SYMBOLP (a)), \
(struct Lisp_Symbol *) ((intptr_t) XLI (a) - Lisp_Symbol \
+ (char *) lispsym))
+# endif
# define lisp_h_XTYPE(a) ((enum Lisp_Type) (XLI (a) & ~VALMASK))
-# define lisp_h_XUNTAG(a, type) \
- __builtin_assume_aligned ((void *) (intptr_t) (XLI (a) - (type)), \
- GCALIGNMENT)
#endif
/* When compiling via gcc -O0, define the key operations as macros, as
@@ -370,21 +448,22 @@ error !;
#if DEFINE_KEY_OPS_AS_MACROS
# define XLI(o) lisp_h_XLI (o)
# define XIL(i) lisp_h_XIL (i)
-# define CHECK_NUMBER(x) lisp_h_CHECK_NUMBER (x)
+# define XLP(o) lisp_h_XLP (o)
+# define XPL(p) lisp_h_XPL (p)
+# define CHECK_FIXNUM(x) lisp_h_CHECK_FIXNUM (x)
# define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x)
# define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x)
# define CONSP(x) lisp_h_CONSP (x)
# define EQ(x, y) lisp_h_EQ (x, y)
# define FLOATP(x) lisp_h_FLOATP (x)
-# define INTEGERP(x) lisp_h_INTEGERP (x)
-# define MARKERP(x) lisp_h_MARKERP (x)
-# define MISCP(x) lisp_h_MISCP (x)
+# define FIXNUMP(x) lisp_h_FIXNUMP (x)
# define NILP(x) lisp_h_NILP (x)
# define SET_SYMBOL_VAL(sym, v) lisp_h_SET_SYMBOL_VAL (sym, v)
# define SYMBOL_CONSTANT_P(sym) lisp_h_SYMBOL_CONSTANT_P (sym)
# define SYMBOL_TRAPPED_WRITE_P(sym) lisp_h_SYMBOL_TRAPPED_WRITE_P (sym)
# define SYMBOL_VAL(sym) lisp_h_SYMBOL_VAL (sym)
# define SYMBOLP(x) lisp_h_SYMBOLP (x)
+# define TAGGEDP(a, tag) lisp_h_TAGGEDP (a, tag)
# define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x)
# define XCAR(c) lisp_h_XCAR (c)
# define XCDR(c) lisp_h_XCDR (c)
@@ -394,12 +473,11 @@ error !;
# define check_cons_list() lisp_h_check_cons_list ()
# endif
# if USE_LSB_TAG
-# define make_number(n) lisp_h_make_number (n)
-# define XFASTINT(a) lisp_h_XFASTINT (a)
-# define XINT(a) lisp_h_XINT (a)
+# define make_fixnum(n) lisp_h_make_fixnum (n)
+# define XFIXNAT(a) lisp_h_XFIXNAT (a)
+# define XFIXNUM(a) lisp_h_XFIXNUM (a)
# define XSYMBOL(a) lisp_h_XSYMBOL (a)
# define XTYPE(a) lisp_h_XTYPE (a)
-# define XUNTAG(a, type) lisp_h_XUNTAG (a, type)
# endif
#endif
@@ -416,9 +494,8 @@ error !;
#define case_Lisp_Int case Lisp_Int0: case Lisp_Int1
/* Idea stolen from GDB. Pedantic GCC complains about enum bitfields,
- MSVC doesn't support them, and xlc and Oracle Studio c99 complain
- vociferously about them. */
-#if (defined __STRICT_ANSI__ || defined _MSC_VER || defined __IBMC__ \
+ and xlc and Oracle Studio c99 complain vociferously about them. */
+#if (defined __STRICT_ANSI__ || defined __IBMC__ \
|| (defined __SUNPRO_C && __STDC__))
#define ENUM_BF(TYPE) unsigned int
#else
@@ -431,11 +508,9 @@ enum Lisp_Type
/* Symbol. XSYMBOL (object) points to a struct Lisp_Symbol. */
Lisp_Symbol = 0,
- /* Miscellaneous. XMISC (object) points to a union Lisp_Misc,
- whose first member indicates the subtype. */
- Lisp_Misc = 1,
+ /* Type 1 is currently unused. */
- /* Integer. XINT (obj) is the integer value. */
+ /* Fixnum. XFIXNUM (obj) is the integer value. */
Lisp_Int0 = 2,
Lisp_Int1 = USE_LSB_TAG ? 6 : 3,
@@ -452,28 +527,10 @@ enum Lisp_Type
/* Cons. XCONS (object) points to a struct Lisp_Cons. */
Lisp_Cons = USE_LSB_TAG ? 3 : 6,
+ /* Must be last entry in Lisp_Type enumeration. */
Lisp_Float = 7
};
-/* This is the set of data types that share a common structure.
- The first member of the structure is a type code from this set.
- The enum values are arbitrary, but we'll use large numbers to make it
- more likely that we'll spot the error if a random word in memory is
- mistakenly interpreted as a Lisp_Misc. */
-enum Lisp_Misc_Type
- {
- Lisp_Misc_Free = 0x5eab,
- Lisp_Misc_Marker,
- Lisp_Misc_Overlay,
- Lisp_Misc_Save_Value,
- Lisp_Misc_Finalizer,
-#ifdef HAVE_MODULES
- Lisp_Misc_User_Ptr,
-#endif
- /* This is not a type code. It is for range checking. */
- Lisp_Misc_Limit
- };
-
/* These are the types of forwarding objects used in the value slot
of symbols for special built-in variables whose value is stored in
C variables. */
@@ -487,16 +544,15 @@ enum Lisp_Fwd_Type
};
/* If you want to define a new Lisp data type, here are some
- instructions. See the thread at
- https://lists.gnu.org/r/emacs-devel/2012-10/msg00561.html
- for more info.
+ instructions.
First, there are already a couple of Lisp types that can be used if
your new type does not need to be exposed to Lisp programs nor
- displayed to users. These are Lisp_Save_Value, a Lisp_Misc
- subtype; and PVEC_OTHER, a kind of vectorlike object. The former
- is suitable for temporarily stashing away pointers and integers in
- a Lisp object. The latter is useful for vector-like Lisp objects
+ displayed to users. These are Lisp_Misc_Ptr and PVEC_OTHER,
+ which are both vectorlike objects. The former
+ is suitable for stashing a pointer in a Lisp object; the pointer
+ might be to some low-level C object that contains auxiliary
+ information. The latter is useful for vector-like Lisp objects
that need to be used as part of other objects, but which are never
shown to users or Lisp code (search for PVEC_OTHER in xterm.c for
an example).
@@ -504,30 +560,13 @@ enum Lisp_Fwd_Type
These two types don't look pretty when printed, so they are
unsuitable for Lisp objects that can be exposed to users.
- To define a new data type, add one more Lisp_Misc subtype or one
- more pseudovector subtype. Pseudovectors are more suitable for
- objects with several slots that need to support fast random access,
- while Lisp_Misc types are for everything else. A pseudovector object
- provides one or more slots for Lisp objects, followed by struct
- members that are accessible only from C. A Lisp_Misc object is a
- wrapper for a C struct that can contain anything you like.
-
- Explicit freeing is discouraged for Lisp objects in general. But if
- you really need to exploit this, use Lisp_Misc (check free_misc in
- alloc.c to see why). There is no way to free a vectorlike object.
-
- To add a new pseudovector type, extend the pvec_type enumeration;
- to add a new Lisp_Misc, extend the Lisp_Misc_Type enumeration.
-
- For a Lisp_Misc, you will also need to add your entry to union
- Lisp_Misc, but make sure the first word has the same structure as
- the others, starting with a 16-bit member of the Lisp_Misc_Type
- enumeration and a 1-bit GC markbit. Also make sure the overall
- size of the union is not increased by your addition. The latter
- requirement is to keep Lisp_Misc objects small enough, so they
- are handled faster: since all Lisp_Misc types use the same space,
- enlarging any of them will affect all the rest. If you really
- need a larger object, it is best to use Lisp_Vectorlike instead.
+ To define a new data type, add a pseudovector subtype by extending
+ the pvec_type enumeration. A pseudovector provides one or more
+ slots for Lisp objects, followed by struct members that are
+ accessible only from C.
+
+ There is no way to explicitly free a Lisp Object; only the garbage
+ collector frees them.
For a new pseudovector, it's highly desirable to limit the size
of your data type by VBLOCK_BYTES_MAX bytes (defined in alloc.c).
@@ -542,24 +581,29 @@ enum Lisp_Fwd_Type
resources allocated for it that are not Lisp objects. You can even
make a pointer to the function that frees the resources a slot in
your object -- this way, the same object could be used to represent
- several disparate C structures. */
+ several disparate C structures.
-#ifdef CHECK_LISP_OBJECT_TYPE
-
-typedef struct Lisp_Object { EMACS_INT i; } Lisp_Object;
+ You also need to add the new type to the constant
+ `cl--typeof-types' in lisp/emacs-lisp/cl-preloaded.el. */
-#define LISP_INITIALLY(i) {i}
-#undef CHECK_LISP_OBJECT_TYPE
-enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = true };
-#else /* CHECK_LISP_OBJECT_TYPE */
+/* A Lisp_Object is a tagged pointer or integer. Ordinarily it is a
+ Lisp_Word. However, if CHECK_LISP_OBJECT_TYPE, it is a wrapper
+ around Lisp_Word, to help catch thinkos like 'Lisp_Object x = 0;'.
-/* If a struct type is not wanted, define Lisp_Object as just a number. */
+ LISP_INITIALLY (W) initializes a Lisp object with a tagged value
+ that is a Lisp_Word W. It can be used in a static initializer. */
-typedef EMACS_INT Lisp_Object;
-#define LISP_INITIALLY(i) (i)
+#ifdef CHECK_LISP_OBJECT_TYPE
+typedef struct Lisp_Object { Lisp_Word i; } Lisp_Object;
+# define LISP_INITIALLY(w) {w}
+# undef CHECK_LISP_OBJECT_TYPE
+enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = true };
+#else
+typedef Lisp_Word Lisp_Object;
+# define LISP_INITIALLY(w) (w)
enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = false };
-#endif /* CHECK_LISP_OBJECT_TYPE */
+#endif
/* Forward declarations. */
@@ -567,6 +611,11 @@ enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = false };
INLINE void set_sub_char_table_contents (Lisp_Object, ptrdiff_t,
Lisp_Object);
+/* Defined in bignum.c. */
+extern double bignum_to_double (Lisp_Object);
+extern Lisp_Object make_bigint (intmax_t);
+extern Lisp_Object make_biguint (uintmax_t);
+
/* Defined in chartab.c. */
extern Lisp_Object char_table_ref (Lisp_Object, int);
extern void char_table_set (Lisp_Object, int, Lisp_Object);
@@ -575,24 +624,121 @@ extern void char_table_set (Lisp_Object, int, Lisp_Object);
extern _Noreturn void wrong_type_argument (Lisp_Object, Lisp_Object);
-#ifdef CANNOT_DUMP
-enum { might_dump = false };
-#elif defined DOUG_LEA_MALLOC
/* Defined in emacs.c. */
-extern bool might_dump;
-#endif
-/* True means Emacs has already been initialized.
- Used during startup to detect startup of dumped Emacs. */
+
+/* Set after Emacs has started up the first time.
+ Prevents reinitialization of the Lisp world and keymaps on
+ subsequent starts. */
extern bool initialized;
+extern struct gflags
+{
+ /* True means this Emacs instance was born to dump. */
+#if defined HAVE_PDUMPER || defined HAVE_UNEXEC
+ bool will_dump_ : 1;
+ bool will_bootstrap_ : 1;
+#endif
+#ifdef HAVE_PDUMPER
+ /* Set in an Emacs process that will likely dump with pdumper; all
+ Emacs processes may dump with pdumper, however. */
+ bool will_dump_with_pdumper_ : 1;
+ /* Set in an Emacs process that has been restored from a portable
+ dump. */
+ bool dumped_with_pdumper_ : 1;
+#endif
+#ifdef HAVE_UNEXEC
+ bool will_dump_with_unexec_ : 1;
+ /* Set in an Emacs process that has been restored from an unexec
+ dump. */
+ bool dumped_with_unexec_ : 1;
+ /* We promise not to unexec: useful for hybrid malloc. */
+ bool will_not_unexec_ : 1;
+#endif
+} gflags;
+
+INLINE bool
+will_dump_p (void)
+{
+#if HAVE_PDUMPER || defined HAVE_UNEXEC
+ return gflags.will_dump_;
+#else
+ return false;
+#endif
+}
+
+INLINE bool
+will_bootstrap_p (void)
+{
+#if HAVE_PDUMPER || defined HAVE_UNEXEC
+ return gflags.will_bootstrap_;
+#else
+ return false;
+#endif
+}
+
+INLINE bool
+will_dump_with_pdumper_p (void)
+{
+#if HAVE_PDUMPER
+ return gflags.will_dump_with_pdumper_;
+#else
+ return false;
+#endif
+}
+
+INLINE bool
+dumped_with_pdumper_p (void)
+{
+#if HAVE_PDUMPER
+ return gflags.dumped_with_pdumper_;
+#else
+ return false;
+#endif
+}
+
+INLINE bool
+will_dump_with_unexec_p (void)
+{
+#ifdef HAVE_UNEXEC
+ return gflags.will_dump_with_unexec_;
+#else
+ return false;
+#endif
+}
+
+INLINE bool
+dumped_with_unexec_p (void)
+{
+#ifdef HAVE_UNEXEC
+ return gflags.dumped_with_unexec_;
+#else
+ return false;
+#endif
+}
+
+/* This function is the opposite of will_dump_with_unexec_p(), except
+ that it returns false before main runs. It's important to use
+ gmalloc for any pre-main allocations if we're going to unexec. */
+INLINE bool
+definitely_will_not_unexec_p (void)
+{
+#ifdef HAVE_UNEXEC
+ return gflags.will_not_unexec_;
+#else
+ return true;
+#endif
+}
+
/* Defined in floatfns.c. */
extern double extract_float (Lisp_Object);
/* Low-level conversion and type checking. */
-/* Convert a Lisp_Object to the corresponding EMACS_INT and vice versa.
- At the machine level, these operations are no-ops. */
+/* Convert among various types use to implement Lisp_Object. At the
+ machine level, these operations may widen or narrow their arguments
+ if pointers differ in width from EMACS_INT; otherwise they are
+ no-ops. */
INLINE EMACS_INT
(XLI) (Lisp_Object o)
@@ -606,6 +752,18 @@ INLINE Lisp_Object
return lisp_h_XIL (i);
}
+INLINE void *
+(XLP) (Lisp_Object o)
+{
+ return lisp_h_XLP (o);
+}
+
+INLINE Lisp_Object
+(XPL) (void *p)
+{
+ return lisp_h_XPL (p);
+}
+
/* Extract A's type. */
INLINE enum Lisp_Type
@@ -619,25 +777,33 @@ INLINE enum Lisp_Type
#endif
}
+/* True if A has type tag TAG.
+ Equivalent to XTYPE (a) == TAG, but often faster. */
+
+INLINE bool
+(TAGGEDP) (Lisp_Object a, enum Lisp_Type tag)
+{
+ return lisp_h_TAGGEDP (a, tag);
+}
+
INLINE void
(CHECK_TYPE) (int ok, Lisp_Object predicate, Lisp_Object x)
{
lisp_h_CHECK_TYPE (ok, predicate, x);
}
-/* Extract A's pointer value, assuming A's type is TYPE. */
+/* Extract A's pointer value, assuming A's Lisp type is TYPE and the
+ extracted pointer's type is CTYPE *. */
-INLINE void *
-(XUNTAG) (Lisp_Object a, int type)
-{
-#if USE_LSB_TAG
- return lisp_h_XUNTAG (a, type);
-#else
- intptr_t i = USE_LSB_TAG ? XLI (a) - type : XLI (a) & VALMASK;
- return (void *) i;
-#endif
-}
+#define XUNTAG(a, type, ctype) ((ctype *) \
+ ((char *) XLP (a) - LISP_WORD_TAG (type)))
+/* A forwarding pointer to a value. It uses a generic pointer to
+ avoid alignment bugs that could occur if it used a pointer to a
+ union of the possible values (struct Lisp_Objfwd, struct
+ Lisp_Intfwd, etc.). The pointer is packaged inside a struct to
+ help static checking. */
+typedef struct { void const *fwdptr; } lispfwd;
/* Interned state of a symbol. */
@@ -703,7 +869,7 @@ struct Lisp_Symbol
Lisp_Object value;
struct Lisp_Symbol *alias;
struct Lisp_Buffer_Local_Value *blv;
- union Lisp_Fwd *fwd;
+ lispfwd fwd;
} val;
/* Function value of the symbol or Qnil if not fboundp. */
@@ -715,10 +881,10 @@ struct Lisp_Symbol
/* Next symbol in obarray bucket, if the symbol is interned. */
struct Lisp_Symbol *next;
} s;
- char alignas (GCALIGNMENT) gcaligned;
+ GCALIGNED_UNION_MEMBER
} u;
};
-verify (alignof (struct Lisp_Symbol) % GCALIGNMENT == 0);
+verify (GCALIGNED (struct Lisp_Symbol));
/* Declare a Lisp-callable function. The MAXARGS parameter has the same
meaning as in the DEFUN macro, and is used to construct a prototype. */
@@ -745,35 +911,47 @@ verify (alignof (struct Lisp_Symbol) % GCALIGNMENT == 0);
#define DEFUN_ARGS_8 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \
Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object)
-/* Yield a signed integer that contains TAG along with PTR.
-
- Sign-extend pointers when USE_LSB_TAG (this simplifies emacs-module.c),
- and zero-extend otherwise (that’s a bit faster here).
- Sign extension matters only when EMACS_INT is wider than a pointer. */
-#define TAG_PTR(tag, ptr) \
- (USE_LSB_TAG \
- ? (intptr_t) (ptr) + (tag) \
- : (EMACS_INT) (((EMACS_UINT) (tag) << VALBITS) + (uintptr_t) (ptr)))
+/* untagged_ptr represents a pointer before tagging, and Lisp_Word_tag
+ contains a possibly-shifted tag to be added to an untagged_ptr to
+ convert it to a Lisp_Word. */
+#if LISP_WORDS_ARE_POINTERS
+/* untagged_ptr is a pointer so that the compiler knows that TAG_PTR
+ yields a pointer; this can help with gcc -fcheck-pointer-bounds.
+ It is char * so that adding a tag uses simple machine addition. */
+typedef char *untagged_ptr;
+typedef uintptr_t Lisp_Word_tag;
+#else
+/* untagged_ptr is an unsigned integer instead of a pointer, so that
+ it can be added to the possibly-wider Lisp_Word_tag type without
+ losing information. */
+typedef uintptr_t untagged_ptr;
+typedef EMACS_UINT Lisp_Word_tag;
+#endif
-/* Yield an integer that contains a symbol tag along with OFFSET.
- OFFSET should be the offset in bytes from 'lispsym' to the symbol. */
-#define TAG_SYMOFFSET(offset) TAG_PTR (Lisp_Symbol, offset)
+/* A integer value tagged with TAG, and otherwise all zero. */
+#define LISP_WORD_TAG(tag) \
+ ((Lisp_Word_tag) (tag) << (USE_LSB_TAG ? 0 : VALBITS))
-/* XLI_BUILTIN_LISPSYM (iQwhatever) is equivalent to
- XLI (builtin_lisp_symbol (Qwhatever)),
- except the former expands to an integer constant expression. */
-#define XLI_BUILTIN_LISPSYM(iname) TAG_SYMOFFSET ((iname) * sizeof *lispsym)
+/* An initializer for a Lisp_Object that contains TAG along with PTR. */
+#define TAG_PTR(tag, ptr) \
+ LISP_INITIALLY ((Lisp_Word) ((untagged_ptr) (ptr) + LISP_WORD_TAG (tag)))
/* LISPSYM_INITIALLY (Qfoo) is equivalent to Qfoo except it is
designed for use as an initializer, even for a constant initializer. */
-#define LISPSYM_INITIALLY(name) LISP_INITIALLY (XLI_BUILTIN_LISPSYM (i##name))
+#define LISPSYM_INITIALLY(name) \
+ TAG_PTR (Lisp_Symbol, (char *) (intptr_t) ((i##name) * sizeof *lispsym))
/* Declare extern constants for Lisp symbols. These can be helpful
when using a debugger like GDB, on older platforms where the debug
- format does not represent C macros. */
-#define DEFINE_LISP_SYMBOL(name) \
- DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \
- DEFINE_GDB_SYMBOL_END (LISPSYM_INITIALLY (name))
+ format does not represent C macros. However, they are unbounded
+ and would just be asking for trouble if checking pointer bounds. */
+#ifdef __CHKP__
+# define DEFINE_LISP_SYMBOL(name)
+#else
+# define DEFINE_LISP_SYMBOL(name) \
+ DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \
+ DEFINE_GDB_SYMBOL_END (LISPSYM_INITIALLY (name))
+#endif
/* The index of the C-defined Lisp symbol SYM.
This can be used in a static initializer. */
@@ -787,6 +965,19 @@ verify (alignof (struct Lisp_Symbol) % GCALIGNMENT == 0);
# define DEFINE_NON_NIL_Q_SYMBOL_MACROS true
#endif
+/* True if N is a power of 2. N should be positive. */
+
+#define POWER_OF_2(n) (((n) & ((n) - 1)) == 0)
+
+/* Return X rounded to the next multiple of Y. Y should be positive,
+ and Y - 1 + X should not overflow. Arguments should not have side
+ effects, as they are evaluated more than once. Tune for Y being a
+ power of 2. */
+
+#define ROUNDUP(x, y) (POWER_OF_2 (y) \
+ ? ((y) - 1 + (x)) & ~ ((y) - 1) \
+ : ((y) - 1 + (x)) - ((y) - 1 + (x)) % (y))
+
#include "globals.h"
/* Header of vector-like objects. This documents the layout constraints on
@@ -795,7 +986,9 @@ verify (alignof (struct Lisp_Symbol) % GCALIGNMENT == 0);
and PSEUDOVECTORP cast their pointers to union vectorlike_header *,
because when two such pointers potentially alias, a compiler won't
incorrectly reorder loads and stores to their size fields. See
- Bug#8546. */
+ Bug#8546. This union formerly contained more members, and there's
+ no compelling reason to change it to a struct merely because the
+ number of members has been reduced to one. */
union vectorlike_header
{
/* The main member contains various pieces of information:
@@ -818,9 +1011,7 @@ union vectorlike_header
Current layout limits the pseudovectors to 63 PVEC_xxx subtypes,
4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */
ptrdiff_t size;
- char alignas (GCALIGNMENT) gcaligned;
};
-verify (alignof (union vectorlike_header) % GCALIGNMENT == 0);
INLINE bool
(SYMBOLP) (Lisp_Object x)
@@ -828,15 +1019,20 @@ INLINE bool
return lisp_h_SYMBOLP (x);
}
-INLINE struct Lisp_Symbol *
+INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED
(XSYMBOL) (Lisp_Object a)
{
#if USE_LSB_TAG
return lisp_h_XSYMBOL (a);
#else
eassert (SYMBOLP (a));
- intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol);
+ intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol);
void *p = (char *) lispsym + i;
+# ifdef __CHKP__
+ /* Bypass pointer checking. Although this could be improved it is
+ probably not worth the trouble. */
+ p = __builtin___bnd_set_ptr_bounds (p, sizeof (struct Lisp_Symbol));
+# endif
return p;
#endif
}
@@ -844,7 +1040,20 @@ INLINE struct Lisp_Symbol *
INLINE Lisp_Object
make_lisp_symbol (struct Lisp_Symbol *sym)
{
- Lisp_Object a = XIL (TAG_SYMOFFSET ((char *) sym - (char *) lispsym));
+#ifdef __CHKP__
+ /* Although '__builtin___bnd_narrow_ptr_bounds (sym, sym, sizeof *sym)'
+ should be more efficient, it runs afoul of GCC bug 83251
+ <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=83251>.
+ Also, attempting to call __builtin___bnd_chk_ptr_bounds (sym, sizeof *sym)
+ here seems to trigger a GCC bug, as yet undiagnosed. */
+ char *addr = __builtin___bnd_set_ptr_bounds (sym, sizeof *sym);
+ char *symoffset = addr - (intptr_t) lispsym;
+#else
+ /* If !__CHKP__, GCC 7 x86-64 generates faster code if lispsym is
+ cast to char * rather than to intptr_t. */
+ char *symoffset = (char *) ((char *) sym - (char *) lispsym);
+#endif
+ Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset);
eassert (XSYMBOL (a) == sym);
return a;
}
@@ -880,6 +1089,14 @@ enum pvec_type
{
PVEC_NORMAL_VECTOR,
PVEC_FREE,
+ PVEC_BIGNUM,
+ PVEC_MARKER,
+ PVEC_OVERLAY,
+ PVEC_FINALIZER,
+ PVEC_MISC_PTR,
+#ifdef HAVE_MODULES
+ PVEC_USER_PTR,
+#endif
PVEC_PROCESS,
PVEC_FRAME,
PVEC_WINDOW,
@@ -932,28 +1149,28 @@ enum More_Lisp_Bits
that cons. */
/* Largest and smallest representable fixnum values. These are the C
- values. They are macros for use in static initializers. */
+ values. They are macros for use in #if and static initializers. */
#define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS)
#define MOST_NEGATIVE_FIXNUM (-1 - MOST_POSITIVE_FIXNUM)
#if USE_LSB_TAG
INLINE Lisp_Object
-(make_number) (EMACS_INT n)
+(make_fixnum) (EMACS_INT n)
{
- return lisp_h_make_number (n);
+ return lisp_h_make_fixnum (n);
}
INLINE EMACS_INT
-(XINT) (Lisp_Object a)
+(XFIXNUM) (Lisp_Object a)
{
- return lisp_h_XINT (a);
+ return lisp_h_XFIXNUM (a);
}
INLINE EMACS_INT
-(XFASTINT) (Lisp_Object a)
+(XFIXNAT) (Lisp_Object a)
{
- EMACS_INT n = lisp_h_XFASTINT (a);
+ EMACS_INT n = lisp_h_XFIXNAT (a);
eassume (0 <= n);
return n;
}
@@ -967,7 +1184,7 @@ INLINE EMACS_INT
/* Make a Lisp integer representing the value of the low order
bits of N. */
INLINE Lisp_Object
-make_number (EMACS_INT n)
+make_fixnum (EMACS_INT n)
{
EMACS_INT int0 = Lisp_Int0;
if (USE_LSB_TAG)
@@ -986,7 +1203,7 @@ make_number (EMACS_INT n)
/* Extract A's value as a signed integer. */
INLINE EMACS_INT
-XINT (Lisp_Object a)
+XFIXNUM (Lisp_Object a)
{
EMACS_INT i = XLI (a);
if (! USE_LSB_TAG)
@@ -997,14 +1214,14 @@ XINT (Lisp_Object a)
return i >> INTTYPEBITS;
}
-/* Like XINT (A), but may be faster. A must be nonnegative.
+/* Like XFIXNUM (A), but may be faster. A must be nonnegative.
If ! USE_LSB_TAG, this takes advantage of the fact that Lisp
integers have zero-bits in their tags. */
INLINE EMACS_INT
-XFASTINT (Lisp_Object a)
+XFIXNAT (Lisp_Object a)
{
EMACS_INT int0 = Lisp_Int0;
- EMACS_INT n = USE_LSB_TAG ? XINT (a) : XLI (a) - (int0 << VALBITS);
+ EMACS_INT n = USE_LSB_TAG ? XFIXNUM (a) : XLI (a) - (int0 << VALBITS);
eassume (0 <= n);
return n;
}
@@ -1013,14 +1230,14 @@ XFASTINT (Lisp_Object a)
/* Extract A's value as an unsigned integer. */
INLINE EMACS_UINT
-XUINT (Lisp_Object a)
+XUFIXNUM (Lisp_Object a)
{
EMACS_UINT i = XLI (a);
return USE_LSB_TAG ? i >> INTTYPEBITS : i & INTMASK;
}
-/* Return A's (Lisp-integer sized) hash. Happens to be like XUINT
- right now, but XUINT should only be applied to objects we know are
+/* Return A's (Lisp-integer sized) hash. Happens to be like XUFIXNUM
+ right now, but XUFIXNUM should only be applied to objects we know are
integers. */
INLINE EMACS_INT
@@ -1029,13 +1246,13 @@ INLINE EMACS_INT
return lisp_h_XHASH (a);
}
-/* Like make_number (N), but may be faster. N must be in nonnegative range. */
+/* Like make_fixnum (N), but may be faster. N must be in nonnegative range. */
INLINE Lisp_Object
-make_natnum (EMACS_INT n)
+make_fixed_natnum (EMACS_INT n)
{
eassert (0 <= n && n <= MOST_POSITIVE_FIXNUM);
EMACS_INT int0 = Lisp_Int0;
- return USE_LSB_TAG ? make_number (n) : XIL (n + (int0 << VALBITS));
+ return USE_LSB_TAG ? make_fixnum (n) : XIL (n + (int0 << VALBITS));
}
/* Return true if X and Y are the same object. */
@@ -1051,8 +1268,8 @@ INLINE bool
#define FIXNUM_OVERFLOW_P(i) \
(! ((0 <= (i) || MOST_NEGATIVE_FIXNUM <= (i)) && (i) <= MOST_POSITIVE_FIXNUM))
-INLINE ptrdiff_t
-clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper)
+INLINE intmax_t
+clip_to_bounds (intmax_t lower, intmax_t num, intmax_t upper)
{
return num < lower ? lower : num <= upper ? num : upper;
}
@@ -1062,25 +1279,24 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper)
INLINE Lisp_Object
make_lisp_ptr (void *ptr, enum Lisp_Type type)
{
- Lisp_Object a = XIL (TAG_PTR (type, ptr));
- eassert (XTYPE (a) == type && XUNTAG (a, type) == ptr);
+ Lisp_Object a = TAG_PTR (type, ptr);
+ eassert (TAGGEDP (a, type) && XUNTAG (a, type, char) == ptr);
return a;
}
INLINE bool
-(INTEGERP) (Lisp_Object x)
+(FIXNUMP) (Lisp_Object x)
{
- return lisp_h_INTEGERP (x);
+ return lisp_h_FIXNUMP (x);
}
-#define XSETINT(a, b) ((a) = make_number (b))
-#define XSETFASTINT(a, b) ((a) = make_natnum (b))
+#define XSETINT(a, b) ((a) = make_fixnum (b))
+#define XSETFASTINT(a, b) ((a) = make_fixed_natnum (b))
#define XSETCONS(a, b) ((a) = make_lisp_ptr (b, Lisp_Cons))
#define XSETVECTOR(a, b) ((a) = make_lisp_ptr (b, Lisp_Vectorlike))
#define XSETSTRING(a, b) ((a) = make_lisp_ptr (b, Lisp_String))
#define XSETSYMBOL(a, b) ((a) = make_lisp_symbol (b))
#define XSETFLOAT(a, b) ((a) = make_lisp_ptr (b, Lisp_Float))
-#define XSETMISC(a, b) ((a) = make_lisp_ptr (b, Lisp_Misc))
/* Pseudovector types. */
@@ -1095,8 +1311,8 @@ INLINE bool
/* The cast to union vectorlike_header * avoids aliasing issues. */
#define XSETPSEUDOVECTOR(a, b, code) \
XSETTYPED_PSEUDOVECTOR (a, b, \
- (((union vectorlike_header *) \
- XUNTAG (a, Lisp_Vectorlike)) \
+ (XUNTAG (a, Lisp_Vectorlike, \
+ union vectorlike_header) \
->size), \
code)
#define XSETTYPED_PSEUDOVECTOR(a, b, size, code) \
@@ -1125,16 +1341,23 @@ INLINE bool
bits set, which makes this conversion inherently unportable. */
INLINE void *
-XINTPTR (Lisp_Object a)
+XFIXNUMPTR (Lisp_Object a)
{
- return XUNTAG (a, Lisp_Int0);
+ return XUNTAG (a, Lisp_Int0, char);
+}
+
+INLINE Lisp_Object
+make_pointer_integer_unsafe (void *p)
+{
+ Lisp_Object a = TAG_PTR (Lisp_Int0, p);
+ return a;
}
INLINE Lisp_Object
make_pointer_integer (void *p)
{
- Lisp_Object a = XIL (TAG_PTR (Lisp_Int0, p));
- eassert (INTEGERP (a) && XINTPTR (a) == p);
+ Lisp_Object a = make_pointer_integer_unsafe (p);
+ eassert (FIXNUMP (a) && XFIXNUMPTR (a) == p);
return a;
}
@@ -1160,10 +1383,10 @@ struct Lisp_Cons
struct Lisp_Cons *chain;
} u;
} s;
- char alignas (GCALIGNMENT) gcaligned;
+ GCALIGNED_UNION_MEMBER
} u;
};
-verify (alignof (struct Lisp_Cons) % GCALIGNMENT == 0);
+verify (GCALIGNED (struct Lisp_Cons));
INLINE bool
(NILP) (Lisp_Object x)
@@ -1282,15 +1505,15 @@ struct Lisp_String
unsigned char *data;
} s;
struct Lisp_String *next;
- char alignas (GCALIGNMENT) gcaligned;
+ GCALIGNED_UNION_MEMBER
} u;
};
-verify (alignof (struct Lisp_String) % GCALIGNMENT == 0);
+verify (GCALIGNED (struct Lisp_String));
INLINE bool
STRINGP (Lisp_Object x)
{
- return XTYPE (x) == Lisp_String;
+ return TAGGEDP (x, Lisp_String);
}
INLINE void
@@ -1303,7 +1526,7 @@ INLINE struct Lisp_String *
XSTRING (Lisp_Object a)
{
eassert (STRINGP (a));
- return XUNTAG (a, Lisp_String);
+ return XUNTAG (a, Lisp_String, struct Lisp_String);
}
/* True if STR is a multibyte string. */
@@ -1314,11 +1537,11 @@ STRING_MULTIBYTE (Lisp_Object str)
}
/* An upper bound on the number of bytes in a Lisp string, not
- counting the terminating null. This a tight enough bound to
+ counting the terminating NUL. This a tight enough bound to
prevent integer overflow errors that would otherwise occur during
string size calculations. A string cannot contain more bytes than
a fixnum can represent, nor can it be so long that C pointer
- arithmetic stops working on the string plus its terminating null.
+ arithmetic stops working on the string plus its terminating NUL.
Although the actual size limit (see STRING_BYTES_MAX in alloc.c)
may be a bit smaller than STRING_BYTES_BOUND, calculating it here
would expose alloc.c internal details that we'd rather keep
@@ -1416,7 +1639,7 @@ struct Lisp_Vector
{
union vectorlike_header header;
Lisp_Object contents[FLEXIBLE_ARRAY_MEMBER];
- };
+ } GCALIGNED_STRUCT;
INLINE bool
(VECTORLIKEP) (Lisp_Object x)
@@ -1428,7 +1651,7 @@ INLINE struct Lisp_Vector *
XVECTOR (Lisp_Object a)
{
eassert (VECTORLIKEP (a));
- return XUNTAG (a, Lisp_Vectorlike);
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Vector);
}
INLINE ptrdiff_t
@@ -1461,7 +1684,7 @@ CHECK_VECTOR (Lisp_Object x)
/* A pseudovector is like a vector, but has other non-Lisp components. */
INLINE enum pvec_type
-PSEUDOVECTOR_TYPE (struct Lisp_Vector *v)
+PSEUDOVECTOR_TYPE (const struct Lisp_Vector *v)
{
ptrdiff_t size = v->header.size;
return (size & PSEUDOVECTOR_FLAG
@@ -1471,7 +1694,7 @@ PSEUDOVECTOR_TYPE (struct Lisp_Vector *v)
/* Can't be used with PVEC_NORMAL_VECTOR. */
INLINE bool
-PSEUDOVECTOR_TYPEP (union vectorlike_header *a, enum pvec_type code)
+PSEUDOVECTOR_TYPEP (const union vectorlike_header *a, enum pvec_type code)
{
/* We don't use PSEUDOVECTOR_TYPE here so as to avoid a shift
* operation when `code' is known. */
@@ -1488,8 +1711,9 @@ PSEUDOVECTORP (Lisp_Object a, int code)
else
{
/* Converting to union vectorlike_header * avoids aliasing issues. */
- union vectorlike_header *h = XUNTAG (a, Lisp_Vectorlike);
- return PSEUDOVECTOR_TYPEP (h, code);
+ return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike,
+ union vectorlike_header),
+ code);
}
}
@@ -1507,10 +1731,19 @@ struct Lisp_Bool_Vector
The bits are in little-endian order in the bytes, and
the bytes are in little-endian order in the words. */
bits_word data[FLEXIBLE_ARRAY_MEMBER];
- };
+ } GCALIGNED_STRUCT;
/* Some handy constants for calculating sizes
- and offsets, mostly of vectorlike objects. */
+ and offsets, mostly of vectorlike objects.
+
+ The garbage collector assumes that the initial part of any struct
+ that starts with a union vectorlike_header followed by N
+ Lisp_Objects (some possibly in arrays and/or a trailing flexible
+ array) will be laid out like a struct Lisp_Vector with N
+ Lisp_Objects. This assumption is true in practice on known Emacs
+ targets even though the C standard does not guarantee it. This
+ header contains a few sanity checks that should suffice to detect
+ violations of this assumption on plausible practical hosts. */
enum
{
@@ -1551,7 +1784,7 @@ INLINE struct Lisp_Bool_Vector *
XBOOL_VECTOR (Lisp_Object a)
{
eassert (BOOL_VECTOR_P (a));
- return XUNTAG (a, Lisp_Vectorlike);
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Bool_Vector);
}
INLINE EMACS_INT
@@ -1645,8 +1878,10 @@ gc_aset (Lisp_Object array, ptrdiff_t idx, Lisp_Object val)
/* True, since Qnil's representation is zero. Every place in the code
that assumes Qnil is zero should verify (NIL_IS_ZERO), to make it easy
- to find such assumptions later if we change Qnil to be nonzero. */
-enum { NIL_IS_ZERO = XLI_BUILTIN_LISPSYM (iQnil) == 0 };
+ to find such assumptions later if we change Qnil to be nonzero.
+ Test iQnil and Lisp_Symbol instead of Qnil directly, since the latter
+ is not suitable for use in an integer constant expression. */
+enum { NIL_IS_ZERO = iQnil == 0 && Lisp_Symbol == 0 };
/* Clear the object addressed by P, with size NBYTES, so that all its
bytes are zero and all its Lisp values are nil. */
@@ -1669,8 +1904,9 @@ memclear (void *p, ptrdiff_t nbytes)
at the end and we need to compute the number of Lisp_Object fields (the
ones that the GC needs to trace). */
-#define PSEUDOVECSIZE(type, nonlispfield) \
- ((offsetof (type, nonlispfield) - header_size) / word_size)
+#define PSEUDOVECSIZE(type, lastlispfield) \
+ (offsetof (type, lastlispfield) + word_size < header_size \
+ ? 0 : (offsetof (type, lastlispfield) + word_size - header_size) / word_size)
/* Compute A OP B, using the unsigned comparison operator OP. A and B
should be integer expressions. This is not the same as
@@ -1735,7 +1971,7 @@ struct Lisp_Char_Table
/* These hold additional data. It is a vector. */
Lisp_Object extras[FLEXIBLE_ARRAY_MEMBER];
- };
+ } GCALIGNED_STRUCT;
INLINE bool
CHAR_TABLE_P (Lisp_Object a)
@@ -1747,7 +1983,7 @@ INLINE struct Lisp_Char_Table *
XCHAR_TABLE (Lisp_Object a)
{
eassert (CHAR_TABLE_P (a));
- return XUNTAG (a, Lisp_Vectorlike);
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Char_Table);
}
struct Lisp_Sub_Char_Table
@@ -1769,7 +2005,7 @@ struct Lisp_Sub_Char_Table
/* Use set_sub_char_table_contents to set this. */
Lisp_Object contents[FLEXIBLE_ARRAY_MEMBER];
- };
+ } GCALIGNED_STRUCT;
INLINE bool
SUB_CHAR_TABLE_P (Lisp_Object a)
@@ -1781,7 +2017,7 @@ INLINE struct Lisp_Sub_Char_Table *
XSUB_CHAR_TABLE (Lisp_Object a)
{
eassert (SUB_CHAR_TABLE_P (a));
- return XUNTAG (a, Lisp_Vectorlike);
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Sub_Char_Table);
}
INLINE Lisp_Object
@@ -1847,7 +2083,13 @@ struct Lisp_Subr
const char *symbol_name;
const char *intspec;
EMACS_INT doc;
+ } GCALIGNED_STRUCT;
+union Aligned_Lisp_Subr
+ {
+ struct Lisp_Subr s;
+ GCALIGNED_UNION_MEMBER
};
+verify (GCALIGNED (union Aligned_Lisp_Subr));
INLINE bool
SUBRP (Lisp_Object a)
@@ -1859,7 +2101,7 @@ INLINE struct Lisp_Subr *
XSUBR (Lisp_Object a)
{
eassert (SUBRP (a));
- return XUNTAG (a, Lisp_Vectorlike);
+ return &XUNTAG (a, Lisp_Vectorlike, union Aligned_Lisp_Subr)->s;
}
enum char_table_specials
@@ -1867,13 +2109,23 @@ enum char_table_specials
/* This is the number of slots that every char table must have. This
counts the ordinary slots and the top, defalt, parent, and purpose
slots. */
- CHAR_TABLE_STANDARD_SLOTS = PSEUDOVECSIZE (struct Lisp_Char_Table, extras),
+ CHAR_TABLE_STANDARD_SLOTS
+ = (PSEUDOVECSIZE (struct Lisp_Char_Table, contents) - 1
+ + (1 << CHARTAB_SIZE_BITS_0)),
- /* This is an index of first Lisp_Object field in Lisp_Sub_Char_Table
+ /* This is the index of the first Lisp_Object field in Lisp_Sub_Char_Table
when the latter is treated as an ordinary Lisp_Vector. */
- SUB_CHAR_TABLE_OFFSET = PSEUDOVECSIZE (struct Lisp_Sub_Char_Table, contents)
+ SUB_CHAR_TABLE_OFFSET
+ = PSEUDOVECSIZE (struct Lisp_Sub_Char_Table, contents) - 1
};
+/* Sanity-check pseudovector layout. */
+verify (offsetof (struct Lisp_Char_Table, defalt) == header_size);
+verify (offsetof (struct Lisp_Char_Table, extras)
+ == header_size + CHAR_TABLE_STANDARD_SLOTS * sizeof (Lisp_Object));
+verify (offsetof (struct Lisp_Sub_Char_Table, contents)
+ == header_size + SUB_CHAR_TABLE_OFFSET * sizeof (Lisp_Object));
+
/* Return the number of "extra" slots in the char table CT. */
INLINE int
@@ -1883,11 +2135,6 @@ CHAR_TABLE_EXTRA_SLOTS (struct Lisp_Char_Table *ct)
- CHAR_TABLE_STANDARD_SLOTS);
}
-/* Make sure that sub char-table contents slot is where we think it is. */
-verify (offsetof (struct Lisp_Sub_Char_Table, contents)
- == (offsetof (struct Lisp_Vector, contents)
- + SUB_CHAR_TABLE_OFFSET * sizeof (Lisp_Object)));
-
/* Save and restore the instruction and environment pointers,
without affecting the signal mask. */
@@ -1934,10 +2181,10 @@ SYMBOL_BLV (struct Lisp_Symbol *sym)
eassume (sym->u.s.redirect == SYMBOL_LOCALIZED && sym->u.s.val.blv);
return sym->u.s.val.blv;
}
-INLINE union Lisp_Fwd *
+INLINE lispfwd
SYMBOL_FWD (struct Lisp_Symbol *sym)
{
- eassume (sym->u.s.redirect == SYMBOL_FORWARDED && sym->u.s.val.fwd);
+ eassume (sym->u.s.redirect == SYMBOL_FORWARDED && sym->u.s.val.fwd.fwdptr);
return sym->u.s.val.fwd;
}
@@ -1960,10 +2207,10 @@ SET_SYMBOL_BLV (struct Lisp_Symbol *sym, struct Lisp_Buffer_Local_Value *v)
sym->u.s.val.blv = v;
}
INLINE void
-SET_SYMBOL_FWD (struct Lisp_Symbol *sym, union Lisp_Fwd *v)
+SET_SYMBOL_FWD (struct Lisp_Symbol *sym, void const *v)
{
eassume (sym->u.s.redirect == SYMBOL_FORWARDED && v);
- sym->u.s.val.fwd = v;
+ sym->u.s.val.fwd.fwdptr = v;
}
INLINE Lisp_Object
@@ -2040,6 +2287,12 @@ struct hash_table_test
struct Lisp_Hash_Table
{
+ /* Change pdumper.c if you change the fields here.
+
+ IMPORTANT!!!!!!!
+
+ Call hash_rehash_if_needed() before accessing. */
+
/* This is for Lisp; the hash table code does not refer to it. */
union vectorlike_header header;
@@ -2063,8 +2316,8 @@ struct Lisp_Hash_Table
hash table size to reduce collisions. */
Lisp_Object index;
- /* Only the fields above are traced normally by the GC. The ones below
- `count' are special and are either ignored by the GC or traced in
+ /* Only the fields above are traced normally by the GC. The ones after
+ 'index' are special and are either ignored by the GC or traced in
a special way (e.g. because of weakness). */
/* Number of key/value entries in the table. */
@@ -2096,11 +2349,14 @@ struct Lisp_Hash_Table
/* The comparison and hash functions. */
struct hash_table_test test;
- /* Next weak hash table if this is a weak hash table. The head
- of the list is in weak_hash_tables. */
+ /* Next weak hash table if this is a weak hash table. The head of
+ the list is in weak_hash_tables. Used only during garbage
+ collection --- at other times, it is NULL. */
struct Lisp_Hash_Table *next_weak;
-};
+} GCALIGNED_STRUCT;
+/* Sanity-check pseudovector layout. */
+verify (offsetof (struct Lisp_Hash_Table, weak) == header_size);
INLINE bool
HASH_TABLE_P (Lisp_Object a)
@@ -2112,7 +2368,7 @@ INLINE struct Lisp_Hash_Table *
XHASH_TABLE (Lisp_Object a)
{
eassert (HASH_TABLE_P (a));
- return XUNTAG (a, Lisp_Vectorlike);
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Hash_Table);
}
#define XSET_HASH_TABLE(VAR, PTR) \
@@ -2120,32 +2376,47 @@ XHASH_TABLE (Lisp_Object a)
/* Value is the key part of entry IDX in hash table H. */
INLINE Lisp_Object
-HASH_KEY (struct Lisp_Hash_Table *h, ptrdiff_t idx)
+HASH_KEY (const struct Lisp_Hash_Table *h, ptrdiff_t idx)
{
return AREF (h->key_and_value, 2 * idx);
}
/* Value is the value part of entry IDX in hash table H. */
INLINE Lisp_Object
-HASH_VALUE (struct Lisp_Hash_Table *h, ptrdiff_t idx)
+HASH_VALUE (const struct Lisp_Hash_Table *h, ptrdiff_t idx)
{
return AREF (h->key_and_value, 2 * idx + 1);
}
/* Value is the hash code computed for entry IDX in hash table H. */
INLINE Lisp_Object
-HASH_HASH (struct Lisp_Hash_Table *h, ptrdiff_t idx)
+HASH_HASH (const struct Lisp_Hash_Table *h, ptrdiff_t idx)
{
return AREF (h->hash, idx);
}
/* Value is the size of hash table H. */
INLINE ptrdiff_t
-HASH_TABLE_SIZE (struct Lisp_Hash_Table *h)
+HASH_TABLE_SIZE (const struct Lisp_Hash_Table *h)
{
return ASIZE (h->next);
}
+void hash_table_rehash (struct Lisp_Hash_Table *h);
+
+INLINE bool
+hash_rehash_needed_p (const struct Lisp_Hash_Table *h)
+{
+ return h->count < 0;
+}
+
+INLINE void
+hash_rehash_if_needed (struct Lisp_Hash_Table *h)
+{
+ if (hash_rehash_needed_p (h))
+ hash_table_rehash (h);
+}
+
/* Default size for hash tables if not specified. */
enum DEFAULT_HASH_SIZE { DEFAULT_HASH_SIZE = 65 };
@@ -2177,46 +2448,10 @@ SXHASH_REDUCE (EMACS_UINT x)
return (x ^ x >> (EMACS_INT_WIDTH - FIXNUM_BITS)) & INTMASK;
}
-/* These structures are used for various misc types. */
-
-struct Lisp_Misc_Any /* Supertype of all Misc types. */
-{
- ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_??? */
- bool_bf gcmarkbit : 1;
- unsigned spacer : 15;
-};
-
-INLINE bool
-(MISCP) (Lisp_Object x)
-{
- return lisp_h_MISCP (x);
-}
-
-INLINE struct Lisp_Misc_Any *
-XMISCANY (Lisp_Object a)
-{
- eassert (MISCP (a));
- return XUNTAG (a, Lisp_Misc);
-}
-
-INLINE enum Lisp_Misc_Type
-XMISCTYPE (Lisp_Object a)
-{
- return XMISCANY (a)->type;
-}
-
struct Lisp_Marker
{
- ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_Marker */
- bool_bf gcmarkbit : 1;
- unsigned spacer : 13;
- /* This flag is temporarily used in the functions
- decode/encode_coding_object to record that the marker position
- must be adjusted after the conversion. */
- bool_bf need_adjustment : 1;
- /* True means normal insertion at the marker's position
- leaves the marker after the inserted text. */
- bool_bf insertion_type : 1;
+ union vectorlike_header header;
+
/* This is the buffer that the marker points into, or 0 if it points nowhere.
Note: a chain of markers can contain markers pointing into different
buffers (the chain is per buffer_text rather than per buffer, so it's
@@ -2229,11 +2464,21 @@ struct Lisp_Marker
*/
struct buffer *buffer;
+ /* This flag is temporarily used in the functions
+ decode/encode_coding_object to record that the marker position
+ must be adjusted after the conversion. */
+ bool_bf need_adjustment : 1;
+ /* True means normal insertion at the marker's position
+ leaves the marker after the inserted text. */
+ bool_bf insertion_type : 1;
+
/* The remaining fields are meaningless in a marker that
does not point anywhere. */
/* For markers that point somewhere,
- this is used to chain of all the markers in a given buffer. */
+ this is used to chain of all the markers in a given buffer.
+ The chain does not preserve markers from garbage collection;
+ instead, markers are removed from the chain when freed by GC. */
/* We could remove it and use an array in buffer_text instead.
That would also allow us to preserve it ordered. */
struct Lisp_Marker *next;
@@ -2244,7 +2489,7 @@ struct Lisp_Marker
used to implement the functionality of markers, but rather to (ab)use
markers as a cache for char<->byte mappings). */
ptrdiff_t bytepos;
-};
+} GCALIGNED_STRUCT;
/* START and END are markers in the overlay's buffer, and
PLIST is the overlay's property list. */
@@ -2261,285 +2506,167 @@ struct Lisp_Overlay
I.e. 9words plus 2 bits, 3words of which are for external linked lists.
*/
{
- ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_Overlay */
- bool_bf gcmarkbit : 1;
- unsigned spacer : 15;
- struct Lisp_Overlay *next;
+ union vectorlike_header header;
Lisp_Object start;
Lisp_Object end;
Lisp_Object plist;
- };
-
-/* Number of bits needed to store one of the values
- SAVE_UNUSED..SAVE_OBJECT. */
-enum { SAVE_SLOT_BITS = 3 };
-
-/* Number of slots in a save value where save_type is nonzero. */
-enum { SAVE_VALUE_SLOTS = 4 };
-
-/* Bit-width and values for struct Lisp_Save_Value's save_type member. */
-
-enum { SAVE_TYPE_BITS = SAVE_VALUE_SLOTS * SAVE_SLOT_BITS + 1 };
-
-/* Types of data which may be saved in a Lisp_Save_Value. */
-
-enum Lisp_Save_Type
- {
- SAVE_UNUSED,
- SAVE_INTEGER,
- SAVE_FUNCPOINTER,
- SAVE_POINTER,
- SAVE_OBJECT,
- SAVE_TYPE_INT_INT = SAVE_INTEGER + (SAVE_INTEGER << SAVE_SLOT_BITS),
- SAVE_TYPE_INT_INT_INT
- = (SAVE_INTEGER + (SAVE_TYPE_INT_INT << SAVE_SLOT_BITS)),
- SAVE_TYPE_OBJ_OBJ = SAVE_OBJECT + (SAVE_OBJECT << SAVE_SLOT_BITS),
- SAVE_TYPE_OBJ_OBJ_OBJ = SAVE_OBJECT + (SAVE_TYPE_OBJ_OBJ << SAVE_SLOT_BITS),
- SAVE_TYPE_OBJ_OBJ_OBJ_OBJ
- = SAVE_OBJECT + (SAVE_TYPE_OBJ_OBJ_OBJ << SAVE_SLOT_BITS),
- SAVE_TYPE_PTR_INT = SAVE_POINTER + (SAVE_INTEGER << SAVE_SLOT_BITS),
- SAVE_TYPE_PTR_OBJ = SAVE_POINTER + (SAVE_OBJECT << SAVE_SLOT_BITS),
- SAVE_TYPE_PTR_PTR = SAVE_POINTER + (SAVE_POINTER << SAVE_SLOT_BITS),
- SAVE_TYPE_FUNCPTR_PTR_OBJ
- = SAVE_FUNCPOINTER + (SAVE_TYPE_PTR_OBJ << SAVE_SLOT_BITS),
-
- /* This has an extra bit indicating it's raw memory. */
- SAVE_TYPE_MEMORY = SAVE_TYPE_PTR_INT + (1 << (SAVE_TYPE_BITS - 1))
- };
-
-/* SAVE_SLOT_BITS must be large enough to represent these values. */
-verify (((SAVE_UNUSED | SAVE_INTEGER | SAVE_FUNCPOINTER
- | SAVE_POINTER | SAVE_OBJECT)
- >> SAVE_SLOT_BITS)
- == 0);
-
-/* Special object used to hold a different values for later use.
-
- This is mostly used to package C integers and pointers to call
- record_unwind_protect when two or more values need to be saved.
- For example:
-
- ...
- struct my_data *md = get_my_data ();
- ptrdiff_t mi = get_my_integer ();
- record_unwind_protect (my_unwind, make_save_ptr_int (md, mi));
- ...
-
- Lisp_Object my_unwind (Lisp_Object arg)
- {
- struct my_data *md = XSAVE_POINTER (arg, 0);
- ptrdiff_t mi = XSAVE_INTEGER (arg, 1);
- ...
- }
-
- If ENABLE_CHECKING is in effect, XSAVE_xxx macros do type checking of the
- saved objects and raise eassert if type of the saved object doesn't match
- the type which is extracted. In the example above, XSAVE_INTEGER (arg, 2)
- and XSAVE_OBJECT (arg, 0) are wrong because nothing was saved in slot 2 and
- slot 0 is a pointer. */
-
-typedef void (*voidfuncptr) (void);
+ struct Lisp_Overlay *next;
+ } GCALIGNED_STRUCT;
-struct Lisp_Save_Value
+struct Lisp_Misc_Ptr
{
- ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_Save_Value */
- bool_bf gcmarkbit : 1;
- unsigned spacer : 32 - (16 + 1 + SAVE_TYPE_BITS);
-
- /* V->data may hold up to SAVE_VALUE_SLOTS entries. The type of
- V's data entries are determined by V->save_type. E.g., if
- V->save_type == SAVE_TYPE_PTR_OBJ, V->data[0] is a pointer,
- V->data[1] is an integer, and V's other data entries are unused.
-
- If V->save_type == SAVE_TYPE_MEMORY, V->data[0].pointer is the address of
- a memory area containing V->data[1].integer potential Lisp_Objects. */
- ENUM_BF (Lisp_Save_Type) save_type : SAVE_TYPE_BITS;
- union {
- void *pointer;
- voidfuncptr funcpointer;
- ptrdiff_t integer;
- Lisp_Object object;
- } data[SAVE_VALUE_SLOTS];
- };
-
-INLINE bool
-SAVE_VALUEP (Lisp_Object x)
-{
- return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Save_Value;
-}
+ union vectorlike_header header;
+ void *pointer;
+ } GCALIGNED_STRUCT;
+
+extern Lisp_Object make_misc_ptr (void *);
+
+/* A mint_ptr object OBJ represents a C-language pointer P efficiently.
+ Preferably (and typically), OBJ is a Lisp integer I such that
+ XFIXNUMPTR (I) == P, as this represents P within a single Lisp value
+ without requiring any auxiliary memory. However, if P would be
+ damaged by being tagged as an integer and then untagged via
+ XFIXNUMPTR, then OBJ is a Lisp_Misc_Ptr with pointer component P.
+
+ mint_ptr objects are efficiency hacks intended for C code.
+ Although xmint_ptr can be given any mint_ptr generated by non-buggy
+ C code, it should not be given a mint_ptr generated from Lisp code
+ as that would allow Lisp code to coin pointers from integers and
+ could lead to crashes. To package a C pointer into a Lisp-visible
+ object you can put the pointer into a pseudovector instead; see
+ Lisp_User_Ptr for an example. */
-INLINE struct Lisp_Save_Value *
-XSAVE_VALUE (Lisp_Object a)
+INLINE Lisp_Object
+make_mint_ptr (void *a)
{
- eassert (SAVE_VALUEP (a));
- return XUNTAG (a, Lisp_Misc);
+ Lisp_Object val = TAG_PTR (Lisp_Int0, a);
+ return FIXNUMP (val) && XFIXNUMPTR (val) == a ? val : make_misc_ptr (a);
}
-/* Return the type of V's Nth saved value. */
-INLINE int
-save_type (struct Lisp_Save_Value *v, int n)
+INLINE bool
+mint_ptrp (Lisp_Object x)
{
- eassert (0 <= n && n < SAVE_VALUE_SLOTS);
- return (v->save_type >> (SAVE_SLOT_BITS * n) & ((1 << SAVE_SLOT_BITS) - 1));
+ return FIXNUMP (x) || PSEUDOVECTORP (x, PVEC_MISC_PTR);
}
-/* Get and set the Nth saved pointer. */
-
INLINE void *
-XSAVE_POINTER (Lisp_Object obj, int n)
-{
- eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_POINTER);
- return XSAVE_VALUE (obj)->data[n].pointer;
-}
-INLINE void
-set_save_pointer (Lisp_Object obj, int n, void *val)
+xmint_pointer (Lisp_Object a)
{
- eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_POINTER);
- XSAVE_VALUE (obj)->data[n].pointer = val;
-}
-INLINE voidfuncptr
-XSAVE_FUNCPOINTER (Lisp_Object obj, int n)
-{
- eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_FUNCPOINTER);
- return XSAVE_VALUE (obj)->data[n].funcpointer;
-}
-
-/* Likewise for the saved integer. */
-
-INLINE ptrdiff_t
-XSAVE_INTEGER (Lisp_Object obj, int n)
-{
- eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_INTEGER);
- return XSAVE_VALUE (obj)->data[n].integer;
-}
-INLINE void
-set_save_integer (Lisp_Object obj, int n, ptrdiff_t val)
-{
- eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_INTEGER);
- XSAVE_VALUE (obj)->data[n].integer = val;
-}
-
-/* Extract Nth saved object. */
-
-INLINE Lisp_Object
-XSAVE_OBJECT (Lisp_Object obj, int n)
-{
- eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_OBJECT);
- return XSAVE_VALUE (obj)->data[n].object;
+ eassert (mint_ptrp (a));
+ if (FIXNUMP (a))
+ return XFIXNUMPTR (a);
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Misc_Ptr)->pointer;
}
#ifdef HAVE_MODULES
struct Lisp_User_Ptr
{
- ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_User_Ptr */
- bool_bf gcmarkbit : 1;
- unsigned spacer : 15;
-
+ union vectorlike_header header;
void (*finalizer) (void *);
void *p;
-};
+} GCALIGNED_STRUCT;
#endif
/* A finalizer sentinel. */
struct Lisp_Finalizer
{
- struct Lisp_Misc_Any base;
-
- /* Circular list of all active weak references. */
- struct Lisp_Finalizer *prev;
- struct Lisp_Finalizer *next;
+ union vectorlike_header header;
/* Call FUNCTION when the finalizer becomes unreachable, even if
FUNCTION contains a reference to the finalizer; i.e., call
FUNCTION when it is reachable _only_ through finalizers. */
Lisp_Object function;
- };
+
+ /* Circular list of all active weak references. */
+ struct Lisp_Finalizer *prev;
+ struct Lisp_Finalizer *next;
+ } GCALIGNED_STRUCT;
+
+extern struct Lisp_Finalizer finalizers;
+extern struct Lisp_Finalizer doomed_finalizers;
INLINE bool
FINALIZERP (Lisp_Object x)
{
- return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Finalizer;
+ return PSEUDOVECTORP (x, PVEC_FINALIZER);
}
INLINE struct Lisp_Finalizer *
XFINALIZER (Lisp_Object a)
{
eassert (FINALIZERP (a));
- return XUNTAG (a, Lisp_Misc);
-}
-
-/* A miscellaneous object, when it's on the free list. */
-struct Lisp_Free
- {
- ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_Free */
- bool_bf gcmarkbit : 1;
- unsigned spacer : 15;
- union Lisp_Misc *chain;
- };
-
-/* To get the type field of a union Lisp_Misc, use XMISCTYPE.
- It uses one of these struct subtypes to get the type field. */
-
-union Lisp_Misc
- {
- struct Lisp_Misc_Any u_any; /* Supertype of all Misc types. */
- struct Lisp_Free u_free;
- struct Lisp_Marker u_marker;
- struct Lisp_Overlay u_overlay;
- struct Lisp_Save_Value u_save_value;
- struct Lisp_Finalizer u_finalizer;
-#ifdef HAVE_MODULES
- struct Lisp_User_Ptr u_user_ptr;
-#endif
- };
-
-INLINE union Lisp_Misc *
-XMISC (Lisp_Object a)
-{
- return XUNTAG (a, Lisp_Misc);
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Finalizer);
}
INLINE bool
-(MARKERP) (Lisp_Object x)
+MARKERP (Lisp_Object x)
{
- return lisp_h_MARKERP (x);
+ return PSEUDOVECTORP (x, PVEC_MARKER);
}
INLINE struct Lisp_Marker *
XMARKER (Lisp_Object a)
{
eassert (MARKERP (a));
- return XUNTAG (a, Lisp_Misc);
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Marker);
}
INLINE bool
OVERLAYP (Lisp_Object x)
{
- return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Overlay;
+ return PSEUDOVECTORP (x, PVEC_OVERLAY);
}
INLINE struct Lisp_Overlay *
XOVERLAY (Lisp_Object a)
{
eassert (OVERLAYP (a));
- return XUNTAG (a, Lisp_Misc);
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Overlay);
}
#ifdef HAVE_MODULES
INLINE bool
USER_PTRP (Lisp_Object x)
{
- return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_User_Ptr;
+ return PSEUDOVECTORP (x, PVEC_USER_PTR);
}
INLINE struct Lisp_User_Ptr *
XUSER_PTR (Lisp_Object a)
{
eassert (USER_PTRP (a));
- return XUNTAG (a, Lisp_Misc);
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_User_Ptr);
}
#endif
+INLINE bool
+BIGNUMP (Lisp_Object x)
+{
+ return PSEUDOVECTORP (x, PVEC_BIGNUM);
+}
+
+INLINE bool
+INTEGERP (Lisp_Object x)
+{
+ return FIXNUMP (x) || BIGNUMP (x);
+}
+
+/* Return a Lisp integer with value taken from N. */
+INLINE Lisp_Object
+make_int (intmax_t n)
+{
+ return FIXNUM_OVERFLOW_P (n) ? make_bigint (n) : make_fixnum (n);
+}
+INLINE Lisp_Object
+make_uint (uintmax_t n)
+{
+ return FIXNUM_OVERFLOW_P (n) ? make_biguint (n) : make_fixnum (n);
+}
+
+/* Return a Lisp integer equal to the value of the C integer EXPR. */
+#define INT_TO_INTEGER(expr) \
+ (EXPR_SIGNED (expr) ? make_int (expr) : make_uint (expr))
+
/* Forwarding pointer to an int variable.
This is allowed only in the value cell of a symbol,
@@ -2548,7 +2675,7 @@ XUSER_PTR (Lisp_Object a)
struct Lisp_Intfwd
{
enum Lisp_Fwd_Type type; /* = Lisp_Fwd_Int */
- EMACS_INT *intvar;
+ intmax_t *intvar;
};
/* Boolean forwarding pointer to an int variable.
@@ -2577,7 +2704,7 @@ struct Lisp_Buffer_Objfwd
{
enum Lisp_Fwd_Type type; /* = Lisp_Fwd_Buffer_Obj */
int offset;
- /* One of Qnil, Qintegerp, Qsymbolp, Qstringp, Qfloatp or Qnumberp. */
+ /* One of Qnil, Qfixnump, Qsymbolp, Qstringp, Qfloatp or Qnumberp. */
Lisp_Object predicate;
};
@@ -2610,7 +2737,7 @@ struct Lisp_Buffer_Local_Value
Presumably equivalent to (defcell!=valcell). */
bool_bf found : 1;
/* If non-NULL, a forwarding to the C var where it should also be set. */
- union Lisp_Fwd *fwd; /* Should never be (Buffer|Kboard)_Objfwd. */
+ lispfwd fwd; /* Should never be (Buffer|Kboard)_Objfwd. */
/* The buffer for which the loaded binding was found. */
Lisp_Object where;
/* A cons cell that holds the default value. It has the form
@@ -2632,32 +2759,24 @@ struct Lisp_Kboard_Objfwd
int offset;
};
-union Lisp_Fwd
- {
- struct Lisp_Intfwd u_intfwd;
- struct Lisp_Boolfwd u_boolfwd;
- struct Lisp_Objfwd u_objfwd;
- struct Lisp_Buffer_Objfwd u_buffer_objfwd;
- struct Lisp_Kboard_Objfwd u_kboard_objfwd;
- };
-
INLINE enum Lisp_Fwd_Type
-XFWDTYPE (union Lisp_Fwd *a)
+XFWDTYPE (lispfwd a)
{
- return a->u_intfwd.type;
+ enum Lisp_Fwd_Type const *p = a.fwdptr;
+ return *p;
}
INLINE bool
-BUFFER_OBJFWDP (union Lisp_Fwd *a)
+BUFFER_OBJFWDP (lispfwd a)
{
return XFWDTYPE (a) == Lisp_Fwd_Buffer_Obj;
}
-INLINE struct Lisp_Buffer_Objfwd *
-XBUFFER_OBJFWD (union Lisp_Fwd *a)
+INLINE struct Lisp_Buffer_Objfwd const *
+XBUFFER_OBJFWD (lispfwd a)
{
eassert (BUFFER_OBJFWDP (a));
- return &a->u_buffer_objfwd;
+ return a.fwdptr;
}
/* Lisp floating point type. */
@@ -2668,7 +2787,7 @@ struct Lisp_Float
double data;
struct Lisp_Float *chain;
} u;
- };
+ } GCALIGNED_STRUCT;
INLINE bool
(FLOATP) (Lisp_Object x)
@@ -2680,7 +2799,7 @@ INLINE struct Lisp_Float *
XFLOAT (Lisp_Object a)
{
eassert (FLOATP (a));
- return XUNTAG (a, Lisp_Float);
+ return XUNTAG (a, Lisp_Float, struct Lisp_Float);
}
INLINE double
@@ -2691,24 +2810,14 @@ XFLOAT_DATA (Lisp_Object f)
/* Most hosts nowadays use IEEE floating point, so they use IEC 60559
representations, have infinities and NaNs, and do not trap on
- exceptions. Define IEEE_FLOATING_POINT if this host is one of the
+ exceptions. Define IEEE_FLOATING_POINT to 1 if this host is one of the
typical ones. The C11 macro __STDC_IEC_559__ is close to what is
wanted here, but is not quite right because Emacs does not require
all the features of C11 Annex F (and does not require C11 at all,
for that matter). */
-enum
- {
- IEEE_FLOATING_POINT
- = (FLT_RADIX == 2 && FLT_MANT_DIG == 24
- && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
- };
-/* A character, declared with the following typedef, is a member
- of some character set associated with the current buffer. */
-#ifndef _UCHAR_T /* Protect against something in ctab.h on AIX. */
-#define _UCHAR_T
-typedef unsigned char UCHAR;
-#endif
+#define IEEE_FLOATING_POINT (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
+ && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
/* Meanings of slots in a Lisp_Compiled: */
@@ -2746,26 +2855,26 @@ enum char_bits
/* Data type checking. */
INLINE bool
-NUMBERP (Lisp_Object x)
+FIXNATP (Lisp_Object x)
{
- return INTEGERP (x) || FLOATP (x);
+ return FIXNUMP (x) && 0 <= XFIXNUM (x);
}
INLINE bool
-NATNUMP (Lisp_Object x)
+NUMBERP (Lisp_Object x)
{
- return INTEGERP (x) && 0 <= XINT (x);
+ return INTEGERP (x) || FLOATP (x);
}
INLINE bool
-RANGED_INTEGERP (intmax_t lo, Lisp_Object x, intmax_t hi)
+RANGED_FIXNUMP (intmax_t lo, Lisp_Object x, intmax_t hi)
{
- return INTEGERP (x) && lo <= XINT (x) && XINT (x) <= hi;
+ return FIXNUMP (x) && lo <= XFIXNUM (x) && XFIXNUM (x) <= hi;
}
-#define TYPE_RANGED_INTEGERP(type, x) \
- (INTEGERP (x) \
- && (TYPE_SIGNED (type) ? TYPE_MINIMUM (type) <= XINT (x) : 0 <= XINT (x)) \
- && XINT (x) <= TYPE_MAXIMUM (type))
+#define TYPE_RANGED_FIXNUMP(type, x) \
+ (FIXNUMP (x) \
+ && (TYPE_SIGNED (type) ? TYPE_MINIMUM (type) <= XFIXNUM (x) : 0 <= XFIXNUM (x)) \
+ && XFIXNUM (x) <= TYPE_MAXIMUM (type))
INLINE bool
AUTOLOADP (Lisp_Object x)
@@ -2833,9 +2942,9 @@ CHECK_LIST_END (Lisp_Object x, Lisp_Object y)
}
INLINE void
-(CHECK_NUMBER) (Lisp_Object x)
+(CHECK_FIXNUM) (Lisp_Object x)
{
- lisp_h_CHECK_NUMBER (x);
+ lisp_h_CHECK_FIXNUM (x);
}
INLINE void
@@ -2859,21 +2968,16 @@ CHECK_ARRAY (Lisp_Object x, Lisp_Object predicate)
CHECK_TYPE (ARRAYP (x), predicate, x);
}
INLINE void
-CHECK_NATNUM (Lisp_Object x)
+CHECK_FIXNAT (Lisp_Object x)
{
- CHECK_TYPE (NATNUMP (x), Qwholenump, x);
+ CHECK_TYPE (FIXNATP (x), Qwholenump, x);
}
#define CHECK_RANGED_INTEGER(x, lo, hi) \
do { \
- CHECK_NUMBER (x); \
- if (! ((lo) <= XINT (x) && XINT (x) <= (hi))) \
- args_out_of_range_3 \
- (x, \
- make_number ((lo) < 0 && (lo) < MOST_NEGATIVE_FIXNUM \
- ? MOST_NEGATIVE_FIXNUM \
- : (lo)), \
- make_number (min (hi, MOST_POSITIVE_FIXNUM))); \
+ CHECK_FIXNUM (x); \
+ if (! ((lo) <= XFIXNUM (x) && XFIXNUM (x) <= (hi))) \
+ args_out_of_range_3 (x, INT_TO_INTEGER (lo), INT_TO_INTEGER (hi)); \
} while (false)
#define CHECK_TYPE_RANGED_INTEGER(type, x) \
do { \
@@ -2883,27 +2987,35 @@ CHECK_NATNUM (Lisp_Object x)
CHECK_RANGED_INTEGER (x, 0, TYPE_MAXIMUM (type)); \
} while (false)
-#define CHECK_NUMBER_COERCE_MARKER(x) \
+#define CHECK_FIXNUM_COERCE_MARKER(x) \
do { \
if (MARKERP ((x))) \
XSETFASTINT (x, marker_position (x)); \
else \
- CHECK_TYPE (INTEGERP (x), Qinteger_or_marker_p, x); \
+ CHECK_TYPE (FIXNUMP (x), Qinteger_or_marker_p, x); \
} while (false)
INLINE double
XFLOATINT (Lisp_Object n)
{
- return FLOATP (n) ? XFLOAT_DATA (n) : XINT (n);
+ return (FIXNUMP (n) ? XFIXNUM (n)
+ : FLOATP (n) ? XFLOAT_DATA (n)
+ : bignum_to_double (n));
}
INLINE void
-CHECK_NUMBER_OR_FLOAT (Lisp_Object x)
+CHECK_NUMBER (Lisp_Object x)
{
CHECK_TYPE (NUMBERP (x), Qnumberp, x);
}
-#define CHECK_NUMBER_OR_FLOAT_COERCE_MARKER(x) \
+INLINE void
+CHECK_INTEGER (Lisp_Object x)
+{
+ CHECK_TYPE (INTEGERP (x), Qnumberp, x);
+}
+
+#define CHECK_NUMBER_COERCE_MARKER(x) \
do { \
if (MARKERP (x)) \
XSETFASTINT (x, marker_position (x)); \
@@ -2911,27 +3023,31 @@ CHECK_NUMBER_OR_FLOAT (Lisp_Object x)
CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x); \
} while (false)
-/* Since we can't assign directly to the CAR or CDR fields of a cons
- cell, use these when checking that those fields contain numbers. */
-INLINE void
-CHECK_NUMBER_CAR (Lisp_Object x)
-{
- Lisp_Object tmp = XCAR (x);
- CHECK_NUMBER (tmp);
- XSETCAR (x, tmp);
-}
-
-INLINE void
-CHECK_NUMBER_CDR (Lisp_Object x)
-{
- Lisp_Object tmp = XCDR (x);
- CHECK_NUMBER (tmp);
- XSETCDR (x, tmp);
-}
+#define CHECK_INTEGER_COERCE_MARKER(x) \
+ do { \
+ if (MARKERP (x)) \
+ XSETFASTINT (x, marker_position (x)); \
+ else \
+ CHECK_TYPE (INTEGERP (x), Qnumber_or_marker_p, x); \
+ } while (false)
+
+/* If we're not dumping using the legacy dumper and we might be using
+ the portable dumper, try to bunch all the subr structures together
+ for more efficient dump loading. */
+#ifndef HAVE_UNEXEC
+# ifdef DARWIN_OS
+# define SUBR_SECTION_ATTRIBUTE ATTRIBUTE_SECTION ("__DATA,subrs")
+# else
+# define SUBR_SECTION_ATTRIBUTE ATTRIBUTE_SECTION (".subrs")
+# endif
+#else
+# define SUBR_SECTION_ATTRIBUTE
+#endif
+
/* Define a built-in function for calling from Lisp.
`lname' should be the name to give the function in Lisp,
- as a null-terminated C string.
+ as a NUL-terminated C string.
`fnname' should be the name of the function in C.
By convention, it starts with F.
`sname' should be the name for the C constant structure
@@ -2956,27 +3072,17 @@ CHECK_NUMBER_CDR (Lisp_Object x)
/* This version of DEFUN declares a function prototype with the right
arguments, so we can catch errors with maxargs at compile-time. */
-#ifdef _MSC_VER
#define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \
- Lisp_Object fnname DEFUN_ARGS_ ## maxargs ; \
- static struct Lisp_Subr sname = \
- { { (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) \
- | (sizeof (struct Lisp_Subr) / sizeof (EMACS_INT)) }, \
- { (Lisp_Object (__cdecl *)(void))fnname }, \
- minargs, maxargs, lname, intspec, 0}; \
- Lisp_Object fnname
-#else /* not _MSC_VER */
-#define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \
- static struct Lisp_Subr sname = \
- { { PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \
+ SUBR_SECTION_ATTRIBUTE \
+ static union Aligned_Lisp_Subr sname = \
+ {{{ PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \
{ .a ## maxargs = fnname }, \
- minargs, maxargs, lname, intspec, 0}; \
+ minargs, maxargs, lname, intspec, 0}}; \
Lisp_Object fnname
-#endif
/* defsubr (Sname);
is how we define the symbol for function `name' at start-up time. */
-extern void defsubr (struct Lisp_Subr *);
+extern void defsubr (union Aligned_Lisp_Subr *);
enum maxargs
{
@@ -2993,11 +3099,11 @@ enum maxargs
CALLN is overkill for simple usages like 'Finsert (1, &text);'. */
#define CALLN(f, ...) CALLMANY (f, ((Lisp_Object []) {__VA_ARGS__}))
-extern void defvar_lisp (struct Lisp_Objfwd *, const char *, Lisp_Object *);
-extern void defvar_lisp_nopro (struct Lisp_Objfwd *, const char *, Lisp_Object *);
-extern void defvar_bool (struct Lisp_Boolfwd *, const char *, bool *);
-extern void defvar_int (struct Lisp_Intfwd *, const char *, EMACS_INT *);
-extern void defvar_kboard (struct Lisp_Kboard_Objfwd *, const char *, int);
+extern void defvar_lisp (struct Lisp_Objfwd const *, char const *);
+extern void defvar_lisp_nopro (struct Lisp_Objfwd const *, char const *);
+extern void defvar_bool (struct Lisp_Boolfwd const *, char const *);
+extern void defvar_int (struct Lisp_Intfwd const *, char const *);
+extern void defvar_kboard (struct Lisp_Kboard_Objfwd const *, char const *);
/* Macros we use to define forwarded Lisp variables.
These are used in the syms_of_FILENAME functions.
@@ -3018,29 +3124,34 @@ extern void defvar_kboard (struct Lisp_Kboard_Objfwd *, const char *, int);
#define DEFVAR_LISP(lname, vname, doc) \
do { \
- static struct Lisp_Objfwd o_fwd; \
- defvar_lisp (&o_fwd, lname, &globals.f_ ## vname); \
+ static struct Lisp_Objfwd const o_fwd \
+ = {Lisp_Fwd_Obj, &globals.f_##vname}; \
+ defvar_lisp (&o_fwd, lname); \
} while (false)
#define DEFVAR_LISP_NOPRO(lname, vname, doc) \
do { \
- static struct Lisp_Objfwd o_fwd; \
- defvar_lisp_nopro (&o_fwd, lname, &globals.f_ ## vname); \
+ static struct Lisp_Objfwd const o_fwd \
+ = {Lisp_Fwd_Obj, &globals.f_##vname}; \
+ defvar_lisp_nopro (&o_fwd, lname); \
} while (false)
#define DEFVAR_BOOL(lname, vname, doc) \
do { \
- static struct Lisp_Boolfwd b_fwd; \
- defvar_bool (&b_fwd, lname, &globals.f_ ## vname); \
+ static struct Lisp_Boolfwd const b_fwd \
+ = {Lisp_Fwd_Bool, &globals.f_##vname}; \
+ defvar_bool (&b_fwd, lname); \
} while (false)
#define DEFVAR_INT(lname, vname, doc) \
do { \
- static struct Lisp_Intfwd i_fwd; \
- defvar_int (&i_fwd, lname, &globals.f_ ## vname); \
+ static struct Lisp_Intfwd const i_fwd \
+ = {Lisp_Fwd_Int, &globals.f_##vname}; \
+ defvar_int (&i_fwd, lname); \
} while (false)
#define DEFVAR_KBOARD(lname, vname, doc) \
do { \
- static struct Lisp_Kboard_Objfwd ko_fwd; \
- defvar_kboard (&ko_fwd, lname, offsetof (KBOARD, vname ## _)); \
+ static struct Lisp_Kboard_Objfwd const ko_fwd \
+ = {Lisp_Fwd_Kboard_Obj, offsetof (KBOARD, vname##_)}; \
+ defvar_kboard (&ko_fwd, lname); \
} while (false)
@@ -3065,8 +3176,11 @@ extern void defvar_kboard (struct Lisp_Kboard_Objfwd *, const char *, int);
enum specbind_tag {
SPECPDL_UNWIND, /* An unwind_protect function on Lisp_Object. */
+ SPECPDL_UNWIND_ARRAY, /* Likewise, on an array that needs freeing.
+ Its elements are potential Lisp_Objects. */
SPECPDL_UNWIND_PTR, /* Likewise, on void *. */
SPECPDL_UNWIND_INT, /* Likewise, on int. */
+ SPECPDL_UNWIND_EXCURSION, /* Likewise, on an execursion. */
SPECPDL_UNWIND_VOID, /* Likewise, with no arg. */
SPECPDL_BACKTRACE, /* An element of the backtrace. */
SPECPDL_LET, /* A plain and simple dynamic let-binding. */
@@ -3077,14 +3191,22 @@ enum specbind_tag {
union specbinding
{
+ /* Aligning similar members consistently might help efficiency slightly
+ (Bug#31996#25). */
ENUM_BF (specbind_tag) kind : CHAR_BIT;
struct {
ENUM_BF (specbind_tag) kind : CHAR_BIT;
void (*func) (Lisp_Object);
Lisp_Object arg;
+ EMACS_INT eval_depth;
} unwind;
struct {
ENUM_BF (specbind_tag) kind : CHAR_BIT;
+ ptrdiff_t nelts;
+ Lisp_Object *array;
+ } unwind_array;
+ struct {
+ ENUM_BF (specbind_tag) kind : CHAR_BIT;
void (*func) (void *);
void *arg;
} unwind_ptr;
@@ -3095,6 +3217,10 @@ union specbinding
} unwind_int;
struct {
ENUM_BF (specbind_tag) kind : CHAR_BIT;
+ Lisp_Object marker, window;
+ } unwind_excursion;
+ struct {
+ ENUM_BF (specbind_tag) kind : CHAR_BIT;
void (*func) (void);
} unwind_void;
struct {
@@ -3114,11 +3240,6 @@ union specbinding
} bt;
};
-/* These 3 are defined as macros in thread.h. */
-/* extern union specbinding *specpdl; */
-/* extern union specbinding *specpdl_ptr; */
-/* extern ptrdiff_t specpdl_size; */
-
INLINE ptrdiff_t
SPECPDL_INDEX (void)
{
@@ -3198,16 +3319,33 @@ extern Lisp_Object Vascii_canon_table;
/* Call staticpro (&var) to protect static variable `var'. */
-void staticpro (Lisp_Object *);
+void staticpro (Lisp_Object const *);
+
+enum { NSTATICS = 2048 };
+extern Lisp_Object const *staticvec[NSTATICS];
+extern int staticidx;
+
/* Forward declarations for prototypes. */
struct window;
struct frame;
+/* Define if the windowing system provides a menu bar. */
+#if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \
+ || defined (HAVE_NS) || defined (USE_GTK)
+#define HAVE_EXT_MENU_BAR true
+#endif
+
+/* Define if the windowing system provides a tool-bar. */
+#if defined (USE_GTK) || defined (HAVE_NS)
+#define HAVE_EXT_TOOL_BAR true
+#endif
+
/* Copy COUNT Lisp_Objects from ARGS to contents of V starting from OFFSET. */
INLINE void
-vcopy (Lisp_Object v, ptrdiff_t offset, Lisp_Object *args, ptrdiff_t count)
+vcopy (Lisp_Object v, ptrdiff_t offset, Lisp_Object const *args,
+ ptrdiff_t count)
{
eassert (0 <= offset && 0 <= count && offset + count <= ASIZE (v));
memcpy (XVECTOR (v)->contents + offset, args, count * sizeof *args);
@@ -3323,6 +3461,72 @@ set_sub_char_table_contents (Lisp_Object table, ptrdiff_t idx, Lisp_Object val)
XSUB_CHAR_TABLE (table)->contents[idx] = val;
}
+/* Defined in bignum.c. This part of bignum.c's API does not require
+ the caller to access bignum internals; see bignum.h for that. */
+extern intmax_t bignum_to_intmax (Lisp_Object);
+extern uintmax_t bignum_to_uintmax (Lisp_Object);
+extern ptrdiff_t bignum_bufsize (Lisp_Object, int);
+extern ptrdiff_t bignum_to_c_string (char *, ptrdiff_t, Lisp_Object, int);
+extern Lisp_Object bignum_to_string (Lisp_Object, int);
+extern Lisp_Object make_bignum_str (char const *, int);
+extern Lisp_Object make_neg_biguint (uintmax_t);
+extern Lisp_Object double_to_integer (double);
+
+/* Converthe integer NUM to *N. Return true if successful, false
+ (possibly setting *N) otherwise. */
+INLINE bool
+integer_to_intmax (Lisp_Object num, intmax_t *n)
+{
+ if (FIXNUMP (num))
+ {
+ *n = XFIXNUM (num);
+ return true;
+ }
+ else
+ {
+ intmax_t i = bignum_to_intmax (num);
+ *n = i;
+ return i != 0;
+ }
+}
+INLINE bool
+integer_to_uintmax (Lisp_Object num, uintmax_t *n)
+{
+ if (FIXNUMP (num))
+ {
+ *n = XFIXNUM (num);
+ return 0 <= XFIXNUM (num);
+ }
+ else
+ {
+ uintmax_t i = bignum_to_uintmax (num);
+ *n = i;
+ return i != 0;
+ }
+}
+
+/* A modification count. These are wide enough, and incremented
+ rarely enough, so that they should never overflow a 60-bit counter
+ in practice, and the code below assumes this so a compiler can
+ generate better code if EMACS_INT is 64 bits. */
+typedef intmax_t modiff_count;
+
+INLINE modiff_count
+modiff_incr (modiff_count *a)
+{
+ modiff_count a0 = *a;
+ bool modiff_overflow = INT_ADD_WRAPV (a0, 1, a);
+ eassert (!modiff_overflow && *a >> 30 >> 30 == 0);
+ return a0;
+}
+
+INLINE Lisp_Object
+modiff_to_integer (modiff_count a)
+{
+ eassume (0 <= a && a >> 30 >> 30 == 0);
+ return make_int (a);
+}
+
/* Defined in data.c. */
extern _Noreturn void wrong_choice (Lisp_Object, Lisp_Object);
extern void notify_variable_watchers (Lisp_Object, Lisp_Object,
@@ -3340,16 +3544,6 @@ enum Arith_Comparison {
extern Lisp_Object arithcompare (Lisp_Object num1, Lisp_Object num2,
enum Arith_Comparison comparison);
-/* Convert the integer I to an Emacs representation, either the integer
- itself, or a cons of two or three integers, or if all else fails a float.
- I should not have side effects. */
-#define INTEGER_TO_CONS(i) \
- (! FIXNUM_OVERFLOW_P (i) \
- ? make_number (i) \
- : EXPR_SIGNED (i) ? intbig_to_lisp (i) : uintbig_to_lisp (i))
-extern Lisp_Object intbig_to_lisp (intmax_t);
-extern Lisp_Object uintbig_to_lisp (uintmax_t);
-
/* Convert the Emacs representation CONS back to an integer of type
TYPE, storing the result the variable VAR. Signal an error if CONS
is not a valid representation or is out of range for TYPE. */
@@ -3365,7 +3559,7 @@ extern _Noreturn void args_out_of_range (Lisp_Object, Lisp_Object);
extern _Noreturn void args_out_of_range_3 (Lisp_Object, Lisp_Object,
Lisp_Object);
extern _Noreturn void circular_list (Lisp_Object);
-extern Lisp_Object do_symval_forwarding (union Lisp_Fwd *);
+extern Lisp_Object do_symval_forwarding (lispfwd);
enum Set_Internal_Bind {
SET_INTERNAL_SET,
SET_INTERNAL_BIND,
@@ -3376,7 +3570,7 @@ extern void set_internal (Lisp_Object, Lisp_Object, Lisp_Object,
enum Set_Internal_Bind);
extern void set_default_internal (Lisp_Object, Lisp_Object,
enum Set_Internal_Bind bindflag);
-
+extern Lisp_Object expt_integer (Lisp_Object, Lisp_Object);
extern void syms_of_data (void);
extern void swap_in_global_binding (struct Lisp_Symbol *);
@@ -3409,14 +3603,17 @@ extern void syms_of_syntax (void);
/* Defined in fns.c. */
enum { NEXT_ALMOST_PRIME_LIMIT = 11 };
+extern ptrdiff_t list_length (Lisp_Object);
extern EMACS_INT next_almost_prime (EMACS_INT) ATTRIBUTE_CONST;
extern Lisp_Object larger_vector (Lisp_Object, ptrdiff_t, ptrdiff_t);
-extern void sweep_weak_hash_tables (void);
+extern bool sweep_weak_table (struct Lisp_Hash_Table *, bool);
extern char *extract_data_from_object (Lisp_Object, ptrdiff_t *, ptrdiff_t *);
EMACS_UINT hash_string (char const *, ptrdiff_t);
EMACS_UINT sxhash (Lisp_Object, int);
+EMACS_UINT hashfn_eql (struct hash_table_test *ht, Lisp_Object key);
+EMACS_UINT hashfn_equal (struct hash_table_test *ht, Lisp_Object key);
Lisp_Object make_hash_table (struct hash_table_test, EMACS_INT, float, float,
- Lisp_Object, bool);
+ Lisp_Object, bool);
ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object, EMACS_UINT *);
ptrdiff_t hash_put (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object,
EMACS_UINT);
@@ -3442,8 +3639,11 @@ extern Lisp_Object string_make_unibyte (Lisp_Object);
extern void syms_of_fns (void);
/* Defined in floatfns.c. */
-extern void syms_of_floatfns (void);
+#ifndef HAVE_TRUNC
+extern double trunc (double);
+#endif
extern Lisp_Object fmod_float (Lisp_Object x, Lisp_Object y);
+extern void syms_of_floatfns (void);
/* Defined in fringe.c. */
extern void syms_of_fringe (void);
@@ -3458,6 +3658,12 @@ extern int x_bitmap_mask (struct frame *, ptrdiff_t);
extern void reset_image_types (void);
extern void syms_of_image (void);
+#ifdef HAVE_JSON
+/* Defined in json.c. */
+extern void init_json (void);
+extern void syms_of_json (void);
+#endif
+
/* Defined in insdel.c. */
extern void move_gap_both (ptrdiff_t, ptrdiff_t);
extern _Noreturn void buffer_overflow (void);
@@ -3507,8 +3713,7 @@ extern void replace_range_2 (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t,
extern void syms_of_insdel (void);
/* Defined in dispnew.c. */
-#if (defined PROFILING \
- && (defined __FreeBSD__ || defined GNU_LINUX || defined __MINGW32__))
+#ifdef PROFILING
_Noreturn void __executable_start (void);
#endif
extern Lisp_Object Vwindow_system;
@@ -3559,7 +3764,6 @@ extern void parse_str_as_multibyte (const unsigned char *, ptrdiff_t,
/* Defined in alloc.c. */
extern void *my_heap_start (void);
extern void check_pure_size (void);
-extern void free_misc (Lisp_Object);
extern void allocate_string_data (struct Lisp_String *, EMACS_INT, EMACS_INT);
extern void malloc_warning (const char *);
extern _Noreturn void memory_full (size_t);
@@ -3571,41 +3775,75 @@ extern void refill_memory_reserve (void);
#endif
extern void alloc_unexec_pre (void);
extern void alloc_unexec_post (void);
-extern void mark_stack (char *, char *);
+extern void mark_maybe_objects (Lisp_Object const *, ptrdiff_t);
+extern void mark_stack (char const *, char const *);
extern void flush_stack_call_func (void (*func) (void *arg), void *arg);
+extern void garbage_collect (void);
extern const char *pending_malloc_warning;
extern Lisp_Object zero_vector;
-extern EMACS_INT consing_since_gc;
-extern EMACS_INT gc_relative_threshold;
-extern EMACS_INT memory_full_cons_threshold;
+typedef uintptr_t byte_ct; /* System byte counts reported by GC. */
+extern byte_ct consing_since_gc;
+extern byte_ct gc_relative_threshold;
+extern byte_ct const memory_full_cons_threshold;
+#ifdef HAVE_PDUMPER
+extern int number_finalizers_run;
+#endif
+#ifdef ENABLE_CHECKING
+extern Lisp_Object Vdead;
+#endif
extern Lisp_Object list1 (Lisp_Object);
extern Lisp_Object list2 (Lisp_Object, Lisp_Object);
extern Lisp_Object list3 (Lisp_Object, Lisp_Object, Lisp_Object);
extern Lisp_Object list4 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
extern Lisp_Object list5 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object);
-enum constype {CONSTYPE_HEAP, CONSTYPE_PURE};
-extern Lisp_Object listn (enum constype, ptrdiff_t, Lisp_Object, ...);
+extern Lisp_Object listn (ptrdiff_t, Lisp_Object, ...);
+extern Lisp_Object pure_listn (ptrdiff_t, Lisp_Object, ...);
+#define list(...) \
+ listn (ARRAYELTS (((Lisp_Object []) {__VA_ARGS__})), __VA_ARGS__)
+#define pure_list(...) \
+ pure_listn (ARRAYELTS (((Lisp_Object []) {__VA_ARGS__})), __VA_ARGS__)
+
+enum gc_root_type
+{
+ GC_ROOT_STATICPRO,
+ GC_ROOT_BUFFER_LOCAL_DEFAULT,
+ GC_ROOT_BUFFER_LOCAL_NAME,
+ GC_ROOT_C_SYMBOL
+};
+
+struct gc_root_visitor
+{
+ void (*visit) (Lisp_Object const *, enum gc_root_type, void *);
+ void *data;
+};
+extern void visit_static_gc_roots (struct gc_root_visitor visitor);
-/* Build a frequently used 2/3/4-integer lists. */
+/* Build a frequently used 1/2/3/4-integer lists. */
+
+INLINE Lisp_Object
+list1i (EMACS_INT x)
+{
+ return list1 (make_fixnum (x));
+}
INLINE Lisp_Object
list2i (EMACS_INT x, EMACS_INT y)
{
- return list2 (make_number (x), make_number (y));
+ return list2 (make_fixnum (x), make_fixnum (y));
}
INLINE Lisp_Object
list3i (EMACS_INT x, EMACS_INT y, EMACS_INT w)
{
- return list3 (make_number (x), make_number (y), make_number (w));
+ return list3 (make_fixnum (x), make_fixnum (y), make_fixnum (w));
}
INLINE Lisp_Object
list4i (EMACS_INT x, EMACS_INT y, EMACS_INT w, EMACS_INT h)
{
- return list4 (make_number (x), make_number (y),
- make_number (w), make_number (h));
+ return list4 (make_fixnum (x), make_fixnum (y),
+ make_fixnum (w), make_fixnum (h));
}
extern Lisp_Object make_uninit_bool_vector (EMACS_INT);
@@ -3615,6 +3853,13 @@ extern Lisp_Object make_string (const char *, ptrdiff_t);
extern Lisp_Object make_formatted_string (char *, const char *, ...)
ATTRIBUTE_FORMAT_PRINTF (2, 3);
extern Lisp_Object make_unibyte_string (const char *, ptrdiff_t);
+extern ptrdiff_t vectorlike_nbytes (const union vectorlike_header *hdr);
+
+INLINE ptrdiff_t
+vector_nbytes (const struct Lisp_Vector *v)
+{
+ return vectorlike_nbytes (&v->header);
+}
/* Make unibyte string from C string when the length isn't known. */
@@ -3652,8 +3897,9 @@ build_string (const char *str)
}
extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object);
+extern Lisp_Object make_vector (ptrdiff_t, Lisp_Object);
extern void make_byte_code (struct Lisp_Vector *);
-extern struct Lisp_Vector *allocate_vector (EMACS_INT);
+extern struct Lisp_Vector *allocate_vector (ptrdiff_t);
/* Make an uninitialized vector for SIZE objects. NOTE: you must
be sure that GC cannot happen until the vector is completely
@@ -3667,12 +3913,7 @@ extern struct Lisp_Vector *allocate_vector (EMACS_INT);
INLINE Lisp_Object
make_uninit_vector (ptrdiff_t size)
{
- Lisp_Object v;
- struct Lisp_Vector *p;
-
- p = allocate_vector (size);
- XSETVECTOR (v, p);
- return v;
+ return make_lisp_ptr (allocate_vector (size), Lisp_Vectorlike);
}
/* Like above, but special for sub char-tables. */
@@ -3689,9 +3930,24 @@ make_uninit_sub_char_table (int depth, int min_char)
return v;
}
+/* Make a vector of SIZE nils. */
+
+INLINE Lisp_Object
+make_nil_vector (ptrdiff_t size)
+{
+ Lisp_Object vec = make_uninit_vector (size);
+ memclear (XVECTOR (vec)->contents, size * word_size);
+ return vec;
+}
+
extern struct Lisp_Vector *allocate_pseudovector (int, int, int,
enum pvec_type);
+/* Allocate uninitialized pseudovector with no Lisp_Object slots. */
+
+#define ALLOCATE_PLAIN_PSEUDOVECTOR(type, tag) \
+ ((type *) allocate_pseudovector (VECSIZE (type), 0, 0, tag))
+
/* Allocate partially initialized pseudovector where all Lisp_Object
slots are set to Qnil but the rest (if any) is left uninitialized. */
@@ -3712,16 +3968,6 @@ extern bool gc_in_progress;
extern Lisp_Object make_float (double);
extern void display_malloc_warning (void);
extern ptrdiff_t inhibit_garbage_collection (void);
-extern Lisp_Object make_save_int_int_int (ptrdiff_t, ptrdiff_t, ptrdiff_t);
-extern Lisp_Object make_save_obj_obj_obj_obj (Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object);
-extern Lisp_Object make_save_ptr (void *);
-extern Lisp_Object make_save_ptr_int (void *, ptrdiff_t);
-extern Lisp_Object make_save_ptr_ptr (void *, void *);
-extern Lisp_Object make_save_funcptr_ptr_obj (void (*) (void), void *,
- Lisp_Object);
-extern Lisp_Object make_save_memory (Lisp_Object *, ptrdiff_t);
-extern void free_save_value (Lisp_Object);
extern Lisp_Object build_overlay (Lisp_Object, Lisp_Object, Lisp_Object);
extern void free_cons (struct Lisp_Cons *);
extern void init_alloc_once (void);
@@ -3809,11 +4055,12 @@ LOADHIST_ATTACH (Lisp_Object x)
}
extern int openp (Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object *, Lisp_Object, bool);
-extern Lisp_Object string_to_number (char const *, int, bool);
+enum { S2N_IGNORE_TRAILING = 1 };
+extern Lisp_Object string_to_number (char const *, int, ptrdiff_t *);
extern void map_obarray (Lisp_Object, void (*) (Lisp_Object, Lisp_Object),
Lisp_Object);
extern void dir_warning (const char *, Lisp_Object);
-extern void init_obarray (void);
+extern void init_obarray_once (void);
extern void init_lread (void);
extern void syms_of_lread (void);
@@ -3859,6 +4106,7 @@ extern _Noreturn void xsignal2 (Lisp_Object, Lisp_Object, Lisp_Object);
extern _Noreturn void xsignal3 (Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object);
extern _Noreturn void signal_error (const char *, Lisp_Object);
+extern _Noreturn void overflow_error (void);
extern bool FUNCTIONP (Lisp_Object);
extern Lisp_Object funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *arg_vector);
extern Lisp_Object eval_sub (Lisp_Object form);
@@ -3880,13 +4128,16 @@ extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp
extern Lisp_Object internal_condition_case_n
(Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *,
Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *));
+extern Lisp_Object internal_catch_all (Lisp_Object (*) (void *), void *, Lisp_Object (*) (Lisp_Object));
extern struct handler *push_handler (Lisp_Object, enum handlertype);
extern struct handler *push_handler_nosignal (Lisp_Object, enum handlertype);
extern void specbind (Lisp_Object, Lisp_Object);
extern void record_unwind_protect (void (*) (Lisp_Object), Lisp_Object);
+extern void record_unwind_protect_array (Lisp_Object *, ptrdiff_t);
extern void record_unwind_protect_ptr (void (*) (void *), void *);
extern void record_unwind_protect_int (void (*) (int), int);
extern void record_unwind_protect_void (void (*) (void));
+extern void record_unwind_protect_excursion (void);
extern void record_unwind_protect_nothing (void);
extern void clear_unwind_protect (ptrdiff_t);
extern void set_unwind_protect (ptrdiff_t, void (*) (Lisp_Object), Lisp_Object);
@@ -3915,7 +4166,7 @@ Lisp_Object backtrace_top_function (void);
extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol);
/* Defined in unexmacosx.c. */
-#if defined DARWIN_OS && !defined CANNOT_DUMP
+#if defined DARWIN_OS && defined HAVE_UNEXEC
extern void unexec_init_emacs_zone (void);
extern void *unexec_malloc (size_t);
extern void *unexec_realloc (void *, size_t);
@@ -3946,7 +4197,7 @@ struct Lisp_Module_Function
ptrdiff_t min_arity, max_arity;
emacs_subr subr;
void *data;
-};
+} GCALIGNED_STRUCT;
INLINE bool
MODULE_FUNCTIONP (Lisp_Object o)
@@ -3958,7 +4209,7 @@ INLINE struct Lisp_Module_Function *
XMODULE_FUNCTION (Lisp_Object o)
{
eassert (MODULE_FUNCTIONP (o));
- return XUNTAG (o, Lisp_Vectorlike);
+ return XUNTAG (o, Lisp_Vectorlike, struct Lisp_Module_Function);
}
#ifdef HAVE_MODULES
@@ -3975,18 +4226,18 @@ extern void syms_of_module (void);
/* Defined in thread.c. */
extern void mark_threads (void);
+extern void unmark_main_thread (void);
/* Defined in editfns.c. */
extern void insert1 (Lisp_Object);
-extern Lisp_Object save_excursion_save (void);
+extern void save_excursion_save (union specbinding *);
+extern void save_excursion_restore (Lisp_Object, Lisp_Object);
extern Lisp_Object save_restriction_save (void);
-extern void save_excursion_restore (Lisp_Object);
extern void save_restriction_restore (Lisp_Object);
-extern _Noreturn void time_overflow (void);
extern Lisp_Object make_buffer_string (ptrdiff_t, ptrdiff_t, bool);
extern Lisp_Object make_buffer_string_both (ptrdiff_t, ptrdiff_t, ptrdiff_t,
ptrdiff_t, bool);
-extern void init_editfns (bool);
+extern void init_editfns (void);
extern void syms_of_editfns (void);
/* Defined in buffer.c. */
@@ -4002,7 +4253,7 @@ extern bool overlay_touches_p (ptrdiff_t);
extern Lisp_Object other_buffer_safely (Lisp_Object);
extern Lisp_Object get_truename_buffer (Lisp_Object);
extern void init_buffer_once (void);
-extern void init_buffer (int);
+extern void init_buffer (void);
extern void syms_of_buffer (void);
extern void keys_of_buffer (void);
@@ -4024,6 +4275,9 @@ extern void syms_of_marker (void);
/* Defined in fileio.c. */
+extern char *splice_dir_file (char *, char const *, char const *);
+extern bool file_name_absolute_p (const char *);
+extern char const *get_homedir (void);
extern Lisp_Object expand_and_dir_to_file (Lisp_Object);
extern Lisp_Object write_region (Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object, Lisp_Object, Lisp_Object,
@@ -4037,7 +4291,7 @@ extern _Noreturn void report_file_error (const char *, Lisp_Object);
extern _Noreturn void report_file_notify_error (const char *, Lisp_Object);
extern bool internal_delete_file (Lisp_Object);
extern Lisp_Object emacs_readlinkat (int, const char *);
-extern bool file_directory_p (const char *);
+extern bool file_directory_p (Lisp_Object);
extern bool file_accessible_directory_p (Lisp_Object);
extern void init_fileio (void);
extern void syms_of_fileio (void);
@@ -4048,10 +4302,6 @@ extern void restore_search_regs (void);
extern void update_search_regs (ptrdiff_t oldstart,
ptrdiff_t oldend, ptrdiff_t newend);
extern void record_unwind_save_match_data (void);
-struct re_registers;
-extern struct re_pattern_buffer *compile_pattern (Lisp_Object,
- struct re_registers *,
- Lisp_Object, bool, bool);
extern ptrdiff_t fast_string_match_internal (Lisp_Object, Lisp_Object,
Lisp_Object);
@@ -4073,8 +4323,8 @@ extern ptrdiff_t fast_looking_at (Lisp_Object, ptrdiff_t, ptrdiff_t,
ptrdiff_t, ptrdiff_t, Lisp_Object);
extern ptrdiff_t find_newline (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t,
ptrdiff_t, ptrdiff_t *, ptrdiff_t *, bool);
-extern ptrdiff_t scan_newline (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t,
- ptrdiff_t, bool);
+extern void scan_newline (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t,
+ ptrdiff_t, bool);
extern ptrdiff_t scan_newline_from_point (ptrdiff_t, ptrdiff_t *, ptrdiff_t *);
extern ptrdiff_t find_newline_no_quit (ptrdiff_t, ptrdiff_t,
ptrdiff_t, ptrdiff_t *);
@@ -4147,11 +4397,13 @@ extern void store_in_alist (Lisp_Object *, Lisp_Object, Lisp_Object);
extern Lisp_Object do_switch_frame (Lisp_Object, int, int, Lisp_Object);
extern Lisp_Object get_frame_param (struct frame *, Lisp_Object);
extern void frames_discard_buffer (Lisp_Object);
+extern void init_frame_once (void);
extern void syms_of_frame (void);
/* Defined in emacs.c. */
extern char **initial_argv;
extern int initial_argc;
+extern char const *emacs_wd;
#if defined (HAVE_X_WINDOWS) || defined (HAVE_NS)
extern bool display_arg;
#endif
@@ -4292,9 +4544,13 @@ struct tty_display_info;
/* Defined in sysdep.c. */
#ifdef HAVE_PERSONALITY_ADDR_NO_RANDOMIZE
-extern bool disable_address_randomization (void);
+extern int maybe_disable_address_randomization (bool, int, char **);
#else
-INLINE bool disable_address_randomization (void) { return false; }
+INLINE int
+maybe_disable_address_randomization (bool dumping, int argc, char **argv)
+{
+ return argc;
+}
#endif
extern int emacs_exec_file (char const *, char *const *, char *const *);
extern void init_standard_fds (void);
@@ -4327,6 +4583,7 @@ extern ptrdiff_t emacs_write_quit (int, void const *, ptrdiff_t);
extern void emacs_perror (char const *);
extern int renameat_noreplace (int, char const *, int, char const *);
extern int str_collate (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
+extern void syms_of_sysdep (void);
/* Defined in filelock.c. */
extern void lock_file (Lisp_Object);
@@ -4392,10 +4649,18 @@ extern void syms_of_gfilenotify (void);
extern void syms_of_w32notify (void);
#endif
+#if defined HAVE_NTGUI || defined CYGWIN
+/* Defined in w32cygwinx.c. */
+extern void syms_of_w32cygwinx (void);
+#endif
+
/* Defined in xfaces.c. */
extern Lisp_Object Vface_alternative_font_family_alist;
extern Lisp_Object Vface_alternative_font_registry_alist;
extern void syms_of_xfaces (void);
+#ifdef HAVE_PDUMPER
+extern void init_xfaces (void);
+#endif
#ifdef HAVE_X_WINDOWS
/* Defined in xfns.c. */
@@ -4417,9 +4682,9 @@ extern void syms_of_xterm (void);
extern char *x_get_keysym_name (int);
#endif /* HAVE_WINDOW_SYSTEM */
-#ifdef HAVE_LIBXML2
/* Defined in xml.c. */
extern void syms_of_xml (void);
+#ifdef HAVE_LIBXML2
extern void xml_cleanup_parser (void);
#endif
@@ -4470,7 +4735,7 @@ extern char *xlispstrdup (Lisp_Object) ATTRIBUTE_MALLOC;
extern void dupstring (char **, char const *);
/* Make DEST a copy of STRING's data. Return a pointer to DEST's terminating
- null byte. This is like stpcpy, except the source is a Lisp string. */
+ NUL byte. This is like stpcpy, except the source is a Lisp string. */
INLINE char *
lispstpcpy (char *dest, Lisp_Object string)
@@ -4500,12 +4765,6 @@ extern void init_system_name (void);
because 'abs' is reserved by the C standard. */
#define eabs(x) ((x) < 0 ? -(x) : (x))
-/* Return a fixnum or float, depending on whether the integer VAL fits
- in a Lisp fixnum. */
-
-#define make_fixnum_or_float(val) \
- (FIXNUM_OVERFLOW_P (val) ? make_float (val) : make_number (val))
-
/* SAFE_ALLOCA normally allocates memory on the stack, but if size is
larger than MAX_ALLOCA, use xmalloc to avoid overflowing the stack. */
@@ -4515,7 +4774,7 @@ extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1));
#define USE_SAFE_ALLOCA \
ptrdiff_t sa_avail = MAX_ALLOCA; \
- ptrdiff_t sa_count = SPECPDL_INDEX (); bool sa_must_free = false
+ ptrdiff_t sa_count = SPECPDL_INDEX ()
#define AVAIL_ALLOCA(size) (sa_avail -= (size), alloca (size))
@@ -4523,7 +4782,7 @@ extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1));
#define SAFE_ALLOCA(size) ((size) <= sa_avail \
? AVAIL_ALLOCA (size) \
- : (sa_must_free = true, record_xmalloc (size)))
+ : record_xmalloc (size))
/* SAFE_NALLOCA sets BUF to a newly allocated array of MULTIPLIER *
NITEMS items, each of the same type as *BUF. MULTIPLIER must
@@ -4536,7 +4795,6 @@ extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1));
else \
{ \
(buf) = xnmalloc (nitems, sizeof *(buf) * (multiplier)); \
- sa_must_free = true; \
record_unwind_protect_ptr (xfree, buf); \
} \
} while (false)
@@ -4549,15 +4807,44 @@ extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1));
memcpy (ptr, SDATA (string), SBYTES (string) + 1); \
} while (false)
-/* SAFE_FREE frees xmalloced memory and enables GC as needed. */
+/* Free xmalloced memory and enable GC as needed. */
-#define SAFE_FREE() \
- do { \
- if (sa_must_free) { \
- sa_must_free = false; \
- unbind_to (sa_count, Qnil); \
- } \
- } while (false)
+#define SAFE_FREE() safe_free (sa_count)
+
+INLINE void
+safe_free (ptrdiff_t sa_count)
+{
+ while (specpdl_ptr != specpdl + sa_count)
+ {
+ specpdl_ptr--;
+ if (specpdl_ptr->kind == SPECPDL_UNWIND_PTR)
+ {
+ eassert (specpdl_ptr->unwind_ptr.func == xfree);
+ xfree (specpdl_ptr->unwind_ptr.arg);
+ }
+ else
+ {
+ eassert (specpdl_ptr->kind == SPECPDL_UNWIND_ARRAY);
+ xfree (specpdl_ptr->unwind_array.array);
+ }
+ }
+}
+
+/* Pop the specpdl stack back to COUNT, and return VAL.
+ Prefer this to { SAFE_FREE (); unbind_to (COUNT, VAL); }
+ when COUNT predates USE_SAFE_ALLOCA, as it is a bit more efficient
+ and also lets callers intermix SAFE_ALLOCA calls with other calls
+ that grow the specpdl stack. */
+
+#define SAFE_FREE_UNBIND_TO(count, val) \
+ safe_free_unbind_to (count, sa_count, val)
+
+INLINE Lisp_Object
+safe_free_unbind_to (ptrdiff_t count, ptrdiff_t sa_count, Lisp_Object val)
+{
+ eassert (count <= sa_count);
+ return unbind_to (count, val);
+}
/* Set BUF to point to an allocated array of NELT Lisp_Objects,
immediately followed by EXTRA spare bytes. */
@@ -4573,11 +4860,8 @@ extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1));
(buf) = AVAIL_ALLOCA (alloca_nbytes); \
else \
{ \
- Lisp_Object arg_; \
(buf) = xmalloc (alloca_nbytes); \
- arg_ = make_save_memory (buf, nelt); \
- sa_must_free = true; \
- record_unwind_protect (free_save_value, arg_); \
+ record_unwind_protect_array (buf, nelt); \
} \
} while (false)
@@ -4586,13 +4870,14 @@ extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1));
#define SAFE_ALLOCA_LISP(buf, nelt) SAFE_ALLOCA_LISP_EXTRA (buf, nelt, 0)
-/* If USE_STACK_LISP_OBJECTS, define macros that and functions that allocate
- block-scoped conses and strings. These objects are not
- managed by the garbage collector, so they are dangerous: passing them
- out of their scope (e.g., to user code) results in undefined behavior.
- Conversely, they have better performance because GC is not involved.
+/* If USE_STACK_LISP_OBJECTS, define macros and functions that
+ allocate some Lisp objects on the C stack. As the storage is not
+ managed by the garbage collector, these objects are dangerous:
+ passing them to user code could result in undefined behavior if the
+ objects are in use after the C function returns. Conversely, these
+ objects have better performance because GC is not involved.
- This feature is experimental and requires careful debugging.
+ While debugging you may want to disable allocation on the C stack.
Build with CPPFLAGS='-DUSE_STACK_LISP_OBJECTS=0' to disable it. */
#if (!defined USE_STACK_LISP_OBJECTS \
@@ -4654,19 +4939,21 @@ enum
: list4 (a, b, c, d))
/* Declare NAME as an auto Lisp string if possible, a GC-based one if not.
- Take its unibyte value from the null-terminated string STR,
+ Take its unibyte value from the NUL-terminated string STR,
an expression that should not have side effects.
STR's value is not necessarily copied. The resulting Lisp string
- should not be modified or made visible to user code. */
+ should not be modified or given text properties or made visible to
+ user code. */
#define AUTO_STRING(name, str) \
AUTO_STRING_WITH_LEN (name, str, strlen (str))
/* Declare NAME as an auto Lisp string if possible, a GC-based one if not.
- Take its unibyte value from the null-terminated string STR with length LEN.
- STR may have side effects and may contain null bytes.
+ Take its unibyte value from the NUL-terminated string STR with length LEN.
+ STR may have side effects and may contain NUL bytes.
STR's value is not necessarily copied. The resulting Lisp string
- should not be modified or made visible to user code. */
+ should not be modified or given text properties or made visible to
+ user code. */
#define AUTO_STRING_WITH_LEN(name, str, len) \
Lisp_Object name = \
@@ -4676,6 +4963,11 @@ enum
Lisp_String)) \
: make_unibyte_string (str, len))
+/* The maximum length of "small" lists, as a heuristic. These lists
+ are so short that code need not check for cycles or quits while
+ traversing. */
+enum { SMALL_LIST_LEN_MAX = 127 };
+
/* Loop over conses of the list TAIL, signaling if a cycle is found,
and possibly quitting after each loop iteration. In the loop body,
set TAIL to the current cons. If the loop exits normally,
@@ -4686,7 +4978,7 @@ enum
#define FOR_EACH_TAIL(tail) \
FOR_EACH_TAIL_INTERNAL (tail, circular_list (tail), true)
-/* Like FOR_EACH_TAIL (LIST), except do not signal or quit.
+/* Like FOR_EACH_TAIL (TAIL), except do not signal or quit.
If the loop exits due to a cycle, TAIL’s value is undefined. */
#define FOR_EACH_TAIL_SAFE(tail) \
@@ -4741,7 +5033,7 @@ maybe_gc (void)
&& consing_since_gc > gc_relative_threshold)
|| (!NILP (Vmemory_full)
&& consing_since_gc > memory_full_cons_threshold))
- Fgarbage_collect ();
+ garbage_collect ();
}
INLINE_HEADER_END
diff --git a/src/lread.c b/src/lread.c
index b0eb29a2a1f..5f33fcd6957 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -42,14 +42,11 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "systime.h"
#include "termhooks.h"
#include "blockinput.h"
+#include "pdumper.h"
#include <c-ctype.h>
#ifdef MSDOS
#include "msdos.h"
-#if __DJGPP__ == 2 && __DJGPP_MINOR__ < 5
-# define INFINITY __builtin_inf()
-# define NAN __builtin_nan("")
-#endif
#endif
#ifdef HAVE_NS
@@ -72,6 +69,13 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#define file_tell ftell
#endif
+#if IEEE_FLOATING_POINT
+# include <ieee754.h>
+# ifndef INFINITY
+# define INFINITY ((union ieee754_double) {.ieee = {.exponent = -1}}.d)
+# endif
+#endif
+
/* The objects or placeholders read with the #n=object form.
A hash table maps a number to either a placeholder (while the
@@ -147,10 +151,10 @@ static ptrdiff_t prev_saved_doc_string_length;
/* This is the file position that string came from. */
static file_offset prev_saved_doc_string_position;
-/* True means inside a new-style backquote
- with no surrounding parentheses.
- Fread initializes this to false, so we need not specbind it
- or worry about what happens to it when there is an error. */
+/* True means inside a new-style backquote with no surrounding
+ parentheses. Fread initializes this to the value of
+ `force_new_style_backquotes', so we need not specbind it or worry
+ about what happens to it when there is an error. */
static bool new_backquote_flag;
/* A list of file names for files being loaded in Fload. Used to
@@ -164,6 +168,8 @@ static int read_emacs_mule_char (int, int (*) (int, Lisp_Object),
static void readevalloop (Lisp_Object, struct infile *, Lisp_Object, bool,
Lisp_Object, Lisp_Object,
Lisp_Object, Lisp_Object);
+
+static void build_load_history (Lisp_Object, bool);
/* Functions that read one byte from the current source READCHARFUN
or unreads one byte. If the integer argument C is -1, it returns
@@ -329,7 +335,7 @@ readchar (Lisp_Object readcharfun, bool *multibyte)
if (NILP (tem))
return -1;
- return XINT (tem);
+ return XFIXNUM (tem);
read_multibyte:
if (unread_char >= 0)
@@ -461,7 +467,7 @@ unreadchar (Lisp_Object readcharfun, int c)
unread_char = c;
}
else
- call1 (readcharfun, make_number (c));
+ call1 (readcharfun, make_fixnum (c));
}
static int
@@ -671,7 +677,7 @@ read_filtered_event (bool no_switch_frame, bool ascii_required,
do
val = read_char (0, Qnil, (input_method ? Qnil : Qt), 0,
NUMBERP (seconds) ? &end_time : NULL);
- while (INTEGERP (val) && XINT (val) == -2); /* wrong_kboard_jmpbuf */
+ while (FIXNUMP (val) && XFIXNUM (val) == -2); /* wrong_kboard_jmpbuf */
if (BUFFERP (val))
goto retry;
@@ -702,12 +708,12 @@ read_filtered_event (bool no_switch_frame, bool ascii_required,
/* Merge this symbol's modifier bits
with the ASCII equivalent of its basic code. */
if (!NILP (tem1))
- XSETFASTINT (val, XINT (tem1) | XINT (Fcar (Fcdr (tem))));
+ XSETFASTINT (val, XFIXNUM (tem1) | XFIXNUM (Fcar (Fcdr (tem))));
}
}
/* If we don't have a character now, deal with it appropriately. */
- if (!INTEGERP (val))
+ if (!FIXNUMP (val))
{
if (error_nonascii)
{
@@ -768,7 +774,7 @@ floating-point value. */)
val = read_filtered_event (1, 1, 1, ! NILP (inherit_input_method), seconds);
return (NILP (val) ? Qnil
- : make_number (char_resolve_modifier_mask (XINT (val))));
+ : make_fixnum (char_resolve_modifier_mask (XFIXNUM (val))));
}
DEFUN ("read-event", Fread_event, Sread_event, 0, 3, 0,
@@ -816,7 +822,7 @@ floating-point value. */)
val = read_filtered_event (1, 1, 0, ! NILP (inherit_input_method), seconds);
return (NILP (val) ? Qnil
- : make_number (char_resolve_modifier_mask (XINT (val))));
+ : make_fixnum (char_resolve_modifier_mask (XFIXNUM (val))));
}
DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0,
@@ -825,7 +831,7 @@ DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0,
{
if (!infile)
error ("get-file-char misused");
- return make_number (readbyte_from_stdio ());
+ return make_fixnum (readbyte_from_stdio ());
}
@@ -1013,13 +1019,15 @@ load_error_handler (Lisp_Object data)
return Qnil;
}
-static void
-load_warn_old_style_backquotes (Lisp_Object file)
+static _Noreturn void
+load_error_old_style_backquotes (void)
{
- if (!NILP (Vlread_old_style_backquotes))
+ if (NILP (Vload_file_name))
+ xsignal1 (Qerror, build_string ("Old-style backquotes detected!"));
+ else
{
AUTO_STRING (format, "Loading `%s': old-style backquotes detected!");
- CALLN (Fmessage, format, file);
+ xsignal1 (Qerror, CALLN (Fformat_message, format, Vload_file_name));
}
}
@@ -1062,14 +1070,15 @@ This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */)
return Fnreverse (lst);
}
-/* Returns true if STRING ends with SUFFIX */
+/* Return true if STRING ends with SUFFIX. */
static bool
suffix_p (Lisp_Object string, const char *suffix)
{
ptrdiff_t suffix_len = strlen (suffix);
ptrdiff_t string_len = SBYTES (string);
- return string_len >= suffix_len && !strcmp (SSDATA (string) + string_len - suffix_len, suffix);
+ return (suffix_len <= string_len
+ && strcmp (SSDATA (string) + string_len - suffix_len, suffix) == 0);
}
static void
@@ -1129,7 +1138,7 @@ Return t if the file exists and loads successfully. */)
(Lisp_Object file, Lisp_Object noerror, Lisp_Object nomessage,
Lisp_Object nosuffix, Lisp_Object must_suffix)
{
- FILE *stream;
+ FILE *stream UNINIT;
int fd;
int fd_index UNINIT;
ptrdiff_t count = SPECPDL_INDEX ();
@@ -1254,8 +1263,9 @@ Return t if the file exists and loads successfully. */)
}
#ifdef HAVE_MODULES
- if (suffix_p (found, MODULES_SUFFIX))
- return unbind_to (count, Fmodule_load (found));
+ bool is_module = suffix_p (found, MODULES_SUFFIX);
+#else
+ bool is_module = false;
#endif
/* Check if we're stuck in a recursive load cycle.
@@ -1292,10 +1302,6 @@ Return t if the file exists and loads successfully. */)
version = -1;
- /* Check for the presence of old-style quotes and warn about them. */
- specbind (Qlread_old_style_backquotes, Qnil);
- record_unwind_protect (load_warn_old_style_backquotes, file);
-
/* Check for the presence of unescaped character literals and warn
about them. */
specbind (Qlread_unescaped_character_literals, Qnil);
@@ -1352,7 +1358,7 @@ Return t if the file exists and loads successfully. */)
if (!NILP (nomessage) && !force_load_messages)
{
Lisp_Object msg_file;
- msg_file = Fsubstring (found, make_number (0), make_number (-1));
+ msg_file = Fsubstring (found, make_fixnum (0), make_fixnum (-1));
message_with_string ("Source file `%s' newer than byte-compiled file",
msg_file, 1);
}
@@ -1360,7 +1366,7 @@ Return t if the file exists and loads successfully. */)
} /* !load_prefer_newer */
}
}
- else
+ else if (!is_module)
{
/* We are loading a source file (*.el). */
if (!NILP (Vload_source_file_function))
@@ -1387,7 +1393,7 @@ Return t if the file exists and loads successfully. */)
stream = NULL;
errno = EINVAL;
}
- else
+ else if (!is_module)
{
#ifdef WINDOWSNT
emacs_close (fd);
@@ -1398,9 +1404,23 @@ Return t if the file exists and loads successfully. */)
stream = fdopen (fd, fmode);
#endif
}
- if (! stream)
- report_file_error ("Opening stdio stream", file);
- set_unwind_protect_ptr (fd_index, close_infile_unwind, stream);
+
+ if (is_module)
+ {
+ /* `module-load' uses the file name, so we can close the stream
+ now. */
+ if (fd >= 0)
+ {
+ emacs_close (fd);
+ clear_unwind_protect (fd_index);
+ }
+ }
+ else
+ {
+ if (! stream)
+ report_file_error ("Opening stdio stream", file);
+ set_unwind_protect_ptr (fd_index, close_infile_unwind, stream);
+ }
if (! NILP (Vpurify_flag))
Vpreloaded_file_list = Fcons (Fpurecopy (file), Vpreloaded_file_list);
@@ -1410,6 +1430,8 @@ Return t if the file exists and loads successfully. */)
if (!safe_p)
message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...",
file, 1);
+ else if (is_module)
+ message_with_string ("Loading %s (module)...", file, 1);
else if (!compiled)
message_with_string ("Loading %s (source)...", file, 1);
else if (newer)
@@ -1423,24 +1445,39 @@ Return t if the file exists and loads successfully. */)
specbind (Qinhibit_file_name_operation, Qnil);
specbind (Qload_in_progress, Qt);
- struct infile input;
- input.stream = stream;
- input.lookahead = 0;
- infile = &input;
-
- if (lisp_file_lexically_bound_p (Qget_file_char))
- Fset (Qlexical_binding, Qt);
-
- if (! version || version >= 22)
- readevalloop (Qget_file_char, &input, hist_file_name,
- 0, Qnil, Qnil, Qnil, Qnil);
+ if (is_module)
+ {
+#ifdef HAVE_MODULES
+ specbind (Qcurrent_load_list, Qnil);
+ LOADHIST_ATTACH (found);
+ Fmodule_load (found);
+ build_load_history (found, true);
+#else
+ /* This cannot happen. */
+ emacs_abort ();
+#endif
+ }
else
{
- /* We can't handle a file which was compiled with
- byte-compile-dynamic by older version of Emacs. */
- specbind (Qload_force_doc_strings, Qt);
- readevalloop (Qget_emacs_mule_file_char, &input, hist_file_name,
- 0, Qnil, Qnil, Qnil, Qnil);
+ struct infile input;
+ input.stream = stream;
+ input.lookahead = 0;
+ infile = &input;
+
+ if (lisp_file_lexically_bound_p (Qget_file_char))
+ Fset (Qlexical_binding, Qt);
+
+ if (! version || version >= 22)
+ readevalloop (Qget_file_char, &input, hist_file_name,
+ 0, Qnil, Qnil, Qnil, Qnil);
+ else
+ {
+ /* We can't handle a file which was compiled with
+ byte-compile-dynamic by older version of Emacs. */
+ specbind (Qload_force_doc_strings, Qt);
+ readevalloop (Qget_emacs_mule_file_char, &input, hist_file_name,
+ 0, Qnil, Qnil, Qnil, Qnil);
+ }
}
unbind_to (count, Qnil);
@@ -1461,6 +1498,8 @@ Return t if the file exists and loads successfully. */)
if (!safe_p)
message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...done",
file, 1);
+ else if (is_module)
+ message_with_string ("Loading %s (module)...done", file, 1);
else if (!compiled)
message_with_string ("Loading %s (source)...done", file, 1);
else if (newer)
@@ -1563,188 +1602,193 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes,
absolute = complete_filename_p (str);
- for (; CONSP (path); path = XCDR (path))
- {
- ptrdiff_t baselen, prefixlen;
+ /* Go through all entries in the path and see whether we find the
+ executable. */
+ do {
+ ptrdiff_t baselen, prefixlen;
+ if (NILP (path))
+ filename = str;
+ else
filename = Fexpand_file_name (str, XCAR (path));
- if (!complete_filename_p (filename))
- /* If there are non-absolute elts in PATH (eg "."). */
- /* Of course, this could conceivably lose if luser sets
- default-directory to be something non-absolute... */
- {
- filename = Fexpand_file_name (filename, BVAR (current_buffer, directory));
- if (!complete_filename_p (filename))
- /* Give up on this path element! */
- continue;
- }
+ if (!complete_filename_p (filename))
+ /* If there are non-absolute elts in PATH (eg "."). */
+ /* Of course, this could conceivably lose if luser sets
+ default-directory to be something non-absolute... */
+ {
+ filename = Fexpand_file_name (filename, BVAR (current_buffer, directory));
+ if (!complete_filename_p (filename))
+ /* Give up on this path element! */
+ continue;
+ }
- /* Calculate maximum length of any filename made from
- this path element/specified file name and any possible suffix. */
- want_length = max_suffix_len + SBYTES (filename);
- if (fn_size <= want_length)
- {
- fn_size = 100 + want_length;
- fn = SAFE_ALLOCA (fn_size);
- }
+ /* Calculate maximum length of any filename made from
+ this path element/specified file name and any possible suffix. */
+ want_length = max_suffix_len + SBYTES (filename);
+ if (fn_size <= want_length)
+ {
+ fn_size = 100 + want_length;
+ fn = SAFE_ALLOCA (fn_size);
+ }
- /* Copy FILENAME's data to FN but remove starting /: if any. */
- prefixlen = ((SCHARS (filename) > 2
- && SREF (filename, 0) == '/'
- && SREF (filename, 1) == ':')
- ? 2 : 0);
- baselen = SBYTES (filename) - prefixlen;
- memcpy (fn, SDATA (filename) + prefixlen, baselen);
-
- /* Loop over suffixes. */
- for (tail = NILP (suffixes) ? list1 (empty_unibyte_string) : suffixes;
- CONSP (tail); tail = XCDR (tail))
- {
- Lisp_Object suffix = XCAR (tail);
- ptrdiff_t fnlen, lsuffix = SBYTES (suffix);
- Lisp_Object handler;
-
- /* Make complete filename by appending SUFFIX. */
- memcpy (fn + baselen, SDATA (suffix), lsuffix + 1);
- fnlen = baselen + lsuffix;
-
- /* Check that the file exists and is not a directory. */
- /* We used to only check for handlers on non-absolute file names:
- if (absolute)
- handler = Qnil;
- else
- handler = Ffind_file_name_handler (filename, Qfile_exists_p);
- It's not clear why that was the case and it breaks things like
- (load "/bar.el") where the file is actually "/bar.el.gz". */
- /* make_string has its own ideas on when to return a unibyte
- string and when a multibyte string, but we know better.
- We must have a unibyte string when dumping, since
- file-name encoding is shaky at best at that time, and in
- particular default-file-name-coding-system is reset
- several times during loadup. We therefore don't want to
- encode the file before passing it to file I/O library
- functions. */
- if (!STRING_MULTIBYTE (filename) && !STRING_MULTIBYTE (suffix))
- string = make_unibyte_string (fn, fnlen);
- else
- string = make_string (fn, fnlen);
- handler = Ffind_file_name_handler (string, Qfile_exists_p);
- if ((!NILP (handler) || (!NILP (predicate) && !EQ (predicate, Qt)))
- && !NATNUMP (predicate))
- {
- bool exists;
- if (NILP (predicate) || EQ (predicate, Qt))
- exists = !NILP (Ffile_readable_p (string));
- else
- {
- Lisp_Object tmp = call1 (predicate, string);
- if (NILP (tmp))
+ /* Copy FILENAME's data to FN but remove starting /: if any. */
+ prefixlen = ((SCHARS (filename) > 2
+ && SREF (filename, 0) == '/'
+ && SREF (filename, 1) == ':')
+ ? 2 : 0);
+ baselen = SBYTES (filename) - prefixlen;
+ memcpy (fn, SDATA (filename) + prefixlen, baselen);
+
+ /* Loop over suffixes. */
+ for (tail = NILP (suffixes) ? list1 (empty_unibyte_string) : suffixes;
+ CONSP (tail); tail = XCDR (tail))
+ {
+ Lisp_Object suffix = XCAR (tail);
+ ptrdiff_t fnlen, lsuffix = SBYTES (suffix);
+ Lisp_Object handler;
+
+ /* Make complete filename by appending SUFFIX. */
+ memcpy (fn + baselen, SDATA (suffix), lsuffix + 1);
+ fnlen = baselen + lsuffix;
+
+ /* Check that the file exists and is not a directory. */
+ /* We used to only check for handlers on non-absolute file names:
+ if (absolute)
+ handler = Qnil;
+ else
+ handler = Ffind_file_name_handler (filename, Qfile_exists_p);
+ It's not clear why that was the case and it breaks things like
+ (load "/bar.el") where the file is actually "/bar.el.gz". */
+ /* make_string has its own ideas on when to return a unibyte
+ string and when a multibyte string, but we know better.
+ We must have a unibyte string when dumping, since
+ file-name encoding is shaky at best at that time, and in
+ particular default-file-name-coding-system is reset
+ several times during loadup. We therefore don't want to
+ encode the file before passing it to file I/O library
+ functions. */
+ if (!STRING_MULTIBYTE (filename) && !STRING_MULTIBYTE (suffix))
+ string = make_unibyte_string (fn, fnlen);
+ else
+ string = make_string (fn, fnlen);
+ handler = Ffind_file_name_handler (string, Qfile_exists_p);
+ if ((!NILP (handler) || (!NILP (predicate) && !EQ (predicate, Qt)))
+ && !FIXNATP (predicate))
+ {
+ bool exists;
+ if (NILP (predicate) || EQ (predicate, Qt))
+ exists = !NILP (Ffile_readable_p (string));
+ else
+ {
+ Lisp_Object tmp = call1 (predicate, string);
+ if (NILP (tmp))
+ exists = false;
+ else if (EQ (tmp, Qdir_ok)
+ || NILP (Ffile_directory_p (string)))
+ exists = true;
+ else
+ {
exists = false;
- else if (EQ (tmp, Qdir_ok)
- || NILP (Ffile_directory_p (string)))
- exists = true;
- else
- {
- exists = false;
- last_errno = EISDIR;
- }
- }
+ last_errno = EISDIR;
+ }
+ }
- if (exists)
- {
- /* We succeeded; return this descriptor and filename. */
- if (storeptr)
- *storeptr = string;
- SAFE_FREE ();
- return -2;
- }
- }
- else
- {
- int fd;
- const char *pfn;
- struct stat st;
+ if (exists)
+ {
+ /* We succeeded; return this descriptor and filename. */
+ if (storeptr)
+ *storeptr = string;
+ SAFE_FREE ();
+ return -2;
+ }
+ }
+ else
+ {
+ int fd;
+ const char *pfn;
+ struct stat st;
- encoded_fn = ENCODE_FILE (string);
- pfn = SSDATA (encoded_fn);
+ encoded_fn = ENCODE_FILE (string);
+ pfn = SSDATA (encoded_fn);
- /* Check that we can access or open it. */
- if (NATNUMP (predicate))
- {
- fd = -1;
- if (INT_MAX < XFASTINT (predicate))
- last_errno = EINVAL;
- else if (faccessat (AT_FDCWD, pfn, XFASTINT (predicate),
- AT_EACCESS)
- == 0)
- {
- if (file_directory_p (pfn))
- last_errno = EISDIR;
- else
- fd = 1;
- }
- }
- else
- {
- fd = emacs_open (pfn, O_RDONLY, 0);
- if (fd < 0)
- {
- if (errno != ENOENT)
- last_errno = errno;
- }
- else
- {
- int err = (fstat (fd, &st) != 0 ? errno
- : S_ISDIR (st.st_mode) ? EISDIR : 0);
- if (err)
- {
- last_errno = err;
- emacs_close (fd);
- fd = -1;
- }
- }
- }
+ /* Check that we can access or open it. */
+ if (FIXNATP (predicate))
+ {
+ fd = -1;
+ if (INT_MAX < XFIXNAT (predicate))
+ last_errno = EINVAL;
+ else if (faccessat (AT_FDCWD, pfn, XFIXNAT (predicate),
+ AT_EACCESS)
+ == 0)
+ {
+ if (file_directory_p (encoded_fn))
+ last_errno = EISDIR;
+ else
+ fd = 1;
+ }
+ }
+ else
+ {
+ fd = emacs_open (pfn, O_RDONLY, 0);
+ if (fd < 0)
+ {
+ if (errno != ENOENT)
+ last_errno = errno;
+ }
+ else
+ {
+ int err = (fstat (fd, &st) != 0 ? errno
+ : S_ISDIR (st.st_mode) ? EISDIR : 0);
+ if (err)
+ {
+ last_errno = err;
+ emacs_close (fd);
+ fd = -1;
+ }
+ }
+ }
- if (fd >= 0)
- {
- if (newer && !NATNUMP (predicate))
- {
- struct timespec mtime = get_stat_mtime (&st);
+ if (fd >= 0)
+ {
+ if (newer && !FIXNATP (predicate))
+ {
+ struct timespec mtime = get_stat_mtime (&st);
- if (timespec_cmp (mtime, save_mtime) <= 0)
- emacs_close (fd);
- else
- {
- if (0 <= save_fd)
- emacs_close (save_fd);
- save_fd = fd;
- save_mtime = mtime;
- save_string = string;
- }
- }
- else
- {
- /* We succeeded; return this descriptor and filename. */
- if (storeptr)
- *storeptr = string;
- SAFE_FREE ();
- return fd;
- }
- }
+ if (timespec_cmp (mtime, save_mtime) <= 0)
+ emacs_close (fd);
+ else
+ {
+ if (0 <= save_fd)
+ emacs_close (save_fd);
+ save_fd = fd;
+ save_mtime = mtime;
+ save_string = string;
+ }
+ }
+ else
+ {
+ /* We succeeded; return this descriptor and filename. */
+ if (storeptr)
+ *storeptr = string;
+ SAFE_FREE ();
+ return fd;
+ }
+ }
- /* No more suffixes. Return the newest. */
- if (0 <= save_fd && ! CONSP (XCDR (tail)))
- {
- if (storeptr)
- *storeptr = save_string;
- SAFE_FREE ();
- return save_fd;
- }
- }
- }
- if (absolute)
- break;
- }
+ /* No more suffixes. Return the newest. */
+ if (0 <= save_fd && ! CONSP (XCDR (tail)))
+ {
+ if (storeptr)
+ *storeptr = save_string;
+ SAFE_FREE ();
+ return save_fd;
+ }
+ }
+ }
+ if (absolute || NILP (path))
+ break;
+ path = XCDR (path);
+ } while (CONSP (path));
SAFE_FREE ();
errno = last_errno;
@@ -1889,13 +1933,10 @@ readevalloop (Lisp_Object readcharfun,
Lisp_Object macroexpand = intern ("internal-macroexpand-for-load");
if (NILP (Ffboundp (macroexpand))
- /* Don't macroexpand in .elc files, since it should have been done
- already. We actually don't know whether we're in a .elc file or not,
- so we use circumstantial evidence: .el files normally go through
- Vload_source_file_function -> load-with-code-conversion
- -> eval-buffer. */
- || EQ (readcharfun, Qget_file_char)
- || EQ (readcharfun, Qget_emacs_mule_file_char))
+ || (STRINGP (sourcename) && suffix_p (sourcename, ".elc")))
+ /* Don't macroexpand before the corresponding function is defined
+ and don't bother macroexpanding in .elc files, since it should have
+ been done already. */
macroexpand = Qnil;
if (MARKERP (readcharfun))
@@ -1927,7 +1968,7 @@ readevalloop (Lisp_Object readcharfun,
? Qnil : list1 (Qt)));
/* Try to ensure sourcename is a truename, except whilst preloading. */
- if (NILP (Vpurify_flag)
+ if (!will_dump_p ()
&& !NILP (sourcename) && !NILP (Ffile_name_absolute_p (sourcename))
&& !NILP (Ffboundp (Qfile_truename)))
sourcename = call1 (Qfile_truename, sourcename) ;
@@ -1945,11 +1986,11 @@ readevalloop (Lisp_Object readcharfun,
if (!NILP (start))
{
/* Switch to the buffer we are reading from. */
- record_unwind_protect (save_excursion_restore, save_excursion_save ());
+ record_unwind_protect_excursion ();
set_buffer_internal (b);
/* Save point in it. */
- record_unwind_protect (save_excursion_restore, save_excursion_save ());
+ record_unwind_protect_excursion ();
/* Save ZV in it. */
record_unwind_protect (save_restriction_restore, save_restriction_save ());
/* Those get unbound after we read one expression. */
@@ -1957,11 +1998,11 @@ readevalloop (Lisp_Object readcharfun,
/* Set point and ZV around stuff to be read. */
Fgoto_char (start);
if (!NILP (end))
- Fnarrow_to_region (make_number (BEGV), end);
+ Fnarrow_to_region (make_fixnum (BEGV), end);
/* Just for cleanliness, convert END to a marker
if it is an integer. */
- if (INTEGERP (end))
+ if (FIXNUMP (end))
end = Fpoint_max_marker ();
}
@@ -2106,15 +2147,13 @@ This function preserves the position of point. */)
specbind (Qeval_buffer_list, Fcons (buf, Veval_buffer_list));
specbind (Qstandard_output, tem);
- record_unwind_protect (save_excursion_restore, save_excursion_save ());
+ record_unwind_protect_excursion ();
BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf)));
specbind (Qlexical_binding, lisp_file_lexically_bound_p (buf) ? Qt : Qnil);
BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf)));
readevalloop (buf, 0, filename,
!NILP (printflag), unibyte, Qnil, Qnil, Qnil);
- unbind_to (count, Qnil);
-
- return Qnil;
+ return unbind_to (count, Qnil);
}
DEFUN ("eval-region", Feval_region, Seval_region, 2, 4, "r",
@@ -2193,7 +2232,7 @@ the end of STRING. */)
CHECK_STRING (string);
/* `read_internal_start' sets `read_from_string_index'. */
ret = read_internal_start (string, start, end);
- return Fcons (ret, make_number (read_from_string_index));
+ return Fcons (ret, make_fixnum (read_from_string_index));
}
/* Function to set up the global context we need in toplevel read
@@ -2204,7 +2243,7 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end)
Lisp_Object retval;
readchar_count = 0;
- new_backquote_flag = 0;
+ new_backquote_flag = force_new_style_backquotes;
/* We can get called from readevalloop which may have set these
already. */
if (! HASH_TABLE_P (read_objects_map)
@@ -2279,7 +2318,7 @@ read0 (Lisp_Object readcharfun)
return val;
xsignal1 (Qinvalid_read_syntax,
- Fmake_string (make_number (1), make_number (c)));
+ Fmake_string (make_fixnum (1), make_fixnum (c), Qnil));
}
/* Grow a read buffer BUF that contains OFFSET useful bytes of data,
@@ -2313,20 +2352,22 @@ character_name_to_code (char const *name, ptrdiff_t name_len)
{
/* For "U+XXXX", pass the leading '+' to string_to_number to reject
monstrosities like "U+-0000". */
+ ptrdiff_t len = name_len - 1;
Lisp_Object code
= (name[0] == 'U' && name[1] == '+'
- ? string_to_number (name + 1, 16, false)
+ ? string_to_number (name + 1, 16, &len)
: call2 (Qchar_from_name, make_unibyte_string (name, name_len), Qt));
- if (! RANGED_INTEGERP (0, code, MAX_UNICODE_CHAR)
- || char_surrogate_p (XINT (code)))
+ if (! RANGED_FIXNUMP (0, code, MAX_UNICODE_CHAR)
+ || len != name_len - 1
+ || char_surrogate_p (XFIXNUM (code)))
{
AUTO_STRING (format, "\\N{%s}");
AUTO_STRING_WITH_LEN (namestr, name, name_len);
xsignal1 (Qinvalid_read_syntax, CALLN (Fformat, format, namestr));
}
- return XINT (code);
+ return XFIXNUM (code);
}
/* Bound on the length of a Unicode character name. As of
@@ -2550,7 +2591,7 @@ read_escape (Lisp_Object readcharfun, bool stringp)
AUTO_STRING (format,
"Invalid character U+%04X in character name");
xsignal1 (Qinvalid_read_syntax,
- CALLN (Fformat, format, make_natnum (c)));
+ CALLN (Fformat, format, make_fixed_natnum (c)));
}
/* Treat multiple adjacent whitespace characters as a
single space character. This makes it easier to use
@@ -2602,6 +2643,13 @@ digit_to_number (int character, int base)
return digit < base ? digit : -1;
}
+static void
+free_contents (void *p)
+{
+ void **ptr = (void **) p;
+ xfree (*ptr);
+}
+
/* Read an integer in radix RADIX using READCHARFUN to read
characters. RADIX must be in the interval [2..36]; if it isn't, a
read error is signaled . Value is the integer read. Signals an
@@ -2611,20 +2659,26 @@ digit_to_number (int character, int base)
static Lisp_Object
read_integer (Lisp_Object readcharfun, EMACS_INT radix)
{
- /* Room for sign, leading 0, other digits, trailing null byte.
+ /* Room for sign, leading 0, other digits, trailing NUL byte.
Also, room for invalid syntax diagnostic. */
- char buf[max (1 + 1 + UINTMAX_WIDTH + 1,
- sizeof "integer, radix " + INT_STRLEN_BOUND (EMACS_INT))];
-
+ size_t len = max (1 + 1 + UINTMAX_WIDTH + 1,
+ sizeof "integer, radix " + INT_STRLEN_BOUND (EMACS_INT));
+ char *buf = NULL;
+ char *p = buf;
int valid = -1; /* 1 if valid, 0 if not, -1 if incomplete. */
+ ptrdiff_t count = SPECPDL_INDEX ();
+
if (radix < 2 || radix > 36)
valid = 0;
else
{
- char *p = buf;
int c, digit;
+ buf = xmalloc (len);
+ record_unwind_protect_ptr (free_contents, &buf);
+ p = buf;
+
c = READCHAR;
if (c == '-' || c == '+')
{
@@ -2650,17 +2704,19 @@ read_integer (Lisp_Object readcharfun, EMACS_INT radix)
valid = 0;
if (valid < 0)
valid = 1;
-
- if (p < buf + sizeof buf - 1)
- *p++ = c;
- else
- valid = 0;
-
+ /* Allow 1 extra byte for the \0. */
+ if (p + 1 == buf + len)
+ {
+ ptrdiff_t where = p - buf;
+ len *= 2;
+ buf = xrealloc (buf, len);
+ p = buf + where;
+ }
+ *p++ = c;
c = READCHAR;
}
UNREAD (c);
- *p = '\0';
}
if (valid != 1)
@@ -2669,7 +2725,8 @@ read_integer (Lisp_Object readcharfun, EMACS_INT radix)
invalid_syntax (buf);
}
- return string_to_number (buf, radix, 0);
+ *p = '\0';
+ return unbind_to (count, string_to_number (buf, radix, 0));
}
@@ -2734,9 +2791,9 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
if (!EQ (head, Qhash_table))
{
- ptrdiff_t size = XINT (Flength (tmp));
+ ptrdiff_t size = XFIXNUM (Flength (tmp));
Lisp_Object record = Fmake_record (CAR_SAFE (tmp),
- make_number (size - 1),
+ make_fixnum (size - 1),
Qnil);
for (int i = 1; i < size; i++)
{
@@ -2821,24 +2878,24 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
/* Sub char-table can't be read as a regular
vector because of a two C integer fields. */
Lisp_Object tbl, tmp = read_list (1, readcharfun);
- ptrdiff_t size = XINT (Flength (tmp));
+ ptrdiff_t size = list_length (tmp);
int i, depth, min_char;
struct Lisp_Cons *cell;
if (size == 0)
error ("Zero-sized sub char-table");
- if (! RANGED_INTEGERP (1, XCAR (tmp), 3))
+ if (! RANGED_FIXNUMP (1, XCAR (tmp), 3))
error ("Invalid depth in sub char-table");
- depth = XINT (XCAR (tmp));
+ depth = XFIXNUM (XCAR (tmp));
if (chartab_size[depth] != size - 2)
error ("Invalid size in sub char-table");
cell = XCONS (tmp), tmp = XCDR (tmp), size--;
free_cons (cell);
- if (! RANGED_INTEGERP (0, XCAR (tmp), MAX_CHAR))
+ if (! RANGED_FIXNUMP (0, XCAR (tmp), MAX_CHAR))
error ("Invalid minimum character in sub-char-table");
- min_char = XINT (XCAR (tmp));
+ min_char = XFIXNUM (XCAR (tmp));
cell = XCONS (tmp), tmp = XCDR (tmp), size--;
free_cons (cell);
@@ -2863,7 +2920,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
if (c == '"')
{
Lisp_Object tmp, val;
- EMACS_INT size_in_chars = bool_vector_bytes (XFASTINT (length));
+ EMACS_INT size_in_chars = bool_vector_bytes (XFIXNAT (length));
unsigned char *data;
UNREAD (c);
@@ -2874,17 +2931,17 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
when the number of bits was a multiple of 8.
Accept such input in case it came from an old
version. */
- && ! (XFASTINT (length)
+ && ! (XFIXNAT (length)
== (SCHARS (tmp) - 1) * BOOL_VECTOR_BITS_PER_CHAR)))
invalid_syntax ("#&...");
- val = make_uninit_bool_vector (XFASTINT (length));
+ val = make_uninit_bool_vector (XFIXNAT (length));
data = bool_vector_uchar_data (val);
memcpy (data, SDATA (tmp), size_in_chars);
/* Clear the extraneous bits in the last byte. */
- if (XINT (length) != size_in_chars * BOOL_VECTOR_BITS_PER_CHAR)
+ if (XFIXNUM (length) != size_in_chars * BOOL_VECTOR_BITS_PER_CHAR)
data[size_in_chars - 1]
- &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
+ &= (1 << (XFIXNUM (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
return val;
}
invalid_syntax ("#&...");
@@ -3097,7 +3154,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
struct Lisp_Hash_Table *h
= XHASH_TABLE (read_objects_map);
EMACS_UINT hash;
- Lisp_Object number = make_number (n);
+ Lisp_Object number = make_fixnum (n);
ptrdiff_t i = hash_lookup (h, number, &hash);
if (i >= 0)
@@ -3148,7 +3205,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
{
struct Lisp_Hash_Table *h
= XHASH_TABLE (read_objects_map);
- ptrdiff_t i = hash_lookup (h, make_number (n), NULL);
+ ptrdiff_t i = hash_lookup (h, make_fixnum (n), NULL);
if (i >= 0)
return HASH_VALUE (h, i);
}
@@ -3188,10 +3245,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
first_in_list exception (old-style can still be obtained via
"(\`" anyway). */
if (!new_backquote_flag && first_in_list && next_char == ' ')
- {
- Vlread_old_style_backquotes = Qt;
- goto default_label;
- }
+ load_error_old_style_backquotes ();
else
{
Lisp_Object value;
@@ -3242,10 +3296,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
return list2 (comma_type, value);
}
else
- {
- Vlread_old_style_backquotes = Qt;
- goto default_label;
- }
+ load_error_old_style_backquotes ();
}
case '?':
{
@@ -3262,13 +3313,13 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
Other literal whitespace like NL, CR, and FF are not accepted,
as there are well-established escape sequences for these. */
if (c == ' ' || c == '\t')
- return make_number (c);
+ return make_fixnum (c);
if (c == '(' || c == ')' || c == '[' || c == ']'
|| c == '"' || c == ';')
{
CHECK_LIST (Vlread_unescaped_character_literals);
- Lisp_Object char_obj = make_natnum (c);
+ Lisp_Object char_obj = make_fixed_natnum (c);
if (NILP (Fmemq (char_obj, Vlread_unescaped_character_literals)))
Vlread_unescaped_character_literals =
Fcons (char_obj, Vlread_unescaped_character_literals);
@@ -3288,7 +3339,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
&& strchr ("\"';()[]#?`,.", next_char) != NULL));
UNREAD (next_char);
if (ok)
- return make_number (c);
+ return make_fixnum (c);
invalid_syntax ("?");
}
@@ -3397,7 +3448,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
return zero instead. This is for doc strings
that we are really going to find in etc/DOC.nn.nn. */
if (!NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel)
- return unbind_to (count, make_number (0));
+ return unbind_to (count, make_fixnum (0));
if (! force_multibyte && force_singlebyte)
{
@@ -3433,7 +3484,6 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
row. */
FALLTHROUGH;
default:
- default_label:
if (c <= 040) goto retry;
if (c == NO_BREAK_SPACE)
goto retry;
@@ -3481,17 +3531,25 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
|| strchr ("\"';()[]#`,", c) == NULL));
*p = 0;
+ ptrdiff_t nbytes = p - read_buffer;
UNREAD (c);
if (!quoted && !uninterned_symbol)
{
- Lisp_Object result = string_to_number (read_buffer, 10, 0);
- if (! NILP (result))
+ ptrdiff_t len;
+ Lisp_Object result = string_to_number (read_buffer, 10, &len);
+ if (! NILP (result) && len == nbytes)
return unbind_to (count, result);
}
+ if (!quoted && multibyte)
+ {
+ int ch = STRING_CHAR ((unsigned char *) read_buffer);
+ if (confusable_symbol_character_p (ch))
+ xsignal2 (Qinvalid_read_syntax, build_string ("strange quote"),
+ CALLN (Fstring, make_fixnum (ch)));
+ }
{
Lisp_Object result;
- ptrdiff_t nbytes = p - read_buffer;
ptrdiff_t nchars
= (multibyte
? multibyte_chars_in_text ((unsigned char *) read_buffer,
@@ -3530,7 +3588,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
if (EQ (Vread_with_symbol_positions, Qt)
|| EQ (Vread_with_symbol_positions, readcharfun))
Vread_symbol_positions_list
- = Fcons (Fcons (result, make_number (start_position)),
+ = Fcons (Fcons (result, make_fixnum (start_position)),
Vread_symbol_positions_list);
return unbind_to (count, result);
}
@@ -3571,7 +3629,7 @@ substitute_object_recurse (struct subst *subst, Lisp_Object subtree)
return subtree;
/* If we've been to this node before, don't explore it again. */
- if (!EQ (Qnil, Fmemq (subtree, subst->seen)))
+ if (!NILP (Fmemq (subtree, subst->seen)))
return subtree;
/* If this node can be the entry point to a cycle, remember that
@@ -3643,27 +3701,27 @@ substitute_in_interval (INTERVAL interval, void *arg)
}
-/* Convert STRING to a number, assuming base BASE. Return a fixnum if
- STRING has integer syntax and fits in a fixnum, else return the
- nearest float if STRING has either floating point or integer syntax
- and BASE is 10, else return nil. If IGNORE_TRAILING, consider just
- the longest prefix of STRING that has valid floating point syntax.
- Signal an overflow if BASE is not 10 and the number has integer
- syntax but does not fit. */
+/* Convert the initial prefix of STRING to a number, assuming base BASE.
+ If the prefix has floating point syntax and BASE is 10, return a
+ nearest float; otherwise, if the prefix has integer syntax, return
+ the integer; otherwise, return nil. If PLEN, set *PLEN to the
+ length of the numeric prefix if there is one, otherwise *PLEN is
+ unspecified. */
Lisp_Object
-string_to_number (char const *string, int base, bool ignore_trailing)
+string_to_number (char const *string, int base, ptrdiff_t *plen)
{
char const *cp = string;
- bool float_syntax = 0;
+ bool float_syntax = false;
double value = 0;
/* Negate the value ourselves. This treats 0, NaNs, and infinity properly on
IEEE floating point hosts, and works around a formerly-common bug where
atof ("-0.0") drops the sign. */
bool negative = *cp == '-';
+ bool positive = *cp == '+';
- bool signedp = negative || *cp == '+';
+ bool signedp = negative | positive;
cp += signedp;
enum { INTOVERFLOW = 1, LEAD_INT = 2, DOT_CHAR = 4, TRAIL_INT = 8,
@@ -3684,6 +3742,7 @@ string_to_number (char const *string, int base, bool ignore_trailing)
n += digit;
}
}
+ char const *after_digits = cp;
if (*cp == '.')
{
state |= DOT_CHAR;
@@ -3712,6 +3771,7 @@ string_to_number (char const *string, int base, bool ignore_trailing)
cp++;
while ('0' <= *cp && *cp <= '9');
}
+#if IEEE_FLOATING_POINT
else if (cp[-1] == '+'
&& cp[0] == 'I' && cp[1] == 'N' && cp[2] == 'F')
{
@@ -3724,9 +3784,12 @@ string_to_number (char const *string, int base, bool ignore_trailing)
{
state |= E_EXP;
cp += 3;
- /* NAN is a "positive" NaN on all known Emacs hosts. */
- value = NAN;
+ union ieee754_double u
+ = { .ieee_nan = { .exponent = -1, .quiet_nan = 1,
+ .mantissa0 = n >> 31 >> 1, .mantissa1 = n }};
+ value = u.d;
}
+#endif
else
cp = ecp;
}
@@ -3735,63 +3798,62 @@ string_to_number (char const *string, int base, bool ignore_trailing)
|| (state & ~INTOVERFLOW) == (LEAD_INT|E_EXP));
}
- /* Return nil if the number uses invalid syntax. If IGNORE_TRAILING, accept
- any prefix that matches. Otherwise, the entire string must match. */
- if (! (ignore_trailing
- ? ((state & LEAD_INT) != 0 || float_syntax)
- : (!*cp && ((state & ~(INTOVERFLOW | DOT_CHAR)) == LEAD_INT
- || float_syntax))))
- return Qnil;
+ if (plen)
+ *plen = cp - string;
- /* If the number uses integer and not float syntax, and is in C-language
- range, use its value, preferably as a fixnum. */
- if (leading_digit >= 0 && ! float_syntax)
+ /* Return a float if the number uses float syntax. */
+ if (float_syntax)
{
- if (state & INTOVERFLOW)
- {
- /* Unfortunately there's no simple and accurate way to convert
- non-base-10 numbers that are out of C-language range. */
- if (base != 10)
- xsignal1 (Qoverflow_error, build_string (string));
- }
- else if (n <= (negative ? -MOST_NEGATIVE_FIXNUM : MOST_POSITIVE_FIXNUM))
- {
- EMACS_INT signed_n = n;
- return make_number (negative ? -signed_n : signed_n);
- }
- else
- value = n;
+ /* Convert to floating point, unless the value is already known
+ because it is infinite or a NaN. */
+ if (! value)
+ value = atof (string + signedp);
+ return make_float (negative ? -value : value);
}
- /* Either the number uses float syntax, or it does not fit into a fixnum.
- Convert it from string to floating point, unless the value is already
- known because it is an infinity, a NAN, or its absolute value fits in
- uintmax_t. */
- if (! value)
- value = atof (string + signedp);
+ /* Return nil if the number uses invalid syntax. */
+ if (! (state & LEAD_INT))
+ return Qnil;
- return make_float (negative ? -value : value);
+ /* Fast path if the integer (san sign) fits in uintmax_t. */
+ if (! (state & INTOVERFLOW))
+ {
+ if (!negative)
+ return make_uint (n);
+ if (-MOST_NEGATIVE_FIXNUM < n)
+ return make_neg_biguint (n);
+ EMACS_INT signed_n = n;
+ return make_fixnum (-signed_n);
+ }
+
+ /* Trim any leading "+" and trailing nondigits, then return a bignum. */
+ string += positive;
+ if (!*after_digits)
+ return make_bignum_str (string, base);
+ ptrdiff_t trimmed_len = after_digits - string;
+ USE_SAFE_ALLOCA;
+ char *trimmed = SAFE_ALLOCA (trimmed_len + 1);
+ memcpy (trimmed, string, trimmed_len);
+ trimmed[trimmed_len] = '\0';
+ Lisp_Object result = make_bignum_str (trimmed, base);
+ SAFE_FREE ();
+ return result;
}
static Lisp_Object
read_vector (Lisp_Object readcharfun, bool bytecodeflag)
{
- ptrdiff_t i, size;
- Lisp_Object *ptr;
- Lisp_Object tem, item, vector;
- struct Lisp_Cons *otem;
- Lisp_Object len;
-
- tem = read_list (1, readcharfun);
- len = Flength (tem);
- vector = Fmake_vector (len, Qnil);
-
- size = ASIZE (vector);
- ptr = XVECTOR (vector)->contents;
- for (i = 0; i < size; i++)
+ Lisp_Object tem = read_list (1, readcharfun);
+ ptrdiff_t size = list_length (tem);
+ if (bytecodeflag && size <= COMPILED_STACK_DEPTH)
+ error ("Invalid byte code");
+ Lisp_Object vector = make_nil_vector (size);
+
+ Lisp_Object *ptr = XVECTOR (vector)->contents;
+ for (ptrdiff_t i = 0; i < size; i++)
{
- item = Fcar (tem);
+ Lisp_Object item = Fcar (tem);
/* If `load-force-doc-strings' is t when reading a lazily-loaded
bytecode object, the docstring containing the bytecode and
constants values must be treated as unibyte and passed to
@@ -3825,7 +3887,7 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag)
if (!CONSP (item))
error ("Invalid byte code");
- otem = XCONS (item);
+ struct Lisp_Cons *otem = XCONS (item);
bytestr = XCAR (item);
item = XCDR (item);
free_cons (otem);
@@ -3845,7 +3907,7 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag)
}
}
ASET (vector, i, item);
- otem = XCONS (tem);
+ struct Lisp_Cons *otem = XCONS (tem);
tem = Fcdr (tem);
free_cons (otem);
}
@@ -3925,8 +3987,8 @@ read_list (bool flag, Lisp_Object readcharfun)
if (ch == ')')
{
if (doc_reference == 1)
- return make_number (0);
- if (doc_reference == 2 && INTEGERP (XCDR (val)))
+ return make_fixnum (0);
+ if (doc_reference == 2 && FIXNUMP (XCDR (val)))
{
char *saved = NULL;
file_offset saved_position;
@@ -3941,7 +4003,7 @@ read_list (bool flag, Lisp_Object readcharfun)
multibyte. */
/* Position is negative for user variables. */
- EMACS_INT pos = eabs (XINT (XCDR (val)));
+ EMACS_INT pos = eabs (XFIXNUM (XCDR (val)));
if (pos >= saved_doc_string_position
&& pos < (saved_doc_string_position
+ saved_doc_string_length))
@@ -4046,7 +4108,7 @@ intern_sym (Lisp_Object sym, Lisp_Object obarray, Lisp_Object index)
SET_SYMBOL_VAL (XSYMBOL (sym), sym);
}
- ptr = aref_addr (obarray, XINT (index));
+ ptr = aref_addr (obarray, XFIXNUM (index));
set_symbol_next (sym, SYMBOLP (*ptr) ? XSYMBOL (*ptr) : NULL);
*ptr = sym;
return sym;
@@ -4104,7 +4166,7 @@ define_symbol (Lisp_Object sym, char const *str)
if (! EQ (sym, Qunbound))
{
Lisp_Object bucket = oblookup (initial_obarray, str, len, len);
- eassert (INTEGERP (bucket));
+ eassert (FIXNUMP (bucket));
intern_sym (sym, initial_obarray, bucket);
}
}
@@ -4150,7 +4212,7 @@ it defaults to the value of `obarray'. */)
string = SYMBOL_NAME (name);
tem = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string));
- if (INTEGERP (tem) || (SYMBOLP (name) && !EQ (name, tem)))
+ if (FIXNUMP (tem) || (SYMBOLP (name) && !EQ (name, tem)))
return Qnil;
else
return tem;
@@ -4182,7 +4244,7 @@ usage: (unintern NAME OBARRAY) */)
tem = oblookup (obarray, SSDATA (string),
SCHARS (string),
SBYTES (string));
- if (INTEGERP (tem))
+ if (FIXNUMP (tem))
return Qnil;
/* If arg was a symbol, don't delete anything but that symbol itself. */
if (SYMBOLP (name) && !EQ (name, tem))
@@ -4192,7 +4254,7 @@ usage: (unintern NAME OBARRAY) */)
session if we unintern them, as well as even more ways to use
`setq' or `fset' or whatnot to make the Emacs session
unusable. Let's not go down this silly road. --Stef */
- /* if (EQ (tem, Qnil) || EQ (tem, Qt))
+ /* if (NILP (tem) || EQ (tem, Qt))
error ("Attempt to unintern t or nil"); */
XSYMBOL (tem)->u.s.interned = SYMBOL_UNINTERNED;
@@ -4208,7 +4270,7 @@ usage: (unintern NAME OBARRAY) */)
ASET (obarray, hash, sym);
}
else
- ASET (obarray, hash, make_number (0));
+ ASET (obarray, hash, make_fixnum (0));
}
else
{
@@ -4251,7 +4313,7 @@ oblookup (Lisp_Object obarray, register const char *ptr, ptrdiff_t size, ptrdiff
hash = hash_string (ptr, size_byte) % obsize;
bucket = AREF (obarray, hash);
oblookup_last_bucket_number = hash;
- if (EQ (bucket, make_number (0)))
+ if (EQ (bucket, make_fixnum (0)))
;
else if (!SYMBOLP (bucket))
error ("Bad data in guts of obarray"); /* Like CADR error message. */
@@ -4310,9 +4372,9 @@ OBARRAY defaults to the value of `obarray'. */)
#define OBARRAY_SIZE 15121
void
-init_obarray (void)
+init_obarray_once (void)
{
- Vobarray = Fmake_vector (make_number (OBARRAY_SIZE), make_number (0));
+ Vobarray = make_vector (OBARRAY_SIZE, make_fixnum (0));
initial_obarray = Vobarray;
staticpro (&initial_obarray);
@@ -4331,15 +4393,17 @@ init_obarray (void)
make_symbol_constant (Qt);
XSYMBOL (Qt)->u.s.declared_special = true;
- /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
+ /* Qt is correct even if not dumping. loadup.el will set to nil at end. */
Vpurify_flag = Qt;
DEFSYM (Qvariable_documentation, "variable-documentation");
}
+
void
-defsubr (struct Lisp_Subr *sname)
+defsubr (union Aligned_Lisp_Subr *aname)
{
+ struct Lisp_Subr *sname = &aname->s;
Lisp_Object sym, tem;
sym = intern_c_string (sname->symbol_name);
XSETPVECTYPE (sname, PVEC_SUBR);
@@ -4358,34 +4422,25 @@ defalias (struct Lisp_Subr *sname, char *string)
#endif /* NOTDEF */
/* Define an "integer variable"; a symbol whose value is forwarded to a
- C variable of type EMACS_INT. Sample call (with "xx" to fool make-docfile):
+ C variable of type intmax_t. Sample call (with "xx" to fool make-docfile):
DEFxxVAR_INT ("emacs-priority", &emacs_priority, "Documentation"); */
void
-defvar_int (struct Lisp_Intfwd *i_fwd,
- const char *namestring, EMACS_INT *address)
+defvar_int (struct Lisp_Intfwd const *i_fwd, char const *namestring)
{
- Lisp_Object sym;
- sym = intern_c_string (namestring);
- i_fwd->type = Lisp_Fwd_Int;
- i_fwd->intvar = address;
+ Lisp_Object sym = intern_c_string (namestring);
XSYMBOL (sym)->u.s.declared_special = true;
XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
- SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)i_fwd);
+ SET_SYMBOL_FWD (XSYMBOL (sym), i_fwd);
}
-/* Similar but define a variable whose value is t if address contains 1,
- nil if address contains 0. */
+/* Similar but define a variable whose value is t if 1, nil if 0. */
void
-defvar_bool (struct Lisp_Boolfwd *b_fwd,
- const char *namestring, bool *address)
+defvar_bool (struct Lisp_Boolfwd const *b_fwd, char const *namestring)
{
- Lisp_Object sym;
- sym = intern_c_string (namestring);
- b_fwd->type = Lisp_Fwd_Bool;
- b_fwd->boolvar = address;
+ Lisp_Object sym = intern_c_string (namestring);
XSYMBOL (sym)->u.s.declared_special = true;
XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
- SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)b_fwd);
+ SET_SYMBOL_FWD (XSYMBOL (sym), b_fwd);
Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars);
}
@@ -4395,40 +4450,31 @@ defvar_bool (struct Lisp_Boolfwd *b_fwd,
gc-marked for some other reason, since marking the same slot twice
can cause trouble with strings. */
void
-defvar_lisp_nopro (struct Lisp_Objfwd *o_fwd,
- const char *namestring, Lisp_Object *address)
+defvar_lisp_nopro (struct Lisp_Objfwd const *o_fwd, char const *namestring)
{
- Lisp_Object sym;
- sym = intern_c_string (namestring);
- o_fwd->type = Lisp_Fwd_Obj;
- o_fwd->objvar = address;
+ Lisp_Object sym = intern_c_string (namestring);
XSYMBOL (sym)->u.s.declared_special = true;
XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
- SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)o_fwd);
+ SET_SYMBOL_FWD (XSYMBOL (sym), o_fwd);
}
void
-defvar_lisp (struct Lisp_Objfwd *o_fwd,
- const char *namestring, Lisp_Object *address)
+defvar_lisp (struct Lisp_Objfwd const *o_fwd, char const *namestring)
{
- defvar_lisp_nopro (o_fwd, namestring, address);
- staticpro (address);
+ defvar_lisp_nopro (o_fwd, namestring);
+ staticpro (o_fwd->objvar);
}
/* Similar but define a variable whose value is the Lisp Object stored
at a particular offset in the current kboard object. */
void
-defvar_kboard (struct Lisp_Kboard_Objfwd *ko_fwd,
- const char *namestring, int offset)
+defvar_kboard (struct Lisp_Kboard_Objfwd const *ko_fwd, char const *namestring)
{
- Lisp_Object sym;
- sym = intern_c_string (namestring);
- ko_fwd->type = Lisp_Fwd_Kboard_Obj;
- ko_fwd->offset = offset;
+ Lisp_Object sym = intern_c_string (namestring);
XSYMBOL (sym)->u.s.declared_special = true;
XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
- SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)ko_fwd);
+ SET_SYMBOL_FWD (XSYMBOL (sym), ko_fwd);
}
/* Check that the elements of lpath exist. */
@@ -4462,11 +4508,9 @@ load_path_check (Lisp_Object lpath)
are running uninstalled.
Uses the following logic:
- If CANNOT_DUMP:
- If Vinstallation_directory is not nil (ie, running uninstalled),
- use PATH_DUMPLOADSEARCH (ie, build path). Else use PATH_LOADSEARCH.
- The remainder is what happens when dumping works:
- If purify-flag (ie dumping) just use PATH_DUMPLOADSEARCH.
+ If !will_dump: Use PATH_LOADSEARCH.
+ The remainder is what happens when dumping is about to happen:
+ If dumping, just use PATH_DUMPLOADSEARCH.
Otherwise use PATH_LOADSEARCH.
If !initialized, then just return PATH_DUMPLOADSEARCH.
@@ -4489,131 +4533,109 @@ load_path_check (Lisp_Object lpath)
static Lisp_Object
load_path_default (void)
{
+ if (will_dump_p ())
+ /* PATH_DUMPLOADSEARCH is the lisp dir in the source directory.
+ We used to add ../lisp (ie the lisp dir in the build
+ directory) at the front here, but that should not be
+ necessary, since in out of tree builds lisp/ is empty, save
+ for Makefile. */
+ return decode_env_path (0, PATH_DUMPLOADSEARCH, 0);
+
Lisp_Object lpath = Qnil;
- const char *normal;
+ const char *normal = PATH_LOADSEARCH;
+ const char *loadpath = NULL;
-#ifdef CANNOT_DUMP
#ifdef HAVE_NS
- const char *loadpath = ns_load_path ();
+ loadpath = ns_load_path ();
#endif
- normal = PATH_LOADSEARCH;
- if (!NILP (Vinstallation_directory)) normal = PATH_DUMPLOADSEARCH;
-
-#ifdef HAVE_NS
lpath = decode_env_path (0, loadpath ? loadpath : normal, 0);
-#else
- lpath = decode_env_path (0, normal, 0);
-#endif
-
-#else /* !CANNOT_DUMP */
-
- normal = NILP (Vpurify_flag) ? PATH_LOADSEARCH : PATH_DUMPLOADSEARCH;
- if (initialized)
+ if (!NILP (Vinstallation_directory))
{
-#ifdef HAVE_NS
- const char *loadpath = ns_load_path ();
- lpath = decode_env_path (0, loadpath ? loadpath : normal, 0);
-#else
- lpath = decode_env_path (0, normal, 0);
-#endif
- if (!NILP (Vinstallation_directory))
+ Lisp_Object tem, tem1;
+
+ /* Add to the path the lisp subdir of the installation
+ dir, if it is accessible. Note: in out-of-tree builds,
+ this directory is empty save for Makefile. */
+ tem = Fexpand_file_name (build_string ("lisp"),
+ Vinstallation_directory);
+ tem1 = Ffile_accessible_directory_p (tem);
+ if (!NILP (tem1))
{
- Lisp_Object tem, tem1;
+ if (NILP (Fmember (tem, lpath)))
+ {
+ /* We are running uninstalled. The default load-path
+ points to the eventual installed lisp directories.
+ We should not use those now, even if they exist,
+ so start over from a clean slate. */
+ lpath = list1 (tem);
+ }
+ }
+ else
+ /* That dir doesn't exist, so add the build-time
+ Lisp dirs instead. */
+ {
+ Lisp_Object dump_path =
+ decode_env_path (0, PATH_DUMPLOADSEARCH, 0);
+ lpath = nconc2 (lpath, dump_path);
+ }
- /* Add to the path the lisp subdir of the installation
- dir, if it is accessible. Note: in out-of-tree builds,
- this directory is empty save for Makefile. */
- tem = Fexpand_file_name (build_string ("lisp"),
+ /* Add site-lisp under the installation dir, if it exists. */
+ if (!no_site_lisp)
+ {
+ tem = Fexpand_file_name (build_string ("site-lisp"),
Vinstallation_directory);
tem1 = Ffile_accessible_directory_p (tem);
if (!NILP (tem1))
{
if (NILP (Fmember (tem, lpath)))
- {
- /* We are running uninstalled. The default load-path
- points to the eventual installed lisp directories.
- We should not use those now, even if they exist,
- so start over from a clean slate. */
- lpath = list1 (tem);
- }
- }
- else
- /* That dir doesn't exist, so add the build-time
- Lisp dirs instead. */
- {
- Lisp_Object dump_path =
- decode_env_path (0, PATH_DUMPLOADSEARCH, 0);
- lpath = nconc2 (lpath, dump_path);
+ lpath = Fcons (tem, lpath);
}
+ }
- /* Add site-lisp under the installation dir, if it exists. */
- if (!no_site_lisp)
- {
- tem = Fexpand_file_name (build_string ("site-lisp"),
- Vinstallation_directory);
- tem1 = Ffile_accessible_directory_p (tem);
- if (!NILP (tem1))
- {
- if (NILP (Fmember (tem, lpath)))
- lpath = Fcons (tem, lpath);
- }
- }
+ /* If Emacs was not built in the source directory,
+ and it is run from where it was built, add to load-path
+ the lisp and site-lisp dirs under that directory. */
- /* If Emacs was not built in the source directory,
- and it is run from where it was built, add to load-path
- the lisp and site-lisp dirs under that directory. */
+ if (NILP (Fequal (Vinstallation_directory, Vsource_directory)))
+ {
+ Lisp_Object tem2;
+
+ tem = Fexpand_file_name (build_string ("src/Makefile"),
+ Vinstallation_directory);
+ tem1 = Ffile_exists_p (tem);
- if (NILP (Fequal (Vinstallation_directory, Vsource_directory)))
+ /* Don't be fooled if they moved the entire source tree
+ AFTER dumping Emacs. If the build directory is indeed
+ different from the source dir, src/Makefile.in and
+ src/Makefile will not be found together. */
+ tem = Fexpand_file_name (build_string ("src/Makefile.in"),
+ Vinstallation_directory);
+ tem2 = Ffile_exists_p (tem);
+ if (!NILP (tem1) && NILP (tem2))
{
- Lisp_Object tem2;
-
- tem = Fexpand_file_name (build_string ("src/Makefile"),
- Vinstallation_directory);
- tem1 = Ffile_exists_p (tem);
-
- /* Don't be fooled if they moved the entire source tree
- AFTER dumping Emacs. If the build directory is indeed
- different from the source dir, src/Makefile.in and
- src/Makefile will not be found together. */
- tem = Fexpand_file_name (build_string ("src/Makefile.in"),
- Vinstallation_directory);
- tem2 = Ffile_exists_p (tem);
- if (!NILP (tem1) && NILP (tem2))
- {
- tem = Fexpand_file_name (build_string ("lisp"),
- Vsource_directory);
+ tem = Fexpand_file_name (build_string ("lisp"),
+ Vsource_directory);
- if (NILP (Fmember (tem, lpath)))
- lpath = Fcons (tem, lpath);
+ if (NILP (Fmember (tem, lpath)))
+ lpath = Fcons (tem, lpath);
- if (!no_site_lisp)
+ if (!no_site_lisp)
+ {
+ tem = Fexpand_file_name (build_string ("site-lisp"),
+ Vsource_directory);
+ tem1 = Ffile_accessible_directory_p (tem);
+ if (!NILP (tem1))
{
- tem = Fexpand_file_name (build_string ("site-lisp"),
- Vsource_directory);
- tem1 = Ffile_accessible_directory_p (tem);
- if (!NILP (tem1))
- {
- if (NILP (Fmember (tem, lpath)))
- lpath = Fcons (tem, lpath);
- }
+ if (NILP (Fmember (tem, lpath)))
+ lpath = Fcons (tem, lpath);
}
}
- } /* Vinstallation_directory != Vsource_directory */
+ }
+ } /* Vinstallation_directory != Vsource_directory */
- } /* if Vinstallation_directory */
- }
- else /* !initialized */
- {
- /* NORMAL refers to PATH_DUMPLOADSEARCH, ie the lisp dir in the
- source directory. We used to add ../lisp (ie the lisp dir in
- the build directory) at the front here, but that should not
- be necessary, since in out of tree builds lisp/ is empty, save
- for Makefile. */
- lpath = decode_env_path (0, normal, 0);
- }
-#endif /* !CANNOT_DUMP */
+ } /* if Vinstallation_directory */
return lpath;
}
@@ -4627,11 +4649,7 @@ init_lread (void)
/* First, set Vload_path. */
/* Ignore EMACSLOADPATH when dumping. */
-#ifdef CANNOT_DUMP
- bool use_loadpath = true;
-#else
- bool use_loadpath = NILP (Vpurify_flag);
-#endif
+ bool use_loadpath = !will_dump_p ();
if (use_loadpath && egetenv ("EMACSLOADPATH"))
{
@@ -4682,7 +4700,7 @@ init_lread (void)
load_path_check (Vload_path);
/* Add the site-lisp directories at the front. */
- if (initialized && !no_site_lisp && PATH_SITELOADSEARCH[0] != '\0')
+ if (!will_dump_p () && !no_site_lisp && PATH_SITELOADSEARCH[0] != '\0')
{
Lisp_Object sitelisp;
sitelisp = decode_env_path (0, PATH_SITELOADSEARCH, 0);
@@ -4898,7 +4916,7 @@ directory. These file names are converted to absolute at startup. */);
If the file loaded had extension `.elc', and the corresponding source file
exists, this variable contains the name of source file, suitable for use
by functions like `custom-save-all' which edit the init file.
-While Emacs loads and evaluates the init file, value is the real name
+While Emacs loads and evaluates any init file, value is the real name
of the file, regardless of whether or not it has the `.elc' extension. */);
Vuser_init_file = Qnil;
@@ -4988,12 +5006,6 @@ variables, this must be set in the first line of a file. */);
doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */);
Veval_buffer_list = Qnil;
- DEFVAR_LISP ("lread--old-style-backquotes", Vlread_old_style_backquotes,
- doc: /* Set to non-nil when `read' encounters an old-style backquote.
-For internal use only. */);
- Vlread_old_style_backquotes = Qnil;
- DEFSYM (Qlread_old_style_backquotes, "lread--old-style-backquotes");
-
DEFVAR_LISP ("lread--unescaped-character-literals",
Vlread_unescaped_character_literals,
doc: /* List of deprecated unescaped character literals encountered by `read'.
@@ -5018,6 +5030,17 @@ Note that if you customize this, obviously it will not affect files
that are loaded before your customizations are read! */);
load_prefer_newer = 0;
+ DEFVAR_BOOL ("force-new-style-backquotes", force_new_style_backquotes,
+ doc: /* Non-nil means to always use the current syntax for backquotes.
+If nil, `load' and `read' raise errors when encountering some
+old-style variants of backquote and comma. If non-nil, these
+constructs are always interpreted as described in the Info node
+`(elisp)Backquotes', even if that interpretation is incompatible with
+previous versions of Emacs. Setting this variable to non-nil makes
+Emacs compatible with the behavior planned for Emacs 28. In Emacs 28,
+this variable will become obsolete. */);
+ force_new_style_backquotes = false;
+
/* Vsource_directory was initialized in init_lread. */
DEFSYM (Qcurrent_load_list, "current-load-list");
diff --git a/src/macfont.m b/src/macfont.m
index 42ebfd3d6b7..59627823fae 100644
--- a/src/macfont.m
+++ b/src/macfont.m
@@ -35,6 +35,7 @@ Original author: YAMAMOTO Mitsuharu
#include "nsterm.h"
#include "macfont.h"
#include "macuvs.h"
+#include "pdumper.h"
#include <libkern/OSByteOrder.h>
@@ -851,7 +852,7 @@ macfont_store_descriptor_attributes (CTFontDescriptorRef desc,
* ((point->y - (point - 1)->y)
/ (point->x - (point - 1)->x)));
FONT_SET_STYLE (spec_or_entity, numeric_traits[i].index,
- make_number (lround (floatval)));
+ make_fixnum (lround (floatval)));
}
}
@@ -864,16 +865,16 @@ macfont_store_descriptor_attributes (CTFontDescriptorRef desc,
cfnumber_get_font_symbolic_traits_value (num, &sym_traits);
spacing = (sym_traits & kCTFontTraitMonoSpace
? FONT_SPACING_MONO : FONT_SPACING_PROPORTIONAL);
- ASET (spec_or_entity, FONT_SPACING_INDEX, make_number (spacing));
+ ASET (spec_or_entity, FONT_SPACING_INDEX, make_fixnum (spacing));
}
CFRelease (dict);
}
num = CTFontDescriptorCopyAttribute (desc, kCTFontSizeAttribute);
if (num && CFNumberGetValue (num, kCFNumberCGFloatType, &floatval))
- ASET (spec_or_entity, FONT_SIZE_INDEX, make_number (floatval));
+ ASET (spec_or_entity, FONT_SIZE_INDEX, make_fixnum (floatval));
else
- ASET (spec_or_entity, FONT_SIZE_INDEX, make_number (0));
+ ASET (spec_or_entity, FONT_SIZE_INDEX, make_fixnum (0));
if (num)
CFRelease (num);
}
@@ -903,21 +904,22 @@ macfont_descriptor_entity (CTFontDescriptorRef desc, Lisp_Object extra,
cfnumber_get_font_symbolic_traits_value (num, &sym_traits);
CFRelease (dict);
}
- if (EQ (AREF (entity, FONT_SIZE_INDEX), make_number (0)))
- ASET (entity, FONT_AVGWIDTH_INDEX, make_number (0));
+ if (EQ (AREF (entity, FONT_SIZE_INDEX), make_fixnum (0)))
+ ASET (entity, FONT_AVGWIDTH_INDEX, make_fixnum (0));
ASET (entity, FONT_EXTRA_INDEX, Fcopy_sequence (extra));
name = CTFontDescriptorCopyAttribute (desc, kCTFontNameAttribute);
font_put_extra (entity, QCfont_entity,
- make_save_ptr_int ((void *) name, sym_traits));
+ Fcons (make_mint_ptr ((void *) name),
+ make_fixnum (sym_traits)));
if (synth_sym_traits & kCTFontTraitItalic)
FONT_SET_STYLE (entity, FONT_SLANT_INDEX,
- make_number (FONT_SLANT_SYNTHETIC_ITALIC));
+ make_fixnum (FONT_SLANT_SYNTHETIC_ITALIC));
if (synth_sym_traits & kCTFontTraitBold)
FONT_SET_STYLE (entity, FONT_WEIGHT_INDEX,
- make_number (FONT_WEIGHT_SYNTHETIC_BOLD));
+ make_fixnum (FONT_WEIGHT_SYNTHETIC_BOLD));
if (synth_sym_traits & kCTFontTraitMonoSpace)
ASET (entity, FONT_SPACING_INDEX,
- make_number (FONT_SPACING_SYNTHETIC_MONO));
+ make_fixnum (FONT_SPACING_SYNTHETIC_MONO));
return entity;
}
@@ -943,8 +945,8 @@ macfont_invalidate_family_cache (void)
{
Lisp_Object value = HASH_VALUE (h, i);
- if (SAVE_VALUEP (value))
- CFRelease (XSAVE_POINTER (value, 0));
+ if (mint_ptrp (value))
+ CFRelease (xmint_pointer (value));
}
macfont_family_cache = Qnil;
}
@@ -962,7 +964,7 @@ macfont_get_family_cache_if_present (Lisp_Object symbol, CFStringRef *string)
{
Lisp_Object value = HASH_VALUE (h, i);
- *string = SAVE_VALUEP (value) ? XSAVE_POINTER (value, 0) : NULL;
+ *string = mint_ptrp (value) ? xmint_pointer (value) : NULL;
return true;
}
@@ -984,13 +986,13 @@ macfont_set_family_cache (Lisp_Object symbol, CFStringRef string)
h = XHASH_TABLE (macfont_family_cache);
i = hash_lookup (h, symbol, &hash);
- value = string ? make_save_ptr ((void *) CFRetain (string)) : Qnil;
+ value = string ? make_mint_ptr ((void *) CFRetain (string)) : Qnil;
if (i >= 0)
{
Lisp_Object old_value = HASH_VALUE (h, i);
- if (SAVE_VALUEP (old_value))
- CFRelease (XSAVE_POINTER (old_value, 0));
+ if (mint_ptrp (old_value))
+ CFRelease (xmint_pointer (old_value));
set_hash_value_slot (h, i, value);
}
else
@@ -1028,12 +1030,12 @@ macfont_handle_font_change_notification (CFNotificationCenterRef center,
static void
macfont_init_font_change_handler (void)
{
- static bool initialized = false;
+ static bool xinitialized = false;
- if (initialized)
+ if (xinitialized)
return;
- initialized = true;
+ xinitialized = true;
CFNotificationCenterAddObserver
(CFNotificationCenterGetLocalCenter (), NULL,
macfont_handle_font_change_notification,
@@ -1441,8 +1443,6 @@ macfont_get_glyph_for_character (struct font *font, UTF32Char c)
CGGlyph *glyphs;
int i, len;
int nrows;
- dispatch_queue_t queue;
- dispatch_group_t group = NULL;
int nkeys;
if (row != 0)
@@ -1647,7 +1647,7 @@ static int macfont_variation_glyphs (struct font *, int c,
unsigned variations[256]);
static void macfont_filter_properties (Lisp_Object, Lisp_Object);
-static struct font_driver const macfont_driver =
+static struct font_driver macfont_driver =
{
.type = LISPSYM_INITIALLY (Qmac_ct),
.get_cache = macfont_get_cache,
@@ -1792,16 +1792,14 @@ macfont_get_open_type_spec (Lisp_Object otf_spec)
spec->nfeatures[0] = spec->nfeatures[1] = 0;
for (i = 0; i < 2 && ! NILP (otf_spec); i++, otf_spec = XCDR (otf_spec))
{
- Lisp_Object len;
-
val = XCAR (otf_spec);
if (NILP (val))
continue;
- len = Flength (val);
+ ptrdiff_t len = list_length (val);
spec->features[i] =
- (min (PTRDIFF_MAX, SIZE_MAX) / sizeof (int) < XINT (len)
+ (min (PTRDIFF_MAX, SIZE_MAX) / sizeof (int) < len
? 0
- : malloc (XINT (len) * sizeof *spec->features[i]));
+ : malloc (len * sizeof *spec->features[i]));
if (! spec->features[i])
{
if (i > 0 && spec->features[0])
@@ -1941,9 +1939,9 @@ macfont_create_attributes_with_spec (Lisp_Object spec)
{
UniChar unichars[2];
CFIndex count =
- macfont_store_utf32char_to_unichars (XFASTINT (XCAR (chars)),
+ macfont_store_utf32char_to_unichars (XFIXNAT (XCAR (chars)),
unichars);
- CFRange range = CFRangeMake (XFASTINT (XCAR (chars)), 1);
+ CFRange range = CFRangeMake (XFIXNAT (XCAR (chars)), 1);
CFStringAppendCharacters (string, unichars, count);
CFCharacterSetAddCharactersInRange (cs, range);
@@ -1982,10 +1980,10 @@ macfont_create_attributes_with_spec (Lisp_Object spec)
for (i = 0; i < ARRAYELTS (numeric_traits); i++)
{
tmp = AREF (spec, numeric_traits[i].index);
- if (INTEGERP (tmp))
+ if (FIXNUMP (tmp))
{
CGPoint *point = numeric_traits[i].points;
- CGFloat floatval = (XINT (tmp) >> 8); // XXX
+ CGFloat floatval = (XFIXNUM (tmp) >> 8); // XXX
CFNumberRef num;
while (point->y < floatval)
@@ -2070,9 +2068,9 @@ macfont_supports_charset_and_languages_p (CTFontDescriptorRef desc,
ptrdiff_t j;
for (j = 0; j < ASIZE (chars); j++)
- if (TYPE_RANGED_INTEGERP (UTF32Char, AREF (chars, j))
+ if (TYPE_RANGED_FIXNUMP (UTF32Char, AREF (chars, j))
&& CFCharacterSetIsLongCharacterMember (desc_charset,
- XFASTINT (AREF (chars, j))))
+ XFIXNAT (AREF (chars, j))))
break;
if (j == ASIZE (chars))
result = false;
@@ -2162,8 +2160,8 @@ macfont_list (struct frame *f, Lisp_Object spec)
languages = CFDictionaryGetValue (attributes, kCTFontLanguagesAttribute);
- if (INTEGERP (AREF (spec, FONT_SPACING_INDEX)))
- spacing = XINT (AREF (spec, FONT_SPACING_INDEX));
+ if (FIXNUMP (AREF (spec, FONT_SPACING_INDEX)))
+ spacing = XFIXNUM (AREF (spec, FONT_SPACING_INDEX));
traits = ((CFMutableDictionaryRef)
CFDictionaryGetValue (attributes, kCTFontTraitsAttribute));
@@ -2507,7 +2505,7 @@ macfont_free_entity (Lisp_Object entity)
{
Lisp_Object val = assq_no_quit (QCfont_entity,
AREF (entity, FONT_EXTRA_INDEX));
- CFStringRef name = XSAVE_POINTER (XCDR (val), 0);
+ CFStringRef name = xmint_pointer (XCAR (XCDR (val)));
block_input ();
CFRelease (name);
@@ -2530,13 +2528,12 @@ macfont_open (struct frame * f, Lisp_Object entity, int pixel_size)
val = assq_no_quit (QCfont_entity, AREF (entity, FONT_EXTRA_INDEX));
if (! CONSP (val)
- || XTYPE (XCDR (val)) != Lisp_Misc
- || XMISCTYPE (XCDR (val)) != Lisp_Misc_Save_Value)
+ || ! CONSP (XCDR (val)))
return Qnil;
- font_name = XSAVE_POINTER (XCDR (val), 0);
- sym_traits = XSAVE_INTEGER (XCDR (val), 1);
+ font_name = xmint_pointer (XCAR (XCDR (val)));
+ sym_traits = XFIXNUM (XCDR (XCDR (val)));
- size = XINT (AREF (entity, FONT_SIZE_INDEX));
+ size = XFIXNUM (AREF (entity, FONT_SIZE_INDEX));
if (size == 0)
size = pixel_size;
@@ -2565,7 +2562,7 @@ macfont_open (struct frame * f, Lisp_Object entity, int pixel_size)
macfont_info->cgfont = CTFontCopyGraphicsFont (macfont, NULL);
val = assq_no_quit (QCdestination, AREF (entity, FONT_EXTRA_INDEX));
- if (CONSP (val) && EQ (XCDR (val), make_number (1)))
+ if (CONSP (val) && EQ (XCDR (val), make_fixnum (1)))
macfont_info->screen_font = mac_screen_font_create_with_name (font_name,
size);
else
@@ -2586,8 +2583,8 @@ macfont_open (struct frame * f, Lisp_Object entity, int pixel_size)
macfont_info->synthetic_bold_p = 1;
if (sym_traits & kCTFontTraitMonoSpace)
macfont_info->spacing = MACFONT_SPACING_MONO;
- else if (INTEGERP (AREF (entity, FONT_SPACING_INDEX))
- && (XINT (AREF (entity, FONT_SPACING_INDEX))
+ else if (FIXNUMP (AREF (entity, FONT_SPACING_INDEX))
+ && (XFIXNUM (AREF (entity, FONT_SPACING_INDEX))
== FONT_SPACING_SYNTHETIC_MONO))
macfont_info->spacing = MACFONT_SPACING_SYNTHETIC_MONO;
if (macfont_info->synthetic_italic_p || macfont_info->synthetic_bold_p)
@@ -2713,7 +2710,7 @@ macfont_has_char (Lisp_Object font, int c)
val = assq_no_quit (QCfont_entity, AREF (font, FONT_EXTRA_INDEX));
val = XCDR (val);
- name = XSAVE_POINTER (val, 0);
+ name = xmint_pointer (XCAR (val));
charset = macfont_get_cf_charset_for_name (name);
}
else
@@ -2994,7 +2991,7 @@ macfont_shape (Lisp_Object lgstring)
if (NILP (lglyph))
{
- lglyph = Fmake_vector (make_number (LGLYPH_SIZE), Qnil);
+ lglyph = make_nil_vector (LGLYPH_SIZE);
LGSTRING_SET_GLYPH (lgstring, i, lglyph);
}
@@ -3046,19 +3043,17 @@ macfont_shape (Lisp_Object lgstring)
wadjust = lround (gl->advance);
if (xoff != 0 || yoff != 0 || wadjust != metrics.width)
{
- Lisp_Object vec;
-
- vec = Fmake_vector (make_number (3), Qnil);
- ASET (vec, 0, make_number (xoff));
- ASET (vec, 1, make_number (yoff));
- ASET (vec, 2, make_number (wadjust));
+ Lisp_Object vec = make_uninit_vector (3);
+ ASET (vec, 0, make_fixnum (xoff));
+ ASET (vec, 1, make_fixnum (yoff));
+ ASET (vec, 2, make_fixnum (wadjust));
LGLYPH_SET_ADJUSTMENT (lglyph, vec);
}
}
unblock_input ();
- return make_number (used);
+ return make_fixnum (used);
}
/* Structures for the UVS subtable (format 14) in the cmap table. */
@@ -4034,12 +4029,14 @@ mac_register_font_driver (struct frame *f)
}
+
+static void syms_of_macfont_for_pdumper (void);
+
void
syms_of_macfont (void)
{
/* Core Text, for macOS. */
DEFSYM (Qmac_ct, "mac-ct");
- register_font_driver (&macfont_driver, NULL);
/* The font property key specifying the font design destination. The
value is an unsigned integer code: 0 for WYSIWYG, and 1 for Video
@@ -4054,4 +4051,18 @@ syms_of_macfont (void)
macfont_family_cache = Qnil;
staticpro (&macfont_family_cache);
+
+ pdumper_do_now_and_after_load (syms_of_macfont_for_pdumper);
+}
+
+static void
+syms_of_macfont_for_pdumper (void)
+{
+ if (dumped_with_pdumper_p ())
+ macfont_family_cache = Qnil;
+ else
+ eassert (NILP (macfont_family_cache));
+
+ macfont_driver.type = Qmac_ct;
+ register_font_driver (&macfont_driver, NULL);
}
diff --git a/src/macros.c b/src/macros.c
index 5f34d4f609c..2d927ffc408 100644
--- a/src/macros.c
+++ b/src/macros.c
@@ -97,9 +97,9 @@ macro before appending to it. */)
for (i = 0; i < len; i++)
{
Lisp_Object c;
- c = Faref (KVAR (current_kboard, Vlast_kbd_macro), make_number (i));
- if (cvt && NATNUMP (c) && (XFASTINT (c) & 0x80))
- XSETFASTINT (c, CHAR_META | (XFASTINT (c) & ~0x80));
+ c = Faref (KVAR (current_kboard, Vlast_kbd_macro), make_fixnum (i));
+ if (cvt && FIXNATP (c) && (XFIXNAT (c) & 0x80))
+ XSETFASTINT (c, CHAR_META | (XFIXNAT (c) & ~0x80));
current_kboard->kbd_macro_buffer[i] = c;
}
@@ -110,7 +110,7 @@ macro before appending to it. */)
for consistency of behavior. */
if (NILP (no_exec))
Fexecute_kbd_macro (KVAR (current_kboard, Vlast_kbd_macro),
- make_number (1), Qnil);
+ make_fixnum (1), Qnil);
message1 ("Appending to kbd macro...");
}
@@ -154,7 +154,7 @@ each iteration of the macro. Iteration stops if LOOPFUNC returns nil. */)
if (NILP (repeat))
XSETFASTINT (repeat, 1);
else
- CHECK_NUMBER (repeat);
+ CHECK_FIXNUM (repeat);
if (!NILP (KVAR (current_kboard, defining_kbd_macro)))
{
@@ -162,11 +162,11 @@ each iteration of the macro. Iteration stops if LOOPFUNC returns nil. */)
message1 ("Keyboard macro defined");
}
- if (XFASTINT (repeat) == 0)
+ if (XFIXNAT (repeat) == 0)
Fexecute_kbd_macro (KVAR (current_kboard, Vlast_kbd_macro), repeat, loopfunc);
- else if (XINT (repeat) > 1)
+ else if (XFIXNUM (repeat) > 1)
{
- XSETINT (repeat, XINT (repeat) - 1);
+ XSETINT (repeat, XFIXNUM (repeat) - 1);
Fexecute_kbd_macro (KVAR (current_kboard, Vlast_kbd_macro),
repeat, loopfunc);
}
@@ -267,7 +267,7 @@ pop_kbd_macro (Lisp_Object info)
Lisp_Object tem;
Vexecuting_kbd_macro = XCAR (info);
tem = XCDR (info);
- executing_kbd_macro_index = XINT (XCAR (tem));
+ integer_to_intmax (XCAR (tem), &executing_kbd_macro_index);
Vreal_this_command = XCDR (tem);
run_hook (Qkbd_macro_termination_hook);
}
@@ -293,7 +293,7 @@ each iteration of the macro. Iteration stops if LOOPFUNC returns nil. */)
if (!NILP (count))
{
count = Fprefix_numeric_value (count);
- repeat = XINT (count);
+ repeat = XFIXNUM (count);
}
final = indirect_function (macro);
@@ -301,7 +301,7 @@ each iteration of the macro. Iteration stops if LOOPFUNC returns nil. */)
error ("Keyboard macros must be strings or vectors");
tem = Fcons (Vexecuting_kbd_macro,
- Fcons (make_number (executing_kbd_macro_index),
+ Fcons (make_int (executing_kbd_macro_index),
Vreal_this_command));
record_unwind_protect (pop_kbd_macro, tem);
diff --git a/src/macuvs.h b/src/macuvs.h
index 679e8fa457a..e83a372df4c 100644
--- a/src/macuvs.h
+++ b/src/macuvs.h
@@ -1,4 +1,5 @@
-/* Automatically generated by uvs.el. */
+/* This file was automatically generated from admin/unidata/IVD_Sequences.txt
+ by the script admin/unidata/uvs.el */
static const unsigned char mac_uvs_table_adobe_japan1_bytes[] =
{
0x00, 0x0e, 0x00, 0x01, 0x1f, 0xb2, 0x00, 0x00,
diff --git a/src/marker.c b/src/marker.c
index 76ec13f01f4..b58051a8c2b 100644
--- a/src/marker.c
+++ b/src/marker.c
@@ -30,7 +30,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
static ptrdiff_t cached_charpos;
static ptrdiff_t cached_bytepos;
static struct buffer *cached_buffer;
-static EMACS_INT cached_modiff;
+static modiff_count cached_modiff;
/* Juanma Barranquero <lekktu@gmail.com> reported ~3x increased
bootstrap time when byte_char_debug_check is enabled; so this
@@ -90,7 +90,7 @@ clear_charpos_cache (struct buffer *b)
#define CONSIDER(CHARPOS, BYTEPOS) \
{ \
ptrdiff_t this_charpos = (CHARPOS); \
- bool changed = 0; \
+ bool changed = false; \
\
if (this_charpos == charpos) \
{ \
@@ -105,14 +105,14 @@ clear_charpos_cache (struct buffer *b)
{ \
best_above = this_charpos; \
best_above_byte = (BYTEPOS); \
- changed = 1; \
+ changed = true; \
} \
} \
else if (this_charpos > best_below) \
{ \
best_below = this_charpos; \
best_below_byte = (BYTEPOS); \
- changed = 1; \
+ changed = true; \
} \
\
if (changed) \
@@ -133,6 +133,28 @@ CHECK_MARKER (Lisp_Object x)
CHECK_TYPE (MARKERP (x), Qmarkerp, x);
}
+/* When converting bytes from/to chars, we look through the list of
+ markers to try and find a good starting point (since markers keep
+ track of both bytepos and charpos at the same time).
+ But if there are many markers, it can take too much time to find a "good"
+ marker from which to start. Worse yet: if it takes a long time and we end
+ up finding a nearby markers, we won't add a new marker to cache this
+ result, so next time around we'll have to go through this same long list
+ to (re)find this best marker. So the further down the list of
+ markers we go, the less demanding we are w.r.t what is a good marker.
+
+ The previous code used INITIAL=50 and INCREMENT=0 and this lead to
+ really poor performance when there are many markers.
+ I haven't tried to tweak INITIAL, but experiments on my trusty Thinkpad
+ T61 using various artificial test cases seem to suggest that INCREMENT=50
+ might be "the best compromise": it significantly improved the
+ worst case and it was rarely slower and never by much.
+
+ The asymptotic behavior is still poor, tho, so in largish buffers with many
+ overlays (e.g. 300KB and 30K overlays), it can still be a bottleneck. */
+#define BYTECHAR_DISTANCE_INITIAL 50
+#define BYTECHAR_DISTANCE_INCREMENT 50
+
/* Return the byte position corresponding to CHARPOS in B. */
ptrdiff_t
@@ -141,6 +163,7 @@ buf_charpos_to_bytepos (struct buffer *b, ptrdiff_t charpos)
struct Lisp_Marker *tail;
ptrdiff_t best_above, best_above_byte;
ptrdiff_t best_below, best_below_byte;
+ ptrdiff_t distance = BYTECHAR_DISTANCE_INITIAL;
eassert (BUF_BEG (b) <= charpos && charpos <= BUF_Z (b));
@@ -180,8 +203,11 @@ buf_charpos_to_bytepos (struct buffer *b, ptrdiff_t charpos)
/* If we are down to a range of 50 chars,
don't bother checking any other markers;
scan the intervening chars directly now. */
- if (best_above - best_below < 50)
+ if (best_above - charpos < distance
+ || charpos - best_below < distance)
break;
+ else
+ distance += BYTECHAR_DISTANCE_INCREMENT;
}
/* We get here if we did not exactly hit one of the known places.
@@ -248,7 +274,7 @@ buf_charpos_to_bytepos (struct buffer *b, ptrdiff_t charpos)
#define CONSIDER(BYTEPOS, CHARPOS) \
{ \
ptrdiff_t this_bytepos = (BYTEPOS); \
- int changed = 0; \
+ int changed = false; \
\
if (this_bytepos == bytepos) \
{ \
@@ -263,14 +289,14 @@ buf_charpos_to_bytepos (struct buffer *b, ptrdiff_t charpos)
{ \
best_above = (CHARPOS); \
best_above_byte = this_bytepos; \
- changed = 1; \
+ changed = true; \
} \
} \
else if (this_bytepos > best_below_byte) \
{ \
best_below = (CHARPOS); \
best_below_byte = this_bytepos; \
- changed = 1; \
+ changed = true; \
} \
\
if (changed) \
@@ -293,6 +319,7 @@ buf_bytepos_to_charpos (struct buffer *b, ptrdiff_t bytepos)
struct Lisp_Marker *tail;
ptrdiff_t best_above, best_above_byte;
ptrdiff_t best_below, best_below_byte;
+ ptrdiff_t distance = BYTECHAR_DISTANCE_INITIAL;
eassert (BUF_BEG_BYTE (b) <= bytepos && bytepos <= BUF_Z_BYTE (b));
@@ -323,8 +350,11 @@ buf_bytepos_to_charpos (struct buffer *b, ptrdiff_t bytepos)
/* If we are down to a range of 50 chars,
don't bother checking any other markers;
scan the intervening chars directly now. */
- if (best_above - best_below < 50)
+ if (best_above - bytepos < distance
+ || bytepos - best_below < distance)
break;
+ else
+ distance += BYTECHAR_DISTANCE_INCREMENT;
}
/* We get here if we did not exactly hit one of the known places.
@@ -417,7 +447,7 @@ DEFUN ("marker-position", Fmarker_position, Smarker_position, 1, 1, 0,
{
CHECK_MARKER (marker);
if (XMARKER (marker)->buffer)
- return make_number (XMARKER (marker)->charpos);
+ return make_fixnum (XMARKER (marker)->charpos);
return Qnil;
}
@@ -491,11 +521,11 @@ set_marker_internal (Lisp_Object marker, Lisp_Object position,
{
register ptrdiff_t charpos, bytepos;
- /* Do not use CHECK_NUMBER_COERCE_MARKER because we
+ /* Do not use CHECK_FIXNUM_COERCE_MARKER because we
don't want to call buf_charpos_to_bytepos if POSITION
is a marker and so we know the bytepos already. */
- if (INTEGERP (position))
- charpos = XINT (position), bytepos = -1;
+ if (FIXNUMP (position))
+ charpos = XFIXNUM (position), bytepos = -1;
else if (MARKERP (position))
{
charpos = XMARKER (position)->charpos;
@@ -682,7 +712,7 @@ see `marker-insertion-type'. */)
register Lisp_Object new;
if (!NILP (marker))
- CHECK_TYPE (INTEGERP (marker) || MARKERP (marker), Qinteger_or_marker_p, marker);
+ CHECK_TYPE (FIXNUMP (marker) || MARKERP (marker), Qinteger_or_marker_p, marker);
new = Fmake_marker ();
Fset_marker (new, marker,
@@ -722,7 +752,7 @@ DEFUN ("buffer-has-markers-at", Fbuffer_has_markers_at, Sbuffer_has_markers_at,
register struct Lisp_Marker *tail;
register ptrdiff_t charpos;
- charpos = clip_to_bounds (BEG, XINT (position), Z);
+ charpos = clip_to_bounds (BEG, XFIXNUM (position), Z);
for (tail = BUF_MARKERS (current_buffer); tail; tail = tail->next)
if (tail->charpos == charpos)
@@ -753,8 +783,8 @@ count_markers (struct buffer *buf)
ptrdiff_t
verify_bytepos (ptrdiff_t charpos)
{
- ptrdiff_t below = 1;
- ptrdiff_t below_byte = 1;
+ ptrdiff_t below = BEG;
+ ptrdiff_t below_byte = BEG_BYTE;
while (below != charpos)
{
diff --git a/src/menu.c b/src/menu.c
index 2ec82a26cd8..7f46e68e73e 100644
--- a/src/menu.c
+++ b/src/menu.c
@@ -60,9 +60,9 @@ have_boxes (void)
Lisp_Object menu_items;
-/* If non-nil, means that the global vars defined here are already in use.
+/* Whether the global vars defined here are already in use.
Used to detect cases where we try to re-enter this non-reentrant code. */
-Lisp_Object menu_items_inuse;
+bool menu_items_inuse;
/* Number of slots currently allocated in menu_items. */
int menu_items_allocated;
@@ -80,16 +80,16 @@ static int menu_items_submenu_depth;
void
init_menu_items (void)
{
- if (!NILP (menu_items_inuse))
+ if (menu_items_inuse)
error ("Trying to use a menu from within a menu-entry");
if (NILP (menu_items))
{
menu_items_allocated = 60;
- menu_items = Fmake_vector (make_number (menu_items_allocated), Qnil);
+ menu_items = make_nil_vector (menu_items_allocated);
}
- menu_items_inuse = Qt;
+ menu_items_inuse = true;
menu_items_used = 0;
menu_items_n_panes = 0;
menu_items_submenu_depth = 0;
@@ -105,7 +105,7 @@ finish_menu_items (void)
void
unuse_menu_items (void)
{
- menu_items_inuse = Qnil;
+ menu_items_inuse = false;
}
/* Call when finished using the data for the current menu
@@ -121,7 +121,7 @@ discard_menu_items (void)
menu_items = Qnil;
menu_items_allocated = 0;
}
- eassert (NILP (menu_items_inuse));
+ eassert (!menu_items_inuse);
}
/* This undoes save_menu_items, and it is called by the specpdl unwind
@@ -131,14 +131,14 @@ static void
restore_menu_items (Lisp_Object saved)
{
menu_items = XCAR (saved);
- menu_items_inuse = (! NILP (menu_items) ? Qt : Qnil);
+ menu_items_inuse = ! NILP (menu_items);
menu_items_allocated = (VECTORP (menu_items) ? ASIZE (menu_items) : 0);
saved = XCDR (saved);
- menu_items_used = XINT (XCAR (saved));
+ menu_items_used = XFIXNUM (XCAR (saved));
saved = XCDR (saved);
- menu_items_n_panes = XINT (XCAR (saved));
+ menu_items_n_panes = XFIXNUM (XCAR (saved));
saved = XCDR (saved);
- menu_items_submenu_depth = XINT (XCAR (saved));
+ menu_items_submenu_depth = XFIXNUM (XCAR (saved));
}
/* Push the whole state of menu_items processing onto the specpdl.
@@ -147,12 +147,12 @@ restore_menu_items (Lisp_Object saved)
void
save_menu_items (void)
{
- Lisp_Object saved = list4 (!NILP (menu_items_inuse) ? menu_items : Qnil,
- make_number (menu_items_used),
- make_number (menu_items_n_panes),
- make_number (menu_items_submenu_depth));
+ Lisp_Object saved = list4 (menu_items_inuse ? menu_items : Qnil,
+ make_fixnum (menu_items_used),
+ make_fixnum (menu_items_n_panes),
+ make_fixnum (menu_items_submenu_depth));
record_unwind_protect (restore_menu_items, saved);
- menu_items_inuse = Qnil;
+ menu_items_inuse = false;
menu_items = Qnil;
}
@@ -170,8 +170,7 @@ ensure_menu_items (int items)
}
}
-#if (defined USE_X_TOOLKIT || defined USE_GTK || defined HAVE_NS \
- || defined HAVE_NTGUI)
+#ifdef HAVE_EXT_MENU_BAR
/* Begin a submenu. */
@@ -195,7 +194,7 @@ push_submenu_end (void)
menu_items_submenu_depth--;
}
-#endif /* USE_X_TOOLKIT || USE_GTK || HAVE_NS || defined HAVE_NTGUI */
+#endif /* HAVE_EXT_MENU_BAR */
/* Indicate boundary between left and right. */
@@ -524,19 +523,15 @@ bool
parse_single_submenu (Lisp_Object item_key, Lisp_Object item_name,
Lisp_Object maps)
{
- Lisp_Object length;
- EMACS_INT len;
Lisp_Object *mapvec;
- ptrdiff_t i;
bool top_level_items = 0;
USE_SAFE_ALLOCA;
- length = Flength (maps);
- len = XINT (length);
+ ptrdiff_t len = list_length (maps);
/* Convert the list MAPS into a vector MAPVEC. */
SAFE_ALLOCA_LISP (mapvec, len);
- for (i = 0; i < len; i++)
+ for (ptrdiff_t i = 0; i < len; i++)
{
mapvec[i] = Fcar (maps);
maps = Fcdr (maps);
@@ -544,7 +539,7 @@ parse_single_submenu (Lisp_Object item_key, Lisp_Object item_name,
/* Loop over the given keymaps, making a pane for each map.
But don't make a pane that is empty--ignore that map instead. */
- for (i = 0; i < len; i++)
+ for (ptrdiff_t i = 0; i < len; i++)
{
if (!KEYMAPP (mapvec[i]))
{
@@ -647,7 +642,7 @@ digest_single_submenu (int start, int end, bool top_level_items)
i = start;
while (i < end)
{
- if (EQ (AREF (menu_items, i), Qnil))
+ if (NILP (AREF (menu_items, i)))
{
submenu_stack[submenu_depth++] = save_wv;
save_wv = prev_wv;
@@ -900,7 +895,7 @@ find_and_call_menu_selection (struct frame *f, int menu_bar_items_used,
while (i < menu_bar_items_used)
{
- if (EQ (AREF (vector, i), Qnil))
+ if (NILP (AREF (vector, i)))
{
subprefix_stack[submenu_depth++] = prefix;
prefix = entry;
@@ -985,7 +980,7 @@ find_and_return_menu_selection (struct frame *f, bool keymaps, void *client_data
while (i < menu_items_used)
{
- if (EQ (AREF (menu_items, i), Qnil))
+ if (NILP (AREF (menu_items, i)))
{
subprefix_stack[submenu_depth++] = prefix;
prefix = entry;
@@ -1079,7 +1074,7 @@ into menu items. */)
if (!FRAME_LIVE_P (f))
return Qnil;
- pixel_to_glyph_coords (f, XINT (x), XINT (y), &col, &row, NULL, 1);
+ pixel_to_glyph_coords (f, XFIXNUM (x), XFIXNUM (y), &col, &row, NULL, 1);
if (0 <= row && row < FRAME_MENU_BAR_LINES (f))
{
Lisp_Object items, item;
@@ -1099,10 +1094,10 @@ into menu items. */)
pos = AREF (items, i + 3);
if (NILP (str))
return item;
- if (XINT (pos) <= col
+ if (XFIXNUM (pos) <= col
/* We use <= so the blank between 2 items on a TTY is
considered part of the previous item. */
- && col <= XINT (pos) + menu_item_width (SDATA (str)))
+ && col <= XFIXNUM (pos) + menu_item_width (SDATA (str)))
{
item = AREF (items, i);
return item;
@@ -1112,51 +1107,8 @@ into menu items. */)
return Qnil;
}
-
-DEFUN ("x-popup-menu", Fx_popup_menu, Sx_popup_menu, 2, 2, 0,
- doc: /* Pop up a deck-of-cards menu and return user's selection.
-POSITION is a position specification. This is either a mouse button event
-or a list ((XOFFSET YOFFSET) WINDOW)
-where XOFFSET and YOFFSET are positions in pixels from the top left
-corner of WINDOW. (WINDOW may be a window or a frame object.)
-This controls the position of the top left of the menu as a whole.
-If POSITION is t, it means to use the current mouse position.
-
-MENU is a specifier for a menu. For the simplest case, MENU is a keymap.
-The menu items come from key bindings that have a menu string as well as
-a definition; actually, the "definition" in such a key binding looks like
-\(STRING . REAL-DEFINITION). To give the menu a title, put a string into
-the keymap as a top-level element.
-
-If REAL-DEFINITION is nil, that puts a nonselectable string in the menu.
-Otherwise, REAL-DEFINITION should be a valid key binding definition.
-
-You can also use a list of keymaps as MENU.
- Then each keymap makes a separate pane.
-
-When MENU is a keymap or a list of keymaps, the return value is the
-list of events corresponding to the user's choice. Note that
-`x-popup-menu' does not actually execute the command bound to that
-sequence of events.
-
-Alternatively, you can specify a menu of multiple panes
- with a list of the form (TITLE PANE1 PANE2...),
-where each pane is a list of form (TITLE ITEM1 ITEM2...).
-Each ITEM is normally a cons cell (STRING . VALUE);
-but a string can appear as an item--that makes a nonselectable line
-in the menu.
-With this form of menu, the return value is VALUE from the chosen item.
-
-If POSITION is nil, don't display the menu at all, just precalculate the
-cached information about equivalent key sequences.
-
-If the user gets rid of the menu without making a valid choice, for
-instance by clicking the mouse away from a valid choice or by typing
-keyboard input, then this normally results in a quit and
-`x-popup-menu' does not return. But if POSITION is a mouse button
-event (indicating that the user invoked the menu with the mouse) then
-no quit occurs and `x-popup-menu' returns nil. */)
- (Lisp_Object position, Lisp_Object menu)
+Lisp_Object
+x_popup_menu_1 (Lisp_Object position, Lisp_Object menu)
{
Lisp_Object keymap, tem, tem2;
int xpos = 0, ypos = 0;
@@ -1195,7 +1147,7 @@ no quit occurs and `x-popup-menu' returns nil. */)
else
{
menuflags |= MENU_FOR_CLICK;
- tem = Fcar (Fcdr (position)); /* EVENT_START (position) */
+ tem = Fcar (XCDR (position)); /* EVENT_START (position) */
window = Fcar (tem); /* POSN_WINDOW (tem) */
tem2 = Fcar (Fcdr (tem)); /* POSN_POSN (tem) */
/* The MENU_KBD_NAVIGATION field is set when the menu
@@ -1211,7 +1163,7 @@ no quit occurs and `x-popup-menu' returns nil. */)
event. */
if (!EQ (POSN_POSN (last_nonmenu_event),
POSN_POSN (position))
- && CONSP (tem2) && EQ (Fcar (tem2), Qmenu_bar))
+ && CONSP (tem2) && EQ (XCAR (tem2), Qmenu_bar))
menuflags |= MENU_KBD_NAVIGATION;
tem = Fcar (Fcdr (Fcdr (tem))); /* POSN_WINDOW_POSN (tem) */
x = Fcar (tem);
@@ -1245,9 +1197,9 @@ no quit occurs and `x-popup-menu' returns nil. */)
int cur_x, cur_y;
x_relative_mouse_position (new_f, &cur_x, &cur_y);
- /* cur_x/y may be negative, so use make_number. */
- x = make_number (cur_x);
- y = make_number (cur_y);
+ /* cur_x/y may be negative, so use make_fixnum. */
+ x = make_fixnum (cur_x);
+ y = make_fixnum (cur_y);
}
}
else
@@ -1311,8 +1263,8 @@ no quit occurs and `x-popup-menu' returns nil. */)
? (EMACS_INT) INT_MIN - ypos
: MOST_NEGATIVE_FIXNUM),
INT_MAX - ypos);
- xpos += XINT (x);
- ypos += XINT (y);
+ xpos += XFIXNUM (x);
+ ypos += XFIXNUM (y);
XSETFRAME (Vmenu_updating_frame, f);
}
@@ -1352,7 +1304,7 @@ no quit occurs and `x-popup-menu' returns nil. */)
else if (CONSP (menu) && KEYMAPP (XCAR (menu)))
{
/* We were given a list of keymaps. */
- EMACS_INT nmaps = XFASTINT (Flength (menu));
+ ptrdiff_t nmaps = list_length (menu);
Lisp_Object *maps;
ptrdiff_t i;
USE_SAFE_ALLOCA;
@@ -1443,6 +1395,55 @@ no quit occurs and `x-popup-menu' returns nil. */)
return selection;
}
+DEFUN ("x-popup-menu", Fx_popup_menu, Sx_popup_menu, 2, 2, 0,
+ doc: /* Pop up a deck-of-cards menu and return user's selection.
+POSITION is a position specification. This is either a mouse button event
+or a list ((XOFFSET YOFFSET) WINDOW)
+where XOFFSET and YOFFSET are positions in pixels from the top left
+corner of WINDOW. (WINDOW may be a window or a frame object.)
+This controls the position of the top left of the menu as a whole.
+If POSITION is t, it means to use the current mouse position.
+
+MENU is a specifier for a menu. For the simplest case, MENU is a keymap.
+The menu items come from key bindings that have a menu string as well as
+a definition; actually, the "definition" in such a key binding looks like
+\(STRING . REAL-DEFINITION). To give the menu a title, put a string into
+the keymap as a top-level element.
+
+If REAL-DEFINITION is nil, that puts a nonselectable string in the menu.
+Otherwise, REAL-DEFINITION should be a valid key binding definition.
+
+You can also use a list of keymaps as MENU.
+ Then each keymap makes a separate pane.
+
+When MENU is a keymap or a list of keymaps, the return value is the
+list of events corresponding to the user's choice. Note that
+`x-popup-menu' does not actually execute the command bound to that
+sequence of events.
+
+Alternatively, you can specify a menu of multiple panes
+ with a list of the form (TITLE PANE1 PANE2...),
+where each pane is a list of form (TITLE ITEM1 ITEM2...).
+Each ITEM is normally a cons cell (STRING . VALUE);
+but a string can appear as an item--that makes a nonselectable line
+in the menu.
+With this form of menu, the return value is VALUE from the chosen item.
+
+If POSITION is nil, don't display the menu at all, just precalculate the
+cached information about equivalent key sequences.
+
+If the user gets rid of the menu without making a valid choice, for
+instance by clicking the mouse away from a valid choice or by typing
+keyboard input, then this normally results in a quit and
+`x-popup-menu' does not return. But if POSITION is a mouse button
+event (indicating that the user invoked the menu with the mouse) then
+no quit occurs and `x-popup-menu' returns nil. */)
+ (Lisp_Object position, Lisp_Object menu)
+{
+ init_raw_keybuf_count ();
+ return x_popup_menu_1 (position, menu);
+}
+
/* If F's terminal is not capable of displaying a popup dialog,
emulate it with a menu. */
@@ -1574,9 +1575,8 @@ for instance using the window manager, then this produces a quit and
void
syms_of_menu (void)
{
- staticpro (&menu_items);
menu_items = Qnil;
- menu_items_inuse = Qnil;
+ staticpro (&menu_items);
defsubr (&Sx_popup_menu);
defsubr (&Sx_popup_dialog);
diff --git a/src/menu.h b/src/menu.h
index 3b39de2d6e0..0321c27454b 100644
--- a/src/menu.h
+++ b/src/menu.h
@@ -35,8 +35,7 @@ extern void discard_menu_items (void);
extern void save_menu_items (void);
extern bool parse_single_submenu (Lisp_Object, Lisp_Object, Lisp_Object);
extern void list_of_panes (Lisp_Object);
-#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NTGUI) \
- || defined (HAVE_NS)
+#ifdef HAVE_EXT_MENU_BAR
extern void free_menubar_widget_value_tree (widget_value *);
extern void update_submenu_strings (widget_value *);
extern void find_and_call_menu_selection (struct frame *, int,
@@ -60,4 +59,5 @@ extern Lisp_Object ns_menu_show (struct frame *, int, int, int,
extern Lisp_Object tty_menu_show (struct frame *, int, int, int,
Lisp_Object, const char **);
extern ptrdiff_t menu_item_width (const unsigned char *);
+extern Lisp_Object x_popup_menu_1 (Lisp_Object position, Lisp_Object menu);
#endif /* MENU_H */
diff --git a/src/mini-gmp-emacs.c b/src/mini-gmp-emacs.c
new file mode 100644
index 00000000000..051590bf8be
--- /dev/null
+++ b/src/mini-gmp-emacs.c
@@ -0,0 +1,32 @@
+/* Tailor mini-gmp.c for GNU Emacs
+
+Copyright 2018-2019 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#include <stddef.h>
+
+/* Pacify GCC -Wsuggest-attribute=malloc. */
+static void *gmp_default_alloc (size_t) ATTRIBUTE_MALLOC;
+
+/* Pacify GCC -Wunused-variable for variables used only in 'assert' calls. */
+#if defined NDEBUG && GNUC_PREREQ (4, 6, 0)
+# pragma GCC diagnostic ignored "-Wunused-variable"
+#endif
+
+#include "mini-gmp.c"
diff --git a/src/mini-gmp.c b/src/mini-gmp.c
new file mode 100644
index 00000000000..90beb6e8327
--- /dev/null
+++ b/src/mini-gmp.c
@@ -0,0 +1,4452 @@
+/* mini-gmp, a minimalistic implementation of a GNU GMP subset.
+
+ Contributed to the GNU project by Niels Möller
+
+Copyright 1991-1997, 1999-2019 Free Software Foundation, Inc.
+
+This file is part of the GNU MP Library.
+
+The GNU MP Library is free software; you can redistribute it and/or modify
+it under the terms of either:
+
+ * the GNU Lesser General Public License as published by the Free
+ Software Foundation; either version 3 of the License, or (at your
+ option) any later version.
+
+or
+
+ * the GNU General Public License as published by the Free Software
+ Foundation; either version 2 of the License, or (at your option) any
+ later version.
+
+or both in parallel, as here.
+
+The GNU MP 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 copies of the GNU General Public License and the
+GNU Lesser General Public License along with the GNU MP Library. If not,
+see https://www.gnu.org/licenses/. */
+
+/* NOTE: All functions in this file which are not declared in
+ mini-gmp.h are internal, and are not intended to be compatible
+ neither with GMP nor with future versions of mini-gmp. */
+
+/* Much of the material copied from GMP files, including: gmp-impl.h,
+ longlong.h, mpn/generic/add_n.c, mpn/generic/addmul_1.c,
+ mpn/generic/lshift.c, mpn/generic/mul_1.c,
+ mpn/generic/mul_basecase.c, mpn/generic/rshift.c,
+ mpn/generic/sbpi1_div_qr.c, mpn/generic/sub_n.c,
+ mpn/generic/submul_1.c. */
+
+#include <assert.h>
+#include <ctype.h>
+#include <limits.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "mini-gmp.h"
+
+#if !defined(MINI_GMP_DONT_USE_FLOAT_H)
+#include <float.h>
+#endif
+
+
+/* Macros */
+#define GMP_LIMB_BITS (sizeof(mp_limb_t) * CHAR_BIT)
+
+#define GMP_LIMB_MAX (~ (mp_limb_t) 0)
+#define GMP_LIMB_HIGHBIT ((mp_limb_t) 1 << (GMP_LIMB_BITS - 1))
+
+#define GMP_HLIMB_BIT ((mp_limb_t) 1 << (GMP_LIMB_BITS / 2))
+#define GMP_LLIMB_MASK (GMP_HLIMB_BIT - 1)
+
+#define GMP_ULONG_BITS (sizeof(unsigned long) * CHAR_BIT)
+#define GMP_ULONG_HIGHBIT ((unsigned long) 1 << (GMP_ULONG_BITS - 1))
+
+#define GMP_ABS(x) ((x) >= 0 ? (x) : -(x))
+#define GMP_NEG_CAST(T,x) (-((T)((x) + 1) - 1))
+
+#define GMP_MIN(a, b) ((a) < (b) ? (a) : (b))
+#define GMP_MAX(a, b) ((a) > (b) ? (a) : (b))
+
+#define GMP_CMP(a,b) (((a) > (b)) - ((a) < (b)))
+
+#if defined(DBL_MANT_DIG) && FLT_RADIX == 2
+#define GMP_DBL_MANT_BITS DBL_MANT_DIG
+#else
+#define GMP_DBL_MANT_BITS (53)
+#endif
+
+/* Return non-zero if xp,xsize and yp,ysize overlap.
+ If xp+xsize<=yp there's no overlap, or if yp+ysize<=xp there's no
+ overlap. If both these are false, there's an overlap. */
+#define GMP_MPN_OVERLAP_P(xp, xsize, yp, ysize) \
+ ((xp) + (xsize) > (yp) && (yp) + (ysize) > (xp))
+
+#define gmp_assert_nocarry(x) do { \
+ mp_limb_t __cy = (x); \
+ assert (__cy == 0); \
+ } while (0)
+
+#define gmp_clz(count, x) do { \
+ mp_limb_t __clz_x = (x); \
+ unsigned __clz_c; \
+ for (__clz_c = 0; \
+ (__clz_x & ((mp_limb_t) 0xff << (GMP_LIMB_BITS - 8))) == 0; \
+ __clz_c += 8) \
+ __clz_x <<= 8; \
+ for (; (__clz_x & GMP_LIMB_HIGHBIT) == 0; __clz_c++) \
+ __clz_x <<= 1; \
+ (count) = __clz_c; \
+ } while (0)
+
+#define gmp_ctz(count, x) do { \
+ mp_limb_t __ctz_x = (x); \
+ unsigned __ctz_c = 0; \
+ gmp_clz (__ctz_c, __ctz_x & - __ctz_x); \
+ (count) = GMP_LIMB_BITS - 1 - __ctz_c; \
+ } while (0)
+
+#define gmp_add_ssaaaa(sh, sl, ah, al, bh, bl) \
+ do { \
+ mp_limb_t __x; \
+ __x = (al) + (bl); \
+ (sh) = (ah) + (bh) + (__x < (al)); \
+ (sl) = __x; \
+ } while (0)
+
+#define gmp_sub_ddmmss(sh, sl, ah, al, bh, bl) \
+ do { \
+ mp_limb_t __x; \
+ __x = (al) - (bl); \
+ (sh) = (ah) - (bh) - ((al) < (bl)); \
+ (sl) = __x; \
+ } while (0)
+
+#define gmp_umul_ppmm(w1, w0, u, v) \
+ do { \
+ mp_limb_t __x0, __x1, __x2, __x3; \
+ unsigned __ul, __vl, __uh, __vh; \
+ mp_limb_t __u = (u), __v = (v); \
+ \
+ __ul = __u & GMP_LLIMB_MASK; \
+ __uh = __u >> (GMP_LIMB_BITS / 2); \
+ __vl = __v & GMP_LLIMB_MASK; \
+ __vh = __v >> (GMP_LIMB_BITS / 2); \
+ \
+ __x0 = (mp_limb_t) __ul * __vl; \
+ __x1 = (mp_limb_t) __ul * __vh; \
+ __x2 = (mp_limb_t) __uh * __vl; \
+ __x3 = (mp_limb_t) __uh * __vh; \
+ \
+ __x1 += __x0 >> (GMP_LIMB_BITS / 2);/* this can't give carry */ \
+ __x1 += __x2; /* but this indeed can */ \
+ if (__x1 < __x2) /* did we get it? */ \
+ __x3 += GMP_HLIMB_BIT; /* yes, add it in the proper pos. */ \
+ \
+ (w1) = __x3 + (__x1 >> (GMP_LIMB_BITS / 2)); \
+ (w0) = (__x1 << (GMP_LIMB_BITS / 2)) + (__x0 & GMP_LLIMB_MASK); \
+ } while (0)
+
+#define gmp_udiv_qrnnd_preinv(q, r, nh, nl, d, di) \
+ do { \
+ mp_limb_t _qh, _ql, _r, _mask; \
+ gmp_umul_ppmm (_qh, _ql, (nh), (di)); \
+ gmp_add_ssaaaa (_qh, _ql, _qh, _ql, (nh) + 1, (nl)); \
+ _r = (nl) - _qh * (d); \
+ _mask = -(mp_limb_t) (_r > _ql); /* both > and >= are OK */ \
+ _qh += _mask; \
+ _r += _mask & (d); \
+ if (_r >= (d)) \
+ { \
+ _r -= (d); \
+ _qh++; \
+ } \
+ \
+ (r) = _r; \
+ (q) = _qh; \
+ } while (0)
+
+#define gmp_udiv_qr_3by2(q, r1, r0, n2, n1, n0, d1, d0, dinv) \
+ do { \
+ mp_limb_t _q0, _t1, _t0, _mask; \
+ gmp_umul_ppmm ((q), _q0, (n2), (dinv)); \
+ gmp_add_ssaaaa ((q), _q0, (q), _q0, (n2), (n1)); \
+ \
+ /* Compute the two most significant limbs of n - q'd */ \
+ (r1) = (n1) - (d1) * (q); \
+ gmp_sub_ddmmss ((r1), (r0), (r1), (n0), (d1), (d0)); \
+ gmp_umul_ppmm (_t1, _t0, (d0), (q)); \
+ gmp_sub_ddmmss ((r1), (r0), (r1), (r0), _t1, _t0); \
+ (q)++; \
+ \
+ /* Conditionally adjust q and the remainders */ \
+ _mask = - (mp_limb_t) ((r1) >= _q0); \
+ (q) += _mask; \
+ gmp_add_ssaaaa ((r1), (r0), (r1), (r0), _mask & (d1), _mask & (d0)); \
+ if ((r1) >= (d1)) \
+ { \
+ if ((r1) > (d1) || (r0) >= (d0)) \
+ { \
+ (q)++; \
+ gmp_sub_ddmmss ((r1), (r0), (r1), (r0), (d1), (d0)); \
+ } \
+ } \
+ } while (0)
+
+/* Swap macros. */
+#define MP_LIMB_T_SWAP(x, y) \
+ do { \
+ mp_limb_t __mp_limb_t_swap__tmp = (x); \
+ (x) = (y); \
+ (y) = __mp_limb_t_swap__tmp; \
+ } while (0)
+#define MP_SIZE_T_SWAP(x, y) \
+ do { \
+ mp_size_t __mp_size_t_swap__tmp = (x); \
+ (x) = (y); \
+ (y) = __mp_size_t_swap__tmp; \
+ } while (0)
+#define MP_BITCNT_T_SWAP(x,y) \
+ do { \
+ mp_bitcnt_t __mp_bitcnt_t_swap__tmp = (x); \
+ (x) = (y); \
+ (y) = __mp_bitcnt_t_swap__tmp; \
+ } while (0)
+#define MP_PTR_SWAP(x, y) \
+ do { \
+ mp_ptr __mp_ptr_swap__tmp = (x); \
+ (x) = (y); \
+ (y) = __mp_ptr_swap__tmp; \
+ } while (0)
+#define MP_SRCPTR_SWAP(x, y) \
+ do { \
+ mp_srcptr __mp_srcptr_swap__tmp = (x); \
+ (x) = (y); \
+ (y) = __mp_srcptr_swap__tmp; \
+ } while (0)
+
+#define MPN_PTR_SWAP(xp,xs, yp,ys) \
+ do { \
+ MP_PTR_SWAP (xp, yp); \
+ MP_SIZE_T_SWAP (xs, ys); \
+ } while(0)
+#define MPN_SRCPTR_SWAP(xp,xs, yp,ys) \
+ do { \
+ MP_SRCPTR_SWAP (xp, yp); \
+ MP_SIZE_T_SWAP (xs, ys); \
+ } while(0)
+
+#define MPZ_PTR_SWAP(x, y) \
+ do { \
+ mpz_ptr __mpz_ptr_swap__tmp = (x); \
+ (x) = (y); \
+ (y) = __mpz_ptr_swap__tmp; \
+ } while (0)
+#define MPZ_SRCPTR_SWAP(x, y) \
+ do { \
+ mpz_srcptr __mpz_srcptr_swap__tmp = (x); \
+ (x) = (y); \
+ (y) = __mpz_srcptr_swap__tmp; \
+ } while (0)
+
+const int mp_bits_per_limb = GMP_LIMB_BITS;
+
+
+/* Memory allocation and other helper functions. */
+static void
+gmp_die (const char *msg)
+{
+ fprintf (stderr, "%s\n", msg);
+ abort();
+}
+
+static void *
+gmp_default_alloc (size_t size)
+{
+ void *p;
+
+ assert (size > 0);
+
+ p = malloc (size);
+ if (!p)
+ gmp_die("gmp_default_alloc: Virtual memory exhausted.");
+
+ return p;
+}
+
+static void *
+gmp_default_realloc (void *old, size_t old_size, size_t new_size)
+{
+ void * p;
+
+ p = realloc (old, new_size);
+
+ if (!p)
+ gmp_die("gmp_default_realloc: Virtual memory exhausted.");
+
+ return p;
+}
+
+static void
+gmp_default_free (void *p, size_t size)
+{
+ free (p);
+}
+
+static void * (*gmp_allocate_func) (size_t) = gmp_default_alloc;
+static void * (*gmp_reallocate_func) (void *, size_t, size_t) = gmp_default_realloc;
+static void (*gmp_free_func) (void *, size_t) = gmp_default_free;
+
+void
+mp_get_memory_functions (void *(**alloc_func) (size_t),
+ void *(**realloc_func) (void *, size_t, size_t),
+ void (**free_func) (void *, size_t))
+{
+ if (alloc_func)
+ *alloc_func = gmp_allocate_func;
+
+ if (realloc_func)
+ *realloc_func = gmp_reallocate_func;
+
+ if (free_func)
+ *free_func = gmp_free_func;
+}
+
+void
+mp_set_memory_functions (void *(*alloc_func) (size_t),
+ void *(*realloc_func) (void *, size_t, size_t),
+ void (*free_func) (void *, size_t))
+{
+ if (!alloc_func)
+ alloc_func = gmp_default_alloc;
+ if (!realloc_func)
+ realloc_func = gmp_default_realloc;
+ if (!free_func)
+ free_func = gmp_default_free;
+
+ gmp_allocate_func = alloc_func;
+ gmp_reallocate_func = realloc_func;
+ gmp_free_func = free_func;
+}
+
+#define gmp_xalloc(size) ((*gmp_allocate_func)((size)))
+#define gmp_free(p) ((*gmp_free_func) ((p), 0))
+
+static mp_ptr
+gmp_xalloc_limbs (mp_size_t size)
+{
+ return (mp_ptr) gmp_xalloc (size * sizeof (mp_limb_t));
+}
+
+static mp_ptr
+gmp_xrealloc_limbs (mp_ptr old, mp_size_t size)
+{
+ assert (size > 0);
+ return (mp_ptr) (*gmp_reallocate_func) (old, 0, size * sizeof (mp_limb_t));
+}
+
+
+/* MPN interface */
+
+void
+mpn_copyi (mp_ptr d, mp_srcptr s, mp_size_t n)
+{
+ mp_size_t i;
+ for (i = 0; i < n; i++)
+ d[i] = s[i];
+}
+
+void
+mpn_copyd (mp_ptr d, mp_srcptr s, mp_size_t n)
+{
+ while (--n >= 0)
+ d[n] = s[n];
+}
+
+int
+mpn_cmp (mp_srcptr ap, mp_srcptr bp, mp_size_t n)
+{
+ while (--n >= 0)
+ {
+ if (ap[n] != bp[n])
+ return ap[n] > bp[n] ? 1 : -1;
+ }
+ return 0;
+}
+
+static int
+mpn_cmp4 (mp_srcptr ap, mp_size_t an, mp_srcptr bp, mp_size_t bn)
+{
+ if (an != bn)
+ return an < bn ? -1 : 1;
+ else
+ return mpn_cmp (ap, bp, an);
+}
+
+static mp_size_t
+mpn_normalized_size (mp_srcptr xp, mp_size_t n)
+{
+ while (n > 0 && xp[n-1] == 0)
+ --n;
+ return n;
+}
+
+int
+mpn_zero_p(mp_srcptr rp, mp_size_t n)
+{
+ return mpn_normalized_size (rp, n) == 0;
+}
+
+void
+mpn_zero (mp_ptr rp, mp_size_t n)
+{
+ while (--n >= 0)
+ rp[n] = 0;
+}
+
+mp_limb_t
+mpn_add_1 (mp_ptr rp, mp_srcptr ap, mp_size_t n, mp_limb_t b)
+{
+ mp_size_t i;
+
+ assert (n > 0);
+ i = 0;
+ do
+ {
+ mp_limb_t r = ap[i] + b;
+ /* Carry out */
+ b = (r < b);
+ rp[i] = r;
+ }
+ while (++i < n);
+
+ return b;
+}
+
+mp_limb_t
+mpn_add_n (mp_ptr rp, mp_srcptr ap, mp_srcptr bp, mp_size_t n)
+{
+ mp_size_t i;
+ mp_limb_t cy;
+
+ for (i = 0, cy = 0; i < n; i++)
+ {
+ mp_limb_t a, b, r;
+ a = ap[i]; b = bp[i];
+ r = a + cy;
+ cy = (r < cy);
+ r += b;
+ cy += (r < b);
+ rp[i] = r;
+ }
+ return cy;
+}
+
+mp_limb_t
+mpn_add (mp_ptr rp, mp_srcptr ap, mp_size_t an, mp_srcptr bp, mp_size_t bn)
+{
+ mp_limb_t cy;
+
+ assert (an >= bn);
+
+ cy = mpn_add_n (rp, ap, bp, bn);
+ if (an > bn)
+ cy = mpn_add_1 (rp + bn, ap + bn, an - bn, cy);
+ return cy;
+}
+
+mp_limb_t
+mpn_sub_1 (mp_ptr rp, mp_srcptr ap, mp_size_t n, mp_limb_t b)
+{
+ mp_size_t i;
+
+ assert (n > 0);
+
+ i = 0;
+ do
+ {
+ mp_limb_t a = ap[i];
+ /* Carry out */
+ mp_limb_t cy = a < b;
+ rp[i] = a - b;
+ b = cy;
+ }
+ while (++i < n);
+
+ return b;
+}
+
+mp_limb_t
+mpn_sub_n (mp_ptr rp, mp_srcptr ap, mp_srcptr bp, mp_size_t n)
+{
+ mp_size_t i;
+ mp_limb_t cy;
+
+ for (i = 0, cy = 0; i < n; i++)
+ {
+ mp_limb_t a, b;
+ a = ap[i]; b = bp[i];
+ b += cy;
+ cy = (b < cy);
+ cy += (a < b);
+ rp[i] = a - b;
+ }
+ return cy;
+}
+
+mp_limb_t
+mpn_sub (mp_ptr rp, mp_srcptr ap, mp_size_t an, mp_srcptr bp, mp_size_t bn)
+{
+ mp_limb_t cy;
+
+ assert (an >= bn);
+
+ cy = mpn_sub_n (rp, ap, bp, bn);
+ if (an > bn)
+ cy = mpn_sub_1 (rp + bn, ap + bn, an - bn, cy);
+ return cy;
+}
+
+mp_limb_t
+mpn_mul_1 (mp_ptr rp, mp_srcptr up, mp_size_t n, mp_limb_t vl)
+{
+ mp_limb_t ul, cl, hpl, lpl;
+
+ assert (n >= 1);
+
+ cl = 0;
+ do
+ {
+ ul = *up++;
+ gmp_umul_ppmm (hpl, lpl, ul, vl);
+
+ lpl += cl;
+ cl = (lpl < cl) + hpl;
+
+ *rp++ = lpl;
+ }
+ while (--n != 0);
+
+ return cl;
+}
+
+mp_limb_t
+mpn_addmul_1 (mp_ptr rp, mp_srcptr up, mp_size_t n, mp_limb_t vl)
+{
+ mp_limb_t ul, cl, hpl, lpl, rl;
+
+ assert (n >= 1);
+
+ cl = 0;
+ do
+ {
+ ul = *up++;
+ gmp_umul_ppmm (hpl, lpl, ul, vl);
+
+ lpl += cl;
+ cl = (lpl < cl) + hpl;
+
+ rl = *rp;
+ lpl = rl + lpl;
+ cl += lpl < rl;
+ *rp++ = lpl;
+ }
+ while (--n != 0);
+
+ return cl;
+}
+
+mp_limb_t
+mpn_submul_1 (mp_ptr rp, mp_srcptr up, mp_size_t n, mp_limb_t vl)
+{
+ mp_limb_t ul, cl, hpl, lpl, rl;
+
+ assert (n >= 1);
+
+ cl = 0;
+ do
+ {
+ ul = *up++;
+ gmp_umul_ppmm (hpl, lpl, ul, vl);
+
+ lpl += cl;
+ cl = (lpl < cl) + hpl;
+
+ rl = *rp;
+ lpl = rl - lpl;
+ cl += lpl > rl;
+ *rp++ = lpl;
+ }
+ while (--n != 0);
+
+ return cl;
+}
+
+mp_limb_t
+mpn_mul (mp_ptr rp, mp_srcptr up, mp_size_t un, mp_srcptr vp, mp_size_t vn)
+{
+ assert (un >= vn);
+ assert (vn >= 1);
+ assert (!GMP_MPN_OVERLAP_P(rp, un + vn, up, un));
+ assert (!GMP_MPN_OVERLAP_P(rp, un + vn, vp, vn));
+
+ /* We first multiply by the low order limb. This result can be
+ stored, not added, to rp. We also avoid a loop for zeroing this
+ way. */
+
+ rp[un] = mpn_mul_1 (rp, up, un, vp[0]);
+
+ /* Now accumulate the product of up[] and the next higher limb from
+ vp[]. */
+
+ while (--vn >= 1)
+ {
+ rp += 1, vp += 1;
+ rp[un] = mpn_addmul_1 (rp, up, un, vp[0]);
+ }
+ return rp[un];
+}
+
+void
+mpn_mul_n (mp_ptr rp, mp_srcptr ap, mp_srcptr bp, mp_size_t n)
+{
+ mpn_mul (rp, ap, n, bp, n);
+}
+
+void
+mpn_sqr (mp_ptr rp, mp_srcptr ap, mp_size_t n)
+{
+ mpn_mul (rp, ap, n, ap, n);
+}
+
+mp_limb_t
+mpn_lshift (mp_ptr rp, mp_srcptr up, mp_size_t n, unsigned int cnt)
+{
+ mp_limb_t high_limb, low_limb;
+ unsigned int tnc;
+ mp_limb_t retval;
+
+ assert (n >= 1);
+ assert (cnt >= 1);
+ assert (cnt < GMP_LIMB_BITS);
+
+ up += n;
+ rp += n;
+
+ tnc = GMP_LIMB_BITS - cnt;
+ low_limb = *--up;
+ retval = low_limb >> tnc;
+ high_limb = (low_limb << cnt);
+
+ while (--n != 0)
+ {
+ low_limb = *--up;
+ *--rp = high_limb | (low_limb >> tnc);
+ high_limb = (low_limb << cnt);
+ }
+ *--rp = high_limb;
+
+ return retval;
+}
+
+mp_limb_t
+mpn_rshift (mp_ptr rp, mp_srcptr up, mp_size_t n, unsigned int cnt)
+{
+ mp_limb_t high_limb, low_limb;
+ unsigned int tnc;
+ mp_limb_t retval;
+
+ assert (n >= 1);
+ assert (cnt >= 1);
+ assert (cnt < GMP_LIMB_BITS);
+
+ tnc = GMP_LIMB_BITS - cnt;
+ high_limb = *up++;
+ retval = (high_limb << tnc);
+ low_limb = high_limb >> cnt;
+
+ while (--n != 0)
+ {
+ high_limb = *up++;
+ *rp++ = low_limb | (high_limb << tnc);
+ low_limb = high_limb >> cnt;
+ }
+ *rp = low_limb;
+
+ return retval;
+}
+
+static mp_bitcnt_t
+mpn_common_scan (mp_limb_t limb, mp_size_t i, mp_srcptr up, mp_size_t un,
+ mp_limb_t ux)
+{
+ unsigned cnt;
+
+ assert (ux == 0 || ux == GMP_LIMB_MAX);
+ assert (0 <= i && i <= un );
+
+ while (limb == 0)
+ {
+ i++;
+ if (i == un)
+ return (ux == 0 ? ~(mp_bitcnt_t) 0 : un * GMP_LIMB_BITS);
+ limb = ux ^ up[i];
+ }
+ gmp_ctz (cnt, limb);
+ return (mp_bitcnt_t) i * GMP_LIMB_BITS + cnt;
+}
+
+mp_bitcnt_t
+mpn_scan1 (mp_srcptr ptr, mp_bitcnt_t bit)
+{
+ mp_size_t i;
+ i = bit / GMP_LIMB_BITS;
+
+ return mpn_common_scan ( ptr[i] & (GMP_LIMB_MAX << (bit % GMP_LIMB_BITS)),
+ i, ptr, i, 0);
+}
+
+mp_bitcnt_t
+mpn_scan0 (mp_srcptr ptr, mp_bitcnt_t bit)
+{
+ mp_size_t i;
+ i = bit / GMP_LIMB_BITS;
+
+ return mpn_common_scan (~ptr[i] & (GMP_LIMB_MAX << (bit % GMP_LIMB_BITS)),
+ i, ptr, i, GMP_LIMB_MAX);
+}
+
+void
+mpn_com (mp_ptr rp, mp_srcptr up, mp_size_t n)
+{
+ while (--n >= 0)
+ *rp++ = ~ *up++;
+}
+
+mp_limb_t
+mpn_neg (mp_ptr rp, mp_srcptr up, mp_size_t n)
+{
+ while (*up == 0)
+ {
+ *rp = 0;
+ if (!--n)
+ return 0;
+ ++up; ++rp;
+ }
+ *rp = - *up;
+ mpn_com (++rp, ++up, --n);
+ return 1;
+}
+
+
+/* MPN division interface. */
+
+/* The 3/2 inverse is defined as
+
+ m = floor( (B^3-1) / (B u1 + u0)) - B
+*/
+mp_limb_t
+mpn_invert_3by2 (mp_limb_t u1, mp_limb_t u0)
+{
+ mp_limb_t r, p, m, ql;
+ unsigned ul, uh, qh;
+
+ assert (u1 >= GMP_LIMB_HIGHBIT);
+
+ /* For notation, let b denote the half-limb base, so that B = b^2.
+ Split u1 = b uh + ul. */
+ ul = u1 & GMP_LLIMB_MASK;
+ uh = u1 >> (GMP_LIMB_BITS / 2);
+
+ /* Approximation of the high half of quotient. Differs from the 2/1
+ inverse of the half limb uh, since we have already subtracted
+ u0. */
+ qh = ~u1 / uh;
+
+ /* Adjust to get a half-limb 3/2 inverse, i.e., we want
+
+ qh' = floor( (b^3 - 1) / u) - b = floor ((b^3 - b u - 1) / u
+ = floor( (b (~u) + b-1) / u),
+
+ and the remainder
+
+ r = b (~u) + b-1 - qh (b uh + ul)
+ = b (~u - qh uh) + b-1 - qh ul
+
+ Subtraction of qh ul may underflow, which implies adjustments.
+ But by normalization, 2 u >= B > qh ul, so we need to adjust by
+ at most 2.
+ */
+
+ r = ((~u1 - (mp_limb_t) qh * uh) << (GMP_LIMB_BITS / 2)) | GMP_LLIMB_MASK;
+
+ p = (mp_limb_t) qh * ul;
+ /* Adjustment steps taken from udiv_qrnnd_c */
+ if (r < p)
+ {
+ qh--;
+ r += u1;
+ if (r >= u1) /* i.e. we didn't get carry when adding to r */
+ if (r < p)
+ {
+ qh--;
+ r += u1;
+ }
+ }
+ r -= p;
+
+ /* Low half of the quotient is
+
+ ql = floor ( (b r + b-1) / u1).
+
+ This is a 3/2 division (on half-limbs), for which qh is a
+ suitable inverse. */
+
+ p = (r >> (GMP_LIMB_BITS / 2)) * qh + r;
+ /* Unlike full-limb 3/2, we can add 1 without overflow. For this to
+ work, it is essential that ql is a full mp_limb_t. */
+ ql = (p >> (GMP_LIMB_BITS / 2)) + 1;
+
+ /* By the 3/2 trick, we don't need the high half limb. */
+ r = (r << (GMP_LIMB_BITS / 2)) + GMP_LLIMB_MASK - ql * u1;
+
+ if (r >= (p << (GMP_LIMB_BITS / 2)))
+ {
+ ql--;
+ r += u1;
+ }
+ m = ((mp_limb_t) qh << (GMP_LIMB_BITS / 2)) + ql;
+ if (r >= u1)
+ {
+ m++;
+ r -= u1;
+ }
+
+ /* Now m is the 2/1 invers of u1. If u0 > 0, adjust it to become a
+ 3/2 inverse. */
+ if (u0 > 0)
+ {
+ mp_limb_t th, tl;
+ r = ~r;
+ r += u0;
+ if (r < u0)
+ {
+ m--;
+ if (r >= u1)
+ {
+ m--;
+ r -= u1;
+ }
+ r -= u1;
+ }
+ gmp_umul_ppmm (th, tl, u0, m);
+ r += th;
+ if (r < th)
+ {
+ m--;
+ m -= ((r > u1) | ((r == u1) & (tl > u0)));
+ }
+ }
+
+ return m;
+}
+
+struct gmp_div_inverse
+{
+ /* Normalization shift count. */
+ unsigned shift;
+ /* Normalized divisor (d0 unused for mpn_div_qr_1) */
+ mp_limb_t d1, d0;
+ /* Inverse, for 2/1 or 3/2. */
+ mp_limb_t di;
+};
+
+static void
+mpn_div_qr_1_invert (struct gmp_div_inverse *inv, mp_limb_t d)
+{
+ unsigned shift;
+
+ assert (d > 0);
+ gmp_clz (shift, d);
+ inv->shift = shift;
+ inv->d1 = d << shift;
+ inv->di = mpn_invert_limb (inv->d1);
+}
+
+static void
+mpn_div_qr_2_invert (struct gmp_div_inverse *inv,
+ mp_limb_t d1, mp_limb_t d0)
+{
+ unsigned shift;
+
+ assert (d1 > 0);
+ gmp_clz (shift, d1);
+ inv->shift = shift;
+ if (shift > 0)
+ {
+ d1 = (d1 << shift) | (d0 >> (GMP_LIMB_BITS - shift));
+ d0 <<= shift;
+ }
+ inv->d1 = d1;
+ inv->d0 = d0;
+ inv->di = mpn_invert_3by2 (d1, d0);
+}
+
+static void
+mpn_div_qr_invert (struct gmp_div_inverse *inv,
+ mp_srcptr dp, mp_size_t dn)
+{
+ assert (dn > 0);
+
+ if (dn == 1)
+ mpn_div_qr_1_invert (inv, dp[0]);
+ else if (dn == 2)
+ mpn_div_qr_2_invert (inv, dp[1], dp[0]);
+ else
+ {
+ unsigned shift;
+ mp_limb_t d1, d0;
+
+ d1 = dp[dn-1];
+ d0 = dp[dn-2];
+ assert (d1 > 0);
+ gmp_clz (shift, d1);
+ inv->shift = shift;
+ if (shift > 0)
+ {
+ d1 = (d1 << shift) | (d0 >> (GMP_LIMB_BITS - shift));
+ d0 = (d0 << shift) | (dp[dn-3] >> (GMP_LIMB_BITS - shift));
+ }
+ inv->d1 = d1;
+ inv->d0 = d0;
+ inv->di = mpn_invert_3by2 (d1, d0);
+ }
+}
+
+/* Not matching current public gmp interface, rather corresponding to
+ the sbpi1_div_* functions. */
+static mp_limb_t
+mpn_div_qr_1_preinv (mp_ptr qp, mp_srcptr np, mp_size_t nn,
+ const struct gmp_div_inverse *inv)
+{
+ mp_limb_t d, di;
+ mp_limb_t r;
+ mp_ptr tp = NULL;
+
+ if (inv->shift > 0)
+ {
+ /* Shift, reusing qp area if possible. In-place shift if qp == np. */
+ tp = qp ? qp : gmp_xalloc_limbs (nn);
+ r = mpn_lshift (tp, np, nn, inv->shift);
+ np = tp;
+ }
+ else
+ r = 0;
+
+ d = inv->d1;
+ di = inv->di;
+ while (--nn >= 0)
+ {
+ mp_limb_t q;
+
+ gmp_udiv_qrnnd_preinv (q, r, r, np[nn], d, di);
+ if (qp)
+ qp[nn] = q;
+ }
+ if ((inv->shift > 0) && (tp != qp))
+ gmp_free (tp);
+
+ return r >> inv->shift;
+}
+
+static mp_limb_t
+mpn_div_qr_1 (mp_ptr qp, mp_srcptr np, mp_size_t nn, mp_limb_t d)
+{
+ assert (d > 0);
+
+ /* Special case for powers of two. */
+ if ((d & (d-1)) == 0)
+ {
+ mp_limb_t r = np[0] & (d-1);
+ if (qp)
+ {
+ if (d <= 1)
+ mpn_copyi (qp, np, nn);
+ else
+ {
+ unsigned shift;
+ gmp_ctz (shift, d);
+ mpn_rshift (qp, np, nn, shift);
+ }
+ }
+ return r;
+ }
+ else
+ {
+ struct gmp_div_inverse inv;
+ mpn_div_qr_1_invert (&inv, d);
+ return mpn_div_qr_1_preinv (qp, np, nn, &inv);
+ }
+}
+
+static void
+mpn_div_qr_2_preinv (mp_ptr qp, mp_ptr np, mp_size_t nn,
+ const struct gmp_div_inverse *inv)
+{
+ unsigned shift;
+ mp_size_t i;
+ mp_limb_t d1, d0, di, r1, r0;
+
+ assert (nn >= 2);
+ shift = inv->shift;
+ d1 = inv->d1;
+ d0 = inv->d0;
+ di = inv->di;
+
+ if (shift > 0)
+ r1 = mpn_lshift (np, np, nn, shift);
+ else
+ r1 = 0;
+
+ r0 = np[nn - 1];
+
+ i = nn - 2;
+ do
+ {
+ mp_limb_t n0, q;
+ n0 = np[i];
+ gmp_udiv_qr_3by2 (q, r1, r0, r1, r0, n0, d1, d0, di);
+
+ if (qp)
+ qp[i] = q;
+ }
+ while (--i >= 0);
+
+ if (shift > 0)
+ {
+ assert ((r0 << (GMP_LIMB_BITS - shift)) == 0);
+ r0 = (r0 >> shift) | (r1 << (GMP_LIMB_BITS - shift));
+ r1 >>= shift;
+ }
+
+ np[1] = r1;
+ np[0] = r0;
+}
+
+static void
+mpn_div_qr_pi1 (mp_ptr qp,
+ mp_ptr np, mp_size_t nn, mp_limb_t n1,
+ mp_srcptr dp, mp_size_t dn,
+ mp_limb_t dinv)
+{
+ mp_size_t i;
+
+ mp_limb_t d1, d0;
+ mp_limb_t cy, cy1;
+ mp_limb_t q;
+
+ assert (dn > 2);
+ assert (nn >= dn);
+
+ d1 = dp[dn - 1];
+ d0 = dp[dn - 2];
+
+ assert ((d1 & GMP_LIMB_HIGHBIT) != 0);
+ /* Iteration variable is the index of the q limb.
+ *
+ * We divide <n1, np[dn-1+i], np[dn-2+i], np[dn-3+i],..., np[i]>
+ * by <d1, d0, dp[dn-3], ..., dp[0] >
+ */
+
+ i = nn - dn;
+ do
+ {
+ mp_limb_t n0 = np[dn-1+i];
+
+ if (n1 == d1 && n0 == d0)
+ {
+ q = GMP_LIMB_MAX;
+ mpn_submul_1 (np+i, dp, dn, q);
+ n1 = np[dn-1+i]; /* update n1, last loop's value will now be invalid */
+ }
+ else
+ {
+ gmp_udiv_qr_3by2 (q, n1, n0, n1, n0, np[dn-2+i], d1, d0, dinv);
+
+ cy = mpn_submul_1 (np + i, dp, dn-2, q);
+
+ cy1 = n0 < cy;
+ n0 = n0 - cy;
+ cy = n1 < cy1;
+ n1 = n1 - cy1;
+ np[dn-2+i] = n0;
+
+ if (cy != 0)
+ {
+ n1 += d1 + mpn_add_n (np + i, np + i, dp, dn - 1);
+ q--;
+ }
+ }
+
+ if (qp)
+ qp[i] = q;
+ }
+ while (--i >= 0);
+
+ np[dn - 1] = n1;
+}
+
+static void
+mpn_div_qr_preinv (mp_ptr qp, mp_ptr np, mp_size_t nn,
+ mp_srcptr dp, mp_size_t dn,
+ const struct gmp_div_inverse *inv)
+{
+ assert (dn > 0);
+ assert (nn >= dn);
+
+ if (dn == 1)
+ np[0] = mpn_div_qr_1_preinv (qp, np, nn, inv);
+ else if (dn == 2)
+ mpn_div_qr_2_preinv (qp, np, nn, inv);
+ else
+ {
+ mp_limb_t nh;
+ unsigned shift;
+
+ assert (inv->d1 == dp[dn-1]);
+ assert (inv->d0 == dp[dn-2]);
+ assert ((inv->d1 & GMP_LIMB_HIGHBIT) != 0);
+
+ shift = inv->shift;
+ if (shift > 0)
+ nh = mpn_lshift (np, np, nn, shift);
+ else
+ nh = 0;
+
+ mpn_div_qr_pi1 (qp, np, nn, nh, dp, dn, inv->di);
+
+ if (shift > 0)
+ gmp_assert_nocarry (mpn_rshift (np, np, dn, shift));
+ }
+}
+
+static void
+mpn_div_qr (mp_ptr qp, mp_ptr np, mp_size_t nn, mp_srcptr dp, mp_size_t dn)
+{
+ struct gmp_div_inverse inv;
+ mp_ptr tp = NULL;
+
+ assert (dn > 0);
+ assert (nn >= dn);
+
+ mpn_div_qr_invert (&inv, dp, dn);
+ if (dn > 2 && inv.shift > 0)
+ {
+ tp = gmp_xalloc_limbs (dn);
+ gmp_assert_nocarry (mpn_lshift (tp, dp, dn, inv.shift));
+ dp = tp;
+ }
+ mpn_div_qr_preinv (qp, np, nn, dp, dn, &inv);
+ if (tp)
+ gmp_free (tp);
+}
+
+
+/* MPN base conversion. */
+static unsigned
+mpn_base_power_of_two_p (unsigned b)
+{
+ switch (b)
+ {
+ case 2: return 1;
+ case 4: return 2;
+ case 8: return 3;
+ case 16: return 4;
+ case 32: return 5;
+ case 64: return 6;
+ case 128: return 7;
+ case 256: return 8;
+ default: return 0;
+ }
+}
+
+struct mpn_base_info
+{
+ /* bb is the largest power of the base which fits in one limb, and
+ exp is the corresponding exponent. */
+ unsigned exp;
+ mp_limb_t bb;
+};
+
+static void
+mpn_get_base_info (struct mpn_base_info *info, mp_limb_t b)
+{
+ mp_limb_t m;
+ mp_limb_t p;
+ unsigned exp;
+
+ m = GMP_LIMB_MAX / b;
+ for (exp = 1, p = b; p <= m; exp++)
+ p *= b;
+
+ info->exp = exp;
+ info->bb = p;
+}
+
+static mp_bitcnt_t
+mpn_limb_size_in_base_2 (mp_limb_t u)
+{
+ unsigned shift;
+
+ assert (u > 0);
+ gmp_clz (shift, u);
+ return GMP_LIMB_BITS - shift;
+}
+
+static size_t
+mpn_get_str_bits (unsigned char *sp, unsigned bits, mp_srcptr up, mp_size_t un)
+{
+ unsigned char mask;
+ size_t sn, j;
+ mp_size_t i;
+ unsigned shift;
+
+ sn = ((un - 1) * GMP_LIMB_BITS + mpn_limb_size_in_base_2 (up[un-1])
+ + bits - 1) / bits;
+
+ mask = (1U << bits) - 1;
+
+ for (i = 0, j = sn, shift = 0; j-- > 0;)
+ {
+ unsigned char digit = up[i] >> shift;
+
+ shift += bits;
+
+ if (shift >= GMP_LIMB_BITS && ++i < un)
+ {
+ shift -= GMP_LIMB_BITS;
+ digit |= up[i] << (bits - shift);
+ }
+ sp[j] = digit & mask;
+ }
+ return sn;
+}
+
+/* We generate digits from the least significant end, and reverse at
+ the end. */
+static size_t
+mpn_limb_get_str (unsigned char *sp, mp_limb_t w,
+ const struct gmp_div_inverse *binv)
+{
+ mp_size_t i;
+ for (i = 0; w > 0; i++)
+ {
+ mp_limb_t h, l, r;
+
+ h = w >> (GMP_LIMB_BITS - binv->shift);
+ l = w << binv->shift;
+
+ gmp_udiv_qrnnd_preinv (w, r, h, l, binv->d1, binv->di);
+ assert ( (r << (GMP_LIMB_BITS - binv->shift)) == 0);
+ r >>= binv->shift;
+
+ sp[i] = r;
+ }
+ return i;
+}
+
+static size_t
+mpn_get_str_other (unsigned char *sp,
+ int base, const struct mpn_base_info *info,
+ mp_ptr up, mp_size_t un)
+{
+ struct gmp_div_inverse binv;
+ size_t sn;
+ size_t i;
+
+ mpn_div_qr_1_invert (&binv, base);
+
+ sn = 0;
+
+ if (un > 1)
+ {
+ struct gmp_div_inverse bbinv;
+ mpn_div_qr_1_invert (&bbinv, info->bb);
+
+ do
+ {
+ mp_limb_t w;
+ size_t done;
+ w = mpn_div_qr_1_preinv (up, up, un, &bbinv);
+ un -= (up[un-1] == 0);
+ done = mpn_limb_get_str (sp + sn, w, &binv);
+
+ for (sn += done; done < info->exp; done++)
+ sp[sn++] = 0;
+ }
+ while (un > 1);
+ }
+ sn += mpn_limb_get_str (sp + sn, up[0], &binv);
+
+ /* Reverse order */
+ for (i = 0; 2*i + 1 < sn; i++)
+ {
+ unsigned char t = sp[i];
+ sp[i] = sp[sn - i - 1];
+ sp[sn - i - 1] = t;
+ }
+
+ return sn;
+}
+
+size_t
+mpn_get_str (unsigned char *sp, int base, mp_ptr up, mp_size_t un)
+{
+ unsigned bits;
+
+ assert (un > 0);
+ assert (up[un-1] > 0);
+
+ bits = mpn_base_power_of_two_p (base);
+ if (bits)
+ return mpn_get_str_bits (sp, bits, up, un);
+ else
+ {
+ struct mpn_base_info info;
+
+ mpn_get_base_info (&info, base);
+ return mpn_get_str_other (sp, base, &info, up, un);
+ }
+}
+
+static mp_size_t
+mpn_set_str_bits (mp_ptr rp, const unsigned char *sp, size_t sn,
+ unsigned bits)
+{
+ mp_size_t rn;
+ size_t j;
+ unsigned shift;
+
+ for (j = sn, rn = 0, shift = 0; j-- > 0; )
+ {
+ if (shift == 0)
+ {
+ rp[rn++] = sp[j];
+ shift += bits;
+ }
+ else
+ {
+ rp[rn-1] |= (mp_limb_t) sp[j] << shift;
+ shift += bits;
+ if (shift >= GMP_LIMB_BITS)
+ {
+ shift -= GMP_LIMB_BITS;
+ if (shift > 0)
+ rp[rn++] = (mp_limb_t) sp[j] >> (bits - shift);
+ }
+ }
+ }
+ rn = mpn_normalized_size (rp, rn);
+ return rn;
+}
+
+/* Result is usually normalized, except for all-zero input, in which
+ case a single zero limb is written at *RP, and 1 is returned. */
+static mp_size_t
+mpn_set_str_other (mp_ptr rp, const unsigned char *sp, size_t sn,
+ mp_limb_t b, const struct mpn_base_info *info)
+{
+ mp_size_t rn;
+ mp_limb_t w;
+ unsigned k;
+ size_t j;
+
+ assert (sn > 0);
+
+ k = 1 + (sn - 1) % info->exp;
+
+ j = 0;
+ w = sp[j++];
+ while (--k != 0)
+ w = w * b + sp[j++];
+
+ rp[0] = w;
+
+ for (rn = 1; j < sn;)
+ {
+ mp_limb_t cy;
+
+ w = sp[j++];
+ for (k = 1; k < info->exp; k++)
+ w = w * b + sp[j++];
+
+ cy = mpn_mul_1 (rp, rp, rn, info->bb);
+ cy += mpn_add_1 (rp, rp, rn, w);
+ if (cy > 0)
+ rp[rn++] = cy;
+ }
+ assert (j == sn);
+
+ return rn;
+}
+
+mp_size_t
+mpn_set_str (mp_ptr rp, const unsigned char *sp, size_t sn, int base)
+{
+ unsigned bits;
+
+ if (sn == 0)
+ return 0;
+
+ bits = mpn_base_power_of_two_p (base);
+ if (bits)
+ return mpn_set_str_bits (rp, sp, sn, bits);
+ else
+ {
+ struct mpn_base_info info;
+
+ mpn_get_base_info (&info, base);
+ return mpn_set_str_other (rp, sp, sn, base, &info);
+ }
+}
+
+
+/* MPZ interface */
+void
+mpz_init (mpz_t r)
+{
+ static const mp_limb_t dummy_limb = 0xc1a0;
+
+ r->_mp_alloc = 0;
+ r->_mp_size = 0;
+ r->_mp_d = (mp_ptr) &dummy_limb;
+}
+
+/* The utility of this function is a bit limited, since many functions
+ assigns the result variable using mpz_swap. */
+void
+mpz_init2 (mpz_t r, mp_bitcnt_t bits)
+{
+ mp_size_t rn;
+
+ bits -= (bits != 0); /* Round down, except if 0 */
+ rn = 1 + bits / GMP_LIMB_BITS;
+
+ r->_mp_alloc = rn;
+ r->_mp_size = 0;
+ r->_mp_d = gmp_xalloc_limbs (rn);
+}
+
+void
+mpz_clear (mpz_t r)
+{
+ if (r->_mp_alloc)
+ gmp_free (r->_mp_d);
+}
+
+static mp_ptr
+mpz_realloc (mpz_t r, mp_size_t size)
+{
+ size = GMP_MAX (size, 1);
+
+ if (r->_mp_alloc)
+ r->_mp_d = gmp_xrealloc_limbs (r->_mp_d, size);
+ else
+ r->_mp_d = gmp_xalloc_limbs (size);
+ r->_mp_alloc = size;
+
+ if (GMP_ABS (r->_mp_size) > size)
+ r->_mp_size = 0;
+
+ return r->_mp_d;
+}
+
+/* Realloc for an mpz_t WHAT if it has less than NEEDED limbs. */
+#define MPZ_REALLOC(z,n) ((n) > (z)->_mp_alloc \
+ ? mpz_realloc(z,n) \
+ : (z)->_mp_d)
+
+/* MPZ assignment and basic conversions. */
+void
+mpz_set_si (mpz_t r, signed long int x)
+{
+ if (x >= 0)
+ mpz_set_ui (r, x);
+ else /* (x < 0) */
+ {
+ r->_mp_size = -1;
+ MPZ_REALLOC (r, 1)[0] = GMP_NEG_CAST (unsigned long int, x);
+ }
+}
+
+void
+mpz_set_ui (mpz_t r, unsigned long int x)
+{
+ if (x > 0)
+ {
+ r->_mp_size = 1;
+ MPZ_REALLOC (r, 1)[0] = x;
+ }
+ else
+ r->_mp_size = 0;
+}
+
+void
+mpz_set (mpz_t r, const mpz_t x)
+{
+ /* Allow the NOP r == x */
+ if (r != x)
+ {
+ mp_size_t n;
+ mp_ptr rp;
+
+ n = GMP_ABS (x->_mp_size);
+ rp = MPZ_REALLOC (r, n);
+
+ mpn_copyi (rp, x->_mp_d, n);
+ r->_mp_size = x->_mp_size;
+ }
+}
+
+void
+mpz_init_set_si (mpz_t r, signed long int x)
+{
+ mpz_init (r);
+ mpz_set_si (r, x);
+}
+
+void
+mpz_init_set_ui (mpz_t r, unsigned long int x)
+{
+ mpz_init (r);
+ mpz_set_ui (r, x);
+}
+
+void
+mpz_init_set (mpz_t r, const mpz_t x)
+{
+ mpz_init (r);
+ mpz_set (r, x);
+}
+
+int
+mpz_fits_slong_p (const mpz_t u)
+{
+ mp_size_t us = u->_mp_size;
+
+ if (us == 1)
+ return u->_mp_d[0] < GMP_LIMB_HIGHBIT;
+ else if (us == -1)
+ return u->_mp_d[0] <= GMP_LIMB_HIGHBIT;
+ else
+ return (us == 0);
+}
+
+int
+mpz_fits_ulong_p (const mpz_t u)
+{
+ mp_size_t us = u->_mp_size;
+
+ return (us == (us > 0));
+}
+
+long int
+mpz_get_si (const mpz_t u)
+{
+ if (u->_mp_size < 0)
+ /* This expression is necessary to properly handle 0x80000000 */
+ return -1 - (long) ((u->_mp_d[0] - 1) & ~GMP_LIMB_HIGHBIT);
+ else
+ return (long) (mpz_get_ui (u) & ~GMP_LIMB_HIGHBIT);
+}
+
+unsigned long int
+mpz_get_ui (const mpz_t u)
+{
+ return u->_mp_size == 0 ? 0 : u->_mp_d[0];
+}
+
+size_t
+mpz_size (const mpz_t u)
+{
+ return GMP_ABS (u->_mp_size);
+}
+
+mp_limb_t
+mpz_getlimbn (const mpz_t u, mp_size_t n)
+{
+ if (n >= 0 && n < GMP_ABS (u->_mp_size))
+ return u->_mp_d[n];
+ else
+ return 0;
+}
+
+void
+mpz_realloc2 (mpz_t x, mp_bitcnt_t n)
+{
+ mpz_realloc (x, 1 + (n - (n != 0)) / GMP_LIMB_BITS);
+}
+
+mp_srcptr
+mpz_limbs_read (mpz_srcptr x)
+{
+ return x->_mp_d;
+}
+
+mp_ptr
+mpz_limbs_modify (mpz_t x, mp_size_t n)
+{
+ assert (n > 0);
+ return MPZ_REALLOC (x, n);
+}
+
+mp_ptr
+mpz_limbs_write (mpz_t x, mp_size_t n)
+{
+ return mpz_limbs_modify (x, n);
+}
+
+void
+mpz_limbs_finish (mpz_t x, mp_size_t xs)
+{
+ mp_size_t xn;
+ xn = mpn_normalized_size (x->_mp_d, GMP_ABS (xs));
+ x->_mp_size = xs < 0 ? -xn : xn;
+}
+
+static mpz_srcptr
+mpz_roinit_normal_n (mpz_t x, mp_srcptr xp, mp_size_t xs)
+{
+ x->_mp_alloc = 0;
+ x->_mp_d = (mp_ptr) xp;
+ x->_mp_size = xs;
+ return x;
+}
+
+mpz_srcptr
+mpz_roinit_n (mpz_t x, mp_srcptr xp, mp_size_t xs)
+{
+ mpz_roinit_normal_n (x, xp, xs);
+ mpz_limbs_finish (x, xs);
+ return x;
+}
+
+
+/* Conversions and comparison to double. */
+void
+mpz_set_d (mpz_t r, double x)
+{
+ int sign;
+ mp_ptr rp;
+ mp_size_t rn, i;
+ double B;
+ double Bi;
+ mp_limb_t f;
+
+ /* x != x is true when x is a NaN, and x == x * 0.5 is true when x is
+ zero or infinity. */
+ if (x != x || x == x * 0.5)
+ {
+ r->_mp_size = 0;
+ return;
+ }
+
+ sign = x < 0.0 ;
+ if (sign)
+ x = - x;
+
+ if (x < 1.0)
+ {
+ r->_mp_size = 0;
+ return;
+ }
+ B = 2.0 * (double) GMP_LIMB_HIGHBIT;
+ Bi = 1.0 / B;
+ for (rn = 1; x >= B; rn++)
+ x *= Bi;
+
+ rp = MPZ_REALLOC (r, rn);
+
+ f = (mp_limb_t) x;
+ x -= f;
+ assert (x < 1.0);
+ i = rn-1;
+ rp[i] = f;
+ while (--i >= 0)
+ {
+ x = B * x;
+ f = (mp_limb_t) x;
+ x -= f;
+ assert (x < 1.0);
+ rp[i] = f;
+ }
+
+ r->_mp_size = sign ? - rn : rn;
+}
+
+void
+mpz_init_set_d (mpz_t r, double x)
+{
+ mpz_init (r);
+ mpz_set_d (r, x);
+}
+
+double
+mpz_get_d (const mpz_t u)
+{
+ int m;
+ mp_limb_t l;
+ mp_size_t un;
+ double x;
+ double B = 2.0 * (double) GMP_LIMB_HIGHBIT;
+
+ un = GMP_ABS (u->_mp_size);
+
+ if (un == 0)
+ return 0.0;
+
+ l = u->_mp_d[--un];
+ gmp_clz (m, l);
+ m = m + GMP_DBL_MANT_BITS - GMP_LIMB_BITS;
+ if (m < 0)
+ l &= GMP_LIMB_MAX << -m;
+
+ for (x = l; --un >= 0;)
+ {
+ x = B*x;
+ if (m > 0) {
+ l = u->_mp_d[un];
+ m -= GMP_LIMB_BITS;
+ if (m < 0)
+ l &= GMP_LIMB_MAX << -m;
+ x += l;
+ }
+ }
+
+ if (u->_mp_size < 0)
+ x = -x;
+
+ return x;
+}
+
+int
+mpz_cmpabs_d (const mpz_t x, double d)
+{
+ mp_size_t xn;
+ double B, Bi;
+ mp_size_t i;
+
+ xn = x->_mp_size;
+ d = GMP_ABS (d);
+
+ if (xn != 0)
+ {
+ xn = GMP_ABS (xn);
+
+ B = 2.0 * (double) GMP_LIMB_HIGHBIT;
+ Bi = 1.0 / B;
+
+ /* Scale d so it can be compared with the top limb. */
+ for (i = 1; i < xn; i++)
+ d *= Bi;
+
+ if (d >= B)
+ return -1;
+
+ /* Compare floor(d) to top limb, subtract and cancel when equal. */
+ for (i = xn; i-- > 0;)
+ {
+ mp_limb_t f, xl;
+
+ f = (mp_limb_t) d;
+ xl = x->_mp_d[i];
+ if (xl > f)
+ return 1;
+ else if (xl < f)
+ return -1;
+ d = B * (d - f);
+ }
+ }
+ return - (d > 0.0);
+}
+
+int
+mpz_cmp_d (const mpz_t x, double d)
+{
+ if (x->_mp_size < 0)
+ {
+ if (d >= 0.0)
+ return -1;
+ else
+ return -mpz_cmpabs_d (x, d);
+ }
+ else
+ {
+ if (d < 0.0)
+ return 1;
+ else
+ return mpz_cmpabs_d (x, d);
+ }
+}
+
+
+/* MPZ comparisons and the like. */
+int
+mpz_sgn (const mpz_t u)
+{
+ return GMP_CMP (u->_mp_size, 0);
+}
+
+int
+mpz_cmp_si (const mpz_t u, long v)
+{
+ mp_size_t usize = u->_mp_size;
+
+ if (usize < -1)
+ return -1;
+ else if (v >= 0)
+ return mpz_cmp_ui (u, v);
+ else if (usize >= 0)
+ return 1;
+ else /* usize == -1 */
+ return GMP_CMP (GMP_NEG_CAST (mp_limb_t, v), u->_mp_d[0]);
+}
+
+int
+mpz_cmp_ui (const mpz_t u, unsigned long v)
+{
+ mp_size_t usize = u->_mp_size;
+
+ if (usize > 1)
+ return 1;
+ else if (usize < 0)
+ return -1;
+ else
+ return GMP_CMP (mpz_get_ui (u), v);
+}
+
+int
+mpz_cmp (const mpz_t a, const mpz_t b)
+{
+ mp_size_t asize = a->_mp_size;
+ mp_size_t bsize = b->_mp_size;
+
+ if (asize != bsize)
+ return (asize < bsize) ? -1 : 1;
+ else if (asize >= 0)
+ return mpn_cmp (a->_mp_d, b->_mp_d, asize);
+ else
+ return mpn_cmp (b->_mp_d, a->_mp_d, -asize);
+}
+
+int
+mpz_cmpabs_ui (const mpz_t u, unsigned long v)
+{
+ if (GMP_ABS (u->_mp_size) > 1)
+ return 1;
+ else
+ return GMP_CMP (mpz_get_ui (u), v);
+}
+
+int
+mpz_cmpabs (const mpz_t u, const mpz_t v)
+{
+ return mpn_cmp4 (u->_mp_d, GMP_ABS (u->_mp_size),
+ v->_mp_d, GMP_ABS (v->_mp_size));
+}
+
+void
+mpz_abs (mpz_t r, const mpz_t u)
+{
+ mpz_set (r, u);
+ r->_mp_size = GMP_ABS (r->_mp_size);
+}
+
+void
+mpz_neg (mpz_t r, const mpz_t u)
+{
+ mpz_set (r, u);
+ r->_mp_size = -r->_mp_size;
+}
+
+void
+mpz_swap (mpz_t u, mpz_t v)
+{
+ MP_SIZE_T_SWAP (u->_mp_size, v->_mp_size);
+ MP_SIZE_T_SWAP (u->_mp_alloc, v->_mp_alloc);
+ MP_PTR_SWAP (u->_mp_d, v->_mp_d);
+}
+
+
+/* MPZ addition and subtraction */
+
+/* Adds to the absolute value. Returns new size, but doesn't store it. */
+static mp_size_t
+mpz_abs_add_ui (mpz_t r, const mpz_t a, unsigned long b)
+{
+ mp_size_t an;
+ mp_ptr rp;
+ mp_limb_t cy;
+
+ an = GMP_ABS (a->_mp_size);
+ if (an == 0)
+ {
+ MPZ_REALLOC (r, 1)[0] = b;
+ return b > 0;
+ }
+
+ rp = MPZ_REALLOC (r, an + 1);
+
+ cy = mpn_add_1 (rp, a->_mp_d, an, b);
+ rp[an] = cy;
+ an += cy;
+
+ return an;
+}
+
+/* Subtract from the absolute value. Returns new size, (or -1 on underflow),
+ but doesn't store it. */
+static mp_size_t
+mpz_abs_sub_ui (mpz_t r, const mpz_t a, unsigned long b)
+{
+ mp_size_t an = GMP_ABS (a->_mp_size);
+ mp_ptr rp;
+
+ if (an == 0)
+ {
+ MPZ_REALLOC (r, 1)[0] = b;
+ return -(b > 0);
+ }
+ rp = MPZ_REALLOC (r, an);
+ if (an == 1 && a->_mp_d[0] < b)
+ {
+ rp[0] = b - a->_mp_d[0];
+ return -1;
+ }
+ else
+ {
+ gmp_assert_nocarry (mpn_sub_1 (rp, a->_mp_d, an, b));
+ return mpn_normalized_size (rp, an);
+ }
+}
+
+void
+mpz_add_ui (mpz_t r, const mpz_t a, unsigned long b)
+{
+ if (a->_mp_size >= 0)
+ r->_mp_size = mpz_abs_add_ui (r, a, b);
+ else
+ r->_mp_size = -mpz_abs_sub_ui (r, a, b);
+}
+
+void
+mpz_sub_ui (mpz_t r, const mpz_t a, unsigned long b)
+{
+ if (a->_mp_size < 0)
+ r->_mp_size = -mpz_abs_add_ui (r, a, b);
+ else
+ r->_mp_size = mpz_abs_sub_ui (r, a, b);
+}
+
+void
+mpz_ui_sub (mpz_t r, unsigned long a, const mpz_t b)
+{
+ if (b->_mp_size < 0)
+ r->_mp_size = mpz_abs_add_ui (r, b, a);
+ else
+ r->_mp_size = -mpz_abs_sub_ui (r, b, a);
+}
+
+static mp_size_t
+mpz_abs_add (mpz_t r, const mpz_t a, const mpz_t b)
+{
+ mp_size_t an = GMP_ABS (a->_mp_size);
+ mp_size_t bn = GMP_ABS (b->_mp_size);
+ mp_ptr rp;
+ mp_limb_t cy;
+
+ if (an < bn)
+ {
+ MPZ_SRCPTR_SWAP (a, b);
+ MP_SIZE_T_SWAP (an, bn);
+ }
+
+ rp = MPZ_REALLOC (r, an + 1);
+ cy = mpn_add (rp, a->_mp_d, an, b->_mp_d, bn);
+
+ rp[an] = cy;
+
+ return an + cy;
+}
+
+static mp_size_t
+mpz_abs_sub (mpz_t r, const mpz_t a, const mpz_t b)
+{
+ mp_size_t an = GMP_ABS (a->_mp_size);
+ mp_size_t bn = GMP_ABS (b->_mp_size);
+ int cmp;
+ mp_ptr rp;
+
+ cmp = mpn_cmp4 (a->_mp_d, an, b->_mp_d, bn);
+ if (cmp > 0)
+ {
+ rp = MPZ_REALLOC (r, an);
+ gmp_assert_nocarry (mpn_sub (rp, a->_mp_d, an, b->_mp_d, bn));
+ return mpn_normalized_size (rp, an);
+ }
+ else if (cmp < 0)
+ {
+ rp = MPZ_REALLOC (r, bn);
+ gmp_assert_nocarry (mpn_sub (rp, b->_mp_d, bn, a->_mp_d, an));
+ return -mpn_normalized_size (rp, bn);
+ }
+ else
+ return 0;
+}
+
+void
+mpz_add (mpz_t r, const mpz_t a, const mpz_t b)
+{
+ mp_size_t rn;
+
+ if ( (a->_mp_size ^ b->_mp_size) >= 0)
+ rn = mpz_abs_add (r, a, b);
+ else
+ rn = mpz_abs_sub (r, a, b);
+
+ r->_mp_size = a->_mp_size >= 0 ? rn : - rn;
+}
+
+void
+mpz_sub (mpz_t r, const mpz_t a, const mpz_t b)
+{
+ mp_size_t rn;
+
+ if ( (a->_mp_size ^ b->_mp_size) >= 0)
+ rn = mpz_abs_sub (r, a, b);
+ else
+ rn = mpz_abs_add (r, a, b);
+
+ r->_mp_size = a->_mp_size >= 0 ? rn : - rn;
+}
+
+
+/* MPZ multiplication */
+void
+mpz_mul_si (mpz_t r, const mpz_t u, long int v)
+{
+ if (v < 0)
+ {
+ mpz_mul_ui (r, u, GMP_NEG_CAST (unsigned long int, v));
+ mpz_neg (r, r);
+ }
+ else
+ mpz_mul_ui (r, u, (unsigned long int) v);
+}
+
+void
+mpz_mul_ui (mpz_t r, const mpz_t u, unsigned long int v)
+{
+ mp_size_t un, us;
+ mp_ptr tp;
+ mp_limb_t cy;
+
+ us = u->_mp_size;
+
+ if (us == 0 || v == 0)
+ {
+ r->_mp_size = 0;
+ return;
+ }
+
+ un = GMP_ABS (us);
+
+ tp = MPZ_REALLOC (r, un + 1);
+ cy = mpn_mul_1 (tp, u->_mp_d, un, v);
+ tp[un] = cy;
+
+ un += (cy > 0);
+ r->_mp_size = (us < 0) ? - un : un;
+}
+
+void
+mpz_mul (mpz_t r, const mpz_t u, const mpz_t v)
+{
+ int sign;
+ mp_size_t un, vn, rn;
+ mpz_t t;
+ mp_ptr tp;
+
+ un = u->_mp_size;
+ vn = v->_mp_size;
+
+ if (un == 0 || vn == 0)
+ {
+ r->_mp_size = 0;
+ return;
+ }
+
+ sign = (un ^ vn) < 0;
+
+ un = GMP_ABS (un);
+ vn = GMP_ABS (vn);
+
+ mpz_init2 (t, (un + vn) * GMP_LIMB_BITS);
+
+ tp = t->_mp_d;
+ if (un >= vn)
+ mpn_mul (tp, u->_mp_d, un, v->_mp_d, vn);
+ else
+ mpn_mul (tp, v->_mp_d, vn, u->_mp_d, un);
+
+ rn = un + vn;
+ rn -= tp[rn-1] == 0;
+
+ t->_mp_size = sign ? - rn : rn;
+ mpz_swap (r, t);
+ mpz_clear (t);
+}
+
+void
+mpz_mul_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t bits)
+{
+ mp_size_t un, rn;
+ mp_size_t limbs;
+ unsigned shift;
+ mp_ptr rp;
+
+ un = GMP_ABS (u->_mp_size);
+ if (un == 0)
+ {
+ r->_mp_size = 0;
+ return;
+ }
+
+ limbs = bits / GMP_LIMB_BITS;
+ shift = bits % GMP_LIMB_BITS;
+
+ rn = un + limbs + (shift > 0);
+ rp = MPZ_REALLOC (r, rn);
+ if (shift > 0)
+ {
+ mp_limb_t cy = mpn_lshift (rp + limbs, u->_mp_d, un, shift);
+ rp[rn-1] = cy;
+ rn -= (cy == 0);
+ }
+ else
+ mpn_copyd (rp + limbs, u->_mp_d, un);
+
+ mpn_zero (rp, limbs);
+
+ r->_mp_size = (u->_mp_size < 0) ? - rn : rn;
+}
+
+void
+mpz_addmul_ui (mpz_t r, const mpz_t u, unsigned long int v)
+{
+ mpz_t t;
+ mpz_init (t);
+ mpz_mul_ui (t, u, v);
+ mpz_add (r, r, t);
+ mpz_clear (t);
+}
+
+void
+mpz_submul_ui (mpz_t r, const mpz_t u, unsigned long int v)
+{
+ mpz_t t;
+ mpz_init (t);
+ mpz_mul_ui (t, u, v);
+ mpz_sub (r, r, t);
+ mpz_clear (t);
+}
+
+void
+mpz_addmul (mpz_t r, const mpz_t u, const mpz_t v)
+{
+ mpz_t t;
+ mpz_init (t);
+ mpz_mul (t, u, v);
+ mpz_add (r, r, t);
+ mpz_clear (t);
+}
+
+void
+mpz_submul (mpz_t r, const mpz_t u, const mpz_t v)
+{
+ mpz_t t;
+ mpz_init (t);
+ mpz_mul (t, u, v);
+ mpz_sub (r, r, t);
+ mpz_clear (t);
+}
+
+
+/* MPZ division */
+enum mpz_div_round_mode { GMP_DIV_FLOOR, GMP_DIV_CEIL, GMP_DIV_TRUNC };
+
+/* Allows q or r to be zero. Returns 1 iff remainder is non-zero. */
+static int
+mpz_div_qr (mpz_t q, mpz_t r,
+ const mpz_t n, const mpz_t d, enum mpz_div_round_mode mode)
+{
+ mp_size_t ns, ds, nn, dn, qs;
+ ns = n->_mp_size;
+ ds = d->_mp_size;
+
+ if (ds == 0)
+ gmp_die("mpz_div_qr: Divide by zero.");
+
+ if (ns == 0)
+ {
+ if (q)
+ q->_mp_size = 0;
+ if (r)
+ r->_mp_size = 0;
+ return 0;
+ }
+
+ nn = GMP_ABS (ns);
+ dn = GMP_ABS (ds);
+
+ qs = ds ^ ns;
+
+ if (nn < dn)
+ {
+ if (mode == GMP_DIV_CEIL && qs >= 0)
+ {
+ /* q = 1, r = n - d */
+ if (r)
+ mpz_sub (r, n, d);
+ if (q)
+ mpz_set_ui (q, 1);
+ }
+ else if (mode == GMP_DIV_FLOOR && qs < 0)
+ {
+ /* q = -1, r = n + d */
+ if (r)
+ mpz_add (r, n, d);
+ if (q)
+ mpz_set_si (q, -1);
+ }
+ else
+ {
+ /* q = 0, r = d */
+ if (r)
+ mpz_set (r, n);
+ if (q)
+ q->_mp_size = 0;
+ }
+ return 1;
+ }
+ else
+ {
+ mp_ptr np, qp;
+ mp_size_t qn, rn;
+ mpz_t tq, tr;
+
+ mpz_init_set (tr, n);
+ np = tr->_mp_d;
+
+ qn = nn - dn + 1;
+
+ if (q)
+ {
+ mpz_init2 (tq, qn * GMP_LIMB_BITS);
+ qp = tq->_mp_d;
+ }
+ else
+ qp = NULL;
+
+ mpn_div_qr (qp, np, nn, d->_mp_d, dn);
+
+ if (qp)
+ {
+ qn -= (qp[qn-1] == 0);
+
+ tq->_mp_size = qs < 0 ? -qn : qn;
+ }
+ rn = mpn_normalized_size (np, dn);
+ tr->_mp_size = ns < 0 ? - rn : rn;
+
+ if (mode == GMP_DIV_FLOOR && qs < 0 && rn != 0)
+ {
+ if (q)
+ mpz_sub_ui (tq, tq, 1);
+ if (r)
+ mpz_add (tr, tr, d);
+ }
+ else if (mode == GMP_DIV_CEIL && qs >= 0 && rn != 0)
+ {
+ if (q)
+ mpz_add_ui (tq, tq, 1);
+ if (r)
+ mpz_sub (tr, tr, d);
+ }
+
+ if (q)
+ {
+ mpz_swap (tq, q);
+ mpz_clear (tq);
+ }
+ if (r)
+ mpz_swap (tr, r);
+
+ mpz_clear (tr);
+
+ return rn != 0;
+ }
+}
+
+void
+mpz_cdiv_qr (mpz_t q, mpz_t r, const mpz_t n, const mpz_t d)
+{
+ mpz_div_qr (q, r, n, d, GMP_DIV_CEIL);
+}
+
+void
+mpz_fdiv_qr (mpz_t q, mpz_t r, const mpz_t n, const mpz_t d)
+{
+ mpz_div_qr (q, r, n, d, GMP_DIV_FLOOR);
+}
+
+void
+mpz_tdiv_qr (mpz_t q, mpz_t r, const mpz_t n, const mpz_t d)
+{
+ mpz_div_qr (q, r, n, d, GMP_DIV_TRUNC);
+}
+
+void
+mpz_cdiv_q (mpz_t q, const mpz_t n, const mpz_t d)
+{
+ mpz_div_qr (q, NULL, n, d, GMP_DIV_CEIL);
+}
+
+void
+mpz_fdiv_q (mpz_t q, const mpz_t n, const mpz_t d)
+{
+ mpz_div_qr (q, NULL, n, d, GMP_DIV_FLOOR);
+}
+
+void
+mpz_tdiv_q (mpz_t q, const mpz_t n, const mpz_t d)
+{
+ mpz_div_qr (q, NULL, n, d, GMP_DIV_TRUNC);
+}
+
+void
+mpz_cdiv_r (mpz_t r, const mpz_t n, const mpz_t d)
+{
+ mpz_div_qr (NULL, r, n, d, GMP_DIV_CEIL);
+}
+
+void
+mpz_fdiv_r (mpz_t r, const mpz_t n, const mpz_t d)
+{
+ mpz_div_qr (NULL, r, n, d, GMP_DIV_FLOOR);
+}
+
+void
+mpz_tdiv_r (mpz_t r, const mpz_t n, const mpz_t d)
+{
+ mpz_div_qr (NULL, r, n, d, GMP_DIV_TRUNC);
+}
+
+void
+mpz_mod (mpz_t r, const mpz_t n, const mpz_t d)
+{
+ mpz_div_qr (NULL, r, n, d, d->_mp_size >= 0 ? GMP_DIV_FLOOR : GMP_DIV_CEIL);
+}
+
+static void
+mpz_div_q_2exp (mpz_t q, const mpz_t u, mp_bitcnt_t bit_index,
+ enum mpz_div_round_mode mode)
+{
+ mp_size_t un, qn;
+ mp_size_t limb_cnt;
+ mp_ptr qp;
+ int adjust;
+
+ un = u->_mp_size;
+ if (un == 0)
+ {
+ q->_mp_size = 0;
+ return;
+ }
+ limb_cnt = bit_index / GMP_LIMB_BITS;
+ qn = GMP_ABS (un) - limb_cnt;
+ bit_index %= GMP_LIMB_BITS;
+
+ if (mode == ((un > 0) ? GMP_DIV_CEIL : GMP_DIV_FLOOR)) /* un != 0 here. */
+ /* Note: Below, the final indexing at limb_cnt is valid because at
+ that point we have qn > 0. */
+ adjust = (qn <= 0
+ || !mpn_zero_p (u->_mp_d, limb_cnt)
+ || (u->_mp_d[limb_cnt]
+ & (((mp_limb_t) 1 << bit_index) - 1)));
+ else
+ adjust = 0;
+
+ if (qn <= 0)
+ qn = 0;
+ else
+ {
+ qp = MPZ_REALLOC (q, qn);
+
+ if (bit_index != 0)
+ {
+ mpn_rshift (qp, u->_mp_d + limb_cnt, qn, bit_index);
+ qn -= qp[qn - 1] == 0;
+ }
+ else
+ {
+ mpn_copyi (qp, u->_mp_d + limb_cnt, qn);
+ }
+ }
+
+ q->_mp_size = qn;
+
+ if (adjust)
+ mpz_add_ui (q, q, 1);
+ if (un < 0)
+ mpz_neg (q, q);
+}
+
+static void
+mpz_div_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t bit_index,
+ enum mpz_div_round_mode mode)
+{
+ mp_size_t us, un, rn;
+ mp_ptr rp;
+ mp_limb_t mask;
+
+ us = u->_mp_size;
+ if (us == 0 || bit_index == 0)
+ {
+ r->_mp_size = 0;
+ return;
+ }
+ rn = (bit_index + GMP_LIMB_BITS - 1) / GMP_LIMB_BITS;
+ assert (rn > 0);
+
+ rp = MPZ_REALLOC (r, rn);
+ un = GMP_ABS (us);
+
+ mask = GMP_LIMB_MAX >> (rn * GMP_LIMB_BITS - bit_index);
+
+ if (rn > un)
+ {
+ /* Quotient (with truncation) is zero, and remainder is
+ non-zero */
+ if (mode == ((us > 0) ? GMP_DIV_CEIL : GMP_DIV_FLOOR)) /* us != 0 here. */
+ {
+ /* Have to negate and sign extend. */
+ mp_size_t i;
+
+ gmp_assert_nocarry (! mpn_neg (rp, u->_mp_d, un));
+ for (i = un; i < rn - 1; i++)
+ rp[i] = GMP_LIMB_MAX;
+
+ rp[rn-1] = mask;
+ us = -us;
+ }
+ else
+ {
+ /* Just copy */
+ if (r != u)
+ mpn_copyi (rp, u->_mp_d, un);
+
+ rn = un;
+ }
+ }
+ else
+ {
+ if (r != u)
+ mpn_copyi (rp, u->_mp_d, rn - 1);
+
+ rp[rn-1] = u->_mp_d[rn-1] & mask;
+
+ if (mode == ((us > 0) ? GMP_DIV_CEIL : GMP_DIV_FLOOR)) /* us != 0 here. */
+ {
+ /* If r != 0, compute 2^{bit_count} - r. */
+ mpn_neg (rp, rp, rn);
+
+ rp[rn-1] &= mask;
+
+ /* us is not used for anything else, so we can modify it
+ here to indicate flipped sign. */
+ us = -us;
+ }
+ }
+ rn = mpn_normalized_size (rp, rn);
+ r->_mp_size = us < 0 ? -rn : rn;
+}
+
+void
+mpz_cdiv_q_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt)
+{
+ mpz_div_q_2exp (r, u, cnt, GMP_DIV_CEIL);
+}
+
+void
+mpz_fdiv_q_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt)
+{
+ mpz_div_q_2exp (r, u, cnt, GMP_DIV_FLOOR);
+}
+
+void
+mpz_tdiv_q_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt)
+{
+ mpz_div_q_2exp (r, u, cnt, GMP_DIV_TRUNC);
+}
+
+void
+mpz_cdiv_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt)
+{
+ mpz_div_r_2exp (r, u, cnt, GMP_DIV_CEIL);
+}
+
+void
+mpz_fdiv_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt)
+{
+ mpz_div_r_2exp (r, u, cnt, GMP_DIV_FLOOR);
+}
+
+void
+mpz_tdiv_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt)
+{
+ mpz_div_r_2exp (r, u, cnt, GMP_DIV_TRUNC);
+}
+
+void
+mpz_divexact (mpz_t q, const mpz_t n, const mpz_t d)
+{
+ gmp_assert_nocarry (mpz_div_qr (q, NULL, n, d, GMP_DIV_TRUNC));
+}
+
+int
+mpz_divisible_p (const mpz_t n, const mpz_t d)
+{
+ return mpz_div_qr (NULL, NULL, n, d, GMP_DIV_TRUNC) == 0;
+}
+
+int
+mpz_congruent_p (const mpz_t a, const mpz_t b, const mpz_t m)
+{
+ mpz_t t;
+ int res;
+
+ /* a == b (mod 0) iff a == b */
+ if (mpz_sgn (m) == 0)
+ return (mpz_cmp (a, b) == 0);
+
+ mpz_init (t);
+ mpz_sub (t, a, b);
+ res = mpz_divisible_p (t, m);
+ mpz_clear (t);
+
+ return res;
+}
+
+static unsigned long
+mpz_div_qr_ui (mpz_t q, mpz_t r,
+ const mpz_t n, unsigned long d, enum mpz_div_round_mode mode)
+{
+ mp_size_t ns, qn;
+ mp_ptr qp;
+ mp_limb_t rl;
+ mp_size_t rs;
+
+ ns = n->_mp_size;
+ if (ns == 0)
+ {
+ if (q)
+ q->_mp_size = 0;
+ if (r)
+ r->_mp_size = 0;
+ return 0;
+ }
+
+ qn = GMP_ABS (ns);
+ if (q)
+ qp = MPZ_REALLOC (q, qn);
+ else
+ qp = NULL;
+
+ rl = mpn_div_qr_1 (qp, n->_mp_d, qn, d);
+ assert (rl < d);
+
+ rs = rl > 0;
+ rs = (ns < 0) ? -rs : rs;
+
+ if (rl > 0 && ( (mode == GMP_DIV_FLOOR && ns < 0)
+ || (mode == GMP_DIV_CEIL && ns >= 0)))
+ {
+ if (q)
+ gmp_assert_nocarry (mpn_add_1 (qp, qp, qn, 1));
+ rl = d - rl;
+ rs = -rs;
+ }
+
+ if (r)
+ {
+ MPZ_REALLOC (r, 1)[0] = rl;
+ r->_mp_size = rs;
+ }
+ if (q)
+ {
+ qn -= (qp[qn-1] == 0);
+ assert (qn == 0 || qp[qn-1] > 0);
+
+ q->_mp_size = (ns < 0) ? - qn : qn;
+ }
+
+ return rl;
+}
+
+unsigned long
+mpz_cdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, unsigned long d)
+{
+ return mpz_div_qr_ui (q, r, n, d, GMP_DIV_CEIL);
+}
+
+unsigned long
+mpz_fdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, unsigned long d)
+{
+ return mpz_div_qr_ui (q, r, n, d, GMP_DIV_FLOOR);
+}
+
+unsigned long
+mpz_tdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, unsigned long d)
+{
+ return mpz_div_qr_ui (q, r, n, d, GMP_DIV_TRUNC);
+}
+
+unsigned long
+mpz_cdiv_q_ui (mpz_t q, const mpz_t n, unsigned long d)
+{
+ return mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_CEIL);
+}
+
+unsigned long
+mpz_fdiv_q_ui (mpz_t q, const mpz_t n, unsigned long d)
+{
+ return mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_FLOOR);
+}
+
+unsigned long
+mpz_tdiv_q_ui (mpz_t q, const mpz_t n, unsigned long d)
+{
+ return mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_TRUNC);
+}
+
+unsigned long
+mpz_cdiv_r_ui (mpz_t r, const mpz_t n, unsigned long d)
+{
+ return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_CEIL);
+}
+unsigned long
+mpz_fdiv_r_ui (mpz_t r, const mpz_t n, unsigned long d)
+{
+ return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_FLOOR);
+}
+unsigned long
+mpz_tdiv_r_ui (mpz_t r, const mpz_t n, unsigned long d)
+{
+ return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_TRUNC);
+}
+
+unsigned long
+mpz_cdiv_ui (const mpz_t n, unsigned long d)
+{
+ return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_CEIL);
+}
+
+unsigned long
+mpz_fdiv_ui (const mpz_t n, unsigned long d)
+{
+ return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_FLOOR);
+}
+
+unsigned long
+mpz_tdiv_ui (const mpz_t n, unsigned long d)
+{
+ return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_TRUNC);
+}
+
+unsigned long
+mpz_mod_ui (mpz_t r, const mpz_t n, unsigned long d)
+{
+ return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_FLOOR);
+}
+
+void
+mpz_divexact_ui (mpz_t q, const mpz_t n, unsigned long d)
+{
+ gmp_assert_nocarry (mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_TRUNC));
+}
+
+int
+mpz_divisible_ui_p (const mpz_t n, unsigned long d)
+{
+ return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_TRUNC) == 0;
+}
+
+
+/* GCD */
+static mp_limb_t
+mpn_gcd_11 (mp_limb_t u, mp_limb_t v)
+{
+ unsigned shift;
+
+ assert ( (u | v) > 0);
+
+ if (u == 0)
+ return v;
+ else if (v == 0)
+ return u;
+
+ gmp_ctz (shift, u | v);
+
+ u >>= shift;
+ v >>= shift;
+
+ if ( (u & 1) == 0)
+ MP_LIMB_T_SWAP (u, v);
+
+ while ( (v & 1) == 0)
+ v >>= 1;
+
+ while (u != v)
+ {
+ if (u > v)
+ {
+ u -= v;
+ do
+ u >>= 1;
+ while ( (u & 1) == 0);
+ }
+ else
+ {
+ v -= u;
+ do
+ v >>= 1;
+ while ( (v & 1) == 0);
+ }
+ }
+ return u << shift;
+}
+
+unsigned long
+mpz_gcd_ui (mpz_t g, const mpz_t u, unsigned long v)
+{
+ mp_size_t un;
+
+ if (v == 0)
+ {
+ if (g)
+ mpz_abs (g, u);
+ }
+ else
+ {
+ un = GMP_ABS (u->_mp_size);
+ if (un != 0)
+ v = mpn_gcd_11 (mpn_div_qr_1 (NULL, u->_mp_d, un, v), v);
+
+ if (g)
+ mpz_set_ui (g, v);
+ }
+
+ return v;
+}
+
+static mp_bitcnt_t
+mpz_make_odd (mpz_t r)
+{
+ mp_bitcnt_t shift;
+
+ assert (r->_mp_size > 0);
+ /* Count trailing zeros, equivalent to mpn_scan1, because we know that there is a 1 */
+ shift = mpn_common_scan (r->_mp_d[0], 0, r->_mp_d, 0, 0);
+ mpz_tdiv_q_2exp (r, r, shift);
+
+ return shift;
+}
+
+void
+mpz_gcd (mpz_t g, const mpz_t u, const mpz_t v)
+{
+ mpz_t tu, tv;
+ mp_bitcnt_t uz, vz, gz;
+
+ if (u->_mp_size == 0)
+ {
+ mpz_abs (g, v);
+ return;
+ }
+ if (v->_mp_size == 0)
+ {
+ mpz_abs (g, u);
+ return;
+ }
+
+ mpz_init (tu);
+ mpz_init (tv);
+
+ mpz_abs (tu, u);
+ uz = mpz_make_odd (tu);
+ mpz_abs (tv, v);
+ vz = mpz_make_odd (tv);
+ gz = GMP_MIN (uz, vz);
+
+ if (tu->_mp_size < tv->_mp_size)
+ mpz_swap (tu, tv);
+
+ mpz_tdiv_r (tu, tu, tv);
+ if (tu->_mp_size == 0)
+ {
+ mpz_swap (g, tv);
+ }
+ else
+ for (;;)
+ {
+ int c;
+
+ mpz_make_odd (tu);
+ c = mpz_cmp (tu, tv);
+ if (c == 0)
+ {
+ mpz_swap (g, tu);
+ break;
+ }
+ if (c < 0)
+ mpz_swap (tu, tv);
+
+ if (tv->_mp_size == 1)
+ {
+ mp_limb_t vl = tv->_mp_d[0];
+ mp_limb_t ul = mpz_tdiv_ui (tu, vl);
+ mpz_set_ui (g, mpn_gcd_11 (ul, vl));
+ break;
+ }
+ mpz_sub (tu, tu, tv);
+ }
+ mpz_clear (tu);
+ mpz_clear (tv);
+ mpz_mul_2exp (g, g, gz);
+}
+
+void
+mpz_gcdext (mpz_t g, mpz_t s, mpz_t t, const mpz_t u, const mpz_t v)
+{
+ mpz_t tu, tv, s0, s1, t0, t1;
+ mp_bitcnt_t uz, vz, gz;
+ mp_bitcnt_t power;
+
+ if (u->_mp_size == 0)
+ {
+ /* g = 0 u + sgn(v) v */
+ signed long sign = mpz_sgn (v);
+ mpz_abs (g, v);
+ if (s)
+ mpz_set_ui (s, 0);
+ if (t)
+ mpz_set_si (t, sign);
+ return;
+ }
+
+ if (v->_mp_size == 0)
+ {
+ /* g = sgn(u) u + 0 v */
+ signed long sign = mpz_sgn (u);
+ mpz_abs (g, u);
+ if (s)
+ mpz_set_si (s, sign);
+ if (t)
+ mpz_set_ui (t, 0);
+ return;
+ }
+
+ mpz_init (tu);
+ mpz_init (tv);
+ mpz_init (s0);
+ mpz_init (s1);
+ mpz_init (t0);
+ mpz_init (t1);
+
+ mpz_abs (tu, u);
+ uz = mpz_make_odd (tu);
+ mpz_abs (tv, v);
+ vz = mpz_make_odd (tv);
+ gz = GMP_MIN (uz, vz);
+
+ uz -= gz;
+ vz -= gz;
+
+ /* Cofactors corresponding to odd gcd. gz handled later. */
+ if (tu->_mp_size < tv->_mp_size)
+ {
+ mpz_swap (tu, tv);
+ MPZ_SRCPTR_SWAP (u, v);
+ MPZ_PTR_SWAP (s, t);
+ MP_BITCNT_T_SWAP (uz, vz);
+ }
+
+ /* Maintain
+ *
+ * u = t0 tu + t1 tv
+ * v = s0 tu + s1 tv
+ *
+ * where u and v denote the inputs with common factors of two
+ * eliminated, and det (s0, t0; s1, t1) = 2^p. Then
+ *
+ * 2^p tu = s1 u - t1 v
+ * 2^p tv = -s0 u + t0 v
+ */
+
+ /* After initial division, tu = q tv + tu', we have
+ *
+ * u = 2^uz (tu' + q tv)
+ * v = 2^vz tv
+ *
+ * or
+ *
+ * t0 = 2^uz, t1 = 2^uz q
+ * s0 = 0, s1 = 2^vz
+ */
+
+ mpz_setbit (t0, uz);
+ mpz_tdiv_qr (t1, tu, tu, tv);
+ mpz_mul_2exp (t1, t1, uz);
+
+ mpz_setbit (s1, vz);
+ power = uz + vz;
+
+ if (tu->_mp_size > 0)
+ {
+ mp_bitcnt_t shift;
+ shift = mpz_make_odd (tu);
+ mpz_mul_2exp (t0, t0, shift);
+ mpz_mul_2exp (s0, s0, shift);
+ power += shift;
+
+ for (;;)
+ {
+ int c;
+ c = mpz_cmp (tu, tv);
+ if (c == 0)
+ break;
+
+ if (c < 0)
+ {
+ /* tv = tv' + tu
+ *
+ * u = t0 tu + t1 (tv' + tu) = (t0 + t1) tu + t1 tv'
+ * v = s0 tu + s1 (tv' + tu) = (s0 + s1) tu + s1 tv' */
+
+ mpz_sub (tv, tv, tu);
+ mpz_add (t0, t0, t1);
+ mpz_add (s0, s0, s1);
+
+ shift = mpz_make_odd (tv);
+ mpz_mul_2exp (t1, t1, shift);
+ mpz_mul_2exp (s1, s1, shift);
+ }
+ else
+ {
+ mpz_sub (tu, tu, tv);
+ mpz_add (t1, t0, t1);
+ mpz_add (s1, s0, s1);
+
+ shift = mpz_make_odd (tu);
+ mpz_mul_2exp (t0, t0, shift);
+ mpz_mul_2exp (s0, s0, shift);
+ }
+ power += shift;
+ }
+ }
+
+ /* Now tv = odd part of gcd, and -s0 and t0 are corresponding
+ cofactors. */
+
+ mpz_mul_2exp (tv, tv, gz);
+ mpz_neg (s0, s0);
+
+ /* 2^p g = s0 u + t0 v. Eliminate one factor of two at a time. To
+ adjust cofactors, we need u / g and v / g */
+
+ mpz_divexact (s1, v, tv);
+ mpz_abs (s1, s1);
+ mpz_divexact (t1, u, tv);
+ mpz_abs (t1, t1);
+
+ while (power-- > 0)
+ {
+ /* s0 u + t0 v = (s0 - v/g) u - (t0 + u/g) v */
+ if (mpz_odd_p (s0) || mpz_odd_p (t0))
+ {
+ mpz_sub (s0, s0, s1);
+ mpz_add (t0, t0, t1);
+ }
+ mpz_divexact_ui (s0, s0, 2);
+ mpz_divexact_ui (t0, t0, 2);
+ }
+
+ /* Arrange so that |s| < |u| / 2g */
+ mpz_add (s1, s0, s1);
+ if (mpz_cmpabs (s0, s1) > 0)
+ {
+ mpz_swap (s0, s1);
+ mpz_sub (t0, t0, t1);
+ }
+ if (u->_mp_size < 0)
+ mpz_neg (s0, s0);
+ if (v->_mp_size < 0)
+ mpz_neg (t0, t0);
+
+ mpz_swap (g, tv);
+ if (s)
+ mpz_swap (s, s0);
+ if (t)
+ mpz_swap (t, t0);
+
+ mpz_clear (tu);
+ mpz_clear (tv);
+ mpz_clear (s0);
+ mpz_clear (s1);
+ mpz_clear (t0);
+ mpz_clear (t1);
+}
+
+void
+mpz_lcm (mpz_t r, const mpz_t u, const mpz_t v)
+{
+ mpz_t g;
+
+ if (u->_mp_size == 0 || v->_mp_size == 0)
+ {
+ r->_mp_size = 0;
+ return;
+ }
+
+ mpz_init (g);
+
+ mpz_gcd (g, u, v);
+ mpz_divexact (g, u, g);
+ mpz_mul (r, g, v);
+
+ mpz_clear (g);
+ mpz_abs (r, r);
+}
+
+void
+mpz_lcm_ui (mpz_t r, const mpz_t u, unsigned long v)
+{
+ if (v == 0 || u->_mp_size == 0)
+ {
+ r->_mp_size = 0;
+ return;
+ }
+
+ v /= mpz_gcd_ui (NULL, u, v);
+ mpz_mul_ui (r, u, v);
+
+ mpz_abs (r, r);
+}
+
+int
+mpz_invert (mpz_t r, const mpz_t u, const mpz_t m)
+{
+ mpz_t g, tr;
+ int invertible;
+
+ if (u->_mp_size == 0 || mpz_cmpabs_ui (m, 1) <= 0)
+ return 0;
+
+ mpz_init (g);
+ mpz_init (tr);
+
+ mpz_gcdext (g, tr, NULL, u, m);
+ invertible = (mpz_cmp_ui (g, 1) == 0);
+
+ if (invertible)
+ {
+ if (tr->_mp_size < 0)
+ {
+ if (m->_mp_size >= 0)
+ mpz_add (tr, tr, m);
+ else
+ mpz_sub (tr, tr, m);
+ }
+ mpz_swap (r, tr);
+ }
+
+ mpz_clear (g);
+ mpz_clear (tr);
+ return invertible;
+}
+
+
+/* Higher level operations (sqrt, pow and root) */
+
+void
+mpz_pow_ui (mpz_t r, const mpz_t b, unsigned long e)
+{
+ unsigned long bit;
+ mpz_t tr;
+ mpz_init_set_ui (tr, 1);
+
+ bit = GMP_ULONG_HIGHBIT;
+ do
+ {
+ mpz_mul (tr, tr, tr);
+ if (e & bit)
+ mpz_mul (tr, tr, b);
+ bit >>= 1;
+ }
+ while (bit > 0);
+
+ mpz_swap (r, tr);
+ mpz_clear (tr);
+}
+
+void
+mpz_ui_pow_ui (mpz_t r, unsigned long blimb, unsigned long e)
+{
+ mpz_t b;
+ mpz_pow_ui (r, mpz_roinit_normal_n (b, &blimb, blimb != 0), e);
+}
+
+void
+mpz_powm (mpz_t r, const mpz_t b, const mpz_t e, const mpz_t m)
+{
+ mpz_t tr;
+ mpz_t base;
+ mp_size_t en, mn;
+ mp_srcptr mp;
+ struct gmp_div_inverse minv;
+ unsigned shift;
+ mp_ptr tp = NULL;
+
+ en = GMP_ABS (e->_mp_size);
+ mn = GMP_ABS (m->_mp_size);
+ if (mn == 0)
+ gmp_die ("mpz_powm: Zero modulo.");
+
+ if (en == 0)
+ {
+ mpz_set_ui (r, 1);
+ return;
+ }
+
+ mp = m->_mp_d;
+ mpn_div_qr_invert (&minv, mp, mn);
+ shift = minv.shift;
+
+ if (shift > 0)
+ {
+ /* To avoid shifts, we do all our reductions, except the final
+ one, using a *normalized* m. */
+ minv.shift = 0;
+
+ tp = gmp_xalloc_limbs (mn);
+ gmp_assert_nocarry (mpn_lshift (tp, mp, mn, shift));
+ mp = tp;
+ }
+
+ mpz_init (base);
+
+ if (e->_mp_size < 0)
+ {
+ if (!mpz_invert (base, b, m))
+ gmp_die ("mpz_powm: Negative exponent and non-invertible base.");
+ }
+ else
+ {
+ mp_size_t bn;
+ mpz_abs (base, b);
+
+ bn = base->_mp_size;
+ if (bn >= mn)
+ {
+ mpn_div_qr_preinv (NULL, base->_mp_d, base->_mp_size, mp, mn, &minv);
+ bn = mn;
+ }
+
+ /* We have reduced the absolute value. Now take care of the
+ sign. Note that we get zero represented non-canonically as
+ m. */
+ if (b->_mp_size < 0)
+ {
+ mp_ptr bp = MPZ_REALLOC (base, mn);
+ gmp_assert_nocarry (mpn_sub (bp, mp, mn, bp, bn));
+ bn = mn;
+ }
+ base->_mp_size = mpn_normalized_size (base->_mp_d, bn);
+ }
+ mpz_init_set_ui (tr, 1);
+
+ while (--en >= 0)
+ {
+ mp_limb_t w = e->_mp_d[en];
+ mp_limb_t bit;
+
+ bit = GMP_LIMB_HIGHBIT;
+ do
+ {
+ mpz_mul (tr, tr, tr);
+ if (w & bit)
+ mpz_mul (tr, tr, base);
+ if (tr->_mp_size > mn)
+ {
+ mpn_div_qr_preinv (NULL, tr->_mp_d, tr->_mp_size, mp, mn, &minv);
+ tr->_mp_size = mpn_normalized_size (tr->_mp_d, mn);
+ }
+ bit >>= 1;
+ }
+ while (bit > 0);
+ }
+
+ /* Final reduction */
+ if (tr->_mp_size >= mn)
+ {
+ minv.shift = shift;
+ mpn_div_qr_preinv (NULL, tr->_mp_d, tr->_mp_size, mp, mn, &minv);
+ tr->_mp_size = mpn_normalized_size (tr->_mp_d, mn);
+ }
+ if (tp)
+ gmp_free (tp);
+
+ mpz_swap (r, tr);
+ mpz_clear (tr);
+ mpz_clear (base);
+}
+
+void
+mpz_powm_ui (mpz_t r, const mpz_t b, unsigned long elimb, const mpz_t m)
+{
+ mpz_t e;
+ mpz_powm (r, b, mpz_roinit_normal_n (e, &elimb, elimb != 0), m);
+}
+
+/* x=trunc(y^(1/z)), r=y-x^z */
+void
+mpz_rootrem (mpz_t x, mpz_t r, const mpz_t y, unsigned long z)
+{
+ int sgn;
+ mpz_t t, u;
+
+ sgn = y->_mp_size < 0;
+ if ((~z & sgn) != 0)
+ gmp_die ("mpz_rootrem: Negative argument, with even root.");
+ if (z == 0)
+ gmp_die ("mpz_rootrem: Zeroth root.");
+
+ if (mpz_cmpabs_ui (y, 1) <= 0) {
+ if (x)
+ mpz_set (x, y);
+ if (r)
+ r->_mp_size = 0;
+ return;
+ }
+
+ mpz_init (u);
+ mpz_init (t);
+ mpz_setbit (t, mpz_sizeinbase (y, 2) / z + 1);
+
+ if (z == 2) /* simplify sqrt loop: z-1 == 1 */
+ do {
+ mpz_swap (u, t); /* u = x */
+ mpz_tdiv_q (t, y, u); /* t = y/x */
+ mpz_add (t, t, u); /* t = y/x + x */
+ mpz_tdiv_q_2exp (t, t, 1); /* x'= (y/x + x)/2 */
+ } while (mpz_cmpabs (t, u) < 0); /* |x'| < |x| */
+ else /* z != 2 */ {
+ mpz_t v;
+
+ mpz_init (v);
+ if (sgn)
+ mpz_neg (t, t);
+
+ do {
+ mpz_swap (u, t); /* u = x */
+ mpz_pow_ui (t, u, z - 1); /* t = x^(z-1) */
+ mpz_tdiv_q (t, y, t); /* t = y/x^(z-1) */
+ mpz_mul_ui (v, u, z - 1); /* v = x*(z-1) */
+ mpz_add (t, t, v); /* t = y/x^(z-1) + x*(z-1) */
+ mpz_tdiv_q_ui (t, t, z); /* x'=(y/x^(z-1) + x*(z-1))/z */
+ } while (mpz_cmpabs (t, u) < 0); /* |x'| < |x| */
+
+ mpz_clear (v);
+ }
+
+ if (r) {
+ mpz_pow_ui (t, u, z);
+ mpz_sub (r, y, t);
+ }
+ if (x)
+ mpz_swap (x, u);
+ mpz_clear (u);
+ mpz_clear (t);
+}
+
+int
+mpz_root (mpz_t x, const mpz_t y, unsigned long z)
+{
+ int res;
+ mpz_t r;
+
+ mpz_init (r);
+ mpz_rootrem (x, r, y, z);
+ res = r->_mp_size == 0;
+ mpz_clear (r);
+
+ return res;
+}
+
+/* Compute s = floor(sqrt(u)) and r = u - s^2. Allows r == NULL */
+void
+mpz_sqrtrem (mpz_t s, mpz_t r, const mpz_t u)
+{
+ mpz_rootrem (s, r, u, 2);
+}
+
+void
+mpz_sqrt (mpz_t s, const mpz_t u)
+{
+ mpz_rootrem (s, NULL, u, 2);
+}
+
+int
+mpz_perfect_square_p (const mpz_t u)
+{
+ if (u->_mp_size <= 0)
+ return (u->_mp_size == 0);
+ else
+ return mpz_root (NULL, u, 2);
+}
+
+int
+mpn_perfect_square_p (mp_srcptr p, mp_size_t n)
+{
+ mpz_t t;
+
+ assert (n > 0);
+ assert (p [n-1] != 0);
+ return mpz_root (NULL, mpz_roinit_normal_n (t, p, n), 2);
+}
+
+mp_size_t
+mpn_sqrtrem (mp_ptr sp, mp_ptr rp, mp_srcptr p, mp_size_t n)
+{
+ mpz_t s, r, u;
+ mp_size_t res;
+
+ assert (n > 0);
+ assert (p [n-1] != 0);
+
+ mpz_init (r);
+ mpz_init (s);
+ mpz_rootrem (s, r, mpz_roinit_normal_n (u, p, n), 2);
+
+ assert (s->_mp_size == (n+1)/2);
+ mpn_copyd (sp, s->_mp_d, s->_mp_size);
+ mpz_clear (s);
+ res = r->_mp_size;
+ if (rp)
+ mpn_copyd (rp, r->_mp_d, res);
+ mpz_clear (r);
+ return res;
+}
+
+/* Combinatorics */
+
+void
+mpz_mfac_uiui (mpz_t x, unsigned long n, unsigned long m)
+{
+ mpz_set_ui (x, n + (n == 0));
+ if (m + 1 < 2) return;
+ while (n > m + 1)
+ mpz_mul_ui (x, x, n -= m);
+}
+
+void
+mpz_2fac_ui (mpz_t x, unsigned long n)
+{
+ mpz_mfac_uiui (x, n, 2);
+}
+
+void
+mpz_fac_ui (mpz_t x, unsigned long n)
+{
+ mpz_mfac_uiui (x, n, 1);
+}
+
+void
+mpz_bin_uiui (mpz_t r, unsigned long n, unsigned long k)
+{
+ mpz_t t;
+
+ mpz_set_ui (r, k <= n);
+
+ if (k > (n >> 1))
+ k = (k <= n) ? n - k : 0;
+
+ mpz_init (t);
+ mpz_fac_ui (t, k);
+
+ for (; k > 0; --k)
+ mpz_mul_ui (r, r, n--);
+
+ mpz_divexact (r, r, t);
+ mpz_clear (t);
+}
+
+
+/* Primality testing */
+static int
+gmp_millerrabin (const mpz_t n, const mpz_t nm1, mpz_t y,
+ const mpz_t q, mp_bitcnt_t k)
+{
+ assert (k > 0);
+
+ /* Caller must initialize y to the base. */
+ mpz_powm (y, y, q, n);
+
+ if (mpz_cmp_ui (y, 1) == 0 || mpz_cmp (y, nm1) == 0)
+ return 1;
+
+ while (--k > 0)
+ {
+ mpz_powm_ui (y, y, 2, n);
+ if (mpz_cmp (y, nm1) == 0)
+ return 1;
+ /* y == 1 means that the previous y was a non-trivial square root
+ of 1 (mod n). y == 0 means that n is a power of the base.
+ In either case, n is not prime. */
+ if (mpz_cmp_ui (y, 1) <= 0)
+ return 0;
+ }
+ return 0;
+}
+
+/* This product is 0xc0cfd797, and fits in 32 bits. */
+#define GMP_PRIME_PRODUCT \
+ (3UL*5UL*7UL*11UL*13UL*17UL*19UL*23UL*29UL)
+
+/* Bit (p+1)/2 is set, for each odd prime <= 61 */
+#define GMP_PRIME_MASK 0xc96996dcUL
+
+int
+mpz_probab_prime_p (const mpz_t n, int reps)
+{
+ mpz_t nm1;
+ mpz_t q;
+ mpz_t y;
+ mp_bitcnt_t k;
+ int is_prime;
+ int j;
+
+ /* Note that we use the absolute value of n only, for compatibility
+ with the real GMP. */
+ if (mpz_even_p (n))
+ return (mpz_cmpabs_ui (n, 2) == 0) ? 2 : 0;
+
+ /* Above test excludes n == 0 */
+ assert (n->_mp_size != 0);
+
+ if (mpz_cmpabs_ui (n, 64) < 0)
+ return (GMP_PRIME_MASK >> (n->_mp_d[0] >> 1)) & 2;
+
+ if (mpz_gcd_ui (NULL, n, GMP_PRIME_PRODUCT) != 1)
+ return 0;
+
+ /* All prime factors are >= 31. */
+ if (mpz_cmpabs_ui (n, 31*31) < 0)
+ return 2;
+
+ /* Use Miller-Rabin, with a deterministic sequence of bases, a[j] =
+ j^2 + j + 41 using Euler's polynomial. We potentially stop early,
+ if a[j] >= n - 1. Since n >= 31*31, this can happen only if reps >
+ 30 (a[30] == 971 > 31*31 == 961). */
+
+ mpz_init (nm1);
+ mpz_init (q);
+ mpz_init (y);
+
+ /* Find q and k, where q is odd and n = 1 + 2**k * q. */
+ nm1->_mp_size = mpz_abs_sub_ui (nm1, n, 1);
+ k = mpz_scan1 (nm1, 0);
+ mpz_tdiv_q_2exp (q, nm1, k);
+
+ for (j = 0, is_prime = 1; is_prime & (j < reps); j++)
+ {
+ mpz_set_ui (y, (unsigned long) j*j+j+41);
+ if (mpz_cmp (y, nm1) >= 0)
+ {
+ /* Don't try any further bases. This "early" break does not affect
+ the result for any reasonable reps value (<=5000 was tested) */
+ assert (j >= 30);
+ break;
+ }
+ is_prime = gmp_millerrabin (n, nm1, y, q, k);
+ }
+ mpz_clear (nm1);
+ mpz_clear (q);
+ mpz_clear (y);
+
+ return is_prime;
+}
+
+
+/* Logical operations and bit manipulation. */
+
+/* Numbers are treated as if represented in two's complement (and
+ infinitely sign extended). For a negative values we get the two's
+ complement from -x = ~x + 1, where ~ is bitwise complement.
+ Negation transforms
+
+ xxxx10...0
+
+ into
+
+ yyyy10...0
+
+ where yyyy is the bitwise complement of xxxx. So least significant
+ bits, up to and including the first one bit, are unchanged, and
+ the more significant bits are all complemented.
+
+ To change a bit from zero to one in a negative number, subtract the
+ corresponding power of two from the absolute value. This can never
+ underflow. To change a bit from one to zero, add the corresponding
+ power of two, and this might overflow. E.g., if x = -001111, the
+ two's complement is 110001. Clearing the least significant bit, we
+ get two's complement 110000, and -010000. */
+
+int
+mpz_tstbit (const mpz_t d, mp_bitcnt_t bit_index)
+{
+ mp_size_t limb_index;
+ unsigned shift;
+ mp_size_t ds;
+ mp_size_t dn;
+ mp_limb_t w;
+ int bit;
+
+ ds = d->_mp_size;
+ dn = GMP_ABS (ds);
+ limb_index = bit_index / GMP_LIMB_BITS;
+ if (limb_index >= dn)
+ return ds < 0;
+
+ shift = bit_index % GMP_LIMB_BITS;
+ w = d->_mp_d[limb_index];
+ bit = (w >> shift) & 1;
+
+ if (ds < 0)
+ {
+ /* d < 0. Check if any of the bits below is set: If so, our bit
+ must be complemented. */
+ if (shift > 0 && (w << (GMP_LIMB_BITS - shift)) > 0)
+ return bit ^ 1;
+ while (--limb_index >= 0)
+ if (d->_mp_d[limb_index] > 0)
+ return bit ^ 1;
+ }
+ return bit;
+}
+
+static void
+mpz_abs_add_bit (mpz_t d, mp_bitcnt_t bit_index)
+{
+ mp_size_t dn, limb_index;
+ mp_limb_t bit;
+ mp_ptr dp;
+
+ dn = GMP_ABS (d->_mp_size);
+
+ limb_index = bit_index / GMP_LIMB_BITS;
+ bit = (mp_limb_t) 1 << (bit_index % GMP_LIMB_BITS);
+
+ if (limb_index >= dn)
+ {
+ mp_size_t i;
+ /* The bit should be set outside of the end of the number.
+ We have to increase the size of the number. */
+ dp = MPZ_REALLOC (d, limb_index + 1);
+
+ dp[limb_index] = bit;
+ for (i = dn; i < limb_index; i++)
+ dp[i] = 0;
+ dn = limb_index + 1;
+ }
+ else
+ {
+ mp_limb_t cy;
+
+ dp = d->_mp_d;
+
+ cy = mpn_add_1 (dp + limb_index, dp + limb_index, dn - limb_index, bit);
+ if (cy > 0)
+ {
+ dp = MPZ_REALLOC (d, dn + 1);
+ dp[dn++] = cy;
+ }
+ }
+
+ d->_mp_size = (d->_mp_size < 0) ? - dn : dn;
+}
+
+static void
+mpz_abs_sub_bit (mpz_t d, mp_bitcnt_t bit_index)
+{
+ mp_size_t dn, limb_index;
+ mp_ptr dp;
+ mp_limb_t bit;
+
+ dn = GMP_ABS (d->_mp_size);
+ dp = d->_mp_d;
+
+ limb_index = bit_index / GMP_LIMB_BITS;
+ bit = (mp_limb_t) 1 << (bit_index % GMP_LIMB_BITS);
+
+ assert (limb_index < dn);
+
+ gmp_assert_nocarry (mpn_sub_1 (dp + limb_index, dp + limb_index,
+ dn - limb_index, bit));
+ dn = mpn_normalized_size (dp, dn);
+ d->_mp_size = (d->_mp_size < 0) ? - dn : dn;
+}
+
+void
+mpz_setbit (mpz_t d, mp_bitcnt_t bit_index)
+{
+ if (!mpz_tstbit (d, bit_index))
+ {
+ if (d->_mp_size >= 0)
+ mpz_abs_add_bit (d, bit_index);
+ else
+ mpz_abs_sub_bit (d, bit_index);
+ }
+}
+
+void
+mpz_clrbit (mpz_t d, mp_bitcnt_t bit_index)
+{
+ if (mpz_tstbit (d, bit_index))
+ {
+ if (d->_mp_size >= 0)
+ mpz_abs_sub_bit (d, bit_index);
+ else
+ mpz_abs_add_bit (d, bit_index);
+ }
+}
+
+void
+mpz_combit (mpz_t d, mp_bitcnt_t bit_index)
+{
+ if (mpz_tstbit (d, bit_index) ^ (d->_mp_size < 0))
+ mpz_abs_sub_bit (d, bit_index);
+ else
+ mpz_abs_add_bit (d, bit_index);
+}
+
+void
+mpz_com (mpz_t r, const mpz_t u)
+{
+ mpz_neg (r, u);
+ mpz_sub_ui (r, r, 1);
+}
+
+void
+mpz_and (mpz_t r, const mpz_t u, const mpz_t v)
+{
+ mp_size_t un, vn, rn, i;
+ mp_ptr up, vp, rp;
+
+ mp_limb_t ux, vx, rx;
+ mp_limb_t uc, vc, rc;
+ mp_limb_t ul, vl, rl;
+
+ un = GMP_ABS (u->_mp_size);
+ vn = GMP_ABS (v->_mp_size);
+ if (un < vn)
+ {
+ MPZ_SRCPTR_SWAP (u, v);
+ MP_SIZE_T_SWAP (un, vn);
+ }
+ if (vn == 0)
+ {
+ r->_mp_size = 0;
+ return;
+ }
+
+ uc = u->_mp_size < 0;
+ vc = v->_mp_size < 0;
+ rc = uc & vc;
+
+ ux = -uc;
+ vx = -vc;
+ rx = -rc;
+
+ /* If the smaller input is positive, higher limbs don't matter. */
+ rn = vx ? un : vn;
+
+ rp = MPZ_REALLOC (r, rn + (mp_size_t) rc);
+
+ up = u->_mp_d;
+ vp = v->_mp_d;
+
+ i = 0;
+ do
+ {
+ ul = (up[i] ^ ux) + uc;
+ uc = ul < uc;
+
+ vl = (vp[i] ^ vx) + vc;
+ vc = vl < vc;
+
+ rl = ( (ul & vl) ^ rx) + rc;
+ rc = rl < rc;
+ rp[i] = rl;
+ }
+ while (++i < vn);
+ assert (vc == 0);
+
+ for (; i < rn; i++)
+ {
+ ul = (up[i] ^ ux) + uc;
+ uc = ul < uc;
+
+ rl = ( (ul & vx) ^ rx) + rc;
+ rc = rl < rc;
+ rp[i] = rl;
+ }
+ if (rc)
+ rp[rn++] = rc;
+ else
+ rn = mpn_normalized_size (rp, rn);
+
+ r->_mp_size = rx ? -rn : rn;
+}
+
+void
+mpz_ior (mpz_t r, const mpz_t u, const mpz_t v)
+{
+ mp_size_t un, vn, rn, i;
+ mp_ptr up, vp, rp;
+
+ mp_limb_t ux, vx, rx;
+ mp_limb_t uc, vc, rc;
+ mp_limb_t ul, vl, rl;
+
+ un = GMP_ABS (u->_mp_size);
+ vn = GMP_ABS (v->_mp_size);
+ if (un < vn)
+ {
+ MPZ_SRCPTR_SWAP (u, v);
+ MP_SIZE_T_SWAP (un, vn);
+ }
+ if (vn == 0)
+ {
+ mpz_set (r, u);
+ return;
+ }
+
+ uc = u->_mp_size < 0;
+ vc = v->_mp_size < 0;
+ rc = uc | vc;
+
+ ux = -uc;
+ vx = -vc;
+ rx = -rc;
+
+ /* If the smaller input is negative, by sign extension higher limbs
+ don't matter. */
+ rn = vx ? vn : un;
+
+ rp = MPZ_REALLOC (r, rn + (mp_size_t) rc);
+
+ up = u->_mp_d;
+ vp = v->_mp_d;
+
+ i = 0;
+ do
+ {
+ ul = (up[i] ^ ux) + uc;
+ uc = ul < uc;
+
+ vl = (vp[i] ^ vx) + vc;
+ vc = vl < vc;
+
+ rl = ( (ul | vl) ^ rx) + rc;
+ rc = rl < rc;
+ rp[i] = rl;
+ }
+ while (++i < vn);
+ assert (vc == 0);
+
+ for (; i < rn; i++)
+ {
+ ul = (up[i] ^ ux) + uc;
+ uc = ul < uc;
+
+ rl = ( (ul | vx) ^ rx) + rc;
+ rc = rl < rc;
+ rp[i] = rl;
+ }
+ if (rc)
+ rp[rn++] = rc;
+ else
+ rn = mpn_normalized_size (rp, rn);
+
+ r->_mp_size = rx ? -rn : rn;
+}
+
+void
+mpz_xor (mpz_t r, const mpz_t u, const mpz_t v)
+{
+ mp_size_t un, vn, i;
+ mp_ptr up, vp, rp;
+
+ mp_limb_t ux, vx, rx;
+ mp_limb_t uc, vc, rc;
+ mp_limb_t ul, vl, rl;
+
+ un = GMP_ABS (u->_mp_size);
+ vn = GMP_ABS (v->_mp_size);
+ if (un < vn)
+ {
+ MPZ_SRCPTR_SWAP (u, v);
+ MP_SIZE_T_SWAP (un, vn);
+ }
+ if (vn == 0)
+ {
+ mpz_set (r, u);
+ return;
+ }
+
+ uc = u->_mp_size < 0;
+ vc = v->_mp_size < 0;
+ rc = uc ^ vc;
+
+ ux = -uc;
+ vx = -vc;
+ rx = -rc;
+
+ rp = MPZ_REALLOC (r, un + (mp_size_t) rc);
+
+ up = u->_mp_d;
+ vp = v->_mp_d;
+
+ i = 0;
+ do
+ {
+ ul = (up[i] ^ ux) + uc;
+ uc = ul < uc;
+
+ vl = (vp[i] ^ vx) + vc;
+ vc = vl < vc;
+
+ rl = (ul ^ vl ^ rx) + rc;
+ rc = rl < rc;
+ rp[i] = rl;
+ }
+ while (++i < vn);
+ assert (vc == 0);
+
+ for (; i < un; i++)
+ {
+ ul = (up[i] ^ ux) + uc;
+ uc = ul < uc;
+
+ rl = (ul ^ ux) + rc;
+ rc = rl < rc;
+ rp[i] = rl;
+ }
+ if (rc)
+ rp[un++] = rc;
+ else
+ un = mpn_normalized_size (rp, un);
+
+ r->_mp_size = rx ? -un : un;
+}
+
+static unsigned
+gmp_popcount_limb (mp_limb_t x)
+{
+ unsigned c;
+
+ /* Do 16 bits at a time, to avoid limb-sized constants. */
+ for (c = 0; x > 0; x >>= 16)
+ {
+ unsigned w = x - ((x >> 1) & 0x5555);
+ w = ((w >> 2) & 0x3333) + (w & 0x3333);
+ w = (w >> 4) + w;
+ w = ((w >> 8) & 0x000f) + (w & 0x000f);
+ c += w;
+ }
+ return c;
+}
+
+mp_bitcnt_t
+mpn_popcount (mp_srcptr p, mp_size_t n)
+{
+ mp_size_t i;
+ mp_bitcnt_t c;
+
+ for (c = 0, i = 0; i < n; i++)
+ c += gmp_popcount_limb (p[i]);
+
+ return c;
+}
+
+mp_bitcnt_t
+mpz_popcount (const mpz_t u)
+{
+ mp_size_t un;
+
+ un = u->_mp_size;
+
+ if (un < 0)
+ return ~(mp_bitcnt_t) 0;
+
+ return mpn_popcount (u->_mp_d, un);
+}
+
+mp_bitcnt_t
+mpz_hamdist (const mpz_t u, const mpz_t v)
+{
+ mp_size_t un, vn, i;
+ mp_limb_t uc, vc, ul, vl, comp;
+ mp_srcptr up, vp;
+ mp_bitcnt_t c;
+
+ un = u->_mp_size;
+ vn = v->_mp_size;
+
+ if ( (un ^ vn) < 0)
+ return ~(mp_bitcnt_t) 0;
+
+ comp = - (uc = vc = (un < 0));
+ if (uc)
+ {
+ assert (vn < 0);
+ un = -un;
+ vn = -vn;
+ }
+
+ up = u->_mp_d;
+ vp = v->_mp_d;
+
+ if (un < vn)
+ MPN_SRCPTR_SWAP (up, un, vp, vn);
+
+ for (i = 0, c = 0; i < vn; i++)
+ {
+ ul = (up[i] ^ comp) + uc;
+ uc = ul < uc;
+
+ vl = (vp[i] ^ comp) + vc;
+ vc = vl < vc;
+
+ c += gmp_popcount_limb (ul ^ vl);
+ }
+ assert (vc == 0);
+
+ for (; i < un; i++)
+ {
+ ul = (up[i] ^ comp) + uc;
+ uc = ul < uc;
+
+ c += gmp_popcount_limb (ul ^ comp);
+ }
+
+ return c;
+}
+
+mp_bitcnt_t
+mpz_scan1 (const mpz_t u, mp_bitcnt_t starting_bit)
+{
+ mp_ptr up;
+ mp_size_t us, un, i;
+ mp_limb_t limb, ux;
+
+ us = u->_mp_size;
+ un = GMP_ABS (us);
+ i = starting_bit / GMP_LIMB_BITS;
+
+ /* Past the end there's no 1 bits for u>=0, or an immediate 1 bit
+ for u<0. Notice this test picks up any u==0 too. */
+ if (i >= un)
+ return (us >= 0 ? ~(mp_bitcnt_t) 0 : starting_bit);
+
+ up = u->_mp_d;
+ ux = 0;
+ limb = up[i];
+
+ if (starting_bit != 0)
+ {
+ if (us < 0)
+ {
+ ux = mpn_zero_p (up, i);
+ limb = ~ limb + ux;
+ ux = - (mp_limb_t) (limb >= ux);
+ }
+
+ /* Mask to 0 all bits before starting_bit, thus ignoring them. */
+ limb &= (GMP_LIMB_MAX << (starting_bit % GMP_LIMB_BITS));
+ }
+
+ return mpn_common_scan (limb, i, up, un, ux);
+}
+
+mp_bitcnt_t
+mpz_scan0 (const mpz_t u, mp_bitcnt_t starting_bit)
+{
+ mp_ptr up;
+ mp_size_t us, un, i;
+ mp_limb_t limb, ux;
+
+ us = u->_mp_size;
+ ux = - (mp_limb_t) (us >= 0);
+ un = GMP_ABS (us);
+ i = starting_bit / GMP_LIMB_BITS;
+
+ /* When past end, there's an immediate 0 bit for u>=0, or no 0 bits for
+ u<0. Notice this test picks up all cases of u==0 too. */
+ if (i >= un)
+ return (ux ? starting_bit : ~(mp_bitcnt_t) 0);
+
+ up = u->_mp_d;
+ limb = up[i] ^ ux;
+
+ if (ux == 0)
+ limb -= mpn_zero_p (up, i); /* limb = ~(~limb + zero_p) */
+
+ /* Mask all bits before starting_bit, thus ignoring them. */
+ limb &= (GMP_LIMB_MAX << (starting_bit % GMP_LIMB_BITS));
+
+ return mpn_common_scan (limb, i, up, un, ux);
+}
+
+
+/* MPZ base conversion. */
+
+size_t
+mpz_sizeinbase (const mpz_t u, int base)
+{
+ mp_size_t un;
+ mp_srcptr up;
+ mp_ptr tp;
+ mp_bitcnt_t bits;
+ struct gmp_div_inverse bi;
+ size_t ndigits;
+
+ assert (base >= 2);
+ assert (base <= 62);
+
+ un = GMP_ABS (u->_mp_size);
+ if (un == 0)
+ return 1;
+
+ up = u->_mp_d;
+
+ bits = (un - 1) * GMP_LIMB_BITS + mpn_limb_size_in_base_2 (up[un-1]);
+ switch (base)
+ {
+ case 2:
+ return bits;
+ case 4:
+ return (bits + 1) / 2;
+ case 8:
+ return (bits + 2) / 3;
+ case 16:
+ return (bits + 3) / 4;
+ case 32:
+ return (bits + 4) / 5;
+ /* FIXME: Do something more clever for the common case of base
+ 10. */
+ }
+
+ tp = gmp_xalloc_limbs (un);
+ mpn_copyi (tp, up, un);
+ mpn_div_qr_1_invert (&bi, base);
+
+ ndigits = 0;
+ do
+ {
+ ndigits++;
+ mpn_div_qr_1_preinv (tp, tp, un, &bi);
+ un -= (tp[un-1] == 0);
+ }
+ while (un > 0);
+
+ gmp_free (tp);
+ return ndigits;
+}
+
+char *
+mpz_get_str (char *sp, int base, const mpz_t u)
+{
+ unsigned bits;
+ const char *digits;
+ mp_size_t un;
+ size_t i, sn;
+
+ digits = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
+ if (base > 1)
+ {
+ if (base <= 36)
+ digits = "0123456789abcdefghijklmnopqrstuvwxyz";
+ else if (base > 62)
+ return NULL;
+ }
+ else if (base >= -1)
+ base = 10;
+ else
+ {
+ base = -base;
+ if (base > 36)
+ return NULL;
+ }
+
+ sn = 1 + mpz_sizeinbase (u, base);
+ if (!sp)
+ sp = (char *) gmp_xalloc (1 + sn);
+
+ un = GMP_ABS (u->_mp_size);
+
+ if (un == 0)
+ {
+ sp[0] = '0';
+ sp[1] = '\0';
+ return sp;
+ }
+
+ i = 0;
+
+ if (u->_mp_size < 0)
+ sp[i++] = '-';
+
+ bits = mpn_base_power_of_two_p (base);
+
+ if (bits)
+ /* Not modified in this case. */
+ sn = i + mpn_get_str_bits ((unsigned char *) sp + i, bits, u->_mp_d, un);
+ else
+ {
+ struct mpn_base_info info;
+ mp_ptr tp;
+
+ mpn_get_base_info (&info, base);
+ tp = gmp_xalloc_limbs (un);
+ mpn_copyi (tp, u->_mp_d, un);
+
+ sn = i + mpn_get_str_other ((unsigned char *) sp + i, base, &info, tp, un);
+ gmp_free (tp);
+ }
+
+ for (; i < sn; i++)
+ sp[i] = digits[(unsigned char) sp[i]];
+
+ sp[sn] = '\0';
+ return sp;
+}
+
+int
+mpz_set_str (mpz_t r, const char *sp, int base)
+{
+ unsigned bits, value_of_a;
+ mp_size_t rn, alloc;
+ mp_ptr rp;
+ size_t dn;
+ int sign;
+ unsigned char *dp;
+
+ assert (base == 0 || (base >= 2 && base <= 62));
+
+ while (isspace( (unsigned char) *sp))
+ sp++;
+
+ sign = (*sp == '-');
+ sp += sign;
+
+ if (base == 0)
+ {
+ if (sp[0] == '0')
+ {
+ if (sp[1] == 'x' || sp[1] == 'X')
+ {
+ base = 16;
+ sp += 2;
+ }
+ else if (sp[1] == 'b' || sp[1] == 'B')
+ {
+ base = 2;
+ sp += 2;
+ }
+ else
+ base = 8;
+ }
+ else
+ base = 10;
+ }
+
+ if (!*sp)
+ {
+ r->_mp_size = 0;
+ return -1;
+ }
+ dp = (unsigned char *) gmp_xalloc (strlen (sp));
+
+ value_of_a = (base > 36) ? 36 : 10;
+ for (dn = 0; *sp; sp++)
+ {
+ unsigned digit;
+
+ if (isspace ((unsigned char) *sp))
+ continue;
+ else if (*sp >= '0' && *sp <= '9')
+ digit = *sp - '0';
+ else if (*sp >= 'a' && *sp <= 'z')
+ digit = *sp - 'a' + value_of_a;
+ else if (*sp >= 'A' && *sp <= 'Z')
+ digit = *sp - 'A' + 10;
+ else
+ digit = base; /* fail */
+
+ if (digit >= (unsigned) base)
+ {
+ gmp_free (dp);
+ r->_mp_size = 0;
+ return -1;
+ }
+
+ dp[dn++] = digit;
+ }
+
+ if (!dn)
+ {
+ gmp_free (dp);
+ r->_mp_size = 0;
+ return -1;
+ }
+ bits = mpn_base_power_of_two_p (base);
+
+ if (bits > 0)
+ {
+ alloc = (dn * bits + GMP_LIMB_BITS - 1) / GMP_LIMB_BITS;
+ rp = MPZ_REALLOC (r, alloc);
+ rn = mpn_set_str_bits (rp, dp, dn, bits);
+ }
+ else
+ {
+ struct mpn_base_info info;
+ mpn_get_base_info (&info, base);
+ alloc = (dn + info.exp - 1) / info.exp;
+ rp = MPZ_REALLOC (r, alloc);
+ rn = mpn_set_str_other (rp, dp, dn, base, &info);
+ /* Normalization, needed for all-zero input. */
+ assert (rn > 0);
+ rn -= rp[rn-1] == 0;
+ }
+ assert (rn <= alloc);
+ gmp_free (dp);
+
+ r->_mp_size = sign ? - rn : rn;
+
+ return 0;
+}
+
+int
+mpz_init_set_str (mpz_t r, const char *sp, int base)
+{
+ mpz_init (r);
+ return mpz_set_str (r, sp, base);
+}
+
+size_t
+mpz_out_str (FILE *stream, int base, const mpz_t x)
+{
+ char *str;
+ size_t len;
+
+ str = mpz_get_str (NULL, base, x);
+ len = strlen (str);
+ len = fwrite (str, 1, len, stream);
+ gmp_free (str);
+ return len;
+}
+
+
+static int
+gmp_detect_endian (void)
+{
+ static const int i = 2;
+ const unsigned char *p = (const unsigned char *) &i;
+ return 1 - *p;
+}
+
+/* Import and export. Does not support nails. */
+void
+mpz_import (mpz_t r, size_t count, int order, size_t size, int endian,
+ size_t nails, const void *src)
+{
+ const unsigned char *p;
+ ptrdiff_t word_step;
+ mp_ptr rp;
+ mp_size_t rn;
+
+ /* The current (partial) limb. */
+ mp_limb_t limb;
+ /* The number of bytes already copied to this limb (starting from
+ the low end). */
+ size_t bytes;
+ /* The index where the limb should be stored, when completed. */
+ mp_size_t i;
+
+ if (nails != 0)
+ gmp_die ("mpz_import: Nails not supported.");
+
+ assert (order == 1 || order == -1);
+ assert (endian >= -1 && endian <= 1);
+
+ if (endian == 0)
+ endian = gmp_detect_endian ();
+
+ p = (unsigned char *) src;
+
+ word_step = (order != endian) ? 2 * size : 0;
+
+ /* Process bytes from the least significant end, so point p at the
+ least significant word. */
+ if (order == 1)
+ {
+ p += size * (count - 1);
+ word_step = - word_step;
+ }
+
+ /* And at least significant byte of that word. */
+ if (endian == 1)
+ p += (size - 1);
+
+ rn = (size * count + sizeof(mp_limb_t) - 1) / sizeof(mp_limb_t);
+ rp = MPZ_REALLOC (r, rn);
+
+ for (limb = 0, bytes = 0, i = 0; count > 0; count--, p += word_step)
+ {
+ size_t j;
+ for (j = 0; j < size; j++, p -= (ptrdiff_t) endian)
+ {
+ limb |= (mp_limb_t) *p << (bytes++ * CHAR_BIT);
+ if (bytes == sizeof(mp_limb_t))
+ {
+ rp[i++] = limb;
+ bytes = 0;
+ limb = 0;
+ }
+ }
+ }
+ assert (i + (bytes > 0) == rn);
+ if (limb != 0)
+ rp[i++] = limb;
+ else
+ i = mpn_normalized_size (rp, i);
+
+ r->_mp_size = i;
+}
+
+void *
+mpz_export (void *r, size_t *countp, int order, size_t size, int endian,
+ size_t nails, const mpz_t u)
+{
+ size_t count;
+ mp_size_t un;
+
+ if (nails != 0)
+ gmp_die ("mpz_import: Nails not supported.");
+
+ assert (order == 1 || order == -1);
+ assert (endian >= -1 && endian <= 1);
+ assert (size > 0 || u->_mp_size == 0);
+
+ un = u->_mp_size;
+ count = 0;
+ if (un != 0)
+ {
+ size_t k;
+ unsigned char *p;
+ ptrdiff_t word_step;
+ /* The current (partial) limb. */
+ mp_limb_t limb;
+ /* The number of bytes left to to in this limb. */
+ size_t bytes;
+ /* The index where the limb was read. */
+ mp_size_t i;
+
+ un = GMP_ABS (un);
+
+ /* Count bytes in top limb. */
+ limb = u->_mp_d[un-1];
+ assert (limb != 0);
+
+ k = 0;
+ do {
+ k++; limb >>= CHAR_BIT;
+ } while (limb != 0);
+
+ count = (k + (un-1) * sizeof (mp_limb_t) + size - 1) / size;
+
+ if (!r)
+ r = gmp_xalloc (count * size);
+
+ if (endian == 0)
+ endian = gmp_detect_endian ();
+
+ p = (unsigned char *) r;
+
+ word_step = (order != endian) ? 2 * size : 0;
+
+ /* Process bytes from the least significant end, so point p at the
+ least significant word. */
+ if (order == 1)
+ {
+ p += size * (count - 1);
+ word_step = - word_step;
+ }
+
+ /* And at least significant byte of that word. */
+ if (endian == 1)
+ p += (size - 1);
+
+ for (bytes = 0, i = 0, k = 0; k < count; k++, p += word_step)
+ {
+ size_t j;
+ for (j = 0; j < size; j++, p -= (ptrdiff_t) endian)
+ {
+ if (bytes == 0)
+ {
+ if (i < un)
+ limb = u->_mp_d[i++];
+ bytes = sizeof (mp_limb_t);
+ }
+ *p = limb;
+ limb >>= CHAR_BIT;
+ bytes--;
+ }
+ }
+ assert (i == un);
+ assert (k == count);
+ }
+
+ if (countp)
+ *countp = count;
+
+ return r;
+}
diff --git a/src/mini-gmp.h b/src/mini-gmp.h
new file mode 100644
index 00000000000..2586d32db9e
--- /dev/null
+++ b/src/mini-gmp.h
@@ -0,0 +1,300 @@
+/* mini-gmp, a minimalistic implementation of a GNU GMP subset.
+
+Copyright 2011-2015, 2017, 2019 Free Software Foundation, Inc.
+
+This file is part of the GNU MP Library.
+
+The GNU MP Library is free software; you can redistribute it and/or modify
+it under the terms of either:
+
+ * the GNU Lesser General Public License as published by the Free
+ Software Foundation; either version 3 of the License, or (at your
+ option) any later version.
+
+or
+
+ * the GNU General Public License as published by the Free Software
+ Foundation; either version 2 of the License, or (at your option) any
+ later version.
+
+or both in parallel, as here.
+
+The GNU MP 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 copies of the GNU General Public License and the
+GNU Lesser General Public License along with the GNU MP Library. If not,
+see https://www.gnu.org/licenses/. */
+
+/* About mini-gmp: This is a minimal implementation of a subset of the
+ GMP interface. It is intended for inclusion into applications which
+ have modest bignums needs, as a fallback when the real GMP library
+ is not installed.
+
+ This file defines the public interface. */
+
+#ifndef __MINI_GMP_H__
+#define __MINI_GMP_H__
+
+/* For size_t */
+#include <stddef.h>
+
+#if defined (__cplusplus)
+extern "C" {
+#endif
+
+void mp_set_memory_functions (void *(*) (size_t),
+ void *(*) (void *, size_t, size_t),
+ void (*) (void *, size_t));
+
+void mp_get_memory_functions (void *(**) (size_t),
+ void *(**) (void *, size_t, size_t),
+ void (**) (void *, size_t));
+
+typedef unsigned long mp_limb_t;
+typedef long mp_size_t;
+typedef unsigned long mp_bitcnt_t;
+
+typedef mp_limb_t *mp_ptr;
+typedef const mp_limb_t *mp_srcptr;
+
+typedef struct
+{
+ int _mp_alloc; /* Number of *limbs* allocated and pointed
+ to by the _mp_d field. */
+ int _mp_size; /* abs(_mp_size) is the number of limbs the
+ last field points to. If _mp_size is
+ negative this is a negative number. */
+ mp_limb_t *_mp_d; /* Pointer to the limbs. */
+} __mpz_struct;
+
+typedef __mpz_struct mpz_t[1];
+
+typedef __mpz_struct *mpz_ptr;
+typedef const __mpz_struct *mpz_srcptr;
+
+extern const int mp_bits_per_limb;
+
+void mpn_copyi (mp_ptr, mp_srcptr, mp_size_t);
+void mpn_copyd (mp_ptr, mp_srcptr, mp_size_t);
+void mpn_zero (mp_ptr, mp_size_t);
+
+int mpn_cmp (mp_srcptr, mp_srcptr, mp_size_t);
+int mpn_zero_p (mp_srcptr, mp_size_t);
+
+mp_limb_t mpn_add_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t);
+mp_limb_t mpn_add_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t);
+mp_limb_t mpn_add (mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t);
+
+mp_limb_t mpn_sub_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t);
+mp_limb_t mpn_sub_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t);
+mp_limb_t mpn_sub (mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t);
+
+mp_limb_t mpn_mul_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t);
+mp_limb_t mpn_addmul_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t);
+mp_limb_t mpn_submul_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t);
+
+mp_limb_t mpn_mul (mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t);
+void mpn_mul_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t);
+void mpn_sqr (mp_ptr, mp_srcptr, mp_size_t);
+int mpn_perfect_square_p (mp_srcptr, mp_size_t);
+mp_size_t mpn_sqrtrem (mp_ptr, mp_ptr, mp_srcptr, mp_size_t);
+
+mp_limb_t mpn_lshift (mp_ptr, mp_srcptr, mp_size_t, unsigned int);
+mp_limb_t mpn_rshift (mp_ptr, mp_srcptr, mp_size_t, unsigned int);
+
+mp_bitcnt_t mpn_scan0 (mp_srcptr, mp_bitcnt_t);
+mp_bitcnt_t mpn_scan1 (mp_srcptr, mp_bitcnt_t);
+
+void mpn_com (mp_ptr, mp_srcptr, mp_size_t);
+mp_limb_t mpn_neg (mp_ptr, mp_srcptr, mp_size_t);
+
+mp_bitcnt_t mpn_popcount (mp_srcptr, mp_size_t);
+
+mp_limb_t mpn_invert_3by2 (mp_limb_t, mp_limb_t);
+#define mpn_invert_limb(x) mpn_invert_3by2 ((x), 0)
+
+size_t mpn_get_str (unsigned char *, int, mp_ptr, mp_size_t);
+mp_size_t mpn_set_str (mp_ptr, const unsigned char *, size_t, int);
+
+void mpz_init (mpz_t);
+void mpz_init2 (mpz_t, mp_bitcnt_t);
+void mpz_clear (mpz_t);
+
+#define mpz_odd_p(z) (((z)->_mp_size != 0) & (int) (z)->_mp_d[0])
+#define mpz_even_p(z) (! mpz_odd_p (z))
+
+int mpz_sgn (const mpz_t);
+int mpz_cmp_si (const mpz_t, long);
+int mpz_cmp_ui (const mpz_t, unsigned long);
+int mpz_cmp (const mpz_t, const mpz_t);
+int mpz_cmpabs_ui (const mpz_t, unsigned long);
+int mpz_cmpabs (const mpz_t, const mpz_t);
+int mpz_cmp_d (const mpz_t, double);
+int mpz_cmpabs_d (const mpz_t, double);
+
+void mpz_abs (mpz_t, const mpz_t);
+void mpz_neg (mpz_t, const mpz_t);
+void mpz_swap (mpz_t, mpz_t);
+
+void mpz_add_ui (mpz_t, const mpz_t, unsigned long);
+void mpz_add (mpz_t, const mpz_t, const mpz_t);
+void mpz_sub_ui (mpz_t, const mpz_t, unsigned long);
+void mpz_ui_sub (mpz_t, unsigned long, const mpz_t);
+void mpz_sub (mpz_t, const mpz_t, const mpz_t);
+
+void mpz_mul_si (mpz_t, const mpz_t, long int);
+void mpz_mul_ui (mpz_t, const mpz_t, unsigned long int);
+void mpz_mul (mpz_t, const mpz_t, const mpz_t);
+void mpz_mul_2exp (mpz_t, const mpz_t, mp_bitcnt_t);
+void mpz_addmul_ui (mpz_t, const mpz_t, unsigned long int);
+void mpz_addmul (mpz_t, const mpz_t, const mpz_t);
+void mpz_submul_ui (mpz_t, const mpz_t, unsigned long int);
+void mpz_submul (mpz_t, const mpz_t, const mpz_t);
+
+void mpz_cdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t);
+void mpz_fdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t);
+void mpz_tdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t);
+void mpz_cdiv_q (mpz_t, const mpz_t, const mpz_t);
+void mpz_fdiv_q (mpz_t, const mpz_t, const mpz_t);
+void mpz_tdiv_q (mpz_t, const mpz_t, const mpz_t);
+void mpz_cdiv_r (mpz_t, const mpz_t, const mpz_t);
+void mpz_fdiv_r (mpz_t, const mpz_t, const mpz_t);
+void mpz_tdiv_r (mpz_t, const mpz_t, const mpz_t);
+
+void mpz_cdiv_q_2exp (mpz_t, const mpz_t, mp_bitcnt_t);
+void mpz_fdiv_q_2exp (mpz_t, const mpz_t, mp_bitcnt_t);
+void mpz_tdiv_q_2exp (mpz_t, const mpz_t, mp_bitcnt_t);
+void mpz_cdiv_r_2exp (mpz_t, const mpz_t, mp_bitcnt_t);
+void mpz_fdiv_r_2exp (mpz_t, const mpz_t, mp_bitcnt_t);
+void mpz_tdiv_r_2exp (mpz_t, const mpz_t, mp_bitcnt_t);
+
+void mpz_mod (mpz_t, const mpz_t, const mpz_t);
+
+void mpz_divexact (mpz_t, const mpz_t, const mpz_t);
+
+int mpz_divisible_p (const mpz_t, const mpz_t);
+int mpz_congruent_p (const mpz_t, const mpz_t, const mpz_t);
+
+unsigned long mpz_cdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long);
+unsigned long mpz_fdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long);
+unsigned long mpz_tdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long);
+unsigned long mpz_cdiv_q_ui (mpz_t, const mpz_t, unsigned long);
+unsigned long mpz_fdiv_q_ui (mpz_t, const mpz_t, unsigned long);
+unsigned long mpz_tdiv_q_ui (mpz_t, const mpz_t, unsigned long);
+unsigned long mpz_cdiv_r_ui (mpz_t, const mpz_t, unsigned long);
+unsigned long mpz_fdiv_r_ui (mpz_t, const mpz_t, unsigned long);
+unsigned long mpz_tdiv_r_ui (mpz_t, const mpz_t, unsigned long);
+unsigned long mpz_cdiv_ui (const mpz_t, unsigned long);
+unsigned long mpz_fdiv_ui (const mpz_t, unsigned long);
+unsigned long mpz_tdiv_ui (const mpz_t, unsigned long);
+
+unsigned long mpz_mod_ui (mpz_t, const mpz_t, unsigned long);
+
+void mpz_divexact_ui (mpz_t, const mpz_t, unsigned long);
+
+int mpz_divisible_ui_p (const mpz_t, unsigned long);
+
+unsigned long mpz_gcd_ui (mpz_t, const mpz_t, unsigned long);
+void mpz_gcd (mpz_t, const mpz_t, const mpz_t);
+void mpz_gcdext (mpz_t, mpz_t, mpz_t, const mpz_t, const mpz_t);
+void mpz_lcm_ui (mpz_t, const mpz_t, unsigned long);
+void mpz_lcm (mpz_t, const mpz_t, const mpz_t);
+int mpz_invert (mpz_t, const mpz_t, const mpz_t);
+
+void mpz_sqrtrem (mpz_t, mpz_t, const mpz_t);
+void mpz_sqrt (mpz_t, const mpz_t);
+int mpz_perfect_square_p (const mpz_t);
+
+void mpz_pow_ui (mpz_t, const mpz_t, unsigned long);
+void mpz_ui_pow_ui (mpz_t, unsigned long, unsigned long);
+void mpz_powm (mpz_t, const mpz_t, const mpz_t, const mpz_t);
+void mpz_powm_ui (mpz_t, const mpz_t, unsigned long, const mpz_t);
+
+void mpz_rootrem (mpz_t, mpz_t, const mpz_t, unsigned long);
+int mpz_root (mpz_t, const mpz_t, unsigned long);
+
+void mpz_fac_ui (mpz_t, unsigned long);
+void mpz_2fac_ui (mpz_t, unsigned long);
+void mpz_mfac_uiui (mpz_t, unsigned long, unsigned long);
+void mpz_bin_uiui (mpz_t, unsigned long, unsigned long);
+
+int mpz_probab_prime_p (const mpz_t, int);
+
+int mpz_tstbit (const mpz_t, mp_bitcnt_t);
+void mpz_setbit (mpz_t, mp_bitcnt_t);
+void mpz_clrbit (mpz_t, mp_bitcnt_t);
+void mpz_combit (mpz_t, mp_bitcnt_t);
+
+void mpz_com (mpz_t, const mpz_t);
+void mpz_and (mpz_t, const mpz_t, const mpz_t);
+void mpz_ior (mpz_t, const mpz_t, const mpz_t);
+void mpz_xor (mpz_t, const mpz_t, const mpz_t);
+
+mp_bitcnt_t mpz_popcount (const mpz_t);
+mp_bitcnt_t mpz_hamdist (const mpz_t, const mpz_t);
+mp_bitcnt_t mpz_scan0 (const mpz_t, mp_bitcnt_t);
+mp_bitcnt_t mpz_scan1 (const mpz_t, mp_bitcnt_t);
+
+int mpz_fits_slong_p (const mpz_t);
+int mpz_fits_ulong_p (const mpz_t);
+long int mpz_get_si (const mpz_t);
+unsigned long int mpz_get_ui (const mpz_t);
+double mpz_get_d (const mpz_t);
+size_t mpz_size (const mpz_t);
+mp_limb_t mpz_getlimbn (const mpz_t, mp_size_t);
+
+void mpz_realloc2 (mpz_t, mp_bitcnt_t);
+mp_srcptr mpz_limbs_read (mpz_srcptr);
+mp_ptr mpz_limbs_modify (mpz_t, mp_size_t);
+mp_ptr mpz_limbs_write (mpz_t, mp_size_t);
+void mpz_limbs_finish (mpz_t, mp_size_t);
+mpz_srcptr mpz_roinit_n (mpz_t, mp_srcptr, mp_size_t);
+
+#define MPZ_ROINIT_N(xp, xs) {{0, (xs),(xp) }}
+
+void mpz_set_si (mpz_t, signed long int);
+void mpz_set_ui (mpz_t, unsigned long int);
+void mpz_set (mpz_t, const mpz_t);
+void mpz_set_d (mpz_t, double);
+
+void mpz_init_set_si (mpz_t, signed long int);
+void mpz_init_set_ui (mpz_t, unsigned long int);
+void mpz_init_set (mpz_t, const mpz_t);
+void mpz_init_set_d (mpz_t, double);
+
+size_t mpz_sizeinbase (const mpz_t, int);
+char *mpz_get_str (char *, int, const mpz_t);
+int mpz_set_str (mpz_t, const char *, int);
+int mpz_init_set_str (mpz_t, const char *, int);
+
+/* This long list taken from gmp.h. */
+/* For reference, "defined(EOF)" cannot be used here. In g++ 2.95.4,
+ <iostream> defines EOF but not FILE. */
+#if defined (FILE) \
+ || defined (H_STDIO) \
+ || defined (_H_STDIO) /* AIX */ \
+ || defined (_STDIO_H) /* glibc, Sun, SCO */ \
+ || defined (_STDIO_H_) /* BSD, OSF */ \
+ || defined (__STDIO_H) /* Borland */ \
+ || defined (__STDIO_H__) /* IRIX */ \
+ || defined (_STDIO_INCLUDED) /* HPUX */ \
+ || defined (__dj_include_stdio_h_) /* DJGPP */ \
+ || defined (_FILE_DEFINED) /* Microsoft */ \
+ || defined (__STDIO__) /* Apple MPW MrC */ \
+ || defined (_MSL_STDIO_H) /* Metrowerks */ \
+ || defined (_STDIO_H_INCLUDED) /* QNX4 */ \
+ || defined (_ISO_STDIO_ISO_H) /* Sun C++ */ \
+ || defined (__STDIO_LOADED) /* VMS */
+size_t mpz_out_str (FILE *, int, const mpz_t);
+#endif
+
+void mpz_import (mpz_t, size_t, int, size_t, int, size_t, const void *);
+void *mpz_export (void *, size_t *, int, size_t, int, size_t, const mpz_t);
+
+#if defined (__cplusplus)
+}
+#endif
+#endif /* __MINI_GMP_H__ */
diff --git a/src/minibuf.c b/src/minibuf.c
index a33ddf40a1c..10fd5e56ac3 100644
--- a/src/minibuf.c
+++ b/src/minibuf.c
@@ -32,6 +32,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "keymap.h"
#include "sysstdio.h"
#include "systty.h"
+#include "pdumper.h"
/* List of buffers for use as minibuffers.
The first element of the list is used for the outermost minibuffer
@@ -157,7 +158,7 @@ string_to_object (Lisp_Object val, Lisp_Object defalt)
}
expr_and_pos = Fread_from_string (val, Qnil, Qnil);
- pos = XINT (Fcdr (expr_and_pos));
+ pos = XFIXNUM (Fcdr (expr_and_pos));
if (pos != SCHARS (val))
{
/* Ignore trailing whitespace; any other trailing junk
@@ -181,12 +182,8 @@ string_to_object (Lisp_Object val, Lisp_Object defalt)
from read_minibuf to do the job if noninteractive. */
static Lisp_Object
-read_minibuf_noninteractive (Lisp_Object map, Lisp_Object initial,
- Lisp_Object prompt, Lisp_Object backup_n,
- bool expflag,
- Lisp_Object histvar, Lisp_Object histpos,
- Lisp_Object defalt,
- bool allow_props, bool inherit_input_method)
+read_minibuf_noninteractive (Lisp_Object prompt, bool expflag,
+ Lisp_Object defalt)
{
ptrdiff_t size, len;
char *line;
@@ -198,7 +195,7 @@ read_minibuf_noninteractive (Lisp_Object map, Lisp_Object initial,
/* Check, whether we need to suppress echoing. */
if (CHARACTERP (Vread_hide_char))
- hide_char = XFASTINT (Vread_hide_char);
+ hide_char = XFIXNAT (Vread_hide_char);
/* Manipulate tty. */
if (hide_char)
@@ -291,7 +288,7 @@ Return (point-min) if current buffer is not a minibuffer. */)
{
/* This function is written to be most efficient when there's a prompt. */
Lisp_Object beg, end, tem;
- beg = make_number (BEGV);
+ beg = make_fixnum (BEGV);
tem = Fmemq (Fcurrent_buffer (), Vminibuffer_list);
if (NILP (tem))
@@ -299,7 +296,7 @@ Return (point-min) if current buffer is not a minibuffer. */)
end = Ffield_end (beg, Qnil, Qnil);
- if (XINT (end) == ZV && NILP (Fget_char_property (beg, Qfield, Qnil)))
+ if (XFIXNUM (end) == ZV && NILP (Fget_char_property (beg, Qfield, Qnil)))
return beg;
else
return end;
@@ -311,7 +308,7 @@ DEFUN ("minibuffer-contents", Fminibuffer_contents,
If the current buffer is not a minibuffer, return its entire contents. */)
(void)
{
- ptrdiff_t prompt_end = XINT (Fminibuffer_prompt_end ());
+ ptrdiff_t prompt_end = XFIXNUM (Fminibuffer_prompt_end ());
return make_buffer_string (prompt_end, ZV, 1);
}
@@ -321,23 +318,10 @@ DEFUN ("minibuffer-contents-no-properties", Fminibuffer_contents_no_properties,
If the current buffer is not a minibuffer, return its entire contents. */)
(void)
{
- ptrdiff_t prompt_end = XINT (Fminibuffer_prompt_end ());
+ ptrdiff_t prompt_end = XFIXNUM (Fminibuffer_prompt_end ());
return make_buffer_string (prompt_end, ZV, 0);
}
-DEFUN ("minibuffer-completion-contents", Fminibuffer_completion_contents,
- Sminibuffer_completion_contents, 0, 0, 0,
- doc: /* Return the user input in a minibuffer before point as a string.
-That is what completion commands operate on.
-If the current buffer is not a minibuffer, return its entire contents. */)
- (void)
-{
- ptrdiff_t prompt_end = XINT (Fminibuffer_prompt_end ());
- if (PT < prompt_end)
- error ("Cannot do completion in the prompt");
- return make_buffer_string (prompt_end, PT, 1);
-}
-
/* Read from the minibuffer using keymap MAP and initial contents INITIAL,
putting point minus BACKUP_N bytes from the end of INITIAL,
@@ -406,13 +390,13 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt,
CHECK_STRING (initial);
if (!NILP (backup_n))
{
- CHECK_NUMBER (backup_n);
+ CHECK_FIXNUM (backup_n);
/* Convert to distance from end of input. */
- if (XINT (backup_n) < 1)
+ if (XFIXNUM (backup_n) < 1)
/* A number too small means the beginning of the string. */
pos = - SCHARS (initial);
else
- pos = XINT (backup_n) - 1 - SCHARS (initial);
+ pos = XFIXNUM (backup_n) - 1 - SCHARS (initial);
}
}
else
@@ -443,10 +427,7 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt,
|| (IS_DAEMON && DAEMON_RUNNING))
&& NILP (Vexecuting_kbd_macro))
{
- val = read_minibuf_noninteractive (map, initial, prompt,
- make_number (pos),
- expflag, histvar, histpos, defalt,
- allow_props, inherit_input_method);
+ val = read_minibuf_noninteractive (prompt, expflag, defalt);
return unbind_to (count, val);
}
@@ -491,7 +472,7 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt,
minibuf_save_list));
minibuf_save_list
= Fcons (minibuf_prompt,
- Fcons (make_number (minibuf_prompt_width),
+ Fcons (make_fixnum (minibuf_prompt_width),
Fcons (Vhelp_form,
Fcons (Vcurrent_prefix_arg,
Fcons (Vminibuffer_history_position,
@@ -608,9 +589,6 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt,
XWINDOW (minibuf_window)->hscroll = 0;
XWINDOW (minibuf_window)->suspend_auto_hscroll = 0;
- Fmake_local_variable (Qprint_escape_newlines);
- print_escape_newlines = 1;
-
/* Erase the buffer. */
{
ptrdiff_t count1 = SPECPDL_INDEX ();
@@ -626,11 +604,11 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt,
Finsert (1, &minibuf_prompt);
if (PT > BEG)
{
- Fput_text_property (make_number (BEG), make_number (PT),
+ Fput_text_property (make_fixnum (BEG), make_fixnum (PT),
Qfront_sticky, Qt, Qnil);
- Fput_text_property (make_number (BEG), make_number (PT),
+ Fput_text_property (make_fixnum (BEG), make_fixnum (PT),
Qrear_nonsticky, Qt, Qnil);
- Fput_text_property (make_number (BEG), make_number (PT),
+ Fput_text_property (make_fixnum (BEG), make_fixnum (PT),
Qfield, Qt, Qnil);
if (CONSP (Vminibuffer_prompt_properties))
{
@@ -649,10 +627,10 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt,
Lisp_Object val = XCAR (list);
list = XCDR (list);
if (EQ (key, Qface))
- Fadd_face_text_property (make_number (BEG),
- make_number (PT), val, Qt, Qnil);
+ Fadd_face_text_property (make_fixnum (BEG),
+ make_fixnum (PT), val, Qt, Qnil);
else
- Fput_text_property (make_number (BEG), make_number (PT),
+ Fput_text_property (make_fixnum (BEG), make_fixnum (PT),
key, val, Qnil);
}
}
@@ -667,7 +645,7 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt,
if (!NILP (initial))
{
Finsert (1, &initial);
- Fforward_char (make_number (pos));
+ Fforward_char (make_fixnum (pos));
}
clear_message (1, 1);
@@ -718,44 +696,8 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt,
histstring = Qnil;
/* Add the value to the appropriate history list, if any. */
- if (!NILP (Vhistory_add_new_input)
- && SYMBOLP (Vminibuffer_history_variable)
- && !NILP (histstring))
- {
- /* If the caller wanted to save the value read on a history list,
- then do so if the value is not already the front of the list. */
-
- /* The value of the history variable must be a cons or nil. Other
- values are unacceptable. We silently ignore these values. */
-
- if (NILP (histval)
- || (CONSP (histval)
- /* Don't duplicate the most recent entry in the history. */
- && (NILP (Fequal (histstring, Fcar (histval))))))
- {
- Lisp_Object length;
-
- if (history_delete_duplicates) Fdelete (histstring, histval);
- histval = Fcons (histstring, histval);
- Fset (Vminibuffer_history_variable, histval);
-
- /* Truncate if requested. */
- length = Fget (Vminibuffer_history_variable, Qhistory_length);
- if (NILP (length)) length = Vhistory_length;
- if (INTEGERP (length))
- {
- if (XINT (length) <= 0)
- Fset (Vminibuffer_history_variable, Qnil);
- else
- {
- Lisp_Object temp;
-
- temp = Fnthcdr (Fsub1 (length), histval);
- if (CONSP (temp)) Fsetcdr (temp, Qnil);
- }
- }
- }
- }
+ if (! (NILP (Vhistory_add_new_input) || NILP (histstring)))
+ call2 (intern ("add-to-history"), Vminibuffer_history_variable, histstring);
/* If Lisp form desired instead of string, parse it. */
if (expflag)
@@ -773,7 +715,7 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt,
Lisp_Object
get_minibuffer (EMACS_INT depth)
{
- Lisp_Object tail = Fnthcdr (make_number (depth), Vminibuffer_list);
+ Lisp_Object tail = Fnthcdr (make_fixnum (depth), Vminibuffer_list);
if (NILP (tail))
{
tail = list1 (Qnil);
@@ -807,7 +749,7 @@ get_minibuffer (EMACS_INT depth)
call0 (intern ("minibuffer-inactive-mode"));
else
Fkill_all_local_variables ();
- unbind_to (count, Qnil);
+ buf = unbind_to (count, buf);
}
return buf;
@@ -839,13 +781,12 @@ read_minibuf_unwind (void)
/* Restore prompt, etc, from outer minibuffer level. */
Lisp_Object key_vec = Fcar (minibuf_save_list);
- eassert (VECTORP (key_vec));
- this_command_key_count = XFASTINT (Flength (key_vec));
+ this_command_key_count = ASIZE (key_vec);
this_command_keys = key_vec;
minibuf_save_list = Fcdr (minibuf_save_list);
minibuf_prompt = Fcar (minibuf_save_list);
minibuf_save_list = Fcdr (minibuf_save_list);
- minibuf_prompt_width = XFASTINT (Fcar (minibuf_save_list));
+ minibuf_prompt_width = XFIXNAT (Fcar (minibuf_save_list));
minibuf_save_list = Fcdr (minibuf_save_list);
Vhelp_form = Fcar (minibuf_save_list);
minibuf_save_list = Fcdr (minibuf_save_list);
@@ -1047,7 +988,7 @@ the current input method and the setting of`enable-multibyte-characters'. */)
{
CHECK_STRING (prompt);
return read_minibuf (Vminibuffer_local_ns_map, initial, prompt,
- 0, Qminibuffer_history, make_number (0), Qnil, 0,
+ 0, Qminibuffer_history, make_fixnum (0), Qnil, 0,
!NILP (inherit_input_method));
}
@@ -1104,7 +1045,8 @@ A user option, or customizable variable, is one for which
name = Fcompleting_read (prompt, Vobarray,
Qcustom_variable_p, Qt,
- Qnil, Qnil, default_string, Qnil);
+ Qnil, Qcustom_variable_history,
+ default_string, Qnil);
if (NILP (name))
return name;
return Fintern (name, Qnil);
@@ -1248,7 +1190,7 @@ is used to further constrain the set of candidates. */)
return call3 (collection, string, predicate, Qnil);
bestmatch = bucket = Qnil;
- zero = make_number (0);
+ zero = make_fixnum (0);
/* If COLLECTION is not a list, set TAIL just for gc pro. */
tail = collection;
@@ -1259,6 +1201,9 @@ is used to further constrain the set of candidates. */)
bucket = AREF (collection, idx);
}
+ if (HASH_TABLE_P (collection))
+ hash_rehash_if_needed (XHASH_TABLE (collection));
+
while (1)
{
/* Get the next element of the alist, obarray, or hash-table. */
@@ -1314,7 +1259,7 @@ is used to further constrain the set of candidates. */)
if (STRINGP (eltstring)
&& SCHARS (string) <= SCHARS (eltstring)
&& (tem = Fcompare_strings (eltstring, zero,
- make_number (SCHARS (string)),
+ make_fixnum (SCHARS (string)),
string, zero, Qnil,
completion_ignore_case ? Qt : Qnil),
EQ (Qt, tem)))
@@ -1327,11 +1272,12 @@ is used to further constrain the set of candidates. */)
for (regexps = Vcompletion_regexp_list; CONSP (regexps);
regexps = XCDR (regexps))
{
- if (bindcount < 0) {
- bindcount = SPECPDL_INDEX ();
- specbind (Qcase_fold_search,
- completion_ignore_case ? Qt : Qnil);
- }
+ if (bindcount < 0)
+ {
+ bindcount = SPECPDL_INDEX ();
+ specbind (Qcase_fold_search,
+ completion_ignore_case ? Qt : Qnil);
+ }
tem = Fstring_match (XCAR (regexps), eltstring, zero);
if (NILP (tem))
break;
@@ -1375,11 +1321,11 @@ is used to further constrain the set of candidates. */)
{
compare = min (bestmatchsize, SCHARS (eltstring));
tem = Fcompare_strings (bestmatch, zero,
- make_number (compare),
+ make_fixnum (compare),
eltstring, zero,
- make_number (compare),
+ make_fixnum (compare),
completion_ignore_case ? Qt : Qnil);
- matchsize = EQ (tem, Qt) ? compare : eabs (XINT (tem)) - 1;
+ matchsize = EQ (tem, Qt) ? compare : eabs (XFIXNUM (tem)) - 1;
if (completion_ignore_case)
{
@@ -1400,13 +1346,13 @@ is used to further constrain the set of candidates. */)
==
(matchsize == SCHARS (bestmatch))
&& (tem = Fcompare_strings (eltstring, zero,
- make_number (SCHARS (string)),
+ make_fixnum (SCHARS (string)),
string, zero,
Qnil,
Qnil),
EQ (Qt, tem))
&& (tem = Fcompare_strings (bestmatch, zero,
- make_number (SCHARS (string)),
+ make_fixnum (SCHARS (string)),
string, zero,
Qnil,
Qnil),
@@ -1430,10 +1376,8 @@ is used to further constrain the set of candidates. */)
}
}
- if (bindcount >= 0) {
+ if (bindcount >= 0)
unbind_to (bindcount, Qnil);
- bindcount = -1;
- }
if (NILP (bestmatch))
return Qnil; /* No completions found. */
@@ -1501,7 +1445,7 @@ with a space are ignored unless STRING itself starts with a space. */)
if (type == 0)
return call3 (collection, string, predicate, Qt);
allmatches = bucket = Qnil;
- zero = make_number (0);
+ zero = make_fixnum (0);
/* If COLLECTION is not a list, set TAIL just for gc pro. */
tail = collection;
@@ -1573,9 +1517,9 @@ with a space are ignored unless STRING itself starts with a space. */)
&& SREF (string, 0) == ' ')
|| SREF (eltstring, 0) != ' ')
&& (tem = Fcompare_strings (eltstring, zero,
- make_number (SCHARS (string)),
+ make_fixnum (SCHARS (string)),
string, zero,
- make_number (SCHARS (string)),
+ make_fixnum (SCHARS (string)),
completion_ignore_case ? Qt : Qnil),
EQ (Qt, tem)))
{
@@ -1587,11 +1531,12 @@ with a space are ignored unless STRING itself starts with a space. */)
for (regexps = Vcompletion_regexp_list; CONSP (regexps);
regexps = XCDR (regexps))
{
- if (bindcount < 0) {
- bindcount = SPECPDL_INDEX ();
- specbind (Qcase_fold_search,
- completion_ignore_case ? Qt : Qnil);
- }
+ if (bindcount < 0)
+ {
+ bindcount = SPECPDL_INDEX ();
+ specbind (Qcase_fold_search,
+ completion_ignore_case ? Qt : Qnil);
+ }
tem = Fstring_match (XCAR (regexps), eltstring, zero);
if (NILP (tem))
break;
@@ -1609,10 +1554,11 @@ with a space are ignored unless STRING itself starts with a space. */)
tem = Fcommandp (elt, Qnil);
else
{
- if (bindcount >= 0) {
- unbind_to (bindcount, Qnil);
- bindcount = -1;
- }
+ if (bindcount >= 0)
+ {
+ unbind_to (bindcount, Qnil);
+ bindcount = -1;
+ }
tem = type == 3
? call2 (predicate, elt,
HASH_VALUE (XHASH_TABLE (collection), idx - 1))
@@ -1625,10 +1571,8 @@ with a space are ignored unless STRING itself starts with a space. */)
}
}
- if (bindcount >= 0) {
+ if (bindcount >= 0)
unbind_to (bindcount, Qnil);
- bindcount = -1;
- }
return Fnreverse (allmatches);
}
@@ -1748,9 +1692,9 @@ the values STRING, PREDICATE and `lambda'. */)
if (SYMBOLP (tail))
while (1)
{
- if (EQ (Fcompare_strings (string, make_number (0), Qnil,
+ if (EQ (Fcompare_strings (string, make_fixnum (0), Qnil,
Fsymbol_name (tail),
- make_number (0) , Qnil, Qt),
+ make_fixnum (0) , Qnil, Qt),
Qt))
{
tem = tail;
@@ -1844,7 +1788,7 @@ If FLAG is nil, invoke `try-completion'; if it is t, invoke
while (CONSP (bufs) && SREF (XCAR (bufs), 0) == ' ')
bufs = XCDR (bufs);
if (NILP (bufs))
- return (EQ (Flength (res), Flength (Vbuffer_alist))
+ return (list_length (res) == list_length (Vbuffer_alist)
/* If all bufs are internal don't strip them out. */
? res : bufs);
res = bufs;
@@ -1859,7 +1803,9 @@ If FLAG is nil, invoke `try-completion'; if it is t, invoke
else if (EQ (flag, Qlambda))
return Ftest_completion (string, Vbuffer_alist, predicate);
else if (EQ (flag, Qmetadata))
- return list2 (Qmetadata, Fcons (Qcategory, Qbuffer));
+ return list3 (Qmetadata,
+ Fcons (Qcategory, Qbuffer),
+ Fcons (Qcycle_sort_function, Qidentity));
else
return Qnil;
}
@@ -1893,8 +1839,8 @@ single string, rather than a cons cell whose car is a string. */)
thiscar = Fsymbol_name (thiscar);
else if (!STRINGP (thiscar))
continue;
- tem = Fcompare_strings (thiscar, make_number (0), Qnil,
- key, make_number (0), Qnil,
+ tem = Fcompare_strings (thiscar, make_fixnum (0), Qnil,
+ key, make_fixnum (0), Qnil,
case_fold);
if (EQ (tem, Qt))
return elt;
@@ -1908,7 +1854,7 @@ DEFUN ("minibuffer-depth", Fminibuffer_depth, Sminibuffer_depth, 0, 0, 0,
doc: /* Return current depth of activations of minibuffer, a nonnegative integer. */)
(void)
{
- return make_number (minibuf_level);
+ return make_fixnum (minibuf_level);
}
DEFUN ("minibuffer-prompt", Fminibuffer_prompt, Sminibuffer_prompt, 0, 0, 0,
@@ -1920,21 +1866,36 @@ If no minibuffer is active, return nil. */)
}
+
+static void init_minibuf_once_for_pdumper (void);
+
void
init_minibuf_once (void)
{
- Vminibuffer_list = Qnil;
staticpro (&Vminibuffer_list);
+ pdumper_do_now_and_after_load (init_minibuf_once_for_pdumper);
}
-void
-syms_of_minibuf (void)
+static void
+init_minibuf_once_for_pdumper (void)
{
+ PDUMPER_IGNORE (minibuf_level);
+ PDUMPER_IGNORE (minibuf_prompt_width);
+
+ /* We run this function on first initialization and whenever we
+ restore from a pdumper image. pdumper doesn't try to preserve
+ frames, windows, and so on, so reset everything related here. */
+ Vminibuffer_list = Qnil;
minibuf_level = 0;
minibuf_prompt = Qnil;
- staticpro (&minibuf_prompt);
-
minibuf_save_list = Qnil;
+ last_minibuf_string = Qnil;
+}
+
+void
+syms_of_minibuf (void)
+{
+ staticpro (&minibuf_prompt);
staticpro (&minibuf_save_list);
DEFSYM (Qcompletion_ignore_case, "completion-ignore-case");
@@ -1944,7 +1905,9 @@ syms_of_minibuf (void)
DEFSYM (Qminibuffer_completion_table, "minibuffer-completion-table");
staticpro (&last_minibuf_string);
- last_minibuf_string = Qnil;
+
+ DEFSYM (Qcustom_variable_history, "custom-variable-history");
+ Fset (Qcustom_variable_history, Qnil);
DEFSYM (Qminibuffer_history, "minibuffer-history");
DEFSYM (Qbuffer_name_history, "buffer-name-history");
@@ -1963,6 +1926,8 @@ syms_of_minibuf (void)
DEFSYM (Qactivate_input_method, "activate-input-method");
DEFSYM (Qcase_fold_search, "case-fold-search");
DEFSYM (Qmetadata, "metadata");
+ DEFSYM (Qcycle_sort_function, "cycle-sort-function");
+
/* A frame parameter. */
DEFSYM (Qminibuffer_exit, "minibuffer-exit");
@@ -2132,7 +2097,6 @@ uses to hide passwords. */);
defsubr (&Sminibuffer_prompt_end);
defsubr (&Sminibuffer_contents);
defsubr (&Sminibuffer_contents_no_properties);
- defsubr (&Sminibuffer_completion_contents);
defsubr (&Stry_completion);
defsubr (&Sall_completions);
diff --git a/src/module-env-25.h b/src/module-env-25.h
index 675010b995b..d8f8eb68119 100644
--- a/src/module-env-25.h
+++ b/src/module-env-25.h
@@ -88,13 +88,13 @@
EMACS_ATTRIBUTE_NONNULL(1);
/* Copy the content of the Lisp string VALUE to BUFFER as an utf8
- null-terminated string.
+ NUL-terminated string.
SIZE must point to the total size of the buffer. If BUFFER is
NULL or if SIZE is not big enough, write the required buffer size
to SIZE and return true.
- Note that SIZE must include the last null byte (e.g. "abc" needs
+ Note that SIZE must include the last NUL byte (e.g. "abc" needs
a buffer of size 4).
Return true if the string was successfully copied. */
diff --git a/src/module-env-27.h b/src/module-env-27.h
new file mode 100644
index 00000000000..b491b60fbbc
--- /dev/null
+++ b/src/module-env-27.h
@@ -0,0 +1,4 @@
+ /* Processes pending input events and returns whether the module
+ function should quit. */
+ enum emacs_process_input_result (*process_input) (emacs_env *env)
+ EMACS_ATTRIBUTE_NONNULL (1);
diff --git a/src/msdos.c b/src/msdos.c
index 3645dc8bb30..7dd5f5747aa 100644
--- a/src/msdos.c
+++ b/src/msdos.c
@@ -223,8 +223,8 @@ them. This happens with wheeled mice on Windows 9X, for example. */)
{
int n;
- CHECK_NUMBER (nbuttons);
- n = XINT (nbuttons);
+ CHECK_FIXNUM (nbuttons);
+ n = XFIXNUM (nbuttons);
if (n < 2 || n > 3)
xsignal2 (Qargs_out_of_range,
build_string ("only 2 or 3 mouse buttons are supported"),
@@ -322,8 +322,8 @@ mouse_get_pos (struct frame **f, int insist, Lisp_Object *bar_window,
*bar_window = Qnil;
mouse_get_xy (&ix, &iy);
*time = event_timestamp ();
- *x = make_number (mouse_last_x = ix);
- *y = make_number (mouse_last_y = iy);
+ *x = make_fixnum (mouse_last_x = ix);
+ *y = make_fixnum (mouse_last_y = iy);
}
static void
@@ -539,8 +539,8 @@ dos_set_window_size (int *rows, int *cols)
(video_name, "screen-dimensions-%dx%d",
*rows, *cols), Qnil));
- if (INTEGERP (video_mode)
- && (video_mode_value = XINT (video_mode)) > 0)
+ if (FIXNUMP (video_mode)
+ && (video_mode_value = XFIXNUM (video_mode)) > 0)
{
regs.x.ax = video_mode_value;
int86 (0x10, &regs, &regs);
@@ -742,21 +742,21 @@ IT_set_cursor_type (struct frame *f, Lisp_Object cursor_type)
Lisp_Object bar_parms = XCDR (cursor_type);
int width;
- if (INTEGERP (bar_parms))
+ if (FIXNUMP (bar_parms))
{
/* Feature: negative WIDTH means cursor at the top
of the character cell, zero means invisible cursor. */
- width = XINT (bar_parms);
+ width = XFIXNUM (bar_parms);
msdos_set_cursor_shape (f, width >= 0 ? DEFAULT_CURSOR_START : 0,
width);
}
else if (CONSP (bar_parms)
- && INTEGERP (XCAR (bar_parms))
- && INTEGERP (XCDR (bar_parms)))
+ && FIXNUMP (XCAR (bar_parms))
+ && FIXNUMP (XCDR (bar_parms)))
{
- int start_line = XINT (XCDR (bar_parms));
+ int start_line = XFIXNUM (XCDR (bar_parms));
- width = XINT (XCAR (bar_parms));
+ width = XFIXNUM (XCAR (bar_parms));
msdos_set_cursor_shape (f, start_line, width);
}
}
@@ -1321,7 +1321,7 @@ IT_frame_up_to_date (struct frame *f)
if (EQ (BVAR (b,cursor_type), Qt))
new_cursor = frame_desired_cursor;
else if (NILP (BVAR (b, cursor_type))) /* nil means no cursor */
- new_cursor = Fcons (Qbar, make_number (0));
+ new_cursor = Fcons (Qbar, make_fixnum (0));
else
new_cursor = BVAR (b, cursor_type);
}
@@ -1564,7 +1564,7 @@ void
IT_set_frame_parameters (struct frame *f, Lisp_Object alist)
{
Lisp_Object tail;
- int i, j, length = XINT (Flength (alist));
+ int i, j, length = XFIXNUM (Flength (alist));
Lisp_Object *parms
= (Lisp_Object *) alloca (length * word_size);
Lisp_Object *values
@@ -1791,7 +1791,7 @@ internal_terminal_init (void)
}
Vinitial_window_system = Qpc;
- Vwindow_system_version = make_number (26); /* RE Emacs version */
+ Vwindow_system_version = make_fixnum (27); /* RE Emacs version */
tty->terminal->type = output_msdos_raw;
/* If Emacs was dumped on DOS/V machine, forget the stale VRAM
@@ -2423,11 +2423,11 @@ dos_rawgetc (void)
sc = regs.h.ah;
total_doskeys += 2;
- ASET (recent_doskeys, recent_doskeys_index, make_number (c));
+ ASET (recent_doskeys, recent_doskeys_index, make_fixnum (c));
recent_doskeys_index++;
if (recent_doskeys_index == NUM_RECENT_DOSKEYS)
recent_doskeys_index = 0;
- ASET (recent_doskeys, recent_doskeys_index, make_number (sc));
+ ASET (recent_doskeys, recent_doskeys_index, make_fixnum (sc));
recent_doskeys_index++;
if (recent_doskeys_index == NUM_RECENT_DOSKEYS)
recent_doskeys_index = 0;
@@ -2609,7 +2609,7 @@ dos_rawgetc (void)
if (code == 0)
continue;
- if (!hlinfo->mouse_face_hidden && INTEGERP (Vmouse_highlight))
+ if (!hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight))
{
clear_mouse_face (hlinfo);
hlinfo->mouse_face_hidden = 1;
@@ -2718,8 +2718,8 @@ dos_rawgetc (void)
event.code = button_num;
event.modifiers = dos_get_modifiers (0)
| (press ? down_modifier : up_modifier);
- event.x = make_number (x);
- event.y = make_number (y);
+ event.x = make_fixnum (x);
+ event.y = make_fixnum (y);
event.frame_or_window = selected_frame;
event.arg = Qnil;
event.timestamp = event_timestamp ();
@@ -3063,15 +3063,15 @@ XMenuActivate (Display *foo, XMenu *menu, int *pane, int *selidx,
state = alloca (menu->panecount * sizeof (struct IT_menu_state));
screensize = screen_size * 2;
faces[0]
- = lookup_derived_face (sf, intern ("msdos-menu-passive-face"),
+ = lookup_derived_face (NULL, sf, intern ("msdos-menu-passive-face"),
DEFAULT_FACE_ID, 1);
faces[1]
- = lookup_derived_face (sf, intern ("msdos-menu-active-face"),
+ = lookup_derived_face (NULL, sf, intern ("msdos-menu-active-face"),
DEFAULT_FACE_ID, 1);
selectface = intern ("msdos-menu-select-face");
- faces[2] = lookup_derived_face (sf, selectface,
+ faces[2] = lookup_derived_face (NULL, sf, selectface,
faces[0], 1);
- faces[3] = lookup_derived_face (sf, selectface,
+ faces[3] = lookup_derived_face (NULL, sf, selectface,
faces[1], 1);
/* Make sure the menu title is always displayed with
@@ -4196,7 +4196,7 @@ msdos_fatal_signal (int sig)
void
syms_of_msdos (void)
{
- recent_doskeys = Fmake_vector (make_number (NUM_RECENT_DOSKEYS), Qnil);
+ recent_doskeys = Fmake_vector (make_fixnum (NUM_RECENT_DOSKEYS), Qnil);
staticpro (&recent_doskeys);
#ifndef HAVE_X_WINDOWS
@@ -4207,7 +4207,7 @@ syms_of_msdos (void)
DEFVAR_LISP ("dos-unsupported-char-glyph", Vdos_unsupported_char_glyph,
doc: /* Glyph to display instead of chars not supported by current codepage.
This variable is used only by MS-DOS terminals. */);
- Vdos_unsupported_char_glyph = make_number ('\177');
+ Vdos_unsupported_char_glyph = make_fixnum ('\177');
#endif
diff --git a/src/nsfns.m b/src/nsfns.m
index 59798d3bddc..ee7598a1c7e 100644
--- a/src/nsfns.m
+++ b/src/nsfns.m
@@ -27,7 +27,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu)
*/
/* This should be the first include, as it may set up #defines affecting
- interpretation of even the system includes. */
+ interpretation of even the system includes. */
#include <config.h>
#include <math.h>
@@ -49,19 +49,17 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu)
#include "macfont.h"
#endif
-
#ifdef HAVE_NS
static EmacsTooltip *ns_tooltip = nil;
-/* Static variables to handle applescript execution. */
+/* Static variables to handle AppleScript execution. */
static Lisp_Object as_script, *as_result;
static int as_status;
static ptrdiff_t image_cache_refcount;
static struct ns_display_info *ns_display_info_for_name (Lisp_Object);
-static void ns_set_name_as_filename (struct frame *);
/* ==========================================================================
@@ -117,7 +115,7 @@ ns_get_window (Lisp_Object maybeFrame)
id view =nil, window =nil;
if (!FRAMEP (maybeFrame) || !FRAME_NS_P (XFRAME (maybeFrame)))
- maybeFrame = selected_frame;/*wrong_type_argument (Qframep, maybeFrame); */
+ maybeFrame = selected_frame; /* wrong_type_argument (Qframep, maybeFrame); */
if (!NILP (maybeFrame))
view = FRAME_NS_VIEW (XFRAME (maybeFrame));
@@ -179,7 +177,7 @@ ns_directory_from_panel (NSSavePanel *panel)
static Lisp_Object
interpret_services_menu (NSMenu *menu, Lisp_Object prefix, Lisp_Object old)
/* --------------------------------------------------------------------------
- Turn the input menu (an NSMenu) into a lisp list for tracking on lisp side
+ Turn the input menu (an NSMenu) into a lisp list for tracking on lisp side.
-------------------------------------------------------------------------- */
{
int i, count;
@@ -210,7 +208,7 @@ interpret_services_menu (NSMenu *menu, Lisp_Object prefix, Lisp_Object old)
if (keys && [keys length] )
{
key = [keys characterAtIndex: 0];
- res = make_number (key|super_modifier);
+ res = make_fixnum (key|super_modifier);
}
else
{
@@ -262,7 +260,7 @@ x_set_foreground_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
if (FRAME_NS_VIEW (f))
{
update_face_from_frame_parameter (f, Qforeground_color, arg);
- /*recompute_basic_faces (f); */
+ /* recompute_basic_faces (f); */
if (FRAME_VISIBLE_P (f))
SET_FRAME_GARBAGED (f);
}
@@ -286,8 +284,9 @@ x_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
error ("Unknown color");
}
- /* clear the frame; in some instances the NS-internal GC appears not to
- update, or it does update and cannot clear old text properly */
+ /* Clear the frame; in some instances the NS-internal GC appears not
+ to update, or it does update and cannot clear old text
+ properly. */
if (FRAME_VISIBLE_P (f))
ns_clear_frame (f);
@@ -357,13 +356,13 @@ x_set_icon_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
NSView *view = FRAME_NS_VIEW (f);
NSTRACE ("x_set_icon_name");
- /* see if it's changed */
+ /* See if it's changed. */
if (STRINGP (arg))
{
if (STRINGP (oldval) && EQ (Fstring_equal (oldval, arg), Qt))
return;
}
- else if (!STRINGP (oldval) && EQ (oldval, Qnil) == EQ (arg, Qnil))
+ else if (!STRINGP (oldval) && NILP (oldval) == NILP (arg))
return;
fset_icon_name (f, arg);
@@ -463,6 +462,47 @@ ns_set_name (struct frame *f, Lisp_Object name, int explicit)
ns_set_name_internal (f, name);
}
+static void
+ns_set_represented_filename (struct frame *f)
+{
+ Lisp_Object filename, encoded_filename;
+ Lisp_Object buf = XWINDOW (f->selected_window)->contents;
+ NSAutoreleasePool *pool;
+ NSString *fstr;
+ NSView *view = FRAME_NS_VIEW (f);
+
+ NSTRACE ("ns_set_represented_filename");
+
+ if (f->explicit_name || ! NILP (f->title))
+ return;
+
+ block_input ();
+ pool = [[NSAutoreleasePool alloc] init];
+ filename = BVAR (XBUFFER (buf), filename);
+
+ if (! NILP (filename))
+ {
+ encoded_filename = ENCODE_UTF_8 (filename);
+
+ fstr = [NSString stringWithUTF8String: SSDATA (encoded_filename)];
+ if (fstr == nil) fstr = @"";
+ }
+ else
+ fstr = @"";
+
+#ifdef NS_IMPL_COCOA
+ /* Work around a bug observed on 10.3 and later where
+ setTitleWithRepresentedFilename does not clear out previous state
+ if given filename does not exist. */
+ if (! [[NSFileManager defaultManager] fileExistsAtPath: fstr])
+ [[view window] setRepresentedFilename: @""];
+#endif
+ [[view window] setRepresentedFilename: fstr];
+
+ [pool release];
+ unblock_input ();
+}
+
/* This function should be called when the user's lisp code has
specified a name for the frame; the name will override any set by the
@@ -483,17 +523,10 @@ x_implicitly_set_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
{
NSTRACE ("x_implicitly_set_name");
- Lisp_Object frame_title = buffer_local_value
- (Qframe_title_format, XWINDOW (f->selected_window)->contents);
- Lisp_Object icon_title = buffer_local_value
- (Qicon_title_format, XWINDOW (f->selected_window)->contents);
+ if (ns_use_proxy_icon)
+ ns_set_represented_filename (f);
- /* Deal with NS specific format t. */
- if (FRAME_NS_P (f) && ((FRAME_ICONIFIED_P (f) && EQ (icon_title, Qt))
- || EQ (frame_title, Qt)))
- ns_set_name_as_filename (f);
- else
- ns_set_name (f, arg, 0);
+ ns_set_name (f, arg, 0);
}
@@ -520,78 +553,6 @@ x_set_title (struct frame *f, Lisp_Object name, Lisp_Object old_name)
ns_set_name_internal (f, name);
}
-
-static void
-ns_set_name_as_filename (struct frame *f)
-{
- NSView *view;
- Lisp_Object name, filename;
- Lisp_Object buf = XWINDOW (f->selected_window)->contents;
- const char *title;
- NSAutoreleasePool *pool;
- Lisp_Object encoded_name, encoded_filename;
- NSString *str;
- NSTRACE ("ns_set_name_as_filename");
-
- if (f->explicit_name || ! NILP (f->title))
- return;
-
- block_input ();
- pool = [[NSAutoreleasePool alloc] init];
- filename = BVAR (XBUFFER (buf), filename);
- name = BVAR (XBUFFER (buf), name);
-
- if (NILP (name))
- {
- if (! NILP (filename))
- name = Ffile_name_nondirectory (filename);
- else
- name = build_string ([ns_app_name UTF8String]);
- }
-
- encoded_name = ENCODE_UTF_8 (name);
-
- view = FRAME_NS_VIEW (f);
-
- title = FRAME_ICONIFIED_P (f) ? [[[view window] miniwindowTitle] UTF8String]
- : [[[view window] title] UTF8String];
-
- if (title && (! strcmp (title, SSDATA (encoded_name))))
- {
- [pool release];
- unblock_input ();
- return;
- }
-
- str = [NSString stringWithUTF8String: SSDATA (encoded_name)];
- if (str == nil) str = @"Bad coding";
-
- if (FRAME_ICONIFIED_P (f))
- [[view window] setMiniwindowTitle: str];
- else
- {
- NSString *fstr;
-
- if (! NILP (filename))
- {
- encoded_filename = ENCODE_UTF_8 (filename);
-
- fstr = [NSString stringWithUTF8String: SSDATA (encoded_filename)];
- if (fstr == nil) fstr = @"";
- }
- else
- fstr = @"";
-
- ns_set_represented_filename (fstr, f);
- [[view window] setTitle: str];
- fset_name (f, name);
- }
-
- [pool release];
- unblock_input ();
-}
-
-
void
ns_set_doc_edited (void)
{
@@ -627,8 +588,8 @@ x_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
if (FRAME_MINIBUF_ONLY_P (f))
return;
- if (TYPE_RANGED_INTEGERP (int, value))
- nlines = XINT (value);
+ if (TYPE_RANGED_FIXNUMP (int, value))
+ nlines = XFIXNUM (value);
else
nlines = 0;
@@ -636,14 +597,14 @@ x_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
if (nlines)
{
FRAME_EXTERNAL_MENU_BAR (f) = 1;
- /* does for all frames, whereas we just want for one frame
+ /* Does for all frames, whereas we just want for one frame
[NSMenu setMenuBarVisible: YES]; */
}
else
{
if (FRAME_EXTERNAL_MENU_BAR (f) == 1)
free_frame_menubar (f);
- /* [NSMenu setMenuBarVisible: NO]; */
+ /* [NSMenu setMenuBarVisible: NO]; */
FRAME_EXTERNAL_MENU_BAR (f) = 0;
}
}
@@ -653,11 +614,11 @@ x_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
static void
x_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
{
- /* Currently, when the tool bar change state, the frame is resized.
+ /* Currently, when the tool bar changes state, the frame is resized.
TODO: It would be better if this didn't occur when 1) the frame
is full height or maximized or 2) when specified by
- `frame-inhibit-implied-resize'. */
+ `frame-inhibit-implied-resize'. */
int nlines;
NSTRACE ("x_set_tool_bar_lines");
@@ -665,8 +626,8 @@ x_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
if (FRAME_MINIBUF_ONLY_P (f))
return;
- if (RANGED_INTEGERP (0, value, INT_MAX))
- nlines = XFASTINT (value);
+ if (RANGED_FIXNUMP (0, value, INT_MAX))
+ nlines = XFIXNAT (value);
else
nlines = 0;
@@ -724,7 +685,7 @@ x_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldva
int old_width = FRAME_INTERNAL_BORDER_WIDTH (f);
CHECK_TYPE_RANGED_INTEGER (int, arg);
- f->internal_border_width = XINT (arg);
+ f->internal_border_width = XFIXNUM (arg);
if (FRAME_INTERNAL_BORDER_WIDTH (f) < 0)
f->internal_border_width = 0;
@@ -774,7 +735,7 @@ ns_implicitly_set_icon_type (struct frame *f)
chain = XCDR (chain))
{
elt = XCAR (chain);
- /* special case: t means go by file type */
+ /* Special case: t means go by file type. */
if (SYMBOLP (elt) && EQ (elt, Qt) && SSDATA (f->name)[0] == '/')
{
NSString *str
@@ -824,7 +785,7 @@ x_set_icon_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
store_frame_param (f, Qicon_type, arg);
}
- /* do it the implicit way */
+ /* Do it the implicit way. */
if (NILP (arg))
{
ns_implicitly_set_icon_type (f);
@@ -860,7 +821,7 @@ x_set_cursor_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
static void
x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
{
- /* don't think we can do this on Nextstep */
+ /* Don't think we can do this on Nextstep. */
}
@@ -889,7 +850,7 @@ ns_appkit_version_str (void)
/* This is for use by x-server-version and collapses all version info we
have into a single int. For a better picture of the implementation
- running, use ns_appkit_version_str.*/
+ running, use ns_appkit_version_str. */
static int
ns_appkit_version_int (void)
{
@@ -922,17 +883,18 @@ x_icon (struct frame *f, Lisp_Object parms)
icon_y = x_get_arg (dpyinfo, parms, Qicon_top, 0, 0, RES_TYPE_NUMBER);
if (!EQ (icon_x, Qunbound) && !EQ (icon_y, Qunbound))
{
- CHECK_NUMBER (icon_x);
- CHECK_NUMBER (icon_y);
- f->output_data.ns->icon_top = XINT (icon_y);
- f->output_data.ns->icon_left = XINT (icon_x);
+ CHECK_FIXNUM (icon_x);
+ CHECK_FIXNUM (icon_y);
+ f->output_data.ns->icon_top = XFIXNUM (icon_y);
+ f->output_data.ns->icon_left = XFIXNUM (icon_x);
}
else if (!EQ (icon_x, Qunbound) || !EQ (icon_y, Qunbound))
error ("Both left and top icon corners of icon must be specified");
}
-/* Note: see frame.c for template, also where generic functions are impl */
+/* Note: see frame.c for template, also where generic functions are
+ implemented. */
frame_parm_handler ns_frame_parm_handlers[] =
{
x_set_autoraise, /* generic OK */
@@ -976,7 +938,7 @@ frame_parm_handler ns_frame_parm_handlers[] =
#ifdef NS_IMPL_COCOA
x_set_undecorated,
#else
- 0, /*x_set_undecorated */
+ 0, /* x_set_undecorated */
#endif
x_set_parent_frame,
0, /* x_set_skip_taskbar */
@@ -1078,15 +1040,7 @@ get_geometry_from_preferences (struct ns_display_info *dpyinfo,
DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame,
1, 1, 0,
- doc: /* Make a new Nextstep window, called a "frame" in Emacs terms.
-Return an Emacs frame object.
-PARMS is an alist of frame parameters.
-If the parameters specify that the frame should not have a minibuffer,
-and do not specify a specific minibuffer window to use,
-then `default-minibuffer-frame' must be a frame whose minibuffer can
-be shared by the new frame.
-
-This function is an internal primitive--use `make-frame' instead. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object parms)
{
struct frame *f;
@@ -1131,7 +1085,7 @@ This function is an internal primitive--use `make-frame' instead. */)
if (EQ (parent, Qunbound))
parent = Qnil;
if (! NILP (parent))
- CHECK_NUMBER (parent);
+ CHECK_FIXNUM (parent);
/* make_frame_without_minibuffer can run Lisp code and garbage collect. */
/* No need to protect DISPLAY because that's not used after passing
@@ -1172,9 +1126,9 @@ This function is an internal primitive--use `make-frame' instead. */)
record_unwind_protect (unwind_create_frame, frame);
f->output_data.ns->window_desc = desc_ctr++;
- if (TYPE_RANGED_INTEGERP (Window, parent))
+ if (TYPE_RANGED_FIXNUMP (Window, parent))
{
- f->output_data.ns->parent_desc = XFASTINT (parent);
+ f->output_data.ns->parent_desc = XFIXNAT (parent);
f->output_data.ns->explicit_parent = 1;
}
else
@@ -1215,7 +1169,7 @@ This function is an internal primitive--use `make-frame' instead. */)
/* use for default font name */
id font = [NSFont userFixedPitchFontOfSize: -1.0]; /* default */
x_default_parameter (f, parms, Qfontsize,
- make_number (0 /*(int)[font pointSize]*/),
+ make_fixnum (0 /* (int)[font pointSize] */),
"fontSize", "FontSize", RES_TYPE_NUMBER);
// Remove ' Regular', not handled by backends.
char *fontname = xstrdup ([[font displayName] UTF8String]);
@@ -1229,14 +1183,14 @@ This function is an internal primitive--use `make-frame' instead. */)
}
unblock_input ();
- x_default_parameter (f, parms, Qborder_width, make_number (0),
+ x_default_parameter (f, parms, Qborder_width, make_fixnum (0),
"borderwidth", "BorderWidth", RES_TYPE_NUMBER);
- x_default_parameter (f, parms, Qinternal_border_width, make_number (2),
+ x_default_parameter (f, parms, Qinternal_border_width, make_fixnum (2),
"internalBorderWidth", "InternalBorderWidth",
RES_TYPE_NUMBER);
- x_default_parameter (f, parms, Qright_divider_width, make_number (0),
+ x_default_parameter (f, parms, Qright_divider_width, make_fixnum (0),
NULL, NULL, RES_TYPE_NUMBER);
- x_default_parameter (f, parms, Qbottom_divider_width, make_number (0),
+ x_default_parameter (f, parms, Qbottom_divider_width, make_fixnum (0),
NULL, NULL, RES_TYPE_NUMBER);
/* default vertical scrollbars on right on Mac */
@@ -1258,7 +1212,6 @@ This function is an internal primitive--use `make-frame' instead. */)
"foreground", "Foreground", RES_TYPE_STRING);
x_default_parameter (f, parms, Qbackground_color, build_string ("White"),
"background", "Background", RES_TYPE_STRING);
- /* FIXME: not supported yet in Nextstep */
x_default_parameter (f, parms, Qline_spacing, Qnil,
"lineSpacing", "LineSpacing", RES_TYPE_NUMBER);
x_default_parameter (f, parms, Qleft_fringe, Qnil,
@@ -1272,10 +1225,10 @@ This function is an internal primitive--use `make-frame' instead. */)
/* Read comment about this code in corresponding place in xfns.c. */
tem = x_get_arg (dpyinfo, parms, Qmin_width, NULL, NULL, RES_TYPE_NUMBER);
- if (NUMBERP (tem))
+ if (FIXNUMP (tem))
store_frame_param (f, Qmin_width, tem);
tem = x_get_arg (dpyinfo, parms, Qmin_height, NULL, NULL, RES_TYPE_NUMBER);
- if (NUMBERP (tem))
+ if (FIXNUMP (tem))
store_frame_param (f, Qmin_height, tem);
adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f),
FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, 1,
@@ -1321,11 +1274,11 @@ This function is an internal primitive--use `make-frame' instead. */)
variables; ignore them here. */
x_default_parameter (f, parms, Qmenu_bar_lines,
NILP (Vmenu_bar_mode)
- ? make_number (0) : make_number (1),
+ ? make_fixnum (0) : make_fixnum (1),
NULL, NULL, RES_TYPE_NUMBER);
x_default_parameter (f, parms, Qtool_bar_lines,
NILP (Vtool_bar_mode)
- ? make_number (0) : make_number (1),
+ ? make_fixnum (0) : make_fixnum (1),
NULL, NULL, RES_TYPE_NUMBER);
x_default_parameter (f, parms, Qbuffer_predicate, Qnil, "bufferPredicate",
@@ -1337,10 +1290,10 @@ This function is an internal primitive--use `make-frame' instead. */)
window_prompting = x_figure_window_size (f, parms, true, &x_width, &x_height);
tem = x_get_arg (dpyinfo, parms, Qunsplittable, 0, 0, RES_TYPE_BOOLEAN);
- f->no_split = minibuffer_only || (!EQ (tem, Qunbound) && !EQ (tem, Qnil));
+ f->no_split = minibuffer_only || (!EQ (tem, Qunbound) && !NILP (tem));
/* NOTE: on other terms, this is done in set_mouse_color, however this
- was not getting called under Nextstep */
+ was not getting called under Nextstep. */
f->output_data.ns->text_cursor = [NSCursor IBeamCursor];
f->output_data.ns->nontext_cursor = [NSCursor arrowCursor];
f->output_data.ns->modeline_cursor = [NSCursor pointingHandCursor];
@@ -1372,8 +1325,9 @@ This function is an internal primitive--use `make-frame' instead. */)
/* ns_display_info does not have a reference_count. */
f->terminal->reference_count++;
- /* It is now ok to make the frame official even if we get an error below.
- The frame needs to be on Vframe_list or making it visible won't work. */
+ /* It is now ok to make the frame official even if we get an error
+ below. The frame needs to be on Vframe_list or making it visible
+ won't work. */
Vframe_list = Fcons (frame, Vframe_list);
x_default_parameter (f, parms, Qicon_type, Qnil,
@@ -1467,7 +1421,7 @@ x_focus_frame (struct frame *f, bool noactivate)
static BOOL
ns_window_is_ancestor (NSWindow *win, NSWindow *candidate)
-/* Test whether CANDIDATE is an ancestor window of WIN. */
+/* Test whether CANDIDATE is an ancestor window of WIN. */
{
if (candidate == NULL)
return NO;
@@ -1542,7 +1496,7 @@ Some window managers may refuse to restack windows. */)
DEFUN ("ns-popup-font-panel", Fns_popup_font_panel, Sns_popup_font_panel,
0, 1, "",
- doc: /* Pop up the font panel. */)
+ doc: /* Pop up the font panel. */)
(Lisp_Object frame)
{
struct frame *f = decode_window_system_frame (frame);
@@ -1783,23 +1737,18 @@ If VALUE is nil, the default is removed. */)
DEFUN ("x-server-max-request-size", Fx_server_max_request_size,
Sx_server_max_request_size,
0, 1, 0,
- doc: /* This function is a no-op. It is only present for completeness. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object terminal)
{
check_ns_display_info (terminal);
- /* This function has no real equivalent under NeXTstep. Return nil to
- indicate this. */
+ /* This function has no real equivalent under Nextstep. Return nil to
+ indicate this. */
return Qnil;
}
DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0,
- doc: /* Return the "vendor ID" string of Nextstep display server TERMINAL.
-\(Labeling every distributor as a "vendor" embodies the false assumption
-that operating systems cannot be developed and distributed noncommercially.)
-The optional argument TERMINAL specifies which display to ask about.
-TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object terminal)
{
check_ns_display_info (terminal);
@@ -1812,95 +1761,66 @@ If omitted or nil, that stands for the selected frame's display. */)
DEFUN ("x-server-version", Fx_server_version, Sx_server_version, 0, 1, 0,
- doc: /* Return the version numbers of the server of display TERMINAL.
-The value is a list of three integers: the major and minor
-version numbers of the X Protocol in use, and the distributor-specific release
-number. See also the function `x-server-vendor'.
-
-The optional argument TERMINAL specifies which display to ask about.
-TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object terminal)
{
check_ns_display_info (terminal);
- /*NOTE: it is unclear what would best correspond with "protocol";
- we return 10.3, meaning Panther, since this is roughly the
- level that GNUstep's APIs correspond to.
- The last number is where we distinguish between the Apple
- and GNUstep implementations ("distributor-specific release
- number") and give int'ized versions of major.minor. */
+ /* NOTE: it is unclear what would best correspond with "protocol";
+ we return 10.3, meaning Panther, since this is roughly the
+ level that GNUstep's APIs correspond to. The last number
+ is where we distinguish between the Apple and GNUstep
+ implementations ("distributor-specific release number") and
+ give int'ized versions of major.minor. */
return list3i (10, 3, ns_appkit_version_int ());
}
DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens, 0, 1, 0,
- doc: /* Return the number of screens on Nextstep display server TERMINAL.
-The optional argument TERMINAL specifies which display to ask about.
-TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display.
-
-Note: "screen" here is not in Nextstep terminology but in X11's. For
-the number of physical monitors, use `(length
-\(display-monitor-attributes-list TERMINAL))' instead. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object terminal)
{
check_ns_display_info (terminal);
- return make_number (1);
+ return make_fixnum (1);
}
DEFUN ("x-display-mm-height", Fx_display_mm_height, Sx_display_mm_height, 0, 1, 0,
- doc: /* Return the height in millimeters of the Nextstep display TERMINAL.
-The optional argument TERMINAL specifies which display to ask about.
-TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display.
-
-On \"multi-monitor\" setups this refers to the height in millimeters for
-all physical monitors associated with TERMINAL. To get information
-for each physical monitor, use `display-monitor-attributes-list'. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object terminal)
{
struct ns_display_info *dpyinfo = check_ns_display_info (terminal);
- return make_number (x_display_pixel_height (dpyinfo) / (92.0/25.4));
+ return make_fixnum (x_display_pixel_height (dpyinfo) / (92.0/25.4));
}
DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0,
- doc: /* Return the width in millimeters of the Nextstep display TERMINAL.
-The optional argument TERMINAL specifies which display to ask about.
-TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display.
-
-On \"multi-monitor\" setups this refers to the width in millimeters for
-all physical monitors associated with TERMINAL. To get information
-for each physical monitor, use `display-monitor-attributes-list'. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object terminal)
{
struct ns_display_info *dpyinfo = check_ns_display_info (terminal);
- return make_number (x_display_pixel_width (dpyinfo) / (92.0/25.4));
+ return make_fixnum (x_display_pixel_width (dpyinfo) / (92.0/25.4));
}
DEFUN ("x-display-backing-store", Fx_display_backing_store,
Sx_display_backing_store, 0, 1, 0,
- doc: /* Return an indication of whether the Nextstep display TERMINAL does backing store.
-The value may be `buffered', `retained', or `non-retained'.
-The optional argument TERMINAL specifies which display to ask about.
-TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object terminal)
{
check_ns_display_info (terminal);
+ /* Note that the xfns.c version has different return values. */
switch ([ns_get_window (terminal) backingType])
{
case NSBackingStoreBuffered:
return intern ("buffered");
+#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101300
case NSBackingStoreRetained:
return intern ("retained");
case NSBackingStoreNonretained:
return intern ("non-retained");
+#endif
default:
error ("Strange value for backingType parameter of frame");
}
@@ -1910,13 +1830,7 @@ If omitted or nil, that stands for the selected frame's display. */)
DEFUN ("x-display-visual-class", Fx_display_visual_class,
Sx_display_visual_class, 0, 1, 0,
- doc: /* Return the visual class of the Nextstep display TERMINAL.
-The value is one of the symbols `static-gray', `gray-scale',
-`static-color', `pseudo-color', `true-color', or `direct-color'.
-
-The optional argument TERMINAL specifies which display to ask about.
-TERMINAL should a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object terminal)
{
NSWindowDepth depth;
@@ -1935,17 +1849,15 @@ If omitted or nil, that stands for the selected frame's display. */)
else if ( depth == NSBestDepth (NSCalibratedRGBColorSpace, 8, 24, NO, NULL))
return intern ("direct-color");
else
- /* color mgmt as far as we do it is really handled by Nextstep itself anyway */
+ /* Color management as far as we do it is really handled by
+ Nextstep itself anyway. */
return intern ("direct-color");
}
DEFUN ("x-display-save-under", Fx_display_save_under,
Sx_display_save_under, 0, 1, 0,
- doc: /* Return t if TERMINAL supports the save-under feature.
-The optional argument TERMINAL specifies which display to ask about.
-TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object terminal)
{
check_ns_display_info (terminal);
@@ -1954,9 +1866,11 @@ If omitted or nil, that stands for the selected frame's display. */)
case NSBackingStoreBuffered:
return Qt;
+#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101300
case NSBackingStoreRetained:
case NSBackingStoreNonretained:
return Qnil;
+#endif
default:
error ("Strange value for backingType parameter of frame");
@@ -1967,12 +1881,7 @@ If omitted or nil, that stands for the selected frame's display. */)
DEFUN ("x-open-connection", Fx_open_connection, Sx_open_connection,
1, 3, 0,
- doc: /* Open a connection to a display server.
-DISPLAY is the name of the display to connect to.
-Optional second arg XRM-STRING is a string of resources in xrdb format.
-If the optional third arg MUST-SUCCEED is non-nil,
-terminate Emacs if we can't open the connection.
-\(In the Nextstep version, the last two arguments are currently ignored.) */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object display, Lisp_Object resource_string, Lisp_Object must_succeed)
{
struct ns_display_info *dpyinfo;
@@ -1997,10 +1906,7 @@ terminate Emacs if we can't open the connection.
DEFUN ("x-close-connection", Fx_close_connection, Sx_close_connection,
1, 1, 0,
- doc: /* Close the connection to TERMINAL's Nextstep display server.
-For TERMINAL, specify a terminal object, a frame or a display name (a
-string). If TERMINAL is nil, that stands for the selected frame's
-terminal. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object terminal)
{
check_ns_display_info (terminal);
@@ -2010,7 +1916,7 @@ terminal. */)
DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0,
- doc: /* Return the list of display names that Emacs has connections to. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(void)
{
Lisp_Object result = Qnil;
@@ -2070,7 +1976,7 @@ DEFUN ("ns-font-name", Fns_font_name, Sns_font_name, 1, 1, 0,
doc: /* Determine font PostScript or family name for font NAME.
NAME should be a string containing either the font name or an XLFD
font descriptor. If string contains `fontset' and not
-`fontset-startup', it is left alone. */)
+`fontset-startup', it is left alone. */)
(Lisp_Object name)
{
char *nm;
@@ -2187,7 +2093,7 @@ there was no result. */)
status as function value. A zero is returned if compilation and
execution is successful, in which case *RESULT is set to a Lisp
string or a number containing the resulting script value. Otherwise,
- 1 is returned. */
+ 1 is returned. */
static int
ns_do_applescript (Lisp_Object script, Lisp_Object *result)
{
@@ -2228,7 +2134,7 @@ ns_do_applescript (Lisp_Object script, Lisp_Object *result)
// coerce the result to the appropriate ObjC type
desc = [returnDescriptor coerceToDescriptorType: typeUTF8Text];
if (desc)
- *result = make_number([desc int32Value]);
+ *result = make_fixnum([desc int32Value]);
}
}
}
@@ -2240,7 +2146,7 @@ ns_do_applescript (Lisp_Object script, Lisp_Object *result)
return 0;
}
-/* Helper function called from sendEvent to run applescript
+/* Helper function called from sendEvent to run AppleScript
from within the main event loop. */
void
@@ -2255,7 +2161,7 @@ DEFUN ("ns-do-applescript", Fns_do_applescript, Sns_do_applescript, 1, 1, 0,
doc: /* Execute AppleScript SCRIPT and return the result.
If compilation and execution are successful, the resulting script value
is returned as a string, a number or, in the case of other constructs, t.
-In case the execution fails, an error is signaled. */)
+In case the execution fails, an error is signaled. */)
(Lisp_Object script)
{
Lisp_Object result;
@@ -2271,10 +2177,10 @@ In case the execution fails, an error is signaled. */)
as_script = script;
as_result = &result;
- /* executing apple script requires the event loop to run, otherwise
+ /* Executing AppleScript requires the event loop to run, otherwise
errors aren't returned and executeAndReturnError hangs forever.
- Post an event that runs applescript and then start the event loop.
- The event loop is exited when the script is done. */
+ Post an event that runs AppleScript and then start the event
+ loop. The event loop is exited when the script is done. */
nxev = [NSEvent otherEventWithType: NSEventTypeApplicationDefined
location: NSMakePoint (0, 0)
modifierFlags: 0
@@ -2287,8 +2193,8 @@ In case the execution fails, an error is signaled. */)
[NSApp postEvent: nxev atStart: NO];
- // If there are other events, the event loop may exit. Keep running
- // until the script has been handled. */
+ /* If there are other events, the event loop may exit. Keep running
+ until the script has been handled. */
ns_init_events (&ev);
while (! NILP (as_script))
[NSApp run];
@@ -2341,7 +2247,7 @@ x_set_scroll_bar_default_height (struct frame *f)
height - 1) / height;
}
-/* terms impl this instead of x-get-resource directly */
+/* Terms implement this instead of x-get-resource directly. */
char *
x_get_string_resource (XrmDatabase rdb, const char *name, const char *class)
{
@@ -2383,8 +2289,7 @@ x_get_focus_frame (struct frame *frame)
DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0,
- doc: /* Internal function called by `color-defined-p', which see.
-\(Note that the Nextstep version of this function ignores FRAME.) */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object color, Lisp_Object frame)
{
NSColor * col;
@@ -2394,7 +2299,7 @@ DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0,
DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0,
- doc: /* Internal function called by `color-values', which see. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object color, Lisp_Object frame)
{
NSColor * col;
@@ -2419,7 +2324,7 @@ DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0,
DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0,
- doc: /* Internal function called by `display-color-p', which see. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object terminal)
{
NSWindowDepth depth;
@@ -2437,11 +2342,7 @@ DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0,
DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p, Sx_display_grayscale_p,
0, 1, 0,
- doc: /* Return t if the Nextstep display supports shades of gray.
-Note that color displays do support shades of gray.
-The optional argument TERMINAL specifies which display to ask about.
-TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object terminal)
{
NSWindowDepth depth;
@@ -2455,37 +2356,23 @@ If omitted or nil, that stands for the selected frame's display. */)
DEFUN ("x-display-pixel-width", Fx_display_pixel_width, Sx_display_pixel_width,
0, 1, 0,
- doc: /* Return the width in pixels of the Nextstep display TERMINAL.
-The optional argument TERMINAL specifies which display to ask about.
-TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display.
-
-On \"multi-monitor\" setups this refers to the pixel width for all
-physical monitors associated with TERMINAL. To get information for
-each physical monitor, use `display-monitor-attributes-list'. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object terminal)
{
struct ns_display_info *dpyinfo = check_ns_display_info (terminal);
- return make_number (x_display_pixel_width (dpyinfo));
+ return make_fixnum (x_display_pixel_width (dpyinfo));
}
DEFUN ("x-display-pixel-height", Fx_display_pixel_height,
Sx_display_pixel_height, 0, 1, 0,
- doc: /* Return the height in pixels of the Nextstep display TERMINAL.
-The optional argument TERMINAL specifies which display to ask about.
-TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display.
-
-On \"multi-monitor\" setups this refers to the pixel height for all
-physical monitors associated with TERMINAL. To get information for
-each physical monitor, use `display-monitor-attributes-list'. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object terminal)
{
struct ns_display_info *dpyinfo = check_ns_display_info (terminal);
- return make_number (x_display_pixel_height (dpyinfo));
+ return make_fixnum (x_display_pixel_height (dpyinfo));
}
#ifdef NS_IMPL_COCOA
@@ -2538,7 +2425,7 @@ ns_screen_name (CGDirectDisplayID did)
/* CGDisplayIOServicePort is deprecated. Do it another (harder) way.
Is this code OK for macOS < 10.9, and GNUstep? I suspect it is,
- in which case is it worth keeping the other method in here? */
+ in which case is it worth keeping the other method in here? */
if (IOMasterPort (MACH_PORT_NULL, &masterPort) != kIOReturnSuccess
|| IOServiceGetMatchingServices (masterPort,
@@ -2588,7 +2475,7 @@ ns_make_monitor_attribute_list (struct MonitorInfo *monitors,
int primary_monitor,
const char *source)
{
- Lisp_Object monitor_frames = Fmake_vector (make_number (n_monitors), Qnil);
+ Lisp_Object monitor_frames = make_nil_vector (n_monitors);
Lisp_Object frame, rest;
NSArray *screens = [NSScreen screens];
int i;
@@ -2725,35 +2612,25 @@ Internal use only, use `display-monitor-attributes-list' instead. */)
DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes,
0, 1, 0,
- doc: /* Return the number of bitplanes of the Nextstep display TERMINAL.
-The optional argument TERMINAL specifies which display to ask about.
-TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object terminal)
{
check_ns_display_info (terminal);
- return make_number
+ return make_fixnum
(NSBitsPerPixelFromDepth ([[[NSScreen screens] objectAtIndex:0] depth]));
}
DEFUN ("x-display-color-cells", Fx_display_color_cells, Sx_display_color_cells,
0, 1, 0,
- doc: /* Returns the number of color cells of the Nextstep display TERMINAL.
-The optional argument TERMINAL specifies which display to ask about.
-TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object terminal)
{
struct ns_display_info *dpyinfo = check_ns_display_info (terminal);
/* We force 24+ bit depths to 24-bit to prevent an overflow. */
- return make_number (1 << min (dpyinfo->n_planes, 24));
+ return make_fixnum (1 << min (dpyinfo->n_planes, 24));
}
-
-/* Unused dummy def needed for compatibility. */
-Lisp_Object tip_frame;
-
/* TODO: move to xdisp or similar */
static void
compute_tip_xy (struct frame *f,
@@ -2775,19 +2652,19 @@ compute_tip_xy (struct frame *f,
right = Fcdr (Fassq (Qright, parms));
bottom = Fcdr (Fassq (Qbottom, parms));
- if ((!INTEGERP (left) && !INTEGERP (right))
- || (!INTEGERP (top) && !INTEGERP (bottom)))
+ if ((!FIXNUMP (left) && !FIXNUMP (right))
+ || (!FIXNUMP (top) && !FIXNUMP (bottom)))
pt = [NSEvent mouseLocation];
else
{
/* Absolute coordinates. */
- pt.x = INTEGERP (left) ? XINT (left) : XINT (right);
+ pt.x = FIXNUMP (left) ? XFIXNUM (left) : XFIXNUM (right);
pt.y = (x_display_pixel_height (FRAME_DISPLAY_INFO (f))
- - (INTEGERP (top) ? XINT (top) : XINT (bottom))
+ - (FIXNUMP (top) ? XFIXNUM (top) : XFIXNUM (bottom))
- height);
}
- /* Find the screen that pt is on. */
+ /* Find the screen that pt is on. */
for (screen in [NSScreen screens])
if (pt.x >= screen.frame.origin.x
&& pt.x < screen.frame.origin.x + screen.frame.size.width
@@ -2800,33 +2677,33 @@ compute_tip_xy (struct frame *f,
if (CGRectContainsPoint ([screen frame], pt))
which would be neater, but it causes problems building on old
- versions of macOS and in GNUstep. */
+ versions of macOS and in GNUstep. */
/* Ensure in bounds. (Note, screen origin = lower left.) */
- if (INTEGERP (left) || INTEGERP (right))
+ if (FIXNUMP (left) || FIXNUMP (right))
*root_x = pt.x;
- else if (pt.x + XINT (dx) <= screen.frame.origin.x)
- *root_x = screen.frame.origin.x; /* Can happen for negative dx */
- else if (pt.x + XINT (dx) + width
+ else if (pt.x + XFIXNUM (dx) <= screen.frame.origin.x)
+ *root_x = screen.frame.origin.x;
+ else if (pt.x + XFIXNUM (dx) + width
<= screen.frame.origin.x + screen.frame.size.width)
/* It fits to the right of the pointer. */
- *root_x = pt.x + XINT (dx);
- else if (width + XINT (dx) <= pt.x)
+ *root_x = pt.x + XFIXNUM (dx);
+ else if (width + XFIXNUM (dx) <= pt.x)
/* It fits to the left of the pointer. */
- *root_x = pt.x - width - XINT (dx);
+ *root_x = pt.x - width - XFIXNUM (dx);
else
/* Put it left justified on the screen -- it ought to fit that way. */
*root_x = screen.frame.origin.x;
- if (INTEGERP (top) || INTEGERP (bottom))
+ if (FIXNUMP (top) || FIXNUMP (bottom))
*root_y = pt.y;
- else if (pt.y - XINT (dy) - height >= screen.frame.origin.y)
+ else if (pt.y - XFIXNUM (dy) - height >= screen.frame.origin.y)
/* It fits below the pointer. */
- *root_y = pt.y - height - XINT (dy);
- else if (pt.y + XINT (dy) + height
+ *root_y = pt.y - height - XFIXNUM (dy);
+ else if (pt.y + XFIXNUM (dy) + height
<= screen.frame.origin.y + screen.frame.size.height)
- /* It fits above the pointer */
- *root_y = pt.y + XINT (dy);
+ /* It fits above the pointer. */
+ *root_y = pt.y + XFIXNUM (dy);
else
/* Put it on the top. */
*root_y = screen.frame.origin.y + screen.frame.size.height - height;
@@ -2834,35 +2711,7 @@ compute_tip_xy (struct frame *f,
DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0,
- doc: /* Show STRING in a \"tooltip\" window on frame FRAME.
-A tooltip window is a small window displaying a string.
-
-This is an internal function; Lisp code should call `tooltip-show'.
-
-FRAME nil or omitted means use the selected frame.
-
-PARMS is an optional list of frame parameters which can be used to
-change the tooltip's appearance.
-
-Automatically hide the tooltip after TIMEOUT seconds. TIMEOUT nil
-means use the default timeout of 5 seconds.
-
-If the list of frame parameters PARMS contains a `left' parameter,
-display the tooltip at that x-position. If the list of frame parameters
-PARMS contains no `left' but a `right' parameter, display the tooltip
-right-adjusted at that x-position. Otherwise display it at the
-x-position of the mouse, with offset DX added (default is 5 if DX isn't
-specified).
-
-Likewise for the y-position: If a `top' frame parameter is specified, it
-determines the position of the upper edge of the tooltip window. If a
-`bottom' parameter but no `top' frame parameter is specified, it
-determines the position of the lower edge of the tooltip window.
-Otherwise display the tooltip window at the y-position of the mouse,
-with offset DY added (default is -10).
-
-A tooltip's maximum size is specified by `x-max-tooltip-size'.
-Text larger than the specified size is clipped. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object string, Lisp_Object frame, Lisp_Object parms, Lisp_Object timeout, Lisp_Object dx, Lisp_Object dy)
{
int root_x, root_y;
@@ -2870,6 +2719,8 @@ Text larger than the specified size is clipped. */)
struct frame *f;
char *str;
NSSize size;
+ NSColor *color;
+ Lisp_Object t;
specbind (Qinhibit_redisplay, Qt);
@@ -2877,19 +2728,19 @@ Text larger than the specified size is clipped. */)
str = SSDATA (string);
f = decode_window_system_frame (frame);
if (NILP (timeout))
- timeout = make_number (5);
+ timeout = make_fixnum (5);
else
- CHECK_NATNUM (timeout);
+ CHECK_FIXNAT (timeout);
if (NILP (dx))
- dx = make_number (5);
+ dx = make_fixnum (5);
else
- CHECK_NUMBER (dx);
+ CHECK_FIXNUM (dx);
if (NILP (dy))
- dy = make_number (-10);
+ dy = make_fixnum (-10);
else
- CHECK_NUMBER (dy);
+ CHECK_FIXNUM (dy);
block_input ();
if (ns_tooltip == nil)
@@ -2897,6 +2748,14 @@ Text larger than the specified size is clipped. */)
else
Fx_hide_tip ();
+ t = x_get_arg (NULL, parms, Qbackground_color, NULL, NULL, RES_TYPE_STRING);
+ if (ns_lisp_to_color (t, &color) == 0)
+ [ns_tooltip setBackgroundColor: color];
+
+ t = x_get_arg (NULL, parms, Qforeground_color, NULL, NULL, RES_TYPE_STRING);
+ if (ns_lisp_to_color (t, &color) == 0)
+ [ns_tooltip setForegroundColor: color];
+
[ns_tooltip setText: str];
size = [ns_tooltip frame].size;
@@ -2905,7 +2764,7 @@ Text larger than the specified size is clipped. */)
compute_tip_xy (f, parms, dx, dy, (int)size.width, (int)size.height,
&root_x, &root_y);
- [ns_tooltip showAtX: root_x Y: root_y for: XINT (timeout)];
+ [ns_tooltip showAtX: root_x Y: root_y for: XFIXNUM (timeout)];
unblock_input ();
return unbind_to (count, Qnil);
@@ -2913,8 +2772,7 @@ Text larger than the specified size is clipped. */)
DEFUN ("x-hide-tip", Fx_hide_tip, Sx_hide_tip, 0, 0, 0,
- doc: /* Hide the current tooltip window, if there is any.
-Value is t if tooltip was open, nil otherwise. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(void)
{
if (ns_tooltip == nil || ![ns_tooltip isActive])
@@ -2953,44 +2811,41 @@ frame_geometry (Lisp_Object frame, Lisp_Object attribute)
/* Construct list. */
if (EQ (attribute, Qouter_edges))
- return list4 (make_number (f->left_pos), make_number (f->top_pos),
- make_number (f->left_pos + outer_width),
- make_number (f->top_pos + outer_height));
+ return list4i (f->left_pos, f->top_pos,
+ f->left_pos + outer_width,
+ f->top_pos + outer_height);
else if (EQ (attribute, Qnative_edges))
- return list4 (make_number (native_left), make_number (native_top),
- make_number (native_right), make_number (native_bottom));
+ return list4i (native_left, native_top,
+ native_right, native_bottom);
else if (EQ (attribute, Qinner_edges))
- return list4 (make_number (native_left + internal_border_width),
- make_number (native_top
- + tool_bar_height
- + internal_border_width),
- make_number (native_right - internal_border_width),
- make_number (native_bottom - internal_border_width));
+ return list4i (native_left + internal_border_width,
+ native_top + tool_bar_height + internal_border_width,
+ native_right - internal_border_width,
+ native_bottom - internal_border_width);
else
return
- listn (CONSTYPE_HEAP, 10,
- Fcons (Qouter_position,
- Fcons (make_number (f->left_pos),
- make_number (f->top_pos))),
+ list (Fcons (Qouter_position,
+ Fcons (make_fixnum (f->left_pos),
+ make_fixnum (f->top_pos))),
Fcons (Qouter_size,
- Fcons (make_number (outer_width),
- make_number (outer_height))),
+ Fcons (make_fixnum (outer_width),
+ make_fixnum (outer_height))),
Fcons (Qexternal_border_size,
(fullscreen
- ? Fcons (make_number (0), make_number (0))
- : Fcons (make_number (border), make_number (border)))),
+ ? Fcons (make_fixnum (0), make_fixnum (0))
+ : Fcons (make_fixnum (border), make_fixnum (border)))),
Fcons (Qtitle_bar_size,
- Fcons (make_number (0), make_number (title_height))),
+ Fcons (make_fixnum (0), make_fixnum (title_height))),
Fcons (Qmenu_bar_external, Qnil),
- Fcons (Qmenu_bar_size, Fcons (make_number (0), make_number (0))),
+ Fcons (Qmenu_bar_size, Fcons (make_fixnum (0), make_fixnum (0))),
Fcons (Qtool_bar_external,
FRAME_EXTERNAL_TOOL_BAR (f) ? Qt : Qnil),
Fcons (Qtool_bar_position, FRAME_TOOL_BAR_POSITION (f)),
Fcons (Qtool_bar_size,
- Fcons (make_number (tool_bar_width),
- make_number (tool_bar_height))),
+ Fcons (make_fixnum (tool_bar_width),
+ make_fixnum (tool_bar_height))),
Fcons (Qinternal_border_width,
- make_number (internal_border_width)));
+ make_fixnum (internal_border_width)));
}
DEFUN ("ns-frame-geometry", Fns_frame_geometry, Sns_frame_geometry, 0, 1, 0,
@@ -3071,7 +2926,7 @@ The coordinates X and Y are interpreted in pixels relative to a position
{
#ifdef NS_IMPL_COCOA
/* GNUstep doesn't support CGWarpMouseCursorPosition, so none of
- this will work. */
+ this will work. */
struct frame *f = SELECTED_FRAME ();
EmacsView *view = FRAME_NS_VIEW (f);
NSScreen *screen = [[view window] screen];
@@ -3088,13 +2943,13 @@ The coordinates X and Y are interpreted in pixels relative to a position
CHECK_TYPE_RANGED_INTEGER (int, x);
CHECK_TYPE_RANGED_INTEGER (int, y);
- mouse_x = screen_frame.origin.x + XINT (x);
+ mouse_x = screen_frame.origin.x + XFIXNUM (x);
if (screen == primary_screen)
- mouse_y = screen_frame.origin.y + XINT (y);
+ mouse_y = screen_frame.origin.y + XFIXNUM (y);
else
mouse_y = (primary_screen_height - screen_frame.size.height
- - screen_frame.origin.y) + XINT (y);
+ - screen_frame.origin.y) + XFIXNUM (y);
CGPoint mouse_pos = CGPointMake(mouse_x, mouse_y);
CGWarpMouseCursorPosition (mouse_pos);
@@ -3109,7 +2964,7 @@ DEFUN ("ns-mouse-absolute-pixel-position",
doc: /* Return absolute position of mouse cursor in pixels.
The position is returned as a cons cell (X . Y) of the
coordinates of the mouse cursor position in pixels relative to a
-position (0, 0) of the selected frame's terminal. */)
+position (0, 0) of the selected frame's terminal. */)
(void)
{
struct frame *f = SELECTED_FRAME ();
@@ -3117,11 +2972,24 @@ position (0, 0) of the selected frame's terminal. */)
NSScreen *screen = [[view window] screen];
NSPoint pt = [NSEvent mouseLocation];
- return Fcons(make_number(pt.x - screen.frame.origin.x),
- make_number(screen.frame.size.height -
+ return Fcons(make_fixnum(pt.x - screen.frame.origin.x),
+ make_fixnum(screen.frame.size.height -
(pt.y - screen.frame.origin.y)));
}
+DEFUN ("ns-show-character-palette",
+ Fns_show_character_palette,
+ Sns_show_character_palette, 0, 0, 0,
+ doc: /* Show the macOS character palette. */)
+ (void)
+{
+ struct frame *f = SELECTED_FRAME ();
+ EmacsView *view = FRAME_NS_VIEW (f);
+ [NSApp orderFrontCharacterPalette:view];
+
+ return Qnil;
+}
+
/* ==========================================================================
Class implementations
@@ -3156,8 +3024,7 @@ handlePanelKeys (NSSavePanel *panel, NSEvent *theEvent)
case NSPageDownFunctionKey:
case NSEndFunctionKey:
/* Don't send command modified keys, as those are handled in the
- performKeyEquivalent method of the super class.
- */
+ performKeyEquivalent method of the super class. */
if (! ([theEvent modifierFlags] & NSEventModifierFlagCommand))
{
[panel sendEvent: theEvent];
@@ -3169,8 +3036,7 @@ handlePanelKeys (NSSavePanel *panel, NSEvent *theEvent)
them here. TODO: handle Emacs key bindings for copy/cut/select-all
here, paste works, because we have that in our Edit menu.
I.e. refactor out code in nsterm.m, keyDown: to figure out the
- correct modifier.
- */
+ correct modifier. */
case 'x': // Cut
case 'c': // Copy
case 'v': // Paste
@@ -3255,7 +3121,6 @@ handlePanelKeys (NSSavePanel *panel, NSEvent *theEvent)
========================================================================== */
-
void
syms_of_nsfns (void)
{
@@ -3289,6 +3154,11 @@ be used as the image of the icon representing the frame. */);
doc: /* Toolkit version for NS Windowing. */);
Vns_version_string = ns_appkit_version_str ();
+ DEFVAR_BOOL ("ns-use-proxy-icon", ns_use_proxy_icon,
+ doc: /* When non-nil display a proxy icon in the titlebar.
+Default is t. */);
+ ns_use_proxy_icon = true;
+
defsubr (&Sns_read_file_name);
defsubr (&Sns_get_resource);
defsubr (&Sns_set_resource);
@@ -3313,6 +3183,7 @@ be used as the image of the icon representing the frame. */);
defsubr (&Sns_frame_restack);
defsubr (&Sns_set_mouse_absolute_pixel_position);
defsubr (&Sns_mouse_absolute_pixel_position);
+ defsubr (&Sns_show_character_palette);
defsubr (&Sx_display_mm_width);
defsubr (&Sx_display_mm_height);
defsubr (&Sx_display_screens);
@@ -3339,5 +3210,6 @@ be used as the image of the icon representing the frame. */);
as_status = 0;
as_script = Qnil;
+ staticpro (&as_script);
as_result = 0;
}
diff --git a/src/nsfont.m b/src/nsfont.m
index 555ad0684e4..9721e489357 100644
--- a/src/nsfont.m
+++ b/src/nsfont.m
@@ -21,7 +21,7 @@ Author: Adrian Robert (arobert@cogsci.ucsd.edu)
*/
/* This should be the first include, as it may set up #defines affecting
- interpretation of even the system includes. */
+ interpretation of even the system includes. */
#include <config.h>
#include "lisp.h"
@@ -36,8 +36,9 @@ Author: Adrian Robert (arobert@cogsci.ucsd.edu)
#include "character.h"
#include "font.h"
#include "termchar.h"
+#include "pdumper.h"
-/* TODO: Drop once we can assume gnustep-gui 0.17.1. */
+/* TODO: Drop once we can assume gnustep-gui 0.17.1. */
#ifdef NS_IMPL_GNUSTEP
#import <AppKit/NSFontDescriptor.h>
#endif
@@ -45,7 +46,7 @@ Author: Adrian Robert (arobert@cogsci.ucsd.edu)
#define NSFONT_TRACE 0
#define LCD_SMOOTHING_MARGIN 2
-/* font glyph and metrics caching functions, implemented at end */
+/* Font glyph and metrics caching functions, implemented at end. */
static void ns_uni_to_glyphs (struct nsfont_info *font_info,
unsigned char block);
static void ns_glyph_metrics (struct nsfont_info *font_info,
@@ -61,7 +62,7 @@ static void ns_glyph_metrics (struct nsfont_info *font_info,
/* Replace spaces w/another character so emacs core font parsing routines
- aren't thrown off. */
+ aren't thrown off. */
static void
ns_escape_name (char *name)
{
@@ -71,7 +72,7 @@ ns_escape_name (char *name)
}
-/* Reconstruct spaces in a font family name passed through emacs. */
+/* Reconstruct spaces in a font family name passed through emacs. */
static void
ns_unescape_name (char *name)
{
@@ -81,7 +82,7 @@ ns_unescape_name (char *name)
}
-/* Extract family name from a font spec. */
+/* Extract family name from a font spec. */
static NSString *
ns_get_family (Lisp_Object font_spec)
{
@@ -103,7 +104,7 @@ ns_get_family (Lisp_Object font_spec)
/* Return 0 if attr not set, else value (which might also be 0).
On Leopard 0 gets returned even on descriptors where the attribute
was never set, so there's no way to distinguish between unspecified
- and set to not have. Callers should assume 0 means unspecified. */
+ and set to not have. Callers should assume 0 means unspecified. */
static float
ns_attribute_fvalue (NSFontDescriptor *fdesc, NSString *trait)
{
@@ -114,7 +115,7 @@ ns_attribute_fvalue (NSFontDescriptor *fdesc, NSString *trait)
/* Converts FONT_WEIGHT, FONT_SLANT, FONT_WIDTH, plus family and script/lang
- to NSFont descriptor. Information under extra only needed for matching. */
+ to NSFont descriptor. Information under extra only needed for matching. */
#define STYLE_REF 100
static NSFontDescriptor *
ns_spec_to_descriptor (Lisp_Object font_spec)
@@ -125,7 +126,7 @@ ns_spec_to_descriptor (Lisp_Object font_spec)
NSString *family = ns_get_family (font_spec);
float n;
- /* add each attr in font_spec to fdAttrs.. */
+ /* Add each attr in font_spec to fdAttrs. */
n = min (FONT_WEIGHT_NUMERIC (font_spec), 200);
if (n != -1 && n != STYLE_REF)
[tdict setObject: [NSNumber numberWithFloat: (n - 100.0F) / 100.0F]
@@ -156,7 +157,7 @@ ns_spec_to_descriptor (Lisp_Object font_spec)
}
-/* Converts NSFont descriptor to FONT_WEIGHT, FONT_SLANT, FONT_WIDTH, etc.. */
+/* Converts NSFont descriptor to FONT_WEIGHT, FONT_SLANT, FONT_WIDTH, etc. */
static Lisp_Object
ns_descriptor_to_entity (NSFontDescriptor *desc,
Lisp_Object extra,
@@ -168,7 +169,7 @@ ns_descriptor_to_entity (NSFontDescriptor *desc,
unsigned int traits = [desc symbolicTraits];
char *escapedFamily;
- /* Shouldn't happen, but on Tiger fallback desc gets name but no family. */
+ /* Shouldn't happen, but on Tiger fallback desc gets name but no family. */
if (family == nil)
family = [desc objectForKey: NSFontNameAttribute];
if (family == nil)
@@ -186,24 +187,24 @@ ns_descriptor_to_entity (NSFontDescriptor *desc,
FONT_SET_STYLE (font_entity, FONT_WEIGHT_INDEX,
traits & NSFontBoldTrait ? Qbold : Qmedium);
/* FONT_SET_STYLE (font_entity, FONT_WEIGHT_INDEX,
- make_number (100 + 100
+ make_fixnum (100 + 100
* ns_attribute_fvalue (desc, NSFontWeightTrait)));*/
FONT_SET_STYLE (font_entity, FONT_SLANT_INDEX,
traits & NSFontItalicTrait ? Qitalic : Qnormal);
/* FONT_SET_STYLE (font_entity, FONT_SLANT_INDEX,
- make_number (100 + 100
+ make_fixnum (100 + 100
* ns_attribute_fvalue (desc, NSFontSlantTrait)));*/
FONT_SET_STYLE (font_entity, FONT_WIDTH_INDEX,
traits & NSFontCondensedTrait ? Qcondensed :
traits & NSFontExpandedTrait ? Qexpanded : Qnormal);
/* FONT_SET_STYLE (font_entity, FONT_WIDTH_INDEX,
- make_number (100 + 100
+ make_fixnum (100 + 100
* ns_attribute_fvalue (desc, NSFontWidthTrait)));*/
- ASET (font_entity, FONT_SIZE_INDEX, make_number (0));
- ASET (font_entity, FONT_AVGWIDTH_INDEX, make_number (0));
+ ASET (font_entity, FONT_SIZE_INDEX, make_fixnum (0));
+ ASET (font_entity, FONT_AVGWIDTH_INDEX, make_fixnum (0));
ASET (font_entity, FONT_SPACING_INDEX,
- make_number([desc symbolicTraits] & NSFontMonoSpaceTrait
+ make_fixnum([desc symbolicTraits] & NSFontMonoSpaceTrait
? FONT_SPACING_MONO : FONT_SPACING_PROPORTIONAL));
ASET (font_entity, FONT_EXTRA_INDEX, extra);
@@ -220,7 +221,7 @@ ns_descriptor_to_entity (NSFontDescriptor *desc,
}
-/* Default font entity. */
+/* Default font entity. */
static Lisp_Object
ns_fallback_entity (void)
{
@@ -229,7 +230,7 @@ ns_fallback_entity (void)
}
-/* Utility: get width of a char c in screen font SFONT */
+/* Utility: get width of a char c in screen font SFONT. */
static CGFloat
ns_char_width (NSFont *sfont, int c)
{
@@ -292,7 +293,7 @@ ns_ascii_average_width (NSFont *sfont)
/* Return whether set1 covers set2 to a reasonable extent given by pct.
We check, out of each 16 Unicode char range containing chars in set2,
whether at least one character is present in set1.
- This must be true for pct of the pairs to consider it covering. */
+ This must be true for pct of the pairs to consider it covering. */
static BOOL
ns_charset_covers(NSCharacterSet *set1, NSCharacterSet *set2, float pct)
{
@@ -312,20 +313,20 @@ ns_charset_covers(NSCharacterSet *set1, NSCharacterSet *set2, float pct)
if (*bytes1 == 0) // *bytes1 & *bytes2 != *bytes2
off++;
}
-//fprintf(stderr, "off = %d\ttot = %d\n", off,tot);
+ // fprintf(stderr, "off = %d\ttot = %d\n", off,tot);
return (float)off / tot < 1.0F - pct;
}
/* Convert :lang property to a script. Use of :lang property by font backend
- seems to be limited for now (2009/05) to ja, zh, and ko. */
+ seems to be limited for now (2009/05) to ja, zh, and ko. */
static NSString
*ns_lang_to_script (Lisp_Object lang)
{
if (!strcmp (SSDATA (SYMBOL_NAME (lang)), "ja"))
return @"han";
/* NOTE: ja given for any hanzi that's also a kanji, but Chinese fonts
- have more characters. */
+ have more characters. */
else if (!strcmp (SSDATA (SYMBOL_NAME (lang)), "zh"))
return @"han";
else if (!strcmp (SSDATA (SYMBOL_NAME (lang)), "ko"))
@@ -336,7 +337,7 @@ static NSString
/* Convert OTF 4-letter script code to emacs script name. (Why can't
- everyone just use some standard Unicode names for these?) */
+ everyone just use some standard Unicode names for these?) */
static NSString
*ns_otf_to_script (Lisp_Object otf)
{
@@ -347,7 +348,7 @@ static NSString
}
-/* Convert a font registry, such as */
+/* Convert a font registry. */
static NSString
*ns_registry_to_script (char *reg)
{
@@ -368,14 +369,14 @@ static NSString
/* Searches the :script, :lang, and :otf extra-bundle properties of the spec,
plus registry regular property, for something that can be mapped to a
- Unicode script. Empty string returned if no script spec found. */
+ Unicode script. Empty string returned if no script spec found. */
static NSString
*ns_get_req_script (Lisp_Object font_spec)
{
Lisp_Object reg = AREF (font_spec, FONT_REGISTRY_INDEX);
Lisp_Object extra = AREF (font_spec, FONT_EXTRA_INDEX);
- /* The extra-bundle properties have priority. */
+ /* The extra-bundle properties have priority. */
for ( ; CONSP (extra); extra = XCDR (extra))
{
Lisp_Object tmp = XCAR (extra);
@@ -392,12 +393,12 @@ static NSString
}
}
- /* If we get here, check the charset portion of the registry. */
+ /* If we get here, check the charset portion of the registry. */
if (! NILP (reg))
{
/* XXX: iso10646 is passed in for non-ascii latin-1 characters
(which causes box rendering if we don't treat it like iso8858-1)
- but also for ascii (which causes unnecessary font substitution). */
+ but also for ascii (which causes unnecessary font substitution). */
#if 0
if (EQ (reg, Qiso10646_1))
reg = Qiso8859_1;
@@ -410,7 +411,7 @@ static NSString
/* This small function is static in fontset.c. If it can be made public for
- all ports, remove this, but otherwise it doesn't seem worth the ifdefs. */
+ all ports, remove this, but otherwise it doesn't seem worth the ifdefs. */
static void
accumulate_script_ranges (Lisp_Object arg, Lisp_Object range, Lisp_Object val)
{
@@ -425,7 +426,7 @@ accumulate_script_ranges (Lisp_Object arg, Lisp_Object range, Lisp_Object val)
/* Use the Unicode range information in Vchar_script_table to convert a script
- name into an NSCharacterSet. */
+ name into an NSCharacterSet. */
static NSCharacterSet
*ns_script_to_charset (NSString *scriptName)
{
@@ -445,8 +446,8 @@ static NSCharacterSet
{
for (; CONSP (range_list); range_list = XCDR (range_list))
{
- int start = XINT (XCAR (XCAR (range_list)));
- int end = XINT (XCDR (XCAR (range_list)));
+ int start = XFIXNUM (XCAR (XCAR (range_list)));
+ int end = XFIXNUM (XCDR (XCAR (range_list)));
if (NSFONT_TRACE)
debug_print (XCAR (range_list));
if (end < 0x10000)
@@ -465,7 +466,7 @@ static NSCharacterSet
If none are found, we reduce the percentage and try again, until 5%.
This provides a font with at least some characters if such can be found.
We don't use isSupersetOfSet: because (a) it doesn't work on Tiger, and
- (b) need approximate match as fonts covering full Unicode ranges are rare. */
+ (b) need approximate match as fonts covering full Unicode ranges are rare. */
static NSSet
*ns_get_covering_families (NSString *script, float pct)
{
@@ -497,7 +498,7 @@ static NSSet
{
NSCharacterSet *fset = [[fontMgr fontWithFamily: family
traits: 0 weight: 5 size: 12.0] coveredCharacterSet];
- /* Some fonts on macOS, maybe many on GNUstep, return nil. */
+ /* Some fonts on macOS, maybe many on GNUstep, return nil. */
if (fset == nil)
fset = [NSCharacterSet characterSetWithRange:
NSMakeRange (0, 127)];
@@ -525,7 +526,7 @@ static NSSet
/* Implementation for list() and match(). List() can return nil, match()
must return something. Strategy is to drop family name from attribute
-matching set for match. */
+matching set for match. */
static Lisp_Object
ns_findfonts (Lisp_Object font_spec, BOOL isMatch)
{
@@ -574,9 +575,9 @@ ns_findfonts (Lisp_Object font_spec, BOOL isMatch)
foundItal = YES;
}
- /* Add synthItal member if needed. */
+ /* Add synthItal member if needed. */
family = [fdesc objectForKey: NSFontFamilyAttribute];
- if (family != nil && !foundItal && XINT (Flength (list)) > 0)
+ if (family != nil && !foundItal && !NILP (list))
{
NSFontDescriptor *s1 = [NSFontDescriptor new];
NSFontDescriptor *sDesc
@@ -590,13 +591,13 @@ ns_findfonts (Lisp_Object font_spec, BOOL isMatch)
unblock_input ();
- /* Return something if was a match and nothing found. */
+ /* Return something if was a match and nothing found. */
if (isMatch)
return ns_fallback_entity ();
if (NSFONT_TRACE)
- fprintf (stderr, " Returning %"pI"d entities.\n",
- XINT (Flength (list)));
+ fprintf (stderr, " Returning %"pD"d entities.\n",
+ list_length (list));
return list;
}
@@ -642,7 +643,7 @@ nsfont_list (struct frame *f, Lisp_Object font_spec)
/* Return a font entity most closely matching with FONT_SPEC on
FRAME. The closeness is determined by the font backend, thus
`face-font-selection-order' is ignored here.
- Properties to be considered are same as for list(). */
+ Properties to be considered are same as for list(). */
static Lisp_Object
nsfont_match (struct frame *f, Lisp_Object font_spec)
{
@@ -651,7 +652,7 @@ nsfont_match (struct frame *f, Lisp_Object font_spec)
/* List available families. The value is a list of family names
- (symbols). */
+ (symbols). */
static Lisp_Object
nsfont_list_family (struct frame *f)
{
@@ -664,11 +665,11 @@ nsfont_list_family (struct frame *f)
objectEnumerator];
while ((family = [families nextObject]))
list = Fcons (intern ([family UTF8String]), list);
- /* FIXME: escape the name? */
+ /* FIXME: escape the name? */
if (NSFONT_TRACE)
- fprintf (stderr, "nsfont: list families returning %"pI"d entries\n",
- XINT (Flength (list)));
+ fprintf (stderr, "nsfont: list families returning %"pD"d entries\n",
+ list_length (list));
unblock_input ();
return list;
@@ -705,7 +706,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size)
{
/* try to get it out of frame params */
Lisp_Object tem = get_frame_param (f, Qfontsize);
- pixel_size = NILP (tem) ? 0 : XFASTINT (tem);
+ pixel_size = NILP (tem) ? 0 : XFIXNAT (tem);
}
tem = AREF (font_entity, FONT_ADSTYLE_INDEX);
@@ -715,7 +716,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size)
if (family == nil)
family = [[NSFont userFixedPitchFontOfSize: 0] familyName];
/* Should be > 0.23 as some font descriptors (e.g. Terminus) set to that
- when setting family in ns_spec_to_descriptor(). */
+ when setting family in ns_spec_to_descriptor(). */
if (ns_attribute_fvalue (fontDesc, NSFontWeightTrait) > 0.50F)
traits |= NSBoldFontMask;
if (fabs (ns_attribute_fvalue (fontDesc, NSFontSlantTrait) > 0.05F))
@@ -757,7 +758,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size)
if (!font)
{
unblock_input ();
- return Qnil; /* FIXME: other terms do, but return Qnil causes segfault */
+ return Qnil; /* FIXME: other terms do, but returning Qnil causes segfault. */
}
font_info->glyphs = xzalloc (0x100 * sizeof *font_info->glyphs);
@@ -793,7 +794,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size)
* -2.00000405... (represented by 0xc000000220000000). Without
* adjustment, the code below would round the descender to -3,
* resulting in a font that would be one pixel higher than
- * intended. */
+ * intended. */
CGFloat adjusted_descender = [sfont descender] + 0.0001;
#ifdef NS_IMPL_GNUSTEP
@@ -810,7 +811,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size)
synthItal || ([fontMgr traitsOfFont: nsfont] & NSItalicFontMask);
/* Metrics etc.; some fonts return an unusually large max advance, so we
- only use it for fonts that have wide characters. */
+ only use it for fonts that have wide characters. */
font_info->width = ([sfont numberOfGlyphs] > 2000) ?
[sfont maximumAdvancement].width : ns_char_width (sfont, '0');
@@ -823,7 +824,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size)
/* max bounds */
font->ascent = font_info->max_bounds.ascent = lrint ([sfont ascender]);
/* Descender is usually negative. Use floor to avoid
- clipping descenders. */
+ clipping descenders. */
font->descent =
font_info->max_bounds.descent = -lrint (floor(adjusted_descender));
font_info->height =
@@ -880,7 +881,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size)
}
-/* Close FONT. */
+/* Close FONT. */
static void
nsfont_close (struct font *font)
{
@@ -911,7 +912,7 @@ nsfont_close (struct font *font)
/* If FONT_ENTITY has a glyph for character C (Unicode code point),
return 1. If not, return 0. If a font must be opened to check
- it, return -1. */
+ it, return -1. */
static int
nsfont_has_char (Lisp_Object entity, int c)
{
@@ -920,7 +921,7 @@ nsfont_has_char (Lisp_Object entity, int c)
/* Return a glyph code of FONT for character C (Unicode code point).
- If FONT doesn't have such a glyph, return FONT_INVALID_CODE. */
+ If FONT doesn't have such a glyph, return FONT_INVALID_CODE. */
static unsigned int
nsfont_encode_char (struct font *font, int c)
{
@@ -931,7 +932,7 @@ nsfont_encode_char (struct font *font, int c)
if (c > 0xFFFF)
return FONT_INVALID_CODE;
- /* did we already cache this block? */
+ /* Did we already cache this block? */
if (!font_info->glyphs[high])
ns_uni_to_glyphs (font_info, high);
@@ -942,7 +943,7 @@ nsfont_encode_char (struct font *font, int c)
/* Perform the size computation of glyphs of FONT and fill in members
of METRICS. The glyphs are specified by their glyph codes in
- CODE (length NGLYPHS). */
+ CODE (length NGLYPHS). */
static void
nsfont_text_extents (struct font *font, unsigned int *code,
int nglyphs, struct font_metrics *metrics)
@@ -985,11 +986,11 @@ nsfont_text_extents (struct font *font, unsigned int *code,
/* Draw glyphs between FROM and TO of S->char2b at (X Y) pixel
position of frame F with S->FACE and S->GC. If WITH_BACKGROUND,
fill the background in advance. It is assured that WITH_BACKGROUND
- is false when (FROM > 0 || TO < S->nchars). */
+ is false when (FROM > 0 || TO < S->nchars). */
static int
nsfont_draw (struct glyph_string *s, int from, int to, int x, int y,
bool with_background)
-/* NOTE: focus and clip must be set */
+/* NOTE: focus and clip must be set. */
{
static unsigned char cbuf[1024];
unsigned char *c = cbuf;
@@ -1019,7 +1020,7 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y,
if (font == NULL)
font = (struct nsfont_info *)FRAME_FONT (s->f);
- /* Select face based on input flags */
+ /* Select face based on input flags. */
flags = s->hl == DRAW_CURSOR ? NS_DUMPGLYPH_CURSOR :
(s->hl == DRAW_MOUSE_FACE ? NS_DUMPGLYPH_MOUSEFACE :
(s->for_overlaps ? NS_DUMPGLYPH_FOREGROUND :
@@ -1049,11 +1050,11 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y,
/* Convert UTF-16 (?) to UTF-8 and determine advances. Note if we just ask
NS to render the string, it will come out differently from the individual
- character widths added up because of layout processing. */
+ character widths added up because of layout processing. */
{
int cwidth, twidth = 0;
int hi, lo;
- /* FIXME: composition: no vertical displacement is considered. */
+ /* FIXME: composition: no vertical displacement is considered. */
t += from; /* advance into composition */
for (i = from; i < to; i++, t++)
{
@@ -1082,14 +1083,14 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y,
}
else
{
- if (!font->metrics[hi]) /* FIXME: why/how can we need this now? */
+ if (!font->metrics[hi]) /* FIXME: why/how can we need this now? */
ns_glyph_metrics (font, hi);
cwidth = font->metrics[hi][lo].width;
}
twidth += cwidth;
#ifdef NS_IMPL_GNUSTEP
*adv++ = cwidth;
- CHAR_STRING_ADVANCE (*t, c); /* this converts the char to UTF-8 */
+ CHAR_STRING_ADVANCE (*t, c); /* This converts the char to UTF-8. */
#else
(*adv++).width = cwidth;
#endif
@@ -1099,7 +1100,7 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y,
*c = 0;
}
- /* fill background if requested */
+ /* Fill background if requested. */
if (with_background && !isComposite)
{
NSRect br = r;
@@ -1119,7 +1120,7 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y,
}
if (s->face->box == FACE_NO_BOX)
{
- /* expand unboxed top row over internal border */
+ /* Expand unboxed top row over internal border. */
if (br.origin.y <= fibw + 1 + mbox_line_width)
{
br.size.height += br.origin.y;
@@ -1258,7 +1259,7 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y,
========================================================================== */
/* Find and cache corresponding glyph codes for unicode values in given
- hi-byte block of 256. */
+ hi-byte block of 256. */
static void
ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block)
{
@@ -1288,7 +1289,7 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block)
if (!unichars || !(font_info->glyphs[block]))
emacs_abort ();
- /* create a string containing all Unicode characters in this block */
+ /* Create a string containing all Unicode characters in this block. */
for (idx = block<<8, i = 0; i < 0x100; idx++, i++)
if (idx < 0xD800 || idx > 0xDFFF)
unichars[i] = idx;
@@ -1303,7 +1304,7 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block)
length: 0x100
freeWhenDone: NO];
NSGlyphGenerator *glyphGenerator = [NSGlyphGenerator sharedGlyphGenerator];
- /*NSCharacterSet *coveredChars = [nsfont coveredCharacterSet]; */
+ /* NSCharacterSet *coveredChars = [nsfont coveredCharacterSet]; */
unsigned int numGlyphs = [font_info->nsfont numberOfGlyphs];
NSUInteger gInd = 0, cInd = 0;
@@ -1319,9 +1320,9 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block)
g = unichars[i];
#else
g = glyphStorage->cglyphs[i];
- /* TODO: is this a good check? maybe need to use coveredChars.. */
+ /* TODO: is this a good check? Maybe need to use coveredChars. */
if (g > numGlyphs || g == NSNullGlyph)
- g = INVALID_GLYPH; /* hopefully unused... */
+ g = INVALID_GLYPH; /* Hopefully unused... */
#endif
*glyphs = g;
}
@@ -1337,7 +1338,7 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block)
/* Determine and cache metrics for corresponding glyph codes in given
- hi-byte block of 256. */
+ hi-byte block of 256. */
static void
ns_glyph_metrics (struct nsfont_info *font_info, unsigned char block)
{
@@ -1387,16 +1388,16 @@ ns_glyph_metrics (struct nsfont_info *font_info, unsigned char block)
metrics->rbearing = lrint (w + rb + LCD_SMOOTHING_MARGIN);
metrics->descent = r.origin.y < 0 ? -r.origin.y : 0;
- /*lrint (hshrink * [sfont ascender] + expand * hd/2); */
+ /* lrint (hshrink * [sfont ascender] + expand * hd/2); */
metrics->ascent = r.size.height - metrics->descent;
-/*-lrint (hshrink* [sfont descender] - expand * hd/2); */
+ /* -lrint (hshrink* [sfont descender] - expand * hd/2); */
}
unblock_input ();
}
#ifdef NS_IMPL_COCOA
-/* helper for font glyph setup */
+/* Helper for font glyph setup. */
@implementation EmacsGlyphStorage
- init
@@ -1483,6 +1484,8 @@ ns_dump_glyphstring (struct glyph_string *s)
fprintf (stderr, "\n");
}
+static void syms_of_nsfont_for_pdumper (void);
+
struct font_driver const nsfont_driver =
{
.type = LISPSYM_INITIALLY (Qns),
@@ -1502,13 +1505,17 @@ struct font_driver const nsfont_driver =
void
syms_of_nsfont (void)
{
- register_font_driver (&nsfont_driver, NULL);
DEFSYM (Qcondensed, "condensed");
DEFSYM (Qexpanded, "expanded");
DEFSYM (Qapple, "apple");
DEFSYM (Qmedium, "medium");
DEFVAR_LISP ("ns-reg-to-script", Vns_reg_to_script,
- doc: /* Internal use: maps font registry to Unicode script. */);
+ doc: /* Internal use: maps font registry to Unicode script. */);
+ pdumper_do_now_and_after_load (syms_of_nsfont_for_pdumper);
+}
- ascii_printable = NULL;
+static void
+syms_of_nsfont_for_pdumper (void)
+{
+ register_font_driver (&nsfont_driver, NULL);
}
diff --git a/src/nsgui.h b/src/nsgui.h
index 271fbc1e032..c857d77d9cd 100644
--- a/src/nsgui.h
+++ b/src/nsgui.h
@@ -19,7 +19,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifndef __NSGUI_H__
#define __NSGUI_H__
-/* this gets included from a couple of the plain (non-NS) .c files */
+/* This gets included from a couple of the plain (non-NS) .c files. */
#ifdef __OBJC__
#ifdef NS_IMPL_COCOA
@@ -73,9 +73,11 @@ typedef unichar XChar2b;
#define XCHAR2B_BYTE2(chp) \
(*(chp) & 0x00ff)
+/* Used in xdisp.c when comparing faces and frame colors. */
+extern unsigned long ns_color_index_to_rgba(int idx, struct frame *f);
/* XXX: xfaces requires these structures, but the question is are we
- forced to use them? */
+ forced to use them? */
typedef struct _XGCValues
{
unsigned long foreground;
@@ -119,8 +121,8 @@ typedef int Display;
typedef Lisp_Object XrmDatabase;
-/* some sort of attempt to normalize rectangle handling.. seems a bit much
- for what is accomplished */
+/* Some sort of attempt to normalize rectangle handling. Seems a bit
+ much for what is accomplished. */
typedef struct {
int x, y;
unsigned width, height;
@@ -160,7 +162,7 @@ typedef struct _NSRect { NSPoint origin; NSSize size; } NSRect;
-/* This stuff needed by frame.c. */
+/* This stuff needed by frame.c. */
#define ForgetGravity 0
#define NorthWestGravity 1
#define NorthGravity 2
diff --git a/src/nsimage.m b/src/nsimage.m
index f3eba5e37b2..f16910de088 100644
--- a/src/nsimage.m
+++ b/src/nsimage.m
@@ -26,7 +26,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu)
*/
/* This should be the first include, as it may set up #defines affecting
- interpretation of even the system includes. */
+ interpretation of even the system includes. */
#include <config.h>
#include "lisp.h"
@@ -41,7 +41,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu)
C interface. This allows easy calling from C files. We could just
compile everything as Objective-C, but that might mean slower
- compilation and possible difficulties on some platforms..
+ compilation and possible difficulties on some platforms.
========================================================================== */
@@ -76,15 +76,19 @@ ns_load_image (struct frame *f, struct image *img,
{
EmacsImage *eImg = nil;
NSSize size;
- Lisp_Object lisp_index;
+ Lisp_Object lisp_index, lisp_rotation;
unsigned int index;
+ double rotation;
NSTRACE ("ns_load_image");
eassert (valid_image_p (img->spec));
lisp_index = Fplist_get (XCDR (img->spec), QCindex);
- index = INTEGERP (lisp_index) ? XFASTINT (lisp_index) : 0;
+ index = FIXNUMP (lisp_index) ? XFIXNAT (lisp_index) : 0;
+
+ lisp_rotation = Fplist_get (XCDR (img->spec), QCrotation);
+ rotation = NUMBERP (lisp_rotation) ? XFLOATINT (lisp_rotation) : 0;
if (STRINGP (spec_file))
{
@@ -109,10 +113,19 @@ ns_load_image (struct frame *f, struct image *img,
if (![eImg setFrame: index])
{
add_to_log ("Unable to set index %d for image %s",
- make_number (index), img->spec);
+ make_fixnum (index), img->spec);
return 0;
}
+ img->lisp_data = [eImg getMetadata];
+
+ if (rotation != 0)
+ {
+ EmacsImage *temp = [eImg rotate:rotation];
+ [eImg release];
+ eImg = temp;
+ }
+
size = [eImg size];
img->width = size.width;
img->height = size.height;
@@ -120,7 +133,6 @@ ns_load_image (struct frame *f, struct image *img,
/* 4) set img->pixmap = emacsimage */
img->pixmap = eImg;
- img->lisp_data = [eImg getMetadata];
return 1;
}
@@ -137,6 +149,12 @@ ns_image_height (void *img)
return [(id)img size].height;
}
+void
+ns_image_set_size (void *img, int width, int height)
+{
+ [(EmacsImage *)img setSize:NSMakeSize (width, height)];
+}
+
unsigned long
ns_get_pixel (void *img, int x, int y)
{
@@ -212,7 +230,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a)
/* Create image from monochrome bitmap. If both FG and BG are 0
- (black), set the background to white and make it transparent. */
+ (black), set the background to white and make it transparent. */
- (instancetype)initFromXBM: (unsigned char *)bits width: (int)w height: (int)h
fg: (unsigned long)fg bg: (unsigned long)bg
{
@@ -237,7 +255,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a)
}
{
- /* pull bits out to set the (bytewise) alpha mask */
+ /* Pull bits out to set the (bytewise) alpha mask. */
int i, j, k;
unsigned char *s = bits;
unsigned char *rr = planes[0];
@@ -348,7 +366,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a)
}
-/* attempt to pull out pixmap data from a BitmapImageRep; returns NO if fails */
+/* Attempt to pull out pixmap data from a BitmapImageRep; returns NO if fails. */
- (void) setPixmapData
{
NSEnumerator *reps;
@@ -372,15 +390,15 @@ ns_set_alpha (void *img, int x, int y, unsigned char a)
}
-/* note; this and next work only for image created with initForXPMWithDepth,
- initFromSkipXBM, or where setPixmapData was called successfully */
+/* Note: this and next work only for image created with initForXPMWithDepth,
+ initFromSkipXBM, or where setPixmapData was called successfully. */
/* return ARGB */
- (unsigned long) getPixelAtX: (int)x Y: (int)y
{
if (bmRep == nil)
return 0;
- /* this method is faster but won't work for bitmaps */
+ /* This method is faster but won't work for bitmaps. */
if (pixmapData[0] != NULL)
{
int loc = x + y * [self size].width;
@@ -443,7 +461,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a)
}
}
-/* returns a pattern color, which is cached here */
+/* Returns a pattern color, which is cached here. */
- (NSColor *)stippleMask
{
if (stippleMask == nil)
@@ -451,7 +469,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a)
return stippleMask;
}
-/* Find the first NSBitmapImageRep which has multiple frames. */
+/* Find the first NSBitmapImageRep which has multiple frames. */
- (NSBitmapImageRep *)getAnimatedBitmapImageRep
{
for (NSImageRep * r in [self representations])
@@ -467,7 +485,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a)
}
/* If the image has multiple frames, get a count of them and the
- animation delay, if available. */
+ animation delay, if available. */
- (Lisp_Object)getMetadata
{
Lisp_Object metadata = Qnil;
@@ -481,14 +499,14 @@ ns_set_alpha (void *img, int x, int y, unsigned char a)
floatValue];
if (frames > 1)
- metadata = Fcons (Qcount, Fcons (make_number (frames), metadata));
+ metadata = Fcons (Qcount, Fcons (make_fixnum (frames), metadata));
if (delay > 0)
metadata = Fcons (Qdelay, Fcons (make_float (delay), metadata));
}
return metadata;
}
-/* Attempt to set the animation frame to be displayed. */
+/* Attempt to set the animation frame to be displayed. */
- (BOOL)setFrame: (unsigned int) index
{
NSBitmapImageRep * bm = [self getAnimatedBitmapImageRep];
@@ -497,7 +515,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a)
{
int frames = [[bm valueForProperty:NSImageFrameCount] intValue];
- /* If index is invalid, give up. */
+ /* If index is invalid, give up. */
if (index < 0 || index > frames)
return NO;
@@ -506,8 +524,46 @@ ns_set_alpha (void *img, int x, int y, unsigned char a)
}
/* Setting the frame has succeeded, or the image doesn't have
- multiple frames. */
+ multiple frames. */
return YES;
}
+- (instancetype)rotate: (double)rotation
+{
+ EmacsImage *new_image;
+ NSPoint new_origin;
+ NSSize new_size, size = [self size];
+ NSRect rect = { NSZeroPoint, [self size] };
+
+ /* Create a bezier path of the outline of the image and do the
+ * rotation on it. */
+ NSBezierPath *bounds_path = [NSBezierPath bezierPathWithRect:rect];
+ NSAffineTransform *transform = [NSAffineTransform transform];
+ [transform rotateByDegrees: rotation * -1];
+ [bounds_path transformUsingAffineTransform:transform];
+
+ /* Now we can find out how large the rotated image needs to be. */
+ new_size = [bounds_path bounds].size;
+ new_image = [[EmacsImage alloc] initWithSize:new_size];
+
+ new_origin = NSMakePoint((new_size.width - size.width)/2,
+ (new_size.height - size.height)/2);
+
+ [new_image lockFocus];
+
+ /* Create the final transform. */
+ transform = [NSAffineTransform transform];
+ [transform translateXBy:new_size.width/2 yBy:new_size.height/2];
+ [transform rotateByDegrees: rotation * -1];
+ [transform translateXBy:-new_size.width/2 yBy:-new_size.height/2];
+
+ [transform concat];
+ [self drawAtPoint:new_origin fromRect:NSZeroRect
+ operation:NSCompositingOperationCopy fraction:1];
+
+ [new_image unlockFocus];
+
+ return new_image;
+}
+
@end
diff --git a/src/nsmenu.m b/src/nsmenu.m
index da63064516e..34ec980856a 100644
--- a/src/nsmenu.m
+++ b/src/nsmenu.m
@@ -22,7 +22,7 @@ Christian Limpach, Scott Bender, Christophe de Dinechin) and code in the
Carbon version by Yamamoto Mitsuharu. */
/* This should be the first include, as it may set up #defines affecting
- interpretation of even the system includes. */
+ interpretation of even the system includes. */
#include <config.h>
#include "lisp.h"
@@ -37,6 +37,7 @@ Carbon version by Yamamoto Mitsuharu. */
#include "termhooks.h"
#include "keyboard.h"
#include "menu.h"
+#include "pdumper.h"
#define NSMENUPROFILE 0
@@ -47,7 +48,7 @@ Carbon version by Yamamoto Mitsuharu. */
#if 0
-/* Include lisp -> C common menu parsing code */
+/* Include lisp -> C common menu parsing code. */
#define ENCODE_MENU_STRING(str) ENCODE_UTF_8 (str)
#include "nsmenu_common.c"
#endif
@@ -62,7 +63,7 @@ static int trackingMenu;
/* NOTE: toolbar implementation is at end,
- following complete menu implementation. */
+ following complete menu implementation. */
/* ==========================================================================
@@ -74,7 +75,7 @@ static int trackingMenu;
/* Supposed to discard menubar and free storage. Since we share the
menubar among frames and update its context for the focused window,
- there is nothing to do here. */
+ there is nothing to do here. */
void
free_frame_menubar (struct frame *f)
{
@@ -123,7 +124,7 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu)
block_input ();
pool = [[NSAutoreleasePool alloc] init];
- /* Menu may have been created automatically; if so, discard it. */
+ /* Menu may have been created automatically; if so, discard it. */
if ([menu isKindOfClass: [EmacsMenu class]] == NO)
{
[menu release];
@@ -147,7 +148,7 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu)
if (deep_p)
{
- /* Fully parse one or more of the submenus. */
+ /* Fully parse one or more of the submenus. */
int n = 0;
int *submenu_start, *submenu_end;
bool *submenu_top_level_items;
@@ -172,8 +173,8 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu)
set_buffer_internal_1 (XBUFFER (buffer));
/* TODO: for some reason this is not needed in other terms,
- but some menu updates call Info-extract-pointer which causes
- abort-on-error if waiting-for-input. Needs further investigation. */
+ but some menu updates call Info-extract-pointer which causes
+ abort-on-error if waiting-for-input. Needs further investigation. */
owfi = waiting_for_input;
waiting_for_input = 0;
@@ -214,10 +215,10 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu)
break;
/* FIXME: we'd like to only parse the needed submenu, but this
- was causing crashes in the _common parsing code.. need to make
- sure proper initialization done.. */
-/* if (submenu && strcmp ([[submenu title] UTF8String], SSDATA (string)))
- continue; */
+ was causing crashes in the _common parsing code: need to make
+ sure proper initialization done. */
+ /* if (submenu && strcmp ([[submenu title] UTF8String], SSDATA (string)))
+ continue; */
submenu_start[i] = menu_items_used;
@@ -267,17 +268,17 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu)
set_buffer_internal_1 (prev);
- /* Compare the new menu items with previous, and leave off if no change */
+ /* Compare the new menu items with previous, and leave off if no change. */
/* FIXME: following other terms here, but seems like this should be
- done before parse stage 2 above, since its results aren't used */
+ done before parse stage 2 above, since its results aren't used. */
if (previous_menu_items_used
&& (!submenu || (submenu && submenu == last_submenu))
&& menu_items_used == previous_menu_items_used)
{
for (i = 0; i < previous_menu_items_used; i++)
/* FIXME: this ALWAYS fails on Buffers menu items.. something
- about their strings causes them to change every time, so we
- double-check failures */
+ about their strings causes them to change every time, so we
+ double-check failures. */
if (!EQ (previous_items[i], AREF (menu_items, i)))
if (!(STRINGP (previous_items[i])
&& STRINGP (AREF (menu_items, i))
@@ -286,7 +287,7 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu)
break;
if (i == previous_menu_items_used)
{
- /* No change.. */
+ /* No change. */
#if NSMENUPROFILE
ftime (&tb);
@@ -302,16 +303,16 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu)
return;
}
}
- /* The menu items are different, so store them in the frame */
- /* FIXME: this is not correct for single-submenu case */
+ /* The menu items are different, so store them in the frame. */
+ /* FIXME: this is not correct for single-submenu case. */
fset_menu_bar_vector (f, menu_items);
f->menu_bar_items_used = menu_items_used;
- /* Calls restore_menu_items, etc., as they were outside */
+ /* Calls restore_menu_items, etc., as they were outside. */
unbind_to (specpdl_count, Qnil);
/* Parse stage 2a: now GC cannot happen during the lifetime of the
- widget_value, so it's safe to store data from a Lisp_String */
+ widget_value, so it's safe to store data from a Lisp_String. */
wv = first_wv->contents;
for (i = 0; i < ASIZE (items); i += 4)
{
@@ -326,7 +327,7 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu)
}
/* Now, update the NS menu; if we have a submenu, use that, otherwise
- create a new menu for each sub and fill it. */
+ create a new menu for each sub and fill it. */
if (submenu)
{
const char *submenuTitle = [[submenu title] UTF8String];
@@ -358,7 +359,7 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu)
wv->button_type = BUTTON_TYPE_NONE;
first_wv = wv;
- /* Make widget-value tree w/ just the top level menu bar strings */
+ /* Make widget-value tree with just the top level menu bar strings. */
items = FRAME_MENU_BAR_ITEMS (f);
if (NILP (items))
{
@@ -369,7 +370,7 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu)
}
- /* check if no change.. this mechanism is a bit rough, but ready */
+ /* Check if no change: this mechanism is a bit rough, but ready. */
n = ASIZE (items) / 4;
if (f == last_f && n_previous_strings == n)
{
@@ -377,7 +378,7 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu)
{
string = AREF (items, 4*i+1);
- if (EQ (string, make_number (0))) // FIXME: Why??? --Stef
+ if (EQ (string, make_fixnum (0))) // FIXME: Why??? --Stef
continue;
if (NILP (string))
{
@@ -416,10 +417,10 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu)
wv->call_data = (void *) (intptr_t) (-1);
#ifdef NS_IMPL_COCOA
- /* we'll update the real copy under app menu when time comes */
+ /* We'll update the real copy under app menu when time comes. */
if (!strcmp ("Services", wv->name))
{
- /* but we need to make sure it will update on demand */
+ /* But we need to make sure it will update on demand. */
[svcsMenu setFrame: f];
}
else
@@ -461,7 +462,7 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu)
/* Main emacs core entry point for menubar menus: called to indicate that the
frame's menus have changed, and the *step representation should be updated
- from Lisp. */
+ from Lisp. */
void
set_frame_menubar (struct frame *f, bool first_time, bool deep_p)
{
@@ -489,7 +490,7 @@ x_activate_menubar (struct frame *f)
/* Menu that can define itself from Emacs "widget_value"s and will lazily
update itself when user clicked. Based on Carbon/AppKit implementation
- by Yamamoto Mitsuharu. */
+ by Yamamoto Mitsuharu. */
@implementation EmacsMenu
/* override designated initializer */
@@ -556,8 +557,8 @@ x_activate_menubar (struct frame *f)
#endif /* NS_IMPL_COCOA */
-/* delegate method called when a submenu is being opened: run a 'deep' call
- to set_frame_menubar */
+/* Delegate method called when a submenu is being opened: run a 'deep' call
+ to set_frame_menubar. */
- (void)menuNeedsUpdate: (NSMenu *)menu
{
if (!FRAME_LIVE_P (frame))
@@ -664,7 +665,7 @@ x_activate_menubar (struct frame *f)
[item setEnabled: wv->enabled];
- /* Draw radio buttons and tickboxes */
+ /* Draw radio buttons and tickboxes. */
if (wv->selected && (wv->button_type == BUTTON_TYPE_TOGGLE ||
wv->button_type == BUTTON_TYPE_RADIO))
[item setState: NSOnState];
@@ -735,7 +736,7 @@ x_activate_menubar (struct frame *f)
}
-/* adds an empty submenu and returns it */
+/* Adds an empty submenu and returns it. */
- (EmacsMenu *)addSubmenuWithTitle: (const char *)title forFrame: (struct frame *)f
{
NSString *titleStr = [NSString stringWithUTF8String: title];
@@ -748,7 +749,7 @@ x_activate_menubar (struct frame *f)
return submenu;
}
-/* run a menu in popup mode */
+/* Run a menu in popup mode. */
- (Lisp_Object)runMenuAt: (NSPoint)p forFrame: (struct frame *)f
keymaps: (bool)keymaps
{
@@ -756,7 +757,7 @@ x_activate_menubar (struct frame *f)
NSEvent *e, *event;
long retVal;
-/* p = [view convertPoint:p fromView: nil]; */
+ /* p = [view convertPoint:p fromView: nil]; */
p.y = NSHeight ([view frame]) - p.y;
e = [[view window] currentEvent];
event = [NSEvent mouseEventWithType: NSEventTypeRightMouseDown
@@ -765,7 +766,7 @@ x_activate_menubar (struct frame *f)
timestamp: [e timestamp]
windowNumber: [[view window] windowNumber]
context: nil
- eventNumber: 0/*[e eventNumber] */
+ eventNumber: 0 /* [e eventNumber] */
clickCount: 1
pressure: 0];
@@ -811,14 +812,14 @@ ns_menu_show (struct frame *f, int x, int y, int menuflags,
first_wv = wv;
#if 0
- /* FIXME: a couple of one-line differences prevent reuse */
+ /* FIXME: a couple of one-line differences prevent reuse. */
wv = digest_single_submenu (0, menu_items_used, 0);
#else
{
widget_value *save_wv = 0, *prev_wv = 0;
widget_value **submenu_stack
= alloca (menu_items_used * sizeof *submenu_stack);
-/* Lisp_Object *subprefix_stack
+ /* Lisp_Object *subprefix_stack
= alloca (menu_items_used * sizeof *subprefix_stack); */
int submenu_depth = 0;
int first_pane = 1;
@@ -828,7 +829,7 @@ ns_menu_show (struct frame *f, int x, int y, int menuflags,
i = 0;
while (i < menu_items_used)
{
- if (EQ (AREF (menu_items, i), Qnil))
+ if (NILP (AREF (menu_items, i)))
{
submenu_stack[submenu_depth++] = save_wv;
save_wv = prev_wv;
@@ -1009,8 +1010,8 @@ free_frame_tool_bar (struct frame *f)
block_input ();
view->wait_for_tool_bar = NO;
- /* Note: This trigger an animation, which calls windowDidResize
- repeatedly. */
+ /* Note: This triggers an animation, which calls windowDidResize
+ repeatedly. */
f->output_data.ns->in_animation = 1;
[[view toolbar] setVisible: NO];
f->output_data.ns->in_animation = 0;
@@ -1021,7 +1022,7 @@ free_frame_tool_bar (struct frame *f)
void
update_frame_tool_bar (struct frame *f)
/* --------------------------------------------------------------------------
- Update toolbar contents
+ Update toolbar contents.
-------------------------------------------------------------------------- */
{
int i, k = 0;
@@ -1042,7 +1043,7 @@ update_frame_tool_bar (struct frame *f)
[toolbar clearAll];
#endif
- /* update EmacsToolbar as in GtkUtils, build items list */
+ /* Update EmacsToolbar as in GtkUtils, build items list. */
for (i = 0; i < f->n_tool_bar_items; ++i)
{
#define TOOLPROP(IDX) AREF (f->tool_bar_items, \
@@ -1070,7 +1071,7 @@ update_frame_tool_bar (struct frame *f)
image = TOOLPROP (TOOL_BAR_ITEM_IMAGES);
if (VECTORP (image))
{
- /* NS toolbar auto-computes disabled and selected images */
+ /* NS toolbar auto-computes disabled and selected images. */
idx = TOOL_BAR_IMAGE_ENABLED_SELECTED;
eassert (ASIZE (image) >= idx);
image = AREF (image, idx);
@@ -1119,7 +1120,7 @@ update_frame_tool_bar (struct frame *f)
#ifdef NS_IMPL_COCOA
if ([toolbar changed])
{
- /* inform app that toolbar has changed */
+ /* Inform app that toolbar has changed. */
NSDictionary *dict = [toolbar configurationDictionary];
NSMutableDictionary *newDict = [dict mutableCopy];
NSEnumerator *keys = [[dict allKeys] objectEnumerator];
@@ -1252,7 +1253,7 @@ update_frame_tool_bar (struct frame *f)
}
/* This overrides super's implementation, which automatically sets
- all items to enabled state (for some reason). */
+ all items to enabled state (for some reason). */
- (void)validateVisibleItems
{
NSTRACE ("[EmacsToolbar validateVisibleItems]");
@@ -1267,7 +1268,7 @@ update_frame_tool_bar (struct frame *f)
{
NSTRACE ("[EmacsToolbar toolbar: ...]");
- /* look up NSToolbarItem by identifier and return... */
+ /* Look up NSToolbarItem by identifier and return... */
return [identifierToItem objectForKey: itemIdentifier];
}
@@ -1275,7 +1276,7 @@ update_frame_tool_bar (struct frame *f)
{
NSTRACE ("[EmacsToolbar toolbarDefaultItemIdentifiers:]");
- /* return entire set.. */
+ /* Return entire set. */
return activeIdentifiers;
}
@@ -1284,7 +1285,7 @@ update_frame_tool_bar (struct frame *f)
{
NSTRACE ("[EmacsToolbar toolbarAllowedItemIdentifiers:]");
- /* return entire set... */
+ /* return entire set... */
return activeIdentifiers;
//return [identifierToItem allKeys];
}
@@ -1313,24 +1314,22 @@ update_frame_tool_bar (struct frame *f)
========================================================================== */
/* Needed because NeXTstep does not provide enough control over tooltip
- display. */
+ display. */
@implementation EmacsTooltip
- (instancetype)init
{
- NSColor *bgcol = [NSColor colorWithCalibratedRed: 1.0 green: 1.0
+ NSColor *col = [NSColor colorWithCalibratedRed: 1.0 green: 1.0
blue: 0.792 alpha: 0.95];
- NSColor *fgcol = [NSColor blackColor];
NSFont *font = [NSFont toolTipsFontOfSize: 0];
NSFont *sfont = [font screenFont];
int height = [sfont ascender] - [sfont descender];
-/*[font boundingRectForFont].size.height; */
+ /* [font boundingRectForFont].size.height; */
NSRect r = NSMakeRect (0, 0, 100, height+6);
textField = [[NSTextField alloc] initWithFrame: r];
[textField setFont: font];
- [textField setTextColor: fgcol];
- [textField setBackgroundColor: bgcol];
+ [textField setBackgroundColor: col];
[textField setEditable: NO];
[textField setSelectable: NO];
@@ -1347,7 +1346,7 @@ update_frame_tool_bar (struct frame *f)
[win setReleasedWhenClosed: NO];
[win setDelegate: self];
[[win contentView] addSubview: textField];
-/* [win setBackgroundColor: bgcol]; */
+ /* [win setBackgroundColor: col]; */
[win setOpaque: NO];
return self;
@@ -1375,6 +1374,16 @@ update_frame_tool_bar (struct frame *f)
[textField setFrame: r];
}
+- (void) setBackgroundColor: (NSColor *)col
+{
+ [textField setBackgroundColor: col];
+}
+
+- (void) setForegroundColor: (NSColor *)col
+{
+ [textField setTextColor: col];
+}
+
- (void) showAtX: (int)x Y: (int)y for: (int)seconds
{
NSRect wr = [win frame];
@@ -1550,7 +1559,7 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents)
[self setTitle: @""];
area.origin.x += ICONSIZE+2*SPACER;
-/* area.origin.y = TEXTHEIGHT; ICONSIZE/2-10+SPACER; */
+ /* area.origin.y = TEXTHEIGHT; ICONSIZE/2-10+SPACER; */
area.size.width = 400;
area.size.height= TEXTHEIGHT;
command = [[[NSTextField alloc] initWithFrame: area] autorelease];
@@ -1561,16 +1570,16 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents)
[command setSelectable: NO];
[command setFont: [NSFont boldSystemFontOfSize: 13.0]];
-/* area.origin.x = ICONSIZE+2*SPACER;
+ /* area.origin.x = ICONSIZE+2*SPACER;
area.origin.y = TEXTHEIGHT + 2*SPACER;
area.size.width = 400;
area.size.height= 2;
tem = [[[NSBox alloc] initWithFrame: area] autorelease];
[[self contentView] addSubview: tem];
[tem setTitlePosition: NSNoTitle];
- [tem setAutoresizingMask: NSViewWidthSizable];*/
+ [tem setAutoresizingMask: NSViewWidthSizable]; */
-/* area.origin.x = ICONSIZE+2*SPACER; */
+ /* area.origin.x = ICONSIZE+2*SPACER; */
area.origin.y += TEXTHEIGHT+SPACER;
area.size.width = 400;
area.size.height= TEXTHEIGHT;
@@ -1624,24 +1633,24 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents)
int row = 0;
int buttons = 0, btnnr = 0;
- for (; XTYPE (lst) == Lisp_Cons; lst = XCDR (lst))
+ for (; CONSP (lst); lst = XCDR (lst))
{
item = XCAR (list);
- if (XTYPE (item) == Lisp_Cons)
+ if (CONSP (item))
++buttons;
}
if (buttons > 0)
button_values = xmalloc (buttons * sizeof *button_values);
- for (; XTYPE (list) == Lisp_Cons; list = XCDR (list))
+ for (; CONSP (list); list = XCDR (list))
{
item = XCAR (list);
- if (XTYPE (item) == Lisp_String)
+ if (STRINGP (item))
{
[self addString: SSDATA (item) row: row++];
}
- else if (XTYPE (item) == Lisp_Cons)
+ else if (CONSP (item))
{
button_values[btnnr] = XCDR (item);
[self addButton: SSDATA (XCAR (item)) value: btnnr row: row++];
@@ -1718,7 +1727,7 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents)
Lisp_Object head;
[super init];
- if (XTYPE (contents) == Lisp_Cons)
+ if (CONSP (contents))
{
head = Fcar (contents);
[self process_dialog: Fcdr (contents)];
@@ -1726,7 +1735,7 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents)
else
head = contents;
- if (XTYPE (head) == Lisp_String)
+ if (STRINGP (head))
[title setStringValue:
[NSString stringWithUTF8String: SSDATA (head)]];
else if (isQ == YES)
@@ -1738,7 +1747,7 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents)
int i;
NSRect r, s, t;
- if (cols == 1 && rows > 1) /* Never told where to split */
+ if (cols == 1 && rows > 1) /* Never told where to split. */
{
[matrix addColumn];
for (i = 0; i < rows/2; i++)
@@ -1802,9 +1811,9 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents)
data2: 0];
timer_fired = YES;
- /* We use sto because stopModal/abortModal out of the main loop does not
- seem to work in 10.6. But as we use stop we must send a real event so
- the stop is seen and acted upon. */
+ /* We use stop because stopModal/abortModal out of the main loop
+ does not seem to work in 10.6. But as we use stop we must send a
+ real event so the stop is seen and acted upon. */
[NSApp stop:self];
[NSApp postEvent: nxev atStart: NO];
}
@@ -1835,7 +1844,7 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents)
ret = dialog_return;
if (! timer_fired)
{
- if (tmo != nil) [tmo invalidate]; /* Cancels timer */
+ if (tmo != nil) [tmo invalidate]; /* Cancels timer. */
break;
}
}
@@ -1866,7 +1875,7 @@ DEFUN ("ns-reset-menu", Fns_reset_menu, Sns_reset_menu, 0, 0, 0,
DEFUN ("menu-or-popup-active-p", Fmenu_or_popup_active_p, Smenu_or_popup_active_p, 0, 0, 0,
- doc: /* Return t if a menu or popup dialog is active. */)
+ doc: /* SKIP: real doc in xmenu.c. */)
(void)
{
return popup_activated () ? Qt : Qnil;
@@ -1885,6 +1894,7 @@ syms_of_nsmenu (void)
/* Don't know how to keep track of this in Next/Open/GNUstep. Always
update menus there. */
trackingMenu = 1;
+ PDUMPER_REMEMBER_SCALAR (trackingMenu);
#endif
defsubr (&Sns_reset_menu);
defsubr (&Smenu_or_popup_active_p);
diff --git a/src/nsselect.m b/src/nsselect.m
index c6dc05d1ec4..cf36c869eb1 100644
--- a/src/nsselect.m
+++ b/src/nsselect.m
@@ -36,7 +36,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu)
static Lisp_Object Vselection_alist;
-/* NSGeneralPboard is pretty much analogous to X11 CLIPBOARD */
+/* NSPasteboardNameGeneral is pretty much analogous to X11 CLIPBOARD. */
static NSString *NXPrimaryPboard;
static NSString *NXSecondaryPboard;
@@ -54,7 +54,7 @@ static NSString *
symbol_to_nsstring (Lisp_Object sym)
{
CHECK_SYMBOL (sym);
- if (EQ (sym, QCLIPBOARD)) return NSGeneralPboard;
+ if (EQ (sym, QCLIPBOARD)) return NSPasteboardNameGeneral;
if (EQ (sym, QPRIMARY)) return NXPrimaryPboard;
if (EQ (sym, QSECONDARY)) return NXSecondaryPboard;
if (EQ (sym, QTEXT)) return NSStringPboardType;
@@ -70,7 +70,7 @@ ns_symbol_to_pb (Lisp_Object symbol)
static Lisp_Object
ns_string_to_symbol (NSString *t)
{
- if ([t isEqualToString: NSGeneralPboard])
+ if ([t isEqualToString: NSPasteboardNameGeneral])
return QCLIPBOARD;
if ([t isEqualToString: NXPrimaryPboard])
return QPRIMARY;
@@ -90,20 +90,20 @@ static Lisp_Object
clean_local_selection_data (Lisp_Object obj)
{
if (CONSP (obj)
- && INTEGERP (XCAR (obj))
+ && FIXNUMP (XCAR (obj))
&& CONSP (XCDR (obj))
- && INTEGERP (XCAR (XCDR (obj)))
+ && FIXNUMP (XCAR (XCDR (obj)))
&& NILP (XCDR (XCDR (obj))))
obj = Fcons (XCAR (obj), XCDR (obj));
if (CONSP (obj)
- && INTEGERP (XCAR (obj))
- && INTEGERP (XCDR (obj)))
+ && FIXNUMP (XCAR (obj))
+ && FIXNUMP (XCDR (obj)))
{
- if (XINT (XCAR (obj)) == 0)
+ if (XFIXNUM (XCAR (obj)) == 0)
return XCDR (obj);
- if (XINT (XCAR (obj)) == -1)
- return make_number (- XINT (XCDR (obj)));
+ if (XFIXNUM (XCAR (obj)) == -1)
+ return make_fixnum (- XFIXNUM (XCDR (obj)));
}
if (VECTORP (obj))
@@ -164,7 +164,7 @@ ns_get_our_change_count_for (Lisp_Object selection)
static void
ns_string_to_pasteboard_internal (id pb, Lisp_Object str, NSString *gtype)
{
- if (EQ (str, Qnil))
+ if (NILP (str))
{
[pb declareTypes: [NSArray array] owner: nil];
}
@@ -399,7 +399,7 @@ these literal upper-case names.) The symbol nil is the same as
return Qnil;
CHECK_SYMBOL (selection);
- if (EQ (selection, Qnil)) selection = QPRIMARY;
+ if (NILP (selection)) selection = QPRIMARY;
if (EQ (selection, Qt)) selection = QSECONDARY;
pb = ns_symbol_to_pb (selection);
if (pb == nil) return Qnil;
@@ -421,7 +421,7 @@ and t is the same as `SECONDARY'. */)
{
check_window_system (NULL);
CHECK_SYMBOL (selection);
- if (EQ (selection, Qnil)) selection = QPRIMARY;
+ if (NILP (selection)) selection = QPRIMARY;
if (EQ (selection, Qt)) selection = QSECONDARY;
return ns_get_pb_change_count (selection)
== ns_get_our_change_count_for (selection)
@@ -469,7 +469,7 @@ nxatoms_of_nsselect (void)
pasteboard_changecount
= [[NSMutableDictionary
dictionaryWithObjectsAndKeys:
- [NSNumber numberWithLong:0], NSGeneralPboard,
+ [NSNumber numberWithLong:0], NSPasteboardNameGeneral,
[NSNumber numberWithLong:0], NXPrimaryPboard,
[NSNumber numberWithLong:0], NXSecondaryPboard,
[NSNumber numberWithLong:0], NSStringPboardType,
diff --git a/src/nsterm.h b/src/nsterm.h
index 35dd9b3c3b6..78ce6085545 100644
--- a/src/nsterm.h
+++ b/src/nsterm.h
@@ -29,7 +29,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
/* CGFloat on GNUstep may be 4 or 8 byte, but functions expect float* for some
versions.
- On Cocoa >= 10.5, functions expect CGFloat *. Make compatible type. */
+ On Cocoa >= 10.5, functions expect CGFloat *. Make compatible type. */
#ifdef NS_IMPL_COCOA
typedef CGFloat EmacsCGFloat;
#elif GNUSTEP_GUI_MAJOR_VERSION > 0 || GNUSTEP_GUI_MINOR_VERSION >= 22
@@ -85,7 +85,7 @@ typedef float EmacsCGFloat;
can become misaligned, as all threads (currently) share one state.
This is post prominent when the EVENTS part is enabled.
- Note that the trace system, when enabled, use the GCC/Clang
+ Note that the trace system, when enabled, uses the GCC/Clang
"cleanup" extension. */
/* For example, the following is the output of `M-x
@@ -170,7 +170,7 @@ void nstrace_leave(int *);
void nstrace_restore_global_trace_state(int *);
char const * nstrace_fullscreen_type_name (int);
-/* printf-style trace output. Output is aligned with contained heading. */
+/* printf-style trace output. Output is aligned with contained heading. */
#define NSTRACE_MSG_NO_DASHES(...) \
do \
{ \
@@ -192,7 +192,7 @@ char const * nstrace_fullscreen_type_name (int);
/* Macros for printing complex types.
NSTRACE_FMT_what -- Printf format string for "what".
- NSTRACE_ARG_what(x) -- Printf argument for "what". */
+ NSTRACE_ARG_what(x) -- Printf argument for "what". */
#define NSTRACE_FMT_SIZE "(W:%.0f H:%.0f)"
#define NSTRACE_ARG_SIZE(elt) (elt).width, (elt).height
@@ -208,7 +208,7 @@ char const * nstrace_fullscreen_type_name (int);
#define NSTRACE_ARG_FSTYPE(elt) nstrace_fullscreen_type_name(elt)
-/* Macros for printing complex types as extra information. */
+/* Macros for printing complex types as extra information. */
#define NSTRACE_SIZE(str,size) \
NSTRACE_MSG (str ": " NSTRACE_FMT_SIZE, \
@@ -236,7 +236,7 @@ char const * nstrace_fullscreen_type_name (int);
NSTRACE_FMT_RETURN - A string literal representing a returned
value. Useful when creating a format string
- to printf-like constructs like NSTRACE(). */
+ to printf-like constructs like NSTRACE(). */
#define NSTRACE_FMT_RETURN "->>"
@@ -262,7 +262,7 @@ char const * nstrace_fullscreen_type_name (int);
NSTRACE_WHEN (cond, fmt, ...) -- Enable trace output when COND is true.
NSTRACE_UNLESS (cond, fmt, ...) -- Enable trace output unless COND is
- true. */
+ true. */
@@ -278,7 +278,7 @@ char const * nstrace_fullscreen_type_name (int);
/* Unsilence called functions.
Concretely, this us used to allow "event" functions to be silenced
- while trace output can be printed for functions they call. */
+ while trace output can be printed for functions they call. */
#define NSTRACE_UNSILENCE() do { nstrace_enabled_global = 1; } while(0)
#endif /* NSTRACE_ENABLED */
@@ -286,7 +286,7 @@ char const * nstrace_fullscreen_type_name (int);
#define NSTRACE(...) NSTRACE_WHEN(1, __VA_ARGS__)
#define NSTRACE_UNLESS(cond, ...) NSTRACE_WHEN(!(cond), __VA_ARGS__)
-/* Non-trace replacement versions. */
+/* Non-trace replacement versions. */
#ifndef NSTRACE_WHEN
#define NSTRACE_WHEN(...)
#endif
@@ -332,7 +332,7 @@ char const * nstrace_fullscreen_type_name (int);
#endif
-/* If the compiler doesn't support instancetype, map it to id. */
+/* If the compiler doesn't support instancetype, map it to id. */
#ifndef NATIVE_OBJC_INSTANCETYPE
typedef id instancetype;
#endif
@@ -356,7 +356,7 @@ typedef id instancetype;
========================================================================== */
-/* We override sendEvent: as a means to stop/start the event loop */
+/* We override sendEvent: as a means to stop/start the event loop. */
@interface EmacsApp : NSApplication
{
#ifdef NS_IMPL_COCOA
@@ -456,7 +456,7 @@ typedef id instancetype;
#endif
- (int)fullscreenState;
-/* Non-notification versions of NSView methods. Used for direct calls. */
+/* Non-notification versions of NSView methods. Used for direct calls. */
- (void)windowWillEnterFullScreen;
- (void)windowDidEnterFullScreen;
- (void)windowWillExitFullScreen;
@@ -465,7 +465,7 @@ typedef id instancetype;
@end
-/* Small utility used for processing resize events under Cocoa. */
+/* Small utility used for processing resize events under Cocoa. */
@interface EmacsWindow : NSWindow
{
NSPoint grabOffset;
@@ -585,6 +585,8 @@ typedef id instancetype;
}
- (instancetype) init;
- (void) setText: (char *)text;
+- (void) setBackgroundColor: (NSColor *)col;
+- (void) setForegroundColor: (NSColor *)col;
- (void) showAtX: (int)x Y: (int)y for: (int)seconds;
- (void) hide;
- (BOOL) isActive;
@@ -646,6 +648,7 @@ typedef id instancetype;
- (NSColor *)stippleMask;
- (Lisp_Object)getMetadata;
- (BOOL)setFrame: (unsigned int) index;
+- (instancetype)rotate: (double)rotation;
@end
@@ -718,7 +721,7 @@ extern NSArray *ns_send_types, *ns_return_types;
extern NSString *ns_app_name;
extern EmacsMenu *svcsMenu;
-/* Apple removed the declaration, but kept the implementation */
+/* Apple removed the declaration, but kept the implementation. */
#if defined (NS_IMPL_COCOA)
@interface NSApplication (EmacsApp)
- (void)setAppleMenu: (NSMenu *)menu;
@@ -748,8 +751,8 @@ extern EmacsMenu *svcsMenu;
#define KEY_NS_TOGGLE_TOOLBAR ((1<<28)|(0<<16)|13)
#define KEY_NS_SHOW_PREFS ((1<<28)|(0<<16)|14)
-/* could use list to store these, but rest of emacs has a big infrastructure
- for managing a table of bitmap "records" */
+/* Could use list to store these, but rest of emacs has a big infrastructure
+ for managing a table of bitmap "records". */
struct ns_bitmap_record
{
#ifdef __OBJC__
@@ -762,7 +765,7 @@ struct ns_bitmap_record
int height, width, depth;
};
-/* this to map between emacs color indices and NSColor objects */
+/* This maps between emacs color indices and NSColor objects. */
struct ns_color_table
{
ptrdiff_t size;
@@ -786,7 +789,7 @@ struct ns_color_table
#define BLUE_FROM_ULONG(color) ((color) & 0xff)
/* Do not change `* 0x101' in the following lines to `<< 8'. If
- changed, image masks in 1-bit depth will not work. */
+ changed, image masks in 1-bit depth will not work. */
#define RED16_FROM_ULONG(color) (RED_FROM_ULONG(color) * 0x101)
#define GREEN16_FROM_ULONG(color) (GREEN_FROM_ULONG(color) * 0x101)
#define BLUE16_FROM_ULONG(color) (BLUE_FROM_ULONG(color) * 0x101)
@@ -798,7 +801,7 @@ struct nsfont_info
char *name; /* PostScript name, uniquely identifies on NS systems */
- /* The following metrics are stored as float rather than int. */
+ /* The following metrics are stored as float rather than int. */
float width; /* Maximum advance for the font. */
float height;
@@ -819,26 +822,26 @@ struct nsfont_info
char bold, ital; /* convenience flags */
char synthItal;
XCharStruct max_bounds;
- /* we compute glyph codes and metrics on-demand in blocks of 256 indexed
- by hibyte, lobyte */
+ /* We compute glyph codes and metrics on-demand in blocks of 256 indexed
+ by hibyte, lobyte. */
unsigned short **glyphs; /* map Unicode index to glyph */
struct font_metrics **metrics;
};
-/* init'd in ns_initialize_display_info () */
+/* Initialized in ns_initialize_display_info (). */
struct ns_display_info
{
/* Chain of all ns_display_info structures. */
struct ns_display_info *next;
- /* The generic display parameters corresponding to this NS display. */
+ /* The generic display parameters corresponding to this NS display. */
struct terminal *terminal;
/* This is a cons cell of the form (NAME . FONT-LIST-CACHE). */
Lisp_Object name_list_element;
- /* The number of fonts loaded. */
+ /* The number of fonts loaded. */
int n_fonts;
/* Minimum width over all characters in all fonts in font_table. */
@@ -868,10 +871,10 @@ struct ns_display_info
/* Xism */
XrmDatabase xrdb;
- /* The cursor to use for vertical scroll bars. */
+ /* The cursor to use for vertical scroll bars. */
Cursor vertical_scroll_bar_cursor;
- /* The cursor to use for horizontal scroll bars. */
+ /* The cursor to use for horizontal scroll bars. */
Cursor horizontal_scroll_bar_cursor;
/* Information about the range of text currently shown in
@@ -927,7 +930,7 @@ struct ns_output
void *toolbar;
#endif
- /* NSCursors init'ed in initFrameFromEmacs */
+ /* NSCursors are initialized in initFrameFromEmacs. */
Cursor text_cursor;
Cursor nontext_cursor;
Cursor modeline_cursor;
@@ -965,10 +968,10 @@ struct ns_output
scroll bars, in pixels. */
int vertical_scroll_bar_extra;
- /* The height of the titlebar decoration (included in NSWindow's frame). */
+ /* The height of the titlebar decoration (included in NSWindow's frame). */
int titlebar_height;
- /* The height of the toolbar if displayed, else 0. */
+ /* The height of the toolbar if displayed, else 0. */
int toolbar_height;
/* This is the Emacs structure for the NS display this frame is on. */
@@ -977,11 +980,11 @@ struct ns_output
/* Non-zero if we are zooming (maximizing) the frame. */
int zooming;
- /* Non-zero if we are doing an animation, e.g. toggling the tool bar. */
+ /* Non-zero if we are doing an animation, e.g. toggling the tool bar. */
int in_animation;
};
-/* this dummy decl needed to support TTYs */
+/* This dummy declaration needed to support TTYs. */
struct x_output
{
int unused;
@@ -1015,12 +1018,12 @@ struct x_output
#define FRAME_FONT(f) ((f)->output_data.ns->font)
#ifdef __OBJC__
-#define XNS_SCROLL_BAR(vec) ((id) XSAVE_POINTER (vec, 0))
+#define XNS_SCROLL_BAR(vec) ((id) xmint_pointer (vec))
#else
-#define XNS_SCROLL_BAR(vec) XSAVE_POINTER (vec, 0)
+#define XNS_SCROLL_BAR(vec) xmint_pointer (vec)
#endif
-/* Compute pixel height of the frame's titlebar. */
+/* Compute pixel height of the frame's titlebar. */
#define FRAME_NS_TITLEBAR_HEIGHT(f) \
(NSHeight([FRAME_NS_VIEW (f) frame]) == 0 ? \
0 \
@@ -1029,7 +1032,7 @@ struct x_output
[[FRAME_NS_VIEW (f) window] frame] \
styleMask:[[FRAME_NS_VIEW (f) window] styleMask]])))
-/* Compute pixel height of the toolbar. */
+/* Compute pixel height of the toolbar. */
#define FRAME_TOOLBAR_HEIGHT(f) \
(([[FRAME_NS_VIEW (f) window] toolbar] == nil \
|| ! [[FRAME_NS_VIEW (f) window] toolbar].isVisible) ? \
@@ -1039,7 +1042,7 @@ struct x_output
styleMask:[[FRAME_NS_VIEW (f) window] styleMask]]) \
- NSHeight([[[FRAME_NS_VIEW (f) window] contentView] frame])))
-/* Compute pixel size for vertical scroll bars */
+/* Compute pixel size for vertical scroll bars. */
#define NS_SCROLL_BAR_WIDTH(f) \
(FRAME_HAS_VERTICAL_SCROLL_BARS (f) \
? rint (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) > 0 \
@@ -1047,7 +1050,7 @@ struct x_output
: (FRAME_SCROLL_BAR_COLS (f) * FRAME_COLUMN_WIDTH (f))) \
: 0)
-/* Compute pixel size for horizontal scroll bars */
+/* Compute pixel size for horizontal scroll bars. */
#define NS_SCROLL_BAR_HEIGHT(f) \
(FRAME_HAS_HORIZONTAL_SCROLL_BARS (f) \
? rint (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) > 0 \
@@ -1055,22 +1058,22 @@ struct x_output
: (FRAME_SCROLL_BAR_LINES (f) * FRAME_LINE_HEIGHT (f))) \
: 0)
-/* Difference btwn char-column-calculated and actual SB widths.
- This is only a concern for rendering when SB on left. */
+/* Difference between char-column-calculated and actual SB widths.
+ This is only a concern for rendering when SB on left. */
#define NS_SCROLL_BAR_ADJUST(w, f) \
(WINDOW_HAS_VERTICAL_SCROLL_BAR_ON_LEFT (w) ? \
(FRAME_SCROLL_BAR_COLS (f) * FRAME_COLUMN_WIDTH (f) \
- NS_SCROLL_BAR_WIDTH (f)) : 0)
-/* Difference btwn char-line-calculated and actual SB heights.
- This is only a concern for rendering when SB on top. */
+/* Difference between char-line-calculated and actual SB heights.
+ This is only a concern for rendering when SB on top. */
#define NS_SCROLL_BAR_ADJUST_HORIZONTALLY(w, f) \
(WINDOW_HAS_HORIZONTAL_SCROLL_BARS (w) ? \
(FRAME_SCROLL_BAR_LINES (f) * FRAME_LINE_HEIGHT (f) \
- NS_SCROLL_BAR_HEIGHT (f)) : 0)
/* Calculate system coordinates of the left and top of the parent
- window or, if there is no parent window, the screen. */
+ window or, if there is no parent window, the screen. */
#define NS_PARENT_WINDOW_LEFT_POS(f) \
(FRAME_PARENT_FRAME (f) != NULL \
? [FRAME_NS_VIEW (FRAME_PARENT_FRAME (f)) window].frame.origin.x : 0)
@@ -1090,7 +1093,7 @@ struct x_output
#define WHITE_PIX_DEFAULT(f) 0xFFFFFF
/* First position where characters can be shown (instead of scrollbar, if
- it is on left. */
+ it is on left. */
#define FIRST_CHAR_POSITION(f) \
(! (FRAME_HAS_VERTICAL_SCROLL_BARS_ON_LEFT (f)) ? 0 \
: FRAME_SCROLL_BAR_COLS (f))
@@ -1114,7 +1117,7 @@ extern void nsfont_make_fontset_for_font (Lisp_Object name,
struct glyph_string;
void ns_dump_glyphstring (struct glyph_string *s) EXTERNALLY_VISIBLE;
-/* Implemented in nsterm, published in or needed from nsfns. */
+/* Implemented in nsterm, published in or needed from nsfns. */
extern Lisp_Object ns_list_fonts (struct frame *f, Lisp_Object pattern,
int size, int maxnames);
extern void ns_clear_frame (struct frame *f);
@@ -1156,6 +1159,9 @@ extern void ns_release_autorelease_pool (void *);
extern const char *ns_get_defaults_value (const char *key);
extern void ns_init_locale (void);
+#ifdef NS_IMPL_COCOA
+extern void ns_enable_screen_updates (void);
+#endif
/* in nsmenu */
extern void update_frame_tool_bar (struct frame *f);
@@ -1190,6 +1196,7 @@ extern bool ns_load_image (struct frame *f, struct image *img,
Lisp_Object spec_file, Lisp_Object spec_data);
extern int ns_image_width (void *img);
extern int ns_image_height (void *img);
+extern void ns_image_set_size (void *img, int width, int height);
extern unsigned long ns_get_pixel (void *img, int x, int y);
extern void ns_put_pixel (void *img, int x, int y, unsigned long argb);
extern void ns_set_alpha (void *img, int x, int y, unsigned char a);
@@ -1230,12 +1237,6 @@ struct input_event;
extern void ns_init_events (struct input_event *);
extern void ns_finish_events (void);
-#ifdef __OBJC__
-/* Needed in nsfns.m. */
-extern void
-ns_set_represented_filename (NSString *fstr, struct frame *f);
-
-#endif
#ifdef NS_IMPL_GNUSTEP
extern char gnustep_base_version[]; /* version tracking */
@@ -1244,13 +1245,13 @@ extern char gnustep_base_version[]; /* version tracking */
#define MINWIDTH 10
#define MINHEIGHT 10
-/* Screen max coordinate
- Using larger coordinates causes movewindow/placewindow to abort */
+/* Screen max coordinate -- using larger coordinates causes
+ movewindow/placewindow to abort. */
#define SCREENMAX 16000
#define NS_SCROLL_BAR_WIDTH_DEFAULT [EmacsScroller scrollerWidth]
#define NS_SCROLL_BAR_HEIGHT_DEFAULT [EmacsScroller scrollerHeight]
-/* This is to match emacs on other platforms, ugly though it is. */
+/* This is to match emacs on other platforms, ugly though it is. */
#define NS_SELECTION_BG_COLOR_DEFAULT @"LightGoldenrod2";
#define NS_SELECTION_FG_COLOR_DEFAULT @"Black";
#define RESIZE_HANDLE_SIZE 12
@@ -1260,7 +1261,7 @@ extern char gnustep_base_version[]; /* version tracking */
? (min) : (((x)>(max)) ? (max) : (x)))
#define SCREENMAXBOUND(x) (IN_BOUND (-SCREENMAX, x, SCREENMAX))
-/* macOS 10.7 introduces some new constants. */
+/* macOS 10.7 introduces some new constants. */
#if !defined (NS_IMPL_COCOA) || !defined (MAC_OS_X_VERSION_10_7)
#define NSFullScreenWindowMask (1 << 14)
#define NSWindowCollectionBehaviorFullScreenPrimary (1 << 7)
@@ -1269,7 +1270,7 @@ extern char gnustep_base_version[]; /* version tracking */
#define NSAppKitVersionNumber10_7 1138
#endif /* !defined (MAC_OS_X_VERSION_10_7) */
-/* macOS 10.12 deprecates a bunch of constants. */
+/* macOS 10.12 deprecates a bunch of constants. */
#if !defined (NS_IMPL_COCOA) || !defined (MAC_OS_X_VERSION_10_12)
#define NSEventModifierFlagCommand NSCommandKeyMask
#define NSEventModifierFlagControl NSControlKeyMask
@@ -1306,18 +1307,24 @@ extern char gnustep_base_version[]; /* version tracking */
#define NSWindowStyleMaskUtilityWindow NSUtilityWindowMask
#define NSAlertStyleCritical NSCriticalAlertStyle
#define NSControlSizeRegular NSRegularControlSize
+#define NSCompositingOperationCopy NSCompositeCopy
-/* And adds NSWindowStyleMask. */
+/* And adds NSWindowStyleMask. */
#ifdef __OBJC__
typedef NSUInteger NSWindowStyleMask;
#endif
-/* Window tabbing mode enums are new too. */
+/* Window tabbing mode enums are new too. */
enum NSWindowTabbingMode
{
NSWindowTabbingModeAutomatic,
NSWindowTabbingModePreferred,
NSWindowTabbingModeDisallowed
};
+#endif /* !defined (NS_IMPL_COCOA) || !defined (MAC_OS_X_VERSION_10_12) */
+
+#if !defined (NS_IMPL_COCOA) || !defined (MAC_OS_X_VERSION_10_13)
+/* Deprecated in macOS 10.13. */
+#define NSPasteboardNameGeneral NSGeneralPboard
#endif
#endif /* HAVE_NS */
diff --git a/src/nsterm.m b/src/nsterm.m
index bbd2c84214c..81d36be6cc0 100644
--- a/src/nsterm.m
+++ b/src/nsterm.m
@@ -27,7 +27,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu)
*/
/* This should be the first include, as it may set up #defines affecting
- interpretation of even the system includes. */
+ interpretation of even the system includes. */
#include <config.h>
#include <fcntl.h>
@@ -37,6 +37,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu)
#include <time.h>
#include <signal.h>
#include <unistd.h>
+#include <stdbool.h>
#include <c-ctype.h>
#include <c-strcase.h>
@@ -59,6 +60,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu)
#include "keyboard.h"
#include "buffer.h"
#include "font.h"
+#include "pdumper.h"
#ifdef NS_IMPL_GNUSTEP
#include "process.h"
@@ -66,6 +68,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu)
#ifdef NS_IMPL_COCOA
#include "macfont.h"
+#include <Carbon/Carbon.h>
#endif
static EmacsMenu *dockMenu;
@@ -82,7 +85,7 @@ static EmacsMenu *mainMenu;
#if NSTRACE_ENABLED
/* The following use "volatile" since they can be accessed from
- parallel threads. */
+ parallel threads. */
volatile int nstrace_num = 0;
volatile int nstrace_depth = 0;
@@ -91,10 +94,10 @@ volatile int nstrace_depth = 0;
TODO: This should really be a thread-local variable, to avoid that
a function with disabled trace thread silence trace output in
- another. However, in practice this seldom is a problem. */
+ another. However, in practice this seldom is a problem. */
volatile int nstrace_enabled_global = 1;
-/* Called when nstrace_enabled goes out of scope. */
+/* Called when nstrace_enabled goes out of scope. */
void nstrace_leave(int * pointer_to_nstrace_enabled)
{
if (*pointer_to_nstrace_enabled)
@@ -104,7 +107,7 @@ void nstrace_leave(int * pointer_to_nstrace_enabled)
}
-/* Called when nstrace_saved_enabled_global goes out of scope. */
+/* Called when nstrace_saved_enabled_global goes out of scope. */
void nstrace_restore_global_trace_state(int * pointer_to_saved_enabled_global)
{
nstrace_enabled_global = *pointer_to_saved_enabled_global;
@@ -159,7 +162,7 @@ char const * nstrace_fullscreen_type_name (int fs_type)
{
/* FIXMES: We're checking for colorWithSRGBRed here so this will
only work in the same place as in the method above. It should
- really be a check whether we're on macOS 10.7 or above. */
+ really be a check whether we're on macOS 10.7 or above. */
#if defined (NS_IMPL_COCOA) \
&& MAC_OS_X_VERSION_MAX_ALLOWED >= 1070
if (ns_use_srgb_colorspace
@@ -183,7 +186,7 @@ char const * nstrace_fullscreen_type_name (int fs_type)
/* Convert a symbol indexed with an NSxxx value to a value as defined
in keyboard.c (lispy_function_key). I hope this is a correct way
- of doing things... */
+ of doing things... */
static unsigned convert_ns_to_X_keysym[] =
{
NSHomeFunctionKey, 0x50,
@@ -232,9 +235,9 @@ static unsigned convert_ns_to_X_keysym[] =
NSF23FunctionKey, 0xD4,
NSF24FunctionKey, 0xD5,
- NSBackspaceCharacter, 0x08, /* 8: Not on some KBs. */
- NSDeleteCharacter, 0xFF, /* 127: Big 'delete' key upper right. */
- NSDeleteFunctionKey, 0x9F, /* 63272: Del forw key off main array. */
+ NSBackspaceCharacter, 0x08, /* 8: Not on some KBs. */
+ NSDeleteCharacter, 0xFF, /* 127: Big 'delete' key upper right. */
+ NSDeleteFunctionKey, 0x9F, /* 63272: Del forw key off main array. */
NSTabCharacter, 0x09,
0x19, 0x09, /* left tab->regular since pass shift */
@@ -264,7 +267,7 @@ static unsigned convert_ns_to_X_keysym[] =
/* On macOS picks up the default NSGlobalDomain AppleAntiAliasingThreshold,
the maximum font size to NOT antialias. On GNUstep there is currently
- no way to control this behavior. */
+ no way to control this behavior. */
float ns_antialias_threshold;
NSArray *ns_send_types = 0, *ns_return_types = 0;
@@ -280,8 +283,11 @@ static int ns_window_num = 0;
static BOOL ns_fake_keydown = NO;
#ifdef NS_IMPL_COCOA
static BOOL ns_menu_bar_is_hidden = NO;
+
+/* The number of times NSDisableScreenUpdates has been called. */
+static int disable_screen_updates_count = 0;
#endif
-/*static int debug_lock = 0; */
+/* static int debug_lock = 0; */
/* event loop */
static BOOL send_appdefined = YES;
@@ -316,9 +322,6 @@ static struct {
NULL, 0, 0
};
-static NSString *represented_filename = nil;
-static struct frame *represented_frame = 0;
-
#ifdef NS_IMPL_COCOA
/*
* State for pending menu activation:
@@ -345,31 +348,56 @@ static CGPoint menu_mouse_point;
#define NSRightCommandKeyMask (0x000010 | NSEventModifierFlagCommand)
#define NSLeftAlternateKeyMask (0x000020 | NSEventModifierFlagOption)
#define NSRightAlternateKeyMask (0x000040 | NSEventModifierFlagOption)
-#define EV_MODIFIERS2(flags) \
- (((flags & NSEventModifierFlagHelp) ? \
- hyper_modifier : 0) \
- | (!EQ (ns_right_alternate_modifier, Qleft) && \
- ((flags & NSRightAlternateKeyMask) \
- == NSRightAlternateKeyMask) ? \
- parse_solitary_modifier (ns_right_alternate_modifier) : 0) \
- | ((flags & NSEventModifierFlagOption) ? \
- parse_solitary_modifier (ns_alternate_modifier) : 0) \
- | ((flags & NSEventModifierFlagShift) ? \
- shift_modifier : 0) \
- | (!EQ (ns_right_control_modifier, Qleft) && \
- ((flags & NSRightControlKeyMask) \
- == NSRightControlKeyMask) ? \
- parse_solitary_modifier (ns_right_control_modifier) : 0) \
- | ((flags & NSEventModifierFlagControl) ? \
- parse_solitary_modifier (ns_control_modifier) : 0) \
- | ((flags & NS_FUNCTION_KEY_MASK) ? \
- parse_solitary_modifier (ns_function_modifier) : 0) \
- | (!EQ (ns_right_command_modifier, Qleft) && \
- ((flags & NSRightCommandKeyMask) \
- == NSRightCommandKeyMask) ? \
- parse_solitary_modifier (ns_right_command_modifier) : 0) \
- | ((flags & NSEventModifierFlagCommand) ? \
- parse_solitary_modifier (ns_command_modifier):0))
+
+static unsigned int
+ev_modifiers_helper (unsigned int flags, unsigned int left_mask,
+ unsigned int right_mask, unsigned int either_mask,
+ Lisp_Object left_modifier, Lisp_Object right_modifier)
+{
+ unsigned int modifiers = 0;
+
+ if (flags & either_mask)
+ {
+ BOOL left_key = (flags & left_mask) == left_mask;
+ BOOL right_key = (flags & right_mask) == right_mask
+ && ! EQ (right_modifier, Qleft);
+
+ if (right_key)
+ modifiers |= parse_solitary_modifier (right_modifier);
+
+ /* GNUstep (and possibly macOS in certain circumstances) doesn't
+ differentiate between the left and right keys, so if we can't
+ identify which key it is, we use the left key setting. */
+ if (left_key || ! right_key)
+ modifiers |= parse_solitary_modifier (left_modifier);
+ }
+
+ return modifiers;
+}
+
+#define EV_MODIFIERS2(flags) \
+ (((flags & NSEventModifierFlagHelp) ? \
+ hyper_modifier : 0) \
+ | ((flags & NSEventModifierFlagShift) ? \
+ shift_modifier : 0) \
+ | ((flags & NS_FUNCTION_KEY_MASK) ? \
+ parse_solitary_modifier (ns_function_modifier) : 0) \
+ | ev_modifiers_helper (flags, NSLeftControlKeyMask, \
+ NSRightControlKeyMask, \
+ NSEventModifierFlagControl, \
+ ns_control_modifier, \
+ ns_right_control_modifier) \
+ | ev_modifiers_helper (flags, NSLeftCommandKeyMask, \
+ NSRightCommandKeyMask, \
+ NSEventModifierFlagCommand, \
+ ns_command_modifier, \
+ ns_right_command_modifier) \
+ | ev_modifiers_helper (flags, NSLeftAlternateKeyMask, \
+ NSRightAlternateKeyMask, \
+ NSEventModifierFlagOption, \
+ ns_alternate_modifier, \
+ ns_right_alternate_modifier))
+
#define EV_MODIFIERS(e) EV_MODIFIERS2 ([e modifierFlags])
#define EV_UDMODIFIERS(e) \
@@ -388,7 +416,7 @@ static CGPoint menu_mouse_point;
(([e type] == NSEventTypeRightMouseDown) || ([e type] == NSEventTypeRightMouseUp)) ? 2 : \
[e buttonNumber] - 1)
-/* Convert the time field to a timestamp in milliseconds. */
+/* Convert the time field to a timestamp in milliseconds. */
#define EV_TIMESTAMP(e) ([e timestamp] * 1000)
/* This is a piece of code which is common to all the event handling
@@ -418,14 +446,14 @@ static CGPoint menu_mouse_point;
/* These flags will be OR'd or XOR'd with the NSWindow's styleMask
- property depending on what we're doing. */
+ property depending on what we're doing. */
#define FRAME_DECORATED_FLAGS (NSWindowStyleMaskTitled \
| NSWindowStyleMaskResizable \
| NSWindowStyleMaskMiniaturizable \
| NSWindowStyleMaskClosable)
#define FRAME_UNDECORATED_FLAGS NSWindowStyleMaskBorderless
-/* TODO: get rid of need for these forward declarations */
+/* TODO: Get rid of need for these forward declarations. */
static void ns_condemn_scroll_bars (struct frame *f);
static void ns_judge_scroll_bars (struct frame *f);
@@ -437,13 +465,6 @@ static void ns_judge_scroll_bars (struct frame *f);
========================================================================== */
void
-ns_set_represented_filename (NSString *fstr, struct frame *f)
-{
- represented_filename = [fstr retain];
- represented_frame = f;
-}
-
-void
ns_init_events (struct input_event *ev)
{
EVENT_INIT (*ev);
@@ -479,7 +500,7 @@ append2 (Lisp_Object list, Lisp_Object item)
Utility to append to a list
-------------------------------------------------------------------------- */
{
- return CALLN (Fnconc, list, list1 (item));
+ return nconc2 (list, list (item));
}
@@ -602,7 +623,7 @@ ns_load_path (void)
void
ns_init_locale (void)
/* macOS doesn't set any environment variables for the locale when run
- from the GUI. Get the locale from the OS and set LANG. */
+ from the GUI. Get the locale from the OS and set LANG. */
{
NSLocale *locale = [NSLocale currentLocale];
@@ -613,11 +634,11 @@ ns_init_locale (void)
/* It seems macOS should probably use UTF-8 everywhere.
'localeIdentifier' does not specify the encoding, and I can't
find any way to get the OS to tell us which encoding to use,
- so hard-code '.UTF-8'. */
+ so hard-code '.UTF-8'. */
NSString *localeID = [NSString stringWithFormat:@"%@.UTF-8",
[locale localeIdentifier]];
- /* Set LANG to locale, but not if LANG is already set. */
+ /* Set LANG to locale, but not if LANG is already set. */
setenv("LANG", [localeID UTF8String], 0);
}
@catch (NSException *e)
@@ -640,7 +661,7 @@ ns_release_object (void *obj)
void
ns_retain_object (void *obj)
/* --------------------------------------------------------------------------
- Retain an object (callable from C)
+ Retain an object (callable from C)
-------------------------------------------------------------------------- */
{
[(id)obj retain];
@@ -667,6 +688,40 @@ ns_release_autorelease_pool (void *pool)
}
+#ifdef NS_IMPL_COCOA
+/* Disabling screen updates can be used to make several actions appear
+ "atomic" to the end user. It seems some actions can still update
+ the display, though.
+
+ When we re-enable screen updates the number of calls to
+ NSEnableScreenUpdates should match the number to
+ NSDisableScreenUpdates.
+
+ We use these functions to prevent the user seeing a blank frame
+ after it has been resized. x_set_window_size disables updates and
+ when redisplay completes unwind_redisplay enables them again
+ (bug#30699). */
+
+static void
+ns_disable_screen_updates (void)
+{
+ NSDisableScreenUpdates ();
+ disable_screen_updates_count++;
+}
+
+void
+ns_enable_screen_updates (void)
+/* Re-enable screen updates. Called from unwind_redisplay. */
+{
+ while (disable_screen_updates_count > 0)
+ {
+ NSEnableScreenUpdates ();
+ disable_screen_updates_count--;
+ }
+}
+#endif
+
+
static BOOL
ns_menu_bar_should_be_hidden (void)
/* True, if the menu bar should be hidden. */
@@ -739,7 +794,7 @@ ns_screen_margins (NSScreen *screen)
static struct EmacsMargins
ns_screen_margins_ignoring_hidden_dock (NSScreen *screen)
/* The parts of SCREEN used by the operating system, excluding the parts
-reserved for an hidden dock. */
+ reserved for a hidden dock. */
{
NSTRACE ("ns_screen_margins_ignoring_hidden_dock");
@@ -1233,7 +1288,7 @@ ns_reset_clipping (struct frame *f)
@interface EmacsBell : NSImageView
{
- // Number of currently active bell:s.
+ // Number of currently active bells.
unsigned int nestCount;
NSView * mView;
bool isAttached;
@@ -1494,7 +1549,7 @@ x_make_frame_visible (struct frame *f)
NSTRACE ("x_make_frame_visible");
/* XXX: at some points in past this was not needed, as the only place that
called this (frame.c:Fraise_frame ()) also called raise_lower;
- if this ends up the case again, comment this out again. */
+ if this ends up the case again, comment this out again. */
if (!FRAME_VISIBLE_P (f))
{
EmacsView *view = (EmacsView *)FRAME_NS_VIEW (f);
@@ -1517,7 +1572,7 @@ x_make_frame_visible (struct frame *f)
}
/* Making a frame invisible seems to break the parent->child
- relationship, so reinstate it. */
+ relationship, so reinstate it. */
if ([window parentWindow] == nil && FRAME_PARENT_FRAME (f) != NULL)
{
NSWindow *parent = [FRAME_NS_VIEW (FRAME_PARENT_FRAME (f)) window];
@@ -1529,7 +1584,7 @@ x_make_frame_visible (struct frame *f)
/* If the parent frame moved while the child frame was
invisible, the child frame's position won't have been
- updated. Make sure it's in the right place now. */
+ updated. Make sure it's in the right place now. */
x_set_offset(f, f->left_pos, f->top_pos, 0);
}
}
@@ -1571,8 +1626,8 @@ x_iconify_frame (struct frame *f)
if ([[view window] windowNumber] <= 0)
{
- /* the window is still deferred. Make it very small, bring it
- on screen and order it out. */
+ /* The window is still deferred. Make it very small, bring it
+ on screen and order it out. */
NSRect s = { { 100, 100}, {0, 0} };
NSRect t;
t = [[view window] frame];
@@ -1583,7 +1638,7 @@ x_iconify_frame (struct frame *f)
}
/* Processing input while Emacs is being minimized can cause a
- crash, so block it for the duration. */
+ crash, so block it for the duration. */
block_input();
[[view window] miniaturize: NSApp];
unblock_input();
@@ -1617,10 +1672,6 @@ x_free_frame_resources (struct frame *f)
dpyinfo->x_highlight_frame = 0;
if (f == hlinfo->mouse_face_mouse_frame)
reset_mouse_highlight (hlinfo);
- /* Ensure that sendEvent does not attempt to dereference a freed
- frame. (bug#30800) */
- if (represented_frame == f)
- represented_frame = NULL;
if (f->output_data.ns->miniimage != nil)
[f->output_data.ns->miniimage release];
@@ -1642,7 +1693,7 @@ x_destroy_window (struct frame *f)
NSTRACE ("x_destroy_window");
/* If this frame has a parent window, detach it as not doing so can
- cause a crash in GNUStep. */
+ cause a crash in GNUStep. */
if (FRAME_PARENT_FRAME (f) != NULL)
{
NSWindow *child = [FRAME_NS_VIEW (f) window];
@@ -1664,7 +1715,6 @@ x_set_offset (struct frame *f, int xoff, int yoff, int change_grav)
-------------------------------------------------------------------------- */
{
NSView *view = FRAME_NS_VIEW (f);
- NSArray *screens = [NSScreen screens];
NSScreen *screen = [[view window] screen];
NSTRACE ("x_set_offset");
@@ -1753,6 +1803,15 @@ x_set_window_size (struct frame *f,
block_input ();
+#ifdef NS_IMPL_COCOA
+ /* To prevent showing the user a blank frame, stop updates being
+ flushed to the screen until after redisplay has completed. This
+ breaks live resize (resizing with a mouse), so don't do it if
+ we're in a live resize loop. */
+ if (![view inLiveResize])
+ ns_disable_screen_updates ();
+#endif
+
if (pixelwise)
{
pixelwidth = FRAME_TEXT_TO_PIXEL_WIDTH (f, width);
@@ -1780,11 +1839,11 @@ x_set_window_size (struct frame *f,
frame_size_history_add
(f, Qx_set_window_size_1, width, height,
- list5 (Fcons (make_number (pixelwidth), make_number (pixelheight)),
- Fcons (make_number (wr.size.width), make_number (wr.size.height)),
- make_number (f->border_width),
- make_number (FRAME_NS_TITLEBAR_HEIGHT (f)),
- make_number (FRAME_TOOLBAR_HEIGHT (f))));
+ list5 (Fcons (make_fixnum (pixelwidth), make_fixnum (pixelheight)),
+ Fcons (make_fixnum (wr.size.width), make_fixnum (wr.size.height)),
+ make_fixnum (f->border_width),
+ make_fixnum (FRAME_NS_TITLEBAR_HEIGHT (f)),
+ make_fixnum (FRAME_TOOLBAR_HEIGHT (f))));
[window setFrame: wr display: YES];
@@ -1826,7 +1885,7 @@ x_set_undecorated (struct frame *f, Lisp_Object new_value, Lisp_Object old_value
else
{
[window setToolbar: nil];
- /* Do I need to release the toolbar here? */
+ /* Do I need to release the toolbar here? */
FRAME_UNDECORATED (f) = true;
[window setStyleMask: ((window.styleMask | FRAME_UNDECORATED_FLAGS)
@@ -1834,7 +1893,7 @@ x_set_undecorated (struct frame *f, Lisp_Object new_value, Lisp_Object old_value
}
/* At this point it seems we don't have an active NSResponder,
- so some key presses (TAB) are swallowed by the system. */
+ so some key presses (TAB) are swallowed by the system. */
[window makeFirstResponder: view];
[view updateFrameSize: NO];
@@ -1925,7 +1984,7 @@ x_set_no_focus_on_map (struct frame *f, Lisp_Object new_value, Lisp_Object old_v
* displayed for the first time and when the frame changes its state
* from `iconified' or `invisible' to `visible'.)
*
- * Some window managers may not honor this parameter. */
+ * Some window managers may not honor this parameter. */
{
NSTRACE ("x_set_no_focus_on_map");
@@ -1944,7 +2003,7 @@ x_set_no_accept_focus (struct frame *f, Lisp_Object new_value, Lisp_Object old_v
* If non-nil, this may have the unwanted side-effect that a user cannot
* scroll a non-selected frame with the mouse.
*
- * Some window managers may not honor this parameter. */
+ * Some window managers may not honor this parameter. */
{
NSTRACE ("x_set_no_accept_focus");
@@ -1961,7 +2020,7 @@ x_set_z_group (struct frame *f, Lisp_Object new_value, Lisp_Object old_value)
`below' property set. If `below', F's window is displayed below
all windows that do.
- Some window managers may not honor this parameter. */
+ Some window managers may not honor this parameter. */
{
EmacsView *view = (EmacsView *)FRAME_NS_VIEW (f);
NSWindow *window = [view window];
@@ -1980,7 +2039,7 @@ x_set_z_group (struct frame *f, Lisp_Object new_value, Lisp_Object old_value)
}
else if (EQ (new_value, Qabove_suspended))
{
- /* Not sure what level this should be. */
+ /* Not sure what level this should be. */
window.level = NSNormalWindowLevel + 1;
FRAME_Z_GROUP (f) = z_group_above_suspended;
}
@@ -2058,8 +2117,7 @@ ns_fullscreen_hook (struct frame *f)
if (! [view fsIsNative] && f->want_fullscreen == FULLSCREEN_BOTH)
{
/* Old style fs don't initiate correctly if created from
- init/default-frame alist, so use a timer (not nice...).
- */
+ init/default-frame alist, so use a timer (not nice...). */
[NSTimer scheduledTimerWithTimeInterval: 0.5 target: view
selector: @selector (handleFS)
userInfo: nil repeats: NO];
@@ -2126,7 +2184,7 @@ ns_index_color (NSColor *color, struct frame *f)
color_table->colors[idx] = color;
[color retain];
-/*fprintf(stderr, "color_table: allocated %d\n",idx);*/
+ /* fprintf(stderr, "color_table: allocated %d\n",idx); */
return idx;
}
@@ -2138,7 +2196,7 @@ ns_get_color (const char *name, NSColor **col)
-------------------------------------------------------------------------- */
/* On *Step, we attempt to mimic the X11 platform here, down to installing an
X11 rgb.txt-compatible color list in Emacs.clr (see ns_term_init()).
- See: http://thread.gmane.org/gmane.emacs.devel/113050/focus=113272). */
+ See https://lists.gnu.org/r/emacs-devel/2009-07/msg01203.html. */
{
NSColor *new = nil;
static char hex[20];
@@ -2173,8 +2231,7 @@ ns_get_color (const char *name, NSColor **col)
else if ([nsname isEqualToString: @"ns_selection_fg_color"])
{
/* NOTE: macOS applications normally don't set foreground
- selection, but text may be unreadable if we don't.
- */
+ selection, but text may be unreadable if we don't. */
if ((new = [NSColor selectedTextColor]) != nil)
{
*col = [new colorUsingDefaultColorSpace];
@@ -2186,7 +2243,7 @@ ns_get_color (const char *name, NSColor **col)
name = [nsname UTF8String];
}
- /* First, check for some sort of numeric specification. */
+ /* First, check for some sort of numeric specification. */
hex[0] = '\0';
if (name[0] == '0' || name[0] == '1' || name[0] == '.') /* RGB decimal */
@@ -2236,7 +2293,7 @@ ns_get_color (const char *name, NSColor **col)
NSColorList *clist;
#ifdef NS_IMPL_GNUSTEP
- /* XXX: who is wrong, the requestor or the implementation? */
+ /* XXX: who is wrong, the requestor or the implementation? */
if ([nsname compare: @"Highlight" options: NSCaseInsensitiveSearch]
== NSOrderedSame)
nsname = @"highlightColor";
@@ -2265,7 +2322,7 @@ ns_get_color (const char *name, NSColor **col)
int
ns_lisp_to_color (Lisp_Object color, NSColor **col)
/* --------------------------------------------------------------------------
- Convert a Lisp string object to a NS color
+ Convert a Lisp string object to a NS color.
-------------------------------------------------------------------------- */
{
NSTRACE ("ns_lisp_to_color");
@@ -2276,6 +2333,22 @@ ns_lisp_to_color (Lisp_Object color, NSColor **col)
return 1;
}
+/* Convert an index into the color table into an RGBA value. Used in
+ xdisp.c:extend_face_to_end_of_line when comparing faces and frame
+ color values. */
+
+unsigned long
+ns_color_index_to_rgba(int idx, struct frame *f)
+{
+ NSColor *col;
+ col = ns_lookup_indexed_color (idx, f);
+
+ EmacsCGFloat r, g, b, a;
+ [col getRed: &r green: &g blue: &b alpha: &a];
+
+ return ARGB_TO_ULONG((int)(a*255),
+ (int)(r*255), (int)(g*255), (int)(b*255));
+}
void
ns_query_color(void *col, XColor *color_def, int setPixel)
@@ -2310,7 +2383,7 @@ ns_defined_color (struct frame *f,
If makeIndex and alloc are nonzero put the color in the color_table,
and set color_def pixel to the resulting index.
If makeIndex is zero, set color_def pixel to ARGB.
- Return false if not found
+ Return false if not found.
-------------------------------------------------------------------------- */
{
NSColor *col;
@@ -2349,8 +2422,8 @@ x_set_frame_alpha (struct frame *f)
if (FLOATP (Vframe_alpha_lower_limit))
alpha_min = XFLOAT_DATA (Vframe_alpha_lower_limit);
- else if (INTEGERP (Vframe_alpha_lower_limit))
- alpha_min = (XINT (Vframe_alpha_lower_limit)) / 100.0;
+ else if (FIXNUMP (Vframe_alpha_lower_limit))
+ alpha_min = (XFIXNUM (Vframe_alpha_lower_limit)) / 100.0;
if (alpha < 0.0)
return;
@@ -2383,7 +2456,7 @@ frame_set_mouse_pixel_position (struct frame *f, int pix_x, int pix_y)
{
NSTRACE ("frame_set_mouse_pixel_position");
- /* FIXME: what about GNUstep? */
+ /* FIXME: what about GNUstep? */
#ifdef NS_IMPL_COCOA
CGPoint mouse_pos =
CGPointMake(f->left_pos + pix_x,
@@ -2404,15 +2477,15 @@ note_mouse_movement (struct frame *frame, CGFloat x, CGFloat y)
struct ns_display_info *dpyinfo = FRAME_DISPLAY_INFO (frame);
NSRect *r;
-// NSTRACE ("note_mouse_movement");
+ // NSTRACE ("note_mouse_movement");
dpyinfo->last_mouse_motion_frame = frame;
r = &dpyinfo->last_mouse_glyph;
/* Note, this doesn't get called for enter/leave, since we don't have a
- position. Those are taken care of in the corresponding NSView methods. */
+ position. Those are taken care of in the corresponding NSView methods. */
- /* has movement gone beyond last rect we were tracking? */
+ /* Has movement gone beyond last rect we were tracking? */
if (x < r->origin.x || x >= r->origin.x + r->size.width
|| y < r->origin.y || y >= r->origin.y + r->size.height)
{
@@ -2436,7 +2509,7 @@ ns_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window,
External (hook): inform emacs about mouse position and hit parts.
If a scrollbar is being dragged, set bar_window, part, x, y, time.
x & y should be position in the scrollbar (the whole bar, not the handle)
- and length of scrollbar respectively
+ and length of scrollbar respectively.
-------------------------------------------------------------------------- */
{
id view;
@@ -2555,7 +2628,7 @@ ns_convert_key (unsigned code)
{
const unsigned last_keysym = ARRAYELTS (convert_ns_to_X_keysym);
unsigned keysym;
- /* An array would be faster, but less easy to read. */
+ /* An array would be faster, but less easy to read. */
for (keysym = 0; keysym < last_keysym; keysym += 2)
if (code == convert_ns_to_X_keysym[keysym])
return 0xFF00 | convert_ns_to_X_keysym[keysym+1];
@@ -2578,7 +2651,78 @@ x_get_keysym_name (int keysym)
return value;
}
+#ifdef NS_IMPL_COCOA
+static UniChar
+ns_get_shifted_character (NSEvent *event)
+/* Look up the character corresponding to the key pressed on the
+ current keyboard layout and the currently configured shift-like
+ modifiers. This ignores the control-like modifiers that cause
+ [event characters] to give us the wrong result.
+
+ Although UCKeyTranslate doesn't require the Carbon framework, some
+ of the surrounding paraphernalia does, so this function makes
+ Carbon a requirement. */
+{
+ static UInt32 dead_key_state;
+
+ /* UCKeyTranslate may return up to 255 characters. If the buffer
+ isn't large enough then it produces an error. What kind of
+ keyboard inputs 255 characters in a single keypress? */
+ UniChar buf[255];
+ UniCharCount max_string_length = 255;
+ UniCharCount actual_string_length = 0;
+ OSStatus result;
+
+ CFDataRef layout_ref = (CFDataRef) TISGetInputSourceProperty
+ (TISCopyCurrentKeyboardLayoutInputSource (), kTISPropertyUnicodeKeyLayoutData);
+ UCKeyboardLayout* layout = (UCKeyboardLayout*) CFDataGetBytePtr (layout_ref);
+
+ UInt32 flags = [event modifierFlags];
+ UInt32 modifiers = (flags & NSEventModifierFlagShift) ? shiftKey : 0;
+
+ NSTRACE ("ns_get_shifted_character");
+
+ if ((flags & NSRightAlternateKeyMask) == NSRightAlternateKeyMask
+ && (EQ (ns_right_alternate_modifier, Qnone)
+ || (EQ (ns_right_alternate_modifier, Qleft)
+ && EQ (ns_alternate_modifier, Qnone))))
+ modifiers |= rightOptionKey;
+
+ if ((flags & NSLeftAlternateKeyMask) == NSLeftAlternateKeyMask
+ && EQ (ns_alternate_modifier, Qnone))
+ modifiers |= optionKey;
+
+ if ((flags & NSRightCommandKeyMask) == NSRightCommandKeyMask
+ && (EQ (ns_right_command_modifier, Qnone)
+ || (EQ (ns_right_command_modifier, Qleft)
+ && EQ (ns_command_modifier, Qnone))))
+ /* Carbon doesn't differentiate between left and right command
+ keys. */
+ modifiers |= cmdKey;
+
+ if ((flags & NSLeftCommandKeyMask) == NSLeftCommandKeyMask
+ && EQ (ns_command_modifier, Qnone))
+ modifiers |= cmdKey;
+
+ result = UCKeyTranslate (layout, [event keyCode], kUCKeyActionDown,
+ (modifiers >> 8) & 0xFF, LMGetKbdType (),
+ kUCKeyTranslateNoDeadKeysBit, &dead_key_state,
+ max_string_length, &actual_string_length, buf);
+
+ if (result != 0)
+ {
+ NSLog(@"Failed to translate character '%@' with modifiers %x",
+ [event characters], modifiers);
+ return 0;
+ }
+ /* FIXME: What do we do if more than one code unit is returned? */
+ if (actual_string_length > 0)
+ return buf[0];
+
+ return 0;
+}
+#endif /* NS_IMPL_COCOA */
/* ==========================================================================
@@ -2698,7 +2842,7 @@ ns_copy_bits (struct frame *f, NSRect src, NSRect dest)
static void
ns_scroll_run (struct window *w, struct run *run)
/* --------------------------------------------------------------------------
- External (RIF): Insert or delete n lines at line vpos
+ External (RIF): Insert or delete n lines at line vpos.
-------------------------------------------------------------------------- */
{
struct frame *f = XFRAME (w->frame);
@@ -2978,7 +3122,6 @@ ns_draw_fringe_bitmap (struct window *w, struct glyph_row *row,
[img setXBMColor: bm_color];
}
-#ifdef NS_IMPL_COCOA
// Note: For periodic images, the full image height is "h + hd".
// By using the height h, a suitable part of the image is used.
NSRect fromRect = NSMakeRect(0, 0, p->wd, p->h);
@@ -2991,13 +3134,6 @@ ns_draw_fringe_bitmap (struct window *w, struct glyph_row *row,
fraction: 1.0
respectFlipped: YES
hints: nil];
-#else
- {
- NSPoint pt = imageRect.origin;
- pt.y += p->h;
- [img compositeToPoint: pt operation: NSCompositingOperationSourceOver];
- }
-#endif
}
ns_reset_clipping (f);
}
@@ -3057,17 +3193,17 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row,
get_phys_cursor_geometry (w, glyph_row, phys_cursor_glyph, &fx, &fy, &h);
/* The above get_phys_cursor_geometry call set w->phys_cursor_width
- to the glyph width; replace with CURSOR_WIDTH for (V)BAR cursors. */
+ to the glyph width; replace with CURSOR_WIDTH for (V)BAR cursors. */
if (cursor_type == BAR_CURSOR)
{
if (cursor_width < 1)
cursor_width = max (FRAME_CURSOR_WIDTH (f), 1);
- /* The bar cursor should never be wider than the glyph. */
+ /* The bar cursor should never be wider than the glyph. */
if (cursor_width < w->phys_cursor_width)
w->phys_cursor_width = cursor_width;
}
- /* If we have an HBAR, "cursor_width" MAY specify height. */
+ /* If we have an HBAR, "cursor_width" MAY specify height. */
else if (cursor_type == HBAR_CURSOR)
{
cursor_height = (cursor_width < 1) ? lrint (0.25 * h) : cursor_width;
@@ -3126,8 +3262,9 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row,
break;
}
- /* draw the character under the cursor */
- if (cursor_type != NO_CURSOR)
+ /* Draw the character under the cursor. Other terms only draw
+ the character on top of box cursors, so do the same here. */
+ if (cursor_type == FILLED_BOX_CURSOR || cursor_type == HOLLOW_BOX_CURSOR)
draw_phys_cursor_glyph (w, glyph_row, DRAW_CURSOR);
ns_reset_clipping (f);
@@ -3319,7 +3456,7 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face,
if (s->for_overlaps)
return;
- /* Do underline. */
+ /* Do underline. */
if (face->underline_p)
{
if (s->face->underline_type == FACE_UNDER_WAVE)
@@ -3337,7 +3474,7 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face,
NSRect r;
unsigned long thickness, position;
- /* If the prev was underlined, match its appearance. */
+ /* If the prev was underlined, match its appearance. */
if (s->prev && s->prev->face->underline_p
&& s->prev->face->underline_type == FACE_UNDER_LINE
&& s->prev->underline_thickness > 0)
@@ -3349,25 +3486,40 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face,
{
struct font *font = font_for_underline_metrics (s);
unsigned long descent = s->y + s->height - s->ybase;
-
- /* Use underline thickness of font, defaulting to 1. */
+ unsigned long minimum_offset;
+ BOOL underline_at_descent_line, use_underline_position_properties;
+ Lisp_Object val = buffer_local_value (Qunderline_minimum_offset,
+ s->w->contents);
+ if (FIXNUMP (val))
+ minimum_offset = XFIXNAT (val);
+ else
+ minimum_offset = 1;
+ val = buffer_local_value (Qx_underline_at_descent_line,
+ s->w->contents);
+ underline_at_descent_line = !(NILP (val) || EQ (val, Qunbound));
+ val = buffer_local_value (Qx_use_underline_position_properties,
+ s->w->contents);
+ use_underline_position_properties =
+ !(NILP (val) || EQ (val, Qunbound));
+
+ /* Use underline thickness of font, defaulting to 1. */
thickness = (font && font->underline_thickness > 0)
? font->underline_thickness : 1;
- /* Determine the offset of underlining from the baseline. */
- if (x_underline_at_descent_line)
+ /* Determine the offset of underlining from the baseline. */
+ if (underline_at_descent_line)
position = descent - thickness;
- else if (x_use_underline_position_properties
+ else if (use_underline_position_properties
&& font && font->underline_position >= 0)
position = font->underline_position;
else if (font)
position = lround (font->descent / 2);
else
- position = underline_minimum_offset;
+ position = minimum_offset;
- position = max (position, underline_minimum_offset);
+ position = max (position, minimum_offset);
- /* Ensure underlining is not cropped. */
+ /* Ensure underlining is not cropped. */
if (descent <= position)
{
position = descent - 1;
@@ -3390,7 +3542,7 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face,
}
}
/* Do overline. We follow other terms in using a thickness of 1
- and ignoring overline_margin. */
+ and ignoring overline_margin. */
if (face->overline_p)
{
NSRect r;
@@ -3404,7 +3556,7 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face,
}
/* Do strike-through. We follow other terms for thickness and
- vertical position.*/
+ vertical position. */
if (face->strike_through_p)
{
NSRect r;
@@ -3511,7 +3663,7 @@ ns_draw_relief (NSRect r, int thickness, char raised_p,
[(raised_p ? lightCol : darkCol) set];
- /* TODO: mitering. Using NSBezierPath doesn't work because of color switch. */
+ /* TODO: mitering. Using NSBezierPath doesn't work because of color switch. */
/* top */
sr.size.height = thickness;
@@ -3585,7 +3737,7 @@ ns_dumpglyphs_box_or_relief (struct glyph_string *s)
r = NSMakeRect (s->x, s->y, right_x - s->x + 1, s->height);
- /* TODO: Sometimes box_color is 0 and this seems wrong; should investigate. */
+ /* TODO: Sometimes box_color is 0 and this seems wrong; should investigate. */
if (s->face->box == FACE_SIMPLE_BOX && s->face->box_color)
{
ns_draw_box (r, abs (thickness),
@@ -3688,7 +3840,7 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r)
/* Draw BG: if we need larger area than image itself cleared, do that,
otherwise, since we composite the image under NS (instead of mucking
- with its background color), we must clear just the image area. */
+ with its background color), we must clear just the image area. */
if (s->hl == DRAW_MOUSE_FACE)
{
face = FACE_FROM_ID_OR_NULL (s->f,
@@ -3714,7 +3866,7 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r)
NSRectFill (br);
- /* Draw the image.. do we need to draw placeholder if img ==nil? */
+ /* Draw the image... do we need to draw placeholder if img == nil? */
if (img != nil)
{
#ifdef NS_IMPL_COCOA
@@ -3740,11 +3892,11 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r)
if (s->w->phys_cursor_type == FILLED_BOX_CURSOR)
tdCol = ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f);
else
- /* Currently on NS img->mask is always 0. Since
+ /* Currently on NS img->mask is always 0. Since
get_window_cursor_type specifies a hollow box cursor when on
- a non-masked image we never reach this clause. But we put it
+ a non-masked image we never reach this clause. But we put it
in, in anticipation of better support for image masks on
- NS. */
+ NS. */
tdCol = ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), s->f);
}
else
@@ -3752,7 +3904,7 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r)
tdCol = ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), s->f);
}
- /* Draw underline, overline, strike-through. */
+ /* Draw underline, overline, strike-through. */
ns_draw_text_decoration (s, face, tdCol, br.size.width, br.origin.x);
/* Draw relief, if requested */
@@ -3760,8 +3912,9 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r)
{
if (s->hl == DRAW_IMAGE_SUNKEN || s->hl == DRAW_IMAGE_RAISED)
{
- th = tool_bar_button_relief >= 0 ?
- tool_bar_button_relief : DEFAULT_TOOL_BAR_BUTTON_RELIEF;
+ th = (tool_bar_button_relief < 0
+ ? DEFAULT_TOOL_BAR_BUTTON_RELIEF
+ : min (tool_bar_button_relief, 1000000));
raised_p = (s->hl == DRAW_IMAGE_RAISED);
}
else
@@ -4148,7 +4301,7 @@ ns_draw_glyph_string (struct glyph_string *s)
emacs_abort ();
}
- /* Draw box if not done already. */
+ /* Draw box if not done already. */
if (!s->for_overlaps && !box_drawn_p && s->face->box != FACE_NO_BOX)
{
n = ns_get_glyph_string_clip_rect (s, r);
@@ -4193,8 +4346,8 @@ ns_send_appdefined (int value)
}
/* Only post this event if we haven't already posted one. This will end
- the [NXApp run] main loop after having processed all events queued at
- this moment. */
+ the [NXApp run] main loop after having processed all events queued at
+ this moment. */
#ifdef NS_IMPL_COCOA
if (! send_appdefined)
@@ -4217,7 +4370,7 @@ ns_send_appdefined (int value)
/* We only need one NX_APPDEFINED event to stop NXApp from running. */
send_appdefined = NO;
- /* Don't need wakeup timer any more */
+ /* Don't need wakeup timer any more. */
if (timed_entry)
{
[timed_entry invalidate];
@@ -4271,7 +4424,7 @@ check_native_fs ()
void
ns_check_menu_open (NSMenu *menu)
{
- /* Click in menu bar? */
+ /* Click in menu bar? */
NSArray *a = [[NSApp mainMenu] itemArray];
int i;
BOOL found = NO;
@@ -4367,19 +4520,19 @@ ns_read_socket (struct terminal *terminal, struct input_event *hold_quit)
ns_init_events (&ev);
q_event_ptr = hold_quit;
- /* we manage autorelease pools by allocate/reallocate each time around
+ /* We manage autorelease pools by allocate/reallocate each time around
the loop; strict nesting is occasionally violated but seems not to
- matter.. earlier methods using full nesting caused major memory leaks */
+ matter... earlier methods using full nesting caused major memory leaks. */
[outerpool release];
outerpool = [[NSAutoreleasePool alloc] init];
- /* If have pending open-file requests, attend to the next one of those. */
+ /* If have pending open-file requests, attend to the next one of those. */
if (ns_pending_files && [ns_pending_files count] != 0
&& [(EmacsApp *)NSApp openFile: [ns_pending_files objectAtIndex: 0]])
{
[ns_pending_files removeObjectAtIndex: 0];
}
- /* Deal with pending service requests. */
+ /* Deal with pending service requests. */
else if (ns_pending_service_names && [ns_pending_service_names count] != 0
&& [(EmacsApp *)
NSApp fulfillService: [ns_pending_service_names objectAtIndex: 0]
@@ -4432,7 +4585,7 @@ ns_select (int nfds, fd_set *readfds, fd_set *writefds,
if (hold_event_q.nr > 0)
{
- /* We already have events pending. */
+ /* We already have events pending. */
raise (SIGIO);
errno = EINTR;
return -1;
@@ -4484,13 +4637,13 @@ ns_select (int nfds, fd_set *readfds, fd_set *writefds,
pthread_mutex_unlock (&select_mutex);
- /* Inform fd_handler that select should be called */
+ /* Inform fd_handler that select should be called. */
c = 'g';
emacs_write_sig (selfds[1], &c, 1);
}
else if (nr == 0 && timeout)
{
- /* No file descriptor, just a timeout, no need to wake fd_handler */
+ /* No file descriptor, just a timeout, no need to wake fd_handler. */
double time = timespectod (*timeout);
timed_entry = [[NSTimer scheduledTimerWithTimeInterval: time
target: NSApp
@@ -4502,7 +4655,7 @@ ns_select (int nfds, fd_set *readfds, fd_set *writefds,
}
else /* No timeout and no file descriptors, can this happen? */
{
- /* Send appdefined so we exit from the loop */
+ /* Send appdefined so we exit from the loop. */
ns_send_appdefined (-1);
}
@@ -4527,7 +4680,7 @@ ns_select (int nfds, fd_set *readfds, fd_set *writefds,
if (t == -2)
{
- /* The NX_APPDEFINED event we received was a timeout. */
+ /* The NX_APPDEFINED event we received was a timeout. */
result = 0;
}
else if (t == -1)
@@ -4539,7 +4692,7 @@ ns_select (int nfds, fd_set *readfds, fd_set *writefds,
}
else
{
- /* Received back from select () in fd_handler; copy the results */
+ /* Received back from select () in fd_handler; copy the results. */
pthread_mutex_lock (&select_mutex);
if (readfds) *readfds = select_readfds;
if (writefds) *writefds = select_writefds;
@@ -4559,11 +4712,11 @@ ns_select (int nfds, fd_set *readfds, fd_set *writefds,
#ifdef HAVE_PTHREAD
void
ns_run_loop_break ()
-/* Break out of the NS run loop in ns_select or ns_read_socket. */
+/* Break out of the NS run loop in ns_select or ns_read_socket. */
{
NSTRACE_WHEN (NSTRACE_GROUP_EVENTS, "ns_run_loop_break");
- /* If we don't have a GUI, don't send the event. */
+ /* If we don't have a GUI, don't send the event. */
if (NSApp != NULL)
ns_send_appdefined(-1);
}
@@ -4593,7 +4746,7 @@ ns_set_vertical_scroll_bar (struct window *window,
int top, left, height, width;
BOOL update_p = YES;
- /* optimization; display engine sends WAY too many of these.. */
+ /* Optimization; display engine sends WAY too many of these. */
if (!NILP (window->vertical_scroll_bar))
{
bar = XNS_SCROLL_BAR (window->vertical_scroll_bar);
@@ -4620,14 +4773,14 @@ ns_set_vertical_scroll_bar (struct window *window,
left = WINDOW_SCROLL_BAR_AREA_X (window);
r = NSMakeRect (left, top, width, height);
- /* the parent view is flipped, so we need to flip y value */
+ /* The parent view is flipped, so we need to flip y value. */
v = [view frame];
r.origin.y = (v.size.height - r.size.height - r.origin.y);
XSETWINDOW (win, window);
block_input ();
- /* we want at least 5 lines to display a scrollbar */
+ /* We want at least 5 lines to display a scrollbar. */
if (WINDOW_TOTAL_LINES (window) < 5)
{
if (!NILP (window->vertical_scroll_bar))
@@ -4648,7 +4801,7 @@ ns_set_vertical_scroll_bar (struct window *window,
ns_clear_frame_area (f, left, top, width, height);
bar = [[EmacsScroller alloc] initFrame: r window: win];
- wset_vertical_scroll_bar (window, make_save_ptr (bar));
+ wset_vertical_scroll_bar (window, make_mint_ptr (bar));
update_p = YES;
}
else
@@ -4675,7 +4828,7 @@ static void
ns_set_horizontal_scroll_bar (struct window *window,
int portion, int whole, int position)
/* --------------------------------------------------------------------------
- External (hook): Update or add scrollbar
+ External (hook): Update or add scrollbar.
-------------------------------------------------------------------------- */
{
Lisp_Object win;
@@ -4687,7 +4840,7 @@ ns_set_horizontal_scroll_bar (struct window *window,
int window_x, window_width;
BOOL update_p = YES;
- /* optimization; display engine sends WAY too many of these.. */
+ /* Optimization; display engine sends WAY too many of these. */
if (!NILP (window->horizontal_scroll_bar))
{
bar = XNS_SCROLL_BAR (window->horizontal_scroll_bar);
@@ -4714,7 +4867,7 @@ ns_set_horizontal_scroll_bar (struct window *window,
top = WINDOW_SCROLL_BAR_AREA_Y (window);
r = NSMakeRect (left, top, width, height);
- /* the parent view is flipped, so we need to flip y value */
+ /* The parent view is flipped, so we need to flip y value. */
v = [view frame];
r.origin.y = (v.size.height - r.size.height - r.origin.y);
@@ -4727,7 +4880,7 @@ ns_set_horizontal_scroll_bar (struct window *window,
ns_clear_frame_area (f, left, top, width, height);
bar = [[EmacsScroller alloc] initFrame: r window: win];
- wset_horizontal_scroll_bar (window, make_save_ptr (bar));
+ wset_horizontal_scroll_bar (window, make_mint_ptr (bar));
update_p = YES;
}
else
@@ -4746,7 +4899,7 @@ ns_set_horizontal_scroll_bar (struct window *window,
/* If there are both horizontal and vertical scroll-bars they leave
a square that belongs to neither. We need to clear it otherwise
- it fills with junk. */
+ it fills with junk. */
if (!NILP (window->vertical_scroll_bar))
ns_clear_frame_area (f, WINDOW_SCROLL_BAR_AREA_X (window), top,
NS_SCROLL_BAR_HEIGHT (f), height);
@@ -4869,7 +5022,7 @@ x_display_pixel_width (struct ns_display_info *dpyinfo)
static Lisp_Object ns_string_to_lispmod (const char *s)
/* --------------------------------------------------------------------------
- Convert modifier name to lisp symbol
+ Convert modifier name to lisp symbol.
-------------------------------------------------------------------------- */
{
if (!strncmp (SSDATA (SYMBOL_NAME (Qmeta)), s, 10))
@@ -4894,7 +5047,7 @@ ns_default (const char *parameter, Lisp_Object *result,
Lisp_Object yesval, Lisp_Object noval,
BOOL is_float, BOOL is_modstring)
/* --------------------------------------------------------------------------
- Check a parameter value in user's preferences
+ Check a parameter value in user's preferences.
-------------------------------------------------------------------------- */
{
const char *value = ns_get_defaults_value (parameter);
@@ -4935,7 +5088,7 @@ ns_initialize_display_info (struct ns_display_info *dpyinfo)
dpyinfo->n_planes = NSBitsPerPixelFromDepth (depth);
dpyinfo->color_table = xmalloc (sizeof *dpyinfo->color_table);
dpyinfo->color_table->colors = NULL;
- dpyinfo->root_window = 42; /* a placeholder.. */
+ dpyinfo->root_window = 42; /* A placeholder. */
dpyinfo->x_highlight_frame = dpyinfo->x_focus_frame = NULL;
dpyinfo->n_fonts = 0;
dpyinfo->smallest_font_height = 1;
@@ -4945,11 +5098,11 @@ ns_initialize_display_info (struct ns_display_info *dpyinfo)
}
-/* This and next define (many of the) public functions in this file. */
+/* This and next define (many of the) public functions in this file. */
/* x_... are generic versions in xdisp.c that we, and other terms, get away
with using despite presence in the "system dependent" redisplay
interface. In addition, many of the ns_ methods have code that is
- shared with all terms, indicating need for further refactoring. */
+ shared with all terms, indicating need for further refactoring. */
extern frame_parm_handler ns_frame_parm_handlers[];
static struct redisplay_interface ns_redisplay_interface =
{
@@ -4985,11 +5138,11 @@ static struct redisplay_interface ns_redisplay_interface =
static void
ns_delete_display (struct ns_display_info *dpyinfo)
{
- /* TODO... */
+ /* TODO... */
}
-/* This function is called when the last frame on a display is deleted. */
+/* This function is called when the last frame on a display is deleted. */
static void
ns_delete_terminal (struct terminal *terminal)
{
@@ -5097,9 +5250,9 @@ ns_term_init (Lisp_Object display_name)
ns_pending_service_names = [[NSMutableArray alloc] init];
ns_pending_service_args = [[NSMutableArray alloc] init];
-/* Start app and create the main menu, window, view.
+ /* Start app and create the main menu, window, view.
Needs to be here because ns_initialize_display_info () uses AppKit classes.
- The view will then ask the NSApp to stop and return to Emacs. */
+ The view will then ask the NSApp to stop and return to Emacs. */
[EmacsApp sharedApplication];
if (NSApp == nil)
return NULL;
@@ -5171,7 +5324,7 @@ ns_term_init (Lisp_Object display_name)
{
color = XCAR (color_map);
name = SSDATA (XCAR (color));
- c = XINT (XCDR (color));
+ c = XFIXNUM (XCDR (color));
[cl setColor:
[NSColor colorForEmacsRed: RED_FROM_ULONG (c) / 255.0
green: GREEN_FROM_ULONG (c) / 255.0
@@ -5203,7 +5356,7 @@ ns_term_init (Lisp_Object display_name)
#ifdef NS_IMPL_GNUSTEP
Vwindow_system_version = build_string (gnustep_base_version);
#else
- /*PSnextrelease (128, c); */
+ /* PSnextrelease (128, c); */
char c[DBL_BUFSIZE_BOUND];
int len = dtoastr (c, sizeof c, 0, 0, NSAppKitVersionNumber);
Vwindow_system_version = make_unibyte_string (c, len);
@@ -5289,7 +5442,7 @@ ns_term_init (Lisp_Object display_name)
#endif /* macOS menu setup */
/* Register our external input/output types, used for determining
- applicable services and also drag/drop eligibility. */
+ applicable services and also drag/drop eligibility. */
NSTRACE_MSG ("Input/output types");
@@ -5454,23 +5607,6 @@ ns_term_shutdown (int sig)
}
#endif
- if (represented_filename != nil && represented_frame)
- {
- NSString *fstr = represented_filename;
- NSView *view = FRAME_NS_VIEW (represented_frame);
-#ifdef NS_IMPL_COCOA
- /* work around a bug observed on 10.3 and later where
- setTitleWithRepresentedFilename does not clear out previous state
- if given filename does not exist */
- if (! [[NSFileManager defaultManager] fileExistsAtPath: fstr])
- [[view window] setRepresentedFilename: @""];
-#endif
- [[view window] setRepresentedFilename: fstr];
- [represented_filename release];
- represented_filename = nil;
- represented_frame = NULL;
- }
-
if (type == NSEventTypeApplicationDefined)
{
switch ([theEvent data2])
@@ -5499,7 +5635,7 @@ ns_term_shutdown (int sig)
/* Events posted by ns_send_appdefined interrupt the run loop here.
But, if a modal window is up, an appdefined can still come through,
(e.g., from a makeKeyWindow event) but stopping self also stops the
- modal loop. Just defer it until later. */
+ modal loop. Just defer it until later. */
if ([NSApp modalWindow] == nil)
{
last_appdefined_event_data = [theEvent data1];
@@ -5564,7 +5700,7 @@ ns_term_shutdown (int sig)
}
-/* Open a file (used by below, after going into queue read by ns_read_socket) */
+/* Open a file (used by below, after going into queue read by ns_read_socket). */
- (BOOL) openFile: (NSString *)fileName
{
NSTRACE ("[EmacsApp openFile:]");
@@ -5594,7 +5730,7 @@ ns_term_shutdown (int sig)
- (void)applicationDidFinishLaunching: (NSNotification *)notification
/* --------------------------------------------------------------------------
- When application is loaded, terminate event loop in ns_term_init
+ When application is loaded, terminate event loop in ns_term_init.
-------------------------------------------------------------------------- */
{
NSTRACE ("[EmacsApp applicationDidFinishLaunching:]");
@@ -5617,7 +5753,7 @@ ns_term_shutdown (int sig)
if ([NSApp activationPolicy] == NSApplicationActivationPolicyProhibited) {
/* Set the app's activation policy to regular when we run outside
of a bundle. This is already done for us by Info.plist when we
- run inside a bundle. */
+ run inside a bundle. */
[NSApp setActivationPolicy:NSApplicationActivationPolicyRegular];
[NSApp setApplicationIconImage:
[EmacsImage
@@ -5721,7 +5857,7 @@ not_in_argv (NSString *arg)
return 1;
}
-/* Notification from the Workspace to open a file */
+/* Notification from the Workspace to open a file. */
- (BOOL)application: sender openFile: (NSString *)file
{
if (ns_do_open_file || not_in_argv (file))
@@ -5730,7 +5866,7 @@ not_in_argv (NSString *arg)
}
-/* Open a file as a temporary file */
+/* Open a file as a temporary file. */
- (BOOL)application: sender openTempFile: (NSString *)file
{
if (ns_do_open_file || not_in_argv (file))
@@ -5739,7 +5875,7 @@ not_in_argv (NSString *arg)
}
-/* Notification from the Workspace to open a file noninteractively (?) */
+/* Notification from the Workspace to open a file noninteractively (?). */
- (BOOL)application: sender openFileWithoutUI: (NSString *)file
{
if (ns_do_open_file || not_in_argv (file))
@@ -5747,7 +5883,7 @@ not_in_argv (NSString *arg)
return YES;
}
-/* Notification from the Workspace to open multiple files */
+/* Notification from the Workspace to open multiple files. */
- (void)application: sender openFiles: (NSArray *)fileList
{
NSEnumerator *files = [fileList objectEnumerator];
@@ -5771,11 +5907,11 @@ not_in_argv (NSString *arg)
}
-/* TODO: these may help w/IO switching btwn terminal and NSApp */
+/* TODO: these may help w/IO switching between terminal and NSApp. */
- (void)applicationWillBecomeActive: (NSNotification *)notification
{
NSTRACE ("[EmacsApp applicationWillBecomeActive:]");
- //ns_app_active=YES;
+ // ns_app_active=YES;
}
- (void)applicationDidBecomeActive: (NSNotification *)notification
@@ -5786,7 +5922,7 @@ not_in_argv (NSString *arg)
if (! applicationDidFinishLaunchingCalled)
[self applicationDidFinishLaunching:notification];
#endif
- //ns_app_active=YES;
+ // ns_app_active=YES;
ns_update_auto_hide_menu_bar ();
// No constraining takes place when the application is not active.
@@ -5796,7 +5932,7 @@ not_in_argv (NSString *arg)
{
NSTRACE ("[EmacsApp applicationDidResignActive:]");
- //ns_app_active=NO;
+ // ns_app_active=NO;
ns_send_appdefined (-1);
}
@@ -5814,7 +5950,7 @@ not_in_argv (NSString *arg)
The timeout specified to ns_select has passed.
-------------------------------------------------------------------------- */
{
- /*NSTRACE ("timeout_handler"); */
+ /* NSTRACE ("timeout_handler"); */
ns_send_appdefined (-2);
}
@@ -5825,7 +5961,7 @@ not_in_argv (NSString *arg)
- (void)fd_handler:(id)unused
/* --------------------------------------------------------------------------
- Check data waiting on file descriptors and terminate if so
+ Check data waiting on file descriptors and terminate if so.
-------------------------------------------------------------------------- */
{
int result;
@@ -5920,7 +6056,7 @@ not_in_argv (NSString *arg)
========================================================================== */
-/* called from system: queue for next pass through event loop */
+/* Called from system: queue for next pass through event loop. */
- (void)requestService: (NSPasteboard *)pboard
userData: (NSString *)userData
error: (NSString **)error
@@ -5931,7 +6067,7 @@ not_in_argv (NSString *arg)
}
-/* called from ns_read_socket to clear queue */
+/* Called from ns_read_socket to clear queue. */
- (BOOL)fulfillService: (NSString *)name withArg: (NSString *)arg
{
struct frame *emacsframe = SELECTED_FRAME ();
@@ -5956,7 +6092,6 @@ not_in_argv (NSString *arg)
@end /* EmacsApp */
-
/* ==========================================================================
EmacsView implementation
@@ -5966,7 +6101,7 @@ not_in_argv (NSString *arg)
@implementation EmacsView
-/* needed to inform when window closed from LISP */
+/* Needed to inform when window closed from lisp. */
- (void) setWindowClosing: (BOOL)closing
{
NSTRACE ("[EmacsView setWindowClosing:%d]", closing);
@@ -5985,7 +6120,7 @@ not_in_argv (NSString *arg)
}
-/* called on font panel selection */
+/* Called on font panel selection. */
- (void)changeFont: (id)sender
{
NSEvent *e = [[self window] currentEvent];
@@ -6016,7 +6151,7 @@ not_in_argv (NSString *arg)
emacs_event->code = KEY_NS_CHANGE_FONT;
size = [newFont pointSize];
- ns_input_fontsize = make_number (lrint (size));
+ ns_input_fontsize = make_fixnum (lrint (size));
ns_input_font = build_string ([[newFont familyName] UTF8String]);
EV_TRAILER (e);
}
@@ -6041,13 +6176,19 @@ not_in_argv (NSString *arg)
if (!NSIsEmptyRect (visible))
[self addCursorRect: visible cursor: currentCursor];
- [currentCursor setOnMouseEntered: YES];
+
+#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101300
+#if MAC_OS_X_VERSION_MAX_ALLOWED >= 101300
+ if ([currentCursor respondsToSelector: @selector(setOnMouseEntered)])
+#endif
+ [currentCursor setOnMouseEntered: YES];
+#endif
}
/*****************************************************************************/
-/* Keyboard handling. */
+/* Keyboard handling. */
#define NS_KEYLOG 0
- (void)keyDown: (NSEvent *)theEvent
@@ -6056,12 +6197,11 @@ not_in_argv (NSString *arg)
int code;
unsigned fnKeysym = 0;
static NSMutableArray *nsEvArray;
- int left_is_none;
unsigned int flags = [theEvent modifierFlags];
NSTRACE ("[EmacsView keyDown:]");
- /* Rhapsody and macOS give up and down events for the arrow keys */
+ /* Rhapsody and macOS give up and down events for the arrow keys. */
if (ns_fake_keydown == YES)
ns_fake_keydown = NO;
else if ([theEvent type] != NSEventTypeKeyDown)
@@ -6072,7 +6212,7 @@ not_in_argv (NSString *arg)
if (![[self window] isKeyWindow]
&& [[theEvent window] isKindOfClass: [EmacsWindow class]]
- /* we must avoid an infinite loop here. */
+ /* We must avoid an infinite loop here. */
&& (EmacsView *)[[theEvent window] delegate] != self)
{
/* XXX: There is an occasional condition in which, when Emacs display
@@ -6080,7 +6220,7 @@ not_in_argv (NSString *arg)
selects it, then processes some interrupt-driven input
(dispnew.c:3878), OS will send the event to the correct NSWindow, but
for some reason that window has its first responder set to the NSView
- most recently updated (I guess), which is not the correct one. */
+ most recently updated (I guess), which is not the correct one. */
[(EmacsView *)[[theEvent window] delegate] keyDown: theEvent];
return;
}
@@ -6090,7 +6230,7 @@ not_in_argv (NSString *arg)
[NSCursor setHiddenUntilMouseMoves: YES];
- if (hlinfo->mouse_face_hidden && INTEGERP (Vmouse_highlight))
+ if (hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight))
{
clear_mouse_face (hlinfo);
hlinfo->mouse_face_hidden = 1;
@@ -6098,19 +6238,14 @@ not_in_argv (NSString *arg)
if (!processingCompose)
{
- /* When using screen sharing, no left or right information is sent,
- so use Left key in those cases. */
- int is_left_key, is_right_key;
-
+ /* FIXME: What should happen for key sequences with more than
+ one character? */
code = ([[theEvent charactersIgnoringModifiers] length] == 0) ?
0 : [[theEvent charactersIgnoringModifiers] characterAtIndex: 0];
- /* (Carbon way: [theEvent keyCode]) */
-
- /* is it a "function key"? */
+ /* Is it a "function key"? */
/* Note: Sometimes a plain key will have the NSEventModifierFlagNumericPad
- flag set (this is probably a bug in the OS).
- */
+ flag set (this is probably a bug in the OS). */
if (code < 0x00ff && (flags&NSEventModifierFlagNumericPad))
{
fnKeysym = ns_convert_key ([theEvent keyCode] | NSEventModifierFlagNumericPad);
@@ -6123,14 +6258,13 @@ not_in_argv (NSString *arg)
if (fnKeysym)
{
/* COUNTERHACK: map 'Delete' on upper-right main KB to 'Backspace',
- because Emacs treats Delete and KP-Delete same (in simple.el). */
+ because Emacs treats Delete and KP-Delete same (in simple.el). */
if ((fnKeysym == 0xFFFF && [theEvent keyCode] == 0x33)
#ifdef NS_IMPL_GNUSTEP
/* GNUstep uses incompatible keycodes, even for those that are
supposed to be hardware independent. Just check for delete.
Keypad delete does not have keysym 0xFFFF.
- See https://savannah.gnu.org/bugs/?25395
- */
+ See https://savannah.gnu.org/bugs/?25395 */
|| (fnKeysym == 0xFFFF && code == 127)
#endif
)
@@ -6139,142 +6273,65 @@ not_in_argv (NSString *arg)
code = fnKeysym;
}
- /* are there modifiers? */
- emacs_event->modifiers = 0;
-
- if (flags & NSEventModifierFlagHelp)
- emacs_event->modifiers |= hyper_modifier;
-
- if (flags & NSEventModifierFlagShift)
- emacs_event->modifiers |= shift_modifier;
-
- is_right_key = (flags & NSRightCommandKeyMask) == NSRightCommandKeyMask;
- is_left_key = (flags & NSLeftCommandKeyMask) == NSLeftCommandKeyMask
- || (! is_right_key && (flags & NSEventModifierFlagCommand) == NSEventModifierFlagCommand);
-
- if (is_right_key)
- emacs_event->modifiers |= parse_solitary_modifier
- (EQ (ns_right_command_modifier, Qleft)
- ? ns_command_modifier
- : ns_right_command_modifier);
-
- if (is_left_key)
- {
- emacs_event->modifiers |= parse_solitary_modifier
- (ns_command_modifier);
-
- /* if super (default), take input manager's word so things like
- dvorak / qwerty layout work */
- if (EQ (ns_command_modifier, Qsuper)
- && !fnKeysym
- && [[theEvent characters] length] != 0)
- {
- /* XXX: the code we get will be unshifted, so if we have
- a shift modifier, must convert ourselves */
- if (!(flags & NSEventModifierFlagShift))
- code = [[theEvent characters] characterAtIndex: 0];
-#if 0
- /* this is ugly and also requires linking w/Carbon framework
- (for LMGetKbdType) so for now leave this rare (?) case
- undealt with.. in future look into CGEvent methods */
- else
- {
- long smv = GetScriptManagerVariable (smKeyScript);
- Handle uchrHandle = GetResource
- ('uchr', GetScriptVariable (smv, smScriptKeys));
- UInt32 dummy = 0;
- UCKeyTranslate ((UCKeyboardLayout *) *uchrHandle,
- [[theEvent characters] characterAtIndex: 0],
- kUCKeyActionDisplay,
- (flags & ~NSEventModifierFlagCommand) >> 8,
- LMGetKbdType (), kUCKeyTranslateNoDeadKeysMask,
- &dummy, 1, &dummy, &code);
- code &= 0xFF;
- }
-#endif
- }
- }
-
- is_right_key = (flags & NSRightControlKeyMask) == NSRightControlKeyMask;
- is_left_key = (flags & NSLeftControlKeyMask) == NSLeftControlKeyMask
- || (! is_right_key && (flags & NSEventModifierFlagControl) == NSEventModifierFlagControl);
-
- if (is_right_key)
- emacs_event->modifiers |= parse_solitary_modifier
- (EQ (ns_right_control_modifier, Qleft)
- ? ns_control_modifier
- : ns_right_control_modifier);
-
- if (is_left_key)
- emacs_event->modifiers |= parse_solitary_modifier
- (ns_control_modifier);
-
- if (flags & NS_FUNCTION_KEY_MASK && !fnKeysym)
- emacs_event->modifiers |=
- parse_solitary_modifier (ns_function_modifier);
-
- left_is_none = NILP (ns_alternate_modifier)
- || EQ (ns_alternate_modifier, Qnone);
-
- is_right_key = (flags & NSRightAlternateKeyMask)
- == NSRightAlternateKeyMask;
- is_left_key = (flags & NSLeftAlternateKeyMask) == NSLeftAlternateKeyMask
- || (! is_right_key
- && (flags & NSEventModifierFlagOption) == NSEventModifierFlagOption);
-
- if (is_right_key)
- {
- if ((NILP (ns_right_alternate_modifier)
- || EQ (ns_right_alternate_modifier, Qnone)
- || (EQ (ns_right_alternate_modifier, Qleft) && left_is_none))
- && !fnKeysym)
- { /* accept pre-interp alt comb */
- if ([[theEvent characters] length] > 0)
- code = [[theEvent characters] characterAtIndex: 0];
- /*HACK: clear lone shift modifier to stop next if from firing */
- if (emacs_event->modifiers == shift_modifier)
- emacs_event->modifiers = 0;
- }
- else
- emacs_event->modifiers |= parse_solitary_modifier
- (EQ (ns_right_alternate_modifier, Qleft)
- ? ns_alternate_modifier
- : ns_right_alternate_modifier);
- }
-
- if (is_left_key) /* default = meta */
- {
- if (left_is_none && !fnKeysym)
- { /* accept pre-interp alt comb */
- if ([[theEvent characters] length] > 0)
- code = [[theEvent characters] characterAtIndex: 0];
- /*HACK: clear lone shift modifier to stop next if from firing */
- if (emacs_event->modifiers == shift_modifier)
- emacs_event->modifiers = 0;
- }
- else
- emacs_event->modifiers |=
- parse_solitary_modifier (ns_alternate_modifier);
- }
-
- if (NS_KEYLOG)
- fprintf (stderr, "keyDown: code =%x\tfnKey =%x\tflags = %x\tmods = %x\n",
- (unsigned) code, fnKeysym, flags, emacs_event->modifiers);
-
- /* if it was a function key or had modifiers, pass it directly to emacs */
+ /* The ⌘ and ⌥ modifiers can be either shift-like (for alternate
+ character input) or control-like (as command prefix). If we
+ have only shift-like modifiers, then we should use the
+ translated characters (returned by the characters method); if
+ we have only control-like modifiers, then we should use the
+ untranslated characters (returned by the
+ charactersIgnoringModifiers method). An annoyance happens if
+ we have both shift-like and control-like modifiers because
+ the NSEvent API doesn’t let us ignore only some modifiers.
+ In that case we use UCKeyTranslate (ns_get_shifted_character)
+ to look up the correct character. */
+
+ /* EV_MODIFIERS2 uses parse_solitary_modifier on all known
+ modifier keys, which returns 0 for shift-like modifiers.
+ Therefore its return value is the set of control-like
+ modifiers. */
+ emacs_event->modifiers = EV_MODIFIERS2 (flags);
+
+ /* Function keys (such as the F-keys, arrow keys, etc.) set
+ modifiers as though the fn key has been pressed when it
+ hasn't. Also some combinations of fn and a function key
+ return a different key than was pressed (e.g. fn-<left> gives
+ <home>). We need to unset the fn modifier in these cases.
+ FIXME: Can we avoid setting it in the first place? */
+ if (fnKeysym && (flags & NS_FUNCTION_KEY_MASK))
+ emacs_event->modifiers ^= parse_solitary_modifier (ns_function_modifier);
+
+ if (NS_KEYLOG)
+ fprintf (stderr, "keyDown: code =%x\tfnKey =%x\tflags = %x\tmods = %x\n",
+ code, fnKeysym, flags, emacs_event->modifiers);
+
+ /* If it was a function key or had control-like modifiers, pass
+ it directly to Emacs. */
if (fnKeysym || (emacs_event->modifiers
&& (emacs_event->modifiers != shift_modifier)
&& [[theEvent charactersIgnoringModifiers] length] > 0))
-/*[[theEvent characters] length] */
{
emacs_event->kind = NON_ASCII_KEYSTROKE_EVENT;
+ /* FIXME: What are the next four lines supposed to do? */
if (code < 0x20)
code |= (1<<28)|(3<<16);
else if (code == 0x7f)
code |= (1<<28)|(3<<16);
else if (!fnKeysym)
- emacs_event->kind = code > 0xFF
- ? MULTIBYTE_CHAR_KEYSTROKE_EVENT : ASCII_KEYSTROKE_EVENT;
+ {
+#ifdef NS_IMPL_COCOA
+ /* We potentially have both shift- and control-like
+ modifiers in use, so find the correct character
+ ignoring any control-like ones. */
+ code = ns_get_shifted_character (theEvent);
+#endif
+
+ /* FIXME: This seems wrong, characters in the range
+ [0x80, 0xFF] are not ASCII characters. Can’t we just
+ use MULTIBYTE_CHAR_KEYSTROKE_EVENT here for all kinds
+ of characters? */
+ emacs_event->kind = code > 0xFF
+ ? MULTIBYTE_CHAR_KEYSTROKE_EVENT : ASCII_KEYSTROKE_EVENT;
+ }
emacs_event->code = code;
EV_TRAILER (theEvent);
@@ -6283,23 +6340,44 @@ not_in_argv (NSString *arg)
}
}
+ /* If we get here, a non-function key without control-like modifiers
+ was hit. Use interpretKeyEvents, which in turn will call
+ insertText; see
+ https://developer.apple.com/library/mac/documentation/Cocoa/Conceptual/EventOverview/HandlingKeyEvents/HandlingKeyEvents.html. */
if (NS_KEYLOG && !processingCompose)
fprintf (stderr, "keyDown: Begin compose sequence.\n");
+ /* FIXME: interpretKeyEvents doesn’t seem to send insertText if ⌘ is
+ used as shift-like modifier, at least on El Capitan. Mask it
+ out. This shouldn’t be needed though; we should figure out what
+ the correct way of handling ⌘ is. */
+ if ([theEvent modifierFlags] & NSEventModifierFlagCommand)
+ theEvent = [NSEvent keyEventWithType:[theEvent type]
+ location:[theEvent locationInWindow]
+ modifierFlags:[theEvent modifierFlags] & ~NSEventModifierFlagCommand
+ timestamp:[theEvent timestamp]
+ windowNumber:[theEvent windowNumber]
+ context:nil
+ characters:[theEvent characters]
+ charactersIgnoringModifiers:[theEvent charactersIgnoringModifiers]
+ isARepeat:[theEvent isARepeat]
+ keyCode:[theEvent keyCode]];
+
processingCompose = YES;
+ /* FIXME: Use [NSArray arrayWithObject:theEvent]? */
[nsEvArray addObject: theEvent];
[self interpretKeyEvents: nsEvArray];
[nsEvArray removeObject: theEvent];
}
-/* <NSTextInput> implementation (called through super interpretKeyEvents:]). */
+/* <NSTextInput> implementation (called through [super interpretKeyEvents:]). */
/* <NSTextInput>: called when done composing;
- NOTE: also called when we delete over working text, followed immed.
- by doCommandBySelector: deleteBackward: */
+ NOTE: also called when we delete over working text, followed
+ immediately by doCommandBySelector: deleteBackward: */
- (void)insertText: (id)aString
{
NSString *s;
@@ -6321,7 +6399,7 @@ not_in_argv (NSString *arg)
if (!emacs_event)
return;
- /* first, clear any working text */
+ /* First, clear any working text. */
if (workingText != nil)
[self deleteWorkingText];
@@ -6330,7 +6408,7 @@ not_in_argv (NSString *arg)
However, we probably can't use SAFE_NALLOCA here because it might
exit nonlocally. */
- /* now insert the string as keystrokes */
+ /* Now insert the string as keystrokes. */
for (NSUInteger i = 0; i < len; i++)
{
NSUInteger code = [s characterAtIndex:i];
@@ -6343,7 +6421,7 @@ not_in_argv (NSString *arg)
++i;
}
}
- /* TODO: still need this? */
+ /* TODO: still need this? */
if (code == 0x2DC)
code = '~'; /* 0x7E */
if (code != 32) /* Space */
@@ -6356,7 +6434,7 @@ not_in_argv (NSString *arg)
}
-/* <NSTextInput>: inserts display of composing characters */
+/* <NSTextInput>: inserts display of composing characters. */
- (void)setMarkedText: (id)aString selectedRange: (NSRange)selRange
{
NSString *str = [aString respondsToSelector: @selector (string)] ?
@@ -6388,7 +6466,7 @@ not_in_argv (NSString *arg)
}
-/* delete display of composing characters [not in <NSTextInput>] */
+/* Delete display of composing characters [not in <NSTextInput>]. */
- (void)deleteWorkingText
{
NSTRACE ("[EmacsView deleteWorkingText]");
@@ -6441,7 +6519,7 @@ not_in_argv (NSString *arg)
}
-/* used to position char selection windows, etc. */
+/* Used to position char selection windows, etc. */
- (NSRect)firstRectForCharacterRange: (NSRange)theRange
{
NSRect rect;
@@ -6501,8 +6579,8 @@ not_in_argv (NSString *arg)
processingCompose = NO;
if (aSelector == @selector (deleteBackward:))
{
- /* happens when user backspaces over an ongoing composition:
- throw a 'delete' into the event queue */
+ /* Happens when user backspaces over an ongoing composition:
+ throw a 'delete' into the event queue. */
if (!emacs_event)
return;
emacs_event->kind = NON_ASCII_KEYSTROKE_EVENT;
@@ -6547,7 +6625,7 @@ not_in_argv (NSString *arg)
return str;
}
-/* End <NSTextInput> impl. */
+/* End <NSTextInput> implementation. */
/*****************************************************************************/
@@ -6565,8 +6643,8 @@ not_in_argv (NSString *arg)
return;
dpyinfo->last_mouse_frame = emacsframe;
- /* appears to be needed to prevent spurious movement events generated on
- button clicks */
+ /* Appears to be needed to prevent spurious movement events generated on
+ button clicks. */
emacsframe->mouse_moved = 0;
if ([theEvent type] == NSEventTypeScrollWheel)
@@ -6602,8 +6680,8 @@ not_in_argv (NSString *arg)
static int totalDeltaX, totalDeltaY;
int lineHeight;
- if (NUMBERP (ns_mwheel_line_height))
- lineHeight = XINT (ns_mwheel_line_height);
+ if (FIXNUMP (ns_mwheel_line_height))
+ lineHeight = XFIXNUM (ns_mwheel_line_height);
else
{
/* FIXME: Use actual line height instead of the default. */
@@ -6672,7 +6750,7 @@ not_in_argv (NSString *arg)
return;
emacs_event->kind = horizontal ? HORIZ_WHEEL_EVENT : WHEEL_EVENT;
- emacs_event->arg = (make_number (lines));
+ emacs_event->arg = (make_fixnum (lines));
emacs_event->code = 0;
emacs_event->modifiers = EV_MODIFIERS (theEvent) |
@@ -6685,7 +6763,8 @@ not_in_argv (NSString *arg)
#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 1070
{
CGFloat delta = [theEvent deltaY];
- /* Mac notebooks send wheel events w/delta =0 when trackpad scrolling */
+ /* Mac notebooks send wheel events with delta equal to 0
+ when trackpad scrolling. */
if (delta == 0)
{
delta = [theEvent deltaX];
@@ -6762,7 +6841,7 @@ not_in_argv (NSString *arg)
}
-/* Tell emacs the mouse has moved. */
+/* Tell emacs the mouse has moved. */
- (void)mouseMoved: (NSEvent *)e
{
Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (emacsframe);
@@ -6777,14 +6856,14 @@ not_in_argv (NSString *arg)
dpyinfo->last_mouse_motion_x = pt.x;
dpyinfo->last_mouse_motion_y = pt.y;
- /* update any mouse face */
+ /* Update any mouse face. */
if (hlinfo->mouse_face_hidden)
{
hlinfo->mouse_face_hidden = 0;
clear_mouse_face (hlinfo);
}
- /* tooltip handling */
+ /* Tooltip handling. */
previous_help_echo_string = help_echo_string;
help_echo_string = Qnil;
@@ -6819,7 +6898,7 @@ not_in_argv (NSString *arg)
{
/* NOTE: help_echo_{window,pos,object} are set in xdisp.c
(note_mouse_highlight), which is called through the
- note_mouse_movement () call above */
+ note_mouse_movement () call above. */
any_help_event_p = YES;
gen_help_event (help_echo_string, frame, help_echo_window,
help_echo_object, help_echo_pos);
@@ -6903,7 +6982,7 @@ not_in_argv (NSString *arg)
if (wait_for_tool_bar)
{
/* The toolbar height is always 0 in fullscreen and undecorated
- frames, so don't wait for it to become available. */
+ frames, so don't wait for it to become available. */
if (FRAME_TOOLBAR_HEIGHT (emacsframe) == 0
&& FRAME_UNDECORATED (emacsframe) == false
&& ! [self isFullscreen])
@@ -6951,7 +7030,7 @@ not_in_argv (NSString *arg)
wr = NSMakeRect (0, 0, neww, newh);
[view setFrame: wr];
- // to do: consider using [NSNotificationCenter postNotificationName:].
+ // To do: consider using [NSNotificationCenter postNotificationName:].
[self windowDidMove: // Update top/left.
[NSNotification notificationWithName:NSWindowDidMoveNotification
object:[view window]]];
@@ -6963,7 +7042,7 @@ not_in_argv (NSString *arg)
}
- (NSSize)windowWillResize: (NSWindow *)sender toSize: (NSSize)frameSize
-/* normalize frame to gridded text size */
+/* Normalize frame to gridded text size. */
{
int extra = 0;
@@ -7005,7 +7084,7 @@ not_in_argv (NSString *arg)
rows = MINHEIGHT;
#ifdef NS_IMPL_COCOA
{
- /* this sets window title to have size in it; the wm does this under GS */
+ /* This sets window title to have size in it; the wm does this under GS. */
NSRect r = [[self window] frame];
if (r.size.height == frameSize.height && r.size.width == frameSize.width)
{
@@ -7038,12 +7117,12 @@ not_in_argv (NSString *arg)
NSTRACE_MSG ("cols: %d rows: %d", cols, rows);
- /* Restrict the new size to the text gird.
+ /* Restrict the new size to the text grid.
Don't restrict the width if the user only adjusted the height, and
vice versa. (Without this, the frame would shrink, and move
slightly, if the window was resized by dragging one of its
- borders.) */
+ borders.) */
if (!frame_resize_pixelwise)
{
NSRect r = [[self window] frame];
@@ -7095,8 +7174,8 @@ not_in_argv (NSString *arg)
NSWindow *theWindow = [notification object];
/* In GNUstep, at least currently, it's possible to get a didResize
- without getting a willResize.. therefore we need to act as if we got
- the willResize now */
+ without getting a willResize, therefore we need to act as if we got
+ the willResize now. */
NSSize sz = [theWindow frame].size;
sz = [self windowWillResize: theWindow toSize: sz];
#endif /* NS_IMPL_GNUSTEP */
@@ -7167,7 +7246,7 @@ not_in_argv (NSString *arg)
ns_frame_rehighlight (emacsframe);
/* FIXME: for some reason needed on second and subsequent clicks away
- from sole-frame Emacs to get hollow box to show */
+ from sole-frame Emacs to get hollow box to show. */
if (!windowClosing && [[self window] isVisible] == YES)
{
x_update_cursor (emacsframe, 1);
@@ -7399,7 +7478,7 @@ not_in_argv (NSString *arg)
/* macOS Sierra automatically enables tabbed windows. We can't
allow this to be enabled until it's available on a Free system.
- Currently it only happens by accident and is buggy anyway. */
+ Currently it only happens by accident and is buggy anyway. */
#if defined (NS_IMPL_COCOA) \
&& MAC_OS_X_VERSION_MAX_ALLOWED >= 101200
#if MAC_OS_X_VERSION_MIN_REQUIRED < 101200
@@ -7441,7 +7520,7 @@ not_in_argv (NSString *arg)
/* Called AFTER method below, but before our windowWillResize call there leads
to windowDidResize -> x_set_window_size. Update emacs' notion of frame
- location so set_window_size moves the frame. */
+ location so set_window_size moves the frame. */
- (BOOL)windowShouldZoom: (NSWindow *)sender toFrame: (NSRect)newFrame
{
NSTRACE (("[EmacsView windowShouldZoom:toFrame:" NSTRACE_FMT_RECT "]"
@@ -7455,7 +7534,7 @@ not_in_argv (NSString *arg)
/* Override to do something slightly nonstandard, but nice. First click on
zoom button will zoom vertically. Second will zoom completely. Third
- returns to original. */
+ returns to original. */
- (NSRect)windowWillUseStandardFrame:(NSWindow *)sender
defaultFrame:(NSRect)defaultFrame
{
@@ -7536,7 +7615,7 @@ not_in_argv (NSString *arg)
{
NSTRACE_MSG ("FULLSCREEN_MAXIMIZED");
- result = defaultFrame; /* second click */
+ result = defaultFrame; /* second click */
maximized_width = result.size.width;
maximized_height = result.size.height;
[self setFSValue: FULLSCREEN_MAXIMIZED];
@@ -7817,7 +7896,7 @@ not_in_argv (NSString *arg)
NSScreen *screen = [w screen];
#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1090
- /* Hide ghost menu bar on secondary monitor? */
+ /* Hide ghost menu bar on secondary monitor? */
if (! onFirstScreen
#if MAC_OS_X_VERSION_MIN_REQUIRED < 1090
&& [NSScreen respondsToSelector: @selector(screensHaveSeparateSpaces)]
@@ -7896,7 +7975,8 @@ not_in_argv (NSString *arg)
f->border_width = bwidth;
- // to do: consider using [NSNotificationCenter postNotificationName:] to send notifications.
+ // To do: consider using [NSNotificationCenter postNotificationName:] to
+ // send notifications.
[self windowWillExitFullScreen];
[fw setFrame: [w frame] display:YES animate:ns_use_fullscreen_animation];
@@ -8036,7 +8116,7 @@ not_in_argv (NSString *arg)
}
-/* this gets called on toolbar button click */
+/* This gets called on toolbar button click. */
- (instancetype)toolbarClicked: (id)item
{
NSEvent *theEvent;
@@ -8047,14 +8127,14 @@ not_in_argv (NSString *arg)
if (!emacs_event)
return self;
- /* send first event (for some reason two needed) */
+ /* Send first event (for some reason two needed). */
theEvent = [[self window] currentEvent];
emacs_event->kind = TOOL_BAR_EVENT;
XSETFRAME (emacs_event->arg, emacsframe);
EV_TRAILER (theEvent);
emacs_event->kind = TOOL_BAR_EVENT;
-/* XSETINT (emacs_event->code, 0); */
+ /* XSETINT (emacs_event->code, 0); */
emacs_event->arg = AREF (emacsframe->tool_bar_items,
idx + TOOL_BAR_ITEM_KEY);
emacs_event->modifiers = EV_MODIFIERS (theEvent);
@@ -8153,7 +8233,9 @@ not_in_argv (NSString *arg)
NSEvent *theEvent = [[self window] currentEvent];
NSPoint position;
NSDragOperation op = [sender draggingSourceOperationMask];
- int modifiers = 0;
+ Lisp_Object operations = Qnil;
+ Lisp_Object strings = Qnil;
+ Lisp_Object type_sym;
NSTRACE ("[EmacsView performDragOperation:]");
@@ -8166,19 +8248,17 @@ not_in_argv (NSString *arg)
pb = [sender draggingPasteboard];
type = [pb availableTypeFromArray: ns_drag_types];
- if (! (op & (NSDragOperationMove|NSDragOperationDelete)) &&
- // URL drags contain all operations (0xf), don't allow all to be set.
- (op & 0xf) != 0xf)
- {
- if (op & NSDragOperationLink)
- modifiers |= NSEventModifierFlagControl;
- if (op & NSDragOperationCopy)
- modifiers |= NSEventModifierFlagOption;
- if (op & NSDragOperationGeneric)
- modifiers |= NSEventModifierFlagCommand;
- }
+ /* We used to convert these drag operations to keyboard modifiers,
+ but because they can be set by the sending program as well as the
+ keyboard modifiers it was difficult to work out a sensible key
+ mapping for drag and drop. */
+ if (op & NSDragOperationLink)
+ operations = Fcons (Qns_drag_operation_link, operations);
+ if (op & NSDragOperationCopy)
+ operations = Fcons (Qns_drag_operation_copy, operations);
+ if (op & NSDragOperationGeneric || NILP (operations))
+ operations = Fcons (Qns_drag_operation_generic, operations);
- modifiers = EV_MODIFIERS2 (modifiers);
if (type == 0)
{
return NO;
@@ -8192,39 +8272,20 @@ not_in_argv (NSString *arg)
if (!(files = [pb propertyListForType: type]))
return NO;
+ type_sym = Qfile;
+
fenum = [files objectEnumerator];
while ( (file = [fenum nextObject]) )
- {
- emacs_event->kind = DRAG_N_DROP_EVENT;
- XSETINT (emacs_event->x, x);
- XSETINT (emacs_event->y, y);
- emacs_event->modifiers = modifiers;
- emacs_event->arg = list2 (Qfile, build_string ([file UTF8String]));
- EV_TRAILER (theEvent);
- }
- return YES;
+ strings = Fcons (build_string ([file UTF8String]), strings);
}
else if ([type isEqualToString: NSURLPboardType])
{
NSURL *url = [NSURL URLFromPasteboard: pb];
if (url == nil) return NO;
- emacs_event->kind = DRAG_N_DROP_EVENT;
- XSETINT (emacs_event->x, x);
- XSETINT (emacs_event->y, y);
- emacs_event->modifiers = modifiers;
- emacs_event->arg = list2 (Qurl,
- build_string ([[url absoluteString]
- UTF8String]));
- EV_TRAILER (theEvent);
+ type_sym = Qurl;
- if ([url isFileURL] != NO)
- {
- NSString *file = [url path];
- ns_input_file = append2 (ns_input_file,
- build_string ([file UTF8String]));
- }
- return YES;
+ strings = list1 (build_string ([[url absoluteString] UTF8String]));
}
else if ([type isEqualToString: NSStringPboardType]
|| [type isEqualToString: NSTabularTextPboardType])
@@ -8234,19 +8295,27 @@ not_in_argv (NSString *arg)
if (! (data = [pb stringForType: type]))
return NO;
- emacs_event->kind = DRAG_N_DROP_EVENT;
- XSETINT (emacs_event->x, x);
- XSETINT (emacs_event->y, y);
- emacs_event->modifiers = modifiers;
- emacs_event->arg = list2 (Qnil, build_string ([data UTF8String]));
- EV_TRAILER (theEvent);
- return YES;
+ type_sym = Qnil;
+
+ strings = list1 (build_string ([data UTF8String]));
}
else
{
fprintf (stderr, "Invalid data type in dragging pasteboard");
return NO;
}
+
+ emacs_event->kind = DRAG_N_DROP_EVENT;
+ XSETINT (emacs_event->x, x);
+ XSETINT (emacs_event->y, y);
+ emacs_event->modifiers = 0;
+
+ emacs_event->arg = Fcons (type_sym,
+ Fcons (operations,
+ strings));
+ EV_TRAILER (theEvent);
+
+ return YES;
}
@@ -8271,13 +8340,13 @@ not_in_argv (NSString *arg)
But this should not happen because we override the services menu with our
own entries which call ns-perform-service.
Nonetheless, it appeared to happen (under strange circumstances): bug#1435.
- So let's at least stub them out until further investigation can be done. */
+ So let's at least stub them out until further investigation can be done. */
- (BOOL) readSelectionFromPasteboard: (NSPasteboard *)pb
{
- /* we could call ns_string_from_pasteboard(pboard) here but then it should
- be written into the buffer in place of the existing selection..
- ordinary service calls go through functions defined in ns-win.el */
+ /* We could call ns_string_from_pasteboard(pboard) here but then it should
+ be written into the buffer in place of the existing selection.
+ Ordinary service calls go through functions defined in ns-win.el. */
return NO;
}
@@ -8288,7 +8357,7 @@ not_in_argv (NSString *arg)
NSTRACE ("[EmacsView writeSelectionToPasteboard:types:]");
- /* We only support NSStringPboardType */
+ /* We only support NSStringPboardType. */
if ([types containsObject:NSStringPboardType] == NO) {
return NO;
}
@@ -8310,10 +8379,10 @@ not_in_argv (NSString *arg)
}
-/* setMini =YES means set from internal (gives a finder icon), NO means set nil
+/* setMini = YES means set from internal (gives a finder icon), NO means set nil
(gives a miniaturized version of the window); currently we use the latter for
frames whose active buffer doesn't correspond to any file
- (e.g., '*scratch*') */
+ (e.g., '*scratch*'). */
- (instancetype)setMiniwindowImage: (BOOL) setMini
{
id image = [[self window] miniwindowImage];
@@ -8321,7 +8390,7 @@ not_in_argv (NSString *arg)
/* NOTE: under Cocoa miniwindowImage always returns nil, documentation
about "AppleDockIconEnabled" notwithstanding, however the set message
- below has its effect nonetheless. */
+ below has its effect nonetheless. */
if (image != emacsframe->output_data.ns->miniimage)
{
if (image && [image isKindOfClass: [EmacsImage class]])
@@ -8432,7 +8501,7 @@ not_in_argv (NSString *arg)
Note that this should work in situations where multiple monitors
are present. Common configurations are side-by-side monitors and a
monitor on top of another (e.g. when a laptop is placed under a
- large screen). */
+ large screen). */
- (NSRect)constrainFrameRect:(NSRect)frameRect toScreen:(NSScreen *)screen
{
NSTRACE ("[EmacsWindow constrainFrameRect:" NSTRACE_FMT_RECT " toScreen:]",
@@ -8659,7 +8728,7 @@ not_in_argv (NSString *arg)
+ (CGFloat) scrollerWidth
{
/* TODO: if we want to allow variable widths, this is the place to do it,
- however neither GNUstep nor Cocoa support it very well */
+ however neither GNUstep nor Cocoa support it very well. */
CGFloat r;
#if defined (NS_IMPL_COCOA) \
&& MAC_OS_X_VERSION_MAX_ALLOWED >= 1070
@@ -8695,7 +8764,7 @@ not_in_argv (NSString *arg)
/* Ensure auto resizing of scrollbars occurs within the emacs frame's view
locked against the top and bottom edges, and right edge on macOS, where
- scrollers are on right. */
+ scrollers are on right. */
#ifdef NS_IMPL_GNUSTEP
[self setAutoresizingMask: NSViewMaxXMargin | NSViewHeightSizable];
#else
@@ -8719,7 +8788,7 @@ not_in_argv (NSString *arg)
NSView *sview = [[view window] contentView];
NSArray *subs = [sview subviews];
- /* disable optimization stopping redraw of other scrollbars */
+ /* Disable optimization stopping redraw of other scrollbars. */
view->scrollbarsNeedingUpdate = 0;
for (i =[subs count]-1; i >= 0; i--)
if ([[subs objectAtIndex: i] isKindOfClass: [EmacsScroller class]])
@@ -8727,7 +8796,7 @@ not_in_argv (NSString *arg)
[sview addSubview: self];
}
-/* [self setFrame: r]; */
+ /* [self setFrame: r]; */
return self;
}
@@ -8737,7 +8806,7 @@ not_in_argv (NSString *arg)
{
NSTRACE ("[EmacsScroller setFrame:]");
-/* block_input (); */
+ /* block_input (); */
if (horizontal)
pixel_length = NSWidth (newRect);
else
@@ -8745,7 +8814,7 @@ not_in_argv (NSString *arg)
if (pixel_length == 0) pixel_length = 1;
min_portion = 20 / pixel_length;
[super setFrame: newRect];
-/* unblock_input (); */
+ /* unblock_input (); */
}
@@ -8788,7 +8857,7 @@ not_in_argv (NSString *arg)
{
EmacsView *view;
block_input ();
- /* ensure other scrollbar updates after deletion */
+ /* Ensure other scrollbar updates after deletion. */
view = (EmacsView *)FRAME_NS_VIEW (frame);
if (view != nil)
view->scrollbarsNeedingUpdate++;
@@ -8815,7 +8884,14 @@ not_in_argv (NSString *arg)
if (!NSIsEmptyRect (visible))
[self addCursorRect: visible cursor: [NSCursor arrowCursor]];
- [[NSCursor arrowCursor] setOnMouseEntered: YES];
+
+#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101300
+#if MAC_OS_X_VERSION_MAX_ALLOWED >= 101300
+ if ([[NSCursor arrowCursor] respondsToSelector:
+ @selector(setOnMouseEntered)])
+#endif
+ [[NSCursor arrowCursor] setOnMouseEntered: YES];
+#endif
}
@@ -8823,7 +8899,7 @@ not_in_argv (NSString *arg)
whole: (int) whole
{
return em_position ==position && em_portion ==portion && em_whole ==whole
- && portion != whole; /* needed for resize empty buf */
+ && portion != whole; /* Needed for resizing empty buffer. */
}
@@ -8862,7 +8938,7 @@ not_in_argv (NSString *arg)
return self;
}
-/* set up emacs_event */
+/* Set up emacs_event. */
- (void) sendScrollEventAtLoc: (float)loc fromEvent: (NSEvent *)e
{
Lisp_Object win;
@@ -8905,7 +8981,8 @@ not_in_argv (NSString *arg)
}
-/* called manually thru timer to implement repeated button action w/hold-down */
+/* Called manually through timer to implement repeated button action
+ with hold-down. */
- (instancetype)repeatScroll: (NSTimer *)scrollEntry
{
NSEvent *e = [[self window] currentEvent];
@@ -8914,7 +8991,7 @@ not_in_argv (NSString *arg)
NSTRACE ("[EmacsScroller repeatScroll:]");
- /* clear timer if need be */
+ /* Clear timer if need be. */
if (inKnob || [scroll_repeat_entry timeInterval] == SCROLL_BAR_FIRST_DELAY)
{
[scroll_repeat_entry invalidate];
@@ -8940,11 +9017,11 @@ not_in_argv (NSString *arg)
/* Asynchronous mouse tracking for scroller. This allows us to dispatch
- mouseDragged events without going into a modal loop. */
+ mouseDragged events without going into a modal loop. */
- (void)mouseDown: (NSEvent *)e
{
NSRect sr, kr;
- /* hitPart is only updated AFTER event is passed on */
+ /* hitPart is only updated AFTER event is passed on. */
NSScrollerPart part = [self testPart: [e locationInWindow]];
CGFloat loc, kloc, pos UNINIT;
int edge = 0;
@@ -9043,9 +9120,9 @@ not_in_argv (NSString *arg)
}
else
{
- pos = 0; /* ignored */
+ pos = 0; /* ignored */
- /* set a timer to repeat, as we can't let superclass do this modally */
+ /* Set a timer to repeat, as we can't let superclass do this modally. */
scroll_repeat_entry
= [[NSTimer scheduledTimerWithTimeInterval: SCROLL_BAR_FIRST_DELAY
target: self
@@ -9060,7 +9137,7 @@ not_in_argv (NSString *arg)
}
-/* Called as we manually track scroller drags, rather than superclass. */
+/* Called as we manually track scroller drags, rather than superclass. */
- (void)mouseDragged: (NSEvent *)e
{
NSRect sr;
@@ -9118,7 +9195,7 @@ not_in_argv (NSString *arg)
}
-/* treat scrollwheel events in the bar as though they were in the main window */
+/* Treat scrollwheel events in the bar as though they were in the main window. */
- (void) scrollWheel: (NSEvent *)theEvent
{
NSTRACE ("[EmacsScroller scrollWheel:]");
@@ -9206,7 +9283,7 @@ x_new_font (struct frame *f, Lisp_Object font_object, int fontset)
/* XLFD: -foundry-family-weight-slant-swidth-adstyle-pxlsz-ptSz-resx-resy-spc-avgWidth-rgstry-encoding */
/* Note: ns_font_to_xlfd and ns_fontname_to_xlfd no longer needed, removed
- in 1.43. */
+ in 1.43. */
const char *
ns_xlfd_to_fontname (const char *xlfd)
@@ -9247,7 +9324,7 @@ ns_xlfd_to_fontname (const char *xlfd)
name[i+1] = c_toupper (name[i+1]);
}
}
-/*fprintf (stderr, "converted '%s' to '%s'\n",xlfd,name); */
+ /* fprintf (stderr, "converted '%s' to '%s'\n",xlfd,name); */
ret = [[NSString stringWithUTF8String: name] UTF8String];
xfree (name);
return ret;
@@ -9260,8 +9337,9 @@ syms_of_nsterm (void)
NSTRACE ("syms_of_nsterm");
ns_antialias_threshold = 10.0;
+ PDUMPER_REMEMBER_SCALAR (ns_antialias_threshold);
- /* from 23+ we need to tell emacs what modifiers there are.. */
+ /* From 23+ we need to tell emacs what modifiers there are. */
DEFSYM (Qmodifier_value, "modifier-value");
DEFSYM (Qalt, "alt");
DEFSYM (Qhyper, "hyper");
@@ -9273,11 +9351,15 @@ syms_of_nsterm (void)
DEFSYM (Qfile, "file");
DEFSYM (Qurl, "url");
- Fput (Qalt, Qmodifier_value, make_number (alt_modifier));
- Fput (Qhyper, Qmodifier_value, make_number (hyper_modifier));
- Fput (Qmeta, Qmodifier_value, make_number (meta_modifier));
- Fput (Qsuper, Qmodifier_value, make_number (super_modifier));
- Fput (Qcontrol, Qmodifier_value, make_number (ctrl_modifier));
+ DEFSYM (Qns_drag_operation_copy, "ns-drag-operation-copy");
+ DEFSYM (Qns_drag_operation_link, "ns-drag-operation-link");
+ DEFSYM (Qns_drag_operation_generic, "ns-drag-operation-generic");
+
+ Fput (Qalt, Qmodifier_value, make_fixnum (alt_modifier));
+ Fput (Qhyper, Qmodifier_value, make_fixnum (hyper_modifier));
+ Fput (Qmeta, Qmodifier_value, make_fixnum (meta_modifier));
+ Fput (Qsuper, Qmodifier_value, make_fixnum (super_modifier));
+ Fput (Qcontrol, Qmodifier_value, make_fixnum (ctrl_modifier));
DEFVAR_LISP ("ns-input-file", ns_input_file,
"The file specified in the last NS event.");
@@ -9376,11 +9458,11 @@ allowing it to be used at a lower level for accented character entry.");
DEFVAR_LISP ("ns-auto-hide-menu-bar", ns_auto_hide_menu_bar,
doc: /* Non-nil means that the menu bar is hidden, but appears when the mouse is near.
-Only works on Mac OS X 10.6 or later. */);
+Only works on Mac OS X. */);
ns_auto_hide_menu_bar = Qnil;
DEFVAR_BOOL ("ns-use-native-fullscreen", ns_use_native_fullscreen,
- doc: /*Non-nil means to use native fullscreen on Mac OS X 10.7 and later.
+ doc: /* Non-nil means to use native fullscreen on Mac OS X 10.7 and later.
Nil means use fullscreen the old (< 10.7) way. The old way works better with
multiple monitors, but lacks tool bar. This variable is ignored on
Mac OS X < 10.7. Default is t. */);
@@ -9388,60 +9470,51 @@ Mac OS X < 10.7. Default is t. */);
ns_last_use_native_fullscreen = ns_use_native_fullscreen;
DEFVAR_BOOL ("ns-use-fullscreen-animation", ns_use_fullscreen_animation,
- doc: /*Non-nil means use animation on non-native fullscreen.
+ doc: /* Non-nil means use animation on non-native fullscreen.
For native fullscreen, this does nothing.
Default is nil. */);
ns_use_fullscreen_animation = NO;
DEFVAR_BOOL ("ns-use-srgb-colorspace", ns_use_srgb_colorspace,
- doc: /*Non-nil means to use sRGB colorspace on Mac OS X 10.7 and later.
+ doc: /* Non-nil means to use sRGB colorspace on Mac OS X 10.7 and later.
Note that this does not apply to images.
This variable is ignored on Mac OS X < 10.7 and GNUstep. */);
ns_use_srgb_colorspace = YES;
DEFVAR_BOOL ("ns-use-mwheel-acceleration",
ns_use_mwheel_acceleration,
- doc: /*Non-nil means use macOS's standard mouse wheel acceleration.
+ doc: /* Non-nil means use macOS's standard mouse wheel acceleration.
This variable is ignored on macOS < 10.7 and GNUstep. Default is t. */);
ns_use_mwheel_acceleration = YES;
DEFVAR_LISP ("ns-mwheel-line-height", ns_mwheel_line_height,
- doc: /*The number of pixels touchpad scrolling considers one line.
+ doc: /* The number of pixels touchpad scrolling considers one line.
Nil or a non-number means use the default frame line height.
This variable is ignored on macOS < 10.7 and GNUstep. Default is nil. */);
ns_mwheel_line_height = Qnil;
DEFVAR_BOOL ("ns-use-mwheel-momentum", ns_use_mwheel_momentum,
- doc: /*Non-nil means mouse wheel scrolling uses momentum.
+ doc: /* Non-nil means mouse wheel scrolling uses momentum.
This variable is ignored on macOS < 10.7 and GNUstep. Default is t. */);
ns_use_mwheel_momentum = YES;
- /* TODO: move to common code */
+ /* TODO: Move to common code. */
DEFVAR_LISP ("x-toolkit-scroll-bars", Vx_toolkit_scroll_bars,
- doc: /* Which toolkit scroll bars Emacs uses, if any.
-A value of nil means Emacs doesn't use toolkit scroll bars.
-With the X Window system, the value is a symbol describing the
-X toolkit. Possible values are: gtk, motif, xaw, or xaw3d.
-With MS Windows or Nextstep, the value is t. */);
+ doc: /* SKIP: real doc in xterm.c. */);
Vx_toolkit_scroll_bars = Qt;
DEFVAR_BOOL ("x-use-underline-position-properties",
x_use_underline_position_properties,
- doc: /*Non-nil means make use of UNDERLINE_POSITION font properties.
-A value of nil means ignore them. If you encounter fonts with bogus
-UNDERLINE_POSITION font properties, for example 7x13 on XFree prior
-to 4.1, set this to nil. */);
+ doc: /* SKIP: real doc in xterm.c. */);
x_use_underline_position_properties = 0;
+ DEFSYM (Qx_use_underline_position_properties,
+ "x-use-underline-position-properties");
DEFVAR_BOOL ("x-underline-at-descent-line",
x_underline_at_descent_line,
- doc: /* Non-nil means to draw the underline at the same place as the descent line.
-(If `line-spacing' is in effect, that moves the underline lower by
-that many pixels.)
-A value of nil means to draw the underline according to the value of the
-variable `x-use-underline-position-properties', which is usually at the
-baseline level. The default value is nil. */);
+ doc: /* SKIP: real doc in xterm.c. */);
x_underline_at_descent_line = 0;
+ DEFSYM (Qx_underline_at_descent_line, "x-underline-at-descent-line");
/* Tell Emacs about this window system. */
Fprovide (Qns, Qnil);
diff --git a/src/pdumper.c b/src/pdumper.c
new file mode 100644
index 00000000000..600c5b3ca3d
--- /dev/null
+++ b/src/pdumper.c
@@ -0,0 +1,5514 @@
+/* Copyright (C) 2018-2019 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#include <errno.h>
+#include <fcntl.h>
+#include <limits.h>
+#include <math.h>
+#include <stdarg.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <sys/mman.h>
+#include <sys/param.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+#include <unistd.h>
+
+#include "blockinput.h"
+#include "buffer.h"
+#include "charset.h"
+#include "coding.h"
+#include "fingerprint.h"
+#include "frame.h"
+#include "getpagesize.h"
+#include "intervals.h"
+#include "lisp.h"
+#include "pdumper.h"
+#include "window.h"
+#include "systime.h"
+#include "thread.h"
+#include "bignum.h"
+
+#ifdef CHECK_STRUCTS
+# include "dmpstruct.h"
+#endif
+
+/*
+ TODO:
+
+ - Two-pass dumping: first assemble object list, then write all.
+ This way, we can perform arbitrary reordering or maybe use fancy
+ graph algorithms to get better locality.
+
+ - Don't emit relocations that happen to set Emacs memory locations
+ to values they will already have.
+
+ - Nullify frame_and_buffer_state.
+
+ - Preferred base address for relocation-free non-PIC startup.
+
+ - Compressed dump support.
+
+*/
+
+#ifdef HAVE_PDUMPER
+
+#if __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 7)
+# pragma GCC diagnostic error "-Wconversion"
+# pragma GCC diagnostic error "-Wshadow"
+# define ALLOW_IMPLICIT_CONVERSION \
+ _Pragma ("GCC diagnostic push") \
+ _Pragma ("GCC diagnostic ignored \"-Wconversion\"")
+ _Pragma ("GCC diagnostic ignored \"-Wsign-conversion\"")
+# define DISALLOW_IMPLICIT_CONVERSION \
+ _Pragma ("GCC diagnostic pop")
+#else
+# define ALLOW_IMPLICIT_CONVERSION ((void)0)
+# define DISALLOW_IMPLICIT_CONVERSION ((void)0)
+#endif
+
+#define VM_POSIX 1
+#define VM_MS_WINDOWS 2
+
+#if defined (HAVE_MMAP) && defined (MAP_FIXED)
+# define VM_SUPPORTED VM_POSIX
+# if !defined (MAP_POPULATE) && defined (MAP_PREFAULT_READ)
+# define MAP_POPULATE MAP_PREFAULT_READ
+# elif !defined (MAP_POPULATE)
+# define MAP_POPULATE 0
+# endif
+#elif defined (WINDOWSNT)
+ /* Use a float infinity, to avoid compiler warnings in comparing vs
+ candidates' score. */
+# undef INFINITY
+# define INFINITY __builtin_inff ()
+# include <windows.h>
+# define VM_SUPPORTED VM_MS_WINDOWS
+#else
+# define VM_SUPPORTED 0
+#endif
+
+#define DANGEROUS 0
+
+/* PDUMPER_CHECK_REHASHING being true causes the portable dumper to
+ check, for each hash table it dumps, that the hash table means the
+ same thing after rehashing. */
+#ifndef PDUMPER_CHECK_REHASHING
+# if ENABLE_CHECKING
+# define PDUMPER_CHECK_REHASHING 1
+# else
+# define PDUMPER_CHECK_REHASHING 0
+# endif
+#endif
+
+/* We require an architecture in which all pointers are the same size
+ and have the same layout, where pointers are either 32 or 64 bits
+ long, and where bytes have eight bits --- that is, a
+ general-purpose computer made after 1990. */
+verify (sizeof (ptrdiff_t) == sizeof (void *));
+verify (sizeof (intptr_t) == sizeof (ptrdiff_t));
+verify (sizeof (void (*)(void)) == sizeof (void *));
+verify (sizeof (ptrdiff_t) <= sizeof (Lisp_Object));
+verify (sizeof (ptrdiff_t) <= sizeof (EMACS_INT));
+verify (CHAR_BIT == 8);
+
+#define DIVIDE_ROUND_UP(x, y) (((x) + (y) - 1) / (y))
+
+static const char dump_magic[16] = {
+ 'D', 'U', 'M', 'P', 'E', 'D',
+ 'G', 'N', 'U',
+ 'E', 'M', 'A', 'C', 'S'
+};
+
+static pdumper_hook dump_hooks[24];
+static int nr_dump_hooks = 0;
+
+static struct
+{
+ void *mem;
+ int sz;
+} remembered_data[32];
+static int nr_remembered_data = 0;
+
+typedef int_least32_t dump_off;
+#define DUMP_OFF_MIN INT_LEAST32_MIN
+#define DUMP_OFF_MAX INT_LEAST32_MAX
+
+__attribute__((format (printf,1,2)))
+static void
+dump_trace (const char *fmt, ...)
+{
+ if (0)
+ {
+ va_list args;
+ va_start (args, fmt);
+ vfprintf (stderr, fmt, args);
+ va_end (args);
+ }
+}
+
+static ssize_t dump_read_all (int fd, void *buf, size_t bytes_to_read);
+
+static dump_off
+ptrdiff_t_to_dump_off (ptrdiff_t value)
+{
+ eassert (DUMP_OFF_MIN <= value);
+ eassert (value <= DUMP_OFF_MAX);
+ return (dump_off) value;
+}
+
+/* Worst-case allocation granularity on any system that might load
+ this dump. */
+static int
+dump_get_page_size (void)
+{
+#if defined (WINDOWSNT) || defined (CYGWIN)
+ return 64 * 1024; /* Worst-case allocation granularity. */
+#else
+ return getpagesize ();
+#endif
+}
+
+#define dump_offsetof(type, member) \
+ (ptrdiff_t_to_dump_off (offsetof (type, member)))
+
+enum dump_reloc_type
+ {
+ /* dump_ptr = dump_ptr + emacs_basis() */
+ RELOC_DUMP_TO_EMACS_PTR_RAW,
+ /* dump_ptr = dump_ptr + dump_base */
+ RELOC_DUMP_TO_DUMP_PTR_RAW,
+ /* dump_mpz = [rebuild bignum] */
+ RELOC_BIGNUM,
+ /* dump_lv = make_lisp_ptr (dump_lv + dump_base,
+ type - RELOC_DUMP_TO_DUMP_LV)
+ (Special case for symbols: make_lisp_symbol)
+ Must be second-last. */
+ RELOC_DUMP_TO_DUMP_LV,
+ /* dump_lv = make_lisp_ptr (dump_lv + emacs_basis(),
+ type - RELOC_DUMP_TO_DUMP_LV)
+ (Special case for symbols: make_lisp_symbol.)
+ Must be last. */
+ RELOC_DUMP_TO_EMACS_LV = RELOC_DUMP_TO_DUMP_LV + 8,
+ };
+
+enum emacs_reloc_type
+ {
+ /* Copy raw bytes from the dump into Emacs. The length field in
+ the emacs_reloc is the number of bytes to copy. */
+ RELOC_EMACS_COPY_FROM_DUMP,
+ /* Set a piece of memory in Emacs to a value we store directly in
+ this relocation. The length field contains the number of bytes
+ we actually copy into Emacs. */
+ RELOC_EMACS_IMMEDIATE,
+ /* Set an aligned pointer-sized object in Emacs to a pointer into
+ the loaded dump at the given offset. The length field is
+ always the machine word size. */
+ RELOC_EMACS_DUMP_PTR_RAW,
+ /* Set an aligned pointer-sized object in Emacs to point to
+ something also in Emacs. The length field is always
+ the machine word size. */
+ RELOC_EMACS_EMACS_PTR_RAW,
+ /* Set an aligned Lisp_Object in Emacs to point to a value in the
+ dump. The length field is the _tag type_ of the Lisp_Object,
+ not a byte count! */
+ RELOC_EMACS_DUMP_LV,
+ /* Set an aligned Lisp_Object in Emacs to point to a value in the
+ Emacs image. The length field is the _tag type_ of the
+ Lisp_Object, not a byte count! */
+ RELOC_EMACS_EMACS_LV,
+ };
+
+#define EMACS_RELOC_TYPE_BITS 3
+#define EMACS_RELOC_LENGTH_BITS \
+ (sizeof (dump_off) * CHAR_BIT - EMACS_RELOC_TYPE_BITS)
+
+struct emacs_reloc
+{
+ ENUM_BF (emacs_reloc_type) type : EMACS_RELOC_TYPE_BITS;
+ dump_off length : EMACS_RELOC_LENGTH_BITS;
+ dump_off emacs_offset;
+ union
+ {
+ dump_off dump_offset;
+ dump_off emacs_offset2;
+ intmax_t immediate;
+ } u;
+};
+
+/* Set the type of an Emacs relocation.
+
+ Also make sure that the type fits in the bitfield. */
+static void
+emacs_reloc_set_type (struct emacs_reloc *reloc,
+ enum emacs_reloc_type type)
+{
+ reloc->type = type;
+ eassert (reloc->type == type);
+}
+
+struct dump_table_locator
+{
+ /* Offset in dump, in bytes, of the first entry in the dump
+ table. */
+ dump_off offset;
+ /* Number of entries in the dump table. We need an explicit end
+ indicator (as opposed to a special sentinel) so we can efficiently
+ binary search over the relocation entries. */
+ dump_off nr_entries;
+};
+
+#define DUMP_RELOC_TYPE_BITS 5
+verify (RELOC_DUMP_TO_EMACS_LV + 8 < (1 << DUMP_RELOC_TYPE_BITS));
+
+#define DUMP_RELOC_ALIGNMENT_BITS 2
+#define DUMP_RELOC_OFFSET_BITS \
+ (sizeof (dump_off) * CHAR_BIT - DUMP_RELOC_TYPE_BITS)
+
+/* Minimum alignment required by dump file format. */
+#define DUMP_RELOCATION_ALIGNMENT (1<<DUMP_RELOC_ALIGNMENT_BITS)
+
+/* The alignment granularity (in bytes) for objects we store in the
+ dump. Always suitable for heap objects; may be more aligned. */
+#define DUMP_ALIGNMENT (max (GCALIGNMENT, DUMP_RELOCATION_ALIGNMENT))
+verify (DUMP_ALIGNMENT >= GCALIGNMENT);
+
+struct dump_reloc
+{
+ unsigned int raw_offset : DUMP_RELOC_OFFSET_BITS;
+ ENUM_BF (dump_reloc_type) type : DUMP_RELOC_TYPE_BITS;
+};
+verify (sizeof (struct dump_reloc) == sizeof (dump_off));
+
+/* Set the type of a dump relocation.
+
+ Also assert that the type fits in the bitfield. */
+static void
+dump_reloc_set_type (struct dump_reloc *reloc, enum dump_reloc_type type)
+{
+ reloc->type = type;
+ eassert (reloc->type == type);
+}
+
+static dump_off
+dump_reloc_get_offset (struct dump_reloc reloc)
+{
+ return reloc.raw_offset << DUMP_RELOC_ALIGNMENT_BITS;
+}
+
+static void
+dump_reloc_set_offset (struct dump_reloc *reloc, dump_off offset)
+{
+ eassert (offset >= 0);
+ ALLOW_IMPLICIT_CONVERSION;
+ reloc->raw_offset = offset >> DUMP_RELOC_ALIGNMENT_BITS;
+ DISALLOW_IMPLICIT_CONVERSION;
+ if (dump_reloc_get_offset (*reloc) != offset)
+ error ("dump relocation out of range");
+}
+
+static void
+dump_fingerprint (const char *label, unsigned char const *xfingerprint)
+{
+ fprintf (stderr, "%s: ", label);
+ for (int i = 0; i < 32; ++i)
+ fprintf (stderr, "%02x", (unsigned) xfingerprint[i]);
+ fprintf (stderr, "\n");
+}
+
+/* Format of an Emacs portable dump file. All offsets are relative to
+ the beginning of the file. An Emacs portable dump file is coupled
+ to exactly the Emacs binary that produced it, so details of
+ alignment and endianness are unimportant.
+
+ An Emacs dump file contains the contents of the Lisp heap.
+ On startup, Emacs can start faster by mapping a dump file into
+ memory and using the objects contained inside it instead of
+ performing initialization from scratch.
+
+ The dump file can be loaded at arbitrary locations in memory, so it
+ includes a table of relocations that let Emacs adjust the pointers
+ embedded in the dump file to account for the location where it was
+ actually loaded.
+
+ Dump files can contain pointers to other objects in the dump file
+ or to parts of the Emacs binary. */
+struct dump_header
+{
+ /* File type magic. */
+ char magic[sizeof (dump_magic)];
+
+ /* Associated Emacs binary. */
+ unsigned char fingerprint[32];
+
+ /* Relocation table for the dump file; each entry is a
+ struct dump_reloc. */
+ struct dump_table_locator dump_relocs;
+
+ /* "Relocation" table we abuse to hold information about the
+ location and type of each lisp object in the dump. We need for
+ pdumper_object_type and ultimately for conservative GC
+ correctness. */
+ struct dump_table_locator object_starts;
+
+ /* Relocation table for Emacs; each entry is a struct
+ emacs_reloc. */
+ struct dump_table_locator emacs_relocs;
+
+ /* Start of sub-region of hot region that we can discard after load
+ completes. The discardable region ends at cold_start.
+
+ This region contains objects that we copy into the Emacs image at
+ dump-load time. */
+ dump_off discardable_start;
+
+ /* Start of the region that does not require relocations and that we
+ expect never to be modified. This region can be memory-mapped
+ directly from the backing dump file with the reasonable
+ expectation of taking few copy-on-write faults.
+
+ For correctness, however, this region must be modifible, since in
+ rare cases it is possible to see modifications to these bytes.
+ For example, this region contains string data, and it's
+ technically possible for someone to ASET a string character
+ (although nobody tends to do that).
+
+ The start of the cold region is always aligned on a page
+ boundary. */
+ dump_off cold_start;
+};
+
+/* Double-ended singly linked list. */
+struct dump_tailq
+{
+ Lisp_Object head;
+ Lisp_Object tail;
+ intptr_t length;
+};
+
+/* Queue of objects to dump. */
+struct dump_queue
+{
+ /* Objects with no link weights at all. Kept in dump order. */
+ struct dump_tailq zero_weight_objects;
+ /* Objects with simple link weight: just one entry of type
+ WEIGHT_NORMAL. Score in this special case is non-decreasing as
+ position increases, so we can avoid the need to rescan a big list
+ for each object by storing these objects in order. */
+ struct dump_tailq one_weight_normal_objects;
+ /* Likewise, for objects with one WEIGHT_STRONG weight. */
+ struct dump_tailq one_weight_strong_objects;
+ /* List of objects with complex link weights --- i.e., not one of
+ the above cases. Order is irrelevant, since we scan the whole
+ list every time. Relatively few objects end up here. */
+ struct dump_tailq fancy_weight_objects;
+ /* Hash table of link weights: maps an object to a list of zero or
+ more (BASIS . WEIGHT) pairs. As a special case, an object with
+ zero weight is marked by Qt in the hash table --- this way, we
+ can distinguish objects we've seen but that have no weight from
+ ones that we haven't seen at all. */
+ Lisp_Object link_weights;
+ /* Hash table mapping object to a sequence number --- used to
+ resolve ties. */
+ Lisp_Object sequence_numbers;
+ dump_off next_sequence_number;
+};
+
+enum cold_op
+ {
+ COLD_OP_OBJECT,
+ COLD_OP_STRING,
+ COLD_OP_CHARSET,
+ COLD_OP_BUFFER,
+ COLD_OP_BIGNUM,
+ };
+
+/* This structure controls what operations we perform inside
+ dump_object. */
+struct dump_flags
+{
+ /* Actually write object contents to the dump. Without this flag
+ set, we still scan objects and enqueue pointed-to objects; making
+ this flag false is useful when we want to process an object's
+ referents normally, but dump an object itself separately,
+ later. */
+ bool_bf dump_object_contents : 1;
+ /* Record object starts. We turn this flag off when writing to the
+ discardable section so that we don't trick conservative GC into
+ thinking we have objects there. Ignored (we never record object
+ starts) if dump_object_contents is false. */
+ bool_bf record_object_starts : 1;
+ /* Pack objects tighter than GC memory alignment would normally
+ require. Useful for objects copied into the Emacs image instead
+ of used directly from the loaded dump.
+ */
+ bool_bf pack_objects : 1;
+ /* Sometimes we dump objects that we've already scanned for outbound
+ references to other objects. These objects should not cause new
+ objects to enter the object dumping queue. This flag causes Emacs
+ to assert that no new objects are enqueued while dumping. */
+ bool_bf assert_already_seen : 1;
+ /* Punt on unstable hash tables: defer them to ctx->deferred_hash_tables. */
+ bool_bf defer_hash_tables : 1;
+ /* Punt on symbols: defer them to ctx->deferred_symbols. */
+ bool_bf defer_symbols : 1;
+ /* Punt on cold objects: defer them to ctx->cold_queue. */
+ bool_bf defer_cold_objects : 1;
+ /* Punt on copied objects: defer them to ctx->copied_queue. */
+ bool_bf defer_copied_objects : 1;
+};
+
+/* Information we use while we dump. Note that we're not the garbage
+ collector and can operate under looser constraints: specifically,
+ we allocate memory during the dumping process. */
+struct dump_context
+{
+ /* Header we'll write to the dump file when done. */
+ struct dump_header header;
+
+ Lisp_Object old_purify_flag;
+ Lisp_Object old_post_gc_hook;
+ Lisp_Object old_process_environment;
+
+#ifdef REL_ALLOC
+ bool blocked_ralloc;
+#endif
+
+ /* File descriptor for dumpfile; < 0 if closed. */
+ int fd;
+ /* Name of dump file --- used for error reporting. */
+ Lisp_Object dump_filename;
+ /* Current offset in dump file. */
+ dump_off offset;
+
+ /* Starting offset of current object. */
+ dump_off obj_offset;
+
+ /* Flags currently in effect for dumping. */
+ struct dump_flags flags;
+
+ dump_off end_heap;
+
+ /* Hash mapping objects we've already dumped to their offsets. */
+ Lisp_Object objects_dumped;
+
+ /* Hash mapping objects to where we got them. Used for debugging. */
+ Lisp_Object referrers;
+ Lisp_Object current_referrer;
+ bool have_current_referrer;
+
+ /* Queue of objects to dump. */
+ struct dump_queue dump_queue;
+
+ /* Deferred object lists. */
+ Lisp_Object deferred_hash_tables;
+ Lisp_Object deferred_symbols;
+
+ /* Fixups in the dump file. */
+ Lisp_Object fixups;
+
+ /* Hash table of staticpro values: avoids double relocations. */
+ Lisp_Object staticpro_table;
+
+ /* Hash table mapping symbols to their pre-copy-queue fwd or blv
+ structures (which we dump immediately before the start of the
+ discardable section). */
+ Lisp_Object symbol_aux;
+ /* Queue of copied objects for special treatment. */
+ Lisp_Object copied_queue;
+ /* Queue of cold objects to dump. */
+ Lisp_Object cold_queue;
+
+ /* Relocations in the dump. */
+ Lisp_Object dump_relocs;
+
+ /* Object starts. */
+ Lisp_Object object_starts;
+
+ /* Relocations in Emacs. */
+ Lisp_Object emacs_relocs;
+
+ /* Hash table mapping bignums to their _data_ blobs, which we store
+ in the cold section. The actual Lisp_Bignum objects are normal
+ heap objects. */
+ Lisp_Object bignum_data;
+
+ unsigned number_hot_relocations;
+ unsigned number_discardable_relocations;
+};
+
+/* These special values for use as offsets in dump_remember_object and
+ dump_recall_object indicate that the corresponding object isn't in
+ the dump yet (and so it has no valid offset), but that it's on one
+ of our to-be-dumped-later object queues (or that we haven't seen it
+ at all). All values must be non-positive, since positive values
+ are physical dump offsets. */
+enum dump_object_special_offset
+ {
+ DUMP_OBJECT_IS_RUNTIME_MAGIC = -6,
+ DUMP_OBJECT_ON_COPIED_QUEUE = -5,
+ DUMP_OBJECT_ON_HASH_TABLE_QUEUE = -4,
+ DUMP_OBJECT_ON_SYMBOL_QUEUE = -3,
+ DUMP_OBJECT_ON_COLD_QUEUE = -2,
+ DUMP_OBJECT_ON_NORMAL_QUEUE = -1,
+ DUMP_OBJECT_NOT_SEEN = 0,
+ };
+
+/* Weights for score scores for object non-locality. */
+enum link_weight_enum
+ {
+ WEIGHT_NONE_VALUE = 0,
+ WEIGHT_NORMAL_VALUE = 1000,
+ WEIGHT_STRONG_VALUE = 1200,
+ };
+
+struct link_weight
+{
+ /* Wrapped in a struct to break unwanted implicit conversion. */
+ enum link_weight_enum value;
+};
+
+#define LINK_WEIGHT_LITERAL(x) ((struct link_weight){.value=(x)})
+#define WEIGHT_NONE LINK_WEIGHT_LITERAL (WEIGHT_NONE_VALUE)
+#define WEIGHT_NORMAL LINK_WEIGHT_LITERAL (WEIGHT_NORMAL_VALUE)
+#define WEIGHT_STRONG LINK_WEIGHT_LITERAL (WEIGHT_STRONG_VALUE)
+
+
+/* Dump file creation */
+
+static dump_off dump_object (struct dump_context *ctx, Lisp_Object object);
+static dump_off dump_object_for_offset (struct dump_context *ctx,
+ Lisp_Object object);
+
+/* Like the Lisp function `push'. Return NEWELT. */
+static Lisp_Object
+dump_push (Lisp_Object *where, Lisp_Object newelt)
+{
+ *where = Fcons (newelt, *where);
+ return newelt;
+}
+
+/* Like the Lisp function `pop'. */
+static Lisp_Object
+dump_pop (Lisp_Object *where)
+{
+ Lisp_Object ret = XCAR (*where);
+ *where = XCDR (*where);
+ return ret;
+}
+
+static bool
+dump_tracking_referrers_p (struct dump_context *ctx)
+{
+ return !NILP (ctx->referrers);
+}
+
+static void
+dump_set_have_current_referrer (struct dump_context *ctx, bool have)
+{
+#ifdef ENABLE_CHECKING
+ ctx->have_current_referrer = have;
+#endif
+}
+
+/* Remember the reason objects are enqueued.
+
+ Until DUMP_CLEAR_REFERRER is called, any objects enqueued are being
+ enqueued because OBJECT refers to them. It is not legal to enqueue
+ objects without a referer set. We check this constraint
+ at runtime.
+
+ It is illegal to call DUMP_SET_REFERRER twice without an
+ intervening call to DUMP_CLEAR_REFERRER.
+
+ Define as a macro so we can avoid evaluating OBJECT
+ if we dont want referrer tracking. */
+#define DUMP_SET_REFERRER(ctx, object) \
+ do \
+ { \
+ struct dump_context *_ctx = (ctx); \
+ eassert (!_ctx->have_current_referrer); \
+ dump_set_have_current_referrer (_ctx, true); \
+ if (dump_tracking_referrers_p (_ctx)) \
+ ctx->current_referrer = (object); \
+ } \
+ while (0)
+
+/* Unset the referer that DUMP_SET_REFERRER set.
+
+ Named with upper-case letters for symmetry with
+ DUMP_SET_REFERRER. */
+static void
+DUMP_CLEAR_REFERRER (struct dump_context *ctx)
+{
+ eassert (ctx->have_current_referrer);
+ dump_set_have_current_referrer (ctx, false);
+ if (dump_tracking_referrers_p (ctx))
+ ctx->current_referrer = Qnil;
+}
+
+static Lisp_Object
+dump_ptr_referrer (const char *label, void const *address)
+{
+ char buf[128];
+ buf[0] = '\0';
+ sprintf (buf, "%s @ %p", label, address);
+ return build_string (buf);
+}
+
+static void
+print_paths_to_root (struct dump_context *ctx, Lisp_Object object);
+
+static void dump_remember_cold_op (struct dump_context *ctx,
+ enum cold_op op,
+ Lisp_Object arg);
+
+_Noreturn
+static void
+error_unsupported_dump_object (struct dump_context *ctx,
+ Lisp_Object object,
+ const char *msg)
+{
+ if (dump_tracking_referrers_p (ctx))
+ print_paths_to_root (ctx, object);
+ error ("unsupported object type in dump: %s", msg);
+}
+
+static uintptr_t
+emacs_basis (void)
+{
+ return (uintptr_t) &Vpurify_flag;
+}
+
+static void *
+emacs_ptr_at (const ptrdiff_t offset)
+{
+ /* TODO: assert somehow that the result is actually in the Emacs
+ image. */
+ return (void *) (emacs_basis () + offset);
+}
+
+static dump_off
+emacs_offset (const void *emacs_ptr)
+{
+ /* TODO: assert that EMACS_PTR is actually in the Emacs image. */
+ eassert (emacs_ptr != NULL);
+ intptr_t emacs_ptr_value = (intptr_t) emacs_ptr;
+ ptrdiff_t emacs_ptr_relative = emacs_ptr_value - (intptr_t) emacs_basis ();
+ return ptrdiff_t_to_dump_off (emacs_ptr_relative);
+}
+
+/* Return whether OBJECT is a symbol the storage of which is built
+ into Emacs (and so is invariant across ASLR). */
+static bool
+dump_builtin_symbol_p (Lisp_Object object)
+{
+ if (!SYMBOLP (object))
+ return false;
+ char *bp = (char *) lispsym;
+ struct Lisp_Symbol *s = XSYMBOL (object);
+ char *sp = (char *) s;
+ return bp <= sp && sp < bp + sizeof (lispsym);
+}
+
+/* Return whether OBJECT has the same bit pattern in all Emacs
+ invocations --- i.e., is invariant across a dump. Note that some
+ self-representing objects still need to be dumped!
+*/
+static bool
+dump_object_self_representing_p (Lisp_Object object)
+{
+ bool result;
+ ALLOW_IMPLICIT_CONVERSION;
+ result = FIXNUMP (object) || dump_builtin_symbol_p (object);
+ DISALLOW_IMPLICIT_CONVERSION;
+ return result;
+}
+
+#define DEFINE_FROMLISP_FUNC(fn, type) \
+ static type \
+ fn (Lisp_Object value) \
+ { \
+ ALLOW_IMPLICIT_CONVERSION; \
+ if (FIXNUMP (value)) \
+ return XFIXNUM (value); \
+ eassert (BIGNUMP (value)); \
+ return TYPE_SIGNED (type) \
+ ? bignum_to_intmax (value) \
+ : bignum_to_uintmax (value); \
+ DISALLOW_IMPLICIT_CONVERSION; \
+ }
+
+#define DEFINE_TOLISP_FUNC(fn, type) \
+ static Lisp_Object \
+ fn (type value) \
+ { \
+ return INT_TO_INTEGER (value); \
+ }
+
+DEFINE_FROMLISP_FUNC (intmax_t_from_lisp, intmax_t);
+DEFINE_TOLISP_FUNC (intmax_t_to_lisp, intmax_t);
+DEFINE_FROMLISP_FUNC (dump_off_from_lisp, dump_off);
+DEFINE_TOLISP_FUNC (dump_off_to_lisp, dump_off);
+
+static void
+dump_write (struct dump_context *ctx, const void *buf, dump_off nbyte)
+{
+ eassert (nbyte == 0 || buf != NULL);
+ eassert (ctx->obj_offset == 0);
+ eassert (ctx->flags.dump_object_contents);
+ if (emacs_write (ctx->fd, buf, nbyte) < nbyte)
+ report_file_error ("Could not write to dump file", ctx->dump_filename);
+ ctx->offset += nbyte;
+}
+
+static Lisp_Object
+make_eq_hash_table (void)
+{
+ return CALLN (Fmake_hash_table, QCtest, Qeq);
+}
+
+static void
+dump_tailq_init (struct dump_tailq *tailq)
+{
+ tailq->head = tailq->tail = Qnil;
+ tailq->length = 0;
+}
+
+static intptr_t
+dump_tailq_length (const struct dump_tailq *tailq)
+{
+ return tailq->length;
+}
+
+__attribute__((unused))
+static void
+dump_tailq_prepend (struct dump_tailq *tailq, Lisp_Object value)
+{
+ Lisp_Object link = Fcons (value, tailq->head);
+ tailq->head = link;
+ if (NILP (tailq->tail))
+ tailq->tail = link;
+ tailq->length += 1;
+}
+
+__attribute__((unused))
+static void
+dump_tailq_append (struct dump_tailq *tailq, Lisp_Object value)
+{
+ Lisp_Object link = Fcons (value, Qnil);
+ if (NILP (tailq->head))
+ {
+ eassert (NILP (tailq->tail));
+ tailq->head = tailq->tail = link;
+ }
+ else
+ {
+ eassert (!NILP (tailq->tail));
+ XSETCDR (tailq->tail, link);
+ tailq->tail = link;
+ }
+ tailq->length += 1;
+}
+
+static bool
+dump_tailq_empty_p (struct dump_tailq *tailq)
+{
+ return NILP (tailq->head);
+}
+
+static Lisp_Object
+dump_tailq_peek (struct dump_tailq *tailq)
+{
+ eassert (!dump_tailq_empty_p (tailq));
+ return XCAR (tailq->head);
+}
+
+static Lisp_Object
+dump_tailq_pop (struct dump_tailq *tailq)
+{
+ eassert (!dump_tailq_empty_p (tailq));
+ eassert (tailq->length > 0);
+ tailq->length -= 1;
+ Lisp_Object value = XCAR (tailq->head);
+ tailq->head = XCDR (tailq->head);
+ if (NILP (tailq->head))
+ tailq->tail = Qnil;
+ return value;
+}
+
+static void
+dump_seek (struct dump_context *ctx, dump_off offset)
+{
+ eassert (ctx->obj_offset == 0);
+ if (lseek (ctx->fd, offset, SEEK_SET) < 0)
+ report_file_error ("Setting file position",
+ ctx->dump_filename);
+ ctx->offset = offset;
+}
+
+static void
+dump_write_zero (struct dump_context *ctx, dump_off nbytes)
+{
+ while (nbytes > 0)
+ {
+ uintmax_t zero = 0;
+ dump_off to_write = sizeof (zero);
+ if (to_write > nbytes)
+ to_write = nbytes;
+ dump_write (ctx, &zero, to_write);
+ nbytes -= to_write;
+ }
+}
+
+static void
+dump_align_output (struct dump_context *ctx, int alignment)
+{
+ if (ctx->offset % alignment != 0)
+ dump_write_zero (ctx, alignment - (ctx->offset % alignment));
+}
+
+static dump_off
+dump_object_start (struct dump_context *ctx,
+ void *out,
+ dump_off outsz)
+{
+ /* We dump only one object at a time, so obj_offset should be
+ invalid on entry to this function. */
+ eassert (ctx->obj_offset == 0);
+ int alignment = ctx->flags.pack_objects ? 1 : DUMP_ALIGNMENT;
+ if (ctx->flags.dump_object_contents)
+ dump_align_output (ctx, alignment);
+ ctx->obj_offset = ctx->offset;
+ memset (out, 0, outsz);
+ return ctx->offset;
+}
+
+static dump_off
+dump_object_finish (struct dump_context *ctx,
+ const void *out,
+ dump_off sz)
+{
+ dump_off offset = ctx->obj_offset;
+ eassert (offset > 0);
+ eassert (offset == ctx->offset); /* No intervening writes. */
+ ctx->obj_offset = 0;
+ if (ctx->flags.dump_object_contents)
+ dump_write (ctx, out, sz);
+ return offset;
+}
+
+/* Return offset at which OBJECT has been dumped, or one of the dump_object_special_offset
+ negative values, or DUMP_OBJECT_NOT_SEEN. */
+static dump_off
+dump_recall_object (struct dump_context *ctx, Lisp_Object object)
+{
+ Lisp_Object dumped = ctx->objects_dumped;
+ return dump_off_from_lisp (Fgethash (object, dumped,
+ make_fixnum (DUMP_OBJECT_NOT_SEEN)));
+}
+
+static void
+dump_remember_object (struct dump_context *ctx,
+ Lisp_Object object,
+ dump_off offset)
+{
+ Fputhash (object,
+ dump_off_to_lisp (offset),
+ ctx->objects_dumped);
+}
+
+static void
+dump_note_reachable (struct dump_context *ctx, Lisp_Object object)
+{
+ eassert (ctx->have_current_referrer);
+ if (!dump_tracking_referrers_p (ctx))
+ return;
+ Lisp_Object referrer = ctx->current_referrer;
+ Lisp_Object obj_referrers = Fgethash (object, ctx->referrers, Qnil);
+ if (NILP (Fmemq (referrer, obj_referrers)))
+ Fputhash (object, Fcons (referrer, obj_referrers), ctx->referrers);
+}
+
+/* If this object lives in the Emacs image and not on the heap, return
+ a pointer to the object data. Otherwise, return NULL. */
+static void *
+dump_object_emacs_ptr (Lisp_Object lv)
+{
+ if (SUBRP (lv))
+ return XSUBR (lv);
+ if (dump_builtin_symbol_p (lv))
+ return XSYMBOL (lv);
+ if (XTYPE (lv) == Lisp_Vectorlike
+ && PSEUDOVECTOR_TYPEP (&XVECTOR (lv)->header, PVEC_THREAD)
+ && main_thread_p (XTHREAD (lv)))
+ return XTHREAD (lv);
+ return NULL;
+}
+
+static void
+dump_queue_init (struct dump_queue *dump_queue)
+{
+ dump_tailq_init (&dump_queue->zero_weight_objects);
+ dump_tailq_init (&dump_queue->one_weight_normal_objects);
+ dump_tailq_init (&dump_queue->one_weight_strong_objects);
+ dump_tailq_init (&dump_queue->fancy_weight_objects);
+ dump_queue->link_weights = make_eq_hash_table ();
+ dump_queue->sequence_numbers = make_eq_hash_table ();
+ dump_queue->next_sequence_number = 1;
+}
+
+static bool
+dump_queue_empty_p (struct dump_queue *dump_queue)
+{
+ bool is_empty =
+ EQ (Fhash_table_count (dump_queue->sequence_numbers),
+ make_fixnum (0));
+ eassert (EQ (Fhash_table_count (dump_queue->sequence_numbers),
+ Fhash_table_count (dump_queue->link_weights)));
+ if (!is_empty)
+ {
+ eassert (!dump_tailq_empty_p (&dump_queue->zero_weight_objects)
+ || !dump_tailq_empty_p (&dump_queue->one_weight_normal_objects)
+ || !dump_tailq_empty_p (&dump_queue->one_weight_strong_objects)
+ || !dump_tailq_empty_p (&dump_queue->fancy_weight_objects));
+ }
+ else
+ {
+ /* If we're empty, we can still have a few stragglers on one of
+ the above queues. */
+ }
+
+ return is_empty;
+}
+
+static void
+dump_queue_push_weight (Lisp_Object *weight_list,
+ dump_off basis,
+ struct link_weight weight)
+{
+ if (EQ (*weight_list, Qt))
+ *weight_list = Qnil;
+ dump_push (weight_list, Fcons (dump_off_to_lisp (basis),
+ dump_off_to_lisp (weight.value)));
+}
+
+static void
+dump_queue_enqueue (struct dump_queue *dump_queue,
+ Lisp_Object object,
+ dump_off basis,
+ struct link_weight weight)
+{
+ Lisp_Object weights = Fgethash (object, dump_queue->link_weights, Qnil);
+ Lisp_Object orig_weights = weights;
+ /* N.B. want to find the last item of a given weight in each queue
+ due to prepend use. */
+ bool use_single_queues = true;
+ if (NILP (weights))
+ {
+ /* Object is new. */
+ dump_trace ("new object %016x weight=%u\n",
+ (unsigned) XLI (object),
+ (unsigned) weight.value);
+
+ if (weight.value == WEIGHT_NONE.value)
+ {
+ eassert (weight.value == 0);
+ dump_tailq_prepend (&dump_queue->zero_weight_objects, object);
+ weights = Qt;
+ }
+ else if (!use_single_queues)
+ {
+ dump_tailq_prepend (&dump_queue->fancy_weight_objects, object);
+ dump_queue_push_weight (&weights, basis, weight);
+ }
+ else if (weight.value == WEIGHT_NORMAL.value)
+ {
+ dump_tailq_prepend (&dump_queue->one_weight_normal_objects, object);
+ dump_queue_push_weight (&weights, basis, weight);
+ }
+ else if (weight.value == WEIGHT_STRONG.value)
+ {
+ dump_tailq_prepend (&dump_queue->one_weight_strong_objects, object);
+ dump_queue_push_weight (&weights, basis, weight);
+ }
+ else
+ {
+ emacs_abort ();
+ }
+
+ Fputhash (object,
+ dump_off_to_lisp(dump_queue->next_sequence_number++),
+ dump_queue->sequence_numbers);
+ }
+ else
+ {
+ /* Object was already on the queue. It's okay for an object to
+ be on multiple queues so long as we maintain order
+ invariants: attempting to dump an object multiple times is
+ harmless, and most of the time, an object is only referenced
+ once before being dumped, making this code path uncommon. */
+ if (weight.value != WEIGHT_NONE.value)
+ {
+ if (EQ (weights, Qt))
+ {
+ /* Object previously had a zero weight. Once we
+ incorporate the link weight attached to this call,
+ the object will have a single weight. Put the object
+ on the appropriate single-weight queue. */
+ weights = Qnil;
+ struct dump_tailq *tailq;
+ if (!use_single_queues)
+ tailq = &dump_queue->fancy_weight_objects;
+ else if (weight.value == WEIGHT_NORMAL.value)
+ tailq = &dump_queue->one_weight_normal_objects;
+ else if (weight.value == WEIGHT_STRONG.value)
+ tailq = &dump_queue->one_weight_strong_objects;
+ else
+ emacs_abort ();
+ dump_tailq_prepend (tailq, object);
+ }
+ else if (use_single_queues && NILP (XCDR (weights)))
+ dump_tailq_prepend (&dump_queue->fancy_weight_objects, object);
+ dump_queue_push_weight (&weights, basis, weight);
+ }
+ }
+
+ if (!EQ (weights, orig_weights))
+ Fputhash (object, weights, dump_queue->link_weights);
+}
+
+static float
+dump_calc_link_score (dump_off basis,
+ dump_off link_basis,
+ dump_off link_weight)
+{
+ float distance = (float)(basis - link_basis);
+ eassert (distance >= 0);
+ float link_score = powf (distance, -0.2f);
+ return powf (link_score, (float) link_weight / 1000.0f);
+}
+
+/* Compute the score score for a queued object.
+
+ OBJECT is the object to query, which must currently be queued for
+ dumping. BASIS is the offset at which we would be
+ dumping the object; score is computed relative to BASIS and the
+ various BASIS values supplied to dump_add_link_weight --- the
+ further an object is from its referrers, the greater the
+ score. */
+static float
+dump_queue_compute_score (struct dump_queue *dump_queue,
+ Lisp_Object object,
+ dump_off basis)
+{
+ float score = 0;
+ Lisp_Object object_link_weights =
+ Fgethash (object, dump_queue->link_weights, Qnil);
+ if (EQ (object_link_weights, Qt))
+ object_link_weights = Qnil;
+ while (!NILP (object_link_weights))
+ {
+ Lisp_Object basis_weight_pair = dump_pop (&object_link_weights);
+ dump_off link_basis = dump_off_from_lisp (XCAR (basis_weight_pair));
+ dump_off link_weight = dump_off_from_lisp (XCDR (basis_weight_pair));
+ score += dump_calc_link_score (basis, link_basis, link_weight);
+ }
+ return score;
+}
+
+/* Scan the fancy part of the dump queue.
+
+ BASIS is the position at which to evaluate the score function,
+ usually ctx->offset.
+
+ If we have at least one entry in the queue, return the pointer (in
+ the singly-linked list) to the cons containing the object via
+ *OUT_HIGHEST_SCORE_CONS_PTR and return its score.
+
+ If the queue is empty, set *OUT_HIGHEST_SCORE_CONS_PTR to NULL
+ and return negative infinity. */
+static float
+dump_queue_scan_fancy (struct dump_queue *dump_queue,
+ dump_off basis,
+ Lisp_Object **out_highest_score_cons_ptr)
+{
+ Lisp_Object *cons_ptr = &dump_queue->fancy_weight_objects.head;
+ Lisp_Object *highest_score_cons_ptr = NULL;
+ float highest_score = -INFINITY;
+ bool first = true;
+
+ while (!NILP (*cons_ptr))
+ {
+ Lisp_Object queued_object = XCAR (*cons_ptr);
+ float score = dump_queue_compute_score (dump_queue, queued_object, basis);
+ if (first || score >= highest_score)
+ {
+ highest_score_cons_ptr = cons_ptr;
+ highest_score = score;
+ if (first)
+ first = false;
+ }
+ cons_ptr = &XCONS (*cons_ptr)->u.s.u.cdr;
+ }
+
+ *out_highest_score_cons_ptr = highest_score_cons_ptr;
+ return highest_score;
+}
+
+/* Return the sequence number of OBJECT.
+
+ Return -1 if object doesn't have a sequence number. This situation
+ can occur when we've double-queued an object. If this happens, we
+ discard the errant object and try again. */
+static dump_off
+dump_queue_sequence (struct dump_queue *dump_queue,
+ Lisp_Object object)
+{
+ Lisp_Object n = Fgethash (object, dump_queue->sequence_numbers, Qnil);
+ return NILP (n) ? -1 : dump_off_from_lisp (n);
+}
+
+/* Find score and sequence at head of a one-weight object queue.
+
+ Transparently discard stale objects from head of queue. BASIS
+ is the baseness for score computation.
+
+ We organize these queues so that score is strictly decreasing, so
+ examining the head is sufficient. */
+static void
+dump_queue_find_score_of_one_weight_queue (struct dump_queue *dump_queue,
+ dump_off basis,
+ struct dump_tailq *one_weight_queue,
+ float *out_score,
+ int *out_sequence)
+{
+ /* Transparently discard stale objects from the head of this queue. */
+ do
+ {
+ if (dump_tailq_empty_p (one_weight_queue))
+ {
+ *out_score = -INFINITY;
+ *out_sequence = 0;
+ }
+ else
+ {
+ Lisp_Object head = dump_tailq_peek (one_weight_queue);
+ *out_sequence = dump_queue_sequence (dump_queue, head);
+ if (*out_sequence < 0)
+ dump_tailq_pop (one_weight_queue);
+ else
+ *out_score =
+ dump_queue_compute_score (dump_queue, head, basis);
+ }
+ }
+ while (*out_sequence < 0);
+}
+
+/* Pop the next object to dump from the dump queue.
+
+ BASIS is the dump offset at which to evaluate score.
+
+ The object returned is the queued object with the greatest score;
+ by side effect, the object is removed from the dump queue.
+ The dump queue must not be empty. */
+static Lisp_Object
+dump_queue_dequeue (struct dump_queue *dump_queue, dump_off basis)
+{
+ eassert (EQ (Fhash_table_count (dump_queue->sequence_numbers),
+ Fhash_table_count (dump_queue->link_weights)));
+
+ eassert (XFIXNUM (Fhash_table_count (dump_queue->sequence_numbers))
+ <= (dump_tailq_length (&dump_queue->fancy_weight_objects)
+ + dump_tailq_length (&dump_queue->zero_weight_objects)
+ + dump_tailq_length (&dump_queue->one_weight_normal_objects)
+ + dump_tailq_length (&dump_queue->one_weight_strong_objects)));
+
+ bool dump_object_counts = true;
+ if (dump_object_counts)
+ dump_trace
+ ("dump_queue_dequeue basis=%d fancy=%u zero=%u "
+ "normal=%u strong=%u hash=%u\n",
+ basis,
+ (unsigned) dump_tailq_length (&dump_queue->fancy_weight_objects),
+ (unsigned) dump_tailq_length (&dump_queue->zero_weight_objects),
+ (unsigned) dump_tailq_length (&dump_queue->one_weight_normal_objects),
+ (unsigned) dump_tailq_length (&dump_queue->one_weight_strong_objects),
+ (unsigned) XFIXNUM (Fhash_table_count (dump_queue->link_weights)));
+
+ static const int nr_candidates = 3;
+ struct candidate
+ {
+ float score;
+ dump_off sequence;
+ } candidates[nr_candidates];
+
+ Lisp_Object *fancy_cons = NULL;
+ candidates[0].sequence = 0;
+ do
+ {
+ if (candidates[0].sequence < 0)
+ *fancy_cons = XCDR (*fancy_cons); /* Discard stale object. */
+ candidates[0].score = dump_queue_scan_fancy (dump_queue, basis,
+ &fancy_cons);
+ candidates[0].sequence =
+ candidates[0].score > -INFINITY
+ ? dump_queue_sequence (dump_queue, XCAR (*fancy_cons))
+ : 0;
+ }
+ while (candidates[0].sequence < 0);
+
+ dump_queue_find_score_of_one_weight_queue
+ (dump_queue, basis,
+ &dump_queue->one_weight_normal_objects,
+ &candidates[1].score,
+ &candidates[1].sequence);
+
+ dump_queue_find_score_of_one_weight_queue
+ (dump_queue, basis,
+ &dump_queue->one_weight_strong_objects,
+ &candidates[2].score,
+ &candidates[2].sequence);
+
+ int best = -1;
+ for (int i = 0; i < nr_candidates; ++i)
+ {
+ eassert (candidates[i].sequence >= 0);
+ if (candidates[i].score > -INFINITY
+ && (best < 0
+ || candidates[i].score > candidates[best].score
+ || (candidates[i].score == candidates[best].score
+ && candidates[i].sequence < candidates[best].sequence)))
+ best = i;
+ }
+
+ Lisp_Object result;
+ const char *src;
+ if (best < 0)
+ {
+ src = "zero";
+ result = dump_tailq_pop (&dump_queue->zero_weight_objects);
+ }
+ else if (best == 0)
+ {
+ src = "fancy";
+ result = dump_tailq_pop (&dump_queue->fancy_weight_objects);
+ }
+ else if (best == 1)
+ {
+ src = "normal";
+ result = dump_tailq_pop (&dump_queue->one_weight_normal_objects);
+ }
+ else if (best == 2)
+ {
+ src = "strong";
+ result = dump_tailq_pop (&dump_queue->one_weight_strong_objects);
+ }
+ else
+ emacs_abort ();
+
+ dump_trace (" result score=%f src=%s object=%016x\n",
+ best < 0 ? -1.0 : (double) candidates[best].score,
+ src,
+ (unsigned) XLI (result));
+
+ {
+ Lisp_Object weights = Fgethash (result, dump_queue->link_weights, Qnil);
+ while (!NILP (weights) && CONSP (weights))
+ {
+ Lisp_Object basis_weight_pair = dump_pop (&weights);
+ dump_off link_basis =
+ dump_off_from_lisp (XCAR (basis_weight_pair));
+ dump_off link_weight =
+ dump_off_from_lisp (XCDR (basis_weight_pair));
+ dump_trace
+ (" link_basis=%d distance=%d weight=%d contrib=%f\n",
+ link_basis,
+ basis - link_basis,
+ link_weight,
+ (double) dump_calc_link_score (basis, link_basis, link_weight));
+ }
+ }
+
+ Fremhash (result, dump_queue->link_weights);
+ Fremhash (result, dump_queue->sequence_numbers);
+ return result;
+}
+
+/* Return whether we need to write OBJECT to the dump file. */
+static bool
+dump_object_needs_dumping_p (Lisp_Object object)
+{
+ /* Some objects, like symbols, are self-representing because they
+ have invariant bit patterns, but sometimes these objects have
+ associated data too, and these data-carrying objects need to be
+ included in the dump despite all references to them being
+ bitwise-invariant. */
+ return (!dump_object_self_representing_p (object)
+ || dump_object_emacs_ptr (object));
+}
+
+static void
+dump_enqueue_object (struct dump_context *ctx,
+ Lisp_Object object,
+ struct link_weight weight)
+{
+ if (dump_object_needs_dumping_p (object))
+ {
+ dump_off state = dump_recall_object (ctx, object);
+ bool already_dumped_object = state > DUMP_OBJECT_NOT_SEEN;
+ if (ctx->flags.assert_already_seen)
+ eassert (already_dumped_object);
+ if (!already_dumped_object)
+ {
+ if (state == DUMP_OBJECT_NOT_SEEN)
+ {
+ state = DUMP_OBJECT_ON_NORMAL_QUEUE;
+ dump_remember_object (ctx, object, state);
+ }
+ /* Note that we call dump_queue_enqueue even if the object
+ is already on the normal queue: multiple enqueue calls
+ can increase the object's weight. */
+ if (state == DUMP_OBJECT_ON_NORMAL_QUEUE)
+ dump_queue_enqueue (&ctx->dump_queue,
+ object,
+ ctx->offset,
+ weight);
+ }
+ }
+ /* Always remember the path to this object. */
+ dump_note_reachable (ctx, object);
+}
+
+static void
+print_paths_to_root_1 (struct dump_context *ctx,
+ Lisp_Object object,
+ int level)
+{
+ Lisp_Object referrers = Fgethash (object, ctx->referrers, Qnil);
+ while (!NILP (referrers))
+ {
+ Lisp_Object referrer = XCAR (referrers);
+ referrers = XCDR (referrers);
+ Lisp_Object repr = Fprin1_to_string (referrer, Qnil);
+ for (int i = 0; i < level; ++i)
+ fputc (' ', stderr);
+ fprintf (stderr, "%s\n", SDATA (repr));
+ print_paths_to_root_1 (ctx, referrer, level + 1);
+ }
+}
+
+static void
+print_paths_to_root (struct dump_context *ctx, Lisp_Object object)
+{
+ print_paths_to_root_1 (ctx, object, 0);
+}
+
+static void
+dump_remember_cold_op (struct dump_context *ctx,
+ enum cold_op op,
+ Lisp_Object arg)
+{
+ if (ctx->flags.dump_object_contents)
+ dump_push (&ctx->cold_queue, Fcons (make_fixnum (op), arg));
+}
+
+/* Add a dump relocation that points into Emacs.
+
+ Add a relocation that updates the pointer stored at DUMP_OFFSET to
+ point into the Emacs binary upon dump load. The pointer-sized
+ value at DUMP_OFFSET in the dump file should contain a number
+ relative to emacs_basis(). */
+static void
+dump_reloc_dump_to_emacs_ptr_raw (struct dump_context *ctx,
+ dump_off dump_offset)
+{
+ if (ctx->flags.dump_object_contents)
+ dump_push (&ctx->dump_relocs,
+ list2 (make_fixnum (RELOC_DUMP_TO_EMACS_PTR_RAW),
+ dump_off_to_lisp (dump_offset)));
+}
+
+/* Add a dump relocation that points a Lisp_Object back at the dump.
+
+ Add a relocation that updates the Lisp_Object at DUMP_OFFSET in the
+ dump to point to another object in the dump. The Lisp_Object-sized
+ value at DUMP_OFFSET in the dump file should contain the offset of
+ the target object relative to the start of the dump. */
+static void
+dump_reloc_dump_to_dump_lv (struct dump_context *ctx,
+ dump_off dump_offset,
+ enum Lisp_Type type)
+{
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ int reloc_type;
+ switch (type)
+ {
+ case Lisp_Symbol:
+ case Lisp_String:
+ case Lisp_Vectorlike:
+ case Lisp_Cons:
+ case Lisp_Float:
+ reloc_type = RELOC_DUMP_TO_DUMP_LV + type;
+ break;
+ default:
+ emacs_abort ();
+ }
+
+ dump_push (&ctx->dump_relocs,
+ list2 (make_fixnum (reloc_type),
+ dump_off_to_lisp (dump_offset)));
+}
+
+/* Add a dump relocation that points a raw pointer back at the dump.
+
+ Add a relocation that updates the raw pointer at DUMP_OFFSET in the
+ dump to point to another object in the dump. The pointer-sized
+ value at DUMP_OFFSET in the dump file should contain the offset of
+ the target object relative to the start of the dump. */
+static void
+dump_reloc_dump_to_dump_ptr_raw (struct dump_context *ctx,
+ dump_off dump_offset)
+{
+ if (ctx->flags.dump_object_contents)
+ dump_push (&ctx->dump_relocs,
+ list2 (make_fixnum (RELOC_DUMP_TO_DUMP_PTR_RAW),
+ dump_off_to_lisp (dump_offset)));
+}
+
+/* Add a dump relocation that points to a Lisp object in Emacs.
+
+ Add a relocation that updates the Lisp_Object at DUMP_OFFSET in the
+ dump to point to a lisp object in Emacs. The Lisp_Object-sized
+ value at DUMP_OFFSET in the dump file should contain the offset of
+ the target object relative to emacs_basis(). TYPE is the type of
+ Lisp value. */
+static void
+dump_reloc_dump_to_emacs_lv (struct dump_context *ctx,
+ dump_off dump_offset,
+ enum Lisp_Type type)
+{
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ int reloc_type;
+ switch (type)
+ {
+ case Lisp_String:
+ case Lisp_Vectorlike:
+ case Lisp_Cons:
+ case Lisp_Float:
+ reloc_type = RELOC_DUMP_TO_EMACS_LV + type;
+ break;
+ default:
+ emacs_abort ();
+ }
+
+ dump_push (&ctx->dump_relocs,
+ list2 (make_fixnum (reloc_type),
+ dump_off_to_lisp (dump_offset)));
+}
+
+/* Add an Emacs relocation that copies arbitrary bytes from the dump.
+
+ When the dump is loaded, Emacs copies SIZE bytes from OFFSET in
+ dump to LOCATION in the Emacs data section. This copying happens
+ after other relocations, so it's all right to, say, copy a
+ Lisp_Object (since by the time we copy the Lisp_Object, it'll have
+ been adjusted to account for the location of the running Emacs and
+ dump file). */
+static void
+dump_emacs_reloc_copy_from_dump (struct dump_context *ctx, dump_off dump_offset,
+ void *emacs_ptr, dump_off size)
+{
+ eassert (size >= 0);
+ eassert (size < (1 << EMACS_RELOC_LENGTH_BITS));
+
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ if (size == 0)
+ return;
+
+ eassert (dump_offset >= 0);
+ dump_push (&ctx->emacs_relocs,
+ list4 (make_fixnum (RELOC_EMACS_COPY_FROM_DUMP),
+ dump_off_to_lisp (emacs_offset (emacs_ptr)),
+ dump_off_to_lisp (dump_offset),
+ dump_off_to_lisp (size)));
+}
+
+/* Add an Emacs relocation that sets values to arbitrary bytes.
+
+ When the dump is loaded, Emacs copies SIZE bytes from the
+ relocation itself to the adjusted location inside Emacs EMACS_PTR.
+ SIZE is the number of bytes to copy. See struct emacs_reloc for
+ the maximum size that this mechanism can support. The value comes
+ from VALUE_PTR.
+ */
+static void
+dump_emacs_reloc_immediate (struct dump_context *ctx,
+ const void *emacs_ptr,
+ const void *value_ptr,
+ dump_off size)
+{
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ intmax_t value = 0;
+ eassert (size <= sizeof (value));
+ memcpy (&value, value_ptr, size);
+ dump_push (&ctx->emacs_relocs,
+ list4 (make_fixnum (RELOC_EMACS_IMMEDIATE),
+ dump_off_to_lisp (emacs_offset (emacs_ptr)),
+ intmax_t_to_lisp (value),
+ dump_off_to_lisp (size)));
+}
+
+#define DEFINE_EMACS_IMMEDIATE_FN(fnname, type) \
+ static void \
+ fnname (struct dump_context *ctx, \
+ const type *emacs_ptr, \
+ type value) \
+ { \
+ dump_emacs_reloc_immediate ( \
+ ctx, emacs_ptr, &value, sizeof (value)); \
+ }
+
+DEFINE_EMACS_IMMEDIATE_FN (dump_emacs_reloc_immediate_lv, Lisp_Object);
+DEFINE_EMACS_IMMEDIATE_FN (dump_emacs_reloc_immediate_ptrdiff_t, ptrdiff_t);
+DEFINE_EMACS_IMMEDIATE_FN (dump_emacs_reloc_immediate_intmax_t, intmax_t);
+DEFINE_EMACS_IMMEDIATE_FN (dump_emacs_reloc_immediate_int, int);
+DEFINE_EMACS_IMMEDIATE_FN (dump_emacs_reloc_immediate_bool, bool);
+
+/* Add an emacs relocation that makes a raw pointer in Emacs point
+ into the dump. */
+static void
+dump_emacs_reloc_to_dump_ptr_raw (struct dump_context *ctx,
+ const void *emacs_ptr, dump_off dump_offset)
+{
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ dump_push (&ctx->emacs_relocs,
+ list3 (make_fixnum (RELOC_EMACS_DUMP_PTR_RAW),
+ dump_off_to_lisp (emacs_offset (emacs_ptr)),
+ dump_off_to_lisp (dump_offset)));
+}
+
+/* Add an emacs relocation that points into the dump.
+
+ When the dump is loaded, the Lisp_Object at EMACS_ROOT in Emacs to
+ point to VALUE. VALUE can be any Lisp value; this function
+ automatically queues the value for dumping if necessary. */
+static void
+dump_emacs_reloc_to_lv (struct dump_context *ctx,
+ Lisp_Object const *emacs_ptr,
+ Lisp_Object value)
+{
+ if (dump_object_self_representing_p (value))
+ dump_emacs_reloc_immediate_lv (ctx, emacs_ptr, value);
+ else
+ {
+ if (ctx->flags.dump_object_contents)
+ /* Conditionally use RELOC_EMACS_EMACS_LV or
+ RELOC_EMACS_DUMP_LV depending on where the target object
+ lives. We could just have decode_emacs_reloc pick the
+ right type, but we might as well maintain the invariant
+ that the types on ctx->emacs_relocs correspond to the types
+ of emacs_relocs we actually emit. */
+ dump_push (&ctx->emacs_relocs,
+ list3 (make_fixnum (dump_object_emacs_ptr (value)
+ ? RELOC_EMACS_EMACS_LV
+ : RELOC_EMACS_DUMP_LV),
+ dump_off_to_lisp (emacs_offset (emacs_ptr)),
+ value));
+ dump_enqueue_object (ctx, value, WEIGHT_NONE);
+ }
+}
+
+/* Add an emacs relocation that makes a raw pointer in Emacs point
+ back into the Emacs image. */
+static void
+dump_emacs_reloc_to_emacs_ptr_raw (struct dump_context *ctx, void *emacs_ptr,
+ void const *target_emacs_ptr)
+{
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ dump_push (&ctx->emacs_relocs,
+ list3 (make_fixnum (RELOC_EMACS_EMACS_PTR_RAW),
+ dump_off_to_lisp (emacs_offset (emacs_ptr)),
+ dump_off_to_lisp (emacs_offset (target_emacs_ptr))));
+}
+
+/* Add an Emacs relocation that makes a raw pointer in Emacs point to
+ a different part of Emacs. */
+
+enum dump_fixup_type
+ {
+ DUMP_FIXUP_LISP_OBJECT,
+ DUMP_FIXUP_LISP_OBJECT_RAW,
+ DUMP_FIXUP_PTR_DUMP_RAW,
+ DUMP_FIXUP_BIGNUM_DATA,
+ };
+
+enum dump_lv_fixup_type
+ {
+ LV_FIXUP_LISP_OBJECT,
+ LV_FIXUP_RAW_POINTER,
+ };
+
+/* Make something in the dump point to a lisp object.
+
+ CTX is a dump context. DUMP_OFFSET is the location in the dump to
+ fix. VALUE is the object to which the location in the dump
+ should point.
+
+ If FIXUP_SUBTYPE is LV_FIXUP_LISP_OBJECT, we expect a Lisp_Object
+ at DUMP_OFFSET. If it's LV_FIXUP_RAW_POINTER, we expect a pointer.
+ */
+static void
+dump_remember_fixup_lv (struct dump_context *ctx,
+ dump_off dump_offset,
+ Lisp_Object value,
+ enum dump_lv_fixup_type fixup_subtype)
+{
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ dump_push (&ctx->fixups,
+ list3 (make_fixnum (fixup_subtype == LV_FIXUP_LISP_OBJECT
+ ? DUMP_FIXUP_LISP_OBJECT
+ : DUMP_FIXUP_LISP_OBJECT_RAW),
+ dump_off_to_lisp (dump_offset),
+ value));
+}
+
+/* Remember to fix up the dump file such that the pointer-sized value
+ at DUMP_OFFSET points to NEW_DUMP_OFFSET in the dump file and to
+ its absolute address at runtime. */
+static void
+dump_remember_fixup_ptr_raw (struct dump_context *ctx,
+ dump_off dump_offset,
+ dump_off new_dump_offset)
+{
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ /* We should not be generating relocations into the
+ to-be-copied-into-Emacs dump region. */
+ eassert (ctx->header.discardable_start == 0
+ || new_dump_offset < ctx->header.discardable_start
+ || (ctx->header.cold_start != 0
+ && new_dump_offset >= ctx->header.cold_start));
+
+ dump_push (&ctx->fixups,
+ list3 (make_fixnum (DUMP_FIXUP_PTR_DUMP_RAW),
+ dump_off_to_lisp (dump_offset),
+ dump_off_to_lisp (new_dump_offset)));
+}
+
+static void
+dump_root_visitor (Lisp_Object const *root_ptr, enum gc_root_type type,
+ void *data)
+{
+ struct dump_context *ctx = data;
+ Lisp_Object value = *root_ptr;
+ if (type == GC_ROOT_C_SYMBOL)
+ {
+ eassert (dump_builtin_symbol_p (value));
+ /* Remember to dump the object itself later along with all the
+ rest of the copied-to-Emacs objects. */
+ DUMP_SET_REFERRER (ctx, build_string ("built-in symbol list"));
+ dump_enqueue_object (ctx, value, WEIGHT_NONE);
+ DUMP_CLEAR_REFERRER (ctx);
+ }
+ else
+ {
+ if (type == GC_ROOT_STATICPRO)
+ Fputhash (dump_off_to_lisp (emacs_offset (root_ptr)),
+ Qt,
+ ctx->staticpro_table);
+ if (root_ptr != &Vinternal_interpreter_environment)
+ {
+ DUMP_SET_REFERRER (ctx, dump_ptr_referrer ("emacs root", root_ptr));
+ dump_emacs_reloc_to_lv (ctx, root_ptr, *root_ptr);
+ DUMP_CLEAR_REFERRER (ctx);
+ }
+ }
+}
+
+/* Kick off the dump process by queuing up the static GC roots. */
+static void
+dump_roots (struct dump_context *ctx)
+{
+ struct gc_root_visitor visitor = { .visit = dump_root_visitor,
+ .data = ctx };
+ visit_static_gc_roots (visitor);
+}
+
+#define PDUMPER_MAX_OBJECT_SIZE 2048
+
+static dump_off
+field_relpos (const void *in_start, const void *in_field)
+{
+ ptrdiff_t in_start_val = (ptrdiff_t) in_start;
+ ptrdiff_t in_field_val = (ptrdiff_t) in_field;
+ eassert (in_start_val <= in_field_val);
+ ptrdiff_t relpos = in_field_val - in_start_val;
+ /* The following assertion attempts to detect bugs whereby IN_START
+ and IN_FIELD don't point to the same object/structure, on the
+ assumption that a too-large difference between them is
+ suspicious. As of Apr 2019 the largest object we dump -- 'struct
+ buffer' -- is slightly smaller than 1KB, and we want to leave
+ some margin for future extensions. If the assertion below is
+ ever violated, make sure the two pointers indeed point into the
+ same object, and if so, enlarge the value of PDUMPER_MAX_OBJECT_SIZE. */
+ eassert (relpos < PDUMPER_MAX_OBJECT_SIZE);
+ return (dump_off) relpos;
+}
+
+static void
+cpyptr (void *out, const void *in)
+{
+ memcpy (out, in, sizeof (void *));
+}
+
+/* Convenience macro for regular assignment. */
+#define DUMP_FIELD_COPY(out, in, name) \
+ do \
+ { \
+ (out)->name = (in)->name; \
+ } \
+ while (0)
+
+static void
+dump_field_lv_or_rawptr (struct dump_context *ctx,
+ void *out,
+ const void *in_start,
+ const void *in_field,
+ /* opt */ const enum Lisp_Type *ptr_raw_type,
+ struct link_weight weight)
+{
+ eassert (ctx->obj_offset > 0);
+
+ Lisp_Object value;
+ dump_off relpos = field_relpos (in_start, in_field);
+ void *out_field = (char *) out + relpos;
+ bool is_ptr_raw = (ptr_raw_type != NULL);
+
+ if (!is_ptr_raw)
+ {
+ memcpy (&value, in_field, sizeof (value));
+ if (dump_object_self_representing_p (value))
+ {
+ memcpy (out_field, &value, sizeof (value));
+ return;
+ }
+ }
+ else
+ {
+ void *ptrval;
+ cpyptr (&ptrval, in_field);
+ if (ptrval == NULL)
+ return; /* Nothing to do. */
+ switch (*ptr_raw_type)
+ {
+ case Lisp_Symbol:
+ value = make_lisp_symbol (ptrval);
+ break;
+ case Lisp_String:
+ case Lisp_Vectorlike:
+ case Lisp_Cons:
+ case Lisp_Float:
+ value = make_lisp_ptr (ptrval, *ptr_raw_type);
+ break;
+ default:
+ emacs_abort ();
+ }
+ }
+
+ /* Now value is the Lisp_Object to which we want to point whether or
+ not the field is a raw pointer (in which case we just synthesized
+ the Lisp_Object outselves) or a Lisp_Object (in which case we
+ just copied the thing). Add a fixup or relocation. */
+
+ intptr_t out_value;
+ dump_off out_field_offset = ctx->obj_offset + relpos;
+ dump_off target_offset = dump_recall_object (ctx, value);
+ if (DANGEROUS
+ && target_offset > 0 && dump_object_emacs_ptr (value) == NULL)
+ {
+ /* We've already dumped the referenced object, so we can emit
+ the value and a relocation directly instead of indirecting
+ through a fixup. */
+ out_value = target_offset;
+ if (is_ptr_raw)
+ dump_reloc_dump_to_dump_ptr_raw (ctx, out_field_offset);
+ else
+ dump_reloc_dump_to_dump_lv (ctx, out_field_offset, XTYPE (value));
+ }
+ else
+ {
+ /* We don't know about the target object yet, so add a fixup.
+ When we process the fixup, we'll have dumped the target
+ object. */
+ out_value = (intptr_t) 0xDEADF00D;
+ dump_remember_fixup_lv (ctx,
+ out_field_offset,
+ value,
+ ( is_ptr_raw
+ ? LV_FIXUP_RAW_POINTER
+ : LV_FIXUP_LISP_OBJECT ));
+ dump_enqueue_object (ctx, value, weight);
+ }
+
+ memcpy (out_field, &out_value, sizeof (out_value));
+}
+
+/* Set a pointer field on an output object during dump.
+
+ CTX is the dump context. OFFSET is the offset at which the current
+ object starts. OUT is a pointer to the dump output object.
+ IN_START is the start of the current Emacs object. IN_FIELD is a
+ pointer to the field in that object. TYPE is the type of pointer
+ to which IN_FIELD points.
+ */
+static void
+dump_field_lv_rawptr (struct dump_context *ctx,
+ void *out,
+ const void *in_start,
+ const void *in_field,
+ enum Lisp_Type type,
+ struct link_weight weight)
+{
+ dump_field_lv_or_rawptr (ctx, out, in_start, in_field, &type, weight);
+}
+
+/* Set a Lisp_Object field on an output object during dump.
+
+ CTX is a dump context. OFFSET is the offset at which the current
+ object starts. OUT is a pointer to the dump output object.
+ IN_START is the start of the current Emacs object. IN_FIELD is a
+ pointer to a Lisp_Object field in that object.
+
+ Arrange for the dump to contain fixups and relocations such that,
+ at load time, the given field of the output object contains a valid
+ Lisp_Object pointing to the same notional object that *IN_FIELD
+ contains now.
+
+ See idomatic usage below. */
+static void
+dump_field_lv (struct dump_context *ctx,
+ void *out,
+ const void *in_start,
+ const Lisp_Object *in_field,
+ struct link_weight weight)
+{
+ dump_field_lv_or_rawptr (ctx, out, in_start, in_field, NULL, weight);
+}
+
+/* Note that we're going to add a manual fixup for the given field
+ later. */
+static void
+dump_field_fixup_later (struct dump_context *ctx,
+ void *out,
+ const void *in_start,
+ const void *in_field)
+{
+ /* TODO: more error checking. */
+ (void) field_relpos (in_start, in_field);
+}
+
+/* Mark an output object field, which is as wide as a poiner, as being
+ fixed up to point to a specific offset in the dump. */
+static void
+dump_field_ptr_to_dump_offset (struct dump_context *ctx,
+ void *out,
+ const void *in_start,
+ const void *in_field,
+ dump_off target_dump_offset)
+{
+ eassert (ctx->obj_offset > 0);
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ dump_off relpos = field_relpos (in_start, in_field);
+ dump_reloc_dump_to_dump_ptr_raw (ctx, ctx->obj_offset + relpos);
+ intptr_t outval = target_dump_offset;
+ memcpy ((char *) out + relpos, &outval, sizeof (outval));
+}
+
+/* Mark a field as pointing to a place inside Emacs.
+
+ CTX is the dump context. OUT points to the out-object for the
+ current dump function. IN_START points to the start of the object
+ being dumped. IN_FIELD points to the field inside the object being
+ dumped that we're dumping. The contents of this field (which
+ should be as wide as a pointer) are the Emacs pointer to dump.
+
+ */
+static void
+dump_field_emacs_ptr (struct dump_context *ctx,
+ void *out,
+ const void *in_start,
+ const void *in_field)
+{
+ eassert (ctx->obj_offset > 0);
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ dump_off relpos = field_relpos (in_start, in_field);
+ void *abs_emacs_ptr;
+ cpyptr (&abs_emacs_ptr, in_field);
+ intptr_t rel_emacs_ptr = 0;
+ if (abs_emacs_ptr)
+ {
+ rel_emacs_ptr = emacs_offset ((void *)abs_emacs_ptr);
+ dump_reloc_dump_to_emacs_ptr_raw (ctx, ctx->obj_offset + relpos);
+ }
+ cpyptr ((char *) out + relpos, &rel_emacs_ptr);
+}
+
+static void
+_dump_object_start_pseudovector (struct dump_context *ctx,
+ union vectorlike_header *out_hdr,
+ const union vectorlike_header *in_hdr)
+{
+ eassert (in_hdr->size & PSEUDOVECTOR_FLAG);
+ ptrdiff_t vec_size = vectorlike_nbytes (in_hdr);
+ dump_object_start (ctx, out_hdr, (dump_off) vec_size);
+ *out_hdr = *in_hdr;
+}
+
+/* Need a macro for alloca. */
+#define START_DUMP_PVEC(ctx, hdr, type, out) \
+ const union vectorlike_header *_in_hdr = (hdr); \
+ type *out = alloca (vectorlike_nbytes (_in_hdr)); \
+ _dump_object_start_pseudovector (ctx, &out->header, _in_hdr)
+
+static dump_off
+finish_dump_pvec (struct dump_context *ctx,
+ union vectorlike_header *out_hdr)
+{
+ ALLOW_IMPLICIT_CONVERSION;
+ return dump_object_finish (ctx, out_hdr, vectorlike_nbytes (out_hdr));
+ DISALLOW_IMPLICIT_CONVERSION;
+}
+
+static void
+dump_pseudovector_lisp_fields (struct dump_context *ctx,
+ union vectorlike_header *out_hdr,
+ const union vectorlike_header *in_hdr)
+{
+ const struct Lisp_Vector *in = (const struct Lisp_Vector *) in_hdr;
+ struct Lisp_Vector *out = (struct Lisp_Vector *) out_hdr;
+ ptrdiff_t size = in->header.size;
+ eassert (size & PSEUDOVECTOR_FLAG);
+ size &= PSEUDOVECTOR_SIZE_MASK;
+ for (ptrdiff_t i = 0; i < size; ++i)
+ dump_field_lv (ctx, out, in, &in->contents[i], WEIGHT_STRONG);
+}
+
+static dump_off
+dump_cons (struct dump_context *ctx, const struct Lisp_Cons *cons)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Cons_00EEE63F67)
+# error "Lisp_Cons changed. See CHECK_STRUCTS comment."
+#endif
+ struct Lisp_Cons out;
+ dump_object_start (ctx, &out, sizeof (out));
+ dump_field_lv (ctx, &out, cons, &cons->u.s.car, WEIGHT_STRONG);
+ dump_field_lv (ctx, &out, cons, &cons->u.s.u.cdr, WEIGHT_NORMAL);
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
+static dump_off
+dump_interval_tree (struct dump_context *ctx,
+ INTERVAL tree,
+ dump_off parent_offset)
+{
+#if CHECK_STRUCTS && !defined (HASH_interval_1B38941C37)
+# error "interval changed. See CHECK_STRUCTS comment."
+#endif
+ /* TODO: output tree breadth-first? */
+ struct interval out;
+ dump_object_start (ctx, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, tree, total_length);
+ DUMP_FIELD_COPY (&out, tree, position);
+ if (tree->left)
+ dump_field_fixup_later (ctx, &out, tree, &tree->left);
+ if (tree->right)
+ dump_field_fixup_later (ctx, &out, tree, &tree->right);
+ if (!tree->up_obj)
+ {
+ eassert (parent_offset != 0);
+ dump_field_ptr_to_dump_offset (ctx, &out, tree, &tree->up.interval,
+ parent_offset);
+ }
+ else
+ dump_field_lv (ctx, &out, tree, &tree->up.obj, WEIGHT_STRONG);
+ DUMP_FIELD_COPY (&out, tree, up_obj);
+ eassert (tree->gcmarkbit == 0);
+ DUMP_FIELD_COPY (&out, tree, write_protect);
+ DUMP_FIELD_COPY (&out, tree, visible);
+ DUMP_FIELD_COPY (&out, tree, front_sticky);
+ DUMP_FIELD_COPY (&out, tree, rear_sticky);
+ dump_field_lv (ctx, &out, tree, &tree->plist, WEIGHT_STRONG);
+ dump_off offset = dump_object_finish (ctx, &out, sizeof (out));
+ if (tree->left)
+ dump_remember_fixup_ptr_raw
+ (ctx,
+ offset + dump_offsetof (struct interval, left),
+ dump_interval_tree (ctx, tree->left, offset));
+ if (tree->right)
+ dump_remember_fixup_ptr_raw
+ (ctx,
+ offset + dump_offsetof (struct interval, right),
+ dump_interval_tree (ctx, tree->right, offset));
+ return offset;
+}
+
+static dump_off
+dump_string (struct dump_context *ctx, const struct Lisp_String *string)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_String_86FEA6EC7C)
+# error "Lisp_String changed. See CHECK_STRUCTS comment."
+#endif
+ /* If we have text properties, write them _after_ the string so that
+ at runtime, the prefetcher and cache will DTRT. (We access the
+ string before its properties.).
+
+ There's special code to dump string data contiguously later on.
+ we seldom write to string data and never relocate it, so lumping
+ it together at the end of the dump saves on COW faults.
+
+ If, however, the string's size_byte field is -1, the string data
+ is actually a pointer to Emacs data segment, so we can do even
+ better by emitting a relocation instead of bothering to copy the
+ string data. */
+ struct Lisp_String out;
+ dump_object_start (ctx, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, string, u.s.size);
+ DUMP_FIELD_COPY (&out, string, u.s.size_byte);
+ if (string->u.s.intervals)
+ dump_field_fixup_later (ctx, &out, string, &string->u.s.intervals);
+
+ if (string->u.s.size_byte == -2)
+ /* String literal in Emacs rodata. */
+ dump_field_emacs_ptr (ctx, &out, string, &string->u.s.data);
+ else
+ {
+ dump_field_fixup_later (ctx, &out, string, &string->u.s.data);
+ dump_remember_cold_op (ctx,
+ COLD_OP_STRING,
+ make_lisp_ptr ((void *) string, Lisp_String));
+ }
+
+ dump_off offset = dump_object_finish (ctx, &out, sizeof (out));
+ if (string->u.s.intervals)
+ dump_remember_fixup_ptr_raw
+ (ctx,
+ offset + dump_offsetof (struct Lisp_String, u.s.intervals),
+ dump_interval_tree (ctx, string->u.s.intervals, 0));
+
+ return offset;
+}
+
+static dump_off
+dump_marker (struct dump_context *ctx, const struct Lisp_Marker *marker)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Marker_642DBAF866)
+# error "Lisp_Marker changed. See CHECK_STRUCTS comment."
+#endif
+
+ START_DUMP_PVEC (ctx, &marker->header, struct Lisp_Marker, out);
+ dump_pseudovector_lisp_fields (ctx, &out->header, &marker->header);
+ DUMP_FIELD_COPY (out, marker, need_adjustment);
+ DUMP_FIELD_COPY (out, marker, insertion_type);
+ if (marker->buffer)
+ {
+ dump_field_lv_rawptr (ctx, out, marker, &marker->buffer,
+ Lisp_Vectorlike, WEIGHT_NORMAL);
+ dump_field_lv_rawptr (ctx, out, marker, &marker->next,
+ Lisp_Vectorlike, WEIGHT_STRONG);
+ DUMP_FIELD_COPY (out, marker, charpos);
+ DUMP_FIELD_COPY (out, marker, bytepos);
+ }
+ return finish_dump_pvec (ctx, &out->header);
+}
+
+static dump_off
+dump_overlay (struct dump_context *ctx, const struct Lisp_Overlay *overlay)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Overlay_72EADA9882)
+# error "Lisp_Overlay changed. See CHECK_STRUCTS comment."
+#endif
+ START_DUMP_PVEC (ctx, &overlay->header, struct Lisp_Overlay, out);
+ dump_pseudovector_lisp_fields (ctx, &out->header, &overlay->header);
+ dump_field_lv_rawptr (ctx, out, overlay, &overlay->next,
+ Lisp_Vectorlike, WEIGHT_STRONG);
+ return finish_dump_pvec (ctx, &out->header);
+}
+
+static void
+dump_field_finalizer_ref (struct dump_context *ctx,
+ void *out,
+ const struct Lisp_Finalizer *finalizer,
+ struct Lisp_Finalizer *const *field)
+{
+ if (*field == &finalizers || *field == &doomed_finalizers)
+ dump_field_emacs_ptr (ctx, out, finalizer, field);
+ else
+ dump_field_lv_rawptr (ctx, out, finalizer, field,
+ Lisp_Vectorlike,
+ WEIGHT_NORMAL);
+}
+
+static dump_off
+dump_finalizer (struct dump_context *ctx,
+ const struct Lisp_Finalizer *finalizer)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Finalizer_D58E647CB8)
+# error "Lisp_Finalizer changed. See CHECK_STRUCTS comment."
+#endif
+ START_DUMP_PVEC (ctx, &finalizer->header, struct Lisp_Finalizer, out);
+ /* Do _not_ call dump_pseudovector_lisp_fields here: we dump the
+ only Lisp field, finalizer->function, manually, so we can give it
+ a low weight. */
+ dump_field_lv (ctx, &out, finalizer, &finalizer->function, WEIGHT_NONE);
+ dump_field_finalizer_ref (ctx, &out, finalizer, &finalizer->prev);
+ dump_field_finalizer_ref (ctx, &out, finalizer, &finalizer->next);
+ return finish_dump_pvec (ctx, &out->header);
+}
+
+struct bignum_reload_info
+{
+ dump_off data_location;
+ dump_off nlimbs;
+};
+
+static dump_off
+dump_bignum (struct dump_context *ctx, Lisp_Object object)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Bignum_661945DE2B)
+# error "Lisp_Bignum changed. See CHECK_STRUCTS comment."
+#endif
+ const struct Lisp_Bignum *bignum = XBIGNUM (object);
+ START_DUMP_PVEC (ctx, &bignum->header, struct Lisp_Bignum, out);
+ verify (sizeof (out->value) >= sizeof (struct bignum_reload_info));
+ dump_field_fixup_later (ctx, out, bignum, &bignum->value);
+ dump_off bignum_offset = finish_dump_pvec (ctx, &out->header);
+ if (ctx->flags.dump_object_contents)
+ {
+ /* Export the bignum into a blob in the cold section. */
+ dump_remember_cold_op (ctx, COLD_OP_BIGNUM, object);
+
+ /* Write the offset of that exported blob here. */
+ dump_off value_offset
+ = (bignum_offset
+ + (dump_off) offsetof (struct Lisp_Bignum, value));
+ dump_push (&ctx->fixups,
+ list3 (make_fixnum (DUMP_FIXUP_BIGNUM_DATA),
+ dump_off_to_lisp (value_offset),
+ object));
+
+ /* When we load the dump, slurp the data blob and turn it into a
+ real bignum. Attach the relocation to the start of the
+ Lisp_Bignum instead of the actual mpz field so that the
+ relocation offset is aligned. The relocation-application
+ code knows to actually advance past the header. */
+ dump_push (&ctx->dump_relocs,
+ list2 (make_fixnum (RELOC_BIGNUM),
+ dump_off_to_lisp (bignum_offset)));
+ }
+
+ return bignum_offset;
+}
+
+static dump_off
+dump_float (struct dump_context *ctx, const struct Lisp_Float *lfloat)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Float_50A7B216D9)
+# error "Lisp_Float changed. See CHECK_STRUCTS comment."
+#endif
+ eassert (ctx->header.cold_start);
+ struct Lisp_Float out;
+ dump_object_start (ctx, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, lfloat, u.data);
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
+static dump_off
+dump_fwd_int (struct dump_context *ctx, const struct Lisp_Intfwd *intfwd)
+{
+#if CHECK_STRUCTS && !defined HASH_Lisp_Intfwd_4D887A7387
+# error "Lisp_Intfwd changed. See CHECK_STRUCTS comment."
+#endif
+ dump_emacs_reloc_immediate_intmax_t (ctx, intfwd->intvar, *intfwd->intvar);
+ struct Lisp_Intfwd out;
+ dump_object_start (ctx, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, intfwd, type);
+ dump_field_emacs_ptr (ctx, &out, intfwd, &intfwd->intvar);
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
+static dump_off
+dump_fwd_bool (struct dump_context *ctx, const struct Lisp_Boolfwd *boolfwd)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Boolfwd_0EA1C7ADCC)
+# error "Lisp_Boolfwd changed. See CHECK_STRUCTS comment."
+#endif
+ dump_emacs_reloc_immediate_bool (ctx, boolfwd->boolvar, *boolfwd->boolvar);
+ struct Lisp_Boolfwd out;
+ dump_object_start (ctx, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, boolfwd, type);
+ dump_field_emacs_ptr (ctx, &out, boolfwd, &boolfwd->boolvar);
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
+static dump_off
+dump_fwd_obj (struct dump_context *ctx, const struct Lisp_Objfwd *objfwd)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Objfwd_45D3E513DC)
+# error "Lisp_Objfwd changed. See CHECK_STRUCTS comment."
+#endif
+ if (NILP (Fgethash (dump_off_to_lisp (emacs_offset (objfwd->objvar)),
+ ctx->staticpro_table,
+ Qnil)))
+ dump_emacs_reloc_to_lv (ctx, objfwd->objvar, *objfwd->objvar);
+ struct Lisp_Objfwd out;
+ dump_object_start (ctx, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, objfwd, type);
+ dump_field_emacs_ptr (ctx, &out, objfwd, &objfwd->objvar);
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
+static dump_off
+dump_fwd_buffer_obj (struct dump_context *ctx,
+ const struct Lisp_Buffer_Objfwd *buffer_objfwd)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Buffer_Objfwd_13CA6B04FC)
+# error "Lisp_Buffer_Objfwd changed. See CHECK_STRUCTS comment."
+#endif
+ struct Lisp_Buffer_Objfwd out;
+ dump_object_start (ctx, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, buffer_objfwd, type);
+ DUMP_FIELD_COPY (&out, buffer_objfwd, offset);
+ dump_field_lv (ctx, &out, buffer_objfwd, &buffer_objfwd->predicate,
+ WEIGHT_NORMAL);
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
+static dump_off
+dump_fwd_kboard_obj (struct dump_context *ctx,
+ const struct Lisp_Kboard_Objfwd *kboard_objfwd)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Kboard_Objfwd_CAA7E71069)
+# error "Lisp_Intfwd changed. See CHECK_STRUCTS comment."
+#endif
+ struct Lisp_Kboard_Objfwd out;
+ dump_object_start (ctx, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, kboard_objfwd, type);
+ DUMP_FIELD_COPY (&out, kboard_objfwd, offset);
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
+static dump_off
+dump_fwd (struct dump_context *ctx, lispfwd fwd)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Fwd_Type_9CBA6EE55E)
+# error "Lisp_Fwd_Type changed. See CHECK_STRUCTS comment."
+#endif
+ void const *p = fwd.fwdptr;
+ dump_off offset;
+
+ switch (XFWDTYPE (fwd))
+ {
+ case Lisp_Fwd_Int:
+ offset = dump_fwd_int (ctx, p);
+ break;
+ case Lisp_Fwd_Bool:
+ offset = dump_fwd_bool (ctx, p);
+ break;
+ case Lisp_Fwd_Obj:
+ offset = dump_fwd_obj (ctx, p);
+ break;
+ case Lisp_Fwd_Buffer_Obj:
+ offset = dump_fwd_buffer_obj (ctx, p);
+ break;
+ case Lisp_Fwd_Kboard_Obj:
+ offset = dump_fwd_kboard_obj (ctx, p);
+ break;
+ default:
+ emacs_abort ();
+ }
+
+ return offset;
+}
+
+static dump_off
+dump_blv (struct dump_context *ctx,
+ const struct Lisp_Buffer_Local_Value *blv)
+{
+#if CHECK_STRUCTS && !defined HASH_Lisp_Buffer_Local_Value_3C363FAC3C
+# error "Lisp_Buffer_Local_Value changed. See CHECK_STRUCTS comment."
+#endif
+ struct Lisp_Buffer_Local_Value out;
+ dump_object_start (ctx, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, blv, local_if_set);
+ DUMP_FIELD_COPY (&out, blv, found);
+ if (blv->fwd.fwdptr)
+ dump_field_fixup_later (ctx, &out, blv, &blv->fwd.fwdptr);
+ dump_field_lv (ctx, &out, blv, &blv->where, WEIGHT_NORMAL);
+ dump_field_lv (ctx, &out, blv, &blv->defcell, WEIGHT_STRONG);
+ dump_field_lv (ctx, &out, blv, &blv->valcell, WEIGHT_STRONG);
+ dump_off offset = dump_object_finish (ctx, &out, sizeof (out));
+ if (blv->fwd.fwdptr)
+ dump_remember_fixup_ptr_raw
+ (ctx,
+ offset + dump_offsetof (struct Lisp_Buffer_Local_Value, fwd),
+ dump_fwd (ctx, blv->fwd));
+ return offset;
+}
+
+static dump_off
+dump_recall_symbol_aux (struct dump_context *ctx, Lisp_Object symbol)
+{
+ Lisp_Object symbol_aux = ctx->symbol_aux;
+ if (NILP (symbol_aux))
+ return 0;
+ return dump_off_from_lisp (Fgethash (symbol, symbol_aux, make_fixnum (0)));
+}
+
+static void
+dump_remember_symbol_aux (struct dump_context *ctx,
+ Lisp_Object symbol,
+ dump_off offset)
+{
+ Fputhash (symbol, dump_off_to_lisp (offset), ctx->symbol_aux);
+}
+
+static void
+dump_pre_dump_symbol (struct dump_context *ctx, struct Lisp_Symbol *symbol)
+{
+ Lisp_Object symbol_lv = make_lisp_symbol (symbol);
+ eassert (!dump_recall_symbol_aux (ctx, symbol_lv));
+ DUMP_SET_REFERRER (ctx, symbol_lv);
+ switch (symbol->u.s.redirect)
+ {
+ case SYMBOL_LOCALIZED:
+ dump_remember_symbol_aux (ctx, symbol_lv,
+ dump_blv (ctx, symbol->u.s.val.blv));
+ break;
+ case SYMBOL_FORWARDED:
+ dump_remember_symbol_aux (ctx, symbol_lv,
+ dump_fwd (ctx, symbol->u.s.val.fwd));
+ break;
+ default:
+ break;
+ }
+ DUMP_CLEAR_REFERRER (ctx);
+}
+
+static dump_off
+dump_symbol (struct dump_context *ctx,
+ Lisp_Object object,
+ dump_off offset)
+{
+#if CHECK_STRUCTS && !defined HASH_Lisp_Symbol_999DC26DEC
+# error "Lisp_Symbol changed. See CHECK_STRUCTS comment."
+#endif
+#if CHECK_STRUCTS && !defined (HASH_symbol_redirect_ADB4F5B113)
+# error "symbol_redirect changed. See CHECK_STRUCTS comment."
+#endif
+
+ if (ctx->flags.defer_symbols)
+ {
+ if (offset != DUMP_OBJECT_ON_SYMBOL_QUEUE)
+ {
+ eassert (offset == DUMP_OBJECT_ON_NORMAL_QUEUE
+ || offset == DUMP_OBJECT_NOT_SEEN);
+ DUMP_CLEAR_REFERRER (ctx);
+ struct dump_flags old_flags = ctx->flags;
+ ctx->flags.dump_object_contents = false;
+ ctx->flags.defer_symbols = false;
+ dump_object (ctx, object);
+ ctx->flags = old_flags;
+ DUMP_SET_REFERRER (ctx, object);
+
+ offset = DUMP_OBJECT_ON_SYMBOL_QUEUE;
+ dump_remember_object (ctx, object, offset);
+ dump_push (&ctx->deferred_symbols, object);
+ }
+ return offset;
+ }
+
+ struct Lisp_Symbol *symbol = XSYMBOL (object);
+ struct Lisp_Symbol out;
+ dump_object_start (ctx, &out, sizeof (out));
+ eassert (symbol->u.s.gcmarkbit == 0);
+ DUMP_FIELD_COPY (&out, symbol, u.s.redirect);
+ DUMP_FIELD_COPY (&out, symbol, u.s.trapped_write);
+ DUMP_FIELD_COPY (&out, symbol, u.s.interned);
+ DUMP_FIELD_COPY (&out, symbol, u.s.declared_special);
+ DUMP_FIELD_COPY (&out, symbol, u.s.pinned);
+ dump_field_lv (ctx, &out, symbol, &symbol->u.s.name, WEIGHT_STRONG);
+ switch (symbol->u.s.redirect)
+ {
+ case SYMBOL_PLAINVAL:
+ dump_field_lv (ctx, &out, symbol, &symbol->u.s.val.value,
+ WEIGHT_NORMAL);
+ break;
+ case SYMBOL_VARALIAS:
+ dump_field_lv_rawptr (ctx, &out, symbol,
+ &symbol->u.s.val.alias, Lisp_Symbol,
+ WEIGHT_NORMAL);
+ break;
+ case SYMBOL_LOCALIZED:
+ dump_field_fixup_later (ctx, &out, symbol, &symbol->u.s.val.blv);
+ break;
+ case SYMBOL_FORWARDED:
+ dump_field_fixup_later (ctx, &out, symbol, &symbol->u.s.val.fwd);
+ break;
+ default:
+ emacs_abort ();
+ }
+ dump_field_lv (ctx, &out, symbol, &symbol->u.s.function, WEIGHT_NORMAL);
+ dump_field_lv (ctx, &out, symbol, &symbol->u.s.plist, WEIGHT_NORMAL);
+ dump_field_lv_rawptr (ctx, &out, symbol, &symbol->u.s.next, Lisp_Symbol,
+ WEIGHT_STRONG);
+
+ offset = dump_object_finish (ctx, &out, sizeof (out));
+ dump_off aux_offset;
+
+ switch (symbol->u.s.redirect)
+ {
+ case SYMBOL_LOCALIZED:
+ aux_offset = dump_recall_symbol_aux (ctx, make_lisp_symbol (symbol));
+ dump_remember_fixup_ptr_raw
+ (ctx,
+ offset + dump_offsetof (struct Lisp_Symbol, u.s.val.blv),
+ (aux_offset
+ ? aux_offset
+ : dump_blv (ctx, symbol->u.s.val.blv)));
+ break;
+ case SYMBOL_FORWARDED:
+ aux_offset = dump_recall_symbol_aux (ctx, make_lisp_symbol (symbol));
+ dump_remember_fixup_ptr_raw
+ (ctx,
+ offset + dump_offsetof (struct Lisp_Symbol, u.s.val.fwd),
+ (aux_offset
+ ? aux_offset
+ : dump_fwd (ctx, symbol->u.s.val.fwd)));
+ break;
+ default:
+ break;
+ }
+ return offset;
+}
+
+static dump_off
+dump_vectorlike_generic (struct dump_context *ctx,
+ const union vectorlike_header *header)
+{
+#if CHECK_STRUCTS && !defined (HASH_vectorlike_header_00A5A4BFB2)
+# error "vectorlike_header changed. See CHECK_STRUCTS comment."
+#endif
+ const struct Lisp_Vector *v = (const struct Lisp_Vector *) header;
+ ptrdiff_t size = header->size;
+ enum pvec_type pvectype = PSEUDOVECTOR_TYPE (v);
+ dump_off offset;
+
+ if (size & PSEUDOVECTOR_FLAG)
+ {
+ /* Assert that the pseudovector contains only Lisp values ---
+ but see the PVEC_SUB_CHAR_TABLE special case below. We allow
+ one extra word of non-lisp data when Lisp_Object is shorter
+ than GCALIGN (e.g., on 32-bit builds) to account for
+ GCALIGN-enforcing struct padding. We can't distinguish
+ between padding and some undumpable data member this way, but
+ we'll count on sizeof(Lisp_Object) >= GCALIGN builds to catch
+ this class of problem.
+ */
+ eassert ((size & PSEUDOVECTOR_REST_MASK) >> PSEUDOVECTOR_REST_BITS
+ <= (sizeof (Lisp_Object) < GCALIGNMENT));
+ size &= PSEUDOVECTOR_SIZE_MASK;
+ }
+
+ dump_align_output (ctx, DUMP_ALIGNMENT);
+ dump_off prefix_start_offset = ctx->offset;
+
+ dump_off skip;
+ if (pvectype == PVEC_SUB_CHAR_TABLE)
+ {
+ /* PVEC_SUB_CHAR_TABLE has a special case because it's a
+ variable-length vector (unlike other pseudovectors, which is
+ why we handle it here) and has its non-Lisp data _before_ the
+ variable-length Lisp part. */
+ const struct Lisp_Sub_Char_Table *sct =
+ (const struct Lisp_Sub_Char_Table *) header;
+ struct Lisp_Sub_Char_Table out;
+ /* Don't use sizeof(out), since that incorporates unwanted
+ padding. Instead, use the size through the last non-Lisp
+ field. */
+ size_t sz = (char *)&out.min_char + sizeof (out.min_char) - (char *)&out;
+ eassert (sz < DUMP_OFF_MAX);
+ dump_object_start (ctx, &out, (dump_off) sz);
+ DUMP_FIELD_COPY (&out, sct, header.size);
+ DUMP_FIELD_COPY (&out, sct, depth);
+ DUMP_FIELD_COPY (&out, sct, min_char);
+ offset = dump_object_finish (ctx, &out, (dump_off) sz);
+ skip = SUB_CHAR_TABLE_OFFSET;
+ }
+ else
+ {
+ union vectorlike_header out;
+ dump_object_start (ctx, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, header, size);
+ offset = dump_object_finish (ctx, &out, sizeof (out));
+ skip = 0;
+ }
+
+ /* We may have written a non-Lisp vector prefix above. If we have,
+ pad to the lisp content start with zero, and make sure we didn't
+ scribble beyond that start. */
+ dump_off prefix_size = ctx->offset - prefix_start_offset;
+ eassert (prefix_size > 0);
+ dump_off skip_start = ptrdiff_t_to_dump_off ((char *) &v->contents[skip]
+ - (char *) v);
+ eassert (skip_start >= prefix_size);
+ dump_write_zero (ctx, skip_start - prefix_size);
+
+ /* dump_object_start isn't what records conservative-GC object
+ starts --- dump_object_1 does --- so the hack below of using
+ dump_object_start for each vector word doesn't cause GC problems
+ at runtime. */
+ struct dump_flags old_flags = ctx->flags;
+ ctx->flags.pack_objects = true;
+ for (dump_off i = skip; i < size; ++i)
+ {
+ Lisp_Object out;
+ const Lisp_Object *vslot = &v->contents[i];
+ /* In the wide case, we're always misaligned. */
+#ifndef WIDE_EMACS_INT
+ eassert (ctx->offset % sizeof (out) == 0);
+#endif
+ dump_object_start (ctx, &out, sizeof (out));
+ dump_field_lv (ctx, &out, vslot, vslot, WEIGHT_STRONG);
+ dump_object_finish (ctx, &out, sizeof (out));
+ }
+ ctx->flags = old_flags;
+ dump_align_output (ctx, DUMP_ALIGNMENT);
+ return offset;
+}
+
+/* Determine whether the hash table's hash order is stable
+ across dump and load. If it is, we don't have to trigger
+ a rehash on access. */
+static bool
+dump_hash_table_stable_p (const struct Lisp_Hash_Table *hash)
+{
+ bool is_eql = hash->test.hashfn == hashfn_eql;
+ bool is_equal = hash->test.hashfn == hashfn_equal;
+ ptrdiff_t size = HASH_TABLE_SIZE (hash);
+ for (ptrdiff_t i = 0; i < size; ++i)
+ if (!NILP (HASH_HASH (hash, i)))
+ {
+ Lisp_Object key = HASH_KEY (hash, i);
+ bool key_stable = (dump_builtin_symbol_p (key)
+ || FIXNUMP (key)
+ || (is_equal && STRINGP (key))
+ || ((is_equal || is_eql) && FLOATP (key)));
+ if (!key_stable)
+ return false;
+ }
+
+ return true;
+}
+
+/* Return a list of (KEY . VALUE) pairs in the given hash table. */
+static Lisp_Object
+hash_table_contents (Lisp_Object table)
+{
+ Lisp_Object contents = Qnil;
+ struct Lisp_Hash_Table *h = XHASH_TABLE (table);
+ for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
+ if (!NILP (HASH_HASH (h, i)))
+ dump_push (&contents, Fcons (HASH_KEY (h, i), HASH_VALUE (h, i)));
+ return Fnreverse (contents);
+}
+
+/* Copy the given hash table, rehash it, and make sure that we can
+ look up all the values in the original. */
+static void
+check_hash_table_rehash (Lisp_Object table_orig)
+{
+ hash_rehash_if_needed (XHASH_TABLE (table_orig));
+ Lisp_Object table_rehashed = Fcopy_hash_table (table_orig);
+ eassert (XHASH_TABLE (table_rehashed)->count >= 0);
+ XHASH_TABLE (table_rehashed)->count *= -1;
+ eassert (XHASH_TABLE (table_rehashed)->count <= 0);
+ hash_rehash_if_needed (XHASH_TABLE (table_rehashed));
+ eassert (XHASH_TABLE (table_rehashed)->count >= 0);
+ Lisp_Object expected_contents = hash_table_contents (table_orig);
+ while (!NILP (expected_contents))
+ {
+ Lisp_Object key_value_pair = dump_pop (&expected_contents);
+ Lisp_Object key = XCAR (key_value_pair);
+ Lisp_Object expected_value = XCDR (key_value_pair);
+ Lisp_Object arbitrary = Qdump_emacs_portable__sort_predicate_copied;
+ Lisp_Object found_value = Fgethash (key, table_rehashed, arbitrary);
+ eassert (EQ (expected_value, found_value));
+ Fremhash (key, table_rehashed);
+ }
+
+ eassert (EQ (Fhash_table_count (table_rehashed),
+ make_fixnum (0)));
+}
+
+static dump_off
+dump_hash_table (struct dump_context *ctx,
+ Lisp_Object object,
+ dump_off offset)
+{
+#if CHECK_STRUCTS && !defined HASH_Lisp_Hash_Table_EF95ED06FF
+# error "Lisp_Hash_Table changed. See CHECK_STRUCTS comment."
+#endif
+ const struct Lisp_Hash_Table *hash_in = XHASH_TABLE (object);
+ bool is_stable = dump_hash_table_stable_p (hash_in);
+ /* If the hash table is likely to be modified in memory (either
+ because we need to rehash, and thus toggle hash->count, or
+ because we need to assemble a list of weak tables) punt the hash
+ table to the end of the dump, where we can lump all such hash
+ tables together. */
+ if (!(is_stable || !NILP (hash_in->weak))
+ && ctx->flags.defer_hash_tables)
+ {
+ if (offset != DUMP_OBJECT_ON_HASH_TABLE_QUEUE)
+ {
+ eassert (offset == DUMP_OBJECT_ON_NORMAL_QUEUE
+ || offset == DUMP_OBJECT_NOT_SEEN);
+ /* We still want to dump the actual keys and values now. */
+ dump_enqueue_object (ctx, hash_in->key_and_value, WEIGHT_NONE);
+ /* We'll get to the rest later. */
+ offset = DUMP_OBJECT_ON_HASH_TABLE_QUEUE;
+ dump_remember_object (ctx, object, offset);
+ dump_push (&ctx->deferred_hash_tables, object);
+ }
+ return offset;
+ }
+
+ if (PDUMPER_CHECK_REHASHING)
+ check_hash_table_rehash (make_lisp_ptr ((void *) hash_in, Lisp_Vectorlike));
+
+ struct Lisp_Hash_Table hash_munged = *hash_in;
+ struct Lisp_Hash_Table *hash = &hash_munged;
+
+ /* Remember to rehash this hash table on first access. After a
+ dump reload, the hash table values will have changed, so we'll
+ need to rebuild the index.
+
+ TODO: for EQ and EQL hash tables, it should be possible to rehash
+ here using the preferred load address of the dump, eliminating
+ the need to rehash-on-access if we can load the dump where we
+ want. */
+ if (hash->count > 0 && !is_stable)
+ hash->count = -hash->count;
+
+ START_DUMP_PVEC (ctx, &hash->header, struct Lisp_Hash_Table, out);
+ dump_pseudovector_lisp_fields (ctx, &out->header, &hash->header);
+ /* TODO: dump the hash bucket vectors synchronously here to keep
+ them as close to the hash table as possible. */
+ DUMP_FIELD_COPY (out, hash, count);
+ DUMP_FIELD_COPY (out, hash, next_free);
+ DUMP_FIELD_COPY (out, hash, pure);
+ DUMP_FIELD_COPY (out, hash, rehash_threshold);
+ DUMP_FIELD_COPY (out, hash, rehash_size);
+ dump_field_lv (ctx, out, hash, &hash->key_and_value, WEIGHT_STRONG);
+ dump_field_lv (ctx, out, hash, &hash->test.name, WEIGHT_STRONG);
+ dump_field_lv (ctx, out, hash, &hash->test.user_hash_function,
+ WEIGHT_STRONG);
+ dump_field_lv (ctx, out, hash, &hash->test.user_cmp_function,
+ WEIGHT_STRONG);
+ dump_field_emacs_ptr (ctx, out, hash, &hash->test.cmpfn);
+ dump_field_emacs_ptr (ctx, out, hash, &hash->test.hashfn);
+ eassert (hash->next_weak == NULL);
+ return finish_dump_pvec (ctx, &out->header);
+}
+
+static dump_off
+dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer)
+{
+#if CHECK_STRUCTS && !defined HASH_buffer_E34A11C6B9
+# error "buffer changed. See CHECK_STRUCTS comment."
+#endif
+ struct buffer munged_buffer = *in_buffer;
+ struct buffer *buffer = &munged_buffer;
+
+ /* Clear some buffer state for correctness upon load. */
+ if (buffer->base_buffer == NULL)
+ buffer->window_count = 0;
+ else
+ eassert (buffer->window_count == -1);
+ buffer->last_selected_window_ = Qnil;
+ buffer->display_count_ = make_fixnum (0);
+ buffer->clip_changed = 0;
+ buffer->last_window_start = -1;
+ buffer->point_before_scroll_ = Qnil;
+
+ dump_off base_offset = 0;
+ if (buffer->base_buffer)
+ {
+ eassert (buffer->base_buffer->base_buffer == NULL);
+ base_offset = dump_object_for_offset
+ (ctx,
+ make_lisp_ptr (buffer->base_buffer, Lisp_Vectorlike));
+ }
+
+ eassert ((base_offset == 0 && buffer->text == &in_buffer->own_text)
+ || (base_offset > 0 && buffer->text != &in_buffer->own_text));
+
+ START_DUMP_PVEC (ctx, &buffer->header, struct buffer, out);
+ dump_pseudovector_lisp_fields (ctx, &out->header, &buffer->header);
+ if (base_offset == 0)
+ base_offset = ctx->obj_offset;
+ eassert (base_offset > 0);
+ if (buffer->base_buffer == NULL)
+ {
+ eassert (base_offset == ctx->obj_offset);
+
+ if (BUFFER_LIVE_P (buffer))
+ {
+ dump_field_fixup_later (ctx, out, buffer, &buffer->own_text.beg);
+ dump_remember_cold_op (ctx, COLD_OP_BUFFER,
+ make_lisp_ptr ((void *) in_buffer,
+ Lisp_Vectorlike));
+ }
+ else
+ eassert (buffer->own_text.beg == NULL);
+
+ DUMP_FIELD_COPY (out, buffer, own_text.gpt);
+ DUMP_FIELD_COPY (out, buffer, own_text.z);
+ DUMP_FIELD_COPY (out, buffer, own_text.gpt_byte);
+ DUMP_FIELD_COPY (out, buffer, own_text.z_byte);
+ DUMP_FIELD_COPY (out, buffer, own_text.gap_size);
+ DUMP_FIELD_COPY (out, buffer, own_text.modiff);
+ DUMP_FIELD_COPY (out, buffer, own_text.chars_modiff);
+ DUMP_FIELD_COPY (out, buffer, own_text.save_modiff);
+ DUMP_FIELD_COPY (out, buffer, own_text.overlay_modiff);
+ DUMP_FIELD_COPY (out, buffer, own_text.compact);
+ DUMP_FIELD_COPY (out, buffer, own_text.beg_unchanged);
+ DUMP_FIELD_COPY (out, buffer, own_text.end_unchanged);
+ DUMP_FIELD_COPY (out, buffer, own_text.unchanged_modified);
+ DUMP_FIELD_COPY (out, buffer, own_text.overlay_unchanged_modified);
+ if (buffer->own_text.intervals)
+ dump_field_fixup_later (ctx, out, buffer, &buffer->own_text.intervals);
+ dump_field_lv_rawptr (ctx, out, buffer, &buffer->own_text.markers,
+ Lisp_Vectorlike, WEIGHT_NORMAL);
+ DUMP_FIELD_COPY (out, buffer, own_text.inhibit_shrinking);
+ DUMP_FIELD_COPY (out, buffer, own_text.redisplay);
+ }
+
+ eassert (ctx->obj_offset > 0);
+ dump_remember_fixup_ptr_raw
+ (ctx,
+ ctx->obj_offset + dump_offsetof (struct buffer, text),
+ base_offset + dump_offsetof (struct buffer, own_text));
+
+ dump_field_lv_rawptr (ctx, out, buffer, &buffer->next,
+ Lisp_Vectorlike, WEIGHT_NORMAL);
+ DUMP_FIELD_COPY (out, buffer, pt);
+ DUMP_FIELD_COPY (out, buffer, pt_byte);
+ DUMP_FIELD_COPY (out, buffer, begv);
+ DUMP_FIELD_COPY (out, buffer, begv_byte);
+ DUMP_FIELD_COPY (out, buffer, zv);
+ DUMP_FIELD_COPY (out, buffer, zv_byte);
+
+ if (buffer->base_buffer)
+ {
+ eassert (ctx->obj_offset != base_offset);
+ dump_field_ptr_to_dump_offset (ctx, out, buffer, &buffer->base_buffer,
+ base_offset);
+ }
+
+ DUMP_FIELD_COPY (out, buffer, indirections);
+ DUMP_FIELD_COPY (out, buffer, window_count);
+
+ memcpy (out->local_flags,
+ &buffer->local_flags,
+ sizeof (out->local_flags));
+ DUMP_FIELD_COPY (out, buffer, modtime);
+ DUMP_FIELD_COPY (out, buffer, modtime_size);
+ DUMP_FIELD_COPY (out, buffer, auto_save_modified);
+ DUMP_FIELD_COPY (out, buffer, display_error_modiff);
+ DUMP_FIELD_COPY (out, buffer, auto_save_failure_time);
+ DUMP_FIELD_COPY (out, buffer, last_window_start);
+
+ /* Not worth serializing these caches. TODO: really? */
+ out->newline_cache = NULL;
+ out->width_run_cache = NULL;
+ out->bidi_paragraph_cache = NULL;
+
+ DUMP_FIELD_COPY (out, buffer, prevent_redisplay_optimizations_p);
+ DUMP_FIELD_COPY (out, buffer, clip_changed);
+ DUMP_FIELD_COPY (out, buffer, inhibit_buffer_hooks);
+
+ dump_field_lv_rawptr (ctx, out, buffer, &buffer->overlays_before,
+ Lisp_Vectorlike, WEIGHT_NORMAL);
+
+ dump_field_lv_rawptr (ctx, out, buffer, &buffer->overlays_after,
+ Lisp_Vectorlike, WEIGHT_NORMAL);
+
+ DUMP_FIELD_COPY (out, buffer, overlay_center);
+ dump_field_lv (ctx, out, buffer, &buffer->undo_list_,
+ WEIGHT_STRONG);
+ dump_off offset = finish_dump_pvec (ctx, &out->header);
+ if (!buffer->base_buffer && buffer->own_text.intervals)
+ dump_remember_fixup_ptr_raw
+ (ctx,
+ offset + dump_offsetof (struct buffer, own_text.intervals),
+ dump_interval_tree (ctx, buffer->own_text.intervals, 0));
+
+ return offset;
+}
+
+static dump_off
+dump_bool_vector (struct dump_context *ctx, const struct Lisp_Vector *v)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Vector_3091289B35)
+# error "Lisp_Vector changed. See CHECK_STRUCTS comment."
+#endif
+ /* No relocation needed, so we don't need dump_object_start. */
+ dump_align_output (ctx, DUMP_ALIGNMENT);
+ eassert (ctx->offset >= ctx->header.cold_start);
+ dump_off offset = ctx->offset;
+ ptrdiff_t nbytes = vector_nbytes ((struct Lisp_Vector *) v);
+ if (nbytes > DUMP_OFF_MAX)
+ error ("vector too large");
+ dump_write (ctx, v, ptrdiff_t_to_dump_off (nbytes));
+ return offset;
+}
+
+static dump_off
+dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_594AB72B54)
+# error "Lisp_Subr changed. See CHECK_STRUCTS comment."
+#endif
+ struct Lisp_Subr out;
+ dump_object_start (ctx, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, subr, header.size);
+ dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0);
+ DUMP_FIELD_COPY (&out, subr, min_args);
+ DUMP_FIELD_COPY (&out, subr, max_args);
+ dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name);
+ dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec);
+ DUMP_FIELD_COPY (&out, subr, doc);
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
+static void
+fill_pseudovec (union vectorlike_header *header, Lisp_Object item)
+{
+ struct Lisp_Vector *v = (struct Lisp_Vector *) header;
+ eassert (v->header.size & PSEUDOVECTOR_FLAG);
+ ptrdiff_t size = v->header.size & PSEUDOVECTOR_SIZE_MASK;
+ for (ptrdiff_t idx = 0; idx < size; idx++)
+ v->contents[idx] = item;
+}
+
+static dump_off
+dump_nilled_pseudovec (struct dump_context *ctx,
+ const union vectorlike_header *in)
+{
+ START_DUMP_PVEC (ctx, in, struct Lisp_Vector, out);
+ fill_pseudovec (&out->header, Qnil);
+ return finish_dump_pvec (ctx, &out->header);
+}
+
+static dump_off
+dump_vectorlike (struct dump_context *ctx,
+ Lisp_Object lv,
+ dump_off offset)
+{
+#if CHECK_STRUCTS && !defined (HASH_pvec_type_549C833A54)
+# error "pvec_type changed. See CHECK_STRUCTS comment."
+#endif
+ const struct Lisp_Vector *v = XVECTOR (lv);
+ switch (PSEUDOVECTOR_TYPE (v))
+ {
+ case PVEC_FONT:
+ /* There are three kinds of font objects that all use PVEC_FONT,
+ distinguished by their size. Font specs and entities are
+ harmless data carriers that we can dump like other Lisp
+ objects. Fonts themselves are window-system-specific and
+ need to be recreated on each startup. */
+ if ((v->header.size & PSEUDOVECTOR_SIZE_MASK) != FONT_SPEC_MAX
+ && (v->header.size & PSEUDOVECTOR_SIZE_MASK) != FONT_ENTITY_MAX)
+ error_unsupported_dump_object(ctx, lv, "font");
+ FALLTHROUGH;
+ case PVEC_NORMAL_VECTOR:
+ case PVEC_COMPILED:
+ case PVEC_CHAR_TABLE:
+ case PVEC_SUB_CHAR_TABLE:
+ case PVEC_RECORD:
+ offset = dump_vectorlike_generic (ctx, &v->header);
+ break;
+ case PVEC_BOOL_VECTOR:
+ offset = dump_bool_vector(ctx, v);
+ break;
+ case PVEC_HASH_TABLE:
+ offset = dump_hash_table (ctx, lv, offset);
+ break;
+ case PVEC_BUFFER:
+ offset = dump_buffer (ctx, XBUFFER (lv));
+ break;
+ case PVEC_SUBR:
+ offset = dump_subr (ctx, XSUBR (lv));
+ break;
+ case PVEC_FRAME:
+ case PVEC_WINDOW:
+ case PVEC_PROCESS:
+ case PVEC_TERMINAL:
+ offset = dump_nilled_pseudovec (ctx, &v->header);
+ break;
+ case PVEC_MARKER:
+ offset = dump_marker (ctx, XMARKER (lv));
+ break;
+ case PVEC_OVERLAY:
+ offset = dump_overlay (ctx, XOVERLAY (lv));
+ break;
+ case PVEC_FINALIZER:
+ offset = dump_finalizer (ctx, XFINALIZER (lv));
+ break;
+ case PVEC_BIGNUM:
+ offset = dump_bignum (ctx, lv);
+ break;
+ case PVEC_WINDOW_CONFIGURATION:
+ error_unsupported_dump_object (ctx, lv, "window configuration");
+ case PVEC_OTHER:
+ error_unsupported_dump_object (ctx, lv, "other?!");
+ case PVEC_XWIDGET:
+ error_unsupported_dump_object (ctx, lv, "xwidget");
+ case PVEC_XWIDGET_VIEW:
+ error_unsupported_dump_object (ctx, lv, "xwidget view");
+ case PVEC_MISC_PTR:
+#ifdef HAVE_MODULES
+ case PVEC_USER_PTR:
+#endif
+ error_unsupported_dump_object (ctx, lv, "smuggled pointers");
+ case PVEC_THREAD:
+ if (main_thread_p (v))
+ {
+ eassert (dump_object_emacs_ptr (lv));
+ return DUMP_OBJECT_IS_RUNTIME_MAGIC;
+ }
+ error_unsupported_dump_object (ctx, lv, "thread");
+ case PVEC_MUTEX:
+ error_unsupported_dump_object (ctx, lv, "mutex");
+ case PVEC_CONDVAR:
+ error_unsupported_dump_object (ctx, lv, "condvar");
+ case PVEC_MODULE_FUNCTION:
+ error_unsupported_dump_object (ctx, lv, "module function");
+ default:
+ error_unsupported_dump_object(ctx, lv, "weird pseudovector");
+ }
+
+ return offset;
+}
+
+/* Add an object to the dump.
+
+ CTX is the dump context; OBJECT is the object to add. Normally,
+ return OFFSET, the location (in bytes, from the start of the dump
+ file) where we wrote the object. Valid OFFSETs are always greater
+ than zero.
+
+ If we've already dumped an object, return the location where we put
+ it: dump_object is idempotent.
+
+ The object must refer to an actual pointer-ish object of some sort.
+ Some self-representing objects are immediate values rather than
+ tagged pointers to Lisp heap structures and so have no individual
+ representation in the Lisp heap dump.
+
+ May also return one of the DUMP_OBJECT_ON_*_QUEUE constants if we
+ "dumped" the object by remembering to process it specially later.
+ In this case, we don't have a valid offset.
+ Call dump_object_for_offset if you need a valid offset for
+ an object.
+ */
+static dump_off
+dump_object (struct dump_context *ctx, Lisp_Object object)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Type_E2AD97D3F7)
+# error "Lisp_Type changed. See CHECK_STRUCTS comment."
+#endif
+#ifdef ENABLE_CHECKING
+ /* Vdead is extern only when ENABLE_CHECKING. */
+ eassert (!EQ (object, Vdead));
+#endif
+
+ dump_off offset = dump_recall_object (ctx, object);
+ if (offset > 0)
+ return offset; /* Object already dumped. */
+
+ bool cold = BOOL_VECTOR_P (object) || FLOATP (object);
+ if (cold && ctx->flags.defer_cold_objects)
+ {
+ if (offset != DUMP_OBJECT_ON_COLD_QUEUE)
+ {
+ eassert (offset == DUMP_OBJECT_ON_NORMAL_QUEUE
+ || offset == DUMP_OBJECT_NOT_SEEN);
+ offset = DUMP_OBJECT_ON_COLD_QUEUE;
+ dump_remember_object (ctx, object, offset);
+ dump_remember_cold_op (ctx, COLD_OP_OBJECT, object);
+ }
+ return offset;
+ }
+
+ void *obj_in_emacs = dump_object_emacs_ptr (object);
+ if (obj_in_emacs && ctx->flags.defer_copied_objects)
+ {
+ if (offset != DUMP_OBJECT_ON_COPIED_QUEUE)
+ {
+ eassert (offset == DUMP_OBJECT_ON_NORMAL_QUEUE
+ || offset == DUMP_OBJECT_NOT_SEEN);
+ /* Even though we're not going to dump this object right
+ away, we still want to scan and enqueue its
+ referents. */
+ struct dump_flags old_flags = ctx->flags;
+ ctx->flags.dump_object_contents = false;
+ ctx->flags.defer_copied_objects = false;
+ dump_object (ctx, object);
+ ctx->flags = old_flags;
+
+ offset = DUMP_OBJECT_ON_COPIED_QUEUE;
+ dump_remember_object (ctx, object, offset);
+ dump_push (&ctx->copied_queue, object);
+ }
+ return offset;
+ }
+
+ /* Object needs to be dumped. */
+ DUMP_SET_REFERRER (ctx, object);
+ switch (XTYPE (object))
+ {
+ case Lisp_String:
+ offset = dump_string (ctx, XSTRING (object));
+ break;
+ case Lisp_Vectorlike:
+ offset = dump_vectorlike (ctx, object, offset);
+ break;
+ case Lisp_Symbol:
+ offset = dump_symbol (ctx, object, offset);
+ break;
+ case Lisp_Cons:
+ offset = dump_cons (ctx, XCONS (object));
+ break;
+ case Lisp_Float:
+ offset = dump_float (ctx, XFLOAT (object));
+ break;
+ case_Lisp_Int:
+ eassert ("should not be dumping int: is self-representing" && 0);
+ abort ();
+ default:
+ emacs_abort ();
+ }
+ DUMP_CLEAR_REFERRER (ctx);
+
+ /* offset can be < 0 if we've deferred an object. */
+ if (ctx->flags.dump_object_contents && offset > DUMP_OBJECT_NOT_SEEN)
+ {
+ eassert (offset % DUMP_ALIGNMENT == 0);
+ dump_remember_object (ctx, object, offset);
+ if (ctx->flags.record_object_starts)
+ {
+ eassert (!ctx->flags.pack_objects);
+ dump_push (&ctx->object_starts,
+ list2 (dump_off_to_lisp (XTYPE (object)),
+ dump_off_to_lisp (offset)));
+ }
+ }
+
+ return offset;
+}
+
+/* Like dump_object(), but assert that we get a valid offset. */
+static dump_off
+dump_object_for_offset (struct dump_context *ctx, Lisp_Object object)
+{
+ dump_off offset = dump_object (ctx, object);
+ eassert (offset > 0);
+ return offset;
+}
+
+static dump_off
+dump_charset (struct dump_context *ctx, int cs_i)
+{
+#if CHECK_STRUCTS && !defined (HASH_charset_317C49E291)
+# error "charset changed. See CHECK_STRUCTS comment."
+#endif
+ dump_align_output (ctx, alignof (int));
+ const struct charset *cs = charset_table + cs_i;
+ struct charset out;
+ dump_object_start (ctx, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, cs, id);
+ DUMP_FIELD_COPY (&out, cs, hash_index);
+ DUMP_FIELD_COPY (&out, cs, dimension);
+ memcpy (out.code_space, &cs->code_space, sizeof (cs->code_space));
+ if (cs->code_space_mask)
+ dump_field_fixup_later (ctx, &out, cs, &cs->code_space_mask);
+ DUMP_FIELD_COPY (&out, cs, code_linear_p);
+ DUMP_FIELD_COPY (&out, cs, iso_chars_96);
+ DUMP_FIELD_COPY (&out, cs, ascii_compatible_p);
+ DUMP_FIELD_COPY (&out, cs, supplementary_p);
+ DUMP_FIELD_COPY (&out, cs, compact_codes_p);
+ DUMP_FIELD_COPY (&out, cs, unified_p);
+ DUMP_FIELD_COPY (&out, cs, iso_final);
+ DUMP_FIELD_COPY (&out, cs, iso_revision);
+ DUMP_FIELD_COPY (&out, cs, emacs_mule_id);
+ DUMP_FIELD_COPY (&out, cs, method);
+ DUMP_FIELD_COPY (&out, cs, min_code);
+ DUMP_FIELD_COPY (&out, cs, max_code);
+ DUMP_FIELD_COPY (&out, cs, char_index_offset);
+ DUMP_FIELD_COPY (&out, cs, min_char);
+ DUMP_FIELD_COPY (&out, cs, max_char);
+ DUMP_FIELD_COPY (&out, cs, invalid_code);
+ memcpy (out.fast_map, &cs->fast_map, sizeof (cs->fast_map));
+ DUMP_FIELD_COPY (&out, cs, code_offset);
+ dump_off offset = dump_object_finish (ctx, &out, sizeof (out));
+ if (cs->code_space_mask)
+ dump_remember_cold_op (ctx, COLD_OP_CHARSET,
+ Fcons (dump_off_to_lisp (cs_i),
+ dump_off_to_lisp (offset)));
+ return offset;
+}
+
+static dump_off
+dump_charset_table (struct dump_context *ctx)
+{
+ struct dump_flags old_flags = ctx->flags;
+ ctx->flags.pack_objects = true;
+ dump_align_output (ctx, DUMP_ALIGNMENT);
+ dump_off offset = ctx->offset;
+ /* We are dumping the entire table, not just the used slots, because
+ otherwise when we restore from the pdump file, the actual size of
+ the table will be smaller than charset_table_size, and we will
+ crash if/when a new charset is defined. */
+ for (int i = 0; i < charset_table_size; ++i)
+ dump_charset (ctx, i);
+ dump_emacs_reloc_to_dump_ptr_raw (ctx, &charset_table, offset);
+ ctx->flags = old_flags;
+ return offset;
+}
+
+static void
+dump_finalizer_list_head_ptr (struct dump_context *ctx,
+ struct Lisp_Finalizer **ptr)
+{
+ struct Lisp_Finalizer *value = *ptr;
+ if (value != &finalizers && value != &doomed_finalizers)
+ dump_emacs_reloc_to_dump_ptr_raw
+ (ctx, ptr,
+ dump_object_for_offset (ctx,
+ make_lisp_ptr (value, Lisp_Vectorlike)));
+}
+
+static void
+dump_metadata_for_pdumper (struct dump_context *ctx)
+{
+ for (int i = 0; i < nr_dump_hooks; ++i)
+ dump_emacs_reloc_to_emacs_ptr_raw (ctx, &dump_hooks[i], dump_hooks[i]);
+ dump_emacs_reloc_immediate_int (ctx, &nr_dump_hooks, nr_dump_hooks);
+
+ for (int i = 0; i < nr_remembered_data; ++i)
+ {
+ dump_emacs_reloc_to_emacs_ptr_raw (ctx, &remembered_data[i].mem,
+ remembered_data[i].mem);
+ dump_emacs_reloc_immediate_int (ctx, &remembered_data[i].sz,
+ remembered_data[i].sz);
+ }
+ dump_emacs_reloc_immediate_int (ctx, &nr_remembered_data,
+ nr_remembered_data);
+}
+
+/* Sort the list of copied objects in CTX. */
+static void
+dump_sort_copied_objects (struct dump_context *ctx)
+{
+ /* Sort the objects into the order in which they'll appear in the
+ Emacs: this way, on startup, we'll do both the IO from the dump
+ file and the copy into Emacs in-order, where prefetch will be
+ most effective. */
+ ctx->copied_queue =
+ Fsort (Fnreverse (ctx->copied_queue),
+ Qdump_emacs_portable__sort_predicate_copied);
+}
+
+/* Dump parts of copied objects we need at runtime. */
+static void
+dump_hot_parts_of_discardable_objects (struct dump_context *ctx)
+{
+ Lisp_Object copied_queue = ctx->copied_queue;
+ while (!NILP (copied_queue))
+ {
+ Lisp_Object copied = dump_pop (&copied_queue);
+ if (SYMBOLP (copied))
+ {
+ eassert (dump_builtin_symbol_p (copied));
+ dump_pre_dump_symbol (ctx, XSYMBOL (copied));
+ }
+ }
+}
+
+static void
+dump_drain_copied_objects (struct dump_context *ctx)
+{
+ Lisp_Object copied_queue = ctx->copied_queue;
+ ctx->copied_queue = Qnil;
+
+ struct dump_flags old_flags = ctx->flags;
+
+ /* We should have already fully scanned these objects, so assert
+ that we're not adding more entries to the dump queue. */
+ ctx->flags.assert_already_seen = true;
+
+ /* Now we want to actually dump the copied objects, not just record
+ them. */
+ ctx->flags.defer_copied_objects = false;
+
+ /* Objects that we memcpy into Emacs shouldn't get object-start
+ records (which conservative GC looks at): we usually discard this
+ memory after we're finished memcpying, and even if we don't, the
+ "real" objects in this section all live in the Emacs image, not
+ in the dump. */
+ ctx->flags.record_object_starts = false;
+
+ /* Dump the objects and generate a copy relocation for each. Don't
+ bother trying to reduce the number of copy relocations we
+ generate: we'll merge adjacent copy relocations upon output.
+ The overall result is that to the greatest extent possible while
+ maintaining strictly increasing address order, we copy into Emacs
+ in nice big chunks. */
+ while (!NILP (copied_queue))
+ {
+ Lisp_Object copied = dump_pop (&copied_queue);
+ void *optr = dump_object_emacs_ptr (copied);
+ eassert (optr != NULL);
+ /* N.B. start_offset is beyond any padding we insert. */
+ dump_off start_offset = dump_object (ctx, copied);
+ if (start_offset != DUMP_OBJECT_IS_RUNTIME_MAGIC)
+ {
+ dump_off size = ctx->offset - start_offset;
+ dump_emacs_reloc_copy_from_dump (ctx, start_offset, optr, size);
+ }
+ }
+
+ ctx->flags = old_flags;
+}
+
+static void
+dump_cold_string (struct dump_context *ctx, Lisp_Object string)
+{
+ /* Dump string contents. */
+ dump_off string_offset = dump_recall_object (ctx, string);
+ eassert (string_offset > 0);
+ if (SBYTES (string) > DUMP_OFF_MAX - 1)
+ error ("string too large");
+ dump_off total_size = ptrdiff_t_to_dump_off (SBYTES (string) + 1);
+ eassert (total_size > 0);
+ dump_remember_fixup_ptr_raw
+ (ctx,
+ string_offset + dump_offsetof (struct Lisp_String, u.s.data),
+ ctx->offset);
+ dump_write (ctx, XSTRING (string)->u.s.data, total_size);
+}
+
+static void
+dump_cold_charset (struct dump_context *ctx, Lisp_Object data)
+{
+ /* Dump charset lookup tables. */
+ ALLOW_IMPLICIT_CONVERSION;
+ int cs_i = XFIXNUM (XCAR (data));
+ DISALLOW_IMPLICIT_CONVERSION;
+ dump_off cs_dump_offset = dump_off_from_lisp (XCDR (data));
+ dump_remember_fixup_ptr_raw
+ (ctx,
+ cs_dump_offset + dump_offsetof (struct charset, code_space_mask),
+ ctx->offset);
+ struct charset *cs = charset_table + cs_i;
+ dump_write (ctx, cs->code_space_mask, 256);
+}
+
+static void
+dump_cold_buffer (struct dump_context *ctx, Lisp_Object data)
+{
+ /* Dump buffer text. */
+ dump_off buffer_offset = dump_recall_object (ctx, data);
+ eassert (buffer_offset > 0);
+ struct buffer *b = XBUFFER (data);
+ eassert (b->text == &b->own_text);
+ /* Zero the gap so we don't dump uninitialized bytes. */
+ memset (BUF_GPT_ADDR (b), 0, BUF_GAP_SIZE (b));
+ /* See buffer.c for this calculation. */
+ ptrdiff_t nbytes =
+ BUF_Z_BYTE (b)
+ - BUF_BEG_BYTE (b)
+ + BUF_GAP_SIZE (b)
+ + 1;
+ if (nbytes > DUMP_OFF_MAX)
+ error ("buffer too large");
+ dump_remember_fixup_ptr_raw
+ (ctx,
+ buffer_offset + dump_offsetof (struct buffer, own_text.beg),
+ ctx->offset);
+ dump_write (ctx, b->own_text.beg, ptrdiff_t_to_dump_off (nbytes));
+}
+
+static void
+dump_cold_bignum (struct dump_context *ctx, Lisp_Object object)
+{
+ const struct Lisp_Bignum *bignum = XBIGNUM (object);
+ size_t sz_nlimbs = mpz_size (bignum->value);
+ eassert (sz_nlimbs < DUMP_OFF_MAX);
+ dump_align_output (ctx, alignof (mp_limb_t));
+ dump_off nlimbs = (dump_off) sz_nlimbs;
+ Lisp_Object descriptor
+ = list2 (dump_off_to_lisp (ctx->offset),
+ dump_off_to_lisp ((mpz_sgn (bignum->value) < 0
+ ? -nlimbs : nlimbs)));
+ Fputhash (object, descriptor, ctx->bignum_data);
+ for (mp_size_t i = 0; i < nlimbs; ++i)
+ {
+ mp_limb_t limb = mpz_getlimbn (bignum->value, i);
+ dump_write (ctx, &limb, sizeof (limb));
+ }
+}
+
+static void
+dump_drain_cold_data (struct dump_context *ctx)
+{
+ Lisp_Object cold_queue = Fnreverse (ctx->cold_queue);
+ ctx->cold_queue = Qnil;
+
+ struct dump_flags old_flags = ctx->flags;
+
+ /* We should have already scanned all objects to which our cold
+ objects refer, so die if an object points to something we haven't
+ seen. */
+ ctx->flags.assert_already_seen = true;
+
+ /* Actually dump cold objects instead of deferring them. */
+ ctx->flags.defer_cold_objects = false;
+
+ while (!NILP (cold_queue))
+ {
+ Lisp_Object item = dump_pop (&cold_queue);
+ enum cold_op op = (enum cold_op) XFIXNUM (XCAR (item));
+ Lisp_Object data = XCDR (item);
+ switch (op)
+ {
+ case COLD_OP_STRING:
+ dump_cold_string (ctx, data);
+ break;
+ case COLD_OP_CHARSET:
+ dump_cold_charset (ctx, data);
+ break;
+ case COLD_OP_BUFFER:
+ dump_cold_buffer (ctx, data);
+ break;
+ case COLD_OP_OBJECT:
+ /* Objects that we can put in the cold section
+ must not refer to other objects. */
+ eassert (dump_queue_empty_p (&ctx->dump_queue));
+ eassert (ctx->flags.dump_object_contents);
+ dump_object (ctx, data);
+ eassert (dump_queue_empty_p (&ctx->dump_queue));
+ break;
+ case COLD_OP_BIGNUM:
+ dump_cold_bignum (ctx, data);
+ break;
+ default:
+ emacs_abort ();
+ }
+ }
+
+ ctx->flags = old_flags;
+}
+
+static void
+read_ptr_raw_and_lv (const void *mem,
+ enum Lisp_Type type,
+ void **out_ptr,
+ Lisp_Object *out_lv)
+{
+ memcpy (out_ptr, mem, sizeof (*out_ptr));
+ if (*out_ptr != NULL)
+ {
+ switch (type)
+ {
+ case Lisp_Symbol:
+ *out_lv = make_lisp_symbol (*out_ptr);
+ break;
+ case Lisp_String:
+ case Lisp_Vectorlike:
+ case Lisp_Cons:
+ case Lisp_Float:
+ *out_lv = make_lisp_ptr (*out_ptr, type);
+ break;
+ default:
+ emacs_abort ();
+ }
+ }
+}
+
+/* Enqueue for dumping objects referenced by static non-Lisp_Object
+ pointers inside Emacs. */
+static void
+dump_drain_user_remembered_data_hot (struct dump_context *ctx)
+{
+ for (int i = 0; i < nr_remembered_data; ++i)
+ {
+ void *mem = remembered_data[i].mem;
+ int sz = remembered_data[i].sz;
+ if (sz <= 0)
+ {
+ enum Lisp_Type type = -sz;
+ void *value;
+ Lisp_Object lv;
+ read_ptr_raw_and_lv (mem, type, &value, &lv);
+ if (value != NULL)
+ {
+ DUMP_SET_REFERRER (ctx, dump_ptr_referrer ("user data", mem));
+ dump_enqueue_object (ctx, lv, WEIGHT_NONE);
+ DUMP_CLEAR_REFERRER (ctx);
+ }
+ }
+ }
+}
+
+/* Dump user-specified non-relocated data. */
+static void
+dump_drain_user_remembered_data_cold (struct dump_context *ctx)
+{
+ for (int i = 0; i < nr_remembered_data; ++i)
+ {
+ void *mem = remembered_data[i].mem;
+ int sz = remembered_data[i].sz;
+ if (sz > 0)
+ {
+ /* Scalar: try to inline the value into the relocation if
+ it's small enough; if it's bigger than we can fit in a
+ relocation, we have to copy the data into the dump proper
+ and emit a copy relocation. */
+ if (sz <= sizeof (intmax_t))
+ dump_emacs_reloc_immediate (ctx, mem, mem, sz);
+ else
+ {
+ dump_emacs_reloc_copy_from_dump (ctx, ctx->offset, mem, sz);
+ dump_write (ctx, mem, sz);
+ }
+ }
+ else
+ {
+ /* *mem is a raw pointer to a Lisp object of some sort.
+ The object to which it points should have already been
+ dumped by dump_drain_user_remembered_data_hot. */
+ void *value;
+ Lisp_Object lv;
+ enum Lisp_Type type = -sz;
+ read_ptr_raw_and_lv (mem, type, &value, &lv);
+ if (value == NULL)
+ /* We can't just ignore NULL: the variable might have
+ transitioned from non-NULL to NULL, and we want to
+ record this fact. */
+ dump_emacs_reloc_immediate_ptrdiff_t (ctx, mem, 0);
+ else
+ {
+ if (dump_object_emacs_ptr (lv) != NULL)
+ {
+ /* We have situation like this:
+
+ static Lisp_Symbol *foo;
+ ...
+ foo = XSYMBOL(Qt);
+ ...
+ pdumper_remember_lv_ptr_raw (&foo, Lisp_Symbol);
+
+ Built-in symbols like Qt aren't in the dump!
+ They're actually in Emacs proper. We need a
+ special case to point this value back at Emacs
+ instead of to something in the dump that
+ isn't there.
+
+ An analogous situation applies to subrs, since
+ Lisp_Subr structures always live in Emacs, not
+ the dump.
+ */
+ dump_emacs_reloc_to_emacs_ptr_raw
+ (ctx, mem, dump_object_emacs_ptr (lv));
+ }
+ else
+ {
+ eassert (!dump_object_self_representing_p (lv));
+ dump_off dump_offset = dump_recall_object (ctx, lv);
+ if (dump_offset <= 0)
+ error ("raw-pointer object not dumped?!");
+ dump_emacs_reloc_to_dump_ptr_raw (ctx, mem, dump_offset);
+ }
+ }
+ }
+ }
+}
+
+static void
+dump_unwind_cleanup (void *data)
+{
+ struct dump_context *ctx = data;
+ if (ctx->fd >= 0)
+ emacs_close (ctx->fd);
+#ifdef REL_ALLOC
+ if (ctx->blocked_ralloc)
+ r_alloc_inhibit_buffer_relocation (0);
+#endif
+ Vpurify_flag = ctx->old_purify_flag;
+ Vpost_gc_hook = ctx->old_post_gc_hook;
+ Vprocess_environment = ctx->old_process_environment;
+}
+
+/* Return DUMP_OFFSET, making sure it is within the heap. */
+static dump_off
+dump_check_dump_off (struct dump_context *ctx, dump_off dump_offset)
+{
+ eassert (dump_offset > 0);
+ if (ctx)
+ eassert (dump_offset < ctx->end_heap);
+ return dump_offset;
+}
+
+static void
+dump_check_emacs_off (dump_off emacs_off)
+{
+ eassert (labs (emacs_off) <= 60 * 1024 * 1024);
+}
+
+static struct dump_reloc
+dump_decode_dump_reloc (Lisp_Object lreloc)
+{
+ struct dump_reloc reloc;
+ dump_reloc_set_type (&reloc,
+ (enum dump_reloc_type) XFIXNUM (dump_pop (&lreloc)));
+ eassert (reloc.type <= RELOC_DUMP_TO_EMACS_LV + Lisp_Float);
+ dump_reloc_set_offset (&reloc, dump_off_from_lisp (dump_pop (&lreloc)));
+ eassert (NILP (lreloc));
+ return reloc;
+}
+
+static void
+dump_emit_dump_reloc (struct dump_context *ctx, Lisp_Object lreloc)
+{
+ eassert (ctx->flags.pack_objects);
+ struct dump_reloc reloc;
+ dump_object_start (ctx, &reloc, sizeof (reloc));
+ reloc = dump_decode_dump_reloc (lreloc);
+ dump_check_dump_off (ctx, dump_reloc_get_offset (reloc));
+ dump_object_finish (ctx, &reloc, sizeof (reloc));
+ if (dump_reloc_get_offset (reloc) < ctx->header.discardable_start)
+ ctx->number_hot_relocations += 1;
+ else
+ ctx->number_discardable_relocations += 1;
+}
+
+#ifdef ENABLE_CHECKING
+static Lisp_Object
+dump_check_overlap_dump_reloc (Lisp_Object lreloc_a,
+ Lisp_Object lreloc_b)
+{
+ struct dump_reloc reloc_a = dump_decode_dump_reloc (lreloc_a);
+ struct dump_reloc reloc_b = dump_decode_dump_reloc (lreloc_b);
+ eassert (dump_reloc_get_offset (reloc_a) < dump_reloc_get_offset (reloc_b));
+ return Qnil;
+}
+#endif
+
+/* Translate a Lisp Emacs-relocation descriptor (a list whose first
+ element is one of the EMACS_RELOC_* values, encoded as a fixnum)
+ into an emacs_reloc structure value suitable for writing to the
+ dump file.
+*/
+static struct emacs_reloc
+decode_emacs_reloc (struct dump_context *ctx, Lisp_Object lreloc)
+{
+ struct emacs_reloc reloc;
+ memset (&reloc, 0, sizeof (reloc));
+ ALLOW_IMPLICIT_CONVERSION;
+ int type = XFIXNUM (dump_pop (&lreloc));
+ DISALLOW_IMPLICIT_CONVERSION;
+ reloc.emacs_offset = dump_off_from_lisp (dump_pop (&lreloc));
+ dump_check_emacs_off (reloc.emacs_offset);
+ switch (type)
+ {
+ case RELOC_EMACS_COPY_FROM_DUMP:
+ {
+ emacs_reloc_set_type (&reloc, type);
+ reloc.u.dump_offset = dump_off_from_lisp (dump_pop (&lreloc));
+ dump_check_dump_off (ctx, reloc.u.dump_offset);
+ dump_off length = dump_off_from_lisp (dump_pop (&lreloc));
+ ALLOW_IMPLICIT_CONVERSION;
+ reloc.length = length;
+ DISALLOW_IMPLICIT_CONVERSION;
+ if (reloc.length != length)
+ error ("relocation copy length too large");
+ }
+ break;
+ case RELOC_EMACS_IMMEDIATE:
+ {
+ emacs_reloc_set_type (&reloc, type);
+ intmax_t value = intmax_t_from_lisp (dump_pop (&lreloc));
+ dump_off size = dump_off_from_lisp (dump_pop (&lreloc));
+ reloc.u.immediate = value;
+ ALLOW_IMPLICIT_CONVERSION;
+ reloc.length = size;
+ DISALLOW_IMPLICIT_CONVERSION;
+ eassert (reloc.length == size);
+ }
+ break;
+ case RELOC_EMACS_EMACS_PTR_RAW:
+ emacs_reloc_set_type (&reloc, type);
+ reloc.u.emacs_offset2 = dump_off_from_lisp (dump_pop (&lreloc));
+ dump_check_emacs_off (reloc.u.emacs_offset2);
+ break;
+ case RELOC_EMACS_DUMP_PTR_RAW:
+ emacs_reloc_set_type (&reloc, type);
+ reloc.u.dump_offset = dump_off_from_lisp (dump_pop (&lreloc));
+ dump_check_dump_off (ctx, reloc.u.dump_offset);
+ break;
+ case RELOC_EMACS_DUMP_LV:
+ case RELOC_EMACS_EMACS_LV:
+ {
+ emacs_reloc_set_type (&reloc, type);
+ Lisp_Object target_value = dump_pop (&lreloc);
+ /* If the object is self-representing,
+ dump_emacs_reloc_to_lv didn't do its job.
+ dump_emacs_reloc_to_lv should have added a
+ RELOC_EMACS_IMMEDIATE relocation instead. */
+ eassert (!dump_object_self_representing_p (target_value));
+ int tag_type = XTYPE (target_value);
+ ALLOW_IMPLICIT_CONVERSION;
+ reloc.length = tag_type;
+ DISALLOW_IMPLICIT_CONVERSION;
+ eassert (reloc.length == tag_type);
+
+ if (type == RELOC_EMACS_EMACS_LV)
+ {
+ void *obj_in_emacs = dump_object_emacs_ptr (target_value);
+ eassert (obj_in_emacs);
+ reloc.u.emacs_offset2 = emacs_offset (obj_in_emacs);
+ }
+ else
+ {
+ eassert (!dump_object_emacs_ptr (target_value));
+ reloc.u.dump_offset = dump_recall_object (ctx, target_value);
+ if (reloc.u.dump_offset <= 0)
+ {
+ Lisp_Object repr = Fprin1_to_string (target_value, Qnil);
+ error ("relocation target was not dumped: %s", SDATA (repr));
+ }
+ dump_check_dump_off (ctx, reloc.u.dump_offset);
+ }
+ }
+ break;
+ default:
+ eassume (!"not reached");
+ }
+
+ /* We should have consumed the whole relocation descriptor. */
+ eassert (NILP (lreloc));
+
+ return reloc;
+}
+
+static void
+dump_emit_emacs_reloc (struct dump_context *ctx, Lisp_Object lreloc)
+{
+ eassert (ctx->flags.pack_objects);
+ struct emacs_reloc reloc;
+ dump_object_start (ctx, &reloc, sizeof (reloc));
+ reloc = decode_emacs_reloc (ctx, lreloc);
+ dump_object_finish (ctx, &reloc, sizeof (reloc));
+}
+
+static Lisp_Object
+dump_merge_emacs_relocs (Lisp_Object lreloc_a, Lisp_Object lreloc_b)
+{
+ /* Combine copy relocations together if they're copying from
+ adjacent chunks to adjacent chunks. */
+
+#ifdef ENABLE_CHECKING
+ {
+ dump_off off_a = dump_off_from_lisp (XCAR (XCDR (lreloc_a)));
+ dump_off off_b = dump_off_from_lisp (XCAR (XCDR (lreloc_b)));
+ eassert (off_a <= off_b); /* Catch sort errors. */
+ eassert (off_a < off_b); /* Catch duplicate relocations. */
+ }
+#endif
+
+ if (XFIXNUM (XCAR (lreloc_a)) != RELOC_EMACS_COPY_FROM_DUMP
+ || XFIXNUM (XCAR (lreloc_b)) != RELOC_EMACS_COPY_FROM_DUMP)
+ return Qnil;
+
+ struct emacs_reloc reloc_a = decode_emacs_reloc (NULL, lreloc_a);
+ struct emacs_reloc reloc_b = decode_emacs_reloc (NULL, lreloc_b);
+
+ eassert (reloc_a.type == RELOC_EMACS_COPY_FROM_DUMP);
+ eassert (reloc_b.type == RELOC_EMACS_COPY_FROM_DUMP);
+
+ if (reloc_a.emacs_offset + reloc_a.length != reloc_b.emacs_offset)
+ return Qnil;
+
+ if (reloc_a.u.dump_offset + reloc_a.length != reloc_b.u.dump_offset)
+ return Qnil;
+
+ dump_off new_length = reloc_a.length + reloc_b.length;
+ ALLOW_IMPLICIT_CONVERSION;
+ reloc_a.length = new_length;
+ DISALLOW_IMPLICIT_CONVERSION;
+ if (reloc_a.length != new_length)
+ return Qnil; /* Overflow */
+
+ return list4 (make_fixnum (RELOC_EMACS_COPY_FROM_DUMP),
+ dump_off_to_lisp (reloc_a.emacs_offset),
+ dump_off_to_lisp (reloc_a.u.dump_offset),
+ dump_off_to_lisp (reloc_a.length));
+}
+
+typedef void (*drain_reloc_handler)(struct dump_context *, Lisp_Object);
+typedef Lisp_Object (*drain_reloc_merger)(Lisp_Object a, Lisp_Object b);
+
+static void
+drain_reloc_list (struct dump_context *ctx,
+ drain_reloc_handler handler,
+ drain_reloc_merger merger,
+ Lisp_Object *reloc_list,
+ struct dump_table_locator *out_locator)
+{
+ struct dump_flags old_flags = ctx->flags;
+ ctx->flags.pack_objects = true;
+ Lisp_Object relocs = Fsort (Fnreverse (*reloc_list),
+ Qdump_emacs_portable__sort_predicate);
+ *reloc_list = Qnil;
+ dump_align_output (ctx, sizeof (dump_off));
+ struct dump_table_locator locator;
+ memset (&locator, 0, sizeof (locator));
+ locator.offset = ctx->offset;
+ for (; !NILP (relocs); locator.nr_entries += 1)
+ {
+ Lisp_Object reloc = dump_pop (&relocs);
+ Lisp_Object merged;
+ while (merger != NULL
+ && !NILP (relocs)
+ && (merged = merger (reloc, XCAR (relocs)), !NILP (merged)))
+ {
+ reloc = merged;
+ relocs = XCDR (relocs);
+ }
+ handler (ctx, reloc);
+ }
+ *out_locator = locator;
+ ctx->flags = old_flags;
+}
+
+static void
+dump_do_fixup (struct dump_context *ctx,
+ Lisp_Object fixup,
+ Lisp_Object prev_fixup)
+{
+ enum dump_fixup_type type =
+ (enum dump_fixup_type) XFIXNUM (dump_pop (&fixup));
+ dump_off dump_fixup_offset = dump_off_from_lisp (dump_pop (&fixup));
+#ifdef ENABLE_CHECKING
+ if (!NILP (prev_fixup))
+ {
+ dump_off prev_dump_fixup_offset =
+ dump_off_from_lisp (XCAR (XCDR (prev_fixup)));
+ eassert (dump_fixup_offset - prev_dump_fixup_offset
+ >= sizeof (void *));
+ }
+#endif
+ Lisp_Object arg = dump_pop (&fixup);
+ eassert (NILP (fixup));
+ dump_seek (ctx, dump_fixup_offset);
+ intptr_t dump_value;
+ bool do_write = true;
+ switch (type)
+ {
+ case DUMP_FIXUP_LISP_OBJECT:
+ case DUMP_FIXUP_LISP_OBJECT_RAW:
+ /* Dump wants a pointer to a Lisp object.
+ If DUMP_FIXUP_LISP_OBJECT_RAW, we should stick a C pointer in
+ the dump; otherwise, a Lisp_Object. */
+ if (SUBRP (arg))
+ {
+ dump_value = emacs_offset (XSUBR (arg));
+ if (type == DUMP_FIXUP_LISP_OBJECT)
+ dump_reloc_dump_to_emacs_lv (ctx, ctx->offset, XTYPE (arg));
+ else
+ dump_reloc_dump_to_emacs_ptr_raw (ctx, ctx->offset);
+ }
+ else if (dump_builtin_symbol_p (arg))
+ {
+ eassert (dump_object_self_representing_p (arg));
+ /* These symbols are part of Emacs, so point there. If we
+ want a Lisp_Object, we're set. If we want a raw pointer,
+ we need to emit a relocation. */
+ if (type == DUMP_FIXUP_LISP_OBJECT)
+ {
+ do_write = false;
+ dump_write (ctx, &arg, sizeof (arg));
+ }
+ else
+ {
+ dump_value = emacs_offset (XSYMBOL (arg));
+ dump_reloc_dump_to_emacs_ptr_raw (ctx, ctx->offset);
+ }
+ }
+ else
+ {
+ eassert (dump_object_emacs_ptr (arg) == NULL);
+ dump_value = dump_recall_object (ctx, arg);
+ if (dump_value <= 0)
+ error ("fixup object not dumped");
+ if (type == DUMP_FIXUP_LISP_OBJECT)
+ dump_reloc_dump_to_dump_lv (ctx, ctx->offset, XTYPE (arg));
+ else
+ dump_reloc_dump_to_dump_ptr_raw (ctx, ctx->offset);
+ }
+ break;
+ case DUMP_FIXUP_PTR_DUMP_RAW:
+ /* Dump wants a raw pointer to something that's not a lisp
+ object. It knows the exact location it wants, so just
+ believe it. */
+ dump_value = dump_off_from_lisp (arg);
+ dump_reloc_dump_to_dump_ptr_raw (ctx, ctx->offset);
+ break;
+ case DUMP_FIXUP_BIGNUM_DATA:
+ {
+ eassert (BIGNUMP (arg));
+ arg = Fgethash (arg, ctx->bignum_data, Qnil);
+ if (NILP (arg))
+ error ("bignum not dumped");
+ struct bignum_reload_info reload_info = { 0 };
+ reload_info.data_location = dump_off_from_lisp (dump_pop (&arg));
+ reload_info.nlimbs = dump_off_from_lisp (dump_pop (&arg));
+ eassert (NILP (arg));
+ dump_write (ctx, &reload_info, sizeof (reload_info));
+ do_write = false;
+ break;
+ }
+ default:
+ emacs_abort ();
+ }
+ if (do_write)
+ dump_write (ctx, &dump_value, sizeof (dump_value));
+}
+
+static void
+dump_do_fixups (struct dump_context *ctx)
+{
+ dump_off saved_offset = ctx->offset;
+ Lisp_Object fixups = Fsort (Fnreverse (ctx->fixups),
+ Qdump_emacs_portable__sort_predicate);
+ Lisp_Object prev_fixup = Qnil;
+ ctx->fixups = Qnil;
+ while (!NILP (fixups))
+ {
+ Lisp_Object fixup = dump_pop (&fixups);
+ dump_do_fixup (ctx, fixup, prev_fixup);
+ prev_fixup = fixup;
+ }
+ dump_seek (ctx, saved_offset);
+}
+
+static void
+dump_drain_normal_queue (struct dump_context *ctx)
+{
+ while (!dump_queue_empty_p (&ctx->dump_queue))
+ dump_object (ctx, dump_queue_dequeue (&ctx->dump_queue, ctx->offset));
+}
+
+static void
+dump_drain_deferred_hash_tables (struct dump_context *ctx)
+{
+ struct dump_flags old_flags = ctx->flags;
+
+ /* Now we want to actually write the hash tables. */
+ ctx->flags.defer_hash_tables = false;
+
+ Lisp_Object deferred_hash_tables = Fnreverse (ctx->deferred_hash_tables);
+ ctx->deferred_hash_tables = Qnil;
+ while (!NILP (deferred_hash_tables))
+ dump_object (ctx, dump_pop (&deferred_hash_tables));
+ ctx->flags = old_flags;
+}
+
+static void
+dump_drain_deferred_symbols (struct dump_context *ctx)
+{
+ struct dump_flags old_flags = ctx->flags;
+
+ /* Now we want to actually write the symbols. */
+ ctx->flags.defer_symbols = false;
+
+ Lisp_Object deferred_symbols = Fnreverse (ctx->deferred_symbols);
+ ctx->deferred_symbols = Qnil;
+ while (!NILP (deferred_symbols))
+ dump_object (ctx, dump_pop (&deferred_symbols));
+ ctx->flags = old_flags;
+}
+
+DEFUN ("dump-emacs-portable",
+ Fdump_emacs_portable, Sdump_emacs_portable,
+ 1, 2, 0,
+ doc: /* Dump current state of Emacs into portable dump file FILENAME.
+If TRACK-REFERRERS is non-nil, keep additional debugging information
+that can help track down the provenance of unsupported object
+types. */)
+ (Lisp_Object filename, Lisp_Object track_referrers)
+{
+ eassert (initialized);
+
+ if (will_dump_with_unexec_p ())
+ error ("This Emacs instance was started under the assumption "
+ "that it would be dumped with unexec, not the portable "
+ "dumper. Dumping with the portable dumper may produce "
+ "unexpected results.");
+
+ if (!main_thread_p (current_thread))
+ error ("This function can be called only in the main thread");
+
+ if (!NILP (XCDR (Fall_threads ())))
+ error ("No other Lisp threads can be running when this function is called");
+
+ /* Clear out any detritus in memory. */
+ do
+ {
+ number_finalizers_run = 0;
+ garbage_collect ();
+ }
+ while (number_finalizers_run);
+
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+ /* Bind `command-line-processed' to nil before dumping,
+ so that the dumped Emacs will process its command line
+ and set up to work with X windows if appropriate. */
+ Lisp_Object symbol = intern ("command-line-processed");
+ specbind (symbol, Qnil);
+
+ CHECK_STRING (filename);
+ filename = Fexpand_file_name (filename, Qnil);
+ filename = ENCODE_FILE (filename);
+
+ struct dump_context ctx_buf;
+ struct dump_context *ctx = &ctx_buf;
+ memset (ctx, 0, sizeof (*ctx));
+ ctx->fd = -1;
+
+ ctx->objects_dumped = make_eq_hash_table ();
+ dump_queue_init (&ctx->dump_queue);
+ ctx->deferred_hash_tables = Qnil;
+ ctx->deferred_symbols = Qnil;
+
+ ctx->fixups = Qnil;
+ ctx->staticpro_table = CALLN (Fmake_hash_table);
+ ctx->symbol_aux = Qnil;
+ ctx->copied_queue = Qnil;
+ ctx->cold_queue = Qnil;
+ ctx->dump_relocs = Qnil;
+ ctx->object_starts = Qnil;
+ ctx->emacs_relocs = Qnil;
+ ctx->bignum_data = make_eq_hash_table ();
+
+ /* Ordinarily, dump_object should remember where it saw objects and
+ actually write the object contents to the dump file. In special
+ circumstances below, we temporarily change this default
+ behavior. */
+ ctx->flags.dump_object_contents = true;
+ ctx->flags.record_object_starts = true;
+
+ /* We want to consolidate certain object types that we know are very likely
+ to be modified. */
+ ctx->flags.defer_hash_tables = true;
+ /* ctx->flags.defer_symbols = true; XXX */
+
+ /* These objects go into special sections. */
+ ctx->flags.defer_cold_objects = true;
+ ctx->flags.defer_copied_objects = true;
+
+ ctx->current_referrer = Qnil;
+ if (!NILP (track_referrers))
+ ctx->referrers = make_eq_hash_table ();
+
+ ctx->dump_filename = filename;
+
+ record_unwind_protect_ptr (dump_unwind_cleanup, ctx);
+ block_input ();
+
+#ifdef REL_ALLOC
+ r_alloc_inhibit_buffer_relocation (1);
+ ctx->blocked_ralloc = true;
+#endif
+
+ ctx->old_purify_flag = Vpurify_flag;
+ Vpurify_flag = Qnil;
+
+ /* Make sure various weird things are less likely to happen. */
+ ctx->old_post_gc_hook = Vpost_gc_hook;
+ Vpost_gc_hook = Qnil;
+
+ /* Reset process-environment -- this is for when they re-dump a
+ pdump-restored emacs, since set_initial_environment wants always
+ to cons it from scratch. */
+ ctx->old_process_environment = Vprocess_environment;
+ Vprocess_environment = Qnil;
+
+ ctx->fd = emacs_open (SSDATA (filename),
+ O_RDWR | O_TRUNC | O_CREAT, 0666);
+ if (ctx->fd < 0)
+ report_file_error ("Opening dump output", filename);
+ verify (sizeof (ctx->header.magic) == sizeof (dump_magic));
+ memcpy (&ctx->header.magic, dump_magic, sizeof (dump_magic));
+ ctx->header.magic[0] = '!'; /* Note that dump is incomplete. */
+
+ verify (sizeof (fingerprint) == sizeof (ctx->header.fingerprint));
+ memcpy (ctx->header.fingerprint, fingerprint, sizeof (fingerprint));
+
+ const dump_off header_start = ctx->offset;
+ dump_fingerprint ("dumping fingerprint", ctx->header.fingerprint);
+ dump_write (ctx, &ctx->header, sizeof (ctx->header));
+ const dump_off header_end = ctx->offset;
+
+ const dump_off hot_start = ctx->offset;
+ /* Start the dump process by processing the static roots and
+ queuing up the objects to which they refer. */
+ dump_roots (ctx);
+
+ dump_charset_table (ctx);
+ dump_finalizer_list_head_ptr (ctx, &finalizers.prev);
+ dump_finalizer_list_head_ptr (ctx, &finalizers.next);
+ dump_finalizer_list_head_ptr (ctx, &doomed_finalizers.prev);
+ dump_finalizer_list_head_ptr (ctx, &doomed_finalizers.next);
+ dump_drain_user_remembered_data_hot (ctx);
+
+ /* We've already remembered all the objects to which GC roots point,
+ but we have to manually save the list of GC roots itself. */
+ dump_metadata_for_pdumper (ctx);
+ for (int i = 0; i < staticidx; ++i)
+ dump_emacs_reloc_to_emacs_ptr_raw (ctx, &staticvec[i], staticvec[i]);
+ dump_emacs_reloc_immediate_int (ctx, &staticidx, staticidx);
+
+ /* Dump until while we keep finding objects to dump. We add new
+ objects to the queue by side effect during dumping.
+ We accumulate some types of objects in special lists to get more
+ locality for these object types at runtime. */
+ do
+ {
+ dump_drain_deferred_hash_tables (ctx);
+ dump_drain_deferred_symbols (ctx);
+ dump_drain_normal_queue (ctx);
+ }
+ while (!dump_queue_empty_p (&ctx->dump_queue)
+ || !NILP (ctx->deferred_hash_tables)
+ || !NILP (ctx->deferred_symbols));
+
+ dump_sort_copied_objects (ctx);
+
+ /* While we copy built-in symbols into the Emacs image, these
+ built-in structures refer to non-Lisp heap objects that must live
+ in the dump; we stick these auxiliary data structures at the end
+ of the hot section and use a special hash table to remember them.
+ The actual symbol dump will pick them up below. */
+ ctx->symbol_aux = make_eq_hash_table ();
+ dump_hot_parts_of_discardable_objects (ctx);
+
+ /* Emacs, after initial dump loading, can forget about the portion
+ of the dump that runs from here to the start of the cold section.
+ This section consists of objects that need to be memcpy()ed into
+ the Emacs data section instead of just used directly.
+
+ We don't need to align hot_end: the loader knows to actually
+ start discarding only at the next page boundary if the loader
+ implements discarding using page manipulation. */
+ const dump_off hot_end = ctx->offset;
+ ctx->header.discardable_start = hot_end;
+
+ dump_drain_copied_objects (ctx);
+ eassert (dump_queue_empty_p (&ctx->dump_queue));
+
+ dump_off discardable_end = ctx->offset;
+ dump_align_output (ctx, dump_get_page_size ());
+ ctx->header.cold_start = ctx->offset;
+
+ /* Start the cold section. This section contains bytes that should
+ never change and so can be direct-mapped from the dump without
+ special processing. */
+ dump_drain_cold_data (ctx);
+ /* dump_drain_user_remembered_data_cold needs to be after
+ dump_drain_cold_data in case dump_drain_cold_data dumps a lisp
+ object to which C code points.
+ dump_drain_user_remembered_data_cold assumes that all lisp
+ objects have been dumped. */
+ dump_drain_user_remembered_data_cold (ctx);
+
+ /* After this point, the dump file contains no data that can be part
+ of the Lisp heap. */
+ ctx->end_heap = ctx->offset;
+
+ /* Make remembered modifications to the dump file itself. */
+ dump_do_fixups (ctx);
+
+ drain_reloc_merger emacs_reloc_merger =
+#ifdef ENABLE_CHECKING
+ dump_check_overlap_dump_reloc
+#else
+ NULL
+#endif
+ ;
+
+ /* Emit instructions for Emacs to execute when loading the dump.
+ Note that this relocation information ends up in the cold section
+ of the dump. */
+ drain_reloc_list (ctx, dump_emit_dump_reloc, emacs_reloc_merger,
+ &ctx->dump_relocs, &ctx->header.dump_relocs);
+ unsigned number_hot_relocations = ctx->number_hot_relocations;
+ ctx->number_hot_relocations = 0;
+ unsigned number_discardable_relocations = ctx->number_discardable_relocations;
+ ctx->number_discardable_relocations = 0;
+ drain_reloc_list (ctx, dump_emit_dump_reloc, emacs_reloc_merger,
+ &ctx->object_starts, &ctx->header.object_starts);
+ drain_reloc_list (ctx, dump_emit_emacs_reloc, dump_merge_emacs_relocs,
+ &ctx->emacs_relocs, &ctx->header.emacs_relocs);
+
+ const dump_off cold_end = ctx->offset;
+
+ eassert (dump_queue_empty_p (&ctx->dump_queue));
+ eassert (NILP (ctx->copied_queue));
+ eassert (NILP (ctx->cold_queue));
+ eassert (NILP (ctx->deferred_symbols));
+ eassert (NILP (ctx->deferred_hash_tables));
+ eassert (NILP (ctx->fixups));
+ eassert (NILP (ctx->dump_relocs));
+ eassert (NILP (ctx->emacs_relocs));
+
+ /* Dump is complete. Go back to the header and write the magic
+ indicating that the dump is complete and can be loaded. */
+ ctx->header.magic[0] = dump_magic[0];
+ dump_seek (ctx, 0);
+ dump_write (ctx, &ctx->header, sizeof (ctx->header));
+
+ fprintf (stderr, "Dump complete\n");
+ fprintf (stderr,
+ "Byte counts: header=%lu hot=%lu discardable=%lu cold=%lu\n",
+ (unsigned long) (header_end - header_start),
+ (unsigned long) (hot_end - hot_start),
+ (unsigned long) (discardable_end - ctx->header.discardable_start),
+ (unsigned long) (cold_end - ctx->header.cold_start));
+ fprintf (stderr, "Reloc counts: hot=%u discardable=%u\n",
+ number_hot_relocations,
+ number_discardable_relocations);
+
+ unblock_input ();
+ return unbind_to (count, Qnil);
+}
+
+DEFUN ("dump-emacs-portable--sort-predicate",
+ Fdump_emacs_portable__sort_predicate,
+ Sdump_emacs_portable__sort_predicate,
+ 2, 2, 0,
+ doc: /* Internal relocation sorting function. */)
+ (Lisp_Object a, Lisp_Object b)
+{
+ dump_off a_offset = dump_off_from_lisp (XCAR (XCDR (a)));
+ dump_off b_offset = dump_off_from_lisp (XCAR (XCDR (b)));
+ return a_offset < b_offset ? Qt : Qnil;
+}
+
+DEFUN ("dump-emacs-portable--sort-predicate-copied",
+ Fdump_emacs_portable__sort_predicate_copied,
+ Sdump_emacs_portable__sort_predicate_copied,
+ 2, 2, 0,
+ doc: /* Internal relocation sorting function. */)
+ (Lisp_Object a, Lisp_Object b)
+{
+ eassert (dump_object_emacs_ptr (a));
+ eassert (dump_object_emacs_ptr (b));
+ return dump_object_emacs_ptr (a) < dump_object_emacs_ptr (b) ? Qt : Qnil;
+}
+
+void
+pdumper_do_now_and_after_load_impl (pdumper_hook hook)
+{
+ if (nr_dump_hooks == ARRAYELTS (dump_hooks))
+ fatal ("out of dump hooks: make dump_hooks[] bigger");
+ dump_hooks[nr_dump_hooks++] = hook;
+ hook ();
+}
+
+static void
+pdumper_remember_user_data_1 (void *mem, int nbytes)
+{
+ if (nr_remembered_data == ARRAYELTS (remembered_data))
+ fatal ("out of remembered data slots: make remembered_data[] bigger");
+ remembered_data[nr_remembered_data].mem = mem;
+ remembered_data[nr_remembered_data].sz = nbytes;
+ nr_remembered_data += 1;
+}
+
+void
+pdumper_remember_scalar_impl (void *mem, ptrdiff_t nbytes)
+{
+ eassert (0 <= nbytes && nbytes <= INT_MAX);
+ if (nbytes > 0)
+ pdumper_remember_user_data_1 (mem, (int) nbytes);
+}
+
+void
+pdumper_remember_lv_ptr_raw_impl (void *ptr, enum Lisp_Type type)
+{
+ pdumper_remember_user_data_1 (ptr, -type);
+}
+
+
+/* Dump runtime */
+enum dump_memory_protection
+{
+ DUMP_MEMORY_ACCESS_NONE = 1,
+ DUMP_MEMORY_ACCESS_READ = 2,
+ DUMP_MEMORY_ACCESS_READWRITE = 3,
+};
+
+#if VM_SUPPORTED == VM_MS_WINDOWS
+static void *
+dump_anonymous_allocate_w32 (void *base,
+ size_t size,
+ enum dump_memory_protection protection)
+{
+ void *ret;
+ DWORD mem_type;
+ DWORD mem_prot;
+
+ switch (protection)
+ {
+ case DUMP_MEMORY_ACCESS_NONE:
+ mem_type = MEM_RESERVE;
+ mem_prot = PAGE_NOACCESS;
+ break;
+ case DUMP_MEMORY_ACCESS_READ:
+ mem_type = MEM_COMMIT;
+ mem_prot = PAGE_READONLY;
+ break;
+ case DUMP_MEMORY_ACCESS_READWRITE:
+ mem_type = MEM_COMMIT;
+ mem_prot = PAGE_READWRITE;
+ break;
+ default:
+ emacs_abort ();
+ }
+
+ ret = VirtualAlloc (base, size, mem_type, mem_prot);
+ if (ret == NULL)
+ errno = (base && GetLastError () == ERROR_INVALID_ADDRESS)
+ ? EBUSY
+ : EPERM;
+ return ret;
+}
+#endif
+
+#if VM_SUPPORTED == VM_POSIX
+
+/* Old versions of macOS only define MAP_ANON, not MAP_ANONYMOUS.
+ FIXME: This probably belongs elsewhere (gnulib/autoconf?) */
+# ifndef MAP_ANONYMOUS
+# define MAP_ANONYMOUS MAP_ANON
+# endif
+
+static void *
+dump_anonymous_allocate_posix (void *base,
+ size_t size,
+ enum dump_memory_protection protection)
+{
+ void *ret;
+ int mem_prot;
+
+ switch (protection)
+ {
+ case DUMP_MEMORY_ACCESS_NONE:
+ mem_prot = PROT_NONE;
+ break;
+ case DUMP_MEMORY_ACCESS_READ:
+ mem_prot = PROT_READ;
+ break;
+ case DUMP_MEMORY_ACCESS_READWRITE:
+ mem_prot = PROT_READ | PROT_WRITE;
+ break;
+ default:
+ emacs_abort ();
+ }
+
+ int mem_flags = MAP_PRIVATE | MAP_ANONYMOUS;
+ if (mem_prot != PROT_NONE)
+ mem_flags |= MAP_POPULATE;
+ if (base)
+ mem_flags |= MAP_FIXED;
+
+ bool retry;
+ do
+ {
+ retry = false;
+ ret = mmap (base, size, mem_prot, mem_flags, -1, 0);
+ if (ret == MAP_FAILED
+ && errno == EINVAL
+ && (mem_flags & MAP_POPULATE))
+ {
+ /* This system didn't understand MAP_POPULATE, so try
+ again without it. */
+ mem_flags &= ~MAP_POPULATE;
+ retry = true;
+ }
+ }
+ while (retry);
+
+ if (ret == MAP_FAILED)
+ ret = NULL;
+ return ret;
+}
+#endif
+
+/* Perform anonymous memory allocation. */
+static void *
+dump_anonymous_allocate (void *base,
+ const size_t size,
+ enum dump_memory_protection protection)
+{
+#if VM_SUPPORTED == VM_POSIX
+ return dump_anonymous_allocate_posix (base, size, protection);
+#elif VM_SUPPORTED == VM_MS_WINDOWS
+ return dump_anonymous_allocate_w32 (base, size, protection);
+#else
+ errno = ENOSYS;
+ return NULL;
+#endif
+}
+
+/* Undo the effect of dump_reserve_address_space(). */
+static void
+dump_anonymous_release (void *addr, size_t size)
+{
+ eassert (size >= 0);
+#if VM_SUPPORTED == VM_MS_WINDOWS
+ (void) size;
+ if (!VirtualFree (addr, 0, MEM_RELEASE))
+ emacs_abort ();
+#elif VM_SUPPORTED == VM_POSIX
+ if (munmap (addr, size) < 0)
+ emacs_abort ();
+#else
+ (void) addr;
+ (void) size;
+ emacs_abort ();
+#endif
+}
+
+#if VM_SUPPORTED == VM_MS_WINDOWS
+static void *
+dump_map_file_w32 (void *base, int fd, off_t offset, size_t size,
+ enum dump_memory_protection protection)
+{
+ void *ret = NULL;
+ HANDLE section = NULL;
+ HANDLE file;
+
+ uint64_t full_offset = offset;
+ uint32_t offset_high = (uint32_t) (full_offset >> 32);
+ uint32_t offset_low = (uint32_t) (full_offset & 0xffffffff);
+
+ int error;
+ DWORD map_access;
+
+ file = (HANDLE) _get_osfhandle (fd);
+ if (file == INVALID_HANDLE_VALUE)
+ goto out;
+
+ section = CreateFileMapping (file,
+ /*lpAttributes=*/NULL,
+ PAGE_READONLY,
+ /*dwMaximumSizeHigh=*/0,
+ /*dwMaximumSizeLow=*/0,
+ /*lpName=*/NULL);
+ if (!section)
+ {
+ errno = EINVAL;
+ goto out;
+ }
+
+ switch (protection)
+ {
+ case DUMP_MEMORY_ACCESS_NONE:
+ case DUMP_MEMORY_ACCESS_READ:
+ map_access = FILE_MAP_READ;
+ break;
+ case DUMP_MEMORY_ACCESS_READWRITE:
+ map_access = FILE_MAP_COPY;
+ break;
+ default:
+ emacs_abort ();
+ }
+
+ ret = MapViewOfFileEx (section,
+ map_access,
+ offset_high,
+ offset_low,
+ size,
+ base);
+
+ error = GetLastError ();
+ if (ret == NULL)
+ errno = (error == ERROR_INVALID_ADDRESS ? EBUSY : EPERM);
+ out:
+ if (section && !CloseHandle (section))
+ emacs_abort ();
+ return ret;
+}
+#endif
+
+#if VM_SUPPORTED == VM_POSIX
+static void *
+dump_map_file_posix (void *base, int fd, off_t offset, size_t size,
+ enum dump_memory_protection protection)
+{
+ void *ret;
+ int mem_prot;
+ int mem_flags;
+
+ switch (protection)
+ {
+ case DUMP_MEMORY_ACCESS_NONE:
+ mem_prot = PROT_NONE;
+ mem_flags = MAP_SHARED;
+ break;
+ case DUMP_MEMORY_ACCESS_READ:
+ mem_prot = PROT_READ;
+ mem_flags = MAP_SHARED;
+ break;
+ case DUMP_MEMORY_ACCESS_READWRITE:
+ mem_prot = PROT_READ | PROT_WRITE;
+ mem_flags = MAP_PRIVATE;
+ break;
+ default:
+ emacs_abort ();
+ }
+
+ if (base)
+ mem_flags |= MAP_FIXED;
+
+ ret = mmap (base, size, mem_prot, mem_flags, fd, offset);
+ if (ret == MAP_FAILED)
+ ret = NULL;
+ return ret;
+}
+#endif
+
+/* Map a file into memory. */
+static void *
+dump_map_file (void *base, int fd, off_t offset, size_t size,
+ enum dump_memory_protection protection)
+{
+#if VM_SUPPORTED == VM_POSIX
+ return dump_map_file_posix (base, fd, offset, size, protection);
+#elif VM_SUPPORTED == VM_MS_WINDOWS
+ return dump_map_file_w32 (base, fd, offset, size, protection);
+#else
+ errno = ENOSYS;
+ return ret;
+#endif
+}
+
+/* Remove a virtual memory mapping.
+
+ On failure, abort Emacs. For maximum platform compatibility, ADDR
+ and SIZE must match the mapping exactly. */
+static void
+dump_unmap_file (void *addr, size_t size)
+{
+ eassert (size >= 0);
+#if !VM_SUPPORTED
+ (void) addr;
+ (void) size;
+ emacs_abort ();
+#elif defined (WINDOWSNT)
+ (void) size;
+ if (!UnmapViewOfFile (addr))
+ emacs_abort ();
+#else
+ if (munmap (addr, size) < 0)
+ emacs_abort ();
+#endif
+}
+
+struct dump_memory_map_spec
+{
+ int fd; /* File to map; anon zero if negative. */
+ size_t size; /* Number of bytes to map. */
+ off_t offset; /* Offset within fd. */
+ enum dump_memory_protection protection;
+};
+
+struct dump_memory_map
+{
+ struct dump_memory_map_spec spec;
+ void *mapping; /* Actual mapped memory. */
+ void (*release)(struct dump_memory_map *);
+ void *private;
+};
+
+/* Mark the pages as unneeded, potentially zeroing them, without
+ releasing the address space reservation. */
+static void
+dump_discard_mem (void *mem, size_t size)
+{
+#if VM_SUPPORTED == VM_MS_WINDOWS
+ /* Discard COWed pages. */
+ (void) VirtualFree (mem, size, MEM_DECOMMIT);
+ /* Release the commit charge for the mapping. */
+ DWORD old_prot;
+ (void) VirtualProtect (mem, size, PAGE_NOACCESS, &old_prot);
+#elif VM_SUPPORTED == VM_POSIX
+# ifdef HAVE_POSIX_MADVISE
+ /* Discard COWed pages. */
+ (void) posix_madvise (mem, size, POSIX_MADV_DONTNEED);
+# endif
+ /* Release the commit charge for the mapping. */
+ (void) mprotect (mem, size, PROT_NONE);
+#endif
+}
+
+static void
+dump_mmap_discard_contents (struct dump_memory_map *map)
+{
+ if (map->mapping)
+ dump_discard_mem (map->mapping, map->spec.size);
+}
+
+static void
+dump_mmap_reset (struct dump_memory_map *map)
+{
+ map->mapping = NULL;
+ map->release = NULL;
+ void *private = map->private;
+ map->private = NULL;
+ free (private);
+}
+
+static void
+dump_mmap_release (struct dump_memory_map *map)
+{
+ if (map->release)
+ map->release (map);
+ dump_mmap_reset (map);
+}
+
+/* Allows heap-allocated dump_mmap to "free" maps individually. */
+struct dump_memory_map_heap_control_block
+{
+ int refcount;
+ void *mem;
+};
+
+static void
+dump_mm_heap_cb_release (struct dump_memory_map_heap_control_block *cb)
+{
+ eassert (cb->refcount > 0);
+ if (--cb->refcount == 0)
+ free (cb->mem);
+}
+
+static void
+dump_mmap_release_heap (struct dump_memory_map *map)
+{
+ dump_mm_heap_cb_release (map->private);
+}
+
+/* Implement dump_mmap using malloc and read. */
+static bool
+dump_mmap_contiguous_heap (struct dump_memory_map *maps, int nr_maps,
+ size_t total_size)
+{
+ bool ret = false;
+ struct dump_memory_map_heap_control_block *cb = calloc (1, sizeof (*cb));
+ char *mem;
+ if (!cb)
+ goto out;
+ cb->refcount = 1;
+ cb->mem = malloc (total_size);
+ if (!cb->mem)
+ goto out;
+ mem = cb->mem;
+ for (int i = 0; i < nr_maps; ++i)
+ {
+ struct dump_memory_map *map = &maps[i];
+ const struct dump_memory_map_spec spec = map->spec;
+ if (!spec.size)
+ continue;
+ map->mapping = mem;
+ mem += spec.size;
+ map->release = dump_mmap_release_heap;
+ map->private = cb;
+ cb->refcount += 1;
+ if (spec.fd < 0)
+ memset (map->mapping, 0, spec.size);
+ else
+ {
+ if (lseek (spec.fd, spec.offset, SEEK_SET) < 0)
+ goto out;
+ ssize_t nb = dump_read_all (spec.fd,
+ map->mapping,
+ spec.size);
+ if (nb >= 0 && nb != spec.size)
+ errno = EIO;
+ if (nb != spec.size)
+ goto out;
+ }
+ }
+
+ ret = true;
+ out:
+ dump_mm_heap_cb_release (cb);
+ if (!ret)
+ for (int i = 0; i < nr_maps; ++i)
+ dump_mmap_release (&maps[i]);
+ return ret;
+}
+
+static void
+dump_mmap_release_vm (struct dump_memory_map *map)
+{
+ if (map->spec.fd < 0)
+ dump_anonymous_release (map->mapping, map->spec.size);
+ else
+ dump_unmap_file (map->mapping, map->spec.size);
+}
+
+static bool
+needs_mmap_retry_p (void)
+{
+#if defined (CYGWIN) || VM_SUPPORTED == VM_MS_WINDOWS
+ return true;
+#else
+ return false;
+#endif
+}
+
+static bool
+dump_mmap_contiguous_vm (struct dump_memory_map *maps, int nr_maps,
+ size_t total_size)
+{
+ bool ret = false;
+ void *resv = NULL;
+ bool retry = false;
+ const bool need_retry = needs_mmap_retry_p ();
+
+ do
+ {
+ if (retry)
+ {
+ eassert (need_retry);
+ retry = false;
+ for (int i = 0; i < nr_maps; ++i)
+ dump_mmap_release (&maps[i]);
+ }
+
+ eassert (resv == NULL);
+ resv = dump_anonymous_allocate (NULL,
+ total_size,
+ DUMP_MEMORY_ACCESS_NONE);
+ if (!resv)
+ goto out;
+
+ char *mem = resv;
+
+ if (need_retry)
+ {
+ /* Windows lacks atomic mapping replace; need to release the
+ reservation so we can allocate within it. Will retry the
+ loop if someone squats on our address space before we can
+ finish allocation. On POSIX systems, we leave the
+ reservation around for atomicity. */
+ dump_anonymous_release (resv, total_size);
+ resv = NULL;
+ }
+
+ for (int i = 0; i < nr_maps; ++i)
+ {
+ struct dump_memory_map *map = &maps[i];
+ const struct dump_memory_map_spec spec = map->spec;
+ if (!spec.size)
+ continue;
+
+ if (spec.fd < 0)
+ map->mapping = dump_anonymous_allocate (mem, spec.size,
+ spec.protection);
+ else
+ map->mapping = dump_map_file (mem, spec.fd, spec.offset,
+ spec.size, spec.protection);
+ mem += spec.size;
+ if (need_retry && map->mapping == NULL
+ && (errno == EBUSY
+#ifdef CYGWIN
+ || errno == EINVAL
+#endif
+ ))
+ {
+ retry = true;
+ continue;
+ }
+ if (map->mapping == NULL)
+ goto out;
+ map->release = dump_mmap_release_vm;
+ }
+ }
+ while (retry);
+
+ ret = true;
+ resv = NULL;
+ out:
+ if (resv)
+ dump_anonymous_release (resv, total_size);
+ if (!ret)
+ {
+ for (int i = 0; i < nr_maps; ++i)
+ {
+ if (need_retry)
+ dump_mmap_reset (&maps[i]);
+ else
+ dump_mmap_release (&maps[i]);
+ }
+ }
+ return ret;
+}
+
+/* Map a range of addresses into a chunk of contiguous memory.
+
+ Each dump_memory_map structure describes how to fill the
+ corresponding range of memory. On input, all members except MAPPING
+ are valid. On output, MAPPING contains the location of the given
+ chunk of memory. The MAPPING for MAPS[N] is MAPS[N-1].mapping +
+ MAPS[N-1].size.
+
+ Each mapping SIZE must be a multiple of the system page size except
+ for the last mapping.
+
+ Return true on success or false on failure with errno set. */
+static bool
+dump_mmap_contiguous (struct dump_memory_map *maps, int nr_maps)
+{
+ if (!nr_maps)
+ return true;
+
+ size_t total_size = 0;
+ int worst_case_page_size = dump_get_page_size ();
+
+ for (int i = 0; i < nr_maps; ++i)
+ {
+ eassert (maps[i].mapping == NULL);
+ eassert (maps[i].release == NULL);
+ eassert (maps[i].private == NULL);
+ if (i != nr_maps - 1)
+ eassert (maps[i].spec.size % worst_case_page_size == 0);
+ total_size += maps[i].spec.size;
+ }
+
+ return (VM_SUPPORTED ? dump_mmap_contiguous_vm : dump_mmap_contiguous_heap)
+ (maps, nr_maps, total_size);
+}
+
+typedef uint_fast32_t dump_bitset_word;
+
+struct dump_bitset
+{
+ dump_bitset_word *restrict bits;
+ ptrdiff_t number_words;
+};
+
+static bool
+dump_bitset_init (struct dump_bitset *bitset, size_t number_bits)
+{
+ int xword_size = sizeof (bitset->bits[0]);
+ int bits_per_word = xword_size * CHAR_BIT;
+ ptrdiff_t words_needed = DIVIDE_ROUND_UP (number_bits, bits_per_word);
+ bitset->number_words = words_needed;
+ bitset->bits = calloc (words_needed, xword_size);
+ return bitset->bits != NULL;
+}
+
+static dump_bitset_word *
+dump_bitset__bit_slot (const struct dump_bitset *bitset,
+ size_t bit_number)
+{
+ int xword_size = sizeof (bitset->bits[0]);
+ int bits_per_word = xword_size * CHAR_BIT;
+ ptrdiff_t word_number = bit_number / bits_per_word;
+ eassert (word_number < bitset->number_words);
+ return &bitset->bits[word_number];
+}
+
+static bool
+dump_bitset_bit_set_p (const struct dump_bitset *bitset,
+ size_t bit_number)
+{
+ unsigned xword_size = sizeof (bitset->bits[0]);
+ unsigned bits_per_word = xword_size * CHAR_BIT;
+ dump_bitset_word bit = 1;
+ bit <<= bit_number % bits_per_word;
+ return *dump_bitset__bit_slot (bitset, bit_number) & bit;
+}
+
+static void
+dump_bitset__set_bit_value (struct dump_bitset *bitset,
+ size_t bit_number,
+ bool bit_is_set)
+{
+ int xword_size = sizeof (bitset->bits[0]);
+ int bits_per_word = xword_size * CHAR_BIT;
+ dump_bitset_word *slot = dump_bitset__bit_slot (bitset, bit_number);
+ dump_bitset_word bit = 1;
+ bit <<= bit_number % bits_per_word;
+ if (bit_is_set)
+ *slot = *slot | bit;
+ else
+ *slot = *slot & ~bit;
+}
+
+static void
+dump_bitset_set_bit (struct dump_bitset *bitset, size_t bit_number)
+{
+ dump_bitset__set_bit_value (bitset, bit_number, true);
+}
+
+static void
+dump_bitset_clear (struct dump_bitset *bitset)
+{
+ int xword_size = sizeof (bitset->bits[0]);
+ memset (bitset->bits, 0, bitset->number_words * xword_size);
+}
+
+struct pdumper_loaded_dump_private
+{
+ /* Copy of the header we read from the dump. */
+ struct dump_header header;
+ /* Mark bits for objects in the dump; used during GC. */
+ struct dump_bitset mark_bits;
+ /* Time taken to load the dump. */
+ double load_time;
+ /* Dump file name. */
+ char *dump_filename;
+};
+
+struct pdumper_loaded_dump dump_public;
+static struct pdumper_loaded_dump_private dump_private;
+
+/* Return a pointer to offset OFFSET within the dump, which begins at
+ DUMP_BASE. DUMP_BASE must be equal to the current dump load
+ location; it's passed as a parameter for efficiency.
+
+ The returned pointer points to the primary memory image of the
+ currently-loaded dump file. The entire dump file is accessible
+ using this function. */
+static void *
+dump_ptr (uintptr_t dump_base, dump_off offset)
+{
+ eassert (dump_base == dump_public.start);
+ eassert (0 <= offset);
+ eassert (dump_public.start + offset < dump_public.end);
+ return (char *)dump_base + offset;
+}
+
+/* Read a pointer-sized word of memory at OFFSET within the dump,
+ which begins at DUMP_BASE. DUMP_BASE must be equal to the current
+ dump load location; it's passed as a parameter for efficiency. */
+static uintptr_t
+dump_read_word_from_dump (uintptr_t dump_base, dump_off offset)
+{
+ uintptr_t value;
+ /* The compiler optimizes this memcpy into a read. */
+ memcpy (&value, dump_ptr (dump_base, offset), sizeof (value));
+ return value;
+}
+
+/* Write a word to the dump. DUMP_BASE and OFFSET are as for
+ dump_read_word_from_dump; VALUE is the word to write at the given
+ offset. */
+static void
+dump_write_word_to_dump (uintptr_t dump_base,
+ dump_off offset,
+ uintptr_t value)
+{
+ /* The compiler optimizes this memcpy into a write. */
+ memcpy (dump_ptr (dump_base, offset), &value, sizeof (value));
+}
+
+/* Write a Lisp_Object to the dump. DUMP_BASE and OFFSET are as for
+ dump_read_word_from_dump; VALUE is the Lisp_Object to write at the
+ given offset. */
+static void
+dump_write_lv_to_dump (uintptr_t dump_base,
+ dump_off offset,
+ Lisp_Object value)
+{
+ /* The compiler optimizes this memcpy into a write. */
+ memcpy (dump_ptr (dump_base, offset), &value, sizeof (value));
+}
+
+/* Search for a relocation given a relocation target.
+
+ DUMP is the dump metadata structure. TABLE is the relocation table
+ to search. KEY is the dump offset to find. Return the relocation
+ RELOC such that RELOC.offset is the smallest RELOC.offset that
+ satisfies the constraint KEY <= RELOC.offset --- that is, return
+ the first relocation at KEY or after KEY. Return NULL if no such
+ relocation exists. */
+static const struct dump_reloc *
+dump_find_relocation (const struct dump_table_locator *const table,
+ const dump_off key)
+{
+ const struct dump_reloc *const relocs = dump_ptr (dump_public.start,
+ table->offset);
+ const struct dump_reloc *found = NULL;
+ ptrdiff_t idx_left = 0;
+ ptrdiff_t idx_right = table->nr_entries;
+
+ eassert (key >= 0);
+
+ while (idx_left < idx_right)
+ {
+ const ptrdiff_t idx_mid = idx_left + (idx_right - idx_left) / 2;
+ const struct dump_reloc *mid = &relocs[idx_mid];
+ if (key > dump_reloc_get_offset (*mid))
+ idx_left = idx_mid + 1;
+ else
+ {
+ found = mid;
+ idx_right = idx_mid;
+ if (idx_right <= idx_left
+ || key > dump_reloc_get_offset (relocs[idx_right - 1]))
+ break;
+ }
+ }
+
+ return found;
+}
+
+static bool
+dump_loaded_p (void)
+{
+ return dump_public.start != 0;
+}
+
+bool
+pdumper_cold_object_p_impl (const void *obj)
+{
+ eassert (pdumper_object_p (obj));
+ eassert (pdumper_object_p_precise (obj));
+ dump_off offset = ptrdiff_t_to_dump_off ((uintptr_t) obj - dump_public.start);
+ return offset >= dump_private.header.cold_start;
+}
+
+enum Lisp_Type
+pdumper_find_object_type_impl (const void *obj)
+{
+ eassert (pdumper_object_p (obj));
+ dump_off offset = ptrdiff_t_to_dump_off ((uintptr_t) obj - dump_public.start);
+ if (offset % DUMP_ALIGNMENT != 0)
+ return PDUMPER_NO_OBJECT;
+ const struct dump_reloc *reloc =
+ dump_find_relocation (&dump_private.header.object_starts, offset);
+ return (reloc != NULL && dump_reloc_get_offset (*reloc) == offset)
+ ? (enum Lisp_Type) reloc->type
+ : PDUMPER_NO_OBJECT;
+}
+
+bool
+pdumper_marked_p_impl (const void *obj)
+{
+ eassert (pdumper_object_p (obj));
+ ptrdiff_t offset = (uintptr_t) obj - dump_public.start;
+ eassert (offset % DUMP_ALIGNMENT == 0);
+ eassert (offset < dump_private.header.cold_start);
+ eassert (offset < dump_private.header.discardable_start);
+ ptrdiff_t bitno = offset / DUMP_ALIGNMENT;
+ return dump_bitset_bit_set_p (&dump_private.mark_bits, bitno);
+}
+
+void
+pdumper_set_marked_impl (const void *obj)
+{
+ eassert (pdumper_object_p (obj));
+ ptrdiff_t offset = (uintptr_t) obj - dump_public.start;
+ eassert (offset % DUMP_ALIGNMENT == 0);
+ eassert (offset < dump_private.header.cold_start);
+ eassert (offset < dump_private.header.discardable_start);
+ ptrdiff_t bitno = offset / DUMP_ALIGNMENT;
+ dump_bitset_set_bit (&dump_private.mark_bits, bitno);
+}
+
+void
+pdumper_clear_marks_impl (void)
+{
+ dump_bitset_clear (&dump_private.mark_bits);
+}
+
+static ssize_t
+dump_read_all (int fd, void *buf, size_t bytes_to_read)
+{
+ /* We don't want to use emacs_read, since that relies on the lisp
+ world, and we're not in the lisp world yet. */
+ eassert (bytes_to_read <= SSIZE_MAX);
+ size_t bytes_read = 0;
+ while (bytes_read < bytes_to_read)
+ {
+ /* Some platforms accept only int-sized values to read. */
+ unsigned chunk_to_read = INT_MAX;
+ if (bytes_to_read - bytes_read < chunk_to_read)
+ chunk_to_read = (unsigned) (bytes_to_read - bytes_read);
+ ssize_t chunk = read (fd, (char *) buf + bytes_read, chunk_to_read);
+ if (chunk < 0)
+ return chunk;
+ if (chunk == 0)
+ break;
+ bytes_read += chunk;
+ }
+
+ return bytes_read;
+}
+
+/* Return the number of bytes written when we perform the given
+ relocation. */
+static int
+dump_reloc_size (const struct dump_reloc reloc)
+{
+ if (sizeof (Lisp_Object) == sizeof (void *))
+ return sizeof (Lisp_Object);
+ if (reloc.type == RELOC_DUMP_TO_EMACS_PTR_RAW
+ || reloc.type == RELOC_DUMP_TO_DUMP_PTR_RAW)
+ return sizeof (void *);
+ return sizeof (Lisp_Object);
+}
+
+static Lisp_Object
+dump_make_lv_from_reloc (const uintptr_t dump_base,
+ const struct dump_reloc reloc)
+{
+ const dump_off reloc_offset = dump_reloc_get_offset (reloc);
+ uintptr_t value = dump_read_word_from_dump (dump_base, reloc_offset);
+ enum Lisp_Type lisp_type;
+
+ if (RELOC_DUMP_TO_DUMP_LV <= reloc.type
+ && reloc.type < RELOC_DUMP_TO_EMACS_LV)
+ {
+ lisp_type = reloc.type - RELOC_DUMP_TO_DUMP_LV;
+ value += dump_base;
+ eassert (pdumper_object_p ((void *) value));
+ }
+ else
+ {
+ eassert (RELOC_DUMP_TO_EMACS_LV <= reloc.type);
+ eassert (reloc.type < RELOC_DUMP_TO_EMACS_LV + 8);
+ lisp_type = reloc.type - RELOC_DUMP_TO_EMACS_LV;
+ value += emacs_basis ();
+ }
+
+ eassert (lisp_type != Lisp_Int0 && lisp_type != Lisp_Int1);
+
+ Lisp_Object lv;
+ if (lisp_type == Lisp_Symbol)
+ lv = make_lisp_symbol ((void *) value);
+ else
+ lv = make_lisp_ptr ((void *) value, lisp_type);
+
+ return lv;
+}
+
+/* Actually apply a dump relocation. */
+static inline void
+dump_do_dump_relocation (const uintptr_t dump_base,
+ const struct dump_reloc reloc)
+{
+ const dump_off reloc_offset = dump_reloc_get_offset (reloc);
+
+ /* We should never generate a relocation in the cold section. */
+ eassert (reloc_offset < dump_private.header.cold_start);
+
+ switch (reloc.type)
+ {
+ case RELOC_DUMP_TO_EMACS_PTR_RAW:
+ {
+ uintptr_t value = dump_read_word_from_dump (dump_base, reloc_offset);
+ eassert (dump_reloc_size (reloc) == sizeof (value));
+ value += emacs_basis ();
+ dump_write_word_to_dump (dump_base, reloc_offset, value);
+ break;
+ }
+ case RELOC_DUMP_TO_DUMP_PTR_RAW:
+ {
+ uintptr_t value = dump_read_word_from_dump (dump_base, reloc_offset);
+ eassert (dump_reloc_size (reloc) == sizeof (value));
+ value += dump_base;
+ dump_write_word_to_dump (dump_base, reloc_offset, value);
+ break;
+ }
+ case RELOC_BIGNUM:
+ {
+ struct Lisp_Bignum *bignum = dump_ptr (dump_base, reloc_offset);
+ struct bignum_reload_info reload_info;
+ verify (sizeof (reload_info) <= sizeof (bignum->value));
+ memcpy (&reload_info, &bignum->value, sizeof (reload_info));
+ const mp_limb_t *limbs =
+ dump_ptr (dump_base, reload_info.data_location);
+ mpz_roinit_n (bignum->value, limbs, reload_info.nlimbs);
+ break;
+ }
+ default: /* Lisp_Object in the dump; precise type in reloc.type */
+ {
+ Lisp_Object lv = dump_make_lv_from_reloc (dump_base, reloc);
+ eassert (dump_reloc_size (reloc) == sizeof (lv));
+ dump_write_lv_to_dump (dump_base, reloc_offset, lv);
+ break;
+ }
+ }
+}
+
+static void
+dump_do_all_dump_relocations (const struct dump_header *const header,
+ const uintptr_t dump_base)
+{
+ struct dump_reloc *r = dump_ptr (dump_base, header->dump_relocs.offset);
+ dump_off nr_entries = header->dump_relocs.nr_entries;
+ for (dump_off i = 0; i < nr_entries; ++i)
+ dump_do_dump_relocation (dump_base, r[i]);
+}
+
+static void
+dump_do_emacs_relocation (const uintptr_t dump_base,
+ const struct emacs_reloc reloc)
+{
+ ptrdiff_t pval;
+ Lisp_Object lv;
+
+ switch (reloc.type)
+ {
+ case RELOC_EMACS_COPY_FROM_DUMP:
+ eassume (reloc.length > 0);
+ memcpy (emacs_ptr_at (reloc.emacs_offset),
+ dump_ptr (dump_base, reloc.u.dump_offset),
+ reloc.length);
+ break;
+ case RELOC_EMACS_IMMEDIATE:
+ eassume (reloc.length > 0);
+ eassume (reloc.length <= sizeof (reloc.u.immediate));
+ memcpy (emacs_ptr_at (reloc.emacs_offset),
+ &reloc.u.immediate,
+ reloc.length);
+ break;
+ case RELOC_EMACS_DUMP_PTR_RAW:
+ pval = reloc.u.dump_offset + dump_base;
+ memcpy (emacs_ptr_at (reloc.emacs_offset), &pval, sizeof (pval));
+ break;
+ case RELOC_EMACS_EMACS_PTR_RAW:
+ pval = reloc.u.emacs_offset2 + emacs_basis ();
+ memcpy (emacs_ptr_at (reloc.emacs_offset), &pval, sizeof (pval));
+ break;
+ case RELOC_EMACS_DUMP_LV:
+ case RELOC_EMACS_EMACS_LV:
+ {
+ /* Lisp_Float is the maximum lisp type. */
+ eassume (reloc.length <= Lisp_Float);
+ void *obj_ptr = reloc.type == RELOC_EMACS_DUMP_LV
+ ? dump_ptr (dump_base, reloc.u.dump_offset)
+ : emacs_ptr_at (reloc.u.emacs_offset2);
+ if (reloc.length == Lisp_Symbol)
+ lv = make_lisp_symbol (obj_ptr);
+ else
+ lv = make_lisp_ptr (obj_ptr, reloc.length);
+ memcpy (emacs_ptr_at (reloc.emacs_offset), &lv, sizeof (lv));
+ break;
+ }
+ default:
+ fatal ("unrecognied relocation type %d", (int) reloc.type);
+ }
+}
+
+static void
+dump_do_all_emacs_relocations (const struct dump_header *const header,
+ const uintptr_t dump_base)
+{
+ const dump_off nr_entries = header->emacs_relocs.nr_entries;
+ struct emacs_reloc *r = dump_ptr (dump_base, header->emacs_relocs.offset);
+ for (dump_off i = 0; i < nr_entries; ++i)
+ dump_do_emacs_relocation (dump_base, r[i]);
+}
+
+enum dump_section
+ {
+ DS_HOT,
+ DS_DISCARDABLE,
+ DS_COLD,
+ NUMBER_DUMP_SECTIONS,
+ };
+
+/* Load a dump from DUMP_FILENAME. Return an error code.
+
+ N.B. We run very early in initialization, so we can't use lisp,
+ unwinding, xmalloc, and so on. */
+enum pdumper_load_result
+pdumper_load (const char *dump_filename)
+{
+ intptr_t dump_size;
+ struct stat stat;
+ uintptr_t dump_base;
+ int dump_page_size;
+ dump_off adj_discardable_start;
+
+ struct dump_bitset mark_bits;
+ size_t mark_bits_needed;
+
+ struct dump_header header_buf = { 0 };
+ struct dump_header *header = &header_buf;
+ struct dump_memory_map sections[NUMBER_DUMP_SECTIONS] = { 0 };
+
+ const struct timespec start_time = current_timespec ();
+ char *dump_filename_copy;
+
+ /* Overwriting an initialized Lisp universe will not go well. */
+ eassert (!initialized);
+
+ /* We can load only one dump. */
+ eassert (!dump_loaded_p ());
+
+ enum pdumper_load_result err = PDUMPER_LOAD_FILE_NOT_FOUND;
+ int dump_fd = emacs_open (dump_filename, O_RDONLY, 0);
+ if (dump_fd < 0)
+ goto out;
+
+ err = PDUMPER_LOAD_FILE_NOT_FOUND;
+ if (fstat (dump_fd, &stat) < 0)
+ goto out;
+
+ err = PDUMPER_LOAD_BAD_FILE_TYPE;
+ if (stat.st_size > INTPTR_MAX)
+ goto out;
+ dump_size = (intptr_t) stat.st_size;
+
+ err = PDUMPER_LOAD_BAD_FILE_TYPE;
+ if (dump_size < sizeof (*header))
+ goto out;
+
+ err = PDUMPER_LOAD_BAD_FILE_TYPE;
+ if (dump_read_all (dump_fd,
+ header,
+ sizeof (*header)) < sizeof (*header))
+ goto out;
+
+ if (memcmp (header->magic, dump_magic, sizeof (dump_magic)) != 0)
+ {
+ if (header->magic[0] == '!'
+ && (header->magic[0] = dump_magic[0],
+ memcmp (header->magic, dump_magic, sizeof (dump_magic)) == 0))
+ {
+ err = PDUMPER_LOAD_FAILED_DUMP;
+ goto out;
+ }
+ err = PDUMPER_LOAD_BAD_FILE_TYPE;
+ goto out;
+ }
+
+ err = PDUMPER_LOAD_VERSION_MISMATCH;
+ verify (sizeof (header->fingerprint) == sizeof (fingerprint));
+ if (memcmp (header->fingerprint, fingerprint, sizeof (fingerprint)) != 0)
+ {
+ dump_fingerprint ("desired fingerprint", fingerprint);
+ dump_fingerprint ("found fingerprint", header->fingerprint);
+ goto out;
+ }
+
+ /* FIXME: The comment at the start of this function says it should
+ not use xmalloc, but xstrdup calls xmalloc. Either fix the
+ comment or fix the following code. */
+ dump_filename_copy = xstrdup (dump_filename);
+
+ err = PDUMPER_LOAD_OOM;
+
+ adj_discardable_start = header->discardable_start;
+ dump_page_size = dump_get_page_size ();
+ /* Snap to next page boundary. */
+ adj_discardable_start = ROUNDUP (adj_discardable_start, dump_page_size);
+ eassert (adj_discardable_start % dump_page_size == 0);
+ eassert (adj_discardable_start <= header->cold_start);
+
+ sections[DS_HOT].spec = (struct dump_memory_map_spec)
+ {
+ .fd = dump_fd,
+ .size = adj_discardable_start,
+ .offset = 0,
+ .protection = DUMP_MEMORY_ACCESS_READWRITE,
+ };
+
+ sections[DS_DISCARDABLE].spec = (struct dump_memory_map_spec)
+ {
+ .fd = dump_fd,
+ .size = header->cold_start - adj_discardable_start,
+ .offset = adj_discardable_start,
+ .protection = DUMP_MEMORY_ACCESS_READWRITE,
+ };
+
+ sections[DS_COLD].spec = (struct dump_memory_map_spec)
+ {
+ .fd = dump_fd,
+ .size = dump_size - header->cold_start,
+ .offset = header->cold_start,
+ .protection = DUMP_MEMORY_ACCESS_READWRITE,
+ };
+
+ if (!dump_mmap_contiguous (sections, ARRAYELTS (sections)))
+ goto out;
+
+ err = PDUMPER_LOAD_ERROR;
+ mark_bits_needed =
+ DIVIDE_ROUND_UP (header->discardable_start, DUMP_ALIGNMENT);
+ if (!dump_bitset_init (&mark_bits, mark_bits_needed))
+ goto out;
+
+ /* Point of no return. */
+ err = PDUMPER_LOAD_SUCCESS;
+ dump_base = (uintptr_t) sections[DS_HOT].mapping;
+ gflags.dumped_with_pdumper_ = true;
+ dump_private.header = *header;
+ dump_private.mark_bits = mark_bits;
+ dump_public.start = dump_base;
+ dump_public.end = dump_public.start + dump_size;
+
+ dump_do_all_dump_relocations (header, dump_base);
+ dump_do_all_emacs_relocations (header, dump_base);
+
+ dump_mmap_discard_contents (&sections[DS_DISCARDABLE]);
+ for (int i = 0; i < ARRAYELTS (sections); ++i)
+ dump_mmap_reset (&sections[i]);
+
+ /* Run the functions Emacs registered for doing post-dump-load
+ initialization. */
+ for (int i = 0; i < nr_dump_hooks; ++i)
+ dump_hooks[i] ();
+ initialized = true;
+
+ struct timespec load_timespec =
+ timespec_sub (current_timespec (), start_time);
+ dump_private.load_time = timespectod (load_timespec);
+ dump_private.dump_filename = dump_filename_copy;
+
+ out:
+ for (int i = 0; i < ARRAYELTS (sections); ++i)
+ dump_mmap_release (&sections[i]);
+ if (dump_fd >= 0)
+ emacs_close (dump_fd);
+ return err;
+}
+
+/* Prepend the Emacs startup directory to dump_filename, if that is
+ relative, so that we could later make it absolute correctly. */
+void
+pdumper_record_wd (const char *wd)
+{
+ if (wd && !file_name_absolute_p (dump_private.dump_filename))
+ {
+ char *dfn = xmalloc (strlen (wd) + 1
+ + strlen (dump_private.dump_filename) + 1);
+ splice_dir_file (dfn, wd, dump_private.dump_filename);
+ xfree (dump_private.dump_filename);
+ dump_private.dump_filename = dfn;
+ }
+}
+
+DEFUN ("pdumper-stats", Fpdumper_stats, Spdumper_stats, 0, 0, 0,
+ doc: /* Return statistics about portable dumping used by this session.
+If this Emacs sesion was started from a portable dump file,
+the return value is an alist of the form:
+
+ ((dumped-with-pdumper . t) (load-time . TIME) (dump-file-name . FILE))
+
+where TIME is the time in seconds it took to restore Emacs state
+from the dump file, and FILE is the name of the dump file.
+Value is nil if this session was not started using a portable dump file.*/)
+ (void)
+{
+ if (!dumped_with_pdumper_p ())
+ return Qnil;
+
+ Lisp_Object dump_fn;
+#ifdef WINDOWSNT
+ char dump_fn_utf8[MAX_UTF8_PATH];
+ if (filename_from_ansi (dump_private.dump_filename, dump_fn_utf8) == 0)
+ dump_fn = DECODE_FILE (build_unibyte_string (dump_fn_utf8));
+ else
+ dump_fn = build_unibyte_string (dump_private.dump_filename);
+#else
+ dump_fn = DECODE_FILE (build_unibyte_string (dump_private.dump_filename));
+#endif
+
+ dump_fn = Fexpand_file_name (dump_fn, Qnil);
+
+ return list3 (Fcons (Qdumped_with_pdumper, Qt),
+ Fcons (Qload_time, make_float (dump_private.load_time)),
+ Fcons (Qdump_file_name, dump_fn));
+}
+
+#endif /* HAVE_PDUMPER */
+
+
+
+void
+syms_of_pdumper (void)
+{
+#ifdef HAVE_PDUMPER
+ defsubr (&Sdump_emacs_portable);
+ defsubr (&Sdump_emacs_portable__sort_predicate);
+ defsubr (&Sdump_emacs_portable__sort_predicate_copied);
+ DEFSYM (Qdump_emacs_portable__sort_predicate,
+ "dump-emacs-portable--sort-predicate");
+ DEFSYM (Qdump_emacs_portable__sort_predicate_copied,
+ "dump-emacs-portable--sort-predicate-copied");
+ DEFSYM (Qdumped_with_pdumper, "dumped-with-pdumper");
+ DEFSYM (Qload_time, "load-time");
+ DEFSYM (Qdump_file_name, "dump-file-name");
+ defsubr (&Spdumper_stats);
+#endif /* HAVE_PDUMPER */
+}
diff --git a/src/pdumper.h b/src/pdumper.h
new file mode 100644
index 00000000000..ab2f426c1e9
--- /dev/null
+++ b/src/pdumper.h
@@ -0,0 +1,254 @@
+/* Header file for the portable dumper.
+
+Copyright (C) 2016, 2018-2019 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 <http://www.gnu.org/licenses/>. */
+
+#ifndef EMACS_PDUMPER_H
+#define EMACS_PDUMPER_H
+
+#include "lisp.h"
+
+INLINE_HEADER_BEGIN
+
+#define PDUMPER_NO_OBJECT ((enum Lisp_Type) -1)
+
+/* Indicate in source code that we're deliberately relying on pdumper
+ not preserving the given value. Compiles to nothing --- for humans
+ only. */
+#define PDUMPER_IGNORE(thing) ((void) &(thing))
+
+/* The portable dumper automatically preserves the Lisp heap and any C
+ variables to which the Lisp heap points. It doesn't know anything
+ about other C variables. The functions below allow code from other
+ parts of Emacs to tell the portable dumper about other bits of
+ information to preserve in dumped images.
+
+ These memory-records are themselves preserved in the dump, so call
+ the functions below only on the !initialized init path, just
+ like staticpro.
+
+ There are no special functions to preserve a global Lisp_Object.
+ You should just staticpro these. */
+
+/* Remember the value of THING in dumped images. THING must not
+ contain any pointers or Lisp_Object variables: these values are not
+ valid across dump and load. */
+#define PDUMPER_REMEMBER_SCALAR(thing) \
+ pdumper_remember_scalar (&(thing), sizeof (thing))
+
+extern void pdumper_remember_scalar_impl (void *data, ptrdiff_t nbytes);
+
+INLINE void
+pdumper_remember_scalar (void *data, ptrdiff_t nbytes)
+{
+#ifdef HAVE_PDUMPER
+ pdumper_remember_scalar_impl (data, nbytes);
+#else
+ (void) data;
+ (void) nbytes;
+#endif
+}
+
+extern void pdumper_remember_lv_ptr_raw_impl (void *ptr, enum Lisp_Type type);
+
+/* Remember the pointer at *PTR. *PTR must be null or point to a Lisp
+ object. TYPE is the rough type of Lisp object to which *PTR
+ points. */
+INLINE void
+pdumper_remember_lv_ptr_raw (void *ptr, enum Lisp_Type type)
+{
+#ifdef HAVE_PDUMPER
+ pdumper_remember_lv_ptr_raw_impl (ptr, type);
+#else
+ (void) ptr;
+ (void) type;
+#endif
+}
+
+typedef void (*pdumper_hook)(void);
+extern void pdumper_do_now_and_after_load_impl (pdumper_hook hook);
+
+INLINE void
+pdumper_do_now_and_after_load (pdumper_hook hook)
+{
+#ifdef HAVE_PDUMPER
+ pdumper_do_now_and_after_load_impl (hook);
+#else
+ hook ();
+#endif
+}
+
+/* Macros useful in pdumper callback functions. Assign a value if
+ we're loading a dump and the value needs to be reset to its
+ original value, and if we're initializing for the first time,
+ assert that the value has the expected original value. */
+
+#define PDUMPER_RESET(variable, value) \
+ do { \
+ if (dumped_with_pdumper_p ()) \
+ (variable) = (value); \
+ else \
+ eassert ((variable) == (value)); \
+ } while (0)
+
+#define PDUMPER_RESET_LV(variable, value) \
+ do { \
+ if (dumped_with_pdumper_p ()) \
+ (variable) = (value); \
+ else \
+ eassert (EQ ((variable), (value))); \
+ } while (0)
+
+/* Actually load a dump. */
+
+enum pdumper_load_result
+ {
+ PDUMPER_LOAD_SUCCESS,
+ PDUMPER_NOT_LOADED /* Not returned: useful for callers */,
+ PDUMPER_LOAD_FILE_NOT_FOUND,
+ PDUMPER_LOAD_BAD_FILE_TYPE,
+ PDUMPER_LOAD_FAILED_DUMP,
+ PDUMPER_LOAD_OOM,
+ PDUMPER_LOAD_VERSION_MISMATCH,
+ PDUMPER_LOAD_ERROR,
+ };
+
+enum pdumper_load_result pdumper_load (const char *dump_filename);
+
+struct pdumper_loaded_dump
+{
+ uintptr_t start;
+ uintptr_t end;
+};
+
+extern struct pdumper_loaded_dump dump_public;
+
+/* Return whether the OBJ points somewhere into the loaded dump image.
+ Works even when we have no dump loaded --- in this case, it just
+ returns false. */
+INLINE _GL_ATTRIBUTE_CONST bool
+pdumper_object_p (const void *obj)
+{
+#ifdef HAVE_PDUMPER
+ uintptr_t obj_addr = (uintptr_t) obj;
+ return dump_public.start <= obj_addr && obj_addr < dump_public.end;
+#else
+ (void) obj;
+ return false;
+#endif
+}
+
+extern bool pdumper_cold_object_p_impl (const void *obj);
+
+/* Return whether the OBJ is in the cold section of the dump.
+ Only bool-vectors and floats should end up there.
+ pdumper_object_p() and pdumper_object_p_precise() must have
+ returned true for OBJ before calling this function. */
+INLINE _GL_ATTRIBUTE_CONST bool
+pdumper_cold_object_p (const void *obj)
+{
+#ifdef HAVE_PDUMPER
+ return pdumper_cold_object_p_impl (obj);
+#else
+ (void) obj;
+ return false;
+#endif
+}
+
+
+extern enum Lisp_Type pdumper_find_object_type_impl (const void *obj);
+
+/* Return the type of the dumped object that starts at OBJ. It is a
+ programming error to call this routine for an OBJ for which
+ pdumper_object_p would return false. */
+INLINE _GL_ATTRIBUTE_CONST enum Lisp_Type
+pdumper_find_object_type (const void *obj)
+{
+#ifdef HAVE_PDUMPER
+ return pdumper_find_object_type_impl (obj);
+#else
+ (void) obj;
+ emacs_abort ();
+#endif
+}
+
+/* Return whether OBJ points exactly to the start of some object in
+ the loaded dump image. It is a programming error to call this
+ routine for an OBJ for which pdumper_object_p would return
+ false. */
+INLINE _GL_ATTRIBUTE_CONST bool
+pdumper_object_p_precise (const void *obj)
+{
+#ifdef HAVE_PDUMPER
+ return pdumper_find_object_type (obj) != PDUMPER_NO_OBJECT;
+#else
+ (void) obj;
+ emacs_abort ();
+#endif
+}
+
+extern bool pdumper_marked_p_impl (const void *obj);
+
+/* Return whether OBJ is marked according to the portable dumper.
+ It is an error to call this routine for an OBJ for which
+ pdumper_object_p_precise would return false. */
+INLINE bool
+pdumper_marked_p (const void *obj)
+{
+#ifdef HAVE_PDUMPER
+ return pdumper_marked_p_impl (obj);
+#else
+ (void) obj;
+ emacs_abort ();
+#endif
+}
+
+extern void pdumper_set_marked_impl (const void *obj);
+
+/* Set the pdumper mark bit for OBJ. It is a programming error to
+ call this function with an OBJ for which pdumper_object_p_precise
+ would return false. */
+INLINE void
+pdumper_set_marked (const void *obj)
+{
+#ifdef HAVE_PDUMPER
+ pdumper_set_marked_impl (obj);
+#else
+ (void) obj;
+ emacs_abort ();
+#endif
+}
+
+extern void pdumper_clear_marks_impl (void);
+
+/* Clear all the mark bits for pdumper objects. */
+INLINE void
+pdumper_clear_marks (void)
+{
+#ifdef HAVE_PDUMPER
+ pdumper_clear_marks_impl ();
+#endif
+}
+
+/* Record the Emacs startup directory, relative to which the pdump
+ file was loaded. */
+extern void pdumper_record_wd (const char *);
+
+void syms_of_pdumper (void);
+
+INLINE_HEADER_END
+#endif
diff --git a/src/print.c b/src/print.c
index f626e610d2d..67c4ed03ee8 100644
--- a/src/print.c
+++ b/src/print.c
@@ -38,6 +38,11 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <c-ctype.h>
#include <float.h>
#include <ftoastr.h>
+#include <math.h>
+
+#if IEEE_FLOATING_POINT
+# include <ieee754.h>
+#endif
#ifdef WINDOWSNT
# include <sys/socket.h> /* for F_DUPFD_CLOEXEC */
@@ -261,7 +266,7 @@ printchar_to_stream (unsigned int ch, FILE *stream)
break;
if (! (i < n))
break;
- ch = XFASTINT (AREF (dv, i));
+ ch = XFIXNAT (AREF (dv, i));
}
}
@@ -274,7 +279,7 @@ static void
printchar (unsigned int ch, Lisp_Object fun)
{
if (!NILP (fun) && !EQ (fun, Qt))
- call1 (fun, make_number (ch));
+ call1 (fun, make_fixnum (ch));
else
{
unsigned char str[MAX_MULTIBYTE_LENGTH];
@@ -313,6 +318,25 @@ printchar (unsigned int ch, Lisp_Object fun)
}
}
+/* Output an octal escape for C. If C is less than '\100' consult the
+ following character (if any) to see whether to use three octal
+ digits to avoid misinterpretation of the next character. The next
+ character after C will be taken from DATA, starting at byte
+ location I, if I is less than SIZE. Use PRINTCHARFUN to output
+ each character. */
+
+static void
+octalout (unsigned char c, unsigned char *data, ptrdiff_t i, ptrdiff_t size,
+ Lisp_Object printcharfun)
+{
+ int digits = (c > '\77' || (i < size && '0' <= data[i] && data[i] <= '7')
+ ? 3
+ : c > '\7' ? 2 : 1);
+ printchar ('\\', printcharfun);
+ do
+ printchar ('0' + ((c >> (3 * --digits)) & 7), printcharfun);
+ while (digits != 0);
+}
/* Output SIZE characters, SIZE_BYTE bytes from string PTR using
method PRINTCHARFUN. PRINTCHARFUN nil means output to
@@ -501,9 +525,9 @@ PRINTCHARFUN defaults to the value of `standard-output' (which see). */)
{
if (NILP (printcharfun))
printcharfun = Vstandard_output;
- CHECK_NUMBER (character);
+ CHECK_FIXNUM (character);
PRINTPREPARE;
- printchar (XINT (character), printcharfun);
+ printchar (XFIXNUM (character), printcharfun);
PRINTFINISH;
return character;
}
@@ -752,8 +776,8 @@ You can call `print' while debugging emacs, and pass it this function
to make it write to the debugging output. */)
(Lisp_Object character)
{
- CHECK_NUMBER (character);
- printchar_to_stream (XINT (character), stderr);
+ CHECK_FIXNUM (character);
+ printchar_to_stream (XFIXNUM (character), stderr);
return character;
}
@@ -836,6 +860,17 @@ safe_debug_print (Lisp_Object arg)
}
}
+/* This function formats the given object and returns the result as a
+ string. Use this in contexts where you can inspect strings, but
+ where stderr output won't work --- e.g., while replaying rr
+ recordings. */
+const char * debug_format (const char *, Lisp_Object) EXTERNALLY_VISIBLE;
+const char *
+debug_format (const char *fmt, Lisp_Object arg)
+{
+ return SSDATA (CALLN (Fformat, build_string (fmt), arg));
+}
+
DEFUN ("error-message-string", Ferror_message_string, Serror_message_string,
1, 1, 0,
@@ -971,43 +1006,22 @@ float_to_string (char *buf, double data)
int width;
int len;
- /* Check for plus infinity in a way that won't lose
- if there is no plus infinity. */
- if (data == data / 2 && data > 1.0)
- {
- static char const infinity_string[] = "1.0e+INF";
- strcpy (buf, infinity_string);
- return sizeof infinity_string - 1;
- }
- /* Likewise for minus infinity. */
- if (data == data / 2 && data < -1.0)
+ if (isinf (data))
{
static char const minus_infinity_string[] = "-1.0e+INF";
- strcpy (buf, minus_infinity_string);
- return sizeof minus_infinity_string - 1;
+ bool positive = 0 < data;
+ strcpy (buf, minus_infinity_string + positive);
+ return sizeof minus_infinity_string - 1 - positive;
}
- /* Check for NaN in a way that won't fail if there are no NaNs. */
- if (! (data * 0.0 >= 0.0))
+#if IEEE_FLOATING_POINT
+ if (isnan (data))
{
- /* Prepend "-" if the NaN's sign bit is negative.
- The sign bit of a double is the bit that is 1 in -0.0. */
- static char const NaN_string[] = "0.0e+NaN";
- int i;
- union { double d; char c[sizeof (double)]; } u_data, u_minus_zero;
- bool negative = 0;
- u_data.d = data;
- u_minus_zero.d = - 0.0;
- for (i = 0; i < sizeof (double); i++)
- if (u_data.c[i] & u_minus_zero.c[i])
- {
- *buf = '-';
- negative = 1;
- break;
- }
-
- strcpy (buf + negative, NaN_string);
- return negative + sizeof NaN_string - 1;
+ union ieee754_double u = { .d = data };
+ uprintmax_t hi = u.ieee_nan.mantissa0;
+ return sprintf (buf, &"-%"pMu".0e+NaN"[!u.ieee_nan.negative],
+ (hi << 31 << 1) + u.ieee_nan.mantissa1);
}
+#endif
if (NILP (Vfloat_output_format)
|| !STRINGP (Vfloat_output_format))
@@ -1194,11 +1208,11 @@ print_preprocess (Lisp_Object obj)
&& SYMBOLP (obj)
&& !SYMBOL_INTERNED_P (obj)))
{ /* OBJ appears more than once. Let's remember that. */
- if (!INTEGERP (num))
+ if (!FIXNUMP (num))
{
print_number_index++;
/* Negative number indicates it hasn't been printed yet. */
- Fputhash (obj, make_number (- print_number_index),
+ Fputhash (obj, make_fixnum (- print_number_index),
Vprint_number_table);
}
print_depth--;
@@ -1298,8 +1312,7 @@ print_check_string_charset_prop (INTERVAL interval, Lisp_Object string)
|| CONSP (XCDR (XCDR (val))))
print_check_string_result |= PRINT_STRING_NON_CHARSET_FOUND;
}
- if (NILP (Vprint_charset_text_property)
- || ! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND))
+ if (! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND))
{
int i, c;
ptrdiff_t charpos = interval->position;
@@ -1329,19 +1342,20 @@ print_prune_string_charset (Lisp_Object string)
print_check_string_result = 0;
traverse_intervals (string_intervals (string), 0,
print_check_string_charset_prop, string);
- if (! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND))
+ if (NILP (Vprint_charset_text_property)
+ || ! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND))
{
string = Fcopy_sequence (string);
if (print_check_string_result & PRINT_STRING_NON_CHARSET_FOUND)
{
if (NILP (print_prune_charset_plist))
print_prune_charset_plist = list1 (Qcharset);
- Fremove_text_properties (make_number (0),
- make_number (SCHARS (string)),
+ Fremove_text_properties (make_fixnum (0),
+ make_fixnum (SCHARS (string)),
print_prune_charset_plist, string);
}
else
- Fset_text_properties (make_number (0), make_number (SCHARS (string)),
+ Fset_text_properties (make_fixnum (0), make_fixnum (SCHARS (string)),
Qnil, string);
}
return string;
@@ -1353,6 +1367,78 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
{
switch (PSEUDOVECTOR_TYPE (XVECTOR (obj)))
{
+ case PVEC_BIGNUM:
+ {
+ ptrdiff_t size = bignum_bufsize (obj, 10);
+ USE_SAFE_ALLOCA;
+ char *str = SAFE_ALLOCA (size);
+ ptrdiff_t len = bignum_to_c_string (str, size, obj, 10);
+ strout (str, len, len, printcharfun);
+ SAFE_FREE ();
+ }
+ break;
+
+ case PVEC_MARKER:
+ print_c_string ("#<marker ", printcharfun);
+ /* Do you think this is necessary? */
+ if (XMARKER (obj)->insertion_type != 0)
+ print_c_string ("(moves after insertion) ", printcharfun);
+ if (! XMARKER (obj)->buffer)
+ print_c_string ("in no buffer", printcharfun);
+ else
+ {
+ int len = sprintf (buf, "at %"pD"d in ", marker_position (obj));
+ strout (buf, len, len, printcharfun);
+ print_string (BVAR (XMARKER (obj)->buffer, name), printcharfun);
+ }
+ printchar ('>', printcharfun);
+ break;
+
+ case PVEC_OVERLAY:
+ print_c_string ("#<overlay ", printcharfun);
+ if (! XMARKER (OVERLAY_START (obj))->buffer)
+ print_c_string ("in no buffer", printcharfun);
+ else
+ {
+ int len = sprintf (buf, "from %"pD"d to %"pD"d in ",
+ marker_position (OVERLAY_START (obj)),
+ marker_position (OVERLAY_END (obj)));
+ strout (buf, len, len, printcharfun);
+ print_string (BVAR (XMARKER (OVERLAY_START (obj))->buffer, name),
+ printcharfun);
+ }
+ printchar ('>', printcharfun);
+ break;
+
+#ifdef HAVE_MODULES
+ case PVEC_USER_PTR:
+ {
+ print_c_string ("#<user-ptr ", printcharfun);
+ int i = sprintf (buf, "ptr=%p finalizer=%p",
+ XUSER_PTR (obj)->p,
+ XUSER_PTR (obj)->finalizer);
+ strout (buf, i, i, printcharfun);
+ printchar ('>', printcharfun);
+ }
+ break;
+#endif
+
+ case PVEC_FINALIZER:
+ print_c_string ("#<finalizer", printcharfun);
+ if (NILP (XFINALIZER (obj)->function))
+ print_c_string (" used", printcharfun);
+ printchar ('>', printcharfun);
+ break;
+
+ case PVEC_MISC_PTR:
+ {
+ /* This shouldn't happen in normal usage, but let's
+ print it anyway for the benefit of the debugger. */
+ int i = sprintf (buf, "#<ptr %p>", xmint_pointer (obj));
+ strout (buf, i, i, printcharfun);
+ }
+ break;
+
case PVEC_PROCESS:
if (escapeflag)
{
@@ -1367,32 +1453,33 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
case PVEC_BOOL_VECTOR:
{
EMACS_INT size = bool_vector_size (obj);
- ptrdiff_t size_in_chars = bool_vector_bytes (size);
- ptrdiff_t real_size_in_chars = size_in_chars;
+ ptrdiff_t size_in_bytes = bool_vector_bytes (size);
+ ptrdiff_t real_size_in_bytes = size_in_bytes;
+ unsigned char *data = bool_vector_uchar_data (obj);
int len = sprintf (buf, "#&%"pI"d\"", size);
strout (buf, len, len, printcharfun);
- /* Don't print more characters than the specified maximum.
+ /* Don't print more bytes than the specified maximum.
Negative values of print-length are invalid. Treat them
like a print-length of nil. */
- if (NATNUMP (Vprint_length)
- && XFASTINT (Vprint_length) < size_in_chars)
- size_in_chars = XFASTINT (Vprint_length);
+ if (FIXNATP (Vprint_length)
+ && XFIXNAT (Vprint_length) < size_in_bytes)
+ size_in_bytes = XFIXNAT (Vprint_length);
- for (ptrdiff_t i = 0; i < size_in_chars; i++)
+ for (ptrdiff_t i = 0; i < size_in_bytes; i++)
{
maybe_quit ();
- unsigned char c = bool_vector_uchar_data (obj)[i];
+ unsigned char c = data[i];
if (c == '\n' && print_escape_newlines)
print_c_string ("\\n", printcharfun);
else if (c == '\f' && print_escape_newlines)
print_c_string ("\\f", printcharfun);
- else if (c > '\177')
+ else if (c > '\177'
+ || (print_escape_control_characters && c_iscntrl (c)))
{
/* Use octal escapes to avoid encoding issues. */
- int len = sprintf (buf, "\\%o", c);
- strout (buf, len, len, printcharfun);
+ octalout (c, data, i + 1, size_in_bytes, printcharfun);
}
else
{
@@ -1402,7 +1489,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
}
}
- if (size_in_chars < real_size_in_chars)
+ if (size_in_bytes < real_size_in_bytes)
print_c_string (" ...", printcharfun);
printchar ('\"', printcharfun);
}
@@ -1490,8 +1577,8 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
ptrdiff_t size = real_size;
/* Don't print more elements than the specified maximum. */
- if (NATNUMP (Vprint_length) && XFASTINT (Vprint_length) < size)
- size = XFASTINT (Vprint_length);
+ if (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size)
+ size = XFIXNAT (Vprint_length);
printchar ('(', printcharfun);
for (ptrdiff_t i = 0; i < size; i++)
@@ -1621,8 +1708,8 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
/* Don't print more elements than the specified maximum. */
ptrdiff_t n
- = (NATNUMP (Vprint_length) && XFASTINT (Vprint_length) < size
- ? XFASTINT (Vprint_length) : size);
+ = (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size
+ ? XFIXNAT (Vprint_length) : size);
print_c_string ("#s(", printcharfun);
for (ptrdiff_t i = 0; i < n; i ++)
@@ -1682,9 +1769,9 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
}
/* Don't print more elements than the specified maximum. */
- if (NATNUMP (Vprint_length)
- && XFASTINT (Vprint_length) < size)
- size = XFASTINT (Vprint_length);
+ if (FIXNATP (Vprint_length)
+ && XFIXNAT (Vprint_length) < size)
+ size = XFIXNAT (Vprint_length);
for (int i = idx; i < size; i++)
{
@@ -1774,16 +1861,16 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
{
/* With the print-circle feature. */
Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil);
- if (INTEGERP (num))
+ if (FIXNUMP (num))
{
- EMACS_INT n = XINT (num);
+ EMACS_INT n = XFIXNUM (num);
if (n < 0)
{ /* Add a prefix #n= if OBJ has not yet been printed;
that is, its status field is nil. */
int len = sprintf (buf, "#%"pI"d=", -n);
strout (buf, len, len, printcharfun);
/* OBJ is going to be printed. Remember that fact. */
- Fputhash (obj, make_number (- n), Vprint_number_table);
+ Fputhash (obj, make_fixnum (- n), Vprint_number_table);
}
else
{
@@ -1801,7 +1888,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
{
case_Lisp_Int:
{
- int len = sprintf (buf, "%"pI"d", XINT (obj));
+ int len = sprintf (buf, "%"pI"d", XFIXNUM (obj));
strout (buf, len, len, printcharfun);
}
break;
@@ -1854,9 +1941,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
(when requested) a non-ASCII character in a unibyte buffer,
print single-byte non-ASCII string chars
using octal escapes. */
- char outbuf[5];
- int len = sprintf (outbuf, "\\%03o", c + 0u);
- strout (outbuf, len, len, printcharfun);
+ octalout (c, SDATA (obj), i_byte, size_byte, printcharfun);
need_nonhex = false;
}
else if (multibyte
@@ -1870,7 +1955,6 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
}
else
{
- bool still_need_nonhex = false;
/* If we just had a hex escape, and this character
could be taken as part of it,
output `\ ' to prevent that. */
@@ -1884,22 +1968,16 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
? (c = 'n', true)
: c == '\f' && print_escape_newlines
? (c = 'f', true)
- : c == '\0' && print_escape_control_characters
- ? (c = '0', still_need_nonhex = true)
: c == '\"' || c == '\\')
{
printchar ('\\', printcharfun);
printchar (c, printcharfun);
}
else if (print_escape_control_characters && c_iscntrl (c))
- {
- char outbuf[1 + 3 + 1];
- int len = sprintf (outbuf, "\\%03o", c + 0u);
- strout (outbuf, len, len, printcharfun);
- }
+ octalout (c, SDATA (obj), i_byte, size_byte, printcharfun);
else
printchar (c, printcharfun);
- need_nonhex = still_need_nonhex;
+ need_nonhex = false;
}
}
printchar ('\"', printcharfun);
@@ -1915,39 +1993,17 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
case Lisp_Symbol:
{
- bool confusing;
- unsigned char *p = SDATA (SYMBOL_NAME (obj));
- unsigned char *end = p + SBYTES (SYMBOL_NAME (obj));
- int c;
- ptrdiff_t i, i_byte;
- ptrdiff_t size_byte;
- Lisp_Object name;
-
- name = SYMBOL_NAME (obj);
-
- if (p != end && (*p == '-' || *p == '+')) p++;
- if (p == end)
- confusing = 0;
- /* If symbol name begins with a digit, and ends with a digit,
- and contains nothing but digits and `e', it could be treated
- as a number. So set CONFUSING.
-
- Symbols that contain periods could also be taken as numbers,
- but periods are always escaped, so we don't have to worry
- about them here. */
- else if (*p >= '0' && *p <= '9'
- && end[-1] >= '0' && end[-1] <= '9')
- {
- while (p != end && ((*p >= '0' && *p <= '9')
- /* Needed for \2e10. */
- || *p == 'e' || *p == 'E'))
- p++;
- confusing = (end == p);
- }
- else
- confusing = 0;
-
- size_byte = SBYTES (name);
+ Lisp_Object name = SYMBOL_NAME (obj);
+ ptrdiff_t size_byte = SBYTES (name);
+
+ /* Set CONFUSING if NAME looks like a number, calling
+ string_to_number for non-obvious cases. */
+ char *p = SSDATA (name);
+ bool signedp = *p == '-' || *p == '+';
+ ptrdiff_t len;
+ bool confusing = ((c_isdigit (p[signedp]) || p[signedp] == '.')
+ && !NILP (string_to_number (p, 10, &len))
+ && len == size_byte);
if (! NILP (Vprint_gensym)
&& !SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (obj))
@@ -1958,10 +2014,12 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
break;
}
- for (i = 0, i_byte = 0; i_byte < size_byte;)
+ ptrdiff_t i = 0;
+ for (ptrdiff_t i_byte = 0; i_byte < size_byte; )
{
/* Here, we must convert each multi-byte form to the
corresponding character code before handing it to PRINTCHAR. */
+ int c;
FETCH_STRING_CHAR_ADVANCE (c, name, i, i_byte);
maybe_quit ();
@@ -1971,7 +2029,9 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
|| c == ';' || c == '#' || c == '(' || c == ')'
|| c == ',' || c == '.' || c == '`'
|| c == '[' || c == ']' || c == '?' || c <= 040
- || confusing)
+ || c == NO_BREAK_SPACE
+ || confusing
+ || (i == 1 && confusable_symbol_character_p (c)))
{
printchar ('\\', printcharfun);
confusing = false;
@@ -1984,8 +2044,8 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
case Lisp_Cons:
/* If deeper than spec'd depth, print placeholder. */
- if (INTEGERP (Vprint_level)
- && print_depth > XINT (Vprint_level))
+ if (FIXNUMP (Vprint_level)
+ && print_depth > XFIXNUM (Vprint_level))
print_c_string ("...", printcharfun);
else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
&& EQ (XCAR (obj), Qquote))
@@ -2026,8 +2086,8 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
/* Negative values of print-length are invalid in CL.
Treat them like nil, as CMUCL does. */
- printmax_t print_length = (NATNUMP (Vprint_length)
- ? XFASTINT (Vprint_length)
+ printmax_t print_length = (FIXNATP (Vprint_length)
+ ? XFIXNAT (Vprint_length)
: TYPE_MAXIMUM (printmax_t));
printmax_t i = 0;
@@ -2050,7 +2110,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
if (i != 0)
{
Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil);
- if (INTEGERP (num))
+ if (FIXNUMP (num))
{
print_c_string (" . ", printcharfun);
print_object (obj, printcharfun, escapeflag);
@@ -2089,170 +2149,16 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
break;
case Lisp_Vectorlike:
- if (! print_vectorlike (obj, printcharfun, escapeflag, buf))
- goto badtype;
- break;
-
- case Lisp_Misc:
- switch (XMISCTYPE (obj))
- {
- case Lisp_Misc_Marker:
- print_c_string ("#<marker ", printcharfun);
- /* Do you think this is necessary? */
- if (XMARKER (obj)->insertion_type != 0)
- print_c_string ("(moves after insertion) ", printcharfun);
- if (! XMARKER (obj)->buffer)
- print_c_string ("in no buffer", printcharfun);
- else
- {
- int len = sprintf (buf, "at %"pD"d in ", marker_position (obj));
- strout (buf, len, len, printcharfun);
- print_string (BVAR (XMARKER (obj)->buffer, name), printcharfun);
- }
- printchar ('>', printcharfun);
- break;
-
- case Lisp_Misc_Overlay:
- print_c_string ("#<overlay ", printcharfun);
- if (! XMARKER (OVERLAY_START (obj))->buffer)
- print_c_string ("in no buffer", printcharfun);
- else
- {
- int len = sprintf (buf, "from %"pD"d to %"pD"d in ",
- marker_position (OVERLAY_START (obj)),
- marker_position (OVERLAY_END (obj)));
- strout (buf, len, len, printcharfun);
- print_string (BVAR (XMARKER (OVERLAY_START (obj))->buffer, name),
- printcharfun);
- }
- printchar ('>', printcharfun);
- break;
-
-#ifdef HAVE_MODULES
- case Lisp_Misc_User_Ptr:
- {
- print_c_string ("#<user-ptr ", printcharfun);
- int i = sprintf (buf, "ptr=%p finalizer=%p",
- XUSER_PTR (obj)->p,
- XUSER_PTR (obj)->finalizer);
- strout (buf, i, i, printcharfun);
- printchar ('>', printcharfun);
- break;
- }
-#endif
-
- case Lisp_Misc_Finalizer:
- print_c_string ("#<finalizer", printcharfun);
- if (NILP (XFINALIZER (obj)->function))
- print_c_string (" used", printcharfun);
- printchar ('>', printcharfun);
- break;
-
- /* Remaining cases shouldn't happen in normal usage, but let's
- print them anyway for the benefit of the debugger. */
-
- case Lisp_Misc_Free:
- print_c_string ("#<misc free cell>", printcharfun);
- break;
-
- case Lisp_Misc_Save_Value:
- {
- int i;
- struct Lisp_Save_Value *v = XSAVE_VALUE (obj);
-
- print_c_string ("#<save-value ", printcharfun);
-
- if (v->save_type == SAVE_TYPE_MEMORY)
- {
- ptrdiff_t amount = v->data[1].integer;
-
- /* valid_lisp_object_p is reliable, so try to print up
- to 8 saved objects. This code is rarely used, so
- it's OK that valid_lisp_object_p is slow. */
-
- int limit = min (amount, 8);
- Lisp_Object *area = v->data[0].pointer;
-
- i = sprintf (buf, "with %"pD"d objects", amount);
- strout (buf, i, i, printcharfun);
-
- for (i = 0; i < limit; i++)
- {
- Lisp_Object maybe = area[i];
- int valid = valid_lisp_object_p (maybe);
-
- printchar (' ', printcharfun);
- if (0 < valid)
- print_object (maybe, printcharfun, escapeflag);
- else
- print_c_string (valid < 0 ? "<some>" : "<invalid>",
- printcharfun);
- }
- if (i == limit && i < amount)
- print_c_string (" ...", printcharfun);
- }
- else
- {
- /* Print each slot according to its type. */
- int index;
- for (index = 0; index < SAVE_VALUE_SLOTS; index++)
- {
- if (index)
- printchar (' ', printcharfun);
-
- switch (save_type (v, index))
- {
- case SAVE_UNUSED:
- i = sprintf (buf, "<unused>");
- break;
-
- case SAVE_POINTER:
- i = sprintf (buf, "<pointer %p>",
- v->data[index].pointer);
- break;
-
- case SAVE_FUNCPOINTER:
- i = sprintf (buf, "<funcpointer %p>",
- ((void *) (intptr_t)
- v->data[index].funcpointer));
- break;
-
- case SAVE_INTEGER:
- i = sprintf (buf, "<integer %"pD"d>",
- v->data[index].integer);
- break;
-
- case SAVE_OBJECT:
- print_object (v->data[index].object, printcharfun,
- escapeflag);
- continue;
-
- default:
- emacs_abort ();
- }
-
- strout (buf, i, i, printcharfun);
- }
- }
- printchar ('>', printcharfun);
- }
- break;
-
- default:
- goto badtype;
- }
- break;
-
+ if (print_vectorlike (obj, printcharfun, escapeflag, buf))
+ break;
+ FALLTHROUGH;
default:
- badtype:
{
int len;
/* We're in trouble if this happens!
Probably should just emacs_abort (). */
print_c_string ("#<EMACS BUG: INVALID DATATYPE ", printcharfun);
- if (MISCP (obj))
- len = sprintf (buf, "(MISC 0x%04x)", (unsigned) XMISCTYPE (obj));
- else if (VECTORLIKEP (obj))
+ if (VECTORLIKEP (obj))
len = sprintf (buf, "(PVEC 0x%08zx)", (size_t) ASIZE (obj));
else
len = sprintf (buf, "(0x%02x)", (unsigned) XTYPE (obj));
@@ -2276,9 +2182,9 @@ print_interval (INTERVAL interval, Lisp_Object printcharfun)
if (NILP (interval->plist))
return;
printchar (' ', printcharfun);
- print_object (make_number (interval->position), printcharfun, 1);
+ print_object (make_fixnum (interval->position), printcharfun, 1);
printchar (' ', printcharfun);
- print_object (make_number (interval->position + LENGTH (interval)),
+ print_object (make_fixnum (interval->position + LENGTH (interval)),
printcharfun, 1);
printchar (' ', printcharfun);
print_object (interval->plist, printcharfun, 1);
@@ -2366,7 +2272,7 @@ This affects only `prin1'. */);
DEFVAR_BOOL ("print-quoted", print_quoted,
doc: /* Non-nil means print quoted forms with reader syntax.
I.e., (quote foo) prints as \\='foo, (function foo) as #\\='foo. */);
- print_quoted = 0;
+ print_quoted = true;
DEFVAR_LISP ("print-gensym", Vprint_gensym,
doc: /* Non-nil means print uninterned symbols so they will read as uninterned.
@@ -2411,7 +2317,7 @@ that need to be recorded in the table. */);
DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property,
doc: /* A flag to control printing of `charset' text property on printing a string.
-The value must be nil, t, or `default'.
+The value should be nil, t, or `default'.
If the value is nil, don't print the text property `charset'.
@@ -2419,7 +2325,8 @@ If the value is t, always print the text property `charset'.
If the value is `default', print the text property `charset' only when
the value is different from what is guessed in the current charset
-priorities. */);
+priorities. Values other than nil or t are also treated as
+`default'. */);
Vprint_charset_text_property = Qdefault;
/* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
@@ -2435,10 +2342,8 @@ priorities. */);
defsubr (&Sredirect_debugging_output);
defsubr (&Sprint_preprocess);
- DEFSYM (Qprint_escape_newlines, "print-escape-newlines");
DEFSYM (Qprint_escape_multibyte, "print-escape-multibyte");
DEFSYM (Qprint_escape_nonascii, "print-escape-nonascii");
- DEFSYM (Qprint_escape_control_characters, "print-escape-control-characters");
print_prune_charset_plist = Qnil;
staticpro (&print_prune_charset_plist);
diff --git a/src/process.c b/src/process.c
index 2df51cfd996..6770a5ed884 100644
--- a/src/process.c
+++ b/src/process.c
@@ -160,6 +160,18 @@ static bool kbd_is_on_hold;
when exiting. */
bool inhibit_sentinels;
+union u_sockaddr
+{
+ struct sockaddr sa;
+ struct sockaddr_in in;
+#ifdef AF_INET6
+ struct sockaddr_in6 in6;
+#endif
+#ifdef HAVE_LOCAL_SOCKETS
+ struct sockaddr_un un;
+#endif
+};
+
#ifdef subprocesses
#ifndef SOCK_CLOEXEC
@@ -240,7 +252,7 @@ static EMACS_INT update_tick;
# define HAVE_SEQPACKET
#endif
-#define READ_OUTPUT_DELAY_INCREMENT (TIMESPEC_RESOLUTION / 100)
+#define READ_OUTPUT_DELAY_INCREMENT (TIMESPEC_HZ / 100)
#define READ_OUTPUT_DELAY_MAX (READ_OUTPUT_DELAY_INCREMENT * 5)
#define READ_OUTPUT_DELAY_MAX_MAX (READ_OUTPUT_DELAY_INCREMENT * 7)
@@ -672,12 +684,12 @@ static Lisp_Object
status_convert (int w)
{
if (WIFSTOPPED (w))
- return Fcons (Qstop, Fcons (make_number (WSTOPSIG (w)), Qnil));
+ return Fcons (Qstop, Fcons (make_fixnum (WSTOPSIG (w)), Qnil));
else if (WIFEXITED (w))
- return Fcons (Qexit, Fcons (make_number (WEXITSTATUS (w)),
+ return Fcons (Qexit, Fcons (make_fixnum (WEXITSTATUS (w)),
WCOREDUMP (w) ? Qt : Qnil));
else if (WIFSIGNALED (w))
- return Fcons (Qsignal, Fcons (make_number (WTERMSIG (w)),
+ return Fcons (Qsignal, Fcons (make_fixnum (WTERMSIG (w)),
WCOREDUMP (w) ? Qt : Qnil));
else
return Qrun;
@@ -706,7 +718,7 @@ decode_status (Lisp_Object l, Lisp_Object *symbol, Lisp_Object *code,
if (SYMBOLP (l))
{
*symbol = l;
- *code = make_number (0);
+ *code = make_fixnum (0);
*coredump = 0;
}
else
@@ -735,7 +747,7 @@ status_message (struct Lisp_Process *p)
{
char const *signame;
synchronize_system_messages_locale ();
- signame = strsignal (XFASTINT (code));
+ signame = strsignal (XFIXNAT (code));
if (signame == 0)
string = build_string ("unknown");
else
@@ -749,7 +761,7 @@ status_message (struct Lisp_Process *p)
c1 = STRING_CHAR (SDATA (string));
c2 = downcase (c1);
if (c1 != c2)
- Faset (string, make_number (0), make_number (c2));
+ Faset (string, make_fixnum (0), make_fixnum (c2));
}
AUTO_STRING (suffix, coredump ? " (core dumped)\n" : "\n");
return concat2 (string, suffix);
@@ -757,10 +769,10 @@ status_message (struct Lisp_Process *p)
else if (EQ (symbol, Qexit))
{
if (NETCONN1_P (p))
- return build_string (XFASTINT (code) == 0
+ return build_string (XFIXNAT (code) == 0
? "deleted\n"
: "connection broken by remote peer\n");
- if (XFASTINT (code) == 0)
+ if (XFIXNAT (code) == 0)
return build_string ("finished\n");
AUTO_STRING (prefix, "exited abnormally with code ");
string = Fnumber_to_string (code);
@@ -846,7 +858,8 @@ allocate_pty (char pty_name[PTY_NAME_SIZE])
static struct Lisp_Process *
allocate_process (void)
{
- return ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Process, pid, PVEC_PROCESS);
+ return ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Process, thread,
+ PVEC_PROCESS);
}
static Lisp_Object
@@ -1013,7 +1026,7 @@ static Lisp_Object deleted_pid_list;
void
record_deleted_pid (pid_t pid, Lisp_Object filename)
{
- deleted_pid_list = Fcons (Fcons (make_fixnum_or_float (pid), filename),
+ deleted_pid_list = Fcons (Fcons (INT_TO_INTEGER (pid), filename),
/* GC treated elements set to nil. */
Fdelq (Qnil, deleted_pid_list));
@@ -1052,7 +1065,7 @@ nil, indicating the current buffer's process. */)
p->raw_status_new = 0;
if (NETCONN1_P (p) || SERIALCONN1_P (p) || PIPECONN1_P (p))
{
- pset_status (p, list2 (Qexit, make_number (0)));
+ pset_status (p, list2 (Qexit, make_fixnum (0)));
p->tick = ++process_tick;
status_notify (p, NULL);
redisplay_preserve_echo_area (13);
@@ -1071,7 +1084,7 @@ nil, indicating the current buffer's process. */)
update_status (p);
symbol = CONSP (p->status) ? XCAR (p->status) : p->status;
if (! (EQ (symbol, Qsignal) || EQ (symbol, Qexit)))
- pset_status (p, list2 (Qsignal, make_number (SIGKILL)));
+ pset_status (p, list2 (Qsignal, make_fixnum (SIGKILL)));
p->tick = ++process_tick;
status_notify (p, NULL);
@@ -1139,12 +1152,13 @@ If PROCESS has not yet exited or died, return 0. */)
update_status (XPROCESS (process));
if (CONSP (XPROCESS (process)->status))
return XCAR (XCDR (XPROCESS (process)->status));
- return make_number (0);
+ return make_fixnum (0);
}
DEFUN ("process-id", Fprocess_id, Sprocess_id, 1, 1, 0,
doc: /* Return the process id of PROCESS.
This is the pid of the external process which PROCESS uses or talks to.
+It is a fixnum if the value is small enough, otherwise a bignum.
For a network, serial, and pipe connections, this value is nil. */)
(register Lisp_Object process)
{
@@ -1152,7 +1166,7 @@ For a network, serial, and pipe connections, this value is nil. */)
CHECK_PROCESS (process);
pid = XPROCESS (process)->pid;
- return (pid ? make_fixnum_or_float (pid) : Qnil);
+ return pid ? INT_TO_INTEGER (pid) : Qnil;
}
DEFUN ("process-name", Fprocess_name, Sprocess_name, 1, 1, 0,
@@ -1248,10 +1262,7 @@ passed to the filter.
The filter gets two arguments: the process and the string of output.
The string argument is normally a multibyte string, except:
- if the process's input coding system is no-conversion or raw-text,
- it is a unibyte string (the non-converted input), or else
-- if `default-enable-multibyte-characters' is nil, it is a unibyte
- string (the result of converting the decoded input multibyte
- string to unibyte with `string-make-unibyte'). */)
+ it is a unibyte string (the non-converted input). */)
(Lisp_Object process, Lisp_Object filter)
{
CHECK_PROCESS (process);
@@ -1374,7 +1385,7 @@ nil otherwise. */)
if (NETCONN_P (process)
|| XPROCESS (process)->infd < 0
|| (set_window_size (XPROCESS (process)->infd,
- XINT (height), XINT (width))
+ XFIXNUM (height), XFIXNUM (width))
< 0))
return Qnil;
else
@@ -1575,12 +1586,12 @@ Return nil if format of ADDRESS is invalid. */)
for (i = 0; i < nargs; i++)
{
- if (! RANGED_INTEGERP (0, p->contents[i], 65535))
+ if (! RANGED_FIXNUMP (0, p->contents[i], 65535))
return Qnil;
if (nargs <= 5 /* IPv4 */
&& i < 4 /* host, not port */
- && XINT (p->contents[i]) > 255)
+ && XFIXNUM (p->contents[i]) > 255)
return Qnil;
args[i + 1] = p->contents[i];
@@ -1648,7 +1659,13 @@ to use a pty, or nil to use the default specified through
:stderr STDERR -- STDERR is either a buffer or a pipe process attached
to the standard error of subprocess. Specifying this implies
-`:connection-type' is set to `pipe'.
+`:connection-type' is set to `pipe'. If STDERR is nil, standard error
+is mixed with standard output and sent to BUFFER or FILTER.
+
+:file-handler FILE-HANDLER -- If FILE-HANDLER is non-nil, then look
+for a file name handler for the current buffer's `default-directory'
+and invoke that file name handler to make the process. If there is no
+such handler, proceed as if FILE-HANDLER were nil.
usage: (make-process &rest ARGS) */)
(ptrdiff_t nargs, Lisp_Object *args)
@@ -1663,6 +1680,15 @@ usage: (make-process &rest ARGS) */)
/* Save arguments for process-contact and clone-process. */
contact = Flist (nargs, args);
+ if (!NILP (Fplist_get (contact, QCfile_handler)))
+ {
+ Lisp_Object file_handler
+ = Ffind_file_name_handler (BVAR (current_buffer, directory),
+ Qmake_process);
+ if (!NILP (file_handler))
+ return CALLN (Fapply, file_handler, Qmake_process, contact);
+ }
+
buffer = Fplist_get (contact, QCbuffer);
if (!NILP (buffer))
buffer = Fget_buffer_create (buffer);
@@ -1779,7 +1805,7 @@ usage: (make-process &rest ARGS) */)
val = Vcoding_system_for_read;
if (NILP (val))
{
- ptrdiff_t nargs2 = 3 + XINT (Flength (command));
+ ptrdiff_t nargs2 = 3 + list_length (command);
Lisp_Object tem2;
SAFE_ALLOCA_LISP (args2, nargs2);
ptrdiff_t i = 0;
@@ -1809,7 +1835,7 @@ usage: (make-process &rest ARGS) */)
{
if (EQ (coding_systems, Qt))
{
- ptrdiff_t nargs2 = 3 + XINT (Flength (command));
+ ptrdiff_t nargs2 = 3 + list_length (command);
Lisp_Object tem2;
SAFE_ALLOCA_LISP (args2, nargs2);
ptrdiff_t i = 0;
@@ -1854,7 +1880,7 @@ usage: (make-process &rest ARGS) */)
{
tem = Qnil;
openp (Vexec_path, program, Vexec_suffixes, &tem,
- make_number (X_OK), false);
+ make_fixnum (X_OK), false);
if (NILP (tem))
report_file_error ("Searching for program", program);
tem = Fexpand_file_name (tem, Qnil);
@@ -1913,8 +1939,7 @@ usage: (make-process &rest ARGS) */)
else
create_pty (proc);
- SAFE_FREE ();
- return unbind_to (count, proc);
+ return SAFE_FREE_UNBIND_TO (count, proc);
}
/* If PROC doesn't have its pid set, then an error was signaled and
@@ -1939,6 +1964,26 @@ close_process_fd (int *fd_addr)
}
}
+void
+dissociate_controlling_tty (void)
+{
+ if (setsid () < 0)
+ {
+#ifdef TIOCNOTTY
+ /* Needed on Darwin after vfork, since setsid fails in a vforked
+ child that has not execed.
+ I wonder: would just ioctl (fd, TIOCNOTTY, 0) work here, for
+ some fd that the caller already has? */
+ int ttyfd = emacs_open (DEV_TTY, O_RDWR, 0);
+ if (0 <= ttyfd)
+ {
+ ioctl (ttyfd, TIOCNOTTY, 0);
+ emacs_close (ttyfd);
+ }
+#endif
+ }
+}
+
/* Indexes of file descriptors in open_fds. */
enum
{
@@ -2087,9 +2132,8 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir)
{
/* Make the pty be the controlling terminal of the process. */
#ifdef HAVE_PTYS
- /* First, disconnect its current controlling terminal.
- Do this even if !PTY_FLAG; see Bug#30762. */
- setsid ();
+ dissociate_controlling_tty ();
+
/* Make the pty's terminal the controlling terminal. */
if (pty_flag && forkin >= 0)
{
@@ -2118,21 +2162,6 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir)
}
#endif
#endif
-#ifdef TIOCNOTTY
- /* In 4.3BSD, the TIOCSPGRP bug has been fixed, and now you
- can do TIOCSPGRP only to the process's controlling tty. */
- if (pty_flag)
- {
- /* I wonder: would just ioctl (0, TIOCNOTTY, 0) work here?
- I can't test it since I don't have 4.3. */
- int j = emacs_open (DEV_TTY, O_RDWR, 0);
- if (j >= 0)
- {
- ioctl (j, TIOCNOTTY, 0);
- emacs_close (j);
- }
- }
-#endif /* TIOCNOTTY */
#if !defined (DONT_REOPEN_PTY)
/*** There is a suggestion that this ought to be a
@@ -2478,7 +2507,6 @@ Lisp_Object
conv_sockaddr_to_lisp (struct sockaddr *sa, ptrdiff_t len)
{
Lisp_Object address;
- ptrdiff_t i;
unsigned char *cp;
struct Lisp_Vector *p;
@@ -2494,9 +2522,9 @@ conv_sockaddr_to_lisp (struct sockaddr *sa, ptrdiff_t len)
{
DECLARE_POINTER_ALIAS (sin, struct sockaddr_in, sa);
len = sizeof (sin->sin_addr) + 1;
- address = Fmake_vector (make_number (len), Qnil);
+ address = make_uninit_vector (len);
p = XVECTOR (address);
- p->contents[--len] = make_number (ntohs (sin->sin_port));
+ p->contents[--len] = make_fixnum (ntohs (sin->sin_port));
cp = (unsigned char *) &sin->sin_addr;
break;
}
@@ -2506,11 +2534,11 @@ conv_sockaddr_to_lisp (struct sockaddr *sa, ptrdiff_t len)
DECLARE_POINTER_ALIAS (sin6, struct sockaddr_in6, sa);
DECLARE_POINTER_ALIAS (ip6, uint16_t, &sin6->sin6_addr);
len = sizeof (sin6->sin6_addr) / 2 + 1;
- address = Fmake_vector (make_number (len), Qnil);
+ address = make_uninit_vector (len);
p = XVECTOR (address);
- p->contents[--len] = make_number (ntohs (sin6->sin6_port));
- for (i = 0; i < len; i++)
- p->contents[i] = make_number (ntohs (ip6[i]));
+ p->contents[--len] = make_fixnum (ntohs (sin6->sin6_port));
+ for (ptrdiff_t i = 0; i < len; i++)
+ p->contents[i] = make_fixnum (ntohs (ip6[i]));
return address;
}
#endif
@@ -2538,16 +2566,14 @@ conv_sockaddr_to_lisp (struct sockaddr *sa, ptrdiff_t len)
#endif
default:
len -= offsetof (struct sockaddr, sa_family) + sizeof (sa->sa_family);
- address = Fcons (make_number (sa->sa_family),
- Fmake_vector (make_number (len), Qnil));
+ address = Fcons (make_fixnum (sa->sa_family), make_nil_vector (len));
p = XVECTOR (XCDR (address));
cp = (unsigned char *) &sa->sa_family + sizeof (sa->sa_family);
break;
}
- i = 0;
- while (i < len)
- p->contents[i++] = make_number (*cp++);
+ for (ptrdiff_t i = 0; i < len; i++)
+ p->contents[i] = make_fixnum (*cp++);
return address;
}
@@ -2557,8 +2583,8 @@ conv_sockaddr_to_lisp (struct sockaddr *sa, ptrdiff_t len)
static Lisp_Object
conv_addrinfo_to_lisp (struct addrinfo *res)
{
- Lisp_Object protocol = make_number (res->ai_protocol);
- eassert (XINT (protocol) == res->ai_protocol);
+ Lisp_Object protocol = make_fixnum (res->ai_protocol);
+ eassert (XFIXNUM (protocol) == res->ai_protocol);
return Fcons (protocol, conv_sockaddr_to_lisp (res->ai_addr, res->ai_addrlen));
}
@@ -2593,14 +2619,14 @@ get_lisp_to_sockaddr_size (Lisp_Object address, int *familyp)
return sizeof (struct sockaddr_un);
}
#endif
- else if (CONSP (address) && TYPE_RANGED_INTEGERP (int, XCAR (address))
+ else if (CONSP (address) && TYPE_RANGED_FIXNUMP (int, XCAR (address))
&& VECTORP (XCDR (address)))
{
struct sockaddr *sa;
p = XVECTOR (XCDR (address));
if (MAX_ALLOCA - sizeof sa->sa_family < p->header.size)
return 0;
- *familyp = XINT (XCAR (address));
+ *familyp = XFIXNUM (XCAR (address));
return p->header.size + sizeof (sa->sa_family);
}
return 0;
@@ -2630,7 +2656,7 @@ conv_lisp_to_sockaddr (int family, Lisp_Object address, struct sockaddr *sa, int
{
DECLARE_POINTER_ALIAS (sin, struct sockaddr_in, sa);
len = sizeof (sin->sin_addr) + 1;
- hostport = XINT (p->contents[--len]);
+ hostport = XFIXNUM (p->contents[--len]);
sin->sin_port = htons (hostport);
cp = (unsigned char *)&sin->sin_addr;
sa->sa_family = family;
@@ -2641,12 +2667,12 @@ conv_lisp_to_sockaddr (int family, Lisp_Object address, struct sockaddr *sa, int
DECLARE_POINTER_ALIAS (sin6, struct sockaddr_in6, sa);
DECLARE_POINTER_ALIAS (ip6, uint16_t, &sin6->sin6_addr);
len = sizeof (sin6->sin6_addr) / 2 + 1;
- hostport = XINT (p->contents[--len]);
+ hostport = XFIXNUM (p->contents[--len]);
sin6->sin6_port = htons (hostport);
for (i = 0; i < len; i++)
- if (INTEGERP (p->contents[i]))
+ if (FIXNUMP (p->contents[i]))
{
- int j = XFASTINT (p->contents[i]) & 0xffff;
+ int j = XFIXNAT (p->contents[i]) & 0xffff;
ip6[i] = ntohs (j);
}
sa->sa_family = family;
@@ -2677,8 +2703,8 @@ conv_lisp_to_sockaddr (int family, Lisp_Object address, struct sockaddr *sa, int
}
for (i = 0; i < len; i++)
- if (INTEGERP (p->contents[i]))
- *cp++ = XFASTINT (p->contents[i]) & 0xff;
+ if (FIXNUMP (p->contents[i]))
+ *cp++ = XFIXNAT (p->contents[i]) & 0xff;
}
#ifdef DATAGRAM_SOCKETS
@@ -2809,8 +2835,8 @@ set_socket_option (int s, Lisp_Object opt, Lisp_Object val)
case SOPT_INT:
{
int optval;
- if (TYPE_RANGED_INTEGERP (int, val))
- optval = XINT (val);
+ if (TYPE_RANGED_FIXNUMP (int, val))
+ optval = XFIXNUM (val);
else
error ("Bad option value for %s", name);
ret = setsockopt (s, sopt->optlevel, sopt->optnum,
@@ -2848,8 +2874,8 @@ set_socket_option (int s, Lisp_Object opt, Lisp_Object val)
linger.l_onoff = 1;
linger.l_linger = 0;
- if (TYPE_RANGED_INTEGERP (int, val))
- linger.l_linger = XINT (val);
+ if (TYPE_RANGED_FIXNUMP (int, val))
+ linger.l_linger = XFIXNUM (val);
else
linger.l_onoff = NILP (val) ? 0 : 1;
ret = setsockopt (s, sopt->optlevel, sopt->optnum,
@@ -3093,7 +3119,7 @@ usage: (make-serial-process &rest ARGS) */)
if (NILP (Fplist_member (contact, QCspeed)))
error (":speed not specified");
if (!NILP (Fplist_get (contact, QCspeed)))
- CHECK_NUMBER (Fplist_get (contact, QCspeed));
+ CHECK_FIXNUM (Fplist_get (contact, QCspeed));
name = Fplist_get (contact, QCname);
if (NILP (name))
@@ -3325,7 +3351,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos,
int xerrno = 0;
int family;
int ret;
- ptrdiff_t addrlen;
+ ptrdiff_t addrlen UNINIT;
struct Lisp_Process *p = XPROCESS (proc);
Lisp_Object contact = p->childp;
int optbits = 0;
@@ -3351,7 +3377,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos,
{
Lisp_Object addrinfo = XCAR (addrinfos);
addrinfos = XCDR (addrinfos);
- int protocol = XINT (XCAR (addrinfo));
+ int protocol = XFIXNUM (XCAR (addrinfo));
Lisp_Object ip_address = XCDR (addrinfo);
#ifdef WINDOWSNT
@@ -3457,7 +3483,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos,
DECLARE_POINTER_ALIAS (psa1, struct sockaddr, &sa1);
if (getsockname (s, psa1, &len1) == 0)
{
- Lisp_Object service = make_number (ntohs (sa1.sin_port));
+ Lisp_Object service = make_fixnum (ntohs (sa1.sin_port));
contact = Fplist_put (contact, QCservice, service);
/* Save the port number so that we can stash it in
the process object later. */
@@ -3708,6 +3734,8 @@ also nil, meaning that this process is not associated with any buffer.
address. The symbol `local' specifies the local host. If specified
for a server process, it must be a valid name or address for the local
host, and only clients connecting to that address will be accepted.
+`local' will use IPv4 by default, use a FAMILY of 'ipv6 to override
+this.
:service SERVICE -- SERVICE is name of the service desired, or an
integer specifying a port number to connect to. If SERVICE is t,
@@ -3773,8 +3801,7 @@ The stopped state is cleared by `continue-process' and set by
:filter-multibyte BOOL -- If BOOL is non-nil, strings given to the
process filter are multibyte, otherwise they are unibyte.
-If this keyword is not specified, the strings are multibyte if
-the default value of `enable-multibyte-characters' is non-nil.
+If this keyword is not specified, the strings are multibyte.
:sentinel SENTINEL -- Install SENTINEL as the process sentinel.
@@ -3851,7 +3878,6 @@ usage: (make-network-process &rest ARGS) */)
Lisp_Object contact;
struct Lisp_Process *p;
const char *portstring UNINIT;
- ptrdiff_t portstringlen ATTRIBUTE_UNUSED;
char portbuf[INT_BUFSIZE_BOUND (EMACS_INT)];
#ifdef HAVE_LOCAL_SOCKETS
struct sockaddr_un address_un;
@@ -3919,7 +3945,7 @@ usage: (make-network-process &rest ARGS) */)
if (!get_lisp_to_sockaddr_size (address, &family))
error ("Malformed :address");
- addrinfos = list1 (Fcons (make_number (any_protocol), address));
+ addrinfos = list1 (Fcons (make_fixnum (any_protocol), address));
goto open_socket;
}
@@ -3943,8 +3969,8 @@ usage: (make-network-process &rest ARGS) */)
#endif
else if (EQ (tem, Qipv4))
family = AF_INET;
- else if (TYPE_RANGED_INTEGERP (int, tem))
- family = XINT (tem);
+ else if (TYPE_RANGED_FIXNUMP (int, tem))
+ family = XFIXNUM (tem);
else
error ("Unknown address family");
@@ -3960,14 +3986,24 @@ usage: (make-network-process &rest ARGS) */)
#ifdef HAVE_LOCAL_SOCKETS
if (family != AF_LOCAL)
#endif
- host = build_string ("127.0.0.1");
+ {
+ if (family == AF_INET6)
+ host = build_string ("::1");
+ else
+ host = build_string ("127.0.0.1");
+ }
}
else
{
if (EQ (host, Qlocal))
+ {
/* Depending on setup, "localhost" may map to different IPv4 and/or
IPv6 addresses, so it's better to be explicit (Bug#6781). */
- host = build_string ("127.0.0.1");
+ if (family == AF_INET6)
+ host = build_string ("::1");
+ else
+ host = build_string ("127.0.0.1");
+ }
CHECK_STRING (host);
}
@@ -3983,7 +4019,7 @@ usage: (make-network-process &rest ARGS) */)
CHECK_STRING (service);
if (sizeof address_un.sun_path <= SBYTES (service))
error ("Service name too long");
- addrinfos = list1 (Fcons (make_number (any_protocol), service));
+ addrinfos = list1 (Fcons (make_fixnum (any_protocol), service));
goto open_socket;
}
#endif
@@ -4001,6 +4037,8 @@ usage: (make-network-process &rest ARGS) */)
if (!NILP (host))
{
+ ptrdiff_t portstringlen ATTRIBUTE_UNUSED;
+
/* SERVICE can either be a string or int.
Convert to a C string for later use by getaddrinfo. */
if (EQ (service, Qt))
@@ -4008,10 +4046,10 @@ usage: (make-network-process &rest ARGS) */)
portstring = "0";
portstringlen = 1;
}
- else if (INTEGERP (service))
+ else if (FIXNUMP (service))
{
portstring = portbuf;
- portstringlen = sprintf (portbuf, "%"pI"d", XINT (service));
+ portstringlen = sprintf (portbuf, "%"pI"d", XFIXNUM (service));
}
else
{
@@ -4019,37 +4057,38 @@ usage: (make-network-process &rest ARGS) */)
portstring = SSDATA (service);
portstringlen = SBYTES (service);
}
- }
#ifdef HAVE_GETADDRINFO_A
- if (!NILP (host) && nowait)
- {
- ptrdiff_t hostlen = SBYTES (host);
- struct req
- {
- struct gaicb gaicb;
- struct addrinfo hints;
- char str[FLEXIBLE_ARRAY_MEMBER];
- } *req = xmalloc (FLEXSIZEOF (struct req, str,
- hostlen + 1 + portstringlen + 1));
- dns_request = &req->gaicb;
- dns_request->ar_name = req->str;
- dns_request->ar_service = req->str + hostlen + 1;
- dns_request->ar_request = &req->hints;
- dns_request->ar_result = NULL;
- memset (&req->hints, 0, sizeof req->hints);
- req->hints.ai_family = family;
- req->hints.ai_socktype = socktype;
- strcpy (req->str, SSDATA (host));
- strcpy (req->str + hostlen + 1, portstring);
-
- int ret = getaddrinfo_a (GAI_NOWAIT, &dns_request, 1, NULL);
- if (ret)
- error ("%s/%s getaddrinfo_a error %d", SSDATA (host), portstring, ret);
-
- goto open_socket;
- }
+ if (nowait)
+ {
+ ptrdiff_t hostlen = SBYTES (host);
+ struct req
+ {
+ struct gaicb gaicb;
+ struct addrinfo hints;
+ char str[FLEXIBLE_ARRAY_MEMBER];
+ } *req = xmalloc (FLEXSIZEOF (struct req, str,
+ hostlen + 1 + portstringlen + 1));
+ dns_request = &req->gaicb;
+ dns_request->ar_name = req->str;
+ dns_request->ar_service = req->str + hostlen + 1;
+ dns_request->ar_request = &req->hints;
+ dns_request->ar_result = NULL;
+ memset (&req->hints, 0, sizeof req->hints);
+ req->hints.ai_family = family;
+ req->hints.ai_socktype = socktype;
+ strcpy (req->str, SSDATA (host));
+ strcpy (req->str + hostlen + 1, portstring);
+
+ int ret = getaddrinfo_a (GAI_NOWAIT, &dns_request, 1, NULL);
+ if (ret)
+ error ("%s/%s getaddrinfo_a error %d",
+ SSDATA (host), portstring, ret);
+
+ goto open_socket;
+ }
#endif /* HAVE_GETADDRINFO_A */
+ }
/* If we have a host, use getaddrinfo to resolve both host and service.
Otherwise, use getservbyname to lookup the service. */
@@ -4095,8 +4134,8 @@ usage: (make-network-process &rest ARGS) */)
if (EQ (service, Qt))
port = 0;
- else if (INTEGERP (service))
- port = XINT (service);
+ else if (FIXNUMP (service))
+ port = XFIXNUM (service);
else
{
CHECK_STRING (service);
@@ -4169,8 +4208,8 @@ usage: (make-network-process &rest ARGS) */)
/* :server QLEN */
p->is_server = !NILP (server);
- if (TYPE_RANGED_INTEGERP (int, server))
- p->backlog = XINT (server);
+ if (TYPE_RANGED_FIXNUMP (int, server))
+ p->backlog = XFIXNUM (server);
/* :nowait BOOL */
if (!p->is_server && socktype != SOCK_DGRAM && nowait)
@@ -4348,7 +4387,7 @@ network_interface_info (Lisp_Object ifname)
Lisp_Object res = Qnil;
Lisp_Object elt;
int s;
- bool any = 0;
+ bool any = false;
ptrdiff_t count;
#if (! (defined SIOCGIFHWADDR && defined HAVE_STRUCT_IFREQ_IFR_HWADDR) \
&& defined HAVE_GETIFADDRS && defined LLADDR)
@@ -4381,7 +4420,7 @@ network_interface_info (Lisp_Object ifname)
if (flags < 0 && sizeof (rq.ifr_flags) < sizeof (flags))
flags = (unsigned short) rq.ifr_flags;
- any = 1;
+ any = true;
for (fp = ifflag_table; flags != 0 && fp->flag_sym; fp++)
{
if (flags & fp->flag_bit)
@@ -4394,7 +4433,7 @@ network_interface_info (Lisp_Object ifname)
{
if (flags & 1)
{
- elt = Fcons (make_number (fnum), elt);
+ elt = Fcons (make_fixnum (fnum), elt);
}
}
}
@@ -4405,25 +4444,23 @@ network_interface_info (Lisp_Object ifname)
#if defined (SIOCGIFHWADDR) && defined (HAVE_STRUCT_IFREQ_IFR_HWADDR)
if (ioctl (s, SIOCGIFHWADDR, &rq) == 0)
{
- Lisp_Object hwaddr = Fmake_vector (make_number (6), Qnil);
- register struct Lisp_Vector *p = XVECTOR (hwaddr);
- int n;
+ Lisp_Object hwaddr = make_uninit_vector (6);
+ struct Lisp_Vector *p = XVECTOR (hwaddr);
- any = 1;
- for (n = 0; n < 6; n++)
- p->contents[n] = make_number (((unsigned char *)
+ any = true;
+ for (int n = 0; n < 6; n++)
+ p->contents[n] = make_fixnum (((unsigned char *)
&rq.ifr_hwaddr.sa_data[0])
[n]);
- elt = Fcons (make_number (rq.ifr_hwaddr.sa_family), hwaddr);
+ elt = Fcons (make_fixnum (rq.ifr_hwaddr.sa_family), hwaddr);
}
#elif defined (HAVE_GETIFADDRS) && defined (LLADDR)
if (getifaddrs (&ifap) != -1)
{
- Lisp_Object hwaddr = Fmake_vector (make_number (6), Qnil);
- register struct Lisp_Vector *p = XVECTOR (hwaddr);
- struct ifaddrs *it;
+ Lisp_Object hwaddr = make_nil_vector (6);
+ struct Lisp_Vector *p = XVECTOR (hwaddr);
- for (it = ifap; it != NULL; it = it->ifa_next)
+ for (struct ifaddrs *it = ifap; it != NULL; it = it->ifa_next)
{
DECLARE_POINTER_ALIAS (sdl, struct sockaddr_dl, it->ifa_addr);
unsigned char linkaddr[6];
@@ -4436,9 +4473,9 @@ network_interface_info (Lisp_Object ifname)
memcpy (linkaddr, LLADDR (sdl), sdl->sdl_alen);
for (n = 0; n < 6; n++)
- p->contents[n] = make_number (linkaddr[n]);
+ p->contents[n] = make_fixnum (linkaddr[n]);
- elt = Fcons (make_number (it->ifa_addr->sa_family), hwaddr);
+ elt = Fcons (make_fixnum (it->ifa_addr->sa_family), hwaddr);
break;
}
}
@@ -4451,10 +4488,12 @@ network_interface_info (Lisp_Object ifname)
res = Fcons (elt, res);
elt = Qnil;
-#if defined (SIOCGIFNETMASK) && (defined (HAVE_STRUCT_IFREQ_IFR_NETMASK) || defined (HAVE_STRUCT_IFREQ_IFR_ADDR))
+#if (defined SIOCGIFNETMASK \
+ && (defined HAVE_STRUCT_IFREQ_IFR_NETMASK \
+ || defined HAVE_STRUCT_IFREQ_IFR_ADDR))
if (ioctl (s, SIOCGIFNETMASK, &rq) == 0)
{
- any = 1;
+ any = true;
#ifdef HAVE_STRUCT_IFREQ_IFR_NETMASK
elt = conv_sockaddr_to_lisp (&rq.ifr_netmask, sizeof (rq.ifr_netmask));
#else
@@ -4468,8 +4507,8 @@ network_interface_info (Lisp_Object ifname)
#if defined (SIOCGIFBRDADDR) && defined (HAVE_STRUCT_IFREQ_IFR_BROADADDR)
if (ioctl (s, SIOCGIFBRDADDR, &rq) == 0)
{
- any = 1;
- elt = conv_sockaddr_to_lisp (&rq.ifr_broadaddr, sizeof (rq.ifr_broadaddr));
+ any = true;
+ elt = conv_sockaddr_to_lisp (&rq.ifr_broadaddr, sizeof rq.ifr_broadaddr);
}
#endif
res = Fcons (elt, res);
@@ -4478,7 +4517,7 @@ network_interface_info (Lisp_Object ifname)
#if defined (SIOCGIFADDR) && defined (HAVE_STRUCT_IFREQ_IFR_ADDR)
if (ioctl (s, SIOCGIFADDR, &rq) == 0)
{
- any = 1;
+ any = true;
elt = conv_sockaddr_to_lisp (&rq.ifr_addr, sizeof (rq.ifr_addr));
}
#endif
@@ -4609,7 +4648,7 @@ corresponding connection was closed. */)
/* Can't wait for a process that is dedicated to a different
thread. */
- if (!EQ (proc->thread, Qnil) && !EQ (proc->thread, Fcurrent_thread ()))
+ if (!NILP (proc->thread) && !EQ (proc->thread, Fcurrent_thread ()))
{
Lisp_Object proc_thread_name = XTHREAD (proc->thread)->name;
@@ -4625,13 +4664,13 @@ corresponding connection was closed. */)
if (!NILP (millisec))
{ /* Obsolete calling convention using integers rather than floats. */
- CHECK_NUMBER (millisec);
+ CHECK_FIXNUM (millisec);
if (NILP (seconds))
- seconds = make_float (XINT (millisec) / 1000.0);
+ seconds = make_float (XFIXNUM (millisec) / 1000.0);
else
{
- CHECK_NUMBER (seconds);
- seconds = make_float (XINT (millisec) / 1000.0 + XINT (seconds));
+ CHECK_FIXNUM (seconds);
+ seconds = make_float (XFIXNUM (millisec) / 1000.0 + XFIXNUM (seconds));
}
}
@@ -4640,11 +4679,11 @@ corresponding connection was closed. */)
if (!NILP (seconds))
{
- if (INTEGERP (seconds))
+ if (FIXNUMP (seconds))
{
- if (XINT (seconds) > 0)
+ if (XFIXNUM (seconds) > 0)
{
- secs = XINT (seconds);
+ secs = XFIXNUM (seconds);
nsecs = 0;
}
}
@@ -4668,7 +4707,7 @@ corresponding connection was closed. */)
Qnil,
!NILP (process) ? XPROCESS (process) : NULL,
(NILP (just_this_one) ? 0
- : !INTEGERP (just_this_one) ? 1 : -1))
+ : !FIXNUMP (just_this_one) ? 1 : -1))
<= 0)
? Qnil : Qt);
}
@@ -4685,16 +4724,7 @@ server_accept_connection (Lisp_Object server, int channel)
struct Lisp_Process *ps = XPROCESS (server);
struct Lisp_Process *p;
int s;
- union u_sockaddr {
- struct sockaddr sa;
- struct sockaddr_in in;
-#ifdef AF_INET6
- struct sockaddr_in6 in6;
-#endif
-#ifdef HAVE_LOCAL_SOCKETS
- struct sockaddr_un un;
-#endif
- } saddr;
+ union u_sockaddr saddr;
socklen_t len = sizeof saddr;
ptrdiff_t count;
@@ -4706,7 +4736,7 @@ server_accept_connection (Lisp_Object server, int channel)
if (!would_block (code) && !NILP (ps->log))
call3 (ps->log, server, Qnil,
concat3 (build_string ("accept failed with code"),
- Fnumber_to_string (make_number (code)),
+ Fnumber_to_string (make_fixnum (code)),
build_string ("\n")));
return;
}
@@ -4738,9 +4768,9 @@ server_accept_connection (Lisp_Object server, int channel)
args[nargs++] = procname_format_in;
args[nargs++] = host_format_in;
unsigned char *ip = (unsigned char *)&saddr.in.sin_addr.s_addr;
- service = make_number (ntohs (saddr.in.sin_port));
+ service = make_fixnum (ntohs (saddr.in.sin_port));
for (int i = 0; i < 4; i++)
- args[nargs++] = make_number (ip[i]);
+ args[nargs++] = make_fixnum (ip[i]);
host = Fformat (5, args + 1);
args[nargs++] = service;
}
@@ -4752,9 +4782,9 @@ server_accept_connection (Lisp_Object server, int channel)
args[nargs++] = procname_format_in6;
args[nargs++] = host_format_in6;
DECLARE_POINTER_ALIAS (ip6, uint16_t, &saddr.in6.sin6_addr);
- service = make_number (ntohs (saddr.in.sin_port));
+ service = make_fixnum (ntohs (saddr.in.sin_port));
for (int i = 0; i < 8; i++)
- args[nargs++] = make_number (ip6[i]);
+ args[nargs++] = make_fixnum (ip6[i]);
host = Fformat (9, args + 1);
args[nargs++] = service;
}
@@ -4764,7 +4794,7 @@ server_accept_connection (Lisp_Object server, int channel)
default:
args[nargs++] = procname_format_default;
nargs++;
- args[nargs++] = make_number (connect_counter);
+ args[nargs++] = make_fixnum (connect_counter);
break;
}
@@ -5019,7 +5049,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
Lisp_Object proc;
struct timespec timeout, end_time, timer_delay;
struct timespec got_output_end_time = invalid_timespec ();
- enum { MINIMUM = -1, TIMEOUT, INFINITY } wait;
+ enum { MINIMUM = -1, TIMEOUT, FOREVER } wait;
int got_some_output = -1;
uintmax_t prev_wait_proc_nbytes_read = wait_proc ? wait_proc->nbytes_read : 0;
#if defined HAVE_GETADDRINFO_A || defined HAVE_GNUTLS
@@ -5031,7 +5061,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
struct timespec now = invalid_timespec ();
eassert (wait_proc == NULL
- || EQ (wait_proc->thread, Qnil)
+ || NILP (wait_proc->thread)
|| XTHREAD (wait_proc->thread) == current_thread);
FD_ZERO (&Available);
@@ -5058,7 +5088,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
end_time = timespec_add (now, make_timespec (time_limit, nsecs));
}
else
- wait = INFINITY;
+ wait = FOREVER;
while (1)
{
@@ -5483,7 +5513,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
have waited a long amount of time due to repeated
timers. */
struct timespec huge_timespec
- = make_timespec (TYPE_MAXIMUM (time_t), 2 * TIMESPEC_RESOLUTION);
+ = make_timespec (TYPE_MAXIMUM (time_t), 2 * TIMESPEC_HZ);
struct timespec cmp_time = huge_timespec;
if (wait < TIMEOUT
|| (wait_proc
@@ -5648,16 +5678,6 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
}
else if (nread == -1 && would_block (errno))
;
-#ifdef WINDOWSNT
- /* FIXME: Is this special case still needed? */
- /* Note that we cannot distinguish between no input
- available now and a closed pipe.
- With luck, a closed pipe will be accompanied by
- subprocess termination and SIGCHLD. */
- else if (nread == 0 && !NETCONN_P (proc) && !SERIALCONN_P (proc)
- && !PIPECONN_P (proc))
- ;
-#endif
#ifdef HAVE_PTYS
/* On some OSs with ptys, when the process on one end of
a pty exits, the other end gets an error reading with
@@ -5696,7 +5716,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
deactivate_process (proc);
if (EQ (XPROCESS (proc)->status, Qrun))
pset_status (XPROCESS (proc),
- list2 (Qexit, make_number (0)));
+ list2 (Qexit, make_fixnum (0)));
}
else
{
@@ -5707,7 +5727,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
update_status (XPROCESS (proc));
if (EQ (XPROCESS (proc)->status, Qrun))
pset_status (XPROCESS (proc),
- list2 (Qexit, make_number (256)));
+ list2 (Qexit, make_fixnum (256)));
}
}
if (FD_ISSET (channel, &Writeok)
@@ -5759,7 +5779,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
else
{
p->tick = ++process_tick;
- pset_status (p, list2 (Qfailed, make_number (xerrno)));
+ pset_status (p, list2 (Qfailed, make_fixnum (xerrno)));
}
deactivate_process (proc);
if (!NILP (addrinfos))
@@ -5828,7 +5848,7 @@ read_process_output_error_handler (Lisp_Object error_val)
cmd_error_internal (error_val, "error in process filter: ");
Vinhibit_quit = Qt;
update_echo_area ();
- Fsleep_for (make_number (2), Qnil);
+ Fsleep_for (make_fixnum (2), Qnil);
return Qt;
}
@@ -5839,7 +5859,8 @@ read_and_dispose_of_process_output (struct Lisp_Process *p, char *chars,
/* Read pending output from the process channel,
starting with our buffered-ahead character if we have one.
- Yield number of decoded characters read.
+ Yield number of decoded characters read,
+ or -1 (setting errno) if there is a read error.
This function reads at most 4096 characters.
If you want to read all available subprocess output,
@@ -5869,8 +5890,10 @@ read_process_output (Lisp_Object proc, int channel)
if (DATAGRAM_CHAN_P (channel))
{
socklen_t len = datagram_address[channel].len;
- nbytes = recvfrom (channel, chars + carryover, readmax,
- 0, datagram_address[channel].sa, &len);
+ do
+ nbytes = recvfrom (channel, chars + carryover, readmax,
+ 0, datagram_address[channel].sa, &len);
+ while (nbytes < 0 && errno == EINTR);
}
else
#endif
@@ -5920,8 +5943,6 @@ read_process_output (Lisp_Object proc, int channel)
p->decoding_carryover = 0;
- /* At this point, NBYTES holds number of bytes just received
- (including the one in proc_buffered_char[channel]). */
if (nbytes <= 0)
{
if (nbytes < 0 || coding->mode & CODING_MODE_LAST_BLOCK)
@@ -5929,6 +5950,9 @@ read_process_output (Lisp_Object proc, int channel)
coding->mode |= CODING_MODE_LAST_BLOCK;
}
+ /* At this point, NBYTES holds number of bytes just received
+ (including the one in proc_buffered_char[channel]). */
+
/* Ignore carryover, it's been added by a previous iteration already. */
p->nbytes_read += nbytes;
@@ -6146,7 +6170,7 @@ Otherwise it discards the output. */)
/* If the restriction isn't what it should be, set it. */
if (old_begv != BEGV || old_zv != ZV)
- Fnarrow_to_region (make_number (old_begv), make_number (old_zv));
+ Fnarrow_to_region (make_fixnum (old_begv), make_fixnum (old_zv));
bset_read_only (current_buffer, old_read_only);
SET_PT_BOTH (opoint, opoint_byte);
@@ -6193,7 +6217,7 @@ write_queue_push (struct Lisp_Process *p, Lisp_Object input_obj,
obj = make_unibyte_string (buf, len);
}
- entry = Fcons (obj, Fcons (make_number (offset), make_number (len)));
+ entry = Fcons (obj, Fcons (make_fixnum (offset), make_fixnum (len)));
if (front)
pset_write_queue (p, Fcons (entry, p->write_queue));
@@ -6221,8 +6245,8 @@ write_queue_pop (struct Lisp_Process *p, Lisp_Object *obj,
*obj = XCAR (entry);
offset_length = XCDR (entry);
- *len = XINT (XCDR (offset_length));
- offset = XINT (XCAR (offset_length));
+ *len = XFIXNUM (XCDR (offset_length));
+ offset = XFIXNUM (XCAR (offset_length));
*buf = SSDATA (*obj) + offset;
return 1;
@@ -6371,9 +6395,17 @@ send_process (Lisp_Object proc, const char *buf, ptrdiff_t len,
#ifdef DATAGRAM_SOCKETS
if (DATAGRAM_CHAN_P (outfd))
{
- rv = sendto (outfd, cur_buf, cur_len,
- 0, datagram_address[outfd].sa,
- datagram_address[outfd].len);
+ while (true)
+ {
+ rv = sendto (outfd, cur_buf, cur_len, 0,
+ datagram_address[outfd].sa,
+ datagram_address[outfd].len);
+ if (! (rv < 0 && errno == EINTR))
+ break;
+ if (pending_signals)
+ process_pending_signals ();
+ }
+
if (rv >= 0)
written = rv;
else if (errno == EMSGSIZE)
@@ -6430,7 +6462,7 @@ send_process (Lisp_Object proc, const char *buf, ptrdiff_t len,
}
#endif /* BROKEN_PTY_READ_AFTER_EAGAIN */
- /* Put what we should have written in wait_queue. */
+ /* Put what we should have written in write_queue. */
write_queue_push (p, cur_object, cur_buf, cur_len, 1);
wait_reading_process_output (0, 20 * 1000 * 1000,
0, 0, Qnil, NULL, 0);
@@ -6440,7 +6472,7 @@ send_process (Lisp_Object proc, const char *buf, ptrdiff_t len,
else if (errno == EPIPE)
{
p->raw_status_new = 0;
- pset_status (p, list2 (Qexit, make_number (256)));
+ pset_status (p, list2 (Qexit, make_fixnum (256)));
p->tick = ++process_tick;
deactivate_process (proc);
error ("process %s no longer connected to pipe; closed it",
@@ -6478,11 +6510,11 @@ set up yet, this function will block until socket setup has completed. */)
validate_region (&start, &end);
- start_byte = CHAR_TO_BYTE (XINT (start));
- end_byte = CHAR_TO_BYTE (XINT (end));
+ start_byte = CHAR_TO_BYTE (XFIXNUM (start));
+ end_byte = CHAR_TO_BYTE (XFIXNUM (end));
- if (XINT (start) < GPT && XINT (end) > GPT)
- move_gap_both (XINT (start), start_byte);
+ if (XFIXNUM (start) < GPT && XFIXNUM (end) > GPT)
+ move_gap_both (XFIXNUM (start), start_byte);
if (NETCONN_P (proc))
wait_while_connecting (proc);
@@ -6565,7 +6597,7 @@ process group. */)
if (gid == p->pid)
return Qnil;
if (gid != -1)
- return make_number (gid);
+ return make_fixnum (gid);
return Qt;
}
@@ -6871,10 +6903,10 @@ SIGCODE may be an integer, or a symbol whose name is a signal name. */)
Lisp_Object tem = Fget_process (process);
if (NILP (tem))
{
- Lisp_Object process_number
- = string_to_number (SSDATA (process), 10, 1);
- if (NUMBERP (process_number))
- tem = process_number;
+ ptrdiff_t len;
+ tem = string_to_number (SSDATA (process), 10, &len);
+ if (NILP (tem) || len != SBYTES (process))
+ return Qnil;
}
process = tem;
}
@@ -6894,10 +6926,10 @@ SIGCODE may be an integer, or a symbol whose name is a signal name. */)
error ("Cannot signal process %s", SDATA (XPROCESS (process)->name));
}
- if (INTEGERP (sigcode))
+ if (FIXNUMP (sigcode))
{
CHECK_TYPE_RANGED_INTEGER (int, sigcode);
- signo = XINT (sigcode);
+ signo = XFIXNUM (sigcode);
}
else
{
@@ -6911,7 +6943,7 @@ SIGCODE may be an integer, or a symbol whose name is a signal name. */)
error ("Undefined signal name %s", name);
}
- return make_number (kill (pid, signo));
+ return make_fixnum (kill (pid, signo));
}
DEFUN ("process-send-eof", Fprocess_send_eof, Sprocess_send_eof, 0, 1, 0,
@@ -7081,13 +7113,11 @@ handle_child_signal (int sig)
if (! CONSP (head))
continue;
xpid = XCAR (head);
- if (all_pids_are_fixnums ? INTEGERP (xpid) : NUMBERP (xpid))
+ if (all_pids_are_fixnums ? FIXNUMP (xpid) : INTEGERP (xpid))
{
- pid_t deleted_pid;
- if (INTEGERP (xpid))
- deleted_pid = XINT (xpid);
- else
- deleted_pid = XFLOAT_DATA (xpid);
+ intmax_t deleted_pid;
+ bool ok = integer_to_intmax (xpid, &deleted_pid);
+ eassert (ok);
if (child_status_changed (deleted_pid, 0, 0))
{
if (STRINGP (XCDR (head)))
@@ -7151,7 +7181,7 @@ exec_sentinel_error_handler (Lisp_Object error_val)
cmd_error_internal (error_val, "error in process sentinel: ");
Vinhibit_quit = Qt;
update_echo_area ();
- Fsleep_for (make_number (2), Qnil);
+ Fsleep_for (make_fixnum (2), Qnil);
return Qt;
}
@@ -7546,7 +7576,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
{
register int nfds;
struct timespec end_time, timeout;
- enum { MINIMUM = -1, TIMEOUT, INFINITY } wait;
+ enum { MINIMUM = -1, TIMEOUT, FOREVER } wait;
if (TYPE_MAXIMUM (time_t) < time_limit)
time_limit = TYPE_MAXIMUM (time_t);
@@ -7560,7 +7590,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
make_timespec (time_limit, nsecs));
}
else
- wait = INFINITY;
+ wait = FOREVER;
/* Turn off periodic alarms (in case they are in use)
and then turn off any other atimers,
@@ -7666,7 +7696,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
/* If we woke up due to SIGWINCH, actually change size now. */
do_pending_window_change (0);
- if (wait < INFINITY && nfds == 0 && ! timeout_reduced_for_timers)
+ if (wait < FOREVER && nfds == 0 && ! timeout_reduced_for_timers)
/* We waited the full specified time, so return now. */
break;
@@ -7959,8 +7989,7 @@ integer or floating point values.
majflt -- number of major page faults (number)
cminflt -- cumulative number of minor page faults (number)
cmajflt -- cumulative number of major page faults (number)
- utime -- user time used by the process, in (current-time) format,
- which is a list of integers (HIGH LOW USEC PSEC)
+ utime -- user time used by the process, in `current-time' format
stime -- system time used by the process (current-time)
time -- sum of utime and stime (current-time)
cutime -- user time used by the process and its children (current-time)
@@ -7972,7 +8001,7 @@ integer or floating point values.
start -- time the process started (current-time)
vsize -- virtual memory size of the process in KB's (number)
rss -- resident set size of the process in KB's (number)
- etime -- elapsed time the process is running, in (HIGH LOW USEC PSEC) format
+ etime -- elapsed time the process is running (current-time)
pcpu -- percents of CPU time used by the process (floating-point number)
pmem -- percents of total physical memory used by process's resident set
(floating-point number)
@@ -8030,9 +8059,7 @@ init_process_emacs (int sockfd)
inhibit_sentinels = 0;
-#ifndef CANNOT_DUMP
- if (! noninteractive || initialized)
-#endif
+ if (!will_dump_with_unexec_p ())
{
#if defined HAVE_GLIB && !defined WINDOWSNT
/* Tickle glib's child-handling code. Ask glib to wait for Emacs itself;
@@ -8058,6 +8085,18 @@ init_process_emacs (int sockfd)
#endif
external_sock_fd = sockfd;
+ Lisp_Object sockname = Qnil;
+# if HAVE_GETSOCKNAME
+ if (0 <= sockfd)
+ {
+ union u_sockaddr sa;
+ socklen_t salen = sizeof sa;
+ if (getsockname (sockfd, &sa.sa, &salen) == 0)
+ sockname = conv_sockaddr_to_lisp (&sa.sa, salen);
+ }
+# endif
+ Vinternal__daemon_sockname = sockname;
+
max_desc = -1;
memset (fd_callback_info, 0, sizeof (fd_callback_info));
@@ -8106,6 +8145,8 @@ init_process_emacs (int sockfd)
void
syms_of_process (void)
{
+ DEFSYM (Qmake_process, "make-process");
+
#ifdef subprocesses
DEFSYM (Qprocessp, "processp");
@@ -8146,6 +8187,7 @@ syms_of_process (void)
DEFSYM (Qreal, "real");
DEFSYM (Qnetwork, "network");
DEFSYM (Qserial, "serial");
+ DEFSYM (QCfile_handler, ":file-handler");
DEFSYM (QCbuffer, ":buffer");
DEFSYM (QChost, ":host");
DEFSYM (QCservice, ":service");
@@ -8250,6 +8292,10 @@ These functions are called in the order of the list, until one of them
returns non-`nil'. */);
Vinterrupt_process_functions = list1 (Qinternal_default_interrupt_process);
+ DEFVAR_LISP ("internal--daemon-sockname", Vinternal__daemon_sockname,
+ doc: /* Name of external socket passed to Emacs, or nil if none. */);
+ Vinternal__daemon_sockname = Qnil;
+
DEFSYM (Qinternal_default_interrupt_process,
"internal-default-interrupt-process");
DEFSYM (Qinterrupt_process_functions, "interrupt-process-functions");
diff --git a/src/process.h b/src/process.h
index 3d0f5f6fc58..5e957c4298e 100644
--- a/src/process.h
+++ b/src/process.h
@@ -117,9 +117,7 @@ struct Lisp_Process
/* The thread a process is linked to, or nil for any thread. */
Lisp_Object thread;
-
- /* After this point, there are no Lisp_Objects any more. */
- /* alloc.c assumes that `pid' is the first such non-Lisp slot. */
+ /* After this point, there are no Lisp_Objects. */
/* Process ID. A positive value is a child process ID.
Zero is for pseudo-processes such as network or serial connections,
@@ -194,7 +192,8 @@ struct Lisp_Process
gnutls_session_t gnutls_state;
gnutls_certificate_client_credentials gnutls_x509_cred;
gnutls_anon_client_credentials_t gnutls_anon_cred;
- gnutls_x509_crt_t gnutls_certificate;
+ gnutls_x509_crt_t *gnutls_certificates;
+ int gnutls_certificates_length;
unsigned int gnutls_peer_verification;
unsigned int gnutls_extra_peer_verification;
int gnutls_log_level;
@@ -202,7 +201,7 @@ struct Lisp_Process
bool_bf gnutls_p : 1;
bool_bf gnutls_complete_negotiation_p : 1;
#endif
-};
+ } GCALIGNED_STRUCT;
INLINE bool
PROCESSP (Lisp_Object a)
@@ -220,7 +219,7 @@ INLINE struct Lisp_Process *
XPROCESS (Lisp_Object a)
{
eassert (PROCESSP (a));
- return XUNTAG (a, Lisp_Vectorlike);
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Process);
}
/* Every field in the preceding structure except for the first two
@@ -299,6 +298,7 @@ extern Lisp_Object network_interface_info (Lisp_Object);
extern Lisp_Object remove_slash_colon (Lisp_Object);
extern void update_processes_for_thread_death (Lisp_Object);
+extern void dissociate_controlling_tty (void);
INLINE_HEADER_END
diff --git a/src/profiler.c b/src/profiler.c
index 41896257557..87be30acc30 100644
--- a/src/profiler.c
+++ b/src/profiler.c
@@ -21,6 +21,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "lisp.h"
#include "syssignal.h"
#include "systime.h"
+#include "pdumper.h"
/* Return A + B, but return the maximum fixnum if the result would overflow.
Assume A and B are nonnegative and in fixnum range. */
@@ -35,15 +36,32 @@ saturated_add (EMACS_INT a, EMACS_INT b)
typedef struct Lisp_Hash_Table log_t;
-static struct hash_table_test hashtest_profiler;
+static bool cmpfn_profiler (
+ struct hash_table_test *, Lisp_Object, Lisp_Object);
+
+static EMACS_UINT hashfn_profiler (
+ struct hash_table_test *, Lisp_Object);
+
+static const struct hash_table_test hashtest_profiler =
+ {
+ LISPSYM_INITIALLY (Qprofiler_backtrace_equal),
+ LISPSYM_INITIALLY (Qnil) /* user_hash_function */,
+ LISPSYM_INITIALLY (Qnil) /* user_cmp_function */,
+ cmpfn_profiler,
+ hashfn_profiler,
+ };
static Lisp_Object
-make_log (EMACS_INT heap_size, EMACS_INT max_stack_depth)
+make_log (void)
{
/* We use a standard Elisp hash-table object, but we use it in
a special way. This is OK as long as the object is not exposed
to Elisp, i.e. until it is returned by *-profiler-log, after which
it can't be used any more. */
+ EMACS_INT heap_size
+ = clip_to_bounds (0, profiler_log_size, MOST_POSITIVE_FIXNUM);
+ ptrdiff_t max_stack_depth
+ = clip_to_bounds (0, profiler_max_stack_depth, PTRDIFF_MAX);;
Lisp_Object log = make_hash_table (hashtest_profiler, heap_size,
DEFAULT_REHASH_SIZE,
DEFAULT_REHASH_THRESHOLD,
@@ -54,8 +72,7 @@ make_log (EMACS_INT heap_size, EMACS_INT max_stack_depth)
with the vectors we'll put in them. */
ptrdiff_t i = ASIZE (h->key_and_value) >> 1;
while (i > 0)
- set_hash_key_slot (h, --i,
- Fmake_vector (make_number (max_stack_depth), Qnil));
+ set_hash_key_slot (h, --i, make_nil_vector (max_stack_depth));
return log;
}
@@ -80,12 +97,12 @@ static EMACS_INT approximate_median (log_t *log,
{
eassert (size > 0);
if (size < 2)
- return XINT (HASH_VALUE (log, start));
+ return XFIXNUM (HASH_VALUE (log, start));
if (size < 3)
/* Not an actual median, but better for our application than
choosing either of the two numbers. */
- return ((XINT (HASH_VALUE (log, start))
- + XINT (HASH_VALUE (log, start + 1)))
+ return ((XFIXNUM (HASH_VALUE (log, start))
+ + XFIXNUM (HASH_VALUE (log, start + 1)))
/ 2);
else
{
@@ -105,12 +122,11 @@ static void evict_lower_half (log_t *log)
{
ptrdiff_t size = ASIZE (log->key_and_value) / 2;
EMACS_INT median = approximate_median (log, 0, size);
- ptrdiff_t i;
- for (i = 0; i < size; i++)
+ for (ptrdiff_t i = 0; i < size; i++)
/* Evict not only values smaller but also values equal to the median,
so as to make sure we evict something no matter what. */
- if (XINT (HASH_VALUE (log, i)) <= median)
+ if (XFIXNUM (HASH_VALUE (log, i)) <= median)
{
Lisp_Object key = HASH_KEY (log, i);
{ /* FIXME: we could make this more efficient. */
@@ -135,17 +151,14 @@ static void evict_lower_half (log_t *log)
static void
record_backtrace (log_t *log, EMACS_INT count)
{
- Lisp_Object backtrace;
- ptrdiff_t index;
-
if (log->next_free < 0)
/* FIXME: transfer the evicted counts to a special entry rather
than dropping them on the floor. */
evict_lower_half (log);
- index = log->next_free;
+ ptrdiff_t index = log->next_free;
/* Get a "working memory" vector. */
- backtrace = HASH_KEY (log, index);
+ Lisp_Object backtrace = HASH_KEY (log, index);
get_backtrace (backtrace);
{ /* We basically do a `gethash+puthash' here, except that we have to be
@@ -156,15 +169,15 @@ record_backtrace (log_t *log, EMACS_INT count)
ptrdiff_t j = hash_lookup (log, backtrace, &hash);
if (j >= 0)
{
- EMACS_INT old_val = XINT (HASH_VALUE (log, j));
+ EMACS_INT old_val = XFIXNUM (HASH_VALUE (log, j));
EMACS_INT new_val = saturated_add (old_val, count);
- set_hash_value_slot (log, j, make_number (new_val));
+ set_hash_value_slot (log, j, make_fixnum (new_val));
}
else
{ /* BEWARE! hash_put in general can allocate memory.
But currently it only does that if log->next_free is -1. */
eassert (0 <= log->next_free);
- ptrdiff_t j = hash_put (log, backtrace, make_number (count), hash);
+ ptrdiff_t j = hash_put (log, backtrace, make_fixnum (count), hash);
/* Let's make sure we've put `backtrace' right where it
already was to start with. */
eassert (index == j);
@@ -219,12 +232,6 @@ static EMACS_INT current_sampling_interval;
/* Signal handler for sampling profiler. */
-/* timer_getoverrun is not implemented on Cygwin, but the following
- seems to be good enough for profiling. */
-#ifdef CYGWIN
-#define timer_getoverrun(x) 0
-#endif
-
static void
handle_profiler_signal (int signal)
{
@@ -239,7 +246,7 @@ handle_profiler_signal (int signal)
else
{
EMACS_INT count = 1;
-#ifdef HAVE_ITIMERSPEC
+#if defined HAVE_ITIMERSPEC && defined HAVE_TIMER_GETOVERRUN
if (profiler_timer_ok)
{
int overruns = timer_getoverrun (profiler_timer);
@@ -261,21 +268,20 @@ deliver_profiler_signal (int signal)
static int
setup_cpu_timer (Lisp_Object sampling_interval)
{
- struct sigaction action;
- struct itimerval timer;
- struct timespec interval;
int billion = 1000000000;
- if (! RANGED_INTEGERP (1, sampling_interval,
+ if (! RANGED_FIXNUMP (1, sampling_interval,
(TYPE_MAXIMUM (time_t) < EMACS_INT_MAX / billion
? ((EMACS_INT) TYPE_MAXIMUM (time_t) * billion
+ (billion - 1))
: EMACS_INT_MAX)))
return -1;
- current_sampling_interval = XINT (sampling_interval);
- interval = make_timespec (current_sampling_interval / billion,
- current_sampling_interval % billion);
+ current_sampling_interval = XFIXNUM (sampling_interval);
+ struct timespec interval
+ = make_timespec (current_sampling_interval / billion,
+ current_sampling_interval % billion);
+ struct sigaction action;
emacs_sigaction_init (&action, deliver_profiler_signal);
sigaction (SIGPROF, &action, 0);
@@ -295,16 +301,15 @@ setup_cpu_timer (Lisp_Object sampling_interval)
#endif
CLOCK_REALTIME
};
- int i;
struct sigevent sigev;
sigev.sigev_value.sival_ptr = &profiler_timer;
sigev.sigev_signo = SIGPROF;
sigev.sigev_notify = SIGEV_SIGNAL;
- for (i = 0; i < ARRAYELTS (system_clock); i++)
+ for (int i = 0; i < ARRAYELTS (system_clock); i++)
if (timer_create (system_clock[i], &sigev, &profiler_timer) == 0)
{
- profiler_timer_ok = 1;
+ profiler_timer_ok = true;
break;
}
}
@@ -319,6 +324,7 @@ setup_cpu_timer (Lisp_Object sampling_interval)
#endif
#ifdef HAVE_SETITIMER
+ struct itimerval timer;
timer.it_value = timer.it_interval = make_timeval (interval);
if (setitimer (ITIMER_PROF, &timer, 0) == 0)
return SETITIMER_RUNNING;
@@ -340,12 +346,11 @@ See also `profiler-log-size' and `profiler-max-stack-depth'. */)
if (NILP (cpu_log))
{
cpu_gc_count = 0;
- cpu_log = make_log (profiler_log_size,
- profiler_max_stack_depth);
+ cpu_log = make_log ();
}
int status = setup_cpu_timer (sampling_interval);
- if (status == -1)
+ if (status < 0)
{
profiler_cpu_running = NOT_RUNNING;
error ("Invalid sampling interval");
@@ -374,8 +379,7 @@ Return non-nil if the profiler was running. */)
#ifdef HAVE_ITIMERSPEC
case TIMER_SETTIME_RUNNING:
{
- struct itimerspec disable;
- memset (&disable, 0, sizeof disable);
+ struct itimerspec disable = { 0, };
timer_settime (profiler_timer, 0, &disable, 0);
}
break;
@@ -384,8 +388,7 @@ Return non-nil if the profiler was running. */)
#ifdef HAVE_SETITIMER
case SETITIMER_RUNNING:
{
- struct itimerval disable;
- memset (&disable, 0, sizeof disable);
+ struct itimerval disable = { 0, };
setitimer (ITIMER_PROF, &disable, 0);
}
break;
@@ -419,11 +422,9 @@ Before returning, a new log is allocated for future samples. */)
/* Here we're making the log visible to Elisp, so it's not safe any
more for our use afterwards since we can't rely on its special
pre-allocated keys anymore. So we have to allocate a new one. */
- cpu_log = (profiler_cpu_running
- ? make_log (profiler_log_size, profiler_max_stack_depth)
- : Qnil);
- Fputhash (Fmake_vector (make_number (1), QAutomatic_GC),
- make_number (cpu_gc_count),
+ cpu_log = profiler_cpu_running ? make_log () : Qnil;
+ Fputhash (make_vector (1, QAutomatic_GC),
+ make_fixnum (cpu_gc_count),
result);
cpu_gc_count = 0;
return result;
@@ -450,8 +451,7 @@ See also `profiler-log-size' and `profiler-max-stack-depth'. */)
error ("Memory profiler is already running");
if (NILP (memory_log))
- memory_log = make_log (profiler_log_size,
- profiler_max_stack_depth);
+ memory_log = make_log ();
profiler_memory_running = true;
@@ -494,9 +494,7 @@ Before returning, a new log is allocated for future samples. */)
/* Here we're making the log visible to Elisp , so it's not safe any
more for our use afterwards since we can't rely on its special
pre-allocated keys anymore. So we have to allocate a new one. */
- memory_log = (profiler_memory_running
- ? make_log (profiler_log_size, profiler_max_stack_depth)
- : Qnil);
+ memory_log = profiler_memory_running ? make_log () : Qnil;
return result;
}
@@ -537,10 +535,10 @@ cmpfn_profiler (struct hash_table_test *t,
{
if (VECTORP (bt1) && VECTORP (bt2))
{
- ptrdiff_t i, l = ASIZE (bt1);
+ ptrdiff_t l = ASIZE (bt1);
if (l != ASIZE (bt2))
return false;
- for (i = 0; i < l; i++)
+ for (ptrdiff_t i = 0; i < l; i++)
if (NILP (Ffunction_equal (AREF (bt1, i), AREF (bt2, i))))
return false;
return true;
@@ -555,8 +553,8 @@ hashfn_profiler (struct hash_table_test *ht, Lisp_Object bt)
if (VECTORP (bt))
{
EMACS_UINT hash = 0;
- ptrdiff_t i, l = ASIZE (bt);
- for (i = 0; i < l; i++)
+ ptrdiff_t l = ASIZE (bt);
+ for (ptrdiff_t i = 0; i < l; i++)
{
Lisp_Object f = AREF (bt, i);
EMACS_UINT hash1
@@ -571,6 +569,8 @@ hashfn_profiler (struct hash_table_test *ht, Lisp_Object bt)
return XHASH (bt);
}
+static void syms_of_profiler_for_pdumper (void);
+
void
syms_of_profiler (void)
{
@@ -585,12 +585,6 @@ to make room for new entries. */);
DEFSYM (Qprofiler_backtrace_equal, "profiler-backtrace-equal");
- hashtest_profiler.name = Qprofiler_backtrace_equal;
- hashtest_profiler.user_hash_function = Qnil;
- hashtest_profiler.user_cmp_function = Qnil;
- hashtest_profiler.cmpfn = cmpfn_profiler;
- hashtest_profiler.hashfn = hashfn_profiler;
-
defsubr (&Sfunction_equal);
#ifdef PROFILER_CPU_SUPPORT
@@ -609,4 +603,26 @@ to make room for new entries. */);
defsubr (&Sprofiler_memory_stop);
defsubr (&Sprofiler_memory_running_p);
defsubr (&Sprofiler_memory_log);
+
+ pdumper_do_now_and_after_load (syms_of_profiler_for_pdumper);
+}
+
+static void
+syms_of_profiler_for_pdumper (void)
+{
+ if (dumped_with_pdumper_p ())
+ {
+#ifdef PROFILER_CPU_SUPPORT
+ cpu_log = Qnil;
+#endif
+ memory_log = Qnil;
+ }
+ else
+ {
+#ifdef PROFILER_CPU_SUPPORT
+ eassert (NILP (cpu_log));
+#endif
+ eassert (NILP (memory_log));
+ }
+
}
diff --git a/src/ptr-bounds.h b/src/ptr-bounds.h
new file mode 100644
index 00000000000..b7798168a58
--- /dev/null
+++ b/src/ptr-bounds.h
@@ -0,0 +1,79 @@
+/* Pointer bounds checking for GNU Emacs
+
+Copyright 2017-2019 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 <https://www.gnu.org/licenses/>. */
+
+/* Pointer bounds checking is a no-op unless running on hardware
+ supporting Intel MPX (Intel Skylake or better). Also, it requires
+ GCC 5 and Linux kernel 3.19, or later. Configure with
+ CFLAGS='-fcheck-pointer-bounds -mmpx', perhaps with
+ -fchkp-first-field-has-own-bounds thrown in.
+
+ Although pointer bounds checking can help during debugging, it is
+ disabled by default because it hurts performance significantly.
+ The checking does not detect all pointer errors. For example, a
+ dumped Emacs might not detect a bounds violation of a pointer that
+ was created before Emacs was dumped. */
+
+#ifndef PTR_BOUNDS_H
+#define PTR_BOUNDS_H
+
+#include <stddef.h>
+
+/* When not checking pointer bounds, the following macros simply
+ return their first argument. These macros return either void *, or
+ the same type as their first argument. */
+
+INLINE_HEADER_BEGIN
+
+/* Return a copy of P, with bounds narrowed to [P, P + N). */
+#ifdef __CHKP__
+INLINE void *
+ptr_bounds_clip (void const *p, size_t n)
+{
+ return __builtin___bnd_narrow_ptr_bounds (p, p, n);
+}
+#else
+# define ptr_bounds_clip(p, n) ((void) (size_t) {n}, p)
+#endif
+
+/* Return a copy of P, but with the bounds of Q. */
+#ifdef __CHKP__
+# define ptr_bounds_copy(p, q) __builtin___bnd_copy_ptr_bounds (p, q)
+#else
+# define ptr_bounds_copy(p, q) ((void) (void const *) {q}, p)
+#endif
+
+/* Return a copy of P, but with infinite bounds.
+ This is a loophole in pointer bounds checking. */
+#ifdef __CHKP__
+# define ptr_bounds_init(p) __builtin___bnd_init_ptr_bounds (p)
+#else
+# define ptr_bounds_init(p) (p)
+#endif
+
+/* Return a copy of P, but with bounds [P, P + N).
+ This is a loophole in pointer bounds checking. */
+#ifdef __CHKP__
+# define ptr_bounds_set(p, n) __builtin___bnd_set_ptr_bounds (p, n)
+#else
+# define ptr_bounds_set(p, n) ((void) (size_t) {n}, p)
+#endif
+
+INLINE_HEADER_END
+
+#endif /* PTR_BOUNDS_H */
diff --git a/src/puresize.h b/src/puresize.h
index f96b2c8d7f0..f120a4b3307 100644
--- a/src/puresize.h
+++ b/src/puresize.h
@@ -47,7 +47,7 @@ INLINE_HEADER_BEGIN
#endif
#ifndef BASE_PURESIZE
-#define BASE_PURESIZE (1900000 + SYSTEM_PURESIZE_EXTRA + SITELOAD_PURESIZE_EXTRA)
+#define BASE_PURESIZE (2000000 + SYSTEM_PURESIZE_EXTRA + SITELOAD_PURESIZE_EXTRA)
#endif
/* Increase BASE_PURESIZE by a ratio depending on the machine's word size. */
diff --git a/src/ralloc.c b/src/ralloc.c
index c8db91f2b8f..66ea2ec4119 100644
--- a/src/ralloc.c
+++ b/src/ralloc.c
@@ -26,11 +26,9 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <stddef.h>
-#ifdef emacs
-# include "lisp.h"
-# include "blockinput.h"
-# include <unistd.h>
-#endif
+#include "lisp.h"
+#include "blockinput.h"
+#include <unistd.h>
#include "getpagesize.h"
@@ -924,9 +922,7 @@ r_alloc_free (void **ptr)
free_bloc (dead_bloc);
*ptr = 0;
-#ifdef emacs
refill_memory_reserve ();
-#endif
}
/* Given a pointer at address PTR to relocatable data, resize it to SIZE.
@@ -1000,7 +996,7 @@ r_re_alloc (void **ptr, size_t size)
}
-#if defined (emacs) && defined (DOUG_LEA_MALLOC)
+#ifdef DOUG_LEA_MALLOC
/* Reinitialize the morecore hook variables after restarting a dumped
Emacs. This is needed when using Doug Lea's malloc from GNU libc. */
diff --git a/src/regex.c b/src/regex-emacs.c
index 09ed64a6e13..8dc69805024 100644
--- a/src/regex.c
+++ b/src/regex-emacs.c
@@ -1,6 +1,4 @@
-/* Extended regular expression matching and search library, version
- 0.12. (Implements POSIX draft P1003.2/D11.2, except for some of the
- internationalization features.)
+/* Emacs regular expression matching and search
Copyright (C) 1993-2019 Free Software Foundation, Inc.
@@ -19,165 +17,64 @@
/* TODO:
- structure the opcode space into opcode+flag.
- - merge with glibc's regex.[ch].
- replace (succeed_n + jump_n + set_number_at) with something that doesn't
- need to modify the compiled regexp so that re_match can be reentrant.
+ need to modify the compiled regexp so that re_search can be reentrant.
- get rid of on_failure_jump_smart by doing the optimization in re_comp
- rather than at run-time, so that re_match can be reentrant.
+ rather than at run-time, so that re_search can be reentrant.
*/
-/* AIX requires this to be the first thing in the file. */
-#if defined _AIX && !defined REGEX_MALLOC
- #pragma alloca
-#endif
-
-/* Ignore some GCC warnings for now. This section should go away
- once the Emacs and Gnulib regex code is merged. */
-#if 4 < __GNUC__ + (5 <= __GNUC_MINOR__) || defined __clang__
-# pragma GCC diagnostic ignored "-Wstrict-overflow"
-# ifndef emacs
-# pragma GCC diagnostic ignored "-Wunused-function"
-# pragma GCC diagnostic ignored "-Wunused-macros"
-# pragma GCC diagnostic ignored "-Wunused-result"
-# pragma GCC diagnostic ignored "-Wunused-variable"
-# endif
-#endif
-
-#if 4 < __GNUC__ + (6 <= __GNUC_MINOR__) && ! defined __clang__
-# pragma GCC diagnostic ignored "-Wunused-but-set-variable"
-#endif
-
#include <config.h>
-#include <stddef.h>
-#include <stdlib.h>
-
-#ifdef emacs
-/* We need this for `regex.h', and perhaps for the Emacs include files. */
-# include <sys/types.h>
-#endif
-
-/* Whether to use ISO C Amendment 1 wide char functions.
- Those should not be used for Emacs since it uses its own. */
-#if defined _LIBC
-#define WIDE_CHAR_SUPPORT 1
-#else
-#define WIDE_CHAR_SUPPORT \
- (HAVE_WCTYPE_H && HAVE_WCHAR_H && HAVE_BTOWC && !emacs)
-#endif
+#include "regex-emacs.h"
-/* For platform which support the ISO C amendment 1 functionality we
- support user defined character classes. */
-#if WIDE_CHAR_SUPPORT
-/* Solaris 2.5 has a bug: <wchar.h> must be included before <wctype.h>. */
-# include <wchar.h>
-# include <wctype.h>
-#endif
-
-#ifdef _LIBC
-/* We have to keep the namespace clean. */
-# define regfree(preg) __regfree (preg)
-# define regexec(pr, st, nm, pm, ef) __regexec (pr, st, nm, pm, ef)
-# define regcomp(preg, pattern, cflags) __regcomp (preg, pattern, cflags)
-# define regerror(err_code, preg, errbuf, errbuf_size) \
- __regerror (err_code, preg, errbuf, errbuf_size)
-# define re_set_registers(bu, re, nu, st, en) \
- __re_set_registers (bu, re, nu, st, en)
-# define re_match_2(bufp, string1, size1, string2, size2, pos, regs, stop) \
- __re_match_2 (bufp, string1, size1, string2, size2, pos, regs, stop)
-# define re_match(bufp, string, size, pos, regs) \
- __re_match (bufp, string, size, pos, regs)
-# define re_search(bufp, string, size, startpos, range, regs) \
- __re_search (bufp, string, size, startpos, range, regs)
-# define re_compile_pattern(pattern, length, bufp) \
- __re_compile_pattern (pattern, length, bufp)
-# define re_set_syntax(syntax) __re_set_syntax (syntax)
-# define re_search_2(bufp, st1, s1, st2, s2, startpos, range, regs, stop) \
- __re_search_2 (bufp, st1, s1, st2, s2, startpos, range, regs, stop)
-# define re_compile_fastmap(bufp) __re_compile_fastmap (bufp)
-
-/* Make sure we call libc's function even if the user overrides them. */
-# define btowc __btowc
-# define iswctype __iswctype
-# define wctype __wctype
-
-# define WEAK_ALIAS(a,b) weak_alias (a, b)
-
-/* We are also using some library internals. */
-# include <locale/localeinfo.h>
-# include <locale/elem-hash.h>
-# include <langinfo.h>
-#else
-# define WEAK_ALIAS(a,b)
-#endif
-
-/* This is for other GNU distributions with internationalized messages. */
-#if HAVE_LIBINTL_H || defined _LIBC
-# include <libintl.h>
-#else
-# define gettext(msgid) (msgid)
-#endif
+#include <stdlib.h>
-#ifndef gettext_noop
-/* This define is so xgettext can find the internationalizable
- strings. */
-# define gettext_noop(String) String
+#include "character.h"
+#include "buffer.h"
+#include "syntax.h"
+#include "category.h"
+
+/* Maximum number of duplicates an interval can allow. Some systems
+ define this in other header files, but we want our value, so remove
+ any previous define. Repeat counts are stored in opcodes as 2-byte
+ unsigned integers. */
+#ifdef RE_DUP_MAX
+# undef RE_DUP_MAX
#endif
-
-/* The `emacs' switch turns on certain matching commands
- that make sense only in Emacs. */
-#ifdef emacs
-
-# include "lisp.h"
-# include "character.h"
-# include "buffer.h"
-
-# include "syntax.h"
-# include "category.h"
+#define RE_DUP_MAX (0xffff)
/* Make syntax table lookup grant data in gl_state. */
-# define SYNTAX(c) syntax_property (c, 1)
-
-# ifdef malloc
-# undef malloc
-# endif
-# define malloc xmalloc
-# ifdef realloc
-# undef realloc
-# endif
-# define realloc xrealloc
-# ifdef free
-# undef free
-# endif
-# define free xfree
-
-/* Converts the pointer to the char to BEG-based offset from the start. */
-# define PTR_TO_OFFSET(d) POS_AS_IN_BUFFER (POINTER_TO_OFFSET (d))
-/* Strings are 0-indexed, buffers are 1-indexed; we pun on the boolean
+#define SYNTAX(c) syntax_property (c, 1)
+
+/* Convert the pointer to the char to BEG-based offset from the start. */
+#define PTR_TO_OFFSET(d) POS_AS_IN_BUFFER (POINTER_TO_OFFSET (d))
+/* Strings are 0-indexed, buffers are 1-indexed; pun on the boolean
result to get the right base index. */
-# define POS_AS_IN_BUFFER(p) ((p) + (NILP (re_match_object) || BUFFERP (re_match_object)))
+#define POS_AS_IN_BUFFER(p) \
+ ((p) + (NILP (gl_state.object) || BUFFERP (gl_state.object)))
-# define RE_MULTIBYTE_P(bufp) ((bufp)->multibyte)
-# define RE_TARGET_MULTIBYTE_P(bufp) ((bufp)->target_multibyte)
-# define RE_STRING_CHAR(p, multibyte) \
- (multibyte ? (STRING_CHAR (p)) : (*(p)))
-# define RE_STRING_CHAR_AND_LENGTH(p, len, multibyte) \
- (multibyte ? (STRING_CHAR_AND_LENGTH (p, len)) : ((len) = 1, *(p)))
+#define RE_MULTIBYTE_P(bufp) ((bufp)->multibyte)
+#define RE_TARGET_MULTIBYTE_P(bufp) ((bufp)->target_multibyte)
+#define RE_STRING_CHAR(p, multibyte) \
+ (multibyte ? STRING_CHAR (p) : *(p))
+#define RE_STRING_CHAR_AND_LENGTH(p, len, multibyte) \
+ (multibyte ? STRING_CHAR_AND_LENGTH (p, len) : ((len) = 1, *(p)))
-# define RE_CHAR_TO_MULTIBYTE(c) UNIBYTE_TO_CHAR (c)
+#define RE_CHAR_TO_MULTIBYTE(c) UNIBYTE_TO_CHAR (c)
-# define RE_CHAR_TO_UNIBYTE(c) CHAR_TO_BYTE_SAFE (c)
+#define RE_CHAR_TO_UNIBYTE(c) CHAR_TO_BYTE_SAFE (c)
/* Set C a (possibly converted to multibyte) character before P. P
points into a string which is the virtual concatenation of STR1
(which ends at END1) or STR2 (which ends at END2). */
-# define GET_CHAR_BEFORE_2(c, p, str1, end1, str2, end2) \
+#define GET_CHAR_BEFORE_2(c, p, str1, end1, str2, end2) \
do { \
if (target_multibyte) \
{ \
re_char *dtemp = (p) == (str2) ? (end1) : (p); \
- re_char *dlimit = ((p) > (str2) && (p) <= (end2)) ? (str2) : (str1); \
- while (dtemp-- > dlimit && !CHAR_HEAD_P (*dtemp)); \
+ re_char *dlimit = (p) > (str2) && (p) <= (end2) ? (str2) : (str1); \
+ while (dtemp-- > dlimit && !CHAR_HEAD_P (*dtemp)) \
+ continue; \
c = STRING_CHAR (dtemp); \
} \
else \
@@ -185,11 +82,11 @@
(c = ((p) == (str2) ? (end1) : (p))[-1]); \
(c) = RE_CHAR_TO_MULTIBYTE (c); \
} \
- } while (0)
+ } while (false)
/* Set C a (possibly converted to multibyte) character at P, and set
LEN to the byte length of that character. */
-# define GET_CHAR_AFTER(c, p, len) \
+#define GET_CHAR_AFTER(c, p, len) \
do { \
if (target_multibyte) \
(c) = STRING_CHAR_AND_LENGTH (p, len); \
@@ -199,342 +96,102 @@
len = 1; \
(c) = RE_CHAR_TO_MULTIBYTE (c); \
} \
- } while (0)
-
-#else /* not emacs */
-
-/* If we are not linking with Emacs proper,
- we can't use the relocating allocator
- even if config.h says that we can. */
-# undef REL_ALLOC
-
-# include <unistd.h>
-
-/* When used in Emacs's lib-src, we need xmalloc and xrealloc. */
-
-static void *
-xmalloc (size_t size)
-{
- void *val = malloc (size);
- if (!val && size)
- {
- write (STDERR_FILENO, "virtual memory exhausted\n", 25);
- exit (1);
- }
- return val;
-}
-
-static void *
-xrealloc (void *block, size_t size)
-{
- void *val;
- /* We must call malloc explicitly when BLOCK is 0, since some
- reallocs don't do this. */
- if (! block)
- val = malloc (size);
- else
- val = realloc (block, size);
- if (!val && size)
- {
- write (STDERR_FILENO, "virtual memory exhausted\n", 25);
- exit (1);
- }
- return val;
-}
-
-# ifdef malloc
-# undef malloc
-# endif
-# define malloc xmalloc
-# ifdef realloc
-# undef realloc
-# endif
-# define realloc xrealloc
-
-# include <stdbool.h>
-# include <string.h>
-
-/* Define the syntax stuff for \<, \>, etc. */
-
-/* Sword must be nonzero for the wordchar pattern commands in re_match_2. */
-enum syntaxcode { Swhitespace = 0, Sword = 1, Ssymbol = 2 };
-
-/* Dummy macros for non-Emacs environments. */
-# define MAX_MULTIBYTE_LENGTH 1
-# define RE_MULTIBYTE_P(x) 0
-# define RE_TARGET_MULTIBYTE_P(x) 0
-# define WORD_BOUNDARY_P(c1, c2) (0)
-# define BYTES_BY_CHAR_HEAD(p) (1)
-# define PREV_CHAR_BOUNDARY(p, limit) ((p)--)
-# define STRING_CHAR(p) (*(p))
-# define RE_STRING_CHAR(p, multibyte) STRING_CHAR (p)
-# define CHAR_STRING(c, s) (*(s) = (c), 1)
-# define STRING_CHAR_AND_LENGTH(p, actual_len) ((actual_len) = 1, *(p))
-# define RE_STRING_CHAR_AND_LENGTH(p, len, multibyte) STRING_CHAR_AND_LENGTH (p, len)
-# define RE_CHAR_TO_MULTIBYTE(c) (c)
-# define RE_CHAR_TO_UNIBYTE(c) (c)
-# define GET_CHAR_BEFORE_2(c, p, str1, end1, str2, end2) \
- (c = ((p) == (str2) ? *((end1) - 1) : *((p) - 1)))
-# define GET_CHAR_AFTER(c, p, len) \
- (c = *p, len = 1)
-# define CHAR_BYTE8_P(c) (0)
-# define CHAR_LEADING_CODE(c) (c)
-
-#endif /* not emacs */
-
-#ifndef RE_TRANSLATE
-# define RE_TRANSLATE(TBL, C) ((unsigned char)(TBL)[C])
-# define RE_TRANSLATE_P(TBL) (TBL)
-#endif
+ } while (false)
-/* Get the interface, including the syntax bits. */
-#include "regex.h"
-
-/* isalpha etc. are used for the character classes. */
-#include <ctype.h>
-
-#ifdef emacs
-
/* 1 if C is an ASCII character. */
-# define IS_REAL_ASCII(c) ((c) < 0200)
+#define IS_REAL_ASCII(c) ((c) < 0200)
/* 1 if C is a unibyte character. */
-# define ISUNIBYTE(c) (SINGLE_BYTE_CHAR_P ((c)))
+#define ISUNIBYTE(c) (SINGLE_BYTE_CHAR_P ((c)))
/* The Emacs definitions should not be directly affected by locales. */
/* In Emacs, these are only used for single-byte characters. */
-# define ISDIGIT(c) ((c) >= '0' && (c) <= '9')
-# define ISCNTRL(c) ((c) < ' ')
-# define ISXDIGIT(c) (0 <= char_hexdigit (c))
+#define ISDIGIT(c) ((c) >= '0' && (c) <= '9')
+#define ISCNTRL(c) ((c) < ' ')
+#define ISXDIGIT(c) (0 <= char_hexdigit (c))
/* The rest must handle multibyte characters. */
-# define ISBLANK(c) (IS_REAL_ASCII (c) \
+#define ISBLANK(c) (IS_REAL_ASCII (c) \
? ((c) == ' ' || (c) == '\t') \
: blankp (c))
-# define ISGRAPH(c) (SINGLE_BYTE_CHAR_P (c) \
+#define ISGRAPH(c) (SINGLE_BYTE_CHAR_P (c) \
? (c) > ' ' && !((c) >= 0177 && (c) <= 0240) \
: graphicp (c))
-# define ISPRINT(c) (SINGLE_BYTE_CHAR_P (c) \
+#define ISPRINT(c) (SINGLE_BYTE_CHAR_P (c) \
? (c) >= ' ' && !((c) >= 0177 && (c) <= 0237) \
: printablep (c))
-# define ISALNUM(c) (IS_REAL_ASCII (c) \
+#define ISALNUM(c) (IS_REAL_ASCII (c) \
? (((c) >= 'a' && (c) <= 'z') \
|| ((c) >= 'A' && (c) <= 'Z') \
|| ((c) >= '0' && (c) <= '9')) \
: alphanumericp (c))
-# define ISALPHA(c) (IS_REAL_ASCII (c) \
+#define ISALPHA(c) (IS_REAL_ASCII (c) \
? (((c) >= 'a' && (c) <= 'z') \
|| ((c) >= 'A' && (c) <= 'Z')) \
: alphabeticp (c))
-# define ISLOWER(c) lowercasep (c)
+#define ISLOWER(c) lowercasep (c)
-# define ISPUNCT(c) (IS_REAL_ASCII (c) \
+#define ISPUNCT(c) (IS_REAL_ASCII (c) \
? ((c) > ' ' && (c) < 0177 \
&& !(((c) >= 'a' && (c) <= 'z') \
|| ((c) >= 'A' && (c) <= 'Z') \
|| ((c) >= '0' && (c) <= '9'))) \
: SYNTAX (c) != Sword)
-# define ISSPACE(c) (SYNTAX (c) == Swhitespace)
-
-# define ISUPPER(c) uppercasep (c)
-
-# define ISWORD(c) (SYNTAX (c) == Sword)
-
-#else /* not emacs */
-
-/* 1 if C is an ASCII character. */
-# define IS_REAL_ASCII(c) ((c) < 0200)
-
-/* This distinction is not meaningful, except in Emacs. */
-# define ISUNIBYTE(c) 1
-
-# ifdef isblank
-# define ISBLANK(c) isblank (c)
-# else
-# define ISBLANK(c) ((c) == ' ' || (c) == '\t')
-# endif
-# ifdef isgraph
-# define ISGRAPH(c) isgraph (c)
-# else
-# define ISGRAPH(c) (isprint (c) && !isspace (c))
-# endif
-
-/* Solaris defines ISPRINT so we must undefine it first. */
-# undef ISPRINT
-# define ISPRINT(c) isprint (c)
-# define ISDIGIT(c) isdigit (c)
-# define ISALNUM(c) isalnum (c)
-# define ISALPHA(c) isalpha (c)
-# define ISCNTRL(c) iscntrl (c)
-# define ISLOWER(c) islower (c)
-# define ISPUNCT(c) ispunct (c)
-# define ISSPACE(c) isspace (c)
-# define ISUPPER(c) isupper (c)
-# define ISXDIGIT(c) isxdigit (c)
-
-# define ISWORD(c) ISALPHA (c)
-
-# ifdef _tolower
-# define TOLOWER(c) _tolower (c)
-# else
-# define TOLOWER(c) tolower (c)
-# endif
-
-/* How many characters in the character set. */
-# define CHAR_SET_SIZE 256
-
-# ifdef SYNTAX_TABLE
-
-extern char *re_syntax_table;
-
-# else /* not SYNTAX_TABLE */
-
-static char re_syntax_table[CHAR_SET_SIZE];
-
-static void
-init_syntax_once (void)
-{
- register int c;
- static int done = 0;
-
- if (done)
- return;
+#define ISSPACE(c) (SYNTAX (c) == Swhitespace)
- memset (re_syntax_table, 0, sizeof re_syntax_table);
-
- for (c = 0; c < CHAR_SET_SIZE; ++c)
- if (ISALNUM (c))
- re_syntax_table[c] = Sword;
-
- re_syntax_table['_'] = Ssymbol;
-
- done = 1;
-}
+#define ISUPPER(c) uppercasep (c)
-# endif /* not SYNTAX_TABLE */
-
-# define SYNTAX(c) re_syntax_table[(c)]
-
-#endif /* not emacs */
-
-#define SIGN_EXTEND_CHAR(c) ((signed char) (c))
+#define ISWORD(c) (SYNTAX (c) == Sword)
-/* Should we use malloc or alloca? If REGEX_MALLOC is not defined, we
- use `alloca' instead of `malloc'. This is because using malloc in
+/* Use alloca instead of malloc. This is because using malloc in
re_search* or re_match* could cause memory leaks when C-g is used
in Emacs (note that SAFE_ALLOCA could also call malloc, but does so
- via `record_xmalloc' which uses `unwind_protect' to ensure the
+ via 'record_xmalloc' which uses 'unwind_protect' to ensure the
memory is freed even in case of non-local exits); also, malloc is
slower and causes storage fragmentation. On the other hand, malloc
is more portable, and easier to debug.
Because we sometimes use alloca, some routines have to be macros,
- not functions -- `alloca'-allocated space disappears at the end of the
+ not functions -- 'alloca'-allocated space disappears at the end of the
function it is called in. */
-#ifdef REGEX_MALLOC
-
-# define REGEX_ALLOCATE malloc
-# define REGEX_REALLOCATE(source, osize, nsize) realloc (source, nsize)
-# define REGEX_FREE free
-
-#else /* not REGEX_MALLOC */
-
-# ifdef emacs
/* This may be adjusted in main(), if the stack is successfully grown. */
ptrdiff_t emacs_re_safe_alloca = MAX_ALLOCA;
/* Like USE_SAFE_ALLOCA, but use emacs_re_safe_alloca. */
-# define REGEX_USE_SAFE_ALLOCA \
- ptrdiff_t sa_avail = emacs_re_safe_alloca; \
- ptrdiff_t sa_count = SPECPDL_INDEX (); bool sa_must_free = false
-
-# define REGEX_SAFE_FREE() SAFE_FREE ()
-# define REGEX_ALLOCATE SAFE_ALLOCA
-# else
-# include <alloca.h>
-# define REGEX_ALLOCATE alloca
-# endif
-
-/* Assumes a `char *destination' variable. */
-# define REGEX_REALLOCATE(source, osize, nsize) \
- (destination = REGEX_ALLOCATE (nsize), \
- memcpy (destination, source, osize))
-
-/* No need to do anything to free, after alloca. */
-# define REGEX_FREE(arg) ((void)0) /* Do nothing! But inhibit gcc warning. */
-
-#endif /* not REGEX_MALLOC */
-
-#ifndef REGEX_USE_SAFE_ALLOCA
-# define REGEX_USE_SAFE_ALLOCA ((void) 0)
-# define REGEX_SAFE_FREE() ((void) 0)
-#endif
-
-/* Define how to allocate the failure stack. */
-
-#if defined REL_ALLOC && defined REGEX_MALLOC
-
-# define REGEX_ALLOCATE_STACK(size) \
- r_alloc (&failure_stack_ptr, (size))
-# define REGEX_REALLOCATE_STACK(source, osize, nsize) \
- r_re_alloc (&failure_stack_ptr, (nsize))
-# define REGEX_FREE_STACK(ptr) \
- r_alloc_free (&failure_stack_ptr)
-
-#else /* not using relocating allocator */
-
-# define REGEX_ALLOCATE_STACK(size) REGEX_ALLOCATE (size)
-# define REGEX_REALLOCATE_STACK(source, o, n) REGEX_REALLOCATE (source, o, n)
-# define REGEX_FREE_STACK(ptr) REGEX_FREE (ptr)
-
-#endif /* not using relocating allocator */
+#define REGEX_USE_SAFE_ALLOCA \
+ USE_SAFE_ALLOCA; sa_avail = emacs_re_safe_alloca
+/* Assumes a 'char *destination' variable. */
+#define REGEX_REALLOCATE(source, osize, nsize) \
+ (destination = SAFE_ALLOCA (nsize), \
+ memcpy (destination, source, osize))
-/* True if `size1' is non-NULL and PTR is pointing anywhere inside
- `string1' or just past its end. This works if PTR is NULL, which is
+/* True if 'size1' is non-NULL and PTR is pointing anywhere inside
+ 'string1' or just past its end. This works if PTR is NULL, which is
a good thing. */
#define FIRST_STRING_P(ptr) \
(size1 && string1 <= (ptr) && (ptr) <= string1 + size1)
-/* (Re)Allocate N items of type T using malloc, or fail. */
-#define TALLOC(n, t) ((t *) malloc ((n) * sizeof (t)))
-#define RETALLOC(addr, n, t) ((addr) = (t *) realloc (addr, (n) * sizeof (t)))
-#define REGEX_TALLOC(n, t) ((t *) REGEX_ALLOCATE ((n) * sizeof (t)))
-
#define BYTEWIDTH 8 /* In bits. */
-#ifndef emacs
-# undef max
-# undef min
-# define max(a, b) ((a) > (b) ? (a) : (b))
-# define min(a, b) ((a) < (b) ? (a) : (b))
-#endif
-
/* Type of source-pattern and string chars. */
-#ifdef _MSC_VER
-typedef unsigned char re_char;
-typedef const re_char const_re_char;
-#else
typedef const unsigned char re_char;
-typedef re_char const_re_char;
-#endif
-typedef char boolean;
-
-static regoff_t re_match_2_internal (struct re_pattern_buffer *bufp,
- re_char *string1, size_t size1,
- re_char *string2, size_t size2,
- ssize_t pos,
+static void re_compile_fastmap (struct re_pattern_buffer *);
+static ptrdiff_t re_match_2_internal (struct re_pattern_buffer *bufp,
+ re_char *string1, ptrdiff_t size1,
+ re_char *string2, ptrdiff_t size2,
+ ptrdiff_t pos,
struct re_registers *regs,
- ssize_t stop);
+ ptrdiff_t stop);
/* These are the command codes that appear in compiled regular
expressions. Some opcodes are followed by argument bytes. A
@@ -582,7 +239,7 @@ typedef enum
/* Stop remembering the text that is matched and store it in a
memory register. Followed by one byte with the register
- number, in the range 0 to one less than `re_nsub' in the
+ number, in the range 0 to one less than 're_nsub' in the
pattern buffer. */
stop_memory,
@@ -596,8 +253,7 @@ typedef enum
/* Fail unless at end of line. */
endline,
- /* Succeeds if at beginning of buffer (if emacs) or at beginning
- of string to be matched (if not). */
+ /* Succeeds if at beginning of buffer. */
begbuf,
/* Analogously, for end of buffer/string. */
@@ -614,23 +270,23 @@ typedef enum
current string position when executed. */
on_failure_keep_string_jump,
- /* Just like `on_failure_jump', except that it checks that we
+ /* Just like 'on_failure_jump', except that it checks that we
don't get stuck in an infinite loop (matching an empty string
indefinitely). */
on_failure_jump_loop,
- /* Just like `on_failure_jump_loop', except that it checks for
+ /* Just like 'on_failure_jump_loop', except that it checks for
a different kind of loop (the kind that shows up with non-greedy
operators). This operation has to be immediately preceded
- by a `no_op'. */
+ by a 'no_op'. */
on_failure_jump_nastyloop,
- /* A smart `on_failure_jump' used for greedy * and + operators.
+ /* A smart 'on_failure_jump' used for greedy * and + operators.
It analyzes the loop before which it is put and if the
loop does not require backtracking, it changes itself to
- `on_failure_keep_string_jump' and short-circuits the loop,
- else it just defaults to changing itself into `on_failure_jump'.
- It assumes that it is pointing to just past a `jump'. */
+ 'on_failure_keep_string_jump' and short-circuits the loop,
+ else it just defaults to changing itself into 'on_failure_jump'.
+ It assumes that it is pointing to just past a 'jump'. */
on_failure_jump_smart,
/* Followed by two-byte relative address and two-byte number n.
@@ -662,10 +318,9 @@ typedef enum
syntaxspec,
/* Matches any character whose syntax is not that specified. */
- notsyntaxspec
+ notsyntaxspec,
-#ifdef emacs
- , at_dot, /* Succeeds if at point. */
+ at_dot, /* Succeeds if at point. */
/* Matches any character whose category-set contains the specified
category. The operator is followed by a byte which contains a
@@ -676,7 +331,6 @@ typedef enum
specified category. The operator is followed by a byte which
contains the category code (mnemonic ASCII character). */
notcategoryspec
-#endif /* emacs */
} re_opcode_t;
/* Common operations on the compiled pattern. */
@@ -687,7 +341,7 @@ typedef enum
do { \
(destination)[0] = (number) & 0377; \
(destination)[1] = (number) >> 8; \
- } while (0)
+ } while (false)
/* Same as STORE_NUMBER, except increment DESTINATION to
the byte after where the number is stored. Therefore, DESTINATION
@@ -697,7 +351,7 @@ typedef enum
do { \
STORE_NUMBER (destination, number); \
(destination) += 2; \
- } while (0)
+ } while (false)
/* Put into DESTINATION a number stored in two contiguous bytes starting
at SOURCE. */
@@ -708,8 +362,8 @@ typedef enum
static int
extract_number (re_char *source)
{
- unsigned leading_byte = SIGN_EXTEND_CHAR (source[1]);
- return (leading_byte << 8) + source[0];
+ signed char leading_byte = source[1];
+ return leading_byte * 256 + source[0];
}
/* Same as EXTRACT_NUMBER, except increment SOURCE to after the number.
@@ -736,7 +390,7 @@ extract_number_and_incr (re_char **source)
(destination)[1] = ((character) >> 8) & 0377; \
(destination)[2] = (character) >> 16; \
(destination) += 3; \
- } while (0)
+ } while (false)
/* Put into DESTINATION a character stored in three contiguous bytes
starting at SOURCE. */
@@ -746,7 +400,7 @@ extract_number_and_incr (re_char **source)
(destination) = ((source)[0] \
| ((source)[1] << 8) \
| ((source)[2] << 16)); \
- } while (0)
+ } while (false)
/* Macros for charset. */
@@ -756,51 +410,43 @@ extract_number_and_incr (re_char **source)
#define CHARSET_BITMAP_SIZE(p) ((p)[1] & 0x7F)
/* Nonzero if charset P has range table. */
-#define CHARSET_RANGE_TABLE_EXISTS_P(p) ((p)[1] & 0x80)
+#define CHARSET_RANGE_TABLE_EXISTS_P(p) (((p)[1] & 0x80) != 0)
/* Return the address of range table of charset P. But not the start
of table itself, but the before where the number of ranges is
- stored. `2 +' means to skip re_opcode_t and size of bitmap,
+ stored. '2 +' means to skip re_opcode_t and size of bitmap,
and the 2 bytes of flags at the start of the range table. */
#define CHARSET_RANGE_TABLE(p) (&(p)[4 + CHARSET_BITMAP_SIZE (p)])
-#ifdef emacs
/* Extract the bit flags that start a range table. */
#define CHARSET_RANGE_TABLE_BITS(p) \
((p)[2 + CHARSET_BITMAP_SIZE (p)] \
+ (p)[3 + CHARSET_BITMAP_SIZE (p)] * 0x100)
-#endif
/* Return the address of end of RANGE_TABLE. COUNT is number of
- ranges (which is a pair of (start, end)) in the RANGE_TABLE. `* 2'
- is start of range and end of range. `* 3' is size of each start
+ ranges (which is a pair of (start, end)) in the RANGE_TABLE. '* 2'
+ is start of range and end of range. '* 3' is size of each start
and end. */
#define CHARSET_RANGE_TABLE_END(range_table, count) \
((range_table) + (count) * 2 * 3)
-/* If DEBUG is defined, Regex prints many voluminous messages about what
- it is doing (if the variable `debug' is nonzero). If linked with the
- main program in `iregex.c', you can enter patterns and strings
- interactively. And if linked with the main program in `main.c' and
- the other test files, you can run the already-written tests. */
+/* If REGEX_EMACS_DEBUG is defined, print many voluminous messages
+ (if the variable regex_emacs_debug is positive). */
-#ifdef DEBUG
+#ifdef REGEX_EMACS_DEBUG
-/* We use standard I/O for debugging. */
+/* Use standard I/O for debugging. */
# include <stdio.h>
-/* It is useful to test things that ``must'' be true when debugging. */
-# include <assert.h>
-
-static int debug = -100000;
+static int regex_emacs_debug = -100000;
# define DEBUG_STATEMENT(e) e
-# define DEBUG_PRINT(...) if (debug > 0) printf (__VA_ARGS__)
+# define DEBUG_PRINT(...) if (regex_emacs_debug > 0) printf (__VA_ARGS__)
# define DEBUG_COMPILES_ARGUMENTS
# define DEBUG_PRINT_COMPILED_PATTERN(p, s, e) \
- if (debug > 0) print_partial_compiled_pattern (s, e)
+ if (regex_emacs_debug > 0) print_partial_compiled_pattern (s, e)
# define DEBUG_PRINT_DOUBLE_STRING(w, s1, sz1, s2, sz2) \
- if (debug > 0) print_double_string (w, s1, sz1, s2, sz2)
+ if (regex_emacs_debug > 0) print_double_string (w, s1, sz1, s2, sz2)
/* Print the fastmap in human-readable form. */
@@ -808,18 +454,18 @@ static int debug = -100000;
static void
print_fastmap (char *fastmap)
{
- unsigned was_a_range = 0;
- unsigned i = 0;
+ bool was_a_range = false;
+ int i = 0;
while (i < (1 << BYTEWIDTH))
{
if (fastmap[i++])
{
- was_a_range = 0;
+ was_a_range = false;
putchar (i - 1);
while (i < (1 << BYTEWIDTH) && fastmap[i])
{
- was_a_range = 1;
+ was_a_range = true;
i++;
}
if (was_a_range)
@@ -893,10 +539,10 @@ print_partial_compiled_pattern (re_char *start, re_char *end)
case charset:
case charset_not:
{
- register int c, last = -100;
- register int in_range = 0;
+ int c, last = -100;
+ bool in_range = false;
int length = CHARSET_BITMAP_SIZE (p - 1);
- int has_range_table = CHARSET_RANGE_TABLE_EXISTS_P (p - 1);
+ bool has_range_table = CHARSET_RANGE_TABLE_EXISTS_P (p - 1);
fprintf (stderr, "/charset [%s",
(re_opcode_t) *(p - 1) == charset_not ? "^" : "");
@@ -912,13 +558,13 @@ print_partial_compiled_pattern (re_char *start, re_char *end)
if (last + 1 == c && ! in_range)
{
fprintf (stderr, "-");
- in_range = 1;
+ in_range = true;
}
/* Have we broken a range? */
else if (last + 1 != c && in_range)
{
fprintf (stderr, "%c", last);
- in_range = 0;
+ in_range = false;
}
if (! in_range)
@@ -1046,7 +692,6 @@ print_partial_compiled_pattern (re_char *start, re_char *end)
fprintf (stderr, "/%d", mcnt);
break;
-# ifdef emacs
case at_dot:
fprintf (stderr, "/at_dot");
break;
@@ -1062,7 +707,6 @@ print_partial_compiled_pattern (re_char *start, re_char *end)
mcnt = *p++;
fprintf (stderr, "/%d", mcnt);
break;
-# endif /* emacs */
case begbuf:
fprintf (stderr, "/begbuf");
@@ -1089,7 +733,7 @@ print_compiled_pattern (struct re_pattern_buffer *bufp)
re_char *buffer = bufp->buffer;
print_partial_compiled_pattern (buffer, buffer + bufp->used);
- printf ("%ld bytes used/%ld bytes allocated.\n",
+ printf ("%tu bytes used/%tu bytes allocated.\n",
bufp->used, bufp->allocated);
if (bufp->fastmap_accurate && bufp->fastmap)
@@ -1098,179 +742,131 @@ print_compiled_pattern (struct re_pattern_buffer *bufp)
print_fastmap (bufp->fastmap);
}
- printf ("re_nsub: %zu\t", bufp->re_nsub);
+ printf ("re_nsub: %tu\t", bufp->re_nsub);
printf ("regs_alloc: %d\t", bufp->regs_allocated);
printf ("can_be_null: %d\t", bufp->can_be_null);
- printf ("no_sub: %d\t", bufp->no_sub);
- printf ("not_bol: %d\t", bufp->not_bol);
- printf ("not_eol: %d\t", bufp->not_eol);
-#ifndef emacs
- printf ("syntax: %lx\n", bufp->syntax);
-#endif
fflush (stdout);
/* Perhaps we should print the translate table? */
}
static void
-print_double_string (re_char *where, re_char *string1, ssize_t size1,
- re_char *string2, ssize_t size2)
+print_double_string (re_char *where, re_char *string1, ptrdiff_t size1,
+ re_char *string2, ptrdiff_t size2)
{
- ssize_t this_char;
-
if (where == NULL)
printf ("(null)");
else
{
if (FIRST_STRING_P (where))
{
- for (this_char = where - string1; this_char < size1; this_char++)
- putchar (string1[this_char]);
-
+ fwrite_unlocked (where, 1, string1 + size1 - where, stdout);
where = string2;
}
- for (this_char = where - string2; this_char < size2; this_char++)
- putchar (string2[this_char]);
+ fwrite_unlocked (where, 1, string2 + size2 - where, stdout);
}
}
-#else /* not DEBUG */
-
-# undef assert
-# define assert(e)
+#else /* not REGEX_EMACS_DEBUG */
# define DEBUG_STATEMENT(e)
# define DEBUG_PRINT(...)
# define DEBUG_PRINT_COMPILED_PATTERN(p, s, e)
# define DEBUG_PRINT_DOUBLE_STRING(w, s1, sz1, s2, sz2)
-#endif /* not DEBUG */
+#endif /* not REGEX_EMACS_DEBUG */
-#ifndef emacs
-
-/* Set by `re_set_syntax' to the current regexp syntax to recognize. Can
- also be assigned to arbitrarily: each pattern buffer stores its own
- syntax, so it can be changed between regex compilations. */
-/* This has no initializer because initialized variables in Emacs
- become read-only after dumping. */
-reg_syntax_t re_syntax_options;
-
-
-/* Specify the precise syntax of regexps for compilation. This provides
- for compatibility for various utilities which historically have
- different, incompatible syntaxes.
-
- The argument SYNTAX is a bit mask comprised of the various bits
- defined in regex.h. We return the old syntax. */
-
-reg_syntax_t
-re_set_syntax (reg_syntax_t syntax)
+typedef enum
{
- reg_syntax_t ret = re_syntax_options;
-
- re_syntax_options = syntax;
- return ret;
-}
-WEAK_ALIAS (__re_set_syntax, re_set_syntax)
-
-#endif
-
-/* This table gives an error message for each of the error codes listed
- in regex.h. Obviously the order here has to be same as there.
- POSIX doesn't require that we do anything for REG_NOERROR,
- but why not be nice? */
+ REG_NOERROR = 0, /* Success. */
+ REG_NOMATCH, /* Didn't find a match (for regexec). */
+
+ /* POSIX regcomp return error codes. (In the order listed in the
+ standard.) An older version of this code supported the POSIX
+ API; this version continues to use these names internally. */
+ REG_BADPAT, /* Invalid pattern. */
+ REG_ECOLLATE, /* Not implemented. */
+ REG_ECTYPE, /* Invalid character class name. */
+ REG_EESCAPE, /* Trailing backslash. */
+ REG_ESUBREG, /* Invalid back reference. */
+ REG_EBRACK, /* Unmatched left bracket. */
+ REG_EPAREN, /* Parenthesis imbalance. */
+ REG_EBRACE, /* Unmatched \{. */
+ REG_BADBR, /* Invalid contents of \{\}. */
+ REG_ERANGE, /* Invalid range end. */
+ REG_ESPACE, /* Ran out of memory. */
+ REG_BADRPT, /* No preceding re for repetition op. */
+
+ /* Error codes we've added. */
+ REG_EEND, /* Premature end. */
+ REG_ESIZE, /* Compiled pattern bigger than 2^16 bytes. */
+ REG_ERPAREN, /* Unmatched ) or \); not returned from regcomp. */
+ REG_ERANGEX, /* Range striding over charsets. */
+ REG_ESIZEBR /* n or m too big in \{n,m\} */
+} reg_errcode_t;
static const char *re_error_msgid[] =
{
- gettext_noop ("Success"), /* REG_NOERROR */
- gettext_noop ("No match"), /* REG_NOMATCH */
- gettext_noop ("Invalid regular expression"), /* REG_BADPAT */
- gettext_noop ("Invalid collation character"), /* REG_ECOLLATE */
- gettext_noop ("Invalid character class name"), /* REG_ECTYPE */
- gettext_noop ("Trailing backslash"), /* REG_EESCAPE */
- gettext_noop ("Invalid back reference"), /* REG_ESUBREG */
- gettext_noop ("Unmatched [ or [^"), /* REG_EBRACK */
- gettext_noop ("Unmatched ( or \\("), /* REG_EPAREN */
- gettext_noop ("Unmatched \\{"), /* REG_EBRACE */
- gettext_noop ("Invalid content of \\{\\}"), /* REG_BADBR */
- gettext_noop ("Invalid range end"), /* REG_ERANGE */
- gettext_noop ("Memory exhausted"), /* REG_ESPACE */
- gettext_noop ("Invalid preceding regular expression"), /* REG_BADRPT */
- gettext_noop ("Premature end of regular expression"), /* REG_EEND */
- gettext_noop ("Regular expression too big"), /* REG_ESIZE */
- gettext_noop ("Unmatched ) or \\)"), /* REG_ERPAREN */
- gettext_noop ("Range striding over charsets") /* REG_ERANGEX */
+ [REG_NOERROR] = "Success",
+ [REG_NOMATCH] = "No match",
+ [REG_BADPAT] = "Invalid regular expression",
+ [REG_ECOLLATE] = "Invalid collation character",
+ [REG_ECTYPE] = "Invalid character class name",
+ [REG_EESCAPE] = "Trailing backslash",
+ [REG_ESUBREG] = "Invalid back reference",
+ [REG_EBRACK] = "Unmatched [ or [^",
+ [REG_EPAREN] = "Unmatched ( or \\(",
+ [REG_EBRACE] = "Unmatched \\{",
+ [REG_BADBR] = "Invalid content of \\{\\}",
+ [REG_ERANGE] = "Invalid range end",
+ [REG_ESPACE] = "Memory exhausted",
+ [REG_BADRPT] = "Invalid preceding regular expression",
+ [REG_EEND] = "Premature end of regular expression",
+ [REG_ESIZE] = "Regular expression too big",
+ [REG_ERPAREN] = "Unmatched ) or \\)",
+ [REG_ERANGEX ] = "Range striding over charsets",
+ [REG_ESIZEBR ] = "Invalid content of \\{\\}",
};
-
-/* Whether to allocate memory during matching. */
-
-/* Define MATCH_MAY_ALLOCATE to allow the searching and matching
- functions allocate memory for the failure stack and registers.
- Normally should be defined, because otherwise searching and
- matching routines will have much smaller memory resources at their
- disposal, and therefore might fail to handle complex regexps.
- Therefore undefine MATCH_MAY_ALLOCATE only in the following
- exceptional situations:
-
- . When running on a system where memory is at premium.
- . When alloca cannot be used at all, perhaps due to bugs in
- its implementation, or its being unavailable, or due to a
- very small stack size. This requires to define REGEX_MALLOC
- to use malloc instead, which in turn could lead to memory
- leaks if search is interrupted by a signal. (For these
- reasons, defining REGEX_MALLOC when building Emacs
- automatically undefines MATCH_MAY_ALLOCATE, but outside
- Emacs you may not care about memory leaks.) If you want to
- prevent the memory leaks, undefine MATCH_MAY_ALLOCATE.
- . When code that calls the searching and matching functions
- cannot allow memory allocation, for whatever reasons. */
-
-/* Normally, this is fine. */
-#define MATCH_MAY_ALLOCATE
-
-/* The match routines may not allocate if (1) they would do it with malloc
- and (2) it's not safe for them to use malloc.
- Note that if REL_ALLOC is defined, matching would not use malloc for the
- failure stack, but we would still use it for the register vectors;
- so REL_ALLOC should not affect this. */
-#if defined REGEX_MALLOC && defined emacs
-# undef MATCH_MAY_ALLOCATE
-#endif
+/* For 'regs_allocated'. */
+enum { REGS_UNALLOCATED, REGS_REALLOCATE, REGS_FIXED };
+
+/* If 'regs_allocated' is REGS_UNALLOCATED in the pattern buffer,
+ 're_match_2' returns information about at least this many registers
+ the first time a 'regs' structure is passed. */
+enum { RE_NREGS = 30 };
+/* The searching and matching functions allocate memory for the
+ failure stack and registers. Otherwise searching and matching
+ routines would have much smaller memory resources at their
+ disposal, and therefore might fail to handle complex regexps. */
+
/* Failure stack declarations and macros; both re_compile_fastmap and
re_match_2 use a failure stack. These have to be macros because of
- REGEX_ALLOCATE_STACK. */
+ SAFE_ALLOCA. */
/* Approximate number of failure points for which to initially allocate space
when matching. If this number is exceeded, we allocate more
space, so it is not a hard limit. */
-#ifndef INIT_FAILURE_ALLOC
-# define INIT_FAILURE_ALLOC 20
-#endif
+#define INIT_FAILURE_ALLOC 20
/* Roughly the maximum number of failure points on the stack. Would be
- exactly that if always used TYPICAL_FAILURE_SIZE items each time we failed.
+ exactly that if failure always used TYPICAL_FAILURE_SIZE items.
This is a variable only so users of regex can assign to it; we never
change it ourselves. We always multiply it by TYPICAL_FAILURE_SIZE
before using it, so it should probably be a byte-count instead. */
-# if defined MATCH_MAY_ALLOCATE
/* Note that 4400 was enough to cause a crash on Alpha OSF/1,
whose default stack limit is 2mb. In order for a larger
value to work reliably, you have to try to make it accord
with the process stack limit. */
-size_t emacs_re_max_failures = 40000;
-# else
-size_t emacs_re_max_failures = 4000;
-# endif
+ptrdiff_t emacs_re_max_failures = 40000;
union fail_stack_elt
{
re_char *pointer;
- /* This should be the biggest `int' that's no bigger than a pointer. */
- long integer;
+ intptr_t integer;
};
typedef union fail_stack_elt fail_stack_elt_t;
@@ -1278,53 +874,36 @@ typedef union fail_stack_elt fail_stack_elt_t;
typedef struct
{
fail_stack_elt_t *stack;
- size_t size;
- size_t avail; /* Offset of next open position. */
- size_t frame; /* Offset of the cur constructed frame. */
+ ptrdiff_t size;
+ ptrdiff_t avail; /* Offset of next open position. */
+ ptrdiff_t frame; /* Offset of the cur constructed frame. */
} fail_stack_type;
#define FAIL_STACK_EMPTY() (fail_stack.frame == 0)
-/* Define macros to initialize and free the failure stack.
- Do `return -2' if the alloc fails. */
+/* Define macros to initialize and free the failure stack. */
-#ifdef MATCH_MAY_ALLOCATE
-# define INIT_FAIL_STACK() \
+#define INIT_FAIL_STACK() \
do { \
fail_stack.stack = \
- REGEX_ALLOCATE_STACK (INIT_FAILURE_ALLOC * TYPICAL_FAILURE_SIZE \
- * sizeof (fail_stack_elt_t)); \
- \
- if (fail_stack.stack == NULL) \
- return -2; \
- \
+ SAFE_ALLOCA (INIT_FAILURE_ALLOC * TYPICAL_FAILURE_SIZE \
+ * sizeof (fail_stack_elt_t)); \
fail_stack.size = INIT_FAILURE_ALLOC; \
fail_stack.avail = 0; \
fail_stack.frame = 0; \
- } while (0)
-#else
-# define INIT_FAIL_STACK() \
- do { \
- fail_stack.avail = 0; \
- fail_stack.frame = 0; \
- } while (0)
-
-# define RETALLOC_IF(addr, n, t) \
- if (addr) RETALLOC((addr), (n), t); else (addr) = TALLOC ((n), t)
-#endif
+ } while (false)
/* Double the size of FAIL_STACK, up to a limit
- which allows approximately `emacs_re_max_failures' items.
+ which allows approximately 'emacs_re_max_failures' items.
Return 1 if succeeds, and 0 if either ran out of memory
allocating space for it or it was already too large.
- REGEX_REALLOCATE_STACK requires `destination' be declared. */
+ REGEX_REALLOCATE requires 'destination' be declared. */
-/* Factor to increase the failure stack size by
- when we increase it.
+/* Factor to increase the failure stack size by.
This used to be 2, but 2 was too wasteful
because the old discarded stacks added up to as much space
were as ultimate, maximum-size stack. */
@@ -1334,34 +913,31 @@ typedef struct
(((fail_stack).size >= emacs_re_max_failures * TYPICAL_FAILURE_SIZE) \
? 0 \
: ((fail_stack).stack \
- = REGEX_REALLOCATE_STACK ((fail_stack).stack, \
+ = REGEX_REALLOCATE ((fail_stack).stack, \
(fail_stack).size * sizeof (fail_stack_elt_t), \
min (emacs_re_max_failures * TYPICAL_FAILURE_SIZE, \
((fail_stack).size * FAIL_STACK_GROWTH_FACTOR)) \
* sizeof (fail_stack_elt_t)), \
- \
- (fail_stack).stack == NULL \
- ? 0 \
- : ((fail_stack).size \
- = (min (emacs_re_max_failures * TYPICAL_FAILURE_SIZE, \
- ((fail_stack).size * FAIL_STACK_GROWTH_FACTOR))), \
- 1)))
+ ((fail_stack).size \
+ = (min (emacs_re_max_failures * TYPICAL_FAILURE_SIZE, \
+ ((fail_stack).size * FAIL_STACK_GROWTH_FACTOR)))), \
+ 1))
/* Push a pointer value onto the failure stack.
- Assumes the variable `fail_stack'. Probably should only
- be called from within `PUSH_FAILURE_POINT'. */
+ Assumes the variable 'fail_stack'. Probably should only
+ be called from within 'PUSH_FAILURE_POINT'. */
#define PUSH_FAILURE_POINTER(item) \
fail_stack.stack[fail_stack.avail++].pointer = (item)
/* This pushes an integer-valued item onto the failure stack.
- Assumes the variable `fail_stack'. Probably should only
- be called from within `PUSH_FAILURE_POINT'. */
+ Assumes the variable 'fail_stack'. Probably should only
+ be called from within 'PUSH_FAILURE_POINT'. */
#define PUSH_FAILURE_INT(item) \
fail_stack.stack[fail_stack.avail++].integer = (item)
/* These POP... operations complement the PUSH... operations.
- All assume that `fail_stack' is nonempty. */
+ All assume that 'fail_stack' is nonempty. */
#define POP_FAILURE_POINTER() fail_stack.stack[--fail_stack.avail].pointer
#define POP_FAILURE_INT() fail_stack.stack[--fail_stack.avail].integer
@@ -1379,22 +955,22 @@ typedef struct
while (REMAINING_AVAIL_SLOTS <= space) { \
if (!GROW_FAIL_STACK (fail_stack)) \
return -2; \
- DEBUG_PRINT ("\n Doubled stack; size now: %zd\n", (fail_stack).size);\
- DEBUG_PRINT (" slots available: %zd\n", REMAINING_AVAIL_SLOTS);\
+ DEBUG_PRINT ("\n Doubled stack; size now: %tu\n", fail_stack.size); \
+ DEBUG_PRINT (" slots available: %tu\n", REMAINING_AVAIL_SLOTS);\
}
/* Push register NUM onto the stack. */
#define PUSH_FAILURE_REG(num) \
do { \
char *destination; \
- long n = num; \
+ intptr_t n = num; \
ENSURE_FAIL_STACK(3); \
- DEBUG_PRINT (" Push reg %ld (spanning %p -> %p)\n", \
+ DEBUG_PRINT (" Push reg %"PRIdPTR" (spanning %p -> %p)\n", \
n, regstart[n], regend[n]); \
PUSH_FAILURE_POINTER (regstart[n]); \
PUSH_FAILURE_POINTER (regend[n]); \
PUSH_FAILURE_INT (n); \
-} while (0)
+} while (false)
/* Change the counter's value to VAL, but make sure that it will
be reset when backtracking. */
@@ -1409,20 +985,20 @@ do { \
PUSH_FAILURE_POINTER (ptr); \
PUSH_FAILURE_INT (-1); \
STORE_NUMBER (ptr, val); \
-} while (0)
+} while (false)
/* Pop a saved register off the stack. */
#define POP_FAILURE_REG_OR_COUNT() \
do { \
- long pfreg = POP_FAILURE_INT (); \
+ intptr_t pfreg = POP_FAILURE_INT (); \
if (pfreg == -1) \
{ \
/* It's a counter. */ \
- /* Here, we discard `const', making re_match non-reentrant. */ \
+ /* Discard 'const', making re_search non-reentrant. */ \
unsigned char *ptr = (unsigned char *) POP_FAILURE_POINTER (); \
pfreg = POP_FAILURE_INT (); \
STORE_NUMBER (ptr, pfreg); \
- DEBUG_PRINT (" Pop counter %p = %ld\n", ptr, pfreg); \
+ DEBUG_PRINT (" Pop counter %p = %"PRIdPTR"\n", ptr, pfreg); \
} \
else \
{ \
@@ -1431,69 +1007,66 @@ do { \
DEBUG_PRINT (" Pop reg %ld (spanning %p -> %p)\n", \
pfreg, regstart[pfreg], regend[pfreg]); \
} \
-} while (0)
+} while (false)
/* Check that we are not stuck in an infinite loop. */
#define CHECK_INFINITE_LOOP(pat_cur, string_place) \
do { \
- ssize_t failure = TOP_FAILURE_HANDLE (); \
+ ptrdiff_t failure = TOP_FAILURE_HANDLE (); \
/* Check for infinite matching loops */ \
while (failure > 0 \
&& (FAILURE_STR (failure) == string_place \
|| FAILURE_STR (failure) == NULL)) \
{ \
- assert (FAILURE_PAT (failure) >= bufp->buffer \
- && FAILURE_PAT (failure) <= bufp->buffer + bufp->used); \
+ eassert (FAILURE_PAT (failure) >= bufp->buffer \
+ && FAILURE_PAT (failure) <= bufp->buffer + bufp->used); \
if (FAILURE_PAT (failure) == pat_cur) \
{ \
- cycle = 1; \
+ cycle = true; \
break; \
} \
DEBUG_PRINT (" Other pattern: %p\n", FAILURE_PAT (failure)); \
failure = NEXT_FAILURE_HANDLE(failure); \
} \
DEBUG_PRINT (" Other string: %p\n", FAILURE_STR (failure)); \
-} while (0)
+} while (false)
/* Push the information about the state we will need
if we ever fail back to it.
Requires variables fail_stack, regstart, regend and
- num_regs be declared. GROW_FAIL_STACK requires `destination' be
+ num_regs be declared. GROW_FAIL_STACK requires 'destination' be
declared.
- Does `return FAILURE_CODE' if runs out of memory. */
+ Does 'return FAILURE_CODE' if runs out of memory. */
#define PUSH_FAILURE_POINT(pattern, string_place) \
do { \
char *destination; \
- /* Must be int, so when we don't save any registers, the arithmetic \
- of 0 + -1 isn't done as unsigned. */ \
- \
DEBUG_STATEMENT (nfailure_points_pushed++); \
DEBUG_PRINT ("\nPUSH_FAILURE_POINT:\n"); \
- DEBUG_PRINT (" Before push, next avail: %zd\n", (fail_stack).avail); \
- DEBUG_PRINT (" size: %zd\n", (fail_stack).size);\
- \
+ DEBUG_PRINT (" Before push, next avail: %tu\n", fail_stack.avail); \
+ DEBUG_PRINT (" size: %tu\n", fail_stack.size); \
+ \
ENSURE_FAIL_STACK (NUM_NONREG_ITEMS); \
- \
+ \
DEBUG_PRINT ("\n"); \
- \
- DEBUG_PRINT (" Push frame index: %zd\n", fail_stack.frame); \
+ \
+ DEBUG_PRINT (" Push frame index: %tu\n", fail_stack.frame); \
PUSH_FAILURE_INT (fail_stack.frame); \
- \
+ \
DEBUG_PRINT (" Push string %p: \"", string_place); \
DEBUG_PRINT_DOUBLE_STRING (string_place, string1, size1, string2, size2);\
DEBUG_PRINT ("\"\n"); \
PUSH_FAILURE_POINTER (string_place); \
- \
+ \
DEBUG_PRINT (" Push pattern %p: ", pattern); \
DEBUG_PRINT_COMPILED_PATTERN (bufp, pattern, pend); \
PUSH_FAILURE_POINTER (pattern); \
- \
+ \
/* Close the frame by moving the frame pointer past it. */ \
fail_stack.frame = fail_stack.avail; \
-} while (0)
+} while (false)
/* Estimate the size of data pushed by a typical failure stack entry.
An estimate is all we need, because all we use this for
@@ -1505,24 +1078,24 @@ do { \
#define REMAINING_AVAIL_SLOTS ((fail_stack).size - (fail_stack).avail)
-/* Pops what PUSH_FAIL_STACK pushes.
+/* Pop what PUSH_FAIL_STACK pushes.
- We restore into the parameters, all of which should be lvalues:
+ Restore into the parameters, all of which should be lvalues:
STR -- the saved data position.
PAT -- the saved pattern position.
REGSTART, REGEND -- arrays of string positions.
- Also assumes the variables `fail_stack' and (if debugging), `bufp',
- `pend', `string1', `size1', `string2', and `size2'. */
+ Also assume the variables FAIL_STACK and (if debugging) BUFP, PEND,
+ STRING1, SIZE1, STRING2, and SIZE2. */
#define POP_FAILURE_POINT(str, pat) \
do { \
- assert (!FAIL_STACK_EMPTY ()); \
+ eassert (!FAIL_STACK_EMPTY ()); \
\
/* Remove failure points and point to how many regs pushed. */ \
DEBUG_PRINT ("POP_FAILURE_POINT:\n"); \
- DEBUG_PRINT (" Before pop, next avail: %zd\n", fail_stack.avail); \
- DEBUG_PRINT (" size: %zd\n", fail_stack.size); \
+ DEBUG_PRINT (" Before pop, next avail: %tu\n", fail_stack.avail); \
+ DEBUG_PRINT (" size: %tu\n", fail_stack.size); \
\
/* Pop the saved registers. */ \
while (fail_stack.frame < fail_stack.avail) \
@@ -1541,13 +1114,13 @@ do { \
DEBUG_PRINT ("\"\n"); \
\
fail_stack.frame = POP_FAILURE_INT (); \
- DEBUG_PRINT (" Popping frame index: %zd\n", fail_stack.frame); \
+ DEBUG_PRINT (" Popping frame index: %zu\n", fail_stack.frame); \
\
- assert (fail_stack.avail >= 0); \
- assert (fail_stack.frame <= fail_stack.avail); \
+ eassert (fail_stack.avail >= 0); \
+ eassert (fail_stack.frame <= fail_stack.avail); \
\
DEBUG_STATEMENT (nfailure_points_popped++); \
-} while (0) /* POP_FAILURE_POINT */
+} while (false) /* POP_FAILURE_POINT */
@@ -1556,13 +1129,9 @@ do { \
/* Subroutine declarations and macros for regex_compile. */
-static reg_errcode_t regex_compile (re_char *pattern, size_t size,
-#ifdef emacs
+static reg_errcode_t regex_compile (re_char *pattern, ptrdiff_t size,
bool posix_backtracking,
const char *whitespace_regexp,
-#else
- reg_syntax_t syntax,
-#endif
struct re_pattern_buffer *bufp);
static void store_op1 (re_opcode_t op, unsigned char *loc, int arg);
static void store_op2 (re_opcode_t op, unsigned char *loc, int arg1, int arg2);
@@ -1570,13 +1139,11 @@ static void insert_op1 (re_opcode_t op, unsigned char *loc,
int arg, unsigned char *end);
static void insert_op2 (re_opcode_t op, unsigned char *loc,
int arg1, int arg2, unsigned char *end);
-static boolean at_begline_loc_p (re_char *pattern, re_char *p,
- reg_syntax_t syntax);
-static boolean at_endline_loc_p (re_char *p, re_char *pend,
- reg_syntax_t syntax);
+static bool at_begline_loc_p (re_char *pattern, re_char *p);
+static bool at_endline_loc_p (re_char *p, re_char *pend);
static re_char *skip_one_char (re_char *p);
static int analyze_first (re_char *p, re_char *pend,
- char *fastmap, const int multibyte);
+ char *fastmap, bool multibyte);
/* Fetch the next character in the uncompiled pattern, with no
translation. */
@@ -1586,35 +1153,28 @@ static int analyze_first (re_char *p, re_char *pend,
if (p == pend) return REG_EEND; \
c = RE_STRING_CHAR_AND_LENGTH (p, len, multibyte); \
p += len; \
- } while (0)
-
+ } while (false)
-/* If `translate' is non-null, return translate[D], else just D. We
- cast the subscript to translate because some data is declared as
- `char *', to avoid warnings when a string constant is passed. But
- when we use a character as a subscript we must make it unsigned. */
-#ifndef TRANSLATE
-# define TRANSLATE(d) \
- (RE_TRANSLATE_P (translate) ? RE_TRANSLATE (translate, (d)) : (d))
-#endif
+#define RE_TRANSLATE(TBL, C) char_table_translate (TBL, C)
+#define TRANSLATE(d) (!NILP (translate) ? RE_TRANSLATE (translate, d) : (d))
-/* Macros for outputting the compiled pattern into `buffer'. */
+/* Macros for outputting the compiled pattern into 'buffer'. */
/* If the buffer isn't allocated when it comes in, use this. */
#define INIT_BUF_SIZE 32
-/* Make sure we have at least N more bytes of space in buffer. */
+/* Ensure at least N more bytes of space in buffer. */
#define GET_BUFFER_SPACE(n) \
- while ((size_t) (b - bufp->buffer + (n)) > bufp->allocated) \
- EXTEND_BUFFER ()
+ if (bufp->buffer + bufp->allocated - b < (n)) \
+ EXTEND_BUFFER ((n) - (bufp->buffer + bufp->allocated - b))
-/* Make sure we have one more byte of buffer space and then add C to it. */
+/* Ensure one more byte of buffer space and then add C to it. */
#define BUF_PUSH(c) \
do { \
GET_BUFFER_SPACE (1); \
*b++ = (unsigned char) (c); \
- } while (0)
+ } while (false)
/* Ensure we have two more bytes of buffer space and then append C1 and C2. */
@@ -1623,10 +1183,10 @@ static int analyze_first (re_char *p, re_char *pend,
GET_BUFFER_SPACE (2); \
*b++ = (unsigned char) (c1); \
*b++ = (unsigned char) (c2); \
- } while (0)
+ } while (false)
-/* Store a jump with opcode OP at LOC to location TO. We store a
+/* Store a jump with opcode OP at LOC to location TO. Store a
relative address offset by the three bytes the jump itself occupies. */
#define STORE_JUMP(op, loc, to) \
store_op1 (op, loc, (to) - (loc) - 3)
@@ -1635,11 +1195,11 @@ static int analyze_first (re_char *p, re_char *pend,
#define STORE_JUMP2(op, loc, to, arg) \
store_op2 (op, loc, (to) - (loc) - 3, arg)
-/* Like `STORE_JUMP', but for inserting. Assume `b' is the buffer end. */
+/* Like 'STORE_JUMP', but for inserting. Assume B is the buffer end. */
#define INSERT_JUMP(op, loc, to) \
insert_op1 (op, loc, (to) - (loc) - 3, b)
-/* Like `STORE_JUMP2', but for inserting. Assume `b' is the buffer end. */
+/* Like 'STORE_JUMP2', but for inserting. Assume B is the buffer end. */
#define INSERT_JUMP2(op, loc, to, arg) \
insert_op2 (op, loc, (to) - (loc) - 3, arg, b)
@@ -1647,20 +1207,18 @@ static int analyze_first (re_char *p, re_char *pend,
/* This is not an arbitrary limit: the arguments which represent offsets
into the pattern are two bytes long. So if 2^15 bytes turns out to
be too small, many things would have to change. */
-# define MAX_BUF_SIZE (1L << 15)
+# define MAX_BUF_SIZE (1 << 15)
-/* Extend the buffer by twice its current size via realloc and
+/* Extend the buffer by at least N bytes via realloc and
reset the pointers that pointed into the old block to point to the
correct places in the new one. If extending the buffer results in it
being larger than MAX_BUF_SIZE, then flag memory exhausted. */
-#define EXTEND_BUFFER() \
+#define EXTEND_BUFFER(n) \
do { \
+ ptrdiff_t requested_extension = n; \
unsigned char *old_buffer = bufp->buffer; \
- if (bufp->allocated == MAX_BUF_SIZE) \
+ if (MAX_BUF_SIZE - bufp->allocated < requested_extension) \
return REG_ESIZE; \
- bufp->allocated <<= 1; \
- if (bufp->allocated > MAX_BUF_SIZE) \
- bufp->allocated = MAX_BUF_SIZE; \
ptrdiff_t b_off = b - old_buffer; \
ptrdiff_t begalt_off = begalt - old_buffer; \
bool fixup_alt_jump_set = !!fixup_alt_jump; \
@@ -1670,16 +1228,15 @@ static int analyze_first (re_char *p, re_char *pend,
if (fixup_alt_jump_set) fixup_alt_jump_off = fixup_alt_jump - old_buffer; \
if (laststart_set) laststart_off = laststart - old_buffer; \
if (pending_exact_set) pending_exact_off = pending_exact - old_buffer; \
- RETALLOC (bufp->buffer, bufp->allocated, unsigned char); \
- if (bufp->buffer == NULL) \
- return REG_ESPACE; \
+ bufp->buffer = xpalloc (bufp->buffer, &bufp->allocated, \
+ requested_extension, MAX_BUF_SIZE, 1); \
unsigned char *new_buffer = bufp->buffer; \
b = new_buffer + b_off; \
begalt = new_buffer + begalt_off; \
if (fixup_alt_jump_set) fixup_alt_jump = new_buffer + fixup_alt_jump_off; \
if (laststart_set) laststart = new_buffer + laststart_off; \
if (pending_exact_set) pending_exact = new_buffer + pending_exact_off; \
- } while (0)
+ } while (false)
/* Since we have one byte reserved for the register number argument to
@@ -1687,17 +1244,15 @@ static int analyze_first (re_char *p, re_char *pend,
things about is what fits in that byte. */
#define MAX_REGNUM 255
-/* But patterns can have more than `MAX_REGNUM' registers. We just
+/* But patterns can have more than 'MAX_REGNUM' registers. Just
ignore the excess. */
typedef int regnum_t;
/* Macros for the compile stack. */
-/* Since offsets can go either forwards or backwards, this type needs to
- be able to hold values from -(MAX_BUF_SIZE - 1) to MAX_BUF_SIZE - 1. */
-/* int may be not enough when sizeof(int) == 2. */
typedef long pattern_offset_t;
+verify (LONG_MIN <= -(MAX_BUF_SIZE - 1) && MAX_BUF_SIZE - 1 <= LONG_MAX);
typedef struct
{
@@ -1711,8 +1266,8 @@ typedef struct
typedef struct
{
compile_stack_elt_t *stack;
- size_t size;
- size_t avail; /* Offset of next open position. */
+ ptrdiff_t size;
+ ptrdiff_t avail; /* Offset of next open position. */
} compile_stack_type;
@@ -1723,12 +1278,6 @@ typedef struct
/* The next available element. */
#define COMPILE_STACK_TOP (compile_stack.stack[compile_stack.avail])
-
-/* Explicit quit checking is needed for Emacs, which uses polling to
- process input events. */
-#ifndef emacs
-static void maybe_quit (void) {}
-#endif
/* Structure to manage work area for range table. */
struct range_table_work_area
@@ -1739,11 +1288,7 @@ struct range_table_work_area
int bits; /* flag to record character classes */
};
-#ifdef emacs
-
-/* Make sure that WORK_AREA can hold more N multibyte characters.
- This is used only in set_image_of_range and set_image_of_range_1.
- It expects WORK_AREA to be a pointer.
+/* Make sure that WORK_AREA can hold N more multibyte characters.
If it can't get the space, it returns from the surrounding function. */
#define EXTEND_RANGE_TABLE(work_area, n) \
@@ -1754,7 +1299,7 @@ struct range_table_work_area
if ((work_area).table == 0) \
return (REG_ESPACE); \
} \
- } while (0)
+ } while (false)
#define SET_RANGE_TABLE_WORK_AREA_BIT(work_area, bit) \
(work_area).bits |= (bit)
@@ -1765,18 +1310,17 @@ struct range_table_work_area
EXTEND_RANGE_TABLE ((work_area), 2); \
(work_area).table[(work_area).used++] = (range_start); \
(work_area).table[(work_area).used++] = (range_end); \
- } while (0)
-
-#endif /* emacs */
+ } while (false)
/* Free allocated memory for WORK_AREA. */
#define FREE_RANGE_TABLE_WORK_AREA(work_area) \
do { \
if ((work_area).table) \
- free ((work_area).table); \
- } while (0)
+ xfree ((work_area).table); \
+ } while (false)
-#define CLEAR_RANGE_TABLE_WORK_USED(work_area) ((work_area).used = 0, (work_area).bits = 0)
+#define CLEAR_RANGE_TABLE_WORK_USED(work_area) \
+ ((work_area).used = 0, (work_area).bits = 0)
#define RANGE_TABLE_WORK_USED(work_area) ((work_area).used)
#define RANGE_TABLE_WORK_BITS(work_area) ((work_area).bits)
#define RANGE_TABLE_WORK_ELT(work_area, i) ((work_area).table[i])
@@ -1801,8 +1345,6 @@ struct range_table_work_area
#define SET_LIST_BIT(c) (b[((c)) / BYTEWIDTH] |= 1 << ((c) % BYTEWIDTH))
-#ifdef emacs
-
/* Store characters in the range FROM to TO in the bitmap at B (for
ASCII and unibyte characters) and WORK_AREA (for multibyte
characters) while translating them and paying attention to the
@@ -1817,7 +1359,7 @@ struct range_table_work_area
#define SETUP_ASCII_RANGE(work_area, FROM, TO) \
do { \
int C0, C1; \
- \
+ \
for (C0 = (FROM); C0 <= (TO); C0++) \
{ \
C1 = TRANSLATE (C0); \
@@ -1829,7 +1371,7 @@ struct range_table_work_area
} \
SET_LIST_BIT (C1); \
} \
- } while (0)
+ } while (false)
/* Both FROM and TO are unibyte characters (0x80..0xFF). */
@@ -1838,7 +1380,7 @@ struct range_table_work_area
do { \
int C0, C1, C2, I; \
int USED = RANGE_TABLE_WORK_USED (work_area); \
- \
+ \
for (C0 = (FROM); C0 <= (TO); C0++) \
{ \
C1 = RE_CHAR_TO_MULTIBYTE (C0); \
@@ -1869,7 +1411,7 @@ struct range_table_work_area
SET_RANGE_TABLE_WORK_AREA ((work_area), C2, C2); \
} \
} \
- } while (0)
+ } while (false)
/* Both FROM and TO are multibyte characters. */
@@ -1877,7 +1419,7 @@ struct range_table_work_area
#define SETUP_MULTIBYTE_RANGE(work_area, FROM, TO) \
do { \
int C0, C1, C2, I, USED = RANGE_TABLE_WORK_USED (work_area); \
- \
+ \
SET_RANGE_TABLE_WORK_AREA ((work_area), (FROM), (TO)); \
for (C0 = (FROM); C0 <= (TO); C0++) \
{ \
@@ -1891,7 +1433,7 @@ struct range_table_work_area
{ \
int from = RANGE_TABLE_WORK_ELT (work_area, I); \
int to = RANGE_TABLE_WORK_ELT (work_area, I + 1); \
- \
+ \
if (C1 >= from - 1 && C1 <= to + 1) \
{ \
if (C1 == from - 1) \
@@ -1904,9 +1446,7 @@ struct range_table_work_area
if (I < USED) \
SET_RANGE_TABLE_WORK_AREA ((work_area), C1, C1); \
} \
- } while (0)
-
-#endif /* emacs */
+ } while (false)
/* Get the next unsigned number in the uncompiled pattern. */
#define GET_INTERVAL_COUNT(num) \
@@ -1921,17 +1461,15 @@ struct range_table_work_area
if (num < 0) \
num = 0; \
if (RE_DUP_MAX / 10 - (RE_DUP_MAX % 10 < c - '0') < num) \
- FREE_STACK_RETURN (REG_BADBR); \
+ FREE_STACK_RETURN (REG_ESIZEBR); \
num = num * 10 + c - '0'; \
if (p == pend) \
FREE_STACK_RETURN (REG_EBRACE); \
PATFETCH (c); \
} \
} \
- } while (0)
+ } while (false)
-#if ! WIDE_CHAR_SUPPORT
-
/* Parse a character class, i.e. string such as "[:name:]". *strp
points to the string to be parsed and limit is length, in bytes, of
that string.
@@ -1947,7 +1485,7 @@ struct range_table_work_area
The function can be used on ASCII and multibyte (UTF-8-encoded) strings.
*/
re_wctype_t
-re_wctype_parse (const unsigned char **strp, unsigned limit)
+re_wctype_parse (const unsigned char **strp, ptrdiff_t limit)
{
const char *beg = (const char *)*strp, *it;
@@ -2025,7 +1563,7 @@ re_wctype_parse (const unsigned char **strp, unsigned limit)
}
/* True if CH is in the char class CC. */
-boolean
+bool
re_iswctype (int ch, re_wctype_t cc)
{
switch (cc)
@@ -2078,7 +1616,6 @@ re_wctype_to_bit (re_wctype_t cc)
abort ();
}
}
-#endif
/* Filling in the work area of a range. */
@@ -2088,357 +1625,75 @@ static void
extend_range_table_work_area (struct range_table_work_area *work_area)
{
work_area->allocated += 16 * sizeof (int);
- work_area->table = realloc (work_area->table, work_area->allocated);
-}
-
-#if 0
-#ifdef emacs
-
-/* Carefully find the ranges of codes that are equivalent
- under case conversion to the range start..end when passed through
- TRANSLATE. Handle the case where non-letters can come in between
- two upper-case letters (which happens in Latin-1).
- Also handle the case of groups of more than 2 case-equivalent chars.
-
- The basic method is to look at consecutive characters and see
- if they can form a run that can be handled as one.
-
- Returns -1 if successful, REG_ESPACE if ran out of space. */
-
-static int
-set_image_of_range_1 (struct range_table_work_area *work_area,
- re_wchar_t start, re_wchar_t end,
- RE_TRANSLATE_TYPE translate)
-{
- /* `one_case' indicates a character, or a run of characters,
- each of which is an isolate (no case-equivalents).
- This includes all ASCII non-letters.
-
- `two_case' indicates a character, or a run of characters,
- each of which has two case-equivalent forms.
- This includes all ASCII letters.
-
- `strange' indicates a character that has more than one
- case-equivalent. */
-
- enum case_type {one_case, two_case, strange};
-
- /* Describe the run that is in progress,
- which the next character can try to extend.
- If run_type is strange, that means there really is no run.
- If run_type is one_case, then run_start...run_end is the run.
- If run_type is two_case, then the run is run_start...run_end,
- and the case-equivalents end at run_eqv_end. */
-
- enum case_type run_type = strange;
- int run_start, run_end, run_eqv_end;
-
- Lisp_Object eqv_table;
-
- if (!RE_TRANSLATE_P (translate))
- {
- EXTEND_RANGE_TABLE (work_area, 2);
- work_area->table[work_area->used++] = (start);
- work_area->table[work_area->used++] = (end);
- return -1;
- }
-
- eqv_table = XCHAR_TABLE (translate)->extras[2];
-
- for (; start <= end; start++)
- {
- enum case_type this_type;
- int eqv = RE_TRANSLATE (eqv_table, start);
- int minchar, maxchar;
-
- /* Classify this character */
- if (eqv == start)
- this_type = one_case;
- else if (RE_TRANSLATE (eqv_table, eqv) == start)
- this_type = two_case;
- else
- this_type = strange;
-
- if (start < eqv)
- minchar = start, maxchar = eqv;
- else
- minchar = eqv, maxchar = start;
-
- /* Can this character extend the run in progress? */
- if (this_type == strange || this_type != run_type
- || !(minchar == run_end + 1
- && (run_type == two_case
- ? maxchar == run_eqv_end + 1 : 1)))
- {
- /* No, end the run.
- Record each of its equivalent ranges. */
- if (run_type == one_case)
- {
- EXTEND_RANGE_TABLE (work_area, 2);
- work_area->table[work_area->used++] = run_start;
- work_area->table[work_area->used++] = run_end;
- }
- else if (run_type == two_case)
- {
- EXTEND_RANGE_TABLE (work_area, 4);
- work_area->table[work_area->used++] = run_start;
- work_area->table[work_area->used++] = run_end;
- work_area->table[work_area->used++]
- = RE_TRANSLATE (eqv_table, run_start);
- work_area->table[work_area->used++]
- = RE_TRANSLATE (eqv_table, run_end);
- }
- run_type = strange;
- }
-
- if (this_type == strange)
- {
- /* For a strange character, add each of its equivalents, one
- by one. Don't start a range. */
- do
- {
- EXTEND_RANGE_TABLE (work_area, 2);
- work_area->table[work_area->used++] = eqv;
- work_area->table[work_area->used++] = eqv;
- eqv = RE_TRANSLATE (eqv_table, eqv);
- }
- while (eqv != start);
- }
-
- /* Add this char to the run, or start a new run. */
- else if (run_type == strange)
- {
- /* Initialize a new range. */
- run_type = this_type;
- run_start = start;
- run_end = start;
- run_eqv_end = RE_TRANSLATE (eqv_table, run_end);
- }
- else
- {
- /* Extend a running range. */
- run_end = minchar;
- run_eqv_end = RE_TRANSLATE (eqv_table, run_end);
- }
- }
-
- /* If a run is still in progress at the end, finish it now
- by recording its equivalent ranges. */
- if (run_type == one_case)
- {
- EXTEND_RANGE_TABLE (work_area, 2);
- work_area->table[work_area->used++] = run_start;
- work_area->table[work_area->used++] = run_end;
- }
- else if (run_type == two_case)
- {
- EXTEND_RANGE_TABLE (work_area, 4);
- work_area->table[work_area->used++] = run_start;
- work_area->table[work_area->used++] = run_end;
- work_area->table[work_area->used++]
- = RE_TRANSLATE (eqv_table, run_start);
- work_area->table[work_area->used++]
- = RE_TRANSLATE (eqv_table, run_end);
- }
-
- return -1;
+ work_area->table = xrealloc (work_area->table, work_area->allocated);
}
-
-#endif /* emacs */
-
-/* Record the image of the range start..end when passed through
- TRANSLATE. This is not necessarily TRANSLATE(start)..TRANSLATE(end)
- and is not even necessarily contiguous.
- Normally we approximate it with the smallest contiguous range that contains
- all the chars we need. However, for Latin-1 we go to extra effort
- to do a better job.
-
- This function is not called for ASCII ranges.
-
- Returns -1 if successful, REG_ESPACE if ran out of space. */
-
-static int
-set_image_of_range (struct range_table_work_area *work_area,
- re_wchar_t start, re_wchar_t end,
- RE_TRANSLATE_TYPE translate)
-{
- re_wchar_t cmin, cmax;
-
-#ifdef emacs
- /* For Latin-1 ranges, use set_image_of_range_1
- to get proper handling of ranges that include letters and nonletters.
- For a range that includes the whole of Latin-1, this is not necessary.
- For other character sets, we don't bother to get this right. */
- if (RE_TRANSLATE_P (translate) && start < 04400
- && !(start < 04200 && end >= 04377))
- {
- int newend;
- int tem;
- newend = end;
- if (newend > 04377)
- newend = 04377;
- tem = set_image_of_range_1 (work_area, start, newend, translate);
- if (tem > 0)
- return tem;
-
- start = 04400;
- if (end < 04400)
- return -1;
- }
-#endif
-
- EXTEND_RANGE_TABLE (work_area, 2);
- work_area->table[work_area->used++] = (start);
- work_area->table[work_area->used++] = (end);
-
- cmin = -1, cmax = -1;
-
- if (RE_TRANSLATE_P (translate))
- {
- int ch;
-
- for (ch = start; ch <= end; ch++)
- {
- re_wchar_t c = TRANSLATE (ch);
- if (! (start <= c && c <= end))
- {
- if (cmin == -1)
- cmin = c, cmax = c;
- else
- {
- cmin = min (cmin, c);
- cmax = max (cmax, c);
- }
- }
- }
-
- if (cmin != -1)
- {
- EXTEND_RANGE_TABLE (work_area, 2);
- work_area->table[work_area->used++] = (cmin);
- work_area->table[work_area->used++] = (cmax);
- }
- }
-
- return -1;
-}
-#endif /* 0 */
-#ifndef MATCH_MAY_ALLOCATE
-
-/* If we cannot allocate large objects within re_match_2_internal,
- we make the fail stack and register vectors global.
- The fail stack, we grow to the maximum size when a regexp
- is compiled.
- The register vectors, we adjust in size each time we
- compile a regexp, according to the number of registers it needs. */
+/* regex_compile and helpers. */
-static fail_stack_type fail_stack;
+static bool group_in_compile_stack (compile_stack_type, regnum_t);
-/* Size with which the following vectors are currently allocated.
- That is so we can make them bigger as needed,
- but never make them smaller. */
-static int regs_allocated_size;
-
-static re_char ** regstart, ** regend;
-static re_char **best_regstart, **best_regend;
-
-/* Make the register vectors big enough for NUM_REGS registers,
- but don't make them smaller. */
-
-static
-regex_grow_registers (int num_regs)
-{
- if (num_regs > regs_allocated_size)
- {
- RETALLOC_IF (regstart, num_regs, re_char *);
- RETALLOC_IF (regend, num_regs, re_char *);
- RETALLOC_IF (best_regstart, num_regs, re_char *);
- RETALLOC_IF (best_regend, num_regs, re_char *);
-
- regs_allocated_size = num_regs;
- }
-}
-
-#endif /* not MATCH_MAY_ALLOCATE */
-
-static boolean group_in_compile_stack (compile_stack_type compile_stack,
- regnum_t regnum);
-
-/* `regex_compile' compiles PATTERN (of length SIZE) according to SYNTAX.
- Returns one of error codes defined in `regex.h', or zero for success.
-
- If WHITESPACE_REGEXP is given (only #ifdef emacs), it is used instead of
- a space character in PATTERN.
-
- Assumes the `allocated' (and perhaps `buffer') and `translate'
- fields are set in BUFP on entry.
-
- If it succeeds, results are put in BUFP (if it returns an error, the
- contents of BUFP are undefined):
- `buffer' is the compiled pattern;
- `syntax' is set to SYNTAX;
- `used' is set to the length of the compiled pattern;
- `fastmap_accurate' is zero;
- `re_nsub' is the number of subexpressions in PATTERN;
- `not_bol' and `not_eol' are zero;
-
- The `fastmap' field is neither examined nor set. */
-
-/* Insert the `jump' from the end of last alternative to "here".
+/* Insert the 'jump' from the end of last alternative to "here".
The space for the jump has already been allocated. */
#define FIXUP_ALT_JUMP() \
do { \
if (fixup_alt_jump) \
STORE_JUMP (jump, fixup_alt_jump, b); \
-} while (0)
+} while (false)
/* Return, freeing storage we allocated. */
#define FREE_STACK_RETURN(value) \
do { \
FREE_RANGE_TABLE_WORK_AREA (range_table_work); \
- free (compile_stack.stack); \
+ xfree (compile_stack.stack); \
return value; \
- } while (0)
+ } while (false)
+
+/* Compile PATTERN (of length SIZE) according to SYNTAX.
+ Return a nonzero error code on failure, or zero for success.
+
+ If WHITESPACE_REGEXP is given, use it instead of a space
+ character in PATTERN.
+
+ Assume the 'allocated' (and perhaps 'buffer') and 'translate'
+ fields are set in BUFP on entry.
+
+ If successful, put results in *BUFP (otherwise the
+ contents of *BUFP are undefined):
+ 'buffer' is the compiled pattern;
+ 'syntax' is set to SYNTAX;
+ 'used' is set to the length of the compiled pattern;
+ 'fastmap_accurate' is false;
+ 're_nsub' is the number of subexpressions in PATTERN;
+
+ The 'fastmap' field is neither examined nor set. */
static reg_errcode_t
-regex_compile (const_re_char *pattern, size_t size,
-#ifdef emacs
-# define syntax RE_SYNTAX_EMACS
+regex_compile (re_char *pattern, ptrdiff_t size,
bool posix_backtracking,
const char *whitespace_regexp,
-#else
- reg_syntax_t syntax,
-# define posix_backtracking (!(syntax & RE_NO_POSIX_BACKTRACKING))
-#endif
struct re_pattern_buffer *bufp)
{
- /* We fetch characters from PATTERN here. */
- register re_wchar_t c, c1;
+ /* Fetch characters from PATTERN here. */
+ int c, c1;
/* Points to the end of the buffer, where we should append. */
- register unsigned char *b;
+ unsigned char *b;
/* Keeps track of unclosed groups. */
compile_stack_type compile_stack;
/* Points to the current (ending) position in the pattern. */
-#ifdef AIX
- /* `const' makes AIX compiler fail. */
- unsigned char *p = pattern;
-#else
re_char *p = pattern;
-#endif
re_char *pend = pattern + size;
/* How to translate the characters in the pattern. */
- RE_TRANSLATE_TYPE translate = bufp->translate;
+ Lisp_Object translate = bufp->translate;
- /* Address of the count-byte of the most recently inserted `exactn'
+ /* Address of the count-byte of the most recently inserted 'exactn'
command. This makes it possible to tell if a new exact-match
character can be added to that command or if the character requires
- a new `exactn' command. */
+ a new 'exactn' command. */
unsigned char *pending_exact = 0;
/* Address of start of the most recently finished expression.
@@ -2454,17 +1709,16 @@ regex_compile (const_re_char *pattern, size_t size,
re_char *beg_interval;
/* Address of the place where a forward jump should go to the end of
- the containing expression. Each alternative of an `or' -- except the
+ the containing expression. Each alternative of an 'or' -- except the
last -- ends with a forward jump of this sort. */
unsigned char *fixup_alt_jump = 0;
/* Work area for range table of charset. */
struct range_table_work_area range_table_work;
- /* If the object matched can contain multibyte characters. */
- const boolean multibyte = RE_MULTIBYTE_P (bufp);
+ /* If the regular expression is multibyte. */
+ bool multibyte = RE_MULTIBYTE_P (bufp);
-#ifdef emacs
/* Nonzero if we have pushed down into a subpattern. */
int in_subpattern = 0;
@@ -2473,26 +1727,21 @@ regex_compile (const_re_char *pattern, size_t size,
re_char *main_p;
re_char *main_pattern;
re_char *main_pend;
-#endif
-#ifdef DEBUG
- debug++;
+#ifdef REGEX_EMACS_DEBUG
+ regex_emacs_debug++;
DEBUG_PRINT ("\nCompiling pattern: ");
- if (debug > 0)
+ if (regex_emacs_debug > 0)
{
- unsigned debug_count;
-
- for (debug_count = 0; debug_count < size; debug_count++)
+ for (ptrdiff_t debug_count = 0; debug_count < size; debug_count++)
putchar (pattern[debug_count]);
putchar ('\n');
}
-#endif /* DEBUG */
+#endif
/* Initialize the compile stack. */
- compile_stack.stack = TALLOC (INIT_COMPILE_STACK_SIZE, compile_stack_elt_t);
- if (compile_stack.stack == NULL)
- return REG_ESPACE;
-
+ compile_stack.stack = xmalloc (INIT_COMPILE_STACK_SIZE
+ * sizeof *compile_stack.stack);
compile_stack.size = INIT_COMPILE_STACK_SIZE;
compile_stack.avail = 0;
@@ -2500,40 +1749,21 @@ regex_compile (const_re_char *pattern, size_t size,
range_table_work.allocated = 0;
/* Initialize the pattern buffer. */
-#ifndef emacs
- bufp->syntax = syntax;
-#endif
- bufp->fastmap_accurate = 0;
- bufp->not_bol = bufp->not_eol = 0;
- bufp->used_syntax = 0;
+ bufp->fastmap_accurate = false;
+ bufp->used_syntax = false;
- /* Set `used' to zero, so that if we return an error, the pattern
+ /* Set 'used' to zero, so that if we return an error, the pattern
printer (for debugging) will think there's no pattern. We reset it
at the end. */
bufp->used = 0;
- /* Always count groups, whether or not bufp->no_sub is set. */
bufp->re_nsub = 0;
-#if !defined emacs && !defined SYNTAX_TABLE
- /* Initialize the syntax table. */
- init_syntax_once ();
-#endif
-
if (bufp->allocated == 0)
{
- if (bufp->buffer)
- { /* If zero allocated, but buffer is non-null, try to realloc
- enough space. This loses if buffer's address is bogus, but
- that is the user's responsibility. */
- RETALLOC (bufp->buffer, INIT_BUF_SIZE, unsigned char);
- }
- else
- { /* Caller did not allocate a buffer. Do it for them. */
- bufp->buffer = TALLOC (INIT_BUF_SIZE, unsigned char);
- }
- if (!bufp->buffer) FREE_STACK_RETURN (REG_ESPACE);
-
+ /* This loses if BUFP->buffer is bogus, but that is the user's
+ responsibility. */
+ bufp->buffer = xrealloc (bufp->buffer, INIT_BUF_SIZE);
bufp->allocated = INIT_BUF_SIZE;
}
@@ -2544,7 +1774,6 @@ regex_compile (const_re_char *pattern, size_t size,
{
if (p == pend)
{
-#ifdef emacs
/* If this is the end of an included regexp,
pop back to the main regexp and try again. */
if (in_subpattern)
@@ -2555,7 +1784,6 @@ regex_compile (const_re_char *pattern, size_t size,
pend = main_pend;
continue;
}
-#endif
/* If this is the end of the main regexp, we are done. */
break;
}
@@ -2564,7 +1792,6 @@ regex_compile (const_re_char *pattern, size_t size,
switch (c)
{
-#ifdef emacs
case ' ':
{
re_char *p1 = p;
@@ -2597,95 +1824,51 @@ regex_compile (const_re_char *pattern, size_t size,
pend = p + strlen (whitespace_regexp);
break;
}
-#endif
case '^':
- {
- if ( /* If at start of pattern, it's an operator. */
- p == pattern + 1
- /* If context independent, it's an operator. */
- || syntax & RE_CONTEXT_INDEP_ANCHORS
- /* Otherwise, depends on what's come before. */
- || at_begline_loc_p (pattern, p, syntax))
- BUF_PUSH ((syntax & RE_NO_NEWLINE_ANCHOR) ? begbuf : begline);
- else
- goto normal_char;
- }
+ if (! (p == pattern + 1 || at_begline_loc_p (pattern, p)))
+ goto normal_char;
+ BUF_PUSH (begline);
break;
-
case '$':
- {
- if ( /* If at end of pattern, it's an operator. */
- p == pend
- /* If context independent, it's an operator. */
- || syntax & RE_CONTEXT_INDEP_ANCHORS
- /* Otherwise, depends on what's next. */
- || at_endline_loc_p (p, pend, syntax))
- BUF_PUSH ((syntax & RE_NO_NEWLINE_ANCHOR) ? endbuf : endline);
- else
- goto normal_char;
- }
- break;
+ if (! (p == pend || at_endline_loc_p (p, pend)))
+ goto normal_char;
+ BUF_PUSH (endline);
+ break;
case '+':
case '?':
- if ((syntax & RE_BK_PLUS_QM)
- || (syntax & RE_LIMITED_OPS))
- goto normal_char;
- FALLTHROUGH;
case '*':
- handle_plus:
/* If there is no previous pattern... */
if (!laststart)
- {
- if (syntax & RE_CONTEXT_INVALID_OPS)
- FREE_STACK_RETURN (REG_BADRPT);
- else if (!(syntax & RE_CONTEXT_INDEP_OPS))
- goto normal_char;
- }
+ goto normal_char;
{
/* 1 means zero (many) matches is allowed. */
- boolean zero_times_ok = 0, many_times_ok = 0;
- boolean greedy = 1;
+ bool zero_times_ok = false, many_times_ok = false;
+ bool greedy = true;
/* If there is a sequence of repetition chars, collapse it
down to just one (the right one). We can't combine
- interval operators with these because of, e.g., `a{2}*',
- which should only match an even number of `a's. */
+ interval operators with these because of, e.g., 'a{2}*',
+ which should only match an even number of 'a's. */
for (;;)
{
- if ((syntax & RE_FRUGAL)
- && c == '?' && (zero_times_ok || many_times_ok))
- greedy = 0;
+ if (c == '?' && (zero_times_ok || many_times_ok))
+ greedy = false;
else
{
zero_times_ok |= c != '+';
many_times_ok |= c != '?';
}
- if (p == pend)
- break;
- else if (*p == '*'
- || (!(syntax & RE_BK_PLUS_QM)
- && (*p == '+' || *p == '?')))
- ;
- else if (syntax & RE_BK_PLUS_QM && *p == '\\')
- {
- if (p+1 == pend)
- FREE_STACK_RETURN (REG_EESCAPE);
- if (p[1] == '+' || p[1] == '?')
- PATFETCH (c); /* Gobble up the backslash. */
- else
- break;
- }
- else
+ if (! (p < pend && (*p == '*' || *p == '+' || *p == '?')))
break;
/* If we get here, we found another repeat character. */
- PATFETCH (c);
+ c = *p++;
}
/* Star, etc. applied to an empty pattern is equivalent
@@ -2699,25 +1882,25 @@ regex_compile (const_re_char *pattern, size_t size,
{
if (many_times_ok)
{
- boolean simple = skip_one_char (laststart) == b;
- size_t startoffset = 0;
+ bool simple = skip_one_char (laststart) == b;
+ ptrdiff_t startoffset = 0;
re_opcode_t ofj =
/* Check if the loop can match the empty string. */
- (simple || !analyze_first (laststart, b, NULL, 0))
+ (simple || !analyze_first (laststart, b, NULL, false))
? on_failure_jump : on_failure_jump_loop;
- assert (skip_one_char (laststart) <= b);
+ eassert (skip_one_char (laststart) <= b);
if (!zero_times_ok && simple)
{ /* Since simple * loops can be made faster by using
- on_failure_keep_string_jump, we turn simple P+
- into PP* if P is simple. */
- unsigned char *p1, *p2;
- startoffset = b - laststart;
- GET_BUFFER_SPACE (startoffset);
- p1 = b; p2 = laststart;
- while (p2 < p1)
- *b++ = *p2++;
- zero_times_ok = 1;
+ on_failure_keep_string_jump, we turn simple P+
+ into PP* if P is simple. */
+ unsigned char *p1, *p2;
+ startoffset = b - laststart;
+ GET_BUFFER_SPACE (startoffset);
+ p1 = b; p2 = laststart;
+ while (p2 < p1)
+ *b++ = *p2++;
+ zero_times_ok = 1;
}
GET_BUFFER_SPACE (6);
@@ -2738,7 +1921,7 @@ regex_compile (const_re_char *pattern, size_t size,
else
{
/* A simple ? pattern. */
- assert (zero_times_ok);
+ eassert (zero_times_ok);
GET_BUFFER_SPACE (3);
INSERT_JUMP (on_failure_jump, laststart, b + 3);
b += 3;
@@ -2750,7 +1933,7 @@ regex_compile (const_re_char *pattern, size_t size,
GET_BUFFER_SPACE (7); /* We might use less. */
if (many_times_ok)
{
- boolean emptyp = analyze_first (laststart, b, NULL, 0);
+ bool emptyp = !!analyze_first (laststart, b, NULL, false);
/* The non-greedy multiple match looks like
a repeat..until: we only need a conditional jump
@@ -2802,8 +1985,8 @@ regex_compile (const_re_char *pattern, size_t size,
laststart = b;
- /* We test `*p == '^' twice, instead of using an if
- statement, so we only need one BUF_PUSH. */
+ /* Test '*p == '^' twice, instead of using an if
+ statement, so we need only one BUF_PUSH. */
BUF_PUSH (*p == '^' ? charset_not : charset);
if (*p == '^')
p++;
@@ -2817,25 +2000,18 @@ regex_compile (const_re_char *pattern, size_t size,
/* Clear the whole map. */
memset (b, 0, (1 << BYTEWIDTH) / BYTEWIDTH);
- /* charset_not matches newline according to a syntax bit. */
- if ((re_opcode_t) b[-2] == charset_not
- && (syntax & RE_HAT_LISTS_NOT_NEWLINE))
- SET_LIST_BIT ('\n');
-
/* Read in characters and ranges, setting map bits. */
for (;;)
{
- boolean escaped_char = false;
const unsigned char *p2 = p;
- re_wctype_t cc;
- re_wchar_t ch;
+ int ch;
if (p == pend) FREE_STACK_RETURN (REG_EBRACK);
/* See if we're at the beginning of a possible character
class. */
- if (syntax & RE_CHAR_CLASSES &&
- (cc = re_wctype_parse(&p, pend - p)) != -1)
+ re_wctype_t cc = re_wctype_parse (&p, pend - p);
+ if (cc != -1)
{
if (cc == 0)
FREE_STACK_RETURN (REG_ECTYPE);
@@ -2843,15 +2019,6 @@ regex_compile (const_re_char *pattern, size_t size,
if (p == pend)
FREE_STACK_RETURN (REG_EBRACK);
-#ifndef emacs
- for (ch = 0; ch < (1 << BYTEWIDTH); ++ch)
- if (re_iswctype (btowc (ch), cc))
- {
- c = TRANSLATE (ch);
- if (c < (1 << BYTEWIDTH))
- SET_LIST_BIT (c);
- }
-#else /* emacs */
/* Most character classes in a multibyte match just set
a flag. Exceptions are is_blank, is_digit, is_cntrl, and
is_xdigit, since they can only match ASCII characters.
@@ -2878,13 +2045,13 @@ regex_compile (const_re_char *pattern, size_t size,
}
SET_RANGE_TABLE_WORK_AREA_BIT
(range_table_work, re_wctype_to_bit (cc));
-#endif /* emacs */
+
/* In most cases the matching rule for char classes only
uses the syntax table for multibyte chars, so that the
content of the syntax-table is not hardcoded in the
range_table. SPACE and WORD are the two exceptions. */
if ((1 << cc) & ((1 << RECC_SPACE) | (1 << RECC_WORD)))
- bufp->used_syntax = 1;
+ bufp->used_syntax = true;
/* Repeat the loop. */
continue;
@@ -2896,60 +2063,33 @@ regex_compile (const_re_char *pattern, size_t size,
(let ((case-fold-search t)) (string-match "[A-_]" "A")) */
PATFETCH (c);
- /* \ might escape characters inside [...] and [^...]. */
- if ((syntax & RE_BACKSLASH_ESCAPE_IN_LISTS) && c == '\\')
- {
- if (p == pend) FREE_STACK_RETURN (REG_EESCAPE);
-
- PATFETCH (c);
- escaped_char = true;
- }
- else
- {
- /* Could be the end of the bracket expression. If it's
- not (i.e., when the bracket expression is `[]' so
- far), the ']' character bit gets set way below. */
- if (c == ']' && p2 != p1)
- break;
- }
+ /* Could be the end of the bracket expression. If it's
+ not (i.e., when the bracket expression is '[]' so
+ far), the ']' character bit gets set way below. */
+ if (c == ']' && p2 != p1)
+ break;
if (p < pend && p[0] == '-' && p[1] != ']')
{
- /* Discard the `-'. */
+ /* Discard the '-'. */
PATFETCH (c1);
/* Fetch the character which ends the range. */
PATFETCH (c1);
-#ifdef emacs
+
if (CHAR_BYTE8_P (c1)
&& ! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
/* Treat the range from a multibyte character to
raw-byte character as empty. */
c = c1 + 1;
-#endif /* emacs */
}
else
/* Range from C to C. */
c1 = c;
- if (c > c1)
- {
- if (syntax & RE_NO_EMPTY_RANGES)
- FREE_STACK_RETURN (REG_ERANGEX);
- /* Else, repeat the loop. */
- }
- else
+ if (c <= c1)
{
-#ifndef emacs
- /* Set the range into bitmap */
- for (; c <= c1; c++)
- {
- ch = TRANSLATE (c);
- if (ch < (1 << BYTEWIDTH))
- SET_LIST_BIT (ch);
- }
-#else /* emacs */
if (c < 128)
{
ch = min (127, c1);
@@ -2958,25 +2098,17 @@ regex_compile (const_re_char *pattern, size_t size,
if (CHAR_BYTE8_P (c1))
c = BYTE8_TO_CHAR (128);
}
- if (c <= c1)
+ if (CHAR_BYTE8_P (c))
{
- if (CHAR_BYTE8_P (c))
- {
- c = CHAR_TO_BYTE8 (c);
- c1 = CHAR_TO_BYTE8 (c1);
- for (; c <= c1; c++)
- SET_LIST_BIT (c);
- }
- else if (multibyte)
- {
- SETUP_MULTIBYTE_RANGE (range_table_work, c, c1);
- }
- else
- {
- SETUP_UNIBYTE_RANGE (range_table_work, c, c1);
- }
+ c = CHAR_TO_BYTE8 (c);
+ c1 = CHAR_TO_BYTE8 (c1);
+ for (; c <= c1; c++)
+ SET_LIST_BIT (c);
}
-#endif /* emacs */
+ else if (multibyte)
+ SETUP_MULTIBYTE_RANGE (range_table_work, c, c1);
+ else
+ SETUP_UNIBYTE_RANGE (range_table_work, c, c1);
}
}
@@ -3001,8 +2133,7 @@ regex_compile (const_re_char *pattern, size_t size,
/* Indicate the existence of range table. */
laststart[1] |= 0x80;
- /* Store the character class flag bits into the range table.
- If not in emacs, these flag bits are always 0. */
+ /* Store the character class flag bits into the range table. */
*b++ = RANGE_TABLE_WORK_BITS (range_table_work) & 0xff;
*b++ = RANGE_TABLE_WORK_BITS (range_table_work) >> 8;
@@ -3015,41 +2146,6 @@ regex_compile (const_re_char *pattern, size_t size,
break;
- case '(':
- if (syntax & RE_NO_BK_PARENS)
- goto handle_open;
- else
- goto normal_char;
-
-
- case ')':
- if (syntax & RE_NO_BK_PARENS)
- goto handle_close;
- else
- goto normal_char;
-
-
- case '\n':
- if (syntax & RE_NEWLINE_ALT)
- goto handle_alt;
- else
- goto normal_char;
-
-
- case '|':
- if (syntax & RE_NO_BK_VBAR)
- goto handle_alt;
- else
- goto normal_char;
-
-
- case '{':
- if (syntax & RE_INTERVALS && syntax & RE_NO_BK_BRACES)
- goto handle_interval;
- else
- goto normal_char;
-
-
case '\\':
if (p == pend) FREE_STACK_RETURN (REG_EESCAPE);
@@ -3061,17 +2157,13 @@ regex_compile (const_re_char *pattern, size_t size,
switch (c)
{
case '(':
- if (syntax & RE_NO_BK_PARENS)
- goto normal_backslash;
-
- handle_open:
{
- int shy = 0;
+ bool shy = false;
regnum_t regnum = 0;
if (p+1 < pend)
{
/* Look for a special (?...) construct */
- if ((syntax & RE_SHY_GROUPS) && *p == '?')
+ if (*p == '?')
{
PATFETCH (c); /* Gobble up the '?'. */
while (!shy)
@@ -3079,7 +2171,7 @@ regex_compile (const_re_char *pattern, size_t size,
PATFETCH (c);
switch (c)
{
- case ':': shy = 1; break;
+ case ':': shy = true; break;
case '0':
/* An explicitly specified regnum must start
with non-0. */
@@ -3088,7 +2180,11 @@ regex_compile (const_re_char *pattern, size_t size,
FALLTHROUGH;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
- regnum = 10*regnum + (c - '0'); break;
+ if (INT_MULTIPLY_WRAPV (regnum, 10, &regnum)
+ || INT_ADD_WRAPV (regnum, c - '0',
+ &regnum))
+ FREE_STACK_RETURN (REG_ESIZE);
+ break;
default:
/* Only (?:...) is supported right now. */
FREE_STACK_RETURN (REG_BADPAT);
@@ -3101,7 +2197,7 @@ regex_compile (const_re_char *pattern, size_t size,
regnum = ++bufp->re_nsub;
else if (regnum)
{ /* It's actually not shy, but explicitly numbered. */
- shy = 0;
+ shy = false;
if (regnum > bufp->re_nsub)
bufp->re_nsub = regnum;
else if (regnum > bufp->re_nsub
@@ -3118,13 +2214,9 @@ regex_compile (const_re_char *pattern, size_t size,
regnum = - bufp->re_nsub;
if (COMPILE_STACK_FULL)
- {
- RETALLOC (compile_stack.stack, compile_stack.size << 1,
- compile_stack_elt_t);
- if (compile_stack.stack == NULL) return REG_ESPACE;
-
- compile_stack.size <<= 1;
- }
+ compile_stack.stack
+ = xpalloc (compile_stack.stack, &compile_stack.size,
+ 1, -1, sizeof *compile_stack.stack);
/* These are the values to restore when we hit end of this
group. They are all relative offsets, so that if the
@@ -3154,35 +2246,22 @@ regex_compile (const_re_char *pattern, size_t size,
}
case ')':
- if (syntax & RE_NO_BK_PARENS) goto normal_backslash;
-
if (COMPILE_STACK_EMPTY)
- {
- if (syntax & RE_UNMATCHED_RIGHT_PAREN_ORD)
- goto normal_backslash;
- else
- FREE_STACK_RETURN (REG_ERPAREN);
- }
+ FREE_STACK_RETURN (REG_ERPAREN);
- handle_close:
FIXUP_ALT_JUMP ();
/* See similar code for backslashed left paren above. */
if (COMPILE_STACK_EMPTY)
- {
- if (syntax & RE_UNMATCHED_RIGHT_PAREN_ORD)
- goto normal_char;
- else
- FREE_STACK_RETURN (REG_ERPAREN);
- }
+ FREE_STACK_RETURN (REG_ERPAREN);
/* Since we just checked for an empty stack above, this
- ``can't happen''. */
- assert (compile_stack.avail != 0);
+ "can't happen". */
+ eassert (compile_stack.avail != 0);
{
- /* We don't just want to restore into `regnum', because
+ /* We don't just want to restore into 'regnum', because
later groups should continue to be numbered higher,
- as in `(ab)c(de)' -- the second group is #2. */
+ as in '(ab)c(de)' -- the second group is #2. */
regnum_t regnum;
compile_stack.avail--;
@@ -3206,13 +2285,7 @@ regex_compile (const_re_char *pattern, size_t size,
break;
- case '|': /* `\|'. */
- if (syntax & RE_LIMITED_OPS || syntax & RE_NO_BK_VBAR)
- goto normal_backslash;
- handle_alt:
- if (syntax & RE_LIMITED_OPS)
- goto normal_char;
-
+ case '|': /* '\|'. */
/* Insert before the previous alternative a jump which
jumps to this alternative if the former fails. */
GET_BUFFER_SPACE (3);
@@ -3229,12 +2302,12 @@ regex_compile (const_re_char *pattern, size_t size,
_____ _____
| | | |
| v | v
- a | b | c
+ A | B | C
- If we are at `b', then fixup_alt_jump right now points to a
- three-byte space after `a'. We'll put in the jump, set
- fixup_alt_jump to right after `b', and leave behind three
- bytes which we'll fill in when we get to after `c'. */
+ If we are at B, then fixup_alt_jump right now points to a
+ three-byte space after A. We'll put in the jump, set
+ fixup_alt_jump to right after B, and leave behind three
+ bytes which we'll fill in when we get to after C. */
FIXUP_ALT_JUMP ();
@@ -3251,17 +2324,7 @@ regex_compile (const_re_char *pattern, size_t size,
case '{':
- /* If \{ is a literal. */
- if (!(syntax & RE_INTERVALS)
- /* If we're at `\{' and it's not the open-interval
- operator. */
- || (syntax & RE_NO_BK_BRACES))
- goto normal_backslash;
-
- handle_interval:
{
- /* If got here, then the syntax allows intervals. */
-
/* At least (most) this many matches must be made. */
int lower_bound = 0, upper_bound = -1;
@@ -3272,37 +2335,23 @@ regex_compile (const_re_char *pattern, size_t size,
if (c == ',')
GET_INTERVAL_COUNT (upper_bound);
else
- /* Interval such as `{1}' => match exactly once. */
+ /* Interval such as '{1}' => match exactly once. */
upper_bound = lower_bound;
if (lower_bound < 0
- || (0 <= upper_bound && upper_bound < lower_bound))
+ || (0 <= upper_bound && upper_bound < lower_bound)
+ || c != '\\')
FREE_STACK_RETURN (REG_BADBR);
-
- if (!(syntax & RE_NO_BK_BRACES))
- {
- if (c != '\\')
- FREE_STACK_RETURN (REG_BADBR);
- if (p == pend)
- FREE_STACK_RETURN (REG_EESCAPE);
- PATFETCH (c);
- }
-
- if (c != '}')
+ if (p == pend)
+ FREE_STACK_RETURN (REG_EESCAPE);
+ if (*p++ != '}')
FREE_STACK_RETURN (REG_BADBR);
/* We just parsed a valid interval. */
/* If it's invalid to have no preceding re. */
if (!laststart)
- {
- if (syntax & RE_CONTEXT_INVALID_OPS)
- FREE_STACK_RETURN (REG_BADRPT);
- else if (syntax & RE_CONTEXT_INDEP_OPS)
- laststart = b;
- else
- goto unfetch_interval;
- }
+ goto unfetch_interval;
if (upper_bound == 0)
/* If the upper bound is zero, just drop the sub pattern
@@ -3319,14 +2368,13 @@ regex_compile (const_re_char *pattern, size_t size,
succeed_n <after jump addr> <succeed_n count>
<body of loop>
jump_n <succeed_n addr> <jump count>
- (The upper bound and `jump_n' are omitted if
- `upper_bound' is 1, though.) */
+ (The upper bound and 'jump_n' are omitted if
+ 'upper_bound' is 1, though.) */
else
{ /* If the upper bound is > 1, we need to insert
more at the end of the loop. */
- unsigned int nbytes = (upper_bound < 0 ? 3
- : upper_bound > 1 ? 5 : 0);
- unsigned int startoffset = 0;
+ int nbytes = upper_bound < 0 ? 3 : upper_bound > 1 ? 5 : 0;
+ int startoffset = 0;
GET_BUFFER_SPACE (20); /* We might use less. */
@@ -3340,21 +2388,22 @@ regex_compile (const_re_char *pattern, size_t size,
}
else
{
- /* Initialize lower bound of the `succeed_n', even
+ /* Initialize lower bound of the 'succeed_n', even
though it will be set during matching by its
- attendant `set_number_at' (inserted next),
- because `re_compile_fastmap' needs to know.
- Jump to the `jump_n' we might insert below. */
+ attendant 'set_number_at' (inserted next),
+ because 're_compile_fastmap' needs to know.
+ Jump to the 'jump_n' we might insert below. */
INSERT_JUMP2 (succeed_n, laststart,
b + 5 + nbytes,
lower_bound);
b += 5;
/* Code to initialize the lower bound. Insert
- before the `succeed_n'. The `5' is the last two
- bytes of this `set_number_at', plus 3 bytes of
- the following `succeed_n'. */
- insert_op2 (set_number_at, laststart, 5, lower_bound, b);
+ before the 'succeed_n'. The '5' is the last two
+ bytes of this 'set_number_at', plus 3 bytes of
+ the following 'succeed_n'. */
+ insert_op2 (set_number_at, laststart, 5,
+ lower_bound, b);
b += 5;
startoffset += 5;
}
@@ -3368,28 +2417,28 @@ regex_compile (const_re_char *pattern, size_t size,
}
else if (upper_bound > 1)
{ /* More than one repetition is allowed, so
- append a backward jump to the `succeed_n'
+ append a backward jump to the 'succeed_n'
that starts this interval.
When we've reached this during matching,
we'll have matched the interval once, so
- jump back only `upper_bound - 1' times. */
+ jump back only 'upper_bound - 1' times. */
STORE_JUMP2 (jump_n, b, laststart + startoffset,
upper_bound - 1);
b += 5;
/* The location we want to set is the second
- parameter of the `jump_n'; that is `b-2' as
- an absolute address. `laststart' will be
- the `set_number_at' we're about to insert;
- `laststart+3' the number to set, the source
+ parameter of the 'jump_n'; that is 'b-2' as
+ an absolute address. 'laststart' will be
+ the 'set_number_at' we're about to insert;
+ 'laststart+3' the number to set, the source
for the relative address. But we are
inserting into the middle of the pattern --
so everything is getting moved up by 5.
Conclusion: (b - 2) - (laststart + 3) + 5,
i.e., b - laststart.
- We insert this at the beginning of the loop
+ Insert this at the beginning of the loop
so that if we fail during matching, we'll
reinitialize the bounds. */
insert_op2 (set_number_at, laststart, b - laststart,
@@ -3404,22 +2453,13 @@ regex_compile (const_re_char *pattern, size_t size,
unfetch_interval:
/* If an invalid interval, match the characters as literals. */
- assert (beg_interval);
+ eassert (beg_interval);
p = beg_interval;
beg_interval = NULL;
-
- /* normal_char and normal_backslash need `c'. */
+ eassert (p > pattern && p[-1] == '\\');
c = '{';
+ goto normal_char;
- if (!(syntax & RE_NO_BK_BRACES))
- {
- assert (p > pattern && p[-1] == '\\');
- goto normal_backslash;
- }
- else
- goto normal_char;
-
-#ifdef emacs
case '=':
laststart = b;
BUF_PUSH (at_dot);
@@ -3448,42 +2488,30 @@ regex_compile (const_re_char *pattern, size_t size,
PATFETCH (c);
BUF_PUSH_2 (notcategoryspec, c);
break;
-#endif /* emacs */
-
case 'w':
- if (syntax & RE_NO_GNU_OPS)
- goto normal_char;
laststart = b;
BUF_PUSH_2 (syntaxspec, Sword);
break;
case 'W':
- if (syntax & RE_NO_GNU_OPS)
- goto normal_char;
laststart = b;
BUF_PUSH_2 (notsyntaxspec, Sword);
break;
case '<':
- if (syntax & RE_NO_GNU_OPS)
- goto normal_char;
laststart = b;
BUF_PUSH (wordbeg);
break;
case '>':
- if (syntax & RE_NO_GNU_OPS)
- goto normal_char;
laststart = b;
BUF_PUSH (wordend);
break;
case '_':
- if (syntax & RE_NO_GNU_OPS)
- goto normal_char;
laststart = b;
PATFETCH (c);
if (c == '<')
@@ -3495,38 +2523,25 @@ regex_compile (const_re_char *pattern, size_t size,
break;
case 'b':
- if (syntax & RE_NO_GNU_OPS)
- goto normal_char;
BUF_PUSH (wordbound);
break;
case 'B':
- if (syntax & RE_NO_GNU_OPS)
- goto normal_char;
BUF_PUSH (notwordbound);
break;
case '`':
- if (syntax & RE_NO_GNU_OPS)
- goto normal_char;
BUF_PUSH (begbuf);
break;
case '\'':
- if (syntax & RE_NO_GNU_OPS)
- goto normal_char;
BUF_PUSH (endbuf);
break;
case '1': case '2': case '3': case '4': case '5':
case '6': case '7': case '8': case '9':
{
- regnum_t reg;
-
- if (syntax & RE_NO_BK_REFS)
- goto normal_backslash;
-
- reg = c - '0';
+ regnum_t reg = c - '0';
if (reg > bufp->re_nsub || reg < 1
/* Can't back reference to a subexp before its end. */
@@ -3538,16 +2553,7 @@ regex_compile (const_re_char *pattern, size_t size,
}
break;
-
- case '+':
- case '?':
- if (syntax & RE_BK_PLUS_QM)
- goto handle_plus;
- else
- goto normal_backslash;
-
default:
- normal_backslash:
/* You might think it would be useful for \ to mean
not to translate; but if we don't translate it
it will never match anything. */
@@ -3557,7 +2563,7 @@ regex_compile (const_re_char *pattern, size_t size,
default:
- /* Expects the character in `c'. */
+ /* Expects the character in C. */
normal_char:
/* If no exactn currently being built. */
if (!pending_exact
@@ -3565,18 +2571,13 @@ regex_compile (const_re_char *pattern, size_t size,
/* If last exactn not at current position. */
|| pending_exact + *pending_exact + 1 != b
- /* We have only one byte following the exactn for the count. */
+ /* Only one byte follows the exactn for the count. */
|| *pending_exact >= (1 << BYTEWIDTH) - MAX_MULTIBYTE_LENGTH
/* If followed by a repetition operator. */
- || (p != pend && (*p == '*' || *p == '^'))
- || ((syntax & RE_BK_PLUS_QM)
- ? p + 1 < pend && *p == '\\' && (p[1] == '+' || p[1] == '?')
- : p != pend && (*p == '+' || *p == '?'))
- || ((syntax & RE_INTERVALS)
- && ((syntax & RE_NO_BK_BRACES)
- ? p != pend && *p == '{'
- : p + 1 < pend && p[0] == '\\' && p[1] == '{')))
+ || (p != pend
+ && (*p == '*' || *p == '+' || *p == '?' || *p == '^'))
+ || (p + 1 < pend && p[0] == '\\' && p[1] == '{'))
{
/* Start building a new exactn. */
@@ -3601,7 +2602,7 @@ regex_compile (const_re_char *pattern, size_t size,
c1 = RE_CHAR_TO_MULTIBYTE (c);
if (! CHAR_BYTE8_P (c1))
{
- re_wchar_t c2 = TRANSLATE (c1);
+ int c2 = TRANSLATE (c1);
if (c1 != c2 && (c1 = RE_CHAR_TO_UNIBYTE (c2)) >= 0)
c = c1;
@@ -3629,47 +2630,24 @@ regex_compile (const_re_char *pattern, size_t size,
if (!posix_backtracking)
BUF_PUSH (succeed);
- /* We have succeeded; set the length of the buffer. */
+ /* Success; set the length of the buffer. */
bufp->used = b - bufp->buffer;
-#ifdef DEBUG
- if (debug > 0)
+#ifdef REGEX_EMACS_DEBUG
+ if (regex_emacs_debug > 0)
{
re_compile_fastmap (bufp);
DEBUG_PRINT ("\nCompiled pattern: \n");
print_compiled_pattern (bufp);
}
- debug--;
-#endif /* DEBUG */
-
-#ifndef MATCH_MAY_ALLOCATE
- /* Initialize the failure stack to the largest possible stack. This
- isn't necessary unless we're trying to avoid calling alloca in
- the search and match routines. */
- {
- int num_regs = bufp->re_nsub + 1;
-
- if (fail_stack.size < emacs_re_max_failures * TYPICAL_FAILURE_SIZE)
- {
- fail_stack.size = emacs_re_max_failures * TYPICAL_FAILURE_SIZE;
- falk_stack.stack = realloc (fail_stack.stack,
- fail_stack.size * sizeof *falk_stack.stack);
- }
-
- regex_grow_registers (num_regs);
- }
-#endif /* not MATCH_MAY_ALLOCATE */
+ regex_emacs_debug--;
+#endif
FREE_STACK_RETURN (REG_NOERROR);
-#ifdef emacs
-# undef syntax
-#else
-# undef posix_backtracking
-#endif
} /* regex_compile */
-/* Subroutines for `regex_compile'. */
+/* Subroutines for 'regex_compile'. */
/* Store OP at LOC followed by two-byte integer parameter ARG. */
@@ -3681,7 +2659,7 @@ store_op1 (re_opcode_t op, unsigned char *loc, int arg)
}
-/* Like `store_op1', but for two two-byte parameters ARG1 and ARG2. */
+/* Like 'store_op1', but for two two-byte parameters ARG1 and ARG2. */
static void
store_op2 (re_opcode_t op, unsigned char *loc, int arg1, int arg2)
@@ -3708,10 +2686,11 @@ insert_op1 (re_opcode_t op, unsigned char *loc, int arg, unsigned char *end)
}
-/* Like `insert_op1', but for two two-byte parameters ARG1 and ARG2. */
+/* Like 'insert_op1', but for two two-byte parameters ARG1 and ARG2. */
static void
-insert_op2 (re_opcode_t op, unsigned char *loc, int arg1, int arg2, unsigned char *end)
+insert_op2 (re_opcode_t op, unsigned char *loc, int arg1, int arg2,
+ unsigned char *end)
{
register unsigned char *pfrom = end;
register unsigned char *pto = end + 5;
@@ -3724,74 +2703,60 @@ insert_op2 (re_opcode_t op, unsigned char *loc, int arg1, int arg2, unsigned cha
/* P points to just after a ^ in PATTERN. Return true if that ^ comes
- after an alternative or a begin-subexpression. We assume there is at
+ after an alternative or a begin-subexpression. Assume there is at
least one character before the ^. */
-static boolean
-at_begline_loc_p (const_re_char *pattern, const_re_char *p, reg_syntax_t syntax)
+static bool
+at_begline_loc_p (re_char *pattern, re_char *p)
{
re_char *prev = p - 2;
- boolean odd_backslashes;
- /* After a subexpression? */
- if (*prev == '(')
- odd_backslashes = (syntax & RE_NO_BK_PARENS) == 0;
-
- /* After an alternative? */
- else if (*prev == '|')
- odd_backslashes = (syntax & RE_NO_BK_VBAR) == 0;
-
- /* After a shy subexpression? */
- else if (*prev == ':' && (syntax & RE_SHY_GROUPS))
+ switch (*prev)
{
+ case '(': /* After a subexpression. */
+ case '|': /* After an alternative. */
+ break;
+
+ case ':': /* After a shy subexpression. */
/* Skip over optional regnum. */
- while (prev - 1 >= pattern && prev[-1] >= '0' && prev[-1] <= '9')
+ while (prev > pattern && '0' <= prev[-1] && prev[-1] <= '9')
--prev;
- if (!(prev - 2 >= pattern
- && prev[-1] == '?' && prev[-2] == '('))
+ if (! (prev > pattern + 1 && prev[-1] == '?' && prev[-2] == '('))
return false;
prev -= 2;
- odd_backslashes = (syntax & RE_NO_BK_PARENS) == 0;
+ break;
+
+ default:
+ return false;
}
- else
- return false;
/* Count the number of preceding backslashes. */
p = prev;
- while (prev - 1 >= pattern && prev[-1] == '\\')
+ while (prev > pattern && prev[-1] == '\\')
--prev;
- return (p - prev) & odd_backslashes;
+ return (p - prev) & 1;
}
-/* The dual of at_begline_loc_p. This one is for $. We assume there is
- at least one character after the $, i.e., `P < PEND'. */
+/* The dual of at_begline_loc_p. This one is for $. Assume there is
+ at least one character after the $, i.e., 'P < PEND'. */
-static boolean
-at_endline_loc_p (const_re_char *p, const_re_char *pend, reg_syntax_t syntax)
+static bool
+at_endline_loc_p (re_char *p, re_char *pend)
{
- re_char *next = p;
- boolean next_backslash = *next == '\\';
- re_char *next_next = p + 1 < pend ? p + 1 : 0;
-
- return
- /* Before a subexpression? */
- (syntax & RE_NO_BK_PARENS ? *next == ')'
- : next_backslash && next_next && *next_next == ')')
- /* Before an alternative? */
- || (syntax & RE_NO_BK_VBAR ? *next == '|'
- : next_backslash && next_next && *next_next == '|');
+ /* Before a subexpression or an alternative? */
+ return *p == '\\' && p + 1 < pend && (p[1] == ')' || p[1] == '|');
}
/* Returns true if REGNUM is in one of COMPILE_STACK's elements and
false if it's not. */
-static boolean
+static bool
group_in_compile_stack (compile_stack_type compile_stack, regnum_t regnum)
{
- ssize_t this_element;
+ ptrdiff_t this_element;
for (this_element = compile_stack.avail - 1;
this_element >= 0;
@@ -3813,39 +2778,38 @@ group_in_compile_stack (compile_stack_type compile_stack, regnum_t regnum)
Return -1 if fastmap was not updated accurately. */
static int
-analyze_first (const_re_char *p, const_re_char *pend, char *fastmap,
- const int multibyte)
+analyze_first (re_char *p, re_char *pend, char *fastmap, bool multibyte)
{
int j, k;
- boolean not;
+ bool not;
/* If all elements for base leading-codes in fastmap is set, this
flag is set true. */
- boolean match_any_multibyte_characters = false;
+ bool match_any_multibyte_characters = false;
- assert (p);
+ eassert (p);
/* The loop below works as follows:
- It has a working-list kept in the PATTERN_STACK and which basically
starts by only containing a pointer to the first operation.
- If the opcode we're looking at is a match against some set of
chars, then we add those chars to the fastmap and go on to the
- next work element from the worklist (done via `break').
+ next work element from the worklist (done via 'break').
- If the opcode is a control operator on the other hand, we either
- ignore it (if it's meaningless at this point, such as `start_memory')
+ ignore it (if it's meaningless at this point, such as 'start_memory')
or execute it (if it's a jump). If the jump has several destinations
- (i.e. `on_failure_jump'), then we push the other destination onto the
+ (i.e. 'on_failure_jump'), then we push the other destination onto the
worklist.
We guarantee termination by ignoring backward jumps (more or less),
- so that `p' is monotonically increasing. More to the point, we
- never set `p' (or push) anything `<= p1'. */
+ so that P is monotonically increasing. More to the point, we
+ never set P (or push) anything '<= p1'. */
while (p < pend)
{
- /* `p1' is used as a marker of how far back a `on_failure_jump'
- can go without being ignored. It is normally equal to `p'
- (which prevents any backward `on_failure_jump') except right
- after a plain `jump', to allow patterns such as:
+ /* P1 is used as a marker of how far back a 'on_failure_jump'
+ can go without being ignored. It is normally equal to P
+ (which prevents any backward 'on_failure_jump') except right
+ after a plain 'jump', to allow patterns such as:
0: jump 10
3..9: <body>
10: on_failure_jump 3
@@ -3867,7 +2831,7 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap,
/* Following are the cases which match a character. These end
- with `break'. */
+ with 'break'. */
case exactn:
if (fastmap)
@@ -3914,7 +2878,6 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap,
if (!!(p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH))) ^ not)
fastmap[j] = 1;
-#ifdef emacs
if (/* Any leading code can possibly start a character
which doesn't match the specified set of characters. */
not
@@ -3942,7 +2905,7 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap,
int c, count;
unsigned char lc1, lc2;
- /* Make P points the range table. `+ 2' is to skip flag
+ /* Make P points the range table. '+ 2' is to skip flag
bits for a character class. */
p += CHARSET_BITMAP_SIZE (&p[-2]) + 2;
@@ -3960,20 +2923,11 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap,
fastmap[j] = 1;
}
}
-#endif
break;
case syntaxspec:
case notsyntaxspec:
if (!fastmap) break;
-#ifndef emacs
- not = (re_opcode_t)p[-1] == notsyntaxspec;
- k = *p++;
- for (j = 0; j < (1 << BYTEWIDTH); j++)
- if ((SYNTAX (j) == (enum syntaxcode) k) ^ not)
- fastmap[j] = 1;
- break;
-#else /* emacs */
/* This match depends on text properties. These end with
aborting optimizations. */
return -1;
@@ -3999,10 +2953,9 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap,
break;
/* All cases after this match the empty string. These end with
- `continue'. */
+ 'continue'. */
case at_dot:
-#endif /* !emacs */
case no_op:
case begline:
case endline:
@@ -4021,7 +2974,7 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap,
EXTRACT_NUMBER_AND_INCR (j, p);
if (j < 0)
/* Backward jumps can only go back to code that we've already
- visited. `re_compile' should make sure this is true. */
+ visited. 're_compile' should make sure this is true. */
break;
p += j;
switch (*p)
@@ -4036,7 +2989,7 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap,
default:
continue;
};
- /* Keep `p1' to allow the `on_failure_jump' we are jumping to
+ /* Keep P1 to allow the 'on_failure_jump' we are jumping to
to jump back to "just after here". */
FALLTHROUGH;
case on_failure_jump:
@@ -4060,7 +3013,7 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap,
case jump_n:
/* This code simply does not properly handle forward jump_n. */
- DEBUG_STATEMENT (EXTRACT_NUMBER (j, p); assert (j < 0));
+ DEBUG_STATEMENT (EXTRACT_NUMBER (j, p); eassert (j < 0));
p += 4;
/* jump_n can either jump or fall through. The (backward) jump
case has already been handled, so we only need to look at the
@@ -4069,7 +3022,7 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap,
case succeed_n:
/* If N == 0, it should be an on_failure_jump_loop instead. */
- DEBUG_STATEMENT (EXTRACT_NUMBER (j, p + 2); assert (j > 0));
+ DEBUG_STATEMENT (EXTRACT_NUMBER (j, p + 2); eassert (j > 0));
p += 4;
/* We only care about one iteration of the loop, so we don't
need to consider the case where this behaves like an
@@ -4103,8 +3056,8 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap,
} /* analyze_first */
-/* re_compile_fastmap computes a ``fastmap'' for the compiled pattern in
- BUFP. A fastmap records which of the (1 << BYTEWIDTH) possible
+/* Compute a fastmap for the compiled pattern in BUFP.
+ A fastmap records which of the (1 << BYTEWIDTH) possible
characters can start a string that matches the pattern. This fastmap
is used by re_search to skip quickly over impossible starting points.
@@ -4115,33 +3068,32 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap,
The caller must supply the address of a (1 << BYTEWIDTH)-byte data
area as BUFP->fastmap.
- We set the `fastmap', `fastmap_accurate', and `can_be_null' fields in
- the pattern buffer.
+ Set the 'fastmap', 'fastmap_accurate', and 'can_be_null' fields in
+ the pattern buffer. */
- Returns 0 if we succeed, -2 if an internal error. */
-
-int
+static void
re_compile_fastmap (struct re_pattern_buffer *bufp)
{
char *fastmap = bufp->fastmap;
int analysis;
- assert (fastmap && bufp->buffer);
+ eassert (fastmap && bufp->buffer);
memset (fastmap, 0, 1 << BYTEWIDTH); /* Assume nothing's valid. */
+
+ /* FIXME: Is the following assignment correct even when ANALYSIS < 0? */
bufp->fastmap_accurate = 1; /* It will be when we're done. */
analysis = analyze_first (bufp->buffer, bufp->buffer + bufp->used,
fastmap, RE_MULTIBYTE_P (bufp));
bufp->can_be_null = (analysis != 0);
- return 0;
} /* re_compile_fastmap */
/* Set REGS to hold NUM_REGS registers, storing them in STARTS and
ENDS. Subsequent matches using PATTERN_BUFFER and REGS will use
this memory for recording register information. STARTS and ENDS
must be allocated using the malloc library routine, and must each
- be at least NUM_REGS * sizeof (regoff_t) bytes long.
+ be at least NUM_REGS * sizeof (ptrdiff_t) bytes long.
If NUM_REGS == 0, then subsequent matches should allocate their own
register data.
@@ -4151,7 +3103,8 @@ re_compile_fastmap (struct re_pattern_buffer *bufp)
freeing the old data. */
void
-re_set_registers (struct re_pattern_buffer *bufp, struct re_registers *regs, unsigned int num_regs, regoff_t *starts, regoff_t *ends)
+re_set_registers (struct re_pattern_buffer *bufp, struct re_registers *regs,
+ ptrdiff_t num_regs, ptrdiff_t *starts, ptrdiff_t *ends)
{
if (num_regs)
{
@@ -4167,21 +3120,19 @@ re_set_registers (struct re_pattern_buffer *bufp, struct re_registers *regs, uns
regs->start = regs->end = 0;
}
}
-WEAK_ALIAS (__re_set_registers, re_set_registers)
/* Searching routines. */
/* Like re_search_2, below, but only one string is specified, and
doesn't let you say where to stop matching. */
-regoff_t
-re_search (struct re_pattern_buffer *bufp, const char *string, size_t size,
- ssize_t startpos, ssize_t range, struct re_registers *regs)
+ptrdiff_t
+re_search (struct re_pattern_buffer *bufp, const char *string, ptrdiff_t size,
+ ptrdiff_t startpos, ptrdiff_t range, struct re_registers *regs)
{
return re_search_2 (bufp, NULL, 0, string, size, startpos, range,
regs, size);
}
-WEAK_ALIAS (__re_search, re_search)
/* Head address of virtual concatenation of string. */
#define HEAD_ADDR_VSTRING(P) \
@@ -4208,25 +3159,26 @@ WEAK_ALIAS (__re_search, re_search)
Do not consider matching one past the index STOP in the virtual
concatenation of STRING1 and STRING2.
- We return either the position in the strings at which the match was
+ Return either the position in the strings at which the match was
found, -1 if no match, or -2 if error (such as failure
stack overflow). */
-regoff_t
-re_search_2 (struct re_pattern_buffer *bufp, const char *str1, size_t size1,
- const char *str2, size_t size2, ssize_t startpos, ssize_t range,
- struct re_registers *regs, ssize_t stop)
+ptrdiff_t
+re_search_2 (struct re_pattern_buffer *bufp, const char *str1, ptrdiff_t size1,
+ const char *str2, ptrdiff_t size2,
+ ptrdiff_t startpos, ptrdiff_t range,
+ struct re_registers *regs, ptrdiff_t stop)
{
- regoff_t val;
+ ptrdiff_t val;
re_char *string1 = (re_char *) str1;
re_char *string2 = (re_char *) str2;
- register char *fastmap = bufp->fastmap;
- register RE_TRANSLATE_TYPE translate = bufp->translate;
- size_t total_size = size1 + size2;
- ssize_t endpos = startpos + range;
- boolean anchored_start;
+ char *fastmap = bufp->fastmap;
+ Lisp_Object translate = bufp->translate;
+ ptrdiff_t total_size = size1 + size2;
+ ptrdiff_t endpos = startpos + range;
+ bool anchored_start;
/* Nonzero if we are searching multibyte string. */
- const boolean multibyte = RE_TARGET_MULTIBYTE_P (bufp);
+ bool multibyte = RE_TARGET_MULTIBYTE_P (bufp);
/* Check for out-of-range STARTPOS. */
if (startpos < 0 || startpos > total_size)
@@ -4250,7 +3202,6 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, size_t size1,
range = 0;
}
-#ifdef emacs
/* In a forward search for something that starts with \=.
don't keep searching past point. */
if (bufp->used > 0 && (re_opcode_t) bufp->buffer[0] == at_dot && range > 0)
@@ -4259,7 +3210,6 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, size_t size1,
if (range < 0)
return -1;
}
-#endif /* emacs */
/* Update the fastmap now if not correct already. */
if (fastmap && !bufp->fastmap_accurate)
@@ -4268,21 +3218,19 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, size_t size1,
/* See whether the pattern is anchored. */
anchored_start = (bufp->buffer[0] == begline);
-#ifdef emacs
gl_state.object = re_match_object; /* Used by SYNTAX_TABLE_BYTE_TO_CHAR. */
{
- ssize_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (POS_AS_IN_BUFFER (startpos));
+ ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (POS_AS_IN_BUFFER (startpos));
SETUP_SYNTAX_TABLE_FOR_OBJECT (re_match_object, charpos, 1);
}
-#endif
/* Loop through the string, looking for a place to start matching. */
for (;;)
{
/* If the pattern is anchored,
skip quickly past places we cannot match.
- We don't bother to treat startpos == 0 specially
+ Don't bother to treat startpos == 0 specially
because that case doesn't repeat. */
if (anchored_start && startpos > 0)
{
@@ -4298,21 +3246,21 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, size_t size1,
the first null string. */
if (fastmap && startpos < total_size && !bufp->can_be_null)
{
- register re_char *d;
- register re_wchar_t buf_ch;
+ re_char *d;
+ int buf_ch;
d = POS_ADDR_VSTRING (startpos);
if (range > 0) /* Searching forwards. */
{
- ssize_t irange = range, lim = 0;
+ ptrdiff_t irange = range, lim = 0;
if (startpos < size1 && startpos + range >= size1)
lim = range - (size1 - startpos);
- /* Written out as an if-else to avoid testing `translate'
+ /* Written out as an if-else to avoid testing 'translate'
inside the loop. */
- if (RE_TRANSLATE_P (translate))
+ if (!NILP (translate))
{
if (multibyte)
while (range > lim)
@@ -4330,11 +3278,9 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, size_t size1,
else
while (range > lim)
{
- register re_wchar_t ch, translated;
-
buf_ch = *d;
- ch = RE_CHAR_TO_MULTIBYTE (buf_ch);
- translated = RE_TRANSLATE (translate, ch);
+ int ch = RE_CHAR_TO_MULTIBYTE (buf_ch);
+ int translated = RE_TRANSLATE (translate, ch);
if (translated != ch
&& (ch = RE_CHAR_TO_UNIBYTE (translated)) >= 0)
buf_ch = ch;
@@ -4377,11 +3323,9 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, size_t size1,
}
else
{
- register re_wchar_t ch, translated;
-
buf_ch = *d;
- ch = RE_CHAR_TO_MULTIBYTE (buf_ch);
- translated = TRANSLATE (ch);
+ int ch = RE_CHAR_TO_MULTIBYTE (buf_ch);
+ int translated = TRANSLATE (ch);
if (translated != ch
&& (ch = RE_CHAR_TO_UNIBYTE (translated)) >= 0)
buf_ch = ch;
@@ -4451,17 +3395,14 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, size_t size1,
}
return -1;
} /* re_search_2 */
-WEAK_ALIAS (__re_search_2, re_search_2)
/* Declarations and macros for re_match_2. */
-static int bcmp_translate (re_char *s1, re_char *s2,
- register ssize_t len,
- RE_TRANSLATE_TYPE translate,
- const int multibyte);
+static bool bcmp_translate (re_char *, re_char *, ptrdiff_t,
+ Lisp_Object, bool);
-/* This converts PTR, a pointer into one of the search strings `string1'
- and `string2' into an offset from the beginning of that string. */
+/* This converts PTR, a pointer into one of the search strings 'string1'
+ and 'string2' into an offset from the beginning of that string. */
#define POINTER_TO_OFFSET(ptr) \
(FIRST_STRING_P (ptr) \
? (ptr) - string1 \
@@ -4485,7 +3426,7 @@ static int bcmp_translate (re_char *s1, re_char *s2,
/* Call before fetching a char with *d if you already checked other limits.
This is meant for use in lookahead operations like wordend, etc..
where we might need to look at parts of the string that might be
- outside of the LIMITs (i.e past `stop'). */
+ outside of the LIMITs (i.e past 'stop'). */
#define PREFETCH_NOLIMIT() \
if (d == end1) \
{ \
@@ -4494,7 +3435,7 @@ static int bcmp_translate (re_char *s1, re_char *s2,
} \
/* Test if at very beginning or at very end of the virtual concatenation
- of `string1' and `string2'. If only one string, it's `string2'. */
+ of STRING1 and STRING2. If only one string, it's STRING2. */
#define AT_STRINGS_BEG(d) ((d) == (size1 ? string1 : string2) || !size2)
#define AT_STRINGS_END(d) ((d) == end2)
@@ -4525,36 +3466,13 @@ static int bcmp_translate (re_char *s1, re_char *s2,
|| WORDCHAR_P (d - 1) != WORDCHAR_P (d))
#endif
-/* Free everything we malloc. */
-#ifdef MATCH_MAY_ALLOCATE
-# define FREE_VAR(var) \
- do { \
- if (var) \
- { \
- REGEX_FREE (var); \
- var = NULL; \
- } \
- } while (0)
-# define FREE_VARIABLES() \
- do { \
- REGEX_FREE_STACK (fail_stack.stack); \
- FREE_VAR (regstart); \
- FREE_VAR (regend); \
- FREE_VAR (best_regstart); \
- FREE_VAR (best_regend); \
- REGEX_SAFE_FREE (); \
- } while (0)
-#else
-# define FREE_VARIABLES() ((void)0) /* Do nothing! But inhibit gcc warning. */
-#endif /* not MATCH_MAY_ALLOCATE */
-
/* Optimization routines. */
/* If the operation is a match against one or more chars,
return a pointer to the next operation, else return NULL. */
static re_char *
-skip_one_char (const_re_char *p)
+skip_one_char (re_char *p)
{
switch (*p++)
{
@@ -4580,10 +3498,8 @@ skip_one_char (const_re_char *p)
case syntaxspec:
case notsyntaxspec:
-#ifdef emacs
case categoryspec:
case notcategoryspec:
-#endif /* emacs */
p++;
break;
@@ -4596,7 +3512,7 @@ skip_one_char (const_re_char *p)
/* Jump over non-matching operations. */
static re_char *
-skip_noops (const_re_char *p, const_re_char *pend)
+skip_noops (re_char *p, re_char *pend)
{
int mcnt;
while (p < pend)
@@ -4617,7 +3533,7 @@ skip_noops (const_re_char *p, const_re_char *pend)
return p;
}
}
- assert (p == pend);
+ eassert (p == pend);
return p;
}
@@ -4627,8 +3543,9 @@ skip_noops (const_re_char *p, const_re_char *pend)
character (i.e. without any translations). UNIBYTE denotes whether c is
unibyte or multibyte character. */
static bool
-execute_charset (const_re_char **pp, unsigned c, unsigned corig, bool unibyte)
+execute_charset (re_char **pp, int c, int corig, bool unibyte)
{
+ eassume (0 <= c && 0 <= corig);
re_char *p = *pp, *rtp = NULL;
bool not = (re_opcode_t) *p == charset_not;
@@ -4644,17 +3561,16 @@ execute_charset (const_re_char **pp, unsigned c, unsigned corig, bool unibyte)
if (unibyte && c < (1 << BYTEWIDTH))
{ /* Lookup bitmap. */
- /* Cast to `unsigned' instead of `unsigned char' in
+ /* Cast to 'unsigned' instead of 'unsigned char' in
case the bit list is a full 32 bytes long. */
if (c < (unsigned) (CHARSET_BITMAP_SIZE (p) * BYTEWIDTH)
&& p[2 + c / BYTEWIDTH] & (1 << (c % BYTEWIDTH)))
return !not;
}
-#ifdef emacs
else if (rtp)
{
int class_bits = CHARSET_RANGE_TABLE_BITS (p);
- re_wchar_t range_start, range_end;
+ int range_start, range_end;
/* Sort tests by the most commonly used classes with some adjustment to which
tests are easiest to perform. Take a look at comment in re_wctype_parse
@@ -4685,21 +3601,21 @@ execute_charset (const_re_char **pp, unsigned c, unsigned corig, bool unibyte)
return !not;
}
}
-#endif /* emacs */
+
return not;
}
-/* Non-zero if "p1 matches something" implies "p2 fails". */
-static int
-mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1,
- const_re_char *p2)
+/* True if "p1 matches something" implies "p2 fails". */
+static bool
+mutually_exclusive_p (struct re_pattern_buffer *bufp, re_char *p1,
+ re_char *p2)
{
re_opcode_t op2;
- const boolean multibyte = RE_MULTIBYTE_P (bufp);
+ bool multibyte = RE_MULTIBYTE_P (bufp);
unsigned char *pend = bufp->buffer + bufp->used;
- assert (p1 >= bufp->buffer && p1 < pend
- && p2 >= bufp->buffer && p2 <= pend);
+ eassert (p1 >= bufp->buffer && p1 < pend
+ && p2 >= bufp->buffer && p2 <= pend);
/* Skip over open/close-group commands.
If what follows this loop is a ...+ construct,
@@ -4710,8 +3626,8 @@ mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1,
is only used in the case where p1 is a simple match operator. */
/* p1 = skip_noops (p1, pend); */
- assert (p1 >= bufp->buffer && p1 < pend
- && p2 >= bufp->buffer && p2 <= pend);
+ eassert (p1 >= bufp->buffer && p1 < pend
+ && p2 >= bufp->buffer && p2 <= pend);
op2 = p2 == pend ? succeed : *p2;
@@ -4723,14 +3639,14 @@ mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1,
if (skip_one_char (p1))
{
DEBUG_PRINT (" End of pattern: fast loop.\n");
- return 1;
+ return true;
}
break;
case endline:
case exactn:
{
- register re_wchar_t c
+ int c
= (re_opcode_t) *p2 == endline ? '\n'
: RE_STRING_CHAR (p2 + 2, multibyte);
@@ -4739,24 +3655,24 @@ mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1,
if (c != RE_STRING_CHAR (p1 + 2, multibyte))
{
DEBUG_PRINT (" '%c' != '%c' => fast loop.\n", c, p1[2]);
- return 1;
+ return true;
}
}
else if ((re_opcode_t) *p1 == charset
|| (re_opcode_t) *p1 == charset_not)
{
- if (!execute_charset (&p1, c, c, !multibyte || IS_REAL_ASCII (c)))
+ if (!execute_charset (&p1, c, c, !multibyte || ASCII_CHAR_P (c)))
{
DEBUG_PRINT (" No match => fast loop.\n");
- return 1;
+ return true;
}
}
else if ((re_opcode_t) *p1 == anychar
&& c == '\n')
{
DEBUG_PRINT (" . != \\n => fast loop.\n");
- return 1;
+ return true;
}
}
break;
@@ -4773,10 +3689,10 @@ mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1,
else if (!multibyte || !CHARSET_RANGE_TABLE_EXISTS_P (p2))
{
/* Now, we are sure that P2 has no range table.
- So, for the size of bitmap in P2, `p2[1]' is
+ So, for the size of bitmap in P2, 'p2[1]' is
enough. But P1 may have range table, so the
size of bitmap table of P1 is extracted by
- using macro `CHARSET_BITMAP_SIZE'.
+ using macro 'CHARSET_BITMAP_SIZE'.
In a multibyte case, we know that all the character
listed in P2 is ASCII. In a unibyte case, P1 has only a
@@ -4799,7 +3715,7 @@ mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1,
|| idx == CHARSET_BITMAP_SIZE (p1))
{
DEBUG_PRINT (" No match => fast loop.\n");
- return 1;
+ return true;
}
}
else if ((re_opcode_t) *p1 == charset_not)
@@ -4816,7 +3732,7 @@ mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1,
if (idx == p2[1])
{
DEBUG_PRINT (" No match => fast loop.\n");
- return 1;
+ return true;
}
}
}
@@ -4860,83 +3776,64 @@ mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1,
|| (re_opcode_t) *p1 == syntaxspec)
&& p1[1] == Sword);
-#ifdef emacs
case categoryspec:
return ((re_opcode_t) *p1 == notcategoryspec && p1[1] == p2[1]);
case notcategoryspec:
return ((re_opcode_t) *p1 == categoryspec && p1[1] == p2[1]);
-#endif /* emacs */
default:
;
}
/* Safe default. */
- return 0;
+ return false;
}
/* Matching routines. */
-#ifndef emacs /* Emacs never uses this. */
-/* re_match is like re_match_2 except it takes only a single string. */
-
-regoff_t
-re_match (struct re_pattern_buffer *bufp, const char *string,
- size_t size, ssize_t pos, struct re_registers *regs)
-{
- regoff_t result = re_match_2_internal (bufp, NULL, 0, (re_char *) string,
- size, pos, regs, size);
- return result;
-}
-WEAK_ALIAS (__re_match, re_match)
-#endif /* not emacs */
-
/* re_match_2 matches the compiled pattern in BUFP against the
the (virtual) concatenation of STRING1 and STRING2 (of length SIZE1
and SIZE2, respectively). We start matching at POS, and stop
matching at STOP.
- If REGS is non-null and the `no_sub' field of BUFP is nonzero, we
- store offsets for the substring each group matched in REGS. See the
- documentation for exactly how many groups we fill.
+ If REGS is non-null, store offsets for the substring each group
+ matched in REGS.
We return -1 if no match, -2 if an internal error (such as the
failure stack overflowing). Otherwise, we return the length of the
matched substring. */
-regoff_t
-re_match_2 (struct re_pattern_buffer *bufp, const char *string1,
- size_t size1, const char *string2, size_t size2, ssize_t pos,
- struct re_registers *regs, ssize_t stop)
+ptrdiff_t
+re_match_2 (struct re_pattern_buffer *bufp,
+ char const *string1, ptrdiff_t size1,
+ char const *string2, ptrdiff_t size2,
+ ptrdiff_t pos, struct re_registers *regs, ptrdiff_t stop)
{
- regoff_t result;
+ ptrdiff_t result;
-#ifdef emacs
- ssize_t charpos;
+ ptrdiff_t charpos;
gl_state.object = re_match_object; /* Used by SYNTAX_TABLE_BYTE_TO_CHAR. */
charpos = SYNTAX_TABLE_BYTE_TO_CHAR (POS_AS_IN_BUFFER (pos));
SETUP_SYNTAX_TABLE_FOR_OBJECT (re_match_object, charpos, 1);
-#endif
result = re_match_2_internal (bufp, (re_char *) string1, size1,
(re_char *) string2, size2,
pos, regs, stop);
return result;
}
-WEAK_ALIAS (__re_match_2, re_match_2)
/* This is a separate function so that we can force an alloca cleanup
afterwards. */
-static regoff_t
-re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
- size_t size1, const_re_char *string2, size_t size2,
- ssize_t pos, struct re_registers *regs, ssize_t stop)
+static ptrdiff_t
+re_match_2_internal (struct re_pattern_buffer *bufp,
+ re_char *string1, ptrdiff_t size1,
+ re_char *string2, ptrdiff_t size2,
+ ptrdiff_t pos, struct re_registers *regs, ptrdiff_t stop)
{
/* General temporaries. */
int mcnt;
- size_t reg;
/* Just past the end of the corresponding string. */
re_char *end1, *end2;
@@ -4959,13 +3856,13 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
re_char *pend = p + bufp->used;
/* We use this to map every character in the string. */
- RE_TRANSLATE_TYPE translate = bufp->translate;
+ Lisp_Object translate = bufp->translate;
- /* Nonzero if BUFP is setup from a multibyte regex. */
- const boolean multibyte = RE_MULTIBYTE_P (bufp);
+ /* True if BUFP is setup from a multibyte regex. */
+ bool multibyte = RE_MULTIBYTE_P (bufp);
- /* Nonzero if STRING1/STRING2 are multibyte. */
- const boolean target_multibyte = RE_TARGET_MULTIBYTE_P (bufp);
+ /* True if STRING1/STRING2 are multibyte. */
+ bool target_multibyte = RE_TARGET_MULTIBYTE_P (bufp);
/* Failure point stack. Each place that can handle a failure further
down the line pushes a failure point on this stack. It consists of
@@ -4974,23 +3871,16 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
registers, and, finally, two char *'s. The first char * is where
to resume scanning the pattern; the second one is where to resume
scanning the strings. */
-#ifdef MATCH_MAY_ALLOCATE /* otherwise, this is global. */
fail_stack_type fail_stack;
-#endif
#ifdef DEBUG_COMPILES_ARGUMENTS
- unsigned nfailure_points_pushed = 0, nfailure_points_popped = 0;
-#endif
-
-#if defined REL_ALLOC && defined REGEX_MALLOC
- /* This holds the pointer to the failure stack, when
- it is allocated relocatably. */
- fail_stack_elt_t *failure_stack_ptr;
+ ptrdiff_t nfailure_points_pushed = 0, nfailure_points_popped = 0;
#endif
/* We fill all the registers internally, independent of what we
return, for use in backreferences. The number here includes
an element for register zero. */
- size_t num_regs = bufp->re_nsub + 1;
+ ptrdiff_t num_regs = bufp->re_nsub + 1;
+ eassume (0 < num_regs);
/* Information on the contents of registers. These are pointers into
the input strings; they record just what was matched (on this
@@ -4999,24 +3889,20 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
matching and the regnum-th regend points to right after where we
stopped matching the regnum-th subexpression. (The zeroth register
keeps track of what the whole pattern matches.) */
-#ifdef MATCH_MAY_ALLOCATE /* otherwise, these are global. */
- re_char **regstart, **regend;
-#endif
+ re_char **regstart UNINIT, **regend UNINIT;
/* The following record the register info as found in the above
variables when we find a match better than any we've seen before.
This happens as we backtrack through the failure points, which in
turn happens only if we have not yet matched the entire string. */
- unsigned best_regs_set = false;
-#ifdef MATCH_MAY_ALLOCATE /* otherwise, these are global. */
- re_char **best_regstart, **best_regend;
-#endif
+ bool best_regs_set = false;
+ re_char **best_regstart UNINIT, **best_regend UNINIT;
- /* Logically, this is `best_regend[0]'. But we don't want to have to
+ /* Logically, this is 'best_regend[0]'. But we don't want to have to
allocate space for that if we're not allocating space for anything
else (see below). Also, we never need info about register 0 for
any of the other register vectors, and it seems rather a kludge to
- treat `best_regend' differently than the rest. So we keep track of
+ treat 'best_regend' differently than the rest. So we keep track of
the end of the best match so far in a separate variable. We
initialize this to NULL so that when we backtrack the first time
and need to test it, it's not garbage. */
@@ -5024,7 +3910,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
#ifdef DEBUG_COMPILES_ARGUMENTS
/* Counts the total number of registers pushed. */
- unsigned num_regs_pushed = 0;
+ ptrdiff_t num_regs_pushed = 0;
#endif
DEBUG_PRINT ("\n\nEntering re_match_2.\n");
@@ -5033,7 +3919,6 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
INIT_FAIL_STACK ();
-#ifdef MATCH_MAY_ALLOCATE
/* Do not bother to initialize all the register variables if there are
no groups in the pattern, as it takes a fair amount of time. If
there are groups, we include space for register 0 (the whole
@@ -5041,40 +3926,26 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
array indexing. We should fix this. */
if (bufp->re_nsub)
{
- regstart = REGEX_TALLOC (num_regs, re_char *);
- regend = REGEX_TALLOC (num_regs, re_char *);
- best_regstart = REGEX_TALLOC (num_regs, re_char *);
- best_regend = REGEX_TALLOC (num_regs, re_char *);
-
- if (!(regstart && regend && best_regstart && best_regend))
- {
- FREE_VARIABLES ();
- return -2;
- }
- }
- else
- {
- /* We must initialize all our variables to NULL, so that
- `FREE_VARIABLES' doesn't try to free them. */
- regstart = regend = best_regstart = best_regend = NULL;
+ regstart = SAFE_ALLOCA (num_regs * 4 * sizeof *regstart);
+ regend = regstart + num_regs;
+ best_regstart = regend + num_regs;
+ best_regend = best_regstart + num_regs;
}
-#endif /* MATCH_MAY_ALLOCATE */
/* The starting position is bogus. */
if (pos < 0 || pos > size1 + size2)
{
- FREE_VARIABLES ();
+ SAFE_FREE ();
return -1;
}
/* Initialize subexpression text positions to -1 to mark ones that no
- start_memory/stop_memory has been seen for. Also initialize the
- register information struct. */
- for (reg = 1; reg < num_regs; reg++)
+ start_memory/stop_memory has been seen for. */
+ for (ptrdiff_t reg = 1; reg < num_regs; reg++)
regstart[reg] = regend[reg] = NULL;
- /* We move `string1' into `string2' if the latter's empty -- but not if
- `string1' is null. */
+ /* We move 'string1' into 'string2' if the latter's empty -- but not if
+ 'string1' is null. */
if (size2 == 0 && string1 != NULL)
{
string2 = string1;
@@ -5085,12 +3956,12 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
end1 = string1 + size1;
end2 = string2 + size2;
- /* `p' scans through the pattern as `d' scans through the data.
- `dend' is the end of the input string that `d' points within. `d'
- is advanced into the following input string whenever necessary, but
+ /* P scans through the pattern as D scans through the data.
+ DEND is the end of the input string that D points within.
+ Advance D into the following input string whenever necessary, but
this happens before fetching; therefore, at the beginning of the
- loop, `d' can be pointing at the end of a string, but it cannot
- equal `string2'. */
+ loop, D can be pointing at the end of a string, but it cannot
+ equal STRING2. */
if (pos >= size1)
{
/* Only match within string2. */
@@ -5107,7 +3978,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
/* BEWARE!
When we reach end_match_1, PREFETCH normally switches to string2.
But in the present case, this means that just doing a PREFETCH
- makes us jump from `stop' to `gap' within the string.
+ makes us jump from 'stop' to 'gap' within the string.
What we really want here is for the search to stop as
soon as we hit end_match_1. That's why we set end_match_2
to end_match_1 (since PREFETCH fails as soon as we hit
@@ -5115,8 +3986,8 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
end_match_2 = end_match_1;
}
else
- { /* It's important to use this code when stop == size so that
- moving `d' from end1 to string2 will not prevent the d == dend
+ { /* It's important to use this code when STOP == SIZE so that
+ moving D from end1 to string2 will not prevent the D == DEND
check from catching the end of string. */
end_match_1 = end1;
end_match_2 = string2 + stop - size1;
@@ -5177,7 +4048,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
DEBUG_PRINT ("\nSAVING match as best so far.\n");
- for (reg = 1; reg < num_regs; reg++)
+ for (ptrdiff_t reg = 1; reg < num_regs; reg++)
{
best_regstart[reg] = regstart[reg];
best_regend[reg] = regend[reg];
@@ -5192,10 +4063,10 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
else if (best_regs_set && !best_match_p)
{
restore_best_regs:
- /* Restore best match. It may happen that `dend ==
+ /* Restore best match. It may happen that 'dend ==
end_match_1' while the restored d is in string2.
- For example, the pattern `x.*y.*z' against the
- strings `x-' and `y-z-', if the two strings are
+ For example, the pattern 'x.*y.*z' against the
+ strings 'x-' and 'y-z-', if the two strings are
not consecutive in memory. */
DEBUG_PRINT ("Restoring best registers.\n");
@@ -5203,7 +4074,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
dend = ((d >= string1 && d <= end1)
? end_match_1 : end_match_2);
- for (reg = 1; reg < num_regs; reg++)
+ for (ptrdiff_t reg = 1; reg < num_regs; reg++)
{
regstart[reg] = best_regstart[reg];
regend[reg] = best_regend[reg];
@@ -5215,47 +4086,35 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
DEBUG_PRINT ("Accepting match.\n");
/* If caller wants register contents data back, do it. */
- if (regs && !bufp->no_sub)
+ if (regs)
{
/* Have the register data arrays been allocated? */
if (bufp->regs_allocated == REGS_UNALLOCATED)
- { /* No. So allocate them with malloc. We need one
- extra element beyond `num_regs' for the `-1' marker
- GNU code uses. */
- regs->num_regs = max (RE_NREGS, num_regs + 1);
- regs->start = TALLOC (regs->num_regs, regoff_t);
- regs->end = TALLOC (regs->num_regs, regoff_t);
- if (regs->start == NULL || regs->end == NULL)
- {
- FREE_VARIABLES ();
- return -2;
- }
+ { /* No. So allocate them with malloc. */
+ ptrdiff_t n = max (RE_NREGS, num_regs);
+ regs->start = xnmalloc (n, sizeof *regs->start);
+ regs->end = xnmalloc (n, sizeof *regs->end);
+ regs->num_regs = n;
bufp->regs_allocated = REGS_REALLOCATE;
}
else if (bufp->regs_allocated == REGS_REALLOCATE)
{ /* Yes. If we need more elements than were already
allocated, reallocate them. If we need fewer, just
leave it alone. */
- if (regs->num_regs < num_regs + 1)
+ ptrdiff_t n = regs->num_regs;
+ if (n < num_regs)
{
- regs->num_regs = num_regs + 1;
- RETALLOC (regs->start, regs->num_regs, regoff_t);
- RETALLOC (regs->end, regs->num_regs, regoff_t);
- if (regs->start == NULL || regs->end == NULL)
- {
- FREE_VARIABLES ();
- return -2;
- }
+ n = max (n + (n >> 1), num_regs);
+ regs->start
+ = xnrealloc (regs->start, n, sizeof *regs->start);
+ regs->end = xnrealloc (regs->end, n, sizeof *regs->end);
+ regs->num_regs = n;
}
}
else
- {
- /* These braces fend off a "empty body in an else-statement"
- warning under GCC when assert expands to nothing. */
- assert (bufp->regs_allocated == REGS_FIXED);
- }
+ eassert (bufp->regs_allocated == REGS_FIXED);
- /* Convert the pointer data in `regstart' and `regend' to
+ /* Convert the pointer data in 'regstart' and 'regend' to
indices. Register zero has to be set differently,
since we haven't kept track of any info for it. */
if (regs->num_regs > 0)
@@ -5264,9 +4123,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
regs->end[0] = POINTER_TO_OFFSET (d);
}
- /* Go through the first `min (num_regs, regs->num_regs)'
- registers, since that is all we initialized. */
- for (reg = 1; reg < min (num_regs, regs->num_regs); reg++)
+ for (ptrdiff_t reg = 1; reg < num_regs; reg++)
{
if (REG_UNSET (regstart[reg]) || REG_UNSET (regend[reg]))
regs->start[reg] = regs->end[reg] = -1;
@@ -5278,24 +4135,21 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
}
/* If the regs structure we return has more elements than
- were in the pattern, set the extra elements to -1. If
- we (re)allocated the registers, this is the case,
- because we always allocate enough to have at least one
- -1 at the end. */
- for (reg = num_regs; reg < regs->num_regs; reg++)
+ were in the pattern, set the extra elements to -1. */
+ for (ptrdiff_t reg = num_regs; reg < regs->num_regs; reg++)
regs->start[reg] = regs->end[reg] = -1;
- } /* regs && !bufp->no_sub */
+ }
- DEBUG_PRINT ("%u failure points pushed, %u popped (%u remain).\n",
+ DEBUG_PRINT ("%td failure points pushed, %td popped (%td remain).\n",
nfailure_points_pushed, nfailure_points_popped,
nfailure_points_pushed - nfailure_points_popped);
- DEBUG_PRINT ("%u registers pushed.\n", num_regs_pushed);
+ DEBUG_PRINT ("%td registers pushed.\n", num_regs_pushed);
ptrdiff_t dcnt = POINTER_TO_OFFSET (d) - pos;
DEBUG_PRINT ("Returning %td from re_match_2.\n", dcnt);
- FREE_VARIABLES ();
+ SAFE_FREE ();
return dcnt;
}
@@ -5322,34 +4176,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
/* Remember the start point to rollback upon failure. */
dfail = d;
-#ifndef emacs
- /* This is written out as an if-else so we don't waste time
- testing `translate' inside the loop. */
- if (RE_TRANSLATE_P (translate))
- do
- {
- PREFETCH ();
- if (RE_TRANSLATE (translate, *d) != *p++)
- {
- d = dfail;
- goto fail;
- }
- d++;
- }
- while (--mcnt);
- else
- do
- {
- PREFETCH ();
- if (*d++ != *p++)
- {
- d = dfail;
- goto fail;
- }
- }
- while (--mcnt);
-#else /* emacs */
- /* The cost of testing `translate' is comparatively small. */
+ /* The cost of testing 'translate' is comparatively small. */
if (target_multibyte)
do
{
@@ -5413,16 +4240,15 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
d++;
}
while (--mcnt);
-#endif
+
break;
- /* Match any character except possibly a newline or a null. */
+ /* Match any character except newline. */
case anychar:
{
int buf_charlen;
- re_wchar_t buf_ch;
- reg_syntax_t syntax;
+ int buf_ch;
DEBUG_PRINT ("EXECUTING anychar.\n");
@@ -5430,15 +4256,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
buf_ch = RE_STRING_CHAR_AND_LENGTH (d, buf_charlen,
target_multibyte);
buf_ch = TRANSLATE (buf_ch);
-
-#ifdef emacs
- syntax = RE_SYNTAX_EMACS;
-#else
- syntax = bufp->syntax;
-#endif
-
- if ((!(syntax & RE_DOT_NEWLINE) && buf_ch == '\n')
- || ((syntax & RE_DOT_NOT_NULL) && buf_ch == '\000'))
+ if (buf_ch == '\n')
goto fail;
DEBUG_PRINT (" Matched \"%d\".\n", *d);
@@ -5450,17 +4268,16 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
case charset:
case charset_not:
{
- register unsigned int c, corig;
- int len;
-
/* Whether matching against a unibyte character. */
- boolean unibyte_char = false;
+ bool unibyte_char = false;
DEBUG_PRINT ("EXECUTING charset%s.\n",
(re_opcode_t) *(p - 1) == charset_not ? "_not" : "");
PREFETCH ();
- corig = c = RE_STRING_CHAR_AND_LENGTH (d, len, target_multibyte);
+ int len;
+ int corig = RE_STRING_CHAR_AND_LENGTH (d, len, target_multibyte);
+ int c = corig;
if (target_multibyte)
{
int c1;
@@ -5524,11 +4341,11 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
case stop_memory:
DEBUG_PRINT ("EXECUTING stop_memory %d:\n", *p);
- assert (!REG_UNSET (regstart[*p]));
+ eassert (!REG_UNSET (regstart[*p]));
/* Strictly speaking, there should be code such as:
- assert (REG_UNSET (regend[*p]));
- PUSH_FAILURE_REGSTOP ((unsigned int)*p);
+ eassert (REG_UNSET (regend[*p]));
+ PUSH_FAILURE_REGSTOP (*p);
But the only info to be pushed is regend[*p] and it is known to
be UNSET, so there really isn't anything to push.
@@ -5547,11 +4364,11 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
break;
- /* \<digit> has been turned into a `duplicate' command which is
+ /* \<digit> has been turned into a 'duplicate' command which is
followed by the numeric value of <digit> as the register number. */
case duplicate:
{
- register re_char *d2, *dend2;
+ re_char *d2, *dend2;
int regno = *p++; /* Get which register to match against. */
DEBUG_PRINT ("EXECUTING duplicate %d.\n", regno);
@@ -5604,7 +4421,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
/* Compare that many; failure if mismatch, else move
past them. */
- if (RE_TRANSLATE_P (translate)
+ if (!NILP (translate)
? bcmp_translate (d, d2, dcnt, translate, target_multibyte)
: memcmp (d, d2, dcnt))
{
@@ -5617,15 +4434,13 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
break;
- /* begline matches the empty string at the beginning of the string
- (unless `not_bol' is set in `bufp'), and after newlines. */
+ /* begline matches the empty string at the beginning of the string,
+ and after newlines. */
case begline:
DEBUG_PRINT ("EXECUTING begline.\n");
if (AT_STRINGS_BEG (d))
- {
- if (!bufp->not_bol) break;
- }
+ break;
else
{
unsigned c;
@@ -5633,7 +4448,6 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
if (c == '\n')
break;
}
- /* In all other cases, we fail. */
goto fail;
@@ -5642,15 +4456,10 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
DEBUG_PRINT ("EXECUTING endline.\n");
if (AT_STRINGS_END (d))
- {
- if (!bufp->not_eol) break;
- }
- else
- {
- PREFETCH_NOLIMIT ();
- if (*d == '\n')
- break;
- }
+ break;
+ PREFETCH_NOLIMIT ();
+ if (*d == '\n')
+ break;
goto fail;
@@ -5670,21 +4479,21 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
goto fail;
- /* on_failure_keep_string_jump is used to optimize `.*\n'. It
+ /* on_failure_keep_string_jump is used to optimize '.*\n'. It
pushes NULL as the value for the string on the stack. Then
- `POP_FAILURE_POINT' will keep the current value for the
+ 'POP_FAILURE_POINT' will keep the current value for the
string, instead of restoring it. To see why, consider
- matching `foo\nbar' against `.*\n'. The .* matches the foo;
+ matching 'foo\nbar' against '.*\n'. The .* matches the foo;
then the . fails against the \n. But the next thing we want
to do is match the \n against the \n; if we restored the
string value, we would be back at the foo.
Because this is used only in specific cases, we don't need to
- check all the things that `on_failure_jump' does, to make
+ check all the things that 'on_failure_jump' does, to make
sure the right things get saved on the stack. Hence we don't
share its code. The only reason to push anything on the
stack at all is that otherwise we would have to change
- `anychar's code to do something besides goto fail in this
+ 'anychar's code to do something besides goto fail in this
case; that seems worse than this. */
case on_failure_keep_string_jump:
EXTRACT_NUMBER_AND_INCR (mcnt, p);
@@ -5713,9 +4522,9 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
DEBUG_PRINT ("EXECUTING on_failure_jump_nastyloop %d (to %p):\n",
mcnt, p + mcnt);
- assert ((re_opcode_t)p[-4] == no_op);
+ eassert ((re_opcode_t)p[-4] == no_op);
{
- int cycle = 0;
+ bool cycle = false;
CHECK_INFINITE_LOOP (p - 4, d);
if (!cycle)
/* If there's a cycle, just continue without pushing
@@ -5734,11 +4543,11 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
DEBUG_PRINT ("EXECUTING on_failure_jump_loop %d (to %p):\n",
mcnt, p + mcnt);
{
- int cycle = 0;
+ bool cycle = false;
CHECK_INFINITE_LOOP (p - 3, d);
if (cycle)
/* If there's a cycle, get out of the loop, as if the matching
- had failed. We used to just `goto fail' here, but that was
+ had failed. We used to just 'goto fail' here, but that was
aborting the search a bit too early: we want to keep the
empty-loop-match and keep matching after the loop.
We want (x?)*y\1z to match both xxyz and xxyxz. */
@@ -5773,7 +4582,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
Compare the beginning of the repeat with what in the
pattern follows its end. If we can establish that there
is nothing that they would both match, i.e., that we
- would have to backtrack because of (as in, e.g., `a*a')
+ would have to backtrack because of (as in, e.g., 'a*a')
then we can use a non-backtracking loop based on
on_failure_keep_string_jump instead of on_failure_jump. */
case on_failure_jump_smart:
@@ -5782,7 +4591,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
mcnt, p + mcnt);
{
re_char *p1 = p; /* Next operation. */
- /* Here, we discard `const', making re_match non-reentrant. */
+ /* Discard 'const', making re_search non-reentrant. */
unsigned char *p2 = (unsigned char *) p + mcnt; /* Jump dest. */
unsigned char *p3 = (unsigned char *) p - 3; /* opcode location. */
@@ -5793,23 +4602,23 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
/* Ensure this is indeed the trivial kind of loop
we are expecting. */
- assert (skip_one_char (p1) == p2 - 3);
- assert ((re_opcode_t) p2[-3] == jump && p2 + mcnt == p);
- DEBUG_STATEMENT (debug += 2);
+ eassert (skip_one_char (p1) == p2 - 3);
+ eassert ((re_opcode_t) p2[-3] == jump && p2 + mcnt == p);
+ DEBUG_STATEMENT (regex_emacs_debug += 2);
if (mutually_exclusive_p (bufp, p1, p2))
{
- /* Use a fast `on_failure_keep_string_jump' loop. */
+ /* Use a fast 'on_failure_keep_string_jump' loop. */
DEBUG_PRINT (" smart exclusive => fast loop.\n");
*p3 = (unsigned char) on_failure_keep_string_jump;
STORE_NUMBER (p2 - 2, mcnt + 3);
}
else
{
- /* Default to a safe `on_failure_jump' loop. */
+ /* Default to a safe 'on_failure_jump' loop. */
DEBUG_PRINT (" smart default => slow loop.\n");
*p3 = (unsigned char) on_failure_jump;
}
- DEBUG_STATEMENT (debug -= 2);
+ DEBUG_STATEMENT (regex_emacs_debug -= 2);
}
break;
@@ -5825,7 +4634,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
/* Have to succeed matching what follows at least n times.
- After that, handle like `on_failure_jump'. */
+ After that, handle like 'on_failure_jump'. */
case succeed_n:
/* Signedness doesn't matter since we only compare MCNT to 0. */
EXTRACT_NUMBER (mcnt, p + 2);
@@ -5834,7 +4643,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
/* Originally, mcnt is how many times we HAVE to succeed. */
if (mcnt != 0)
{
- /* Here, we discard `const', making re_match non-reentrant. */
+ /* Discard 'const', making re_search non-reentrant. */
unsigned char *p2 = (unsigned char *) p + 2; /* counter loc. */
mcnt--;
p += 4;
@@ -5853,7 +4662,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
/* Originally, this is how many times we CAN jump. */
if (mcnt != 0)
{
- /* Here, we discard `const', making re_match non-reentrant. */
+ /* Discard 'const', making re_search non-reentrant. */
unsigned char *p2 = (unsigned char *) p + 2; /* counter loc. */
mcnt--;
PUSH_NUMBER (p2, mcnt);
@@ -5870,7 +4679,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
DEBUG_PRINT ("EXECUTING set_number_at.\n");
EXTRACT_NUMBER_AND_INCR (mcnt, p);
- /* Here, we discard `const', making re_match non-reentrant. */
+ /* Discard 'const', making re_search non-reentrant. */
p2 = (unsigned char *) p + mcnt;
/* Signedness doesn't matter since we only copy MCNT's bits. */
EXTRACT_NUMBER_AND_INCR (mcnt, p);
@@ -5882,7 +4691,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
case wordbound:
case notwordbound:
{
- boolean not = (re_opcode_t) *(p - 1) == notwordbound;
+ bool not = (re_opcode_t) *(p - 1) == notwordbound;
DEBUG_PRINT ("EXECUTING %swordbound.\n", not ? "not" : "");
/* We SUCCEED (or FAIL) in one of the following cases: */
@@ -5894,19 +4703,15 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
{
/* C1 is the character before D, S1 is the syntax of C1, C2
is the character at D, and S2 is the syntax of C2. */
- re_wchar_t c1, c2;
+ int c1, c2;
int s1, s2;
int dummy;
-#ifdef emacs
- ssize_t offset = PTR_TO_OFFSET (d - 1);
- ssize_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset);
- UPDATE_SYNTAX_TABLE_FAST (charpos);
-#endif
+ ptrdiff_t offset = PTR_TO_OFFSET (d);
+ ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset) - 1;
+ UPDATE_SYNTAX_TABLE (charpos);
GET_CHAR_BEFORE_2 (c1, d, string1, end1, string2, end2);
s1 = SYNTAX (c1);
-#ifdef emacs
- UPDATE_SYNTAX_TABLE_FORWARD_FAST (charpos + 1);
-#endif
+ UPDATE_SYNTAX_TABLE_FORWARD (charpos + 1);
PREFETCH_NOLIMIT ();
GET_CHAR_AFTER (c2, d, dummy);
s2 = SYNTAX (c2);
@@ -5936,14 +4741,12 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
{
/* C1 is the character before D, S1 is the syntax of C1, C2
is the character at D, and S2 is the syntax of C2. */
- re_wchar_t c1, c2;
+ int c1, c2;
int s1, s2;
int dummy;
-#ifdef emacs
- ssize_t offset = PTR_TO_OFFSET (d);
- ssize_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset);
- UPDATE_SYNTAX_TABLE_FAST (charpos);
-#endif
+ ptrdiff_t offset = PTR_TO_OFFSET (d);
+ ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset);
+ UPDATE_SYNTAX_TABLE (charpos);
PREFETCH ();
GET_CHAR_AFTER (c2, d, dummy);
s2 = SYNTAX (c2);
@@ -5956,9 +4759,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
if (!AT_STRINGS_BEG (d))
{
GET_CHAR_BEFORE_2 (c1, d, string1, end1, string2, end2);
-#ifdef emacs
UPDATE_SYNTAX_TABLE_BACKWARD (charpos - 1);
-#endif
s1 = SYNTAX (c1);
/* ... and S1 is Sword, and WORD_BOUNDARY_P (C1, C2)
@@ -5981,14 +4782,12 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
{
/* C1 is the character before D, S1 is the syntax of C1, C2
is the character at D, and S2 is the syntax of C2. */
- re_wchar_t c1, c2;
+ int c1, c2;
int s1, s2;
int dummy;
-#ifdef emacs
- ssize_t offset = PTR_TO_OFFSET (d) - 1;
- ssize_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset);
- UPDATE_SYNTAX_TABLE_FAST (charpos);
-#endif
+ ptrdiff_t offset = PTR_TO_OFFSET (d);
+ ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset) - 1;
+ UPDATE_SYNTAX_TABLE (charpos);
GET_CHAR_BEFORE_2 (c1, d, string1, end1, string2, end2);
s1 = SYNTAX (c1);
@@ -6001,9 +4800,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
{
PREFETCH_NOLIMIT ();
GET_CHAR_AFTER (c2, d, dummy);
-#ifdef emacs
- UPDATE_SYNTAX_TABLE_FORWARD_FAST (charpos);
-#endif
+ UPDATE_SYNTAX_TABLE_FORWARD (charpos + 1);
s2 = SYNTAX (c2);
/* ... and S2 is Sword, and WORD_BOUNDARY_P (C1, C2)
@@ -6026,13 +4823,11 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
{
/* C1 is the character before D, S1 is the syntax of C1, C2
is the character at D, and S2 is the syntax of C2. */
- re_wchar_t c1, c2;
+ int c1, c2;
int s1, s2;
-#ifdef emacs
- ssize_t offset = PTR_TO_OFFSET (d);
- ssize_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset);
- UPDATE_SYNTAX_TABLE_FAST (charpos);
-#endif
+ ptrdiff_t offset = PTR_TO_OFFSET (d);
+ ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset);
+ UPDATE_SYNTAX_TABLE (charpos);
PREFETCH ();
c2 = RE_STRING_CHAR (d, target_multibyte);
s2 = SYNTAX (c2);
@@ -6045,9 +4840,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
if (!AT_STRINGS_BEG (d))
{
GET_CHAR_BEFORE_2 (c1, d, string1, end1, string2, end2);
-#ifdef emacs
UPDATE_SYNTAX_TABLE_BACKWARD (charpos - 1);
-#endif
s1 = SYNTAX (c1);
/* ... and S1 is Sword or Ssymbol. */
@@ -6069,13 +4862,11 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
{
/* C1 is the character before D, S1 is the syntax of C1, C2
is the character at D, and S2 is the syntax of C2. */
- re_wchar_t c1, c2;
+ int c1, c2;
int s1, s2;
-#ifdef emacs
- ssize_t offset = PTR_TO_OFFSET (d) - 1;
- ssize_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset);
- UPDATE_SYNTAX_TABLE_FAST (charpos);
-#endif
+ ptrdiff_t offset = PTR_TO_OFFSET (d);
+ ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset) - 1;
+ UPDATE_SYNTAX_TABLE (charpos);
GET_CHAR_BEFORE_2 (c1, d, string1, end1, string2, end2);
s1 = SYNTAX (c1);
@@ -6088,9 +4879,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
{
PREFETCH_NOLIMIT ();
c2 = RE_STRING_CHAR (d, target_multibyte);
-#ifdef emacs
- UPDATE_SYNTAX_TABLE_FORWARD_FAST (charpos + 1);
-#endif
+ UPDATE_SYNTAX_TABLE_FORWARD (charpos + 1);
s2 = SYNTAX (c2);
/* ... and S2 is Sword or Ssymbol. */
@@ -6103,21 +4892,19 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
case syntaxspec:
case notsyntaxspec:
{
- boolean not = (re_opcode_t) *(p - 1) == notsyntaxspec;
+ bool not = (re_opcode_t) *(p - 1) == notsyntaxspec;
mcnt = *p++;
DEBUG_PRINT ("EXECUTING %ssyntaxspec %d.\n", not ? "not" : "",
mcnt);
PREFETCH ();
-#ifdef emacs
{
- ssize_t offset = PTR_TO_OFFSET (d);
- ssize_t pos1 = SYNTAX_TABLE_BYTE_TO_CHAR (offset);
- UPDATE_SYNTAX_TABLE_FAST (pos1);
+ ptrdiff_t offset = PTR_TO_OFFSET (d);
+ ptrdiff_t pos1 = SYNTAX_TABLE_BYTE_TO_CHAR (offset);
+ UPDATE_SYNTAX_TABLE (pos1);
}
-#endif
{
int len;
- re_wchar_t c;
+ int c;
GET_CHAR_AFTER (c, d, len);
if ((SYNTAX (c) != (enum syntaxcode) mcnt) ^ not)
@@ -6127,7 +4914,6 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
}
break;
-#ifdef emacs
case at_dot:
DEBUG_PRINT ("EXECUTING at_dot.\n");
if (PTR_BYTE_POS (d) != PT_BYTE)
@@ -6137,7 +4923,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
case categoryspec:
case notcategoryspec:
{
- boolean not = (re_opcode_t) *(p - 1) == notcategoryspec;
+ bool not = (re_opcode_t) *(p - 1) == notcategoryspec;
mcnt = *p++;
DEBUG_PRINT ("EXECUTING %scategoryspec %d.\n",
not ? "not" : "", mcnt);
@@ -6145,7 +4931,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
{
int len;
- re_wchar_t c;
+ int c;
GET_CHAR_AFTER (c, d, len);
if ((!CHAR_HAS_CATEGORY (c, mcnt)) ^ not)
goto fail;
@@ -6154,8 +4940,6 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
}
break;
-#endif /* emacs */
-
default:
abort ();
}
@@ -6174,11 +4958,11 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
switch (*pat++)
{
case on_failure_keep_string_jump:
- assert (str == NULL);
+ eassert (str == NULL);
goto continue_failure_jump;
case on_failure_jump_nastyloop:
- assert ((re_opcode_t)pat[-2] == no_op);
+ eassert ((re_opcode_t)pat[-2] == no_op);
PUSH_FAILURE_POINT (pat - 2, str);
FALLTHROUGH;
case on_failure_jump_loop:
@@ -6198,7 +4982,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
abort ();
}
- assert (p >= bufp->buffer && p <= pend);
+ eassert (p >= bufp->buffer && p <= pend);
if (d >= string1 && d <= end1)
dend = end_match_1;
@@ -6210,45 +4994,42 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
if (best_regs_set)
goto restore_best_regs;
- FREE_VARIABLES ();
+ SAFE_FREE ();
- return -1; /* Failure to match. */
+ return -1; /* Failure to match. */
}
/* Subroutine definitions for re_match_2. */
-/* Return zero if TRANSLATE[S1] and TRANSLATE[S2] are identical for LEN
- bytes; nonzero otherwise. */
+/* Return true if TRANSLATE[S1] and TRANSLATE[S2] are not identical
+ for LEN bytes. */
-static int
-bcmp_translate (const_re_char *s1, const_re_char *s2, register ssize_t len,
- RE_TRANSLATE_TYPE translate, const int target_multibyte)
+static bool
+bcmp_translate (re_char *s1, re_char *s2, ptrdiff_t len,
+ Lisp_Object translate, bool target_multibyte)
{
- register re_char *p1 = s1, *p2 = s2;
+ re_char *p1 = s1, *p2 = s2;
re_char *p1_end = s1 + len;
re_char *p2_end = s2 + len;
/* FIXME: Checking both p1 and p2 presumes that the two strings might have
- different lengths, but relying on a single `len' would break this. -sm */
+ different lengths, but relying on a single LEN would break this. -sm */
while (p1 < p1_end && p2 < p2_end)
{
int p1_charlen, p2_charlen;
- re_wchar_t p1_ch, p2_ch;
+ int p1_ch, p2_ch;
GET_CHAR_AFTER (p1_ch, p1, p1_charlen);
GET_CHAR_AFTER (p2_ch, p2, p2_charlen);
if (RE_TRANSLATE (translate, p1_ch)
!= RE_TRANSLATE (translate, p2_ch))
- return 1;
+ return true;
p1 += p1_charlen, p2 += p2_charlen;
}
- if (p1 != p1_end || p2 != p2_end)
- return 1;
-
- return 0;
+ return p1 != p1_end || p2 != p2_end;
}
/* Entry points for GNU code. */
@@ -6257,353 +5038,25 @@ bcmp_translate (const_re_char *s1, const_re_char *s2, register ssize_t len,
compiles PATTERN (of length SIZE) and puts the result in BUFP.
Returns 0 if the pattern was valid, otherwise an error string.
- Assumes the `allocated' (and perhaps `buffer') and `translate' fields
+ Assumes the 'allocated' (and perhaps 'buffer') and 'translate' fields
are set in BUFP on entry.
We call regex_compile to do the actual compilation. */
const char *
-re_compile_pattern (const char *pattern, size_t length,
-#ifdef emacs
+re_compile_pattern (const char *pattern, ptrdiff_t length,
bool posix_backtracking, const char *whitespace_regexp,
-#endif
struct re_pattern_buffer *bufp)
{
- reg_errcode_t ret;
-
- /* GNU code is written to assume at least RE_NREGS registers will be set
- (and at least one extra will be -1). */
bufp->regs_allocated = REGS_UNALLOCATED;
- /* And GNU code determines whether or not to get register information
- by passing null for the REGS argument to re_match, etc., not by
- setting no_sub. */
- bufp->no_sub = 0;
-
- ret = regex_compile ((re_char *) pattern, length,
-#ifdef emacs
+ reg_errcode_t ret
+ = regex_compile ((re_char *) pattern, length,
posix_backtracking,
whitespace_regexp,
-#else
- re_syntax_options,
-#endif
bufp);
if (!ret)
return NULL;
- return gettext (re_error_msgid[(int) ret]);
+ return re_error_msgid[ret];
}
-WEAK_ALIAS (__re_compile_pattern, re_compile_pattern)
-
-/* Entry points compatible with 4.2 BSD regex library. We don't define
- them unless specifically requested. */
-
-#if defined _REGEX_RE_COMP || defined _LIBC
-
-/* BSD has one and only one pattern buffer. */
-static struct re_pattern_buffer re_comp_buf;
-
-char *
-# ifdef _LIBC
-/* Make these definitions weak in libc, so POSIX programs can redefine
- these names if they don't use our functions, and still use
- regcomp/regexec below without link errors. */
-weak_function
-# endif
-re_comp (const char *s)
-{
- reg_errcode_t ret;
-
- if (!s)
- {
- if (!re_comp_buf.buffer)
- /* Yes, we're discarding `const' here if !HAVE_LIBINTL. */
- return (char *) gettext ("No previous regular expression");
- return 0;
- }
-
- if (!re_comp_buf.buffer)
- {
- re_comp_buf.buffer = malloc (200);
- if (re_comp_buf.buffer == NULL)
- /* Yes, we're discarding `const' here if !HAVE_LIBINTL. */
- return (char *) gettext (re_error_msgid[(int) REG_ESPACE]);
- re_comp_buf.allocated = 200;
-
- re_comp_buf.fastmap = malloc (1 << BYTEWIDTH);
- if (re_comp_buf.fastmap == NULL)
- /* Yes, we're discarding `const' here if !HAVE_LIBINTL. */
- return (char *) gettext (re_error_msgid[(int) REG_ESPACE]);
- }
-
- /* Since `re_exec' always passes NULL for the `regs' argument, we
- don't need to initialize the pattern buffer fields which affect it. */
-
- ret = regex_compile (s, strlen (s), re_syntax_options, &re_comp_buf);
-
- if (!ret)
- return NULL;
-
- /* Yes, we're discarding `const' here if !HAVE_LIBINTL. */
- return (char *) gettext (re_error_msgid[(int) ret]);
-}
-
-
-int
-# ifdef _LIBC
-weak_function
-# endif
-re_exec (const char *s)
-{
- const size_t len = strlen (s);
- return re_search (&re_comp_buf, s, len, 0, len, 0) >= 0;
-}
-#endif /* _REGEX_RE_COMP */
-
-/* POSIX.2 functions. Don't define these for Emacs. */
-
-#ifndef emacs
-
-/* regcomp takes a regular expression as a string and compiles it.
-
- PREG is a regex_t *. We do not expect any fields to be initialized,
- since POSIX says we shouldn't. Thus, we set
-
- `buffer' to the compiled pattern;
- `used' to the length of the compiled pattern;
- `syntax' to RE_SYNTAX_POSIX_EXTENDED if the
- REG_EXTENDED bit in CFLAGS is set; otherwise, to
- RE_SYNTAX_POSIX_BASIC;
- `fastmap' to an allocated space for the fastmap;
- `fastmap_accurate' to zero;
- `re_nsub' to the number of subexpressions in PATTERN.
-
- PATTERN is the address of the pattern string.
-
- CFLAGS is a series of bits which affect compilation.
-
- If REG_EXTENDED is set, we use POSIX extended syntax; otherwise, we
- use POSIX basic syntax.
-
- If REG_NEWLINE is set, then . and [^...] don't match newline.
- Also, regexec will try a match beginning after every newline.
-
- If REG_ICASE is set, then we considers upper- and lowercase
- versions of letters to be equivalent when matching.
-
- If REG_NOSUB is set, then when PREG is passed to regexec, that
- routine will report only success or failure, and nothing about the
- registers.
-
- It returns 0 if it succeeds, nonzero if it doesn't. (See regex.h for
- the return codes and their meanings.) */
-
-reg_errcode_t
-regcomp (regex_t *_Restrict_ preg, const char *_Restrict_ pattern,
- int cflags)
-{
- reg_errcode_t ret;
- reg_syntax_t syntax
- = (cflags & REG_EXTENDED) ?
- RE_SYNTAX_POSIX_EXTENDED : RE_SYNTAX_POSIX_BASIC;
-
- /* regex_compile will allocate the space for the compiled pattern. */
- preg->buffer = 0;
- preg->allocated = 0;
- preg->used = 0;
-
- /* Try to allocate space for the fastmap. */
- preg->fastmap = malloc (1 << BYTEWIDTH);
-
- if (cflags & REG_ICASE)
- {
- unsigned i;
-
- preg->translate = malloc (CHAR_SET_SIZE * sizeof *preg->translate);
- if (preg->translate == NULL)
- return (int) REG_ESPACE;
-
- /* Map uppercase characters to corresponding lowercase ones. */
- for (i = 0; i < CHAR_SET_SIZE; i++)
- preg->translate[i] = ISUPPER (i) ? TOLOWER (i) : i;
- }
- else
- preg->translate = NULL;
-
- /* If REG_NEWLINE is set, newlines are treated differently. */
- if (cflags & REG_NEWLINE)
- { /* REG_NEWLINE implies neither . nor [^...] match newline. */
- syntax &= ~RE_DOT_NEWLINE;
- syntax |= RE_HAT_LISTS_NOT_NEWLINE;
- }
- else
- syntax |= RE_NO_NEWLINE_ANCHOR;
-
- preg->no_sub = !!(cflags & REG_NOSUB);
-
- /* POSIX says a null character in the pattern terminates it, so we
- can use strlen here in compiling the pattern. */
- ret = regex_compile ((re_char *) pattern, strlen (pattern), syntax, preg);
-
- /* POSIX doesn't distinguish between an unmatched open-group and an
- unmatched close-group: both are REG_EPAREN. */
- if (ret == REG_ERPAREN)
- ret = REG_EPAREN;
-
- if (ret == REG_NOERROR && preg->fastmap)
- { /* Compute the fastmap now, since regexec cannot modify the pattern
- buffer. */
- re_compile_fastmap (preg);
- if (preg->can_be_null)
- { /* The fastmap can't be used anyway. */
- free (preg->fastmap);
- preg->fastmap = NULL;
- }
- }
- return ret;
-}
-WEAK_ALIAS (__regcomp, regcomp)
-
-
-/* regexec searches for a given pattern, specified by PREG, in the
- string STRING.
-
- If NMATCH is zero or REG_NOSUB was set in the cflags argument to
- `regcomp', we ignore PMATCH. Otherwise, we assume PMATCH has at
- least NMATCH elements, and we set them to the offsets of the
- corresponding matched substrings.
-
- EFLAGS specifies `execution flags' which affect matching: if
- REG_NOTBOL is set, then ^ does not match at the beginning of the
- string; if REG_NOTEOL is set, then $ does not match at the end.
-
- We return 0 if we find a match and REG_NOMATCH if not. */
-
-reg_errcode_t
-regexec (const regex_t *_Restrict_ preg, const char *_Restrict_ string,
- size_t nmatch, regmatch_t pmatch[_Restrict_arr_], int eflags)
-{
- regoff_t ret;
- struct re_registers regs;
- regex_t private_preg;
- size_t len = strlen (string);
- boolean want_reg_info = !preg->no_sub && nmatch > 0 && pmatch;
-
- private_preg = *preg;
-
- private_preg.not_bol = !!(eflags & REG_NOTBOL);
- private_preg.not_eol = !!(eflags & REG_NOTEOL);
-
- /* The user has told us exactly how many registers to return
- information about, via `nmatch'. We have to pass that on to the
- matching routines. */
- private_preg.regs_allocated = REGS_FIXED;
-
- if (want_reg_info)
- {
- regs.num_regs = nmatch;
- regs.start = TALLOC (nmatch * 2, regoff_t);
- if (regs.start == NULL)
- return REG_NOMATCH;
- regs.end = regs.start + nmatch;
- }
-
- /* Instead of using not_eol to implement REG_NOTEOL, we could simply
- pass (&private_preg, string, len + 1, 0, len, ...) pretending the string
- was a little bit longer but still only matching the real part.
- This works because the `endline' will check for a '\n' and will find a
- '\0', correctly deciding that this is not the end of a line.
- But it doesn't work out so nicely for REG_NOTBOL, since we don't have
- a convenient '\0' there. For all we know, the string could be preceded
- by '\n' which would throw things off. */
-
- /* Perform the searching operation. */
- ret = re_search (&private_preg, string, len,
- /* start: */ 0, /* range: */ len,
- want_reg_info ? &regs : 0);
-
- /* Copy the register information to the POSIX structure. */
- if (want_reg_info)
- {
- if (ret >= 0)
- {
- unsigned r;
-
- for (r = 0; r < nmatch; r++)
- {
- pmatch[r].rm_so = regs.start[r];
- pmatch[r].rm_eo = regs.end[r];
- }
- }
-
- /* If we needed the temporary register info, free the space now. */
- free (regs.start);
- }
-
- /* We want zero return to mean success, unlike `re_search'. */
- return ret >= 0 ? REG_NOERROR : REG_NOMATCH;
-}
-WEAK_ALIAS (__regexec, regexec)
-
-
-/* Returns a message corresponding to an error code, ERR_CODE, returned
- from either regcomp or regexec. We don't use PREG here.
-
- ERR_CODE was previously called ERRCODE, but that name causes an
- error with msvc8 compiler. */
-
-size_t
-regerror (int err_code, const regex_t *preg, char *errbuf, size_t errbuf_size)
-{
- const char *msg;
- size_t msg_size;
-
- if (err_code < 0
- || err_code >= (sizeof (re_error_msgid) / sizeof (re_error_msgid[0])))
- /* Only error codes returned by the rest of the code should be passed
- to this routine. If we are given anything else, or if other regex
- code generates an invalid error code, then the program has a bug.
- Dump core so we can fix it. */
- abort ();
-
- msg = gettext (re_error_msgid[err_code]);
-
- msg_size = strlen (msg) + 1; /* Includes the null. */
-
- if (errbuf_size != 0)
- {
- if (msg_size > errbuf_size)
- {
- memcpy (errbuf, msg, errbuf_size - 1);
- errbuf[errbuf_size - 1] = 0;
- }
- else
- strcpy (errbuf, msg);
- }
-
- return msg_size;
-}
-WEAK_ALIAS (__regerror, regerror)
-
-
-/* Free dynamically allocated space used by PREG. */
-
-void
-regfree (regex_t *preg)
-{
- free (preg->buffer);
- preg->buffer = NULL;
-
- preg->allocated = 0;
- preg->used = 0;
-
- free (preg->fastmap);
- preg->fastmap = NULL;
- preg->fastmap_accurate = 0;
-
- free (preg->translate);
- preg->translate = NULL;
-}
-WEAK_ALIAS (__regfree, regfree)
-
-#endif /* not emacs */
diff --git a/src/regex-emacs.h b/src/regex-emacs.h
new file mode 100644
index 00000000000..ddf14e0d9e1
--- /dev/null
+++ b/src/regex-emacs.h
@@ -0,0 +1,197 @@
+/* Emacs regular expression API
+
+ Copyright (C) 1985, 1989-1993, 1995, 2000-2019 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, 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 <https://www.gnu.org/licenses/>. */
+
+#ifndef EMACS_REGEX_H
+#define EMACS_REGEX_H 1
+
+#include <stddef.h>
+
+/* This is the structure we store register match data in.
+ Declare this before including lisp.h, since lisp.h (via thread.h)
+ uses struct re_registers. */
+struct re_registers
+{
+ ptrdiff_t num_regs;
+ ptrdiff_t *start;
+ ptrdiff_t *end;
+};
+
+#include "lisp.h"
+
+/* The string or buffer being matched.
+ It is used for looking up syntax properties.
+
+ If the value is a Lisp string object, match text in that string; if
+ it's nil, match text in the current buffer; if it's t, match text
+ in a C string.
+
+ This value is effectively another parameter to re_search_2 and
+ re_match_2. No calls into Lisp or thread switches are allowed
+ before setting re_match_object and calling into the regex search
+ and match functions. These functions capture the current value of
+ re_match_object into gl_state on entry.
+
+ TODO: turn into an actual function parameter. */
+extern Lisp_Object re_match_object;
+
+/* Roughly the maximum number of failure points on the stack. */
+extern ptrdiff_t emacs_re_max_failures;
+
+/* Amount of memory that we can safely stack allocate. */
+extern ptrdiff_t emacs_re_safe_alloca;
+
+/* This data structure represents a compiled pattern. Before calling
+ the pattern compiler, the fields 'buffer', 'allocated', 'fastmap',
+ and 'translate' can be set. After the pattern has been
+ compiled, the 're_nsub' field is available. All other fields are
+ private to the regex routines. */
+
+struct re_pattern_buffer
+{
+ /* Space that holds the compiled pattern. It is declared as
+ 'unsigned char *' because its elements are
+ sometimes used as array indexes. */
+ unsigned char *buffer;
+
+ /* Number of bytes to which 'buffer' points. */
+ ptrdiff_t allocated;
+
+ /* Number of bytes actually used in 'buffer'. */
+ ptrdiff_t used;
+
+ /* Charset of unibyte characters at compiling time. */
+ int charset_unibyte;
+
+ /* Pointer to a fastmap, if any, otherwise zero. re_search uses
+ the fastmap, if there is one, to skip over impossible
+ starting points for matches. */
+ char *fastmap;
+
+ /* Either a translate table to apply to all characters before
+ comparing them, or zero for no translation. The translation
+ applies to a pattern when it is compiled and to a string
+ when it is matched. */
+ Lisp_Object translate;
+
+ /* Number of subexpressions found by the compiler. */
+ ptrdiff_t re_nsub;
+
+ /* True if and only if this pattern can match the empty string.
+ Well, in truth it's used only in 're_search_2', to see
+ whether or not we should use the fastmap, so we don't set
+ this absolutely perfectly; see 're_compile_fastmap'. */
+ bool_bf can_be_null : 1;
+
+ /* If REGS_UNALLOCATED, allocate space in the 'regs' structure
+ for at least (re_nsub + 1) groups.
+ If REGS_REALLOCATE, reallocate space if necessary.
+ If REGS_FIXED, use what's there. */
+ unsigned regs_allocated : 2;
+
+ /* Set to false when 'regex_compile' compiles a pattern; set to true
+ by 're_compile_fastmap' if it updates the fastmap. */
+ bool_bf fastmap_accurate : 1;
+
+ /* If true, the compilation of the pattern had to look up the syntax table,
+ so the compiled pattern is valid for the current syntax table only. */
+ bool_bf used_syntax : 1;
+
+ /* If true, multi-byte form in the regexp pattern should be
+ recognized as a multibyte character. */
+ bool_bf multibyte : 1;
+
+ /* If true, multi-byte form in the target of match should be
+ recognized as a multibyte character. */
+ bool_bf target_multibyte : 1;
+};
+
+/* Declarations for routines. */
+
+/* Compile the regular expression PATTERN, with length LENGTH
+ and syntax given by the global 're_syntax_options', into the buffer
+ BUFFER. Return NULL if successful, and an error string if not. */
+extern const char *re_compile_pattern (const char *pattern, ptrdiff_t length,
+ bool posix_backtracking,
+ const char *whitespace_regexp,
+ struct re_pattern_buffer *buffer);
+
+
+/* Search in the string STRING (with length LENGTH) for the pattern
+ compiled into BUFFER. Start searching at position START, for RANGE
+ characters. Return the starting position of the match, -1 for no
+ match, or -2 for an internal error. Also return register
+ information in REGS (if REGS is non-null). */
+extern ptrdiff_t re_search (struct re_pattern_buffer *buffer,
+ const char *string, ptrdiff_t length,
+ ptrdiff_t start, ptrdiff_t range,
+ struct re_registers *regs);
+
+
+/* Like 're_search', but search in the concatenation of STRING1 and
+ STRING2. Also, stop searching at index START + STOP. */
+extern ptrdiff_t re_search_2 (struct re_pattern_buffer *buffer,
+ const char *string1, ptrdiff_t length1,
+ const char *string2, ptrdiff_t length2,
+ ptrdiff_t start, ptrdiff_t range,
+ struct re_registers *regs,
+ ptrdiff_t stop);
+
+
+/* Like 're_search_2', but return how many characters in STRING the regexp
+ in BUFFER matched, starting at position START. */
+extern ptrdiff_t re_match_2 (struct re_pattern_buffer *buffer,
+ const char *string1, ptrdiff_t length1,
+ const char *string2, ptrdiff_t length2,
+ ptrdiff_t start, struct re_registers *regs,
+ ptrdiff_t stop);
+
+
+/* Set REGS to hold NUM_REGS registers, storing them in STARTS and
+ ENDS. Subsequent matches using BUFFER and REGS will use this memory
+ for recording register information. STARTS and ENDS must be
+ allocated with malloc, and must each be at least 'NUM_REGS * sizeof
+ (ptrdiff_t)' bytes long.
+
+ If NUM_REGS == 0, then subsequent matches should allocate their own
+ register data.
+
+ Unless this function is called, the first search or match using
+ PATTERN_BUFFER will allocate its own register data, without
+ freeing the old data. */
+extern void re_set_registers (struct re_pattern_buffer *buffer,
+ struct re_registers *regs,
+ ptrdiff_t num_regs,
+ ptrdiff_t *starts, ptrdiff_t *ends);
+
+/* Character classes. */
+typedef enum { RECC_ERROR = 0,
+ RECC_ALNUM, RECC_ALPHA, RECC_WORD,
+ RECC_GRAPH, RECC_PRINT,
+ RECC_LOWER, RECC_UPPER,
+ RECC_PUNCT, RECC_CNTRL,
+ RECC_DIGIT, RECC_XDIGIT,
+ RECC_BLANK, RECC_SPACE,
+ RECC_MULTIBYTE, RECC_NONASCII,
+ RECC_ASCII, RECC_UNIBYTE
+} re_wctype_t;
+
+extern bool re_iswctype (int ch, re_wctype_t cc);
+extern re_wctype_t re_wctype_parse (const unsigned char **strp,
+ ptrdiff_t limit);
+
+#endif /* EMACS_REGEX_H */
diff --git a/src/regex.h b/src/regex.h
deleted file mode 100644
index 5ef3d541d91..00000000000
--- a/src/regex.h
+++ /dev/null
@@ -1,644 +0,0 @@
-/* Definitions for data structures and routines for the regular
- expression library, version 0.12.
-
- Copyright (C) 1985, 1989-1993, 1995, 2000-2019 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, 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 <https://www.gnu.org/licenses/>. */
-
-#ifndef _REGEX_H
-#define _REGEX_H 1
-
-#if defined emacs && (defined _REGEX_RE_COMP || defined _LIBC)
-/* We're not defining re_set_syntax and using a different prototype of
- re_compile_pattern when building Emacs so fail compilation early with
- a (somewhat helpful) error message when conflict is detected. */
-# error "_REGEX_RE_COMP nor _LIBC can be defined if emacs is defined."
-#endif
-
-#include <sys/types.h>
-
-/* Allow the use in C++ code. */
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-#if !defined _POSIX_C_SOURCE && !defined _POSIX_SOURCE && defined VMS
-/* VMS doesn't have `size_t' in <sys/types.h>, even though POSIX says it
- should be there. */
-# include <stddef.h>
-#endif
-
-/* The following bits are used to determine the regexp syntax we
- recognize. The set/not-set meanings where historically chosen so
- that Emacs syntax had the value 0.
- The bits are given in alphabetical order, and
- the definitions shifted by one from the previous bit; thus, when we
- add or remove a bit, only one other definition need change. */
-typedef unsigned long reg_syntax_t;
-
-/* If this bit is not set, then \ inside a bracket expression is literal.
- If set, then such a \ quotes the following character. */
-#define RE_BACKSLASH_ESCAPE_IN_LISTS ((unsigned long int) 1)
-
-/* If this bit is not set, then + and ? are operators, and \+ and \? are
- literals.
- If set, then \+ and \? are operators and + and ? are literals. */
-#define RE_BK_PLUS_QM (RE_BACKSLASH_ESCAPE_IN_LISTS << 1)
-
-/* If this bit is set, then character classes are supported. They are:
- [:alpha:], [:upper:], [:lower:], [:digit:], [:alnum:], [:xdigit:],
- [:space:], [:print:], [:punct:], [:graph:], and [:cntrl:].
- If not set, then character classes are not supported. */
-#define RE_CHAR_CLASSES (RE_BK_PLUS_QM << 1)
-
-/* If this bit is set, then ^ and $ are always anchors (outside bracket
- expressions, of course).
- If this bit is not set, then it depends:
- ^ is an anchor if it is at the beginning of a regular
- expression or after an open-group or an alternation operator;
- $ is an anchor if it is at the end of a regular expression, or
- before a close-group or an alternation operator.
-
- This bit could be (re)combined with RE_CONTEXT_INDEP_OPS, because
- POSIX draft 11.2 says that * etc. in leading positions is undefined.
- We already implemented a previous draft which made those constructs
- invalid, though, so we haven't changed the code back. */
-#define RE_CONTEXT_INDEP_ANCHORS (RE_CHAR_CLASSES << 1)
-
-/* If this bit is set, then special characters are always special
- regardless of where they are in the pattern.
- If this bit is not set, then special characters are special only in
- some contexts; otherwise they are ordinary. Specifically,
- * + ? and intervals are only special when not after the beginning,
- open-group, or alternation operator. */
-#define RE_CONTEXT_INDEP_OPS (RE_CONTEXT_INDEP_ANCHORS << 1)
-
-/* If this bit is set, then *, +, ?, and { cannot be first in an re or
- immediately after an alternation or begin-group operator. */
-#define RE_CONTEXT_INVALID_OPS (RE_CONTEXT_INDEP_OPS << 1)
-
-/* If this bit is set, then . matches newline.
- If not set, then it doesn't. */
-#define RE_DOT_NEWLINE (RE_CONTEXT_INVALID_OPS << 1)
-
-/* If this bit is set, then . doesn't match NUL.
- If not set, then it does. */
-#define RE_DOT_NOT_NULL (RE_DOT_NEWLINE << 1)
-
-/* If this bit is set, nonmatching lists [^...] do not match newline.
- If not set, they do. */
-#define RE_HAT_LISTS_NOT_NEWLINE (RE_DOT_NOT_NULL << 1)
-
-/* If this bit is set, either \{...\} or {...} defines an
- interval, depending on RE_NO_BK_BRACES.
- If not set, \{, \}, {, and } are literals. */
-#define RE_INTERVALS (RE_HAT_LISTS_NOT_NEWLINE << 1)
-
-/* If this bit is set, +, ? and | aren't recognized as operators.
- If not set, they are. */
-#define RE_LIMITED_OPS (RE_INTERVALS << 1)
-
-/* If this bit is set, newline is an alternation operator.
- If not set, newline is literal. */
-#define RE_NEWLINE_ALT (RE_LIMITED_OPS << 1)
-
-/* If this bit is set, then `{...}' defines an interval, and \{ and \}
- are literals.
- If not set, then `\{...\}' defines an interval. */
-#define RE_NO_BK_BRACES (RE_NEWLINE_ALT << 1)
-
-/* If this bit is set, (...) defines a group, and \( and \) are literals.
- If not set, \(...\) defines a group, and ( and ) are literals. */
-#define RE_NO_BK_PARENS (RE_NO_BK_BRACES << 1)
-
-/* If this bit is set, then \<digit> matches <digit>.
- If not set, then \<digit> is a back-reference. */
-#define RE_NO_BK_REFS (RE_NO_BK_PARENS << 1)
-
-/* If this bit is set, then | is an alternation operator, and \| is literal.
- If not set, then \| is an alternation operator, and | is literal. */
-#define RE_NO_BK_VBAR (RE_NO_BK_REFS << 1)
-
-/* If this bit is set, then an ending range point collating higher
- than the starting range point, as in [z-a], is invalid.
- If not set, then when ending range point collates higher than the
- starting range point, the range is ignored. */
-#define RE_NO_EMPTY_RANGES (RE_NO_BK_VBAR << 1)
-
-/* If this bit is set, then an unmatched ) is ordinary.
- If not set, then an unmatched ) is invalid. */
-#define RE_UNMATCHED_RIGHT_PAREN_ORD (RE_NO_EMPTY_RANGES << 1)
-
-/* If this bit is set, succeed as soon as we match the whole pattern,
- without further backtracking. */
-#define RE_NO_POSIX_BACKTRACKING (RE_UNMATCHED_RIGHT_PAREN_ORD << 1)
-
-/* If this bit is set, do not process the GNU regex operators.
- If not set, then the GNU regex operators are recognized. */
-#define RE_NO_GNU_OPS (RE_NO_POSIX_BACKTRACKING << 1)
-
-/* If this bit is set, then *?, +? and ?? match non greedily. */
-#define RE_FRUGAL (RE_NO_GNU_OPS << 1)
-
-/* If this bit is set, then (?:...) is treated as a shy group. */
-#define RE_SHY_GROUPS (RE_FRUGAL << 1)
-
-/* If this bit is set, ^ and $ only match at beg/end of buffer. */
-#define RE_NO_NEWLINE_ANCHOR (RE_SHY_GROUPS << 1)
-
-/* If this bit is set, turn on internal regex debugging.
- If not set, and debugging was on, turn it off.
- This only works if regex.c is compiled -DDEBUG.
- We define this bit always, so that all that's needed to turn on
- debugging is to recompile regex.c; the calling code can always have
- this bit set, and it won't affect anything in the normal case. */
-#define RE_DEBUG (RE_NO_NEWLINE_ANCHOR << 1)
-
-/* This global variable defines the particular regexp syntax to use (for
- some interfaces). When a regexp is compiled, the syntax used is
- stored in the pattern buffer, so changing this does not affect
- already-compiled regexps. */
-/* extern reg_syntax_t re_syntax_options; */
-
-#ifdef emacs
-# include "lisp.h"
-/* In Emacs, this is the string or buffer in which we are matching.
- It is used for looking up syntax properties.
-
- If the value is a Lisp string object, we are matching text in that
- string; if it's nil, we are matching text in the current buffer; if
- it's t, we are matching text in a C string.
-
- This is defined as a macro in thread.h, which see. */
-/* extern Lisp_Object re_match_object; */
-#endif
-
-/* Roughly the maximum number of failure points on the stack. */
-extern size_t emacs_re_max_failures;
-
-#ifdef emacs
-/* Amount of memory that we can safely stack allocate. */
-extern ptrdiff_t emacs_re_safe_alloca;
-#endif
-
-
-/* Define combinations of the above bits for the standard possibilities.
- (The [[[ comments delimit what gets put into the Texinfo file, so
- don't delete them!) */
-/* [[[begin syntaxes]]] */
-#define RE_SYNTAX_EMACS \
- (RE_CHAR_CLASSES | RE_INTERVALS | RE_SHY_GROUPS | RE_FRUGAL)
-
-#define RE_SYNTAX_AWK \
- (RE_BACKSLASH_ESCAPE_IN_LISTS | RE_DOT_NOT_NULL \
- | RE_NO_BK_PARENS | RE_NO_BK_REFS \
- | RE_NO_BK_VBAR | RE_NO_EMPTY_RANGES \
- | RE_DOT_NEWLINE | RE_CONTEXT_INDEP_ANCHORS \
- | RE_UNMATCHED_RIGHT_PAREN_ORD | RE_NO_GNU_OPS)
-
-#define RE_SYNTAX_GNU_AWK \
- ((RE_SYNTAX_POSIX_EXTENDED | RE_BACKSLASH_ESCAPE_IN_LISTS | RE_DEBUG) \
- & ~(RE_DOT_NOT_NULL | RE_INTERVALS | RE_CONTEXT_INDEP_OPS))
-
-#define RE_SYNTAX_POSIX_AWK \
- (RE_SYNTAX_POSIX_EXTENDED | RE_BACKSLASH_ESCAPE_IN_LISTS \
- | RE_INTERVALS | RE_NO_GNU_OPS)
-
-#define RE_SYNTAX_GREP \
- (RE_BK_PLUS_QM | RE_CHAR_CLASSES \
- | RE_HAT_LISTS_NOT_NEWLINE | RE_INTERVALS \
- | RE_NEWLINE_ALT)
-
-#define RE_SYNTAX_EGREP \
- (RE_CHAR_CLASSES | RE_CONTEXT_INDEP_ANCHORS \
- | RE_CONTEXT_INDEP_OPS | RE_HAT_LISTS_NOT_NEWLINE \
- | RE_NEWLINE_ALT | RE_NO_BK_PARENS \
- | RE_NO_BK_VBAR)
-
-#define RE_SYNTAX_POSIX_EGREP \
- (RE_SYNTAX_EGREP | RE_INTERVALS | RE_NO_BK_BRACES)
-
-/* P1003.2/D11.2, section 4.20.7.1, lines 5078ff. */
-#define RE_SYNTAX_ED RE_SYNTAX_POSIX_BASIC
-
-#define RE_SYNTAX_SED RE_SYNTAX_POSIX_BASIC
-
-/* Syntax bits common to both basic and extended POSIX regex syntax. */
-#define _RE_SYNTAX_POSIX_COMMON \
- (RE_CHAR_CLASSES | RE_DOT_NEWLINE | RE_DOT_NOT_NULL \
- | RE_INTERVALS | RE_NO_EMPTY_RANGES)
-
-#define RE_SYNTAX_POSIX_BASIC \
- (_RE_SYNTAX_POSIX_COMMON | RE_BK_PLUS_QM)
-
-/* Differs from ..._POSIX_BASIC only in that RE_BK_PLUS_QM becomes
- RE_LIMITED_OPS, i.e., \? \+ \| are not recognized. Actually, this
- isn't minimal, since other operators, such as \`, aren't disabled. */
-#define RE_SYNTAX_POSIX_MINIMAL_BASIC \
- (_RE_SYNTAX_POSIX_COMMON | RE_LIMITED_OPS)
-
-#define RE_SYNTAX_POSIX_EXTENDED \
- (_RE_SYNTAX_POSIX_COMMON | RE_CONTEXT_INDEP_ANCHORS \
- | RE_CONTEXT_INDEP_OPS | RE_NO_BK_BRACES \
- | RE_NO_BK_PARENS | RE_NO_BK_VBAR \
- | RE_CONTEXT_INVALID_OPS | RE_UNMATCHED_RIGHT_PAREN_ORD)
-
-/* Differs from ..._POSIX_EXTENDED in that RE_CONTEXT_INDEP_OPS is
- removed and RE_NO_BK_REFS is added. */
-#define RE_SYNTAX_POSIX_MINIMAL_EXTENDED \
- (_RE_SYNTAX_POSIX_COMMON | RE_CONTEXT_INDEP_ANCHORS \
- | RE_CONTEXT_INVALID_OPS | RE_NO_BK_BRACES \
- | RE_NO_BK_PARENS | RE_NO_BK_REFS \
- | RE_NO_BK_VBAR | RE_UNMATCHED_RIGHT_PAREN_ORD)
-/* [[[end syntaxes]]] */
-
-/* Maximum number of duplicates an interval can allow. Some systems
- (erroneously) define this in other header files, but we want our
- value, so remove any previous define. */
-#ifdef RE_DUP_MAX
-# undef RE_DUP_MAX
-#endif
-/* If sizeof(int) == 2, then ((1 << 15) - 1) overflows. */
-#define RE_DUP_MAX (0x7fff)
-
-
-/* POSIX `cflags' bits (i.e., information for `regcomp'). */
-
-/* If this bit is set, then use extended regular expression syntax.
- If not set, then use basic regular expression syntax. */
-#define REG_EXTENDED 1
-
-/* If this bit is set, then ignore case when matching.
- If not set, then case is significant. */
-#define REG_ICASE (REG_EXTENDED << 1)
-
-/* If this bit is set, then anchors do not match at newline
- characters in the string.
- If not set, then anchors do match at newlines. */
-#define REG_NEWLINE (REG_ICASE << 1)
-
-/* If this bit is set, then report only success or fail in regexec.
- If not set, then returns differ between not matching and errors. */
-#define REG_NOSUB (REG_NEWLINE << 1)
-
-
-/* POSIX `eflags' bits (i.e., information for regexec). */
-
-/* If this bit is set, then the beginning-of-line operator doesn't match
- the beginning of the string (presumably because it's not the
- beginning of a line).
- If not set, then the beginning-of-line operator does match the
- beginning of the string. */
-#define REG_NOTBOL 1
-
-/* Like REG_NOTBOL, except for the end-of-line. */
-#define REG_NOTEOL (1 << 1)
-
-
-/* If any error codes are removed, changed, or added, update the
- `re_error_msg' table in regex.c. */
-typedef enum
-{
-#ifdef _XOPEN_SOURCE
- REG_ENOSYS = -1, /* This will never happen for this implementation. */
-#endif
-
- REG_NOERROR = 0, /* Success. */
- REG_NOMATCH, /* Didn't find a match (for regexec). */
-
- /* POSIX regcomp return error codes. (In the order listed in the
- standard.) */
- REG_BADPAT, /* Invalid pattern. */
- REG_ECOLLATE, /* Not implemented. */
- REG_ECTYPE, /* Invalid character class name. */
- REG_EESCAPE, /* Trailing backslash. */
- REG_ESUBREG, /* Invalid back reference. */
- REG_EBRACK, /* Unmatched left bracket. */
- REG_EPAREN, /* Parenthesis imbalance. */
- REG_EBRACE, /* Unmatched \{. */
- REG_BADBR, /* Invalid contents of \{\}. */
- REG_ERANGE, /* Invalid range end. */
- REG_ESPACE, /* Ran out of memory. */
- REG_BADRPT, /* No preceding re for repetition op. */
-
- /* Error codes we've added. */
- REG_EEND, /* Premature end. */
- REG_ESIZE, /* Compiled pattern bigger than 2^16 bytes. */
- REG_ERPAREN, /* Unmatched ) or \); not returned from regcomp. */
- REG_ERANGEX /* Range striding over charsets. */
-} reg_errcode_t;
-
-/* This data structure represents a compiled pattern. Before calling
- the pattern compiler, the fields `buffer', `allocated', `fastmap',
- `translate', and `no_sub' can be set. After the pattern has been
- compiled, the `re_nsub' field is available. All other fields are
- private to the regex routines. */
-
-#ifndef RE_TRANSLATE_TYPE
-# define RE_TRANSLATE_TYPE char *
-#endif
-
-struct re_pattern_buffer
-{
-/* [[[begin pattern_buffer]]] */
- /* Space that holds the compiled pattern. It is declared as
- `unsigned char *' because its elements are
- sometimes used as array indexes. */
- unsigned char *buffer;
-
- /* Number of bytes to which `buffer' points. */
- size_t allocated;
-
- /* Number of bytes actually used in `buffer'. */
- size_t used;
-
-#ifndef emacs
- /* Syntax setting with which the pattern was compiled. */
- reg_syntax_t syntax;
-#endif
- /* Pointer to a fastmap, if any, otherwise zero. re_search uses
- the fastmap, if there is one, to skip over impossible
- starting points for matches. */
- char *fastmap;
-
- /* Either a translate table to apply to all characters before
- comparing them, or zero for no translation. The translation
- is applied to a pattern when it is compiled and to a string
- when it is matched. */
- RE_TRANSLATE_TYPE translate;
-
- /* Number of subexpressions found by the compiler. */
- size_t re_nsub;
-
- /* Zero if this pattern cannot match the empty string, one else.
- Well, in truth it's used only in `re_search_2', to see
- whether or not we should use the fastmap, so we don't set
- this absolutely perfectly; see `re_compile_fastmap'. */
- unsigned can_be_null : 1;
-
- /* If REGS_UNALLOCATED, allocate space in the `regs' structure
- for `max (RE_NREGS, re_nsub + 1)' groups.
- If REGS_REALLOCATE, reallocate space if necessary.
- If REGS_FIXED, use what's there. */
-#define REGS_UNALLOCATED 0
-#define REGS_REALLOCATE 1
-#define REGS_FIXED 2
- unsigned regs_allocated : 2;
-
- /* Set to zero when `regex_compile' compiles a pattern; set to one
- by `re_compile_fastmap' if it updates the fastmap. */
- unsigned fastmap_accurate : 1;
-
- /* If set, `re_match_2' does not return information about
- subexpressions. */
- unsigned no_sub : 1;
-
- /* If set, a beginning-of-line anchor doesn't match at the
- beginning of the string. */
- unsigned not_bol : 1;
-
- /* Similarly for an end-of-line anchor. */
- unsigned not_eol : 1;
-
- /* If true, the compilation of the pattern had to look up the syntax table,
- so the compiled pattern is only valid for the current syntax table. */
- unsigned used_syntax : 1;
-
-#ifdef emacs
- /* If true, multi-byte form in the regexp pattern should be
- recognized as a multibyte character. */
- unsigned multibyte : 1;
-
- /* If true, multi-byte form in the target of match should be
- recognized as a multibyte character. */
- unsigned target_multibyte : 1;
-
- /* Charset of unibyte characters at compiling time. */
- int charset_unibyte;
-#endif
-
-/* [[[end pattern_buffer]]] */
-};
-
-typedef struct re_pattern_buffer regex_t;
-
-/* POSIX 1003.1-2008 requires that regoff_t be at least as wide as
- ptrdiff_t and ssize_t. We don't know of any hosts where ptrdiff_t
- is wider than ssize_t, so ssize_t is safe. ptrdiff_t is not
- necessarily visible here, so use ssize_t. */
-typedef ssize_t regoff_t;
-
-
-/* This is the structure we store register match data in. See
- regex.texinfo for a full description of what registers match. */
-struct re_registers
-{
- unsigned num_regs;
- regoff_t *start;
- regoff_t *end;
-};
-
-
-/* If `regs_allocated' is REGS_UNALLOCATED in the pattern buffer,
- `re_match_2' returns information about at least this many registers
- the first time a `regs' structure is passed. */
-#ifndef RE_NREGS
-# define RE_NREGS 30
-#endif
-
-
-/* POSIX specification for registers. Aside from the different names than
- `re_registers', POSIX uses an array of structures, instead of a
- structure of arrays. */
-typedef struct
-{
- regoff_t rm_so; /* Byte offset from string's start to substring's start. */
- regoff_t rm_eo; /* Byte offset from string's start to substring's end. */
-} regmatch_t;
-
-/* Declarations for routines. */
-
-#ifndef emacs
-
-/* Sets the current default syntax to SYNTAX, and return the old syntax.
- You can also simply assign to the `re_syntax_options' variable. */
-extern reg_syntax_t re_set_syntax (reg_syntax_t __syntax);
-
-#endif
-
-/* Compile the regular expression PATTERN, with length LENGTH
- and syntax given by the global `re_syntax_options', into the buffer
- BUFFER. Return NULL if successful, and an error string if not. */
-extern const char *re_compile_pattern (const char *__pattern, size_t __length,
-#ifdef emacs
- bool posix_backtracking,
- const char *whitespace_regexp,
-#endif
- struct re_pattern_buffer *__buffer);
-
-
-/* Compile a fastmap for the compiled pattern in BUFFER; used to
- accelerate searches. Return 0 if successful and -2 if was an
- internal error. */
-extern int re_compile_fastmap (struct re_pattern_buffer *__buffer);
-
-
-/* Search in the string STRING (with length LENGTH) for the pattern
- compiled into BUFFER. Start searching at position START, for RANGE
- characters. Return the starting position of the match, -1 for no
- match, or -2 for an internal error. Also return register
- information in REGS (if REGS and BUFFER->no_sub are nonzero). */
-extern regoff_t re_search (struct re_pattern_buffer *__buffer,
- const char *__string, size_t __length,
- ssize_t __start, ssize_t __range,
- struct re_registers *__regs);
-
-
-/* Like `re_search', but search in the concatenation of STRING1 and
- STRING2. Also, stop searching at index START + STOP. */
-extern regoff_t re_search_2 (struct re_pattern_buffer *__buffer,
- const char *__string1, size_t __length1,
- const char *__string2, size_t __length2,
- ssize_t __start, ssize_t __range,
- struct re_registers *__regs,
- ssize_t __stop);
-
-
-/* Like `re_search', but return how many characters in STRING the regexp
- in BUFFER matched, starting at position START. */
-extern regoff_t re_match (struct re_pattern_buffer *__buffer,
- const char *__string, size_t __length,
- ssize_t __start, struct re_registers *__regs);
-
-
-/* Relates to `re_match' as `re_search_2' relates to `re_search'. */
-extern regoff_t re_match_2 (struct re_pattern_buffer *__buffer,
- const char *__string1, size_t __length1,
- const char *__string2, size_t __length2,
- ssize_t __start, struct re_registers *__regs,
- ssize_t __stop);
-
-
-/* Set REGS to hold NUM_REGS registers, storing them in STARTS and
- ENDS. Subsequent matches using BUFFER and REGS will use this memory
- for recording register information. STARTS and ENDS must be
- allocated with malloc, and must each be at least `NUM_REGS * sizeof
- (regoff_t)' bytes long.
-
- If NUM_REGS == 0, then subsequent matches should allocate their own
- register data.
-
- Unless this function is called, the first search or match using
- PATTERN_BUFFER will allocate its own register data, without
- freeing the old data. */
-extern void re_set_registers (struct re_pattern_buffer *__buffer,
- struct re_registers *__regs,
- unsigned __num_regs,
- regoff_t *__starts, regoff_t *__ends);
-
-#if defined _REGEX_RE_COMP || defined _LIBC
-# ifndef _CRAY
-/* 4.2 bsd compatibility. */
-extern char *re_comp (const char *);
-extern int re_exec (const char *);
-# endif
-#endif
-
-/* GCC 2.95 and later have "__restrict"; C99 compilers have
- "restrict", and "configure" may have defined "restrict".
- Other compilers use __restrict, __restrict__, and _Restrict, and
- 'configure' might #define 'restrict' to those words, so pick a
- different name. */
-#ifndef _Restrict_
-# if 199901L <= __STDC_VERSION__
-# define _Restrict_ restrict
-# elif 2 < __GNUC__ || (2 == __GNUC__ && 95 <= __GNUC_MINOR__)
-# define _Restrict_ __restrict
-# else
-# define _Restrict_
-# endif
-#endif
-/* gcc 3.1 and up support the [restrict] syntax. Don't trust
- sys/cdefs.h's definition of __restrict_arr, though, as it
- mishandles gcc -ansi -pedantic. */
-#ifndef _Restrict_arr_
-# if ((199901L <= __STDC_VERSION__ \
- || ((3 < __GNUC__ || (3 == __GNUC__ && 1 <= __GNUC_MINOR__)) \
- && !defined __STRICT_ANSI__)) \
- && !defined __GNUG__)
-# define _Restrict_arr_ _Restrict_
-# else
-# define _Restrict_arr_
-# endif
-#endif
-
-/* POSIX compatibility. */
-extern reg_errcode_t regcomp (regex_t *_Restrict_ __preg,
- const char *_Restrict_ __pattern,
- int __cflags);
-
-extern reg_errcode_t regexec (const regex_t *_Restrict_ __preg,
- const char *_Restrict_ __string, size_t __nmatch,
- regmatch_t __pmatch[_Restrict_arr_],
- int __eflags);
-
-extern size_t regerror (int __errcode, const regex_t * __preg,
- char *__errbuf, size_t __errbuf_size);
-
-extern void regfree (regex_t *__preg);
-
-
-#ifdef __cplusplus
-}
-#endif /* C++ */
-
-/* For platform which support the ISO C amendment 1 functionality we
- support user defined character classes. */
-#if WIDE_CHAR_SUPPORT
-/* Solaris 2.5 has a bug: <wchar.h> must be included before <wctype.h>. */
-# include <wchar.h>
-# include <wctype.h>
-
-typedef wctype_t re_wctype_t;
-typedef wchar_t re_wchar_t;
-# define re_wctype wctype
-# define re_iswctype iswctype
-# define re_wctype_to_bit(cc) 0
-#else
-# ifndef emacs
-# define btowc(c) c
-# endif
-
-/* Character classes. */
-typedef enum { RECC_ERROR = 0,
- RECC_ALNUM, RECC_ALPHA, RECC_WORD,
- RECC_GRAPH, RECC_PRINT,
- RECC_LOWER, RECC_UPPER,
- RECC_PUNCT, RECC_CNTRL,
- RECC_DIGIT, RECC_XDIGIT,
- RECC_BLANK, RECC_SPACE,
- RECC_MULTIBYTE, RECC_NONASCII,
- RECC_ASCII, RECC_UNIBYTE
-} re_wctype_t;
-
-extern char re_iswctype (int ch, re_wctype_t cc);
-extern re_wctype_t re_wctype_parse (const unsigned char **strp, unsigned limit);
-
-typedef int re_wchar_t;
-
-#endif /* not WIDE_CHAR_SUPPORT */
-
-#endif /* regex.h */
-
diff --git a/src/scroll.c b/src/scroll.c
index 6cbf212f09e..8eda510945f 100644
--- a/src/scroll.c
+++ b/src/scroll.c
@@ -28,12 +28,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "frame.h"
#include "termhooks.h"
-/* All costs measured in characters.
- So no cost can exceed the area of a frame, measured in characters.
- Let's hope this is never more than 1000000 characters. */
-
-#define INFINITY 1000000
-
struct matrix_elt
{
/* Cost of outputting through this line
@@ -113,15 +107,13 @@ calculate_scrolling (struct frame *frame,
/* Discourage long scrolls on fast lines.
Don't scroll nearly a full frame height unless it saves
at least 1/4 second. */
- int extra_cost = baud_rate / (10 * 4 * frame_total_lines);
-
- if (baud_rate <= 0)
- extra_cost = 1;
+ int extra_cost
+ = clip_to_bounds (1, baud_rate / (10 * 4) / frame_total_lines, INT_MAX / 2);
/* initialize the top left corner of the matrix */
matrix->writecost = 0;
- matrix->insertcost = INFINITY;
- matrix->deletecost = INFINITY;
+ matrix->insertcost = SCROLL_INFINITY;
+ matrix->deletecost = SCROLL_INFINITY;
matrix->insertcount = 0;
matrix->deletecount = 0;
@@ -132,8 +124,8 @@ calculate_scrolling (struct frame *frame,
p = matrix + i * (window_size + 1);
cost += draw_cost[i] + next_insert_cost[i] + extra_cost;
p->insertcost = cost;
- p->writecost = INFINITY;
- p->deletecost = INFINITY;
+ p->writecost = SCROLL_INFINITY;
+ p->deletecost = SCROLL_INFINITY;
p->insertcount = i;
p->deletecount = 0;
}
@@ -144,8 +136,8 @@ calculate_scrolling (struct frame *frame,
{
cost += next_delete_cost[j];
matrix[j].deletecost = cost;
- matrix[j].writecost = INFINITY;
- matrix[j].insertcost = INFINITY;
+ matrix[j].writecost = SCROLL_INFINITY;
+ matrix[j].insertcost = SCROLL_INFINITY;
matrix[j].deletecount = j;
matrix[j].insertcount = 0;
}
@@ -192,13 +184,13 @@ calculate_scrolling (struct frame *frame,
else
{
cost = p1->writecost + first_insert_cost[i];
- if ((int) p1->insertcount > i)
+ if (p1->insertcount > i)
emacs_abort ();
cost1 = p1->insertcost + next_insert_cost[i - p1->insertcount];
}
p->insertcost = min (cost, cost1) + draw_cost[i] + extra_cost;
p->insertcount = (cost < cost1) ? 1 : p1->insertcount + 1;
- if ((int) p->insertcount > i)
+ if (p->insertcount > i)
emacs_abort ();
/* Calculate the cost if we do a delete line after
@@ -452,10 +444,8 @@ calculate_direct_scrolling (struct frame *frame,
/* Discourage long scrolls on fast lines.
Don't scroll nearly a full frame height unless it saves
at least 1/4 second. */
- int extra_cost = baud_rate / (10 * 4 * frame_total_lines);
-
- if (baud_rate <= 0)
- extra_cost = 1;
+ int extra_cost
+ = clip_to_bounds (1, baud_rate / (10 * 4) / frame_total_lines, INT_MAX / 2);
/* Overhead of setting the scroll window, plus the extra
cost of scrolling by a distance of one. The extra cost is
@@ -465,8 +455,8 @@ calculate_direct_scrolling (struct frame *frame,
/* initialize the top left corner of the matrix */
matrix->writecost = 0;
- matrix->insertcost = INFINITY;
- matrix->deletecost = INFINITY;
+ matrix->insertcost = SCROLL_INFINITY;
+ matrix->deletecost = SCROLL_INFINITY;
matrix->writecount = 0;
matrix->insertcount = 0;
matrix->deletecount = 0;
@@ -478,8 +468,8 @@ calculate_direct_scrolling (struct frame *frame,
p = matrix + i * (window_size + 1);
cost += draw_cost[i];
p->insertcost = cost;
- p->writecost = INFINITY;
- p->deletecost = INFINITY;
+ p->writecost = SCROLL_INFINITY;
+ p->deletecost = SCROLL_INFINITY;
p->insertcount = i;
p->writecount = 0;
p->deletecount = 0;
@@ -489,8 +479,8 @@ calculate_direct_scrolling (struct frame *frame,
for (j = 1; j <= window_size; j++)
{
matrix[j].deletecost = 0;
- matrix[j].writecost = INFINITY;
- matrix[j].insertcost = INFINITY;
+ matrix[j].writecost = SCROLL_INFINITY;
+ matrix[j].insertcost = SCROLL_INFINITY;
matrix[j].deletecount = j;
matrix[j].writecount = 0;
matrix[j].insertcount = 0;
diff --git a/src/search.c b/src/search.c
index 9bde884bc53..a450e920b03 100644
--- a/src/search.c
+++ b/src/search.c
@@ -29,8 +29,9 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "region-cache.h"
#include "blockinput.h"
#include "intervals.h"
+#include "pdumper.h"
-#include "regex.h"
+#include "regex-emacs.h"
#define REGEXP_CACHE_SIZE 20
@@ -48,6 +49,8 @@ struct regexp_cache
char fastmap[0400];
/* True means regexp was compiled to do full POSIX backtracking. */
bool posix;
+ /* True means we're inside a buffer match. */
+ bool busy;
};
/* The instances of that struct. */
@@ -56,31 +59,6 @@ static struct regexp_cache searchbufs[REGEXP_CACHE_SIZE];
/* The head of the linked list; points to the most recently used buffer. */
static struct regexp_cache *searchbuf_head;
-
-/* Every call to re_match, etc., must pass &search_regs as the regs
- argument unless you can show it is unnecessary (i.e., if re_match
- is certainly going to be called again before region-around-match
- can be called).
-
- Since the registers are now dynamically allocated, we need to make
- sure not to refer to the Nth register before checking that it has
- been allocated by checking search_regs.num_regs.
-
- The regex code keeps track of whether it has allocated the search
- buffer using bits in the re_pattern_buffer. This means that whenever
- you compile a new pattern, it completely forgets whether it has
- allocated any registers, and will allocate new registers the next
- time you call a searching or matching function. Therefore, we need
- to call re_set_registers after compiling a new pattern or after
- setting the match registers, so that the regex functions will be
- able to free or re-allocate it properly. */
-/* static struct re_registers search_regs; */
-
-/* The buffer in which the last search was performed, or
- Qt if the last search was done in a string;
- Qnil if no searching has been done yet. */
-/* static Lisp_Object last_thing_searched; */
-
static void set_search_regs (ptrdiff_t, ptrdiff_t);
static void save_search_regs (void);
static EMACS_INT simple_search (EMACS_INT, unsigned char *, ptrdiff_t,
@@ -93,6 +71,8 @@ static EMACS_INT search_buffer (Lisp_Object, ptrdiff_t, ptrdiff_t,
ptrdiff_t, ptrdiff_t, EMACS_INT, int,
Lisp_Object, Lisp_Object, bool);
+Lisp_Object re_match_object;
+
static _Noreturn void
matcher_overflow (void)
{
@@ -110,14 +90,6 @@ freeze_buffer_relocation (void)
#endif
}
-static void
-thaw_buffer_relocation (void)
-{
-#ifdef REL_ALLOC
- unbind_to (SPECPDL_INDEX () - 1, Qnil);
-#endif
-}
-
/* Compile a regexp and signal a Lisp error if anything goes wrong.
PATTERN is the pattern to compile.
CP is the place to put the result.
@@ -134,8 +106,9 @@ compile_pattern_1 (struct regexp_cache *cp, Lisp_Object pattern,
const char *whitespace_regexp;
char *val;
+ eassert (!cp->busy);
cp->regexp = Qnil;
- cp->buf.translate = (! NILP (translate) ? translate : make_number (0));
+ cp->buf.translate = translate;
cp->posix = posix;
cp->buf.multibyte = STRING_MULTIBYTE (pattern);
cp->buf.charset_unibyte = charset_unibyte;
@@ -144,12 +117,6 @@ compile_pattern_1 (struct regexp_cache *cp, Lisp_Object pattern,
else
cp->f_whitespace_regexp = Qnil;
- /* rms: I think BLOCK_INPUT is not needed here any more,
- because regex.c defines malloc to call xmalloc.
- Using BLOCK_INPUT here means the debugger won't run if an error occurs.
- So let's turn it off. */
- /* BLOCK_INPUT; */
-
whitespace_regexp = STRINGP (Vsearch_spaces_regexp) ?
SSDATA (Vsearch_spaces_regexp) : NULL;
@@ -160,7 +127,6 @@ compile_pattern_1 (struct regexp_cache *cp, Lisp_Object pattern,
syntax-table, it can only be reused with *this* syntax table. */
cp->syntax_table = cp->buf.used_syntax ? BVAR (current_buffer, syntax_table) : Qt;
- /* unblock_input (); */
if (val)
xsignal1 (Qinvalid_regexp, build_string (val));
@@ -177,10 +143,11 @@ shrink_regexp_cache (void)
struct regexp_cache *cp;
for (cp = searchbuf_head; cp != 0; cp = cp->next)
- {
- cp->buf.allocated = cp->buf.used;
- cp->buf.buffer = xrealloc (cp->buf.buffer, cp->buf.used);
- }
+ if (!cp->busy)
+ {
+ cp->buf.allocated = cp->buf.used;
+ cp->buf.buffer = xrealloc (cp->buf.buffer, cp->buf.used);
+ }
}
/* Clear the regexp cache w.r.t. a particular syntax table,
@@ -197,10 +164,25 @@ clear_regexp_cache (void)
/* It's tempting to compare with the syntax-table we've actually changed,
but it's not sufficient because char-table inheritance means that
modifying one syntax-table can change others at the same time. */
- if (!EQ (searchbufs[i].syntax_table, Qt))
+ if (!searchbufs[i].busy && !EQ (searchbufs[i].syntax_table, Qt))
searchbufs[i].regexp = Qnil;
}
+static void
+unfreeze_pattern (void *arg)
+{
+ struct regexp_cache *searchbuf = arg;
+ searchbuf->busy = false;
+}
+
+static void
+freeze_pattern (struct regexp_cache *searchbuf)
+{
+ eassert (!searchbuf->busy);
+ record_unwind_protect_ptr (unfreeze_pattern, searchbuf);
+ searchbuf->busy = true;
+}
+
/* Compile a regexp if necessary, but first check to see if there's one in
the cache.
PATTERN is the pattern to compile.
@@ -212,15 +194,17 @@ clear_regexp_cache (void)
POSIX is true if we want full backtracking (POSIX style) for this pattern.
False means backtrack only enough to get a valid match. */
-struct re_pattern_buffer *
+static struct regexp_cache *
compile_pattern (Lisp_Object pattern, struct re_registers *regp,
Lisp_Object translate, bool posix, bool multibyte)
{
- struct regexp_cache *cp, **cpp;
+ struct regexp_cache *cp, **cpp, **lru_nonbusy;
- for (cpp = &searchbuf_head; ; cpp = &cp->next)
+ for (cpp = &searchbuf_head, lru_nonbusy = NULL; ; cpp = &cp->next)
{
cp = *cpp;
+ if (!cp->busy)
+ lru_nonbusy = cpp;
/* Entries are initialized to nil, and may be set to nil by
compile_pattern_1 if the pattern isn't valid. Don't apply
string accessors in those cases. However, compile_pattern_1
@@ -229,9 +213,10 @@ compile_pattern (Lisp_Object pattern, struct re_registers *regp,
if (NILP (cp->regexp))
goto compile_it;
if (SCHARS (cp->regexp) == SCHARS (pattern)
+ && !cp->busy
&& STRING_MULTIBYTE (cp->regexp) == STRING_MULTIBYTE (pattern)
&& !NILP (Fstring_equal (cp->regexp, pattern))
- && EQ (cp->buf.translate, (! NILP (translate) ? translate : make_number (0)))
+ && EQ (cp->buf.translate, translate)
&& cp->posix == posix
&& (EQ (cp->syntax_table, Qt)
|| EQ (cp->syntax_table, BVAR (current_buffer, syntax_table)))
@@ -239,12 +224,16 @@ compile_pattern (Lisp_Object pattern, struct re_registers *regp,
&& cp->buf.charset_unibyte == charset_unibyte)
break;
- /* If we're at the end of the cache, compile into the nil cell
- we found, or the last (least recently used) cell with a
- string value. */
+ /* If we're at the end of the cache, compile into the last
+ (least recently used) non-busy cell in the cache. */
if (cp->next == 0)
{
+ if (!lru_nonbusy)
+ error ("Too much matching reentrancy");
+ cpp = lru_nonbusy;
+ cp = *cpp;
compile_it:
+ eassert (!cp->busy);
compile_pattern_1 (cp, pattern, translate, posix);
break;
}
@@ -265,8 +254,7 @@ compile_pattern (Lisp_Object pattern, struct re_registers *regp,
/* The compiled pattern can be used both for multibyte and unibyte
target. But, we have to tell which the pattern is used for. */
cp->buf.target_multibyte = multibyte;
-
- return &cp->buf;
+ return cp;
}
@@ -277,23 +265,27 @@ looking_at_1 (Lisp_Object string, bool posix)
unsigned char *p1, *p2;
ptrdiff_t s1, s2;
register ptrdiff_t i;
- struct re_pattern_buffer *bufp;
if (running_asynch_code)
save_search_regs ();
- /* This is so set_image_of_range_1 in regex.c can find the EQV table. */
+ /* This is so set_image_of_range_1 in regex-emacs.c can find the EQV
+ table. */
set_char_table_extras (BVAR (current_buffer, case_canon_table), 2,
BVAR (current_buffer, case_eqv_table));
CHECK_STRING (string);
- bufp = compile_pattern (string,
- (NILP (Vinhibit_changing_match_data)
- ? &search_regs : NULL),
- (!NILP (BVAR (current_buffer, case_fold_search))
- ? BVAR (current_buffer, case_canon_table) : Qnil),
- posix,
- !NILP (BVAR (current_buffer, enable_multibyte_characters)));
+
+ /* Snapshot in case Lisp changes the value. */
+ bool preserve_match_data = NILP (Vinhibit_changing_match_data);
+
+ struct regexp_cache *cache_entry = compile_pattern (
+ string,
+ preserve_match_data ? &search_regs : NULL,
+ (!NILP (BVAR (current_buffer, case_fold_search))
+ ? BVAR (current_buffer, case_canon_table) : Qnil),
+ posix,
+ !NILP (BVAR (current_buffer, enable_multibyte_characters)));
/* Do a pending quit right away, to avoid paradoxical behavior */
maybe_quit ();
@@ -317,21 +309,23 @@ looking_at_1 (Lisp_Object string, bool posix)
s2 = 0;
}
- re_match_object = Qnil;
-
+ ptrdiff_t count = SPECPDL_INDEX ();
freeze_buffer_relocation ();
- i = re_match_2 (bufp, (char *) p1, s1, (char *) p2, s2,
+ freeze_pattern (cache_entry);
+ re_match_object = Qnil;
+ i = re_match_2 (&cache_entry->buf, (char *) p1, s1, (char *) p2, s2,
PT_BYTE - BEGV_BYTE,
- (NILP (Vinhibit_changing_match_data)
- ? &search_regs : NULL),
+ preserve_match_data ? &search_regs : NULL,
ZV_BYTE - BEGV_BYTE);
- thaw_buffer_relocation ();
if (i == -2)
- matcher_overflow ();
+ {
+ unbind_to (count, Qnil);
+ matcher_overflow ();
+ }
val = (i >= 0 ? Qt : Qnil);
- if (NILP (Vinhibit_changing_match_data) && i >= 0)
+ if (preserve_match_data && i >= 0)
{
for (i = 0; i < search_regs.num_regs; i++)
if (search_regs.start[i] >= 0)
@@ -345,7 +339,7 @@ looking_at_1 (Lisp_Object string, bool posix)
XSETBUFFER (last_thing_searched, current_buffer);
}
- return val;
+ return unbind_to (count, val);
}
DEFUN ("looking-at", Flooking_at, Slooking_at, 1, 1, 0,
@@ -390,8 +384,8 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start,
{
ptrdiff_t len = SCHARS (string);
- CHECK_NUMBER (start);
- pos = XINT (start);
+ CHECK_FIXNUM (start);
+ pos = XFIXNUM (start);
if (pos < 0 && -pos <= len)
pos = len + pos;
else if (0 > pos || pos > len)
@@ -399,19 +393,19 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start,
pos_byte = string_char_to_byte (string, pos);
}
- /* This is so set_image_of_range_1 in regex.c can find the EQV table. */
+ /* This is so set_image_of_range_1 in regex-emacs.c can find the EQV
+ table. */
set_char_table_extras (BVAR (current_buffer, case_canon_table), 2,
BVAR (current_buffer, case_eqv_table));
- bufp = compile_pattern (regexp,
- (NILP (Vinhibit_changing_match_data)
- ? &search_regs : NULL),
- (!NILP (BVAR (current_buffer, case_fold_search))
- ? BVAR (current_buffer, case_canon_table) : Qnil),
- posix,
- STRING_MULTIBYTE (string));
+ bufp = &compile_pattern (regexp,
+ (NILP (Vinhibit_changing_match_data)
+ ? &search_regs : NULL),
+ (!NILP (BVAR (current_buffer, case_fold_search))
+ ? BVAR (current_buffer, case_canon_table) : Qnil),
+ posix,
+ STRING_MULTIBYTE (string))->buf;
re_match_object = string;
-
val = re_search (bufp, SSDATA (string),
SBYTES (string), pos_byte,
SBYTES (string) - pos_byte,
@@ -436,7 +430,7 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start,
= string_byte_to_char (string, search_regs.end[i]);
}
- return make_number (string_byte_to_char (string, val));
+ return make_fixnum (string_byte_to_char (string, val));
}
DEFUN ("string-match", Fstring_match, Sstring_match, 2, 3, 0,
@@ -478,10 +472,9 @@ fast_string_match_internal (Lisp_Object regexp, Lisp_Object string,
ptrdiff_t val;
struct re_pattern_buffer *bufp;
- bufp = compile_pattern (regexp, 0, table,
- 0, STRING_MULTIBYTE (string));
+ bufp = &compile_pattern (regexp, 0, table,
+ 0, STRING_MULTIBYTE (string))->buf;
re_match_object = string;
-
val = re_search (bufp, SSDATA (string),
SBYTES (string), 0,
SBYTES (string), 0);
@@ -501,10 +494,10 @@ fast_c_string_match_ignore_case (Lisp_Object regexp,
struct re_pattern_buffer *bufp;
regexp = string_make_unibyte (regexp);
+ bufp = &compile_pattern (regexp, 0,
+ Vascii_canon_table, 0,
+ 0)->buf;
re_match_object = Qt;
- bufp = compile_pattern (regexp, 0,
- Vascii_canon_table, 0,
- 0);
val = re_search (bufp, string, len, 0, len, 0);
return val;
}
@@ -520,7 +513,6 @@ fast_looking_at (Lisp_Object regexp, ptrdiff_t pos, ptrdiff_t pos_byte,
ptrdiff_t limit, ptrdiff_t limit_byte, Lisp_Object string)
{
bool multibyte;
- struct re_pattern_buffer *buf;
unsigned char *p1, *p2;
ptrdiff_t s1, s2;
ptrdiff_t len;
@@ -535,7 +527,6 @@ fast_looking_at (Lisp_Object regexp, ptrdiff_t pos, ptrdiff_t pos_byte,
s1 = 0;
p2 = SDATA (string);
s2 = SBYTES (string);
- re_match_object = string;
multibyte = STRING_MULTIBYTE (string);
}
else
@@ -561,16 +552,19 @@ fast_looking_at (Lisp_Object regexp, ptrdiff_t pos, ptrdiff_t pos_byte,
s1 = ZV_BYTE - BEGV_BYTE;
s2 = 0;
}
- re_match_object = Qnil;
multibyte = ! NILP (BVAR (current_buffer, enable_multibyte_characters));
}
- buf = compile_pattern (regexp, 0, Qnil, 0, multibyte);
+ struct regexp_cache *cache_entry =
+ compile_pattern (regexp, 0, Qnil, 0, multibyte);
+ ptrdiff_t count = SPECPDL_INDEX ();
freeze_buffer_relocation ();
- len = re_match_2 (buf, (char *) p1, s1, (char *) p2, s2,
+ freeze_pattern (cache_entry);
+ re_match_object = STRINGP (string) ? string : Qnil;
+ len = re_match_2 (&cache_entry->buf, (char *) p1, s1, (char *) p2, s2,
pos_byte, NULL, limit_byte);
- thaw_buffer_relocation ();
+ unbind_to (count, Qnil);
return len;
}
@@ -634,14 +628,16 @@ newline_cache_on_off (struct buffer *buf)
If COUNT is zero, do anything you please; run rogue, for all I care.
If END is zero, use BEGV or ZV instead, as appropriate for the
- direction indicated by COUNT.
+ direction indicated by COUNT. If START_BYTE is -1 it is unknown,
+ and similarly for END_BYTE.
- If we find COUNT instances, set *SHORTAGE to zero, and return the
+ If we find COUNT instances, set *COUNTED to COUNT, and return the
position past the COUNTth match. Note that for reverse motion
this is not the same as the usual convention for Emacs motion commands.
- If we don't find COUNT instances before reaching END, set *SHORTAGE
- to the number of newlines left unfound, and return END.
+ If we don't find COUNT instances before reaching END, set *COUNTED
+ to the number of newlines left found (negated if COUNT is negative),
+ and return END.
If BYTEPOS is not NULL, set *BYTEPOS to the byte position corresponding
to the returned character position.
@@ -651,23 +647,17 @@ newline_cache_on_off (struct buffer *buf)
ptrdiff_t
find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
- ptrdiff_t end_byte, ptrdiff_t count, ptrdiff_t *shortage,
+ ptrdiff_t end_byte, ptrdiff_t count, ptrdiff_t *counted,
ptrdiff_t *bytepos, bool allow_quit)
{
struct region_cache *newline_cache;
- int direction;
struct buffer *cache_buffer;
- if (count > 0)
+ if (!end)
{
- direction = 1;
- if (!end)
+ if (count > 0)
end = ZV, end_byte = ZV_BYTE;
- }
- else
- {
- direction = -1;
- if (!end)
+ else
end = BEGV, end_byte = BEGV_BYTE;
}
if (end_byte == -1)
@@ -679,8 +669,8 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
else
cache_buffer = current_buffer;
- if (shortage != 0)
- *shortage = 0;
+ if (counted)
+ *counted = count;
if (count > 0)
while (start != end)
@@ -923,8 +913,8 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
}
}
- if (shortage)
- *shortage = count * direction;
+ if (counted)
+ *counted -= count;
if (bytepos)
{
*bytepos = start_byte == -1 ? CHAR_TO_BYTE (start) : start_byte;
@@ -939,30 +929,28 @@ find_newline (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
We report the resulting position by calling TEMP_SET_PT_BOTH.
If we find COUNT instances. we position after (always after,
- even if scanning backwards) the COUNTth match, and return 0.
+ even if scanning backwards) the COUNTth match.
If we don't find COUNT instances before reaching the end of the
- buffer (or the beginning, if scanning backwards), we return
- the number of line boundaries left unfound, and position at
+ buffer (or the beginning, if scanning backwards), we position at
the limit we bumped up against.
If ALLOW_QUIT, check for quitting. That's good to do
except in special cases. */
-ptrdiff_t
+void
scan_newline (ptrdiff_t start, ptrdiff_t start_byte,
ptrdiff_t limit, ptrdiff_t limit_byte,
ptrdiff_t count, bool allow_quit)
{
- ptrdiff_t charpos, bytepos, shortage;
+ ptrdiff_t charpos, bytepos, counted;
charpos = find_newline (start, start_byte, limit, limit_byte,
- count, &shortage, &bytepos, allow_quit);
- if (shortage)
+ count, &counted, &bytepos, allow_quit);
+ if (counted != count)
TEMP_SET_PT_BOTH (limit, limit_byte);
else
TEMP_SET_PT_BOTH (charpos, bytepos);
- return shortage;
}
/* Like above, but always scan from point and report the
@@ -972,19 +960,19 @@ ptrdiff_t
scan_newline_from_point (ptrdiff_t count, ptrdiff_t *charpos,
ptrdiff_t *bytepos)
{
- ptrdiff_t shortage;
+ ptrdiff_t counted;
if (count <= 0)
*charpos = find_newline (PT, PT_BYTE, BEGV, BEGV_BYTE, count - 1,
- &shortage, bytepos, 1);
+ &counted, bytepos, 1);
else
*charpos = find_newline (PT, PT_BYTE, ZV, ZV_BYTE, count,
- &shortage, bytepos, 1);
- return shortage;
+ &counted, bytepos, 1);
+ return counted;
}
/* Like find_newline, but doesn't allow QUITting and doesn't return
- SHORTAGE. */
+ COUNTED. */
ptrdiff_t
find_newline_no_quit (ptrdiff_t from, ptrdiff_t frombyte,
ptrdiff_t cnt, ptrdiff_t *bytepos)
@@ -1000,10 +988,10 @@ ptrdiff_t
find_before_next_newline (ptrdiff_t from, ptrdiff_t to,
ptrdiff_t cnt, ptrdiff_t *bytepos)
{
- ptrdiff_t shortage;
- ptrdiff_t pos = find_newline (from, -1, to, -1, cnt, &shortage, bytepos, 1);
+ ptrdiff_t counted;
+ ptrdiff_t pos = find_newline (from, -1, to, -1, cnt, &counted, bytepos, 1);
- if (shortage == 0)
+ if (counted == cnt)
{
if (bytepos)
DEC_BOTH (pos, *bytepos);
@@ -1026,8 +1014,8 @@ search_command (Lisp_Object string, Lisp_Object bound, Lisp_Object noerror,
if (!NILP (count))
{
- CHECK_NUMBER (count);
- n *= XINT (count);
+ CHECK_FIXNUM (count);
+ n *= XFIXNUM (count);
}
CHECK_STRING (string);
@@ -1040,8 +1028,8 @@ search_command (Lisp_Object string, Lisp_Object bound, Lisp_Object noerror,
}
else
{
- CHECK_NUMBER_COERCE_MARKER (bound);
- lim = XINT (bound);
+ CHECK_FIXNUM_COERCE_MARKER (bound);
+ lim = XFIXNUM (bound);
if (n > 0 ? lim < PT : lim > PT)
error ("Invalid search bound (wrong side of point)");
if (lim > ZV)
@@ -1052,7 +1040,8 @@ search_command (Lisp_Object string, Lisp_Object bound, Lisp_Object noerror,
lim_byte = CHAR_TO_BYTE (lim);
}
- /* This is so set_image_of_range_1 in regex.c can find the EQV table. */
+ /* This is so set_image_of_range_1 in regex-emacs.c can find the EQV
+ table. */
set_char_table_extras (BVAR (current_buffer, case_canon_table), 2,
BVAR (current_buffer, case_eqv_table));
@@ -1086,7 +1075,7 @@ search_command (Lisp_Object string, Lisp_Object bound, Lisp_Object noerror,
eassert (BEGV <= np && np <= ZV);
SET_PT (np);
- return make_number (np);
+ return make_fixnum (np);
}
/* Return true if REGEXP it matches just one constant string. */
@@ -1141,9 +1130,9 @@ do \
if (! NILP (trt)) \
{ \
Lisp_Object temp; \
- temp = Faref (trt, make_number (d)); \
- if (INTEGERP (temp)) \
- out = XINT (temp); \
+ temp = Faref (trt, make_fixnum (d)); \
+ if (FIXNUMP (temp)) \
+ out = XFIXNUM (temp); \
else \
out = d; \
} \
@@ -1158,355 +1147,374 @@ while (0)
static struct re_registers search_regs_1;
static EMACS_INT
-search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte,
- ptrdiff_t lim, ptrdiff_t lim_byte, EMACS_INT n,
- int RE, Lisp_Object trt, Lisp_Object inverse_trt, bool posix)
+search_buffer_re (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte,
+ ptrdiff_t lim, ptrdiff_t lim_byte, EMACS_INT n,
+ Lisp_Object trt, Lisp_Object inverse_trt, bool posix)
{
- ptrdiff_t len = SCHARS (string);
- ptrdiff_t len_byte = SBYTES (string);
- register ptrdiff_t i;
+ unsigned char *p1, *p2;
+ ptrdiff_t s1, s2;
- if (running_asynch_code)
- save_search_regs ();
+ /* Snapshot in case Lisp changes the value. */
+ bool preserve_match_data = NILP (Vinhibit_changing_match_data);
- /* Searching 0 times means don't move. */
- /* Null string is found at starting position. */
- if (len == 0 || n == 0)
+ struct regexp_cache *cache_entry =
+ compile_pattern (string,
+ preserve_match_data ? &search_regs : &search_regs_1,
+ trt, posix,
+ !NILP (BVAR (current_buffer, enable_multibyte_characters)));
+ struct re_pattern_buffer *bufp = &cache_entry->buf;
+
+ maybe_quit (); /* Do a pending quit right away,
+ to avoid paradoxical behavior */
+ /* Get pointers and sizes of the two strings
+ that make up the visible portion of the buffer. */
+
+ p1 = BEGV_ADDR;
+ s1 = GPT_BYTE - BEGV_BYTE;
+ p2 = GAP_END_ADDR;
+ s2 = ZV_BYTE - GPT_BYTE;
+ if (s1 < 0)
{
- set_search_regs (pos_byte, 0);
- return pos;
+ p2 = p1;
+ s2 = ZV_BYTE - BEGV_BYTE;
+ s1 = 0;
}
-
- if (RE && !(trivial_regexp_p (string) && NILP (Vsearch_spaces_regexp)))
+ if (s2 < 0)
{
- unsigned char *p1, *p2;
- ptrdiff_t s1, s2;
- struct re_pattern_buffer *bufp;
+ s1 = ZV_BYTE - BEGV_BYTE;
+ s2 = 0;
+ }
- bufp = compile_pattern (string,
- (NILP (Vinhibit_changing_match_data)
- ? &search_regs : &search_regs_1),
- trt, posix,
- !NILP (BVAR (current_buffer, enable_multibyte_characters)));
+ ptrdiff_t count = SPECPDL_INDEX ();
+ freeze_buffer_relocation ();
+ freeze_pattern (cache_entry);
- maybe_quit (); /* Do a pending quit right away,
- to avoid paradoxical behavior */
- /* Get pointers and sizes of the two strings
- that make up the visible portion of the buffer. */
+ while (n < 0)
+ {
+ ptrdiff_t val;
- p1 = BEGV_ADDR;
- s1 = GPT_BYTE - BEGV_BYTE;
- p2 = GAP_END_ADDR;
- s2 = ZV_BYTE - GPT_BYTE;
- if (s1 < 0)
- {
- p2 = p1;
- s2 = ZV_BYTE - BEGV_BYTE;
- s1 = 0;
- }
- if (s2 < 0)
- {
- s1 = ZV_BYTE - BEGV_BYTE;
- s2 = 0;
- }
re_match_object = Qnil;
+ val = re_search_2 (bufp, (char *) p1, s1, (char *) p2, s2,
+ pos_byte - BEGV_BYTE, lim_byte - pos_byte,
+ preserve_match_data ? &search_regs : &search_regs_1,
+ /* Don't allow match past current point */
+ pos_byte - BEGV_BYTE);
+ if (val == -2)
+ {
+ unbind_to (count, Qnil);
+ matcher_overflow ();
+ }
+ if (val >= 0)
+ {
+ if (preserve_match_data)
+ {
+ pos_byte = search_regs.start[0] + BEGV_BYTE;
+ for (ptrdiff_t i = 0; i < search_regs.num_regs; i++)
+ if (search_regs.start[i] >= 0)
+ {
+ search_regs.start[i]
+ = BYTE_TO_CHAR (search_regs.start[i] + BEGV_BYTE);
+ search_regs.end[i]
+ = BYTE_TO_CHAR (search_regs.end[i] + BEGV_BYTE);
+ }
+ XSETBUFFER (last_thing_searched, current_buffer);
+ /* Set pos to the new position. */
+ pos = search_regs.start[0];
+ }
+ else
+ {
+ pos_byte = search_regs_1.start[0] + BEGV_BYTE;
+ /* Set pos to the new position. */
+ pos = BYTE_TO_CHAR (search_regs_1.start[0] + BEGV_BYTE);
+ }
+ }
+ else
+ {
+ unbind_to (count, Qnil);
+ return (n);
+ }
+ n++;
+ maybe_quit ();
+ }
+ while (n > 0)
+ {
+ ptrdiff_t val;
- freeze_buffer_relocation ();
+ re_match_object = Qnil;
+ val = re_search_2 (bufp, (char *) p1, s1, (char *) p2, s2,
+ pos_byte - BEGV_BYTE, lim_byte - pos_byte,
+ preserve_match_data ? &search_regs : &search_regs_1,
+ lim_byte - BEGV_BYTE);
+ if (val == -2)
+ {
+ unbind_to (count, Qnil);
+ matcher_overflow ();
+ }
+ if (val >= 0)
+ {
+ if (preserve_match_data)
+ {
+ pos_byte = search_regs.end[0] + BEGV_BYTE;
+ for (ptrdiff_t i = 0; i < search_regs.num_regs; i++)
+ if (search_regs.start[i] >= 0)
+ {
+ search_regs.start[i]
+ = BYTE_TO_CHAR (search_regs.start[i] + BEGV_BYTE);
+ search_regs.end[i]
+ = BYTE_TO_CHAR (search_regs.end[i] + BEGV_BYTE);
+ }
+ XSETBUFFER (last_thing_searched, current_buffer);
+ pos = search_regs.end[0];
+ }
+ else
+ {
+ pos_byte = search_regs_1.end[0] + BEGV_BYTE;
+ pos = BYTE_TO_CHAR (search_regs_1.end[0] + BEGV_BYTE);
+ }
+ }
+ else
+ {
+ unbind_to (count, Qnil);
+ return (0 - n);
+ }
+ n--;
+ maybe_quit ();
+ }
+ unbind_to (count, Qnil);
+ return (pos);
+}
- while (n < 0)
- {
- ptrdiff_t val;
-
- val = re_search_2 (bufp, (char *) p1, s1, (char *) p2, s2,
- pos_byte - BEGV_BYTE, lim_byte - pos_byte,
- (NILP (Vinhibit_changing_match_data)
- ? &search_regs : &search_regs_1),
- /* Don't allow match past current point */
- pos_byte - BEGV_BYTE);
- if (val == -2)
- {
- matcher_overflow ();
- }
- if (val >= 0)
- {
- if (NILP (Vinhibit_changing_match_data))
- {
- pos_byte = search_regs.start[0] + BEGV_BYTE;
- for (i = 0; i < search_regs.num_regs; i++)
- if (search_regs.start[i] >= 0)
- {
- search_regs.start[i]
- = BYTE_TO_CHAR (search_regs.start[i] + BEGV_BYTE);
- search_regs.end[i]
- = BYTE_TO_CHAR (search_regs.end[i] + BEGV_BYTE);
- }
- XSETBUFFER (last_thing_searched, current_buffer);
- /* Set pos to the new position. */
- pos = search_regs.start[0];
- }
- else
- {
- pos_byte = search_regs_1.start[0] + BEGV_BYTE;
- /* Set pos to the new position. */
- pos = BYTE_TO_CHAR (search_regs_1.start[0] + BEGV_BYTE);
- }
- }
- else
- {
- thaw_buffer_relocation ();
- return (n);
- }
- n++;
- maybe_quit ();
- }
- while (n > 0)
- {
- ptrdiff_t val;
-
- val = re_search_2 (bufp, (char *) p1, s1, (char *) p2, s2,
- pos_byte - BEGV_BYTE, lim_byte - pos_byte,
- (NILP (Vinhibit_changing_match_data)
- ? &search_regs : &search_regs_1),
- lim_byte - BEGV_BYTE);
- if (val == -2)
- {
- matcher_overflow ();
- }
- if (val >= 0)
- {
- if (NILP (Vinhibit_changing_match_data))
- {
- pos_byte = search_regs.end[0] + BEGV_BYTE;
- for (i = 0; i < search_regs.num_regs; i++)
- if (search_regs.start[i] >= 0)
- {
- search_regs.start[i]
- = BYTE_TO_CHAR (search_regs.start[i] + BEGV_BYTE);
- search_regs.end[i]
- = BYTE_TO_CHAR (search_regs.end[i] + BEGV_BYTE);
- }
- XSETBUFFER (last_thing_searched, current_buffer);
- pos = search_regs.end[0];
- }
- else
- {
- pos_byte = search_regs_1.end[0] + BEGV_BYTE;
- pos = BYTE_TO_CHAR (search_regs_1.end[0] + BEGV_BYTE);
- }
- }
- else
- {
- thaw_buffer_relocation ();
- return (0 - n);
- }
- n--;
- maybe_quit ();
- }
- thaw_buffer_relocation ();
- return (pos);
+static EMACS_INT
+search_buffer_non_re (Lisp_Object string, ptrdiff_t pos,
+ ptrdiff_t pos_byte, ptrdiff_t lim, ptrdiff_t lim_byte,
+ EMACS_INT n, int RE, Lisp_Object trt, Lisp_Object inverse_trt,
+ bool posix)
+{
+ unsigned char *raw_pattern, *pat;
+ ptrdiff_t raw_pattern_size;
+ ptrdiff_t raw_pattern_size_byte;
+ unsigned char *patbuf;
+ bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
+ unsigned char *base_pat;
+ /* Set to positive if we find a non-ASCII char that need
+ translation. Otherwise set to zero later. */
+ int char_base = -1;
+ bool boyer_moore_ok = 1;
+ USE_SAFE_ALLOCA;
+
+ /* MULTIBYTE says whether the text to be searched is multibyte.
+ We must convert PATTERN to match that, or we will not really
+ find things right. */
+
+ if (multibyte == STRING_MULTIBYTE (string))
+ {
+ raw_pattern = SDATA (string);
+ raw_pattern_size = SCHARS (string);
+ raw_pattern_size_byte = SBYTES (string);
}
- else /* non-RE case */
+ else if (multibyte)
{
- unsigned char *raw_pattern, *pat;
- ptrdiff_t raw_pattern_size;
- ptrdiff_t raw_pattern_size_byte;
- unsigned char *patbuf;
- bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
- unsigned char *base_pat;
- /* Set to positive if we find a non-ASCII char that need
- translation. Otherwise set to zero later. */
- int char_base = -1;
- bool boyer_moore_ok = 1;
- USE_SAFE_ALLOCA;
-
- /* MULTIBYTE says whether the text to be searched is multibyte.
- We must convert PATTERN to match that, or we will not really
- find things right. */
-
- if (multibyte == STRING_MULTIBYTE (string))
- {
- raw_pattern = SDATA (string);
- raw_pattern_size = SCHARS (string);
- raw_pattern_size_byte = SBYTES (string);
- }
- else if (multibyte)
- {
- raw_pattern_size = SCHARS (string);
- raw_pattern_size_byte
- = count_size_as_multibyte (SDATA (string),
- raw_pattern_size);
- raw_pattern = SAFE_ALLOCA (raw_pattern_size_byte + 1);
- copy_text (SDATA (string), raw_pattern,
- SCHARS (string), 0, 1);
- }
- else
- {
- /* Converting multibyte to single-byte.
-
- ??? Perhaps this conversion should be done in a special way
- by subtracting nonascii-insert-offset from each non-ASCII char,
- so that only the multibyte chars which really correspond to
- the chosen single-byte character set can possibly match. */
- raw_pattern_size = SCHARS (string);
- raw_pattern_size_byte = SCHARS (string);
- raw_pattern = SAFE_ALLOCA (raw_pattern_size + 1);
- copy_text (SDATA (string), raw_pattern,
- SBYTES (string), 1, 0);
- }
+ raw_pattern_size = SCHARS (string);
+ raw_pattern_size_byte
+ = count_size_as_multibyte (SDATA (string),
+ raw_pattern_size);
+ raw_pattern = SAFE_ALLOCA (raw_pattern_size_byte + 1);
+ copy_text (SDATA (string), raw_pattern,
+ SCHARS (string), 0, 1);
+ }
+ else
+ {
+ /* Converting multibyte to single-byte.
+
+ ??? Perhaps this conversion should be done in a special way
+ by subtracting nonascii-insert-offset from each non-ASCII char,
+ so that only the multibyte chars which really correspond to
+ the chosen single-byte character set can possibly match. */
+ raw_pattern_size = SCHARS (string);
+ raw_pattern_size_byte = SCHARS (string);
+ raw_pattern = SAFE_ALLOCA (raw_pattern_size + 1);
+ copy_text (SDATA (string), raw_pattern,
+ SBYTES (string), 1, 0);
+ }
- /* Copy and optionally translate the pattern. */
- len = raw_pattern_size;
- len_byte = raw_pattern_size_byte;
- SAFE_NALLOCA (patbuf, MAX_MULTIBYTE_LENGTH, len);
- pat = patbuf;
- base_pat = raw_pattern;
- if (multibyte)
- {
- /* Fill patbuf by translated characters in STRING while
- checking if we can use boyer-moore search. If TRT is
- non-nil, we can use boyer-moore search only if TRT can be
- represented by the byte array of 256 elements. For that,
- all non-ASCII case-equivalents of all case-sensitive
- characters in STRING must belong to the same character
- group (two characters belong to the same group iff their
- multibyte forms are the same except for the last byte;
- i.e. every 64 characters form a group; U+0000..U+003F,
- U+0040..U+007F, U+0080..U+00BF, ...). */
-
- while (--len >= 0)
- {
- unsigned char str_base[MAX_MULTIBYTE_LENGTH], *str;
- int c, translated, inverse;
- int in_charlen, charlen;
-
- /* If we got here and the RE flag is set, it's because we're
- dealing with a regexp known to be trivial, so the backslash
- just quotes the next character. */
- if (RE && *base_pat == '\\')
- {
- len--;
- raw_pattern_size--;
- len_byte--;
- base_pat++;
- }
+ /* Copy and optionally translate the pattern. */
+ ptrdiff_t len = raw_pattern_size;
+ ptrdiff_t len_byte = raw_pattern_size_byte;
+ SAFE_NALLOCA (patbuf, MAX_MULTIBYTE_LENGTH, len);
+ pat = patbuf;
+ base_pat = raw_pattern;
+ if (multibyte)
+ {
+ /* Fill patbuf by translated characters in STRING while
+ checking if we can use boyer-moore search. If TRT is
+ non-nil, we can use boyer-moore search only if TRT can be
+ represented by the byte array of 256 elements. For that,
+ all non-ASCII case-equivalents of all case-sensitive
+ characters in STRING must belong to the same character
+ group (two characters belong to the same group iff their
+ multibyte forms are the same except for the last byte;
+ i.e. every 64 characters form a group; U+0000..U+003F,
+ U+0040..U+007F, U+0080..U+00BF, ...). */
+
+ while (--len >= 0)
+ {
+ unsigned char str_base[MAX_MULTIBYTE_LENGTH], *str;
+ int c, translated, inverse;
+ int in_charlen, charlen;
+
+ /* If we got here and the RE flag is set, it's because we're
+ dealing with a regexp known to be trivial, so the backslash
+ just quotes the next character. */
+ if (RE && *base_pat == '\\')
+ {
+ len--;
+ raw_pattern_size--;
+ len_byte--;
+ base_pat++;
+ }
- c = STRING_CHAR_AND_LENGTH (base_pat, in_charlen);
+ c = STRING_CHAR_AND_LENGTH (base_pat, in_charlen);
- if (NILP (trt))
- {
- str = base_pat;
- charlen = in_charlen;
- }
- else
- {
- /* Translate the character. */
- TRANSLATE (translated, trt, c);
- charlen = CHAR_STRING (translated, str_base);
- str = str_base;
-
- /* Check if C has any other case-equivalents. */
- TRANSLATE (inverse, inverse_trt, c);
- /* If so, check if we can use boyer-moore. */
- if (c != inverse && boyer_moore_ok)
- {
- /* Check if all equivalents belong to the same
- group of characters. Note that the check of C
- itself is done by the last iteration. */
- int this_char_base = -1;
+ if (NILP (trt))
+ {
+ str = base_pat;
+ charlen = in_charlen;
+ }
+ else
+ {
+ /* Translate the character. */
+ TRANSLATE (translated, trt, c);
+ charlen = CHAR_STRING (translated, str_base);
+ str = str_base;
+
+ /* Check if C has any other case-equivalents. */
+ TRANSLATE (inverse, inverse_trt, c);
+ /* If so, check if we can use boyer-moore. */
+ if (c != inverse && boyer_moore_ok)
+ {
+ /* Check if all equivalents belong to the same
+ group of characters. Note that the check of C
+ itself is done by the last iteration. */
+ int this_char_base = -1;
+
+ while (boyer_moore_ok)
+ {
+ if (ASCII_CHAR_P (inverse))
+ {
+ if (this_char_base > 0)
+ boyer_moore_ok = 0;
+ else
+ this_char_base = 0;
+ }
+ else if (CHAR_BYTE8_P (inverse))
+ /* Boyer-moore search can't handle a
+ translation of an eight-bit
+ character. */
+ boyer_moore_ok = 0;
+ else if (this_char_base < 0)
+ {
+ this_char_base = inverse & ~0x3F;
+ if (char_base < 0)
+ char_base = this_char_base;
+ else if (this_char_base != char_base)
+ boyer_moore_ok = 0;
+ }
+ else if ((inverse & ~0x3F) != this_char_base)
+ boyer_moore_ok = 0;
+ if (c == inverse)
+ break;
+ TRANSLATE (inverse, inverse_trt, inverse);
+ }
+ }
+ }
- while (boyer_moore_ok)
- {
- if (ASCII_CHAR_P (inverse))
- {
- if (this_char_base > 0)
- boyer_moore_ok = 0;
- else
- this_char_base = 0;
- }
- else if (CHAR_BYTE8_P (inverse))
- /* Boyer-moore search can't handle a
- translation of an eight-bit
- character. */
- boyer_moore_ok = 0;
- else if (this_char_base < 0)
- {
- this_char_base = inverse & ~0x3F;
- if (char_base < 0)
- char_base = this_char_base;
- else if (this_char_base != char_base)
- boyer_moore_ok = 0;
- }
- else if ((inverse & ~0x3F) != this_char_base)
- boyer_moore_ok = 0;
- if (c == inverse)
- break;
- TRANSLATE (inverse, inverse_trt, inverse);
- }
- }
- }
+ /* Store this character into the translated pattern. */
+ memcpy (pat, str, charlen);
+ pat += charlen;
+ base_pat += in_charlen;
+ len_byte -= in_charlen;
+ }
- /* Store this character into the translated pattern. */
- memcpy (pat, str, charlen);
- pat += charlen;
- base_pat += in_charlen;
- len_byte -= in_charlen;
- }
+ /* If char_base is still negative we didn't find any translated
+ non-ASCII characters. */
+ if (char_base < 0)
+ char_base = 0;
+ }
+ else
+ {
+ /* Unibyte buffer. */
+ char_base = 0;
+ while (--len >= 0)
+ {
+ int c, translated, inverse;
- /* If char_base is still negative we didn't find any translated
- non-ASCII characters. */
- if (char_base < 0)
- char_base = 0;
- }
- else
- {
- /* Unibyte buffer. */
- char_base = 0;
- while (--len >= 0)
- {
- int c, translated, inverse;
+ /* If we got here and the RE flag is set, it's because we're
+ dealing with a regexp known to be trivial, so the backslash
+ just quotes the next character. */
+ if (RE && *base_pat == '\\')
+ {
+ len--;
+ raw_pattern_size--;
+ base_pat++;
+ }
+ c = *base_pat++;
+ TRANSLATE (translated, trt, c);
+ *pat++ = translated;
+ /* Check that none of C's equivalents violates the
+ assumptions of boyer_moore. */
+ TRANSLATE (inverse, inverse_trt, c);
+ while (1)
+ {
+ if (inverse >= 0200)
+ {
+ boyer_moore_ok = 0;
+ break;
+ }
+ if (c == inverse)
+ break;
+ TRANSLATE (inverse, inverse_trt, inverse);
+ }
+ }
+ }
- /* If we got here and the RE flag is set, it's because we're
- dealing with a regexp known to be trivial, so the backslash
- just quotes the next character. */
- if (RE && *base_pat == '\\')
- {
- len--;
- raw_pattern_size--;
- base_pat++;
- }
- c = *base_pat++;
- TRANSLATE (translated, trt, c);
- *pat++ = translated;
- /* Check that none of C's equivalents violates the
- assumptions of boyer_moore. */
- TRANSLATE (inverse, inverse_trt, c);
- while (1)
- {
- if (inverse >= 0200)
- {
- boyer_moore_ok = 0;
- break;
- }
- if (c == inverse)
- break;
- TRANSLATE (inverse, inverse_trt, inverse);
- }
- }
- }
+ len_byte = pat - patbuf;
+ pat = base_pat = patbuf;
+
+ EMACS_INT result
+ = (boyer_moore_ok
+ ? boyer_moore (n, pat, len_byte, trt, inverse_trt,
+ pos_byte, lim_byte,
+ char_base)
+ : simple_search (n, pat, raw_pattern_size, len_byte, trt,
+ pos, pos_byte, lim, lim_byte));
+ SAFE_FREE ();
+ return result;
+}
- len_byte = pat - patbuf;
- pat = base_pat = patbuf;
-
- EMACS_INT result
- = (boyer_moore_ok
- ? boyer_moore (n, pat, len_byte, trt, inverse_trt,
- pos_byte, lim_byte,
- char_base)
- : simple_search (n, pat, raw_pattern_size, len_byte, trt,
- pos, pos_byte, lim, lim_byte));
- SAFE_FREE ();
- return result;
+static EMACS_INT
+search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte,
+ ptrdiff_t lim, ptrdiff_t lim_byte, EMACS_INT n,
+ int RE, Lisp_Object trt, Lisp_Object inverse_trt, bool posix)
+{
+ if (running_asynch_code)
+ save_search_regs ();
+
+ /* Searching 0 times means don't move. */
+ /* Null string is found at starting position. */
+ if (n == 0 || SCHARS (string) == 0)
+ {
+ set_search_regs (pos_byte, 0);
+ return pos;
}
+
+ if (RE && !(trivial_regexp_p (string) && NILP (Vsearch_spaces_regexp)))
+ pos = search_buffer_re (string, pos, pos_byte, lim, lim_byte,
+ n, trt, inverse_trt, posix);
+ else
+ pos = search_buffer_non_re (string, pos, pos_byte, lim, lim_byte,
+ n, RE, trt, inverse_trt, posix);
+
+ return pos;
}
/* Do a simple string search N times for the string PAT,
@@ -2159,8 +2167,8 @@ set_search_regs (ptrdiff_t beg_byte, ptrdiff_t nbytes)
the match position. */
if (search_regs.num_regs == 0)
{
- search_regs.start = xmalloc (2 * sizeof (regoff_t));
- search_regs.end = xmalloc (2 * sizeof (regoff_t));
+ search_regs.start = xmalloc (2 * sizeof *search_regs.start);
+ search_regs.end = xmalloc (2 * sizeof *search_regs.end);
search_regs.num_regs = 2;
}
@@ -2393,10 +2401,10 @@ since only regular expressions have distinguished subexpressions. */)
sub = 0;
else
{
- CHECK_NUMBER (subexp);
- if (! (0 <= XINT (subexp) && XINT (subexp) < search_regs.num_regs))
- args_out_of_range (subexp, make_number (search_regs.num_regs));
- sub = XINT (subexp);
+ CHECK_FIXNUM (subexp);
+ if (! (0 <= XFIXNUM (subexp) && XFIXNUM (subexp) < search_regs.num_regs))
+ args_out_of_range (subexp, make_fixnum (search_regs.num_regs));
+ sub = XFIXNUM (subexp);
}
if (NILP (string))
@@ -2404,16 +2412,16 @@ since only regular expressions have distinguished subexpressions. */)
if (search_regs.start[sub] < BEGV
|| search_regs.start[sub] > search_regs.end[sub]
|| search_regs.end[sub] > ZV)
- args_out_of_range (make_number (search_regs.start[sub]),
- make_number (search_regs.end[sub]));
+ args_out_of_range (make_fixnum (search_regs.start[sub]),
+ make_fixnum (search_regs.end[sub]));
}
else
{
if (search_regs.start[sub] < 0
|| search_regs.start[sub] > search_regs.end[sub]
|| search_regs.end[sub] > SCHARS (string))
- args_out_of_range (make_number (search_regs.start[sub]),
- make_number (search_regs.end[sub]));
+ args_out_of_range (make_fixnum (search_regs.start[sub]),
+ make_fixnum (search_regs.end[sub]));
}
if (NILP (fixedcase))
@@ -2498,9 +2506,9 @@ since only regular expressions have distinguished subexpressions. */)
{
Lisp_Object before, after;
- before = Fsubstring (string, make_number (0),
- make_number (search_regs.start[sub]));
- after = Fsubstring (string, make_number (search_regs.end[sub]), Qnil);
+ before = Fsubstring (string, make_fixnum (0),
+ make_fixnum (search_regs.start[sub]));
+ after = Fsubstring (string, make_fixnum (search_regs.end[sub]), Qnil);
/* Substitute parts of the match into NEWTEXT
if desired. */
@@ -2563,8 +2571,8 @@ since only regular expressions have distinguished subexpressions. */)
middle = Qnil;
accum = concat3 (accum, middle,
Fsubstring (string,
- make_number (substart),
- make_number (subend)));
+ make_fixnum (substart),
+ make_fixnum (subend)));
lastpos = pos;
lastpos_byte = pos_byte;
}
@@ -2738,7 +2746,7 @@ since only regular expressions have distinguished subexpressions. */)
error out since otherwise this will result in confusing bugs. */
ptrdiff_t sub_start = search_regs.start[sub];
ptrdiff_t sub_end = search_regs.end[sub];
- unsigned num_regs = search_regs.num_regs;
+ ptrdiff_t num_regs = search_regs.num_regs;
newpoint = search_regs.start[sub] + SCHARS (newtext);
/* Replace the old text with the new in the cleanest possible way. */
@@ -2753,12 +2761,12 @@ since only regular expressions have distinguished subexpressions. */)
}
if (case_action == all_caps)
- Fupcase_region (make_number (search_regs.start[sub]),
- make_number (newpoint),
+ Fupcase_region (make_fixnum (search_regs.start[sub]),
+ make_fixnum (newpoint),
Qnil);
else if (case_action == cap_initial)
- Fupcase_initials_region (make_number (search_regs.start[sub]),
- make_number (newpoint));
+ Fupcase_initials_region (make_fixnum (search_regs.start[sub]),
+ make_fixnum (newpoint));
if (search_regs.start[sub] != sub_start
|| search_regs.end[sub] != sub_end
@@ -2782,16 +2790,16 @@ match_limit (Lisp_Object num, bool beginningp)
{
EMACS_INT n;
- CHECK_NUMBER (num);
- n = XINT (num);
+ CHECK_FIXNUM (num);
+ n = XFIXNUM (num);
if (n < 0)
- args_out_of_range (num, make_number (0));
+ args_out_of_range (num, make_fixnum (0));
if (search_regs.num_regs <= 0)
error ("No match data, because no search succeeded");
if (n >= search_regs.num_regs
|| search_regs.start[n] < 0)
return Qnil;
- return (make_number ((beginningp) ? search_regs.start[n]
+ return (make_fixnum ((beginningp) ? search_regs.start[n]
: search_regs.end[n]));
}
@@ -2881,11 +2889,11 @@ Return value is undefined if the last search failed. */)
{
data[2 * i] = Fmake_marker ();
Fset_marker (data[2 * i],
- make_number (start),
+ make_fixnum (start),
last_thing_searched);
data[2 * i + 1] = Fmake_marker ();
Fset_marker (data[2 * i + 1],
- make_number (search_regs.end[i]),
+ make_fixnum (search_regs.end[i]),
last_thing_searched);
}
else
@@ -2962,18 +2970,16 @@ If optional arg RESEAT is non-nil, make markers on LIST point nowhere. */)
/* Allocate registers if they don't already exist. */
{
- EMACS_INT length = XFASTINT (Flength (list)) / 2;
+ ptrdiff_t length = list_length (list) / 2;
if (length > search_regs.num_regs)
{
ptrdiff_t num_regs = search_regs.num_regs;
- if (PTRDIFF_MAX < length)
- memory_full (SIZE_MAX);
search_regs.start =
xpalloc (search_regs.start, &num_regs, length - num_regs,
- min (PTRDIFF_MAX, UINT_MAX), sizeof (regoff_t));
+ min (PTRDIFF_MAX, UINT_MAX), sizeof *search_regs.start);
search_regs.end =
- xrealloc (search_regs.end, num_regs * sizeof (regoff_t));
+ xrealloc (search_regs.end, num_regs * sizeof *search_regs.end);
for (i = search_regs.num_regs; i < num_regs; i++)
search_regs.start[i] = -1;
@@ -3010,7 +3016,7 @@ If optional arg RESEAT is non-nil, make markers on LIST point nowhere. */)
XSETBUFFER (last_thing_searched, XMARKER (marker)->buffer);
}
- CHECK_NUMBER_COERCE_MARKER (marker);
+ CHECK_FIXNUM_COERCE_MARKER (marker);
from = marker;
if (!NILP (reseat) && MARKERP (m))
@@ -3027,16 +3033,13 @@ If optional arg RESEAT is non-nil, make markers on LIST point nowhere. */)
if (MARKERP (marker) && XMARKER (marker)->buffer == 0)
XSETFASTINT (marker, 0);
- CHECK_NUMBER_COERCE_MARKER (marker);
- if ((XINT (from) < 0
- ? TYPE_MINIMUM (regoff_t) <= XINT (from)
- : XINT (from) <= TYPE_MAXIMUM (regoff_t))
- && (XINT (marker) < 0
- ? TYPE_MINIMUM (regoff_t) <= XINT (marker)
- : XINT (marker) <= TYPE_MAXIMUM (regoff_t)))
+ CHECK_FIXNUM_COERCE_MARKER (marker);
+ if (PTRDIFF_MIN <= XFIXNUM (from) && XFIXNUM (from) <= PTRDIFF_MAX
+ && PTRDIFF_MIN <= XFIXNUM (marker)
+ && XFIXNUM (marker) <= PTRDIFF_MAX)
{
- search_regs.start[i] = XINT (from);
- search_regs.end[i] = XINT (marker);
+ search_regs.start[i] = XFIXNUM (from);
+ search_regs.end[i] = XFIXNUM (marker);
}
else
{
@@ -3059,29 +3062,19 @@ If optional arg RESEAT is non-nil, make markers on LIST point nowhere. */)
return Qnil;
}
-/* If true the match data have been saved in saved_search_regs
- during the execution of a sentinel or filter. */
-/* static bool search_regs_saved; */
-/* static struct re_registers saved_search_regs; */
-/* static Lisp_Object saved_last_thing_searched; */
-
/* Called from Flooking_at, Fstring_match, search_buffer, Fstore_match_data
if asynchronous code (filter or sentinel) is running. */
static void
save_search_regs (void)
{
- if (!search_regs_saved)
+ if (saved_search_regs.num_regs == 0)
{
- saved_search_regs.num_regs = search_regs.num_regs;
- saved_search_regs.start = search_regs.start;
- saved_search_regs.end = search_regs.end;
+ saved_search_regs = search_regs;
saved_last_thing_searched = last_thing_searched;
last_thing_searched = Qnil;
search_regs.num_regs = 0;
search_regs.start = 0;
search_regs.end = 0;
-
- search_regs_saved = 1;
}
}
@@ -3089,19 +3082,17 @@ save_search_regs (void)
void
restore_search_regs (void)
{
- if (search_regs_saved)
+ if (saved_search_regs.num_regs != 0)
{
if (search_regs.num_regs > 0)
{
xfree (search_regs.start);
xfree (search_regs.end);
}
- search_regs.num_regs = saved_search_regs.num_regs;
- search_regs.start = saved_search_regs.start;
- search_regs.end = saved_search_regs.end;
+ search_regs = saved_search_regs;
last_thing_searched = saved_last_thing_searched;
saved_last_thing_searched = Qnil;
- search_regs_saved = 0;
+ saved_search_regs.num_regs = 0;
}
}
@@ -3184,7 +3175,7 @@ DEFUN ("regexp-quote", Fregexp_quote, Sregexp_quote, 1, 1, 0,
/* Like find_newline, but doesn't use the cache, and only searches forward. */
static ptrdiff_t
find_newline1 (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
- ptrdiff_t end_byte, ptrdiff_t count, ptrdiff_t *shortage,
+ ptrdiff_t end_byte, ptrdiff_t count, ptrdiff_t *counted,
ptrdiff_t *bytepos, bool allow_quit)
{
if (count > 0)
@@ -3200,8 +3191,8 @@ find_newline1 (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
if (end_byte == -1)
end_byte = CHAR_TO_BYTE (end);
- if (shortage != 0)
- *shortage = 0;
+ if (counted)
+ *counted = count;
if (count > 0)
while (start != end)
@@ -3258,8 +3249,8 @@ find_newline1 (ptrdiff_t start, ptrdiff_t start_byte, ptrdiff_t end,
}
}
- if (shortage)
- *shortage = count;
+ if (counted)
+ *counted -= count;
if (bytepos)
{
*bytepos = start_byte == -1 ? CHAR_TO_BYTE (start) : start_byte;
@@ -3280,7 +3271,7 @@ the buffer. If the buffer doesn't have a cache, the value is nil. */)
(Lisp_Object buffer)
{
struct buffer *buf, *old = NULL;
- ptrdiff_t shortage, nl_count_cache, nl_count_buf;
+ ptrdiff_t nl_count_cache, nl_count_buf;
Lisp_Object cache_newlines, buf_newlines, val;
ptrdiff_t from, found, i;
@@ -3306,8 +3297,7 @@ the buffer. If the buffer doesn't have a cache, the value is nil. */)
/* How many newlines are there according to the cache? */
find_newline (BEGV, BEGV_BYTE, ZV, ZV_BYTE,
- TYPE_MAXIMUM (ptrdiff_t), &shortage, NULL, true);
- nl_count_cache = TYPE_MAXIMUM (ptrdiff_t) - shortage;
+ TYPE_MAXIMUM (ptrdiff_t), &nl_count_cache, NULL, true);
/* Create vector and populate it. */
cache_newlines = make_uninit_vector (nl_count_cache);
@@ -3316,38 +3306,37 @@ the buffer. If the buffer doesn't have a cache, the value is nil. */)
{
for (from = BEGV, found = from, i = 0; from < ZV; from = found, i++)
{
- ptrdiff_t from_byte = CHAR_TO_BYTE (from);
+ ptrdiff_t from_byte = CHAR_TO_BYTE (from), counted;
- found = find_newline (from, from_byte, 0, -1, 1, &shortage,
+ found = find_newline (from, from_byte, 0, -1, 1, &counted,
NULL, true);
- if (shortage != 0 || i >= nl_count_cache)
+ if (counted == 0 || i >= nl_count_cache)
break;
- ASET (cache_newlines, i, make_number (found - 1));
+ ASET (cache_newlines, i, make_fixnum (found - 1));
}
/* Fill the rest of slots with an invalid position. */
for ( ; i < nl_count_cache; i++)
- ASET (cache_newlines, i, make_number (-1));
+ ASET (cache_newlines, i, make_fixnum (-1));
}
/* Now do the same, but without using the cache. */
find_newline1 (BEGV, BEGV_BYTE, ZV, ZV_BYTE,
- TYPE_MAXIMUM (ptrdiff_t), &shortage, NULL, true);
- nl_count_buf = TYPE_MAXIMUM (ptrdiff_t) - shortage;
+ TYPE_MAXIMUM (ptrdiff_t), &nl_count_buf, NULL, true);
buf_newlines = make_uninit_vector (nl_count_buf);
if (nl_count_buf)
{
for (from = BEGV, found = from, i = 0; from < ZV; from = found, i++)
{
- ptrdiff_t from_byte = CHAR_TO_BYTE (from);
+ ptrdiff_t from_byte = CHAR_TO_BYTE (from), counted;
- found = find_newline1 (from, from_byte, 0, -1, 1, &shortage,
+ found = find_newline1 (from, from_byte, 0, -1, 1, &counted,
NULL, true);
- if (shortage != 0 || i >= nl_count_buf)
+ if (counted == 0 || i >= nl_count_buf)
break;
- ASET (buf_newlines, i, make_number (found - 1));
+ ASET (buf_newlines, i, make_fixnum (found - 1));
}
for ( ; i < nl_count_buf; i++)
- ASET (buf_newlines, i, make_number (-1));
+ ASET (buf_newlines, i, make_fixnum (-1));
}
/* Construct the value and return it. */
@@ -3360,25 +3349,18 @@ the buffer. If the buffer doesn't have a cache, the value is nil. */)
return val;
}
+
+static void syms_of_search_for_pdumper (void);
+
void
syms_of_search (void)
{
- register int i;
-
- for (i = 0; i < REGEXP_CACHE_SIZE; ++i)
+ for (int i = 0; i < REGEXP_CACHE_SIZE; ++i)
{
- searchbufs[i].buf.allocated = 100;
- searchbufs[i].buf.buffer = xmalloc (100);
- searchbufs[i].buf.fastmap = searchbufs[i].fastmap;
- searchbufs[i].regexp = Qnil;
- searchbufs[i].f_whitespace_regexp = Qnil;
- searchbufs[i].syntax_table = Qnil;
staticpro (&searchbufs[i].regexp);
staticpro (&searchbufs[i].f_whitespace_regexp);
staticpro (&searchbufs[i].syntax_table);
- searchbufs[i].next = (i == REGEXP_CACHE_SIZE-1 ? 0 : &searchbufs[i+1]);
}
- searchbuf_head = &searchbufs[0];
/* Error condition used for failing searches. */
DEFSYM (Qsearch_failed, "search-failed");
@@ -3391,18 +3373,17 @@ syms_of_search (void)
DEFSYM (Qinvalid_regexp, "invalid-regexp");
Fput (Qsearch_failed, Qerror_conditions,
- listn (CONSTYPE_PURE, 2, Qsearch_failed, Qerror));
+ pure_list (Qsearch_failed, Qerror));
Fput (Qsearch_failed, Qerror_message,
build_pure_c_string ("Search failed"));
Fput (Quser_search_failed, Qerror_conditions,
- listn (CONSTYPE_PURE, 4,
- Quser_search_failed, Quser_error, Qsearch_failed, Qerror));
+ pure_list (Quser_search_failed, Quser_error, Qsearch_failed, Qerror));
Fput (Quser_search_failed, Qerror_message,
build_pure_c_string ("Search failed"));
Fput (Qinvalid_regexp, Qerror_conditions,
- listn (CONSTYPE_PURE, 2, Qinvalid_regexp, Qerror));
+ pure_list (Qinvalid_regexp, Qerror));
Fput (Qinvalid_regexp, Qerror_message,
build_pure_c_string ("Invalid regexp"));
@@ -3412,6 +3393,9 @@ syms_of_search (void)
saved_last_thing_searched = Qnil;
staticpro (&saved_last_thing_searched);
+ re_match_object = Qnil;
+ staticpro (&re_match_object);
+
DEFVAR_LISP ("search-spaces-regexp", Vsearch_spaces_regexp,
doc: /* Regexp to substitute for bunches of spaces in regexp search.
Some commands use this for user-specified regexps.
@@ -3446,4 +3430,23 @@ is to bind it with `let' around a small expression. */);
defsubr (&Sset_match_data);
defsubr (&Sregexp_quote);
defsubr (&Snewline_cache_check);
+
+ pdumper_do_now_and_after_load (syms_of_search_for_pdumper);
+}
+
+static void
+syms_of_search_for_pdumper (void)
+{
+ for (int i = 0; i < REGEXP_CACHE_SIZE; ++i)
+ {
+ searchbufs[i].buf.allocated = 100;
+ searchbufs[i].buf.buffer = xmalloc (100);
+ searchbufs[i].buf.fastmap = searchbufs[i].fastmap;
+ searchbufs[i].regexp = Qnil;
+ searchbufs[i].f_whitespace_regexp = Qnil;
+ searchbufs[i].busy = false;
+ searchbufs[i].syntax_table = Qnil;
+ searchbufs[i].next = (i == REGEXP_CACHE_SIZE-1 ? 0 : &searchbufs[i+1]);
+ }
+ searchbuf_head = &searchbufs[0];
}
diff --git a/src/sheap.c b/src/sheap.c
index f019c7ee3c4..015ee5786ff 100644
--- a/src/sheap.c
+++ b/src/sheap.c
@@ -31,7 +31,6 @@ static int debug_sheap;
char bss_sbrk_buffer[STATIC_HEAP_SIZE];
char *max_bss_sbrk_ptr;
-bool bss_sbrk_did_unexec;
void *
bss_sbrk (ptrdiff_t request_size)
diff --git a/src/sheap.h b/src/sheap.h
index 27300814b07..a5653288f5b 100644
--- a/src/sheap.h
+++ b/src/sheap.h
@@ -27,5 +27,4 @@ enum { STATIC_HEAP_SIZE = sizeof (Lisp_Object) << 22 };
extern char bss_sbrk_buffer[STATIC_HEAP_SIZE];
extern char *max_bss_sbrk_ptr;
-extern bool bss_sbrk_did_unexec;
extern void *bss_sbrk (ptrdiff_t);
diff --git a/src/sound.c b/src/sound.c
index c1f869045f5..2b8715010e7 100644
--- a/src/sound.c
+++ b/src/sound.c
@@ -2,6 +2,8 @@
Copyright (C) 1998-1999, 2001-2019 Free Software Foundation, Inc.
+Author: Gerd Moellmann <gerd@gnu.org>
+
This file is part of GNU Emacs.
GNU Emacs is free software: you can redistribute it and/or modify
@@ -17,8 +19,7 @@ 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 <https://www.gnu.org/licenses/>. */
-/* Written by Gerd Moellmann <gerd@gnu.org>. Tested with Luigi's
- driver on FreeBSD 2.2.7 with a SoundBlaster 16. */
+/* Tested with Luigi's driver on FreeBSD 2.2.7 with a SoundBlaster 16. */
/*
Modified by Ben Key <Bkey1@tampabay.rr.com> to add a partial
@@ -384,9 +385,9 @@ parse_sound (Lisp_Object sound, Lisp_Object *attrs)
/* Volume must be in the range 0..100 or unspecified. */
if (!NILP (attrs[SOUND_VOLUME]))
{
- if (INTEGERP (attrs[SOUND_VOLUME]))
+ if (FIXNUMP (attrs[SOUND_VOLUME]))
{
- EMACS_INT volume = XINT (attrs[SOUND_VOLUME]);
+ EMACS_INT volume = XFIXNUM (attrs[SOUND_VOLUME]);
if (! (0 <= volume && volume <= 100))
return 0;
}
@@ -1399,8 +1400,8 @@ Internal use only, use `play-sound' instead. */)
/* Set up a device. */
current_sound_device->file = attrs[SOUND_DEVICE];
- if (INTEGERP (attrs[SOUND_VOLUME]))
- current_sound_device->volume = XFASTINT (attrs[SOUND_VOLUME]);
+ if (FIXNUMP (attrs[SOUND_VOLUME]))
+ current_sound_device->volume = XFIXNAT (attrs[SOUND_VOLUME]);
else if (FLOATP (attrs[SOUND_VOLUME]))
current_sound_device->volume = XFLOAT_DATA (attrs[SOUND_VOLUME]) * 100;
@@ -1422,9 +1423,9 @@ Internal use only, use `play-sound' instead. */)
file = Fexpand_file_name (attrs[SOUND_FILE], Vdata_directory);
file = ENCODE_FILE (file);
- if (INTEGERP (attrs[SOUND_VOLUME]))
+ if (FIXNUMP (attrs[SOUND_VOLUME]))
{
- ui_volume_tmp = XFASTINT (attrs[SOUND_VOLUME]);
+ ui_volume_tmp = XFIXNAT (attrs[SOUND_VOLUME]);
}
else if (FLOATP (attrs[SOUND_VOLUME]))
{
diff --git a/src/syntax.c b/src/syntax.c
index 3cc32094a8c..edfdae22590 100644
--- a/src/syntax.c
+++ b/src/syntax.c
@@ -23,7 +23,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "lisp.h"
#include "character.h"
#include "buffer.h"
-#include "regex.h"
+#include "regex-emacs.h"
#include "syntax.h"
#include "intervals.h"
#include "category.h"
@@ -175,7 +175,7 @@ static ptrdiff_t find_start_value;
static ptrdiff_t find_start_value_byte;
static struct buffer *find_start_buffer;
static ptrdiff_t find_start_begv;
-static EMACS_INT find_start_modiff;
+static modiff_count find_start_modiff;
static Lisp_Object skip_chars (bool, Lisp_Object, Lisp_Object, bool);
@@ -267,9 +267,10 @@ SETUP_SYNTAX_TABLE (ptrdiff_t from, ptrdiff_t count)
If it is t (which is only used in fast_c_string_match_ignore_case),
ignore properties altogether.
- This is meant for regex.c to use. For buffers, regex.c passes arguments
- to the UPDATE_SYNTAX_TABLE functions which are relative to BEGV.
- So if it is a buffer, we set the offset field to BEGV. */
+ This is meant for regex-emacs.c to use. For buffers, regex-emacs.c
+ passes arguments to the UPDATE_SYNTAX_TABLE functions which are
+ relative to BEGV. So if it is a buffer, we set the offset field to
+ BEGV. */
void
SETUP_SYNTAX_TABLE_FOR_OBJECT (Lisp_Object object,
@@ -308,7 +309,7 @@ SETUP_SYNTAX_TABLE_FOR_OBJECT (Lisp_Object object,
}
/* Update gl_state to an appropriate interval which contains CHARPOS. The
- sign of COUNT give the relative position of CHARPOS wrt the previously
+ sign of COUNT gives the relative position of CHARPOS wrt the previously
valid interval. If INIT, only [be]_property fields of gl_state are
valid at start, the rest is filled basing on OBJECT.
@@ -339,59 +340,46 @@ update_syntax_table (ptrdiff_t charpos, EMACS_INT count, bool init,
invalidate = false;
if (!i)
return;
- /* interval_of updates only ->position of the return value, so
- update the parents manually to speed up update_interval. */
- while (!NULL_PARENT (i))
- {
- if (AM_RIGHT_CHILD (i))
- INTERVAL_PARENT (i)->position = i->position
- - LEFT_TOTAL_LENGTH (i) + TOTAL_LENGTH (i) /* right end */
- - TOTAL_LENGTH (INTERVAL_PARENT (i))
- + LEFT_TOTAL_LENGTH (INTERVAL_PARENT (i));
- else
- INTERVAL_PARENT (i)->position = i->position - LEFT_TOTAL_LENGTH (i)
- + TOTAL_LENGTH (i);
- i = INTERVAL_PARENT (i);
- }
i = gl_state.forward_i;
gl_state.b_property = i->position - gl_state.offset;
gl_state.e_property = INTERVAL_LAST_POS (i) - gl_state.offset;
- goto update;
- }
- i = count > 0 ? gl_state.forward_i : gl_state.backward_i;
-
- /* We are guaranteed to be called with CHARPOS either in i,
- or further off. */
- if (!i)
- error ("Error in syntax_table logic for to-the-end intervals");
- else if (charpos < i->position) /* Move left. */
- {
- if (count > 0)
- error ("Error in syntax_table logic for intervals <-");
- /* Update the interval. */
- i = update_interval (i, charpos);
- if (INTERVAL_LAST_POS (i) != gl_state.b_property)
- {
- invalidate = false;
- gl_state.forward_i = i;
- gl_state.e_property = INTERVAL_LAST_POS (i) - gl_state.offset;
- }
}
- else if (charpos >= INTERVAL_LAST_POS (i)) /* Move right. */
+ else
{
- if (count < 0)
- error ("Error in syntax_table logic for intervals ->");
- /* Update the interval. */
- i = update_interval (i, charpos);
- if (i->position != gl_state.e_property)
- {
- invalidate = false;
- gl_state.backward_i = i;
- gl_state.b_property = i->position - gl_state.offset;
- }
+ i = count > 0 ? gl_state.forward_i : gl_state.backward_i;
+
+ /* We are guaranteed to be called with CHARPOS either in i,
+ or further off. */
+ if (!i)
+ error ("Error in syntax_table logic for to-the-end intervals");
+ else if (charpos < i->position) /* Move left. */
+ {
+ if (count > 0)
+ error ("Error in syntax_table logic for intervals <-");
+ /* Update the interval. */
+ i = update_interval (i, charpos);
+ if (INTERVAL_LAST_POS (i) != gl_state.b_property)
+ {
+ invalidate = false;
+ gl_state.forward_i = i;
+ gl_state.e_property = INTERVAL_LAST_POS (i) - gl_state.offset;
+ }
+ }
+ else if (charpos >= INTERVAL_LAST_POS (i)) /* Move right. */
+ {
+ if (count < 0)
+ error ("Error in syntax_table logic for intervals ->");
+ /* Update the interval. */
+ i = update_interval (i, charpos);
+ if (i->position != gl_state.e_property)
+ {
+ invalidate = false;
+ gl_state.backward_i = i;
+ gl_state.b_property = i->position - gl_state.offset;
+ }
+ }
}
- update:
tmp_table = textget (i->plist, Qsyntax_table);
if (invalidate)
@@ -488,9 +476,9 @@ parse_sexp_propertize (ptrdiff_t charpos)
if (syntax_propertize__done <= charpos
&& syntax_propertize__done < zv)
{
- EMACS_INT modiffs = CHARS_MODIFF;
+ modiff_count modiffs = CHARS_MODIFF;
safe_call1 (Qinternal__syntax_propertize,
- make_number (min (zv, 1 + charpos)));
+ make_fixnum (min (zv, 1 + charpos)));
if (modiffs != CHARS_MODIFF)
error ("parse-sexp-propertize-function modified the buffer!");
if (syntax_propertize__done <= charpos
@@ -605,6 +593,26 @@ find_defun_start (ptrdiff_t pos, ptrdiff_t pos_byte)
&& MODIFF == find_start_modiff)
return find_start_value;
+ if (!NILP (Vcomment_use_syntax_ppss))
+ {
+ modiff_count modiffs = CHARS_MODIFF;
+ Lisp_Object ppss = call1 (Qsyntax_ppss, make_fixnum (pos));
+ if (modiffs != CHARS_MODIFF)
+ error ("syntax-ppss modified the buffer!");
+ TEMP_SET_PT_BOTH (opoint, opoint_byte);
+ Lisp_Object boc = Fnth (make_fixnum (8), ppss);
+ if (FIXNUMP (boc))
+ {
+ find_start_value = XFIXNUM (boc);
+ find_start_value_byte = CHAR_TO_BYTE (find_start_value);
+ }
+ else
+ {
+ find_start_value = pos;
+ find_start_value_byte = pos_byte;
+ }
+ goto found;
+ }
if (!open_paren_in_column_0_is_defun_start)
{
find_start_value = BEGV;
@@ -874,6 +882,7 @@ back_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop,
case Sopen:
/* Assume a defun-start point is outside of strings. */
if (open_paren_in_column_0_is_defun_start
+ && NILP (Vcomment_use_syntax_ppss)
&& (from == stop
|| (temp_byte = dec_bytepos (from_byte),
FETCH_CHAR (temp_byte) == '\n')))
@@ -931,7 +940,7 @@ back_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop,
{
adjusted = true;
find_start_value
- = CONSP (state.levelstarts) ? XINT (XCAR (state.levelstarts))
+ = CONSP (state.levelstarts) ? XFIXNUM (XCAR (state.levelstarts))
: state.thislevelstart >= 0 ? state.thislevelstart
: find_start_value;
find_start_value_byte = CHAR_TO_BYTE (find_start_value);
@@ -1097,9 +1106,9 @@ this is probably the wrong function to use, because it can't take
{
int char_int;
CHECK_CHARACTER (character);
- char_int = XINT (character);
+ char_int = XFIXNUM (character);
SETUP_BUFFER_SYNTAX_TABLE ();
- return make_number (syntax_code_spec[SYNTAX (char_int)]);
+ return make_fixnum (syntax_code_spec[SYNTAX (char_int)]);
}
DEFUN ("matching-paren", Fmatching_paren, Smatching_paren, 1, 1, 0,
@@ -1109,7 +1118,7 @@ DEFUN ("matching-paren", Fmatching_paren, Smatching_paren, 1, 1, 0,
int char_int;
enum syntaxcode code;
CHECK_CHARACTER (character);
- char_int = XINT (character);
+ char_int = XFIXNUM (character);
SETUP_BUFFER_SYNTAX_TABLE ();
code = SYNTAX (char_int);
if (code == Sopen || code == Sclose)
@@ -1144,7 +1153,7 @@ the value of a `syntax-table' text property. */)
int len;
int character = STRING_CHAR_AND_LENGTH (p, len);
XSETINT (match, character);
- if (XFASTINT (match) == ' ')
+ if (XFIXNAT (match) == ' ')
match = Qnil;
p += len;
}
@@ -1191,7 +1200,7 @@ the value of a `syntax-table' text property. */)
return AREF (Vsyntax_code_object, val);
else
/* Since we can't use a shared object, let's make a new one. */
- return Fcons (make_number (val), match);
+ return Fcons (make_fixnum (val), match);
}
/* I really don't know why this is interactive
@@ -1256,7 +1265,7 @@ usage: (modify-syntax-entry CHAR NEWENTRY &optional SYNTAX-TABLE) */)
if (CONSP (c))
SET_RAW_SYNTAX_ENTRY_RANGE (syntax_table, c, newentry);
else
- SET_RAW_SYNTAX_ENTRY (syntax_table, XINT (c), newentry);
+ SET_RAW_SYNTAX_ENTRY (syntax_table, XFIXNUM (c), newentry);
/* We clear the regexp cache, since character classes can now have
different values from those in the compiled regexps.*/
@@ -1298,13 +1307,13 @@ DEFUN ("internal-describe-syntax-value", Finternal_describe_syntax_value,
first = XCAR (value);
match_lisp = XCDR (value);
- if (!INTEGERP (first) || !(NILP (match_lisp) || CHARACTERP (match_lisp)))
+ if (!FIXNUMP (first) || !(NILP (match_lisp) || CHARACTERP (match_lisp)))
{
insert_string ("invalid");
return syntax;
}
- syntax_code = XINT (first) & INT_MAX;
+ syntax_code = XFIXNUM (first) & INT_MAX;
code = syntax_code & 0377;
start1 = SYNTAX_FLAGS_COMSTART_FIRST (syntax_code);
start2 = SYNTAX_FLAGS_COMSTART_SECOND (syntax_code);
@@ -1327,7 +1336,7 @@ DEFUN ("internal-describe-syntax-value", Finternal_describe_syntax_value,
if (NILP (match_lisp))
insert (" ", 1);
else
- insert_char (XINT (match_lisp));
+ insert_char (XFIXNUM (match_lisp));
if (start1)
insert ("1", 1);
@@ -1392,7 +1401,7 @@ DEFUN ("internal-describe-syntax-value", Finternal_describe_syntax_value,
if (!NILP (match_lisp))
{
insert_string (", matches ");
- insert_char (XINT (match_lisp));
+ insert_char (XFIXNUM (match_lisp));
}
if (start1)
@@ -1459,10 +1468,10 @@ scan_words (ptrdiff_t from, EMACS_INT count)
func = CHAR_TABLE_REF (Vfind_word_boundary_function_table, ch0);
if (! NILP (Ffboundp (func)))
{
- pos = call2 (func, make_number (from - 1), make_number (end));
- if (INTEGERP (pos) && from < XINT (pos) && XINT (pos) <= ZV)
+ pos = call2 (func, make_fixnum (from - 1), make_fixnum (end));
+ if (FIXNUMP (pos) && from < XFIXNUM (pos) && XFIXNUM (pos) <= ZV)
{
- from = XINT (pos);
+ from = XFIXNUM (pos);
from_byte = CHAR_TO_BYTE (from);
}
}
@@ -1508,10 +1517,10 @@ scan_words (ptrdiff_t from, EMACS_INT count)
func = CHAR_TABLE_REF (Vfind_word_boundary_function_table, ch1);
if (! NILP (Ffboundp (func)))
{
- pos = call2 (func, make_number (from), make_number (beg));
- if (INTEGERP (pos) && BEGV <= XINT (pos) && XINT (pos) < from)
+ pos = call2 (func, make_fixnum (from), make_fixnum (beg));
+ if (FIXNUMP (pos) && BEGV <= XFIXNUM (pos) && XFIXNUM (pos) < from)
{
- from = XINT (pos);
+ from = XFIXNUM (pos);
from_byte = CHAR_TO_BYTE (from);
}
}
@@ -1565,16 +1574,16 @@ instead. See Info node `(elisp) Word Motion' for details. */)
if (NILP (arg))
XSETFASTINT (arg, 1);
else
- CHECK_NUMBER (arg);
+ CHECK_FIXNUM (arg);
- val = orig_val = scan_words (PT, XINT (arg));
+ val = orig_val = scan_words (PT, XFIXNUM (arg));
if (! orig_val)
- val = XINT (arg) > 0 ? ZV : BEGV;
+ val = XFIXNUM (arg) > 0 ? ZV : BEGV;
/* Avoid jumping out of an input field. */
- tmp = Fconstrain_to_field (make_number (val), make_number (PT),
+ tmp = Fconstrain_to_field (make_fixnum (val), make_fixnum (PT),
Qnil, Qnil, Qnil);
- val = XFASTINT (tmp);
+ val = XFIXNAT (tmp);
SET_PT (val);
return val == orig_val ? Qt : Qnil;
@@ -1655,16 +1664,16 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
if (NILP (lim))
XSETINT (lim, forwardp ? ZV : BEGV);
else
- CHECK_NUMBER_COERCE_MARKER (lim);
+ CHECK_FIXNUM_COERCE_MARKER (lim);
/* In any case, don't allow scan outside bounds of buffer. */
- if (XINT (lim) > ZV)
+ if (XFIXNUM (lim) > ZV)
XSETFASTINT (lim, ZV);
- if (XINT (lim) < BEGV)
+ if (XFIXNUM (lim) < BEGV)
XSETFASTINT (lim, BEGV);
multibyte = (!NILP (BVAR (current_buffer, enable_multibyte_characters))
- && (XINT (lim) - PT != CHAR_TO_BYTE (XINT (lim)) - PT_BYTE));
+ && (XFIXNUM (lim) - PT != CHAR_TO_BYTE (XFIXNUM (lim)) - PT_BYTE));
string_multibyte = SBYTES (string) > SCHARS (string);
memset (fastmap, 0, sizeof fastmap);
@@ -1700,7 +1709,7 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
error ("Invalid ISO C character class");
if (cc != -1)
{
- iso_classes = Fcons (make_number (cc), iso_classes);
+ iso_classes = Fcons (make_fixnum (cc), iso_classes);
i_byte = ch - str;
continue;
}
@@ -1796,7 +1805,7 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
error ("Invalid ISO C character class");
if (cc != -1)
{
- iso_classes = Fcons (make_number (cc), iso_classes);
+ iso_classes = Fcons (make_fixnum (cc), iso_classes);
i_byte = ch - str;
continue;
}
@@ -1915,13 +1924,13 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
if (forwardp)
{
- endp = (XINT (lim) == GPT) ? GPT_ADDR : CHAR_POS_ADDR (XINT (lim));
- stop = (pos < GPT && GPT < XINT (lim)) ? GPT_ADDR : endp;
+ endp = (XFIXNUM (lim) == GPT) ? GPT_ADDR : CHAR_POS_ADDR (XFIXNUM (lim));
+ stop = (pos < GPT && GPT < XFIXNUM (lim)) ? GPT_ADDR : endp;
}
else
{
- endp = CHAR_POS_ADDR (XINT (lim));
- stop = (pos >= GPT && GPT > XINT (lim)) ? GAP_END_ADDR : endp;
+ endp = CHAR_POS_ADDR (XFIXNUM (lim));
+ stop = (pos >= GPT && GPT > XFIXNUM (lim)) ? GAP_END_ADDR : endp;
}
/* This code may look up syntax tables using functions that rely on the
@@ -2073,7 +2082,7 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
SET_PT_BOTH (pos, pos_byte);
SAFE_FREE ();
- return make_number (PT - start_point);
+ return make_fixnum (PT - start_point);
}
}
@@ -2094,19 +2103,19 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim)
if (NILP (lim))
XSETINT (lim, forwardp ? ZV : BEGV);
else
- CHECK_NUMBER_COERCE_MARKER (lim);
+ CHECK_FIXNUM_COERCE_MARKER (lim);
/* In any case, don't allow scan outside bounds of buffer. */
- if (XINT (lim) > ZV)
+ if (XFIXNUM (lim) > ZV)
XSETFASTINT (lim, ZV);
- if (XINT (lim) < BEGV)
+ if (XFIXNUM (lim) < BEGV)
XSETFASTINT (lim, BEGV);
- if (forwardp ? (PT >= XFASTINT (lim)) : (PT <= XFASTINT (lim)))
- return make_number (0);
+ if (forwardp ? (PT >= XFIXNAT (lim)) : (PT <= XFIXNAT (lim)))
+ return make_fixnum (0);
multibyte = (!NILP (BVAR (current_buffer, enable_multibyte_characters))
- && (XINT (lim) - PT != CHAR_TO_BYTE (XINT (lim)) - PT_BYTE));
+ && (XFIXNUM (lim) - PT != CHAR_TO_BYTE (XFIXNUM (lim)) - PT_BYTE));
memset (fastmap, 0, sizeof fastmap);
@@ -2151,8 +2160,8 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim)
while (true)
{
p = BYTE_POS_ADDR (pos_byte);
- endp = XINT (lim) == GPT ? GPT_ADDR : CHAR_POS_ADDR (XINT (lim));
- stop = pos < GPT && GPT < XINT (lim) ? GPT_ADDR : endp;
+ endp = XFIXNUM (lim) == GPT ? GPT_ADDR : CHAR_POS_ADDR (XFIXNUM (lim));
+ stop = pos < GPT && GPT < XFIXNUM (lim) ? GPT_ADDR : endp;
do
{
@@ -2184,8 +2193,8 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim)
else
{
p = BYTE_POS_ADDR (pos_byte);
- endp = CHAR_POS_ADDR (XINT (lim));
- stop = pos >= GPT && GPT > XINT (lim) ? GAP_END_ADDR : endp;
+ endp = CHAR_POS_ADDR (XFIXNUM (lim));
+ stop = pos >= GPT && GPT > XFIXNUM (lim) ? GAP_END_ADDR : endp;
if (multibyte)
{
@@ -2235,7 +2244,7 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim)
done:
SET_PT_BOTH (pos, pos_byte);
- return make_number (PT - start_point);
+ return make_fixnum (PT - start_point);
}
}
@@ -2254,7 +2263,7 @@ in_classes (int c, Lisp_Object iso_classes)
elt = XCAR (iso_classes);
iso_classes = XCDR (iso_classes);
- if (re_iswctype (c, XFASTINT (elt)))
+ if (re_iswctype (c, XFIXNAT (elt)))
fits_class = 1;
}
@@ -2421,8 +2430,8 @@ between them, return t; otherwise return nil. */)
int dummy2;
unsigned short int quit_count = 0;
- CHECK_NUMBER (count);
- count1 = XINT (count);
+ CHECK_FIXNUM (count);
+ count1 = XFIXNUM (count);
stop = count1 > 0 ? ZV : BEGV;
from = PT;
@@ -2772,7 +2781,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
if (depth < min_depth)
xsignal3 (Qscan_error,
build_string ("Containing expression ends prematurely"),
- make_number (last_good), make_number (from));
+ make_fixnum (last_good), make_fixnum (from));
break;
case Sstring:
@@ -2928,7 +2937,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
if (depth < min_depth)
xsignal3 (Qscan_error,
build_string ("Containing expression ends prematurely"),
- make_number (last_good), make_number (from));
+ make_fixnum (last_good), make_fixnum (from));
break;
case Sendcomment:
@@ -3008,7 +3017,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag)
lose:
xsignal3 (Qscan_error,
build_string ("Unbalanced parentheses"),
- make_number (last_good), make_number (from));
+ make_fixnum (last_good), make_fixnum (from));
}
DEFUN ("scan-lists", Fscan_lists, Sscan_lists, 3, 3, 0,
@@ -3032,11 +3041,11 @@ before we have scanned over COUNT lists, return nil if the depth at
that point is zero, and signal an error if the depth is nonzero. */)
(Lisp_Object from, Lisp_Object count, Lisp_Object depth)
{
- CHECK_NUMBER (from);
- CHECK_NUMBER (count);
- CHECK_NUMBER (depth);
+ CHECK_FIXNUM (from);
+ CHECK_FIXNUM (count);
+ CHECK_FIXNUM (depth);
- return scan_lists (XINT (from), XINT (count), XINT (depth), 0);
+ return scan_lists (XFIXNUM (from), XFIXNUM (count), XFIXNUM (depth), 0);
}
DEFUN ("scan-sexps", Fscan_sexps, Sscan_sexps, 2, 2, 0,
@@ -3052,10 +3061,10 @@ If the beginning or end is reached between groupings
but before count is used up, nil is returned. */)
(Lisp_Object from, Lisp_Object count)
{
- CHECK_NUMBER (from);
- CHECK_NUMBER (count);
+ CHECK_FIXNUM (from);
+ CHECK_FIXNUM (count);
- return scan_lists (XINT (from), XINT (count), 0, 1);
+ return scan_lists (XFIXNUM (from), XFIXNUM (count), 0, 1);
}
DEFUN ("backward-prefix-chars", Fbackward_prefix_chars, Sbackward_prefix_chars,
@@ -3195,8 +3204,8 @@ do { prev_from = from; \
while (!NILP (tem)) /* >= second enclosing sexps. */
{
Lisp_Object temhd = Fcar (tem);
- if (RANGED_INTEGERP (PTRDIFF_MIN, temhd, PTRDIFF_MAX))
- curlevel->last = XINT (temhd);
+ if (RANGED_FIXNUMP (PTRDIFF_MIN, temhd, PTRDIFF_MAX))
+ curlevel->last = XFIXNUM (temhd);
if (++curlevel == endlevel)
curlevel--; /* error ("Nesting too deep for parser"); */
curlevel->prev = -1;
@@ -3441,7 +3450,7 @@ do { prev_from = from; \
state->location_byte = from_byte;
state->levelstarts = Qnil;
while (curlevel > levelstart)
- state->levelstarts = Fcons (make_number ((--curlevel)->last),
+ state->levelstarts = Fcons (make_fixnum ((--curlevel)->last),
state->levelstarts);
state->prev_syntax = (SYNTAX_FLAGS_COMSTARTEND_FIRST (prev_from_syntax)
|| state->quoted) ? prev_from_syntax : Smax;
@@ -3468,10 +3477,7 @@ internalize_parse_state (Lisp_Object external, struct lisp_parse_state *state)
else
{
tem = Fcar (external);
- if (!NILP (tem))
- state->depth = XINT (tem);
- else
- state->depth = 0;
+ state->depth = FIXNUMP (tem) ? XFIXNUM (tem) : 0;
external = Fcdr (external);
external = Fcdr (external);
@@ -3479,13 +3485,13 @@ internalize_parse_state (Lisp_Object external, struct lisp_parse_state *state)
tem = Fcar (external);
/* Check whether we are inside string_fence-style string: */
state->instring = (!NILP (tem)
- ? (CHARACTERP (tem) ? XFASTINT (tem) : ST_STRING_STYLE)
+ ? (CHARACTERP (tem) ? XFIXNAT (tem) : ST_STRING_STYLE)
: -1);
external = Fcdr (external);
tem = Fcar (external);
state->incomment = (!NILP (tem)
- ? (INTEGERP (tem) ? XINT (tem) : -1)
+ ? (FIXNUMP (tem) ? XFIXNUM (tem) : -1)
: 0);
external = Fcdr (external);
@@ -3499,21 +3505,21 @@ internalize_parse_state (Lisp_Object external, struct lisp_parse_state *state)
tem = Fcar (external);
state->comstyle = (NILP (tem)
? 0
- : (RANGED_INTEGERP (0, tem, ST_COMMENT_STYLE)
- ? XINT (tem)
+ : (RANGED_FIXNUMP (0, tem, ST_COMMENT_STYLE)
+ ? XFIXNUM (tem)
: ST_COMMENT_STYLE));
external = Fcdr (external);
tem = Fcar (external);
state->comstr_start =
- RANGED_INTEGERP (PTRDIFF_MIN, tem, PTRDIFF_MAX) ? XINT (tem) : -1;
+ RANGED_FIXNUMP (PTRDIFF_MIN, tem, PTRDIFF_MAX) ? XFIXNUM (tem) : -1;
external = Fcdr (external);
tem = Fcar (external);
state->levelstarts = tem;
external = Fcdr (external);
tem = Fcar (external);
- state->prev_syntax = NILP (tem) ? Smax : XINT (tem);
+ state->prev_syntax = NILP (tem) ? Smax : XFIXNUM (tem);
}
}
@@ -3562,16 +3568,16 @@ Sixth arg COMMENTSTOP non-nil means stop after the start of a comment.
if (!NILP (targetdepth))
{
- CHECK_NUMBER (targetdepth);
- target = XINT (targetdepth);
+ CHECK_FIXNUM (targetdepth);
+ target = XFIXNUM (targetdepth);
}
else
target = TYPE_MINIMUM (EMACS_INT); /* We won't reach this depth. */
validate_region (&from, &to);
internalize_parse_state (oldstate, &state);
- scan_sexps_forward (&state, XINT (from), CHAR_TO_BYTE (XINT (from)),
- XINT (to),
+ scan_sexps_forward (&state, XFIXNUM (from), CHAR_TO_BYTE (XFIXNUM (from)),
+ XFIXNUM (to),
target, !NILP (stopbefore),
(NILP (commentstop)
? 0 : (EQ (commentstop, Qsyntax_table) ? -1 : 1)));
@@ -3579,32 +3585,32 @@ Sixth arg COMMENTSTOP non-nil means stop after the start of a comment.
SET_PT_BOTH (state.location, state.location_byte);
return
- Fcons (make_number (state.depth),
+ Fcons (make_fixnum (state.depth),
Fcons (state.prevlevelstart < 0
- ? Qnil : make_number (state.prevlevelstart),
+ ? Qnil : make_fixnum (state.prevlevelstart),
Fcons (state.thislevelstart < 0
- ? Qnil : make_number (state.thislevelstart),
+ ? Qnil : make_fixnum (state.thislevelstart),
Fcons (state.instring >= 0
? (state.instring == ST_STRING_STYLE
- ? Qt : make_number (state.instring)) : Qnil,
+ ? Qt : make_fixnum (state.instring)) : Qnil,
Fcons (state.incomment < 0 ? Qt :
(state.incomment == 0 ? Qnil :
- make_number (state.incomment)),
+ make_fixnum (state.incomment)),
Fcons (state.quoted ? Qt : Qnil,
- Fcons (make_number (state.mindepth),
+ Fcons (make_fixnum (state.mindepth),
Fcons ((state.comstyle
? (state.comstyle == ST_COMMENT_STYLE
? Qsyntax_table
- : make_number (state.comstyle))
+ : make_fixnum (state.comstyle))
: Qnil),
Fcons (((state.incomment
|| (state.instring >= 0))
- ? make_number (state.comstr_start)
+ ? make_fixnum (state.comstr_start)
: Qnil),
Fcons (state.levelstarts,
Fcons (state.prev_syntax == Smax
? Qnil
- : make_number (state.prev_syntax),
+ : make_fixnum (state.prev_syntax),
Qnil)))))))))));
}
@@ -3620,11 +3626,11 @@ init_syntax_once (void)
/* Create objects which can be shared among syntax tables. */
Vsyntax_code_object = make_uninit_vector (Smax);
for (i = 0; i < Smax; i++)
- ASET (Vsyntax_code_object, i, Fcons (make_number (i), Qnil));
+ ASET (Vsyntax_code_object, i, Fcons (make_fixnum (i), Qnil));
/* Now we are ready to set up this property, so we can
create syntax tables. */
- Fput (Qsyntax_table, Qchar_table_extra_slots, make_number (0));
+ Fput (Qsyntax_table, Qchar_table_extra_slots, make_fixnum (0));
temp = AREF (Vsyntax_code_object, Swhitespace);
@@ -3656,21 +3662,21 @@ init_syntax_once (void)
SET_RAW_SYNTAX_ENTRY (Vstandard_syntax_table, '%', temp);
SET_RAW_SYNTAX_ENTRY (Vstandard_syntax_table, '(',
- Fcons (make_number (Sopen), make_number (')')));
+ Fcons (make_fixnum (Sopen), make_fixnum (')')));
SET_RAW_SYNTAX_ENTRY (Vstandard_syntax_table, ')',
- Fcons (make_number (Sclose), make_number ('(')));
+ Fcons (make_fixnum (Sclose), make_fixnum ('(')));
SET_RAW_SYNTAX_ENTRY (Vstandard_syntax_table, '[',
- Fcons (make_number (Sopen), make_number (']')));
+ Fcons (make_fixnum (Sopen), make_fixnum (']')));
SET_RAW_SYNTAX_ENTRY (Vstandard_syntax_table, ']',
- Fcons (make_number (Sclose), make_number ('[')));
+ Fcons (make_fixnum (Sclose), make_fixnum ('[')));
SET_RAW_SYNTAX_ENTRY (Vstandard_syntax_table, '{',
- Fcons (make_number (Sopen), make_number ('}')));
+ Fcons (make_fixnum (Sopen), make_fixnum ('}')));
SET_RAW_SYNTAX_ENTRY (Vstandard_syntax_table, '}',
- Fcons (make_number (Sclose), make_number ('{')));
+ Fcons (make_fixnum (Sclose), make_fixnum ('{')));
SET_RAW_SYNTAX_ENTRY (Vstandard_syntax_table, '"',
- Fcons (make_number (Sstring), Qnil));
+ Fcons (make_fixnum (Sstring), Qnil));
SET_RAW_SYNTAX_ENTRY (Vstandard_syntax_table, '\\',
- Fcons (make_number (Sescape), Qnil));
+ Fcons (make_fixnum (Sescape), Qnil));
temp = AREF (Vsyntax_code_object, Ssymbol);
for (i = 0; i < 10; i++)
@@ -3695,6 +3701,11 @@ void
syms_of_syntax (void)
{
DEFSYM (Qsyntax_table_p, "syntax-table-p");
+ DEFSYM (Qsyntax_ppss, "syntax-ppss");
+ DEFVAR_LISP ("comment-use-syntax-ppss",
+ Vcomment_use_syntax_ppss,
+ doc: /* Non-nil means `forward-comment' can use `syntax-ppss' internally. */);
+ Vcomment_use_syntax_ppss = Qt;
staticpro (&Vsyntax_code_object);
@@ -3703,12 +3714,9 @@ syms_of_syntax (void)
staticpro (&gl_state.current_syntax_table);
staticpro (&gl_state.old_prop);
- /* Defined in regex.c. */
- staticpro (&re_match_object);
-
DEFSYM (Qscan_error, "scan-error");
Fput (Qscan_error, Qerror_conditions,
- listn (CONSTYPE_PURE, 2, Qscan_error, Qerror));
+ pure_list (Qscan_error, Qerror));
Fput (Qscan_error, Qerror_message,
build_pure_c_string ("Scan error"));
diff --git a/src/syntax.h b/src/syntax.h
index 0251fded4c6..6d3851ff72f 100644
--- a/src/syntax.h
+++ b/src/syntax.h
@@ -118,7 +118,7 @@ INLINE int
syntax_property_with_flags (int c, bool via_property)
{
Lisp_Object ent = syntax_property_entry (c, via_property);
- return CONSP (ent) ? XINT (XCAR (ent)) : Swhitespace;
+ return CONSP (ent) ? XFIXNUM (XCAR (ent)) : Swhitespace;
}
INLINE int
SYNTAX_WITH_FLAGS (int c)
@@ -186,13 +186,6 @@ UPDATE_SYNTAX_TABLE_FORWARD (ptrdiff_t charpos)
false, gl_state.object);
}
-INLINE void
-UPDATE_SYNTAX_TABLE_FORWARD_FAST (ptrdiff_t charpos)
-{
- if (parse_sexp_lookup_properties && charpos >= gl_state.e_property)
- update_syntax_table (charpos + gl_state.offset, 1, false, gl_state.object);
-}
-
/* Make syntax table state (gl_state) good for CHARPOS, assuming it is
currently good for a position after CHARPOS. */
@@ -212,13 +205,6 @@ UPDATE_SYNTAX_TABLE (ptrdiff_t charpos)
UPDATE_SYNTAX_TABLE_FORWARD (charpos);
}
-INLINE void
-UPDATE_SYNTAX_TABLE_FAST (ptrdiff_t charpos)
-{
- UPDATE_SYNTAX_TABLE_BACKWARD (charpos);
- UPDATE_SYNTAX_TABLE_FORWARD_FAST (charpos);
-}
-
/* Set up the buffer-global syntax table. */
INLINE void
diff --git a/src/sysdep.c b/src/sysdep.c
index 1e35e06b633..57ea8220cac 100644
--- a/src/sysdep.c
+++ b/src/sysdep.c
@@ -91,13 +91,19 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <sys/file.h>
#include <fcntl.h>
+#include "syssignal.h"
+#include "systime.h"
#include "systty.h"
#include "syswait.h"
+#ifdef HAVE_SYS_RESOURCE_H
+# include <sys/resource.h>
+#endif
+
#ifdef HAVE_SYS_UTSNAME_H
-#include <sys/utsname.h>
-#include <memory.h>
-#endif /* HAVE_SYS_UTSNAME_H */
+# include <sys/utsname.h>
+# include <memory.h>
+#endif
#include "keyboard.h"
#include "frame.h"
@@ -118,18 +124,15 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#endif
#ifdef WINDOWSNT
-#include <direct.h>
+# include <direct.h>
/* In process.h which conflicts with the local copy. */
-#define _P_WAIT 0
+# define _P_WAIT 0
int _cdecl _spawnlp (int, const char *, const char *, ...);
/* The following is needed for O_CLOEXEC, F_SETFD, FD_CLOEXEC, and
several prototypes of functions called below. */
-#include <sys/socket.h>
+# include <sys/socket.h>
#endif
-#include "syssignal.h"
-#include "systime.h"
-
/* ULLONG_MAX is missing on Red Hat Linux 7.3; see Bug#11781. */
#ifndef ULLONG_MAX
#define ULLONG_MAX TYPE_MAXIMUM (unsigned long long int)
@@ -147,22 +150,52 @@ static const int baud_convert[] =
#ifdef HAVE_PERSONALITY_ADDR_NO_RANDOMIZE
# include <sys/personality.h>
-/* Disable address randomization in the current process. Return true
- if addresses were randomized but this has been disabled, false
- otherwise. */
-bool
-disable_address_randomization (void)
+/* If not -1, the personality that should be restored before exec. */
+static int exec_personality;
+
+/* Try to disable randomization if the current process needs it and
+ does not appear to have it already. */
+int
+maybe_disable_address_randomization (bool dumping, int argc, char **argv)
{
- int pers = personality (0xffffffff);
- if (pers < 0)
- return false;
- int desired_pers = pers | ADDR_NO_RANDOMIZE;
+ /* Undocumented Emacs option used only by this function. */
+ static char const aslr_disabled_option[] = "--__aslr-disabled";
- /* Call 'personality' twice, to detect buggy platforms like WSL
- where 'personality' always returns 0. */
- return (pers != desired_pers
- && personality (desired_pers) == pers
- && personality (0xffffffff) == desired_pers);
+ if (argc < 2 || strcmp (argv[1], aslr_disabled_option) != 0)
+ {
+ bool disable_aslr = dumping;
+# ifdef __PPC64__
+ disable_aslr = true;
+# endif
+ exec_personality = disable_aslr ? personality (0xffffffff) : -1;
+ if (exec_personality & ADDR_NO_RANDOMIZE)
+ exec_personality = -1;
+ if (exec_personality != -1
+ && personality (exec_personality | ADDR_NO_RANDOMIZE) != -1)
+ {
+ char **newargv = malloc ((argc + 2) * sizeof *newargv);
+ if (newargv)
+ {
+ /* Invoke self with undocumented option. */
+ newargv[0] = argv[0];
+ newargv[1] = (char *) aslr_disabled_option;
+ memcpy (&newargv[2], &argv[1], argc * sizeof *newargv);
+ execvp (newargv[0], newargv);
+ }
+
+ /* If malloc or execvp fails, warn and then try anyway. */
+ perror (argv[0]);
+ free (newargv);
+ }
+ }
+ else
+ {
+ /* Our earlier incarnation already disabled ASLR. */
+ argc--;
+ memmove (&argv[1], &argv[2], argc * sizeof *argv);
+ }
+
+ return argc;
}
#endif
@@ -174,21 +207,12 @@ int
emacs_exec_file (char const *file, char *const *argv, char *const *envp)
{
#ifdef HAVE_PERSONALITY_ADDR_NO_RANDOMIZE
- int pers = getenv ("EMACS_HEAP_EXEC") ? personality (0xffffffff) : -1;
- bool change_personality = 0 <= pers && pers & ADDR_NO_RANDOMIZE;
- if (change_personality)
- personality (pers & ~ADDR_NO_RANDOMIZE);
+ if (exec_personality != -1)
+ personality (exec_personality);
#endif
execve (file, argv, envp);
- int err = errno;
-
-#ifdef HAVE_PERSONALITY_ADDR_NO_RANDOMIZE
- if (change_personality)
- personality (pers);
-#endif
-
- return err;
+ return errno;
}
/* If FD is not already open, arrange for it to be open with FLAGS. */
@@ -233,12 +257,12 @@ get_current_dir_name_or_unreachable (void)
char *pwd;
- /* The maximum size of a directory name, including the terminating null.
+ /* The maximum size of a directory name, including the terminating NUL.
Leave room so that the caller can append a trailing slash. */
ptrdiff_t dirsize_max = min (PTRDIFF_MAX, SIZE_MAX) - 1;
/* The maximum size of a buffer for a file name, including the
- terminating null. This is bounded by MAXPATHLEN, if available. */
+ terminating NUL. This is bounded by MAXPATHLEN, if available. */
ptrdiff_t bufsize_max = dirsize_max;
#ifdef MAXPATHLEN
bufsize_max = min (bufsize_max, MAXPATHLEN);
@@ -246,7 +270,7 @@ get_current_dir_name_or_unreachable (void)
# if HAVE_GET_CURRENT_DIR_NAME && !BROKEN_GET_CURRENT_DIR_NAME
# ifdef HYBRID_MALLOC
- bool use_libc = bss_sbrk_did_unexec;
+ bool use_libc = will_dump_with_unexec_p ();
# else
bool use_libc = true;
# endif
@@ -1496,18 +1520,18 @@ reset_sys_modes (struct tty_display_info *tty_out)
tty_out->terminal->reset_terminal_modes_hook (tty_out->terminal);
/* Avoid possible loss of output when changing terminal modes. */
- while (fdatasync (fileno (tty_out->output)) != 0 && errno == EINTR)
+ while (tcdrain (fileno (tty_out->output)) != 0 && errno == EINTR)
continue;
#ifndef DOS_NT
-#ifdef F_SETOWN
+# ifdef F_SETOWN
if (interrupt_input)
{
reset_sigio (fileno (tty_out->input));
fcntl (fileno (tty_out->input), F_SETOWN,
old_fcntl_owner[fileno (tty_out->input)]);
}
-#endif /* F_SETOWN */
+# endif /* F_SETOWN */
fcntl (fileno (tty_out->input), F_SETFL,
fcntl (fileno (tty_out->input), F_GETFL, 0) & ~O_NONBLOCK);
#endif
@@ -1671,7 +1695,7 @@ emacs_sigaction_init (struct sigaction *action, signal_handler_t handler)
}
#ifdef FORWARD_SIGNAL_TO_MAIN_THREAD
-pthread_t main_thread_id;
+static pthread_t main_thread_id;
#endif
/* SIG has arrived at the current process. Deliver it to the main
@@ -1826,8 +1850,8 @@ stack_overflow (siginfo_t *siginfo)
/* The known top and bottom of the stack. The actual stack may
extend a bit beyond these boundaries. */
- char *bot = stack_bottom;
- char *top = current_thread->stack_top;
+ char const *bot = stack_bottom;
+ char const *top = current_thread->stack_top;
/* Log base 2 of the stack heuristic ratio. This ratio is the size
of the known stack divided by the size of the guard area past the
@@ -1884,7 +1908,10 @@ init_sigsegv (void)
sigfillset (&sa.sa_mask);
sa.sa_sigaction = handle_sigsegv;
sa.sa_flags = SA_SIGINFO | SA_ONSTACK | emacs_sigaction_flags ();
- return sigaction (SIGSEGV, &sa, NULL) < 0 ? 0 : 1;
+ if (sigaction (SIGSEGV, &sa, NULL) < 0)
+ return 0;
+
+ return 1;
}
#else /* not HAVE_STACK_OVERFLOW_HANDLING or WINDOWSNT */
@@ -1939,7 +1966,7 @@ maybe_fatal_sig (int sig)
}
void
-init_signals (bool dumping)
+init_signals (void)
{
struct sigaction thread_fatal_action;
struct sigaction action;
@@ -2090,7 +2117,7 @@ init_signals (bool dumping)
/* Don't alter signal handlers if dumping. On some machines,
changing signal handlers sets static data that would make signals
fail to work right when the dumped Emacs is run. */
- if (dumping)
+ if (will_dump_p ())
return;
sigfillset (&process_fatal_action.sa_mask);
@@ -2554,6 +2581,22 @@ emacs_close (int fd)
#define MAX_RW_COUNT (INT_MAX >> 18 << 18)
#endif
+/* Verify that MAX_RW_COUNT fits in the relevant standard types. */
+#ifndef SSIZE_MAX
+# define SSIZE_MAX TYPE_MAXIMUM (ssize_t)
+#endif
+verify (MAX_RW_COUNT <= PTRDIFF_MAX);
+verify (MAX_RW_COUNT <= SIZE_MAX);
+verify (MAX_RW_COUNT <= SSIZE_MAX);
+
+#ifdef WINDOWSNT
+/* Verify that Emacs read requests cannot cause trouble, even in
+ 64-bit builds. The last argument of 'read' is 'unsigned int', and
+ the return value's type (see 'sys_read') is 'int'. */
+verify (MAX_RW_COUNT <= INT_MAX);
+verify (MAX_RW_COUNT <= UINT_MAX);
+#endif
+
/* Read from FD to a buffer BUF with size NBYTE.
If interrupted, process any quits and pending signals immediately
if INTERRUPTIBLE, and then retry the read unless quitting.
@@ -2562,10 +2605,11 @@ emacs_close (int fd)
static ptrdiff_t
emacs_intr_read (int fd, void *buf, ptrdiff_t nbyte, bool interruptible)
{
+ /* No caller should ever pass a too-large size to emacs_read. */
+ eassert (nbyte <= MAX_RW_COUNT);
+
ssize_t result;
- /* There is no need to check against MAX_RW_COUNT, since no caller ever
- passes a size that large to emacs_read. */
do
{
if (interruptible)
@@ -2687,30 +2731,6 @@ emacs_perror (char const *message)
errno = err;
}
-/* Return a struct timeval that is roughly equivalent to T.
- Use the least timeval not less than T.
- Return an extremal value if the result would overflow. */
-struct timeval
-make_timeval (struct timespec t)
-{
- struct timeval tv;
- tv.tv_sec = t.tv_sec;
- tv.tv_usec = t.tv_nsec / 1000;
-
- if (t.tv_nsec % 1000 != 0)
- {
- if (tv.tv_usec < 999999)
- tv.tv_usec++;
- else if (tv.tv_sec < TYPE_MAXIMUM (time_t))
- {
- tv.tv_sec++;
- tv.tv_usec = 0;
- }
- }
-
- return tv;
-}
-
/* Set the access and modification time stamps of FD (a.k.a. FILE) to be
ATIME and MTIME, respectively.
FD must be either negative -- in which case it is ignored --
@@ -2833,8 +2853,8 @@ serial_configure (struct Lisp_Process *p,
tem = Fplist_get (contact, QCspeed);
else
tem = Fplist_get (p->childp, QCspeed);
- CHECK_NUMBER (tem);
- err = cfsetspeed (&attr, XINT (tem));
+ CHECK_FIXNUM (tem);
+ err = cfsetspeed (&attr, XFIXNUM (tem));
if (err != 0)
report_file_error ("Failed cfsetspeed", tem);
childp2 = Fplist_put (childp2, QCspeed, tem);
@@ -2845,17 +2865,17 @@ serial_configure (struct Lisp_Process *p,
else
tem = Fplist_get (p->childp, QCbytesize);
if (NILP (tem))
- tem = make_number (8);
- CHECK_NUMBER (tem);
- if (XINT (tem) != 7 && XINT (tem) != 8)
+ tem = make_fixnum (8);
+ CHECK_FIXNUM (tem);
+ if (XFIXNUM (tem) != 7 && XFIXNUM (tem) != 8)
error (":bytesize must be nil (8), 7, or 8");
- summary[0] = XINT (tem) + '0';
+ summary[0] = XFIXNUM (tem) + '0';
#if defined (CSIZE) && defined (CS7) && defined (CS8)
attr.c_cflag &= ~CSIZE;
- attr.c_cflag |= ((XINT (tem) == 7) ? CS7 : CS8);
+ attr.c_cflag |= ((XFIXNUM (tem) == 7) ? CS7 : CS8);
#else
/* Don't error on bytesize 8, which should be set by cfmakeraw. */
- if (XINT (tem) != 8)
+ if (XFIXNUM (tem) != 8)
error ("Bytesize cannot be changed");
#endif
childp2 = Fplist_put (childp2, QCbytesize, tem);
@@ -2899,18 +2919,18 @@ serial_configure (struct Lisp_Process *p,
else
tem = Fplist_get (p->childp, QCstopbits);
if (NILP (tem))
- tem = make_number (1);
- CHECK_NUMBER (tem);
- if (XINT (tem) != 1 && XINT (tem) != 2)
+ tem = make_fixnum (1);
+ CHECK_FIXNUM (tem);
+ if (XFIXNUM (tem) != 1 && XFIXNUM (tem) != 2)
error (":stopbits must be nil (1 stopbit), 1, or 2");
- summary[2] = XINT (tem) + '0';
+ summary[2] = XFIXNUM (tem) + '0';
#if defined (CSTOPB)
attr.c_cflag &= ~CSTOPB;
- if (XINT (tem) == 2)
+ if (XFIXNUM (tem) == 2)
attr.c_cflag |= CSTOPB;
#else
/* Don't error on 1 stopbit, which should be set by cfmakeraw. */
- if (XINT (tem) != 1)
+ if (XFIXNUM (tem) != 1)
error ("Stopbits cannot be configured");
#endif
childp2 = Fplist_put (childp2, QCstopbits, tem);
@@ -3028,9 +3048,9 @@ list_system_processes (void)
for (i = 0; i < len; i++)
{
#ifdef DARWIN_OS
- proclist = Fcons (make_fixnum_or_float (procs[i].kp_proc.p_pid), proclist);
+ proclist = Fcons (INT_TO_INTEGER (procs[i].kp_proc.p_pid), proclist);
#else
- proclist = Fcons (make_fixnum_or_float (procs[i].ki_pid), proclist);
+ proclist = Fcons (INT_TO_INTEGER (procs[i].ki_pid), proclist);
#endif
}
@@ -3051,6 +3071,22 @@ list_system_processes (void)
#endif /* !defined (WINDOWSNT) */
+
+#if defined __FreeBSD__ || defined DARWIN_OS
+
+static struct timespec
+timeval_to_timespec (struct timeval t)
+{
+ return make_timespec (t.tv_sec, t.tv_usec * 1000);
+}
+static Lisp_Object
+make_lisp_timeval (struct timeval t)
+{
+ return make_lisp_time (timeval_to_timespec (t));
+}
+
+#endif
+
#if defined GNU_LINUX && defined HAVE_LONG_LONG_INT
static struct timespec
time_from_jiffies (unsigned long long tval, long hz)
@@ -3061,16 +3097,15 @@ time_from_jiffies (unsigned long long tval, long hz)
if (TYPE_MAXIMUM (time_t) < s)
time_overflow ();
- if (LONG_MAX - 1 <= ULLONG_MAX / TIMESPEC_RESOLUTION
- || frac <= ULLONG_MAX / TIMESPEC_RESOLUTION)
- ns = frac * TIMESPEC_RESOLUTION / hz;
+ if (LONG_MAX - 1 <= ULLONG_MAX / TIMESPEC_HZ
+ || frac <= ULLONG_MAX / TIMESPEC_HZ)
+ ns = frac * TIMESPEC_HZ / hz;
else
{
/* This is reachable only in the unlikely case that HZ * HZ
exceeds ULLONG_MAX. It calculates an approximation that is
guaranteed to be in range. */
- long hz_per_ns = (hz / TIMESPEC_RESOLUTION
- + (hz % TIMESPEC_RESOLUTION != 0));
+ long hz_per_ns = hz / TIMESPEC_HZ + (hz % TIMESPEC_HZ != 0);
ns = frac / hz_per_ns;
}
@@ -3095,27 +3130,26 @@ get_up_time (void)
if (fup)
{
- unsigned long long upsec, upfrac, idlesec, idlefrac;
- int upfrac_start, upfrac_end, idlefrac_start, idlefrac_end;
+ unsigned long long upsec, upfrac;
+ int upfrac_start, upfrac_end;
- if (fscanf (fup, "%llu.%n%llu%n %llu.%n%llu%n",
- &upsec, &upfrac_start, &upfrac, &upfrac_end,
- &idlesec, &idlefrac_start, &idlefrac, &idlefrac_end)
- == 4)
+ if (fscanf (fup, "%llu.%n%llu%n",
+ &upsec, &upfrac_start, &upfrac, &upfrac_end)
+ == 2)
{
if (TYPE_MAXIMUM (time_t) < upsec)
{
upsec = TYPE_MAXIMUM (time_t);
- upfrac = TIMESPEC_RESOLUTION - 1;
+ upfrac = TIMESPEC_HZ - 1;
}
else
{
int upfraclen = upfrac_end - upfrac_start;
- for (; upfraclen < LOG10_TIMESPEC_RESOLUTION; upfraclen++)
+ for (; upfraclen < LOG10_TIMESPEC_HZ; upfraclen++)
upfrac *= 10;
- for (; LOG10_TIMESPEC_RESOLUTION < upfraclen; upfraclen--)
+ for (; LOG10_TIMESPEC_HZ < upfraclen; upfraclen--)
upfrac /= 10;
- upfrac = min (upfrac, TIMESPEC_RESOLUTION - 1);
+ upfrac = min (upfrac, TIMESPEC_HZ - 1);
}
up = make_timespec (upsec, upfrac);
}
@@ -3222,7 +3256,7 @@ system_process_attributes (Lisp_Object pid)
struct group *gr;
long clocks_per_sec;
char *procfn_end;
- char procbuf[1025], *p, *q;
+ char procbuf[1025], *p, *q UNINIT;
int fd;
ssize_t nread;
static char const default_cmd[] = "???";
@@ -3244,7 +3278,7 @@ system_process_attributes (Lisp_Object pid)
Lisp_Object decoded_cmd;
ptrdiff_t count;
- CHECK_NUMBER_OR_FLOAT (pid);
+ CHECK_NUMBER (pid);
CONS_TO_INTEGER (pid, pid_t, proc_id);
sprintf (procfn, "/proc/%"pMd, proc_id);
if (stat (procfn, &st) < 0)
@@ -3252,7 +3286,7 @@ system_process_attributes (Lisp_Object pid)
/* euid egid */
uid = st.st_uid;
- attrs = Fcons (Fcons (Qeuid, make_fixnum_or_float (uid)), attrs);
+ attrs = Fcons (Fcons (Qeuid, INT_TO_INTEGER (uid)), attrs);
block_input ();
pw = getpwuid (uid);
unblock_input ();
@@ -3260,7 +3294,7 @@ system_process_attributes (Lisp_Object pid)
attrs = Fcons (Fcons (Quser, build_string (pw->pw_name)), attrs);
gid = st.st_gid;
- attrs = Fcons (Fcons (Qegid, make_fixnum_or_float (gid)), attrs);
+ attrs = Fcons (Fcons (Qegid, INT_TO_INTEGER (gid)), attrs);
block_input ();
gr = getgrgid (gid);
unblock_input ();
@@ -3318,17 +3352,15 @@ system_process_attributes (Lisp_Object pid)
state_str[0] = c;
state_str[1] = '\0';
attrs = Fcons (Fcons (Qstate, build_string (state_str)), attrs);
- attrs = Fcons (Fcons (Qppid, make_fixnum_or_float (ppid)), attrs);
- attrs = Fcons (Fcons (Qpgrp, make_fixnum_or_float (pgrp)), attrs);
- attrs = Fcons (Fcons (Qsess, make_fixnum_or_float (sess)), attrs);
+ attrs = Fcons (Fcons (Qppid, INT_TO_INTEGER (ppid)), attrs);
+ attrs = Fcons (Fcons (Qpgrp, INT_TO_INTEGER (pgrp)), attrs);
+ attrs = Fcons (Fcons (Qsess, INT_TO_INTEGER (sess)), attrs);
attrs = Fcons (Fcons (Qttname, procfs_ttyname (tty)), attrs);
- attrs = Fcons (Fcons (Qtpgid, make_fixnum_or_float (tpgid)), attrs);
- attrs = Fcons (Fcons (Qminflt, make_fixnum_or_float (minflt)), attrs);
- attrs = Fcons (Fcons (Qmajflt, make_fixnum_or_float (majflt)), attrs);
- attrs = Fcons (Fcons (Qcminflt, make_fixnum_or_float (cminflt)),
- attrs);
- attrs = Fcons (Fcons (Qcmajflt, make_fixnum_or_float (cmajflt)),
- attrs);
+ attrs = Fcons (Fcons (Qtpgid, INT_TO_INTEGER (tpgid)), attrs);
+ attrs = Fcons (Fcons (Qminflt, INT_TO_INTEGER (minflt)), attrs);
+ attrs = Fcons (Fcons (Qmajflt, INT_TO_INTEGER (majflt)), attrs);
+ attrs = Fcons (Fcons (Qcminflt, INT_TO_INTEGER (cminflt)), attrs);
+ attrs = Fcons (Fcons (Qcmajflt, INT_TO_INTEGER (cmajflt)), attrs);
clocks_per_sec = sysconf (_SC_CLK_TCK);
if (clocks_per_sec < 0)
clocks_per_sec = 100;
@@ -3352,19 +3384,17 @@ system_process_attributes (Lisp_Object pid)
ltime_from_jiffies (cstime + cutime,
clocks_per_sec)),
attrs);
- attrs = Fcons (Fcons (Qpri, make_number (priority)), attrs);
- attrs = Fcons (Fcons (Qnice, make_number (niceness)), attrs);
- attrs = Fcons (Fcons (Qthcount, make_fixnum_or_float (thcount)),
- attrs);
+ attrs = Fcons (Fcons (Qpri, make_fixnum (priority)), attrs);
+ attrs = Fcons (Fcons (Qnice, make_fixnum (niceness)), attrs);
+ attrs = Fcons (Fcons (Qthcount, INT_TO_INTEGER (thcount)), attrs);
tnow = current_timespec ();
telapsed = get_up_time ();
tboot = timespec_sub (tnow, telapsed);
tstart = time_from_jiffies (start, clocks_per_sec);
tstart = timespec_add (tboot, tstart);
attrs = Fcons (Fcons (Qstart, make_lisp_time (tstart)), attrs);
- attrs = Fcons (Fcons (Qvsize, make_fixnum_or_float (vsize / 1024)),
- attrs);
- attrs = Fcons (Fcons (Qrss, make_fixnum_or_float (4 * rss)), attrs);
+ attrs = Fcons (Fcons (Qvsize, INT_TO_INTEGER (vsize / 1024)), attrs);
+ attrs = Fcons (Fcons (Qrss, INT_TO_INTEGER (4 * rss)), attrs);
telapsed = timespec_sub (tnow, tstart);
attrs = Fcons (Fcons (Qetime, make_lisp_time (telapsed)), attrs);
us_time = time_from_jiffies (u_time + s_time, clocks_per_sec);
@@ -3405,7 +3435,7 @@ system_process_attributes (Lisp_Object pid)
if (nread)
{
- /* We don't want trailing null characters. */
+ /* We don't want trailing NUL characters. */
for (p = cmdline + nread; cmdline < p && !p[-1]; p--)
continue;
@@ -3478,7 +3508,7 @@ system_process_attributes (Lisp_Object pid)
Lisp_Object decoded_cmd;
ptrdiff_t count;
- CHECK_NUMBER_OR_FLOAT (pid);
+ CHECK_NUMBER (pid);
CONS_TO_INTEGER (pid, pid_t, proc_id);
sprintf (procfn, "/proc/%"pMd, proc_id);
if (stat (procfn, &st) < 0)
@@ -3486,7 +3516,7 @@ system_process_attributes (Lisp_Object pid)
/* euid egid */
uid = st.st_uid;
- attrs = Fcons (Fcons (Qeuid, make_fixnum_or_float (uid)), attrs);
+ attrs = Fcons (Fcons (Qeuid, INT_TO_INTEGER (uid)), attrs);
block_input ();
pw = getpwuid (uid);
unblock_input ();
@@ -3494,7 +3524,7 @@ system_process_attributes (Lisp_Object pid)
attrs = Fcons (Fcons (Quser, build_string (pw->pw_name)), attrs);
gid = st.st_gid;
- attrs = Fcons (Fcons (Qegid, make_fixnum_or_float (gid)), attrs);
+ attrs = Fcons (Fcons (Qegid, INT_TO_INTEGER (gid)), attrs);
block_input ();
gr = getgrgid (gid);
unblock_input ();
@@ -3516,9 +3546,9 @@ system_process_attributes (Lisp_Object pid)
if (nread == sizeof pinfo)
{
- attrs = Fcons (Fcons (Qppid, make_fixnum_or_float (pinfo.pr_ppid)), attrs);
- attrs = Fcons (Fcons (Qpgrp, make_fixnum_or_float (pinfo.pr_pgid)), attrs);
- attrs = Fcons (Fcons (Qsess, make_fixnum_or_float (pinfo.pr_sid)), attrs);
+ attrs = Fcons (Fcons (Qppid, INT_TO_INTEGER (pinfo.pr_ppid)), attrs);
+ attrs = Fcons (Fcons (Qpgrp, INT_TO_INTEGER (pinfo.pr_pgid)), attrs);
+ attrs = Fcons (Fcons (Qsess, INT_TO_INTEGER (pinfo.pr_sid)), attrs);
{
char state_str[2];
@@ -3546,16 +3576,13 @@ system_process_attributes (Lisp_Object pid)
attrs = Fcons (Fcons (Qtime, make_lisp_time (pinfo.pr_time)), attrs);
attrs = Fcons (Fcons (Qctime, make_lisp_time (pinfo.pr_ctime)), attrs);
- attrs = Fcons (Fcons (Qpri, make_number (pinfo.pr_lwp.pr_pri)), attrs);
- attrs = Fcons (Fcons (Qnice, make_number (pinfo.pr_lwp.pr_nice)), attrs);
- attrs = Fcons (Fcons (Qthcount, make_fixnum_or_float (pinfo.pr_nlwp)),
- attrs);
+ attrs = Fcons (Fcons (Qpri, make_fixnum (pinfo.pr_lwp.pr_pri)), attrs);
+ attrs = Fcons (Fcons (Qnice, make_fixnum (pinfo.pr_lwp.pr_nice)), attrs);
+ attrs = Fcons (Fcons (Qthcount, INT_TO_INTEGER (pinfo.pr_nlwp)), attrs);
attrs = Fcons (Fcons (Qstart, make_lisp_time (pinfo.pr_start)), attrs);
- attrs = Fcons (Fcons (Qvsize, make_fixnum_or_float (pinfo.pr_size)),
- attrs);
- attrs = Fcons (Fcons (Qrss, make_fixnum_or_float (pinfo.pr_rssize)),
- attrs);
+ attrs = Fcons (Fcons (Qvsize, INT_TO_INTEGER (pinfo.pr_size)), attrs);
+ attrs = Fcons (Fcons (Qrss, INT_TO_INTEGER (pinfo.pr_rssize)), attrs);
/* pr_pctcpu and pr_pctmem are unsigned integers in the
range 0 .. 2**15, representing 0.0 .. 1.0. */
@@ -3575,24 +3602,11 @@ system_process_attributes (Lisp_Object pid)
Vlocale_coding_system, 0);
attrs = Fcons (Fcons (Qargs, decoded_cmd), attrs);
}
- unbind_to (count, Qnil);
- return attrs;
+ return unbind_to (count, attrs);
}
#elif defined __FreeBSD__
-static struct timespec
-timeval_to_timespec (struct timeval t)
-{
- return make_timespec (t.tv_sec, t.tv_usec * 1000);
-}
-
-static Lisp_Object
-make_lisp_timeval (struct timeval t)
-{
- return make_lisp_time (timeval_to_timespec (t));
-}
-
Lisp_Object
system_process_attributes (Lisp_Object pid)
{
@@ -3614,14 +3628,14 @@ system_process_attributes (Lisp_Object pid)
Lisp_Object attrs = Qnil;
Lisp_Object decoded_comm;
- CHECK_NUMBER_OR_FLOAT (pid);
+ CHECK_NUMBER (pid);
CONS_TO_INTEGER (pid, int, proc_id);
mib[3] = proc_id;
if (sysctl (mib, 4, &proc, &proclen, NULL, 0) != 0)
return attrs;
- attrs = Fcons (Fcons (Qeuid, make_fixnum_or_float (proc.ki_uid)), attrs);
+ attrs = Fcons (Fcons (Qeuid, INT_TO_INTEGER (proc.ki_uid)), attrs);
block_input ();
pw = getpwuid (proc.ki_uid);
@@ -3629,7 +3643,7 @@ system_process_attributes (Lisp_Object pid)
if (pw)
attrs = Fcons (Fcons (Quser, build_string (pw->pw_name)), attrs);
- attrs = Fcons (Fcons (Qegid, make_fixnum_or_float (proc.ki_svgid)), attrs);
+ attrs = Fcons (Fcons (Qegid, INT_TO_INTEGER (proc.ki_svgid)), attrs);
block_input ();
gr = getgrgid (proc.ki_svgid);
@@ -3668,9 +3682,9 @@ system_process_attributes (Lisp_Object pid)
attrs = Fcons (Fcons (Qstate, build_string (state)), attrs);
}
- attrs = Fcons (Fcons (Qppid, make_fixnum_or_float (proc.ki_ppid)), attrs);
- attrs = Fcons (Fcons (Qpgrp, make_fixnum_or_float (proc.ki_pgid)), attrs);
- attrs = Fcons (Fcons (Qsess, make_fixnum_or_float (proc.ki_sid)), attrs);
+ attrs = Fcons (Fcons (Qppid, INT_TO_INTEGER (proc.ki_ppid)), attrs);
+ attrs = Fcons (Fcons (Qpgrp, INT_TO_INTEGER (proc.ki_pgid)), attrs);
+ attrs = Fcons (Fcons (Qsess, INT_TO_INTEGER (proc.ki_sid)), attrs);
block_input ();
ttyname = proc.ki_tdev == NODEV ? NULL : devname (proc.ki_tdev, S_IFCHR);
@@ -3678,11 +3692,13 @@ system_process_attributes (Lisp_Object pid)
if (ttyname)
attrs = Fcons (Fcons (Qtty, build_string (ttyname)), attrs);
- attrs = Fcons (Fcons (Qtpgid, make_fixnum_or_float (proc.ki_tpgid)), attrs);
- attrs = Fcons (Fcons (Qminflt, make_fixnum_or_float (proc.ki_rusage.ru_minflt)), attrs);
- attrs = Fcons (Fcons (Qmajflt, make_fixnum_or_float (proc.ki_rusage.ru_majflt)), attrs);
- attrs = Fcons (Fcons (Qcminflt, make_number (proc.ki_rusage_ch.ru_minflt)), attrs);
- attrs = Fcons (Fcons (Qcmajflt, make_number (proc.ki_rusage_ch.ru_majflt)), attrs);
+ attrs = Fcons (Fcons (Qtpgid, INT_TO_INTEGER (proc.ki_tpgid)), attrs);
+ attrs = Fcons (Fcons (Qminflt, INT_TO_INTEGER (proc.ki_rusage.ru_minflt)),
+ attrs);
+ attrs = Fcons (Fcons (Qmajflt, INT_TO_INTEGER (proc.ki_rusage.ru_majflt)),
+ attrs);
+ attrs = Fcons (Fcons (Qcminflt, make_fixnum (proc.ki_rusage_ch.ru_minflt)), attrs);
+ attrs = Fcons (Fcons (Qcmajflt, make_fixnum (proc.ki_rusage_ch.ru_majflt)), attrs);
attrs = Fcons (Fcons (Qutime, make_lisp_timeval (proc.ki_rusage.ru_utime)),
attrs);
@@ -3702,13 +3718,12 @@ system_process_attributes (Lisp_Object pid)
timeval_to_timespec (proc.ki_rusage_ch.ru_stime));
attrs = Fcons (Fcons (Qctime, make_lisp_time (t)), attrs);
- attrs = Fcons (Fcons (Qthcount, make_fixnum_or_float (proc.ki_numthreads)),
- attrs);
- attrs = Fcons (Fcons (Qpri, make_number (proc.ki_pri.pri_native)), attrs);
- attrs = Fcons (Fcons (Qnice, make_number (proc.ki_nice)), attrs);
+ attrs = Fcons (Fcons (Qthcount, INT_TO_INTEGER (proc.ki_numthreads)), attrs);
+ attrs = Fcons (Fcons (Qpri, make_fixnum (proc.ki_pri.pri_native)), attrs);
+ attrs = Fcons (Fcons (Qnice, make_fixnum (proc.ki_nice)), attrs);
attrs = Fcons (Fcons (Qstart, make_lisp_timeval (proc.ki_start)), attrs);
- attrs = Fcons (Fcons (Qvsize, make_number (proc.ki_size >> 10)), attrs);
- attrs = Fcons (Fcons (Qrss, make_number (proc.ki_rssize * pagesize >> 10)),
+ attrs = Fcons (Fcons (Qvsize, make_fixnum (proc.ki_size >> 10)), attrs);
+ attrs = Fcons (Fcons (Qrss, make_fixnum (proc.ki_rssize * pagesize >> 10)),
attrs);
now = current_timespec ();
@@ -3725,7 +3740,7 @@ system_process_attributes (Lisp_Object pid)
{
pcpu = (100.0 * proc.ki_pctcpu / fscale
/ (1 - exp (proc.ki_swtime * log ((double) ccpu / fscale))));
- attrs = Fcons (Fcons (Qpcpu, make_fixnum_or_float (pcpu)), attrs);
+ attrs = Fcons (Fcons (Qpcpu, INT_TO_INTEGER (pcpu)), attrs);
}
}
@@ -3735,7 +3750,7 @@ system_process_attributes (Lisp_Object pid)
double pmem = (proc.ki_flag & P_INMEM
? 100.0 * proc.ki_rssize / npages
: 0);
- attrs = Fcons (Fcons (Qpmem, make_fixnum_or_float (pmem)), attrs);
+ attrs = Fcons (Fcons (Qpmem, INT_TO_INTEGER (pmem)), attrs);
}
mib[2] = KERN_PROC_ARGS;
@@ -3761,18 +3776,6 @@ system_process_attributes (Lisp_Object pid)
#elif defined DARWIN_OS
-static struct timespec
-timeval_to_timespec (struct timeval t)
-{
- return make_timespec (t.tv_sec, t.tv_usec * 1000);
-}
-
-static Lisp_Object
-make_lisp_timeval (struct timeval t)
-{
- return make_lisp_time (timeval_to_timespec (t));
-}
-
Lisp_Object
system_process_attributes (Lisp_Object pid)
{
@@ -3794,7 +3797,7 @@ system_process_attributes (Lisp_Object pid)
Lisp_Object attrs = Qnil;
Lisp_Object decoded_comm;
- CHECK_NUMBER_OR_FLOAT (pid);
+ CHECK_NUMBER (pid);
CONS_TO_INTEGER (pid, int, proc_id);
mib[3] = proc_id;
@@ -3802,7 +3805,7 @@ system_process_attributes (Lisp_Object pid)
return attrs;
uid = proc.kp_eproc.e_ucred.cr_uid;
- attrs = Fcons (Fcons (Qeuid, make_fixnum_or_float (uid)), attrs);
+ attrs = Fcons (Fcons (Qeuid, INT_TO_INTEGER (uid)), attrs);
block_input ();
pw = getpwuid (uid);
@@ -3811,7 +3814,7 @@ system_process_attributes (Lisp_Object pid)
attrs = Fcons (Fcons (Quser, build_string (pw->pw_name)), attrs);
gid = proc.kp_eproc.e_pcred.p_svgid;
- attrs = Fcons (Fcons (Qegid, make_fixnum_or_float (gid)), attrs);
+ attrs = Fcons (Fcons (Qegid, INT_TO_INTEGER (gid)), attrs);
block_input ();
gr = getgrgid (gid);
@@ -3851,10 +3854,8 @@ system_process_attributes (Lisp_Object pid)
attrs = Fcons (Fcons (Qstate, build_string (state)), attrs);
}
- attrs = Fcons (Fcons (Qppid, make_fixnum_or_float (proc.kp_eproc.e_ppid)),
- attrs);
- attrs = Fcons (Fcons (Qpgrp, make_fixnum_or_float (proc.kp_eproc.e_pgid)),
- attrs);
+ attrs = Fcons (Fcons (Qppid, INT_TO_INTEGER (proc.kp_eproc.e_ppid)), attrs);
+ attrs = Fcons (Fcons (Qpgrp, INT_TO_INTEGER (proc.kp_eproc.e_pgid)), attrs);
tdev = proc.kp_eproc.e_tdev;
block_input ();
@@ -3863,15 +3864,15 @@ system_process_attributes (Lisp_Object pid)
if (ttyname)
attrs = Fcons (Fcons (Qtty, build_string (ttyname)), attrs);
- attrs = Fcons (Fcons (Qtpgid, make_fixnum_or_float (proc.kp_eproc.e_tpgid)),
+ attrs = Fcons (Fcons (Qtpgid, INT_TO_INTEGER (proc.kp_eproc.e_tpgid)),
attrs);
rusage = proc.kp_proc.p_ru;
if (rusage)
{
- attrs = Fcons (Fcons (Qminflt, make_fixnum_or_float (rusage->ru_minflt)),
+ attrs = Fcons (Fcons (Qminflt, INT_TO_INTEGER (rusage->ru_minflt)),
attrs);
- attrs = Fcons (Fcons (Qmajflt, make_fixnum_or_float (rusage->ru_majflt)),
+ attrs = Fcons (Fcons (Qmajflt, INT_TO_INTEGER (rusage->ru_majflt)),
attrs);
attrs = Fcons (Fcons (Qutime, make_lisp_timeval (rusage->ru_utime)),
@@ -3884,7 +3885,7 @@ system_process_attributes (Lisp_Object pid)
}
starttime = proc.kp_proc.p_starttime;
- attrs = Fcons (Fcons (Qnice, make_number (proc.kp_proc.p_nice)), attrs);
+ attrs = Fcons (Fcons (Qnice, make_fixnum (proc.kp_proc.p_nice)), attrs);
attrs = Fcons (Fcons (Qstart, make_lisp_timeval (starttime)), attrs);
now = current_timespec ();
@@ -3905,6 +3906,42 @@ system_process_attributes (Lisp_Object pid)
}
#endif /* !defined (WINDOWSNT) */
+
+DEFUN ("get-internal-run-time", Fget_internal_run_time, Sget_internal_run_time,
+ 0, 0, 0,
+ doc: /* Return the current run time used by Emacs.
+The time is returned as in the style of `current-time'.
+
+On systems that can't determine the run time, `get-internal-run-time'
+does the same thing as `current-time'. */)
+ (void)
+{
+#ifdef HAVE_GETRUSAGE
+ struct rusage usage;
+ time_t secs;
+ int usecs;
+
+ if (getrusage (RUSAGE_SELF, &usage) < 0)
+ /* This shouldn't happen. What action is appropriate? */
+ xsignal0 (Qerror);
+
+ /* Sum up user time and system time. */
+ secs = usage.ru_utime.tv_sec + usage.ru_stime.tv_sec;
+ usecs = usage.ru_utime.tv_usec + usage.ru_stime.tv_usec;
+ if (usecs >= 1000000)
+ {
+ usecs -= 1000000;
+ secs++;
+ }
+ return make_lisp_time (make_timespec (secs, usecs * 1000));
+#else /* ! HAVE_GETRUSAGE */
+#ifdef WINDOWSNT
+ return w32_get_internal_run_time ();
+#else /* ! WINDOWSNT */
+ return Fcurrent_time ();
+#endif /* WINDOWSNT */
+#endif /* HAVE_GETRUSAGE */
+}
/* Wide character string collation. */
@@ -4110,3 +4147,9 @@ str_collate (Lisp_Object s1, Lisp_Object s2,
return res;
}
#endif /* WINDOWSNT */
+
+void
+syms_of_sysdep (void)
+{
+ defsubr (&Sget_internal_run_time);
+}
diff --git a/src/syssignal.h b/src/syssignal.h
index 7a360346c3e..82e376126ae 100644
--- a/src/syssignal.h
+++ b/src/syssignal.h
@@ -22,7 +22,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <signal.h>
-extern void init_signals (bool);
+extern void init_signals (void);
extern void block_child_signal (sigset_t *);
extern void unblock_child_signal (sigset_t const *);
extern void block_interrupt_signal (sigset_t *);
@@ -32,7 +32,6 @@ extern void unblock_tty_out_signal (sigset_t const *);
#ifdef HAVE_PTHREAD
#include <pthread.h>
-extern pthread_t main_thread_id;
/* If defined, asynchronous signals delivered to a non-main thread are
forwarded to the main thread. */
#define FORWARD_SIGNAL_TO_MAIN_THREAD
diff --git a/src/systhread.c b/src/systhread.c
index 91f7e4fd156..6f4de536fba 100644
--- a/src/systhread.c
+++ b/src/systhread.c
@@ -18,6 +18,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <config.h>
#include <setjmp.h>
+#include <stdio.h>
+#include <string.h>
#include "lisp.h"
#ifdef HAVE_NS
@@ -74,11 +76,17 @@ sys_thread_self (void)
return 0;
}
-int
+bool
+sys_thread_equal (sys_thread_t t, sys_thread_t u)
+{
+ return t == u;
+}
+
+bool
sys_thread_create (sys_thread_t *t, const char *name,
thread_creation_function *func, void *datum)
{
- return 0;
+ return false;
}
void
@@ -97,43 +105,77 @@ sys_thread_yield (void)
void
sys_mutex_init (sys_mutex_t *mutex)
{
- pthread_mutex_init (mutex, NULL);
+ pthread_mutexattr_t *attr_ptr;
+#ifdef ENABLE_CHECKING
+ pthread_mutexattr_t attr;
+ {
+ int error = pthread_mutexattr_init (&attr);
+ eassert (error == 0);
+ error = pthread_mutexattr_settype (&attr, PTHREAD_MUTEX_ERRORCHECK);
+ eassert (error == 0);
+ }
+ attr_ptr = &attr;
+#else
+ attr_ptr = NULL;
+#endif
+ int error = pthread_mutex_init (mutex, attr_ptr);
+ /* We could get ENOMEM. Can't do anything except aborting. */
+ if (error != 0)
+ {
+ fprintf (stderr, "\npthread_mutex_init failed: %s\n", strerror (error));
+ emacs_abort ();
+ }
+#ifdef ENABLE_CHECKING
+ error = pthread_mutexattr_destroy (&attr);
+ eassert (error == 0);
+#endif
}
void
sys_mutex_lock (sys_mutex_t *mutex)
{
- pthread_mutex_lock (mutex);
+ int error = pthread_mutex_lock (mutex);
+ eassert (error == 0);
}
void
sys_mutex_unlock (sys_mutex_t *mutex)
{
- pthread_mutex_unlock (mutex);
+ int error = pthread_mutex_unlock (mutex);
+ eassert (error == 0);
}
void
sys_cond_init (sys_cond_t *cond)
{
- pthread_cond_init (cond, NULL);
+ int error = pthread_cond_init (cond, NULL);
+ /* We could get ENOMEM. Can't do anything except aborting. */
+ if (error != 0)
+ {
+ fprintf (stderr, "\npthread_cond_init failed: %s\n", strerror (error));
+ emacs_abort ();
+ }
}
void
sys_cond_wait (sys_cond_t *cond, sys_mutex_t *mutex)
{
- pthread_cond_wait (cond, mutex);
+ int error = pthread_cond_wait (cond, mutex);
+ eassert (error == 0);
}
void
sys_cond_signal (sys_cond_t *cond)
{
- pthread_cond_signal (cond);
+ int error = pthread_cond_signal (cond);
+ eassert (error == 0);
}
void
sys_cond_broadcast (sys_cond_t *cond)
{
- pthread_cond_broadcast (cond);
+ int error = pthread_cond_broadcast (cond);
+ eassert (error == 0);
#ifdef HAVE_NS
/* Send an app defined event to break out of the NS run loop.
It seems that if ns_select is running the NS run loop, this
@@ -146,7 +188,8 @@ sys_cond_broadcast (sys_cond_t *cond)
void
sys_cond_destroy (sys_cond_t *cond)
{
- pthread_cond_destroy (cond);
+ int error = pthread_cond_destroy (cond);
+ eassert (error == 0);
}
sys_thread_t
@@ -155,24 +198,31 @@ sys_thread_self (void)
return pthread_self ();
}
-int
+bool
+sys_thread_equal (sys_thread_t t, sys_thread_t u)
+{
+ return pthread_equal (t, u);
+}
+
+bool
sys_thread_create (sys_thread_t *thread_ptr, const char *name,
thread_creation_function *func, void *arg)
{
pthread_attr_t attr;
- int result = 0;
+ bool result = false;
if (pthread_attr_init (&attr))
- return 0;
+ return false;
-#ifdef DARWIN_OS
/* Avoid crash on macOS with deeply nested GC (Bug#30364). */
size_t stack_size;
size_t required_stack_size = sizeof (void *) * 1024 * 1024;
if (pthread_attr_getstacksize (&attr, &stack_size) == 0
&& stack_size < required_stack_size)
- pthread_attr_setstacksize (&attr, required_stack_size);
-#endif
+ {
+ if (pthread_attr_setstacksize (&attr, required_stack_size) != 0)
+ goto out;
+ }
if (!pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED))
{
@@ -183,7 +233,9 @@ sys_thread_create (sys_thread_t *thread_ptr, const char *name,
#endif
}
- pthread_attr_destroy (&attr);
+ out: ;
+ int error = pthread_attr_destroy (&attr);
+ eassert (error == 0);
return result;
}
@@ -332,6 +384,12 @@ sys_thread_self (void)
return (sys_thread_t) GetCurrentThreadId ();
}
+bool
+sys_thread_equal (sys_thread_t t, sys_thread_t u)
+{
+ return t == u;
+}
+
static thread_creation_function *thread_start_address;
/* _beginthread wants a void function, while we are passed a function
@@ -343,7 +401,7 @@ w32_beginthread_wrapper (void *arg)
(void)thread_start_address (arg);
}
-int
+bool
sys_thread_create (sys_thread_t *thread_ptr, const char *name,
thread_creation_function *func, void *arg)
{
@@ -367,7 +425,7 @@ sys_thread_create (sys_thread_t *thread_ptr, const char *name,
rule in many places... */
thandle = _beginthread (w32_beginthread_wrapper, stack_size, arg);
if (thandle == (uintptr_t)-1L)
- return 0;
+ return false;
/* Kludge alert! We use the Windows thread ID, an unsigned 32-bit
number, as the sys_thread_t type, because that ID is the only
@@ -382,7 +440,7 @@ sys_thread_create (sys_thread_t *thread_ptr, const char *name,
Therefore, we return some more or less arbitrary value of the
thread ID from this function. */
*thread_ptr = thandle & 0xFFFFFFFF;
- return 1;
+ return true;
}
void
diff --git a/src/systhread.h b/src/systhread.h
index 8d7c1a845c1..a1d2746721d 100644
--- a/src/systhread.h
+++ b/src/systhread.h
@@ -19,6 +19,18 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifndef SYSTHREAD_H
#define SYSTHREAD_H
+#include <stdbool.h>
+
+#ifndef __has_attribute
+# define __has_attribute(a) false
+#endif
+
+#if __has_attribute (__warn_unused_result__)
+# define ATTRIBUTE_WARN_UNUSED_RESULT __attribute__ ((__warn_unused_result__))
+#else
+# define ATTRIBUTE_WARN_UNUSED_RESULT
+#endif
+
#ifdef THREADS_ENABLED
#ifdef HAVE_PTHREAD
@@ -99,11 +111,14 @@ extern void sys_cond_signal (sys_cond_t *);
extern void sys_cond_broadcast (sys_cond_t *);
extern void sys_cond_destroy (sys_cond_t *);
-extern sys_thread_t sys_thread_self (void);
+extern sys_thread_t sys_thread_self (void)
+ ATTRIBUTE_WARN_UNUSED_RESULT;
+extern bool sys_thread_equal (sys_thread_t, sys_thread_t)
+ ATTRIBUTE_WARN_UNUSED_RESULT;
-extern int sys_thread_create (sys_thread_t *, const char *,
- thread_creation_function *,
- void *);
+extern bool sys_thread_create (sys_thread_t *, const char *,
+ thread_creation_function *, void *)
+ ATTRIBUTE_WARN_UNUSED_RESULT;
extern void sys_thread_yield (void);
diff --git a/src/systime.h b/src/systime.h
index 6940dc4d1a6..9080cd2bba1 100644
--- a/src/systime.h
+++ b/src/systime.h
@@ -19,16 +19,15 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifndef EMACS_SYSTIME_H
#define EMACS_SYSTIME_H
+#include "lisp.h"
#include <timespec.h>
INLINE_HEADER_BEGIN
-#ifdef emacs
-# ifdef HAVE_X_WINDOWS
-# include <X11/X.h>
-# else
+#ifdef HAVE_X_WINDOWS
+# include <X11/X.h>
+#else
typedef unsigned long Time;
-# endif
#endif
/* On some configurations (hpux8.0, X11R4), sys/time.h and X11/Xos.h
@@ -58,52 +57,44 @@ invalid_timespec (void)
}
/* Return true if TIME is a valid timespec. This currently doesn't worry
- about whether tv_nsec is less than TIMESPEC_RESOLUTION; leap seconds
- might cause a problem if it did. */
+ about whether tv_nsec is less than TIMESPEC_HZ; leap seconds might
+ cause a problem if it did. */
INLINE bool
timespec_valid_p (struct timespec t)
{
return t.tv_nsec >= 0;
}
-/* Return current system time. */
-INLINE struct timespec
-current_timespec (void)
-{
- struct timespec r;
- gettime (&r);
- return r;
-}
-
/* defined in sysdep.c */
extern int set_file_times (int, const char *, struct timespec, struct timespec);
-extern struct timeval make_timeval (struct timespec) ATTRIBUTE_CONST;
/* defined in keyboard.c */
extern void set_waiting_for_input (struct timespec *);
-/* When lisp.h is not included Lisp_Object is not defined (this can
- happen when this file is used outside the src directory). */
-#ifdef emacs
-
/* Emacs uses the integer list (HI LO US PS) to represent the time
(HI << LO_TIME_BITS) + LO + US / 1e6 + PS / 1e12. */
enum { LO_TIME_BITS = 16 };
-/* A Lisp time (HI LO US PS), sans the cons cells. */
+/* Components of a new-format Lisp timestamp. */
struct lisp_time
{
- EMACS_INT hi;
- int lo, us, ps;
+ /* Clock count as a Lisp integer. */
+ Lisp_Object ticks;
+
+ /* Clock frequency (ticks per second) as a positive Lisp integer.
+ (TICKS . HZ) is a valid Lisp timestamp unless HZ < 65536. */
+ Lisp_Object hz;
};
-/* defined in editfns.c */
+/* defined in timefns.c */
+extern struct timeval make_timeval (struct timespec) ATTRIBUTE_CONST;
extern Lisp_Object make_lisp_time (struct timespec);
-extern int decode_time_components (Lisp_Object, Lisp_Object, Lisp_Object,
- Lisp_Object, struct lisp_time *, double *);
-extern struct timespec lisp_to_timespec (struct lisp_time);
+extern bool list4_to_timespec (Lisp_Object, Lisp_Object, Lisp_Object,
+ Lisp_Object, struct timespec *);
extern struct timespec lisp_time_argument (Lisp_Object);
-#endif
+extern _Noreturn void time_overflow (void);
+extern void init_timefns (void);
+extern void syms_of_timefns (void);
INLINE_HEADER_END
diff --git a/src/term.c b/src/term.c
index dcb7d75aa54..a492276c888 100644
--- a/src/term.c
+++ b/src/term.c
@@ -1201,7 +1201,9 @@ calculate_costs (struct frame *frame)
calculate_ins_del_char_costs (frame);
/* Don't use TS_repeat if its padding is worse than sending the chars */
- if (tty->TS_repeat && per_line_cost (tty->TS_repeat) * baud_rate < 9000)
+ if (tty->TS_repeat
+ && (baud_rate <= 0
+ || per_line_cost (tty->TS_repeat) < 9000 / baud_rate))
tty->RPov = string_cost (tty->TS_repeat);
else
tty->RPov = FRAME_COLS (frame) * 2;
@@ -1350,7 +1352,8 @@ term_get_fkeys_1 (void)
char **address = term_get_fkeys_address;
KBOARD *kboard = term_get_fkeys_kboard;
- /* This can happen if CANNOT_DUMP or with strange options. */
+ /* This can happen if Emacs is starting up from scratch, or with
+ strange options. */
if (!KEYMAPP (KVAR (kboard, Vinput_decode_map)))
kset_input_decode_map (kboard, Fmake_sparse_keymap (Qnil));
@@ -1359,8 +1362,7 @@ term_get_fkeys_1 (void)
char *sequence = tgetstr (keys[i].cap, address);
if (sequence)
Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (sequence),
- Fmake_vector (make_number (1),
- intern (keys[i].name)));
+ make_vector (1, intern (keys[i].name)));
}
/* The uses of the "k0" capability are inconsistent; sometimes it
@@ -1379,13 +1381,13 @@ term_get_fkeys_1 (void)
/* Define f0 first, so that f10 takes precedence in case the
key sequences happens to be the same. */
Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (k0),
- Fmake_vector (make_number (1), intern ("f0")));
+ make_vector (1, intern ("f0")));
Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (k_semi),
- Fmake_vector (make_number (1), intern ("f10")));
+ make_vector (1, intern ("f10")));
}
else if (k0)
Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (k0),
- Fmake_vector (make_number (1), intern (k0_name)));
+ make_vector (1, intern (k0_name)));
}
/* Set up cookies for numbered function keys above f10. */
@@ -1408,8 +1410,7 @@ term_get_fkeys_1 (void)
{
sprintf (fkey, "f%d", i);
Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (sequence),
- Fmake_vector (make_number (1),
- intern (fkey)));
+ make_vector (1, intern (fkey)));
}
}
}
@@ -1425,8 +1426,7 @@ term_get_fkeys_1 (void)
char *sequence = tgetstr (cap2, address); \
if (sequence) \
Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (sequence), \
- Fmake_vector (make_number (1), \
- intern (sym))); \
+ make_vector (1, intern (sym))); \
}
/* if there's no key_next keycap, map key_npage to `next' keysym */
@@ -2050,7 +2050,7 @@ TERMINAL does not refer to a text terminal. */)
{
struct terminal *t = decode_tty_terminal (terminal);
- return make_number (t ? t->display_info.tty->TN_max_colors : 0);
+ return make_fixnum (t ? t->display_info.tty->TN_max_colors : 0);
}
#ifndef DOS_NT
@@ -2137,7 +2137,7 @@ set_tty_color_mode (struct tty_display_info *tty, struct frame *f)
tem = assq_no_quit (Qtty_color_mode, f->param_alist);
val = CONSP (tem) ? XCDR (tem) : Qnil;
- if (INTEGERP (val))
+ if (FIXNUMP (val))
color_mode = val;
else if (SYMBOLP (tty_color_mode_alist))
{
@@ -2147,7 +2147,7 @@ set_tty_color_mode (struct tty_display_info *tty, struct frame *f)
else
color_mode = Qnil;
- mode = TYPE_RANGED_INTEGERP (int, color_mode) ? XINT (color_mode) : 0;
+ mode = TYPE_RANGED_FIXNUMP (int, color_mode) ? XFIXNUM (color_mode) : 0;
if (mode != tty->previous_color_mode)
{
@@ -2437,15 +2437,14 @@ term_mouse_movement (struct frame *frame, Gpm_Event *event)
return 0;
}
-/* Return the Time that corresponds to T. Wrap around on overflow. */
+/* Return the current time, as a Time value. Wrap around on overflow. */
static Time
-timeval_to_Time (struct timeval const *t)
+current_Time (void)
{
- Time s_1000, ms;
-
- s_1000 = t->tv_sec;
+ struct timespec now = current_timespec ();
+ Time s_1000 = now.tv_sec;
s_1000 *= 1000;
- ms = t->tv_usec / 1000;
+ Time ms = now.tv_nsec / 1000000;
return s_1000 + ms;
}
@@ -2467,8 +2466,6 @@ term_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window,
enum scroll_bar_part *part, Lisp_Object *x,
Lisp_Object *y, Time *timeptr)
{
- struct timeval now;
-
*fp = SELECTED_FRAME ();
(*fp)->mouse_moved = 0;
@@ -2477,8 +2474,7 @@ term_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window,
XSETINT (*x, last_mouse_x);
XSETINT (*y, last_mouse_y);
- gettimeofday(&now, 0);
- *timeptr = timeval_to_Time (&now);
+ *timeptr = current_Time ();
}
/* Prepare a mouse-event in *RESULT for placement in the input queue.
@@ -2490,7 +2486,6 @@ static Lisp_Object
term_mouse_click (struct input_event *result, Gpm_Event *event,
struct frame *f)
{
- struct timeval now;
int i, j;
result->kind = GPM_CLICK_EVENT;
@@ -2501,8 +2496,7 @@ term_mouse_click (struct input_event *result, Gpm_Event *event,
break;
}
}
- gettimeofday(&now, 0);
- result->timestamp = timeval_to_Time (&now);
+ result->timestamp = current_Time ();
if (event->type & GPM_UP)
result->modifiers = up_modifier;
@@ -2721,7 +2715,7 @@ typedef struct tty_menu_struct
/* Create a brand new menu structure. */
-static tty_menu *
+static tty_menu * ATTRIBUTE_MALLOC
tty_menu_create (void)
{
return xzalloc (sizeof *tty_menu_create ());
@@ -2805,8 +2799,8 @@ mouse_get_xy (int *x, int *y)
&time_dummy);
if (!NILP (lmx))
{
- *x = XINT (lmx);
- *y = XINT (lmy);
+ *x = XFIXNUM (lmx);
+ *y = XFIXNUM (lmy);
}
}
@@ -3132,15 +3126,15 @@ tty_menu_activate (tty_menu *menu, int *pane, int *selidx,
SAFE_NALLOCA (state, 1, menu->panecount);
memset (state, 0, sizeof (*state));
faces[0]
- = lookup_derived_face (sf, intern ("tty-menu-disabled-face"),
+ = lookup_derived_face (NULL, sf, intern ("tty-menu-disabled-face"),
DEFAULT_FACE_ID, 1);
faces[1]
- = lookup_derived_face (sf, intern ("tty-menu-enabled-face"),
+ = lookup_derived_face (NULL, sf, intern ("tty-menu-enabled-face"),
DEFAULT_FACE_ID, 1);
selectface = intern ("tty-menu-selected-face");
- faces[2] = lookup_derived_face (sf, selectface,
+ faces[2] = lookup_derived_face (NULL, sf, selectface,
faces[0], 1);
- faces[3] = lookup_derived_face (sf, selectface,
+ faces[3] = lookup_derived_face (NULL, sf, selectface,
faces[1], 1);
/* Make sure the menu title is always displayed with
@@ -3403,20 +3397,25 @@ tty_menu_help_callback (char const *help_string, int pane, int item)
pane_name = first_item[MENU_ITEMS_ITEM_NAME];
/* (menu-item MENU-NAME PANE-NUMBER) */
- menu_object = list3 (Qmenu_item, pane_name, make_number (pane));
+ menu_object = list3 (Qmenu_item, pane_name, make_fixnum (pane));
show_help_echo (help_string ? build_string (help_string) : Qnil,
- Qnil, menu_object, make_number (item));
+ Qnil, menu_object, make_fixnum (item));
}
+struct tty_pop_down_menu
+{
+ tty_menu *menu;
+ struct buffer *buffer;
+};
+
static void
-tty_pop_down_menu (Lisp_Object arg)
+tty_pop_down_menu (void *arg)
{
- tty_menu *menu = XSAVE_POINTER (arg, 0);
- struct buffer *orig_buffer = XSAVE_POINTER (arg, 1);
+ struct tty_pop_down_menu *data = arg;
block_input ();
- tty_menu_destroy (menu);
- set_buffer_internal (orig_buffer);
+ tty_menu_destroy (data->menu);
+ set_buffer_internal (data->buffer);
unblock_input ();
}
@@ -3472,7 +3471,7 @@ tty_menu_new_item_coords (struct frame *f, int which, int *x, int *y)
pos = AREF (items, i + 3);
if (NILP (str))
return;
- ix = XINT (pos);
+ ix = XFIXNUM (pos);
if (ix <= *x
/* We use <= so the blank between 2 items on a TTY is
considered part of the previous item. */
@@ -3483,14 +3482,14 @@ tty_menu_new_item_coords (struct frame *f, int which, int *x, int *y)
if (which == TTYM_NEXT)
{
if (i < last_i)
- *x = XINT (AREF (items, i + 4 + 3));
+ *x = XFIXNUM (AREF (items, i + 4 + 3));
else
*x = 0; /* Wrap around to the first item. */
}
else if (prev_x < 0)
{
/* Wrap around to the last item. */
- *x = XINT (AREF (items, last_i + 3));
+ *x = XFIXNUM (AREF (items, last_i + 3));
}
else
*x = prev_x;
@@ -3697,8 +3696,9 @@ tty_menu_show (struct frame *f, int x, int y, int menuflags,
/* We save and restore the current buffer because tty_menu_activate
triggers redisplay, which switches buffers at will. */
- record_unwind_protect (tty_pop_down_menu,
- make_save_ptr_ptr (menu, current_buffer));
+ record_unwind_protect_ptr (tty_pop_down_menu,
+ &((struct tty_pop_down_menu)
+ {menu, current_buffer}));
specbind (Qoverriding_terminal_local_map,
Fsymbol_value (Qtty_menu_navigation_map));
@@ -3748,7 +3748,7 @@ tty_menu_show (struct frame *f, int x, int y, int menuflags,
case TTYM_NEXT:
case TTYM_PREV:
tty_menu_new_item_coords (f, status, &item_x, &item_y);
- entry = Fcons (make_number (item_x), make_number (item_y));
+ entry = Fcons (make_fixnum (item_x), make_fixnum (item_y));
break;
case TTYM_FAILURE:
@@ -3770,9 +3770,7 @@ tty_menu_show (struct frame *f, int x, int y, int menuflags,
tty_menu_end:
- SAFE_FREE ();
- unbind_to (specpdl_count, Qnil);
- return entry;
+ return SAFE_FREE_UNBIND_TO (specpdl_count, entry);
}
#endif /* !MSDOS */
@@ -4145,10 +4143,10 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\
tty->TN_max_colors = tgetnum ("Co");
#ifdef TERMINFO
- /* Non-standard support for 24-bit colors. */
{
const char *fg = tigetstr ("setf24");
const char *bg = tigetstr ("setb24");
+ /* Non-standard support for 24-bit colors. */
if (fg && bg
&& fg != (char *) (intptr_t) -1
&& bg != (char *) (intptr_t) -1)
@@ -4157,6 +4155,14 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\
tty->TS_set_background = bg;
tty->TN_max_colors = 16777216;
}
+ /* Standard support for 24-bit colors. */
+ else if (tigetflag ("RGB") > 0)
+ {
+ /* If the used Terminfo library supports only 16-bit
+ signed values, tgetnum("Co") and tigetnum("colors")
+ could return 32767. */
+ tty->TN_max_colors = 16777216;
+ }
}
#endif
diff --git a/src/termcap.c b/src/termcap.c
index 2f2a0b29d5e..7dc0d572888 100644
--- a/src/termcap.c
+++ b/src/termcap.c
@@ -20,10 +20,14 @@ along with this program. If not, see <https://www.gnu.org/licenses/>. */
/* Emacs config.h may rename various library functions such as malloc. */
#include <config.h>
+
+#include <stdlib.h>
#include <sys/file.h>
#include <fcntl.h>
#include <unistd.h>
+#include <intprops.h>
+
#include "lisp.h"
#include "tparam.h"
#ifdef MSDOS
@@ -158,7 +162,7 @@ tgetst1 (char *ptr, char **area)
else
ret = *area;
- /* Copy the string value, stopping at null or colon.
+ /* Copy the string value, stopping at NUL or colon.
Also process ^ and \ abbreviations. */
p = ptr;
r = ret;
@@ -265,14 +269,7 @@ char PC;
void
tputs (register const char *str, int nlines, int (*outfun) (int))
{
- register int padcount = 0;
- register int speed;
-
- speed = baud_rate;
- /* For quite high speeds, convert to the smaller
- units to avoid overflow. */
- if (speed > 10000)
- speed = - speed / 100;
+ int padcount = 0;
if (!str)
return;
@@ -296,21 +293,13 @@ tputs (register const char *str, int nlines, int (*outfun) (int))
(*outfun) (*str++);
/* PADCOUNT is now in units of tenths of msec.
- SPEED is measured in characters per 10 seconds
- or in characters per .1 seconds (if negative).
- We use the smaller units for larger speeds to avoid overflow. */
- padcount *= speed;
- padcount += 500;
- padcount /= 1000;
- if (speed < 0)
- padcount = -padcount;
- else
- {
- padcount += 50;
- padcount /= 100;
- }
+ BAUD_RATE is measured in characters per 10 seconds.
+ Compute PADFACTOR = 100000 * (how many padding bytes are needed). */
+ intmax_t padfactor;
+ if (INT_MULTIPLY_WRAPV (padcount, baud_rate, &padfactor))
+ padfactor = baud_rate < 0 ? INTMAX_MIN : INTMAX_MAX;
- while (padcount-- > 0)
+ for (; 50000 <= padfactor; padfactor -= 100000)
(*outfun) (PC);
}
@@ -426,7 +415,7 @@ tgetent (char *bp, const char *name)
}
if (!termcap_name || !filep)
- termcap_name = TERMCAP_FILE;
+ termcap_name = (char *) TERMCAP_FILE;
/* Here we know we must search a file and termcap_name has its name. */
@@ -435,7 +424,7 @@ tgetent (char *bp, const char *name)
return -1;
buf.size = BUFSIZE;
- /* Add 1 to size to ensure room for terminating null. */
+ /* Add 1 to size to ensure room for terminating NUL. */
buf.beg = xmalloc (buf.size + 1);
term = indirect ? indirect : (char *)name;
@@ -491,7 +480,7 @@ tgetent (char *bp, const char *name)
*bp1 = '\0';
/* Does this entry refer to another terminal type's entry?
- If something is found, copy it into heap and null-terminate it. */
+ If something is found, copy it into heap and NUL-terminate it. */
tc_search_point = find_capability (tc_search_point, "tc");
term = tgetst1 (tc_search_point, 0);
}
@@ -629,7 +618,7 @@ gobble_line (int fd, register struct termcap_buffer *bufp, char *append_end)
{
ptrdiff_t ptr_offset = bufp->ptr - buf;
ptrdiff_t append_end_offset = append_end - buf;
- /* Add 1 to size to ensure room for terminating null. */
+ /* Add 1 to size to ensure room for terminating NUL. */
ptrdiff_t size = bufp->size + 1;
bufp->beg = buf = xpalloc (buf, &size, 1, -1, 1);
bufp->size = size - 1;
diff --git a/src/termhooks.h b/src/termhooks.h
index fa15765df4b..a92b981110d 100644
--- a/src/termhooks.h
+++ b/src/termhooks.h
@@ -222,6 +222,10 @@ enum event_kind
, DBUS_EVENT
#endif
+#ifdef THREADS_ENABLED
+ , THREAD_EVENT
+#endif
+
, CONFIG_CHANGED_EVENT
#ifdef HAVE_NTGUI
@@ -346,7 +350,7 @@ enum {
FIXNUM_BITS, so using it to represent a modifier key means that
characters thus modified have different integer equivalents
depending on the architecture they're running on. Oh, and
- applying XINT to a character whose 2^28 bit is set might sign-extend
+ applying XFIXNUM to a character whose 2^28 bit is set might sign-extend
it, so you get a bunch of bits in the mask you didn't want.
The CHAR_ macros are defined in lisp.h. */
@@ -404,7 +408,7 @@ struct terminal
whether the mapping is available. */
Lisp_Object glyph_code_table;
- /* All fields before `next_terminal' should be Lisp_Object and are traced
+ /* All earlier fields should be Lisp_Objects and are traced
by the GC. All fields afterwards are ignored by the GC. */
/* Chain of all terminal devices. */
@@ -657,7 +661,7 @@ struct terminal
frames on the terminal when it calls this hook, so infinite
recursion is prevented. */
void (*delete_terminal_hook) (struct terminal *);
-};
+} GCALIGNED_STRUCT;
INLINE bool
TERMINALP (Lisp_Object a)
@@ -669,7 +673,7 @@ INLINE struct terminal *
XTERMINAL (Lisp_Object a)
{
eassert (TERMINALP (a));
- return XUNTAG (a, Lisp_Vectorlike);
+ return XUNTAG (a, Lisp_Vectorlike, struct terminal);
}
/* Most code should use these functions to set Lisp fields in struct
diff --git a/src/terminal.c b/src/terminal.c
index a7d99aaf70f..0ee0121e35e 100644
--- a/src/terminal.c
+++ b/src/terminal.c
@@ -264,8 +264,8 @@ get_named_terminal (const char *name)
static struct terminal *
allocate_terminal (void)
{
- return ALLOCATE_ZEROED_PSEUDOVECTOR
- (struct terminal, next_terminal, PVEC_TERMINAL);
+ return ALLOCATE_ZEROED_PSEUDOVECTOR (struct terminal, glyph_code_table,
+ PVEC_TERMINAL);
}
/* Create a new terminal object of TYPE and add it to the terminal list. RIF
@@ -490,7 +490,7 @@ static Lisp_Object
store_terminal_param (struct terminal *t, Lisp_Object parameter, Lisp_Object value)
{
Lisp_Object old_alist_elt = Fassq (parameter, t->param_alist);
- if (EQ (old_alist_elt, Qnil))
+ if (NILP (old_alist_elt))
{
tset_param_alist (t, Fcons (Fcons (parameter, value), t->param_alist));
return Qnil;
@@ -558,10 +558,10 @@ calculate_glyph_code_table (struct terminal *t)
struct unimapdesc unimapdesc = { entry_ct, entries };
if (ioctl (fd, GIO_UNIMAP, &unimapdesc) == 0)
{
- glyphtab = Fmake_char_table (Qnil, make_number (-1));
+ glyphtab = Fmake_char_table (Qnil, make_fixnum (-1));
for (int i = 0; i < unimapdesc.entry_ct; i++)
char_table_set (glyphtab, entries[i].unicode,
- make_number (entries[i].fontpos));
+ make_fixnum (entries[i].fontpos));
break;
}
if (errno != ENOMEM)
diff --git a/src/textprop.c b/src/textprop.c
index db9a568d191..bb063d3eaaa 100644
--- a/src/textprop.c
+++ b/src/textprop.c
@@ -79,7 +79,7 @@ text_read_only (Lisp_Object propval)
static void
modify_text_properties (Lisp_Object buffer, Lisp_Object start, Lisp_Object end)
{
- ptrdiff_t b = XINT (start), e = XINT (end);
+ ptrdiff_t b = XFIXNUM (start), e = XFIXNUM (end);
struct buffer *buf = XBUFFER (buffer), *old = current_buffer;
set_buffer_internal (buf);
@@ -89,7 +89,7 @@ modify_text_properties (Lisp_Object buffer, Lisp_Object start, Lisp_Object end)
BUF_COMPUTE_UNCHANGED (buf, b - 1, e);
if (MODIFF <= SAVE_MODIFF)
record_first_change ();
- MODIFF++;
+ modiff_incr (&MODIFF);
bset_point_before_scroll (current_buffer, Qnil);
@@ -111,9 +111,6 @@ CHECK_STRING_OR_BUFFER (Lisp_Object x)
to by BEGIN and END may be integers or markers; if the latter, they
are coerced to integers.
- When OBJECT is a string, we increment *BEGIN and *END
- to make them origin-one.
-
Note that buffer points don't correspond to interval indices.
For example, point-max is 1 greater than the index of the last
character. This difference is handled in the caller, which uses
@@ -137,15 +134,15 @@ validate_interval_range (Lisp_Object object, Lisp_Object *begin,
ptrdiff_t searchpos;
CHECK_STRING_OR_BUFFER (object);
- CHECK_NUMBER_COERCE_MARKER (*begin);
- CHECK_NUMBER_COERCE_MARKER (*end);
+ CHECK_FIXNUM_COERCE_MARKER (*begin);
+ CHECK_FIXNUM_COERCE_MARKER (*end);
/* If we are asked for a point, but from a subr which operates
on a range, then return nothing. */
if (EQ (*begin, *end) && begin != end)
return NULL;
- if (XINT (*begin) > XINT (*end))
+ if (XFIXNUM (*begin) > XFIXNUM (*end))
{
Lisp_Object n;
n = *begin;
@@ -157,8 +154,8 @@ validate_interval_range (Lisp_Object object, Lisp_Object *begin,
{
register struct buffer *b = XBUFFER (object);
- if (!(BUF_BEGV (b) <= XINT (*begin) && XINT (*begin) <= XINT (*end)
- && XINT (*end) <= BUF_ZV (b)))
+ if (!(BUF_BEGV (b) <= XFIXNUM (*begin) && XFIXNUM (*begin) <= XFIXNUM (*end)
+ && XFIXNUM (*end) <= BUF_ZV (b)))
args_out_of_range (*begin, *end);
i = buffer_intervals (b);
@@ -166,24 +163,21 @@ validate_interval_range (Lisp_Object object, Lisp_Object *begin,
if (BUF_BEGV (b) == BUF_ZV (b))
return NULL;
- searchpos = XINT (*begin);
+ searchpos = XFIXNUM (*begin);
}
else
{
ptrdiff_t len = SCHARS (object);
- if (! (0 <= XINT (*begin) && XINT (*begin) <= XINT (*end)
- && XINT (*end) <= len))
+ if (! (0 <= XFIXNUM (*begin) && XFIXNUM (*begin) <= XFIXNUM (*end)
+ && XFIXNUM (*end) <= len))
args_out_of_range (*begin, *end);
- XSETFASTINT (*begin, XFASTINT (*begin));
- if (begin != end)
- XSETFASTINT (*end, XFASTINT (*end));
i = string_intervals (object);
if (len == 0)
return NULL;
- searchpos = XINT (*begin);
+ searchpos = XFIXNUM (*begin);
}
if (!i)
@@ -544,7 +538,7 @@ interval_of (ptrdiff_t position, Lisp_Object object)
}
if (!(beg <= position && position <= end))
- args_out_of_range (make_number (position), make_number (position));
+ args_out_of_range (make_fixnum (position), make_fixnum (position));
if (beg == end || !i)
return NULL;
@@ -572,7 +566,7 @@ If POSITION is at the end of OBJECT, the value is nil. */)
it means it's the end of OBJECT.
There are no properties at the very end,
since no character follows. */
- if (XINT (position) == LENGTH (i) + i->position)
+ if (XFIXNUM (position) == LENGTH (i) + i->position)
return Qnil;
return i->plist;
@@ -604,7 +598,7 @@ get_char_property_and_overlay (Lisp_Object position, register Lisp_Object prop,
{
struct window *w = 0;
- CHECK_NUMBER_COERCE_MARKER (position);
+ CHECK_FIXNUM_COERCE_MARKER (position);
if (NILP (object))
XSETBUFFER (object, current_buffer);
@@ -621,14 +615,14 @@ get_char_property_and_overlay (Lisp_Object position, register Lisp_Object prop,
Lisp_Object *overlay_vec;
struct buffer *obuf = current_buffer;
- if (XINT (position) < BUF_BEGV (XBUFFER (object))
- || XINT (position) > BUF_ZV (XBUFFER (object)))
+ if (XFIXNUM (position) < BUF_BEGV (XBUFFER (object))
+ || XFIXNUM (position) > BUF_ZV (XBUFFER (object)))
xsignal1 (Qargs_out_of_range, position);
set_buffer_temp (XBUFFER (object));
USE_SAFE_ALLOCA;
- GET_OVERLAYS_AT (XINT (position), overlay_vec, noverlays, NULL, false);
+ GET_OVERLAYS_AT (XFIXNUM (position), overlay_vec, noverlays, NULL, false);
noverlays = sort_overlays (overlay_vec, noverlays, w);
set_buffer_temp (obuf);
@@ -714,8 +708,8 @@ before LIMIT. LIMIT is a no-op if it is greater than (point-max). */)
temp = Fnext_overlay_change (position);
if (! NILP (limit))
{
- CHECK_NUMBER_COERCE_MARKER (limit);
- if (XINT (limit) < XINT (temp))
+ CHECK_FIXNUM_COERCE_MARKER (limit);
+ if (XFIXNUM (limit) < XFIXNUM (temp))
temp = limit;
}
return Fnext_property_change (position, Qnil, temp);
@@ -740,8 +734,8 @@ before LIMIT. LIMIT is a no-op if it is less than (point-min). */)
temp = Fprevious_overlay_change (position);
if (! NILP (limit))
{
- CHECK_NUMBER_COERCE_MARKER (limit);
- if (XINT (limit) > XINT (temp))
+ CHECK_FIXNUM_COERCE_MARKER (limit);
+ if (XFIXNUM (limit) > XFIXNUM (temp))
temp = limit;
}
return Fprevious_property_change (position, Qnil, temp);
@@ -774,10 +768,10 @@ last valid position in OBJECT. */)
if (NILP (position))
{
if (NILP (limit))
- position = make_number (SCHARS (object));
+ position = make_fixnum (SCHARS (object));
else
{
- CHECK_NUMBER (limit);
+ CHECK_FIXNUM (limit);
position = limit;
}
}
@@ -796,26 +790,26 @@ last valid position in OBJECT. */)
Fset_buffer (object);
}
- CHECK_NUMBER_COERCE_MARKER (position);
+ CHECK_FIXNUM_COERCE_MARKER (position);
initial_value = Fget_char_property (position, prop, object);
if (NILP (limit))
XSETFASTINT (limit, ZV);
else
- CHECK_NUMBER_COERCE_MARKER (limit);
+ CHECK_FIXNUM_COERCE_MARKER (limit);
- if (XFASTINT (position) >= XFASTINT (limit))
+ if (XFIXNAT (position) >= XFIXNAT (limit))
{
position = limit;
- if (XFASTINT (position) > ZV)
+ if (XFIXNAT (position) > ZV)
XSETFASTINT (position, ZV);
}
else
while (true)
{
position = Fnext_char_property_change (position, limit);
- if (XFASTINT (position) >= XFASTINT (limit))
+ if (XFIXNAT (position) >= XFIXNAT (limit))
{
position = limit;
break;
@@ -826,7 +820,7 @@ last valid position in OBJECT. */)
break;
}
- unbind_to (count, Qnil);
+ position = unbind_to (count, position);
}
return position;
@@ -859,10 +853,10 @@ first valid position in OBJECT. */)
if (NILP (position))
{
if (NILP (limit))
- position = make_number (0);
+ position = make_fixnum (0);
else
{
- CHECK_NUMBER (limit);
+ CHECK_FIXNUM (limit);
position = limit;
}
}
@@ -880,30 +874,30 @@ first valid position in OBJECT. */)
Fset_buffer (object);
}
- CHECK_NUMBER_COERCE_MARKER (position);
+ CHECK_FIXNUM_COERCE_MARKER (position);
if (NILP (limit))
XSETFASTINT (limit, BEGV);
else
- CHECK_NUMBER_COERCE_MARKER (limit);
+ CHECK_FIXNUM_COERCE_MARKER (limit);
- if (XFASTINT (position) <= XFASTINT (limit))
+ if (XFIXNAT (position) <= XFIXNAT (limit))
{
position = limit;
- if (XFASTINT (position) < BEGV)
+ if (XFIXNAT (position) < BEGV)
XSETFASTINT (position, BEGV);
}
else
{
Lisp_Object initial_value
- = Fget_char_property (make_number (XFASTINT (position) - 1),
+ = Fget_char_property (make_fixnum (XFIXNAT (position) - 1),
prop, object);
while (true)
{
position = Fprevious_char_property_change (position, limit);
- if (XFASTINT (position) <= XFASTINT (limit))
+ if (XFIXNAT (position) <= XFIXNAT (limit))
{
position = limit;
break;
@@ -911,7 +905,7 @@ first valid position in OBJECT. */)
else
{
Lisp_Object value
- = Fget_char_property (make_number (XFASTINT (position) - 1),
+ = Fget_char_property (make_fixnum (XFIXNAT (position) - 1),
prop, object);
if (!EQ (value, initial_value))
@@ -920,7 +914,7 @@ first valid position in OBJECT. */)
}
}
- unbind_to (count, Qnil);
+ position = unbind_to (count, position);
}
return position;
@@ -948,7 +942,7 @@ past position LIMIT; return LIMIT if nothing is found before LIMIT. */)
XSETBUFFER (object, current_buffer);
if (!NILP (limit) && !EQ (limit, Qt))
- CHECK_NUMBER_COERCE_MARKER (limit);
+ CHECK_FIXNUM_COERCE_MARKER (limit);
i = validate_interval_range (object, &position, &position, soft);
@@ -976,19 +970,19 @@ past position LIMIT; return LIMIT if nothing is found before LIMIT. */)
next = next_interval (i);
while (next && intervals_equal (i, next)
- && (NILP (limit) || next->position < XFASTINT (limit)))
+ && (NILP (limit) || next->position < XFIXNAT (limit)))
next = next_interval (next);
if (!next
|| (next->position
- >= (INTEGERP (limit)
- ? XFASTINT (limit)
+ >= (FIXNUMP (limit)
+ ? XFIXNAT (limit)
: (STRINGP (object)
? SCHARS (object)
: BUF_ZV (XBUFFER (object))))))
return limit;
else
- return make_number (next->position);
+ return make_fixnum (next->position);
}
DEFUN ("next-single-property-change", Fnext_single_property_change,
@@ -1015,7 +1009,7 @@ past position LIMIT; return LIMIT if nothing is found before LIMIT. */)
XSETBUFFER (object, current_buffer);
if (!NILP (limit))
- CHECK_NUMBER_COERCE_MARKER (limit);
+ CHECK_FIXNUM_COERCE_MARKER (limit);
i = validate_interval_range (object, &position, &position, soft);
if (!i)
@@ -1025,19 +1019,19 @@ past position LIMIT; return LIMIT if nothing is found before LIMIT. */)
next = next_interval (i);
while (next
&& EQ (here_val, textget (next->plist, prop))
- && (NILP (limit) || next->position < XFASTINT (limit)))
+ && (NILP (limit) || next->position < XFIXNAT (limit)))
next = next_interval (next);
if (!next
|| (next->position
- >= (INTEGERP (limit)
- ? XFASTINT (limit)
+ >= (FIXNUMP (limit)
+ ? XFIXNAT (limit)
: (STRINGP (object)
? SCHARS (object)
: BUF_ZV (XBUFFER (object))))))
return limit;
else
- return make_number (next->position);
+ return make_fixnum (next->position);
}
DEFUN ("previous-property-change", Fprevious_property_change,
@@ -1062,30 +1056,30 @@ back past position LIMIT; return LIMIT if nothing is found until LIMIT. */)
XSETBUFFER (object, current_buffer);
if (!NILP (limit))
- CHECK_NUMBER_COERCE_MARKER (limit);
+ CHECK_FIXNUM_COERCE_MARKER (limit);
i = validate_interval_range (object, &position, &position, soft);
if (!i)
return limit;
/* Start with the interval containing the char before point. */
- if (i->position == XFASTINT (position))
+ if (i->position == XFIXNAT (position))
i = previous_interval (i);
previous = previous_interval (i);
while (previous && intervals_equal (previous, i)
&& (NILP (limit)
- || (previous->position + LENGTH (previous) > XFASTINT (limit))))
+ || (previous->position + LENGTH (previous) > XFIXNAT (limit))))
previous = previous_interval (previous);
if (!previous
|| (previous->position + LENGTH (previous)
- <= (INTEGERP (limit)
- ? XFASTINT (limit)
+ <= (FIXNUMP (limit)
+ ? XFIXNAT (limit)
: (STRINGP (object) ? 0 : BUF_BEGV (XBUFFER (object))))))
return limit;
else
- return make_number (previous->position + LENGTH (previous));
+ return make_fixnum (previous->position + LENGTH (previous));
}
DEFUN ("previous-single-property-change", Fprevious_single_property_change,
@@ -1112,12 +1106,12 @@ back past position LIMIT; return LIMIT if nothing is found until LIMIT. */)
XSETBUFFER (object, current_buffer);
if (!NILP (limit))
- CHECK_NUMBER_COERCE_MARKER (limit);
+ CHECK_FIXNUM_COERCE_MARKER (limit);
i = validate_interval_range (object, &position, &position, soft);
/* Start with the interval containing the char before point. */
- if (i && i->position == XFASTINT (position))
+ if (i && i->position == XFIXNAT (position))
i = previous_interval (i);
if (!i)
@@ -1128,17 +1122,17 @@ back past position LIMIT; return LIMIT if nothing is found until LIMIT. */)
while (previous
&& EQ (here_val, textget (previous->plist, prop))
&& (NILP (limit)
- || (previous->position + LENGTH (previous) > XFASTINT (limit))))
+ || (previous->position + LENGTH (previous) > XFIXNAT (limit))))
previous = previous_interval (previous);
if (!previous
|| (previous->position + LENGTH (previous)
- <= (INTEGERP (limit)
- ? XFASTINT (limit)
+ <= (FIXNUMP (limit)
+ ? XFIXNAT (limit)
: (STRINGP (object) ? 0 : BUF_BEGV (XBUFFER (object))))))
return limit;
else
- return make_number (previous->position + LENGTH (previous));
+ return make_fixnum (previous->position + LENGTH (previous));
}
/* Used by add-text-properties and add-face-text-property. */
@@ -1164,8 +1158,8 @@ add_text_properties_1 (Lisp_Object start, Lisp_Object end,
if (!i)
return Qnil;
- s = XINT (start);
- len = XINT (end) - s;
+ s = XFIXNUM (start);
+ len = XFIXNUM (end) - s;
/* If this interval already has the properties, we can skip it. */
if (interval_has_all_properties (properties, i))
@@ -1221,8 +1215,8 @@ add_text_properties_1 (Lisp_Object start, Lisp_Object end,
if (interval_has_all_properties (properties, i))
{
if (BUFFERP (object))
- signal_after_change (XINT (start), XINT (end) - XINT (start),
- XINT (end) - XINT (start));
+ signal_after_change (XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start),
+ XFIXNUM (end) - XFIXNUM (start));
eassert (modified);
return Qt;
@@ -1232,8 +1226,8 @@ add_text_properties_1 (Lisp_Object start, Lisp_Object end,
{
add_properties (properties, i, object, set_type);
if (BUFFERP (object))
- signal_after_change (XINT (start), XINT (end) - XINT (start),
- XINT (end) - XINT (start));
+ signal_after_change (XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start),
+ XFIXNUM (end) - XFIXNUM (start));
return Qt;
}
@@ -1243,8 +1237,8 @@ add_text_properties_1 (Lisp_Object start, Lisp_Object end,
copy_properties (unchanged, i);
add_properties (properties, i, object, set_type);
if (BUFFERP (object))
- signal_after_change (XINT (start), XINT (end) - XINT (start),
- XINT (end) - XINT (start));
+ signal_after_change (XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start),
+ XFIXNUM (end) - XFIXNUM (start));
return Qt;
}
@@ -1348,13 +1342,9 @@ Lisp_Object
set_text_properties (Lisp_Object start, Lisp_Object end, Lisp_Object properties,
Lisp_Object object, Lisp_Object coherent_change_p)
{
- register INTERVAL i;
- Lisp_Object ostart, oend;
+ INTERVAL i;
bool first_time = true;
- ostart = start;
- oend = end;
-
properties = validate_plist (properties);
if (NILP (object))
@@ -1363,8 +1353,8 @@ set_text_properties (Lisp_Object start, Lisp_Object end, Lisp_Object properties,
/* If we want no properties for a whole string,
get rid of its intervals. */
if (NILP (properties) && STRINGP (object)
- && XFASTINT (start) == 0
- && XFASTINT (end) == SCHARS (object))
+ && XFIXNAT (start) == 0
+ && XFIXNAT (end) == SCHARS (object))
{
if (!string_intervals (object))
return Qnil;
@@ -1382,11 +1372,6 @@ set_text_properties (Lisp_Object start, Lisp_Object end, Lisp_Object properties,
if (NILP (properties))
return Qnil;
- /* Restore the original START and END values
- because validate_interval_range increments them for strings. */
- start = ostart;
- end = oend;
-
i = validate_interval_range (object, &start, &end, hard);
/* This can return if start == end. */
if (!i)
@@ -1413,42 +1398,33 @@ set_text_properties (Lisp_Object start, Lisp_Object end, Lisp_Object properties,
set_text_properties_1 (start, end, properties, object, i);
if (BUFFERP (object) && !NILP (coherent_change_p))
- signal_after_change (XINT (start), XINT (end) - XINT (start),
- XINT (end) - XINT (start));
+ signal_after_change (XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start),
+ XFIXNUM (end) - XFIXNUM (start));
return Qt;
}
/* Replace properties of text from START to END with new list of
properties PROPERTIES. OBJECT is the buffer or string containing
the text. This does not obey any hooks.
- You should provide the interval that START is located in as I.
- START and END can be in any order. */
+ I is the interval that START is located in. */
void
-set_text_properties_1 (Lisp_Object start, Lisp_Object end, Lisp_Object properties, Lisp_Object object, INTERVAL i)
+set_text_properties_1 (Lisp_Object start, Lisp_Object end,
+ Lisp_Object properties, Lisp_Object object, INTERVAL i)
{
- register INTERVAL prev_changed = NULL;
- register ptrdiff_t s, len;
- INTERVAL unchanged;
+ INTERVAL prev_changed = NULL;
+ ptrdiff_t s = XFIXNUM (start);
+ ptrdiff_t len = XFIXNUM (end) - s;
- if (XINT (start) < XINT (end))
- {
- s = XINT (start);
- len = XINT (end) - s;
- }
- else if (XINT (end) < XINT (start))
- {
- s = XINT (end);
- len = XINT (start) - s;
- }
- else
+ if (len == 0)
return;
+ eassert (0 < len);
eassert (i);
if (i->position != s)
{
- unchanged = i;
+ INTERVAL unchanged = i;
i = split_interval_right (unchanged, s - unchanged->position);
if (LENGTH (i) > len)
@@ -1531,8 +1507,8 @@ Use `set-text-properties' if you want to remove all text properties. */)
if (!i)
return Qnil;
- s = XINT (start);
- len = XINT (end) - s;
+ s = XFIXNUM (start);
+ len = XFIXNUM (end) - s;
/* If there are no properties on this entire interval, return. */
if (! interval_has_some_properties (properties, i))
@@ -1589,8 +1565,8 @@ Use `set-text-properties' if you want to remove all text properties. */)
{
eassert (modified);
if (BUFFERP (object))
- signal_after_change (XINT (start), XINT (end) - XINT (start),
- XINT (end) - XINT (start));
+ signal_after_change (XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start),
+ XFIXNUM (end) - XFIXNUM (start));
return Qt;
}
@@ -1598,8 +1574,8 @@ Use `set-text-properties' if you want to remove all text properties. */)
{
remove_properties (properties, Qnil, i, object);
if (BUFFERP (object))
- signal_after_change (XINT (start), XINT (end) - XINT (start),
- XINT (end) - XINT (start));
+ signal_after_change (XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start),
+ XFIXNUM (end) - XFIXNUM (start));
return Qt;
}
@@ -1609,8 +1585,8 @@ Use `set-text-properties' if you want to remove all text properties. */)
copy_properties (unchanged, i);
remove_properties (properties, Qnil, i, object);
if (BUFFERP (object))
- signal_after_change (XINT (start), XINT (end) - XINT (start),
- XINT (end) - XINT (start));
+ signal_after_change (XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start),
+ XFIXNUM (end) - XFIXNUM (start));
return Qt;
}
@@ -1643,8 +1619,8 @@ Return t if any property was actually removed, nil otherwise. */)
if (!i)
return Qnil;
- s = XINT (start);
- len = XINT (end) - s;
+ s = XFIXNUM (start);
+ len = XFIXNUM (end) - s;
/* If there are no properties on the interval, return. */
if (! interval_has_some_properties_list (properties, i))
@@ -1687,9 +1663,9 @@ Return t if any property was actually removed, nil otherwise. */)
if (modified)
{
if (BUFFERP (object))
- signal_after_change (XINT (start),
- XINT (end) - XINT (start),
- XINT (end) - XINT (start));
+ signal_after_change (XFIXNUM (start),
+ XFIXNUM (end) - XFIXNUM (start),
+ XFIXNUM (end) - XFIXNUM (start));
return Qt;
}
else
@@ -1701,8 +1677,8 @@ Return t if any property was actually removed, nil otherwise. */)
modify_text_properties (object, start, end);
remove_properties (Qnil, properties, i, object);
if (BUFFERP (object))
- signal_after_change (XINT (start), XINT (end) - XINT (start),
- XINT (end) - XINT (start));
+ signal_after_change (XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start),
+ XFIXNUM (end) - XFIXNUM (start));
return Qt;
}
else
@@ -1714,8 +1690,8 @@ Return t if any property was actually removed, nil otherwise. */)
modify_text_properties (object, start, end);
remove_properties (Qnil, properties, i, object);
if (BUFFERP (object))
- signal_after_change (XINT (start), XINT (end) - XINT (start),
- XINT (end) - XINT (start));
+ signal_after_change (XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start),
+ XFIXNUM (end) - XFIXNUM (start));
return Qt;
}
}
@@ -1733,9 +1709,9 @@ Return t if any property was actually removed, nil otherwise. */)
if (modified)
{
if (BUFFERP (object))
- signal_after_change (XINT (start),
- XINT (end) - XINT (start),
- XINT (end) - XINT (start));
+ signal_after_change (XFIXNUM (start),
+ XFIXNUM (end) - XFIXNUM (start),
+ XFIXNUM (end) - XFIXNUM (start));
return Qt;
}
else
@@ -1762,7 +1738,7 @@ markers). If OBJECT is a string, START and END are 0-based indices into it. */
i = validate_interval_range (object, &start, &end, soft);
if (!i)
return (!NILP (value) || EQ (start, end) ? Qnil : start);
- e = XINT (end);
+ e = XFIXNUM (end);
while (i)
{
@@ -1771,9 +1747,9 @@ markers). If OBJECT is a string, START and END are 0-based indices into it. */
if (EQ (textget (i->plist, property), value))
{
pos = i->position;
- if (pos < XINT (start))
- pos = XINT (start);
- return make_number (pos);
+ if (pos < XFIXNUM (start))
+ pos = XFIXNUM (start);
+ return make_fixnum (pos);
}
i = next_interval (i);
}
@@ -1798,8 +1774,8 @@ markers). If OBJECT is a string, START and END are 0-based indices into it. */
i = validate_interval_range (object, &start, &end, soft);
if (!i)
return (NILP (value) || EQ (start, end)) ? Qnil : start;
- s = XINT (start);
- e = XINT (end);
+ s = XFIXNUM (start);
+ e = XFIXNUM (end);
while (i)
{
@@ -1809,7 +1785,7 @@ markers). If OBJECT is a string, START and END are 0-based indices into it. */
{
if (i->position > s)
s = i->position;
- return make_number (s);
+ return make_fixnum (s);
}
i = next_interval (i);
}
@@ -1827,7 +1803,7 @@ int
text_property_stickiness (Lisp_Object prop, Lisp_Object pos, Lisp_Object buffer)
{
bool ignore_previous_character;
- Lisp_Object prev_pos = make_number (XINT (pos) - 1);
+ Lisp_Object prev_pos = make_fixnum (XFIXNUM (pos) - 1);
Lisp_Object front_sticky;
bool is_rear_sticky = true, is_front_sticky = false; /* defaults */
Lisp_Object defalt = Fassq (prop, Vtext_property_default_nonsticky);
@@ -1835,7 +1811,7 @@ text_property_stickiness (Lisp_Object prop, Lisp_Object pos, Lisp_Object buffer)
if (NILP (buffer))
XSETBUFFER (buffer, current_buffer);
- ignore_previous_character = XINT (pos) <= BUF_BEGV (XBUFFER (buffer));
+ ignore_previous_character = XFIXNUM (pos) <= BUF_BEGV (XBUFFER (buffer));
if (ignore_previous_character || (CONSP (defalt) && !NILP (XCDR (defalt))))
is_rear_sticky = false;
@@ -1896,45 +1872,30 @@ Lisp_Object
copy_text_properties (Lisp_Object start, Lisp_Object end, Lisp_Object src,
Lisp_Object pos, Lisp_Object dest, Lisp_Object prop)
{
- INTERVAL i;
- Lisp_Object res;
- Lisp_Object stuff;
- Lisp_Object plist;
- ptrdiff_t s, e, e2, p, len;
- bool modified = false;
-
- i = validate_interval_range (src, &start, &end, soft);
+ INTERVAL i = validate_interval_range (src, &start, &end, soft);
if (!i)
return Qnil;
- CHECK_NUMBER_COERCE_MARKER (pos);
- {
- Lisp_Object dest_start, dest_end;
+ CHECK_FIXNUM_COERCE_MARKER (pos);
- e = XINT (pos) + (XINT (end) - XINT (start));
- if (MOST_POSITIVE_FIXNUM < e)
- args_out_of_range (pos, end);
- dest_start = pos;
- XSETFASTINT (dest_end, e);
- /* Apply this to a copy of pos; it will try to increment its arguments,
- which we don't want. */
- validate_interval_range (dest, &dest_start, &dest_end, soft);
- }
+ EMACS_INT dest_e = XFIXNUM (pos) + (XFIXNUM (end) - XFIXNUM (start));
+ if (MOST_POSITIVE_FIXNUM < dest_e)
+ args_out_of_range (pos, end);
+ Lisp_Object dest_end = make_fixnum (dest_e);
+ validate_interval_range (dest, &pos, &dest_end, soft);
- s = XINT (start);
- e = XINT (end);
- p = XINT (pos);
+ ptrdiff_t s = XFIXNUM (start), e = XFIXNUM (end), p = XFIXNUM (pos);
- stuff = Qnil;
+ Lisp_Object stuff = Qnil;
while (s < e)
{
- e2 = i->position + LENGTH (i);
+ ptrdiff_t e2 = i->position + LENGTH (i);
if (e2 > e)
e2 = e;
- len = e2 - s;
+ ptrdiff_t len = e2 - s;
- plist = i->plist;
+ Lisp_Object plist = i->plist;
if (! NILP (prop))
while (! NILP (plist))
{
@@ -1948,7 +1909,7 @@ copy_text_properties (Lisp_Object start, Lisp_Object end, Lisp_Object src,
if (! NILP (plist))
/* Must defer modifications to the interval tree in case
src and dest refer to the same string or buffer. */
- stuff = Fcons (list3 (make_number (p), make_number (p + len), plist),
+ stuff = Fcons (list3 (make_fixnum (p), make_fixnum (p + len), plist),
stuff);
i = next_interval (i);
@@ -1959,9 +1920,11 @@ copy_text_properties (Lisp_Object start, Lisp_Object end, Lisp_Object src,
s = i->position;
}
+ bool modified = false;
+
while (! NILP (stuff))
{
- res = Fcar (stuff);
+ Lisp_Object res = Fcar (stuff);
res = Fadd_text_properties (Fcar (res), Fcar (Fcdr (res)),
Fcar (Fcdr (Fcdr (res))), dest);
if (! NILP (res))
@@ -1991,8 +1954,8 @@ text_property_list (Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp
i = validate_interval_range (object, &start, &end, soft);
if (i)
{
- ptrdiff_t s = XINT (start);
- ptrdiff_t e = XINT (end);
+ ptrdiff_t s = XFIXNUM (start);
+ ptrdiff_t e = XFIXNUM (end);
while (s < e)
{
@@ -2015,7 +1978,7 @@ text_property_list (Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp
}
if (!NILP (plist))
- result = Fcons (list3 (make_number (s), make_number (s + len),
+ result = Fcons (list3 (make_fixnum (s), make_fixnum (s + len),
plist),
result);
@@ -2043,8 +2006,8 @@ add_text_properties_from_list (Lisp_Object object, Lisp_Object list, Lisp_Object
Lisp_Object item, start, end, plist;
item = XCAR (list);
- start = make_number (XINT (XCAR (item)) + XINT (delta));
- end = make_number (XINT (XCAR (XCDR (item))) + XINT (delta));
+ start = make_fixnum (XFIXNUM (XCAR (item)) + XFIXNUM (delta));
+ end = make_fixnum (XFIXNUM (XCAR (XCDR (item))) + XFIXNUM (delta));
plist = XCAR (XCDR (XCDR (item)));
Fadd_text_properties (start, end, plist, object);
@@ -2062,7 +2025,7 @@ Lisp_Object
extend_property_ranges (Lisp_Object list, Lisp_Object old_end, Lisp_Object new_end)
{
Lisp_Object prev = Qnil, head = list;
- ptrdiff_t max = XINT (new_end);
+ ptrdiff_t max = XFIXNUM (new_end);
for (; CONSP (list); prev = list, list = XCDR (list))
{
@@ -2071,9 +2034,9 @@ extend_property_ranges (Lisp_Object list, Lisp_Object old_end, Lisp_Object new_e
item = XCAR (list);
beg = XCAR (item);
- end = XINT (XCAR (XCDR (item)));
+ end = XFIXNUM (XCAR (XCDR (item)));
- if (XINT (beg) >= max)
+ if (XFIXNUM (beg) >= max)
{
/* The start-point is past the end of the new string.
Discard this property. */
@@ -2082,7 +2045,7 @@ extend_property_ranges (Lisp_Object list, Lisp_Object old_end, Lisp_Object new_e
else
XSETCDR (prev, XCDR (list));
}
- else if ((end == XINT (old_end) && end != max)
+ else if ((end == XFIXNUM (old_end) && end != max)
|| end > max)
{
/* Either the end-point is past the end of the new string,
@@ -2285,10 +2248,10 @@ verify_interval_modification (struct buffer *buf,
if (!inhibit_modification_hooks)
{
hooks = Fnreverse (hooks);
- while (! EQ (hooks, Qnil))
+ while (! NILP (hooks))
{
- call_mod_hooks (Fcar (hooks), make_number (start),
- make_number (end));
+ call_mod_hooks (Fcar (hooks), make_fixnum (start),
+ make_fixnum (end));
hooks = Fcdr (hooks);
}
}
@@ -2356,11 +2319,10 @@ inherits it if NONSTICKINESS is nil. The `front-sticky' and
Vtext_property_default_nonsticky
= list2 (Fcons (Qsyntax_table, Qt), Fcons (Qdisplay, Qt));
- staticpro (&interval_insert_behind_hooks);
- staticpro (&interval_insert_in_front_hooks);
interval_insert_behind_hooks = Qnil;
interval_insert_in_front_hooks = Qnil;
-
+ staticpro (&interval_insert_behind_hooks);
+ staticpro (&interval_insert_in_front_hooks);
/* Common attributes one might give text. */
diff --git a/src/thread.c b/src/thread.c
index 0cd1ae33dc2..670680f2b0d 100644
--- a/src/thread.c
+++ b/src/thread.c
@@ -25,16 +25,24 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "process.h"
#include "coding.h"
#include "syssignal.h"
+#include "pdumper.h"
+#include "keyboard.h"
-static struct thread_state main_thread;
+union aligned_thread_state
+{
+ struct thread_state s;
+ GCALIGNED_UNION_MEMBER
+};
+verify (GCALIGNED (union aligned_thread_state));
+
+static union aligned_thread_state main_thread;
-struct thread_state *current_thread = &main_thread;
+struct thread_state *current_thread = &main_thread.s;
-static struct thread_state *all_threads = &main_thread;
+static struct thread_state *all_threads = &main_thread.s;
static sys_mutex_t global_lock;
-extern int poll_suppress_count;
extern volatile int interrupt_input_blocked;
@@ -113,7 +121,7 @@ maybe_reacquire_global_lock (void)
/* SIGINT handler is always run on the main thread, see
deliver_process_signal, so reflect that in our thread-tracking
variables. */
- current_thread = &main_thread;
+ current_thread = &main_thread.s;
if (current_thread->not_holding_lock)
{
@@ -259,7 +267,7 @@ informational only. */)
if (!NILP (name))
CHECK_STRING (name);
- mutex = ALLOCATE_PSEUDOVECTOR (struct Lisp_Mutex, mutex, PVEC_MUTEX);
+ mutex = ALLOCATE_PSEUDOVECTOR (struct Lisp_Mutex, name, PVEC_MUTEX);
memset ((char *) mutex + offsetof (struct Lisp_Mutex, mutex),
0, sizeof (struct Lisp_Mutex) - offsetof (struct Lisp_Mutex,
mutex));
@@ -378,7 +386,7 @@ informational only. */)
if (!NILP (name))
CHECK_STRING (name);
- condvar = ALLOCATE_PSEUDOVECTOR (struct Lisp_CondVar, cond, PVEC_CONDVAR);
+ condvar = ALLOCATE_PSEUDOVECTOR (struct Lisp_CondVar, name, PVEC_CONDVAR);
memset ((char *) condvar + offsetof (struct Lisp_CondVar, cond),
0, sizeof (struct Lisp_CondVar) - offsetof (struct Lisp_CondVar,
cond));
@@ -609,7 +617,7 @@ static void
mark_one_thread (struct thread_state *thread)
{
/* Get the stack top now, in case mark_specpdl changes it. */
- void *stack_top = thread->stack_top;
+ void const *stack_top = thread->stack_top;
mark_specpdl (thread->m_specpdl, thread->m_specpdl_ptr);
@@ -656,6 +664,12 @@ mark_threads (void)
flush_stack_call_func (mark_threads_callback, NULL);
}
+void
+unmark_main_thread (void)
+{
+ main_thread.s.header.size &= ~ARRAY_MARK_FLAG;
+}
+
static void
@@ -681,7 +695,7 @@ invoke_thread_function (void)
{
ptrdiff_t count = SPECPDL_INDEX ();
- Ffuncall (1, &current_thread->function);
+ current_thread->result = Ffuncall (1, &current_thread->function);
return unbind_to (count, Qnil);
}
@@ -754,9 +768,21 @@ run_thread (void *state)
return NULL;
}
+static void
+free_search_regs (struct re_registers *regs)
+{
+ if (regs->num_regs != 0)
+ {
+ xfree (regs->start);
+ xfree (regs->end);
+ }
+}
+
void
finalize_one_thread (struct thread_state *state)
{
+ free_search_regs (&state->m_search_regs);
+ free_search_regs (&state->m_saved_search_regs);
sys_cond_destroy (&state->thread_condvar);
}
@@ -779,7 +805,7 @@ If NAME is given, it must be a string; it names the new thread. */)
if (!NILP (name))
CHECK_STRING (name);
- new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_stack_bottom,
+ new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, event_object,
PVEC_THREAD);
memset ((char *) new_thread + offset, 0,
sizeof (struct thread_state) - offset);
@@ -789,6 +815,7 @@ If NAME is given, it must be a string; it names the new thread. */)
new_thread->m_last_thing_searched = Qnil; /* copy from parent? */
new_thread->m_saved_last_thing_searched = Qnil;
new_thread->m_current_buffer = current_thread->m_current_buffer;
+ new_thread->result = Qnil;
new_thread->error_symbol = Qnil;
new_thread->error_data = Qnil;
new_thread->event_object = Qnil;
@@ -862,7 +889,8 @@ DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0,
This acts like `signal', but arranges for the signal to be raised
in THREAD. If THREAD is the current thread, acts just like `signal'.
This will interrupt a blocked call to `mutex-lock', `condition-wait',
-or `thread-join' in the target thread. */)
+or `thread-join' in the target thread.
+If THREAD is the main thread, just the error message is shown. */)
(Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data)
{
struct thread_state *tstate;
@@ -873,13 +901,31 @@ or `thread-join' in the target thread. */)
if (tstate == current_thread)
Fsignal (error_symbol, data);
- /* What to do if thread is already signaled? */
- /* What if error_symbol is Qnil? */
- tstate->error_symbol = error_symbol;
- tstate->error_data = data;
+#ifdef THREADS_ENABLED
+ if (main_thread_p (tstate))
+ {
+ /* Construct an event. */
+ struct input_event event;
+ EVENT_INIT (event);
+ event.kind = THREAD_EVENT;
+ event.frame_or_window = Qnil;
+ event.arg = list3 (Fcurrent_thread (), error_symbol, data);
+
+ /* Store it into the input event queue. */
+ kbd_buffer_store_event (&event);
+ }
+
+ else
+#endif
+ {
+ /* What to do if thread is already signaled? */
+ /* What if error_symbol is Qnil? */
+ tstate->error_symbol = error_symbol;
+ tstate->error_data = data;
- if (tstate->wait_condvar)
- flush_stack_call_func (thread_signal_callback, tstate);
+ if (tstate->wait_condvar)
+ flush_stack_call_func (thread_signal_callback, tstate);
+ }
return Qnil;
}
@@ -933,12 +979,13 @@ thread_join_callback (void *arg)
DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0,
doc: /* Wait for THREAD to exit.
-This blocks the current thread until THREAD exits or until
-the current thread is signaled.
-It is an error for a thread to try to join itself. */)
+This blocks the current thread until THREAD exits or until the current
+thread is signaled. It returns the result of the THREAD function. It
+is an error for a thread to try to join itself. */)
(Lisp_Object thread)
{
struct thread_state *tstate;
+ Lisp_Object error_symbol, error_data;
CHECK_THREAD (thread);
tstate = XTHREAD (thread);
@@ -946,10 +993,16 @@ It is an error for a thread to try to join itself. */)
if (tstate == current_thread)
error ("Cannot join current thread");
+ error_symbol = tstate->error_symbol;
+ error_data = tstate->error_data;
+
if (thread_live_p (tstate))
flush_stack_call_func (thread_join_callback, tstate);
- return Qnil;
+ if (!NILP (error_symbol))
+ Fsignal (error_symbol, error_data);
+
+ return tstate->result;
}
DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0,
@@ -973,11 +1026,17 @@ DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0,
return result;
}
-DEFUN ("thread-last-error", Fthread_last_error, Sthread_last_error, 0, 0, 0,
- doc: /* Return the last error form recorded by a dying thread. */)
- (void)
+DEFUN ("thread-last-error", Fthread_last_error, Sthread_last_error, 0, 1, 0,
+ doc: /* Return the last error form recorded by a dying thread.
+If CLEANUP is non-nil, remove this error form from history. */)
+ (Lisp_Object cleanup)
{
- return last_thread_error;
+ Lisp_Object result = last_thread_error;
+
+ if (!NILP (cleanup))
+ last_thread_error = Qnil;
+
+ return result;
}
@@ -1004,22 +1063,31 @@ thread_check_current_buffer (struct buffer *buffer)
static void
init_main_thread (void)
{
- main_thread.header.size
- = PSEUDOVECSIZE (struct thread_state, m_stack_bottom);
- XSETPVECTYPE (&main_thread, PVEC_THREAD);
- main_thread.m_last_thing_searched = Qnil;
- main_thread.m_saved_last_thing_searched = Qnil;
- main_thread.name = Qnil;
- main_thread.function = Qnil;
- main_thread.error_symbol = Qnil;
- main_thread.error_data = Qnil;
- main_thread.event_object = Qnil;
+ main_thread.s.header.size
+ = PSEUDOVECSIZE (struct thread_state, event_object);
+ XSETPVECTYPE (&main_thread.s, PVEC_THREAD);
+ main_thread.s.m_last_thing_searched = Qnil;
+ main_thread.s.m_saved_last_thing_searched = Qnil;
+ main_thread.s.name = Qnil;
+ main_thread.s.function = Qnil;
+ main_thread.s.result = Qnil;
+ main_thread.s.error_symbol = Qnil;
+ main_thread.s.error_data = Qnil;
+ main_thread.s.event_object = Qnil;
+}
+
+bool
+main_thread_p (const void *ptr)
+{
+ return ptr == &main_thread.s;
}
bool
-main_thread_p (void *ptr)
+in_current_thread (void)
{
- return ptr == &main_thread;
+ if (current_thread == NULL)
+ return false;
+ return sys_thread_equal (sys_thread_self (), current_thread->thread_id);
}
void
@@ -1032,11 +1100,11 @@ void
init_threads (void)
{
init_main_thread ();
- sys_cond_init (&main_thread.thread_condvar);
+ sys_cond_init (&main_thread.s.thread_condvar);
sys_mutex_init (&global_lock);
sys_mutex_lock (&global_lock);
- current_thread = &main_thread;
- main_thread.thread_id = sys_thread_self ();
+ current_thread = &main_thread.s;
+ main_thread.s.thread_id = sys_thread_self ();
}
void
@@ -1078,4 +1146,12 @@ syms_of_threads (void)
DEFSYM (Qthreadp, "threadp");
DEFSYM (Qmutexp, "mutexp");
DEFSYM (Qcondition_variable_p, "condition-variable-p");
+
+ DEFVAR_LISP ("main-thread", Vmain_thread,
+ doc: /* The main thread of Emacs. */);
+#ifdef THREADS_ENABLED
+ XSETTHREAD (Vmain_thread, &main_thread.s);
+#else
+ Vmain_thread = Qnil;
+#endif
}
diff --git a/src/thread.h b/src/thread.h
index 8877f22ffa5..0514669a87d 100644
--- a/src/thread.h
+++ b/src/thread.h
@@ -19,7 +19,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifndef THREAD_H
#define THREAD_H
-#include "regex.h"
+#include "regex-emacs.h"
#ifdef WINDOWSNT
#include <sys/socket.h>
@@ -30,7 +30,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#endif
#include "sysselect.h" /* FIXME */
-#include "systime.h" /* FIXME */
#include "systhread.h"
struct thread_state
@@ -52,6 +51,9 @@ struct thread_state
/* The thread's function. */
Lisp_Object function;
+ /* The thread's result, if function has finished. */
+ Lisp_Object result;
+
/* If non-nil, this thread has been signaled. */
Lisp_Object error_symbol;
Lisp_Object error_data;
@@ -59,11 +61,11 @@ struct thread_state
/* If we are waiting for some event, this holds the object we are
waiting on. */
Lisp_Object event_object;
+ /* event_object must be the last Lisp field. */
- /* m_stack_bottom must be the first non-Lisp field. */
/* An address near the bottom of the stack.
Tells GC how to save a copy of the stack. */
- char *m_stack_bottom;
+ char const *m_stack_bottom;
#define stack_bottom (current_thread->m_stack_bottom)
/* The address of an object near the C stack top, used to determine
@@ -73,7 +75,7 @@ struct thread_state
error in Emacs. If the C function F calls G which calls H which
calls ... F, then at least one of the functions in the chain
should set this to the address of a local variable. */
- void *stack_top;
+ void const *stack_top;
struct catchtag *m_catchlist;
#define catchlist (current_thread->m_catchlist)
@@ -102,15 +104,15 @@ struct thread_state
#define specpdl_ptr (current_thread->m_specpdl_ptr)
/* Depth in Lisp evaluations and function calls. */
- EMACS_INT m_lisp_eval_depth;
+ intmax_t m_lisp_eval_depth;
#define lisp_eval_depth (current_thread->m_lisp_eval_depth)
/* This points to the current buffer. */
struct buffer *m_current_buffer;
#define current_buffer (current_thread->m_current_buffer)
- /* Every call to re_match, etc., must pass &search_regs as the regs
- argument unless you can show it is unnecessary (i.e., if re_match
+ /* Every call to re_search, etc., must pass &search_regs as the regs
+ argument unless you can show it is unnecessary (i.e., if re_search
is certainly going to be called again before region-around-match
can be called).
@@ -129,23 +131,9 @@ struct thread_state
struct re_registers m_search_regs;
#define search_regs (current_thread->m_search_regs)
- /* If non-zero the match data have been saved in saved_search_regs
- during the execution of a sentinel or filter. */
- bool m_search_regs_saved;
-#define search_regs_saved (current_thread->m_search_regs_saved)
-
struct re_registers m_saved_search_regs;
#define saved_search_regs (current_thread->m_saved_search_regs)
- /* This is the string or buffer in which we
- are matching. It is used for looking up syntax properties.
-
- If the value is a Lisp string object, we are matching text in that
- string; if it's nil, we are matching text in the current buffer; if
- it's t, we are matching text in a C string. */
- Lisp_Object m_re_match_object;
-#define re_match_object (current_thread->m_re_match_object)
-
/* This member is different from waiting_for_input.
It is used to communicate to a lisp process-filter/sentinel (via the
function Fwaiting_for_user_input_p) whether Emacs was waiting
@@ -190,7 +178,7 @@ struct thread_state
/* Threads are kept on a linked list. */
struct thread_state *next_thread;
-};
+} GCALIGNED_STRUCT;
INLINE bool
THREADP (Lisp_Object a)
@@ -208,7 +196,7 @@ INLINE struct thread_state *
XTHREAD (Lisp_Object a)
{
eassert (THREADP (a));
- return XUNTAG (a, Lisp_Vectorlike);
+ return XUNTAG (a, Lisp_Vectorlike, struct thread_state);
}
/* A mutex in lisp is represented by a system condition variable.
@@ -237,7 +225,7 @@ struct Lisp_Mutex
/* The lower-level mutex object. */
lisp_mutex_t mutex;
-};
+} GCALIGNED_STRUCT;
INLINE bool
MUTEXP (Lisp_Object a)
@@ -255,7 +243,7 @@ INLINE struct Lisp_Mutex *
XMUTEX (Lisp_Object a)
{
eassert (MUTEXP (a));
- return XUNTAG (a, Lisp_Vectorlike);
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Mutex);
}
/* A condition variable as a lisp object. */
@@ -271,7 +259,7 @@ struct Lisp_CondVar
/* The lower-level condition variable object. */
sys_cond_t cond;
-};
+} GCALIGNED_STRUCT;
INLINE bool
CONDVARP (Lisp_Object a)
@@ -289,7 +277,7 @@ INLINE struct Lisp_CondVar *
XCONDVAR (Lisp_Object a)
{
eassert (CONDVARP (a));
- return XUNTAG (a, Lisp_Vectorlike);
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_CondVar);
}
extern struct thread_state *current_thread;
@@ -302,7 +290,8 @@ extern void maybe_reacquire_global_lock (void);
extern void init_threads_once (void);
extern void init_threads (void);
extern void syms_of_threads (void);
-extern bool main_thread_p (void *);
+extern bool main_thread_p (const void *);
+extern bool in_current_thread (void);
typedef int select_func (int, fd_set *, fd_set *, fd_set *,
const struct timespec *, const sigset_t *);
diff --git a/src/timefns.c b/src/timefns.c
new file mode 100644
index 00000000000..514fa24f8b9
--- /dev/null
+++ b/src/timefns.c
@@ -0,0 +1,1781 @@
+/* Timestamp functions for Emacs
+
+Copyright (C) 1985-1987, 1989, 1993-2019 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#include "systime.h"
+
+#include "blockinput.h"
+#include "bignum.h"
+#include "coding.h"
+#include "lisp.h"
+#include "pdumper.h"
+
+#include <strftime.h>
+
+#include <errno.h>
+#include <limits.h>
+#include <math.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+#ifdef HAVE_TIMEZONE_T
+# include <sys/param.h>
+# if defined __NetBSD_Version__ && __NetBSD_Version__ < 700000000
+# define HAVE_TZALLOC_BUG true
+# endif
+#endif
+#ifndef HAVE_TZALLOC_BUG
+# define HAVE_TZALLOC_BUG false
+#endif
+
+enum { TM_YEAR_BASE = 1900 };
+
+#ifndef HAVE_TM_GMTOFF
+# define HAVE_TM_GMTOFF false
+#endif
+
+#ifndef TIME_T_MIN
+# define TIME_T_MIN TYPE_MINIMUM (time_t)
+#endif
+#ifndef TIME_T_MAX
+# define TIME_T_MAX TYPE_MAXIMUM (time_t)
+#endif
+
+/* Compile with -DFASTER_TIMEFNS=0 to disable common optimizations and
+ allow easier testing of some slow-path code. */
+#ifndef FASTER_TIMEFNS
+# define FASTER_TIMEFNS 1
+#endif
+
+/* Whether to warn about Lisp timestamps (TICKS . HZ) that may be
+ instances of obsolete-format timestamps (HI . LO) where HI is
+ the high-order bits and LO the low-order 16 bits. Currently this
+ is true, but it should change to false in a future version of
+ Emacs. Compile with -DWARN_OBSOLETE_TIMESTAMPS=0 to see what the
+ future will be like. */
+#ifndef WARN_OBSOLETE_TIMESTAMPS
+enum { WARN_OBSOLETE_TIMESTAMPS = true };
+#endif
+
+/* Although current-time etc. generate list-format timestamps
+ (HI LO US PS), the plan is to change these functions to generate
+ frequency-based timestamps (TICKS . HZ) in a future release.
+ To try this now, compile with -DCURRENT_TIME_LIST=0. */
+#ifndef CURRENT_TIME_LIST
+enum { CURRENT_TIME_LIST = true };
+#endif
+
+#if FIXNUM_OVERFLOW_P (1000000000)
+static Lisp_Object timespec_hz;
+#else
+# define timespec_hz make_fixnum (TIMESPEC_HZ)
+#endif
+
+#define TRILLION 1000000000000
+#if FIXNUM_OVERFLOW_P (TRILLION)
+static Lisp_Object trillion;
+# define ztrillion (XBIGNUM (trillion)->value)
+#else
+# define trillion make_fixnum (TRILLION)
+# if ULONG_MAX < TRILLION || !FASTER_TIMEFNS
+mpz_t ztrillion;
+# endif
+#endif
+
+/* Return a struct timeval that is roughly equivalent to T.
+ Use the least timeval not less than T.
+ Return an extremal value if the result would overflow. */
+struct timeval
+make_timeval (struct timespec t)
+{
+ struct timeval tv;
+ tv.tv_sec = t.tv_sec;
+ tv.tv_usec = t.tv_nsec / 1000;
+
+ if (t.tv_nsec % 1000 != 0)
+ {
+ if (tv.tv_usec < 999999)
+ tv.tv_usec++;
+ else if (tv.tv_sec < TIME_T_MAX)
+ {
+ tv.tv_sec++;
+ tv.tv_usec = 0;
+ }
+ }
+
+ return tv;
+}
+
+/* Yield A's UTC offset, or an unspecified value if unknown. */
+static long int
+tm_gmtoff (struct tm *a)
+{
+#if HAVE_TM_GMTOFF
+ return a->tm_gmtoff;
+#else
+ return 0;
+#endif
+}
+
+/* Yield A - B, measured in seconds.
+ This function is copied from the GNU C Library. */
+static int
+tm_diff (struct tm *a, struct tm *b)
+{
+ /* Compute intervening leap days correctly even if year is negative.
+ Take care to avoid int overflow in leap day calculations,
+ but it's OK to assume that A and B are close to each other. */
+ int a4 = (a->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (a->tm_year & 3);
+ int b4 = (b->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (b->tm_year & 3);
+ int a100 = a4 / 25 - (a4 % 25 < 0);
+ int b100 = b4 / 25 - (b4 % 25 < 0);
+ int a400 = a100 >> 2;
+ int b400 = b100 >> 2;
+ int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400);
+ int years = a->tm_year - b->tm_year;
+ int days = (365 * years + intervening_leap_days
+ + (a->tm_yday - b->tm_yday));
+ return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour))
+ + (a->tm_min - b->tm_min))
+ + (a->tm_sec - b->tm_sec));
+}
+
+enum { tzeqlen = sizeof "TZ=" - 1 };
+
+/* Time zones equivalent to current local time and to UTC, respectively. */
+static timezone_t local_tz;
+static timezone_t const utc_tz = 0;
+
+static struct tm *
+emacs_localtime_rz (timezone_t tz, time_t const *t, struct tm *tm)
+{
+ tm = localtime_rz (tz, t, tm);
+ if (!tm && errno == ENOMEM)
+ memory_full (SIZE_MAX);
+ return tm;
+}
+
+static _Noreturn void
+invalid_time_zone_specification (Lisp_Object zone)
+{
+ xsignal2 (Qerror, build_string ("Invalid time zone specification"), zone);
+}
+
+/* Free a timezone, except do not free the time zone for local time.
+ Freeing utc_tz is also a no-op. */
+static void
+xtzfree (timezone_t tz)
+{
+ if (tz != local_tz)
+ tzfree (tz);
+}
+
+/* Convert the Lisp time zone rule ZONE to a timezone_t object.
+ The returned value either is 0, or is LOCAL_TZ, or is newly allocated.
+ If SETTZ, set Emacs local time to the time zone rule; otherwise,
+ the caller should eventually pass the returned value to xtzfree. */
+static timezone_t
+tzlookup (Lisp_Object zone, bool settz)
+{
+ static char const tzbuf_format[] = "<%+.*"pI"d>%s%"pI"d:%02d:%02d";
+ char const *trailing_tzbuf_format = tzbuf_format + sizeof "<%+.*"pI"d" - 1;
+ char tzbuf[sizeof tzbuf_format + 2 * INT_STRLEN_BOUND (EMACS_INT)];
+ char const *zone_string;
+ timezone_t new_tz;
+
+ if (NILP (zone))
+ return local_tz;
+ else if (EQ (zone, Qt) || EQ (zone, make_fixnum (0)))
+ {
+ zone_string = "UTC0";
+ new_tz = utc_tz;
+ }
+ else
+ {
+ bool plain_integer = FIXNUMP (zone);
+
+ if (EQ (zone, Qwall))
+ zone_string = 0;
+ else if (STRINGP (zone))
+ zone_string = SSDATA (ENCODE_SYSTEM (zone));
+ else if (plain_integer || (CONSP (zone) && FIXNUMP (XCAR (zone))
+ && CONSP (XCDR (zone))))
+ {
+ Lisp_Object abbr UNINIT;
+ if (!plain_integer)
+ {
+ abbr = XCAR (XCDR (zone));
+ zone = XCAR (zone);
+ }
+
+ EMACS_INT abszone = eabs (XFIXNUM (zone)), hour = abszone / (60 * 60);
+ int hour_remainder = abszone % (60 * 60);
+ int min = hour_remainder / 60, sec = hour_remainder % 60;
+
+ if (plain_integer)
+ {
+ int prec = 2;
+ EMACS_INT numzone = hour;
+ if (hour_remainder != 0)
+ {
+ prec += 2, numzone = 100 * numzone + min;
+ if (sec != 0)
+ prec += 2, numzone = 100 * numzone + sec;
+ }
+ sprintf (tzbuf, tzbuf_format, prec,
+ XFIXNUM (zone) < 0 ? -numzone : numzone,
+ &"-"[XFIXNUM (zone) < 0], hour, min, sec);
+ zone_string = tzbuf;
+ }
+ else
+ {
+ AUTO_STRING (leading, "<");
+ AUTO_STRING_WITH_LEN (trailing, tzbuf,
+ sprintf (tzbuf, trailing_tzbuf_format,
+ &"-"[XFIXNUM (zone) < 0],
+ hour, min, sec));
+ zone_string = SSDATA (concat3 (leading, ENCODE_SYSTEM (abbr),
+ trailing));
+ }
+ }
+ else
+ invalid_time_zone_specification (zone);
+
+ new_tz = tzalloc (zone_string);
+
+ if (HAVE_TZALLOC_BUG && !new_tz && errno != ENOMEM && plain_integer
+ && XFIXNUM (zone) % (60 * 60) == 0)
+ {
+ /* tzalloc mishandles POSIX strings; fall back on tzdb if
+ possible (Bug#30738). */
+ sprintf (tzbuf, "Etc/GMT%+"pI"d", - (XFIXNUM (zone) / (60 * 60)));
+ new_tz = tzalloc (zone_string);
+ }
+
+ if (!new_tz)
+ {
+ if (errno == ENOMEM)
+ memory_full (SIZE_MAX);
+ invalid_time_zone_specification (zone);
+ }
+ }
+
+ if (settz)
+ {
+ block_input ();
+ emacs_setenv_TZ (zone_string);
+ tzset ();
+ timezone_t old_tz = local_tz;
+ local_tz = new_tz;
+ tzfree (old_tz);
+ unblock_input ();
+ }
+
+ return new_tz;
+}
+
+void
+init_timefns (void)
+{
+#ifdef HAVE_UNEXEC
+ /* A valid but unlikely setting for the TZ environment variable.
+ It is OK (though a bit slower) if the user chooses this value. */
+ static char dump_tz_string[] = "TZ=UtC0";
+
+ /* When just dumping out, set the time zone to a known unlikely value
+ and skip the rest of this function. */
+ if (will_dump_with_unexec_p ())
+ {
+ xputenv (dump_tz_string);
+ tzset ();
+ return;
+ }
+#endif
+
+ char *tz = getenv ("TZ");
+
+#ifdef HAVE_UNEXEC
+ /* If the execution TZ happens to be the same as the dump TZ,
+ change it to some other value and then change it back,
+ to force the underlying implementation to reload the TZ info.
+ This is needed on implementations that load TZ info from files,
+ since the TZ file contents may differ between dump and execution. */
+ if (tz && strcmp (tz, &dump_tz_string[tzeqlen]) == 0)
+ {
+ ++*tz;
+ tzset ();
+ --*tz;
+ }
+#endif
+
+ /* Set the time zone rule now, so that the call to putenv is done
+ before multiple threads are active. */
+ tzlookup (tz ? build_string (tz) : Qwall, true);
+}
+
+/* Report that a time value is out of range for Emacs. */
+void
+time_overflow (void)
+{
+ error ("Specified time is not representable");
+}
+
+static _Noreturn void
+time_error (int err)
+{
+ switch (err)
+ {
+ case ENOMEM: memory_full (SIZE_MAX);
+ case EOVERFLOW: time_overflow ();
+ default: error ("Invalid time specification");
+ }
+}
+
+static _Noreturn void
+invalid_hz (Lisp_Object hz)
+{
+ xsignal2 (Qerror, build_string ("Invalid time frequency"), hz);
+}
+
+/* Return the upper part of the time T (everything but the bottom 16 bits). */
+static Lisp_Object
+hi_time (time_t t)
+{
+ return INT_TO_INTEGER (t >> LO_TIME_BITS);
+}
+
+/* Return the bottom bits of the time T. */
+static Lisp_Object
+lo_time (time_t t)
+{
+ return make_fixnum (t & ((1 << LO_TIME_BITS) - 1));
+}
+
+/* Convert T into an Emacs time *RESULT, truncating toward minus infinity.
+ Return zero if successful, an error number otherwise. */
+static int
+decode_float_time (double t, struct lisp_time *result)
+{
+ if (!isfinite (t))
+ return isnan (t) ? EINVAL : EOVERFLOW;
+ /* Actual hz unknown; guess TIMESPEC_HZ. */
+ mpz_set_d (mpz[1], t);
+ mpz_set_si (mpz[0], floor ((t - trunc (t)) * TIMESPEC_HZ));
+ mpz_addmul_ui (mpz[0], mpz[1], TIMESPEC_HZ);
+ result->ticks = make_integer_mpz ();
+ result->hz = timespec_hz;
+ return 0;
+}
+
+/* Compute S + NS/TIMESPEC_HZ as a double.
+ Calls to this function suffer from double-rounding;
+ work around some of the problem by using long double. */
+static double
+s_ns_to_double (long double s, long double ns)
+{
+ return s + ns / TIMESPEC_HZ;
+}
+
+/* Make a 4-element timestamp (HI LO US PS) from TICKS and HZ.
+ Drop any excess precision. */
+static Lisp_Object
+ticks_hz_list4 (Lisp_Object ticks, Lisp_Object hz)
+{
+ mpz_t *zticks = bignum_integer (&mpz[0], ticks);
+#if FASTER_TIMEFNS && TRILLION <= ULONG_MAX
+ mpz_mul_ui (mpz[0], *zticks, TRILLION);
+#else
+ mpz_mul (mpz[0], *zticks, ztrillion);
+#endif
+ mpz_fdiv_q (mpz[0], mpz[0], *bignum_integer (&mpz[1], hz));
+#if FASTER_TIMEFNS && TRILLION <= ULONG_MAX
+ unsigned long int fullps = mpz_fdiv_q_ui (mpz[0], mpz[0], TRILLION);
+ int us = fullps / 1000000;
+ int ps = fullps % 1000000;
+#else
+ mpz_fdiv_qr (mpz[0], mpz[1], mpz[0], ztrillion);
+ int ps = mpz_fdiv_q_ui (mpz[1], mpz[1], 1000000);
+ int us = mpz_get_ui (mpz[1]);
+#endif
+ unsigned long ulo = mpz_get_ui (mpz[0]);
+ if (mpz_sgn (mpz[0]) < 0)
+ ulo = -ulo;
+ int lo = ulo & ((1 << LO_TIME_BITS) - 1);
+ mpz_fdiv_q_2exp (mpz[0], mpz[0], LO_TIME_BITS);
+ return list4 (make_integer_mpz (), make_fixnum (lo),
+ make_fixnum (us), make_fixnum (ps));
+}
+
+/* Set ROP to T. */
+static void
+mpz_set_time (mpz_t rop, time_t t)
+{
+ if (EXPR_SIGNED (t))
+ mpz_set_intmax (rop, t);
+ else
+ mpz_set_uintmax (rop, t);
+}
+
+/* Store into mpz[0] a clock tick count for T, assuming a
+ TIMESPEC_HZ-frequency clock. Use mpz[1] as a temp. */
+static void
+timespec_mpz (struct timespec t)
+{
+ mpz_set_ui (mpz[0], t.tv_nsec);
+ mpz_set_time (mpz[1], t.tv_sec);
+ mpz_addmul_ui (mpz[0], mpz[1], TIMESPEC_HZ);
+}
+
+/* Convert T to a Lisp integer counting TIMESPEC_HZ ticks. */
+static Lisp_Object
+timespec_ticks (struct timespec t)
+{
+ intmax_t accum;
+ if (FASTER_TIMEFNS
+ && !INT_MULTIPLY_WRAPV (t.tv_sec, TIMESPEC_HZ, &accum)
+ && !INT_ADD_WRAPV (t.tv_nsec, accum, &accum))
+ return make_int (accum);
+ timespec_mpz (t);
+ return make_integer_mpz ();
+}
+
+/* Convert T to a Lisp integer counting HZ ticks, taking the floor.
+ Assume T is valid, but check HZ. */
+static Lisp_Object
+time_hz_ticks (time_t t, Lisp_Object hz)
+{
+ if (FIXNUMP (hz))
+ {
+ if (XFIXNUM (hz) <= 0)
+ invalid_hz (hz);
+ intmax_t ticks;
+ if (FASTER_TIMEFNS && !INT_MULTIPLY_WRAPV (t, XFIXNUM (hz), &ticks))
+ return make_int (ticks);
+ }
+ else if (! (BIGNUMP (hz) && 0 < mpz_sgn (XBIGNUM (hz)->value)))
+ invalid_hz (hz);
+
+ mpz_set_time (mpz[0], t);
+ mpz_mul (mpz[0], mpz[0], *bignum_integer (&mpz[1], hz));
+ return make_integer_mpz ();
+}
+static Lisp_Object
+lisp_time_hz_ticks (struct lisp_time t, Lisp_Object hz)
+{
+ if (FASTER_TIMEFNS && EQ (t.hz, hz))
+ return t.ticks;
+ if (FIXNUMP (hz))
+ {
+ if (XFIXNUM (hz) <= 0)
+ invalid_hz (hz);
+ intmax_t ticks;
+ if (FASTER_TIMEFNS && FIXNUMP (t.ticks) && FIXNUMP (t.hz)
+ && !INT_MULTIPLY_WRAPV (XFIXNUM (t.ticks), XFIXNUM (hz), &ticks))
+ return make_int (ticks / XFIXNUM (t.hz)
+ - (ticks % XFIXNUM (t.hz) < 0));
+ }
+ else if (! (BIGNUMP (hz) && 0 < mpz_sgn (XBIGNUM (hz)->value)))
+ invalid_hz (hz);
+
+ mpz_mul (mpz[0],
+ *bignum_integer (&mpz[0], t.ticks),
+ *bignum_integer (&mpz[1], hz));
+ mpz_fdiv_q (mpz[0], mpz[0], *bignum_integer (&mpz[1], t.hz));
+ return make_integer_mpz ();
+}
+
+/* Convert T to a Lisp integer counting seconds, taking the floor. */
+static Lisp_Object
+lisp_time_seconds (struct lisp_time t)
+{
+ if (!FASTER_TIMEFNS)
+ return lisp_time_hz_ticks (t, make_fixnum (1));
+ if (FIXNUMP (t.ticks) && FIXNUMP (t.hz))
+ return make_fixnum (XFIXNUM (t.ticks) / XFIXNUM (t.hz)
+ - (XFIXNUM (t.ticks) % XFIXNUM (t.hz) < 0));
+ mpz_fdiv_q (mpz[0],
+ *bignum_integer (&mpz[0], t.ticks),
+ *bignum_integer (&mpz[1], t.hz));
+ return make_integer_mpz ();
+}
+
+/* Convert T to a Lisp timestamp. */
+Lisp_Object
+make_lisp_time (struct timespec t)
+{
+ if (CURRENT_TIME_LIST)
+ {
+ time_t s = t.tv_sec;
+ int ns = t.tv_nsec;
+ return list4 (hi_time (s), lo_time (s),
+ make_fixnum (ns / 1000), make_fixnum (ns % 1000 * 1000));
+ }
+ else
+ return Fcons (timespec_ticks (t), timespec_hz);
+}
+
+/* Convert T to a Lisp timestamp. FORM specifies the timestamp format. */
+static Lisp_Object
+time_form_stamp (time_t t, Lisp_Object form)
+{
+ if (NILP (form))
+ form = CURRENT_TIME_LIST ? Qlist : Qt;
+ if (EQ (form, Qlist))
+ return list2 (hi_time (t), lo_time (t));
+ if (EQ (form, Qt) || EQ (form, Qinteger))
+ return INT_TO_INTEGER (t);
+ return Fcons (time_hz_ticks (t, form), form);
+}
+static Lisp_Object
+lisp_time_form_stamp (struct lisp_time t, Lisp_Object form)
+{
+ if (NILP (form))
+ form = CURRENT_TIME_LIST ? Qlist : Qt;
+ if (EQ (form, Qlist))
+ return ticks_hz_list4 (t.ticks, t.hz);
+ if (EQ (form, Qinteger))
+ return lisp_time_seconds (t);
+ if (EQ (form, Qt))
+ form = t.hz;
+ return Fcons (lisp_time_hz_ticks (t, form), form);
+}
+
+/* From what should be a valid timestamp (TICKS . HZ), generate the
+ corresponding time values.
+
+ If RESULT is not null, store into *RESULT the converted time.
+ Otherwise, store into *DRESULT the number of seconds since the
+ start of the POSIX Epoch. Unsuccessful calls may or may not store
+ results.
+
+ Return zero if successful, an error number if (TICKS . HZ) would not
+ be a valid new-format timestamp. */
+static int
+decode_ticks_hz (Lisp_Object ticks, Lisp_Object hz,
+ struct lisp_time *result, double *dresult)
+{
+ int ns;
+ mpz_t *q = &mpz[0];
+
+ if (! (INTEGERP (ticks)
+ && ((FIXNUMP (hz) && 0 < XFIXNUM (hz))
+ || (BIGNUMP (hz) && 0 < mpz_sgn (XBIGNUM (hz)->value)))))
+ return EINVAL;
+
+ if (result)
+ {
+ result->ticks = ticks;
+ result->hz = hz;
+ }
+ else
+ {
+ if (FASTER_TIMEFNS && EQ (hz, timespec_hz))
+ {
+ if (FIXNUMP (ticks))
+ {
+ verify (1 < TIMESPEC_HZ);
+ EMACS_INT s = XFIXNUM (ticks) / TIMESPEC_HZ;
+ ns = XFIXNUM (ticks) % TIMESPEC_HZ;
+ if (ns < 0)
+ s--, ns += TIMESPEC_HZ;
+ *dresult = s_ns_to_double (s, ns);
+ return 0;
+ }
+ ns = mpz_fdiv_q_ui (*q, XBIGNUM (ticks)->value, TIMESPEC_HZ);
+ }
+ else if (FASTER_TIMEFNS && EQ (hz, make_fixnum (1)))
+ {
+ ns = 0;
+ if (FIXNUMP (ticks))
+ {
+ *dresult = XFIXNUM (ticks);
+ return 0;
+ }
+ q = &XBIGNUM (ticks)->value;
+ }
+ else
+ {
+ mpz_mul_ui (*q, *bignum_integer (&mpz[1], ticks), TIMESPEC_HZ);
+ mpz_fdiv_q (*q, *q, *bignum_integer (&mpz[1], hz));
+ ns = mpz_fdiv_q_ui (*q, *q, TIMESPEC_HZ);
+ }
+
+ *dresult = s_ns_to_double (mpz_get_d (*q), ns);
+ }
+
+ return 0;
+}
+
+/* Lisp timestamp classification. */
+enum timeform
+ {
+ TIMEFORM_INVALID = 0,
+ TIMEFORM_HI_LO, /* seconds in the form (HI << LO_TIME_BITS) + LO. */
+ TIMEFORM_HI_LO_US, /* seconds plus microseconds (HI LO US) */
+ TIMEFORM_NIL, /* current time in nanoseconds */
+ TIMEFORM_HI_LO_US_PS, /* seconds plus micro and picoseconds (HI LO US PS) */
+ TIMEFORM_FLOAT, /* time as a float */
+ TIMEFORM_TICKS_HZ /* fractional time: HI is ticks, LO is ticks per second */
+ };
+
+/* From the valid form FORM and the time components HIGH, LOW, USEC
+ and PSEC, generate the corresponding time value. If LOW is
+ floating point, the other components should be zero and FORM should
+ not be TIMEFORM_TICKS_HZ.
+
+ If RESULT is not null, store into *RESULT the converted time.
+ Otherwise, store into *DRESULT the number of seconds since the
+ start of the POSIX Epoch. Unsuccessful calls may or may not store
+ results.
+
+ Return zero if successful, an error number otherwise. */
+static int
+decode_time_components (enum timeform form,
+ Lisp_Object high, Lisp_Object low,
+ Lisp_Object usec, Lisp_Object psec,
+ struct lisp_time *result, double *dresult)
+{
+ switch (form)
+ {
+ case TIMEFORM_INVALID:
+ return EINVAL;
+
+ case TIMEFORM_TICKS_HZ:
+ return decode_ticks_hz (high, low, result, dresult);
+
+ case TIMEFORM_FLOAT:
+ {
+ double t = XFLOAT_DATA (low);
+ if (result)
+ return decode_float_time (t, result);
+ else
+ {
+ *dresult = t;
+ return 0;
+ }
+ }
+
+ case TIMEFORM_NIL:
+ {
+ struct timespec now = current_timespec ();
+ if (result)
+ {
+ result->ticks = timespec_ticks (now);
+ result->hz = timespec_hz;
+ }
+ else
+ *dresult = s_ns_to_double (now.tv_sec, now.tv_nsec);
+ return 0;
+ }
+
+ default:
+ break;
+ }
+
+ if (! (INTEGERP (high) && INTEGERP (low)
+ && FIXNUMP (usec) && FIXNUMP (psec)))
+ return EINVAL;
+ EMACS_INT us = XFIXNUM (usec);
+ EMACS_INT ps = XFIXNUM (psec);
+
+ /* Normalize out-of-range lower-order components by carrying
+ each overflow into the next higher-order component. */
+ us += ps / 1000000 - (ps % 1000000 < 0);
+ mpz_set_intmax (mpz[0], us / 1000000 - (us % 1000000 < 0));
+ mpz_add (mpz[0], mpz[0], *bignum_integer (&mpz[1], low));
+ mpz_addmul_ui (mpz[0], *bignum_integer (&mpz[1], high), 1 << LO_TIME_BITS);
+ ps = ps % 1000000 + 1000000 * (ps % 1000000 < 0);
+ us = us % 1000000 + 1000000 * (us % 1000000 < 0);
+
+ if (result)
+ {
+ switch (form)
+ {
+ case TIMEFORM_HI_LO:
+ /* Floats and nil were handled above, so it was an integer. */
+ result->hz = make_fixnum (1);
+ break;
+
+ case TIMEFORM_HI_LO_US:
+ mpz_mul_ui (mpz[0], mpz[0], 1000000);
+ mpz_add_ui (mpz[0], mpz[0], us);
+ result->hz = make_fixnum (1000000);
+ break;
+
+ case TIMEFORM_HI_LO_US_PS:
+ mpz_mul_ui (mpz[0], mpz[0], 1000000);
+ mpz_add_ui (mpz[0], mpz[0], us);
+ mpz_mul_ui (mpz[0], mpz[0], 1000000);
+ mpz_add_ui (mpz[0], mpz[0], ps);
+ result->hz = trillion;
+ break;
+
+ default:
+ eassume (false);
+ }
+ result->ticks = make_integer_mpz ();
+ }
+ else
+ *dresult = mpz_get_d (mpz[0]) + (us * 1e6L + ps) / 1e12L;
+
+ return 0;
+}
+
+enum { DECODE_SECS_ONLY = WARN_OBSOLETE_TIMESTAMPS + 1 };
+
+/* Decode a Lisp timestamp SPECIFIED_TIME that represents a time.
+
+ FLAGS specifies conversion flags. If FLAGS & DECODE_SECS_ONLY,
+ ignore and do not validate any sub-second components of an
+ old-format SPECIFIED_TIME. If FLAGS & WARN_OBSOLETE_TIMESTAMPS,
+ diagnose what could be obsolete (HIGH . LOW) timestamps.
+
+ If PFORM is not null, store into *PFORM the form of SPECIFIED-TIME.
+ If RESULT is not null, store into *RESULT the converted time;
+ otherwise, store into *DRESULT the number of seconds since the
+ start of the POSIX Epoch. Unsuccessful calls may or may not store
+ results.
+
+ Signal an error if unsuccessful. */
+static void
+decode_lisp_time (Lisp_Object specified_time, int flags,
+ enum timeform *pform,
+ struct lisp_time *result, double *dresult)
+{
+ Lisp_Object high = make_fixnum (0);
+ Lisp_Object low = specified_time;
+ Lisp_Object usec = make_fixnum (0);
+ Lisp_Object psec = make_fixnum (0);
+ enum timeform form = TIMEFORM_HI_LO;
+
+ if (NILP (specified_time))
+ form = TIMEFORM_NIL;
+ else if (FLOATP (specified_time))
+ form = TIMEFORM_FLOAT;
+ else if (CONSP (specified_time))
+ {
+ high = XCAR (specified_time);
+ low = XCDR (specified_time);
+ if (CONSP (low))
+ {
+ Lisp_Object low_tail = XCDR (low);
+ low = XCAR (low);
+ if (! (flags & DECODE_SECS_ONLY))
+ {
+ if (CONSP (low_tail))
+ {
+ usec = XCAR (low_tail);
+ low_tail = XCDR (low_tail);
+ if (CONSP (low_tail))
+ {
+ psec = XCAR (low_tail);
+ form = TIMEFORM_HI_LO_US_PS;
+ }
+ else
+ form = TIMEFORM_HI_LO_US;
+ }
+ else if (!NILP (low_tail))
+ {
+ usec = low_tail;
+ form = TIMEFORM_HI_LO_US;
+ }
+ }
+ }
+ else
+ {
+ if (flags & WARN_OBSOLETE_TIMESTAMPS
+ && RANGED_FIXNUMP (0, low, (1 << LO_TIME_BITS) - 1))
+ message ("obsolete timestamp with cdr %"pI"d", XFIXNUM (low));
+ form = TIMEFORM_TICKS_HZ;
+ }
+
+ /* Require LOW to be an integer, as otherwise the computation
+ would be considerably trickier. */
+ if (! INTEGERP (low))
+ form = TIMEFORM_INVALID;
+ }
+
+ if (pform)
+ *pform = form;
+ int err = decode_time_components (form, high, low, usec, psec,
+ result, dresult);
+ if (err)
+ time_error (err);
+}
+
+/* Convert Z to time_t, returning true if it fits. */
+static bool
+mpz_time (mpz_t const z, time_t *t)
+{
+ if (TYPE_SIGNED (time_t))
+ {
+ intmax_t i;
+ if (! (mpz_to_intmax (z, &i) && TIME_T_MIN <= i && i <= TIME_T_MAX))
+ return false;
+ *t = i;
+ }
+ else
+ {
+ uintmax_t i;
+ if (! (mpz_to_uintmax (z, &i) && i <= TIME_T_MAX))
+ return false;
+ *t = i;
+ }
+ return true;
+}
+
+/* Convert T to struct timespec, returning an invalid timespec
+ if T does not fit. */
+static struct timespec
+lisp_to_timespec (struct lisp_time t)
+{
+ struct timespec result = invalid_timespec ();
+ int ns;
+ mpz_t *q = &mpz[0];
+
+ if (FASTER_TIMEFNS && EQ (t.hz, timespec_hz))
+ {
+ if (FIXNUMP (t.ticks))
+ {
+ EMACS_INT s = XFIXNUM (t.ticks) / TIMESPEC_HZ;
+ ns = XFIXNUM (t.ticks) % TIMESPEC_HZ;
+ if (ns < 0)
+ s--, ns += TIMESPEC_HZ;
+ if ((TYPE_SIGNED (time_t) ? TIME_T_MIN <= s : 0 <= s)
+ && s <= TIME_T_MAX)
+ {
+ result.tv_sec = s;
+ result.tv_nsec = ns;
+ }
+ return result;
+ }
+ else
+ ns = mpz_fdiv_q_ui (*q, XBIGNUM (t.ticks)->value, TIMESPEC_HZ);
+ }
+ else if (FASTER_TIMEFNS && EQ (t.hz, make_fixnum (1)))
+ {
+ ns = 0;
+ if (FIXNUMP (t.ticks))
+ {
+ EMACS_INT s = XFIXNUM (t.ticks);
+ if ((TYPE_SIGNED (time_t) ? TIME_T_MIN <= s : 0 <= s)
+ && s <= TIME_T_MAX)
+ {
+ result.tv_sec = s;
+ result.tv_nsec = ns;
+ }
+ return result;
+ }
+ else
+ q = &XBIGNUM (t.ticks)->value;
+ }
+ else
+ {
+ mpz_mul_ui (*q, *bignum_integer (q, t.ticks), TIMESPEC_HZ);
+ mpz_fdiv_q (*q, *q, *bignum_integer (&mpz[1], t.hz));
+ ns = mpz_fdiv_q_ui (*q, *q, TIMESPEC_HZ);
+ }
+
+ /* With some versions of MinGW, tv_sec is a 64-bit type, whereas
+ time_t is a 32-bit type. */
+ time_t sec;
+ if (mpz_time (*q, &sec))
+ {
+ result.tv_sec = sec;
+ result.tv_nsec = ns;
+ }
+ return result;
+}
+
+/* Convert (HIGH LOW USEC PSEC) to struct timespec.
+ Return true if successful. */
+bool
+list4_to_timespec (Lisp_Object high, Lisp_Object low,
+ Lisp_Object usec, Lisp_Object psec,
+ struct timespec *result)
+{
+ struct lisp_time t;
+ if (decode_time_components (TIMEFORM_HI_LO_US_PS, high, low, usec, psec,
+ &t, 0))
+ return false;
+ *result = lisp_to_timespec (t);
+ return timespec_valid_p (*result);
+}
+
+/* Decode a Lisp list SPECIFIED_TIME that represents a time.
+ If SPECIFIED_TIME is nil, use the current time.
+ Signal an error if SPECIFIED_TIME does not represent a time. */
+static struct lisp_time
+lisp_time_struct (Lisp_Object specified_time, enum timeform *pform)
+{
+ struct lisp_time t;
+ decode_lisp_time (specified_time, WARN_OBSOLETE_TIMESTAMPS, pform, &t, 0);
+ return t;
+}
+
+/* Decode a Lisp list SPECIFIED_TIME that represents a time.
+ Discard any low-order (sub-ns) resolution.
+ If SPECIFIED_TIME is nil, use the current time.
+ Signal an error if SPECIFIED_TIME does not represent a timespec. */
+struct timespec
+lisp_time_argument (Lisp_Object specified_time)
+{
+ struct lisp_time lt = lisp_time_struct (specified_time, 0);
+ struct timespec t = lisp_to_timespec (lt);
+ if (! timespec_valid_p (t))
+ time_overflow ();
+ return t;
+}
+
+/* Like lisp_time_argument, except decode only the seconds part, and
+ do not check the subseconds part. */
+static time_t
+lisp_seconds_argument (Lisp_Object specified_time)
+{
+ int flags = WARN_OBSOLETE_TIMESTAMPS | DECODE_SECS_ONLY;
+ struct lisp_time lt;
+ decode_lisp_time (specified_time, flags, 0, &lt, 0);
+ struct timespec t = lisp_to_timespec (lt);
+ if (! timespec_valid_p (t))
+ time_overflow ();
+ return t.tv_sec;
+}
+
+/* Given Lisp operands A and B, add their values, and return the
+ result as a Lisp timestamp that is in (TICKS . HZ) form if either A
+ or B are in that form, (HI LO US PS) form otherwise. Subtract
+ instead of adding if SUBTRACT. */
+static Lisp_Object
+time_arith (Lisp_Object a, Lisp_Object b, bool subtract)
+{
+ if (FLOATP (a) && !isfinite (XFLOAT_DATA (a)))
+ {
+ double da = XFLOAT_DATA (a);
+ double db = XFLOAT_DATA (Ffloat_time (b));
+ return make_float (subtract ? da - db : da + db);
+ }
+ if (FLOATP (b) && !isfinite (XFLOAT_DATA (b)))
+ return subtract ? make_float (-XFLOAT_DATA (b)) : b;
+
+ enum timeform aform, bform;
+ struct lisp_time ta = lisp_time_struct (a, &aform);
+ struct lisp_time tb = lisp_time_struct (b, &bform);
+ Lisp_Object ticks, hz;
+
+ if (FASTER_TIMEFNS && EQ (ta.hz, tb.hz))
+ {
+ hz = ta.hz;
+ if (FIXNUMP (ta.ticks) && FIXNUMP (tb.ticks))
+ ticks = make_int (subtract
+ ? XFIXNUM (ta.ticks) - XFIXNUM (tb.ticks)
+ : XFIXNUM (ta.ticks) + XFIXNUM (tb.ticks));
+ else
+ {
+ (subtract ? mpz_sub : mpz_add)
+ (mpz[0],
+ *bignum_integer (&mpz[0], ta.ticks),
+ *bignum_integer (&mpz[1], tb.ticks));
+ ticks = make_integer_mpz ();
+ }
+ }
+ else
+ {
+ /* The plan is to decompose ta into na/da and tb into nb/db.
+ Start by computing da and db. */
+ mpz_t *da = bignum_integer (&mpz[1], ta.hz);
+ mpz_t *db = bignum_integer (&mpz[2], tb.hz);
+
+ /* The plan is to compute (na * (db/g) + nb * (da/g)) / lcm (da, db)
+ where g = gcd (da, db). Start by computing g. */
+ mpz_t *g = &mpz[3];
+ mpz_gcd (*g, *da, *db);
+
+ /* fa = da/g, fb = db/g. */
+ mpz_t *fa = &mpz[1], *fb = &mpz[3];
+ mpz_tdiv_q (*fa, *da, *g);
+ mpz_tdiv_q (*fb, *db, *g);
+
+ /* FIXME: Maybe omit need for extra temp by computing fa * db here? */
+
+ /* hz = fa * db. This is equal to lcm (da, db). */
+ mpz_mul (mpz[0], *fa, *db);
+ hz = make_integer_mpz ();
+
+ /* ticks = (fb * na) OPER (fa * nb), where OPER is + or -.
+ OP is the multiply-add or multiply-sub form of OPER. */
+ mpz_t *na = bignum_integer (&mpz[0], ta.ticks);
+ mpz_mul (mpz[0], *fb, *na);
+ mpz_t *nb = bignum_integer (&mpz[3], tb.ticks);
+ (subtract ? mpz_submul : mpz_addmul) (mpz[0], *fa, *nb);
+ ticks = make_integer_mpz ();
+ }
+
+ /* Return the (TICKS . HZ) form if either argument is that way,
+ otherwise the (HI LO US PS) form for backward compatibility. */
+ return (aform == TIMEFORM_TICKS_HZ || bform == TIMEFORM_TICKS_HZ
+ ? Fcons (ticks, hz)
+ : ticks_hz_list4 (ticks, hz));
+}
+
+DEFUN ("time-add", Ftime_add, Stime_add, 2, 2, 0,
+ doc: /* Return the sum of two time values A and B, as a time value.
+See `format-time-string' for the various forms of a time value.
+For example, nil stands for the current time. */)
+ (Lisp_Object a, Lisp_Object b)
+{
+ return time_arith (a, b, false);
+}
+
+DEFUN ("time-subtract", Ftime_subtract, Stime_subtract, 2, 2, 0,
+ doc: /* Return the difference between two time values A and B, as a time value.
+You can use `float-time' to convert the difference into elapsed seconds.
+See `format-time-string' for the various forms of a time value.
+For example, nil stands for the current time. */)
+ (Lisp_Object a, Lisp_Object b)
+{
+ return time_arith (a, b, true);
+}
+
+/* Return negative, 0, positive if a < b, a == b, a > b respectively.
+ Return positive if either a or b is a NaN; this is good enough
+ for the current callers. */
+static int
+time_cmp (Lisp_Object a, Lisp_Object b)
+{
+ if ((FLOATP (a) && !isfinite (XFLOAT_DATA (a)))
+ || (FLOATP (b) && !isfinite (XFLOAT_DATA (b))))
+ {
+ double da = FLOATP (a) ? XFLOAT_DATA (a) : 0;
+ double db = FLOATP (b) ? XFLOAT_DATA (b) : 0;
+ return da < db ? -1 : da != db;
+ }
+
+ struct lisp_time ta = lisp_time_struct (a, 0);
+
+ /* Compare nil to nil correctly, and other eq values while we're at it.
+ Compare here rather than earlier, to handle NaNs and check formats. */
+ if (EQ (a, b))
+ return 0;
+
+ struct lisp_time tb = lisp_time_struct (b, 0);
+ mpz_t *za = bignum_integer (&mpz[0], ta.ticks);
+ mpz_t *zb = bignum_integer (&mpz[1], tb.ticks);
+ if (! (FASTER_TIMEFNS && EQ (ta.hz, tb.hz)))
+ {
+ /* This could be sped up by looking at the signs, sizes, and
+ number of bits of the two sides; see how GMP does mpq_cmp.
+ It may not be worth the trouble here, though. */
+ mpz_mul (mpz[0], *za, *bignum_integer (&mpz[2], tb.hz));
+ mpz_mul (mpz[1], *zb, *bignum_integer (&mpz[2], ta.hz));
+ za = &mpz[0];
+ zb = &mpz[1];
+ }
+ return mpz_cmp (*za, *zb);
+}
+
+DEFUN ("time-less-p", Ftime_less_p, Stime_less_p, 2, 2, 0,
+ doc: /* Return non-nil if time value A is less than time value B.
+See `format-time-string' for the various forms of a time value.
+For example, nil stands for the current time. */)
+ (Lisp_Object a, Lisp_Object b)
+{
+ return time_cmp (a, b) < 0 ? Qt : Qnil;
+}
+
+DEFUN ("time-equal-p", Ftime_equal_p, Stime_equal_p, 2, 2, 0,
+ doc: /* Return non-nil if A and B are equal time values.
+See `format-time-string' for the various forms of a time value. */)
+ (Lisp_Object a, Lisp_Object b)
+{
+ return time_cmp (a, b) == 0 ? Qt : Qnil;
+}
+
+
+DEFUN ("float-time", Ffloat_time, Sfloat_time, 0, 1, 0,
+ doc: /* Return the current time, as a float number of seconds since the epoch.
+If SPECIFIED-TIME is given, it is a time value to convert to float
+instead of the current time. See `format-time-string' for the various
+forms of a time value.
+
+WARNING: Since the result is floating point, it may not be exact.
+If precise time stamps are required, use either `encode-time',
+or (if you need time as a string) `format-time-string'. */)
+ (Lisp_Object specified_time)
+{
+ double t;
+ decode_lisp_time (specified_time, 0, 0, 0, &t);
+ return make_float (t);
+}
+
+/* Write information into buffer S of size MAXSIZE, according to the
+ FORMAT of length FORMAT_LEN, using time information taken from *TP.
+ Use the time zone specified by TZ.
+ Use NS as the number of nanoseconds in the %N directive.
+ Return the number of bytes written, not including the terminating
+ '\0'. If S is NULL, nothing will be written anywhere; so to
+ determine how many bytes would be written, use NULL for S and
+ ((size_t) -1) for MAXSIZE.
+
+ This function behaves like nstrftime, except it allows NUL
+ bytes in FORMAT and it does not support nanoseconds. */
+static size_t
+emacs_nmemftime (char *s, size_t maxsize, const char *format,
+ size_t format_len, const struct tm *tp, timezone_t tz, int ns)
+{
+ size_t total = 0;
+
+ /* Loop through all the NUL-terminated strings in the format
+ argument. Normally there's just one NUL-terminated string, but
+ there can be arbitrarily many, concatenated together, if the
+ format contains '\0' bytes. nstrftime stops at the first
+ '\0' byte so we must invoke it separately for each such string. */
+ for (;;)
+ {
+ size_t len;
+ size_t result;
+
+ if (s)
+ s[0] = '\1';
+
+ result = nstrftime (s, maxsize, format, tp, tz, ns);
+
+ if (s)
+ {
+ if (result == 0 && s[0] != '\0')
+ return 0;
+ s += result + 1;
+ }
+
+ maxsize -= result + 1;
+ total += result;
+ len = strlen (format);
+ if (len == format_len)
+ return total;
+ total++;
+ format += len + 1;
+ format_len -= len + 1;
+ }
+}
+
+static Lisp_Object
+format_time_string (char const *format, ptrdiff_t formatlen,
+ struct timespec t, Lisp_Object zone, struct tm *tmp)
+{
+ char buffer[4000];
+ char *buf = buffer;
+ ptrdiff_t size = sizeof buffer;
+ size_t len;
+ int ns = t.tv_nsec;
+ USE_SAFE_ALLOCA;
+
+ timezone_t tz = tzlookup (zone, false);
+ /* On some systems, like 32-bit MinGW, tv_sec of struct timespec is
+ a 64-bit type, but time_t is a 32-bit type. emacs_localtime_rz
+ expects a pointer to time_t value. */
+ time_t tsec = t.tv_sec;
+ tmp = emacs_localtime_rz (tz, &tsec, tmp);
+ if (! tmp)
+ {
+ int localtime_errno = errno;
+ xtzfree (tz);
+ time_error (localtime_errno);
+ }
+ synchronize_system_time_locale ();
+
+ while (true)
+ {
+ buf[0] = '\1';
+ len = emacs_nmemftime (buf, size, format, formatlen, tmp, tz, ns);
+ if ((0 < len && len < size) || (len == 0 && buf[0] == '\0'))
+ break;
+
+ /* Buffer was too small, so make it bigger and try again. */
+ len = emacs_nmemftime (NULL, SIZE_MAX, format, formatlen, tmp, tz, ns);
+ if (STRING_BYTES_BOUND <= len)
+ {
+ xtzfree (tz);
+ string_overflow ();
+ }
+ size = len + 1;
+ buf = SAFE_ALLOCA (size);
+ }
+
+ xtzfree (tz);
+ AUTO_STRING_WITH_LEN (bufstring, buf, len);
+ Lisp_Object result = code_convert_string_norecord (bufstring,
+ Vlocale_coding_system, 0);
+ SAFE_FREE ();
+ return result;
+}
+
+DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0,
+ doc: /* Use FORMAT-STRING to format the time value TIME.
+A time value that is omitted or nil stands for the current time,
+a number stands for that many seconds, an integer pair (TICKS . HZ)
+stands for TICKS/HZ seconds, and an integer list (HI LO US PS) stands
+for HI*2**16 + LO + US/10**6 + PS/10**12 seconds. This function
+treats seconds as time since the epoch of 1970-01-01 00:00:00 UTC.
+
+The optional ZONE is omitted or nil for Emacs local time, t for
+Universal Time, `wall' for system wall clock time, or a string as in
+the TZ environment variable. It can also be a list (as from
+`current-time-zone') or an integer (as from `decode-time') applied
+without consideration for daylight saving time.
+
+The value is a copy of FORMAT-STRING, but with certain constructs replaced
+by text that describes the specified date and time in TIME:
+
+%Y is the year, %y within the century, %C the century.
+%G is the year corresponding to the ISO week, %g within the century.
+%m is the numeric month.
+%b and %h are the locale's abbreviated month name, %B the full name.
+ (%h is not supported on MS-Windows.)
+%d is the day of the month, zero-padded, %e is blank-padded.
+%u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
+%a is the locale's abbreviated name of the day of week, %A the full name.
+%U is the week number starting on Sunday, %W starting on Monday,
+ %V according to ISO 8601.
+%j is the day of the year.
+
+%H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
+ only blank-padded, %l is like %I blank-padded.
+%p is the locale's equivalent of either AM or PM.
+%q is the calendar quarter (1–4).
+%M is the minute (00-59).
+%S is the second (00-59; 00-60 on platforms with leap seconds)
+%s is the number of seconds since 1970-01-01 00:00:00 +0000.
+%N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
+%Z is the time zone abbreviation, %z is the numeric form.
+
+%c is the locale's date and time format.
+%x is the locale's "preferred" date format.
+%D is like "%m/%d/%y".
+%F is the ISO 8601 date format (like "%+4Y-%m-%d").
+
+%R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
+%X is the locale's "preferred" time format.
+
+Finally, %n is a newline, %t is a tab, %% is a literal %, and
+unrecognized %-sequences stand for themselves.
+
+A %-sequence can contain optional flags, field width, and a modifier
+(in that order) after the `%'. The flags are:
+
+`-' Do not pad the field.
+`_' Pad with spaces.
+`0' Pad with zeros.
+`+' Pad with zeros and put `+' before nonnegative year numbers with >4 digits.
+`^' Use upper case characters if possible.
+`#' Use opposite case characters if possible.
+
+A field width N is an unsigned decimal integer with a leading digit nonzero.
+%NX is like %X, but takes up at least N positions.
+
+The modifiers are:
+
+`E' Use the locale's alternative version.
+`O' Use the locale's number symbols.
+
+For example, to produce full ISO 8601 format, use "%FT%T%z".
+
+usage: (format-time-string FORMAT-STRING &optional TIME ZONE) */)
+ (Lisp_Object format_string, Lisp_Object timeval, Lisp_Object zone)
+{
+ struct timespec t = lisp_time_argument (timeval);
+ struct tm tm;
+
+ CHECK_STRING (format_string);
+ format_string = code_convert_string_norecord (format_string,
+ Vlocale_coding_system, 1);
+ return format_time_string (SSDATA (format_string), SBYTES (format_string),
+ t, zone, &tm);
+}
+
+DEFUN ("decode-time", Fdecode_time, Sdecode_time, 0, 2, 0,
+ doc: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF).
+The optional TIME is the time value to convert. See
+`format-time-string' for the various forms of a time value.
+
+The optional ZONE is omitted or nil for Emacs local time, t for
+Universal Time, `wall' for system wall clock time, or a string as in
+the TZ environment variable. It can also be a list (as from
+`current-time-zone') or an integer (the UTC offset in seconds) applied
+without consideration for daylight saving time.
+
+The list has the following nine members: SEC is an integer between 0
+and 60; SEC is 60 for a leap second, which only some operating systems
+support. MINUTE is an integer between 0 and 59. HOUR is an integer
+between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
+integer between 1 and 12. YEAR is an integer indicating the
+four-digit year. DOW is the day of week, an integer between 0 and 6,
+where 0 is Sunday. DST is t if daylight saving time is in effect,
+nil if it is not in effect, and -1 if daylight saving information is
+not available. UTCOFF is an integer indicating the UTC offset in
+seconds, i.e., the number of seconds east of Greenwich. (Note that
+Common Lisp has different meanings for DOW and UTCOFF.)
+
+usage: (decode-time &optional TIME ZONE) */)
+ (Lisp_Object specified_time, Lisp_Object zone)
+{
+ time_t time_spec = lisp_seconds_argument (specified_time);
+ struct tm local_tm, gmt_tm;
+ timezone_t tz = tzlookup (zone, false);
+ struct tm *tm = emacs_localtime_rz (tz, &time_spec, &local_tm);
+ int localtime_errno = errno;
+ xtzfree (tz);
+
+ if (!tm)
+ time_error (localtime_errno);
+
+ Lisp_Object year;
+ if (FASTER_TIMEFNS
+ && MOST_NEGATIVE_FIXNUM - TM_YEAR_BASE <= local_tm.tm_year
+ && local_tm.tm_year <= MOST_POSITIVE_FIXNUM - TM_YEAR_BASE)
+ {
+ /* Avoid overflow when INT_MAX - TM_YEAR_BASE < local_tm.tm_year. */
+ EMACS_INT tm_year_base = TM_YEAR_BASE;
+ year = make_fixnum (local_tm.tm_year + tm_year_base);
+ }
+ else
+ {
+ mpz_set_si (mpz[0], local_tm.tm_year);
+ mpz_add_ui (mpz[0], mpz[0], TM_YEAR_BASE);
+ year = make_integer_mpz ();
+ }
+
+ return CALLN (Flist,
+ make_fixnum (local_tm.tm_sec),
+ make_fixnum (local_tm.tm_min),
+ make_fixnum (local_tm.tm_hour),
+ make_fixnum (local_tm.tm_mday),
+ make_fixnum (local_tm.tm_mon + 1),
+ year,
+ make_fixnum (local_tm.tm_wday),
+ (local_tm.tm_isdst < 0 ? make_fixnum (-1)
+ : local_tm.tm_isdst == 0 ? Qnil : Qt),
+ (HAVE_TM_GMTOFF
+ ? make_fixnum (tm_gmtoff (&local_tm))
+ : gmtime_r (&time_spec, &gmt_tm)
+ ? make_fixnum (tm_diff (&local_tm, &gmt_tm))
+ : Qnil));
+}
+
+/* Return OBJ - OFFSET, checking that OBJ is a valid integer and that
+ the result is representable as an int. 0 <= OFFSET <= TM_YEAR_BASE. */
+static int
+check_tm_member (Lisp_Object obj, int offset)
+{
+ if (FASTER_TIMEFNS && INT_MAX <= MOST_POSITIVE_FIXNUM - TM_YEAR_BASE)
+ {
+ CHECK_FIXNUM (obj);
+ EMACS_INT n = XFIXNUM (obj);
+ int i;
+ if (INT_SUBTRACT_WRAPV (n, offset, &i))
+ time_overflow ();
+ return i;
+ }
+ else
+ {
+ CHECK_INTEGER (obj);
+ mpz_sub_ui (mpz[0], *bignum_integer (&mpz[0], obj), offset);
+ intmax_t i;
+ if (! (mpz_to_intmax (mpz[0], &i) && INT_MIN <= i && i <= INT_MAX))
+ time_overflow ();
+ return i;
+ }
+}
+
+DEFUN ("encode-time", Fencode_time, Sencode_time, 1, MANY, 0,
+ doc: /* Convert optional TIME to a timestamp.
+Optional FORM specifies how the returned value should be encoded.
+This can act as the reverse operation of `decode-time', which see.
+
+If TIME is a list (SECOND MINUTE HOUR DAY MONTH YEAR IGNORED DST ZONE)
+it is a decoded time in the style of `decode-time', so that (encode-time
+(decode-time ...)) works. TIME can also be a time value.
+See `format-time-string' for the various forms of a time value.
+For example, an omitted TIME stands for the current time.
+
+If FORM is a positive integer, the time is returned as a pair of
+integers (TICKS . FORM), where TICKS is the number of clock ticks and FORM
+is the clock frequency in ticks per second. (Currently the positive
+integer should be at least 65536 if the returned value is expected to
+be given to standard functions expecting Lisp timestamps.) If FORM is
+t, the time is returned as (TICKS . PHZ), where PHZ is a platform dependent
+clock frequency in ticks per second. If FORM is `integer', the time is
+returned as an integer count of seconds. If FORM is `list', the time is
+returned as an integer list (HIGH LOW USEC PSEC), where HIGH has the
+most significant bits of the seconds, LOW has the least significant 16
+bits, and USEC and PSEC are the microsecond and picosecond counts.
+Returned values are rounded toward minus infinity. Although an
+omitted or nil FORM currently acts like `list', this is planned to
+change, so callers requiring list timestamps should specify `list'.
+
+As an obsolescent calling convention, if this function is called with
+6 or more arguments, the first 6 arguments are SECOND, MINUTE, HOUR,
+DAY, MONTH, and YEAR, and specify the components of a decoded time,
+where DST assumed to be -1 and FORM is omitted. If there are more
+than 6 arguments the *last* argument is used as ZONE and any other
+extra arguments are ignored, so that (apply #\\='encode-time
+(decode-time ...)) works; otherwise ZONE is assumed to be nil.
+
+If the input is a decoded time, ZONE is nil for Emacs local time, t
+for Universal Time, `wall' for system wall clock time, or a string as
+in the TZ environment variable. It can also be a list (as from
+`current-time-zone') or an integer (as from `decode-time') applied
+without consideration for daylight saving time.
+
+If the input is a decoded time and ZONE specifies a time zone with
+daylight-saving transitions, DST is t for daylight saving time and nil
+for standard time. If DST is -1, the daylight saving flag is guessed.
+
+Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
+for example, a DAY of 0 means the day preceding the given month.
+Year numbers less than 100 are treated just like other year numbers.
+If you want them to stand for years in this century, you must do that yourself.
+
+Years before 1970 are not guaranteed to work. On some systems,
+year values as low as 1901 do work.
+
+usage: (encode-time &optional TIME FORM &rest OBSOLESCENT-ARGUMENTS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+{
+ struct tm tm;
+ Lisp_Object form = Qnil, zone = Qnil;
+ Lisp_Object a = args[0];
+ tm.tm_isdst = -1;
+
+ if (nargs <= 2)
+ {
+ if (nargs == 2)
+ form = args[1];
+ Lisp_Object tail = a;
+ for (int i = 0; i < 9; i++, tail = XCDR (tail))
+ if (! CONSP (tail))
+ {
+ struct lisp_time t;
+ decode_lisp_time (a, 0, 0, &t, 0);
+ return lisp_time_form_stamp (t, form);
+ }
+ tm.tm_sec = check_tm_member (XCAR (a), 0); a = XCDR (a);
+ tm.tm_min = check_tm_member (XCAR (a), 0); a = XCDR (a);
+ tm.tm_hour = check_tm_member (XCAR (a), 0); a = XCDR (a);
+ tm.tm_mday = check_tm_member (XCAR (a), 0); a = XCDR (a);
+ tm.tm_mon = check_tm_member (XCAR (a), 1); a = XCDR (a);
+ tm.tm_year = check_tm_member (XCAR (a), TM_YEAR_BASE); a = XCDR (a);
+ a = XCDR (a);
+ if (SYMBOLP (XCAR (a)))
+ tm.tm_isdst = !NILP (XCAR (a));
+ a = XCDR (a);
+ zone = XCAR (a);
+ }
+ else if (nargs < 6)
+ xsignal2 (Qwrong_number_of_arguments, Qencode_time, make_fixnum (nargs));
+ else
+ {
+ if (6 < nargs)
+ zone = args[nargs - 1];
+ tm.tm_sec = check_tm_member (a, 0);
+ tm.tm_min = check_tm_member (args[1], 0);
+ tm.tm_hour = check_tm_member (args[2], 0);
+ tm.tm_mday = check_tm_member (args[3], 0);
+ tm.tm_mon = check_tm_member (args[4], 1);
+ tm.tm_year = check_tm_member (args[5], TM_YEAR_BASE);
+ }
+
+ timezone_t tz = tzlookup (zone, false);
+ tm.tm_wday = -1;
+ time_t value = mktime_z (tz, &tm);
+ int mktime_errno = errno;
+ xtzfree (tz);
+
+ if (tm.tm_wday < 0)
+ time_error (mktime_errno);
+
+ return time_form_stamp (value, form);
+}
+
+DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0,
+ doc: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
+The time is returned as a list of integers (HIGH LOW USEC PSEC).
+HIGH has the most significant bits of the seconds, while LOW has the
+least significant 16 bits. USEC and PSEC are the microsecond and
+picosecond counts. Use `encode-time' if you need a particular
+timestamp form; for example, (encode-time nil \\='integer) returns the
+current time in seconds. */)
+ (void)
+{
+ return make_lisp_time (current_timespec ());
+}
+
+DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string,
+ 0, 2, 0,
+ doc: /* Return the current local time, as a human-readable string.
+Programs can use this function to decode a time,
+since the number of columns in each field is fixed
+if the year is in the range 1000-9999.
+The format is `Sun Sep 16 01:03:52 1973'.
+However, see also the functions `decode-time' and `format-time-string'
+which provide a much more powerful and general facility.
+
+If SPECIFIED-TIME is given, it is the time value to format instead of
+the current time. See `format-time-string' for the various forms of a
+time value.
+
+The optional ZONE is omitted or nil for Emacs local time, t for
+Universal Time, `wall' for system wall clock time, or a string as in
+the TZ environment variable. It can also be a list (as from
+`current-time-zone') or an integer (as from `decode-time') applied
+without consideration for daylight saving time. */)
+ (Lisp_Object specified_time, Lisp_Object zone)
+{
+ time_t value = lisp_seconds_argument (specified_time);
+ timezone_t tz = tzlookup (zone, false);
+
+ /* Convert to a string in ctime format, except without the trailing
+ newline, and without the 4-digit year limit. Don't use asctime
+ or ctime, as they might dump core if the year is outside the
+ range -999 .. 9999. */
+ struct tm tm;
+ struct tm *tmp = emacs_localtime_rz (tz, &value, &tm);
+ int localtime_errno = errno;
+ xtzfree (tz);
+ if (! tmp)
+ time_error (localtime_errno);
+
+ static char const wday_name[][4] =
+ { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
+ static char const mon_name[][4] =
+ { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
+ "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
+ printmax_t year_base = TM_YEAR_BASE;
+ char buf[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
+ int len = sprintf (buf, "%s %s%3d %02d:%02d:%02d %"pMd,
+ wday_name[tm.tm_wday], mon_name[tm.tm_mon], tm.tm_mday,
+ tm.tm_hour, tm.tm_min, tm.tm_sec,
+ tm.tm_year + year_base);
+
+ return make_unibyte_string (buf, len);
+}
+
+DEFUN ("current-time-zone", Fcurrent_time_zone, Scurrent_time_zone, 0, 2, 0,
+ doc: /* Return the offset and name for the local time zone.
+This returns a list of the form (OFFSET NAME).
+OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
+ A negative value means west of Greenwich.
+NAME is a string giving the name of the time zone.
+If SPECIFIED-TIME is given, the time zone offset is determined from it
+instead of using the current time. The argument should be a Lisp
+time value; see `format-time-string' for the various forms of a time
+value.
+
+The optional ZONE is omitted or nil for Emacs local time, t for
+Universal Time, `wall' for system wall clock time, or a string as in
+the TZ environment variable. It can also be a list (as from
+`current-time-zone') or an integer (as from `decode-time') applied
+without consideration for daylight saving time.
+
+Some operating systems cannot provide all this information to Emacs;
+in this case, `current-time-zone' returns a list containing nil for
+the data it can't find. */)
+ (Lisp_Object specified_time, Lisp_Object zone)
+{
+ struct timespec value;
+ struct tm local_tm, gmt_tm;
+ Lisp_Object zone_offset, zone_name;
+
+ zone_offset = Qnil;
+ value = make_timespec (lisp_seconds_argument (specified_time), 0);
+ zone_name = format_time_string ("%Z", sizeof "%Z" - 1, value,
+ zone, &local_tm);
+
+ /* gmtime_r expects a pointer to time_t, but tv_sec of struct
+ timespec on some systems (MinGW) is a 64-bit field. */
+ time_t tsec = value.tv_sec;
+ if (HAVE_TM_GMTOFF || gmtime_r (&tsec, &gmt_tm))
+ {
+ long int offset = (HAVE_TM_GMTOFF
+ ? tm_gmtoff (&local_tm)
+ : tm_diff (&local_tm, &gmt_tm));
+ zone_offset = make_fixnum (offset);
+ if (SCHARS (zone_name) == 0)
+ {
+ /* No local time zone name is available; use numeric zone instead. */
+ long int hour = offset / 3600;
+ int min_sec = offset % 3600;
+ int amin_sec = min_sec < 0 ? - min_sec : min_sec;
+ int min = amin_sec / 60;
+ int sec = amin_sec % 60;
+ int min_prec = min_sec ? 2 : 0;
+ int sec_prec = sec ? 2 : 0;
+ char buf[sizeof "+0000" + INT_STRLEN_BOUND (long int)];
+ zone_name = make_formatted_string (buf, "%c%.2ld%.*d%.*d",
+ (offset < 0 ? '-' : '+'),
+ hour, min_prec, min, sec_prec, sec);
+ }
+ }
+
+ return list2 (zone_offset, zone_name);
+}
+
+DEFUN ("set-time-zone-rule", Fset_time_zone_rule, Sset_time_zone_rule, 1, 1, 0,
+ doc: /* Set the Emacs local time zone using TZ, a string specifying a time zone rule.
+If TZ is nil or `wall', use system wall clock time; this differs from
+the usual Emacs convention where nil means current local time. If TZ
+is t, use Universal Time. If TZ is a list (as from
+`current-time-zone') or an integer (as from `decode-time'), use the
+specified time zone without consideration for daylight saving time.
+
+Instead of calling this function, you typically want something else.
+To temporarily use a different time zone rule for just one invocation
+of `decode-time', `encode-time', or `format-time-string', pass the
+function a ZONE argument. To change local time consistently
+throughout Emacs, call (setenv "TZ" TZ): this changes both the
+environment of the Emacs process and the variable
+`process-environment', whereas `set-time-zone-rule' affects only the
+former. */)
+ (Lisp_Object tz)
+{
+ tzlookup (NILP (tz) ? Qwall : tz, true);
+ return Qnil;
+}
+
+/* A buffer holding a string of the form "TZ=value", intended
+ to be part of the environment. If TZ is supposed to be unset,
+ the buffer string is "tZ=". */
+ static char *tzvalbuf;
+
+/* Get the local time zone rule. */
+char *
+emacs_getenv_TZ (void)
+{
+ return tzvalbuf[0] == 'T' ? tzvalbuf + tzeqlen : 0;
+}
+
+/* Set the local time zone rule to TZSTRING, which can be null to
+ denote wall clock time. Do not record the setting in LOCAL_TZ.
+
+ This function is not thread-safe, in theory because putenv is not,
+ but mostly because of the static storage it updates. Other threads
+ that invoke localtime etc. may be adversely affected while this
+ function is executing. */
+
+int
+emacs_setenv_TZ (const char *tzstring)
+{
+ static ptrdiff_t tzvalbufsize;
+ ptrdiff_t tzstringlen = tzstring ? strlen (tzstring) : 0;
+ char *tzval = tzvalbuf;
+ bool new_tzvalbuf = tzvalbufsize <= tzeqlen + tzstringlen;
+
+ if (new_tzvalbuf)
+ {
+ /* Do not attempt to free the old tzvalbuf, since another thread
+ may be using it. In practice, the first allocation is large
+ enough and memory does not leak. */
+ tzval = xpalloc (NULL, &tzvalbufsize,
+ tzeqlen + tzstringlen - tzvalbufsize + 1, -1, 1);
+ tzvalbuf = tzval;
+ tzval[1] = 'Z';
+ tzval[2] = '=';
+ }
+
+ if (tzstring)
+ {
+ /* Modify TZVAL in place. Although this is dicey in a
+ multithreaded environment, we know of no portable alternative.
+ Calling putenv or setenv could crash some other thread. */
+ tzval[0] = 'T';
+ strcpy (tzval + tzeqlen, tzstring);
+ }
+ else
+ {
+ /* Turn 'TZ=whatever' into an empty environment variable 'tZ='.
+ Although this is also dicey, calling unsetenv here can crash Emacs.
+ See Bug#8705. */
+ tzval[0] = 't';
+ tzval[tzeqlen] = 0;
+ }
+
+
+#ifndef WINDOWSNT
+ /* Modifying *TZVAL merely requires calling tzset (which is the
+ caller's responsibility). However, modifying TZVAL requires
+ calling putenv; although this is not thread-safe, in practice this
+ runs only on startup when there is only one thread. */
+ bool need_putenv = new_tzvalbuf;
+#else
+ /* MS-Windows 'putenv' copies the argument string into a block it
+ allocates, so modifying *TZVAL will not change the environment.
+ However, the other threads run by Emacs on MS-Windows never call
+ 'xputenv' or 'putenv' or 'unsetenv', so the original cause for the
+ dicey in-place modification technique doesn't exist there in the
+ first place. */
+ bool need_putenv = true;
+#endif
+ if (need_putenv)
+ xputenv (tzval);
+
+ return 0;
+}
+
+#if (ULONG_MAX < TRILLION || !FASTER_TIMEFNS) && !defined ztrillion
+# define NEED_ZTRILLION_INIT 1
+#endif
+
+#ifdef NEED_ZTRILLION_INIT
+static void
+syms_of_timefns_for_pdumper (void)
+{
+ mpz_init_set_ui (ztrillion, 1000000);
+ mpz_mul_ui (ztrillion, ztrillion, 1000000);
+}
+#endif
+
+void
+syms_of_timefns (void)
+{
+#ifndef timespec_hz
+ timespec_hz = make_int (TIMESPEC_HZ);
+ staticpro (&timespec_hz);
+#endif
+#ifndef trillion
+ trillion = make_int (1000000000000);
+ staticpro (&trillion);
+#endif
+
+ DEFSYM (Qencode_time, "encode-time");
+
+ defsubr (&Scurrent_time);
+ defsubr (&Stime_add);
+ defsubr (&Stime_subtract);
+ defsubr (&Stime_less_p);
+ defsubr (&Stime_equal_p);
+ defsubr (&Sformat_time_string);
+ defsubr (&Sfloat_time);
+ defsubr (&Sdecode_time);
+ defsubr (&Sencode_time);
+ defsubr (&Scurrent_time_string);
+ defsubr (&Scurrent_time_zone);
+ defsubr (&Sset_time_zone_rule);
+#ifdef NEED_ZTRILLION_INIT
+ pdumper_do_now_and_after_load (syms_of_timefns_for_pdumper);
+#endif
+}
diff --git a/src/tparam.h b/src/tparam.h
index 5aa4ebf4cc2..6918c9e7a0f 100644
--- a/src/tparam.h
+++ b/src/tparam.h
@@ -30,14 +30,15 @@ int tgetnum (const char *);
char *tgetstr (const char *, char **);
char *tgoto (const char *, int, int);
-char *tparam (const char *, char *, int, int, int, int, int);
+char *tparam (const char *, char *, int, int, int, int, int) ATTRIBUTE_MALLOC;
extern char PC;
extern char *BC;
extern char *UP;
#ifdef TERMINFO
-char *tigetstr(const char *);
+int tigetflag (const char *);
+char *tigetstr (const char *);
#endif
#endif /* EMACS_TPARAM_H */
diff --git a/src/undo.c b/src/undo.c
index dded73a13e5..3c1251dae6e 100644
--- a/src/undo.c
+++ b/src/undo.c
@@ -74,7 +74,7 @@ record_point (ptrdiff_t beg)
&& point_before_last_command_or_undo != beg
&& buffer_before_last_command_or_undo == current_buffer )
bset_undo_list (current_buffer,
- Fcons (make_number (point_before_last_command_or_undo),
+ Fcons (make_fixnum (point_before_last_command_or_undo),
BVAR (current_buffer, undo_list)));
}
@@ -102,11 +102,11 @@ record_insert (ptrdiff_t beg, ptrdiff_t length)
Lisp_Object elt;
elt = XCAR (BVAR (current_buffer, undo_list));
if (CONSP (elt)
- && INTEGERP (XCAR (elt))
- && INTEGERP (XCDR (elt))
- && XINT (XCDR (elt)) == beg)
+ && FIXNUMP (XCAR (elt))
+ && FIXNUMP (XCDR (elt))
+ && XFIXNUM (XCDR (elt)) == beg)
{
- XSETCDR (elt, make_number (beg + length));
+ XSETCDR (elt, make_fixnum (beg + length));
return;
}
}
@@ -126,15 +126,11 @@ record_insert (ptrdiff_t beg, ptrdiff_t length)
static void
record_marker_adjustments (ptrdiff_t from, ptrdiff_t to)
{
- Lisp_Object marker;
- register struct Lisp_Marker *m;
- register ptrdiff_t charpos, adjustment;
-
- prepare_record();
+ prepare_record ();
- for (m = BUF_MARKERS (current_buffer); m; m = m->next)
+ for (struct Lisp_Marker *m = BUF_MARKERS (current_buffer); m; m = m->next)
{
- charpos = m->charpos;
+ ptrdiff_t charpos = m->charpos;
eassert (charpos <= Z);
if (from <= charpos && charpos <= to)
@@ -146,14 +142,14 @@ record_marker_adjustments (ptrdiff_t from, ptrdiff_t to)
insertion_type t markers will automatically move forward
upon re-inserting the deleted text, so we have to arrange
for them to move backward to the correct position. */
- adjustment = (m->insertion_type ? to : from) - charpos;
+ ptrdiff_t adjustment = (m->insertion_type ? to : from) - charpos;
if (adjustment)
{
- XSETMISC (marker, m);
+ Lisp_Object marker = make_lisp_ptr (m, Lisp_Vectorlike);
bset_undo_list
(current_buffer,
- Fcons (Fcons (marker, make_number (adjustment)),
+ Fcons (Fcons (marker, make_fixnum (adjustment)),
BVAR (current_buffer, undo_list)));
}
}
@@ -295,7 +291,7 @@ truncate_undo_list (struct buffer *b)
{
Lisp_Object list;
Lisp_Object prev, next, last_boundary;
- EMACS_INT size_so_far = 0;
+ intmax_t size_so_far = 0;
/* Make sure that calling undo-outer-limit-function
won't cause another GC. */
@@ -352,14 +348,17 @@ truncate_undo_list (struct buffer *b)
/* If by the first boundary we have already passed undo_outer_limit,
we're heading for memory full, so offer to clear out the list. */
- if (INTEGERP (Vundo_outer_limit)
- && size_so_far > XINT (Vundo_outer_limit)
+ intmax_t undo_outer_limit;
+ if ((INTEGERP (Vundo_outer_limit)
+ && (integer_to_intmax (Vundo_outer_limit, &undo_outer_limit)
+ ? undo_outer_limit < size_so_far
+ : NILP (Fnatnump (Vundo_outer_limit))))
&& !NILP (Vundo_outer_limit_function))
{
Lisp_Object tem;
/* Normally the function this calls is undo-outer-limit-truncate. */
- tem = call1 (Vundo_outer_limit_function, make_number (size_so_far));
+ tem = call1 (Vundo_outer_limit_function, make_int (size_so_far));
if (! NILP (tem))
{
/* The function is responsible for making
@@ -472,7 +471,7 @@ In fact, this calls the function which is the value of
`undo-outer-limit-function' with one argument, the size.
The text above describes the behavior of the function
that variable usually specifies. */);
- Vundo_outer_limit = make_number (12000000);
+ Vundo_outer_limit = make_fixnum (12000000);
DEFVAR_LISP ("undo-outer-limit-function", Vundo_outer_limit_function,
doc: /* Function to call when an undo list exceeds `undo-outer-limit'.
diff --git a/src/unexcoff.c b/src/unexcoff.c
index 6e90c0628d2..220ce709df9 100644
--- a/src/unexcoff.c
+++ b/src/unexcoff.c
@@ -56,7 +56,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#define PERROR(file) report_error (file, new)
-#ifndef CANNOT_DUMP /* all rest of file! */
+#ifdef HAVE_UNEXEC /* all rest of file! */
#ifdef HAVE_COFF_H
#include <coff.h>
@@ -538,4 +538,4 @@ unexec (const char *new_name, const char *a_name)
emacs_close (a_out);
}
-#endif /* not CANNOT_DUMP */
+#endif /* HAVE_UNEXEC */
diff --git a/src/unexcw.c b/src/unexcw.c
index 8caaafcaab0..a6e30f6a21e 100644
--- a/src/unexcw.c
+++ b/src/unexcw.c
@@ -48,7 +48,7 @@ static exe_header_t *
read_exe_header (int fd, exe_header_t * exe_header_buffer)
{
int i;
- int ret;
+ int ret ATTRIBUTE_UNUSED;
assert (fd >= 0);
assert (exe_header_buffer != 0);
@@ -111,7 +111,7 @@ fixup_executable (int fd)
exe_header_t exe_header_buffer;
exe_header_t *exe_header;
int i;
- int ret;
+ int ret ATTRIBUTE_UNUSED;
int found_data = 0;
int found_bss = 0;
@@ -269,7 +269,7 @@ unexec (const char *outfile, const char *infile)
int fd_in;
int fd_out;
int ret;
- int ret2;
+ int ret2 ATTRIBUTE_UNUSED;
infile = add_exe_suffix_if_necessary (infile, infile_buffer);
outfile = add_exe_suffix_if_necessary (outfile, outfile_buffer);
diff --git a/src/unexmacosx.c b/src/unexmacosx.c
index 53a30e36278..a94c0cccb6b 100644
--- a/src/unexmacosx.c
+++ b/src/unexmacosx.c
@@ -447,7 +447,7 @@ unexec_regions_recorder (task_t task, void *rr, unsigned type,
while (num && num_unexec_regions < MAX_UNEXEC_REGIONS)
{
- /* Subtract the size of trailing null bytes from filesize. It
+ /* Subtract the size of trailing NUL bytes from filesize. It
can be smaller than vmsize in segment commands. In such a
case, trailing bytes are initialized with zeros. */
for (p = ranges->address + ranges->size; p > ranges->address; p--)
diff --git a/src/unexw32.c b/src/unexw32.c
index f8941344fcc..59feaa74b9f 100644
--- a/src/unexw32.c
+++ b/src/unexw32.c
@@ -39,17 +39,12 @@ PIMAGE_NT_HEADERS (__stdcall * pfnCheckSumMappedFile) (LPVOID BaseAddress,
LPDWORD HeaderSum,
LPDWORD CheckSum);
-extern BOOL ctrl_c_handler (unsigned long type);
-
extern char my_begdata[];
extern char my_begbss[];
extern char *my_begbss_static;
#include "w32heap.h"
-/* Basically, our "initialized" flag. */
-BOOL using_dynamic_heap = FALSE;
-
void get_section_info (file_data *p_file);
void copy_executable_and_dump_data (file_data *, file_data *);
void dump_bss_and_heap (file_data *p_infile, file_data *p_outfile);
@@ -70,84 +65,10 @@ PCHAR bss_start_static = 0;
DWORD_PTR bss_size_static = 0;
DWORD_PTR extra_bss_size_static = 0;
-/* MinGW64 doesn't add a leading underscore to external symbols,
- whereas configure.ac sets up LD_SWITCH_SYSTEM_TEMACS to force the
- entry point at __start, with two underscores. */
-#ifdef __MINGW64__
-#define _start __start
-#endif
-
-extern void mainCRTStartup (void);
-
-/* Startup code for running on NT. When we are running as the dumped
- version, we need to bootstrap our heap and .bss section into our
- address space before we can actually hand off control to the startup
- code supplied by NT (primarily because that code relies upon malloc ()). */
-void _start (void);
-
-void
-_start (void)
-{
-
-#if 1
- /* Give us a way to debug problems with crashes on startup when
- running under the MSVC profiler. */
- if (GetEnvironmentVariable ("EMACS_DEBUG", NULL, 0) > 0)
- DebugBreak ();
-#endif
-
- /* Cache system info, e.g., the NT page size. */
- cache_system_info ();
-
- /* Grab our malloc arena space now, before CRT starts up. */
- init_heap ();
-
- /* This prevents ctrl-c's in shells running while we're suspended from
- having us exit. */
- SetConsoleCtrlHandler ((PHANDLER_ROUTINE) ctrl_c_handler, TRUE);
-
- /* Prevent Emacs from being locked up (eg. in batch mode) when
- accessing devices that aren't mounted (eg. removable media drives). */
- SetErrorMode (SEM_FAILCRITICALERRORS);
- mainCRTStartup ();
-}
-
-
/* File handling. */
/* Implementation note: this and the next functions work with ANSI
codepage encoded file names! */
-int
-open_input_file (file_data *p_file, char *filename)
-{
- HANDLE file;
- HANDLE file_mapping;
- void *file_base;
- unsigned long size, upper_size;
-
- file = CreateFileA (filename, GENERIC_READ, FILE_SHARE_READ, NULL,
- OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
- if (file == INVALID_HANDLE_VALUE)
- return FALSE;
-
- size = GetFileSize (file, &upper_size);
- file_mapping = CreateFileMapping (file, NULL, PAGE_READONLY,
- 0, size, NULL);
- if (!file_mapping)
- return FALSE;
-
- file_base = MapViewOfFile (file_mapping, FILE_MAP_READ, 0, 0, size);
- if (file_base == 0)
- return FALSE;
-
- p_file->name = filename;
- p_file->size = size;
- p_file->file = file;
- p_file->file_mapping = file_mapping;
- p_file->file_base = file_base;
-
- return TRUE;
-}
int
open_output_file (file_data *p_file, char *filename, unsigned long size)
@@ -187,18 +108,6 @@ open_output_file (file_data *p_file, char *filename, unsigned long size)
return TRUE;
}
-/* Close the system structures associated with the given file. */
-void
-close_file_data (file_data *p_file)
-{
- UnmapViewOfFile (p_file->file_base);
- CloseHandle (p_file->file_mapping);
- /* For the case of output files, set final size. */
- SetFilePointer (p_file->file, p_file->size, NULL, FILE_BEGIN);
- SetEndOfFile (p_file->file);
- CloseHandle (p_file->file);
-}
-
/* Routines to manipulate NT executable file sections. */
@@ -220,34 +129,6 @@ find_section (const char * name, IMAGE_NT_HEADERS * nt_header)
return NULL;
}
-/* Return pointer to section header for section containing the given
- relative virtual address. */
-IMAGE_SECTION_HEADER *
-rva_to_section (DWORD_PTR rva, IMAGE_NT_HEADERS * nt_header)
-{
- PIMAGE_SECTION_HEADER section;
- int i;
-
- section = IMAGE_FIRST_SECTION (nt_header);
-
- for (i = 0; i < nt_header->FileHeader.NumberOfSections; i++)
- {
- /* Some linkers (eg. the NT SDK linker I believe) swapped the
- meaning of these two values - or rather, they ignored
- VirtualSize entirely and always set it to zero. This affects
- some very old exes (eg. gzip dated Dec 1993). Since
- w32_executable_type relies on this function to work reliably,
- we need to cope with this. */
- DWORD_PTR real_size = max (section->SizeOfRawData,
- section->Misc.VirtualSize);
- if (rva >= section->VirtualAddress
- && rva < section->VirtualAddress + real_size)
- return section;
- section++;
- }
- return NULL;
-}
-
#if 0 /* unused */
/* Return pointer to section header for section containing the given
offset in its raw data area. */
@@ -765,15 +646,8 @@ unexec (const char *new_name, const char *old_name)
exit (1);
}
- /* Set the flag (before dumping). */
- using_dynamic_heap = TRUE;
-
copy_executable_and_dump_data (&in_file, &out_file);
- /* Unset it because it is plain wrong to keep it after dumping.
- Malloc can still occur! */
- using_dynamic_heap = FALSE;
-
/* Patch up header fields; profiler is picky about this. */
{
PIMAGE_DOS_HEADER dos_header;
diff --git a/src/w16select.c b/src/w16select.c
index fb8161b61fa..3eb219954af 100644
--- a/src/w16select.c
+++ b/src/w16select.c
@@ -2,6 +2,8 @@
Copyright (C) 1996-1997, 2001-2019 Free Software Foundation, Inc.
+Author: Dale P. Smith <dpsm@en.com>
+
This file is part of GNU Emacs.
GNU Emacs is free software: you can redistribute it and/or modify
@@ -22,7 +24,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
"old" (character-mode) application access to Dynamic Data Exchange,
menus, and the Windows clipboard. */
-/* Written by Dale P. Smith <dpsm@en.com> */
/* Adapted to DJGPP by Eli Zaretskii <eliz@gnu.org> */
#ifdef MSDOS
@@ -219,7 +220,7 @@ set_clipboard_data (unsigned Format, void *Data, unsigned Size, int Raw)
/* need to know final size after '\r' chars are inserted (the
standard CF_OEMTEXT clipboard format uses CRLF line endings,
while Emacs uses just LF internally). */
- truelen = Size + 1; /* +1 for the terminating null */
+ truelen = Size + 1; /* +1 for the terminating NUL */
if (!Raw)
{
@@ -242,7 +243,7 @@ set_clipboard_data (unsigned Format, void *Data, unsigned Size, int Raw)
{
dosmemput (Data, Size, xbuf_addr);
- /* Terminate with a null, otherwise Windows does strange things
+ /* Terminate with a NUL, otherwise Windows does strange things
when the text size is an integral multiple of 32 bytes. */
_farpokeb (_dos_ds, xbuf_addr + Size, '\0');
}
@@ -254,7 +255,7 @@ set_clipboard_data (unsigned Format, void *Data, unsigned Size, int Raw)
while (Size--)
{
/* Don't allow them to put binary data into the clipboard, since
- it will cause yanked data to be truncated at the first null. */
+ it will cause yanked data to be truncated at the first NUL. */
if (*dp == '\0')
return 2;
if (*dp == '\n')
@@ -262,7 +263,7 @@ set_clipboard_data (unsigned Format, void *Data, unsigned Size, int Raw)
_farnspokeb (buf_offset++, *dp++);
}
- /* Terminate with a null, otherwise Windows does strange things
+ /* Terminate with a NUL, otherwise Windows does strange things
when the text size is an integral multiple of 32 bytes. */
_farnspokeb (buf_offset, '\0');
}
@@ -353,13 +354,13 @@ get_clipboard_data (unsigned Format, void *Data, unsigned Size, int Raw)
__dpmi_int (0x2f, &regs);
if (regs.x.ax != 0)
{
- unsigned char null_char = '\0';
+ unsigned char nul_char = '\0';
unsigned long xbuf_beg = xbuf_addr;
/* If last_clipboard_text is NULL, we don't want to slow down
the next loop by an additional test. */
register unsigned char *lcdp =
- last_clipboard_text == NULL ? &null_char : last_clipboard_text;
+ last_clipboard_text == NULL ? &nul_char : last_clipboard_text;
/* Copy data from low memory, remove CR
characters before LF if needed. */
@@ -382,7 +383,7 @@ get_clipboard_data (unsigned Format, void *Data, unsigned Size, int Raw)
/* Windows reportedly rounds up the size of clipboard data
(passed in SIZE) to a multiple of 32, and removes trailing
spaces from each line without updating SIZE. We therefore
- bail out when we see the first null character. */
+ bail out when we see the first NUL character. */
else if (c == '\0')
break;
}
@@ -391,7 +392,7 @@ get_clipboard_data (unsigned Format, void *Data, unsigned Size, int Raw)
last time set_clipboard_data was called, pretend there's no
data in the clipboard. This is so we don't pass our own text
from the clipboard (which might be troublesome if the killed
- text includes null characters). */
+ text includes NUL characters). */
if (last_clipboard_text &&
xbuf_addr - xbuf_beg == (long)(lcdp - last_clipboard_text))
dp = (unsigned char *)Data + 1;
@@ -535,7 +536,7 @@ DEFUN ("w16-set-clipboard-data", Fw16_set_clipboard_data, Sw16_set_clipboard_dat
message3 (make_unibyte_string (system_error_msg, sizeof (system_error_msg) - 1));
break;
}
- sit_for (make_number (2), 0, 2);
+ sit_for (make_fixnum (2), 0, 2);
}
done:
@@ -678,43 +679,11 @@ syms_of_win16select (void)
defsubr (&Sw16_selection_exists_p);
DEFVAR_LISP ("selection-coding-system", Vselection_coding_system,
- doc: /* Coding system for communicating with other programs.
-
-For MS-Windows and MS-DOS:
-When sending or receiving text via selection and clipboard, the text
-is encoded or decoded by this coding system. The default value is
-the current system default encoding on 9x/Me, `utf-16le-dos'
-\(Unicode) on NT/W2K/XP, and `iso-latin-1-dos' on MS-DOS.
-
-For X Windows:
-When sending text via selection and clipboard, if the target
-data-type matches with the type of this coding system, it is used
-for encoding the text. Otherwise (including the case that this
-variable is nil), a proper coding system is used as below:
-
-data-type coding system
---------- -------------
-UTF8_STRING utf-8
-COMPOUND_TEXT compound-text-with-extensions
-STRING iso-latin-1
-C_STRING no-conversion
-
-When receiving text, if this coding system is non-nil, it is used
-for decoding regardless of the data-type. If this is nil, a
-proper coding system is used according to the data-type as above.
-
-See also the documentation of the variable `x-select-request-type' how
-to control which data-type to request for receiving text.
-
-The default value is nil. */);
+ doc: /* SKIP: real doc in select.el. */);
Vselection_coding_system = intern ("iso-latin-1-dos");
DEFVAR_LISP ("next-selection-coding-system", Vnext_selection_coding_system,
- doc: /* Coding system for the next communication with other programs.
-Usually, `selection-coding-system' is used for communicating with
-other programs (X Windows clients or MS Windows programs). But, if this
-variable is set, it is used for the next communication only.
-After the communication, this variable is set to nil. */);
+ doc: /* SKIP: real doc in select.el. */);
Vnext_selection_coding_system = Qnil;
DEFSYM (QCLIPBOARD, "CLIPBOARD");
diff --git a/src/w32.c b/src/w32.c
index 374011cb290..082a66b7384 100644
--- a/src/w32.c
+++ b/src/w32.c
@@ -326,6 +326,9 @@ static BOOL g_b_init_set_file_security_a;
static BOOL g_b_init_set_named_security_info_w;
static BOOL g_b_init_set_named_security_info_a;
static BOOL g_b_init_get_adapters_info;
+static BOOL g_b_init_reg_open_key_ex_w;
+static BOOL g_b_init_reg_query_value_ex_w;
+static BOOL g_b_init_expand_environment_strings_w;
BOOL g_b_init_compare_string_w;
BOOL g_b_init_debug_break_process;
@@ -504,6 +507,9 @@ typedef DWORD (WINAPI *GetAdaptersInfo_Proc) (
int (WINAPI *pMultiByteToWideChar)(UINT,DWORD,LPCSTR,int,LPWSTR,int);
int (WINAPI *pWideCharToMultiByte)(UINT,DWORD,LPCWSTR,int,LPSTR,int,LPCSTR,LPBOOL);
DWORD multiByteToWideCharFlags;
+typedef LONG (WINAPI *RegOpenKeyExW_Proc) (HKEY,LPCWSTR,DWORD,REGSAM,PHKEY);
+typedef LONG (WINAPI *RegQueryValueExW_Proc) (HKEY,LPCWSTR,LPDWORD,LPDWORD,LPBYTE,LPDWORD);
+typedef DWORD (WINAPI *ExpandEnvironmentStringsW_Proc) (LPCWSTR,LPWSTR,DWORD);
/* ** A utility function ** */
static BOOL
@@ -529,8 +535,6 @@ static Lisp_Object ltime (ULONGLONG);
/* Get total user and system times for get-internal-run-time.
Returns a list of integers if the times are provided by the OS
(NT derivatives), otherwise it returns the result of current-time. */
-Lisp_Object w32_get_internal_run_time (void);
-
Lisp_Object
w32_get_internal_run_time (void)
{
@@ -570,8 +574,8 @@ open_process_token (HANDLE ProcessHandle,
{
g_b_init_open_process_token = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Open_Process_Token =
- (OpenProcessToken_Proc) GetProcAddress (hm_advapi32, "OpenProcessToken");
+ s_pfn_Open_Process_Token = (OpenProcessToken_Proc)
+ get_proc_addr (hm_advapi32, "OpenProcessToken");
}
if (s_pfn_Open_Process_Token == NULL)
{
@@ -602,8 +606,8 @@ get_token_information (HANDLE TokenHandle,
{
g_b_init_get_token_information = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Get_Token_Information =
- (GetTokenInformation_Proc) GetProcAddress (hm_advapi32, "GetTokenInformation");
+ s_pfn_Get_Token_Information = (GetTokenInformation_Proc)
+ get_proc_addr (hm_advapi32, "GetTokenInformation");
}
if (s_pfn_Get_Token_Information == NULL)
{
@@ -638,8 +642,8 @@ lookup_account_sid (LPCTSTR lpSystemName,
{
g_b_init_lookup_account_sid = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Lookup_Account_Sid =
- (LookupAccountSid_Proc) GetProcAddress (hm_advapi32, LookupAccountSid_Name);
+ s_pfn_Lookup_Account_Sid = (LookupAccountSid_Proc)
+ get_proc_addr (hm_advapi32, LookupAccountSid_Name);
}
if (s_pfn_Lookup_Account_Sid == NULL)
{
@@ -671,9 +675,8 @@ get_sid_sub_authority (PSID pSid, DWORD n)
{
g_b_init_get_sid_sub_authority = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Get_Sid_Sub_Authority =
- (GetSidSubAuthority_Proc) GetProcAddress (
- hm_advapi32, "GetSidSubAuthority");
+ s_pfn_Get_Sid_Sub_Authority = (GetSidSubAuthority_Proc)
+ get_proc_addr (hm_advapi32, "GetSidSubAuthority");
}
if (s_pfn_Get_Sid_Sub_Authority == NULL)
{
@@ -696,9 +699,8 @@ get_sid_sub_authority_count (PSID pSid)
{
g_b_init_get_sid_sub_authority_count = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Get_Sid_Sub_Authority_Count =
- (GetSidSubAuthorityCount_Proc) GetProcAddress (
- hm_advapi32, "GetSidSubAuthorityCount");
+ s_pfn_Get_Sid_Sub_Authority_Count = (GetSidSubAuthorityCount_Proc)
+ get_proc_addr (hm_advapi32, "GetSidSubAuthorityCount");
}
if (s_pfn_Get_Sid_Sub_Authority_Count == NULL)
{
@@ -727,9 +729,8 @@ get_security_info (HANDLE handle,
{
g_b_init_get_security_info = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Get_Security_Info =
- (GetSecurityInfo_Proc) GetProcAddress (
- hm_advapi32, "GetSecurityInfo");
+ s_pfn_Get_Security_Info = (GetSecurityInfo_Proc)
+ get_proc_addr (hm_advapi32, "GetSecurityInfo");
}
if (s_pfn_Get_Security_Info == NULL)
{
@@ -763,9 +764,8 @@ get_file_security (const char *lpFileName,
{
g_b_init_get_file_security_w = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Get_File_SecurityW =
- (GetFileSecurityW_Proc) GetProcAddress (hm_advapi32,
- "GetFileSecurityW");
+ s_pfn_Get_File_SecurityW = (GetFileSecurityW_Proc)
+ get_proc_addr (hm_advapi32, "GetFileSecurityW");
}
if (s_pfn_Get_File_SecurityW == NULL)
{
@@ -785,9 +785,8 @@ get_file_security (const char *lpFileName,
{
g_b_init_get_file_security_a = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Get_File_SecurityA =
- (GetFileSecurityA_Proc) GetProcAddress (hm_advapi32,
- "GetFileSecurityA");
+ s_pfn_Get_File_SecurityA = (GetFileSecurityA_Proc)
+ get_proc_addr (hm_advapi32, "GetFileSecurityA");
}
if (s_pfn_Get_File_SecurityA == NULL)
{
@@ -822,9 +821,8 @@ set_file_security (const char *lpFileName,
{
g_b_init_set_file_security_w = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Set_File_SecurityW =
- (SetFileSecurityW_Proc) GetProcAddress (hm_advapi32,
- "SetFileSecurityW");
+ s_pfn_Set_File_SecurityW = (SetFileSecurityW_Proc)
+ get_proc_addr (hm_advapi32, "SetFileSecurityW");
}
if (s_pfn_Set_File_SecurityW == NULL)
{
@@ -843,9 +841,8 @@ set_file_security (const char *lpFileName,
{
g_b_init_set_file_security_a = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Set_File_SecurityA =
- (SetFileSecurityA_Proc) GetProcAddress (hm_advapi32,
- "SetFileSecurityA");
+ s_pfn_Set_File_SecurityA = (SetFileSecurityA_Proc)
+ get_proc_addr (hm_advapi32, "SetFileSecurityA");
}
if (s_pfn_Set_File_SecurityA == NULL)
{
@@ -883,9 +880,8 @@ set_named_security_info (LPCTSTR lpObjectName,
{
g_b_init_set_named_security_info_w = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Set_Named_Security_InfoW =
- (SetNamedSecurityInfoW_Proc) GetProcAddress (hm_advapi32,
- "SetNamedSecurityInfoW");
+ s_pfn_Set_Named_Security_InfoW = (SetNamedSecurityInfoW_Proc)
+ get_proc_addr (hm_advapi32, "SetNamedSecurityInfoW");
}
if (s_pfn_Set_Named_Security_InfoW == NULL)
{
@@ -905,9 +901,8 @@ set_named_security_info (LPCTSTR lpObjectName,
{
g_b_init_set_named_security_info_a = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Set_Named_Security_InfoA =
- (SetNamedSecurityInfoA_Proc) GetProcAddress (hm_advapi32,
- "SetNamedSecurityInfoA");
+ s_pfn_Set_Named_Security_InfoA = (SetNamedSecurityInfoA_Proc)
+ get_proc_addr (hm_advapi32, "SetNamedSecurityInfoA");
}
if (s_pfn_Set_Named_Security_InfoA == NULL)
{
@@ -937,9 +932,8 @@ get_security_descriptor_owner (PSECURITY_DESCRIPTOR pSecurityDescriptor,
{
g_b_init_get_security_descriptor_owner = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Get_Security_Descriptor_Owner =
- (GetSecurityDescriptorOwner_Proc) GetProcAddress (
- hm_advapi32, "GetSecurityDescriptorOwner");
+ s_pfn_Get_Security_Descriptor_Owner = (GetSecurityDescriptorOwner_Proc)
+ get_proc_addr (hm_advapi32, "GetSecurityDescriptorOwner");
}
if (s_pfn_Get_Security_Descriptor_Owner == NULL)
{
@@ -966,9 +960,8 @@ get_security_descriptor_group (PSECURITY_DESCRIPTOR pSecurityDescriptor,
{
g_b_init_get_security_descriptor_group = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Get_Security_Descriptor_Group =
- (GetSecurityDescriptorGroup_Proc) GetProcAddress (
- hm_advapi32, "GetSecurityDescriptorGroup");
+ s_pfn_Get_Security_Descriptor_Group = (GetSecurityDescriptorGroup_Proc)
+ get_proc_addr (hm_advapi32, "GetSecurityDescriptorGroup");
}
if (s_pfn_Get_Security_Descriptor_Group == NULL)
{
@@ -996,9 +989,8 @@ get_security_descriptor_dacl (PSECURITY_DESCRIPTOR pSecurityDescriptor,
{
g_b_init_get_security_descriptor_dacl = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Get_Security_Descriptor_Dacl =
- (GetSecurityDescriptorDacl_Proc) GetProcAddress (
- hm_advapi32, "GetSecurityDescriptorDacl");
+ s_pfn_Get_Security_Descriptor_Dacl = (GetSecurityDescriptorDacl_Proc)
+ get_proc_addr (hm_advapi32, "GetSecurityDescriptorDacl");
}
if (s_pfn_Get_Security_Descriptor_Dacl == NULL)
{
@@ -1023,9 +1015,8 @@ is_valid_sid (PSID sid)
{
g_b_init_is_valid_sid = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Is_Valid_Sid =
- (IsValidSid_Proc) GetProcAddress (
- hm_advapi32, "IsValidSid");
+ s_pfn_Is_Valid_Sid = (IsValidSid_Proc)
+ get_proc_addr (hm_advapi32, "IsValidSid");
}
if (s_pfn_Is_Valid_Sid == NULL)
{
@@ -1047,9 +1038,8 @@ equal_sid (PSID sid1, PSID sid2)
{
g_b_init_equal_sid = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Equal_Sid =
- (EqualSid_Proc) GetProcAddress (
- hm_advapi32, "EqualSid");
+ s_pfn_Equal_Sid = (EqualSid_Proc)
+ get_proc_addr (hm_advapi32, "EqualSid");
}
if (s_pfn_Equal_Sid == NULL)
{
@@ -1071,9 +1061,8 @@ get_length_sid (PSID sid)
{
g_b_init_get_length_sid = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Get_Length_Sid =
- (GetLengthSid_Proc) GetProcAddress (
- hm_advapi32, "GetLengthSid");
+ s_pfn_Get_Length_Sid = (GetLengthSid_Proc)
+ get_proc_addr (hm_advapi32, "GetLengthSid");
}
if (s_pfn_Get_Length_Sid == NULL)
{
@@ -1095,9 +1084,8 @@ copy_sid (DWORD destlen, PSID dest, PSID src)
{
g_b_init_copy_sid = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Copy_Sid =
- (CopySid_Proc) GetProcAddress (
- hm_advapi32, "CopySid");
+ s_pfn_Copy_Sid = (CopySid_Proc)
+ get_proc_addr (hm_advapi32, "CopySid");
}
if (s_pfn_Copy_Sid == NULL)
{
@@ -1121,9 +1109,9 @@ get_native_system_info (LPSYSTEM_INFO lpSystemInfo)
if (g_b_init_get_native_system_info == 0)
{
g_b_init_get_native_system_info = 1;
- s_pfn_Get_Native_System_Info =
- (GetNativeSystemInfo_Proc)GetProcAddress (GetModuleHandle ("kernel32.dll"),
- "GetNativeSystemInfo");
+ s_pfn_Get_Native_System_Info = (GetNativeSystemInfo_Proc)
+ get_proc_addr (GetModuleHandle ("kernel32.dll"),
+ "GetNativeSystemInfo");
}
if (s_pfn_Get_Native_System_Info != NULL)
s_pfn_Get_Native_System_Info (lpSystemInfo);
@@ -1145,9 +1133,9 @@ get_system_times (LPFILETIME lpIdleTime,
if (g_b_init_get_system_times == 0)
{
g_b_init_get_system_times = 1;
- s_pfn_Get_System_times =
- (GetSystemTimes_Proc)GetProcAddress (GetModuleHandle ("kernel32.dll"),
- "GetSystemTimes");
+ s_pfn_Get_System_times = (GetSystemTimes_Proc)
+ get_proc_addr (GetModuleHandle ("kernel32.dll"),
+ "GetSystemTimes");
}
if (s_pfn_Get_System_times == NULL)
return FALSE;
@@ -1175,9 +1163,9 @@ create_symbolic_link (LPCSTR lpSymlinkFilename,
if (g_b_init_create_symbolic_link_w == 0)
{
g_b_init_create_symbolic_link_w = 1;
- s_pfn_Create_Symbolic_LinkW =
- (CreateSymbolicLinkW_Proc)GetProcAddress (GetModuleHandle ("kernel32.dll"),
- "CreateSymbolicLinkW");
+ s_pfn_Create_Symbolic_LinkW = (CreateSymbolicLinkW_Proc)
+ get_proc_addr (GetModuleHandle ("kernel32.dll"),
+ "CreateSymbolicLinkW");
}
if (s_pfn_Create_Symbolic_LinkW == NULL)
{
@@ -1210,9 +1198,9 @@ create_symbolic_link (LPCSTR lpSymlinkFilename,
if (g_b_init_create_symbolic_link_a == 0)
{
g_b_init_create_symbolic_link_a = 1;
- s_pfn_Create_Symbolic_LinkA =
- (CreateSymbolicLinkA_Proc)GetProcAddress (GetModuleHandle ("kernel32.dll"),
- "CreateSymbolicLinkA");
+ s_pfn_Create_Symbolic_LinkA = (CreateSymbolicLinkA_Proc)
+ get_proc_addr (GetModuleHandle ("kernel32.dll"),
+ "CreateSymbolicLinkA");
}
if (s_pfn_Create_Symbolic_LinkA == NULL)
{
@@ -1255,9 +1243,9 @@ is_valid_security_descriptor (PSECURITY_DESCRIPTOR pSecurityDescriptor)
if (g_b_init_is_valid_security_descriptor == 0)
{
g_b_init_is_valid_security_descriptor = 1;
- s_pfn_Is_Valid_Security_Descriptor_Proc =
- (IsValidSecurityDescriptor_Proc)GetProcAddress (GetModuleHandle ("Advapi32.dll"),
- "IsValidSecurityDescriptor");
+ s_pfn_Is_Valid_Security_Descriptor_Proc = (IsValidSecurityDescriptor_Proc)
+ get_proc_addr (GetModuleHandle ("Advapi32.dll"),
+ "IsValidSecurityDescriptor");
}
if (s_pfn_Is_Valid_Security_Descriptor_Proc == NULL)
{
@@ -1289,12 +1277,14 @@ convert_sd_to_sddl (PSECURITY_DESCRIPTOR SecurityDescriptor,
g_b_init_convert_sd_to_sddl = 1;
#ifdef _UNICODE
s_pfn_Convert_SD_To_SDDL =
- (ConvertSecurityDescriptorToStringSecurityDescriptor_Proc)GetProcAddress (GetModuleHandle ("Advapi32.dll"),
- "ConvertSecurityDescriptorToStringSecurityDescriptorW");
+ (ConvertSecurityDescriptorToStringSecurityDescriptor_Proc)
+ get_proc_addr (GetModuleHandle ("Advapi32.dll"),
+ "ConvertSecurityDescriptorToStringSecurityDescriptorW");
#else
s_pfn_Convert_SD_To_SDDL =
- (ConvertSecurityDescriptorToStringSecurityDescriptor_Proc)GetProcAddress (GetModuleHandle ("Advapi32.dll"),
- "ConvertSecurityDescriptorToStringSecurityDescriptorA");
+ (ConvertSecurityDescriptorToStringSecurityDescriptor_Proc)
+ get_proc_addr (GetModuleHandle ("Advapi32.dll"),
+ "ConvertSecurityDescriptorToStringSecurityDescriptorA");
#endif
}
if (s_pfn_Convert_SD_To_SDDL == NULL)
@@ -1332,12 +1322,14 @@ convert_sddl_to_sd (LPCTSTR StringSecurityDescriptor,
g_b_init_convert_sddl_to_sd = 1;
#ifdef _UNICODE
s_pfn_Convert_SDDL_To_SD =
- (ConvertStringSecurityDescriptorToSecurityDescriptor_Proc)GetProcAddress (GetModuleHandle ("Advapi32.dll"),
- "ConvertStringSecurityDescriptorToSecurityDescriptorW");
+ (ConvertStringSecurityDescriptorToSecurityDescriptor_Proc)
+ get_proc_addr (GetModuleHandle ("Advapi32.dll"),
+ "ConvertStringSecurityDescriptorToSecurityDescriptorW");
#else
s_pfn_Convert_SDDL_To_SD =
- (ConvertStringSecurityDescriptorToSecurityDescriptor_Proc)GetProcAddress (GetModuleHandle ("Advapi32.dll"),
- "ConvertStringSecurityDescriptorToSecurityDescriptorA");
+ (ConvertStringSecurityDescriptorToSecurityDescriptor_Proc)
+ get_proc_addr (GetModuleHandle ("Advapi32.dll"),
+ "ConvertStringSecurityDescriptorToSecurityDescriptorA");
#endif
}
if (s_pfn_Convert_SDDL_To_SD == NULL)
@@ -1369,13 +1361,86 @@ get_adapters_info (PIP_ADAPTER_INFO pAdapterInfo, PULONG pOutBufLen)
hm_iphlpapi = LoadLibrary ("Iphlpapi.dll");
if (hm_iphlpapi)
s_pfn_Get_Adapters_Info = (GetAdaptersInfo_Proc)
- GetProcAddress (hm_iphlpapi, "GetAdaptersInfo");
+ get_proc_addr (hm_iphlpapi, "GetAdaptersInfo");
}
if (s_pfn_Get_Adapters_Info == NULL)
return ERROR_NOT_SUPPORTED;
return s_pfn_Get_Adapters_Info (pAdapterInfo, pOutBufLen);
}
+static LONG WINAPI
+reg_open_key_ex_w (HKEY hkey, LPCWSTR lpSubKey, DWORD ulOptions,
+ REGSAM samDesired, PHKEY phkResult)
+{
+ static RegOpenKeyExW_Proc s_pfn_Reg_Open_Key_Ex_w = NULL;
+ HMODULE hm_advapi32 = NULL;
+
+ if (is_windows_9x () == TRUE)
+ return ERROR_NOT_SUPPORTED;
+
+ if (g_b_init_reg_open_key_ex_w == 0)
+ {
+ g_b_init_reg_open_key_ex_w = 1;
+ hm_advapi32 = LoadLibrary ("Advapi32.dll");
+ if (hm_advapi32)
+ s_pfn_Reg_Open_Key_Ex_w = (RegOpenKeyExW_Proc)
+ get_proc_addr (hm_advapi32, "RegOpenKeyExW");
+ }
+ if (s_pfn_Reg_Open_Key_Ex_w == NULL)
+ return ERROR_NOT_SUPPORTED;
+ return s_pfn_Reg_Open_Key_Ex_w (hkey, lpSubKey, ulOptions,
+ samDesired, phkResult);
+}
+
+static LONG WINAPI
+reg_query_value_ex_w (HKEY hkey, LPCWSTR lpValueName, LPDWORD lpReserved,
+ LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData)
+{
+ static RegQueryValueExW_Proc s_pfn_Reg_Query_Value_Ex_w = NULL;
+ HMODULE hm_advapi32 = NULL;
+
+ if (is_windows_9x () == TRUE)
+ return ERROR_NOT_SUPPORTED;
+
+ if (g_b_init_reg_query_value_ex_w == 0)
+ {
+ g_b_init_reg_query_value_ex_w = 1;
+ hm_advapi32 = LoadLibrary ("Advapi32.dll");
+ if (hm_advapi32)
+ s_pfn_Reg_Query_Value_Ex_w = (RegQueryValueExW_Proc)
+ get_proc_addr (hm_advapi32, "RegQueryValueExW");
+ }
+ if (s_pfn_Reg_Query_Value_Ex_w == NULL)
+ return ERROR_NOT_SUPPORTED;
+ return s_pfn_Reg_Query_Value_Ex_w (hkey, lpValueName, lpReserved,
+ lpType, lpData, lpcbData);
+}
+
+static DWORD WINAPI
+expand_environment_strings_w (LPCWSTR lpSrc, LPWSTR lpDst, DWORD nSize)
+{
+ static ExpandEnvironmentStringsW_Proc s_pfn_Expand_Environment_Strings_w = NULL;
+ HMODULE hm_kernel32 = NULL;
+
+ if (is_windows_9x () == TRUE)
+ return ERROR_NOT_SUPPORTED;
+
+ if (g_b_init_expand_environment_strings_w == 0)
+ {
+ g_b_init_expand_environment_strings_w = 1;
+ hm_kernel32 = LoadLibrary ("Kernel32.dll");
+ if (hm_kernel32)
+ s_pfn_Expand_Environment_Strings_w = (ExpandEnvironmentStringsW_Proc)
+ get_proc_addr (hm_kernel32, "ExpandEnvironmentStringsW");
+ }
+ if (s_pfn_Expand_Environment_Strings_w == NULL)
+ {
+ errno = ENOSYS;
+ return FALSE;
+ }
+ return s_pfn_Expand_Environment_Strings_w (lpSrc, lpDst, nSize);
+}
+
/* Return 1 if P is a valid pointer to an object of size SIZE. Return
@@ -1706,7 +1771,40 @@ filename_from_ansi (const char *fn_in, char *fn_out)
/* The directory where we started, in UTF-8. */
static char startup_dir[MAX_UTF8_PATH];
-/* Get the current working directory. */
+/* Get the current working directory. The caller must arrange for CWD
+ to be allocated with enough space to hold a 260-char directory name
+ in UTF-8. IOW, the space should be at least MAX_UTF8_PATH bytes. */
+static void
+w32_get_current_directory (char *cwd)
+{
+ /* FIXME: Do we need to resolve possible symlinks in startup_dir?
+ Does it matter anywhere in Emacs? */
+ if (w32_unicode_filenames)
+ {
+ wchar_t wstartup_dir[MAX_PATH];
+
+ if (!GetCurrentDirectoryW (MAX_PATH, wstartup_dir))
+ emacs_abort ();
+ filename_from_utf16 (wstartup_dir, cwd);
+ }
+ else
+ {
+ char astartup_dir[MAX_PATH];
+
+ if (!GetCurrentDirectoryA (MAX_PATH, astartup_dir))
+ emacs_abort ();
+ filename_from_ansi (astartup_dir, cwd);
+ }
+}
+
+/* For external callers. Used by 'main' in emacs.c. */
+void
+w32_init_current_directory (void)
+{
+ w32_get_current_directory (startup_dir);
+}
+
+/* Return the original directory where Emacs started. */
char *
getcwd (char *dir, int dirsize)
{
@@ -1978,7 +2076,9 @@ getpwuid (unsigned uid)
struct group *
getgrgid (gid_t gid)
{
- return &dflt_group;
+ if (gid == dflt_passwd.pw_gid)
+ return &dflt_group;
+ return NULL;
}
struct passwd *
@@ -1991,7 +2091,29 @@ getpwnam (char *name)
return pw;
if (xstrcasecmp (name, pw->pw_name))
- return NULL;
+ {
+ /* Mimic what init_editfns does with these environment
+ variables, so that the likes of ~USER is recognized by
+ expand-file-name even if $LOGNAME gives a name different from
+ the real username produced by the process token. */
+ char *logname = getenv ("LOGNAME");
+ char *username = getenv ("USERNAME");
+ if ((logname || username)
+ && xstrcasecmp (name, logname ? logname : username) == 0)
+ {
+ static struct passwd alias_user;
+ static char alias_name[PASSWD_FIELD_SIZE];
+
+ memcpy (&alias_user, &dflt_passwd, sizeof dflt_passwd);
+ alias_name[0] = '\0';
+ strncat (alias_name, logname ? logname : username,
+ PASSWD_FIELD_SIZE - 1);
+ alias_user.pw_name = alias_name;
+ pw = &alias_user;
+ }
+ else
+ return NULL;
+ }
return pw;
}
@@ -2728,7 +2850,8 @@ init_environment (char ** argv)
MSIE 5. */
ShGetFolderPath_fn get_folder_path;
get_folder_path = (ShGetFolderPath_fn)
- GetProcAddress (GetModuleHandle ("shell32.dll"), "SHGetFolderPathA");
+ get_proc_addr (GetModuleHandle ("shell32.dll"),
+ "SHGetFolderPathA");
if (get_folder_path != NULL)
{
@@ -2859,8 +2982,7 @@ init_environment (char ** argv)
if (strcmp (env_vars[i].name, "HOME") == 0 && !appdata)
Vdelayed_warnings_list
= Fcons
- (listn (CONSTYPE_HEAP, 2,
- intern ("initialization"), build_string
+ (list2 (intern ("initialization"), build_string
("Use of `C:\\.emacs' without defining `HOME'\n"
"in the environment is deprecated, "
"see `Windows HOME' in the Emacs manual.")),
@@ -2929,24 +3051,7 @@ init_environment (char ** argv)
}
/* Remember the initial working directory for getcwd. */
- /* FIXME: Do we need to resolve possible symlinks in startup_dir?
- Does it matter anywhere in Emacs? */
- if (w32_unicode_filenames)
- {
- wchar_t wstartup_dir[MAX_PATH];
-
- if (!GetCurrentDirectoryW (MAX_PATH, wstartup_dir))
- emacs_abort ();
- filename_from_utf16 (wstartup_dir, startup_dir);
- }
- else
- {
- char astartup_dir[MAX_PATH];
-
- if (!GetCurrentDirectoryA (MAX_PATH, astartup_dir))
- emacs_abort ();
- filename_from_ansi (astartup_dir, startup_dir);
- }
+ w32_get_current_directory (startup_dir);
{
static char modname[MAX_PATH];
@@ -3130,22 +3235,7 @@ GetCachedVolumeInformation (char * root_dir)
/* NULL for root_dir means use root from current directory. */
if (root_dir == NULL)
{
- if (w32_unicode_filenames)
- {
- wchar_t curdirw[MAX_PATH];
-
- if (GetCurrentDirectoryW (MAX_PATH, curdirw) == 0)
- return NULL;
- filename_from_utf16 (curdirw, default_root);
- }
- else
- {
- char curdira[MAX_PATH];
-
- if (GetCurrentDirectoryA (MAX_PATH, curdira) == 0)
- return NULL;
- filename_from_ansi (curdira, default_root);
- }
+ w32_get_current_directory (default_root);
parse_root (default_root, (const char **)&root_dir);
*root_dir = 0;
root_dir = default_root;
@@ -5851,7 +5941,7 @@ is_symlink (const char *filename)
/* If NAME identifies a symbolic link, copy into BUF the file name of
the symlink's target. Copy at most BUF_SIZE bytes, and do NOT
- null-terminate the target name, even if it fits. Return the number
+ NUL-terminate the target name, even if it fits. Return the number
of bytes copied, or -1 if NAME is not a symlink or any error was
encountered while resolving it. The file name copied into BUF is
encoded in the current ANSI codepage. */
@@ -5955,10 +6045,10 @@ readlink (const char *name, char *buf, size_t buf_size)
size_t size_to_copy = buf_size;
/* According to MSDN, PrintNameLength does not include the
- terminating null character. */
+ terminating NUL character. */
lwname = alloca ((lwname_len + 1) * sizeof(WCHAR));
memcpy (lwname, lwname_src, lwname_len);
- lwname[lwname_len/sizeof(WCHAR)] = 0; /* null-terminate */
+ lwname[lwname_len/sizeof(WCHAR)] = 0; /* NUL-terminate */
filename_from_utf16 (lwname, resolved);
dostounix_filename (resolved);
lname_size = strlen (resolved) + 1;
@@ -6560,8 +6650,8 @@ create_toolhelp32_snapshot (DWORD Flags, DWORD Ignored)
{
g_b_init_create_toolhelp32_snapshot = 1;
s_pfn_Create_Toolhelp32_Snapshot = (CreateToolhelp32Snapshot_Proc)
- GetProcAddress (GetModuleHandle ("kernel32.dll"),
- "CreateToolhelp32Snapshot");
+ get_proc_addr (GetModuleHandle ("kernel32.dll"),
+ "CreateToolhelp32Snapshot");
}
if (s_pfn_Create_Toolhelp32_Snapshot == NULL)
{
@@ -6579,8 +6669,8 @@ process32_first (HANDLE hSnapshot, LPPROCESSENTRY32 lppe)
{
g_b_init_process32_first = 1;
s_pfn_Process32_First = (Process32First_Proc)
- GetProcAddress (GetModuleHandle ("kernel32.dll"),
- "Process32First");
+ get_proc_addr (GetModuleHandle ("kernel32.dll"),
+ "Process32First");
}
if (s_pfn_Process32_First == NULL)
{
@@ -6598,8 +6688,8 @@ process32_next (HANDLE hSnapshot, LPPROCESSENTRY32 lppe)
{
g_b_init_process32_next = 1;
s_pfn_Process32_Next = (Process32Next_Proc)
- GetProcAddress (GetModuleHandle ("kernel32.dll"),
- "Process32Next");
+ get_proc_addr (GetModuleHandle ("kernel32.dll"),
+ "Process32Next");
}
if (s_pfn_Process32_Next == NULL)
{
@@ -6625,8 +6715,8 @@ open_thread_token (HANDLE ThreadHandle,
{
g_b_init_open_thread_token = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Open_Thread_Token =
- (OpenThreadToken_Proc) GetProcAddress (hm_advapi32, "OpenThreadToken");
+ s_pfn_Open_Thread_Token = (OpenThreadToken_Proc)
+ get_proc_addr (hm_advapi32, "OpenThreadToken");
}
if (s_pfn_Open_Thread_Token == NULL)
{
@@ -6655,8 +6745,8 @@ impersonate_self (SECURITY_IMPERSONATION_LEVEL ImpersonationLevel)
{
g_b_init_impersonate_self = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Impersonate_Self =
- (ImpersonateSelf_Proc) GetProcAddress (hm_advapi32, "ImpersonateSelf");
+ s_pfn_Impersonate_Self = (ImpersonateSelf_Proc)
+ get_proc_addr (hm_advapi32, "ImpersonateSelf");
}
if (s_pfn_Impersonate_Self == NULL)
{
@@ -6678,8 +6768,8 @@ revert_to_self (void)
{
g_b_init_revert_to_self = 1;
hm_advapi32 = LoadLibrary ("Advapi32.dll");
- s_pfn_Revert_To_Self =
- (RevertToSelf_Proc) GetProcAddress (hm_advapi32, "RevertToSelf");
+ s_pfn_Revert_To_Self = (RevertToSelf_Proc)
+ get_proc_addr (hm_advapi32, "RevertToSelf");
}
if (s_pfn_Revert_To_Self == NULL)
{
@@ -6705,7 +6795,7 @@ get_process_memory_info (HANDLE h_proc,
hm_psapi = LoadLibrary ("Psapi.dll");
if (hm_psapi)
s_pfn_Get_Process_Memory_Info = (GetProcessMemoryInfo_Proc)
- GetProcAddress (hm_psapi, "GetProcessMemoryInfo");
+ get_proc_addr (hm_psapi, "GetProcessMemoryInfo");
}
if (s_pfn_Get_Process_Memory_Info == NULL)
{
@@ -6730,8 +6820,8 @@ get_process_working_set_size (HANDLE h_proc,
{
g_b_init_get_process_working_set_size = 1;
s_pfn_Get_Process_Working_Set_Size = (GetProcessWorkingSetSize_Proc)
- GetProcAddress (GetModuleHandle ("kernel32.dll"),
- "GetProcessWorkingSetSize");
+ get_proc_addr (GetModuleHandle ("kernel32.dll"),
+ "GetProcessWorkingSetSize");
}
if (s_pfn_Get_Process_Working_Set_Size == NULL)
{
@@ -6753,8 +6843,8 @@ global_memory_status (MEMORYSTATUS *buf)
{
g_b_init_global_memory_status = 1;
s_pfn_Global_Memory_Status = (GlobalMemoryStatus_Proc)
- GetProcAddress (GetModuleHandle ("kernel32.dll"),
- "GlobalMemoryStatus");
+ get_proc_addr (GetModuleHandle ("kernel32.dll"),
+ "GlobalMemoryStatus");
}
if (s_pfn_Global_Memory_Status == NULL)
{
@@ -6776,8 +6866,8 @@ global_memory_status_ex (MEMORY_STATUS_EX *buf)
{
g_b_init_global_memory_status_ex = 1;
s_pfn_Global_Memory_Status_Ex = (GlobalMemoryStatusEx_Proc)
- GetProcAddress (GetModuleHandle ("kernel32.dll"),
- "GlobalMemoryStatusEx");
+ get_proc_addr (GetModuleHandle ("kernel32.dll"),
+ "GlobalMemoryStatusEx");
}
if (s_pfn_Global_Memory_Status_Ex == NULL)
{
@@ -6805,7 +6895,7 @@ list_system_processes (void)
res = process32_next (h_snapshot, &proc_entry))
{
proc_id = proc_entry.th32ProcessID;
- proclist = Fcons (make_fixnum_or_float (proc_id), proclist);
+ proclist = Fcons (INT_TO_INTEGER (proc_id), proclist);
}
CloseHandle (h_snapshot);
@@ -6963,8 +7053,8 @@ system_process_attributes (Lisp_Object pid)
double pcpu;
BOOL result = FALSE;
- CHECK_NUMBER_OR_FLOAT (pid);
- proc_id = FLOATP (pid) ? XFLOAT_DATA (pid) : XINT (pid);
+ CHECK_NUMBER (pid);
+ proc_id = FLOATP (pid) ? XFLOAT_DATA (pid) : XFIXNUM (pid);
h_snapshot = create_toolhelp32_snapshot (TH32CS_SNAPPROCESS, 0);
@@ -6993,12 +7083,12 @@ system_process_attributes (Lisp_Object pid)
}
attrs = Fcons (Fcons (Qcomm, decoded_cmd), attrs);
attrs = Fcons (Fcons (Qppid,
- make_fixnum_or_float (pe.th32ParentProcessID)),
+ INT_TO_INTEGER (pe.th32ParentProcessID)),
attrs);
- attrs = Fcons (Fcons (Qpri, make_number (pe.pcPriClassBase)),
+ attrs = Fcons (Fcons (Qpri, make_fixnum (pe.pcPriClassBase)),
attrs);
attrs = Fcons (Fcons (Qthcount,
- make_fixnum_or_float (pe.cntThreads)),
+ INT_TO_INTEGER (pe.cntThreads)),
attrs);
found_proc = 1;
break;
@@ -7146,12 +7236,12 @@ system_process_attributes (Lisp_Object pid)
CloseHandle (token);
}
- attrs = Fcons (Fcons (Qeuid, make_fixnum_or_float (euid)), attrs);
+ attrs = Fcons (Fcons (Qeuid, INT_TO_INTEGER (euid)), attrs);
tem = make_unibyte_string (uname, ulength);
attrs = Fcons (Fcons (Quser,
code_convert_string_norecord (tem, Vlocale_coding_system, 0)),
attrs);
- attrs = Fcons (Fcons (Qegid, make_fixnum_or_float (egid)), attrs);
+ attrs = Fcons (Fcons (Qegid, INT_TO_INTEGER (egid)), attrs);
tem = make_unibyte_string (gname, glength);
attrs = Fcons (Fcons (Qgroup,
code_convert_string_norecord (tem, Vlocale_coding_system, 0)),
@@ -7182,12 +7272,12 @@ system_process_attributes (Lisp_Object pid)
SIZE_T rss = mem_ex.WorkingSetSize / 1024;
attrs = Fcons (Fcons (Qmajflt,
- make_fixnum_or_float (mem_ex.PageFaultCount)),
+ INT_TO_INTEGER (mem_ex.PageFaultCount)),
attrs);
attrs = Fcons (Fcons (Qvsize,
- make_fixnum_or_float (mem_ex.PrivateUsage / 1024)),
+ INT_TO_INTEGER (mem_ex.PrivateUsage / 1024)),
attrs);
- attrs = Fcons (Fcons (Qrss, make_fixnum_or_float (rss)), attrs);
+ attrs = Fcons (Fcons (Qrss, INT_TO_INTEGER (rss)), attrs);
if (totphys)
attrs = Fcons (Fcons (Qpmem, make_float (100. * rss / totphys)), attrs);
}
@@ -7197,9 +7287,9 @@ system_process_attributes (Lisp_Object pid)
SIZE_T rss = mem_ex.WorkingSetSize / 1024;
attrs = Fcons (Fcons (Qmajflt,
- make_fixnum_or_float (mem.PageFaultCount)),
+ INT_TO_INTEGER (mem.PageFaultCount)),
attrs);
- attrs = Fcons (Fcons (Qrss, make_fixnum_or_float (rss)), attrs);
+ attrs = Fcons (Fcons (Qrss, INT_TO_INTEGER (rss)), attrs);
if (totphys)
attrs = Fcons (Fcons (Qpmem, make_float (100. * rss / totphys)), attrs);
}
@@ -7208,7 +7298,7 @@ system_process_attributes (Lisp_Object pid)
{
DWORD rss = maxrss / 1024;
- attrs = Fcons (Fcons (Qrss, make_fixnum_or_float (maxrss / 1024)), attrs);
+ attrs = Fcons (Fcons (Qrss, INT_TO_INTEGER (maxrss / 1024)), attrs);
if (totphys)
attrs = Fcons (Fcons (Qpmem, make_float (100. * rss / totphys)), attrs);
}
@@ -7350,8 +7440,8 @@ init_winsock (int load_now)
return TRUE;
pfn_SetHandleInformation
- = (void *) GetProcAddress (GetModuleHandle ("kernel32.dll"),
- "SetHandleInformation");
+ = (void *) get_proc_addr (GetModuleHandle ("kernel32.dll"),
+ "SetHandleInformation");
winsock_lib = LoadLibrary ("Ws2_32.dll");
@@ -7360,7 +7450,7 @@ init_winsock (int load_now)
/* dynamically link to socket functions */
#define LOAD_PROC(fn) \
- if ((pfn_##fn = (void *) GetProcAddress (winsock_lib, #fn)) == NULL) \
+ if ((pfn_##fn = (void *) get_proc_addr (winsock_lib, #fn)) == NULL) \
goto fail;
LOAD_PROC (WSAStartup);
@@ -7395,8 +7485,8 @@ init_winsock (int load_now)
#undef LOAD_PROC
/* Try loading functions not available before XP. */
- pfn_getaddrinfo = (void *) GetProcAddress (winsock_lib, "getaddrinfo");
- pfn_freeaddrinfo = (void *) GetProcAddress (winsock_lib, "freeaddrinfo");
+ pfn_getaddrinfo = (void *) get_proc_addr (winsock_lib, "getaddrinfo");
+ pfn_freeaddrinfo = (void *) get_proc_addr (winsock_lib, "freeaddrinfo");
/* Paranoia: these two functions should go together, so if one
is absent, we cannot use the other. */
if (pfn_getaddrinfo == NULL)
@@ -8391,13 +8481,14 @@ _sys_read_ahead (int fd)
{
rc = _read (fd, &cp->chr, sizeof (char));
- /* Give subprocess time to buffer some more output for us before
- reporting that input is available; we need this because Windows 95
- connects DOS programs to pipes by making the pipe appear to be
- the normal console stdout - as a result most DOS programs will
- write to stdout without buffering, ie. one character at a
- time. Even some W32 programs do this - "dir" in a command
- shell on NT is very slow if we don't do this. */
+ /* Optionally give subprocess time to buffer some more output
+ for us before reporting that input is available; we may need
+ this because Windows 9X connects DOS programs to pipes by
+ making the pipe appear to be the normal console stdout -- as
+ a result most DOS programs will write to stdout without
+ buffering, i.e., one character at a time. Even some W32
+ programs do this -- "dir" in a command shell on NT is very
+ slow if we don't do this. */
if (rc > 0)
{
int wait = w32_pipe_read_delay;
@@ -9135,7 +9226,7 @@ network_interface_get_info (Lisp_Object ifname)
res);
else if (strcmp (namebuf, SSDATA (ifname)) == 0)
{
- Lisp_Object hwaddr = Fmake_vector (make_number (6), Qnil);
+ Lisp_Object hwaddr = Fmake_vector (make_fixnum (6), Qnil);
register struct Lisp_Vector *p = XVECTOR (hwaddr);
Lisp_Object flags = Qnil;
int n;
@@ -9164,11 +9255,11 @@ network_interface_get_info (Lisp_Object ifname)
/* Hardware address and its family. */
for (n = 0; n < adapter->AddressLength; n++)
- p->contents[n] = make_number ((int) adapter->Address[n]);
+ p->contents[n] = make_fixnum ((int) adapter->Address[n]);
/* Windows does not support AF_LINK or AF_PACKET family
of addresses. Use an arbitrary family number that is
identical to what GNU/Linux returns. */
- res = Fcons (Fcons (make_number (1), hwaddr), res);
+ res = Fcons (Fcons (make_fixnum (1), hwaddr), res);
/* Network mask. */
sa.sin_family = AF_INET;
@@ -9230,9 +9321,9 @@ network_interface_get_info (Lisp_Object ifname)
Fcons (intern ("up"), Qnil))), Qnil);
/* 772 is what 3 different GNU/Linux systems report for
the loopback interface. */
- res = Fcons (Fcons (make_number (772),
- Fmake_vector (make_number (6),
- make_number (0))),
+ res = Fcons (Fcons (make_fixnum (772),
+ Fmake_vector (make_fixnum (6),
+ make_fixnum (0))),
res);
sa.sin_addr.s_addr = sys_inet_addr ("255.0.0.0");
res = Fcons (conv_sockaddr_to_lisp ((struct sockaddr *) &sa,
@@ -9270,6 +9361,215 @@ network_interface_info (Lisp_Object ifname)
}
+/* Workhorse for w32-read-registry, which see. */
+Lisp_Object
+w32_read_registry (HKEY rootkey, Lisp_Object lkey, Lisp_Object lname)
+{
+ HKEY hkey = NULL;
+ LONG status;
+ DWORD vsize, vtype;
+ LPBYTE pvalue;
+ Lisp_Object val, retval;
+ const char *key, *value_name = NULL;
+ /* The following sizes are according to size limitations
+ documented in MSDN. */
+ wchar_t key_w[255+1];
+ wchar_t value_w[16*1024+1];
+ bool use_unicode = is_windows_9x () == 0;
+
+ if (use_unicode)
+ {
+ Lisp_Object encoded_key, encoded_vname;
+
+ /* Convert input strings to UTF-16. */
+ encoded_key = code_convert_string_norecord (lkey, Qutf_16le, 1);
+ memcpy (key_w, SSDATA (encoded_key), SBYTES (encoded_key));
+ /* wchar_t strings need to be terminated by 2 NUL bytes. */
+ key_w [SBYTES (encoded_key)/2] = L'\0';
+ encoded_vname = code_convert_string_norecord (lname, Qutf_16le, 1);
+ memcpy (value_w, SSDATA (encoded_vname), SBYTES (encoded_vname));
+ value_w[SBYTES (encoded_vname)/2] = L'\0';
+
+ /* Mirror the slashes, if required. */
+ for (int i = 0; i < SBYTES (encoded_key)/2; i++)
+ {
+ if (key_w[i] == L'/')
+ key_w[i] = L'\\';
+ }
+ if ((status = reg_open_key_ex_w (rootkey, key_w, 0,
+ KEY_READ, &hkey)) == ERROR_NOT_SUPPORTED
+ || (status = reg_query_value_ex_w (hkey, value_w, NULL, NULL, NULL,
+ &vsize)) == ERROR_NOT_SUPPORTED
+ || status != ERROR_SUCCESS)
+ {
+ if (hkey)
+ RegCloseKey (hkey);
+ if (status != ERROR_NOT_SUPPORTED)
+ return Qnil;
+ use_unicode = 0; /* fall back to non-Unicode calls */
+ }
+ }
+ if (!use_unicode)
+ {
+ /* Need to copy LKEY because we are going to modify it. */
+ Lisp_Object local_lkey = Fcopy_sequence (lkey);
+
+ /* Mirror the slashes. Note: this has to be done before
+ encoding, because after encoding we cannot guarantee that a
+ slash '/' always stands for itself, it could be part of some
+ multibyte sequence. */
+ for (int i = 0; i < SBYTES (local_lkey); i++)
+ {
+ if (SSDATA (local_lkey)[i] == '/')
+ SSDATA (local_lkey)[i] = '\\';
+ }
+
+ key = SSDATA (ENCODE_SYSTEM (local_lkey));
+ value_name = SSDATA (ENCODE_SYSTEM (lname));
+
+ if ((status = RegOpenKeyEx (rootkey, key, 0,
+ KEY_READ, &hkey)) != ERROR_SUCCESS
+ || (status = RegQueryValueEx (hkey, value_name, NULL,
+ NULL, NULL, &vsize)) != ERROR_SUCCESS)
+ {
+ if (hkey)
+ RegCloseKey (hkey);
+ return Qnil;
+ }
+ }
+
+ pvalue = xzalloc (vsize);
+ if (use_unicode)
+ status = reg_query_value_ex_w (hkey, value_w, NULL, &vtype, pvalue, &vsize);
+ else
+ status = RegQueryValueEx (hkey, value_name, NULL, &vtype, pvalue, &vsize);
+ if (status != ERROR_SUCCESS)
+ {
+ xfree (pvalue);
+ RegCloseKey (hkey);
+ return Qnil;
+ }
+
+ switch (vtype)
+ {
+ case REG_NONE:
+ retval = Qt;
+ break;
+ case REG_DWORD:
+ retval = INT_TO_INTEGER (*((DWORD *)pvalue));
+ break;
+ case REG_QWORD:
+ retval = INT_TO_INTEGER (*((long long *)pvalue));
+ break;
+ case REG_BINARY:
+ {
+ int i;
+ unsigned char *dbuf = (unsigned char *)pvalue;
+
+ val = make_uninit_vector (vsize);
+ for (i = 0; i < vsize; i++)
+ ASET (val, i, make_fixnum (dbuf[i]));
+
+ retval = val;
+ break;
+ }
+ case REG_SZ:
+ if (use_unicode)
+ {
+ /* pvalue ends with 2 NUL bytes, but we need only one,
+ and AUTO_STRING_WITH_LEN will add it. */
+ if (pvalue[vsize - 1] == '\0')
+ vsize -= 2;
+ AUTO_STRING_WITH_LEN (sval, (char *)pvalue, vsize);
+ retval = from_unicode (sval);
+ }
+ else
+ {
+ /* Don't waste a byte on the terminating NUL character,
+ since make_unibyte_string will add one anyway. */
+ if (pvalue[vsize - 1] == '\0')
+ vsize--;
+ retval = DECODE_SYSTEM (make_unibyte_string (pvalue, vsize));
+ }
+ break;
+ case REG_EXPAND_SZ:
+ if (use_unicode)
+ {
+ wchar_t expanded_w[32*1024];
+ DWORD dsize = sizeof (expanded_w) / 2;
+ DWORD produced = expand_environment_strings_w ((wchar_t *)pvalue,
+ expanded_w,
+ dsize);
+ if (produced > 0 && produced < dsize)
+ {
+ AUTO_STRING_WITH_LEN (sval, (char *)expanded_w,
+ produced * 2 - 2);
+ retval = from_unicode (sval);
+ }
+ else
+ {
+ if (pvalue[vsize - 1] == '\0')
+ vsize -= 2;
+ AUTO_STRING_WITH_LEN (sval, (char *)pvalue, vsize);
+ retval = from_unicode (sval);
+ }
+ }
+ else
+ {
+ char expanded[32*1024]; /* size limitation according to MSDN */
+ DWORD produced = ExpandEnvironmentStrings ((char *)pvalue,
+ expanded,
+ sizeof (expanded));
+ if (produced > 0 && produced < sizeof (expanded))
+ retval = make_unibyte_string (expanded, produced - 1);
+ else
+ {
+ if (pvalue[vsize - 1] == '\0')
+ vsize--;
+ retval = make_unibyte_string (pvalue, vsize);
+ }
+
+ retval = DECODE_SYSTEM (retval);
+ }
+ break;
+ case REG_MULTI_SZ:
+ if (use_unicode)
+ {
+ wchar_t *wp = (wchar_t *)pvalue;
+
+ val = Qnil;
+ do {
+ size_t wslen = wcslen (wp);
+ AUTO_STRING_WITH_LEN (sval, (char *)wp, wslen * 2);
+ val = Fcons (from_unicode (sval), val);
+ wp += wslen + 1;
+ } while (*wp);
+ }
+ else
+ {
+ char *p = (char *)pvalue;
+
+ val = Qnil;
+ do {
+ size_t slen = strlen (p);
+
+ val = Fcons (DECODE_SYSTEM (make_unibyte_string (p, slen)), val);
+ p += slen + 1;
+ } while (*p);
+ }
+
+ retval = Fnreverse (val);
+ break;
+ default:
+ error ("unsupported registry data type: %d", (int)vtype);
+ }
+
+ xfree (pvalue);
+ RegCloseKey (hkey);
+ return retval;
+}
+
+
/* The Windows CRT functions are "optimized for speed", so they don't
check for timezone and DST changes if they were last called less
than 1 minute ago (see http://support.microsoft.com/kb/821231). So
@@ -9604,10 +9904,10 @@ maybe_load_unicows_dll (void)
pointers, and assign the correct addresses to these
pointers at program startup (see emacs.c, which calls
this function early on). */
- pMultiByteToWideChar =
- (MultiByteToWideChar_Proc)GetProcAddress (ret, "MultiByteToWideChar");
- pWideCharToMultiByte =
- (WideCharToMultiByte_Proc)GetProcAddress (ret, "WideCharToMultiByte");
+ pMultiByteToWideChar = (MultiByteToWideChar_Proc)
+ get_proc_addr (ret, "MultiByteToWideChar");
+ pWideCharToMultiByte = (WideCharToMultiByte_Proc)
+ get_proc_addr (ret, "WideCharToMultiByte");
multiByteToWideCharFlags = MB_ERR_INVALID_CHARS;
return ret;
}
@@ -9647,6 +9947,40 @@ maybe_load_unicows_dll (void)
}
}
+/* Relocate a directory specified by epaths.h, using the location of
+ our binary as an anchor. Note: this runs early during startup, so
+ we cannot rely on the usual file-related facilities, and in
+ particular the argument is assumed to be a unibyte string in system
+ codepage encoding. */
+const char *
+w32_relocate (const char *epath_dir)
+{
+ if (strncmp (epath_dir, "%emacs_dir%/", 12) == 0)
+ {
+ static char relocated_dir[MAX_PATH];
+
+ /* Replace "%emacs_dir%" with the parent of the directory where
+ our binary lives. Note that init_environment was not yet
+ called, so we cannot rely on emacs_dir being set in the
+ environment. */
+ if (GetModuleFileNameA (NULL, relocated_dir, MAX_PATH))
+ {
+ char *p = _mbsrchr (relocated_dir, '\\');
+
+ if (p)
+ {
+ *p = '\0';
+ if ((p = _mbsrchr (relocated_dir, '\\')) != NULL)
+ {
+ strcpy (p, epath_dir + 11);
+ epath_dir = relocated_dir;
+ }
+ }
+ }
+ }
+ return epath_dir;
+}
+
/*
globals_of_w32 is used to initialize those global variables that
must always be initialized on startup even when the global variable
@@ -9658,7 +9992,7 @@ globals_of_w32 (void)
HMODULE kernel32 = GetModuleHandle ("kernel32.dll");
get_process_times_fn = (GetProcessTimes_Proc)
- GetProcAddress (kernel32, "GetProcessTimes");
+ get_proc_addr (kernel32, "GetProcessTimes");
DEFSYM (QCloaded_from, ":loaded-from");
@@ -9700,6 +10034,9 @@ globals_of_w32 (void)
g_b_init_set_named_security_info_w = 0;
g_b_init_set_named_security_info_a = 0;
g_b_init_get_adapters_info = 0;
+ g_b_init_reg_open_key_ex_w = 0;
+ g_b_init_reg_query_value_ex_w = 0;
+ g_b_init_expand_environment_strings_w = 0;
g_b_init_compare_string_w = 0;
g_b_init_debug_break_process = 0;
num_of_processors = 0;
@@ -9815,8 +10152,8 @@ serial_configure (struct Lisp_Process *p, Lisp_Object contact)
tem = Fplist_get (contact, QCspeed);
else
tem = Fplist_get (p->childp, QCspeed);
- CHECK_NUMBER (tem);
- dcb.BaudRate = XINT (tem);
+ CHECK_FIXNUM (tem);
+ dcb.BaudRate = XFIXNUM (tem);
childp2 = Fplist_put (childp2, QCspeed, tem);
/* Configure bytesize. */
@@ -9825,12 +10162,12 @@ serial_configure (struct Lisp_Process *p, Lisp_Object contact)
else
tem = Fplist_get (p->childp, QCbytesize);
if (NILP (tem))
- tem = make_number (8);
- CHECK_NUMBER (tem);
- if (XINT (tem) != 7 && XINT (tem) != 8)
+ tem = make_fixnum (8);
+ CHECK_FIXNUM (tem);
+ if (XFIXNUM (tem) != 7 && XFIXNUM (tem) != 8)
error (":bytesize must be nil (8), 7, or 8");
- dcb.ByteSize = XINT (tem);
- summary[0] = XINT (tem) + '0';
+ dcb.ByteSize = XFIXNUM (tem);
+ summary[0] = XFIXNUM (tem) + '0';
childp2 = Fplist_put (childp2, QCbytesize, tem);
/* Configure parity. */
@@ -9869,14 +10206,14 @@ serial_configure (struct Lisp_Process *p, Lisp_Object contact)
else
tem = Fplist_get (p->childp, QCstopbits);
if (NILP (tem))
- tem = make_number (1);
- CHECK_NUMBER (tem);
- if (XINT (tem) != 1 && XINT (tem) != 2)
+ tem = make_fixnum (1);
+ CHECK_FIXNUM (tem);
+ if (XFIXNUM (tem) != 1 && XFIXNUM (tem) != 2)
error (":stopbits must be nil (1 stopbit), 1, or 2");
- summary[2] = XINT (tem) + '0';
- if (XINT (tem) == 1)
+ summary[2] = XFIXNUM (tem) + '0';
+ if (XFIXNUM (tem) == 1)
dcb.StopBits = ONESTOPBIT;
- else if (XINT (tem) == 2)
+ else if (XFIXNUM (tem) == 2)
dcb.StopBits = TWOSTOPBITS;
childp2 = Fplist_put (childp2, QCstopbits, tem);
diff --git a/src/w32.h b/src/w32.h
index 7194ca2d1c8..3790583bfc8 100644
--- a/src/w32.h
+++ b/src/w32.h
@@ -185,6 +185,8 @@ extern MultiByteToWideChar_Proc pMultiByteToWideChar;
extern WideCharToMultiByte_Proc pWideCharToMultiByte;
extern DWORD multiByteToWideCharFlags;
+extern const char *w32_relocate (const char *);
+
extern void init_environment (char **);
extern void check_windows_init_file (void);
extern void syms_of_ntproc (void);
@@ -195,11 +197,13 @@ extern int filename_from_ansi (const char *, char *);
extern int filename_to_ansi (const char *, char *);
extern int filename_from_utf16 (const wchar_t *, char *);
extern int filename_to_utf16 (const char *, wchar_t *);
+extern Lisp_Object w32_get_internal_run_time (void);
extern void w32_init_file_name_codepage (void);
extern int codepage_for_filenames (CPINFO *);
extern Lisp_Object ansi_encode_filename (Lisp_Object);
extern int w32_copy_file (const char *, const char *, int, int, int);
extern int w32_accessible_directory_p (const char *, ptrdiff_t);
+extern void w32_init_current_directory (void);
extern BOOL init_winsock (int load_now);
extern void srandom (int);
@@ -227,6 +231,8 @@ extern int w32_compare_strings (const char *, const char *, char *, int);
/* Return a cryptographically secure seed for PRNG. */
extern int w32_init_random (void *, ptrdiff_t);
+extern Lisp_Object w32_read_registry (HKEY, Lisp_Object, Lisp_Object);
+
#ifdef HAVE_GNUTLS
#include <gnutls/gnutls.h>
@@ -239,17 +245,4 @@ extern ssize_t emacs_gnutls_push (gnutls_transport_ptr_t p,
const void* buf, size_t sz);
#endif /* HAVE_GNUTLS */
-/* Definine a function that will be loaded from a DLL. */
-#define DEF_DLL_FN(type, func, args) static type (FAR CDECL *fn_##func) args
-
-/* Load a function from the DLL. */
-#define LOAD_DLL_FN(lib, func) \
- do \
- { \
- fn_##func = (void *) GetProcAddress (lib, #func); \
- if (!fn_##func) \
- return false; \
- } \
- while (false)
-
#endif /* EMACS_W32_H */
diff --git a/src/w32common.h b/src/w32common.h
index ff939963032..bca5244caaa 100644
--- a/src/w32common.h
+++ b/src/w32common.h
@@ -50,4 +50,35 @@ extern int os_subtype;
/* Cache system info, e.g., the NT page size. */
extern void cache_system_info (void);
+typedef void (* VOIDFNPTR) (void);
+
+/* Load a function address from a DLL. Cast the result via VOIDFNPTR
+ to pacify -Wcast-function-type in GCC 8.1. The return value must
+ be cast to the correct function pointer type. */
+INLINE VOIDFNPTR get_proc_addr (HINSTANCE, LPCSTR);
+INLINE VOIDFNPTR
+get_proc_addr (HINSTANCE handle, LPCSTR fname)
+{
+ return (VOIDFNPTR) GetProcAddress (handle, fname);
+}
+
+/* Define a function that will be loaded from a DLL. The variable
+ arguments should contain the argument list for the function, and
+ optionally be followed by function attributes. For example:
+ DEF_DLL_FN (void, png_longjmp, (png_structp, int) PNG_NORETURN);
+ */
+#define DEF_DLL_FN(type, func, ...) \
+ typedef type (CDECL *W32_PFN_##func) __VA_ARGS__; \
+ static W32_PFN_##func fn_##func
+
+/* Load a function from the DLL. */
+#define LOAD_DLL_FN(lib, func) \
+ do \
+ { \
+ fn_##func = (W32_PFN_##func) get_proc_addr (lib, #func); \
+ if (!fn_##func) \
+ return false; \
+ } \
+ while (false)
+
#endif /* W32COMMON_H */
diff --git a/src/w32console.c b/src/w32console.c
index cb758c1ef89..df232ecd1a1 100644
--- a/src/w32console.c
+++ b/src/w32console.c
@@ -506,7 +506,7 @@ w32con_set_terminal_modes (struct terminal *t)
/* Initialize input mode: interrupt_input off, no flow control, allow
8 bit character input, standard quit char. */
- Fset_input_mode (Qnil, Qnil, make_number (2), Qnil);
+ Fset_input_mode (Qnil, Qnil, make_fixnum (2), Qnil);
}
/* hmmm... perhaps these let us bracket screen changes so that we can flush
@@ -813,9 +813,9 @@ DEFUN ("set-screen-color", Fset_screen_color, Sset_screen_color, 2, 2, 0,
Arguments should be indices between 0 and 15, see w32console.el. */)
(Lisp_Object foreground, Lisp_Object background)
{
- char_attr_normal = XFASTINT (foreground) + (XFASTINT (background) << 4);
+ char_attr_normal = XFIXNAT (foreground) + (XFIXNAT (background) << 4);
- Frecenter (Qnil);
+ Frecenter (Qnil, Qt);
return Qt;
}
@@ -827,8 +827,8 @@ See w32console.el and `tty-defined-color-alist' for mapping of indices
to colors. */)
(void)
{
- return Fcons (make_number (char_attr_normal & 0x000f),
- Fcons (make_number ((char_attr_normal >> 4) & 0x000f), Qnil));
+ return Fcons (make_fixnum (char_attr_normal & 0x000f),
+ Fcons (make_fixnum ((char_attr_normal >> 4) & 0x000f), Qnil));
}
DEFUN ("set-cursor-size", Fset_cursor_size, Sset_cursor_size, 1, 1, 0,
@@ -836,7 +836,7 @@ DEFUN ("set-cursor-size", Fset_cursor_size, Sset_cursor_size, 1, 1, 0,
(Lisp_Object size)
{
CONSOLE_CURSOR_INFO cci;
- cci.dwSize = XFASTINT (size);
+ cci.dwSize = XFIXNAT (size);
cci.bVisible = TRUE;
(void) SetConsoleCursorInfo (cur_screen, &cci);
diff --git a/src/w32cygwinx.c b/src/w32cygwinx.c
new file mode 100644
index 00000000000..3b994b16b3f
--- /dev/null
+++ b/src/w32cygwinx.c
@@ -0,0 +1,134 @@
+/* Common functions for the Microsoft Windows and Cygwin builds.
+
+Copyright (C) 2018-2019 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#include <stdio.h>
+
+#include "lisp.h"
+#include "w32common.h"
+
+static Lisp_Object ATTRIBUTE_FORMAT_PRINTF (1, 2)
+format_string (char const *format, ...)
+{
+ va_list args;
+ va_start (args, format);
+ Lisp_Object str = vformat_string (format, args);
+ va_end (args);
+ return str;
+}
+
+DEFUN ("w32-battery-status", Fw32_battery_status, Sw32_battery_status, 0, 0, 0,
+ doc: /* Get power status information from Windows system.
+
+The following %-sequences are provided:
+%L AC line status (verbose)
+%B Battery status (verbose)
+%b Battery status, empty means high, `-' means low,
+ `!' means critical, and `+' means charging
+%p Battery load percentage
+%s Remaining time (to charge or discharge) in seconds
+%m Remaining time (to charge or discharge) in minutes
+%h Remaining time (to charge or discharge) in hours
+%t Remaining time (to charge or discharge) in the form `h:min' */)
+ (void)
+{
+ Lisp_Object status = Qnil;
+
+ SYSTEM_POWER_STATUS system_status;
+ if (GetSystemPowerStatus (&system_status))
+ {
+ Lisp_Object line_status, battery_status, battery_status_symbol;
+ Lisp_Object load_percentage, seconds, minutes, hours, remain;
+
+ long seconds_left = (long) system_status.BatteryLifeTime;
+
+ if (system_status.ACLineStatus == 0)
+ line_status = build_string ("off-line");
+ else if (system_status.ACLineStatus == 1)
+ line_status = build_string ("on-line");
+ else
+ line_status = build_string ("N/A");
+
+ if (system_status.BatteryFlag & 128)
+ {
+ battery_status = build_string ("N/A");
+ battery_status_symbol = empty_unibyte_string;
+ }
+ else if (system_status.BatteryFlag & 8)
+ {
+ battery_status = build_string ("charging");
+ battery_status_symbol = build_string ("+");
+ if (system_status.BatteryFullLifeTime != -1L)
+ seconds_left = system_status.BatteryFullLifeTime - seconds_left;
+ }
+ else if (system_status.BatteryFlag & 4)
+ {
+ battery_status = build_string ("critical");
+ battery_status_symbol = build_string ("!");
+ }
+ else if (system_status.BatteryFlag & 2)
+ {
+ battery_status = build_string ("low");
+ battery_status_symbol = build_string ("-");
+ }
+ else if (system_status.BatteryFlag & 1)
+ {
+ battery_status = build_string ("high");
+ battery_status_symbol = empty_unibyte_string;
+ }
+ else
+ {
+ battery_status = build_string ("medium");
+ battery_status_symbol = empty_unibyte_string;
+ }
+
+ if (system_status.BatteryLifePercent > 100)
+ load_percentage = build_string ("N/A");
+ else
+ load_percentage = format_string ("%d", system_status.BatteryLifePercent);
+
+ if (seconds_left < 0)
+ seconds = minutes = hours = remain = build_string ("N/A");
+ else
+ {
+ long m = seconds_left / 60;
+ seconds = format_string ("%ld", seconds_left);
+ minutes = format_string ("%ld", m);
+ hours = format_string ("%3.1f", seconds_left / 3600.0);
+ remain = format_string ("%ld:%02ld", m / 60, m % 60);
+ }
+
+ status = list (Fcons (make_fixnum ('L'), line_status),
+ Fcons (make_fixnum ('B'), battery_status),
+ Fcons (make_fixnum ('b'), battery_status_symbol),
+ Fcons (make_fixnum ('p'), load_percentage),
+ Fcons (make_fixnum ('s'), seconds),
+ Fcons (make_fixnum ('m'), minutes),
+ Fcons (make_fixnum ('h'), hours),
+ Fcons (make_fixnum ('t'), remain));
+ }
+ return status;
+}
+
+void
+syms_of_w32cygwinx (void)
+{
+ defsubr (&Sw32_battery_status);
+}
diff --git a/src/w32fns.c b/src/w32fns.c
index f9060ce5ac1..af82b463059 100644
--- a/src/w32fns.c
+++ b/src/w32fns.c
@@ -48,6 +48,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifdef WINDOWSNT
#include <mbstring.h>
+#include <mbctype.h> /* for _getmbcp */
#endif /* WINDOWSNT */
#if CYGWIN
@@ -56,6 +57,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "w32.h"
#endif
+#include "pdumper.h"
+
#include <basetyps.h>
#include <unknwn.h>
#include <commctrl.h>
@@ -457,12 +460,12 @@ if the entry is new. */)
Lisp_Object oldrgb = Qnil;
Lisp_Object entry;
- CHECK_NUMBER (red);
- CHECK_NUMBER (green);
- CHECK_NUMBER (blue);
+ CHECK_FIXNUM (red);
+ CHECK_FIXNUM (green);
+ CHECK_FIXNUM (blue);
CHECK_STRING (name);
- XSETINT (rgb, RGB (XUINT (red), XUINT (green), XUINT (blue)));
+ XSETINT (rgb, RGB (XUFIXNUM (red), XUFIXNUM (green), XUFIXNUM (blue)));
block_input ();
@@ -748,7 +751,7 @@ w32_default_color_map (void)
for (i = 0; i < ARRAYELTS (w32_color_map); pc++, i++)
cmap = Fcons (Fcons (build_string (pc->name),
- make_number (pc->colorref)),
+ make_fixnum (pc->colorref)),
cmap);
unblock_input ();
@@ -828,7 +831,7 @@ add_system_logical_colors_to_map (Lisp_Object *system_colors)
unsigned r, g, b;
if (sscanf (color_buffer, " %u %u %u", &r, &g, &b) == 3)
*system_colors = Fcons (Fcons (build_string (full_name_buffer),
- make_number (RGB (r, g, b))),
+ make_fixnum (RGB (r, g, b))),
*system_colors);
name_size = sizeof (full_name_buffer) - SYSTEM_COLOR_PREFIX_LEN;
@@ -1182,7 +1185,7 @@ w32_defined_color (struct frame *f, const char *color, XColor *color_def,
if (f)
{
/* Apply gamma correction. */
- w32_color_ref = XUINT (tem);
+ w32_color_ref = XUFIXNUM (tem);
gamma_correct (f, &w32_color_ref);
XSETINT (tem, w32_color_ref);
}
@@ -1198,7 +1201,7 @@ w32_defined_color (struct frame *f, const char *color, XColor *color_def,
/* check if color is already mapped */
while (entry)
{
- if (W32_COLOR (entry->entry) == XUINT (tem))
+ if (W32_COLOR (entry->entry) == XUFIXNUM (tem))
break;
prev = &entry->next;
entry = entry->next;
@@ -1208,7 +1211,7 @@ w32_defined_color (struct frame *f, const char *color, XColor *color_def,
{
/* not already mapped, so add to list */
entry = xmalloc (sizeof (struct w32_palette_entry));
- SET_W32_COLOR (entry->entry, XUINT (tem));
+ SET_W32_COLOR (entry->entry, XUFIXNUM (tem));
entry->next = NULL;
*prev = entry;
one_w32_display_info.num_colors++;
@@ -1220,7 +1223,7 @@ w32_defined_color (struct frame *f, const char *color, XColor *color_def,
/* Ensure COLORREF value is snapped to nearest color in (default)
palette by simulating the PALETTERGB macro. This works whether
or not the display device has a palette. */
- w32_color_ref = XUINT (tem) | 0x2000000;
+ w32_color_ref = XUFIXNUM (tem) | 0x2000000;
color_def->pixel = w32_color_ref;
color_def->red = GetRValue (w32_color_ref) * 256;
@@ -1343,8 +1346,8 @@ x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
if (!EQ (Qnil, Vx_pointer_shape))
{
- CHECK_NUMBER (Vx_pointer_shape);
- cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XINT (Vx_pointer_shape));
+ CHECK_FIXNUM (Vx_pointer_shape);
+ cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XFIXNUM (Vx_pointer_shape));
}
else
cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_xterm);
@@ -1352,9 +1355,9 @@ x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
if (!EQ (Qnil, Vx_nontext_pointer_shape))
{
- CHECK_NUMBER (Vx_nontext_pointer_shape);
+ CHECK_FIXNUM (Vx_nontext_pointer_shape);
nontext_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f),
- XINT (Vx_nontext_pointer_shape));
+ XFIXNUM (Vx_nontext_pointer_shape));
}
else
nontext_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_left_ptr);
@@ -1362,9 +1365,9 @@ x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
if (!EQ (Qnil, Vx_hourglass_pointer_shape))
{
- CHECK_NUMBER (Vx_hourglass_pointer_shape);
+ CHECK_FIXNUM (Vx_hourglass_pointer_shape);
hourglass_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f),
- XINT (Vx_hourglass_pointer_shape));
+ XFIXNUM (Vx_hourglass_pointer_shape));
}
else
hourglass_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_watch);
@@ -1373,9 +1376,9 @@ x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
x_check_errors (FRAME_W32_DISPLAY (f), "bad nontext pointer cursor: %s");
if (!EQ (Qnil, Vx_mode_pointer_shape))
{
- CHECK_NUMBER (Vx_mode_pointer_shape);
+ CHECK_FIXNUM (Vx_mode_pointer_shape);
mode_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f),
- XINT (Vx_mode_pointer_shape));
+ XFIXNUM (Vx_mode_pointer_shape));
}
else
mode_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_xterm);
@@ -1383,20 +1386,20 @@ x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
if (!EQ (Qnil, Vx_sensitive_text_pointer_shape))
{
- CHECK_NUMBER (Vx_sensitive_text_pointer_shape);
+ CHECK_FIXNUM (Vx_sensitive_text_pointer_shape);
hand_cursor
= XCreateFontCursor (FRAME_W32_DISPLAY (f),
- XINT (Vx_sensitive_text_pointer_shape));
+ XFIXNUM (Vx_sensitive_text_pointer_shape));
}
else
hand_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_crosshair);
if (!NILP (Vx_window_horizontal_drag_shape))
{
- CHECK_NUMBER (Vx_window_horizontal_drag_shape);
+ CHECK_FIXNUM (Vx_window_horizontal_drag_shape);
horizontal_drag_cursor
= XCreateFontCursor (FRAME_W32_DISPLAY (f),
- XINT (Vx_window_horizontal_drag_shape));
+ XFIXNUM (Vx_window_horizontal_drag_shape));
}
else
horizontal_drag_cursor
@@ -1404,10 +1407,10 @@ x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
if (!NILP (Vx_window_vertical_drag_shape))
{
- CHECK_NUMBER (Vx_window_vertical_drag_shape);
+ CHECK_FIXNUM (Vx_window_vertical_drag_shape);
vertical_drag_cursor
= XCreateFontCursor (FRAME_W32_DISPLAY (f),
- XINT (Vx_window_vertical_drag_shape));
+ XFIXNUM (Vx_window_vertical_drag_shape));
}
else
vertical_drag_cursor
@@ -1648,12 +1651,16 @@ x_clear_under_internal_border (struct frame *f)
/* Clear border if it's larger than before. */
if (border != 0)
{
- HDC hdc = get_frame_dc (f);
int width = FRAME_PIXEL_WIDTH (f);
int height = FRAME_PIXEL_HEIGHT (f);
- struct face *face = FACE_FROM_ID_OR_NULL (f, INTERNAL_BORDER_FACE_ID);
+ int face_id =
+ !NILP (Vface_remapping_alist)
+ ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID)
+ : INTERNAL_BORDER_FACE_ID;
+ struct face *face = FACE_FROM_ID_OR_NULL (f, face_id);
block_input ();
+ HDC hdc = get_frame_dc (f);
if (face)
{
/* Fill border with internal border face. */
@@ -1689,7 +1696,7 @@ x_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldva
int border;
CHECK_TYPE_RANGED_INTEGER (int, arg);
- border = max (XINT (arg), 0);
+ border = max (XFIXNUM (arg), 0);
if (border != FRAME_INTERNAL_BORDER_WIDTH (f))
{
@@ -1725,7 +1732,7 @@ x_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
if (!FRAME_MINIBUF_ONLY_P (f) && !FRAME_PARENT_FRAME (f))
{
boolean old = FRAME_EXTERNAL_MENU_BAR (f);
- boolean new = (INTEGERP (value) && XINT (value) > 0) ? true : false;
+ boolean new = (FIXNUMP (value) && XFIXNUM (value) > 0) ? true : false;
FRAME_MENU_BAR_LINES (f) = 0;
FRAME_MENU_BAR_HEIGHT (f) = 0;
@@ -1757,7 +1764,7 @@ x_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
x_clear_under_internal_border (f);
/* Don't store anything but 1 or 0 in the parameter. */
- store_frame_param (f, Qmenu_bar_lines, make_number (new ? 1 : 0));
+ store_frame_param (f, Qmenu_bar_lines, make_fixnum (new ? 1 : 0));
}
}
}
@@ -1780,8 +1787,8 @@ x_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
return;
/* Use VALUE only if an integer >= 0. */
- if (INTEGERP (value) && XINT (value) >= 0)
- nlines = XFASTINT (value);
+ if (FIXNUMP (value) && XFIXNUM (value) >= 0)
+ nlines = XFIXNAT (value);
else
nlines = 0;
@@ -1805,8 +1812,8 @@ x_change_tool_bar_height (struct frame *f, int height)
FRAME_TOOL_BAR_HEIGHT (f) = height;
FRAME_TOOL_BAR_LINES (f) = lines;
/* Store `tool-bar-lines' and `height' frame parameters. */
- store_frame_param (f, Qtool_bar_lines, make_number (lines));
- store_frame_param (f, Qheight, make_number (FRAME_LINES (f)));
+ store_frame_param (f, Qtool_bar_lines, make_fixnum (lines));
+ store_frame_param (f, Qheight, make_fixnum (FRAME_LINES (f)));
if (FRAME_W32_WINDOW (f) && FRAME_TOOL_BAR_HEIGHT (f) == 0)
{
@@ -2027,7 +2034,7 @@ x_set_undecorated (struct frame *f, Lisp_Object new_value, Lisp_Object old_value
if (!NILP (new_value) && !FRAME_UNDECORATED (f))
{
dwStyle = ((dwStyle & ~WS_THICKFRAME & ~WS_CAPTION)
- | ((NUMBERP (border_width) && (XINT (border_width) > 0))
+ | ((FIXNUMP (border_width) && (XFIXNUM (border_width) > 0))
? WS_BORDER : false));
SetWindowLong (hwnd, GWL_STYLE, dwStyle);
SetWindowPos (hwnd, HWND_TOP, 0, 0, 0, 0,
@@ -2334,7 +2341,7 @@ w32_createwindow (struct frame *f, int *coords)
if (FRAME_UNDECORATED (f))
{
/* If we want a thin border, specify it here. */
- if (NUMBERP (border_width) && (XINT (border_width) > 0))
+ if (FIXNUMP (border_width) && (XFIXNUM (border_width) > 0))
f->output_data.w32->dwStyle |= WS_BORDER;
}
else
@@ -2350,7 +2357,7 @@ w32_createwindow (struct frame *f, int *coords)
f->output_data.w32->dwStyle = WS_POPUP;
/* If we want a thin border, specify it here. */
- if (NUMBERP (border_width) && (XINT (border_width) > 0))
+ if (FIXNUMP (border_width) && (XFIXNUM (border_width) > 0))
f->output_data.w32->dwStyle |= WS_BORDER;
}
else
@@ -2640,7 +2647,7 @@ setup_w32_kbdhook (void)
if (w32_kbdhook_active)
{
IsDebuggerPresent_Proc is_debugger_present = (IsDebuggerPresent_Proc)
- GetProcAddress (GetModuleHandle ("kernel32.dll"), "IsDebuggerPresent");
+ get_proc_addr (GetModuleHandle ("kernel32.dll"), "IsDebuggerPresent");
if (is_debugger_present && is_debugger_present ())
return;
}
@@ -2655,7 +2662,7 @@ setup_w32_kbdhook (void)
(https://support.microsoft.com/en-us/kb/124103) is used for
NT 4 systems. */
GetConsoleWindow_Proc get_console = (GetConsoleWindow_Proc)
- GetProcAddress (GetModuleHandle ("kernel32.dll"), "GetConsoleWindow");
+ get_proc_addr (GetModuleHandle ("kernel32.dll"), "GetConsoleWindow");
if (get_console != NULL)
kbdhook.console = get_console ();
@@ -3116,10 +3123,10 @@ map_keypad_keys (unsigned int virt_key, unsigned int extended)
(Windows 2000 and later). */
static Lisp_Object w32_grabbed_keys;
-#define HOTKEY(vk, mods) make_number (((vk) & 255) | ((mods) << 8))
-#define HOTKEY_ID(k) (XFASTINT (k) & 0xbfff)
-#define HOTKEY_VK_CODE(k) (XFASTINT (k) & 255)
-#define HOTKEY_MODIFIERS(k) (XFASTINT (k) >> 8)
+#define HOTKEY(vk, mods) make_fixnum (((vk) & 255) | ((mods) << 8))
+#define HOTKEY_ID(k) (XFIXNAT (k) & 0xbfff)
+#define HOTKEY_VK_CODE(k) (XFIXNAT (k) & 255)
+#define HOTKEY_MODIFIERS(k) (XFIXNAT (k) >> 8)
#define RAW_HOTKEY_ID(k) ((k) & 0xbfff)
#define RAW_HOTKEY_VK_CODE(k) ((k) & 255)
@@ -3140,7 +3147,7 @@ register_hot_keys (HWND hwnd)
Lisp_Object key = XCAR (keylist);
/* Deleted entries get set to nil. */
- if (!INTEGERP (key))
+ if (!FIXNUMP (key))
continue;
RegisterHotKey (hwnd, HOTKEY_ID (key),
@@ -3157,7 +3164,7 @@ unregister_hot_keys (HWND hwnd)
{
Lisp_Object key = XCAR (keylist);
- if (!INTEGERP (key))
+ if (!FIXNUMP (key))
continue;
UnregisterHotKey (hwnd, HOTKEY_ID (key));
@@ -4199,8 +4206,8 @@ w32_wnd_proc (HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
press of Space which we will ignore. */
if (GetAsyncKeyState (wParam) & 1)
{
- if (NUMBERP (Vw32_phantom_key_code))
- key = XUINT (Vw32_phantom_key_code) & 255;
+ if (FIXNUMP (Vw32_phantom_key_code))
+ key = XUFIXNUM (Vw32_phantom_key_code) & 255;
else
key = VK_SPACE;
dpyinfo->faked_key = key;
@@ -4215,8 +4222,8 @@ w32_wnd_proc (HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
{
if (GetAsyncKeyState (wParam) & 1)
{
- if (NUMBERP (Vw32_phantom_key_code))
- key = XUINT (Vw32_phantom_key_code) & 255;
+ if (FIXNUMP (Vw32_phantom_key_code))
+ key = XUFIXNUM (Vw32_phantom_key_code) & 255;
else
key = VK_SPACE;
dpyinfo->faked_key = key;
@@ -5413,11 +5420,11 @@ my_create_window (struct frame * f)
if (EQ (left, Qunbound))
coords[0] = CW_USEDEFAULT;
else
- coords[0] = XINT (left);
+ coords[0] = XFIXNUM (left);
if (EQ (top, Qunbound))
coords[1] = CW_USEDEFAULT;
else
- coords[1] = XINT (top);
+ coords[1] = XFIXNUM (top);
if (!PostThreadMessage (dwWindowsThreadId, WM_EMACS_CREATEWINDOW,
(WPARAM)f, (LPARAM)coords))
@@ -5529,8 +5536,8 @@ x_icon (struct frame *f, Lisp_Object parms)
icon_y = x_get_arg (dpyinfo, parms, Qicon_top, 0, 0, RES_TYPE_NUMBER);
if (!EQ (icon_x, Qunbound) && !EQ (icon_y, Qunbound))
{
- CHECK_NUMBER (icon_x);
- CHECK_NUMBER (icon_y);
+ CHECK_FIXNUM (icon_x);
+ CHECK_FIXNUM (icon_y);
}
else if (!EQ (icon_x, Qunbound) || !EQ (icon_y, Qunbound))
error ("Both left and top icon corners of icon must be specified");
@@ -5675,15 +5682,7 @@ x_default_font_parameter (struct frame *f, Lisp_Object parms)
DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame,
1, 1, 0,
- doc: /* Make a new window, which is called a \"frame\" in Emacs terms.
-Return an Emacs frame object.
-PARAMETERS is an alist of frame parameters.
-If the parameters specify that the frame should not have a minibuffer,
-and do not specify a specific minibuffer window to use,
-then `default-minibuffer-frame' must be a frame whose minibuffer can
-be shared by the new frame.
-
-This function is an internal primitive--use `make-frame' instead. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object parameters)
{
struct frame *f;
@@ -5736,7 +5735,7 @@ This function is an internal primitive--use `make-frame' instead. */)
if (EQ (parent, Qunbound))
parent = Qnil;
else if (!NILP (parent))
- CHECK_NUMBER (parent);
+ CHECK_FIXNUM (parent);
/* make_frame_without_minibuffer can run Lisp code and garbage collect. */
/* No need to protect DISPLAY because that's not used after passing
@@ -5817,7 +5816,7 @@ This function is an internal primitive--use `make-frame' instead. */)
{
/* Cast to UINT_PTR shuts up compiler warnings about cast to
pointer from integer of different size. */
- f->output_data.w32->parent_desc = (Window) (UINT_PTR) XFASTINT (parent);
+ f->output_data.w32->parent_desc = (Window) (UINT_PTR) XFIXNAT (parent);
f->output_data.w32->explicit_parent = true;
}
else
@@ -5853,7 +5852,7 @@ This function is an internal primitive--use `make-frame' instead. */)
x_default_font_parameter (f, parameters);
/* Default BorderWidth to 0 to match other platforms. */
- x_default_parameter (f, parameters, Qborder_width, make_number (0),
+ x_default_parameter (f, parameters, Qborder_width, make_fixnum (0),
"borderWidth", "BorderWidth", RES_TYPE_NUMBER);
/* We recognize either internalBorderWidth or internalBorder
@@ -5869,11 +5868,11 @@ This function is an internal primitive--use `make-frame' instead. */)
parameters);
}
- x_default_parameter (f, parameters, Qinternal_border_width, make_number (0),
+ x_default_parameter (f, parameters, Qinternal_border_width, make_fixnum (0),
"internalBorderWidth", "InternalBorder", RES_TYPE_NUMBER);
- x_default_parameter (f, parameters, Qright_divider_width, make_number (0),
+ x_default_parameter (f, parameters, Qright_divider_width, make_fixnum (0),
NULL, NULL, RES_TYPE_NUMBER);
- x_default_parameter (f, parameters, Qbottom_divider_width, make_number (0),
+ x_default_parameter (f, parameters, Qbottom_divider_width, make_fixnum (0),
NULL, NULL, RES_TYPE_NUMBER);
x_default_parameter (f, parameters, Qvertical_scroll_bars, Qright,
"verticalScrollBars", "ScrollBars", RES_TYPE_SYMBOL);
@@ -5929,11 +5928,11 @@ This function is an internal primitive--use `make-frame' instead. */)
because `frame-windows-min-size' needs them. */
tem = x_get_arg (dpyinfo, parameters, Qmin_width, NULL, NULL,
RES_TYPE_NUMBER);
- if (NUMBERP (tem))
+ if (FIXNUMP (tem))
store_frame_param (f, Qmin_width, tem);
tem = x_get_arg (dpyinfo, parameters, Qmin_height, NULL, NULL,
RES_TYPE_NUMBER);
- if (NUMBERP (tem))
+ if (FIXNUMP (tem))
store_frame_param (f, Qmin_height, tem);
adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f),
FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, true,
@@ -5946,16 +5945,16 @@ This function is an internal primitive--use `make-frame' instead. */)
{
x_default_parameter (f, parameters, Qmenu_bar_lines,
NILP (Vmenu_bar_mode)
- ? make_number (0) : make_number (1),
+ ? make_fixnum (0) : make_fixnum (1),
NULL, NULL, RES_TYPE_NUMBER);
}
else
/* No menu bar for child frames. */
- store_frame_param (f, Qmenu_bar_lines, make_number (0));
+ store_frame_param (f, Qmenu_bar_lines, make_fixnum (0));
x_default_parameter (f, parameters, Qtool_bar_lines,
NILP (Vtool_bar_mode)
- ? make_number (0) : make_number (1),
+ ? make_fixnum (0) : make_fixnum (1),
NULL, NULL, RES_TYPE_NUMBER);
x_default_parameter (f, parameters, Qbuffer_predicate, Qnil,
@@ -6102,8 +6101,7 @@ x_get_focus_frame (struct frame *frame)
}
DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0,
- doc: /* Internal function called by `color-defined-p', which see.
-\(Note that the Nextstep version of this function ignores FRAME.) */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object color, Lisp_Object frame)
{
XColor foo;
@@ -6118,7 +6116,7 @@ DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0,
}
DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0,
- doc: /* Internal function called by `color-values', which see. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object color, Lisp_Object frame)
{
XColor foo;
@@ -6135,7 +6133,7 @@ DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0,
}
DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0,
- doc: /* Internal function called by `display-color-p', which see. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object display)
{
struct w32_display_info *dpyinfo = check_x_display_info (display);
@@ -6148,11 +6146,7 @@ DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0,
DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p,
Sx_display_grayscale_p, 0, 1, 0,
- doc: /* Return t if DISPLAY supports shades of gray.
-Note that color displays do support shades of gray.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object display)
{
struct w32_display_info *dpyinfo = check_x_display_info (display);
@@ -6165,57 +6159,37 @@ If omitted or nil, that stands for the selected frame's display. */)
DEFUN ("x-display-pixel-width", Fx_display_pixel_width,
Sx_display_pixel_width, 0, 1, 0,
- doc: /* Return the width in pixels of DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display.
-
-On \"multi-monitor\" setups this refers to the pixel width for all
-physical monitors associated with DISPLAY. To get information for
-each physical monitor, use `display-monitor-attributes-list'. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object display)
{
struct w32_display_info *dpyinfo = check_x_display_info (display);
- return make_number (x_display_pixel_width (dpyinfo));
+ return make_fixnum (x_display_pixel_width (dpyinfo));
}
DEFUN ("x-display-pixel-height", Fx_display_pixel_height,
Sx_display_pixel_height, 0, 1, 0,
- doc: /* Return the height in pixels of DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display.
-
-On \"multi-monitor\" setups this refers to the pixel height for all
-physical monitors associated with DISPLAY. To get information for
-each physical monitor, use `display-monitor-attributes-list'. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object display)
{
struct w32_display_info *dpyinfo = check_x_display_info (display);
- return make_number (x_display_pixel_height (dpyinfo));
+ return make_fixnum (x_display_pixel_height (dpyinfo));
}
DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes,
0, 1, 0,
- doc: /* Return the number of bitplanes of DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object display)
{
struct w32_display_info *dpyinfo = check_x_display_info (display);
- return make_number (dpyinfo->n_planes * dpyinfo->n_cbits);
+ return make_fixnum (dpyinfo->n_planes * dpyinfo->n_cbits);
}
DEFUN ("x-display-color-cells", Fx_display_color_cells, Sx_display_color_cells,
0, 1, 0,
- doc: /* Return the number of color cells of DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object display)
{
struct w32_display_info *dpyinfo = check_x_display_info (display);
@@ -6227,78 +6201,42 @@ If omitted or nil, that stands for the selected frame's display. */)
* anyway. */
cap = 1 << min (dpyinfo->n_planes * dpyinfo->n_cbits, 24);
- return make_number (cap);
+ return make_fixnum (cap);
}
DEFUN ("x-server-max-request-size", Fx_server_max_request_size,
Sx_server_max_request_size,
0, 1, 0,
- doc: /* Return the maximum request size of the server of DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object display)
{
- return make_number (1);
+ return make_fixnum (1);
}
DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0,
- doc: /* Return the "vendor ID" string of the GUI software on TERMINAL.
-
-\(Labeling every distributor as a "vendor" embodies the false assumption
-that operating systems cannot be developed and distributed noncommercially.)
-
-For GNU and Unix systems, this queries the X server software; for
-MS-Windows, this queries the OS.
-
-The optional argument TERMINAL specifies which display to ask about.
-TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object terminal)
{
return build_string ("Microsoft Corp.");
}
DEFUN ("x-server-version", Fx_server_version, Sx_server_version, 0, 1, 0,
- doc: /* Return the version numbers of the GUI software on TERMINAL.
-The value is a list of three integers specifying the version of the GUI
-software in use.
-
-For GNU and Unix system, the first 2 numbers are the version of the X
-Protocol used on TERMINAL and the 3rd number is the distributor-specific
-release number. For MS-Windows, the 3 numbers report the version and
-the build number of the OS.
-
-See also the function `x-server-vendor'.
-
-The optional argument TERMINAL specifies which display to ask about.
-TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object terminal)
{
return list3i (w32_major_version, w32_minor_version, w32_build_number);
}
DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens, 0, 1, 0,
- doc: /* Return the number of screens on the server of DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object display)
{
- return make_number (1);
+ return make_fixnum (1);
}
DEFUN ("x-display-mm-height", Fx_display_mm_height,
Sx_display_mm_height, 0, 1, 0,
- doc: /* Return the height in millimeters of DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display.
-
-On \"multi-monitor\" setups this refers to the height in millimeters for
-all physical monitors associated with DISPLAY. To get information
-for each physical monitor, use `display-monitor-attributes-list'. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object display)
{
struct w32_display_info *dpyinfo = check_x_display_info (display);
@@ -6310,18 +6248,11 @@ for each physical monitor, use `display-monitor-attributes-list'. */)
/ GetDeviceCaps (hdc, VERTRES));
ReleaseDC (NULL, hdc);
- return make_number (x_display_pixel_height (dpyinfo) * mm_per_pixel + 0.5);
+ return make_fixnum (x_display_pixel_height (dpyinfo) * mm_per_pixel + 0.5);
}
DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0,
- doc: /* Return the width in millimeters of DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display.
-
-On \"multi-monitor\" setups this refers to the width in millimeters for
-all physical monitors associated with TERMINAL. To get information
-for each physical monitor, use `display-monitor-attributes-list'. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object display)
{
struct w32_display_info *dpyinfo = check_x_display_info (display);
@@ -6333,16 +6264,12 @@ for each physical monitor, use `display-monitor-attributes-list'. */)
/ GetDeviceCaps (hdc, HORZRES));
ReleaseDC (NULL, hdc);
- return make_number (x_display_pixel_width (dpyinfo) * mm_per_pixel + 0.5);
+ return make_fixnum (x_display_pixel_width (dpyinfo) * mm_per_pixel + 0.5);
}
DEFUN ("x-display-backing-store", Fx_display_backing_store,
Sx_display_backing_store, 0, 1, 0,
- doc: /* Return an indication of whether DISPLAY does backing store.
-The value may be `always', `when-mapped', or `not-useful'.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object display)
{
return intern ("not-useful");
@@ -6350,13 +6277,7 @@ If omitted or nil, that stands for the selected frame's display. */)
DEFUN ("x-display-visual-class", Fx_display_visual_class,
Sx_display_visual_class, 0, 1, 0,
- doc: /* Return the visual class of DISPLAY.
-The value is one of the symbols `static-gray', `gray-scale',
-`static-color', `pseudo-color', `true-color', or `direct-color'.
-
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object display)
{
struct w32_display_info *dpyinfo = check_x_display_info (display);
@@ -6365,7 +6286,7 @@ If omitted or nil, that stands for the selected frame's display. */)
if (dpyinfo->has_palette)
result = intern ("pseudo-color");
else if (dpyinfo->n_planes * dpyinfo->n_cbits == 1)
- result = intern ("static-grey");
+ result = intern ("static-gray");
else if (dpyinfo->n_planes * dpyinfo->n_cbits == 4)
result = intern ("static-color");
else if (dpyinfo->n_planes * dpyinfo->n_cbits > 8)
@@ -6376,10 +6297,7 @@ If omitted or nil, that stands for the selected frame's display. */)
DEFUN ("x-display-save-under", Fx_display_save_under,
Sx_display_save_under, 0, 1, 0,
- doc: /* Return t if DISPLAY supports the save-under feature.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object display)
{
return Qnil;
@@ -6390,7 +6308,7 @@ w32_monitor_enum (HMONITOR monitor, HDC hdc, RECT *rcMonitor, LPARAM dwData)
{
Lisp_Object *monitor_list = (Lisp_Object *) dwData;
- *monitor_list = Fcons (make_save_ptr (monitor), *monitor_list);
+ *monitor_list = Fcons (make_mint_ptr (monitor), *monitor_list);
return TRUE;
}
@@ -6419,16 +6337,16 @@ w32_display_monitor_attributes_list (void)
monitors = xmalloc (n_monitors * sizeof (*monitors));
for (i = 0; i < n_monitors; i++)
{
- monitors[i] = XSAVE_POINTER (XCAR (monitor_list), 0);
+ monitors[i] = xmint_pointer (XCAR (monitor_list));
monitor_list = XCDR (monitor_list);
}
- monitor_frames = Fmake_vector (make_number (n_monitors), Qnil);
+ monitor_frames = Fmake_vector (make_fixnum (n_monitors), Qnil);
FOR_EACH_FRAME (rest, frame)
{
struct frame *f = XFRAME (frame);
- if (FRAME_W32_P (f) && !EQ (frame, tip_frame))
+ if (FRAME_W32_P (f) && !FRAME_TOOLTIP_P (f))
{
HMONITOR monitor =
monitor_from_window_fn (FRAME_W32_WINDOW (f),
@@ -6515,7 +6433,7 @@ w32_display_monitor_attributes_list_fallback (struct w32_display_info *dpyinfo)
{
struct frame *f = XFRAME (frame);
- if (FRAME_W32_P (f) && !EQ (frame, tip_frame))
+ if (FRAME_W32_P (f) && !FRAME_TOOLTIP_P (f))
frames = Fcons (frame, frames);
}
attributes = Fcons (Fcons (Qframes, frames), attributes);
@@ -6644,12 +6562,7 @@ x_display_info_for_name (Lisp_Object name)
}
DEFUN ("x-open-connection", Fx_open_connection, Sx_open_connection,
- 1, 3, 0, doc: /* Open a connection to a display server.
-DISPLAY is the name of the display to connect to.
-Optional second arg XRM-STRING is a string of resources in xrdb format.
-If the optional third arg MUST-SUCCEED is non-nil,
-terminate Emacs if we can't open the connection.
-\(In the Nextstep version, the last two arguments are currently ignored.) */)
+ 1, 3, 0, doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object display, Lisp_Object xrm_string, Lisp_Object must_succeed)
{
char *xrm_option;
@@ -6731,9 +6644,7 @@ terminate Emacs if we can't open the connection.
DEFUN ("x-close-connection", Fx_close_connection,
Sx_close_connection, 1, 1, 0,
- doc: /* Close the connection to DISPLAY's server.
-For DISPLAY, specify either a frame or a display name (a string).
-If DISPLAY is nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object display)
{
struct w32_display_info *dpyinfo = check_x_display_info (display);
@@ -6751,7 +6662,7 @@ If DISPLAY is nil, that stands for the selected frame's display. */)
}
DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0,
- doc: /* Return the list of display names that Emacs has connections to. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(void)
{
Lisp_Object result = Qnil;
@@ -6764,17 +6675,7 @@ DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0,
}
DEFUN ("x-synchronize", Fx_synchronize, Sx_synchronize, 1, 2, 0,
- doc: /* If ON is non-nil, report X errors as soon as the erring request is made.
-This function only has an effect on X Windows. With MS Windows, it is
-defined but does nothing.
-
-If ON is nil, allow buffering of requests.
-Turning on synchronization prohibits the Xlib routines from buffering
-requests and seriously degrades performance, but makes debugging much
-easier.
-The optional second argument TERMINAL specifies which display to act on.
-TERMINAL should be a terminal object, a frame or a display name (a string).
-If TERMINAL is omitted or nil, that stands for the selected frame's display. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object on, Lisp_Object display)
{
return Qnil;
@@ -6790,21 +6691,7 @@ If TERMINAL is omitted or nil, that stands for the selected frame's display. */
DEFUN ("x-change-window-property", Fx_change_window_property,
Sx_change_window_property, 2, 6, 0,
- doc: /* Change window property PROP to VALUE on the X window of FRAME.
-PROP must be a string. VALUE may be a string or a list of conses,
-numbers and/or strings. If an element in the list is a string, it is
-converted to an atom and the value of the Atom is used. If an element
-is a cons, it is converted to a 32 bit number where the car is the 16
-top bits and the cdr is the lower 16 bits.
-
-FRAME nil or omitted means use the selected frame.
-If TYPE is given and non-nil, it is the name of the type of VALUE.
-If TYPE is not given or nil, the type is STRING.
-FORMAT gives the size in bits of each element if VALUE is a list.
-It must be one of 8, 16 or 32.
-If VALUE is a string or FORMAT is nil or not given, FORMAT defaults to 8.
-If OUTER-P is non-nil, the property is changed for the outer X window of
-FRAME. Default is to change on the edit X window. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object prop, Lisp_Object value, Lisp_Object frame,
Lisp_Object type, Lisp_Object format, Lisp_Object outer_p)
{
@@ -6830,8 +6717,7 @@ FRAME. Default is to change on the edit X window. */)
DEFUN ("x-delete-window-property", Fx_delete_window_property,
Sx_delete_window_property, 1, 2, 0,
- doc: /* Remove window property PROP from X window of FRAME.
-FRAME nil or omitted means use the selected frame. Value is PROP. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object prop, Lisp_Object frame)
{
struct frame *f = decode_window_system_frame (frame);
@@ -6852,21 +6738,7 @@ FRAME nil or omitted means use the selected frame. Value is PROP. */)
DEFUN ("x-window-property", Fx_window_property, Sx_window_property,
1, 6, 0,
- doc: /* Value is the value of window property PROP on FRAME.
-If FRAME is nil or omitted, use the selected frame.
-
-On X Windows, the following optional arguments are also accepted:
-If TYPE is nil or omitted, get the property as a string.
-Otherwise TYPE is the name of the atom that denotes the type expected.
-If SOURCE is non-nil, get the property on that window instead of from
-FRAME. The number 0 denotes the root window.
-If DELETE-P is non-nil, delete the property after retrieving it.
-If VECTOR-RET-P is non-nil, don't return a string but a vector of values.
-
-On MS Windows, this function accepts but ignores those optional arguments.
-
-Value is nil if FRAME hasn't a property with name PROP or if PROP has
-no value of TYPE (always string in the MS Windows case). */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object prop, Lisp_Object frame, Lisp_Object type,
Lisp_Object source, Lisp_Object delete_p, Lisp_Object vector_ret_p)
{
@@ -6921,20 +6793,25 @@ no value of TYPE (always string in the MS Windows case). */)
static void compute_tip_xy (struct frame *, Lisp_Object, Lisp_Object,
Lisp_Object, int, int, int *, int *);
-/* The frame of a currently visible tooltip. */
-
+/* The frame of the currently visible tooltip. */
Lisp_Object tip_frame;
-/* If non-nil, a timer started that hides the last tooltip when it
- fires. */
+/* The window-system window corresponding to the frame of the
+ currently visible tooltip. */
+Window tip_window;
+/* A timer that hides or deletes the currently visible tooltip when it
+ fires. */
Lisp_Object tip_timer;
-Window tip_window;
-/* If non-nil, a vector of 3 elements containing the last args
- with which x-show-tip was called. See there. */
+/* STRING argument of last `x-show-tip' call. */
+Lisp_Object tip_last_string;
+
+/* Normalized FRAME argument of last `x-show-tip' call. */
+Lisp_Object tip_last_frame;
-Lisp_Object last_show_tip_args;
+/* PARMS argument of last `x-show-tip' call. */
+Lisp_Object tip_last_parms;
static void
@@ -7007,6 +6884,7 @@ x_create_tip_frame (struct w32_display_info *dpyinfo, Lisp_Object parms)
FRAME_FONTSET (f) = -1;
fset_icon_name (f, Qnil);
+ f->tooltip = true;
#ifdef GLYPH_DEBUG
image_cache_refcount =
@@ -7041,7 +6919,7 @@ x_create_tip_frame (struct w32_display_info *dpyinfo, Lisp_Object parms)
that are needed to determine window geometry. */
x_default_font_parameter (f, parms);
- x_default_parameter (f, parms, Qborder_width, make_number (2),
+ x_default_parameter (f, parms, Qborder_width, make_fixnum (2),
"borderWidth", "BorderWidth", RES_TYPE_NUMBER);
/* This defaults to 2 in order to match xterm. We recognize either
internalBorderWidth or internalBorder (which is what xterm calls
@@ -7057,7 +6935,7 @@ x_create_tip_frame (struct w32_display_info *dpyinfo, Lisp_Object parms)
parms);
}
- x_default_parameter (f, parms, Qinternal_border_width, make_number (1),
+ x_default_parameter (f, parms, Qinternal_border_width, make_fixnum (1),
"internalBorderWidth", "internalBorderWidth",
RES_TYPE_NUMBER);
/* Also do the stuff which must be set before the window exists. */
@@ -7193,8 +7071,8 @@ compute_tip_xy (struct frame *f,
/* Move the tooltip window where the mouse pointer is. Resize and
show it. */
- if ((!INTEGERP (left) && !INTEGERP (right))
- || (!INTEGERP (top) && !INTEGERP (bottom)))
+ if ((!FIXNUMP (left) && !FIXNUMP (right))
+ || (!FIXNUMP (top) && !FIXNUMP (bottom)))
{
POINT pt;
@@ -7233,40 +7111,50 @@ compute_tip_xy (struct frame *f,
}
}
- if (INTEGERP (top))
- *root_y = XINT (top);
- else if (INTEGERP (bottom))
- *root_y = XINT (bottom) - height;
- else if (*root_y + XINT (dy) <= min_y)
+ if (FIXNUMP (top))
+ *root_y = XFIXNUM (top);
+ else if (FIXNUMP (bottom))
+ *root_y = XFIXNUM (bottom) - height;
+ else if (*root_y + XFIXNUM (dy) <= min_y)
*root_y = min_y; /* Can happen for negative dy */
- else if (*root_y + XINT (dy) + height <= max_y)
+ else if (*root_y + XFIXNUM (dy) + height <= max_y)
/* It fits below the pointer */
- *root_y += XINT (dy);
- else if (height + XINT (dy) + min_y <= *root_y)
+ *root_y += XFIXNUM (dy);
+ else if (height + XFIXNUM (dy) + min_y <= *root_y)
/* It fits above the pointer. */
- *root_y -= height + XINT (dy);
+ *root_y -= height + XFIXNUM (dy);
else
/* Put it on the top. */
*root_y = min_y;
- if (INTEGERP (left))
- *root_x = XINT (left);
- else if (INTEGERP (right))
- *root_x = XINT (right) - width;
- else if (*root_x + XINT (dx) <= min_x)
+ if (FIXNUMP (left))
+ *root_x = XFIXNUM (left);
+ else if (FIXNUMP (right))
+ *root_x = XFIXNUM (right) - width;
+ else if (*root_x + XFIXNUM (dx) <= min_x)
*root_x = 0; /* Can happen for negative dx */
- else if (*root_x + XINT (dx) + width <= max_x)
+ else if (*root_x + XFIXNUM (dx) + width <= max_x)
/* It fits to the right of the pointer. */
- *root_x += XINT (dx);
- else if (width + XINT (dx) + min_x <= *root_x)
+ *root_x += XFIXNUM (dx);
+ else if (width + XFIXNUM (dx) + min_x <= *root_x)
/* It fits to the left of the pointer. */
- *root_x -= width + XINT (dx);
+ *root_x -= width + XFIXNUM (dx);
else
/* Put it left justified on the screen -- it ought to fit that way. */
*root_x = min_x;
}
-/* Hide tooltip. Delete its frame if DELETE is true. */
+/**
+ * x_hide_tip:
+ *
+ * Hide currently visible tooltip and cancel its timer.
+ *
+ * This will try to make tooltip_frame invisible (if DELETE is false)
+ * or delete tooltip_frame (if DELETE is true).
+ *
+ * Return Qt if the tooltip was either deleted or made invisible, Qnil
+ * otherwise.
+ */
static Lisp_Object
x_hide_tip (bool delete)
{
@@ -7291,15 +7179,20 @@ x_hide_tip (bool delete)
if (FRAMEP (tip_frame))
{
- if (delete)
+ if (FRAME_LIVE_P (XFRAME (tip_frame)))
{
- delete_frame (tip_frame, Qnil);
- tip_frame = Qnil;
+ if (delete)
+ {
+ delete_frame (tip_frame, Qnil);
+ tip_frame = Qnil;
+ }
+ else
+ x_make_frame_invisible (XFRAME (tip_frame));
+
+ was_open = Qt;
}
else
- x_make_frame_invisible (XFRAME (tip_frame));
-
- was_open = Qt;
+ tip_frame = Qnil;
}
else
tip_frame = Qnil;
@@ -7310,36 +7203,9 @@ x_hide_tip (bool delete)
DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0,
- doc: /* Show STRING in a \"tooltip\" window on frame FRAME.
-A tooltip window is a small window displaying a string.
-
-This is an internal function; Lisp code should call `tooltip-show'.
-
-FRAME nil or omitted means use the selected frame.
-
-PARMS is an optional list of frame parameters which can be
-used to change the tooltip's appearance.
-
-Automatically hide the tooltip after TIMEOUT seconds. TIMEOUT nil
-means use the default timeout of 5 seconds.
-
-If the list of frame parameters PARMS contains a `left' parameter,
-display the tooltip at that x-position. If the list of frame parameters
-PARMS contains no `left' but a `right' parameter, display the tooltip
-right-adjusted at that x-position. Otherwise display it at the
-x-position of the mouse, with offset DX added (default is 5 if DX isn't
-specified).
-
-Likewise for the y-position: If a `top' frame parameter is specified, it
-determines the position of the upper edge of the tooltip window. If a
-`bottom' parameter but no `top' frame parameter is specified, it
-determines the position of the lower edge of the tooltip window.
-Otherwise display the tooltip window at the y-position of the mouse,
-with offset DY added (default is -10).
-
-A tooltip's maximum size is specified by `x-max-tooltip-size'.
-Text larger than the specified size is clipped. */)
- (Lisp_Object string, Lisp_Object frame, Lisp_Object parms, Lisp_Object timeout, Lisp_Object dx, Lisp_Object dy)
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object string, Lisp_Object frame, Lisp_Object parms,
+ Lisp_Object timeout, Lisp_Object dx, Lisp_Object dy)
{
struct frame *tip_f;
struct window *w;
@@ -7350,42 +7216,38 @@ Text larger than the specified size is clipped. */)
int old_windows_or_buffers_changed = windows_or_buffers_changed;
ptrdiff_t count = SPECPDL_INDEX ();
ptrdiff_t count_1;
- Lisp_Object window, size;
- Lisp_Object tip_buf;
+ Lisp_Object window, size, tip_buf;
AUTO_STRING (tip, " *tip*");
specbind (Qinhibit_redisplay, Qt);
CHECK_STRING (string);
+
+ if (NILP (frame))
+ frame = selected_frame;
decode_window_system_frame (frame);
+
if (NILP (timeout))
- timeout = make_number (5);
+ timeout = make_fixnum (5);
else
- CHECK_NATNUM (timeout);
+ CHECK_FIXNAT (timeout);
if (NILP (dx))
- dx = make_number (5);
+ dx = make_fixnum (5);
else
- CHECK_NUMBER (dx);
+ CHECK_FIXNUM (dx);
if (NILP (dy))
- dy = make_number (-10);
+ dy = make_fixnum (-10);
else
- CHECK_NUMBER (dy);
-
- if (NILP (last_show_tip_args))
- last_show_tip_args = Fmake_vector (make_number (3), Qnil);
+ CHECK_FIXNUM (dy);
if (FRAMEP (tip_frame) && FRAME_LIVE_P (XFRAME (tip_frame)))
{
- Lisp_Object last_string = AREF (last_show_tip_args, 0);
- Lisp_Object last_frame = AREF (last_show_tip_args, 1);
- Lisp_Object last_parms = AREF (last_show_tip_args, 2);
-
if (FRAME_VISIBLE_P (XFRAME (tip_frame))
- && EQ (frame, last_frame)
- && !NILP (Fequal_including_properties (last_string, string))
- && !NILP (Fequal (last_parms, parms)))
+ && EQ (frame, tip_last_frame)
+ && !NILP (Fequal_including_properties (string, tip_last_string))
+ && !NILP (Fequal (parms, tip_last_parms)))
{
/* Only DX and DY have changed. */
tip_f = XFRAME (tip_frame);
@@ -7419,14 +7281,14 @@ Text larger than the specified size is clipped. */)
goto start_timer;
}
- else if (tooltip_reuse_hidden_frame && EQ (frame, last_frame))
+ else if (tooltip_reuse_hidden_frame && EQ (frame, tip_last_frame))
{
bool delete = false;
Lisp_Object tail, elt, parm, last;
/* Check if every parameter in PARMS has the same value in
- last_parms. This may destruct last_parms which, however,
- will be recreated below. */
+ tip_last_parms. This may destruct tip_last_parms
+ which, however, will be recreated below. */
for (tail = parms; CONSP (tail); tail = XCDR (tail))
{
elt = XCAR (tail);
@@ -7436,7 +7298,7 @@ Text larger than the specified size is clipped. */)
if (!EQ (parm, Qleft) && !EQ (parm, Qtop)
&& !EQ (parm, Qright) && !EQ (parm, Qbottom))
{
- last = Fassq (parm, last_parms);
+ last = Fassq (parm, tip_last_parms);
if (NILP (Fequal (Fcdr (elt), Fcdr (last))))
{
/* We lost, delete the old tooltip. */
@@ -7444,15 +7306,17 @@ Text larger than the specified size is clipped. */)
break;
}
else
- last_parms = call2 (Qassq_delete_all, parm, last_parms);
+ tip_last_parms =
+ call2 (Qassq_delete_all, parm, tip_last_parms);
}
else
- last_parms = call2 (Qassq_delete_all, parm, last_parms);
+ tip_last_parms =
+ call2 (Qassq_delete_all, parm, tip_last_parms);
}
- /* Now check if there's a parameter left in last_parms with a
+ /* Now check if there's a parameter left in tip_last_parms with a
non-nil value. */
- for (tail = last_parms; CONSP (tail); tail = XCDR (tail))
+ for (tail = tip_last_parms; CONSP (tail); tail = XCDR (tail))
{
elt = XCAR (tail);
parm = Fcar (elt);
@@ -7473,9 +7337,9 @@ Text larger than the specified size is clipped. */)
else
x_hide_tip (true);
- ASET (last_show_tip_args, 0, string);
- ASET (last_show_tip_args, 1, frame);
- ASET (last_show_tip_args, 2, parms);
+ tip_last_frame = frame;
+ tip_last_string = string;
+ tip_last_parms = parms;
/* Block input until the tip has been fully drawn, to avoid crashes
when drawing tips in menus. */
@@ -7487,16 +7351,17 @@ Text larger than the specified size is clipped. */)
if (NILP (Fassq (Qname, parms)))
parms = Fcons (Fcons (Qname, build_string ("tooltip")), parms);
if (NILP (Fassq (Qinternal_border_width, parms)))
- parms = Fcons (Fcons (Qinternal_border_width, make_number (3)), parms);
+ parms = Fcons (Fcons (Qinternal_border_width, make_fixnum (3)), parms);
if (NILP (Fassq (Qborder_width, parms)))
- parms = Fcons (Fcons (Qborder_width, make_number (1)), parms);
+ parms = Fcons (Fcons (Qborder_width, make_fixnum (1)), parms);
if (NILP (Fassq (Qborder_color, parms)))
- parms = Fcons (Fcons (Qborder_color, build_string ("lightyellow")), parms);
+ parms = Fcons (Fcons (Qborder_color, build_string ("lightyellow")),
+ parms);
if (NILP (Fassq (Qbackground_color, parms)))
parms = Fcons (Fcons (Qbackground_color, build_string ("lightyellow")),
parms);
- /* Create a frame for the tooltip, and record it in the global
+ /* Create a frame for the tooltip and record it in the global
variable tip_frame. */
struct frame *f; /* The value is unused. */
if (NILP (tip_frame = x_create_tip_frame (FRAME_DISPLAY_INFO (f), parms)))
@@ -7512,8 +7377,8 @@ Text larger than the specified size is clipped. */)
tip_buf = Fget_buffer_create (tip);
/* We will mark the tip window a "pseudo-window" below, and such
windows cannot have display margins. */
- bset_left_margin_cols (XBUFFER (tip_buf), make_number (0));
- bset_right_margin_cols (XBUFFER (tip_buf), make_number (0));
+ bset_left_margin_cols (XBUFFER (tip_buf), make_fixnum (0));
+ bset_right_margin_cols (XBUFFER (tip_buf), make_fixnum (0));
set_window_buffer (window, tip_buf, false, false);
w = XWINDOW (window);
w->pseudo_window_p = true;
@@ -7528,11 +7393,11 @@ Text larger than the specified size is clipped. */)
w->pixel_top = 0;
if (CONSP (Vx_max_tooltip_size)
- && RANGED_INTEGERP (1, XCAR (Vx_max_tooltip_size), INT_MAX)
- && RANGED_INTEGERP (1, XCDR (Vx_max_tooltip_size), INT_MAX))
+ && RANGED_FIXNUMP (1, XCAR (Vx_max_tooltip_size), INT_MAX)
+ && RANGED_FIXNUMP (1, XCDR (Vx_max_tooltip_size), INT_MAX))
{
- w->total_cols = XFASTINT (XCAR (Vx_max_tooltip_size));
- w->total_lines = XFASTINT (XCDR (Vx_max_tooltip_size));
+ w->total_cols = XFIXNAT (XCAR (Vx_max_tooltip_size));
+ w->total_lines = XFIXNAT (XCDR (Vx_max_tooltip_size));
}
else
{
@@ -7562,18 +7427,18 @@ Text larger than the specified size is clipped. */)
try_window (window, pos, TRY_WINDOW_IGNORE_FONTS_CHANGE);
/* Calculate size of tooltip window. */
size = Fwindow_text_pixel_size (window, Qnil, Qnil, Qnil,
- make_number (w->pixel_height), Qnil);
+ make_fixnum (w->pixel_height), Qnil);
/* Add the frame's internal border to calculated size. */
- width = XINT (Fcar (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f);
- height = XINT (Fcdr (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f);
+ width = XFIXNUM (Fcar (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f);
+ height = XFIXNUM (Fcdr (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f);
/* Calculate position of tooltip frame. */
compute_tip_xy (tip_f, parms, dx, dy, width, height, &root_x, &root_y);
/* Show tooltip frame. */
{
RECT rect;
- int pad = (NUMBERP (Vw32_tooltip_extra_pixels)
- ? max (0, XINT (Vw32_tooltip_extra_pixels))
+ int pad = (FIXNUMP (Vw32_tooltip_extra_pixels)
+ ? max (0, XFIXNUM (Vw32_tooltip_extra_pixels))
: FRAME_COLUMN_WIDTH (tip_f));
rect.left = rect.top = 0;
@@ -7617,8 +7482,7 @@ Text larger than the specified size is clipped. */)
DEFUN ("x-hide-tip", Fx_hide_tip, Sx_hide_tip, 0, 0, 0,
- doc: /* Hide the current tooltip window, if there is any.
-Value is t if tooltip was open, nil otherwise. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(void)
{
return x_hide_tip (!tooltip_reuse_hidden_frame);
@@ -7764,18 +7628,7 @@ w32_dialog_in_progress (Lisp_Object in_progress)
}
DEFUN ("x-file-dialog", Fx_file_dialog, Sx_file_dialog, 2, 5, 0,
- doc: /* Read file name, prompting with PROMPT in directory DIR.
-Use a file selection dialog. Select DEFAULT-FILENAME in the dialog's file
-selection box, if specified. If MUSTMATCH is non-nil, the returned file
-or directory must exist.
-
-This function is only defined on NS, MS Windows, and X Windows with the
-Motif or Gtk toolkits. With the Motif toolkit, ONLY-DIR-P is ignored.
-Otherwise, if ONLY-DIR-P is non-nil, the user can only select directories.
-On Windows 7 and later, the file selection dialog "remembers" the last
-directory where the user selected a file, and will open that directory
-instead of DIR on subsequent invocations of this function with the same
-value of DIR as in previous invocations; this is standard Windows behavior. */)
+ doc: /* SKIP: real doc in xfns.c. */)
(Lisp_Object prompt, Lisp_Object dir, Lisp_Object default_filename, Lisp_Object mustmatch, Lisp_Object only_dir_p)
{
/* Filter index: 1: All Files, 2: Directories only */
@@ -8112,7 +7965,7 @@ DEFUN ("system-move-file-to-trash", Fsystem_move_file_to_trash,
{
SHFILEOPSTRUCTW file_op_w;
/* We need one more element beyond MAX_PATH because this is
- a list of file names, with the last element double-null
+ a list of file names, with the last element double-NUL
terminated. */
wchar_t tmp_path_w[MAX_PATH + 1];
@@ -8187,10 +8040,10 @@ If optional parameter FRAME is not specified, use selected frame. */)
{
struct frame *f = decode_window_system_frame (frame);
- CHECK_NUMBER (command);
+ CHECK_FIXNUM (command);
if (FRAME_W32_P (f))
- PostMessage (FRAME_W32_WINDOW (f), WM_SYSCOMMAND, XINT (command), 0);
+ PostMessage (FRAME_W32_WINDOW (f), WM_SYSCOMMAND, XFIXNUM (command), 0);
return Qnil;
}
@@ -8297,8 +8150,8 @@ a ShowWindow flag:
}
result = (intptr_t) ShellExecuteW (NULL, ops_w, doc_w, params_w,
GUI_SDATA (current_dir),
- (INTEGERP (show_flag)
- ? XINT (show_flag) : SW_SHOWDEFAULT));
+ (FIXNUMP (show_flag)
+ ? XFIXNUM (show_flag) : SW_SHOWDEFAULT));
if (result > 32)
return Qt;
@@ -8363,7 +8216,7 @@ a ShowWindow flag:
if (c_isalpha (*p) && p[1] == ':' && IS_DIRECTORY_SEP (p[2]))
document = Fsubstring_no_properties (document,
- make_number (file_url_len), Qnil);
+ make_fixnum (file_url_len), Qnil);
}
/* We have a situation here. If DOCUMENT is a relative file name,
but its name includes leading directories, i.e. it lives not in
@@ -8373,7 +8226,7 @@ a ShowWindow flag:
URL, for example. So we make it absolute only if it is an
existing file; if it is a file that does not exist, tough. */
absdoc = Fexpand_file_name (document, Qnil);
- /* Don't call file handlers for file-exists-p, since they might
+ /* Don't call file name handlers for file-exists-p, since they might
attempt to access the file, which could fail or produce undesired
consequences, see bug#16558 for an example. */
handler = Ffind_file_name_handler (absdoc, Qfile_exists_p);
@@ -8455,7 +8308,7 @@ a ShowWindow flag:
shexinfo_w.lpParameters = params_w;
shexinfo_w.lpDirectory = current_dir_w;
shexinfo_w.nShow =
- (INTEGERP (show_flag) ? XINT (show_flag) : SW_SHOWDEFAULT);
+ (FIXNUMP (show_flag) ? XFIXNUM (show_flag) : SW_SHOWDEFAULT);
success = ShellExecuteExW (&shexinfo_w);
xfree (doc_w);
}
@@ -8490,7 +8343,7 @@ a ShowWindow flag:
shexinfo_a.lpParameters = params_a;
shexinfo_a.lpDirectory = current_dir_a;
shexinfo_a.nShow =
- (INTEGERP (show_flag) ? XINT (show_flag) : SW_SHOWDEFAULT);
+ (FIXNUMP (show_flag) ? XFIXNUM (show_flag) : SW_SHOWDEFAULT);
success = ShellExecuteExA (&shexinfo_a);
xfree (doc_w);
xfree (doc_a);
@@ -8566,14 +8419,14 @@ w32_parse_and_hook_hot_key (Lisp_Object key, int hook)
if (CONSP (c) && lucid_event_type_list_p (c))
c = Fevent_convert_list (c);
- if (! INTEGERP (c) && ! SYMBOLP (c))
+ if (! FIXNUMP (c) && ! SYMBOLP (c))
error ("Key definition is invalid");
/* Work out the base key and the modifiers. */
if (SYMBOLP (c))
{
c = parse_modifiers (c);
- lisp_modifiers = XINT (Fcar (Fcdr (c)));
+ lisp_modifiers = XFIXNUM (Fcar (Fcdr (c)));
c = Fcar (c);
if (!SYMBOLP (c))
emacs_abort ();
@@ -8584,11 +8437,11 @@ w32_parse_and_hook_hot_key (Lisp_Object key, int hook)
else
vk_code = lookup_vk_code (vkname);
}
- else if (INTEGERP (c))
+ else if (FIXNUMP (c))
{
- lisp_modifiers = XINT (c) & ~CHARACTERBITS;
+ lisp_modifiers = XFIXNUM (c) & ~CHARACTERBITS;
/* Many ascii characters are their own virtual key code. */
- vk_code = XINT (c) & CHARACTERBITS;
+ vk_code = XFIXNUM (c) & CHARACTERBITS;
}
if (vk_code < 0 || vk_code > 255)
@@ -8688,7 +8541,7 @@ any key combinations, otherwise nil. */)
/* Notify input thread about new hot-key definition, so that it
takes effect without needing to switch focus. */
PostThreadMessage (dwWindowsThreadId, WM_EMACS_REGISTER_HOT_KEY,
- (WPARAM) XINT (key), 0);
+ (WPARAM) XFIXNUM (key), 0);
}
return key;
@@ -8701,7 +8554,7 @@ DEFUN ("w32-unregister-hot-key", Fw32_unregister_hot_key,
{
Lisp_Object item;
- if (!INTEGERP (key))
+ if (!FIXNUMP (key))
key = w32_parse_and_hook_hot_key (key, 0);
if (w32_kbdhook_active)
@@ -8716,12 +8569,12 @@ DEFUN ("w32-unregister-hot-key", Fw32_unregister_hot_key,
eassert (CONSP (item));
/* Pass the tail of the list as a pointer to a Lisp_Cons cell,
so that it works in a --with-wide-int build as well. */
- lparam = (LPARAM) XUNTAG (item, Lisp_Cons);
+ lparam = (LPARAM) XUNTAG (item, Lisp_Cons, struct Lisp_Cons);
/* Notify input thread about hot-key definition being removed, so
that it takes effect without needing focus switch. */
if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_UNREGISTER_HOT_KEY,
- (WPARAM) XINT (XCAR (item)), lparam))
+ (WPARAM) XFIXNUM (XCAR (item)), lparam))
{
MSG msg;
GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
@@ -8748,7 +8601,7 @@ usage: (w32-reconstruct-hot-key ID) */)
int vk_code, w32_modifiers;
Lisp_Object key;
- CHECK_NUMBER (hotkeyid);
+ CHECK_FIXNUM (hotkeyid);
vk_code = HOTKEY_VK_CODE (hotkeyid);
w32_modifiers = HOTKEY_MODIFIERS (hotkeyid);
@@ -8756,7 +8609,7 @@ usage: (w32-reconstruct-hot-key ID) */)
if (vk_code < 256 && lispy_function_keys[vk_code])
key = intern (lispy_function_keys[vk_code]);
else
- key = make_number (vk_code);
+ key = make_fixnum (vk_code);
key = Fcons (key, Qnil);
if (w32_modifiers & MOD_SHIFT)
@@ -8796,18 +8649,18 @@ to change the state. */)
return Qnil;
if (!dwWindowsThreadId)
- return make_number (w32_console_toggle_lock_key (vk_code, new_state));
+ return make_fixnum (w32_console_toggle_lock_key (vk_code, new_state));
if (NILP (new_state))
lparam = -1;
else
- lparam = (XUINT (new_state)) & 1;
+ lparam = (XUFIXNUM (new_state)) & 1;
if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_TOGGLE_LOCK_KEY,
(WPARAM) vk_code, lparam))
{
MSG msg;
GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
- return make_number (msg.wParam);
+ return make_fixnum (msg.wParam);
}
return Qnil;
}
@@ -8939,34 +8792,33 @@ and width values are in pixels.
/* A single line menu bar. */
menu_bar_height = single_menu_bar_height;
- return listn (CONSTYPE_HEAP, 10,
- Fcons (Qouter_position,
- Fcons (make_number (left), make_number (top))),
+ return list (Fcons (Qouter_position,
+ Fcons (make_fixnum (left), make_fixnum (top))),
Fcons (Qouter_size,
- Fcons (make_number (right - left),
- make_number (bottom - top))),
+ Fcons (make_fixnum (right - left),
+ make_fixnum (bottom - top))),
Fcons (Qexternal_border_size,
- Fcons (make_number (external_border_width),
- make_number (external_border_height))),
+ Fcons (make_fixnum (external_border_width),
+ make_fixnum (external_border_height))),
Fcons (Qtitle_bar_size,
- Fcons (make_number (title_bar_width),
- make_number (title_bar_height))),
+ Fcons (make_fixnum (title_bar_width),
+ make_fixnum (title_bar_height))),
Fcons (Qmenu_bar_external, Qt),
Fcons (Qmenu_bar_size,
- Fcons (make_number
+ Fcons (make_fixnum
(menu_bar.rcBar.right - menu_bar.rcBar.left),
- make_number (menu_bar_height))),
+ make_fixnum (menu_bar_height))),
Fcons (Qtool_bar_external, Qnil),
Fcons (Qtool_bar_position, tool_bar_height ? Qtop : Qnil),
Fcons (Qtool_bar_size,
- Fcons (make_number
+ Fcons (make_fixnum
(tool_bar_height
? (right - left - 2 * external_border_width
- 2 * internal_border_width)
: 0),
- make_number (tool_bar_height))),
+ make_fixnum (tool_bar_height))),
Fcons (Qinternal_border_width,
- make_number (internal_border_width)));
+ make_fixnum (internal_border_width)));
}
DEFUN ("w32-frame-edges", Fw32_frame_edges, Sw32_frame_edges, 0, 2, 0,
@@ -9003,10 +8855,10 @@ menu bar or tool bar of FRAME. */)
unblock_input ();
if (success)
- return list4 (make_number (rectangle.left),
- make_number (rectangle.top),
- make_number (rectangle.right),
- make_number (rectangle.bottom));
+ return list4 (make_fixnum (rectangle.left),
+ make_fixnum (rectangle.top),
+ make_fixnum (rectangle.right),
+ make_fixnum (rectangle.bottom));
else
return Qnil;
}
@@ -9045,16 +8897,16 @@ menu bar or tool bar of FRAME. */)
{
int internal_border_width = FRAME_INTERNAL_BORDER_WIDTH (f);
- return list4 (make_number (left + internal_border_width),
- make_number (top
+ return list4 (make_fixnum (left + internal_border_width),
+ make_fixnum (top
+ FRAME_TOOL_BAR_HEIGHT (f)
+ internal_border_width),
- make_number (right - internal_border_width),
- make_number (bottom - internal_border_width));
+ make_fixnum (right - internal_border_width),
+ make_fixnum (bottom - internal_border_width));
}
else
- return list4 (make_number (left), make_number (top),
- make_number (right), make_number (bottom));
+ return list4 (make_fixnum (left), make_fixnum (top),
+ make_fixnum (right), make_fixnum (bottom));
}
}
@@ -9202,7 +9054,7 @@ selected frame's display. */)
GetCursorPos (&pt);
unblock_input ();
- return Fcons (make_number (pt.x), make_number (pt.y));
+ return Fcons (make_fixnum (pt.x), make_fixnum (pt.y));
}
DEFUN ("w32-set-mouse-absolute-pixel-position", Fw32_set_mouse_absolute_pixel_position,
@@ -9225,7 +9077,7 @@ The coordinates X and Y are interpreted in pixels relative to a position
if (os_subtype == OS_NT
&& w32_major_version + w32_minor_version >= 6)
ret = SystemParametersInfo (SPI_GETMOUSETRAILS, 0, &trail_num, 0);
- SetCursorPos (XINT (x), XINT (y));
+ SetCursorPos (XFIXNUM (x), XFIXNUM (y));
if (ret)
SystemParametersInfo (SPI_SETMOUSETRAILS, trail_num, NULL, 0);
unblock_input ();
@@ -9233,115 +9085,6 @@ The coordinates X and Y are interpreted in pixels relative to a position
return Qnil;
}
-DEFUN ("w32-battery-status", Fw32_battery_status, Sw32_battery_status, 0, 0, 0,
- doc: /* Get power status information from Windows system.
-
-The following %-sequences are provided:
-%L AC line status (verbose)
-%B Battery status (verbose)
-%b Battery status, empty means high, `-' means low,
- `!' means critical, and `+' means charging
-%p Battery load percentage
-%s Remaining time (to charge or discharge) in seconds
-%m Remaining time (to charge or discharge) in minutes
-%h Remaining time (to charge or discharge) in hours
-%t Remaining time (to charge or discharge) in the form `h:min' */)
- (void)
-{
- Lisp_Object status = Qnil;
-
- SYSTEM_POWER_STATUS system_status;
- if (GetSystemPowerStatus (&system_status))
- {
- Lisp_Object line_status, battery_status, battery_status_symbol;
- Lisp_Object load_percentage, seconds, minutes, hours, remain;
-
- long seconds_left = (long) system_status.BatteryLifeTime;
-
- if (system_status.ACLineStatus == 0)
- line_status = build_string ("off-line");
- else if (system_status.ACLineStatus == 1)
- line_status = build_string ("on-line");
- else
- line_status = build_string ("N/A");
-
- if (system_status.BatteryFlag & 128)
- {
- battery_status = build_string ("N/A");
- battery_status_symbol = empty_unibyte_string;
- }
- else if (system_status.BatteryFlag & 8)
- {
- battery_status = build_string ("charging");
- battery_status_symbol = build_string ("+");
- if (system_status.BatteryFullLifeTime != -1L)
- seconds_left = system_status.BatteryFullLifeTime - seconds_left;
- }
- else if (system_status.BatteryFlag & 4)
- {
- battery_status = build_string ("critical");
- battery_status_symbol = build_string ("!");
- }
- else if (system_status.BatteryFlag & 2)
- {
- battery_status = build_string ("low");
- battery_status_symbol = build_string ("-");
- }
- else if (system_status.BatteryFlag & 1)
- {
- battery_status = build_string ("high");
- battery_status_symbol = empty_unibyte_string;
- }
- else
- {
- battery_status = build_string ("medium");
- battery_status_symbol = empty_unibyte_string;
- }
-
- if (system_status.BatteryLifePercent > 100)
- load_percentage = build_string ("N/A");
- else
- {
- char buffer[16];
- snprintf (buffer, 16, "%d", system_status.BatteryLifePercent);
- load_percentage = build_string (buffer);
- }
-
- if (seconds_left < 0)
- seconds = minutes = hours = remain = build_string ("N/A");
- else
- {
- long m;
- double h;
- char buffer[16];
- snprintf (buffer, 16, "%ld", seconds_left);
- seconds = build_string (buffer);
-
- m = seconds_left / 60;
- snprintf (buffer, 16, "%ld", m);
- minutes = build_string (buffer);
-
- h = seconds_left / 3600.0;
- snprintf (buffer, 16, "%3.1f", h);
- hours = build_string (buffer);
-
- snprintf (buffer, 16, "%ld:%02ld", m / 60, m % 60);
- remain = build_string (buffer);
- }
-
- status = listn (CONSTYPE_HEAP, 8,
- Fcons (make_number ('L'), line_status),
- Fcons (make_number ('B'), battery_status),
- Fcons (make_number ('b'), battery_status_symbol),
- Fcons (make_number ('p'), load_percentage),
- Fcons (make_number ('s'), seconds),
- Fcons (make_number ('m'), minutes),
- Fcons (make_number ('h'), hours),
- Fcons (make_number ('t'), remain));
- }
- return status;
-}
-
#ifdef WINDOWSNT
typedef BOOL (WINAPI *GetDiskFreeSpaceExW_Proc)
@@ -9350,11 +9093,7 @@ typedef BOOL (WINAPI *GetDiskFreeSpaceExA_Proc)
(LPCSTR, PULARGE_INTEGER, PULARGE_INTEGER, PULARGE_INTEGER);
DEFUN ("file-system-info", Ffile_system_info, Sfile_system_info, 1, 1, 0,
- doc: /* Return storage information about the file system FILENAME is on.
-Value is a list of floats (TOTAL FREE AVAIL), where TOTAL is the total
-storage of the file system, FREE is the free storage, and AVAIL is the
-storage available to a non-superuser. All 3 numbers are in bytes.
-If the underlying system call fails, value is nil. */)
+ doc: /* SKIP: Real doc in fileio.c. */)
(Lisp_Object filename)
{
Lisp_Object encoded, value;
@@ -9363,6 +9102,17 @@ If the underlying system call fails, value is nil. */)
filename = Fexpand_file_name (filename, Qnil);
encoded = ENCODE_FILE (filename);
+ /* If the file name has special constructs in it,
+ call the corresponding file name handler. */
+ Lisp_Object handler = Ffind_file_name_handler (encoded, Qfile_system_info);
+ if (!NILP (handler))
+ {
+ value = call2 (handler, Qfile_system_info, encoded);
+ if (CONSP (value) || NILP (value))
+ return value;
+ error ("Invalid handler in `file-name-handler-alist'");
+ }
+
value = Qnil;
/* Determining the required information on Windows turns out, sadly,
@@ -9373,9 +9123,9 @@ If the underlying system call fails, value is nil. */)
{
HMODULE hKernel = GetModuleHandle ("kernel32");
GetDiskFreeSpaceExW_Proc pfn_GetDiskFreeSpaceExW =
- (GetDiskFreeSpaceExW_Proc) GetProcAddress (hKernel, "GetDiskFreeSpaceExW");
+ (GetDiskFreeSpaceExW_Proc) get_proc_addr (hKernel, "GetDiskFreeSpaceExW");
GetDiskFreeSpaceExA_Proc pfn_GetDiskFreeSpaceExA =
- (GetDiskFreeSpaceExA_Proc) GetProcAddress (hKernel, "GetDiskFreeSpaceExA");
+ (GetDiskFreeSpaceExA_Proc) get_proc_addr (hKernel, "GetDiskFreeSpaceExA");
bool have_pfn_GetDiskFreeSpaceEx =
((w32_unicode_filenames && pfn_GetDiskFreeSpaceExW)
|| (!w32_unicode_filenames && pfn_GetDiskFreeSpaceExA));
@@ -9687,8 +9437,8 @@ w32_console_toggle_lock_key (int vk_code, Lisp_Object new_state)
int cur_state = (GetKeyState (vk_code) & 1);
if (NILP (new_state)
- || (NUMBERP (new_state)
- && ((XUINT (new_state)) & 1) != cur_state))
+ || (FIXNUMP (new_state)
+ && ((XUFIXNUM (new_state)) & 1) != cur_state))
{
#ifdef WINDOWSNT
faked_key = vk_code;
@@ -9950,8 +9700,8 @@ get_dll_version (const char *dll_name)
if (hdll)
{
- DLLGETVERSIONPROC pDllGetVersion
- = (DLLGETVERSIONPROC) GetProcAddress (hdll, "DllGetVersion");
+ DLLGETVERSIONPROC pDllGetVersion = (DLLGETVERSIONPROC)
+ get_proc_addr (hdll, "DllGetVersion");
if (pDllGetVersion)
{
@@ -9974,7 +9724,7 @@ get_dll_version (const char *dll_name)
/* Return the number of bytes in UTF-8 encoded string STR that
corresponds to at most LIM characters. If STR ends before LIM
characters, return the number of bytes in STR including the
- terminating null byte. */
+ terminating NUL byte. */
static int
utf8_mbslen_lim (const char *str, int lim)
{
@@ -10315,7 +10065,7 @@ usage: (w32-notification-notify &rest PARAMS) */)
/* Do it! */
retval = add_tray_notification (f, icon, tip, severity, timeout, title, msg);
- return (retval < 0 ? Qnil : make_number (retval));
+ return (retval < 0 ? Qnil : make_fixnum (retval));
}
DEFUN ("w32-notification-close",
@@ -10326,8 +10076,8 @@ DEFUN ("w32-notification-close",
{
struct frame *f = SELECTED_FRAME ();
- if (INTEGERP (id))
- delete_tray_notification (f, XINT (id));
+ if (FIXNUMP (id))
+ delete_tray_notification (f, XFIXNUM (id));
return Qnil;
}
@@ -10335,6 +10085,74 @@ DEFUN ("w32-notification-close",
#endif /* WINDOWSNT && !HAVE_DBUS */
+#ifdef WINDOWSNT
+/***********************************************************************
+ Reading Registry
+ ***********************************************************************/
+DEFUN ("w32-read-registry",
+ Fw32_read_registry, Sw32_read_registry,
+ 3, 3, 0,
+ doc: /* Return the value stored in MS-Windows Registry under ROOT/KEY/NAME.
+
+ROOT is a symbol, one of `HKCR', `HKCU', `HKLM', `HKU', or `HKCC'.
+It can also be nil, which means try `HKCU', and if that fails, try `HKLM'.
+
+KEY and NAME must be strings, and NAME must not include slashes.
+KEY can use either forward- or back-slashes.
+To access the default value of KEY (if it is defined), use NAME
+that is an empty string.
+
+If the the named KEY or its subkey called NAME don't exist, or cannot
+be accessed by the current user, the function returns nil. Otherwise,
+the return value depends on the type of the data stored in Registry:
+
+ If the data type is REG_NONE, the function returns t.
+ If the data type is REG_DWORD or REG_QWORD, the function returns
+ its integer value. If the value is too large for a fixnum,
+ the function returns a bignum.
+ If the data type is REG_BINARY, the function returns a vector whose
+ elements are individual bytes of the value.
+ If the data type is REG_SZ, the function returns a string.
+ If the data type is REG_EXPAND_SZ, the function returns a string
+ with all the %..% references to environment variables replaced
+ by the values of those variables. If the expansion fails, or
+ some variables are not defined in the environment, some or all
+ of the environment variables will remain unexpanded.
+ If the data type is REG_MULTI_SZ, the function returns a list whose
+ elements are the individual strings.
+
+Note that this function doesn't know whether a string value is a file
+name, so file names will be returned with backslashes, which may need
+to be converted to forward slashes by the caller. */)
+ (Lisp_Object root, Lisp_Object key, Lisp_Object name)
+{
+ CHECK_SYMBOL (root);
+ CHECK_STRING (key);
+ CHECK_STRING (name);
+
+ HKEY rootkey = HKEY_CURRENT_USER;
+ if (EQ (root, QHKCR))
+ rootkey = HKEY_CLASSES_ROOT;
+ else if (EQ (root, QHKCU))
+ rootkey = HKEY_CURRENT_USER;
+ else if (EQ (root, QHKLM))
+ rootkey = HKEY_LOCAL_MACHINE;
+ else if (EQ (root, QHKU))
+ rootkey = HKEY_USERS;
+ else if (EQ (root, QHKCC))
+ rootkey = HKEY_CURRENT_CONFIG;
+ else if (!NILP (root))
+ error ("unknown root key: %s", SDATA (SYMBOL_NAME (root)));
+
+ Lisp_Object val = w32_read_registry (rootkey, key, name);
+ if (NILP (val) && NILP (root))
+ val = w32_read_registry (HKEY_LOCAL_MACHINE, key, name);
+
+ return val;
+}
+
+#endif /* WINDOWSNT */
+
/***********************************************************************
Initialization
***********************************************************************/
@@ -10399,6 +10217,7 @@ syms_of_w32fns (void)
track_mouse_window = NULL;
w32_visible_system_caret_hwnd = NULL;
+ PDUMPER_IGNORE (w32_visible_system_caret_hwnd);
DEFSYM (Qundefined_color, "undefined-color");
DEFSYM (Qcancel_timer, "cancel-timer");
@@ -10427,15 +10246,24 @@ syms_of_w32fns (void)
DEFSYM (QCbody, ":body");
#endif
+#ifdef WINDOWSNT
+ DEFSYM (QHKCR, "HKCR");
+ DEFSYM (QHKCU, "HKCU");
+ DEFSYM (QHKLM, "HKLM");
+ DEFSYM (QHKU, "HKU");
+ DEFSYM (QHKCC, "HKCC");
+#endif
+
/* Symbols used elsewhere, but only in MS-Windows-specific code. */
DEFSYM (Qgnutls, "gnutls");
DEFSYM (Qlibxml2, "libxml2");
DEFSYM (Qserif, "serif");
DEFSYM (Qzlib, "zlib");
DEFSYM (Qlcms2, "lcms2");
+ DEFSYM (Qjson, "json");
Fput (Qundefined_color, Qerror_conditions,
- listn (CONSTYPE_PURE, 2, Qundefined_color, Qerror));
+ pure_list (Qundefined_color, Qerror));
Fput (Qundefined_color, Qerror_message,
build_pure_c_string ("Undefined color"));
@@ -10625,9 +10453,7 @@ bass-down, bass-boost, bass-up, treble-down, treble-up */);
#if 0 /* TODO: Mouse cursor customization. */
DEFVAR_LISP ("x-pointer-shape", Vx_pointer_shape,
- doc: /* The shape of the pointer when over text.
-Changing the value does not affect existing frames
-unless you set the mouse color. */);
+ doc: /* SKIP: real doc in xfns.c. */);
Vx_pointer_shape = Qnil;
Vx_nontext_pointer_shape = Qnil;
@@ -10635,58 +10461,42 @@ unless you set the mouse color. */);
Vx_mode_pointer_shape = Qnil;
DEFVAR_LISP ("x-hourglass-pointer-shape", Vx_hourglass_pointer_shape,
- doc: /* The shape of the pointer when Emacs is busy.
-This variable takes effect when you create a new frame
-or when you set the mouse color. */);
+ doc: /* SKIP: real doc in xfns.c. */);
Vx_hourglass_pointer_shape = Qnil;
DEFVAR_LISP ("x-sensitive-text-pointer-shape",
Vx_sensitive_text_pointer_shape,
- doc: /* The shape of the pointer when over mouse-sensitive text.
-This variable takes effect when you create a new frame
-or when you set the mouse color. */);
+ doc: /* SKIP: real doc in xfns.c. */);
Vx_sensitive_text_pointer_shape = Qnil;
DEFVAR_LISP ("x-window-horizontal-drag-cursor",
Vx_window_horizontal_drag_shape,
- doc: /* Pointer shape to use for indicating a window can be dragged horizontally.
-This variable takes effect when you create a new frame
-or when you set the mouse color. */);
+ doc: /* SKIP: real doc in xfns.c. */);
Vx_window_horizontal_drag_shape = Qnil;
DEFVAR_LISP ("x-window-vertical-drag-cursor",
Vx_window_vertical_drag_shape,
- doc: /* Pointer shape to use for indicating a window can be dragged vertically.
-This variable takes effect when you create a new frame
-or when you set the mouse color. */);
+ doc: /* SKIP: real doc in xfns.c. */);
Vx_window_vertical_drag_shape = Qnil;
#endif
DEFVAR_LISP ("x-cursor-fore-pixel", Vx_cursor_fore_pixel,
- doc: /* A string indicating the foreground color of the cursor box. */);
+ doc: /* SKIP: real doc in xfns.c. */);
Vx_cursor_fore_pixel = Qnil;
DEFVAR_LISP ("x-max-tooltip-size", Vx_max_tooltip_size,
- doc: /* Maximum size for tooltips.
-Value is a pair (COLUMNS . ROWS). Text larger than this is clipped. */);
- Vx_max_tooltip_size = Fcons (make_number (80), make_number (40));
+ doc: /* SKIP: real doc in xfns.c. */);
+ Vx_max_tooltip_size = Fcons (make_fixnum (80), make_fixnum (40));
DEFVAR_LISP ("x-no-window-manager", Vx_no_window_manager,
- doc: /* Non-nil if no window manager is in use.
-Emacs doesn't try to figure this out; this is always nil
-unless you set it to something else. */);
+ doc: /* SKIP: real doc in xfns.c. */);
/* We don't have any way to find this out, so set it to nil
and maybe the user would like to set it to t. */
Vx_no_window_manager = Qnil;
DEFVAR_LISP ("x-pixel-size-width-font-regexp",
Vx_pixel_size_width_font_regexp,
- doc: /* Regexp matching a font name whose width is the same as `PIXEL_SIZE'.
-
-Since Emacs gets width of a font matching with this regexp from
-PIXEL_SIZE field of the name, font finding mechanism gets faster for
-such a font. This is especially effective for such large fonts as
-Chinese, Japanese, and Korean. */);
+ doc: /* SKIP: real doc in xfns.c. */);
Vx_pixel_size_width_font_regexp = Qnil;
DEFVAR_LISP ("w32-bdf-filename-alist",
@@ -10794,7 +10604,6 @@ tip frame. */);
defsubr (&Sw32_reconstruct_hot_key);
defsubr (&Sw32_toggle_lock_key);
defsubr (&Sw32_window_exists_p);
- defsubr (&Sw32_battery_status);
defsubr (&Sw32__menu_bar_in_use);
#if defined WINDOWSNT && !defined HAVE_DBUS
defsubr (&Sw32_notification_notify);
@@ -10802,6 +10611,7 @@ tip frame. */);
#endif
#ifdef WINDOWSNT
+ defsubr (&Sw32_read_registry);
defsubr (&Sfile_system_info);
defsubr (&Sdefault_printer_name);
#endif
@@ -10813,9 +10623,12 @@ tip frame. */);
staticpro (&tip_timer);
tip_frame = Qnil;
staticpro (&tip_frame);
-
- last_show_tip_args = Qnil;
- staticpro (&last_show_tip_args);
+ tip_last_frame = Qnil;
+ staticpro (&tip_last_frame);
+ tip_last_string = Qnil;
+ staticpro (&tip_last_string);
+ tip_last_parms = Qnil;
+ staticpro (&tip_last_parms);
defsubr (&Sx_file_dialog);
#ifdef WINDOWSNT
@@ -10852,9 +10665,8 @@ void
w32_reset_stack_overflow_guard (void)
{
if (resetstkoflw == NULL)
- resetstkoflw =
- (_resetstkoflw_proc)GetProcAddress (GetModuleHandle ("msvcrt.dll"),
- "_resetstkoflw");
+ resetstkoflw = (_resetstkoflw_proc)
+ get_proc_addr (GetModuleHandle ("msvcrt.dll"), "_resetstkoflw");
/* We ignore the return value. If _resetstkoflw fails, the next
stack overflow will crash the program. */
if (resetstkoflw != NULL)
@@ -10928,9 +10740,8 @@ w32_backtrace (void **buffer, int limit)
if (!s_pfn_CaptureStackBackTrace)
{
hm_kernel32 = LoadLibrary ("Kernel32.dll");
- s_pfn_CaptureStackBackTrace =
- (CaptureStackBackTrace_proc) GetProcAddress (hm_kernel32,
- "RtlCaptureStackBackTrace");
+ s_pfn_CaptureStackBackTrace = (CaptureStackBackTrace_proc)
+ get_proc_addr (hm_kernel32, "RtlCaptureStackBackTrace");
}
if (s_pfn_CaptureStackBackTrace)
return s_pfn_CaptureStackBackTrace (0, min (BACKTRACE_LIMIT_MAX, limit),
@@ -11063,29 +10874,29 @@ globals_of_w32fns (void)
it dynamically. Do it once, here, instead of every time it is used.
*/
track_mouse_event_fn = (TrackMouseEvent_Proc)
- GetProcAddress (user32_lib, "TrackMouseEvent");
+ get_proc_addr (user32_lib, "TrackMouseEvent");
monitor_from_point_fn = (MonitorFromPoint_Proc)
- GetProcAddress (user32_lib, "MonitorFromPoint");
+ get_proc_addr (user32_lib, "MonitorFromPoint");
get_monitor_info_fn = (GetMonitorInfo_Proc)
- GetProcAddress (user32_lib, "GetMonitorInfoA");
+ get_proc_addr (user32_lib, "GetMonitorInfoA");
monitor_from_window_fn = (MonitorFromWindow_Proc)
- GetProcAddress (user32_lib, "MonitorFromWindow");
+ get_proc_addr (user32_lib, "MonitorFromWindow");
enum_display_monitors_fn = (EnumDisplayMonitors_Proc)
- GetProcAddress (user32_lib, "EnumDisplayMonitors");
+ get_proc_addr (user32_lib, "EnumDisplayMonitors");
get_title_bar_info_fn = (GetTitleBarInfo_Proc)
- GetProcAddress (user32_lib, "GetTitleBarInfo");
+ get_proc_addr (user32_lib, "GetTitleBarInfo");
{
HMODULE imm32_lib = GetModuleHandle ("imm32.dll");
get_composition_string_fn = (ImmGetCompositionString_Proc)
- GetProcAddress (imm32_lib, "ImmGetCompositionStringW");
+ get_proc_addr (imm32_lib, "ImmGetCompositionStringW");
get_ime_context_fn = (ImmGetContext_Proc)
- GetProcAddress (imm32_lib, "ImmGetContext");
+ get_proc_addr (imm32_lib, "ImmGetContext");
release_ime_context_fn = (ImmReleaseContext_Proc)
- GetProcAddress (imm32_lib, "ImmReleaseContext");
+ get_proc_addr (imm32_lib, "ImmReleaseContext");
set_ime_composition_window_fn = (ImmSetCompositionWindow_Proc)
- GetProcAddress (imm32_lib, "ImmSetCompositionWindow");
+ get_proc_addr (imm32_lib, "ImmSetCompositionWindow");
}
except_code = 0;
@@ -11100,6 +10911,15 @@ globals_of_w32fns (void)
doc: /* The ANSI code page used by the system. */);
w32_ansi_code_page = GetACP ();
+#ifndef CYGWIN
+ DEFVAR_INT ("w32-multibyte-code-page",
+ w32_multibyte_code_page,
+ doc: /* The current multibyte code page used by the system.
+A value of zero indicates that the single-byte code page is in use,
+see `w32-ansi-code-page'. */);
+ w32_multibyte_code_page = _getmbcp ();
+#endif
+
if (os_subtype == OS_NT)
w32_unicode_gui = 1;
else
diff --git a/src/w32font.c b/src/w32font.c
index 0570d2acba3..33c89825e94 100644
--- a/src/w32font.c
+++ b/src/w32font.c
@@ -29,9 +29,12 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "coding.h" /* for ENCODE_SYSTEM, DECODE_SYSTEM */
#include "w32font.h"
#ifdef WINDOWSNT
+#include "w32common.h"
#include "w32.h"
#endif
+#include "pdumper.h"
+
/* Cleartype available on Windows XP, cleartype_natural from XP SP1.
The latter does not try to fit cleartype smoothed fonts into the
same bounding box as the non-antialiased version of the font.
@@ -153,7 +156,7 @@ get_outline_metrics_w(HDC hdc, UINT cbData, LPOUTLINETEXTMETRICW lpotmw)
hm_unicows = w32_load_unicows_or_gdi32 ();
if (hm_unicows)
s_pfn_Get_Outline_Text_MetricsW = (GetOutlineTextMetricsW_Proc)
- GetProcAddress (hm_unicows, "GetOutlineTextMetricsW");
+ get_proc_addr (hm_unicows, "GetOutlineTextMetricsW");
}
eassert (s_pfn_Get_Outline_Text_MetricsW != NULL);
return s_pfn_Get_Outline_Text_MetricsW (hdc, cbData, lpotmw);
@@ -170,7 +173,7 @@ get_text_metrics_w(HDC hdc, LPTEXTMETRICW lptmw)
hm_unicows = w32_load_unicows_or_gdi32 ();
if (hm_unicows)
s_pfn_Get_Text_MetricsW = (GetTextMetricsW_Proc)
- GetProcAddress (hm_unicows, "GetTextMetricsW");
+ get_proc_addr (hm_unicows, "GetTextMetricsW");
}
eassert (s_pfn_Get_Text_MetricsW != NULL);
return s_pfn_Get_Text_MetricsW (hdc, lptmw);
@@ -188,7 +191,7 @@ get_glyph_outline_w (HDC hdc, UINT uChar, UINT uFormat, LPGLYPHMETRICS lpgm,
hm_unicows = w32_load_unicows_or_gdi32 ();
if (hm_unicows)
s_pfn_Get_Glyph_OutlineW = (GetGlyphOutlineW_Proc)
- GetProcAddress (hm_unicows, "GetGlyphOutlineW");
+ get_proc_addr (hm_unicows, "GetGlyphOutlineW");
}
eassert (s_pfn_Get_Glyph_OutlineW != NULL);
return s_pfn_Get_Glyph_OutlineW (hdc, uChar, uFormat, lpgm, cbBuffer,
@@ -206,7 +209,7 @@ get_char_width_32_w (HDC hdc, UINT uFirstChar, UINT uLastChar, LPINT lpBuffer)
hm_unicows = w32_load_unicows_or_gdi32 ();
if (hm_unicows)
s_pfn_Get_Char_Width_32W = (GetCharWidth32W_Proc)
- GetProcAddress (hm_unicows, "GetCharWidth32W");
+ get_proc_addr (hm_unicows, "GetCharWidth32W");
}
eassert (s_pfn_Get_Char_Width_32W != NULL);
return s_pfn_Get_Char_Width_32W (hdc, uFirstChar, uLastChar, lpBuffer);
@@ -718,7 +721,7 @@ w32font_draw (struct glyph_string *s, int from, int to,
}
/* w32 implementation of free_entity for font backend.
- Optional (if FONT_EXTRA_INDEX is not Lisp_Save_Value).
+ Optional.
Free FONT_EXTRA_INDEX field of FONT_ENTITY.
static void
w32font_free_entity (Lisp_Object entity);
@@ -920,7 +923,7 @@ w32font_open_internal (struct frame *f, Lisp_Object font_entity,
if (!EQ (val, Qraster))
logfont.lfOutPrecision = OUT_TT_PRECIS;
- size = XINT (AREF (font_entity, FONT_SIZE_INDEX));
+ size = XFIXNUM (AREF (font_entity, FONT_SIZE_INDEX));
if (!size)
size = pixel_size;
@@ -1096,9 +1099,9 @@ w32_enumfont_pattern_entity (Lisp_Object frame,
ASET (entity, FONT_ADSTYLE_INDEX, tem);
if (physical_font->ntmTm.tmPitchAndFamily & 0x01)
- ASET (entity, FONT_SPACING_INDEX, make_number (FONT_SPACING_PROPORTIONAL));
+ ASET (entity, FONT_SPACING_INDEX, make_fixnum (FONT_SPACING_PROPORTIONAL));
else
- ASET (entity, FONT_SPACING_INDEX, make_number (FONT_SPACING_CHARCELL));
+ ASET (entity, FONT_SPACING_INDEX, make_fixnum (FONT_SPACING_CHARCELL));
if (requested_font->lfQuality != DEFAULT_QUALITY)
{
@@ -1109,19 +1112,19 @@ w32_enumfont_pattern_entity (Lisp_Object frame,
intern_font_name (lf->lfFaceName));
FONT_SET_STYLE (entity, FONT_WEIGHT_INDEX,
- make_number (w32_decode_weight (lf->lfWeight)));
+ make_fixnum (w32_decode_weight (lf->lfWeight)));
FONT_SET_STYLE (entity, FONT_SLANT_INDEX,
- make_number (lf->lfItalic ? 200 : 100));
+ make_fixnum (lf->lfItalic ? 200 : 100));
/* TODO: PANOSE struct has this info, but need to call GetOutlineTextMetrics
to get it. */
- FONT_SET_STYLE (entity, FONT_WIDTH_INDEX, make_number (100));
+ FONT_SET_STYLE (entity, FONT_WIDTH_INDEX, make_fixnum (100));
if (font_type & RASTER_FONTTYPE)
ASET (entity, FONT_SIZE_INDEX,
- make_number (physical_font->ntmTm.tmHeight
+ make_fixnum (physical_font->ntmTm.tmHeight
+ physical_font->ntmTm.tmExternalLeading));
else
- ASET (entity, FONT_SIZE_INDEX, make_number (0));
+ ASET (entity, FONT_SIZE_INDEX, make_fixnum (0));
/* Cache Unicode codepoints covered by this font, as there is no other way
of getting this information easily. */
@@ -1229,9 +1232,9 @@ font_matches_spec (DWORD type, NEWTEXTMETRICEX *font,
/* Check spacing */
val = AREF (spec, FONT_SPACING_INDEX);
- if (INTEGERP (val))
+ if (FIXNUMP (val))
{
- int spacing = XINT (val);
+ int spacing = XFIXNUM (val);
int proportional = (spacing < FONT_SPACING_MONO);
if ((proportional && !(font->ntmTm.tmPitchAndFamily & 0x01))
@@ -1822,8 +1825,8 @@ w32_to_x_charset (int fncharset, char *matching)
/* Look for Same charset and a valid codepage (or non-int
which means ignore). */
if (EQ (w32_charset, charset_type)
- && (!INTEGERP (codepage) || XINT (codepage) == CP_DEFAULT
- || IsValidCodePage (XINT (codepage))))
+ && (!FIXNUMP (codepage) || XFIXNUM (codepage) == CP_DEFAULT
+ || IsValidCodePage (XFIXNUM (codepage))))
{
/* If we don't have a match already, then this is the
best. */
@@ -1955,9 +1958,9 @@ fill_in_logfont (struct frame *f, LOGFONT *logfont, Lisp_Object font_spec)
int dpi = FRAME_RES_Y (f);
tmp = AREF (font_spec, FONT_DPI_INDEX);
- if (INTEGERP (tmp))
+ if (FIXNUMP (tmp))
{
- dpi = XINT (tmp);
+ dpi = XFIXNUM (tmp);
}
else if (FLOATP (tmp))
{
@@ -1966,8 +1969,8 @@ fill_in_logfont (struct frame *f, LOGFONT *logfont, Lisp_Object font_spec)
/* Height */
tmp = AREF (font_spec, FONT_SIZE_INDEX);
- if (INTEGERP (tmp))
- logfont->lfHeight = -1 * XINT (tmp);
+ if (FIXNUMP (tmp))
+ logfont->lfHeight = -1 * XFIXNUM (tmp);
else if (FLOATP (tmp))
logfont->lfHeight = (int) (-1.0 * dpi * XFLOAT_DATA (tmp) / 72.27 + 0.5);
@@ -1977,12 +1980,12 @@ fill_in_logfont (struct frame *f, LOGFONT *logfont, Lisp_Object font_spec)
/* Weight */
tmp = AREF (font_spec, FONT_WEIGHT_INDEX);
- if (INTEGERP (tmp))
+ if (FIXNUMP (tmp))
logfont->lfWeight = w32_encode_weight (FONT_WEIGHT_NUMERIC (font_spec));
/* Italic */
tmp = AREF (font_spec, FONT_SLANT_INDEX);
- if (INTEGERP (tmp))
+ if (FIXNUMP (tmp))
{
int slant = FONT_SLANT_NUMERIC (font_spec);
logfont->lfItalic = slant > 150 ? 1 : 0;
@@ -2036,9 +2039,9 @@ fill_in_logfont (struct frame *f, LOGFONT *logfont, Lisp_Object font_spec)
/* Set pitch based on the spacing property. */
tmp = AREF (font_spec, FONT_SPACING_INDEX);
- if (INTEGERP (tmp))
+ if (FIXNUMP (tmp))
{
- int spacing = XINT (tmp);
+ int spacing = XFIXNUM (tmp);
if (spacing < FONT_SPACING_MONO)
logfont->lfPitchAndFamily
= (logfont->lfPitchAndFamily & 0xF0) | VARIABLE_PITCH;
@@ -2623,6 +2626,9 @@ struct font_driver w32font_driver =
/* Initialize state that does not change between invocations. This is only
called when Emacs is dumped. */
+
+static void syms_of_w32font_for_pdumper (void);
+
void
syms_of_w32font (void)
{
@@ -2802,6 +2808,12 @@ versions of Windows) characters. */);
defsubr (&Sx_select_font);
+ pdumper_do_now_and_after_load (syms_of_w32font_for_pdumper);
+}
+
+static void
+syms_of_w32font_for_pdumper (void)
+{
register_font_driver (&w32font_driver, NULL);
}
diff --git a/src/w32heap.c b/src/w32heap.c
index 69cd3a69336..9a59a1f0758 100644
--- a/src/w32heap.c
+++ b/src/w32heap.c
@@ -28,7 +28,7 @@
Memory allocation scheme for w32/w64:
- Buffers are mmap'ed using a very simple emulation of mmap/munmap
- - During the temacs phase:
+ - During the temacs phase, if unexec is to be used:
* we use a private heap declared to be stored into the `dumped_data'
* unfortunately, this heap cannot be made growable, so the size of
blocks it can allocate is limited to (0x80000 - pagesize)
@@ -37,7 +37,7 @@
We use a very simple first-fit scheme to reuse those blocks.
* we check that the private heap does not cross the area used
by the bigger chunks.
- - During the emacs phase:
+ - During the emacs phase, or always if pdumper is used:
* we create a private heap for new memory blocks
* we make sure that we never free a block that has been dumped.
Freeing a dumped block could work in principle, but may prove
@@ -115,10 +115,16 @@ typedef struct _RTL_HEAP_PARAMETERS {
than half of the size stated below. It would be nice to find a way
to build only the first bootstrap-emacs.exe with the large size,
and reset that to a lower value afterwards. */
-#if defined _WIN64 || defined WIDE_EMACS_INT
-# define DUMPED_HEAP_SIZE (23*1024*1024)
+#ifndef HAVE_UNEXEC
+/* We don't use dumped_data[], so define to a small size that won't
+ matter. */
+# define DUMPED_HEAP_SIZE 10
#else
-# define DUMPED_HEAP_SIZE (13*1024*1024)
+# if defined _WIN64 || defined WIDE_EMACS_INT
+# define DUMPED_HEAP_SIZE (23*1024*1024)
+# else
+# define DUMPED_HEAP_SIZE (13*1024*1024)
+# endif
#endif
static unsigned char dumped_data[DUMPED_HEAP_SIZE];
@@ -173,8 +179,8 @@ static DWORD blocks_number = 0;
static unsigned char *bc_limit;
/* Handle for the private heap:
- - inside the dumped_data[] array before dump,
- - outside of it after dump.
+ - inside the dumped_data[] array before dump with unexec,
+ - outside of it after dump, or always if pdumper is used.
*/
HANDLE heap = NULL;
@@ -188,8 +194,8 @@ free_fn the_free_fn;
http://stackoverflow.com/questions/307060/what-is-the-purpose-of-allocating-pages-in-the-pagefile-with-createfilemapping */
/* This is the function to commit memory when the heap allocator
- claims for new memory. Before dumping, we allocate space
- from the fixed size dumped_data[] array.
+ claims for new memory. Before dumping with unexec, we allocate
+ space from the fixed size dumped_data[] array.
*/
static NTSTATUS NTAPI
dumped_data_commit (PVOID Base, PVOID *CommitAddress, PSIZE_T CommitSize)
@@ -224,14 +230,13 @@ typedef WINBASEAPI BOOL (WINAPI * HeapSetInformation_Proc)(HANDLE,HEAP_INFORMATI
#endif
void
-init_heap (void)
+init_heap (bool use_dynamic_heap)
{
- if (using_dynamic_heap)
+ /* FIXME: Remove the condition, the 'else' branch below, and all the
+ related definitions and code, including dumped_data[], when unexec
+ support is removed from Emacs. */
+ if (use_dynamic_heap)
{
-#ifndef MINGW_W64
- unsigned long enable_lfh = 2;
-#endif
-
/* After dumping, use a new private heap. We explicitly enable
the low fragmentation heap (LFH) here, for the sake of pre
Vista versions. Note: this will harmlessly fail on Vista and
@@ -248,9 +253,12 @@ init_heap (void)
heap = HeapCreate (0, 0, 0);
#ifndef MINGW_W64
+ unsigned long enable_lfh = 2;
/* Set the low-fragmentation heap for OS before Vista. */
HMODULE hm_kernel32dll = LoadLibrary ("kernel32.dll");
- HeapSetInformation_Proc s_pfn_Heap_Set_Information = (HeapSetInformation_Proc) GetProcAddress (hm_kernel32dll, "HeapSetInformation");
+ HeapSetInformation_Proc s_pfn_Heap_Set_Information =
+ (HeapSetInformation_Proc) get_proc_addr (hm_kernel32dll,
+ "HeapSetInformation");
if (s_pfn_Heap_Set_Information != NULL)
{
if (s_pfn_Heap_Set_Information ((PVOID) heap,
@@ -274,14 +282,14 @@ init_heap (void)
the_free_fn = free_after_dump;
}
}
- else
+ else /* Before dumping with unexec: use static heap. */
{
/* Find the RtlCreateHeap function. Headers for this function
are provided with the w32 DDK, but the function is available
in ntdll.dll since XP. */
HMODULE hm_ntdll = LoadLibrary ("ntdll.dll");
RtlCreateHeap_Proc s_pfn_Rtl_Create_Heap
- = (RtlCreateHeap_Proc) GetProcAddress (hm_ntdll, "RtlCreateHeap");
+ = (RtlCreateHeap_Proc) get_proc_addr (hm_ntdll, "RtlCreateHeap");
/* Specific parameters for the private heap. */
RTL_HEAP_PARAMETERS params;
ZeroMemory (&params, sizeof(params));
@@ -353,6 +361,8 @@ malloc_after_dump (size_t size)
return p;
}
+/* FIXME: The *_before_dump functions should be removed when pdumper
+ becomes the only dumping method. */
void *
malloc_before_dump (size_t size)
{
@@ -587,7 +597,7 @@ free_after_dump_9x (void *ptr)
}
}
-#ifdef ENABLE_CHECKING
+#if defined HAVE_UNEXEC && defined ENABLE_CHECKING
void
report_temacs_memory_usage (void)
{
diff --git a/src/w32heap.h b/src/w32heap.h
index 6b9dca38a3b..13f7a6325b2 100644
--- a/src/w32heap.h
+++ b/src/w32heap.h
@@ -31,7 +31,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
extern unsigned char *get_data_start (void);
extern unsigned char *get_data_end (void);
extern size_t reserved_heap_size;
-extern BOOL using_dynamic_heap;
extern void *mmap_realloc (void **, size_t);
extern void mmap_free (void **);
@@ -43,7 +42,7 @@ extern void report_temacs_memory_usage (void);
extern void *sbrk (ptrdiff_t size);
/* Initialize heap structures for sbrk on startup. */
-extern void init_heap (void);
+extern void init_heap (bool);
/* ----------------------------------------------------------------- */
/* Useful routines for manipulating memory-mapped files. */
diff --git a/src/w32inevt.c b/src/w32inevt.c
index 155a8f56526..ab71c560d69 100644
--- a/src/w32inevt.c
+++ b/src/w32inevt.c
@@ -181,8 +181,8 @@ key_event (KEY_EVENT_RECORD *event, struct input_event *emacs_ev, int *isdead)
Space which we will ignore. */
if ((mod_key_state & LEFT_WIN_PRESSED) == 0)
{
- if (NUMBERP (Vw32_phantom_key_code))
- faked_key = XUINT (Vw32_phantom_key_code) & 255;
+ if (FIXNUMP (Vw32_phantom_key_code))
+ faked_key = XUFIXNUM (Vw32_phantom_key_code) & 255;
else
faked_key = VK_SPACE;
keybd_event (faked_key, (BYTE) MapVirtualKey (faked_key, 0), 0, 0);
@@ -198,8 +198,8 @@ key_event (KEY_EVENT_RECORD *event, struct input_event *emacs_ev, int *isdead)
{
if ((mod_key_state & RIGHT_WIN_PRESSED) == 0)
{
- if (NUMBERP (Vw32_phantom_key_code))
- faked_key = XUINT (Vw32_phantom_key_code) & 255;
+ if (FIXNUMP (Vw32_phantom_key_code))
+ faked_key = XUFIXNUM (Vw32_phantom_key_code) & 255;
else
faked_key = VK_SPACE;
keybd_event (faked_key, (BYTE) MapVirtualKey (faked_key, 0), 0, 0);
diff --git a/src/w32menu.c b/src/w32menu.c
index 853dc971c57..38e1b506e09 100644
--- a/src/w32menu.c
+++ b/src/w32menu.c
@@ -30,6 +30,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "buffer.h"
#include "coding.h" /* for ENCODE_SYSTEM */
#include "menu.h"
+#include "pdumper.h"
/* This may include sys/types.h, and that somehow loses
if this is not done before the other system files. */
@@ -1407,7 +1408,8 @@ add_menu_item (HMENU menu, widget_value *wv, HMENU item)
Windows alike. MSVC headers get it right; hopefully,
MinGW headers will, too. */
eassert (STRINGP (wv->help));
- info.dwItemData = (ULONG_PTR) XUNTAG (wv->help, Lisp_String);
+ info.dwItemData = (ULONG_PTR) XUNTAG (wv->help, Lisp_String,
+ struct Lisp_String);
}
if (wv->button_type == BUTTON_TYPE_RADIO)
{
@@ -1571,7 +1573,7 @@ w32_free_menu_strings (HWND hwnd)
/* The following is used by delayed window autoselection. */
DEFUN ("menu-or-popup-active-p", Fmenu_or_popup_active_p, Smenu_or_popup_active_p, 0, 0, 0,
- doc: /* Return t if a menu or popup dialog is active on selected frame. */)
+ doc: /* SKIP: real doc in xmenu.c. */)
(void)
{
struct frame *f;
@@ -1585,6 +1587,7 @@ syms_of_w32menu (void)
globals_of_w32menu ();
current_popup_menu = NULL;
+ PDUMPER_IGNORE (current_popup_menu);
DEFSYM (Qdebug_on_next_call, "debug-on-next-call");
DEFSYM (Qunsupported__w32_dialog, "unsupported--w32-dialog");
@@ -1606,9 +1609,13 @@ globals_of_w32menu (void)
#ifndef NTGUI_UNICODE
/* See if Get/SetMenuItemInfo functions are available. */
HMODULE user32 = GetModuleHandle ("user32.dll");
- get_menu_item_info = (GetMenuItemInfoA_Proc) GetProcAddress (user32, "GetMenuItemInfoA");
- set_menu_item_info = (SetMenuItemInfoA_Proc) GetProcAddress (user32, "SetMenuItemInfoA");
- unicode_append_menu = (AppendMenuW_Proc) GetProcAddress (user32, "AppendMenuW");
- unicode_message_box = (MessageBoxW_Proc) GetProcAddress (user32, "MessageBoxW");
+ get_menu_item_info = (GetMenuItemInfoA_Proc)
+ get_proc_addr (user32, "GetMenuItemInfoA");
+ set_menu_item_info = (SetMenuItemInfoA_Proc)
+ get_proc_addr (user32, "SetMenuItemInfoA");
+ unicode_append_menu = (AppendMenuW_Proc)
+ get_proc_addr (user32, "AppendMenuW");
+ unicode_message_box = (MessageBoxW_Proc)
+ get_proc_addr (user32, "MessageBoxW");
#endif /* !NTGUI_UNICODE */
}
diff --git a/src/w32notify.c b/src/w32notify.c
index e03650f0fd3..53787fd45db 100644
--- a/src/w32notify.c
+++ b/src/w32notify.c
@@ -1,5 +1,8 @@
/* Filesystem notifications support for GNU Emacs on the Microsoft Windows API.
- Copyright (C) 2012-2019 Free Software Foundation, Inc.
+
+Copyright (C) 2012-2019 Free Software Foundation, Inc.
+
+Author: Eli Zaretskii <eliz@gnu.org>
This file is part of GNU Emacs.
@@ -16,9 +19,7 @@ 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 <https://www.gnu.org/licenses/>. */
-/* Written by Eli Zaretskii <eliz@gnu.org>.
-
- Design overview:
+/* Design overview:
For each watch request, we launch a separate worker thread. The
worker thread runs the watch_worker function, which issues an
@@ -621,7 +622,7 @@ generate notifications correctly, though. */)
report_file_notify_error ("Cannot watch file", Fcons (file, Qnil));
}
/* Store watch object in watch list. */
- watch_descriptor = make_pointer_integer (dirwatch);
+ watch_descriptor = make_mint_ptr (dirwatch);
watch_object = Fcons (watch_descriptor, callback);
watch_list = Fcons (watch_object, watch_list);
@@ -646,7 +647,7 @@ WATCH-DESCRIPTOR should be an object returned by `w32notify-add-watch'. */)
if (!NILP (watch_object))
{
watch_list = Fdelete (watch_object, watch_list);
- dirwatch = (struct notification *)XINTPTR (watch_descriptor);
+ dirwatch = (struct notification *)xmint_pointer (watch_descriptor);
if (w32_valid_pointer_p (dirwatch, sizeof(struct notification)))
status = remove_watch (dirwatch);
}
@@ -661,7 +662,7 @@ WATCH-DESCRIPTOR should be an object returned by `w32notify-add-watch'. */)
Lisp_Object
w32_get_watch_object (void *desc)
{
- Lisp_Object descriptor = make_pointer_integer (desc);
+ Lisp_Object descriptor = make_mint_ptr (desc);
/* This is called from the input queue handling code, inside a
critical section, so we cannot possibly quit if watch_list is not
@@ -684,7 +685,7 @@ watch by calling `w32notify-rm-watch' also makes it invalid. */)
if (!NILP (watch_object))
{
struct notification *dirwatch =
- (struct notification *)XINTPTR (watch_descriptor);
+ (struct notification *)xmint_pointer (watch_descriptor);
if (w32_valid_pointer_p (dirwatch, sizeof(struct notification))
&& dirwatch->dir != NULL)
return Qt;
diff --git a/src/w32proc.c b/src/w32proc.c
index f591a80e7b2..75e345a525a 100644
--- a/src/w32proc.c
+++ b/src/w32proc.c
@@ -81,6 +81,82 @@ static sigset_t sig_mask;
static CRITICAL_SECTION crit_sig;
+/* Catch memory allocation before the heap allocation scheme is set
+ up. These functions should never be called, unless code is added
+ early on in 'main' that runs before init_heap is called. */
+_Noreturn void * malloc_before_init (size_t);
+_Noreturn void * realloc_before_init (void *, size_t);
+_Noreturn void free_before_init (void *);
+
+_Noreturn void *
+malloc_before_init (size_t size)
+{
+ fprintf (stderr,
+ "error: 'malloc' called before setting up heap allocation; exiting.\n");
+ exit (-1);
+}
+
+_Noreturn void *
+realloc_before_init (void *ptr, size_t size)
+{
+ fprintf (stderr,
+ "error: 'realloc' called before setting up heap allocation; exiting.\n");
+ exit (-1);
+}
+
+_Noreturn void
+free_before_init (void *ptr)
+{
+ fprintf (stderr,
+ "error: 'free' called before setting up heap allocation; exiting.\n");
+ exit (-1);
+}
+
+extern BOOL ctrl_c_handler (unsigned long type);
+
+/* MinGW64 doesn't add a leading underscore to external symbols,
+ whereas configure.ac sets up LD_SWITCH_SYSTEM_TEMACS to force the
+ entry point at __start, with two underscores. */
+#ifdef __MINGW64__
+#define _start __start
+#endif
+
+extern void mainCRTStartup (void);
+
+/* Startup code for running on NT. When we are running as the dumped
+ version, we need to bootstrap our heap and .bss section into our
+ address space before we can actually hand off control to the startup
+ code supplied by NT (primarily because that code relies upon malloc ()). */
+void _start (void);
+
+void
+_start (void)
+{
+
+#if 1
+ /* Give us a way to debug problems with crashes on startup when
+ running under the MSVC profiler. */
+ if (GetEnvironmentVariable ("EMACS_DEBUG", NULL, 0) > 0)
+ DebugBreak ();
+#endif
+
+ the_malloc_fn = malloc_before_init;
+ the_realloc_fn = realloc_before_init;
+ the_free_fn = free_before_init;
+
+ /* Cache system info, e.g., the NT page size. */
+ cache_system_info ();
+
+ /* This prevents ctrl-c's in shells running while we're suspended from
+ having us exit. */
+ SetConsoleCtrlHandler ((PHANDLER_ROUTINE) ctrl_c_handler, TRUE);
+
+ /* Prevent Emacs from being locked up (eg. in batch mode) when
+ accessing devices that aren't mounted (eg. removable media drives). */
+ SetErrorMode (SEM_FAILCRITICALERRORS);
+ mainCRTStartup ();
+}
+
/* Improve on the CRT 'signal' implementation so that we could record
the SIGCHLD handler and fake interval timers. */
signal_handler
@@ -548,9 +624,8 @@ init_timers (void)
through a pointer. */
s_pfn_Get_Thread_Times = NULL; /* in case dumped Emacs comes with a value */
if (os_subtype != OS_9X)
- s_pfn_Get_Thread_Times =
- (GetThreadTimes_Proc)GetProcAddress (GetModuleHandle ("kernel32.dll"),
- "GetThreadTimes");
+ s_pfn_Get_Thread_Times = (GetThreadTimes_Proc)
+ get_proc_addr (GetModuleHandle ("kernel32.dll"), "GetThreadTimes");
/* Make sure we start with zeroed out itimer structures, since
dumping may have left there traces of threads long dead. */
@@ -1529,6 +1604,78 @@ waitpid (pid_t pid, int *status, int options)
return pid;
}
+int
+open_input_file (file_data *p_file, char *filename)
+{
+ HANDLE file;
+ HANDLE file_mapping;
+ void *file_base;
+ unsigned long size, upper_size;
+
+ file = CreateFileA (filename, GENERIC_READ, FILE_SHARE_READ, NULL,
+ OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
+ if (file == INVALID_HANDLE_VALUE)
+ return FALSE;
+
+ size = GetFileSize (file, &upper_size);
+ file_mapping = CreateFileMapping (file, NULL, PAGE_READONLY,
+ 0, size, NULL);
+ if (!file_mapping)
+ return FALSE;
+
+ file_base = MapViewOfFile (file_mapping, FILE_MAP_READ, 0, 0, size);
+ if (file_base == 0)
+ return FALSE;
+
+ p_file->name = filename;
+ p_file->size = size;
+ p_file->file = file;
+ p_file->file_mapping = file_mapping;
+ p_file->file_base = file_base;
+
+ return TRUE;
+}
+
+/* Return pointer to section header for section containing the given
+ relative virtual address. */
+IMAGE_SECTION_HEADER *
+rva_to_section (DWORD_PTR rva, IMAGE_NT_HEADERS * nt_header)
+{
+ PIMAGE_SECTION_HEADER section;
+ int i;
+
+ section = IMAGE_FIRST_SECTION (nt_header);
+
+ for (i = 0; i < nt_header->FileHeader.NumberOfSections; i++)
+ {
+ /* Some linkers (eg. the NT SDK linker I believe) swapped the
+ meaning of these two values - or rather, they ignored
+ VirtualSize entirely and always set it to zero. This affects
+ some very old exes (eg. gzip dated Dec 1993). Since
+ w32_executable_type relies on this function to work reliably,
+ we need to cope with this. */
+ DWORD_PTR real_size = max (section->SizeOfRawData,
+ section->Misc.VirtualSize);
+ if (rva >= section->VirtualAddress
+ && rva < section->VirtualAddress + real_size)
+ return section;
+ section++;
+ }
+ return NULL;
+}
+
+/* Close the system structures associated with the given file. */
+void
+close_file_data (file_data *p_file)
+{
+ UnmapViewOfFile (p_file->file_base);
+ CloseHandle (p_file->file_mapping);
+ /* For the case of output files, set final size. */
+ SetFilePointer (p_file->file, p_file->size, NULL, FILE_BEGIN);
+ SetEndOfFile (p_file->file);
+ CloseHandle (p_file->file);
+}
+
/* Old versions of w32api headers don't have separate 32-bit and
64-bit defines, but the one they have matches the 32-bit variety. */
#ifndef IMAGE_NT_OPTIONAL_HDR32_MAGIC
@@ -1629,22 +1776,27 @@ w32_executable_type (char * filename,
if (data_dir)
{
/* Look for Cygwin DLL in the DLL import list. */
- IMAGE_DATA_DIRECTORY import_dir =
- data_dir[IMAGE_DIRECTORY_ENTRY_IMPORT];
+ IMAGE_DATA_DIRECTORY import_dir
+ = data_dir[IMAGE_DIRECTORY_ENTRY_IMPORT];
/* Import directory can be missing in .NET DLLs. */
if (import_dir.VirtualAddress != 0)
{
+ IMAGE_SECTION_HEADER *section
+ = rva_to_section (import_dir.VirtualAddress, nt_header);
+ if (!section)
+ emacs_abort ();
+
IMAGE_IMPORT_DESCRIPTOR * imports =
- RVA_TO_PTR (import_dir.VirtualAddress,
- rva_to_section (import_dir.VirtualAddress,
- nt_header),
+ RVA_TO_PTR (import_dir.VirtualAddress, section,
executable);
for ( ; imports->Name; imports++)
{
- IMAGE_SECTION_HEADER * section =
- rva_to_section (imports->Name, nt_header);
+ section = rva_to_section (imports->Name, nt_header);
+ if (!section)
+ emacs_abort ();
+
char * dllname = RVA_TO_PTR (imports->Name, section,
executable);
@@ -1766,7 +1918,7 @@ sys_spawnve (int mode, char *cmdname, char **argv, char **envp)
{
program = build_string (cmdname);
full = Qnil;
- openp (Vexec_path, program, Vexec_suffixes, &full, make_number (X_OK), 0);
+ openp (Vexec_path, program, Vexec_suffixes, &full, make_fixnum (X_OK), 0);
if (NILP (full))
{
errno = EINVAL;
@@ -1855,9 +2007,9 @@ sys_spawnve (int mode, char *cmdname, char **argv, char **envp)
}
/* we have to do some conjuring here to put argv and envp into the
- form CreateProcess wants... argv needs to be a space separated/null
- terminated list of parameters, and envp is a null
- separated/double-null terminated list of parameters.
+ form CreateProcess wants... argv needs to be a space separated/NUL
+ terminated list of parameters, and envp is a NUL
+ separated/double-NUL terminated list of parameters.
Additionally, zero-length args and args containing whitespace or
quote chars need to be wrapped in double quotes - for this to work,
@@ -1889,8 +2041,8 @@ sys_spawnve (int mode, char *cmdname, char **argv, char **envp)
do_quoting = 1;
/* Override escape char by binding w32-quote-process-args to
desired character, or use t for auto-selection. */
- if (INTEGERP (Vw32_quote_process_args))
- escape_char = XINT (Vw32_quote_process_args);
+ if (FIXNUMP (Vw32_quote_process_args))
+ escape_char = XFIXNUM (Vw32_quote_process_args);
else
escape_char = (is_cygnus_app || is_msys_app) ? '"' : '\\';
}
@@ -2691,8 +2843,8 @@ sys_kill (pid_t pid, int sig)
{
g_b_init_debug_break_process = 1;
s_pfn_Debug_Break_Process = (DebugBreakProcess_Proc)
- GetProcAddress (GetModuleHandle ("kernel32.dll"),
- "DebugBreakProcess");
+ get_proc_addr (GetModuleHandle ("kernel32.dll"),
+ "DebugBreakProcess");
}
if (s_pfn_Debug_Break_Process == NULL)
@@ -3017,13 +3169,13 @@ If successful, the return value is t, otherwise nil. */)
DWORD pid;
child_process *cp;
- CHECK_NUMBER (process);
+ CHECK_FIXNUM (process);
/* Allow pid to be an internally generated one, or one obtained
externally. This is necessary because real pids on Windows 95 are
negative. */
- pid = XINT (process);
+ pid = XFIXNUM (process);
cp = find_child_pid (pid);
if (cp != NULL)
pid = cp->procinfo.dwProcessId;
@@ -3101,6 +3253,12 @@ such programs cannot be invoked by Emacs anyway. */)
}
#ifdef HAVE_LANGINFO_CODESET
+
+/* If we are compiling for compatibility with older 32-bit Windows
+ versions, this might not be defined by the Windows headers. */
+#ifndef LOCALE_IPAPERSIZE
+# define LOCALE_IPAPERSIZE 0x100A
+#endif
/* Emulation of nl_langinfo. Used in fns.c:Flocale_info. */
char *
nl_langinfo (nl_item item)
@@ -3113,7 +3271,8 @@ nl_langinfo (nl_item item)
LOCALE_SMONTHNAME1, LOCALE_SMONTHNAME2, LOCALE_SMONTHNAME3,
LOCALE_SMONTHNAME4, LOCALE_SMONTHNAME5, LOCALE_SMONTHNAME6,
LOCALE_SMONTHNAME7, LOCALE_SMONTHNAME8, LOCALE_SMONTHNAME9,
- LOCALE_SMONTHNAME10, LOCALE_SMONTHNAME11, LOCALE_SMONTHNAME12
+ LOCALE_SMONTHNAME10, LOCALE_SMONTHNAME11, LOCALE_SMONTHNAME12,
+ LOCALE_IPAPERSIZE, LOCALE_IPAPERSIZE
};
static char *nl_langinfo_buf = NULL;
@@ -3122,6 +3281,8 @@ nl_langinfo (nl_item item)
if (nl_langinfo_len <= 0)
nl_langinfo_buf = xmalloc (nl_langinfo_len = 1);
+ char *retval = nl_langinfo_buf;
+
if (item < 0 || item >= _NL_NUM)
nl_langinfo_buf[0] = 0;
else
@@ -3143,6 +3304,8 @@ nl_langinfo (nl_item item)
if (nl_langinfo_len <= need_len)
nl_langinfo_buf = xrealloc (nl_langinfo_buf,
nl_langinfo_len = need_len);
+ retval = nl_langinfo_buf;
+
if (!GetLocaleInfo (cloc, w32item[item] | LOCALE_USE_CP_ACP,
nl_langinfo_buf, nl_langinfo_len))
nl_langinfo_buf[0] = 0;
@@ -3159,9 +3322,32 @@ nl_langinfo (nl_item item)
nl_langinfo_buf[1] = 'p';
}
}
+ else if (item == _NL_PAPER_WIDTH || item == _NL_PAPER_HEIGHT)
+ {
+ static const int paper_size[][2] =
+ {
+ { -1, -1 },
+ { 216, 279 },
+ { -1, -1 },
+ { -1, -1 },
+ { -1, -1 },
+ { 216, 356 },
+ { -1, -1 },
+ { -1, -1 },
+ { 297, 420 },
+ { 210, 297 }
+ };
+ int idx = atoi (nl_langinfo_buf);
+ if (0 <= idx && idx < ARRAYELTS (paper_size))
+ retval = (char *)(intptr_t) (item == _NL_PAPER_WIDTH
+ ? paper_size[idx][0]
+ : paper_size[idx][1]);
+ else
+ retval = (char *)(intptr_t) -1;
+ }
}
}
- return nl_langinfo_buf;
+ return retval;
}
#endif /* HAVE_LANGINFO_CODESET */
@@ -3186,14 +3372,14 @@ If LCID (a 16-bit number) is not a valid locale, the result is nil. */)
char abbrev_name[32] = { 0 };
char full_name[256] = { 0 };
- CHECK_NUMBER (lcid);
+ CHECK_FIXNUM (lcid);
- if (!IsValidLocale (XINT (lcid), LCID_SUPPORTED))
+ if (!IsValidLocale (XFIXNUM (lcid), LCID_SUPPORTED))
return Qnil;
if (NILP (longform))
{
- got_abbrev = GetLocaleInfo (XINT (lcid),
+ got_abbrev = GetLocaleInfo (XFIXNUM (lcid),
LOCALE_SABBREVLANGNAME | LOCALE_USE_CP_ACP,
abbrev_name, sizeof (abbrev_name));
if (got_abbrev)
@@ -3201,21 +3387,21 @@ If LCID (a 16-bit number) is not a valid locale, the result is nil. */)
}
else if (EQ (longform, Qt))
{
- got_full = GetLocaleInfo (XINT (lcid),
+ got_full = GetLocaleInfo (XFIXNUM (lcid),
LOCALE_SLANGUAGE | LOCALE_USE_CP_ACP,
full_name, sizeof (full_name));
if (got_full)
return DECODE_SYSTEM (build_string (full_name));
}
- else if (NUMBERP (longform))
+ else if (FIXNUMP (longform))
{
- got_full = GetLocaleInfo (XINT (lcid),
- XINT (longform),
+ got_full = GetLocaleInfo (XFIXNUM (lcid),
+ XFIXNUM (longform),
full_name, sizeof (full_name));
- /* GetLocaleInfo's return value includes the terminating null
+ /* GetLocaleInfo's return value includes the terminating NUL
character, when the returned information is a string, whereas
make_unibyte_string needs the string length without the
- terminating null. */
+ terminating NUL. */
if (got_full)
return make_unibyte_string (full_name, got_full - 1);
}
@@ -3231,7 +3417,7 @@ This is a numerical value; use `w32-get-locale-info' to convert to a
human-readable form. */)
(void)
{
- return make_number (GetThreadLocale ());
+ return make_fixnum (GetThreadLocale ());
}
static DWORD
@@ -3260,7 +3446,7 @@ static BOOL CALLBACK ALIGN_STACK
enum_locale_fn (LPTSTR localeNum)
{
DWORD id = int_from_hex (localeNum);
- Vw32_valid_locale_ids = Fcons (make_number (id), Vw32_valid_locale_ids);
+ Vw32_valid_locale_ids = Fcons (make_fixnum (id), Vw32_valid_locale_ids);
return TRUE;
}
@@ -3289,8 +3475,8 @@ human-readable form. */)
(Lisp_Object userp)
{
if (NILP (userp))
- return make_number (GetSystemDefaultLCID ());
- return make_number (GetUserDefaultLCID ());
+ return make_fixnum (GetSystemDefaultLCID ());
+ return make_fixnum (GetUserDefaultLCID ());
}
@@ -3299,20 +3485,20 @@ DEFUN ("w32-set-current-locale", Fw32_set_current_locale, Sw32_set_current_local
If successful, the new locale id is returned, otherwise nil. */)
(Lisp_Object lcid)
{
- CHECK_NUMBER (lcid);
+ CHECK_FIXNUM (lcid);
- if (!IsValidLocale (XINT (lcid), LCID_SUPPORTED))
+ if (!IsValidLocale (XFIXNUM (lcid), LCID_SUPPORTED))
return Qnil;
- if (!SetThreadLocale (XINT (lcid)))
+ if (!SetThreadLocale (XFIXNUM (lcid)))
return Qnil;
/* Need to set input thread locale if present. */
if (dwWindowsThreadId)
/* Reply is not needed. */
- PostThreadMessage (dwWindowsThreadId, WM_EMACS_SETLOCALE, XINT (lcid), 0);
+ PostThreadMessage (dwWindowsThreadId, WM_EMACS_SETLOCALE, XFIXNUM (lcid), 0);
- return make_number (GetThreadLocale ());
+ return make_fixnum (GetThreadLocale ());
}
@@ -3324,7 +3510,7 @@ static BOOL CALLBACK ALIGN_STACK
enum_codepage_fn (LPTSTR codepageNum)
{
DWORD id = atoi (codepageNum);
- Vw32_valid_codepages = Fcons (make_number (id), Vw32_valid_codepages);
+ Vw32_valid_codepages = Fcons (make_fixnum (id), Vw32_valid_codepages);
return TRUE;
}
@@ -3347,7 +3533,7 @@ DEFUN ("w32-get-console-codepage", Fw32_get_console_codepage,
doc: /* Return current Windows codepage for console input. */)
(void)
{
- return make_number (GetConsoleCP ());
+ return make_fixnum (GetConsoleCP ());
}
@@ -3358,15 +3544,15 @@ This codepage setting affects keyboard input in tty mode.
If successful, the new CP is returned, otherwise nil. */)
(Lisp_Object cp)
{
- CHECK_NUMBER (cp);
+ CHECK_FIXNUM (cp);
- if (!IsValidCodePage (XINT (cp)))
+ if (!IsValidCodePage (XFIXNUM (cp)))
return Qnil;
- if (!SetConsoleCP (XINT (cp)))
+ if (!SetConsoleCP (XFIXNUM (cp)))
return Qnil;
- return make_number (GetConsoleCP ());
+ return make_fixnum (GetConsoleCP ());
}
@@ -3375,7 +3561,7 @@ DEFUN ("w32-get-console-output-codepage", Fw32_get_console_output_codepage,
doc: /* Return current Windows codepage for console output. */)
(void)
{
- return make_number (GetConsoleOutputCP ());
+ return make_fixnum (GetConsoleOutputCP ());
}
@@ -3386,15 +3572,15 @@ This codepage setting affects display in tty mode.
If successful, the new CP is returned, otherwise nil. */)
(Lisp_Object cp)
{
- CHECK_NUMBER (cp);
+ CHECK_FIXNUM (cp);
- if (!IsValidCodePage (XINT (cp)))
+ if (!IsValidCodePage (XFIXNUM (cp)))
return Qnil;
- if (!SetConsoleOutputCP (XINT (cp)))
+ if (!SetConsoleOutputCP (XFIXNUM (cp)))
return Qnil;
- return make_number (GetConsoleOutputCP ());
+ return make_fixnum (GetConsoleOutputCP ());
}
@@ -3412,17 +3598,17 @@ yield nil. */)
CHARSETINFO info;
DWORD_PTR dwcp;
- CHECK_NUMBER (cp);
+ CHECK_FIXNUM (cp);
- if (!IsValidCodePage (XINT (cp)))
+ if (!IsValidCodePage (XFIXNUM (cp)))
return Qnil;
/* Going through a temporary DWORD_PTR variable avoids compiler warning
about cast to pointer from integer of different size, when
building --with-wide-int or building for 64bit. */
- dwcp = XINT (cp);
+ dwcp = XFIXNUM (cp);
if (TranslateCharsetInfo ((DWORD *) dwcp, &info, TCI_SRCCODEPAGE))
- return make_number (info.ciCharset);
+ return make_fixnum (info.ciCharset);
return Qnil;
}
@@ -3444,8 +3630,8 @@ The return value is a list of pairs of language id and layout id. */)
{
HKL kl = layouts[num_layouts];
- obj = Fcons (Fcons (make_number (LOWORD (kl)),
- make_number (HIWORD (kl))),
+ obj = Fcons (Fcons (make_fixnum (LOWORD (kl)),
+ make_fixnum (HIWORD (kl))),
obj);
}
}
@@ -3462,8 +3648,8 @@ The return value is the cons of the language id and the layout id. */)
{
HKL kl = GetKeyboardLayout (dwWindowsThreadId);
- return Fcons (make_number (LOWORD (kl)),
- make_number (HIWORD (kl)));
+ return Fcons (make_fixnum (LOWORD (kl)),
+ make_fixnum (HIWORD (kl)));
}
@@ -3477,11 +3663,11 @@ If successful, the new layout id is returned, otherwise nil. */)
HKL kl;
CHECK_CONS (layout);
- CHECK_NUMBER_CAR (layout);
- CHECK_NUMBER_CDR (layout);
+ CHECK_FIXNUM (XCAR (layout));
+ CHECK_FIXNUM (XCDR (layout));
- kl = (HKL) (UINT_PTR) ((XINT (XCAR (layout)) & 0xffff)
- | (XINT (XCDR (layout)) << 16));
+ kl = (HKL) (UINT_PTR) ((XFIXNUM (XCAR (layout)) & 0xffff)
+ | (XFIXNUM (XCDR (layout)) << 16));
/* Synchronize layout with input thread. */
if (dwWindowsThreadId)
@@ -3608,9 +3794,9 @@ w32_compare_strings (const char *s1, const char *s2, char *locname,
{
if (os_subtype == OS_9X)
{
- pCompareStringW =
- (CompareStringW_Proc) GetProcAddress (LoadLibrary ("Unicows.dll"),
- "CompareStringW");
+ pCompareStringW = (CompareStringW_Proc)
+ get_proc_addr (LoadLibrary ("Unicows.dll"),
+ "CompareStringW");
if (!pCompareStringW)
{
errno = EINVAL;
@@ -3763,14 +3949,17 @@ them blocking when trying to access unmounted drives etc. */);
DEFVAR_INT ("w32-pipe-read-delay", w32_pipe_read_delay,
doc: /* Forced delay before reading subprocess output.
-This is done to improve the buffering of subprocess output, by
-avoiding the inefficiency of frequently reading small amounts of data.
+This may need to be done to improve the buffering of subprocess output,
+by avoiding the inefficiency of frequently reading small amounts of data.
+Typically needed only with DOS programs on Windows 9X; set to 50 if
+throughput with such programs is slow.
If positive, the value is the number of milliseconds to sleep before
-reading the subprocess output. If negative, the magnitude is the number
-of time slices to wait (effectively boosting the priority of the child
-process temporarily). A value of zero disables waiting entirely. */);
- w32_pipe_read_delay = 50;
+signaling that output from a subprocess is ready to be read.
+If negative, the value is the number of time slices to wait (effectively
+boosting the priority of the child process temporarily).
+A value of zero disables waiting entirely. */);
+ w32_pipe_read_delay = 0;
DEFVAR_INT ("w32-pipe-buffer-size", w32_pipe_buffer_size,
doc: /* Size of buffer for pipes created to communicate with subprocesses.
diff --git a/src/w32reg.c b/src/w32reg.c
index e2aebbb1b76..aff131dd37d 100644
--- a/src/w32reg.c
+++ b/src/w32reg.c
@@ -1,6 +1,8 @@
/* Emulate the X Resource Manager through the registry.
- Copyright (C) 1990, 1993-1994, 2001-2019 Free Software Foundation,
- Inc.
+
+Copyright (C) 1990, 1993-1994, 2001-2019 Free Software Foundation, Inc.
+
+Author: Kevin Gallo
This file is part of GNU Emacs.
@@ -17,8 +19,6 @@ 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 <https://www.gnu.org/licenses/>. */
-/* Written by Kevin Gallo */
-
#include <config.h>
#include "lisp.h"
#include "w32term.h" /* for XrmDatabase, xrdb */
diff --git a/src/w32select.c b/src/w32select.c
index 6c7808d9813..af4f0496ed9 100644
--- a/src/w32select.c
+++ b/src/w32select.c
@@ -2,6 +2,9 @@
Copyright (C) 1993-1994, 2001-2019 Free Software Foundation, Inc.
+Author: Kevin Gallo
+ Benjamin Riefenstahl
+
This file is part of GNU Emacs.
GNU Emacs is free software: you can redistribute it and/or modify
@@ -17,9 +20,6 @@ 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 <https://www.gnu.org/licenses/>. */
-/* Written by Kevin Gallo, Benjamin Riefenstahl */
-
-
/*
* Notes on usage of selection-coding-system and
* next-selection-coding-system on MS Windows:
@@ -241,7 +241,7 @@ static Lisp_Object
render (Lisp_Object oformat)
{
HGLOBAL htext = NULL;
- UINT format = XFASTINT (oformat);
+ UINT format = XFIXNAT (oformat);
ONTRACE (fprintf (stderr, "render\n"));
@@ -371,8 +371,8 @@ render_all (Lisp_Object ignore)
render_locale ();
if (current_clipboard_type == CF_UNICODETEXT)
- render (make_number (CF_TEXT));
- render (make_number (current_clipboard_type));
+ render (make_fixnum (CF_TEXT));
+ render (make_fixnum (current_clipboard_type));
CloseClipboard ();
@@ -419,7 +419,7 @@ owner_callback (HWND win, UINT msg, WPARAM wp, LPARAM lp)
{
case WM_RENDERFORMAT:
ONTRACE (fprintf (stderr, "WM_RENDERFORMAT\n"));
- run_protected (render, make_number (wp));
+ run_protected (render, make_fixnum (wp));
return 0;
case WM_RENDERALLFORMATS:
@@ -631,7 +631,7 @@ validate_coding_system (Lisp_Object coding_system)
eol_type = Fcoding_system_eol_type (coding_system);
/* Already a DOS coding system? */
- if (EQ (eol_type, make_number (1)))
+ if (EQ (eol_type, make_fixnum (1)))
return coding_system;
/* Get EOL_TYPE vector of the base of CODING_SYSTEM. */
@@ -742,7 +742,7 @@ DEFUN ("w32-set-clipboard-data", Fw32_set_clipboard_data,
/* If for some reason we don't have a clipboard_owner, we
just set the text format as chosen by the configuration
and than forget about the whole thing. */
- ok = !NILP (render (make_number (current_clipboard_type)));
+ ok = !NILP (render (make_fixnum (current_clipboard_type)));
current_text = Qnil;
current_coding_system = Qnil;
}
@@ -803,7 +803,7 @@ DEFUN ("w32-get-clipboard-data", Fw32_get_clipboard_data,
(void) ignored;
/* Don't pass our own text from the clipboard (which might be
- troublesome if the killed text includes null characters). */
+ troublesome if the killed text includes NUL characters). */
if (!NILP (current_text))
return ret;
@@ -1123,7 +1123,7 @@ representing a data format that is currently available in the clipboard. */)
/* We generate a vector because that's what xselect.c
does in this case. */
- val = Fmake_vector (make_number (fmtcount), Qnil);
+ val = Fmake_vector (make_fixnum (fmtcount), Qnil);
/* Note: when stepping with GDB through this code, the
loop below terminates immediately because
EnumClipboardFormats for some reason returns with
@@ -1170,45 +1170,13 @@ syms_of_w32select (void)
defsubr (&Sw32_selection_targets);
DEFVAR_LISP ("selection-coding-system", Vselection_coding_system,
- doc: /* Coding system for communicating with other programs.
-
-For MS-Windows and MS-DOS:
-When sending or receiving text via selection and clipboard, the text
-is encoded or decoded by this coding system. The default value is
-the current system default encoding on 9x/Me, `utf-16le-dos'
-\(Unicode) on NT/W2K/XP, and `iso-latin-1-dos' on MS-DOS.
-
-For X Windows:
-When sending text via selection and clipboard, if the target
-data-type matches with the type of this coding system, it is used
-for encoding the text. Otherwise (including the case that this
-variable is nil), a proper coding system is used as below:
-
-data-type coding system
---------- -------------
-UTF8_STRING utf-8
-COMPOUND_TEXT compound-text-with-extensions
-STRING iso-latin-1
-C_STRING no-conversion
-
-When receiving text, if this coding system is non-nil, it is used
-for decoding regardless of the data-type. If this is nil, a
-proper coding system is used according to the data-type as above.
-
-See also the documentation of the variable `x-select-request-type' how
-to control which data-type to request for receiving text.
-
-The default value is nil. */);
+ doc: /* SKIP: real doc in select.el. */);
/* The actual value is set dynamically in the dumped Emacs, see
below. */
Vselection_coding_system = Qnil;
DEFVAR_LISP ("next-selection-coding-system", Vnext_selection_coding_system,
- doc: /* Coding system for the next communication with other programs.
-Usually, `selection-coding-system' is used for communicating with
-other programs (X Windows clients or MS Windows programs). But, if this
-variable is set, it is used for the next communication only.
-After the communication, this variable is set to nil. */);
+ doc: /* SKIP: real doc in select.el. */);
Vnext_selection_coding_system = Qnil;
DEFSYM (QCLIPBOARD, "CLIPBOARD");
diff --git a/src/w32term.c b/src/w32term.c
index dbaf1054f1f..bb1f0bad018 100644
--- a/src/w32term.c
+++ b/src/w32term.c
@@ -478,8 +478,8 @@ x_set_frame_alpha (struct frame *f)
if (FLOATP (Vframe_alpha_lower_limit))
alpha_min = XFLOAT_DATA (Vframe_alpha_lower_limit);
- else if (INTEGERP (Vframe_alpha_lower_limit))
- alpha_min = (XINT (Vframe_alpha_lower_limit)) / 100.0;
+ else if (FIXNUMP (Vframe_alpha_lower_limit))
+ alpha_min = (XFIXNUM (Vframe_alpha_lower_limit)) / 100.0;
if (alpha < 0.0)
return;
@@ -800,29 +800,32 @@ x_after_update_window_line (struct window *w, struct glyph_row *desired_row)
height > 0))
{
int y = WINDOW_TO_FRAME_PIXEL_Y (w, max (0, desired_row->y));
+ int face_id =
+ !NILP (Vface_remapping_alist)
+ ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID)
+ : INTERNAL_BORDER_FACE_ID;
+ struct face *face = FACE_FROM_ID_OR_NULL (f, face_id);
block_input ();
- {
- HDC hdc = get_frame_dc (f);
- struct face *face = FACE_FROM_ID_OR_NULL (f, INTERNAL_BORDER_FACE_ID);
- if (face)
- {
- /* Fill border with internal border face. */
- unsigned long color = face->background;
+ HDC hdc = get_frame_dc (f);
+ if (face)
+ {
+ /* Fill border with internal border face. */
+ unsigned long color = face->background;
+
+ w32_fill_area (f, hdc, color, 0, y, width, height);
+ w32_fill_area (f, hdc, color, FRAME_PIXEL_WIDTH (f) - width,
+ y, width, height);
+ }
+ else
+ {
+ w32_clear_area (f, hdc, 0, y, width, height);
+ w32_clear_area (f, hdc, FRAME_PIXEL_WIDTH (f) - width,
+ y, width, height);
+ }
+ release_frame_dc (f, hdc);
- w32_fill_area (f, hdc, color, 0, y, width, height);
- w32_fill_area (f, hdc, color, FRAME_PIXEL_WIDTH (f) - width,
- y, width, height);
- }
- else
- {
- w32_clear_area (f, hdc, 0, y, width, height);
- w32_clear_area (f, hdc, FRAME_PIXEL_WIDTH (f) - width,
- y, width, height);
- }
- release_frame_dc (f, hdc);
- }
unblock_input ();
}
}
@@ -1476,7 +1479,7 @@ x_draw_glyphless_glyph_string_foreground (struct glyph_string *s)
{
sprintf ((char *) buf, "%0*X",
glyph->u.glyphless.ch < 0x10000 ? 4 : 6,
- (unsigned int) glyph->u.glyphless.ch);
+ (unsigned int) glyph->u.glyphless.ch & 0xffffff);
str = buf;
}
@@ -1874,9 +1877,42 @@ x_draw_image_foreground (struct glyph_string *s)
HBRUSH fg_brush = CreateSolidBrush (s->gc->foreground);
HBRUSH orig_brush = SelectObject (s->hdc, fg_brush);
HGDIOBJ orig_obj = SelectObject (compat_hdc, s->img->pixmap);
+ LONG orig_width, orig_height;
+ DIBSECTION dib;
SetBkColor (compat_hdc, RGB (255, 255, 255));
SetTextColor (s->hdc, RGB (0, 0, 0));
x_set_glyph_string_clipping (s);
+ /* Extract the original dimensions of the bitmap. */
+ if (GetObject (s->img->pixmap, sizeof (dib), &dib) > 0)
+ {
+ BITMAP bmp = dib.dsBm;
+ orig_width = bmp.bmWidth;
+ orig_height = bmp.bmHeight;
+ }
+ else
+ {
+ DebPrint (("x_draw_image_foreground: GetObject failed!\n"));
+ orig_width = s->slice.width;
+ orig_height = s->slice.height;
+ }
+
+ double w_factor = 1.0, h_factor = 1.0;
+ bool scaled = false;
+ int orig_slice_width = s->slice.width,
+ orig_slice_height = s->slice.height;
+ int orig_slice_x = s->slice.x, orig_slice_y = s->slice.y;
+ /* For scaled images we need to restore the original slice's
+ dimensions and origin coordinates, from before the scaling. */
+ if (s->img->width != orig_width || s->img->height != orig_height)
+ {
+ scaled = true;
+ w_factor = (double) orig_width / (double) s->img->width;
+ h_factor = (double) orig_height / (double) s->img->height;
+ orig_slice_width = s->slice.width * w_factor + 0.5;
+ orig_slice_height = s->slice.height * h_factor + 0.5;
+ orig_slice_x = s->slice.x * w_factor + 0.5;
+ orig_slice_y = s->slice.y * h_factor + 0.5;
+ }
if (s->img->mask)
{
@@ -1885,14 +1921,36 @@ x_draw_image_foreground (struct glyph_string *s)
SetTextColor (s->hdc, RGB (255, 255, 255));
SetBkColor (s->hdc, RGB (0, 0, 0));
-
- BitBlt (s->hdc, x, y, s->slice.width, s->slice.height,
- compat_hdc, s->slice.x, s->slice.y, SRCINVERT);
- BitBlt (s->hdc, x, y, s->slice.width, s->slice.height,
- mask_dc, s->slice.x, s->slice.y, SRCAND);
- BitBlt (s->hdc, x, y, s->slice.width, s->slice.height,
- compat_hdc, s->slice.x, s->slice.y, SRCINVERT);
-
+ if (!scaled)
+ {
+ BitBlt (s->hdc, x, y, s->slice.width, s->slice.height,
+ compat_hdc, s->slice.x, s->slice.y, SRCINVERT);
+ BitBlt (s->hdc, x, y, s->slice.width, s->slice.height,
+ mask_dc, s->slice.x, s->slice.y, SRCAND);
+ BitBlt (s->hdc, x, y, s->slice.width, s->slice.height,
+ compat_hdc, s->slice.x, s->slice.y, SRCINVERT);
+ }
+ else
+ {
+ int pmode = 0;
+ /* HALFTONE produces better results, especially when
+ scaling to a larger size, but Windows 9X doesn't
+ support HALFTONE. */
+ if (os_subtype == OS_NT
+ && (pmode = SetStretchBltMode (s->hdc, HALFTONE)) != 0)
+ SetBrushOrgEx (s->hdc, 0, 0, NULL);
+ StretchBlt (s->hdc, x, y, s->slice.width, s->slice.height,
+ compat_hdc, orig_slice_x, orig_slice_y,
+ orig_slice_width, orig_slice_height, SRCINVERT);
+ StretchBlt (s->hdc, x, y, s->slice.width, s->slice.height,
+ mask_dc, orig_slice_x, orig_slice_y,
+ orig_slice_width, orig_slice_height, SRCAND);
+ StretchBlt (s->hdc, x, y, s->slice.width, s->slice.height,
+ compat_hdc, orig_slice_x, orig_slice_y,
+ orig_slice_width, orig_slice_height, SRCINVERT);
+ if (pmode)
+ SetStretchBltMode (s->hdc, pmode);
+ }
SelectObject (mask_dc, mask_orig_obj);
DeleteDC (mask_dc);
}
@@ -1900,9 +1958,22 @@ x_draw_image_foreground (struct glyph_string *s)
{
SetTextColor (s->hdc, s->gc->foreground);
SetBkColor (s->hdc, s->gc->background);
-
- BitBlt (s->hdc, x, y, s->slice.width, s->slice.height,
- compat_hdc, s->slice.x, s->slice.y, SRCCOPY);
+ if (!scaled)
+ BitBlt (s->hdc, x, y, s->slice.width, s->slice.height,
+ compat_hdc, s->slice.x, s->slice.y, SRCCOPY);
+ else
+ {
+ int pmode = 0;
+ /* Windows 9X doesn't support HALFTONE. */
+ if (os_subtype == OS_NT
+ && (pmode = SetStretchBltMode (s->hdc, HALFTONE)) != 0)
+ SetBrushOrgEx (s->hdc, 0, 0, NULL);
+ StretchBlt (s->hdc, x, y, s->slice.width, s->slice.height,
+ compat_hdc, orig_slice_x, orig_slice_y,
+ orig_slice_width, orig_slice_height, SRCCOPY);
+ if (pmode)
+ SetStretchBltMode (s->hdc, pmode);
+ }
/* When the image has a mask, we can expect that at
least part of a mouse highlight or a block cursor will
@@ -1979,14 +2050,14 @@ x_draw_image_relief (struct glyph_string *s)
if (s->face->id == TOOL_BAR_FACE_ID)
{
if (CONSP (Vtool_bar_button_margin)
- && INTEGERP (XCAR (Vtool_bar_button_margin))
- && INTEGERP (XCDR (Vtool_bar_button_margin)))
+ && FIXNUMP (XCAR (Vtool_bar_button_margin))
+ && FIXNUMP (XCDR (Vtool_bar_button_margin)))
{
- extra_x = XINT (XCAR (Vtool_bar_button_margin));
- extra_y = XINT (XCDR (Vtool_bar_button_margin));
+ extra_x = XFIXNUM (XCAR (Vtool_bar_button_margin));
+ extra_y = XFIXNUM (XCDR (Vtool_bar_button_margin));
}
- else if (INTEGERP (Vtool_bar_button_margin))
- extra_x = extra_y = XINT (Vtool_bar_button_margin);
+ else if (FIXNUMP (Vtool_bar_button_margin))
+ extra_x = extra_y = XFIXNUM (Vtool_bar_button_margin);
}
top_p = bot_p = left_p = right_p = 0;
@@ -2031,6 +2102,10 @@ w32_draw_image_foreground_1 (struct glyph_string *s, HBITMAP pixmap)
if (s->slice.y == 0)
y += s->img->vmargin;
+ /* FIXME (maybe): The below doesn't support image scaling. But it
+ seems to never be called, because the conditions for its call in
+ x_draw_image_glyph_string are never fulfilled (they will be if
+ the #ifdef'ed away part of that function is ever activated). */
if (s->img->pixmap)
{
HDC compat_hdc = CreateCompatibleDC (hdc);
@@ -2475,31 +2550,52 @@ x_draw_glyph_string (struct glyph_string *s)
else
{
struct font *font = font_for_underline_metrics (s);
+ unsigned long minimum_offset;
+ BOOL underline_at_descent_line;
+ BOOL use_underline_position_properties;
+ Lisp_Object val
+ = buffer_local_value (Qunderline_minimum_offset,
+ s->w->contents);
+ if (FIXNUMP (val))
+ minimum_offset = XFIXNAT (val);
+ else
+ minimum_offset = 1;
+ val = buffer_local_value (Qx_underline_at_descent_line,
+ s->w->contents);
+ underline_at_descent_line
+ = !(NILP (val) || EQ (val, Qunbound));
+ val
+ = buffer_local_value (Qx_use_underline_position_properties,
+ s->w->contents);
+ use_underline_position_properties
+ = !(NILP (val) || EQ (val, Qunbound));
/* Get the underline thickness. Default is 1 pixel. */
if (font && font->underline_thickness > 0)
thickness = font->underline_thickness;
else
thickness = 1;
- if (x_underline_at_descent_line || !font)
+ if (underline_at_descent_line
+ || !font)
position = (s->height - thickness) - (s->ybase - s->y);
else
{
- /* Get the underline position. This is the recommended
- vertical offset in pixels from the baseline to the top of
- the underline. This is a signed value according to the
+ /* Get the underline position. This is the
+ recommended vertical offset in pixels from
+ the baseline to the top of the underline.
+ This is a signed value according to the
specs, and its default is
ROUND ((maximum_descent) / 2), with
ROUND (x) = floor (x + 0.5) */
- if (x_use_underline_position_properties
+ if (use_underline_position_properties
&& font->underline_position >= 0)
position = font->underline_position;
else
position = (font->descent + 1) / 2;
}
- position = max (position, underline_minimum_offset);
+ position = max (position, minimum_offset);
}
/* Check the sanity of thickness and position. We should
avoid drawing underline out of the current line area. */
@@ -2865,20 +2961,6 @@ x_focus_changed (int type, int state, struct w32_display_info *dpyinfo,
{
x_new_focus_frame (dpyinfo, frame);
dpyinfo->w32_focus_event_frame = frame;
-
- /* Don't stop displaying the initial startup message
- for a switch-frame event we don't need. */
- if (NILP (Vterminal_frame)
- && CONSP (Vframe_list)
- && !NILP (XCDR (Vframe_list)))
- {
- bufp->arg = Qt;
- }
- else
- {
- bufp->arg = Qnil;
- }
-
bufp->kind = FOCUS_IN_EVENT;
XSETFRAME (bufp->frame_or_window, frame);
}
@@ -3566,8 +3648,8 @@ w32_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window,
static void
w32_handle_tool_bar_click (struct frame *f, struct input_event *button_event)
{
- int x = XFASTINT (button_event->x);
- int y = XFASTINT (button_event->y);
+ int x = XFIXNAT (button_event->x);
+ int y = XFIXNAT (button_event->y);
if (button_event->modifiers & down_modifier)
handle_tool_bar_click (f, x, y, 1, 0);
@@ -3608,7 +3690,7 @@ x_window_to_scroll_bar (Window window_id, int type)
! NILP (bar));
bar = XSCROLL_BAR (bar)->next)
if (SCROLL_BAR_W32_WINDOW (XSCROLL_BAR (bar)) == window_id
- && (type = 2
+ && (type == 2
|| (type == 1 && XSCROLL_BAR (bar)->horizontal)
|| (type == 0 && !XSCROLL_BAR (bar)->horizontal)))
return XSCROLL_BAR (bar);
@@ -3814,7 +3896,7 @@ x_scroll_bar_create (struct window *w, int left, int top, int width, int height,
HWND hwnd;
SCROLLINFO si;
struct scroll_bar *bar
- = ALLOCATE_PSEUDOVECTOR (struct scroll_bar, top, PVEC_OTHER);
+ = ALLOCATE_PSEUDOVECTOR (struct scroll_bar, w32_widget_high, PVEC_OTHER);
Lisp_Object barobj;
block_input ();
@@ -4762,7 +4844,7 @@ w32_read_socket (struct terminal *terminal,
if (f && !FRAME_ICONIFIED_P (f))
{
- if (!hlinfo->mouse_face_hidden && INTEGERP (Vmouse_highlight)
+ if (!hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight)
&& !EQ (f->tool_bar_window, hlinfo->mouse_face_window))
{
clear_mouse_face (hlinfo);
@@ -4787,7 +4869,7 @@ w32_read_socket (struct terminal *terminal,
if (f && !FRAME_ICONIFIED_P (f))
{
- if (!hlinfo->mouse_face_hidden && INTEGERP (Vmouse_highlight)
+ if (!hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight)
&& !EQ (f->tool_bar_window, hlinfo->mouse_face_window))
{
clear_mouse_face (hlinfo);
@@ -4865,7 +4947,7 @@ w32_read_socket (struct terminal *terminal,
if (f && !FRAME_ICONIFIED_P (f))
{
- if (!hlinfo->mouse_face_hidden && INTEGERP (Vmouse_highlight)
+ if (!hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight)
&& !EQ (f->tool_bar_window, hlinfo->mouse_face_window))
{
clear_mouse_face (hlinfo);
@@ -4989,8 +5071,8 @@ w32_read_socket (struct terminal *terminal,
&& WINDOW_TOTAL_LINES (XWINDOW (f->tool_bar_window)))
{
Lisp_Object window;
- int x = XFASTINT (inev.x);
- int y = XFASTINT (inev.y);
+ int x = XFIXNAT (inev.x);
+ int y = XFIXNAT (inev.y);
window = window_from_coordinates (f, x, y, 0, 1);
@@ -5569,7 +5651,7 @@ w32_read_socket (struct terminal *terminal,
struct frame *f = XFRAME (frame);
/* The tooltip has been drawn already. Avoid the
SET_FRAME_GARBAGED below. */
- if (EQ (frame, tip_frame))
+ if (FRAME_TOOLTIP_P (f))
continue;
/* Check "visible" frames and mark each as obscured or not.
@@ -6046,7 +6128,7 @@ x_new_font (struct frame *f, Lisp_Object font_object, int fontset)
/* Don't change the size of a tip frame; there's no point in
doing it because it's done in Fx_show_tip, and it leads to
problems because the tip frame has no widget. */
- if (NILP (tip_frame) || XFRAME (tip_frame) != f)
+ if (!FRAME_TOOLTIP_P (f))
adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f),
FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 3,
false, Qfont);
@@ -6135,11 +6217,11 @@ x_calc_absolute_position (struct frame *f)
geometry = Fassoc (Qgeometry, attributes, Qnil);
if (!NILP (geometry))
{
- monitor_left = Fnth (make_number (1), geometry);
- monitor_top = Fnth (make_number (2), geometry);
+ monitor_left = Fnth (make_fixnum (1), geometry);
+ monitor_top = Fnth (make_fixnum (2), geometry);
- display_left = min (display_left, XINT (monitor_left));
- display_top = min (display_top, XINT (monitor_top));
+ display_left = min (display_left, XFIXNUM (monitor_left));
+ display_top = min (display_top, XFIXNUM (monitor_top));
}
}
}
@@ -6425,10 +6507,10 @@ x_set_window_size (struct frame *f, bool change_gravity,
{
frame_size_history_add
(f, Qx_set_window_size_1, width, height,
- list2 (Fcons (make_number (pixelwidth),
- make_number (pixelheight)),
- Fcons (make_number (rect.right - rect.left),
- make_number (rect.bottom - rect.top))));
+ list2 (Fcons (make_fixnum (pixelwidth),
+ make_fixnum (pixelheight)),
+ Fcons (make_fixnum (rect.right - rect.left),
+ make_fixnum (rect.bottom - rect.top))));
if (!FRAME_PARENT_FRAME (f))
my_set_window_pos (FRAME_W32_WINDOW (f), NULL,
@@ -7261,7 +7343,7 @@ w32_initialize (void)
/* Initialize input mode: interrupt_input off, no flow control, allow
8 bit character input, standard quit char. */
- Fset_input_mode (Qnil, Qnil, make_number (2), Qnil);
+ Fset_input_mode (Qnil, Qnil, make_fixnum (2), Qnil);
{
LCID input_locale_id = LOWORD (GetKeyboardLayout (0));
@@ -7332,14 +7414,7 @@ syms_of_w32term (void)
DEFSYM (Qrenamed_to, "renamed-to");
DEFVAR_LISP ("x-wait-for-event-timeout", Vx_wait_for_event_timeout,
- doc: /* How long to wait for X events.
-
-Emacs will wait up to this many seconds to receive X events after
-making changes which affect the state of the graphical interface.
-Under some window managers this can take an indefinite amount of time,
-so it is important to limit the wait.
-
-If set to a non-float value, there will be no wait at all. */);
+ doc: /* SKIP: real doc in xterm.c. */);
Vx_wait_for_event_timeout = make_float (0.1);
DEFVAR_INT ("w32-num-mouse-buttons",
@@ -7393,30 +7468,19 @@ the cursor have no effect. */);
from cus-start.el and other places, like "M-x set-variable". */
DEFVAR_BOOL ("x-use-underline-position-properties",
x_use_underline_position_properties,
- doc: /* Non-nil means make use of UNDERLINE_POSITION font properties.
-A value of nil means ignore them. If you encounter fonts with bogus
-UNDERLINE_POSITION font properties, for example 7x13 on XFree prior
-to 4.1, set this to nil. You can also use `underline-minimum-offset'
-to override the font's UNDERLINE_POSITION for small font display
-sizes. */);
+ doc: /* SKIP: real doc in xterm.c. */);
x_use_underline_position_properties = 0;
+ DEFSYM (Qx_use_underline_position_properties,
+ "x-use-underline-position-properties");
DEFVAR_BOOL ("x-underline-at-descent-line",
x_underline_at_descent_line,
- doc: /* Non-nil means to draw the underline at the same place as the descent line.
-(If `line-spacing' is in effect, that moves the underline lower by
-that many pixels.)
-A value of nil means to draw the underline according to the value of the
-variable `x-use-underline-position-properties', which is usually at the
-baseline level. The default value is nil. */);
+ doc: /* SKIP: real doc in xterm.c. */);
x_underline_at_descent_line = 0;
+ DEFSYM (Qx_underline_at_descent_line, "x-underline-at-descent-line");
DEFVAR_LISP ("x-toolkit-scroll-bars", Vx_toolkit_scroll_bars,
- doc: /* Which toolkit scroll bars Emacs uses, if any.
-A value of nil means Emacs doesn't use toolkit scroll bars.
-With the X Window system, the value is a symbol describing the
-X toolkit. Possible values are: gtk, motif, xaw, or xaw3d.
-With MS Windows or Nextstep, the value is t. */);
+ doc: /* SKIP: real doc in xterm.c. */);
Vx_toolkit_scroll_bars = Qt;
DEFVAR_BOOL ("w32-unicode-filenames",
diff --git a/src/w32term.h b/src/w32term.h
index 9a6c358982a..4c496e97e4a 100644
--- a/src/w32term.h
+++ b/src/w32term.h
@@ -478,7 +478,7 @@ struct scroll_bar {
#ifdef _WIN64
/* Building a 64-bit C integer from two 32-bit lisp integers. */
-#define SCROLL_BAR_PACK(low, high) (XINT (high) << 32 | XINT (low))
+#define SCROLL_BAR_PACK(low, high) (XFIXNUM (high) << 32 | XFIXNUM (low))
/* Setting two lisp integers to the low and high words of a 64-bit C int. */
#define SCROLL_BAR_UNPACK(low, high, int64) \
@@ -486,7 +486,7 @@ struct scroll_bar {
XSETINT ((high), ((DWORDLONG)(int64) >> 32) & 0xffffffff))
#else /* not _WIN64 */
/* Building a 32-bit C unsigned integer from two 16-bit lisp integers. */
-#define SCROLL_BAR_PACK(low, high) ((UINT_PTR)(XINT (high) << 16 | XINT (low)))
+#define SCROLL_BAR_PACK(low, high) ((UINT_PTR)(XFIXNUM (high) << 16 | XFIXNUM (low)))
/* Setting two lisp integers to the low and high words of a 32-bit C int. */
#define SCROLL_BAR_UNPACK(low, high, int32) \
@@ -817,6 +817,8 @@ extern struct window *w32_system_caret_window;
extern int w32_system_caret_hdr_height;
extern int w32_system_caret_mode_height;
+extern Window tip_window;
+
#ifdef _MSC_VER
#ifndef EnumSystemLocales
/* MSVC headers define these only for _WIN32_WINNT >= 0x0500. */
diff --git a/src/w32uniscribe.c b/src/w32uniscribe.c
index 28050d6ac76..72b524f2eab 100644
--- a/src/w32uniscribe.c
+++ b/src/w32uniscribe.c
@@ -36,6 +36,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "composite.h"
#include "font.h"
#include "w32font.h"
+#include "pdumper.h"
+#include "w32common.h"
struct uniscribe_font_info
{
@@ -466,21 +468,21 @@ uniscribe_shape (Lisp_Object lgstring)
the direction, the Hebrew point HOLAM is
drawn above the right edge of the base
consonant, instead of above the left edge. */
- ASET (vec, 0, make_number (-offsets[j].du
+ ASET (vec, 0, make_fixnum (-offsets[j].du
+ adj_offset));
/* Update the adjustment value for the width
advance of the glyph we just emitted. */
adj_offset -= 2 * advances[j];
}
else
- ASET (vec, 0, make_number (offsets[j].du + adj_offset));
+ ASET (vec, 0, make_fixnum (offsets[j].du + adj_offset));
/* In the font definition coordinate system, the
Y coordinate points up, while in our screen
coordinates Y grows downwards. So we need to
reverse the sign of Y-OFFSET here. */
- ASET (vec, 1, make_number (-offsets[j].dv));
+ ASET (vec, 1, make_fixnum (-offsets[j].dv));
/* Based on what ftfont.c does... */
- ASET (vec, 2, make_number (advances[j]));
+ ASET (vec, 2, make_fixnum (advances[j]));
LGLYPH_SET_ADJUSTMENT (lglyph, vec);
}
else
@@ -508,7 +510,7 @@ uniscribe_shape (Lisp_Object lgstring)
if (NILP (lgstring))
return Qnil;
else
- return make_number (done_glyphs);
+ return make_fixnum (done_glyphs);
}
/* Uniscribe implementation of encode_char for font backend.
@@ -885,7 +887,7 @@ uniscribe_check_otf (LOGFONT *font, Lisp_Object otf_spec)
int i, retval = 0;
/* Check the spec is in the right format. */
- if (!CONSP (otf_spec) || XINT (Flength (otf_spec)) < 3)
+ if (!CONSP (otf_spec) || XFIXNUM (Flength (otf_spec)) < 3)
return 0;
/* Break otf_spec into its components. */
@@ -1181,9 +1183,17 @@ struct font_driver uniscribe_font_driver =
as it needs to test for the existence of the Uniscribe library. */
void syms_of_w32uniscribe (void);
+static void syms_of_w32uniscribe_for_pdumper (void);
+
void
syms_of_w32uniscribe (void)
{
+ pdumper_do_now_and_after_load (syms_of_w32uniscribe_for_pdumper);
+}
+
+static void
+syms_of_w32uniscribe_for_pdumper (void)
+{
HMODULE uniscribe;
/* Don't init uniscribe when dumping */
@@ -1200,11 +1210,11 @@ syms_of_w32uniscribe (void)
register_font_driver (&uniscribe_font_driver, NULL);
script_get_font_scripts_fn = (ScriptGetFontScriptTags_Proc)
- GetProcAddress (uniscribe, "ScriptGetFontScriptTags");
+ get_proc_addr (uniscribe, "ScriptGetFontScriptTags");
script_get_font_languages_fn = (ScriptGetFontLanguageTags_Proc)
- GetProcAddress (uniscribe, "ScriptGetFontLanguageTags");
+ get_proc_addr (uniscribe, "ScriptGetFontLanguageTags");
script_get_font_features_fn = (ScriptGetFontFeatureTags_Proc)
- GetProcAddress (uniscribe, "ScriptGetFontFeatureTags");
+ get_proc_addr (uniscribe, "ScriptGetFontFeatureTags");
if (script_get_font_scripts_fn
&& script_get_font_languages_fn
&& script_get_font_features_fn)
diff --git a/src/widget.c b/src/widget.c
index 5abb3c229b4..508974dd46f 100644
--- a/src/widget.c
+++ b/src/widget.c
@@ -282,7 +282,7 @@ set_frame_size (EmacsFrame ew)
frame_size_history_add
(f, Qset_frame_size, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f),
- list2 (make_number (ew->core.width), make_number (ew->core.height)));
+ list2i (ew->core.width, ew->core.height));
}
static void
@@ -297,7 +297,6 @@ update_wm_hints (EmacsFrame ew)
int char_height;
int base_width;
int base_height;
- int min_rows = 0, min_cols = 0;
/* This happens when the frame is just created. */
if (! wmshell) return;
@@ -323,8 +322,8 @@ update_wm_hints (EmacsFrame ew)
XtNbaseHeight, (XtArgVal) base_height,
XtNwidthInc, (XtArgVal) (frame_resize_pixelwise ? 1 : cw),
XtNheightInc, (XtArgVal) (frame_resize_pixelwise ? 1 : ch),
- XtNminWidth, (XtArgVal) (base_width + min_cols * cw),
- XtNminHeight, (XtArgVal) (base_height + min_rows * ch),
+ XtNminWidth, (XtArgVal) base_width,
+ XtNminHeight, (XtArgVal) base_height,
NULL);
}
@@ -421,10 +420,10 @@ EmacsFrameResize (Widget widget)
frame_size_history_add
(f, QEmacsFrameResize, width, height,
- list5 (make_number (ew->core.width), make_number (ew->core.height),
- make_number (FRAME_TOP_MARGIN_HEIGHT (f)),
- make_number (FRAME_SCROLL_BAR_AREA_HEIGHT (f)),
- make_number (2 * FRAME_INTERNAL_BORDER_WIDTH (f))));
+ list5 (make_fixnum (ew->core.width), make_fixnum (ew->core.height),
+ make_fixnum (FRAME_TOP_MARGIN_HEIGHT (f)),
+ make_fixnum (FRAME_SCROLL_BAR_AREA_HEIGHT (f)),
+ make_fixnum (2 * FRAME_INTERNAL_BORDER_WIDTH (f))));
change_frame_size (f, width, height, 0, 1, 0, 1);
diff --git a/src/window.c b/src/window.c
index dfac3b5b879..ef2ed638508 100644
--- a/src/window.c
+++ b/src/window.c
@@ -42,6 +42,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifdef MSDOS
#include "msdos.h"
#endif
+#include "pdumper.h"
static ptrdiff_t count_windows (struct window *);
static ptrdiff_t get_leaf_windows (struct window *, struct window **,
@@ -77,11 +78,19 @@ static void apply_window_adjustment (struct window *);
FRAME_SELECTED_WINDOW (selected_frame). */
Lisp_Object selected_window;
+/* The value of selected_window at the last time window change
+ functions were run. This is always the same as
+ FRAME_OLD_SELECTED_WINDOW (old_selected_frame). */
+static Lisp_Object old_selected_window;
+
/* A list of all windows for use by next_window and Fwindow_list.
Functions creating or deleting windows should invalidate this cache
by setting it to nil. */
Lisp_Object Vwindow_list;
+/* True mean window_change_record has to record all live frames. */
+static bool window_change_record_frames;
+
/* The mini-buffer window of the selected frame.
Note that you cannot test for mini-bufferness of an arbitrary window
by comparing against this; but you can test for mini-bufferness of
@@ -304,6 +313,12 @@ wset_buffer (struct window *w, Lisp_Object val)
adjust_window_count (w, 1);
}
+static void
+wset_old_buffer (struct window *w, Lisp_Object val)
+{
+ w->old_buffer = val;
+}
+
DEFUN ("windowp", Fwindowp, Swindowp, 1, 1, 0,
doc: /* Return t if OBJECT is a window and nil otherwise. */)
(Lisp_Object object)
@@ -428,6 +443,22 @@ return the selected window of that frame. */)
return window;
}
+DEFUN ("frame-old-selected-window", Fframe_old_selected_window,
+ Sframe_old_selected_window, 0, 1, 0,
+ doc: /* Return old selected window of FRAME.
+FRAME must be a live frame and defaults to the selected one.
+
+The return value is the window selected on FRAME the last time window
+change functions were run for FRAME. */)
+ (Lisp_Object frame)
+{
+ if (NILP (frame))
+ frame = selected_frame;
+ CHECK_LIVE_FRAME (frame);
+
+ return XFRAME (frame)->old_selected_window;
+}
+
DEFUN ("set-frame-selected-window", Fset_frame_selected_window,
Sset_frame_selected_window, 2, 3, 0,
doc: /* Set selected window of FRAME to WINDOW.
@@ -465,6 +496,16 @@ selected windows appears and to which many commands apply. */)
return selected_window;
}
+DEFUN ("old-selected-window", Fold_selected_window,
+ Sold_selected_window, 0, 0, 0,
+ doc: /* Return the old selected window.
+The return value is the window selected the last time window change
+functions were run. */)
+ (void)
+{
+ return old_selected_window;
+}
+
EMACS_INT window_select_count;
/* If select_window is called with inhibit_point_swap true it will
@@ -597,9 +638,33 @@ Return nil for an internal window or a deleted window. */)
(Lisp_Object window)
{
struct window *w = decode_any_window (window);
+
return WINDOW_LEAF_P (w) ? w->contents : Qnil;
}
+DEFUN ("window-old-buffer", Fwindow_old_buffer, Swindow_old_buffer, 0, 1, 0,
+ doc: /* Return the old buffer displayed by WINDOW.
+WINDOW must be a live window and defaults to the selected one.
+
+The return value is the buffer shown in WINDOW at the last time window
+change functions were run. It is nil if WINDOW was created after
+that. It is t if WINDOW has been restored from a window configuration
+after that. */)
+ (Lisp_Object window)
+{
+ struct window *w = decode_live_window (window);
+
+ return (NILP (w->old_buffer)
+ /* A new window. */
+ ? Qnil
+ : (w->change_stamp != WINDOW_XFRAME (w)->change_stamp)
+ /* A window restored from a configuration. */
+ ? Qt
+ /* A window that was live the last time seen by window
+ change functions. */
+ : w->old_buffer);
+}
+
DEFUN ("window-parent", Fwindow_parent, Swindow_parent, 0, 1, 0,
doc: /* Return the parent window of window WINDOW.
WINDOW must be a valid window and defaults to the selected one.
@@ -695,7 +760,7 @@ one. The window with the lowest use time is the least recently
selected one. */)
(Lisp_Object window)
{
- return make_number (decode_live_window (window)->use_time);
+ return make_fixnum (decode_live_window (window)->use_time);
}
DEFUN ("window-pixel-width", Fwindow_pixel_width, Swindow_pixel_width, 0, 1, 0,
@@ -708,7 +773,7 @@ an internal window, its pixel width is the width of the screen areas
spanned by its children. */)
(Lisp_Object window)
{
- return make_number (decode_valid_window (window)->pixel_width);
+ return make_fixnum (decode_valid_window (window)->pixel_width);
}
DEFUN ("window-pixel-height", Fwindow_pixel_height, Swindow_pixel_height, 0, 1, 0,
@@ -720,37 +785,35 @@ divider, if any. If WINDOW is an internal window, its pixel height is
the height of the screen areas spanned by its children. */)
(Lisp_Object window)
{
- return make_number (decode_valid_window (window)->pixel_height);
+ return make_fixnum (decode_valid_window (window)->pixel_height);
}
-DEFUN ("window-pixel-width-before-size-change",
- Fwindow_pixel_width_before_size_change,
- Swindow_pixel_width_before_size_change, 0, 1, 0,
- doc: /* Return pixel width of window WINDOW before last size changes.
+DEFUN ("window-old-pixel-width", Fwindow_old_pixel_width,
+ Swindow_old_pixel_width, 0, 1, 0,
+ doc: /* Return old total pixel width of WINDOW.
WINDOW must be a valid window and defaults to the selected one.
-The return value is the pixel width of WINDOW at the last time
-`window-size-change-functions' was run. It's zero if WINDOW was made
-after that. */)
+The return value is the total pixel width of WINDOW after the last
+time window change functions found WINDOW live on its frame. It is
+zero if WINDOW was created after that. */)
(Lisp_Object window)
{
- return (make_number
- (decode_valid_window (window)->pixel_width_before_size_change));
+ return (make_fixnum
+ (decode_valid_window (window)->old_pixel_width));
}
-DEFUN ("window-pixel-height-before-size-change",
- Fwindow_pixel_height_before_size_change,
- Swindow_pixel_height_before_size_change, 0, 1, 0,
- doc: /* Return pixel height of window WINDOW before last size changes.
+DEFUN ("window-old-pixel-height", Fwindow_old_pixel_height,
+ Swindow_old_pixel_height, 0, 1, 0,
+ doc: /* Return old total pixel height of WINDOW.
WINDOW must be a valid window and defaults to the selected one.
-The return value is the pixel height of WINDOW at the last time
-`window-size-change-functions' was run. It's zero if WINDOW was made
-after that. */)
+The return value is the total pixel height of WINDOW after the last
+time window change functions found WINDOW live on its frame. It is
+zero if WINDOW was created after that. */)
(Lisp_Object window)
{
- return (make_number
- (decode_valid_window (window)->pixel_height_before_size_change));
+ return (make_fixnum
+ (decode_valid_window (window)->old_pixel_height));
}
DEFUN ("window-total-height", Fwindow_total_height, Swindow_total_height, 0, 2, 0,
@@ -778,12 +841,12 @@ total height of WINDOW. */)
struct window *w = decode_valid_window (window);
if (! EQ (round, Qfloor) && ! EQ (round, Qceiling))
- return make_number (w->total_lines);
+ return make_fixnum (w->total_lines);
else
{
int unit = FRAME_LINE_HEIGHT (WINDOW_XFRAME (w));
- return make_number (EQ (round, Qceiling)
+ return make_fixnum (EQ (round, Qceiling)
? ((w->pixel_height + unit - 1) /unit)
: (w->pixel_height / unit));
}
@@ -815,12 +878,12 @@ total width of WINDOW. */)
struct window *w = decode_valid_window (window);
if (! EQ (round, Qfloor) && ! EQ (round, Qceiling))
- return make_number (w->total_cols);
+ return make_fixnum (w->total_cols);
else
{
int unit = FRAME_COLUMN_WIDTH (WINDOW_XFRAME (w));
- return make_number (EQ (round, Qceiling)
+ return make_fixnum (EQ (round, Qceiling)
? ((w->pixel_width + unit - 1) /unit)
: (w->pixel_width / unit));
}
@@ -898,7 +961,7 @@ DEFUN ("window-pixel-left", Fwindow_pixel_left, Swindow_pixel_left, 0, 1, 0,
WINDOW must be a valid window and defaults to the selected one. */)
(Lisp_Object window)
{
- return make_number (decode_valid_window (window)->pixel_left);
+ return make_fixnum (decode_valid_window (window)->pixel_left);
}
DEFUN ("window-pixel-top", Fwindow_pixel_top, Swindow_pixel_top, 0, 1, 0,
@@ -906,7 +969,7 @@ DEFUN ("window-pixel-top", Fwindow_pixel_top, Swindow_pixel_top, 0, 1, 0,
WINDOW must be a valid window and defaults to the selected one. */)
(Lisp_Object window)
{
- return make_number (decode_valid_window (window)->pixel_top);
+ return make_fixnum (decode_valid_window (window)->pixel_top);
}
DEFUN ("window-left-column", Fwindow_left_column, Swindow_left_column, 0, 1, 0,
@@ -918,7 +981,7 @@ value is 0 if there is no window to the left of WINDOW.
WINDOW must be a valid window and defaults to the selected one. */)
(Lisp_Object window)
{
- return make_number (decode_valid_window (window)->left_col);
+ return make_fixnum (decode_valid_window (window)->left_col);
}
DEFUN ("window-top-line", Fwindow_top_line, Swindow_top_line, 0, 1, 0,
@@ -930,7 +993,7 @@ there is no window above WINDOW.
WINDOW must be a valid window and defaults to the selected one. */)
(Lisp_Object window)
{
- return make_number (decode_valid_window (window)->top_line);
+ return make_fixnum (decode_valid_window (window)->top_line);
}
/* Return the number of lines/pixels of W's body. Don't count any mode
@@ -984,6 +1047,26 @@ window_body_width (struct window *w, bool pixelwise)
0);
}
+DEFUN ("window-body-width", Fwindow_body_width, Swindow_body_width, 0, 2, 0,
+ doc: /* Return the width of WINDOW's text area.
+WINDOW must be a live window and defaults to the selected one. Optional
+argument PIXELWISE non-nil means return the width in pixels. The return
+value does not include any vertical dividers, fringes or marginal areas,
+or scroll bars.
+
+If PIXELWISE is nil, return the largest integer smaller than WINDOW's
+pixel width divided by the character width of WINDOW's frame. This
+means that if a column at the right of the text area is only partially
+visible, that column is not counted.
+
+Note that the returned value includes the column reserved for the
+continuation glyph. */)
+ (Lisp_Object window, Lisp_Object pixelwise)
+{
+ return make_fixnum (window_body_width (decode_live_window (window),
+ !NILP (pixelwise)));
+}
+
DEFUN ("window-body-height", Fwindow_body_height, Swindow_body_height, 0, 2, 0,
doc: /* Return the height of WINDOW's text area.
WINDOW must be a live window and defaults to the selected one. Optional
@@ -997,28 +1080,38 @@ means that if a line at the bottom of the text area is only partially
visible, that line is not counted. */)
(Lisp_Object window, Lisp_Object pixelwise)
{
- return make_number (window_body_height (decode_live_window (window),
+ return make_fixnum (window_body_height (decode_live_window (window),
!NILP (pixelwise)));
}
-DEFUN ("window-body-width", Fwindow_body_width, Swindow_body_width, 0, 2, 0,
- doc: /* Return the width of WINDOW's text area.
-WINDOW must be a live window and defaults to the selected one. Optional
-argument PIXELWISE non-nil means return the width in pixels. The return
-value does not include any vertical dividers, fringes or marginal areas,
-or scroll bars.
+DEFUN ("window-old-body-pixel-width",
+ Fwindow_old_body_pixel_width,
+ Swindow_old_body_pixel_width, 0, 1, 0,
+ doc: /* Return old width of WINDOW's text area in pixels.
+WINDOW must be a live window and defaults to the selected one.
-If PIXELWISE is nil, return the largest integer smaller than WINDOW's
-pixel width divided by the character width of WINDOW's frame. This
-means that if a column at the right of the text area is only partially
-visible, that column is not counted.
+The return value is the pixel width of WINDOW's text area after the
+last time window change functions found WINDOW live on its frame. It
+is zero if WINDOW was created after that. */)
+ (Lisp_Object window)
+{
+ return (make_fixnum
+ (decode_live_window (window)->old_body_pixel_width));
+}
-Note that the returned value includes the column reserved for the
-continuation glyph. */)
- (Lisp_Object window, Lisp_Object pixelwise)
+DEFUN ("window-old-body-pixel-height",
+ Fwindow_old_body_pixel_height,
+ Swindow_old_body_pixel_height, 0, 1, 0,
+ doc: /* Return old height of WINDOW's text area in pixels.
+WINDOW must be a live window and defaults to the selected one.
+
+The return value is the pixel height of WINDOW's text area after the
+last time window change functions found WINDOW live on its frame. It
+is zero if WINDOW was created after that. */)
+ (Lisp_Object window)
{
- return make_number (window_body_width (decode_live_window (window),
- !NILP (pixelwise)));
+ return (make_fixnum
+ (decode_live_window (window)->old_body_pixel_height));
}
DEFUN ("window-mode-line-height", Fwindow_mode_line_height,
@@ -1027,7 +1120,7 @@ DEFUN ("window-mode-line-height", Fwindow_mode_line_height,
WINDOW must be a live window and defaults to the selected one. */)
(Lisp_Object window)
{
- return (make_number (WINDOW_MODE_LINE_HEIGHT (decode_live_window (window))));
+ return (make_fixnum (WINDOW_MODE_LINE_HEIGHT (decode_live_window (window))));
}
DEFUN ("window-header-line-height", Fwindow_header_line_height,
@@ -1036,7 +1129,7 @@ DEFUN ("window-header-line-height", Fwindow_header_line_height,
WINDOW must be a live window and defaults to the selected one. */)
(Lisp_Object window)
{
- return (make_number (WINDOW_HEADER_LINE_HEIGHT (decode_live_window (window))));
+ return (make_fixnum (WINDOW_HEADER_LINE_HEIGHT (decode_live_window (window))));
}
DEFUN ("window-right-divider-width", Fwindow_right_divider_width,
@@ -1045,7 +1138,7 @@ DEFUN ("window-right-divider-width", Fwindow_right_divider_width,
WINDOW must be a live window and defaults to the selected one. */)
(Lisp_Object window)
{
- return (make_number (WINDOW_RIGHT_DIVIDER_WIDTH (decode_live_window (window))));
+ return (make_fixnum (WINDOW_RIGHT_DIVIDER_WIDTH (decode_live_window (window))));
}
DEFUN ("window-bottom-divider-width", Fwindow_bottom_divider_width,
@@ -1054,7 +1147,7 @@ DEFUN ("window-bottom-divider-width", Fwindow_bottom_divider_width,
WINDOW must be a live window and defaults to the selected one. */)
(Lisp_Object window)
{
- return (make_number (WINDOW_BOTTOM_DIVIDER_WIDTH (decode_live_window (window))));
+ return (make_fixnum (WINDOW_BOTTOM_DIVIDER_WIDTH (decode_live_window (window))));
}
DEFUN ("window-scroll-bar-width", Fwindow_scroll_bar_width,
@@ -1063,7 +1156,7 @@ DEFUN ("window-scroll-bar-width", Fwindow_scroll_bar_width,
WINDOW must be a live window and defaults to the selected one. */)
(Lisp_Object window)
{
- return (make_number (WINDOW_SCROLL_BAR_AREA_WIDTH (decode_live_window (window))));
+ return (make_fixnum (WINDOW_SCROLL_BAR_AREA_WIDTH (decode_live_window (window))));
}
DEFUN ("window-scroll-bar-height", Fwindow_scroll_bar_height,
@@ -1072,7 +1165,7 @@ DEFUN ("window-scroll-bar-height", Fwindow_scroll_bar_height,
WINDOW must be a live window and defaults to the selected one. */)
(Lisp_Object window)
{
- return (make_number (WINDOW_SCROLL_BAR_AREA_HEIGHT (decode_live_window (window))));
+ return (make_fixnum (WINDOW_SCROLL_BAR_AREA_HEIGHT (decode_live_window (window))));
}
DEFUN ("window-hscroll", Fwindow_hscroll, Swindow_hscroll, 0, 1, 0,
@@ -1080,7 +1173,7 @@ DEFUN ("window-hscroll", Fwindow_hscroll, Swindow_hscroll, 0, 1, 0,
WINDOW must be a live window and defaults to the selected one. */)
(Lisp_Object window)
{
- return make_number (decode_live_window (window)->hscroll);
+ return make_fixnum (decode_live_window (window)->hscroll);
}
/* Set W's horizontal scroll amount to HSCROLL clipped to a reasonable
@@ -1104,7 +1197,7 @@ set_window_hscroll (struct window *w, EMACS_INT hscroll)
w->hscroll = new_hscroll;
w->suspend_auto_hscroll = true;
- return make_number (new_hscroll);
+ return make_fixnum (new_hscroll);
}
DEFUN ("set-window-hscroll", Fset_window_hscroll, Sset_window_hscroll, 2, 2, 0,
@@ -1117,8 +1210,8 @@ Note that if `automatic-hscrolling' is non-nil, you cannot scroll the
window so that the location of point moves off-window. */)
(Lisp_Object window, Lisp_Object ncol)
{
- CHECK_NUMBER (ncol);
- return set_window_hscroll (decode_live_window (window), XINT (ncol));
+ CHECK_FIXNUM (ncol);
+ return set_window_hscroll (decode_live_window (window), XFIXNUM (ncol));
}
DEFUN ("window-redisplay-end-trigger", Fwindow_redisplay_end_trigger,
@@ -1383,8 +1476,8 @@ If they are in the windows's left or right marginal areas, `left-margin'\n\
CHECK_CONS (coordinates);
lx = Fcar (coordinates);
ly = Fcdr (coordinates);
- CHECK_NUMBER_OR_FLOAT (lx);
- CHECK_NUMBER_OR_FLOAT (ly);
+ CHECK_NUMBER (lx);
+ CHECK_NUMBER (ly);
x = FRAME_PIXEL_X_FROM_CANON_X (f, lx) + FRAME_INTERNAL_BORDER_WIDTH (f);
y = FRAME_PIXEL_Y_FROM_CANON_Y (f, ly) + FRAME_INTERNAL_BORDER_WIDTH (f);
@@ -1506,7 +1599,7 @@ window_from_coordinates (struct frame *f, int x, int y,
cw.window = &window, cw.x = x, cw.y = y; cw.part = part;
foreach_window (f, check_window_containing, &cw);
-#if defined (HAVE_WINDOW_SYSTEM) && ! defined (USE_GTK) && ! defined (HAVE_NS)
+#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_TOOL_BAR)
/* If not found above, see if it's in the tool bar window, if a tool
bar exists. */
if (NILP (window)
@@ -1533,9 +1626,8 @@ column 0. */)
{
struct frame *f = decode_live_frame (frame);
- /* Check that arguments are integers or floats. */
- CHECK_NUMBER_OR_FLOAT (x);
- CHECK_NUMBER_OR_FLOAT (y);
+ CHECK_NUMBER (x);
+ CHECK_NUMBER (y);
return window_from_coordinates (f,
(FRAME_PIXEL_X_FROM_CANON_X (f, x)
@@ -1561,7 +1653,7 @@ correct to return the top-level value of `point', outside of any
register struct window *w = decode_live_window (window);
if (w == XWINDOW (selected_window))
- return make_number (BUF_PT (XBUFFER (w->contents)));
+ return make_fixnum (BUF_PT (XBUFFER (w->contents)));
else
return Fmarker_position (w->pointm);
}
@@ -1652,7 +1744,7 @@ if it isn't already recorded. */)
move_it_vertically (&it, window_box_height (w));
if (it.current_y < it.last_visible_y)
move_it_past_eol (&it);
- value = make_number (IT_CHARPOS (it));
+ value = make_fixnum (IT_CHARPOS (it));
bidi_unshelve_cache (itdata, false);
if (old_buffer)
@@ -1683,7 +1775,7 @@ Return POS. */)
struct buffer *old_buffer = current_buffer;
/* ... but here we want to catch type error before buffer change. */
- CHECK_NUMBER_COERCE_MARKER (pos);
+ CHECK_FIXNUM_COERCE_MARKER (pos);
set_buffer_internal (XBUFFER (w->contents));
Fgoto_char (pos);
set_buffer_internal (old_buffer);
@@ -1768,8 +1860,8 @@ POS, ROWH is the visible height of that row, and VPOS is the row number
posint = -1;
else if (!NILP (pos))
{
- CHECK_NUMBER_COERCE_MARKER (pos);
- posint = XINT (pos);
+ CHECK_FIXNUM_COERCE_MARKER (pos);
+ posint = XFIXNUM (pos);
}
else if (w == XWINDOW (selected_window))
posint = PT;
@@ -1794,8 +1886,8 @@ POS, ROWH is the visible height of that row, and VPOS is the row number
Lisp_Object part = Qnil;
if (!fully_p)
part = list4i (rtop, rbot, rowh, vpos);
- in_window = Fcons (make_number (x),
- Fcons (make_number (y), part));
+ in_window = Fcons (make_fixnum (x),
+ Fcons (make_fixnum (y), part));
}
return in_window;
@@ -1874,8 +1966,8 @@ Return nil if window display is not up-to-date. In that case, use
: Qnil);
}
- CHECK_NUMBER (line);
- n = XINT (line);
+ CHECK_FIXNUM (line);
+ n = XFIXNUM (line);
row = MATRIX_FIRST_TEXT_ROW (w->current_matrix);
end_row = MATRIX_BOTTOM_TEXT_ROW (w->current_matrix, w);
@@ -1977,10 +2069,10 @@ though when run from an idle timer with a delay of zero seconds. */)
row = (NILP (body)
? MATRIX_ROW (w->current_matrix, 0)
: MATRIX_FIRST_TEXT_ROW (w->current_matrix));
- else if (NUMBERP (first))
+ else if (FIXNUMP (first))
{
CHECK_RANGED_INTEGER (first, 0, w->current_matrix->nrows);
- row = MATRIX_ROW (w->current_matrix, XINT (first));
+ row = MATRIX_ROW (w->current_matrix, XFIXNUM (first));
}
else
error ("Invalid specification of first line");
@@ -1990,10 +2082,10 @@ though when run from an idle timer with a delay of zero seconds. */)
end_row = (NILP (body)
? MATRIX_ROW (w->current_matrix, w->current_matrix->nrows)
: MATRIX_BOTTOM_TEXT_ROW (w->current_matrix, w));
- else if (NUMBERP (last))
+ else if (FIXNUMP (last))
{
CHECK_RANGED_INTEGER (last, 0, w->current_matrix->nrows);
- end_row = MATRIX_ROW (w->current_matrix, XINT (last));
+ end_row = MATRIX_ROW (w->current_matrix, XFIXNUM (last));
}
else
error ("Invalid specification of last line");
@@ -2006,19 +2098,19 @@ though when run from an idle timer with a delay of zero seconds. */)
{
struct glyph *glyph = row->glyphs[TEXT_AREA];
- rows = Fcons (Fcons (make_number
+ rows = Fcons (Fcons (make_fixnum
(invert
? glyph->pixel_width
: window_width - glyph->pixel_width),
- make_number (row->y + row->height - subtract)),
+ make_fixnum (row->y + row->height - subtract)),
rows);
}
else
- rows = Fcons (Fcons (make_number
+ rows = Fcons (Fcons (make_fixnum
(invert
? window_width - row->pixel_width
: row->pixel_width),
- make_number (row->y + row->height - subtract)),
+ make_fixnum (row->y + row->height - subtract)),
rows);
row++;
}
@@ -2441,7 +2533,7 @@ window_list (void)
have to reverse this list at the end. */
foreach_window (XFRAME (frame), add_window_to_list, &arglist);
arglist = Fnreverse (arglist);
- Vwindow_list = CALLN (Fnconc, Vwindow_list, arglist);
+ Vwindow_list = nconc2 (Vwindow_list, arglist);
}
}
@@ -2497,7 +2589,7 @@ candidate_window_p (Lisp_Object window, Lisp_Object owindow,
== FRAME_TERMINAL (XFRAME (selected_frame)));
}
- else if (INTEGERP (all_frames) && XINT (all_frames) == 0)
+ else if (FIXNUMP (all_frames) && XFIXNUM (all_frames) == 0)
{
candidate_p = (FRAME_VISIBLE_P (f) || FRAME_ICONIFIED_P (f)
#ifdef HAVE_X_WINDOWS
@@ -2556,7 +2648,7 @@ decode_next_window_args (Lisp_Object *window, Lisp_Object *minibuf, Lisp_Object
: Qnil);
else if (EQ (*all_frames, Qvisible))
;
- else if (EQ (*all_frames, make_number (0)))
+ else if (EQ (*all_frames, make_fixnum (0)))
;
else if (FRAMEP (*all_frames))
;
@@ -2839,7 +2931,7 @@ window_loop (enum window_loop type, Lisp_Object obj, bool mini,
if (f)
frame_arg = Qlambda;
- else if (EQ (frames, make_number (0)))
+ else if (EQ (frames, make_fixnum (0)))
frame_arg = frames;
else if (EQ (frames, Qvisible))
frame_arg = frames;
@@ -3270,7 +3362,7 @@ window-start value is reasonable when this function is called. */)
adjust_frame_glyphs (f);
unblock_input ();
- run_window_configuration_change_hook (f);
+ FRAME_WINDOW_CHANGE (f) = true;
return Qnil;
}
@@ -3324,6 +3416,15 @@ select_frame_norecord (Lisp_Object frame)
Fselect_frame (frame, Qt);
}
+/**
+ * run_window_configuration_change_hook:
+ *
+ * Run any functions on 'window-configuration-change-hook' for the
+ * frame specified by F. The buffer-local values are run with the
+ * window showing the buffer selected. The default value is run with
+ * the frame specified by F selected. All functions are called with
+ * the selected window's buffer current.
+ */
static void
run_window_configuration_change_hook (struct frame *f)
{
@@ -3333,8 +3434,8 @@ run_window_configuration_change_hook (struct frame *f)
XSETFRAME (frame, f);
if (NILP (Vrun_hooks)
- || !(f->can_x_set_window_size)
- || !(f->after_make_frame))
+ || !f->can_x_set_window_size
+ || !f->after_make_frame)
return;
/* Use the right buffer. Matters when running the local hooks. */
@@ -3377,7 +3478,10 @@ run_window_configuration_change_hook (struct frame *f)
DEFUN ("run-window-configuration-change-hook", Frun_window_configuration_change_hook,
Srun_window_configuration_change_hook, 0, 1, 0,
doc: /* Run `window-configuration-change-hook' for FRAME.
-If FRAME is omitted or nil, it defaults to the selected frame. */)
+If FRAME is omitted or nil, it defaults to the selected frame.
+
+This function should not be needed any more and will be therefore
+considered obsolete. */)
(Lisp_Object frame)
{
run_window_configuration_change_hook (decode_live_frame (frame));
@@ -3387,93 +3491,437 @@ If FRAME is omitted or nil, it defaults to the selected frame. */)
DEFUN ("run-window-scroll-functions", Frun_window_scroll_functions,
Srun_window_scroll_functions, 0, 1, 0,
doc: /* Run `window-scroll-functions' for WINDOW.
-If WINDOW is omitted or nil, it defaults to the selected window. */)
+If WINDOW is omitted or nil, it defaults to the selected window.
+
+This function is curently only called by 'split-window' for the new
+window after it has established the size of the new window. */)
(Lisp_Object window)
{
- if (! NILP (Vwindow_scroll_functions))
+ struct window *w = decode_live_window (window);
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+ record_unwind_current_buffer ();
+ Fset_buffer (w->contents);
+ if (!NILP (Vwindow_scroll_functions))
run_hook_with_args_2 (Qwindow_scroll_functions, window,
- Fmarker_position (decode_live_window (window)->start));
+ Fmarker_position (w->start));
+ unbind_to (count, Qnil);
+
return Qnil;
}
-/* Compare old and present pixel sizes of windows in tree rooted at W.
- Return true iff any of these windows differs in size. */
+/**
+ * window_sub_list:
+ *
+ * Return list of live windows constructed by traversing any window
+ * sub-tree rooted at WINDOW in preorder followed by right siblings of
+ * WINDOW. Called from outside with second argument WINDOWS nil. The
+ * returned list is in reverse order.
+ */
+static Lisp_Object
+window_sub_list (Lisp_Object window, Lisp_Object windows)
+{
-static bool
-window_size_changed (struct window *w)
+ struct window *w = XWINDOW (window);
+
+ while (w)
+ {
+ if (WINDOW_INTERNAL_P (w))
+ windows = window_sub_list (w->contents, windows);
+ else
+ windows = Fcons (window, windows);
+
+ window = w->next;
+ w = NILP (window) ? 0 : XWINDOW (window);
+ }
+
+ return windows;
+}
+
+
+/**
+ * window_change_record_windows:
+ *
+ * Record changes for all live windows found by traversing any window
+ * sub-tree rooted at WINDOW in preorder followed by any right
+ * siblings of WINDOW. This sets the old buffer, old pixel and old
+ * body pixel sizes of each live window found to the respective
+ * current values. It also sets the change stamp of each window found
+ * to STAMP. Return the number of live windows found.
+ *
+ * When not called by itself recursively, WINDOW is its frame's root
+ * window, STAMP is the current change stamp of WINDOW's frame and
+ * NUMBER is 0.
+ */
+static ptrdiff_t
+window_change_record_windows (Lisp_Object window, int stamp, ptrdiff_t number)
{
- if (w->pixel_width != w->pixel_width_before_size_change
- || w->pixel_height != w->pixel_height_before_size_change)
- return true;
+ struct window *w = XWINDOW (window);
- if (WINDOW_INTERNAL_P (w))
+ while (w)
{
- w = XWINDOW (w->contents);
- while (w)
+ if (WINDOW_INTERNAL_P (w))
+ number = window_change_record_windows (w->contents, stamp, number);
+ else
{
- if (window_size_changed (w))
- return true;
+ number += 1;
+ w->change_stamp = stamp;
+ wset_old_buffer (w, w->contents);
+ w->old_pixel_width = w->pixel_width;
+ w->old_pixel_height = w->pixel_height;
+ w->old_body_pixel_width = window_body_width (w, true);
+ w->old_body_pixel_height = window_body_height (w, true);
+ }
+
+ w = NILP (w->next) ? 0 : XWINDOW (w->next);
+ }
- w = NILP (w->next) ? 0 : XWINDOW (w->next);
+ return number;
+}
+
+
+/**
+ * window_change_record:
+ *
+ * For each frame that has recorded changes, record its selected
+ * window, update Fchange stamp, record the states of all its live
+ * windows via window_change_record_windows and reset its
+ * window_change and window_state_change flags.
+ *
+ * Record selected window in old_selected_window and selected frame in
+ * old_selected_frame.
+ */
+static void
+window_change_record (void)
+{
+ if (window_change_record_frames)
+ {
+ Lisp_Object tail, frame;
+
+ FOR_EACH_FRAME (tail, frame)
+ {
+ struct frame *f = XFRAME (frame);
+
+ /* Record FRAME's selected window. */
+ fset_old_selected_window (f, FRAME_SELECTED_WINDOW (f));
+
+ /* Bump up FRAME's change stamp. If this wraps, make it 1 to avoid
+ that a new window (whose change stamp is always set to 0) gets
+ reported as "existing before". */
+ f->change_stamp += 1;
+ if (f->change_stamp == 0)
+ f->change_stamp = 1;
+
+ /* Bump up the change stamps of all live windows on this frame so
+ the next call of this function can tell whether any of them
+ "existed before" and record state for each of these windows. */
+ f->number_of_windows
+ = window_change_record_windows (f->root_window, f->change_stamp, 0);
+
+ /* Reset our flags. */
+ FRAME_WINDOW_CHANGE (f) = false;
+ FRAME_WINDOW_STATE_CHANGE (f) = false;
}
}
- return false;
+ /* Strictly spoken we don't need old_selected_window at all - its
+ value is the old selected window of old_selected_frame. */
+ old_selected_window = selected_window;
+ old_selected_frame = selected_frame;
}
-/* Set before size change pixel sizes of windows in tree rooted at W to
- their present pixel sizes. */
+/**
+ * run_window_change_functions_1:
+ *
+ * Run window change functions specified by SYMBOL with argument
+ * WINDOW_OR_FRAME. If BUFFER is nil, WINDOW_OR_FRAME specifies a
+ * frame. In this case, run the default value of SYMBOL. Otherwise,
+ * WINDOW_OR_FRAME denotes a window showing BUFFER. In this case, run
+ * the buffer local value of SYMBOL in BUFFER, if any.
+ */
static void
-window_set_before_size_change_sizes (struct window *w)
+run_window_change_functions_1 (Lisp_Object symbol, Lisp_Object buffer,
+ Lisp_Object window_or_frame)
{
- w->pixel_width_before_size_change = w->pixel_width;
- w->pixel_height_before_size_change = w->pixel_height;
+ Lisp_Object funs = Qnil;
+
+ if (NILP (buffer))
+ funs = Fdefault_value (symbol);
+ else if (!NILP (Fassoc (symbol, BVAR (XBUFFER (buffer), local_var_alist),
+ Qnil)))
+ /* Don't run global value buffer-locally. */
+ funs = buffer_local_value (symbol, buffer);
- if (WINDOW_INTERNAL_P (w))
+ while (CONSP (funs))
{
- w = XWINDOW (w->contents);
- while (w)
+ if (!EQ (XCAR (funs), Qt)
+ && (NILP (buffer)
+ ? FRAME_LIVE_P (XFRAME (window_or_frame))
+ : WINDOW_LIVE_P (window_or_frame)))
{
- window_set_before_size_change_sizes (w);
- w = NILP (w->next) ? 0 : XWINDOW (w->next);
+ /* Any function called here may change the state of any
+ frame. Make sure to record changes for each live frame
+ in window_change_record later. */
+ window_change_record_frames = true;
+ safe_call1 (XCAR (funs), window_or_frame);
}
+
+ funs = XCDR (funs);
}
}
+/**
+ * run_window_change_functions:
+ *
+ * Run window change functions for each live frame. This function
+ * must be called from a "safe" position in redisplay_internal.
+ *
+ * Do not run any functions for a frame whose window_change flag is
+ * nil, where no window selection happened and whose window state
+ * change flag was not set since the last time this function was
+ * called. Never run any functions for tooltip frames.
+ *
+ * The change functions run are, in this order:
+ *
+ * 'window-buffer-change-functions' which are run for a window that
+ * changed its buffer or that was not shown the last time window
+ * change functions were run. The default value is also run when a
+ * window was deleted since the last time window change functions were
+ * run.
+ *
+ * `window-size-change-functions' run for a window that changed its
+ * body or total size, a window that changed its buffer or a window
+ * that was not shown the last time window change functions were run.
+ *
+ * `window-selected-change-functions' run for a window that was
+ * (de-)selected since the last time window change functions were run.
+ *
+ * `window-state-change-functions' run for a window for which any of
+ * the above three changes occurred.
+ *
+ * A buffer-local value of these functions is run if and only if the
+ * window for which the functions are run currently shows the buffer.
+ * Each call gets one argument - the window showing the buffer. This
+ * means that the buffer-local value of these functions may be called
+ * as many times as the buffer is shown on the frame.
+ *
+ * The default values of these functions are called only after all
+ * buffer-local values for all of these functions have been run. Each
+ * such call receives one argument - the frame for which a change
+ * occurred. Functions on `window-state-change-functions' are run
+ * also if the corresponding frame's window state change flag has been
+ * set.
+ *
+ * After the four change functions cited above have been run in the
+ * indicated way, functions on 'window-configuration-change-hook' are
+ * run. A buffer-local value is run if a window shows that buffer and
+ * has either changed its buffer or its body or total size or did not
+ * appear on this frame since the last time window change functions
+ * were run. The functions are called without argument and with the
+ * buffer's window selected. The default value is run without
+ * argument and with the frame for which the function is run selected.
+ *
+ * In a final step, functions on `window-state-change-hook' are run
+ * provided a window state change has occurred or the window state
+ * change flag has been set on at least one frame. Each of these
+ * functions is called without argument.
+ *
+ * This function does not save and restore match data. Any functions
+ * it calls are responsible for doing that themselves.
+ */
void
-run_window_size_change_functions (Lisp_Object frame)
+run_window_change_functions (void)
{
- struct frame *f = XFRAME (frame);
- struct window *r = XWINDOW (FRAME_ROOT_WINDOW (f));
- Lisp_Object functions = Vwindow_size_change_functions;
+ Lisp_Object tail, frame;
+ bool selected_frame_change = !EQ (selected_frame, old_selected_frame);
+ bool run_window_state_change_hook = false;
+ ptrdiff_t count = SPECPDL_INDEX ();
- if (FRAME_WINDOW_CONFIGURATION_CHANGED (f)
- /* Here we implicitly exclude the possibility that the height of
- FRAME and its minibuffer window both change leaving the height
- of FRAME's root window alone. */
- || window_size_changed (r))
- {
- while (CONSP (functions))
+ window_change_record_frames = false;
+ record_unwind_protect_void (window_change_record);
+ specbind (Qinhibit_redisplay, Qt);
+
+ FOR_EACH_FRAME (tail, frame)
+ {
+ struct frame *f = XFRAME (frame);
+ Lisp_Object root = FRAME_ROOT_WINDOW (f);
+ bool frame_window_change = FRAME_WINDOW_CHANGE (f);
+ bool window_buffer_change, window_size_change;
+ bool frame_buffer_change = false, frame_size_change = false;
+ bool frame_selected_change
+ = (selected_frame_change
+ && (EQ (frame, old_selected_frame)
+ || EQ (frame, selected_frame)));
+ bool frame_selected_window_change
+ = !EQ (FRAME_OLD_SELECTED_WINDOW (f), FRAME_SELECTED_WINDOW (f));
+ bool frame_window_state_change = FRAME_WINDOW_STATE_CHANGE (f);
+ bool window_deleted = false;
+ Lisp_Object windows;
+ ptrdiff_t number_of_windows;
+
+ if (!FRAME_LIVE_P (f)
+ || !f->can_x_set_window_size
+ || !f->after_make_frame
+ || FRAME_TOOLTIP_P (f)
+ || !(frame_window_change
+ || frame_selected_change
+ || frame_selected_window_change
+ || frame_window_state_change))
+ /* Either we are not allowed to run hooks for this frame or no
+ window change has been reported for it since the last time
+ we ran window change functions on it. */
+ continue;
+
+ /* Analyze windows and run buffer locals hooks in pre-order. */
+ windows = Fnreverse (window_sub_list (root, Qnil));
+ number_of_windows = 0;
+
+ /* The following loop collects all data needed to tell whether
+ the default value of a hook shall be run and runs any buffer
+ local hooks right away. */
+ for (; CONSP (windows); windows = XCDR (windows))
{
- if (!EQ (XCAR (functions), Qt))
- safe_call1 (XCAR (functions), frame);
- functions = XCDR (functions);
+ Lisp_Object window = XCAR (windows);
+ struct window *w = XWINDOW (window);
+ Lisp_Object buffer = WINDOW_BUFFER (w);
+
+ /* Count this window even if it has been deleted while
+ running a hook. */
+ number_of_windows += 1;
+
+ if (!WINDOW_LIVE_P (window))
+ continue;
+
+ /* A "buffer change" means either the window's buffer
+ changed or the window was not part of this frame the last
+ time window change functions were run for it. */
+ window_buffer_change =
+ (frame_window_change
+ && (!EQ (buffer, w->old_buffer)
+ || w->change_stamp != f->change_stamp));
+ /* A "size change" means either a buffer change or that the
+ total or body size of the window has changed.
+
+ Note: A buffer change implies a size change because either
+ this window didn't show the buffer before or this window
+ didn't show the buffer the last time the window change
+ functions were run. In either case, an application
+ tracing size changes in a buffer-locally fashion might
+ want to be informed about that change. */
+ window_size_change =
+ (frame_window_change
+ && (window_buffer_change
+ || w->pixel_width != w->old_pixel_width
+ || w->pixel_height != w->old_pixel_height
+ || window_body_width (w, true) != w->old_body_pixel_width
+ || window_body_height (w, true) != w->old_body_pixel_height));
+
+ /* The following two are needed when running the default
+ values for this frame below. */
+ frame_buffer_change = frame_buffer_change || window_buffer_change;
+ frame_size_change = frame_size_change || window_size_change;
+
+ if (window_buffer_change)
+ run_window_change_functions_1
+ (Qwindow_buffer_change_functions, buffer, window);
+
+ if (window_size_change && WINDOW_LIVE_P (window))
+ run_window_change_functions_1
+ (Qwindow_size_change_functions, buffer, window);
+
+ /* This window's selection has changed when it was
+ (de-)selected as its frame's or the globally selected
+ window. */
+ if (((frame_selected_change
+ && (EQ (window, old_selected_window)
+ || EQ (window, selected_window)))
+ || (frame_selected_window_change
+ && (EQ (window, FRAME_OLD_SELECTED_WINDOW (f))
+ || EQ (window, FRAME_SELECTED_WINDOW (f)))))
+ && WINDOW_LIVE_P (window))
+ run_window_change_functions_1
+ (Qwindow_selection_change_functions, buffer, window);
+
+ /* This window's state has changed when its buffer or size
+ changed or it was (de-)selected as its frame's or the
+ globally selected window. */
+ if ((window_buffer_change
+ || window_size_change
+ || ((frame_selected_change
+ && (EQ (window, old_selected_window)
+ || EQ (window, selected_window)))
+ || (frame_selected_window_change
+ && (EQ (window, FRAME_OLD_SELECTED_WINDOW (f))
+ || EQ (window, FRAME_SELECTED_WINDOW (f))))))
+ && WINDOW_LIVE_P (window))
+ run_window_change_functions_1
+ (Qwindow_state_change_functions, buffer, window);
}
- window_set_before_size_change_sizes (r);
-
- if (FRAME_HAS_MINIBUF_P (f) && !FRAME_MINIBUF_ONLY_P (f))
- /* Record size of FRAME's minibuffer window too. */
- window_set_before_size_change_sizes
- (XWINDOW (FRAME_MINIBUF_WINDOW (f)));
+ /* When the number of windows on a frame has decreased, at least
+ one window of that frame was deleted. In that case, we want
+ to run the default buffer and configuration change hooks. The
+ default size change hook is not necessarily run in that case,
+ but usually will be unless the deletion was "compensated" by
+ a reduction of the frame size or an increase of a minibuffer
+ window size. */
+ window_deleted = number_of_windows < f->number_of_windows;
+ /* A frame changed buffers when one of its windows has changed
+ its buffer or at least one window was deleted. */
+ if ((frame_buffer_change || window_deleted) && FRAME_LIVE_P (f))
+ run_window_change_functions_1
+ (Qwindow_buffer_change_functions, Qnil, frame);
+
+ /* A size change occurred when at least one of the frame's
+ windows has changed size. */
+ if (frame_size_change && FRAME_LIVE_P (f))
+ run_window_change_functions_1
+ (Qwindow_size_change_functions, Qnil, frame);
+
+ /* A frame has changed its window selection when its selected
+ window has changed or when it was (de-)selected. */
+ if ((frame_selected_change || frame_selected_window_change)
+ && FRAME_LIVE_P (f))
+ run_window_change_functions_1
+ (Qwindow_selection_change_functions, Qnil, frame);
+
+ /* A frame has changed state when a size or buffer change
+ occurred, its selected window has changed, when it was
+ (de-)selected or its window state change flag was set. */
+ if ((frame_selected_change || frame_selected_window_change
+ || frame_buffer_change || window_deleted
+ || frame_size_change || frame_window_state_change)
+ && FRAME_LIVE_P (f))
+ {
+ run_window_change_functions_1
+ (Qwindow_state_change_functions, Qnil, frame);
+ /* Make sure to run 'window-state-change-hook' later. */
+ run_window_state_change_hook = true;
+ /* Make sure to record changes for each live frame in
+ window_change_record later. */
+ window_change_record_frames = true;
+ }
- FRAME_WINDOW_CONFIGURATION_CHANGED (f) = false;
+ /* A frame's configuration changed when one of its windows has
+ changed buffer or size or at least one window was deleted. */
+ if ((frame_size_change || window_deleted) && FRAME_LIVE_P (f))
+ /* This will run any buffer local window configuration change
+ hook as well. */
+ run_window_configuration_change_hook (f);
}
-}
+ /* Run 'window-state-change-hook' if at least one frame has changed
+ state. */
+ if (run_window_state_change_hook && !NILP (Vwindow_state_change_hook))
+ safe_run_hooks (Qwindow_state_change_hook);
+
+ /* Record changes for all frames (if asked for), selected window and
+ frame. */
+ unbind_to (count, Qnil);
+}
/* Make WINDOW display BUFFER. RUN_HOOKS_P means it's allowed
to run hooks. See make_frame for a case where it's not allowed.
@@ -3499,8 +3947,8 @@ set_window_buffer (Lisp_Object window, Lisp_Object buffer,
b->display_error_modiff = 0;
/* Update time stamps of buffer display. */
- if (INTEGERP (BVAR (b, display_count)))
- bset_display_count (b, make_number (XINT (BVAR (b, display_count)) + 1));
+ if (FIXNUMP (BVAR (b, display_count)))
+ bset_display_count (b, make_fixnum (XFIXNUM (BVAR (b, display_count)) + 1));
bset_display_time (b, Fcurrent_time ());
w->window_end_pos = 0;
@@ -3518,7 +3966,7 @@ set_window_buffer (Lisp_Object window, Lisp_Object buffer,
set_marker_both (w->pointm, buffer, BUF_PT (b), BUF_PT_BYTE (b));
set_marker_both (w->old_pointm, buffer, BUF_PT (b), BUF_PT_BYTE (b));
set_marker_restricted (w->start,
- make_number (b->last_window_start),
+ make_fixnum (b->last_window_start),
buffer);
w->start_at_line_beg = false;
w->force_start = false;
@@ -3550,14 +3998,18 @@ set_window_buffer (Lisp_Object window, Lisp_Object buffer,
apply_window_adjustment (w);
}
- if (run_hooks_p)
- {
- if (!NILP (Vwindow_scroll_functions))
- run_hook_with_args_2 (Qwindow_scroll_functions, window,
- Fmarker_position (w->start));
- if (!samebuf)
- run_window_configuration_change_hook (XFRAME (WINDOW_FRAME (w)));
- }
+ if (run_hooks_p && !NILP (Vwindow_scroll_functions))
+ run_hook_with_args_2 (Qwindow_scroll_functions, window,
+ Fmarker_position (w->start));
+
+ /* Ensure that window change functions are run later if the buffer
+ differs and the window is neither a mini nor a pseudo window.
+
+ Note: Running window change functions for the minibuffer is noisy
+ and was generally suppressed in the past. Is there any reason we
+ should run them? */
+ if (!samebuf && !MINI_WINDOW_P (w) && !WINDOW_PSEUDO_P (w))
+ FRAME_WINDOW_CHANGE (XFRAME (w->frame)) = true;
unbind_to (count, Qnil);
}
@@ -3723,8 +4175,8 @@ temp_output_buffer_show (register Lisp_Object buf)
static struct window *
allocate_window (void)
{
- return ALLOCATE_ZEROED_PSEUDOVECTOR
- (struct window, current_matrix, PVEC_WINDOW);
+ return ALLOCATE_ZEROED_PSEUDOVECTOR (struct window, mode_line_help_echo,
+ PVEC_WINDOW);
}
/* Make new window, have it replace WINDOW in window-tree, and make
@@ -3774,9 +4226,9 @@ make_window (void)
Lisp data to nil, so do it only for slots which should not be nil. */
wset_normal_lines (w, make_float (1.0));
wset_normal_cols (w, make_float (1.0));
- wset_new_total (w, make_number (0));
- wset_new_normal (w, make_number (0));
- wset_new_pixel (w, make_number (0));
+ wset_new_total (w, make_fixnum (0));
+ wset_new_normal (w, make_fixnum (0));
+ wset_new_pixel (w, make_fixnum (0));
wset_start (w, Fmake_marker ());
wset_pointm (w, Fmake_marker ());
wset_old_pointm (w, Fmake_marker ());
@@ -3797,8 +4249,6 @@ make_window (void)
w->phys_cursor_width = -1;
#endif
w->sequence_number = ++sequence_number;
- w->pixel_width_before_size_change = 0;
- w->pixel_height_before_size_change = 0;
w->scroll_bar_width = -1;
w->scroll_bar_height = -1;
w->column_number_displayed = -1;
@@ -3825,14 +4275,14 @@ Note: This function does not operate on any child windows of WINDOW. */)
(Lisp_Object window, Lisp_Object size, Lisp_Object add)
{
struct window *w = decode_valid_window (window);
- EMACS_INT size_min = NILP (add) ? 0 : - XINT (w->new_pixel);
+ EMACS_INT size_min = NILP (add) ? 0 : - XFIXNUM (w->new_pixel);
EMACS_INT size_max = size_min + min (INT_MAX, MOST_POSITIVE_FIXNUM);
CHECK_RANGED_INTEGER (size, size_min, size_max);
if (NILP (add))
wset_new_pixel (w, size);
else
- wset_new_pixel (w, make_number (XINT (w->new_pixel) + XINT (size)));
+ wset_new_pixel (w, make_fixnum (XFIXNUM (w->new_pixel) + XFIXNUM (size)));
return w->new_pixel;
}
@@ -3854,11 +4304,11 @@ Note: This function does not operate on any child windows of WINDOW. */)
{
struct window *w = decode_valid_window (window);
- CHECK_NUMBER (size);
+ CHECK_FIXNUM (size);
if (NILP (add))
wset_new_total (w, size);
else
- wset_new_total (w, make_number (XINT (w->new_total) + XINT (size)));
+ wset_new_total (w, make_fixnum (XFIXNUM (w->new_total) + XFIXNUM (size)));
return w->new_total;
}
@@ -3900,7 +4350,7 @@ window_resize_check (struct window *w, bool horflag)
{
while (c)
{
- if (XINT (c->new_pixel) != XINT (w->new_pixel)
+ if (XFIXNUM (c->new_pixel) != XFIXNUM (w->new_pixel)
|| !window_resize_check (c, horflag))
return false;
@@ -3913,14 +4363,14 @@ window_resize_check (struct window *w, bool horflag)
/* The sum of the heights of the child windows of W must equal
W's height. */
{
- int remaining_pixels = XINT (w->new_pixel);
+ int remaining_pixels = XFIXNUM (w->new_pixel);
while (c)
{
if (!window_resize_check (c, horflag))
return false;
- remaining_pixels -= XINT (c->new_pixel);
+ remaining_pixels -= XFIXNUM (c->new_pixel);
if (remaining_pixels < 0)
return false;
c = NILP (c->next) ? 0 : XWINDOW (c->next);
@@ -3937,14 +4387,14 @@ window_resize_check (struct window *w, bool horflag)
/* The sum of the widths of the child windows of W must equal W's
width. */
{
- int remaining_pixels = XINT (w->new_pixel);
+ int remaining_pixels = XFIXNUM (w->new_pixel);
while (c)
{
if (!window_resize_check (c, horflag))
return false;
- remaining_pixels -= XINT (c->new_pixel);
+ remaining_pixels -= XFIXNUM (c->new_pixel);
if (remaining_pixels < 0)
return false;
c = NILP (c->next) ? 0 : XWINDOW (c->next);
@@ -3957,7 +4407,7 @@ window_resize_check (struct window *w, bool horflag)
{
while (c)
{
- if (XINT (c->new_pixel) != XINT (w->new_pixel)
+ if (XFIXNUM (c->new_pixel) != XFIXNUM (w->new_pixel)
|| !window_resize_check (c, horflag))
return false;
@@ -3971,7 +4421,7 @@ window_resize_check (struct window *w, bool horflag)
/* A leaf window. Make sure it's not too small. The following
hardcodes the values of `window-safe-min-width' (2) and
`window-safe-min-height' (1) which are defined in window.el. */
- return (XINT (w->new_pixel) >= (horflag
+ return (XFIXNUM (w->new_pixel) >= (horflag
? (2 * FRAME_COLUMN_WIDTH (f))
: FRAME_LINE_HEIGHT (f)));
}
@@ -3997,7 +4447,7 @@ window_resize_apply (struct window *w, bool horflag)
parent window has been set *before*. */
if (horflag)
{
- w->pixel_width = XFASTINT (w->new_pixel);
+ w->pixel_width = XFIXNAT (w->new_pixel);
w->total_cols = w->pixel_width / unit;
if (NUMBERP (w->new_normal))
wset_normal_cols (w, w->new_normal);
@@ -4006,7 +4456,7 @@ window_resize_apply (struct window *w, bool horflag)
}
else
{
- w->pixel_height = XFASTINT (w->new_pixel);
+ w->pixel_height = XFIXNAT (w->new_pixel);
w->total_lines = w->pixel_height / unit;
if (NUMBERP (w->new_normal))
wset_normal_lines (w, w->new_normal);
@@ -4064,6 +4514,9 @@ window_resize_apply (struct window *w, bool horflag)
else
/* Bug#15957. */
w->window_end_valid = false;
+
+ if (!WINDOW_PSEUDO_P (w))
+ FRAME_WINDOW_CHANGE (WINDOW_XFRAME (w)) = true;
}
@@ -4081,12 +4534,12 @@ window_resize_apply_total (struct window *w, bool horflag)
parent window has been set *before*. */
if (horflag)
{
- w->total_cols = XFASTINT (w->new_total);
+ w->total_cols = XFIXNAT (w->new_total);
edge = w->left_col;
}
else
{
- w->total_lines = XFASTINT (w->new_total);
+ w->total_lines = XFIXNAT (w->new_total);
edge = w->top_line;
}
@@ -4154,7 +4607,7 @@ be applied on the Elisp level. */)
bool horflag = !NILP (horizontal);
if (!window_resize_check (r, horflag)
- || (XINT (r->new_pixel)
+ || (XFIXNUM (r->new_pixel)
!= (horflag ? r->pixel_width : r->pixel_height)))
return Qnil;
@@ -4198,10 +4651,10 @@ values. */)
if (NILP (horizontal))
{
m->top_line = r->top_line + r->total_lines;
- m->total_lines = XFASTINT (m->new_total);
+ m->total_lines = XFIXNAT (m->new_total);
}
else
- m->total_cols = XFASTINT (m->new_total);
+ m->total_cols = XFIXNAT (m->new_total);
}
unblock_input ();
@@ -4261,16 +4714,26 @@ resize_frame_windows (struct frame *f, int size, bool horflag, bool pixelwise)
/* For a leaf root window just set the size. */
if (horflag)
{
+ bool changed = r->pixel_width != new_pixel_size;
+
r->total_cols = new_size;
r->pixel_width = new_pixel_size;
+
+ if (changed && !WINDOW_PSEUDO_P (r))
+ FRAME_WINDOW_CHANGE (f) = true;
}
else
{
+ bool changed = r->pixel_height != new_pixel_size;
+
r->top_line = FRAME_TOP_MARGIN (f);
r->pixel_top = FRAME_TOP_MARGIN_HEIGHT (f);
r->total_lines = new_size;
r->pixel_height = new_pixel_size;
+
+ if (changed && !WINDOW_PSEUDO_P (r))
+ FRAME_WINDOW_CHANGE (f) = true;
}
else
{
@@ -4291,7 +4754,7 @@ resize_frame_windows (struct frame *f, int size, bool horflag, bool pixelwise)
resize_root_window (root, delta, horflag ? Qt : Qnil, Qnil,
pixelwise ? Qt : Qnil);
if (window_resize_check (r, horflag)
- && new_pixel_size == XINT (r->new_pixel))
+ && new_pixel_size == XFIXNUM (r->new_pixel))
{
window_resize_apply (r, horflag);
window_pixel_to_total (r->frame, horflag ? Qt : Qnil);
@@ -4302,7 +4765,7 @@ resize_frame_windows (struct frame *f, int size, bool horflag, bool pixelwise)
resize_root_window (root, delta, horflag ? Qt : Qnil, Qt,
pixelwise ? Qt : Qnil);
if (window_resize_check (r, horflag)
- && new_pixel_size == XINT (r->new_pixel))
+ && new_pixel_size == XFIXNUM (r->new_pixel))
{
window_resize_apply (r, horflag);
window_pixel_to_total (r->frame, horflag ? Qt : Qnil);
@@ -4374,9 +4837,9 @@ set correctly. See the code of `split-window' for how this is done. */)
frame = WINDOW_FRAME (o);
f = XFRAME (frame);
- CHECK_NUMBER (pixel_size);
+ CHECK_FIXNUM (pixel_size);
EMACS_INT total_size
- = XINT (pixel_size) / (horflag
+ = XFIXNUM (pixel_size) / (horflag
? FRAME_COLUMN_WIDTH (f)
: FRAME_LINE_HEIGHT (f));
@@ -4411,19 +4874,19 @@ set correctly. See the code of `split-window' for how this is done. */)
p = XWINDOW (o->parent);
/* Temporarily pretend we split the parent window. */
wset_new_pixel
- (p, make_number ((horflag ? p->pixel_width : p->pixel_height)
- - XINT (pixel_size)));
+ (p, make_fixnum ((horflag ? p->pixel_width : p->pixel_height)
+ - XFIXNUM (pixel_size)));
if (!window_resize_check (p, horflag))
error ("Window sizes don't fit");
else
/* Undo the temporary pretension. */
- wset_new_pixel (p, make_number (horflag ? p->pixel_width : p->pixel_height));
+ wset_new_pixel (p, make_fixnum (horflag ? p->pixel_width : p->pixel_height));
}
else
{
if (!window_resize_check (o, horflag))
error ("Resizing old window failed");
- else if (XINT (pixel_size) + XINT (o->new_pixel)
+ else if (XFIXNUM (pixel_size) + XFIXNUM (o->new_pixel)
!= (horflag ? o->pixel_width : o->pixel_height))
error ("Sum of sizes of old and new window don't fit");
}
@@ -4445,9 +4908,9 @@ set correctly. See the code of `split-window' for how this is done. */)
wset_combination_limit (p, Qt);
/* These get applied below. */
wset_new_pixel
- (p, make_number (horflag ? o->pixel_width : o->pixel_height));
+ (p, make_fixnum (horflag ? o->pixel_width : o->pixel_height));
wset_new_total
- (p, make_number (horflag ? o->total_cols : o->total_lines));
+ (p, make_fixnum (horflag ? o->total_cols : o->total_lines));
wset_new_normal (p, new_normal);
}
else
@@ -4516,10 +4979,10 @@ set correctly. See the code of `split-window' for how this is done. */)
while (c)
{
if (c != n)
- sum = sum + XINT (c->new_total);
+ sum = sum + XFIXNUM (c->new_total);
c = NILP (c->next) ? 0 : XWINDOW (c->next);
}
- wset_new_total (n, make_number ((horflag
+ wset_new_total (n, make_fixnum ((horflag
? p->total_cols
: p->total_lines)
- sum));
@@ -4528,17 +4991,11 @@ set correctly. See the code of `split-window' for how this is done. */)
block_input ();
window_resize_apply (p, horflag);
adjust_frame_glyphs (f);
- /* Set buffer of NEW to buffer of reference window. Don't run
- any hooks. */
- set_window_buffer (new, r->contents, false, true);
+ /* Set buffer of NEW to buffer of reference window. */
+ set_window_buffer (new, r->contents, true, true);
+ FRAME_WINDOW_CHANGE (f) = true;
unblock_input ();
- /* Maybe we should run the scroll functions in Elisp (which already
- runs the configuration change hook). */
- if (! NILP (Vwindow_scroll_functions))
- run_hook_with_args_2 (Qwindow_scroll_functions, new,
- Fmarker_position (n->start));
- /* Return NEW. */
return new;
}
@@ -4601,7 +5058,7 @@ Signal an error when WINDOW is the only window on its frame. */)
}
if (window_resize_check (r, horflag)
- && (XINT (r->new_pixel)
+ && (XFIXNUM (r->new_pixel)
== (horflag ? r->pixel_width : r->pixel_height)))
/* We can delete WINDOW now. */
{
@@ -4689,6 +5146,8 @@ Signal an error when WINDOW is the only window on its frame. */)
}
else
unblock_input ();
+
+ FRAME_WINDOW_CHANGE (f) = true;
}
else
/* We failed: Relink WINDOW into window tree. */
@@ -4714,118 +5173,111 @@ Signal an error when WINDOW is the only window on its frame. */)
Resizing Mini-Windows
***********************************************************************/
-/* Grow mini-window W by DELTA lines, DELTA >= 0, or as much as we
- can. */
+/**
+ * resize_mini_window_apply:
+ *
+ * Assign new window sizes after resizing a mini window W by DELTA
+ * pixels. No error checking performed.
+ */
+static void
+resize_mini_window_apply (struct window *w, int delta)
+{
+ struct frame *f = XFRAME (w->frame);
+ Lisp_Object root = FRAME_ROOT_WINDOW (f);
+ struct window *r = XWINDOW (root);
+
+ block_input ();
+ w->pixel_height = w->pixel_height + delta;
+ w->total_lines = w->pixel_height / FRAME_LINE_HEIGHT (f);
+
+ window_resize_apply (r, false);
+
+ w->pixel_top = r->pixel_top + r->pixel_height;
+ w->top_line = r->top_line + r->total_lines;
+
+ /* Enforce full redisplay of the frame. */
+ /* FIXME: Shouldn't some of the caller do it? */
+ fset_redisplay (f);
+ adjust_frame_glyphs (f);
+ unblock_input ();
+}
+
+/**
+ * grow_mini_window:
+ *
+ * Grow mini-window W by DELTA pixels. If DELTA is negative, this may
+ * shrink the minibuffer window to the minimum height to display one
+ * line of text.
+ */
void
-grow_mini_window (struct window *w, int delta, bool pixelwise)
+grow_mini_window (struct window *w, int delta)
{
struct frame *f = XFRAME (w->frame);
- struct window *r;
- Lisp_Object root, height;
- int line_height, pixel_height;
+ int old_height = WINDOW_PIXEL_HEIGHT (w);
+ int min_height = FRAME_LINE_HEIGHT (f);
eassert (MINI_WINDOW_P (w));
- eassert (delta >= 0);
- if (delta > 0)
+ if (old_height + delta < min_height)
+ /* Never shrink mini-window to less than its minimum
+ height. */
+ delta = old_height > min_height ? min_height - old_height : 0;
+
+ if (delta != 0)
{
- root = FRAME_ROOT_WINDOW (f);
- r = XWINDOW (root);
- height = call3 (Qwindow__resize_root_window_vertically,
- root, make_number (- delta), pixelwise ? Qt : Qnil);
- if (INTEGERP (height) && window_resize_check (r, false))
- {
- block_input ();
- window_resize_apply (r, false);
+ Lisp_Object root = FRAME_ROOT_WINDOW (f);
+ struct window *r = XWINDOW (root);
+ Lisp_Object grow;
- if (pixelwise)
- {
- pixel_height = min (-XINT (height), INT_MAX - w->pixel_height);
- line_height = pixel_height / FRAME_LINE_HEIGHT (f);
- }
- else
- {
- line_height = min (-XINT (height),
- ((INT_MAX - w->pixel_height)
- / FRAME_LINE_HEIGHT (f)));
- pixel_height = line_height * FRAME_LINE_HEIGHT (f);
- }
-
- /* Grow the mini-window. */
- w->pixel_top = r->pixel_top + r->pixel_height;
- w->top_line = r->top_line + r->total_lines;
- /* Make sure the mini-window has always at least one line. */
- w->pixel_height = max (w->pixel_height + pixel_height,
- FRAME_LINE_HEIGHT (f));
- w->total_lines = max (w->total_lines + line_height, 1);
-
- /* Enforce full redisplay of the frame. */
- /* FIXME: Shouldn't window--resize-root-window-vertically do it? */
- fset_redisplay (f);
- adjust_frame_glyphs (f);
- unblock_input ();
- }
- else
- error ("Failed to grow minibuffer window");
+ FRAME_WINDOWS_FROZEN (f) = true;
+ grow = call3 (Qwindow__resize_root_window_vertically,
+ root, make_fixnum (- delta), Qt);
+ if (FIXNUMP (grow) && window_resize_check (r, false))
+ resize_mini_window_apply (w, -XFIXNUM (grow));
}
}
-/* Shrink mini-window W to one line. */
+/**
+ * shrink_mini_window:
+ *
+ * Shrink mini-window W to the minimum height needed to display one
+ * line of text.
+ */
void
-shrink_mini_window (struct window *w, bool pixelwise)
+shrink_mini_window (struct window *w)
{
struct frame *f = XFRAME (w->frame);
- struct window *r;
- Lisp_Object root, delta;
- EMACS_INT height, unit;
+ int delta = WINDOW_PIXEL_HEIGHT (w) - FRAME_LINE_HEIGHT (f);
eassert (MINI_WINDOW_P (w));
- height = pixelwise ? w->pixel_height : w->total_lines;
- unit = pixelwise ? FRAME_LINE_HEIGHT (f) : 1;
- if (height > unit)
+ if (delta > 0)
{
- root = FRAME_ROOT_WINDOW (f);
- r = XWINDOW (root);
- delta = call3 (Qwindow__resize_root_window_vertically,
- root, make_number (height - unit),
- pixelwise ? Qt : Qnil);
- if (INTEGERP (delta) && window_resize_check (r, false))
- {
- block_input ();
- window_resize_apply (r, false);
-
- /* Shrink the mini-window. */
- w->top_line = r->top_line + r->total_lines;
- w->total_lines = 1;
- w->pixel_top = r->pixel_top + r->pixel_height;
- w->pixel_height = FRAME_LINE_HEIGHT (f);
- /* Enforce full redisplay of the frame. */
- /* FIXME: Shouldn't window--resize-root-window-vertically do it? */
- fset_redisplay (f);
- adjust_frame_glyphs (f);
- unblock_input ();
- }
- /* If the above failed for whatever strange reason we must make a
- one window frame here. The same routine will be needed when
- shrinking the frame (and probably when making the initial
- *scratch* window). For the moment leave things as they are. */
- else
- error ("Failed to shrink minibuffer window");
+ Lisp_Object root = FRAME_ROOT_WINDOW (f);
+ struct window *r = XWINDOW (root);
+ Lisp_Object grow;
+
+ FRAME_WINDOWS_FROZEN (f) = false;
+ grow = call3 (Qwindow__resize_root_window_vertically,
+ root, make_fixnum (delta), Qt);
+
+ if (FIXNUMP (grow) && window_resize_check (r, false))
+ resize_mini_window_apply (w, -XFIXNUM (grow));
}
}
-DEFUN ("resize-mini-window-internal", Fresize_mini_window_internal, Sresize_mini_window_internal, 1, 1, 0,
- doc: /* Resize minibuffer window WINDOW. */)
+DEFUN ("resize-mini-window-internal", Fresize_mini_window_internal,
+ Sresize_mini_window_internal, 1, 1, 0,
+ doc: /* Resize mini window WINDOW. */)
(Lisp_Object window)
{
struct window *w = XWINDOW (window);
struct window *r;
struct frame *f;
- int height;
+ int old_height, delta;
- CHECK_WINDOW (window);
+ CHECK_LIVE_WINDOW (window);
f = XFRAME (w->frame);
if (!EQ (FRAME_MINIBUF_WINDOW (XFRAME (w->frame)), window))
@@ -4834,26 +5286,18 @@ DEFUN ("resize-mini-window-internal", Fresize_mini_window_internal, Sresize_mini
error ("Cannot resize a minibuffer-only frame");
r = XWINDOW (FRAME_ROOT_WINDOW (f));
- height = r->pixel_height + w->pixel_height;
+ old_height = r->pixel_height + w->pixel_height;
+ delta = XFIXNUM (w->new_pixel) - w->pixel_height;
if (window_resize_check (r, false)
- && XINT (w->new_pixel) > 0
- && height == XINT (r->new_pixel) + XINT (w->new_pixel))
+ && XFIXNUM (w->new_pixel) > 0
+ && old_height == XFIXNUM (r->new_pixel) + XFIXNUM (w->new_pixel))
{
- block_input ();
- window_resize_apply (r, false);
-
- w->pixel_height = XFASTINT (w->new_pixel);
- w->total_lines = w->pixel_height / FRAME_LINE_HEIGHT (f);
- w->pixel_top = r->pixel_top + r->pixel_height;
- w->top_line = r->top_line + r->total_lines;
+ resize_mini_window_apply (w, delta);
- fset_redisplay (f);
- adjust_frame_glyphs (f);
- unblock_input ();
return Qt;
}
else
- error ("Failed to resize minibuffer window");
+ error ("Cannot resize mini window");
}
/* Mark window cursors off for all windows in the window tree rooted
@@ -5025,6 +5469,11 @@ window_scroll_margin (struct window *window, enum margin_unit unit)
return 0;
}
+static int
+sanitize_next_screen_context_lines (void)
+{
+ return clip_to_bounds (0, next_screen_context_lines, 1000000);
+}
/* Implementation of window_scroll that works based on pixel line
heights. See the comment of window_scroll for parameter
@@ -5095,9 +5544,11 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror)
height. This is important to ensure we get back to the
same position when scrolling up, then down. */
if (whole)
- dy = max ((window_box_height (w) / dy
- - next_screen_context_lines) * dy,
- dy);
+ {
+ int ht = window_box_height (w);
+ int nscls = sanitize_next_screen_context_lines ();
+ dy = max (dy, (ht / dy - nscls) * dy);
+ }
dy *= n;
if (n < 0)
@@ -5106,7 +5557,7 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror)
if (w->vscroll < 0 && rtop > 0)
{
px = max (0, -w->vscroll - min (rtop, -dy));
- Fset_window_vscroll (window, make_number (px), Qt);
+ Fset_window_vscroll (window, make_fixnum (px), Qt);
return;
}
}
@@ -5116,7 +5567,7 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror)
if (rbot > 0 && (w->vscroll < 0 || vpos == 0))
{
px = max (0, -w->vscroll + min (rbot, dy));
- Fset_window_vscroll (window, make_number (px), Qt);
+ Fset_window_vscroll (window, make_fixnum (px), Qt);
return;
}
@@ -5125,14 +5576,14 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror)
{
ptrdiff_t spos;
- Fset_window_vscroll (window, make_number (0), Qt);
+ Fset_window_vscroll (window, make_fixnum (0), Qt);
/* If there are other text lines above the current row,
move window start to current row. Else to next row. */
if (rbot > 0)
- spos = XINT (Fline_beginning_position (Qnil));
+ spos = XFIXNUM (Fline_beginning_position (Qnil));
else
- spos = min (XINT (Fline_end_position (Qnil)) + 1, ZV);
- set_marker_restricted (w->start, make_number (spos),
+ spos = min (XFIXNUM (Fline_end_position (Qnil)) + 1, ZV);
+ set_marker_restricted (w->start, make_fixnum (spos),
w->contents);
w->start_at_line_beg = true;
wset_update_mode_line (w);
@@ -5144,7 +5595,7 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror)
}
}
/* Cancel previous vscroll. */
- Fset_window_vscroll (window, make_number (0), Qt);
+ Fset_window_vscroll (window, make_fixnum (0), Qt);
}
itdata = bidi_shelve_cache ();
@@ -5178,13 +5629,14 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror)
{
ptrdiff_t start_pos = IT_CHARPOS (it);
int dy = frame_line_height;
+ int ht = window_box_height (w);
+ int nscls = sanitize_next_screen_context_lines ();
/* In the below we divide the window box height by the frame's
line height to make the result predictable when the window
box is not an integral multiple of the line height. This is
important to ensure we get back to the same position when
scrolling up, then down. */
- dy = max ((window_box_height (w) / dy - next_screen_context_lines) * dy,
- dy) * n;
+ dy = n * max (dy, (ht / dy - nscls) * dy);
/* Note that move_it_vertically always moves the iterator to the
start of a line. So, if the last line doesn't have a newline,
@@ -5449,7 +5901,7 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror)
if (adjust_old_pointm)
Fset_marker (w->old_pointm,
((w == XWINDOW (selected_window))
- ? make_number (BUF_PT (XBUFFER (w->contents)))
+ ? make_fixnum (BUF_PT (XBUFFER (w->contents)))
: Fmarker_position (w->pointm)),
w->contents);
}
@@ -5482,7 +5934,10 @@ window_scroll_line_based (Lisp_Object window, int n, bool whole, bool noerror)
/* If scrolling screen-fulls, compute the number of lines to
scroll from the window's height. */
if (whole)
- n *= max (1, ht - next_screen_context_lines);
+ {
+ int nscls = sanitize_next_screen_context_lines ();
+ n *= max (1, ht - nscls);
+ }
if (!NILP (Vscroll_preserve_screen_position))
{
@@ -5498,8 +5953,8 @@ window_scroll_line_based (Lisp_Object window, int n, bool whole, bool noerror)
window_scroll_preserve_hpos = posit.hpos + w->hscroll;
}
- original_pos = Fcons (make_number (window_scroll_preserve_hpos),
- make_number (window_scroll_preserve_vpos));
+ original_pos = Fcons (make_fixnum (window_scroll_preserve_hpos),
+ make_fixnum (window_scroll_preserve_vpos));
}
XSETFASTINT (tem, PT);
@@ -5507,14 +5962,14 @@ window_scroll_line_based (Lisp_Object window, int n, bool whole, bool noerror)
if (NILP (tem))
{
- Fvertical_motion (make_number (- (ht / 2)), window, Qnil);
+ Fvertical_motion (make_fixnum (- (ht / 2)), window, Qnil);
startpos = PT;
startbyte = PT_BYTE;
}
SET_PT_BOTH (startpos, startbyte);
lose = n < 0 && PT == BEGV;
- Fvertical_motion (make_number (n), window, Qnil);
+ Fvertical_motion (make_fixnum (n), window, Qnil);
pos = PT;
pos_byte = PT_BYTE;
bolp = Fbolp ();
@@ -5556,7 +6011,7 @@ window_scroll_line_based (Lisp_Object window, int n, bool whole, bool noerror)
if (this_scroll_margin > 0)
{
SET_PT_BOTH (pos, pos_byte);
- Fvertical_motion (make_number (this_scroll_margin), window, Qnil);
+ Fvertical_motion (make_fixnum (this_scroll_margin), window, Qnil);
top_margin = PT;
}
else
@@ -5575,8 +6030,8 @@ window_scroll_line_based (Lisp_Object window, int n, bool whole, bool noerror)
else if (window_scroll_preserve_vpos
>= w->total_lines - this_scroll_margin)
nlines = w->total_lines - this_scroll_margin - 1;
- Fvertical_motion (Fcons (make_number (window_scroll_preserve_hpos),
- make_number (nlines)), window, Qnil);
+ Fvertical_motion (Fcons (make_fixnum (window_scroll_preserve_hpos),
+ make_fixnum (nlines)), window, Qnil);
}
else
SET_PT (top_margin);
@@ -5588,9 +6043,9 @@ window_scroll_line_based (Lisp_Object window, int n, bool whole, bool noerror)
/* If we scrolled backward, put point near the end of the window
but not within the scroll margin. */
SET_PT_BOTH (pos, pos_byte);
- tem = Fvertical_motion (make_number (ht - this_scroll_margin), window,
+ tem = Fvertical_motion (make_fixnum (ht - this_scroll_margin), window,
Qnil);
- if (XFASTINT (tem) == ht - this_scroll_margin)
+ if (XFIXNAT (tem) == ht - this_scroll_margin)
bottom_margin = PT;
else
bottom_margin = PT + 1;
@@ -5610,11 +6065,11 @@ window_scroll_line_based (Lisp_Object window, int n, bool whole, bool noerror)
else if (window_scroll_preserve_vpos
>= ht - this_scroll_margin)
nlines = ht - this_scroll_margin - 1;
- Fvertical_motion (Fcons (make_number (window_scroll_preserve_hpos),
- make_number (nlines)), window, Qnil);
+ Fvertical_motion (Fcons (make_fixnum (window_scroll_preserve_hpos),
+ make_fixnum (nlines)), window, Qnil);
}
else
- Fvertical_motion (make_number (-1), window, Qnil);
+ Fvertical_motion (make_fixnum (-1), window, Qnil);
}
}
}
@@ -5629,41 +6084,65 @@ window_scroll_line_based (Lisp_Object window, int n, bool whole, bool noerror)
if (adjust_old_pointm)
Fset_marker (w->old_pointm,
((w == XWINDOW (selected_window))
- ? make_number (BUF_PT (XBUFFER (w->contents)))
+ ? make_fixnum (BUF_PT (XBUFFER (w->contents)))
: Fmarker_position (w->pointm)),
w->contents);
}
-/* Scroll selected_window up or down. If N is nil, scroll a
+/* Scroll WINDOW up or down. If N is nil, scroll upward by a
screen-full which is defined as the height of the window minus
- next_screen_context_lines. If N is the symbol `-', scroll.
- DIRECTION may be 1 meaning to scroll down, or -1 meaning to scroll
- up. This is the guts of Fscroll_up and Fscroll_down. */
+ next_screen_context_lines. If N is the symbol `-', scroll downward
+ by a screen-full. DIRECTION may be 1 meaning to scroll down, or -1
+ meaning to scroll up. */
static void
-scroll_command (Lisp_Object n, int direction)
+scroll_command (Lisp_Object window, Lisp_Object n, int direction)
{
+ struct window *w;
+ bool other_window;
ptrdiff_t count = SPECPDL_INDEX ();
eassert (eabs (direction) == 1);
- /* If selected window's buffer isn't current, make it current for
- the moment. But don't screw up if window_scroll gets an error. */
- if (XBUFFER (XWINDOW (selected_window)->contents) != current_buffer)
+ w = XWINDOW (window);
+ other_window = ! EQ (window, selected_window);
+
+ /* If given window's buffer isn't current, make it current for the
+ moment. If the window's buffer is the same, but it is not the
+ selected window, we need to save-excursion to avoid affecting
+ point in the selected window (which would cause the selected
+ window to scroll). Don't screw up if window_scroll gets an
+ error. */
+ if (other_window || XBUFFER (w->contents) != current_buffer)
+ {
+ record_unwind_protect_excursion ();
+ if (XBUFFER (w->contents) != current_buffer)
+ Fset_buffer (w->contents);
+ }
+
+ if (other_window)
{
- record_unwind_protect (save_excursion_restore, save_excursion_save ());
- Fset_buffer (XWINDOW (selected_window)->contents);
+ SET_PT_BOTH (marker_position (w->pointm),
+ marker_byte_position (w->pointm));
+ SET_PT_BOTH (marker_position (w->old_pointm),
+ marker_byte_position (w->old_pointm));
}
if (NILP (n))
- window_scroll (selected_window, direction, true, false);
+ window_scroll (window, direction, true, false);
else if (EQ (n, Qminus))
- window_scroll (selected_window, -direction, true, false);
+ window_scroll (window, -direction, true, false);
else
{
n = Fprefix_numeric_value (n);
- window_scroll (selected_window, XINT (n) * direction, false, false);
+ window_scroll (window, XFIXNUM (n) * direction, false, false);
+ }
+
+ if (other_window)
+ {
+ set_marker_both (w->pointm, Qnil, PT, PT_BYTE);
+ set_marker_both (w->old_pointm, Qnil, PT, PT_BYTE);
}
unbind_to (count, Qnil);
@@ -5678,7 +6157,7 @@ If ARG is the atom `-', scroll downward by nearly full screen.
When calling from a program, supply as argument a number, nil, or `-'. */)
(Lisp_Object arg)
{
- scroll_command (arg, 1);
+ scroll_command (selected_window, arg, 1);
return Qnil;
}
@@ -5691,17 +6170,18 @@ If ARG is the atom `-', scroll upward by nearly full screen.
When calling from a program, supply as argument a number, nil, or `-'. */)
(Lisp_Object arg)
{
- scroll_command (arg, -1);
+ scroll_command (selected_window, arg, -1);
return Qnil;
}
DEFUN ("other-window-for-scrolling", Fother_window_for_scrolling, Sother_window_for_scrolling, 0, 0, 0,
doc: /* Return the other window for \"other window scroll\" commands.
-If `other-window-scroll-buffer' is non-nil, a window
-showing that buffer is used.
If in the minibuffer, `minibuffer-scroll-window' if non-nil
-specifies the window. This takes precedence over
-`other-window-scroll-buffer'. */)
+specifies the window.
+Otherwise, if `other-window-scroll-buffer' is non-nil, a window
+showing that buffer is used, popping the buffer up if necessary.
+Finally, look for a neighboring window on the selected frame,
+followed by all visible frames on the current terminal. */)
(void)
{
Lisp_Object window;
@@ -5710,8 +6190,7 @@ specifies the window. This takes precedence over
&& !NILP (Vminibuf_scroll_window))
window = Vminibuf_scroll_window;
/* If buffer is specified and live, scroll that buffer. */
- else if (!NILP (Vother_window_scroll_buffer)
- && BUFFERP (Vother_window_scroll_buffer)
+ else if (BUFFERP (Vother_window_scroll_buffer)
&& BUFFER_LIVE_P (XBUFFER (Vother_window_scroll_buffer)))
{
window = Fget_buffer_window (Vother_window_scroll_buffer, Qnil);
@@ -5726,11 +6205,8 @@ specifies the window. This takes precedence over
if (EQ (window, selected_window))
/* That didn't get us anywhere; look for a window on another
- visible frame. */
- do
- window = Fnext_window (window, Qnil, Qt);
- while (! FRAME_VISIBLE_P (XFRAME (WINDOW_FRAME (XWINDOW (window))))
- && ! EQ (window, selected_window));
+ visible frame on the current terminal. */
+ window = Fnext_window (window, Qnil, Qvisible);
}
CHECK_LIVE_WINDOW (window);
@@ -5744,49 +6220,30 @@ specifies the window. This takes precedence over
DEFUN ("scroll-other-window", Fscroll_other_window, Sscroll_other_window, 0, 1, "P",
doc: /* Scroll next window upward ARG lines; or near full screen if no ARG.
A near full screen is `next-screen-context-lines' less than a full screen.
-The next window is the one below the current one; or the one at the top
-if the current one is at the bottom. Negative ARG means scroll downward.
-If ARG is the atom `-', scroll downward by nearly full screen.
-When calling from a program, supply as argument a number, nil, or `-'.
-
-If `other-window-scroll-buffer' is non-nil, scroll the window
-showing that buffer, popping the buffer up if necessary.
-If in the minibuffer, `minibuffer-scroll-window' if non-nil
-specifies the window to scroll. This takes precedence over
-`other-window-scroll-buffer'. */)
+Negative ARG means scroll downward. If ARG is the atom `-', scroll
+downward by nearly full screen. When calling from a program, supply
+as argument a number, nil, or `-'.
+
+The next window is usually the one below the current one;
+or the one at the top if the current one is at the bottom.
+It is determined by the function `other-window-for-scrolling',
+which see. */)
(Lisp_Object arg)
{
- Lisp_Object window;
- struct window *w;
ptrdiff_t count = SPECPDL_INDEX ();
+ scroll_command (Fother_window_for_scrolling (), arg, 1);
+ return unbind_to (count, Qnil);
+}
- window = Fother_window_for_scrolling ();
- w = XWINDOW (window);
-
- /* Don't screw up if window_scroll gets an error. */
- record_unwind_protect (save_excursion_restore, save_excursion_save ());
-
- Fset_buffer (w->contents);
- SET_PT_BOTH (marker_position (w->pointm), marker_byte_position (w->pointm));
- SET_PT_BOTH (marker_position (w->old_pointm), marker_byte_position (w->old_pointm));
-
- if (NILP (arg))
- window_scroll (window, 1, true, true);
- else if (EQ (arg, Qminus))
- window_scroll (window, -1, true, true);
- else
- {
- if (CONSP (arg))
- arg = XCAR (arg);
- CHECK_NUMBER (arg);
- window_scroll (window, XINT (arg), false, true);
- }
-
- set_marker_both (w->pointm, Qnil, PT, PT_BYTE);
- set_marker_both (w->old_pointm, Qnil, PT, PT_BYTE);
- unbind_to (count, Qnil);
-
- return Qnil;
+DEFUN ("scroll-other-window-down", Fscroll_other_window_down,
+ Sscroll_other_window_down, 0, 1, "P",
+ doc: /* Scroll next window downward ARG lines; or near full screen if no ARG.
+For more details, see the documentation for `scroll-other-window'. */)
+ (Lisp_Object arg)
+{
+ ptrdiff_t count = SPECPDL_INDEX ();
+ scroll_command (Fother_window_for_scrolling (), arg, -1);
+ return unbind_to (count, Qnil);
}
DEFUN ("scroll-left", Fscroll_left, Sscroll_left, 0, 2, "^P\np",
@@ -5803,7 +6260,7 @@ by this function. This happens in an interactive call. */)
struct window *w = XWINDOW (selected_window);
EMACS_INT requested_arg = (NILP (arg)
? window_body_width (w, 0) - 2
- : XINT (Fprefix_numeric_value (arg)));
+ : XFIXNUM (Fprefix_numeric_value (arg)));
Lisp_Object result = set_window_hscroll (w, w->hscroll + requested_arg);
if (!NILP (set_minimum))
@@ -5828,7 +6285,7 @@ by this function. This happens in an interactive call. */)
struct window *w = XWINDOW (selected_window);
EMACS_INT requested_arg = (NILP (arg)
? window_body_width (w, 0) - 2
- : XINT (Fprefix_numeric_value (arg)));
+ : XFIXNUM (Fprefix_numeric_value (arg)));
Lisp_Object result = set_window_hscroll (w, w->hscroll - requested_arg);
if (!NILP (set_minimum))
@@ -5900,22 +6357,23 @@ displayed_window_lines (struct window *w)
}
-DEFUN ("recenter", Frecenter, Srecenter, 0, 1, "P",
+DEFUN ("recenter", Frecenter, Srecenter, 0, 2, "P\np",
doc: /* Center point in selected window and maybe redisplay frame.
With a numeric prefix argument ARG, recenter putting point on screen line ARG
relative to the selected window. If ARG is negative, it counts up from the
bottom of the window. (ARG should be less than the height of the window.)
-If ARG is omitted or nil, then recenter with point on the middle line of
-the selected window; if the variable `recenter-redisplay' is non-nil,
-also erase the entire frame and redraw it (when `auto-resize-tool-bars'
-is set to `grow-only', this resets the tool-bar's height to the minimum
-height needed); if `recenter-redisplay' has the special value `tty',
-then only tty frames are redrawn.
+If ARG is omitted or nil, then recenter with point on the middle line
+of the selected window; if REDISPLAY & `recenter-redisplay' are
+non-nil, also erase the entire frame and redraw it (when
+`auto-resize-tool-bars' is set to `grow-only', this resets the
+tool-bar's height to the minimum height needed); if
+`recenter-redisplay' has the special value `tty', then only tty frames
+are redrawn. Interactively, REDISPLAY is always non-nil.
Just C-u as prefix means put point in the center of the window
and redisplay normally--don't erase and redraw the frame. */)
- (register Lisp_Object arg)
+ (Lisp_Object arg, Lisp_Object redisplay)
{
struct window *w = XWINDOW (selected_window);
struct buffer *buf = XBUFFER (w->contents);
@@ -5935,7 +6393,8 @@ and redisplay normally--don't erase and redraw the frame. */)
if (NILP (arg))
{
- if (!NILP (Vrecenter_redisplay)
+ if (!NILP (redisplay)
+ && !NILP (Vrecenter_redisplay)
&& (!EQ (Vrecenter_redisplay, Qtty)
|| !NILP (Ftty_type (selected_frame))))
{
@@ -5944,7 +6403,7 @@ and redisplay normally--don't erase and redraw the frame. */)
/* Invalidate pixel data calculated for all compositions. */
for (i = 0; i < n_compositions; i++)
composition_table[i]->font = NULL;
-#if defined (HAVE_WINDOW_SYSTEM) && ! defined (USE_GTK) && ! defined (HAVE_NS)
+#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_TOOL_BAR)
WINDOW_XFRAME (w)->minimize_tool_bar_window_p = 1;
#endif
Fredraw_frame (WINDOW_FRAME (w));
@@ -5958,8 +6417,8 @@ and redisplay normally--don't erase and redraw the frame. */)
else
{
arg = Fprefix_numeric_value (arg);
- CHECK_NUMBER (arg);
- iarg = XINT (arg);
+ CHECK_FIXNUM (arg);
+ iarg = XFIXNUM (arg);
}
/* Do this after making BUF current
@@ -6136,10 +6595,10 @@ pixels. */)
struct window *w = decode_live_window (window);
if (NILP (pixelwise))
- return make_number (window_box_width (w, TEXT_AREA)
+ return make_fixnum (window_box_width (w, TEXT_AREA)
/ FRAME_COLUMN_WIDTH (WINDOW_XFRAME (w)));
else
- return make_number (window_box_width (w, TEXT_AREA));
+ return make_fixnum (window_box_width (w, TEXT_AREA));
}
DEFUN ("window-text-height", Fwindow_text_height, Swindow_text_height,
@@ -6157,10 +6616,10 @@ pixels. */)
struct window *w = decode_live_window (window);
if (NILP (pixelwise))
- return make_number (window_box_height (w)
+ return make_fixnum (window_box_height (w)
/ FRAME_LINE_HEIGHT (WINDOW_XFRAME (w)));
else
- return make_number (window_box_height (w));
+ return make_fixnum (window_box_height (w));
}
DEFUN ("move-to-window-line", Fmove_to_window_line, Smove_to_window_line,
@@ -6193,7 +6652,7 @@ from the top of the window. */)
if (start < BEGV || start > ZV)
{
int height = window_internal_height (w);
- Fvertical_motion (make_number (- (height / 2)), window, Qnil);
+ Fvertical_motion (make_fixnum (- (height / 2)), window, Qnil);
set_marker_both (w->start, w->contents, PT, PT_BYTE);
w->start_at_line_beg = !NILP (Fbolp ());
w->force_start = true;
@@ -6207,7 +6666,7 @@ from the top of the window. */)
XSETFASTINT (arg, lines / 2);
else
{
- EMACS_INT iarg = XINT (Fprefix_numeric_value (arg));
+ EMACS_INT iarg = XFIXNUM (Fprefix_numeric_value (arg));
if (iarg < 0)
iarg = iarg + lines;
@@ -6225,12 +6684,12 @@ from the top of the window. */)
iarg = min (iarg, lines - this_scroll_margin - 1);
#endif
- arg = make_number (iarg);
+ arg = make_fixnum (iarg);
}
/* Skip past a partially visible first line. */
if (w->vscroll)
- XSETINT (arg, XINT (arg) + 1);
+ XSETINT (arg, XFIXNUM (arg) + 1);
return Fvertical_motion (arg, window, Qnil);
}
@@ -6256,7 +6715,8 @@ struct save_window_data
Lisp_Object saved_windows;
/* All fields above are traced by the GC.
- From `frame-cols' down, the fields are ignored by the GC. */
+ After saved_windows, the fields are ignored by the GC. */
+
/* We should be able to do without the following two. */
int frame_cols, frame_lines;
/* These two should get eventually replaced by their pixel
@@ -6266,7 +6726,7 @@ struct save_window_data
/* These are currently unused. We need them as soon as we convert
to pixels. */
int frame_menu_bar_height, frame_tool_bar_height;
- };
+ } GCALIGNED_STRUCT;
/* This is saved as a Lisp_Vector. */
struct saved_window
@@ -6275,7 +6735,6 @@ struct saved_window
Lisp_Object window, buffer, start, pointm, old_pointm;
Lisp_Object pixel_left, pixel_top, pixel_height, pixel_width;
- Lisp_Object pixel_height_before_size_change, pixel_width_before_size_change;
Lisp_Object left_col, top_line, total_cols, total_lines;
Lisp_Object normal_cols, normal_lines;
Lisp_Object hscroll, min_hscroll, hscroll_whole, suspend_auto_hscroll;
@@ -6391,12 +6850,6 @@ the return value is nil. Otherwise the value is t. */)
struct window *root_window;
struct window **leaf_windows;
ptrdiff_t i, k, n_leaf_windows;
- /* Records whether a window has been added or removed wrt the
- original configuration. */
- bool window_changed = false;
- /* Records whether a window has changed its buffer wrt the
- original configuration. */
- bool buffer_changed = false;
/* Don't do this within the main loop below: This may call Lisp
code and is thus potentially unsafe while input is blocked. */
@@ -6406,11 +6859,6 @@ the return value is nil. Otherwise the value is t. */)
window = p->window;
w = XWINDOW (window);
- if (NILP (w->contents))
- /* A dead window that will be resurrected, the window
- configuration will change. */
- window_changed = true;
-
if (BUFFERP (w->contents)
&& !EQ (w->contents, p->buffer)
&& BUFFER_LIVE_P (XBUFFER (p->buffer)))
@@ -6468,14 +6916,14 @@ the return value is nil. Otherwise the value is t. */)
if (!NILP (p->parent))
wset_parent
- (w, SAVED_WINDOW_N (saved_windows, XFASTINT (p->parent))->window);
+ (w, SAVED_WINDOW_N (saved_windows, XFIXNAT (p->parent))->window);
else
wset_parent (w, Qnil);
if (!NILP (p->prev))
{
wset_prev
- (w, SAVED_WINDOW_N (saved_windows, XFASTINT (p->prev))->window);
+ (w, SAVED_WINDOW_N (saved_windows, XFIXNAT (p->prev))->window);
wset_next (XWINDOW (w->prev), p->window);
}
else
@@ -6483,7 +6931,7 @@ the return value is nil. Otherwise the value is t. */)
wset_prev (w, Qnil);
if (!NILP (w->parent))
wset_combination (XWINDOW (w->parent),
- (XINT (p->total_cols)
+ (XFIXNUM (p->total_cols)
!= XWINDOW (w->parent)->total_cols),
p->window);
}
@@ -6491,32 +6939,28 @@ the return value is nil. Otherwise the value is t. */)
/* If we squirreled away the buffer, restore it now. */
if (BUFFERP (w->combination_limit))
wset_buffer (w, w->combination_limit);
- w->pixel_left = XFASTINT (p->pixel_left);
- w->pixel_top = XFASTINT (p->pixel_top);
- w->pixel_width = XFASTINT (p->pixel_width);
- w->pixel_height = XFASTINT (p->pixel_height);
- w->pixel_width_before_size_change
- = XFASTINT (p->pixel_width_before_size_change);
- w->pixel_height_before_size_change
- = XFASTINT (p->pixel_height_before_size_change);
- w->left_col = XFASTINT (p->left_col);
- w->top_line = XFASTINT (p->top_line);
- w->total_cols = XFASTINT (p->total_cols);
- w->total_lines = XFASTINT (p->total_lines);
+ w->pixel_left = XFIXNAT (p->pixel_left);
+ w->pixel_top = XFIXNAT (p->pixel_top);
+ w->pixel_width = XFIXNAT (p->pixel_width);
+ w->pixel_height = XFIXNAT (p->pixel_height);
+ w->left_col = XFIXNAT (p->left_col);
+ w->top_line = XFIXNAT (p->top_line);
+ w->total_cols = XFIXNAT (p->total_cols);
+ w->total_lines = XFIXNAT (p->total_lines);
wset_normal_cols (w, p->normal_cols);
wset_normal_lines (w, p->normal_lines);
- w->hscroll = XFASTINT (p->hscroll);
+ w->hscroll = XFIXNAT (p->hscroll);
w->suspend_auto_hscroll = !NILP (p->suspend_auto_hscroll);
- w->min_hscroll = XFASTINT (p->min_hscroll);
- w->hscroll_whole = XFASTINT (p->hscroll_whole);
+ w->min_hscroll = XFIXNAT (p->min_hscroll);
+ w->hscroll_whole = XFIXNAT (p->hscroll_whole);
wset_display_table (w, p->display_table);
- w->left_margin_cols = XINT (p->left_margin_cols);
- w->right_margin_cols = XINT (p->right_margin_cols);
- w->left_fringe_width = XINT (p->left_fringe_width);
- w->right_fringe_width = XINT (p->right_fringe_width);
+ w->left_margin_cols = XFIXNUM (p->left_margin_cols);
+ w->right_margin_cols = XFIXNUM (p->right_margin_cols);
+ w->left_fringe_width = XFIXNUM (p->left_fringe_width);
+ w->right_fringe_width = XFIXNUM (p->right_fringe_width);
w->fringes_outside_margins = !NILP (p->fringes_outside_margins);
- w->scroll_bar_width = XINT (p->scroll_bar_width);
- w->scroll_bar_height = XINT (p->scroll_bar_height);
+ w->scroll_bar_width = XFIXNUM (p->scroll_bar_width);
+ w->scroll_bar_height = XFIXNUM (p->scroll_bar_height);
wset_vertical_scroll_bar_type (w, p->vertical_scroll_bar_type);
wset_horizontal_scroll_bar_type (w, p->horizontal_scroll_bar_type);
wset_dedicated (w, p->dedicated);
@@ -6546,9 +6990,6 @@ the return value is nil. Otherwise the value is t. */)
if (BUFFERP (p->buffer) && BUFFER_LIVE_P (XBUFFER (p->buffer)))
/* If saved buffer is alive, install it. */
{
- if (!EQ (w->contents, p->buffer))
- /* Record buffer configuration change. */
- buffer_changed = true;
wset_buffer (w, p->buffer);
w->start_at_line_beg = !NILP (p->start_at_line_beg);
set_marker_restricted (w->start, p->start, w->contents);
@@ -6582,8 +7023,6 @@ the return value is nil. Otherwise the value is t. */)
else if (!NILP (w->start))
/* Leaf window has no live buffer, get one. */
{
- /* Record buffer configuration change. */
- buffer_changed = true;
/* Get the buffer via other_buffer_safely in order to
avoid showing an unimportant buffer and, if necessary, to
recreate *scratch* in the course (part of Juanma's bs-show
@@ -6608,7 +7047,7 @@ the return value is nil. Otherwise the value is t. */)
current when the window configuration was saved. */
if (EQ (XWINDOW (data->current_window)->contents, new_current_buffer))
set_marker_restricted (XWINDOW (data->current_window)->pointm,
- make_number (old_point),
+ make_fixnum (old_point),
XWINDOW (data->current_window)->contents);
/* In the following call to select_window, prevent "swapping out
@@ -6631,10 +7070,7 @@ the return value is nil. Otherwise the value is t. */)
/* Now, free glyph matrices in windows that were not reused. */
for (i = 0; i < n_leaf_windows; i++)
if (NILP (leaf_windows[i]->contents))
- {
- free_window_matrices (leaf_windows[i]);
- window_changed = true;
- }
+ free_window_matrices (leaf_windows[i]);
/* Allow x_set_window_size again and apply frame size changes if
needed. */
@@ -6664,35 +7100,10 @@ the return value is nil. Otherwise the value is t. */)
selected window. */
if (FRAME_LIVE_P (XFRAME (data->selected_frame)))
do_switch_frame (data->selected_frame, 0, 0, Qnil);
-
- if (window_changed)
- /* At least one window has been added or removed. Run
- `window-configuration-change-hook' and make sure
- `window-size-change-functions' get run later.
-
- We have to do this in order to capture the following
- scenario: Suppose our frame contains two live windows W1 and
- W2 and 'set-window-configuration' replaces them by two
- windows W3 and W4 that were dead the last time
- run_window_size_change_functions was run. If W3 and W4 have
- the same values for their old and new pixel sizes but these
- values differ from those of W1 and W2, the sizes of our
- frame's two live windows changed but window_size_changed has
- no means to detect that fact.
-
- Obviously, this will get us false positives, for example,
- when we restore the original configuration with W1 and W2
- before run_window_size_change_functions gets called. */
- {
- run_window_configuration_change_hook (f);
- FRAME_WINDOW_CONFIGURATION_CHANGED (f) = true;
- }
- else if (buffer_changed)
- /* At least one window has changed its buffer. Run
- `window-configuration-change-hook' only. */
- run_window_configuration_change_hook (f);
}
+ FRAME_WINDOW_CHANGE (f) = true;
+
if (!NILP (new_current_buffer))
{
Fset_buffer (new_current_buffer);
@@ -6712,7 +7123,7 @@ the return value is nil. Otherwise the value is t. */)
the "normal" frame's selected window and that window *does*
show new_current_buffer. */
if (!EQ (XWINDOW (selected_window)->contents, new_current_buffer))
- Fgoto_char (make_number (old_point));
+ Fgoto_char (make_fixnum (old_point));
}
Vminibuf_scroll_window = data->minibuf_scroll_window;
@@ -6847,21 +7258,17 @@ save_window_save (Lisp_Object window, struct Lisp_Vector *vector, ptrdiff_t i)
p = SAVED_WINDOW_N (vector, i);
w = XWINDOW (window);
- wset_temslot (w, make_number (i)); i++;
+ wset_temslot (w, make_fixnum (i)); i++;
p->window = window;
p->buffer = (WINDOW_LEAF_P (w) ? w->contents : Qnil);
- p->pixel_left = make_number (w->pixel_left);
- p->pixel_top = make_number (w->pixel_top);
- p->pixel_width = make_number (w->pixel_width);
- p->pixel_height = make_number (w->pixel_height);
- p->pixel_width_before_size_change
- = make_number (w->pixel_width_before_size_change);
- p->pixel_height_before_size_change
- = make_number (w->pixel_height_before_size_change);
- p->left_col = make_number (w->left_col);
- p->top_line = make_number (w->top_line);
- p->total_cols = make_number (w->total_cols);
- p->total_lines = make_number (w->total_lines);
+ p->pixel_left = make_fixnum (w->pixel_left);
+ p->pixel_top = make_fixnum (w->pixel_top);
+ p->pixel_width = make_fixnum (w->pixel_width);
+ p->pixel_height = make_fixnum (w->pixel_height);
+ p->left_col = make_fixnum (w->left_col);
+ p->top_line = make_fixnum (w->top_line);
+ p->total_cols = make_fixnum (w->total_cols);
+ p->total_lines = make_fixnum (w->total_lines);
p->normal_cols = w->normal_cols;
p->normal_lines = w->normal_lines;
XSETFASTINT (p->hscroll, w->hscroll);
@@ -6869,13 +7276,13 @@ save_window_save (Lisp_Object window, struct Lisp_Vector *vector, ptrdiff_t i)
XSETFASTINT (p->min_hscroll, w->min_hscroll);
XSETFASTINT (p->hscroll_whole, w->hscroll_whole);
p->display_table = w->display_table;
- p->left_margin_cols = make_number (w->left_margin_cols);
- p->right_margin_cols = make_number (w->right_margin_cols);
- p->left_fringe_width = make_number (w->left_fringe_width);
- p->right_fringe_width = make_number (w->right_fringe_width);
+ p->left_margin_cols = make_fixnum (w->left_margin_cols);
+ p->right_margin_cols = make_fixnum (w->right_margin_cols);
+ p->left_fringe_width = make_fixnum (w->left_fringe_width);
+ p->right_fringe_width = make_fixnum (w->right_fringe_width);
p->fringes_outside_margins = w->fringes_outside_margins ? Qt : Qnil;
- p->scroll_bar_width = make_number (w->scroll_bar_width);
- p->scroll_bar_height = make_number (w->scroll_bar_height);
+ p->scroll_bar_width = make_fixnum (w->scroll_bar_width);
+ p->scroll_bar_height = make_fixnum (w->scroll_bar_height);
p->vertical_scroll_bar_type = w->vertical_scroll_bar_type;
p->horizontal_scroll_bar_type = w->horizontal_scroll_bar_type;
p->dedicated = w->dedicated;
@@ -6930,6 +7337,10 @@ save_window_save (Lisp_Object window, struct Lisp_Vector *vector, ptrdiff_t i)
if (BUFFERP (w->contents))
{
+ bool window_point_insertion_type
+ = !NILP (buffer_local_value
+ (Qwindow_point_insertion_type, w->contents));
+
/* Save w's value of point in the window configuration. If w
is the selected window, then get the value of point from
the buffer; pointm is garbage in the selected window. */
@@ -6940,12 +7351,8 @@ save_window_save (Lisp_Object window, struct Lisp_Vector *vector, ptrdiff_t i)
else
p->pointm = Fcopy_marker (w->pointm, Qnil);
p->old_pointm = Fcopy_marker (w->old_pointm, Qnil);
- XMARKER (p->pointm)->insertion_type
- = !NILP (buffer_local_value /* Don't signal error if void. */
- (Qwindow_point_insertion_type, w->contents));
- XMARKER (p->old_pointm)->insertion_type
- = !NILP (buffer_local_value /* Don't signal error if void. */
- (Qwindow_point_insertion_type, w->contents));
+ XMARKER (p->pointm)->insertion_type = window_point_insertion_type;
+ XMARKER (p->old_pointm)->insertion_type = window_point_insertion_type;
p->start = Fcopy_marker (w->start, Qnil);
p->start_at_line_beg = w->start_at_line_beg ? Qt : Qnil;
@@ -6982,15 +7389,11 @@ redirection (see `redirect-frame-focus'). The variable
saved by this function. */)
(Lisp_Object frame)
{
- Lisp_Object tem;
- ptrdiff_t i, n_windows;
- struct save_window_data *data;
struct frame *f = decode_live_frame (frame);
-
- n_windows = count_windows (XWINDOW (FRAME_ROOT_WINDOW (f)));
- data = ALLOCATE_PSEUDOVECTOR (struct save_window_data, frame_cols,
- PVEC_WINDOW_CONFIGURATION);
-
+ ptrdiff_t n_windows = count_windows (XWINDOW (FRAME_ROOT_WINDOW (f)));
+ struct save_window_data *data
+ = ALLOCATE_PSEUDOVECTOR (struct save_window_data, saved_windows,
+ PVEC_WINDOW_CONFIGURATION);
data->frame_cols = FRAME_COLS (f);
data->frame_lines = FRAME_LINES (f);
data->frame_menu_bar_lines = FRAME_MENU_BAR_LINES (f);
@@ -7006,11 +7409,10 @@ saved by this function. */)
data->minibuf_selected_window = minibuf_level > 0 ? minibuf_selected_window : Qnil;
data->root_window = FRAME_ROOT_WINDOW (f);
data->focus_frame = FRAME_FOCUS_FRAME (f);
- tem = make_uninit_vector (n_windows);
+ Lisp_Object tem = make_uninit_vector (n_windows);
data->saved_windows = tem;
- for (i = 0; i < n_windows; i++)
- ASET (tem, i,
- Fmake_vector (make_number (VECSIZE (struct saved_window)), Qnil));
+ for (ptrdiff_t i = 0; i < n_windows; i++)
+ ASET (tem, i, make_nil_vector (VECSIZE (struct saved_window)));
save_window_save (FRAME_ROOT_WINDOW (f), XVECTOR (tem), 0);
XSETWINDOW_CONFIGURATION (tem, data);
return (tem);
@@ -7039,7 +7441,7 @@ extract_dimension (Lisp_Object dimension)
if (NILP (dimension))
return -1;
CHECK_RANGED_INTEGER (dimension, 0, INT_MAX);
- return XINT (dimension);
+ return XFIXNUM (dimension);
}
static struct window *
@@ -7104,9 +7506,9 @@ as nil. */)
{
struct window *w = decode_live_window (window);
return Fcons (w->left_margin_cols
- ? make_number (w->left_margin_cols) : Qnil,
+ ? make_fixnum (w->left_margin_cols) : Qnil,
w->right_margin_cols
- ? make_number (w->right_margin_cols) : Qnil);
+ ? make_fixnum (w->right_margin_cols) : Qnil);
}
@@ -7193,8 +7595,8 @@ Value is a list of the form (LEFT-WIDTH RIGHT-WIDTH OUTSIDE-MARGINS). */)
{
struct window *w = decode_live_window (window);
- return list3 (make_number (WINDOW_LEFT_FRINGE_WIDTH (w)),
- make_number (WINDOW_RIGHT_FRINGE_WIDTH (w)),
+ return list3 (make_fixnum (WINDOW_LEFT_FRINGE_WIDTH (w)),
+ make_fixnum (WINDOW_RIGHT_FRINGE_WIDTH (w)),
WINDOW_HAS_FRINGES_OUTSIDE_MARGINS (w) ? Qt : Qnil);
}
@@ -7324,14 +7726,14 @@ value. */)
struct window *w = decode_live_window (window);
return Fcons (((w->scroll_bar_width >= 0)
- ? make_number (w->scroll_bar_width)
+ ? make_fixnum (w->scroll_bar_width)
: Qnil),
- list5 (make_number (WINDOW_SCROLL_BAR_COLS (w)),
+ list5 (make_fixnum (WINDOW_SCROLL_BAR_COLS (w)),
w->vertical_scroll_bar_type,
((w->scroll_bar_height >= 0)
- ? make_number (w->scroll_bar_height)
+ ? make_fixnum (w->scroll_bar_height)
: Qnil),
- make_number (WINDOW_SCROLL_BAR_LINES (w)),
+ make_fixnum (WINDOW_SCROLL_BAR_LINES (w)),
w->horizontal_scroll_bar_type));
}
@@ -7355,9 +7757,9 @@ optional second arg PIXELS-P means value is measured in pixels. */)
if (FRAME_WINDOW_P (f))
result = (NILP (pixels_p)
? FRAME_CANON_Y_FROM_PIXEL_Y (f, -w->vscroll)
- : make_number (-w->vscroll));
+ : make_fixnum (-w->vscroll));
else
- result = make_number (0);
+ result = make_fixnum (0);
return result;
}
@@ -7379,7 +7781,7 @@ If PIXELS-P is non-nil, the return value is VSCROLL. */)
struct window *w = decode_live_window (window);
struct frame *f = XFRAME (w->frame);
- CHECK_NUMBER_OR_FLOAT (vscroll);
+ CHECK_NUMBER (vscroll);
if (FRAME_WINDOW_P (f))
{
@@ -7549,14 +7951,63 @@ and scrolling positions. */)
return Qnil;
}
+
+static void init_window_once_for_pdumper (void);
+
void
init_window_once (void)
{
+ minibuf_window = Qnil;
+ staticpro (&minibuf_window);
+
+ selected_window = Qnil;
+ staticpro (&selected_window);
+
+ Vwindow_list = Qnil;
+ staticpro (&Vwindow_list);
+
+ minibuf_selected_window = Qnil;
+ staticpro (&minibuf_selected_window);
+
+ pdumper_do_now_and_after_load (init_window_once_for_pdumper);
+}
+
+static void init_window_once_for_pdumper (void)
+{
+ window_scroll_pixel_based_preserve_x = -1;
+ window_scroll_pixel_based_preserve_y = -1;
+ window_scroll_preserve_hpos = -1;
+ window_scroll_preserve_vpos = -1;
+ PDUMPER_IGNORE (sequence_number);
+
+ PDUMPER_RESET_LV (minibuf_window, Qnil);
+ PDUMPER_RESET_LV (selected_window, Qnil);
+ PDUMPER_RESET_LV (Vwindow_list, Qnil);
+ PDUMPER_RESET_LV (minibuf_selected_window, Qnil);
+
+ /* Hack: if mode_line_in_non_selected_windows is true (which it may
+ be, if we're restoring from a dump) the guts of
+ make_initial_frame will try to access selected_window, which is
+ invalid at this point, and lose. For the purposes of creating
+ the initial frame and window, this variable must be false. */
+ bool old_mode_line_in_non_selected_windows;
+
+ /* Snapshot dumped_with_pdumper to suppress compiler warning. */
+ bool saved_dumped_with_pdumper = dumped_with_pdumper_p ();
+ if (saved_dumped_with_pdumper)
+ {
+ old_mode_line_in_non_selected_windows
+ = mode_line_in_non_selected_windows;
+ mode_line_in_non_selected_windows = false;
+ }
struct frame *f = make_initial_frame ();
+ if (saved_dumped_with_pdumper)
+ mode_line_in_non_selected_windows =
+ old_mode_line_in_non_selected_windows;
XSETFRAME (selected_frame, f);
- Vterminal_frame = selected_frame;
+ old_selected_frame = Vterminal_frame = selected_frame;
minibuf_window = f->minibuffer_window;
- selected_window = f->selected_window;
+ old_selected_window = selected_window = f->selected_window;
}
void
@@ -7576,6 +8027,11 @@ syms_of_window (void)
Fput (Qscroll_down, Qscroll_command, Qt);
DEFSYM (Qwindow_configuration_change_hook, "window-configuration-change-hook");
+ DEFSYM (Qwindow_state_change_hook, "window-state-change-hook");
+ DEFSYM (Qwindow_state_change_functions, "window-state-change-functions");
+ DEFSYM (Qwindow_size_change_functions, "window-size-change-functions");
+ DEFSYM (Qwindow_buffer_change_functions, "window-buffer-change-functions");
+ DEFSYM (Qwindow_selection_change_functions, "window-selection-change-functions");
DEFSYM (Qwindowp, "windowp");
DEFSYM (Qwindow_configuration_p, "window-configuration-p");
DEFSYM (Qwindow_live_p, "window-live-p");
@@ -7585,6 +8041,7 @@ syms_of_window (void)
DEFSYM (Qwindow__resize_root_window, "window--resize-root-window");
DEFSYM (Qwindow__resize_root_window_vertically,
"window--resize-root-window-vertically");
+ DEFSYM (Qwindow__resize_mini_frame, "window--resize-mini-frame");
DEFSYM (Qwindow__sanitize_window_sizes, "window--sanitize-window-sizes");
DEFSYM (Qwindow__pixel_to_total, "window--pixel-to-total");
DEFSYM (Qsafe, "safe");
@@ -7602,16 +8059,6 @@ syms_of_window (void)
DEFSYM (Qmode_line_format, "mode-line-format");
DEFSYM (Qheader_line_format, "header-line-format");
- staticpro (&Vwindow_list);
-
- minibuf_selected_window = Qnil;
- staticpro (&minibuf_selected_window);
-
- window_scroll_pixel_based_preserve_x = -1;
- window_scroll_pixel_based_preserve_y = -1;
- window_scroll_preserve_hpos = -1;
- window_scroll_preserve_vpos = -1;
-
DEFVAR_LISP ("temp-buffer-show-function", Vtemp_buffer_show_function,
doc: /* Non-nil means call as function to display a help buffer.
The function is called with one argument, the buffer to be displayed.
@@ -7660,24 +8107,96 @@ on their symbols to be controlled by this variable. */);
Vwindow_point_insertion_type = Qnil;
DEFSYM (Qwindow_point_insertion_type, "window-point-insertion-type");
- DEFVAR_LISP ("window-configuration-change-hook",
- Vwindow_configuration_change_hook,
- doc: /* Functions to call when window configuration changes.
-The buffer-local value is run once per window, with the relevant window
-selected; while the global value is run only once for the modified frame,
-with the relevant frame selected. */);
- Vwindow_configuration_change_hook = Qnil;
+ DEFVAR_LISP ("window-buffer-change-functions", Vwindow_buffer_change_functions,
+ doc: /* Functions called during redisplay when window buffers have changed.
+The value should be a list of functions that take one argument.
+
+Functions specified buffer-locally are called for each window showing
+the corresponding buffer if and only if that window has been added or
+changed its buffer since the last redisplay. In this case the window
+is passed as argument.
+
+Functions specified by the default value are called for each frame if
+at least one window on that frame has been added, deleted or changed
+its buffer since the last redisplay. In this case the frame is passed
+as argument. */);
+ Vwindow_buffer_change_functions = Qnil;
DEFVAR_LISP ("window-size-change-functions", Vwindow_size_change_functions,
- doc: /* Functions called during redisplay, if window sizes have changed.
+ doc: /* Functions called during redisplay when window sizes have changed.
The value should be a list of functions that take one argument.
-During the first part of redisplay, for each frame, if any of its windows
-have changed size since the last redisplay, or have been split or deleted,
-all the functions in the list are called, with the frame as argument.
-If redisplay decides to resize the minibuffer window, it calls these
-functions on behalf of that as well. */);
+
+Functions specified buffer-locally are called for each window showing
+the corresponding buffer if and only if that window has been added or
+changed its buffer or its total or body size since the last redisplay.
+In this case the window is passed as argument.
+
+Functions specified by the default value are called for each frame if
+at least one window on that frame has been added or changed its buffer
+or its total or body size since the last redisplay. In this case the
+frame is passed as argument. */);
Vwindow_size_change_functions = Qnil;
+ DEFVAR_LISP ("window-selection-change-functions", Vwindow_selection_change_functions,
+ doc: /* Functions called during redisplay when the selected window has changed.
+The value should be a list of functions that take one argument.
+
+Functions specified buffer-locally are called for each window showing
+the corresponding buffer if and only if that window has been selected
+or deselected since the last redisplay. In this case the window is
+passed as argument.
+
+Functions specified by the default value are called for each frame if
+the frame's selected window has changed since the last redisplay. In
+this case the frame is passed as argument. */);
+ Vwindow_selection_change_functions = Qnil;
+
+ DEFVAR_LISP ("window-state-change-functions", Vwindow_state_change_functions,
+ doc: /* Functions called during redisplay when the window state changed.
+The value should be a list of functions that take one argument.
+
+Functions specified buffer-locally are called for each window showing
+the corresponding buffer if and only if that window has been added,
+resized, changed its buffer or has been (de-)selected since the last
+redisplay. In this case the window is passed as argument.
+
+Functions specified by the default value are called for each frame if
+at least one window on that frame has been added, deleted, changed its
+buffer or its total or body size or the frame has been (de-)selected,
+its selected window has changed or the window state change flag has
+been set for this frame since the last redisplay. In this case the
+frame is passed as argument. */);
+ Vwindow_state_change_functions = Qnil;
+
+ DEFVAR_LISP ("window-state-change-hook", Vwindow_state_change_hook,
+ doc: /* Functions called during redisplay when the window state changed.
+The value should be a list of functions that take no argument.
+
+This hook is called during redisplay when at least one window has been
+added, deleted, (de-)selected, changed its buffer or its total or body
+size or the window state change flag has been set for at least one
+frame. This hook is called after all other window change functions
+have been run and should be used only if a function should react to
+changes that happened on at least two frames since last redisplay or
+the function intends to change the window configuration. */);
+ Vwindow_state_change_hook = Qnil;
+
+ DEFVAR_LISP ("window-configuration-change-hook", Vwindow_configuration_change_hook,
+ doc: /* Functions called during redisplay when window configuration has changed.
+The value should be a list of functions that take no argument.
+
+Functions specified buffer-locally are called for each window showing
+the corresponding buffer if at least one window on that frame has been
+added, deleted or changed its buffer or its total or body size since
+the last redisplay. Each call is performed with the window showing
+the buffer temporarily selected.
+
+Functions specified by the default value are called for each frame if
+at least one window on that frame has been added, deleted or changed
+its buffer or its total or body size since the last redisplay. Each
+call is performed with the frame temporarily selected. */);
+ Vwindow_configuration_change_hook = Qnil;
+
DEFVAR_LISP ("recenter-redisplay", Vrecenter_redisplay,
doc: /* Non-nil means `recenter' redraws entire frame.
If this option is non-nil, then the `recenter' command with a nil
@@ -7789,6 +8308,7 @@ displayed after a scrolling operation to be somewhat inaccurate. */);
Vfast_but_imprecise_scrolling = false;
defsubr (&Sselected_window);
+ defsubr (&Sold_selected_window);
defsubr (&Sminibuffer_window);
defsubr (&Swindow_minibuffer_p);
defsubr (&Swindowp);
@@ -7798,10 +8318,12 @@ displayed after a scrolling operation to be somewhat inaccurate. */);
defsubr (&Sframe_root_window);
defsubr (&Sframe_first_window);
defsubr (&Sframe_selected_window);
+ defsubr (&Sframe_old_selected_window);
defsubr (&Sset_frame_selected_window);
defsubr (&Spos_visible_in_window_p);
defsubr (&Swindow_line_height);
defsubr (&Swindow_buffer);
+ defsubr (&Swindow_old_buffer);
defsubr (&Swindow_parent);
defsubr (&Swindow_top_child);
defsubr (&Swindow_left_child);
@@ -7812,8 +8334,10 @@ displayed after a scrolling operation to be somewhat inaccurate. */);
defsubr (&Swindow_use_time);
defsubr (&Swindow_pixel_width);
defsubr (&Swindow_pixel_height);
- defsubr (&Swindow_pixel_width_before_size_change);
- defsubr (&Swindow_pixel_height_before_size_change);
+ defsubr (&Swindow_old_pixel_width);
+ defsubr (&Swindow_old_pixel_height);
+ defsubr (&Swindow_old_body_pixel_width);
+ defsubr (&Swindow_old_body_pixel_height);
defsubr (&Swindow_total_width);
defsubr (&Swindow_total_height);
defsubr (&Swindow_normal_size);
@@ -7872,6 +8396,7 @@ displayed after a scrolling operation to be somewhat inaccurate. */);
defsubr (&Sscroll_right);
defsubr (&Sother_window_for_scrolling);
defsubr (&Sscroll_other_window);
+ defsubr (&Sscroll_other_window_down);
defsubr (&Sminibuffer_selected_window);
defsubr (&Srecenter);
defsubr (&Swindow_text_width);
diff --git a/src/window.h b/src/window.h
index 72c58e7abfe..fdef407041b 100644
--- a/src/window.h
+++ b/src/window.h
@@ -142,6 +142,11 @@ struct window
as well. */
Lisp_Object contents;
+ /* The old buffer of this window, set to this window's buffer by
+ run_window_change_functions every time it sees this window.
+ Unused for internal windows. */
+ Lisp_Object old_buffer;
+
/* A marker pointing to where in the text to start displaying.
BIDI Note: This is the _logical-order_ start, i.e. the smallest
buffer position visible in the window, not necessarily the
@@ -204,9 +209,11 @@ struct window
/* An alist with parameters. */
Lisp_Object window_parameters;
- /* No Lisp data may follow below this point without changing
- mark_object in alloc.c. The member current_matrix must be the
- first non-Lisp member. */
+ /* The help echo text for this window. Qnil if there's none. */
+ Lisp_Object mode_line_help_echo;
+
+ /* No Lisp data may follow this point; mode_line_help_echo must be
+ the last Lisp member. */
/* Glyph matrices. */
struct glyph_matrix *current_matrix;
@@ -226,6 +233,14 @@ struct window
/* Unique number of window assigned when it was created. */
EMACS_INT sequence_number;
+ /* The change stamp of this window. Set to 0 when the window is
+ created, it is set to its frame's change stamp every time
+ run_window_change_functions is run on that frame with this
+ window live. It is left alone when the window exists only
+ within a window configuration. Not useful for internal
+ windows. */
+ int change_stamp;
+
/* The upper left corner pixel coordinates of this window, as
integers relative to upper left corner of frame = 0, 0. */
int pixel_left;
@@ -240,10 +255,13 @@ struct window
int pixel_width;
int pixel_height;
- /* The pixel sizes of the window at the last time
- `window-size-change-functions' was run. */
- int pixel_width_before_size_change;
- int pixel_height_before_size_change;
+ /* The pixel and pixel body sizes of the window at the last time
+ run_window_change_functions was run with this window live. Not
+ useful for internal windows. */
+ int old_pixel_width;
+ int old_pixel_height;
+ int old_body_pixel_width;
+ int old_body_pixel_height;
/* The size of the window. */
int total_cols;
@@ -262,11 +280,11 @@ struct window
/* Displayed buffer's text modification events counter as of last time
display completed. */
- EMACS_INT last_modified;
+ modiff_count last_modified;
/* Displayed buffer's overlays modification events counter as of last
complete update. */
- EMACS_INT last_overlay_modified;
+ modiff_count last_overlay_modified;
/* Value of point at that time. Since this is a position in a buffer,
it should be positive. */
@@ -423,7 +441,7 @@ struct window
/* Z_BYTE - buffer position of the last glyph in the current matrix of W.
Should be nonnegative, and only valid if window_end_valid is true. */
ptrdiff_t window_end_bytepos;
- };
+ } GCALIGNED_STRUCT;
INLINE bool
WINDOWP (Lisp_Object a)
@@ -441,7 +459,7 @@ INLINE struct window *
XWINDOW (Lisp_Object a)
{
eassert (WINDOWP (a));
- return XUNTAG (a, Lisp_Vectorlike);
+ return XUNTAG (a, Lisp_Vectorlike, struct window);
}
/* Most code should use these functions to set Lisp fields in struct
@@ -471,6 +489,12 @@ wset_redisplay_end_trigger (struct window *w, Lisp_Object val)
}
INLINE void
+wset_mode_line_help_echo (struct window *w, Lisp_Object val)
+{
+ w->mode_line_help_echo = val;
+}
+
+INLINE void
wset_new_pixel (struct window *w, Lisp_Object val)
{
w->new_pixel = val;
@@ -714,7 +738,7 @@ wset_next_buffers (struct window *w, Lisp_Object val)
#endif
/* True if W is a tool bar window. */
-#if defined (HAVE_WINDOW_SYSTEM) && ! defined (USE_GTK) && ! defined (HAVE_NS)
+#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_TOOL_BAR)
#define WINDOW_TOOL_BAR_P(W) \
(WINDOWP (WINDOW_XFRAME (W)->tool_bar_window) \
&& (W) == XWINDOW (WINDOW_XFRAME (W)->tool_bar_window))
@@ -1038,11 +1062,11 @@ extern Lisp_Object window_from_coordinates (struct frame *, int, int,
extern void resize_frame_windows (struct frame *, int, bool, bool);
extern void restore_window_configuration (Lisp_Object);
extern void delete_all_child_windows (Lisp_Object);
-extern void grow_mini_window (struct window *, int, bool);
-extern void shrink_mini_window (struct window *, bool);
+extern void grow_mini_window (struct window *, int);
+extern void shrink_mini_window (struct window *);
extern int window_relative_x_coord (struct window *, enum window_part, int);
-void run_window_size_change_functions (Lisp_Object);
+void run_window_change_functions (void);
/* Make WINDOW display BUFFER. RUN_HOOKS_P means it's allowed
to run hooks. See make_frame for a case where it's not allowed. */
diff --git a/src/xdisp.c b/src/xdisp.c
index 0c3754a338f..a88fc698b85 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -265,7 +265,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
character to be delivered is a composed character, the iteration
calls composition_reseat_it and next_element_from_composition. If
they succeed to compose the character with one or more of the
- following characters, the whole sequence of characters that where
+ following characters, the whole sequence of characters that were
composed is recorded in the `struct composition_it' object that is
part of the buffer iterator. The composed sequence could produce
one or more font glyphs (called "grapheme clusters") on the screen.
@@ -440,10 +440,8 @@ static Lisp_Object default_invis_vector[3];
Lisp_Object echo_area_window;
-/* List of pairs (MESSAGE . MULTIBYTE). The function save_message
- pushes the current message and the value of
- message_enable_multibyte on the stack, the function restore_message
- pops the stack and displays MESSAGE again. */
+/* Stack of messages, which are pushed by push_message and popped and
+ displayed by restore_message. */
static Lisp_Object Vmessage_stack;
@@ -469,12 +467,12 @@ static bool message_enable_multibyte;
looking for those `redisplay' bits (actually, there might be some such bits
set, but then only on objects which aren't displayed anyway).
- OTOH if it's non-zero we wil have to loop through all windows and then check
- the `redisplay' bit of the corresponding window, frame, and buffer, in order
- to decide whether that window needs attention or not. Note that we can't
- just look at the frame's redisplay bit to decide that the whole frame can be
- skipped, since even if the frame's redisplay bit is unset, some of its
- windows's redisplay bits may be set.
+ OTOH if it's non-zero we will have to loop through all windows and then
+ check the `redisplay' bit of the corresponding window, frame, and buffer, in
+ order to decide whether that window needs attention or not. Note that we
+ can't just look at the frame's redisplay bit to decide that the whole frame
+ can be skipped, since even if the frame's redisplay bit is unset, some of
+ its windows's redisplay bits may be set.
Mostly for historical reasons, windows_or_buffers_changed can also take
other non-zero values. In that case, the precise value doesn't matter (it
@@ -485,7 +483,7 @@ static bool message_enable_multibyte;
int windows_or_buffers_changed;
/* Nonzero if we should redraw the mode lines on the next redisplay.
- Similarly to `windows_or_buffers_changed', If it has value REDISPLAY_SOME,
+ Similarly to `windows_or_buffers_changed', if it has value REDISPLAY_SOME,
then only redisplay the mode lines in those buffers/windows/frames where the
`redisplay' bit has been set.
For any other value, redisplay all mode lines (the number used is then only
@@ -844,7 +842,7 @@ static Lisp_Object redisplay_window_1 (Lisp_Object);
static bool set_cursor_from_row (struct window *, struct glyph_row *,
struct glyph_matrix *, ptrdiff_t, ptrdiff_t,
int, int);
-static bool cursor_row_fully_visible_p (struct window *, bool, bool);
+static bool cursor_row_fully_visible_p (struct window *, bool, bool, bool);
static bool update_menu_bar (struct frame *, bool, bool);
static bool try_window_reusing_current_matrix (struct window *);
static int try_window_id (struct window *);
@@ -1216,7 +1214,7 @@ Value is the height in pixels of the line at point. */)
move_it_by_lines (&it, 0);
it.vpos = it.current_y = 0;
last_height = 0;
- result = make_number (line_bottom_y (&it));
+ result = make_fixnum (line_bottom_y (&it));
if (old_buffer)
set_buffer_internal_1 (old_buffer);
@@ -1252,8 +1250,8 @@ default_line_pixel_height (struct window *w)
val = BVAR (&buffer_defaults, extra_line_spacing);
if (!NILP (val))
{
- if (RANGED_INTEGERP (0, val, INT_MAX))
- height += XFASTINT (val);
+ if (RANGED_FIXNUMP (0, val, INT_MAX))
+ height += XFIXNAT (val);
else if (FLOATP (val))
{
int addon = XFLOAT_DATA (val) * height + 0.5;
@@ -1509,7 +1507,7 @@ pos_visible_p (struct window *w, ptrdiff_t charpos, int *x, int *y,
}
else if (IT_CHARPOS (it) != charpos)
{
- Lisp_Object cpos = make_number (charpos);
+ Lisp_Object cpos = make_fixnum (charpos);
Lisp_Object spec = Fget_char_property (cpos, Qdisplay, Qnil);
Lisp_Object string = string_from_display_spec (spec);
struct text_pos tpos;
@@ -1552,8 +1550,8 @@ pos_visible_p (struct window *w, ptrdiff_t charpos, int *x, int *y,
startpos =
Fprevious_single_char_property_change (endpos, Qdisplay,
Qnil, Qnil);
- start = XFASTINT (startpos);
- end = XFASTINT (endpos);
+ start = XFIXNAT (startpos);
+ end = XFIXNAT (endpos);
/* Move to the last buffer position before the
display property. */
start_display (&it3, w, top);
@@ -2283,9 +2281,9 @@ get_phys_cursor_geometry (struct window *w, struct glyph_row *row,
int x, y, wd, h, h0, y0, ascent;
/* Compute the width of the rectangle to draw. If on a stretch
- glyph, and `x-stretch-block-cursor' is nil, don't draw a
- rectangle as wide as the glyph, but use a canonical character
- width instead. */
+ glyph, and `x-stretch-cursor' is nil, don't draw a rectangle
+ as wide as the glyph, but use a canonical character width
+ instead. */
wd = glyph->pixel_width;
x = w->phys_cursor.x;
@@ -2645,8 +2643,7 @@ safe__call (bool inhibit_quit, ptrdiff_t nargs, Lisp_Object func, va_list ap)
so there is no possibility of wanting to redisplay. */
val = internal_condition_case_n (Ffuncall, nargs, args, Qt,
safe_eval_handler);
- SAFE_FREE ();
- val = unbind_to (count, val);
+ val = SAFE_FREE_UNBIND_TO (count, val);
}
return val;
@@ -2789,6 +2786,7 @@ init_iterator (struct it *it, struct window *w,
struct glyph_row *row, enum face_id base_face_id)
{
enum face_id remapped_base_face_id = base_face_id;
+ int body_width = 0, body_height = 0;
/* Some precondition checks. */
eassert (w != NULL && it != NULL);
@@ -2817,7 +2815,7 @@ init_iterator (struct it *it, struct window *w,
/* Perhaps remap BASE_FACE_ID to a user-specified alternative. */
if (! NILP (Vface_remapping_alist))
remapped_base_face_id
- = lookup_basic_face (XFRAME (w->frame), base_face_id);
+ = lookup_basic_face (w, XFRAME (w->frame), base_face_id);
/* Use one of the mode line rows of W's desired matrix if
appropriate. */
@@ -2851,8 +2849,8 @@ init_iterator (struct it *it, struct window *w,
if (base_face_id == DEFAULT_FACE_ID
&& FRAME_WINDOW_P (it->f))
{
- if (NATNUMP (BVAR (current_buffer, extra_line_spacing)))
- it->extra_line_spacing = XFASTINT (BVAR (current_buffer, extra_line_spacing));
+ if (FIXNATP (BVAR (current_buffer, extra_line_spacing)))
+ it->extra_line_spacing = XFIXNAT (BVAR (current_buffer, extra_line_spacing));
else if (FLOATP (BVAR (current_buffer, extra_line_spacing)))
it->extra_line_spacing = (XFLOAT_DATA (BVAR (current_buffer, extra_line_spacing))
* FRAME_LINE_HEIGHT (it->f));
@@ -2877,9 +2875,9 @@ init_iterator (struct it *it, struct window *w,
/* -1 means everything between a CR and the following line end
is invisible. >0 means lines indented more than this value are
invisible. */
- it->selective = (INTEGERP (BVAR (current_buffer, selective_display))
+ it->selective = (FIXNUMP (BVAR (current_buffer, selective_display))
? (clip_to_bounds
- (-1, XINT (BVAR (current_buffer, selective_display)),
+ (-1, XFIXNUM (BVAR (current_buffer, selective_display)),
PTRDIFF_MAX))
: (!NILP (BVAR (current_buffer, selective_display))
? -1 : 0));
@@ -2898,9 +2896,9 @@ init_iterator (struct it *it, struct window *w,
&& XMARKER (w->redisplay_end_trigger)->buffer != 0)
it->redisplay_end_trigger_charpos
= marker_position (w->redisplay_end_trigger);
- else if (INTEGERP (w->redisplay_end_trigger))
+ else if (FIXNUMP (w->redisplay_end_trigger))
it->redisplay_end_trigger_charpos
- = clip_to_bounds (PTRDIFF_MIN, XINT (w->redisplay_end_trigger),
+ = clip_to_bounds (PTRDIFF_MIN, XFIXNUM (w->redisplay_end_trigger),
PTRDIFF_MAX);
it->tab_width = SANE_TAB_WIDTH (current_buffer);
@@ -2912,9 +2910,9 @@ init_iterator (struct it *it, struct window *w,
&& !it->w->hscroll
&& (WINDOW_FULL_WIDTH_P (it->w)
|| NILP (Vtruncate_partial_width_windows)
- || (INTEGERP (Vtruncate_partial_width_windows)
+ || (FIXNUMP (Vtruncate_partial_width_windows)
/* PXW: Shall we do something about this? */
- && (XINT (Vtruncate_partial_width_windows)
+ && (XFIXNUM (Vtruncate_partial_width_windows)
<= WINDOW_TOTAL_COLS (it->w))))
&& NILP (BVAR (current_buffer, truncate_lines)))
it->line_wrap = NILP (BVAR (current_buffer, word_wrap))
@@ -2965,7 +2963,7 @@ init_iterator (struct it *it, struct window *w,
{
/* Mode lines, menu bar in terminal frames. */
it->first_visible_x = 0;
- it->last_visible_x = WINDOW_PIXEL_WIDTH (w);
+ it->last_visible_x = body_width = WINDOW_PIXEL_WIDTH (w);
}
else
{
@@ -2985,8 +2983,12 @@ init_iterator (struct it *it, struct window *w,
else
it->first_visible_x =
window_hscroll_limited (w, it->f) * FRAME_COLUMN_WIDTH (it->f);
- it->last_visible_x = (it->first_visible_x
- + window_box_width (w, TEXT_AREA));
+
+ body_width = window_box_width (w, TEXT_AREA);
+ if (!w->pseudo_window_p && !MINI_WINDOW_P (w)
+ && body_width != w->old_body_pixel_width)
+ FRAME_WINDOW_CHANGE (it->f) = true;
+ it->last_visible_x = it->first_visible_x + body_width;
/* If we truncate lines, leave room for the truncation glyph(s) at
the right margin. Otherwise, leave room for the continuation
@@ -3000,7 +3002,8 @@ init_iterator (struct it *it, struct window *w,
}
it->header_line_p = window_wants_header_line (w);
- it->current_y = WINDOW_HEADER_LINE_HEIGHT (w) + w->vscroll;
+ body_height = WINDOW_HEADER_LINE_HEIGHT (w);
+ it->current_y = body_height + w->vscroll;
}
/* Leave room for a border glyph. */
@@ -3009,6 +3012,10 @@ init_iterator (struct it *it, struct window *w,
it->last_visible_x -= 1;
it->last_visible_y = window_text_bottom_y (w);
+ body_height += it->last_visible_y;
+ if (!w->pseudo_window_p && !MINI_WINDOW_P (w)
+ && body_height != w->old_body_pixel_height)
+ FRAME_WINDOW_CHANGE (it->f) = true;
/* For mode lines and alike, arrange for the first glyph having a
left box line if the face specifies a box. */
@@ -3197,11 +3204,11 @@ in_ellipses_for_invisible_text_p (struct display_pos *pos, struct window *w)
&& CHARPOS (pos->string_pos) < 0
&& charpos > BEGV
&& (XSETWINDOW (window, w),
- prop = Fget_char_property (make_number (charpos),
+ prop = Fget_char_property (make_fixnum (charpos),
Qinvisible, window),
TEXT_PROP_MEANS_INVISIBLE (prop) == 0))
{
- prop = Fget_char_property (make_number (charpos - 1), Qinvisible,
+ prop = Fget_char_property (make_fixnum (charpos - 1), Qinvisible,
window);
ellipses_p = 2 == TEXT_PROP_MEANS_INVISIBLE (prop);
}
@@ -3586,12 +3593,12 @@ compute_stop_pos (struct it *it)
/* Set up variables for computing the stop position from text
property changes. */
XSETBUFFER (object, current_buffer);
- limit = make_number (IT_CHARPOS (*it) + TEXT_PROP_DISTANCE_LIMIT);
+ limit = make_fixnum (IT_CHARPOS (*it) + TEXT_PROP_DISTANCE_LIMIT);
}
/* Get the interval containing IT's position. Value is a null
interval if there isn't such an interval. */
- position = make_number (charpos);
+ position = make_fixnum (charpos);
iv = validate_interval_range (object, &position, &position, false);
if (iv)
{
@@ -3608,7 +3615,7 @@ compute_stop_pos (struct it *it)
for (next_iv = next_interval (iv);
(next_iv
&& (NILP (limit)
- || XFASTINT (limit) > next_iv->position));
+ || XFIXNAT (limit) > next_iv->position));
next_iv = next_interval (next_iv))
{
for (p = it_props; p->handler; ++p)
@@ -3625,10 +3632,10 @@ compute_stop_pos (struct it *it)
if (next_iv)
{
- if (INTEGERP (limit)
- && next_iv->position >= XFASTINT (limit))
+ if (FIXNUMP (limit)
+ && next_iv->position >= XFIXNAT (limit))
/* No text property change up to limit. */
- it->stop_charpos = min (XFASTINT (limit), it->stop_charpos);
+ it->stop_charpos = min (XFIXNAT (limit), it->stop_charpos);
else
/* Text properties change in next_iv. */
it->stop_charpos = min (it->stop_charpos, next_iv->position);
@@ -3743,7 +3750,7 @@ compute_display_string_pos (struct text_pos *position,
/* If the character at CHARPOS is where the display string begins,
return CHARPOS. */
- pos = make_number (charpos);
+ pos = make_fixnum (charpos);
if (STRINGP (object))
bufpos = string->bufpos;
else
@@ -3751,10 +3758,10 @@ compute_display_string_pos (struct text_pos *position,
tpos = *position;
if (!NILP (spec = Fget_char_property (pos, Qdisplay, object))
&& (charpos <= begb
- || !EQ (Fget_char_property (make_number (charpos - 1), Qdisplay,
+ || !EQ (Fget_char_property (make_fixnum (charpos - 1), Qdisplay,
object),
spec))
- && (rv = handle_display_spec (NULL, spec, object, Qnil, &tpos, bufpos,
+ && (rv = handle_display_spec (NULL, spec, object1, Qnil, &tpos, bufpos,
frame_window_p)))
{
if (rv == 2)
@@ -3764,10 +3771,10 @@ compute_display_string_pos (struct text_pos *position,
/* Look forward for the first character with a `display' property
that will replace the underlying text when displayed. */
- limpos = make_number (lim);
+ limpos = make_fixnum (lim);
do {
pos = Fnext_single_char_property_change (pos, Qdisplay, object1, limpos);
- CHARPOS (tpos) = XFASTINT (pos);
+ CHARPOS (tpos) = XFIXNAT (pos);
if (CHARPOS (tpos) >= lim)
{
*disp_prop = 0;
@@ -3781,7 +3788,7 @@ compute_display_string_pos (struct text_pos *position,
if (!STRINGP (object))
bufpos = CHARPOS (tpos);
} while (NILP (spec)
- || !(rv = handle_display_spec (NULL, spec, object, Qnil, &tpos,
+ || !(rv = handle_display_spec (NULL, spec, object1, Qnil, &tpos,
bufpos, frame_window_p)));
if (rv == 2)
*disp_prop = 2;
@@ -3800,7 +3807,7 @@ compute_display_string_end (ptrdiff_t charpos, struct bidi_string_data *string)
/* OBJECT = nil means current buffer. */
Lisp_Object object =
(string && STRINGP (string->lstring)) ? string->lstring : Qnil;
- Lisp_Object pos = make_number (charpos);
+ Lisp_Object pos = make_fixnum (charpos);
ptrdiff_t eob =
(STRINGP (object) || (string && string->s)) ? string->schars : ZV;
@@ -3828,7 +3835,7 @@ compute_display_string_end (ptrdiff_t charpos, struct bidi_string_data *string)
changes. */
pos = Fnext_single_char_property_change (pos, Qdisplay, object, Qnil);
- return XFASTINT (pos);
+ return XFIXNAT (pos);
}
@@ -3858,7 +3865,7 @@ handle_fontified_prop (struct it *it)
&& it->s == NULL
&& !NILP (Vfontification_functions)
&& !NILP (Vrun_hooks)
- && (pos = make_number (IT_CHARPOS (*it)),
+ && (pos = make_fixnum (IT_CHARPOS (*it)),
prop = Fget_char_property (pos, Qfontified, Qnil),
/* Ignore the special cased nil value always present at EOB since
no amount of fontifying will be able to change it. */
@@ -4068,7 +4075,7 @@ handle_face_prop (struct it *it)
might be a big deal. */
base_face_id = it->string_from_prefix_prop_p
? (!NILP (Vface_remapping_alist)
- ? lookup_basic_face (it->f, DEFAULT_FACE_ID)
+ ? lookup_basic_face (it->w, it->f, DEFAULT_FACE_ID)
: DEFAULT_FACE_ID)
: underlying_face_id (it);
}
@@ -4358,7 +4365,7 @@ handle_invisible_prop (struct it *it)
/* Get the value of the invisible text property at the
current position. Value will be nil if there is no such
property. */
- end_charpos = make_number (IT_STRING_CHARPOS (*it));
+ end_charpos = make_fixnum (IT_STRING_CHARPOS (*it));
prop = Fget_text_property (end_charpos, Qinvisible, it->string);
invis = TEXT_PROP_MEANS_INVISIBLE (prop);
@@ -4382,10 +4389,10 @@ handle_invisible_prop (struct it *it)
it->string, limit);
/* Since LIMIT is always an integer, so should be the
value returned by Fnext_single_property_change. */
- eassert (INTEGERP (end_charpos));
- if (INTEGERP (end_charpos))
+ eassert (FIXNUMP (end_charpos));
+ if (FIXNUMP (end_charpos))
{
- endpos = XFASTINT (end_charpos);
+ endpos = XFIXNAT (end_charpos);
prop = Fget_text_property (end_charpos, Qinvisible, it->string);
invis = TEXT_PROP_MEANS_INVISIBLE (prop);
if (invis == 2)
@@ -4461,7 +4468,7 @@ handle_invisible_prop (struct it *it)
/* First of all, is there invisible text at this position? */
tem = start_charpos = IT_CHARPOS (*it);
- pos = make_number (tem);
+ pos = make_fixnum (tem);
prop = get_char_property_and_overlay (pos, Qinvisible, it->window,
&overlay);
invis = TEXT_PROP_MEANS_INVISIBLE (prop);
@@ -4499,7 +4506,7 @@ handle_invisible_prop (struct it *it)
the char before the given position, i.e. if we
get invis = 0, this means that the char at
newpos is visible. */
- pos = make_number (newpos);
+ pos = make_fixnum (newpos);
prop = Fget_char_property (pos, Qinvisible, it->window);
invis = TEXT_PROP_MEANS_INVISIBLE (prop);
}
@@ -4754,7 +4761,7 @@ handle_display_prop (struct it *it)
if (!it->string_from_display_prop_p)
it->area = TEXT_AREA;
- propval = get_char_property_and_overlay (make_number (position->charpos),
+ propval = get_char_property_and_overlay (make_fixnum (position->charpos),
Qdisplay, object, &overlay);
if (NILP (propval))
return HANDLED_NORMALLY;
@@ -4870,13 +4877,13 @@ display_prop_end (struct it *it, Lisp_Object object, struct text_pos start_pos)
Lisp_Object end;
struct text_pos end_pos;
- end = Fnext_single_char_property_change (make_number (CHARPOS (start_pos)),
+ end = Fnext_single_char_property_change (make_fixnum (CHARPOS (start_pos)),
Qdisplay, object, Qnil);
- CHARPOS (end_pos) = XFASTINT (end);
+ CHARPOS (end_pos) = XFIXNAT (end);
if (STRINGP (object))
compute_string_pos (&end_pos, start_pos, it->string);
else
- BYTEPOS (end_pos) = CHAR_TO_BYTE (XFASTINT (end));
+ BYTEPOS (end_pos) = CHAR_TO_BYTE (XFIXNAT (end));
return end_pos;
}
@@ -4943,10 +4950,10 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object,
if (NILP (object))
XSETBUFFER (object, current_buffer);
specbind (Qobject, object);
- specbind (Qposition, make_number (CHARPOS (*position)));
- specbind (Qbuffer_position, make_number (bufpos));
+ specbind (Qposition, make_fixnum (CHARPOS (*position)));
+ specbind (Qbuffer_position, make_fixnum (bufpos));
form = safe_eval (form);
- unbind_to (count, Qnil);
+ form = unbind_to (count, form);
}
if (NILP (form))
@@ -4971,10 +4978,10 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object,
&& (EQ (XCAR (it->font_height), Qplus)
|| EQ (XCAR (it->font_height), Qminus))
&& CONSP (XCDR (it->font_height))
- && RANGED_INTEGERP (0, XCAR (XCDR (it->font_height)), INT_MAX))
+ && RANGED_FIXNUMP (0, XCAR (XCDR (it->font_height)), INT_MAX))
{
/* `(+ N)' or `(- N)' where N is an integer. */
- int steps = XINT (XCAR (XCDR (it->font_height)));
+ int steps = XFIXNUM (XCAR (XCDR (it->font_height)));
if (EQ (XCAR (it->font_height), Qplus))
steps = - steps;
it->face_id = smaller_face (it->f, it->face_id, steps);
@@ -4996,9 +5003,9 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object,
struct face *f;
f = FACE_FROM_ID (it->f,
- lookup_basic_face (it->f, DEFAULT_FACE_ID));
+ lookup_basic_face (it->w, it->f, DEFAULT_FACE_ID));
new_height = (XFLOATINT (it->font_height)
- * XINT (f->lface[LFACE_HEIGHT_INDEX]));
+ * XFIXNUM (f->lface[LFACE_HEIGHT_INDEX]));
}
else if (enable_eval_p)
{
@@ -5009,7 +5016,7 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object,
specbind (Qheight, face->lface[LFACE_HEIGHT_INDEX]);
value = safe_eval (it->font_height);
- unbind_to (count, Qnil);
+ value = unbind_to (count, value);
if (NUMBERP (value))
new_height = XFLOATINT (value);
@@ -5183,12 +5190,12 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object,
if (it)
{
- int face_id = lookup_basic_face (it->f, DEFAULT_FACE_ID);
+ int face_id = lookup_basic_face (it->w, it->f, DEFAULT_FACE_ID);
if (CONSP (XCDR (XCDR (spec))))
{
Lisp_Object face_name = XCAR (XCDR (XCDR (spec)));
- int face_id2 = lookup_derived_face (it->f, face_name,
+ int face_id2 = lookup_derived_face (it->w, it->f, face_name,
FRINGE_FACE_ID, false);
if (face_id2 >= 0)
face_id = face_id2;
@@ -5497,11 +5504,11 @@ string_buffer_position_lim (Lisp_Object string,
Lisp_Object limit, prop, pos;
bool found = false;
- pos = make_number (max (from, BEGV));
+ pos = make_fixnum (max (from, BEGV));
if (!back_p) /* looking forward */
{
- limit = make_number (min (to, ZV));
+ limit = make_fixnum (min (to, ZV));
while (!found && !EQ (pos, limit))
{
prop = Fget_char_property (pos, Qdisplay, Qnil);
@@ -5514,7 +5521,7 @@ string_buffer_position_lim (Lisp_Object string,
}
else /* looking back */
{
- limit = make_number (max (to, BEGV));
+ limit = make_fixnum (max (to, BEGV));
while (!found && !EQ (pos, limit))
{
prop = Fget_char_property (pos, Qdisplay, Qnil);
@@ -5526,7 +5533,7 @@ string_buffer_position_lim (Lisp_Object string,
}
}
- return found ? XINT (pos) : 0;
+ return found ? XFIXNUM (pos) : 0;
}
/* Determine which buffer position in current buffer STRING comes from.
@@ -5828,11 +5835,7 @@ compare_overlay_entries (const void *e1, const void *e2)
static void
load_overlay_strings (struct it *it, ptrdiff_t charpos)
{
- Lisp_Object overlay, window, str, invisible;
- struct Lisp_Overlay *ov;
- ptrdiff_t start, end;
- ptrdiff_t n = 0, i, j;
- int invis;
+ ptrdiff_t n = 0;
struct overlay_entry entriesbuf[20];
ptrdiff_t size = ARRAYELTS (entriesbuf);
struct overlay_entry *entries = entriesbuf;
@@ -5861,19 +5864,20 @@ load_overlay_strings (struct it *it, ptrdiff_t charpos)
entries[n].string = (STRING); \
entries[n].overlay = (OVERLAY); \
priority = Foverlay_get ((OVERLAY), Qpriority); \
- entries[n].priority = INTEGERP (priority) ? XINT (priority) : 0; \
+ entries[n].priority = FIXNUMP (priority) ? XFIXNUM (priority) : 0; \
entries[n].after_string_p = (AFTER_P); \
++n; \
} \
while (false)
/* Process overlay before the overlay center. */
- for (ov = current_buffer->overlays_before; ov; ov = ov->next)
+ for (struct Lisp_Overlay *ov = current_buffer->overlays_before;
+ ov; ov = ov->next)
{
- XSETMISC (overlay, ov);
+ Lisp_Object overlay = make_lisp_ptr (ov, Lisp_Vectorlike);
eassert (OVERLAYP (overlay));
- start = OVERLAY_POSITION (OVERLAY_START (overlay));
- end = OVERLAY_POSITION (OVERLAY_END (overlay));
+ ptrdiff_t start = OVERLAY_POSITION (OVERLAY_START (overlay));
+ ptrdiff_t end = OVERLAY_POSITION (OVERLAY_END (overlay));
if (end < charpos)
break;
@@ -5884,17 +5888,18 @@ load_overlay_strings (struct it *it, ptrdiff_t charpos)
continue;
/* Skip this overlay if it doesn't apply to IT->w. */
- window = Foverlay_get (overlay, Qwindow);
+ Lisp_Object window = Foverlay_get (overlay, Qwindow);
if (WINDOWP (window) && XWINDOW (window) != it->w)
continue;
/* If the text ``under'' the overlay is invisible, both before-
and after-strings from this overlay are visible; start and
end position are indistinguishable. */
- invisible = Foverlay_get (overlay, Qinvisible);
- invis = TEXT_PROP_MEANS_INVISIBLE (invisible);
+ Lisp_Object invisible = Foverlay_get (overlay, Qinvisible);
+ int invis = TEXT_PROP_MEANS_INVISIBLE (invisible);
/* If overlay has a non-empty before-string, record it. */
+ Lisp_Object str;
if ((start == charpos || (end == charpos && invis != 0))
&& (str = Foverlay_get (overlay, Qbefore_string), STRINGP (str))
&& SCHARS (str))
@@ -5908,12 +5913,13 @@ load_overlay_strings (struct it *it, ptrdiff_t charpos)
}
/* Process overlays after the overlay center. */
- for (ov = current_buffer->overlays_after; ov; ov = ov->next)
+ for (struct Lisp_Overlay *ov = current_buffer->overlays_after;
+ ov; ov = ov->next)
{
- XSETMISC (overlay, ov);
+ Lisp_Object overlay = make_lisp_ptr (ov, Lisp_Vectorlike);
eassert (OVERLAYP (overlay));
- start = OVERLAY_POSITION (OVERLAY_START (overlay));
- end = OVERLAY_POSITION (OVERLAY_END (overlay));
+ ptrdiff_t start = OVERLAY_POSITION (OVERLAY_START (overlay));
+ ptrdiff_t end = OVERLAY_POSITION (OVERLAY_END (overlay));
if (start > charpos)
break;
@@ -5924,16 +5930,17 @@ load_overlay_strings (struct it *it, ptrdiff_t charpos)
continue;
/* Skip this overlay if it doesn't apply to IT->w. */
- window = Foverlay_get (overlay, Qwindow);
+ Lisp_Object window = Foverlay_get (overlay, Qwindow);
if (WINDOWP (window) && XWINDOW (window) != it->w)
continue;
/* If the text ``under'' the overlay is invisible, it has a zero
dimension, and both before- and after-strings apply. */
- invisible = Foverlay_get (overlay, Qinvisible);
- invis = TEXT_PROP_MEANS_INVISIBLE (invisible);
+ Lisp_Object invisible = Foverlay_get (overlay, Qinvisible);
+ int invis = TEXT_PROP_MEANS_INVISIBLE (invisible);
/* If overlay has a non-empty before-string, record it. */
+ Lisp_Object str;
if ((start == charpos || (end == charpos && invis != 0))
&& (str = Foverlay_get (overlay, Qbefore_string), STRINGP (str))
&& SCHARS (str))
@@ -5959,12 +5966,11 @@ load_overlay_strings (struct it *it, ptrdiff_t charpos)
/* IT->current.overlay_string_index is the number of overlay strings
that have already been consumed by IT. Copy some of the
remaining overlay strings to IT->overlay_strings. */
- i = 0;
- j = it->current.overlay_string_index;
- while (i < OVERLAY_STRING_CHUNK_SIZE && j < n)
+ ptrdiff_t j = it->current.overlay_string_index;
+ for (ptrdiff_t i = 0; i < OVERLAY_STRING_CHUNK_SIZE && j < n; i++, j++)
{
it->overlay_strings[i] = entries[j].string;
- it->string_overlays[i++] = entries[j++].overlay;
+ it->string_overlays[i] = entries[j].overlay;
}
CHECK_IT (it);
@@ -6394,9 +6400,9 @@ forward_to_next_line_start (struct it *it, bool *skipped_p,
overlays, we can just use the position of the newline in
buffer text. */
if (it->stop_charpos >= limit
- || ((pos = Fnext_single_property_change (make_number (start),
+ || ((pos = Fnext_single_property_change (make_fixnum (start),
Qdisplay, Qnil,
- make_number (limit)),
+ make_fixnum (limit)),
NILP (pos))
&& next_overlay_change (start) == ZV))
{
@@ -6472,7 +6478,7 @@ back_to_previous_visible_line_start (struct it *it)
/* Check the newline before point for invisibility. */
{
Lisp_Object prop;
- prop = Fget_char_property (make_number (IT_CHARPOS (*it) - 1),
+ prop = Fget_char_property (make_fixnum (IT_CHARPOS (*it) - 1),
Qinvisible, it->window);
if (TEXT_PROP_MEANS_INVISIBLE (prop) != 0)
continue;
@@ -6505,7 +6511,7 @@ back_to_previous_visible_line_start (struct it *it)
it2.from_disp_prop_p = false;
if (handle_display_prop (&it2) == HANDLED_RETURN
&& !NILP (val = get_char_property_and_overlay
- (make_number (pos), Qdisplay, Qnil, &overlay))
+ (make_fixnum (pos), Qdisplay, Qnil, &overlay))
&& (OVERLAYP (overlay)
? (beg = OVERLAY_POSITION (OVERLAY_START (overlay)))
: get_property_and_range (pos, Qdisplay, &val, &beg, &end, Qnil)))
@@ -6993,7 +6999,7 @@ merge_escape_glyph_face (struct it *it)
else
{
/* Merge the `escape-glyph' face into the current face. */
- face_id = merge_faces (it->f, Qescape_glyph, 0, it->face_id);
+ face_id = merge_faces (it->w, Qescape_glyph, 0, it->face_id);
last_escape_glyph_frame = it->f;
last_escape_glyph_face_id = it->face_id;
last_escape_glyph_merged_face_id = face_id;
@@ -7018,7 +7024,7 @@ merge_glyphless_glyph_face (struct it *it)
else
{
/* Merge the `glyphless-char' face into the current face. */
- face_id = merge_faces (it->f, Qglyphless_char, 0, it->face_id);
+ face_id = merge_faces (it->w, Qglyphless_char, 0, it->face_id);
last_glyphless_glyph_frame = it->f;
last_glyphless_glyph_face_id = it->face_id;
last_glyphless_glyph_merged_face_id = face_id;
@@ -7192,7 +7198,7 @@ get_next_display_element (struct it *it)
}
face_id = (lface_id
- ? merge_faces (it->f, Qt, lface_id, it->face_id)
+ ? merge_faces (it->w, Qt, lface_id, it->face_id)
: merge_escape_glyph_face (it));
XSETINT (it->ctl_chars[0], g);
@@ -7207,7 +7213,7 @@ get_next_display_element (struct it *it)
if (nonascii_space_p && EQ (Vnobreak_char_display, Qt))
{
/* Merge `nobreak-space' into the current face. */
- face_id = merge_faces (it->f, Qnobreak_space, 0,
+ face_id = merge_faces (it->w, Qnobreak_space, 0,
it->face_id);
XSETINT (it->ctl_chars[0], ' ');
ctl_len = 1;
@@ -7220,7 +7226,7 @@ get_next_display_element (struct it *it)
if (nonascii_hyphen_p && EQ (Vnobreak_char_display, Qt))
{
/* Merge `nobreak-space' into the current face. */
- face_id = merge_faces (it->f, Qnobreak_hyphen, 0,
+ face_id = merge_faces (it->w, Qnobreak_hyphen, 0,
it->face_id);
XSETINT (it->ctl_chars[0], '-');
ctl_len = 1;
@@ -7240,7 +7246,7 @@ get_next_display_element (struct it *it)
}
face_id = (lface_id
- ? merge_faces (it->f, Qt, lface_id, it->face_id)
+ ? merge_faces (it->w, Qt, lface_id, it->face_id)
: merge_escape_glyph_face (it));
/* Draw non-ASCII space/hyphen with escape glyph: */
@@ -7868,7 +7874,7 @@ next_element_from_display_vector (struct it *it)
{
int lface_id = GLYPH_CODE_FACE (gc);
if (lface_id > 0)
- it->face_id = merge_faces (it->f, Qt, lface_id,
+ it->face_id = merge_faces (it->w, Qt, lface_id,
it->saved_face_id);
}
@@ -7897,7 +7903,7 @@ next_element_from_display_vector (struct it *it)
GLYPH_CODE_FACE (it->dpvec[it->current.dpvec_index + 1]);
if (lface_id > 0)
- next_face_id = merge_faces (it->f, Qt, lface_id,
+ next_face_id = merge_faces (it->w, Qt, lface_id,
it->saved_face_id);
}
}
@@ -8197,7 +8203,7 @@ next_element_from_c_string (struct it *it)
eassert (!it->bidi_p || it->s == it->bidi_it.string.s);
it->what = IT_CHARACTER;
BYTEPOS (it->position) = CHARPOS (it->position) = 0;
- it->object = make_number (0);
+ it->object = make_fixnum (0);
/* With bidi reordering, the character to display might not be the
character at IT_CHARPOS. BIDI_IT.FIRST_ELT means that
@@ -8393,7 +8399,7 @@ next_element_from_buffer (struct it *it)
eassert (IT_CHARPOS (*it) >= BEGV);
eassert (NILP (it->string) && !it->s);
eassert (!it->bidi_p
- || (EQ (it->bidi_it.string.lstring, Qnil)
+ || (NILP (it->bidi_it.string.lstring)
&& it->bidi_it.string.s == NULL));
/* With bidi reordering, the character to display might not be the
@@ -8579,7 +8585,7 @@ run_redisplay_end_trigger_hook (struct it *it)
them again, even if they get an error. */
wset_redisplay_end_trigger (it->w, Qnil);
CALLN (Frun_hook_with_args, Qredisplay_end_trigger_functions, it->window,
- make_number (charpos));
+ make_fixnum (charpos));
/* Notice if it changed the face of the character we are on. */
handle_face_prop (it);
@@ -10152,8 +10158,8 @@ include the height of both, if present, in the return value. */)
}
else
{
- CHECK_NUMBER_COERCE_MARKER (from);
- start = min (max (XINT (from), BEGV), ZV);
+ CHECK_FIXNUM_COERCE_MARKER (from);
+ start = min (max (XFIXNUM (from), BEGV), ZV);
}
if (NILP (to))
@@ -10169,17 +10175,17 @@ include the height of both, if present, in the return value. */)
}
else
{
- CHECK_NUMBER_COERCE_MARKER (to);
- end = max (start, min (XINT (to), ZV));
+ CHECK_FIXNUM_COERCE_MARKER (to);
+ end = max (start, min (XFIXNUM (to), ZV));
}
- if (!NILP (x_limit) && RANGED_INTEGERP (0, x_limit, INT_MAX))
- max_x = XINT (x_limit);
+ if (!NILP (x_limit) && RANGED_FIXNUMP (0, x_limit, INT_MAX))
+ max_x = XFIXNUM (x_limit);
if (NILP (y_limit))
max_y = INT_MAX;
- else if (RANGED_INTEGERP (0, y_limit, INT_MAX))
- max_y = XINT (y_limit);
+ else if (RANGED_FIXNUMP (0, y_limit, INT_MAX))
+ max_y = XFIXNUM (y_limit);
itdata = bidi_shelve_cache ();
SET_TEXT_POS (startp, start, CHAR_TO_BYTE (start));
@@ -10259,7 +10265,7 @@ include the height of both, if present, in the return value. */)
if (old_b)
set_buffer_internal (old_b);
- return Fcons (make_number (x), make_number (y));
+ return Fcons (make_fixnum (x), make_fixnum (y));
}
/***********************************************************************
@@ -10427,6 +10433,13 @@ message_dolog (const char *m, ptrdiff_t nbytes, bool nlflag, bool multibyte)
ptrdiff_t this_bol, this_bol_byte, prev_bol, prev_bol_byte;
printmax_t dups;
+ /* Since we call del_range_both passing false for PREPARE,
+ we aren't prepared to run modification hooks (we could
+ end up calling modification hooks from another buffer and
+ only with AFTER=t, Bug#21824). */
+ ptrdiff_t count = SPECPDL_INDEX ();
+ specbind (Qinhibit_modification_hooks, Qt);
+
insert_1_both ("\n", 1, 1, true, false, false);
scan_newline (Z, Z_BYTE, BEG, BEG_BYTE, -2, false);
@@ -10466,12 +10479,14 @@ message_dolog (const char *m, ptrdiff_t nbytes, bool nlflag, bool multibyte)
in the *Messages* buffer now, delete the oldest ones.
This is safe because we don't have undo in this buffer. */
- if (NATNUMP (Vmessage_log_max))
+ if (FIXNATP (Vmessage_log_max))
{
scan_newline (Z, Z_BYTE, BEG, BEG_BYTE,
- -XFASTINT (Vmessage_log_max) - 1, false);
+ -XFIXNAT (Vmessage_log_max) - 1, false);
del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, false);
}
+
+ unbind_to (count, Qnil);
}
BEGV = marker_position (oldbegv);
BEGV_BYTE = marker_byte_position (oldbegv);
@@ -10553,7 +10568,7 @@ message_log_check_duplicate (ptrdiff_t prev_bol_byte, ptrdiff_t this_bol_byte)
/* Display an echo area message M with a specified length of NBYTES
- bytes. The string may include null characters. If M is not a
+ bytes. The string may include NUL characters. If M is not a
string, clear out any existing message, and let the mini-buffer
text show through.
@@ -10657,7 +10672,7 @@ message3_nolog (Lisp_Object m)
}
-/* Display a null-terminated echo area message M. If M is 0, clear
+/* Display a NUL-terminated echo area message M. If M is 0, clear
out any existing message, and let the mini-buffer text show through.
The buffer M must continue to exist until after the echo area gets
@@ -10972,22 +10987,22 @@ with_echo_area_buffer_unwind_data (struct window *w)
Vwith_echo_area_save_vector = Qnil;
if (NILP (vector))
- vector = Fmake_vector (make_number (11), Qnil);
+ vector = make_nil_vector (11);
XSETBUFFER (tmp, current_buffer); ASET (vector, i, tmp); ++i;
ASET (vector, i, Vdeactivate_mark); ++i;
- ASET (vector, i, make_number (windows_or_buffers_changed)); ++i;
+ ASET (vector, i, make_fixnum (windows_or_buffers_changed)); ++i;
if (w)
{
XSETWINDOW (tmp, w); ASET (vector, i, tmp); ++i;
ASET (vector, i, w->contents); ++i;
- ASET (vector, i, make_number (marker_position (w->pointm))); ++i;
- ASET (vector, i, make_number (marker_byte_position (w->pointm))); ++i;
- ASET (vector, i, make_number (marker_position (w->old_pointm))); ++i;
- ASET (vector, i, make_number (marker_byte_position (w->old_pointm))); ++i;
- ASET (vector, i, make_number (marker_position (w->start))); ++i;
- ASET (vector, i, make_number (marker_byte_position (w->start))); ++i;
+ ASET (vector, i, make_fixnum (marker_position (w->pointm))); ++i;
+ ASET (vector, i, make_fixnum (marker_byte_position (w->pointm))); ++i;
+ ASET (vector, i, make_fixnum (marker_position (w->old_pointm))); ++i;
+ ASET (vector, i, make_fixnum (marker_byte_position (w->old_pointm))); ++i;
+ ASET (vector, i, make_fixnum (marker_position (w->start))); ++i;
+ ASET (vector, i, make_fixnum (marker_byte_position (w->start))); ++i;
}
else
{
@@ -11009,7 +11024,7 @@ unwind_with_echo_area_buffer (Lisp_Object vector)
{
set_buffer_internal_1 (XBUFFER (AREF (vector, 0)));
Vdeactivate_mark = AREF (vector, 1);
- windows_or_buffers_changed = XFASTINT (AREF (vector, 2));
+ windows_or_buffers_changed = XFIXNAT (AREF (vector, 2));
if (WINDOWP (AREF (vector, 3)))
{
@@ -11020,15 +11035,15 @@ unwind_with_echo_area_buffer (Lisp_Object vector)
buffer = AREF (vector, 4);
wset_buffer (w, buffer);
- set_marker_both (w->pointm, buffer,
- XFASTINT (AREF (vector, 5)),
- XFASTINT (AREF (vector, 6)));
- set_marker_both (w->old_pointm, buffer,
- XFASTINT (AREF (vector, 7)),
- XFASTINT (AREF (vector, 8)));
- set_marker_both (w->start, buffer,
- XFASTINT (AREF (vector, 9)),
- XFASTINT (AREF (vector, 10)));
+ set_marker_restricted_both (w->pointm, buffer,
+ XFIXNAT (AREF (vector, 5)),
+ XFIXNAT (AREF (vector, 6)));
+ set_marker_restricted_both (w->old_pointm, buffer,
+ XFIXNAT (AREF (vector, 7)),
+ XFIXNAT (AREF (vector, 8)));
+ set_marker_restricted_both (w->start, buffer,
+ XFIXNAT (AREF (vector, 9)),
+ XFIXNAT (AREF (vector, 10)));
}
Vwith_echo_area_save_vector = vector;
@@ -11070,10 +11085,18 @@ setup_echo_area_for_printing (bool multibyte_p)
}
TEMP_SET_PT_BOTH (BEG, BEG_BYTE);
- /* Set up the buffer for the multibyteness we need. */
- if (multibyte_p
- != !NILP (BVAR (current_buffer, enable_multibyte_characters)))
- Fset_buffer_multibyte (multibyte_p ? Qt : Qnil);
+ /* Set up the buffer for the multibyteness we need. We always
+ set it to be multibyte, except when
+ unibyte-display-via-language-environment is non-nil and the
+ buffer from which we are called is unibyte, because in that
+ case unibyte characters should not be displayed as octal
+ escapes. */
+ if (unibyte_display_via_language_environment
+ && !multibyte_p
+ && !NILP (BVAR (current_buffer, enable_multibyte_characters)))
+ Fset_buffer_multibyte (Qnil);
+ else if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
+ Fset_buffer_multibyte (Qt);
/* Raise the frame containing the echo area. */
if (minibuffer_auto_raise)
@@ -11149,7 +11172,7 @@ display_echo_area (struct window *w)
/* Helper for display_echo_area. Display the current buffer which
contains the current echo area message in window W, a mini-window,
- a pointer to which is passed in A1. A2..A4 are currently not used.
+ a pointer to which is passed in A1. A2 is currently not used.
Change the height of W so that all of the message is displayed.
Value is true if height of W was changed. */
@@ -11210,8 +11233,8 @@ resize_echo_area_exactly (void)
/* Callback function for with_echo_area_buffer, when used from
resize_echo_area_exactly. A1 contains a pointer to the window to
resize, EXACTLY non-nil means resize the mini-window exactly to the
- size of the text displayed. A3 and A4 are not used. Value is what
- resize_mini_window returns. */
+ size of the text displayed. Value is what resize_mini_window
+ returns. */
static bool
resize_mini_window_1 (ptrdiff_t a1, Lisp_Object exactly)
@@ -11236,15 +11259,10 @@ bool
resize_mini_window (struct window *w, bool exact_p)
{
struct frame *f = XFRAME (w->frame);
- bool window_height_changed_p = false;
+ int old_height = WINDOW_PIXEL_HEIGHT (w);
eassert (MINI_WINDOW_P (w));
- /* By default, start display at the beginning. */
- set_marker_both (w->start, w->contents,
- BUF_BEGV (XBUFFER (w->contents)),
- BUF_BEGV_BYTE (XBUFFER (w->contents)));
-
/* Don't resize windows while redisplaying a window; it would
confuse redisplay functions when the size of the window they are
displaying changes from under them. Such a resizing can happen,
@@ -11255,19 +11273,30 @@ resize_mini_window (struct window *w, bool exact_p)
return false;
/* Nil means don't try to resize. */
- if (NILP (Vresize_mini_windows)
+ if ((NILP (Vresize_mini_windows)
+ && (NILP (resize_mini_frames) || !FRAME_MINIBUF_ONLY_P (f)))
|| (FRAME_X_P (f) && FRAME_X_OUTPUT (f) == NULL))
return false;
- if (!FRAME_MINIBUF_ONLY_P (f))
+ /* By default, start display at the beginning. */
+ set_marker_both (w->start, w->contents,
+ BUF_BEGV (XBUFFER (w->contents)),
+ BUF_BEGV_BYTE (XBUFFER (w->contents)));
+
+ if (FRAME_MINIBUF_ONLY_P (f))
+ {
+ if (!NILP (resize_mini_frames))
+ safe_call1 (Qwindow__resize_mini_frame, WINDOW_FRAME (w));
+ }
+ else
{
struct it it;
- int total_height = (WINDOW_PIXEL_HEIGHT (XWINDOW (FRAME_ROOT_WINDOW (f)))
- + WINDOW_PIXEL_HEIGHT (w));
+ int old_height = WINDOW_PIXEL_HEIGHT (w);
int unit = FRAME_LINE_HEIGHT (f);
int height, max_height;
struct text_pos start;
struct buffer *old_current_buffer = NULL;
+ int windows_height = FRAME_WINDOWS_HEIGHT (f);
if (current_buffer != XBUFFER (w->contents))
{
@@ -11279,14 +11308,14 @@ resize_mini_window (struct window *w, bool exact_p)
/* Compute the max. number of lines specified by the user. */
if (FLOATP (Vmax_mini_window_height))
- max_height = XFLOAT_DATA (Vmax_mini_window_height) * total_height;
- else if (INTEGERP (Vmax_mini_window_height))
- max_height = XINT (Vmax_mini_window_height) * unit;
+ max_height = XFLOAT_DATA (Vmax_mini_window_height) * windows_height;
+ else if (FIXNUMP (Vmax_mini_window_height))
+ max_height = XFIXNUM (Vmax_mini_window_height) * unit;
else
- max_height = total_height / 4;
+ max_height = windows_height / 4;
/* Correct that max. height if it's bogus. */
- max_height = clip_to_bounds (unit, max_height, total_height);
+ max_height = clip_to_bounds (unit, max_height, windows_height);
/* Find out the height of the text in the window. */
if (it.line_wrap == TRUNCATE)
@@ -11312,63 +11341,27 @@ resize_mini_window (struct window *w, bool exact_p)
}
else
SET_TEXT_POS (start, BEGV, BEGV_BYTE);
+
SET_MARKER_FROM_TEXT_POS (w->start, start);
if (EQ (Vresize_mini_windows, Qgrow_only))
{
/* Let it grow only, until we display an empty message, in which
case the window shrinks again. */
- if (height > WINDOW_PIXEL_HEIGHT (w))
- {
- int old_height = WINDOW_PIXEL_HEIGHT (w);
-
- FRAME_WINDOWS_FROZEN (f) = true;
- grow_mini_window (w, height - WINDOW_PIXEL_HEIGHT (w), true);
- window_height_changed_p = WINDOW_PIXEL_HEIGHT (w) != old_height;
- }
- else if (height < WINDOW_PIXEL_HEIGHT (w)
- && (exact_p || BEGV == ZV))
- {
- int old_height = WINDOW_PIXEL_HEIGHT (w);
-
- FRAME_WINDOWS_FROZEN (f) = false;
- shrink_mini_window (w, true);
- window_height_changed_p = WINDOW_PIXEL_HEIGHT (w) != old_height;
- }
- }
- else
- {
- /* Always resize to exact size needed. */
- if (height > WINDOW_PIXEL_HEIGHT (w))
- {
- int old_height = WINDOW_PIXEL_HEIGHT (w);
-
- FRAME_WINDOWS_FROZEN (f) = true;
- grow_mini_window (w, height - WINDOW_PIXEL_HEIGHT (w), true);
- window_height_changed_p = WINDOW_PIXEL_HEIGHT (w) != old_height;
- }
- else if (height < WINDOW_PIXEL_HEIGHT (w))
- {
- int old_height = WINDOW_PIXEL_HEIGHT (w);
-
- FRAME_WINDOWS_FROZEN (f) = false;
- shrink_mini_window (w, true);
-
- if (height)
- {
- FRAME_WINDOWS_FROZEN (f) = true;
- grow_mini_window (w, height - WINDOW_PIXEL_HEIGHT (w), true);
- }
-
- window_height_changed_p = WINDOW_PIXEL_HEIGHT (w) != old_height;
- }
+ if (height > old_height)
+ grow_mini_window (w, height - old_height);
+ else if (height < old_height && (exact_p || BEGV == ZV))
+ shrink_mini_window (w);
}
+ else if (height != old_height)
+ /* Always resize to exact size needed. */
+ grow_mini_window (w, height - old_height);
if (old_current_buffer)
set_buffer_internal (old_current_buffer);
}
- return window_height_changed_p;
+ return WINDOW_PIXEL_HEIGHT (w) != old_height;
}
@@ -11519,10 +11512,17 @@ set_message_1 (ptrdiff_t a1, Lisp_Object string)
{
eassert (STRINGP (string));
- /* Change multibyteness of the echo buffer appropriately. */
- if (message_enable_multibyte
- != !NILP (BVAR (current_buffer, enable_multibyte_characters)))
- Fset_buffer_multibyte (message_enable_multibyte ? Qt : Qnil);
+ /* Change multibyteness of the echo buffer appropriately. We always
+ set it to be multibyte, except when
+ unibyte-display-via-language-environment is non-nil and the
+ string to display is unibyte, because in that case unibyte
+ characters should not be displayed as octal escapes. */
+ if (!message_enable_multibyte
+ && unibyte_display_via_language_environment
+ && !NILP (BVAR (current_buffer, enable_multibyte_characters)))
+ Fset_buffer_multibyte (Qnil);
+ else if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
+ Fset_buffer_multibyte (Qt);
bset_truncate_lines (current_buffer, message_truncate_lines ? Qt : Qnil);
if (!NILP (BVAR (current_buffer, bidi_display_reordering)))
@@ -11830,10 +11830,10 @@ format_mode_line_unwind_data (struct frame *target_frame,
Vmode_line_unwind_vector = Qnil;
if (NILP (vector))
- vector = Fmake_vector (make_number (10), Qnil);
+ vector = make_nil_vector (12);
- ASET (vector, 0, make_number (mode_line_target));
- ASET (vector, 1, make_number (MODE_LINE_NOPROP_LEN (0)));
+ ASET (vector, 0, make_fixnum (mode_line_target));
+ ASET (vector, 1, make_fixnum (MODE_LINE_NOPROP_LEN (0)));
ASET (vector, 2, mode_line_string_list);
ASET (vector, 3, save_proptrans ? mode_line_proptrans_alist : Qt);
ASET (vector, 4, mode_line_string_face);
@@ -11847,12 +11847,24 @@ format_mode_line_unwind_data (struct frame *target_frame,
ASET (vector, 7, owin);
if (target_frame)
{
+ Lisp_Object buffer = XWINDOW (target_frame->selected_window)->contents;
+ struct buffer *b = XBUFFER (buffer);
+ struct buffer *cb = current_buffer;
+
/* Similarly to `with-selected-window', if the operation selects
a window on another frame, we must restore that frame's
selected window, and (for a tty) the top-frame. */
ASET (vector, 8, target_frame->selected_window);
if (FRAME_TERMCAP_P (target_frame))
ASET (vector, 9, FRAME_TTY (target_frame)->top_frame);
+
+ /* If we select a window on another frame, make sure that that
+ selection does not leave its buffer's point modified when
+ unwinding (Bug#32777). */
+ ASET (vector, 10, buffer);
+ current_buffer = b;
+ ASET (vector, 11, build_marker (current_buffer, PT, PT_BYTE));
+ current_buffer = cb;
}
return vector;
@@ -11865,8 +11877,8 @@ unwind_format_mode_line (Lisp_Object vector)
Lisp_Object target_frame_window = AREF (vector, 8);
Lisp_Object old_top_frame = AREF (vector, 9);
- mode_line_target = XINT (AREF (vector, 0));
- mode_line_noprop_ptr = mode_line_noprop_buf + XINT (AREF (vector, 1));
+ mode_line_target = XFIXNUM (AREF (vector, 0));
+ mode_line_noprop_ptr = mode_line_noprop_buf + XFIXNUM (AREF (vector, 1));
mode_line_string_list = AREF (vector, 2);
if (! EQ (AREF (vector, 3), Qt))
mode_line_proptrans_alist = AREF (vector, 3);
@@ -11892,6 +11904,24 @@ unwind_format_mode_line (Lisp_Object vector)
}
Fselect_window (old_window, Qt);
+
+ /* Restore point of target_frame_window's buffer (Bug#32777).
+ But do this only after old_window has been reselected to
+ avoid that the window point of target_frame_window moves. */
+ if (!NILP (target_frame_window))
+ {
+ Lisp_Object buffer = AREF (vector, 10);
+
+ if (BUFFER_LIVE_P (XBUFFER (buffer)))
+ {
+ struct buffer *cb = current_buffer;
+
+ current_buffer = XBUFFER (buffer);
+ set_point_from_marker (AREF (vector, 11));
+ ASET (vector, 11, Qnil);
+ current_buffer = cb;
+ }
+ }
}
if (!NILP (AREF (vector, 6)))
@@ -11976,7 +12006,7 @@ x_consider_frame_title (Lisp_Object frame)
if ((FRAME_WINDOW_P (f)
|| FRAME_MINIBUF_ONLY_P (f)
|| f->explicit_name)
- && NILP (Fframe_parameter (frame, Qtooltip)))
+ && !FRAME_TOOLTIP_P (f))
{
/* Do we have more than one visible frame on this X display? */
Lisp_Object tail, other_frame, fmt;
@@ -11993,8 +12023,8 @@ x_consider_frame_title (Lisp_Object frame)
if (tf != f
&& FRAME_KBOARD (tf) == FRAME_KBOARD (f)
&& !FRAME_MINIBUF_ONLY_P (tf)
- && !EQ (other_frame, tip_frame)
&& !FRAME_PARENT_FRAME (tf)
+ && !FRAME_TOOLTIP_P (tf)
&& (FRAME_VISIBLE_P (tf) || FRAME_ICONIFIED_P (tf)))
break;
}
@@ -12002,19 +12032,26 @@ x_consider_frame_title (Lisp_Object frame)
/* Set global variable indicating that multiple frames exist. */
multiple_frames = CONSP (tail);
- /* Switch to the buffer of selected window of the frame. Set up
- mode_line_target so that display_mode_element will output into
- mode_line_noprop_buf; then display the title. */
- record_unwind_protect (unwind_format_mode_line,
- format_mode_line_unwind_data
- (f, current_buffer, selected_window, false));
/* select-frame calls resize_mini_window, which could resize the
mini-window and by that undo the effect of this redisplay
cycle wrt minibuffer and echo-area display. Binding
inhibit-redisplay to t makes the call to resize_mini_window a
no-op, thus avoiding the adverse side effects. */
+
+ /* The following was moved before the record_unwind_protect form
+ below to inhibit redisplay also when restoring the selected
+ window/frame: This avoids that resize_mini_window sizes back
+ the minibuffer window of a temporarily selected frame. See
+ Bug#34317. */
specbind (Qinhibit_redisplay, Qt);
+ /* Switch to the buffer of selected window of the frame. Set up
+ mode_line_target so that display_mode_element will output into
+ mode_line_noprop_buf; then display the title. */
+ record_unwind_protect (unwind_format_mode_line,
+ format_mode_line_unwind_data
+ (f, current_buffer, selected_window, false));
+
Fselect_window (f->selected_window, Qt);
set_buffer_internal_1
(XBUFFER (XWINDOW (f->selected_window)->contents));
@@ -12063,13 +12100,6 @@ prepare_menu_bars (void)
{
bool all_windows = windows_or_buffers_changed || update_mode_lines;
bool some_windows = REDISPLAY_SOME_P ();
- Lisp_Object tooltip_frame;
-
-#ifdef HAVE_WINDOW_SYSTEM
- tooltip_frame = tip_frame;
-#else
- tooltip_frame = Qnil;
-#endif
if (FUNCTIONP (Vpre_redisplay_function))
{
@@ -12110,7 +12140,7 @@ prepare_menu_bars (void)
&& !XBUFFER (w->contents)->text->redisplay)
continue;
- if (!EQ (frame, tooltip_frame)
+ if (!FRAME_TOOLTIP_P (f)
&& !FRAME_PARENT_FRAME (f)
&& (FRAME_ICONIFIED_P (f)
|| FRAME_VISIBLE_P (f) == 1
@@ -12148,7 +12178,7 @@ prepare_menu_bars (void)
struct window *w = XWINDOW (FRAME_SELECTED_WINDOW (f));
/* Ignore tooltip frame. */
- if (EQ (frame, tooltip_frame))
+ if (FRAME_TOOLTIP_P (f))
continue;
if (some_windows
@@ -12157,8 +12187,6 @@ prepare_menu_bars (void)
&& !XBUFFER (w->contents)->text->redisplay)
continue;
- run_window_size_change_functions (frame);
-
if (FRAME_PARENT_FRAME (f))
continue;
@@ -12209,8 +12237,7 @@ update_menu_bar (struct frame *f, bool save_match_data, bool hooks_run)
if (FRAME_WINDOW_P (f)
?
-#if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \
- || defined (HAVE_NS) || defined (USE_GTK)
+#ifdef HAVE_EXT_MENU_BAR
FRAME_EXTERNAL_MENU_BAR (f)
#else
FRAME_MENU_BAR_LINES (f) > 0
@@ -12263,8 +12290,7 @@ update_menu_bar (struct frame *f, bool save_match_data, bool hooks_run)
fset_menu_bar_items (f, menu_bar_items (FRAME_MENU_BAR_ITEMS (f)));
/* Redisplay the menu bar in case we changed it. */
-#if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \
- || defined (HAVE_NS) || defined (USE_GTK)
+#ifdef HAVE_EXT_MENU_BAR
if (FRAME_WINDOW_P (f))
{
#if defined (HAVE_NS)
@@ -12278,11 +12304,11 @@ update_menu_bar (struct frame *f, bool save_match_data, bool hooks_run)
/* On a terminal screen, the menu bar is an ordinary screen
line, and this makes it get updated. */
w->update_mode_line = true;
-#else /* ! (USE_X_TOOLKIT || HAVE_NTGUI || HAVE_NS || USE_GTK) */
+#else /* ! (HAVE_EXT_MENU_BAR) */
/* In the non-toolkit version, the menu bar is an ordinary screen
line, and this makes it get updated. */
w->update_mode_line = true;
-#endif /* ! (USE_X_TOOLKIT || HAVE_NTGUI || HAVE_NS || USE_GTK) */
+#endif /* HAVE_EXT_MENU_BAR */
unbind_to (count, Qnil);
set_buffer_internal_1 (prev);
@@ -12320,7 +12346,7 @@ fast_set_selected_frame (Lisp_Object frame)
static void
update_tool_bar (struct frame *f, bool save_match_data)
{
-#if defined (USE_GTK) || defined (HAVE_NS)
+#ifdef HAVE_EXT_TOOL_BAR
bool do_update = FRAME_EXTERNAL_TOOL_BAR (f);
#else
bool do_update = (WINDOWP (f->tool_bar_window)
@@ -12405,7 +12431,7 @@ update_tool_bar (struct frame *f, bool save_match_data)
}
}
-#if ! defined (USE_GTK) && ! defined (HAVE_NS)
+#ifndef HAVE_EXT_TOOL_BAR
/* Set F->desired_tool_bar_string to a Lisp string representing frame
F's desired tool-bar contents. F->tool_bar_items must have
@@ -12433,11 +12459,11 @@ build_desired_tool_bar_string (struct frame *f)
/* Reuse f->desired_tool_bar_string, if possible. */
if (size < size_needed || NILP (f->desired_tool_bar_string))
fset_desired_tool_bar_string
- (f, Fmake_string (make_number (size_needed), make_number (' ')));
+ (f, Fmake_string (make_fixnum (size_needed), make_fixnum (' '), Qnil));
else
{
AUTO_LIST4 (props, Qdisplay, Qnil, Qmenu_item, Qnil);
- Fremove_text_properties (make_number (0), make_number (size),
+ Fremove_text_properties (make_fixnum (0), make_fixnum (size),
props, f->desired_tool_bar_string);
}
@@ -12482,25 +12508,26 @@ build_desired_tool_bar_string (struct frame *f)
/* Compute margin and relief to draw. */
relief = (tool_bar_button_relief >= 0
- ? tool_bar_button_relief
+ ? min (tool_bar_button_relief,
+ min (INT_MAX, MOST_POSITIVE_FIXNUM))
: DEFAULT_TOOL_BAR_BUTTON_RELIEF);
hmargin = vmargin = relief;
- if (RANGED_INTEGERP (1, Vtool_bar_button_margin,
+ if (RANGED_FIXNUMP (1, Vtool_bar_button_margin,
INT_MAX - max (hmargin, vmargin)))
{
- hmargin += XFASTINT (Vtool_bar_button_margin);
- vmargin += XFASTINT (Vtool_bar_button_margin);
+ hmargin += XFIXNAT (Vtool_bar_button_margin);
+ vmargin += XFIXNAT (Vtool_bar_button_margin);
}
else if (CONSP (Vtool_bar_button_margin))
{
- if (RANGED_INTEGERP (1, XCAR (Vtool_bar_button_margin),
+ if (RANGED_FIXNUMP (1, XCAR (Vtool_bar_button_margin),
INT_MAX - hmargin))
- hmargin += XFASTINT (XCAR (Vtool_bar_button_margin));
+ hmargin += XFIXNAT (XCAR (Vtool_bar_button_margin));
- if (RANGED_INTEGERP (1, XCDR (Vtool_bar_button_margin),
+ if (RANGED_FIXNUMP (1, XCDR (Vtool_bar_button_margin),
INT_MAX - vmargin))
- vmargin += XFASTINT (XCDR (Vtool_bar_button_margin));
+ vmargin += XFIXNAT (XCDR (Vtool_bar_button_margin));
}
if (auto_raise_tool_bar_buttons_p)
@@ -12509,7 +12536,7 @@ build_desired_tool_bar_string (struct frame *f)
selected. */
if (selected_p)
{
- plist = Fplist_put (plist, QCrelief, make_number (-relief));
+ plist = Fplist_put (plist, QCrelief, make_fixnum (-relief));
hmargin -= relief;
vmargin -= relief;
}
@@ -12521,8 +12548,8 @@ build_desired_tool_bar_string (struct frame *f)
raised relief. */
plist = Fplist_put (plist, QCrelief,
(selected_p
- ? make_number (-relief)
- : make_number (relief)));
+ ? make_fixnum (-relief)
+ : make_fixnum (relief)));
hmargin -= relief;
vmargin -= relief;
}
@@ -12531,11 +12558,11 @@ build_desired_tool_bar_string (struct frame *f)
if (hmargin || vmargin)
{
if (hmargin == vmargin)
- plist = Fplist_put (plist, QCmargin, make_number (hmargin));
+ plist = Fplist_put (plist, QCmargin, make_fixnum (hmargin));
else
plist = Fplist_put (plist, QCmargin,
- Fcons (make_number (hmargin),
- make_number (vmargin)));
+ Fcons (make_fixnum (hmargin),
+ make_fixnum (vmargin)));
}
/* If button is not enabled, and we don't have special images
@@ -12550,7 +12577,7 @@ build_desired_tool_bar_string (struct frame *f)
vector. */
image = Fcons (Qimage, plist);
AUTO_LIST4 (props, Qdisplay, image, Qmenu_item,
- make_number (i * TOOL_BAR_ITEM_NSLOTS));
+ make_fixnum (i * TOOL_BAR_ITEM_NSLOTS));
/* Let the last image hide all remaining spaces in the tool bar
string. The string can be longer than needed when we reuse a
@@ -12559,7 +12586,7 @@ build_desired_tool_bar_string (struct frame *f)
end = SCHARS (f->desired_tool_bar_string);
else
end = i + 1;
- Fadd_text_properties (make_number (i), make_number (end),
+ Fadd_text_properties (make_fixnum (i), make_fixnum (end),
props, f->desired_tool_bar_string);
#undef PROP
}
@@ -12739,7 +12766,7 @@ tool_bar_height (struct frame *f, int *n_rows, bool pixelwise)
return (it.current_y + FRAME_LINE_HEIGHT (f) - 1) / FRAME_LINE_HEIGHT (f);
}
-#endif /* !USE_GTK && !HAVE_NS */
+#endif /* ! (HAVE_EXT_TOOL_BAR) */
DEFUN ("tool-bar-height", Ftool_bar_height, Stool_bar_height,
0, 2, 0,
@@ -12750,7 +12777,7 @@ PIXELWISE non-nil means return the height of the tool bar in pixels. */)
{
int height = 0;
-#if ! defined (USE_GTK) && ! defined (HAVE_NS)
+#ifndef HAVE_EXT_TOOL_BAR
struct frame *f = decode_any_frame (frame);
if (WINDOWP (f->tool_bar_window)
@@ -12765,7 +12792,7 @@ PIXELWISE non-nil means return the height of the tool bar in pixels. */)
}
#endif
- return make_number (height);
+ return make_fixnum (height);
}
@@ -12775,13 +12802,13 @@ static bool
redisplay_tool_bar (struct frame *f)
{
f->tool_bar_redisplayed = true;
-#if defined (USE_GTK) || defined (HAVE_NS)
+#ifdef HAVE_EXT_TOOL_BAR
if (FRAME_EXTERNAL_TOOL_BAR (f))
update_frame_tool_bar (f);
return false;
-#else /* !USE_GTK && !HAVE_NS */
+#else /* ! (HAVE_EXT_TOOL_BAR) */
struct window *w;
struct it it;
@@ -12836,8 +12863,8 @@ redisplay_tool_bar (struct frame *f)
{
int border, rows, height, extra;
- if (TYPE_RANGED_INTEGERP (int, Vtool_bar_border))
- border = XINT (Vtool_bar_border);
+ if (TYPE_RANGED_FIXNUMP (int, Vtool_bar_border))
+ border = XFIXNUM (Vtool_bar_border);
else if (EQ (Vtool_bar_border, Qinternal_border_width))
border = FRAME_INTERNAL_BORDER_WIDTH (f);
else if (EQ (Vtool_bar_border, Qborder_width))
@@ -12930,10 +12957,10 @@ redisplay_tool_bar (struct frame *f)
f->minimize_tool_bar_window_p = false;
return false;
-#endif /* USE_GTK || HAVE_NS */
+#endif /* HAVE_EXT_TOOL_BAR */
}
-#if ! defined (USE_GTK) && ! defined (HAVE_NS)
+#ifndef HAVE_EXT_TOOL_BAR
/* Get information about the tool-bar item which is displayed in GLYPH
on frame F. Return in *PROP_IDX the index where tool-bar item
@@ -12955,11 +12982,11 @@ tool_bar_item_info (struct frame *f, struct glyph *glyph, int *prop_idx)
/* Get the text property `menu-item' at pos. The value of that
property is the start index of this item's properties in
F->tool_bar_items. */
- prop = Fget_text_property (make_number (charpos),
+ prop = Fget_text_property (make_fixnum (charpos),
Qmenu_item, f->current_tool_bar_string);
- if (! INTEGERP (prop))
+ if (! FIXNUMP (prop))
return false;
- *prop_idx = XINT (prop);
+ *prop_idx = XFIXNUM (prop);
return true;
}
@@ -13171,7 +13198,7 @@ note_tool_bar_highlight (struct frame *f, int x, int y)
help_echo_string = AREF (f->tool_bar_items, prop_idx + TOOL_BAR_ITEM_CAPTION);
}
-#endif /* !USE_GTK && !HAVE_NS */
+#endif /* ! (HAVE_EXT_TOOL_BAR) */
#endif /* HAVE_WINDOW_SYSTEM */
@@ -13204,9 +13231,9 @@ hscroll_window_tree (Lisp_Object window)
hscroll_step_abs = 0;
}
}
- else if (TYPE_RANGED_INTEGERP (int, Vhscroll_step))
+ else if (TYPE_RANGED_FIXNUMP (int, Vhscroll_step))
{
- hscroll_step_abs = XINT (Vhscroll_step);
+ hscroll_step_abs = XFIXNUM (Vhscroll_step);
if (hscroll_step_abs < 0)
hscroll_step_abs = 0;
}
@@ -13283,7 +13310,8 @@ hscroll_window_tree (Lisp_Object window)
text_area_width = window_box_width (w, TEXT_AREA);
/* Scroll when cursor is inside this scroll margin. */
- h_margin = hscroll_margin * WINDOW_FRAME_COLUMN_WIDTH (w);
+ h_margin = (clip_to_bounds (0, hscroll_margin, 1000000)
+ * WINDOW_FRAME_COLUMN_WIDTH (w));
/* If the position of this window's point has explicitly
changed, no more suspend auto hscrolling. */
@@ -13305,7 +13333,7 @@ hscroll_window_tree (Lisp_Object window)
/* Remember window point. */
Fset_marker (w->old_pointm,
((w == XWINDOW (selected_window))
- ? make_number (BUF_PT (XBUFFER (w->contents)))
+ ? make_fixnum (BUF_PT (XBUFFER (w->contents)))
: Fmarker_position (w->pointm)),
w->contents);
@@ -13562,8 +13590,8 @@ text_outside_line_unchanged_p (struct window *w,
/* If selective display, can't optimize if changes start at the
beginning of the line. */
if (unchanged_p
- && INTEGERP (BVAR (current_buffer, selective_display))
- && XINT (BVAR (current_buffer, selective_display)) > 0
+ && FIXNUMP (BVAR (current_buffer, selective_display))
+ && XFIXNUM (BVAR (current_buffer, selective_display)) > 0
&& (BEG_UNCHANGED < start || GPT <= start))
unchanged_p = false;
@@ -13765,10 +13793,10 @@ overlay_arrow_at_row (struct it *it, struct glyph_row *row)
{
int fringe_bitmap = lookup_fringe_bitmap (val);
if (fringe_bitmap != 0)
- return make_number (fringe_bitmap);
+ return make_fixnum (fringe_bitmap);
}
#endif
- return make_number (-1); /* Use default arrow bitmap. */
+ return make_fixnum (-1); /* Use default arrow bitmap. */
}
return overlay_arrow_string_or_property (var);
}
@@ -13934,7 +13962,15 @@ redisplay_internal (void)
#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS)
if (popup_activated ())
- return;
+ {
+#ifdef NS_IMPL_COCOA
+ /* On macOS we may have disabled screen updates due to window
+ resizing. We should re-enable them so the popup can be
+ displayed. */
+ ns_enable_screen_updates ();
+#endif
+ return;
+ }
#endif
/* I don't think this happens but let's be paranoid. */
@@ -14068,20 +14104,6 @@ redisplay_internal (void)
{
echo_area_display (false);
- /* If echo_area_display resizes the mini-window, the redisplay and
- window_sizes_changed flags of the selected frame are set, but
- it's too late for the hooks in window-size-change-functions,
- which have been examined already in prepare_menu_bars. So in
- that case we call the hooks here only for the selected frame. */
- if (sf->redisplay)
- {
- ptrdiff_t count1 = SPECPDL_INDEX ();
-
- record_unwind_save_match_data ();
- run_window_size_change_functions (selected_frame);
- unbind_to (count1, Qnil);
- }
-
if (message_cleared_p)
update_miniwindow_p = true;
@@ -14098,15 +14120,6 @@ redisplay_internal (void)
&& (current_buffer->clip_changed || window_outdated (w))
&& resize_mini_window (w, false))
{
- if (sf->redisplay)
- {
- ptrdiff_t count1 = SPECPDL_INDEX ();
-
- record_unwind_save_match_data ();
- run_window_size_change_functions (selected_frame);
- unbind_to (count1, Qnil);
- }
-
/* Resized active mini-window to fit the size of what it is
showing if its contents might have changed. */
must_finish = true;
@@ -14117,6 +14130,9 @@ redisplay_internal (void)
clear_garbaged_frames ();
}
+ if (!NILP (Vrun_hooks))
+ run_window_change_functions ();
+
if (windows_or_buffers_changed && !update_mode_lines)
/* Code that sets windows_or_buffers_changed doesn't distinguish whether
only the windows's contents needs to be refreshed, or whether the
@@ -14135,9 +14151,9 @@ redisplay_internal (void)
#define AINC(a,i) \
{ \
- Lisp_Object entry = Fgethash (make_number (i), a, make_number (0)); \
- if (INTEGERP (entry)) \
- Fputhash (make_number (i), make_number (1 + XINT (entry)), a); \
+ Lisp_Object entry = Fgethash (make_fixnum (i), a, make_fixnum (0)); \
+ if (FIXNUMP (entry)) \
+ Fputhash (make_fixnum (i), make_fixnum (1 + XFIXNUM (entry)), a); \
}
AINC (Vredisplay__all_windows_cause, windows_or_buffers_changed);
@@ -14296,7 +14312,7 @@ redisplay_internal (void)
&& (w = XWINDOW (selected_window)) != sw)
goto retry;
- /* We used to always goto end_of_redisplay here, but this
+ /* We used to always goto end_of_redisplay here, but this
isn't enough if we have a blinking cursor. */
if (w->cursor_off_p == w->last_cursor_off_p)
goto end_of_redisplay;
@@ -14331,7 +14347,7 @@ redisplay_internal (void)
eassert (this_line_vpos == it.vpos);
eassert (this_line_y == it.current_y);
set_cursor_from_row (w, row, w->current_matrix, 0, 0, 0, 0);
- if (cursor_row_fully_visible_p (w, false, true))
+ if (cursor_row_fully_visible_p (w, false, true, false))
{
#ifdef GLYPH_DEBUG
*w->desired_matrix->method = 0;
@@ -14392,7 +14408,17 @@ redisplay_internal (void)
FRAME_TERMINAL (f)->condemn_scroll_bars_hook (f);
if (FRAME_VISIBLE_P (f) && !FRAME_OBSCURED_P (f))
- redisplay_windows (FRAME_ROOT_WINDOW (f));
+ {
+
+ /* Don't allow freeing images for this frame as long
+ as the frame's update wasn't completed. This
+ prevents crashes when some Lisp that runs from
+ the various hooks or font-lock decides to clear
+ the frame's image cache, when the images in that
+ cache are referenced by the desired matrix. */
+ f->inhibit_clear_image_cache = true;
+ redisplay_windows (FRAME_ROOT_WINDOW (f));
+ }
/* Remember that the invisible frames need to be redisplayed next
time they're visible. */
else if (!REDISPLAY_SOME_P ())
@@ -14473,6 +14499,7 @@ redisplay_internal (void)
pending |= update_frame (f, false, false);
f->cursor_type_changed = false;
f->updated_p = true;
+ f->inhibit_clear_image_cache = false;
}
}
}
@@ -14500,6 +14527,7 @@ redisplay_internal (void)
}
else if (FRAME_VISIBLE_P (sf) && !FRAME_OBSCURED_P (sf))
{
+ sf->inhibit_clear_image_cache = true;
displayed_buffer = XBUFFER (XWINDOW (selected_window)->contents);
/* Use list_of_error, not Qerror, so that
we catch only errors and don't run the debugger. */
@@ -14555,6 +14583,7 @@ redisplay_internal (void)
XWINDOW (selected_window)->must_be_updated_p = true;
pending = update_frame (sf, false, false);
sf->cursor_type_changed = false;
+ sf->inhibit_clear_image_cache = false;
}
/* We may have called echo_area_display at the top of this
@@ -14655,7 +14684,8 @@ redisplay_internal (void)
/* If we just did a pending size change, or have additional
visible frames, or selected_window changed, redisplay again. */
if ((windows_or_buffers_changed && !pending)
- || (WINDOWP (selected_window) && (w = XWINDOW (selected_window)) != sw))
+ || (WINDOWP (selected_window)
+ && (w = XWINDOW (selected_window)) != sw))
goto retry;
/* Clear the face and image caches.
@@ -14740,6 +14770,12 @@ unwind_redisplay (void)
{
redisplaying_p = false;
unblock_buffer_flips ();
+#ifdef NS_IMPL_COCOA
+ /* On macOS we may have disabled screen updates due to window
+ resizing. When redisplay completes we want to re-enable
+ them. */
+ ns_enable_screen_updates ();
+#endif
}
@@ -15100,7 +15136,7 @@ set_cursor_from_row (struct window *w, struct glyph_row *row,
Lisp_Object chprop;
ptrdiff_t glyph_pos = glyph->charpos;
- chprop = Fget_char_property (make_number (glyph_pos), Qcursor,
+ chprop = Fget_char_property (make_fixnum (glyph_pos), Qcursor,
glyph->object);
if (!NILP (chprop))
{
@@ -15121,9 +15157,9 @@ set_cursor_from_row (struct window *w, struct glyph_row *row,
if (prop_pos >= pos_before)
bpos_max = prop_pos;
}
- if (INTEGERP (chprop))
+ if (FIXNUMP (chprop))
{
- bpos_covered = bpos_max + XINT (chprop);
+ bpos_covered = bpos_max + XFIXNUM (chprop);
/* If the `cursor' property covers buffer positions up
to and including point, we should display cursor on
this glyph. Note that, if a `cursor' property on one
@@ -15184,7 +15220,7 @@ set_cursor_from_row (struct window *w, struct glyph_row *row,
Lisp_Object chprop;
ptrdiff_t glyph_pos = glyph->charpos;
- chprop = Fget_char_property (make_number (glyph_pos), Qcursor,
+ chprop = Fget_char_property (make_fixnum (glyph_pos), Qcursor,
glyph->object);
if (!NILP (chprop))
{
@@ -15195,9 +15231,9 @@ set_cursor_from_row (struct window *w, struct glyph_row *row,
if (prop_pos >= pos_before)
bpos_max = prop_pos;
}
- if (INTEGERP (chprop))
+ if (FIXNUMP (chprop))
{
- bpos_covered = bpos_max + XINT (chprop);
+ bpos_covered = bpos_max + XFIXNUM (chprop);
/* If the `cursor' property covers buffer positions up
to and including point, we should display cursor on
this glyph. */
@@ -15371,7 +15407,7 @@ set_cursor_from_row (struct window *w, struct glyph_row *row,
Lisp_Object cprop;
ptrdiff_t gpos = glyph->charpos;
- cprop = Fget_char_property (make_number (gpos),
+ cprop = Fget_char_property (make_fixnum (gpos),
Qcursor,
glyph->object);
if (!NILP (cprop))
@@ -15502,7 +15538,7 @@ set_cursor_from_row (struct window *w, struct glyph_row *row,
/* Previous candidate is a glyph from a string that has
a non-nil `cursor' property. */
|| (STRINGP (g1->object)
- && (!NILP (Fget_char_property (make_number (g1->charpos),
+ && (!NILP (Fget_char_property (make_fixnum (g1->charpos),
Qcursor, g1->object))
/* Previous candidate is from the same display
string as this one, and the display string
@@ -15585,7 +15621,7 @@ run_window_scroll_functions (Lisp_Object window, struct text_pos startp)
if (!NILP (Vwindow_scroll_functions))
{
run_hook_with_args_2 (Qwindow_scroll_functions, window,
- make_number (CHARPOS (startp)));
+ make_fixnum (CHARPOS (startp)));
SET_TEXT_POS_FROM_MARKER (startp, w->start);
/* In case the hook functions switch buffers. */
set_buffer_internal (XBUFFER (w->contents));
@@ -15607,19 +15643,46 @@ run_window_scroll_functions (Lisp_Object window, struct text_pos startp)
window's current glyph matrix; otherwise use the desired glyph
matrix.
+ If JUST_TEST_USER_PREFERENCE_P, just test what the value of
+ make-cursor-row-fully-visible requires, don't test the actual
+ cursor position. The assumption is that in that case the caller
+ performs the necessary testing of the cursor position.
+
A value of false means the caller should do scrolling
as if point had gone off the screen. */
static bool
cursor_row_fully_visible_p (struct window *w, bool force_p,
- bool current_matrix_p)
+ bool current_matrix_p,
+ bool just_test_user_preference_p)
{
struct glyph_matrix *matrix;
struct glyph_row *row;
int window_height;
+ Lisp_Object mclfv_p =
+ buffer_local_value (Qmake_cursor_line_fully_visible, w->contents);
- if (!make_cursor_line_fully_visible_p)
+ /* If no local binding, use the global value. */
+ if (EQ (mclfv_p, Qunbound))
+ mclfv_p = Vmake_cursor_line_fully_visible;
+ /* Follow mode sets the variable to a Lisp function in buffers that
+ are under Follow mode. */
+ if (FUNCTIONP (mclfv_p))
+ {
+ Lisp_Object window;
+ XSETWINDOW (window, w);
+ /* Implementation note: if the function we call here signals an
+ error, we will NOT scroll when the cursor is partially-visible. */
+ Lisp_Object val = safe_call1 (mclfv_p, window);
+ if (NILP (val))
+ return true;
+ else if (just_test_user_preference_p)
+ return false;
+ }
+ else if (NILP (mclfv_p))
return true;
+ else if (just_test_user_preference_p)
+ return false;
/* It's not always possible to find the cursor, e.g, when a window
is full of overlay strings. Don't do anything in that case. */
@@ -15679,7 +15742,7 @@ enum
static int
try_scrolling (Lisp_Object window, bool just_this_one_p,
- ptrdiff_t arg_scroll_conservatively, ptrdiff_t scroll_step,
+ intmax_t arg_scroll_conservatively, intmax_t scroll_step,
bool temp_scroll_step, bool last_line_misfit)
{
struct window *w = XWINDOW (window);
@@ -15711,12 +15774,15 @@ try_scrolling (Lisp_Object window, bool just_this_one_p,
arg_scroll_conservatively = scroll_limit + 1;
scroll_max = scroll_limit * frame_line_height;
}
- else if (scroll_step || arg_scroll_conservatively || temp_scroll_step)
+ else if (0 < scroll_step || 0 < arg_scroll_conservatively || temp_scroll_step)
/* Compute how much we should try to scroll maximally to bring
point into view. */
- scroll_max = (max (scroll_step,
- max (arg_scroll_conservatively, temp_scroll_step))
- * frame_line_height);
+ {
+ intmax_t scroll_lines_max
+ = max (scroll_step, max (arg_scroll_conservatively, temp_scroll_step));
+ int scroll_lines = clip_to_bounds (0, scroll_lines_max, 1000000);
+ scroll_max = scroll_lines * frame_line_height;
+ }
else if (NUMBERP (BVAR (current_buffer, scroll_down_aggressively))
|| NUMBERP (BVAR (current_buffer, scroll_up_aggressively)))
/* We're trying to scroll because of aggressive scrolling but no
@@ -15981,7 +16047,7 @@ try_scrolling (Lisp_Object window, bool just_this_one_p,
/* If cursor ends up on a partially visible line,
treat that as being off the bottom of the screen. */
if (! cursor_row_fully_visible_p (w, extra_scroll_margin_lines <= 1,
- false)
+ false, false)
/* It's possible that the cursor is on the first line of the
buffer, which is partially obscured due to a vscroll
(Bug#7537). In that case, avoid looping forever. */
@@ -16346,7 +16412,7 @@ try_cursor_movement (Lisp_Object window, struct text_pos startp,
/* Make sure this isn't a header line by any chance, since
then MATRIX_ROW_PARTIALLY_VISIBLE_P might yield true. */
&& !row->mode_line_p
- && make_cursor_line_fully_visible_p)
+ && !cursor_row_fully_visible_p (w, true, true, true))
{
if (PT == MATRIX_ROW_END_CHARPOS (row)
&& !row->ends_at_zv_p
@@ -16364,7 +16430,7 @@ try_cursor_movement (Lisp_Object window, struct text_pos startp,
else
{
set_cursor_from_row (w, row, w->current_matrix, 0, 0, 0, 0);
- if (!cursor_row_fully_visible_p (w, false, true))
+ if (!cursor_row_fully_visible_p (w, false, true, false))
rc = CURSOR_MOVEMENT_MUST_SCROLL;
else
rc = CURSOR_MOVEMENT_SUCCESS;
@@ -16920,18 +16986,18 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
position past that. */
struct glyph_row *r = NULL;
Lisp_Object invprop =
- get_char_property_and_overlay (make_number (PT), Qinvisible,
+ get_char_property_and_overlay (make_fixnum (PT), Qinvisible,
Qnil, NULL);
if (TEXT_PROP_MEANS_INVISIBLE (invprop) != 0)
{
ptrdiff_t alt_pt;
Lisp_Object invprop_end =
- Fnext_single_char_property_change (make_number (PT), Qinvisible,
+ Fnext_single_char_property_change (make_fixnum (PT), Qinvisible,
Qnil, Qnil);
- if (NATNUMP (invprop_end))
- alt_pt = XFASTINT (invprop_end);
+ if (FIXNATP (invprop_end))
+ alt_pt = XFIXNAT (invprop_end);
else
alt_pt = ZV;
r = row_containing_pos (w, alt_pt, w->desired_matrix->rows,
@@ -16943,7 +17009,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
new_vpos = window_box_height (w) / 2;
}
- if (!cursor_row_fully_visible_p (w, false, false))
+ if (!cursor_row_fully_visible_p (w, false, false, false))
{
/* Point does appear, but on a line partly visible at end of window.
Move it back to a fully-visible line. */
@@ -17038,7 +17104,8 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
goto need_larger_matrices;
}
}
- if (w->cursor.vpos < 0 || !cursor_row_fully_visible_p (w, false, false))
+ if (w->cursor.vpos < 0
+ || !cursor_row_fully_visible_p (w, false, false, false))
{
clear_glyph_matrix (w->desired_matrix);
goto try_to_scroll;
@@ -17185,7 +17252,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
/* Forget any recorded base line for line number display. */
w->base_line_number = 0;
- if (!cursor_row_fully_visible_p (w, true, false))
+ if (!cursor_row_fully_visible_p (w, true, false, false))
{
clear_glyph_matrix (w->desired_matrix);
last_line_misfit = true;
@@ -17208,8 +17275,8 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
}
/* Try to scroll by specified few lines. */
- if ((scroll_conservatively
- || emacs_scroll_step
+ if ((0 < scroll_conservatively
+ || 0 < emacs_scroll_step
|| temp_scroll_step
|| NUMBERP (BVAR (current_buffer, scroll_up_aggressively))
|| NUMBERP (BVAR (current_buffer, scroll_down_aggressively)))
@@ -17452,18 +17519,18 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
if (!row)
{
Lisp_Object val =
- get_char_property_and_overlay (make_number (PT), Qinvisible,
+ get_char_property_and_overlay (make_fixnum (PT), Qinvisible,
Qnil, NULL);
if (TEXT_PROP_MEANS_INVISIBLE (val) != 0)
{
ptrdiff_t alt_pos;
Lisp_Object invis_end =
- Fnext_single_char_property_change (make_number (PT), Qinvisible,
+ Fnext_single_char_property_change (make_fixnum (PT), Qinvisible,
Qnil, Qnil);
- if (NATNUMP (invis_end))
- alt_pos = XFASTINT (invis_end);
+ if (FIXNATP (invis_end))
+ alt_pos = XFIXNAT (invis_end);
else
alt_pos = ZV;
row = row_containing_pos (w, alt_pos, matrix->rows, NULL, 0);
@@ -17481,7 +17548,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
set_cursor_from_row (w, row, matrix, 0, 0, 0, 0);
}
- if (!cursor_row_fully_visible_p (w, false, false))
+ if (!cursor_row_fully_visible_p (w, false, false, false))
{
/* If vscroll is enabled, disable it and try again. */
if (w->vscroll)
@@ -17589,8 +17656,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
if (FRAME_WINDOW_P (f))
{
-#if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \
- || defined (HAVE_NS) || defined (USE_GTK)
+#ifdef HAVE_EXT_MENU_BAR
redisplay_menu_p = FRAME_EXTERNAL_MENU_BAR (f);
#else
redisplay_menu_p = FRAME_MENU_BAR_LINES (f) > 0;
@@ -17605,7 +17671,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
#ifdef HAVE_WINDOW_SYSTEM
if (FRAME_WINDOW_P (f))
{
-#if defined (USE_GTK) || defined (HAVE_NS)
+#ifdef HAVE_EXT_TOOL_BAR
if (FRAME_EXTERNAL_TOOL_BAR (f))
redisplay_tool_bar (f);
#else
@@ -19047,9 +19113,10 @@ try_window_id (struct window *w)
&& CHARPOS (start) > BEGV)
/* Old redisplay didn't take scroll margin into account at the bottom,
but then global-hl-line-mode doesn't scroll. KFS 2004-06-14 */
- || (w->cursor.y + (make_cursor_line_fully_visible_p
- ? cursor_height + this_scroll_margin
- : 1)) > it.last_visible_y)
+ || (w->cursor.y
+ + (cursor_row_fully_visible_p (w, false, true, true)
+ ? 1
+ : cursor_height + this_scroll_margin)) > it.last_visible_y)
{
w->cursor.vpos = -1;
clear_glyph_matrix (w->desired_matrix);
@@ -19572,7 +19639,7 @@ with numeric argument, its value is passed as the GLYPHS flag. */)
w->cursor.x, w->cursor.y, w->cursor.hpos, w->cursor.vpos);
fprintf (stderr, "=============================================\n");
dump_glyph_matrix (w->current_matrix,
- TYPE_RANGED_INTEGERP (int, glyphs) ? XINT (glyphs) : 0);
+ TYPE_RANGED_FIXNUMP (int, glyphs) ? XFIXNUM (glyphs) : 0);
return Qnil;
}
@@ -19616,14 +19683,14 @@ GLYPHS > 1 or omitted means dump glyphs in long form. */)
}
else
{
- CHECK_NUMBER (row);
- vpos = XINT (row);
+ CHECK_FIXNUM (row);
+ vpos = XFIXNUM (row);
}
matrix = XWINDOW (selected_window)->current_matrix;
if (vpos >= 0 && vpos < matrix->nrows)
dump_glyph_row (MATRIX_ROW (matrix, vpos),
vpos,
- TYPE_RANGED_INTEGERP (int, glyphs) ? XINT (glyphs) : 2);
+ TYPE_RANGED_FIXNUMP (int, glyphs) ? XFIXNUM (glyphs) : 2);
return Qnil;
}
@@ -19639,7 +19706,7 @@ If there's no tool-bar, or if the tool-bar is not drawn by Emacs,
do nothing. */)
(Lisp_Object row, Lisp_Object glyphs)
{
-#if defined (HAVE_WINDOW_SYSTEM) && ! defined (USE_GTK) && ! defined (HAVE_NS)
+#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_TOOL_BAR)
struct frame *sf = SELECTED_FRAME ();
struct glyph_matrix *m = XWINDOW (sf->tool_bar_window)->current_matrix;
EMACS_INT vpos;
@@ -19648,12 +19715,12 @@ do nothing. */)
vpos = 0;
else
{
- CHECK_NUMBER (row);
- vpos = XINT (row);
+ CHECK_FIXNUM (row);
+ vpos = XFIXNUM (row);
}
if (vpos >= 0 && vpos < m->nrows)
dump_glyph_row (MATRIX_ROW (m, vpos), vpos,
- TYPE_RANGED_INTEGERP (int, glyphs) ? XINT (glyphs) : 2);
+ TYPE_RANGED_FIXNUMP (int, glyphs) ? XFIXNUM (glyphs) : 2);
#endif
return Qnil;
}
@@ -19669,7 +19736,7 @@ With ARG, turn tracing on if and only if ARG is positive. */)
else
{
arg = Fprefix_numeric_value (arg);
- trace_redisplay_p = XINT (arg) > 0;
+ trace_redisplay_p = XFIXNUM (arg) > 0;
}
return Qnil;
@@ -19735,7 +19802,7 @@ get_overlay_arrow_glyph_row (struct window *w, Lisp_Object overlay_arrow_string)
p += it.len;
/* Get its face. */
- ilisp = make_number (p - arrow_string);
+ ilisp = make_fixnum (p - arrow_string);
face = Fget_text_property (ilisp, Qface, overlay_arrow_string);
it.face_id = compute_char_face (f, it.char_to_display, face);
@@ -20071,7 +20138,7 @@ append_space_for_newline (struct it *it, bool default_face_p)
/* If the default face was remapped, be sure to use the
remapped face for the appended newline. */
if (default_face_p)
- it->face_id = lookup_basic_face (it->f, DEFAULT_FACE_ID);
+ it->face_id = lookup_basic_face (it->w, it->f, DEFAULT_FACE_ID);
else if (it->face_before_selective_p)
it->face_id = it->saved_face_id;
face = FACE_FROM_ID (it->f, it->face_id);
@@ -20135,8 +20202,8 @@ append_space_for_newline (struct it *it, bool default_face_p)
it->phys_ascent = it->ascent;
it->phys_descent = it->descent;
if (!NILP (height)
- && XINT (height) > it->ascent + it->descent)
- it->ascent = XINT (height) - it->descent;
+ && XFIXNUM (height) > it->ascent + it->descent)
+ it->ascent = XFIXNUM (height) - it->descent;
if (!NILP (total_height))
spacing = calc_line_height_property (it, total_height, font,
@@ -20147,9 +20214,9 @@ append_space_for_newline (struct it *it, bool default_face_p)
spacing = calc_line_height_property (it, spacing, font,
boff, false);
}
- if (INTEGERP (spacing))
+ if (FIXNUMP (spacing))
{
- extra_line_spacing = XINT (spacing);
+ extra_line_spacing = XFIXNUM (spacing);
if (!NILP (total_height))
extra_line_spacing -= (it->phys_ascent + it->phys_descent);
}
@@ -20218,8 +20285,8 @@ extend_face_to_end_of_line (struct it *it)
return;
/* The default face, possibly remapped. */
- default_face = FACE_FROM_ID_OR_NULL (f,
- lookup_basic_face (f, DEFAULT_FACE_ID));
+ default_face =
+ FACE_FROM_ID_OR_NULL (f, lookup_basic_face (it->w, f, DEFAULT_FACE_ID));
/* Face extension extends the background and box of IT->face_id
to the end of the line. If the background equals the background
@@ -20231,7 +20298,7 @@ extend_face_to_end_of_line (struct it *it)
if (FRAME_WINDOW_P (f)
&& MATRIX_ROW_DISPLAYS_TEXT_P (it->glyph_row)
&& face->box == FACE_NO_BOX
- && face->background == FRAME_BACKGROUND_PIXEL (f)
+ && FACE_COLOR_TO_PIXEL (face->background, f) == FRAME_BACKGROUND_PIXEL (f)
#ifdef HAVE_WINDOW_SYSTEM
&& !face->stipple
#endif
@@ -20265,7 +20332,7 @@ extend_face_to_end_of_line (struct it *it)
/* Mode line and the header line don't have margins, and
likewise the frame's tool-bar window, if there is any. */
if (!(it->glyph_row->mode_line_p
-#if defined (HAVE_WINDOW_SYSTEM) && ! defined (USE_GTK) && ! defined (HAVE_NS)
+#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_TOOL_BAR)
|| (WINDOWP (f->tool_bar_window)
&& it->w == XWINDOW (f->tool_bar_window))
#endif
@@ -20376,7 +20443,7 @@ extend_face_to_end_of_line (struct it *it)
&& (it->glyph_row->used[LEFT_MARGIN_AREA]
< WINDOW_LEFT_MARGIN_WIDTH (it->w))
&& !it->glyph_row->mode_line_p
- && default_face->background != FRAME_BACKGROUND_PIXEL (f))
+ && FACE_COLOR_TO_PIXEL (face->background, f) != FRAME_BACKGROUND_PIXEL (f))
{
struct glyph *g = it->glyph_row->glyphs[LEFT_MARGIN_AREA];
struct glyph *e = g + it->glyph_row->used[LEFT_MARGIN_AREA];
@@ -20417,7 +20484,7 @@ extend_face_to_end_of_line (struct it *it)
&& (it->glyph_row->used[RIGHT_MARGIN_AREA]
< WINDOW_RIGHT_MARGIN_WIDTH (it->w))
&& !it->glyph_row->mode_line_p
- && default_face->background != FRAME_BACKGROUND_PIXEL (f))
+ && FACE_COLOR_TO_PIXEL (face->background, f) != FRAME_BACKGROUND_PIXEL (f))
{
struct glyph *g = it->glyph_row->glyphs[RIGHT_MARGIN_AREA];
struct glyph *e = g + it->glyph_row->used[RIGHT_MARGIN_AREA];
@@ -20473,11 +20540,12 @@ trailing_whitespace_p (ptrdiff_t charpos)
}
-/* Highlight trailing whitespace, if any, in ROW. */
+/* Highlight trailing whitespace, if any, in row at IT. */
static void
-highlight_trailing_whitespace (struct frame *f, struct glyph_row *row)
+highlight_trailing_whitespace (struct it *it)
{
+ struct glyph_row *row = it->glyph_row;
int used = row->used[TEXT_AREA];
if (used)
@@ -20507,7 +20575,7 @@ highlight_trailing_whitespace (struct frame *f, struct glyph_row *row)
else
{
while (glyph <= start
- && glyph->type == CHAR_GLYPH
+ && (glyph->type == CHAR_GLYPH || glyph->type == STRETCH_GLYPH)
&& NILP (glyph->object))
++glyph;
}
@@ -20522,7 +20590,7 @@ highlight_trailing_whitespace (struct frame *f, struct glyph_row *row)
&& glyph->u.ch == ' '))
&& trailing_whitespace_p (glyph->charpos))
{
- int face_id = lookup_named_face (f, Qtrailing_whitespace, false);
+ int face_id = lookup_named_face (it->w, it->f, Qtrailing_whitespace, false);
if (face_id < 0)
return;
@@ -20584,7 +20652,7 @@ row_for_charpos_p (struct glyph_row *row, ptrdiff_t charpos)
if (STRINGP (glyph->object))
{
Lisp_Object prop
- = Fget_char_property (make_number (charpos),
+ = Fget_char_property (make_fixnum (charpos),
Qdisplay, Qnil);
result =
(!NILP (prop)
@@ -20600,7 +20668,7 @@ row_for_charpos_p (struct glyph_row *row, ptrdiff_t charpos)
{
ptrdiff_t gpos = glyph->charpos;
- if (!NILP (Fget_char_property (make_number (gpos),
+ if (!NILP (Fget_char_property (make_fixnum (gpos),
Qcursor, s)))
{
result = true;
@@ -20739,10 +20807,10 @@ get_it_property (struct it *it, Lisp_Object prop)
Lisp_Object position, object = it->object;
if (STRINGP (object))
- position = make_number (IT_STRING_CHARPOS (*it));
+ position = make_fixnum (IT_STRING_CHARPOS (*it));
else if (BUFFERP (object))
{
- position = make_number (IT_CHARPOS (*it));
+ position = make_fixnum (IT_CHARPOS (*it));
object = it->window;
}
else
@@ -21094,9 +21162,9 @@ maybe_produce_line_number (struct it *it)
char lnum_buf[INT_STRLEN_BOUND (ptrdiff_t) + 1];
bool beyond_zv = IT_BYTEPOS (*it) >= ZV_BYTE ? true : false;
ptrdiff_t lnum_offset = -1; /* to produce 1-based line numbers */
- int lnum_face_id = merge_faces (it->f, Qline_number, 0, DEFAULT_FACE_ID);
+ int lnum_face_id = merge_faces (it->w, Qline_number, 0, DEFAULT_FACE_ID);
int current_lnum_face_id
- = merge_faces (it->f, Qline_number_current_line, 0, DEFAULT_FACE_ID);
+ = merge_faces (it->w, Qline_number_current_line, 0, DEFAULT_FACE_ID);
/* Compute point's line number if needed. */
if ((EQ (Vdisplay_line_numbers, Qrelative)
|| EQ (Vdisplay_line_numbers, Qvisual)
@@ -21115,8 +21183,8 @@ maybe_produce_line_number (struct it *it)
/* Compute the required width if needed. */
if (!it->lnum_width)
{
- if (NATNUMP (Vdisplay_line_numbers_width))
- it->lnum_width = XFASTINT (Vdisplay_line_numbers_width);
+ if (FIXNATP (Vdisplay_line_numbers_width))
+ it->lnum_width = XFIXNAT (Vdisplay_line_numbers_width);
/* Max line number to be displayed cannot be more than the one
corresponding to the last row of the desired matrix. */
@@ -21286,13 +21354,7 @@ should_produce_line_number (struct it *it)
#ifdef HAVE_WINDOW_SYSTEM
/* Don't display line number in tooltip frames. */
- if (FRAMEP (tip_frame) && EQ (WINDOW_FRAME (it->w), tip_frame)
-#ifdef USE_GTK
- /* GTK builds store in tip_frame the frame that shows the tip,
- so we need an additional test. */
- && !NILP (Fframe_parameter (tip_frame, Qtooltip))
-#endif
- )
+ if (FRAME_TOOLTIP_P (XFRAME (WINDOW_FRAME (it->w))))
return false;
#endif
@@ -21300,7 +21362,7 @@ should_produce_line_number (struct it *it)
property, disable line numbers for this row. This is for
packages such as company-mode, which need this for their tricky
layout, where line numbers get in the way. */
- Lisp_Object val = Fget_char_property (make_number (IT_CHARPOS (*it)),
+ Lisp_Object val = Fget_char_property (make_fixnum (IT_CHARPOS (*it)),
Qdisplay_line_numbers_disable,
it->window);
/* For ZV, we need to also look in empty overlays at that point,
@@ -21563,7 +21625,8 @@ display_line (struct it *it, int cursor_vpos)
portions of the screen will clear with the default face's
background color. */
if (row->reversed_p
- || lookup_basic_face (it->f, DEFAULT_FACE_ID) != DEFAULT_FACE_ID)
+ || lookup_basic_face (it->w, it->f, DEFAULT_FACE_ID)
+ != DEFAULT_FACE_ID)
extend_face_to_end_of_line (it);
break;
}
@@ -22188,15 +22251,15 @@ display_line (struct it *it, int cursor_vpos)
}
else
{
- eassert (INTEGERP (overlay_arrow_string));
- row->overlay_arrow_bitmap = XINT (overlay_arrow_string);
+ eassert (FIXNUMP (overlay_arrow_string));
+ row->overlay_arrow_bitmap = XFIXNUM (overlay_arrow_string);
}
overlay_arrow_seen = true;
}
/* Highlight trailing whitespace. */
if (!NILP (Vshow_trailing_whitespace))
- highlight_trailing_whitespace (it->f, it->glyph_row);
+ highlight_trailing_whitespace (it);
/* Compute pixel dimensions of this line. */
compute_line_metrics (it);
@@ -22452,8 +22515,8 @@ the `bidi-class' property of a character. */)
set_buffer_temp (buf);
validate_region (&from, &to);
- from_pos = XINT (from);
- to_pos = XINT (to);
+ from_pos = XFIXNUM (from);
+ to_pos = XFIXNUM (to);
if (from_pos >= ZV)
return Qnil;
@@ -22495,7 +22558,7 @@ the `bidi-class' property of a character. */)
bidi_unshelve_cache (itb_data, false);
set_buffer_temp (old);
- return (from_pos <= found && found < to_pos) ? make_number (found) : Qnil;
+ return (from_pos <= found && found < to_pos) ? make_fixnum (found) : Qnil;
}
DEFUN ("move-point-visually", Fmove_point_visually,
@@ -22521,8 +22584,8 @@ Value is the new character position of point. */)
&& (GLYPH)->charpos >= 0 \
&& !(GLYPH)->avoid_cursor_p)
- CHECK_NUMBER (direction);
- dir = XINT (direction);
+ CHECK_FIXNUM (direction);
+ dir = XFIXNUM (direction);
if (dir > 0)
dir = 1;
else
@@ -22555,7 +22618,7 @@ Value is the new character position of point. */)
{
SET_PT (g->charpos);
w->cursor.vpos = -1;
- return make_number (PT);
+ return make_fixnum (PT);
}
else if (!NILP (g->object) && !EQ (g->object, gpt->object))
{
@@ -22580,7 +22643,7 @@ Value is the new character position of point. */)
break;
SET_PT (new_pos);
w->cursor.vpos = -1;
- return make_number (PT);
+ return make_fixnum (PT);
}
else if (ROW_GLYPH_NEWLINE_P (row, g))
{
@@ -22596,7 +22659,7 @@ Value is the new character position of point. */)
else
break;
w->cursor.vpos = -1;
- return make_number (PT);
+ return make_fixnum (PT);
}
}
if (g == e || NILP (g->object))
@@ -22617,7 +22680,7 @@ Value is the new character position of point. */)
{
SET_PT (MATRIX_ROW_END_CHARPOS (row) - 1);
w->cursor.vpos = -1;
- return make_number (PT);
+ return make_fixnum (PT);
}
g = row->glyphs[TEXT_AREA];
e = g + row->used[TEXT_AREA];
@@ -22645,7 +22708,7 @@ Value is the new character position of point. */)
else
continue;
w->cursor.vpos = -1;
- return make_number (PT);
+ return make_fixnum (PT);
}
}
}
@@ -22655,7 +22718,7 @@ Value is the new character position of point. */)
{
SET_PT (MATRIX_ROW_END_CHARPOS (row) - 1);
w->cursor.vpos = -1;
- return make_number (PT);
+ return make_fixnum (PT);
}
e = row->glyphs[TEXT_AREA];
g = e + row->used[TEXT_AREA] - 1;
@@ -22683,7 +22746,7 @@ Value is the new character position of point. */)
else
continue;
w->cursor.vpos = -1;
- return make_number (PT);
+ return make_fixnum (PT);
}
}
}
@@ -22943,7 +23006,7 @@ Value is the new character position of point. */)
SET_PT_BOTH (IT_CHARPOS (it), IT_BYTEPOS (it));
}
- return make_number (PT);
+ return make_fixnum (PT);
#undef ROW_GLYPH_NEWLINE_P
}
@@ -22992,8 +23055,8 @@ Emacs UBA implementation, in particular with the test suite. */)
}
else
{
- CHECK_NUMBER_COERCE_MARKER (vpos);
- nrow = XINT (vpos);
+ CHECK_FIXNUM (vpos);
+ nrow = XFIXNUM (vpos);
}
/* We require up-to-date glyph matrix for this window. */
@@ -23032,7 +23095,7 @@ Emacs UBA implementation, in particular with the test suite. */)
/* Create and fill the array. */
levels = make_uninit_vector (nglyphs);
for (i = 0; g1 < g; i++, g1++)
- ASET (levels, i, make_number (g1->resolved_level));
+ ASET (levels, i, make_fixnum (g1->resolved_level));
}
else /* Right-to-left glyph row. */
{
@@ -23047,7 +23110,7 @@ Emacs UBA implementation, in particular with the test suite. */)
nglyphs++;
levels = make_uninit_vector (nglyphs);
for (i = 0; g1 > g; i++, g1--)
- ASET (levels, i, make_number (g1->resolved_level));
+ ASET (levels, i, make_fixnum (g1->resolved_level));
}
return levels;
}
@@ -23149,7 +23212,7 @@ display_menu_bar (struct window *w)
break;
/* Remember where item was displayed. */
- ASET (items, i + 3, make_number (it.hpos));
+ ASET (items, i + 3, make_fixnum (it.hpos));
/* Display the item, pad with one space. */
if (it.current_x < it.last_visible_x)
@@ -23356,6 +23419,23 @@ display_mode_lines (struct window *w)
Lisp_Object old_frame_selected_window = XFRAME (new_frame)->selected_window;
int n = 0;
+ if (window_wants_mode_line (w))
+ {
+ Lisp_Object window;
+ Lisp_Object default_help
+ = buffer_local_value (Qmode_line_default_help_echo, w->contents);
+
+ /* Set up mode line help echo. Do this before selecting w so it
+ can reasonably tell whether a mouse click will select w. */
+ XSETWINDOW (window, w);
+ if (FUNCTIONP (default_help))
+ wset_mode_line_help_echo (w, safe_call1 (default_help, window));
+ else if (STRINGP (default_help))
+ wset_mode_line_help_echo (w, default_help);
+ else
+ wset_mode_line_help_echo (w, Qnil);
+ }
+
selected_frame = new_frame;
/* FIXME: If we were to allow the mode-line's computation changing the buffer
or window's point, then we'd need select_window_1 here as well. */
@@ -23370,7 +23450,6 @@ display_mode_lines (struct window *w)
{
Lisp_Object window_mode_line_format
= window_parameter (w, Qmode_line_format);
-
struct window *sel_w = XWINDOW (old_selected_window);
/* Select mode line face based on the real selected window. */
@@ -23503,6 +23582,17 @@ move_elt_to_front (Lisp_Object elt, Lisp_Object list)
return list;
}
+/* Subroutine to call Fset_text_properties through
+ internal_condition_case_n. ARGS are the arguments of
+ Fset_text_properties, in order. */
+
+static Lisp_Object
+safe_set_text_properties (ptrdiff_t nargs, Lisp_Object *args)
+{
+ eassert (nargs == 4);
+ return Fset_text_properties (args[0], args[1], args[2], args[3]);
+}
+
/* Contribute ELT to the mode line for window IT->w. How it
translates into text depends on its data type.
@@ -23552,7 +23642,7 @@ display_mode_element (struct it *it, int depth, int field_width, int precision,
&& (!NILP (props) || risky))
{
Lisp_Object oprops, aelt;
- oprops = Ftext_properties_at (make_number (0), elt);
+ oprops = Ftext_properties_at (make_fixnum (0), elt);
/* If the starting string's properties are not what
we want, translate the string. Also, if the string
@@ -23597,15 +23687,24 @@ display_mode_element (struct it *it, int depth, int field_width, int precision,
= Fdelq (aelt, mode_line_proptrans_alist);
elt = Fcopy_sequence (elt);
- Fset_text_properties (make_number (0), Flength (elt),
- props, elt);
+ /* PROPS might cause set-text-properties to signal
+ an error, so we call it via internal_condition_case_n,
+ to avoid an infloop in redisplay due to the error. */
+ internal_condition_case_n (safe_set_text_properties,
+ 4,
+ ((Lisp_Object [])
+ {make_fixnum (0),
+ Flength (elt),
+ props,
+ elt}),
+ Qt, safe_eval_handler);
/* Add this item to mode_line_proptrans_alist. */
mode_line_proptrans_alist
= Fcons (Fcons (elt, props),
mode_line_proptrans_alist);
/* Truncate mode_line_proptrans_alist
to at most 50 elements. */
- tem = Fnthcdr (make_number (50),
+ tem = Fnthcdr (make_fixnum (50),
mode_line_proptrans_alist);
if (! NILP (tem))
XSETCDR (tem, Qnil);
@@ -23676,8 +23775,8 @@ display_mode_element (struct it *it, int depth, int field_width, int precision,
? string_byte_to_char (elt, offset)
: charpos + nchars);
Lisp_Object mode_string
- = Fsubstring (elt, make_number (charpos),
- make_number (endpos));
+ = Fsubstring (elt, make_fixnum (charpos),
+ make_fixnum (endpos));
n += store_mode_line_string (NULL, mode_string, false,
0, 0, Qnil);
}
@@ -23740,7 +23839,7 @@ display_mode_element (struct it *it, int depth, int field_width, int precision,
case MODE_LINE_STRING:
{
Lisp_Object tem = build_string (spec);
- props = Ftext_properties_at (make_number (charpos), elt);
+ props = Ftext_properties_at (make_fixnum (charpos), elt);
/* Should only keep face property in props */
n += store_mode_line_string (NULL, tem, false,
field, prec, props);
@@ -23897,9 +23996,9 @@ display_mode_element (struct it *it, int depth, int field_width, int precision,
elt = XCAR (elt);
goto tail_recurse;
}
- else if (INTEGERP (car))
+ else if (FIXNUMP (car))
{
- register int lim = XINT (car);
+ register int lim = XFIXNUM (car);
elt = XCDR (elt);
if (lim < 0)
{
@@ -24014,23 +24113,23 @@ store_mode_line_string (const char *string, Lisp_Object lisp_string,
face = list2 (face, mode_line_string_face);
props = Fplist_put (props, Qface, face);
}
- Fadd_text_properties (make_number (0), make_number (len),
+ Fadd_text_properties (make_fixnum (0), make_fixnum (len),
props, lisp_string);
}
else
{
- len = XFASTINT (Flength (lisp_string));
+ len = SCHARS (lisp_string);
if (precision > 0 && len > precision)
{
len = precision;
- lisp_string = Fsubstring (lisp_string, make_number (0), make_number (len));
+ lisp_string = Fsubstring (lisp_string, make_fixnum (0), make_fixnum (len));
precision = -1;
}
if (!NILP (mode_line_string_face))
{
Lisp_Object face;
if (NILP (props))
- props = Ftext_properties_at (make_number (0), lisp_string);
+ props = Ftext_properties_at (make_fixnum (0), lisp_string);
face = Fplist_get (props, Qface);
if (NILP (face))
face = mode_line_string_face;
@@ -24041,7 +24140,7 @@ store_mode_line_string (const char *string, Lisp_Object lisp_string,
lisp_string = Fcopy_sequence (lisp_string);
}
if (!NILP (props))
- Fadd_text_properties (make_number (0), make_number (len),
+ Fadd_text_properties (make_fixnum (0), make_fixnum (len),
props, lisp_string);
}
@@ -24054,9 +24153,10 @@ store_mode_line_string (const char *string, Lisp_Object lisp_string,
if (field_width > len)
{
field_width -= len;
- lisp_string = Fmake_string (make_number (field_width), make_number (' '));
+ lisp_string = Fmake_string (make_fixnum (field_width), make_fixnum (' '),
+ Qnil);
if (!NILP (props))
- Fadd_text_properties (make_number (0), make_number (field_width),
+ Fadd_text_properties (make_fixnum (0), make_fixnum (field_width),
props, lisp_string);
mode_line_string_list = Fcons (lisp_string, mode_line_string_list);
n += field_width;
@@ -24093,7 +24193,7 @@ are the selected window and the WINDOW's buffer). */)
struct window *w;
struct buffer *old_buffer = NULL;
int face_id;
- bool no_props = INTEGERP (face);
+ bool no_props = FIXNUMP (face);
ptrdiff_t count = SPECPDL_INDEX ();
Lisp_Object str;
int string_start = 0;
@@ -24169,11 +24269,10 @@ are the selected window and the WINDOW's buffer). */)
empty_unibyte_string);
}
- unbind_to (count, Qnil);
- return str;
+ return unbind_to (count, str);
}
-/* Write a null-terminated, right justified decimal representation of
+/* Write a NUL-terminated, right justified decimal representation of
the positive integer D to BUF using a minimal field width WIDTH. */
static void
@@ -24203,7 +24302,7 @@ pint2str (register char *buf, register int width, register ptrdiff_t d)
}
}
-/* Write a null-terminated, right justified decimal and "human
+/* Write a NUL-terminated, right justified decimal and "human
readable" representation of the nonnegative integer D to BUF using
a minimal field width WIDTH. D should be smaller than 999.5e24. */
@@ -24349,7 +24448,7 @@ decode_mode_spec_coding (Lisp_Object coding_system, char *buf, bool eol_flag)
eolvalue = AREF (val, 2);
*buf++ = multibyte
- ? XFASTINT (CODING_ATTR_MNEMONIC (attrs))
+ ? XFIXNAT (CODING_ATTR_MNEMONIC (attrs))
: ' ';
if (eol_flag)
@@ -24378,7 +24477,7 @@ decode_mode_spec_coding (Lisp_Object coding_system, char *buf, bool eol_flag)
}
else if (CHARACTERP (eoltype))
{
- int c = XFASTINT (eoltype);
+ int c = XFIXNAT (eoltype);
return buf + CHAR_STRING (c, (unsigned char *) buf);
}
else
@@ -24423,7 +24522,7 @@ decode_mode_spec (struct window *w, register int c, int field_width,
produce strings from numerical values, so limit preposterously
large values of FIELD_WIDTH to avoid overrunning the buffer's
end. The size of the buffer is enough for FRAME_MESSAGE_BUF_SIZE
- bytes plus the terminating null. */
+ bytes plus the terminating NUL. */
int width = min (field_width, FRAME_MESSAGE_BUF_SIZE (f));
struct buffer *b = current_buffer;
@@ -24584,8 +24683,8 @@ decode_mode_spec (struct window *w, register int c, int field_width,
goto no_value;
/* If the buffer is very big, don't waste time. */
- if (INTEGERP (Vline_number_display_limit)
- && BUF_ZV (b) - BUF_BEGV (b) > XINT (Vline_number_display_limit))
+ if (FIXNUMP (Vline_number_display_limit)
+ && BUF_ZV (b) - BUF_BEGV (b) > XFIXNUM (Vline_number_display_limit))
{
w->base_line_pos = 0;
w->base_line_number = 0;
@@ -24629,8 +24728,12 @@ decode_mode_spec (struct window *w, register int c, int field_width,
ptrdiff_t limit = BUF_BEGV (b);
ptrdiff_t limit_byte = BUF_BEGV_BYTE (b);
ptrdiff_t position;
- ptrdiff_t distance =
- (height * 2 + 30) * line_number_display_limit_width;
+ ptrdiff_t distance
+ = (line_number_display_limit_width < 0 ? 0
+ : INT_MULTIPLY_WRAPV (line_number_display_limit_width,
+ height * 2 + 30,
+ &distance)
+ ? PTRDIFF_MAX : distance);
if (startpos - distance > limit)
{
@@ -24790,7 +24893,7 @@ decode_mode_spec (struct window *w, register int c, int field_width,
if (STRINGP (curdir))
val = call1 (intern ("file-remote-p"), curdir);
- unbind_to (count, Qnil);
+ val = unbind_to (count, val);
if (NILP (val))
return "-";
@@ -24873,7 +24976,7 @@ display_count_lines (ptrdiff_t start_byte,
check only for newlines. */
bool selective_display
= (!NILP (BVAR (current_buffer, selective_display))
- && !INTEGERP (BVAR (current_buffer, selective_display)));
+ && !FIXNUMP (BVAR (current_buffer, selective_display)));
if (count > 0)
{
@@ -25272,13 +25375,13 @@ display may depend on `buffer-invisibility-spec', which see. */)
(Lisp_Object pos)
{
Lisp_Object prop
- = (NATNUMP (pos) || MARKERP (pos)
+ = (FIXNATP (pos) || MARKERP (pos)
? Fget_char_property (pos, Qinvisible, Qnil)
: pos);
int invis = TEXT_PROP_MEANS_INVISIBLE (prop);
return (invis == 0 ? Qnil
: invis == 1 ? Qt
- : make_number (invis));
+ : make_fixnum (invis));
}
/* Calculate a width or height in pixels from a specification using
@@ -25552,7 +25655,7 @@ calc_pixel_width_or_height (double *res, struct it *it, Lisp_Object prop,
/* '(NUM)': absolute number of pixels. */
if (NUMBERP (car))
- {
+{
double fact;
int offset =
width_p && align_to && *align_to < 0 ? it->lnum_pixel_width : 0;
@@ -27182,23 +27285,23 @@ produce_image_glyph (struct it *it)
slice.width = img->width;
slice.height = img->height;
- if (INTEGERP (it->slice.x))
- slice.x = XINT (it->slice.x);
+ if (FIXNUMP (it->slice.x))
+ slice.x = XFIXNUM (it->slice.x);
else if (FLOATP (it->slice.x))
slice.x = XFLOAT_DATA (it->slice.x) * img->width;
- if (INTEGERP (it->slice.y))
- slice.y = XINT (it->slice.y);
+ if (FIXNUMP (it->slice.y))
+ slice.y = XFIXNUM (it->slice.y);
else if (FLOATP (it->slice.y))
slice.y = XFLOAT_DATA (it->slice.y) * img->height;
- if (INTEGERP (it->slice.width))
- slice.width = XINT (it->slice.width);
+ if (FIXNUMP (it->slice.width))
+ slice.width = XFIXNUM (it->slice.width);
else if (FLOATP (it->slice.width))
slice.width = XFLOAT_DATA (it->slice.width) * img->width;
- if (INTEGERP (it->slice.height))
- slice.height = XINT (it->slice.height);
+ if (FIXNUMP (it->slice.height))
+ slice.height = XFIXNUM (it->slice.height);
else if (FLOATP (it->slice.height))
slice.height = XFLOAT_DATA (it->slice.height) * img->height;
@@ -27832,7 +27935,7 @@ calc_line_height_property (struct it *it, Lisp_Object val, struct font *font,
face_name = XCAR (val);
val = XCDR (val);
if (!NUMBERP (val))
- val = make_number (1);
+ val = make_fixnum (1);
if (NILP (face_name))
{
height = it->ascent + it->descent;
@@ -27854,10 +27957,10 @@ calc_line_height_property (struct it *it, Lisp_Object val, struct font *font,
int face_id;
struct face *face;
- face_id = lookup_named_face (it->f, face_name, false);
+ face_id = lookup_named_face (it->w, it->f, face_name, false);
face = FACE_FROM_ID_OR_NULL (it->f, face_id);
if (face == NULL || ((font = face->font) == NULL))
- return make_number (-1);
+ return make_fixnum (-1);
boff = font->baseline_offset;
if (font->vertical_centering)
boff = VCENTER_BASELINE_OFFSET (font, it->f) - boff;
@@ -27875,12 +27978,17 @@ calc_line_height_property (struct it *it, Lisp_Object val, struct font *font,
height = ascent + descent;
scale:
+ /* FIXME: Check for overflow in multiplication or conversion. */
if (FLOATP (val))
height = (int)(XFLOAT_DATA (val) * height);
else if (INTEGERP (val))
- height *= XINT (val);
+ {
+ intmax_t v;
+ if (integer_to_intmax (val, &v))
+ height *= v;
+ }
- return make_number (height);
+ return make_fixnum (height);
}
@@ -28252,7 +28360,7 @@ x_produce_glyphs (struct it *it)
/* If face has an overline, add the height of the overline
(1 pixel) and a 1 pixel margin to the character height. */
if (face->overline_p)
- it->ascent += overline_margin;
+ it->ascent += clip_to_bounds (0, overline_margin, 1000000);
if (it->constrain_row_ascent_descent_p)
{
@@ -28368,8 +28476,8 @@ x_produce_glyphs (struct it *it)
it->descent += face->box_line_width;
}
if (!NILP (height)
- && XINT (height) > it->ascent + it->descent)
- it->ascent = XINT (height) - it->descent;
+ && XFIXNUM (height) > it->ascent + it->descent)
+ it->ascent = XFIXNUM (height) - it->descent;
if (!NILP (total_height))
spacing = calc_line_height_property (it, total_height, font,
@@ -28380,9 +28488,9 @@ x_produce_glyphs (struct it *it)
spacing = calc_line_height_property (it, spacing, font,
boff, false);
}
- if (INTEGERP (spacing))
+ if (FIXNUMP (spacing))
{
- extra_line_spacing = XINT (spacing);
+ extra_line_spacing = XFIXNUM (spacing);
if (!NILP (total_height))
extra_line_spacing -= (it->phys_ascent + it->phys_descent);
}
@@ -28599,7 +28707,7 @@ x_produce_glyphs (struct it *it)
&& font->default_ascent
&& CHAR_TABLE_P (Vuse_default_ascent)
&& !NILP (Faref (Vuse_default_ascent,
- make_number (it->char_to_display))))
+ make_fixnum (it->char_to_display))))
highest = font->default_ascent + boff;
/* Draw the first glyph at the normal position. It may be
@@ -28650,7 +28758,7 @@ x_produce_glyphs (struct it *it)
if (font->relative_compose
&& (! CHAR_TABLE_P (Vignore_relative_composition)
|| NILP (Faref (Vignore_relative_composition,
- make_number (ch)))))
+ make_fixnum (ch)))))
{
if (- descent >= font->relative_compose)
@@ -28793,7 +28901,7 @@ x_produce_glyphs (struct it *it)
/* If face has an overline, add the height of the overline
(1 pixel) and a 1 pixel margin to the character height. */
if (face->overline_p)
- it->ascent += overline_margin;
+ it->ascent += clip_to_bounds (0, overline_margin, 1000000);
take_vertical_position_into_account (it);
if (it->ascent < 0)
@@ -28842,7 +28950,7 @@ x_produce_glyphs (struct it *it)
/* If face has an overline, add the height of the overline
(1 pixel) and a 1 pixel margin to the character height. */
if (face->overline_p)
- it->ascent += overline_margin;
+ it->ascent += clip_to_bounds (0, overline_margin, 1000000);
take_vertical_position_into_account (it);
if (it->ascent < 0)
it->ascent = 0;
@@ -29086,9 +29194,9 @@ get_specified_cursor_type (Lisp_Object arg, int *width)
if (CONSP (arg)
&& EQ (XCAR (arg), Qbar)
- && RANGED_INTEGERP (0, XCDR (arg), INT_MAX))
+ && RANGED_FIXNUMP (0, XCDR (arg), INT_MAX))
{
- *width = XINT (XCDR (arg));
+ *width = XFIXNUM (XCDR (arg));
return BAR_CURSOR;
}
@@ -29100,9 +29208,9 @@ get_specified_cursor_type (Lisp_Object arg, int *width)
if (CONSP (arg)
&& EQ (XCAR (arg), Qhbar)
- && RANGED_INTEGERP (0, XCDR (arg), INT_MAX))
+ && RANGED_FIXNUMP (0, XCDR (arg), INT_MAX))
{
- *width = XINT (XCDR (arg));
+ *width = XFIXNUM (XCDR (arg));
return HBAR_CURSOR;
}
@@ -29909,7 +30017,7 @@ show_mouse_face (Mouse_HLInfo *hlinfo, enum draw_glyphs_face draw)
/* Change the mouse cursor. */
if (FRAME_WINDOW_P (f) && NILP (do_mouse_tracking))
{
-#if ! defined (USE_GTK) && ! defined (HAVE_NS)
+#ifndef HAVE_EXT_TOOL_BAR
if (draw == DRAW_NORMAL_TEXT
&& !EQ (hlinfo->mouse_face_window, f->tool_bar_window))
FRAME_RIF (f)->define_frame_cursor (f, FRAME_X_OUTPUT (f)->text_cursor);
@@ -30725,13 +30833,13 @@ on_hot_spot_p (Lisp_Object hot_spot, int x, int y)
return false;
if (!CONSP (XCDR (rect)))
return false;
- if (!(tem = XCAR (XCAR (rect)), INTEGERP (tem) && x >= XINT (tem)))
+ if (!(tem = XCAR (XCAR (rect)), FIXNUMP (tem) && x >= XFIXNUM (tem)))
return false;
- if (!(tem = XCDR (XCAR (rect)), INTEGERP (tem) && y >= XINT (tem)))
+ if (!(tem = XCDR (XCAR (rect)), FIXNUMP (tem) && y >= XFIXNUM (tem)))
return false;
- if (!(tem = XCAR (XCDR (rect)), INTEGERP (tem) && x <= XINT (tem)))
+ if (!(tem = XCAR (XCDR (rect)), FIXNUMP (tem) && x <= XFIXNUM (tem)))
return false;
- if (!(tem = XCDR (XCDR (rect)), INTEGERP (tem) && y <= XINT (tem)))
+ if (!(tem = XCDR (XCDR (rect)), FIXNUMP (tem) && y <= XFIXNUM (tem)))
return false;
return true;
}
@@ -30743,12 +30851,12 @@ on_hot_spot_p (Lisp_Object hot_spot, int x, int y)
if (CONSP (circ)
&& CONSP (XCAR (circ))
&& (lr = XCDR (circ), NUMBERP (lr))
- && (lx0 = XCAR (XCAR (circ)), INTEGERP (lx0))
- && (ly0 = XCDR (XCAR (circ)), INTEGERP (ly0)))
+ && (lx0 = XCAR (XCAR (circ)), FIXNUMP (lx0))
+ && (ly0 = XCDR (XCAR (circ)), FIXNUMP (ly0)))
{
double r = XFLOATINT (lr);
- double dx = XINT (lx0) - x;
- double dy = XINT (ly0) - y;
+ double dx = XFIXNUM (lx0) - x;
+ double dy = XFIXNUM (ly0) - y;
return (dx * dx + dy * dy <= r * r);
}
}
@@ -30773,17 +30881,17 @@ on_hot_spot_p (Lisp_Object hot_spot, int x, int y)
If count is odd, we are inside polygon. Pixels on edges
may or may not be included depending on actual geometry of the
polygon. */
- if ((lx = poly[n-2], !INTEGERP (lx))
- || (ly = poly[n-1], !INTEGERP (lx)))
+ if ((lx = poly[n-2], !FIXNUMP (lx))
+ || (ly = poly[n-1], !FIXNUMP (lx)))
return false;
- x0 = XINT (lx), y0 = XINT (ly);
+ x0 = XFIXNUM (lx), y0 = XFIXNUM (ly);
for (i = 0; i < n; i += 2)
{
int x1 = x0, y1 = y0;
- if ((lx = poly[i], !INTEGERP (lx))
- || (ly = poly[i+1], !INTEGERP (ly)))
+ if ((lx = poly[i], !FIXNUMP (lx))
+ || (ly = poly[i+1], !FIXNUMP (ly)))
return false;
- x0 = XINT (lx), y0 = XINT (ly);
+ x0 = XFIXNUM (lx), y0 = XFIXNUM (ly);
/* Does this segment cross the X line? */
if (x0 >= x)
@@ -30835,12 +30943,12 @@ Returns the alist element for the first matching AREA in MAP. */)
if (NILP (map))
return Qnil;
- CHECK_NUMBER (x);
- CHECK_NUMBER (y);
+ CHECK_FIXNUM (x);
+ CHECK_FIXNUM (y);
return find_hot_spot (map,
- clip_to_bounds (INT_MIN, XINT (x), INT_MAX),
- clip_to_bounds (INT_MIN, XINT (y), INT_MAX));
+ clip_to_bounds (INT_MIN, XFIXNUM (x), INT_MAX),
+ clip_to_bounds (INT_MIN, XFIXNUM (y), INT_MAX));
}
#endif /* HAVE_WINDOW_SYSTEM */
@@ -30899,9 +31007,6 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y,
struct window *w = XWINDOW (window);
struct frame *f = XFRAME (w->frame);
Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f);
-#ifdef HAVE_WINDOW_SYSTEM
- Display_Info *dpyinfo;
-#endif
Cursor cursor = No_Cursor;
Lisp_Object pointer = Qnil;
int dx, dy, width, height;
@@ -30991,11 +31096,12 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y,
#endif /* HAVE_WINDOW_SYSTEM */
if (STRINGP (string))
- pos = make_number (charpos);
+ pos = make_fixnum (charpos);
/* Set the help text and mouse pointer. If the mouse is on a part
of the mode line without any text (e.g. past the right edge of
- the mode line text), use the default help text and pointer. */
+ the mode line text), use that windows's mode line help echo if it
+ has been set. */
if (STRINGP (string) || area == ON_MODE_LINE)
{
/* Arrange to display the help by setting the global variables
@@ -31012,19 +31118,13 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y,
help_echo_object = string;
help_echo_pos = charpos;
}
- else if (area == ON_MODE_LINE)
+ else if (area == ON_MODE_LINE
+ && !NILP (w->mode_line_help_echo))
{
- Lisp_Object default_help
- = buffer_local_value (Qmode_line_default_help_echo,
- w->contents);
-
- if (STRINGP (default_help))
- {
- help_echo_string = default_help;
- XSETWINDOW (help_echo_window, w);
- help_echo_object = Qnil;
- help_echo_pos = -1;
- }
+ help_echo_string = w->mode_line_help_echo;
+ XSETWINDOW (help_echo_window, w);
+ help_echo_object = Qnil;
+ help_echo_pos = -1;
}
}
@@ -31036,7 +31136,6 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y,
|| minibuf_level
|| NILP (Vresize_mini_windows));
- dpyinfo = FRAME_DISPLAY_INFO (f);
if (STRINGP (string))
{
cursor = FRAME_X_OUTPUT (f)->nontext_cursor;
@@ -31046,25 +31145,28 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y,
/* Change the mouse pointer according to what is under X/Y. */
if (NILP (pointer)
- && ((area == ON_MODE_LINE) || (area == ON_HEADER_LINE)))
+ && (area == ON_MODE_LINE || area == ON_HEADER_LINE))
{
Lisp_Object map;
+
map = Fget_text_property (pos, Qlocal_map, string);
if (!KEYMAPP (map))
map = Fget_text_property (pos, Qkeymap, string);
- if (!KEYMAPP (map) && draggable)
- cursor = dpyinfo->vertical_scroll_bar_cursor;
+ if (!KEYMAPP (map) && draggable && area == ON_MODE_LINE)
+ cursor = FRAME_X_OUTPUT (f)->vertical_drag_cursor;
}
}
- else if (draggable)
- /* Default mode-line pointer. */
- cursor = FRAME_DISPLAY_INFO (f)->vertical_scroll_bar_cursor;
+ else if (draggable && area == ON_MODE_LINE)
+ cursor = FRAME_X_OUTPUT (f)->vertical_drag_cursor;
+ else
+ cursor = FRAME_X_OUTPUT (f)->nontext_cursor;
}
#endif
}
/* Change the mouse face according to what is under X/Y. */
bool mouse_face_shown = false;
+
if (STRINGP (string))
{
mouse_face = Fget_text_property (pos, Qmouse_face, string);
@@ -31083,18 +31185,18 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y,
int vpos, hpos;
- b = Fprevious_single_property_change (make_number (charpos + 1),
+ b = Fprevious_single_property_change (make_fixnum (charpos + 1),
Qmouse_face, string, Qnil);
if (NILP (b))
begpos = 0;
else
- begpos = XINT (b);
+ begpos = XFIXNUM (b);
e = Fnext_single_property_change (pos, Qmouse_face, string, Qnil);
if (NILP (e))
endpos = SCHARS (string);
else
- endpos = XINT (e);
+ endpos = XFIXNUM (e);
/* Calculate the glyph position GPOS of GLYPH in the
displayed string, relative to the beginning of the
@@ -31317,7 +31419,7 @@ note_mouse_highlight (struct frame *f, int x, int y)
w = XWINDOW (window);
frame_to_window_pixel_xy (w, &x, &y);
-#if defined (HAVE_WINDOW_SYSTEM) && ! defined (USE_GTK) && ! defined (HAVE_NS)
+#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_TOOL_BAR)
/* Handle tool-bar window differently since it doesn't display a
buffer. */
if (EQ (window, f->tool_bar_window))
@@ -31492,7 +31594,7 @@ note_mouse_highlight (struct frame *f, int x, int y)
ZV = Z;
/* Is this char mouse-active or does it have help-echo? */
- position = make_number (pos);
+ position = make_fixnum (pos);
USE_SAFE_ALLOCA;
@@ -31563,15 +31665,15 @@ note_mouse_highlight (struct frame *f, int x, int y)
ptrdiff_t ignore;
s = Fprevious_single_property_change
- (make_number (pos + 1), Qmouse_face, object, Qnil);
+ (make_fixnum (pos + 1), Qmouse_face, object, Qnil);
e = Fnext_single_property_change
(position, Qmouse_face, object, Qnil);
if (NILP (s))
- s = make_number (0);
+ s = make_fixnum (0);
if (NILP (e))
- e = make_number (SCHARS (object));
+ e = make_fixnum (SCHARS (object));
mouse_face_from_string_pos (w, hlinfo, object,
- XINT (s), XINT (e));
+ XFIXNUM (s), XFIXNUM (e));
hlinfo->mouse_face_past_end = false;
hlinfo->mouse_face_window = window;
hlinfo->mouse_face_face_id
@@ -31597,7 +31699,7 @@ note_mouse_highlight (struct frame *f, int x, int y)
if (pos > 0)
{
mouse_face = get_char_property_and_overlay
- (make_number (pos), Qmouse_face, w->contents, &overlay);
+ (make_fixnum (pos), Qmouse_face, w->contents, &overlay);
buffer = w->contents;
disp_string = object;
}
@@ -31628,7 +31730,7 @@ note_mouse_highlight (struct frame *f, int x, int y)
: Qnil;
Lisp_Object lim2
= NILP (BVAR (XBUFFER (buffer), bidi_display_reordering))
- ? make_number (BUF_Z (XBUFFER (buffer))
+ ? make_fixnum (BUF_Z (XBUFFER (buffer))
- w->window_end_pos)
: Qnil;
@@ -31636,9 +31738,9 @@ note_mouse_highlight (struct frame *f, int x, int y)
{
/* Handle the text property case. */
before = Fprevious_single_property_change
- (make_number (pos + 1), Qmouse_face, buffer, lim1);
+ (make_fixnum (pos + 1), Qmouse_face, buffer, lim1);
after = Fnext_single_property_change
- (make_number (pos), Qmouse_face, buffer, lim2);
+ (make_fixnum (pos), Qmouse_face, buffer, lim2);
before_string = after_string = Qnil;
}
else
@@ -31656,10 +31758,10 @@ note_mouse_highlight (struct frame *f, int x, int y)
mouse_face_from_buffer_pos (window, hlinfo, pos,
NILP (before)
? 1
- : XFASTINT (before),
+ : XFIXNAT (before),
NILP (after)
? BUF_Z (XBUFFER (buffer))
- : XFASTINT (after),
+ : XFIXNAT (after),
before_string, after_string,
disp_string);
cursor = No_Cursor;
@@ -31698,7 +31800,7 @@ note_mouse_highlight (struct frame *f, int x, int y)
&& charpos >= 0
&& charpos < SCHARS (obj))
{
- help = Fget_text_property (make_number (charpos),
+ help = Fget_text_property (make_fixnum (charpos),
Qhelp_echo, obj);
if (NILP (help))
{
@@ -31710,7 +31812,7 @@ note_mouse_highlight (struct frame *f, int x, int y)
ptrdiff_t p = string_buffer_position (obj, start);
if (p > 0)
{
- help = Fget_char_property (make_number (p),
+ help = Fget_char_property (make_fixnum (p),
Qhelp_echo, w->contents);
if (!NILP (help))
{
@@ -31723,7 +31825,7 @@ note_mouse_highlight (struct frame *f, int x, int y)
else if (BUFFERP (obj)
&& charpos >= BEGV
&& charpos < ZV)
- help = Fget_text_property (make_number (charpos), Qhelp_echo,
+ help = Fget_text_property (make_fixnum (charpos), Qhelp_echo,
obj);
if (!NILP (help))
@@ -31754,7 +31856,7 @@ note_mouse_highlight (struct frame *f, int x, int y)
&& charpos >= 0
&& charpos < SCHARS (obj))
{
- pointer = Fget_text_property (make_number (charpos),
+ pointer = Fget_text_property (make_fixnum (charpos),
Qpointer, obj);
if (NILP (pointer))
{
@@ -31765,14 +31867,14 @@ note_mouse_highlight (struct frame *f, int x, int y)
ptrdiff_t start = MATRIX_ROW_START_CHARPOS (r);
ptrdiff_t p = string_buffer_position (obj, start);
if (p > 0)
- pointer = Fget_char_property (make_number (p),
+ pointer = Fget_char_property (make_fixnum (p),
Qpointer, w->contents);
}
}
else if (BUFFERP (obj)
&& charpos >= BEGV
&& charpos < ZV)
- pointer = Fget_text_property (make_number (charpos),
+ pointer = Fget_text_property (make_fixnum (charpos),
Qpointer, obj);
}
}
@@ -32089,7 +32191,7 @@ x_draw_bottom_divider (struct window *w)
int x1 = WINDOW_RIGHT_EDGE_X (w);
int y0 = WINDOW_BOTTOM_EDGE_Y (w) - WINDOW_BOTTOM_DIVIDER_WIDTH (w);
int y1 = WINDOW_BOTTOM_EDGE_Y (w);
- struct window *p = !NILP (w->parent) ? XWINDOW (w->parent) : false;
+ struct window *p = !NILP (w->parent) ? XWINDOW (w->parent) : NULL;
/* If W is vertically combined and has a sibling below, don't draw
over any right divider. */
@@ -32173,6 +32275,18 @@ expose_window (struct window *w, XRectangle *fr)
y0 or y1 is negative (can happen for tall images). */
int r_bottom = r.y + r.height;
+ /* We must temporarily switch to the window's buffer, in case
+ the fringe face has been remapped in that buffer's
+ face-remapping-alist, so that draw_row_fringe_bitmaps,
+ called from expose_line, will use the right face. */
+ bool buffer_changed = false;
+ struct buffer *oldbuf = current_buffer;
+ if (!w->pseudo_window_p)
+ {
+ set_buffer_internal_1 (XBUFFER (w->contents));
+ buffer_changed = true;
+ }
+
/* Update lines intersecting rectangle R. */
first_overlapping_row = last_overlapping_row = NULL;
for (row = w->current_matrix->rows;
@@ -32218,6 +32332,9 @@ expose_window (struct window *w, XRectangle *fr)
break;
}
+ if (buffer_changed)
+ set_buffer_internal_1 (oldbuf);
+
/* Display the mode line if there is one. */
if (window_wants_mode_line (w)
&& (row = MATRIX_MODE_LINE_ROW (w->current_matrix),
@@ -32327,7 +32444,7 @@ expose_frame (struct frame *f, int x, int y, int w, int h)
TRACE ((stderr, "(%d, %d, %d, %d)\n", r.x, r.y, r.width, r.height));
mouse_face_overwritten_p = expose_window_tree (XWINDOW (f->root_window), &r);
-#if ! defined (USE_GTK) && ! defined (HAVE_NS)
+#ifndef HAVE_EXT_TOOL_BAR
if (WINDOWP (f->tool_bar_window))
mouse_face_overwritten_p
|= expose_window (XWINDOW (f->tool_bar_window), &r);
@@ -32748,7 +32865,7 @@ not span the full frame width.
A value of nil means to respect the value of `truncate-lines'.
If `word-wrap' is enabled, you might want to reduce this. */);
- Vtruncate_partial_width_windows = make_number (50);
+ Vtruncate_partial_width_windows = make_fixnum (50);
DEFVAR_LISP ("line-number-display-limit", Vline_number_display_limit,
doc: /* Maximum buffer size for which line number should be displayed.
@@ -32789,20 +32906,18 @@ and is used only on frames for which no explicit name has been set
\(see `modify-frame-parameters'). */);
Vicon_title_format
= Vframe_title_format
- = listn (CONSTYPE_PURE, 3,
- intern_c_string ("multiple-frames"),
- build_pure_c_string ("%b"),
- listn (CONSTYPE_PURE, 4,
- empty_unibyte_string,
- intern_c_string ("invocation-name"),
- build_pure_c_string ("@"),
- intern_c_string ("system-name")));
+ = pure_list (intern_c_string ("multiple-frames"),
+ build_pure_c_string ("%b"),
+ pure_list (empty_unibyte_string,
+ intern_c_string ("invocation-name"),
+ build_pure_c_string ("@"),
+ intern_c_string ("system-name")));
DEFVAR_LISP ("message-log-max", Vmessage_log_max,
doc: /* Maximum number of lines to keep in the message log buffer.
If nil, disable message logging. If t, log messages but don't truncate
the buffer when it becomes large. */);
- Vmessage_log_max = make_number (1000);
+ Vmessage_log_max = make_fixnum (1000);
DEFVAR_LISP ("window-scroll-functions", Vwindow_scroll_functions,
doc: /* List of functions to call before redisplaying a window with scrolling.
@@ -32862,9 +32977,15 @@ automatically; to decrease the tool-bar height, use \\[recenter]. */);
doc: /* Non-nil means raise tool-bar buttons when the mouse moves over them. */);
auto_raise_tool_bar_buttons_p = true;
- DEFVAR_BOOL ("make-cursor-line-fully-visible", make_cursor_line_fully_visible_p,
- doc: /* Non-nil means to scroll (recenter) cursor line if it is not fully visible. */);
- make_cursor_line_fully_visible_p = true;
+ DEFVAR_LISP ("make-cursor-line-fully-visible", Vmake_cursor_line_fully_visible,
+ doc: /* Whether to scroll the window if the cursor line is not fully visible.
+If the value is non-nil, Emacs scrolls or recenters the window to make
+the cursor line fully visible. The value could also be a function, which
+is called with a single argument, the window to be scrolled, and should
+return non-nil if the partially-visible cursor requires scrolling the
+window, nil if it's okay to leave the cursor partially-visible. */);
+ Vmake_cursor_line_fully_visible = Qt;
+ DEFSYM (Qmake_cursor_line_fully_visible, "make-cursor-line-fully-visible");
DEFVAR_LISP ("tool-bar-border", Vtool_bar_border,
doc: /* Border below tool-bar in pixels.
@@ -32880,7 +33001,7 @@ If an integer, use that for both horizontal and vertical margins.
Otherwise, value should be a pair of integers `(HORZ . VERT)' with
HORZ specifying the horizontal margin, and VERT specifying the
vertical margin. */);
- Vtool_bar_button_margin = make_number (DEFAULT_TOOL_BAR_BUTTON_MARGIN);
+ Vtool_bar_button_margin = make_fixnum (DEFAULT_TOOL_BAR_BUTTON_MARGIN);
DEFVAR_INT ("tool-bar-button-relief", tool_bar_button_relief,
doc: /* Relief thickness of tool-bar buttons. */);
@@ -32937,7 +33058,11 @@ A value of nil means don't automatically resize mini-windows.
A value of t means resize them to fit the text displayed in them.
A value of `grow-only', the default, means let mini-windows grow only;
they return to their normal size when the minibuffer is closed, or the
-echo area becomes empty. */);
+echo area becomes empty.
+
+This variable does not affect resizing of the minibuffer window of
+minibuffer-only frames. These are handled by 'resize-mini-frames'
+only. */);
/* Contrary to the doc string, we initialize this to nil, so that
loading loadup.el won't try to resize windows before loading
window.el, where some functions we need to call for this live.
@@ -32988,7 +33113,7 @@ scroll more than the value given by the scroll step.
Note that the lower bound for automatic hscrolling specified by `scroll-left'
and `scroll-right' overrides this variable's effect. */);
- Vhscroll_step = make_number (0);
+ Vhscroll_step = make_fixnum (0);
DEFVAR_BOOL ("message-truncate-lines", message_truncate_lines,
doc: /* If non-nil, messages are truncated instead of resizing the echo area.
@@ -33127,6 +33252,7 @@ particularly when using variable `x-use-underline-position-properties'
with fonts that specify an UNDERLINE_POSITION relatively close to the
baseline. The default value is 1. */);
underline_minimum_offset = 1;
+ DEFSYM (Qunderline_minimum_offset, "underline-minimum-offset");
DEFVAR_BOOL ("display-hourglass", display_hourglass_p,
doc: /* Non-nil means show an hourglass pointer, when Emacs is busy.
@@ -33136,7 +33262,7 @@ cursor shapes. */);
DEFVAR_LISP ("hourglass-delay", Vhourglass_delay,
doc: /* Seconds to wait before displaying an hourglass pointer when Emacs is busy. */);
- Vhourglass_delay = make_number (DEFAULT_HOURGLASS_DELAY);
+ Vhourglass_delay = make_fixnum (DEFAULT_HOURGLASS_DELAY);
#ifdef HAVE_WINDOW_SYSTEM
hourglass_atimer = NULL;
@@ -33161,7 +33287,7 @@ or t (meaning all windows). */);
/* Symbol for the purpose of Vglyphless_char_display. */
DEFSYM (Qglyphless_char_display, "glyphless-char-display");
- Fput (Qglyphless_char_display, Qchar_table_extra_slots, make_number (1));
+ Fput (Qglyphless_char_display, Qchar_table_extra_slots, make_fixnum (1));
DEFVAR_LISP ("glyphless-char-display", Vglyphless_char_display,
doc: /* Char-table defining glyphless characters.
@@ -33184,7 +33310,7 @@ If a character has a non-nil entry in an active display table, the
display table takes effect; in this case, Emacs does not consult
`glyphless-char-display' at all. */);
Vglyphless_char_display = Fmake_char_table (Qglyphless_char_display, Qnil);
- Fset_char_table_extra_slot (Vglyphless_char_display, make_number (0),
+ Fset_char_table_extra_slot (Vglyphless_char_display, make_fixnum (0),
Qempty_box);
DEFVAR_LISP ("debug-on-message", Vdebug_on_message,
@@ -33252,7 +33378,7 @@ init_xdisp (void)
/* The default ellipsis glyphs `...'. */
for (i = 0; i < 3; ++i)
- default_invis_vector[i] = make_number ('.');
+ default_invis_vector[i] = make_fixnum ('.');
}
{
@@ -33311,9 +33437,9 @@ start_hourglass (void)
cancel_hourglass ();
- if (INTEGERP (Vhourglass_delay)
- && XINT (Vhourglass_delay) > 0)
- delay = make_timespec (min (XINT (Vhourglass_delay),
+ if (FIXNUMP (Vhourglass_delay)
+ && XFIXNUM (Vhourglass_delay) > 0)
+ delay = make_timespec (min (XFIXNUM (Vhourglass_delay),
TYPE_MAXIMUM (time_t)),
0);
else if (FLOATP (Vhourglass_delay)
diff --git a/src/xfaces.c b/src/xfaces.c
index a219fe89e42..c6723ebe2c3 100644
--- a/src/xfaces.c
+++ b/src/xfaces.c
@@ -350,7 +350,8 @@ static bool realize_default_face (struct frame *);
static void realize_named_face (struct frame *, Lisp_Object, int);
static struct face_cache *make_face_cache (struct frame *);
static void free_face_cache (struct face_cache *);
-static bool merge_face_ref (struct frame *, Lisp_Object, Lisp_Object *,
+static bool merge_face_ref (struct window *w,
+ struct frame *, Lisp_Object, Lisp_Object *,
bool, struct named_merge_point *);
static int color_distance (XColor *x, XColor *y);
@@ -735,11 +736,11 @@ the pixmap. Bits are stored row by row, each row occupies
}
if (STRINGP (data)
- && RANGED_INTEGERP (1, width, INT_MAX)
- && RANGED_INTEGERP (1, height, INT_MAX))
+ && RANGED_FIXNUMP (1, width, INT_MAX)
+ && RANGED_FIXNUMP (1, height, INT_MAX))
{
- int bytes_per_row = (XINT (width) + CHAR_BIT - 1) / CHAR_BIT;
- if (XINT (height) <= SBYTES (data) / bytes_per_row)
+ int bytes_per_row = (XFIXNUM (width) + CHAR_BIT - 1) / CHAR_BIT;
+ if (XFIXNUM (height) <= SBYTES (data) / bytes_per_row)
pixmap_p = true;
}
}
@@ -772,8 +773,8 @@ load_pixmap (struct frame *f, Lisp_Object name)
int h, w;
Lisp_Object bits;
- w = XINT (Fcar (name));
- h = XINT (Fcar (Fcdr (name)));
+ w = XFIXNUM (Fcar (name));
+ h = XFIXNUM (Fcar (Fcdr (name)));
bits = Fcar (Fcdr (Fcdr (name)));
bitmap_id = x_create_bitmap_from_data (f, SSDATA (bits),
@@ -817,9 +818,9 @@ static bool
parse_rgb_list (Lisp_Object rgb_list, XColor *color)
{
#define PARSE_RGB_LIST_FIELD(field) \
- if (CONSP (rgb_list) && INTEGERP (XCAR (rgb_list))) \
+ if (CONSP (rgb_list) && FIXNUMP (XCAR (rgb_list))) \
{ \
- color->field = XINT (XCAR (rgb_list)); \
+ color->field = XFIXNUM (XCAR (rgb_list)); \
rgb_list = XCDR (rgb_list); \
} \
else \
@@ -854,10 +855,10 @@ tty_lookup_color (struct frame *f, Lisp_Object color, XColor *tty_color,
{
Lisp_Object rgb;
- if (! INTEGERP (XCAR (XCDR (color_desc))))
+ if (! FIXNUMP (XCAR (XCDR (color_desc))))
return false;
- tty_color->pixel = XINT (XCAR (XCDR (color_desc)));
+ tty_color->pixel = XFIXNUM (XCAR (XCDR (color_desc)));
rgb = XCDR (XCDR (color_desc));
if (! parse_rgb_list (rgb, tty_color))
@@ -970,7 +971,7 @@ tty_color_name (struct frame *f, int idx)
Lisp_Object coldesc;
XSETFRAME (frame, f);
- coldesc = call2 (Qtty_color_by_index, make_number (idx), frame);
+ coldesc = call2 (Qtty_color_by_index, make_fixnum (idx), frame);
if (!NILP (coldesc))
return XCAR (coldesc);
@@ -1156,8 +1157,6 @@ load_color (struct frame *f, struct face *face, Lisp_Object name,
#ifdef HAVE_WINDOW_SYSTEM
-#define NEAR_SAME_COLOR_THRESHOLD 30000
-
/* Load colors for face FACE which is used on frame F. Colors are
specified by slots LFACE_BACKGROUND_INDEX and LFACE_FOREGROUND_INDEX
of ATTRS. If the background color specified is not supported on F,
@@ -1198,7 +1197,7 @@ load_face_colors (struct frame *f, struct face *face,
dfg = attrs[LFACE_DISTANT_FOREGROUND_INDEX];
if (!NILP (dfg) && !UNSPECIFIEDP (dfg)
- && color_distance (&xbg, &xfg) < NEAR_SAME_COLOR_THRESHOLD)
+ && color_distance (&xbg, &xfg) < face_near_same_color_threshold)
{
if (EQ (attrs[LFACE_INVERSE_INDEX], Qt))
face->background = load_color (f, face, dfg, LFACE_BACKGROUND_INDEX);
@@ -1389,12 +1388,12 @@ compare_fonts_by_sort_order (const void *v1, const void *v2)
}
else
{
- if (INTEGERP (val1))
- result = (INTEGERP (val2) && XINT (val1) >= XINT (val2)
- ? XINT (val1) > XINT (val2)
+ if (FIXNUMP (val1))
+ result = (FIXNUMP (val2) && XFIXNUM (val1) >= XFIXNUM (val2)
+ ? XFIXNUM (val1) > XFIXNUM (val2)
: -1);
else
- result = INTEGERP (val2) ? 1 : 0;
+ result = FIXNUMP (val2) ? 1 : 0;
}
if (result)
return result;
@@ -1423,7 +1422,6 @@ the face font sort order. */)
Lisp_Object font_spec, list, *drivers, vec;
struct frame *f = decode_live_frame (frame);
ptrdiff_t i, nfonts;
- EMACS_INT ndrivers;
Lisp_Object result;
USE_SAFE_ALLOCA;
@@ -1456,7 +1454,7 @@ the face font sort order. */)
font_props_for_sorting[i++] = FONT_ADSTYLE_INDEX;
font_props_for_sorting[i++] = FONT_REGISTRY_INDEX;
- ndrivers = XINT (Flength (list));
+ ptrdiff_t ndrivers = list_length (list);
SAFE_ALLOCA_LISP (drivers, ndrivers);
for (i = 0; i < ndrivers; i++, list = XCDR (list))
drivers[i] = XCAR (list);
@@ -1476,9 +1474,9 @@ the face font sort order. */)
ASET (v, 0, AREF (font, FONT_FAMILY_INDEX));
ASET (v, 1, FONT_WIDTH_SYMBOLIC (font));
- point = PIXEL_TO_POINT (XINT (AREF (font, FONT_SIZE_INDEX)) * 10,
+ point = PIXEL_TO_POINT (XFIXNUM (AREF (font, FONT_SIZE_INDEX)) * 10,
FRAME_RES_Y (f));
- ASET (v, 2, make_number (point));
+ ASET (v, 2, make_fixnum (point));
ASET (v, 3, FONT_WEIGHT_SYMBOLIC (font));
ASET (v, 4, FONT_SLANT_SYMBOLIC (font));
spacing = Ffont_get (font, QCspacing);
@@ -1525,10 +1523,10 @@ the WIDTH times as wide as FACE on FRAME. */)
CHECK_STRING (pattern);
if (! NILP (maximum))
- CHECK_NATNUM (maximum);
+ CHECK_FIXNAT (maximum);
if (!NILP (width))
- CHECK_NUMBER (width);
+ CHECK_FIXNUM (width);
/* We can't simply call decode_window_system_frame because
this function may be called before any frame is created. */
@@ -1551,7 +1549,7 @@ the WIDTH times as wide as FACE on FRAME. */)
{
/* This is of limited utility since it works with character
widths. Keep it for compatibility. --gerd. */
- int face_id = lookup_named_face (f, face, false);
+ int face_id = lookup_named_face (NULL, f, face, false);
struct face *width_face = FACE_FROM_ID_OR_NULL (f, face_id);
if (width_face && width_face->font)
@@ -1565,7 +1563,7 @@ the WIDTH times as wide as FACE on FRAME. */)
avgwidth = FRAME_FONT (f)->average_width;
}
if (!NILP (width))
- avgwidth *= XINT (width);
+ avgwidth *= XFIXNUM (width);
}
Lisp_Object font_spec = font_spec_from_name (pattern);
@@ -1574,8 +1572,8 @@ the WIDTH times as wide as FACE on FRAME. */)
if (size)
{
- Ffont_put (font_spec, QCsize, make_number (size));
- Ffont_put (font_spec, QCavgwidth, make_number (avgwidth));
+ Ffont_put (font_spec, QCsize, make_fixnum (size));
+ Ffont_put (font_spec, QCavgwidth, make_fixnum (avgwidth));
}
Lisp_Object fonts = Flist_fonts (font_spec, frame, maximum, font_spec);
for (Lisp_Object tail = fonts; CONSP (tail); tail = XCDR (tail))
@@ -1584,7 +1582,7 @@ the WIDTH times as wide as FACE on FRAME. */)
font_entity = XCAR (tail);
if ((NILP (AREF (font_entity, FONT_SIZE_INDEX))
- || XINT (AREF (font_entity, FONT_SIZE_INDEX)) == 0)
+ || XFIXNUM (AREF (font_entity, FONT_SIZE_INDEX)) == 0)
&& ! NILP (AREF (font_spec, FONT_SIZE_INDEX)))
{
/* This is a scalable font. For backward compatibility,
@@ -1599,7 +1597,7 @@ the WIDTH times as wide as FACE on FRAME. */)
/* We don't have to check fontsets. */
return fonts;
Lisp_Object fontsets = list_fontsets (f, pattern, size);
- return CALLN (Fnconc, fonts, fontsets);
+ return nconc2 (fonts, fontsets);
}
#endif /* HAVE_WINDOW_SYSTEM */
@@ -1683,7 +1681,7 @@ check_lface_attrs (Lisp_Object attrs[LFACE_VECTOR_SIZE])
|| IGNORE_DEFFACE_P (attrs[LFACE_BOX_INDEX])
|| SYMBOLP (attrs[LFACE_BOX_INDEX])
|| STRINGP (attrs[LFACE_BOX_INDEX])
- || INTEGERP (attrs[LFACE_BOX_INDEX])
+ || FIXNUMP (attrs[LFACE_BOX_INDEX])
|| CONSP (attrs[LFACE_BOX_INDEX]));
eassert (UNSPECIFIEDP (attrs[LFACE_INVERSE_INDEX])
|| IGNORE_DEFFACE_P (attrs[LFACE_INVERSE_INDEX])
@@ -1907,19 +1905,22 @@ get_lface_attributes_no_remap (struct frame *f, Lisp_Object face_name,
return !NILP (lface);
}
-/* Get face attributes of face FACE_NAME from frame-local faces on frame
- F. Store the resulting attributes in ATTRS which must point to a
- vector of Lisp_Objects of size LFACE_VECTOR_SIZE. If FACE_NAME is an
- alias for another face, use that face's definition.
- If SIGNAL_P, signal an error if FACE_NAME does not name a face.
- Otherwise, return true iff FACE_NAME is a face. */
-
+/* Get face attributes of face FACE_NAME from frame-local faces on
+ frame F. Store the resulting attributes in ATTRS which must point
+ to a vector of Lisp_Objects of size LFACE_VECTOR_SIZE.
+ If FACE_NAME is an alias for another face, use that face's
+ definition. If SIGNAL_P, signal an error if FACE_NAME does not
+ name a face. Otherwise, return true iff FACE_NAME is a face. If W
+ is non-NULL, also consider remappings attached to the window.
+ */
static bool
-get_lface_attributes (struct frame *f, Lisp_Object face_name,
+get_lface_attributes (struct window *w,
+ struct frame *f, Lisp_Object face_name,
Lisp_Object attrs[LFACE_VECTOR_SIZE], bool signal_p,
struct named_merge_point *named_merge_points)
{
Lisp_Object face_remapping;
+ eassert (w == NULL || WINDOW_XFRAME (w) == f);
face_name = resolve_face_name (face_name, signal_p);
@@ -1939,7 +1940,7 @@ get_lface_attributes (struct frame *f, Lisp_Object face_name,
for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
attrs[i] = Qunspecified;
- return merge_face_ref (f, XCDR (face_remapping), attrs,
+ return merge_face_ref (w, f, XCDR (face_remapping), attrs,
signal_p, named_merge_points);
}
}
@@ -2003,7 +2004,7 @@ set_lface_from_font (struct frame *f, Lisp_Object lface,
int pt = PIXEL_TO_POINT (font->pixel_size * 10, FRAME_RES_Y (f));
eassert (pt > 0);
- ASET (lface, LFACE_HEIGHT_INDEX, make_number (pt));
+ ASET (lface, LFACE_HEIGHT_INDEX, make_fixnum (pt));
}
if (force_p || UNSPECIFIEDP (LFACE_WEIGHT (lface)))
@@ -2039,15 +2040,15 @@ merge_face_heights (Lisp_Object from, Lisp_Object to, Lisp_Object invalid)
{
Lisp_Object result = invalid;
- if (INTEGERP (from))
+ if (FIXNUMP (from))
/* FROM is absolute, just use it as is. */
result = from;
else if (FLOATP (from))
/* FROM is a scale, use it to adjust TO. */
{
- if (INTEGERP (to))
+ if (FIXNUMP (to))
/* relative X absolute => absolute */
- result = make_number (XFLOAT_DATA (from) * XINT (to));
+ result = make_fixnum (XFLOAT_DATA (from) * XFIXNUM (to));
else if (FLOATP (to))
/* relative X relative => relative */
result = make_float (XFLOAT_DATA (from) * XFLOAT_DATA (to));
@@ -2062,7 +2063,7 @@ merge_face_heights (Lisp_Object from, Lisp_Object to, Lisp_Object invalid)
result = safe_call1 (from, to);
/* Ensure that if TO was absolute, so is the result. */
- if (INTEGERP (to) && !INTEGERP (result))
+ if (FIXNUMP (to) && !FIXNUMP (result))
result = invalid;
}
@@ -2072,15 +2073,16 @@ merge_face_heights (Lisp_Object from, Lisp_Object to, Lisp_Object invalid)
/* Merge two Lisp face attribute vectors on frame F, FROM and TO, and
store the resulting attributes in TO, which must be already be
- completely specified and contain only absolute attributes. Every
- specified attribute of FROM overrides the corresponding attribute of
- TO; relative attributes in FROM are merged with the absolute value in
- TO and replace it. NAMED_MERGE_POINTS is used internally to detect
- loops in face inheritance/remapping; it should be 0 when called from
- other places. */
-
+ completely specified and contain only absolute attributes.
+ Every specified attribute of FROM overrides the corresponding
+ attribute of TO; relative attributes in FROM are merged with the
+ absolute value in TO and replace it. NAMED_MERGE_POINTS is used
+ internally to detect loops in face inheritance/remapping; it should
+ be 0 when called from other places. If window W is non-NULL, use W
+ to interpret face specifications. */
static void
-merge_face_vectors (struct frame *f, Lisp_Object *from, Lisp_Object *to,
+merge_face_vectors (struct window *w,
+ struct frame *f, Lisp_Object *from, Lisp_Object *to,
struct named_merge_point *named_merge_points)
{
int i;
@@ -2093,7 +2095,8 @@ merge_face_vectors (struct frame *f, Lisp_Object *from, Lisp_Object *to,
other code uses `unspecified' as a generic value for face attributes. */
if (!UNSPECIFIEDP (from[LFACE_INHERIT_INDEX])
&& !NILP (from[LFACE_INHERIT_INDEX]))
- merge_face_ref (f, from[LFACE_INHERIT_INDEX], to, false, named_merge_points);
+ merge_face_ref (w, f, from[LFACE_INHERIT_INDEX],
+ to, false, named_merge_points);
if (FONT_SPEC_P (from[LFACE_FONT_INDEX]))
{
@@ -2107,7 +2110,7 @@ merge_face_vectors (struct frame *f, Lisp_Object *from, Lisp_Object *to,
for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
if (!UNSPECIFIEDP (from[i]))
{
- if (i == LFACE_HEIGHT_INDEX && !INTEGERP (from[i]))
+ if (i == LFACE_HEIGHT_INDEX && !FIXNUMP (from[i]))
{
to[i] = merge_face_heights (from[i], to[i], to[i]);
font_clear_prop (to, FONT_SIZE_INDEX);
@@ -2153,10 +2156,12 @@ merge_face_vectors (struct frame *f, Lisp_Object *from, Lisp_Object *to,
/* Merge the named face FACE_NAME on frame F, into the vector of face
attributes TO. Use NAMED_MERGE_POINTS to detect loops in face
inheritance. Return true if FACE_NAME is a valid face name and
- merging succeeded. */
+ merging succeeded. Window W, if non-NULL, is used to filter face
+ specifications. */
static bool
-merge_named_face (struct frame *f, Lisp_Object face_name, Lisp_Object *to,
+merge_named_face (struct window *w,
+ struct frame *f, Lisp_Object face_name, Lisp_Object *to,
struct named_merge_point *named_merge_points)
{
struct named_merge_point named_merge_point;
@@ -2166,11 +2171,11 @@ merge_named_face (struct frame *f, Lisp_Object face_name, Lisp_Object *to,
&named_merge_points))
{
Lisp_Object from[LFACE_VECTOR_SIZE];
- bool ok = get_lface_attributes (f, face_name, from, false,
+ bool ok = get_lface_attributes (w, f, face_name, from, false,
named_merge_points);
if (ok)
- merge_face_vectors (f, from, to, named_merge_points);
+ merge_face_vectors (w, f, from, to, named_merge_points);
return ok;
}
@@ -2178,6 +2183,119 @@ merge_named_face (struct frame *f, Lisp_Object face_name, Lisp_Object *to,
return false;
}
+/* Determine whether the face filter FILTER evaluated in window W
+ matches. W can be NULL if the window context is unknown.
+
+ A face filter is either nil, which always matches, or a list
+ (:window PARAMETER VALUE), which matches if the current window has
+ a PARAMETER EQ to VALUE.
+
+ This function returns true if the face filter matches, and false if
+ it doesn't or if the function encountered an error. If the filter
+ is invalid, set *OK to false and, if ERR_MSGS is true, log an error
+ message. On success, *OK is untouched. */
+static bool
+evaluate_face_filter (Lisp_Object filter, struct window *w,
+ bool *ok, bool err_msgs)
+{
+ Lisp_Object orig_filter = filter;
+
+ /* Inner braces keep compiler happy about the goto skipping variable
+ initialization. */
+ {
+ if (NILP (filter))
+ return true;
+
+ if (face_filters_always_match)
+ return true;
+
+ if (!CONSP (filter))
+ goto err;
+
+ if (!EQ (XCAR (filter), QCwindow))
+ goto err;
+ filter = XCDR (filter);
+
+ Lisp_Object parameter = XCAR (filter);
+ filter = XCDR (filter);
+ if (!CONSP (filter))
+ goto err;
+
+ Lisp_Object value = XCAR (filter);
+ filter = XCDR (filter);
+ if (!NILP (filter))
+ goto err;
+
+ bool match = false;
+ if (w)
+ {
+ Lisp_Object found = assq_no_quit (parameter, w->window_parameters);
+ if (!NILP (found) && EQ (XCDR (found), value))
+ match = true;
+ }
+
+ return match;
+ }
+
+ err:
+ if (err_msgs)
+ add_to_log ("Invalid face filter %S", orig_filter);
+ *ok = false;
+ return false;
+}
+
+/* Determine whether FACE_REF is a "filter" face specification (case
+ #4 in merge_face_ref). If it is, evaluate the filter, and if the
+ filter matches, return the filtered face spec. If the filter does
+ not match, return `nil'. If FACE_REF is not a filtered face
+ specification, return FACE_REF.
+
+ On error, set *OK to false, having logged an error message if
+ ERR_MSGS is true, and return `nil'. Otherwise, *OK is not touched.
+
+ W is either NULL or a window used to evaluate filters. If W is
+ NULL, no window-based face specification filter matches.
+*/
+static Lisp_Object
+filter_face_ref (Lisp_Object face_ref,
+ struct window *w,
+ bool *ok,
+ bool err_msgs)
+{
+ Lisp_Object orig_face_ref = face_ref;
+ if (!CONSP (face_ref))
+ return face_ref;
+
+ /* Inner braces keep compiler happy about the goto skipping variable
+ initialization. */
+ {
+ if (!EQ (XCAR (face_ref), QCfiltered))
+ return face_ref;
+ face_ref = XCDR (face_ref);
+
+ if (!CONSP (face_ref))
+ goto err;
+ Lisp_Object filter = XCAR (face_ref);
+ face_ref = XCDR (face_ref);
+
+ if (!CONSP (face_ref))
+ goto err;
+ Lisp_Object filtered_face_ref = XCAR (face_ref);
+ face_ref = XCDR (face_ref);
+
+ if (!NILP (face_ref))
+ goto err;
+
+ return evaluate_face_filter (filter, w, ok, err_msgs)
+ ? filtered_face_ref : Qnil;
+ }
+
+ err:
+ if (err_msgs)
+ add_to_log ("Invalid face ref %S", orig_face_ref);
+ *ok = false;
+ return Qnil;
+}
/* Merge face attributes from the lisp `face reference' FACE_REF on
frame F into the face attribute vector TO. If ERR_MSGS,
@@ -2199,14 +2317,38 @@ merge_named_face (struct frame *f, Lisp_Object face_name, Lisp_Object *to,
(BACKGROUND-COLOR . COLOR) where COLOR is a color name. This is
for compatibility with 20.2.
+ 4. Conses of the form
+ (:filtered (:window PARAMETER VALUE) FACE-SPECIFICATION),
+ which applies FACE-SPECIFICATION only if the
+ given face attributes are being evaluated in the context of a
+ window with a parameter named PARAMETER being EQ VALUE.
+
+ 5. nil, which means to merge nothing.
+
Face specifications earlier in lists take precedence over later
specifications. */
static bool
-merge_face_ref (struct frame *f, Lisp_Object face_ref, Lisp_Object *to,
+merge_face_ref (struct window *w,
+ struct frame *f, Lisp_Object face_ref, Lisp_Object *to,
bool err_msgs, struct named_merge_point *named_merge_points)
{
bool ok = true; /* Succeed without an error? */
+ Lisp_Object filtered_face_ref;
+
+ filtered_face_ref = face_ref;
+ do
+ {
+ face_ref = filtered_face_ref;
+ filtered_face_ref = filter_face_ref (face_ref, w, &ok, err_msgs);
+ }
+ while (ok && !EQ (face_ref, filtered_face_ref));
+
+ if (!ok)
+ return false;
+
+ if (NILP (face_ref))
+ return true;
if (CONSP (face_ref))
{
@@ -2331,8 +2473,8 @@ merge_face_ref (struct frame *f, Lisp_Object face_ref, Lisp_Object *to,
else if (EQ (keyword, QCbox))
{
if (EQ (value, Qt))
- value = make_number (1);
- if (INTEGERP (value)
+ value = make_fixnum (1);
+ if (FIXNUMP (value)
|| STRINGP (value)
|| CONSP (value)
|| NILP (value))
@@ -2400,7 +2542,7 @@ merge_face_ref (struct frame *f, Lisp_Object face_ref, Lisp_Object *to,
{
/* This is not really very useful; it's just like a
normal face reference. */
- if (! merge_face_ref (f, value, to,
+ if (! merge_face_ref (w, f, value, to,
err_msgs, named_merge_points))
err = true;
}
@@ -2424,16 +2566,16 @@ merge_face_ref (struct frame *f, Lisp_Object face_ref, Lisp_Object *to,
Lisp_Object next = XCDR (face_ref);
if (! NILP (next))
- ok = merge_face_ref (f, next, to, err_msgs, named_merge_points);
+ ok = merge_face_ref (w, f, next, to, err_msgs, named_merge_points);
- if (! merge_face_ref (f, first, to, err_msgs, named_merge_points))
+ if (! merge_face_ref (w, f, first, to, err_msgs, named_merge_points))
ok = false;
}
}
else
{
/* FACE_REF ought to be a face name. */
- ok = merge_named_face (f, face_ref, to, named_merge_points);
+ ok = merge_named_face (w, f, face_ref, to, named_merge_points);
if (!ok && err_msgs)
add_to_log ("Invalid face reference: %s", face_ref);
}
@@ -2470,8 +2612,7 @@ Value is a vector of face attributes. */)
/* Add a global definition if there is none. */
if (NILP (global_lface))
{
- global_lface = Fmake_vector (make_number (LFACE_VECTOR_SIZE),
- Qunspecified);
+ global_lface = make_vector (LFACE_VECTOR_SIZE, Qunspecified);
ASET (global_lface, 0, Qface);
Vface_new_frame_defaults = Fcons (Fcons (face, global_lface),
Vface_new_frame_defaults);
@@ -2486,7 +2627,7 @@ Value is a vector of face attributes. */)
sizeof *lface_id_to_name);
lface_id_to_name[next_lface_id] = face;
- Fput (face, Qface, make_number (next_lface_id));
+ Fput (face, Qface, make_fixnum (next_lface_id));
++next_lface_id;
}
else if (f == NULL)
@@ -2498,8 +2639,7 @@ Value is a vector of face attributes. */)
{
if (NILP (lface))
{
- lface = Fmake_vector (make_number (LFACE_VECTOR_SIZE),
- Qunspecified);
+ lface = make_vector (LFACE_VECTOR_SIZE, Qunspecified);
ASET (lface, 0, Qface);
fset_face_alist (f, Fcons (Fcons (face, lface), f->face_alist));
}
@@ -2647,7 +2787,7 @@ FRAME 0 means change the face on all frames, and change the default
/* If FRAME is 0, change face on all frames, and change the
default for new frames. */
- if (INTEGERP (frame) && XINT (frame) == 0)
+ if (FIXNUMP (frame) && XFIXNUM (frame) == 0)
{
Lisp_Object tail;
Finternal_set_lisp_face_attribute (face, attr, value, Qt);
@@ -2717,7 +2857,7 @@ FRAME 0 means change the face on all frames, and change the default
if (EQ (face, Qdefault))
{
/* The default face must have an absolute size. */
- if (!INTEGERP (value) || XINT (value) <= 0)
+ if (!FIXNUMP (value) || XFIXNUM (value) <= 0)
signal_error ("Default face height not absolute and positive",
value);
}
@@ -2726,9 +2866,9 @@ FRAME 0 means change the face on all frames, and change the default
/* For non-default faces, do a test merge with a random
height to see if VALUE's ok. */
Lisp_Object test = merge_face_heights (value,
- make_number (10),
+ make_fixnum (10),
Qnil);
- if (!INTEGERP (test) || XINT (test) <= 0)
+ if (!FIXNUMP (test) || XFIXNUM (test) <= 0)
signal_error ("Face height does not produce a positive integer",
value);
}
@@ -2826,7 +2966,7 @@ FRAME 0 means change the face on all frames, and change the default
if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
if ((SYMBOLP (value)
&& !EQ (value, Qt)
- && !EQ (value, Qnil))
+ && !NILP (value))
/* Overline color. */
|| (STRINGP (value)
&& SCHARS (value) == 0))
@@ -2840,7 +2980,7 @@ FRAME 0 means change the face on all frames, and change the default
if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
if ((SYMBOLP (value)
&& !EQ (value, Qt)
- && !EQ (value, Qnil))
+ && !NILP (value))
/* Strike-through color. */
|| (STRINGP (value)
&& SCHARS (value) == 0))
@@ -2856,14 +2996,14 @@ FRAME 0 means change the face on all frames, and change the default
/* Allow t meaning a simple box of width 1 in foreground color
of the face. */
if (EQ (value, Qt))
- value = make_number (1);
+ value = make_fixnum (1);
if (UNSPECIFIEDP (value) || IGNORE_DEFFACE_P (value))
valid_p = true;
else if (NILP (value))
valid_p = true;
- else if (INTEGERP (value))
- valid_p = XINT (value) != 0;
+ else if (FIXNUMP (value))
+ valid_p = XFIXNUM (value) != 0;
else if (STRINGP (value))
valid_p = SCHARS (value) > 0;
else if (CONSP (value))
@@ -2884,7 +3024,7 @@ FRAME 0 means change the face on all frames, and change the default
if (EQ (k, QCline_width))
{
- if (!INTEGERP (v) || XINT (v) == 0)
+ if (!FIXNUMP (v) || XFIXNUM (v) == 0)
break;
}
else if (EQ (k, QCcolor))
@@ -3359,7 +3499,7 @@ ordinary `x-get-resource' doesn't take a frame argument. */)
static Lisp_Object
face_boolean_x_resource_value (Lisp_Object value, bool signal_p)
{
- Lisp_Object result = make_number (0);
+ Lisp_Object result = make_fixnum (0);
eassert (STRINGP (value));
@@ -3392,8 +3532,8 @@ DEFUN ("internal-set-lisp-face-attribute-from-resource",
value = Qunspecified;
else if (EQ (attr, QCheight))
{
- value = Fstring_to_number (value, make_number (10));
- if (XINT (value) <= 0)
+ value = Fstring_to_number (value, Qnil);
+ if (!FIXNUMP (value) || XFIXNUM (value) <= 0)
signal_error ("Invalid face height from X resource", value);
}
else if (EQ (attr, QCbold) || EQ (attr, QCitalic))
@@ -3553,7 +3693,7 @@ However, for :height, floating point values are also relative. */
if (EQ (value, Qunspecified) || (EQ (value, QCignore_defface)))
return Qt;
else if (EQ (attribute, QCheight))
- return INTEGERP (value) ? Qnil : Qt;
+ return FIXNUMP (value) ? Qnil : Qt;
else
return Qnil;
}
@@ -3701,7 +3841,7 @@ Default face attributes override any local face attributes. */)
/* Ensure that the face vector is fully specified by merging
the previously-cached vector. */
memcpy (attrs, oldface->lface, sizeof attrs);
- merge_face_vectors (f, lvec, attrs, 0);
+ merge_face_vectors (NULL, f, lvec, attrs, 0);
vcopy (local_lface, 0, attrs, LFACE_VECTOR_SIZE);
newface = realize_face (c, lvec, DEFAULT_FACE_ID);
@@ -3774,7 +3914,7 @@ return the font name used for CHARACTER. */)
else
{
struct frame *f = decode_live_frame (frame);
- int face_id = lookup_named_face (f, face, true);
+ int face_id = lookup_named_face (NULL, f, face, true);
struct face *fface = FACE_FROM_ID_OR_NULL (f, face_id);
if (! fface)
@@ -3783,7 +3923,7 @@ return the font name used for CHARACTER. */)
if (FRAME_WINDOW_P (f) && !NILP (character))
{
CHECK_CHARACTER (character);
- face_id = FACE_FOR_CHAR (f, fface, XINT (character), -1, Qnil);
+ face_id = FACE_FOR_CHAR (f, fface, XFIXNUM (character), -1, Qnil);
fface = FACE_FROM_ID_OR_NULL (f, face_id);
}
return ((fface && fface->font)
@@ -4111,15 +4251,11 @@ two lists of the form (RED GREEN BLUE) aforementioned. */)
signal_error ("Invalid color", color2);
if (NILP (metric))
- return make_number (color_distance (&cdef1, &cdef2));
+ return make_fixnum (color_distance (&cdef1, &cdef2));
else
return call2 (metric,
- list3 (make_number (cdef1.red),
- make_number (cdef1.green),
- make_number (cdef1.blue)),
- list3 (make_number (cdef2.red),
- make_number (cdef2.green),
- make_number (cdef2.blue)));
+ list3i (cdef1.red, cdef1.green, cdef1.blue),
+ list3i (cdef2.red, cdef2.green, cdef2.blue));
}
@@ -4432,10 +4568,12 @@ face_for_font (struct frame *f, Lisp_Object font_object, struct face *base_face)
/* Return the face id of the realized face for named face SYMBOL on
frame F suitable for displaying ASCII characters. Value is -1 if
the face couldn't be determined, which might happen if the default
- face isn't realized and cannot be realized. */
-
+ face isn't realized and cannot be realized. If window W is given,
+ consider face remappings specified for W or for W's buffer. If W
+ is NULL, consider only frame-level face configuration. */
int
-lookup_named_face (struct frame *f, Lisp_Object symbol, bool signal_p)
+lookup_named_face (struct window *w, struct frame *f,
+ Lisp_Object symbol, bool signal_p)
{
Lisp_Object attrs[LFACE_VECTOR_SIZE];
Lisp_Object symbol_attrs[LFACE_VECTOR_SIZE];
@@ -4448,11 +4586,11 @@ lookup_named_face (struct frame *f, Lisp_Object symbol, bool signal_p)
default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
}
- if (! get_lface_attributes (f, symbol, symbol_attrs, signal_p, 0))
+ if (! get_lface_attributes (w, f, symbol, symbol_attrs, signal_p, 0))
return -1;
memcpy (attrs, default_face->lface, sizeof attrs);
- merge_face_vectors (f, symbol_attrs, attrs, 0);
+ merge_face_vectors (w, f, symbol_attrs, attrs, 0);
return lookup_face (f, attrs);
}
@@ -4462,10 +4600,10 @@ lookup_named_face (struct frame *f, Lisp_Object symbol, bool signal_p)
is FACE_ID. The return value will usually simply be FACE_ID, unless that
basic face has bee remapped via Vface_remapping_alist. This function is
conservative: if something goes wrong, it will simply return FACE_ID
- rather than signal an error. */
-
+ rather than signal an error. Window W, if non-NULL, is used to filter
+ face specifications for remapping. */
int
-lookup_basic_face (struct frame *f, int face_id)
+lookup_basic_face (struct window *w, struct frame *f, int face_id)
{
Lisp_Object name, mapping;
int remapped_face_id;
@@ -4487,6 +4625,7 @@ lookup_basic_face (struct frame *f, int face_id)
case MOUSE_FACE_ID: name = Qmouse; break;
case MENU_FACE_ID: name = Qmenu; break;
case WINDOW_DIVIDER_FACE_ID: name = Qwindow_divider; break;
+ case VERTICAL_BORDER_FACE_ID: name = Qvertical_border; break;
case WINDOW_DIVIDER_FIRST_PIXEL_FACE_ID: name = Qwindow_divider_first_pixel; break;
case WINDOW_DIVIDER_LAST_PIXEL_FACE_ID: name = Qwindow_divider_last_pixel; break;
case INTERNAL_BORDER_FACE_ID: name = Qinternal_border; break;
@@ -4504,7 +4643,7 @@ lookup_basic_face (struct frame *f, int face_id)
/* If there is a remapping entry, lookup the face using NAME, which will
handle the remapping too. */
- remapped_face_id = lookup_named_face (f, name, false);
+ remapped_face_id = lookup_named_face (w, f, name, false);
if (remapped_face_id < 0)
return face_id; /* Give up. */
@@ -4537,7 +4676,7 @@ smaller_face (struct frame *f, int face_id, int steps)
face = FACE_FROM_ID (f, face_id);
memcpy (attrs, face->lface, sizeof attrs);
- pt = last_pt = XFASTINT (attrs[LFACE_HEIGHT_INDEX]);
+ pt = last_pt = XFIXNAT (attrs[LFACE_HEIGHT_INDEX]);
new_face_id = face_id;
last_height = FONT_HEIGHT (face->font);
@@ -4548,7 +4687,7 @@ smaller_face (struct frame *f, int face_id, int steps)
{
/* Look up a face for a slightly smaller/larger font. */
pt += delta;
- attrs[LFACE_HEIGHT_INDEX] = make_number (pt);
+ attrs[LFACE_HEIGHT_INDEX] = make_fixnum (pt);
new_face_id = lookup_face (f, attrs);
new_face = FACE_FROM_ID (f, new_face_id);
@@ -4588,7 +4727,7 @@ face_with_height (struct frame *f, int face_id, int height)
face = FACE_FROM_ID (f, face_id);
memcpy (attrs, face->lface, sizeof attrs);
- attrs[LFACE_HEIGHT_INDEX] = make_number (height);
+ attrs[LFACE_HEIGHT_INDEX] = make_fixnum (height);
font_clear_prop (attrs, FONT_SIZE_INDEX);
face_id = lookup_face (f, attrs);
#endif /* HAVE_WINDOW_SYSTEM */
@@ -4602,22 +4741,23 @@ face_with_height (struct frame *f, int face_id, int height)
attributes of the face FACE_ID for attributes that aren't
completely specified by SYMBOL. This is like lookup_named_face,
except that the default attributes come from FACE_ID, not from the
- default face. FACE_ID is assumed to be already realized. */
-
+ default face. FACE_ID is assumed to be already realized.
+ Window W, if non-NULL, filters face specifications. */
int
-lookup_derived_face (struct frame *f, Lisp_Object symbol, int face_id,
+lookup_derived_face (struct window *w,
+ struct frame *f, Lisp_Object symbol, int face_id,
bool signal_p)
{
Lisp_Object attrs[LFACE_VECTOR_SIZE];
Lisp_Object symbol_attrs[LFACE_VECTOR_SIZE];
struct face *default_face;
- if (!get_lface_attributes (f, symbol, symbol_attrs, signal_p, 0))
+ if (!get_lface_attributes (w, f, symbol, symbol_attrs, signal_p, 0))
return -1;
default_face = FACE_FROM_ID (f, face_id);
memcpy (attrs, default_face->lface, sizeof attrs);
- merge_face_vectors (f, symbol_attrs, attrs, 0);
+ merge_face_vectors (w, f, symbol_attrs, attrs, 0);
return lookup_face (f, attrs);
}
@@ -4626,10 +4766,9 @@ DEFUN ("face-attributes-as-vector", Fface_attributes_as_vector,
doc: /* Return a vector of face attributes corresponding to PLIST. */)
(Lisp_Object plist)
{
- Lisp_Object lface;
- lface = Fmake_vector (make_number (LFACE_VECTOR_SIZE),
- Qunspecified);
- merge_face_ref (XFRAME (selected_frame), plist, XVECTOR (lface)->contents,
+ Lisp_Object lface = make_vector (LFACE_VECTOR_SIZE, Qunspecified);
+ merge_face_ref (NULL, XFRAME (selected_frame),
+ plist, XVECTOR (lface)->contents,
true, 0);
return lface;
}
@@ -4713,7 +4852,7 @@ x_supports_face_attributes_p (struct frame *f,
memcpy (merged_attrs, def_attrs, sizeof merged_attrs);
- merge_face_vectors (f, attrs, merged_attrs, 0);
+ merge_face_vectors (NULL, f, attrs, merged_attrs, 0);
face_id = lookup_face (f, merged_attrs);
face = FACE_FROM_ID_OR_NULL (f, face_id);
@@ -4736,8 +4875,8 @@ x_supports_face_attributes_p (struct frame *f,
return true;
s1 = SYMBOL_NAME (face->font->props[i]);
s2 = SYMBOL_NAME (def_face->font->props[i]);
- if (! EQ (Fcompare_strings (s1, make_number (0), Qnil,
- s2, make_number (0), Qnil, Qt), Qt))
+ if (! EQ (Fcompare_strings (s1, make_fixnum (0), Qnil,
+ s2, make_fixnum (0), Qnil, Qt), Qt))
return true;
}
return false;
@@ -4984,7 +5123,7 @@ face for italic. */)
for (i = 0; i < LFACE_VECTOR_SIZE; i++)
attrs[i] = Qunspecified;
- merge_face_ref (f, attributes, attrs, true, 0);
+ merge_face_ref (NULL, f, attributes, attrs, true, 0);
def_face = FACE_FROM_ID_OR_NULL (f, DEFAULT_FACE_ID);
if (def_face == NULL)
@@ -5241,7 +5380,7 @@ realize_default_face (struct frame *f)
ASET (lface, LFACE_FAMILY_INDEX, build_string ("default"));
ASET (lface, LFACE_FOUNDRY_INDEX, LFACE_FAMILY (lface));
ASET (lface, LFACE_SWIDTH_INDEX, Qnormal);
- ASET (lface, LFACE_HEIGHT_INDEX, make_number (1));
+ ASET (lface, LFACE_HEIGHT_INDEX, make_fixnum (1));
if (UNSPECIFIEDP (LFACE_WEIGHT (lface)))
ASET (lface, LFACE_WEIGHT_INDEX, Qnormal);
if (UNSPECIFIEDP (LFACE_SLANT (lface)))
@@ -5353,7 +5492,7 @@ realize_named_face (struct frame *f, Lisp_Object symbol, int id)
/* Merge SYMBOL's face with the default face. */
get_lface_attributes_no_remap (f, symbol, symbol_attrs, true);
- merge_face_vectors (f, symbol_attrs, attrs, 0);
+ merge_face_vectors (NULL, f, symbol_attrs, attrs, 0);
/* Realize the face. */
realize_face (c, attrs, id);
@@ -5525,13 +5664,13 @@ realize_x_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE])
face->box = FACE_SIMPLE_BOX;
face->box_line_width = 1;
}
- else if (INTEGERP (box))
+ else if (FIXNUMP (box))
{
/* Simple box of specified line width in foreground color of the
face. */
- eassert (XINT (box) != 0);
+ eassert (XFIXNUM (box) != 0);
face->box = FACE_SIMPLE_BOX;
- face->box_line_width = XINT (box);
+ face->box_line_width = XFIXNUM (box);
face->box_color = face->foreground;
face->box_color_defaulted_p = true;
}
@@ -5558,8 +5697,8 @@ realize_x_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE])
if (EQ (keyword, QCline_width))
{
- if (INTEGERP (value) && XINT (value) != 0)
- face->box_line_width = XINT (value);
+ if (FIXNUMP (value) && XFIXNUM (value) != 0)
+ face->box_line_width = XFIXNUM (value);
}
else if (EQ (keyword, QCcolor))
{
@@ -5725,7 +5864,7 @@ map_tty_color (struct frame *f, struct face *face,
{
/* Associations in tty-defined-color-alist are of the form
(NAME INDEX R G B). We need the INDEX part. */
- pixel = XINT (XCAR (XCDR (def)));
+ pixel = XFIXNUM (XCAR (XCDR (def)));
}
if (pixel == default_pixel && STRINGP (color))
@@ -5868,7 +6007,7 @@ compute_char_face (struct frame *f, int ch, Lisp_Object prop)
Lisp_Object attrs[LFACE_VECTOR_SIZE];
struct face *default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
memcpy (attrs, default_face->lface, sizeof attrs);
- merge_face_ref (f, prop, attrs, true, 0);
+ merge_face_ref (NULL, f, prop, attrs, true, 0);
face_id = lookup_face (f, attrs);
}
@@ -5924,8 +6063,8 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos,
prop = Fget_text_property (position, propname, w->contents);
XSETFASTINT (limit1, (limit < endpos ? limit : endpos));
end = Fnext_single_property_change (position, propname, w->contents, limit1);
- if (INTEGERP (end))
- endpos = XINT (end);
+ if (FIXNUMP (end))
+ endpos = XFIXNUM (end);
/* Look at properties from overlays. */
USE_SAFE_ALLOCA;
@@ -5949,12 +6088,12 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos,
cached faces since we've looked up the base face, we need
to look it up again. */
if (!FACE_FROM_ID_OR_NULL (f, face_id))
- face_id = lookup_basic_face (f, DEFAULT_FACE_ID);
+ face_id = lookup_basic_face (w, f, DEFAULT_FACE_ID);
}
else if (NILP (Vface_remapping_alist))
face_id = DEFAULT_FACE_ID;
else
- face_id = lookup_basic_face (f, DEFAULT_FACE_ID);
+ face_id = lookup_basic_face (w, f, DEFAULT_FACE_ID);
default_face = FACE_FROM_ID (f, face_id);
}
@@ -5972,7 +6111,7 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos,
/* Merge in attributes specified via text properties. */
if (!NILP (prop))
- merge_face_ref (f, prop, attrs, true, 0);
+ merge_face_ref (w, f, prop, attrs, true, 0);
/* Now merge the overlay data. */
noverlays = sort_overlays (overlay_vec, noverlays, w);
@@ -5992,7 +6131,7 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos,
so discard the mouse-face text property, if any, and
use the overlay property instead. */
memcpy (attrs, default_face->lface, sizeof attrs);
- merge_face_ref (f, prop, attrs, true, 0);
+ merge_face_ref (w, f, prop, attrs, true, 0);
}
oend = OVERLAY_END (overlay_vec[i]);
@@ -6010,7 +6149,7 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos,
prop = Foverlay_get (overlay_vec[i], propname);
if (!NILP (prop))
- merge_face_ref (f, prop, attrs, true, 0);
+ merge_face_ref (w, f, prop, attrs, true, 0);
oend = OVERLAY_END (overlay_vec[i]);
oendpos = OVERLAY_POSITION (oend);
@@ -6060,8 +6199,8 @@ face_for_overlay_string (struct window *w, ptrdiff_t pos,
prop = Fget_text_property (position, propname, w->contents);
XSETFASTINT (limit1, (limit < endpos ? limit : endpos));
end = Fnext_single_property_change (position, propname, w->contents, limit1);
- if (INTEGERP (end))
- endpos = XINT (end);
+ if (FIXNUMP (end))
+ endpos = XFIXNUM (end);
*endptr = endpos;
@@ -6071,12 +6210,12 @@ face_for_overlay_string (struct window *w, ptrdiff_t pos,
return DEFAULT_FACE_ID;
/* Begin with attributes from the default face. */
- default_face = FACE_FROM_ID (f, lookup_basic_face (f, DEFAULT_FACE_ID));
+ default_face = FACE_FROM_ID (f, lookup_basic_face (w, f, DEFAULT_FACE_ID));
memcpy (attrs, default_face->lface, sizeof attrs);
/* Merge in attributes specified via text properties. */
if (!NILP (prop))
- merge_face_ref (f, prop, attrs, true, 0);
+ merge_face_ref (w, f, prop, attrs, true, 0);
*endptr = endpos;
@@ -6133,8 +6272,8 @@ face_at_string_position (struct window *w, Lisp_Object string,
short, so set the limit to the end of the string. */
XSETFASTINT (limit, SCHARS (string));
end = Fnext_single_property_change (position, prop_name, string, limit);
- if (INTEGERP (end))
- *endptr = XFASTINT (end);
+ if (FIXNUMP (end))
+ *endptr = XFIXNAT (end);
else
*endptr = -1;
@@ -6155,7 +6294,7 @@ face_at_string_position (struct window *w, Lisp_Object string,
/* Merge in attributes specified via text properties. */
if (!NILP (prop))
- merge_face_ref (f, prop, attrs, true, 0);
+ merge_face_ref (w, f, prop, attrs, true, 0);
/* Look up a realized face with the given face attributes,
or realize a new one for ASCII characters. */
@@ -6165,7 +6304,7 @@ face_at_string_position (struct window *w, Lisp_Object string,
/* Merge a face into a realized face.
- F is frame where faces are (to be) realized.
+ W is a window in the frame where faces are (to be) realized.
FACE_NAME is named face to merge.
@@ -6179,9 +6318,10 @@ face_at_string_position (struct window *w, Lisp_Object string,
*/
int
-merge_faces (struct frame *f, Lisp_Object face_name, int face_id,
+merge_faces (struct window *w, Lisp_Object face_name, int face_id,
int base_face_id)
{
+ struct frame *f = WINDOW_XFRAME (w);
Lisp_Object attrs[LFACE_VECTOR_SIZE];
struct face *base_face;
@@ -6196,7 +6336,7 @@ merge_faces (struct frame *f, Lisp_Object face_name, int face_id,
face_name = lface_id_to_name[face_id];
/* When called during make-frame, lookup_derived_face may fail
if the faces are uninitialized. Don't signal an error. */
- face_id = lookup_derived_face (f, face_name, base_face_id, 0);
+ face_id = lookup_derived_face (w, f, face_name, base_face_id, 0);
return (face_id >= 0 ? face_id : base_face_id);
}
@@ -6205,7 +6345,7 @@ merge_faces (struct frame *f, Lisp_Object face_name, int face_id,
if (!NILP (face_name))
{
- if (!merge_named_face (f, face_name, attrs, 0))
+ if (!merge_named_face (w, f, face_name, attrs, 0))
return base_face_id;
}
else
@@ -6216,7 +6356,7 @@ merge_faces (struct frame *f, Lisp_Object face_name, int face_id,
face = FACE_FROM_ID_OR_NULL (f, face_id);
if (!face)
return base_face_id;
- merge_face_vectors (f, face->lface, attrs, 0);
+ merge_face_vectors (w, f, face->lface, attrs, 0);
}
/* Look up a realized face with the given face attributes,
@@ -6262,7 +6402,7 @@ where R,G,B are numbers between 0 and 255 and name is an arbitrary string. */)
char *name = buf + num;
ptrdiff_t len = strlen (name);
len -= 0 < len && name[len - 1] == '\n';
- cmap = Fcons (Fcons (make_string (name, len), make_number (color)),
+ cmap = Fcons (Fcons (make_string (name, len), make_fixnum (color)),
cmap);
}
}
@@ -6327,13 +6467,13 @@ DEFUN ("dump-face", Fdump_face, Sdump_face, 0, 1, 0, doc: /* */)
fprintf (stderr, "\n");
for (i = 0; i < FRAME_FACE_CACHE (SELECTED_FRAME ())->used; ++i)
- Fdump_face (make_number (i));
+ Fdump_face (make_fixnum (i));
}
else
{
struct face *face;
- CHECK_NUMBER (n);
- face = FACE_FROM_ID_OR_NULL (SELECTED_FRAME (), XINT (n));
+ CHECK_FIXNUM (n);
+ face = FACE_FROM_ID_OR_NULL (SELECTED_FRAME (), XFIXNUM (n));
if (face == NULL)
error ("Not a valid face");
dump_realized_face (face);
@@ -6361,6 +6501,37 @@ DEFUN ("show-face-resources", Fshow_face_resources, Sshow_face_resources,
Initialization
***********************************************************************/
+#ifdef HAVE_PDUMPER
+/* All the faces defined during loadup are recorded in
+ face-new-frame-defaults, with the last face first in the list. We
+ need to set next_lface_id to the next face ID number, so that any
+ new faces defined in this session will have face IDs different from
+ those defined during loadup. We also need to set up the
+ lface_id_to_name[] array for the faces that were defined during
+ loadup. */
+void
+init_xfaces (void)
+{
+ if (CONSP (Vface_new_frame_defaults))
+ {
+ /* Allocate the lface_id_to_name[] array. */
+ lface_id_to_name_size = next_lface_id =
+ XFIXNAT (Flength (Vface_new_frame_defaults));
+ lface_id_to_name = xnmalloc (next_lface_id, sizeof *lface_id_to_name);
+
+ /* Store the faces. */
+ Lisp_Object tail;
+ int i = next_lface_id - 1;
+ for (tail = Vface_new_frame_defaults; CONSP (tail); tail = XCDR (tail))
+ {
+ Lisp_Object lface = XCAR (tail);
+ eassert (i >= 0);
+ lface_id_to_name[i--] = XCAR (lface);
+ }
+ }
+}
+#endif
+
void
syms_of_xfaces (void)
{
@@ -6427,6 +6598,11 @@ syms_of_xfaces (void)
DEFSYM (Qunspecified, "unspecified");
DEFSYM (QCignore_defface, ":ignore-defface");
+ /* Used for limiting character attributes to windows with specific
+ characteristics. */
+ DEFSYM (QCwindow, ":window");
+ DEFSYM (QCfiltered, ":filtered");
+
/* The symbol `face-alias'. A symbol having that property is an
alias for another face. Value of the property is the name of
the aliased face. */
@@ -6502,6 +6678,12 @@ syms_of_xfaces (void)
defsubr (&Sdump_colors);
#endif
+ DEFVAR_BOOL ("face-filters-always-match", face_filters_always_match,
+ doc: /* Non-nil means that face filters are always deemed to match.
+This variable is intended for use only by code that evaluates
+the "specifity" of a face specification and should be let-bound
+only for this purpose. */);
+
DEFVAR_LISP ("face-new-frame-defaults", Vface_new_frame_defaults,
doc: /* List of global face definitions (for internal use only.) */);
Vface_new_frame_defaults = Qnil;
@@ -6532,7 +6714,12 @@ other font of the appropriate family and registry is available. */);
doc: /* List of ignored fonts.
Each element is a regular expression that matches names of fonts to
ignore. */);
+#ifdef HAVE_OTF_KANNADA_BUG
+ /* https://debbugs.gnu.org/30193 */
+ Vface_ignored_fonts = list1 (build_string ("Noto Serif Kannada"));
+#else
Vface_ignored_fonts = Qnil;
+#endif
DEFVAR_LISP ("face-remapping-alist", Vface_remapping_alist,
doc: /* Alist of face remappings.
@@ -6545,7 +6732,7 @@ REPLACEMENT is a face specification, i.e. one of the following:
(1) a face name
(2) a property list of attribute/value pairs, or
- (3) a list in which each element has the form of (1) or (2).
+ (3) a list in which each element has one of the above forms.
List values for REPLACEMENT are merged to form the final face
specification, with earlier entries taking precedence, in the same way
@@ -6565,17 +6752,37 @@ causes EXTRA-FACE... or (FACE-ATTR VAL ...) to be _merged_ with the
existing definition of FACE. Note that this isn't necessary for the
default face, since every face inherits from the default face.
-If this variable is made buffer-local, the face remapping takes effect
-only in that buffer. For instance, the mode my-mode could define a
-face `my-mode-default', and then in the mode setup function, do:
+An entry in the list can also be a filtered face expression of the
+form:
+
+ (:filtered FILTER FACE-SPECIFICATION)
+
+This construct applies FACE-SPECIFICATION (which can have any of the
+forms allowed for face specifications generally) only if FILTER
+matches at the moment Emacs wants to draw text with the combined face.
+
+The only filters currently defined are NIL (which always matches) and
+(:window PARAMETER VALUE), which matches only in the context of a
+window with a parameter EQ-equal to VALUE.
+
+An entry in the face list can also be nil, which does nothing.
+
+If `face-remapping-alist' is made buffer-local, the face remapping
+takes effect only in that buffer. For instance, the mode my-mode
+could define a face `my-mode-default', and then in the mode setup
+function, do:
(set (make-local-variable \\='face-remapping-alist)
\\='((default my-mode-default)))).
+You probably want to use the face-remap package included in Emacs
+instead of manipulating face-remapping-alist directly.
+
Because Emacs normally only redraws screen areas when the underlying
buffer contents change, you may need to call `redraw-display' after
changing this variable for it to take effect. */);
Vface_remapping_alist = Qnil;
+ DEFSYM (Qface_remapping_alist,"face-remapping-alist");
DEFVAR_LISP ("face-font-rescale-alist", Vface_font_rescale_alist,
doc: /* Alist of fonts vs the rescaling factors.
@@ -6586,6 +6793,20 @@ RESCALE-RATIO is a floating point number to specify how much larger
a font of 10 point, we actually use a font of 10 * RESCALE-RATIO point. */);
Vface_font_rescale_alist = Qnil;
+ DEFVAR_INT ("face-near-same-color-threshold", face_near_same_color_threshold,
+ doc: /* Threshold for using distant-foreground color instead of foreground.
+
+The value should be an integer number providing the minimum distance
+between two colors that will still qualify them to be used as foreground
+and background. If the value of `color-distance', invoked with a nil
+METRIC argument, for the foreground and background colors of a face is
+less than this threshold, the distant-foreground color, if defined,
+will be used for the face instead of the foreground color.
+
+Lisp programs that change the value of this variable should also
+clear the face cache, see `clear-face-cache'. */);
+ face_near_same_color_threshold = 30000;
+
#ifdef HAVE_WINDOW_SYSTEM
defsubr (&Sbitmap_spec_p);
defsubr (&Sx_list_fonts);
diff --git a/src/xfns.c b/src/xfns.c
index 732bc87814a..13f66f07183 100644
--- a/src/xfns.c
+++ b/src/xfns.c
@@ -215,8 +215,9 @@ x_real_pos_and_offsets (struct frame *f,
int win_x = 0, win_y = 0, outer_x = 0, outer_y = 0;
int real_x = 0, real_y = 0;
bool had_errors = false;
- Window win = (FRAME_PARENT_FRAME (f)
- ? FRAME_X_WINDOW (FRAME_PARENT_FRAME (f))
+ struct frame *parent_frame = FRAME_PARENT_FRAME (f);
+ Window win = (parent_frame
+ ? FRAME_X_WINDOW (parent_frame)
: f->output_data.x->parent_desc);
struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
long max_len = 400;
@@ -273,7 +274,7 @@ x_real_pos_and_offsets (struct frame *f,
should be the outer WM window. */
for (;;)
{
- Window wm_window, rootw;
+ Window wm_window UNINIT, rootw UNINIT;
#ifdef USE_XCB
xcb_query_tree_cookie_t query_tree_cookie;
@@ -355,8 +356,8 @@ x_real_pos_and_offsets (struct frame *f,
outer_geom_cookie = xcb_get_geometry (xcb_conn,
FRAME_OUTER_WINDOW (f));
- if ((dpyinfo->root_window == f->output_data.x->parent_desc)
- && !FRAME_PARENT_FRAME (f))
+ if (!parent_frame
+ && dpyinfo->root_window == f->output_data.x->parent_desc)
/* Try _NET_FRAME_EXTENTS if our parent is the root window. */
prop_cookie = xcb_get_property (xcb_conn, 0, win,
dpyinfo->Xatom_net_frame_extents,
@@ -470,8 +471,7 @@ x_real_pos_and_offsets (struct frame *f,
#endif
}
- if ((dpyinfo->root_window == f->output_data.x->parent_desc)
- && !FRAME_PARENT_FRAME (f))
+ if (!parent_frame && dpyinfo->root_window == f->output_data.x->parent_desc)
{
/* Try _NET_FRAME_EXTENTS if our parent is the root window. */
#ifdef USE_XCB
@@ -1233,7 +1233,7 @@ x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
if (!NILP (shape_var))
{
CHECK_TYPE_RANGED_INTEGER (unsigned, shape_var);
- cursor_data.cursor_num[i] = XINT (shape_var);
+ cursor_data.cursor_num[i] = XFIXNUM (shape_var);
}
else
cursor_data.cursor_num[i] = mouse_cursor_types[i].default_shape;
@@ -1456,7 +1456,7 @@ x_set_icon_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
if (STRINGP (oldval) && EQ (Fstring_equal (oldval, arg), Qt))
return;
}
- else if (!STRINGP (oldval) && EQ (oldval, Qnil) == EQ (arg, Qnil))
+ else if (!STRINGP (oldval) && NILP (oldval) == NILP (arg))
return;
block_input ();
@@ -1531,8 +1531,8 @@ x_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
if (FRAME_MINIBUF_ONLY_P (f) || FRAME_PARENT_FRAME (f))
return;
- if (TYPE_RANGED_INTEGERP (int, value))
- nlines = XINT (value);
+ if (TYPE_RANGED_FIXNUMP (int, value))
+ nlines = XFIXNUM (value);
else
nlines = 0;
@@ -1618,8 +1618,8 @@ x_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
return;
/* Use VALUE only if an int >= 0. */
- if (RANGED_INTEGERP (0, value, INT_MAX))
- nlines = XFASTINT (value);
+ if (RANGED_FIXNUMP (0, value, INT_MAX))
+ nlines = XFIXNAT (value);
else
nlines = 0;
@@ -1661,8 +1661,8 @@ x_change_tool_bar_height (struct frame *f, int height)
FRAME_TOOL_BAR_HEIGHT (f) = height;
FRAME_TOOL_BAR_LINES (f) = lines;
/* Store the `tool-bar-lines' and `height' frame parameters. */
- store_frame_param (f, Qtool_bar_lines, make_number (lines));
- store_frame_param (f, Qheight, make_number (FRAME_LINES (f)));
+ store_frame_param (f, Qtool_bar_lines, make_fixnum (lines));
+ store_frame_param (f, Qheight, make_fixnum (FRAME_LINES (f)));
/* We also have to make sure that the internal border at the top of
the frame, below the menu bar or tool bar, is redrawn when the
@@ -1716,7 +1716,7 @@ x_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldva
int border;
CHECK_TYPE_RANGED_INTEGER (int, arg);
- border = max (XINT (arg), 0);
+ border = max (XFIXNUM (arg), 0);
if (border != FRAME_INTERNAL_BORDER_WIDTH (f))
{
@@ -3261,8 +3261,8 @@ x_icon_verify (struct frame *f, Lisp_Object parms)
icon_y = x_frame_get_and_record_arg (f, parms, Qicon_top, 0, 0, RES_TYPE_NUMBER);
if (!EQ (icon_x, Qunbound) && !EQ (icon_y, Qunbound))
{
- CHECK_NUMBER (icon_x);
- CHECK_NUMBER (icon_y);
+ CHECK_FIXNUM (icon_x);
+ CHECK_FIXNUM (icon_y);
}
else if (!EQ (icon_x, Qunbound) || !EQ (icon_y, Qunbound))
error ("Both left and top icon corners of icon must be specified");
@@ -3292,7 +3292,7 @@ x_icon (struct frame *f, Lisp_Object parms)
block_input ();
if (! EQ (icon_x, Qunbound))
- x_wm_set_icon_position (f, XINT (icon_x), XINT (icon_y));
+ x_wm_set_icon_position (f, XFIXNUM (icon_x), XFIXNUM (icon_y));
#if false /* x_get_arg removes the visibility parameter as a side effect,
but x_create_frame still needs it. */
@@ -3617,7 +3617,7 @@ This function is an internal primitive--use `make-frame' instead. */)
if (EQ (parent, Qunbound))
parent = Qnil;
if (! NILP (parent))
- CHECK_NUMBER (parent);
+ CHECK_FIXNUM (parent);
frame = Qnil;
tem = x_get_arg (dpyinfo, parms, Qminibuffer, "minibuffer", "Minibuffer",
@@ -3725,7 +3725,7 @@ This function is an internal primitive--use `make-frame' instead. */)
/* Specify the parent under which to make this X window. */
if (!NILP (parent))
{
- f->output_data.x->parent_desc = (Window) XFASTINT (parent);
+ f->output_data.x->parent_desc = (Window) XFIXNAT (parent);
f->output_data.x->explicit_parent = true;
}
else
@@ -3782,7 +3782,7 @@ This function is an internal primitive--use `make-frame' instead. */)
/* Frame contents get displaced if an embedded X window has a border. */
if (! FRAME_X_EMBEDDED_P (f))
- x_default_parameter (f, parms, Qborder_width, make_number (0),
+ x_default_parameter (f, parms, Qborder_width, make_fixnum (0),
"borderWidth", "BorderWidth", RES_TYPE_NUMBER);
/* This defaults to 1 in order to match xterm. We recognize either
@@ -3800,15 +3800,15 @@ This function is an internal primitive--use `make-frame' instead. */)
}
x_default_parameter (f, parms, Qinternal_border_width,
#ifdef USE_GTK /* We used to impose 0 in xg_create_frame_widgets. */
- make_number (0),
+ make_fixnum (0),
#else
- make_number (1),
+ make_fixnum (1),
#endif
"internalBorderWidth", "internalBorderWidth",
RES_TYPE_NUMBER);
- x_default_parameter (f, parms, Qright_divider_width, make_number (0),
+ x_default_parameter (f, parms, Qright_divider_width, make_fixnum (0),
NULL, NULL, RES_TYPE_NUMBER);
- x_default_parameter (f, parms, Qbottom_divider_width, make_number (0),
+ x_default_parameter (f, parms, Qbottom_divider_width, make_fixnum (0),
NULL, NULL, RES_TYPE_NUMBER);
x_default_parameter (f, parms, Qvertical_scroll_bars,
#if defined (USE_GTK) && defined (USE_TOOLKIT_SCROLL_BARS)
@@ -3866,10 +3866,10 @@ This function is an internal primitive--use `make-frame' instead. */)
Also process `min-width' and `min-height' parameters right here
because `frame-windows-min-size' needs them. */
tem = x_get_arg (dpyinfo, parms, Qmin_width, NULL, NULL, RES_TYPE_NUMBER);
- if (NUMBERP (tem))
+ if (FIXNUMP (tem))
store_frame_param (f, Qmin_width, tem);
tem = x_get_arg (dpyinfo, parms, Qmin_height, NULL, NULL, RES_TYPE_NUMBER);
- if (NUMBERP (tem))
+ if (FIXNUMP (tem))
store_frame_param (f, Qmin_height, tem);
adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f),
FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, true,
@@ -3882,11 +3882,11 @@ This function is an internal primitive--use `make-frame' instead. */)
x_default_parameter (f, parms, Qmenu_bar_lines,
NILP (Vmenu_bar_mode)
- ? make_number (0) : make_number (1),
+ ? make_fixnum (0) : make_fixnum (1),
NULL, NULL, RES_TYPE_NUMBER);
x_default_parameter (f, parms, Qtool_bar_lines,
NILP (Vtool_bar_mode)
- ? make_number (0) : make_number (1),
+ ? make_fixnum (0) : make_fixnum (1),
NULL, NULL, RES_TYPE_NUMBER);
x_default_parameter (f, parms, Qbuffer_predicate, Qnil,
@@ -4125,7 +4125,7 @@ x_focus_frame (struct frame *f, bool noactivate)
DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0,
- doc: /* Internal function called by `color-defined-p', which see.
+ doc: /* Internal function called by `color-defined-p'.
\(Note that the Nextstep version of this function ignores FRAME.) */)
(Lisp_Object color, Lisp_Object frame)
{
@@ -4141,7 +4141,8 @@ DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0,
}
DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0,
- doc: /* Internal function called by `color-values', which see. */)
+ doc: /* Internal function called by `color-values'.
+\(Note that the Nextstep version of this function ignores FRAME.) */)
(Lisp_Object color, Lisp_Object frame)
{
XColor foo;
@@ -4156,7 +4157,7 @@ DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0,
}
DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0,
- doc: /* Internal function called by `display-color-p', which see. */)
+ doc: /* Internal function called by `display-color-p'. */)
(Lisp_Object terminal)
{
struct x_display_info *dpyinfo = check_x_display_info (terminal);
@@ -4212,6 +4213,7 @@ DEFUN ("x-display-pixel-width", Fx_display_pixel_width, Sx_display_pixel_width,
The optional argument TERMINAL specifies which display to ask about.
TERMINAL should be a terminal object, a frame or a display name (a string).
If omitted or nil, that stands for the selected frame's display.
+\(On MS Windows, this function does not accept terminal objects.)
On \"multi-monitor\" setups this refers to the pixel width for all
physical monitors associated with TERMINAL. To get information for
@@ -4220,7 +4222,7 @@ each physical monitor, use `display-monitor-attributes-list'. */)
{
struct x_display_info *dpyinfo = check_x_display_info (terminal);
- return make_number (x_display_pixel_width (dpyinfo));
+ return make_fixnum (x_display_pixel_width (dpyinfo));
}
DEFUN ("x-display-pixel-height", Fx_display_pixel_height,
@@ -4229,6 +4231,7 @@ DEFUN ("x-display-pixel-height", Fx_display_pixel_height,
The optional argument TERMINAL specifies which display to ask about.
TERMINAL should be a terminal object, a frame or a display name (a string).
If omitted or nil, that stands for the selected frame's display.
+\(On MS Windows, this function does not accept terminal objects.)
On \"multi-monitor\" setups this refers to the pixel height for all
physical monitors associated with TERMINAL. To get information for
@@ -4237,7 +4240,7 @@ each physical monitor, use `display-monitor-attributes-list'. */)
{
struct x_display_info *dpyinfo = check_x_display_info (terminal);
- return make_number (x_display_pixel_height (dpyinfo));
+ return make_fixnum (x_display_pixel_height (dpyinfo));
}
DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes,
@@ -4245,12 +4248,13 @@ DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes,
doc: /* Return the number of bitplanes of the X display TERMINAL.
The optional argument TERMINAL specifies which display to ask about.
TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+If omitted or nil, that stands for the selected frame's display.
+\(On MS Windows, this function does not accept terminal objects.) */)
(Lisp_Object terminal)
{
struct x_display_info *dpyinfo = check_x_display_info (terminal);
- return make_number (dpyinfo->n_planes);
+ return make_fixnum (dpyinfo->n_planes);
}
DEFUN ("x-display-color-cells", Fx_display_color_cells, Sx_display_color_cells,
@@ -4258,7 +4262,8 @@ DEFUN ("x-display-color-cells", Fx_display_color_cells, Sx_display_color_cells,
doc: /* Return the number of color cells of the X display TERMINAL.
The optional argument TERMINAL specifies which display to ask about.
TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+If omitted or nil, that stands for the selected frame's display.
+\(On MS Windows, this function does not accept terminal objects.) */)
(Lisp_Object terminal)
{
struct x_display_info *dpyinfo = check_x_display_info (terminal);
@@ -4273,7 +4278,7 @@ If omitted or nil, that stands for the selected frame's display. */)
it "should be enough for everyone". */
if (nr_planes > 24) nr_planes = 24;
- return make_number (1 << nr_planes);
+ return make_fixnum (1 << nr_planes);
}
DEFUN ("x-server-max-request-size", Fx_server_max_request_size,
@@ -4282,12 +4287,15 @@ DEFUN ("x-server-max-request-size", Fx_server_max_request_size,
doc: /* Return the maximum request size of the X server of display TERMINAL.
The optional argument TERMINAL specifies which display to ask about.
TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+If omitted or nil, that stands for the selected frame's display.
+
+On MS Windows, this function just returns 1.
+On Nextstep, this function just returns nil. */)
(Lisp_Object terminal)
{
struct x_display_info *dpyinfo = check_x_display_info (terminal);
- return make_number (MAXREQUEST (dpyinfo->display));
+ return make_fixnum (MAXREQUEST (dpyinfo->display));
}
DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0,
@@ -4297,8 +4305,8 @@ DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0,
that operating systems cannot be developed and distributed noncommercially.)
The optional argument TERMINAL specifies which display to ask about.
-For GNU and Unix systems, this queries the X server software; for
-MS-Windows, this queries the OS.
+For GNU and Unix systems, this queries the X server software.
+For MS Windows and Nextstep the result is hard-coded.
TERMINAL should be a terminal object, a frame or a display name (a string).
If omitted or nil, that stands for the selected frame's display. */)
@@ -4318,8 +4326,9 @@ software in use.
For GNU and Unix system, the first 2 numbers are the version of the X
Protocol used on TERMINAL and the 3rd number is the distributor-specific
-release number. For MS-Windows, the 3 numbers report the version and
-the build number of the OS.
+release number. For MS Windows, the 3 numbers report the OS major and
+minor version and build number. For Nextstep, the first 2 numbers are
+hard-coded and the 3rd represents the OS version.
See also the function `x-server-vendor'.
@@ -4339,12 +4348,17 @@ DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens, 0, 1, 0,
doc: /* Return the number of screens on the X server of display TERMINAL.
The optional argument TERMINAL specifies which display to ask about.
TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+If omitted or nil, that stands for the selected frame's display.
+
+On MS Windows, this function just returns 1.
+On Nextstep, "screen" is in X terminology, not that of Nextstep.
+For the number of physical monitors, use `(length
+\(display-monitor-attributes-list TERMINAL))' instead. */)
(Lisp_Object terminal)
{
struct x_display_info *dpyinfo = check_x_display_info (terminal);
- return make_number (ScreenCount (dpyinfo->display));
+ return make_fixnum (ScreenCount (dpyinfo->display));
}
DEFUN ("x-display-mm-height", Fx_display_mm_height, Sx_display_mm_height, 0, 1, 0,
@@ -4352,6 +4366,7 @@ DEFUN ("x-display-mm-height", Fx_display_mm_height, Sx_display_mm_height, 0, 1,
The optional argument TERMINAL specifies which display to ask about.
TERMINAL should be a terminal object, a frame or a display name (a string).
If omitted or nil, that stands for the selected frame's display.
+\(On MS Windows, this function does not accept terminal objects.)
On \"multi-monitor\" setups this refers to the height in millimeters for
all physical monitors associated with TERMINAL. To get information
@@ -4360,7 +4375,7 @@ for each physical monitor, use `display-monitor-attributes-list'. */)
{
struct x_display_info *dpyinfo = check_x_display_info (terminal);
- return make_number (HeightMMOfScreen (dpyinfo->screen));
+ return make_fixnum (HeightMMOfScreen (dpyinfo->screen));
}
DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0,
@@ -4368,6 +4383,7 @@ DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0,
The optional argument TERMINAL specifies which display to ask about.
TERMINAL should be a terminal object, a frame or a display name (a string).
If omitted or nil, that stands for the selected frame's display.
+\(On MS Windows, this function does not accept terminal objects.)
On \"multi-monitor\" setups this refers to the width in millimeters for
all physical monitors associated with TERMINAL. To get information
@@ -4376,16 +4392,19 @@ for each physical monitor, use `display-monitor-attributes-list'. */)
{
struct x_display_info *dpyinfo = check_x_display_info (terminal);
- return make_number (WidthMMOfScreen (dpyinfo->screen));
+ return make_fixnum (WidthMMOfScreen (dpyinfo->screen));
}
DEFUN ("x-display-backing-store", Fx_display_backing_store,
Sx_display_backing_store, 0, 1, 0,
doc: /* Return an indication of whether X display TERMINAL does backing store.
-The value may be `always', `when-mapped', or `not-useful'.
The optional argument TERMINAL specifies which display to ask about.
TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+If omitted or nil, that stands for the selected frame's display.
+
+The value may be `always', `when-mapped', or `not-useful'.
+On Nextstep, the value may be `buffered', `retained', or `non-retained'.
+On MS Windows, this returns nothing useful. */)
(Lisp_Object terminal)
{
struct x_display_info *dpyinfo = check_x_display_info (terminal);
@@ -4417,10 +4436,12 @@ DEFUN ("x-display-visual-class", Fx_display_visual_class,
doc: /* Return the visual class of the X display TERMINAL.
The value is one of the symbols `static-gray', `gray-scale',
`static-color', `pseudo-color', `true-color', or `direct-color'.
+\(On MS Windows, the second and last result above are not possible.)
The optional argument TERMINAL specifies which display to ask about.
TERMINAL should a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+If omitted or nil, that stands for the selected frame's display.
+\(On MS Windows, this function does not accept terminal objects.) */)
(Lisp_Object terminal)
{
struct x_display_info *dpyinfo = check_x_display_info (terminal);
@@ -4458,7 +4479,9 @@ DEFUN ("x-display-save-under", Fx_display_save_under,
doc: /* Return t if the X display TERMINAL supports the save-under feature.
The optional argument TERMINAL specifies which display to ask about.
TERMINAL should be a terminal object, a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
+If omitted or nil, that stands for the selected frame's display.
+
+On MS Windows, this just returns nil. */)
(Lisp_Object terminal)
{
struct x_display_info *dpyinfo = check_x_display_info (terminal);
@@ -4605,15 +4628,16 @@ x_make_monitor_attribute_list (struct MonitorInfo *monitors,
struct x_display_info *dpyinfo,
const char *source)
{
- Lisp_Object monitor_frames = Fmake_vector (make_number (n_monitors), Qnil);
+ Lisp_Object monitor_frames = make_nil_vector (n_monitors);
Lisp_Object frame, rest;
FOR_EACH_FRAME (rest, frame)
{
struct frame *f = XFRAME (frame);
- if (FRAME_X_P (f) && FRAME_DISPLAY_INFO (f) == dpyinfo
- && !EQ (frame, tip_frame))
+ if (FRAME_X_P (f)
+ && FRAME_DISPLAY_INFO (f) == dpyinfo
+ && !FRAME_TOOLTIP_P (f))
{
int i = x_get_monitor_for_frame (f, monitors, n_monitors);
ASET (monitor_frames, i, Fcons (frame, AREF (monitor_frames, i)));
@@ -4907,19 +4931,16 @@ Internal use only, use `display-monitor-attributes-list' instead. */)
#endif
n_monitors = gdk_screen_get_n_monitors (gscreen);
#endif
- monitor_frames = Fmake_vector (make_number (n_monitors), Qnil);
+ monitor_frames = make_nil_vector (n_monitors);
monitors = xzalloc (n_monitors * sizeof *monitors);
FOR_EACH_FRAME (rest, frame)
{
struct frame *f = XFRAME (frame);
- if (FRAME_X_P (f) && FRAME_DISPLAY_INFO (f) == dpyinfo
- && !(EQ (frame, tip_frame)
-#ifdef USE_GTK
- && !NILP (Fframe_parameter (tip_frame, Qtooltip))
-#endif
- ))
+ if (FRAME_X_P (f)
+ && FRAME_DISPLAY_INFO (f) == dpyinfo
+ && !FRAME_TOOLTIP_P (f))
{
GdkWindow *gwin = gtk_widget_get_window (FRAME_GTK_WIDGET (f));
@@ -5009,7 +5030,7 @@ Internal use only, use `display-monitor-attributes-list' instead. */)
mi->mm_height = height_mm;
#if GTK_CHECK_VERSION (3, 22, 0)
- mi->name = g_strdup (gdk_monitor_get_model (monitor));
+ mi->name = xstrdup (gdk_monitor_get_model (monitor));
#elif GTK_CHECK_VERSION (2, 14, 0)
mi->name = gdk_screen_get_monitor_plug_name (gscreen, i);
#endif
@@ -5020,6 +5041,11 @@ Internal use only, use `display-monitor-attributes-list' instead. */)
primary_monitor,
monitor_frames,
source);
+#if GTK_CHECK_VERSION (2, 14, 0)
+ free_monitors (monitors, n_monitors);
+#else
+ xfree (monitors);
+#endif
unblock_input ();
#else /* not USE_GTK */
@@ -5078,8 +5104,8 @@ frame_geometry (Lisp_Object frame, Lisp_Object attribute)
edges = Fx_frame_edges (parent, Qnative_edges);
if (!NILP (edges))
{
- x_native += XINT (Fnth (make_number (0), edges));
- y_native += XINT (Fnth (make_number (1), edges));
+ x_native += XFIXNUM (Fnth (make_fixnum (0), edges));
+ y_native += XFIXNUM (Fnth (make_fixnum (1), edges));
}
outer_left = x_native;
@@ -5111,7 +5137,7 @@ frame_geometry (Lisp_Object frame, Lisp_Object attribute)
inner_right = native_right - internal_border_width;
inner_bottom = native_bottom - internal_border_width;
-#if defined (USE_X_TOOLKIT) || defined (USE_GTK)
+#ifdef HAVE_EXT_MENU_BAR
menu_bar_external = true;
menu_bar_height = FRAME_MENUBAR_HEIGHT (f);
native_top += menu_bar_height;
@@ -5122,7 +5148,7 @@ frame_geometry (Lisp_Object frame, Lisp_Object attribute)
#endif
menu_bar_width = menu_bar_height ? native_width : 0;
-#if defined (USE_GTK)
+#ifdef HAVE_EXT_TOOL_BAR
tool_bar_external = true;
if (EQ (FRAME_TOOL_BAR_POSITION (f), Qleft))
{
@@ -5164,43 +5190,39 @@ frame_geometry (Lisp_Object frame, Lisp_Object attribute)
/* Construct list. */
if (EQ (attribute, Qouter_edges))
- return list4 (make_number (outer_left), make_number (outer_top),
- make_number (outer_right), make_number (outer_bottom));
+ return list4i (outer_left, outer_top, outer_right, outer_bottom);
else if (EQ (attribute, Qnative_edges))
- return list4 (make_number (native_left), make_number (native_top),
- make_number (native_right), make_number (native_bottom));
+ return list4i (native_left, native_top, native_right, native_bottom);
else if (EQ (attribute, Qinner_edges))
- return list4 (make_number (inner_left), make_number (inner_top),
- make_number (inner_right), make_number (inner_bottom));
+ return list4i (inner_left, inner_top, inner_right, inner_bottom);
else
return
- listn (CONSTYPE_HEAP, 11,
- Fcons (Qouter_position,
- Fcons (make_number (outer_left),
- make_number (outer_top))),
+ list (Fcons (Qouter_position,
+ Fcons (make_fixnum (outer_left),
+ make_fixnum (outer_top))),
Fcons (Qouter_size,
- Fcons (make_number (outer_right - outer_left),
- make_number (outer_bottom - outer_top))),
+ Fcons (make_fixnum (outer_right - outer_left),
+ make_fixnum (outer_bottom - outer_top))),
/* Approximate. */
Fcons (Qexternal_border_size,
- Fcons (make_number (right_off),
- make_number (bottom_off))),
- Fcons (Qouter_border_width, make_number (x_border_width)),
+ Fcons (make_fixnum (right_off),
+ make_fixnum (bottom_off))),
+ Fcons (Qouter_border_width, make_fixnum (x_border_width)),
/* Approximate. */
Fcons (Qtitle_bar_size,
- Fcons (make_number (0),
- make_number (top_off - bottom_off))),
+ Fcons (make_fixnum (0),
+ make_fixnum (top_off - bottom_off))),
Fcons (Qmenu_bar_external, menu_bar_external ? Qt : Qnil),
Fcons (Qmenu_bar_size,
- Fcons (make_number (menu_bar_width),
- make_number (menu_bar_height))),
+ Fcons (make_fixnum (menu_bar_width),
+ make_fixnum (menu_bar_height))),
Fcons (Qtool_bar_external, tool_bar_external ? Qt : Qnil),
Fcons (Qtool_bar_position, FRAME_TOOL_BAR_POSITION (f)),
Fcons (Qtool_bar_size,
- Fcons (make_number (tool_bar_width),
- make_number (tool_bar_height))),
+ Fcons (make_fixnum (tool_bar_width),
+ make_fixnum (tool_bar_height))),
Fcons (Qinternal_border_width,
- make_number (internal_border_width)));
+ make_fixnum (internal_border_width)));
}
DEFUN ("x-frame-geometry", Fx_frame_geometry, Sx_frame_geometry, 0, 1, 0,
@@ -5400,16 +5422,10 @@ Some window managers may refuse to restack windows. */)
struct frame *f1 = decode_live_frame (frame1);
struct frame *f2 = decode_live_frame (frame2);
- if (FRAME_OUTER_WINDOW (f1) && FRAME_OUTER_WINDOW (f2))
- {
- x_frame_restack (f1, f2, !NILP (above));
- return Qt;
- }
- else
- {
- error ("Cannot restack frames");
- return Qnil;
- }
+ if (! (FRAME_OUTER_WINDOW (f1) && FRAME_OUTER_WINDOW (f2)))
+ error ("Cannot restack frames");
+ x_frame_restack (f1, f2, !NILP (above));
+ return Qt;
}
@@ -5435,7 +5451,7 @@ selected frame's display. */)
(unsigned int *) &dummy);
unblock_input ();
- return Fcons (make_number (x), make_number (y));
+ return Fcons (make_fixnum (x), make_fixnum (y));
}
DEFUN ("x-set-mouse-absolute-pixel-position", Fx_set_mouse_absolute_pixel_position,
@@ -5455,7 +5471,7 @@ The coordinates X and Y are interpreted in pixels relative to a position
block_input ();
XWarpPointer (FRAME_X_DISPLAY (f), None, DefaultRootWindow (FRAME_X_DISPLAY (f)),
- 0, 0, 0, 0, XINT (x), XINT (y));
+ 0, 0, 0, 0, XFIXNUM (x), XFIXNUM (y));
unblock_input ();
return Qnil;
@@ -5658,8 +5674,8 @@ DEFUN ("x-close-connection", Fx_close_connection,
Sx_close_connection, 1, 1, 0,
doc: /* Close the connection to TERMINAL's X server.
For TERMINAL, specify a terminal object, a frame or a display name (a
-string). If TERMINAL is nil, that stands for the selected frame's
-terminal. */)
+string). If TERMINAL is nil, that stands for the selected frame's terminal.
+\(On MS Windows, this function does not accept terminal objects.) */)
(Lisp_Object terminal)
{
struct x_display_info *dpyinfo = check_x_display_info (terminal);
@@ -5701,7 +5717,7 @@ If TERMINAL is omitted or nil, that stands for the selected frame's display. */
{
struct x_display_info *dpyinfo = check_x_display_info (terminal);
- XSynchronize (dpyinfo->display, !EQ (on, Qnil));
+ XSynchronize (dpyinfo->display, !NILP (on));
return Qnil;
}
@@ -5753,12 +5769,12 @@ FRAME. Default is to change on the edit X window. */)
if (! NILP (format))
{
- CHECK_NUMBER (format);
+ CHECK_FIXNUM (format);
- if (XINT (format) != 8 && XINT (format) != 16
- && XINT (format) != 32)
+ if (XFIXNUM (format) != 8 && XFIXNUM (format) != 16
+ && XFIXNUM (format) != 32)
error ("FORMAT must be one of 8, 16 or 32");
- element_format = XINT (format);
+ element_format = XFIXNUM (format);
}
if (CONSP (value))
@@ -5932,8 +5948,6 @@ FRAME. The number 0 denotes the root window.
If DELETE-P is non-nil, delete the property after retrieving it.
If VECTOR-RET-P is non-nil, don't return a string but a vector of values.
-On MS Windows, this function accepts but ignores those optional arguments.
-
Value is nil if FRAME hasn't a property with name PROP or if PROP has
no value of TYPE (always string in the MS Windows case). */)
(Lisp_Object prop, Lisp_Object frame, Lisp_Object type,
@@ -6053,9 +6067,9 @@ Otherwise, the return value is a vector with the following fields:
XFree (tmp_data);
prop_attr = make_uninit_vector (3);
- ASET (prop_attr, 0, make_number (actual_type));
- ASET (prop_attr, 1, make_number (actual_format));
- ASET (prop_attr, 2, make_number (bytes_remaining / (actual_format >> 3)));
+ ASET (prop_attr, 0, make_fixnum (actual_type));
+ ASET (prop_attr, 1, make_fixnum (actual_format));
+ ASET (prop_attr, 2, make_fixnum (bytes_remaining / (actual_format >> 3)));
}
unblock_input ();
@@ -6067,22 +6081,27 @@ Otherwise, the return value is a vector with the following fields:
***********************************************************************/
static void compute_tip_xy (struct frame *, Lisp_Object, Lisp_Object,
- Lisp_Object, int, int, int *, int *);
+ Lisp_Object, int, int, int *, int *);
-/* The frame of a currently visible tooltip. */
+/* The frame of the currently visible tooltip. */
+static Lisp_Object tip_frame;
-Lisp_Object tip_frame;
+/* The window-system window corresponding to the frame of the
+ currently visible tooltip. */
+Window tip_window;
-/* If non-nil, a timer started that hides the last tooltip when it
+/* A timer that hides or deletes the currently visible tooltip when it
fires. */
-
static Lisp_Object tip_timer;
-Window tip_window;
-/* If non-nil, a vector of 3 elements containing the last args
- with which x-show-tip was called. See there. */
+/* STRING argument of last `x-show-tip' call. */
+static Lisp_Object tip_last_string;
+
+/* Normalized FRAME argument of last `x-show-tip' call. */
+static Lisp_Object tip_last_frame;
-static Lisp_Object last_show_tip_args;
+/* PARMS argument of last `x-show-tip' call. */
+static Lisp_Object tip_last_parms;
static void
@@ -6156,6 +6175,7 @@ x_create_tip_frame (struct x_display_info *dpyinfo, Lisp_Object parms)
f->output_data.x->white_relief.pixel = -1;
f->output_data.x->black_relief.pixel = -1;
+ f->tooltip = true;
fset_icon_name (f, Qnil);
FRAME_DISPLAY_INFO (f) = dpyinfo;
f->output_data.x->parent_desc = FRAME_DISPLAY_INFO (f)->root_window;
@@ -6232,7 +6252,7 @@ x_create_tip_frame (struct x_display_info *dpyinfo, Lisp_Object parms)
needed to determine window geometry. */
x_default_font_parameter (f, parms);
- x_default_parameter (f, parms, Qborder_width, make_number (0),
+ x_default_parameter (f, parms, Qborder_width, make_fixnum (0),
"borderWidth", "BorderWidth", RES_TYPE_NUMBER);
/* This defaults to 2 in order to match xterm. We recognize either
@@ -6249,12 +6269,12 @@ x_create_tip_frame (struct x_display_info *dpyinfo, Lisp_Object parms)
parms);
}
- x_default_parameter (f, parms, Qinternal_border_width, make_number (1),
+ x_default_parameter (f, parms, Qinternal_border_width, make_fixnum (1),
"internalBorderWidth", "internalBorderWidth",
RES_TYPE_NUMBER);
- x_default_parameter (f, parms, Qright_divider_width, make_number (0),
+ x_default_parameter (f, parms, Qright_divider_width, make_fixnum (0),
NULL, NULL, RES_TYPE_NUMBER);
- x_default_parameter (f, parms, Qbottom_divider_width, make_number (0),
+ x_default_parameter (f, parms, Qbottom_divider_width, make_fixnum (0),
NULL, NULL, RES_TYPE_NUMBER);
/* Also do the stuff which must be set before the window exists. */
@@ -6420,7 +6440,9 @@ x_create_tip_frame (struct x_display_info *dpyinfo, Lisp_Object parms)
the display in *ROOT_X, and *ROOT_Y. */
static void
-compute_tip_xy (struct frame *f, Lisp_Object parms, Lisp_Object dx, Lisp_Object dy, int width, int height, int *root_x, int *root_y)
+compute_tip_xy (struct frame *f,
+ Lisp_Object parms, Lisp_Object dx, Lisp_Object dy,
+ int width, int height, int *root_x, int *root_y)
{
Lisp_Object left, top, right, bottom;
int win_x, win_y;
@@ -6436,8 +6458,8 @@ compute_tip_xy (struct frame *f, Lisp_Object parms, Lisp_Object dx, Lisp_Object
/* Move the tooltip window where the mouse pointer is. Resize and
show it. */
- if ((!INTEGERP (left) && !INTEGERP (right))
- || (!INTEGERP (top) && !INTEGERP (bottom)))
+ if ((!FIXNUMP (left) && !FIXNUMP (right))
+ || (!FIXNUMP (top) && !FIXNUMP (bottom)))
{
Lisp_Object frame, attributes, monitor, geometry;
@@ -6457,10 +6479,10 @@ compute_tip_xy (struct frame *f, Lisp_Object parms, Lisp_Object dx, Lisp_Object
geometry = Fassq (Qgeometry, monitor);
if (CONSP (geometry))
{
- min_x = XINT (Fnth (make_number (1), geometry));
- min_y = XINT (Fnth (make_number (2), geometry));
- max_x = min_x + XINT (Fnth (make_number (3), geometry));
- max_y = min_y + XINT (Fnth (make_number (4), geometry));
+ min_x = XFIXNUM (Fnth (make_fixnum (1), geometry));
+ min_y = XFIXNUM (Fnth (make_fixnum (2), geometry));
+ max_x = min_x + XFIXNUM (Fnth (make_fixnum (3), geometry));
+ max_y = min_y + XFIXNUM (Fnth (make_fixnum (4), geometry));
if (min_x <= *root_x && *root_x < max_x
&& min_y <= *root_y && *root_y < max_y)
{
@@ -6483,41 +6505,53 @@ compute_tip_xy (struct frame *f, Lisp_Object parms, Lisp_Object dx, Lisp_Object
max_y = x_display_pixel_height (FRAME_DISPLAY_INFO (f));
}
- if (INTEGERP (top))
- *root_y = XINT (top);
- else if (INTEGERP (bottom))
- *root_y = XINT (bottom) - height;
- else if (*root_y + XINT (dy) <= min_y)
+ if (FIXNUMP (top))
+ *root_y = XFIXNUM (top);
+ else if (FIXNUMP (bottom))
+ *root_y = XFIXNUM (bottom) - height;
+ else if (*root_y + XFIXNUM (dy) <= min_y)
*root_y = min_y; /* Can happen for negative dy */
- else if (*root_y + XINT (dy) + height <= max_y)
+ else if (*root_y + XFIXNUM (dy) + height <= max_y)
/* It fits below the pointer */
- *root_y += XINT (dy);
- else if (height + XINT (dy) + min_y <= *root_y)
+ *root_y += XFIXNUM (dy);
+ else if (height + XFIXNUM (dy) + min_y <= *root_y)
/* It fits above the pointer. */
- *root_y -= height + XINT (dy);
+ *root_y -= height + XFIXNUM (dy);
else
/* Put it on the top. */
*root_y = min_y;
- if (INTEGERP (left))
- *root_x = XINT (left);
- else if (INTEGERP (right))
- *root_x = XINT (right) - width;
- else if (*root_x + XINT (dx) <= min_x)
+ if (FIXNUMP (left))
+ *root_x = XFIXNUM (left);
+ else if (FIXNUMP (right))
+ *root_x = XFIXNUM (right) - width;
+ else if (*root_x + XFIXNUM (dx) <= min_x)
*root_x = 0; /* Can happen for negative dx */
- else if (*root_x + XINT (dx) + width <= max_x)
+ else if (*root_x + XFIXNUM (dx) + width <= max_x)
/* It fits to the right of the pointer. */
- *root_x += XINT (dx);
- else if (width + XINT (dx) + min_x <= *root_x)
+ *root_x += XFIXNUM (dx);
+ else if (width + XFIXNUM (dx) + min_x <= *root_x)
/* It fits to the left of the pointer. */
- *root_x -= width + XINT (dx);
+ *root_x -= width + XFIXNUM (dx);
else
/* Put it left justified on the screen -- it ought to fit that way. */
*root_x = min_x;
}
-/* Hide tooltip. Delete its frame if DELETE is true. */
+/**
+ * x_hide_tip:
+ *
+ * Hide currently visible tooltip and cancel its timer.
+ *
+ * If GTK+ system tooltips are used, this will try to hide the tooltip
+ * referenced by the x_output structure of tooltip_last_frame. For
+ * Emacs tooltips this will try to make tooltip_frame invisible (if
+ * DELETE is false) or delete tooltip_frame (if DELETE is true).
+ *
+ * Return Qt if the tooltip was either deleted or made invisible, Qnil
+ * otherwise.
+ */
static Lisp_Object
x_hide_tip (bool delete)
{
@@ -6527,10 +6561,21 @@ x_hide_tip (bool delete)
tip_timer = Qnil;
}
-
- if (NILP (tip_frame)
- || (!delete && FRAMEP (tip_frame)
+#ifdef USE_GTK
+ /* Any GTK+ system tooltip can be found via the x_output structure of
+ tip_last_frame, provided that frame is still live. Any Emacs
+ tooltip is found via the tip_frame variable. Note that the current
+ value of x_gtk_use_system_tooltips might not be the same as used
+ for the tooltip we have to hide, see Bug#30399. */
+ if ((NILP (tip_last_frame) && NILP (tip_frame))
+ || (!x_gtk_use_system_tooltips
+ && !delete
+ && FRAMEP (tip_frame)
+ && FRAME_LIVE_P (XFRAME (tip_frame))
&& !FRAME_VISIBLE_P (XFRAME (tip_frame))))
+ /* Either there's no tooltip to hide or it's an already invisible
+ Emacs tooltip and we don't want to change its type. Return
+ quickly. */
return Qnil;
else
{
@@ -6541,61 +6586,117 @@ x_hide_tip (bool delete)
specbind (Qinhibit_redisplay, Qt);
specbind (Qinhibit_quit, Qt);
-#ifdef USE_GTK
- {
- /* When using system tooltip, tip_frame is the Emacs frame on
- which the tip is shown. */
- struct frame *f = XFRAME (tip_frame);
+ /* Try to hide the GTK+ system tip first. */
+ if (FRAMEP (tip_last_frame))
+ {
+ struct frame *f = XFRAME (tip_last_frame);
- if (FRAME_LIVE_P (f) && xg_hide_tooltip (f))
- {
- tip_frame = Qnil;
- was_open = Qt;
- }
- }
-#endif
+ if (FRAME_LIVE_P (f))
+ {
+ if (xg_hide_tooltip (f))
+ was_open = Qt;
+ }
+ }
+ /* Reset tip_last_frame, it will be reassigned when showing the
+ next GTK+ system tooltip. */
+ tip_last_frame = Qnil;
+
+ /* Now look whether there's an Emacs tip around. */
if (FRAMEP (tip_frame))
{
- if (delete)
+ struct frame *f = XFRAME (tip_frame);
+
+ if (FRAME_LIVE_P (f))
{
- delete_frame (tip_frame, Qnil);
- tip_frame = Qnil;
+ if (delete || x_gtk_use_system_tooltips)
+ {
+ /* Delete the Emacs tooltip frame when DELETE is true
+ or we change the tooltip type from an Emacs one to
+ a GTK+ system one. */
+ delete_frame (tip_frame, Qnil);
+ tip_frame = Qnil;
+ }
+ else
+ x_make_frame_invisible (f);
+
+ was_open = Qt;
}
else
- x_make_frame_invisible (XFRAME (tip_frame));
+ tip_frame = Qnil;
+ }
+ else
+ tip_frame = Qnil;
- was_open = Qt;
+ return unbind_to (count, was_open);
+ }
+#else /* not USE_GTK */
+ if (NILP (tip_frame)
+ || (!delete
+ && FRAMEP (tip_frame)
+ && FRAME_LIVE_P (XFRAME (tip_frame))
+ && !FRAME_VISIBLE_P (XFRAME (tip_frame))))
+ return Qnil;
+ else
+ {
+ ptrdiff_t count;
+ Lisp_Object was_open = Qnil;
+
+ count = SPECPDL_INDEX ();
+ specbind (Qinhibit_redisplay, Qt);
+ specbind (Qinhibit_quit, Qt);
+
+ if (FRAMEP (tip_frame))
+ {
+ struct frame *f = XFRAME (tip_frame);
+
+ if (FRAME_LIVE_P (f))
+ {
+ if (delete)
+ {
+ delete_frame (tip_frame, Qnil);
+ tip_frame = Qnil;
+ }
+ else
+ x_make_frame_invisible (XFRAME (tip_frame));
#ifdef USE_LUCID
- /* Bloodcurdling hack alert: The Lucid menu bar widget's
- redisplay procedure is not called when a tip frame over
- menu items is unmapped. Redisplay the menu manually... */
- {
- Widget w;
- struct frame *f = SELECTED_FRAME ();
- if (FRAME_X_P (f) && FRAME_LIVE_P (f))
+ /* Bloodcurdling hack alert: The Lucid menu bar widget's
+ redisplay procedure is not called when a tip frame over
+ menu items is unmapped. Redisplay the menu manually... */
{
- w = f->output_data.x->menubar_widget;
+ Widget w;
+ struct frame *f = SELECTED_FRAME ();
- if (!DoesSaveUnders (FRAME_DISPLAY_INFO (f)->screen)
- && w != NULL)
+ if (FRAME_X_P (f) && FRAME_LIVE_P (f))
{
- block_input ();
- xlwmenu_redisplay (w);
- unblock_input ();
+ w = f->output_data.x->menubar_widget;
+
+ if (!DoesSaveUnders (FRAME_DISPLAY_INFO (f)->screen)
+ && w != NULL)
+ {
+ block_input ();
+ xlwmenu_redisplay (w);
+ unblock_input ();
+ }
}
}
- }
#endif /* USE_LUCID */
+
+ was_open = Qt;
+ }
+ else
+ tip_frame = Qnil;
}
else
tip_frame = Qnil;
return unbind_to (count, was_open);
}
+#endif /* USE_GTK */
}
+
DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0,
doc: /* Show STRING in a "tooltip" window on frame FRAME.
A tooltip window is a small X window displaying a string.
@@ -6626,7 +6727,8 @@ with offset DY added (default is -10).
A tooltip's maximum size is specified by `x-max-tooltip-size'.
Text larger than the specified size is clipped. */)
- (Lisp_Object string, Lisp_Object frame, Lisp_Object parms, Lisp_Object timeout, Lisp_Object dx, Lisp_Object dy)
+ (Lisp_Object string, Lisp_Object frame, Lisp_Object parms,
+ Lisp_Object timeout, Lisp_Object dx, Lisp_Object dy)
{
struct frame *f, *tip_f;
struct window *w;
@@ -6637,8 +6739,7 @@ Text larger than the specified size is clipped. */)
int old_windows_or_buffers_changed = windows_or_buffers_changed;
ptrdiff_t count = SPECPDL_INDEX ();
ptrdiff_t count_1;
- Lisp_Object window, size;
- Lisp_Object tip_buf;
+ Lisp_Object window, size, tip_buf;
AUTO_STRING (tip, " *tip*");
specbind (Qinhibit_redisplay, Qt);
@@ -6647,21 +6748,24 @@ Text larger than the specified size is clipped. */)
if (SCHARS (string) == 0)
string = make_unibyte_string (" ", 1);
+ if (NILP (frame))
+ frame = selected_frame;
f = decode_window_system_frame (frame);
+
if (NILP (timeout))
- timeout = make_number (5);
+ timeout = make_fixnum (5);
else
- CHECK_NATNUM (timeout);
+ CHECK_FIXNAT (timeout);
if (NILP (dx))
- dx = make_number (5);
+ dx = make_fixnum (5);
else
- CHECK_NUMBER (dx);
+ CHECK_FIXNUM (dx);
if (NILP (dy))
- dy = make_number (-10);
+ dy = make_fixnum (-10);
else
- CHECK_NUMBER (dy);
+ CHECK_FIXNUM (dy);
#ifdef USE_GTK
if (x_gtk_use_system_tooltips)
@@ -6677,36 +6781,27 @@ Text larger than the specified size is clipped. */)
{
compute_tip_xy (f, parms, dx, dy, width, height, &root_x, &root_y);
xg_show_tooltip (f, root_x, root_y);
- /* This is used in Fx_hide_tip. */
- XSETFRAME (tip_frame, f);
+ tip_last_frame = frame;
}
+
unblock_input ();
if (ok) goto start_timer;
}
#endif /* USE_GTK */
- if (NILP (last_show_tip_args))
- last_show_tip_args = Fmake_vector (make_number (3), Qnil);
-
if (FRAMEP (tip_frame) && FRAME_LIVE_P (XFRAME (tip_frame)))
{
- Lisp_Object last_string = AREF (last_show_tip_args, 0);
- Lisp_Object last_frame = AREF (last_show_tip_args, 1);
- Lisp_Object last_parms = AREF (last_show_tip_args, 2);
-
if (FRAME_VISIBLE_P (XFRAME (tip_frame))
- && EQ (frame, last_frame)
- && !NILP (Fequal_including_properties (last_string, string))
- && !NILP (Fequal (last_parms, parms)))
+ && EQ (frame, tip_last_frame)
+ && !NILP (Fequal_including_properties (tip_last_string, string))
+ && !NILP (Fequal (tip_last_parms, parms)))
{
/* Only DX and DY have changed. */
tip_f = XFRAME (tip_frame);
if (!NILP (tip_timer))
{
- Lisp_Object timer = tip_timer;
-
+ call1 (Qcancel_timer, tip_timer);
tip_timer = Qnil;
- call1 (Qcancel_timer, timer);
}
block_input ();
@@ -6718,15 +6813,14 @@ Text larger than the specified size is clipped. */)
goto start_timer;
}
- else if (tooltip_reuse_hidden_frame && EQ (frame, last_frame))
+ else if (tooltip_reuse_hidden_frame && EQ (frame, tip_last_frame))
{
bool delete = false;
Lisp_Object tail, elt, parm, last;
/* Check if every parameter in PARMS has the same value in
- last_parms unless it should be ignored by means of
- Vtooltip_reuse_hidden_frame_parameters. This may destruct
- last_parms which, however, will be recreated below. */
+ tip_last_parms. This may destruct tip_last_parms which,
+ however, will be recreated below. */
for (tail = parms; CONSP (tail); tail = XCDR (tail))
{
elt = XCAR (tail);
@@ -6736,7 +6830,7 @@ Text larger than the specified size is clipped. */)
if (!EQ (parm, Qleft) && !EQ (parm, Qtop)
&& !EQ (parm, Qright) && !EQ (parm, Qbottom))
{
- last = Fassq (parm, last_parms);
+ last = Fassq (parm, tip_last_parms);
if (NILP (Fequal (Fcdr (elt), Fcdr (last))))
{
/* We lost, delete the old tooltip. */
@@ -6744,17 +6838,18 @@ Text larger than the specified size is clipped. */)
break;
}
else
- last_parms = call2 (Qassq_delete_all, parm, last_parms);
+ tip_last_parms =
+ call2 (Qassq_delete_all, parm, tip_last_parms);
}
else
- last_parms = call2 (Qassq_delete_all, parm, last_parms);
+ tip_last_parms =
+ call2 (Qassq_delete_all, parm, tip_last_parms);
}
- /* Now check if every parameter in what is left of last_parms
- with a non-nil value has an association in PARMS unless it
- should be ignored by means of
- Vtooltip_reuse_hidden_frame_parameters. */
- for (tail = last_parms; CONSP (tail); tail = XCDR (tail))
+ /* Now check if every parameter in what is left of
+ tip_last_parms with a non-nil value has an association in
+ PARMS. */
+ for (tail = tip_last_parms; CONSP (tail); tail = XCDR (tail))
{
elt = XCAR (tail);
parm = Fcar (elt);
@@ -6775,9 +6870,9 @@ Text larger than the specified size is clipped. */)
else
x_hide_tip (true);
- ASET (last_show_tip_args, 0, string);
- ASET (last_show_tip_args, 1, frame);
- ASET (last_show_tip_args, 2, parms);
+ tip_last_frame = frame;
+ tip_last_string = string;
+ tip_last_parms = parms;
if (!FRAMEP (tip_frame) || !FRAME_LIVE_P (XFRAME (tip_frame)))
{
@@ -6785,9 +6880,9 @@ Text larger than the specified size is clipped. */)
if (NILP (Fassq (Qname, parms)))
parms = Fcons (Fcons (Qname, build_string ("tooltip")), parms);
if (NILP (Fassq (Qinternal_border_width, parms)))
- parms = Fcons (Fcons (Qinternal_border_width, make_number (3)), parms);
+ parms = Fcons (Fcons (Qinternal_border_width, make_fixnum (3)), parms);
if (NILP (Fassq (Qborder_width, parms)))
- parms = Fcons (Fcons (Qborder_width, make_number (1)), parms);
+ parms = Fcons (Fcons (Qborder_width, make_fixnum (1)), parms);
if (NILP (Fassq (Qborder_color, parms)))
parms = Fcons (Fcons (Qborder_color, build_string ("lightyellow")), parms);
if (NILP (Fassq (Qbackground_color, parms)))
@@ -6806,8 +6901,8 @@ Text larger than the specified size is clipped. */)
tip_buf = Fget_buffer_create (tip);
/* We will mark the tip window a "pseudo-window" below, and such
windows cannot have display margins. */
- bset_left_margin_cols (XBUFFER (tip_buf), make_number (0));
- bset_right_margin_cols (XBUFFER (tip_buf), make_number (0));
+ bset_left_margin_cols (XBUFFER (tip_buf), make_fixnum (0));
+ bset_right_margin_cols (XBUFFER (tip_buf), make_fixnum (0));
set_window_buffer (window, tip_buf, false, false);
w = XWINDOW (window);
w->pseudo_window_p = true;
@@ -6822,11 +6917,11 @@ Text larger than the specified size is clipped. */)
w->pixel_top = 0;
if (CONSP (Vx_max_tooltip_size)
- && RANGED_INTEGERP (1, XCAR (Vx_max_tooltip_size), INT_MAX)
- && RANGED_INTEGERP (1, XCDR (Vx_max_tooltip_size), INT_MAX))
+ && RANGED_FIXNUMP (1, XCAR (Vx_max_tooltip_size), INT_MAX)
+ && RANGED_FIXNUMP (1, XCDR (Vx_max_tooltip_size), INT_MAX))
{
- w->total_cols = XFASTINT (XCAR (Vx_max_tooltip_size));
- w->total_lines = XFASTINT (XCDR (Vx_max_tooltip_size));
+ w->total_cols = XFIXNAT (XCAR (Vx_max_tooltip_size));
+ w->total_lines = XFIXNAT (XCDR (Vx_max_tooltip_size));
}
else
{
@@ -6856,10 +6951,10 @@ Text larger than the specified size is clipped. */)
try_window (window, pos, TRY_WINDOW_IGNORE_FONTS_CHANGE);
/* Calculate size of tooltip window. */
size = Fwindow_text_pixel_size (window, Qnil, Qnil, Qnil,
- make_number (w->pixel_height), Qnil);
+ make_fixnum (w->pixel_height), Qnil);
/* Add the frame's internal border to calculated size. */
- width = XINT (Fcar (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f);
- height = XINT (Fcdr (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f);
+ width = XFIXNUM (Fcar (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f);
+ height = XFIXNUM (Fcdr (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f);
/* Calculate position of tooltip frame. */
compute_tip_xy (tip_f, parms, dx, dy, width, height, &root_x, &root_y);
@@ -6964,18 +7059,7 @@ clean_up_file_dialog (void *arg)
DEFUN ("x-file-dialog", Fx_file_dialog, Sx_file_dialog, 2, 5, 0,
- doc: /* Read file name, prompting with PROMPT in directory DIR.
-Use a file selection dialog. Select DEFAULT-FILENAME in the dialog's file
-selection box, if specified. If MUSTMATCH is non-nil, the returned file
-or directory must exist.
-
-This function is only defined on NS, MS Windows, and X Windows with the
-Motif or Gtk toolkits. With the Motif toolkit, ONLY-DIR-P is ignored.
-Otherwise, if ONLY-DIR-P is non-nil, the user can only select directories.
-On Windows 7 and later, the file selection dialog "remembers" the last
-directory where the user selected a file, and will open that directory
-instead of DIR on subsequent invocations of this function with the same
-value of DIR as in previous invocations; this is standard Windows behavior. */)
+ doc: /* SKIP: real doc in USE_GTK definition in xfns.c. */)
(Lisp_Object prompt, Lisp_Object dir, Lisp_Object default_filename,
Lisp_Object mustmatch, Lisp_Object only_dir_p)
{
@@ -7144,10 +7228,10 @@ or directory must exist.
This function is only defined on NS, MS Windows, and X Windows with the
Motif or Gtk toolkits. With the Motif toolkit, ONLY-DIR-P is ignored.
Otherwise, if ONLY-DIR-P is non-nil, the user can only select directories.
-On Windows 7 and later, the file selection dialog "remembers" the last
+On MS Windows 7 and later, the file selection dialog "remembers" the last
directory where the user selected a file, and will open that directory
instead of DIR on subsequent invocations of this function with the same
-value of DIR as in previous invocations; this is standard Windows behavior. */)
+value of DIR as in previous invocations; this is standard MS Windows behavior. */)
(Lisp_Object prompt, Lisp_Object dir, Lisp_Object default_filename, Lisp_Object mustmatch, Lisp_Object only_dir_p)
{
struct frame *f = SELECTED_FRAME ();
@@ -7592,7 +7676,7 @@ syms_of_xfns (void)
#endif
Fput (Qundefined_color, Qerror_conditions,
- listn (CONSTYPE_PURE, 2, Qundefined_color, Qerror));
+ pure_list (Qundefined_color, Qerror));
Fput (Qundefined_color, Qerror_message,
build_pure_c_string ("Undefined color"));
@@ -7708,7 +7792,7 @@ or when you set the mouse color. */);
DEFVAR_LISP ("x-max-tooltip-size", Vx_max_tooltip_size,
doc: /* Maximum size for tooltips.
Value is a pair (COLUMNS . ROWS). Text larger than this is clipped. */);
- Vx_max_tooltip_size = Fcons (make_number (80), make_number (40));
+ Vx_max_tooltip_size = Fcons (make_fixnum (80), make_fixnum (40));
DEFVAR_LISP ("x-no-window-manager", Vx_no_window_manager,
doc: /* Non-nil if no X window manager is in use.
@@ -7722,9 +7806,9 @@ unless you set it to something else. */);
Vx_pixel_size_width_font_regexp,
doc: /* Regexp matching a font name whose width is the same as `PIXEL_SIZE'.
-Since Emacs gets width of a font matching with this regexp from
-PIXEL_SIZE field of the name, font finding mechanism gets faster for
-such a font. This is especially effective for such large fonts as
+Since Emacs gets the width of a font matching this regexp from the
+PIXEL_SIZE field of the name, the font-finding mechanism gets faster for
+such a font. This is especially effective for large fonts such as
Chinese, Japanese, and Korean. */);
Vx_pixel_size_width_font_regexp = Qnil;
@@ -7838,7 +7922,6 @@ When using Gtk+ tooltips, the tooltip face is not used. */);
defsubr (&Sx_display_list);
defsubr (&Sx_synchronize);
defsubr (&Sx_backspace_delete_keys_p);
-
defsubr (&Sx_show_tip);
defsubr (&Sx_hide_tip);
defsubr (&Sx_double_buffered_p);
@@ -7846,9 +7929,12 @@ When using Gtk+ tooltips, the tooltip face is not used. */);
staticpro (&tip_timer);
tip_frame = Qnil;
staticpro (&tip_frame);
-
- last_show_tip_args = Qnil;
- staticpro (&last_show_tip_args);
+ tip_last_frame = Qnil;
+ staticpro (&tip_last_frame);
+ tip_last_string = Qnil;
+ staticpro (&tip_last_string);
+ tip_last_parms = Qnil;
+ staticpro (&tip_last_parms);
defsubr (&Sx_uses_old_gtk_dialog);
#if defined (USE_MOTIF) || defined (USE_GTK)
diff --git a/src/xfont.c b/src/xfont.c
index b61c374fdc3..5ecbd6de33b 100644
--- a/src/xfont.c
+++ b/src/xfont.c
@@ -31,6 +31,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "character.h"
#include "charset.h"
#include "font.h"
+#include "pdumper.h"
/* X core font driver. */
@@ -131,7 +132,7 @@ compare_font_names (const void *name1, const void *name2)
/* Decode XLFD as iso-8859-1 into OUTPUT, and return the byte length
of the decoding result. LEN is the byte length of XLFD, or -1 if
- XLFD is NULL terminated. The caller must assure that OUTPUT is at
+ XLFD is NUL terminated. The caller must assure that OUTPUT is at
least twice (plus 1) as large as XLFD. */
static ptrdiff_t
@@ -190,7 +191,7 @@ xfont_chars_supported (Lisp_Object chars, XFontStruct *xfont,
{
for (; CONSP (chars); chars = XCDR (chars))
{
- int c = XINT (XCAR (chars));
+ int c = XFIXNUM (XCAR (chars));
unsigned code = ENCODE_CHAR (charset, c);
XChar2b char2b;
@@ -213,7 +214,7 @@ xfont_chars_supported (Lisp_Object chars, XFontStruct *xfont,
for (i = ASIZE (chars) - 1; i >= 0; i--)
{
- int c = XINT (AREF (chars, i));
+ int c = XFIXNUM (AREF (chars, i));
unsigned code = ENCODE_CHAR (charset, c);
XChar2b char2b;
@@ -376,18 +377,18 @@ xfont_list_pattern (Display *display, const char *pattern,
continue;
ASET (entity, FONT_TYPE_INDEX, Qx);
/* Avoid auto-scaled fonts. */
- if (INTEGERP (AREF (entity, FONT_DPI_INDEX))
- && INTEGERP (AREF (entity, FONT_AVGWIDTH_INDEX))
- && XINT (AREF (entity, FONT_DPI_INDEX)) != 0
- && XINT (AREF (entity, FONT_AVGWIDTH_INDEX)) == 0)
+ if (FIXNUMP (AREF (entity, FONT_DPI_INDEX))
+ && FIXNUMP (AREF (entity, FONT_AVGWIDTH_INDEX))
+ && XFIXNUM (AREF (entity, FONT_DPI_INDEX)) != 0
+ && XFIXNUM (AREF (entity, FONT_AVGWIDTH_INDEX)) == 0)
continue;
/* Avoid not-allowed scalable fonts. */
if (NILP (Vscalable_fonts_allowed))
{
int size = 0;
- if (INTEGERP (AREF (entity, FONT_SIZE_INDEX)))
- size = XINT (AREF (entity, FONT_SIZE_INDEX));
+ if (FIXNUMP (AREF (entity, FONT_SIZE_INDEX)))
+ size = XFIXNUM (AREF (entity, FONT_SIZE_INDEX));
else if (FLOATP (AREF (entity, FONT_SIZE_INDEX)))
size = XFLOAT_DATA (AREF (entity, FONT_SIZE_INDEX));
if (size == 0 && i_pass == 0)
@@ -672,8 +673,8 @@ xfont_open (struct frame *f, Lisp_Object entity, int pixel_size)
return Qnil;
}
- if (XINT (AREF (entity, FONT_SIZE_INDEX)) != 0)
- pixel_size = XINT (AREF (entity, FONT_SIZE_INDEX));
+ if (XFIXNUM (AREF (entity, FONT_SIZE_INDEX)) != 0)
+ pixel_size = XFIXNUM (AREF (entity, FONT_SIZE_INDEX));
else if (pixel_size == 0)
{
if (FRAME_FONT (f))
@@ -811,8 +812,8 @@ xfont_open (struct frame *f, Lisp_Object entity, int pixel_size)
font->space_width = 0;
val = Ffont_get (font_object, QCavgwidth);
- if (INTEGERP (val))
- font->average_width = XINT (val) / 10;
+ if (FIXNUMP (val))
+ font->average_width = XFIXNUM (val) / 10;
if (font->average_width < 0)
font->average_width = - font->average_width;
else
@@ -1077,6 +1078,7 @@ xfont_check (struct frame *f, struct font *font)
}
+static void syms_of_xfont_for_pdumper (void);
struct font_driver const xfont_driver =
{
@@ -1101,6 +1103,12 @@ syms_of_xfont (void)
staticpro (&xfont_scripts_cache);
xfont_scripts_cache = CALLN (Fmake_hash_table, QCtest, Qequal);
staticpro (&xfont_scratch_props);
- xfont_scratch_props = Fmake_vector (make_number (8), Qnil);
+ xfont_scratch_props = make_nil_vector (8);
+ pdumper_do_now_and_after_load (syms_of_xfont_for_pdumper);
+}
+
+static void
+syms_of_xfont_for_pdumper (void)
+{
register_font_driver (&xfont_driver, NULL);
}
diff --git a/src/xftfont.c b/src/xftfont.c
index 805ea0ede9c..8a4516f7f91 100644
--- a/src/xftfont.c
+++ b/src/xftfont.c
@@ -32,32 +32,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "composite.h"
#include "font.h"
#include "ftfont.h"
+#include "pdumper.h"
/* Xft font driver. */
-
-/* The actual structure for Xft font that can be cast to struct
- font. */
-
-struct xftfont_info
-{
- struct font font;
- /* The following members up to and including 'matrix' must be here
- in this order to be compatible with struct ftfont_info (in
- ftfont.c). */
-#ifdef HAVE_LIBOTF
- bool maybe_otf; /* Flag to tell if this may be OTF or not. */
- OTF *otf;
-#endif /* HAVE_LIBOTF */
- FT_Size ft_size;
- int index;
- FT_Matrix matrix;
-
- Display *display;
- XftFont *xftfont;
- unsigned x_display_id;
-};
-
/* Structure pointed by (struct face *)->extra */
struct xftface_info
@@ -221,24 +199,24 @@ xftfont_add_rendering_parameters (FcPattern *pat, Lisp_Object entity)
FcPatternAddBool (pat, FC_AUTOHINT, NILP (val) ? FcFalse : FcTrue);
else if (EQ (key, QChintstyle))
{
- if (INTEGERP (val))
- FcPatternAddInteger (pat, FC_HINT_STYLE, XINT (val));
+ if (FIXNUMP (val))
+ FcPatternAddInteger (pat, FC_HINT_STYLE, XFIXNUM (val));
else if (SYMBOLP (val)
&& FcNameConstant (SDATA (SYMBOL_NAME (val)), &ival))
FcPatternAddInteger (pat, FC_HINT_STYLE, ival);
}
else if (EQ (key, QCrgba))
{
- if (INTEGERP (val))
- FcPatternAddInteger (pat, FC_RGBA, XINT (val));
+ if (FIXNUMP (val))
+ FcPatternAddInteger (pat, FC_RGBA, XFIXNUM (val));
else if (SYMBOLP (val)
&& FcNameConstant (SDATA (SYMBOL_NAME (val)), &ival))
FcPatternAddInteger (pat, FC_RGBA, ival);
}
else if (EQ (key, QClcdfilter))
{
- if (INTEGERP (val))
- FcPatternAddInteger (pat, FC_LCD_FILTER, ival = XINT (val));
+ if (FIXNUMP (val))
+ FcPatternAddInteger (pat, FC_LCD_FILTER, ival = XFIXNUM (val));
else if (SYMBOLP (val)
&& FcNameConstant (SDATA (SYMBOL_NAME (val)), &ival))
FcPatternAddInteger (pat, FC_LCD_FILTER, ival);
@@ -257,7 +235,7 @@ xftfont_open (struct frame *f, Lisp_Object entity, int pixel_size)
Display *display = FRAME_X_DISPLAY (f);
Lisp_Object val, filename, idx, font_object;
FcPattern *pat = NULL, *match;
- struct xftfont_info *xftfont_info = NULL;
+ struct font_info *xftfont_info = NULL;
struct font *font;
double size = 0;
XftFont *xftfont = NULL;
@@ -273,7 +251,7 @@ xftfont_open (struct frame *f, Lisp_Object entity, int pixel_size)
val = XCDR (val);
filename = XCAR (val);
idx = XCDR (val);
- size = XINT (AREF (entity, FONT_SIZE_INDEX));
+ size = XFIXNUM (AREF (entity, FONT_SIZE_INDEX));
if (size == 0)
size = pixel_size;
pat = FcPatternCreate ();
@@ -291,16 +269,16 @@ xftfont_open (struct frame *f, Lisp_Object entity, int pixel_size)
FcPatternAddString (pat, FC_FOUNDRY, (FcChar8 *) SDATA (SYMBOL_NAME (val)));
val = AREF (entity, FONT_SPACING_INDEX);
if (! NILP (val))
- FcPatternAddInteger (pat, FC_SPACING, XINT (val));
+ FcPatternAddInteger (pat, FC_SPACING, XFIXNUM (val));
val = AREF (entity, FONT_DPI_INDEX);
if (! NILP (val))
{
- double dbl = XINT (val);
+ double dbl = XFIXNUM (val);
FcPatternAddDouble (pat, FC_DPI, dbl);
}
val = AREF (entity, FONT_AVGWIDTH_INDEX);
- if (INTEGERP (val) && XINT (val) == 0)
+ if (FIXNUMP (val) && XFIXNUM (val) == 0)
FcPatternAddBool (pat, FC_SCALABLE, FcTrue);
/* This is necessary to identify the exact font (e.g. 10x20.pcf.gz
over 10x20-ISO8859-1.pcf.gz). */
@@ -309,7 +287,7 @@ xftfont_open (struct frame *f, Lisp_Object entity, int pixel_size)
xftfont_add_rendering_parameters (pat, entity);
FcPatternAddString (pat, FC_FILE, (FcChar8 *) SDATA (filename));
- FcPatternAddInteger (pat, FC_INDEX, XINT (idx));
+ FcPatternAddInteger (pat, FC_INDEX, XFIXNUM (idx));
block_input ();
@@ -332,7 +310,7 @@ xftfont_open (struct frame *f, Lisp_Object entity, int pixel_size)
/* We should not destroy PAT here because it is kept in XFTFONT and
destroyed automatically when XFTFONT is closed. */
- font_object = font_build_object (VECSIZE (struct xftfont_info),
+ font_object = font_build_object (VECSIZE (struct font_info),
Qxft, entity, size);
ASET (font_object, FONT_FILE_INDEX, filename);
font = XFONT_OBJECT (font_object);
@@ -340,7 +318,7 @@ xftfont_open (struct frame *f, Lisp_Object entity, int pixel_size)
font->driver = &xftfont_driver;
font->encoding_charset = font->repertory_charset = -1;
- xftfont_info = (struct xftfont_info *) font;
+ xftfont_info = (struct font_info *) font;
xftfont_info->display = display;
xftfont_info->xftfont = xftfont;
xftfont_info->x_display_id = FRAME_DISPLAY_INFO (f)->x_id;
@@ -354,8 +332,8 @@ xftfont_open (struct frame *f, Lisp_Object entity, int pixel_size)
xftfont_info->matrix.xy = 0x10000L * matrix->xy;
xftfont_info->matrix.yx = 0x10000L * matrix->yx;
}
- if (INTEGERP (AREF (entity, FONT_SPACING_INDEX)))
- spacing = XINT (AREF (entity, FONT_SPACING_INDEX));
+ if (FIXNUMP (AREF (entity, FONT_SPACING_INDEX)))
+ spacing = XFIXNUM (AREF (entity, FONT_SPACING_INDEX));
else
spacing = FC_PROPORTIONAL;
if (! ascii_printable[0])
@@ -414,7 +392,7 @@ xftfont_open (struct frame *f, Lisp_Object entity, int pixel_size)
}
font->height = font->ascent + font->descent;
- if (XINT (AREF (entity, FONT_SIZE_INDEX)) == 0)
+ if (XFIXNUM (AREF (entity, FONT_SIZE_INDEX)) == 0)
{
int upEM = ft_face->units_per_EM;
@@ -462,7 +440,7 @@ static void
xftfont_close (struct font *font)
{
struct x_display_info *xdi;
- struct xftfont_info *xftfont_info = (struct xftfont_info *) font;
+ struct font_info *xftfont_info = (struct font_info *) font;
#ifdef HAVE_LIBOTF
if (xftfont_info->otf)
@@ -528,7 +506,7 @@ xftfont_done_face (struct frame *f, struct face *face)
static int
xftfont_has_char (Lisp_Object font, int c)
{
- struct xftfont_info *xftfont_info;
+ struct font_info *xftfont_info;
struct charset *cs = NULL;
if (EQ (AREF (font, FONT_ADSTYLE_INDEX), Qja)
@@ -542,7 +520,7 @@ xftfont_has_char (Lisp_Object font, int c)
if (FONT_ENTITY_P (font))
return ftfont_has_char (font, c);
- xftfont_info = (struct xftfont_info *) XFONT_OBJECT (font);
+ xftfont_info = (struct font_info *) XFONT_OBJECT (font);
return (XftCharExists (xftfont_info->display, xftfont_info->xftfont,
(FcChar32) c) == FcTrue);
}
@@ -550,7 +528,7 @@ xftfont_has_char (Lisp_Object font, int c)
static unsigned
xftfont_encode_char (struct font *font, int c)
{
- struct xftfont_info *xftfont_info = (struct xftfont_info *) font;
+ struct font_info *xftfont_info = (struct font_info *) font;
unsigned code = XftCharIndex (xftfont_info->display, xftfont_info->xftfont,
(FcChar32) c);
@@ -561,7 +539,7 @@ static void
xftfont_text_extents (struct font *font, unsigned int *code,
int nglyphs, struct font_metrics *metrics)
{
- struct xftfont_info *xftfont_info = (struct xftfont_info *) font;
+ struct font_info *xftfont_info = (struct font_info *) font;
XGlyphInfo extents;
block_input ();
@@ -603,7 +581,7 @@ xftfont_draw (struct glyph_string *s, int from, int to, int x, int y,
struct frame *f = s->f;
struct face *face = s->face;
- struct xftfont_info *xftfont_info = (struct xftfont_info *) s->font;
+ struct font_info *xftfont_info = (struct font_info *) s->font;
struct xftface_info *xftface_info = NULL;
XftDraw *xft_draw = xftfont_get_xft_draw (f);
FT_UInt *code;
@@ -666,7 +644,7 @@ static Lisp_Object
xftfont_shape (Lisp_Object lgstring)
{
struct font *font = CHECK_FONT_GET_OBJECT (LGSTRING_FONT (lgstring));
- struct xftfont_info *xftfont_info = (struct xftfont_info *) font;
+ struct font_info *xftfont_info = (struct font_info *) font;
FT_Face ft_face = XftLockFace (xftfont_info->xftfont);
xftfont_info->ft_size = ft_face->size;
Lisp_Object val = ftfont_shape (lgstring);
@@ -710,7 +688,7 @@ static bool
xftfont_cached_font_ok (struct frame *f, Lisp_Object font_object,
Lisp_Object entity)
{
- struct xftfont_info *info = (struct xftfont_info *) XFONT_OBJECT (font_object);
+ struct font_info *info = (struct font_info *) XFONT_OBJECT (font_object);
FcPattern *oldpat = info->xftfont->pattern;
Display *display = FRAME_X_DISPLAY (f);
FcPattern *pat = FcPatternCreate ();
@@ -751,6 +729,8 @@ xftfont_cached_font_ok (struct frame *f, Lisp_Object font_object,
return ok;
}
+static void syms_of_xftfont_for_pdumper (void);
+
struct font_driver const xftfont_driver =
{
/* We can't draw a text without device dependent functions. */
@@ -802,7 +782,11 @@ syms_of_xftfont (void)
This is needed with some fonts to correct vertical overlap of glyphs. */);
xft_font_ascent_descent_override = 0;
- ascii_printable[0] = 0;
+ pdumper_do_now_and_after_load (syms_of_xftfont_for_pdumper);
+}
+static void
+syms_of_xftfont_for_pdumper (void)
+{
register_font_driver (&xftfont_driver, NULL);
}
diff --git a/src/xmenu.c b/src/xmenu.c
index 49cd5940eae..22d1cc21aa8 100644
--- a/src/xmenu.c
+++ b/src/xmenu.c
@@ -3,6 +3,10 @@
Copyright (C) 1986, 1988, 1993-1994, 1996, 1999-2019 Free Software
Foundation, Inc.
+Author: Jon Arnold
+ Roman Budzianowski
+ Robert Krawitz
+
This file is part of GNU Emacs.
GNU Emacs is free software: you can redistribute it and/or modify
@@ -20,9 +24,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
/* X pop-up deck-of-cards menu facility for GNU Emacs.
*
- * Written by Jon Arnold and Roman Budzianowski
- * Mods and rewrite by Robert Krawitz
- *
*/
/* Modified by Fred Pierresteguy on December 93
@@ -44,6 +45,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "buffer.h"
#include "coding.h"
#include "sysselect.h"
+#include "pdumper.h"
#ifdef MSDOS
#include "msdos.h"
@@ -142,7 +144,7 @@ x_menu_set_in_use (bool in_use)
{
Lisp_Object frames, frame;
- menu_items_inuse = in_use ? Qt : Qnil;
+ menu_items_inuse = in_use;
popup_activated_flag = in_use;
#ifdef USE_X_TOOLKIT
if (popup_activated_flag)
@@ -278,12 +280,7 @@ popup_get_selection (XEvent *initial_event, struct x_display_info *dpyinfo,
}
DEFUN ("x-menu-bar-open-internal", Fx_menu_bar_open_internal, Sx_menu_bar_open_internal, 0, 1, "i",
- doc: /* Start key navigation of the menu bar in FRAME.
-This initially opens the first menu bar item and you can then navigate with the
-arrow keys, select a menu entry with the return key or cancel with the
-escape key. If FRAME has no menu bar this function does nothing.
-
-If FRAME is nil or not given, use the selected frame. */)
+ doc: /* SKIP: real doc in USE_GTK definition in xmenu.c. */)
(Lisp_Object frame)
{
XEvent ev;
@@ -1177,17 +1174,17 @@ menu_position_func (GtkMenu *menu, gint *x, gint *y, gboolean *push_in, gpointer
items in x-display-monitor-attributes-list. */
workarea = call3 (Qframe_monitor_workarea,
Qnil,
- make_number (data->x),
- make_number (data->y));
+ make_fixnum (data->x),
+ make_fixnum (data->y));
if (CONSP (workarea))
{
int min_x, min_y;
- min_x = XINT (XCAR (workarea));
- min_y = XINT (Fnth (make_number (1), workarea));
- max_x = min_x + XINT (Fnth (make_number (2), workarea));
- max_y = min_y + XINT (Fnth (make_number (3), workarea));
+ min_x = XFIXNUM (XCAR (workarea));
+ min_y = XFIXNUM (Fnth (make_fixnum (1), workarea));
+ max_x = min_x + XFIXNUM (Fnth (make_fixnum (2), workarea));
+ max_y = min_y + XFIXNUM (Fnth (make_fixnum (3), workarea));
}
if (max_x < 0 || max_y < 0)
@@ -1491,7 +1488,7 @@ x_menu_show (struct frame *f, int x, int y, int menuflags,
i = 0;
while (i < menu_items_used)
{
- if (EQ (AREF (menu_items, i), Qnil))
+ if (NILP (AREF (menu_items, i)))
{
submenu_stack[submenu_depth++] = save_wv;
save_wv = prev_wv;
@@ -1660,7 +1657,7 @@ x_menu_show (struct frame *f, int x, int y, int menuflags,
i = 0;
while (i < menu_items_used)
{
- if (EQ (AREF (menu_items, i), Qnil))
+ if (NILP (AREF (menu_items, i)))
{
subprefix_stack[submenu_depth++] = prefix;
prefix = entry;
@@ -2047,16 +2044,23 @@ menu_help_callback (char const *help_string, int pane, int item)
pane_name = first_item[MENU_ITEMS_ITEM_NAME];
/* (menu-item MENU-NAME PANE-NUMBER) */
- menu_object = list3 (Qmenu_item, pane_name, make_number (pane));
+ menu_object = list3 (Qmenu_item, pane_name, make_fixnum (pane));
show_help_echo (help_string ? build_string (help_string) : Qnil,
- Qnil, menu_object, make_number (item));
+ Qnil, menu_object, make_fixnum (item));
}
+struct pop_down_menu
+{
+ struct frame *frame;
+ XMenu *menu;
+};
+
static void
-pop_down_menu (Lisp_Object arg)
+pop_down_menu (void *arg)
{
- struct frame *f = XSAVE_POINTER (arg, 0);
- XMenu *menu = XSAVE_POINTER (arg, 1);
+ struct pop_down_menu *data = arg;
+ struct frame *f = data->frame;
+ XMenu *menu = data->menu;
block_input ();
#ifndef MSDOS
@@ -2302,7 +2306,8 @@ x_menu_show (struct frame *f, int x, int y, int menuflags,
XMenuActivateSetWaitFunction (x_menu_wait_for_event, FRAME_X_DISPLAY (f));
#endif
- record_unwind_protect (pop_down_menu, make_save_ptr_ptr (f, menu));
+ record_unwind_protect_ptr (pop_down_menu,
+ &(struct pop_down_menu) {f, menu});
/* Help display under X won't work because XMenuActivate contains
a loop that doesn't give Emacs a chance to process it. */
@@ -2371,8 +2376,7 @@ x_menu_show (struct frame *f, int x, int y, int menuflags,
return_entry:
unblock_input ();
- SAFE_FREE ();
- return unbind_to (specpdl_count, entry);
+ return SAFE_FREE_UNBIND_TO (specpdl_count, entry);
}
#endif /* not USE_X_TOOLKIT */
@@ -2391,21 +2395,19 @@ popup_activated (void)
/* The following is used by delayed window autoselection. */
DEFUN ("menu-or-popup-active-p", Fmenu_or_popup_active_p, Smenu_or_popup_active_p, 0, 0, 0,
- doc: /* Return t if a menu or popup dialog is active. */)
+ doc: /* Return t if a menu or popup dialog is active.
+\(On MS Windows, this refers to the selected frame.) */)
(void)
{
return (popup_activated ()) ? Qt : Qnil;
}
+
+static void syms_of_xmenu_for_pdumper (void);
+
void
syms_of_xmenu (void)
{
-#ifdef USE_X_TOOLKIT
- enum { WIDGET_ID_TICK_START = 1 << 16 };
- widget_id_tick = WIDGET_ID_TICK_START;
- next_menubar_widget_id = 1;
-#endif
-
DEFSYM (Qdebug_on_next_call, "debug-on-next-call");
defsubr (&Smenu_or_popup_active_p);
@@ -2416,6 +2418,18 @@ syms_of_xmenu (void)
#if defined (USE_GTK) || defined (USE_X_TOOLKIT)
defsubr (&Sx_menu_bar_open_internal);
Ffset (intern_c_string ("accelerate-menu"),
- intern_c_string (Sx_menu_bar_open_internal.symbol_name));
+ intern_c_string (Sx_menu_bar_open_internal.s.symbol_name));
+#endif
+
+ pdumper_do_now_and_after_load (syms_of_xmenu_for_pdumper);
+}
+
+static void
+syms_of_xmenu_for_pdumper (void)
+{
+#ifdef USE_X_TOOLKIT
+ enum { WIDGET_ID_TICK_START = 1 << 16 };
+ widget_id_tick = WIDGET_ID_TICK_START;
+ next_menubar_widget_id = 1;
#endif
}
diff --git a/src/xml.c b/src/xml.c
index 787e883ea55..60bd958952a 100644
--- a/src/xml.c
+++ b/src/xml.c
@@ -18,19 +18,20 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <config.h>
+#include "lisp.h"
+#include "buffer.h"
+
#ifdef HAVE_LIBXML2
#include <libxml/tree.h>
#include <libxml/parser.h>
#include <libxml/HTMLparser.h>
-#include "lisp.h"
-#include "buffer.h"
-
#ifdef WINDOWSNT
# include <windows.h>
+# include "w32common.h"
# include "w32.h"
DEF_DLL_FN (htmlDocPtr, htmlReadMemory,
@@ -187,8 +188,8 @@ parse_region (Lisp_Object start, Lisp_Object end, Lisp_Object base_url,
validate_region (&start, &end);
- istart = XINT (start);
- iend = XINT (end);
+ istart = XFIXNUM (start);
+ iend = XFIXNUM (end);
istart_byte = CHAR_TO_BYTE (istart);
iend_byte = CHAR_TO_BYTE (iend);
@@ -271,7 +272,9 @@ DEFUN ("libxml-parse-html-region", Flibxml_parse_html_region,
2, 4, 0,
doc: /* Parse the region as an HTML document and return the parse tree.
If BASE-URL is non-nil, it is used to expand relative URLs.
-If DISCARD-COMMENTS is non-nil, all HTML comments are discarded. */)
+
+If you want comments to be stripped, use the `xml-remove-comments'
+function to strip comments before calling this function. */)
(Lisp_Object start, Lisp_Object end, Lisp_Object base_url, Lisp_Object discard_comments)
{
if (init_libxml2_functions ())
@@ -284,23 +287,52 @@ DEFUN ("libxml-parse-xml-region", Flibxml_parse_xml_region,
2, 4, 0,
doc: /* Parse the region as an XML document and return the parse tree.
If BASE-URL is non-nil, it is used to expand relative URLs.
-If DISCARD-COMMENTS is non-nil, all HTML comments are discarded. */)
+
+If you want comments to be stripped, use the `xml-remove-comments'
+function to strip comments before calling this function. */)
(Lisp_Object start, Lisp_Object end, Lisp_Object base_url, Lisp_Object discard_comments)
{
if (init_libxml2_functions ())
return parse_region (start, end, base_url, discard_comments, false);
return Qnil;
}
+#endif /* HAVE_LIBXML2 */
+
+DEFUN ("libxml-available-p", Flibxml_available_p, Slibxml_available_p, 0, 0, 0,
+ doc: /* Return t if libxml2 support is available in this instance of Emacs.*/)
+ (void)
+{
+#ifdef HAVE_LIBXML2
+# ifdef WINDOWSNT
+ Lisp_Object found = Fassq (Qlibxml2, Vlibrary_cache);
+ if (CONSP (found))
+ return XCDR (found);
+ else
+ {
+ Lisp_Object status;
+ status = init_libxml2_functions () ? Qt : Qnil;
+ Vlibrary_cache = Fcons (Fcons (Qlibxml2, status), Vlibrary_cache);
+ return status;
+ }
+# else
+ return Qt;
+# endif /* WINDOWSNT */
+#else
+ return Qnil;
+#endif /* HAVE_LIBXML2 */
+}
+
/***********************************************************************
Initialization
***********************************************************************/
void
syms_of_xml (void)
{
+#ifdef HAVE_LIBXML2
defsubr (&Slibxml_parse_html_region);
defsubr (&Slibxml_parse_xml_region);
+#endif
+ defsubr (&Slibxml_available_p);
}
-
-#endif /* HAVE_LIBXML2 */
diff --git a/src/xrdb.c b/src/xrdb.c
index 41b1dd8c033..35de446cb7a 100644
--- a/src/xrdb.c
+++ b/src/xrdb.c
@@ -202,35 +202,6 @@ magic_db (const char *string, ptrdiff_t string_len, const char *class,
}
-static char *
-gethomedir (void)
-{
- struct passwd *pw;
- char *ptr;
- char *copy;
-
- if ((ptr = getenv ("HOME")) == NULL)
- {
- if ((ptr = getenv ("LOGNAME")) != NULL
- || (ptr = getenv ("USER")) != NULL)
- pw = getpwnam (ptr);
- else
- pw = getpwuid (getuid ());
-
- if (pw)
- ptr = pw->pw_dir;
- }
-
- if (ptr == NULL)
- return xstrdup ("/");
-
- ptrdiff_t len = strlen (ptr);
- copy = xmalloc (len + 2);
- strcpy (copy + len, "/");
- return memcpy (copy, ptr, len);
-}
-
-
/* Find the first element of SEARCH_PATH which exists and is readable,
after expanding the %-escapes. Return 0 if we didn't find any, and
the path name of the one we found otherwise. */
@@ -316,12 +287,11 @@ get_user_app (const char *class)
if (! db)
{
/* Check in the home directory. This is a bit of a hack; let's
- hope one's home directory doesn't contain any %-escapes. */
- char *home = gethomedir ();
+ hope one's home directory doesn't contain ':' or '%'. */
+ char const *home = get_homedir ();
db = search_magic_path (home, class, "%L/%N");
if (! db)
db = search_magic_path (home, class, "%N");
- xfree (home);
}
return db;
@@ -346,10 +316,9 @@ get_user_db (Display *display)
else
{
/* Use ~/.Xdefaults. */
- char *home = gethomedir ();
- ptrdiff_t homelen = strlen (home);
- char *filename = xrealloc (home, homelen + sizeof xdefaults);
- strcpy (filename + homelen, xdefaults);
+ char const *home = get_homedir ();
+ char *filename = xmalloc (strlen (home) + 1 + sizeof xdefaults);
+ splice_dir_file (filename, home, xdefaults);
db = XrmGetFileDatabase (filename);
xfree (filename);
}
@@ -380,13 +349,12 @@ get_environ_db (void)
if (STRINGP (system_name))
{
/* Use ~/.Xdefaults-HOSTNAME. */
- char *home = gethomedir ();
- ptrdiff_t homelen = strlen (home);
- ptrdiff_t filenamesize = (homelen + sizeof xdefaults
- + 1 + SBYTES (system_name));
- p = filename = xrealloc (home, filenamesize);
- lispstpcpy (stpcpy (stpcpy (filename + homelen, xdefaults), "-"),
- system_name);
+ char const *home = get_homedir ();
+ p = filename = xmalloc (strlen (home) + 1 + sizeof xdefaults
+ + 1 + SBYTES (system_name));
+ char *e = splice_dir_file (p, home, xdefaults);
+ *e++ = '/';
+ lispstpcpy (e, system_name);
}
}
@@ -474,13 +442,13 @@ x_load_resources (Display *display, const char *xrm_string,
/* Set double click time of list boxes in the file selection
dialog from `double-click-time'. */
- if (INTEGERP (Vdouble_click_time) && XINT (Vdouble_click_time) > 0)
+ if (FIXNUMP (Vdouble_click_time) && XFIXNUM (Vdouble_click_time) > 0)
{
sprintf (line, "%s*fsb*DirList.doubleClickInterval: %"pI"d",
- myclass, XFASTINT (Vdouble_click_time));
+ myclass, XFIXNAT (Vdouble_click_time));
XrmPutLineResource (&rdb, line);
sprintf (line, "%s*fsb*ItemsList.doubleClickInterval: %"pI"d",
- myclass, XFASTINT (Vdouble_click_time));
+ myclass, XFIXNAT (Vdouble_click_time));
XrmPutLineResource (&rdb, line);
}
diff --git a/src/xselect.c b/src/xselect.c
index 9c6a3498589..5f0bb44cc9a 100644
--- a/src/xselect.c
+++ b/src/xselect.c
@@ -35,6 +35,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "blockinput.h"
#include "termhooks.h"
#include "keyboard.h"
+#include "pdumper.h"
#include <X11/Xproto.h>
@@ -321,7 +322,7 @@ x_own_selection (Lisp_Object selection_name, Lisp_Object selection_value,
Lisp_Object prev_value;
selection_data = list4 (selection_name, selection_value,
- INTEGER_TO_CONS (timestamp), frame);
+ INT_TO_INTEGER (timestamp), frame);
prev_value = LOCAL_SELECTION (selection_name, dpyinfo);
tset_selection_alist
@@ -387,7 +388,7 @@ x_get_local_selection (Lisp_Object selection_symbol, Lisp_Object target_type,
XCAR (XCDR (local_value)));
else
value = Qnil;
- unbind_to (count, Qnil);
+ value = unbind_to (count, value);
}
/* Make sure this value is of a type that we could transmit
@@ -1084,10 +1085,10 @@ wait_for_property_change (struct prop_location *location)
property_change_reply, because property_change_reply_object says so. */
if (! location->arrived)
{
- EMACS_INT timeout = max (0, x_selection_timeout);
- EMACS_INT secs = timeout / 1000;
+ intmax_t timeout = max (0, x_selection_timeout);
+ intmax_t secs = timeout / 1000;
int nsecs = (timeout % 1000) * 1000000;
- TRACE2 (" Waiting %"pI"d secs, %d nsecs", secs, nsecs);
+ TRACE2 (" Waiting %"PRIdMAX" secs, %d nsecs", secs, nsecs);
wait_reading_process_output (secs, nsecs, 0, false,
property_change_reply, NULL, 0);
@@ -1157,8 +1158,6 @@ x_get_foreign_selection (Lisp_Object selection_symbol, Lisp_Object target_type,
Atom type_atom = (CONSP (target_type)
? symbol_to_x_atom (dpyinfo, XCAR (target_type))
: symbol_to_x_atom (dpyinfo, target_type));
- EMACS_INT timeout, secs;
- int nsecs;
if (!FRAME_LIVE_P (f))
return Qnil;
@@ -1194,10 +1193,10 @@ x_get_foreign_selection (Lisp_Object selection_symbol, Lisp_Object target_type,
unblock_input ();
/* This allows quits. Also, don't wait forever. */
- timeout = max (0, x_selection_timeout);
- secs = timeout / 1000;
- nsecs = (timeout % 1000) * 1000000;
- TRACE1 (" Start waiting %"pI"d secs for SelectionNotify", secs);
+ intmax_t timeout = max (0, x_selection_timeout);
+ intmax_t secs = timeout / 1000;
+ int nsecs = (timeout % 1000) * 1000000;
+ TRACE1 (" Start waiting %"PRIdMAX" secs for SelectionNotify", secs);
wait_reading_process_output (secs, nsecs, 0, false,
reading_selection_reply, NULL, 0);
TRACE1 (" Got event = %d", !NILP (XCAR (reading_selection_reply)));
@@ -1536,17 +1535,10 @@ x_get_window_property_as_lisp_data (struct x_display_info *dpyinfo,
ATOM 32 > 1 Vector of Symbols
* 16 1 Integer
* 16 > 1 Vector of Integers
- * 32 1 if <=16 bits: Integer
- if > 16 bits: Cons of top16, bot16
+ * 32 1 if small enough: fixnum
+ otherwise: bignum
* 32 > 1 Vector of the above
- When converting a Lisp number to C, it is assumed to be of format 16 if
- it is an integer, and of format 32 if it is a cons of two integers.
-
- When converting a vector of numbers from Lisp to C, it is assumed to be
- of format 16 if every element in the vector is an integer, and is assumed
- to be of format 32 if any element is a cons of two integers.
-
When converting an object to C, it may be of the form (SYMBOL . <data>)
where SYMBOL is what we should claim that the type is. Format and
representation are as above.
@@ -1581,7 +1573,7 @@ selection_data_to_lisp_data (struct x_display_info *dpyinfo,
lispy_type = QUTF8_STRING;
else
lispy_type = QSTRING;
- Fput_text_property (make_number (0), make_number (size),
+ Fput_text_property (make_fixnum (0), make_fixnum (size),
Qforeign_selection, lispy_type, str);
return str;
}
@@ -1611,8 +1603,8 @@ selection_data_to_lisp_data (struct x_display_info *dpyinfo,
}
/* Convert a single 16-bit number or a small 32-bit number to a Lisp_Int.
- If the number is 32 bits and won't fit in a Lisp_Int,
- convert it to a cons of integers, 16 bits in each half.
+ If the number is 32 bits and won't fit in a Lisp_Int, convert it
+ to a bignum.
INTEGER is a signed type, CARDINAL is unsigned.
Assume any other types are unsigned as well.
@@ -1620,16 +1612,16 @@ selection_data_to_lisp_data (struct x_display_info *dpyinfo,
else if (format == 32 && size == sizeof (int))
{
if (type == XA_INTEGER)
- return INTEGER_TO_CONS (((int *) data) [0]);
+ return INT_TO_INTEGER (((int *) data) [0]);
else
- return INTEGER_TO_CONS (((unsigned int *) data) [0]);
+ return INT_TO_INTEGER (((unsigned int *) data) [0]);
}
else if (format == 16 && size == sizeof (short))
{
if (type == XA_INTEGER)
- return make_number (((short *) data) [0]);
+ return make_fixnum (((short *) data) [0]);
else
- return make_number (((unsigned short *) data) [0]);
+ return make_fixnum (((unsigned short *) data) [0]);
}
/* Convert any other kind of data to a vector of numbers, represented
@@ -1645,7 +1637,7 @@ selection_data_to_lisp_data (struct x_display_info *dpyinfo,
for (i = 0; i < size / 2; i++)
{
short j = ((short *) data) [i];
- ASET (v, i, make_number (j));
+ ASET (v, i, make_fixnum (j));
}
}
else
@@ -1653,7 +1645,7 @@ selection_data_to_lisp_data (struct x_display_info *dpyinfo,
for (i = 0; i < size / 2; i++)
{
unsigned short j = ((unsigned short *) data) [i];
- ASET (v, i, make_number (j));
+ ASET (v, i, make_fixnum (j));
}
}
return v;
@@ -1668,7 +1660,7 @@ selection_data_to_lisp_data (struct x_display_info *dpyinfo,
for (i = 0; i < size / X_LONG_SIZE; i++)
{
int j = ((int *) data) [i];
- ASET (v, i, INTEGER_TO_CONS (j));
+ ASET (v, i, INT_TO_INTEGER (j));
}
}
else
@@ -1676,7 +1668,7 @@ selection_data_to_lisp_data (struct x_display_info *dpyinfo,
for (i = 0; i < size / X_LONG_SIZE; i++)
{
unsigned int j = ((unsigned int *) data) [i];
- ASET (v, i, INTEGER_TO_CONS (j));
+ ASET (v, i, INT_TO_INTEGER (j));
}
}
return v;
@@ -1693,7 +1685,7 @@ static unsigned long
cons_to_x_long (Lisp_Object obj)
{
if (X_ULONG_MAX <= INTMAX_MAX
- || XINT (INTEGERP (obj) ? obj : XCAR (obj)) < 0)
+ || NILP (Fnatnump (CONSP (obj) ? XCAR (obj) : obj)))
return cons_to_signed (obj, X_LONG_MIN, min (X_ULONG_MAX, INTMAX_MAX));
else
return cons_to_unsigned (obj, X_ULONG_MAX);
@@ -1748,7 +1740,7 @@ lisp_data_to_selection_data (struct x_display_info *dpyinfo,
*x_atom_ptr = symbol_to_x_atom (dpyinfo, obj);
if (NILP (type)) type = QATOM;
}
- else if (RANGED_INTEGERP (X_SHRT_MIN, obj, X_SHRT_MAX))
+ else if (RANGED_FIXNUMP (X_SHRT_MIN, obj, X_SHRT_MAX))
{
void *data = xmalloc (sizeof (short) + 1);
short *short_ptr = data;
@@ -1756,14 +1748,14 @@ lisp_data_to_selection_data (struct x_display_info *dpyinfo,
cs->format = 16;
cs->size = 1;
cs->data[sizeof (short)] = 0;
- *short_ptr = XINT (obj);
+ *short_ptr = XFIXNUM (obj);
if (NILP (type)) type = QINTEGER;
}
else if (INTEGERP (obj)
|| (CONSP (obj) && INTEGERP (XCAR (obj))
- && (INTEGERP (XCDR (obj))
+ && (FIXNUMP (XCDR (obj))
|| (CONSP (XCDR (obj))
- && INTEGERP (XCAR (XCDR (obj)))))))
+ && FIXNUMP (XCAR (XCDR (obj)))))))
{
void *data = xmalloc (sizeof (unsigned long) + 1);
unsigned long *x_long_ptr = data;
@@ -1811,7 +1803,7 @@ lisp_data_to_selection_data (struct x_display_info *dpyinfo,
if (NILP (type)) type = QINTEGER;
for (i = 0; i < size; i++)
{
- if (! RANGED_INTEGERP (X_SHRT_MIN, AREF (obj, i),
+ if (! RANGED_FIXNUMP (X_SHRT_MIN, AREF (obj, i),
X_SHRT_MAX))
{
/* Use sizeof (long) even if it is more than 32 bits.
@@ -1832,7 +1824,7 @@ lisp_data_to_selection_data (struct x_display_info *dpyinfo,
if (format == 32)
x_atoms[i] = cons_to_x_long (AREF (obj, i));
else
- shorts[i] = XINT (AREF (obj, i));
+ shorts[i] = XFIXNUM (AREF (obj, i));
}
}
}
@@ -1848,18 +1840,18 @@ clean_local_selection_data (Lisp_Object obj)
if (CONSP (obj)
&& INTEGERP (XCAR (obj))
&& CONSP (XCDR (obj))
- && INTEGERP (XCAR (XCDR (obj)))
+ && FIXNUMP (XCAR (XCDR (obj)))
&& NILP (XCDR (XCDR (obj))))
obj = Fcons (XCAR (obj), XCDR (obj));
if (CONSP (obj)
&& INTEGERP (XCAR (obj))
- && INTEGERP (XCDR (obj)))
+ && FIXNUMP (XCDR (obj)))
{
- if (XINT (XCAR (obj)) == 0)
+ if (EQ (XCAR (obj), make_fixnum (0)))
return XCDR (obj);
- if (XINT (XCAR (obj)) == -1)
- return make_number (- XINT (XCDR (obj)));
+ if (EQ (XCAR (obj), make_fixnum (-1)))
+ return make_fixnum (- XFIXNUM (XCDR (obj)));
}
if (VECTORP (obj))
{
@@ -2094,7 +2086,7 @@ On Nextstep, TERMINAL is unused. */)
struct frame *f = frame_for_x_selection (terminal);
CHECK_SYMBOL (selection);
- if (EQ (selection, Qnil)) selection = QPRIMARY;
+ if (NILP (selection)) selection = QPRIMARY;
if (EQ (selection, Qt)) selection = QSECONDARY;
if (f && !NILP (LOCAL_SELECTION (selection, FRAME_DISPLAY_INFO (f))))
@@ -2124,7 +2116,7 @@ On Nextstep, TERMINAL is unused. */)
struct x_display_info *dpyinfo;
CHECK_SYMBOL (selection);
- if (EQ (selection, Qnil)) selection = QPRIMARY;
+ if (NILP (selection)) selection = QPRIMARY;
if (EQ (selection, Qt)) selection = QSECONDARY;
if (!f)
@@ -2306,15 +2298,15 @@ x_fill_property_data (Display *dpy, Lisp_Object data, void *ret, int format)
if (NUMBERP (o) || CONSP (o))
{
if (CONSP (o)
- && RANGED_INTEGERP (X_LONG_MIN >> 16, XCAR (o), X_LONG_MAX >> 16)
- && RANGED_INTEGERP (- (1 << 15), XCDR (o), -1))
+ && RANGED_FIXNUMP (X_LONG_MIN >> 16, XCAR (o), X_LONG_MAX >> 16)
+ && RANGED_FIXNUMP (- (1 << 15), XCDR (o), -1))
{
/* cons_to_x_long does not handle negative values for v2.
For XDnd, v2 might be y of a window, and can be negative.
The XDnd spec. is not explicit about negative values,
but let's assume negative v2 is sent modulo 2**16. */
- unsigned long v1 = XINT (XCAR (o)) & 0xffff;
- unsigned long v2 = XINT (XCDR (o)) & 0xffff;
+ unsigned long v1 = XFIXNUM (XCAR (o)) & 0xffff;
+ unsigned long v2 = XFIXNUM (XCDR (o)) & 0xffff;
val = (v1 << 16) | v2;
}
else
@@ -2481,11 +2473,11 @@ x_handle_dnd_message (struct frame *f, const XClientMessageEvent *event,
data = (unsigned char *) idata;
}
- vec = Fmake_vector (make_number (4), Qnil);
+ vec = make_nil_vector (4);
ASET (vec, 0, SYMBOL_NAME (x_atom_to_symbol (FRAME_DISPLAY_INFO (f),
event->message_type)));
ASET (vec, 1, frame);
- ASET (vec, 2, make_number (event->format));
+ ASET (vec, 2, make_fixnum (event->format));
ASET (vec, 3, x_property_data_to_lisp (f,
data,
event->message_type,
@@ -2496,8 +2488,8 @@ x_handle_dnd_message (struct frame *f, const XClientMessageEvent *event,
bufp->kind = DRAG_N_DROP_EVENT;
bufp->frame_or_window = frame;
bufp->timestamp = CurrentTime;
- bufp->x = make_number (x);
- bufp->y = make_number (y);
+ bufp->x = make_fixnum (x);
+ bufp->y = make_fixnum (y);
bufp->arg = vec;
bufp->modifiers = 0;
@@ -2554,17 +2546,17 @@ x_send_client_event (Lisp_Object display, Lisp_Object dest, Lisp_Object from,
struct frame *f = decode_window_system_frame (from);
bool to_root;
- CHECK_NUMBER (format);
+ CHECK_FIXNUM (format);
CHECK_CONS (values);
if (x_check_property_data (values) == -1)
error ("Bad data in VALUES, must be number, cons or string");
- if (XINT (format) != 8 && XINT (format) != 16 && XINT (format) != 32)
+ if (XFIXNUM (format) != 8 && XFIXNUM (format) != 16 && XFIXNUM (format) != 32)
error ("FORMAT must be one of 8, 16 or 32");
event.xclient.type = ClientMessage;
- event.xclient.format = XINT (format);
+ event.xclient.format = XFIXNUM (format);
if (FRAMEP (dest) || NILP (dest))
{
@@ -2620,6 +2612,9 @@ x_send_client_event (Lisp_Object display, Lisp_Object dest, Lisp_Object from,
}
+
+static void syms_of_xselect_for_pdumper (void);
+
void
syms_of_xselect (void)
{
@@ -2635,17 +2630,9 @@ syms_of_xselect (void)
reading_selection_reply = Fcons (Qnil, Qnil);
staticpro (&reading_selection_reply);
- reading_selection_window = 0;
- reading_which_selection = 0;
- property_change_wait_list = 0;
- prop_location_identifier = 0;
- property_change_reply = Fcons (Qnil, Qnil);
staticpro (&property_change_reply);
- converted_selections = NULL;
- conversion_fail_tag = None;
-
/* FIXME: Duplicate definition in nsselect.c. */
DEFVAR_LISP ("selection-converter-alist", Vselection_converter_alist,
doc: /* An alist associating X Windows selection-types with functions.
@@ -2724,4 +2711,18 @@ A value of 0 means wait as long as necessary. This is initialized from the
DEFSYM (Qforeign_selection, "foreign-selection");
DEFSYM (Qx_lost_selection_functions, "x-lost-selection-functions");
DEFSYM (Qx_sent_selection_functions, "x-sent-selection-functions");
+
+ pdumper_do_now_and_after_load (syms_of_xselect_for_pdumper);
+}
+
+static void
+syms_of_xselect_for_pdumper (void)
+{
+ reading_selection_window = 0;
+ reading_which_selection = 0;
+ property_change_wait_list = 0;
+ prop_location_identifier = 0;
+ property_change_reply = Fcons (Qnil, Qnil);
+ converted_selections = NULL;
+ conversion_fail_tag = None;
}
diff --git a/src/xsettings.c b/src/xsettings.c
index 6a0240242a0..947d5cfb7b6 100644
--- a/src/xsettings.c
+++ b/src/xsettings.c
@@ -32,6 +32,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "keyboard.h"
#include "blockinput.h"
#include "termhooks.h"
+#include "pdumper.h"
#include <X11/Xproto.h>
@@ -392,8 +393,8 @@ parse_settings (unsigned char *prop,
unsigned long bytes,
struct xsettings *settings)
{
- Lisp_Object byteorder = Fbyteorder ();
- int my_bo = XFASTINT (byteorder) == 'B' ? MSBFirst : LSBFirst;
+ int int1 = 1;
+ int my_bo = *(char *) &int1 == 1 ? LSBFirst : MSBFirst;
int that_bo = prop[0];
CARD32 n_settings;
int bytes_parsed = 0;
@@ -1023,13 +1024,18 @@ void
syms_of_xsettings (void)
{
current_mono_font = NULL;
+ PDUMPER_IGNORE (current_mono_font);
current_font = NULL;
+ PDUMPER_IGNORE (current_font);
first_dpyinfo = NULL;
+ PDUMPER_IGNORE (first_dpyinfo);
#ifdef HAVE_GSETTINGS
gsettings_client = NULL;
+ PDUMPER_IGNORE (gsettings_client);
#endif
#ifdef HAVE_GCONF
gconf_client = NULL;
+ PDUMPER_IGNORE (gconf_client);
#endif
DEFSYM (Qmonospace_font_name, "monospace-font-name");
diff --git a/src/xterm.c b/src/xterm.c
index 3cadf693804..5aa3e3ff25c 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -38,11 +38,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <X11/extensions/Xfixes.h>
#endif
-/* Using Xft implies that XRender is available. */
-#ifdef HAVE_XFT
-#include <X11/extensions/Xrender.h>
-#endif
-
#ifdef HAVE_XDBE
#include <X11/extensions/Xdbe.h>
#endif
@@ -79,6 +74,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "xsettings.h"
#include "sysselect.h"
#include "menu.h"
+#include "pdumper.h"
#ifdef USE_X_TOOLKIT
#include <X11/Shell.h>
@@ -430,7 +426,7 @@ x_set_cr_source_with_gc_background (struct frame *f, GC gc)
/* Fringe bitmaps. */
static int max_fringe_bmp = 0;
-static cairo_pattern_t **fringe_bmp = 0;
+static cairo_surface_t **fringe_bmp = 0;
static void
x_cr_define_fringe_bitmap (int which, unsigned short *bits, int h, int wd)
@@ -438,13 +434,12 @@ x_cr_define_fringe_bitmap (int which, unsigned short *bits, int h, int wd)
int i, stride;
cairo_surface_t *surface;
unsigned char *data;
- cairo_pattern_t *pattern;
if (which >= max_fringe_bmp)
{
i = max_fringe_bmp;
max_fringe_bmp = which + 20;
- fringe_bmp = (cairo_pattern_t **) xrealloc (fringe_bmp, max_fringe_bmp * sizeof (cairo_pattern_t *));
+ fringe_bmp = xrealloc (fringe_bmp, max_fringe_bmp * sizeof (*fringe_bmp));
while (i < max_fringe_bmp)
fringe_bmp[i++] = 0;
}
@@ -462,12 +457,10 @@ x_cr_define_fringe_bitmap (int which, unsigned short *bits, int h, int wd)
}
cairo_surface_mark_dirty (surface);
- pattern = cairo_pattern_create_for_surface (surface);
- cairo_surface_destroy (surface);
unblock_input ();
- fringe_bmp[which] = pattern;
+ fringe_bmp[which] = surface;
}
static void
@@ -479,23 +472,20 @@ x_cr_destroy_fringe_bitmap (int which)
if (fringe_bmp[which])
{
block_input ();
- cairo_pattern_destroy (fringe_bmp[which]);
+ cairo_surface_destroy (fringe_bmp[which]);
unblock_input ();
}
fringe_bmp[which] = 0;
}
static void
-x_cr_draw_image (struct frame *f, GC gc, cairo_pattern_t *image,
+x_cr_draw_image (struct frame *f, GC gc, cairo_surface_t *image,
+ int image_width, int image_height,
int src_x, int src_y, int width, int height,
int dest_x, int dest_y, bool overlay_p)
{
- cairo_t *cr;
- cairo_matrix_t matrix;
- cairo_surface_t *surface;
- cairo_format_t format;
+ cairo_t *cr = x_begin_cr_clip (f, gc);
- cr = x_begin_cr_clip (f, gc);
if (overlay_p)
cairo_rectangle (cr, dest_x, dest_y, width, height);
else
@@ -504,21 +494,33 @@ x_cr_draw_image (struct frame *f, GC gc, cairo_pattern_t *image,
cairo_rectangle (cr, dest_x, dest_y, width, height);
cairo_fill_preserve (cr);
}
- cairo_clip (cr);
- cairo_matrix_init_translate (&matrix, src_x - dest_x, src_y - dest_y);
- cairo_pattern_set_matrix (image, &matrix);
- cairo_pattern_get_surface (image, &surface);
- format = cairo_image_surface_get_format (surface);
+
+ int orig_image_width = cairo_image_surface_get_width (image);
+ if (image_width == 0) image_width = orig_image_width;
+ int orig_image_height = cairo_image_surface_get_height (image);
+ if (image_height == 0) image_height = orig_image_height;
+
+ cairo_pattern_t *pattern = cairo_pattern_create_for_surface (image);
+ cairo_matrix_t matrix;
+ cairo_matrix_init_scale (&matrix, orig_image_width / (double) image_width,
+ orig_image_height / (double) image_height);
+ cairo_matrix_translate (&matrix, src_x - dest_x, src_y - dest_y);
+ cairo_pattern_set_matrix (pattern, &matrix);
+
+ cairo_format_t format = cairo_image_surface_get_format (image);
if (format != CAIRO_FORMAT_A8 && format != CAIRO_FORMAT_A1)
{
- cairo_set_source (cr, image);
+ cairo_set_source (cr, pattern);
cairo_fill (cr);
}
else
{
x_set_cr_source_with_gc_foreground (f, gc);
- cairo_mask (cr, image);
+ cairo_clip (cr);
+ cairo_mask (cr, pattern);
}
+ cairo_pattern_destroy (pattern);
+
x_end_cr_clip (f);
}
@@ -549,10 +551,8 @@ x_cr_accumulate_data (void *closure, const unsigned char *data,
}
static void
-x_cr_destroy (Lisp_Object arg)
+x_cr_destroy (void *cr)
{
- cairo_t *cr = (cairo_t *) XSAVE_POINTER (arg, 0);
-
block_input ();
cairo_destroy (cr);
unblock_input ();
@@ -611,7 +611,7 @@ x_cr_export_frames (Lisp_Object frames, cairo_surface_type_t surface_type)
cr = cairo_create (surface);
cairo_surface_destroy (surface);
- record_unwind_protect (x_cr_destroy, make_save_ptr (cr));
+ record_unwind_protect_ptr (x_cr_destroy, cr);
while (1)
{
@@ -924,8 +924,8 @@ x_set_frame_alpha (struct frame *f)
if (FLOATP (Vframe_alpha_lower_limit))
alpha_min = XFLOAT_DATA (Vframe_alpha_lower_limit);
- else if (INTEGERP (Vframe_alpha_lower_limit))
- alpha_min = (XINT (Vframe_alpha_lower_limit)) / 100.0;
+ else if (FIXNUMP (Vframe_alpha_lower_limit))
+ alpha_min = (XFIXNUM (Vframe_alpha_lower_limit)) / 100.0;
if (alpha < 0.0)
return;
@@ -996,12 +996,7 @@ static void
x_update_begin (struct frame *f)
{
#ifdef USE_CAIRO
- if (! NILP (tip_frame) && XFRAME (tip_frame) == f
- && ! FRAME_VISIBLE_P (f)
-#ifdef USE_GTK
- && !NILP (Fframe_parameter (tip_frame, Qtooltip))
-#endif
- )
+ if (FRAME_TOOLTIP_P (f) && !FRAME_VISIBLE_P (f))
return;
if (! FRAME_CR_SURFACE (f))
@@ -1313,7 +1308,11 @@ x_clear_under_internal_border (struct frame *f)
#else
int margin = FRAME_TOP_MARGIN_HEIGHT (f);
#endif
- struct face *face = FACE_FROM_ID_OR_NULL (f, INTERNAL_BORDER_FACE_ID);
+ int face_id =
+ !NILP (Vface_remapping_alist)
+ ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID)
+ : INTERNAL_BORDER_FACE_ID;
+ struct face *face = FACE_FROM_ID_OR_NULL (f, face_id);
block_input ();
@@ -1376,7 +1375,11 @@ x_after_update_window_line (struct window *w, struct glyph_row *desired_row)
height > 0))
{
int y = WINDOW_TO_FRAME_PIXEL_Y (w, max (0, desired_row->y));
- struct face *face = FACE_FROM_ID_OR_NULL (f, INTERNAL_BORDER_FACE_ID);
+ int face_id =
+ !NILP (Vface_remapping_alist)
+ ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID)
+ : INTERNAL_BORDER_FACE_ID;
+ struct face *face = FACE_FROM_ID_OR_NULL (f, face_id);
block_input ();
if (face)
@@ -1441,7 +1444,7 @@ x_draw_fringe_bitmap (struct window *w, struct glyph_row *row, struct draw_fring
: f->output_data.x->cursor_pixel)
: face->foreground));
XSetBackground (display, gc, face->background);
- x_cr_draw_image (f, gc, fringe_bmp[p->which], 0, p->dh,
+ x_cr_draw_image (f, gc, fringe_bmp[p->which], 0, 0, 0, p->dh,
p->wd, p->h, p->x, p->y, p->overlay_p);
XSetForeground (display, gc, gcv.foreground);
XSetBackground (display, gc, gcv.background);
@@ -1522,7 +1525,9 @@ static void x_setup_relief_colors (struct glyph_string *);
static void x_draw_image_glyph_string (struct glyph_string *);
static void x_draw_image_relief (struct glyph_string *);
static void x_draw_image_foreground (struct glyph_string *);
+#ifndef USE_CAIRO
static void x_draw_image_foreground_1 (struct glyph_string *, Pixmap);
+#endif
static void x_clear_glyph_string_rect (struct glyph_string *, int,
int, int, int);
static void x_draw_relief_rect (struct frame *, int, int, int, int,
@@ -1984,7 +1989,13 @@ x_draw_glyphless_glyph_string_foreground (struct glyph_string *s)
for (i = 0; i < s->nchars; i++, glyph++)
{
- char buf[7], *str = NULL;
+#ifdef GCC_LINT
+ enum { PACIFY_GCC_BUG_81401 = 1 };
+#else
+ enum { PACIFY_GCC_BUG_81401 = 0 };
+#endif
+ char buf[7 + PACIFY_GCC_BUG_81401];
+ char *str = NULL;
int len = glyph->u.glyphless.len;
if (glyph->u.glyphless.method == GLYPHLESS_DISPLAY_ACRONYM)
@@ -2977,6 +2988,47 @@ x_draw_glyph_string_box (struct glyph_string *s)
}
+static void
+x_composite_image (struct glyph_string *s, Pixmap dest,
+ int srcX, int srcY, int dstX, int dstY,
+ int width, int height)
+{
+#ifdef HAVE_XRENDER
+ if (s->img->picture)
+ {
+ Picture destination;
+ XRenderPictFormat *default_format;
+ XRenderPictureAttributes attr;
+
+ /* FIXME: Should we do this each time or would it make sense to
+ store destination in the frame struct? */
+ default_format = XRenderFindVisualFormat (s->display,
+ DefaultVisual (s->display, 0));
+ destination = XRenderCreatePicture (s->display, dest,
+ default_format, 0, &attr);
+
+ /* FIXME: It may make sense to use PictOpSrc instead of
+ PictOpOver, as I don't know if we care about alpha values too
+ much here. */
+ XRenderComposite (s->display, PictOpOver,
+ s->img->picture, s->img->mask_picture, destination,
+ srcX, srcY,
+ srcX, srcY,
+ dstX, dstY,
+ width, height);
+
+ XRenderFreePicture (s->display, destination);
+ return;
+ }
+#endif
+
+ XCopyArea (s->display, s->img->pixmap,
+ dest, s->gc,
+ srcX, srcY,
+ width, height, dstX, dstY);
+}
+
+
/* Draw foreground of image glyph string S. */
static void
@@ -2999,6 +3051,32 @@ x_draw_image_foreground (struct glyph_string *s)
if (s->slice.y == 0)
y += s->img->vmargin;
+#ifdef USE_CAIRO
+ if (s->img->cr_data)
+ {
+ x_set_glyph_string_clipping (s);
+ x_cr_draw_image (s->f, s->gc,
+ s->img->cr_data, s->img->width, s->img->height,
+ s->slice.x, s->slice.y, s->slice.width, s->slice.height,
+ x, y, true);
+ if (!s->img->mask)
+ {
+ /* When the image has a mask, we can expect that at
+ least part of a mouse highlight or a block cursor will
+ be visible. If the image doesn't have a mask, make
+ a block cursor visible by drawing a rectangle around
+ the image. I believe it's looking better if we do
+ nothing here for mouse-face. */
+ if (s->hl == DRAW_CURSOR)
+ {
+ int relief = eabs (s->img->relief);
+ x_draw_rectangle (s->f, s->gc, x - relief, y - relief,
+ s->slice.width + relief*2 - 1,
+ s->slice.height + relief*2 - 1);
+ }
+ }
+ }
+#else /* ! USE_CAIRO */
if (s->img->pixmap)
{
if (s->img->mask)
@@ -3008,6 +3086,7 @@ x_draw_image_foreground (struct glyph_string *s)
trust on the shape extension to be available
(XShapeCombineRegion). So, compute the rectangle to draw
manually. */
+ /* FIXME: Do we need to do this when using XRender compositing? */
unsigned long mask = (GCClipMask | GCClipXOrigin | GCClipYOrigin
| GCFunction);
XGCValues xgcv;
@@ -3025,10 +3104,9 @@ x_draw_image_foreground (struct glyph_string *s)
image_rect.width = s->slice.width;
image_rect.height = s->slice.height;
if (x_intersect_rectangles (&clip_rect, &image_rect, &r))
- XCopyArea (s->display, s->img->pixmap,
- FRAME_X_DRAWABLE (s->f), s->gc,
- s->slice.x + r.x - x, s->slice.y + r.y - y,
- r.width, r.height, r.x, r.y);
+ x_composite_image (s, FRAME_X_DRAWABLE (s->f),
+ s->slice.x + r.x - x, s->slice.y + r.y - y,
+ r.x, r.y, r.width, r.height);
}
else
{
@@ -3040,10 +3118,8 @@ x_draw_image_foreground (struct glyph_string *s)
image_rect.width = s->slice.width;
image_rect.height = s->slice.height;
if (x_intersect_rectangles (&clip_rect, &image_rect, &r))
- XCopyArea (s->display, s->img->pixmap,
- FRAME_X_DRAWABLE (s->f), s->gc,
- s->slice.x + r.x - x, s->slice.y + r.y - y,
- r.width, r.height, r.x, r.y);
+ x_composite_image (s, FRAME_X_DRAWABLE (s->f), s->slice.x + r.x - x, s->slice.y + r.y - y,
+ r.x, r.y, r.width, r.height);
/* When the image has a mask, we can expect that at
least part of a mouse highlight or a block cursor will
@@ -3061,6 +3137,7 @@ x_draw_image_foreground (struct glyph_string *s)
}
}
}
+#endif /* ! USE_CAIRO */
else
/* Draw a rectangle if image could not be loaded. */
x_draw_rectangle (s->f, s->gc, x, y,
@@ -3097,7 +3174,9 @@ x_draw_image_relief (struct glyph_string *s)
if (s->hl == DRAW_IMAGE_SUNKEN
|| s->hl == DRAW_IMAGE_RAISED)
{
- thick = tool_bar_button_relief >= 0 ? tool_bar_button_relief : DEFAULT_TOOL_BAR_BUTTON_RELIEF;
+ thick = (tool_bar_button_relief < 0
+ ? DEFAULT_TOOL_BAR_BUTTON_RELIEF
+ : min (tool_bar_button_relief, 1000000));
raised_p = s->hl == DRAW_IMAGE_RAISED;
}
else
@@ -3113,14 +3192,14 @@ x_draw_image_relief (struct glyph_string *s)
if (s->face->id == TOOL_BAR_FACE_ID)
{
if (CONSP (Vtool_bar_button_margin)
- && INTEGERP (XCAR (Vtool_bar_button_margin))
- && INTEGERP (XCDR (Vtool_bar_button_margin)))
+ && FIXNUMP (XCAR (Vtool_bar_button_margin))
+ && FIXNUMP (XCDR (Vtool_bar_button_margin)))
{
- extra_x = XINT (XCAR (Vtool_bar_button_margin));
- extra_y = XINT (XCDR (Vtool_bar_button_margin));
+ extra_x = XFIXNUM (XCAR (Vtool_bar_button_margin));
+ extra_y = XFIXNUM (XCDR (Vtool_bar_button_margin));
}
- else if (INTEGERP (Vtool_bar_button_margin))
- extra_x = extra_y = XINT (Vtool_bar_button_margin);
+ else if (FIXNUMP (Vtool_bar_button_margin))
+ extra_x = extra_y = XFIXNUM (Vtool_bar_button_margin);
}
top_p = bot_p = left_p = right_p = false;
@@ -3141,6 +3220,7 @@ x_draw_image_relief (struct glyph_string *s)
}
+#ifndef USE_CAIRO
/* Draw the foreground of image glyph string S to PIXMAP. */
static void
@@ -3213,6 +3293,7 @@ x_draw_image_foreground_1 (struct glyph_string *s, Pixmap pixmap)
x_draw_rectangle (s->f, s->gc, x, y,
s->slice.width - 1, s->slice.height - 1);
}
+#endif /* ! USE_CAIRO */
/* Draw part of the background of glyph string S. X, Y, W, and H
@@ -3272,6 +3353,7 @@ x_draw_image_glyph_string (struct glyph_string *s)
|| s->img->pixmap == 0
|| s->width != s->background_width)
{
+#ifndef USE_CAIRO
if (s->img->mask)
{
/* Create a pixmap as large as the glyph string. Fill it
@@ -3312,6 +3394,7 @@ x_draw_image_glyph_string (struct glyph_string *s)
}
}
else
+#endif /* ! USE_CAIRO */
{
int x = s->x;
int y = s->y;
@@ -3334,25 +3417,8 @@ x_draw_image_glyph_string (struct glyph_string *s)
}
/* Draw the foreground. */
-#ifdef USE_CAIRO
- if (s->img->cr_data)
- {
- cairo_t *cr = x_begin_cr_clip (s->f, s->gc);
-
- int x = s->x + s->img->hmargin;
- int y = s->y + s->img->vmargin;
- int width = s->background_width;
-
- cairo_set_source_surface (cr, s->img->cr_data,
- x - s->slice.x,
- y - s->slice.y);
- cairo_rectangle (cr, x, y, width, height);
- cairo_fill (cr);
- x_end_cr_clip (s->f);
- }
- else
-#endif
- if (pixmap != None)
+#ifndef USE_CAIRO
+ if (pixmap != None)
{
x_draw_image_foreground_1 (s, pixmap);
x_set_glyph_string_clipping (s);
@@ -3361,6 +3427,7 @@ x_draw_image_glyph_string (struct glyph_string *s)
XFreePixmap (s->display, pixmap);
}
else
+#endif /* ! USE_CAIRO */
x_draw_image_foreground (s);
/* If we must draw a relief around the image, do it. */
@@ -3705,33 +3772,53 @@ x_draw_glyph_string (struct glyph_string *s)
else
{
struct font *font = font_for_underline_metrics (s);
+ unsigned long minimum_offset;
+ bool underline_at_descent_line;
+ bool use_underline_position_properties;
+ Lisp_Object val
+ = buffer_local_value (Qunderline_minimum_offset,
+ s->w->contents);
+ if (FIXNUMP (val))
+ minimum_offset = XFIXNAT (val);
+ else
+ minimum_offset = 1;
+ val = buffer_local_value (Qx_underline_at_descent_line,
+ s->w->contents);
+ underline_at_descent_line
+ = !(NILP (val) || EQ (val, Qunbound));
+ val
+ = buffer_local_value (Qx_use_underline_position_properties,
+ s->w->contents);
+ use_underline_position_properties
+ = !(NILP (val) || EQ (val, Qunbound));
/* Get the underline thickness. Default is 1 pixel. */
if (font && font->underline_thickness > 0)
thickness = font->underline_thickness;
else
thickness = 1;
- if (x_underline_at_descent_line)
+ if (underline_at_descent_line)
position = (s->height - thickness) - (s->ybase - s->y);
else
{
- /* Get the underline position. This is the recommended
- vertical offset in pixels from the baseline to the top of
- the underline. This is a signed value according to the
+ /* Get the underline position. This is the
+ recommended vertical offset in pixels from
+ the baseline to the top of the underline.
+ This is a signed value according to the
specs, and its default is
ROUND ((maximum descent) / 2), with
ROUND(x) = floor (x + 0.5) */
- if (x_use_underline_position_properties
+ if (use_underline_position_properties
&& font && font->underline_position >= 0)
position = font->underline_position;
else if (font)
position = (font->descent + 1) / 2;
else
- position = underline_minimum_offset;
+ position = minimum_offset;
}
- position = max (position, underline_minimum_offset);
+ position = max (position, minimum_offset);
}
/* Check the sanity of thickness and position. We should
avoid drawing underline out of the current line area. */
@@ -4251,7 +4338,6 @@ x_scroll_run (struct window *w, struct run *run)
#ifdef USE_CAIRO
if (FRAME_CR_CONTEXT (f))
{
- int wx = WINDOW_LEFT_EDGE_X (w);
cairo_surface_t *s = cairo_image_surface_create (CAIRO_FORMAT_ARGB32,
width, height);
cairo_t *cr = cairo_create (s);
@@ -4262,8 +4348,8 @@ x_scroll_run (struct window *w, struct run *run)
cr = FRAME_CR_CONTEXT (f);
cairo_save (cr);
- cairo_set_source_surface (cr, s, wx, to_y);
- cairo_rectangle (cr, wx, to_y, width, height);
+ cairo_set_source_surface (cr, s, x, to_y);
+ cairo_rectangle (cr, x, to_y, width, height);
cairo_fill (cr);
cairo_restore (cr);
cairo_surface_destroy (s);
@@ -4372,16 +4458,6 @@ x_focus_changed (int type, int state, struct x_display_info *dpyinfo, struct fra
{
x_new_focus_frame (dpyinfo, frame);
dpyinfo->x_focus_event_frame = frame;
-
- /* Don't stop displaying the initial startup message
- for a switch-frame event we don't need. */
- /* When run as a daemon, Vterminal_frame is always NIL. */
- bufp->arg = (((NILP (Vterminal_frame)
- || ! FRAME_X_P (XFRAME (Vterminal_frame))
- || EQ (Fdaemonp (), Qt))
- && CONSP (Vframe_list)
- && !NILP (XCDR (Vframe_list)))
- ? Qt : Qnil);
bufp->kind = FOCUS_IN_EVENT;
XSETFRAME (bufp->frame_or_window, frame);
}
@@ -4821,15 +4897,15 @@ x_x_to_emacs_modifiers (struct x_display_info *dpyinfo, int state)
Lisp_Object tem;
tem = Fget (Vx_ctrl_keysym, Qmodifier_value);
- if (INTEGERP (tem)) mod_ctrl = XINT (tem) & INT_MAX;
+ if (FIXNUMP (tem)) mod_ctrl = XFIXNUM (tem) & INT_MAX;
tem = Fget (Vx_alt_keysym, Qmodifier_value);
- if (INTEGERP (tem)) mod_alt = XINT (tem) & INT_MAX;
+ if (FIXNUMP (tem)) mod_alt = XFIXNUM (tem) & INT_MAX;
tem = Fget (Vx_meta_keysym, Qmodifier_value);
- if (INTEGERP (tem)) mod_meta = XINT (tem) & INT_MAX;
+ if (FIXNUMP (tem)) mod_meta = XFIXNUM (tem) & INT_MAX;
tem = Fget (Vx_hyper_keysym, Qmodifier_value);
- if (INTEGERP (tem)) mod_hyper = XINT (tem) & INT_MAX;
+ if (FIXNUMP (tem)) mod_hyper = XFIXNUM (tem) & INT_MAX;
tem = Fget (Vx_super_keysym, Qmodifier_value);
- if (INTEGERP (tem)) mod_super = XINT (tem) & INT_MAX;
+ if (FIXNUMP (tem)) mod_super = XFIXNUM (tem) & INT_MAX;
return ( ((state & (ShiftMask | dpyinfo->shift_lock_mask)) ? shift_modifier : 0)
| ((state & ControlMask) ? mod_ctrl : 0)
@@ -4840,7 +4916,7 @@ x_x_to_emacs_modifiers (struct x_display_info *dpyinfo, int state)
}
static int
-x_emacs_to_x_modifiers (struct x_display_info *dpyinfo, EMACS_INT state)
+x_emacs_to_x_modifiers (struct x_display_info *dpyinfo, intmax_t state)
{
EMACS_INT mod_ctrl = ctrl_modifier;
EMACS_INT mod_meta = meta_modifier;
@@ -4851,15 +4927,15 @@ x_emacs_to_x_modifiers (struct x_display_info *dpyinfo, EMACS_INT state)
Lisp_Object tem;
tem = Fget (Vx_ctrl_keysym, Qmodifier_value);
- if (INTEGERP (tem)) mod_ctrl = XINT (tem);
+ if (FIXNUMP (tem)) mod_ctrl = XFIXNUM (tem);
tem = Fget (Vx_alt_keysym, Qmodifier_value);
- if (INTEGERP (tem)) mod_alt = XINT (tem);
+ if (FIXNUMP (tem)) mod_alt = XFIXNUM (tem);
tem = Fget (Vx_meta_keysym, Qmodifier_value);
- if (INTEGERP (tem)) mod_meta = XINT (tem);
+ if (FIXNUMP (tem)) mod_meta = XFIXNUM (tem);
tem = Fget (Vx_hyper_keysym, Qmodifier_value);
- if (INTEGERP (tem)) mod_hyper = XINT (tem);
+ if (FIXNUMP (tem)) mod_hyper = XFIXNUM (tem);
tem = Fget (Vx_super_keysym, Qmodifier_value);
- if (INTEGERP (tem)) mod_super = XINT (tem);
+ if (FIXNUMP (tem)) mod_super = XFIXNUM (tem);
return ( ((state & mod_alt) ? dpyinfo->alt_mod_mask : 0)
@@ -5267,7 +5343,7 @@ x_window_to_scroll_bar (Display *display, Window window_id, int type)
bar = XSCROLL_BAR (bar)->next)
if (XSCROLL_BAR (bar)->x_window == window_id
&& FRAME_X_DISPLAY (XFRAME (frame)) == display
- && (type = 2
+ && (type == 2
|| (type == 1 && XSCROLL_BAR (bar)->horizontal)
|| (type == 0 && !XSCROLL_BAR (bar)->horizontal)))
return XSCROLL_BAR (bar);
@@ -5508,8 +5584,8 @@ x_scroll_bar_to_input_event (const XEvent *event,
#endif
ievent->code = 0;
ievent->part = ev->data.l[2];
- ievent->x = make_number (ev->data.l[3]);
- ievent->y = make_number (ev->data.l[4]);
+ ievent->x = make_fixnum (ev->data.l[3]);
+ ievent->y = make_fixnum (ev->data.l[4]);
ievent->modifiers = 0;
}
@@ -5543,8 +5619,8 @@ x_horizontal_scroll_bar_to_input_event (const XEvent *event,
#endif
ievent->code = 0;
ievent->part = ev->data.l[2];
- ievent->x = make_number (ev->data.l[3]);
- ievent->y = make_number (ev->data.l[4]);
+ ievent->x = make_fixnum (ev->data.l[3]);
+ ievent->y = make_fixnum (ev->data.l[4]);
ievent->modifiers = 0;
}
@@ -6535,8 +6611,8 @@ x_scroll_bar_create (struct window *w, int top, int left,
int width, int height, bool horizontal)
{
struct frame *f = XFRAME (w->frame);
- struct scroll_bar *bar
- = ALLOCATE_PSEUDOVECTOR (struct scroll_bar, x_window, PVEC_OTHER);
+ struct scroll_bar *bar = ALLOCATE_PSEUDOVECTOR (struct scroll_bar, prev,
+ PVEC_OTHER);
Lisp_Object barobj;
block_input ();
@@ -8106,7 +8182,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
/* Redo the mouse-highlight after the tooltip has gone. */
if (event->xunmap.window == tip_window)
{
- tip_window = 0;
+ tip_window = None;
x_redo_mouse_highlight (dpyinfo);
}
@@ -8198,7 +8274,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
/* If mouse-highlight is an integer, input clears out
mouse highlighting. */
- if (!hlinfo->mouse_face_hidden && INTEGERP (Vmouse_highlight)
+ if (!hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight)
#if ! defined (USE_GTK)
&& (f == 0
|| !EQ (f->tool_bar_window, hlinfo->mouse_face_window))
@@ -8355,15 +8431,15 @@ handle_one_xevent (struct x_display_info *dpyinfo,
/* Now non-ASCII. */
if (HASH_TABLE_P (Vx_keysym_table)
- && (c = Fgethash (make_number (keysym),
+ && (c = Fgethash (make_fixnum (keysym),
Vx_keysym_table,
Qnil),
- NATNUMP (c)))
+ FIXNATP (c)))
{
- inev.ie.kind = (SINGLE_BYTE_CHAR_P (XFASTINT (c))
+ inev.ie.kind = (SINGLE_BYTE_CHAR_P (XFIXNAT (c))
? ASCII_KEYSTROKE_EVENT
: MULTIBYTE_CHAR_KEYSTROKE_EVENT);
- inev.ie.code = XFASTINT (c);
+ inev.ie.code = XFIXNAT (c);
goto done_keysym;
}
@@ -8748,7 +8824,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
#ifdef USE_X_TOOLKIT
/* Tip frames are pure X window, set size for them. */
- if (! NILP (tip_frame) && XFRAME (tip_frame) == f)
+ if (FRAME_TOOLTIP_P (f))
{
if (FRAME_PIXEL_HEIGHT (f) != configureEvent.xconfigure.height
|| FRAME_PIXEL_WIDTH (f) != configureEvent.xconfigure.width)
@@ -9819,7 +9895,7 @@ x_connection_closed (Display *dpy, const char *error_message, bool ioerror)
current Xt versions, this isn't needed either. */
#ifdef USE_GTK
/* A long-standing GTK bug prevents proper disconnect handling
- (https://gitlab.gnome.org/GNOME/gtk/issues/221). Once,
+ <https://gitlab.gnome.org/GNOME/gtk/issues/221>. Once,
the resulting Glib error message loop filled a user's disk.
To avoid this, kill Emacs unconditionally on disconnect. */
shut_down_emacs (0, Qnil);
@@ -9850,7 +9926,7 @@ For details, see etc/PROBLEMS.\n",
if (terminal_list == 0)
{
fprintf (stderr, "%s\n", error_msg);
- Fkill_emacs (make_number (70));
+ Fkill_emacs (make_fixnum (70));
/* NOTREACHED */
}
@@ -9932,7 +10008,6 @@ x_io_error_quitter (Display *display)
snprintf (buf, sizeof buf, "Connection lost to X server '%s'",
DisplayString (display));
x_connection_closed (display, buf, true);
- assume (false);
}
/* Changing the font of the frame. */
@@ -9986,11 +10061,7 @@ x_new_font (struct frame *f, Lisp_Object font_object, int fontset)
/* Don't change the size of a tip frame; there's no point in
doing it because it's done in Fx_show_tip, and it leads to
problems because the tip frame has no widget. */
- if (NILP (tip_frame) || XFRAME (tip_frame) != f
-#ifdef USE_GTK
- || NILP (Fframe_parameter (tip_frame, Qtooltip))
-#endif
- )
+ if (!FRAME_TOOLTIP_P (f))
{
adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f),
FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 3,
@@ -10255,8 +10326,8 @@ x_calc_absolute_position (struct frame *f)
XSETFRAME (frame, f);
edges = Fx_frame_edges (frame, Qouter_edges);
if (!NILP (edges))
- width = (XINT (Fnth (make_number (2), edges))
- - XINT (Fnth (make_number (0), edges)));
+ width = (XFIXNUM (Fnth (make_fixnum (2), edges))
+ - XFIXNUM (Fnth (make_fixnum (0), edges)));
}
if (p)
@@ -10297,8 +10368,8 @@ x_calc_absolute_position (struct frame *f)
if (NILP (edges))
edges = Fx_frame_edges (frame, Qouter_edges);
if (!NILP (edges))
- height = (XINT (Fnth (make_number (3), edges))
- - XINT (Fnth (make_number (1), edges)));
+ height = (XFIXNUM (Fnth (make_fixnum (3), edges))
+ - XFIXNUM (Fnth (make_fixnum (1), edges)));
}
if (p)
@@ -10502,16 +10573,16 @@ set_wm_state (Lisp_Object frame, bool add, Atom atom, Atom value)
{
struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (XFRAME (frame));
- x_send_client_event (frame, make_number (0), frame,
+ x_send_client_event (frame, make_fixnum (0), frame,
dpyinfo->Xatom_net_wm_state,
- make_number (32),
+ make_fixnum (32),
/* 1 = add, 0 = remove */
Fcons
- (make_number (add),
+ (make_fixnum (add),
Fcons
- (make_fixnum_or_float (atom),
+ (INT_TO_INTEGER (atom),
(value != 0
- ? list1 (make_fixnum_or_float (value))
+ ? list1 (INT_TO_INTEGER (value))
: Qnil))));
}
@@ -10639,14 +10710,14 @@ get_current_wm_state (struct frame *f,
#ifdef USE_XCB
xcb_get_property_cookie_t prop_cookie;
xcb_get_property_reply_t *prop;
- xcb_atom_t *reply_data;
+ xcb_atom_t *reply_data UNINIT;
#else
Display *dpy = FRAME_X_DISPLAY (f);
unsigned long bytes_remaining;
int rc, actual_format;
Atom actual_type;
unsigned char *tmp_data = NULL;
- Atom *reply_data;
+ Atom *reply_data UNINIT;
#endif
*sticky = false;
@@ -11140,8 +11211,7 @@ x_set_window_size_1 (struct frame *f, bool change_gravity,
{
frame_size_history_add
(f, Qx_set_window_size_1, width, height,
- list2 (make_number (old_height),
- make_number (pixelheight + FRAME_MENUBAR_HEIGHT (f))));
+ list2i (old_height, pixelheight + FRAME_MENUBAR_HEIGHT (f)));
XResizeWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f),
old_width, pixelheight + FRAME_MENUBAR_HEIGHT (f));
@@ -11150,7 +11220,7 @@ x_set_window_size_1 (struct frame *f, bool change_gravity,
{
frame_size_history_add
(f, Qx_set_window_size_2, width, height,
- list2 (make_number (old_width), make_number (pixelwidth)));
+ list2i (old_width, pixelwidth));
XResizeWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f),
pixelwidth, old_height);
@@ -11160,10 +11230,10 @@ x_set_window_size_1 (struct frame *f, bool change_gravity,
{
frame_size_history_add
(f, Qx_set_window_size_3, width, height,
- list3 (make_number (pixelwidth + FRAME_TOOLBAR_WIDTH (f)),
- make_number (pixelheight + FRAME_TOOLBAR_HEIGHT (f)
- + FRAME_MENUBAR_HEIGHT (f)),
- make_number (FRAME_MENUBAR_HEIGHT (f))));
+ list3i (pixelwidth + FRAME_TOOLBAR_WIDTH (f),
+ (pixelheight + FRAME_TOOLBAR_HEIGHT (f)
+ + FRAME_MENUBAR_HEIGHT (f)),
+ FRAME_MENUBAR_HEIGHT (f)));
XResizeWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f),
pixelwidth, pixelheight + FRAME_MENUBAR_HEIGHT (f));
@@ -11228,7 +11298,7 @@ x_set_window_size (struct frame *f, bool change_gravity,
/* The following breaks our calculations. If it's really needed,
think of something else. */
#if false
- if (NILP (tip_frame) || XFRAME (tip_frame) != f)
+ if (!FRAME_TOOLTIP_P (f))
{
int text_width, text_height;
@@ -11347,9 +11417,9 @@ x_ewmh_activate_frame (struct frame *f)
{
Lisp_Object frame;
XSETFRAME (frame, f);
- x_send_client_event (frame, make_number (0), frame,
+ x_send_client_event (frame, make_fixnum (0), frame,
dpyinfo->Xatom_net_active_window,
- make_number (32),
+ make_fixnum (32),
list2i (1, dpyinfo->last_user_time));
}
}
@@ -13260,6 +13330,7 @@ void
syms_of_xterm (void)
{
x_error_message = NULL;
+ PDUMPER_IGNORE (x_error_message);
DEFSYM (Qvendor_specific_keysyms, "vendor-specific-keysyms");
DEFSYM (Qlatin_1, "latin-1");
@@ -13275,11 +13346,12 @@ syms_of_xterm (void)
x_use_underline_position_properties,
doc: /* Non-nil means make use of UNDERLINE_POSITION font properties.
A value of nil means ignore them. If you encounter fonts with bogus
-UNDERLINE_POSITION font properties, for example 7x13 on XFree prior
-to 4.1, set this to nil. You can also use `underline-minimum-offset'
-to override the font's UNDERLINE_POSITION for small font display
-sizes. */);
+UNDERLINE_POSITION font properties, set this to nil. You can also use
+`underline-minimum-offset' to override the font's UNDERLINE_POSITION for
+small font display sizes. */);
x_use_underline_position_properties = true;
+ DEFSYM (Qx_use_underline_position_properties,
+ "x-use-underline-position-properties");
DEFVAR_BOOL ("x-underline-at-descent-line",
x_underline_at_descent_line,
@@ -13290,6 +13362,7 @@ A value of nil means to draw the underline according to the value of the
variable `x-use-underline-position-properties', which is usually at the
baseline level. The default value is nil. */);
x_underline_at_descent_line = false;
+ DEFSYM (Qx_underline_at_descent_line, "x-underline-at-descent-line");
DEFVAR_BOOL ("x-mouse-click-focus-ignore-position",
x_mouse_click_focus_ignore_position,
@@ -13323,15 +13396,15 @@ With MS Windows or Nextstep, the value is t. */);
DEFSYM (Qmodifier_value, "modifier-value");
DEFSYM (Qctrl, "ctrl");
- Fput (Qctrl, Qmodifier_value, make_number (ctrl_modifier));
+ Fput (Qctrl, Qmodifier_value, make_fixnum (ctrl_modifier));
DEFSYM (Qalt, "alt");
- Fput (Qalt, Qmodifier_value, make_number (alt_modifier));
+ Fput (Qalt, Qmodifier_value, make_fixnum (alt_modifier));
DEFSYM (Qhyper, "hyper");
- Fput (Qhyper, Qmodifier_value, make_number (hyper_modifier));
+ Fput (Qhyper, Qmodifier_value, make_fixnum (hyper_modifier));
DEFSYM (Qmeta, "meta");
- Fput (Qmeta, Qmodifier_value, make_number (meta_modifier));
+ Fput (Qmeta, Qmodifier_value, make_fixnum (meta_modifier));
DEFSYM (Qsuper, "super");
- Fput (Qsuper, Qmodifier_value, make_number (super_modifier));
+ Fput (Qsuper, Qmodifier_value, make_fixnum (super_modifier));
DEFVAR_LISP ("x-ctrl-keysym", Vx_ctrl_keysym,
doc: /* Which keys Emacs uses for the ctrl modifier.
diff --git a/src/xterm.h b/src/xterm.h
index 411a5567cc0..c5ad38650c2 100644
--- a/src/xterm.h
+++ b/src/xterm.h
@@ -503,6 +503,8 @@ extern bool x_display_ok (const char *);
extern void select_visual (struct x_display_info *);
+extern Window tip_window;
+
/* Each X frame object points to its own struct x_output object
in the output_data.x field. The x_output structure contains
the information that is specific to X windows. */
@@ -895,7 +897,7 @@ struct scroll_bar
/* The next and previous in the chain of scroll bars in this frame. */
Lisp_Object next, prev;
- /* Fields from `x_window' down will not be traced by the GC. */
+ /* Fields after 'prev' are not traced by the GC. */
/* The X window representing this scroll bar. */
Window x_window;
@@ -935,7 +937,7 @@ struct scroll_bar
/* True if the scroll bar is horizontal. */
bool horizontal;
-};
+} GCALIGNED_STRUCT;
/* Turning a lisp vector value into a pointer to a struct scroll_bar. */
#define XSCROLL_BAR(vec) ((struct scroll_bar *) XVECTOR (vec))
diff --git a/src/xwidget.c b/src/xwidget.c
index fcd2a0e4b96..2486a2d4da8 100644
--- a/src/xwidget.c
+++ b/src/xwidget.c
@@ -30,17 +30,24 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <webkit2/webkit2.h>
#include <JavaScriptCore/JavaScript.h>
+/* Suppress GCC deprecation warnings starting in WebKitGTK+ 2.21.1 for
+ webkit_javascript_result_get_global_context and
+ webkit_javascript_result_get_value (Bug#33679).
+ FIXME: Use the JavaScriptCore GLib API instead, and remove this hack. */
+#if WEBKIT_CHECK_VERSION (2, 21, 1) && GNUC_PREREQ (4, 2, 0)
+# pragma GCC diagnostic ignored "-Wdeprecated-declarations"
+#endif
+
static struct xwidget *
allocate_xwidget (void)
{
- return ALLOCATE_PSEUDOVECTOR (struct xwidget, height, PVEC_XWIDGET);
+ return ALLOCATE_PSEUDOVECTOR (struct xwidget, script_callbacks, PVEC_XWIDGET);
}
static struct xwidget_view *
allocate_xwidget_view (void)
{
- return ALLOCATE_PSEUDOVECTOR (struct xwidget_view, redisplayed,
- PVEC_XWIDGET_VIEW);
+ return ALLOCATE_PSEUDOVECTOR (struct xwidget_view, w, PVEC_XWIDGET_VIEW);
}
#define XSETXWIDGET(a, b) XSETPSEUDOVECTOR (a, b, PVEC_XWIDGET)
@@ -81,16 +88,16 @@ Returns the newly constructed xwidget, or nil if construction fails. */)
if (!xg_gtk_initialized)
error ("make-xwidget: GTK has not been initialized");
CHECK_SYMBOL (type);
- CHECK_NATNUM (width);
- CHECK_NATNUM (height);
+ CHECK_FIXNAT (width);
+ CHECK_FIXNAT (height);
struct xwidget *xw = allocate_xwidget ();
Lisp_Object val;
xw->type = type;
xw->title = title;
xw->buffer = NILP (buffer) ? Fcurrent_buffer () : Fget_buffer_create (buffer);
- xw->height = XFASTINT (height);
- xw->width = XFASTINT (width);
+ xw->height = XFIXNAT (height);
+ xw->width = XFIXNAT (width);
xw->kill_without_query = false;
XSETXWIDGET (val, xw);
Vxwidget_list = Fcons (val, Vxwidget_list);
@@ -296,17 +303,21 @@ webkit_js_to_lisp (JSContextRef context, JSValueRef value)
case kJSTypeBoolean:
return (JSValueToBoolean (context, value)) ? Qt : Qnil;
case kJSTypeNumber:
- return make_number (JSValueToNumber (context, value, NULL));
+ return make_fixnum (JSValueToNumber (context, value, NULL));
case kJSTypeObject:
{
if (JSValueIsArray (context, value))
{
JSStringRef pname = JSStringCreateWithUTF8CString("length");
- JSValueRef len = JSObjectGetProperty (context, (JSObjectRef) value, pname, NULL);
- EMACS_INT n = JSValueToNumber (context, len, NULL);
+ JSValueRef len = JSObjectGetProperty (context, (JSObjectRef) value,
+ pname, NULL);
+ double dlen = JSValueToNumber (context, len, NULL);
JSStringRelease(pname);
Lisp_Object obj;
+ if (! (0 <= dlen && dlen < PTRDIFF_MAX + 1.0))
+ memory_full (SIZE_MAX);
+ ptrdiff_t n = dlen;
struct Lisp_Vector *p = allocate_vector (n);
for (ptrdiff_t i = 0; i < n; ++i)
@@ -325,10 +336,12 @@ webkit_js_to_lisp (JSContextRef context, JSValueRef value)
JSPropertyNameArrayRef properties =
JSObjectCopyPropertyNames (context, (JSObjectRef) value);
- ptrdiff_t n = JSPropertyNameArrayGetCount (properties);
+ size_t n = JSPropertyNameArrayGetCount (properties);
Lisp_Object obj;
/* TODO: can we use a regular list here? */
+ if (PTRDIFF_MAX < n)
+ memory_full (n);
struct Lisp_Vector *p = allocate_vector (n);
for (ptrdiff_t i = 0; i < n; ++i)
@@ -364,7 +377,7 @@ webkit_js_to_lisp (JSContextRef context, JSValueRef value)
static void
webkit_javascript_finished_cb (GObject *webview,
GAsyncResult *result,
- gpointer lisp_callback)
+ gpointer arg)
{
WebKitJavascriptResult *js_result;
JSValueRef value;
@@ -372,6 +385,11 @@ webkit_javascript_finished_cb (GObject *webview,
GError *error = NULL;
struct xwidget *xw = g_object_get_data (G_OBJECT (webview),
XG_XWIDGET);
+ ptrdiff_t script_idx = (intptr_t) arg;
+ Lisp_Object script_callback = AREF (xw->script_callbacks, script_idx);
+ ASET (xw->script_callbacks, script_idx, Qnil);
+ if (!NILP (script_callback))
+ xfree (xmint_pointer (XCAR (script_callback)));
js_result = webkit_web_view_run_javascript_finish
(WEBKIT_WEB_VIEW (webview), result, &error);
@@ -383,19 +401,19 @@ webkit_javascript_finished_cb (GObject *webview,
return;
}
- context = webkit_javascript_result_get_global_context (js_result);
- value = webkit_javascript_result_get_value (js_result);
- Lisp_Object lisp_value = webkit_js_to_lisp (context, value);
- webkit_javascript_result_unref (js_result);
+ if (!NILP (script_callback) && !NILP (XCDR (script_callback)))
+ {
+ context = webkit_javascript_result_get_global_context (js_result);
+ value = webkit_javascript_result_get_value (js_result);
+ Lisp_Object lisp_value = webkit_js_to_lisp (context, value);
+
+ /* Register an xwidget event here, which then runs the callback.
+ This ensures that the callback runs in sync with the Emacs
+ event loop. */
+ store_xwidget_js_callback_event (xw, XCDR (script_callback), lisp_value);
+ }
- /* Register an xwidget event here, which then runs the callback.
- This ensures that the callback runs in sync with the Emacs
- event loop. */
- /* FIXME: This might lead to disaster if LISP_CALLBACK's object
- was garbage collected before now. See the FIXME in
- Fxwidget_webkit_execute_script. */
- store_xwidget_js_callback_event (xw, XIL ((intptr_t) lisp_callback),
- lisp_value);
+ webkit_javascript_result_unref (js_result);
}
@@ -591,22 +609,20 @@ x_draw_xwidget_glyph_string (struct glyph_string *s)
xwidget on screen. Moving and clipping is done here. Also view
initialization. */
struct xwidget *xww = s->xwidget;
- struct xwidget_view *xv;
+ struct xwidget_view *xv = xwidget_view_lookup (xww, s->w);
int clip_right;
int clip_bottom;
int clip_top;
int clip_left;
- /* FIXME: The result of this call is discarded.
- What if the lookup fails? */
- xwidget_view_lookup (xww, s->w);
-
int x = s->x;
int y = s->y + (s->height / 2) - (xww->height / 2);
/* Do initialization here in the display loop because there is no
- other time to know things like window placement etc. */
- xv = xwidget_init_view (xww, s, x, y);
+ other time to know things like window placement etc. Do not
+ create a new view if we have found one that is usable. */
+ if (!xv)
+ xv = xwidget_init_view (xww, s, x, y);
int text_area_x, text_area_y, text_area_width, text_area_height;
@@ -686,6 +702,7 @@ DEFUN ("xwidget-webkit-goto-uri",
{
WEBKIT_FN_INIT ();
CHECK_STRING (uri);
+ uri = ENCODE_FILE (uri);
webkit_web_view_load_uri (WEBKIT_WEB_VIEW (xw->widget_osr), SSDATA (uri));
return Qnil;
}
@@ -693,8 +710,7 @@ DEFUN ("xwidget-webkit-goto-uri",
DEFUN ("xwidget-webkit-zoom",
Fxwidget_webkit_zoom, Sxwidget_webkit_zoom,
2, 2, 0,
- doc: /* Change the zoom factor of the xwidget webkit instance
-referenced by XWIDGET. */)
+ doc: /* Change the zoom factor of the xwidget webkit instance referenced by XWIDGET. */)
(Lisp_Object xwidget, Lisp_Object factor)
{
WEBKIT_FN_INIT ();
@@ -709,12 +725,33 @@ referenced by XWIDGET. */)
return Qnil;
}
+/* Save script and fun in the script/callback save vector and return
+ its index. */
+static ptrdiff_t
+save_script_callback (struct xwidget *xw, Lisp_Object script, Lisp_Object fun)
+{
+ Lisp_Object cbs = xw->script_callbacks;
+ if (NILP (cbs))
+ xw->script_callbacks = cbs = make_nil_vector (32);
+
+ /* Find first free index. */
+ ptrdiff_t idx;
+ for (idx = 0; !NILP (AREF (cbs, idx)); idx++)
+ if (idx + 1 == ASIZE (cbs))
+ {
+ xw->script_callbacks = cbs = larger_vector (cbs, 1, -1);
+ break;
+ }
+
+ ASET (cbs, idx, Fcons (make_mint_ptr (xlispstrdup (script)), fun));
+ return idx;
+}
DEFUN ("xwidget-webkit-execute-script",
Fxwidget_webkit_execute_script, Sxwidget_webkit_execute_script,
2, 3, 0,
- doc: /* Make the Webkit XWIDGET execute JavaScript SCRIPT. If
-FUN is provided, feed the JavaScript return value to the single
+ doc: /* Make the Webkit XWIDGET execute JavaScript SCRIPT.
+If FUN is provided, feed the JavaScript return value to the single
argument procedure FUN.*/)
(Lisp_Object xwidget, Lisp_Object script, Lisp_Object fun)
{
@@ -723,36 +760,34 @@ argument procedure FUN.*/)
if (!NILP (fun) && !FUNCTIONP (fun))
wrong_type_argument (Qinvalid_function, fun);
- GAsyncReadyCallback callback
- = FUNCTIONP (fun) ? webkit_javascript_finished_cb : NULL;
+ script = ENCODE_SYSTEM (script);
- /* FIXME: The following hack assumes USE_LSB_TAG. */
- verify (USE_LSB_TAG);
- /* FIXME: This hack might lead to disaster if FUN is garbage
- collected before store_xwidget_js_callback_event makes it visible
- to Lisp again. See the FIXME in webkit_javascript_finished_cb. */
- gpointer callback_arg = (gpointer) (intptr_t) XLI (fun);
+ /* Protect script and fun during GC. */
+ intptr_t idx = save_script_callback (xw, script, fun);
/* JavaScript execution happens asynchronously. If an elisp
callback function is provided we pass it to the C callback
procedure that retrieves the return value. */
+ gchar *script_string
+ = xmint_pointer (XCAR (AREF (xw->script_callbacks, idx)));
webkit_web_view_run_javascript (WEBKIT_WEB_VIEW (xw->widget_osr),
- SSDATA (script),
+ script_string,
NULL, /* cancelable */
- callback, callback_arg);
+ webkit_javascript_finished_cb,
+ (gpointer) idx);
return Qnil;
}
DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0,
- doc: /* Resize XWIDGET. NEW_WIDTH, NEW_HEIGHT define the new size. */ )
+ doc: /* Resize XWIDGET to NEW_WIDTH, NEW_HEIGHT. */ )
(Lisp_Object xwidget, Lisp_Object new_width, Lisp_Object new_height)
{
CHECK_XWIDGET (xwidget);
CHECK_RANGED_INTEGER (new_width, 0, INT_MAX);
CHECK_RANGED_INTEGER (new_height, 0, INT_MAX);
struct xwidget *xw = XXWIDGET (xwidget);
- int w = XFASTINT (new_width);
- int h = XFASTINT (new_height);
+ int w = XFIXNAT (new_width);
+ int h = XFIXNAT (new_height);
xw->width = w;
xw->height = h;
@@ -795,8 +830,7 @@ Emacs allocated area accordingly. */)
CHECK_XWIDGET (xwidget);
GtkRequisition requisition;
gtk_widget_size_request (XXWIDGET (xwidget)->widget_osr, &requisition);
- return list2 (make_number (requisition.width),
- make_number (requisition.height));
+ return list2i (requisition.width, requisition.height);
}
DEFUN ("xwidgetp",
@@ -827,7 +861,7 @@ Currently [TYPE TITLE WIDTH HEIGHT]. */)
CHECK_XWIDGET (xwidget);
struct xwidget *xw = XXWIDGET (xwidget);
return CALLN (Fvector, xw->type, xw->title,
- make_natnum (xw->width), make_natnum (xw->height));
+ make_fixed_natnum (xw->width), make_fixed_natnum (xw->height));
}
DEFUN ("xwidget-view-info",
@@ -839,9 +873,9 @@ Currently [X Y CLIP_RIGHT CLIP_BOTTOM CLIP_TOP CLIP_LEFT]. */)
{
CHECK_XWIDGET_VIEW (xwidget_view);
struct xwidget_view *xv = XXWIDGET_VIEW (xwidget_view);
- return CALLN (Fvector, make_number (xv->x), make_number (xv->y),
- make_number (xv->clip_right), make_number (xv->clip_bottom),
- make_number (xv->clip_top), make_number (xv->clip_left));
+ return CALLN (Fvector, make_fixnum (xv->x), make_fixnum (xv->y),
+ make_fixnum (xv->clip_right), make_fixnum (xv->clip_bottom),
+ make_fixnum (xv->clip_top), make_fixnum (xv->clip_left));
}
DEFUN ("xwidget-view-model",
@@ -1081,7 +1115,7 @@ xwidget_view_lookup (struct xwidget *xw, struct window *w)
ret = Fxwidget_view_lookup (xwidget, window);
- return EQ (ret, Qnil) ? NULL : XXWIDGET_VIEW (ret);
+ return NILP (ret) ? NULL : XXWIDGET_VIEW (ret);
}
struct xwidget *
@@ -1204,6 +1238,14 @@ kill_buffer_xwidgets (Lisp_Object buffer)
gtk_widget_destroy (xw->widget_osr);
gtk_widget_destroy (xw->widgetwindow_osr);
}
+ if (!NILP (xw->script_callbacks))
+ for (ptrdiff_t idx = 0; idx < ASIZE (xw->script_callbacks); idx++)
+ {
+ Lisp_Object cb = AREF (xw->script_callbacks, idx);
+ if (!NILP (cb))
+ xfree (xmint_pointer (XCAR (cb)));
+ ASET (xw->script_callbacks, idx, Qnil);
+ }
}
}
}
diff --git a/src/xwidget.h b/src/xwidget.h
index 1a742318271..1b6368daabf 100644
--- a/src/xwidget.h
+++ b/src/xwidget.h
@@ -47,7 +47,9 @@ struct xwidget
/* A title used for button labels, for instance. */
Lisp_Object title;
- /* Here ends the Lisp part. "height" is the marker field. */
+ /* Vector of currently executing scripts with callbacks. */
+ Lisp_Object script_callbacks;
+ /* Here ends the Lisp part. script_callbacks is the marker field. */
int height;
int width;
@@ -58,15 +60,14 @@ struct xwidget
/* Kill silently if Emacs is exited. */
bool_bf kill_without_query : 1;
-};
+} GCALIGNED_STRUCT;
struct xwidget_view
{
union vectorlike_header header;
Lisp_Object model;
Lisp_Object w;
-
- /* Here ends the lisp part. "redisplayed" is the marker field. */
+ /* Here ends the lisp part. "w" is the marker field. */
/* If touched by redisplay. */
bool redisplayed;
@@ -85,13 +86,13 @@ struct xwidget_view
int clip_left;
long handler_id;
-};
+} GCALIGNED_STRUCT;
#endif
/* Test for xwidget pseudovector. */
#define XWIDGETP(x) PSEUDOVECTORP (x, PVEC_XWIDGET)
#define XXWIDGET(a) (eassert (XWIDGETP (a)), \
- (struct xwidget *) XUNTAG (a, Lisp_Vectorlike))
+ XUNTAG (a, Lisp_Vectorlike, struct xwidget))
#define CHECK_XWIDGET(x) \
CHECK_TYPE (XWIDGETP (x), Qxwidgetp, x)
@@ -99,7 +100,7 @@ struct xwidget_view
/* Test for xwidget_view pseudovector. */
#define XWIDGET_VIEW_P(x) PSEUDOVECTORP (x, PVEC_XWIDGET_VIEW)
#define XXWIDGET_VIEW(a) (eassert (XWIDGET_VIEW_P (a)), \
- (struct xwidget_view *) XUNTAG (a, Lisp_Vectorlike))
+ XUNTAG (a, Lisp_Vectorlike, struct xwidget_view))
#define CHECK_XWIDGET_VIEW(x) \
CHECK_TYPE (XWIDGET_VIEW_P (x), Qxwidget_view_p, x)
diff --git a/test/Makefile.in b/test/Makefile.in
index 481c418787a..ce6ce04b8be 100644
--- a/test/Makefile.in
+++ b/test/Makefile.in
@@ -105,16 +105,19 @@ endif
# Whether to run tests from .el files in preference to .elc, we do
# this by default since it gives nicer stacktraces.
-TEST_LOAD_EL ?= yes
+# If you just want a pass/fail, setting this to no is much faster.
+export TEST_LOAD_EL ?= \
+ $(if $(findstring $(MAKECMDGOALS), all check check-maybe),no,yes)
+
+# Additional settings for ert.
+ert_opts =
# Maximum length of lines in ert backtraces; nil for no limit.
# (if empty, use the default ert-batch-backtrace-right-margin).
TEST_BACKTRACE_LINE_LENGTH =
-ifeq (${TEST_BACKTRACE_LINE_LENGTH},)
-ert_opts =
-else
-ert_opts = --eval '(setq ert-batch-backtrace-right-margin ${TEST_BACKTRACE_LINE_LENGTH})'
+ifneq (${TEST_BACKTRACE_LINE_LENGTH},)
+ert_opts += --eval '(setq ert-batch-backtrace-right-margin ${TEST_BACKTRACE_LINE_LENGTH})'
endif
ifeq (@HAVE_MODULES@, yes)
@@ -134,7 +137,7 @@ emacs = EMACSLOADPATH= LC_ALL=$(TEST_LOCALE) \
# exists, or writing to ~/.bzr.log when running bzr commands).
TEST_HOME = /nonexistent
-test_module_dir := $(srcdir)/data/emacs-module
+test_module_dir := data/emacs-module
.PHONY: all check
@@ -163,6 +166,11 @@ endif
## Save logs, and show logs for failed tests.
WRITE_LOG = > $@ 2>&1 || { STAT=$$?; cat $@; exit $$STAT; }
+ifdef EMACS_HYDRA_CI
+## On Hydra, always show logs for certain problematic tests.
+lisp/net/tramp-tests.log \
+: WRITE_LOG = 2>&1 | tee $@
+endif
ifeq ($(TEST_LOAD_EL), yes)
testloadfile = $*.el
@@ -182,11 +190,26 @@ else
maybe_exclude_module_tests := -name emacs-module-tests.el -prune -o
endif
+## Optional list of .el files to exclude from testing.
+## Intended for use in automated testing where one or more files
+## has some problem and needs to be excluded.
+## To avoid writing full name, can use eg %foo-tests.el.
+EXCLUDE_TESTS =
+
+## To speed up parallel builds, put these slow test files (which can
+## take longer than all the rest combined) at the start of the list.
+SLOW_TESTS = ${srcdir}/lisp/net/tramp-tests.el
+
ELFILES := $(sort $(shell find ${srcdir} -path "${srcdir}/manual" -prune -o \
-path "${srcdir}/data" -prune -o \
-name "*resources" -prune -o \
${maybe_exclude_module_tests} \
-name "*.el" ! -name ".*" -print))
+
+$(foreach slow,${SLOW_TESTS},$(eval ELFILES:= ${slow} $(filter-out ${slow},${ELFILES})))
+
+$(foreach exclude,${EXCLUDE_TESTS},$(eval ELFILES:= $(filter-out ${exclude},${ELFILES})))
+
## .log files may be in a different directory for out of source builds
LOGFILES := $(patsubst %.el,%.log, \
$(patsubst $(srcdir)/%,%,$(ELFILES)))
@@ -231,16 +254,21 @@ else
FPIC_CFLAGS = -fPIC
endif
+HYBRID_MALLOC = @HYBRID_MALLOC@
+LIBEGNU_ARCHIVE = ../lib/lib$(if $(HYBRID_MALLOC),e)gnu.a
+
# Note: emacs-module.h is generated from emacs-module.h.in, hence we
# look in ../src, not $(srcdir)/../src.
-MODULE_CFLAGS = -I../src $(FPIC_CFLAGS) $(PROFILING_CFLAGS) \
+MODULE_CFLAGS = -I../src -I$(srcdir)/../lib \
+ $(FPIC_CFLAGS) $(PROFILING_CFLAGS) \
$(WARN_CFLAGS) $(WERROR_CFLAGS) $(CFLAGS)
test_module = $(test_module_dir)/mod-test${SO}
src/emacs-module-tests.log: $(test_module)
-$(test_module): $(test_module:${SO}=.c) ../src/emacs-module.h
+$(test_module): $(test_module:${SO}=.c) ../src/emacs-module.h $(LIBEGNU_ARCHIVE)
+ $(AM_V_at)${MKDIR_P} $(dir $@)
$(AM_V_CCLD)$(CC) -shared $(CPPFLAGS) $(MODULE_CFLAGS) $(LDFLAGS) \
- -o $@ $<
+ -o $@ $< $(LIBEGNU_ARCHIVE)
endif
## Check that there is no 'automated' subdirectory, which would
@@ -283,14 +311,15 @@ ifeq ($(TEST_INTERACTIVE), yes)
$(TEST_RUN_ERT)
else
-@${MAKE} -k ${LOGFILES}
- @$(emacs) --batch -l ert -f ert-summarize-tests-batch-and-exit ${LOGFILES}
+ @$(emacs) --batch -l ert --eval \
+ "(ert-summarize-tests-batch-and-exit ${SUMMARIZE_TESTS})" ${LOGFILES}
endif
.PHONY: mostlyclean clean bootstrap-clean distclean maintainer-clean
mostlyclean:
-@for f in ${LOGFILES}; do test ! -f $$f || mv $$f $$f~; done
- rm -f *.tmp
+ rm -f ./*.tmp
clean:
find . '(' -name '*.log' -o -name '*.log~' ')' $(FIND_DELETE)
@@ -304,3 +333,9 @@ distclean: clean
rm -f Makefile
maintainer-clean: distclean bootstrap-clean
+
+.PHONY: check-declare
+
+check-declare:
+ $(emacs) -l check-declare \
+ --eval '(check-declare-directory "$(srcdir)")'
diff --git a/test/README b/test/README
index fa5611bdd53..cd6905d7ebf 100644
--- a/test/README
+++ b/test/README
@@ -11,12 +11,23 @@ Emacs uses ERT, Emacs Lisp Regression Testing, for testing. See (info
"(ert)") or https://www.gnu.org/software/emacs/manual/html_node/ert/
for more information on writing and running tests.
+Tests could be tagged by the developer. In this test directory, the
+following tags are recognized:
+
+* :expensive-test
+ The test needs a serious amount of time to run. It is not intended
+ to run on a regular basis by users. Instead, it runs on demand
+ only, or during regression tests.
+
+* :unstable
+ The test is under development. It shall run on demand only.
+
The Makefile in this directory supports the following targets:
* make check
- Run all tests as defined in the directory. Expensive tests are
- suppressed. The result of the tests for <filename>.el is stored in
- <filename>.log.
+ Run all tests as defined in the directory. Expensive and unstable
+ tests are suppressed. The result of the tests for <filename>.el is
+ stored in <filename>.log.
* make check-maybe
Like "make check", but run only the tests for files which have
@@ -25,6 +36,9 @@ The Makefile in this directory supports the following targets:
* make check-expensive
Like "make check", but run also the tests marked as expensive.
+* make check-all
+ Like "make check", but run all tests.
+
* make <filename> or make <filename>.log
Run all tests declared in <filename>.el. This includes expensive
tests. In the former case the output is shown on the terminal, in
@@ -38,7 +52,7 @@ https://www.gnu.org/software/emacs/manual/html_node/ert/Test-Selectors.html
You could use predefined selectors of the Makefile. "make <filename>
SELECTOR='$(SELECTOR_DEFAULT)'" runs all tests for <filename>.el
-except the tests tagged as expensive.
+except the tests tagged as expensive or unstable.
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
@@ -48,11 +62,17 @@ protect against "make" variable expansion):
make <filename> SELECTOR='"foo$$"'
Note that although the test files are always compiled (unless they set
-no-byte-compile), the source files will be run by default, to give
-nicer backtraces. To run the compiled version of a test use
+no-byte-compile), the source files will be run when expensive or
+unstable tests are involved, to give nicer backtraces. To run the
+compiled version of a test use
make TEST_LOAD_EL=no ...
+Some tests might take long time to run. In order to summarize the
+<nn> tests with the longest duration, call
+
+ make SUMMARIZE_TESTS=<nn> ...
+
The tests are run in batch mode by default; sometimes it's useful to
get precisely the same environment but run in interactive mode for
debugging. To do that, use
@@ -69,6 +89,16 @@ value in order to overwrite the default value:
env REMOTE_TEMPORARY_FILE_DIRECTORY=/ssh:host:/tmp make ...
+There are also continuous integration tests on
+<https://hydra.nixos.org/jobset/gnu/emacs-trunk> (see
+admin/notes/hydra) and <https://emba.gnu.org/emacs/emacs>. Both
+environments provide an environment variable, which could be used to
+determine, whether the tests run in one of these test environments.
+
+$EMACS_HYDRA_CI indicates the hydra environment, and $EMACS_EMBA_CI
+indicates the emba environment, respectively.
+
+
(Also, see etc/compilation.txt for compilation mode font lock tests.)
diff --git a/test/data/decompress/tg.tar.gz b/test/data/decompress/tg.tar.gz
new file mode 100644
index 00000000000..3dc8185f56e
--- /dev/null
+++ b/test/data/decompress/tg.tar.gz
Binary files differ
diff --git a/test/data/decompress/zg.zip b/test/data/decompress/zg.zip
new file mode 100644
index 00000000000..c4c998ee63d
--- /dev/null
+++ b/test/data/decompress/zg.zip
Binary files differ
diff --git a/test/data/emacs-module/mod-test.c b/test/data/emacs-module/mod-test.c
index 30dc4fd9245..a39e41afee6 100644
--- a/test/data/emacs-module/mod-test.c
+++ b/test/data/emacs-module/mod-test.c
@@ -17,12 +17,20 @@ 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 <https://www.gnu.org/licenses/>. */
+#include "config.h"
+
#include <assert.h>
+#include <errno.h>
+#include <limits.h>
#include <stdio.h>
#include <stdlib.h>
-#include <limits.h>
+#include <string.h>
+#include <time.h>
+
#include <emacs-module.h>
+#include "timespec.h"
+
int plugin_is_GPL_compatible;
#if INTPTR_MAX <= 0
@@ -86,7 +94,7 @@ Fmod_test_signal (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
assert (env->non_local_exit_check (env) == emacs_funcall_exit_return);
env->non_local_exit_signal (env, env->intern (env, "error"),
env->make_integer (env, 56));
- return env->intern (env, "nil");
+ return NULL;
}
@@ -98,7 +106,7 @@ Fmod_test_throw (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
assert (env->non_local_exit_check (env) == emacs_funcall_exit_return);
env->non_local_exit_throw (env, env->intern (env, "tag"),
env->make_integer (env, 65));
- return env->intern (env, "nil");
+ return NULL;
}
@@ -296,9 +304,67 @@ Fmod_test_invalid_finalizer (emacs_env *env, ptrdiff_t nargs, emacs_value *args,
{
current_env = env;
env->make_user_ptr (env, invalid_finalizer, NULL);
- return env->funcall (env, env->intern (env, "garbage-collect"), 0, NULL);
+ return env->intern (env, "nil");
+}
+
+static void
+signal_wrong_type_argument (emacs_env *env, const char *predicate,
+ emacs_value arg)
+{
+ emacs_value symbol = env->intern (env, "wrong-type-argument");
+ emacs_value elements[2] = {env->intern (env, predicate), arg};
+ emacs_value data = env->funcall (env, env->intern (env, "list"), 2, elements);
+ env->non_local_exit_signal (env, symbol, data);
}
+static void
+signal_errno (emacs_env *env, const char *function)
+{
+ const char *message = strerror (errno);
+ emacs_value message_value = env->make_string (env, message, strlen (message));
+ emacs_value symbol = env->intern (env, "file-error");
+ emacs_value elements[2]
+ = {env->make_string (env, function, strlen (function)), message_value};
+ emacs_value data = env->funcall (env, env->intern (env, "list"), 2, elements);
+ env->non_local_exit_signal (env, symbol, data);
+}
+
+/* A long-running operation that occasionally calls `should_quit' or
+ `process_input'. */
+
+static emacs_value
+Fmod_test_sleep_until (emacs_env *env, ptrdiff_t nargs, emacs_value *args,
+ void *data)
+{
+ assert (nargs == 2);
+ const double until_seconds = env->extract_float (env, args[0]);
+ if (env->non_local_exit_check (env))
+ return NULL;
+ if (until_seconds <= 0)
+ {
+ signal_wrong_type_argument (env, "cl-plusp", args[0]);
+ return NULL;
+ }
+ const bool process_input = env->is_not_nil (env, args[1]);
+ const struct timespec until = dtotimespec (until_seconds);
+ const struct timespec amount = make_timespec(0, 10000000);
+ while (true)
+ {
+ const struct timespec now = current_timespec ();
+ if (timespec_cmp (now, until) >= 0)
+ break;
+ if (nanosleep (&amount, NULL) && errno != EINTR)
+ {
+ signal_errno (env, "nanosleep");
+ return NULL;
+ }
+ if ((process_input
+ && env->process_input (env) == emacs_process_input_quit)
+ || env->should_quit (env))
+ return NULL;
+ }
+ return env->intern (env, "finished");
+}
/* Lisp utilities for easier readability (simple wrappers). */
@@ -317,11 +383,11 @@ provide (emacs_env *env, const char *feature)
static void
bind_function (emacs_env *env, const char *name, emacs_value Sfun)
{
- emacs_value Qfset = env->intern (env, "fset");
+ emacs_value Qdefalias = env->intern (env, "defalias");
emacs_value Qsym = env->intern (env, name);
emacs_value args[] = { Qsym, Sfun };
- env->funcall (env, Qfset, 2, args);
+ env->funcall (env, Qdefalias, 2, args);
}
/* Module init function. */
@@ -367,6 +433,7 @@ emacs_module_init (struct emacs_runtime *ert)
DEFUN ("mod-test-invalid-load", Fmod_test_invalid_load, 0, 0, NULL, NULL);
DEFUN ("mod-test-invalid-finalizer", Fmod_test_invalid_finalizer, 0, 0,
NULL, NULL);
+ DEFUN ("mod-test-sleep-until", Fmod_test_sleep_until, 2, 2, NULL, NULL);
#undef DEFUN
diff --git a/test/data/shr/ol.html b/test/data/shr/ol.html
new file mode 100644
index 00000000000..f9a15f26409
--- /dev/null
+++ b/test/data/shr/ol.html
@@ -0,0 +1,29 @@
+<ol>
+ <li>one</li>
+ <li>two</li>
+ <li>three</li>
+</ol>
+
+<ol start="10">
+ <li>ten</li>
+ <li>eleven</li>
+ <li>twelve</li>
+</ol>
+
+<ol start="0">
+ <li>zero</li>
+ <li>one</li>
+ <li>two</li>
+</ol>
+
+<ol start="-5">
+ <li>minus five</li>
+ <li>minus four</li>
+ <li>minus three</li>
+</ol>
+
+<ol start="notanumber">
+ <li>one</li>
+ <li>two</li>
+ <li>three</li>
+</ol>
diff --git a/test/data/shr/ol.txt b/test/data/shr/ol.txt
new file mode 100644
index 00000000000..0d46e2a8ddb
--- /dev/null
+++ b/test/data/shr/ol.txt
@@ -0,0 +1,19 @@
+1 one
+2 two
+3 three
+
+10 ten
+11 eleven
+12 twelve
+
+0 zero
+1 one
+2 two
+
+-5 minus five
+-4 minus four
+-3 minus three
+
+1 one
+2 two
+3 three
diff --git a/test/data/vc/diff-mode/hello_emacs.c b/test/data/vc/diff-mode/hello_emacs.c
new file mode 100644
index 00000000000..c7ed7538c3a
--- /dev/null
+++ b/test/data/vc/diff-mode/hello_emacs.c
@@ -0,0 +1,6 @@
+#include <stdio.h>
+int main()
+{
+ printf("Hello, Emacs!\n");
+ return 0;
+}
diff --git a/test/data/vc/diff-mode/hello_emacs_1.c b/test/data/vc/diff-mode/hello_emacs_1.c
new file mode 100644
index 00000000000..62145a6b44a
--- /dev/null
+++ b/test/data/vc/diff-mode/hello_emacs_1.c
@@ -0,0 +1 @@
+int main() { printf("Hello, Emacs!\n"); return 0; } \ No newline at end of file
diff --git a/test/data/vc/diff-mode/hello_world.c b/test/data/vc/diff-mode/hello_world.c
new file mode 100644
index 00000000000..dcbe06c6012
--- /dev/null
+++ b/test/data/vc/diff-mode/hello_world.c
@@ -0,0 +1,6 @@
+#include <stdio.h>
+int main()
+{
+ printf("Hello, World!\n");
+ return 0;
+}
diff --git a/test/data/vc/diff-mode/hello_world_1.c b/test/data/vc/diff-mode/hello_world_1.c
new file mode 100644
index 00000000000..606afb371cb
--- /dev/null
+++ b/test/data/vc/diff-mode/hello_world_1.c
@@ -0,0 +1 @@
+int main() { printf("Hello, World!\n"); return 0; } \ No newline at end of file
diff --git a/test/data/xdg/mimeapps.list b/test/data/xdg/mimeapps.list
new file mode 100644
index 00000000000..27fbd94b16b
--- /dev/null
+++ b/test/data/xdg/mimeapps.list
@@ -0,0 +1,9 @@
+[Default Applications]
+x-test/foo=a.desktop
+
+[Added Associations]
+x-test/foo=b.desktop
+x-test/baz=a.desktop
+
+[Removed Associations]
+x-test/foo=c.desktop;d.desktop
diff --git a/test/data/xdg/mimeinfo.cache b/test/data/xdg/mimeinfo.cache
new file mode 100644
index 00000000000..6e54f604fa0
--- /dev/null
+++ b/test/data/xdg/mimeinfo.cache
@@ -0,0 +1,4 @@
+[MIME Cache]
+x-test/foo=c.desktop;d.desktop
+x-test/bar=a.desktop;c.desktop
+x-test/baz=b.desktop;d.desktop
diff --git a/test/lisp/abbrev-tests.el b/test/lisp/abbrev-tests.el
index 800c9aac33c..3b8acf5519a 100644
--- a/test/lisp/abbrev-tests.el
+++ b/test/lisp/abbrev-tests.el
@@ -38,6 +38,12 @@
(abbrev-table-put ert-test-abbrevs :ert-test "ert-test-value")
ert-test-abbrevs)
+(defun setup-test-abbrev-table-with-props ()
+ (defvar ert-test-abbrevs nil)
+ (define-abbrev-table 'ert-test-abbrevs '(("fb" "fooBar" nil :case-fixed t)))
+ (abbrev-table-put ert-test-abbrevs :ert-test "ert-test-value")
+ ert-test-abbrevs)
+
(ert-deftest abbrev-table-p-test ()
(should-not (abbrev-table-p 42))
(should-not (abbrev-table-p "aoeu"))
@@ -58,6 +64,14 @@
(should (= (length table) obarray-default-size))
(should (eq (abbrev-table-get table 'foo) 'bar))))
+(ert-deftest abbrev--table-symbols-test ()
+ (let ((ert-test-abbrevs (setup-test-abbrev-table)))
+ (define-abbrev ert-test-abbrevs "sys" "system abbrev" nil :system t)
+ (should (equal (mapcar #'symbol-name (abbrev--table-symbols 'ert-test-abbrevs))
+ '("a-e-t")))
+ (should (equal (mapcar #'symbol-name (abbrev--table-symbols 'ert-test-abbrevs t))
+ '("a-e-t" "sys")))))
+
(ert-deftest abbrev-table-get-put-test ()
(let ((table (make-abbrev-table)))
(should-not (abbrev-table-get table 'foo))
@@ -230,6 +244,17 @@
(should (equal "abbrev-ert-test" (abbrev-expansion "a-e-t" ert-test-abbrevs)))
(delete-file temp-test-file)))
+(ert-deftest read-write-abbrev-file-test-with-props ()
+ "Test reading and writing abbrevs from file"
+ (let ((temp-test-file (make-temp-file "ert-abbrev-test"))
+ (ert-test-abbrevs (setup-test-abbrev-table-with-props)))
+ (write-abbrev-file temp-test-file)
+ (clear-abbrev-table ert-test-abbrevs)
+ (should (abbrev-table-empty-p ert-test-abbrevs))
+ (read-abbrev-file temp-test-file)
+ (should (equal "fooBar" (abbrev-expansion "fb" ert-test-abbrevs)))
+ (delete-file temp-test-file)))
+
(ert-deftest abbrev-edit-save-to-file-test ()
"Test saving abbrev definitions in buffer to file"
(defvar ert-save-test-table nil)
diff --git a/test/lisp/arc-mode-tests.el b/test/lisp/arc-mode-tests.el
index e6857671393..79d3ac6365c 100644
--- a/test/lisp/arc-mode-tests.el
+++ b/test/lisp/arc-mode-tests.el
@@ -21,6 +21,8 @@
(require 'ert)
(require 'arc-mode)
+(defvar arc-mode-tests-data-directory
+ (expand-file-name "test/data/decompress" source-directory))
(ert-deftest arc-mode-test-archive-int-to-mode ()
(let ((alist (list (cons 448 "-rwx------")
@@ -32,6 +34,18 @@
(dolist (x alist)
(should (equal (cdr x) (archive-int-to-mode (car x)))))))
+(ert-deftest arc-mode-test-zip-extract-gz ()
+ (skip-unless (and archive-zip-extract (executable-find (car archive-zip-extract))))
+ (skip-unless (executable-find "gzip"))
+ (let* ((zip-file (expand-file-name "zg.zip" arc-mode-tests-data-directory))
+ zip-buffer gz-buffer)
+ (unwind-protect
+ (with-current-buffer (setq zip-buffer (find-file-noselect zip-file))
+ (setq gz-buffer (archive-extract))
+ (should (equal (char-after) ?\N{SNOWFLAKE})))
+ (when (buffer-live-p zip-buffer) (kill-buffer zip-buffer))
+ (when (buffer-live-p gz-buffer) (kill-buffer gz-buffer)))))
+
(provide 'arc-mode-tests)
;; arc-mode-tests.el ends here
diff --git a/test/lisp/auth-source-pass-tests.el b/test/lisp/auth-source-pass-tests.el
index 9cb92fe3842..d1e486ad6be 100644
--- a/test/lisp/auth-source-pass-tests.el
+++ b/test/lisp/auth-source-pass-tests.el
@@ -73,102 +73,113 @@ This function is intended to be set to `auth-source-debug`."
(auth-source-pass--debug-log nil))
,@body)))
+(ert-deftest auth-source-pass-any-host ()
+ (auth-source-pass--with-store '(("foo" ("port" . "foo-port") ("host" . "foo-user"))
+ ("bar"))
+ (should-not (auth-source-pass-search :host t))))
+
+(ert-deftest auth-source-pass-undefined-host ()
+ (auth-source-pass--with-store '(("foo" ("port" . "foo-port") ("host" . "foo-user"))
+ ("bar"))
+ (should-not (auth-source-pass-search :host nil))))
+
+
(ert-deftest auth-source-pass-find-match-matching-at-entry-name ()
(auth-source-pass--with-store '(("foo"))
- (should (equal (auth-source-pass--find-match "foo" nil)
+ (should (equal (auth-source-pass--find-match "foo" nil nil)
"foo"))))
(ert-deftest auth-source-pass-find-match-matching-at-entry-name-part ()
(auth-source-pass--with-store '(("foo"))
- (should (equal (auth-source-pass--find-match "https://foo" nil)
+ (should (equal (auth-source-pass--find-match "https://foo" nil nil)
"foo"))))
(ert-deftest auth-source-pass-find-match-matching-at-entry-name-ignoring-user ()
(auth-source-pass--with-store '(("foo"))
- (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil)
+ (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil nil)
"foo"))))
(ert-deftest auth-source-pass-find-match-matching-at-entry-name-with-user ()
(auth-source-pass--with-store '(("SomeUser@foo"))
- (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil)
+ (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil nil)
"SomeUser@foo"))))
(ert-deftest auth-source-pass-find-match-matching-at-entry-name-prefer-full ()
(auth-source-pass--with-store '(("SomeUser@foo") ("foo"))
- (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil)
+ (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil nil)
"SomeUser@foo"))))
(ert-deftest auth-source-pass-find-match-matching-at-entry-name-prefer-full-reversed ()
(auth-source-pass--with-store '(("foo") ("SomeUser@foo"))
- (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil)
+ (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil nil)
"SomeUser@foo"))))
(ert-deftest auth-source-pass-find-match-matching-at-entry-name-without-subdomain ()
(auth-source-pass--with-store '(("bar.com"))
- (should (equal (auth-source-pass--find-match "foo.bar.com" nil)
+ (should (equal (auth-source-pass--find-match "foo.bar.com" nil nil)
"bar.com"))))
(ert-deftest auth-source-pass-find-match-matching-at-entry-name-without-subdomain-with-user ()
(auth-source-pass--with-store '(("someone@bar.com"))
- (should (equal (auth-source-pass--find-match "foo.bar.com" "someone")
+ (should (equal (auth-source-pass--find-match "foo.bar.com" "someone" nil)
"someone@bar.com"))))
(ert-deftest auth-source-pass-find-match-matching-at-entry-name-without-subdomain-with-bad-user ()
(auth-source-pass--with-store '(("someoneelse@bar.com"))
- (should (equal (auth-source-pass--find-match "foo.bar.com" "someone")
+ (should (equal (auth-source-pass--find-match "foo.bar.com" "someone" nil)
nil))))
(ert-deftest auth-source-pass-find-match-matching-at-entry-name-without-subdomain-prefer-full ()
(auth-source-pass--with-store '(("bar.com") ("foo.bar.com"))
- (should (equal (auth-source-pass--find-match "foo.bar.com" nil)
+ (should (equal (auth-source-pass--find-match "foo.bar.com" nil nil)
"foo.bar.com"))))
(ert-deftest auth-source-pass-dont-match-at-folder-name ()
(auth-source-pass--with-store '(("foo.bar.com/foo"))
- (should (equal (auth-source-pass--find-match "foo.bar.com" nil)
+ (should (equal (auth-source-pass--find-match "foo.bar.com" nil nil)
nil))))
+(ert-deftest auth-source-pass-find-match-matching-extracting-user-from-host ()
+ (auth-source-pass--with-store '(("foo.com/bar"))
+ (should (equal (auth-source-pass--find-match "https://bar@foo.com" nil nil)
+ "foo.com/bar"))))
+
(ert-deftest auth-source-pass-search-with-user-first ()
(auth-source-pass--with-store '(("foo") ("user@foo"))
- (should (equal (auth-source-pass--find-match "foo" "user")
+ (should (equal (auth-source-pass--find-match "foo" "user" nil)
"user@foo"))
(auth-source-pass--should-have-message-containing "Found 1 match")))
(ert-deftest auth-source-pass-give-priority-to-desired-user ()
(auth-source-pass--with-store '(("foo") ("subdir/foo" ("user" . "someone")))
- (should (equal (auth-source-pass--find-match "foo" "someone")
+ (should (equal (auth-source-pass--find-match "foo" "someone" nil)
"subdir/foo"))
(auth-source-pass--should-have-message-containing "Found 2 matches")
(auth-source-pass--should-have-message-containing "matching user field")))
(ert-deftest auth-source-pass-give-priority-to-desired-user-reversed ()
(auth-source-pass--with-store '(("foo" ("user" . "someone")) ("subdir/foo"))
- (should (equal (auth-source-pass--find-match "foo" "someone")
+ (should (equal (auth-source-pass--find-match "foo" "someone" nil)
"foo"))
(auth-source-pass--should-have-message-containing "Found 2 matches")
(auth-source-pass--should-have-message-containing "matching user field")))
(ert-deftest auth-source-pass-return-first-when-several-matches ()
(auth-source-pass--with-store '(("foo") ("subdir/foo"))
- (should (equal (auth-source-pass--find-match "foo" nil)
+ (should (equal (auth-source-pass--find-match "foo" nil nil)
"foo"))
(auth-source-pass--should-have-message-containing "Found 2 matches")
(auth-source-pass--should-have-message-containing "the first one")))
(ert-deftest auth-source-pass-make-divansantana-happy ()
(auth-source-pass--with-store '(("host.com"))
- (should (equal (auth-source-pass--find-match "smtp.host.com" "myusername@host.co.za")
+ (should (equal (auth-source-pass--find-match "smtp.host.com" "myusername@host.co.za" nil)
"host.com"))))
-(ert-deftest auth-source-pass-hostname ()
- (should (equal (auth-source-pass--hostname "https://foo.bar") "foo.bar"))
- (should (equal (auth-source-pass--hostname "http://foo.bar") "foo.bar"))
- (should (equal (auth-source-pass--hostname "https://SomeUser@foo.bar") "foo.bar")))
-
-(ert-deftest auth-source-pass-hostname-with-user ()
- (should (equal (auth-source-pass--hostname-with-user "https://foo.bar") "foo.bar"))
- (should (equal (auth-source-pass--hostname-with-user "http://foo.bar") "foo.bar"))
- (should (equal (auth-source-pass--hostname-with-user "https://SomeUser@foo.bar") "SomeUser@foo.bar")))
+(ert-deftest auth-source-pass-find-host-without-port ()
+ (auth-source-pass--with-store '(("host.com"))
+ (should (equal (auth-source-pass--find-match "host.com:8888" "someuser" nil)
+ "host.com"))))
(defmacro auth-source-pass--with-store-find-foo (store &rest body)
"Use STORE while executing BODY. \"foo\" is the matched entry."
@@ -197,14 +208,25 @@ This function is intended to be set to `auth-source-debug`."
(should (equal (plist-get result :port) 512))
(should (equal (plist-get result :user) "anuser")))))
+(ert-deftest auth-source-pass-build-result-passes-full-host-to-find-match ()
+ (let (passed-host)
+ (cl-letf (((symbol-function 'auth-source-pass--find-match)
+ (lambda (host _user _port) (setq passed-host host))))
+ (auth-source-pass--build-result "https://user@host.com:123" nil nil)
+ (should (equal passed-host "https://user@host.com:123"))
+ (auth-source-pass--build-result "https://user@host.com" nil nil)
+ (should (equal passed-host "https://user@host.com"))
+ (auth-source-pass--build-result "user@host.com" nil nil)
+ (should (equal passed-host "user@host.com"))
+ (auth-source-pass--build-result "user@host.com:443" nil nil)
+ (should (equal passed-host "user@host.com:443")))))
+
(ert-deftest auth-source-pass-only-return-entries-that-can-be-open ()
(cl-letf (((symbol-function 'auth-source-pass-entries)
- (lambda () '("foo.site.com" "bar.site.com"
- "mail/baz.site.com/scott")))
+ (lambda () '("foo.site.com" "bar.site.com" "mail/baz.site.com/scott")))
((symbol-function 'auth-source-pass--entry-valid-p)
;; only foo.site.com and "mail/baz.site.com/scott" are valid
- (lambda (entry) (member entry '("foo.site.com"
- "mail/baz.site.com/scott")))))
+ (lambda (entry) (member entry '("foo.site.com" "mail/baz.site.com/scott")))))
(should (equal (auth-source-pass--find-all-by-entry-name "foo.site.com" "someuser")
'("foo.site.com")))
(should (equal (auth-source-pass--find-all-by-entry-name "bar.site.com" "someuser")
@@ -222,6 +244,13 @@ This function is intended to be set to `auth-source-debug`."
(should (auth-source-pass--entry-valid-p "foo"))
(should-not (auth-source-pass--entry-valid-p "bar"))))
+(ert-deftest auth-source-pass-can-start-from-auth-source-search ()
+ (auth-source-pass--with-store '(("gitlab.com" ("user" . "someone")))
+ (auth-source-pass-enable)
+ (let ((result (car (auth-source-search :host "gitlab.com"))))
+ (should (equal (plist-get result :user) "someone"))
+ (should (equal (plist-get result :host) "gitlab.com")))))
+
(provide 'auth-source-pass-tests)
;;; auth-source-pass-tests.el ends here
diff --git a/test/lisp/auth-source-tests.el b/test/lisp/auth-source-tests.el
index 748e9eccd54..c8460c00353 100644
--- a/test/lisp/auth-source-tests.el
+++ b/test/lisp/auth-source-tests.el
@@ -29,9 +29,7 @@
(require 'ert)
(require 'cl-lib)
(require 'auth-source)
-
-(defvar secrets-enabled t
- "Enable the secrets backend to test its features.")
+(require 'secrets)
(defun auth-source-ensure-ignored-backend (source)
(auth-source-validate-backend source '((:source . "")
@@ -308,6 +306,44 @@
(should (equal found-as-string (concat testname ": " needed)))))
(delete-file netrc-file)))
+(ert-deftest auth-source-test-secrets-create-secret ()
+ (skip-unless secrets-enabled)
+ ;; The "session" collection is temporary for the lifetime of the
+ ;; Emacs process. Therefore, we don't care to delete it.
+ (let ((auth-sources '((:source (:secrets "session"))))
+ (auth-source-save-behavior t)
+ (host (md5 (concat (prin1-to-string process-environment)
+ (current-time-string))))
+ (passwd (md5 (concat (prin1-to-string process-environment)
+ (current-time-string) (current-time-string))))
+ auth-info auth-passwd)
+ ;; Redefine `read-*' in order to avoid interactive input.
+ (cl-letf (((symbol-function 'read-passwd) (lambda (_) passwd))
+ ((symbol-function 'read-string)
+ (lambda (_prompt _initial _history default) default)))
+ (setq auth-info
+ (car (auth-source-search
+ :max 1 :host host :require '(:user :secret) :create t))))
+ (should (functionp (plist-get auth-info :save-function)))
+ (funcall (plist-get auth-info :save-function))
+
+ ;; Check, that the item has been created indeed.
+ (auth-source-forget+ :host t)
+ (setq auth-info (car (auth-source-search :host host))
+ auth-passwd (plist-get auth-info :secret)
+ auth-passwd (if (functionp auth-passwd)
+ (funcall auth-passwd)
+ auth-passwd))
+ (should (string-equal (plist-get auth-info :user) (user-login-name)))
+ (should (string-equal (plist-get auth-info :host) host))
+ (should (string-equal auth-passwd passwd))
+
+ ;; Cleanup.
+ ;; Should use `auth-source-delete' when implemented for :secrets backend.
+ (secrets-delete-item
+ "session"
+ (format "%s@%s" (plist-get auth-info :user) (plist-get auth-info :host)))))
+
(ert-deftest auth-source-delete ()
(let* ((netrc-file (make-temp-file "auth-source-test" nil nil "\
machine a1 port a2 user a3 password a4
diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el
index 831c6f7b375..6e8219d238d 100644
--- a/test/lisp/autorevert-tests.el
+++ b/test/lisp/autorevert-tests.el
@@ -159,14 +159,18 @@ This expects `auto-revert--messages' to be bound by
(ert-deftest auto-revert-test02-auto-revert-deleted-file ()
"Check autorevert for a deleted file."
:tags '(:expensive-test)
+ ;; Repeated unpredictable failures, bug#32645.
+ ;; Unlikely to be hydra-specific?
+ (skip-unless (not (getenv "EMACS_HYDRA_CI")))
(let ((tmpfile (make-temp-file "auto-revert-test"))
- buf)
+ buf desc)
(unwind-protect
(progn
(write-region "any text" nil tmpfile nil 'no-message)
(setq buf (find-file-noselect tmpfile))
(with-current-buffer buf
+ (should-not auto-revert-notify-watch-descriptor)
(should (string-equal (buffer-string) "any text"))
;; `buffer-stale--default-function' checks for
;; `verify-visited-file-modtime'. We must ensure that
@@ -174,12 +178,16 @@ This expects `auto-revert--messages' to be bound by
(sleep-for 1)
(auto-revert-mode 1)
(should auto-revert-mode)
+ (setq desc auto-revert-notify-watch-descriptor)
;; Remove file while reverting. We simulate this by
;; modifying `before-revert-hook'.
(add-hook
'before-revert-hook
- (lambda () (delete-file buffer-file-name))
+ (lambda ()
+ ;; Temporarily.
+ (message "%s deleted" buffer-file-name)
+ (delete-file buffer-file-name))
nil t)
(ert-with-message-capture auto-revert--messages
@@ -192,7 +200,7 @@ This expects `auto-revert--messages' to be bound by
(should (string-match "any text" (buffer-string)))
;; With w32notify, the 'stopped' events are not sent.
(or (eq file-notify--library 'w32notify)
- (should-not auto-revert-use-notify))
+ (should-not auto-revert-notify-watch-descriptor))
;; Once the file has been recreated, the buffer shall be
;; reverted.
@@ -203,6 +211,11 @@ This expects `auto-revert--messages' to be bound by
(auto-revert--wait-for-revert buf))
;; Check, that the buffer has been reverted.
(should (string-match "another text" (buffer-string)))
+ ;; When file notification is used, it must be reenabled
+ ;; after recreation of the file. We cannot expect that
+ ;; the descriptor is the same, so we just check the
+ ;; existence.
+ (should (eq (null desc) (null auto-revert-notify-watch-descriptor)))
;; An empty file shall still be reverted.
(ert-with-message-capture auto-revert--messages
diff --git a/test/lisp/button-tests.el b/test/lisp/button-tests.el
new file mode 100644
index 00000000000..d54a992ab89
--- /dev/null
+++ b/test/lisp/button-tests.el
@@ -0,0 +1,40 @@
+;;; button-tests.el --- tests for button.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2019 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+
+(ert-deftest button-at ()
+ "Test `button-at' behavior."
+ (with-temp-buffer
+ (should-not (button-at (point)))
+ (let ((button (insert-text-button "text button"))
+ (marker (button-at (1- (point)))))
+ (should (markerp marker))
+ (should (= (button-end button) (button-end marker) (point))))
+ (let ((button (insert-button "overlay button"))
+ (overlay (button-at (1- (point)))))
+ (should (overlayp overlay))
+ (should (eq button overlay)))
+ ;; Buttons and widgets are incompatible (bug#34506).
+ (widget-create 'link "link widget")
+ (should-not (button-at (1- (point))))))
+
+;;; button-tests.el ends here
diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el
index 4d34f896015..af617e677f1 100644
--- a/test/lisp/calendar/icalendar-tests.el
+++ b/test/lisp/calendar/icalendar-tests.el
@@ -57,17 +57,16 @@
(ert-deftest icalendar--create-uid ()
"Test for `icalendar--create-uid'."
- (let* ((icalendar-uid-format "xxx-%t-%c-%h-%u-%s")
+ (let* ((icalendar-uid-format "xxx-%c-%h-%u-%s")
(icalendar--uid-count 77)
(entry-full "30.06.1964 07:01 blahblah")
(hash (format "%d" (abs (sxhash entry-full))))
(contents "DTSTART:19640630T070100\nblahblah")
(username (or user-login-name "UNKNOWN_USER")))
- (cl-letf (((symbol-function 'current-time) (lambda () '(1 2 3))))
- (should (= 77 icalendar--uid-count))
- (should (string= (concat "xxx-123-77-" hash "-" username "-19640630")
- (icalendar--create-uid entry-full contents)))
- (should (= 78 icalendar--uid-count)))
+ (should (= 77 icalendar--uid-count))
+ (should (string= (concat "xxx-77-" hash "-" username "-19640630")
+ (icalendar--create-uid entry-full contents)))
+ (should (= 78 icalendar--uid-count))
(setq contents "blahblah")
(setq icalendar-uid-format "yyy%syyy")
(should (string= (concat "yyyDTSTARTyyy")
diff --git a/test/lisp/calendar/parse-time-tests.el b/test/lisp/calendar/parse-time-tests.el
index 839265d7689..7435620b71f 100644
--- a/test/lisp/calendar/parse-time-tests.el
+++ b/test/lisp/calendar/parse-time-tests.el
@@ -28,35 +28,51 @@
(ert-deftest parse-time-tests ()
(should (equal (parse-time-string "Mon, 22 Feb 2016 19:35:42 +0100")
- '(42 35 19 22 2 2016 1 nil 3600)))
+ '(42 35 19 22 2 2016 1 -1 3600)))
(should (equal (parse-time-string "22 Feb 2016 19:35:42 +0100")
- '(42 35 19 22 2 2016 nil nil 3600)))
+ '(42 35 19 22 2 2016 nil -1 3600)))
(should (equal (parse-time-string "22 Feb 2016 +0100")
- '(nil nil nil 22 2 2016 nil nil 3600)))
+ '(nil nil nil 22 2 2016 nil -1 3600)))
(should (equal (parse-time-string "Mon, 22 Feb 16 19:35:42 +0100")
- '(42 35 19 22 2 2016 1 nil 3600)))
+ '(42 35 19 22 2 2016 1 -1 3600)))
(should (equal (parse-time-string "Mon, 22 February 2016 19:35:42 +0100")
- '(42 35 19 22 2 2016 1 nil 3600)))
+ '(42 35 19 22 2 2016 1 -1 3600)))
(should (equal (parse-time-string "Mon, 22 feb 2016 19:35:42 +0100")
- '(42 35 19 22 2 2016 1 nil 3600)))
+ '(42 35 19 22 2 2016 1 -1 3600)))
(should (equal (parse-time-string "Monday, 22 february 2016 19:35:42 +0100")
- '(42 35 19 22 2 2016 1 nil 3600)))
- (should (equal (parse-time-string "Monday, 22 february 2016 19:35:42 PDT")
- '(42 35 19 22 2 2016 1 t -25200)))
- (should (equal (parse-iso8601-time-string "1998-09-12T12:21:54-0200")
- '(13818 33666)))
- (should (equal (parse-iso8601-time-string "1998-09-12T12:21:54-0230")
- '(13818 35466)))
- (should (equal (parse-iso8601-time-string "1998-09-12T12:21:54-02:00")
- '(13818 33666)))
- (should (equal (parse-iso8601-time-string "1998-09-12T12:21:54-02")
- '(13818 33666)))
- (should (equal (parse-iso8601-time-string "1998-09-12T12:21:54+0230")
- '(13818 17466)))
- (should (equal (parse-iso8601-time-string "1998-09-12T12:21:54+02")
- '(13818 19266)))
- (should (equal (parse-iso8601-time-string "1998-09-12T12:21:54Z")
- '(13818 26466)))
+ '(42 35 19 22 2 2016 1 -1 3600)))
+ (should (equal (parse-time-string "Monday, 22 february 2016 19:35:42 PST")
+ '(42 35 19 22 2 2016 1 nil -28800)))
+ (should (equal (parse-time-string "Friday, 21 Sep 2018 13:47:58 PDT")
+ '(58 47 13 21 9 2018 5 t -25200)))
+ (should (equal (format-time-string
+ "%Y-%m-%d %H:%M:%S"
+ (parse-iso8601-time-string "1998-09-12T12:21:54-0200") t)
+ "1998-09-12 14:21:54"))
+ (should (equal (format-time-string
+ "%Y-%m-%d %H:%M:%S"
+ (parse-iso8601-time-string "1998-09-12T12:21:54-0230") t)
+ "1998-09-12 14:51:54"))
+ (should (equal (format-time-string
+ "%Y-%m-%d %H:%M:%S"
+ (parse-iso8601-time-string "1998-09-12T12:21:54-02:00") t)
+ "1998-09-12 14:21:54"))
+ (should (equal (format-time-string
+ "%Y-%m-%d %H:%M:%S"
+ (parse-iso8601-time-string "1998-09-12T12:21:54-02") t)
+ "1998-09-12 14:21:54"))
+ (should (equal (format-time-string
+ "%Y-%m-%d %H:%M:%S"
+ (parse-iso8601-time-string "1998-09-12T12:21:54+0230") t)
+ "1998-09-12 09:51:54"))
+ (should (equal (format-time-string
+ "%Y-%m-%d %H:%M:%S"
+ (parse-iso8601-time-string "1998-09-12T12:21:54+02") t)
+ "1998-09-12 10:21:54"))
+ (should (equal (format-time-string
+ "%Y-%m-%d %H:%M:%S"
+ (parse-iso8601-time-string "1998-09-12T12:21:54Z") t)
+ "1998-09-12 12:21:54"))
(should (equal (parse-iso8601-time-string "1998-09-12T12:21:54")
(encode-time 54 21 12 12 9 1998))))
diff --git a/test/lisp/calendar/todo-mode-tests.el b/test/lisp/calendar/todo-mode-tests.el
index 606af30180b..7d4f7a77683 100644
--- a/test/lisp/calendar/todo-mode-tests.el
+++ b/test/lisp/calendar/todo-mode-tests.el
@@ -25,6 +25,7 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'todo-mode)
(defvar todo-test-data-dir
@@ -561,11 +562,12 @@ source file is different."
;; Headers in the todo file are still hidden.
(should (equal (overlay-get (todo-get-overlay 'header) 'display) "")))))
-(defun todo-test--insert-item (item &optional priority)
+(defun todo-test--insert-item (item &optional priority
+ _arg diary-type date-type time where)
"Insert string ITEM into current category with priority PRIORITY.
-Use defaults for all other item insertion parameters. This
-provides a noninteractive API for todo-insert-item for use in
-automatic testing."
+The remaining arguments (except _ARG, which is ignored) specify
+item insertion parameters. This provides a noninteractive API
+for todo-insert-item for use in automatic testing."
(cl-letf (((symbol-function 'read-from-minibuffer)
(lambda (_prompt) item))
((symbol-function 'read-number) ; For todo-set-item-priority
@@ -581,6 +583,271 @@ automatic testing."
(todo-test--insert-item item 1)
(should (equal (overlay-get (todo-get-overlay 'header) 'display) "")))))
+(defun todo-test--done-items-separator (&optional eol)
+ "Set up test of command interaction with done items separator.
+With non-nil argument EOL, return the position at the end of the
+separator, otherwise, return the position at the beginning."
+ (todo-test--show 1)
+ (goto-char (point-max))
+ ;; See comment about recentering in todo-test-raise-lower-priority.
+ (set-window-buffer nil (current-buffer))
+ (todo-toggle-view-done-items)
+ ;; FIXME: Point should now be on the first done item, and in batch
+ ;; testing it is, so we have to move back one line to the done items
+ ;; separator; but for some reason, in the graphical test
+ ;; environment, it stays on the last empty line of the todo items
+ ;; section, so there we have to advance one character to the done
+ ;; items separator.
+ (if (display-graphic-p)
+ (forward-char)
+ (forward-line -1))
+ (if eol (forward-char)))
+
+(ert-deftest todo-test-done-items-separator01-bol () ; bug#32343
+ "Test item copying and here insertion at BOL of separator.
+Both should be user errors."
+ (with-todo-test
+ (todo-test--done-items-separator)
+ (let* ((copy-err "Item copying is not valid here")
+ (here-err "Item insertion is not valid here")
+ (insert-item-test (lambda (where)
+ (should-error (todo-insert-item--basic
+ nil nil nil nil where)))))
+ (should (string= copy-err (cadr (funcall insert-item-test 'copy))))
+ (should (string= here-err (cadr (funcall insert-item-test 'here)))))))
+
+(ert-deftest todo-test-done-items-separator01-eol () ; bug#32343
+ "Test item copying and here insertion at EOL of separator.
+Both should be user errors."
+ (with-todo-test
+ (todo-test--done-items-separator 'eol)
+ (let* ((copy-err "Item copying is not valid here")
+ (here-err "Item insertion is not valid here")
+ (insert-item-test (lambda (where)
+ (should-error (todo-insert-item--basic
+ nil nil nil nil where)))))
+ (should (string= copy-err (cadr (funcall insert-item-test 'copy))))
+ (should (string= here-err (cadr (funcall insert-item-test 'here)))))))
+
+(ert-deftest todo-test-done-items-separator02-bol () ; bug#32343
+ "Test item editing commands at BOL of done items separator.
+They should all be noops."
+ (with-todo-test
+ (todo-test--done-items-separator)
+ (should-not (todo-item-done))
+ (should-not (todo-raise-item-priority))
+ (should-not (todo-lower-item-priority))
+ (should-not (called-interactively-p #'todo-set-item-priority))
+ (should-not (called-interactively-p #'todo-move-item))
+ (should-not (called-interactively-p #'todo-delete-item))
+ (should-not (called-interactively-p #'todo-edit-item))))
+
+(ert-deftest todo-test-done-items-separator02-eol () ; bug#32343
+ "Test item editing command at EOL of done items separator.
+They should all be noops."
+ (with-todo-test
+ (todo-test--done-items-separator 'eol)
+ (should-not (todo-item-done))
+ (should-not (todo-raise-item-priority))
+ (should-not (todo-lower-item-priority))
+ (should-not (called-interactively-p #'todo-set-item-priority))
+ (should-not (called-interactively-p #'todo-move-item))
+ (should-not (called-interactively-p #'todo-delete-item))
+ (should-not (called-interactively-p #'todo-edit-item))))
+
+(ert-deftest todo-test-done-items-separator03-bol () ; bug#32343
+ "Test item marking at BOL of done items separator.
+This should be a noop, adding no marks to the category."
+ (with-todo-test
+ (todo-test--done-items-separator)
+ (call-interactively #'todo-toggle-mark-item)
+ (should-not (assoc (todo-current-category) todo-categories-with-marks))))
+
+(ert-deftest todo-test-done-items-separator03-eol () ; bug#32343
+ "Test item marking at EOL of done items separator.
+This should be a noop, adding no marks to the category."
+ (with-todo-test
+ (todo-test--done-items-separator 'eol)
+ (call-interactively #'todo-toggle-mark-item)
+ (should-not (assoc (todo-current-category) todo-categories-with-marks))))
+
+(ert-deftest todo-test-done-items-separator04-bol () ; bug#32343
+ "Test moving to previous item from BOL of done items separator.
+This should move point to the last not done todo item."
+ (with-todo-test
+ (todo-test--done-items-separator)
+ (let ((last-item (save-excursion
+ ;; Move to empty line after last todo item.
+ (forward-line -1)
+ (todo-previous-item)
+ (todo-item-string))))
+ (should (string= last-item (save-excursion
+ (todo-previous-item)
+ (todo-item-string)))))))
+
+(ert-deftest todo-test-done-items-separator04-eol () ; bug#32343
+ "Test moving to previous item from EOL of done items separator.
+This should move point to the last not done todo item."
+ (with-todo-test
+ (todo-test--done-items-separator 'eol)
+ (let ((last-item (save-excursion
+ ;; Move to empty line after last todo item.
+ (forward-line -1)
+ (todo-previous-item)
+ (todo-item-string))))
+ (should (string= last-item (save-excursion
+ (todo-previous-item)
+ (todo-item-string)))))))
+
+(ert-deftest todo-test-done-items-separator05-bol () ; bug#32343
+ "Test moving to next item from BOL of done items separator.
+This should move point to the first done todo item."
+ (with-todo-test
+ (todo-test--done-items-separator)
+ (let ((first-done (save-excursion
+ ;; Move to empty line after last todo item.
+ (forward-line -1)
+ (todo-next-item)
+ (todo-item-string))))
+ (should (string= first-done (save-excursion
+ (todo-next-item)
+ (todo-item-string)))))))
+
+(ert-deftest todo-test-done-items-separator05-eol () ; bug#32343
+ "Test moving to next item from EOL of done items separator.
+This should move point to the first done todo item."
+ (with-todo-test
+ (todo-test--done-items-separator 'eol)
+ (let ((first-done (save-excursion
+ ;; Move to empty line after last todo item.
+ (forward-line -1)
+ (todo-next-item)
+ (todo-item-string))))
+ (should (string= first-done (save-excursion
+ (todo-next-item)
+ (todo-item-string)))))))
+
+;; Item highlighting uses hl-line-mode, which enables highlighting in
+;; post-command-hook. For some reason, in the test environment, the
+;; hook function is not automatically run, so after enabling item
+;; highlighting, use ert-simulate-command around the next command,
+;; which explicitly runs the hook function.
+(ert-deftest todo-test-done-items-separator06-bol () ; bug#32343
+ "Test enabling item highlighting at BOL of done items separator.
+Subsequently moving to an item should show it highlighted."
+ (with-todo-test
+ (todo-test--done-items-separator)
+ (call-interactively #'todo-toggle-item-highlighting)
+ (ert-simulate-command '(todo-previous-item))
+ (should (eq 'hl-line (get-char-property (point) 'face)))))
+
+(ert-deftest todo-test-done-items-separator06-eol () ; bug#32343
+ "Test enabling item highlighting at EOL of done items separator.
+Subsequently moving to an item should show it highlighted."
+ (with-todo-test
+ (todo-test--done-items-separator 'eol)
+ (todo-toggle-item-highlighting)
+ (forward-line -1)
+ (ert-simulate-command '(todo-previous-item))
+ (should (eq 'hl-line (get-char-property (point) 'face)))))
+
+(ert-deftest todo-test-done-items-separator07 () ; bug#32343
+ "Test item highlighting when crossing done items separator.
+The highlighting should remain enabled."
+ (with-todo-test
+ (todo-test--done-items-separator)
+ (todo-previous-item)
+ (todo-toggle-item-highlighting)
+ (todo-next-item) ; Now on empty line above separator.
+ (forward-line) ; Now on separator.
+ (ert-simulate-command '(forward-line)) ; Now on first done item.
+ (should (eq 'hl-line (get-char-property (point) 'face)))))
+
+(ert-deftest todo-test-current-file-in-edit-mode () ; bug#32437
+ "Test the value of todo-current-todo-file in todo-edit-mode."
+ (with-todo-test
+ (todo-test--show 1)
+ ;; The preceding calls todo-mode but does not run pre-command-hook
+ ;; in the test environment, thus failing to set
+ ;; todo-global-current-todo-file, which is needed for the test
+ ;; after todo-edit-item--text. So force the hook function to run.
+ (ert-simulate-command '(todo-mode))
+ (let ((curfile todo-current-todo-file))
+ (should (equal curfile todo-test-file-1))
+ (todo-edit-item--text 'multiline)
+ (should (equal todo-current-todo-file curfile))
+ (todo-edit-quit)
+ (todo-edit-file)
+ (should (equal todo-current-todo-file curfile))
+ (todo-edit-quit))
+ (todo-find-archive)
+ (let ((curfile todo-current-todo-file))
+ (should (equal curfile todo-test-archive-1))
+ (todo-edit-file)
+ (should (equal todo-current-todo-file curfile)))))
+
+(ert-deftest todo-test-edit-quit () ; bug#32437
+ "Test result of exiting todo-edit-mode on a whole file.
+Exiting should return to the same todo-mode or todo-archive-mode
+buffer from which the editing command was invoked."
+ (with-todo-test
+ (todo-test--show 1)
+ (let ((buf (current-buffer)))
+ (todo-edit-file)
+ (todo-edit-quit)
+ (should (eq (current-buffer) buf))
+ (should (eq major-mode 'todo-mode))
+ (todo-find-archive)
+ (let ((buf (current-buffer)))
+ (todo-edit-file)
+ (todo-edit-quit)
+ (should (eq (current-buffer) buf))
+ (should (eq major-mode 'todo-archive-mode))))))
+
+(defun todo-test--add-file (file cat)
+ "Add file FILE with category CAT to todo-files and show it.
+This provides a noninteractive API for todo-add-file for use in
+automatic testing."
+ (let ((file0 (file-truename (concat todo-test-data-dir file ".todo")))
+ todo-add-item-if-new-category) ; Don't need an item in cat.
+ (cl-letf (((symbol-function 'todo-read-file-name)
+ (lambda (_prompt) file0))
+ ((symbol-function 'todo-read-category)
+ (lambda (_prompt &optional _match-type _file) (cons cat file0))))
+ (call-interactively 'todo-add-file) ; Interactive to call todo-show.
+ (todo-add-category file0 cat))))
+
+(defun todo-test--delete-file ()
+ "Delete current todo file without prompting."
+ (cl-letf (((symbol-function 'yes-or-no-p)
+ (lambda (_prompt) t)))
+ (todo-delete-file)))
+
+(ert-deftest todo-test-add-and-delete-file () ; bug#32627
+ "Test adding a new todo file and then deleting it.
+Calling todo-show should display the last current todo file, not
+necessarily the new file. After deleting the new file, todo-show
+should display the previously current (or default) todo file."
+ (with-todo-test
+ (todo-show)
+ (should (equal todo-current-todo-file todo-test-file-1))
+ (let* ((file (concat todo-directory "todo-test-2.todo"))
+ (file-nb (file-name-base file))
+ (cat "cat21"))
+ (todo-test--add-file file-nb cat) ; Add new file and show it.
+ (should (equal todo-current-todo-file file))
+ (todo-quit) ; Quitting todo-mode displays previous buffer.
+ (should (equal todo-current-todo-file todo-test-file-1))
+ (switch-to-buffer "*scratch*")
+ (todo-show) ; Show the last current todo-file (not the new one).
+ (should (equal todo-current-todo-file todo-test-file-1))
+ (switch-to-buffer (get-file-buffer file)) ; Back to new file.
+ (should (equal todo-current-todo-file file))
+ (todo-test--delete-file)
+ (todo-show) ; Back to old file.
+ (should (equal todo-current-todo-file todo-test-file-1))
+ (delete-file (concat file "~")))))
+
(provide 'todo-mode-tests)
;;; todo-mode-tests.el ends here
diff --git a/test/lisp/char-fold-tests.el b/test/lisp/char-fold-tests.el
index 51c64145f8b..8a647bd0765 100644
--- a/test/lisp/char-fold-tests.el
+++ b/test/lisp/char-fold-tests.el
@@ -117,16 +117,14 @@
(char-fold-to-regexp string)))
(with-temp-buffer
(save-excursion (insert string))
- (let ((time (time-to-seconds (current-time))))
+ (let ((time (time-to-seconds)))
;; Our initial implementation of case-folding in char-folding
;; created a lot of redundant paths in the regexp. Because of
;; that, if a really long string "almost" matches, the regexp
;; engine took a long time to realize that it doesn't match.
(should-not (char-fold-search-forward (concat string "c") nil 'noerror))
;; Ensure it took less than a second.
- (should (< (- (time-to-seconds (current-time))
- time)
- 1))))))
+ (should (< (- (time-to-seconds) time) 1))))))
(provide 'char-fold-tests)
;;; char-fold-tests.el ends here
diff --git a/test/lisp/comint-tests.el b/test/lisp/comint-tests.el
index 468feeaa1ac..49e59c526f4 100644
--- a/test/lisp/comint-tests.el
+++ b/test/lisp/comint-tests.el
@@ -36,9 +36,10 @@
"Enter same passphrase again: " ; ssh-keygen
"Passphrase for key root@GNU.ORG: " ; plink
"[sudo] password for user:" ; Ubuntu sudo
+ "[sudo] user 的密码:" ; localized
"Password (again):"
"Enter password:"
- "Mot de Passe:" ; localized
+ "Mot de Passe :" ; localized (Bug#29729)
"Passwort:") ; localized
"List of strings that should match `comint-password-prompt-regexp'.")
diff --git a/test/lisp/custom-resources/custom--test-theme.el b/test/lisp/custom-resources/custom--test-theme.el
new file mode 100644
index 00000000000..da9121e0a0a
--- /dev/null
+++ b/test/lisp/custom-resources/custom--test-theme.el
@@ -0,0 +1,9 @@
+(deftheme custom--test
+ "A test theme.")
+
+(custom-theme-set-variables
+ 'custom--test
+ '(custom--test-user-option 'bar)
+ '(custom--test-variable 'bar))
+
+(provide-theme 'custom--test)
diff --git a/test/lisp/custom-tests.el b/test/lisp/custom-tests.el
new file mode 100644
index 00000000000..0c49db6c76d
--- /dev/null
+++ b/test/lisp/custom-tests.el
@@ -0,0 +1,126 @@
+;;; custom-tests.el --- tests for custom.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2018-2019 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 this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+
+(ert-deftest custom-theme--load-path ()
+ "Test `custom-theme--load-path' behavior."
+ (let ((tmpdir (file-name-as-directory (make-temp-file "custom-tests-" t))))
+ (unwind-protect
+ ;; Create all temporary files under the same deletable parent.
+ (let ((temporary-file-directory tmpdir))
+ ;; Path is empty.
+ (let ((custom-theme-load-path ()))
+ (should (null (custom-theme--load-path))))
+
+ ;; Path comprises non-existent file.
+ (let* ((name (make-temp-name tmpdir))
+ (custom-theme-load-path (list name)))
+ (should (not (file-exists-p name)))
+ (should (null (custom-theme--load-path))))
+
+ ;; Path comprises existing file.
+ (let* ((file (make-temp-file "file"))
+ (custom-theme-load-path (list file)))
+ (should (file-exists-p file))
+ (should (not (file-directory-p file)))
+ (should (null (custom-theme--load-path))))
+
+ ;; Path comprises existing directory.
+ (let* ((dir (make-temp-file "dir" t))
+ (custom-theme-load-path (list dir)))
+ (should (file-directory-p dir))
+ (should (equal (custom-theme--load-path) custom-theme-load-path)))
+
+ ;; Expand `custom-theme-directory' path element.
+ (let ((custom-theme-load-path '(custom-theme-directory)))
+ (let ((custom-theme-directory (make-temp-name tmpdir)))
+ (should (not (file-exists-p custom-theme-directory)))
+ (should (null (custom-theme--load-path))))
+ (let ((custom-theme-directory (make-temp-file "file")))
+ (should (file-exists-p custom-theme-directory))
+ (should (not (file-directory-p custom-theme-directory)))
+ (should (null (custom-theme--load-path))))
+ (let ((custom-theme-directory (make-temp-file "dir" t)))
+ (should (file-directory-p custom-theme-directory))
+ (should (equal (custom-theme--load-path)
+ (list custom-theme-directory)))))
+
+ ;; Expand t path element.
+ (let ((custom-theme-load-path '(t)))
+ (let ((data-directory (make-temp-name tmpdir)))
+ (should (not (file-exists-p data-directory)))
+ (should (null (custom-theme--load-path))))
+ (let ((data-directory tmpdir)
+ (themedir (expand-file-name "themes" tmpdir)))
+ (should (not (file-exists-p themedir)))
+ (should (null (custom-theme--load-path)))
+ (with-temp-file themedir)
+ (should (file-exists-p themedir))
+ (should (not (file-directory-p themedir)))
+ (should (null (custom-theme--load-path)))
+ (delete-file themedir)
+ (make-directory themedir)
+ (should (file-directory-p themedir))
+ (should (equal (custom-theme--load-path) (list themedir))))))
+ (when (file-directory-p tmpdir)
+ (delete-directory tmpdir t)))))
+
+(defcustom custom--test-user-option 'foo
+ "User option for test."
+ :group 'emacs
+ :type 'symbol)
+
+(defvar custom--test-variable 'foo
+ "Variable for test.")
+
+;; This is demonstrating bug#34027.
+(ert-deftest custom--test-theme-variables ()
+ "Test variables setting with enabling / disabling a custom theme."
+ :expected-result :failed
+ ;; We load custom-resources/custom--test-theme.el.
+ (let ((custom-theme-load-path
+ `(,(expand-file-name "custom-resources" (file-name-directory #$)))))
+ (load-theme 'custom--test 'no-confirm 'no-enable)
+ ;; The variables have still their initial values.
+ (should (equal custom--test-user-option 'foo))
+ (should (equal custom--test-variable 'foo))
+
+ (custom-set-variables
+ '(custom--test-user-option 'baz)
+ '(custom--test-variable 'baz))
+ ;; The initial values have been changed.
+ (should (equal custom--test-user-option 'baz))
+ (should (equal custom--test-variable 'baz))
+
+ (enable-theme 'custom--test)
+ ;; The variables have the theme values.
+ (should (equal custom--test-user-option 'bar))
+ (should (equal custom--test-variable 'bar))
+
+ (disable-theme 'custom--test)
+ ;; The variables should have the changed values, by reverting.
+ ;; This doesn't work as expected. Instead, they have their
+ ;; initial values `foo'.
+ (should (equal custom--test-user-option 'baz))
+ (should (equal custom--test-variable 'baz))))
+
+;;; custom-tests.el ends here
diff --git a/test/lisp/dired-aux-tests.el b/test/lisp/dired-aux-tests.el
index 6c368359525..ccd3192792d 100644
--- a/test/lisp/dired-aux-tests.el
+++ b/test/lisp/dired-aux-tests.el
@@ -20,7 +20,7 @@
;;; Code:
(require 'ert)
(require 'dired-aux)
-
+(eval-when-compile (require 'cl-lib))
(ert-deftest dired-test-bug27496 ()
"Test for https://debbugs.gnu.org/27496 ."
@@ -40,5 +40,80 @@
(should-not (dired-do-shell-command "ls ? ./`?`" nil files)))
(delete-file foo))))
+;; Auxiliar macro for `dired-test-bug28834': it binds
+;; `dired-create-destination-dirs' to CREATE-DIRS and execute BODY.
+;; If YES-OR-NO is non-nil, it binds `yes-or-no-p' to
+;; to avoid the prompt.
+(defmacro with-dired-bug28834-test (create-dirs yes-or-no &rest body)
+ (declare (debug (form symbolp body)))
+ (let ((foo (make-symbol "foo")))
+ `(let* ((,foo (make-temp-file "foo" 'dir))
+ (dired-create-destination-dirs ,create-dirs))
+ (setq from (make-temp-file "from"))
+ (setq to-cp
+ (expand-file-name
+ "foo-cp" (file-name-as-directory (expand-file-name "bar" ,foo))))
+ (setq to-mv
+ (expand-file-name
+ "foo-mv" (file-name-as-directory (expand-file-name "qux" ,foo))))
+ (unwind-protect
+ (if ,yes-or-no
+ (cl-letf (((symbol-function 'yes-or-no-p)
+ (lambda (_prompt) (eq ,yes-or-no 'yes))))
+ ,@body)
+ ,@body)
+ ;; clean up
+ (delete-directory ,foo 'recursive)
+ (delete-file from)))))
+
+(ert-deftest dired-test-bug28834 ()
+ "test for https://debbugs.gnu.org/28834 ."
+ (let (from to-cp to-mv)
+ ;; `dired-create-destination-dirs' set to 'always.
+ (with-dired-bug28834-test
+ 'always nil
+ (dired-copy-file-recursive from to-cp nil)
+ (should (file-exists-p to-cp))
+ (dired-rename-file from to-mv nil)
+ (should (file-exists-p to-mv)))
+ ;; `dired-create-destination-dirs' set to nil.
+ (with-dired-bug28834-test
+ nil nil
+ (should-error (dired-copy-file-recursive from to-cp nil))
+ (should-error (dired-rename-file from to-mv nil)))
+ ;; `dired-create-destination-dirs' set to 'ask.
+ (with-dired-bug28834-test
+ 'ask 'yes ; Answer `yes'
+ (dired-copy-file-recursive from to-cp nil)
+ (should (file-exists-p to-cp))
+ (dired-rename-file from to-mv nil)
+ (should (file-exists-p to-mv)))
+ (with-dired-bug28834-test
+ 'ask 'no ; Answer `no'
+ (should-error (dired-copy-file-recursive from to-cp nil))
+ (should-error (dired-rename-file from to-mv nil)))))
+
+(ert-deftest dired-test-bug30624 ()
+ "test for https://debbugs.gnu.org/30624 ."
+ (cl-letf* ((target-dir (make-temp-file "target" 'dir))
+ ((symbol-function 'dired-mark-read-file-name)
+ (lambda (&rest _) target-dir))
+ (inhibit-message t))
+ ;; Delete target-dir: `dired-do-create-files' must recreate it.
+ (delete-directory target-dir)
+ (let ((file1 (make-temp-file "bug30624_file1"))
+ (file2 (make-temp-file "bug30624_file2"))
+ (dired-create-destination-dirs 'always)
+ (buf (dired temporary-file-directory)))
+ (unwind-protect
+ (progn
+ (dired-revert)
+ (dired-mark-files-regexp "bug30624_file")
+ (should (dired-do-create-files 'copy 'dired-copy-file "Copy" nil)))
+ (delete-directory target-dir 'recursive)
+ (mapc #'delete-file `(,file1 ,file2))
+ (kill-buffer buf)))))
+
+
(provide 'dired-aux-tests)
;; dired-aux-tests.el ends here
diff --git a/test/lisp/dired-tests.el b/test/lisp/dired-tests.el
index 12b6fffbd60..71ffcdd5458 100644
--- a/test/lisp/dired-tests.el
+++ b/test/lisp/dired-tests.el
@@ -210,12 +210,12 @@
(concat (file-name-as-directory test-dir)
(file-name-as-directory "test-subdir"))))
(push (dired-find-file) buffers)
- (let ((pt2 (point))) ; Point is on test-file.
- (switch-to-buffer buf)
- ;; Sanity check: point should now be back on the subdirectory.
- (should (eq (point) pt1))
- (push (dired test-dir) buffers)
- (should (eq (point) pt1))))
+ ;; Point is on test-file.
+ (switch-to-buffer buf)
+ ;; Sanity check: point should now be back on the subdirectory.
+ (should (eq (point) pt1))
+ (push (dired test-dir) buffers)
+ (should (eq (point) pt1)))
(dolist (buf buffers)
(when (buffer-live-p buf) (kill-buffer buf)))
(delete-directory test-dir t))))
@@ -224,7 +224,7 @@
"Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#61 ."
(let ((test-dir (make-temp-file "test-dir-" t))
(dired-auto-revert-buffer t)
- test-subdir1 test-subdir2 allbufs)
+ allbufs)
(unwind-protect
(progn
(with-current-buffer (find-file-noselect test-dir)
@@ -294,9 +294,9 @@
(ert-deftest dired-test-bug27899 ()
"Test for https://debbugs.gnu.org/27899 ."
- (let* ((dir (expand-file-name "src" source-directory))
- (buf (dired (list dir "cygw32.c" "alloc.c" "w32xfns.c" "xdisp.c")))
- (orig dired-hide-details-mode))
+ (dired (list (expand-file-name "src" source-directory)
+ "cygw32.c" "alloc.c" "w32xfns.c" "xdisp.c"))
+ (let ((orig dired-hide-details-mode))
(dired-goto-file (expand-file-name "cygw32.c"))
(forward-line 0)
(unwind-protect
@@ -362,8 +362,7 @@
(defmacro dired-test-with-temp-dirs (just-empty-dirs &rest body)
"Helper macro for Bug#27940 test."
(declare (indent 1) (debug body))
- (let ((dir (make-symbol "dir"))
- (ignore-funcs (make-symbol "ignore-funcs")))
+ (let ((dir (make-symbol "dir")))
`(let* ((,dir (make-temp-file "bug27940" t))
(dired-deletion-confirmer (lambda (_) "yes")) ; Suppress prompts.
(inhibit-message t)
diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el
index 55fefcebd79..4f1e5729be1 100644
--- a/test/lisp/electric-tests.el
+++ b/test/lisp/electric-tests.el
@@ -114,14 +114,30 @@
mode
extra-desc))
()
- ,(format "With |%s|, try input %c at point %d. \
-Should %s |%s| and point at %d"
+ ,(format "Electricity test in a `%s' buffer.\n
+Start with point at %d in a %d-char-long buffer
+like this one:
+
+ |%s| (buffer start and end are denoted by `|')
+%s
+%s
+Now press the key for: %c
+
+The buffer's contents should %s:
+
+ |%s|
+
+, and point should be at %d."
+ mode
+ (1+ pos)
+ (length fixture)
fixture
+ (if fixture-fn (format "\nNow call this:\n\n%s"
+ (pp-to-string fixture-fn)) "")
+ (if bindings (format "\nEnsure the following bindings:\n\n%s"
+ (pp-to-string bindings)) "")
char
- (1+ pos)
- (if (string= fixture expected-string)
- "stay"
- "become")
+ (if (string= fixture expected-string) "stay" "become")
(replace-regexp-in-string "\n" "\\\\n" expected-string)
expected-point)
(electric-pair-test-for ,fixture
@@ -141,7 +157,7 @@ Should %s |%s| and point at %d"
expected-string
expected-point
bindings
- (modes '(quote (ruby-mode c++-mode)))
+ (modes '(quote (ruby-mode js-mode)))
(test-in-comments t)
(test-in-strings t)
(test-in-code t)
@@ -163,9 +179,9 @@ Should %s |%s| and point at %d"
""
"-in-comments")))
(if test-in-strings
- `(("\"" "\"" "-in-strings")))
+ '(("\"" "\"" "-in-strings")))
(if test-in-code
- `(("" "" ""))))
+ '(("" "" ""))))
append
(cl-loop
for char across input
@@ -375,6 +391,23 @@ baz\"\""
:bindings '((electric-pair-skip-whitespace . chomp))
:test-in-comments nil)
+(ert-deftest electric-pair-whitespace-chomping-2-at-point-4-in-c++-mode-in-strings nil
+ "Check if whitespace chomping works in `c++' unterminated strings."
+ (electric-pair-test-for
+ "\" ( \n \n ) \"" 4 41 "\" () \"" 5 'c++-mode
+ '((electric-pair-skip-whitespace . chomp))
+ (lambda () (electric-pair-mode 1))))
+;; A test failure introduced by:
+;;
+;; bb591f139f: Enhance CC Mode's fontification, etc., of unterminated strings.
+;;
+;; Hopefully CC mode will sort this out eventually. See
+;; https://lists.gnu.org/archive/html/emacs-devel/2018-06/msg00535.html
+(setf
+ (ert-test-expected-result-type
+ (ert-get-test 'electric-pair-whitespace-chomping-2-at-point-4-in-c++-mode-in-strings))
+ :failed)
+
(define-electric-pair-test whitespace-chomping-dont-cross-comments
" ( \n\t\t\n ) " "--)------" :expected-string " () \n\t\t\n ) "
:expected-point 4
@@ -481,6 +514,7 @@ baz\"\""
:fixture-fn #'(lambda ()
(electric-pair-mode 1)))
+
(define-electric-pair-test js-mode-braces-with-layout
"" "{" :expected-string "{\n\n}" :expected-point 3
:modes '(js-mode)
@@ -500,6 +534,16 @@ baz\"\""
(electric-indent-mode 1)
(electric-layout-mode 1)))
+(define-electric-pair-test js-mode-braces-with-layout-and-indent
+ "" "{" :expected-string "{\n \n}" :expected-point 7
+ :modes '(js-mode)
+ :test-in-comments nil
+ :test-in-strings nil
+ :fixture-fn #'(lambda ()
+ (electric-pair-mode 1)
+ (electric-indent-mode 1)
+ (electric-layout-mode 1)))
+
;;; Backspacing
;;; TODO: better tests
@@ -617,6 +661,12 @@ baz\"\""
:fixture-fn #'electric-quote-local-mode
:test-in-comments nil :test-in-strings nil)
+(define-electric-pair-test electric-quote-replace-double-disabled
+ "" "\"" :expected-string "\"" :expected-point 2
+ :modes '(text-mode)
+ :fixture-fn #'electric-quote-local-mode
+ :test-in-comments nil :test-in-strings nil)
+
(define-electric-pair-test electric-quote-context-sensitive-backtick
"" "`" :expected-string "`" :expected-point 2
:modes '(text-mode)
@@ -638,6 +688,13 @@ baz\"\""
:bindings '((electric-quote-context-sensitive . t))
:test-in-comments nil :test-in-strings nil)
+(define-electric-pair-test electric-quote-replace-double-bob
+ "" "\"" :expected-string "“" :expected-point 2
+ :modes '(text-mode)
+ :fixture-fn #'electric-quote-local-mode
+ :bindings '((electric-quote-replace-double . t))
+ :test-in-comments nil :test-in-strings nil)
+
(define-electric-pair-test electric-quote-context-sensitive-bol-single
"a\n" "--'" :expected-string "a\n‘" :expected-point 4
:modes '(text-mode)
@@ -652,6 +709,13 @@ baz\"\""
:bindings '((electric-quote-context-sensitive . t))
:test-in-comments nil :test-in-strings nil)
+(define-electric-pair-test electric-quote-replace-double-bol
+ "a\n" "--\"" :expected-string "a\n“" :expected-point 4
+ :modes '(text-mode)
+ :fixture-fn #'electric-quote-local-mode
+ :bindings '((electric-quote-replace-double . t))
+ :test-in-comments nil :test-in-strings nil)
+
(define-electric-pair-test electric-quote-context-sensitive-after-space-single
" " "-'" :expected-string " ‘" :expected-point 3
:modes '(text-mode)
@@ -666,6 +730,13 @@ baz\"\""
:bindings '((electric-quote-context-sensitive . t))
:test-in-comments nil :test-in-strings nil)
+(define-electric-pair-test electric-quote-replace-double-after-space
+ " " "-\"" :expected-string " “" :expected-point 3
+ :modes '(text-mode)
+ :fixture-fn #'electric-quote-local-mode
+ :bindings '((electric-quote-replace-double . t))
+ :test-in-comments nil :test-in-strings nil)
+
(define-electric-pair-test electric-quote-context-sensitive-after-letter-single
"a" "-'" :expected-string "a’" :expected-point 3
:modes '(text-mode)
@@ -680,6 +751,13 @@ baz\"\""
:bindings '((electric-quote-context-sensitive . t))
:test-in-comments nil :test-in-strings nil)
+(define-electric-pair-test electric-quote-replace-double-after-letter
+ "a" "-\"" :expected-string "a”" :expected-point 3
+ :modes '(text-mode)
+ :fixture-fn #'electric-quote-local-mode
+ :bindings '((electric-quote-replace-double . t))
+ :test-in-comments nil :test-in-strings nil)
+
(define-electric-pair-test electric-quote-context-sensitive-after-paren-single
"(" "-'" :expected-string "(‘" :expected-point 3
:modes '(text-mode)
@@ -694,6 +772,38 @@ baz\"\""
:bindings '((electric-quote-context-sensitive . t))
:test-in-comments nil :test-in-strings nil)
+(define-electric-pair-test electric-quote-replace-double-after-paren
+ "(" "-\"" :expected-string "(“" :expected-point 3
+ :modes '(text-mode)
+ :fixture-fn #'electric-quote-local-mode
+ :bindings '((electric-quote-replace-double . t))
+ :test-in-comments nil :test-in-strings nil)
+
+(define-electric-pair-test electric-quote-replace-double-no-context-single
+ " " "-'" :expected-string " ’" :expected-point 3
+ :modes '(text-mode)
+ :fixture-fn #'electric-quote-local-mode
+ :bindings '((electric-quote-replace-double . t))
+ :test-in-comments nil :test-in-strings nil)
+
+(define-electric-pair-test electric-quote-replace-double-escaped-open
+ "foo \\" "-----\"" :expected-string "foo \\“"
+ :expected-point 7 :modes '(emacs-lisp-mode c-mode)
+ :fixture-fn #'electric-quote-local-mode
+ :bindings '((electric-quote-replace-double . t)
+ (electric-quote-comment . t)
+ (electric-quote-string . t))
+ :test-in-comments t :test-in-strings t :test-in-code nil)
+
+(define-electric-pair-test electric-quote-replace-double-escaped-close
+ "foo \\“foo\\" "----------\"" :expected-string "foo \\“foo\\”"
+ :expected-point 12 :modes '(emacs-lisp-mode c-mode)
+ :fixture-fn #'electric-quote-local-mode
+ :bindings '((electric-quote-replace-double . t)
+ (electric-quote-comment . t)
+ (electric-quote-string . t))
+ :test-in-comments t :test-in-strings t :test-in-code nil)
+
;; Simulate ‘markdown-mode’: it sets both ‘comment-start’ and
;; ‘comment-use-syntax’, but derives from ‘text-mode’.
(define-electric-pair-test electric-quote-markdown-in-text
@@ -720,5 +830,127 @@ baz\"\""
:bindings '((comment-start . "<!--") (comment-use-syntax . t))
:test-in-comments nil :test-in-strings nil)
+
+;;; tests for `electric-layout-mode'
+
+(define-derived-mode plainer-c-mode c-mode "pC"
+ "A plainer/saner C-mode with no internal electric machinery."
+ (c-toggle-electric-state -1)
+ (setq-local electric-indent-local-mode-hook nil)
+ (setq-local electric-indent-mode-hook nil)
+ (electric-indent-local-mode 1)
+ (dolist (key '(?\" ?\' ?\{ ?\} ?\( ?\) ?\[ ?\]))
+ (local-set-key (vector key) 'self-insert-command)))
+
+(defun electric-layout-for-c-style-du-jour (inserted)
+ "A function to use in `electric-layout-rules'"
+ (when (memq inserted '(?{ ?}))
+ (save-excursion
+ (backward-char 2) (c-point-syntax) (forward-char) ; silly, but needed
+ (c-brace-newlines (c-point-syntax)))))
+
+(ert-deftest electric-layout-plainer-c-mode-use-c-style ()
+ (ert-with-test-buffer ()
+ (plainer-c-mode)
+ (electric-layout-local-mode 1)
+ (electric-pair-local-mode 1)
+ (electric-indent-local-mode 1)
+ (setq-local electric-layout-rules
+ '(electric-layout-for-c-style-du-jour))
+ (insert "int main () ")
+ (let ((last-command-event ?\{))
+ (call-interactively (key-binding `[,last-command-event])))
+ (should (equal (buffer-string) "int main ()\n{\n \n}\n"))))
+
+(ert-deftest electric-layout-int-main-kernel-style ()
+ (ert-with-test-buffer ()
+ (plainer-c-mode)
+ (electric-layout-local-mode 1)
+ (electric-pair-local-mode 1)
+ (electric-indent-local-mode 1)
+ (setq-local electric-layout-rules
+ '((?\{ . (after))
+ (?\} . (before))))
+ (insert "int main () ")
+ (let ((last-command-event ?\{))
+ (call-interactively (key-binding `[,last-command-event])))
+ (should (equal (buffer-string) "int main () {\n \n}"))))
+
+(define-derived-mode plainer-c-mode c-mode "pC"
+ "A plainer/saner C-mode with no internal electric machinery."
+ (c-toggle-electric-state -1)
+ (setq-local electric-indent-local-mode-hook nil)
+ (setq-local electric-indent-mode-hook nil)
+ (electric-indent-local-mode 1)
+ (dolist (key '(?\" ?\' ?\{ ?\} ?\( ?\) ?\[ ?\]))
+ (local-set-key (vector key) 'self-insert-command)))
+
+(ert-deftest electric-modes-int-main-allman-style ()
+ (ert-with-test-buffer ()
+ (plainer-c-mode)
+ (electric-layout-local-mode 1)
+ (electric-pair-local-mode 1)
+ (electric-indent-local-mode 1)
+ (setq-local electric-layout-rules
+ '((?\{ . (before after))
+ (?\} . (before))))
+ (insert "int main () ")
+ (let ((last-command-event ?\{))
+ (call-interactively (key-binding `[,last-command-event])))
+ (should (equal (buffer-string) "int main ()\n{\n \n}"))))
+
+(ert-deftest electric-pair-mode-newline-between-parens ()
+ (ert-with-test-buffer ()
+ (plainer-c-mode)
+ (electric-layout-local-mode -1) ;; ensure e-l-m mode is off
+ (electric-pair-local-mode 1)
+ (insert-before-markers "int main () {}")
+ (backward-char 1)
+ (let ((last-command-event ? ))
+ (call-interactively (key-binding `[,last-command-event])))
+ (should (equal (buffer-string) "int main () {\n \n}"))))
+
+(ert-deftest electric-layout-mode-newline-between-parens-without-e-p-m ()
+ (ert-with-test-buffer ()
+ (plainer-c-mode)
+ (electric-layout-local-mode 1)
+ (electric-pair-local-mode -1) ;; ensure e-p-m mode is off
+ (electric-indent-local-mode 1)
+ (setq-local electric-layout-rules
+ '((?\n
+ .
+ (lambda ()
+ (when (eq (save-excursion
+ (skip-chars-backward "\t\s")
+ (char-before (1- (point))))
+ (matching-paren (char-after)))
+ '(after-stay))))))
+ (insert "int main () {}")
+ (backward-char 1)
+ (let ((last-command-event ? ))
+ (call-interactively (key-binding `[,last-command-event])))
+ (should (equal (buffer-string) "int main () {\n \n}"))))
+
+(ert-deftest electric-layout-mode-newline-between-parens-without-e-p-m-2 ()
+ (ert-with-test-buffer ()
+ (plainer-c-mode)
+ (electric-layout-local-mode 1)
+ (electric-pair-local-mode -1) ;; ensure e-p-m mode is off
+ (electric-indent-local-mode 1)
+ (setq-local electric-layout-rules
+ '((lambda (char)
+ (when (and
+ (eq char ?\n)
+ (eq (save-excursion
+ (skip-chars-backward "\t\s")
+ (char-before (1- (point))))
+ (matching-paren (char-after))))
+ '(after-stay)))))
+ (insert "int main () {}")
+ (backward-char 1)
+ (let ((last-command-event ? ))
+ (call-interactively (key-binding `[,last-command-event])))
+ (should (equal (buffer-string) "int main () {\n \n}"))))
+
(provide 'electric-tests)
;;; electric-tests.el ends here
diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el
new file mode 100644
index 00000000000..ce827e0166f
--- /dev/null
+++ b/test/lisp/emacs-lisp/backtrace-tests.el
@@ -0,0 +1,436 @@
+;;; backtrace-tests.el --- Tests for backtraces -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018-2019 Free Software Foundation, Inc.
+
+;; Author: Gemini Lasswell
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'backtrace)
+(require 'ert)
+(require 'ert-x)
+(require 'seq)
+
+;; Delay evaluation of the backtrace-creating functions until
+;; load so that the backtraces are the same whether this file
+;; is compiled or not.
+
+(eval-and-compile
+ (defconst backtrace-tests--uncompiled-functions
+ '(progn
+ (defun backtrace-tests--make-backtrace (arg)
+ (backtrace-tests--setup-buffer))
+
+ (defun backtrace-tests--setup-buffer ()
+ "Set up the current buffer in backtrace mode."
+ (backtrace-mode)
+ (setq backtrace-frames (backtrace-get-frames))
+ (let ((this-index))
+ ;; Discard all past `backtrace-tests-make-backtrace'.
+ (dotimes (index (length backtrace-frames))
+ (when (eq (backtrace-frame-fun (nth index backtrace-frames))
+ 'backtrace-tests--make-backtrace)
+ (setq this-index index)))
+ (setq backtrace-frames (seq-subseq backtrace-frames 0 (1+ this-index))))
+ (backtrace-print))))
+
+ (eval backtrace-tests--uncompiled-functions))
+
+(defun backtrace-tests--backtrace-lines ()
+ (if debugger-stack-frame-as-list
+ '(" (backtrace-get-frames)\n"
+ " (setq backtrace-frames (backtrace-get-frames))\n"
+ " (backtrace-tests--setup-buffer)\n"
+ " (backtrace-tests--make-backtrace %s)\n")
+ '(" backtrace-get-frames()\n"
+ " (setq backtrace-frames (backtrace-get-frames))\n"
+ " backtrace-tests--setup-buffer()\n"
+ " backtrace-tests--make-backtrace(%s)\n")))
+
+(defconst backtrace-tests--line-count (length (backtrace-tests--backtrace-lines)))
+
+(defun backtrace-tests--backtrace-lines-with-locals ()
+ (let ((lines (backtrace-tests--backtrace-lines))
+ (locals '(" [no locals]\n"
+ " [no locals]\n"
+ " [no locals]\n"
+ " arg = %s\n")))
+ (apply #'append (cl-mapcar #'list lines locals))))
+
+(defun backtrace-tests--result (value)
+ (format (apply #'concat (backtrace-tests--backtrace-lines))
+ (cl-prin1-to-string value)))
+
+(defun backtrace-tests--result-with-locals (value)
+ (let ((str (cl-prin1-to-string value)))
+ (format (apply #'concat (backtrace-tests--backtrace-lines-with-locals))
+ str str)))
+
+;; TODO check that debugger-batch-max-lines still works
+
+(defconst backtrace-tests--header "Test header\n")
+(defun backtrace-tests--insert-header ()
+ (insert backtrace-tests--header))
+
+;;; Tests
+
+(ert-deftest backtrace-tests--variables ()
+ "Backtrace buffers can show and hide local variables."
+ (ert-with-test-buffer (:name "variables")
+ (let ((results (concat backtrace-tests--header
+ (backtrace-tests--result 'value)))
+ (last-frame (format (nth (1- backtrace-tests--line-count)
+ (backtrace-tests--backtrace-lines)) 'value))
+ (last-frame-with-locals
+ (format (apply #'concat (nthcdr (* 2 (1- backtrace-tests--line-count))
+ (backtrace-tests--backtrace-lines-with-locals)))
+ 'value 'value)))
+ (backtrace-tests--make-backtrace 'value)
+ (setq backtrace-insert-header-function #'backtrace-tests--insert-header)
+ (backtrace-print)
+ (should (string= (backtrace-tests--get-substring (point-min) (point-max))
+ results))
+ ;; Go to the last frame.
+ (goto-char (point-max))
+ (forward-line -1)
+ ;; Turn on locals for that frame.
+ (backtrace-toggle-locals)
+ (should (string= (backtrace-tests--get-substring (point) (point-max))
+ last-frame-with-locals))
+ (should (string= (backtrace-tests--get-substring (point-min) (point-max))
+ (concat results
+ (format (car (last (backtrace-tests--backtrace-lines-with-locals)))
+ 'value))))
+ ;; Turn off locals for that frame.
+ (backtrace-toggle-locals)
+ (should (string= (backtrace-tests--get-substring (point) (point-max))
+ last-frame))
+ (should (string= (backtrace-tests--get-substring (point-min) (point-max))
+ results))
+ ;; Turn all locals on.
+ (backtrace-toggle-locals '(4))
+ (should (string= (backtrace-tests--get-substring (point) (point-max))
+ last-frame-with-locals))
+ (should (string= (backtrace-tests--get-substring (point-min) (point-max))
+ (concat backtrace-tests--header
+ (backtrace-tests--result-with-locals 'value))))
+ ;; Turn all locals off.
+ (backtrace-toggle-locals '(4))
+ (should (string= (backtrace-tests--get-substring
+ (point) (+ (point) (length last-frame)))
+ last-frame))
+ (should (string= (backtrace-tests--get-substring (point-min) (point-max))
+ results)))))
+
+(ert-deftest backtrace-tests--backward-frame ()
+ "`backtrace-backward-frame' moves backward to the start of a frame."
+ (ert-with-test-buffer (:name "backward")
+ (let ((results (concat backtrace-tests--header
+ (backtrace-tests--result nil))))
+ (backtrace-tests--make-backtrace nil)
+ (setq backtrace-insert-header-function #'backtrace-tests--insert-header)
+ (backtrace-print)
+ (should (string= (backtrace-tests--get-substring (point-min) (point-max))
+ results))
+
+ ;; Try to move backward from header.
+ (goto-char (+ (point-min) (/ (length backtrace-tests--header) 2)))
+ (let ((pos (point)))
+ (should-error (backtrace-backward-frame))
+ (should (= pos (point))))
+
+ ;; Try to move backward from start of first line.
+ (forward-line)
+ (let ((pos (point)))
+ (should-error (backtrace-backward-frame))
+ (should (= pos (point))))
+
+ ;; Move backward from middle of line.
+ (let ((start (point)))
+ (forward-char (/ (length (nth 0 (backtrace-tests--backtrace-lines))) 2))
+ (backtrace-backward-frame)
+ (should (= start (point))))
+
+ ;; Move backward from end of buffer.
+ (goto-char (point-max))
+ (backtrace-backward-frame)
+ (let* ((last (format (car (last (backtrace-tests--backtrace-lines))) nil))
+ (len (length last)))
+ (should (string= (buffer-substring-no-properties (point) (+ (point) len))
+ last)))
+
+ ;; Move backward from start of line.
+ (backtrace-backward-frame)
+ (let* ((line (car (last (backtrace-tests--backtrace-lines) 2)))
+ (len (length line)))
+ (should (string= (buffer-substring-no-properties (point) (+ (point) len))
+ line))))))
+
+(ert-deftest backtrace-tests--forward-frame ()
+ "`backtrace-forward-frame' moves forward to the start of a frame."
+ (ert-with-test-buffer (:name "forward")
+ (let* ((arg '(1 2 3))
+ (results (concat backtrace-tests--header
+ (backtrace-tests--result arg)))
+ (first-line (nth 0 (backtrace-tests--backtrace-lines))))
+ (backtrace-tests--make-backtrace arg)
+ (setq backtrace-insert-header-function #'backtrace-tests--insert-header)
+ (backtrace-print)
+ (should (string= (backtrace-tests--get-substring (point-min) (point-max))
+ results))
+ ;; Move forward from header.
+ (goto-char (+ (point-min) (/ (length backtrace-tests--header) 2)))
+ (backtrace-forward-frame)
+ (should (string= (backtrace-tests--get-substring
+ (point) (+ (point) (length first-line)))
+ first-line))
+
+ (let ((start (point))
+ (offset (/ (length first-line) 2))
+ (second-line (nth 1 (backtrace-tests--backtrace-lines))))
+ ;; Move forward from start of first frame.
+ (backtrace-forward-frame)
+ (should (string= (backtrace-tests--get-substring
+ (point) (+ (point) (length second-line)))
+ second-line))
+ ;; Move forward from middle of first frame.
+ (goto-char (+ start offset))
+ (backtrace-forward-frame)
+ (should (string= (backtrace-tests--get-substring
+ (point) (+ (point) (length second-line)))
+ second-line)))
+ ;; Try to move forward from middle of last frame.
+ (goto-char (- (point-max)
+ (/ 2 (length (car (last (backtrace-tests--backtrace-lines)))))))
+ (should-error (backtrace-forward-frame))
+ ;; Try to move forward from end of buffer.
+ (goto-char (point-max))
+ (should-error (backtrace-forward-frame)))))
+
+(ert-deftest backtrace-tests--single-and-multi-line ()
+ "Forms in backtrace frames can be on a single line or on multiple lines."
+ (ert-with-test-buffer (:name "single-multi-line")
+ (let* ((arg '(lambda (x) ; Quote this so it isn't made into a closure.
+ (let ((number (1+ x)))
+ (+ x number))))
+ (header-string "Test header: ")
+ (header (format "%s%s\n" header-string arg))
+ (insert-header-function (lambda ()
+ (insert header-string)
+ (insert (backtrace-print-to-string arg))
+ (insert "\n")))
+ (results (concat header (backtrace-tests--result arg)))
+ (last-line (format (nth (1- backtrace-tests--line-count)
+ (backtrace-tests--backtrace-lines))
+ arg))
+ (last-line-locals (format (nth (1- (* 2 backtrace-tests--line-count))
+ (backtrace-tests--backtrace-lines-with-locals))
+ arg)))
+
+ (backtrace-tests--make-backtrace arg)
+ (setq backtrace-insert-header-function insert-header-function)
+ (backtrace-print)
+ (should (string= (backtrace-tests--get-substring (point-min) (point-max))
+ results))
+ ;; Check pp and collapse for the form in the header.
+ (goto-char (point-min))
+ (backtrace-tests--verify-single-and-multi-line header)
+ ;; Check pp and collapse for the last frame.
+ (goto-char (point-max))
+ (backtrace-backward-frame)
+ (backtrace-tests--verify-single-and-multi-line last-line)
+ ;; Check pp and collapse for local variables in the last line.
+ (goto-char (point-max))
+ (backtrace-backward-frame)
+ (backtrace-toggle-locals)
+ (forward-line)
+ (backtrace-tests--verify-single-and-multi-line last-line-locals))))
+
+(defun backtrace-tests--verify-single-and-multi-line (line)
+ "Verify that `backtrace-single-line' and `backtrace-multi-line' work at point.
+Point should be at the beginning of a line, and LINE should be a
+string containing the text of the line at point. Assume that the
+line contains the strings \"lambda\" and \"number\"."
+ (let ((pos (point)))
+ (backtrace-multi-line)
+ ;; Verify point is still at the start of the line.
+ (should (= pos (point))))
+
+ ;; Verify the form now spans multiple lines.
+ (let ((pos (point)))
+ (search-forward "number")
+ (should-not (= pos (point-at-bol))))
+ ;; Collapse the form.
+ (backtrace-single-line)
+ ;; Verify that the form is now back on one line,
+ ;; and that point is at the same place.
+ (should (string= (backtrace-tests--get-substring
+ (- (point) 6) (point)) "number"))
+ (should-not (= (point) (point-at-bol)))
+ (should (string= (backtrace-tests--get-substring
+ (point-at-bol) (1+ (point-at-eol)))
+ line)))
+
+(ert-deftest backtrace-tests--print-circle ()
+ "Backtrace buffers can toggle `print-circle' syntax."
+ (ert-with-test-buffer (:name "print-circle")
+ (let* ((print-circle nil)
+ (arg (let ((val (make-list 5 'a))) (nconc val val) val))
+ (results (backtrace-tests--make-regexp
+ (backtrace-tests--result arg)))
+ (results-circle (regexp-quote (let ((print-circle t))
+ (backtrace-tests--result arg))))
+ (last-frame (backtrace-tests--make-regexp
+ (format (nth (1- backtrace-tests--line-count)
+ (backtrace-tests--backtrace-lines))
+ arg)))
+ (last-frame-circle (regexp-quote
+ (let ((print-circle t))
+ (format (nth (1- backtrace-tests--line-count)
+ (backtrace-tests--backtrace-lines))
+ arg)))))
+ (backtrace-tests--make-backtrace arg)
+ (backtrace-print)
+ (should (string-match-p results
+ (backtrace-tests--get-substring (point-min) (point-max))))
+ ;; Go to the last frame.
+ (goto-char (point-max))
+ (forward-line -1)
+ ;; Turn on print-circle for that frame.
+ (backtrace-toggle-print-circle)
+ (should (string-match-p last-frame-circle
+ (backtrace-tests--get-substring (point) (point-max))))
+ ;; Turn off print-circle for the frame.
+ (backtrace-toggle-print-circle)
+ (should (string-match-p last-frame
+ (backtrace-tests--get-substring (point) (point-max))))
+ (should (string-match-p results
+ (backtrace-tests--get-substring (point-min) (point-max))))
+ ;; Turn print-circle on for the buffer.
+ (backtrace-toggle-print-circle '(4))
+ (should (string-match-p last-frame-circle
+ (backtrace-tests--get-substring (point) (point-max))))
+ (should (string-match-p results-circle
+ (backtrace-tests--get-substring (point-min) (point-max))))
+ ;; Turn print-circle off.
+ (backtrace-toggle-print-circle '(4))
+ (should (string-match-p last-frame
+ (backtrace-tests--get-substring
+ (point) (+ (point) (length last-frame)))))
+ (should (string-match-p results
+ (backtrace-tests--get-substring (point-min) (point-max)))))))
+
+(defun backtrace-tests--make-regexp (str)
+ "Make regexp from STR for `backtrace-tests--print-circle'.
+Used for results of printing circular objects without
+`print-circle' on. Look for #n in string STR where n is any
+digit and replace with #[0-9]."
+ (let ((regexp (regexp-quote str)))
+ (with-temp-buffer
+ (insert regexp)
+ (goto-char (point-min))
+ (while (re-search-forward "#[0-9]" nil t)
+ (replace-match "#[0-9]")))
+ (buffer-string)))
+
+(ert-deftest backtrace-tests--expand-ellipsis ()
+ "Backtrace buffers ellipsify large forms as buttons which expand the ellipses."
+ ;; make a backtrace with an ellipsis
+ ;; expand the ellipsis
+ (ert-with-test-buffer (:name "variables")
+ (let* ((print-level nil)
+ (print-length nil)
+ (backtrace-line-length 300)
+ (arg (make-list 40 (make-string 10 ?a)))
+ (results (backtrace-tests--result arg)))
+ (backtrace-tests--make-backtrace arg)
+ (backtrace-print)
+
+ ;; There should be an ellipsis. Find and expand it.
+ (goto-char (point-min))
+ (search-forward "...")
+ (backward-char)
+ (push-button)
+
+ (should (string= (backtrace-tests--get-substring (point-min) (point-max))
+ results)))))
+
+(ert-deftest backtrace-tests--expand-ellipses ()
+ "Backtrace buffers ellipsify large forms and can expand the ellipses."
+ (ert-with-test-buffer (:name "variables")
+ (let* ((print-level nil)
+ (print-length nil)
+ (backtrace-line-length 300)
+ (arg (let ((outer (make-list 40 (make-string 10 ?a)))
+ (nested (make-list 40 (make-string 10 ?b))))
+ (setf (nth 39 nested) (make-list 40 (make-string 10 ?c)))
+ (setf (nth 39 outer) nested)
+ outer))
+ (results (backtrace-tests--result-with-locals arg)))
+
+ ;; Make a backtrace with local variables visible.
+ (backtrace-tests--make-backtrace arg)
+ (backtrace-print)
+ (backtrace-toggle-locals '(4))
+
+ ;; There should be two ellipses.
+ (goto-char (point-min))
+ (should (search-forward "..."))
+ (should (search-forward "..."))
+ (should-error (search-forward "..."))
+
+ ;; Expanding the last frame without argument should expand both
+ ;; ellipses, but the expansions will contain one ellipsis each.
+ (let ((buffer-len (- (point-max) (point-min))))
+ (goto-char (point-max))
+ (backtrace-backward-frame)
+ (backtrace-expand-ellipses)
+ (should (> (- (point-max) (point-min)) buffer-len))
+ (goto-char (point-min))
+ (should (search-forward "..."))
+ (should (search-forward "..."))
+ (should-error (search-forward "...")))
+
+ ;; Expanding with argument should remove all ellipses.
+ (goto-char (point-max))
+ (backtrace-backward-frame)
+ (backtrace-expand-ellipses '(4))
+ (goto-char (point-min))
+
+ (should-error (search-forward "..."))
+ (should (string= (backtrace-tests--get-substring (point-min) (point-max))
+ results)))))
+
+
+(ert-deftest backtrace-tests--to-string ()
+ "Backtraces can be produced as strings."
+ (let ((frames (ert-with-test-buffer (:name nil)
+ (backtrace-tests--make-backtrace "string")
+ backtrace-frames)))
+ (should (string= (backtrace-to-string frames)
+ (backtrace-tests--result "string")))))
+
+(defun backtrace-tests--get-substring (beg end)
+ "Return the visible text between BEG and END.
+Strip the string properties because it makes failed test results
+easier to read."
+ (substring-no-properties (filter-buffer-substring beg end)))
+
+(provide 'backtrace-tests)
+
+;;; backtrace-tests.el ends here
diff --git a/test/lisp/emacs-lisp/benchmark-tests.el b/test/lisp/emacs-lisp/benchmark-tests.el
index a4be6d30748..a8c37bbe836 100644
--- a/test/lisp/emacs-lisp/benchmark-tests.el
+++ b/test/lisp/emacs-lisp/benchmark-tests.el
@@ -23,29 +23,37 @@
(require 'ert)
(ert-deftest benchmark-tests ()
- (let (str t-long t-short)
- (should (consp (benchmark-run nil (1+ 0))))
- (should (consp (benchmark-run 1 (1+ 0))))
+ (let (str t-long t-short m)
+ (should (consp (benchmark-run nil (setq m (1+ 0)))))
+ (should (consp (benchmark-run 1 (setq m (1+ 0)))))
(should (stringp (benchmark nil (1+ 0))))
(should (stringp (benchmark 1 (1+ 0))))
- (should (consp (benchmark-run-compiled nil (1+ 0))))
+ (should (consp (benchmark-run-compiled (1+ 0))))
(should (consp (benchmark-run-compiled 1 (1+ 0))))
;; First test is heavier, must need longer time.
- (should (> (car (benchmark-run nil
+ (let ((count1 0)
+ (count2 0)
+ (repeat 2))
+ (ignore (benchmark-run (setq count1 (1+ count1))))
+ (ignore (benchmark-run repeat (setq count2 (1+ count2))))
+ (should (> count2 count1)))
+ (should (> (car (benchmark-run
(let ((n 100000)) (while (> n 1) (setq n (1- n))))))
- (car (benchmark-run nil (1+ 0)))))
- (should (> (car (benchmark-run nil
+ (car (benchmark-run (setq m (1+ 0))))))
+ (should (> (car (benchmark-run
(let ((n 100000)) (while (> n 1) (setq n (1- n))))))
- (car (benchmark-run nil (1+ 0)))))
- (should (> (car (benchmark-run-compiled nil
+ (car (benchmark-run (setq m (1+ 0))))))
+ (should (> (car (benchmark-run-compiled
(let ((n 100000)) (while (> n 1) (setq n (1- n))))))
- (car (benchmark-run-compiled nil (1+ 0)))))
+ (car (benchmark-run-compiled (1+ 0)))))
(setq str (benchmark nil '(let ((n 100000)) (while (> n 1) (setq n (1- n))))))
(string-match "Elapsed time: \\([0-9.]+\\)" str)
(setq t-long (string-to-number (match-string 1 str)))
(setq str (benchmark nil '(1+ 0)))
(string-match "Elapsed time: \\([0-9.]+\\)" str)
(setq t-short (string-to-number (match-string 1 str)))
- (should (> t-long t-short))))
+ (should (> t-long t-short))
+ ;; Silence compiler.
+ m))
;;; benchmark-tests.el ends here.
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index bc28c5a6a00..f66a06bc1bc 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -27,6 +27,7 @@
(require 'ert)
(require 'cl-lib)
+(require 'bytecomp)
;;; Code:
(defconst byte-opt-testsuite-arith-data
@@ -38,8 +39,7 @@
(let ((a 3) (b 2) (c 1.0)) (/ a b c))
(let ((a (+ 1 (expt 2 -64))) (b (expt 2 -65))) (+ a -1 b))
(let ((a (+ 1 (expt 2 -64))) (b (expt 2 -65))) (- a 1 (- b)))
- ;; This fails. Should it be a bug?
- ;; (let ((a (expt 2 -1074)) (b 0.125)) (* a 8 b))
+ (let ((a (expt 2 -1074)) (b 0.125)) (* a 8 b))
(let ((a 1.0)) (* a 0))
(let ((a 1.0)) (* a 2.0 0))
(let ((a 1.0)) (/ 0 a))
@@ -244,6 +244,9 @@
(let ((a 3) (b 2) (c 1.0)) (/ a b c 0))
(let ((a 3) (b 2) (c 1.0)) (/ a b c 1))
(let ((a 3) (b 2) (c 1.0)) (/ a b c -1))
+
+ (let ((a t)) (logand 0 a))
+
;; Test switch bytecode
(let ((a 3)) (cond ((eq a 1) 'one) ((eq a 2) 'two) ((eq a 3) 'three) (t t)))
(let ((a 'three)) (cond ((eq a 'one) 1) ((eq a 2) 'two) ((eq a 'three) 3)
@@ -541,23 +544,17 @@ literals (Bug#20852)."
(ert-deftest bytecomp-tests--old-style-backquotes ()
"Check that byte compiling warns about old-style backquotes."
- (should (boundp 'lread--old-style-backquotes))
(bytecomp-tests--with-temp-file source
(write-region "(` (a b))" nil source)
(bytecomp-tests--with-temp-file destination
(let* ((byte-compile-dest-file-function (lambda (_) destination))
- (byte-compile-error-on-warn t)
- (byte-compile-debug t)
- (err (should-error (byte-compile-file source))))
- (should (equal (cdr err)
- (list "!! The file uses old-style backquotes !!
-This functionality has been obsolete for more than 10 years already
-and will be removed soon. See (elisp)Backquote in the manual.")))))))
+ (byte-compile-debug t)
+ (err (should-error (byte-compile-file source))))
+ (should (equal (cdr err) '("Old-style backquotes detected!")))))))
(ert-deftest bytecomp-tests-function-put ()
"Check `function-put' operates during compilation."
- (should (boundp 'lread--old-style-backquotes))
(bytecomp-tests--with-temp-file source
(dolist (form '((function-put 'bytecomp-tests--foo 'foo 1)
(function-put 'bytecomp-tests--foo 'bar 2)
@@ -582,6 +579,38 @@ and will be removed soon. See (elisp)Backquote in the manual.")))))))
(goto-char (point-min))
(should-not (search-forward "Warning" nil t))))
+(ert-deftest bytecomp-test-featurep-warnings ()
+ (let ((byte-compile-log-buffer (generate-new-buffer " *Compile-Log*")))
+ (unwind-protect
+ (progn
+ (with-temp-buffer
+ (insert "\
+\(defun foo ()
+ (an-undefined-function))
+
+\(defun foo1 ()
+ (if (featurep 'xemacs)
+ (some-undefined-function-if)))
+
+\(defun foo2 ()
+ (and (featurep 'xemacs)
+ (some-undefined-function-and)))
+
+\(defun foo3 ()
+ (if (not (featurep 'emacs))
+ (some-undefined-function-not)))
+
+\(defun foo4 ()
+ (or (featurep 'emacs)
+ (some-undefined-function-or)))
+")
+ (byte-compile-from-buffer (current-buffer)))
+ (with-current-buffer byte-compile-log-buffer
+ (should (search-forward "an-undefined-function" nil t))
+ (should-not (search-forward "some-undefined-function" nil t))))
+ (if (buffer-live-p byte-compile-log-buffer)
+ (kill-buffer byte-compile-log-buffer)))))
+
;; Local Variables:
;; no-byte-compile: t
;; End:
diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el
new file mode 100644
index 00000000000..c218bd6382b
--- /dev/null
+++ b/test/lisp/emacs-lisp/cconv-tests.el
@@ -0,0 +1,40 @@
+;;; cconv-tests.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2018-2019 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+(require 'ert)
+
+(ert-deftest cconv-convert-lambda-lifted ()
+ "Bug#30872."
+ (should
+ (equal (funcall
+ (byte-compile
+ '#'(lambda (handle-fun arg)
+ (let* ((subfun
+ #'(lambda (params)
+ (ignore handle-fun)
+ (funcall #'(lambda () (setq params 42)))
+ params)))
+ (funcall subfun arg))))
+ nil 99)
+ 42)))
+
+(provide 'cconv-tests)
+;; cconv-tests.el ends here.
diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el
index cc29ca91147..82c2c0d8e01 100644
--- a/test/lisp/emacs-lisp/cl-lib-tests.el
+++ b/test/lisp/emacs-lisp/cl-lib-tests.el
@@ -201,6 +201,10 @@
:b :a :a 42)
'(42 :a))))
+(ert-deftest cl-lib-empty-keyargs ()
+ (should-error (funcall (cl-function (lambda (&key) 1))
+ :b 1)))
+
(cl-defstruct (mystruct
(:constructor cl-lib--con-1 (&aux (abc 1)))
(:constructor cl-lib--con-2 (&optional def) "Constructor docstring."))
@@ -216,7 +220,7 @@
(should-error (cl-struct-slot-offset 'mystruct 'marypoppins))
(should (pcase (cl-struct-slot-info 'mystruct)
(`((cl-tag-slot) (abc 5 :readonly t)
- (def . ,(or `nil `(nil))))
+ (def . ,(or 'nil '(nil))))
t)))))
(ert-deftest cl-lib-struct-constructors ()
(should (string-match "\\`Constructor docstring."
@@ -512,6 +516,17 @@
(ert-deftest cl-lib-symbol-macrolet-2 ()
(should (equal (cl-lib-symbol-macrolet-4+5) (+ 4 5))))
+
+(ert-deftest cl-lib-symbol-macrolet-hide ()
+ ;; bug#26325, bug#26073
+ (should (equal (let ((y 5))
+ (cl-symbol-macrolet ((x y))
+ (list x
+ (let ((x 6)) (list x y))
+ (cl-letf ((x 6)) (list x y))
+ (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)
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el
index 2c5925f15b4..989553bd7bd 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -497,4 +497,20 @@ collection clause."
vconcat (vector (1+ x)))
[2 3 4 5 6])))
+(ert-deftest cl-macs-loop-for-as-equals-and ()
+ "Test for https://debbugs.gnu.org/29799 ."
+ (let ((arr (make-vector 3 0)))
+ (should (equal '((0 0) (1 1) (2 2))
+ (cl-loop for k below 3 for x = k and z = (elt arr k)
+ collect (list k x))))))
+
+
+(ert-deftest cl-defstruct/builtin-type ()
+ (should-error
+ (macroexpand '(cl-defstruct hash-table))
+ :type 'wrong-type-argument)
+ (should-error
+ (macroexpand '(cl-defstruct (hash-table (:predicate hash-table-p))))
+ :type 'wrong-type-argument))
+
;;; cl-macs-tests.el ends here
diff --git a/test/lisp/emacs-lisp/cl-preloaded-tests.el b/test/lisp/emacs-lisp/cl-preloaded-tests.el
new file mode 100644
index 00000000000..3251b5ff0a2
--- /dev/null
+++ b/test/lisp/emacs-lisp/cl-preloaded-tests.el
@@ -0,0 +1,33 @@
+;;; cl-preloaded-tests.el --- unit tests for cl-preloaded.el -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017-2019 Free Software Foundation, Inc.
+;; Author: Philipp Stephani <phst@google.com>
+
+;; 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 this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Unit tests for lisp/emacs-lisp/cl-preloaded.el.
+
+;;; Code:
+
+(ert-deftest cl-struct-define/builtin-type ()
+ (should-error
+ (cl-struct-define 'hash-table nil nil 'record nil nil
+ 'cl-preloaded-tests-tag 'cl-preloaded-tests nil)
+ :type 'wrong-type-argument))
+
+;;; cl-preloaded-tests.el ends here
diff --git a/test/lisp/emacs-lisp/cl-print-tests.el b/test/lisp/emacs-lisp/cl-print-tests.el
index 6ba2f2fcede..406c528dce5 100644
--- a/test/lisp/emacs-lisp/cl-print-tests.el
+++ b/test/lisp/emacs-lisp/cl-print-tests.el
@@ -34,7 +34,7 @@
(let ((print-circle t))
(should (equal (cl-prin1-to-string `((x . ,x) (y . ,x)))
"((x . #1=#s(cl-print--test :a 1 :b 2)) (y . #1#))")))
- (should (string-match "\\`#f(compiled-function (x) \"[^\"]+\" [^\)]*)\\'"
+ (should (string-match "\\`#f(compiled-function (x) \"[^\"]+\" [^)]*)\\'"
(cl-prin1-to-string (symbol-function #'caar))))))
(ert-deftest cl-print-tests-2 ()
@@ -56,19 +56,30 @@
(let ((long-list (make-list 5 'a))
(long-vec (make-vector 5 'b))
(long-struct (cl-print-tests-con))
+ (long-string (make-string 5 ?a))
(print-length 4))
(should (equal "(a a a a ...)" (cl-prin1-to-string long-list)))
(should (equal "[b b b b ...]" (cl-prin1-to-string long-vec)))
(should (equal "#s(cl-print-tests-struct :a nil :b nil :c nil :d nil ...)"
- (cl-prin1-to-string long-struct)))))
+ (cl-prin1-to-string long-struct)))
+ (should (equal "\"aaaa...\"" (cl-prin1-to-string long-string)))))
(ert-deftest cl-print-tests-4 ()
"CL printing observes `print-level'."
- (let ((deep-list '(a (b (c (d (e))))))
- (deep-struct (cl-print-tests-con))
- (print-level 4))
+ (let* ((deep-list '(a (b (c (d (e))))))
+ (buried-vector '(a (b (c (d [e])))))
+ (deep-struct (cl-print-tests-con))
+ (buried-struct `(a (b (c (d ,deep-struct)))))
+ (buried-string '(a (b (c (d #("hello" 0 5 (cl-print-test t)))))))
+ (buried-simple-string '(a (b (c (d "hello")))))
+ (print-level 4))
(setf (cl-print-tests-struct-a deep-struct) deep-list)
(should (equal "(a (b (c (d ...))))" (cl-prin1-to-string deep-list)))
+ (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-vector)))
+ (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-struct)))
+ (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-string)))
+ (should (equal "(a (b (c (d \"hello\"))))"
+ (cl-prin1-to-string buried-simple-string)))
(should (equal "#s(cl-print-tests-struct :a (a (b (c ...))) :b nil :c nil :d nil :e nil)"
(cl-prin1-to-string deep-struct)))))
@@ -82,6 +93,129 @@
(should (equal "((quote a) (function b) (\\` ((\\, c) (\\,@ d))))"
(cl-prin1-to-string quoted-stuff))))))
+(ert-deftest cl-print-tests-strings ()
+ "CL printing prints strings and propertized strings."
+ (let* ((str1 "abcdefghij")
+ (str2 #("abcdefghij" 3 6 (bold t) 7 9 (italic t)))
+ (str3 #("abcdefghij" 0 10 (test t)))
+ (obj '(a b))
+ ;; Since the byte compiler reuses string literals,
+ ;; and the put-text-property call is destructive, use
+ ;; copy-sequence to make a new string.
+ (str4 (copy-sequence "abcdefghij")))
+ (put-text-property 0 5 'test obj str4)
+ (put-text-property 7 10 'test obj str4)
+
+ (should (equal "\"abcdefghij\"" (cl-prin1-to-string str1)))
+ (should (equal "#(\"abcdefghij\" 3 6 (bold t) 7 9 (italic t))"
+ (cl-prin1-to-string str2)))
+ (should (equal "#(\"abcdefghij\" 0 10 (test t))"
+ (cl-prin1-to-string str3)))
+ (let ((print-circle nil))
+ (should
+ (equal
+ "#(\"abcdefghij\" 0 5 (test (a b)) 7 10 (test (a b)))"
+ (cl-prin1-to-string str4))))
+ (let ((print-circle t))
+ (should
+ (equal
+ "#(\"abcdefghij\" 0 5 (test #1=(a b)) 7 10 (test #1#))"
+ (cl-prin1-to-string str4))))))
+
+(ert-deftest cl-print-tests-ellipsis-cons ()
+ "Ellipsis expansion works in conses."
+ (let ((print-length 4)
+ (print-level 3))
+ (cl-print-tests-check-ellipsis-expansion
+ '(0 1 2 3 4 5) "(0 1 2 3 ...)" "4 5")
+ (cl-print-tests-check-ellipsis-expansion
+ '(0 1 2 3 4 5 6 7 8 9) "(0 1 2 3 ...)" "4 5 6 7 ...")
+ (cl-print-tests-check-ellipsis-expansion
+ '(a (b (c (d (e))))) "(a (b (c ...)))" "(d (e))")
+ (cl-print-tests-check-ellipsis-expansion
+ (let ((x (make-list 6 'b)))
+ (setf (nthcdr 6 x) 'c)
+ x)
+ "(b b b b ...)" "b b . c")))
+
+(ert-deftest cl-print-tests-ellipsis-vector ()
+ "Ellipsis expansion works in vectors."
+ (let ((print-length 4)
+ (print-level 3))
+ (cl-print-tests-check-ellipsis-expansion
+ [0 1 2 3 4 5] "[0 1 2 3 ...]" "4 5")
+ (cl-print-tests-check-ellipsis-expansion
+ [0 1 2 3 4 5 6 7 8 9] "[0 1 2 3 ...]" "4 5 6 7 ...")
+ (cl-print-tests-check-ellipsis-expansion
+ [a [b [c [d [e]]]]] "[a [b [c ...]]]" "[d [e]]")))
+
+(ert-deftest cl-print-tests-ellipsis-string ()
+ "Ellipsis expansion works in strings."
+ (let ((print-length 4)
+ (print-level 3))
+ (cl-print-tests-check-ellipsis-expansion
+ "abcdefg" "\"abcd...\"" "efg")
+ (cl-print-tests-check-ellipsis-expansion
+ "abcdefghijk" "\"abcd...\"" "efgh...")
+ (cl-print-tests-check-ellipsis-expansion
+ '(1 (2 (3 #("abcde" 0 5 (test t)))))
+ "(1 (2 (3 ...)))" "#(\"abcd...\" 0 5 (test t))")
+ (cl-print-tests-check-ellipsis-expansion
+ #("abcd" 0 1 (bold t) 1 2 (invisible t) 3 4 (italic t))
+ "#(\"abcd\" 0 1 (bold t) ...)" "1 2 (invisible t) ...")))
+
+(ert-deftest cl-print-tests-ellipsis-struct ()
+ "Ellipsis expansion works in structures."
+ (let ((print-length 4)
+ (print-level 3)
+ (struct (cl-print-tests-con)))
+ (cl-print-tests-check-ellipsis-expansion
+ struct "#s(cl-print-tests-struct :a nil :b nil :c nil :d nil ...)" ":e nil")
+ (let ((print-length 2))
+ (cl-print-tests-check-ellipsis-expansion
+ struct "#s(cl-print-tests-struct :a nil :b nil ...)" ":c nil :d nil ..."))
+ (cl-print-tests-check-ellipsis-expansion
+ `(a (b (c ,struct)))
+ "(a (b (c ...)))"
+ "#s(cl-print-tests-struct :a nil :b nil :c nil :d nil ...)")))
+
+(ert-deftest cl-print-tests-ellipsis-circular ()
+ "Ellipsis expansion works with circular objects."
+ (let ((wide-obj (list 0 1 2 3 4))
+ (deep-obj `(0 (1 (2 (3 (4))))))
+ (print-length 4)
+ (print-level 3))
+ (setf (nth 4 wide-obj) wide-obj)
+ (setf (car (cadadr (cadadr deep-obj))) deep-obj)
+ (let ((print-circle nil))
+ (cl-print-tests-check-ellipsis-expansion-rx
+ wide-obj (regexp-quote "(0 1 2 3 ...)") "\\`#[0-9]\\'")
+ (cl-print-tests-check-ellipsis-expansion-rx
+ deep-obj (regexp-quote "(0 (1 (2 ...)))") "\\`(3 (#[0-9]))\\'"))
+ (let ((print-circle t))
+ (cl-print-tests-check-ellipsis-expansion
+ wide-obj "#1=(0 1 2 3 ...)" "#1#")
+ (cl-print-tests-check-ellipsis-expansion
+ deep-obj "#1=(0 (1 (2 ...)))" "(3 (#1#))"))))
+
+(defun cl-print-tests-check-ellipsis-expansion (obj expected expanded)
+ (let* ((result (cl-prin1-to-string obj))
+ (pos (next-single-property-change 0 'cl-print-ellipsis result))
+ value)
+ (should pos)
+ (setq value (get-text-property pos 'cl-print-ellipsis result))
+ (should (equal expected result))
+ (should (equal expanded (with-output-to-string (cl-print-expand-ellipsis
+ value nil))))))
+
+(defun cl-print-tests-check-ellipsis-expansion-rx (obj expected expanded)
+ (let* ((result (cl-prin1-to-string obj))
+ (pos (next-single-property-change 0 'cl-print-ellipsis result))
+ (value (get-text-property pos 'cl-print-ellipsis result)))
+ (should (string-match expected result))
+ (should (string-match expanded (with-output-to-string
+ (cl-print-expand-ellipsis value nil))))))
+
(ert-deftest cl-print-circle ()
(let ((x '(#1=(a . #1#) #1#)))
(let ((print-circle nil))
@@ -99,5 +233,41 @@
(let ((print-circle t))
(should (equal "(0 . #1=(0 . #1#))" (cl-prin1-to-string x))))))
+(ert-deftest cl-print-tests-print-to-string-with-limit ()
+ (let* ((thing10 (make-list 10 'a))
+ (thing100 (make-list 100 'a))
+ (thing10x10 (make-list 10 thing10))
+ (nested-thing (let ((val 'a))
+ (dotimes (_i 20)
+ (setq val (list val)))
+ val))
+ ;; Make a consistent environment for this test.
+ (print-circle nil)
+ (print-level nil)
+ (print-length nil))
+
+ ;; Print something that fits in the space given.
+ (should (string= (cl-prin1-to-string thing10)
+ (cl-print-to-string-with-limit #'cl-prin1 thing10 100)))
+
+ ;; Print something which needs to be abbreviated and which can be.
+ (should (< (length (cl-print-to-string-with-limit #'cl-prin1 thing100 100))
+ 100
+ (length (cl-prin1-to-string thing100))))
+
+ ;; Print something resistant to easy abbreviation.
+ (should (string= (cl-prin1-to-string thing10x10)
+ (cl-print-to-string-with-limit #'cl-prin1 thing10x10 100)))
+
+ ;; Print something which should be abbreviated even if the limit is large.
+ (should (< (length (cl-print-to-string-with-limit #'cl-prin1 nested-thing 1000))
+ (length (cl-prin1-to-string nested-thing))))
+
+ ;; Print with no limits.
+ (dolist (thing (list thing10 thing100 thing10x10 nested-thing))
+ (let ((rep (cl-prin1-to-string thing)))
+ (should (string= rep (cl-print-to-string-with-limit #'cl-prin1 thing 0)))
+ (should (string= rep (cl-print-to-string-with-limit #'cl-prin1 thing nil)))))))
+
;;; cl-print-tests.el ends here.
diff --git a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el
index e3bcb3d9410..013843826e0 100644
--- a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el
+++ b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el
@@ -41,7 +41,7 @@
(defun edebug-test-code-range (num)
!start!(let ((index 0)
(result nil))
- (while (< index num)!test!
+ (while !lt!(< index num)!test!
(push index result)!loop!
(cl-incf index))!end-loop!
(nreverse result)))
@@ -130,5 +130,12 @@
(let ((two 2) (three 3))
(cl-destructuring-bind (x . y) (cons two three) (+ x!x! y!y!))))
+(defun edebug-test-code-use-cl-macrolet (x)
+ (cl-macrolet ((wrap (func &rest args)
+ `(format "The result of applying %s to %s is %S"
+ ',func!func! ',args
+ ,(cons func args))))
+ (wrap + 1 x)))
+
(provide 'edebug-test-code)
;;; edebug-test-code.el ends here
diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el
index 7bfaf98e02e..4c517406cf8 100644
--- a/test/lisp/emacs-lisp/edebug-tests.el
+++ b/test/lisp/emacs-lisp/edebug-tests.el
@@ -432,9 +432,11 @@ test and possibly others should be updated."
(verify-keybinding "P" 'edebug-view-outside) ;; same as v
(verify-keybinding "W" 'edebug-toggle-save-windows)
(verify-keybinding "?" 'edebug-help)
- (verify-keybinding "d" 'edebug-backtrace)
+ (verify-keybinding "d" 'edebug-pop-to-backtrace)
(verify-keybinding "-" 'negative-argument)
- (verify-keybinding "=" 'edebug-temp-display-freq-count)))
+ (verify-keybinding "=" 'edebug-temp-display-freq-count)
+ (should (eq (lookup-key backtrace-mode-map "n") 'backtrace-forward-frame))
+ (should (eq (lookup-key backtrace-mode-map "s") 'backtrace-goto-source))))
(ert-deftest edebug-tests-stop-point-at-start-of-first-instrumented-function ()
"Edebug stops at the beginning of an instrumented function."
@@ -913,5 +915,28 @@ test and possibly others should be updated."
"g"
(should (equal edebug-tests-@-result 5)))))
+(ert-deftest edebug-tests-cl-macrolet ()
+ "Edebug can instrument `cl-macrolet' expressions. (Bug#29919)"
+ (edebug-tests-with-normal-env
+ (edebug-tests-setup-@ "use-cl-macrolet" '(10) t)
+ (edebug-tests-run-kbd-macro
+ "@ SPC SPC"
+ (edebug-tests-should-be-at "use-cl-macrolet" "func")
+ (edebug-tests-should-match-result-in-messages "+")
+ "g"
+ (should (equal edebug-tests-@-result "The result of applying + to (1 x) is 11")))))
+
+(ert-deftest edebug-tests-backtrace-goto-source ()
+ "Edebug can jump to instrumented source from its *Edebug-Backtrace* buffer."
+ (edebug-tests-with-normal-env
+ (edebug-tests-setup-@ "range" '(2) t)
+ (edebug-tests-run-kbd-macro
+ "@ SPC SPC"
+ (edebug-tests-should-be-at "range" "lt")
+ "dns" ; Pop to backtrace, next frame, goto source.
+ (edebug-tests-should-be-at "range" "start")
+ "g"
+ (should (equal edebug-tests-@-result '(0 1))))))
+
(provide 'edebug-tests)
;;; edebug-tests.el ends here
diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el
index c9e67d31366..a7c63467bf9 100644
--- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el
+++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el
@@ -326,7 +326,7 @@
)
(ert-deftest eieio-test-method-order-list-9 ()
- (should (eitest-Jd "test")))
+ (should (eitest-Jd)))
;;; call-next-method with replacement arguments across a simple class hierarchy.
;;
@@ -372,7 +372,7 @@
(ert-deftest eieio-test-method-order-list-10 ()
(let ((eieio-test-call-next-method-arguments nil))
- (CNM-M (CNM-2 "") '(INIT))
+ (CNM-M (CNM-2) '(INIT))
(should (equal (eieio-test-arguments-for 'CNM-0)
'(CNM-1-1 CNM-2 INIT)))
(should (equal (eieio-test-arguments-for 'CNM-1-1)
diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
index dfaa031844f..2820d16254a 100644
--- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
+++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
@@ -107,7 +107,7 @@ This is usually a symbol that starts with `:'."
(ert-deftest eieio-test-persist-simple-1 ()
(let ((persist-simple-1
- (persist-simple "simple 1" :slot1 'goose :slot2 "testing"
+ (persist-simple :slot1 'goose :slot2 "testing"
:file (concat default-directory "test-ps1.pt"))))
(should persist-simple-1)
@@ -141,7 +141,7 @@ Assume SLOTVALUE is a symbol of some sort."
(ert-deftest eieio-test-persist-printer ()
(let ((persist-:printer-1
- (persist-:printer "persist" :slot1 'goose :slot2 "testing"
+ (persist-:printer :slot1 'goose :slot2 "testing"
:file (concat default-directory "test-ps2.pt"))))
(should persist-:printer-1)
(persist-test-save-and-compare persist-:printer-1)
@@ -178,8 +178,7 @@ persistent class.")
(ert-deftest eieio-test-non-persistent-as-slot ()
(let ((persist-wos
(persistent-with-objs-slot
- "persist wos 1"
- :pnp (persist-not-persistent "pnp 1" :slot1 3)
+ :pnp (persist-not-persistent :slot1 3)
:file (concat default-directory "test-ps3.pt"))))
(persist-test-save-and-compare persist-wos)
@@ -205,8 +204,7 @@ persistent class.")
(ert-deftest eieio-test-non-persistent-as-slot-child ()
(let ((persist-woss
(persistent-with-objs-slot-subs
- "persist woss 1"
- :pnp (persist-not-persistent-subclass "pnps 1" :slot1 3)
+ :pnp (persist-not-persistent-subclass :slot1 3)
:file (concat default-directory "test-ps4.pt"))))
(persist-test-save-and-compare persist-woss)
@@ -228,7 +226,7 @@ persistent class.")
(ert-deftest eieio-test-multiple-class-slot ()
(let ((persist
- (persistent-multiclass-slot "random string"
+ (persistent-multiclass-slot
:slot1 (persistent-random-class)
:slot2 (persist-not-persistent)
:slot3 (persistent-random-class)
@@ -249,10 +247,9 @@ persistent class.")
(ert-deftest eieio-test-slot-with-list-of-objects ()
(let ((persist-wols
(persistent-with-objs-list-slot
- "persist wols 1"
- :pnp (list (persist-not-persistent "pnp 1" :slot1 3)
- (persist-not-persistent "pnp 2" :slot1 4)
- (persist-not-persistent "pnp 3" :slot1 5))
+ :pnp (list (persist-not-persistent :slot1 3)
+ (persist-not-persistent :slot1 4)
+ (persist-not-persistent :slot1 5))
:file (concat default-directory "test-ps5.pt"))))
(persist-test-save-and-compare persist-wols)
diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
index 09ee123efaa..ea6df0f36fc 100644
--- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
+++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
@@ -689,7 +689,7 @@ Do not override for `prot-2'."
(defvar eitest-II2 nil)
(defvar eitest-II3 nil)
(ert-deftest eieio-test-29-instance-inheritor ()
- (setq eitest-II1 (II "II Test."))
+ (setq eitest-II1 (II))
(oset eitest-II1 slot2 'cat)
(setq eitest-II2 (clone eitest-II1 "eitest-II2 Test."))
(oset eitest-II2 slot1 'moose)
diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el
index 7736360b6ac..36db1eeb425 100644
--- a/test/lisp/emacs-lisp/ert-tests.el
+++ b/test/lisp/emacs-lisp/ert-tests.el
@@ -188,7 +188,7 @@ failed or if there was a problem."
(ert-deftest ert-test-should-with-macrolet ()
(let ((test (make-ert-test :body (lambda ()
- (cl-macrolet ((foo () `(progn t nil)))
+ (cl-macrolet ((foo () '(progn t nil)))
(should (foo)))))))
(let ((result (let ((ert-debug-on-error nil))
(ert-run-test test))))
@@ -376,7 +376,7 @@ This macro is used to test if macroexpansion in `should' works."
(test (make-ert-test :body test-body))
(result (ert-run-test test)))
(should (ert-test-failed-p result))
- (should (eq (nth 1 (car (ert-test-failed-backtrace result)))
+ (should (eq (backtrace-frame-fun (car (ert-test-failed-backtrace result)))
'signal))))
(ert-deftest ert-test-messages ()
@@ -490,54 +490,12 @@ This macro is used to test if macroexpansion in `should' works."
:name nil
:body nil
:tags '(a b))))
- (should (equal (ert-select-tests `(tag a) (list test)) (list test)))
- (should (equal (ert-select-tests `(tag b) (list test)) (list test)))
- (should (equal (ert-select-tests `(tag c) (list test)) '()))))
+ (should (equal (ert-select-tests '(tag a) (list test)) (list test)))
+ (should (equal (ert-select-tests '(tag b) (list test)) (list test)))
+ (should (equal (ert-select-tests '(tag c) (list test)) '()))))
;;; Tests for utility functions.
-(ert-deftest ert-test-proper-list-p ()
- (should (ert--proper-list-p '()))
- (should (ert--proper-list-p '(1)))
- (should (ert--proper-list-p '(1 2)))
- (should (ert--proper-list-p '(1 2 3)))
- (should (ert--proper-list-p '(1 2 3 4)))
- (should (not (ert--proper-list-p 'a)))
- (should (not (ert--proper-list-p '(1 . a))))
- (should (not (ert--proper-list-p '(1 2 . a))))
- (should (not (ert--proper-list-p '(1 2 3 . a))))
- (should (not (ert--proper-list-p '(1 2 3 4 . a))))
- (let ((a (list 1)))
- (setf (cdr (last a)) a)
- (should (not (ert--proper-list-p a))))
- (let ((a (list 1 2)))
- (setf (cdr (last a)) a)
- (should (not (ert--proper-list-p a))))
- (let ((a (list 1 2 3)))
- (setf (cdr (last a)) a)
- (should (not (ert--proper-list-p a))))
- (let ((a (list 1 2 3 4)))
- (setf (cdr (last a)) a)
- (should (not (ert--proper-list-p a))))
- (let ((a (list 1 2)))
- (setf (cdr (last a)) (cdr a))
- (should (not (ert--proper-list-p a))))
- (let ((a (list 1 2 3)))
- (setf (cdr (last a)) (cdr a))
- (should (not (ert--proper-list-p a))))
- (let ((a (list 1 2 3 4)))
- (setf (cdr (last a)) (cdr a))
- (should (not (ert--proper-list-p a))))
- (let ((a (list 1 2 3)))
- (setf (cdr (last a)) (cddr a))
- (should (not (ert--proper-list-p a))))
- (let ((a (list 1 2 3 4)))
- (setf (cdr (last a)) (cddr a))
- (should (not (ert--proper-list-p a))))
- (let ((a (list 1 2 3 4)))
- (setf (cdr (last a)) (cl-cdddr a))
- (should (not (ert--proper-list-p a)))))
-
(ert-deftest ert-test-parse-keys-and-body ()
(should (equal (ert--parse-keys-and-body '(foo)) '(nil (foo))))
(should (equal (ert--parse-keys-and-body '(:bar foo)) '((:bar foo) nil)))
diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el
new file mode 100644
index 00000000000..e940c5f5145
--- /dev/null
+++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el
@@ -0,0 +1,76 @@
+;;; faceup-test-mode.el --- Dummy major mode for testing `faceup'.
+
+;; Copyright (C) 2014-2019 Free Software Foundation, Inc.
+
+;; Author: Anders Lindgren
+;; Keywords: languages, faces
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Dummy major-mode for testing `faceup', a regression test system for
+;; font-lock keywords (syntax highlighting rules for Emacs).
+;;
+;; This mode use `syntax-propertize' to set the `syntax-table'
+;; property on "<" and ">" in "<TEXT>" to make them act like
+;; parentheses.
+;;
+;; This mode also sets the `help-echo' property on the text WARNING,
+;; the effect is that Emacs displays a tooltip when you move your
+;; mouse on to the text.
+
+;;; Code:
+
+(defvar faceup-test-mode-syntax-table
+ (make-syntax-table)
+ "Syntax table for `faceup-test-mode'.")
+
+(defvar faceup-test-font-lock-keywords
+ '(("\\_<WARNING\\_>"
+ (0 (progn
+ (add-text-properties (match-beginning 0)
+ (match-end 0)
+ '(help-echo "Baloon tip: Fly smoothly!"))
+ font-lock-warning-face))))
+ "Highlight rules for `faceup-test-mode'.")
+
+(defun faceup-test-syntax-propertize (start end)
+ (goto-char start)
+ (funcall
+ (syntax-propertize-rules
+ ("\\(<\\)\\([^<>\n]*\\)\\(>\\)"
+ (1 "() ")
+ (3 ")( ")))
+ start end))
+
+(defmacro faceup-test-define-prog-mode (mode name &rest args)
+ "Define a major mode for a programming language.
+If `prog-mode' is defined, inherit from it."
+ (declare (indent defun))
+ `(define-derived-mode
+ ,mode ,(and (fboundp 'prog-mode) 'prog-mode)
+ ,name ,@args))
+
+(faceup-test-define-prog-mode faceup-test-mode "faceup-test"
+ "Dummy major mode for testing `faceup', a test system for font-lock."
+ (set (make-local-variable 'syntax-propertize-function)
+ #'faceup-test-syntax-propertize)
+ (setq font-lock-defaults '(faceup-test-font-lock-keywords nil)))
+
+(provide 'faceup-test-mode)
+
+;;; faceup-test-mode.el ends here
diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el
new file mode 100644
index 00000000000..11c48de38eb
--- /dev/null
+++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el
@@ -0,0 +1,32 @@
+;;; faceup-test-this-file-directory.el --- Support file for faceup tests
+
+;; Copyright (C) 2014-2019 Free Software Foundation, Inc.
+
+;; Author: Anders Lindgren
+;; Keywords: languages, faces
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Support file for `faceup-test-basics.el'. This file is used to test
+;; `faceup-this-file-directory' in various contexts.
+
+;;; Code:
+
+(defvar faceup-test-this-file-directory (faceup-this-file-directory))
+
+;;; faceup-test-this-file-directory.el ends here
diff --git a/test/lisp/emacs-lisp/faceup-resources/files/test1.txt b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt
new file mode 100644
index 00000000000..d971f364c2d
--- /dev/null
+++ b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt
@@ -0,0 +1,15 @@
+This is a test of `faceup', a regression test system for font-lock
+keywords. It should use major mode `faceup-test-mode'.
+
+WARNING: The first word on this line should use
+`font-lock-warning-face', and a tooltip should be displayed if the
+mouse pointer is moved over it.
+
+In this mode "<" and ">" are parentheses, but only when on the same
+line without any other "<" and ">" characters between them.
+<OK> <NOT <OK> >
+<
+NOT OK
+>
+
+test1.txt ends here.
diff --git a/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup
new file mode 100644
index 00000000000..7d4938adf17
--- /dev/null
+++ b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup
@@ -0,0 +1,15 @@
+This is a test of `faceup', a regression test system for font-lock
+keywords. It should use major mode `faceup-test-mode'.
+
+«(help-echo):"Baloon tip: Fly smoothly!":«w:WARNING»»: The first word on this line should use
+`font-lock-warning-face', and a tooltip should be displayed if the
+mouse pointer is moved over it.
+
+In this mode «s:"«(syntax-table):(4 . 41):<»"» and «s:"«(syntax-table):(5 . 40):>»"» are parentheses, but only when on the same
+line without any other «s:"«(syntax-table):(4 . 41):<»"» and «s:"«(syntax-table):(5 . 40):>»"» characters between them.
+«(syntax-table):(4 . 41):<»OK«(syntax-table):(5 . 40):>» <NOT «(syntax-table):(4 . 41):<»OK«(syntax-table):(5 . 40):>» >
+<
+NOT OK
+>
+
+test1.txt ends here.
diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el
new file mode 100644
index 00000000000..c35188eb8b6
--- /dev/null
+++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el
@@ -0,0 +1,269 @@
+;;; faceup-test-basics.el --- Tests for the `faceup' package.
+
+;; Copyright (C) 2014-2019 Free Software Foundation, Inc.
+
+;; Author: Anders Lindgren
+;; Keywords: languages, faces
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Basic tests for the `faceup' package.
+
+;;; Code:
+
+(eval-when-compile (require 'cl-lib))
+(require 'faceup)
+
+(ert-deftest faceup-functions ()
+ "Test primitive functions."
+ (should (equal (faceup-normalize-face-property '()) '()))
+ (should (equal (faceup-normalize-face-property 'a) '(a)))
+ (should (equal (faceup-normalize-face-property '(a)) '(a)))
+ (should (equal (faceup-normalize-face-property '(:x t)) '((:x t))))
+ (should (equal (faceup-normalize-face-property '(:x t a)) '((:x t))))
+ (should (equal (faceup-normalize-face-property '(:x t a b)) '((:x t))))
+ (should (equal (faceup-normalize-face-property '(a :x t)) '(a (:x t))))
+ (should (equal (faceup-normalize-face-property '(a b :x t))
+ '(a b (:x t))))
+
+ (should (equal (faceup-normalize-face-property '(:x t :y nil))
+ '((:y nil) (:x t))))
+ (should (equal (faceup-normalize-face-property '(:x t :y nil a))
+ '((:y nil) (:x t))))
+ (should (equal (faceup-normalize-face-property '(:x t :y nil a b))
+ '((:y nil) (:x t))))
+ (should (equal (faceup-normalize-face-property '(a :x t :y nil))
+ '(a (:y nil) (:x t))))
+ (should (equal (faceup-normalize-face-property '(a b :x t :y nil))
+ '(a b (:y nil) (:x t)))))
+
+
+(ert-deftest faceup-markup-basics ()
+ (should (equal (faceup-markup-string "") ""))
+ (should (equal (faceup-markup-string "test") "test")))
+
+(ert-deftest faceup-markup-escaping ()
+ (should (equal (faceup-markup-string "«") "««"))
+ (should (equal (faceup-markup-string "«A«B«C«") "««A««B««C««"))
+ (should (equal (faceup-markup-string "»") "«»"))
+ (should (equal (faceup-markup-string "»A»B»C»") "«»A«»B«»C«»")))
+
+(ert-deftest faceup-markup-plain ()
+ ;; UU
+ ;; ABCDEF
+ (should (equal (faceup-markup-string
+ #("ABCDEF" 2 4 (face underline)))
+ "AB«U:CD»EF")))
+
+(ert-deftest faceup-markup-plain-full-text ()
+ ;; UUUUUU
+ ;; ABCDEF
+ (should (equal (faceup-markup-string
+ #("ABCDEF" 0 6 (face underline)))
+ "«U:ABCDEF»")))
+
+(ert-deftest faceup-markup-anonymous-face ()
+ ;; AA
+ ;; ABCDEF
+ (should (equal (faceup-markup-string
+ #("ABCDEF" 2 4 (face (:underline t))))
+ "AB«:(:underline t):CD»EF")))
+
+(ert-deftest faceup-markup-anonymous-face-2keys ()
+ ;; AA
+ ;; ABCDEF
+ (should (equal (faceup-markup-string
+ #("ABCDEF" 2 4 (face (:foo t :bar nil))))
+ "AB«:(:foo t):«:(:bar nil):CD»»EF"))
+ ;; Plist in list.
+ (should (equal (faceup-markup-string
+ #("ABCDEF" 2 4 (face ((:foo t :bar nil)))))
+ "AB«:(:foo t):«:(:bar nil):CD»»EF"))
+ ;; Two plists.
+ (should (equal (faceup-markup-string
+ #("ABCDEF" 2 4 (face ((:foo t) (:bar nil)))))
+ "AB«:(:bar nil):«:(:foo t):CD»»EF")))
+
+(ert-deftest faceup-markup-anonymous-nested ()
+ ;; AA
+ ;; IIII
+ ;; ABCDEF
+ (should (equal (faceup-markup-string
+ #("ABCDEF"
+ 1 2 (face ((:foo t)))
+ 2 4 (face ((:bar t) (:foo t)))
+ 4 5 (face ((:foo t)))))
+ "A«:(:foo t):B«:(:bar t):CD»E»F")))
+
+(ert-deftest faceup-markup-nested ()
+ ;; UU
+ ;; IIII
+ ;; ABCDEF
+ (should (equal (faceup-markup-string
+ #("ABCDEF"
+ 1 2 (face italic)
+ 2 4 (face (underline italic))
+ 4 5 (face italic)))
+ "A«I:B«U:CD»E»F")))
+
+(ert-deftest faceup-markup-overlapping ()
+ ;; UUU
+ ;; III
+ ;; ABCDEF
+ (should (equal (faceup-markup-string
+ #("ABCDEF"
+ 1 2 (face italic)
+ 2 4 (face (underline italic))
+ 4 5 (face underline)))
+ "A«I:B«U:CD»»«U:E»F"))
+ ;; III
+ ;; UUU
+ ;; ABCDEF
+ (should (equal (faceup-markup-string
+ #("ABCDEF"
+ 1 2 (face italic)
+ 2 4 (face (italic underline))
+ 4 5 (face underline)))
+ "A«I:B»«U:«I:CD»E»F")))
+
+(ert-deftest faceup-markup-multi-face ()
+ ;; More than one face at the same location.
+ ;;
+ ;; The property to the front takes precedence, it is rendered as the
+ ;; innermost parenthesis pair.
+ (should (equal (faceup-markup-string
+ #("ABCDEF" 2 4 (face (underline italic))))
+ "AB«I:«U:CD»»EF"))
+ (should (equal (faceup-markup-string
+ #("ABCDEF" 2 4 (face (italic underline))))
+ "AB«U:«I:CD»»EF"))
+ ;; Equal ranges, full text.
+ (should (equal (faceup-markup-string
+ #("ABCDEF" 0 6 (face (underline italic))))
+ "«I:«U:ABCDEF»»"))
+ ;; Ditto, with stray markup characters.
+ (should (equal (faceup-markup-string
+ #("AB«CD»EF" 0 8 (face (underline italic))))
+ "«I:«U:AB««CD«»EF»»")))
+
+(ert-deftest faceup-markup-multi-property ()
+ (let ((faceup-properties '(alpha beta gamma)))
+ ;; One property.
+ (should (equal (faceup-markup-string
+ #("ABCDEF" 2 4 (alpha (a l p h a))))
+ "AB«(alpha):(a l p h a):CD»EF"))
+
+ ;; Two properties, inner enclosed.
+ (should (equal (faceup-markup-string
+ (let ((s (copy-sequence "ABCDEFGHIJ")))
+ (set-text-properties 2 8 '(alpha (a l p h a)) s)
+ (font-lock-append-text-property 4 6 'beta '(b e t a) s)
+ s))
+ "AB«(alpha):(a l p h a):CD«(beta):(b e t a):EF»GH»IJ"))
+
+ ;; Two properties, same end
+ (should (equal (faceup-markup-string
+ (let ((s (copy-sequence "ABCDEFGH")))
+ (set-text-properties 2 6 '(alpha (a)) s)
+ (add-text-properties 4 6 '(beta (b)) s)
+ s))
+ "AB«(alpha):(a):CD«(beta):(b):EF»»GH"))
+
+ ;; Two properties, overlap.
+ (should (equal (faceup-markup-string
+ (let ((s (copy-sequence "ABCDEFGHIJ")))
+ (set-text-properties 2 6 '(alpha (a)) s)
+ (add-text-properties 4 8 '(beta (b)) s)
+ s))
+ "AB«(alpha):(a):CD«(beta):(b):EF»»«(beta):(b):GH»IJ"))))
+
+
+(ert-deftest faceup-clean ()
+ "Test the clean features of `faceup'."
+ (should (equal (faceup-clean-string "") ""))
+ (should (equal (faceup-clean-string "test") "test"))
+ (should (equal (faceup-clean-string "AB«U:CD»EF") "ABCDEF"))
+ (should (equal (faceup-clean-string "«U:ABCDEF»") "ABCDEF"))
+ (should (equal (faceup-clean-string "A«I:B«U:CD»E»F") "ABCDEF"))
+ (should (equal (faceup-clean-string "A«I:B«U:CD»»«U:E»F") "ABCDEF"))
+ (should (equal (faceup-clean-string "AB«I:«U:CD»»EF") "ABCDEF"))
+ (should (equal (faceup-clean-string "«I:«U:ABCDEF»»") "ABCDEF"))
+ (should (equal (faceup-clean-string "«(foo)I:ABC»DEF") "ABCDEF"))
+ (should (equal (faceup-clean-string "«:(:foo t):ABC»DEF") "ABCDEF"))
+ ;; Escaped markup characters.
+ (should (equal (faceup-clean-string "««") "«"))
+ (should (equal (faceup-clean-string "«»") "»"))
+ (should (equal (faceup-clean-string "A«I:B«U:CD»«»»«U:E»F") "ABCD»EF")))
+
+
+(ert-deftest faceup-render ()
+ "Test the render features of `faceup'."
+ (should (equal (faceup-render-string "") ""))
+ (should (equal (faceup-render-string "««") "«"))
+ (should (equal (faceup-render-string "«»") "»"))
+ (should (equal (faceup-render-string "A«I:B«U:CD»«»»«U:E»F") "ABCD»EF")))
+
+
+(defvar faceup-test-resources-directory
+ (concat (file-name-directory
+ (substring (faceup-this-file-directory) 0 -1))
+ "faceup-resources/")
+ "The `faceup-resources' directory.")
+
+
+(defvar faceup-test-this-file-directory nil
+ "The result of `faceup-this-file-directory' in various contexts.
+
+This is set by the file test support file
+`faceup-test-this-file-directory.el'.")
+
+
+(ert-deftest faceup-directory ()
+ "Test `faceup-this-file-directory'."
+ (let ((file (concat faceup-test-resources-directory
+ "faceup-test-this-file-directory.el"))
+ (load-file-name nil))
+ ;; Test normal load.
+ (makunbound 'faceup-test-this-file-directory)
+ (load file nil :nomessage)
+ (should (equal faceup-test-this-file-directory
+ faceup-test-resources-directory))
+ ;; Test `eval-buffer'.
+ (makunbound 'faceup-test-this-file-directory)
+ (save-excursion
+ (find-file file)
+ (eval-buffer))
+ (should (equal faceup-test-this-file-directory
+ faceup-test-resources-directory))
+ ;; Test `eval-defun'.
+ (makunbound 'faceup-test-this-file-directory)
+ (save-excursion
+ (find-file file)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ ;; Note: In batch mode, this prints the result of the
+ ;; evaluation. Unfortunately, this is hard to fix.
+ (eval-defun nil)
+ (forward-sexp))))
+ (should (equal faceup-test-this-file-directory
+ faceup-test-resources-directory))))
+
+(provide 'faceup-test-basics)
+
+;;; faceup-test-basics.el ends here
diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el
new file mode 100644
index 00000000000..c8c3a1f5d8a
--- /dev/null
+++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el
@@ -0,0 +1,63 @@
+;;; faceup-test-files.el --- Self test of `faceup' using dummy major mode.
+
+;; Copyright (C) 2014-2019 Free Software Foundation, Inc.
+
+;; Author: Anders Lindgren
+;; Keywords: languages, faces
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Self test of `faceup' with a major mode that sets both the
+;; `syntax-table' and the `echo-help' property.
+;;
+;; This file can also be seen as a blueprint of test cases for real
+;; major modes.
+
+;;; Code:
+
+(require 'faceup)
+
+;; Note: The byte compiler needs the value to load `faceup-test-mode',
+;; hence the `eval-and-compile'.
+(eval-and-compile
+ (defvar faceup-test-files-dir (faceup-this-file-directory)
+ "The directory of this file."))
+
+(require 'faceup-test-mode
+ (concat faceup-test-files-dir
+ "../faceup-resources/"
+ "faceup-test-mode.el"))
+
+(defun faceup-test-files-check-one (file)
+ "Test that FILE is fontified as the .faceup file describes.
+
+FILE is interpreted as relative to this source directory."
+ (let ((faceup-properties '(face syntax-table help-echo)))
+ (faceup-test-font-lock-file 'faceup-test-mode
+ (concat
+ faceup-test-files-dir
+ "../faceup-resources/"
+ file))))
+(faceup-defexplainer faceup-test-files-check-one)
+
+(ert-deftest faceup-files ()
+ (should (faceup-test-files-check-one "files/test1.txt")))
+
+(provide 'faceup-test-files)
+
+;;; faceup-test-files.el ends here
diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el
index 35382dd8d04..613de2fd577 100644
--- a/test/lisp/emacs-lisp/generator-tests.el
+++ b/test/lisp/emacs-lisp/generator-tests.el
@@ -292,3 +292,13 @@ identical output.
(i 0)
(j (setq i (1+ i))))
(iter-yield i))))))))
+
+(ert-deftest iter-lambda-variable-shadowing ()
+ "`iter-lambda' forms which have local variable shadowing (Bug#26073)."
+ (should (equal (iter-next
+ (funcall (iter-lambda ()
+ (let ((it 1))
+ (iter-yield (funcall
+ (lambda (it) (- it))
+ (1+ it)))))))
+ -2)))
diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el
index 55238ec034d..a54af8059b3 100644
--- a/test/lisp/emacs-lisp/map-tests.el
+++ b/test/lisp/emacs-lisp/map-tests.el
@@ -38,17 +38,19 @@ Evaluate BODY for each created map.
\(fn (var map) body)"
(declare (indent 1) (debug (symbolp body)))
(let ((alist (make-symbol "alist"))
+ (plist (make-symbol "plist"))
(vec (make-symbol "vec"))
(ht (make-symbol "ht")))
`(let ((,alist (list (cons 0 3)
(cons 1 4)
(cons 2 5)))
+ (,plist (list 0 3 1 4 2 5))
(,vec (vector 3 4 5))
(,ht (make-hash-table)))
(puthash 0 3 ,ht)
(puthash 1 4 ,ht)
(puthash 2 5 ,ht)
- (dolist (,var (list ,alist ,vec ,ht))
+ (dolist (,var (list ,alist ,plist ,vec ,ht))
,@body))))
(ert-deftest test-map-elt ()
@@ -76,13 +78,26 @@ Evaluate BODY for each created map.
'b
'2))))
-(ert-deftest test-map-put ()
+(ert-deftest test-map-put! ()
(with-maps-do map
(setf (map-elt map 2) 'hello)
(should (eq (map-elt map 2) 'hello)))
(with-maps-do map
(map-put map 2 'hello)
(should (eq (map-elt map 2) 'hello)))
+ (with-maps-do map
+ (map-put! map 2 'hello)
+ (should (eq (map-elt map 2) 'hello))
+ (if (not (or (hash-table-p map)
+ (and (listp map) (not (listp (car map)))))) ;plist!
+ (should-error (map-put! map 5 'value)
+ ;; For vectors, it could arguably signal
+ ;; map-not-inplace as well, but it currently doesn't.
+ :type (if (listp map)
+ 'map-not-inplace
+ 'error))
+ (map-put! map 5 'value)
+ (should (eq (map-elt map 5) 'value))))
(let ((ht (make-hash-table)))
(setf (map-elt ht 2) 'a)
(should (eq (map-elt ht 2)
@@ -92,7 +107,7 @@ Evaluate BODY for each created map.
(should (eq (map-elt alist 2)
'a)))
(let ((vec [3 4 5]))
- (should-error (setf (map-elt vec 3) 6))))
+ (should-error (setf (map-elt vec 3) 6))))
(ert-deftest test-map-put-alist-new-key ()
"Regression test for Bug#23105."
@@ -105,9 +120,9 @@ Evaluate BODY for each created map.
(let ((alist (list (cons "a" 1) (cons "b" 2)))
;; Make sure to use a non-eq "a", even when compiled.
(noneq-key (string ?a)))
- (map-put alist noneq-key 3 'equal)
+ (map-put alist noneq-key 3 #'equal)
(should-not (cddr alist))
- (map-put alist noneq-key 9)
+ (map-put alist noneq-key 9 #'eql)
(should (cddr alist))))
(ert-deftest test-map-put-return-value ()
diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el
index 212e73f4726..c757bccf672 100644
--- a/test/lisp/emacs-lisp/package-tests.el
+++ b/test/lisp/emacs-lisp/package-tests.el
@@ -112,7 +112,7 @@
upload-base)
&rest body)
"Set up temporary locations and variables for testing."
- (declare (indent 1))
+ (declare (indent 1) (debug (([&rest form]) body)))
`(let* ((package-test-user-dir (make-temp-file "pkg-test-user-dir-" t))
(process-environment (cons (format "HOME=%s" package-test-user-dir)
process-environment))
@@ -158,6 +158,7 @@
(defmacro with-fake-help-buffer (&rest body)
"Execute BODY in a temp buffer which is treated as the \"*Help*\" buffer."
+ (declare (debug body))
`(with-temp-buffer
(help-mode)
;; Trick `help-buffer' into using the temp buffer.
@@ -189,12 +190,33 @@ Must called from within a `tar-mode' buffer."
"Return the package version as a string."
(package-version-join (package-desc-version desc)))
+(defun package-test--compatible-p (pkg-desc pkg-sample &optional kind)
+ (and (cl-every (lambda (f)
+ (equal (funcall f pkg-desc)
+ (funcall f pkg-sample)))
+ (cons (if kind #'package-desc-kind #'ignore)
+ '(package-desc-name
+ package-desc-version
+ package-desc-summary
+ package-desc-reqs
+ package-desc-archive
+ package-desc-dir
+ package-desc-signed)))
+ ;; The `extras' field should contain at least the specified elements.
+ (let ((extras (package-desc-extras pkg-desc))
+ (extras-sample (package-desc-extras pkg-sample)))
+ (cl-every (lambda (sample-elem)
+ (member sample-elem extras))
+ extras-sample))))
+
(ert-deftest package-test-desc-from-buffer ()
"Parse an elisp buffer to get a `package-desc' object."
(with-package-test (:basedir "package-resources" :file "simple-single-1.3.el")
- (should (equal (package-buffer-info) simple-single-desc)))
+ (should (package-test--compatible-p
+ (package-buffer-info) simple-single-desc 'kind)))
(with-package-test (:basedir "package-resources" :file "simple-depend-1.0.el")
- (should (equal (package-buffer-info) simple-depend-desc)))
+ (should (package-test--compatible-p
+ (package-buffer-info) simple-depend-desc 'kind)))
(with-package-test (:basedir "package-resources"
:file "multi-file-0.2.3.tar")
(tar-mode)
@@ -222,15 +244,12 @@ Must called from within a `tar-mode' buffer."
(with-temp-buffer
(insert-file-contents (expand-file-name "simple-single-pkg.el"
simple-pkg-dir))
- (should (string= (buffer-string)
- (concat ";;; -*- no-byte-compile: t -*-\n"
- "(define-package \"simple-single\" \"1.3\" "
- "\"A single-file package "
- "with no dependencies\" 'nil "
- ":authors '((\"J. R. Hacker\" . \"jrh@example.com\")) "
- ":maintainer '(\"J. R. Hacker\" . \"jrh@example.com\") "
- ":url \"http://doodles.au\""
- ")\n"))))
+ (goto-char (point-min))
+ (let ((sexp (read (current-buffer))))
+ (should (eq (car-safe sexp) 'define-package))
+ (should (package-test--compatible-p
+ (apply #'package-desc-from-define (cdr sexp))
+ simple-single-desc))))
(should (file-exists-p autoloads-file))
(should-not (get-file-buffer autoloads-file)))))
@@ -414,7 +433,7 @@ Must called from within a `tar-mode' buffer."
(with-fake-help-buffer
(describe-package '5x5)
(goto-char (point-min))
- (should (search-forward "5x5 is a built-in package." nil t))
+ (should (search-forward "5x5 is built-in." nil t))
;; Don't assume the descriptions are in any particular order.
(save-excursion (should (search-forward "Status: Built-in." nil t)))
(save-excursion (should (search-forward "Summary: simple little puzzle game" nil t)))
@@ -428,17 +447,30 @@ Must called from within a `tar-mode' buffer."
(with-fake-help-buffer
(describe-package 'simple-single)
(goto-char (point-min))
- (should (search-forward "simple-single is an installed package." nil t))
+ (should (search-forward "Package simple-single is installed." nil t))
(save-excursion (should (re-search-forward "Status: Installed in ['`‘]simple-single-1.3/['’] (unsigned)." nil t)))
(save-excursion (should (search-forward "Version: 1.3" nil t)))
(save-excursion (should (search-forward "Summary: A single-file package with no dependencies" nil t)))
(save-excursion (should (search-forward "Homepage: http://doodles.au" nil t)))
(save-excursion (should (re-search-forward "Keywords: \\[?frobnicate\\]?" nil t)))
- ;; No description, though. Because at this point we don't know
- ;; what archive the package originated from, and we don't have
- ;; its readme file saved.
+ (save-excursion (should (search-forward "This package provides a minor mode to frobnicate"
+ nil t)))
)))
+(ert-deftest package-test-describe-installed-multi-file-package ()
+ "Test displaying of the readme for installed multi-file package."
+
+ (with-package-test ()
+ (package-initialize)
+ (package-refresh-contents)
+ (package-install 'multi-file)
+ (with-fake-help-buffer
+ (describe-package 'multi-file)
+ (goto-char (point-min))
+ (should (search-forward "Homepage: http://puddles.li" nil t))
+ (should (search-forward "This is a bare-bones readme file for the multi-file"
+ nil t)))))
+
(ert-deftest package-test-describe-non-installed-package ()
"Test displaying of the readme for non-installed package."
@@ -467,15 +499,23 @@ Must called from within a `tar-mode' buffer."
(ert-deftest package-test-signed ()
"Test verifying package signature."
- (skip-unless (ignore-errors
- (let ((homedir (make-temp-file "package-test" t)))
- (unwind-protect
- (let ((process-environment
- (cons (format "HOME=%s" homedir)
- process-environment)))
- (epg-check-configuration (epg-configuration))
- (epg-find-configuration 'OpenPGP))
- (delete-directory homedir t)))))
+ (skip-unless (let ((homedir (make-temp-file "package-test" t)))
+ (unwind-protect
+ (let ((process-environment
+ (cons (concat "HOME=" homedir)
+ process-environment)))
+ (epg-find-configuration
+ 'OpenPGP nil
+ ;; By default we require gpg2 2.1+ due to some
+ ;; practical problems with pinentry. But this
+ ;; test works fine with 2.0 as well.
+ (let ((prog-alist (copy-tree epg-config--program-alist)))
+ (setf (alist-get "gpg2"
+ (alist-get 'OpenPGP prog-alist)
+ nil nil #'equal)
+ "2.0")
+ prog-alist)))
+ (delete-directory homedir t))))
(let* ((keyring (expand-file-name "key.pub" package-test-data-dir))
(package-test-data-dir
(expand-file-name "package-resources/signed" package-test-file-dir)))
@@ -484,14 +524,16 @@ Must called from within a `tar-mode' buffer."
(package-import-keyring keyring)
(package-refresh-contents)
(let ((package-check-signature 'allow-unsigned))
- (should (package-install 'signed-good))
+ (should (progn (package-install 'signed-good) 'noerror))
(should-error (package-install 'signed-bad)))
+ (package-delete (car (alist-get 'signed-good package-alist)))
(let ((package-check-signature t))
- (should (package-install 'signed-good))
+ (should (progn (package-install 'signed-good) 'noerror))
(should-error (package-install 'signed-bad)))
+ (package-delete (car (alist-get 'signed-good package-alist)))
(let ((package-check-signature nil))
- (should (package-install 'signed-good))
- (should (package-install 'signed-bad)))
+ (should (progn (package-install 'signed-good) 'noerror))
+ (should (progn (package-install 'signed-bad) 'noerror)))
;; Check if the installed package status is updated.
(let ((buf (package-list-packages)))
(package-menu-refresh)
@@ -504,7 +546,7 @@ Must called from within a `tar-mode' buffer."
(with-fake-help-buffer
(describe-package 'signed-good)
(goto-char (point-min))
- (should (re-search-forward "signed-good is an? \\(\\S-+\\) package." nil t))
+ (should (re-search-forward "Package signed-good is \\(\\S-+\\)\\." nil t))
(should (string-equal (match-string-no-properties 1) "installed"))
(should (re-search-forward
"Status: Installed in ['`‘]signed-good-1.0/['’]."
@@ -556,8 +598,17 @@ Must called from within a `tar-mode' buffer."
(setq archive-contents
(package-read-from-string
(buffer-substring (point-min) (point-max)))))
- (should (equal archive-contents
- (list 1 package-x-test--single-archive-entry-1-3))))))
+ (should (equal 1 (car archive-contents)))
+ (should (equal 2 (length archive-contents)))
+ (let ((pac (cadr archive-contents))
+ (pac-sample package-x-test--single-archive-entry-1-3))
+ (should (equal (pop pac) (pop pac-sample)))
+ (dotimes (i 4)
+ (should (equal (aref pac i) (aref pac-sample i))))
+ ;; The `extras' field should contain at least the specified elements.
+ (should (cl-every (lambda (sample-elem)
+ (member sample-elem (aref pac 4)))
+ (aref pac-sample 4)))))))
(ert-deftest package-x-test-upload-new-version ()
"Test uploading a new version of a package"
@@ -577,8 +628,17 @@ Must called from within a `tar-mode' buffer."
(setq archive-contents
(package-read-from-string
(buffer-substring (point-min) (point-max)))))
- (should (equal archive-contents
- (list 1 package-x-test--single-archive-entry-1-4))))))
+ (should (equal 1 (car archive-contents)))
+ (should (equal 2 (length archive-contents)))
+ (let ((pac (cadr archive-contents))
+ (pac-sample package-x-test--single-archive-entry-1-4))
+ (should (equal (pop pac) (pop pac-sample)))
+ (dotimes (i 4)
+ (should (equal (aref pac i) (aref pac-sample i))))
+ ;; The `extras' field should contain at least the specified elements.
+ (should (cl-every (lambda (sample-elem)
+ (member sample-elem (aref pac 4)))
+ (aref pac-sample 4)))))))
(ert-deftest package-test-get-deps ()
"Test `package--get-deps' with complex structures."
diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el
index bc451a6212f..af8c9a3f3c3 100644
--- a/test/lisp/emacs-lisp/pcase-tests.el
+++ b/test/lisp/emacs-lisp/pcase-tests.el
@@ -51,11 +51,13 @@
(ert-deftest pcase-tests-member ()
(should (pcase-tests-grep
- 'memq (macroexpand-all '(pcase x ((or 1 2 3) body)))))
+ 'memql (macroexpand-all '(pcase x ((or 1 2 3) body)))))
(should (pcase-tests-grep
- 'member (macroexpand-all '(pcase x ((or '"a" '2 '3) body)))))
+ 'member (macroexpand-all '(pcase x ((or "a" 2 3) body)))))
(should-not (pcase-tests-grep
'memq (macroexpand-all '(pcase x ((or "a" 2 3) body)))))
+ (should-not (pcase-tests-grep
+ 'memql (macroexpand-all '(pcase x ((or "a" 2 3) body)))))
(let ((exp (macroexpand-all
'(pcase x
("a" body1)
diff --git a/test/lisp/emacs-lisp/ring-tests.el b/test/lisp/emacs-lisp/ring-tests.el
index 0b6b57c6f8f..991c4e55119 100644
--- a/test/lisp/emacs-lisp/ring-tests.el
+++ b/test/lisp/emacs-lisp/ring-tests.el
@@ -162,6 +162,43 @@
(should (= (ring-size ring) 5))
(should (equal (ring-elements ring) '(3 2 1)))))
+(ert-deftest ring-resize/grow ()
+ (let ((ring (make-ring 3)))
+ (ring-insert ring 1)
+ (ring-insert ring 2)
+ (ring-insert ring 3)
+ (ring-resize ring 5)
+ (should (= (ring-size ring) 5))
+ (should (equal (ring-elements ring) '(3 2 1)))))
+
+(ert-deftest ring-resize/grow-empty ()
+ (let ((ring (make-ring 3)))
+ (ring-resize ring 5)
+ (should (= (ring-size ring) 5))
+ (should (equal (ring-elements ring) '()))))
+
+(ert-deftest ring-resize/grow-wrapped-ring ()
+ (let ((ring (make-ring 3)))
+ (ring-insert ring 1)
+ (ring-insert ring 2)
+ (ring-insert ring 3)
+ (ring-insert ring 4)
+ (ring-insert ring 5)
+ (ring-resize ring 5)
+ (should (= (ring-size ring) 5))
+ (should (equal (ring-elements ring) '(5 4 3)))))
+
+(ert-deftest ring-resize/shrink ()
+ (let ((ring (make-ring 5)))
+ (ring-insert ring 1)
+ (ring-insert ring 2)
+ (ring-insert ring 3)
+ (ring-insert ring 4)
+ (ring-insert ring 5)
+ (ring-resize ring 3)
+ (should (= (ring-size ring) 3))
+ (should (equal (ring-elements ring) '(5 4 3)))))
+
(ert-deftest ring-tests-insert ()
(let ((ring (make-ring 2)))
(ring-insert+extend ring :a)
diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el
index 9f5a6a62c30..4a5919edf02 100644
--- a/test/lisp/emacs-lisp/rx-tests.el
+++ b/test/lisp/emacs-lisp/rx-tests.el
@@ -25,7 +25,7 @@
;;; Code:
(ert-deftest rx-char-any ()
- "Test character alternatives with `\]' and `-' (Bug#25123)."
+ "Test character alternatives with `]' and `-' (Bug#25123)."
(should (string-match
(rx string-start (1+ (char (?\] . ?\{) (?< . ?\]) (?- . ?:)))
string-end)
@@ -33,6 +33,36 @@
(number-sequence ?< ?\])
(number-sequence ?- ?:))))))
+(ert-deftest rx-char-any-range-nl ()
+ "Test character alternatives with LF as a range endpoint."
+ (should (equal (rx (any "\n-\r"))
+ "[\n-\r]"))
+ (should (equal (rx (any "\a-\n"))
+ "[\a-\n]")))
+
+(ert-deftest rx-char-any-range-bad ()
+ (should-error (rx (any "0-9a-Z")))
+ (should-error (rx (any (?0 . ?9) (?a . ?Z)))))
+
+(ert-deftest rx-char-any-raw-byte ()
+ "Test raw bytes in character alternatives."
+ ;; Separate raw characters.
+ (should (equal (string-match-p (rx (any "\326A\333B"))
+ "X\326\333")
+ 1))
+ ;; Range of raw characters, unibyte.
+ (should (equal (string-match-p (rx (any "\200-\377"))
+ "ÿA\310B")
+ 2))
+ ;; Range of raw characters, multibyte.
+ (should (equal (string-match-p (rx (any "Å\211\326-\377\177"))
+ "XY\355\177\327")
+ 2))
+ ;; Split range; \177-\377ÿ should not be optimised to \177-\377.
+ (should (equal (string-match-p (rx (any "\177-\377" ?ÿ))
+ "ÿA\310B")
+ 0)))
+
(ert-deftest rx-pcase ()
(should (equal (pcase "a 1 2 3 1 1 b"
((rx (let u (+ digit)) space
@@ -43,5 +73,41 @@
(list u v)))
'("1" "3"))))
+(ert-deftest rx-kleene ()
+ "Test greedy and non-greedy repetition operators."
+ (should (equal (rx (* "a") (+ "b") (\? "c") (?\s "d")
+ (*? "e") (+? "f") (\?? "g") (?? "h"))
+ "a*b+c?d?e*?f+?g??h??"))
+ (should (equal (rx (zero-or-more "a") (0+ "b")
+ (one-or-more "c") (1+ "d")
+ (zero-or-one "e") (optional "f") (opt "g"))
+ "a*b*c+d+e?f?g?"))
+ (should (equal (rx (minimal-match
+ (seq (* "a") (+ "b") (\? "c") (?\s "d")
+ (*? "e") (+? "f") (\?? "g") (?? "h"))))
+ "a*b+c?d?e*?f+?g??h??"))
+ (should (equal (rx (minimal-match
+ (seq (zero-or-more "a") (0+ "b")
+ (one-or-more "c") (1+ "d")
+ (zero-or-one "e") (optional "f") (opt "g"))))
+ "a*?b*?c+?d+?e??f??g??"))
+ (should (equal (rx (maximal-match
+ (seq (* "a") (+ "b") (\? "c") (?\s "d")
+ (*? "e") (+? "f") (\?? "g") (?? "h"))))
+ "a*b+c?d?e*?f+?g??h??")))
+
+(ert-deftest rx-or ()
+ ;; Test or-pattern reordering (Bug#34641).
+ (let ((s "abc"))
+ (should (equal (and (string-match (rx (or "abc" "ab" "a")) s)
+ (match-string 0 s))
+ "abc"))
+ (should (equal (and (string-match (rx (or "ab" "abc" "a")) s)
+ (match-string 0 s))
+ "ab"))
+ (should (equal (and (string-match (rx (or "a" "ab" "abc")) s)
+ (match-string 0 s))
+ "a"))))
+
(provide 'rx-tests)
;; rx-tests.el ends here.
diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el
index deb2829db45..ef05e2b389d 100644
--- a/test/lisp/emacs-lisp/seq-tests.el
+++ b/test/lisp/emacs-lisp/seq-tests.el
@@ -185,6 +185,18 @@ Evaluate BODY for each created sequence.
(with-test-sequences (seq '(3 4 5 6))
(should (= 5 (seq-contains seq 5)))))
+(ert-deftest test-seq-contains-p ()
+ (with-test-sequences (seq '(3 4 5 6))
+ (should (eq (seq-contains-p seq 3) t))
+ (should-not (seq-contains-p seq 7)))
+ (with-test-sequences (seq '())
+ (should-not (seq-contains-p seq 3))
+ (should-not (seq-contains-p seq nil))))
+
+(ert-deftest test-seq-contains-p-with-nil ()
+ (should (seq-contains-p [nil] nil))
+ (should (seq-contains-p '(nil) nil)))
+
(ert-deftest test-seq-every-p ()
(with-test-sequences (seq '(43 54 22 1))
(should (seq-every-p (lambda (elt) t) seq))
@@ -424,5 +436,30 @@ Evaluate BODY for each created sequence.
(should (eq (seq-into vec 'vector) vec))
(should (eq (seq-into str 'string) str))))
+(ert-deftest test-seq-first ()
+ (let ((lst '(1 2 3))
+ (vec [1 2 3]))
+ (should (eq (seq-first lst) 1))
+ (should (eq (seq-first vec) 1))))
+
+(ert-deftest test-seq-rest ()
+ (let ((lst '(1 2 3))
+ (vec [1 2 3]))
+ (should (equal (seq-rest lst) '(2 3)))
+ (should (equal (seq-rest vec) [2 3]))))
+
+;; Regression tests for bug#34852
+(progn
+ (ert-deftest test-seq-intersection-with-nil ()
+ (should (equal (seq-intersection '(1 2 nil) '(1 nil)) '(1 nil))))
+
+ (ert-deftest test-seq-set-equal-p-with-nil ()
+ (should (seq-set-equal-p '("a" "b" nil)
+ '(nil "b" "a"))))
+
+ (ert-deftest test-difference-with-nil ()
+ (should (equal (seq-difference '(1 nil) '(2 nil))
+ '(1)))))
+
(provide 'seq-tests)
;;; seq-tests.el ends here
diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el
index 519cb384920..d3cb2b140d9 100644
--- a/test/lisp/emacs-lisp/subr-x-tests.el
+++ b/test/lisp/emacs-lisp/subr-x-tests.el
@@ -148,34 +148,34 @@
"Test `if-let' with falsie bindings."
(should (equal
(if-let* ((a nil))
- (list a b c)
+ "yes"
"no")
"no"))
(should (equal
(if-let* ((a nil) (b 2) (c 3))
- (list a b c)
+ "yes"
"no")
"no"))
(should (equal
(if-let* ((a 1) (b nil) (c 3))
- (list a b c)
+ "yes"
"no")
"no"))
(should (equal
(if-let* ((a 1) (b 2) (c nil))
- (list a b c)
+ "yes"
"no")
"no"))
(should (equal
(let (z)
(if-let* (z (a 1) (b 2) (c 3))
- (list a b c)
+ "yes"
"no"))
"no"))
(should (equal
(let (d)
(if-let* ((a 1) (b 2) (c 3) d)
- (list a b c)
+ "yes"
"no"))
"no")))
@@ -312,34 +312,28 @@
"Test `when-let' with falsie bindings."
(should (equal
(when-let* ((a nil))
- (list a b c)
"no")
nil))
(should (equal
(when-let* ((a nil) (b 2) (c 3))
- (list a b c)
"no")
nil))
(should (equal
(when-let* ((a 1) (b nil) (c 3))
- (list a b c)
"no")
nil))
(should (equal
(when-let* ((a 1) (b 2) (c nil))
- (list a b c)
"no")
nil))
(should (equal
(let (z)
(when-let* (z (a 1) (b 2) (c 3))
- (list a b c)
"no"))
nil))
(should (equal
(let (d)
(when-let* ((a 1) (b 2) (c 3) d)
- (list a b c)
"no"))
nil)))
@@ -538,6 +532,53 @@
(format "abs sum is: %s"))
"abs sum is: 15")))
+
+;; Substring tests
+
+(ert-deftest subr-x-test-string-trim-left ()
+ "Test `string-trim-left' behavior."
+ (should (equal (string-trim-left "") ""))
+ (should (equal (string-trim-left " \t\n\r") ""))
+ (should (equal (string-trim-left " \t\n\ra") "a"))
+ (should (equal (string-trim-left "a \t\n\r") "a \t\n\r"))
+ (should (equal (string-trim-left "" "") ""))
+ (should (equal (string-trim-left "a" "") "a"))
+ (should (equal (string-trim-left "aa" "a*") ""))
+ (should (equal (string-trim-left "ba" "a*") "ba"))
+ (should (equal (string-trim-left "aa" "a*?") "aa"))
+ (should (equal (string-trim-left "aa" "a+?") "a")))
+
+(ert-deftest subr-x-test-string-trim-right ()
+ "Test `string-trim-right' behavior."
+ (should (equal (string-trim-right "") ""))
+ (should (equal (string-trim-right " \t\n\r") ""))
+ (should (equal (string-trim-right " \t\n\ra") " \t\n\ra"))
+ (should (equal (string-trim-right "a \t\n\r") "a"))
+ (should (equal (string-trim-right "" "") ""))
+ (should (equal (string-trim-right "a" "") "a"))
+ (should (equal (string-trim-right "aa" "a*") ""))
+ (should (equal (string-trim-right "ab" "a*") "ab"))
+ (should (equal (string-trim-right "aa" "a*?") "")))
+
+(ert-deftest subr-x-test-string-remove-prefix ()
+ "Test `string-remove-prefix' behavior."
+ (should (equal (string-remove-prefix "" "") ""))
+ (should (equal (string-remove-prefix "" "a") "a"))
+ (should (equal (string-remove-prefix "a" "") ""))
+ (should (equal (string-remove-prefix "a" "b") "b"))
+ (should (equal (string-remove-prefix "a" "a") ""))
+ (should (equal (string-remove-prefix "a" "aa") "a"))
+ (should (equal (string-remove-prefix "a" "ab") "b")))
+
+(ert-deftest subr-x-test-string-remove-suffix ()
+ "Test `string-remove-suffix' behavior."
+ (should (equal (string-remove-suffix "" "") ""))
+ (should (equal (string-remove-suffix "" "a") "a"))
+ (should (equal (string-remove-suffix "a" "") ""))
+ (should (equal (string-remove-suffix "a" "b") "b"))
+ (should (equal (string-remove-suffix "a" "a") ""))
+ (should (equal (string-remove-suffix "a" "aa") "a"))
+ (should (equal (string-remove-suffix "a" "ba") "b")))
(provide 'subr-x-tests)
;;; subr-x-tests.el ends here
diff --git a/test/lisp/emacs-lisp/testcover-resources/testcases.el b/test/lisp/emacs-lisp/testcover-resources/testcases.el
index 832775a730d..571e9ab3884 100644
--- a/test/lisp/emacs-lisp/testcover-resources/testcases.el
+++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el
@@ -53,7 +53,6 @@
;; ==== constants-bug-25316 ====
"Testcover doesn't splotch constants."
-:expected-result :failed
;; ====
(defconst testcover-testcase-const "apples")
(defun testcover-testcase-zero () 0)
@@ -76,7 +75,6 @@
;; ==== customize-defcustom-bug-25326 ====
"Testcover doesn't prevent testing of defcustom values."
-:expected-result :failed
;; ====
(defgroup testcover-testcase nil
"Test case for testcover"
@@ -135,7 +133,6 @@
;; ==== 1-value-symbol-bug-25316 ====
"Wrapping a form with 1value prevents splotching."
-:expected-result :failed
;; ====
(defun testcover-testcase-always-zero (num)
(- num%%% num%%%)%%%)
@@ -229,8 +226,7 @@
(should-not (testcover-testcase-cc nil))
;; ==== quotes-within-backquotes-bug-25316 ====
-"Forms to instrument are found within quotes within backquotes."
-:expected-result :failed
+"Forms to analyze are found within quotes within backquotes."
;; ====
(defun testcover-testcase-make-list ()
(list 'defun 'defvar))
@@ -296,7 +292,6 @@
;; ==== backquote-1value-bug-24509 ====
"Commas within backquotes are recognized as non-1value."
-:expected-result :failed
;; ====
(defmacro testcover-testcase-lambda (&rest body)
`(lambda () ,@body))
@@ -320,7 +315,6 @@
;; ==== pcase-bug-24688 ====
"Testcover copes with condition-case within backquoted list."
-:expected-result :failed
;; ====
(defun testcover-testcase-pcase (form)
(pcase form%%%
@@ -335,7 +329,6 @@
;; ==== defun-in-backquote-bug-11307-and-24743 ====
"Testcover handles defun forms within backquoted list."
-:expected-result :failed
;; ====
(defmacro testcover-testcase-defun (name &rest body)
(declare (debug (symbolp def-body)))
@@ -348,7 +341,6 @@
;; ==== closure-1value-bug ====
"Testcover does not mark closures as 1value."
-:expected-result :failed
;; ====
;; -*- lexical-binding:t -*-
(setq testcover-testcase-foo nil)
@@ -365,7 +357,6 @@
;; ==== by-value-vs-by-reference-bug-25351 ====
"An object created by a 1value expression may be modified by other code."
-:expected-result :failed
;; ====
(defun testcover-testcase-ab ()
(list 'a 'b))
@@ -386,7 +377,7 @@
(should-error (testcover-testcase-thing 3))
;; ==== dotted-backquote ====
-"Testcover correctly instruments dotted backquoted lists."
+"Testcover can analyze code inside dotted backquoted lists."
;; ====
(defun testcover-testcase-dotted-bq (flag extras)
(let* ((bq
@@ -396,9 +387,16 @@
(should (equal '(a b c) (testcover-testcase-dotted-bq nil '(d e))))
(should (equal '(a b c d e) (testcover-testcase-dotted-bq t '(d e))))
+;; ==== quoted-backquote ====
+"Testcover correctly handles the quoted backquote symbol."
+;; ====
+(defun testcover-testcase-special-symbols ()
+ (list '\` '\, '\,@))
+
+(should (equal '(\` \, \,@) (testcover-testcase-special-symbols)))
+
;; ==== backquoted-vector-bug-25316 ====
-"Testcover reinstruments within backquoted vectors."
-:expected-result :failed
+"Testcover can analyze code within backquoted vectors."
;; ====
(defun testcover-testcase-vec (a b c)
`[,a%%% ,(list b%%% c%%%)%%%]%%%)
@@ -413,9 +411,15 @@
(should (equal '([[4 5] 6]) (testcover-testcase-vec-in-list 4 5 6)))
(should (equal '([100]) (testcover-testcase-vec-arg 100)))
+;; ==== dotted-list-in-vector-bug-30909 ====
+"Testcover can analyze dotted pairs within vectors."
+;; ====
+(defun testcover-testcase-vectors-with-dotted-pairs ()
+ (equal [(1 . "x")] [(1 2 . "y")])%%%)
+(should-not (testcover-testcase-vectors-with-dotted-pairs))
+
;; ==== vector-in-macro-spec-bug-25316 ====
-"Testcover reinstruments within vectors."
-:expected-result :failed
+"Testcover can analyze code inside vectors."
;; ====
(defmacro testcover-testcase-nth-case (arg vec)
(declare (indent 1)
@@ -435,7 +439,6 @@
;; ==== mapcar-is-not-compose ====
"Mapcar with 1value arguments is not 1value."
-:expected-result :failed
;; ====
(defvar testcover-testcase-num 0)
(defun testcover-testcase-add-num (n)
@@ -450,10 +453,10 @@
;; ==== function-with-edebug-spec-bug-25316 ====
"Functions can have edebug specs too.
-See c-make-font-lock-search-function for an example in the Emacs
-sources. The other issue is that it's ok to use quote in an
-edebug spec, so testcover needs to cope with that."
-:expected-result :failed
+See `c-make-font-lock-search-function' for an example in the
+Emacs sources. `c-make-font-lock-search-function''s Edebug spec
+also contains a quote. See comment in `testcover-analyze-coverage'
+regarding the odd-looking coverage result for the quoted form."
;; ====
(defun testcover-testcase-make-function (forms)
`(lambda (flag) (if flag 0 ,@forms%%%))%%%)
@@ -462,7 +465,7 @@ edebug spec, so testcover needs to cope with that."
(("quote" (&rest def-form))))
(defun testcover-testcase-thing ()
- (testcover-testcase-make-function '((+ 1 (+ 2 (+ 3 (+ 4 5))))))%%%)
+ (testcover-testcase-make-function '(!!!(+ 1 !!!(+ 2 !!!(+ 3 !!!(+ 4 5)%%%)%%%)%%%)%%%))%%%)
(defun testcover-testcase-use-thing ()
(funcall (testcover-testcase-thing)%%% nil)%%%)
@@ -470,7 +473,7 @@ edebug spec, so testcover needs to cope with that."
(should (equal (testcover-testcase-use-thing) 15))
;; ==== backquoted-dotted-alist ====
-"Testcover can instrument a dotted alist constructed with backquote."
+"Testcover can analyze a dotted alist constructed with backquote."
;; ====
(defun testcover-testcase-make-alist (expr entries)
`((0 . ,expr%%%) . ,entries%%%)%%%)
@@ -494,10 +497,18 @@ edebug spec, so testcover needs to cope with that."
"Testcover captures and ignores circular list errors."
;; ====
(defun testcover-testcase-cyc1 (a)
- (let ((ls (make-list 10 a%%%)))
- (nconc ls ls)
- ls))
+ (let ((ls (make-list 10 a%%%)%%%))
+ (nconc ls%%% ls%%%)
+ ls)) ; The lack of a mark here is due to an ignored circular list error.
(testcover-testcase-cyc1 1)
(testcover-testcase-cyc1 1)
+(defun testcover-testcase-cyc2 (a b)
+ (let ((ls1 (make-list 10 a%%%)%%%)
+ (ls2 (make-list 10 b)))
+ (nconc ls2 ls2)
+ (nconc ls1%%% ls2)
+ ls1))
+(testcover-testcase-cyc2 1 2)
+(testcover-testcase-cyc2 1 4)
;; testcases.el ends here.
diff --git a/test/lisp/emacs-lisp/testcover-tests.el b/test/lisp/emacs-lisp/testcover-tests.el
index 6f9ee694d3e..cbef493cc84 100644
--- a/test/lisp/emacs-lisp/testcover-tests.el
+++ b/test/lisp/emacs-lisp/testcover-tests.el
@@ -124,14 +124,12 @@ arguments for `testcover-start'."
(save-current-buffer
(set-buffer (find-file-noselect tempfile))
;; Fail the test if the debugger tries to become active,
- ;; which will happen if Testcover's reinstrumentation
- ;; leaves an edebug-enter in the code. This will also
- ;; prevent debugging these tests using Edebug.
- (cl-letf (((symbol-function #'edebug-enter)
+ ;; which can happen if Testcover fails to attach itself
+ ;; correctly. Note that this will prevent debugging
+ ;; these tests using Edebug.
+ (cl-letf (((symbol-function #'edebug-default-enter)
(lambda (&rest _args)
- (ert-fail
- (concat "Debugger invoked during test run "
- "(possible edebug-enter not replaced)")))))
+ (ert-fail "Debugger invoked during test run"))))
(dolist (byte-compile '(t nil))
(testcover-tests-unmarkup-region (point-min) (point-max))
(unwind-protect
diff --git a/test/lisp/emacs-lisp/text-property-search-tests.el b/test/lisp/emacs-lisp/text-property-search-tests.el
new file mode 100644
index 00000000000..47db54a0512
--- /dev/null
+++ b/test/lisp/emacs-lisp/text-property-search-tests.el
@@ -0,0 +1,113 @@
+;;; text-property-search-tests.el --- Testing text-property-search
+
+;; Copyright (C) 2018-2019 Free Software Foundation, Inc.
+
+;; Author: Lars Ingebrigtsen <larsi@gnus.org>
+;; Keywords:
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;
+
+;;; Code:
+
+(require 'ert)
+(require 'text-property-search)
+(require 'cl-lib)
+
+(defun text-property-setup ()
+ (insert "This is "
+ (propertize "bold1" 'face 'bold)
+ " and this is "
+ (propertize "italic1" 'face 'italic)
+ (propertize "bold2" 'face 'bold)
+ (propertize "italic2" 'face 'italic)
+ " at the end")
+ (goto-char (point-min)))
+
+(defmacro with-test (form result &optional point)
+ `(with-temp-buffer
+ (text-property-setup)
+ (when ,point
+ (goto-char ,point))
+ (should
+ (equal
+ (cl-loop for match = ,form
+ while match
+ collect (buffer-substring (prop-match-beginning match)
+ (prop-match-end match)))
+ ,result))))
+
+(ert-deftest text-property-search-forward-bold-t ()
+ (with-test (text-property-search-forward 'face 'bold t)
+ '("bold1" "bold2")))
+
+(ert-deftest text-property-search-forward-bold-nil ()
+ (with-test (text-property-search-forward 'face 'bold nil)
+ '("This is " " and this is italic1" "italic2 at the end")))
+
+(ert-deftest text-property-search-forward-nil-t ()
+ (with-test (text-property-search-forward 'face nil t)
+ '("This is " " and this is " " at the end")))
+
+(ert-deftest text-property-search-forward-nil-nil ()
+ (with-test (text-property-search-forward 'face nil nil)
+ '("bold1" "italic1" "bold2" "italic2")))
+
+(ert-deftest text-property-search-forward-partial-bold-t ()
+ (with-test (text-property-search-forward 'face 'bold t)
+ '("old1" "bold2")
+ 10))
+
+(ert-deftest text-property-search-forward-partial-non-current-bold-t ()
+ (with-test (text-property-search-forward 'face 'bold t t)
+ '("bold2")
+ 10))
+
+
+(ert-deftest text-property-search-backward-bold-t ()
+ (with-test (text-property-search-backward 'face 'bold t)
+ '("bold2" "bold1")
+ (point-max)))
+
+(ert-deftest text-property-search-backward-bold-nil ()
+ (with-test (text-property-search-backward 'face 'bold nil)
+ '( "italic2 at the end" " and this is italic1" "This is ")
+ (point-max)))
+
+(ert-deftest text-property-search-backward-nil-t ()
+ (with-test (text-property-search-backward 'face nil t)
+ '(" at the end" " and this is " "This is ")
+ (point-max)))
+
+(ert-deftest text-property-search-backward-nil-nil ()
+ (with-test (text-property-search-backward 'face nil nil)
+ '("italic2" "bold2" "italic1" "bold1")
+ (point-max)))
+
+(ert-deftest text-property-search-backward-partial-bold-t ()
+ (with-test (text-property-search-backward 'face 'bold t)
+ '("b" "bold1")
+ 35))
+
+(ert-deftest text-property-search-backward-partial-non-current-bold-t ()
+ (with-test (text-property-search-backward 'face 'bold t t)
+ '("bold1")
+ 35))
+
+(provide 'text-property-search-tests)
+
+;;; text-property-search-tests.el ends here
diff --git a/test/lisp/emacs-lisp/thunk-tests.el b/test/lisp/emacs-lisp/thunk-tests.el
index 9efc2d1f705..caa2c415460 100644
--- a/test/lisp/emacs-lisp/thunk-tests.el
+++ b/test/lisp/emacs-lisp/thunk-tests.el
@@ -51,5 +51,55 @@
(thunk-force thunk)
(should (= x 1))))
+
+
+;; thunk-let tests
+
+(ert-deftest thunk-let-basic-test ()
+ "Test whether bindings are established."
+ (should (equal (thunk-let ((x 1) (y 2)) (+ x y)) 3)))
+
+(ert-deftest thunk-let*-basic-test ()
+ "Test whether bindings are established."
+ (should (equal (thunk-let* ((x 1) (y (+ 1 x))) (+ x y)) 3)))
+
+(ert-deftest thunk-let-bound-vars-cant-be-set-test ()
+ "Test whether setting a `thunk-let' bound variable fails."
+ (should-error
+ (eval '(thunk-let ((x 1)) (let ((y 7)) (setq x (+ x y)) (* 10 x))) t)))
+
+(ert-deftest thunk-let-laziness-test ()
+ "Test laziness of `thunk-let'."
+ (should
+ (equal (let ((x-evalled nil)
+ (y-evalled nil))
+ (thunk-let ((x (progn (setq x-evalled t) (+ 1 2)))
+ (y (progn (setq y-evalled t) (+ 3 4))))
+ (let ((evalled-y y))
+ (list x-evalled y-evalled evalled-y))))
+ (list nil t 7))))
+
+(ert-deftest thunk-let*-laziness-test ()
+ "Test laziness of `thunk-let*'."
+ (should
+ (equal (let ((x-evalled nil)
+ (y-evalled nil)
+ (z-evalled nil)
+ (a-evalled nil))
+ (thunk-let* ((x (progn (setq x-evalled t) (+ 1 1)))
+ (y (progn (setq y-evalled t) (+ x 1)))
+ (z (progn (setq z-evalled t) (+ y 1)))
+ (a (progn (setq a-evalled t) (+ z 1))))
+ (let ((evalled-z z))
+ (list x-evalled y-evalled z-evalled a-evalled evalled-z))))
+ (list t t t nil 4))))
+
+(ert-deftest thunk-let-bad-binding-test ()
+ "Test whether a bad binding causes an error when expanding."
+ (should-error (macroexpand '(thunk-let ((x 1 1)) x)))
+ (should-error (macroexpand '(thunk-let (27) x)))
+ (should-error (macroexpand '(thunk-let x x))))
+
+
(provide 'thunk-tests)
;;; thunk-tests.el ends here
diff --git a/test/lisp/emacs-lisp/timer-tests.el b/test/lisp/emacs-lisp/timer-tests.el
index 1d2a83cd7ed..bd2dcbe554e 100644
--- a/test/lisp/emacs-lisp/timer-tests.el
+++ b/test/lisp/emacs-lisp/timer-tests.el
@@ -39,4 +39,29 @@
(if (fboundp 'debug-timer-check)
(should (debug-timer-check)) t))
+(ert-deftest timer-test-multiple-of-time ()
+ (should (time-equal-p
+ (timer-next-integral-multiple-of-time '(0 0 0 1) (1+ (ash 1 53)))
+ (list (ash 1 (- 53 16)) 1))))
+
+(ert-deftest timer-next-integral-multiple-of-time-2 ()
+ "Test bug#33071."
+ (let* ((tc (current-time))
+ (delta-ticks 1000)
+ (hz 128000)
+ (tce (encode-time tc hz))
+ (tc+delta (time-add tce (cons delta-ticks hz)))
+ (tc+deltae (encode-time tc+delta hz))
+ (tc+delta-ticks (car tc+deltae))
+ (tc-nexte (cons (- tc+delta-ticks (% tc+delta-ticks delta-ticks)) hz))
+ (nt (timer-next-integral-multiple-of-time
+ tc (/ (float delta-ticks) hz)))
+ (nte (encode-time nt hz)))
+ (should (equal tc-nexte nte))))
+
+(ert-deftest timer-next-integral-multiple-of-time-3 ()
+ "Test bug#33071."
+ (let ((nt (timer-next-integral-multiple-of-time '(32770 . 65539) 0.5)))
+ (should (time-equal-p 1 nt))))
+
;;; timer-tests.el ends here
diff --git a/test/lisp/epg-tests.el b/test/lisp/epg-tests.el
index 98e08fca750..1a11e418384 100644
--- a/test/lisp/epg-tests.el
+++ b/test/lisp/epg-tests.el
@@ -30,8 +30,28 @@
(expand-file-name "data/epg" (getenv "EMACS_TEST_DIRECTORY"))
"Directory containing epg test data.")
-(defun epg-tests-find-usable-gpg-configuration (&optional _require-passphrase)
- (epg-find-configuration 'OpenPGP 'no-cache))
+(defconst epg-tests--config-program-alist
+ ;; The default `epg-config--program-alist' requires gpg2 2.1 or
+ ;; greater due to some practical problems with pinentry. But most
+ ;; tests here work fine with 2.0 as well.
+ (let ((prog-alist (copy-tree epg-config--program-alist)))
+ (setf (alist-get "gpg2"
+ (alist-get 'OpenPGP prog-alist)
+ nil nil #'equal)
+ "2.0")
+ prog-alist))
+
+(defun epg-tests-find-usable-gpg-configuration
+ (&optional require-passphrase require-public-key)
+ ;; Clear config cache because we may be using a different
+ ;; program-alist. We do want to update the cache, so that
+ ;; `epg-make-context' can use our result.
+ (setq epg--configurations nil)
+ (epg-find-configuration 'OpenPGP nil
+ ;; The symmetric operations fail on Hydra
+ ;; with gpg 2.0.
+ (if (or (not require-passphrase) require-public-key)
+ epg-tests--config-program-alist)))
(defun epg-tests-passphrase-callback (_c _k _d)
;; Need to create a copy here, since the string will be wiped out
@@ -51,16 +71,18 @@
(format "GNUPGHOME=%s" epg-tests-home-directory))
process-environment)))
(unwind-protect
- (let ((context (epg-make-context 'OpenPGP)))
+ ;; GNUPGHOME is needed to find a usable gpg, so we can't
+ ;; check whether to skip any earlier (Bug#23561).
+ (let ((epg-config (or (epg-tests-find-usable-gpg-configuration
+ ,require-passphrase ,require-public-key)
+ (ert-skip "No usable gpg config")))
+ (context (epg-make-context 'OpenPGP)))
(setf (epg-context-program context)
- (alist-get 'program
- (epg-tests-find-usable-gpg-configuration
- ,(if require-passphrase
- `'require-passphrase))))
+ (alist-get 'program epg-config))
(setf (epg-context-home-directory context)
epg-tests-home-directory)
,(if require-passphrase
- `(with-temp-file (expand-file-name
+ '(with-temp-file (expand-file-name
"gpg-agent.conf" epg-tests-home-directory)
(insert "pinentry-program "
(expand-file-name "dummy-pinentry"
@@ -70,11 +92,11 @@
context
#'epg-tests-passphrase-callback)))
,(if require-public-key
- `(epg-import-keys-from-file
+ '(epg-import-keys-from-file
context
(expand-file-name "pubkey.asc" epg-tests-data-directory)))
,(if require-secret-key
- `(epg-import-keys-from-file
+ '(epg-import-keys-from-file
context
(expand-file-name "seckey.asc" epg-tests-data-directory)))
(with-temp-buffer
@@ -85,7 +107,7 @@
(delete-directory epg-tests-home-directory t)))))
(ert-deftest epg-decrypt-1 ()
- (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase))
+ :expected-result (if (getenv "EMACS_HYDRA_CI") :failed :passed) ; fixme
(with-epg-tests (:require-passphrase t)
(with-temp-file (expand-file-name "gpg.conf" epg-tests-home-directory)
(insert "ignore-mdc-error"))
@@ -99,14 +121,13 @@ jA0EAwMCE19JBLTvvmhgyRrGGglRbnKkK9PJG8fDwO5ccjysrR7IcdNcnA==
-----END PGP MESSAGE-----")))))
(ert-deftest epg-roundtrip-1 ()
- (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase))
+ :expected-result (if (getenv "EMACS_HYDRA_CI") :failed :passed) ; fixme
(with-epg-tests (:require-passphrase t)
(let ((cipher (epg-encrypt-string epg-tests-context "symmetric" nil)))
(should (equal "symmetric"
(epg-decrypt-string epg-tests-context cipher))))))
(ert-deftest epg-roundtrip-2 ()
- (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase))
(with-epg-tests (:require-passphrase t
:require-public-key t
:require-secret-key t)
@@ -117,7 +138,6 @@ jA0EAwMCE19JBLTvvmhgyRrGGglRbnKkK9PJG8fDwO5ccjysrR7IcdNcnA==
(epg-decrypt-string epg-tests-context cipher))))))
(ert-deftest epg-sign-verify-1 ()
- (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase))
(with-epg-tests (:require-passphrase t
:require-public-key t
:require-secret-key t)
@@ -131,7 +151,6 @@ jA0EAwMCE19JBLTvvmhgyRrGGglRbnKkK9PJG8fDwO5ccjysrR7IcdNcnA==
(should (eq 'good (epg-signature-status (car verify-result)))))))
(ert-deftest epg-sign-verify-2 ()
- (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase))
(with-epg-tests (:require-passphrase t
:require-public-key t
:require-secret-key t)
@@ -147,7 +166,6 @@ jA0EAwMCE19JBLTvvmhgyRrGGglRbnKkK9PJG8fDwO5ccjysrR7IcdNcnA==
(should (eq 'good (epg-signature-status (car verify-result)))))))
(ert-deftest epg-sign-verify-3 ()
- (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase))
(with-epg-tests (:require-passphrase t
:require-public-key t
:require-secret-key t)
@@ -162,7 +180,6 @@ jA0EAwMCE19JBLTvvmhgyRrGGglRbnKkK9PJG8fDwO5ccjysrR7IcdNcnA==
(should (eq 'good (epg-signature-status (car verify-result)))))))
(ert-deftest epg-import-1 ()
- (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase))
(with-epg-tests (:require-passphrase nil)
(should (= 0 (length (epg-list-keys epg-tests-context))))
(should (= 0 (length (epg-list-keys epg-tests-context nil t)))))
diff --git a/test/lisp/eshell/em-ls-tests.el b/test/lisp/eshell/em-ls-tests.el
index a2072d6b392..d5f9d244be0 100644
--- a/test/lisp/eshell/em-ls-tests.el
+++ b/test/lisp/eshell/em-ls-tests.el
@@ -26,6 +26,7 @@
(require 'ert)
(require 'em-ls)
+(require 'dired)
(ert-deftest em-ls-test-bug27631 ()
"Test for https://debbugs.gnu.org/27631 ."
@@ -77,6 +78,11 @@
(ert-deftest em-ls-test-bug27844 ()
"Test for https://debbugs.gnu.org/27844 ."
+ ;; FIXME: it would be better to use something other than source-directory
+ ;; in this test.
+ (skip-unless (and source-directory
+ (file-exists-p
+ (expand-file-name "lisp/subr.el" source-directory))))
(let ((orig eshell-ls-use-in-dired)
(dired-use-ls-dired 'unspecified)
buf insert-directory-program)
@@ -87,7 +93,14 @@
(dired-toggle-marks)
(should (cdr (dired-get-marked-files)))
(kill-buffer buf)
- (setq buf (dired (expand-file-name "lisp/subr.el" source-directory)))
+ ;; Eshell's default format duplicates the year for non-recent files,
+ ;; eg "2015-05-06 2015", which doesn't make a lot of sense,
+ ;; and causes this portion of the test to fail if subr.el
+ ;; is non-recent (eg if building from a tarfile unpacked
+ ;; with a fixed early timestamp for reproducibility). Bug#33734.
+ (let ((eshell-ls-date-format "%b %e"))
+ (setq buf (dired (expand-file-name "lisp/subr.el"
+ source-directory))))
(should (looking-at "subr\\.el")))
(customize-set-variable 'eshell-ls-use-in-dired orig)
(and (buffer-live-p buf) (kill-buffer)))))
diff --git a/test/lisp/eshell/esh-opt-tests.el b/test/lisp/eshell/esh-opt-tests.el
new file mode 100644
index 00000000000..39284c08a11
--- /dev/null
+++ b/test/lisp/eshell/esh-opt-tests.el
@@ -0,0 +1,124 @@
+;;; tests/esh-opt-tests.el --- esh-opt test suite
+
+;; Copyright (C) 2018-2019 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'esh-opt)
+
+(ert-deftest esh-opt-process-args-test ()
+ "Unit tests which verify correct behavior of `eshell--process-args'."
+ (should
+ (equal '(t)
+ (eshell--process-args
+ "sudo"
+ '("-a")
+ '((?a "all" nil show-all "")))))
+ (should
+ (equal '(nil)
+ (eshell--process-args
+ "sudo"
+ '("-g")
+ '((?a "all" nil show-all "")))))
+ (should
+ (equal '("root" "world")
+ (eshell--process-args
+ "sudo"
+ '("-u" "root" "world")
+ '((?u "user" t user "execute a command as another USER")))))
+ (should
+ (equal '(nil "emerge" "-uDN" "world")
+ (eshell--process-args
+ "sudo"
+ '("emerge" "-uDN" "world")
+ '((?u "user" t user "execute a command as another USER")
+ :parse-leading-options-only))))
+ (should
+ (equal '("root" "emerge" "-uDN" "world")
+ (eshell--process-args
+ "sudo"
+ '("-u" "root" "emerge" "-uDN" "world")
+ '((?u "user" t user "execute a command as another USER")
+ :parse-leading-options-only))))
+ (should
+ (equal '("world" "emerge")
+ (eshell--process-args
+ "sudo"
+ '("-u" "root" "emerge" "-uDN" "world")
+ '((?u "user" t user "execute a command as another USER"))))))
+
+(ert-deftest test-eshell-eval-using-options ()
+ "Tests for `eshell-eval-using-options'."
+ (eshell-eval-using-options
+ "sudo" '("-u" "root" "whoami")
+ '((?u "user" t user "execute a command as another USER")
+ :parse-leading-options-only)
+ (should (equal user "root")))
+ (eshell-eval-using-options
+ "sudo" '("--user" "root" "whoami")
+ '((?u "user" t user "execute a command as another USER")
+ :parse-leading-options-only)
+ (should (equal user "root")))
+
+ (eshell-eval-using-options
+ "sudo" '("emerge" "-uDN" "world")
+ '((?u "user" t user "execute a command as another USER"))
+ (should (equal user "world")))
+ (eshell-eval-using-options
+ "sudo" '("emerge" "-uDN" "world")
+ '((?u "user" t user "execute a command as another USER")
+ :parse-leading-options-only)
+ (should (eq user nil)))
+
+ (eshell-eval-using-options
+ "ls" '("-I" "*.txt" "/dev/null")
+ '((?I "ignore" t ignore-pattern
+ "do not list implied entries matching pattern"))
+ (should (equal ignore-pattern "*.txt")))
+
+ (eshell-eval-using-options
+ "ls" '("-l" "/dev/null")
+ '((?l nil long-listing listing-style
+ "use a long listing format"))
+ (should (eql listing-style 'long-listing)))
+ (eshell-eval-using-options
+ "ls" '("/dev/null")
+ '((?l nil long-listing listing-style
+ "use a long listing format"))
+ (should (eq listing-style nil)))
+
+ (eshell-eval-using-options
+ "ls" '("/dev/null" "-h")
+ '((?h "human-readable" 1024 human-readable
+ "print sizes in human readable format"))
+ (should (eql human-readable 1024)))
+ (eshell-eval-using-options
+ "ls" '("/dev/null" "--human-readable")
+ '((?h "human-readable" 1024 human-readable
+ "print sizes in human readable format"))
+ (should (eql human-readable 1024)))
+ (eshell-eval-using-options
+ "ls" '("/dev/null")
+ '((?h "human-readable" 1024 human-readable
+ "print sizes in human readable format"))
+ (should (eq human-readable nil))))
+
+(provide 'esh-opt-tests)
+
+;;; esh-opt-tests.el ends here
diff --git a/test/lisp/eshell/eshell-tests.el b/test/lisp/eshell/eshell-tests.el
index 862594541bb..53cf854f210 100644
--- a/test/lisp/eshell/eshell-tests.el
+++ b/test/lisp/eshell/eshell-tests.el
@@ -31,6 +31,9 @@
(defmacro with-temp-eshell (&rest body)
"Evaluate BODY in a temporary Eshell buffer."
`(let* ((eshell-directory-name (make-temp-file "eshell" t))
+ ;; We want no history file, so prevent Eshell from falling
+ ;; back on $HISTFILE.
+ (process-environment (cons "HISTFILE" process-environment))
(eshell-history-file-name nil)
(eshell-buffer (eshell t)))
(unwind-protect
diff --git a/test/lisp/faces-tests.el b/test/lisp/faces-tests.el
index 4447dd7b309..f00c93cedcb 100644
--- a/test/lisp/faces-tests.el
+++ b/test/lisp/faces-tests.el
@@ -60,5 +60,14 @@
(should (equal (background-color-at-point) "black"))
(should (equal (foreground-color-at-point) "black"))))
+(ert-deftest faces--test-face-id ()
+ ;; Face ID of 0 is the 'default' face; no face should have the same ID.
+ (should (> (face-id 'faces--test1) 0))
+ ;; 'tooltip' is the last face defined by preloaded packages, so any
+ ;; face we define in Emacs should have a face ID greater than that,
+ ;; since the ID of a face is just its index in the array that maps
+ ;; face IDs to faces.
+ (should (> (face-id 'faces--test1) (face-id 'tooltip))))
+
(provide 'faces-tests)
;;; faces-tests.el ends here
diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el
index 4e1a46285c6..50036209b0f 100644
--- a/test/lisp/filenotify-tests.el
+++ b/test/lisp/filenotify-tests.el
@@ -31,6 +31,21 @@
;; remote host, set this environment variable to "/dev/null" or
;; whatever is appropriate on your system.
+;; For the remote file-notify library, Tramp checks for the existence
+;; of a respective command. The first command found is used. In
+;; order to use a dedicated one, the environment variable
+;; $REMOTE_FILE_NOTIFY_LIBRARY shall be set, possible values are
+;; "inotifywait", "gio-monitor" and "gvfs-monitor-dir".
+
+;; Local file-notify libraries are auto-detected during Emacs
+;; configuration. This can be changed with a respective configuration
+;; argument, like
+;;
+;; --with-file-notification=inotify
+;; --with-file-notification=kqueue
+;; --with-file-notification=gfile
+;; --with-file-notification=w32
+
;; A whole test run can be performed calling the command `file-notify-test-all'.
;;; Code:
@@ -57,12 +72,19 @@
'tramp-default-host-alist
`("\\`mock\\'" nil ,(system-name)))
;; Emacs' Makefile sets $HOME to a nonexistent value. Needed in
- ;; batch mode only, therefore.
+ ;; batch mode only, therefore. `temporary-file-directory' might
+ ;; be quoted, so we unquote it just in case.
(unless (and (null noninteractive) (file-directory-p "~/"))
- (setenv "HOME" temporary-file-directory))
+ (setenv "HOME" (file-name-unquote temporary-file-directory)))
(format "/mock::%s" temporary-file-directory)))
"Temporary directory for Tramp tests.")
+;; Filter suppressed remote file-notify libraries.
+(when (stringp (getenv "REMOTE_FILE_NOTIFY_LIBRARY"))
+ (dolist (lib '("inotifywait" "gio-monitor" "gvfs-monitor-dir"))
+ (unless (string-equal (getenv "REMOTE_FILE_NOTIFY_LIBRARY") lib)
+ (add-to-list 'tramp-connection-properties `(nil ,lib nil)))))
+
(defvar file-notify--test-tmpdir nil)
(defvar file-notify--test-tmpfile nil)
(defvar file-notify--test-tmpfile1 nil)
@@ -239,15 +261,18 @@ This returns only for the local case and gfilenotify; otherwise it is nil.
(gfile-monitor-name file-notify--test-desc)))
(cdr (assq file-notify--test-desc file-notify--test-monitors))))))
-(defmacro file-notify--deftest-remote (test docstring)
+(defmacro file-notify--deftest-remote (test docstring &optional expected skip)
"Define ert `TEST-remote' for remote files."
(declare (indent 1))
`(ert-deftest ,(intern (concat (symbol-name test) "-remote")) ()
,docstring
:tags '(:expensive-test)
+ :expected-result (or ,expected :passed)
+ (skip-unless (not ,skip))
(let* ((temporary-file-directory
file-notify-test-remote-temporary-file-directory)
- (ert-test (ert-get-test ',test)))
+ (ert-test (ert-get-test ',test))
+ vc-handled-backends)
(skip-unless (file-notify--test-remote-enabled))
(tramp-cleanup-connection
(tramp-dissect-file-name temporary-file-directory) nil 'keep-password)
@@ -425,36 +450,36 @@ This returns only for the local case and gfilenotify; otherwise it is nil.
;; harm. This fails on Cygwin because of timing issues unless a
;; long `sit-for' is added before the call to
;; `file-notify--test-read-event'.
- (if (not (eq system-type 'cygwin))
- (let (results)
- (cl-flet ((first-callback (event)
- (when (eq (nth 1 event) 'deleted) (push 1 results)))
- (second-callback (event)
- (when (eq (nth 1 event) 'deleted) (push 2 results))))
- (setq file-notify--test-tmpfile (file-notify--test-make-temp-name))
- (write-region
- "any text" nil file-notify--test-tmpfile nil 'no-message)
- (should
- (setq file-notify--test-desc
- (file-notify-add-watch
- file-notify--test-tmpfile
- '(change) #'first-callback)))
- (should
- (setq file-notify--test-desc1
- (file-notify-add-watch
- file-notify--test-tmpfile
- '(change) #'second-callback)))
- ;; Remove first watch.
- (file-notify-rm-watch file-notify--test-desc)
- ;; Only the second callback shall run.
- (file-notify--test-read-event)
- (delete-file file-notify--test-tmpfile)
- (file-notify--wait-for-events
- (file-notify--test-timeout) results)
- (should (equal results (list 2)))
+ (unless (eq system-type 'cygwin)
+ (let (results)
+ (cl-flet ((first-callback (event)
+ (when (eq (nth 1 event) 'deleted) (push 1 results)))
+ (second-callback (event)
+ (when (eq (nth 1 event) 'deleted) (push 2 results))))
+ (setq file-notify--test-tmpfile (file-notify--test-make-temp-name))
+ (write-region
+ "any text" nil file-notify--test-tmpfile nil 'no-message)
+ (should
+ (setq file-notify--test-desc
+ (file-notify-add-watch
+ file-notify--test-tmpfile
+ '(change) #'first-callback)))
+ (should
+ (setq file-notify--test-desc1
+ (file-notify-add-watch
+ file-notify--test-tmpfile
+ '(change) #'second-callback)))
+ ;; Remove first watch.
+ (file-notify-rm-watch file-notify--test-desc)
+ ;; Only the second callback shall run.
+ (file-notify--test-read-event)
+ (delete-file file-notify--test-tmpfile)
+ (file-notify--wait-for-events
+ (file-notify--test-timeout) results)
+ (should (equal results (list 2)))
- ;; The environment shall be cleaned up.
- (file-notify--test-cleanup-p))))
+ ;; The environment shall be cleaned up.
+ (file-notify--test-cleanup-p))))
;; Cleanup.
(file-notify--test-cleanup)))
@@ -566,35 +591,42 @@ delivered."
(skip-unless (file-notify--test-local-enabled))
(unwind-protect
- (progn
- ;; Check file creation, change and deletion. It doesn't work
- ;; for kqueue, because we don't use an implicit directory
- ;; monitor.
- (unless (string-equal (file-notify--test-library) "kqueue")
- (setq file-notify--test-tmpfile (file-notify--test-make-temp-name))
- (should
- (setq file-notify--test-desc
- (file-notify-add-watch
- file-notify--test-tmpfile
- '(change) #'file-notify--test-event-handler)))
- (file-notify--test-with-events
- (cond
- ;; gvfs-monitor-dir on cygwin does not detect the
- ;; `created' event reliably.
- ((string-equal
- (file-notify--test-library) "gvfs-monitor-dir.exe")
- '((deleted stopped)
- (created deleted stopped)))
- ;; cygwin does not raise a `changed' event.
- ((eq system-type 'cygwin)
- '(created deleted stopped))
- (t '(created changed deleted stopped)))
- (write-region
- "another text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
- (delete-file file-notify--test-tmpfile))
- (file-notify-rm-watch file-notify--test-desc))
+ ;; Check file creation, change and deletion. It doesn't work
+ ;; for kqueue, because we don't use an implicit directory
+ ;; monitor.
+ (unless (string-equal (file-notify--test-library) "kqueue")
+ (setq file-notify--test-tmpfile (file-notify--test-make-temp-name))
+ (should
+ (setq file-notify--test-desc
+ (file-notify-add-watch
+ file-notify--test-tmpfile
+ '(change) #'file-notify--test-event-handler)))
+ (file-notify--test-with-events
+ (cond
+ ;; gvfs-monitor-dir on cygwin does not detect the
+ ;; `created' event reliably.
+ ((string-equal
+ (file-notify--test-library) "gvfs-monitor-dir.exe")
+ '((deleted stopped)
+ (created deleted stopped)))
+ ;; cygwin does not raise a `changed' event.
+ ((eq system-type 'cygwin)
+ '(created deleted stopped))
+ (t '(created changed deleted stopped)))
+ (write-region
+ "another text" nil file-notify--test-tmpfile nil 'no-message)
+ (file-notify--test-read-event)
+ (delete-file file-notify--test-tmpfile))
+ (file-notify-rm-watch file-notify--test-desc)
+
+ ;; The environment shall be cleaned up.
+ (file-notify--test-cleanup-p))
+ ;; Cleanup.
+ (file-notify--test-cleanup))
+
+ (unwind-protect
+ (progn
;; Check file change and deletion.
(setq file-notify--test-tmpfile (file-notify--test-make-temp-name))
(write-region "any text" nil file-notify--test-tmpfile nil 'no-message)
@@ -619,175 +651,203 @@ delivered."
(delete-file file-notify--test-tmpfile))
(file-notify-rm-watch file-notify--test-desc)
- ;; Check file creation, change and deletion when watching a
- ;; directory. There must be a `stopped' event when deleting
- ;; the directory.
- (let ((file-notify--test-tmpdir
- (make-temp-file "file-notify-test-parent" t)))
- (should
- (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)
- file-notify--test-desc
- (file-notify-add-watch
- file-notify--test-tmpdir
- '(change) #'file-notify--test-event-handler)))
- (file-notify--test-with-events
- (cond
- ;; w32notify does not raise `deleted' and `stopped'
- ;; events for the watched directory.
- ((string-equal (file-notify--test-library) "w32notify")
- '(created changed deleted))
- ;; gvfs-monitor-dir on cygwin does not detect the
- ;; `created' event reliably.
- ((string-equal
- (file-notify--test-library) "gvfs-monitor-dir.exe")
- '((deleted stopped)
- (created deleted stopped)))
- ;; There are two `deleted' events, for the file and for
- ;; the directory. Except for cygwin and kqueue. And
- ;; cygwin does not raise a `changed' event.
- ((eq system-type 'cygwin)
- '(created deleted stopped))
- ((string-equal (file-notify--test-library) "kqueue")
- '(created changed deleted stopped))
- ;; On emba, `deleted' and `stopped' events of the
- ;; directory are not detected.
- ((getenv "EMACS_EMBA_CI")
- '(created changed deleted))
- (t '(created changed deleted deleted stopped)))
- (write-region
- "any text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
- (delete-directory file-notify--test-tmpdir 'recursive))
- (file-notify-rm-watch file-notify--test-desc))
+ ;; The environment shall be cleaned up.
+ (file-notify--test-cleanup-p))
- ;; Check copy of files inside a directory.
- (let ((file-notify--test-tmpdir
- (make-temp-file "file-notify-test-parent" t)))
- (should
- (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)
- file-notify--test-tmpfile1 (file-notify--test-make-temp-name)
- file-notify--test-desc
- (file-notify-add-watch
- file-notify--test-tmpdir
- '(change) #'file-notify--test-event-handler)))
- (file-notify--test-with-events
- (cond
- ;; w32notify does not distinguish between `changed' and
- ;; `attribute-changed'. It does not raise `deleted'
- ;; and `stopped' events for the watched directory.
- ((string-equal (file-notify--test-library) "w32notify")
- '(created changed created changed
- changed changed changed
- deleted deleted))
- ;; gvfs-monitor-dir on cygwin does not detect the
- ;; `created' event reliably.
- ((string-equal
- (file-notify--test-library) "gvfs-monitor-dir.exe")
- '((deleted stopped)
- (created created deleted stopped)))
- ;; There are three `deleted' events, for two files and
- ;; for the directory. Except for cygwin and kqueue.
- ((eq system-type 'cygwin)
- '(created created changed changed deleted stopped))
- ((string-equal (file-notify--test-library) "kqueue")
- '(created changed created changed deleted stopped))
- ;; On emba, `deleted' and `stopped' events of the
- ;; directory are not detected.
- ((getenv "EMACS_EMBA_CI")
- '(created changed created changed deleted deleted))
- (t '(created changed created changed
- deleted deleted deleted stopped)))
- (write-region
- "any text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
- (copy-file file-notify--test-tmpfile file-notify--test-tmpfile1)
- ;; The next two events shall not be visible.
- (file-notify--test-read-event)
- (set-file-modes file-notify--test-tmpfile 000)
- (file-notify--test-read-event)
- (set-file-times file-notify--test-tmpfile '(0 0))
- (file-notify--test-read-event)
- (delete-directory file-notify--test-tmpdir 'recursive))
- (file-notify-rm-watch file-notify--test-desc))
+ ;; Cleanup.
+ (file-notify--test-cleanup))
- ;; Check rename of files inside a directory.
- (let ((file-notify--test-tmpdir
- (make-temp-file "file-notify-test-parent" t)))
- (should
- (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)
- file-notify--test-tmpfile1 (file-notify--test-make-temp-name)
- file-notify--test-desc
- (file-notify-add-watch
- file-notify--test-tmpdir
- '(change) #'file-notify--test-event-handler)))
- (file-notify--test-with-events
- (cond
- ;; w32notify does not raise `deleted' and `stopped'
- ;; events for the watched directory.
- ((string-equal (file-notify--test-library) "w32notify")
- '(created changed renamed deleted))
- ;; gvfs-monitor-dir on cygwin does not detect the
- ;; `created' event reliably.
- ((string-equal
- (file-notify--test-library) "gvfs-monitor-dir.exe")
- '((deleted stopped)
- (created deleted stopped)))
- ;; There are two `deleted' events, for the file and for
- ;; the directory. Except for cygwin and kqueue. And
- ;; cygwin raises `created' and `deleted' events instead
- ;; of a `renamed' event.
- ((eq system-type 'cygwin)
- '(created created deleted deleted stopped))
- ((string-equal (file-notify--test-library) "kqueue")
- '(created changed renamed deleted stopped))
- ;; On emba, `deleted' and `stopped' events of the
- ;; directory are not detected.
- ((getenv "EMACS_EMBA_CI")
- '(created changed renamed deleted))
- (t '(created changed renamed deleted deleted stopped)))
- (write-region
- "any text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
- (rename-file file-notify--test-tmpfile file-notify--test-tmpfile1)
- ;; After the rename, we won't get events anymore.
- (file-notify--test-read-event)
- (delete-directory file-notify--test-tmpdir 'recursive))
- (file-notify-rm-watch file-notify--test-desc))
+ (unwind-protect
+ ;; Check file creation, change and deletion when watching a
+ ;; directory. There must be a `stopped' event when deleting the
+ ;; directory.
+ (let ((file-notify--test-tmpdir
+ (make-temp-file "file-notify-test-parent" t)))
+ (should
+ (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)
+ file-notify--test-desc
+ (file-notify-add-watch
+ file-notify--test-tmpdir
+ '(change) #'file-notify--test-event-handler)))
+ (file-notify--test-with-events
+ (cond
+ ;; w32notify does not raise `deleted' and `stopped'
+ ;; events for the watched directory.
+ ((string-equal (file-notify--test-library) "w32notify")
+ '(created changed deleted))
+ ;; gvfs-monitor-dir on cygwin does not detect the
+ ;; `created' event reliably.
+ ((string-equal
+ (file-notify--test-library) "gvfs-monitor-dir.exe")
+ '((deleted stopped)
+ (created deleted stopped)))
+ ;; There are two `deleted' events, for the file and for
+ ;; the directory. Except for cygwin and kqueue. And
+ ;; cygwin does not raise a `changed' event.
+ ((eq system-type 'cygwin)
+ '(created deleted stopped))
+ ((string-equal (file-notify--test-library) "kqueue")
+ '(created changed deleted stopped))
+ ;; On emba, `deleted' and `stopped' events of the
+ ;; directory are not detected.
+ ((getenv "EMACS_EMBA_CI")
+ '(created changed deleted))
+ (t '(created changed deleted deleted stopped)))
+ (write-region
+ "any text" nil file-notify--test-tmpfile nil 'no-message)
+ (file-notify--test-read-event)
+ (delete-directory file-notify--test-tmpdir 'recursive))
+ (file-notify-rm-watch file-notify--test-desc)
- ;; Check attribute change. Does not work for cygwin.
- (unless (eq system-type 'cygwin)
- (setq file-notify--test-tmpfile (file-notify--test-make-temp-name))
+ ;; The environment shall be cleaned up.
+ (file-notify--test-cleanup-p))
+
+ ;; Cleanup.
+ (file-notify--test-cleanup))
+
+ (unwind-protect
+ ;; Check copy of files inside a directory.
+ (let ((file-notify--test-tmpdir
+ (make-temp-file "file-notify-test-parent" t)))
+ (should
+ (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)
+ file-notify--test-tmpfile1 (file-notify--test-make-temp-name)
+ file-notify--test-desc
+ (file-notify-add-watch
+ file-notify--test-tmpdir
+ '(change) #'file-notify--test-event-handler)))
+ (file-notify--test-with-events
+ (cond
+ ;; w32notify does not distinguish between `changed' and
+ ;; `attribute-changed'. It does not raise `deleted' and
+ ;; `stopped' events for the watched directory.
+ ((string-equal (file-notify--test-library) "w32notify")
+ '(created changed created changed
+ changed changed changed
+ deleted deleted))
+ ;; gvfs-monitor-dir on cygwin does not detect the
+ ;; `created' event reliably.
+ ((string-equal
+ (file-notify--test-library) "gvfs-monitor-dir.exe")
+ '((deleted stopped)
+ (created created deleted stopped)))
+ ;; There are three `deleted' events, for two files and
+ ;; for the directory. Except for cygwin and kqueue.
+ ((eq system-type 'cygwin)
+ '(created created changed changed deleted stopped))
+ ((string-equal (file-notify--test-library) "kqueue")
+ '(created changed created changed deleted stopped))
+ ;; On emba, `deleted' and `stopped' events of the
+ ;; directory are not detected.
+ ((getenv "EMACS_EMBA_CI")
+ '(created changed created changed deleted deleted))
+ (t '(created changed created changed
+ deleted deleted deleted stopped)))
(write-region
"any text" nil file-notify--test-tmpfile nil 'no-message)
- (should
- (setq file-notify--test-desc
- (file-notify-add-watch
- file-notify--test-tmpfile
- '(attribute-change) #'file-notify--test-event-handler)))
- (file-notify--test-with-events
- (cond
- ;; w32notify does not distinguish between `changed' and
- ;; `attribute-changed'. Under MS Windows 7, we get
- ;; four `changed' events, and under MS Windows 10 just
- ;; two. Strange.
- ((string-equal (file-notify--test-library) "w32notify")
- '((changed changed)
- (changed changed changed changed)))
- ;; For kqueue and in the remote case, `write-region'
- ;; raises also an `attribute-changed' event.
- ((or (string-equal (file-notify--test-library) "kqueue")
- (file-remote-p temporary-file-directory))
- '(attribute-changed attribute-changed attribute-changed))
- (t '(attribute-changed attribute-changed)))
- (write-region
- "any text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
- (set-file-modes file-notify--test-tmpfile 000)
- (file-notify--test-read-event)
- (set-file-times file-notify--test-tmpfile '(0 0))
- (file-notify--test-read-event)
- (delete-file file-notify--test-tmpfile))
- (file-notify-rm-watch file-notify--test-desc))
+ (file-notify--test-read-event)
+ (copy-file file-notify--test-tmpfile file-notify--test-tmpfile1)
+ ;; The next two events shall not be visible.
+ (file-notify--test-read-event)
+ (set-file-modes file-notify--test-tmpfile 000)
+ (file-notify--test-read-event)
+ (set-file-times file-notify--test-tmpfile '(0 0))
+ (file-notify--test-read-event)
+ (delete-directory file-notify--test-tmpdir 'recursive))
+ (file-notify-rm-watch file-notify--test-desc)
+
+ ;; The environment shall be cleaned up.
+ (file-notify--test-cleanup-p))
+
+ ;; Cleanup.
+ (file-notify--test-cleanup))
+
+ (unwind-protect
+ ;; Check rename of files inside a directory.
+ (let ((file-notify--test-tmpdir
+ (make-temp-file "file-notify-test-parent" t)))
+ (should
+ (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)
+ file-notify--test-tmpfile1 (file-notify--test-make-temp-name)
+ file-notify--test-desc
+ (file-notify-add-watch
+ file-notify--test-tmpdir
+ '(change) #'file-notify--test-event-handler)))
+ (file-notify--test-with-events
+ (cond
+ ;; w32notify does not raise `deleted' and `stopped'
+ ;; events for the watched directory.
+ ((string-equal (file-notify--test-library) "w32notify")
+ '(created changed renamed deleted))
+ ;; gvfs-monitor-dir on cygwin does not detect the
+ ;; `created' event reliably.
+ ((string-equal
+ (file-notify--test-library) "gvfs-monitor-dir.exe")
+ '((deleted stopped)
+ (created deleted stopped)))
+ ;; There are two `deleted' events, for the file and for
+ ;; the directory. Except for cygwin and kqueue. And
+ ;; cygwin raises `created' and `deleted' events instead
+ ;; of a `renamed' event.
+ ((eq system-type 'cygwin)
+ '(created created deleted deleted stopped))
+ ((string-equal (file-notify--test-library) "kqueue")
+ '(created changed renamed deleted stopped))
+ ;; On emba, `deleted' and `stopped' events of the
+ ;; directory are not detected.
+ ((getenv "EMACS_EMBA_CI")
+ '(created changed renamed deleted))
+ (t '(created changed renamed deleted deleted stopped)))
+ (write-region
+ "any text" nil file-notify--test-tmpfile nil 'no-message)
+ (file-notify--test-read-event)
+ (rename-file file-notify--test-tmpfile file-notify--test-tmpfile1)
+ ;; After the rename, we won't get events anymore.
+ (file-notify--test-read-event)
+ (delete-directory file-notify--test-tmpdir 'recursive))
+ (file-notify-rm-watch file-notify--test-desc)
+
+ ;; The environment shall be cleaned up.
+ (file-notify--test-cleanup-p))
+
+ ;; Cleanup.
+ (file-notify--test-cleanup))
+
+ (unwind-protect
+ ;; Check attribute change. Does not work for cygwin.
+ (unless (eq system-type 'cygwin)
+ (setq file-notify--test-tmpfile (file-notify--test-make-temp-name))
+ (write-region
+ "any text" nil file-notify--test-tmpfile nil 'no-message)
+ (should
+ (setq file-notify--test-desc
+ (file-notify-add-watch
+ file-notify--test-tmpfile
+ '(attribute-change) #'file-notify--test-event-handler)))
+ (file-notify--test-with-events
+ (cond
+ ;; w32notify does not distinguish between `changed' and
+ ;; `attribute-changed'. Under MS Windows 7, we get four
+ ;; `changed' events, and under MS Windows 10 just two.
+ ;; Strange.
+ ((string-equal (file-notify--test-library) "w32notify")
+ '((changed changed)
+ (changed changed changed changed)))
+ ;; For kqueue and in the remote case, `write-region'
+ ;; raises also an `attribute-changed' event.
+ ((or (string-equal (file-notify--test-library) "kqueue")
+ (file-remote-p temporary-file-directory))
+ '(attribute-changed attribute-changed attribute-changed))
+ (t '(attribute-changed attribute-changed)))
+ (write-region
+ "any text" nil file-notify--test-tmpfile nil 'no-message)
+ (file-notify--test-read-event)
+ (set-file-modes file-notify--test-tmpfile 000)
+ (file-notify--test-read-event)
+ (set-file-times file-notify--test-tmpfile '(0 0))
+ (file-notify--test-read-event)
+ (delete-file file-notify--test-tmpfile))
+ (file-notify-rm-watch file-notify--test-desc)
;; The environment shall be cleaned up.
(file-notify--test-cleanup-p))
@@ -861,15 +921,15 @@ delivered."
;; Stop file notification. Autorevert shall still work via polling.
(file-notify-rm-watch auto-revert-notify-watch-descriptor)
(file-notify--wait-for-events
- timeout (null auto-revert-use-notify))
- (should-not auto-revert-use-notify)
+ timeout (null auto-revert-notify-watch-descriptor))
+ (should auto-revert-use-notify)
(should-not auto-revert-notify-watch-descriptor)
;; Modify file. We wait for two seconds, in order to
;; have another timestamp. One second seems to be too
- ;; short.
+ ;; short. And Cygwin sporadically requires more than two.
(ert-with-message-capture captured-messages
- (sleep-for 2)
+ (sleep-for (if (eq system-type 'cygwin) 3 2))
(write-region
"foo bla" nil file-notify--test-tmpfile nil 'no-message)
@@ -879,7 +939,10 @@ delivered."
(string-match
(format-message "Reverting buffer `%s'." (buffer-name buf))
captured-messages))
- (should (string-match "foo bla" (buffer-string)))))
+ (should (string-match "foo bla" (buffer-string))))
+
+ ;; Stop autorevert, in order to cleanup descriptor.
+ (auto-revert-mode -1))
;; The environment shall be cleaned up.
(file-notify--test-cleanup-p))
@@ -1029,7 +1092,7 @@ delivered."
(file-notify--test-timeout)
(not (file-notify-valid-p file-notify--test-desc)))
(should-not (file-notify-valid-p file-notify--test-desc))
- (delete-directory file-notify--test-tmpfile t)
+ (delete-directory file-notify--test-tmpfile 'recursive)
;; The environment shall be cleaned up.
(file-notify--test-cleanup-p))
@@ -1051,7 +1114,7 @@ delivered."
(should (file-notify-valid-p file-notify--test-desc))
;; After deleting the directory, the descriptor must not be
;; valid anymore.
- (delete-directory file-notify--test-tmpfile t)
+ (delete-directory file-notify--test-tmpfile 'recursive)
(file-notify--wait-for-events
(file-notify--test-timeout)
(not (file-notify-valid-p file-notify--test-desc)))
@@ -1108,14 +1171,16 @@ delivered."
;; w32notify fires both `deleted' and `renamed' events.
((string-equal (file-notify--test-library) "w32notify")
(let (r)
- (dotimes (_i n r)
- (setq r (append '(deleted renamed) r)))))
+ (dotimes (_i n)
+ (setq r (append '(deleted renamed) r)))
+ r))
;; cygwin fires `changed' and `deleted' events, sometimes
;; in random order.
((eq system-type 'cygwin)
(let (r)
- (dotimes (_i n (cons :random r))
- (setq r (append '(changed deleted) r)))))
+ (dotimes (_i n)
+ (setq r (append '(changed deleted) r)))
+ (cons :random r)))
(t (make-list n 'renamed)))
(let ((source-file-list source-file-list)
(target-file-list target-file-list))
@@ -1137,8 +1202,10 @@ delivered."
;; Cleanup.
(file-notify--test-cleanup)))
+;; Unpredictable failures, eg https://hydra.nixos.org/build/86016286
(file-notify--deftest-remote file-notify-test07-many-events
- "Check that events are not dropped for remote directories.")
+ "Check that events are not dropped for remote directories."
+ :passed (getenv "EMACS_HYDRA_CI"))
(ert-deftest file-notify-test08-backup ()
"Check that backup keeps file notification."
diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el
index f69ab466264..57d8363ef9c 100644
--- a/test/lisp/files-tests.el
+++ b/test/lisp/files-tests.el
@@ -21,6 +21,10 @@
(require 'ert)
(require 'nadvice)
+(eval-when-compile (require 'cl-lib))
+(require 'bytecomp) ; `byte-compiler-base-file-name'.
+(require 'dired) ; `dired-uncache'.
+(require 'filenotify) ; `file-notify-add-watch'.
;; Set to t if the local variable was set, `query' if the query was
;; triggered.
@@ -153,6 +157,9 @@ form.")
(ert-deftest files-test-bug-18141 ()
"Test for https://debbugs.gnu.org/18141 ."
(skip-unless (executable-find "gzip"))
+ ;; If called interactively, environment variable
+ ;; $EMACS_TEST_DIRECTORY does not exist.
+ (skip-unless (file-exists-p files-test-bug-18141-file))
(let ((tempfile (make-temp-file "files-test-bug-18141" nil ".gz")))
(unwind-protect
(progn
@@ -255,14 +262,29 @@ be $HOME."
(concat "/:/:" subdir)))))
(delete-directory dir 'recursive))))
+(ert-deftest files-tests-file-name-non-special-quote-unquote ()
+ (let (;; Just in case it is quoted, who knows.
+ (temporary-file-directory (file-name-unquote temporary-file-directory)))
+ (should-not (file-name-quoted-p temporary-file-directory))
+ (should (file-name-quoted-p (file-name-quote temporary-file-directory)))
+ (should (equal temporary-file-directory
+ (file-name-unquote
+ (file-name-quote temporary-file-directory))))
+ ;; It does not hurt to quote/unquote a file several times.
+ (should (equal (file-name-quote temporary-file-directory)
+ (file-name-quote
+ (file-name-quote temporary-file-directory))))
+ (should (equal (file-name-unquote temporary-file-directory)
+ (file-name-unquote
+ (file-name-unquote temporary-file-directory))))))
+
(ert-deftest files-tests--file-name-non-special--subprocess ()
"Check that Bug#25949 is fixed."
(skip-unless (executable-find "true"))
- (let ((defdir (if (memq system-type '(ms-dos windows-nt)) "/:c:/" "/:/")))
- (should (eq (let ((default-directory defdir)) (process-file "true")) 0))
- (should (processp (let ((default-directory defdir))
- (start-file-process "foo" nil "true"))))
- (should (eq (let ((default-directory defdir)) (shell-command "true")) 0))))
+ (let ((default-directory (file-name-quote temporary-file-directory)))
+ (should (zerop (process-file "true")))
+ (should (processp (start-file-process "foo" nil "true")))
+ (should (zerop (shell-command "true")))))
(defmacro files-tests--with-advice (symbol where function &rest body)
(declare (indent 3))
@@ -277,7 +299,7 @@ be $HOME."
(advice-remove #',symbol ,function)))))
(defmacro files-tests--with-temp-file (name &rest body)
- (declare (indent 1))
+ (declare (indent 1) (debug (symbolp body)))
(cl-check-type name symbol)
`(let ((,name (make-temp-file "emacs")))
(unwind-protect
@@ -297,8 +319,10 @@ be invoked with the right arguments."
(let* ((buffer-visiting-file (current-buffer))
(actual-args ())
(log (lambda (&rest args) (push args actual-args))))
- (insert-file-contents (concat "/:" temp-file-name) :visit)
+ (insert-file-contents (file-name-quote temp-file-name) :visit)
(should (stringp buffer-file-name))
+ (should (file-name-quoted-p buffer-file-name))
+ ;; The following is not true for remote files.
(should (string-prefix-p "/:" buffer-file-name))
(should (consp (visited-file-modtime)))
(should (equal (find-file-name-handler buffer-file-name
@@ -325,6 +349,776 @@ be invoked with the right arguments."
`((verify-visited-file-modtime ,buffer-visiting-file)
(verify-visited-file-modtime nil))))))))
+(cl-defmacro files-tests--with-temp-non-special
+ ((name non-special-name &optional dir-flag) &rest body)
+ "Run tests with quoted file name.
+NAME is the symbol which contains the name of a created temporary
+file. NON-SPECIAL-NAME is another symbol, which contains the
+temporary file name with quoted file name syntax. If DIR-FLAG is
+non-nil, a temporary directory is created instead.
+After evaluating BODY, the temporary file or directory is deleted."
+ (declare (indent 1) (debug ((symbolp symbolp &optional form) body)))
+ (cl-check-type name symbol)
+ (cl-check-type non-special-name symbol)
+ `(let* ((temporary-file-directory (file-truename temporary-file-directory))
+ (,name (make-temp-file "files-tests" ,dir-flag))
+ (,non-special-name (file-name-quote ,name)))
+ (unwind-protect
+ (progn ,@body)
+ (when (file-exists-p ,name)
+ (if ,dir-flag (delete-directory ,name t)
+ (delete-file ,name)))
+ (when (file-exists-p ,non-special-name)
+ (if ,dir-flag (delete-directory ,non-special-name t)
+ (delete-file ,non-special-name))))))
+
+(defconst files-tests--special-file-name-extension ".special"
+ "Trailing string for test file name handler.")
+
+(defconst files-tests--special-file-name-regexp
+ (concat (regexp-quote files-tests--special-file-name-extension) "\\'")
+ "Regular expression for test file name handler.")
+
+(defun files-tests--special-file-name-handler (operation &rest args)
+ "File name handler for files with extension \".special\"."
+ (let ((arg args)
+ ;; Avoid cyclic call.
+ (file-name-handler-alist
+ (delete
+ (rassoc
+ 'files-tests--special-file-name-handler file-name-handler-alist)
+ file-name-handler-alist)))
+ ;; Remove trailing "\\.special\\'" from arguments, if they are not quoted.
+ (while arg
+ (when (and (stringp (car arg))
+ (not (file-name-quoted-p (car arg)))
+ (string-match files-tests--special-file-name-regexp (car arg)))
+ (setcar arg (replace-match "" nil nil (car arg))))
+ (setq arg (cdr arg)))
+ ;; Call it.
+ (apply operation args)))
+
+(cl-defmacro files-tests--with-temp-non-special-and-file-name-handler
+ ((name non-special-name &optional dir-flag) &rest body)
+ "Run tests with quoted file name, see `files-tests--with-temp-non-special'.
+Both file names in NAME and NON-SPECIAL-NAME have the extension
+\".special\". The created temporary file or directory does not have
+that extension.
+A file name handler is added which is activated for files with
+that extension. It simply removes the extension from file names.
+It is expected, that this file name handler works only for
+unquoted file names."
+ (declare (indent 1) (debug ((symbolp symbolp &optional form) body)))
+ (cl-check-type name symbol)
+ (cl-check-type non-special-name symbol)
+ `(let* ((temporary-file-directory (file-truename temporary-file-directory))
+ (file-name-handler-alist
+ `((,files-tests--special-file-name-regexp
+ . files-tests--special-file-name-handler)
+ . ,file-name-handler-alist))
+ (,name (concat
+ (make-temp-file "files-tests" ,dir-flag)
+ files-tests--special-file-name-extension))
+ (,non-special-name (file-name-quote ,name)))
+ (unwind-protect
+ (progn ,@body)
+ (when (file-exists-p ,name)
+ (if ,dir-flag (delete-directory ,name t)
+ (delete-file ,name)))
+ (when (file-exists-p ,non-special-name)
+ (if ,dir-flag (delete-directory ,non-special-name t)
+ (delete-file ,non-special-name))))))
+
+(defun files-tests--new-name (name part)
+ (let (file-name-handler-alist)
+ (concat (file-name-sans-extension name) part (file-name-extension name t))))
+
+(ert-deftest files-tests-file-name-non-special-access-file ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ ;; Both versions of the file name work.
+ (should-not (access-file tmpfile "test"))
+ (should-not (access-file nospecial "test")))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should-not (access-file tmpfile "test"))
+ ;; The quoted file name does not work.
+ (should-error (access-file nospecial "test"))))
+
+(ert-deftest files-tests-file-name-non-special-add-name-to-file ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (let ((newname (files-tests--new-name nospecial "add-name")))
+ ;; Both versions work.
+ (add-name-to-file tmpfile newname)
+ (should (file-exists-p newname))
+ (delete-file newname)
+ (add-name-to-file nospecial newname)
+ (should (file-exists-p newname))
+ (delete-file newname)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (let ((newname (files-tests--new-name tmpfile "add-name")))
+ ;; Using an unquoted file name works.
+ (add-name-to-file tmpfile newname)
+ (should (file-exists-p newname))
+ (delete-file newname))
+ (let ((newname (files-tests--new-name nospecial "add-name")))
+ (add-name-to-file tmpfile newname)
+ (should (file-exists-p newname))
+ (delete-file newname)
+ ;; The quoted special file name does not work.
+ (should-error (add-name-to-file nospecial newname)))))
+
+(ert-deftest files-tests-file-name-non-special-byte-compiler-base-file-name ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should (equal (byte-compiler-base-file-name nospecial)
+ (byte-compiler-base-file-name tmpfile))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should (equal (byte-compiler-base-file-name nospecial) tmpfile))
+ (should-not (equal (byte-compiler-base-file-name tmpfile) tmpfile))))
+
+(ert-deftest files-tests-file-name-non-special-copy-directory ()
+ (files-tests--with-temp-non-special (tmpdir nospecial-dir t)
+ (let ((newname (files-tests--new-name
+ (directory-file-name nospecial-dir) "copy-dir")))
+ (copy-directory nospecial-dir newname)
+ (should (file-directory-p newname))
+ (delete-directory newname)
+ (should-not (file-directory-p newname))))
+ (files-tests--with-temp-non-special-and-file-name-handler
+ (tmpdir nospecial-dir t)
+ (let ((newname (files-tests--new-name
+ (directory-file-name nospecial-dir) "copy-dir")))
+ (should-error (copy-directory nospecial-dir newname))
+ (delete-directory newname))))
+
+(ert-deftest files-tests-file-name-non-special-copy-file ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (let ((newname
+ (files-tests--new-name (directory-file-name nospecial) "copy-file")))
+ (copy-file nospecial newname)
+ (should (file-exists-p newname))
+ (delete-file newname)
+ (should-not (file-exists-p newname))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (let ((newname
+ (files-tests--new-name (directory-file-name nospecial) "copy-file")))
+ (should-error (copy-file nospecial newname)))))
+
+(ert-deftest files-tests-file-name-non-special-delete-directory ()
+ (files-tests--with-temp-non-special (tmpdir nospecial-dir t)
+ (delete-directory nospecial-dir))
+ (files-tests--with-temp-non-special-and-file-name-handler
+ (tmpdir nospecial-dir t)
+ (should-error (delete-directory nospecial-dir))))
+
+(ert-deftest files-tests-file-name-non-special-delete-file ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (delete-file nospecial))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (delete-file nospecial)
+ (should (file-exists-p tmpfile))))
+
+(ert-deftest files-tests-file-name-non-special-diff-latest-backup-file ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (write-region "foo" nil (make-backup-file-name tmpfile))
+ (should (equal (diff-latest-backup-file nospecial)
+ (diff-latest-backup-file tmpfile)))
+ (delete-file (diff-latest-backup-file nospecial)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (write-region "foo" nil (make-backup-file-name tmpfile))
+ (should-not (equal (diff-latest-backup-file nospecial)
+ (diff-latest-backup-file tmpfile)))
+ (delete-file (diff-latest-backup-file nospecial))))
+
+(ert-deftest files-tests-file-name-non-special-directory-file-name ()
+ (files-tests--with-temp-non-special (tmpdir nospecial-dir t)
+ (should (equal (directory-file-name nospecial-dir)
+ (file-name-quote (directory-file-name tmpdir)))))
+ (files-tests--with-temp-non-special-and-file-name-handler
+ (tmpdir nospecial-dir t)
+ (should-not (equal (directory-file-name nospecial-dir)
+ (file-name-quote (directory-file-name tmpdir))))))
+
+(ert-deftest files-tests-file-name-non-special-directory-files ()
+ (files-tests--with-temp-non-special (tmpdir nospecial-dir t)
+ (should (equal (directory-files nospecial-dir)
+ (directory-files tmpdir))))
+ (files-tests--with-temp-non-special-and-file-name-handler
+ (tmpdir nospecial-dir t)
+ (should-error (directory-files nospecial-dir))))
+
+(defun files-tests-file-attributes-equal (attr1 attr2)
+ ;; Element 4 is access time, which may be changed by the act of
+ ;; checking the attributes.
+ (setf (nth 4 attr1) nil)
+ (setf (nth 4 attr2) nil)
+ ;; Element 9 is unspecified.
+ (setf (nth 9 attr1) nil)
+ (setf (nth 9 attr2) nil)
+ (equal attr1 attr2))
+
+(ert-deftest files-tests-file-name-non-special-directory-files-and-attributes ()
+ (files-tests--with-temp-non-special (tmpdir nospecial-dir t)
+ (cl-loop for (file1 . attr1) in (directory-files-and-attributes nospecial-dir)
+ for (file2 . attr2) in (directory-files-and-attributes tmpdir)
+ do
+ (should (equal file1 file2))
+ (should (files-tests-file-attributes-equal attr1 attr2))))
+ (files-tests--with-temp-non-special-and-file-name-handler
+ (tmpdir nospecial-dir t)
+ (should-error (directory-files-and-attributes nospecial-dir))))
+
+(ert-deftest files-tests-file-name-non-special-dired-compress-handler ()
+ ;; `dired-compress-file' can get confused by filenames with ":" in
+ ;; them, which causes this to fail on `windows-nt' systems.
+ (when (string-match-p ":" (expand-file-name temporary-file-directory))
+ (ert-skip "FIXME: `dired-compress-file' unreliable when filenames contain `:'."))
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (let ((compressed (dired-compress-file nospecial)))
+ (when compressed
+ ;; FIXME: Should it return a still-quoted name?
+ (should (file-equal-p nospecial (dired-compress-file compressed))))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should-not (dired-compress-file nospecial))))
+
+(ert-deftest files-tests-file-name-non-special-dired-uncache ()
+ ;; FIXME: This is not a real test. We need cached values, and check
+ ;; whether they disappear.
+ (files-tests--with-temp-non-special (tmpdir nospecial-dir t)
+ (dired-uncache nospecial-dir))
+ (files-tests--with-temp-non-special-and-file-name-handler
+ (tmpdir nospecial-dir t)
+ (dired-uncache nospecial-dir)))
+
+(ert-deftest files-tests-file-name-non-special-expand-file-name ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should (equal (expand-file-name nospecial) nospecial)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should (equal (expand-file-name nospecial) nospecial))))
+
+(ert-deftest files-tests-file-name-non-special-file-accessible-directory-p ()
+ (files-tests--with-temp-non-special (tmpdir nospecial-dir t)
+ (should (file-accessible-directory-p nospecial-dir)))
+ (files-tests--with-temp-non-special-and-file-name-handler
+ (tmpdir nospecial-dir t)
+ (should-not (file-accessible-directory-p nospecial-dir))))
+
+(ert-deftest files-tests-file-name-non-special-file-acl ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should (equal (file-acl nospecial) (file-acl tmpfile))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should-not (file-acl nospecial))))
+
+(ert-deftest files-tests-file-name-non-special-file-attributes ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should (files-tests-file-attributes-equal
+ (file-attributes nospecial) (file-attributes tmpfile))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should-not (file-attributes nospecial))))
+
+(ert-deftest files-tests-file-name-non-special-file-directory-p ()
+ (files-tests--with-temp-non-special (tmpdir nospecial-dir t)
+ (should (file-directory-p nospecial-dir)))
+ (files-tests--with-temp-non-special-and-file-name-handler
+ (tmpdir nospecial-dir t)
+ (should-not (file-directory-p nospecial-dir))))
+
+(ert-deftest files-tests-file-name-non-special-file-equal-p ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should (file-equal-p nospecial tmpfile))
+ (should (file-equal-p tmpfile nospecial))
+ (should (file-equal-p nospecial nospecial)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should (file-equal-p (file-name-unquote nospecial) tmpfile))
+ (should (file-equal-p tmpfile (file-name-unquote nospecial)))
+ ;; File `nospecial' does not exist, so it cannot be compared.
+ (should-not (file-equal-p nospecial nospecial))
+ (write-region "foo" nil nospecial)
+ (should (file-equal-p nospecial nospecial))))
+
+(ert-deftest files-tests-file-name-non-special-file-executable-p ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should-not (file-executable-p nospecial)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should-not (file-executable-p nospecial))))
+
+(ert-deftest files-tests-file-name-non-special-file-exists-p ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should (file-exists-p tmpfile))
+ (should (file-exists-p nospecial)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should (file-exists-p tmpfile))
+ (should-not (file-exists-p nospecial))))
+
+(ert-deftest files-tests-file-name-non-special-file-in-directory-p ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (let ((nospecial-tempdir (file-name-quote temporary-file-directory)))
+ (should (file-in-directory-p nospecial temporary-file-directory))
+ (should (file-in-directory-p tmpfile nospecial-tempdir))
+ (should (file-in-directory-p nospecial nospecial-tempdir))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (let ((nospecial-tempdir (file-name-quote temporary-file-directory)))
+ (should (file-in-directory-p nospecial temporary-file-directory))
+ (should (file-in-directory-p tmpfile nospecial-tempdir))
+ (should (file-in-directory-p nospecial nospecial-tempdir)))))
+
+(ert-deftest files-tests-file-name-non-special-file-local-copy ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should-not (file-local-copy nospecial))) ; Already local.
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should-not (file-local-copy nospecial)))) ; Already local.
+
+(ert-deftest files-tests-file-name-non-special-file-modes ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should (equal (file-modes nospecial) (file-modes tmpfile))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should-not (equal (file-modes nospecial) (file-modes tmpfile)))))
+
+(ert-deftest files-tests-file-name-non-special-file-name-all-completions ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (let ((nospecial-tempdir (file-name-quote temporary-file-directory))
+ (tmpdir temporary-file-directory)
+ (file (file-name-nondirectory tmpfile))
+ (nospecial-file (file-name-nondirectory nospecial)))
+ (should (string-equal file nospecial-file))
+ (should (equal (file-name-all-completions
+ nospecial-file nospecial-tempdir)
+ (file-name-all-completions file tmpdir)))
+ (should (equal (file-name-all-completions file nospecial-tempdir)
+ (file-name-all-completions file tmpdir)))
+ (should (equal (file-name-all-completions nospecial-file tmpdir)
+ (file-name-all-completions file tmpdir)))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (let ((nospecial-tempdir (file-name-quote temporary-file-directory))
+ (tmpdir temporary-file-directory)
+ (file (file-name-nondirectory tmpfile))
+ (nospecial-file (file-name-nondirectory nospecial)))
+ (should-not (string-equal file nospecial-file))
+ (should-not (equal (file-name-all-completions
+ nospecial-file nospecial-tempdir)
+ (file-name-all-completions file tmpdir)))
+ (should (equal (file-name-all-completions file nospecial-tempdir)
+ (file-name-all-completions file tmpdir)))
+ (should (equal (file-name-all-completions nospecial-file tmpdir)
+ (file-name-all-completions file tmpdir))))))
+
+(ert-deftest files-tests-file-name-non-special-file-name-as-directory ()
+ (files-tests--with-temp-non-special (tmpdir nospecial-dir t)
+ (should (equal (file-name-as-directory nospecial-dir)
+ (file-name-quote (file-name-as-directory tmpdir)))))
+ (files-tests--with-temp-non-special-and-file-name-handler
+ (tmpdir nospecial-dir t)
+ (should-not (equal (file-name-as-directory nospecial-dir)
+ (file-name-quote (file-name-as-directory tmpdir))))))
+
+(ert-deftest files-tests-file-name-non-special-file-name-case-insensitive-p ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should (equal (file-name-case-insensitive-p nospecial)
+ (file-name-case-insensitive-p tmpfile))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should (equal (file-name-case-insensitive-p nospecial)
+ (file-name-case-insensitive-p tmpfile)))))
+
+(ert-deftest files-tests-file-name-non-special-file-name-completion ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (let ((nospecial-tempdir (file-name-quote temporary-file-directory))
+ (tmpdir temporary-file-directory)
+ (file (file-name-nondirectory tmpfile))
+ (nospecial-file (file-name-nondirectory nospecial)))
+ (should (string-equal file nospecial-file))
+ (should (equal (file-name-completion nospecial-file nospecial-tempdir)
+ (file-name-completion file tmpdir)))
+ (should (equal (file-name-completion file nospecial-tempdir)
+ (file-name-completion file tmpdir)))
+ (should (equal (file-name-completion nospecial-file tmpdir)
+ (file-name-completion file tmpdir)))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (let ((nospecial-tempdir (file-name-quote temporary-file-directory))
+ (tmpdir temporary-file-directory)
+ (file (file-name-nondirectory tmpfile))
+ (nospecial-file (file-name-nondirectory nospecial)))
+ (should-not (string-equal file nospecial-file))
+ (should-not (equal (file-name-completion nospecial-file nospecial-tempdir)
+ (file-name-completion file tmpdir)))
+ (should (equal (file-name-completion file nospecial-tempdir)
+ (file-name-completion file tmpdir)))
+ (should (equal (file-name-completion nospecial-file tmpdir)
+ (file-name-completion file tmpdir))))))
+
+(ert-deftest files-tests-file-name-non-special-file-name-directory ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should (equal (file-name-directory nospecial)
+ (file-name-quote temporary-file-directory))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should (equal (file-name-directory nospecial)
+ (file-name-quote temporary-file-directory)))))
+
+(ert-deftest files-tests-file-name-non-special-file-name-nondirectory ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should (equal (file-name-nondirectory nospecial)
+ (file-name-nondirectory tmpfile))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should-not (equal (file-name-nondirectory nospecial)
+ (file-name-nondirectory tmpfile)))))
+
+(ert-deftest files-tests-file-name-non-special-file-name-sans-versions ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should (equal (file-name-sans-versions nospecial) nospecial)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should (equal (file-name-sans-versions nospecial) nospecial))))
+
+(ert-deftest files-tests-file-name-non-special-file-newer-than-file-p ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should-not (file-newer-than-file-p nospecial tmpfile))
+ (should-not (file-newer-than-file-p tmpfile nospecial))
+ (should-not (file-newer-than-file-p nospecial nospecial)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should-not (file-newer-than-file-p nospecial tmpfile))
+ (should (file-newer-than-file-p tmpfile nospecial))
+ (should-not (file-newer-than-file-p nospecial nospecial))))
+
+(ert-deftest files-tests-file-name-non-special-notify-handlers ()
+ (skip-unless file-notify--library)
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (let ((watch (file-notify-add-watch nospecial '(change) #'ignore)))
+ (should (file-notify-valid-p watch))
+ (file-notify-rm-watch watch)
+ (should-not (file-notify-valid-p watch))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (let ((watch (file-notify-add-watch nospecial '(change) #'ignore)))
+ (should (file-notify-valid-p watch))
+ (file-notify-rm-watch watch)
+ (should-not (file-notify-valid-p watch)))))
+
+(ert-deftest files-tests-file-name-non-special-file-ownership-preserved-p ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should (equal (file-ownership-preserved-p nospecial)
+ (file-ownership-preserved-p tmpfile))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should (equal (file-ownership-preserved-p nospecial)
+ (file-ownership-preserved-p tmpfile)))))
+
+(ert-deftest files-tests-file-name-non-special-file-readable-p ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should (file-readable-p nospecial)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should-not (file-readable-p nospecial))))
+
+(ert-deftest files-tests-file-name-non-special-file-regular-p ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should (file-regular-p nospecial)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should-not (file-regular-p nospecial))))
+
+(ert-deftest files-tests-file-name-non-special-file-remote-p ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should-not (file-remote-p nospecial)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should-not (file-remote-p nospecial))))
+
+(ert-deftest files-tests-file-name-non-special-file-selinux-context ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (unless (equal (file-selinux-context tmpfile) '(nil nil nil nil))
+ (should (equal (file-selinux-context nospecial)
+ (file-selinux-context tmpfile)))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (unless (equal (file-selinux-context tmpfile) '(nil nil nil nil))
+ (should-not (equal (file-selinux-context nospecial)
+ (file-selinux-context tmpfile))))))
+
+(ert-deftest files-tests-file-name-non-special-file-symlink-p ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should-not (file-symlink-p nospecial)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should-not (file-symlink-p nospecial))))
+
+(ert-deftest files-tests-file-name-non-special-file-truename ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should (equal nospecial (file-truename nospecial))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should (equal nospecial (file-truename nospecial)))))
+
+(ert-deftest files-tests-file-name-non-special-file-writable-p ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should (file-writable-p nospecial)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should (file-writable-p nospecial))))
+
+(ert-deftest files-tests-file-name-non-special-find-backup-file-name ()
+ (let (version-control delete-old-versions
+ (kept-old-versions (default-toplevel-value 'kept-old-versions))
+ (kept-new-versions (default-toplevel-value 'kept-new-versions)))
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should (equal (find-backup-file-name nospecial)
+ (mapcar #'file-name-quote
+ (find-backup-file-name tmpfile)))))
+ (files-tests--with-temp-non-special-and-file-name-handler
+ (tmpfile nospecial)
+ (should-not (equal (find-backup-file-name nospecial)
+ (mapcar #'file-name-quote
+ (find-backup-file-name tmpfile)))))))
+
+(ert-deftest files-tests-file-name-non-special-get-file-buffer ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should-not (get-file-buffer nospecial)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should-not (get-file-buffer nospecial))))
+
+(ert-deftest files-tests-file-name-non-special-insert-directory ()
+ (files-tests--with-temp-non-special (tmpdir nospecial-dir t)
+ (should (equal (with-temp-buffer
+ (insert-directory nospecial-dir "")
+ (buffer-string))
+ (with-temp-buffer
+ (insert-directory tmpdir "")
+ (buffer-string)))))
+ (files-tests--with-temp-non-special-and-file-name-handler
+ (tmpdir nospecial-dir t)
+ (should-error (with-temp-buffer (insert-directory nospecial-dir "")))))
+
+(ert-deftest files-tests-file-name-non-special-insert-file-contents ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (with-temp-buffer
+ (insert-file-contents nospecial)
+ (should (zerop (buffer-size)))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should-error (with-temp-buffer (insert-file-contents nospecial)))))
+
+(ert-deftest files-tests-file-name-non-special-load ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should (load nospecial nil t)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should (load nospecial nil t))))
+
+(ert-deftest files-tests-file-name-non-special-make-auto-save-file-name ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (save-current-buffer
+ (should (equal (prog2 (set-buffer (find-file-noselect nospecial))
+ (make-auto-save-file-name)
+ (kill-buffer))
+ (prog2 (set-buffer (find-file-noselect tmpfile))
+ (make-auto-save-file-name)
+ (kill-buffer))))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (save-current-buffer
+ (should-not (equal (prog2 (set-buffer (find-file-noselect nospecial))
+ (make-auto-save-file-name)
+ (kill-buffer))
+ (prog2 (set-buffer (find-file-noselect tmpfile))
+ (make-auto-save-file-name)
+ (kill-buffer)))))))
+
+(ert-deftest files-tests-file-name-non-special-make-directory ()
+ (files-tests--with-temp-non-special (tmpdir nospecial-dir t)
+ (let ((default-directory nospecial-dir))
+ (make-directory "dir")
+ (should (file-directory-p "dir"))
+ (delete-directory "dir")))
+ (files-tests--with-temp-non-special-and-file-name-handler
+ (tmpdir nospecial-dir t)
+ (let ((default-directory nospecial-dir))
+ (should-error (make-directory "dir")))))
+
+(ert-deftest files-tests-file-name-non-special-make-directory-internal ()
+ (files-tests--with-temp-non-special (tmpdir nospecial-dir t)
+ (let ((default-directory nospecial-dir))
+ (make-directory-internal "dir")
+ (should (file-directory-p "dir"))
+ (delete-directory "dir")))
+ (files-tests--with-temp-non-special-and-file-name-handler
+ (tmpdir nospecial-dir t)
+ (let ((default-directory nospecial-dir))
+ (should-error (make-directory-internal "dir")))))
+
+(ert-deftest files-tests-file-name-non-special-make-nearby-temp-file ()
+ (let* ((default-directory (file-name-quote temporary-file-directory))
+ (near-tmpfile (make-nearby-temp-file "file")))
+ (should (file-exists-p near-tmpfile))
+ (delete-file near-tmpfile)))
+
+(ert-deftest files-tests-file-name-non-special-make-symbolic-link ()
+ (files-tests--with-temp-non-special (tmpdir nospecial-dir t)
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (let* ((linkname (expand-file-name "link" tmpdir))
+ (may-symlink (ignore-errors (make-symbolic-link tmpfile linkname)
+ t)))
+ (when may-symlink
+ (should (file-symlink-p linkname))
+ (delete-file linkname)
+ (let ((linkname (expand-file-name "link" nospecial-dir)))
+ (make-symbolic-link tmpfile linkname)
+ (should (file-symlink-p linkname))
+ (delete-file linkname))))))
+ (files-tests--with-temp-non-special-and-file-name-handler
+ (tmpdir nospecial-dir t)
+ (files-tests--with-temp-non-special-and-file-name-handler
+ (tmpfile nospecial)
+ (let* ((linkname (expand-file-name "link" tmpdir))
+ (may-symlink (ignore-errors (make-symbolic-link tmpfile linkname)
+ t)))
+ (when may-symlink
+ (should (file-symlink-p linkname))
+ (delete-file linkname)
+ (let ((linkname (expand-file-name "link" nospecial-dir)))
+ (should-error (make-symbolic-link tmpfile linkname))))))))
+
+;; See `files-tests--file-name-non-special--subprocess'.
+;; (ert-deftest files-tests-file-name-non-special-process-file ())
+
+(ert-deftest files-tests-file-name-non-special-rename-file ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (rename-file nospecial (files-tests--new-name nospecial "x"))
+ (rename-file (files-tests--new-name nospecial "x") nospecial)
+ (rename-file tmpfile (files-tests--new-name nospecial "x"))
+ (rename-file (files-tests--new-name nospecial "x") nospecial)
+ (rename-file nospecial (files-tests--new-name tmpfile "x"))
+ (rename-file (files-tests--new-name nospecial "x") nospecial))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should-error (rename-file nospecial (files-tests--new-name nospecial "x")))
+ (rename-file tmpfile (files-tests--new-name nospecial "x"))
+ (rename-file (files-tests--new-name nospecial "x") nospecial)
+ (rename-file nospecial (files-tests--new-name tmpfile "x"))
+ (should-error (rename-file (files-tests--new-name nospecial "x") nospecial))
+ (delete-file (files-tests--new-name tmpfile "x"))
+ (delete-file (files-tests--new-name nospecial "x"))))
+
+(ert-deftest files-tests-file-name-non-special-set-file-acl ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (set-file-acl nospecial (file-acl nospecial)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (set-file-acl nospecial (file-acl nospecial))))
+
+(ert-deftest files-tests-file-name-non-special-set-file-modes ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (set-file-modes nospecial (file-modes nospecial)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should-error (set-file-modes nospecial (file-modes nospecial)))))
+
+(ert-deftest files-tests-file-name-non-special-set-file-selinux-context ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (unless (equal (file-selinux-context tmpfile) '(nil nil nil nil))
+ (set-file-selinux-context nospecial (file-selinux-context nospecial))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (unless (equal (file-selinux-context tmpfile) '(nil nil nil nil))
+ (should-error
+ (set-file-selinux-context nospecial (file-selinux-context nospecial))))))
+
+(ert-deftest files-tests-file-name-non-special-set-file-times ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (set-file-times nospecial))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should-error (set-file-times nospecial))))
+
+(ert-deftest files-tests-file-name-non-special-set-visited-file-modtime ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (save-current-buffer
+ (set-buffer (find-file-noselect nospecial))
+ (set-visited-file-modtime)
+ (kill-buffer)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (save-current-buffer
+ (set-buffer (find-file-noselect nospecial))
+ (set-visited-file-modtime)
+ (kill-buffer))))
+
+(ert-deftest files-tests-file-name-non-special-shell-command ()
+ (files-tests--with-temp-non-special (tmpdir nospecial-dir t)
+ (with-temp-buffer
+ (let ((default-directory nospecial-dir))
+ (shell-command (concat (shell-quote-argument
+ (concat invocation-directory invocation-name))
+ " --version")
+ (current-buffer))
+ (goto-char (point-min))
+ (should (search-forward emacs-version nil t)))))
+ (files-tests--with-temp-non-special-and-file-name-handler
+ (tmpdir nospecial-dir t)
+ (with-temp-buffer
+ (let ((default-directory nospecial-dir))
+ (should-error
+ (shell-command (concat (shell-quote-argument
+ (concat invocation-directory invocation-name))
+ " --version")
+ (current-buffer)))))))
+
+(ert-deftest files-tests-file-name-non-special-start-file-process ()
+ (files-tests--with-temp-non-special (tmpdir nospecial-dir t)
+ (with-temp-buffer
+ (let ((default-directory nospecial-dir))
+ (let ((proc (start-file-process
+ "emacs" (current-buffer)
+ (concat invocation-directory invocation-name)
+ "--version")))
+ (accept-process-output proc)
+ (goto-char (point-min))
+ (should (search-forward emacs-version nil t))
+ ;; Don't stop the test run with a query, as the subprocess
+ ;; may or may not be dead by the time we reach here.
+ (set-process-query-on-exit-flag proc nil)))))
+ (files-tests--with-temp-non-special-and-file-name-handler
+ (tmpdir nospecial-dir t)
+ (with-temp-buffer
+ (let ((default-directory nospecial-dir))
+ (should-error (start-file-process
+ "emacs" (current-buffer)
+ (concat invocation-directory invocation-name)
+ "--version"))))))
+
+(ert-deftest files-tests-file-name-non-special-substitute-in-file-name ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (let ((process-environment (cons "FOO=foo" process-environment))
+ (nospecial-foo (files-tests--new-name nospecial "$FOO")))
+ ;; The "/:" prevents substitution.
+ (equal (substitute-in-file-name nospecial-foo) nospecial-foo)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (let ((process-environment (cons "FOO=foo" process-environment))
+ (nospecial-foo (files-tests--new-name nospecial "$FOO")))
+ ;; The "/:" prevents substitution.
+ (equal (substitute-in-file-name nospecial-foo) nospecial-foo))))
+
+(ert-deftest files-tests-file-name-non-special-temporary-file-directory ()
+ (files-tests--with-temp-non-special (tmpdir nospecial-dir t)
+ (let ((default-directory nospecial-dir))
+ (equal (temporary-file-directory) temporary-file-directory)))
+ (files-tests--with-temp-non-special-and-file-name-handler
+ (tmpdir nospecial-dir t)
+ (let ((default-directory nospecial-dir))
+ (equal (temporary-file-directory) temporary-file-directory))))
+
+(ert-deftest files-tests-file-name-non-special-unhandled-file-name-directory ()
+ (files-tests--with-temp-non-special (tmpdir nospecial-dir t)
+ (equal (unhandled-file-name-directory nospecial-dir)
+ (file-name-as-directory tmpdir)))
+ (files-tests--with-temp-non-special-and-file-name-handler
+ (tmpdir nospecial-dir t)
+ (equal (unhandled-file-name-directory nospecial-dir)
+ (file-name-as-directory tmpdir))))
+
+(ert-deftest files-tests-file-name-non-special-vc-registered ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (should (equal (vc-registered nospecial) (vc-registered tmpfile))))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (should (equal (vc-registered nospecial) (vc-registered tmpfile)))))
+
+;; See test `files-tests--file-name-non-special--buffers'.
+;; (ert-deftest files-tests-file-name-non-special-verify-visited-file-modtime ())
+
+(ert-deftest files-tests-file-name-non-special-write-region ()
+ (files-tests--with-temp-non-special (tmpfile nospecial)
+ (with-temp-buffer
+ (write-region nil nil nospecial nil :visit)))
+ (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
+ (with-temp-buffer
+ (write-region nil nil nospecial nil :visit))))
+
+(ert-deftest files-tests-file-name-non-special-make-process ()
+ "Check that the ‘:file-handler’ argument of ‘make-process’
+works as expected if the default directory is quoted."
+ (let ((default-directory (file-name-quote invocation-directory))
+ (program (file-name-quote
+ (expand-file-name invocation-name invocation-directory))))
+ (should (processp (make-process :name "name"
+ :command (list program "--version")
+ :file-handler t)))))
+
(ert-deftest files-tests--insert-directory-wildcard-in-dir-p ()
(let ((alist (list (cons "/home/user/*/.txt" (cons "/home/user/" "*/.txt"))
(cons "/home/user/.txt" nil)
@@ -373,7 +1167,8 @@ consider the buffer saved, without prompting for a file
name (Bug#28412)."
(let ((read-file-name-function
(lambda (&rest _ignore)
- (error "Prompting for file name"))))
+ (error "Prompting for file name")))
+ require-final-newline)
;; With contents function, and no file.
(with-temp-buffer
(setq write-contents-functions (lambda () t))
diff --git a/test/lisp/files-x-tests.el b/test/lisp/files-x-tests.el
index d678be409d1..568a8984479 100644
--- a/test/lisp/files-x-tests.el
+++ b/test/lisp/files-x-tests.el
@@ -35,6 +35,11 @@
'((remote-null-device . "/dev/null")))
(defconst files-x-test--variables4
'((remote-null-device . "null")))
+(put 'remote-shell-file-name 'safe-local-variable #'identity)
+(put 'remote-shell-command-switch 'safe-local-variable #'identity)
+(put 'remote-shell-interactive-switch 'safe-local-variable #'identity)
+(put 'remote-shell-login-switch 'safe-local-variable #'identity)
+(put 'remote-null-device 'safe-local-variable #'identity)
(defconst files-x-test--application '(:application 'my-application))
(defconst files-x-test--another-application
@@ -268,7 +273,9 @@
(should-not (local-variable-p 'remote-shell-file-name))
(should-not (boundp 'remote-shell-file-name))))))
-(ert-deftest files-x-test-with-connection-local-profiles ()
+(defvar tramp-connection-local-default-profile)
+
+(ert-deftest files-x-test-with-connection-local-variables ()
"Test setting connection-local variables."
(let (connection-local-profile-alist connection-local-criteria-alist)
@@ -303,46 +310,48 @@
(string-equal (symbol-value 'remote-null-device) "/dev/null"))
;; A candidate connection-local variable is not bound yet.
- (should-not (local-variable-p 'remote-shell-command-switch))
-
- ;; Use the macro.
- (with-connection-local-profiles '(remote-bash remote-ksh)
- ;; All connection-local variables are set. They apply in
- ;; reverse order in `connection-local-variables-alist'.
- ;; This variable keeps only the variables to be set inside
- ;; the macro.
- (should
- (equal connection-local-variables-alist
- (nreverse (copy-tree files-x-test--variables1))))
- ;; The variables exist also as local variables.
- (should (local-variable-p 'remote-shell-file-name))
- (should (local-variable-p 'remote-shell-command-switch))
- ;; The proper variable values are set. The settings from
- ;; `remote-bash' overwrite the same variables as in
- ;; `remote-ksh'.
- (should
- (string-equal (symbol-value 'remote-shell-file-name) "/bin/bash"))
- (should
- (string-equal (symbol-value 'remote-shell-command-switch) "-c")))
-
- ;; Everything is rewound. The old variable values are reset.
- (should
- (equal connection-local-variables-alist
- (append
- (nreverse (copy-tree files-x-test--variables3))
- (nreverse (copy-tree files-x-test--variables2)))))
- ;; The variables exist also as local variables.
- (should (local-variable-p 'remote-shell-file-name))
- (should (local-variable-p 'remote-null-device))
- ;; The proper variable values are set. The settings from
- ;; `remote-ksh' are back.
- (should
- (string-equal (symbol-value 'remote-shell-file-name) "/bin/ksh"))
- (should
- (string-equal (symbol-value 'remote-null-device) "/dev/null"))
+ (should-not (local-variable-p 'remote-shell-command-switch))))
- ;; The variable set temporarily is not unbound, again.
- (should-not (local-variable-p 'remote-shell-command-switch))))))
+ (with-temp-buffer
+ ;; Use the macro. We need a remote `default-directory'.
+ (let ((enable-connection-local-variables t)
+ (default-directory "/method:host:")
+ (remote-null-device "null"))
+ (should-not connection-local-variables-alist)
+ (should-not (local-variable-p 'remote-shell-file-name))
+ (should-not (local-variable-p 'remote-null-device))
+ (should-not (boundp 'remote-shell-file-name))
+ (should (string-equal (symbol-value 'remote-null-device) "null"))
+
+ (with-connection-local-variables
+ ;; All connection-local variables are set. They apply in
+ ;; reverse order in `connection-local-variables-alist'.
+ ;; Since we ha a remote default directory, Tramp's settings
+ ;; are appended as well.
+ (should
+ (equal
+ connection-local-variables-alist
+ (append
+ (nreverse (copy-tree files-x-test--variables3))
+ (nreverse (copy-tree files-x-test--variables2))
+ (nreverse (copy-tree tramp-connection-local-default-profile)))))
+ ;; The variables exist also as local variables.
+ (should (local-variable-p 'remote-shell-file-name))
+ (should (local-variable-p 'remote-null-device))
+ ;; The proper variable values are set.
+ (should
+ (string-equal (symbol-value 'remote-shell-file-name) "/bin/ksh"))
+ (should
+ (string-equal (symbol-value 'remote-null-device) "/dev/null")))
+
+ ;; Everything is rewound. The old variable values are reset.
+ (should-not connection-local-variables-alist)
+ ;; The variables don't exist as local variables.
+ (should-not (local-variable-p 'remote-shell-file-name))
+ (should-not (local-variable-p 'remote-null-device))
+ ;; The variable values are reset.
+ (should-not (boundp 'remote-shell-file-name))
+ (should (string-equal (symbol-value 'remote-null-device) "null"))))))
(provide 'files-x-tests)
;;; files-x-tests.el ends here
diff --git a/test/lisp/gnus/gnus-test-headers.el b/test/lisp/gnus/gnus-test-headers.el
new file mode 100644
index 00000000000..abf3d4f2713
--- /dev/null
+++ b/test/lisp/gnus/gnus-test-headers.el
@@ -0,0 +1,178 @@
+;;; gnus-test-headers.el --- Tests for Gnus header-related functions -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018-2019 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <eric@ericabrahamsen.net>
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; The tests her are for
+
+;;; Code:
+
+(require 'ert)
+(require 'gnus-sum)
+
+(defconst gnus-headers-test-data
+ '([2 "Re: [Emacs-devel] Emacs move" "Dave Love <d.love@dl.ac.uk>"
+ "Thu, 14 Sep 2000 11:10:46 +0100"
+ "<200009141010.LAA26351@djlvig.dl.ac.uk>"
+ "<20000913175943.A26093@sparky.nisa.net>"
+ 1882 16 "nnmaildir mails:2"
+ ((To . "Jeff Bailey <jbailey@nisa.net>")
+ (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
+ [3 "Re: [Emacs-devel] Emacs move" "Sam Steingold <sds@gnu.org>"
+ "14 Sep 2000 10:21:56 -0400" "<upum7xddn.fsf@xchange.com>"
+ "<20000913175943.A26093@sparky.nisa.net>"
+ 2991 50 "nnmaildir mails:3"
+ ((To . "Jeff Bailey <jbailey@nisa.net>")
+ (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
+ [4 "Re: [Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>"
+ "Thu, 14 Sep 2000 09:14:47 -0700"
+ "<20000914091447.G4827@sparky.nisa.net>"
+ "<20000913175943.A26093@sparky.nisa.net> <upum7xddn.fsf@xchange.com>"
+ 1780 15 "nnmaildir mails:4"
+ ((To . "sds@gnu.org, Jeff Bailey <jbailey@nisa.net>")
+ (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
+ [5 "Re: [Emacs-devel] Emacs move" "Dave Love <d.love@dl.ac.uk>"
+ "Thu, 14 Sep 2000 18:24:36 +0100"
+ "<200009141724.SAA26807@djlvig.dl.ac.uk>"
+ "<20000913175943.A26093@sparky.nisa.net>"
+ 1343 9 "nnmaildir mails:5"
+ ((To . "Jeff Bailey <jbailey@nisa.net>")
+ (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
+ [6 "Re: [Emacs-devel] Emacs move" "Karl Fogel <kfogel@galois.collab.net>"
+ "14 Sep 2000 10:37:35 -0500" "<87em2nyog0.fsf@galois.collab.net>"
+ "<20000913175943.A26093@sparky.nisa.net> <200009141724.SAA26807@djlvig.dl.ac.uk>"
+ 3740 124 "nnmaildir mails:6"
+ ((To . "Dave Love <d.love@dl.ac.uk>")
+ (Cc . "Jeff Bailey <jbailey@nisa.net>, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
+ [7 "Re: [Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>"
+ "Thu, 14 Sep 2000 10:55:12 -0700"
+ "<20000914105512.A29291@sparky.nisa.net>"
+ "<20000913175943.A26093@sparky.nisa.net> <200009141724.SAA26807@djlvig.dl.ac.uk> <87em2nyog0.fsf@galois.collab.net>"
+ 1687 16 "nnmaildir mails:7"
+ ((To . "kfogel@red-bean.com, Dave Love <d.love@dl.ac.uk>")
+ (Cc . "Jeff Bailey <jbailey@nisa.net>, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
+ [8 "Re: [Emacs-devel] Emacs move" "John Wiegley <johnw@gnu.org>"
+ "Thu, 14 Sep 2000 12:19:01 -0700"
+ "<200009141919.MAA05085@localhost.localdomain>"
+ "<20000913175943.A26093@sparky.nisa.net>"
+ 1978 27 "nnmaildir mails:8"
+ ((To . "emacs-devel@gnu.org"))]
+ [9 "Re: [Emacs-devel] Emacs move"
+ "\"Robert J. Chassell\" <bob@rattlesnake.com>"
+ "Thu, 14 Sep 2000 07:33:15 -0400 (EDT)"
+ "<m13ZXGV-000BCgC@megalith.rattlesnake.com>"
+ "<20000913175943.A26093@sparky.nisa.net>"
+ 3046 72 "nnmaildir mails:9"
+ ((To . "jbailey@nisa.net")
+ (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
+ [10 "Re: [Emacs-devel] Emacs move"
+ "wmperry@aventail.com (William M. Perry)"
+ "14 Sep 2000 09:10:25 -0500"
+ "<86g0n3f4j2.fsf@megalith.bp.aventail.com>"
+ "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com>"
+ 3104 44 "nnmaildir mails:10"
+ ((To . "bob@rattlesnake.com")
+ (Cc . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
+ [11 "Re: [Emacs-devel] Emacs move" "Gerd Moellmann <gerd@gnu.org>"
+ "Thu, 14 Sep 2000 21:51:05 +0200 (CEST)"
+ "<200009141951.VAA06005@gerd.segv.de>"
+ "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com> <86g0n3f4j2.fsf@megalith.bp.aventail.com>"
+ 1884 6 "nnmaildir mails:11"
+ ((To . "wmvperry@aventail.com")
+ (Cc . "bob@rattlesnake.com, jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
+ [12 "Re: [Emacs-devel] Emacs move" "Gerd Moellmann <gerd@gnu.org>"
+ "Thu, 14 Sep 2000 21:49:03 +0200 (CEST)"
+ "<200009141949.VAA05998@gerd.segv.de>"
+ "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com>"
+ 2408 24 "nnmaildir mails:12"
+ ((To . "bob@rattlesnake.com")
+ (Cc . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
+ [13 "Re: [Emacs-devel] Emacs move"
+ "\"Robert J. Chassell\" <bob@rattlesnake.com>"
+ "Thu, 14 Sep 2000 17:50:01 -0400 (EDT)"
+ "<m13ZgtN-000BD3C@megalith.rattlesnake.com>"
+ "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com> <200009141949.VAA05998@gerd.segv.de>"
+ 1968 23 "nnmaildir mails:13"
+ ((To . "gerd@gnu.org")
+ (Cc . "bob@rattlesnake.com, jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
+ [14 "Re: [Emacs-devel] Emacs move" "Richard Stallman <rms@gnu.org>"
+ "Fri, 15 Sep 2000 16:28:12 -0600 (MDT)"
+ "<200009152228.QAA20526@wijiji.santafe.edu>"
+ "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com>"
+ 1288 2 "nnmaildir mails:14"
+ ((To . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
+ [15 "[Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>"
+ "Wed, 13 Sep 2000 17:59:43 -0700"
+ "<20000913175943.A26093@sparky.nisa.net>" ""
+ 1661 26 "nnmaildir mails:15"
+ ((To . "emacs-devel@gnu.org")
+ (Cc . "cvs-hackers@gnu.org"))]
+ [16 "Re: [Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>"
+ "Fri, 15 Sep 2000 22:00:12 -0700"
+ "<20000915220012.A3923@sparky.nisa.net>"
+ "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com> <200009141949.VAA05998@gerd.segv.de> <m13ZgtN-000BD3C@megalith.rattlesnake.com>"
+ 2857 51 "nnmaildir mails:16"
+ ((To . "bob@rattlesnake.com, gerd@gnu.org")
+ (Cc . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))])
+ "A pile of headers with potential interdependencies.")
+
+(ert-deftest gnus-headers-make-dependency-table ()
+ (let ((table (gnus-make-hashtable 20))
+ (data (copy-sequence gnus-headers-test-data))
+ ret)
+ (dolist (h data)
+ ;; `gnus-dependencies-add-header' returns nil if it fails to add
+ ;; the header.
+ (should (gnus-dependencies-add-header h table nil)))
+ ;; Pick a value to test.
+ (setq ret (gethash "<m13ZXGV-000BCgC@megalith.rattlesnake.com>"
+ table))
+ ;; The message has three children.
+ (should (= 3 (length (cdr ret))))
+ ;; The first of those children has one child.
+ (should (= 1 (length (cdr (nth 1 ret)))))))
+
+(ert-deftest gnus-headers-loop-dependencies ()
+ "Intentionally create a reference loop."
+ (let ((table (gnus-make-hashtable 20))
+ (data (copy-sequence gnus-headers-test-data))
+ (parent-id "<200009141724.SAA26807@djlvig.dl.ac.uk>")
+ (child-id "<87em2nyog0.fsf@galois.collab.net>")
+ parent)
+ (dolist (h data)
+ (gnus-dependencies-add-header h table nil))
+
+ (setq parent (gethash parent-id table))
+
+ ;; Put the parent header in the child references of one of its own
+ ;; children. `gnus-thread-loop-p' only checks if there's a loop
+ ;; between parent and immediate child, not parent and random
+ ;; descendant. At least, near as I can tell that's the case.
+
+ (push (list (car parent)) (cdr (gethash child-id table)))
+
+ (let ((gnus-newsgroup-dependencies table))
+ (should
+ (= 1 ; 1 indicates an infloop.
+ (gnus-thread-loop-p (car parent) (cadr parent)))))))
+
+(provide 'gnus-test-headers)
+;;; gnus-test-headers.el ends here
diff --git a/test/lisp/gnus/gnus-tests.el b/test/lisp/gnus/gnus-tests.el
index 33e438300aa..4b7c91f130d 100644
--- a/test/lisp/gnus/gnus-tests.el
+++ b/test/lisp/gnus/gnus-tests.el
@@ -26,8 +26,6 @@
;;; Code:
;; registry.el is required by gnus-registry.el but this way we're explicit.
-(eval-when-compile (require 'cl))
-
(require 'registry)
(require 'gnus-registry)
diff --git a/test/lisp/gnus/message-tests.el b/test/lisp/gnus/message-tests.el
index c55ccbf34d0..aa3587dddf5 100644
--- a/test/lisp/gnus/message-tests.el
+++ b/test/lisp/gnus/message-tests.el
@@ -29,6 +29,8 @@
(require 'ert)
(require 'ert-x)
+(require 'cl-lib)
+
(ert-deftest message-mode-propertize ()
(with-temp-buffer
(unwind-protect
@@ -97,6 +99,60 @@
(should (string= stripped-was
(message-strip-subject-trailing-was with-was)))))))
+(ert-deftest message-all-recipients ()
+ (ert-with-test-buffer (:name "message")
+ (insert "To: Person 1 <p1@p1.org>, Person 2 <p2@p2.org>\n")
+ (insert "Cc: Person 3 <p3@p3.org>, Person 4 <p4@p4.org>\n")
+ (insert "Bcc: Person 5 <p5@p5.org>, Person 6 <p6@p6.org>\n")
+ (should (equal (message-all-recipients)
+ '(("Person 1" "p1@p1.org")
+ ("Person 2" "p2@p2.org")
+ ("Person 3" "p3@p3.org")
+ ("Person 4" "p4@p4.org")
+ ("Person 5" "p5@p5.org")
+ ("Person 6" "p6@p6.org"))))))
+
+(ert-deftest message-all-epg-keys-available-p ()
+ (skip-unless (epg-check-configuration (epg-find-configuration 'OpenPGP)))
+ (let ((person1 '("Person 1" "p1@p1.org"))
+ (person2 '("Person 2" "p2@p2.org"))
+ (person3 '("Person 3" "p3@p3.org"))
+ (recipients nil)
+ (keyring '("p1@p1.org" "p2@p2.org")))
+ (cl-letf (((symbol-function 'epg-list-keys)
+ (lambda (_ email) (cl-find email keyring :test #'string=)))
+ ((symbol-function 'message-all-recipients)
+ (lambda () recipients)))
+
+ (setq recipients (list))
+ (should (message-all-epg-keys-available-p))
+
+ (setq recipients (list person1))
+ (should (message-all-epg-keys-available-p))
+
+ (setq recipients (list person1 person2))
+ (should (message-all-epg-keys-available-p))
+
+ (setq recipients (list person3))
+ (should-not (message-all-epg-keys-available-p))
+
+ (setq recipients (list person1 person3))
+ (should-not (message-all-epg-keys-available-p))
+
+ (setq recipients (list person3 person1))
+ (should-not (message-all-epg-keys-available-p))
+
+ (setq recipients (list person1 person2 person3))
+ (should-not (message-all-epg-keys-available-p)))))
+
+(ert-deftest message-alter-repeat-address ()
+ (should (equal (message--alter-repeat-address
+ "Lars Ingebrigtsen <larsi@gnus.org>")
+ "Lars Ingebrigtsen <larsi@gnus.org>"))
+
+ (should (equal (message--alter-repeat-address
+ "\"larsi@gnus.org\" <larsi@gnus.org>")
+ "larsi@gnus.org")))
(provide 'message-mode-tests)
diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el
index 66a96e6fa50..e31ac6a4d48 100644
--- a/test/lisp/help-fns-tests.el
+++ b/test/lisp/help-fns-tests.el
@@ -81,6 +81,11 @@ Return first line of the output of (describe-function-1 FUNC)."
(result (help-fns-tests--describe-function 'search-forward-regexp)))
(should (string-match regexp result))))
+(ert-deftest help-fns-test-dangling-alias ()
+ "Make sure we don't burp on bogus aliases."
+ (let ((f (make-symbol "bogus-alias")))
+ (define-obsolete-function-alias f 'help-fns-test--undefined-function "past")
+ (describe-symbol f)))
;;; Test describe-function over functions with funny names
(defun abc\\\[universal-argument\]b\`c\'d\\e\"f (x)
diff --git a/test/lisp/hi-lock-tests.el b/test/lisp/hi-lock-tests.el
index 8dd872398e5..c4d25b69e14 100644
--- a/test/lisp/hi-lock-tests.el
+++ b/test/lisp/hi-lock-tests.el
@@ -29,7 +29,7 @@
(with-temp-buffer
(insert "a A b B\n")
(cl-letf (((symbol-function 'completing-read)
- (lambda (prompt coll x y z hist defaults)
+ (lambda (_prompt _coll _x _y _z _hist defaults)
(car defaults))))
(dotimes (_ 2)
(let ((face (hi-lock-read-face-name)))
@@ -41,7 +41,7 @@
(with-temp-buffer
(insert "foo bar")
(cl-letf (((symbol-function 'completing-read)
- (lambda (prompt coll x y z hist defaults)
+ (lambda (_prompt _coll _x _y _z _hist defaults)
(car defaults))))
(hi-lock-set-pattern "9999" (hi-lock-read-face-name)) ; No match
(hi-lock-set-pattern "foo" (hi-lock-read-face-name)))
diff --git a/test/lisp/htmlfontify-tests.el b/test/lisp/htmlfontify-tests.el
index 08163874ac2..ada8294984e 100644
--- a/test/lisp/htmlfontify-tests.el
+++ b/test/lisp/htmlfontify-tests.el
@@ -36,7 +36,7 @@ available (Bug#25468)."
(should (equal (let ((process-environment
(cons "SHELL=/does/not/exist" process-environment)))
(call-process
- (expand-file-name (invocation-name) (invocation-directory))
+ (expand-file-name invocation-name invocation-directory)
nil nil nil
"--quick" "--batch"
(concat "--load=" (locate-library "htmlfontify"))))
diff --git a/test/lisp/info-xref-tests.el b/test/lisp/info-xref-tests.el
index ed6fa417f5f..1de3a0d0627 100644
--- a/test/lisp/info-xref-tests.el
+++ b/test/lisp/info-xref-tests.el
@@ -144,4 +144,21 @@ text.
(format "%s.info" (file-name-sans-extension
tempfile2)))))))
+(ert-deftest info-xref-test-emacs-manuals ()
+ "Test that all internal links in the Emacs manuals work."
+ :tags '(:expensive-test)
+ (require 'info)
+ (let ((default-directory (car (Info-default-dirs)))
+ (Info-directory-list '(".")))
+ (skip-unless (file-readable-p "emacs.info"))
+ (info-xref-check-all)
+ (with-current-buffer info-xref-output-buffer
+ (goto-char (point-max))
+ (should (search-backward "done" nil t))
+ (should (string-match-p
+ " [0-9]\\{3,\\} good, 0 bad"
+ (buffer-substring-no-properties (line-beginning-position)
+ (line-end-position)))))))
+
+
;;; info-xref.el ends here
diff --git a/test/lisp/international/ccl-tests.el b/test/lisp/international/ccl-tests.el
new file mode 100644
index 00000000000..69e3930d42c
--- /dev/null
+++ b/test/lisp/international/ccl-tests.el
@@ -0,0 +1,229 @@
+;; Copyright (C) 2018-2019 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'ccl)
+(require 'seq)
+
+
+(ert-deftest shift ()
+ ;; shift left +ve 5628 #x00000000000015fc
+ (should (= (ash 5628 8) 1440768)) ; #x000000000015fc00
+ (should (= (lsh 5628 8) 1440768)) ; #x000000000015fc00
+
+ ;; shift left -ve -5628 #x3fffffffffffea04
+ (should (= (ash -5628 8) -1440768)) ; #x3fffffffffea0400
+ (should (= (lsh -5628 8) -1440768)) ; #x3fffffffffea0400
+
+ ;; shift right +ve 5628 #x00000000000015fc
+ (should (= (ash 5628 -8) 21)) ; #x0000000000000015
+ (should (= (lsh 5628 -8) 21)) ; #x0000000000000015
+
+ ;; shift right -ve -5628 #x3fffffffffffea04
+ (should (= (ash -5628 -8) -22)) ; #x3fffffffffffffea
+ (should (= (lsh -5628 -8)
+ (ash (- -5628 (ash most-negative-fixnum 1)) -8)
+ (ash (logand (ash -5628 -1) most-positive-fixnum) -7))))
+
+;; CCl program from `pgg-parse-crc24' in lisp/obsolete/pgg-parse.el
+(defconst prog-pgg-source
+ '(1
+ ((loop
+ (read r0) (r1 ^= r0) (r2 ^= 0)
+ (r5 = 0)
+ (loop
+ (r1 <<= 1)
+ (r1 += ((r2 >> 15) & 1))
+ (r2 <<= 1)
+ (if (r1 & 256)
+ ((r1 ^= 390) (r2 ^= 19707)))
+ (if (r5 < 7)
+ ((r5 += 1)
+ (repeat))))
+ (repeat)))))
+
+(defconst prog-pgg-code
+ [1 30 14 114744 114775 0 161 131127 1 148217 15 82167
+ 1 1848 131159 1 1595 5 256 114743 390 114775 19707
+ 1467 16 7 183 1 -5628 -7164 22])
+
+(defconst prog-pgg-dump
+"Out-buffer must be as large as in-buffer.
+Main-body:
+ 2:[read-register] read r0 (0 remaining)
+ 3:[set-assign-expr-register] r1 ^= r0
+ 4:[set-assign-expr-const] r2 ^= 0
+ 6:[set-short-const] r5 = 0
+ 7:[set-assign-expr-const] r1 <<= 1
+ 9:[set-expr-const] r7 = r2 >> 15
+ 11:[set-assign-expr-const] r7 &= 1
+ 13:[set-assign-expr-register] r1 += r7
+ 14:[set-assign-expr-const] r2 <<= 1
+ 16:[jump-cond-expr-const] if !(r1 & 256), jump to 23(+7)
+ 19:[set-assign-expr-const] r1 ^= 390
+ 21:[set-assign-expr-const] r2 ^= 19707
+ 23:[jump-cond-expr-const] if !(r5 < 7), jump to 29(+6)
+ 26:[set-assign-expr-const] r5 += 1
+ 28:[jump] jump to 7(-21)
+ 29:[jump] jump to 2(-27)
+At EOF:
+ 30:[end] end
+")
+
+(ert-deftest ccl-compile-pgg ()
+ (should (equal (ccl-compile prog-pgg-source) prog-pgg-code)))
+
+(ert-deftest ccl-dump-pgg ()
+ (with-temp-buffer
+ (ccl-dump prog-pgg-code)
+ (should (equal (buffer-string) prog-pgg-dump))))
+
+(ert-deftest pgg-parse-crc24 ()
+ ;; Compiler
+ (require 'pgg)
+ (should (equal pgg-parse-crc24 prog-pgg-code))
+ ;; Interpreter
+ (should (equal (pgg-parse-crc24-string "foo") (concat [#x4f #xc2 #x55])))
+ (should (equal (pgg-parse-crc24-string "bar") (concat [#x51 #xd9 #x53])))
+ (should (equal (pgg-parse-crc24-string "baz") (concat [#xf0 #x58 #x6a]))))
+
+(ert-deftest pgg-parse-crc24-dump ()
+ ;; Disassembler
+ (require 'pgg)
+ (with-temp-buffer
+ (ccl-dump pgg-parse-crc24)
+ (should (equal (buffer-string) prog-pgg-dump))))
+
+;;----------------------------------------------------------------------------
+;; Program from 'midikbd-decoder in midi-kbd-0.2.el GNU ELPA package
+(defconst prog-midi-source
+ '(2
+ (loop
+ (loop
+ ;; central message receiver loop here.
+ ;; When it exits, the command to deal with is in r0
+ ;; Any arguments are in r1 and r2
+ ;; r3 contains: 0 if no arguments are accepted
+ ;; 1 if 1 argument can be accepted
+ ;; 2 if 2 arguments can be accepted
+ ;; 3 if the first of two arguments has been accepted
+ ;; Arguments are read into r1 and r2.
+ ;; r4 contains the current running status byte if any.
+ (read-if (r0 < #x80)
+ (branch r3
+ (repeat)
+ ((r1 = r0) (r0 = r4) (break))
+ ((r1 = r0) (r3 = 3) (repeat))
+ ((r2 = r0) (r3 = 2) (r0 = r4) (break))))
+ (if (r0 >= #xf8) ; real time message
+ (break))
+ (if (r0 < #xf0) ; channel command
+ ((r4 = r0)
+ (if ((r0 & #xe0) == #xc0)
+ ;; program change and channel pressure take only 1 argument
+ (r3 = 1)
+ (r3 = 2))
+ (repeat)))
+ ;; system common message, we swallow those for now
+ (r3 = 0)
+ (repeat))
+ (if ((r0 & #xf0) == #x90)
+ (if (r2 == 0) ; Some Midi devices use velocity 0
+ ; for switching notes off,
+ ; so translate into note-off
+ ; and fall through
+ (r0 -= #x10)
+ ((r0 &= #xf)
+ (write 0)
+ (write r0 r1 r2)
+ (repeat))))
+ (if ((r0 & #xf0) == #x80)
+ ((r0 &= #xf)
+ (write 1)
+ (write r0 r1 r2)
+ (repeat)))
+ (repeat))))
+
+(defconst prog-midi-code
+ [2 72 4893 16 128 1133 5 6 9 12 16 -2556 32 1024 6660 32 865
+ -4092 64 609 1024 4868 795 20 248 3844 3099 16 240 128 82169
+ 224 1275 18 192 353 260 609 -9468 97 -9980 82169 240 4091
+ 18 144 1371 18 0 16407 16 1796 81943 15 20 529 305 81 -14588
+ 82169 240 2555 18 128 81943 15 276 529 305 81 -17660 -17916 22])
+
+(defconst prog-midi-dump
+(concat "Out-buffer must be 2 times bigger than in-buffer.
+Main-body:
+ 2:[read-jump-cond-expr-const] read r0, if !(r0 < 128), jump to 22(+20)
+ 5:[branch] jump to array[r3] of length 4
+ 11 12 15 18 22 ""
+ 11:[jump] jump to 2(-9)
+ 12:[set-register] r1 = r0
+ 13:[set-register] r0 = r4
+ 14:[jump] jump to 41(+27)
+ 15:[set-register] r1 = r0
+ 16:[set-short-const] r3 = 3
+ 17:[jump] jump to 2(-15)
+ 18:[set-register] r2 = r0
+ 19:[set-short-const] r3 = 2
+ 20:[set-register] r0 = r4
+ 21:[jump] jump to 41(+20)
+ 22:[jump-cond-expr-const] if !(r0 >= 248), jump to 26(+4)
+ 25:[jump] jump to 41(+16)
+ 26:[jump-cond-expr-const] if !(r0 < 240), jump to 39(+13)
+ 29:[set-register] r4 = r0
+ 30:[set-expr-const] r7 = r0 & 224
+ 32:[jump-cond-expr-const] if !(r7 == 192), jump to 37(+5)
+ 35:[set-short-const] r3 = 1
+ 36:[jump] jump to 38(+2)
+ 37:[set-short-const] r3 = 2
+ 38:[jump] jump to 2(-36)
+ 39:[set-short-const] r3 = 0
+ 40:[jump] jump to 2(-38)
+ 41:[set-expr-const] r7 = r0 & 240
+ 43:[jump-cond-expr-const] if !(r7 == 144), jump to 59(+16)
+ 46:[jump-cond-expr-const] if !(r2 == 0), jump to 52(+6)
+ 49:[set-assign-expr-const] r0 -= 16
+ 51:[jump] jump to 59(+8)
+ 52:[set-assign-expr-const] r0 &= 15
+ 54:[write-const-string] write char \"\x00\"
+ 55:[write-register] write r0 (2 remaining)
+ 56:[write-register] write r1 (1 remaining)
+ 57:[write-register] write r2 (0 remaining)
+ 58:[jump] jump to 2(-56)
+ 59:[set-expr-const] r7 = r0 & 240
+ 61:[jump-cond-expr-const] if !(r7 == 128), jump to 71(+10)
+ 64:[set-assign-expr-const] r0 &= 15
+ 66:[write-const-string] write char \"\x01\"
+ 67:[write-register] write r0 (2 remaining)
+ 68:[write-register] write r1 (1 remaining)
+ 69:[write-register] write r2 (0 remaining)
+ 70:[jump] jump to 2(-68)
+ 71:[jump] jump to 2(-69)
+At EOF:
+ 72:[end] end
+"))
+
+(ert-deftest ccl-compile-midi ()
+ (should (equal (ccl-compile prog-midi-source) prog-midi-code)))
+
+(ert-deftest ccl-dump-midi ()
+ (with-temp-buffer
+ (ccl-dump prog-midi-code)
+ (should (equal (buffer-string) prog-midi-dump))))
diff --git a/test/lisp/international/ucs-normalize-tests.el b/test/lisp/international/ucs-normalize-tests.el
index d31aa5b4a92..97d3eae41cc 100644
--- a/test/lisp/international/ucs-normalize-tests.el
+++ b/test/lisp/international/ucs-normalize-tests.el
@@ -182,25 +182,24 @@ implementations:
(defconst ucs-normalize-tests--failing-lines-part1
(list 15131 15132 15133 15134 15135 15136 15137 15138
- 15139
- 16149 16150 16151 16152 16153 16154 16155 16156
- 16157 16158 16159 16160 16161 16162 16163 16164
- 16165 16166 16167 16168 16169 16170 16171 16172
- 16173 16174 16175 16176 16177 16178 16179 16180
- 16181 16182 16183 16184 16185 16186 16187 16188
- 16189 16190 16191 16192 16193 16194 16195 16196
- 16197 16198 16199 16200 16201 16202 16203 16204
- 16205 16206 16207 16208 16209 16210 16211 16212
- 16213 16214 16215 16216 16217 16218 16219 16220
- 16221 16222 16223 16224 16225 16226 16227 16228
- 16229 16230 16231 16232 16233 16234 16235 16236
- 16237 16238 16239 16240 16241 16242 16243 16244
- 16245 16246 16247 16248 16249 16250 16251 16252
- 16253 16254 16255 16256 16257 16258 16259 16260
- 16261 16262 16263 16264 16265 16266 16267 16268
- 16269 16270 16271 16272 16273 16274 16275 16276
- 16277 16278 16279 16280 16281 16282 16283 16284
- 16285 16286 16287 16288 16289))
+ 15139 16149 16150 16151 16152 16153 16154 16155
+ 16156 16157 16158 16159 16160 16161 16162 16163
+ 16164 16165 16166 16167 16168 16169 16170 16171
+ 16172 16173 16174 16175 16176 16177 16178 16179
+ 16180 16181 16182 16183 16184 16185 16186 16187
+ 16188 16189 16190 16191 16192 16193 16194 16195
+ 16196 16197 16198 16199 16200 16201 16202 16203
+ 16204 16205 16206 16207 16208 16209 16210 16211
+ 16212 16213 16214 16215 16216 16217 16218 16219
+ 16220 16221 16222 16223 16224 16225 16226 16227
+ 16228 16229 16230 16231 16232 16233 16234 16235
+ 16236 16237 16238 16239 16240 16241 16242 16243
+ 16244 16245 16246 16247 16248 16249 16250 16251
+ 16252 16253 16254 16255 16256 16257 16258 16259
+ 16260 16261 16262 16263 16264 16265 16266 16267
+ 16268 16269 16270 16271 16272 16273 16274 16275
+ 16276 16277 16278 16279 16280 16281 16282 16283
+ 16284 16285 16286 16287 16288 16289 16366))
;; Keep a record of failures, for consulting afterwards (the ert
;; backtrace only shows a truncated version of these lists).
@@ -258,23 +257,22 @@ implementations:
ucs-normalize-tests--failing-lines-part1)))
(defconst ucs-normalize-tests--failing-lines-part2
- (list 17482 17532 17636 18338 18340 18342 18344 18346
- 18348 18350 18352 18354 18356 18358 18360 18362
- 18364 18366 18376 18378 18380 18382 18384 18386
- 18388 18390 18392 18394 18396 18398 18400 18402
- 18404 18406 18408 18410 18412 18414 18416 18418
- 18420 18422 18424 18426 18428 18430 18432 18434
- 18436 18438 18440 18442 18444 18446 18448 18450
- 18452 18454 18456 18458 18460 18462 18464 18466
- 18468 18470 18472 18474 18476 18478 18480 18482
- 18484 18486 18488 18490 18492 18494 18496 18564
- 18566 18568 18570 18572 18574 18576 18578 18580
- 18582 18584 18586 18588 18590 18592 18594 18596
- 18598 18600 18602 18604 18606 18608 18610 18612
- 18614 18616 18618 18620 18622 18624 18626 18628
- 18630 18632 18634 18636 18638 18640 18642 18644
- 18646 18648 18650 18652 18654 18656 18658 18660
- 18662 18664 18666))
+ (list 17689 18379 18381 18383 18385 18387 18389 18391
+ 18393 18395 18397 18399 18401 18403 18405 18407
+ 18409 18411 18413 18415 18417 18419 18421 18423
+ 18425 18427 18429 18431 18433 18435 18437 18439
+ 18441 18443 18445 18447 18449 18451 18453 18455
+ 18457 18459 18461 18463 18465 18467 18469 18471
+ 18473 18475 18477 18479 18481 18483 18485 18487
+ 18489 18491 18493 18495 18497 18499 18501 18569
+ 18571 18573 18575 18577 18579 18581 18583 18585
+ 18587 18589 18591 18593 18595 18597 18599 18601
+ 18603 18605 18607 18609 18611 18613 18615 18617
+ 18619 18621 18623 18625 18627 18629 18631 18633
+ 18635 18637 18639 18641 18643 18645 18647 18649
+ 18651 18653 18655 18657 18659 18661 18663 18665
+ 18667 18669 18671 18673 18675 18677 18679 18681
+ 18683 18685 18687 18689 18691 18693))
(ert-deftest ucs-normalize-part2 ()
:tags '(:expensive-test)
diff --git a/test/lisp/json-tests.el b/test/lisp/json-tests.el
index d6098e7237e..8d1978f557c 100644
--- a/test/lisp/json-tests.el
+++ b/test/lisp/json-tests.el
@@ -325,5 +325,72 @@ Point is moved to beginning of the buffer."
(with-temp-buffer
(should-error (json-encode (current-buffer)) :type 'json-error)))
+;;; Pretty-print
+
+(defun json-tests-equal-pretty-print (original &optional expected)
+ "Abort current test if pretty-printing ORIGINAL does not yield EXPECTED.
+
+Both ORIGINAL and EXPECTED should be strings. If EXPECTED is
+nil, ORIGINAL should stay unchanged by pretty-printing."
+ (with-temp-buffer
+ (insert original)
+ (json-pretty-print-buffer)
+ (should (equal (buffer-string) (or expected original)))))
+
+(ert-deftest test-json-pretty-print-string ()
+ (json-tests-equal-pretty-print "\"\"")
+ (json-tests-equal-pretty-print "\"foo\""))
+
+(ert-deftest test-json-pretty-print-atom ()
+ (json-tests-equal-pretty-print "true")
+ (json-tests-equal-pretty-print "false")
+ (json-tests-equal-pretty-print "null"))
+
+(ert-deftest test-json-pretty-print-number ()
+ (json-tests-equal-pretty-print "123")
+ (json-tests-equal-pretty-print "0.123"))
+
+(ert-deftest test-json-pretty-print-object ()
+ ;; empty (regression test for bug#24252)
+ (json-tests-equal-pretty-print
+ "{}"
+ "{\n}")
+ ;; one pair
+ (json-tests-equal-pretty-print
+ "{\"key\":1}"
+ "{\n \"key\": 1\n}")
+ ;; two pairs
+ (json-tests-equal-pretty-print
+ "{\"key1\":1,\"key2\":2}"
+ "{\n \"key1\": 1,\n \"key2\": 2\n}")
+ ;; embedded object
+ (json-tests-equal-pretty-print
+ "{\"foo\":{\"key\":1}}"
+ "{\n \"foo\": {\n \"key\": 1\n }\n}")
+ ;; embedded array
+ (json-tests-equal-pretty-print
+ "{\"key\":[1,2]}"
+ "{\n \"key\": [\n 1,\n 2\n ]\n}"))
+
+(ert-deftest test-json-pretty-print-array ()
+ ;; empty
+ (json-tests-equal-pretty-print "[]")
+ ;; one item
+ (json-tests-equal-pretty-print
+ "[1]"
+ "[\n 1\n]")
+ ;; two items
+ (json-tests-equal-pretty-print
+ "[1,2]"
+ "[\n 1,\n 2\n]")
+ ;; embedded object
+ (json-tests-equal-pretty-print
+ "[{\"key\":1}]"
+ "[\n {\n \"key\": 1\n }\n]")
+ ;; embedded array
+ (json-tests-equal-pretty-print
+ "[[1,2]]"
+ "[\n [\n 1,\n 2\n ]\n]"))
+
(provide 'json-tests)
;;; json-tests.el ends here
diff --git a/test/lisp/jsonrpc-tests.el b/test/lisp/jsonrpc-tests.el
new file mode 100644
index 00000000000..52f709f14c1
--- /dev/null
+++ b/test/lisp/jsonrpc-tests.el
@@ -0,0 +1,254 @@
+;;; jsonrpc-tests.el --- tests for jsonrpc.el -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018-2019 Free Software Foundation, Inc.
+
+;; Author: João Távora <joaotavora@gmail.com>
+;; Maintainer: João Távora <joaotavora@gmail.com>
+;; Keywords: tests
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; About "deferred" tests, `jsonrpc--test-client' has a flag that we
+;; test in its `jsonrpc-connection-ready-p' API method. It holds any
+;; `jsonrpc-request's and `jsonrpc-async-request's explicitly passed
+;; `:deferred'. After clearing the flag, the held requests are
+;; actually sent to the server in the next opportunity (when receiving
+;; or sending something to the server).
+
+;;; Code:
+
+(require 'ert)
+(require 'jsonrpc)
+(require 'eieio)
+
+(defclass jsonrpc--test-endpoint (jsonrpc-process-connection)
+ ((scp :accessor jsonrpc--shutdown-complete-p)))
+
+(defclass jsonrpc--test-client (jsonrpc--test-endpoint)
+ ((hold-deferred :initform t :accessor jsonrpc--hold-deferred)))
+
+(defun jsonrpc--call-with-emacsrpc-fixture (fn)
+ "Do work for `jsonrpc--with-emacsrpc-fixture'. Call FN."
+ (let* (listen-server endpoint)
+ (unwind-protect
+ (progn
+ (setq listen-server
+ (make-network-process
+ :name "Emacs RPC server" :server t :host "localhost"
+ :service (if (version<= emacs-version "26.1")
+ 44444
+ ;; 26.1 can automatically find ports if
+ ;; one passes 0 here.
+ 0)
+ :log (lambda (listen-server client _message)
+ (push
+ (make-instance
+ 'jsonrpc--test-endpoint
+ :name (process-name client)
+ :process client
+ :request-dispatcher
+ (lambda (_endpoint method params)
+ (unless (memq method '(+ - * / vconcat append
+ sit-for ignore))
+ (signal 'jsonrpc-error
+ '((jsonrpc-error-message
+ . "Sorry, this isn't allowed")
+ (jsonrpc-error-code . -32601))))
+ (apply method (append params nil)))
+ :on-shutdown
+ (lambda (conn)
+ (setf (jsonrpc--shutdown-complete-p conn) t)))
+ (process-get listen-server 'handlers)))))
+ (setq endpoint
+ (make-instance
+ 'jsonrpc--test-client
+ "Emacs RPC client"
+ :process
+ (open-network-stream "JSONRPC test tcp endpoint"
+ nil "localhost"
+ (process-contact listen-server
+ :service))
+ :on-shutdown
+ (lambda (conn)
+ (setf (jsonrpc--shutdown-complete-p conn) t))))
+ (funcall fn endpoint))
+ (unwind-protect
+ (when endpoint
+ (kill-buffer (jsonrpc--events-buffer endpoint))
+ (jsonrpc-shutdown endpoint))
+ (when listen-server
+ (cl-loop do (delete-process listen-server)
+ while (progn (accept-process-output nil 0.1)
+ (process-live-p listen-server))
+ do (jsonrpc--message
+ "test listen-server is still running, waiting"))
+ (cl-loop for handler in (process-get listen-server 'handlers)
+ do (ignore-errors (jsonrpc-shutdown handler)))
+ (mapc #'kill-buffer
+ (mapcar #'jsonrpc--events-buffer
+ (process-get listen-server 'handlers))))))))
+
+(cl-defmacro jsonrpc--with-emacsrpc-fixture ((endpoint-sym) &body body)
+ `(jsonrpc--call-with-emacsrpc-fixture (lambda (,endpoint-sym) ,@body)))
+
+(ert-deftest returns-3 ()
+ "A basic test for adding two numbers in our test RPC."
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ (should (= 3 (jsonrpc-request conn '+ [1 2])))))
+
+(ert-deftest errors-with--32601 ()
+ "Errors with -32601"
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ (condition-case err
+ (progn
+ (jsonrpc-request conn 'delete-directory "~/tmp")
+ (ert-fail "A `jsonrpc-error' should have been signalled!"))
+ (jsonrpc-error
+ (should (= -32601 (cdr (assoc 'jsonrpc-error-code (cdr err)))))))))
+
+(ert-deftest signals-an--32603-JSONRPC-error ()
+ "Signals an -32603 JSONRPC error."
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ (condition-case err
+ (progn
+ (jsonrpc-request conn '+ ["a" 2])
+ (ert-fail "A `jsonrpc-error' should have been signalled!"))
+ (jsonrpc-error
+ (should (= -32603 (cdr (assoc 'jsonrpc-error-code (cdr err)))))))))
+
+(ert-deftest times-out ()
+ "Request for 3-sec sit-for with 1-sec timeout times out."
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ (should-error
+ (jsonrpc-request conn 'sit-for [3] :timeout 1))))
+
+(ert-deftest doesnt-time-out ()
+ :tags '(:expensive-test)
+ "Request for 1-sec sit-for with 2-sec timeout succeeds."
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ (jsonrpc-request conn 'sit-for [1] :timeout 2)))
+
+(ert-deftest stretching-it-but-works ()
+ "Vector of numbers or vector of vector of numbers are serialized."
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ ;; (vconcat [1 2 3] [3 4 5]) => [1 2 3 3 4 5] which can be
+ ;; serialized.
+ (should (equal
+ [1 2 3 3 4 5]
+ (jsonrpc-request conn 'vconcat [[1 2 3] [3 4 5]])))))
+
+(ert-deftest json-el-cant-serialize-this ()
+ "Can't serialize a response that is half-vector/half-list."
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ (should-error
+ ;; (append [1 2 3] [3 4 5]) => (1 2 3 . [3 4 5]), which can't be
+ ;; serialized
+ (jsonrpc-request conn 'append [[1 2 3] [3 4 5]]))))
+
+(cl-defmethod jsonrpc-connection-ready-p
+ ((conn jsonrpc--test-client) what)
+ (and (cl-call-next-method)
+ (or (not (string-match "deferred" what))
+ (not (jsonrpc--hold-deferred conn)))))
+
+(ert-deftest deferred-action-toolate ()
+ :tags '(:expensive-test)
+ "Deferred request fails because noone clears the flag."
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ (should-error
+ (jsonrpc-request conn '+ [1 2]
+ :deferred "deferred-testing" :timeout 0.5)
+ :type 'jsonrpc-error)
+ (should
+ (= 3 (jsonrpc-request conn '+ [1 2]
+ :timeout 0.5)))))
+
+(ert-deftest deferred-action-intime ()
+ :tags '(:expensive-test)
+ "Deferred request barely makes it after event clears a flag."
+ ;; Send an async request, which returns immediately. However the
+ ;; success fun which sets the flag only runs after some time.
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ (jsonrpc-async-request conn
+ 'sit-for [0.5]
+ :success-fn
+ (lambda (_result)
+ (setf (jsonrpc--hold-deferred conn) nil)))
+ ;; Now wait for an answer to this request, which should be sent as
+ ;; soon as the previous one is answered.
+ (should
+ (= 3 (jsonrpc-request conn '+ [1 2]
+ :deferred "deferred"
+ :timeout 1)))))
+
+(ert-deftest deferred-action-complex-tests ()
+ :tags '(:expensive-test)
+ "Test a more complex situation with deferred requests."
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ (let (n-deferred-1
+ n-deferred-2
+ second-deferred-went-through-p)
+ ;; This returns immediately
+ (jsonrpc-async-request
+ conn
+ 'sit-for [0.1]
+ :success-fn
+ (lambda (_result)
+ ;; this only gets runs after the "first deferred" is stashed.
+ (setq n-deferred-1
+ (hash-table-count (jsonrpc--deferred-actions conn)))))
+ (should-error
+ ;; This stashes the request and waits. It will error because
+ ;; no-one clears the "hold deferred" flag.
+ (jsonrpc-request conn 'ignore ["first deferred"]
+ :deferred "first deferred"
+ :timeout 0.5)
+ :type 'jsonrpc-error)
+ ;; The error means the deferred actions stash is now empty
+ (should (zerop (hash-table-count (jsonrpc--deferred-actions conn))))
+ ;; Again, this returns immediately.
+ (jsonrpc-async-request
+ conn
+ 'sit-for [0.1]
+ :success-fn
+ (lambda (_result)
+ ;; This gets run while "third deferred" below is waiting for
+ ;; a reply. Notice that we clear the flag in time here.
+ (setq n-deferred-2 (hash-table-count (jsonrpc--deferred-actions conn)))
+ (setf (jsonrpc--hold-deferred conn) nil)))
+ ;; This again stashes a request and returns immediately.
+ (jsonrpc-async-request conn 'ignore ["second deferred"]
+ :deferred "second deferred"
+ :timeout 1
+ :success-fn
+ (lambda (_result)
+ (setq second-deferred-went-through-p t)))
+ ;; And this also stashes a request, but waits. Eventually the
+ ;; flag is cleared in time and both requests go through.
+ (jsonrpc-request conn 'ignore ["third deferred"]
+ :deferred "third deferred"
+ :timeout 1)
+ ;; Wait another 0.5 secs just in case the success handlers of
+ ;; one of these last two requests didn't quite have a chance to
+ ;; run (Emacs 25.2 apparentely needs this).
+ (accept-process-output nil 0.5)
+ (should second-deferred-went-through-p)
+ (should (eq 1 n-deferred-1))
+ (should (eq 2 n-deferred-2))
+ (should (eq 0 (hash-table-count (jsonrpc--deferred-actions conn)))))))
+
+(provide 'jsonrpc-tests)
+;;; jsonrpc-tests.el ends here
diff --git a/test/lisp/ls-lisp-tests.el b/test/lisp/ls-lisp-tests.el
index 2c1e46e5c5d..e97c0fcd004 100644
--- a/test/lisp/ls-lisp-tests.el
+++ b/test/lisp/ls-lisp-tests.el
@@ -26,6 +26,7 @@
;;; Code:
(require 'ert)
(require 'ls-lisp)
+(require 'dired)
(ert-deftest ls-lisp-unload ()
"Test for https://debbugs.gnu.org/xxxxx ."
diff --git a/test/lisp/mail/rmail-tests.el b/test/lisp/mail/rmail-tests.el
index 00f4583335b..3a0fdbc2614 100644
--- a/test/lisp/mail/rmail-tests.el
+++ b/test/lisp/mail/rmail-tests.el
@@ -23,7 +23,7 @@
(ert-deftest rmail-autoload ()
- "Tests to see whether reftex-auc has been autoloaded"
+ "Test that `rmail-edit-current-message' has been autoloaded."
(should
(fboundp 'rmail-edit-current-message))
(should
diff --git a/test/lisp/minibuffer-tests.el b/test/lisp/minibuffer-tests.el
index 77bfea93716..35df7cc17f1 100644
--- a/test/lisp/minibuffer-tests.el
+++ b/test/lisp/minibuffer-tests.el
@@ -74,5 +74,11 @@
'completion-table-with-predicate
full-collection no-A nil))))))
+(ert-deftest completion-table-subvert-test ()
+ (let* ((origtable '("A-hello" "A-there"))
+ (subvtable (completion-table-subvert origtable "B" "A")))
+ (should (equal (try-completion "B-hel" subvtable)
+ "B-hello"))))
+
(provide 'completion-tests)
;;; completion-tests.el ends here
diff --git a/test/lisp/mouse-tests.el b/test/lisp/mouse-tests.el
index 68181b3b8e7..aa7b14545b9 100644
--- a/test/lisp/mouse-tests.el
+++ b/test/lisp/mouse-tests.el
@@ -27,24 +27,22 @@
(ert-deftest bug23288-use-return-value ()
"If `mouse-on-link-p' returns a string, its first character is used."
- (cl-letf ((last-input-event '(down-mouse-1 nil 1))
- (unread-command-events '((mouse-1 nil 1)))
+ (cl-letf ((unread-command-events '((down-mouse-1 nil 1) (mouse-1 nil 1)))
(mouse-1-click-follows-link t)
(mouse-1-click-in-non-selected-windows t)
((symbol-function 'mouse-on-link-p) (lambda (_pos) "abc")))
- (should-not (mouse--down-1-maybe-follows-link))
- (should (equal unread-command-events '(?a)))))
+ (should (eq 'down-mouse-1 (car-safe (aref (read-key-sequence "") 0))))
+ (should (eq ?a (aref (read-key-sequence "") 0)))))
(ert-deftest bug23288-translate-to-mouse-2 ()
"If `mouse-on-link-p' doesn't return a string or vector,
translate `mouse-1' events into `mouse-2' events."
- (cl-letf ((last-input-event '(down-mouse-1 nil 1))
- (unread-command-events '((mouse-1 nil 1)))
+ (cl-letf ((unread-command-events '((down-mouse-1 nil 1) (mouse-1 nil 1)))
(mouse-1-click-follows-link t)
(mouse-1-click-in-non-selected-windows t)
((symbol-function 'mouse-on-link-p) (lambda (_pos) t)))
- (should-not (mouse--down-1-maybe-follows-link))
- (should (equal unread-command-events '((mouse-2 nil 1))))))
+ (should (eq 'down-mouse-1 (car-safe (aref (read-key-sequence "") 0))))
+ (should (eq 'mouse-2 (car-safe (aref (read-key-sequence "") 0))))))
(ert-deftest bug26816-mouse-frame-movement ()
"Mouse moves relative to frame."
diff --git a/test/lisp/net/gnutls-tests.el b/test/lisp/net/gnutls-tests.el
index b74594fb295..ea8dd7eb668 100644
--- a/test/lisp/net/gnutls-tests.el
+++ b/test/lisp/net/gnutls-tests.el
@@ -26,7 +26,7 @@
;;; Code:
(require 'ert)
-(require 'cl)
+(require 'cl-lib)
(require 'gnutls)
(require 'hex-util)
@@ -46,22 +46,22 @@
(defvar gnutls-tests-tested-macs
(when (gnutls-available-p)
- (remove-duplicates
- (append (mapcar 'cdr gnutls-tests-internal-macs-upcased)
- (mapcar 'car (gnutls-macs))))))
+ (cl-remove-duplicates
+ (append (mapcar #'cdr gnutls-tests-internal-macs-upcased)
+ (mapcar #'car (gnutls-macs))))))
(defvar gnutls-tests-tested-digests
(when (gnutls-available-p)
- (remove-duplicates
- (append (mapcar 'cdr gnutls-tests-internal-macs-upcased)
- (mapcar 'car (gnutls-digests))))))
+ (cl-remove-duplicates
+ (append (mapcar #'cdr gnutls-tests-internal-macs-upcased)
+ (mapcar #'car (gnutls-digests))))))
(defvar gnutls-tests-tested-ciphers
(when (gnutls-available-p)
- (remove-duplicates
- ; these cause FPEs or SEGVs
- (remove-if (lambda (e) (memq e '(ARCFOUR-128)))
- (mapcar 'car (gnutls-ciphers))))))
+ (cl-remove-duplicates
+ ;; these cause FPEs or SEGVs
+ (cl-remove-if (lambda (e) (memq e '(ARCFOUR-128)))
+ (mapcar #'car (gnutls-ciphers))))))
(defvar gnutls-tests-mondo-strings
(list
@@ -154,7 +154,7 @@
("0cc175b9c0f1b6a831c399e269772661" "a" MD5)
("a9993e364706816aba3e25717850c26c9cd0d89d" "abc" SHA1)
("a9993e364706816aba3e25717850c26c9cd0d89d" "abc" "SHA1"))) ; check string ID for digest
- (destructuring-bind (hash input mac) test
+ (pcase-let ((`(,hash ,input ,mac) test))
(let ((plist (cdr (assq mac macs)))
result resultb)
(gnutls-tests-message "%s %S" mac plist)
@@ -178,7 +178,7 @@
("81568ba71fa2c5f33cc84bf362466988f98eba3735479100b4e8908acad87ac4" "more and more data goes into a file to exceed the buffer size" "very long key goes here to exceed the key size" SHA256)
("4bc830005783a73b8112f4bd5f4aa5f92e05b51e9b55c0cd6f9a7bee48371def" "more and more data goes into a file to exceed the buffer size" "" "SHA256") ; check string ID for HMAC
("4bc830005783a73b8112f4bd5f4aa5f92e05b51e9b55c0cd6f9a7bee48371def" "more and more data goes into a file to exceed the buffer size" "" SHA256)))
- (destructuring-bind (hash input key mac) test
+ (pcase-let ((`(,hash ,input ,key ,mac) test))
(let ((plist (cdr (assq mac macs)))
result)
(gnutls-tests-message "%s %S" mac plist)
@@ -214,7 +214,7 @@
(let ((keys '("mykey" "mykey2"))
(inputs gnutls-tests-mondo-strings)
(ivs '("" "-abc123-" "init" "ini2"))
- (ciphers (remove-if
+ (ciphers (cl-remove-if
(lambda (c) (plist-get (cdr (assq c (gnutls-ciphers)))
:cipher-aead-capable))
gnutls-tests-tested-ciphers)))
@@ -252,7 +252,7 @@
"auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data "
"AUTH data and more data to go over the block limit!"
"AUTH data and more data to go over the block limit"))
- (ciphers (remove-if
+ (ciphers (cl-remove-if
(lambda (c) (or (null (plist-get (cdr (assq c (gnutls-ciphers)))
:cipher-aead-capable))))
gnutls-tests-tested-ciphers))
diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el
index 29b92da3de0..b85746a3123 100644
--- a/test/lisp/net/network-stream-tests.el
+++ b/test/lisp/net/network-stream-tests.el
@@ -25,6 +25,10 @@
;;; Code:
(require 'gnutls)
+(require 'network-stream)
+;; The require above is needed for 'open-network-stream' to work, but
+;; it pulls in nsm, which then makes the :nowait t' tests fail unless
+;; we disable the nsm, which we do by binding 'network-security-level'
(ert-deftest make-local-unix-server ()
(skip-unless (featurep 'make-network-process '(:family local)))
@@ -67,12 +71,45 @@
(= (aref (process-contact server :local) 4) 57869)))
(delete-process server)))
-(defun make-server (host)
+(ert-deftest make-ipv6-tcp-server-with-unspecified-port ()
+ (skip-unless (featurep 'make-network-process '(:family ipv6)))
+ (let ((server
+ (ignore-errors
+ (make-network-process
+ :name "server"
+ :server t
+ :noquery t
+ :family 'ipv6
+ :service t
+ :host 'local))))
+ (skip-unless server)
+ (should (and (arrayp (process-contact server :local))
+ (numberp (aref (process-contact server :local) 8))
+ (> (aref (process-contact server :local) 8) 0)))
+ (delete-process server)))
+
+(ert-deftest make-ipv6-tcp-server-with-specified-port ()
+ (skip-unless (featurep 'make-network-process '(:family ipv6)))
+ (let ((server
+ (ignore-errors
+ (make-network-process
+ :name "server"
+ :server t
+ :noquery t
+ :family 'ipv6
+ :service 57870
+ :host 'local))))
+ (skip-unless server)
+ (should (and (arrayp (process-contact server :local))
+ (= (aref (process-contact server :local) 8) 57870)))
+ (delete-process server)))
+
+(defun make-server (host &optional family)
(make-network-process
:name "server"
:server t
:noquery t
- :family 'ipv4
+ :family (or family 'ipv4)
:coding 'raw-text-unix
:buffer (get-buffer-create "*server*")
:service t
@@ -125,6 +162,36 @@
(should (equal (buffer-string) "foo\n")))
(delete-process server)))
+(ert-deftest echo-server-with-local-ipv4 ()
+ (let* ((server (make-server 'local 'ipv4))
+ (port (aref (process-contact server :local) 4))
+ (proc (make-network-process :name "foo"
+ :buffer (generate-new-buffer "*foo*")
+ :host 'local
+ :family 'ipv4
+ :service port)))
+ (with-current-buffer (process-buffer proc)
+ (process-send-string proc "echo foo")
+ (sleep-for 0.1)
+ (should (equal (buffer-string) "foo\n")))
+ (delete-process server)))
+
+(ert-deftest echo-server-with-local-ipv6 ()
+ (skip-unless (featurep 'make-network-process '(:family ipv6)))
+ (let ((server (ignore-errors (make-server 'local 'ipv6))))
+ (skip-unless server)
+ (let* ((port (aref (process-contact server :local) 8))
+ (proc (make-network-process :name "foo"
+ :buffer (generate-new-buffer "*foo*")
+ :host 'local
+ :family 'ipv6
+ :service port)))
+ (with-current-buffer (process-buffer proc)
+ (process-send-string proc "echo foo")
+ (sleep-for 0.1)
+ (should (equal (buffer-string) "foo\n")))
+ (delete-process server))))
+
(ert-deftest echo-server-with-ip ()
(let* ((server (make-server 'local))
(port (aref (process-contact server :local) 4))
@@ -214,6 +281,7 @@
(skip-unless (gnutls-available-p))
(let ((server (make-tls-server 44331))
(times 0)
+ (network-security-level 'low)
proc status)
(unwind-protect
(progn
@@ -257,6 +325,7 @@
(skip-unless (featurep 'make-network-process '(:family ipv6)))
(let ((server (make-tls-server 44333))
(times 0)
+ (network-security-level 'low)
proc status)
(unwind-protect
(progn
@@ -294,4 +363,365 @@
(setq issuer (split-string issuer ","))
(should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
+(ert-deftest open-network-stream-tls-wait ()
+ (skip-unless (executable-find "gnutls-serv"))
+ (skip-unless (gnutls-available-p))
+ (let ((server (make-tls-server 44334))
+ (times 0)
+ (network-security-level 'low)
+ proc status)
+ (unwind-protect
+ (progn
+ (sleep-for 1)
+ (with-current-buffer (process-buffer server)
+ (message "gnutls-serv: %s" (buffer-string)))
+
+ ;; It takes a while for gnutls-serv to start.
+ (while (and (null (ignore-errors
+ (setq proc (open-network-stream
+ "bar"
+ (generate-new-buffer "*foo*")
+ "localhost"
+ 44334
+ :type 'tls
+ :nowait nil))))
+ (< (setq times (1+ times)) 10))
+ (sit-for 0.1))
+ (should proc)
+ (skip-unless (not (eq (process-status proc) 'connect))))
+ (if (process-live-p server) (delete-process server)))
+ (setq status (gnutls-peer-status proc))
+ (should (consp status))
+ (delete-process proc)
+ ;; This sleep-for is needed for the native MS-Windows build. If
+ ;; it is removed, the next test mysteriously fails because the
+ ;; initial part of the echo is not received.
+ (sleep-for 0.1)
+ (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
+ (should (stringp issuer))
+ (setq issuer (split-string issuer ","))
+ (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
+
+(ert-deftest open-network-stream-tls-nowait ()
+ (skip-unless (executable-find "gnutls-serv"))
+ (skip-unless (gnutls-available-p))
+ (let ((server (make-tls-server 44335))
+ (times 0)
+ (network-security-level 'low)
+ proc status)
+ (unwind-protect
+ (progn
+ (sleep-for 1)
+ (with-current-buffer (process-buffer server)
+ (message "gnutls-serv: %s" (buffer-string)))
+
+ ;; It takes a while for gnutls-serv to start.
+ (while (and (null (ignore-errors
+ (setq proc (open-network-stream
+ "bar"
+ (generate-new-buffer "*foo*")
+ "localhost"
+ 44335
+ :type 'tls
+ :nowait t))))
+ (< (setq times (1+ times)) 10))
+ (sit-for 0.1))
+ (should proc)
+ (setq times 0)
+ (while (and (eq (process-status proc) 'connect)
+ (< (setq times (1+ times)) 10))
+ (sit-for 0.1))
+ (skip-unless (not (eq (process-status proc) 'connect))))
+ (if (process-live-p server) (delete-process server)))
+ (setq status (gnutls-peer-status proc))
+ (should (consp status))
+ (delete-process proc)
+ ;; This sleep-for is needed for the native MS-Windows build. If
+ ;; it is removed, the next test mysteriously fails because the
+ ;; initial part of the echo is not received.
+ (sleep-for 0.1)
+ (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
+ (should (stringp issuer))
+ (setq issuer (split-string issuer ","))
+ (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
+
+(ert-deftest open-network-stream-tls ()
+ (skip-unless (executable-find "gnutls-serv"))
+ (skip-unless (gnutls-available-p))
+ (let ((server (make-tls-server 44336))
+ (times 0)
+ (network-security-level 'low)
+ proc status)
+ (unwind-protect
+ (progn
+ (sleep-for 1)
+ (with-current-buffer (process-buffer server)
+ (message "gnutls-serv: %s" (buffer-string)))
+
+ ;; It takes a while for gnutls-serv to start.
+ (while (and (null (ignore-errors
+ (setq proc (open-network-stream
+ "bar"
+ (generate-new-buffer "*foo*")
+ "localhost"
+ 44336
+ :type 'tls))))
+ (< (setq times (1+ times)) 10))
+ (sit-for 0.1))
+ (should proc)
+ (skip-unless (not (eq (process-status proc) 'connect))))
+ (if (process-live-p server) (delete-process server)))
+ (setq status (gnutls-peer-status proc))
+ (should (consp status))
+ (delete-process proc)
+ ;; This sleep-for is needed for the native MS-Windows build. If
+ ;; it is removed, the next test mysteriously fails because the
+ ;; initial part of the echo is not received.
+ (sleep-for 0.1)
+ (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
+ (should (stringp issuer))
+ (setq issuer (split-string issuer ","))
+ (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
+
+(ert-deftest open-network-stream-tls-nocert ()
+ (skip-unless (executable-find "gnutls-serv"))
+ (skip-unless (gnutls-available-p))
+ (let ((server (make-tls-server 44337))
+ (times 0)
+ (network-security-level 'low)
+ proc status)
+ (unwind-protect
+ (progn
+ (sleep-for 1)
+ (with-current-buffer (process-buffer server)
+ (message "gnutls-serv: %s" (buffer-string)))
+
+ ;; It takes a while for gnutls-serv to start.
+ (while (and (null (ignore-errors
+ (setq proc (open-network-stream
+ "bar"
+ (generate-new-buffer "*foo*")
+ "localhost"
+ 44337
+ :type 'tls
+ :client-certificate nil))))
+ (< (setq times (1+ times)) 10))
+ (sit-for 0.1))
+ (should proc)
+ (skip-unless (not (eq (process-status proc) 'connect))))
+ (if (process-live-p server) (delete-process server)))
+ (setq status (gnutls-peer-status proc))
+ (should (consp status))
+ (delete-process proc)
+ ;; This sleep-for is needed for the native MS-Windows build. If
+ ;; it is removed, the next test mysteriously fails because the
+ ;; initial part of the echo is not received.
+ (sleep-for 0.1)
+ (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
+ (should (stringp issuer))
+ (setq issuer (split-string issuer ","))
+ (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
+
+(ert-deftest open-gnutls-stream-new-api-default ()
+ (skip-unless (executable-find "gnutls-serv"))
+ (skip-unless (gnutls-available-p))
+ (let ((server (make-tls-server 44665))
+ (times 0)
+ proc status)
+ (unwind-protect
+ (progn
+ (sleep-for 1)
+ (with-current-buffer (process-buffer server)
+ (message "gnutls-serv: %s" (buffer-string)))
+
+ ;; It takes a while for gnutls-serv to start.
+ (while (and (null (ignore-errors
+ (setq proc (open-gnutls-stream
+ "bar"
+ (generate-new-buffer "*foo*")
+ "localhost"
+ 44665))))
+ (< (setq times (1+ times)) 10))
+ (sit-for 0.1))
+ (should proc)
+ (if (process-live-p server) (delete-process server)))
+ (setq status (gnutls-peer-status proc))
+ (should (consp status))
+ (delete-process proc)
+ ;; This sleep-for is needed for the native MS-Windows build. If
+ ;; it is removed, the next test mysteriously fails because the
+ ;; initial part of the echo is not received.
+ (sleep-for 0.1)
+ (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
+ (should (stringp issuer))
+ (setq issuer (split-string issuer ","))
+ (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC"))))))
+
+(ert-deftest open-gnutls-stream-new-api-wait ()
+ (skip-unless (executable-find "gnutls-serv"))
+ (skip-unless (gnutls-available-p))
+ (let ((server (make-tls-server 44666))
+ (times 0)
+ proc status)
+ (unwind-protect
+ (progn
+ (sleep-for 1)
+ (with-current-buffer (process-buffer server)
+ (message "gnutls-serv: %s" (buffer-string)))
+
+ ;; It takes a while for gnutls-serv to start.
+ (while (and (null (ignore-errors
+ (setq proc (open-gnutls-stream
+ "bar"
+ (generate-new-buffer "*foo*")
+ "localhost"
+ 44666
+ (list :nowait nil)))))
+ (< (setq times (1+ times)) 10))
+ (sit-for 0.1))
+ (should proc)
+ (if (process-live-p server) (delete-process server)))
+ (setq status (gnutls-peer-status proc))
+ (should (consp status))
+ (delete-process proc)
+ ;; This sleep-for is needed for the native MS-Windows build. If
+ ;; it is removed, the next test mysteriously fails because the
+ ;; initial part of the echo is not received.
+ (sleep-for 0.1)
+ (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
+ (should (stringp issuer))
+ (setq issuer (split-string issuer ","))
+ (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC"))))))
+
+(ert-deftest open-gnutls-stream-old-api-wait ()
+ (skip-unless (executable-find "gnutls-serv"))
+ (skip-unless (gnutls-available-p))
+ (let ((server (make-tls-server 44667))
+ (times 0)
+ nowait
+ proc status)
+ (unwind-protect
+ (progn
+ (sleep-for 1)
+ (with-current-buffer (process-buffer server)
+ (message "gnutls-serv: %s" (buffer-string)))
+
+ ;; It takes a while for gnutls-serv to start.
+ (while (and (null (ignore-errors
+ (setq proc (open-gnutls-stream
+ "bar"
+ (generate-new-buffer "*foo*")
+ "localhost"
+ 44667
+ nowait))))
+ (< (setq times (1+ times)) 10))
+ (sit-for 0.1))
+ (should proc)
+ (if (process-live-p server) (delete-process server)))
+ (setq status (gnutls-peer-status proc))
+ (should (consp status))
+ (delete-process proc)
+ ;; This sleep-for is needed for the native MS-Windows build. If
+ ;; it is removed, the next test mysteriously fails because the
+ ;; initial part of the echo is not received.
+ (sleep-for 0.1)
+ (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
+ (should (stringp issuer))
+ (setq issuer (split-string issuer ","))
+ (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC"))))))
+
+(ert-deftest open-gnutls-stream-new-api-nowait ()
+ (skip-unless (executable-find "gnutls-serv"))
+ (skip-unless (gnutls-available-p))
+ (let ((server (make-tls-server 44668))
+ (times 0)
+ (network-security-level 'low)
+ proc status)
+ (unwind-protect
+ (progn
+ (sleep-for 1)
+ (with-current-buffer (process-buffer server)
+ (message "gnutls-serv: %s" (buffer-string)))
+
+ ;; It takes a while for gnutls-serv to start.
+ (while (and (null (ignore-errors
+ (setq proc (open-gnutls-stream
+ "bar"
+ (generate-new-buffer "*foo*")
+ "localhost"
+ 44668
+ (list :nowait t)))))
+ (< (setq times (1+ times)) 10))
+ (sit-for 0.1))
+ (should proc)
+ (setq times 0)
+ (while (and (eq (process-status proc) 'connect)
+ (< (setq times (1+ times)) 10))
+ (sit-for 0.1))
+ (skip-unless (not (eq (process-status proc) 'connect))))
+ (if (process-live-p server) (delete-process server)))
+ (setq status (gnutls-peer-status proc))
+ (should (consp status))
+ (delete-process proc)
+ (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
+ (should (stringp issuer))
+ (setq issuer (split-string issuer ","))
+ (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
+
+(ert-deftest open-gnutls-stream-old-api-nowait ()
+ (skip-unless (executable-find "gnutls-serv"))
+ (skip-unless (gnutls-available-p))
+ (let ((server (make-tls-server 44669))
+ (times 0)
+ (network-security-level 'low)
+ (nowait t)
+ proc status)
+ (unwind-protect
+ (progn
+ (sleep-for 1)
+ (with-current-buffer (process-buffer server)
+ (message "gnutls-serv: %s" (buffer-string)))
+
+ ;; It takes a while for gnutls-serv to start.
+ (while (and (null (ignore-errors
+ (setq proc (open-gnutls-stream
+ "bar"
+ (generate-new-buffer "*foo*")
+ "localhost"
+ 44669
+ nowait))))
+ (< (setq times (1+ times)) 10))
+ (sit-for 0.1))
+ (should proc)
+ (setq times 0)
+ (while (and (eq (process-status proc) 'connect)
+ (< (setq times (1+ times)) 10))
+ (sit-for 0.1))
+ (skip-unless (not (eq (process-status proc) 'connect))))
+ (if (process-live-p server) (delete-process server)))
+ (setq status (gnutls-peer-status proc))
+ (should (consp status))
+ (delete-process proc)
+ (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
+ (should (stringp issuer))
+ (setq issuer (split-string issuer ","))
+ (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
+
+(ert-deftest open-gnutls-stream-new-api-errors ()
+ (skip-unless (gnutls-available-p))
+ (should-error
+ (open-gnutls-stream
+ "bar"
+ (generate-new-buffer "*foo*")
+ "localhost"
+ 44777
+ (list t)))
+ (should-error
+ (open-gnutls-stream
+ "bar"
+ (generate-new-buffer "*foo*")
+ "localhost"
+ 44777
+ (vector :nowait t))))
+
;;; network-stream-tests.el ends here
diff --git a/test/lisp/net/secrets-tests.el b/test/lisp/net/secrets-tests.el
new file mode 100644
index 00000000000..c565eba5679
--- /dev/null
+++ b/test/lisp/net/secrets-tests.el
@@ -0,0 +1,268 @@
+;;; secrets-tests.el --- Tests of Secret Service API
+
+;; Copyright (C) 2018-2019 Free Software Foundation, Inc.
+
+;; Author: Michael Albinus <michael.albinus@gmx.de>
+
+;; 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 `https://www.gnu.org/licenses/'.
+
+;;; Code:
+
+(require 'ert)
+(require 'secrets)
+(require 'notifications)
+
+;; We do not want chatty messages.
+(setq secrets-debug nil)
+
+(ert-deftest secrets-test00-availability ()
+ "Test availability of Secret Service API."
+ :expected-result (if secrets-enabled :passed :failed)
+ (should secrets-enabled)
+ (should (dbus-ping :session secrets-service))
+
+ ;; Exit.
+ (secrets--test-close-all-sessions))
+
+(defun secrets--test-get-all-sessions ()
+ "Return all object paths for existing secrets sessions."
+ (let ((session-path (concat secrets-path "/session")))
+ (delete
+ session-path
+ (dbus-introspect-get-all-nodes :session secrets-service session-path))))
+
+(defun secrets--test-close-all-sessions ()
+ "Close all secrets sessions which are bound to this Emacs."
+ (secrets-close-session)
+ ;; We loop over all other sessions. If a session does not belong to
+ ;; us, a `dbus-error' is fired, which we ignore.
+ (dolist (path (secrets--test-get-all-sessions))
+ (dbus-ignore-errors
+ (dbus-call-method
+ :session secrets-service path secrets-interface-session "Close"))))
+
+(defun secrets--test-delete-all-session-items ()
+ "Delete all items of collection \"session\" bound to this Emacs."
+ (dolist (item (secrets-list-items "session"))
+ (secrets-delete-item "session" item)))
+
+(ert-deftest secrets-test01-sessions ()
+ "Test opening / closing a secrets session."
+ (skip-unless secrets-enabled)
+ (skip-unless (secrets-empty-path secrets-session-path))
+
+ (unwind-protect
+ (progn
+ ;; Simple opening / closing of a session.
+ (should (secrets-open-session))
+ (should-not (secrets-empty-path secrets-session-path))
+ (should (secrets-close-session))
+ (should (secrets-empty-path secrets-session-path))
+
+ ;; Reopening a new session.
+ (should (string-equal (secrets-open-session) (secrets-open-session)))
+ (should (string-equal secrets-session-path (secrets-open-session)))
+ (should-not
+ (string-equal (secrets-open-session) (secrets-open-session 'reopen)))
+ (should-not
+ (string-equal secrets-session-path (secrets-open-session 'reopen))))
+
+ ;; Exit.
+ (should (secrets-close-session))
+ (secrets--test-close-all-sessions)))
+
+(ert-deftest secrets-test02-collections ()
+ "Test creation / deletion a secrets collections."
+ (skip-unless secrets-enabled)
+ (skip-unless (secrets-empty-path secrets-session-path))
+
+ (unwind-protect
+ (progn
+ (should (secrets-open-session))
+ (should (member "session" (secrets-list-collections)))
+
+ ;; Create a random collection. This asks for a password
+ ;; outside our control, so we make it in the interactive case
+ ;; only.
+ (unless noninteractive
+ (let ((collection (md5 (concat (prin1-to-string process-environment)
+ (current-time-string))))
+ (alias (secrets-get-alias "default")))
+ (notifications-notify
+ :title (symbol-name (ert-test-name (ert-running-test)))
+ :body "Please enter the password \"secret\" twice")
+ ;; The optional argument ALIAS does not seem to work.
+ (should (secrets-create-collection collection))
+ (should (member collection (secrets-list-collections)))
+
+ ;; We reset the alias. The temporary collection "session"
+ ;; is not accepted.
+ (secrets-set-alias collection "default")
+ (should (string-equal (secrets-get-alias "default") collection))
+
+ ;; Delete alias.
+ (secrets-delete-alias "default")
+ (should-not (secrets-get-alias "default"))
+
+ ;; Lock / unlock the collection.
+ (secrets-lock-collection collection)
+ (should
+ (secrets-get-collection-property
+ (secrets-collection-path collection) "Locked"))
+ (notifications-notify
+ :title (symbol-name (ert-test-name (ert-running-test)))
+ :body "Please enter the password \"secret\"")
+ (secrets-unlock-collection collection)
+ (should-not
+ (secrets-get-collection-property
+ (secrets-collection-path collection) "Locked"))
+
+ ;; Delete the collection. The alias disappears as well.
+ (secrets-set-alias collection "default")
+ (secrets-delete-collection collection)
+ (should-not (secrets-get-alias "default"))
+
+ ;; Reset alias.
+ (when alias
+ (secrets-set-alias alias "default")
+ (should (string-equal (secrets-get-alias "default") alias))))))
+
+ ;; Exit.
+ (should (secrets-close-session))
+ (secrets--test-close-all-sessions)))
+
+(ert-deftest secrets-test03-items ()
+ "Test creation / deletion a secret item."
+ (skip-unless secrets-enabled)
+ (skip-unless (secrets-empty-path secrets-session-path))
+
+ (unwind-protect
+ (let (item-path)
+ (should (secrets-open-session))
+
+ ;; Cleanup. There could be items in the "session" collection.
+ (secrets--test-delete-all-session-items)
+
+ ;; There shall be no items in the "session" collection.
+ (should-not (secrets-list-items "session"))
+
+ ;; Create a new item.
+ (should (setq item-path (secrets-create-item "session" "foo" "secret")))
+ (dolist (item `("foo" ,item-path))
+ (should (string-equal (secrets-get-secret "session" item) "secret")))
+
+ ;; Create another item with same label.
+ (should (secrets-create-item "session" "foo" "geheim"))
+ (should (equal (secrets-list-items "session") '("foo" "foo")))
+
+ ;; Create an item with attributes.
+ (should
+ (setq item-path
+ (secrets-create-item
+ "session" "bar" "secret"
+ :method "sudo" :user "joe" :host "remote-host")))
+ (dolist (item `("bar" ,item-path))
+ (should
+ (string-equal (secrets-get-attribute "session" item :method) "sudo"))
+ ;; The attributes are collected in reverse order.
+ ;; :xdg:schema is added silently.
+ (should
+ (equal
+ (secrets-get-attributes "session" item)
+ '((:xdg:schema . "org.freedesktop.Secret.Generic")
+ (:host . "remote-host") (:user . "joe") (:method . "sudo")))))
+
+ ;; Create an item with another schema.
+ (should
+ (setq item-path
+ (secrets-create-item
+ "session" "baz" "secret" :xdg:schema "org.gnu.Emacs.foo")))
+ (dolist (item `("baz" ,item-path))
+ (should
+ (equal
+ (secrets-get-attributes "session" item)
+ '((:xdg:schema . "org.gnu.Emacs.foo")))))
+
+ ;; Delete them.
+ (dolist (item (secrets-list-items "session"))
+ (secrets-delete-item "session" item))
+ (should-not (secrets-list-items "session")))
+
+ ;; Exit.
+ (secrets--test-delete-all-session-items)
+ (should (secrets-close-session))
+ (secrets--test-close-all-sessions)))
+
+(ert-deftest secrets-test04-search ()
+ "Test searching of secret items."
+ (skip-unless secrets-enabled)
+ (skip-unless (secrets-empty-path secrets-session-path))
+
+ (unwind-protect
+ (progn
+ (should (secrets-open-session))
+
+ ;; Cleanup. There could be items in the "session" collection.
+ (secrets--test-delete-all-session-items)
+
+ ;; There shall be no items in the "session" collection.
+ (should-not (secrets-list-items "session"))
+
+ ;; Create some items.
+ (should
+ (secrets-create-item
+ "session" "foo" "secret"
+ :method "sudo" :user "joe" :host "remote-host"))
+ (should
+ (secrets-create-item
+ "session" "bar" "secret"
+ :method "sudo" :user "smith" :host "remote-host"))
+ (should
+ (secrets-create-item
+ "session" "baz" "secret"
+ :method "ssh" :user "joe" :host "other-host"))
+
+ ;; Search the items. `secrets-search-items' uses
+ ;; `secrets-search-item-paths' internally, it is sufficient to
+ ;; test only one of them.
+ (should-not (secrets-search-item-paths "session" :user "john"))
+ (should-not (secrets-search-items "session" :user "john"))
+ (should-not
+ (secrets-search-items "session" :xdg:schema "org.gnu.Emacs.foo"))
+ (should
+ (equal
+ (sort (secrets-search-items "session" :user "joe") 'string-lessp)
+ '("baz" "foo")))
+ (should
+ (equal
+ (secrets-search-items "session":method "sudo" :user "joe") '("foo")))
+ (should
+ (equal
+ (sort (secrets-search-items "session") 'string-lessp)
+ '("bar" "baz" "foo"))))
+
+ ;; Exit.
+ (secrets--test-delete-all-session-items)
+ (should (secrets-close-session))
+ (secrets--test-close-all-sessions)))
+
+(defun secrets-test-all (&optional interactive)
+ "Run all tests for \\[secrets]."
+ (interactive "p")
+ (funcall
+ (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch)
+ "^secrets"))
+
+(provide 'secrets-tests)
+;;; secrets-tests.el ends here
diff --git a/test/lisp/net/tramp-archive-resources/foo.iso/foo b/test/lisp/net/tramp-archive-resources/foo.iso/foo
new file mode 100644
index 00000000000..257cc5642cb
--- /dev/null
+++ b/test/lisp/net/tramp-archive-resources/foo.iso/foo
@@ -0,0 +1 @@
+foo
diff --git a/test/lisp/net/tramp-archive-resources/foo.tar.gz b/test/lisp/net/tramp-archive-resources/foo.tar.gz
new file mode 100644
index 00000000000..0d2e9878dd7
--- /dev/null
+++ b/test/lisp/net/tramp-archive-resources/foo.tar.gz
Binary files differ
diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el
new file mode 100644
index 00000000000..454279e435e
--- /dev/null
+++ b/test/lisp/net/tramp-archive-tests.el
@@ -0,0 +1,965 @@
+;;; tramp-archive-tests.el --- Tests of file archive access -*- lexical-binding:t -*-
+
+;; Copyright (C) 2017-2019 Free Software Foundation, Inc.
+
+;; Author: Michael Albinus <michael.albinus@gmx.de>
+
+;; 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 `https://www.gnu.org/licenses/'.
+
+;;; Code:
+
+;; The `tramp-archive-testnn-*' tests correspond to the respective
+;; tests in tramp-tests.el.
+
+(require 'ert)
+(require 'tramp-archive)
+(defvar tramp-copy-size-limit)
+(defvar tramp-persistency-file-name)
+
+(defconst tramp-archive-test-resource-directory
+ (let ((default-directory
+ (if load-in-progress
+ (file-name-directory load-file-name)
+ default-directory)))
+ (cond
+ ((file-accessible-directory-p (expand-file-name "resources"))
+ (expand-file-name "resources"))
+ ((file-accessible-directory-p (expand-file-name "tramp-archive-resources"))
+ (expand-file-name "tramp-archive-resources"))))
+ "The resources directory test files are located in.")
+
+(defconst tramp-archive-test-file-archive
+ (file-truename
+ (expand-file-name "foo.tar.gz" tramp-archive-test-resource-directory))
+ "The test file archive.")
+
+(defconst tramp-archive-test-archive
+ (file-name-as-directory tramp-archive-test-file-archive)
+ "The test archive.")
+
+(defconst tramp-archive-test-directory
+ (file-truename
+ (expand-file-name "foo.iso" tramp-archive-test-resource-directory))
+ "A directory file name, which looks like an archive.")
+
+(setq password-cache-expiry nil
+ tramp-verbose 0
+ tramp-cache-read-persistent-data t ;; For auth-sources.
+ tramp-copy-size-limit nil
+ tramp-message-show-message nil
+ tramp-persistency-file-name nil)
+
+(defun tramp-archive--test-make-temp-name ()
+ "Return a temporary file name for test.
+The temporary file is not created."
+ (expand-file-name
+ (make-temp-name "tramp-archive-test") temporary-file-directory))
+
+(defun tramp-archive--test-delete (tmpfile)
+ "Delete temporary file or directory TMPFILE.
+This needs special support, because archive file names, which are
+the origin of the temporary TMPFILE, have no write permissions."
+ (unless (file-writable-p (file-name-directory tmpfile))
+ (set-file-modes
+ (file-name-directory tmpfile)
+ (logior (file-modes (file-name-directory tmpfile)) #o0700)))
+ (set-file-modes tmpfile #o0700)
+ (if (file-regular-p tmpfile)
+ (delete-file tmpfile)
+ (mapc
+ #'tramp-archive--test-delete
+ (directory-files tmpfile 'full directory-files-no-dot-files-regexp))
+ (delete-directory tmpfile)))
+
+(defun tramp-archive--test-emacs26-p ()
+ "Check for Emacs version >= 26.1.
+Some semantics has been changed for there, w/o new functions or
+variables, so we check the Emacs version directly."
+ (>= emacs-major-version 26))
+
+(defun tramp-archive--test-emacs27-p ()
+ "Check for Emacs version >= 27.1.
+Some semantics has been changed for there, w/o new functions or
+variables, so we check the Emacs version directly."
+ (>= emacs-major-version 27))
+
+(ert-deftest tramp-archive-test00-availability ()
+ "Test availability of archive file name functions."
+ :expected-result (if tramp-archive-enabled :passed :failed)
+ (should
+ (and
+ tramp-archive-enabled
+ (file-exists-p tramp-archive-test-file-archive)
+ (tramp-archive-file-name-p tramp-archive-test-archive))))
+
+(ert-deftest tramp-archive-test01-file-name-syntax ()
+ "Check archive file name syntax."
+ (should-not (tramp-archive-file-name-p tramp-archive-test-file-archive))
+ (should (tramp-archive-file-name-p tramp-archive-test-archive))
+ (should
+ (string-equal
+ (tramp-archive-file-name-archive tramp-archive-test-archive)
+ tramp-archive-test-file-archive))
+ (should
+ (string-equal
+ (tramp-archive-file-name-localname tramp-archive-test-archive) "/"))
+ (should (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo")))
+ (should
+ (string-equal
+ (tramp-archive-file-name-localname
+ (concat tramp-archive-test-archive "foo"))
+ "/foo"))
+ (should
+ (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo/bar")))
+ (should
+ (string-equal
+ (tramp-archive-file-name-localname
+ (concat tramp-archive-test-archive "foo/bar"))
+ "/foo/bar"))
+ ;; A file archive inside a file archive.
+ (should
+ (tramp-archive-file-name-p (concat tramp-archive-test-archive "baz.tar")))
+ (should
+ (string-equal
+ (tramp-archive-file-name-archive
+ (concat tramp-archive-test-archive "baz.tar"))
+ tramp-archive-test-file-archive))
+ (should
+ (string-equal
+ (tramp-archive-file-name-localname
+ (concat tramp-archive-test-archive "baz.tar"))
+ "/baz.tar"))
+ (should
+ (tramp-archive-file-name-p (concat tramp-archive-test-archive "baz.tar/")))
+ (should
+ (string-equal
+ (tramp-archive-file-name-archive
+ (concat tramp-archive-test-archive "baz.tar/"))
+ (concat tramp-archive-test-archive "baz.tar")))
+ (should
+ (string-equal
+ (tramp-archive-file-name-localname
+ (concat tramp-archive-test-archive "baz.tar/"))
+ "/")))
+
+(ert-deftest tramp-archive-test02-file-name-dissect ()
+ "Check archive file name components."
+ (skip-unless tramp-archive-enabled)
+
+ (with-parsed-tramp-archive-file-name tramp-archive-test-archive nil
+ (should (string-equal method tramp-archive-method))
+ (should-not user)
+ (should-not domain)
+ (should
+ (string-equal
+ host
+ (file-remote-p
+ (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host)))
+ (should
+ (string-equal
+ host
+ (url-hexify-string (concat "file://" tramp-archive-test-file-archive))))
+ (should-not port)
+ (should (string-equal localname "/"))
+ (should (string-equal archive tramp-archive-test-file-archive)))
+
+ ;; Localname.
+ (with-parsed-tramp-archive-file-name
+ (concat tramp-archive-test-archive "foo") nil
+ (should (string-equal method tramp-archive-method))
+ (should-not user)
+ (should-not domain)
+ (should
+ (string-equal
+ host
+ (file-remote-p
+ (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host)))
+ (should
+ (string-equal
+ host
+ (url-hexify-string (concat "file://" tramp-archive-test-file-archive))))
+ (should-not port)
+ (should (string-equal localname "/foo"))
+ (should (string-equal archive tramp-archive-test-file-archive)))
+
+ ;; File archive in file archive.
+ (let* ((tramp-archive-test-file-archive
+ (concat tramp-archive-test-archive "baz.tar"))
+ (tramp-archive-test-archive
+ (file-name-as-directory tramp-archive-test-file-archive))
+ (tramp-methods (cons `(,tramp-archive-method) tramp-methods))
+ (tramp-gvfs-methods tramp-archive-all-gvfs-methods))
+ (unwind-protect
+ (with-parsed-tramp-archive-file-name
+ (expand-file-name "bar" tramp-archive-test-archive) nil
+ (should (string-equal method tramp-archive-method))
+ (should-not user)
+ (should-not domain)
+ (should
+ (string-equal
+ host
+ (file-remote-p
+ (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host)))
+ ;; We reimplement the logic of tramp-archive.el here. Don't
+ ;; know, whether it is worth the test.
+ (should
+ (string-equal
+ host
+ (url-hexify-string
+ (concat
+ (tramp-gvfs-url-file-name
+ (tramp-make-tramp-file-name
+ tramp-archive-method
+ ;; User and Domain.
+ nil nil
+ ;; Host.
+ (url-hexify-string
+ (concat
+ "file://"
+ ;; `directory-file-name' does not leave file archive
+ ;; boundaries. So we must cut the trailing slash
+ ;; ourselves.
+ (substring
+ (file-name-directory tramp-archive-test-file-archive) 0 -1)))
+ nil "/"))
+ (file-name-nondirectory tramp-archive-test-file-archive)))))
+ (should-not port)
+ (should (string-equal localname "/bar"))
+ (should (string-equal archive tramp-archive-test-file-archive)))
+
+ ;; Cleanup.
+ (tramp-archive-cleanup-hash))))
+
+(ert-deftest tramp-archive-test05-expand-file-name ()
+ "Check `expand-file-name'."
+ (should
+ (string-equal
+ (expand-file-name "/foo.tar/path/./file") "/foo.tar/path/file"))
+ (should
+ (string-equal (expand-file-name "/foo.tar/path/../file") "/foo.tar/file"))
+ ;; `expand-file-name' does not care "~/" in archive file names.
+ (should
+ (string-equal (expand-file-name "/foo.tar/~/file") "/foo.tar/~/file"))
+ ;; `expand-file-name' does not care file archive boundaries.
+ (should (string-equal (expand-file-name "/foo.tar/./file") "/foo.tar/file"))
+ (should (string-equal (expand-file-name "/foo.tar/../file") "/file")))
+
+;; This test is inspired by Bug#30293.
+(ert-deftest tramp-archive-test05-expand-file-name-non-archive-directory ()
+ "Check existing directories with archive file name syntax.
+They shall still be supported"
+ (should (file-directory-p tramp-archive-test-directory))
+ ;; `tramp-archive-file-name-p' tests only for file name syntax. It
+ ;; doesn't test, whether it is really a file archive.
+ (should
+ (tramp-archive-file-name-p
+ (file-name-as-directory tramp-archive-test-directory)))
+ (should
+ (file-directory-p (file-name-as-directory tramp-archive-test-directory)))
+ (should
+ (file-exists-p (expand-file-name "foo" tramp-archive-test-directory))))
+
+(ert-deftest tramp-archive-test06-directory-file-name ()
+ "Check `directory-file-name'.
+This checks also `file-name-as-directory', `file-name-directory',
+`file-name-nondirectory' and `unhandled-file-name-directory'."
+ (skip-unless tramp-archive-enabled)
+
+ (should
+ (string-equal
+ (directory-file-name "/foo.tar/path/to/file") "/foo.tar/path/to/file"))
+ (should
+ (string-equal
+ (directory-file-name "/foo.tar/path/to/file/") "/foo.tar/path/to/file"))
+ ;; `directory-file-name' does not leave file archive boundaries.
+ (should (string-equal (directory-file-name "/foo.tar/") "/foo.tar/"))
+
+ (should
+ (string-equal
+ (file-name-as-directory "/foo.tar/path/to/file") "/foo.tar/path/to/file/"))
+ (should
+ (string-equal
+ (file-name-as-directory "/foo.tar/path/to/file/") "/foo.tar/path/to/file/"))
+ (should (string-equal (file-name-as-directory "/foo.tar/") "/foo.tar/"))
+ (should (string-equal (file-name-as-directory "/foo.tar") "/foo.tar/"))
+
+ (should
+ (string-equal
+ (file-name-directory "/foo.tar/path/to/file") "/foo.tar/path/to/"))
+ (should
+ (string-equal
+ (file-name-directory "/foo.tar/path/to/file/") "/foo.tar/path/to/file/"))
+ (should (string-equal (file-name-directory "/foo.tar/") "/foo.tar/"))
+
+ (should
+ (string-equal (file-name-nondirectory "/foo.tar/path/to/file") "file"))
+ (should
+ (string-equal (file-name-nondirectory "/foo.tar/path/to/file/") ""))
+ (should (string-equal (file-name-nondirectory "/foo.tar/") ""))
+
+ (should-not
+ (unhandled-file-name-directory "/foo.tar/path/to/file")))
+
+(ert-deftest tramp-archive-test07-file-exists-p ()
+ "Check `file-exist-p', `write-region' and `delete-file'."
+ :tags '(:expensive-test)
+ (skip-unless tramp-archive-enabled)
+
+ (unwind-protect
+ (let ((default-directory tramp-archive-test-archive))
+ (should (file-exists-p tramp-archive-test-file-archive))
+ (should (file-exists-p tramp-archive-test-archive))
+ (should (file-exists-p "foo.txt"))
+ (should (file-exists-p "foo.lnk"))
+ (should (file-exists-p "bar"))
+ (should (file-exists-p "bar/bar"))
+ (should-error
+ (write-region "foo" nil "baz")
+ :type 'file-error)
+ (should-error
+ (delete-file "baz")
+ :type 'file-error))
+
+ ;; Cleanup.
+ (tramp-archive-cleanup-hash)))
+
+(ert-deftest tramp-archive-test08-file-local-copy ()
+ "Check `file-local-copy'."
+ :tags '(:expensive-test)
+ (skip-unless tramp-archive-enabled)
+
+ (let (tmp-name)
+ (unwind-protect
+ (progn
+ (should
+ (setq tmp-name
+ (file-local-copy
+ (expand-file-name "bar/bar" tramp-archive-test-archive))))
+ (with-temp-buffer
+ (insert-file-contents tmp-name)
+ (should (string-equal (buffer-string) "bar\n")))
+ ;; Error case.
+ (tramp-archive--test-delete tmp-name)
+ (should-error
+ (setq tmp-name
+ (file-local-copy
+ (expand-file-name "what" tramp-archive-test-archive)))
+ :type tramp-file-missing))
+
+ ;; Cleanup.
+ (ignore-errors (tramp-archive--test-delete tmp-name))
+ (tramp-archive-cleanup-hash))))
+
+(ert-deftest tramp-archive-test09-insert-file-contents ()
+ "Check `insert-file-contents'."
+ :tags '(:expensive-test)
+ (skip-unless tramp-archive-enabled)
+
+ (let ((tmp-name (expand-file-name "bar/bar" tramp-archive-test-archive)))
+ (unwind-protect
+ (with-temp-buffer
+ (insert-file-contents tmp-name)
+ (should (string-equal (buffer-string) "bar\n"))
+ (insert-file-contents tmp-name)
+ (should (string-equal (buffer-string) "bar\nbar\n"))
+ ;; Insert partly.
+ (insert-file-contents tmp-name nil 1 3)
+ (should (string-equal (buffer-string) "arbar\nbar\n"))
+ ;; Replace.
+ (insert-file-contents tmp-name nil nil nil 'replace)
+ (should (string-equal (buffer-string) "bar\n"))
+ ;; Error case.
+ (should-error
+ (insert-file-contents
+ (expand-file-name "what" tramp-archive-test-archive))
+ :type tramp-file-missing))
+
+ ;; Cleanup.
+ (tramp-archive-cleanup-hash))))
+
+(ert-deftest tramp-archive-test11-copy-file ()
+ "Check `copy-file'."
+ :tags '(:expensive-test)
+ (skip-unless tramp-archive-enabled)
+
+ ;; Copy simple file.
+ (let ((tmp-name1 (expand-file-name "bar/bar" tramp-archive-test-archive))
+ (tmp-name2 (tramp-archive--test-make-temp-name)))
+ (unwind-protect
+ (progn
+ (copy-file tmp-name1 tmp-name2)
+ (should (file-exists-p tmp-name2))
+ (with-temp-buffer
+ (insert-file-contents tmp-name2)
+ (should (string-equal (buffer-string) "bar\n")))
+ (should-error
+ (copy-file tmp-name1 tmp-name2)
+ :type 'file-already-exists)
+ (copy-file tmp-name1 tmp-name2 'ok)
+ ;; The file archive is not writable.
+ (should-error
+ (copy-file tmp-name2 tmp-name1 'ok)
+ :type 'file-error))
+
+ ;; Cleanup.
+ (ignore-errors (tramp-archive--test-delete tmp-name2))
+ (tramp-archive-cleanup-hash)))
+
+ ;; Copy directory to existing directory.
+ (let ((tmp-name1 (expand-file-name "bar" tramp-archive-test-archive))
+ (tmp-name2 (tramp-archive--test-make-temp-name)))
+ (unwind-protect
+ (progn
+ (make-directory tmp-name2)
+ (should (file-directory-p tmp-name2))
+ ;; Directory `tmp-name2' exists already, so we must use
+ ;; `file-name-as-directory'.
+ (copy-file tmp-name1 (file-name-as-directory tmp-name2))
+ (should
+ (file-exists-p
+ (expand-file-name
+ (concat (file-name-nondirectory tmp-name1) "/bar") tmp-name2))))
+
+ ;; Cleanup.
+ (ignore-errors (tramp-archive--test-delete tmp-name2))
+ (tramp-archive-cleanup-hash)))
+
+ ;; Copy directory/file to non-existing directory.
+ (let ((tmp-name1 (expand-file-name "bar" tramp-archive-test-archive))
+ (tmp-name2 (tramp-archive--test-make-temp-name)))
+ (unwind-protect
+ (progn
+ (make-directory tmp-name2)
+ (should (file-directory-p tmp-name2))
+ (copy-file
+ tmp-name1
+ (expand-file-name (file-name-nondirectory tmp-name1) tmp-name2))
+ (should
+ (file-exists-p
+ (expand-file-name
+ (concat (file-name-nondirectory tmp-name1) "/bar") tmp-name2))))
+
+ ;; Cleanup.
+ (ignore-errors (tramp-archive--test-delete tmp-name2))
+ (tramp-archive-cleanup-hash))))
+
+(ert-deftest tramp-archive-test15-copy-directory ()
+ "Check `copy-directory'."
+ :tags '(:expensive-test)
+ (skip-unless tramp-archive-enabled)
+
+ (let* ((tmp-name1 (expand-file-name "bar" tramp-archive-test-archive))
+ (tmp-name2 (tramp-archive--test-make-temp-name))
+ (tmp-name3 (expand-file-name
+ (file-name-nondirectory tmp-name1) tmp-name2))
+ (tmp-name4 (expand-file-name "bar" tmp-name2))
+ (tmp-name5 (expand-file-name "bar" tmp-name3)))
+
+ ;; Copy complete directory.
+ (unwind-protect
+ (progn
+ ;; Copy empty directory.
+ (copy-directory tmp-name1 tmp-name2)
+ (should (file-directory-p tmp-name2))
+ (should (file-exists-p tmp-name4))
+ ;; Target directory does exist already.
+ ;; This has been changed in Emacs 26.1.
+ (when (tramp-archive--test-emacs26-p)
+ (should-error
+ (copy-directory tmp-name1 tmp-name2)
+ :type 'file-error))
+ (tramp-archive--test-delete tmp-name4)
+ (copy-directory tmp-name1 (file-name-as-directory tmp-name2))
+ (should (file-directory-p tmp-name3))
+ (should (file-exists-p tmp-name5)))
+
+ ;; Cleanup.
+ (ignore-errors (tramp-archive--test-delete tmp-name2))
+ (tramp-archive-cleanup-hash))
+
+ ;; Copy directory contents.
+ (unwind-protect
+ (progn
+ ;; Copy empty directory.
+ (copy-directory tmp-name1 tmp-name2 nil 'parents 'contents)
+ (should (file-directory-p tmp-name2))
+ (should (file-exists-p tmp-name4))
+ ;; Target directory does exist already.
+ (tramp-archive--test-delete tmp-name4)
+ (copy-directory
+ tmp-name1 (file-name-as-directory tmp-name2)
+ nil 'parents 'contents)
+ (should (file-directory-p tmp-name2))
+ (should (file-exists-p tmp-name4))
+ (should-not (file-directory-p tmp-name3))
+ (should-not (file-exists-p tmp-name5)))
+
+ ;; Cleanup.
+ (ignore-errors (tramp-archive--test-delete tmp-name2))
+ (tramp-archive-cleanup-hash))))
+
+(ert-deftest tramp-archive-test16-directory-files ()
+ "Check `directory-files'."
+ :tags '(:expensive-test)
+ (skip-unless tramp-archive-enabled)
+
+ (let ((tmp-name tramp-archive-test-archive)
+ (files '("." ".." "bar" "baz.tar" "foo.hrd" "foo.lnk" "foo.txt")))
+ (unwind-protect
+ (progn
+ (should (file-directory-p tmp-name))
+ (should (equal (directory-files tmp-name) files))
+ (should (equal (directory-files tmp-name 'full)
+ (mapcar (lambda (x) (concat tmp-name x)) files)))
+ (should (equal (directory-files
+ tmp-name nil directory-files-no-dot-files-regexp)
+ (delete "." (delete ".." files))))
+ (should (equal (directory-files
+ tmp-name 'full directory-files-no-dot-files-regexp)
+ (mapcar (lambda (x) (concat tmp-name x))
+ (delete "." (delete ".." files))))))
+
+ ;; Cleanup.
+ (tramp-archive-cleanup-hash))))
+
+(ert-deftest tramp-archive-test17-insert-directory ()
+ "Check `insert-directory'."
+ :tags '(:expensive-test)
+ (skip-unless tramp-archive-enabled)
+
+ (let (;; We test for the summary line. Keyword "total" could be localized.
+ (process-environment
+ (append '("LANG=C" "LANGUAGE=C" "LC_ALL=C") process-environment)))
+ (unwind-protect
+ (progn
+ ;; Due to Bug#29423, this works only since for Emacs 26.1.
+ (when nil ;; TODO (tramp-archive--test-emacs26-p)
+ (with-temp-buffer
+ (insert-directory tramp-archive-test-archive nil)
+ (goto-char (point-min))
+ (should
+ (looking-at-p (regexp-quote tramp-archive-test-archive)))))
+ (with-temp-buffer
+ (insert-directory tramp-archive-test-archive "-al")
+ (goto-char (point-min))
+ (should
+ (looking-at-p
+ (format "^.+ %s$" (regexp-quote tramp-archive-test-archive)))))
+ (with-temp-buffer
+ (insert-directory
+ (file-name-as-directory tramp-archive-test-archive)
+ "-al" nil 'full-directory-p)
+ (goto-char (point-min))
+ (should
+ (looking-at-p
+ (concat
+ ;; There might be a summary line.
+ "\\(total.+[[:digit:]]+\n\\)?"
+ ;; We don't know in which order the files appear.
+ (format
+ "\\(.+ %s\\( ->.+\\)?\n\\)\\{%d\\}"
+ (regexp-opt (directory-files tramp-archive-test-archive))
+ (length (directory-files tramp-archive-test-archive)))))))
+
+ ;; Check error case.
+ (with-temp-buffer
+ (should-error
+ (insert-directory
+ (expand-file-name "baz" tramp-archive-test-archive) nil)
+ :type tramp-file-missing)))
+
+ ;; Cleanup.
+ (tramp-archive-cleanup-hash))))
+
+(ert-deftest tramp-archive-test18-file-attributes ()
+ "Check `file-attributes'.
+This tests also `access-file', `file-readable-p' and `file-regular-p'."
+ :tags '(:expensive-test)
+ (skip-unless tramp-archive-enabled)
+
+ (let ((tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive))
+ (tmp-name2 (expand-file-name "foo.lnk" tramp-archive-test-archive))
+ (tmp-name3 (expand-file-name "bar" tramp-archive-test-archive))
+ (tmp-name4 (expand-file-name "baz" tramp-archive-test-archive))
+ attr)
+ (unwind-protect
+ (progn
+ (should (file-exists-p tmp-name1))
+ (should (file-readable-p tmp-name1))
+ (should (file-regular-p tmp-name1))
+ (should-not (access-file tmp-name1 "error"))
+
+ ;; We do not test inodes and device numbers.
+ (setq attr (file-attributes tmp-name1))
+ (should (consp attr))
+ (should (null (car attr)))
+ (should (numberp (nth 1 attr))) ;; Link.
+ (should (numberp (nth 2 attr))) ;; Uid.
+ (should (numberp (nth 3 attr))) ;; Gid.
+ ;; Last access time.
+ (should (stringp (current-time-string (nth 4 attr))))
+ ;; Last modification time.
+ (should (stringp (current-time-string (nth 5 attr))))
+ ;; Last status change time.
+ (should (stringp (current-time-string (nth 6 attr))))
+ (should (numberp (nth 7 attr))) ;; Size.
+ (should (stringp (nth 8 attr))) ;; Modes.
+
+ (setq attr (file-attributes tmp-name1 'string))
+ (should (stringp (nth 2 attr))) ;; Uid.
+ (should (stringp (nth 3 attr))) ;; Gid.
+
+ ;; Symlink.
+ (should (file-exists-p tmp-name2))
+ (should (file-symlink-p tmp-name2))
+ (setq attr (file-attributes tmp-name2))
+ (should (string-equal (car attr) (file-name-nondirectory tmp-name1)))
+
+ ;; Directory.
+ (should (file-exists-p tmp-name3))
+ (should (file-readable-p tmp-name3))
+ (should-not (file-regular-p tmp-name3))
+ (setq attr (file-attributes tmp-name3))
+ (should (eq (car attr) t))
+ (should-not (access-file tmp-name3 "error"))
+
+ ;; Check error case.
+ (should-error
+ (access-file tmp-name4 "error")
+ :type tramp-file-missing))
+
+ ;; Cleanup.
+ (tramp-archive-cleanup-hash))))
+
+(ert-deftest tramp-archive-test19-directory-files-and-attributes ()
+ "Check `directory-files-and-attributes'."
+ :tags '(:expensive-test)
+ (skip-unless tramp-archive-enabled)
+
+ (let ((tmp-name (expand-file-name "bar" tramp-archive-test-archive))
+ attr)
+ (unwind-protect
+ (progn
+ (should (file-directory-p tmp-name))
+ (setq attr (directory-files-and-attributes tmp-name))
+ (should (consp attr))
+ (dolist (elt attr)
+ (should
+ (equal (file-attributes (expand-file-name (car elt) tmp-name))
+ (cdr elt))))
+ (setq attr (directory-files-and-attributes tmp-name 'full))
+ (dolist (elt attr)
+ (should (equal (file-attributes (car elt)) (cdr elt))))
+ (setq attr (directory-files-and-attributes tmp-name nil "^b"))
+ (should (equal (mapcar #'car attr) '("bar"))))
+
+ ;; Cleanup.
+ (tramp-archive-cleanup-hash))))
+
+(ert-deftest tramp-archive-test20-file-modes ()
+ "Check `file-modes'.
+This tests also `file-executable-p', `file-writable-p' and `set-file-modes'."
+ :tags '(:expensive-test)
+ (skip-unless tramp-archive-enabled)
+
+ (let ((tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive))
+ (tmp-name2 (expand-file-name "bar" tramp-archive-test-archive)))
+ (unwind-protect
+ (progn
+ (should (file-exists-p tmp-name1))
+ ;; `set-file-modes' is not implemented.
+ (should-error
+ (set-file-modes tmp-name1 #o777)
+ :type 'file-error)
+ (should (= (file-modes tmp-name1) #o400))
+ (should-not (file-executable-p tmp-name1))
+ (should-not (file-writable-p tmp-name1))
+
+ (should (file-exists-p tmp-name2))
+ ;; `set-file-modes' is not implemented.
+ (should-error
+ (set-file-modes tmp-name2 #o777)
+ :type 'file-error)
+ (should (= (file-modes tmp-name2) #o500))
+ (should (file-executable-p tmp-name2))
+ (should-not (file-writable-p tmp-name2)))
+
+ ;; Cleanup.
+ (tramp-archive-cleanup-hash))))
+
+(ert-deftest tramp-archive-test21-file-links ()
+ "Check `file-symlink-p' and `file-truename'"
+ :tags '(:expensive-test)
+ (skip-unless tramp-archive-enabled)
+
+ ;; We must use `file-truename' for the file archive, because it
+ ;; could be located on a symlinked directory. This would let the
+ ;; test fail.
+ (let* ((tramp-archive-test-archive (file-truename tramp-archive-test-archive))
+ (tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive))
+ (tmp-name2 (expand-file-name "foo.lnk" tramp-archive-test-archive)))
+
+ (unwind-protect
+ (progn
+ (should (file-exists-p tmp-name1))
+ (should (string-equal tmp-name1 (file-truename tmp-name1)))
+ ;; `make-symbolic-link' is not implemented.
+ (should-error
+ (make-symbolic-link tmp-name1 tmp-name2)
+ :type 'file-error)
+ (should (file-symlink-p tmp-name2))
+ (should
+ (string-equal
+ ;; This is "/foo.txt".
+ (with-parsed-tramp-archive-file-name tmp-name1 nil localname)
+ ;; `file-symlink-p' returns "foo.txt". Wer must expand, therefore.
+ (with-parsed-tramp-archive-file-name
+ (expand-file-name
+ (file-symlink-p tmp-name2) tramp-archive-test-archive)
+ nil
+ localname)))
+ (should-not (string-equal tmp-name2 (file-truename tmp-name2)))
+ (should
+ (string-equal (file-truename tmp-name1) (file-truename tmp-name2)))
+ (should (file-equal-p tmp-name1 tmp-name2)))
+
+ ;; Cleanup.
+ (tramp-archive-cleanup-hash))))
+
+(ert-deftest tramp-archive-test26-file-name-completion ()
+ "Check `file-name-completion' and `file-name-all-completions'."
+ :tags '(:expensive-test)
+ (skip-unless tramp-archive-enabled)
+
+ (let ((tmp-name tramp-archive-test-archive))
+ (unwind-protect
+ (progn
+ ;; Local files.
+ (should (equal (file-name-completion "fo" tmp-name) "foo."))
+ (should (equal (file-name-completion "foo.txt" tmp-name) t))
+ (should (equal (file-name-completion "b" tmp-name) "ba"))
+ (should-not (file-name-completion "a" tmp-name))
+ (should
+ (equal
+ (file-name-completion "b" tmp-name #'file-directory-p) "bar/"))
+ (should
+ (equal
+ (sort (file-name-all-completions "fo" tmp-name) #'string-lessp)
+ '("foo.hrd" "foo.lnk" "foo.txt")))
+ (should
+ (equal
+ (sort (file-name-all-completions "b" tmp-name) #'string-lessp)
+ '("bar/" "baz.tar")))
+ (should-not (file-name-all-completions "a" tmp-name))
+ ;; `completion-regexp-list' restricts the completion to
+ ;; files which match all expressions in this list.
+ (let ((completion-regexp-list
+ `(,directory-files-no-dot-files-regexp "b")))
+ (should
+ (equal (file-name-completion "" tmp-name) "ba"))
+ (should
+ (equal
+ (sort (file-name-all-completions "" tmp-name) #'string-lessp)
+ '("bar/" "baz.tar")))))
+
+ ;; Cleanup.
+ (tramp-archive-cleanup-hash))))
+
+;; The functions were introduced in Emacs 26.1.
+(ert-deftest tramp-archive-test39-make-nearby-temp-file ()
+ "Check `make-nearby-temp-file' and `temporary-file-directory'."
+ (skip-unless tramp-archive-enabled)
+ ;; Since Emacs 26.1.
+ (skip-unless
+ (and (fboundp 'make-nearby-temp-file) (fboundp 'temporary-file-directory)))
+
+ ;; `make-nearby-temp-file' and `temporary-file-directory' exists
+ ;; since Emacs 26.1. We don't want to see compiler warnings for
+ ;; older Emacsen.
+ (let ((default-directory tramp-archive-test-archive)
+ tmp-file)
+ ;; The file archive shall know a temporary file directory. It is
+ ;; not in the archive itself.
+ (should
+ (stringp (with-no-warnings (with-no-warnings (temporary-file-directory)))))
+ (should-not
+ (tramp-archive-file-name-p (with-no-warnings (temporary-file-directory))))
+
+ ;; A temporary file or directory shall not be located in the
+ ;; archive itself.
+ (setq tmp-file
+ (with-no-warnings (make-nearby-temp-file "tramp-archive-test")))
+ (should (file-exists-p tmp-file))
+ (should (file-regular-p tmp-file))
+ (should-not (tramp-archive-file-name-p tmp-file))
+ (delete-file tmp-file)
+ (should-not (file-exists-p tmp-file))
+
+ (setq tmp-file
+ (with-no-warnings (make-nearby-temp-file "tramp-archive-test" 'dir)))
+ (should (file-exists-p tmp-file))
+ (should (file-directory-p tmp-file))
+ (should-not (tramp-archive-file-name-p tmp-file))
+ (delete-directory tmp-file)
+ (should-not (file-exists-p tmp-file))))
+
+(ert-deftest tramp-archive-test42-file-system-info ()
+ "Check that `file-system-info' returns proper values."
+ (skip-unless tramp-archive-enabled)
+ ;; Since Emacs 27.1.
+ (skip-unless (fboundp 'file-system-info))
+
+ ;; `file-system-info' exists since Emacs 27. We don't want to see
+ ;; compiler warnings for older Emacsen.
+ (let ((fsi (with-no-warnings (file-system-info tramp-archive-test-archive))))
+ (skip-unless fsi)
+ (should (and (consp fsi)
+ (= (length fsi) 3)
+ (numberp (nth 0 fsi))
+ ;; FREE and AVAIL are always 0.
+ (zerop (nth 1 fsi))
+ (zerop (nth 2 fsi))))))
+
+(ert-deftest tramp-archive-test45-auto-load ()
+ "Check that `tramp-archive' autoloads properly."
+ :tags '(:expensive-test)
+ (skip-unless tramp-archive-enabled)
+ ;; Autoloading tramp-archive works since Emacs 27.1.
+ (skip-unless (tramp-archive--test-emacs27-p))
+
+ ;; tramp-archive is neither loaded at Emacs startup, nor when
+ ;; loading a file like "/mock::foo" (which loads Tramp).
+ (let ((default-directory (expand-file-name temporary-file-directory))
+ (code
+ "(progn \
+ (message \"tramp-archive loaded: %%s %%s\" \
+ (featurep 'tramp) (featurep 'tramp-archive)) \
+ (file-attributes %S \"/\") \
+ (message \"tramp-archive loaded: %%s %%s\" \
+ (featurep 'tramp) (featurep 'tramp-archive)))"))
+ (dolist (file `("/mock::foo" ,(concat tramp-archive-test-archive "foo")))
+ (should
+ (string-match
+ (format
+ "tramp-archive loaded: nil nil[[:ascii:]]+tramp-archive loaded: t %s"
+ (tramp-archive-file-name-p file))
+ (shell-command-to-string
+ (format
+ "%s -batch -Q -L %s --eval %s"
+ (shell-quote-argument
+ (expand-file-name invocation-name invocation-directory))
+ (mapconcat #'shell-quote-argument load-path " -L ")
+ (shell-quote-argument (format code file)))))))))
+
+(ert-deftest tramp-archive-test45-delay-load ()
+ "Check that `tramp-archive' is loaded lazily, only when needed."
+ :tags '(:expensive-test)
+ (skip-unless tramp-archive-enabled)
+ ;; Autoloading tramp-archive works since Emacs 27.1.
+ (skip-unless (tramp-archive--test-emacs27-p))
+
+ ;; tramp-archive is neither loaded at Emacs startup, nor when
+ ;; loading a file like "/foo.tar". It is loaded only when
+ ;; `tramp-archive-enabled' is t.
+ (let ((default-directory (expand-file-name temporary-file-directory))
+ (code
+ "(progn \
+ (setq tramp-archive-enabled %s) \
+ (message \"tramp-archive loaded: %%s\" \
+ (featurep 'tramp-archive)) \
+ (file-attributes %S \"/\") \
+ (message \"tramp-archive loaded: %%s\" \
+ (featurep 'tramp-archive)) \
+ (file-attributes %S \"/\") \
+ (message \"tramp-archive loaded: %%s\" \
+ (featurep 'tramp-archive)))"))
+ ;; tramp-archive doesn't load when `tramp-archive-enabled' is nil.
+ (dolist (tae '(t nil))
+ (should
+ (string-match
+ (format
+ "tramp-archive loaded: nil[[:ascii:]]+tramp-archive loaded: nil[[:ascii:]]+tramp-archive loaded: %s"
+ tae)
+ (shell-command-to-string
+ (format
+ "%s -batch -Q -L %s --eval %s"
+ (shell-quote-argument
+ (expand-file-name invocation-name invocation-directory))
+ (mapconcat #'shell-quote-argument load-path " -L ")
+ (shell-quote-argument
+ (format
+ code tae tramp-archive-test-file-archive
+ (concat tramp-archive-test-archive "foo"))))))))))
+
+(ert-deftest tramp-archive-test99-libarchive-tests ()
+ "Run tests of libarchive test files."
+ :tags '(:expensive-test :unstable)
+ (skip-unless tramp-archive-enabled)
+ ;; We do not want to run unless chosen explicitly. This test makes
+ ;; sense only in my local environment. Michael Albinus.
+ (skip-unless
+ (equal
+ (ert--stats-selector ert--current-run-stats)
+ (ert-test-name (ert-running-test))))
+
+ (url-handler-mode)
+ (unwind-protect
+ (dolist (dir
+ '("~/Downloads" "/sftp::~/Downloads" "/ssh::~/Downloads"
+ "http://ftp.debian.org/debian/pool/main/c/coreutils"))
+ (dolist
+ (file
+ '("coreutils_8.26-3_amd64.deb"
+ "coreutils_8.26-3ubuntu3_amd64.deb"))
+ (setq file (expand-file-name file dir))
+ (when (file-exists-p file)
+ (setq file (expand-file-name "control.tar.gz/control" file))
+ (message "%s" file)
+ (should (file-attributes (file-name-as-directory file))))))
+
+ ;; Cleanup.
+ (tramp-archive-cleanup-hash))
+
+ (unwind-protect
+ (dolist (dir '("" "/sftp::" "/ssh::"))
+ (dolist
+ (file
+ (apply
+ 'append
+ (mapcar
+ (lambda (x) (directory-files (concat dir x) 'full "uu\\'" 'sort))
+ '("~/src/libarchive-3.2.2/libarchive/test"
+ "~/src/libarchive-3.2.2/cpio/test"
+ "~/src/libarchive-3.2.2/tar/test"))))
+ (setq file (file-name-as-directory file))
+ (cond
+ ((not (tramp-archive-file-name-p file))
+ (message "skipped: %s" file))
+ ((file-attributes file)
+ (message "%s" file))
+ (t (message "failed: %s" file)))
+ (tramp-archive-cleanup-hash)))
+
+ ;; Cleanup.
+ (tramp-archive-cleanup-hash)))
+
+(defun tramp-archive-test-all (&optional interactive)
+ "Run all tests for \\[tramp-archive]."
+ (interactive "p")
+ (funcall
+ (if interactive #'ert-run-tests-interactively #'ert-run-tests-batch)
+ "^tramp-archive"))
+
+(provide 'tramp-archive-tests)
+;;; tramp-archive-tests.el ends here
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index 70b2646cc89..5a9541db8fb 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -33,7 +33,7 @@
;; remote host, set this environment variable to "/dev/null" or
;; whatever is appropriate on your system.
-;; For slow remote connections, `tramp-test41-asynchronous-requests'
+;; For slow remote connections, `tramp-test43-asynchronous-requests'
;; might be too heavy. Setting $REMOTE_PARALLEL_PROCESSES to a proper
;; value less than 10 could help.
@@ -52,14 +52,27 @@
(declare-function tramp-find-executable "tramp-sh")
(declare-function tramp-get-remote-path "tramp-sh")
-(declare-function tramp-get-remote-stat "tramp-sh")
(declare-function tramp-get-remote-perl "tramp-sh")
+(declare-function tramp-get-remote-stat "tramp-sh")
+(declare-function tramp-method-out-of-band-p "tramp-sh")
+(declare-function tramp-smb-get-localname "tramp-smb")
(defvar auto-save-file-name-transforms)
+(defvar tramp-connection-properties)
(defvar tramp-copy-size-limit)
+(defvar tramp-display-escape-sequence-regexp)
+(defvar tramp-inline-compress-start-size)
(defvar tramp-persistency-file-name)
+(defvar tramp-remote-path)
(defvar tramp-remote-process-environment)
-;; Suppress nasty messages.
-(fset 'shell-command-sentinel 'ignore)
+
+;; Beautify batch mode.
+(when noninteractive
+ ;; Suppress nasty messages.
+ (fset #'shell-command-sentinel #'ignore)
+ ;; We do not want to be interrupted.
+ (eval-after-load 'tramp-gvfs
+ '(fset 'tramp-gvfs-handler-askquestion
+ (lambda (_message _choices) '(t nil 0)))))
;; There is no default value on w32 systems, which could work out of the box.
(defconst tramp-test-temporary-file-directory
@@ -84,7 +97,8 @@
(format "/mock::%s" temporary-file-directory)))
"Temporary directory for Tramp tests.")
-(setq password-cache-expiry nil
+(setq auth-source-save-behavior nil
+ password-cache-expiry nil
tramp-verbose 0
tramp-cache-read-persistent-data t ;; For auth-sources.
tramp-copy-size-limit nil
@@ -95,11 +109,6 @@
(when (getenv "EMACS_HYDRA_CI")
(add-to-list 'tramp-remote-path 'tramp-own-remote-path))
-(defvar tramp--test-expensive-test
- (null
- (string-equal (getenv "SELECTOR") "(quote (not (tag :expensive-test)))"))
- "Whether expensive tests are run.")
-
(defvar tramp--test-enabled-checked nil
"Cached result of `tramp--test-enabled'.
If the function did run, the value is a cons cell, the `cdr'
@@ -127,13 +136,20 @@ being the result.")
;; Return result.
(cdr tramp--test-enabled-checked))
+(defsubst tramp--test-expensive-test ()
+ "Whether expensive tests are run."
+ (ert-select-tests
+ (ert--stats-selector ert--current-run-stats)
+ (list (make-ert-test :name (ert-test-name (ert-running-test))
+ :body nil :tags '(:expensive-test)))))
+
(defun tramp--test-make-temp-name (&optional local quoted)
"Return a temporary file name for test.
If LOCAL is non-nil, a local file name is returned.
If QUOTED is non-nil, the local part of the file name is quoted.
The temporary file is not created."
(funcall
- (if quoted 'tramp-compat-file-name-quote 'identity)
+ (if quoted #'tramp-compat-file-name-quote #'identity)
(expand-file-name
(make-temp-name "tramp-test")
(if local temporary-file-directory tramp-test-temporary-file-directory))))
@@ -145,9 +161,9 @@ This shall used dynamically bound only.")
(defmacro tramp--test-instrument-test-case (verbose &rest body)
"Run BODY with `tramp-verbose' equal VERBOSE.
-Print the content of the Tramp debug buffer, if BODY does not
-eval properly in `should' or `should-not'. `should-error' is not
-handled properly. BODY shall not contain a timeout."
+Print the content of the Tramp connection and debug buffers, if
+`tramp-verbose' is greater than 3. `should-error' is not handled
+properly. BODY shall not contain a timeout."
(declare (indent 1) (debug (natnump body)))
`(let ((tramp-verbose (max (or ,verbose 0) (or tramp-verbose 0)))
(tramp-message-show-message t)
@@ -169,7 +185,7 @@ handled properly. BODY shall not contain a timeout."
"Emit a message into ERT *Messages*."
(tramp--test-instrument-test-case 0
(apply
- 'tramp-message
+ #'tramp-message
(tramp-dissect-file-name tramp-test-temporary-file-directory) 0
fmt-string arguments)))
@@ -179,6 +195,16 @@ handled properly. BODY shall not contain a timeout."
(tramp-backtrace
(tramp-dissect-file-name tramp-test-temporary-file-directory))))
+(defmacro tramp--test-print-duration (message &rest body)
+ "Run BODY and print a message with duration, prompted by MESSAGE."
+ (declare (indent 1) (debug (stringp body)))
+ `(let ((start (current-time)))
+ (unwind-protect
+ (progn ,@body)
+ (tramp--test-message
+ "%s %f sec"
+ ,message (float-time (time-subtract (current-time) start))))))
+
(ert-deftest tramp-test00-availability ()
"Test availability of Tramp functions."
:expected-result (if (tramp--test-enabled) :passed :failed)
@@ -211,6 +237,10 @@ handled properly. BODY shall not contain a timeout."
(should (tramp-tramp-file-p "/method:[::1]:"))
(should (tramp-tramp-file-p "/method:user@[::1]:"))
+ ;; Using an IPv4 mapped IPv6 address.
+ (should (tramp-tramp-file-p "/method:[::ffff:1.2.3.4]:"))
+ (should (tramp-tramp-file-p "/method:user@[::ffff:1.2.3.4]:"))
+
;; Local file name part.
(should (tramp-tramp-file-p "/method:::"))
(should (tramp-tramp-file-p "/method::/:"))
@@ -229,12 +259,16 @@ handled properly. BODY shall not contain a timeout."
;; No strings.
(should-not (tramp-tramp-file-p nil))
(should-not (tramp-tramp-file-p 'symbol))
+ ;; No newline or linefeed.
+ (should-not (tramp-tramp-file-p "/method::file\nname"))
+ (should-not (tramp-tramp-file-p "/method::file\rname"))
;; Ange-ftp syntax.
(should-not (tramp-tramp-file-p "/host:"))
(should-not (tramp-tramp-file-p "/user@host:"))
(should-not (tramp-tramp-file-p "/1.2.3.4:"))
(should-not (tramp-tramp-file-p "/[]:"))
(should-not (tramp-tramp-file-p "/[::1]:"))
+ (should-not (tramp-tramp-file-p "/[::ffff:1.2.3.4]:"))
(should-not (tramp-tramp-file-p "/host:/:"))
(should-not (tramp-tramp-file-p "/host1|host2:"))
(should-not (tramp-tramp-file-p "/user1@host1|user2@host2:"))
@@ -242,6 +276,12 @@ handled properly. BODY shall not contain a timeout."
(should-not (tramp-tramp-file-p "/::"))
(should-not (tramp-tramp-file-p "/:@:"))
(should-not (tramp-tramp-file-p "/:[]:"))
+ ;; When `tramp-mode' is nil, Tramp is not activated.
+ (let (tramp-mode)
+ (should-not (tramp-tramp-file-p "/method:user@host:")))
+ ;; `tramp-ignored-file-name-regexp' suppresses Tramp.
+ (let ((tramp-ignored-file-name-regexp "^/method:user@host:"))
+ (should-not (tramp-tramp-file-p "/method:user@host:")))
;; Methods shall be at least two characters on MS Windows, except
;; the default method.
(let ((system-type 'windows-nt))
@@ -277,6 +317,10 @@ handled properly. BODY shall not contain a timeout."
(should (tramp-tramp-file-p "/[::1]:"))
(should (tramp-tramp-file-p "/user@[::1]:"))
+ ;; Using an IPv4 mapped IPv6 address.
+ (should (tramp-tramp-file-p "/[::ffff:1.2.3.4]:"))
+ (should (tramp-tramp-file-p "/user@[::ffff:1.2.3.4]:"))
+
;; Local file name part.
(should (tramp-tramp-file-p "/host::"))
(should (tramp-tramp-file-p "/host:/:"))
@@ -327,6 +371,10 @@ handled properly. BODY shall not contain a timeout."
(should (tramp-tramp-file-p "/[method/::1]"))
(should (tramp-tramp-file-p "/[method/user@::1]"))
+ ;; Using an IPv4 mapped IPv6 address.
+ (should (tramp-tramp-file-p "/[method/::ffff:1.2.3.4]"))
+ (should (tramp-tramp-file-p "/[method/user@::ffff:1.2.3.4]"))
+
;; Local file name part.
(should (tramp-tramp-file-p "/[method/]"))
(should (tramp-tramp-file-p "/[method/]/:"))
@@ -365,7 +413,13 @@ handled properly. BODY shall not contain a timeout."
"Check remote file name components."
(let ((tramp-default-method "default-method")
(tramp-default-user "default-user")
- (tramp-default-host "default-host"))
+ (tramp-default-host "default-host")
+ tramp-default-method-alist
+ tramp-default-user-alist
+ tramp-default-host-alist
+ ;; Suppress check for multihops.
+ (tramp-cache-data (make-hash-table :test #'equal))
+ (tramp-connection-properties '((nil "login-program" t))))
;; Expand `tramp-default-user' and `tramp-default-host'.
(should (string-equal
(file-remote-p "/method::")
@@ -715,7 +769,84 @@ handled properly. BODY shall not contain a timeout."
"|method3:user3@host3:/path/to/file")
'hop)
(format "%s:%s@%s|%s:%s@%s|"
- "method1" "user1" "host1" "method2" "user2" "host2")))))
+ "method1" "user1" "host1" "method2" "user2" "host2")))
+
+ ;; Expand `tramp-default-method-alist'.
+ (add-to-list 'tramp-default-method-alist '("host1" "user1" "method1"))
+ (add-to-list 'tramp-default-method-alist '("host2" "user2" "method2"))
+ (add-to-list 'tramp-default-method-alist '("host3" "user3" "method3"))
+ (should
+ (string-equal
+ (file-remote-p
+ (concat
+ "/-:user1@host1"
+ "|-:user2@host2"
+ "|-:user3@host3:/path/to/file"))
+ (format "/%s:%s@%s|%s:%s@%s|%s:%s@%s:"
+ "method1" "user1" "host1"
+ "method2" "user2" "host2"
+ "method3" "user3" "host3")))
+
+ ;; Expand `tramp-default-user-alist'.
+ (add-to-list 'tramp-default-user-alist '("method1" "host1" "user1"))
+ (add-to-list 'tramp-default-user-alist '("method2" "host2" "user2"))
+ (add-to-list 'tramp-default-user-alist '("method3" "host3" "user3"))
+ (should
+ (string-equal
+ (file-remote-p
+ (concat
+ "/method1:host1"
+ "|method2:host2"
+ "|method3:host3:/path/to/file"))
+ (format "/%s:%s@%s|%s:%s@%s|%s:%s@%s:"
+ "method1" "user1" "host1"
+ "method2" "user2" "host2"
+ "method3" "user3" "host3")))
+
+ ;; Expand `tramp-default-host-alist'.
+ (add-to-list 'tramp-default-host-alist '("method1" "user1" "host1"))
+ (add-to-list 'tramp-default-host-alist '("method2" "user2" "host2"))
+ (add-to-list 'tramp-default-host-alist '("method3" "user3" "host3"))
+ (should
+ (string-equal
+ (file-remote-p
+ (concat
+ "/method1:user1@"
+ "|method2:user2@"
+ "|method3:user3@:/path/to/file"))
+ (format "/%s:%s@%s|%s:%s@%s|%s:%s@%s:"
+ "method1" "user1" "host1"
+ "method2" "user2" "host2"
+ "method3" "user3" "host3")))
+
+ ;; Ad-hoc user name and host name expansion.
+ (setq tramp-default-method-alist nil
+ tramp-default-user-alist nil
+ tramp-default-host-alist nil)
+ (should
+ (string-equal
+ (file-remote-p
+ (concat
+ "/method1:user1@host1"
+ "|method2:user2@"
+ "|method3:user3@:/path/to/file"))
+ (format "/%s:%s@%s|%s:%s@%s|%s:%s@%s:"
+ "method1" "user1" "host1"
+ "method2" "user2" "host1"
+ "method3" "user3" "host1")))
+ (should
+ (string-equal
+ (file-remote-p
+ (concat
+ "/method1:%u@%h"
+ "|method2:user2@host2"
+ "|method3:%u@%h"
+ "|method4:user4%domain4@host4#1234:/path/to/file"))
+ (format "/%s:%s@%s|%s:%s@%s|%s:%s@%s|%s:%s@%s:"
+ "method1" "user2" "host2"
+ "method2" "user2" "host2"
+ "method3" "user4" "host4"
+ "method4" "user4%domain4" "host4#1234")))))
(ert-deftest tramp-test02-file-name-dissect-simplified ()
"Check simplified file name components."
@@ -723,6 +854,11 @@ handled properly. BODY shall not contain a timeout."
(let ((tramp-default-method "default-method")
(tramp-default-user "default-user")
(tramp-default-host "default-host")
+ tramp-default-user-alist
+ tramp-default-host-alist
+ ;; Suppress check for multihops.
+ (tramp-cache-data (make-hash-table :test #'equal))
+ (tramp-connection-properties '((nil "login-program" t)))
(syntax tramp-syntax))
(unwind-protect
(progn
@@ -970,7 +1106,67 @@ handled properly. BODY shall not contain a timeout."
"|user3@host3:/path/to/file")
'hop)
(format "%s@%s|%s@%s|"
- "user1" "host1" "user2" "host2"))))
+ "user1" "host1" "user2" "host2")))
+
+ ;; Expand `tramp-default-user-alist'.
+ (add-to-list 'tramp-default-user-alist '(nil "host1" "user1"))
+ (add-to-list 'tramp-default-user-alist '(nil "host2" "user2"))
+ (add-to-list 'tramp-default-user-alist '(nil "host3" "user3"))
+ (should
+ (string-equal
+ (file-remote-p
+ (concat
+ "/host1"
+ "|host2"
+ "|host3:/path/to/file"))
+ (format "/%s@%s|%s@%s|%s@%s:"
+ "user1" "host1"
+ "user2" "host2"
+ "user3" "host3")))
+
+ ;; Expand `tramp-default-host-alist'.
+ (add-to-list 'tramp-default-host-alist '(nil "user1" "host1"))
+ (add-to-list 'tramp-default-host-alist '(nil "user2" "host2"))
+ (add-to-list 'tramp-default-host-alist '(nil "user3" "host3"))
+ (should
+ (string-equal
+ (file-remote-p
+ (concat
+ "/user1@"
+ "|user2@"
+ "|user3@:/path/to/file"))
+ (format "/%s@%s|%s@%s|%s@%s:"
+ "user1" "host1"
+ "user2" "host2"
+ "user3" "host3")))
+
+ ;; Ad-hoc user name and host name expansion.
+ (setq tramp-default-user-alist nil
+ tramp-default-host-alist nil)
+ (should
+ (string-equal
+ (file-remote-p
+ (concat
+ "/user1@host1"
+ "|user2@"
+ "|user3@:/path/to/file"))
+ (format "/%s@%s|%s@%s|%s@%s:"
+ "user1" "host1"
+ "user2" "host1"
+ "user3" "host1")))
+ (should
+ (string-equal
+ (file-remote-p
+ (concat
+ "/%u@%h"
+ "|user2@host2"
+ "|%u@%h"
+ "|user4%domain4@host4#1234:/path/to/file"))
+ (format "/%s@%s|%s@%s|%s@%s|%s@%s:"
+ "user2" "host2"
+ "user2" "host2"
+ "user4" "host4"
+ "user4%domain4" "host4#1234"))))
;; Exit.
(tramp-change-syntax syntax))))
@@ -981,6 +1177,12 @@ handled properly. BODY shall not contain a timeout."
(let ((tramp-default-method "default-method")
(tramp-default-user "default-user")
(tramp-default-host "default-host")
+ tramp-default-method-alist
+ tramp-default-user-alist
+ tramp-default-host-alist
+ ;; Suppress check for multihops.
+ (tramp-cache-data (make-hash-table :test #'equal))
+ (tramp-connection-properties '((nil "login-program" t)))
(syntax tramp-syntax))
(unwind-protect
(progn
@@ -1538,7 +1740,84 @@ handled properly. BODY shall not contain a timeout."
"|method3/user3@host3]/path/to/file")
'hop)
(format "%s/%s@%s|%s/%s@%s|"
- "method1" "user1" "host1" "method2" "user2" "host2"))))
+ "method1" "user1" "host1" "method2" "user2" "host2")))
+
+ ;; Expand `tramp-default-method-alist'.
+ (add-to-list 'tramp-default-method-alist '("host1" "user1" "method1"))
+ (add-to-list 'tramp-default-method-alist '("host2" "user2" "method2"))
+ (add-to-list 'tramp-default-method-alist '("host3" "user3" "method3"))
+ (should
+ (string-equal
+ (file-remote-p
+ (concat
+ "/[/user1@host1"
+ "|/user2@host2"
+ "|/user3@host3]/path/to/file"))
+ (format "/[%s/%s@%s|%s/%s@%s|%s/%s@%s]"
+ "method1" "user1" "host1"
+ "method2" "user2" "host2"
+ "method3" "user3" "host3")))
+
+ ;; Expand `tramp-default-user-alist'.
+ (add-to-list 'tramp-default-user-alist '("method1" "host1" "user1"))
+ (add-to-list 'tramp-default-user-alist '("method2" "host2" "user2"))
+ (add-to-list 'tramp-default-user-alist '("method3" "host3" "user3"))
+ (should
+ (string-equal
+ (file-remote-p
+ (concat
+ "/[method1/host1"
+ "|method2/host2"
+ "|method3/host3]/path/to/file"))
+ (format "/[%s/%s@%s|%s/%s@%s|%s/%s@%s]"
+ "method1" "user1" "host1"
+ "method2" "user2" "host2"
+ "method3" "user3" "host3")))
+
+ ;; Expand `tramp-default-host-alist'.
+ (add-to-list 'tramp-default-host-alist '("method1" "user1" "host1"))
+ (add-to-list 'tramp-default-host-alist '("method2" "user2" "host2"))
+ (add-to-list 'tramp-default-host-alist '("method3" "user3" "host3"))
+ (should
+ (string-equal
+ (file-remote-p
+ (concat
+ "/[method1/user1@"
+ "|method2/user2@"
+ "|method3/user3@]/path/to/file"))
+ (format "/[%s/%s@%s|%s/%s@%s|%s/%s@%s]"
+ "method1" "user1" "host1"
+ "method2" "user2" "host2"
+ "method3" "user3" "host3")))
+
+ ;; Ad-hoc user name and host name expansion.
+ (setq tramp-default-method-alist nil
+ tramp-default-user-alist nil
+ tramp-default-host-alist nil)
+ (should
+ (string-equal
+ (file-remote-p
+ (concat
+ "/[method1/user1@host1"
+ "|method2/user2@"
+ "|method3/user3@]/path/to/file"))
+ (format "/[%s/%s@%s|%s/%s@%s|%s/%s@%s]"
+ "method1" "user1" "host1"
+ "method2" "user2" "host1"
+ "method3" "user3" "host1")))
+ (should
+ (string-equal
+ (file-remote-p
+ (concat
+ "/[method1/%u@%h"
+ "|method2/user2@host2"
+ "|method3/%u@%h"
+ "|method4/user4%domain4@host4#1234]/path/to/file"))
+ (format "/[%s/%s@%s|%s/%s@%s|%s/%s@%s|%s/%s@%s]"
+ "method1" "user2" "host2"
+ "method2" "user2" "host2"
+ "method3" "user4" "host4"
+ "method4" "user4%domain4" "host4#1234"))))
;; Exit.
(tramp-change-syntax syntax))))
@@ -1551,57 +1830,126 @@ handled properly. BODY shall not contain a timeout."
(should (string-equal (file-remote-p "/-:ftp.host:" 'method) "ftp"))
(dolist (u '("ftp" "anonymous"))
(should (string-equal (file-remote-p (format "/-:%s@:" u) 'method) "ftp")))
- ;; Default values in tramp-gvfs.el.
- (when (and (load "tramp-gvfs" 'noerror 'nomessage)
- (symbol-value 'tramp-gvfs-enabled))
- (should (string-equal (file-remote-p "/synce::" 'user) nil)))
- ;; Default values in tramp-sh.el.
+ ;; Default values in tramp-sh.el and tramp-sudoedit.el.
(dolist (h `("127.0.0.1" "[::1]" "localhost" "localhost6" ,(system-name)))
(should
(string-equal (file-remote-p (format "/-:root@%s:" h) 'method) "su")))
- (dolist (m '("su" "sudo" "ksu"))
- (should (string-equal (file-remote-p (format "/%s::" m) 'user) "root")))
- (dolist (m '("rcp" "remcp" "rsh" "telnet" "krlogin" "fcp"))
+ (dolist (m '("su" "sudo" "ksu" "doas" "sudoedit"))
+ (should (string-equal (file-remote-p (format "/%s::" m) 'user) "root"))
+ (should
+ (string-equal (file-remote-p (format "/%s::" m) 'host) (system-name))))
+ (dolist (m '("rcp" "remcp" "rsh" "telnet" "krlogin" "fcp" "nc"))
(should
(string-equal (file-remote-p (format "/%s::" m) 'user) (user-login-name))))
;; Default values in tramp-smb.el.
(should (string-equal (file-remote-p "/smb::" 'user) nil)))
+;; The following test is inspired by Bug#30946.
+(ert-deftest tramp-test03-file-name-host-rules ()
+ "Check host name rules for host-less methods."
+ (skip-unless (tramp--test-enabled))
+ (skip-unless (tramp--test-sh-p))
+ ;; `user-error' has appeared in Emacs 24.3.
+ (skip-unless (fboundp 'user-error))
+
+ ;; Host names must match rules in case the command template of a
+ ;; method doesn't use them.
+ (dolist (m '("su" "sg" "sudo" "doas" "ksu"))
+ (let ((vec (tramp-dissect-file-name tramp-test-temporary-file-directory))
+ tramp-connection-properties tramp-default-proxies-alist)
+ (ignore-errors (tramp-cleanup-connection vec nil 'keep-password))
+ ;; Single hop. The host name must match `tramp-local-host-regexp'.
+ (should-error
+ (find-file (format "/%s:foo:" m))
+ :type 'user-error)
+ ;; Multi hop. The host name must match the previous hop.
+ (should-error
+ (find-file
+ (format
+ "%s|%s:foo:"
+ (substring (file-remote-p tramp-test-temporary-file-directory) 0 -1)
+ m))
+ :type 'user-error))))
+
+(ert-deftest tramp-test03-file-name-method-rules ()
+ "Check file name rules for some methods."
+ (skip-unless (tramp--test-enabled))
+ ;; `user-error' has appeared in Emacs 24.3.
+ (skip-unless (fboundp 'user-error))
+
+ ;; Multi hops are allowed for inline methods only.
+ (should-error
+ (file-remote-p "/ssh:user1@host1|method:user2@host2:/path/to/file")
+ :type 'user-error)
+ (should-error
+ (file-remote-p "/method:user1@host1|ssh:user2@host2:/path/to/file")
+ :type 'user-error)
+
+ ;; Samba does not support file names with periods followed by
+ ;; spaces, and trailing periods or spaces.
+ (when (tramp-smb-file-name-p tramp-test-temporary-file-directory)
+ (dolist (file '("foo." "foo. bar" "foo "))
+ (should-error
+ (tramp-smb-get-localname
+ (tramp-dissect-file-name
+ (expand-file-name file tramp-test-temporary-file-directory)))
+ :type 'file-error))))
+
(ert-deftest tramp-test04-substitute-in-file-name ()
"Check `substitute-in-file-name'."
- (should (string-equal (substitute-in-file-name "/method:host://foo") "/foo"))
+ (should (string-equal (substitute-in-file-name "/method:host:///foo") "/foo"))
(should
(string-equal
- (substitute-in-file-name "/method:host:/path//foo") "/method:host:/foo"))
+ (substitute-in-file-name "/method:host://foo") "/method:host:/foo"))
(should
(string-equal (substitute-in-file-name "/method:host:/path///foo") "/foo"))
+ (should
+ (string-equal
+ (substitute-in-file-name "/method:host:/path//foo") "/method:host:/foo"))
;; Quoting local part.
(should
(string-equal
- (substitute-in-file-name "/method:host:/://foo") "/method:host:/://foo"))
+ (substitute-in-file-name "/method:host:/:///foo") "/method:host:/:///foo"))
(should
(string-equal
- (substitute-in-file-name "/method:host:/:/path//foo")
- "/method:host:/:/path//foo"))
+ (substitute-in-file-name "/method:host:/://foo") "/method:host:/://foo"))
(should
(string-equal
(substitute-in-file-name "/method:host:/:/path///foo")
"/method:host:/:/path///foo"))
+ (should
+ (string-equal
+ (substitute-in-file-name "/method:host:/:/path//foo")
+ "/method:host:/:/path//foo"))
(should
+ (string-equal (substitute-in-file-name "/method:host://~foo") "/~foo"))
+ (should
(string-equal
- (substitute-in-file-name "/method:host:/path/~/foo") "/method:host:~/foo"))
+ (substitute-in-file-name "/method:host:/~foo") "/method:host:/~foo"))
+ (should
+ (string-equal (substitute-in-file-name "/method:host:/path//~foo") "/~foo"))
+ ;; (substitute-in-file-name "/path/~foo") expands only for a local
+ ;; user "foo" to "/~foo"". Otherwise, it doesn't expand.
(should
- (string-equal (substitute-in-file-name "/method:host:/path//~/foo") "~/foo"))
+ (string-equal
+ (substitute-in-file-name
+ "/method:host:/path/~foo") "/method:host:/path/~foo"))
;; Quoting local part.
(should
(string-equal
- (substitute-in-file-name "/method:host:/:/path/~/foo")
- "/method:host:/:/path/~/foo"))
+ (substitute-in-file-name "/method:host:/://~foo") "/method:host:/://~foo"))
+ (should
+ (string-equal
+ (substitute-in-file-name "/method:host:/:/~foo") "/method:host:/:/~foo"))
(should
(string-equal
- (substitute-in-file-name "/method:host:/:/path//~/foo")
- "/method:host:/:/path//~/foo"))
+ (substitute-in-file-name
+ "/method:host:/:/path//~foo") "/method:host:/:/path//~foo"))
+ (should
+ (string-equal
+ (substitute-in-file-name
+ "/method:host:/:/path/~foo") "/method:host:/:/path/~foo"))
(let (process-environment)
(should
@@ -1640,6 +1988,18 @@ handled properly. BODY shall not contain a timeout."
(should
(string-equal
(expand-file-name "/method:host:/path/../file") "/method:host:/file"))
+ (should
+ (string-equal
+ (expand-file-name "/method:host:/path/.") "/method:host:/path"))
+ (should
+ (string-equal
+ (expand-file-name "/method:host:/path/..") "/method:host:/"))
+ (should
+ (string-equal
+ (expand-file-name "." "/method:host:/path/") "/method:host:/path"))
+ (should
+ (string-equal
+ (expand-file-name "" "/method:host:/path/") "/method:host:/path"))
;; Quoting local part.
(should
(string-equal
@@ -1653,16 +2013,17 @@ handled properly. BODY shall not contain a timeout."
(expand-file-name "/method:host:/:/~/path/./file")
"/method:host:/:/~/path/file")))
-;; The following test is inspired by Bug#26911. It is rather a bug in
-;; `expand-file-name', and it fails for all Emacs versions. Test
-;; added for later, when it is fixed.
+;; The following test is inspired by Bug#26911 and Bug#34834. They
+;; are rather bugs in `expand-file-name', and it fails for all Emacs
+;; versions. Test added for later, when they are fixed.
(ert-deftest tramp-test05-expand-file-name-relative ()
"Check `expand-file-name'."
;; Mark as failed until bug has been fixed.
:expected-result :failed
(skip-unless (tramp--test-enabled))
+
;; These are the methods the test doesn't fail.
- (when (or (tramp--test-adb-p) (tramp--test-gvfs-p)
+ (when (or (tramp--test-adb-p) (tramp--test-gvfs-p) (tramp--test-rclone-p)
(tramp-smb-file-name-p tramp-test-temporary-file-directory))
(setf (ert-test-expected-result-type
(ert-get-test 'tramp-test05-expand-file-name-relative))
@@ -1709,6 +2070,14 @@ This checks also `file-name-as-directory', `file-name-directory',
(file-name-directory "/method:host:/path/to/file/")
"/method:host:/path/to/file/"))
(should
+ (string-equal (file-name-directory "/method:host:file") "/method:host:"))
+ (should
+ (string-equal
+ (file-name-directory "/method:host:path/") "/method:host:path/"))
+ (should
+ (string-equal
+ (file-name-directory "/method:host:path/to") "/method:host:path/"))
+ (should
(string-equal (file-name-nondirectory "/method:host:/path/to/file") "file"))
(should
(string-equal (file-name-nondirectory "/method:host:/path/to/file/") ""))
@@ -1721,7 +2090,8 @@ This checks also `file-name-as-directory', `file-name-directory',
;; We must clear `tramp-default-method'. On hydra, it is "ftp",
;; which ruins the tests.
(let ((non-essential n-e)
- tramp-default-method)
+ (tramp-default-method
+ (file-remote-p tramp-test-temporary-file-directory 'method)))
(dolist
(file
`(,(format
@@ -1743,7 +2113,7 @@ This checks also `file-name-as-directory', `file-name-directory',
"Check `file-exist-p', `write-region' and `delete-file'."
(skip-unless (tramp--test-enabled))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let ((tmp-name (tramp--test-make-temp-name nil quoted)))
(should-not (file-exists-p tmp-name))
(write-region "foo" nil tmp-name)
@@ -1755,7 +2125,7 @@ This checks also `file-name-as-directory', `file-name-directory',
"Check `file-local-copy'."
(skip-unless (tramp--test-enabled))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let ((tmp-name1 (tramp--test-make-temp-name nil quoted))
tmp-name2)
(unwind-protect
@@ -1787,7 +2157,7 @@ This checks also `file-name-as-directory', `file-name-directory',
"Check `insert-file-contents'."
(skip-unless (tramp--test-enabled))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let ((tmp-name (tramp--test-make-temp-name nil quoted)))
(unwind-protect
(with-temp-buffer
@@ -1815,7 +2185,7 @@ This checks also `file-name-as-directory', `file-name-directory',
"Check `write-region'."
(skip-unless (tramp--test-enabled))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let ((tmp-name (tramp--test-make-temp-name nil quoted)))
(unwind-protect
(progn
@@ -1905,7 +2275,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(skip-unless (tramp--test-enabled))
;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579.
- (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs27-p))
+ (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p))
'(nil t) '(nil)))
(let ((tmp-name1 (tramp--test-make-temp-name nil quoted))
(tmp-name2 (tramp--test-make-temp-name nil quoted))
@@ -1930,9 +2300,10 @@ This checks also `file-name-as-directory', `file-name-directory',
(with-temp-buffer
(insert-file-contents target)
(should (string-equal (buffer-string) "foo")))
- (should-error
- (copy-file source target)
- :type 'file-already-exists)
+ (when (tramp--test-expensive-test)
+ (should-error
+ (copy-file source target)
+ :type 'file-already-exists))
(copy-file source target 'ok))
;; Cleanup.
@@ -1941,13 +2312,15 @@ This checks also `file-name-as-directory', `file-name-directory',
;; Copy file to directory.
(unwind-protect
- (progn
+ ;; FIXME: This fails on my QNAP server, see
+ ;; /share/Web/owncloud/data/owncloud.log
+ (unless (tramp--test-nextcloud-p)
(write-region "foo" nil source)
(should (file-exists-p source))
(make-directory target)
(should (file-directory-p target))
;; This has been changed in Emacs 26.1.
- (when (tramp--test-emacs26-p)
+ (when (and (tramp--test-expensive-test) (tramp--test-emacs26-p))
(should-error
(copy-file source target)
:type 'file-already-exists))
@@ -1962,7 +2335,11 @@ This checks also `file-name-as-directory', `file-name-directory',
;; Copy directory to existing directory.
(unwind-protect
- (progn
+ ;; FIXME: This fails on my QNAP server, see
+ ;; /share/Web/owncloud/data/owncloud.log
+ (unless (and (tramp--test-nextcloud-p)
+ (or (not (file-remote-p source))
+ (not (file-remote-p target))))
(make-directory source)
(should (file-directory-p source))
(write-region "foo" nil (expand-file-name "foo" source))
@@ -1983,7 +2360,10 @@ This checks also `file-name-as-directory', `file-name-directory',
;; Copy directory/file to non-existing directory.
(unwind-protect
- (progn
+ ;; FIXME: This fails on my QNAP server, see
+ ;; /share/Web/owncloud/data/owncloud.log
+ (unless
+ (and (tramp--test-nextcloud-p) (not (file-remote-p source)))
(make-directory source)
(should (file-directory-p source))
(write-region "foo" nil (expand-file-name "foo" source))
@@ -2007,7 +2387,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(skip-unless (tramp--test-enabled))
;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579.
- (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs27-p))
+ (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p))
'(nil t) '(nil)))
(let ((tmp-name1 (tramp--test-make-temp-name nil quoted))
(tmp-name2 (tramp--test-make-temp-name nil quoted))
@@ -2035,9 +2415,10 @@ This checks also `file-name-as-directory', `file-name-directory',
(should (string-equal (buffer-string) "foo")))
(write-region "foo" nil source)
(should (file-exists-p source))
- (should-error
- (rename-file source target)
- :type 'file-already-exists)
+ (when (tramp--test-expensive-test)
+ (should-error
+ (rename-file source target)
+ :type 'file-already-exists))
(rename-file source target 'ok)
(should-not (file-exists-p source)))
@@ -2053,7 +2434,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(make-directory target)
(should (file-directory-p target))
;; This has been changed in Emacs 26.1.
- (when (tramp--test-emacs26-p)
+ (when (and (tramp--test-expensive-test) (tramp--test-emacs26-p))
(should-error
(rename-file source target)
:type 'file-already-exists))
@@ -2069,7 +2450,9 @@ This checks also `file-name-as-directory', `file-name-directory',
;; Rename directory to existing directory.
(unwind-protect
- (progn
+ ;; FIXME: This fails on my QNAP server, see
+ ;; /share/Web/owncloud/data/owncloud.log
+ (unless (tramp--test-nextcloud-p)
(make-directory source)
(should (file-directory-p source))
(write-region "foo" nil (expand-file-name "foo" source))
@@ -2091,7 +2474,9 @@ This checks also `file-name-as-directory', `file-name-directory',
;; Rename directory/file to non-existing directory.
(unwind-protect
- (progn
+ ;; FIXME: This fails on my QNAP server, see
+ ;; /share/Web/owncloud/data/owncloud.log
+ (unless (tramp--test-nextcloud-p)
(make-directory source)
(should (file-directory-p source))
(write-region "foo" nil (expand-file-name "foo" source))
@@ -2116,7 +2501,7 @@ This checks also `file-name-as-directory', `file-name-directory',
This tests also `file-directory-p' and `file-accessible-directory-p'."
(skip-unless (tramp--test-enabled))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let* ((tmp-name1 (tramp--test-make-temp-name nil quoted))
(tmp-name2 (expand-file-name "foo/bar" tmp-name1)))
(unwind-protect
@@ -2139,7 +2524,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
"Check `delete-directory'."
(skip-unless (tramp--test-enabled))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let ((tmp-name (tramp--test-make-temp-name nil quoted)))
;; Delete empty directory.
(make-directory tmp-name)
@@ -2159,7 +2544,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
"Check `copy-directory'."
(skip-unless (tramp--test-enabled))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let* ((tmp-name1 (tramp--test-make-temp-name nil quoted))
(tmp-name2 (tramp--test-make-temp-name nil quoted))
(tmp-name3 (expand-file-name
@@ -2225,7 +2610,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
"Check `directory-files'."
(skip-unless (tramp--test-enabled))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let* ((tmp-name1 (tramp--test-make-temp-name nil quoted))
(tmp-name2 (expand-file-name "bla" tmp-name1))
(tmp-name3 (expand-file-name "foo" tmp-name1)))
@@ -2258,7 +2643,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
"Check `file-expand-wildcards'."
(skip-unless (tramp--test-enabled))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let* ((tmp-name1 (tramp--test-make-temp-name nil quoted))
(tmp-name2 (expand-file-name "foo" tmp-name1))
(tmp-name3 (expand-file-name "bar" tmp-name1))
@@ -2322,7 +2707,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
"Check `insert-directory'."
(skip-unless (tramp--test-enabled))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let* ((tmp-name1
(expand-file-name (tramp--test-make-temp-name nil quoted)))
(tmp-name2 (expand-file-name "foo" tmp-name1))
@@ -2370,7 +2755,14 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(format
"\\(.+ %s\\( ->.+\\)?\n\\)\\{%d\\}"
(regexp-opt (directory-files tmp-name1))
- (length (directory-files tmp-name1))))))))
+ (length (directory-files tmp-name1)))))))
+
+ ;; Check error case. We do not check for the error type,
+ ;; because ls-lisp returns `file-error', and native Tramp
+ ;; returns `file-missing'.
+ (delete-directory tmp-name1 'recursive)
+ (with-temp-buffer
+ (should-error (insert-directory tmp-name1 nil))))
;; Cleanup.
(ignore-errors (delete-directory tmp-name1 'recursive))))))
@@ -2383,7 +2775,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
;; Since Emacs 26.1.
(skip-unless (fboundp 'insert-directory-wildcard-in-dir-p))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let* ((tmp-name1
(expand-file-name (tramp--test-make-temp-name nil quoted)))
(tmp-name2
@@ -2392,7 +2784,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(tmp-name4 (expand-file-name "bar" tmp-name2))
(tramp-test-temporary-file-directory
(funcall
- (if quoted 'tramp-compat-file-name-quote 'identity)
+ (if quoted #'tramp-compat-file-name-quote #'identity)
tramp-test-temporary-file-directory))
buffer)
(unwind-protect
@@ -2496,11 +2888,11 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(ert-deftest tramp-test18-file-attributes ()
"Check `file-attributes'.
-This tests also `file-readable-p', `file-regular-p' and
-`file-ownership-preserved-p'."
+This tests also `access-file', `file-readable-p',
+`file-regular-p' and `file-ownership-preserved-p'."
(skip-unless (tramp--test-enabled))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
;; We must use `file-truename' for the temporary directory,
;; because it could be located on a symlinked directory. This
;; would let the test fail.
@@ -2518,6 +2910,9 @@ This tests also `file-readable-p', `file-regular-p' and
attr)
(unwind-protect
(progn
+ (should-error
+ (access-file tmp-name1 "error")
+ :type tramp-file-missing)
;; `file-ownership-preserved-p' should return t for
;; non-existing files. It is implemented only in tramp-sh.el.
(when (tramp--test-sh-p)
@@ -2526,6 +2921,7 @@ This tests also `file-readable-p', `file-regular-p' and
(should (file-exists-p tmp-name1))
(should (file-readable-p tmp-name1))
(should (file-regular-p tmp-name1))
+ (should-not (access-file tmp-name1 "error"))
(when (tramp--test-sh-p)
(should (file-ownership-preserved-p tmp-name1 'group)))
@@ -2550,18 +2946,22 @@ This tests also `file-readable-p', `file-regular-p' and
(should (stringp (nth 3 attr))) ;; Gid.
(tramp--test-ignore-make-symbolic-link-error
+ (should-error
+ (access-file tmp-name2 "error")
+ :type tramp-file-missing)
(when (tramp--test-sh-p)
(should (file-ownership-preserved-p tmp-name2 'group)))
(make-symbolic-link tmp-name1 tmp-name2)
(should (file-exists-p tmp-name2))
(should (file-symlink-p tmp-name2))
+ (should-not (access-file tmp-name2 "error"))
(when (tramp--test-sh-p)
(should (file-ownership-preserved-p tmp-name2 'group)))
(setq attr (file-attributes tmp-name2))
(should
(string-equal
(funcall
- (if quoted 'tramp-compat-file-name-quote 'identity)
+ (if quoted #'tramp-compat-file-name-quote #'identity)
(car attr))
(file-remote-p (file-truename tmp-name1) 'localname)))
(delete-file tmp-name2))
@@ -2593,6 +2993,7 @@ This tests also `file-readable-p', `file-regular-p' and
(should (file-exists-p tmp-name1))
(should (file-readable-p tmp-name1))
(should-not (file-regular-p tmp-name1))
+ (should-not (access-file tmp-name1 ""))
(when (tramp--test-sh-p)
(should (file-ownership-preserved-p tmp-name1 'group)))
(setq attr (file-attributes tmp-name1))
@@ -2603,11 +3004,18 @@ This tests also `file-readable-p', `file-regular-p' and
(ignore-errors (delete-file tmp-name1))
(ignore-errors (delete-file tmp-name2))))))
+(defsubst tramp--test-file-attributes-equal-p (attr1 attr2)
+ "Check, whether file attributes ATTR1 and ATTR2 are equal.
+They might differ only in access time."
+ (setcar (nthcdr 4 attr1) tramp-time-dont-know)
+ (setcar (nthcdr 4 attr2) tramp-time-dont-know)
+ (equal attr1 attr2))
+
(ert-deftest tramp-test19-directory-files-and-attributes ()
"Check `directory-files-and-attributes'."
(skip-unless (tramp--test-enabled))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
;; `directory-files-and-attributes' contains also values for
;; "../". Ensure that this doesn't change during tests, for
;; example due to handling temporary files.
@@ -2629,20 +3037,23 @@ This tests also `file-readable-p', `file-regular-p' and
;; able to return the date correctly. They say "don't know".
(dolist (elt attr)
(unless
- (equal
+ (tramp-compat-time-equal-p
(nth
5 (file-attributes (expand-file-name (car elt) tmp-name2)))
- '(0 0))
+ tramp-time-dont-know)
(should
- (equal (file-attributes (expand-file-name (car elt) tmp-name2))
- (cdr elt)))))
+ (tramp--test-file-attributes-equal-p
+ (file-attributes (expand-file-name (car elt) tmp-name2))
+ (cdr elt)))))
(setq attr (directory-files-and-attributes tmp-name2 'full))
(dolist (elt attr)
- (unless (equal (nth 5 (file-attributes (car elt))) '(0 0))
+ (unless (tramp-compat-time-equal-p
+ (nth 5 (file-attributes (car elt))) tramp-time-dont-know)
(should
- (equal (file-attributes (car elt)) (cdr elt)))))
+ (tramp--test-file-attributes-equal-p
+ (file-attributes (car elt)) (cdr elt)))))
(setq attr (directory-files-and-attributes tmp-name2 nil "^b"))
- (should (equal (mapcar 'car attr) '("bar" "boz"))))
+ (should (equal (mapcar #'car attr) '("bar" "boz"))))
;; Cleanup.
(ignore-errors (delete-directory tmp-name1 'recursive))))))
@@ -2651,9 +3062,9 @@ This tests also `file-readable-p', `file-regular-p' and
"Check `file-modes'.
This tests also `file-executable-p', `file-writable-p' and `set-file-modes'."
(skip-unless (tramp--test-enabled))
- (skip-unless (tramp--test-sh-p))
+ (skip-unless (or (tramp--test-sh-p) (tramp--test-sudoedit-p)))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let ((tmp-name (tramp--test-make-temp-name nil quoted)))
(unwind-protect
(progn
@@ -2673,15 +3084,27 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'."
;; Cleanup.
(ignore-errors (delete-file tmp-name))))))
+;; Method "smb" could run into "NT_STATUS_REVISION_MISMATCH" error.
+(defmacro tramp--test-ignore-add-name-to-file-error (&rest body)
+ "Run BODY, ignoring \"error with add-name-to-file\" file error."
+ (declare (indent defun) (debug t))
+ `(condition-case err
+ (progn ,@body)
+ ((error quit debug)
+ (unless (and (eq (car err) 'file-error)
+ (string-match "^error with add-name-to-file"
+ (error-message-string err)))
+ (signal (car err) (cdr err))))))
+
(ert-deftest tramp-test21-file-links ()
"Check `file-symlink-p'.
This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(skip-unless (tramp--test-enabled))
- ;; The semantics has changed heavily in Emacs 26.1. We cannot test
+ ;; The semantics have changed heavily in Emacs 26.1. We cannot test
;; older Emacsen, therefore.
(skip-unless (tramp--test-emacs26-p))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
;; We must use `file-truename' for the temporary directory,
;; because it could be located on a symlinked directory. This
;; would let the test fail.
@@ -2702,30 +3125,32 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(should
(string-equal
(funcall
- (if quoted 'tramp-compat-file-name-unquote 'identity)
+ (if quoted #'tramp-compat-file-name-unquote #'identity)
(file-remote-p tmp-name1 'localname))
(file-symlink-p tmp-name2)))
- (should-error
- (make-symbolic-link tmp-name1 tmp-name2)
- :type 'file-already-exists)
- ;; A number means interactive case.
- (cl-letf (((symbol-function 'yes-or-no-p) 'ignore))
+ (when (tramp--test-expensive-test)
(should-error
- (make-symbolic-link tmp-name1 tmp-name2 0)
+ (make-symbolic-link tmp-name1 tmp-name2)
:type 'file-already-exists))
+ (when (tramp--test-expensive-test)
+ ;; A number means interactive case.
+ (cl-letf (((symbol-function 'yes-or-no-p) #'ignore))
+ (should-error
+ (make-symbolic-link tmp-name1 tmp-name2 0)
+ :type 'file-already-exists)))
(cl-letf (((symbol-function 'yes-or-no-p) (lambda (_prompt) t)))
(make-symbolic-link tmp-name1 tmp-name2 0)
(should
(string-equal
(funcall
- (if quoted 'tramp-compat-file-name-unquote 'identity)
+ (if quoted #'tramp-compat-file-name-unquote #'identity)
(file-remote-p tmp-name1 'localname))
(file-symlink-p tmp-name2))))
(make-symbolic-link tmp-name1 tmp-name2 'ok-if-already-exists)
(should
(string-equal
(funcall
- (if quoted 'tramp-compat-file-name-unquote 'identity)
+ (if quoted #'tramp-compat-file-name-unquote #'identity)
(file-remote-p tmp-name1 'localname))
(file-symlink-p tmp-name2)))
;; If we use the local part of `tmp-name1', it shall still work.
@@ -2735,7 +3160,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(should
(string-equal
(funcall
- (if quoted 'tramp-compat-file-name-unquote 'identity)
+ (if quoted #'tramp-compat-file-name-unquote #'identity)
(file-remote-p tmp-name1 'localname))
(file-symlink-p tmp-name2)))
;; `tmp-name3' is a local file name. Therefore, the link
@@ -2747,14 +3172,15 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(string-equal tmp-name1 (file-symlink-p tmp-name3))))
;; Check directory as newname.
(make-directory tmp-name4)
- (should-error
- (make-symbolic-link tmp-name1 tmp-name4)
- :type 'file-already-exists)
+ (when (tramp--test-expensive-test)
+ (should-error
+ (make-symbolic-link tmp-name1 tmp-name4)
+ :type 'file-already-exists))
(make-symbolic-link tmp-name1 (file-name-as-directory tmp-name4))
(should
(string-equal
(funcall
- (if quoted 'tramp-compat-file-name-unquote 'identity)
+ (if quoted #'tramp-compat-file-name-unquote #'identity)
(file-remote-p tmp-name1 'localname))
(file-symlink-p tmp-name5)))
;; `smbclient' does not show symlinks in directories, so
@@ -2771,38 +3197,40 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
;; Check `add-name-to-file'.
(unwind-protect
- (unless (tramp-smb-file-name-p tramp-test-temporary-file-directory)
- (write-region "foo" nil tmp-name1)
- (should (file-exists-p tmp-name1))
- (add-name-to-file tmp-name1 tmp-name2)
- (should (file-regular-p tmp-name2))
- (should-error
+ (when (tramp--test-expensive-test)
+ (tramp--test-ignore-add-name-to-file-error
+ (write-region "foo" nil tmp-name1)
+ (should (file-exists-p tmp-name1))
(add-name-to-file tmp-name1 tmp-name2)
- :type 'file-already-exists)
- ;; A number means interactive case.
- (cl-letf (((symbol-function 'yes-or-no-p) 'ignore))
- (should-error
- (add-name-to-file tmp-name1 tmp-name2 0)
- :type 'file-already-exists))
- (cl-letf (((symbol-function 'yes-or-no-p) (lambda (_prompt) t)))
+ (should (file-regular-p tmp-name2))
+ (should-error
+ (add-name-to-file tmp-name1 tmp-name2)
+ :type 'file-already-exists)
+ ;; A number means interactive case.
+ (cl-letf (((symbol-function 'yes-or-no-p) #'ignore))
+ (should-error
+ (add-name-to-file tmp-name1 tmp-name2 0)
+ :type 'file-already-exists))
+ (cl-letf (((symbol-function 'yes-or-no-p) (lambda (_prompt) t)))
(add-name-to-file tmp-name1 tmp-name2 0)
(should (file-regular-p tmp-name2)))
- (add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists)
- (should-not (file-symlink-p tmp-name2))
- (should (file-regular-p tmp-name2))
- ;; `tmp-name3' is a local file name.
- (should-error
- (add-name-to-file tmp-name1 tmp-name3)
- :type 'file-error)
- ;; Check directory as newname.
- (make-directory tmp-name4)
- (should-error
- (add-name-to-file tmp-name1 tmp-name4)
- :type 'file-already-exists)
- (add-name-to-file tmp-name1 (file-name-as-directory tmp-name4))
- (should
- (file-regular-p
- (expand-file-name (file-name-nondirectory tmp-name1) tmp-name4))))
+ (add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists)
+ (should-not (file-symlink-p tmp-name2))
+ (should (file-regular-p tmp-name2))
+ ;; `tmp-name3' is a local file name.
+ (should-error
+ (add-name-to-file tmp-name1 tmp-name3)
+ :type 'file-error)
+ ;; Check directory as newname.
+ (make-directory tmp-name4)
+ (should-error
+ (add-name-to-file tmp-name1 tmp-name4)
+ :type 'file-already-exists)
+ (add-name-to-file tmp-name1 (file-name-as-directory tmp-name4))
+ (should
+ (file-regular-p
+ (expand-file-name
+ (file-name-nondirectory tmp-name1) tmp-name4)))))
;; Cleanup.
(ignore-errors
@@ -2836,7 +3264,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(delete-file tmp-name2)
(make-symbolic-link
(funcall
- (if quoted 'tramp-compat-file-name-unquote 'identity)
+ (if quoted #'tramp-compat-file-name-unquote #'identity)
"/penguin:motd:")
tmp-name2)
(should (file-symlink-p tmp-name2))
@@ -2882,12 +3310,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(string-equal
(file-truename tmp-name2)
(file-truename tmp-name3)))
- (should-error
- (with-temp-buffer (insert-file-contents tmp-name2))
- :type tramp-file-missing)
- (should-error
- (with-temp-buffer (insert-file-contents tmp-name3))
- :type tramp-file-missing)
+ (when (tramp--test-expensive-test)
+ (should-error
+ (with-temp-buffer (insert-file-contents tmp-name2))
+ :type tramp-file-missing))
+ (when (tramp--test-expensive-test)
+ (should-error
+ (with-temp-buffer (insert-file-contents tmp-name3))
+ :type tramp-file-missing))
;; `directory-files' does not show symlinks to
;; non-existing targets in the "smb" case. So we remove
;; the symlinks manually.
@@ -2900,32 +3330,42 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
;; Detect cyclic symbolic links.
(unwind-protect
- (tramp--test-ignore-make-symbolic-link-error
- (make-symbolic-link tmp-name2 tmp-name1)
- (should (file-symlink-p tmp-name1))
- (make-symbolic-link tmp-name1 tmp-name2)
- (should (file-symlink-p tmp-name2))
- (should-error (file-truename tmp-name1) :type 'file-error))
+ (when (tramp--test-expensive-test)
+ (tramp--test-ignore-make-symbolic-link-error
+ (make-symbolic-link tmp-name2 tmp-name1)
+ (should (file-symlink-p tmp-name1))
+ (if (tramp-smb-file-name-p tramp-test-temporary-file-directory)
+ ;; The symlink command of `smbclient' detects the
+ ;; cycle already.
+ (should-error
+ (make-symbolic-link tmp-name1 tmp-name2)
+ :type 'file-error)
+ (make-symbolic-link tmp-name1 tmp-name2)
+ (should (file-symlink-p tmp-name2))
+ (should-error (file-truename tmp-name1) :type 'file-error))))
;; Cleanup.
(ignore-errors
(delete-file tmp-name1)
(delete-file tmp-name2)))
- ;; `file-truename' shall preserve trailing link of directories.
- (unless (file-symlink-p tramp-test-temporary-file-directory)
- (let* ((dir1 (directory-file-name tramp-test-temporary-file-directory))
- (dir2 (file-name-as-directory dir1)))
- (should (string-equal (file-truename dir1) (expand-file-name dir1)))
- (should
- (string-equal (file-truename dir2) (expand-file-name dir2))))))))
+ ;; `file-truename' shall preserve trailing slash of directories.
+ (let* ((dir1
+ (directory-file-name
+ (funcall
+ (if quoted #'tramp-compat-file-name-quote #'identity)
+ tramp-test-temporary-file-directory)))
+ (dir2 (file-name-as-directory dir1)))
+ (should (string-equal (file-truename dir1) (expand-file-name dir1)))
+ (should (string-equal (file-truename dir2) (expand-file-name dir2)))))))
(ert-deftest tramp-test22-file-times ()
"Check `set-file-times' and `file-newer-than-file-p'."
(skip-unless (tramp--test-enabled))
- (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p)))
+ (skip-unless
+ (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sudoedit-p)))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let ((tmp-name1 (tramp--test-make-temp-name nil quoted))
(tmp-name2 (tramp--test-make-temp-name nil quoted))
(tmp-name3 (tramp--test-make-temp-name nil quoted)))
@@ -2934,15 +3374,15 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(write-region "foo" nil tmp-name1)
(should (file-exists-p tmp-name1))
(should (consp (nth 5 (file-attributes tmp-name1))))
- ;; '(0 0) means don't know, and will be replaced by
- ;; `current-time'. Therefore, we use '(0 1). We skip the
- ;; test, if the remote handler is not able to set the
- ;; correct time.
- (skip-unless (set-file-times tmp-name1 '(0 1)))
+ ;; Skip the test, if the remote handler is not able to set
+ ;; the correct time.
+ (skip-unless (set-file-times tmp-name1 (seconds-to-time 1)))
;; Dumb remote shells without perl(1) or stat(1) are not
;; able to return the date correctly. They say "don't know".
- (unless (equal (nth 5 (file-attributes tmp-name1)) '(0 0))
- (should (equal (nth 5 (file-attributes tmp-name1)) '(0 1)))
+ (unless (tramp-compat-time-equal-p
+ (nth 5 (file-attributes tmp-name1)) tramp-time-dont-know)
+ (should
+ (equal (nth 5 (file-attributes tmp-name1)) (seconds-to-time 1)))
(write-region "bla" nil tmp-name2)
(should (file-exists-p tmp-name2))
(should (file-newer-than-file-p tmp-name2 tmp-name1))
@@ -2959,7 +3399,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
"Check `set-visited-file-modtime' and `verify-visited-file-modtime'."
(skip-unless (tramp--test-enabled))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let ((tmp-name (tramp--test-make-temp-name nil quoted)))
(unwind-protect
(progn
@@ -2968,9 +3408,17 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(with-temp-buffer
(insert-file-contents tmp-name)
(should (verify-visited-file-modtime))
- (set-visited-file-modtime '(0 1))
+ (set-visited-file-modtime (seconds-to-time 1))
+ (should (verify-visited-file-modtime))
+ (should (= 1 (float-time (visited-file-modtime))))
+
+ ;; Checks with deleted file.
+ (delete-file tmp-name)
+ (dired-uncache tmp-name)
+ (should (verify-visited-file-modtime))
+ (set-visited-file-modtime (seconds-to-time 1))
(should (verify-visited-file-modtime))
- (should (equal (visited-file-modtime) '(0 1 0 0)))))
+ (should (= 1 (float-time (visited-file-modtime))))))
;; Cleanup.
(ignore-errors (delete-file tmp-name))))))
@@ -2982,7 +3430,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(skip-unless (file-acl tramp-test-temporary-file-directory))
;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579.
- (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs27-p))
+ (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p))
'(nil t) '(nil)))
(let ((tmp-name1 (tramp--test-make-temp-name nil quoted))
(tmp-name2 (tramp--test-make-temp-name nil quoted))
@@ -3060,7 +3508,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
'(nil nil nil nil))))
;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579.
- (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs27-p))
+ (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p))
'(nil t) '(nil)))
(let ((tmp-name1 (tramp--test-make-temp-name nil quoted))
(tmp-name2 (tramp--test-make-temp-name nil quoted))
@@ -3201,6 +3649,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(when (not (memq system-type '(cygwin windows-nt)))
(let ((method (file-remote-p tramp-test-temporary-file-directory 'method))
(host (file-remote-p tramp-test-temporary-file-directory 'host))
+ (vec (tramp-dissect-file-name tramp-test-temporary-file-directory))
(orig-syntax tramp-syntax))
(when (and (stringp host) (string-match tramp-host-with-port-regexp host))
(setq host (match-string 1 host)))
@@ -3208,9 +3657,13 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(unwind-protect
(dolist
(syntax
- (if tramp--test-expensive-test
+ (if (tramp--test-expensive-test)
(tramp-syntax-values) `(,orig-syntax)))
(tramp-change-syntax syntax)
+ ;; This has cleaned up all connection data, which are used
+ ;; for completion. We must refill the cache.
+ (tramp-set-connection-property vec "property" nil)
+
(let ;; This is needed for the `simplified' syntax.
((method-marker
(if (zerop (length tramp-method-regexp))
@@ -3259,7 +3712,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(tramp-change-syntax orig-syntax))))
(dolist (n-e '(nil t))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let ((non-essential n-e)
(tmp-name (tramp--test-make-temp-name nil quoted)))
@@ -3280,12 +3733,12 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(should-not (file-name-completion "a" tmp-name))
(should
(equal
- (file-name-completion "b" tmp-name 'file-directory-p) "boz/"))
+ (file-name-completion "b" tmp-name #'file-directory-p) "boz/"))
(should
(equal (file-name-all-completions "fo" tmp-name) '("foo")))
(should
(equal
- (sort (file-name-all-completions "b" tmp-name) 'string-lessp)
+ (sort (file-name-all-completions "b" tmp-name) #'string-lessp)
'("bold" "boz/")))
(should-not (file-name-all-completions "a" tmp-name))
;; `completion-regexp-list' restricts the completion to
@@ -3296,7 +3749,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(equal (file-name-completion "" tmp-name) "bo"))
(should
(equal
- (sort (file-name-all-completions "" tmp-name) 'string-lessp)
+ (sort (file-name-all-completions "" tmp-name) #'string-lessp)
'("bold" "boz/"))))
;; `file-name-completion' ignores file names that end in
;; any string in `completion-ignored-extensions'.
@@ -3311,7 +3764,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
;; `file-name-all-completions' is not affected.
(should
(equal
- (sort (file-name-all-completions "" tmp-name) 'string-lessp)
+ (sort (file-name-all-completions "" tmp-name) #'string-lessp)
'("../" "./" "bold" "boz/" "foo" "foo.ext")))))
;; Cleanup.
@@ -3321,7 +3774,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
"Check `load'."
(skip-unless (tramp--test-enabled))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let ((tmp-name (tramp--test-make-temp-name nil quoted)))
(unwind-protect
(progn
@@ -3346,7 +3799,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(skip-unless (tramp--test-enabled))
(skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p)))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let* ((tmp-name (tramp--test-make-temp-name nil quoted))
(fnnd (file-name-nondirectory tmp-name))
(default-directory tramp-test-temporary-file-directory)
@@ -3386,16 +3839,24 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
;; Cleanup.
(ignore-errors (delete-file tmp-name))))))
+;; Must be a command, because used as `sigusr' handler.
+(defun tramp--test-timeout-handler (&rest _ignore)
+ "Timeout handler, reporting a failed test."
+ (interactive)
+ (ert-fail (format "`%s' timed out" (ert-test-name (ert-running-test)))))
+
(ert-deftest tramp-test29-start-file-process ()
"Check `start-file-process'."
:tags '(:expensive-test)
(skip-unless (tramp--test-enabled))
- (skip-unless (tramp--test-sh-p))
+ (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p)))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let ((default-directory tramp-test-temporary-file-directory)
(tmp-name (tramp--test-make-temp-name nil quoted))
kill-buffer-query-functions proc)
+
+ ;; Simple process.
(unwind-protect
(with-temp-buffer
(setq proc (start-file-process "test1" (current-buffer) "cat"))
@@ -3404,14 +3865,17 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(process-send-string proc "foo")
(process-send-eof proc)
;; Read output.
- (with-timeout (10 (ert-fail "`start-file-process' timed out"))
+ (with-timeout (10 (tramp--test-timeout-handler))
(while (< (- (point-max) (point-min)) (length "foo"))
- (accept-process-output proc 0.1)))
- (should (string-equal (buffer-string) "foo")))
+ (while (accept-process-output proc 0 nil t))))
+ ;; We cannot use `string-equal', because tramp-adb.el
+ ;; echoes also the sent string.
+ (should (string-match "\\`foo" (buffer-string))))
;; Cleanup.
(ignore-errors (delete-process proc)))
+ ;; Simple process using a file.
(unwind-protect
(with-temp-buffer
(write-region "foo" nil tmp-name)
@@ -3422,9 +3886,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
"cat" (file-name-nondirectory tmp-name)))
(should (processp proc))
;; Read output.
- (with-timeout (10 (ert-fail "`start-file-process' timed out"))
+ (with-timeout (10 (tramp--test-timeout-handler))
(while (< (- (point-max) (point-min)) (length "foo"))
- (accept-process-output proc 0.1)))
+ (while (accept-process-output proc 0 nil t))))
(should (string-equal (buffer-string) "foo")))
;; Cleanup.
@@ -3432,6 +3896,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(delete-process proc)
(delete-file tmp-name)))
+ ;; Process filter.
(unwind-protect
(with-temp-buffer
(setq proc (start-file-process "test3" (current-buffer) "cat"))
@@ -3443,15 +3908,151 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(process-send-string proc "foo")
(process-send-eof proc)
;; Read output.
- (with-timeout (10 (ert-fail "`start-file-process' timed out"))
+ (with-timeout (10 (tramp--test-timeout-handler))
(while (< (- (point-max) (point-min)) (length "foo"))
- (accept-process-output proc 0.1)))
- (should (string-equal (buffer-string) "foo")))
+ (while (accept-process-output proc 0 nil t))))
+ ;; We cannot use `string-equal', because tramp-adb.el
+ ;; echoes also the sent string.
+ (should (string-match "\\`foo" (buffer-string))))
;; Cleanup.
(ignore-errors (delete-process proc))))))
-(ert-deftest tramp-test30-interrupt-process ()
+(ert-deftest tramp-test30-make-process ()
+ "Check `make-process'."
+ :tags '(:expensive-test)
+ (skip-unless (tramp--test-enabled))
+ (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p)))
+ ;; `make-process' supports file name handlers since Emacs 27.
+ (skip-unless (tramp--test-emacs27-p))
+
+ (tramp--test-instrument-test-case 0
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
+ (let ((default-directory tramp-test-temporary-file-directory)
+ (tmp-name (tramp--test-make-temp-name nil quoted))
+ kill-buffer-query-functions proc)
+ (should-not (make-process))
+
+ ;; Simple process.
+ (unwind-protect
+ (with-temp-buffer
+ (setq proc
+ (make-process
+ :name "test1" :buffer (current-buffer) :command '("cat")
+ :file-handler t))
+ (should (processp proc))
+ (should (equal (process-status proc) 'run))
+ (process-send-string proc "foo")
+ (process-send-eof proc)
+ ;; Read output.
+ (with-timeout (10 (tramp--test-timeout-handler))
+ (while (< (- (point-max) (point-min)) (length "foo"))
+ (while (accept-process-output proc 0 nil t))))
+ ;; We cannot use `string-equal', because tramp-adb.el
+ ;; echoes also the sent string.
+ (should (string-match "\\`foo" (buffer-string))))
+
+ ;; Cleanup.
+ (ignore-errors (delete-process proc)))
+
+ ;; Simple process using a file.
+ (unwind-protect
+ (with-temp-buffer
+ (write-region "foo" nil tmp-name)
+ (should (file-exists-p tmp-name))
+ (setq proc
+ (make-process
+ :name "test2" :buffer (current-buffer)
+ :command `("cat" ,(file-name-nondirectory tmp-name))
+ :file-handler t))
+ (should (processp proc))
+ ;; Read output.
+ (with-timeout (10 (tramp--test-timeout-handler))
+ (while (< (- (point-max) (point-min)) (length "foo"))
+ (while (accept-process-output proc 0 nil t))))
+ (should (string-equal (buffer-string) "foo")))
+
+ ;; Cleanup.
+ (ignore-errors
+ (delete-process proc)
+ (delete-file tmp-name)))
+
+ ;; Process filter.
+ (unwind-protect
+ (with-temp-buffer
+ (setq proc
+ (make-process
+ :name "test3" :buffer (current-buffer) :command '("cat")
+ :filter
+ (lambda (p s)
+ (with-current-buffer (process-buffer p) (insert s)))
+ :file-handler t))
+ (should (processp proc))
+ (should (equal (process-status proc) 'run))
+ (process-send-string proc "foo")
+ (process-send-eof proc)
+ ;; Read output.
+ (with-timeout (10 (tramp--test-timeout-handler))
+ (while (not (string-match "foo" (buffer-string)))
+ (while (accept-process-output proc 0 nil t))))
+ ;; We cannot use `string-equal', because tramp-adb.el
+ ;; echoes also the sent string.
+ (should (string-match "\\`foo" (buffer-string))))
+
+ ;; Cleanup.
+ (ignore-errors (delete-process proc)))
+
+ ;; Process sentinel.
+ (unwind-protect
+ (with-temp-buffer
+ (setq proc
+ (make-process
+ :name "test4" :buffer (current-buffer) :command '("cat")
+ :sentinel
+ (lambda (p s)
+ (with-current-buffer (process-buffer p) (insert s)))
+ :file-handler t))
+ (should (processp proc))
+ (should (equal (process-status proc) 'run))
+ (process-send-string proc "foo")
+ (process-send-eof proc)
+ (delete-process proc)
+ ;; Read output.
+ (with-timeout (10 (tramp--test-timeout-handler))
+ (while (accept-process-output proc 0 nil t)))
+ ;; We cannot use `string-equal', because tramp-adb.el
+ ;; echoes also the sent string.
+ (should (string-match "killed\n\\'" (buffer-string))))
+
+ ;; Cleanup.
+ (ignore-errors (delete-process proc)))
+
+ ;; Process with stderr. tramp-adb.el doesn't support it (yet).
+ (unless (tramp--test-adb-p)
+ (let ((stderr
+ (generate-new-buffer (generate-new-buffer-name "stderr"))))
+ (unwind-protect
+ (with-temp-buffer
+ (setq proc
+ (make-process
+ :name "test5" :buffer (current-buffer)
+ :command '("cat" "/")
+ :stderr stderr
+ :file-handler t))
+ (should (processp proc))
+ ;; Read stderr.
+ (with-current-buffer stderr
+ (with-timeout (10 (tramp--test-timeout-handler))
+ (while (= (point-min) (point-max))
+ (while (accept-process-output proc 0 nil t))))
+ (should
+ (string-match "^cat:.* Is a directory" (buffer-string)))))
+
+ ;; Cleanup.
+ (ignore-errors (delete-process proc))
+ (ignore-errors (kill-buffer stderr)))))))))
+
+(ert-deftest tramp-test31-interrupt-process ()
"Check `interrupt-process'."
:tags '(:expensive-test)
(skip-unless (tramp--test-enabled))
@@ -3470,7 +4071,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(should (numberp (process-get proc 'remote-pid)))
(should (interrupt-process proc))
;; Let the process accept the interrupt.
- (accept-process-output proc 1 nil 0)
+ (while (accept-process-output proc nil nil 0))
(should-not (process-live-p proc))
;; An interrupted process cannot be interrupted, again.
(should-error (interrupt-process proc) :type 'error))
@@ -3478,13 +4079,16 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
;; Cleanup.
(ignore-errors (delete-process proc)))))
-(ert-deftest tramp-test31-shell-command ()
+(ert-deftest tramp-test32-shell-command ()
"Check `shell-command'."
:tags '(:expensive-test)
(skip-unless (tramp--test-enabled))
- (skip-unless (tramp--test-sh-p))
+ ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for
+ ;; remote processes in Emacs. That doesn't work for tramp-adb.el.
+ (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p))
+ (tramp--test-sh-p)))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let ((tmp-name (tramp--test-make-temp-name nil quoted))
(default-directory tramp-test-temporary-file-directory)
;; Suppress nasty messages.
@@ -3518,11 +4122,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(format "ls %s" (file-name-nondirectory tmp-name))
(current-buffer))
;; Read output.
- (with-timeout (10 (ert-fail "`async-shell-command' timed out"))
- (while (< (- (point-max) (point-min))
- (1+ (length (file-name-nondirectory tmp-name))))
- (accept-process-output
- (get-buffer-process (current-buffer)) 0.1)))
+ (with-timeout (10 (tramp--test-timeout-handler))
+ (while (accept-process-output
+ (get-buffer-process (current-buffer)) nil nil t)))
;; `ls' could produce colorized output.
(goto-char (point-min))
(while
@@ -3549,11 +4151,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(get-buffer-process (current-buffer))
(format "%s\n" (file-name-nondirectory tmp-name)))
;; Read output.
- (with-timeout (10 (ert-fail "`async-shell-command' timed out"))
- (while (< (- (point-max) (point-min))
- (1+ (length (file-name-nondirectory tmp-name))))
- (accept-process-output
- (get-buffer-process (current-buffer)) 0.1)))
+ (with-timeout (10 (tramp--test-timeout-handler))
+ (while (accept-process-output
+ (get-buffer-process (current-buffer)) nil nil t)))
;; `ls' could produce colorized output.
(goto-char (point-min))
(while
@@ -3575,14 +4175,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
"Like `shell-command-to-string', but for asynchronous processes."
(with-temp-buffer
(async-shell-command command (current-buffer))
- (with-timeout (10)
- (while (get-buffer-process (current-buffer))
- (accept-process-output (get-buffer-process (current-buffer)) 0.1)))
- (accept-process-output nil 0.1)
+ (with-timeout
+ ((if (getenv "EMACS_EMBA_CI") 30 10) (tramp--test-timeout-handler))
+ (while (accept-process-output
+ (get-buffer-process (current-buffer)) nil nil t)))
(buffer-substring-no-properties (point-min) (point-max))))
;; This test is inspired by Bug#23952.
-(ert-deftest tramp-test32-environment-variables ()
+(ert-deftest tramp-test33-environment-variables ()
"Check that remote processes set / unset environment variables properly."
:tags '(:expensive-test)
(skip-unless (tramp--test-enabled))
@@ -3660,7 +4260,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(funcall this-shell-command-to-string "set")))))))))
;; This test is inspired by Bug#27009.
-(ert-deftest tramp-test32-environment-variables-and-port-numbers ()
+(ert-deftest tramp-test33-environment-variables-and-port-numbers ()
"Check that two connections with separate ports are different."
(skip-unless (tramp--test-enabled))
;; We test it only for the mock-up connection; otherwise there might
@@ -3695,12 +4295,81 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(dolist (dir '("/mock:localhost#11111:" "/mock:localhost#22222:"))
(tramp-cleanup-connection (tramp-dissect-file-name dir)))))
+;; Connection-local variables are enabled per default since Emacs 27.1.
+(ert-deftest tramp-test34-connection-local-variables ()
+ "Check that connection-local variables are enabled."
+ :tags '(:expensive-test)
+ (skip-unless (tramp--test-enabled))
+ ;; Since Emacs 27.1.
+ (skip-unless (fboundp 'with-connection-local-variables))
+
+ ;; `connection-local-set-profile-variables' and
+ ;; `connection-local-set-profiles' exist since Emacs 26.1. We don't
+ ;; want to see compiler warnings for older Emacsen.
+ (let* ((default-directory tramp-test-temporary-file-directory)
+ (tmp-name1 (tramp--test-make-temp-name))
+ (tmp-name2 (expand-file-name "foo" tmp-name1))
+ (enable-local-variables :all)
+ (enable-remote-dir-locals t)
+ kill-buffer-query-functions
+ connection-local-profile-alist connection-local-criteria-alist)
+ (unwind-protect
+ (progn
+ (make-directory tmp-name1)
+ (should (file-directory-p tmp-name1))
+
+ ;; `local-variable' is buffer-local due to explicit setting.
+ (with-no-warnings
+ (defvar-local local-variable 'buffer))
+ (with-temp-buffer
+ (should (eq local-variable 'buffer)))
+
+ ;; `local-variable' is connection-local due to Tramp.
+ (write-region "foo" nil tmp-name2)
+ (should (file-exists-p tmp-name2))
+ (with-no-warnings
+ (connection-local-set-profile-variables
+ 'local-variable-profile
+ '((local-variable . connect)))
+ (connection-local-set-profiles
+ `(:application tramp
+ :protocol ,(file-remote-p default-directory 'method)
+ :user ,(file-remote-p default-directory 'user)
+ :machine ,(file-remote-p default-directory 'host))
+ 'local-variable-profile))
+ (with-current-buffer (find-file-noselect tmp-name2)
+ (should (eq local-variable 'connect))
+ (kill-buffer (current-buffer)))
+
+ ;; `local-variable' is dir-local due to existence of .dir-locals.el.
+ (write-region
+ "((nil . ((local-variable . dir))))" nil
+ (expand-file-name ".dir-locals.el" tmp-name1))
+ (should (file-exists-p (expand-file-name ".dir-locals.el" tmp-name1)))
+ (with-current-buffer (find-file-noselect tmp-name2)
+ (should (eq local-variable 'dir))
+ (kill-buffer (current-buffer)))
+
+ ;; `local-variable' is file-local due to specifying as file variable.
+ (write-region
+ "-*- mode: comint; local-variable: file; -*-" nil tmp-name2)
+ (should (file-exists-p tmp-name2))
+ (with-current-buffer (find-file-noselect tmp-name2)
+ (should (eq local-variable 'file))
+ (kill-buffer (current-buffer))))
+
+ ;; Cleanup.
+ (ignore-errors (delete-directory tmp-name1 'recursive)))))
+
;; The functions were introduced in Emacs 26.1.
-(ert-deftest tramp-test33-explicit-shell-file-name ()
+(ert-deftest tramp-test34-explicit-shell-file-name ()
"Check that connection-local `explicit-shell-file-name' is set."
:tags '(:expensive-test)
(skip-unless (tramp--test-enabled))
- (skip-unless (tramp--test-sh-p))
+ ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for
+ ;; remote processes in Emacs. That doesn't work for tramp-adb.el.
+ (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p))
+ (tramp--test-sh-p)))
;; Since Emacs 26.1.
(skip-unless (and (fboundp 'connection-local-set-profile-variables)
(fboundp 'connection-local-set-profiles)))
@@ -3709,44 +4378,162 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
;; `connection-local-set-profiles' exist since Emacs 26.1. We don't
;; want to see compiler warnings for older Emacsen.
(let ((default-directory tramp-test-temporary-file-directory)
- explicit-shell-file-name kill-buffer-query-functions)
+ explicit-shell-file-name kill-buffer-query-functions
+ connection-local-profile-alist connection-local-criteria-alist)
(unwind-protect
(progn
;; `shell-mode' would ruin our test, because it deletes all
- ;; buffer local variables.
+ ;; buffer local variables. Not needed in Emacs 27.1.
(put 'explicit-shell-file-name 'permanent-local t)
- ;; Declare connection-local variable `explicit-shell-file-name'.
+ ;; Declare connection-local variables `explicit-shell-file-name'
+ ;; and `explicit-sh-args'.
(with-no-warnings
(connection-local-set-profile-variables
'remote-sh
- '((explicit-shell-file-name . "/bin/sh")
- (explicit-sh-args . ("-i"))))
+ `((explicit-shell-file-name
+ . ,(if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh"))
+ (explicit-sh-args . ("-c" "echo foo"))))
(connection-local-set-profiles
`(:application tramp
:protocol ,(file-remote-p default-directory 'method)
:user ,(file-remote-p default-directory 'user)
:machine ,(file-remote-p default-directory 'host))
'remote-sh))
+ (put 'explicit-shell-file-name 'safe-local-variable #'identity)
+ (put 'explicit-sh-args 'safe-local-variable #'identity)
- ;; Run interactive shell. Since the default directory is
- ;; remote, `explicit-shell-file-name' shall be set in order
- ;; to avoid a question.
+ ;; Run `shell' interactively. Since the default directory
+ ;; is remote, `explicit-shell-file-name' shall be set in
+ ;; 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)))
(should-not explicit-shell-file-name)
- (call-interactively 'shell)
- (should explicit-shell-file-name)))
+ (call-interactively #'shell)
+ (with-timeout (10)
+ (while (accept-process-output
+ (get-buffer-process (current-buffer)) nil nil t)))
+ (should (string-match "^foo$" (buffer-string)))))
+ ;; Cleanup.
(put 'explicit-shell-file-name 'permanent-local nil)
(kill-buffer "*shell*"))))
-(ert-deftest tramp-test34-vc-registered ()
+;; `exec-path' was introduced in Emacs 27.1. `executable-find' has
+;; changed the number of parameters, so we use `apply' for older
+;; Emacsen.
+(ert-deftest tramp-test35-exec-path ()
+ "Check `exec-path' and `executable-find'."
+ (skip-unless (tramp--test-enabled))
+ (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p)))
+ ;; Since Emacs 27.1.
+ (skip-unless (fboundp 'exec-path))
+
+ (let ((tmp-name (tramp--test-make-temp-name))
+ (default-directory tramp-test-temporary-file-directory))
+ (unwind-protect
+ (progn
+ (should (consp (with-no-warnings (exec-path))))
+ ;; Last element is the `exec-directory'.
+ (should
+ (string-equal
+ (car (last (with-no-warnings (exec-path))))
+ (file-remote-p default-directory 'localname)))
+ ;; The shell "sh" shall always exist.
+ (should (apply #'executable-find '("sh" remote)))
+ ;; Since the last element in `exec-path' is the current
+ ;; directory, an executable file in that directory will be
+ ;; found.
+ (write-region "foo" nil tmp-name)
+ (should (file-exists-p tmp-name))
+ (set-file-modes tmp-name #o777)
+ (should (file-executable-p tmp-name))
+ (should
+ (string-equal
+ (apply
+ #'executable-find `(,(file-name-nondirectory tmp-name) remote))
+ (file-remote-p tmp-name 'localname)))
+ (should-not
+ (apply
+ #'executable-find
+ `(,(concat (file-name-nondirectory tmp-name) "foo") remote))))
+
+ ;; Cleanup.
+ (ignore-errors (delete-file tmp-name)))))
+
+;; This test is inspired by Bug#33781.
+;; `exec-path' was introduced in Emacs 27.1. `executable-find' has
+;; changed the number of parameters, so we use `apply' for older
+;; Emacsen.
+(ert-deftest tramp-test35-remote-path ()
+ "Check loooong `tramp-remote-path'."
+ (skip-unless (tramp--test-enabled))
+ (skip-unless (tramp--test-sh-p))
+ ;; Since Emacs 27.1.
+ (skip-unless (fboundp 'exec-path))
+
+ (let* ((tmp-name (tramp--test-make-temp-name))
+ (default-directory tramp-test-temporary-file-directory)
+ (orig-exec-path (with-no-warnings (exec-path)))
+ (tramp-remote-path tramp-remote-path)
+ (orig-tramp-remote-path tramp-remote-path))
+ (unwind-protect
+ (progn
+ ;; Non existing directories are removed.
+ (setq tramp-remote-path
+ (cons (file-remote-p tmp-name 'localname) tramp-remote-path))
+ (tramp-cleanup-connection
+ (tramp-dissect-file-name tramp-test-temporary-file-directory)
+ 'keep-debug 'keep-password)
+ (should (equal (with-no-warnings (exec-path)) orig-exec-path))
+ (setq tramp-remote-path orig-tramp-remote-path)
+
+ ;; Double entries are removed.
+ (setq tramp-remote-path (append '("/" "/") tramp-remote-path))
+ (tramp-cleanup-connection
+ (tramp-dissect-file-name tramp-test-temporary-file-directory)
+ 'keep-debug 'keep-password)
+ (should
+ (equal (with-no-warnings (exec-path)) (cons "/" orig-exec-path)))
+ (setq tramp-remote-path orig-tramp-remote-path)
+
+ ;; We make a super long `tramp-remote-path'.
+ (make-directory tmp-name)
+ (should (file-directory-p tmp-name))
+ (while (< (length (mapconcat #'identity orig-exec-path ":")) 5000)
+ (let ((dir (make-temp-file (file-name-as-directory tmp-name) 'dir)))
+ (should (file-directory-p dir))
+ (setq tramp-remote-path
+ (cons (file-remote-p dir 'localname) tramp-remote-path)
+ orig-exec-path
+ (cons (file-remote-p dir 'localname) orig-exec-path))))
+ (tramp-cleanup-connection
+ (tramp-dissect-file-name tramp-test-temporary-file-directory)
+ 'keep-debug 'keep-password)
+ (should (equal (with-no-warnings (exec-path)) orig-exec-path))
+ (should
+ (string-equal
+ ;; Ignore trailing newline.
+ (substring (shell-command-to-string "echo $PATH") nil -1)
+ ;; The last element of `exec-path' is `exec-directory'.
+ (mapconcat #'identity (butlast orig-exec-path) ":")))
+ ;; The shell "sh" shall always exist.
+ (should (apply #'executable-find '("sh" remote))))
+
+ ;; Cleanup.
+ (tramp-cleanup-connection
+ (tramp-dissect-file-name tramp-test-temporary-file-directory)
+ 'keep-debug 'keep-password)
+ (setq tramp-remote-path orig-tramp-remote-path)
+ (ignore-errors (delete-directory tmp-name 'recursive)))))
+
+(ert-deftest tramp-test36-vc-registered ()
"Check `vc-registered'."
:tags '(:expensive-test)
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-sh-p))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let* ((default-directory tramp-test-temporary-file-directory)
(tmp-name1 (tramp--test-make-temp-name nil quoted))
(tmp-name2 (expand-file-name "foo" tmp-name1))
@@ -3810,11 +4597,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
;; Cleanup.
(ignore-errors (delete-directory tmp-name1 'recursive))))))
-(ert-deftest tramp-test35-make-auto-save-file-name ()
+(ert-deftest tramp-test37-make-auto-save-file-name ()
"Check `make-auto-save-file-name'."
(skip-unless (tramp--test-enabled))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let ((tmp-name1 (tramp--test-make-temp-name nil quoted))
(tmp-name2 (tramp--test-make-temp-name nil quoted)))
@@ -3847,7 +4634,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(string-equal
(make-auto-save-file-name)
(funcall
- (if quoted 'tramp-compat-file-name-quote 'identity)
+ (if quoted #'tramp-compat-file-name-quote #'identity)
(expand-file-name
(format "#%s#" (file-name-nondirectory tmp-name1))
tramp-test-temporary-file-directory))))))
@@ -3901,11 +4688,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(ignore-errors (delete-file tmp-name1))
(ignore-errors (delete-directory tmp-name2 'recursive))))))
-(ert-deftest tramp-test36-find-backup-file-name ()
+(ert-deftest tramp-test38-find-backup-file-name ()
"Check `find-backup-file-name'."
(skip-unless (tramp--test-enabled))
- (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let ((tmp-name1 (tramp--test-make-temp-name nil quoted))
(tmp-name2 (tramp--test-make-temp-name nil quoted))
;; These settings are not used by Tramp, so we ignore them.
@@ -3921,7 +4708,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(find-backup-file-name tmp-name1)
(list
(funcall
- (if quoted 'tramp-compat-file-name-quote 'identity)
+ (if quoted #'tramp-compat-file-name-quote #'identity)
(expand-file-name
(format "%s~" (file-name-nondirectory tmp-name1))
tramp-test-temporary-file-directory)))))))
@@ -3935,7 +4722,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(find-backup-file-name tmp-name1)
(list
(funcall
- (if quoted 'tramp-compat-file-name-quote 'identity)
+ (if quoted #'tramp-compat-file-name-quote #'identity)
(expand-file-name
(format
"%s~"
@@ -3963,7 +4750,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(find-backup-file-name tmp-name1)
(list
(funcall
- (if quoted 'tramp-compat-file-name-quote 'identity)
+ (if quoted #'tramp-compat-file-name-quote #'identity)
(expand-file-name
(format
"%s~"
@@ -3992,7 +4779,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(find-backup-file-name tmp-name1)
(list
(funcall
- (if quoted 'tramp-compat-file-name-quote 'identity)
+ (if quoted #'tramp-compat-file-name-quote #'identity)
(expand-file-name
(format
"%s~"
@@ -4012,7 +4799,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(ignore-errors (delete-directory tmp-name2 'recursive))))))
;; The functions were introduced in Emacs 26.1.
-(ert-deftest tramp-test37-make-nearby-temp-file ()
+(ert-deftest tramp-test39-make-nearby-temp-file ()
"Check `make-nearby-temp-file' and `temporary-file-directory'."
(skip-unless (tramp--test-enabled))
;; Since Emacs 26.1.
@@ -4104,6 +4891,16 @@ This does not support external Emacs calls."
(string-equal
"mock" (file-remote-p tramp-test-temporary-file-directory 'method)))
+(defun tramp--test-nextcloud-p ()
+ "Check, whether the nextcloud method is used."
+ (string-equal
+ "nextcloud" (file-remote-p tramp-test-temporary-file-directory 'method)))
+
+(defun tramp--test-rclone-p ()
+ "Check, whether the remote host is offered by rclone.
+This requires restrictions of file name syntax."
+ (tramp-rclone-file-name-p tramp-test-temporary-file-directory))
+
(defun tramp--test-rsync-p ()
"Check, whether the rsync method is used.
This does not support special file names."
@@ -4116,6 +4913,10 @@ This does not support special file names."
(tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory)
'tramp-sh-file-name-handler))
+(defun tramp--test-sudoedit-p ()
+ "Check, whether the sudoedit method is used."
+ (tramp-sudoedit-file-name-p tramp-test-temporary-file-directory))
+
(defun tramp--test-windows-nt ()
"Check, whether the locale host runs MS Windows."
(eq system-type 'windows-nt))
@@ -4142,7 +4943,7 @@ This requires restrictions of file name syntax."
(defun tramp--test-check-files (&rest files)
"Run a simple but comprehensive test over every file in FILES."
;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579.
- (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs27-p))
+ (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p))
'(nil t) '(nil)))
;; We must use `file-truename' for the temporary directory,
;; because it could be located on a symlinked directory. This
@@ -4187,7 +4988,7 @@ This requires restrictions of file name syntax."
(should
(string-equal
(funcall
- (if quoted 'tramp-compat-file-name-quote 'identity)
+ (if quoted #'tramp-compat-file-name-quote #'identity)
(car (file-attributes file3)))
(file-remote-p (file-truename file1) 'localname)))
;; Check file contents.
@@ -4199,10 +5000,10 @@ This requires restrictions of file name syntax."
;; Check file names.
(should (equal (directory-files
tmp-name1 nil directory-files-no-dot-files-regexp)
- (sort (copy-sequence files) 'string-lessp)))
+ (sort (copy-sequence files) #'string-lessp)))
(should (equal (directory-files
tmp-name2 nil directory-files-no-dot-files-regexp)
- (sort (copy-sequence files) 'string-lessp)))
+ (sort (copy-sequence files) #'string-lessp)))
;; `substitute-in-file-name' could return different
;; values. For `adb', there could be strange file
@@ -4262,7 +5063,7 @@ This requires restrictions of file name syntax."
(should
(string-equal
(funcall
- (if quoted 'tramp-compat-file-name-quote 'identity)
+ (if quoted #'tramp-compat-file-name-quote #'identity)
(cadr (car (directory-files-and-attributes
file1 nil (regexp-quote elt1)))))
(file-remote-p (file-truename file2) 'localname)))
@@ -4275,9 +5076,10 @@ This requires restrictions of file name syntax."
(should-not (file-exists-p file1))))
;; Check, that environment variables are set correctly.
- (when (and tramp--test-expensive-test (tramp--test-sh-p))
+ (when (and (tramp--test-expensive-test) (tramp--test-sh-p))
(dolist (elt files)
(let ((envvar (concat "VAR_" (upcase (md5 elt))))
+ (elt (encode-coding-string elt coding-system-for-read))
(default-directory tramp-test-temporary-file-directory)
(process-environment process-environment))
(setenv envvar elt)
@@ -4299,50 +5101,60 @@ This requires restrictions of file name syntax."
(ignore-errors (delete-directory tmp-name2 'recursive))))))
(defun tramp--test-special-characters ()
- "Perform the test in `tramp-test38-special-characters*'."
+ "Perform the test in `tramp-test40-special-characters*'."
;; Newlines, slashes and backslashes in file names are not
;; supported. So we don't test. And we don't test the tab
;; character on Windows or Cygwin, because the backslash is
;; interpreted as a path separator, preventing "\t" from being
;; expanded to <TAB>.
- (tramp--test-check-files
- (if (or (tramp--test-gvfs-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"))
- "$foo$bar$$baz$"
- "-foo-bar-baz-"
- "%foo%bar%baz%"
- "&foo&bar&baz&"
- (unless (or (tramp--test-ftp-p)
- (tramp--test-gvfs-p)
- (tramp--test-windows-nt-or-smb-p))
- "?foo?bar?baz?")
- (unless (or (tramp--test-ftp-p)
- (tramp--test-gvfs-p)
- (tramp--test-windows-nt-or-smb-p))
- "*foo*bar*baz*")
- (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p))
- "'foo'bar'baz'"
- "'foo\"bar'baz\"")
- "#foo~bar#baz~"
- (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p))
- "!foo!bar!baz!"
- "!foo|bar!baz|")
- (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p))
- ";foo;bar;baz;"
- ":foo;bar:baz;")
- (unless (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p))
- "<foo>bar<baz>")
- "(foo)bar(baz)"
- (unless (or (tramp--test-ftp-p) (tramp--test-gvfs-p)) "[foo]bar[baz]")
- "{foo}bar{baz}"))
+ (let ((files
+ (list
+ (if (or (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"))
+ "$foo$bar$$baz$"
+ "-foo-bar-baz-"
+ "%foo%bar%baz%"
+ "&foo&bar&baz&"
+ (unless (or (tramp--test-ftp-p)
+ (tramp--test-gvfs-p)
+ (tramp--test-windows-nt-or-smb-p))
+ "?foo?bar?baz?")
+ (unless (or (tramp--test-ftp-p)
+ (tramp--test-gvfs-p)
+ (tramp--test-windows-nt-or-smb-p))
+ "*foo*bar*baz*")
+ (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p))
+ "'foo'bar'baz'"
+ "'foo\"bar'baz\"")
+ "#foo~bar#baz~"
+ (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p))
+ "!foo!bar!baz!"
+ "!foo|bar!baz|")
+ (if (or (tramp--test-gvfs-p)
+ (tramp--test-rclone-p)
+ (tramp--test-windows-nt-or-smb-p))
+ ";foo;bar;baz;"
+ ":foo;bar:baz;")
+ (unless (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p))
+ "<foo>bar<baz>")
+ "(foo)bar(baz)"
+ (unless (or (tramp--test-ftp-p) (tramp--test-gvfs-p)) "[foo]bar[baz]")
+ "{foo}bar{baz}")))
+ ;; Simplify test in order to speed up.
+ (apply #'tramp--test-check-files
+ (if (tramp--test-expensive-test)
+ files (list (mapconcat #'identity files ""))))))
;; These tests are inspired by Bug#17238.
-(ert-deftest tramp-test38-special-characters ()
+(ert-deftest tramp-test40-special-characters ()
"Check special characters in file names."
(skip-unless (tramp--test-enabled))
(skip-unless (not (tramp--test-rsync-p)))
@@ -4350,7 +5162,7 @@ This requires restrictions of file name syntax."
(tramp--test-special-characters))
-(ert-deftest tramp-test38-special-characters-with-stat ()
+(ert-deftest tramp-test40-special-characters-with-stat ()
"Check special characters in file names.
Use the `stat' command."
:tags '(:expensive-test)
@@ -4368,7 +5180,7 @@ Use the `stat' command."
tramp-connection-properties)))
(tramp--test-special-characters)))
-(ert-deftest tramp-test38-special-characters-with-perl ()
+(ert-deftest tramp-test40-special-characters-with-perl ()
"Check special characters in file names.
Use the `perl' command."
:tags '(:expensive-test)
@@ -4389,7 +5201,7 @@ Use the `perl' command."
tramp-connection-properties)))
(tramp--test-special-characters)))
-(ert-deftest tramp-test38-special-characters-with-ls ()
+(ert-deftest tramp-test40-special-characters-with-ls ()
"Check special characters in file names.
Use the `ls' command."
:tags '(:expensive-test)
@@ -4412,7 +5224,7 @@ Use the `ls' command."
(tramp--test-special-characters)))
(defun tramp--test-utf8 ()
- "Perform the test in `tramp-test39-utf8*'."
+ "Perform the test in `tramp-test41-utf8*'."
(let* ((utf8 (if (and (eq system-type 'darwin)
(memq 'utf-8-hfs (coding-system-list)))
'utf-8-hfs 'utf-8))
@@ -4420,14 +5232,34 @@ Use the `ls' command."
(coding-system-for-write utf8)
(file-name-coding-system
(coding-system-change-eol-conversion utf8 'unix)))
- (tramp--test-check-files
- (unless (tramp--test-hpux-p) "Γυρίστε το Γαλαξία με Ώτο Στοπ")
- (unless (tramp--test-hpux-p)
- "أصبح بوسعك الآن تنزيل نسخة كاملة من موسوعة ويكيبيديا العربية لتصفحها بلا اتصال بالإنترنت")
- "银河系漫游指南系列"
- "Автостопом по гала́ктике")))
-
-(ert-deftest tramp-test39-utf8 ()
+ (apply
+ #'tramp--test-check-files
+ (append
+ (list
+ (unless (tramp--test-hpux-p) "Γυρίστε το Γαλαξία με Ώτο Στοπ")
+ (unless (tramp--test-hpux-p)
+ "أصبح بوسعك الآن تنزيل نسخة كاملة من موسوعة ويكيبيديا العربية لتصفحها بلا اتصال بالإنترنت")
+ "银河系漫游指南系列"
+ "Автостопом по гала́ктике"
+ ;; Use codepoints without a name. See Bug#31272.
+ "™›šbung")
+
+ (when (tramp--test-expensive-test)
+ (delete-dups
+ (mapcar
+ ;; Use all available language specific snippets. Filter out
+ ;; strings which use unencodable characters.
+ (lambda (x)
+ (and
+ (stringp (setq x (eval (get-language-info (car x) 'sample-text))))
+ (not (unencodable-char-position
+ 0 (length x) file-name-coding-system nil x))
+ ;; ?\n and ?/ shouldn't be part of any file name. ?\t,
+ ;; ?. and ?? do not work for "smb" method.
+ (replace-regexp-in-string "[\t\n/.?]" "" x)))
+ language-info-alist)))))))
+
+(ert-deftest tramp-test41-utf8 ()
"Check UTF8 encoding in file names and file contents."
(skip-unless (tramp--test-enabled))
(skip-unless (not (tramp--test-docker-p)))
@@ -4437,7 +5269,7 @@ Use the `ls' command."
(tramp--test-utf8))
-(ert-deftest tramp-test39-utf8-with-stat ()
+(ert-deftest tramp-test41-utf8-with-stat ()
"Check UTF8 encoding in file names and file contents.
Use the `stat' command."
:tags '(:expensive-test)
@@ -4457,7 +5289,7 @@ Use the `stat' command."
tramp-connection-properties)))
(tramp--test-utf8)))
-(ert-deftest tramp-test39-utf8-with-perl ()
+(ert-deftest tramp-test41-utf8-with-perl ()
"Check UTF8 encoding in file names and file contents.
Use the `perl' command."
:tags '(:expensive-test)
@@ -4480,7 +5312,7 @@ Use the `perl' command."
tramp-connection-properties)))
(tramp--test-utf8)))
-(ert-deftest tramp-test39-utf8-with-ls ()
+(ert-deftest tramp-test41-utf8-with-ls ()
"Check UTF8 encoding in file names and file contents.
Use the `ls' command."
:tags '(:expensive-test)
@@ -4503,7 +5335,7 @@ Use the `ls' command."
tramp-connection-properties)))
(tramp--test-utf8)))
-(ert-deftest tramp-test40-file-system-info ()
+(ert-deftest tramp-test42-file-system-info ()
"Check that `file-system-info' returns proper values."
(skip-unless (tramp--test-enabled))
;; Since Emacs 27.1.
@@ -4520,29 +5352,38 @@ Use the `ls' command."
(numberp (nth 1 fsi))
(numberp (nth 2 fsi))))))
-(defun tramp--test-timeout-handler ()
- (interactive)
- (ert-fail (format "`%s' timed out" (ert-test-name (ert-running-test)))))
+;; `tramp-test43-asynchronous-requests' could be blocked. So we set a
+;; timeout of 300 seconds, and we send a SIGUSR1 signal after 300
+;; seconds. Similar check is performed in the timer function.
+(defconst tramp--test-asynchronous-requests-timeout 300
+ "Timeout for `tramp-test43-asynchronous-requests'.")
;; This test is inspired by Bug#16928.
-(ert-deftest tramp-test41-asynchronous-requests ()
+(ert-deftest tramp-test43-asynchronous-requests ()
"Check parallel asynchronous requests.
Such requests could arrive from timers, process filters and
process sentinels. They shall not disturb each other."
- :tags '(:expensive-test)
+ ;; The test fails from time to time, w/o a reproducible pattern. So
+ ;; we mark it as unstable.
+ :tags '(:expensive-test :unstable)
(skip-unless (tramp--test-enabled))
- (skip-unless (tramp--test-sh-p))
-
- ;; This test could be blocked on hydra. So we set a timeout of 300
- ;; seconds, and we send a SIGUSR1 signal after 300 seconds.
- (with-timeout (300 (tramp--test-timeout-handler))
- (define-key special-event-map [sigusr1] 'tramp--test-timeout-handler)
+ ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for
+ ;; remote processes in Emacs. That doesn't work for tramp-adb.el.
+ (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p))
+ (tramp--test-sh-p)))
+
+ (with-timeout
+ (tramp--test-asynchronous-requests-timeout (tramp--test-timeout-handler))
+ (define-key special-event-map [sigusr1] #'tramp--test-timeout-handler)
(let* (;; For the watchdog.
(default-directory (expand-file-name temporary-file-directory))
+ (shell-file-name (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh"))
(watchdog
- (start-process
- "*watchdog*" nil shell-file-name shell-command-switch
- (format "sleep 300; kill -USR1 %d" (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.
@@ -4555,10 +5396,11 @@ process sentinels. They shall not disturb each other."
;; Number of asynchronous processes for test. Tests on
;; some machines handle less parallel processes.
(number-proc
- (or
- (ignore-errors
- (string-to-number (getenv "REMOTE_PARALLEL_PROCESSES")))
- 10))
+ (cond
+ ((ignore-errors
+ (string-to-number (getenv "REMOTE_PARALLEL_PROCESSES"))))
+ ((getenv "EMACS_HYDRA_CI") 5)
+ (t 10)))
;; On hydra, timings are bad.
(timer-repeat
(cond
@@ -4567,8 +5409,11 @@ process sentinels. They shall not disturb each other."
;; We must distinguish due to performance reasons.
(timer-operation
(cond
- ((tramp--test-mock-p) 'vc-registered)
- (t 'file-attributes)))
+ ((tramp--test-mock-p) #'vc-registered)
+ (t #'file-attributes)))
+ ;; This is when all timers start. We check inside the
+ ;; timer function, that we don't exceed timeout.
+ (timer-start (current-time))
timer buffers kill-buffer-query-functions)
(unwind-protect
@@ -4583,16 +5428,25 @@ process sentinels. They shall not disturb each other."
(run-at-time
0 timer-repeat
(lambda ()
+ (when (> (- (time-to-seconds) (time-to-seconds timer-start))
+ tramp--test-asynchronous-requests-timeout)
+ (tramp--test-timeout-handler))
(when buffers
(let ((time (float-time))
(default-directory tmp-name)
(file
(buffer-name (nth (random (length buffers)) buffers))))
+ (tramp--test-message
+ "Start timer %s %s" file (current-time-string))
(funcall timer-operation file)
;; Adjust timer if it takes too much time.
+ (tramp--test-message
+ "Stop timer %s %s" file (current-time-string))
(when (> (- (float-time) time) timer-repeat)
(setq timer-repeat (* 1.5 timer-repeat))
- (setf (timer--repeat-delay timer) timer-repeat)))))))
+ (setf (timer--repeat-delay timer) timer-repeat)
+ (tramp--test-message
+ "Increase timer %s" timer-repeat)))))))
;; Create temporary buffers. The number of buffers
;; corresponds to the number of processes; it could be
@@ -4608,9 +5462,9 @@ process sentinels. They shall not disturb each other."
(start-file-process-shell-command
(buffer-name buf) buf
(concat
- "(read line && echo $line >$line);"
- "(read line && cat $line);"
- "(read line && rm $line)")))
+ "(read line && echo $line >$line && echo $line);"
+ "(read line && cat $line);"
+ "(read line && rm -f $line)")))
(file (expand-file-name (buffer-name buf))))
;; Remember the file name. Add counter.
(process-put proc 'foo file)
@@ -4619,20 +5473,23 @@ process sentinels. They shall not disturb each other."
(set-process-filter
proc
(lambda (proc string)
+ (tramp--test-message
+ "Process filter %s %s %s" proc string (current-time-string))
(with-current-buffer (process-buffer proc)
(insert string))
- (unless (zerop (length string))
+ (when (< (process-get proc 'bar) 2)
(dired-uncache (process-get proc 'foo))
(should (file-attributes (process-get proc 'foo))))))
- ;; Add process sentinel.
+ ;; Add process sentinel. It shall not perform remote
+ ;; operations, triggering Tramp processes. This blocks.
(set-process-sentinel
proc
(lambda (proc _state)
- (dired-uncache (process-get proc 'foo))
- (should-not (file-attributes (process-get proc 'foo)))))))
+ (tramp--test-message
+ "Process sentinel %s %s" proc (current-time-string))))))
- ;; Send a string. Use a random order of the buffers. Mix
- ;; with regular operation.
+ ;; Send a string to the processes. Use a random order of
+ ;; the buffers. Mix with regular operation.
(let ((buffers (copy-sequence buffers)))
(while buffers
;; Activate timer.
@@ -4641,6 +5498,8 @@ process sentinels. They shall not disturb each other."
(proc (get-buffer-process buf))
(file (process-get proc 'foo))
(count (process-get proc 'bar)))
+ (tramp--test-message
+ "Start action %d %s %s" count buf (current-time-string))
;; Regular operation prior process action.
(dired-uncache file)
(if (= count 0)
@@ -4648,14 +5507,18 @@ process sentinels. They shall not disturb each other."
(should (file-attributes file)))
;; Send string to process.
(process-send-string proc (format "%s\n" (buffer-name buf)))
- (accept-process-output proc 0.1 nil 0)
+ (while (accept-process-output proc 0 nil 0))
;; Give the watchdog a chance.
(read-event nil nil 0.01)
+ (tramp--test-message
+ "Continue action %d %s %s" count buf (current-time-string))
;; Regular operation post process action.
(dired-uncache file)
(if (= count 2)
(should-not (file-attributes file))
(should (file-attributes file)))
+ (tramp--test-message
+ "Stop action %d %s %s" count buf (current-time-string))
(process-put proc 'bar (1+ count))
(unless (process-live-p proc)
(setq buffers (delq buf buffers))))))
@@ -4663,15 +5526,22 @@ process sentinels. They shall not disturb each other."
;; Checks. All process output shall exists in the
;; respective buffers. All created files shall be
;; deleted.
+ (tramp--test-message "Check %s" (current-time-string))
(dolist (buf buffers)
(with-current-buffer buf
- (should (string-equal (format "%s\n" buf) (buffer-string)))))
+ (should
+ (string-equal
+ ;; tramp-adb.el echoes, so we must add the three strings.
+ (if (tramp--test-adb-p)
+ (format "%s\n%s\n%s\n%s\n%s\n" buf buf buf buf buf)
+ (format "%s\n%s\n" buf buf))
+ (buffer-string)))))
(should-not
(directory-files
tmp-name nil directory-files-no-dot-files-regexp)))
;; Cleanup.
- (define-key special-event-map [sigusr1] 'ignore)
+ (define-key special-event-map [sigusr1] #'ignore)
(ignore-errors (quit-process watchdog))
(dolist (buf buffers)
(ignore-errors (delete-process (get-buffer-process buf)))
@@ -4680,8 +5550,10 @@ process sentinels. They shall not disturb each other."
(ignore-errors (delete-directory tmp-name 'recursive))))))
;; This test is inspired by Bug#29163.
-(ert-deftest tramp-test42-auto-load ()
+(ert-deftest tramp-test44-auto-load ()
"Check that Tramp autoloads properly."
+ (skip-unless (tramp--test-enabled))
+
(let ((default-directory (expand-file-name temporary-file-directory))
(code
(format
@@ -4695,10 +5567,10 @@ process sentinels. They shall not disturb each other."
"%s -batch -Q -L %s --eval %s"
(shell-quote-argument
(expand-file-name invocation-name invocation-directory))
- (mapconcat 'shell-quote-argument load-path " -L ")
+ (mapconcat #'shell-quote-argument load-path " -L ")
(shell-quote-argument code)))))))
-(ert-deftest tramp-test42-delay-load ()
+(ert-deftest tramp-test44-delay-load ()
"Check that Tramp is loaded lazily, only when needed."
;; The autoloaded Tramp objects are different since Emacs 26.1. We
;; cannot test older Emacsen, therefore.
@@ -4728,10 +5600,10 @@ process sentinels. They shall not disturb each other."
"%s -batch -Q -L %s --eval %s"
(shell-quote-argument
(expand-file-name invocation-name invocation-directory))
- (mapconcat 'shell-quote-argument load-path " -L ")
+ (mapconcat #'shell-quote-argument load-path " -L ")
(shell-quote-argument (format code tm)))))))))
-(ert-deftest tramp-test42-recursive-load ()
+(ert-deftest tramp-test44-recursive-load ()
"Check that Tramp does not fail due to recursive load."
(skip-unless (tramp--test-enabled))
@@ -4752,10 +5624,10 @@ process sentinels. They shall not disturb each other."
"%s -batch -Q -L %s --eval %s"
(shell-quote-argument
(expand-file-name invocation-name invocation-directory))
- (mapconcat 'shell-quote-argument load-path " -L ")
+ (mapconcat #'shell-quote-argument load-path " -L ")
(shell-quote-argument code))))))))
-(ert-deftest tramp-test42-remote-load-path ()
+(ert-deftest tramp-test44-remote-load-path ()
"Check that Tramp autoloads its packages with remote `load-path'."
;; The autoloaded Tramp objects are different since Emacs 26.1. We
;; cannot test older Emacsen, therefore.
@@ -4781,10 +5653,10 @@ process sentinels. They shall not disturb each other."
"%s -batch -Q -L %s -l tramp-sh --eval %s"
(shell-quote-argument
(expand-file-name invocation-name invocation-directory))
- (mapconcat 'shell-quote-argument load-path " -L ")
+ (mapconcat #'shell-quote-argument load-path " -L ")
(shell-quote-argument code)))))))
-(ert-deftest tramp-test43-unload ()
+(ert-deftest tramp-test45-unload ()
"Check that Tramp and its subpackages unload completely.
Since it unloads Tramp, it shall be the last test to run."
:tags '(:expensive-test)
@@ -4793,48 +5665,59 @@ Since it unloads Tramp, it shall be the last test to run."
;; cannot test older Emacsen, therefore.
(skip-unless (tramp--test-emacs26-p))
- (when (featurep 'tramp)
- (unload-feature 'tramp 'force)
- ;; No Tramp feature must be left.
- (should-not (featurep 'tramp))
- (should-not (all-completions "tramp" (delq 'tramp-tests features)))
- ;; `file-name-handler-alist' must be clean.
- (should-not (all-completions "tramp" (mapcar 'cdr file-name-handler-alist)))
- ;; There shouldn't be left a bound symbol, except buffer-local
- ;; variables, and autoload functions. We do not regard our test
- ;; symbols, and the Tramp unload hooks.
- (mapatoms
- (lambda (x)
- (and (or (and (boundp x) (null (local-variable-if-set-p x)))
- (and (functionp x) (null (autoloadp (symbol-function x)))))
- (string-match "^tramp" (symbol-name x))
- (not (string-match "^tramp--?test" (symbol-name x)))
- (not (string-match "unload-hook$" (symbol-name x)))
- (ert-fail (format "`%s' still bound" x)))))
- ;; The defstruct `tramp-file-name' and all its internal functions
- ;; shall be purged.
- (should-not (cl--find-class 'tramp-file-name))
- (mapatoms
- (lambda (x)
- (and (functionp x)
- (string-match "tramp-file-name" (symbol-name x))
- (ert-fail (format "Structure function `%s' still exists" x)))))
- ;; There shouldn't be left a hook function containing a Tramp
- ;; function. We do not regard the Tramp unload hooks.
- (mapatoms
- (lambda (x)
- (and (boundp x)
- (string-match "-\\(hook\\|function\\)s?$" (symbol-name x))
- (not (string-match "unload-hook$" (symbol-name x)))
- (consp (symbol-value x))
- (ignore-errors (all-completions "tramp" (symbol-value x)))
- (ert-fail (format "Hook `%s' still contains Tramp function" x)))))))
+ ;; We have autoloaded objects from tramp.el and tramp-archive.el.
+ ;; In order to remove them, we first need to load both packages.
+ (require 'tramp)
+ (require 'tramp-archive)
+ (should (featurep 'tramp))
+ (should (featurep 'tramp-archive))
+ ;; This unloads also tramp-archive.el and tramp-theme.el if needed.
+ (unload-feature 'tramp 'force)
+ ;; No Tramp feature must be left.
+ (should-not (featurep 'tramp))
+ (should-not (featurep 'tramp-archive))
+ (should-not (featurep 'tramp-theme))
+ (should-not
+ (all-completions
+ "tramp" (delq 'tramp-tests (delq 'tramp-archive-tests features))))
+ ;; `file-name-handler-alist' must be clean.
+ (should-not (all-completions "tramp" (mapcar #'cdr file-name-handler-alist)))
+ ;; There shouldn't be left a bound symbol, except buffer-local
+ ;; variables, and autoload functions. We do not regard our test
+ ;; symbols, and the Tramp unload hooks.
+ (mapatoms
+ (lambda (x)
+ (and (or (and (boundp x) (null (local-variable-if-set-p x)))
+ (and (functionp x) (null (autoloadp (symbol-function x)))))
+ (string-match "^tramp" (symbol-name x))
+ (not (string-match "^tramp\\(-archive\\)?--?test" (symbol-name x)))
+ (not (string-match "unload-hook$" (symbol-name x)))
+ (ert-fail (format "`%s' still bound" x)))))
+ ;; The defstruct `tramp-file-name' and all its internal functions
+ ;; shall be purged.
+ (should-not (cl--find-class 'tramp-file-name))
+ (mapatoms
+ (lambda (x)
+ (and (functionp x)
+ (string-match "tramp-file-name" (symbol-name x))
+ (ert-fail (format "Structure function `%s' still exists" x)))))
+ ;; There shouldn't be left a hook function containing a Tramp
+ ;; function. We do not regard the Tramp unload hooks.
+ (mapatoms
+ (lambda (x)
+ (and (boundp x)
+ (string-match "-\\(hook\\|function\\)s?$" (symbol-name x))
+ (not (string-match "unload-hook$" (symbol-name x)))
+ (consp (symbol-value x))
+ (ignore-errors (all-completions "tramp" (symbol-value x)))
+ (ert-fail (format "Hook `%s' still contains Tramp function" x))))))
(defun tramp-test-all (&optional interactive)
"Run all tests for \\[tramp]."
(interactive "p")
(funcall
- (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch) "^tramp"))
+ (if interactive
+ #'ert-run-tests-interactively #'ert-run-tests-batch) "^tramp"))
;; TODO:
@@ -4843,13 +5726,19 @@ Since it unloads Tramp, it shall be the last test to run."
;; * file-equal-p (partly done in `tramp-test21-file-links')
;; * file-in-directory-p
;; * file-name-case-insensitive-p
+;; * tramp-set-file-uid-gid
;; * Work on skipped tests. Make a comment, when it is impossible.
+;; * Revisit expensive tests, once problems in `tramp-error' are solved.
;; * Fix `tramp-test05-expand-file-name-relative' in `expand-file-name'.
;; * Fix `tramp-test06-directory-file-name' for `ftp'.
-;; * Fix `tramp-test29-start-file-process' on MS Windows (`process-send-eof'?).
-;; * Fix `tramp-test30-interrupt-process', timeout doesn't work reliably.
-;; * Fix Bug#16928 in `tramp-test41-asynchronous-requests'.
+;; * Investigate, why `tramp-test11-copy-file' and `tramp-test12-rename-file'
+;; do not work properly for `nextcloud'.
+;; * Fix `tramp-test29-start-file-process' and
+;; `tramp-test30-make-process' on MS Windows (`process-send-eof'?).
+;; * Fix Bug#16928 in `tramp-test43-asynchronous-requests'. Looks
+;; like it is resolved now. Remove `:unstable' tag?
+;; * Implement `tramp-test31-interrupt-process' for `adb'.
(provide 'tramp-tests)
;;; tramp-tests.el ends here
diff --git a/test/lisp/progmodes/bat-mode-tests.el b/test/lisp/progmodes/bat-mode-tests.el
index a437d5e8010..05b8459b116 100644
--- a/test/lisp/progmodes/bat-mode-tests.el
+++ b/test/lisp/progmodes/bat-mode-tests.el
@@ -63,10 +63,11 @@
"Test fontification of iteration variables."
(should
(equal
- (bat-test-fontify "echo %%a\necho %%~dp1\necho %%~$PATH:I")
+ (bat-test-fontify "echo %%a\necho %%~dp1\necho %%~$PATH:I\necho %%~1")
"<span class=\"builtin\">echo</span> %%<span class=\"variable-name\">a</span>
<span class=\"builtin\">echo</span> %%~dp<span class=\"variable-name\">1</span>
-<span class=\"builtin\">echo</span> %%~$<span class=\"variable-name\">PATH</span>:<span class=\"variable-name\">I</span>")))
+<span class=\"builtin\">echo</span> %%~$<span class=\"variable-name\">PATH</span>:<span class=\"variable-name\">I</span>
+<span class=\"builtin\">echo</span> %%~<span class=\"variable-name\">1</span>")))
(defun bat-test-fill-paragraph (str)
"Return the result of invoking `fill-paragraph' on STR in a `bat-mode' buffer."
diff --git a/test/lisp/progmodes/f90-tests.el b/test/lisp/progmodes/f90-tests.el
index 3cd7392bbc4..b1642388413 100644
--- a/test/lisp/progmodes/f90-tests.el
+++ b/test/lisp/progmodes/f90-tests.el
@@ -98,7 +98,7 @@ end subroutine test")
(insert "(/ x /)")
(f90-do-auto-fill)
(beginning-of-line)
- (skip-chars-forward "[ \t]")
+ (skip-chars-forward " \t")
(should (equal "&(/" (buffer-substring (point) (+ 3 (point)))))))
;; TODO bug#5593
diff --git a/test/lisp/progmodes/flymake-resources/Makefile b/test/lisp/progmodes/flymake-resources/Makefile
index 494407567f2..05399ba388b 100644
--- a/test/lisp/progmodes/flymake-resources/Makefile
+++ b/test/lisp/progmodes/flymake-resources/Makefile
@@ -8,6 +8,6 @@ CC_OPTS = -Wall -Wextra
## normally use flymake, so it seems like just avoiding the issue
## in this test is fine. Set flymake-log-level to 3 to investigate.
check-syntax:
- GCC_COLORS= $(CC) $(CC_OPTS) ${CHK_SOURCES} || true
+ GCC_COLORS= gcc $(CC_OPTS) ${CHK_SOURCES} || true
# eof
diff --git a/test/lisp/progmodes/flymake-tests.el b/test/lisp/progmodes/flymake-tests.el
index f5aa5d76a1e..732193476dd 100644
--- a/test/lisp/progmodes/flymake-tests.el
+++ b/test/lisp/progmodes/flymake-tests.el
@@ -53,7 +53,7 @@
while notdone
unless noninteractive do (read-event "" nil 0.1)
do (sleep-for (+ 0.5 flymake-no-changes-timeout))
- finally (when notdone (ert-fail
+ finally (when notdone (ert-skip
(format "Some backends not reporting yet %s"
notdone)))))
@@ -118,6 +118,7 @@ SEVERITY-PREDICATE is used to setup
(flymake-goto-prev-error)
(should (eq 'flymake-error (face-at-point)))))
+(defvar ruby-mode-hook)
(ert-deftest ruby-backend ()
"Test the ruby backend"
(skip-unless (executable-find "ruby"))
@@ -129,15 +130,20 @@ SEVERITY-PREDICATE is used to setup
;; for this particular yuckiness
(abbreviated-home-dir nil))
(unwind-protect
- (flymake-tests--with-flymake ("test.rb")
- (flymake-goto-next-error)
- (should (eq 'flymake-warning (face-at-point)))
- (flymake-goto-next-error)
- (should (eq 'flymake-error (face-at-point))))
+ (let ((ruby-mode-hook
+ (lambda ()
+ (setq flymake-diagnostic-functions '(ruby-flymake-simple)))))
+ (flymake-tests--with-flymake ("test.rb")
+ (flymake-goto-next-error)
+ (should (eq 'flymake-warning (face-at-point)))
+ (flymake-goto-next-error)
+ (should (eq 'flymake-error (face-at-point)))))
(delete-directory tempdir t))))
(ert-deftest different-diagnostic-types ()
"Test GCC warning via function predicate."
+ ;; http://lists.gnu.org/archive/html/emacs-devel/2019-03/msg01043.html
+ :expected-result (if (getenv "EMACS_HYDRA_CI") :failed :passed)
(skip-unless (and (executable-find "gcc")
(version<=
"5" (string-trim
diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el
index 3ce27a687da..999cf8dc7a3 100644
--- a/test/lisp/progmodes/python-tests.el
+++ b/test/lisp/progmodes/python-tests.el
@@ -1161,10 +1161,13 @@ def b()
if do:
something()
else
+outside
"
(python-tests-look-at "else")
(goto-char (line-end-position))
(python-tests-self-insert ":")
+ (should (= (current-indentation) 0))
+ (python-tests-look-at "outside")
(should (= (current-indentation) 0))))
(ert-deftest python-indent-electric-colon-3 ()
@@ -2004,6 +2007,12 @@ string
(python-util-forward-comment -1)
(point))))))
+(ert-deftest python-nav-end-of-statement-2 ()
+ "Test the string overlap assertion (Bug#30964)."
+ (python-tests-with-temp-buffer
+ "'\n''\n"
+ (python-nav-end-of-statement)))
+
(ert-deftest python-nav-forward-statement-1 ()
(python-tests-with-temp-buffer
"
@@ -5336,13 +5345,23 @@ class SomeClass:
(ert-deftest python-tests--python-nav-end-of-statement--infloop ()
"Checks that `python-nav-end-of-statement' doesn't infloop in a
buffer with overlapping strings."
+ ;; FIXME: The treatment of strings has changed in the mean time, and the
+ ;; test below now neither signals an error nor inf-loops.
+ ;; The description of the problem it's trying to catch is not clear enough
+ ;; to be able to see if the underlying problem is really fixed, sadly.
+ ;; E.g. I don't know what is meant by "overlap", really.
+ (skip-unless nil)
(python-tests-with-temp-buffer "''' '\n''' ' '\n"
(syntax-propertize (point-max))
;; Create a situation where strings nominally overlap. This
;; shouldn't happen in practice, but apparently it can happen when
;; a package calls `syntax-ppss' in a narrowed buffer during JIT
;; lock.
+ ;; FIXME: 4-5 is the SPC right after the opening triple quotes: why
+ ;; put a string-fence syntax on it?
(put-text-property 4 5 'syntax-table (string-to-syntax "|"))
+ ;; FIXME: 8-9 is the middle quote in the closing triple quotes:
+ ;; it shouldn't have any syntax-table property to remove anyway!
(remove-text-properties 8 9 '(syntax-table nil))
(goto-char 4)
(setq-local syntax-propertize-function nil)
@@ -5352,6 +5371,15 @@ buffer with overlapping strings."
(python-nav-end-of-statement)))
(should (eolp))))
+;; After call `run-python' the buffer running the python process is current.
+(ert-deftest python-tests--bug31398 ()
+ "Test for https://debbugs.gnu.org/31398 ."
+ (skip-unless (executable-find python-tests-shell-interpreter))
+ (let ((buffer (process-buffer (run-python nil nil 'show))))
+ (should (eq buffer (current-buffer)))
+ (pop-to-buffer (other-buffer))
+ (run-python nil nil 'show)
+ (should (eq buffer (current-buffer)))))
(provide 'python-tests)
diff --git a/test/lisp/progmodes/ruby-mode-tests.el b/test/lisp/progmodes/ruby-mode-tests.el
index 97faad4c329..efbe012427f 100644
--- a/test/lisp/progmodes/ruby-mode-tests.el
+++ b/test/lisp/progmodes/ruby-mode-tests.el
@@ -705,17 +705,109 @@ VALUES-PLIST is a list with alternating index and value elements."
(ert-deftest ruby-forward-sexp-skips-method-calls-with-keyword-names ()
(ruby-with-temp-buffer ruby-sexp-test-example
- (goto-line 2)
+ (goto-char (point-min))
+ (forward-line 1)
(ruby-forward-sexp)
(should (= 8 (line-number-at-pos)))))
(ert-deftest ruby-backward-sexp-skips-method-calls-with-keyword-names ()
(ruby-with-temp-buffer ruby-sexp-test-example
- (goto-line 8)
+ (goto-char (point-min))
+ (forward-line 7)
(end-of-line)
(ruby-backward-sexp)
(should (= 2 (line-number-at-pos)))))
+(ert-deftest ruby-forward-sexp-jumps-do-end-block-with-no-args ()
+ (ruby-with-temp-buffer
+ (ruby-test-string
+ "proc do
+ |end")
+ (search-backward "do\n")
+ (ruby-forward-sexp)
+ (should (eobp))))
+
+(ert-deftest ruby-backward-sexp-jumps-do-end-block-with-no-args ()
+ (ruby-with-temp-buffer
+ (ruby-test-string
+ "proc do
+ |end")
+ (goto-char (point-max))
+ (ruby-backward-sexp)
+ (should (looking-at "do$"))))
+
+(ert-deftest ruby-forward-sexp-jumps-do-end-block-with-empty-args ()
+ (ruby-with-temp-buffer
+ (ruby-test-string
+ "proc do ||
+ |end")
+ (search-backward "do ")
+ (ruby-forward-sexp)
+ (should (eobp))))
+
+(ert-deftest ruby-backward-sexp-jumps-do-end-block-with-empty-args ()
+ (ruby-with-temp-buffer
+ (ruby-test-string
+ "proc do ||
+ |end")
+ (goto-char (point-max))
+ (ruby-backward-sexp)
+ (should (looking-at "do "))))
+
+(ert-deftest ruby-forward-sexp-jumps-do-end-block-with-args ()
+ (ruby-with-temp-buffer
+ (ruby-test-string
+ "proc do |a,b|
+ |end")
+ (search-backward "do ")
+ (ruby-forward-sexp)
+ (should (eobp))))
+
+(ert-deftest ruby-backward-sexp-jumps-do-end-block-with-args ()
+ (ruby-with-temp-buffer
+ (ruby-test-string
+ "proc do |a,b|
+ |end")
+ (goto-char (point-max))
+ (ruby-backward-sexp)
+ (should (looking-at "do "))))
+
+(ert-deftest ruby-forward-sexp-jumps-do-end-block-with-any-args ()
+ (ruby-with-temp-buffer
+ (ruby-test-string
+ "proc do |*|
+ |end")
+ (search-backward "do ")
+ (ruby-forward-sexp)
+ (should (eobp))))
+
+(ert-deftest ruby-forward-sexp-jumps-do-end-block-with-expanded-one-arg ()
+ (ruby-with-temp-buffer
+ (ruby-test-string
+ "proc do |a,|
+ |end")
+ (search-backward "do ")
+ (ruby-forward-sexp)
+ (should (eobp))))
+
+(ert-deftest ruby-forward-sexp-jumps-do-end-block-with-one-and-any-args ()
+ (ruby-with-temp-buffer
+ (ruby-test-string
+ "proc do |a,*|
+ |end")
+ (search-backward "do ")
+ (ruby-forward-sexp)
+ (should (eobp))))
+
+(ert-deftest ruby-backward-sexp-jumps-do-end-block-with-one-and-any-args ()
+ (ruby-with-temp-buffer
+ (ruby-test-string
+ "proc do |a,*|
+ |end")
+ (goto-char (point-max))
+ (ruby-backward-sexp)
+ (should (looking-at "do "))))
+
(ert-deftest ruby-toggle-string-quotes-quotes-correctly ()
(let ((pairs
'(("puts '\"foo\"\\''" . "puts \"\\\"foo\\\"'\"")
diff --git a/test/lisp/progmodes/sql-tests.el b/test/lisp/progmodes/sql-tests.el
index 604c02172ea..7a11f762eb0 100644
--- a/test/lisp/progmodes/sql-tests.el
+++ b/test/lisp/progmodes/sql-tests.el
@@ -53,5 +53,222 @@
(error "some error"))))
(should-not (sql-postgres-list-databases))))
+;;; Check Connection Password Handling/Wallet
+
+(defvar sql-test-login-params nil)
+(defmacro with-sql-test-connect-harness (id login-params connection expected)
+ "Set-up and tear-down SQL connect related test.
+
+Identify tests by ID. Set :sql-login dialect attribute to
+LOGIN-PARAMS. Provide the CONNECTION parameters and the EXPECTED
+string of values passed to the comint function for validation."
+ (declare (indent 2))
+ `(cl-letf
+ ((sql-test-login-params ' ,login-params)
+ ((symbol-function 'sql-comint-test)
+ (lambda (product options &optional buf-name)
+ (with-current-buffer (get-buffer-create buf-name)
+ (insert (pp-to-string (list product options sql-user sql-password sql-server sql-database))))))
+ ((symbol-function 'sql-run-test)
+ (lambda (&optional buffer)
+ (interactive "P")
+ (sql-product-interactive 'sqltest buffer)))
+ (sql-user nil)
+ (sql-server nil)
+ (sql-database nil)
+ (sql-product-alist
+ '((ansi)
+ (sqltest
+ :name "SqlTest"
+ :sqli-login sql-test-login-params
+ :sqli-comint-func sql-comint-test)))
+ (sql-connection-alist
+ '((,(format "test-%s" id)
+ ,@connection)))
+ (sql-password-wallet
+ (list
+ (make-temp-file
+ "sql-test-netrc" nil nil
+ (mapconcat #'identity
+ '("machine aMachine user aUserName password \"netrc-A aPassword\""
+ "machine aServer user aUserName password \"netrc-B aPassword\""
+ "machine aMachine server aServer user aUserName password \"netrc-C aPassword\""
+ "machine aMachine database aDatabase user aUserName password \"netrc-D aPassword\""
+ "machine aDatabase user aUserName password \"netrc-E aPassword\""
+ "machine aMachine server aServer database aDatabase user aUserName password \"netrc-F aPassword\""
+ "machine \"aServer/aDatabase\" user aUserName password \"netrc-G aPassword\""
+ ) "\n")))))
+
+ (let* ((connection ,(format "test-%s" id))
+ (buffername (format "*SQL: ERT TEST <%s>*" connection)))
+ (when (get-buffer buffername)
+ (kill-buffer buffername))
+ (sql-connect connection buffername)
+ (should (get-buffer buffername))
+ (should (string-equal (with-current-buffer buffername (buffer-string)) ,expected))
+ (when (get-buffer buffername)
+ (kill-buffer buffername))
+ (delete-file (car sql-password-wallet)))))
+
+(ert-deftest sql-test-connect ()
+ "Test of basic `sql-connect'."
+ (with-sql-test-connect-harness 1 (user password server database)
+ ((sql-product 'sqltest)
+ (sql-user "aUserName")
+ (sql-password "test-1 aPassword")
+ (sql-server "aServer")
+ (sql-database "aDatabase"))
+ "(sqltest nil \"aUserName\" \"test-1 aPassword\" \"aServer\" \"aDatabase\")\n"))
+
+(ert-deftest sql-test-connect-password-func ()
+ "Test of password function."
+ (with-sql-test-connect-harness 2 (user password server database)
+ ((sql-product 'sqltest)
+ (sql-user "aUserName")
+ (sql-password (lambda () (concat [?t ?e ?s ?t ?- ?2 ?\s
+ ?a ?P ?a ?s ?s ?w ?o ?r ?d])))
+ (sql-server "aServer")
+ (sql-database "aDatabase"))
+ "(sqltest nil \"aUserName\" \"test-2 aPassword\" \"aServer\" \"aDatabase\")\n"))
+
+(ert-deftest sql-test-connect-wallet-server-database ()
+ "Test of password function."
+ (with-sql-test-connect-harness 3 (user password server database)
+ ((sql-product 'sqltest)
+ (sql-user "aUserName")
+ (sql-server "aServer")
+ (sql-database "aDatabase"))
+ "(sqltest nil \"aUserName\" \"netrc-G aPassword\" \"aServer\" \"aDatabase\")\n"))
+
+(ert-deftest sql-test-connect-wallet-database ()
+ "Test of password function."
+ (with-sql-test-connect-harness 4 (user password database)
+ ((sql-product 'sqltest)
+ (sql-user "aUserName")
+ (sql-database "aDatabase"))
+ "(sqltest nil \"aUserName\" \"netrc-E aPassword\" nil \"aDatabase\")\n"))
+
+(ert-deftest sql-test-connect-wallet-server ()
+ "Test of password function."
+ (with-sql-test-connect-harness 5 (user password server)
+ ((sql-product 'sqltest)
+ (sql-user "aUserName")
+ (sql-server "aServer"))
+ "(sqltest nil \"aUserName\" \"netrc-B aPassword\" \"aServer\" nil)\n"))
+
+;;; Set/Get Product Features
+
+(defvar sql-test-feature-value-a nil "Indirect value A.")
+(defvar sql-test-feature-value-b nil "Indirect value B.")
+(defvar sql-test-feature-value-c nil "Indirect value C.")
+(defvar sql-test-feature-value-d nil "Indirect value D.")
+(defmacro sql-test-product-feature-harness (&rest action)
+ "Set-up and tear-down of testing product/feature API.
+
+Perform ACTION and validate results"
+ (declare (indent 2))
+ `(cl-letf
+ ((sql-product-alist
+ (list (list 'a :X 1 :Y 2 :Z 'sql-test-feature-value-a)
+ (list 'b :X 3 :Z 'sql-test-feature-value-b)
+ (list 'c :Y 6 :Z 'sql-test-feature-value-c)
+ (list 'd :X 7 :Y 8 )))
+ (sql-indirect-features '(:Z :W))
+ (sql-test-feature-value-a "original A")
+ (sql-test-feature-value-b "original B")
+ (sql-test-feature-value-c "original C")
+ (sql-test-feature-value-d "original D"))
+ ,@action))
+
+(ert-deftest sql-test-add-product ()
+ "Add a product"
+
+ (sql-test-product-feature-harness
+ (sql-add-product 'xyz "XyzDb")
+
+ (should (equal (pp-to-string (assoc 'xyz sql-product-alist))
+ "(xyz :name \"XyzDb\")\n"))))
+
+(ert-deftest sql-test-add-existing-product ()
+ "Add a product that already exists."
+
+ (sql-test-product-feature-harness
+ (should-error (sql-add-feature 'a "Aaa"))
+ (should (equal (pp-to-string (assoc 'a sql-product-alist))
+ "(a :X 1 :Y 2 :Z sql-test-feature-value-a)\n"))))
+
+(ert-deftest sql-test-set-feature ()
+ "Add a feature"
+
+ (sql-test-product-feature-harness
+ (sql-set-product-feature 'b :Y 4)
+ (should (equal (pp-to-string (assoc 'b sql-product-alist))
+ "(b :Y 4 :X 3 :Z sql-test-feature-value-b)\n"))))
+
+(ert-deftest sql-test-set-indirect-feature ()
+ "Set a new indirect feature"
+
+ (sql-test-product-feature-harness
+ (sql-set-product-feature 'd :Z 'sql-test-feature-value-d)
+ (should (equal (pp-to-string (assoc 'd sql-product-alist))
+ "(d :Z sql-test-feature-value-d :X 7 :Y 8)\n"))))
+
+(ert-deftest sql-test-set-existing-feature ()
+ "Set an existing feature."
+
+ (sql-test-product-feature-harness
+ (sql-set-product-feature 'b :X 33)
+ (should (equal (pp-to-string (assoc 'b sql-product-alist))
+ "(b :X 33 :Z sql-test-feature-value-b)\n"))))
+
+(ert-deftest sql-test-set-existing-indirect-feature ()
+ "Set an existing indirect feature."
+
+ (sql-test-product-feature-harness
+ (should (equal sql-test-feature-value-b "original B"))
+ (sql-set-product-feature 'b :Z "Hurray!")
+ (should (equal (pp-to-string (assoc 'b sql-product-alist))
+ "(b :X 3 :Z sql-test-feature-value-b)\n")) ;; unchanged
+ (should (equal sql-test-feature-value-b "Hurray!"))))
+
+(ert-deftest sql-test-set-missing-product ()
+ "Add a feature to a missing product."
+
+ (sql-test-product-feature-harness
+ (should-error (sql-set-product-feature 'x :Y 4))
+ (should-not (assoc 'x sql-product-alist))))
+
+(ert-deftest sql-test-get-feature ()
+ "Get a feature value."
+
+ (sql-test-product-feature-harness
+ (should (equal (sql-get-product-feature 'c :Y) 6))))
+
+(ert-deftest sql-test-get-indirect-feature ()
+ "Get a feature indirect value."
+
+ (sql-test-product-feature-harness
+ (should (equal (sql-get-product-feature 'c :Z nil t) 'sql-test-feature-value-c))
+ (should (equal sql-test-feature-value-c "original C"))
+ (should (equal (sql-get-product-feature 'c :Z) "original C"))))
+
+(ert-deftest sql-test-get-missing-product ()
+ "Get a feature value from a missing product."
+
+ (sql-test-product-feature-harness
+ (should-error (sql-get-product-feature 'x :Y))))
+
+(ert-deftest sql-test-get-missing-feature ()
+ "Get a missing feature value."
+
+ (sql-test-product-feature-harness
+ (should-not (sql-get-product-feature 'c :X))))
+
+(ert-deftest sql-test-get-missing-indirect-feature ()
+ "Get a missing indirect feature value."
+
+ (sql-test-product-feature-harness
+ (should-not (sql-get-product-feature 'd :Z))))
+
(provide 'sql-tests)
;;; sql-tests.el ends here
diff --git a/test/lisp/progmodes/tcl-tests.el b/test/lisp/progmodes/tcl-tests.el
new file mode 100644
index 00000000000..50c3eba75d1
--- /dev/null
+++ b/test/lisp/progmodes/tcl-tests.el
@@ -0,0 +1,77 @@
+;;; tcl-tests.el --- Test suite for tcl-mode
+
+;; Copyright (C) 2018-2019 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert)
+(require 'tcl)
+
+;; From bug#23565
+(ert-deftest tcl-mode-beginning-of-defun-1 ()
+ (with-temp-buffer
+ (tcl-mode)
+ (insert "proc bad {{value \"\"}} {\n # do something\n}")
+ (should (beginning-of-defun))
+ (should (= (point) (point-min)))
+ (end-of-defun)
+ (should (= (point) (point-max)))))
+
+;; From bug#23565
+(ert-deftest tcl-mode-beginning-of-defun-2 ()
+ (with-temp-buffer
+ (tcl-mode)
+ (insert "proc good {{value}} {\n # do something\n}")
+ (should (beginning-of-defun))
+ (should (= (point) (point-min)))
+ (end-of-defun)
+ (should (= (point) (point-max)))))
+
+(ert-deftest tcl-mode-function-name ()
+ (with-temp-buffer
+ (tcl-mode)
+ (insert "proc notinthis {} {\n # nothing\n}\n\n")
+ (should-not (add-log-current-defun))))
+
+(ert-deftest tcl-mode-function-name ()
+ (with-temp-buffer
+ (tcl-mode)
+ (insert "proc simple {} {\n # nothing\n}")
+ (backward-char 3)
+ (should (equal "simple" (add-log-current-defun)))))
+
+(ert-deftest tcl-mode-function-name ()
+ (with-temp-buffer
+ (tcl-mode)
+ (insert "proc inthis {} {\n # nothing\n")
+ (should (equal "inthis" (add-log-current-defun)))))
+
+;; From bug#32035
+(ert-deftest tcl-mode-namespace-indent ()
+ (with-temp-buffer
+ (tcl-mode)
+ (let ((text "namespace eval Foo {\n variable foo\n}\n"))
+ (insert text)
+ (indent-region (point-min) (point-max))
+ (should (equal (buffer-string) text)))))
+
+(provide 'tcl-tests)
+
+;;; tcl-tests.el ends here
diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el
index cd30633e377..ed948ad8554 100644
--- a/test/lisp/replace-tests.el
+++ b/test/lisp/replace-tests.el
@@ -359,6 +359,52 @@ Each element has the format:
(dotimes (i (length replace-occur-tests))
(replace-occur-test-create i))
+(ert-deftest replace-occur-revert-bug32543 ()
+ "Test `occur-revert' with non-nil `list-matching-lines-jump-to-current-line'."
+ (let ((temp-buffer (get-buffer-create " *test-occur*")))
+ (unwind-protect
+ (save-window-excursion
+ (with-current-buffer temp-buffer
+ (erase-buffer)
+ (setq list-matching-lines-jump-to-current-line t)
+ (insert
+";; This buffer is for text that is not saved, and for Lisp evaluation.
+;; To create a file, visit it with C-x C-f and enter text in its buffer.
+
+")
+ (occur "and")
+ (with-current-buffer "*Occur*"
+ (revert-buffer)
+ (goto-char (point-min))
+ (should (string-match "\\`2 matches for \"and\" in buffer: "
+ (buffer-substring-no-properties
+ (point) (line-end-position)))))))
+ (and (buffer-name temp-buffer)
+ (kill-buffer temp-buffer)))))
+
+(ert-deftest replace-occur-revert-bug32987 ()
+ "Test `occur-revert' with non-nil `list-matching-lines-jump-to-current-line'."
+ (let ((temp-buffer (get-buffer-create " *test-occur*")))
+ (unwind-protect
+ (save-window-excursion
+ (with-current-buffer temp-buffer
+ (erase-buffer)
+ (setq list-matching-lines-jump-to-current-line nil)
+ (insert
+";; This buffer is for text that is not saved, and for Lisp evaluation.
+;; To create a file, visit it with C-x C-f and enter text in its buffer.
+
+")
+ (occur "and")
+ (with-current-buffer "*Occur*"
+ (revert-buffer)
+ (goto-char (point-min))
+ (should (string-match "\\`2 matches for \"and\" in buffer: "
+ (buffer-substring-no-properties
+ (point) (line-end-position)))))))
+ (and (buffer-name temp-buffer)
+ (kill-buffer temp-buffer)))))
+
;;; Tests for `query-replace' undo feature.
@@ -454,5 +500,4 @@ Return the last evalled form in BODY."
input "a" "B" ((?\s . (1 2 3)) (?E . (4)) (?U . (5))) ?q
(string= input (buffer-string))))))
-
;;; replace-tests.el ends here
diff --git a/test/lisp/ses-tests.el b/test/lisp/ses-tests.el
index c60b59a4332..8b07a550df6 100644
--- a/test/lisp/ses-tests.el
+++ b/test/lisp/ses-tests.el
@@ -38,7 +38,7 @@ interactively."
(dolist (c '((0 0 1) (1 0 (1+ A1))))
(apply 'ses-cell-set-formula c)
(apply 'ses-calculate-cell (list (car c) (cadr c) nil)))
- (should (eq A2 2)))))
+ (should (eq (bound-and-true-p A2) 2)))))
(ert-deftest ses-tests-plain-formula ()
"Check that setting A1 to 1 and A2 to (1+ A1), makes A2 value
@@ -49,13 +49,16 @@ equal to 2. This is done using interactive calls."
(dolist (c '((0 0 1) (1 0 (1+ A1))))
(apply 'funcall-interactively 'ses-edit-cell c))
(ses-command-hook)
- (should (eq A2 2)))))
+ (should (eq (bound-and-true-p A2) 2)))))
;; PLAIN CELL RENAMING TESTS
;; ======================================================================
+(defvar ses--foo)
+(defvar ses--cells)
+
(ert-deftest ses-tests-lowlevel-renamed-cell ()
- "Check that renaming A1 to `foo' and setting `foo' to 1 and A2 to (1+ foo), makes A2 value equal to 2.
+ "Check that renaming A1 to `ses--foo' and setting `ses--foo' to 1 and A2 to (1+ ses--foo), makes A2 value equal to 2.
This is done using low level functions, `ses-rename-cell' is not
called but instead we use text replacement in the buffer
previously passed in text mode."
@@ -69,63 +72,63 @@ previously passed in text mode."
(text-mode)
(goto-char (point-min))
(while (re-search-forward "\\<A1\\>" nil t)
- (replace-match "foo" t t))
+ (replace-match "ses--foo" t t))
(ses-mode)
(should-not (local-variable-p 'A1))
- (should (eq foo 1))
- (should (equal (ses-cell-formula 1 0) '(ses-safe-formula (1+ foo))))
- (should (eq A2 2)))))
+ (should (eq ses--foo 1))
+ (should (equal (ses-cell-formula 1 0) '(ses-safe-formula (1+ ses--foo))))
+ (should (eq (bound-and-true-p A2) 2)))))
(ert-deftest ses-tests-renamed-cell ()
- "Check that renaming A1 to `foo' and setting `foo' to 1 and A2
-to (1+ foo), makes A2 value equal to 2."
+ "Check that renaming A1 to `ses--foo' and setting `ses--foo' to 1 and A2
+to (1+ ses--foo), makes A2 value equal to 2."
(let ((ses-initial-size '(2 . 1)))
(with-temp-buffer
(ses-mode)
- (ses-rename-cell 'foo (ses-get-cell 0 0))
- (dolist (c '((0 0 1) (1 0 (1+ foo))))
+ (ses-rename-cell 'ses--foo (ses-get-cell 0 0))
+ (dolist (c '((0 0 1) (1 0 (1+ ses--foo))))
(apply 'funcall-interactively 'ses-edit-cell c))
(ses-command-hook)
(should-not (local-variable-p 'A1))
- (should (eq foo 1))
- (should (equal (ses-cell-formula 1 0) '(1+ foo)))
- (should (eq A2 2)))))
+ (should (eq ses--foo 1))
+ (should (equal (ses-cell-formula 1 0) '(1+ ses--foo)))
+ (should (eq (bound-and-true-p A2) 2)))))
(ert-deftest ses-tests-renamed-cell-after-setting ()
"Check that setting A1 to 1 and A2 to (1+ A1), and then
-renaming A1 to `foo' makes `foo' value equal to 2."
+renaming A1 to `ses--foo' makes `ses--foo' value equal to 2."
(let ((ses-initial-size '(2 . 1)))
(with-temp-buffer
(ses-mode)
(dolist (c '((0 0 1) (1 0 (1+ A1))))
(apply 'funcall-interactively 'ses-edit-cell c))
(ses-command-hook); deferred recalc
- (ses-rename-cell 'foo (ses-get-cell 0 0))
+ (ses-rename-cell 'ses--foo (ses-get-cell 0 0))
(should-not (local-variable-p 'A1))
- (should (eq foo 1))
- (should (equal (ses-cell-formula 1 0) '(1+ foo)))
- (should (eq A2 2)))))
+ (should (eq ses--foo 1))
+ (should (equal (ses-cell-formula 1 0) '(1+ ses--foo)))
+ (should (eq (bound-and-true-p A2) 2)))))
(ert-deftest ses-tests-renaming-cell-with-one-symbol-formula ()
"Check that setting A1 to 1 and A2 to A1, and then renaming A1
-to `foo' makes `foo' value equal to 1. Then set A1 to 2 and check
-that `foo' becomes 2."
+to `ses--foo' makes `ses--foo' value equal to 1. Then set A1 to 2 and check
+that `ses--foo' becomes 2."
(let ((ses-initial-size '(3 . 1)))
(with-temp-buffer
(ses-mode)
(dolist (c '((0 0 1) (1 0 A1)))
(apply 'funcall-interactively 'ses-edit-cell c))
(ses-command-hook); deferred recalc
- (ses-rename-cell 'foo (ses-get-cell 0 0))
+ (ses-rename-cell 'ses--foo (ses-get-cell 0 0))
(ses-command-hook); deferred recalc
(should-not (local-variable-p 'A1))
- (should (eq foo 1))
- (should (equal (ses-cell-formula 1 0) 'foo))
- (should (eq A2 1))
+ (should (eq ses--foo 1))
+ (should (equal (ses-cell-formula 1 0) 'ses--foo))
+ (should (eq (bound-and-true-p A2) 1))
(funcall-interactively 'ses-edit-cell 0 0 2)
(ses-command-hook); deferred recalc
- (should (eq A2 2))
- (should (eq foo 2)))))
+ (should (eq (bound-and-true-p A2) 2))
+ (should (eq ses--foo 2)))))
;; ROW INSERTION TESTS
@@ -144,32 +147,31 @@ to A2 and inserting a row, makes A2 value empty, and A3 equal to
(ses-jump 'A2)
(ses-insert-row 1)
(ses-command-hook)
- (should-not A2)
- (should (eq A3 2)))))
+ (should-not (bound-and-true-p A2))
+ (should (eq (bound-and-true-p A3) 2)))))
-; (defvar ses-tests-trigger nil)
+(defvar ses--bar)
(ert-deftest ses-tests-renamed-cells-row-insertion ()
- "Check that setting A1 to 1 and A2 to (1+ A1), and then renaming A1 to `foo' and A2 to `bar' jumping
-to `bar' and inserting a row, makes A2 value empty, and `bar' equal to
+ "Check that setting A1 to 1 and A2 to (1+ A1), and then renaming A1 to `ses--foo' and A2 to `ses--bar' jumping
+to `ses--bar' and inserting a row, makes A2 value empty, and `ses--bar' equal to
2."
- (setq ses-tests-trigger nil)
(let ((ses-initial-size '(2 . 1)))
(with-temp-buffer
(ses-mode)
(dolist (c '((0 0 1) (1 0 (1+ A1))))
(apply 'funcall-interactively 'ses-edit-cell c))
(ses-command-hook)
- (ses-rename-cell 'foo (ses-get-cell 0 0))
+ (ses-rename-cell 'ses--foo (ses-get-cell 0 0))
(ses-command-hook)
- (ses-rename-cell 'bar (ses-get-cell 1 0))
+ (ses-rename-cell 'ses--bar (ses-get-cell 1 0))
(ses-command-hook)
- (should (eq bar 2))
- (ses-jump 'bar)
+ (should (eq ses--bar 2))
+ (ses-jump 'ses--bar)
(ses-insert-row 1)
(ses-command-hook)
- (should-not A2)
- (should (eq bar 2)))))
+ (should-not (bound-and-true-p A2))
+ (should (eq ses--bar 2)))))
(provide 'ses-tests)
diff --git a/test/lisp/shell-tests.el b/test/lisp/shell-tests.el
index c4ec6cca416..329f5cf1129 100644
--- a/test/lisp/shell-tests.el
+++ b/test/lisp/shell-tests.el
@@ -30,4 +30,12 @@
"Test problem found by Filipp Gunbin in emacs-devel."
(should (equal (car (shell--unquote&requote-argument "te'st" 2)) "test")))
+(ert-deftest shell-tests-completion-before-semi ()
+ (with-temp-buffer
+ (shell-mode)
+ (insert "cd ba;")
+ (forward-char -1)
+ (should (equal (shell--parse-pcomplete-arguments)
+ '(("cd" "ba") 1 4)))))
+
;;; shell-tests.el ends here
diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el
index 0103409a636..cc2feebbefa 100644
--- a/test/lisp/simple-tests.el
+++ b/test/lisp/simple-tests.el
@@ -22,6 +22,11 @@
(require 'ert)
(eval-when-compile (require 'cl-lib))
+(defun simple-test--buffer-substrings ()
+ "Return cons of buffer substrings before and after point."
+ (cons (buffer-substring (point-min) (point))
+ (buffer-substring (point) (point-max))))
+
(defmacro simple-test--dummy-buffer (&rest body)
(declare (indent 0)
(debug t))
@@ -31,10 +36,7 @@
(insert "(a b")
(save-excursion (insert " c d)"))
,@body
- (with-no-warnings
- (cons (buffer-substring (point-min) (point))
- (buffer-substring (point) (point-max))))))
-
+ (with-no-warnings (simple-test--buffer-substrings))))
;;; `transpose-sexps'
@@ -46,8 +48,7 @@
(insert "(s1) (s2) (s3) (s4) (s5)")
(backward-sexp 1)
,@body
- (cons (buffer-substring (point-min) (point))
- (buffer-substring (point) (point-max)))))
+ (simple-test--buffer-substrings)))
;;; Transposition with negative args (bug#20698, bug#21885)
(ert-deftest simple-transpose-subr ()
@@ -214,6 +215,147 @@
(remove-hook 'post-self-insert-hook inc))))
+;;; `delete-indentation'
+
+(ert-deftest simple-delete-indentation-no-region ()
+ "Test `delete-indentation' when no mark is set; see bug#35021."
+ (with-temp-buffer
+ (insert " first \n second \n third \n fourth ")
+ (should-not (mark t))
+ ;; Without prefix argument.
+ (should-not (call-interactively #'delete-indentation))
+ (should (equal (simple-test--buffer-substrings)
+ '(" first \n second \n third" . " fourth ")))
+ (should-not (call-interactively #'delete-indentation))
+ (should (equal (simple-test--buffer-substrings)
+ '(" first \n second" . " third fourth ")))
+ ;; With prefix argument.
+ (goto-char (point-min))
+ (let ((current-prefix-arg '(4)))
+ (should-not (call-interactively #'delete-indentation)))
+ (should (equal (simple-test--buffer-substrings)
+ '(" first" . " second third fourth ")))))
+
+(ert-deftest simple-delete-indentation-inactive-region ()
+ "Test `delete-indentation' with an inactive region."
+ (with-temp-buffer
+ (insert " first \n second \n third ")
+ (set-marker (mark-marker) (point-min))
+ (should (mark t))
+ (should-not (call-interactively #'delete-indentation))
+ (should (equal (simple-test--buffer-substrings)
+ '(" first \n second" . " third ")))))
+
+(ert-deftest simple-delete-indentation-blank-line ()
+ "Test `delete-indentation' does not skip blank lines.
+See bug#35036."
+ (with-temp-buffer
+ (insert "\n\n third \n \n \n sixth \n\n")
+ ;; Without prefix argument.
+ (should-not (delete-indentation))
+ (should (equal (simple-test--buffer-substrings)
+ '("\n\n third \n \n \n sixth \n" . "")))
+ (should-not (delete-indentation))
+ (should (equal (simple-test--buffer-substrings)
+ '("\n\n third \n \n \n sixth" . "")))
+ (should-not (delete-indentation))
+ (should (equal (simple-test--buffer-substrings)
+ '("\n\n third \n \n" . "sixth")))
+ ;; With prefix argument.
+ (goto-char (point-min))
+ (should-not (delete-indentation t))
+ (should (equal (simple-test--buffer-substrings)
+ '("" . "\n third \n \nsixth")))
+ (should-not (delete-indentation t))
+ (should (equal (simple-test--buffer-substrings)
+ '("" . "third \n \nsixth")))
+ (should-not (delete-indentation t))
+ (should (equal (simple-test--buffer-substrings)
+ '("third" . "\nsixth")))
+ (should-not (delete-indentation t))
+ (should (equal (simple-test--buffer-substrings)
+ '("third" . " sixth")))))
+
+(ert-deftest simple-delete-indentation-boundaries ()
+ "Test `delete-indentation' motion at buffer boundaries."
+ (with-temp-buffer
+ (insert " first \n second \n third ")
+ ;; Stay at EOB.
+ (should-not (delete-indentation t))
+ (should (equal (simple-test--buffer-substrings)
+ '(" first \n second \n third " . "")))
+ ;; Stay at BOB.
+ (forward-line -1)
+ (save-restriction
+ (narrow-to-region (point) (line-end-position))
+ (should-not (delete-indentation))
+ (should (equal (simple-test--buffer-substrings)
+ '("" . " second ")))
+ ;; Go to EOB.
+ (should-not (delete-indentation t))
+ (should (equal (simple-test--buffer-substrings)
+ '(" second " . ""))))
+ ;; Go to BOB.
+ (end-of-line 0)
+ (should-not (delete-indentation))
+ (should (equal (simple-test--buffer-substrings)
+ '("" . " first \n second \n third ")))))
+
+(ert-deftest simple-delete-indentation-region ()
+ "Test `delete-indentation' with an active region."
+ (with-temp-buffer
+ ;; Empty region.
+ (insert " first ")
+ (should-not (delete-indentation nil (point) (point)))
+ (should (equal (simple-test--buffer-substrings)
+ '(" first " . "")))
+ ;; Single line.
+ (should-not (delete-indentation
+ nil (line-beginning-position) (1- (point))))
+ (should (equal (simple-test--buffer-substrings)
+ '("" . " first ")))
+ (should-not (delete-indentation nil (1+ (point)) (line-end-position)))
+ (should (equal (simple-test--buffer-substrings)
+ '(" " . "first ")))
+ (should-not (delete-indentation
+ nil (line-beginning-position) (line-end-position)))
+ (should (equal (simple-test--buffer-substrings)
+ '("" . " first ")))
+ ;; Multiple lines.
+ (goto-char (point-max))
+ (insert "\n second \n third \n fourth ")
+ (goto-char (point-min))
+ (should-not (delete-indentation
+ nil (line-end-position) (line-beginning-position 2)))
+ (should (equal (simple-test--buffer-substrings)
+ '(" first" . " second \n third \n fourth ")))
+ (should-not (delete-indentation
+ nil (point) (1+ (line-beginning-position 2))))
+ (should (equal (simple-test--buffer-substrings)
+ '(" first second" . " third \n fourth ")))
+ ;; Prefix argument overrides region.
+ (should-not (delete-indentation t (point-min) (point)))
+ (should (equal (simple-test--buffer-substrings)
+ '(" first second third" . " fourth ")))))
+
+(ert-deftest simple-delete-indentation-prefix ()
+ "Test `delete-indentation' with a fill prefix."
+ (with-temp-buffer
+ (insert "> first \n> second \n> third \n> fourth ")
+ (let ((fill-prefix ""))
+ (delete-indentation))
+ (should (equal (simple-test--buffer-substrings)
+ '("> first \n> second \n> third" . " > fourth ")))
+ (let ((fill-prefix "<"))
+ (delete-indentation))
+ (should (equal (simple-test--buffer-substrings)
+ '("> first \n> second" . " > third > fourth ")))
+ (let ((fill-prefix ">"))
+ (delete-indentation))
+ (should (equal (simple-test--buffer-substrings)
+ '("> first" . " second > third > fourth ")))))
+
+
;;; `delete-trailing-whitespace'
(ert-deftest simple-delete-trailing-whitespace--bug-21766 ()
"Test bug#21766: delete-whitespace sometimes deletes non-whitespace."
@@ -448,6 +590,17 @@ See Bug#21722."
(call-interactively #'eval-expression)
(should (equal (current-message) "66 (#o102, #x42, ?B)"))))))
+(ert-deftest command-execute-prune-command-history ()
+ "Check that Bug#31211 is fixed."
+ (let ((history-length 1)
+ (command-history ()))
+ (dotimes (_ (1+ history-length))
+ (command-execute "" t))
+ (should (= (length command-history) history-length))))
+
+
+;;; `line-number-at-pos'
+
(ert-deftest line-number-at-pos-in-widen-buffer ()
(let ((target-line 3))
(with-temp-buffer
@@ -489,13 +642,12 @@ See Bug#21722."
(should (equal pos (point))))))
(ert-deftest line-number-at-pos-when-passing-point ()
- (let (pos)
- (with-temp-buffer
- (insert "a\nb\nc\nd\n")
- (should (equal (line-number-at-pos 1) 1))
- (should (equal (line-number-at-pos 3) 2))
- (should (equal (line-number-at-pos 5) 3))
- (should (equal (line-number-at-pos 7) 4)))))
+ (with-temp-buffer
+ (insert "a\nb\nc\nd\n")
+ (should (equal (line-number-at-pos 1) 1))
+ (should (equal (line-number-at-pos 3) 2))
+ (should (equal (line-number-at-pos 5) 3))
+ (should (equal (line-number-at-pos 7) 4))))
;;; Auto fill.
@@ -511,5 +663,53 @@ See Bug#21722."
(do-auto-fill)
(should (string-equal (buffer-string) "foo bar"))))
+
+;;; Shell command.
+
+(ert-deftest simple-tests-async-shell-command-30280 ()
+ "Test for https://debbugs.gnu.org/30280 ."
+ (let* ((async-shell-command-buffer 'new-buffer)
+ (async-shell-command-display-buffer nil)
+ (base "name")
+ (first (buffer-name (generate-new-buffer base)))
+ (second (generate-new-buffer-name base))
+ ;; `save-window-excursion' doesn't restore frame configurations.
+ (pop-up-frames nil)
+ (inhibit-message t)
+ (emacs (expand-file-name invocation-name invocation-directory)))
+ (skip-unless (file-executable-p emacs))
+ ;; Let `shell-command' create the buffer as needed.
+ (kill-buffer first)
+ (unwind-protect
+ (save-window-excursion
+ ;; One command has no output, the other does.
+ ;; Removing the -eval argument also yields no output, but
+ ;; then both commands exit simultaneously when
+ ;; `accept-process-output' is called on the second command.
+ (dolist (form '("(sleep-for 8)" "(message \"\")"))
+ (async-shell-command (format "%s -Q -batch -eval '%s'"
+ emacs form)
+ first))
+ ;; First command should neither have nor display output.
+ (let* ((buffer (get-buffer first))
+ (process (get-buffer-process buffer)))
+ (should (buffer-live-p buffer))
+ (should process)
+ (should (zerop (buffer-size buffer)))
+ (should (not (get-buffer-window buffer))))
+ ;; Second command should both have and display output.
+ (let* ((buffer (get-buffer second))
+ (process (get-buffer-process buffer)))
+ (should (buffer-live-p buffer))
+ (should process)
+ (should (accept-process-output process 4 nil t))
+ (should (> (buffer-size buffer) 0))
+ (should (get-buffer-window buffer))))
+ (dolist (name (list first second))
+ (let* ((buffer (get-buffer name))
+ (process (and buffer (get-buffer-process buffer))))
+ (when process (delete-process process))
+ (when buffer (kill-buffer buffer)))))))
+
(provide 'simple-test)
;;; simple-test.el ends here
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index aa16a0da34e..c458eef2f93 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -26,7 +26,6 @@
;;
;;; Code:
-
(require 'ert)
(eval-when-compile (require 'cl-lib))
@@ -62,6 +61,18 @@
(quote
(0 font-lock-keyword-face))))))))
+(ert-deftest provided-mode-derived-p ()
+ ;; base case: `derived-mode' directly derives `prog-mode'
+ (should (progn
+ (define-derived-mode derived-mode prog-mode "test")
+ (provided-mode-derived-p 'derived-mode 'prog-mode)))
+ ;; edge case: `derived-mode' derives an alias of `prog-mode'
+ (should (progn
+ (defalias 'parent-mode
+ (if (fboundp 'prog-mode) 'prog-mode 'fundamental-mode))
+ (define-derived-mode derived-mode parent-mode "test")
+ (provided-mode-derived-p 'derived-mode 'prog-mode))))
+
(ert-deftest number-sequence-test ()
(should (= (length
(number-sequence (1- most-positive-fixnum) most-positive-fixnum))
@@ -307,6 +318,25 @@ cf. Bug#25477."
(should (eq (string-to-char (symbol-name (gensym))) ?g))
(should (eq (string-to-char (symbol-name (gensym "X"))) ?X)))
+(ert-deftest subr-tests--assq-delete-all ()
+ "Test `assq-delete-all' behavior."
+ (cl-flet ((new-list-fn
+ ()
+ (list (cons 'a 1) (cons 'b 2) (cons 'c 3) 'd (cons "foo" "bar"))))
+ (should (equal (cdr (new-list-fn)) (assq-delete-all 'a (new-list-fn))))
+ (should (equal (new-list-fn) (assq-delete-all 'd (new-list-fn))))
+ (should (equal (new-list-fn) (assq-delete-all "foo" (new-list-fn))))))
+
+(ert-deftest subr-tests--assoc-delete-all ()
+ "Test `assoc-delete-all' behavior."
+ (cl-flet ((new-list-fn
+ ()
+ (list (cons 'a 1) (cons 'b 2) (cons 'c 3) 'd (cons "foo" "bar"))))
+ (should (equal (cdr (new-list-fn)) (assoc-delete-all 'a (new-list-fn))))
+ (should (equal (new-list-fn) (assoc-delete-all 'd (new-list-fn))))
+ (should (equal (butlast (new-list-fn))
+ (assoc-delete-all "foo" (new-list-fn))))))
+
(ert-deftest shell-quote-argument-%-on-w32 ()
"Quoting of `%' in w32 shells isn't perfect.
See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350."
@@ -324,5 +354,24 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350."
(shell-quote-argument "%ca%")))
"without-caret %ca%"))))
+(ert-deftest subr-tests-flatten-tree ()
+ "Test `flatten-tree' behavior."
+ (should (equal (flatten-tree '(1 (2 . 3) nil (4 5 (6)) 7))
+ '(1 2 3 4 5 6 7)))
+ (should (equal (flatten-tree '((1 . 2)))
+ '(1 2)))
+ (should (equal (flatten-tree '(1 nil 2))
+ '(1 2)))
+ (should (equal (flatten-tree 42)
+ '(42)))
+ (should (equal (flatten-tree t)
+ '(t)))
+ (should (equal (flatten-tree nil)
+ nil))
+ (should (equal (flatten-tree '((nil) ((((nil)))) nil))
+ nil))
+ (should (equal (flatten-tree '(1 ("foo" "bar") 2))
+ '(1 "foo" "bar" 2))))
+
(provide 'subr-tests)
;;; subr-tests.el ends here
diff --git a/test/lisp/tar-mode-tests.el b/test/lisp/tar-mode-tests.el
index 3ad0ced01d6..1fce200721b 100644
--- a/test/lisp/tar-mode-tests.el
+++ b/test/lisp/tar-mode-tests.el
@@ -21,6 +21,8 @@
(require 'ert)
(require 'tar-mode)
+(defvar tar-mode-tests-data-directory
+ (expand-file-name "test/data/decompress" source-directory))
(ert-deftest tar-mode-test-tar-grind-file-mode ()
(let ((alist (list (cons 448 "rwx------")
@@ -31,6 +33,17 @@
(dolist (x alist)
(should (equal (cdr x) (tar-grind-file-mode (car x)))))))
+(ert-deftest tar-mode-test-tar-extract-gz ()
+ (skip-unless (executable-find "gzip"))
+ (let* ((tar-file (expand-file-name "tg.tar.gz" tar-mode-tests-data-directory))
+ tar-buffer gz-buffer)
+ (unwind-protect
+ (with-current-buffer (setq tar-buffer (find-file-noselect tar-file))
+ (setq gz-buffer (tar-extract))
+ (should (equal (char-after) ?\N{SNOWFLAKE})))
+ (when (buffer-live-p tar-buffer) (kill-buffer tar-buffer))
+ (when (buffer-live-p gz-buffer) (kill-buffer gz-buffer)))))
+
(provide 'tar-mode-tests)
;; tar-mode-tests.el ends here
diff --git a/test/lisp/term-tests.el b/test/lisp/term-tests.el
index c2b90dea604..9f5dcd559eb 100644
--- a/test/lisp/term-tests.el
+++ b/test/lisp/term-tests.el
@@ -89,6 +89,13 @@ first line\r_next line\r\n"))
"\e[2;1Hc"
"\e[1;2Hb"
"\e[1;1Ha") "" t))))
+ (should (equal "abcde j"
+ (term-test-screen-from-input
+ 10 12 '("abcdefghij"
+ "\e[H" ;move back to point-min
+ "abcde"
+ " j"))))
+
;; Relative positioning.
(should (equal "ab\ncd"
(term-test-screen-from-input
@@ -124,6 +131,18 @@ line6\r
40 12 (list "\eAnSiTc /f" "oo/\n") 'default-directory)
"/foo/"))))
+(ert-deftest term-line-wrapping-then-motion ()
+ "Make sure we reset the line-wrapping state after moving cursor.
+A real-life example is the default zsh prompt which writes spaces
+to the end of line (triggering line-wrapping state), and then
+sends a carriage return followed by another space to overwrite
+the first character of the line."
+ (let* ((width 10)
+ (strs (list "x" (make-string (1- width) ?_)
+ "\r_")))
+ (should (equal (term-test-screen-from-input width 12 strs)
+ (make-string width ?_)))))
+
(ert-deftest term-to-margin ()
"Test cursor movement at the scroll margin.
This is a reduced example from GNU nano's initial screen."
@@ -144,7 +163,6 @@ This is a reduced example from GNU nano's initial screen."
`("\e[1;3r" "\e[2;1H" ,x "\r\e[1A" ,y))
(concat y "\n" x)))))
-
(provide 'term-tests)
;;; term-tests.el ends here
diff --git a/test/lisp/textmodes/conf-mode-tests.el b/test/lisp/textmodes/conf-mode-tests.el
new file mode 100644
index 00000000000..3eefc8f84f9
--- /dev/null
+++ b/test/lisp/textmodes/conf-mode-tests.el
@@ -0,0 +1,204 @@
+;;; conf-mode-tests.el --- Test suite for conf mode -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2016-2019 Free Software Foundation, Inc.
+
+;; Author: J. Alexander Branham <alex.branham@gmail.com>
+;; Keywords: internal
+
+;; This file is part of GNU Emacs.
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+(require 'conf-mode)
+(require 'ert)
+
+(ert-deftest conf-test-align-assignments ()
+ "Test for `conf-align-assignments'."
+ (with-temp-buffer
+ (insert "foo: bar\nbar: baz")
+ (conf-colon-mode)
+ (conf-align-assignments)
+ (should (equal (buffer-string)
+ "foo: bar\nbar: baz"))))
+
+(ert-deftest conf-test-font-lock ()
+ (with-temp-buffer
+ (insert "foo: bar\nbar: baz")
+ (conf-colon-mode)
+ (font-lock-mode)
+ (font-lock-ensure)
+ (goto-char (point-min))
+ (should (equal (face-at-point) 'font-lock-variable-name-face))
+ (search-forward "bar")
+ (should-not (face-at-point))))
+
+(ert-deftest conf-test-windows-mode ()
+ (with-temp-buffer
+ ;; from `conf-windows-mode' docstring:
+ (insert "[ExtShellFolderViews]
+Default={5984FFE0-28D4-11CF-AE66-08002B2E1262}
+{5984FFE0-28D4-11CF-AE66-08002B2E1262}={5984FFE0-28D4-11CF-AE66-08002B2E1262}
+
+[{5984FFE0-28D4-11CF-AE66-08002B2E1262}]
+PersistMoniker=file://Folder.htt")
+ (goto-char (point-min))
+ (conf-windows-mode)
+ (font-lock-mode)
+ (font-lock-ensure)
+ (search-forward "ExtShell")
+ (should (equal (face-at-point) 'font-lock-type-face))
+ (search-forward "Defau")
+ (should (equal (face-at-point) 'font-lock-variable-name-face))
+ (forward-line)
+ (beginning-of-line)
+ (should (equal (face-at-point) 'font-lock-variable-name-face))
+ (forward-line 2)
+ (should-not (face-at-point))
+ (forward-char)
+ (should (equal (face-at-point) 'font-lock-type-face))))
+
+(ert-deftest conf-test-javaprop-mode ()
+ (with-temp-buffer
+ ;; From `conf-javaprop-mode' docstring
+ (insert "// another kind of comment
+/* yet another */
+
+name:value
+name=value
+name value
+x.1 =
+x.2.y.1.z.1 =
+x.2.y.1.z.2.zz =")
+ (goto-char (point-min))
+ (conf-javaprop-mode)
+ (font-lock-mode)
+ (font-lock-ensure)
+ (should (equal (face-at-point) 'font-lock-comment-delimiter-face))
+ (forward-char 3)
+ (should (equal (face-at-point) 'font-lock-comment-face))
+ (search-forward "*")
+ (should (equal (face-at-point) 'font-lock-comment-delimiter-face))
+ (while (search-forward "nam" nil t)
+ (should (equal (face-at-point) 'font-lock-variable-name-face))
+ (search-forward "val")
+ (should-not (face-at-point)))
+ (while (re-search-forward "a-z" nil t)
+ (backward-char)
+ (should (equal (face-at-point) 'font-lock-variable-name-face))
+ (re-search-forward "[0-0]" nil t)
+ (backward-char)
+ (should (equal (face-at-point) 'font-lock-constant-face)))))
+
+(ert-deftest conf-test-space-mode ()
+ ;; From `conf-space-mode' docstring.
+ (with-temp-buffer
+ (insert "image/jpeg jpeg jpg jpe
+image/png png
+image/tiff tiff tif
+")
+ (goto-char (point-min))
+ (conf-space-mode)
+ (font-lock-mode)
+ (font-lock-ensure)
+ (should (equal (face-at-point) 'font-lock-variable-name-face))
+ (forward-char 15)
+ (should-not (face-at-point))))
+
+(ert-deftest conf-test-colon-mode ()
+ ;; From `conf-colon-mode' docstring.
+ (with-temp-buffer
+ (insert "<Multi_key> <exclam> <exclam> : \"\\241\" exclamdown
+<Multi_key> <c> <slash> : \"\\242\" cent")
+ (goto-char (point-min))
+ (conf-colon-mode)
+ (font-lock-mode)
+ (font-lock-ensure)
+ (should (equal (face-at-point) 'font-lock-variable-name-face))
+ (search-forward "24")
+ (should (equal (face-at-point) 'font-lock-string-face))
+ (forward-line)
+ (should (equal (face-at-point) 'font-lock-variable-name-face))))
+
+(ert-deftest conf-test-ppd-mode ()
+ ;; From `conf-ppd-mode' docstring.
+ (with-temp-buffer
+ (insert "*DefaultTransfer: Null
+*Transfer Null.Inverse: \"{ 1 exch sub }\"")
+ (goto-char (point-min))
+ (conf-ppd-mode)
+ (font-lock-mode)
+ (font-lock-ensure)
+ (should (equal (face-at-point) 'font-lock-variable-name-face))
+ (search-forward "Nul")
+ (should-not (face-at-point))))
+
+(ert-deftest conf-test-xdefaults-mode ()
+ ;; From `conf-xdefaults-mode' docstring.
+ (with-temp-buffer
+ (insert "*background: gray99
+*foreground: black")
+ (goto-char (point-min))
+ (conf-xdefaults-mode)
+ (font-lock-mode)
+ (font-lock-ensure)
+ (should (equal (face-at-point) 'font-lock-variable-name-face))
+ (search-forward "gray")
+ (should-not (face-at-point))))
+
+(ert-deftest conf-test-toml-mode ()
+ ;; From `conf-toml-mode' docstring.
+ (with-temp-buffer
+ (insert "\[entry]
+value = \"some string\"")
+ (goto-char (point-min))
+ (conf-toml-mode)
+ (font-lock-mode)
+ (font-lock-ensure)
+ (should-not (face-at-point))
+ (forward-char)
+ (should (equal (face-at-point) 'font-lock-type-face))
+ (forward-line)
+ (should (equal (face-at-point) 'font-lock-variable-name-face))
+ (search-forward "som")
+ (should (equal (face-at-point) 'font-lock-string-face))))
+
+(ert-deftest conf-test-desktop-mode ()
+ ;; From `conf-desktop-mode' dostring.
+ (with-temp-buffer
+ (insert " [Desktop Entry]
+ Name=GNU Image Manipulation Program
+ Name[oc]=Editor d'imatge GIMP
+ Exec=gimp-2.8 %U
+ Terminal=false")
+ (goto-char (point-min))
+ (conf-desktop-mode)
+ (font-lock-mode)
+ (font-lock-ensure)
+ (search-forward "Desk")
+ (should (equal (face-at-point) 'font-lock-type-face))
+ (search-forward "Nam")
+ (should (equal (face-at-point) 'font-lock-variable-name-face))
+ (forward-char 2)
+ (should-not (face-at-point))
+ (search-forward "[")
+ (should (equal (face-at-point) 'font-lock-constant-face))))
+
+
+
+(provide 'conf-mode-tests)
+
+;;; conf-mode-tests.el ends here
diff --git a/test/lisp/textmodes/css-mode-tests.el b/test/lisp/textmodes/css-mode-tests.el
index c16ad3ac287..98dac7478f2 100644
--- a/test/lisp/textmodes/css-mode-tests.el
+++ b/test/lisp/textmodes/css-mode-tests.el
@@ -85,7 +85,7 @@
(insert "body { top: 0; }")
(goto-char 7)
(should (equal (css-current-defun-name) "body"))
- (goto-char 18)
+ (goto-char 15)
(should (equal (css-current-defun-name) "body"))))
(ert-deftest css-test-current-defun-name-nested ()
@@ -244,6 +244,99 @@
(should (member "body" completions))
(should-not (member "article" completions)))))
+(ert-deftest css-test-color-to-4-dpc ()
+ (should (equal (css--color-to-4-dpc "#ffffff")
+ (css--color-to-4-dpc "#fff")))
+ (should (equal (css--color-to-4-dpc "#aabbcc")
+ (css--color-to-4-dpc "#abc")))
+ (should (equal (css--color-to-4-dpc "#fab")
+ "#ffffaaaabbbb"))
+ (should (equal (css--color-to-4-dpc "#fafbfc")
+ "#fafafbfbfcfc")))
+
+(ert-deftest css-test-format-hex ()
+ (should (equal (css--format-hex "#fff") "#fff"))
+ (should (equal (css--format-hex "#ffffff") "#fff"))
+ (should (equal (css--format-hex "#aabbcc") "#abc"))
+ (should (equal (css--format-hex "#12ff34") "#12ff34"))
+ (should (equal (css--format-hex "#aabbccdd") "#abcd"))
+ (should (equal (css--format-hex "#aabbccde") "#aabbccde"))
+ (should (equal (css--format-hex "#abcdef") "#abcdef")))
+
+(ert-deftest css-test-named-color-to-hex ()
+ (dolist (item '(("black" "#000")
+ ("white" "#fff")
+ ("salmon" "#fa8072")))
+ (with-temp-buffer
+ (css-mode)
+ (insert (nth 0 item))
+ (css--named-color-to-hex)
+ (should (equal (buffer-string) (nth 1 item))))))
+
+(ert-deftest css-test-format-rgba-alpha ()
+ (should (equal (css--format-rgba-alpha 0) "0"))
+ (should (equal (css--format-rgba-alpha 0.0) "0"))
+ (should (equal (css--format-rgba-alpha 0.00001) "0"))
+ (should (equal (css--format-rgba-alpha 1) "1"))
+ (should (equal (css--format-rgba-alpha 1.0) "1"))
+ (should (equal (css--format-rgba-alpha 1.00001) "1"))
+ (should (equal (css--format-rgba-alpha 0.10000) "0.1"))
+ (should (equal (css--format-rgba-alpha 0.100001) "0.1"))
+ (should (equal (css--format-rgba-alpha 0.2524334) "0.25")))
+
+(ert-deftest css-test-hex-to-rgb ()
+ (dolist (item '(("#000" "rgb(0, 0, 0)")
+ ("#000000" "rgb(0, 0, 0)")
+ ("#fff" "rgb(255, 255, 255)")
+ ("#ffffff" "rgb(255, 255, 255)")
+ ("#ffffff80" "rgba(255, 255, 255, 0.5)")
+ ("#fff0" "rgba(255, 255, 255, 0)")
+ ("#fff8" "rgba(255, 255, 255, 0.53)")
+ ("#ffff" "rgba(255, 255, 255, 1)")))
+ (with-temp-buffer
+ (css-mode)
+ (insert (nth 0 item))
+ (css--hex-to-rgb)
+ (should (equal (buffer-string) (nth 1 item))))))
+
+(ert-deftest css-test-rgb-to-named-color-or-hex ()
+ (dolist (item '(("rgb(0, 0, 0)" "black")
+ ("rgb(255, 255, 255)" "white")
+ ("rgb(255, 255, 240)" "ivory")
+ ("rgb(18, 52, 86)" "#123456")
+ ("rgba(18, 52, 86, 0.5)" "#12345680")
+ ("rgba(18, 52, 86, 50%)" "#12345680")
+ ("rgba(50%, 50%, 50%, 50%)" "#80808080")))
+ (with-temp-buffer
+ (css-mode)
+ (insert (nth 0 item))
+ (css--rgb-to-named-color-or-hex)
+ (should (equal (buffer-string) (nth 1 item))))))
+
+(ert-deftest css-test-cycle-color-format ()
+ (with-temp-buffer
+ (css-mode)
+ (insert "black")
+ (css-cycle-color-format)
+ (should (equal (buffer-string) "#000"))
+ (css-cycle-color-format)
+ (should (equal (buffer-string) "rgb(0, 0, 0)"))
+ (css-cycle-color-format)
+ (should (equal (buffer-string) "black"))))
+
+(ert-deftest css-test-join-nested-selectors ()
+ (should (equal (css--join-nested-selectors '("div" "&:hover"))
+ "div:hover"))
+ (should
+ (equal (css--join-nested-selectors '("a" "&::before, &::after"))
+ "a::before, a::after"))
+ (should
+ (equal (css--join-nested-selectors
+ '("article" "& > .front-page" "& h1, & h2"))
+ "article > .front-page h1, article > .front-page h2"))
+ (should (equal (css--join-nested-selectors '(".link" "& + &"))
+ ".link + .link")))
+
(ert-deftest css-mdn-symbol-guessing ()
(dolist (item '(("@med" "ia" "@media")
("@keyframes " "{" "@keyframes")
@@ -263,11 +356,11 @@
(ert-deftest css-test-rgb-parser ()
(with-temp-buffer
(css-mode)
- (dolist (input '("255, 0, 127"
- "255, /* comment */ 0, 127"
- "255 0 127"
- "255, 0, 127, 0.75"
- "255 0 127 / 0.75"
+ (dolist (input '("255, 0, 128"
+ "255, /* comment */ 0, 128"
+ "255 0 128"
+ "255, 0, 128, 0.75"
+ "255 0 128 / 0.75"
"100%, 0%, 50%"
"100%, 0%, 50%, 0.115"
"100% 0% 50%"
@@ -275,7 +368,7 @@
(erase-buffer)
(save-excursion
(insert input ")"))
- (should (equal (css--rgb-color) "#ff007f")))))
+ (should (equal (css--rgb-color) "#ff0080")))))
(ert-deftest css-test-hsl-parser ()
(with-temp-buffer
@@ -301,6 +394,12 @@
(should (equal (css--hex-color "#aabbcc") "#aabbcc"))
(should (equal (css--hex-color "#aabbccdd") "#aabbcc")))
+(ert-deftest css-test-hex-alpha ()
+ (should (equal (css--hex-alpha "#abcd") "d"))
+ (should-not (css--hex-alpha "#abc"))
+ (should (equal (css--hex-alpha "#aabbccdd") "dd"))
+ (should-not (css--hex-alpha "#aabbcc")))
+
(ert-deftest css-test-named-color ()
(dolist (text '("@mixin black" "@include black"))
(with-temp-buffer
diff --git a/test/lisp/textmodes/fill-tests.el b/test/lisp/textmodes/fill-tests.el
new file mode 100644
index 00000000000..08728746629
--- /dev/null
+++ b/test/lisp/textmodes/fill-tests.el
@@ -0,0 +1,50 @@
+;;; fill-test.el --- ERT tests for fill.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2017-2019 Free Software Foundation, Inc.
+
+;; Author: Marcin Borkowski <mbork@mbork.pl>
+;; Keywords: text, wp
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package defines tests for the filling feature, specifically
+;; the `fill-polish-nobreak-p' function.
+
+;;; Code:
+
+(require 'ert)
+
+(ert-deftest fill-test-no-fill-polish-nobreak-p nil
+ "Tests of the `fill-polish-nobreak-p' function."
+ (with-temp-buffer
+ (insert "Abc d efg (h ijk).")
+ (setq fill-column 8)
+ (setq-local fill-nobreak-predicate '())
+ (fill-paragraph)
+ (should (string= (buffer-string) "Abc d\nefg (h\nijk).")))
+ (with-temp-buffer
+ (insert "Abc d efg (h ijk).")
+ (setq fill-column 8)
+ (setq-local fill-nobreak-predicate '(fill-polish-nobreak-p))
+ (fill-paragraph)
+ (should (string= (buffer-string) "Abc\nd efg\n(h ijk)."))))
+
+
+(provide 'fill-tests)
+
+;;; fill-tests.el ends here
diff --git a/test/lisp/textmodes/sgml-mode-tests.el b/test/lisp/textmodes/sgml-mode-tests.el
index 20b5e27ff5d..61ae87e36db 100644
--- a/test/lisp/textmodes/sgml-mode-tests.el
+++ b/test/lisp/textmodes/sgml-mode-tests.el
@@ -131,5 +131,35 @@ The point is set to the beginning of the buffer."
(sgml-delete-tag 1)
(should (string= "Winter is comin'" (buffer-string)))))
+(ert-deftest sgml-quote-works ()
+ (let ((text "Foo<Bar> \"Baz\" 'Qux'\n"))
+ (with-temp-buffer
+ ;; Back and forth transformation.
+ (insert text)
+ (sgml-quote (point-min) (point-max))
+ (should (string= "Foo&lt;Bar&gt; &#34;Baz&#34; &#39;Qux&#39;\n"
+ (buffer-string)))
+ (sgml-quote (point-min) (point-max) t)
+ (should (string= text (buffer-string)))
+
+ ;; The same text escaped differently.
+ (erase-buffer)
+ (insert "Foo&lt;Bar&gt; &#34;Baz&quot; &#x27;Qux&#X27;\n")
+ (sgml-quote (point-min) (point-max) t)
+ (should (string= text (buffer-string)))
+
+ ;; Lack of semicolon.
+ (erase-buffer)
+ (insert "&amp&amp")
+ (sgml-quote (point-min) (point-max) t)
+ (should (string= "&&" (buffer-string)))
+
+ ;; Double quoting
+ (sgml-quote (point-min) (point-max))
+ (sgml-quote (point-min) (point-max))
+ (sgml-quote (point-min) (point-max) t)
+ (sgml-quote (point-min) (point-max) t)
+ (should (string= "&&" (buffer-string))))))
+
(provide 'sgml-mode-tests)
;;; sgml-mode-tests.el ends here
diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el
index 452fcc6895b..347cc7f12cb 100644
--- a/test/lisp/thingatpt-tests.el
+++ b/test/lisp/thingatpt-tests.el
@@ -65,7 +65,10 @@
("http://example.com/ab)c" 4 url "http://example.com/ab)c")
;; URL markup, lacking schema
("<url:foo@example.com>" 1 url "mailto:foo@example.com")
- ("<url:ftp.example.net/abc/>" 1 url "ftp://ftp.example.net/abc/"))
+ ("<url:ftp.example.net/abc/>" 1 url "ftp://ftp.example.net/abc/")
+ ;; UUID, only hex is allowed
+ ("01234567-89ab-cdef-ABCD-EF0123456789" 1 uuid "01234567-89ab-cdef-ABCD-EF0123456789")
+ ("01234567-89ab-cdef-ABCD-EF012345678G" 1 uuid nil))
"List of thing-at-point tests.
Each list element should have the form
diff --git a/test/lisp/thread-tests.el b/test/lisp/thread-tests.el
new file mode 100644
index 00000000000..3f7beed35a6
--- /dev/null
+++ b/test/lisp/thread-tests.el
@@ -0,0 +1,96 @@
+;;; thread-tests.el --- Test suite for thread.el -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018-2019 Free Software Foundation, Inc.
+
+;; Author: Gemini Lasswell <gazally@runbox.com>
+;; Keywords: threads
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+
+;;; Code:
+
+(require 'ert)
+(require 'thread)
+
+;; Declare the functions used here in case Emacs has been configured
+;; --without-threads.
+(declare-function make-mutex "thread.c" (&optional name))
+(declare-function mutex-lock "thread.c" (mutex))
+(declare-function mutex-unlock "thread.c" (mutex))
+(declare-function make-thread "thread.c" (function &optional name))
+(declare-function thread-join "thread.c" (thread))
+(declare-function thread-yield "thread.c" ())
+
+(defvar thread-tests-flag)
+(defvar thread-tests-mutex (when (featurep 'threads) (make-mutex "mutex1")))
+
+(defun thread-tests--thread-function ()
+ (setq thread-tests-flag t)
+ (with-mutex thread-tests-mutex
+ (sleep-for 0.01)))
+
+(ert-deftest thread-tests-thread-list-send-error ()
+ "A thread can be sent an error signal from the *Thread List* buffer."
+ (skip-unless (featurep 'threads))
+ (cl-letf (((symbol-function 'y-or-n-p) (lambda (_prompt) t)))
+ (with-mutex thread-tests-mutex
+ (setq thread-tests-flag nil)
+ (let ((thread (make-thread #'thread-tests--thread-function
+ "thread-tests-wait")))
+ (while (not thread-tests-flag)
+ (thread-yield))
+ (list-threads)
+ (goto-char (point-min))
+ (re-search-forward
+ "^thread-tests.+[[:blank:]]+Blocked[[:blank:]]+.+mutex1.+?")
+ (thread-list-send-error-signal)
+ (should-error (thread-join thread))
+ (list-threads)
+ (goto-char (point-min))
+ (should-error (re-search-forward "thread-tests"))))))
+
+(ert-deftest thread-tests-thread-list-show-backtrace ()
+ "Show a backtrace for another thread from the *Thread List* buffer."
+ (skip-unless (featurep 'threads))
+ (let (thread)
+ (with-mutex thread-tests-mutex
+ (setq thread-tests-flag nil)
+ (setq thread
+ (make-thread #'thread-tests--thread-function "thread-tests-back"))
+ (while (not thread-tests-flag)
+ (thread-yield))
+ (list-threads)
+ (goto-char (point-min))
+ (re-search-forward
+ "^thread-tests.+[[:blank:]]+Blocked[[:blank:]]+.+mutex1.+?")
+ (thread-list-pop-to-backtrace)
+ (goto-char (point-min))
+ (re-search-forward "thread-tests-back")
+ (re-search-forward "mutex-lock")
+ (re-search-forward "thread-tests--thread-function"))
+ (thread-join thread)))
+
+(ert-deftest thread-tests-list-threads-error-when-not-configured ()
+ "Signal an error running `list-threads' if threads are not configured."
+ (skip-unless (not (featurep 'threads)))
+ (should-error (list-threads)))
+
+(provide 'thread-tests)
+
+;;; thread-tests.el ends here
diff --git a/test/lisp/url/url-handlers-test.el b/test/lisp/url/url-handlers-test.el
new file mode 100644
index 00000000000..1613f87e707
--- /dev/null
+++ b/test/lisp/url/url-handlers-test.el
@@ -0,0 +1,75 @@
+;;; url-handlers-test.el --- Test suite for url-handlers.el -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018-2019 Free Software Foundation, Inc.
+
+;; Author: Nicolas Petton <nicolas@petton.fr>
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert)
+(require 'url-handlers)
+
+(defmacro with-url-handler-mode (&rest body)
+ "Evaluate BODY with `url-handler-mode' turned on."
+ (declare (indent 0) (debug t))
+ (let ((url-handler-mode-active (make-symbol "url-handler-mode-active")))
+ `(let ((,url-handler-mode-active url-handler-mode))
+ (unwind-protect
+ (progn
+ (unless ,url-handler-mode-active
+ (url-handler-mode))
+ ,@body)
+ (unless ,url-handler-mode-active
+ (url-handler-mode -1))))))
+
+(ert-deftest url-handlers-file-name-directory/preserve-url-types ()
+ (with-url-handler-mode
+ (should (equal (file-name-directory "https://gnu.org/index.html")
+ "https://gnu.org/"))
+ (should (equal (file-name-directory "http://gnu.org/index.html")
+ "http://gnu.org/"))
+ (should (equal (file-name-directory "ftp://gnu.org/index.html")
+ "ftp://gnu.org/"))))
+
+(ert-deftest url-handlers-file-name-directory/should-not-handle-non-url-file-names ()
+ (with-url-handler-mode
+ (should-not (equal (file-name-directory "not-uri://gnu.org")
+ "not-uri://gnu.org/"))))
+
+(ert-deftest url-handlers-file-name-directory/sub-directories ()
+ (with-url-handler-mode
+ (should (equal (file-name-directory "https://foo/bar/baz/index.html")
+ "https://foo/bar/baz/"))))
+
+(ert-deftest url-handlers-file-name-directory/file-urls ()
+ (with-url-handler-mode
+ (should (equal (file-name-directory "file:///foo/bar/baz.txt")
+ "file:///foo/bar/"))
+ (should (equal (file-name-directory "file:///")
+ "file:///"))))
+
+;; Regression test for bug#30444
+(ert-deftest url-handlers-file-name-directory/no-filename ()
+ (with-url-handler-mode
+ (should (equal (file-name-directory "https://foo.org")
+ "https://foo.org/"))
+ (should (equal (file-name-directory "https://foo.org/")
+ "https://foo.org/"))))
+
+(provide 'url-handlers-test)
+;;; url-handlers-test.el ends here
diff --git a/test/lisp/url/url-util-tests.el b/test/lisp/url/url-util-tests.el
index 8af2b2cd55d..69117b81f42 100644
--- a/test/lisp/url/url-util-tests.el
+++ b/test/lisp/url/url-util-tests.el
@@ -46,6 +46,18 @@
("key2" "val2")
("key1" "val1")))))
+(ert-deftest url-domain-tests ()
+ (should (equal (url-domain (url-generic-parse-url "http://www.fsf.co.uk"))
+ "fsf.co.uk"))
+ (should (equal (url-domain (url-generic-parse-url "http://fsf.co.uk"))
+ "fsf.co.uk"))
+ (should (equal (url-domain (url-generic-parse-url "http://co.uk"))
+ nil))
+ (should (equal (url-domain (url-generic-parse-url "http://www.fsf.com"))
+ "fsf.com"))
+ (should (equal (url-domain (url-generic-parse-url "http://192.168.0.1"))
+ nil)))
+
(provide 'url-util-tests)
;;; url-util-tests.el ends here
diff --git a/test/lisp/vc/diff-mode-tests.el b/test/lisp/vc/diff-mode-tests.el
index 54cabe6e48a..676d461076b 100644
--- a/test/lisp/vc/diff-mode-tests.el
+++ b/test/lisp/vc/diff-mode-tests.el
@@ -21,7 +21,10 @@
;;; Code:
(require 'diff-mode)
+(require 'diff)
+(defconst diff-mode-tests--datadir
+ (expand-file-name "test/data/vc/diff-mode" source-directory))
(ert-deftest diff-mode-test-ignore-trailing-dashes ()
"Check to make sure we successfully ignore trailing -- made by
@@ -182,7 +185,7 @@ youthfulness
(with-temp-buffer
(cd temp-dir)
(insert patch)
- (beginning-of-buffer)
+ (goto-char (point-min))
(diff-apply-hunk)
(diff-apply-hunk)
(diff-apply-hunk))
@@ -199,5 +202,118 @@ youthfulness
(kill-buffer buf2)
(delete-directory temp-dir 'recursive))))))
+(ert-deftest diff-mode-test-font-lock ()
+ "Check font-locking of diff hunks."
+ (skip-unless (executable-find shell-file-name))
+ (skip-unless (executable-find diff-command))
+ (let ((default-directory diff-mode-tests--datadir)
+ (old "hello_world.c")
+ (new "hello_emacs.c")
+ (diff-buffer (get-buffer-create "*Diff*"))
+ (diff-refine 'font-lock)
+ (diff-font-lock-syntax t)
+ diff-beg)
+ (diff-no-select old new '("-u") 'no-async diff-buffer)
+ (with-current-buffer diff-buffer
+ (font-lock-ensure)
+ (narrow-to-region (progn (diff-hunk-next)
+ (setq diff-beg (diff-beginning-of-hunk)))
+ (diff-end-of-hunk))
+
+ (should (equal-including-properties
+ (buffer-string)
+ #("@@ -1,6 +1,6 @@
+ #include <stdio.h>
+ int main()
+ {
+- printf(\"Hello, World!\\n\");
++ printf(\"Hello, Emacs!\\n\");
+ return 0;
+ }
+"
+ 0 15 (face diff-hunk-header)
+ 16 36 (face diff-context)
+ 36 48 (face diff-context)
+ 48 51 (face diff-context)
+ 51 52 (face diff-indicator-removed)
+ 52 81 (face diff-removed)
+ 81 82 (face diff-indicator-added)
+ 82 111 (face diff-added)
+ 111 124 (face diff-context)
+ 124 127 (face diff-context))))
+
+ (should (equal (mapcar (lambda (o)
+ (list (- (overlay-start o) diff-beg)
+ (- (overlay-end o) diff-beg)
+ (append (and (overlay-get o 'diff-mode)
+ `(diff-mode ,(overlay-get o 'diff-mode)))
+ (and (overlay-get o 'face)
+ `(face ,(overlay-get o 'face))))))
+ (sort (overlays-in (point-min) (point-max))
+ (lambda (a b) (< (overlay-start a) (overlay-start b)))))
+ '((0 127 (diff-mode fine))
+ (0 127 (diff-mode syntax))
+ (17 25 (diff-mode syntax face font-lock-preprocessor-face))
+ (26 35 (diff-mode syntax face font-lock-string-face))
+ (37 40 (diff-mode syntax face font-lock-type-face))
+ (41 45 (diff-mode syntax face font-lock-function-name-face))
+ (61 78 (diff-mode syntax face font-lock-string-face))
+ (69 74 (diff-mode fine face diff-refine-removed))
+ (91 108 (diff-mode syntax face font-lock-string-face))
+ (99 104 (diff-mode fine face diff-refine-added))
+ (114 120 (diff-mode syntax face font-lock-keyword-face))))))))
+
+(ert-deftest diff-mode-test-font-lock-syntax-one-line ()
+ "Check diff syntax highlighting for one line with no newline at end."
+ (skip-unless (executable-find shell-file-name))
+ (skip-unless (executable-find diff-command))
+ (let ((default-directory diff-mode-tests--datadir)
+ (old "hello_world_1.c")
+ (new "hello_emacs_1.c")
+ (diff-buffer (get-buffer-create "*Diff*"))
+ (diff-refine nil)
+ (diff-font-lock-syntax t)
+ diff-beg)
+ (diff-no-select old new '("-u") 'no-async diff-buffer)
+ (with-current-buffer diff-buffer
+ (font-lock-ensure)
+ (narrow-to-region (progn (diff-hunk-next)
+ (setq diff-beg (diff-beginning-of-hunk)))
+ (diff-end-of-hunk))
+
+ (should (equal-including-properties
+ (buffer-string)
+ #("@@ -1 +1 @@
+-int main() { printf(\"Hello, World!\\n\"); return 0; }
+\\ No newline at end of file
++int main() { printf(\"Hello, Emacs!\\n\"); return 0; }
+\\ No newline at end of file
+"
+ 0 11 (face diff-hunk-header)
+ 12 13 (face diff-indicator-removed)
+ 13 65 (face diff-removed)
+ 65 93 (face diff-context)
+ 93 94 (face diff-indicator-added)
+ 94 146 (face diff-added)
+ 146 174 (face diff-context))))
+
+ (should (equal (mapcar (lambda (o)
+ (list (- (overlay-start o) diff-beg)
+ (- (overlay-end o) diff-beg)
+ (append (and (overlay-get o 'diff-mode)
+ `(diff-mode ,(overlay-get o 'diff-mode)))
+ (and (overlay-get o 'face)
+ `(face ,(overlay-get o 'face))))))
+ (sort (overlays-in (point-min) (point-max))
+ (lambda (a b) (< (overlay-start a) (overlay-start b)))))
+ '((0 174 (diff-mode syntax))
+ (13 16 (diff-mode syntax face font-lock-type-face))
+ (17 21 (diff-mode syntax face font-lock-function-name-face))
+ (33 50 (diff-mode syntax face font-lock-string-face))
+ (53 59 (diff-mode syntax face font-lock-keyword-face))
+ (94 97 (diff-mode syntax face font-lock-type-face))
+ (98 102 (diff-mode syntax face font-lock-function-name-face))
+ (114 131 (diff-mode syntax face font-lock-string-face))
+ (134 140 (diff-mode syntax face font-lock-keyword-face))))))))
(provide 'diff-mode-tests)
diff --git a/test/lisp/vc/vc-bzr-tests.el b/test/lisp/vc/vc-bzr-tests.el
index af65cd1c205..8fa16cdccb1 100644
--- a/test/lisp/vc/vc-bzr-tests.el
+++ b/test/lisp/vc/vc-bzr-tests.el
@@ -112,9 +112,6 @@
(ert-deftest vc-bzr-test-faulty-bzr-autoloads ()
"Test we can generate autoloads in a bzr directory when bzr is faulty."
(skip-unless (executable-find vc-bzr-program))
- ;; Avoid vc-mode-line bug;
- ;; http://lists.gnu.org/r/emacs-devel/2018-12/msg00368.html
- (skip-unless (not (eq 0 (user-real-uid))))
(let* ((homedir (make-temp-file "vc-bzr-test" t))
(bzrdir (expand-file-name "bzr" homedir))
(file (progn
diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el
index 2bc65198645..0e61d2a767a 100644
--- a/test/lisp/vc/vc-tests.el
+++ b/test/lisp/vc/vc-tests.el
@@ -109,7 +109,7 @@
(require 'ert)
(require 'vc)
-(declare-function w32-application-type "w32proc")
+(declare-function w32-application-type "w32proc.c")
;; The working horses.
diff --git a/test/lisp/wid-edit-tests.el b/test/lisp/wid-edit-tests.el
new file mode 100644
index 00000000000..a4350e715ed
--- /dev/null
+++ b/test/lisp/wid-edit-tests.el
@@ -0,0 +1,39 @@
+;;; wid-edit-tests.el --- tests for wid-edit.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2019 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'wid-edit)
+
+(ert-deftest widget-at ()
+ "Test `widget-at' behavior."
+ (with-temp-buffer
+ (should-not (widget-at))
+ (let ((marco (widget-create 'link "link widget"))
+ (polo (widget-at (1- (point)))))
+ (should (widgetp polo))
+ (should (eq marco polo)))
+ ;; Buttons and widgets are incompatible (bug#34506).
+ (insert-text-button "text button")
+ (should-not (widget-at (1- (point))))
+ (insert-button "overlay button")
+ (should-not (widget-at (1- (point))))))
+
+;;; wid-edit-tests.el ends here
diff --git a/test/lisp/xdg-tests.el b/test/lisp/xdg-tests.el
index 65084926203..9c815065b2a 100644
--- a/test/lisp/xdg-tests.el
+++ b/test/lisp/xdg-tests.el
@@ -65,4 +65,16 @@
(should (equal (xdg-desktop-strings " ") nil))
(should (equal (xdg-desktop-strings "a; ;") '("a" " "))))
+(ert-deftest xdg-mime-associations ()
+ "Test reading MIME associations from files."
+ (let* ((apps (expand-file-name "mimeapps.list" xdg-tests-data-dir))
+ (cache (expand-file-name "mimeinfo.cache" xdg-tests-data-dir))
+ (fs (list apps cache)))
+ (should (equal (xdg-mime-collect-associations "x-test/foo" fs)
+ '("a.desktop" "b.desktop")))
+ (should (equal (xdg-mime-collect-associations "x-test/bar" fs)
+ '("a.desktop" "c.desktop")))
+ (should (equal (xdg-mime-collect-associations "x-test/baz" fs)
+ '("a.desktop" "b.desktop" "d.desktop")))))
+
;;; xdg-tests.el ends here
diff --git a/test/manual/BidiCharacterTest.txt b/test/manual/BidiCharacterTest.txt
index 6a0df6dfb6d..064594b98a2 100644
--- a/test/manual/BidiCharacterTest.txt
+++ b/test/manual/BidiCharacterTest.txt
@@ -1,5 +1,5 @@
-# BidiCharacterTest-11.0.0.txt
-# Date: 2018-02-18, 05:50:00 GMT [LI]
+# BidiCharacterTest-12.0.0.txt
+# Date: 2018-11-02, 16:34:00 GMT [LI]
# © 2018 Unicode®, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
#
diff --git a/test/manual/cedet/semantic-ia-utest.el b/test/manual/cedet/semantic-ia-utest.el
index 07f8118f32a..665a5382440 100644
--- a/test/manual/cedet/semantic-ia-utest.el
+++ b/test/manual/cedet/semantic-ia-utest.el
@@ -434,7 +434,7 @@ tag that contains point, and return that."
(when (interactive-p)
(message "Found %d occurrences of %s in %.2f seconds"
Lcount (semantic-tag-name target)
- (semantic-elapsed-time start (current-time))))
+ (semantic-elapsed-time start nil)))
Lcount)))
(defun semantic-src-utest-buffer-refs ()
diff --git a/test/manual/cedet/semantic-tests.el b/test/manual/cedet/semantic-tests.el
index a98e01816ef..9109d665fa3 100644
--- a/test/manual/cedet/semantic-tests.el
+++ b/test/manual/cedet/semantic-tests.el
@@ -178,9 +178,8 @@ Optional argument ARG specifies not to use color."
"Test `semantic-idle-scheduler-work-parse-neighboring-files' and time it."
(interactive)
(let ((start (current-time))
- (junk (semantic-idle-scheduler-work-parse-neighboring-files))
- (end (current-time)))
- (message "Work took %.2f seconds." (semantic-elapsed-time start end))))
+ (junk (semantic-idle-scheduler-work-parse-neighboring-files)))
+ (message "Work took %.2f seconds." (semantic-elapsed-time start nil))))
;;; From semantic-lex:
@@ -195,10 +194,9 @@ If universal argument ARG, then try the whole buffer."
(result (semantic-lex
(if arg (point-min) (point))
(point-max)
- 100))
- (end (current-time)))
+ 100)))
(message "Elapsed Time: %.2f seconds."
- (semantic-elapsed-time start end))
+ (semantic-elapsed-time start nil))
(pop-to-buffer "*Lexer Output*")
(require 'pp)
(erase-buffer)
@@ -278,7 +276,7 @@ tag that contains point, and return that."
(when (interactive-p)
(message "Found %d occurrences of %s in %.2f seconds"
Lcount (semantic-tag-name target)
- (semantic-elapsed-time start (current-time))))
+ (semantic-elapsed-time start nil)))
Lcount)))
;;; From bovine-gcc:
diff --git a/test/manual/indent/css-mode.css b/test/manual/indent/css-mode.css
index 640418b022d..ecf6c3c0ca5 100644
--- a/test/manual/indent/css-mode.css
+++ b/test/manual/indent/css-mode.css
@@ -56,6 +56,8 @@ div::before {
sans-serif;
font: 15px "Helvetica Neue", Helvetica, Arial,
"Nimbus Sans L", sans-serif;
+ background: no-repeat right
+ 5px center;
transform: matrix(1.0, 2.0,
3.0, 4.0,
5.0, 6.0);
diff --git a/test/manual/indent/js-jsx.js b/test/manual/indent/js-jsx.js
deleted file mode 100644
index 7401939d282..00000000000
--- a/test/manual/indent/js-jsx.js
+++ /dev/null
@@ -1,85 +0,0 @@
-// -*- mode: js-jsx; -*-
-
-var foo = <div></div>;
-
-return (
- <div>
- </div>
- <div>
- <div></div>
- <div>
- <div></div>
- </div>
- </div>
-);
-
-React.render(
- <div>
- <div></div>
- </div>,
- {
- a: 1
- },
- <div>
- <div></div>
- </div>
-);
-
-return (
- // Sneaky!
- <div></div>
-);
-
-return (
- <div></div>
- // Sneaky!
-);
-
-React.render(
- <input
- />,
- {
- a: 1
- }
-);
-
-return (
- <div>
- {array.map(function () {
- return {
- a: 1
- };
- })}
- </div>
-);
-
-return (
- <div attribute={array.map(function () {
- return {
- a: 1
- };
-
- return {
- a: 1
- };
-
- return {
- a: 1
- };
- })}>
- </div>
-);
-
-// Local Variables:
-// indent-tabs-mode: nil
-// js-indent-level: 2
-// End:
-
-// The following test has intentionally unclosed elements and should
-// be placed below all other tests to prevent awkward indentation.
-
-return (
- <div>
- {array.map(function () {
- return {
- a: 1
diff --git a/test/manual/indent/js.js b/test/manual/indent/js.js
index df790986947..9658c95701c 100644
--- a/test/manual/indent/js.js
+++ b/test/manual/indent/js.js
@@ -151,6 +151,20 @@ let b = {
`
}
+// bug#25904
+foo.bar.baz(very => // A comment
+ very
+).biz(([baz={a: [123]}, boz]) =>
+ baz
+).snarf((snorf) => /* Another comment */
+ snorf
+);
+
+// Continuation of bug#25904; support broken arrow as N+1th arg
+map(arr, (val) =>
+ val
+)
+
// Local Variables:
// indent-tabs-mode: nil
// js-indent-level: 2
diff --git a/test/manual/indent/jsx-align-gt-with-lt.jsx b/test/manual/indent/jsx-align-gt-with-lt.jsx
new file mode 100644
index 00000000000..8eb1d6d718c
--- /dev/null
+++ b/test/manual/indent/jsx-align-gt-with-lt.jsx
@@ -0,0 +1,12 @@
+<element
+ attr=""
+ >
+</element>
+<input
+ />
+
+// Local Variables:
+// indent-tabs-mode: nil
+// js-indent-level: 2
+// js-jsx-align->-with-<: nil
+// End:
diff --git a/test/manual/indent/jsx-indent-level.jsx b/test/manual/indent/jsx-indent-level.jsx
new file mode 100644
index 00000000000..0a84b9eb77a
--- /dev/null
+++ b/test/manual/indent/jsx-indent-level.jsx
@@ -0,0 +1,13 @@
+return (
+ <element>
+ <element>
+ Hello World!
+ </element>
+ </element>
+)
+
+// Local Variables:
+// indent-tabs-mode: nil
+// js-indent-level: 4
+// js-jsx-indent-level: 2
+// End:
diff --git a/test/manual/indent/jsx-quote.jsx b/test/manual/indent/jsx-quote.jsx
new file mode 100644
index 00000000000..1b2c6528734
--- /dev/null
+++ b/test/manual/indent/jsx-quote.jsx
@@ -0,0 +1,16 @@
+// JSX text node values should be strings, but only JS string syntax
+// is considered, so quote marks delimit strings like normal, with
+// disastrous results (https://github.com/mooz/js2-mode/issues/409).
+function Bug() {
+ return <div>C'est Montréal</div>;
+}
+function Test(foo = /'/,
+ bar = 123) {}
+
+// This test is in a separate file because it can break other tests
+// when indenting the whole buffer (not sure why).
+
+// Local Variables:
+// indent-tabs-mode: nil
+// js-indent-level: 2
+// End:
diff --git a/test/manual/indent/jsx-self-closing.jsx b/test/manual/indent/jsx-self-closing.jsx
new file mode 100644
index 00000000000..f8ea7a138ad
--- /dev/null
+++ b/test/manual/indent/jsx-self-closing.jsx
@@ -0,0 +1,13 @@
+// Local Variables:
+// indent-tabs-mode: nil
+// js-indent-level: 2
+// End:
+
+// The following test goes below any comments to avoid including
+// misindented comments among the erroring lines.
+
+// Properly parse/indent code with a self-closing tag inside the
+// attribute of another self-closing tag.
+<div>
+ <div attr={() => <div attr="" />} />
+</div>
diff --git a/test/manual/indent/jsx-unclosed-1.jsx b/test/manual/indent/jsx-unclosed-1.jsx
new file mode 100644
index 00000000000..1f5c3fba8da
--- /dev/null
+++ b/test/manual/indent/jsx-unclosed-1.jsx
@@ -0,0 +1,13 @@
+// Local Variables:
+// indent-tabs-mode: nil
+// js-indent-level: 2
+// End:
+
+// The following test goes below any comments to avoid including
+// misindented comments among the erroring lines.
+
+return (
+ <div>
+ {array.map(function () {
+ return {
+ a: 1
diff --git a/test/manual/indent/jsx-unclosed-2.jsx b/test/manual/indent/jsx-unclosed-2.jsx
new file mode 100644
index 00000000000..fb665b96a43
--- /dev/null
+++ b/test/manual/indent/jsx-unclosed-2.jsx
@@ -0,0 +1,65 @@
+// Local Variables:
+// indent-tabs-mode: nil
+// js-indent-level: 2
+// End:
+
+// The following tests go below any comments to avoid including
+// misindented comments among the erroring lines.
+
+// Don’t misinterpret inequality operators as JSX.
+for (; i < length;) void 0
+if (foo > bar) void 0
+
+// Don’t misintrepet inequalities within JSX, either.
+<div>
+ {foo < bar}
+</div>
+
+// Don’t even misinterpret unary operators as JSX.
+if (foo < await bar) void 0
+while (await foo > bar) void 0
+
+<div>
+ {foo < await bar}
+</div>
+
+// Allow unary keyword names as null-valued JSX attributes.
+// (As if this will EVER happen…)
+<Foo yield>
+ <Bar void>
+ <Baz
+ zorp
+ typeof>
+ <Please do_n0t delete this_stupidTest >
+ How would we ever live without unary support
+ </Please>
+ </Baz>
+ </Bar>
+</Foo>
+
+// “-” is not allowed in a JSXBoundaryElement’s name.
+<ABC />
+ <A-B-C /> // Weirdly-indented “continued expression.”
+
+// “-” may be used in a JSXAttribute’s name.
+<Foo a-b-c=""
+ x-y-z="" />
+
+// Weird spaces should be tolerated.
+< div >
+ < div >
+ < div
+ attr=""
+ / >
+ < div
+ attr=""
+ / >
+ < / div>
+< / div >
+
+// Non-ASCII identifiers are acceptable.
+<Über>
+ <Québec διακριτικός sueño="">
+ Guten Tag!
+ </Québec>
+</Über>
diff --git a/test/manual/indent/jsx.jsx b/test/manual/indent/jsx.jsx
new file mode 100644
index 00000000000..c200979df8c
--- /dev/null
+++ b/test/manual/indent/jsx.jsx
@@ -0,0 +1,314 @@
+var foo = <div></div>;
+
+return (
+ <div>
+ </div>
+ <div>
+ <div></div>
+ <div>
+ <div></div>
+ </div>
+ </div>
+);
+
+React.render(
+ <div>
+ <div></div>
+ </div>,
+ {
+ a: 1
+ },
+ <div>
+ <div></div>
+ </div>
+);
+
+return (
+ // Sneaky!
+ <div></div>
+);
+
+return (
+ <div></div>
+ // Sneaky!
+);
+
+React.render(
+ <input
+ />,
+ {
+ a: 1
+ }
+);
+
+return (
+ <div>
+ {array.map(function () {
+ return {
+ a: 1
+ };
+ })}
+ </div>
+);
+
+return (
+ <div attribute={array.map(function () {
+ return {
+ a: 1
+ };
+
+ return {
+ a: 1
+ };
+
+ return {
+ a: 1
+ };
+ })}>
+ </div>
+);
+
+return (
+ <div attribute={{
+ a: 1, // Indent relative to “attribute” column.
+ b: 2
+ } && { // Dedent to “attribute” column.
+ a: 1,
+ b: 2
+ }} /> // Also dedent.
+);
+
+return (
+ <div attribute=
+ { // Indent properly on another line, too.
+ {
+ a: 1,
+ b: 2,
+ } && (
+ // Indent other forms, too.
+ a ? b :
+ c ? d :
+ e
+ )
+ } />
+)
+
+// JSXMemberExpression names are parsed/indented:
+<Foo.Bar>
+ <div>
+ <Foo.Bar>
+ Hello World!
+ </Foo.Bar>
+ <Foo.Bar>
+ <div>
+ </div>
+ </Foo.Bar>
+ </div>
+</Foo.Bar>
+
+// JSXOpeningFragment and JSXClosingFragment are parsed/indented:
+<>
+ <div>
+ <>
+ Hello World!
+ </>
+ <>
+ <div>
+ </div>
+ </>
+ </div>
+</>
+
+// Indent void expressions (no need for contextual parens / commas)
+// (https://github.com/mooz/js2-mode/issues/140#issuecomment-166250016).
+<div className="class-name">
+ <h2>Title</h2>
+ {array.map(() => {
+ return <Element />;
+ })}
+ {message}
+</div>
+// Another example of above issue
+// (https://github.com/mooz/js2-mode/issues/490).
+<App>
+ <div>
+ {variable1}
+ <Component/>
+ </div>
+</App>
+
+// Comments and arrows can break indentation (Bug#24896 /
+// https://github.com/mooz/js2-mode/issues/389).
+const Component = props => (
+ <FatArrow a={e => c}
+ b={123}>
+ </FatArrow>
+);
+const Component = props => (
+ <NoFatArrow a={123}
+ b={123}>
+ </NoFatArrow>
+);
+const Component = props => ( // Parse this comment, please.
+ <FatArrow a={e => c}
+ b={123}>
+ </FatArrow>
+);
+const Component = props => ( // Parse this comment, please.
+ <NoFatArrow a={123}
+ b={123}>
+ </NoFatArrow>
+);
+// Another example of above issue (Bug#30225).
+class {
+ render() {
+ return (
+ <select style={{paddingRight: "10px"}}
+ onChange={e => this.setState({value: e.target.value})}
+ value={this.state.value}>
+ <option>Hi</option>
+ </select>
+ );
+ }
+}
+
+// JSX attributes of an arrow function’s expression body’s JSX
+// expression should be indented with respect to the JSX opening
+// element (Bug#26001 /
+// https://github.com/mooz/js2-mode/issues/389#issuecomment-271869380).
+class {
+ render() {
+ const messages = this.state.messages.map(
+ message => <Message key={message.id}
+ text={message.text}
+ mine={message.mine} />
+ ); return messages;
+ }
+ render() {
+ const messages = this.state.messages.map(message =>
+ <Message key={message.timestamp}
+ text={message.text}
+ mine={message.mine} />
+ ); return messages;
+ }
+}
+
+// Users expect tag closers to align with the tag’s start; this is the
+// style used in the React docs, so it should be the default.
+// - https://github.com/mooz/js2-mode/issues/389#issuecomment-390766873
+// - https://github.com/mooz/js2-mode/issues/482
+// - Bug#32158
+const foo = (props) => (
+ <div>
+ <input
+ cat={i => i}
+ />
+ <button
+ className="square"
+ >
+ {this.state.value}
+ </button>
+ </div>
+);
+
+// Embedded JSX in parens breaks indentation
+// (https://github.com/mooz/js2-mode/issues/411).
+let a = (
+ <div>
+ {condition && <Component/>}
+ {condition && <Component/>}
+ <div/>
+ </div>
+)
+let b = (
+ <div>
+ {condition && (<Component/>)}
+ <div/>
+ </div>
+)
+let c = (
+ <div>
+ {condition && (<Component/>)}
+ {condition && "something"}
+ </div>
+)
+let d = (
+ <div>
+ {(<Component/>)}
+ {condition && "something"}
+ </div>
+)
+// Another example of the above issue (Bug#27000).
+function testA() {
+ return (
+ <div>
+ <div> { ( <div/> ) } </div>
+ </div>
+ );
+}
+function testB() {
+ return (
+ <div>
+ <div> { <div/> } </div>
+ </div>
+ );
+}
+// Another example of the above issue
+// (https://github.com/mooz/js2-mode/issues/451).
+class Classy extends React.Component {
+ render () {
+ return (
+ <div>
+ <ul className="tocListRoot">
+ { this.state.list.map((item) => {
+ return (<div />)
+ })}
+ </ul>
+ </div>
+ )
+ }
+}
+
+// Self-closing tags should be indented properly
+// (https://github.com/mooz/js2-mode/issues/459).
+export default ({ stars }) => (
+ <div className='overlay__container'>
+ <div className='overlay__header overlay--text'>
+ Congratulations!
+ </div>
+ <div className='overlay__reward'>
+ <Icon {...createIconProps(stars > 0)} size='large' />
+ <div className='overlay__reward__bottom'>
+ <Icon {...createIconProps(stars > 1)} size='small' />
+ <Icon {...createIconProps(stars > 2)} size='small' />
+ </div>
+ </div>
+ <div className='overlay__description overlay--text'>
+ You have created <large>1</large> reminder
+ </div>
+ </div>
+)
+
+// JS expressions should not break indentation
+// (https://github.com/mooz/js2-mode/issues/462).
+//
+// In the referenced issue, the user actually wanted indentation which
+// was simply different than Emacs’ SGML attribute indentation.
+// Nevertheless, his issue highlighted our inability to properly
+// indent code with JSX inside JSXExpressionContainers inside JSX.
+return (
+ <Router>
+ <Bar>
+ <Route exact path="/foo"
+ render={() => (
+ <div>nothing</div>
+ )} />
+ <Route exact path="/bar" />
+ </Bar>
+ </Router>
+)
+
+// Local Variables:
+// indent-tabs-mode: nil
+// js-indent-level: 2
+// End:
diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el
index 43b7ea75d50..845d41f9d60 100644
--- a/test/src/buffer-tests.el
+++ b/test/src/buffer-tests.el
@@ -69,4 +69,29 @@ with parameters from the *Messages* buffer modification."
(progn (get-buffer-create "nil")
(generate-new-buffer-name "nil")))))
+(ert-deftest test-buffer-base-buffer-indirect ()
+ (with-temp-buffer
+ (let* ((ind-buf-name (generate-new-buffer-name "indbuf"))
+ (ind-buf (make-indirect-buffer (current-buffer) ind-buf-name)))
+ (should (eq (buffer-base-buffer ind-buf) (current-buffer))))))
+
+(ert-deftest test-buffer-base-buffer-non-indirect ()
+ (with-temp-buffer
+ (should (eq (buffer-base-buffer (current-buffer)) nil))))
+
+(ert-deftest overlay-evaporation-after-killed-buffer ()
+ (let* ((ols (with-temp-buffer
+ (insert "toto")
+ (list
+ (make-overlay (point-min) (point-max))
+ (make-overlay (point-min) (point-max))
+ (make-overlay (point-min) (point-max)))))
+ (ol (nth 1 ols)))
+ (overlay-put ol 'evaporate t)
+ ;; Evaporation within move-overlay of an overlay that was deleted because
+ ;; of a kill-buffer, triggered an assertion failure in unchain_both.
+ (with-temp-buffer
+ (insert "toto")
+ (move-overlay ol (point-min) (point-min)))))
+
;;; buffer-tests.el ends here
diff --git a/test/src/callint-tests.el b/test/src/callint-tests.el
new file mode 100644
index 00000000000..5c310b5c08d
--- /dev/null
+++ b/test/src/callint-tests.el
@@ -0,0 +1,54 @@
+;;; callint-tests.el --- unit tests for callint.c -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018-2019 Free Software Foundation, Inc.
+
+;; Author: Philipp Stephani <phst@google.com>
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Unit tests for src/callint.c.
+
+;;; Code:
+
+(require 'ert)
+
+(ert-deftest call-interactively/incomplete-multibyte-sequence ()
+ "Check that Bug#30004 is fixed."
+ (let ((data (should-error (call-interactively (lambda () (interactive "\xFF"))))))
+ (should
+ (equal
+ (cdr data)
+ '("Invalid control letter `\u00FF' (#o377, #x00ff) in interactive calling string")))))
+
+(ert-deftest call-interactively/embedded-nulls ()
+ "Check that Bug#30005 is fixed."
+ (should (equal (let ((unread-command-events '(?a ?b)))
+ (call-interactively (lambda (a b)
+ (interactive "ka\0a: \nkb: ")
+ (list a b))))
+ '("a" "b"))))
+
+(ert-deftest call-interactively-prune-command-history ()
+ "Check that Bug#31211 is fixed."
+ (let ((history-length 1)
+ (command-history ()))
+ (dotimes (_ (1+ history-length))
+ (call-interactively #'ignore t))
+ (should (= (length command-history) history-length))))
+
+;;; callint-tests.el ends here
diff --git a/test/src/cmds-tests.el b/test/src/cmds-tests.el
index 05c62858773..bab8b5f26ec 100644
--- a/test/src/cmds-tests.el
+++ b/test/src/cmds-tests.el
@@ -30,5 +30,13 @@
(let ((last-command-event ?a))
(should-error (self-insert-command -1))))
+(ert-deftest forward-line-with-bignum ()
+ (with-temp-buffer
+ (insert "x\n")
+ (let ((shortage (forward-line (1- most-negative-fixnum))))
+ (should (= shortage most-negative-fixnum)))
+ (let ((shortage (forward-line (+ 2 most-positive-fixnum))))
+ (should (= shortage (1+ most-positive-fixnum))))))
+
(provide 'cmds-tests)
;;; cmds-tests.el ends here
diff --git a/test/src/data-tests.el b/test/src/data-tests.el
index f3b4262de4b..a9d48e29a8a 100644
--- a/test/src/data-tests.el
+++ b/test/src/data-tests.el
@@ -113,7 +113,24 @@ most-positive-fixnum, which is just less than a power of 2.")
(should (isnan (min 0.0e+NaN)))
(should (isnan (min 0.0e+NaN 1 2)))
(should (isnan (min 1.0 0.0e+NaN)))
- (should (isnan (min 1.0 0.0e+NaN 1.1))))
+ (should (isnan (min 1.0 0.0e+NaN 1.1)))
+ (should (isnan (min 1.0 0.0e+NaN 1.1 (1+ most-positive-fixnum))))
+ (should (isnan (max 1.0 0.0e+NaN 1.1 (1+ most-positive-fixnum)))))
+
+(defun data-tests-popcnt (byte)
+ "Calculate the Hamming weight of BYTE."
+ (if (< byte 0)
+ (setq byte (lognot byte)))
+ (if (zerop byte)
+ 0
+ (+ (logand byte 1) (data-tests-popcnt (ash byte -1)))))
+
+(ert-deftest data-tests-logcount ()
+ (should (cl-loop for n in (number-sequence -255 255)
+ always (= (logcount n) (data-tests-popcnt n))))
+ ;; https://oeis.org/A000120
+ (should (= 11 (logcount 9727)))
+ (should (= 8 (logcount 9999))))
;; Bool vector tests. Compactly represent bool vectors as hex
;; strings.
@@ -169,17 +186,17 @@ most-positive-fixnum, which is just less than a power of 2.")
(dotimes (_ 4)
(aset bv i (> (logand 1 n) 0))
(cl-incf i)
- (setf n (lsh n -1)))))
+ (setf n (ash n -1)))))
bv))
(defun test-bool-vector-to-hex-string (bv)
(let (nibbles (v (cl-coerce bv 'list)))
(while v
(push (logior
- (lsh (if (nth 0 v) 1 0) 0)
- (lsh (if (nth 1 v) 1 0) 1)
- (lsh (if (nth 2 v) 1 0) 2)
- (lsh (if (nth 3 v) 1 0) 3))
+ (ash (if (nth 0 v) 1 0) 0)
+ (ash (if (nth 1 v) 1 0) 1)
+ (ash (if (nth 2 v) 1 0) 2)
+ (ash (if (nth 3 v) 1 0) 3))
nibbles)
(setf v (nthcdr 4 v)))
(mapconcat (lambda (n) (format "%X" n))
@@ -467,7 +484,7 @@ comparing the subr with a much slower lisp implementation."
(should-have-watch-data `(data-tests-lvar 3 set ,buf1)))
(should-have-watch-data `(data-tests-lvar 1 unlet ,buf1))
(setq-default data-tests-lvar 4)
- (should-have-watch-data `(data-tests-lvar 4 set nil))
+ (should-have-watch-data '(data-tests-lvar 4 set nil))
(with-temp-buffer
(setq buf2 (current-buffer))
(setq data-tests-lvar 1)
@@ -484,7 +501,7 @@ comparing the subr with a much slower lisp implementation."
(kill-all-local-variables)
(should-have-watch-data `(data-tests-lvar nil makunbound ,buf2)))
(setq-default data-tests-lvar 4)
- (should-have-watch-data `(data-tests-lvar 4 set nil))
+ (should-have-watch-data '(data-tests-lvar 4 set nil))
(makunbound 'data-tests-lvar)
(should-have-watch-data '(data-tests-lvar nil makunbound nil))
(setq data-tests-lvar 5)
@@ -508,6 +525,150 @@ comparing the subr with a much slower lisp implementation."
(bound-and-true-p data-tests-foo2)
(bound-and-true-p data-tests-foo3)))))))
+(ert-deftest data-tests-bignum ()
+ (should (bignump (+ most-positive-fixnum 1)))
+ (let ((f0 (+ (float most-positive-fixnum) 1))
+ (f-1 (- (float most-negative-fixnum) 1))
+ (b0 (+ most-positive-fixnum 1))
+ (b-1 (- most-negative-fixnum 1)))
+ (should (> b0 -1))
+ (should (> b0 f-1))
+ (should (> b0 b-1))
+ (should (>= b0 -1))
+ (should (>= b0 f-1))
+ (should (>= b0 b-1))
+ (should (>= b-1 b-1))
+
+ (should (< -1 b0))
+ (should (< f-1 b0))
+ (should (< b-1 b0))
+ (should (<= -1 b0))
+ (should (<= f-1 b0))
+ (should (<= b-1 b0))
+ (should (<= b-1 b-1))
+
+ (should (= (+ f0 b0) (+ b0 f0)))
+ (should (= (+ f0 b-1) (+ b-1 f0)))
+ (should (= (+ f-1 b0) (+ b0 f-1)))
+ (should (= (+ f-1 b-1) (+ b-1 f-1)))
+
+ (should (= (* f0 b0) (* b0 f0)))
+ (should (= (* f0 b-1) (* b-1 f0)))
+ (should (= (* f-1 b0) (* b0 f-1)))
+ (should (= (* f-1 b-1) (* b-1 f-1)))
+
+ (should (= b0 f0))
+ (should (= b0 b0))
+
+ (should (/= b0 f-1))
+ (should (/= b0 b-1))
+
+ (should (/= b0 0.0e+NaN))
+ (should (/= b-1 0.0e+NaN))))
+
+(ert-deftest data-tests-+ ()
+ (should-not (fixnump (+ most-positive-fixnum most-positive-fixnum)))
+ (should (> (+ most-positive-fixnum most-positive-fixnum) most-positive-fixnum))
+ (should (eq (- (+ most-positive-fixnum most-positive-fixnum)
+ (+ most-positive-fixnum most-positive-fixnum))
+ 0)))
+
+(ert-deftest data-tests-/ ()
+ (let* ((x (* most-positive-fixnum 8))
+ (y (* most-negative-fixnum 8))
+ (z (- y)))
+ (should (= most-positive-fixnum (/ x 8)))
+ (should (= most-negative-fixnum (/ y 8)))
+ (should (= -1 (/ y z)))
+ (should (= -1 (/ z y)))
+ (should (= 0 (/ x (* 2 x))))
+ (should (= 0 (/ y (* 2 y))))
+ (should (= 0 (/ z (* 2 z))))))
+
+(ert-deftest data-tests-number-predicates ()
+ (should (fixnump 0))
+ (should (fixnump most-negative-fixnum))
+ (should (fixnump most-positive-fixnum))
+ (should (integerp (+ most-positive-fixnum 1)))
+ (should (integer-or-marker-p (+ most-positive-fixnum 1)))
+ (should (numberp (+ most-positive-fixnum 1)))
+ (should (number-or-marker-p (+ most-positive-fixnum 1)))
+ (should (natnump (+ most-positive-fixnum 1)))
+ (should-not (fixnump (+ most-positive-fixnum 1)))
+ (should (bignump (+ most-positive-fixnum 1))))
+
+(ert-deftest data-tests-number-to-string ()
+ (let* ((s "99999999999999999999999999999")
+ (v (read s)))
+ (should (equal (number-to-string v) s))))
+
+(ert-deftest data-tests-1+ ()
+ (should (> (1+ most-positive-fixnum) most-positive-fixnum))
+ (should (fixnump (1+ (1- most-negative-fixnum)))))
+
+(ert-deftest data-tests-1- ()
+ (should (< (1- most-negative-fixnum) most-negative-fixnum))
+ (should (fixnump (1- (1+ most-positive-fixnum)))))
+
+(ert-deftest data-tests-logand ()
+ (should (= -1 (logand) (logand -1) (logand -1 -1)))
+ (let ((n (1+ most-positive-fixnum)))
+ (should (= (logand -1 n) n)))
+ (let ((n (* 2 most-negative-fixnum)))
+ (should (= (logand -1 n) n))))
+
+(ert-deftest data-tests-logcount ()
+ (should (= (logcount (read "#xffffffffffffffffffffffffffffffff")) 128)))
+
+(ert-deftest data-tests-logior ()
+ (should (= -1 (logior -1) (logior -1 -1)))
+ (should (= -1 (logior most-positive-fixnum most-negative-fixnum))))
+
+(ert-deftest data-tests-logxor ()
+ (should (= -1 (logxor -1) (logxor -1 -1 -1)))
+ (let ((n (1+ most-positive-fixnum)))
+ (should (= (logxor -1 n) (lognot n)))))
+
+(ert-deftest data-tests-minmax ()
+ (let ((a (- most-negative-fixnum 1))
+ (b (+ most-positive-fixnum 1))
+ (c 0))
+ (should (= (min a b c) a))
+ (should (= (max a b c) b))))
+
+(defun data-tests-check-sign (x y)
+ (should (eq (cl-signum x) (cl-signum y))))
+
+(ert-deftest data-tests-%-mod ()
+ (let* ((b1 (+ most-positive-fixnum 1))
+ (nb1 (- b1))
+ (b3 (+ most-positive-fixnum 3))
+ (nb3 (- b3)))
+ (data-tests-check-sign (% 1 3) (% b1 b3))
+ (data-tests-check-sign (mod 1 3) (mod b1 b3))
+ (data-tests-check-sign (% 1 -3) (% b1 nb3))
+ (data-tests-check-sign (mod 1 -3) (mod b1 nb3))
+ (data-tests-check-sign (% -1 3) (% nb1 b3))
+ (data-tests-check-sign (mod -1 3) (mod nb1 b3))
+ (data-tests-check-sign (% -1 -3) (% nb1 nb3))
+ (data-tests-check-sign (mod -1 -3) (mod nb1 nb3))))
+
+(ert-deftest data-tests-ash-lsh ()
+ (should (= (ash most-negative-fixnum 1)
+ (* most-negative-fixnum 2)))
+ (should (= (ash 0 (* 2 most-positive-fixnum)) 0))
+ (should (= (ash 1000 (* 2 most-negative-fixnum)) 0))
+ (should (= (ash -1000 (* 2 most-negative-fixnum)) -1))
+ (should (= (ash (* 2 most-negative-fixnum) (* 2 most-negative-fixnum)) -1))
+ (should (= (lsh most-negative-fixnum 1)
+ (* most-negative-fixnum 2)))
+ (should (= (ash (* 2 most-negative-fixnum) -1)
+ most-negative-fixnum))
+ (should (= (lsh most-positive-fixnum -1) (/ most-positive-fixnum 2)))
+ (should (= (lsh most-negative-fixnum -1) (lsh (- most-negative-fixnum) -1)))
+ (should (= (lsh -1 -1) most-positive-fixnum))
+ (should-error (lsh (1- most-negative-fixnum) -1)))
+
(ert-deftest data-tests-make-local-forwarded-var () ;bug#34318
;; Boy, this bug is tricky to trigger. You need to:
;; - call make-local-variable on a forwarded var (i.e. one that
diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el
index 041d21d9c16..1e8b7066d15 100644
--- a/test/src/editfns-tests.el
+++ b/test/src/editfns-tests.el
@@ -150,54 +150,58 @@
(ert-deftest format-c-float ()
(should-error (format "%c" 0.5)))
-;;; Check format-time-string with various TZ settings.
-;;; Use only POSIX-compatible TZ values, since the tests should work
-;;; even if tzdb is not in use.
-(ert-deftest format-time-string-with-zone ()
- ;; Don’t use (0 0 0 0) as the test case, as there are too many bugs
- ;; in MS-Windows (and presumably other) C libraries when formatting
- ;; time stamps near the Epoch of 1970-01-01 00:00:00 UTC, and this
- ;; test is for GNU Emacs, not for C runtimes. Instead, look before
- ;; you leap: "look" is the timestamp just before the first leap
- ;; second on 1972-06-30 23:59:60 UTC, so it should format to the
- ;; same string regardless of whether the underlying C library
- ;; ignores leap seconds, while avoiding circa-1970 glitches.
- ;;
- ;; Similarly, stick to the limited set of time zones that are
- ;; supported by both POSIX and MS-Windows: exactly 3 ASCII letters
- ;; in the abbreviation, and no DST.
- (let ((look '(1202 22527 999999 999999))
- (format "%Y-%m-%d %H:%M:%S.%3N %z (%Z)"))
- ;; UTC.
- (should (string-equal
- (format-time-string "%Y-%m-%d %H:%M:%S.%3N %z" look t)
- "1972-06-30 23:59:59.999 +0000"))
- ;; "UTC0".
- (should (string-equal
- (format-time-string format look "UTC0")
- "1972-06-30 23:59:59.999 +0000 (UTC)"))
- ;; Negative UTC offset, as a Lisp list.
- (should (string-equal
- (format-time-string format look '(-28800 "PST"))
- "1972-06-30 15:59:59.999 -0800 (PST)"))
- ;; Negative UTC offset, as a Lisp integer.
- (should (string-equal
- (format-time-string format look -28800)
- ;; MS-Windows build replaces unrecognizable TZ values,
- ;; such as "-08", with "ZZZ".
- (if (eq system-type 'windows-nt)
- "1972-06-30 15:59:59.999 -0800 (ZZZ)"
- "1972-06-30 15:59:59.999 -0800 (-08)")))
- ;; Positive UTC offset that is not an hour multiple, as a string.
- (should (string-equal
- (format-time-string format look "IST-5:30")
- "1972-07-01 05:29:59.999 +0530 (IST)"))))
-
-;;; This should not dump core.
-(ert-deftest format-time-string-with-outlandish-zone ()
- (should (stringp
- (format-time-string "%Y-%m-%d %H:%M:%S.%3N %z" nil
- (concat (make-string 2048 ?X) "0")))))
+;;; Test for Bug#29609.
+(ert-deftest format-sharp-0-x ()
+ (should (string-equal (format "%#08x" #x10) "0x000010"))
+ (should (string-equal (format "%#05X" #x10) "0X010"))
+ (should (string-equal (format "%#04x" 0) "0000")))
+
+
+;;; Tests for Bug#30408.
+
+(ert-deftest format-%d-large-float ()
+ (should (string-equal (format "%d" 18446744073709551616.0)
+ "18446744073709551616"))
+ (should (string-equal (format "%d" -18446744073709551616.0)
+ "-18446744073709551616")))
+
+;;; Perhaps Emacs will be improved someday to return the correct
+;;; answer for positive numbers instead of overflowing; in
+;;; that case these tests will need to be changed. In the meantime make
+;;; sure Emacs is reporting the overflow correctly.
+(ert-deftest format-%x-large-float ()
+ (should-error (format "%x" 18446744073709551616.0)
+ :type 'overflow-error))
+(ert-deftest read-large-integer ()
+ (should (eq (type-of (read (format "%d0" most-negative-fixnum))) 'integer))
+ (should (eq (type-of (read (format "%+d" (* -8.0 most-negative-fixnum))))
+ 'integer))
+ (should (eq (type-of (read (substring (format "%d" most-negative-fixnum) 1)))
+ 'integer))
+ (should (eq (type-of (read (format "#x%x" most-negative-fixnum)))
+ 'integer))
+ (should (eq (type-of (read (format "#o%o" most-negative-fixnum)))
+ 'integer))
+ (should (eq (type-of (read (format "#32rG%x" most-positive-fixnum)))
+ 'integer))
+ (dolist (fmt '("%d" "%s" "#o%o" "#x%x"))
+ (dolist (val (list most-negative-fixnum (1+ most-negative-fixnum)
+ -1 0 1
+ (1- most-positive-fixnum) most-positive-fixnum))
+ (should (eq val (read (format fmt val)))))))
+
+(ert-deftest format-%o-invalid-float ()
+ (should-error (format "%o" -1e-37)
+ :type 'overflow-error))
+
+;; Bug#31938
+(ert-deftest format-%d-float ()
+ (should (string-equal (format "%d" -1.1) "-1"))
+ (should (string-equal (format "%d" -0.9) "0"))
+ (should (string-equal (format "%d" -0.0) "0"))
+ (should (string-equal (format "%d" 0.0) "0"))
+ (should (string-equal (format "%d" 0.9) "0"))
+ (should (string-equal (format "%d" 1.1) "1")))
(ert-deftest format-with-field ()
(should (equal (format "First argument %2$s, then %3$s, then %1$s" 1 2 3)
@@ -323,4 +327,61 @@
(should (eq (type-of (car (nth 4 buffer-undo-list))) 'marker))
(garbage-collect)))
+(ert-deftest format-bignum ()
+ (let* ((s1 "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF")
+ (v1 (read (concat "#x" s1)))
+ (s2 "99999999999999999999999999999999")
+ (v2 (read s2))
+ (v3 #x-3ffffffffffffffe000000000000000))
+ (should (> v1 most-positive-fixnum))
+ (should (equal (format "%X" v1) s1))
+ (should (> v2 most-positive-fixnum))
+ (should (equal (format "%d" v2) s2))
+ (should (equal (format "%d" v3) "-5316911983139663489309385231907684352"))
+ (should (equal (format "%+d" v3) "-5316911983139663489309385231907684352"))
+ (should (equal (format "%+d" (- v3))
+ "+5316911983139663489309385231907684352"))
+ (should (equal (format "% d" (- v3))
+ " 5316911983139663489309385231907684352"))
+ (should (equal (format "%o" v3)
+ "-37777777777777777777600000000000000000000"))
+ (should (equal (format "%#50.40x" v3)
+ " -0x000000003ffffffffffffffe000000000000000"))
+ (should (equal (format "%-#50.40x" v3)
+ "-0x000000003ffffffffffffffe000000000000000 "))))
+
+(ert-deftest test-group-name ()
+ ;; FIXME: Actually my GID in one of my systems has no associated entry
+ ;; in /etc/group so there's no name for it and `group-name' correctly
+ ;; returns nil!
+ (should (stringp (group-name (group-gid))))
+ (should-error (group-name 'foo))
+ (cond
+ ((memq system-type '(windows-nt ms-dos))
+ (should-not (group-name 123456789)))
+ ((executable-find "getent")
+ (with-temp-buffer
+ (let (stat name)
+ (dolist (gid (list 0 1212345 (group-gid)))
+ (erase-buffer)
+ (setq stat (ignore-errors
+ (call-process "getent" nil '(t nil) nil "group"
+ (number-to-string gid))))
+ (setq name (group-name gid))
+ (goto-char (point-min))
+ (cond ((eq stat 0)
+ (if (looking-at "\\([[:alnum:]_-]+\\):")
+ (should (string= (match-string 1) name))))
+ ((eq stat 2)
+ (should-not name)))))))))
+
+(ert-deftest test-translate-region-internal ()
+ (with-temp-buffer
+ (let ((max-char #16r3FFFFF)
+ (tt (make-char-table 'translation-table)))
+ (aset tt max-char ?*)
+ (insert max-char)
+ (translate-region-internal (point-min) (point-max) tt)
+ (should (string-equal (buffer-string) "*")))))
+
;;; editfns-tests.el ends here
diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el
index 6f4490d9d12..35aaaa64b65 100644
--- a/test/src/emacs-module-tests.el
+++ b/test/src/emacs-module-tests.el
@@ -17,7 +17,9 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
+(require 'cl-lib)
(require 'ert)
+(require 'help-fns)
(defconst mod-test-emacs
(expand-file-name invocation-name invocation-directory)
@@ -25,12 +27,19 @@
(eval-and-compile
(defconst mod-test-file
- (substitute-in-file-name
- "$EMACS_TEST_DIRECTORY/data/emacs-module/mod-test")
+ (expand-file-name "../test/data/emacs-module/mod-test" invocation-directory)
"File name of the module test file."))
(require 'mod-test mod-test-file)
+(cl-defgeneric emacs-module-tests--generic (_))
+
+(cl-defmethod emacs-module-tests--generic ((_ module-function))
+ 'module-function)
+
+(cl-defmethod emacs-module-tests--generic ((_ user-ptr))
+ 'user-ptr)
+
;;
;; Basic tests.
;;
@@ -57,12 +66,12 @@
(when (< #x1fffffff most-positive-fixnum)
(should (= (mod-test-sum 1 #x1fffffff)
(1+ #x1fffffff)))
- (should (= (mod-test-sum -1 #x20000000)
+ (should (= (mod-test-sum -1 (1+ #x1fffffff))
#x1fffffff)))
- (should-error (mod-test-sum 1 most-positive-fixnum)
- :type 'overflow-error)
- (should-error (mod-test-sum -1 most-negative-fixnum)
- :type 'overflow-error))
+ (should (= (mod-test-sum 1 most-positive-fixnum)
+ (1+ most-positive-fixnum)))
+ (should (= (mod-test-sum -1 most-negative-fixnum)
+ (1- most-negative-fixnum))))
(ert-deftest mod-test-sum-docstring ()
(should (string= (documentation 'mod-test-sum) "Return A + B\n\n(fn a b)")))
@@ -73,7 +82,9 @@ This test needs to be changed whenever the implementation
changes."
(let ((func (symbol-function #'mod-test-sum)))
(should (module-function-p func))
+ (should (functionp func))
(should (equal (type-of func) 'module-function))
+ (should (eq (emacs-module-tests--generic func) 'module-function))
(should (string-match-p
(rx bos "#<module function "
(or "Fmod_test_sum"
@@ -127,8 +138,9 @@ changes."
(defun multiply-string (s n)
(let ((res ""))
- (dotimes (i n res)
- (setq res (concat res s)))))
+ (dotimes (i n)
+ (setq res (concat res s)))
+ res))
(ert-deftest mod-test-globref-make-test ()
(let ((mod-str (mod-test-globref-make))
@@ -152,6 +164,7 @@ changes."
(r (mod-test-userptr-get v)))
(should (eq (type-of v) 'user-ptr))
+ (should (eq (emacs-module-tests--generic v) 'user-ptr))
(should (integerp r))
(should (= r n))))
@@ -252,6 +265,49 @@ during garbage collection."
(skip-unless (file-executable-p mod-test-emacs))
(module--test-assertion
(rx "Module function called during garbage collection\n")
- (mod-test-invalid-finalizer)))
+ (mod-test-invalid-finalizer)
+ (garbage-collect)))
+
+(ert-deftest module/describe-function-1 ()
+ "Check that Bug#30163 is fixed."
+ (with-temp-buffer
+ (let ((standard-output (current-buffer)))
+ (describe-function-1 #'mod-test-sum)
+ (should (equal
+ (buffer-substring-no-properties 1 (point-max))
+ (format "a module function in `data/emacs-module/mod-test%s'.
+
+(mod-test-sum a b)
+
+Return A + B"
+ module-file-suffix))))))
+
+(ert-deftest module/load-history ()
+ "Check that Bug#30164 is fixed."
+ (load mod-test-file)
+ (cl-destructuring-bind (file &rest entries) (car load-history)
+ (should (equal (file-name-sans-extension file) mod-test-file))
+ (should (member '(provide . mod-test) entries))
+ (should (member '(defun . mod-test-sum) entries))))
+
+(ert-deftest mod-test-sleep-until ()
+ "Check that `mod-test-sleep-until' either returns normally or quits.
+Interactively, you can try hitting \\[keyboard-quit] to quit."
+ (dolist (arg '(nil t))
+ ;; Guard against some caller setting `inhibit-quit'.
+ (with-local-quit
+ (condition-case nil
+ (should (eq (with-local-quit
+ ;; Because `inhibit-quit' is nil here, the next
+ ;; form either quits or returns `finished'.
+ (mod-test-sleep-until
+ ;; Interactively, run for 5 seconds to give the
+ ;; user time to quit. In batch mode, run only
+ ;; briefly since the user can't quit.
+ (float-time (time-add nil (if noninteractive 0.1 5)))
+ ;; should_quit or process_input
+ arg))
+ 'finished))
+ (quit)))))
;;; emacs-module-tests.el ends here
diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el
index b7509aed58f..48295b81fa3 100644
--- a/test/src/eval-tests.el
+++ b/test/src/eval-tests.el
@@ -26,6 +26,7 @@
;;; Code:
(require 'ert)
+(eval-when-compile (require 'cl-lib))
(ert-deftest eval-tests--bug24673 ()
"Check that Bug#24673 has been fixed."
@@ -37,8 +38,7 @@
(ert-deftest eval-tests--bugs-24912-and-24913 ()
"Check that Emacs doesn't accept weird argument lists.
Bug#24912 and Bug#24913."
- (dolist (args '((&optional) (&rest) (&optional &rest) (&rest &optional)
- (&optional &rest a) (&optional a &rest)
+ (dolist (args '((&rest &optional)
(&rest a &optional) (&rest &optional a)
(&optional &optional) (&optional &optional a)
(&optional a &optional b)
@@ -47,7 +47,22 @@ Bug#24912 and Bug#24913."
(should-error (eval `(funcall (lambda ,args)) t) :type 'invalid-function)
(should-error (byte-compile-check-lambda-list args))
(let ((byte-compile-debug t))
- (should-error (eval `(byte-compile (lambda ,args)) t)))))
+ (ert-info ((format "bytecomp: args = %S" args))
+ (should-error (eval `(byte-compile (lambda ,args)) t))))))
+
+(ert-deftest eval-tests-accept-empty-optional-rest ()
+ "Check that Emacs accepts empty &optional and &rest arglists.
+Bug#24912."
+ (dolist (args '((&optional) (&rest) (&optional &rest)
+ (&optional &rest a) (&optional a &rest)))
+ (let ((fun `(lambda ,args 'ok)))
+ (ert-info ("eval")
+ (should (eq (funcall (eval fun t)) 'ok)))
+ (ert-info ("byte comp check")
+ (byte-compile-check-lambda-list args))
+ (ert-info ("bytecomp")
+ (let ((byte-compile-debug t))
+ (should (eq (funcall (byte-compile fun)) 'ok)))))))
(dolist (form '(let let*))
@@ -99,6 +114,31 @@ crash/abort/malloc assert failure on the next test."
(signal-hook-function #'ignore))
(should-error (eval-tests--exceed-specbind-limit))))
+(ert-deftest defvar/bug31072 ()
+ "Check that Bug#31072 is fixed."
+ (should-error (eval '(defvar 1) t) :type 'wrong-type-argument))
+
+(ert-deftest defvaralias-overwrite-warning ()
+ "Test for Bug#5950."
+ (defvar eval-tests--foo)
+ (setq eval-tests--foo 2)
+ (defvar eval-tests--foo-alias)
+ (setq eval-tests--foo-alias 1)
+ (cl-letf (((symbol-function 'display-warning)
+ (lambda (type &rest _)
+ (throw 'got-warning type))))
+ ;; Warn if we lose a value through aliasing.
+ (should (equal
+ '(defvaralias losing-value eval-tests--foo-alias)
+ (catch 'got-warning
+ (defvaralias 'eval-tests--foo-alias 'eval-tests--foo))))
+ ;; Don't warn if we don't.
+ (makunbound 'eval-tests--foo-alias)
+ (should (eq 'no-warning
+ (catch 'got-warning
+ (defvaralias 'eval-tests--foo-alias 'eval-tests--foo)
+ 'no-warning)))))
+
(ert-deftest eval-tests-byte-code-being-evaluated-is-protected-from-gc ()
"Regression test for Bug#33014.
Check that byte-compiled objects being executed by exec-byte-code
diff --git a/test/src/fileio-tests.el b/test/src/fileio-tests.el
index 8853a4e9f7b..6262d946df1 100644
--- a/test/src/fileio-tests.el
+++ b/test/src/fileio-tests.el
@@ -29,11 +29,7 @@
(defun fileio-tests--symlink-failure ()
(let* ((dir (make-temp-file "fileio" t))
- (link (expand-file-name "link" dir))
- (file-name-coding-system (if (and (eq system-type 'darwin)
- (featurep 'ucs-normalize))
- 'utf-8-hfs-unix
- file-name-coding-system)))
+ (link (expand-file-name "link" dir)))
(unwind-protect
(let (failure
(char 0))
@@ -99,3 +95,15 @@ Also check that an encoding error can appear in a symlink."
(should (equal (file-name-as-directory "d:/abc/") "d:/abc/"))
(should (equal (file-name-as-directory "D:\\abc/") "d:/abc/"))
(should (equal (file-name-as-directory "D:/abc//") "d:/abc//")))
+
+(ert-deftest fileio-tests--relative-HOME ()
+ "Test that expand-file-name works even when HOME is relative."
+ (let ((old-home (getenv "HOME")))
+ (setenv "HOME" "a/b/c")
+ (should (equal (expand-file-name "~/foo")
+ (expand-file-name "a/b/c/foo")))
+ (when (memq system-type '(ms-dos windows-nt))
+ ;; Test expansion of drive-relative file names.
+ (setenv "HOME" "x:foo")
+ (should (equal (expand-file-name "~/bar") "x:/foo/bar")))
+ (setenv "HOME" old-home)))
diff --git a/test/src/floatfns-tests.el b/test/src/floatfns-tests.el
index 6dfd01034eb..643866f1146 100644
--- a/test/src/floatfns-tests.el
+++ b/test/src/floatfns-tests.el
@@ -20,10 +20,10 @@
(require 'ert)
(ert-deftest divide-extreme-sign ()
- (should-error (ceiling most-negative-fixnum -1.0))
- (should-error (floor most-negative-fixnum -1.0))
- (should-error (round most-negative-fixnum -1.0))
- (should-error (truncate most-negative-fixnum -1.0)))
+ (should (= (ceiling most-negative-fixnum -1.0) (- most-negative-fixnum)))
+ (should (= (floor most-negative-fixnum -1.0) (- most-negative-fixnum)))
+ (should (= (round most-negative-fixnum -1.0) (- most-negative-fixnum)))
+ (should (= (truncate most-negative-fixnum -1.0) (- most-negative-fixnum))))
(ert-deftest logb-extreme-fixnum ()
(should (= (logb most-negative-fixnum) (1+ (logb most-positive-fixnum)))))
@@ -34,4 +34,89 @@
(should-error (ftruncate 0) :type 'wrong-type-argument)
(should-error (fround 0) :type 'wrong-type-argument))
+(ert-deftest bignum-to-float ()
+ ;; 122 because we want to go as big as possible to provoke a rounding error,
+ ;; but not too big: 2**122 < 10**37 < 2**123, and the C standard says
+ ;; 10**37 <= DBL_MAX so 2**122 cannot overflow as a double.
+ (let ((a (1- (ash 1 122))))
+ (should (or (eql a (1- (floor (float a))))
+ (eql a (floor (float a))))))
+ (should (eql (float (+ most-positive-fixnum 1))
+ (+ (float most-positive-fixnum) 1))))
+
+(ert-deftest bignum-abs ()
+ (should (= most-positive-fixnum
+ (- (abs most-negative-fixnum) 1))))
+
+(ert-deftest bignum-expt ()
+ (dolist (n (list most-positive-fixnum (1+ most-positive-fixnum)
+ most-negative-fixnum (1- most-negative-fixnum)
+ -2 -1 0 1 2))
+ (should (= (expt n 0) 1))
+ (should (= (expt n 1) n))
+ (should (= (expt n 2) (* n n)))
+ (should (= (expt n 3) (* n n n)))))
+
+(ert-deftest bignum-logb ()
+ (should (= (+ (logb most-positive-fixnum) 1)
+ (logb (+ most-positive-fixnum 1)))))
+
+(ert-deftest bignum-mod ()
+ (should (= 0 (mod (1+ most-positive-fixnum) 2.0))))
+
+(ert-deftest bignum-round ()
+ (let ((ns (list (* most-positive-fixnum most-negative-fixnum)
+ (1- most-negative-fixnum) most-negative-fixnum
+ (1+ most-negative-fixnum) -2 1 1 2
+ (1- most-positive-fixnum) most-positive-fixnum
+ (1+ most-positive-fixnum)
+ (* most-positive-fixnum most-positive-fixnum))))
+ (dolist (n ns)
+ (should (= n (ceiling n)))
+ (should (= n (floor n)))
+ (should (= n (round n)))
+ (should (= n (truncate n)))
+ (let ((-n (- n))
+ (f (float n))
+ (-f (- (float n))))
+ (should (= 1 (round n f) (round -n -f) (round f n) (round -f -n)))
+ (should (= -1 (round -n f) (round n -f) (round f -n) (round -f n))))
+ (dolist (d ns)
+ (let ((q (/ n d))
+ (r (% n d))
+ (same-sign (eq (< n 0) (< d 0))))
+ (should (= (ceiling n d)
+ (+ q (if (and same-sign (not (zerop r))) 1 0))))
+ (should (= (floor n d)
+ (- q (if (and (not same-sign) (not (zerop r))) 1 0))))
+ (should (= (truncate n d) q))
+ (let ((cdelta (abs (- n (* d (ceiling n d)))))
+ (fdelta (abs (- n (* d (floor n d)))))
+ (rdelta (abs (- n (* d (round n d))))))
+ (should (<= rdelta cdelta))
+ (should (<= rdelta fdelta))
+ (should (if (zerop r)
+ (= 0 cdelta fdelta rdelta)
+ (or (/= cdelta fdelta)
+ (zerop (% (round n d) 2)))))))))))
+
+(ert-deftest special-round ()
+ (let ((ns '(-1e+INF 1e+INF -1 1 -1e+NaN 1e+NaN)))
+ (dolist (n ns)
+ (unless (<= (abs n) 1)
+ (should-error (ceiling n))
+ (should-error (floor n))
+ (should-error (round n))
+ (should-error (truncate n)))
+ (dolist (d ns)
+ (unless (<= (abs (/ n d)) 1)
+ (should-error (ceiling n d))
+ (should-error (floor n d))
+ (should-error (round n d))
+ (should-error (truncate n d)))))))
+
+(ert-deftest big-round ()
+ (should (= (floor 54043195528445955 3)
+ (floor 54043195528445955 3.0))))
+
(provide 'floatfns-tests)
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index 0d2a15e758b..6ebab4287f7 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -23,6 +23,17 @@
(require 'cl-lib)
+;; Test that equality predicates work correctly on NaNs when combined
+;; with hash tables based on those predicates. This was not the case
+;; for eql in Emacs 26.
+(ert-deftest fns-tests-equality-nan ()
+ (dolist (test (list #'eq #'eql #'equal))
+ (let* ((h (make-hash-table :test test))
+ (nan 0.0e+NaN)
+ (-nan (- nan)))
+ (puthash nan t h)
+ (should (eq (funcall test nan -nan) (gethash -nan h))))))
+
(ert-deftest fns-tests-reverse ()
(should-error (reverse))
(should-error (reverse 1))
@@ -150,7 +161,10 @@
'(9 . "ppp") '(8 . "ttt") '(8 . "eee") '(9 . "fff"))
(lambda (x y) (< (car x) (car y))))
[(8 . "xxx") (8 . "bbb") (8 . "ttt") (8 . "eee")
- (9 . "aaa") (9 . "zzz") (9 . "ppp") (9 . "fff")])))
+ (9 . "aaa") (9 . "zzz") (9 . "ppp") (9 . "fff")]))
+ ;; Bug#34104
+ (should (equal (should-error (sort "cba" #'<) :type 'wrong-type-argument)
+ '(wrong-type-argument list-or-vector-p "cba"))))
(ert-deftest fns-tests-collate-sort ()
(skip-unless (fns-tests--collate-enabled-p))
@@ -575,4 +589,81 @@
:type 'wrong-type-argument)
'(wrong-type-argument plistp (:foo 1 . :bar)))))
+(ert-deftest test-string-distance ()
+ "Test `string-distance' behavior."
+ ;; ASCII characters are always fine
+ (should (equal 1 (string-distance "heelo" "hello")))
+ (should (equal 2 (string-distance "aeelo" "hello")))
+ (should (equal 0 (string-distance "ab" "ab" t)))
+ (should (equal 1 (string-distance "ab" "abc" t)))
+
+ ;; string containing hanzi character, compare by byte
+ (should (equal 6 (string-distance "ab" "ab我她" t)))
+ (should (equal 3 (string-distance "ab" "a我b" t)))
+ (should (equal 3 (string-distance "我" "她" t)))
+
+ ;; string containing hanzi character, compare by character
+ (should (equal 2 (string-distance "ab" "ab我她")))
+ (should (equal 1 (string-distance "ab" "a我b")))
+ (should (equal 1 (string-distance "我" "她"))))
+
+(ert-deftest test-bignum-eql ()
+ "Test that `eql' works for bignums."
+ (let ((x (+ most-positive-fixnum 1))
+ (y (+ most-positive-fixnum 1)))
+ (should (eq x x))
+ (should (eql x y))
+ (should (equal x y))
+ (should-not (eql x 0.0e+NaN))))
+
+(ert-deftest test-bignum-hash ()
+ "Test that hash tables work for bignums."
+ ;; Make two bignums that are eql but not eq.
+ (let ((b1 (1+ most-positive-fixnum))
+ (b2 (1+ most-positive-fixnum)))
+ (dolist (test '(eq eql equal))
+ (let ((hash (make-hash-table :test test)))
+ (puthash b1 t hash)
+ (should (eq (gethash b2 hash)
+ (funcall test b1 b2)))))))
+
+(ert-deftest test-nthcdr-simple ()
+ (should (eq (nthcdr 0 'x) 'x))
+ (should (eq (nthcdr 1 '(x . y)) 'y))
+ (should (eq (nthcdr 2 '(x y . z)) 'z)))
+
+(ert-deftest test-nthcdr-circular ()
+ (dolist (len '(1 2 5 37 120 997 1024))
+ (let ((cycle (make-list len nil)))
+ (setcdr (last cycle) cycle)
+ (dolist (n (list (1- most-negative-fixnum) most-negative-fixnum
+ -1 0 1
+ (1- len) len (1+ len)
+ most-positive-fixnum (1+ most-positive-fixnum)
+ (* 2 most-positive-fixnum)
+ (* most-positive-fixnum most-positive-fixnum)
+ (ash 1 12345)))
+ (let ((a (nthcdr n cycle))
+ (b (if (<= n 0) cycle (nthcdr (mod n len) cycle))))
+ (should (equal (list (eq a b) n len)
+ (list t n len))))))))
+
+(ert-deftest test-proper-list-p ()
+ "Test `proper-list-p' behavior."
+ (dotimes (length 4)
+ ;; Proper and dotted lists.
+ (let ((list (make-list length 0)))
+ (should (= (proper-list-p list) length))
+ (should (not (proper-list-p (nconc list 0)))))
+ ;; Circular lists.
+ (dotimes (n (1+ length))
+ (let ((circle (make-list (1+ length) 0)))
+ (should (not (proper-list-p (nconc circle (nthcdr n circle))))))))
+ ;; Atoms.
+ (should (not (proper-list-p 0)))
+ (should (not (proper-list-p "")))
+ (should (not (proper-list-p [])))
+ (should (not (proper-list-p (make-bool-vector 0 nil))))
+ (should (not (proper-list-p (make-symbol "a")))))
+
(provide 'fns-tests)
diff --git a/test/src/json-tests.el b/test/src/json-tests.el
new file mode 100644
index 00000000000..04f91f4abbc
--- /dev/null
+++ b/test/src/json-tests.el
@@ -0,0 +1,291 @@
+;;; json-tests.el --- unit tests for json.c -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017-2019 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Unit tests for src/json.c.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'map)
+
+(declare-function json-serialize "json.c" (object &rest args))
+(declare-function json-insert "json.c" (object &rest args))
+(declare-function json-parse-string "json.c" (string &rest args))
+(declare-function json-parse-buffer "json.c" (&rest args))
+
+(define-error 'json-tests--error "JSON test error")
+
+(ert-deftest json-serialize/roundtrip ()
+ (skip-unless (fboundp 'json-serialize))
+ ;; The noncharacter U+FFFF should be passed through,
+ ;; cf. https://www.unicode.org/faq/private_use.html#noncharacters.
+ (let ((lisp [:null :false t 0 123 -456 3.75 "abc\uFFFFαβγ𝔸𝐁𝖢\"\\"])
+ (json "[null,false,true,0,123,-456,3.75,\"abc\uFFFFαβγ𝔸𝐁𝖢\\\"\\\\\"]"))
+ (should (equal (json-serialize lisp) json))
+ (with-temp-buffer
+ (json-insert lisp)
+ (should (equal (buffer-string) json))
+ (should (eobp)))
+ (should (equal (json-parse-string json) lisp))
+ (with-temp-buffer
+ (insert json)
+ (goto-char 1)
+ (should (equal (json-parse-buffer) lisp))
+ (should (eobp)))))
+
+(ert-deftest json-serialize/object ()
+ (skip-unless (fboundp 'json-serialize))
+ (let ((table (make-hash-table :test #'equal)))
+ (puthash "abc" [1 2 t] table)
+ (puthash "def" :null table)
+ (should (equal (json-serialize table)
+ "{\"abc\":[1,2,true],\"def\":null}")))
+ (should (equal (json-serialize '((abc . [1 2 t]) (def . :null)))
+ "{\"abc\":[1,2,true],\"def\":null}"))
+ (should (equal (json-serialize nil) "{}"))
+ (should (equal (json-serialize '((abc))) "{\"abc\":{}}"))
+ (should (equal (json-serialize '((a . 1) (b . 2) (a . 3)))
+ "{\"a\":1,\"b\":2}"))
+ (should-error (json-serialize '(abc)) :type 'wrong-type-argument)
+ (should-error (json-serialize '((a 1))) :type 'wrong-type-argument)
+ (should-error (json-serialize '((1 . 2))) :type 'wrong-type-argument)
+ (should-error (json-serialize '((a . 1) . b)) :type 'wrong-type-argument)
+ (should-error (json-serialize '#1=((a . 1) . #1#)) :type 'circular-list)
+ (should-error (json-serialize '(#1=(a #1#))))
+
+ (should (equal (json-serialize '(:abc [1 2 t] :def :null))
+ "{\"abc\":[1,2,true],\"def\":null}"))
+ (should (equal (json-serialize '(abc [1 2 t] :def :null))
+ "{\"abc\":[1,2,true],\"def\":null}"))
+ (should-error (json-serialize '#1=(:a 1 . #1#)) :type 'circular-list)
+ (should-error (json-serialize '#1=(:a 1 :b . #1#)) :type 'circular-list)
+ (should-error (json-serialize '(:foo "bar" (unexpected-alist-key . 1)))
+ :type 'wrong-type-argument)
+ (should-error (json-serialize '((abc . "abc") :unexpected-plist-key "key"))
+ :type 'wrong-type-argument)
+ (should-error (json-serialize '(:foo bar :odd-numbered))
+ :type 'wrong-type-argument)
+ (should (equal
+ (json-serialize
+ (list :detect-hash-table #s(hash-table test equal data ("bla" "ble"))
+ :detect-alist '((bla . "ble"))
+ :detect-plist '(:bla "ble")))
+ "\
+{\
+\"detect-hash-table\":{\"bla\":\"ble\"},\
+\"detect-alist\":{\"bla\":\"ble\"},\
+\"detect-plist\":{\"bla\":\"ble\"}\
+}")))
+
+(ert-deftest json-serialize/object-with-duplicate-keys ()
+ (skip-unless (fboundp 'json-serialize))
+ (let ((table (make-hash-table :test #'eq)))
+ (puthash (copy-sequence "abc") [1 2 t] table)
+ (puthash (copy-sequence "abc") :null table)
+ (should (equal (hash-table-count table) 2))
+ (should-error (json-serialize table) :type 'wrong-type-argument)))
+
+(ert-deftest json-parse-string/object ()
+ (skip-unless (fboundp 'json-parse-string))
+ (let ((input
+ "{ \"abc\" : [1, 2, true], \"def\" : null, \"abc\" : [9, false] }\n"))
+ (let ((actual (json-parse-string input)))
+ (should (hash-table-p actual))
+ (should (equal (hash-table-count actual) 2))
+ (should (equal (cl-sort (map-pairs actual) #'string< :key #'car)
+ '(("abc" . [9 :false]) ("def" . :null)))))
+ (should (equal (json-parse-string input :object-type 'alist)
+ '((abc . [9 :false]) (def . :null))))
+ (should (equal (json-parse-string input :object-type 'plist)
+ '(:abc [9 :false] :def :null)))))
+
+(ert-deftest json-parse-string/string ()
+ (skip-unless (fboundp 'json-parse-string))
+ (should-error (json-parse-string "[\"formfeed\f\"]") :type 'json-parse-error)
+ (should (equal (json-parse-string "[\"foo \\\"bar\\\"\"]") ["foo \"bar\""]))
+ (should (equal (json-parse-string "[\"abcαβγ\"]") ["abcαβγ"]))
+ (should (equal (json-parse-string "[\"\\nasd\\u0444\\u044b\\u0432fgh\\t\"]")
+ ["\nasdфывfgh\t"]))
+ (should (equal (json-parse-string "[\"\\uD834\\uDD1E\"]") ["\U0001D11E"]))
+ (should-error (json-parse-string "foo") :type 'json-parse-error)
+ ;; FIXME: Is this the right behavior?
+ (should (equal (json-parse-string "[\"\u00C4\xC3\x84\"]") ["\u00C4\u00C4"])))
+
+(ert-deftest json-serialize/string ()
+ (skip-unless (fboundp 'json-serialize))
+ (should (equal (json-serialize ["foo"]) "[\"foo\"]"))
+ (should (equal (json-serialize ["a\n\fb"]) "[\"a\\n\\fb\"]"))
+ (should (equal (json-serialize ["\nasdфыв\u001f\u007ffgh\t"])
+ "[\"\\nasdфыв\\u001F\u007ffgh\\t\"]"))
+ (should (equal (json-serialize ["a\0b"]) "[\"a\\u0000b\"]"))
+ ;; FIXME: Is this the right behavior?
+ (should (equal (json-serialize ["\u00C4\xC3\x84"]) "[\"\u00C4\u00C4\"]")))
+
+(ert-deftest json-serialize/invalid-unicode ()
+ (skip-unless (fboundp 'json-serialize))
+ (should-error (json-serialize ["a\uDBBBb"]) :type 'wrong-type-argument)
+ (should-error (json-serialize ["u\x110000v"]) :type 'wrong-type-argument)
+ (should-error (json-serialize ["u\x3FFFFFv"]) :type 'wrong-type-argument)
+ (should-error (json-serialize ["u\xCCv"]) :type 'wrong-type-argument)
+ (should-error (json-serialize ["u\u00C4\xCCv"]) :type 'wrong-type-argument))
+
+(ert-deftest json-parse-string/null ()
+ (skip-unless (fboundp 'json-parse-string))
+ (should-error (json-parse-string "\x00") :type 'wrong-type-argument)
+ ;; FIXME: Reconsider whether this is the right behavior.
+ (should-error (json-parse-string "[a\\u0000b]") :type 'json-parse-error))
+
+(ert-deftest json-parse-string/invalid-unicode ()
+ "Some examples from
+https://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt.
+Test with both unibyte and multibyte strings."
+ (skip-unless (fboundp 'json-parse-string))
+ ;; Invalid UTF-8 code unit sequences.
+ (should-error (json-parse-string "[\"\x80\"]") :type 'json-parse-error)
+ (should-error (json-parse-string "[\"\u00C4\x80\"]") :type 'json-parse-error)
+ (should-error (json-parse-string "[\"\xBF\"]") :type 'json-parse-error)
+ (should-error (json-parse-string "[\"\u00C4\xBF\"]") :type 'json-parse-error)
+ (should-error (json-parse-string "[\"\xFE\"]") :type 'json-parse-error)
+ (should-error (json-parse-string "[\"\u00C4\xFE\"]") :type 'json-parse-error)
+ (should-error (json-parse-string "[\"\xC0\xAF\"]") :type 'json-parse-error)
+ (should-error (json-parse-string "[\"\u00C4\xC0\xAF\"]")
+ :type 'json-parse-error)
+ (should-error (json-parse-string "[\"\u00C4\xC0\x80\"]")
+ :type 'json-parse-error)
+ ;; Surrogates.
+ (should-error (json-parse-string "[\"\uDB7F\"]")
+ :type 'json-parse-error)
+ (should-error (json-parse-string "[\"\xED\xAD\xBF\"]")
+ :type 'json-parse-error)
+ (should-error (json-parse-string "[\"\u00C4\xED\xAD\xBF\"]")
+ :type 'json-parse-error)
+ (should-error (json-parse-string "[\"\uDB7F\uDFFF\"]")
+ :type 'json-parse-error)
+ (should-error (json-parse-string "[\"\xED\xAD\xBF\xED\xBF\xBF\"]")
+ :type 'json-parse-error)
+ (should-error (json-parse-string "[\"\u00C4\xED\xAD\xBF\xED\xBF\xBF\"]")
+ :type 'json-parse-error))
+
+(ert-deftest json-parse-string/incomplete ()
+ (skip-unless (fboundp 'json-parse-string))
+ (should-error (json-parse-string "[123") :type 'json-end-of-file))
+
+(ert-deftest json-parse-string/trailing ()
+ (skip-unless (fboundp 'json-parse-string))
+ (should-error (json-parse-string "[123] [456]") :type 'json-trailing-content))
+
+(ert-deftest json-parse-buffer/incomplete ()
+ (skip-unless (fboundp 'json-parse-buffer))
+ (with-temp-buffer
+ (insert "[123")
+ (goto-char 1)
+ (should-error (json-parse-buffer) :type 'json-end-of-file)
+ (should (bobp))))
+
+(ert-deftest json-parse-buffer/trailing ()
+ (skip-unless (fboundp 'json-parse-buffer))
+ (with-temp-buffer
+ (insert "[123] [456]")
+ (goto-char 1)
+ (should (equal (json-parse-buffer) [123]))
+ (should-not (bobp))
+ (should (looking-at-p (rx " [456]" eos)))))
+
+(ert-deftest json-parse-with-custom-null-and-false-objects ()
+ (skip-unless (and (fboundp 'json-serialize)
+ (fboundp 'json-parse-string)))
+ (let* ((input
+ "{ \"abc\" : [9, false] , \"def\" : null }")
+ (output
+ (replace-regexp-in-string " " "" input)))
+ (should (equal (json-parse-string input
+ :object-type 'plist
+ :null-object :json-null
+ :false-object :json-false)
+ '(:abc [9 :json-false] :def :json-null)))
+ (should (equal (json-parse-string input
+ :object-type 'plist
+ :false-object :json-false)
+ '(:abc [9 :json-false] :def :null)))
+ (should (equal (json-parse-string input
+ :object-type 'alist
+ :null-object :zilch)
+ '((abc . [9 :false]) (def . :zilch))))
+ (should (equal (json-parse-string input
+ :object-type 'alist
+ :false-object nil
+ :null-object nil)
+ '((abc . [9 nil]) (def))))
+ (let* ((thingy '(1 2 3))
+ (retval (json-parse-string input
+ :object-type 'alist
+ :false-object thingy
+ :null-object nil)))
+ (should (equal retval `((abc . [9 ,thingy]) (def))))
+ (should (eq (elt (cdr (car retval)) 1) thingy)))
+ (should (equal output
+ (json-serialize '((abc . [9 :myfalse]) (def . :mynull))
+ :false-object :myfalse
+ :null-object :mynull)))
+ ;; :object-type is not allowed in json-serialize
+ (should-error (json-serialize '() :object-type 'alist))))
+
+(ert-deftest json-insert/signal ()
+ (skip-unless (fboundp 'json-insert))
+ (with-temp-buffer
+ (let ((calls 0))
+ (add-hook 'after-change-functions
+ (lambda (_begin _end _length)
+ (cl-incf calls)
+ (signal 'json-tests--error
+ '("Error in `after-change-functions'")))
+ :local)
+ (should-error
+ (json-insert '((a . "b") (c . 123) (d . [1 2 t :false])))
+ :type 'json-tests--error)
+ (should (equal calls 1)))))
+
+(ert-deftest json-insert/throw ()
+ (skip-unless (fboundp 'json-insert))
+ (with-temp-buffer
+ (let ((calls 0))
+ (add-hook 'after-change-functions
+ (lambda (_begin _end _length)
+ (cl-incf calls)
+ (throw 'test-tag 'throw-value))
+ :local)
+ (should
+ (equal
+ (catch 'test-tag
+ (json-insert '((a . "b") (c . 123) (d . [1 2 t :false]))))
+ 'throw-value))
+ (should (equal calls 1)))))
+
+(ert-deftest json-serialize/bignum ()
+ (skip-unless (fboundp 'json-serialize))
+ (should (equal (json-serialize (vector (1+ most-positive-fixnum)
+ (1- most-negative-fixnum)))
+ (format "[%d,%d]"
+ (1+ most-positive-fixnum)
+ (1- most-negative-fixnum)))))
+
+(provide 'json-tests)
+;;; json-tests.el ends here
diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el
index b92dfc18c5c..ae918f03120 100644
--- a/test/src/lread-tests.el
+++ b/test/src/lread-tests.el
@@ -142,6 +142,23 @@ literals (Bug#20852)."
"unescaped character literals "
"`?\"', `?(', `?)', `?;', `?[', `?]' detected!")))))
+(ert-deftest lread-tests--funny-quote-symbols ()
+ "Check that 'smart quotes' or similar trigger errors in symbol names."
+ (dolist (quote-char
+ '(#x2018 ;; LEFT SINGLE QUOTATION MARK
+ #x2019 ;; RIGHT SINGLE QUOTATION MARK
+ #x201B ;; SINGLE HIGH-REVERSED-9 QUOTATION MARK
+ #x201C ;; LEFT DOUBLE QUOTATION MARK
+ #x201D ;; RIGHT DOUBLE QUOTATION MARK
+ #x201F ;; DOUBLE HIGH-REVERSED-9 QUOTATION MARK
+ #x301E ;; DOUBLE PRIME QUOTATION MARK
+ #xFF02 ;; FULLWIDTH QUOTATION MARK
+ #xFF07 ;; FULLWIDTH APOSTROPHE
+ ))
+ (let ((str (format "%cfoo" quote-char)))
+ (should-error (read str) :type 'invalid-read-syntax)
+ (should (eq (read (concat "\\" str)) (intern str))))))
+
(ert-deftest lread-test-bug26837 ()
"Test for https://debbugs.gnu.org/26837 ."
(let ((load-path (cons
@@ -156,13 +173,20 @@ literals (Bug#20852)."
(should (string-suffix-p "/somelib.el" (caar load-history)))))
(ert-deftest lread-tests--old-style-backquotes ()
- "Check that loading warns about old-style backquotes."
+ "Check that loading doesn't accept old-style backquotes."
(lread-tests--with-temp-file file-name
(write-region "(` (a b))" nil file-name)
- (should (equal (load file-name nil :nomessage :nosuffix) t))
- (should (equal (lread-tests--last-message)
- (concat (format-message "Loading `%s': " file-name)
- "old-style backquotes detected!")))))
+ (let ((data (should-error (load file-name nil :nomessage :nosuffix))))
+ (should (equal (cdr data)
+ (list (concat (format-message "Loading `%s': " file-name)
+ "old-style backquotes detected!")))))))
+
+(ert-deftest lread-tests--force-new-style-backquotes ()
+ (let ((data (should-error (read "(` (a b))"))))
+ (should (equal (cdr data) '("Old-style backquotes detected!"))))
+ (should (equal (let ((force-new-style-backquotes t))
+ (read "(` (a b))"))
+ '(`(a b)))))
(ert-deftest lread-lread--substitute-object-in-subtree ()
(let ((x (cons 0 1)))
@@ -170,6 +194,9 @@ literals (Bug#20852)."
(lread--substitute-object-in-subtree x 1 t)
(should (eq x (cdr x)))))
+(ert-deftest lread-long-hex-integer ()
+ (should (bignump (read "#xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"))))
+
(ert-deftest lread-test-bug-31186 ()
(with-temp-buffer
(insert ";; -*- -:*-")
@@ -178,4 +205,17 @@ literals (Bug#20852)."
;; bug was fixed.
(eval-buffer))))
+(ert-deftest lread-invalid-bytecodes ()
+ (should-error
+ (let ((load-force-doc-strings t)) (read "#[0 \"\"]"))))
+
+(ert-deftest lread-string-to-number-trailing-dot ()
+ (dolist (n (list (* most-negative-fixnum most-negative-fixnum)
+ (1- most-negative-fixnum) most-negative-fixnum
+ (1+ most-negative-fixnum) -1 0 1
+ (1- most-positive-fixnum) most-positive-fixnum
+ (1+ most-positive-fixnum)
+ (* most-positive-fixnum most-positive-fixnum)))
+ (should (= n (string-to-number (format "%d." n))))))
+
;;; lread-tests.el ends here
diff --git a/test/src/print-tests.el b/test/src/print-tests.el
index bb98443bbe2..8e377d71808 100644
--- a/test/src/print-tests.el
+++ b/test/src/print-tests.el
@@ -27,6 +27,42 @@
(prin1-to-string "\u00A2\ff"))
"\"\\x00a2\\ff\"")))
+(defun print-tests--prints-with-charset-p (ch odd-charset)
+ "Return t if `prin1-to-string' prints CH with the `charset' property.
+CH is propertized with a `charset' value according to
+ODD-CHARSET: if nil, then use the one returned by `char-charset',
+otherwise, use a different charset."
+ (integerp
+ (string-match
+ "charset"
+ (prin1-to-string
+ (propertize (string ch)
+ 'charset
+ (if odd-charset
+ (cl-find (char-charset ch) charset-list :test-not #'eq)
+ (char-charset ch)))))))
+
+(ert-deftest print-charset-text-property-nil ()
+ (let ((print-charset-text-property nil))
+ (should-not (print-tests--prints-with-charset-p ?\xf6 t)) ; Bug#31376.
+ (should-not (print-tests--prints-with-charset-p ?a t))
+ (should-not (print-tests--prints-with-charset-p ?\xf6 nil))
+ (should-not (print-tests--prints-with-charset-p ?a nil))))
+
+(ert-deftest print-charset-text-property-default ()
+ (let ((print-charset-text-property 'default))
+ (should (print-tests--prints-with-charset-p ?\xf6 t))
+ (should-not (print-tests--prints-with-charset-p ?a t))
+ (should-not (print-tests--prints-with-charset-p ?\xf6 nil))
+ (should-not (print-tests--prints-with-charset-p ?a nil))))
+
+(ert-deftest print-charset-text-property-t ()
+ (let ((print-charset-text-property t))
+ (should (print-tests--prints-with-charset-p ?\xf6 t))
+ (should (print-tests--prints-with-charset-p ?a t))
+ (should (print-tests--prints-with-charset-p ?\xf6 nil))
+ (should (print-tests--prints-with-charset-p ?a nil))))
+
(ert-deftest terpri ()
(should (string= (with-output-to-string
(princ 'abc)
@@ -58,5 +94,27 @@
(buffer-string))
"--------\n"))))
+(ert-deftest print-read-roundtrip ()
+ (let ((syms (list '## '& '* '+ '- '/ '0E '0e '< '= '> 'E 'E0 'NaN '\"
+ '\# '\#x0 '\' '\'\' '\( '\) '\+00 '\, '\-0 '\. '\.0
+ '\0 '\0.0 '\0E0 '\0e0 '\1E+ '\1E+NaN '\1e+ '\1e+NaN
+ '\; '\? '\[ '\\ '\] '\` '_ 'a 'e 'e0 'x
+ '{ '| '} '~ : '\’ '\’bar
+ (intern "\t") (intern "\n") (intern " ")
+ (intern "\N{NO-BREAK SPACE}")
+ (intern "\N{ZERO WIDTH SPACE}")
+ (intern "\0"))))
+ (dolist (sym syms)
+ (should (eq (read (prin1-to-string sym)) sym))
+ (dolist (sym1 syms)
+ (let ((sym2 (intern (concat (symbol-name sym) (symbol-name sym1)))))
+ (should (eq (read (prin1-to-string sym2)) sym2)))))))
+
+(ert-deftest print-bignum ()
+ (let* ((str "999999999999999999999999999999999")
+ (val (read str)))
+ (should (> val most-positive-fixnum))
+ (should (equal (prin1-to-string val) str))))
+
(provide 'print-tests)
;;; print-tests.el ends here
diff --git a/test/src/process-tests.el b/test/src/process-tests.el
index 7cccc5a02cb..5dbf441e8c2 100644
--- a/test/src/process-tests.el
+++ b/test/src/process-tests.el
@@ -181,5 +181,88 @@
(should-not (process-query-on-exit-flag process))))
(kill-process process)))))
+;; Return t if OUTPUT could have been generated by merging the INPUTS somehow.
+(defun process-tests--mixable (output &rest inputs)
+ (while (and output (let ((ins inputs))
+ (while (and ins (not (eq (car (car ins)) (car output))))
+ (setq ins (cdr ins)))
+ (if ins
+ (setcar ins (cdr (car ins))))
+ ins))
+ (setq output (cdr output)))
+ (not (apply #'append output inputs)))
+
+(ert-deftest make-process/mix-stderr ()
+ "Check that `make-process' mixes the output streams if STDERR is nil."
+ (skip-unless (executable-find "bash"))
+ ;; Frequent random (?) failures on hydra.nixos.org, with no process output.
+ ;; Maybe this test should be tagged unstable? See bug#31214.
+ (skip-unless (not (getenv "EMACS_HYDRA_CI")))
+ (with-temp-buffer
+ (let ((process (make-process
+ :name "mix-stderr"
+ :command (list "bash" "-c"
+ "echo stdout && echo stderr >&2")
+ :buffer (current-buffer)
+ :sentinel #'ignore
+ :noquery t
+ :connection-type 'pipe)))
+ (while (or (accept-process-output process)
+ (process-live-p process)))
+ (should (eq (process-status process) 'exit))
+ (should (eq (process-exit-status process) 0))
+ (should (process-tests--mixable (string-to-list (buffer-string))
+ (string-to-list "stdout\n")
+ (string-to-list "stderr\n"))))))
+
+(ert-deftest make-process/file-handler/found ()
+ "Check that the ‘:file-handler’ argument of ‘make-process’
+works as expected if a file name handler is found."
+ (let ((file-handler-calls 0))
+ (cl-flet ((file-handler
+ (&rest args)
+ (should (equal default-directory "test-handler:/dir/"))
+ (should (equal args '(make-process :name "name"
+ :command ("/some/binary")
+ :file-handler t)))
+ (cl-incf file-handler-calls)
+ 'fake-process))
+ (let ((file-name-handler-alist (list (cons (rx bos "test-handler:")
+ #'file-handler)))
+ (default-directory "test-handler:/dir/"))
+ (should (eq (make-process :name "name"
+ :command '("/some/binary")
+ :file-handler t)
+ 'fake-process))
+ (should (= file-handler-calls 1))))))
+
+(ert-deftest make-process/file-handler/not-found ()
+ "Check that the ‘:file-handler’ argument of ‘make-process’
+works as expected if no file name handler is found."
+ (let ((file-name-handler-alist ())
+ (default-directory invocation-directory)
+ (program (expand-file-name invocation-name invocation-directory)))
+ (should (processp (make-process :name "name"
+ :command (list program "--version")
+ :file-handler t)))))
+
+(ert-deftest make-process/file-handler/disable ()
+ "Check ‘make-process’ works as expected if it shouldn’t use the
+file name handler."
+ (let ((file-name-handler-alist (list (cons (rx bos "test-handler:")
+ #'process-tests--file-handler)))
+ (default-directory "test-handler:/dir/")
+ (program (expand-file-name invocation-name invocation-directory)))
+ (should (processp (make-process :name "name"
+ :command (list program "--version"))))))
+
+(defun process-tests--file-handler (operation &rest _args)
+ (cl-ecase operation
+ (unhandled-file-name-directory "/")
+ (make-process (ert-fail "file name handler called unexpectedly"))))
+
+(put #'process-tests--file-handler 'operations
+ '(unhandled-file-name-directory make-process))
+
(provide 'process-tests)
;; process-tests.el ends here.
diff --git a/test/src/regex-tests.el b/test/src/regex-emacs-tests.el
index 26469c304db..0ae50c94d4c 100644
--- a/test/src/regex-tests.el
+++ b/test/src/regex-emacs-tests.el
@@ -1,4 +1,4 @@
-;;; regex-tests.el --- tests for regex.c functions -*- lexical-binding: t -*-
+;;; regex-emacs-tests.el --- tests for regex-emacs.c -*- lexical-binding: t -*-
;; Copyright (C) 2015-2019 Free Software Foundation, Inc.
@@ -24,7 +24,7 @@
(defvar regex-tests--resources-dir
(concat (concat (file-name-directory (or load-file-name buffer-file-name))
"/regex-resources/"))
- "Path to regex-resources directory next to the \"regex-tests.el\" file.")
+ "Path to regex-resources directory next to the \"regex-emacs-tests.el\" file.")
(ert-deftest regex-word-cc-fallback-test ()
"Test that \"[[:cc:]]*x\" matches \"x\" (bug#24020).
@@ -278,7 +278,7 @@ on success"
(defconst regex-tests-re-even-escapes
- "\\(?:^\\|[^\\\\]\\)\\(?:\\\\\\\\\\)*"
+ "\\(?:^\\|[^\\]\\)\\(?:\\\\\\\\\\)*"
"Regex that matches an even number of \\ characters")
(defconst regex-tests-re-odd-escapes
@@ -555,11 +555,11 @@ differences in behavior.")
(defconst regex-tests-PTESTS-whitelist
[
- ;; emacs doesn't barf on weird ranges such as [b-a], but simply
- ;; fails to match
+ ;; emacs doesn't see DEL (0x7f) as a [:cntrl:] character
138
- ;; emacs doesn't see DEL (0x78) as a [:cntrl:] character
+ ;; emacs doesn't barf on weird ranges such as [b-a], but simply
+ ;; fails to match
168
]
"Line numbers in the PTESTS test that should be skipped. These
@@ -677,4 +677,10 @@ This evaluates the PTESTS test cases from glibc."
This evaluates the TESTS test cases from glibc."
(should-not (regex-tests-TESTS)))
-;;; regex-tests.el ends here
+(ert-deftest regex-repeat-limit ()
+ "Test the #xFFFF repeat limit."
+ (should (string-match "\\`x\\{65535\\}" (make-string 65535 ?x)))
+ (should-not (string-match "\\`x\\{65535\\}" (make-string 65534 ?x)))
+ (should-error (string-match "\\`x\\{65536\\}" "X") :type 'invalid-regexp))
+
+;;; regex-emacs-tests.el ends here
diff --git a/test/src/thread-tests.el b/test/src/thread-tests.el
index e8d66b87db3..5e5bfd155fb 100644
--- a/test/src/thread-tests.el
+++ b/test/src/thread-tests.el
@@ -19,6 +19,8 @@
;;; Code:
+(require 'thread)
+
;; Declare the functions in case Emacs has been configured --without-threads.
(declare-function all-threads "thread.c" ())
(declare-function condition-mutex "thread.c" (cond))
@@ -34,10 +36,11 @@
(declare-function thread--blocker "thread.c" (thread))
(declare-function thread-live-p "thread.c" (thread))
(declare-function thread-join "thread.c" (thread))
-(declare-function thread-last-error "thread.c" ())
+(declare-function thread-last-error "thread.c" (&optional cleanup))
(declare-function thread-name "thread.c" (thread))
(declare-function thread-signal "thread.c" (thread error-symbol data))
(declare-function thread-yield "thread.c" ())
+(defvar main-thread)
(ert-deftest threads-is-one ()
"Test for existence of a thread."
@@ -71,6 +74,11 @@
(skip-unless (featurep 'threads))
(should (listp (all-threads))))
+(ert-deftest threads-main-thread ()
+ "Simple test for all-threads."
+ (skip-unless (featurep 'threads))
+ (should (eq main-thread (car (all-threads)))))
+
(defvar threads-test-global nil)
(defun threads-test-thread1 ()
@@ -94,15 +102,24 @@
(progn
(setq threads-test-global nil)
(let ((thread (make-thread #'threads-test-thread1)))
- (thread-join thread)
- (and threads-test-global
- (not (thread-live-p thread)))))))
+ (and (= (thread-join thread) 23)
+ (= threads-test-global 23)
+ (not (thread-live-p thread)))))))
(ert-deftest threads-join-self ()
"Cannot `thread-join' the current thread."
(skip-unless (featurep 'threads))
(should-error (thread-join (current-thread))))
+(ert-deftest threads-join-error ()
+ "Test of error signalling from `thread-join'."
+ :tags '(:unstable)
+ (skip-unless (featurep 'threads))
+ (let ((thread (make-thread #'threads-call-error)))
+ (while (thread-live-p thread)
+ (thread-yield))
+ (should-error (thread-join thread))))
+
(defvar threads-test-binding nil)
(defun threads-test-thread2 ()
@@ -191,7 +208,7 @@
(ert-deftest threads-mutex-signal ()
"Test signaling a blocked thread."
(skip-unless (featurep 'threads))
- (should
+ (should-error
(progn
(setq threads-mutex (make-mutex))
(setq threads-mutex-key nil)
@@ -200,8 +217,10 @@
(while (not threads-mutex-key)
(thread-yield))
(thread-signal thr 'quit nil)
- (thread-join thr))
- t)))
+ ;; `quit' is not catched by `should-error'. We must indicate it.
+ (condition-case nil
+ (thread-join thr)
+ (quit (signal 'error nil)))))))
(defun threads-test-io-switch ()
(setq threads-test-global 23))
@@ -275,6 +294,9 @@
(thread-yield))
(should (equal (thread-last-error)
'(error "Error is called")))
+ (should (equal (thread-last-error 'cleanup)
+ '(error "Error is called")))
+ (should-not (thread-last-error))
(setq th2 (make-thread #'threads-custom "threads-custom"))
(should (threadp th2))))
@@ -300,6 +322,25 @@
(should-not (thread-live-p thread))
(should (equal (thread-last-error) '(error)))))
+(ert-deftest threads-signal-main-thread ()
+ "Test signaling the main thread."
+ (skip-unless (featurep 'threads))
+ ;; We cannot use `ert-with-message-capture', because threads do not
+ ;; know let-bound variables.
+ (with-current-buffer "*Messages*"
+ (let (buffer-read-only)
+ (erase-buffer))
+ (let ((thread
+ (make-thread #'(lambda () (thread-signal main-thread 'error nil)))))
+ (while (thread-live-p thread)
+ (thread-yield))
+ (read-event nil nil 0.1)
+ ;; No error has been raised, which is part of the test.
+ (should
+ (string-match
+ (format-message "Error %s: (error nil)" thread)
+ (buffer-string ))))))
+
(defvar threads-condvar nil)
(defun threads-test-condvar-wait ()
@@ -347,4 +388,8 @@
(should (= (length (all-threads)) 1))
(should (equal (thread-last-error) '(error "Die, die, die!")))))
+(ert-deftest threads-test-bug33073 ()
+ (let ((th (make-thread 'ignore)))
+ (should-not (equal th main-thread))))
+
;;; threads.el ends here
diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el
new file mode 100644
index 00000000000..5c858ef3bd8
--- /dev/null
+++ b/test/src/timefns-tests.el
@@ -0,0 +1,144 @@
+;;; timefns-tests.el -- tests for timefns.c
+
+;; Copyright (C) 2016-2019 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+(require 'ert)
+
+;;; Check format-time-string and decode-time with various TZ settings.
+;;; Use only POSIX-compatible TZ values, since the tests should work
+;;; even if tzdb is not in use.
+(ert-deftest format-time-string-with-zone ()
+ ;; Don’t use (0 0 0 0) as the test case, as there are too many bugs
+ ;; in MS-Windows (and presumably other) C libraries when formatting
+ ;; time stamps near the Epoch of 1970-01-01 00:00:00 UTC, and this
+ ;; test is for GNU Emacs, not for C runtimes. Instead, look before
+ ;; you leap: "look" is the timestamp just before the first leap
+ ;; second on 1972-06-30 23:59:60 UTC, so it should format to the
+ ;; same string regardless of whether the underlying C library
+ ;; ignores leap seconds, while avoiding circa-1970 glitches.
+ ;;
+ ;; Similarly, stick to the limited set of time zones that are
+ ;; supported by both POSIX and MS-Windows: exactly 3 ASCII letters
+ ;; in the abbreviation, and no DST.
+ (let ((format "%Y-%m-%d %H:%M:%S.%3N %z (%Z)"))
+ (dolist (look '((1202 22527 999999 999999)
+ (7879679999900 . 100000)
+ (78796799999999999999 . 1000000000000)))
+ ;; UTC.
+ (should (string-equal
+ (format-time-string "%Y-%m-%d %H:%M:%S.%3N %z" look t)
+ "1972-06-30 23:59:59.999 +0000"))
+ (should (equal (decode-time look t)
+ '(59 59 23 30 6 1972 5 nil 0)))
+ ;; "UTC0".
+ (should (string-equal
+ (format-time-string format look "UTC0")
+ "1972-06-30 23:59:59.999 +0000 (UTC)"))
+ (should (equal (decode-time look "UTC0")
+ '(59 59 23 30 6 1972 5 nil 0)))
+ ;; Negative UTC offset, as a Lisp list.
+ (should (string-equal
+ (format-time-string format look '(-28800 "PST"))
+ "1972-06-30 15:59:59.999 -0800 (PST)"))
+ (should (equal (decode-time look '(-28800 "PST"))
+ '(59 59 15 30 6 1972 5 nil -28800)))
+ ;; Negative UTC offset, as a Lisp integer.
+ (should (string-equal
+ (format-time-string format look -28800)
+ ;; MS-Windows build replaces unrecognizable TZ values,
+ ;; such as "-08", with "ZZZ".
+ (if (eq system-type 'windows-nt)
+ "1972-06-30 15:59:59.999 -0800 (ZZZ)"
+ "1972-06-30 15:59:59.999 -0800 (-08)")))
+ (should (equal (decode-time look -28800)
+ '(59 59 15 30 6 1972 5 nil -28800)))
+ ;; Positive UTC offset that is not an hour multiple, as a string.
+ (should (string-equal
+ (format-time-string format look "IST-5:30")
+ "1972-07-01 05:29:59.999 +0530 (IST)"))
+ (should (equal (decode-time look "IST-5:30")
+ '(59 29 5 1 7 1972 6 nil 19800))))))
+
+(ert-deftest decode-then-encode-time ()
+ (let ((time-values (list 0 -2 1 0.0 -0.0 -2.0 1.0
+ most-negative-fixnum most-positive-fixnum
+ (1- most-negative-fixnum)
+ (1+ most-positive-fixnum)
+ 1e+INF -1e+INF 1e+NaN -1e+NaN
+ '(0 1 0 0) '(1 0 0 0) '(-1 0 0 0)
+ '(123456789000000 . 1000000)
+ (cons (1+ most-positive-fixnum) 1000000000000)
+ (cons 1000000000000 (1+ most-positive-fixnum)))))
+ (dolist (a time-values)
+ (let* ((d (ignore-errors (decode-time a t)))
+ (e (encode-time d))
+ (diff (float-time (time-subtract a e))))
+ (should (or (not d)
+ (and (<= 0 diff) (< diff 1))))))))
+
+;;; This should not dump core.
+(ert-deftest format-time-string-with-outlandish-zone ()
+ (should (stringp
+ (format-time-string "%Y-%m-%d %H:%M:%S.%3N %z" nil
+ (concat (make-string 2048 ?X) "0")))))
+
+(defun timefns-tests--have-leap-seconds ()
+ (string-equal (format-time-string "%Y-%m-%d %H:%M:%S" 78796800 t)
+ "1972-06-30 23:59:60"))
+
+(ert-deftest format-time-string-with-bignum-on-32-bit ()
+ (should (or (string-equal
+ (format-time-string "%Y-%m-%d %H:%M:%S" (- (ash 1 31) 3600) t)
+ "2038-01-19 02:14:08")
+ (timefns-tests--have-leap-seconds))))
+
+(ert-deftest time-equal-p-nil-nil ()
+ (should (time-equal-p nil nil)))
+
+(ert-deftest time-arith-tests ()
+ (let ((time-values (list 0 -1 1 0.0 -0.0 -1.0 1.0
+ most-negative-fixnum most-positive-fixnum
+ (1- most-negative-fixnum)
+ (1+ most-positive-fixnum)
+ 1e+INF -1e+INF 1e+NaN -1e+NaN
+ '(0 0 0 1) '(0 0 1 0) '(0 1 0 0) '(1 0 0 0)
+ '(-1 0 0 0) '(1 2 3 4) '(-1 2 3 4)
+ '(-123456789 . 100000) '(123456789 . 1000000)
+ (cons (1+ most-positive-fixnum) 1000000000000)
+ (cons 1000000000000 (1+ most-positive-fixnum)))))
+ (dolist (a time-values)
+ (dolist (b time-values)
+ (let ((aa (time-subtract (time-add a b) b)))
+ (should (or (time-equal-p a aa) (and (floatp aa) (isnan aa)))))
+ (should (= 1 (+ (if (time-less-p a b) 1 0)
+ (if (time-equal-p a b) 1 0)
+ (if (time-less-p b a) 1 0)
+ (if (or (and (floatp a) (isnan a))
+ (and (floatp b) (isnan b)))
+ 1 0))))
+ (should (or (not (time-less-p 0 b))
+ (time-less-p a (time-add a b))
+ (time-equal-p a (time-add a b))
+ (and (floatp (time-add a b)) (isnan (time-add a b)))))
+ (let ((x (float-time (time-add a b)))
+ (y (+ (float-time a) (float-time b))))
+ (should (or (and (isnan x) (isnan y))
+ (= x y)
+ (< 0.99 (/ x y) 1.01)
+ (< 0.99 (/ (- (float-time a)) (float-time b))
+ 1.01))))))))